Imported Upstream version 8.4~betaupstream/8.4_beta

58 files changed, 3118 insertions, 4609 deletions

diff --git a/tactics/auto.ml b/tactics/auto.ml
index 6a9ced3e..93ca89f4 100644
--- a/tactics/auto.ml
+++ b/tactics/auto.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: auto.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Pp
 open Util
 open Names
@@ -27,7 +25,7 @@ open Matching
 open Tacmach
 open Proof_type
 open Pfedit
-open Rawterm
+open Glob_term
 open Evar_refiner
 open Tacred
 open Tactics
@@ -48,23 +46,43 @@ open Mod_subst
 (*            The Type of Constructions Autotactic Hints                    *)
 (****************************************************************************)
 
-type auto_tactic =
-  | Res_pf     of constr * clausenv (* Hint Apply *)
-  | ERes_pf    of constr * clausenv (* Hint EApply *)
+type 'a auto_tactic =
+  | Res_pf     of constr * 'a (* Hint Apply *)
+  | ERes_pf    of constr * 'a (* Hint EApply *)
   | Give_exact of constr
-  | Res_pf_THEN_trivial_fail of constr * clausenv (* Hint Immediate *)
+  | Res_pf_THEN_trivial_fail of constr * 'a (* Hint Immediate *)
   | Unfold_nth of evaluable_global_reference       (* Hint Unfold *)
   | Extern     of glob_tactic_expr       (* Hint Extern *)
 
-type pri_auto_tactic = {
-  pri  : int;            (* A number between 0 and 4, 4 = lower priority *)
+type hints_path_atom = 
+  | PathHints of global_reference list
+  | PathAny
+
+type hints_path =
+  | PathAtom of hints_path_atom
+  | PathStar of hints_path
+  | PathSeq of hints_path * hints_path
+  | PathOr of hints_path * hints_path
+  | PathEmpty
+  | PathEpsilon
+
+type 'a gen_auto_tactic = {
+  pri  : int;            (* A number lower is higher priority *)
   pat  : constr_pattern option; (* A pattern for the concl of the Goal *)
-  code : auto_tactic     (* the tactic to apply when the concl matches pat *)
+  name  : hints_path_atom; (* A potential name to refer to the hint *) 
+  code : 'a auto_tactic     (* the tactic to apply when the concl matches pat *)
 }
 
-type hint_entry = global_reference option * pri_auto_tactic
+type pri_auto_tactic = clausenv gen_auto_tactic
 
-let pri_order {pri=pri1} {pri=pri2} = pri1 <= pri2
+type hint_entry = global_reference option * types gen_auto_tactic
+
+let pri_order_int (id1, {pri=pri1}) (id2, {pri=pri2}) =
+  let d = pri1 - pri2 in
+    if d == 0 then id2 - id1
+    else d
+
+let pri_order t1 t2 = pri_order_int t1 t2 <= 0
 
 let insert v l =
   let rec insrec = function
@@ -74,32 +92,45 @@ let insert v l =
   insrec l
 
 (* Nov 98 -- Papageno *)
-(* Les Hints sont ré-organisés en plusieurs databases.
+(* Les Hints sont ré-organisés en plusieurs databases.
 
-  La table impérative "searchtable", de type "hint_db_table",
-   associe une database (hint_db) à chaque nom.
+  La table impérative "searchtable", de type "hint_db_table",
+   associe une database (hint_db) à chaque nom.
 
   Une hint_db est une table d'association fonctionelle constr -> search_entry
-  Le constr correspond à la constante de tête de la conclusion.
+  Le constr correspond à la constante de tête de la conclusion.
 
   Une search_entry est un triplet comprenant :
-     - la liste des tactiques qui n'ont pas de pattern associé
+     - la liste des tactiques qui n'ont pas de pattern associé
      - la liste des tactiques qui ont un pattern
-     - un discrimination net borné (Btermdn.t) constitué de tous les
+     - un discrimination net borné (Btermdn.t) constitué de tous les
        patterns de la seconde liste de tactiques *)
 
-type stored_data = pri_auto_tactic
+type stored_data = int * pri_auto_tactic
+    (* First component is the index of insertion in the table, to keep most recent first semantics. *)
+
+let auto_tactic_ord code1 code2 =
+  match code1, code2 with
+  | Res_pf (c1, _), Res_pf (c2, _)
+  | ERes_pf (c1, _), ERes_pf (c2, _)
+  | Give_exact c1, Give_exact c2
+  | Res_pf_THEN_trivial_fail (c1, _), Res_pf_THEN_trivial_fail (c2, _) -> constr_ord c1 c2
+  | Unfold_nth (EvalVarRef i1), Unfold_nth (EvalVarRef i2) -> Pervasives.compare i1 i2
+  | Unfold_nth (EvalConstRef c1), Unfold_nth (EvalConstRef c2) ->
+      kn_ord (canonical_con c1) (canonical_con c2)
+  | Extern t1, Extern t2 -> Pervasives.compare t1 t2
+  | _ -> Pervasives.compare code1 code2
 
 module Bounded_net = Btermdn.Make(struct
 				    type t = stored_data
-				    let compare = Pervasives.compare
+				    let compare = pri_order_int
 				  end)
 
 type search_entry = stored_data list * stored_data list * Bounded_net.t
 
 let empty_se = ([],[],Bounded_net.create ())
 
-let eq_pri_auto_tactic x y =
+let eq_pri_auto_tactic (_, x) (_, y) =
   if x.pri = y.pri && x.pat = y.pat then
     match x.code,y.code with
       | Res_pf(cstr,_),Res_pf(cstr1,_) -> 
@@ -118,15 +149,18 @@ let eq_pri_auto_tactic x y =
 let add_tac pat t st (l,l',dn) =
   match pat with
   | None -> if not (List.exists (eq_pri_auto_tactic t) l) then (insert t l, l', dn) else (l, l', dn)
-  | Some pat -> if not (List.exists (eq_pri_auto_tactic t) l') then (l, insert t l', Bounded_net.add st dn (pat,t)) else (l, l', dn)
+  | Some pat -> 
+    if not (List.exists (eq_pri_auto_tactic t) l') 
+    then (l, insert t l', Bounded_net.add st dn (pat,t)) else (l, l', dn)
 
-let rebuild_dn st (l,l',dn) =
-  (l, l', List.fold_left (fun dn t -> Bounded_net.add (Some st) dn (Option.get t.pat, t))
+let rebuild_dn st ((l,l',dn) : search_entry) =
+  (l, l', List.fold_left (fun dn (id, t) -> Bounded_net.add (Some st) dn (Option.get t.pat, (id, t)))
     (Bounded_net.create ()) l')
 
+
 let lookup_tacs (hdc,c) st (l,l',dn) =
   let l'  = List.map snd (Bounded_net.lookup st dn c) in
-  let sl' = Sort.list pri_order l' in
+  let sl' = List.stable_sort pri_order_int l' in
     Sort.merge pri_order l sl'
 
 module Constr_map = Map.Make(RefOrdered)
@@ -136,11 +170,138 @@ let is_transparent_gr (ids, csts) = function
   | ConstRef cst -> Cpred.mem cst csts
   | IndRef _ | ConstructRef _ -> false
 
+let dummy_goal = Goal.V82.dummy_goal
+
+let translate_hint (go,p) =
+  let mk_clenv (c,t) =
+    let cl = mk_clenv_from dummy_goal (c,t) in {cl with env = empty_env }
+  in
+  let code = match p.code with
+    | Res_pf (c,t) -> Res_pf (c, mk_clenv (c,t))
+    | ERes_pf (c,t) -> ERes_pf (c, mk_clenv (c,t))
+    | Res_pf_THEN_trivial_fail (c,t) ->
+      Res_pf_THEN_trivial_fail (c, mk_clenv (c,t))
+    | Give_exact c -> Give_exact c
+    | Unfold_nth e -> Unfold_nth e
+    | Extern t -> Extern t
+  in
+  (go,{ p with code = code })
+
+let path_matches hp hints =
+  let rec aux hp hints k =
+    match hp, hints with
+    | PathAtom _, [] -> false
+    | PathAtom PathAny, (_ :: hints') -> k hints'
+    | PathAtom p, (h :: hints') -> 
+      if p = h then k hints' else false
+    | PathStar hp', hints -> 
+      k hints || aux hp' hints (fun hints' -> aux hp hints' k)
+    | PathSeq (hp, hp'), hints -> 
+      aux hp hints (fun hints' -> aux hp' hints' k)
+    | PathOr (hp, hp'), hints ->
+      aux hp hints k || aux hp' hints k
+    | PathEmpty, _ -> false
+    | PathEpsilon, hints -> k hints
+  in aux hp hints (fun hints' -> true)
+
+let rec matches_epsilon = function
+  | PathAtom _ -> false
+  | PathStar _ -> true
+  | PathSeq (p, p') -> matches_epsilon p && matches_epsilon p'
+  | PathOr (p, p') -> matches_epsilon p || matches_epsilon p'
+  | PathEmpty -> false
+  | PathEpsilon -> true
+
+let rec is_empty = function
+  | PathAtom _ -> false
+  | PathStar _ -> false
+  | PathSeq (p, p') -> is_empty p || is_empty p'
+  | PathOr (p, p') -> matches_epsilon p && matches_epsilon p'
+  | PathEmpty -> true
+  | PathEpsilon -> false
+
+let rec path_derivate hp hint =
+  let rec derivate_atoms hints hints' =
+    match hints, hints' with
+    | gr :: grs, gr' :: grs' when gr = gr' -> derivate_atoms grs grs'
+    | [], [] -> PathEpsilon
+    | [], hints -> PathEmpty
+    | grs, [] -> PathAtom (PathHints grs)
+    | _, _ -> PathEmpty 
+  in
+    match hp with
+    | PathAtom PathAny -> PathEpsilon
+    | PathAtom (PathHints grs) -> 
+      (match grs, hint with
+       | h :: hints, PathAny -> PathEmpty
+       | hints, PathHints hints' -> derivate_atoms hints hints'
+       | _, _ -> assert false)
+    | PathStar p -> if path_matches p [hint] then hp else PathEpsilon
+    | PathSeq (hp, hp') ->
+      let hpder = path_derivate hp hint in
+	if matches_epsilon hp then 
+	  PathOr (PathSeq (hpder, hp'), path_derivate hp' hint)
+	else if is_empty hpder then PathEmpty 
+	else PathSeq (hpder, hp')
+    | PathOr (hp, hp') ->
+      PathOr (path_derivate hp hint, path_derivate hp' hint)
+    | PathEmpty -> PathEmpty
+    | PathEpsilon -> PathEmpty
+
+let rec normalize_path h =
+  match h with
+  | PathStar PathEpsilon -> PathEpsilon
+  | PathSeq (PathEmpty, _) | PathSeq (_, PathEmpty) -> PathEmpty
+  | PathSeq (PathEpsilon, p) | PathSeq (p, PathEpsilon) -> normalize_path p
+  | PathOr (PathEmpty, p) | PathOr (p, PathEmpty) -> normalize_path p
+  | PathOr (p, q) -> 
+    let p', q' = normalize_path p, normalize_path q in
+      if p = p' && q = q' then h
+      else normalize_path (PathOr (p', q'))
+  | PathSeq (p, q) -> 
+    let p', q' = normalize_path p, normalize_path q in
+      if p = p' && q = q' then h
+      else normalize_path (PathSeq (p', q'))
+  | _ -> h
+
+let path_derivate hp hint = normalize_path (path_derivate hp hint)
+
+let rec pp_hints_path = function
+  | PathAtom (PathAny) -> str"."
+  | PathAtom (PathHints grs) -> prlist_with_sep pr_spc pr_global grs
+  | PathStar p -> str "(" ++ pp_hints_path p ++ str")*"
+  | PathSeq (p, p') -> pp_hints_path p ++ str" ; " ++ pp_hints_path p'
+  | PathOr (p, p') -> 
+    str "(" ++ pp_hints_path p ++ spc () ++ str"|" ++ spc () ++ pp_hints_path p' ++ str ")"
+  | PathEmpty -> str"Ø"
+  | PathEpsilon -> str"ε"
+
+let rec subst_hints_path subst hp =
+  match hp with
+  | PathAtom PathAny -> hp
+  | PathAtom (PathHints grs) -> 
+    let gr' gr = fst (subst_global subst gr) in
+    let grs' = list_smartmap gr' grs in
+      if grs' == grs then hp else PathAtom (PathHints grs')
+  | PathStar p -> let p' = subst_hints_path subst p in
+      if p' == p then hp else PathStar p'
+  | PathSeq (p, q) ->
+    let p' = subst_hints_path subst p in
+    let q' = subst_hints_path subst q in
+      if p' == p && q' == q then hp else PathSeq (p', q')
+  | PathOr (p, q) ->
+    let p' = subst_hints_path subst p in
+    let q' = subst_hints_path subst q in
+      if p' == p && q' == q then hp else PathOr (p', q')
+  | _ -> hp
+
 module Hint_db = struct
 
   type t = {
     hintdb_state : Names.transparent_state;
+    hintdb_cut : hints_path;
     hintdb_unfolds : Idset.t * Cset.t;
+    mutable hintdb_max_id : int;
     use_dn : bool;
     hintdb_map : search_entry Constr_map.t;
     (* A list of unindexed entries starting with an unfoldable constant
@@ -148,8 +309,13 @@ module Hint_db = struct
     hintdb_nopat : (global_reference option * stored_data) list
   }
 
+  let next_hint_id t = 
+    let h = t.hintdb_max_id in t.hintdb_max_id <- succ t.hintdb_max_id; h
+
   let empty st use_dn = { hintdb_state = st;
+			  hintdb_cut = PathEmpty;
 			  hintdb_unfolds = (Idset.empty, Cset.empty);
+			  hintdb_max_id = 0;
 			  use_dn = use_dn;
 			  hintdb_map = Constr_map.empty;
 			  hintdb_nopat = [] }
@@ -157,47 +323,54 @@ module Hint_db = struct
   let find key db =
     try Constr_map.find key db.hintdb_map
     with Not_found -> empty_se
-
+ 
   let map_none db =
-    Sort.merge pri_order (List.map snd db.hintdb_nopat) []
-
+    List.map snd (Sort.merge pri_order (List.map snd db.hintdb_nopat) [])
+    
   let map_all k db =
     let (l,l',_) = find k db in
-      Sort.merge pri_order (List.map snd db.hintdb_nopat @ l) l'
+      List.map snd (Sort.merge pri_order (List.map snd db.hintdb_nopat @ l) l')
 
   let map_auto (k,c) db =
     let st = if db.use_dn then Some db.hintdb_state else None in
     let l' = lookup_tacs (k,c) st (find k db) in
-      Sort.merge pri_order (List.map snd db.hintdb_nopat) l'
+      List.map snd (Sort.merge pri_order (List.map snd db.hintdb_nopat) l')
 
   let is_exact = function
     | Give_exact _ -> true
     | _ -> false
 
-  let addkv gr v db =
+  let is_unfold = function
+    | Unfold_nth _ -> true
+    | _ -> false
+
+  let addkv gr id v db =
+    let idv = id, v in
     let k = match gr with
-      | Some gr -> if db.use_dn && is_transparent_gr db.hintdb_state gr then None else Some gr
+      | Some gr -> if db.use_dn && is_transparent_gr db.hintdb_state gr &&
+	  is_unfold v.code then None else Some gr
       | None -> None
     in
     let dnst = if db.use_dn then Some db.hintdb_state else None in
     let pat = if not db.use_dn && is_exact v.code then None else v.pat in
       match k with
       | None ->
-	  if not (List.exists (fun (_, v') -> v = v') db.hintdb_nopat) then
-	    { db with hintdb_nopat = (gr,v) :: db.hintdb_nopat }
+	  if not (List.exists (fun (_, (_, v')) -> v = v') db.hintdb_nopat) then
+	    { db with hintdb_nopat = (gr,idv) :: db.hintdb_nopat }
 	  else db
       | Some gr ->
 	  let oval = find gr db in
-	    { db with hintdb_map = Constr_map.add gr (add_tac pat v dnst oval) db.hintdb_map }
+	    { db with hintdb_map = Constr_map.add gr (add_tac pat idv dnst oval) db.hintdb_map }
 
   let rebuild_db st' db =
     let db' =
       { db with hintdb_map = Constr_map.map (rebuild_dn st') db.hintdb_map;
 	hintdb_state = st'; hintdb_nopat = [] }
     in
-      List.fold_left (fun db (gr,v) -> addkv gr v db) db' db.hintdb_nopat
+      List.fold_left (fun db (gr,(id,v)) -> addkv gr id v db) db' db.hintdb_nopat
 
-  let add_one (k,v) db =
+  let add_one kv db =
+    let (k,v) = translate_hint kv in
     let st',db,rebuild =
       match v.code with
       | Unfold_nth egr ->
@@ -211,13 +384,27 @@ module Hint_db = struct
       | _ -> db.hintdb_state, db, false
     in
     let db = if db.use_dn && rebuild then rebuild_db st' db else db
-    in addkv k v db
+    in addkv k (next_hint_id db) v db
 
   let add_list l db = List.fold_right add_one l db
 
+  let remove_sdl p sdl = list_smartfilter p sdl 
+  let remove_he st p (sl1, sl2, dn as he) =
+    let sl1' = remove_sdl p sl1 and sl2' = remove_sdl p sl2 in
+      if sl1' == sl1 && sl2' == sl2 then he
+      else rebuild_dn st (sl1', sl2', dn)
+
+  let remove_list grs db =
+    let filter (_, h) = match h.name with PathHints [gr] -> not (List.mem gr grs) | _ -> true in
+    let hintmap = Constr_map.map (remove_he db.hintdb_state filter) db.hintdb_map in
+    let hintnopat = list_smartfilter (fun (ge, sd) -> filter sd) db.hintdb_nopat in
+      { db with hintdb_map = hintmap; hintdb_nopat = hintnopat }
+
+  let remove_one gr db = remove_list [gr] db
+
   let iter f db =
-    f None (List.map snd db.hintdb_nopat);
-    Constr_map.iter (fun k (l,l',_) -> f (Some k) (l@l')) db.hintdb_map
+    f None (List.map (fun x -> snd (snd x)) db.hintdb_nopat);
+    Constr_map.iter (fun k (l,l',_) -> f (Some k) (List.map snd (l@l'))) db.hintdb_map
 
   let transparent_state db = db.hintdb_state
 
@@ -225,6 +412,11 @@ module Hint_db = struct
     if db.use_dn then rebuild_db st db
     else { db with hintdb_state = st }
 
+  let add_cut path db =
+    { db with hintdb_cut = normalize_path (PathOr (db.hintdb_cut, path)) }
+
+  let cut db = db.hintdb_cut
+
   let unfolds db = db.hintdb_unfolds
 
   let use_dn db = db.use_dn
@@ -255,6 +447,9 @@ let current_db_names () =
 (**************************************************************************)
 
 let auto_init : (unit -> unit) ref = ref (fun () -> ())
+let add_auto_init f = 
+  let init = !auto_init in
+    auto_init := (fun () -> init (); f ())
 
 let init     () = searchtable := Hintdbmap.empty; !auto_init ()
 let freeze   () = !searchtable
@@ -280,47 +475,51 @@ let try_head_pattern c =
   try head_pattern_bound c
   with BoundPattern -> error "Bound head variable."
 
-let dummy_goal =
-  {it = make_evar empty_named_context_val mkProp;
-   sigma = empty}
+let name_of_constr c = try Some (global_of_constr c) with Not_found -> None
 
-let make_exact_entry sigma pri (c,cty) =
+let make_exact_entry sigma pri ?(name=PathAny) (c,cty) =
   let cty = strip_outer_cast cty in
     match kind_of_term cty with
     | Prod _ -> failwith "make_exact_entry"
     | _ ->
 	let pat = snd (Pattern.pattern_of_constr sigma cty) in
-	let head = 
-	  try head_of_constr_reference (fst (head_constr cty)) 
-	  with _ -> failwith "make_exact_entry" 
+	let hd =
+	  try head_pattern_bound pat
+	  with BoundPattern -> failwith "make_exact_entry"
 	in
-          (Some head,
-	  { pri=(match pri with Some pri -> pri | None -> 0); pat=Some pat; code=Give_exact c })
+          (Some hd,
+	  { pri = (match pri with None -> 0 | Some p -> p);
+	    pat = Some pat;
+	    name = name;
+	    code = Give_exact c })
 
-let make_apply_entry env sigma (eapply,hnf,verbose) pri (c,cty) =
+let make_apply_entry env sigma (eapply,hnf,verbose) pri ?(name=PathAny) (c,cty) =
   let cty = if hnf then hnf_constr env sigma cty else cty in
     match kind_of_term cty with
     | Prod _ ->
         let ce = mk_clenv_from dummy_goal (c,cty) in
 	let c' = clenv_type (* ~reduce:false *) ce in
 	let pat = snd (Pattern.pattern_of_constr sigma c') in
-        let hd = (try head_pattern_bound pat
-          with BoundPattern -> failwith "make_apply_entry") in
+        let hd =
+	  try head_pattern_bound pat
+          with BoundPattern -> failwith "make_apply_entry" in
         let nmiss = List.length (clenv_missing ce) in
 	if nmiss = 0 then
 	  (Some hd,
           { pri = (match pri with None -> nb_hyp cty | Some p -> p);
             pat = Some pat;
-            code = Res_pf(c,{ce with env=empty_env}) })
+	    name = name;
+            code = Res_pf(c,cty) })
 	else begin
 	  if not eapply then failwith "make_apply_entry";
           if verbose then
 	    warn (str "the hint: eapply " ++ pr_lconstr c ++
 	    str " will only be used by eauto");
           (Some hd,
-            { pri = (match pri with None -> nb_hyp cty + nmiss | Some p -> p);
-              pat = Some pat;
-              code = ERes_pf(c,{ce with env=empty_env}) })
+           { pri = (match pri with None -> nb_hyp cty + nmiss | Some p -> p);
+             pat = Some pat;
+	     name = name;
+             code = ERes_pf(c,cty) })
         end
     | _ -> failwith "make_apply_entry"
 
@@ -328,12 +527,12 @@ let make_apply_entry env sigma (eapply,hnf,verbose) pri (c,cty) =
    c is a constr
    cty is the type of constr *)
 
-let make_resolves env sigma flags pri c =
-  let cty = type_of env sigma c in
+let make_resolves env sigma flags pri ?name c =
+  let cty = Retyping.get_type_of env sigma c in
   let ents =
     map_succeed
       (fun f -> f (c,cty))
-      [make_exact_entry sigma pri; make_apply_entry env sigma flags pri]
+      [make_exact_entry sigma pri ?name; make_apply_entry env sigma flags pri ?name]
   in
   if ents = [] then
     errorlabstrm "Hint"
@@ -345,7 +544,8 @@ let make_resolves env sigma flags pri c =
 (* used to add an hypothesis to the local hint database *)
 let make_resolve_hyp env sigma (hname,_,htyp) =
   try
-    [make_apply_entry env sigma (true, true, false) None
+    [make_apply_entry env sigma (true, true, false) None 
+       ~name:(PathHints [VarRef hname])
        (mkVar hname, htyp)]
   with
     | Failure _ -> []
@@ -353,26 +553,30 @@ let make_resolve_hyp env sigma (hname,_,htyp) =
 
 (* REM : in most cases hintname = id *)
 let make_unfold eref =
-  (Some (global_of_evaluable_reference eref),
+  let g = global_of_evaluable_reference eref in
+  (Some g,
    { pri = 4;
      pat = None;
+     name = PathHints [g];
      code = Unfold_nth eref })
 
 let make_extern pri pat tacast =
   let hdconstr = Option.map try_head_pattern pat in
   (hdconstr,
-   { pri=pri;
+   { pri = pri;
      pat = pat;
-     code= Extern tacast })
+     name = PathAny;
+     code = Extern tacast })
 
-let make_trivial env sigma c =
+let make_trivial env sigma ?(name=PathAny) c =
   let t = hnf_constr env sigma (type_of env sigma c) in
   let hd = head_of_constr_reference (fst (head_constr t)) in
   let ce = mk_clenv_from dummy_goal (c,t) in
   (Some hd, { pri=1;
-         pat = Some (snd (Pattern.pattern_of_constr sigma (clenv_type ce)));
-         code=Res_pf_THEN_trivial_fail(c,{ce with env=empty_env}) })
-
+              pat = Some (snd (Pattern.pattern_of_constr sigma (clenv_type ce)));
+	      name = name;
+              code=Res_pf_THEN_trivial_fail(c,t) })
+  
 open Vernacexpr
 
 (**************************************************************************)
@@ -402,23 +606,39 @@ let add_transparency dbname grs b =
       st grs
   in searchtable_add (dbname, Hint_db.set_transparent_state db st')
 
-type hint_action = | CreateDB of bool * transparent_state
-		   | AddTransparency of evaluable_global_reference list * bool
-		   | AddTactic of (global_reference option * pri_auto_tactic) list
+let remove_hint dbname grs =
+  let db = get_db dbname in
+  let db' = Hint_db.remove_list grs db in
+    searchtable_add (dbname, db')
+
+type hint_action =
+  | CreateDB of bool * transparent_state
+  | AddTransparency of evaluable_global_reference list * bool
+  | AddHints of hint_entry list
+  | RemoveHints of global_reference list
+  | AddCut of hints_path
+
+let add_cut dbname path =
+  let db = get_db dbname in
+  let db' = Hint_db.add_cut path db in
+    searchtable_add (dbname, db')
+
+type hint_obj = bool * string * hint_action  (* locality, name, action *)
 
 let cache_autohint (_,(local,name,hints)) =
   match hints with
   | CreateDB (b, st) -> searchtable_add (name, Hint_db.empty st b)
   | AddTransparency (grs, b) -> add_transparency name grs b
-  | AddTactic hints -> add_hint name hints
+  | AddHints hints -> add_hint name hints
+  | RemoveHints grs -> remove_hint name grs
+  | AddCut path -> add_cut name path
 
 let forward_subst_tactic =
   ref (fun _ -> failwith "subst_tactic is not installed for auto")
 
 let set_extern_subst_tactic f = forward_subst_tactic := f
 
-let subst_autohint (subst,(local,name,hintlist as obj)) = 
-  let trans_clenv clenv = Clenv.subst_clenv subst clenv in
+let subst_autohint (subst,(local,name,hintlist as obj)) =
   let subst_key gr =
     let (lab'', elab') = subst_global subst gr in
     let gr' =
@@ -428,90 +648,72 @@ let subst_autohint (subst,(local,name,hintlist as obj)) =
   in
   let subst_hint (k,data as hint) =
     let k' = Option.smartmap subst_key k in
-    let data' = match data.code with
-      | Res_pf (c, clenv) ->
-	  let c' = subst_mps subst c in
-	  let clenv' = trans_clenv clenv in
-	  let pat' = Option.smartmap (subst_pattern subst) data.pat in
-	    if c==c' && clenv'==clenv && pat'==data.pat then data else
-	      {data with
-		 pat=pat';
-		 code=Res_pf (c', clenv')}
-      | ERes_pf (c, clenv) ->
-	  let c' = subst_mps subst c in
-	  let clenv' = trans_clenv clenv in
-	  let pat' = Option.smartmap (subst_pattern subst) data.pat in
-	    if c==c' && clenv'==clenv && pat'==data.pat then data else
-	      {data with
-		 pat=pat';
-		 code=ERes_pf (c', clenv')}
+    let pat' = Option.smartmap (subst_pattern subst) data.pat in
+    let code' = match data.code with
+      | Res_pf (c,t) ->
+          let c' = subst_mps subst c in
+          let t' = subst_mps subst t in
+          if c==c' && t'==t then data.code else Res_pf (c', t')
+      | ERes_pf (c,t) ->
+          let c' = subst_mps subst c in
+          let t' = subst_mps subst t in
+          if c==c' && t'==t then data.code else ERes_pf (c',t')
       | Give_exact c ->
-	  let c' = subst_mps subst c in
-	  let pat' = Option.smartmap (subst_pattern subst) data.pat in
-	    if c==c' && pat'==data.pat then data else
-	      {data with
-		 pat=pat';
-		 code=(Give_exact c')}
-      | Res_pf_THEN_trivial_fail (c, clenv) ->
-	  let c' = subst_mps subst c in
-	  let clenv' = trans_clenv clenv in
-	  let pat' = Option.smartmap (subst_pattern subst) data.pat in
-	    if c==c' && clenv'==clenv && pat'==data.pat then data else
-	      {data with
-		 pat=pat';
-		 code=Res_pf_THEN_trivial_fail (c',clenv')}
+          let c' = subst_mps subst c in
+          if c==c' then data.code else Give_exact c'
+      | Res_pf_THEN_trivial_fail (c,t) ->
+          let c' = subst_mps subst c in
+          let t' = subst_mps subst t in
+          if c==c' && t==t' then data.code else Res_pf_THEN_trivial_fail (c',t')
       | Unfold_nth ref ->
           let ref' = subst_evaluable_reference subst ref in
-	  let pat' = Option.smartmap (subst_pattern subst) data.pat in
-           if ref==ref' && pat'==data.pat then data else
-	     {data with
-		pat=pat';
-		code=(Unfold_nth ref')}
+          if ref==ref' then data.code else Unfold_nth ref'
       | Extern tac ->
 	  let tac' = !forward_subst_tactic subst tac in
-	  let pat' = Option.smartmap (subst_pattern subst) data.pat in
-	    if tac==tac' && pat'==data.pat then data else
-	      {data with
-		 pat=pat';
-		 code=(Extern tac')}
+	  if tac==tac' then data.code else Extern tac'
     in
-      if k' == k && data' == data then hint else
-	(k',data')
+    let data' =
+      if data.pat==pat' && data.code==code' then data
+      else { data with pat = pat'; code = code' }
+    in
+    if k' == k && data' == data then hint else (k',data')
   in
     match hintlist with
     | CreateDB _ -> obj
     | AddTransparency (grs, b) ->
 	let grs' = list_smartmap (subst_evaluable_reference subst) grs in
 	  if grs==grs' then obj else (local, name, AddTransparency (grs', b))
-    | AddTactic hintlist ->
+    | AddHints hintlist ->
 	let hintlist' = list_smartmap subst_hint hintlist in
 	  if hintlist' == hintlist then obj else
-	    (local,name,AddTactic hintlist')
+	    (local,name,AddHints hintlist')
+    | RemoveHints grs ->
+	let grs' = list_smartmap (fun x -> fst (subst_global subst x)) grs in
+	  if grs==grs' then obj else (local, name, RemoveHints grs')
+    | AddCut path ->
+      let path' = subst_hints_path subst path in
+	if path' == path then obj else (local, name, AddCut path')
 
 let classify_autohint ((local,name,hintlist) as obj) =
-  if local or hintlist = (AddTactic []) then Dispose else Substitute obj
+  if local or hintlist = (AddHints []) then Dispose else Substitute obj
 
-let discharge_autohint (_,(local,name,hintlist as obj)) =
-  if local then None else
-    match hintlist with
-    | CreateDB _ ->
-	(* We assume that the transparent state is either empty or full *)
-	Some obj
-    | AddTransparency _ | AddTactic _ ->
-	(* Needs the adequate code here to support Global Hints in sections *)
-	None
-
-let (inAutoHint,_) =
+let inAutoHint : hint_obj -> obj =
   declare_object {(default_object "AUTOHINT") with
                     cache_function = cache_autohint;
 		    load_function = (fun _ -> cache_autohint);
 		    subst_function = subst_autohint;
-		    classify_function = classify_autohint }
-
+		    classify_function = classify_autohint; }
 
 let create_hint_db l n st b =
   Lib.add_anonymous_leaf (inAutoHint (l,n,CreateDB (b, st)))
 
+let remove_hints local dbnames grs =
+  let dbnames = if dbnames = [] then ["core"] else dbnames in
+    List.iter
+      (fun dbname ->
+	 Lib.add_anonymous_leaf (inAutoHint(local, dbname, RemoveHints grs)))
+      dbnames
+
 (**************************************************************************)
 (*                     The "Hint" vernacular command                      *)
 (**************************************************************************)
@@ -520,16 +722,21 @@ let add_resolves env sigma clist local dbnames =
     (fun dbname ->
        Lib.add_anonymous_leaf
 	 (inAutoHint
-	    (local,dbname, AddTactic
-     	      (List.flatten (List.map (fun (x, hnf, y) ->
-		make_resolves env sigma (true,hnf,Flags.is_verbose()) x y) clist)))))
+	    (local,dbname, AddHints
+     	      (List.flatten (List.map (fun (x, hnf, path, y) ->
+		make_resolves env sigma (true,hnf,Flags.is_verbose()) x ~name:path y) clist)))))
     dbnames
 
-
 let add_unfolds l local dbnames =
   List.iter
     (fun dbname -> Lib.add_anonymous_leaf
-       (inAutoHint (local,dbname, AddTactic (List.map make_unfold l))))
+       (inAutoHint (local,dbname, AddHints (List.map make_unfold l))))
+    dbnames
+
+let add_cuts l local dbnames =
+  List.iter
+    (fun dbname -> Lib.add_anonymous_leaf
+       (inAutoHint (local,dbname, AddCut l)))
     dbnames
 
 let add_transparency l b local dbnames =
@@ -550,10 +757,10 @@ let add_extern pri pat tacast local dbname =
 	      (str "The meta-variable ?" ++ Ppconstr.pr_patvar i ++ str" is not bound.")
 	| []  ->
 	    Lib.add_anonymous_leaf
-	      (inAutoHint(local,dbname, AddTactic [make_extern pri (Some pat) tacast])))
+	      (inAutoHint(local,dbname, AddHints [make_extern pri (Some pat) tacast])))
     | None ->
 	Lib.add_anonymous_leaf
-	  (inAutoHint(local,dbname, AddTactic [make_extern pri None tacast]))
+	  (inAutoHint(local,dbname, AddHints [make_extern pri None tacast]))
 
 let add_externs pri pat tacast local dbnames =
   List.iter (add_extern pri pat tacast local) dbnames
@@ -562,7 +769,8 @@ let add_trivials env sigma l local dbnames =
   List.iter
     (fun dbname ->
        Lib.add_anonymous_leaf (
-	 inAutoHint(local,dbname, AddTactic (List.map (make_trivial env sigma) l))))
+	 inAutoHint(local,dbname, 
+		    AddHints (List.map (fun (name, c) -> make_trivial env sigma ~name c) l))))
     dbnames
 
 let forward_intern_tac =
@@ -571,8 +779,9 @@ let forward_intern_tac =
 let set_extern_intern_tac f = forward_intern_tac := f
 
 type hints_entry =
-  | HintsResolveEntry of (int option * bool * constr) list
-  | HintsImmediateEntry of constr list
+  | HintsResolveEntry of (int option * bool * hints_path_atom * constr) list
+  | HintsImmediateEntry of (hints_path_atom * constr) list
+  | HintsCutEntry of hints_path
   | HintsUnfoldEntry of evaluable_global_reference list
   | HintsTransparencyEntry of evaluable_global_reference list * bool
   | HintsExternEntry of
@@ -580,24 +789,69 @@ type hints_entry =
   | HintsDestructEntry of identifier * int * (bool,unit) location *
       (patvar list * constr_pattern) * glob_tactic_expr
 
+let h = id_of_string "H"
+
+exception Found of constr * types
+
+let prepare_hint env (sigma,c) =
+  let sigma = Typeclasses.resolve_typeclasses ~fail:false env sigma in
+  (* We re-abstract over uninstantiated evars.
+     It is actually a bit stupid to generalize over evars since the first
+     thing make_resolves will do is to re-instantiate the products *)
+  let c = drop_extra_implicit_args (Evarutil.nf_evar sigma c) in
+  let vars = ref (collect_vars c) in
+  let subst = ref [] in
+  let rec find_next_evar c = match kind_of_term c with
+    | Evar (evk,args as ev) ->
+      (* We skip the test whether args is the identity or not *)
+      let t = Evarutil.nf_evar sigma (existential_type sigma ev) in
+      let t = List.fold_right (fun (e,id) c -> replace_term e id c) !subst t in
+      if free_rels t <> Intset.empty then
+	error "Hints with holes dependent on a bound variable not supported.";
+      if occur_existential t then
+	(* Not clever enough to construct dependency graph of evars *)
+	error "Not clever enough to deal with evars dependent in other evars.";
+      raise (Found (c,t))
+    | _ -> iter_constr find_next_evar c in
+  let rec iter c =
+    try find_next_evar c; c
+    with Found (evar,t) ->
+      let id = next_ident_away_from h (fun id -> Idset.mem id !vars) in
+      vars := Idset.add id !vars;
+      subst := (evar,mkVar id)::!subst;
+      mkNamedLambda id t (iter (replace_term evar (mkVar id) c)) in
+  iter c
+
+let path_of_constr_expr c =
+  match c with
+  | Topconstr.CRef r -> (try PathHints [global r] with _ -> PathAny)
+  | _ -> PathAny
+      
 let interp_hints h =
-  let f = Constrintern.interp_constr Evd.empty (Global.env()) in
+  let f c =
+    let evd,c = Constrintern.interp_open_constr Evd.empty (Global.env()) c in
+    let c = prepare_hint (Global.env()) (evd,c) in
+    Evarutil.check_evars (Global.env()) Evd.empty evd c;
+    c in
   let fr r =
     let gr = global_with_alias r in
     let r' = evaluable_of_global_reference (Global.env()) gr in
     Dumpglob.add_glob (loc_of_reference r) gr;
     r' in
+  let fres (o, b, c) = (o, b, path_of_constr_expr c, f c) in
+  let fi c = path_of_constr_expr c, f c in
   let fp = Constrintern.intern_constr_pattern Evd.empty (Global.env()) in
   match h with
-  | HintsResolve lhints -> HintsResolveEntry (List.map (on_pi3 f) lhints)
-  | HintsImmediate lhints -> HintsImmediateEntry (List.map f lhints)
+  | HintsResolve lhints -> HintsResolveEntry (List.map fres lhints)
+  | HintsImmediate lhints -> HintsImmediateEntry (List.map fi lhints)
   | HintsUnfold lhints -> HintsUnfoldEntry (List.map fr lhints)
   | HintsTransparency (lhints, b) ->
       HintsTransparencyEntry (List.map fr lhints, b)
   | HintsConstructors lqid ->
       let constr_hints_of_ind qid =
         let ind = global_inductive_with_alias qid in
-        list_tabulate (fun i -> None, true, mkConstruct (ind,i+1))
+        list_tabulate (fun i -> let c = (ind,i+1) in
+			 None, true, PathHints [ConstructRef c], mkConstruct c)
 	  (nconstructors ind) in
 	HintsResolveEntry (List.flatten (List.map constr_hints_of_ind lqid))
   | HintsExtern (pri, patcom, tacexp) ->
@@ -609,11 +863,14 @@ let interp_hints h =
       HintsDestructEntry (na,pri,loc,pat,!forward_intern_tac l code)
 
 let add_hints local dbnames0 h =
+  if List.mem "nocore" dbnames0 then
+    error "The hint database \"nocore\" is meant to stay empty.";
   let dbnames = if dbnames0 = [] then ["core"] else dbnames0 in
   let env = Global.env() and sigma = Evd.empty in
   match h with
   | HintsResolveEntry lhints -> add_resolves env sigma lhints local dbnames
   | HintsImmediateEntry lhints -> add_trivials env sigma lhints local dbnames
+  | HintsCutEntry lhints -> add_cuts lhints local dbnames
   | HintsUnfoldEntry lhints -> add_unfolds lhints local dbnames
   | HintsTransparencyEntry (lhints, b) ->
       add_transparency lhints b local dbnames
@@ -639,8 +896,8 @@ let pr_autotactic =
   | Extern tac ->
       (str "(external) " ++ Pptactic.pr_glob_tactic (Global.env()) tac)
 
-let pr_hint v =
-  (pr_autotactic v.code ++ str"(" ++ int v.pri ++ str")" ++ spc ())
+let pr_hint (id, v) =
+  (pr_autotactic v.code ++ str"(level " ++ int v.pri ++ str", id " ++ int id ++ str ")" ++ spc ())
 
 let pr_hint_list hintlist =
   (str "  " ++ hov 0 (prlist pr_hint hintlist) ++ fnl ())
@@ -655,7 +912,7 @@ let pr_hint_list_for_head c =
   let dbs = Hintdbmap.to_list !searchtable in
   let valid_dbs =
     map_succeed
-      (fun (name,db) -> (name,db,Hint_db.map_all c db))
+      (fun (name,db) -> (name,db, List.map (fun v -> 0, v) (Hint_db.map_all c db)))
       dbs
   in
   if valid_dbs = [] then
@@ -682,6 +939,7 @@ let pr_hint_term cl =
 	    else Hint_db.map_auto (hd, applist (hdc,args))
 	with Bound -> Hint_db.map_none
       in
+      let fn db = List.map (fun x -> 0, x) (fn db) in
 	map_succeed (fun (name, db) -> (name, db, fn db)) dbs
     in
       if valid_dbs = [] then
@@ -700,8 +958,12 @@ let print_hint_term cl = ppnl (pr_hint_term cl)
 (* print all hints that apply to the concl of the current goal *)
 let print_applicable_hint () =
   let pts = get_pftreestate () in
-  let gl = nth_goal_of_pftreestate 1 pts in
-  print_hint_term (pf_concl gl)
+  let glss = Proof.V82.subgoals pts in
+  match glss.Evd.it with
+  | [] -> Util.error "No focused goal."
+  | g::_ ->
+    let gl = { Evd.it = g; sigma = glss.Evd.sigma } in
+    print_hint_term (pf_concl gl)
 
 (* displays the whole hint database db *)
 let print_hint_db db =
@@ -711,17 +973,18 @@ let print_hint_db db =
 	    else str"Non-discriminated database")));
   msgnl (hov 2 (str"Unfoldable variable definitions: " ++ pr_idpred ids));
   msgnl (hov 2 (str"Unfoldable constant definitions: " ++ pr_cpred csts));
+  msgnl (hov 2 (str"Cut: " ++ pp_hints_path (Hint_db.cut db)));
   Hint_db.iter
     (fun head hintlist ->
       match head with
       | Some head ->
 	  msg (hov 0
 		  (str "For " ++ pr_global head ++ str " -> " ++
-		      pr_hint_list hintlist))
+		      pr_hint_list (List.map (fun x -> (0,x)) hintlist)))
       | None ->
 	  msg (hov 0
 		  (str "For any goal -> " ++
-		      pr_hint_list hintlist)))
+		      pr_hint_list (List.map (fun x -> (0, x)) hintlist))))
     db
 
 let print_hint_db_by_name dbname =
@@ -746,7 +1009,7 @@ let print_searchtable () =
 (*          tactics with a trace mechanism for automatic search           *)
 (**************************************************************************)
 
-let priority l = List.filter (fun (_,hint) -> hint.pri = 0) l
+let priority l = List.filter (fun (_, hint) -> hint.pri = 0) l
 
 (* tell auto not to reuse already instantiated metas in unification (for
    compatibility, since otherwise, apply succeeds oftener) *)
@@ -755,10 +1018,18 @@ open Unification
 
 let auto_unif_flags = {
   modulo_conv_on_closed_terms = Some full_transparent_state;
-  use_metas_eagerly = false;
+  use_metas_eagerly_in_conv_on_closed_terms = false;
   modulo_delta = empty_transparent_state;
+  modulo_delta_types = full_transparent_state;
+  check_applied_meta_types = false;
   resolve_evars = true;
-  use_evars_pattern_unification = false;
+  use_pattern_unification = false;
+  use_meta_bound_pattern_unification = true;
+  frozen_evars = ExistentialSet.empty;
+  restrict_conv_on_strict_subterms = false; (* Compat *)
+  modulo_betaiota = false;
+  modulo_eta = true;
+  allow_K_in_toplevel_higher_order_unification = false
 }
 
 (* Try unification with the precompiled clause, then use registered Apply *)
@@ -769,12 +1040,12 @@ let h_clenv_refine ev c clenv =
 
 let unify_resolve_nodelta (c,clenv) gl =
   let clenv' = connect_clenv gl clenv in
-  let clenv'' = clenv_unique_resolver false ~flags:auto_unif_flags clenv' gl in
+  let clenv'' = clenv_unique_resolver ~flags:auto_unif_flags clenv' gl in
   h_clenv_refine false c clenv'' gl
 
 let unify_resolve flags (c,clenv) gl =
   let clenv' = connect_clenv gl clenv in
-  let clenv'' = clenv_unique_resolver false ~flags clenv' gl in
+  let clenv'' = clenv_unique_resolver ~flags clenv' gl in
   h_clenv_refine false c clenv'' gl
 
 let unify_resolve_gen = function
@@ -783,40 +1054,44 @@ let unify_resolve_gen = function
 
 (* Util *)
 
-let expand_constructor_hints lems =
-  list_map_append (fun lem ->
+let expand_constructor_hints env lems =
+  list_map_append (fun (sigma,lem) ->
     match kind_of_term lem with
     | Ind ind ->
 	list_tabulate (fun i -> mkConstruct (ind,i+1)) (nconstructors ind)
     | _ ->
-	[lem]) lems
+	[prepare_hint env (sigma,lem)]) lems
 
 (* builds a hint database from a constr signature *)
 (* typically used with (lid, ltyp) = pf_hyps_types <some goal> *)
 
 let add_hint_lemmas eapply lems hint_db gl =
-  let lems = expand_constructor_hints lems in
+  let lems = expand_constructor_hints (pf_env gl) lems in
   let hintlist' =
     list_map_append (pf_apply make_resolves gl (eapply,true,false) None) lems in
   Hint_db.add_list hintlist' hint_db
 
-let make_local_hint_db eapply lems gl =
+let make_local_hint_db ?ts eapply lems gl =
   let sign = pf_hyps gl in
+  let ts = match ts with
+    | None -> Hint_db.transparent_state (searchtable_map "core") 
+    | Some ts -> ts
+  in
   let hintlist = list_map_append (pf_apply make_resolve_hyp gl) sign in
   add_hint_lemmas eapply lems
-    (Hint_db.add_list hintlist (Hint_db.empty empty_transparent_state false)) gl
+    (Hint_db.add_list hintlist (Hint_db.empty ts false)) gl
 
 (* Serait-ce possible de compiler d'abord la tactique puis de faire la
-   substitution sans passer par bdize dont l'objectif est de préparer un
+   substitution sans passer par bdize dont l'objectif est de préparer un
    terme pour l'affichage ? (HH) *)
 
-(* Si on enlève le dernier argument (gl) conclPattern est calculé une
+(* Si on enlève le dernier argument (gl) conclPattern est calculé une
 fois pour toutes : en particulier si Pattern.somatch produit une UserError
-Ce qui fait que si la conclusion ne matche pas le pattern, Auto échoue, même
-si après Intros la conclusion matche le pattern.
+Ce qui fait que si la conclusion ne matche pas le pattern, Auto échoue, même
+si après Intros la conclusion matche le pattern.
 *)
 
-(* conclPattern doit échouer avec error car il est rattraper par tclFIRST *)
+(* conclPattern doit échouer avec error car il est rattraper par tclFIRST *)
 
 let forward_interp_tactic =
   ref (fun _ -> failwith "interp_tactic is not installed for auto")
@@ -837,8 +1112,8 @@ let conclPattern concl pat tac gl =
 (**************************************************************************)
 
 (* local_db is a Hint database containing the hypotheses of current goal *)
-(* Papageno : cette fonction a été pas mal simplifiée depuis que la base
-  de Hint impérative a été remplacée par plusieurs bases fonctionnelles *)
+(* Papageno : cette fonction a été pas mal simplifiée depuis que la base
+  de Hint impérative a été remplacée par plusieurs bases fonctionnelles *)
 
 let flags_of_state st =
   {auto_unif_flags with
@@ -864,7 +1139,7 @@ let rec trivial_fail_db mod_delta db_list local_db gl =
   in
   tclFIRST
     (assumption::intro_tac::
-     (List.map tclCOMPLETE
+     (List.map (fun tac -> tclCOMPLETE tac)
        (trivial_resolve mod_delta db_list local_db (pf_concl gl)))) gl
 
 and my_find_search_nodelta db_list local_db hdc concl =
@@ -876,7 +1151,7 @@ and my_find_search mod_delta =
   else my_find_search_nodelta
 
 and my_find_search_delta db_list local_db hdc concl =
-  let flags = {auto_unif_flags with use_metas_eagerly = true} in
+  let flags = {auto_unif_flags with use_metas_eagerly_in_conv_on_closed_terms = true} in
   let f = hintmap_of hdc concl in
     if occur_existential concl then
       list_map_append
@@ -906,20 +1181,23 @@ and my_find_search_delta db_list local_db hdc concl =
 	  in List.map (fun x -> (Some flags,x)) l)
       	(local_db::db_list)
 
-and tac_of_hint db_list local_db concl (flags, {pat=p; code=t}) =
-  match t with
-  | Res_pf (term,cl) -> unify_resolve_gen flags (term,cl)
-  | ERes_pf (_,c) -> (fun gl -> error "eres_pf")
-  | Give_exact c  -> exact_check c
-  | Res_pf_THEN_trivial_fail (term,cl) ->
+and tac_of_hint db_list local_db concl (flags, ({pat=p; code=t})) =
+  let tactic = 
+    match t with
+    | Res_pf (c,cl) -> unify_resolve_gen flags (c,cl)
+    | ERes_pf _ -> (fun gl -> error "eres_pf")
+    | Give_exact c  -> exact_check c
+    | Res_pf_THEN_trivial_fail (c,cl) ->
       tclTHEN
-        (unify_resolve_gen flags (term,cl))
+        (unify_resolve_gen flags (c,cl))
         (trivial_fail_db (flags <> None) db_list local_db)
-  | Unfold_nth c -> (fun gl ->
-      if exists_evaluable_reference (pf_env gl) c then
-	tclPROGRESS (h_reduce (Unfold [all_occurrences_expr,c]) onConcl) gl
-      else tclFAIL 0 (str"Unbound reference") gl)
-  | Extern tacast -> conclPattern concl p tacast
+    | Unfold_nth c -> 
+      (fun gl ->
+       if exists_evaluable_reference (pf_env gl) c then
+	 tclPROGRESS (h_reduce (Unfold [all_occurrences_expr,c]) onConcl) gl
+       else tclFAIL 0 (str"Unbound reference") gl)
+    | Extern tacast -> conclPattern concl p tacast
+  in tactic
 
 and trivial_resolve mod_delta db_list local_db cl =
   try
@@ -933,21 +1211,25 @@ and trivial_resolve mod_delta db_list local_db cl =
 	    (my_find_search mod_delta db_list local_db head cl))
   with Not_found -> []
 
-let trivial lems dbnames gl =
-  let db_list =
-    List.map
-      (fun x ->
-	 try
-	   searchtable_map x
-	 with Not_found ->
-	   error_no_such_hint_database x)
-      ("core"::dbnames)
+(** The use of the "core" database can be de-activated by passing
+    "nocore" amongst the databases. *)
+
+let make_db_list dbnames =
+  let use_core = not (List.mem "nocore" dbnames) in
+  let dbnames = list_remove "nocore" dbnames in
+  let dbnames = if use_core then "core"::dbnames else dbnames in
+  let lookup db =
+    try searchtable_map db with Not_found -> error_no_such_hint_database db
   in
+  List.map lookup dbnames
+
+let trivial lems dbnames gl =
+  let db_list = make_db_list dbnames in
   tclTRY (trivial_fail_db false db_list (make_local_hint_db false lems gl)) gl
 
 let full_trivial lems gl =
   let dbnames = Hintdbmap.dom !searchtable in
-  let dbnames = list_subtract dbnames ["v62"] in
+  let dbnames = list_remove "v62" dbnames in
   let db_list = List.map (fun x -> searchtable_map x) dbnames in
   tclTRY (trivial_fail_db false db_list (make_local_hint_db false lems gl)) gl
 
@@ -955,10 +1237,8 @@ let gen_trivial lems = function
   | None -> full_trivial lems
   | Some l -> trivial lems l
 
-let inj_open c = (Evd.empty,c)
-
 let h_trivial lems l =
-  Refiner.abstract_tactic (TacTrivial (lems,l))
+  Refiner.abstract_tactic (TacTrivial (List.map snd lems,l))
     (gen_trivial lems l)
 
 (**************************************************************************)
@@ -1051,15 +1331,7 @@ let search = search_gen 0
 let default_search_depth = ref 5
 
 let delta_auto mod_delta n lems dbnames gl =
-  let db_list =
-    List.map
-      (fun x ->
-	 try
-	   searchtable_map x
-	 with Not_found ->
-	   error_no_such_hint_database x)
-      ("core"::dbnames)
-  in
+  let db_list = make_db_list dbnames in
   tclTRY (search n mod_delta db_list (make_local_hint_db false lems gl)) gl
 
 let auto = delta_auto false
@@ -1070,7 +1342,7 @@ let default_auto = auto !default_search_depth [] []
 
 let delta_full_auto mod_delta n lems gl =
   let dbnames = Hintdbmap.dom !searchtable in
-  let dbnames = list_subtract dbnames ["v62"] in
+  let dbnames = list_remove "v62" dbnames in
   let db_list = List.map (fun x -> searchtable_map x) dbnames in
   tclTRY (search n mod_delta db_list (make_local_hint_db false lems gl)) gl
 
@@ -1088,7 +1360,7 @@ let gen_auto n lems dbnames =
 let inj_or_var = Option.map (fun n -> ArgArg n)
 
 let h_auto n lems l =
-  Refiner.abstract_tactic (TacAuto (inj_or_var n,lems,l))
+  Refiner.abstract_tactic (TacAuto (inj_or_var n,List.map snd lems,l))
     (gen_auto n lems l)
 
 (**************************************************************************)
@@ -1117,7 +1389,7 @@ let dauto (n,p) lems =
 let default_dauto = dauto (None,None) []
 
 let h_dauto (n,p) lems =
-  Refiner.abstract_tactic (TacDAuto (inj_or_var n,p,lems))
+  Refiner.abstract_tactic (TacDAuto (inj_or_var n,p,List.map snd lems))
     (dauto (n,p) lems)
 
 (***************************************)
diff --git a/tactics/auto.mli b/tactics/auto.mli
index eef6a0ee..521c5ed2 100644
--- a/tactics/auto.mli
+++ b/tactics/auto.mli
@@ -1,14 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: auto.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Util
 open Names
 open Term
@@ -22,31 +19,52 @@ open Evd
 open Libnames
 open Vernacexpr
 open Mod_subst
-(*i*)
 
-type auto_tactic =
-  | Res_pf     of constr * clausenv    (* Hint Apply *)
-  | ERes_pf    of constr * clausenv    (* Hint EApply *)
+(** Auto and related automation tactics *)
+
+type 'a auto_tactic =
+  | Res_pf     of constr * 'a    (** Hint Apply *)
+  | ERes_pf    of constr * 'a    (** Hint EApply *)
   | Give_exact of constr
-  | Res_pf_THEN_trivial_fail of constr * clausenv (* Hint Immediate *)
-  | Unfold_nth of evaluable_global_reference          (* Hint Unfold *)
-  | Extern     of Tacexpr.glob_tactic_expr   (* Hint Extern *)
+  | Res_pf_THEN_trivial_fail of constr * 'a (** Hint Immediate *)
+  | Unfold_nth of evaluable_global_reference          (** Hint Unfold *)
+  | Extern     of Tacexpr.glob_tactic_expr   (** Hint Extern *)
 
-open Rawterm
+open Glob_term
 
-type pri_auto_tactic = {
-  pri   : int;            (* A number between 0 and 4, 4 = lower priority *)
-  pat   : constr_pattern option; (* A pattern for the concl of the Goal *)
-  code  : auto_tactic;    (* the tactic to apply when the concl matches pat *)
+type hints_path_atom = 
+  | PathHints of global_reference list
+  | PathAny
+
+type 'a gen_auto_tactic = {
+  pri   : int;            (** A number between 0 and 4, 4 = lower priority *)
+  pat   : constr_pattern option; (** A pattern for the concl of the Goal *)
+  name  : hints_path_atom; (** A potential name to refer to the hint *) 
+  code  : 'a auto_tactic; (** the tactic to apply when the concl matches pat *)
 }
 
-type stored_data = pri_auto_tactic
+type pri_auto_tactic = clausenv gen_auto_tactic
+
+type stored_data = int * clausenv gen_auto_tactic
 
 type search_entry
 
-(* The head may not be bound. *)
+(** The head may not be bound. *)
 
-type hint_entry = global_reference option * pri_auto_tactic
+type hint_entry = global_reference option * types gen_auto_tactic
+
+type hints_path =
+  | PathAtom of hints_path_atom
+  | PathStar of hints_path
+  | PathSeq of hints_path * hints_path
+  | PathOr of hints_path * hints_path
+  | PathEmpty
+  | PathEpsilon
+
+val normalize_path : hints_path -> hints_path
+val path_matches : hints_path -> hints_path_atom list -> bool
+val path_derivate : hints_path -> hints_path_atom -> hints_path
+val pp_hints_path : hints_path -> Pp.std_ppcmds
 
 module Hint_db :
   sig
@@ -58,12 +76,17 @@ module Hint_db :
     val map_auto : global_reference * constr -> t -> pri_auto_tactic list
     val add_one : hint_entry -> t -> t
     val add_list : (hint_entry) list -> t -> t
-    val iter : (global_reference option -> stored_data list -> unit) -> t -> unit
+    val remove_one : global_reference -> t -> t
+    val remove_list : global_reference list -> t -> t
+    val iter : (global_reference option -> pri_auto_tactic list -> unit) -> t -> unit
 
     val use_dn : t -> bool
     val transparent_state : t -> transparent_state
     val set_transparent_state : t -> transparent_state -> t
 
+    val add_cut : hints_path -> t -> t
+    val cut : t -> hints_path
+
     val unfolds : t -> Idset.t * Cset.t
   end
 
@@ -72,8 +95,9 @@ type hint_db_name = string
 type hint_db = Hint_db.t
 
 type hints_entry =
-  | HintsResolveEntry of (int option * bool * constr) list
-  | HintsImmediateEntry of constr list
+  | HintsResolveEntry of (int option * bool * hints_path_atom * constr) list
+  | HintsImmediateEntry of (hints_path_atom * constr) list
+  | HintsCutEntry of hints_path
   | HintsUnfoldEntry of evaluable_global_reference list
   | HintsTransparencyEntry of evaluable_global_reference list * bool
   | HintsExternEntry of
@@ -85,19 +109,23 @@ val searchtable_map : hint_db_name -> hint_db
 
 val searchtable_add : (hint_db_name * hint_db) -> unit
 
-(* [create_hint_db local name st use_dn].
+(** [create_hint_db local name st use_dn].
    [st] is a transparency state for unification using this db
    [use_dn] switches the use of the discrimination net for all hints
    and patterns. *)
 
 val create_hint_db : bool -> hint_db_name -> transparent_state -> bool -> unit
 
+val remove_hints : bool -> hint_db_name list -> global_reference list -> unit
+
 val current_db_names : unit -> hint_db_name list
 
 val interp_hints : hints_expr -> hints_entry
 
 val add_hints : locality_flag -> hint_db_name list -> hints_entry -> unit
 
+val prepare_hint : env -> open_constr -> constr
+
 val print_searchtable : unit -> unit
 
 val print_applicable_hint : unit -> unit
@@ -108,13 +136,13 @@ val print_hint_db_by_name : hint_db_name -> unit
 
 val print_hint_db : Hint_db.t -> unit
 
-(* [make_exact_entry pri (c, ctyp)].
+(** [make_exact_entry pri (c, ctyp)].
    [c] is the term given as an exact proof to solve the goal;
    [ctyp] is the type of [c]. *)
 
-val make_exact_entry : evar_map -> int option -> constr * constr -> hint_entry
+val make_exact_entry : evar_map -> int option -> ?name:hints_path_atom -> constr * constr -> hint_entry
 
-(* [make_apply_entry (eapply,verbose) pri (c,cty)].
+(** [make_apply_entry (eapply,hnf,verbose) pri (c,cty)].
    [eapply] is true if this hint will be used only with EApply;
    [hnf] should be true if we should expand the head of cty before searching for
    products;
@@ -122,21 +150,21 @@ val make_exact_entry : evar_map -> int option -> constr * constr -> hint_entry
    [cty] is the type of [c]. *)
 
 val make_apply_entry :
-  env -> evar_map -> bool * bool * bool -> int option -> constr * constr
-      -> hint_entry
+  env -> evar_map -> bool * bool * bool -> int option -> ?name:hints_path_atom -> 
+  constr * constr -> hint_entry
 
-(* A constr which is Hint'ed will be:
-   (1) used as an Exact, if it does not start with a product
-   (2) used as an Apply, if its HNF starts with a product, and
-       has no missing arguments.
-   (3) used as an EApply, if its HNF starts with a product, and
-       has missing arguments. *)
+(** A constr which is Hint'ed will be:
+   - (1) used as an Exact, if it does not start with a product
+   - (2) used as an Apply, if its HNF starts with a product, and
+         has no missing arguments.
+   - (3) used as an EApply, if its HNF starts with a product, and
+         has missing arguments. *)
 
 val make_resolves :
-  env -> evar_map -> bool * bool * bool -> int option -> constr ->
-      hint_entry list
+  env -> evar_map -> bool * bool * bool -> int option -> ?name:hints_path_atom -> 
+  constr -> hint_entry list
 
-(* [make_resolve_hyp hname htyp].
+(** [make_resolve_hyp hname htyp].
    used to add an hypothesis to the local hint database;
    Never raises a user exception;
    If the hyp cannot be used as a Hint, the empty list is returned. *)
@@ -144,7 +172,7 @@ val make_resolves :
 val make_resolve_hyp :
   env -> evar_map -> named_declaration -> hint_entry list
 
-(* [make_extern pri pattern tactic_expr] *)
+(** [make_extern pri pattern tactic_expr] *)
 
 val make_extern :
   int -> constr_pattern option -> Tacexpr.glob_tactic_expr
@@ -161,11 +189,11 @@ val set_extern_subst_tactic :
   (substitution -> Tacexpr.glob_tactic_expr -> Tacexpr.glob_tactic_expr)
   -> unit
 
-(* Create a Hint database from the pairs (name, constr).
+(** Create a Hint database from the pairs (name, constr).
    Useful to take the current goal hypotheses as hints;
    Boolean tells if lemmas with evars are allowed *)
 
-val make_local_hint_db : bool -> constr list -> goal sigma -> hint_db
+val make_local_hint_db : ?ts:transparent_state -> bool -> open_constr list -> goal sigma -> hint_db
 
 val priority : ('a * pri_auto_tactic) list -> ('a * pri_auto_tactic) list
 
@@ -173,63 +201,69 @@ val default_search_depth : int ref
 
 val auto_unif_flags : Unification.unify_flags
 
-(* Try unification with the precompiled clause, then use registered Apply *)
+(** Try unification with the precompiled clause, then use registered Apply *)
 val unify_resolve_nodelta : (constr * clausenv) -> tactic
 
 val unify_resolve : Unification.unify_flags -> (constr * clausenv) -> tactic
 
-(* [ConclPattern concl pat tacast]:
+(** [ConclPattern concl pat tacast]:
    if the term concl matches the pattern pat, (in sense of
    [Pattern.somatches], then replace [?1] [?2] metavars in tacast by the
    right values to build a tactic *)
 
 val conclPattern : constr -> constr_pattern option -> Tacexpr.glob_tactic_expr -> tactic
 
-(* The Auto tactic *)
+(** The Auto tactic *)
 
-val auto : int -> constr list -> hint_db_name list -> tactic
+(** The use of the "core" database can be de-activated by passing
+    "nocore" amongst the databases. *)
 
-(* Auto with more delta. *)
+val make_db_list : hint_db_name list -> hint_db list
 
-val new_auto : int -> constr list -> hint_db_name list -> tactic
+val auto : int -> open_constr list -> hint_db_name list -> tactic
 
-(* auto with default search depth and with the hint database "core" *)
+(** Auto with more delta. *)
+
+val new_auto : int -> open_constr list -> hint_db_name list -> tactic
+
+(** auto with default search depth and with the hint database "core" *)
 val default_auto : tactic
 
-(* auto with all hint databases except the "v62" compatibility database *)
-val full_auto : int -> constr list -> tactic
+(** auto with all hint databases except the "v62" compatibility database *)
+val full_auto : int -> open_constr list -> tactic
 
-(* auto with all hint databases except the "v62" compatibility database
+(** auto with all hint databases except the "v62" compatibility database
    and doing delta *)
-val new_full_auto : int -> constr list -> tactic
+val new_full_auto : int -> open_constr list -> tactic
 
-(* auto with default search depth and with all hint databases
+(** auto with default search depth and with all hint databases
    except the "v62" compatibility database *)
 val default_full_auto : tactic
 
-(* The generic form of auto (second arg [None] means all bases) *)
-val gen_auto : int option -> constr list -> hint_db_name list option -> tactic
+(** The generic form of auto (second arg [None] means all bases) *)
+val gen_auto : int option -> open_constr list -> hint_db_name list option -> tactic
 
-(* The hidden version of auto *)
-val h_auto   : int option -> constr list -> hint_db_name list option -> tactic
+(** The hidden version of auto *)
+val h_auto   : int option -> open_constr list -> hint_db_name list option -> tactic
 
-(* Trivial *)
-val trivial : constr list -> hint_db_name list -> tactic
-val gen_trivial : constr list -> hint_db_name list option -> tactic
-val full_trivial : constr list -> tactic
-val h_trivial : constr list -> hint_db_name list option -> tactic
+(** Trivial *)
+val trivial : open_constr list -> hint_db_name list -> tactic
+val gen_trivial : open_constr list -> hint_db_name list option -> tactic
+val full_trivial : open_constr list -> tactic
+val h_trivial : open_constr list -> hint_db_name list option -> tactic
 
-val pr_autotactic : auto_tactic -> Pp.std_ppcmds
+val pr_autotactic : 'a auto_tactic -> Pp.std_ppcmds
 
-(*s The following is not yet up to date -- Papageno. *)
+(** {6 The following is not yet up to date -- Papageno. } *)
 
-(* DAuto *)
-val dauto : int option * int option -> constr list -> tactic
+(** DAuto *)
+val dauto : int option * int option -> open_constr list -> tactic
 val default_search_decomp : int ref
 val default_dauto : tactic
 
-val h_dauto : int option * int option -> constr list -> tactic
-(* SuperAuto *)
+val h_dauto : int option * int option -> open_constr list -> tactic
+
+(** SuperAuto *)
 
 type autoArguments =
   | UsingTDB
@@ -241,4 +275,4 @@ val superauto : int -> (identifier * constr) list -> autoArguments list -> tacti
 
 val h_superauto : int option -> reference list -> bool -> bool -> tactic
 
-val auto_init : (unit -> unit) ref
+val add_auto_init : (unit -> unit) -> unit
diff --git a/tactics/autorewrite.ml b/tactics/autorewrite.ml
index 2a41a8e5..a974c76a 100644
--- a/tactics/autorewrite.ml
+++ b/tactics/autorewrite.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: autorewrite.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Equality
 open Hipattern
 open Names
@@ -19,7 +17,7 @@ open Tactics
 open Term
 open Termops
 open Util
-open Rawterm
+open Glob_term
 open Vernacinterp
 open Tacexpr
 open Mod_subst
@@ -36,7 +34,7 @@ let subst_hint subst hint =
   let typ' = subst_mps subst hint.rew_type in
   let pat' = subst_mps subst hint.rew_pat in
   let t' = Tacinterp.subst_tactic subst hint.rew_tac in
-    if hint.rew_lemma == cst' && hint.rew_tac == t' then hint else
+    if hint.rew_lemma == cst' && hint.rew_type == typ' && hint.rew_tac == t' then hint else
       { hint with
 	rew_lemma = cst'; rew_type = typ';
 	rew_pat = pat';	rew_tac = t' }
@@ -119,7 +117,7 @@ let autorewrite ?(conds=Naive) tac_main lbas =
        tclTHEN tac
         (one_base (fun dir c tac ->
 	  let tac = tac, conds in
-	    general_rewrite dir all_occurrences false ~tac c)
+	    general_rewrite dir all_occurrences true false ~tac c)
 	  tac_main bas))
       tclIDTAC lbas))
 
@@ -132,16 +130,16 @@ let autorewrite_multi_in ?(conds=Naive) idl tac_main lbas : tactic =
   let to_be_cleared = ref false in
    fun dir cstr tac gl ->
     let last_hyp_id =
-     match (Environ.named_context_of_val gl.Evd.it.Evd.evar_hyps) with
+     match Tacmach.pf_hyps gl with
         (last_hyp_id,_,_)::_ -> last_hyp_id
       | _ -> (* even the hypothesis id is missing *)
              error ("No such hypothesis: " ^ (string_of_id !id) ^".")
     in
-    let gl' = general_rewrite_in dir all_occurrences ~tac:(tac, conds) false !id cstr false gl in
-    let gls = (fst gl').Evd.it in
+    let gl' = general_rewrite_in dir all_occurrences true ~tac:(tac, conds) false !id cstr false gl in
+    let gls = gl'.Evd.it in
     match gls with
        g::_ ->
-        (match Environ.named_context_of_val g.Evd.evar_hyps with
+        (match Environ.named_context_of_val (Goal.V82.hyps gl'.Evd.sigma g) with
             (lastid,_,_)::_ ->
               if last_hyp_id <> lastid then
                begin
@@ -225,7 +223,7 @@ let classify_hintrewrite x = Libobject.Substitute x
 
 
 (* Declaration of the Hint Rewrite library object *)
-let (inHintRewrite,_)=
+let inHintRewrite : string * HintDN.t -> Libobject.obj =
   Libobject.declare_object {(Libobject.default_object "HINT_REWRITE") with
     Libobject.cache_function = cache_hintrewrite;
     Libobject.load_function = (fun _ -> cache_hintrewrite);
@@ -248,7 +246,7 @@ type hypinfo = {
 
 let evd_convertible env evd x y =
   try
-    ignore(Unification.w_unify true env Reduction.CONV x y evd); true 
+    ignore(Unification.w_unify ~flags:Unification.elim_flags env evd Reduction.CONV x y); true 
   (* try ignore(Evarconv.the_conv_x env x y evd); true *)
   with _ -> false
 
diff --git a/tactics/autorewrite.mli b/tactics/autorewrite.mli
index ec285500..3205b041 100644
--- a/tactics/autorewrite.mli
+++ b/tactics/autorewrite.mli
@@ -1,34 +1,30 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: autorewrite.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Term
 open Tacexpr
 open Tacmach
 open Equality
-(*i*)
 
-(* Rewriting rules before tactic interpretation *)
+(** Rewriting rules before tactic interpretation *)
 type raw_rew_rule = Util.loc * Term.constr * bool * Tacexpr.raw_tactic_expr
 
-(* To add rewriting rules to a base *)
+(** To add rewriting rules to a base *)
 val add_rew_rules : string -> raw_rew_rule list -> unit
 
-(* The AutoRewrite tactic.
+(** The AutoRewrite tactic.
    The optional conditions tell rewrite how to handle matching and side-condition solving.
    Default is Naive: first match in the clause, don't look at the side-conditions to
    tell if the rewrite succeeded. *)
 val autorewrite : ?conds:conditions -> tactic -> string list -> tactic
 val autorewrite_in : ?conds:conditions -> Names.identifier -> tactic -> string list -> tactic
 
-(* Rewriting rules *)
+(** Rewriting rules *)
 type rew_rule = { rew_lemma: constr;
 		  rew_type: types;
 		  rew_pat: constr;
diff --git a/tactics/btermdn.ml b/tactics/btermdn.ml
index 119d8398..c13136b9 100644
--- a/tactics/btermdn.ml
+++ b/tactics/btermdn.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: btermdn.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Term
 open Names
 open Termdn
diff --git a/tactics/btermdn.mli b/tactics/btermdn.mli
index 22d3c3a2..55826df5 100644
--- a/tactics/btermdn.mli
+++ b/tactics/btermdn.mli
@@ -1,20 +1,16 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: btermdn.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Term
 open Pattern
 open Names
-(*i*)
 
-(* Discrimination nets with bounded depth. *)
+(** Discrimination nets with bounded depth. *)
 module Make :
   functor (Z : Map.OrderedType) ->
 sig
diff --git a/tactics/class_tactics.ml4 b/tactics/class_tactics.ml4
index 465d1d80..42df244d 100644
--- a/tactics/class_tactics.ml4
+++ b/tactics/class_tactics.ml4
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,8 +8,6 @@
 
 (*i camlp4deps: "parsing/grammar.cma" i*)
 
-(* $Id: class_tactics.ml4 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Pp
 open Util
 open Names
@@ -19,7 +17,6 @@ open Termops
 open Sign
 open Reduction
 open Proof_type
-open Proof_trees
 open Declarations
 open Tacticals
 open Tacmach
@@ -28,7 +25,7 @@ open Tactics
 open Pattern
 open Clenv
 open Auto
-open Rawterm
+open Glob_term
 open Hiddentac
 open Typeclasses
 open Typeclasses_errors
@@ -38,77 +35,57 @@ open Pfedit
 open Command
 open Libnames
 open Evd
+open Compat
 
-let default_eauto_depth = 100
 let typeclasses_db = "typeclass_instances"
+let typeclasses_debug = ref false
+let typeclasses_depth = ref None
 
-let _ = Auto.auto_init := (fun () ->
-  Auto.create_hint_db false typeclasses_db full_transparent_state true)
+let _ = 
+  Auto.add_auto_init 
+    (fun () -> Auto.create_hint_db false typeclasses_db full_transparent_state true)
 
 exception Found of evar_map
 
-let is_dependent ev evm =
-  Evd.fold (fun ev' evi dep ->
-    if ev = ev' then dep
-    else dep || occur_evar ev evi.evar_concl)
-    evm false
-
-let valid goals p res_sigma l =
-  let evm =
-    List.fold_left2
-      (fun sigma (ev, evi) prf ->
-	let cstr, obls = Refiner.extract_open_proof !res_sigma prf in
-	  if not (Evd.is_defined sigma ev) then
-	    Evd.define ev cstr sigma
-	  else sigma)
-      !res_sigma goals l
-  in raise (Found evm)
-
-let evar_filter evi =
-  let hyps' = evar_filtered_context evi in
-    { evi with 
-      evar_hyps = Environ.val_of_named_context hyps';
-      evar_filter = List.map (fun _ -> true) hyps' }
+(** We transform the evars that are concerned by this resolution
+    (according to predicate p) into goals.
+    Invariant: function p only manipulates undefined evars *)
 
 let evars_to_goals p evm =
   let goals, evm' =
-    Evd.fold
+    Evd.fold_undefined
       (fun ev evi (gls, evm') ->
-	if evi.evar_body = Evar_empty then
-	  let evi', goal = p evm ev evi in
-	    if goal then
-	      ((ev, evi') :: gls, Evd.add evm' ev evi')
-	    else (gls, Evd.add evm' ev evi')
-	else (gls, Evd.add evm' ev evi))
-      evm ([], Evd.empty)
+	let evi', goal = p evm ev evi in
+	let gls' = if goal then (ev,Goal.V82.build ev) :: gls else gls in
+	(gls', Evd.add evm' ev evi'))
+      evm ([], Evd.defined_evars evm)
   in
-    if goals = [] then None
-    else
-      let goals = List.rev goals in
-      let evm' = evars_reset_evd ~with_conv_pbs:false evm' evm in
-	Some (goals, evm')
+  if goals = [] then None else Some (List.rev goals, evm')
 
 (** Typeclasses instance search tactic / eauto *)
 
-let intersects s t =
-  Intset.exists (fun el -> Intset.mem el t) s
-
 open Auto
 
 let e_give_exact flags c gl = 
   let t1 = (pf_type_of gl c) in
     tclTHEN (Clenvtac.unify ~flags t1) (exact_no_check c) gl
 
-let assumption flags id = e_give_exact flags (mkVar id)
-
 open Unification
 
 let auto_unif_flags = {
   modulo_conv_on_closed_terms = Some full_transparent_state;
-  use_metas_eagerly = true;
+  use_metas_eagerly_in_conv_on_closed_terms = true;
   modulo_delta = var_full_transparent_state;
+  modulo_delta_types = full_transparent_state;
+  check_applied_meta_types = false;
   resolve_evars = false;
-  use_evars_pattern_unification = true;
+  use_pattern_unification = true;
+  use_meta_bound_pattern_unification = true;
+  frozen_evars = ExistentialSet.empty;
+  restrict_conv_on_strict_subterms = false; (* ? *)
+  modulo_betaiota = true;
+  modulo_eta = true;
+  allow_K_in_toplevel_higher_order_unification = false
 }
 
 let rec eq_constr_mod_evars x y =
@@ -126,18 +103,18 @@ let progress_evars t gl =
   in tclTHEN t check gl
 
 TACTIC EXTEND progress_evars
-  [ "progress_evars" tactic(t) ] -> [ progress_evars (snd t) ]
+  [ "progress_evars" tactic(t) ] -> [ progress_evars (Tacinterp.eval_tactic t) ]
 END
 
 let unify_e_resolve flags (c,clenv) gls =
   let clenv' = connect_clenv gls clenv in
-  let clenv' = clenv_unique_resolver false ~flags clenv' gls in
-    tclPROGRESS (Clenvtac.clenv_refine true ~with_classes:false clenv') gls
+  let clenv' = clenv_unique_resolver ~flags clenv' gls in
+    Clenvtac.clenv_refine true ~with_classes:false clenv' gls
 
 let unify_resolve flags (c,clenv) gls =
   let clenv' = connect_clenv gls clenv in
-  let clenv' = clenv_unique_resolver false ~flags clenv' gls in
-    tclPROGRESS (Clenvtac.clenv_refine false ~with_classes:false clenv') gls
+  let clenv' = clenv_unique_resolver ~flags clenv' gls in
+    Clenvtac.clenv_refine false ~with_classes:false clenv' gls
 
 let clenv_of_prods nprods (c, clenv) gls =
   if nprods = 0 then Some clenv
@@ -157,7 +134,9 @@ let with_prods nprods (c, clenv) f gls =
 
 let flags_of_state st =
   {auto_unif_flags with
-    modulo_conv_on_closed_terms = Some st; modulo_delta = st}
+    modulo_conv_on_closed_terms = Some st; modulo_delta = st; 
+     modulo_delta_types = st;
+     modulo_eta = false}
 
 let rec e_trivial_fail_db db_list local_db goal =
   let tacl =
@@ -168,11 +147,11 @@ let rec e_trivial_fail_db db_list local_db goal =
 	  let hintl = make_resolve_hyp (pf_env g') (project g') d in
           (e_trivial_fail_db db_list
 	      (Hint_db.add_list hintl local_db) g'))) ::
-    (List.map (fun (x,_,_,_) -> x) (e_trivial_resolve db_list local_db (pf_concl goal)))
+    (List.map (fun (x,_,_,_,_) -> x) (e_trivial_resolve db_list local_db (pf_concl goal)))
   in 
   tclFIRST (List.map tclCOMPLETE tacl) goal 
 
-and e_my_find_search db_list local_db hdc concl =
+and e_my_find_search db_list local_db hdc complete concl =
   let hdc = head_of_constr_reference hdc in
   let prods, concl = decompose_prod_assum concl in
   let nprods = List.length prods in
@@ -188,7 +167,7 @@ and e_my_find_search db_list local_db hdc concl =
       (local_db::db_list)
   in
   let tac_of_hint =
-    fun (flags, {pri=b; pat = p; code=t}) ->
+    fun (flags, {pri = b; pat = p; code = t; name = name}) ->
       let tac =
 	match t with
 	  | Res_pf (term,cl) -> with_prods nprods (term,cl) (unify_resolve flags)
@@ -196,66 +175,55 @@ and e_my_find_search db_list local_db hdc concl =
 	  | Give_exact (c) -> e_give_exact flags c
 	  | Res_pf_THEN_trivial_fail (term,cl) ->
               tclTHEN (with_prods nprods (term,cl) (unify_e_resolve flags))
-		(e_trivial_fail_db db_list local_db)
+	        (if complete then tclIDTAC else e_trivial_fail_db db_list local_db)
 	  | Unfold_nth c -> tclWEAK_PROGRESS (unfold_in_concl [all_occurrences,c])
-	  | Extern tacast -> conclPattern concl p tacast
+	  | Extern tacast -> 
+(* 	    tclTHEN *)
+(* 	      (fun gl -> Refiner.tclEVARS (mark_unresolvables (project gl)) gl) *)
+	      (conclPattern concl p tacast)
       in
+      let tac = if complete then tclCOMPLETE tac else tac in
 	match t with
-	| Extern _ -> (tac,b,true,lazy (pr_autotactic t))
-	| _ -> (tac,b,false,lazy (pr_autotactic t))
+	| Extern _ -> (tac,b,true, name, lazy (pr_autotactic t))
+	| _ -> 
+(* 	  let tac gl = with_pattern (pf_env gl) (project gl) flags p concl tac gl in *)
+	    (tac,b,false, name, lazy (pr_autotactic t))
   in List.map tac_of_hint hintl
 
 and e_trivial_resolve db_list local_db gl =
   try
     e_my_find_search db_list local_db
-      (fst (head_constr_bound gl)) gl
+    (fst (head_constr_bound gl)) true gl
   with Bound | Not_found -> []
 
 let e_possible_resolve db_list local_db gl =
   try
     e_my_find_search db_list local_db
-      (fst (head_constr_bound gl)) gl
+      (fst (head_constr_bound gl)) false gl
   with Bound | Not_found -> []
 
 let rec catchable = function
   | Refiner.FailError _ -> true
-  | Stdpp.Exc_located (_, e) -> catchable e
+  | Loc.Exc_located (_, e) -> catchable e
   | e -> Logic.catchable_exception e
 
-let is_dep gl gls =
-  let evs = Evarutil.evars_of_term gl.evar_concl in
-    if evs = Intset.empty then false
-    else
-      List.fold_left
-	(fun b gl ->
-	  if b then b
-	  else
-	    let evs' = Evarutil.evars_of_term gl.evar_concl in
-	      intersects evs evs')
-	false gls
-
-let is_ground gl =
-  Evarutil.is_ground_term (project gl) (pf_concl gl)
-
 let nb_empty_evars s =
-  Evd.fold (fun ev evi acc -> if evi.evar_body = Evar_empty then succ acc else acc) s 0
+  Evd.fold_undefined (fun ev evi acc -> succ acc) s 0
 
-let pr_ev evs ev = Printer.pr_constr_env (Evd.evar_env ev) (Evarutil.nf_evar evs ev.Evd.evar_concl)
-
-let typeclasses_debug = ref false
-
-type validation = evar_map -> proof_tree list -> proof_tree
+let pr_ev evs ev = Printer.pr_constr_env (Goal.V82.env evs ev) (Evarutil.nf_evar evs (Goal.V82.concl evs ev))
 
 let pr_depth l = prlist_with_sep (fun () -> str ".") pr_int (List.rev l)
 
 type autoinfo = { hints : Auto.hint_db; is_evar: existential_key option;
-		  only_classes: bool; auto_depth: int list; auto_last_tac: std_ppcmds Lazy.t}
+		  only_classes: bool; auto_depth: int list; auto_last_tac: std_ppcmds Lazy.t;
+		  auto_path : global_reference option list;
+		  auto_cut : hints_path }
 type autogoal = goal * autoinfo
 type 'ans fk = unit -> 'ans
 type ('a,'ans) sk = 'a -> 'ans fk -> 'ans
 type 'a tac = { skft : 'ans. ('a,'ans) sk -> 'ans fk -> autogoal sigma -> 'ans }
 
-type auto_result = autogoal list sigma * validation
+type auto_result = autogoal list sigma
 
 type atac = auto_result tac
 
@@ -272,26 +240,67 @@ let make_resolve_hyp env sigma st flags only_classes pri (id, _, cty) =
 	       if not (eq_constr ty' ar) then iscl env' ty'
 	       else false
   in
-  let keep = not only_classes || iscl env cty in
-    if keep then let c = mkVar id in
-      map_succeed 
-	(fun f -> try f (c,cty) with UserError _ -> failwith "") 
-	[make_exact_entry sigma pri; make_apply_entry env sigma flags pri]
+  let is_class = iscl env cty in
+  let keep = not only_classes || is_class in
+    if keep then 
+      let c = mkVar id in
+      let name = PathHints [VarRef id] in
+      let hints =
+	if is_class then
+	  let hints = build_subclasses ~check:false env sigma (VarRef id) None in
+	    (list_map_append
+	       (fun (pri, c) -> make_resolves env sigma 
+		  (true,false,Flags.is_verbose()) pri c) 
+	       hints)
+	else []
+      in
+        (hints @ map_succeed 
+	 (fun f -> try f (c,cty) with UserError _ -> failwith "") 
+	 [make_exact_entry ~name sigma pri; make_apply_entry ~name env sigma flags pri])
     else []
 
 let pf_filtered_hyps gls = 
-  evar_filtered_context (sig_it gls)
+  Goal.V82.hyps gls.Evd.sigma (sig_it gls)
+
+let make_hints g st only_classes sign =
+  let paths, hintlist = 
+    List.fold_left 
+    (fun (paths, hints) hyp ->
+     if is_section_variable (pi1 hyp) then (paths, hints)
+     else
+       let path, hint = 		    
+	 PathEmpty, pf_apply make_resolve_hyp g st (true,false,false) only_classes None hyp
+       in
+	 (PathOr (paths, path), hint @ hints))
+    (PathEmpty, []) sign
+  in Hint_db.add_list hintlist (Hint_db.empty st true)
+
+let autogoal_hints_cache : (Environ.named_context_val * hint_db) option ref = ref None
+let freeze () = !autogoal_hints_cache
+let unfreeze v = autogoal_hints_cache := v
+let init () = autogoal_hints_cache := None
+
+let _ = init ()
 
-let make_autogoal_hints only_classes ?(st=full_transparent_state) g =
-  let sign = pf_filtered_hyps g in
-  let hintlist = list_map_append (pf_apply make_resolve_hyp g st (true,false,false) only_classes None) sign in
-    Hint_db.add_list hintlist (Hint_db.empty st true)
-  
+let _ =
+  Summary.declare_summary "autogoal-hints-cache"
+    { Summary.freeze_function = freeze;
+      Summary.unfreeze_function = unfreeze;
+      Summary.init_function = init }
+    
+let make_autogoal_hints = 
+  fun only_classes ?(st=full_transparent_state) g ->
+    let sign = pf_filtered_hyps g in
+      match freeze () with
+      | Some (sign', hints) when Environ.eq_named_context_val sign sign' -> hints
+      | _ -> let hints = make_hints g st only_classes (Environ.named_context_of_val sign) in
+	  unfreeze (Some (sign, hints)); hints
+	  
 let lift_tactic tac (f : goal list sigma -> autoinfo -> autogoal list sigma) : 'a tac =
   { skft = fun sk fk {it = gl,hints; sigma=s} ->
     let res = try Some (tac {it=gl; sigma=s}) with e when catchable e -> None in
       match res with
-      | Some (gls,v) -> sk (f gls hints, fun _ -> v) fk
+      | Some gls -> sk (f gls hints) fk
       | None -> fk () }
 
 let intro_tac : atac =
@@ -299,28 +308,22 @@ let intro_tac : atac =
     (fun {it = gls; sigma = s} info ->
       let gls' =
 	List.map (fun g' ->
-	  let env = evar_env g' in
+	  let env = Goal.V82.env s g' in
+	  let context = Environ.named_context_of_val (Goal.V82.hyps s g') in
 	  let hint = make_resolve_hyp env s (Hint_db.transparent_state info.hints) 
-	    (true,false,false) info.only_classes None (List.hd (evar_context g')) in
+	    (true,false,false) info.only_classes None (List.hd context) in
 	  let ldb = Hint_db.add_list hint info.hints in
 	    (g', { info with is_evar = None; hints = ldb; auto_last_tac = lazy (str"intro") })) gls
       in {it = gls'; sigma = s})
 
 let normevars_tac : atac = 
-  lift_tactic tclNORMEVAR
-    (fun {it = gls; sigma = s} info ->
-      let gls' =
-	List.map (fun g' ->
-	  (g', { info with auto_last_tac = lazy (str"NORMEVAR") })) gls
-      in {it = gls'; sigma = s})
-
-
-let id_tac : atac =
-  { skft = fun sk fk {it = gl; sigma = s} ->
-    sk ({it = [gl]; sigma = s}, fun _ pfs -> List.hd pfs) fk }
+  { skft = fun sk fk {it = (gl, info); sigma = s} ->
+    let gl', sigma' = Goal.V82.nf_evar s gl in
+    let info' = { info with auto_last_tac = lazy (str"normevars") } in
+      sk {it = [gl', info']; sigma = sigma'} fk }
 
 (* Ordering of states is lexicographic on the number of remaining goals. *)
-let compare (pri, _, _, (res, _)) (pri', _, _, (res', _)) =
+let compare (pri, _, _, res) (pri', _, _, res') =
   let nbgoals s =
     List.length (sig_it s) + nb_empty_evars (sig_sig s)
   in
@@ -331,131 +334,104 @@ let compare (pri, _, _, (res, _)) (pri', _, _, (res', _)) =
 let or_tac (x : 'a tac) (y : 'a tac) : 'a tac =
   { skft = fun sk fk gls -> x.skft sk (fun () -> y.skft sk fk gls) gls }
 
-let solve_tac (x : 'a tac) : 'a tac =
-  { skft = fun sk fk gls -> x.skft (fun ({it = gls},_ as res) fk -> 
-    if gls = [] then sk res fk else fk ()) fk gls }
-
-let solve_unif_tac : atac =
-  { skft = fun sk fk {it = gl; sigma = s} -> 
-    try let s' = Evarconv.consider_remaining_unif_problems (Global.env ()) s in
-	  normevars_tac.skft sk fk ({it=gl; sigma=s'})
-    with _ -> fk () }
-
 let hints_tac hints =
   { skft = fun sk fk {it = gl,info; sigma = s} ->
-    let possible_resolve ((lgls,v) as res, pri, b, pp) =
-      (pri, pp, b, res)
-    in
-    let tacs =
-      let concl = gl.evar_concl in
+      let concl = Goal.V82.concl s gl in
+      let tacgl = {it = gl; sigma = s} in
       let poss = e_possible_resolve hints info.hints concl in
-      let l =
-	let tacgl = {it = gl; sigma = s} in
-	Util.list_map_append (fun (tac, pri, b, pptac) ->
-	  try [tac tacgl, pri, b, pptac] with e when catchable e -> [])
-	  poss
-      in
-	if l = [] && !typeclasses_debug then
-	  msgnl (pr_depth info.auto_depth ++ str": no match for " ++
-		    Printer.pr_constr_env (Evd.evar_env gl) concl ++
-		    spc () ++ int (List.length poss) ++ str" possibilities");
-	List.map possible_resolve l
-    in
-    let tacs = List.sort compare tacs in
-    let rec aux i = function
-      | (_, pp, b, ({it = gls; sigma = s}, v)) :: tl ->
-	  if !typeclasses_debug then msgnl (pr_depth (i :: info.auto_depth) ++ str": " ++ Lazy.force pp
-					       ++ str" on" ++ spc () ++ pr_ev s gl);
-	  let fk =
-	    (fun () -> (* if !typeclasses_debug then msgnl (str"backtracked after " ++ pp); *)
-	    aux (succ i) tl)
+      let rec aux i foundone = function
+	| (tac, _, b, name, pp) :: tl ->
+	  let derivs = path_derivate info.auto_cut name in
+	  let res = 
+            try
+		if path_matches derivs [] then None else Some (tac tacgl)
+	    with e when catchable e -> None 
 	  in
-	  let sgls = evars_to_goals (fun evm ev evi ->
-	    if Typeclasses.is_resolvable evi && 
-	      (not info.only_classes || Typeclasses.is_class_evar evm evi) then
-	      Typeclasses.mark_unresolvable evi, true
-	    else evi, false) s
-	  in
-	  let nbgls, newgls, s' =
-	    let gls' = List.map (fun g -> (None, g)) gls in
-	    match sgls with
-	    | None -> List.length gls', gls', s
-	    | Some (evgls, s') ->
-		(List.length gls', gls' @ List.map (fun (ev, x) -> (Some ev, x)) evgls, s')
-	  in
-	  let gls' = list_map_i (fun j (evar, g) -> 
-	    let info = 
-	      { info with auto_depth = j :: i :: info.auto_depth; auto_last_tac = pp;
-		is_evar = evar;
-		hints = 
-		  if b && g.evar_hyps <> gl.evar_hyps 
-		  then make_autogoal_hints info.only_classes
-		    ~st:(Hint_db.transparent_state info.hints) {it = g; sigma = s'}
-		  else info.hints }
-	    in g, info) 1 newgls in
-	  let glsv = {it = gls'; sigma = s'}, (fun _ pfl -> v (list_firstn nbgls pfl)) in
-	    sk glsv fk
-      | [] -> fk ()
-    in aux 1 tacs }
-
-let evars_of_term c =
-  let rec evrec acc c =
-    match kind_of_term c with
-    | Evar (n, _) -> Intset.add n acc
-    | _ -> fold_constr evrec acc c
-  in evrec Intset.empty c
-
-exception Found_evar of int
-
-let occur_evars evars c =
-  try
-    let rec evrec c =
-      match kind_of_term c with
-      | Evar (n, _) -> if Intset.mem n evars then raise (Found_evar n) else ()
-      | _ -> iter_constr evrec c
-    in evrec c; false
-  with Found_evar _ -> true
-
-let dependent only_classes evd oev concl =
-  let concl_evars = Intset.union (evars_of_term concl)
-    (Option.cata Intset.singleton Intset.empty oev)
-  in not (Intset.is_empty concl_evars) 
+	    (match res with
+	       | None -> aux i foundone tl
+	       | Some {it = gls; sigma = s'} ->
+	    	   if !typeclasses_debug then
+		     msgnl (pr_depth (i :: info.auto_depth) ++ str": " ++ Lazy.force pp
+			    ++ str" on" ++ spc () ++ pr_ev s gl);
+		   let fk =
+		     (fun () -> if !typeclasses_debug then msgnl (str"backtracked after " ++ Lazy.force pp);
+			aux (succ i) true tl)
+		   in
+		   let sgls =
+		     evars_to_goals
+		       (fun evm ev evi ->
+			  if Typeclasses.is_resolvable evi &&
+			    (not info.only_classes || Typeclasses.is_class_evar evm evi)
+			  then Typeclasses.mark_unresolvable evi, true
+			  else evi, false) s'
+		   in
+		   let newgls, s' =
+		     let gls' = List.map (fun g -> (None, g)) gls in
+		       match sgls with
+		       | None -> gls', s'
+		       | Some (evgls, s') ->
+			 (* Reorder with dependent subgoals. *)
+			 (gls' @ List.map (fun (ev, x) -> Some ev, x) evgls, s')
+		   in
+		   let gls' = list_map_i
+		     (fun j (evar, g) ->
+			let info =
+			  { info with auto_depth = j :: i :: info.auto_depth; auto_last_tac = pp;
+			      is_evar = evar;
+			      hints =
+			      if b && not (Environ.eq_named_context_val (Goal.V82.hyps s' g) (Goal.V82.hyps s' gl))
+			      then make_autogoal_hints info.only_classes
+				~st:(Hint_db.transparent_state info.hints) {it = g; sigma = s'}
+			      else info.hints;
+			      auto_cut = derivs }
+			in g, info) 1 newgls in
+		   let glsv = {it = gls'; sigma = s'} in
+		     sk glsv fk)
+	| [] ->
+	  if not foundone && !typeclasses_debug then
+	    msgnl (pr_depth info.auto_depth ++ str": no match for " ++
+		     Printer.pr_constr_env (Goal.V82.env s gl) concl ++
+		     spc () ++ int (List.length poss) ++ str" possibilities");
+	  fk ()
+    in aux 1 false poss }
+
+let isProp env sigma concl = 
+  let ty = Retyping.get_type_of env sigma concl in
+    kind_of_term ty = Sort (Prop Null)
+
+let needs_backtrack only_classes env evd oev concl =
+  if oev = None || isProp env evd concl then
+    not (Intset.is_empty (Evarutil.evars_of_term concl))
+  else true
 
 let then_list (second : atac) (sk : (auto_result, 'a) sk) : (auto_result, 'a) sk =
-  let rec aux s (acc : (autogoal list * validation) list) fk = function
+  let rec aux s (acc : autogoal list list) fk = function
     | (gl,info) :: gls ->
-	second.skft (fun ({it=gls';sigma=s'},v') fk' ->
-	  let s', needs_backtrack = 
-	    if gls' = [] then
-	      match info.is_evar with
-	      | Some ev -> 
-		  let s' = 
-		    if Evd.is_defined s' ev then s' 
-		    else
-		      let prf = v' s' [] in
-		      let term, _ = Refiner.extract_open_proof s' prf in
-			Evd.define ev term s' 
-		  in s', dependent info.only_classes s' (Some ev) gl.evar_concl
-	      | None -> s', dependent info.only_classes s' None gl.evar_concl
-	    else s', true
-	  in
-	  let fk'' = if not needs_backtrack then
-	    (if !typeclasses_debug then msgnl (str"no backtrack on " ++ pr_ev s gl); fk) else fk' 
-	  in aux s' ((gls',v')::acc) fk'' gls)
-	  fk {it = (gl,info); sigma = s}
+	(match info.is_evar with 
+	 | Some ev when Evd.is_defined s ev -> aux s acc fk gls
+	 | _ -> 
+	     second.skft
+	       (fun {it=gls';sigma=s'} fk' ->
+		  let needs_backtrack = 
+		    if gls' = [] then
+ 		      needs_backtrack info.only_classes
+		        (Goal.V82.env s gl) s' info.is_evar (Goal.V82.concl s gl)
+		    else true
+		  in
+		  let fk'' = 
+		    if not needs_backtrack then
+		      (if !typeclasses_debug then msgnl (str"no backtrack on " ++ pr_ev s gl ++ 
+							 str " after " ++ Lazy.force info.auto_last_tac); fk) 
+		    else fk' 
+		  in aux s' (gls'::acc) fk'' gls)
+	       fk {it = (gl,info); sigma = s})
     | [] -> Some (List.rev acc, s, fk)
-  in fun ({it = gls; sigma = s},v) fk ->
+  in fun {it = gls; sigma = s} fk ->
     let rec aux' = function
       | None -> fk ()
       | Some (res, s', fk') ->
-	  let goals' = List.concat (List.map (fun (gls,v) -> gls) res) in
-	  let v' s' pfs' : proof_tree =
-	    let (newpfs, rest) = List.fold_left (fun (newpfs,pfs') (gls,v) ->
-	      let before, after = list_split_at (List.length gls) pfs' in
-		(v s' before :: newpfs, after))
-	      ([], pfs') res
-	    in assert(rest = []); v s' (List.rev newpfs)
-	  in sk ({it = goals'; sigma = s'}, v') (fun () -> aux' (fk' ()))
+	  let goals' = List.concat res in
+	    sk {it = goals'; sigma = s'} (fun () -> aux' (fk' ()))
     in aux' (aux s [] (fun () -> None) gls)
 
 let then_tac (first : atac) (second : atac) : atac =
@@ -468,52 +444,68 @@ type run_list_res = (auto_result * run_list_res fk) option
 
 let run_list_tac (t : 'a tac) p goals (gl : autogoal list sigma) : run_list_res =
   (then_list t (fun x fk -> Some (x, fk)))
-    (gl, fun s pfs -> valid goals p (ref s) pfs)
+    gl
     (fun _ -> None)
 
+let fail_tac : atac = 
+  { skft = fun sk fk _ -> fk () }
+
 let rec fix (t : 'a tac) : 'a tac =
   then_tac t { skft = fun sk fk -> (fix t).skft sk fk }
 
-let make_autogoal ?(only_classes=true) ?(st=full_transparent_state) ev g =
+let rec fix_limit limit (t : 'a tac) : 'a tac =
+  if limit = 0 then fail_tac 
+  else then_tac t { skft = fun sk fk -> (fix_limit (pred limit) t).skft sk fk }
+    
+let make_autogoal ?(only_classes=true) ?(st=full_transparent_state) cut ev g =
   let hints = make_autogoal_hints only_classes ~st g in
     (g.it, { hints = hints ; is_evar = ev; 
-	     only_classes = only_classes; auto_depth = []; auto_last_tac = lazy (mt()) })
+	     only_classes = only_classes; auto_depth = []; auto_last_tac = lazy (str"none");
+	     auto_path = []; auto_cut = cut })
       
-let make_autogoals ?(only_classes=true) ?(st=full_transparent_state) gs evm' =
+
+let cut_of_hints h =
+  List.fold_left (fun cut db -> PathOr (Hint_db.cut db, cut)) PathEmpty h
+
+let make_autogoals ?(only_classes=true) ?(st=full_transparent_state) hints gs evm' =
+  let cut = cut_of_hints hints in
   { it = list_map_i (fun i g -> 
-    let (gl, auto) = make_autogoal ~only_classes ~st (Some (fst g)) {it = snd g; sigma = evm'} in
+    let (gl, auto) = make_autogoal ~only_classes ~st cut (Some (fst g)) {it = snd g; sigma = evm'} in
       (gl, { auto with auto_depth = [i]})) 1 gs; sigma = evm' }
 
 let get_result r = 
   match r with
   | None -> None
-  | Some ((gls, v), fk) ->
-      try ignore(v (sig_sig gls) []); assert(false)
-      with Found evm' -> Some (evm', fk)
-
-let run_on_evars ?(only_classes=true) ?(st=full_transparent_state) p evm tac =
+  | Some (gls, fk) -> Some (gls.sigma,fk)
+	
+let run_on_evars ?(only_classes=true) ?(st=full_transparent_state) p evm hints tac =
   match evars_to_goals p evm with
   | None -> None (* This happens only because there's no evar having p *)
   | Some (goals, evm') ->
-      let res = run_list_tac tac p goals (make_autogoals ~only_classes ~st goals evm') in
+      let res = run_list_tac tac p goals (make_autogoals ~only_classes ~st hints goals evm') in
 	match get_result res with
 	| None -> raise Not_found
-	| Some (evm', fk) -> Some (evars_reset_evd evm' evm, fk)
+	| Some (evm', fk) -> Some (evars_reset_evd ~with_conv_pbs:true evm' evm, fk)
 	    
 let eauto_tac hints = 
-  fix (or_tac (then_tac normevars_tac (hints_tac hints)) intro_tac)
-  
-let eauto ?(only_classes=true) ?st hints g =
-  let gl = { it = make_autogoal ~only_classes ?st None g; sigma = project g } in
-    match run_tac (eauto_tac hints) gl with
+  then_tac normevars_tac (or_tac (hints_tac hints) intro_tac)
+
+let eauto_tac ?limit hints = 
+  match limit with
+  | None -> fix (eauto_tac hints)
+  | Some limit -> fix_limit limit (eauto_tac hints)
+      
+let eauto ?(only_classes=true) ?st ?limit hints g =
+  let gl = { it = make_autogoal ~only_classes ?st (cut_of_hints hints) None g; sigma = project g } in
+    match run_tac (eauto_tac ?limit hints) gl with
     | None -> raise Not_found
-    | Some ({it = goals; sigma = s}, valid) ->
-	{it = List.map fst goals; sigma = s}, valid s
+    | Some {it = goals; sigma = s} ->
+	{it = List.map fst goals; sigma = s}
 
-let real_eauto st hints p evd =
+let real_eauto st ?limit hints p evd =
   let rec aux evd fails =
     let res, fails =
-      try run_on_evars ~st p evd (eauto_tac hints), fails
+      try run_on_evars ~st p evd hints (eauto_tac ?limit hints), fails
       with Not_found ->
 	List.fold_right (fun fk (res, fails) ->
 	  match res with
@@ -526,162 +518,209 @@ let real_eauto st hints p evd =
       | Some (evd', fk) -> aux evd' (fk :: fails)
   in aux evd []
 
-let resolve_all_evars_once debug (mode, depth) p evd =
+let resolve_all_evars_once debug limit p evd =
   let db = searchtable_map typeclasses_db in
-    real_eauto (Hint_db.transparent_state db) [db] p evd
+    real_eauto ?limit (Hint_db.transparent_state db) [db] p evd
+
+(** We compute dependencies via a union-find algorithm.
+    Beware of the imperative effects on the partition structure,
+    it should not be shared, but only used locally. *)
+
+module Intpart = Unionfind.Make(Intset)(Intmap)
 
-exception FoundTerm of constr
+let deps_of_constraints cstrs evm p =
+  List.iter (fun (_, _, x, y) ->
+    let evx = Evarutil.undefined_evars_of_term evm x in
+    let evy = Evarutil.undefined_evars_of_term evm y in
+    Intpart.union_set (Intset.union evx evy) p)
+    cstrs
+
+let evar_dependencies evm p =
+  Evd.fold_undefined
+    (fun ev evi _ ->
+      let evars = Intset.add ev (Evarutil.undefined_evars_of_evar_info evm evi)
+      in Intpart.union_set evars p)
+    evm ()
 
 let resolve_one_typeclass env ?(sigma=Evd.empty) gl =
-  let gls = { it = Evd.make_evar (Environ.named_context_val env) gl; sigma = sigma } in
+  let nc, gl, subst, _ = Evarutil.push_rel_context_to_named_context env gl in
+  let (gl,t,sigma) = 
+    Goal.V82.mk_goal sigma nc gl Store.empty in
+  let gls = { it = gl ; sigma = sigma } in
   let hints = searchtable_map typeclasses_db in
-  let gls', v = eauto ~st:(Hint_db.transparent_state hints) [hints] gls in
-  let term = v [] in
+  let gls' = eauto ?limit:!typeclasses_depth ~st:(Hint_db.transparent_state hints) [hints] gls in
   let evd = sig_sig gls' in
-  let term = fst (Refiner.extract_open_proof evd term) in
-  let term = Evarutil.nf_evar evd term in
+  let t' = let (ev, inst) = destEvar t in
+    mkEvar (ev, Array.of_list subst)
+  in
+  let term = Evarutil.nf_evar evd t' in
     evd, term
 
 let _ =
   Typeclasses.solve_instanciation_problem := (fun x y z -> resolve_one_typeclass x ~sigma:y z)
 
-let has_undefined p oevd evd =
-  Evd.fold (fun ev evi has -> has ||
-    (evi.evar_body = Evar_empty && snd (p oevd ev evi)))
-    evd false
-
-let rec merge_deps deps = function
-  | [] -> [deps]
-  | hd :: tl ->
-      if intersects deps hd then
-	merge_deps (Intset.union deps hd) tl
-      else hd :: merge_deps deps tl
-
-let evars_of_evi evi =
-  Intset.union (evars_of_term evi.evar_concl)
-    (Intset.union
-	(match evi.evar_body with
-	| Evar_empty -> Intset.empty
-	| Evar_defined b -> evars_of_term b)
-	(Evarutil.evars_of_named_context (evar_filtered_context evi)))
-
-let deps_of_constraints cstrs deps =
-  List.fold_right (fun (_, _, x, y) deps -> 
-    let evs = Intset.union (evars_of_term x) (evars_of_term y) in
-      merge_deps evs deps)
-    cstrs deps
-      
-let evar_dependencies evm =
-  Evd.fold 
-    (fun ev evi acc ->
-      merge_deps (Intset.union (Intset.singleton ev) 
-		     (evars_of_evi evi)) acc)
-    evm []
+(** [split_evars] returns groups of undefined evars according to dependencies *)
 
 let split_evars evm =
-  let _, cstrs = extract_all_conv_pbs evm in
-  let evmdeps = evar_dependencies evm in
-  let deps = deps_of_constraints cstrs evmdeps in
-    List.sort Intset.compare deps
+  let p = Intpart.create () in
+  evar_dependencies evm p;
+  deps_of_constraints (snd (extract_all_conv_pbs evm)) evm p;
+  Intpart.partition p
+
+(** [evars_in_comp] filters an [evar_map], keeping only evars
+    that belongs to a certain component *)
 
-let select_evars evs evm =
-  Evd.fold (fun ev evi acc ->
-    if Intset.mem ev evs then Evd.add acc ev evi else acc)
-    evm Evd.empty
+let evars_in_comp comp evm =
+  try
+    evars_reset_evd 
+      (Intset.fold (fun ev acc -> Evd.add acc ev (Evd.find_undefined evm ev))
+	 comp Evd.empty) evm
+  with Not_found -> assert false
 
-let is_inference_forced p ev evd =
+let is_inference_forced p evd ev =
   try
-    let evi = Evd.find evd ev in
-      if evi.evar_body = Evar_empty then
-	if Typeclasses.is_resolvable evi
-	  && snd (p ev evi)
-	then
-	  let (loc, k) = evar_source ev evd in
-	    match k with
-	    | ImplicitArg (_, _, b) -> b
-	    | QuestionMark _ -> false
-	    | _ -> true
-	else true
-      else false
-  with Not_found -> true
-
-let is_optional p comp evd =
-  Intset.fold (fun ev acc ->
-    acc && not (is_inference_forced p ev evd))
-    comp true
+    let evi = Evd.find_undefined evd ev in
+    if Typeclasses.is_resolvable evi && snd (p ev evi)
+    then
+      let (loc, k) = evar_source ev evd in
+      match k with
+	| ImplicitArg (_, _, b) -> b
+	| QuestionMark _ -> false
+	| _ -> true
+    else true
+  with Not_found -> assert false
+
+let is_mandatory p comp evd =
+  Intset.exists (is_inference_forced p evd) comp
+
+(** In case of unsatisfiable constraints, build a nice error message *)
+
+let error_unresolvable env comp do_split evd =
+  let evd = Evarutil.nf_evar_map_undefined evd in
+  let evm = if do_split then evars_in_comp comp evd else evd in
+  let _, ev = Evd.fold_undefined
+    (fun ev evi (b,acc) ->
+      (* focus on one instance if only one was searched for *)
+      if class_of_constr evi.evar_concl <> None then
+	if not b (* || do_split *) then
+	  true, Some ev
+	else b, None
+      else b, acc) evm (false, None)
+  in
+  Typeclasses_errors.unsatisfiable_constraints
+    (Evarutil.nf_env_evar evm env) evm ev
+
+(** Check if an evar is concerned by the current resolution attempt,
+    (and in particular is in the current component), and also update
+    its evar_info.
+    Invariant : this should only be applied to undefined evars,
+    and return undefined evar_info *)
+
+let select_and_update_evars p oevd in_comp evd ev evi =
+  assert (evi.evar_body = Evar_empty);
+  try
+    let oevi = Evd.find_undefined oevd ev in
+    if Typeclasses.is_resolvable oevi then
+      Typeclasses.mark_unresolvable evi,
+      (in_comp ev && p evd ev evi)
+    else evi, false
+  with Not_found ->
+    Typeclasses.mark_unresolvable evi, p evd ev evi
+
+(** Do we still have unresolved evars that should be resolved ? *)
+
+let has_undefined p oevd evd =
+  Evd.fold_undefined (fun ev evi has -> has ||
+    snd (p oevd ev evi))
+    evd false
+
+(** If [do_split] is [true], we try to separate the problem in
+    several components and then solve them separately *)
+
+exception Unresolved
 
 let resolve_all_evars debug m env p oevd do_split fail =
   let split = if do_split then split_evars oevd else [Intset.empty] in
-  let p = if do_split then
-    fun comp evd ev evi -> 
-      if evi.evar_body = Evar_empty then
-	(try let oevi = Evd.find oevd ev in
-	       if Typeclasses.is_resolvable oevi then
-		 Typeclasses.mark_unresolvable evi, (Intset.mem ev comp &&
-							p evd ev evi)
-	       else evi, false
-	  with Not_found ->
-	    Typeclasses.mark_unresolvable evi, p evd ev evi)
-      else evi, false
-    else fun _ evd ev evi -> 
-      if evi.evar_body = Evar_empty then
-	try let oevi = Evd.find oevd ev in
-	      if Typeclasses.is_resolvable oevi then
-		Typeclasses.mark_unresolvable evi, p evd ev evi
-	      else evi, false
-	with Not_found ->
-	  Typeclasses.mark_unresolvable evi, p evd ev evi
-      else evi, false
-  in
-  let rec aux p evd =
-    let evd' = resolve_all_evars_once debug m p evd in
-      if has_undefined p oevd evd' then None
-      else Some evd'
+  let in_comp comp ev = if do_split then Intset.mem ev comp else true
   in
   let rec docomp evd = function
     | [] -> evd
     | comp :: comps ->
-	let res = try aux (p comp) evd with Not_found -> None in
-	  match res with
-	  | None -> 
-	      if fail && (not do_split || not (is_optional (p comp evd) comp evd)) then
-		(* Unable to satisfy the constraints. *)		
-		let evd = Evarutil.nf_evars evd in
-		let evm = if do_split then select_evars comp evd else evd in
-		let _, ev = Evd.fold
-		  (fun ev evi (b,acc) ->
-		    (* focus on one instance if only one was searched for *)
-		    if class_of_constr evi.evar_concl <> None then
-		      if not b (* || do_split *) then
-			true, Some ev
-		      else b, None
-		    else b, acc) evm (false, None)
-		in
-		  Typeclasses_errors.unsatisfiable_constraints (Evarutil.nf_env_evar evm env) evm ev
-	      else (* Best effort: do nothing *) oevd
-	  | Some evd' -> docomp evd' comps
+      let p = select_and_update_evars p oevd (in_comp comp) in
+      try
+	 let evd' = resolve_all_evars_once debug m p evd in
+	 if has_undefined p oevd evd' then raise Unresolved;
+	 docomp evd' comps
+      with Unresolved | Not_found ->
+	if fail && (not do_split || is_mandatory (p evd) comp evd)
+	then (* Unable to satisfy the constraints. *)
+	  error_unresolvable env comp do_split evd
+	else (* Best effort: do nothing on this component *) 
+	  docomp evd comps
   in docomp oevd split
 
-let resolve_typeclass_evars d p env evd onlyargs split fail =
-  let pred =
-    if onlyargs then
-      (fun evd ev evi -> Typeclasses.is_implicit_arg (snd (Evd.evar_source ev evd)) &&
-	Typeclasses.is_class_evar evd evi)
-    else (fun evd ev evi -> Typeclasses.is_class_evar evd evi)
-  in resolve_all_evars d p env pred evd split fail
+let initial_select_evars onlyargs =
+  if onlyargs then
+    (fun evd ev evi ->
+      Typeclasses.is_implicit_arg (snd (Evd.evar_source ev evd))
+      && Typeclasses.is_class_evar evd evi)
+  else
+    (fun evd ev evi -> Typeclasses.is_class_evar evd evi)
+
+let resolve_typeclass_evars debug m env evd onlyargs split fail =
+  let evd = 
+    try Evarconv.consider_remaining_unif_problems
+      ~ts:(Typeclasses.classes_transparent_state ()) env evd
+    with _ -> evd
+  in
+    resolve_all_evars debug m env (initial_select_evars onlyargs) evd split fail
 
-let solve_inst debug mode depth env evd onlyargs split fail =
-  resolve_typeclass_evars debug (mode, depth) env evd onlyargs split fail
+let solve_inst debug depth env evd onlyargs split fail =
+  resolve_typeclass_evars debug depth env evd onlyargs split fail
 
 let _ =
   Typeclasses.solve_instanciations_problem :=
-    solve_inst false true default_eauto_depth
+    solve_inst false !typeclasses_depth
+
+
+(** Options: depth, debug and transparency settings. *)
+
+open Goptions
+
+let set_typeclasses_debug d = (:=) typeclasses_debug d;
+  Typeclasses.solve_instanciations_problem := solve_inst d !typeclasses_depth
+    
+let get_typeclasses_debug () = !typeclasses_debug
+
+let set_typeclasses_debug =
+  declare_bool_option
+    { optsync  = true;
+      optdepr  = false;
+      optname  = "debug output for typeclasses proof search";
+      optkey   = ["Typeclasses";"Debug"];
+      optread  = get_typeclasses_debug;
+      optwrite = set_typeclasses_debug; }
+
+
+let set_typeclasses_depth d = (:=) typeclasses_depth d;
+  Typeclasses.solve_instanciations_problem := solve_inst !typeclasses_debug !typeclasses_depth
+    
+let get_typeclasses_depth () = !typeclasses_depth
+
+let set_typeclasses_depth =
+  declare_int_option
+    { optsync  = true;
+      optdepr  = false;
+      optname  = "depth for typeclasses proof search";
+      optkey   = ["Typeclasses";"Depth"];
+      optread  = get_typeclasses_depth;
+      optwrite = set_typeclasses_depth; }
 
 let set_transparency cl b =
   List.iter (fun r -> 
     let gr = Smartlocate.global_with_alias r in
     let ev = Tacred.evaluable_of_global_reference (Global.env ()) gr in
-      Classes.set_typeclass_transparency ev b) cl
+      Classes.set_typeclass_transparency ev false b) cl
 
 VERNAC COMMAND EXTEND Typeclasses_Unfold_Settings
 | [ "Typeclasses" "Transparent" reference_list(cl) ] -> [
@@ -704,18 +743,6 @@ ARGUMENT EXTEND debug TYPED AS bool PRINTED BY pr_debug
 | [ ] -> [ false ]
 END
 
-let pr_mode _prc _prlc _prt m =
-  match m with
-      Some b ->
-	if b then Pp.str "depth-first" else Pp.str "breadth-fist"
-    | None -> Pp.mt()
-
-ARGUMENT EXTEND search_mode TYPED AS bool option PRINTED BY pr_mode
-| [ "dfs" ] -> [ Some true ]
-| [ "bfs" ] -> [ Some false ]
-| [] -> [ None ]
-END
-
 let pr_depth _prc _prlc _prt = function
     Some i -> Util.pr_int i
   | None -> Pp.mt()
@@ -724,13 +751,12 @@ ARGUMENT EXTEND depth TYPED AS int option PRINTED BY pr_depth
 | [ int_or_var_opt(v) ] -> [ match v with Some (ArgArg i) -> Some i | _ -> None ]
 END
 
+(* true = All transparent, false = Opaque if possible *)
+
 VERNAC COMMAND EXTEND Typeclasses_Settings
- | [ "Typeclasses" "eauto" ":=" debug(d) search_mode(s) depth(depth) ] -> [
-     typeclasses_debug := d;
-     let mode = match s with Some t -> t | None -> true in
-     let depth = match depth with Some i -> i | None -> default_eauto_depth in
-       Typeclasses.solve_instanciations_problem :=
-	 solve_inst d mode depth
+ | [ "Typeclasses" "eauto" ":=" debug(d) depth(depth) ] -> [
+     set_typeclasses_debug d;
+     set_typeclasses_depth depth
    ]
 END
 
@@ -738,8 +764,8 @@ let typeclasses_eauto ?(only_classes=false) ?(st=full_transparent_state) dbs gl
   try 
     let dbs = list_map_filter (fun db -> try Some (Auto.searchtable_map db) with _ -> None) dbs in
     let st = match dbs with x :: _ -> Hint_db.transparent_state x | _ -> st in
-      eauto ~only_classes ~st dbs gl
-   with Not_found -> tclFAIL 0 (str" typeclasses eauto failed") gl
+      eauto ?limit:!typeclasses_depth ~only_classes ~st dbs gl
+   with Not_found -> tclFAIL 0 (str" typeclasses eauto failed on: " ++ Printer.pr_goal gl) gl
  
 TACTIC EXTEND typeclasses_eauto
 | [ "typeclasses" "eauto" "with" ne_preident_list(l) ] -> [ typeclasses_eauto l ]
diff --git a/tactics/contradiction.ml b/tactics/contradiction.ml
index f459a3dd..a3d43623 100644
--- a/tactics/contradiction.ml
+++ b/tactics/contradiction.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: contradiction.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Util
 open Term
 open Proof_type
@@ -17,7 +15,7 @@ open Tacticals
 open Tactics
 open Coqlib
 open Reductionops
-open Rawterm
+open Glob_term
 
 (* Absurd *)
 
diff --git a/tactics/contradiction.mli b/tactics/contradiction.mli
index bd2138d5..b77b2721 100644
--- a/tactics/contradiction.mli
+++ b/tactics/contradiction.mli
@@ -1,20 +1,16 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: contradiction.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Names
 open Term
 open Proof_type
-open Rawterm
+open Glob_term
 open Genarg
-(*i*)
 
 val absurd                      : constr -> tactic
 val contradiction               : constr with_bindings option -> tactic
diff --git a/tactics/decl_interp.ml b/tactics/decl_interp.ml
deleted file mode 100644
index c4cff4d7..00000000
--- a/tactics/decl_interp.ml
+++ /dev/null
@@ -1,472 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(*i $Id: decl_interp.ml 14677 2011-11-17 22:19:38Z herbelin $ i*)
-
-open Util
-open Names
-open Topconstr
-open Tacinterp
-open Tacmach
-open Decl_expr
-open Decl_mode
-open Pretyping.Default
-open Rawterm
-open Term
-open Pp
-
-(* INTERN *)
-
-let raw_app (loc,hd,args) = if args =[] then hd else RApp(loc,hd,args)
-
-let intern_justification_items globs =
-  Option.map (List.map (intern_constr globs))
-
-let intern_justification_method globs =
-  Option.map (intern_pure_tactic globs)
-
-let intern_statement intern_it globs st =
-  {st_label=st.st_label;
-   st_it=intern_it globs st.st_it}
-
-let intern_no_bind intern_it globs x =
-  globs,intern_it globs x
-
-let intern_constr_or_thesis globs = function
-    Thesis n -> Thesis n
-  | 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)}
-
-let add_name nam globs=
- match nam with
-     Anonymous -> globs
-   | Name id -> add_var id globs
-
-let intern_hyp iconstr globs = function
-    Hvar (loc,(id,topt)) -> add_var id globs,
-      Hvar (loc,(id,Option.map (intern_constr globs) topt))
-  | Hprop st -> add_name st.st_label globs,
-      Hprop (intern_statement iconstr globs st)
-
-let intern_hyps iconstr globs hyps =
-  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
-    {cut_stat=nstat;
-     cut_by=intern_justification_items nglobs cut.cut_by;
-     cut_using=intern_justification_method nglobs cut.cut_using}
-
-let intern_casee globs = function
-    Real c -> Real (intern_constr globs c)
-  | Virtual cut -> Virtual
-      (intern_cut (intern_no_bind (intern_statement intern_constr)) globs cut)
-
-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
-
-let intern_suffices_clause globs (hyps,c) =
-  let nglobs,nhyps = list_fold_map (intern_hyp intern_constr) globs hyps in
-    nglobs,(nhyps,intern_constr_or_thesis nglobs c)
-
-let intern_fundecl args body globs=
-  let nglobs,nargs = intern_hyp_list args globs in
-    nargs,intern_constr nglobs body
-
-let rec add_vars_of_simple_pattern globs = function
-    CPatAlias (loc,p,id) ->
-      add_vars_of_simple_pattern (add_var id globs) p
-(*      Stdpp.raise_with_loc loc
-	(UserError ("simple_pattern",str "\"as\" is not allowed here"))*)
-  | CPatOr (loc, _)->
-      Stdpp.raise_with_loc loc
-	(UserError ("simple_pattern",str "\"(_ | _)\" is not allowed here"))
-  | CPatDelimiters (_,_,p) ->
-      add_vars_of_simple_pattern globs p
-  | CPatCstr (_,_,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))
-  | CPatAtom (_,Some (Libnames.Ident (_,id))) -> add_var id globs
-  |  _  -> globs
-
-let rec intern_bare_proof_instr globs = function
-    Pthus i -> Pthus (intern_bare_proof_instr globs i)
-  | Pthen i -> Pthen (intern_bare_proof_instr globs i)
-  | Phence i -> Phence (intern_bare_proof_instr globs i)
-  | Pcut c -> Pcut
-      (intern_cut
-	 (intern_no_bind (intern_statement intern_constr_or_thesis)) globs c)
-  | Psuffices c ->
-      Psuffices (intern_cut intern_suffices_clause globs c)
-  | Prew (s,c) -> Prew
-      (s,intern_cut
-	 (intern_no_bind  (intern_statement intern_constr)) globs c)
-  | Psuppose hyps -> Psuppose (intern_hyps intern_constr globs hyps)
-  | Pcase (params,pat,hyps) ->
-      let nglobs,nparams = intern_hyp_list params globs in
-      let nnglobs= add_vars_of_simple_pattern nglobs pat in
-      let nhyps = intern_hyps intern_constr_or_thesis nnglobs hyps in
-	Pcase (nparams,pat,nhyps)
-  | Ptake witl -> Ptake (List.map (intern_constr globs) witl)
-  | Pconsider (c,hyps) -> Pconsider (intern_constr globs c,
-				      intern_hyps intern_constr globs hyps)
-  | Pper (et,c) -> Pper (et,intern_casee globs c)
-  | Pend bt -> Pend bt
-  | Pescape -> Pescape
-  | Passume hyps -> Passume (intern_hyps intern_constr globs hyps)
-  | Pgiven hyps -> Pgiven (intern_hyps intern_constr globs hyps)
-  | Plet hyps -> Plet (intern_hyps intern_constr globs hyps)
-  | Pclaim st -> Pclaim (intern_statement intern_constr globs st)
-  | Pfocus st -> Pfocus (intern_statement intern_constr globs st)
-  | Pdefine (id,args,body) ->
-      let nargs,nbody = intern_fundecl args body globs in
-	Pdefine (id,nargs,nbody)
-  | Pcast (id,typ) ->
-      Pcast (id,intern_constr globs typ)
-
-let rec 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_constr check_sort sigma env c =
-  if check_sort then
-    understand_type sigma env (fst c)
-  else
-    understand sigma env (fst c)
-
-let special_whd env =
-  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 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
-	  then args.(0)
-	  else error "Previous step is not an equality."
-      | _ -> error "Previous step is not an equality."
-
-let get_eq_typ info env =
-  let typ = decompose_eq env (get_last env) in
-    typ
-
-let interp_constr_in_type typ sigma env c =
-  understand sigma env (fst c) ~expected_type:typ
-
-let interp_statement interp_it sigma env st =
-  {st_label=st.st_label;
-   st_it=interp_it sigma env st.st_it}
-
-let interp_constr_or_thesis check_sort sigma env = function
-    Thesis n -> Thesis n
-  | This c -> This (interp_constr check_sort sigma env c)
-
-let abstract_one_hyp inject h raw =
-  match h with
-      Hvar (loc,(id,None)) ->
-	RProd (dummy_loc,Name id, Explicit, RHole (loc,Evd.BinderType (Name id)), raw)
-    | Hvar (loc,(id,Some typ)) ->
-	RProd (dummy_loc,Name id, Explicit, fst typ, raw)
-    | Hprop st ->
-	RProd (dummy_loc,st.st_label, Explicit, inject st.st_it, raw)
-
-let rawconstr_of_hyps inject hyps head =
-  List.fold_right (abstract_one_hyp inject) hyps head
-
-let raw_prop = RSort (dummy_loc,RProp Null)
-
-let rec match_hyps blend names constr = function
-    [] -> [],substl names constr
-  | hyp::q ->
-      let (name,typ,body)=destProd constr in
-      let st= {st_label=name;st_it=substl names typ} in
-      let qnames=
-	match name with
-	    Anonymous -> mkMeta 0 :: names
-	  | Name id -> mkVar id :: names in
-      let qhyp = match hyp with
-	  Hprop st' -> Hprop (blend st st')
-	| Hvar _ -> Hvar st in
-      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 (rawconstr_of_hyps inject hyps head) in
-    match_hyps blend [] constr hyps
-
-let interp_hyps sigma env hyps = fst (interp_hyps_gen fst (fun x _ -> x) sigma env hyps raw_prop)
-
-let dummy_prefix= id_of_string "__"
-
-let rec deanonymize ids =
-  function
-      PatVar (loc,Anonymous) ->
-	let (found,known) = !ids in
-	let new_id=Namegen.next_ident_away dummy_prefix known in
-	let _= ids:= (loc,new_id) :: found , new_id :: known in
-	  PatVar (loc,Name new_id)
-    | PatVar (loc,Name id) as pat ->
-	let (found,known) = !ids in
-	let _= ids:= (loc,id) :: found , known in
-	  pat
-    | PatCstr(loc,cstr,lpat,nam) ->
-	PatCstr(loc,cstr,List.map (deanonymize ids) lpat,nam)
-
-let rec raw_of_pat =
-  function
-      PatVar (loc,Anonymous) -> anomaly "Anonymous pattern variable"
-    | PatVar (loc,Name id) ->
-	  RVar (loc,id)
-    | PatCstr(loc,((ind,_) as cstr),lpat,_) ->
-	let mind= fst (Global.lookup_inductive ind) in
-	let rec add_params n q =
-	  if n<=0 then q else
-	    add_params (pred n) (RHole(dummy_loc,
-				       Evd.TomatchTypeParameter(ind,n))::q) in
-	    let args = List.map raw_of_pat lpat in
-	      raw_app(loc,RRef(dummy_loc,Libnames.ConstructRef cstr),
-		   add_params mind.Declarations.mind_nparams args)
-
-let prod_one_hyp = function
-    (loc,(id,None)) ->
-      (fun raw ->
-	 RProd (dummy_loc,Name id, Explicit,
-		RHole (loc,Evd.BinderType (Name id)), raw))
-  | (loc,(id,Some typ)) ->
-      (fun raw ->
-	 RProd (dummy_loc,Name id, Explicit, fst typ, raw))
-
-let prod_one_id (loc,id) raw =
-  RProd (dummy_loc,Name id, Explicit,
-	 RHole (loc,Evd.BinderType (Name id)), raw)
-
-let let_in_one_alias (id,pat) raw =
-  RLetIn (dummy_loc,Name id, raw_of_pat pat, raw)
-
-let rec bind_primary_aliases map pat =
-  match pat with
-      PatVar (_,_) -> map
-    | PatCstr(loc,_,lpat,nam) ->
-	let map1 =
-	  match nam with
-	      Anonymous -> map
-	    | Name id -> (id,pat)::map
-	in
-	  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
-
-let bind_aliases patvars subst patt =
-  let map = bind_primary_aliases [] patt in
-  let map1 = bind_secondary_aliases map subst in
-  List.rev map1
-
-let interp_pattern env pat_expr =
-  let patvars,pats = Constrintern.intern_pattern env pat_expr in
-    match pats with
-	[] -> anomaly "empty pattern list"
-      | [subst,patt] ->
-	  (patvars,bind_aliases patvars subst patt,patt)
-      | _  -> anomaly "undetected disjunctive pattern"
-
-let rec match_args dest names constr = function
-    [] -> [],names,substl names constr
-  | _::q ->
-      let (name,typ,body)=dest constr in
-      let st={st_label=name;st_it=substl names typ} in
-      let qnames=
-	match name with
-	    Anonymous -> assert  false
-	  | Name id -> mkVar id :: names in
-      let args,bnames,body = match_args dest qnames body q in
-	st::args,bnames,body
-
-let rec match_aliases names constr = function
-    [] -> [],names,substl names constr
-  | _::q ->
-      let (name,c,typ,body)=destLetIn constr in
-      let st={st_label=name;st_it=(substl names c,substl names typ)} in
-      let qnames=
-	match name with
-	    Anonymous -> assert false
-	  | Name id -> mkVar id :: names in
-      let args,bnames,body = match_aliases qnames body q in
-	st::args,bnames,body
-
-let detype_ground c = Detyping.detype false [] [] c
-
-let interp_cases info sigma env params (pat:cases_pattern_expr) hyps =
-  let et,pinfo =
-    match info.pm_stack with
-	Per(et,pi,_,_)::_ -> et,pi
-      | _ -> error "No proof per cases/induction/inversion in progress." in
-  let mib,oib=Global.lookup_inductive  pinfo.per_ind in
-  let num_params = pinfo.per_nparams in
-  let _ =
-    let expected = mib.Declarations.mind_nparams - num_params in
-      if 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 () ++
-	     str "expected.") in
-  let app_ind =
-    let rind = RRef (dummy_loc,Libnames.IndRef pinfo.per_ind) in
-    let rparams = List.map detype_ground pinfo.per_params in
-    let rparams_rec =
-      List.map
-	(fun (loc,(id,_)) ->
-	   RVar (loc,id)) params in
-    let dum_args=
-      list_tabulate (fun _ -> RHole (dummy_loc,Evd.QuestionMark (Evd.Define false)))
-	oib.Declarations.mind_nrealargs in
-      raw_app(dummy_loc,rind,rparams@rparams_rec@dum_args) in
-  let pat_vars,aliases,patt = interp_pattern env pat in
-  let inject = function
-      Thesis (Plain) -> Rawterm.RSort(dummy_loc,RProp Null)
-    | Thesis (For rec_occ) ->
-	if not (List.mem rec_occ pat_vars) then
-	  errorlabstrm "suppose it is"
-	    (str "Variable " ++ Nameops.pr_id rec_occ ++
-	       str " does not occur in pattern.");
-	Rawterm.RSort(dummy_loc,RProp Null)
-    | This (c,_) -> c in
-  let term1 = rawconstr_of_hyps inject hyps raw_prop in
-  let loc_ids,npatt =
-    let rids=ref ([],pat_vars) in
-    let npatt= deanonymize rids patt in
-      List.rev (fst !rids),npatt in
-  let term2 =
-    RLetIn(dummy_loc,Anonymous,
-	   RCast(dummy_loc,raw_of_pat npatt,
-		 CastConv (DEFAULTcast,app_ind)),term1) in
-  let term3=List.fold_right let_in_one_alias aliases term2 in
-  let 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 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
-  let (_,pat_pat,pat_typ,rest1) = destLetIn rest2 in
-  let blend st st' =
-    match st'.st_it with
-	Thesis nam -> {st_it=Thesis nam;st_label=st'.st_label}
-      | This _ -> {st_it = This st.st_it;st_label=st.st_label} in
-  let thyps = fst (match_hyps blend nam2 (Termops.pop rest1) hyps) in
-    tparams,{pat_vars=tpatvars;
-	     pat_aliases=taliases;
-	     pat_constr=pat_pat;
-	     pat_typ=pat_typ;
-	     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
-    {cut with
-       cut_stat=nstat;
-       cut_by=interp_justification_items sigma nenv cut.cut_by}
-
-let interp_no_bind interp_it sigma env x =
-  env,interp_it sigma env x
-
-let interp_suffices_clause sigma env (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
-	  nhyps,This nc
-      | Thesis Plain as th  -> interp_hyps sigma env hyps,th
-      | Thesis (For n) -> error "\"thesis for\" is not applicable here." in
-  let push_one hyp env0 =
-    match hyp with
-	(Hprop st | Hvar st) ->
-	  match st.st_label with
-	      Name id -> Environ.push_named (id,None,st.st_it) env0
-	    | _ -> env in
-  let nenv = List.fold_right push_one locvars env in
-    nenv,res
-
-let interp_casee sigma env = function
-    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 abstract_one_arg = function
-    (loc,(id,None)) ->
-      (fun raw ->
-	 RLambda (dummy_loc,Name id, Explicit,
-		RHole (loc,Evd.BinderType (Name id)), raw))
-  | (loc,(id,Some typ)) ->
-      (fun raw ->
-	 RLambda (dummy_loc,Name id, Explicit, fst typ, raw))
-
-let rawconstr_of_fun args body =
-  List.fold_right abstract_one_arg args (fst body)
-
-let interp_fun sigma env args body =
-  let constr=understand sigma env (rawconstr_of_fun args body) in
-    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)
-  | Pcut c -> Pcut (interp_cut
-		      (interp_no_bind (interp_statement
-					 (interp_constr_or_thesis true)))
-		      sigma env c)
-  | Psuffices c ->
-      Psuffices (interp_cut interp_suffices_clause sigma env c)
-  | Prew (s,c) -> Prew (s,interp_cut
-			  (interp_no_bind (interp_statement
-			     (interp_constr_in_type (get_eq_typ info env))))
-			  sigma env c)
-
-  | Psuppose hyps -> Psuppose (interp_hyps sigma env hyps)
-  | Pcase (params,pat,hyps) ->
-      let tparams,tpat,thyps = interp_cases info sigma env params pat hyps in
-	Pcase (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)
-  | 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)
-  | Pdefine (id,args,body) ->
-      let nargs,_,nbody = interp_fun sigma env args body in
-	Pdefine (id,nargs,nbody)
-  | Pcast (id,typ) ->
-      Pcast(id,interp_constr true sigma env typ)
-
-let rec interp_proof_instr info sigma env instr=
-  {emph = instr.emph;
-   instr = interp_bare_proof_instr info sigma env instr.instr}
-
-
-
diff --git a/tactics/decl_interp.mli b/tactics/decl_interp.mli
deleted file mode 100644
index e2c1e531..00000000
--- a/tactics/decl_interp.mli
+++ /dev/null
@@ -1,18 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(* $Id: decl_interp.mli 14641 2011-11-06 11:59:10Z herbelin $ *)
-
-open Tacinterp
-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
diff --git a/tactics/decl_proof_instr.ml b/tactics/decl_proof_instr.ml
deleted file mode 100644
index 5a89e859..00000000
--- a/tactics/decl_proof_instr.ml
+++ /dev/null
@@ -1,1518 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(* $Id: decl_proof_instr.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
-open Util
-open Pp
-open Evd
-
-open Refiner
-open Proof_type
-open Proof_trees
-open Tacmach
-open Tacinterp
-open Decl_expr
-open Decl_mode
-open Decl_interp
-open Rawterm
-open Names
-open Nameops
-open Declarations
-open Tactics
-open Tacticals
-open Term
-open Termops
-open Namegen
-open Reductionops
-open Goptions
-
-
-(* Strictness option *)
-
-let get_its_info gls = get_info gls.it
-
-let get_strictness,set_strictness =
-  let strictness = ref false in
-    (fun () -> (!strictness)),(fun b -> strictness:=b)
-
-let _ =
-  declare_bool_option
-    { optsync  = true;
-      optname  = "strict mode";
-      optkey   = ["Strict";"Proofs"];
-      optread  = get_strictness;
-      optwrite = set_strictness }
-
-let tcl_change_info_gen info_gen =
-  (fun gls ->
-  let gl =sig_it gls in
-    {it=[{gl with evar_extra=info_gen}];sigma=sig_sig gls},
-  function
-      [pftree] ->
-	{pftree with
-	   goal=gl;
-	   ref=Some (Prim Change_evars,[pftree])}
-    | _ -> anomaly "change_info : Wrong number of subtrees")
-
-let tcl_change_info info gls =  tcl_change_info_gen (Some (pm_in info)) gls
-
-let tcl_erase_info gls =  tcl_change_info_gen None gls
-
-let special_whd gl=
-  let infos=Closure.create_clos_infos Closure.betadeltaiota (pf_env gl) in
-    (fun t -> Closure.whd_val infos (Closure.inject t))
-
-let special_nf gl=
-  let infos=Closure.create_clos_infos Closure.betaiotazeta (pf_env gl) in
-    (fun t -> Closure.norm_val infos (Closure.inject t))
-
-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))
-
-let check_not_per pts =
-  if not (Proof_trees.is_complete_proof (proof_of_pftreestate pts)) then
-    match get_stack pts with
-	Per (_,_,_,_)::_ ->
-	  error "You are inside a proof per cases/induction.\n\
-Please \"suppose\" something or \"end\" it now."
-      | _ -> ()
-
-let mk_evd metalist gls =
-  let evd0= create_goal_evar_defs (sig_sig gls) in
-  let add_one (meta,typ) evd =
-    meta_declare meta typ evd in
-    List.fold_right add_one metalist evd0
-
-let is_tmp id = (string_of_id id).[0] = '_'
-
-let tmp_ids gls =
-  let ctx = pf_hyps gls in
-    match ctx with
-	[] -> []
-      | _::q -> List.filter is_tmp (ids_of_named_context q)
-
-let clean_tmp gls =
-  let clean_id id0 gls0 =
-      tclTRY (clear [id0]) gls0 in
-  let rec clean_all = function
-      [] -> tclIDTAC
-    | id :: rest -> tclTHEN (clean_id id) (clean_all rest)
-  in
-    clean_all (tmp_ids gls) gls
-
-let assert_postpone id t =
-  assert_tac (Name id) t
-
-(* start a proof *)
-
-let start_proof_tac gls=
-  let gl=sig_it gls in
-  let info={pm_stack=[]} in
-    {it=[{gl with evar_extra=Some (pm_in info)}];sigma=sig_sig gls},
-  function
-      [pftree] ->
-	{pftree with
-	   goal=gl;
-	   ref=Some (Decl_proof true,[pftree])}
-    | _ -> anomaly "Dem : Wrong number of subtrees"
-
-let go_to_proof_mode () =
-  Pfedit.mutate
-    (fun pts -> nth_unproven 1 (solve_pftreestate start_proof_tac pts))
-
-(* closing gaps *)
-
-let daimon_tac gls =
-  set_daimon_flag ();
-  ({it=[];sigma=sig_sig gls},
-   function
-       [] ->
-	 {open_subgoals=0;
-	    goal=sig_it gls;
-	    ref=Some (Daimon,[])}
-     | _ -> anomaly "Daimon: Wrong number of subtrees")
-
-let daimon _ pftree =
-  set_daimon_flag ();
-  {pftree with
-     open_subgoals=0;
-     ref=Some (Daimon,[])}
-
-let daimon_subtree = map_pftreestate (fun _ ->  frontier_mapi daimon )
-
-(* 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"
-  | Nested(Proof_instr (lock_focus,instr),spfl) ->
-      if lock_focus then
-	Nested(Proof_instr (false,instr),spfl)
-      else
-	anomaly "already marked as done"
-  | _ -> anomaly "mark_rule_as_done"
-
-let mark_proof_tree_as_done pt =
-  match pt.ref with
-      None -> anomaly "mark_proof_tree_as_done"
-    | Some (r,spfl) ->
-	{pt with ref= Some (mark_rule_as_done r,spfl)}
-
-let mark_as_done pts =
-  map_pftreestate
-    (fun _ -> mark_proof_tree_as_done)
-    (up_to_matching_rule is_focussing_command pts)
-
-(* post-instruction focus management *)
-
-let goto_current_focus pts = up_until_matching_rule is_focussing_command pts
-
-let goto_current_focus_or_top pts =
-  try
-    up_until_matching_rule is_focussing_command pts
-  with Not_found -> top_of_tree pts
-
-(* return *)
-
-let close_tactic_mode pts =
-    let pts1=
-      try goto_current_focus pts
-      with Not_found ->
-	error "\"return\" cannot be used outside of Declarative Proof Mode." in
-    let pts2 = daimon_subtree pts1 in
-    let pts3 = mark_as_done pts2 in
-      goto_current_focus pts3
-
-let return_from_tactic_mode () = Pfedit.mutate close_tactic_mode
-
-(* end proof/claim *)
-
-let close_block bt pts =
-  let stack =
-    if Proof_trees.is_complete_proof (proof_of_pftreestate pts) then
-      get_top_stack pts
-    else
-      get_stack pts in
-    match bt,stack with
-	B_claim, Claim::_ | B_focus, Focus_claim::_ | B_proof, [] ->
-	  daimon_subtree (goto_current_focus pts)
-      | _, Claim::_ ->
-	  error "\"end claim\" expected."
-      | _, Focus_claim::_ ->
-	  error "\"end focus\" expected."
-      | _, [] ->
- 	  error "\"end proof\" expected."
-      | _, (Per (et,_,_,_)::_|Suppose_case::Per (et,_,_,_)::_) ->
-	  begin
-	    match et with
-		ET_Case_analysis -> error "\"end cases\" expected."
-	      | ET_Induction ->  error "\"end induction\" expected."
-	  end
-      | _,_ -> anomaly "Lonely suppose on stack."
-
-(* utility for suppose / suppose it is *)
-
-let close_previous_case pts =
-  if
-    Proof_trees.is_complete_proof (proof_of_pftreestate pts)
-  then
-    match get_top_stack pts with
-	Per (et,_,_,_) :: _ -> anomaly "Weird case occured ..."
-      | Suppose_case :: Per (et,_,_,_) :: _ ->
-	  goto_current_focus (mark_as_done pts)
-      | _ -> error "Not inside a proof per cases or induction."
-  else
-    match get_stack pts with
-	Per (et,_,_,_) :: _ -> pts
-      | Suppose_case :: Per (et,_,_,_) :: _ ->
-	  goto_current_focus (mark_as_done (daimon_subtree pts))
-      | _ -> error "Not inside a proof per cases or induction."
-
-(* Proof instructions *)
-
-(* automation *)
-
-let filter_hyps f gls =
-  let filter_aux (id,_,_) =
-    if f id then
-      tclIDTAC
-    else
-      tclTRY (clear [id])  in
-    tclMAP filter_aux (Environ.named_context_of_val gls.it.evar_hyps) gls
-
-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;
-	  tclIDTAC gls
-      | _ ->
-	  let id=pf_get_new_id local_hyp_prefix gls in
-	    keep:=Idset.add id !keep;
-	    tclTHEN (letin_tac None (Names.Name id) c None Tacexpr.nowhere)
-              (thin_body [id]) gls in
-    tclMAP add_aux items gls
-
-let prepare_goal items gls =
-  let tokeep = ref Idset.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
-
-let my_automation_tac = ref
-  (fun gls -> anomaly "No automation registered")
-
-let register_automation_tac tac = my_automation_tac:= tac
-
-let automation_tac gls = !my_automation_tac gls
-
-let justification tac gls=
-    tclORELSE
-      (tclSOLVE [tclTHEN tac assumption])
-      (fun gls ->
-	 if get_strictness () then
-	   error "Insufficient justification."
-	 else
-	   begin
-	     msg_warning (str "Insufficient justification.");
-	     daimon_tac gls
-	   end) gls
-
-let default_justification elems gls=
-  justification (tclTHEN (prepare_goal elems) automation_tac) gls
-
-(* code for conclusion refining *)
-
-let constant dir s = lazy (Coqlib.gen_constant "Declarative" dir s)
-
-let _and       = constant ["Init";"Logic"] "and"
-
-let _and_rect  = constant ["Init";"Logic"] "and_rect"
-
-let _prod      = constant ["Init";"Datatypes"] "prod"
-
-let _prod_rect = constant ["Init";"Datatypes"] "prod_rect"
-
-let _ex        = constant ["Init";"Logic"] "ex"
-
-let _ex_ind    = constant ["Init";"Logic"] "ex_ind"
-
-let _sig       = constant ["Init";"Specif"] "sig"
-
-let _sig_rect  = constant ["Init";"Specif"] "sig_rect"
-
-let _sigT      = constant ["Init";"Specif"] "sigT"
-
-let _sigT_rect = constant ["Init";"Specif"] "sigT_rect"
-
-type stackd_elt =
-{se_meta:metavariable;
- se_type:types;
- se_last_meta:metavariable;
- se_meta_list:(metavariable*types) list;
- se_evd: evar_map}
-
-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
-
-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 ->
-	  let mib,oib=
-	    Inductive.lookup_mind_specif env ind in
-          let gentypes=
-            Inductive.arities_of_constructors ind (mib,oib) in
-	  let process i gentyp =
-	    let constructor = mkConstruct(ind,succ i)
-	      (* constructors numbering*) in
-	    let appterm = applist (constructor,params) in
-	    let apptype = Term.prod_applist gentyp params in
-	    let rc,_ = Reduction.dest_prod env apptype in
-	    let rec meta_aux last lenv = function
-		[] -> (last,lenv,[])
-	      | (nam,_,typ)::q ->
-		  let nlast=succ last in
-		  let (llast,holes,metas) =
-		    meta_aux nlast (mkMeta nlast :: lenv) q in
-		    (llast,holes,(nlast,special_nf gls (substl lenv typ))::metas) in
-	    let (nlast,holes,nmetas) =
-		meta_aux se.se_last_meta [] (List.rev rc) in
-	    let refiner = applist (appterm,List.rev holes) in
-	    let evd = meta_assign se.se_meta
-              (refiner,(ConvUpToEta 0,TypeProcessed (* ? *))) se.se_evd in
-	    let ncreated = replace_in_list
-	      se.se_meta nmetas se.se_meta_list in
-	    let evd0 = List.fold_left
-	      (fun evd (m,typ) -> meta_declare m typ evd) evd nmetas in
-	      List.iter (fun (m,typ) ->
-			   Stack.push
-			     {se_meta=m;
-			      se_type=typ;
-			      se_evd=evd0;
-			      se_meta_list=ncreated;
-			      se_last_meta=nlast} stack) (List.rev nmetas)
-	  in
-	    Array.iteri process gentypes
-      | _ -> ()
-
-let rec nf_list evd =
-  function
-      [] -> []
-    | (m,typ)::others ->
-	if meta_defined evd m then
-	    nf_list evd others
-	else
-	  (m,nf_meta evd typ)::nf_list evd others
-
-let find_subsubgoal c ctyp skip submetas gls =
-  let env= pf_env gls in
-  let concl = pf_concl gls in
-  let evd = mk_evd ((0,concl)::submetas) gls in
-  let stack = Stack.create () in
-  let max_meta =
-      List.fold_left (fun a (m,_) -> max a m) 0 submetas in
-  let _ = Stack.push
-		{se_meta=0;
-		 se_type=concl;
-		 se_last_meta=max_meta;
-		 se_meta_list=[0,concl];
-		 se_evd=evd} stack  in
-  let rec dfs n =
-    let se = Stack.pop stack in
-      try
-	let unifier =
-	  Unification.w_unify true env Reduction.CUMUL
-	    ctyp se.se_type se.se_evd in
-	  if n <= 0 then
-	      {se with
-		 se_evd=meta_assign se.se_meta
-                  (c,(ConvUpToEta 0,TypeNotProcessed (* ?? *))) unifier;
-	         se_meta_list=replace_in_list
-		  se.se_meta submetas se.se_meta_list}
-	  else
-	      dfs (pred n)
-      with _ ->
-	begin
-	  enstack_subsubgoals env se stack 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)
-
-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 rec aux env avoid subst = function
-      [] -> anomaly "concl_refiner: cannot happen"
-    | (n,typ)::rest ->
-	let _A = subst_meta subst typ in
-	let x = id_of_name_using_hdchar env _A Anonymous in
-	let _x = fresh_id avoid x gls in
-	let nenv = Environ.push_named (_x,None,_A) env in
-	let asort = family_of_sort (Typing.sort_of nenv evd _A) in
-	let nsubst = (n,mkVar _x)::subst in
-	  if rest = [] then
-	    asort,_A,mkNamedLambda _x _A (subst_meta nsubst body)
-	  else
-	    let bsort,_B,nbody =
-	      aux nenv (_x::avoid) ((n,mkVar _x)::subst) rest in
-	    let body = mkNamedLambda _x _A nbody in
-	      if occur_term (mkVar _x) _B then
-	        begin
-		  let _P = mkNamedLambda _x _A _B in
-		    match bsort,sort with
-			InProp,InProp ->
-			  let _AxB = mkApp(Lazy.force _ex,[|_A;_P|]) in
-			    InProp,_AxB,
-			  mkApp(Lazy.force _ex_ind,[|_A;_P;concl;body|])
-		    | InProp,_ ->
-			let _AxB = mkApp(Lazy.force _sig,[|_A;_P|]) in
-			let _P0 = mkLambda(Anonymous,_AxB,concl) in
-			  InType,_AxB,
-			mkApp(Lazy.force _sig_rect,[|_A;_P;_P0;body|])
-		    | _,_ ->
-			let _AxB = mkApp(Lazy.force _sigT,[|_A;_P|]) in
-			let _P0 = mkLambda(Anonymous,_AxB,concl) in
-			  InType,_AxB,
-			mkApp(Lazy.force _sigT_rect,[|_A;_P;_P0;body|])
-		end
-	      else
-		begin
-		  match asort,bsort with
-		      InProp,InProp ->
-			let _AxB = mkApp(Lazy.force _and,[|_A;_B|]) in
-			  InProp,_AxB,
-		     mkApp(Lazy.force _and_rect,[|_A;_B;concl;body|])
-		    |_,_ ->
-		       let _AxB = mkApp(Lazy.force _prod,[|_A;_B|]) in
-		       let _P0 = mkLambda(Anonymous,_AxB,concl) in
-			 InType,_AxB,
-			mkApp(Lazy.force _prod_rect,[|_A;_B;_P0;body|])
-		end
-  in
-  let (_,_,prf) = aux env [] [] metas in
-    mkApp(prf,[|mkMeta 1|])
-
-let thus_tac c ctyp submetas gls =
-  let list,proof =
-    try
-      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
-  else
-    let refiner = concl_refiner list proof gls in
-      Tactics.refine refiner gls
-
-(* general forward step *)
-
-let mk_stat_or_thesis info gls = function
-    This c -> c
-  | Thesis (For _ ) ->
-      error "\"thesis for ...\" is not applicable here."
-  | Thesis Plain -> pf_concl gls
-
-let just_tac _then cut info gls0 =
-  let items_tac gls =
-    match cut.cut_by with
-	None -> tclIDTAC gls
-      | Some items ->
-	  let items_ =
-	    if _then then
-	      let last_id = get_last (pf_env gls) in
-		(mkVar last_id)::items
-	    else items
-	  in prepare_goal items_ gls in
-  let method_tac gls =
-    match cut.cut_using with
-        None ->
-	  automation_tac gls
-      | Some tac ->
-	  (Tacinterp.eval_tactic tac) gls in
-    justification (tclTHEN items_tac method_tac) gls0
-
-let instr_cut mkstat _thus _then cut gls0 =
-  let info = get_its_info gls0 in
-  let stat = cut.cut_stat in
-  let (c_id,_) = match stat.st_label with
-      Anonymous ->
-	pf_get_new_id (id_of_string "_fact") gls0,false
-    | Name id -> id,true in
-  let c_stat = mkstat info gls0 stat.st_it in
-  let thus_tac gls=
-    if _thus then
-      thus_tac (mkVar c_id) c_stat [] gls
-    else tclIDTAC gls in
-    tclTHENS (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 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
-	  then (args.(0),
-		args.(1),
-		args.(2))
-	  else error "Previous step is not an equality."
-      | _ -> error "Previous step is not an equality."
-
-let instr_rew _thus rew_side cut gls0 =
-  let last_id =
-    try get_last (pf_env gls0) with _ -> error "No previous equality." in
-  let typ,lhs,rhs = decompose_eq last_id gls0 in
-  let items_tac gls =
-    match cut.cut_by with
-	None -> tclIDTAC gls
-      | Some items -> prepare_goal items gls in
-  let method_tac gls =
-    match cut.cut_using with
-        None ->
-	  automation_tac gls
-      | Some tac ->
-	  (Tacinterp.eval_tactic tac) gls in
-  let just_tac gls =
-    justification (tclTHEN items_tac method_tac) gls in
-  let (c_id,_) = match cut.cut_stat.st_label with
-      Anonymous ->
-	pf_get_new_id (id_of_string "_eq") gls0,false
-    | Name id -> id,true in
-  let thus_tac new_eq gls=
-    if _thus then
-      thus_tac (mkVar c_id) new_eq [] gls
-    else tclIDTAC gls in
-    match rew_side with
-	Lhs ->
-	  let new_eq = mkApp(_eq,[|typ;cut.cut_stat.st_it;rhs|]) in
-	    tclTHENS (assert_postpone c_id new_eq)
-	      [tclTHEN tcl_erase_info
-		 (tclTHENS (transitivity lhs)
-		    [just_tac;exact_check (mkVar last_id)]);
-	       thus_tac new_eq] gls0
-      | Rhs ->
-	  let new_eq = mkApp(_eq,[|typ;lhs;cut.cut_stat.st_it|]) in
-	    tclTHENS (assert_postpone c_id new_eq)
-	      [tclTHEN tcl_erase_info
-		 (tclTHENS (transitivity rhs)
-		    [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
-    | Name id -> id,true in
-  let thus_tac gls=
-    if _thus then
-      thus_tac (mkVar id) st.st_it [] gls
-    else tclIDTAC gls in
-  let ninfo1 = {pm_stack=
-      (if _thus then Focus_claim else Claim)::info.pm_stack} in
-    tclTHENS (assert_postpone id st.st_it)
-      [tcl_change_info ninfo1;
-       thus_tac] gls0
-
-(* tactics for assume *)
-
-let push_intro_tac coerce nam gls =
-      let (hid,_) =
-	match nam with
-	    Anonymous -> pf_get_new_id (id_of_string "_hyp") gls,false
-	  | Name id -> id,true in
-	tclTHENLIST
-	  [intro_mustbe_force hid;
-	   coerce hid]
-	  gls
-
-let assume_tac hyps gls =
-  List.fold_right
-    (fun (Hvar st | Hprop st) ->
-       tclTHEN
-	 (push_intro_tac
-	    (fun id ->
-	       convert_hyp (id,None,st.st_it)) st.st_label))
-	 hyps tclIDTAC gls
-
-let assume_hyps_or_theses hyps gls =
-  List.fold_right
-    (function
-	 (Hvar {st_label=nam;st_it=c} | Hprop {st_label=nam;st_it=This c}) ->
-	   tclTHEN
-	     (push_intro_tac
-		(fun id ->
-		   convert_hyp (id,None,c)) nam)
-       | Hprop {st_label=nam;st_it=Thesis (tk)} ->
-	   tclTHEN
-	     (push_intro_tac
-		(fun id -> tclIDTAC) nam))
-    hyps tclIDTAC gls
-
-let assume_st hyps gls =
-  List.fold_right
-    (fun st ->
-       tclTHEN
-	 (push_intro_tac
-	    (fun id -> convert_hyp (id,None,st.st_it)) st.st_label))
-	 hyps tclIDTAC gls
-
-let assume_st_letin hyps gls =
-  List.fold_right
-    (fun st ->
-       tclTHEN
-	 (push_intro_tac
-	    (fun id ->
-	       convert_hyp (id,Some (fst st.st_it),snd st.st_it)) st.st_label))
-	 hyps tclIDTAC gls
-
-(* suffices *)
-
-let rec metas_from n hyps =
-  match hyps with
-      _ :: q -> n :: metas_from (succ n) q
-    | [] -> []
-
-let rec build_product args body =
-  match args with
-      (Hprop st| Hvar st )::rest ->
-	let pprod= lift 1 (build_product rest body) in
-	let lbody =
-	  match st.st_label with
-	      Anonymous -> pprod
-	    | Name id -> subst_term (mkVar id) pprod in
-	  mkProd (st.st_label, st.st_it, lbody)
-    | [] -> body
-
-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
-	(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 ctx,hd = cut.cut_stat in
-  let c_stat = build_product ctx (mk_stat_or_thesis info gls0 hd) in
-  let metas = metas_from 1 ctx in
-  let c_ctx,c_head = build_applist c_stat metas in
-  let c_term = applist (mkVar c_id,List.map mkMeta metas) in
-  let thus_tac gls=
-    thus_tac c_term c_head c_ctx gls in
-   tclTHENS (assert_postpone c_id c_stat)
-     [tclTHENLIST
-	 [ assume_tac ctx;
-	   tcl_erase_info;
-	   just_tac _then cut info];
-      thus_tac] gls0
-
-(* tactics for consider/given *)
-
-let conjunction_arity id gls =
-  let typ = pf_get_hyp_typ gls id  in
-  let hd,params = decompose_app (special_whd gls typ) in
-  let env =pf_env gls in
-    match kind_of_term hd with
-	Ind ind 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
-	  let rc,_ = Reduction.dest_prod env apptype in
-	    List.length rc
-      | _ -> raise Not_found
-
-let rec intron_then n ids ltac gls =
-  if n<=0 then
-    ltac ids gls
-  else
-    let id = pf_get_new_id (id_of_string "_tmp") gls in
-      tclTHEN
-	(intro_mustbe_force id)
-	(intron_then (pred n) (id::ids) ltac) gls
-
-
-let rec consider_match may_intro introduced available expected gls =
-  match available,expected with
-      [],[] ->
-	  tclIDTAC gls
-    | _,[] -> error "Last statements do not match a complete hypothesis."
-	(* should tell which ones *)
-    | [],hyps ->
-	if may_intro then
-	  begin
- 	    let id = pf_get_new_id (id_of_string "_tmp") gls in
-	      tclIFTHENELSE
-		(intro_mustbe_force id)
-		(consider_match true [] [id] hyps)
-		(fun _ ->
-		   error "Not enough sub-hypotheses to match statements.")
-		gls
-          end
-	else
-	  error "Not enough sub-hypotheses to match statements."
-	    (* should tell which ones *)
-    | id::rest_ids,(Hvar st | Hprop st)::rest ->
-	tclIFTHENELSE (convert_hyp (id,None,st.st_it))
-	  begin
-	    match st.st_label with
-		Anonymous ->
-		  consider_match may_intro ((id,false)::introduced) rest_ids rest
-	      | Name hid ->
-		  tclTHENLIST
-		    [rename_hyp [id,hid];
-		     consider_match may_intro ((hid,true)::introduced) rest_ids rest]
-	  end
-	  begin
-	    (fun gls ->
-	       let nhyps =
-		 try conjunction_arity id gls with
-		     Not_found -> error "Matching hypothesis not found." in
-		 tclTHENLIST
-		   [general_case_analysis false (mkVar id,NoBindings);
-		    intron_then nhyps []
-		      (fun l -> consider_match may_intro introduced
-			 (List.rev_append l rest_ids) expected)] gls)
-	  end
-	  gls
-
-let consider_tac c hyps gls =
-  match kind_of_term (strip_outer_cast c) with
-      Var id ->
-	consider_match false [] [id] hyps gls
-    | _ ->
-	let id = pf_get_new_id (id_of_string "_tmp") gls in
-	tclTHEN
-	  (forward None (Some (dummy_loc, Genarg.IntroIdentifier id)) c)
- 	  (consider_match false [] [id] hyps) gls
-
-
-let given_tac hyps gls =
-  consider_match true [] [] hyps gls
-
-(* tactics for take *)
-
-let rec take_tac wits gls =
-  match wits with
-      [] -> tclIDTAC gls
-    | wit::rest ->
-	let typ = pf_type_of gls wit in
-	  tclTHEN (thus_tac wit typ []) (take_tac rest)  gls
-
-
-(* tactics for define *)
-
-let rec build_function args body =
-  match args with
-      st::rest ->
-	let pfun= lift 1 (build_function rest body) in
-	let id = match st.st_label with
-	    Anonymous -> assert false
-	  | Name id -> id in
-	  mkLambda (Name id, st.st_it, subst_term (mkVar id) pfun)
-    | [] -> body
-
-let define_tac id args body gls =
-  let t = build_function args body in
-    letin_tac None (Name id) t None Tacexpr.nowhere gls
-
-(* tactics for reconsider *)
-
-let cast_tac id_or_thesis typ gls =
-  match id_or_thesis with
-      This id ->
-	let (_,body,_) = pf_get_hyp gls id in
-	  convert_hyp (id,body,typ) gls
-    | Thesis (For _ ) ->
-	error "\"thesis for ...\" is not applicable here."
-    | Thesis Plain ->
-          convert_concl typ DEFAULTcast gls
-
-(* per cases *)
-
-let is_rec_pos (main_ind,wft) =
-  match main_ind with
-      None -> false
-    | Some index ->
-	match fst (Rtree.dest_node wft) with
-	    Mrec i when i = index -> true
-	  | _ -> false
-
-let rec constr_trees (main_ind,wft) ind =
-    match Rtree.dest_node wft with
-      Norec,_ ->
-	let itree =
-	  (snd (Global.lookup_inductive ind)).mind_recargs in
-	  constr_trees (None,itree) ind
-    | _,constrs -> main_ind,constrs
-
-let ind_args rp ind =
-    let main_ind,constrs = constr_trees rp ind in
-    let args ctree =
-      Array.map (fun t -> main_ind,t) (snd (Rtree.dest_node ctree)) in
-      Array.map args constrs
-
-let init_tree ids ind rp nexti =
-  let indargs = ind_args rp ind in
-  let do_i i arp = (Array.map is_rec_pos arp),nexti i arp in
-    Split_patt (ids,ind,Array.mapi do_i indargs)
-
-let map_tree_rp rp id_fun mapi = function
-    Split_patt (ids,ind,branches) ->
-  let indargs = ind_args rp ind in
-  let do_i i (recargs,bri) = recargs,mapi i indargs.(i) bri in
-    Split_patt (id_fun ids,ind,Array.mapi do_i branches)
-  | _ -> failwith "map_tree_rp: not a splitting node"
-
-let map_tree id_fun mapi = function
-    Split_patt (ids,ind,branches) ->
-  let do_i i (recargs,bri) = recargs,mapi i bri in
-    Split_patt (id_fun ids,ind,Array.mapi do_i branches)
-  | _ -> failwith "map_tree: not a splitting node"
-
-
-let start_tree env ind rp =
-  init_tree Idset.empty ind rp (fun _ _ -> None)
-
-let build_per_info etype casee gls =
-  let concl=pf_concl gls in
-  let env=pf_env gls in
-  let ctyp=pf_type_of gls casee in
-  let is_dep = dependent casee concl in
-  let hd,args = decompose_app (special_whd gls ctyp) in
-  let ind =
-    try
-      destInd hd
-    with _ ->
-      error "Case analysis must be done on an inductive object." in
-  let mind,oind = Global.lookup_inductive ind in
-  let nparams,index =
-    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 abstract_obj c body =
-    let typ=pf_type_of gls c in
-      lambda_create env (typ,subst_term c body) in
-  let pred= List.fold_right abstract_obj
-    real_args (lambda_create env (ctyp,subst_term casee concl)) in
-    is_dep,
-  {per_casee=casee;
-   per_ctype=ctyp;
-   per_ind=ind;
-   per_pred=pred;
-   per_args=real_args;
-   per_params=params;
-   per_nparams=nparams;
-   per_wf=index,oind.mind_recargs}
-
-let per_tac etype casee gls=
-  let env=pf_env gls in
-  let info = get_its_info gls in
-    match casee with
-	Real c ->
-	  let is_dep,per_info = build_per_info etype c gls in
-	  let ek =
-	    if is_dep then
-	      EK_dep (start_tree env per_info.per_ind per_info.per_wf)
-	    else EK_unknown in
-	    tcl_change_info
-	      {pm_stack=
-		  Per(etype,per_info,ek,[])::info.pm_stack} gls
-      | Virtual cut ->
-	  assert (cut.cut_stat.st_label=Anonymous);
-	  let id = pf_get_new_id (id_of_string "anonymous_matched") gls in
-	  let c = mkVar id in
-	  let modified_cut =
-	    {cut with cut_stat={cut.cut_stat with st_label=Name id}} in
-	    tclTHEN
-	      (instr_cut (fun _ _ c -> c) false false modified_cut)
-	      (fun gls0 ->
-		 let is_dep,per_info = build_per_info etype c gls0 in
-		   assert (not is_dep);
-		   tcl_change_info
-		     {pm_stack=
-			 Per(etype,per_info,EK_unknown,[])::info.pm_stack} gls0)
-	      gls
-
-(* suppose *)
-
-let register_nodep_subcase id= function
-    Per(et,pi,ek,clauses)::s ->
-      begin
-	match ek with
-	    EK_unknown -> clauses,Per(et,pi,EK_nodep,id::clauses)::s
-	  | 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"
-
-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 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)
-      [tclTHENLIST [tcl_change_info ninfo1;
-		    assume_tac hyps;
-		    clear old_clauses];
-       tcl_change_info ninfo2] gls0
-
-(* suppose it is ... *)
-
-(* pattern matching compiling *)
-
-let rec skip_args rest ids n =
-  if n <= 0 then
-    Close_patt rest
-  else
-    Skip_patt (ids,skip_args rest ids (pred n))
-
-let rec tree_of_pats ((id,_) as cpl) pats =
-  match pats with
-      [] -> End_patt cpl
-    | args::stack ->
-	match args with
-	    [] -> Close_patt (tree_of_pats cpl stack)
-	  | (patt,rp) :: rest_args ->
-	      match patt with
-		  PatVar (_,v) ->
-		    Skip_patt (Idset.singleton id,
-			       tree_of_pats cpl (rest_args::stack))
-		| PatCstr (_,(ind,cnum),args,nam) ->
-		    let nexti i ati =
-		      if i = pred cnum then
-			let nargs =
-			  list_map_i (fun j a -> (a,ati.(j))) 0 args in
-			  Some (Idset.singleton id,
-				tree_of_pats cpl (nargs::rest_args::stack))
-		      else None
-		      in init_tree Idset.empty ind rp nexti
-
-let rec add_branch ((id,_) as cpl) pats tree=
-  match pats with
-      [] ->
-	begin
-	  match tree with
-	      End_patt cpl0 -> End_patt cpl0
-		(* this ensures precedence for overlapping patterns *)
-	    | _ -> anomaly "tree is expected to end here"
-	end
-    | args::stack ->
-	match args with
-	    [] ->
-	      begin
-		match tree with
-		   Close_patt t ->
-		     Close_patt (add_branch cpl stack t)
-		  | _ -> anomaly "we should pop here"
-	      end
-	  | (patt,rp) :: rest_args ->
-	      match patt with
-		  PatVar (_,v) ->
-		    begin
-		      match tree with
-			  Skip_patt (ids,t) ->
-			    Skip_patt (Idset.add id ids,
-				       add_branch cpl (rest_args::stack) t)
-			| Split_patt (_,_,_) ->
-			    map_tree (Idset.add id)
-			      (fun i bri ->
-				 append_branch cpl 1 (rest_args::stack) bri)
-			      tree
-			| _ -> anomaly "No pop/stop expected here"
-		    end
-		| PatCstr (_,(ind,cnum),args,nam) ->
-		      match tree with
-			Skip_patt (ids,t) ->
-			  let nexti i ati =
-			    if i = pred cnum then
-			      let nargs =
-				list_map_i (fun j a -> (a,ati.(j))) 0 args in
-				Some (Idset.add id ids,
-				      add_branch cpl (nargs::rest_args::stack)
-					(skip_args t ids (Array.length ati)))
-			    else
-			      Some (ids,
-				    skip_args t ids (Array.length ati))
-			  in init_tree ids ind rp nexti
-		      | Split_patt (_,ind0,_) ->
-			  if (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
-			      let nargs =
-				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"
-and append_branch ((id,_) as cpl) depth pats = function
-    Some (ids,tree) ->
-      Some (Idset.add id ids,append_tree cpl depth pats tree)
-  | None ->
-      Some (Idset.singleton id,tree_of_pats cpl pats)
-and append_tree ((id,_) as cpl) depth pats tree =
-  if depth<=0 then add_branch cpl pats tree
-  else match tree with
-      Close_patt t ->
-	Close_patt (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"
-    | Split_patt (_,_,_) ->
-	map_tree (Idset.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
-  | _ :: 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
-    errorlabstrm "thesis_for"
-      ((Printer.pr_constr_env env obj) ++ spc () ++
-	 str"cannot give an induction hypothesis (wrong inductive type).") in
-  let params,args = list_chop per_info.per_nparams all_args in
-  let _ = if not (List.for_all2 eq_constr params per_info.per_params) then
-    errorlabstrm "thesis_for"
-      ((Printer.pr_constr_env env obj) ++ spc () ++
-	 str "cannot give an induction hypothesis (wrong parameters).") in
-  let hd2 = (applist ((lift (List.length rc) per_info.per_pred),args@[obj])) in
-    compose_prod rc (whd_beta Evd.empty hd2)
-
-let rec build_product_dep pat_info per_info args body gls =
-  match args with
-      (Hprop {st_label=nam;st_it=This c}
-      | Hvar {st_label=nam;st_it=c})::rest ->
-	let pprod=
-	  lift 1 (build_product_dep pat_info per_info rest body gls) in
-	let lbody =
-	  match nam with
-	      Anonymous -> body
-	    | Name id -> subst_var id pprod in
-	  mkProd (nam,c,lbody)
-    | Hprop ({st_it=Thesis tk} as st)::rest ->
-	let pprod=
-	  lift 1 (build_product_dep pat_info per_info rest body gls) in
-	let lbody =
-	  match st.st_label with
-	      Anonymous -> body
-	    | Name id -> subst_var id pprod in
-	let ptyp =
-	  match tk with
-	      For id ->
-		let obj = mkVar id in
-		let typ =
-		  try st_assoc (Name id) pat_info.pat_vars
-		  with Not_found ->
-		    snd (st_assoc (Name id) pat_info.pat_aliases) in
-		  thesis_for obj typ per_info (pf_env gls)
-	    | Plain -> pf_concl gls in
-	  mkProd (st.st_label,ptyp,lbody)
-    | [] -> body
-
-let build_dep_clause params pat_info per_info hyps gls =
-  let concl=
-    thesis_for pat_info.pat_constr pat_info.pat_typ per_info (pf_env gls) in
-  let open_clause =
-    build_product_dep pat_info per_info hyps concl gls in
-  let prod_one st body =
-    match st.st_label with
-	Anonymous -> mkProd(Anonymous,st.st_it,lift 1 body)
-      | Name id -> mkNamedProd id st.st_it (lift 1 body) in
-  let let_one_in st body =
-    match st.st_label with
-	Anonymous -> mkLetIn(Anonymous,fst st.st_it,snd st.st_it,lift 1 body)
-      | Name id ->
-	  mkNamedLetIn id (fst st.st_it) (snd st.st_it) (lift 1 body) in
-  let aliased_clause =
-    List.fold_right let_one_in pat_info.pat_aliases open_clause in
-    List.fold_right prod_one (params@pat_info.pat_vars) aliased_clause
-
-let rec register_dep_subcase id env per_info pat = function
-    EK_nodep -> error  "Only \"suppose it is\" can be used here."
-  | EK_unknown ->
-      register_dep_subcase id env per_info pat
-	(EK_dep (start_tree env per_info.per_ind per_info.per_wf))
-  | EK_dep tree -> EK_dep (add_branch id [[pat,per_info.per_wf]] tree)
-
-let case_tac params pat_info hyps gls0 =
-  let info = get_its_info gls0 in
-  let id = pf_get_new_id (id_of_string "subcase_") gls0 in
-  let et,per_info,ek,old_clauses,rest =
-    match info.pm_stack with
-	Per (et,pi,ek,old_clauses)::rest -> (et,pi,ek,old_clauses,rest)
-      | _ -> anomaly "wrong place for cases" in
-  let clause = build_dep_clause params pat_info per_info hyps gls0 in
-  let ninfo1 = {pm_stack=Suppose_case::info.pm_stack} in
-  let nek = 
-    register_dep_subcase (id,(List.length params,List.length hyps)) 
-      (pf_env gls0) per_info pat_info.pat_pat ek in  
-  let ninfo2 = {pm_stack=Per(et,per_info,nek,id::old_clauses)::rest} in
-    tclTHENS (assert_postpone id clause)
-      [tclTHENLIST
-	 [tcl_change_info ninfo1;
-	  assume_st (params@pat_info.pat_vars);
-	  assume_st_letin pat_info.pat_aliases;
-	  assume_hyps_or_theses hyps;
-	  clear old_clauses];
-       tcl_change_info ninfo2] gls0
-
-(* end cases *)
-
-type instance_stack =
-    (constr option*(constr list) list) list
-
-let initial_instance_stack ids =
-  List.map (fun id -> id,[None,[]]) ids
-
-let push_one_arg arg = function
-    [] -> anomaly "impossible"
-  | (head,args) :: ctx ->
-      ((head,(arg::args)) :: ctx)
-
-let push_arg arg stacks =
-  List.map (fun (id,stack) -> (id,push_one_arg arg stack)) stacks
-
-
-let push_one_head c ids (id,stack) =
-  let head = if Idset.mem id ids then Some c else None in
-    id,(head,[]) :: stack
-
-let push_head c ids stacks =
-  List.map (push_one_head c ids) stacks
-
-let pop_one (id,stack) =
-  let nstack=
-    match stack with
-	[] -> anomaly "impossible"
-      | [c] as l -> l
-      | (Some head,args)::(head0,args0)::ctx ->
-	  let arg = applist (head,(List.rev args)) in
-	    (head0,(arg::args0))::ctx
-     | (None,args)::(head0,args0)::ctx ->
-	 (head0,(args@args0))::ctx
-  in id,nstack
-
-let pop_stacks stacks =
-  List.map pop_one stacks
-
-let hrec_for fix_id per_info gls obj_id =
-  let obj=mkVar obj_id in
-  let typ=pf_get_hyp_typ gls obj_id in
-  let rc,hd1=decompose_prod typ in
-  let cind,all_args=decompose_app typ in
-  let ind = destInd cind in assert (ind=per_info.per_ind);
-  let params,args= list_chop per_info.per_nparams all_args in
-  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)
-
-
-let rec execute_cases fix_name per_info tacnext args objs nhrec tree gls =
-  match tree, objs  with
-      Close_patt t,_ ->
-	let args0 = pop_stacks args in
-	  execute_cases fix_name per_info tacnext args0 objs nhrec t gls
-    | Skip_patt (_,t),skipped::next_objs ->
-	let args0 = push_arg skipped args in
-	  execute_cases fix_name per_info tacnext args0 next_objs nhrec t gls
-    | End_patt (id,(nparams,nhyps)),[] -> 
-	begin
-	  match 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
-		  tclTHEN
-		    (tclDO nhrec introf)
-		    (tacnext 
-		       (applist (mkVar id,
-				 List.append param_metas 
-				   (List.rev_append br_args hyp_metas)))) gls
-	    | _ -> anomaly "wrong stack size"
-	end
-    | Split_patt (ids,ind,br), casee::next_objs ->
-	let (mind,oind) as spec = Global.lookup_inductive ind in
-	let nparams = mind.mind_nparams in
-	let concl=pf_concl gls in
-	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 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 f_ids typ =
-	  let sign =
-	    (prod_assum (Term.prod_applist typ params)) in
-	    find_intro_names sign gls in
-	let constr_args_ids = Array.map f_ids gen_arities in
-	let case_term =
-	  mkCase(case_info,elim_pred,casee,
-		 Array.mapi (fun i _ -> mkMeta (succ i)) constr_args_ids) in
-	let branch_tac i (recargs,bro) gls0 =
-	  let args_ids = constr_args_ids.(i) in
-	  let rec aux n = function
-	      [] ->
-		assert (n=Array.length recargs);
-		next_objs,[],nhrec
-	    | id :: q ->
-		let objs,recs,nrec = aux (succ n) q in
-		  if recargs.(n)
-		  then (mkVar id::objs),(id::recs),succ nrec
-		  else (mkVar id::objs),recs,nrec in
-	  let objs,recs,nhrec = aux 0 args_ids in
-	    tclTHENLIST
-	      [tclMAP intro_mustbe_force args_ids;
-	       begin
-		 fun gls1 ->
-		   let hrecs =
-		     List.map
-		       (fun id ->
-			  hrec_for (out_name fix_name) per_info gls1 id)
-		       recs in
-		     generalize hrecs gls1
-	       end;
-	       match bro with
-		   None ->
-		     msg_warning (str "missing case");
-		     tacnext (mkMeta 1)
-		 | Some (sub_ids,tree) ->
-		     let br_args =
-		       List.filter
-			 (fun (id,_) -> Idset.mem id sub_ids) args in
-		     let construct =
-		       applist (mkConstruct(ind,succ i),params) in
-		     let p_args =
-		       push_head construct ids br_args in
-		       execute_cases fix_name per_info tacnext
-			 p_args objs nhrec tree] gls0 in
-	  tclTHENSV
-	    (refine case_term)
-	    (Array.mapi branch_tac br) gls
-    | Split_patt (_, _, _) , [] ->
-	anomaly "execute_cases : Nothing to split"
-    | Skip_patt _ , [] ->
-	anomaly "execute_cases : 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 REvar _ -> RHole (dummy_loc,QuestionMark Expand) | rc ->  map_rawconstr frob rc in
-    Pretyping.Default.understand_tcc (sig_sig gls) env ~expected_type:(pf_concl gls) (frob rawc)
-
-let set_refine,my_refine =
-let refine = ref (fun (_:open_constr) -> (assert false : tactic) ) in
-((fun tac -> refine:= tac),
-(fun c gls -> 
-   let oc = understand_my_constr c gls in
-     !refine oc gls))
-
-(* end focus/claim *)
-
-let end_tac et2 gls =
-  let info = get_its_info gls in
-  let et1,pi,ek,clauses =
-    match info.pm_stack with
-	Suppose_case::_ ->
-	  anomaly "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
-    tclTHEN
-      tcl_erase_info
-      begin
-	match et,ek with
-	    _,EK_unknown ->
-	      tclSOLVE [simplest_elim pi.per_casee]
-	  | ET_Case_analysis,EK_nodep ->
-	      tclTHEN
-		(general_case_analysis false (pi.per_casee,NoBindings))
-		(default_justification (List.map mkVar clauses))
-	  | ET_Induction,EK_nodep ->
-	      tclTHENLIST
-		[generalize (pi.per_args@[pi.per_casee]);
-		 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])
-		   (initial_instance_stack clauses) [pi.per_casee] 0 tree
-	  | ET_Induction,EK_dep tree ->
-	      let nargs = (List.length pi.per_args) in
-		tclTHEN (generalize (pi.per_args@[pi.per_casee]))
-		  begin
-		    fun gls0 ->
-		      let fix_id =
-			pf_get_new_id (id_of_string "_fix") gls0 in
-		      let c_id =
-			pf_get_new_id (id_of_string "_main_arg") gls0 in
-			tclTHENLIST
-			  [fix (Some fix_id) (succ nargs);
-			   tclDO nargs introf;
-			   intro_mustbe_force c_id;
-			   execute_cases (Name fix_id) pi
-			     (fun c ->
-				tclTHENLIST
-				  [clear [fix_id];
-				   my_refine c;
-				   clear clauses;
-				   justification assumption])
-			     (initial_instance_stack clauses)
-			     [mkVar c_id]  0 tree] gls0
-		  end
-      end gls
-
-(* escape *)
-
-let escape_tac gls =  tcl_erase_info gls
-
-(* General instruction engine *)
-
-let rec do_proof_instr_gen _thus _then instr =
-  match instr with
-      Pthus i ->
-	assert (not _thus);
-	do_proof_instr_gen true _then i
-    | Pthen i ->
-	assert (not _then);
-	do_proof_instr_gen _thus true i
-    | Phence i ->
-	assert (not (_then || _thus));
-	do_proof_instr_gen true true i
-    | Pcut c ->
-	instr_cut mk_stat_or_thesis _thus _then c
-    | Psuffices c ->
-	instr_suffices _then c
-    | Prew (s,c) ->
-	assert (not _then);
-	instr_rew _thus s c
-    | Pconsider (c,hyps)    -> consider_tac c hyps
-    | Pgiven hyps            -> given_tac hyps
-    | Passume hyps           -> assume_tac hyps
-    | Plet hyps              -> assume_tac hyps
-    | Pclaim st              -> instr_claim false st
-    | Pfocus st              -> instr_claim true st
-    | Ptake witl             -> take_tac witl
-    | Pdefine (id,args,body) -> define_tac id args body
-    | Pcast (id,typ)         -> cast_tac id typ
-    | Pper (et,cs)           -> per_tac et cs
-    | Psuppose hyps      -> suppose_tac hyps
-    | Pcase (params,pat_info,hyps) -> case_tac params pat_info hyps
-    | Pend (B_elim et) -> end_tac et
-    | Pend _ -> anomaly "Not applicable"
-    | Pescape -> escape_tac
-
-let eval_instr {instr=instr} =
-  do_proof_instr_gen false false instr
-
-let rec preprocess pts instr =
-  match instr with
-    Phence i |Pthus i | Pthen i -> preprocess pts i
-  | Psuffices _ | Pcut _ |  Passume _ | Plet _ | Pclaim _ | Pfocus _
-  | Pconsider (_,_) | Pcast (_,_) | Pgiven _ | Ptake _
-  | Pdefine (_,_,_) | Pper _ | Prew _ ->
-      check_not_per pts;
-      true,pts
-  | Pescape ->
-      check_not_per pts;
-      true,pts
-  | Pcase _ | Psuppose _ | Pend (B_elim _) ->
-      true,close_previous_case pts
-  | Pend bt ->
-      false,close_block bt pts
-
-let rec postprocess pts instr =
-  match instr with
-      Phence i | Pthus i | Pthen i -> postprocess pts i
-    | Pcut _ | Psuffices _ | Passume _ | Plet _ | Pconsider (_,_) | Pcast (_,_)
-    | Pgiven _ | Ptake _ | Pdefine (_,_,_) | Prew (_,_) -> pts
-    | Pclaim _ | Pfocus _ | Psuppose _ | Pcase _ | Pper _
-    | Pescape -> nth_unproven 1 pts
-    | Pend (B_elim ET_Induction) ->
-  	begin
-	  let pf = proof_of_pftreestate pts in
-	  let (pfterm,_) = extract_open_pftreestate pts in
-	  let env =  Evd.evar_env (goal_of_proof pf) in
-	    try
-	      Inductiveops.control_only_guard env pfterm;
-	      goto_current_focus_or_top (mark_as_done pts)
- 	    with
-		Type_errors.TypeError(env,
-				      Type_errors.IllFormedRecBody(_,_,_,_,_)) ->
-		  anomaly "\"end induction\" generated an ill-formed fixpoint"
-	end
-    | Pend _ ->
-	goto_current_focus_or_top (mark_as_done pts)
-
-let do_instr raw_instr pts =
-  let has_tactic,pts1 = preprocess pts raw_instr.instr in
-  let pts2 =
-    if has_tactic then
-      let gl = nth_goal_of_pftreestate 1 pts1 in
-      let env=  pf_env gl in
-      let sigma= project gl in
-      let ist = {ltacvars = ([],[]); ltacrecvars = [];
-		 gsigma = sigma; genv = env} in
-      let glob_instr = intern_proof_instr ist raw_instr in
-      let instr =
-	interp_proof_instr (get_its_info gl) sigma env glob_instr in
-      let lock_focus = is_focussing_instr instr.instr in
-      let marker= Proof_instr (lock_focus,instr) in
-	solve_nth_pftreestate 1
-	  (abstract_operation marker (tclTHEN (eval_instr instr) clean_tmp)) pts1
-    else pts1 in
-      postprocess pts2 raw_instr.instr
-
-let proof_instr raw_instr =
-  Pfedit.mutate (do_instr raw_instr)
-
-(*
-
-(* STUFF FOR ITERATED RELATIONS *)
-let decompose_bin_app t=
-  let hd,args = destApp
-
-let identify_transitivity_lemma c =
-  let varx,tx,c1 = destProd c in
-  let vary,ty,c2 = destProd (pop c1) in
-  let varz,tz,c3 = destProd (pop c2) in
-  let _,p1,c4 = destProd (pop c3) in
-  let _,lp2,lp3 = destProd (pop c4) in
-  let p2=pop lp2 in
-  let p3=pop lp3 in
-*)
-
diff --git a/tactics/decl_proof_instr.mli b/tactics/decl_proof_instr.mli
deleted file mode 100644
index 5af60a1b..00000000
--- a/tactics/decl_proof_instr.mli
+++ /dev/null
@@ -1,119 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(* $Id: decl_proof_instr.mli 14641 2011-11-06 11:59:10Z herbelin $ *)
-
-open Refiner
-open Names
-open Term
-open Tacmach
-open Decl_mode
-
-val go_to_proof_mode: unit -> unit
-val return_from_tactic_mode: unit -> unit
-
-val register_automation_tac: tactic -> unit
-
-val automation_tac : tactic
-
-val daimon_subtree: pftreestate -> pftreestate
-
-val concl_refiner:
-  Termops.meta_type_map -> constr -> Proof_type.goal sigma -> constr
-
-val do_instr: Decl_expr.raw_proof_instr -> pftreestate -> pftreestate
-val proof_instr: Decl_expr.raw_proof_instr -> unit
-
-val tcl_change_info : Decl_mode.pm_info -> tactic
-
-val mark_proof_tree_as_done : Proof_type.proof_tree -> Proof_type.proof_tree
-
-val mark_as_done : pftreestate -> pftreestate
-
-val execute_cases :
-    Names.name ->
-    Decl_mode.per_info ->
-    (Term.constr -> Proof_type.tactic) ->
-    (Names.Idset.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) -> (Rawterm.cases_pattern*recpath) list list ->
-  split_tree
-
-val add_branch : 
-  identifier * (int * int) -> (Rawterm.cases_pattern*recpath) list list ->
-  split_tree -> split_tree
-
-val append_branch :
-  identifier *(int * int) -> int -> (Rawterm.cases_pattern*recpath) list list ->
-  (Names.Idset.t * Decl_mode.split_tree) option ->
-  (Names.Idset.t * Decl_mode.split_tree) option
-
-val append_tree :
-  identifier * (int * int) -> int -> (Rawterm.cases_pattern*recpath) list list ->
-  split_tree -> split_tree
-
-val build_dep_clause :   Term.types Decl_expr.statement list ->
-    Decl_expr.proof_pattern ->
-    Decl_mode.per_info ->
-    (Term.types Decl_expr.statement, Term.types Decl_expr.or_thesis)
-    Decl_expr.hyp list -> Proof_type.goal Tacmach.sigma -> Term.types
-
-val register_dep_subcase :    
-    Names.identifier * (int * int) ->
-    Environ.env ->
-    Decl_mode.per_info ->
-    Rawterm.cases_pattern -> Decl_mode.elim_kind -> Decl_mode.elim_kind
-
-val thesis_for :     Term.constr ->
-    Term.constr -> Decl_mode.per_info -> Environ.env -> Term.constr
-
-val close_previous_case : pftreestate -> pftreestate
-
-val pop_stacks :
-  (Names.identifier *
-     (Term.constr option * Term.constr list) list) list ->
-  (Names.identifier *
-     (Term.constr option * Term.constr list) list) list
-
-val push_head :   Term.constr ->
-  Names.Idset.t ->
-  (Names.identifier *
-     (Term.constr option * Term.constr list) list) list ->
-  (Names.identifier *
-     (Term.constr option * Term.constr list) list) list
-
-val push_arg : Term.constr ->
-  (Names.identifier *
-     (Term.constr option * Term.constr list) list) list ->
-  (Names.identifier *
-     (Term.constr option * Term.constr list) list) list
-
-val hrec_for:
-    Names.identifier ->
-    Decl_mode.per_info -> Proof_type.goal Tacmach.sigma ->
-    Names.identifier -> Term.constr
-
-val consider_match :
-   bool ->
-    (Names.Idset.elt*bool) list ->
-    Names.Idset.elt list ->
-    (Term.types Decl_expr.statement, Term.types) Decl_expr.hyp list ->
-    Proof_type.tactic
-
-val init_tree:
-    Names.Idset.t ->
-    Names.inductive ->
-    int option * Declarations.wf_paths ->
-    (int ->
-     (int option * Declarations.recarg Rtree.t) array ->
-     (Names.Idset.t * Decl_mode.split_tree) option) ->
-    Decl_mode.split_tree
-
-val set_refine : (Evd.open_constr -> Proof_type.tactic) -> unit
diff --git a/tactics/dhyp.ml b/tactics/dhyp.ml
index 041e58df..fd924707 100644
--- a/tactics/dhyp.ml
+++ b/tactics/dhyp.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: dhyp.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 (* Chet's comments about this tactic :
 
  Programmable destruction of hypotheses and conclusions.
@@ -118,7 +116,7 @@ open Term
 open Environ
 open Reduction
 open Proof_type
-open Rawterm
+open Glob_term
 open Tacmach
 open Refiner
 open Tactics
@@ -222,7 +220,7 @@ let subst_dd (subst,(local,na,dd)) =
     d_pri = dd.d_pri;
     d_code = !forward_subst_tactic subst dd.d_code })
 
-let (inDD,_) =
+let inDD : bool * identifier * destructor_data -> obj =
   declare_object {(default_object "DESTRUCT-HYP-CONCL-DATA") with
                     cache_function = cache_dd;
 		    open_function = (fun i o -> if i=1 then cache_dd o);
@@ -292,7 +290,7 @@ let applyDestructor cls discard dd gls =
       match cl, dd.d_code with
         | Some id, (Some x, tac) ->
 	    let arg =
-              ConstrMayEval(ConstrTerm (RRef(dummy_loc,VarRef id),None)) in
+              ConstrMayEval(ConstrTerm (GRef(dummy_loc,VarRef id),None)) in
             TacLetIn (false, [(dummy_loc, x), arg], tac)
         | None, (None, tac) -> tac
         | _, (Some _,_) -> error "Destructor expects an hypothesis."
diff --git a/tactics/dhyp.mli b/tactics/dhyp.mli
index 4cde3b49..1bdeed6a 100644
--- a/tactics/dhyp.mli
+++ b/tactics/dhyp.mli
@@ -1,20 +1,16 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: dhyp.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Names
 open Tacmach
 open Tacexpr
-(*i*)
 
-(* Programmable destruction of hypotheses and conclusions. *)
+(** Programmable destruction of hypotheses and conclusions. *)
 
 val set_extern_interp : (glob_tactic_expr -> tactic) -> unit
 
@@ -28,5 +24,5 @@ val h_auto_tdb : int option -> tactic
 
 val add_destructor_hint :
   Vernacexpr.locality_flag -> identifier -> (bool,unit) Tacexpr.location ->
-    Rawterm.patvar list * Pattern.constr_pattern -> int ->
+    Glob_term.patvar list * Pattern.constr_pattern -> int ->
       glob_tactic_expr -> unit
diff --git a/tactics/dn.mli b/tactics/dn.mli
index 3cb52a56..662ac19a 100644
--- a/tactics/dn.mli
+++ b/tactics/dn.mli
@@ -17,7 +17,7 @@ sig
 
   val create : unit -> t
     
-  (* [add t f (tree,inf)] adds a structured object [tree] together with
+  (** [add t f (tree,inf)] adds a structured object [tree] together with
      the associated information [inf] to the table [t]; the function
      [f] is used to translated [tree] into its prefix decomposition: [f]
      must decompose any tree into a label characterizing its root node and
@@ -31,7 +31,8 @@ sig
       
   type 'tree lookup_fun = 'tree -> (Y.t * 'tree list) lookup_res
     
-(* [lookup t f tree] looks for trees (and their associated
+
+(** [lookup t f tree] looks for trees (and their associated
    information) in table [t] such that the structured object [tree]
    matches against them; [f] is used to translated [tree] into its
    prefix decomposition: [f] must decompose any tree into a label
diff --git a/tactics/eauto.ml4 b/tactics/eauto.ml4
index e0cdbcfa..9966fb77 100644
--- a/tactics/eauto.ml4
+++ b/tactics/eauto.ml4
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,8 +8,6 @@
 
 (*i camlp4deps: "parsing/grammar.cma" i*)
 
-(* $Id: eauto.ml4 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Pp
 open Util
 open Names
@@ -19,7 +17,6 @@ open Termops
 open Sign
 open Reduction
 open Proof_type
-open Proof_trees
 open Declarations
 open Tacticals
 open Tacmach
@@ -28,7 +25,7 @@ open Tactics
 open Pattern
 open Clenv
 open Auto
-open Rawterm
+open Glob_term
 open Hiddentac
 
 let eauto_unif_flags = { auto_unif_flags with Unification.modulo_delta = full_transparent_state }
@@ -71,6 +68,7 @@ let rec prolog l n gl =
   (tclFIRST (List.map (fun t -> (tclTHEN t prol)) (one_step l gl))) gl
 
 let prolog_tac l n gl =
+  let l = List.map (prepare_hint (pf_env gl)) l in
   let n =
     match n with
       |  ArgArg n -> n
@@ -81,7 +79,7 @@ let prolog_tac l n gl =
     errorlabstrm "Prolog.prolog" (str "Prolog failed.")
 
 TACTIC EXTEND prolog
-| [ "prolog" "[" constr_list(l) "]" int_or_var(n) ] -> [ prolog_tac l n ]
+| [ "prolog" "[" open_constr_list(l) "]" int_or_var(n) ] -> [ prolog_tac l n ]
 END
 
 open Auto
@@ -95,7 +93,7 @@ let priority l = List.map snd (List.filter (fun (pr,_) -> pr = 0) l)
 
 let unify_e_resolve flags (c,clenv) gls =
   let clenv' = connect_clenv gls clenv in
-  let _ = clenv_unique_resolver false ~flags clenv' gls in
+  let _ = clenv_unique_resolver ~flags clenv' gls in
   h_simplest_eapply c gls
 
 let rec e_trivial_fail_db db_list local_db goal =
@@ -170,7 +168,7 @@ let find_first_goal gls =
 
 type search_state = {
   depth : int; (*r depth of search before failing *)
-  tacres : goal list sigma * validation;
+  tacres : goal list sigma;
   last_tactic : std_ppcmds Lazy.t;
   dblist : Auto.hint_db list;
   localdb :  Auto.hint_db list }
@@ -179,15 +177,15 @@ module SearchProblem = struct
 
   type state = search_state
 
-  let success s = (sig_it (fst s.tacres)) = []
+  let success s = (sig_it s.tacres) = []
 
   let pr_ev evs ev = Printer.pr_constr_env (Evd.evar_env ev) (Evarutil.nf_evar evs ev.Evd.evar_concl)
 
   let pr_goals gls =
-    let evars = Evarutil.nf_evars (Refiner.project gls) in
+    let evars = Evarutil.nf_evar_map (Refiner.project gls) in
       prlist (pr_ev evars) (sig_it gls)
 
-  let filter_tactics (glls,v) l =
+  let filter_tactics glls l =
 (*     let _ = Proof_trees.db_pr_goal (List.hd (sig_it glls)) in *)
 (*     let evars = Evarutil.nf_evars (Refiner.project glls) in *)
 (*     msg (str"Goal:" ++ pr_ev evars (List.hd (sig_it glls)) ++ str"\n"); *)
@@ -195,11 +193,10 @@ module SearchProblem = struct
       | [] -> []
       | (tac,pptac) :: tacl ->
 	  try
-	    let (lgls,ptl) = apply_tac_list tac glls in
-	    let v' p = v (ptl p) in
+	    let lgls = apply_tac_list tac glls in
 (* 	    let gl = Proof_trees.db_pr_goal (List.hd (sig_it glls)) in *)
 (* 	      msg (hov 1 (pptac ++ str" gives: \n" ++ pr_goals lgls ++ str"\n")); *)
-	      ((lgls,v'),pptac) :: aux tacl
+	      (lgls,pptac) :: aux tacl
 	  with e -> Refiner.catch_failerror e; aux tacl
     in aux l
 
@@ -207,14 +204,14 @@ module SearchProblem = struct
      number of remaining goals. *)
   let compare s s' =
     let d = s'.depth - s.depth in
-    let nbgoals s = List.length (sig_it (fst s.tacres)) in
+    let nbgoals s = List.length (sig_it s.tacres) in
     if d <> 0 then d else nbgoals s - nbgoals s'
 
   let branching s =
     if s.depth = 0 then
       []
     else
-      let lg = fst s.tacres in
+      let lg = s.tacres in
       let nbgl = List.length (sig_it lg) in
       assert (nbgl > 0);
       let g = find_first_goal lg in
@@ -232,7 +229,7 @@ module SearchProblem = struct
       in
       let intro_tac =
 	List.map
-	  (fun ((lgls,_) as res,pp) ->
+	  (fun (lgls as res,pp) ->
 	     let g' = first_goal lgls in
 	     let hintl =
 	       make_resolve_hyp (pf_env g') (project g') (pf_last_hyp g')
@@ -248,7 +245,7 @@ module SearchProblem = struct
 	  filter_tactics s.tacres (e_possible_resolve s.dblist (List.hd s.localdb) (pf_concl g))
 	in
 	List.map
-	  (fun ((lgls,_) as res, pp) ->
+	  (fun (lgls as res, pp) ->
 	     let nbgl' = List.length (sig_it lgls) in
 	     if nbgl' < nbgl then
 	       { depth = s.depth; tacres = res; last_tactic = pp;
@@ -294,7 +291,7 @@ let e_breadth_search debug n db_list local_db gl =
   with Not_found -> error "eauto: breadth first search failed."
 
 let e_search_auto debug (in_depth,p) lems db_list gl =
-  let local_db = make_local_hint_db true lems gl in
+  let local_db = make_local_hint_db ~ts:full_transparent_state true lems gl in
   if in_depth then
     e_depth_search debug p db_list local_db gl
   else
@@ -306,18 +303,12 @@ let eauto_with_bases debug np lems db_list =
   tclTRY (e_search_auto debug np lems db_list)
 
 let eauto debug np lems dbnames =
-  let db_list =
-    List.map
-      (fun x ->
-	 try searchtable_map x
-	 with Not_found -> error ("No such Hint database: "^x^"."))
-      ("core"::dbnames)
-  in
+  let db_list = make_db_list dbnames in
   tclTRY (e_search_auto debug np lems db_list)
 
 let full_eauto debug n lems gl =
   let dbnames = current_db_names () in
-  let dbnames =  list_subtract dbnames ["v62"] in
+  let dbnames =  list_remove "v62" dbnames in
   let db_list = List.map searchtable_map dbnames in
   tclTRY (e_search_auto debug n lems db_list) gl
 
@@ -349,19 +340,20 @@ ARGUMENT EXTEND hintbases
 | [ ] -> [ Some [] ]
 END
 
-let pr_constr_coma_sequence prc _ _ = prlist_with_sep pr_comma prc
+let pr_constr_coma_sequence prc _ _ =
+  prlist_with_sep pr_comma (fun (_,c) -> prc c)
 
 ARGUMENT EXTEND constr_coma_sequence
-  TYPED AS constr_list
+  TYPED AS open_constr_list
   PRINTED BY pr_constr_coma_sequence
-| [ constr(c) "," constr_coma_sequence(l) ] -> [ c::l ]
-| [ constr(c) ] -> [ [c] ]
+| [ open_constr(c) "," constr_coma_sequence(l) ] -> [ c::l ]
+| [ open_constr(c) ] -> [ [c] ]
 END
 
-let pr_auto_using prc _prlc _prt = Pptactic.pr_auto_using prc
+let pr_auto_using prc _prlc _prt = Pptactic.pr_auto_using (fun (_,c) -> prc c)
 
 ARGUMENT EXTEND auto_using
-  TYPED AS constr_list
+  TYPED AS open_constr_list
   PRINTED BY pr_auto_using
 | [ "using" constr_coma_sequence(l) ] -> [ l ]
 | [ ] -> [ [] ]
@@ -414,19 +406,6 @@ let autounfold db cls gl =
     | OnConcl occs -> tac occs None)
     cls gl
 
-let autosimpl db cl =
-  let unfold_of_elts constr (b, elts) =
-    if not b then
-      List.map (fun c -> all_occurrences, constr c) elts
-    else []
-  in
-  let unfolds = List.concat (List.map (fun dbname ->
-    let db = searchtable_map dbname in
-    let (ids, csts) = Hint_db.transparent_state db in
-      unfold_of_elts (fun x -> EvalConstRef x) (Cpred.elements csts) @
-      unfold_of_elts (fun x -> EvalVarRef x) (Idpred.elements ids)) db)
-  in unfold_option unfolds cl
-
 open Extraargs
 
 TACTIC EXTEND autounfold
@@ -520,3 +499,55 @@ END
 TACTIC EXTEND convert_concl_no_check
 | ["convert_concl_no_check" constr(x) ] -> [ convert_concl_no_check x DEFAULTcast ]
 END
+
+
+let pr_hints_path_atom prc _ _ a =
+  match a with
+  | PathAny -> str"."
+  | PathHints grs ->
+    prlist_with_sep pr_spc Printer.pr_global grs
+
+ARGUMENT EXTEND hints_path_atom
+  TYPED AS hints_path_atom
+  PRINTED BY pr_hints_path_atom
+| [ global_list(g) ] -> [ PathHints (List.map Nametab.global g) ]
+| [ "*" ] -> [ PathAny ]
+END
+
+let pr_hints_path prc prx pry c =
+  let rec aux = function
+  | PathAtom a -> pr_hints_path_atom prc prx pry a
+  | PathStar p -> str"(" ++ aux p ++ str")*"
+  | PathSeq (p, p') -> aux p ++ spc () ++ aux p'
+  | PathOr (p, p') -> str "(" ++ aux p ++ str"|" ++ aux p' ++ str")"
+  | PathEmpty -> str"ø"
+  | PathEpsilon -> str"ε"
+  in aux c
+
+ARGUMENT EXTEND hints_path
+  TYPED AS hints_path
+  PRINTED BY pr_hints_path
+| [ "(" hints_path(p) ")"  ] -> [ p ]
+| [ "!" hints_path(p)  ] -> [ PathStar p ]
+| [ "emp" ] -> [ PathEmpty ]
+| [ "eps" ] -> [ PathEpsilon ]
+| [ hints_path_atom(a) ] -> [ PathAtom a ]
+| [ hints_path(p) "|" hints_path(q) ] -> [ PathOr (p, q) ]
+| [ hints_path(p) ";" hints_path(q) ] -> [ PathSeq (p, q) ]
+END
+
+let pr_hintbases _prc _prlc _prt = Pptactic.pr_hintbases
+
+ARGUMENT EXTEND opthints
+  TYPED AS preident_list_opt
+  PRINTED BY pr_hintbases
+| [ ":" ne_preident_list(l) ] -> [ Some l ]
+| [ ] -> [ None ]
+END
+
+VERNAC COMMAND EXTEND HintCut
+| [ "Hint" "Cut" "[" hints_path(p) "]" opthints(dbnames) ] -> [
+  let entry = HintsCutEntry p in
+    Auto.add_hints (Vernacexpr.use_section_locality ()) 
+      (match dbnames with None -> ["core"] | Some l -> l) entry ]
+END
diff --git a/tactics/eauto.mli b/tactics/eauto.mli
index b40261b6..68ec42f4 100644
--- a/tactics/eauto.mli
+++ b/tactics/eauto.mli
@@ -1,12 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i*)
 open Term
 open Proof_type
 open Tacexpr
@@ -15,13 +14,12 @@ open Topconstr
 open Evd
 open Environ
 open Explore
-(*i*)
 
-val hintbases : hint_db_name list option Pcoq.Gram.Entry.e
+val hintbases : hint_db_name list option Pcoq.Gram.entry
 val wit_hintbases : hint_db_name list option typed_abstract_argument_type
 val rawwit_hintbases : hint_db_name list option raw_abstract_argument_type
 
-val rawwit_auto_using : constr_expr list raw_abstract_argument_type
+val rawwit_auto_using : Genarg.open_constr_expr list raw_abstract_argument_type
 
 val e_assumption : tactic
 
@@ -29,13 +27,12 @@ val registered_e_assumption : tactic
 
 val e_give_exact : ?flags:Unification.unify_flags -> constr -> tactic
 
-val gen_eauto : bool -> bool * int -> constr list ->
+val gen_eauto : bool -> bool * int -> open_constr list ->
   hint_db_name list option -> tactic
 
-
 val eauto_with_bases :
   bool ->
   bool * int ->
-  Term.constr list -> Auto.hint_db list -> Proof_type.tactic
+  open_constr list -> Auto.hint_db list -> Proof_type.tactic
 
 val autounfold : hint_db_name list -> Tacticals.clause -> tactic
diff --git a/tactics/elim.ml b/tactics/elim.ml
index f3517ea6..1ff8800f 100644
--- a/tactics/elim.ml
+++ b/tactics/elim.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: elim.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Pp
 open Util
 open Names
@@ -111,12 +109,6 @@ let head_in gls indl t =
     in List.mem ity indl
   with Not_found -> false
 
-let inductive_of = function
-  | IndRef ity -> ity
-  | r ->
-      errorlabstrm "Decompose"
-        (Printer.pr_global r ++ str " is not an inductive type.")
-
 let decompose_these c l gls =
   let indl = (*List.map inductive_of*) l in
   general_decompose (fun (_,t) -> head_in gls indl t) c gls
@@ -136,8 +128,6 @@ let decompose_or c gls =
     (fun (_,t) -> is_disjunction t)
     c gls
 
-let inj_open c = (Evd.empty,c)
-
 let h_decompose l c =
   Refiner.abstract_tactic (TacDecompose (l,c)) (decompose_these c l)
 
diff --git a/tactics/elim.mli b/tactics/elim.mli
index c6aecad7..48a7ca68 100644
--- a/tactics/elim.mli
+++ b/tactics/elim.mli
@@ -1,23 +1,19 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: elim.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Names
 open Term
 open Proof_type
 open Tacmach
 open Genarg
 open Tacticals
-(*i*)
 
-(* Eliminations tactics. *)
+(** Eliminations tactics. *)
 
 val introElimAssumsThen :
   (branch_assumptions -> tactic) -> branch_args -> tactic
@@ -34,5 +30,5 @@ val h_decompose       : inductive list -> constr -> tactic
 val h_decompose_or    : constr -> tactic
 val h_decompose_and   : constr -> tactic
 
-val double_ind : Rawterm.quantified_hypothesis -> Rawterm.quantified_hypothesis -> tactic
-val h_double_induction : Rawterm.quantified_hypothesis -> Rawterm.quantified_hypothesis->tactic
+val double_ind : Glob_term.quantified_hypothesis -> Glob_term.quantified_hypothesis -> tactic
+val h_double_induction : Glob_term.quantified_hypothesis -> Glob_term.quantified_hypothesis->tactic
diff --git a/tactics/elimschemes.ml b/tactics/elimschemes.ml
index c60938ed..fbf36c1c 100644
--- a/tactics/elimschemes.ml
+++ b/tactics/elimschemes.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: elimschemes.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 (* Created by Hugo Herbelin from contents related to inductive schemes
    initially developed by Christine Paulin (induction schemes), Vincent
    Siles (decidable equality and boolean equality) and Matthieu Sozeau
diff --git a/tactics/elimschemes.mli b/tactics/elimschemes.mli
index ab01a5fa..06d44550 100644
--- a/tactics/elimschemes.mli
+++ b/tactics/elimschemes.mli
@@ -1,16 +1,14 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: elimschemes.mli 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Ind_tables
 
-(* Induction/recursion schemes *)
+(** Induction/recursion schemes *)
 
 val rect_scheme_kind_from_prop : individual scheme_kind
 val ind_scheme_kind_from_prop : individual scheme_kind
@@ -21,7 +19,7 @@ val ind_dep_scheme_kind_from_type : individual scheme_kind
 val rec_dep_scheme_kind_from_type : individual scheme_kind
 
 
-(* Case analysis schemes *)
+(** Case analysis schemes *)
 
 val case_scheme_kind_from_type : individual scheme_kind
 val case_scheme_kind_from_prop : individual scheme_kind
diff --git a/tactics/eqdecide.ml4 b/tactics/eqdecide.ml4
index a16e99bb..6d40b2da 100644
--- a/tactics/eqdecide.ml4
+++ b/tactics/eqdecide.ml4
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -14,8 +14,6 @@
 
 (*i camlp4deps: "parsing/grammar.cma" i*)
 
-(* $Id: eqdecide.ml4 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Util
 open Names
 open Namegen
@@ -29,7 +27,6 @@ open Auto
 open Pattern
 open Matching
 open Hipattern
-open Proof_trees
 open Proof_type
 open Tacmach
 open Coqlib
@@ -163,8 +160,7 @@ let decideGralEquality g =
 
 let decideEqualityGoal = tclTHEN intros decideGralEquality
 
-let decideEquality c1 c2 g =
-  let rectype = (pf_type_of g c1) in
+let decideEquality rectype g =
   let decide  = mkGenDecideEqGoal rectype g in
   (tclTHENS (cut decide) [default_auto;decideEqualityGoal]) g
 
@@ -178,13 +174,12 @@ let compare c1 c2 g =
             [(tclTHEN  intro
              (tclTHEN (onLastHyp simplest_case)
                        clear_last));
-             decideEquality c1 c2]) g
+             decideEquality (pf_type_of g c1)]) g
 
 
 (* User syntax *)
 
 TACTIC EXTEND decide_equality
-  [ "decide" "equality" constr(c1) constr(c2) ] -> [ decideEquality c1 c2 ]
 | [ "decide" "equality" ] -> [ decideEqualityGoal ]
 END
 
diff --git a/tactics/eqschemes.ml b/tactics/eqschemes.ml
index 88931415..779fe265 100644
--- a/tactics/eqschemes.ml
+++ b/tactics/eqschemes.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: eqschemes.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 (* File created by Hugo Herbelin, Nov 2009 *)
 
 (* This file builds schemes related to equality inductive types,
@@ -70,8 +68,8 @@ let build_dependent_inductive ind (mib,mip) =
        extended_rel_list mip.mind_nrealargs_ctxt mib.mind_params_ctxt
        @ extended_rel_list 0 realargs)
 
-let my_it_mkLambda_or_LetIn s c = it_mkLambda_or_LetIn ~init:c s
-let my_it_mkProd_or_LetIn s c = it_mkProd_or_LetIn ~init:c s
+let my_it_mkLambda_or_LetIn s c = it_mkLambda_or_LetIn c s
+let my_it_mkProd_or_LetIn s c = it_mkProd_or_LetIn c s
 let my_it_mkLambda_or_LetIn_name s c =
   it_mkLambda_or_LetIn_name (Global.env()) c s
 
@@ -110,7 +108,7 @@ let get_sym_eq_data env ind =
   let _,params2 = list_chop (mib.mind_nparams-mip.mind_nrealargs) params in
   let paramsctxt1,_ =
     list_chop (mib.mind_nparams-mip.mind_nrealargs) mib.mind_params_ctxt in
-  if params2 <> constrargs then
+  if not (list_equal eq_constr params2 constrargs) then
     error "Constructors arguments must repeat the parameters.";
   (* nrealargs_ctxt and nrealargs are the same here *)
   (specif,mip.mind_nrealargs,realsign,mib.mind_params_ctxt,paramsctxt1)
@@ -176,7 +174,7 @@ let build_sym_scheme env ind =
        [|cstr (nrealargs+1)|]))))
 
 let sym_scheme_kind =
-  declare_individual_scheme_object "_sym"
+  declare_individual_scheme_object "_sym_internal"
   (fun ind -> build_sym_scheme (Global.env() (* side-effect! *)) ind)
 
 (**********************************************************************)
@@ -635,27 +633,14 @@ let rew_l2r_forward_dep_scheme_kind =
 (**********************************************************************)
 (* Non-dependent rewrite from either left-to-right in conclusion or   *)
 (* right-to-left in hypotheses: both l2r_rew and r2l_forward_rew are  *)
-(* potential candidates. However r2l_forward_rew introduces a blocked *)
-(* beta-expansion that blocks in turn the guard condition if this     *)
-(* one does not support commutative cuts while l2r_rew does not       *)
-(* support non symmetrical equalities, so...                          *)
-(**********************************************************************)
-
-(**********************************************************************)
-(* ... we use l2r_rew for the symmetrical case:                       *)
+(* potential candidates. Since l2r_rew needs a symmetrical equality,  *)
+(* we adopt r2l_forward_rew (this one introduces a blocked beta-      *)
+(* expansion but since the guard condition supports commutative cuts  *)
+(* this is not a problem; we need though a fix to adjust it to the    *)
+(* standard form of schemes in Coq)                                   *)
 (**********************************************************************)
 let rew_l2r_scheme_kind =
   declare_individual_scheme_object "_rew_r"
-  (fun ind -> build_l2r_rew_scheme false (Global.env()) ind InType)
-
-(**********************************************************************)
-(* ... and r2l_forward_rew for the non-symmetrical case, even though  *)
-(* it may break the guard condition. Moreover, its standard form      *)
-(* needs the inductive hypothesis not in last position what breaks    *)
-(* the order of goals and need a fix:                                 *)
-(**********************************************************************)
-let rew_asym_scheme_kind =
-  declare_individual_scheme_object "_rew_r_asym"
   (fun ind -> fix_r2l_forward_rew_scheme
       (build_r2l_forward_rew_scheme false (Global.env()) ind InType))
 
diff --git a/tactics/eqschemes.mli b/tactics/eqschemes.mli
index 08b3b05c..870ca6b6 100644
--- a/tactics/eqschemes.mli
+++ b/tactics/eqschemes.mli
@@ -1,21 +1,19 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: eqschemes.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(* This file builds schemes relative to equality inductive types *)
+(** This file builds schemes relative to equality inductive types *)
 
 open Names
 open Term
 open Environ
 open Ind_tables
 
-(* Builds a left-to-right rewriting scheme for an equality type *)
+(** Builds a left-to-right rewriting scheme for an equality type *)
 
 val rew_l2r_dep_scheme_kind : individual scheme_kind
 val rew_l2r_scheme_kind : individual scheme_kind
@@ -23,7 +21,6 @@ val rew_r2l_forward_dep_scheme_kind : individual scheme_kind
 val rew_l2r_forward_dep_scheme_kind : individual scheme_kind
 val rew_r2l_dep_scheme_kind : individual scheme_kind
 val rew_r2l_scheme_kind : individual scheme_kind
-val rew_asym_scheme_kind : individual scheme_kind
 
 val build_r2l_rew_scheme : bool -> env -> inductive -> sorts_family -> constr
 val build_l2r_rew_scheme : bool -> env -> inductive -> sorts_family -> constr
@@ -32,7 +29,7 @@ val build_r2l_forward_rew_scheme :
 val build_l2r_forward_rew_scheme :
   bool -> env -> inductive -> sorts_family -> constr
 
-(* Builds a symmetry scheme for a symmetrical equality type *)
+(** Builds a symmetry scheme for a symmetrical equality type *)
 
 val build_sym_scheme : env -> inductive -> constr
 val sym_scheme_kind : individual scheme_kind
@@ -40,7 +37,7 @@ val sym_scheme_kind : individual scheme_kind
 val build_sym_involutive_scheme : env -> inductive -> constr
 val sym_involutive_scheme_kind : individual scheme_kind
 
-(* Builds a congruence scheme for an equality type *)
+(** Builds a congruence scheme for an equality type *)
 
 val congr_scheme_kind : individual scheme_kind
 val build_congr : env -> constr * constr -> inductive -> constr
diff --git a/tactics/equality.ml b/tactics/equality.ml
index a25f88e3..10fd0fef 100644
--- a/tactics/equality.ml
+++ b/tactics/equality.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: equality.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Pp
 open Util
 open Names
@@ -35,7 +33,7 @@ open Tacexpr
 open Tacticals
 open Tactics
 open Tacred
-open Rawterm
+open Glob_term
 open Coqlib
 open Vernacexpr
 open Declarations
@@ -58,6 +56,7 @@ open Goptions
 let _ =
   declare_bool_option
     { optsync  = true;
+      optdepr  = false;
       optname  = "automatic introduction of hypotheses by discriminate";
       optkey   = ["Discriminate";"Introduction"];
       optread  = (fun () -> !discriminate_introduction);
@@ -66,6 +65,7 @@ let _ =
 (* Rewriting tactics *)
 
 type dep_proof_flag = bool (* true = support rewriting dependent proofs *)
+type freeze_evars_flag = bool (* true = don't instantiate existing evars *)
 
 type orientation = bool
 
@@ -84,18 +84,42 @@ type conditions =
 
 let rewrite_unif_flags = {
   Unification.modulo_conv_on_closed_terms = None;
-  Unification.use_metas_eagerly = true;
+  Unification.use_metas_eagerly_in_conv_on_closed_terms = true;
   Unification.modulo_delta = empty_transparent_state;
+  Unification.modulo_delta_types = empty_transparent_state;
+  Unification.check_applied_meta_types = true;
   Unification.resolve_evars = true;
-  Unification.use_evars_pattern_unification = true;
+  Unification.use_pattern_unification = true;
+  Unification.use_meta_bound_pattern_unification = true;
+  Unification.frozen_evars = ExistentialSet.empty;
+  Unification.restrict_conv_on_strict_subterms = false;
+  Unification.modulo_betaiota = false;
+  Unification.modulo_eta = true;
+  Unification.allow_K_in_toplevel_higher_order_unification = false
+    (* allow_K does not matter in practice because calls w_typed_unify *)
 }
 
+let freeze_initial_evars sigma flags clause =
+  (* We take evars of the type: this may include old evars! For excluding *)
+  (* all old evars, including the ones occurring in the rewriting lemma, *)
+  (* we would have to take the clenv_value *)
+  let newevars = Evd.collect_evars (clenv_type clause) in
+  let evars =
+    fold_undefined (fun evk _ evars ->
+      if ExistentialSet.mem evk newevars then evars
+      else ExistentialSet.add evk evars)
+      sigma ExistentialSet.empty in
+  { flags with Unification.frozen_evars = evars }
+
+let make_flags frzevars sigma flags clause =
+  if frzevars then freeze_initial_evars sigma flags clause else flags
+
 let side_tac tac sidetac =
   match sidetac with
   | None -> tac
   | Some sidetac -> tclTHENSFIRSTn tac [|tclIDTAC|] sidetac
 
-let instantiate_lemma_all env sigma gl c ty l l2r concl =
+let instantiate_lemma_all frzevars env sigma gl c ty l l2r concl =
   let eqclause = Clenv.make_clenv_binding { gl with sigma = sigma } (c,ty) l in
   let (equiv, args) = decompose_app (Clenv.clenv_type eqclause) in
   let rec split_last_two = function
@@ -105,13 +129,12 @@ let instantiate_lemma_all env sigma gl c ty l l2r concl =
       | _ -> error "The term provided is not an applied relation." in
   let others,(c1,c2) = split_last_two args in
   let try_occ (evd', c') =
-    let cl' = {eqclause with evd = evd'} in
-    let mvs = clenv_dependent false cl' in
-      clenv_pose_metas_as_evars cl' mvs
+    clenv_pose_dependent_evars true {eqclause with evd = evd'}
   in
+  let flags = make_flags frzevars sigma rewrite_unif_flags eqclause in
   let occs =
-    Unification.w_unify_to_subterm_all ~flags:rewrite_unif_flags env
-      ((if l2r then c1 else c2),concl) eqclause.evd
+    Unification.w_unify_to_subterm_all ~flags env eqclause.evd
+      ((if l2r then c1 else c2),concl)
   in List.map try_occ occs
 
 let instantiate_lemma env sigma gl c ty l l2r concl =
@@ -121,28 +144,61 @@ let instantiate_lemma env sigma gl c ty l l2r concl =
   let eqclause = Clenv.make_clenv_binding gl (c,t) l in
    [eqclause]
 
-let rewrite_elim with_evars c e ?(allow_K=true) =
-  general_elim_clause_gen (elimination_clause_scheme with_evars allow_K) c e
+let rewrite_conv_closed_unif_flags = {
+  Unification.modulo_conv_on_closed_terms = Some full_transparent_state;
+    (* We have this flag for historical reasons, it has e.g. the consequence *)
+    (* to rewrite "?x+2" in "y+(1+1)=0" or to rewrite "?x+?x" in "2+(1+1)=0" *)
+
+  Unification.use_metas_eagerly_in_conv_on_closed_terms = true;
+    (* Combined with modulo_conv_on_closed_terms, this flag allows since 8.2 *)
+    (* to rewrite e.g. "?x+(2+?x)" in "1+(1+2)=0" *)
+
+  Unification.modulo_delta = empty_transparent_state;
+  Unification.modulo_delta_types = full_transparent_state;
+  Unification.check_applied_meta_types = true;
+  Unification.resolve_evars = false;
+  Unification.use_pattern_unification = true;
+    (* To rewrite "?n x y" in "y+x=0" when ?n is *)
+    (* a preexisting evar of the goal*)
+
+  Unification.use_meta_bound_pattern_unification = true;
+
+  Unification.frozen_evars = ExistentialSet.empty;
+    (* This is set dynamically *)
+
+  Unification.restrict_conv_on_strict_subterms = false;
+  Unification.modulo_betaiota = false;
+  Unification.modulo_eta = true;
+  Unification.allow_K_in_toplevel_higher_order_unification = false
+}
+
+let rewrite_elim with_evars frzevars c e gl =
+  let flags =
+    make_flags frzevars (project gl) rewrite_conv_closed_unif_flags c in
+  general_elim_clause_gen (elimination_clause_scheme with_evars ~flags) c e gl
 
-let rewrite_elim_in with_evars id c e =
-  general_elim_clause_gen (elimination_in_clause_scheme with_evars id) c e
+let rewrite_elim_in with_evars frzevars id c e gl =
+  let flags =
+    make_flags frzevars (project gl) rewrite_conv_closed_unif_flags c in
+  general_elim_clause_gen
+    (elimination_in_clause_scheme with_evars ~flags id) c e gl
 
 (* Ad hoc asymmetric general_elim_clause *)
-let general_elim_clause with_evars cls rew elim =
+let general_elim_clause with_evars frzevars cls rew elim =
   try
     (match cls with
       | None ->
 	  (* was tclWEAK_PROGRESS which only fails for tactics generating one
              subgoal and did not fail for useless conditional rewritings generating
              an extra condition *)
-	  tclNOTSAMEGOAL (rewrite_elim with_evars rew elim ~allow_K:false)
-      | Some id -> rewrite_elim_in with_evars id rew elim)
-  with Pretype_errors.PretypeError (env,
-				   (Pretype_errors.NoOccurrenceFound (c', _))) ->
+	  tclNOTSAMEGOAL (rewrite_elim with_evars frzevars rew elim)
+      | Some id -> rewrite_elim_in with_evars frzevars id rew elim)
+  with Pretype_errors.PretypeError (env,evd,
+				    Pretype_errors.NoOccurrenceFound (c', _)) ->
     raise (Pretype_errors.PretypeError
-	      (env, (Pretype_errors.NoOccurrenceFound (c', cls))))
+	      (env,evd,Pretype_errors.NoOccurrenceFound (c', cls)))
 
-let general_elim_clause with_evars tac cls sigma c t l l2r elim gl =
+let general_elim_clause with_evars frzevars tac cls sigma c t l l2r elim gl =
   let all, firstonly, tac =
     match tac with
     | None -> false, false, None
@@ -151,12 +207,15 @@ let general_elim_clause with_evars tac cls sigma c t l l2r elim gl =
     | Some (tac, AllMatches) -> true, false, Some (tclCOMPLETE tac)
   in
   let cs =
-    (if not all then instantiate_lemma else instantiate_lemma_all)
+    (if not all then instantiate_lemma else instantiate_lemma_all frzevars)
       (pf_env gl) sigma gl c t l l2r
       (match cls with None -> pf_concl gl | Some id -> pf_get_hyp_typ gl id)
   in
   let try_clause c =
-    side_tac (tclTHEN (Refiner.tclEVARS c.evd) (general_elim_clause with_evars cls c elim)) tac
+    side_tac
+      (tclTHEN
+         (Refiner.tclEVARS c.evd)
+         (general_elim_clause with_evars frzevars cls c elim)) tac
   in
     if firstonly then
       tclFIRST (List.map try_clause cs) gl
@@ -180,8 +239,8 @@ let register_is_applied_rewrite_relation = (:=) is_applied_rewrite_relation
 
 let find_elim hdcncl lft2rgt dep cls args gl =
   let inccl = (cls = None) in
-  if (hdcncl = constr_of_reference (Coqlib.glob_eq) ||
-      hdcncl = constr_of_reference (Coqlib.glob_jmeq) &&
+  if (eq_constr hdcncl (constr_of_reference (Coqlib.glob_eq)) ||
+      eq_constr hdcncl (constr_of_reference (Coqlib.glob_jmeq)) &&
       pf_conv_x gl (List.nth args 0) (List.nth args 2)) && not dep
     || Flags.version_less_or_equal Flags.V8_2
   then
@@ -195,7 +254,7 @@ let find_elim hdcncl lft2rgt dep cls args gl =
 	  let c1 = destConst pr1 in 
 	  let mp,dp,l = repr_con (constant_of_kn (canonical_con c1)) in 
 	  let l' = label_of_id (add_suffix (id_of_label l) "_r")  in 
-	  let c1' = Global.constant_of_delta (make_con mp dp l') in
+	  let c1' = Global.constant_of_delta_kn (make_kn mp dp l') in
 	  begin 
 	    try 
 	      let _ = Global.lookup_constant c1' in
@@ -211,20 +270,16 @@ let find_elim hdcncl lft2rgt dep cls args gl =
 	assert false
   else
   let scheme_name = match dep, lft2rgt, inccl with
-    (* Non dependent case with symmetric equality *)
-    | false, Some true, true | false, Some false, false -> rew_l2r_scheme_kind
-    | false, Some false, true | false, Some true, false -> rew_r2l_scheme_kind
-    (* Dependent case with symmetric equality *)
+    (* Non dependent case *)
+    | false, Some true, true -> rew_l2r_scheme_kind
+    | false, Some true, false -> rew_r2l_scheme_kind
+    | false, _, false -> rew_l2r_scheme_kind
+    | false, _, true -> rew_r2l_scheme_kind
+    (* Dependent case *)
     | true, Some true, true -> rew_l2r_dep_scheme_kind
     | true, Some true, false -> rew_l2r_forward_dep_scheme_kind
-    | true, Some false, true -> rew_r2l_dep_scheme_kind
-    | true, Some false, false -> rew_r2l_forward_dep_scheme_kind
-    (* Non dependent case with non-symmetric rewriting lemma *)
-    | false, None, true -> rew_r2l_scheme_kind
-    | false, None, false -> rew_asym_scheme_kind
-    (* Dependent case with non-symmetric rewriting lemma *)
-    | true, None, true -> rew_r2l_dep_scheme_kind
-    | true, None, false -> rew_r2l_forward_dep_scheme_kind
+    | true, _, true -> rew_r2l_dep_scheme_kind
+    | true, _, false -> rew_r2l_forward_dep_scheme_kind
   in
   match kind_of_term hdcncl with
   | Ind ind -> mkConst (find_scheme scheme_name ind)
@@ -234,12 +289,12 @@ let type_of_clause gl = function
   | None -> pf_concl gl
   | Some id -> pf_get_hyp_typ gl id
 
-let leibniz_rewrite_ebindings_clause cls lft2rgt tac sigma c t l with_evars dep_proof_ok gl hdcncl =
+let leibniz_rewrite_ebindings_clause cls lft2rgt tac sigma c t l with_evars frzevars dep_proof_ok gl hdcncl =
   let isatomic = isProd (whd_zeta hdcncl) in
   let dep_fun = if isatomic then dependent else dependent_no_evar in
   let dep = dep_proof_ok && dep_fun c (type_of_clause gl cls) in
   let elim = find_elim hdcncl lft2rgt dep cls (snd (decompose_app t)) gl in
-  general_elim_clause with_evars tac cls sigma c t l
+  general_elim_clause with_evars frzevars tac cls sigma c t l
     (match lft2rgt with None -> false | Some b -> b)
     {elimindex = None; elimbody = (elim,NoBindings)} gl
 
@@ -259,7 +314,7 @@ let rewrite_side_tac tac sidetac = side_tac tac (Option.map fst sidetac)
 
 (* Main function for dispatching which kind of rewriting it is about *)
 
-let general_rewrite_ebindings_clause cls lft2rgt occs dep_proof_ok ?tac
+let general_rewrite_ebindings_clause cls lft2rgt occs frzevars dep_proof_ok ?tac
     ((c,l) : constr with_bindings) with_evars gl =
   if occs <> all_occurrences then (
     rewrite_side_tac (!general_rewrite_clause cls lft2rgt occs (c,l) ~new_goals:[]) tac gl)
@@ -272,7 +327,7 @@ let general_rewrite_ebindings_clause cls lft2rgt occs dep_proof_ok ?tac
       | Some (hdcncl,args) -> (* Fast path: direct leibniz-like rewrite *)
 	  let lft2rgt = adjust_rewriting_direction args lft2rgt in
           leibniz_rewrite_ebindings_clause cls lft2rgt tac sigma c (it_mkProd_or_LetIn t rels)
-	    l with_evars dep_proof_ok gl hdcncl
+	    l with_evars frzevars dep_proof_ok gl hdcncl
       | None ->
 	  try
 	    rewrite_side_tac (!general_rewrite_clause cls
@@ -284,27 +339,31 @@ let general_rewrite_ebindings_clause cls lft2rgt occs dep_proof_ok ?tac
 	      | Some (hdcncl,args) ->
 		  let lft2rgt = adjust_rewriting_direction args lft2rgt in
 		    leibniz_rewrite_ebindings_clause cls lft2rgt tac sigma c
-		      (it_mkProd_or_LetIn t' (rels' @ rels)) l with_evars dep_proof_ok gl hdcncl
+		      (it_mkProd_or_LetIn t' (rels' @ rels)) l with_evars frzevars dep_proof_ok gl hdcncl
 	      | None -> raise e
 		  (* error "The provided term does not end with an equality or a declared rewrite relation." *)
 
 let general_rewrite_ebindings =
   general_rewrite_ebindings_clause None
 
-let general_rewrite_bindings l2r occs dep_proof_ok ?tac (c,bl) =
-  general_rewrite_ebindings_clause None l2r occs dep_proof_ok ?tac (c,bl)
+let general_rewrite_bindings l2r occs frzevars dep_proof_ok ?tac (c,bl) =
+  general_rewrite_ebindings_clause None l2r occs
+    frzevars dep_proof_ok ?tac (c,bl)
 
-let general_rewrite l2r occs dep_proof_ok ?tac c =
-  general_rewrite_bindings l2r occs dep_proof_ok ?tac (c,NoBindings) false
+let general_rewrite l2r occs frzevars dep_proof_ok ?tac c =
+  general_rewrite_bindings l2r occs
+    frzevars dep_proof_ok ?tac (c,NoBindings) false
 
-let general_rewrite_ebindings_in l2r occs dep_proof_ok ?tac id =
-  general_rewrite_ebindings_clause (Some id) l2r occs dep_proof_ok ?tac
+let general_rewrite_ebindings_in l2r occs frzevars dep_proof_ok ?tac id =
+  general_rewrite_ebindings_clause (Some id) l2r occs frzevars dep_proof_ok ?tac
 
-let general_rewrite_bindings_in l2r occs dep_proof_ok ?tac id (c,bl) =
-  general_rewrite_ebindings_clause (Some id) l2r occs dep_proof_ok ?tac (c,bl)
+let general_rewrite_bindings_in l2r occs frzevars dep_proof_ok ?tac id (c,bl) =
+  general_rewrite_ebindings_clause (Some id) l2r occs
+    frzevars dep_proof_ok ?tac (c,bl)
 
-let general_rewrite_in l2r occs dep_proof_ok ?tac id c =
-  general_rewrite_ebindings_clause (Some id) l2r occs dep_proof_ok ?tac (c,NoBindings)
+let general_rewrite_in l2r occs frzevars dep_proof_ok ?tac id c =
+  general_rewrite_ebindings_clause (Some id) l2r occs
+    frzevars dep_proof_ok ?tac (c,NoBindings)
 
 let general_multi_rewrite l2r with_evars ?tac c cl =
   let occs_of = on_snd (List.fold_left
@@ -320,12 +379,12 @@ let general_multi_rewrite l2r with_evars ?tac c cl =
 	  | [] -> tclIDTAC
 	  | ((occs,id),_) :: l ->
 	    tclTHENFIRST
-	      (general_rewrite_ebindings_in l2r (occs_of occs) true ?tac id c with_evars)
+	      (general_rewrite_ebindings_in l2r (occs_of occs) false true ?tac id c with_evars)
 	      (do_hyps l)
 	in
 	if cl.concl_occs = no_occurrences_expr then do_hyps l else
 	  tclTHENFIRST
-	   (general_rewrite_ebindings l2r (occs_of cl.concl_occs) true ?tac c with_evars)
+	   (general_rewrite_ebindings l2r (occs_of cl.concl_occs) false true ?tac c with_evars)
 	   (do_hyps l)
     | None ->
 	(* Otherwise, if we are told to rewrite in all hypothesis via the
@@ -334,7 +393,7 @@ let general_multi_rewrite l2r with_evars ?tac c cl =
 	  | [] -> (fun gl -> error "Nothing to rewrite.")
 	  | id :: l ->
 	    tclIFTHENTRYELSEMUST
-	     (general_rewrite_ebindings_in l2r all_occurrences true ?tac id c with_evars)
+	     (general_rewrite_ebindings_in l2r all_occurrences false true ?tac id c with_evars)
 	     (do_hyps_atleastonce l)
 	in
 	let do_hyps gl =
@@ -346,7 +405,7 @@ let general_multi_rewrite l2r with_evars ?tac c cl =
 	in
 	if cl.concl_occs = no_occurrences_expr then do_hyps else
 	  tclIFTHENTRYELSEMUST
-	   (general_rewrite_ebindings l2r (occs_of cl.concl_occs) true ?tac c with_evars)
+	   (general_rewrite_ebindings l2r (occs_of cl.concl_occs) false true ?tac c with_evars)
 	   do_hyps
 
 type delayed_open_constr_with_bindings =
@@ -371,8 +430,8 @@ let general_multi_multi_rewrite with_evars l cl tac =
     | (l2r,m,c)::l -> tclTHENFIRST (doN l2r c m) (loop l)
   in loop l
 
-let rewriteLR = general_rewrite true all_occurrences true
-let rewriteRL = general_rewrite false all_occurrences true
+let rewriteLR = general_rewrite true all_occurrences true true
+let rewriteRL = general_rewrite false all_occurrences true true
 
 (* Replacing tactics *)
 
@@ -512,7 +571,7 @@ let discriminable env sigma t1 t2 =
 
 let injectable env sigma t1 t2 =
     match find_positions env sigma t1 t2 with
-    | Inl _ | Inr [] -> false
+    | Inl _ | Inr [] | Inr [([],_,_)] -> false
     | Inr _ -> true
 
 
@@ -631,7 +690,7 @@ let construct_discriminator sigma env dirn c sort =
           CP : changed assert false in a more informative error
        *)
       errorlabstrm "Equality.construct_discriminator"
-	(str "Cannot discriminate on inductive constructors with
+	(str "Cannot discriminate on inductive constructors with \
 		 dependent types.") in
   let (ind,_) = dest_ind_family indf in
   let (mib,mip) = lookup_mind_specif env ind in
@@ -682,14 +741,13 @@ let gen_absurdity id gl =
 *)
 
 let ind_scheme_of_eq lbeq =
-  let ind = destInd lbeq.eq in
-  let (mib,mip) = Global.lookup_inductive ind in
+  let (mib,mip) = Global.lookup_inductive (destInd lbeq.eq) in
   let kind = inductive_sort_family mip in
   (* use ind rather than case by compatibility *)
   let kind =
     if kind = InProp then Elimschemes.ind_scheme_kind_from_prop
     else Elimschemes.ind_scheme_kind_from_type in
-  mkConst (find_scheme kind ind)
+  mkConst (find_scheme kind (destInd lbeq.eq))
 
 
 let discrimination_pf e (t,t1,t2) discriminator lbeq =
@@ -894,8 +952,8 @@ let sig_clausal_form env sigma sort_of_ty siglen ty dflt =
       let rty = beta_applist(p_i_minus_1,[ev]) in
       let tuple_tail = sigrec_clausal_form (siglen-1) rty in
       match
-  	Evd.existential_opt_value !evdref
- 	  (destEvar ev)
+        Evd.existential_opt_value !evdref
+          (destEvar ev)
       with
 	| Some w ->
             let w_type = type_of env sigma w in
@@ -1057,6 +1115,8 @@ let injEq ipats (eq,_,(t,t1,t2) as u) eq_clause =
     | Inr [] ->
 	errorlabstrm "Equality.inj"
 	   (str"Nothing to do, it is an equality between convertible terms.")
+    | Inr [([],_,_)] when Flags.version_strictly_greater Flags.V8_3 ->
+        errorlabstrm "Equality.inj" (str"Nothing to inject.")
     | Inr posns ->
 (* Est-ce utile à partir du moment où les arguments projetés subissent "nf" ?
 	let t1 = try_delta_expand env sigma t1 in
@@ -1186,26 +1246,37 @@ let bareRevSubstInConcl lbeq body (t,e1,e2) gls =
 
 let decomp_tuple_term env c t =
   let rec decomprec inner_code ex exty =
+    let iterated_decomp =
     try
       let {proj1=p1; proj2=p2},(a,p,car,cdr) = find_sigma_data_decompose ex in
       let car_code = applist (p1,[a;p;inner_code])
       and cdr_code = applist (p2,[a;p;inner_code]) in
       let cdrtyp = beta_applist (p,[car]) in
-      ((car,a),car_code)::(decomprec cdr_code cdr cdrtyp)
+      List.map (fun l -> ((car,a),car_code)::l) (decomprec cdr_code cdr cdrtyp)
     with PatternMatchingFailure ->
-      [((ex,exty),inner_code)]
+      []
+    in
+    [((ex,exty),inner_code)]::iterated_decomp
   in
-  List.split (decomprec (mkRel 1) c t)
+  decomprec (mkRel 1) c t
 
 let subst_tuple_term env sigma dep_pair1 dep_pair2 b =
   let typ = get_type_of env sigma dep_pair1 in
+  (* We find all possible decompositions *)
+  let decomps1 = decomp_tuple_term env dep_pair1 typ in
+  let decomps2 = decomp_tuple_term env dep_pair2 typ in
+  (* We adjust to the shortest decomposition *)
+  let n = min (List.length decomps1) (List.length decomps2) in
+  let decomp1 = List.nth decomps1 (n-1) in
+  let decomp2 = List.nth decomps2 (n-1) in
   (* We rewrite dep_pair1 ... *)
-  let e1_list,proj_list = decomp_tuple_term env dep_pair1 typ in
+  let e1_list,proj_list = List.split decomp1 in
+  (* ... and use dep_pair2 to compute the expected goal *)
+  let e2_list,_ = List.split decomp2 in
+  (* We build the expected goal *)
   let abst_B =
     List.fold_right
       (fun (e,t) body -> lambda_create env (t,subst_term e body)) e1_list b in
-  (* ... and use dep_pair2 to compute the expected goal *)
-  let e2_list,_ = decomp_tuple_term env dep_pair2 typ in
   let pred_body = beta_applist(abst_B,proj_list) in
   let expected_goal = beta_applist (abst_B,List.map fst e2_list) in
   (* Simulate now the normalisation treatment made by Logic.mk_refgoals *)
@@ -1330,34 +1401,21 @@ exception FoundHyp of (identifier * constr * bool)
 let is_eq_x gl x (id,_,c) =
   try
     let (_,lhs,rhs) = snd (find_eq_data_decompose gl c) in
-    if (x = lhs) && not (occur_term x rhs) then raise (FoundHyp (id,rhs,true));
-    if (x = rhs) && not (occur_term x lhs) then raise (FoundHyp (id,lhs,false))
+    if (eq_constr x lhs) && not (occur_term x rhs) then raise (FoundHyp (id,rhs,true));
+    if (eq_constr x rhs) && not (occur_term x lhs) then raise (FoundHyp (id,lhs,false))
   with PatternMatchingFailure ->
     ()
 
-let subst_one dep_proof_ok x gl =
-  let hyps = pf_hyps gl in
-  let (_,xval,_) = pf_get_hyp gl x in
-  (* If x has a body, simply replace x with body and clear x *)
-  if xval <> None then tclTHEN (unfold_body x) (clear [x]) gl else
-  (* x is a variable: *)
-  let varx = mkVar x in
-  (* Find a non-recursive definition for x *)
-  let (hyp,rhs,dir) =
-    try
-      let test hyp _ = is_eq_x gl varx hyp in
-      Sign.fold_named_context test ~init:() hyps;
-      errorlabstrm "Subst"
-        (str "Cannot find any non-recursive equality over " ++ pr_id x ++
-	 str".")
-    with FoundHyp res -> res
-  in
+(* Rewrite "hyp:x=rhs" or "hyp:rhs=x" (if dir=false) everywhere and
+   erase hyp and x; proceed by generalizing all dep hyps *)
+
+let subst_one dep_proof_ok x (hyp,rhs,dir) gl =
   (* The set of hypotheses using x *)
   let depdecls =
     let test (id,_,c as dcl) =
       if id <> hyp && occur_var_in_decl (pf_env gl) x dcl then dcl
       else failwith "caught" in
-    List.rev (map_succeed test hyps) in
+    List.rev (map_succeed test (pf_hyps gl)) in
   let dephyps = List.map (fun (id,_,_) -> id) depdecls in
   (* Decides if x appears in conclusion *)
   let depconcl = occur_var (pf_env gl) x (pf_concl gl) in
@@ -1373,23 +1431,47 @@ let subst_one dep_proof_ok x gl =
       (id,None,_) -> intro_using id
     | (id,Some hval,htyp) ->
         letin_tac None (Name id)
-	  (replace_term varx rhs hval)
-	  (Some (replace_term varx rhs htyp)) nowhere
+	  (replace_term (mkVar x) rhs hval)
+	  (Some (replace_term (mkVar x) rhs htyp)) nowhere
   in
   let need_rewrite = dephyps <> [] || depconcl in
   tclTHENLIST
     ((if need_rewrite then
       [generalize abshyps;
-       general_rewrite dir all_occurrences dep_proof_ok (mkVar hyp);
+       general_rewrite dir all_occurrences true dep_proof_ok (mkVar hyp);
        thin dephyps;
        tclMAP introtac depdecls]
-    else
-      [thin dephyps;
-       tclMAP introtac depdecls]) @
+      else
+       [tclIDTAC]) @
      [tclTRY (clear [x;hyp])]) gl
 
+(* Look for an hypothesis hyp of the form "x=rhs" or "rhs=x", rewrite
+   it everywhere, and erase hyp and x; proceed by generalizing all dep hyps *)
+
+let subst_one_var dep_proof_ok x gl =
+  let hyps = pf_hyps gl in
+  let (_,xval,_) = pf_get_hyp gl x in
+  (* If x has a body, simply replace x with body and clear x *)
+  if xval <> None then tclTHEN (unfold_body x) (clear [x]) gl else
+  (* x is a variable: *)
+  let varx = mkVar x in
+  (* Find a non-recursive definition for x *)
+  let (hyp,rhs,dir) =
+    try
+      let test hyp _ = is_eq_x gl varx hyp in
+      Sign.fold_named_context test ~init:() hyps;
+      errorlabstrm "Subst"
+        (str "Cannot find any non-recursive equality over " ++ pr_id x ++
+	 str".")
+    with FoundHyp res -> res in
+  subst_one dep_proof_ok x (hyp,rhs,dir) gl
+
 let subst_gen dep_proof_ok ids =
-  tclTHEN tclNORMEVAR (tclMAP (subst_one dep_proof_ok) ids)
+  tclTHEN tclNORMEVAR (tclMAP (subst_one_var dep_proof_ok) ids)
+
+(* For every x, look for an hypothesis hyp of the form "x=rhs" or "rhs=x",
+   rewrite it everywhere, and erase hyp and x; proceed by generalizing
+   all dep hyps *)
 
 let subst = subst_gen true
 
@@ -1466,3 +1548,5 @@ let replace_multi_term dir_opt c  =
 
 let _ = Tactics.register_general_multi_rewrite
   (fun b evars t cls -> general_multi_rewrite b evars t cls)
+
+let _ = Tactics.register_subst_one (fun b -> subst_one b)
diff --git a/tactics/equality.mli b/tactics/equality.mli
index 0c2d8942..79059469 100644
--- a/tactics/equality.mli
+++ b/tactics/equality.mli
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: equality.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 (*i*)
 open Util
 open Names
@@ -23,12 +21,13 @@ open Tacticals
 open Tactics
 open Tacexpr
 open Termops
-open Rawterm
+open Glob_term
 open Genarg
 open Ind_tables
 (*i*)
 
 type dep_proof_flag = bool (* true = support rewriting dependent proofs *)
+type freeze_evars_flag = bool (* true = don't instantiate existing evars *)
 
 type orientation = bool
 
@@ -38,10 +37,10 @@ type conditions =
   | AllMatches (* Rewrite all matches whose side-conditions are solved *)
 
 val general_rewrite_bindings :
-  orientation -> occurrences -> dep_proof_flag ->
+  orientation -> occurrences -> freeze_evars_flag -> dep_proof_flag ->
   ?tac:(tactic * conditions) -> constr with_bindings -> evars_flag -> tactic
 val general_rewrite :
-  orientation -> occurrences -> dep_proof_flag ->
+  orientation -> occurrences -> freeze_evars_flag -> dep_proof_flag ->
   ?tac:(tactic * conditions) -> constr -> tactic
 
 (* Equivalent to [general_rewrite l2r] *)
@@ -56,15 +55,16 @@ val register_general_rewrite_clause :
 val register_is_applied_rewrite_relation : (env -> evar_map -> rel_context -> constr -> constr option) -> unit
 
 val general_rewrite_ebindings_clause : identifier option ->
-  orientation -> occurrences -> dep_proof_flag -> ?tac:(tactic * conditions) ->
-  constr with_bindings -> evars_flag -> tactic
+  orientation -> occurrences -> freeze_evars_flag -> dep_proof_flag ->
+  ?tac:(tactic * conditions) -> constr with_bindings -> evars_flag -> tactic
 
 val general_rewrite_bindings_in :
-  orientation -> occurrences -> dep_proof_flag -> ?tac:(tactic * conditions) ->
+  orientation -> occurrences -> freeze_evars_flag -> dep_proof_flag ->
+  ?tac:(tactic * conditions) ->
   identifier -> constr with_bindings -> evars_flag -> tactic
 val general_rewrite_in          :
-  orientation -> occurrences -> dep_proof_flag -> ?tac:(tactic * conditions) ->
-  identifier -> constr -> evars_flag -> tactic
+  orientation -> occurrences -> freeze_evars_flag -> dep_proof_flag -> 
+  ?tac:(tactic * conditions) -> identifier -> constr -> evars_flag -> tactic
 
 val general_multi_rewrite :
   orientation -> evars_flag -> ?tac:(tactic * conditions) -> constr with_bindings -> clause -> tactic
@@ -73,7 +73,7 @@ type delayed_open_constr_with_bindings =
     env -> evar_map -> evar_map * constr with_bindings
 
 val general_multi_multi_rewrite :
-  evars_flag -> (bool * multi * delayed_open_constr_with_bindings) list -> 
+  evars_flag -> (bool * multi * delayed_open_constr_with_bindings) list ->
     clause -> (tactic * conditions) option -> tactic
 
 val replace_in_clause_maybe_by : constr -> constr -> clause -> tactic option -> tactic
diff --git a/tactics/evar_tactics.ml b/tactics/evar_tactics.ml
index 9f7c0a54..992fdc91 100644
--- a/tactics/evar_tactics.ml
+++ b/tactics/evar_tactics.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: evar_tactics.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Term
 open Util
 open Evar_refiner
@@ -25,9 +23,9 @@ let instantiate n (ist,rawc) ido gl =
   let sigma = gl.sigma in
   let evl =
     match ido with
-	ConclLocation () -> evar_list sigma gl.it.evar_concl
+	ConclLocation () -> evar_list sigma (pf_concl gl)
       | HypLocation (id,hloc) ->
-	  let decl = Environ.lookup_named_val id gl.it.evar_hyps in
+	  let decl = Environ.lookup_named_val id (Goal.V82.hyps sigma (sig_it gl)) in
 	    match hloc with
 		InHyp ->
 		  (match decl with
@@ -57,4 +55,3 @@ let let_evar name typ gls =
   let sigma',evar = Evarutil.new_evar gls.sigma (pf_env gls) ~src typ in
   Refiner.tclTHEN (Refiner.tclEVARS sigma')
     (Tactics.letin_tac None name evar None nowhere) gls
-
diff --git a/tactics/evar_tactics.mli b/tactics/evar_tactics.mli
index f54f6a4c..882cf3ce 100644
--- a/tactics/evar_tactics.mli
+++ b/tactics/evar_tactics.mli
@@ -1,23 +1,17 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: evar_tactics.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 open Tacmach
 open Names
 open Tacexpr
 open Termops
 
-val instantiate : int -> Tacinterp.interp_sign * Rawterm.rawconstr ->
+val instantiate : int -> Tacinterp.interp_sign * Glob_term.glob_constr ->
   (identifier * hyp_location_flag, unit) location -> tactic
 
-(*i
-val instantiate_tac : tactic_arg list -> tactic
-i*)
-
 val let_evar : name -> Term.types -> tactic
diff --git a/tactics/extraargs.ml4 b/tactics/extraargs.ml4
index 310423d2..6a13ac2a 100644
--- a/tactics/extraargs.ml4
+++ b/tactics/extraargs.ml4
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,8 +8,6 @@
 
 (*i camlp4deps: "parsing/grammar.cma" i*)
 
-(* $Id: extraargs.ml4 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Pp
 open Pcoq
 open Genarg
@@ -27,35 +25,37 @@ let pr_orient _prc _prlc _prt = function
   | true -> Pp.mt ()
   | false -> Pp.str " <-"
 
-
 ARGUMENT EXTEND orient TYPED AS bool PRINTED BY pr_orient
 | [ "->" ] -> [ true ]
 | [ "<-" ] -> [ false ]
 | [ ] -> [ true ]
 END
 
-let pr_int_list _prc _prlc _prt l =
+let pr_orient = pr_orient () () ()
+
+let pr_int_list_full _prc _prlc _prt l =
   let rec aux = function
     | i :: l -> Pp.int i ++ Pp.spc () ++ aux l
     | [] -> Pp.mt()
   in aux l
 
 ARGUMENT EXTEND int_nelist
-  TYPED AS int list
-  PRINTED BY pr_int_list
+  PRINTED BY pr_int_list_full
   RAW_TYPED AS int list
-  RAW_PRINTED BY pr_int_list
+  RAW_PRINTED BY pr_int_list_full
   GLOB_TYPED AS int list
-  GLOB_PRINTED BY pr_int_list
+  GLOB_PRINTED BY pr_int_list_full
 | [ integer(x) int_nelist(l) ] -> [x::l]
 | [ integer(x) ] -> [ [x] ]
 END
 
-open Rawterm
+let pr_int_list = pr_int_list_full () () ()
+
+open Glob_term
 
 let pr_occurrences _prc _prlc _prt l =
   match l with
-    | ArgArg x -> pr_int_list _prc _prlc _prt x
+    | ArgArg x -> pr_int_list x
     | ArgVar (loc, id) -> Nameops.pr_id id
 
 let coerce_to_int = function
@@ -81,8 +81,7 @@ type occurrences_or_var = int list or_var
 type occurrences = int list
 
 ARGUMENT EXTEND occurrences
-  TYPED AS occurrences
-  PRINTED BY pr_int_list
+  PRINTED BY pr_int_list_full
 
   INTERPRETED BY interp_occs
   GLOBALIZED BY glob_occs
@@ -98,32 +97,34 @@ ARGUMENT EXTEND occurrences
 | [ var(id) ] -> [ ArgVar id ]
 END
 
+let pr_occurrences = pr_occurrences () () ()
+
 let pr_gen prc _prlc _prtac c = prc c
 
-let pr_rawc _prc _prlc _prtac (_,raw) = Printer.pr_rawconstr raw
+let pr_globc _prc _prlc _prtac (_,glob) = Printer.pr_glob_constr glob
 
-let interp_raw ist gl (t,_) = (ist,t)
+let interp_glob ist gl (t,_) = (ist,t)
 
-let glob_raw = Tacinterp.intern_constr
+let glob_glob = Tacinterp.intern_constr
 
-let subst_raw = Tacinterp.subst_rawconstr_and_expr
+let subst_glob = Tacinterp.subst_glob_constr_and_expr
 
-ARGUMENT EXTEND raw
-    TYPED AS rawconstr
-    PRINTED BY pr_rawc
+ARGUMENT EXTEND glob
+    PRINTED BY pr_globc
 
-     INTERPRETED BY interp_raw
-     GLOBALIZED BY glob_raw
-     SUBSTITUTED BY subst_raw
+     INTERPRETED BY interp_glob
+     GLOBALIZED BY glob_glob
+     SUBSTITUTED BY subst_glob
 
      RAW_TYPED AS constr_expr
      RAW_PRINTED BY pr_gen
 
-     GLOB_TYPED AS rawconstr_and_expr
+     GLOB_TYPED AS glob_constr_and_expr
      GLOB_PRINTED BY pr_gen
   [ lconstr(c) ] -> [ c ]
 END
 
+
 type 'id gen_place= ('id * hyp_location_flag,unit) location
 
 type loc_place = identifier Util.located gen_place
@@ -139,6 +140,7 @@ let pr_gen_place pr_id = function
 
 let pr_loc_place _ _ _ = pr_gen_place (fun (_,id) -> Nameops.pr_id id)
 let pr_place _ _ _ = pr_gen_place Nameops.pr_id
+let pr_hloc = pr_loc_place () () ()
 
 let intern_place ist = function
     ConclLocation () -> ConclLocation ()
@@ -151,7 +153,6 @@ let interp_place ist gl = function
 let subst_place subst pl = pl
 
 ARGUMENT EXTEND hloc
-    TYPED AS place
     PRINTED BY pr_place
     INTERPRETED BY interp_place
     GLOBALIZED BY intern_place
@@ -193,6 +194,7 @@ ARGUMENT EXTEND by_arg_tac
 | [ ] -> [ None ]
 END
 
+let pr_by_arg_tac prtac opt_c = pr_by_arg_tac () () prtac opt_c
 
 let pr_in_hyp  pr_id (lo,concl) :  Pp.std_ppcmds =
   match lo,concl with
@@ -220,7 +222,6 @@ let pr_var_list _ _ _ = pr_var_list_gen (fun (_,id) -> Ppconstr.pr_id id)
 
 
 ARGUMENT EXTEND comma_var_lne
-  TYPED AS var list
   PRINTED BY pr_var_list_typed
   RAW_TYPED AS var list
   RAW_PRINTED BY pr_var_list
@@ -231,7 +232,6 @@ ARGUMENT EXTEND comma_var_lne
 END
 
 ARGUMENT EXTEND comma_var_l
-  TYPED AS var list
   PRINTED BY pr_var_list_typed
   RAW_TYPED AS var list
   RAW_PRINTED BY pr_var_list
@@ -253,7 +253,6 @@ END
 
 
 ARGUMENT EXTEND in_arg_hyp
-  TYPED AS var list option * bool
   PRINTED BY pr_in_arg_hyp_typed
   RAW_TYPED AS var list option * bool
   RAW_PRINTED BY pr_in_arg_hyp
@@ -267,6 +266,7 @@ ARGUMENT EXTEND in_arg_hyp
 | [ ] -> [ (Some [],true) ]
 END
 
+let pr_in_arg_hyp = pr_in_arg_hyp_typed () () ()
 
 let gen_in_arg_hyp_to_clause trad_id (hyps ,concl) : Tacticals.clause =
   {Tacexpr.onhyps=
diff --git a/tactics/extraargs.mli b/tactics/extraargs.mli
index a3f27fde..2abca40e 100644
--- a/tactics/extraargs.mli
+++ b/tactics/extraargs.mli
@@ -1,32 +1,32 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: extraargs.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 open Tacexpr
 open Term
 open Names
 open Proof_type
 open Topconstr
 open Termops
-open Rawterm
+open Glob_term
 
 val rawwit_orient : bool raw_abstract_argument_type
 val wit_orient : bool typed_abstract_argument_type
-val orient : bool Pcoq.Gram.Entry.e
+val orient : bool Pcoq.Gram.entry
+val pr_orient : bool -> Pp.std_ppcmds
 
-val occurrences : (int list or_var) Pcoq.Gram.Entry.e
+val occurrences : (int list or_var) Pcoq.Gram.entry
 val rawwit_occurrences : (int list or_var) raw_abstract_argument_type
 val wit_occurrences : (int list) typed_abstract_argument_type
+val pr_occurrences : int list Glob_term.or_var -> Pp.std_ppcmds
 
-val rawwit_raw : constr_expr raw_abstract_argument_type
-val wit_raw : (Tacinterp.interp_sign * rawconstr) typed_abstract_argument_type
-val raw : constr_expr Pcoq.Gram.Entry.e
+val rawwit_glob : constr_expr raw_abstract_argument_type
+val wit_glob : (Tacinterp.interp_sign * glob_constr) typed_abstract_argument_type
+val glob : constr_expr Pcoq.Gram.entry
 
 type 'id gen_place= ('id * hyp_location_flag,unit) location
 
@@ -35,24 +35,26 @@ type place = identifier gen_place
 
 val rawwit_hloc : loc_place raw_abstract_argument_type
 val wit_hloc : place typed_abstract_argument_type
-val hloc : loc_place Pcoq.Gram.Entry.e
-
+val hloc : loc_place Pcoq.Gram.entry
+val pr_hloc : loc_place -> Pp.std_ppcmds
 
-val in_arg_hyp:  (Names.identifier Util.located list option * bool)  Pcoq.Gram.Entry.e
+val in_arg_hyp:  (Names.identifier Util.located list option * bool)  Pcoq.Gram.entry
 val rawwit_in_arg_hyp : (Names.identifier Util.located list option * bool) raw_abstract_argument_type
 val wit_in_arg_hyp : (Names.identifier list option * bool) typed_abstract_argument_type
 val raw_in_arg_hyp_to_clause : (Names.identifier Util.located list option * bool) -> Tacticals.clause
 val glob_in_arg_hyp_to_clause :  (Names.identifier list option * bool)  -> Tacticals.clause
+val pr_in_arg_hyp : (Names.identifier list option * bool) -> Pp.std_ppcmds
 
-
-val by_arg_tac : Tacexpr.raw_tactic_expr option Pcoq.Gram.Entry.e
+val by_arg_tac : Tacexpr.raw_tactic_expr option Pcoq.Gram.entry
 val rawwit_by_arg_tac :  raw_tactic_expr option raw_abstract_argument_type
 val wit_by_arg_tac : glob_tactic_expr option typed_abstract_argument_type
+val pr_by_arg_tac : 
+  (int * Ppextend.parenRelation -> raw_tactic_expr -> Pp.std_ppcmds) ->
+  raw_tactic_expr option -> Pp.std_ppcmds
 
 
+(** Spiwack: Primitive for retroknowledge registration *)
 
-(* Spiwack: Primitive for retroknowledge registration *)
-
-val retroknowledge_field : Retroknowledge.field Pcoq.Gram.Entry.e
+val retroknowledge_field : Retroknowledge.field Pcoq.Gram.entry
 val rawwit_retroknowledge_field :  Retroknowledge.field raw_abstract_argument_type
 val wit_retroknowledge_field : Retroknowledge.field typed_abstract_argument_type
diff --git a/tactics/extratactics.ml4 b/tactics/extratactics.ml4
index c4a2ef44..da35edbe 100644
--- a/tactics/extratactics.ml4
+++ b/tactics/extratactics.ml4
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,8 +8,6 @@
 
 (*i camlp4deps: "parsing/grammar.cma" i*)
 
-(* $Id: extratactics.ml4 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Pp
 open Pcoq
 open Genarg
@@ -17,12 +15,12 @@ open Extraargs
 open Mod_subst
 open Names
 open Tacexpr
-open Rawterm
+open Glob_term
 open Tactics
 open Util
-open Termops
 open Evd
 open Equality
+open Compat
 
 (**********************************************************************)
 (* replace, discriminate, injection, simplify_eq                      *)
@@ -189,13 +187,24 @@ END
 
 open Autorewrite
 
+let pr_orient _prc _prlc _prt = function
+  | true -> Pp.mt ()
+  | false -> Pp.str " <-"
+
+let pr_orient_string _prc _prlc _prt (orient, s) =
+  pr_orient _prc _prlc _prt orient ++ Pp.spc () ++ Pp.str s
+
+ARGUMENT EXTEND orient_string TYPED AS (bool * string) PRINTED BY pr_orient_string
+| [ orient(r) preident(i) ] -> [ r, i ]
+END
+
 TACTIC EXTEND autorewrite
 | [ "autorewrite" "with" ne_preident_list(l) in_arg_hyp(cl) ] ->
     [ auto_multi_rewrite  l (glob_in_arg_hyp_to_clause  cl) ]
 | [ "autorewrite" "with" ne_preident_list(l) in_arg_hyp(cl) "using" tactic(t) ] ->
     [
       let cl =  glob_in_arg_hyp_to_clause cl in
-      auto_multi_rewrite_with (snd t) l cl
+      auto_multi_rewrite_with (Tacinterp.eval_tactic t) l cl
 
     ]
 END
@@ -205,7 +214,7 @@ TACTIC EXTEND autorewrite_star
     [ auto_multi_rewrite ~conds:AllMatches l (glob_in_arg_hyp_to_clause  cl) ]
 | [ "autorewrite" "*" "with" ne_preident_list(l) in_arg_hyp(cl) "using" tactic(t) ] ->
     [ let cl =  glob_in_arg_hyp_to_clause cl in
-	auto_multi_rewrite_with ~conds:AllMatches (snd t) l cl ]
+	auto_multi_rewrite_with ~conds:AllMatches (Tacinterp.eval_tactic t) l cl ]
 END
 
 (**********************************************************************)
@@ -214,7 +223,7 @@ END
 let rewrite_star clause orient occs (sigma,c) (tac : glob_tactic_expr option) =
   let tac' = Option.map (fun t -> Tacinterp.eval_tactic t, FirstSolved) tac in
   Refiner. tclWITHHOLES false
-    (general_rewrite_ebindings_clause clause orient occs ?tac:tac' true (c,NoBindings)) sigma true
+    (general_rewrite_ebindings_clause clause orient occs ?tac:tac' true true (c,NoBindings)) sigma true
 
 let occurrences_of = function
   | n::_ as nl when n < 0 -> (false,List.map abs nl)
@@ -229,11 +238,11 @@ TACTIC EXTEND rewrite_star
 | [ "rewrite" "*" orient(o) open_constr(c) "at" occurrences(occ) "in" hyp(id) by_arg_tac(tac) ] ->
     [ rewrite_star (Some id) o (occurrences_of occ) c tac ]
 | [ "rewrite" "*" orient(o) open_constr(c) "in" hyp(id) by_arg_tac(tac) ] ->
-    [ rewrite_star (Some id) o all_occurrences c tac ]
+    [ rewrite_star (Some id) o Termops.all_occurrences c tac ]
 | [ "rewrite" "*" orient(o) open_constr(c) "at" occurrences(occ) by_arg_tac(tac) ] ->
     [ rewrite_star None o (occurrences_of occ) c tac ]
 | [ "rewrite" "*" orient(o) open_constr(c) by_arg_tac(tac) ] ->
-    [ rewrite_star None o all_occurrences c tac ]
+    [ rewrite_star None o Termops.all_occurrences c tac ]
     END
 
 (**********************************************************************)
@@ -277,7 +286,7 @@ let project_hint pri l2r c =
   let c = Reductionops.whd_beta Evd.empty (mkApp (c,Termops.extended_rel_vect 0 sign)) in
   let c = it_mkLambda_or_LetIn
     (mkApp (p,[|mkArrow a (lift 1 b);mkArrow b (lift 1 a);c|])) sign in
-  (pri,true,c)
+  (pri,true,Auto.PathAny,c)
 
 let add_hints_iff l2r lc n bl =
   Auto.add_hints true bl
@@ -326,18 +335,18 @@ VERNAC COMMAND EXTEND DeriveInversionClear
   -> [ add_inversion_lemma_exn na c s false inv_clear_tac ]
 
 | [ "Derive" "Inversion_clear" ident(na) "with" constr(c) ]
-  -> [ add_inversion_lemma_exn na c (Rawterm.RProp Term.Null) false inv_clear_tac ]
+  -> [ add_inversion_lemma_exn na c (Glob_term.GProp Term.Null) false inv_clear_tac ]
 END
 
 open Term
-open Rawterm
+open Glob_term
 
 VERNAC COMMAND EXTEND DeriveInversion
 | [ "Derive" "Inversion" ident(na) "with" constr(c) "Sort" sort(s) ]
   -> [ add_inversion_lemma_exn na c s false inv_tac ]
 
 | [ "Derive" "Inversion" ident(na) "with" constr(c) ]
-  -> [ add_inversion_lemma_exn na c (RProp Null) false inv_tac ]
+  -> [ add_inversion_lemma_exn na c (GProp Null) false inv_tac ]
 
 | [ "Derive" "Inversion" ident(na) hyp(id) ]
   -> [ inversion_lemma_from_goal 1 na id Term.prop_sort false inv_tac ]
@@ -385,7 +394,7 @@ open Tacexpr
 open Tacticals
 
 TACTIC EXTEND instantiate
-  [ "instantiate" "(" integer(i) ":=" raw(c) ")" hloc(hl) ] ->
+  [ "instantiate" "(" integer(i) ":=" glob(c) ")" hloc(hl) ] ->
     [instantiate i c hl  ]
 | [ "instantiate" ] -> [ tclNORMEVAR ]
 END
@@ -397,7 +406,7 @@ END
 open Tactics
 open Tactics
 open Libnames
-open Rawterm
+open Glob_term
 open Summary
 open Libobject
 open Lib
@@ -433,7 +442,7 @@ let cache_transitivity_lemma (_,(left,lem)) =
 
 let subst_transitivity_lemma (subst,(b,ref)) = (b,subst_mps subst ref)
 
-let (inTransitivity,_) =
+let inTransitivity : bool * constr -> obj =
   declare_object {(default_object "TRANSITIVITY-STEPS") with
     cache_function = cache_transitivity_lemma;
     open_function = (fun i o -> if i=1 then cache_transitivity_lemma o);
@@ -467,12 +476,12 @@ let add_transitivity_lemma left lem =
 (* Vernacular syntax *)
 
 TACTIC EXTEND stepl
-| ["stepl" constr(c) "by" tactic(tac) ] -> [ step true c (snd tac) ]
+| ["stepl" constr(c) "by" tactic(tac) ] -> [ step true c (Tacinterp.eval_tactic tac) ]
 | ["stepl" constr(c) ] -> [ step true c tclIDTAC ]
 END
 
 TACTIC EXTEND stepr
-| ["stepr" constr(c) "by" tactic(tac) ] -> [ step false c (snd tac) ]
+| ["stepr" constr(c) "by" tactic(tac) ] -> [ step false c (Tacinterp.eval_tactic tac) ]
 | ["stepr" constr(c) ] -> [ step false c tclIDTAC ]
 END
 
@@ -488,7 +497,7 @@ END
 
 VERNAC COMMAND EXTEND ImplicitTactic
 | [ "Declare" "Implicit" "Tactic" tactic(tac) ] ->
-    [ Tacinterp.declare_implicit_tactic (Tacinterp.interp tac) ]
+    [ Pfedit.declare_implicit_tactic (Tacinterp.interp tac) ]
 END
 
 
@@ -539,27 +548,27 @@ END
 (**********************************************************************)
 
 let subst_var_with_hole occ tid t = 
-  let occref = if occ > 0 then ref occ else error_invalid_occurrence [occ] in
+  let occref = if occ > 0 then ref occ else Termops.error_invalid_occurrence [occ] in
   let locref = ref 0 in
   let rec substrec = function
-    | RVar (_,id) as x -> 
+    | GVar (_,id) as x -> 
         if id = tid 
         then (decr occref; if !occref = 0 then x
-                           else (incr locref; RHole (make_loc (!locref,0),Evd.QuestionMark(Evd.Define true))))
+                           else (incr locref; GHole (make_loc (!locref,0),Evd.QuestionMark(Evd.Define true))))
         else x
-    | c -> map_rawconstr_left_to_right substrec c in
+    | c -> map_glob_constr_left_to_right substrec c in
   let t' = substrec t
   in
-  if !occref > 0 then error_invalid_occurrence [occ] else t'
+  if !occref > 0 then Termops.error_invalid_occurrence [occ] else t'
 
 let subst_hole_with_term occ tc t =
   let locref = ref 0 in
   let occref = ref occ in
   let rec substrec = function
-    | RHole (_,Evd.QuestionMark(Evd.Define true)) -> 
+    | GHole (_,Evd.QuestionMark(Evd.Define true)) -> 
         decr occref; if !occref = 0 then tc
-                     else (incr locref; RHole (make_loc (!locref,0),Evd.QuestionMark(Evd.Define true)))
-    | c -> map_rawconstr_left_to_right substrec c
+                     else (incr locref; GHole (make_loc (!locref,0),Evd.QuestionMark(Evd.Define true)))
+    | c -> map_glob_constr_left_to_right substrec c
   in
   substrec t
 
@@ -571,16 +580,16 @@ let out_arg = function
 
 let hResolve id c occ t gl = 
   let sigma = project gl in 
-  let env = clear_named_body id (pf_env gl) in
-  let env_ids = ids_of_context env in
-  let env_names = names_of_rel_context env in
+  let env = Termops.clear_named_body id (pf_env gl) in
+  let env_ids = Termops.ids_of_context env in
+  let env_names = Termops.names_of_rel_context env in
   let c_raw = Detyping.detype true env_ids env_names c in 
   let t_raw = Detyping.detype true env_ids env_names t in 
   let rec resolve_hole t_hole =
     try 
       Pretyping.Default.understand sigma env t_hole
     with 
-    | Stdpp.Exc_located (loc,Pretype_errors.PretypeError (_, Pretype_errors.UnsolvableImplicit _)) -> 
+    | Loc.Exc_located (loc,Pretype_errors.PretypeError (_,_,Pretype_errors.UnsolvableImplicit _)) ->
         resolve_hole (subst_hole_with_term (fst (unloc loc)) c_raw t_hole)
   in
   let t_constr = resolve_hole (subst_var_with_hole occ id t_raw) in
@@ -625,8 +634,91 @@ END
 
 (**********************************************************************)
 
+(**********************************************************************)
+(* A tactic that reduces one match t with ... by doing destruct t.    *)
+(* if t is not a variable, the tactic does                            *)
+(* case_eq t;intros ... heq;rewrite heq in *|-. (but heq itself is    *)
+(* preserved).                                                        *)
+(* Contributed by Julien Forest and Pierre Courtieu (july 2010)       *)
+(**********************************************************************)
+
+exception Found of tactic
+
+let rewrite_except h g =
+  tclMAP (fun id -> if id = h then tclIDTAC else 
+      tclTRY (Equality.general_rewrite_in true Termops.all_occurrences true true id (mkVar h) false))
+    (Tacmach.pf_ids_of_hyps g) g
+
+
+let refl_equal = 
+  let coq_base_constant s =
+    Coqlib.gen_constant_in_modules "RecursiveDefinition"
+      (Coqlib.init_modules @ [["Coq";"Arith";"Le"];["Coq";"Arith";"Lt"]]) s in
+  function () -> (coq_base_constant "eq_refl")
+
+
+(* This is simply an implementation of the case_eq tactic.  this code
+  should be replaced by a call to the tactic but I don't know how to
+  call it before it is defined. *)
+let  mkCaseEq a  : tactic =
+     (fun g ->
+       let type_of_a = Tacmach.pf_type_of g a in
+       tclTHENLIST
+         [Hiddentac.h_generalize [mkApp(delayed_force refl_equal, [| type_of_a; a|])];
+          (fun g2 ->
+	    change_in_concl None
+	     (Tacred.pattern_occs [((false,[1]), a)] (Tacmach.pf_env g2) Evd.empty (Tacmach.pf_concl g2))
+		  g2);
+	  simplest_case a] g);;
+
+
+let case_eq_intros_rewrite x g =
+  let n = nb_prod (Tacmach.pf_concl g) in
+  Pp.msgnl (Printer.pr_lconstr x); 
+  tclTHENLIST [
+      mkCaseEq x;
+      (fun g -> 
+	let n' = nb_prod (Tacmach.pf_concl g) in
+	let h = fresh_id (Tacmach.pf_ids_of_hyps g) (id_of_string "heq") g in
+	tclTHENLIST [ (tclDO (n'-n-1) intro);
+		      Tacmach.introduction h;
+		      rewrite_except h] g
+      )
+    ] g
+
+let rec find_a_destructable_match t =
+  match kind_of_term t with
+    | Case (_,_,x,_) when closed0 x ->
+	if isVar x then
+	  (* TODO check there is no rel n. *)
+	  raise (Found (Tacinterp.eval_tactic(<:tactic<destruct x>>)))
+	else
+	  let _ = Pp.msgnl (Printer.pr_lconstr x)  in
+	  raise (Found (case_eq_intros_rewrite x))
+    | _ -> iter_constr find_a_destructable_match t
+	
+
+let destauto t =
+  try find_a_destructable_match t;
+    error "No destructable match found"
+  with Found tac -> tac
+
+let destauto_in id g = 
+  let ctype = Tacmach.pf_type_of g (mkVar id) in
+  Pp.msgnl (Printer.pr_lconstr (mkVar id)); 
+  Pp.msgnl (Printer.pr_lconstr (ctype)); 
+  destauto ctype g
+
+TACTIC EXTEND destauto
+| [ "destauto" ] -> [ (fun g -> destauto (Tacmach.pf_concl g) g) ]
+| [ "destauto" "in" hyp(id) ] -> [ destauto_in id ]
+END
+
+
+(* ********************************************************************* *)
+
 TACTIC EXTEND constr_eq
-| [ "constr_eq" constr(x) constr(y) ] -> [ 
+| [ "constr_eq" constr(x) constr(y) ] -> [
     if eq_constr x y then tclIDTAC else tclFAIL 0 (str "Not equal") ]
 END
 
diff --git a/tactics/extratactics.mli b/tactics/extratactics.mli
index ecad939c..66f46722 100644
--- a/tactics/extratactics.mli
+++ b/tactics/extratactics.mli
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: extratactics.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 open Proof_type
 
 val h_discrHyp : Names.identifier -> tactic
diff --git a/tactics/hiddentac.ml b/tactics/hiddentac.ml
index 018bf815..fafc681a 100644
--- a/tactics/hiddentac.ml
+++ b/tactics/hiddentac.ml
@@ -1,18 +1,16 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: hiddentac.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Term
 open Proof_type
 open Tacmach
 
-open Rawterm
+open Glob_term
 open Refiner
 open Genarg
 open Tacexpr
@@ -66,6 +64,10 @@ let h_generalize_dep c =
 let h_let_tac b na c cl =
   let with_eq = if b then None else Some (true,(dummy_loc,IntroAnonymous)) in
   abstract_tactic (TacLetTac (na,c,cl,b)) (letin_tac with_eq na c None cl)
+let h_let_pat_tac b na c cl =
+  let with_eq = if b then None else Some (true,(dummy_loc,IntroAnonymous)) in
+  abstract_tactic (TacLetTac (na,snd c,cl,b))
+    (letin_pat_tac with_eq na c None cl)
 
 (* Derived basic tactics *)
 let h_simple_induction_destruct isrec h =
@@ -74,10 +76,17 @@ let h_simple_induction_destruct isrec h =
 let h_simple_induction = h_simple_induction_destruct true
 let h_simple_destruct = h_simple_induction_destruct false
 
+let out_indarg = function
+  | ElimOnConstr (_,c) -> ElimOnConstr c
+  | ElimOnIdent id -> ElimOnIdent id
+  | ElimOnAnonHyp n -> ElimOnAnonHyp n
+
 let h_induction_destruct isrec ev lcl =
-  abstract_tactic (TacInductionDestruct (isrec,ev,lcl))
+  let lcl' = on_fst (List.map (fun (a,b,c) ->(List.map out_indarg a,b,c))) lcl in
+  abstract_tactic (TacInductionDestruct (isrec,ev,lcl'))
     (induction_destruct isrec ev lcl)
-let h_new_induction ev c e idl cl = h_induction_destruct true ev ([c,e,idl],cl)
+let h_new_induction ev c e idl cl =
+  h_induction_destruct true ev ([c,e,idl],cl)
 let h_new_destruct ev c e idl cl = h_induction_destruct false ev ([c,e,idl],cl)
 
 let h_specialize n d = abstract_tactic (TacSpecialize (n,d)) (specialize n d)
@@ -102,9 +111,9 @@ let h_any_constructor t =
   abstract_tactic (TacAnyConstructor t) (any_constructor t)
 *)
 let h_constructor ev n l =
-  abstract_tactic (TacConstructor(ev,AI n,l))(constructor_tac ev None n l)
+  abstract_tactic (TacConstructor(ev,ArgArg n,l))(constructor_tac ev None n l)
 let h_one_constructor n =
-  abstract_tactic (TacConstructor(false,AI n,NoBindings)) (one_constructor n NoBindings)
+  abstract_tactic (TacConstructor(false,ArgArg n,NoBindings)) (one_constructor n NoBindings)
 let h_simplest_left   = h_left false NoBindings
 let h_simplest_right  = h_right false NoBindings
 
diff --git a/tactics/hiddentac.mli b/tactics/hiddentac.mli
index 31484cc0..96e7e3f0 100644
--- a/tactics/hiddentac.mli
+++ b/tactics/hiddentac.mli
@@ -1,14 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: hiddentac.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Names
 open Util
 open Term
@@ -16,16 +13,15 @@ open Proof_type
 open Tacmach
 open Genarg
 open Tacexpr
-open Rawterm
+open Glob_term
 open Evd
 open Clenv
 open Termops
-(*i*)
 
-(* Tactics for the interpreter. They left a trace in the proof tree
+(** Tactics for the interpreter. They left a trace in the proof tree
    when they are called. *)
 
-(* Basic tactics *)
+(** Basic tactics *)
 
 val h_intro_move      : identifier option -> identifier move_location -> tactic
 val h_intro           : identifier -> tactic
@@ -61,39 +57,44 @@ val h_generalize_gen  : (constr with_occurrences * name) list -> tactic
 val h_generalize_dep  : constr -> tactic
 val h_let_tac         : letin_flag -> name -> constr ->
                         Tacticals.clause -> tactic
+val h_let_pat_tac     : letin_flag -> name -> evar_map * constr ->
+                        Tacticals.clause -> tactic
 
-(* Derived basic tactics *)
+(** Derived basic tactics *)
 
 val h_simple_induction   : quantified_hypothesis -> tactic
 val h_simple_destruct    : quantified_hypothesis -> tactic
 val h_simple_induction_destruct : rec_flag -> quantified_hypothesis -> tactic
 val h_new_induction   : evars_flag ->
-  constr with_bindings induction_arg list -> constr with_bindings option ->
+  (evar_map * constr with_bindings) induction_arg list ->
+  constr with_bindings option ->
   intro_pattern_expr located option * intro_pattern_expr located option ->
   Tacticals.clause option -> tactic
 val h_new_destruct    : evars_flag ->
-  constr with_bindings induction_arg list -> constr with_bindings option ->
+  (evar_map * constr with_bindings) induction_arg list ->
+  constr with_bindings option ->
   intro_pattern_expr located option * intro_pattern_expr located option ->
   Tacticals.clause option -> tactic
 val h_induction_destruct : rec_flag -> evars_flag ->
-  (constr with_bindings induction_arg list * constr with_bindings option *
+  ((evar_map * constr with_bindings) induction_arg list *
+   constr with_bindings option *
    (intro_pattern_expr located option * intro_pattern_expr located option)) list
     * Tacticals.clause option -> tactic
 
 val h_specialize      : int option -> constr with_bindings -> tactic
 val h_lapply          : constr -> tactic
 
-(* Automation tactic : see Auto *)
+(** Automation tactic : see Auto *)
 
 
-(* Context management *)
+(** Context management *)
 val h_clear           : bool -> identifier list -> tactic
 val h_clear_body      : identifier list -> tactic
 val h_move            : bool -> identifier -> identifier move_location -> tactic
 val h_rename          : (identifier*identifier) list -> tactic
 val h_revert          : identifier list -> tactic
 
-(* Constructors *)
+(** Constructors *)
 val h_constructor     : evars_flag -> int -> constr bindings -> tactic
 val h_left            : evars_flag -> constr bindings -> tactic
 val h_right           : evars_flag -> constr bindings -> tactic
@@ -104,12 +105,12 @@ val h_simplest_left   : tactic
 val h_simplest_right  : tactic
 
 
-(* Conversion *)
+(** Conversion *)
 val h_reduce          : Redexpr.red_expr -> Tacticals.clause -> tactic
 val h_change          :
   Pattern.constr_pattern option -> constr -> Tacticals.clause -> tactic
 
-(* Equivalence relations *)
+(** Equivalence relations *)
 val h_reflexivity     : tactic
 val h_symmetry        : Tacticals.clause -> tactic
 val h_transitivity    : constr option -> tactic
diff --git a/tactics/hipattern.ml4 b/tactics/hipattern.ml4
index 08bcf65a..9057c60d 100644
--- a/tactics/hipattern.ml4
+++ b/tactics/hipattern.ml4
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,8 +8,6 @@
 
 (*i camlp4deps: "parsing/grammar.cma parsing/q_constr.cmo" i*)
 
-(* $Id: hipattern.ml4 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Pp
 open Util
 open Names
@@ -21,7 +19,6 @@ open Reductionops
 open Inductiveops
 open Evd
 open Environ
-open Proof_trees
 open Clenv
 open Pattern
 open Matching
@@ -98,7 +95,7 @@ let match_with_one_constructor style allow_rec t =
 	      (decompose_prod_n_assum mib.mind_nparams mip.mind_nf_lc.(0)))) in
 	  if
 	    List.for_all
-	      (fun (_,b,c) -> b=None && c = mkRel mib.mind_nparams) ctx
+	      (fun (_,b,c) -> b=None && isRel c && destRel c = mib.mind_nparams) ctx
 	  then
 	    Some (hdapp,args)
 	  else None
@@ -145,7 +142,7 @@ let is_tuple t =
 let test_strict_disjunction n lc =
   array_for_all_i (fun i c ->
     match (prod_assum (snd (decompose_prod_n_assum n c))) with
-    | [_,None,c] -> c = mkRel (n - i)
+    | [_,None,c] -> isRel c && destRel c = (n - i)
     | _ -> false) 0 lc
 
 let match_with_disjunction ?(strict=false) t =
@@ -426,6 +423,7 @@ let dest_nf_eq gls eqn =
 (* Patterns "(existS ?1 ?2 ?3 ?4)" and "(existT ?1 ?2 ?3 ?4)" *)
 let coq_ex_pattern_gen ex = lazy PATTERN [ %ex ?X1 ?X2 ?X3 ?X4 ]
 let coq_existT_pattern = coq_ex_pattern_gen coq_existT_ref
+let coq_exist_pattern = coq_ex_pattern_gen coq_exist_ref
 
 let match_sigma ex ex_pat =
   match matches (Lazy.force ex_pat) ex with
@@ -437,7 +435,8 @@ let match_sigma ex ex_pat =
 
 let find_sigma_data_decompose ex = (* fails with PatternMatchingFailure *)
   first_match (match_sigma ex)
-    [coq_existT_pattern, build_sigma_type]
+    [coq_existT_pattern, build_sigma_type;
+     coq_exist_pattern, build_sigma]
 
 (* Pattern "(sig ?1 ?2)" *)
 let coq_sig_pattern = lazy PATTERN [ %coq_sig_ref ?X1 ?X2 ]
diff --git a/tactics/hipattern.mli b/tactics/hipattern.mli
index 15d7bfc6..aa386364 100644
--- a/tactics/hipattern.mli
+++ b/tactics/hipattern.mli
@@ -1,25 +1,22 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: hipattern.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Util
 open Names
 open Term
 open Sign
 open Evd
 open Pattern
-open Proof_trees
 open Coqlib
-(*i*)
 
-(*s Given a term with second-order variables in it,
+(** High-order patterns *)
+
+(** Given a term with second-order variables in it,
    represented by Meta's, and possibly applied using SoApp
    terms, this function will perform second-order, binding-preserving,
    matching, in the case where the pattern is a pattern in the sense
@@ -38,7 +35,7 @@ open Coqlib
    intersection of the free-rels of the term and the current stack be
    contained in the arguments of the application *)
 
-(*s I implemented the following functions which test whether a term [t]
+(** I implemented the following functions which test whether a term [t]
    is an inductive but non-recursive type, a general conjuction, a
    general disjunction, or a type with no constructors.
 
@@ -53,36 +50,36 @@ type testing_function = constr -> bool
 val match_with_non_recursive_type : (constr * constr list) matching_function
 val is_non_recursive_type         : testing_function
 
-(* Non recursive type with no indices and exactly one argument for each
+(** Non recursive type with no indices and exactly one argument for each
    constructor; canonical definition of n-ary disjunction if strict *)
 val match_with_disjunction : ?strict:bool -> (constr * constr list) matching_function
 val is_disjunction         : ?strict:bool -> testing_function
 
-(* Non recursive tuple (one constructor and no indices) with no inner
+(** Non recursive tuple (one constructor and no indices) with no inner
    dependencies; canonical definition of n-ary conjunction if strict *)
 val match_with_conjunction : ?strict:bool -> (constr * constr list) matching_function
 val is_conjunction         : ?strict:bool -> testing_function
 
-(* Non recursive tuple, possibly with inner dependencies *)
+(** Non recursive tuple, possibly with inner dependencies *)
 val match_with_record      : (constr * constr list) matching_function
 val is_record              : testing_function
 
-(* Like record but supports and tells if recursive (e.g. Acc) *)
+(** Like record but supports and tells if recursive (e.g. Acc) *)
 val match_with_tuple       : (constr * constr list * bool) matching_function
 val is_tuple               : testing_function
 
-(* No constructor, possibly with indices *)
+(** No constructor, possibly with indices *)
 val match_with_empty_type  : constr matching_function
 val is_empty_type          : testing_function
 
-(* type with only one constructor and no arguments, possibly with indices *)
+(** type with only one constructor and no arguments, possibly with indices *)
 val match_with_unit_or_eq_type : constr matching_function
 val is_unit_or_eq_type     : testing_function
 
-(* type with only one constructor and no arguments, no indices *)
+(** type with only one constructor and no arguments, no indices *)
 val is_unit_type           : testing_function
 
-(* type with only one constructor, no arguments and at least one dependency *)
+(** type with only one constructor, no arguments and at least one dependency *)
 val is_inductive_equality  : inductive -> bool
 val match_with_equality_type : (constr * constr list) matching_function
 val is_equality_type       : testing_function
@@ -96,7 +93,7 @@ val is_forall_term            : testing_function
 val match_with_imp_term    : (constr * constr) matching_function
 val is_imp_term            : testing_function
 
-(* I added these functions to test whether a type contains dependent
+(** I added these functions to test whether a type contains dependent
   products or not, and if an inductive has constructors with dependent types
  (excluding parameters). this is useful to check whether a conjunction is a
  real conjunction and not a dependent tuple. (Pierre Corbineau, 13/5/2002) *)
@@ -110,7 +107,7 @@ val is_nodep_ind           : testing_function
 val match_with_sigma_type   : (constr * constr list) matching_function
 val is_sigma_type           : testing_function
 
-(* Recongnize inductive relation defined by reflexivity *)
+(** Recongnize inductive relation defined by reflexivity *)
 
 type equation_kind =
   | MonomorphicLeibnizEq of constr * constr
@@ -124,37 +121,37 @@ val match_with_equation:
 
 (***** Destructing patterns bound to some theory *)
 
-(* Match terms [eq A t u], [identity A t u] or [JMeq A t A u] *)
-(* Returns associated lemmas and [A,t,u] or fails PatternMatchingFailure *)
+(** Match terms [eq A t u], [identity A t u] or [JMeq A t A u] 
+   Returns associated lemmas and [A,t,u] or fails PatternMatchingFailure *)
 val find_eq_data_decompose : Proof_type.goal sigma -> constr ->
       coq_eq_data * (types * constr * constr)
 
-(* Idem but fails with an error message instead of PatternMatchingFailure *)
+(** Idem but fails with an error message instead of PatternMatchingFailure *)
 val find_this_eq_data_decompose : Proof_type.goal sigma -> constr ->
       coq_eq_data * (types * constr * constr)
 
-(* A variant that returns more informative structure on the equality found *)
+(** A variant that returns more informative structure on the equality found *)
 val find_eq_data : constr -> coq_eq_data * equation_kind
 
-(* Match a term of the form [(existT A P t p)] *)
-(* Returns associated lemmas and [A,P,t,p] *)
+(** Match a term of the form [(existT A P t p)] 
+   Returns associated lemmas and [A,P,t,p] *)
 val find_sigma_data_decompose : constr ->
   coq_sigma_data * (constr * constr * constr * constr)
 
-(* Match a term of the form [{x:A|P}], returns [A] and [P] *)
+(** Match a term of the form [{x:A|P}], returns [A] and [P] *)
 val match_sigma : constr -> constr * constr
 
 val is_matching_sigma : constr -> bool
 
-(* Match a decidable equality judgement (e.g [{t=u:>T}+{~t=u}]), returns
+(** Match a decidable equality judgement (e.g [{t=u:>T}+{~t=u}]), returns
    [t,u,T] and a boolean telling if equality is on the left side *)
 val match_eqdec : constr -> bool * constr * constr * constr * constr
 
-(* Match an equality up to conversion; returns [(eq,t1,t2)] in normal form *)
+(** Match an equality up to conversion; returns [(eq,t1,t2)] in normal form *)
 open Proof_type
 open Tacmach
 val dest_nf_eq : goal sigma -> constr -> (constr * constr * constr)
 
-(* Match a negation *)
+(** Match a negation *)
 val is_matching_not : constr -> bool
 val is_matching_imp_False : constr -> bool
diff --git a/tactics/inv.ml b/tactics/inv.ml
index 37142f30..2ae4e22e 100644
--- a/tactics/inv.ml
+++ b/tactics/inv.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: inv.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Pp
 open Util
 open Names
@@ -34,7 +32,7 @@ open Equality
 open Typing
 open Pattern
 open Matching
-open Rawterm
+open Glob_term
 open Genarg
 open Tacexpr
 
@@ -333,7 +331,9 @@ let projectAndApply thin id eqname names depids gls =
   substHypIfVariable
     (* If no immediate variable in the equation, try to decompose it *)
     (* and apply a trailer which again try to substitute *)
-    (fun id -> dEqThen false (deq_trailer id) (Some (ElimOnIdent (dummy_loc,id))))
+    (fun id ->
+      dEqThen false (deq_trailer id)
+	(Some (ElimOnConstr (mkVar id,NoBindings))))
     id
     gls
 
diff --git a/tactics/inv.mli b/tactics/inv.mli
index 43e2a8de..ef828d88 100644
--- a/tactics/inv.mli
+++ b/tactics/inv.mli
@@ -1,22 +1,18 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: inv.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Util
 open Names
 open Term
 open Tacmach
 open Genarg
 open Tacexpr
-open Rawterm
-(*i*)
+open Glob_term
 
 type inversion_status = Dep of constr option | NoDep
 
diff --git a/tactics/leminv.ml b/tactics/leminv.ml
index 2544a4be..1697c146 100644
--- a/tactics/leminv.ml
+++ b/tactics/leminv.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: leminv.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Pp
 open Util
 open Names
@@ -24,7 +22,6 @@ open Entries
 open Inductiveops
 open Environ
 open Tacmach
-open Proof_trees
 open Proof_type
 open Pfedit
 open Evar_refiner
@@ -37,8 +34,6 @@ open Vernacexpr
 open Safe_typing
 open Decl_kinds
 
-let not_work_message = "tactic fails to build the inversion lemma, may be because the predicate has arguments that depend on other arguments"
-
 let no_inductive_inconstr env constr =
   (str "Cannot recognize an inductive predicate in " ++
      pr_lconstr_env env constr ++
@@ -89,18 +84,6 @@ let no_inductive_inconstr env constr =
 
  *)
 
-let thin_ids env (hyps,vars) =
-  fst
-    (List.fold_left
-       (fun ((ids,globs) as sofar) (id,c,a) ->
-          if List.mem id globs then
-	    match c with
-	      | None -> (id::ids,(global_vars env a)@globs)
-	      | Some body ->
-                  (id::ids,(global_vars env body)@(global_vars env a)@globs)
-          else sofar)
-       ([],vars) hyps)
-
 (* returns the sub_signature of sign corresponding to those identifiers that
  * are not global. *)
 (*
@@ -192,10 +175,6 @@ let compute_first_inversion_scheme env sigma ind sort dep_option =
   let extenv = push_named (p,None,npty) env in
   extenv, goal
 
-let whd_meta_from_map metamap c = match kind_of_term c with
-  | Meta p -> (try List.assoc p metamap with Not_found -> c)
-  | _ -> c
-
 (* [inversion_scheme sign I]
 
    Given a local signature, [sign], and an instance of an inductive
@@ -221,29 +200,32 @@ let inversion_scheme env sigma t sort dep_option inv_op =
     errorlabstrm "lemma_inversion"
     (str"Computed inversion goal was not closed in initial signature.");
   *)
-  let invSign = named_context_val invEnv in
-  let pfs = mk_pftreestate (mk_goal invSign invGoal None) in
-  let pfs = solve_pftreestate (tclTHEN intro (onLastHypId inv_op)) pfs in
-  let (pfterm,meta_types) = extract_open_pftreestate pfs in
+  let pf = Proof.start [invEnv,invGoal] in
+  Proof.run_tactic env (Proofview.V82.tactic (tclTHEN intro (onLastHypId inv_op))) pf;
+  let pfterm = List.hd (Proof.partial_proof pf) in
   let global_named_context = Global.named_context () in
-  let ownSign =
+  let ownSign = ref begin
     fold_named_context
       (fun env (id,_,_ as d) sign ->
          if mem_named_context id global_named_context then sign
 	 else add_named_decl d sign)
       invEnv ~init:empty_named_context
+  end in
+  let avoid = ref [] in
+  let { sigma=sigma } = Proof.V82.subgoals pf in
+  let rec fill_holes c =
+    match kind_of_term c with
+    | Evar (e,args) ->
+	let h = next_ident_away (id_of_string "H") !avoid in
+	let ty,inst = Evarutil.generalize_evar_over_rels sigma (e,args) in
+	avoid := h::!avoid;
+	ownSign := add_named_decl (h,None,ty) !ownSign;
+	applist (mkVar h, inst)
+    | _ -> map_constr fill_holes c
   in
-  let (_,ownSign,mvb) =
-    List.fold_left
-      (fun (avoid,sign,mvb) (mv,mvty) ->
-         let h = next_ident_away (id_of_string "H") avoid in
-	 (h::avoid, add_named_decl (h,None,mvty) sign, (mv,mkVar h)::mvb))
-      (ids_of_context invEnv, ownSign, [])
-      meta_types
-  in
-  let invProof =
-    it_mkNamedLambda_or_LetIn
-      (local_strong (fun _ -> whd_meta_from_map mvb) Evd.empty pfterm) ownSign
+  let c = fill_holes pfterm in
+  (* warning: side-effect on ownSign *)
+  let invProof = it_mkNamedLambda_or_LetIn c !ownSign
   in
   invProof
 
@@ -253,32 +235,23 @@ let add_inversion_lemma name env sigma t sort dep inv_op =
     declare_constant name
     (DefinitionEntry
        { const_entry_body = invProof;
+         const_entry_secctx = None;
          const_entry_type = None;
-         const_entry_opaque = false;
-	 const_entry_boxed = true && (Flags.boxed_definitions())},
+         const_entry_opaque = false },
      IsProof Lemma)
   in ()
 
-(* open Pfedit *)
-
 (* inv_op = Inv (derives de complete inv. lemma)
  * inv_op = InvNoThining (derives de semi inversion lemma) *)
 
 let inversion_lemma_from_goal n na (loc,id) sort dep_option inv_op =
   let pts = get_pftreestate() in
-  let gl = nth_goal_of_pftreestate n pts in
+  let { it=gls ; sigma=sigma } = Proof.V82.subgoals pts in
+  let gl = { it = List.nth gls (n-1) ; sigma=sigma } in
   let t =
     try pf_get_hyp_typ gl id
     with Not_found -> Pretype_errors.error_var_not_found_loc loc id in
   let env = pf_env gl and sigma = project gl in
-(* Pourquoi ???
-  let fv = global_vars env t in
-  let thin_ids = thin_ids (hyps,fv) in
-  if not(list_subset thin_ids fv) then
-    errorlabstrm "lemma_inversion"
-      (str"Cannot compute lemma inversion when there are" ++ spc () ++
-	 str"free variables in the types of an inductive" ++ spc () ++
-	 str"which are not free in its instance."); *)
   add_inversion_lemma na env sigma t sort dep_option inv_op
 
 let add_inversion_lemma_exn na com comsort bool tac =
@@ -296,11 +269,10 @@ let add_inversion_lemma_exn na com comsort bool tac =
 (* ================================= *)
 
 let lemInv id c gls =
-  ignore (pf_get_hyp gls id); (* ensure id exists *)
   try
     let clause = mk_clenv_type_of gls c in
     let clause = clenv_constrain_last_binding (mkVar id) clause in
-    Clenvtac.res_pf clause ~allow_K:true gls
+    Clenvtac.res_pf clause ~flags:Unification.elim_flags gls
   with
     | NoSuchBinding ->
 	errorlabstrm ""
diff --git a/tactics/leminv.mli b/tactics/leminv.mli
index b4b5737b..233aeba3 100644
--- a/tactics/leminv.mli
+++ b/tactics/leminv.mli
@@ -1,7 +1,7 @@
 open Util
 open Names
 open Term
-open Rawterm
+open Glob_term
 open Proof_type
 open Topconstr
 
@@ -15,5 +15,5 @@ val inversion_lemma_from_goal :
   int -> identifier -> identifier located -> sorts -> bool ->
     (identifier -> tactic) -> unit
 val add_inversion_lemma_exn :
-  identifier -> constr_expr -> rawsort -> bool -> (identifier -> tactic) ->
+  identifier -> constr_expr -> glob_sort -> bool -> (identifier -> tactic) ->
     unit
diff --git a/tactics/nbtermdn.ml b/tactics/nbtermdn.ml
index 19df4ff1..4e34fae8 100644
--- a/tactics/nbtermdn.ml
+++ b/tactics/nbtermdn.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: nbtermdn.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Util
 open Names
 open Term
diff --git a/tactics/nbtermdn.mli b/tactics/nbtermdn.mli
index e655b6e3..652ff4f4 100644
--- a/tactics/nbtermdn.mli
+++ b/tactics/nbtermdn.mli
@@ -1,20 +1,16 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: nbtermdn.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Term
 open Pattern
 open Libnames
-(*i*)
 
-(* Named, bounded-depth, term-discrimination nets. *)
+(** Named, bounded-depth, term-discrimination nets. *)
 module Make :
   functor (Y:Map.OrderedType) ->
 sig
diff --git a/tactics/refine.ml b/tactics/refine.ml
index c1b1fe9d..e7f3998a 100644
--- a/tactics/refine.ml
+++ b/tactics/refine.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: refine.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 (* JCF -- 6 janvier 1998  EXPERIMENTAL *)
 
 (*
@@ -114,8 +112,6 @@ let replace_by_meta env sigma = function
 	| _ -> invalid_arg "Tcc.replace_by_meta (TO DO)"
         *)
       in
-      if occur_meta ty then
-	error "Unable to manage a dependent metavariable of higher-order type.";
       mkCast (m,DEFAULTcast, ty),[n,ty],[Some th]
 
 exception NoMeta
@@ -197,8 +193,6 @@ let rec compute_metamap env sigma c = match kind_of_term c with
       end
 
   | Case (ci,p,cc,v) ->
-      if occur_meta p then
-       error "Unable to manage a metavariable in the return clause of a match.";
       (* bof... *)
       let nbr = Array.length v in
       let v = Array.append [|p;cc|] v in
@@ -401,5 +395,3 @@ let refine (evd,c) gl =
      complicated to update meta types when passing through a binder *)
   let th = compute_metamap (pf_env gl) evd c in
   tclTHEN (Refiner.tclEVARS evd) (tcc_aux [] th) gl
-
-let _ = Decl_proof_instr.set_refine refine (* dirty trick to solve circular dependency *)
diff --git a/tactics/refine.mli b/tactics/refine.mli
index 15491616..a96f47ba 100644
--- a/tactics/refine.mli
+++ b/tactics/refine.mli
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: refine.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 open Tacmach
 
 val refine : Evd.open_constr -> tactic
diff --git a/tactics/rewrite.ml4 b/tactics/rewrite.ml4
index fd3eeeb2..d297969d 100644
--- a/tactics/rewrite.ml4
+++ b/tactics/rewrite.ml4
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,8 +8,6 @@
 
 (*i camlp4deps: "parsing/grammar.cma" i*)
 
-(* $Id: rewrite.ml4 11981 2009-03-16 08:18:53Z herbelin $ *)
-
 open Pp
 open Util
 open Names
@@ -20,7 +18,6 @@ open Termops
 open Sign
 open Reduction
 open Proof_type
-open Proof_trees
 open Declarations
 open Tacticals
 open Tacmach
@@ -29,7 +26,7 @@ open Tactics
 open Pattern
 open Clenv
 open Auto
-open Rawterm
+open Glob_term
 open Hiddentac
 open Typeclasses
 open Typeclasses_errors
@@ -39,21 +36,16 @@ open Pfedit
 open Command
 open Libnames
 open Evd
+open Compat
 
 (** Typeclass-based generalized rewriting. *)
 
-let check_required_library d =
-  let d' = List.map id_of_string d in
-  let dir = make_dirpath (List.rev d') in
-  if not (Library.library_is_loaded dir) then
-    error ("Library "^(list_last d)^" has to be required first.")
-
 let classes_dirpath =
   make_dirpath (List.map id_of_string ["Classes";"Coq"])
 
 let init_setoid () =
   if is_dirpath_prefix_of classes_dirpath (Lib.cwd ()) then ()
-  else check_required_library ["Coq";"Setoids";"Setoid"]
+  else Coqlib.check_required_library ["Coq";"Setoids";"Setoid"]
 
 let proper_class =
   lazy (class_info (Nametab.global (Qualid (dummy_loc, qualid_of_string "Coq.Classes.Morphisms.Proper"))))
@@ -61,7 +53,7 @@ let proper_class =
 let proper_proxy_class =
   lazy (class_info (Nametab.global (Qualid (dummy_loc, qualid_of_string "Coq.Classes.Morphisms.ProperProxy"))))
 
-let proper_proj = lazy (mkConst (Option.get (snd (List.hd (Lazy.force proper_class).cl_projs))))
+let proper_proj = lazy (mkConst (Option.get (pi3 (List.hd (Lazy.force proper_class).cl_projs))))
 
 let make_dir l = make_dirpath (List.map id_of_string (List.rev l))
 
@@ -73,28 +65,21 @@ let try_find_reference dir s =
   constr_of_global (try_find_global_reference dir s)
 
 let gen_constant dir s = Coqlib.gen_constant "rewrite" dir s
-let coq_proj1 = lazy(gen_constant ["Init"; "Logic"] "proj1")
-let coq_proj2 = lazy(gen_constant ["Init"; "Logic"] "proj2")
 let coq_eq = lazy(gen_constant ["Init"; "Logic"] "eq")
-let coq_eq_rect = lazy (gen_constant ["Init"; "Logic"] "eq_rect")
 let coq_f_equal = lazy (gen_constant ["Init"; "Logic"] "f_equal")
-let iff = lazy (gen_constant ["Init"; "Logic"] "iff")
 let coq_all = lazy (gen_constant ["Init"; "Logic"] "all")
+let coq_forall = lazy (gen_constant ["Classes"; "Morphisms"] "forall_def")
 let impl = lazy (gen_constant ["Program"; "Basics"] "impl")
 let arrow = lazy (gen_constant ["Program"; "Basics"] "arrow")
-let coq_id = lazy (gen_constant ["Init"; "Datatypes"] "id")
 
 let reflexive_type = lazy (try_find_reference ["Classes"; "RelationClasses"] "Reflexive")
-let reflexive_proof_global = lazy (try_find_global_reference ["Classes"; "RelationClasses"] "reflexivity")
 let reflexive_proof = lazy (try_find_reference ["Classes"; "RelationClasses"] "reflexivity")
 
 let symmetric_type = lazy (try_find_reference ["Classes"; "RelationClasses"] "Symmetric")
 let symmetric_proof = lazy (try_find_reference ["Classes"; "RelationClasses"] "symmetry")
-let symmetric_proof_global = lazy (try_find_global_reference ["Classes"; "RelationClasses"] "symmetry")
 
 let transitive_type = lazy (try_find_reference ["Classes"; "RelationClasses"] "Transitive")
 let transitive_proof = lazy (try_find_reference ["Classes"; "RelationClasses"] "transitivity")
-let transitive_proof_global = lazy (try_find_global_reference ["Classes"; "RelationClasses"] "transitivity")
 
 let coq_inverse = lazy (gen_constant (* ["Classes"; "RelationClasses"] "inverse" *)
 			   ["Program"; "Basics"] "flip")
@@ -102,18 +87,14 @@ let coq_inverse = lazy (gen_constant (* ["Classes"; "RelationClasses"] "inverse"
 let inverse car rel = mkApp (Lazy.force coq_inverse, [| car ; car; mkProp; rel |])
 (* let inverse car rel = mkApp (Lazy.force coq_inverse, [| car ; car; new_Type (); rel |]) *)
 
-let complement = lazy (gen_constant ["Classes"; "RelationClasses"] "complement")
 let forall_relation = lazy (gen_constant ["Classes"; "Morphisms"] "forall_relation")
 let pointwise_relation = lazy (gen_constant ["Classes"; "Morphisms"] "pointwise_relation")
 
-let respectful_dep = lazy (gen_constant ["Classes"; "Morphisms"] "respectful_dep")
 let respectful = lazy (gen_constant ["Classes"; "Morphisms"] "respectful")
 
-let equivalence = lazy (gen_constant ["Classes"; "RelationClasses"] "Equivalence")
 let default_relation = lazy (gen_constant ["Classes"; "SetoidTactics"] "DefaultRelation")
 
 let subrelation = lazy (gen_constant ["Classes"; "RelationClasses"] "subrelation")
-let is_subrelation = lazy (gen_constant ["Classes"; "RelationClasses"] "is_subrelation")
 let do_subrelation = lazy (gen_constant ["Classes"; "Morphisms"] "do_subrelation")
 let apply_subrelation = lazy (gen_constant ["Classes"; "Morphisms"] "apply_subrelation")
 
@@ -121,25 +102,13 @@ let coq_relation = lazy (gen_constant ["Relations";"Relation_Definitions"] "rela
 let mk_relation a = mkApp (Lazy.force coq_relation, [| a |])
 (* let mk_relation a = mkProd (Anonymous, a, mkProd (Anonymous, a, new_Type ())) *)
 
-let coq_relationT = lazy (gen_constant ["Classes";"Relations"] "relationT")
-
-let setoid_refl_proj = lazy (gen_constant ["Classes"; "SetoidClass"] "Equivalence_Reflexive")
-
-let setoid_equiv = lazy (gen_constant ["Classes"; "SetoidClass"] "equiv")
-let setoid_proper = lazy (gen_constant ["Classes"; "SetoidClass"] "setoid_proper")
-let setoid_refl_proj = lazy (gen_constant ["Classes"; "SetoidClass"] "Equivalence_Reflexive")
-
 let rewrite_relation_class = lazy (gen_constant ["Classes"; "RelationClasses"] "RewriteRelation")
-let rewrite_relation = lazy (gen_constant ["Classes"; "RelationClasses"] "rewrite_relation")
 
 let arrow_morphism a b =
   if isprop a && isprop b then
     Lazy.force impl
   else Lazy.force arrow
 
-let setoid_refl pars x =
-  applistc (Lazy.force setoid_refl_proj) (pars @ [x])
-
 let proper_type = lazy (constr_of_global (Lazy.force proper_class).cl_impl)
 
 let proper_proxy_type = lazy (constr_of_global (Lazy.force proper_proxy_class).cl_impl)
@@ -167,14 +136,14 @@ let split_head = function
     hd :: tl -> hd, tl
   | [] -> assert(false)
 
-let new_goal_evar (goal,cstr) env t =
-  let goal', t = Evarutil.new_evar goal env t in
-    (goal', cstr), t
-
 let new_cstr_evar (goal,cstr) env t =
   let cstr', t = Evarutil.new_evar cstr env t in
     (goal, cstr'), t
 
+let new_goal_evar (goal,cstr) env t =
+  let goal', t = Evarutil.new_evar goal env t in
+    (goal', cstr), t
+
 let build_signature evars env m (cstrs : (types * types option) option list)
     (finalcstr : (types * types option) option) =
   let new_evar evars env t =
@@ -220,11 +189,17 @@ let proper_proof env evars carrier relation x =
   let goal = mkApp (Lazy.force proper_proxy_type, [| carrier ; relation; x |])
   in new_cstr_evar evars env goal
 
+let extends_undefined evars evars' =
+  let f ev evi found = found || not (Evd.mem evars ev)
+  in fold_undefined f evars' false
+  
+
 let find_class_proof proof_type proof_method env evars carrier relation =
   try
     let goal = mkApp (Lazy.force proof_type, [| carrier ; relation |]) in
-    let evars, c = Typeclasses.resolve_one_typeclass env evars goal in
-      mkApp (Lazy.force proof_method, [| carrier; relation; c |])
+    let evars', c = Typeclasses.resolve_one_typeclass env evars goal in
+      if extends_undefined evars evars' then raise Not_found
+      else mkApp (Lazy.force proof_method, [| carrier; relation; c |])
   with e when Logic.catchable_exception e -> raise Not_found
 
 let get_reflexive_proof env = find_class_proof reflexive_type reflexive_proof env
@@ -247,10 +222,14 @@ type hypinfo = {
   l2r : bool;
   c1 : constr;
   c2 : constr;
-  c  : constr with_bindings option;
+  c  : (Tacinterp.interp_sign * Genarg.glob_constr_and_expr with_bindings) option;
   abs : (constr * types) option;
+  flags : Unification.unify_flags;
 }
 
+let goalevars evars = fst evars
+let cstrevars evars = snd evars
+
 let evd_convertible env evd x y =
   try ignore(Evarconv.the_conv_x env x y evd); true
   with _ -> false
@@ -270,10 +249,14 @@ let rec decompose_app_rel env evd t =
 	in (f'', args)
   | _ -> error "The term provided is not an applied relation."
 
-let decompose_applied_relation env sigma (c,l) left2right =
-  let ctype = Typing.type_of env sigma c in
+(*   let nc, c', cl = push_rel_context_to_named_context env c in *)
+(*   let env' = reset_with_named_context nc env in *)
+
+let decompose_applied_relation env sigma flags orig (c,l) left2right =
+  let c' = c in
+  let ctype = Typing.type_of env sigma c' in
   let find_rel ty =
-    let eqclause = Clenv.make_clenv_binding_env_apply env sigma None (c,ty) l in
+    let eqclause = Clenv.make_clenv_binding_env_apply env sigma None (c',ty) l in
     let (equiv, args) = decompose_app_rel env sigma (Clenv.clenv_type eqclause) in
     let c1 = args.(0) and c2 = args.(1) in 
     let ty1, ty2 =
@@ -283,7 +266,8 @@ let decompose_applied_relation env sigma (c,l) left2right =
       else
 	Some { cl=eqclause; prf=(Clenv.clenv_value eqclause);
 	       car=ty1; rel = equiv;
-	       l2r=left2right; c1=c1; c2=c2; c=Some (c,l); abs=None }
+	       l2r=left2right; c1=c1; c2=c2; c=orig; abs=None;
+	       flags = flags }
   in
     match find_rel ctype with
     | Some c -> c
@@ -293,44 +277,81 @@ let decompose_applied_relation env sigma (c,l) left2right =
 	| Some c -> c
 	| None -> error "The term does not end with an applied homogeneous relation."
 
-let rewrite_unif_flags = {
-  Unification.modulo_conv_on_closed_terms = None;
-  Unification.use_metas_eagerly = true;
-  Unification.modulo_delta = empty_transparent_state;
-  Unification.resolve_evars = true;
-  Unification.use_evars_pattern_unification = true;
-}
+open Tacinterp
+let decompose_applied_relation_expr env sigma flags (is, (c,l)) left2right =
+  let sigma, cbl = Tacinterp.interp_open_constr_with_bindings is env sigma (c,l) in
+    decompose_applied_relation env sigma flags (Some (is, (c,l))) cbl left2right
+
+let rewrite_db = "rewrite"
 
 let conv_transparent_state = (Idpred.empty, Cpred.full)
 
-let rewrite2_unif_flags = {
-  Unification.modulo_conv_on_closed_terms = Some conv_transparent_state;
-  Unification.use_metas_eagerly = true;
+let _ = 
+  Auto.add_auto_init
+    (fun () ->
+       Auto.create_hint_db false rewrite_db conv_transparent_state true)
+
+let rewrite_transparent_state () =
+  Auto.Hint_db.transparent_state (Auto.searchtable_map rewrite_db)
+
+let rewrite_unif_flags = {
+  Unification.modulo_conv_on_closed_terms = None;
+  Unification.use_metas_eagerly_in_conv_on_closed_terms = true;
   Unification.modulo_delta = empty_transparent_state;
+  Unification.modulo_delta_types = full_transparent_state;
+  Unification.check_applied_meta_types = true;
   Unification.resolve_evars = true;
-  Unification.use_evars_pattern_unification = true;
+  Unification.use_pattern_unification = true;
+  Unification.use_meta_bound_pattern_unification = true;
+  Unification.frozen_evars = ExistentialSet.empty;
+  Unification.restrict_conv_on_strict_subterms = false;
+  Unification.modulo_betaiota = false;
+  Unification.modulo_eta = true;
+  Unification.allow_K_in_toplevel_higher_order_unification = true
 }
 
-let setoid_rewrite_unif_flags = {
-  Unification.modulo_conv_on_closed_terms = Some conv_transparent_state;
-  Unification.use_metas_eagerly = true;
-  Unification.modulo_delta = conv_transparent_state;
-  Unification.resolve_evars = true;
-  Unification.use_evars_pattern_unification = true;
-}
+let rewrite2_unif_flags = 
+  {  Unification.modulo_conv_on_closed_terms = Some conv_transparent_state;
+     Unification.use_metas_eagerly_in_conv_on_closed_terms = true;
+     Unification.modulo_delta = empty_transparent_state;
+     Unification.modulo_delta_types = conv_transparent_state;
+     Unification.check_applied_meta_types = true;
+     Unification.resolve_evars = true;
+     Unification.use_pattern_unification = true;
+     Unification.use_meta_bound_pattern_unification = true;
+     Unification.frozen_evars = ExistentialSet.empty;
+     Unification.restrict_conv_on_strict_subterms = false;
+     Unification.modulo_betaiota = true;
+     Unification.modulo_eta = true;
+     Unification.allow_K_in_toplevel_higher_order_unification = true
+  }
+
+let general_rewrite_unif_flags () = 
+  let ts = rewrite_transparent_state () in
+    {  Unification.modulo_conv_on_closed_terms = Some ts;
+       Unification.use_metas_eagerly_in_conv_on_closed_terms = true;
+       Unification.modulo_delta = ts;
+       Unification.modulo_delta_types = ts;
+       Unification.check_applied_meta_types = true;
+       Unification.resolve_evars = true;
+       Unification.use_pattern_unification = true;
+       Unification.use_meta_bound_pattern_unification = true;
+       Unification.frozen_evars = ExistentialSet.empty;
+       Unification.restrict_conv_on_strict_subterms = false;
+       Unification.modulo_betaiota = true;
+       Unification.modulo_eta = true;
+       Unification.allow_K_in_toplevel_higher_order_unification = true }
 
 let convertible env evd x y =
   Reductionops.is_conv env evd x y
 
-let allowK = true
-
 let refresh_hypinfo env sigma hypinfo =
   if hypinfo.abs = None then
-    let {l2r=l2r; c=c;cl=cl} = hypinfo in
+    let {l2r=l2r; c=c;cl=cl;flags=flags} = hypinfo in
       match c with
 	| Some c ->
 	    (* Refresh the clausenv to not get the same meta twice in the goal. *)
-	    decompose_applied_relation env cl.evd c l2r;
+	    decompose_applied_relation_expr env sigma flags c l2r;
 	| _ -> hypinfo
   else hypinfo
 
@@ -342,19 +363,13 @@ let unify_eqn env sigma hypinfo t =
     let env', prf, c1, c2, car, rel =
       match abs with
       | Some (absprf, absprfty) ->
-	  let env' = clenv_unify allowK ~flags:rewrite_unif_flags CONV left t cl in
+	  let env' = clenv_unify ~flags:rewrite_unif_flags CONV left t cl in
 	    env', prf, c1, c2, car, rel
       | None ->
-	  let env' =
-	    try clenv_unify allowK ~flags:rewrite_unif_flags CONV left t cl
-	    with Pretype_errors.PretypeError _ ->
-	      (* For Ring essentially, only when doing setoid_rewrite *)
-	      clenv_unify allowK ~flags:rewrite2_unif_flags CONV left t cl
-	  in
-	  let env' =
-	    let mvs = clenv_dependent false env' in
-	      clenv_pose_metas_as_evars env' mvs
+	  let env' = clenv_unify ~flags:!hypinfo.flags CONV left t cl
 	  in
+	  let env' = Clenvtac.clenv_pose_dependent_evars true env' in
+(* 	  let env' = Clenv.clenv_pose_metas_as_evars env' (Evd.undefined_metas env'.evd) in *)
 	  let evd' = Typeclasses.resolve_typeclasses ~fail:true env'.env env'.evd in
 	  let env' = { env' with evd = evd' } in
 	  let nf c = Evarutil.nf_evar evd' (Clenv.clenv_nf_meta env' c) in
@@ -365,34 +380,83 @@ let unify_eqn env sigma hypinfo t =
 	  and ty2 = Typing.type_of env'.env env'.evd c2
 	  in
 	    if convertible env env'.evd ty1 ty2 then (
-	      if occur_meta prf then
-		hypinfo := refresh_hypinfo env sigma !hypinfo;
+	      if occur_meta_or_existential prf then
+		hypinfo := refresh_hypinfo env env'.evd !hypinfo;
 	      env', prf, c1, c2, car, rel)
 	    else raise Reduction.NotConvertible
     in
     let res =
       if l2r then (prf, (car, rel, c1, c2))
       else
-	try (mkApp (get_symmetric_proof env Evd.empty car rel,
+	try (mkApp (get_symmetric_proof env env'.evd car rel,
 		   [| c1 ; c2 ; prf |]),
 	    (car, rel, c2, c1))
 	with Not_found ->
 	  (prf, (car, inverse car rel, c2, c1))
-    in Some (env', res)
+    in Some (env'.evd, res)
   with e when Class_tactics.catchable e -> None
 
+(* let unify_eqn env sigma hypinfo t = *)
+(*   if isEvar t then None *)
+(*   else try *)
+(*     let {cl=cl; prf=prf; car=car; rel=rel; l2r=l2r; c1=c1; c2=c2; c=c; abs=abs} = !hypinfo in *)
+(*     let left = if l2r then c1 else c2 in *)
+(*     let evd', prf, c1, c2, car, rel = *)
+(*       match abs with *)
+(*       | Some (absprf, absprfty) -> *)
+(* 	  let env' = clenv_unify allowK ~flags:rewrite_unif_flags CONV left t cl in *)
+(* 	    env'.evd, prf, c1, c2, car, rel *)
+(*       | None -> *)
+(* 	  let cl' = Clenv.clenv_pose_metas_as_evars cl (Evd.undefined_metas cl.evd) in *)
+(* 	  let sigma = cl'.evd in *)
+(* 	  let c1 = Clenv.clenv_nf_meta cl' c1 *)
+(* 	  and c2 = Clenv.clenv_nf_meta cl' c2 *)
+(* 	  and prf = Clenv.clenv_nf_meta cl' prf *)
+(* 	  and car = Clenv.clenv_nf_meta cl' car *)
+(* 	  and rel = Clenv.clenv_nf_meta cl' rel *)
+(* 	  in *)
+(* 	  let sigma' = *)
+(* 	    try Evarconv.the_conv_x ~ts:empty_transparent_state env t c1 sigma *)
+(* 	    with Reduction.NotConvertible _ ->  *)
+(* 	      Evarconv.the_conv_x ~ts:conv_transparent_state env t c1 sigma *)
+(* 	  in *)
+(* 	  let sigma' = Evarconv.consider_remaining_unif_problems ~ts:conv_transparent_state env sigma' in *)
+(* 	  let evd' = Typeclasses.resolve_typeclasses ~fail:true env sigma' in *)
+(* 	  let nf c = Evarutil.nf_evar evd' c in *)
+(* 	  let c1 = nf c1 and c2 = nf c2 *)
+(* 	  and car = nf car and rel = nf rel *)
+(* 	  and prf' = nf prf in *)
+(* 	    if occur_meta_or_existential prf then *)
+(* 	      hypinfo := refresh_hypinfo env evd' !hypinfo; *)
+(* 	    evd', prf', c1, c2, car, rel *)
+(*     in *)
+(*     let res = *)
+(*       if l2r then (prf, (car, rel, c1, c2)) *)
+(*       else *)
+(* 	try (mkApp (get_symmetric_proof env Evd.empty car rel, *)
+(* 		   [| c1 ; c2 ; prf |]), *)
+(* 	    (car, rel, c2, c1)) *)
+(* 	with Not_found -> *)
+(* 	  (prf, (car, inverse car rel, c2, c1)) *)
+(*     in Some (evd', res) *)
+(*   with Reduction.NotConvertible -> None *)
+(*   | e when Class_tactics.catchable e -> None *)
+
 let unfold_impl t =
   match kind_of_term t with
     | App (arrow, [| a; b |])(*  when eq_constr arrow (Lazy.force impl) *) ->
 	mkProd (Anonymous, a, lift 1 b)
     | _ -> assert false
 
-let unfold_id t =
+let unfold_all t =
   match kind_of_term t with
-    | App (id, [| a; b |]) (* when eq_constr id (Lazy.force coq_id) *) -> b
+    | App (id, [| a; b |]) (* when eq_constr id (Lazy.force coq_all) *) ->
+	(match kind_of_term b with
+	  | Lambda (n, ty, b) -> mkProd (n, ty, b)
+	  | _ -> assert false)
     | _ -> assert false
 
-let unfold_all t =
+let unfold_forall t =
   match kind_of_term t with
     | App (id, [| a; b |]) (* when eq_constr id (Lazy.force coq_all) *) ->
 	(match kind_of_term b with
@@ -400,9 +464,6 @@ let unfold_all t =
 	  | _ -> assert false)
     | _ -> assert false
 
-let decomp_prod env evm n c =
-  snd (Reductionops.splay_prod_n env evm n c)
-
 let rec decomp_pointwise n c =
   if n = 0 then c
   else
@@ -430,31 +491,35 @@ let pointwise_or_dep_relation n t car rel =
     mkApp (Lazy.force forall_relation, 
 	  [| t; mkLambda (n, t, car); mkLambda (n, t, rel) |])
 
-let lift_cstr env sigma evars (args : constr list) ty cstr =
+let lift_cstr env sigma evars (args : constr list) c ty cstr =
   let start env car =
     match cstr with
     | None | Some (_, None) ->
 	Evarutil.e_new_evar evars env (mk_relation car)
     | Some (ty, Some rel) -> rel
   in
-  let rec aux env prod n args = 
-    if n = 0 then Some (start env prod)
+  let rec aux env prod n = 
+    if n = 0 then start env prod
     else
       match kind_of_term (Reduction.whd_betadeltaiota env prod) with
       | Prod (na, ty, b) ->
 	  if noccurn 1 b then
 	    let b' = lift (-1) b in
-	    let rb = aux env b' (pred n) (List.tl args) in
-	      Option.map (fun rb -> mkApp (Lazy.force pointwise_relation, [| ty; b'; rb |]))
-		rb
+	    let rb = aux env b' (pred n) in
+	      mkApp (Lazy.force pointwise_relation, [| ty; b'; rb |])
 	  else
-	    let rb = aux (Environ.push_rel (na, None, ty) env) b (pred n) (List.tl args) in
-	      Option.map 
-		(fun rb -> mkApp (Lazy.force forall_relation, 
-				  [| ty; mkLambda (na, ty, b); mkLambda (na, ty, rb) |]))
-		rb
-      | _ -> None
-  in Option.map (fun rel -> (ty, rel)) (aux env ty (List.length args) args)
+	    let rb = aux (Environ.push_rel (na, None, ty) env) b (pred n) in
+	      mkApp (Lazy.force forall_relation, 
+		    [| ty; mkLambda (na, ty, b); mkLambda (na, ty, rb) |])
+      | _ -> raise Not_found
+  in 
+  let rec find env c ty = function
+    | [] -> None
+    | arg :: args ->
+	try Some (aux env ty (succ (List.length args)), c, ty, arg :: args)
+	with Not_found ->
+	  find env (mkApp (c, [| arg |])) (prod_applist ty [arg]) args
+  in find env c ty args
 
 let unlift_cstr env sigma = function
   | None -> None
@@ -470,7 +535,7 @@ type rewrite_proof =
   | RewPrf of constr * constr
   | RewCast of cast_kind
 
-let get_rew_rel = function RewPrf (rel, prf) -> Some rel | _ -> None
+let get_opt_rew_rel = function RewPrf (rel, prf) -> Some rel | _ -> None
 
 type rewrite_result_info = {
   rew_car : constr;
@@ -482,16 +547,21 @@ type rewrite_result_info = {
 
 type rewrite_result = rewrite_result_info option
 
-type strategy = Environ.env -> evar_map -> constr -> types ->
+type strategy = Environ.env -> identifier list -> constr -> types ->
   constr option -> evars -> rewrite_result option
 
+let get_rew_rel r = match r.rew_prf with
+  | RewPrf (rel, prf) -> rel
+  | RewCast c -> mkApp (Coqlib.build_coq_eq (), [| r.rew_car; r.rew_from; r.rew_to |])
+
 let get_rew_prf r = match r.rew_prf with
-  | RewPrf (rel, prf) -> prf 
+  | RewPrf (rel, prf) -> rel, prf 
   | RewCast c ->
-      mkCast (mkApp (Coqlib.build_coq_eq_refl (), [| r.rew_car; r.rew_from |]),
-	     c, mkApp (Coqlib.build_coq_eq (), [| r.rew_car; r.rew_from; r.rew_to |]))
+    let rel = mkApp (Coqlib.build_coq_eq (), [| r.rew_car |]) in
+      rel, mkCast (mkApp (Coqlib.build_coq_eq_refl (), [| r.rew_car; r.rew_from |]),
+		   c, mkApp (rel, [| r.rew_from; r.rew_to |]))
 
-let resolve_subrelation env sigma car rel prf rel' res =
+let resolve_subrelation env avoid car rel prf rel' res =
   if eq_constr rel rel' then res
   else
 (*   try let evd' = Evarconv.the_conv_x env rel rel' res.rew_evars in *)
@@ -504,15 +574,15 @@ let resolve_subrelation env sigma car rel prf rel' res =
 	rew_prf = RewPrf (rel', appsub);
 	rew_evars = evars }
 
-let resolve_morphism env sigma oldt m ?(fnewt=fun x -> x) args args' cstr evars =
+let resolve_morphism env avoid oldt m ?(fnewt=fun x -> x) args args' cstr evars =
   let evars, morph_instance, proj, sigargs, m', args, args' =
     let first = try (array_find args' (fun i b -> b <> None)) 
       with Not_found -> raise (Invalid_argument "resolve_morphism") in
     let morphargs, morphobjs = array_chop first args in
     let morphargs', morphobjs' = array_chop first args' in
     let appm = mkApp(m, morphargs) in
-    let appmtype = Typing.type_of env sigma appm in
-    let cstrs = List.map (Option.map (fun r -> r.rew_car, get_rew_rel r.rew_prf)) (Array.to_list morphobjs') in
+    let appmtype = Typing.type_of env (goalevars evars) appm in
+    let cstrs = List.map (Option.map (fun r -> r.rew_car, get_opt_rew_rel r.rew_prf)) (Array.to_list morphobjs') in
       (* Desired signature *)
     let evars, appmtype', signature, sigargs = 
       build_signature evars env appmtype cstrs cstr
@@ -540,7 +610,7 @@ let resolve_morphism env sigma oldt m ?(fnewt=fun x -> x) args args' cstr evars
 		  let evars, proof = proper_proof env evars carrier relation x in
 		    [ proof ; x ; x ] @ acc, subst, evars, sigargs, x :: typeargs'
 	      | Some r ->
-		  [ get_rew_prf r; r.rew_to; x ] @ acc, subst, evars, sigargs, r.rew_to :: typeargs')
+		  [ snd (get_rew_prf r); r.rew_to; x ] @ acc, subst, evars, sigargs, r.rew_to :: typeargs')
 	  | None ->
 	      if y <> None then error "Cannot rewrite the argument of a dependent function";
 	      x :: acc, x :: subst, evars, sigargs, x :: typeargs')
@@ -552,10 +622,10 @@ let resolve_morphism env sigma oldt m ?(fnewt=fun x -> x) args args' cstr evars
 	[ a, Some r ] -> evars, proof, a, r, oldt, fnewt newt
       | _ -> assert(false)
 
-let apply_constraint env sigma car rel prf cstr res =
+let apply_constraint env avoid car rel prf cstr res =
   match cstr with
   | None -> res
-  | Some r -> resolve_subrelation env sigma car rel prf r res
+  | Some r -> resolve_subrelation env avoid car rel prf r res
 
 let eq_env x y = x == y
 
@@ -564,29 +634,27 @@ let apply_rule hypinfo loccs : strategy =
   let is_occ occ =
     if nowhere_except_in then List.mem occ occs else not (List.mem occ occs) in
   let occ = ref 0 in
-    fun env sigma t ty cstr evars ->
-      if not (eq_env !hypinfo.cl.env env) then hypinfo := refresh_hypinfo env sigma !hypinfo;
-      let unif = unify_eqn env sigma hypinfo t in
+    fun env avoid t ty cstr evars ->
+      if not (eq_env !hypinfo.cl.env env) then
+	hypinfo := refresh_hypinfo env (goalevars evars) !hypinfo;
+      let unif = unify_eqn env (goalevars evars) hypinfo t in
 	if unif <> None then incr occ;
 	match unif with
-	| Some (env', (prf, (car, rel, c1, c2))) when is_occ !occ ->
+	| Some (evd', (prf, (car, rel, c1, c2))) when is_occ !occ ->
 	    begin
 	      if eq_constr t c2 then Some None
 	      else
-		let goalevars = Evd.evar_merge (fst evars)
-		  (Evd.undefined_evars (Evarutil.nf_evar_map env'.evd))
-		in
 		let res = { rew_car = ty; rew_from = c1;
-			    rew_to = c2; rew_prf = RewPrf (rel, prf); rew_evars = goalevars, snd evars }
-		in Some (Some (apply_constraint env sigma car rel prf cstr res))
+			    rew_to = c2; rew_prf = RewPrf (rel, prf); 
+			    rew_evars = evd', cstrevars evars }
+		in Some (Some (apply_constraint env avoid car rel prf cstr res))
 	    end
 	| _ -> None
 
-let apply_lemma (evm,c) left2right loccs : strategy =
-  fun env sigma ->
-    let evars = Evd.merge sigma evm in
-    let hypinfo = ref (decompose_applied_relation env evars c left2right) in
-      apply_rule hypinfo loccs env sigma
+let apply_lemma flags (evm,c) left2right loccs : strategy =
+  fun env avoid t ty cstr evars ->
+    let hypinfo = ref (decompose_applied_relation env (goalevars evars) flags None c left2right) in
+      apply_rule hypinfo loccs env avoid t ty cstr evars
 
 let make_leibniz_proof c ty r =
   let prf = 
@@ -658,9 +726,15 @@ let unfold_match env sigma sk app =
       let v = Environ.constant_value (Global.env ()) sk in
 	Reductionops.whd_beta sigma (mkApp (v, args))
   | _ -> app
-    
+
+let is_rew_cast = function RewCast _ -> true | _ -> false
+
+let coerce env avoid cstr res = 
+  let rel, prf = get_rew_prf res in
+    apply_constraint env avoid res.rew_car rel prf cstr res
+
 let subterm all flags (s : strategy) : strategy =
-  let rec aux env sigma t ty cstr evars =
+  let rec aux env avoid t ty cstr evars =
     let cstr' = Option.map (fun c -> (ty, Some c)) cstr in
       match kind_of_term t with
       | App (m, args) ->
@@ -670,7 +744,7 @@ let subterm all flags (s : strategy) : strategy =
 		(fun (acc, evars, progress) arg ->
 		  if progress <> None && not all then (None :: acc, evars, progress)
 		  else
-		    let res = s env sigma arg (Typing.type_of env sigma arg) None evars in
+		    let res = s env avoid arg (Typing.type_of env (goalevars evars) arg) None evars in
 		      match res with
 		      | Some None -> (None :: acc, evars, if progress = None then Some false else progress)
 		      | Some (Some r) -> (Some r :: acc, r.rew_evars, Some true)
@@ -682,19 +756,38 @@ let subterm all flags (s : strategy) : strategy =
 	      | Some false -> Some None
 	      | Some true ->
 		  let args' = Array.of_list (List.rev args') in
-		  let evars', prf, car, rel, c1, c2 = resolve_morphism env sigma t m args args' cstr' evars' in
-		  let res = { rew_car = ty; rew_from = c1;
-			      rew_to = c2; rew_prf = RewPrf (rel, prf);
-			      rew_evars = evars' } 
-		  in
-		    Some (Some res)
+		    if array_exists
+		      (function 
+			 | None -> false 
+			 | Some r -> not (is_rew_cast r.rew_prf)) args'
+		    then
+		      let evars', prf, car, rel, c1, c2 = resolve_morphism env avoid t m args args' cstr' evars' in
+		      let res = { rew_car = ty; rew_from = c1;
+				  rew_to = c2; rew_prf = RewPrf (rel, prf);
+				  rew_evars = evars' } 
+		      in Some (Some res)
+		    else 
+		      let args' = array_map2
+			(fun aorig anew ->
+			   match anew with None -> aorig
+			   | Some r -> r.rew_to) args args' 
+		      in
+		      let res = { rew_car = ty; rew_from = t;
+				  rew_to = mkApp (m, args'); rew_prf = RewCast DEFAULTcast;
+				  rew_evars = evars' }
+		      in Some (Some res)
+
 	  in
 	    if flags.on_morphisms then
 	      let evarsref = ref (snd evars) in
-	      let mty = Typing.type_of env sigma m in
-	      let argsl = Array.to_list args in
-	      let cstr' = lift_cstr env sigma evarsref argsl mty None in
-	      let m' = s env sigma m mty (Option.map snd cstr') (fst evars, !evarsref) in
+	      let mty = Typing.type_of env (goalevars evars) m in
+	      let cstr', m, mty, argsl, args = 
+		let argsl = Array.to_list args in
+		  match lift_cstr env (goalevars evars) evarsref argsl m mty None with
+		  | Some (cstr', m, mty, args) -> Some cstr', m, mty, args, Array.of_list args
+		  | None -> None, m, mty, argsl, args
+	      in
+	      let m' = s env avoid m mty cstr' (fst evars, !evarsref) in
 		match m' with
 		| None -> rewrite_args None (* Standard path, try rewrite on arguments *)
 		| Some None -> rewrite_args (Some false)
@@ -714,14 +807,14 @@ let subterm all flags (s : strategy) : strategy =
 		    in 
 		      match prf with
 		      | RewPrf (rel, prf) ->
-			  Some (Some (apply_constraint env sigma res.rew_car rel prf cstr res))
+			Some (Some (apply_constraint env avoid res.rew_car rel prf cstr res))
 		      | _ -> Some (Some res)
 	    else rewrite_args None
-
+	      
       | Prod (n, x, b) when noccurn 1 b ->
 	  let b = subst1 mkProp b in
-	  let tx = Typing.type_of env sigma x and tb = Typing.type_of env sigma b in
-	  let res = aux env sigma (mkApp (arrow_morphism tx tb, [| x; b |])) ty cstr evars in
+	  let tx = Typing.type_of env (goalevars evars) x and tb = Typing.type_of env (goalevars evars) b in
+	  let res = aux env avoid (mkApp (arrow_morphism tx tb, [| x; b |])) ty cstr evars in
 	    (match res with
 	    | Some (Some r) -> Some (Some { r with rew_to = unfold_impl r.rew_to })
 	    | _ -> res)
@@ -740,22 +833,28 @@ let subterm all flags (s : strategy) : strategy =
       (* 		  in res, occ *)
       (* 		else *)
 
-      | Prod (n, dom, codom) when eq_constr ty mkProp ->
+      | Prod (n, dom, codom) ->
 	  let lam = mkLambda (n, dom, codom) in
-	  let res = aux env sigma (mkApp (Lazy.force coq_all, [| dom; lam |])) ty cstr evars in
+	  let app, unfold = 
+	    if eq_constr ty mkProp then
+	      mkApp (Lazy.force coq_all, [| dom; lam |]), unfold_all
+	    else mkApp (Lazy.force coq_forall, [| dom; lam |]), unfold_forall
+	  in
+	  let res = aux env avoid app ty cstr evars in
 	    (match res with
-	    | Some (Some r) -> Some (Some { r with rew_to = unfold_all r.rew_to })
-	    | _ -> res)
+	     | Some (Some r) -> Some (Some { r with rew_to = unfold r.rew_to })
+	     | _ -> res)
 
       | Lambda (n, t, b) when flags.under_lambdas ->
-	  let env' = Environ.push_rel (n, None, t) env in
-	  let b' = s env' sigma b (Typing.type_of env' sigma b) (unlift_cstr env sigma cstr) evars in
+	  let n' = name_app (fun id -> Tactics.fresh_id_in_env avoid id env) n in
+	  let env' = Environ.push_rel (n', None, t) env in
+	  let b' = s env' avoid b (Typing.type_of env' (goalevars evars) b) (unlift_cstr env (goalevars evars) cstr) evars in
 	    (match b' with
 	    | Some (Some r) ->
 		let prf = match r.rew_prf with
 		  | RewPrf (rel, prf) ->
-		      let rel = pointwise_or_dep_relation n t r.rew_car rel in
-		      let prf = mkLambda (n, t, prf) in
+		      let rel = pointwise_or_dep_relation n' t r.rew_car rel in
+		      let prf = mkLambda (n', t, prf) in
 			RewPrf (rel, prf)
 		  | x -> x
 		in
@@ -767,38 +866,47 @@ let subterm all flags (s : strategy) : strategy =
 	    | _ -> b')
 
       | Case (ci, p, c, brs) ->
-	  let cty = Typing.type_of env sigma c in
+	  let cty = Typing.type_of env (goalevars evars) c in
 	  let cstr' = Some (mkApp (Lazy.force coq_eq, [| cty |])) in
-	  let c' = s env sigma c cty cstr' evars in
-	    (match c' with
+	  let c' = s env avoid c cty cstr' evars in
+	  let res = 
+	    match c' with
 	    | Some (Some r) ->
-		Some (Some (make_leibniz_proof (mkCase (ci, lift 1 p, mkRel 1, Array.map (lift 1) brs)) ty r))
+		let res = make_leibniz_proof (mkCase (ci, lift 1 p, mkRel 1, Array.map (lift 1) brs)) ty r in
+		  Some (Some (coerce env avoid cstr res))
 	    | x ->
-		if array_for_all ((=) 0) ci.ci_cstr_nargs then
-		  let cstr = Some (mkApp (Lazy.force coq_eq, [| ty |])) in
-		  let found, brs' = Array.fold_left (fun (found, acc) br ->
-		    if found <> None then (found, fun x -> lift 1 br :: acc x)
-		    else
-		      match s env sigma br ty cstr evars with
-		      | Some (Some r) -> (Some r, fun x -> mkRel 1 :: acc x)
-		      | _ -> (None, fun x -> lift 1 br :: acc x))
-		    (None, fun x -> []) brs
-		  in
-		    match found with
-		    | Some r ->
-			let ctxc = mkCase (ci, lift 1 p, lift 1 c, Array.of_list (List.rev (brs' x))) in
-			  Some (Some (make_leibniz_proof ctxc ty r))
-		    | None -> x
-		else
-		  match try Some (fold_match env sigma t) with Not_found -> None with
+	      if array_for_all ((=) 0) ci.ci_cstr_ndecls then
+		let cstr = Some (mkApp (Lazy.force coq_eq, [| ty |])) in
+		let found, brs' = Array.fold_left 
+		  (fun (found, acc) br ->
+		   if found <> None then (found, fun x -> lift 1 br :: acc x)
+		   else
+		     match s env avoid br ty cstr evars with
+		     | Some (Some r) -> (Some r, fun x -> mkRel 1 :: acc x)
+		     | _ -> (None, fun x -> lift 1 br :: acc x))
+		  (None, fun x -> []) brs
+		in
+		  match found with
+		  | Some r ->
+		    let ctxc = mkCase (ci, lift 1 p, lift 1 c, Array.of_list (List.rev (brs' x))) in
+		      Some (Some (make_leibniz_proof ctxc ty r))
 		  | None -> x
-		  | Some (cst, _, t') ->
-		      match aux env sigma t' ty cstr evars with
-		      | Some (Some prf) -> Some (Some { prf with
-			  rew_from = t; rew_to = unfold_match env sigma cst prf.rew_to })
-		      | x' -> x)
-
-      | _ -> if all then Some None else None
+	      else
+		match try Some (fold_match env (goalevars evars) t) with Not_found -> None with
+		| None -> x
+		| Some (cst, _, t') ->
+		  match aux env avoid t' ty cstr evars with
+		  | Some (Some prf) -> 
+		    Some (Some { prf with
+				 rew_from = t; rew_to = unfold_match env (goalevars evars) cst prf.rew_to })
+		  | x' -> x
+	  in 
+	    (match res with
+	     | Some (Some r) ->  
+	       let rel, prf = get_rew_prf r in
+		 Some (Some (apply_constraint env avoid r.rew_car rel prf cstr r))
+	     | x -> x)
+      | _ -> None
   in aux
 
 let all_subterms = subterm true default_flags
@@ -807,8 +915,8 @@ let one_subterm = subterm false default_flags
 (** Requires transitivity of the rewrite step, if not a reduction.
     Not tail-recursive. *)
 
-let transitivity env sigma (res : rewrite_result_info) (next : strategy) : rewrite_result option =
-  match next env sigma res.rew_to res.rew_car (get_rew_rel res.rew_prf) res.rew_evars with
+let transitivity env avoid (res : rewrite_result_info) (next : strategy) : rewrite_result option =
+  match next env avoid res.rew_to res.rew_car (get_opt_rew_rel res.rew_prf) res.rew_evars with
   | None -> None
   | Some None -> Some (Some res)
   | Some (Some res') ->
@@ -835,13 +943,13 @@ module Strategies =
   struct
 
     let fail : strategy =
-      fun env sigma t ty cstr evars -> None
+      fun env avoid t ty cstr evars -> None
 
     let id : strategy =
-      fun env sigma t ty cstr evars -> Some None
+      fun env avoid t ty cstr evars -> Some None
 
     let refl : strategy =
-      fun env sigma t ty cstr evars ->
+      fun env avoid t ty cstr evars ->
 	let evars, rel = match cstr with
 	  | None -> new_cstr_evar evars env (mk_relation ty)
 	  | Some r -> evars, r
@@ -854,23 +962,23 @@ module Strategies =
 		       rew_prf = RewPrf (rel, proof); rew_evars = evars })
 
     let progress (s : strategy) : strategy =
-      fun env sigma t ty cstr evars ->
-	match s env sigma t ty cstr evars with
+      fun env avoid t ty cstr evars ->
+	match s env avoid t ty cstr evars with
 	| None -> None
 	| Some None -> None
 	| r -> r
 
     let seq fst snd : strategy =
-      fun env sigma t ty cstr evars ->
-	match fst env sigma t ty cstr evars with
+      fun env avoid t ty cstr evars ->
+	match fst env avoid t ty cstr evars with
 	| None -> None
-	| Some None -> snd env sigma t ty cstr evars
-	| Some (Some res) -> transitivity env sigma res snd
+	| Some None -> snd env avoid t ty cstr evars
+	| Some (Some res) -> transitivity env avoid res snd
 
     let choice fst snd : strategy =
-      fun env sigma t ty cstr evars ->
-	match fst env sigma t ty cstr evars with
-	| None -> snd env sigma t ty cstr evars
+      fun env avoid t ty cstr evars ->
+	match fst env avoid t ty cstr evars with
+	| None -> snd env avoid t ty cstr evars
 	| res -> res
 
     let try_ str : strategy = choice str id
@@ -896,33 +1004,51 @@ module Strategies =
     let outermost (s : strategy) : strategy =
       fix (fun out -> choice s (one_subterm out))
 
-    let lemmas cs : strategy =
+    let lemmas flags cs : strategy =
       List.fold_left (fun tac (l,l2r) ->
-	choice tac (apply_lemma l l2r (false,[])))
+	choice tac (apply_lemma flags l l2r (false,[])))
 	fail cs
 
     let inj_open c = (Evd.empty,c)
 
     let old_hints (db : string) : strategy =
       let rules = Autorewrite.find_rewrites db in
-	lemmas (List.map (fun hint -> (inj_open (hint.Autorewrite.rew_lemma, NoBindings), hint.Autorewrite.rew_l2r)) rules)
+	lemmas rewrite_unif_flags
+	  (List.map (fun hint -> (inj_open (hint.Autorewrite.rew_lemma, NoBindings), hint.Autorewrite.rew_l2r)) rules)
 
     let hints (db : string) : strategy =
-      fun env sigma t ty cstr evars ->
+      fun env avoid t ty cstr evars ->
       let rules = Autorewrite.find_matches db t in
-	lemmas (List.map (fun hint -> (inj_open (hint.Autorewrite.rew_lemma, NoBindings), hint.Autorewrite.rew_l2r)) rules)
-	  env sigma t ty cstr evars
+      let lemma hint = (inj_open (hint.Autorewrite.rew_lemma, NoBindings), hint.Autorewrite.rew_l2r) in
+      let lems = List.map lemma rules in
+	lemmas rewrite_unif_flags lems env avoid t ty cstr evars
 
     let reduce (r : Redexpr.red_expr) : strategy =
       let rfn, ckind = Redexpr.reduction_of_red_expr r in
-	fun env sigma t ty cstr evars ->
-	  let t' = rfn env sigma t in
+	fun env avoid t ty cstr evars ->
+	  let t' = rfn env (goalevars evars) t in
 	    if eq_constr t' t then
 	      Some None
 	    else
 	      Some (Some { rew_car = ty; rew_from = t; rew_to = t';
 			   rew_prf = RewCast ckind; rew_evars = evars })
-	  
+	
+    let fold c : strategy =
+      fun env avoid t ty cstr evars ->
+(* 	let sigma, (c,_) = Tacinterp.interp_open_constr_with_bindings is env (goalevars evars) c in *)
+	let sigma, c = Constrintern.interp_open_constr (goalevars evars) env c in
+	let unfolded =
+	  try Tacred.try_red_product env sigma c
+	  with _ -> error "fold: the term is not unfoldable !"
+	in
+	  try
+	    let sigma = Unification.w_unify env sigma CONV ~flags:Unification.elim_flags unfolded t in
+	    let c' = Evarutil.nf_evar sigma c in
+	      Some (Some { rew_car = ty; rew_from = t; rew_to = c';
+			   rew_prf = RewCast DEFAULTcast; 
+			   rew_evars = sigma, cstrevars evars })
+	  with _ -> None
+  
 
 end
 
@@ -934,49 +1060,34 @@ let rewrite_strat flags occs hyp =
     Strategies.choice app (subterm true flags (fun env -> aux () env))
   in aux ()
 
-let rewrite_with {it = c; sigma = evm} left2right loccs : strategy =
-  fun env sigma ->
-    let evars = Evd.merge sigma evm in
-    let hypinfo = ref (decompose_applied_relation env evars c left2right) in
-      rewrite_strat default_flags loccs hypinfo env sigma
+let get_hypinfo_ids {c = opt} =
+  match opt with
+  | None -> []
+  | Some (is, gc) -> List.map fst is.lfun @ is.avoid_ids
 
-let apply_strategy (s : strategy) env sigma concl cstr evars =
+let rewrite_with flags c left2right loccs : strategy =
+  fun env avoid t ty cstr evars ->
+    let gevars = goalevars evars in
+    let hypinfo = ref (decompose_applied_relation_expr env gevars flags c left2right) in
+    let avoid = get_hypinfo_ids !hypinfo @ avoid in
+      rewrite_strat default_flags loccs hypinfo env avoid t ty cstr (gevars, cstrevars evars)
+
+let apply_strategy (s : strategy) env avoid concl cstr evars =
   let res =
-    s env sigma concl (Typing.type_of env sigma concl)
-      (Option.map snd cstr) !evars
+    s env avoid
+ concl (Typing.type_of env (goalevars evars) concl)
+      (Option.map snd cstr) evars
   in
     match res with
     | None -> None
     | Some None -> Some None
     | Some (Some res) ->
-	evars := res.rew_evars;
-	Some (Some (res.rew_prf, (res.rew_car, res.rew_from, res.rew_to)))
-
-let split_evars_once sigma evd =
-  Evd.fold (fun ev evi deps ->
-    if Intset.mem ev deps then
-      Intset.union (Class_tactics.evars_of_evi evi) deps
-    else deps) evd sigma
-
-let existentials_of_evd evd =
-  Evd.fold (fun ev evi acc -> Intset.add ev acc) evd Intset.empty
-
-let evd_of_existentials evd exs =
-  Intset.fold (fun i acc ->
-    let evi = Evd.find evd i in
-      Evd.add acc i evi) exs Evd.empty
-
-let split_evars sigma evd =
-  let rec aux deps =
-    let deps' = split_evars_once deps evd in
-      if Intset.equal deps' deps then
-	evd_of_existentials evd deps
-      else aux deps'
-  in aux (existentials_of_evd sigma)
+	Some (Some (res.rew_prf, res.rew_evars, res.rew_car, res.rew_from, res.rew_to))
 
 let merge_evars (goal,cstr) = Evd.merge goal cstr
 let solve_constraints env evars =
-  Typeclasses.resolve_typeclasses env ~split:false ~fail:true (merge_evars evars)
+  Typeclasses.resolve_typeclasses env ~split:false ~fail:true
+    (merge_evars evars)
 
 let nf_zeta =
   Reductionops.clos_norm_flags (Closure.RedFlags.mkflags [Closure.RedFlags.fZETA])
@@ -987,12 +1098,9 @@ let map_rewprf f = function
 
 exception RewriteFailure
 
-let cl_rewrite_clause_aux ?(abs=None) strat goal_meta clause gl =
-  let concl, is_hyp =
-    match clause with
-	Some id -> pf_get_hyp_typ gl id, Some id
-      | None -> pf_concl gl, None
-  in
+type result = (evar_map * constr option * types) option option
+
+let cl_rewrite_clause_aux ?(abs=None) strat env avoid sigma concl is_hyp : result =
   let cstr =
     let sort = mkProp in
     let impl = Lazy.force impl in
@@ -1000,82 +1108,205 @@ let cl_rewrite_clause_aux ?(abs=None) strat goal_meta clause gl =
       | None -> (sort, inverse sort impl)
       | Some _ -> (sort, impl)
   in
-  let sigma = project gl in
-  let evars = ref (Evd.create_evar_defs sigma, Evd.empty) in
-  let env = pf_env gl in
-  let eq = apply_strategy strat env sigma concl (Some cstr) evars in
+  let evars = (sigma, Evd.empty) in
+  let eq = apply_strategy strat env avoid concl (Some cstr) evars in
     match eq with
-    | Some (Some (p, (car, oldt, newt))) ->
-	(try
-	    let cstrevars = !evars in
-	    let evars = solve_constraints env cstrevars in
-	    let p = map_rewprf 
-	      (fun p -> nf_zeta env evars (Evarutil.nf_evar evars p)) 
-	      p 
-	    in
-	    let newt = Evarutil.nf_evar evars newt in
-	    let abs = Option.map (fun (x, y) ->
-	      Evarutil.nf_evar evars x, Evarutil.nf_evar evars y) abs in
-	    let undef = split_evars (fst cstrevars) evars in
-	    let rewtac =
-	      match is_hyp with
-	      | Some id ->
-		  (match p with
-		  | RewPrf (rel, p) ->
-		      let term =
-			match abs with
-			| None -> p
-			| Some (t, ty) ->
-			    mkApp (mkLambda (Name (id_of_string "lemma"), ty, p), [| t |])
-		      in
-			cut_replacing id newt
-			  (Tacmach.refine_no_check (mkApp (term, [| mkVar id |])))
-		  | RewCast c ->
-		      change_in_hyp None newt (id, InHypTypeOnly))
-		    
-	      | None ->
-		  (match p with
-		  | RewPrf (rel, p) ->
-		      (match abs with
-		      | None ->
-			  let name = next_name_away_with_default "H" Anonymous (pf_ids_of_hyps gl) in
-			    tclTHENLAST
-			      (Tacmach.internal_cut_no_check false name newt)
-			      (tclTHEN (Tactics.revert [name]) (Tacmach.refine_no_check p))
-		      | Some (t, ty) ->
-			  Tacmach.refine_no_check
-			    (mkApp (mkLambda (Name (id_of_string "newt"), newt,
-					     mkLambda (Name (id_of_string "lemma"), ty,
-						      mkApp (p, [| mkRel 2 |]))),
-				   [| mkMeta goal_meta; t |])))
-		  | RewCast c -> 
-		      change_in_concl None newt)
-	    in
-	    let evartac =
-	      if not (undef = Evd.empty) then
-		Refiner.tclEVARS undef
-	      else tclIDTAC
-	    in tclTHENLIST [evartac; rewtac] gl
-	  with
-	  | Stdpp.Exc_located (_, TypeClassError (env, (UnsatisfiableConstraints _ as e)))
-	  | TypeClassError (env, (UnsatisfiableConstraints _ as e)) ->
-	      Refiner.tclFAIL_lazy 0
-		(lazy (str"setoid rewrite failed: unable to satisfy the rewriting constraints."
-			++ fnl () ++ Himsg.explain_typeclass_error env e)) gl)
+    | Some (Some (p, evars, car, oldt, newt)) ->
+	let evars' = solve_constraints env evars in
+	let p = map_rewprf (fun p -> nf_zeta env evars' (Evarutil.nf_evar evars' p)) p in
+	let newt = Evarutil.nf_evar evars' newt in
+	let abs = Option.map (fun (x, y) ->
+				Evarutil.nf_evar evars' x, Evarutil.nf_evar evars' y) abs in
+	let evars = (* Keep only original evars (potentially instantiated) and goal evars,
+		       the rest has been defined and substituted already. *)
+(* 	  let cstrs = cstrevars evars in *)
+	    (* cstrs is small *)
+	  let gevars = goalevars evars in
+	    Evd.fold (fun ev evi acc -> 
+			if Evd.mem gevars ev then Evd.add acc ev evi
+			else acc) evars' Evd.empty
+(* 	    Evd.fold (fun ev evi acc -> Evd.remove acc ev) cstrs evars' *)
+	in
+	let res =
+	  match is_hyp with
+	  | Some id ->
+	      (match p with
+	       | RewPrf (rel, p) ->
+		   let term =
+		     match abs with
+		     | None -> p
+		     | Some (t, ty) ->
+			 mkApp (mkLambda (Name (id_of_string "lemma"), ty, p), [| t |])
+		   in
+		     Some (evars, Some (mkApp (term, [| mkVar id |])), newt)
+	       | RewCast c ->
+		   Some (evars, None, newt))
+		
+	  | None ->
+	      (match p with
+	       | RewPrf (rel, p) ->
+		   (match abs with
+		    | None -> Some (evars, Some p, newt)
+		    | Some (t, ty) ->
+			let proof = mkApp (mkLambda (Name (id_of_string "lemma"), ty, p), [| t |]) in
+			  Some (evars, Some proof, newt))
+	       | RewCast c -> Some (evars, None, newt))
+	in Some res
+    | Some None -> Some None
+    | None -> None
+		   
+let rewrite_refine (evd,c) = 
+  Tacmach.refine c
+
+let cl_rewrite_clause_tac ?abs strat meta clause gl =
+  let evartac evd = Refiner.tclEVARS evd in
+  let treat res =
+    match res with
+    | None -> raise RewriteFailure
     | Some None ->
-	tclFAIL 0 (str"setoid rewrite failed: no progress made") gl
+	tclFAIL 0 (str"setoid rewrite failed: no progress made")
+    | Some (Some (undef, p, newt)) ->
+	let tac = 
+	  match clause, p with
+	  | Some id, Some p ->
+	      cut_replacing id newt (Tacmach.refine p)
+	  | Some id, None -> 
+	      change_in_hyp None newt (id, InHypTypeOnly)
+	  | None, Some p ->
+	      let name = next_name_away_with_default "H" Anonymous (pf_ids_of_hyps gl) in
+		tclTHENLAST
+		  (Tacmach.internal_cut_no_check false name newt)
+		  (tclTHEN (Tactics.revert [name]) (Tacmach.refine p))
+	  | None, None -> change_in_concl None newt
+	in tclTHEN (evartac undef) tac
+  in
+  let tac =
+    try
+      let concl, is_hyp =
+	match clause with
+	| Some id -> pf_get_hyp_typ gl id, Some id
+	| None -> pf_concl gl, None
+      in
+      let sigma = project gl in
+      let concl = Evarutil.nf_evar sigma concl in 
+      let res = cl_rewrite_clause_aux ?abs strat (pf_env gl) [] sigma concl is_hyp in
+	treat res
+    with
+    | Loc.Exc_located (_, TypeClassError (env, (UnsatisfiableConstraints _ as e)))
+    | TypeClassError (env, (UnsatisfiableConstraints _ as e)) ->
+	Refiner.tclFAIL_lazy 0
+	  (lazy (str"setoid rewrite failed: unable to satisfy the rewriting constraints."
+		 ++ fnl () ++ Himsg.explain_typeclass_error env e))
+  in tac gl
+
+open Goal
+open Environ
+
+let bind_gl_info f =
+  bind concl (fun c -> bind env (fun v -> bind defs (fun ev -> f c v ev))) 
+
+let fail l s =
+  raise (Refiner.FailError (l, lazy s))
+
+let new_refine c : Goal.subgoals Goal.sensitive =
+  let refable = Goal.Refinable.make
+    (fun handle -> Goal.Refinable.constr_of_open_constr handle true c) 
+  in Goal.bind refable Goal.refine
+
+let assert_replacing id newt tac = 
+  let sens = bind_gl_info 
+    (fun concl env sigma ->
+       let nc' = 
+	 Environ.fold_named_context
+	   (fun _ (n, b, t as decl) nc' ->
+	      if n = id then (n, b, newt) :: nc'
+	      else decl :: nc')
+	   env ~init:[]
+       in
+       let reft = Refinable.make 
+	 (fun h -> 
+	    Goal.bind (Refinable.mkEvar h
+			 (Environ.reset_with_named_context (val_of_named_context nc') env) concl)
+	      (fun ev -> 
+		 Goal.bind (Refinable.mkEvar h env newt)
+		   (fun ev' ->
+		      let inst = 
+			fold_named_context
+			  (fun _ (n, b, t) inst ->
+			     if n = id then ev' :: inst
+			     else if b = None then mkVar n :: inst else inst)
+			  env ~init:[]
+		      in
+		      let (e, args) = destEvar ev in
+			Goal.return (mkEvar (e, Array.of_list inst)))))
+       in Goal.bind reft Goal.refine)
+  in Proofview.tclTHEN (Proofview.tclSENSITIVE sens) 
+       (Proofview.tclFOCUS 2 2 tac)
+
+let cl_rewrite_clause_newtac ?abs strat clause =
+  let treat (res, is_hyp) = 
+    match res with
     | None -> raise RewriteFailure
-
-let cl_rewrite_clause_strat strat clause gl =
+    | Some None ->
+	fail 0 (str"setoid rewrite failed: no progress made")
+    | Some (Some res) ->
+	match is_hyp, res with
+	| Some id, (undef, Some p, newt) ->
+	    assert_replacing id newt (Proofview.tclSENSITIVE (new_refine (undef, p)))
+	| Some id, (undef, None, newt) -> 
+	    Proofview.tclSENSITIVE (Goal.convert_hyp false (id, None, newt))
+	| None, (undef, Some p, newt) ->
+	    let refable = Goal.Refinable.make
+	      (fun handle -> 
+		 Goal.bind env
+		   (fun env -> Goal.bind (Refinable.mkEvar handle env newt)
+		      (fun ev ->
+			 Goal.Refinable.constr_of_open_constr handle true 
+			   (undef, mkApp (p, [| ev |])))))
+	    in
+	      Proofview.tclSENSITIVE (Goal.bind refable Goal.refine)
+	| None, (undef, None, newt) ->
+	    Proofview.tclSENSITIVE (Goal.convert_concl false newt)
+  in
+  let info =
+    bind_gl_info
+      (fun concl env sigma ->
+	 let ty, is_hyp =
+	   match clause with
+	   | Some id -> Environ.named_type id env, Some id
+	   | None -> concl, None
+	 in
+	 let res = 
+	   try cl_rewrite_clause_aux ?abs strat env [] sigma ty is_hyp 
+	   with
+	   | Loc.Exc_located (_, TypeClassError (env, (UnsatisfiableConstraints _ as e)))
+	   | TypeClassError (env, (UnsatisfiableConstraints _ as e)) ->
+	       fail 0 (str"setoid rewrite failed: unable to satisfy the rewriting constraints."
+		       ++ fnl () ++ Himsg.explain_typeclass_error env e)
+	 in return (res, is_hyp))
+  in Proofview.tclGOALBINDU info (fun i -> treat i)
+  
+let cl_rewrite_clause_new_strat ?abs strat clause =
   init_setoid ();
-  let meta = Evarutil.new_meta() in
-  let gl = { gl with sigma = Typeclasses.mark_unresolvables gl.sigma } in
-    try cl_rewrite_clause_aux strat meta clause gl
+    try cl_rewrite_clause_newtac ?abs strat clause
     with RewriteFailure ->
-      tclFAIL 0 (str"setoid rewrite failed: strategy failed") gl
+      fail 0 (str"setoid rewrite failed: strategy failed")
+
+let cl_rewrite_clause_newtac' l left2right occs clause =
+  Proof_global.run_tactic 
+    (Proofview.tclFOCUS 1 1 
+       (cl_rewrite_clause_new_strat (rewrite_with rewrite_unif_flags l left2right occs) clause))
+
+let cl_rewrite_clause_strat strat clause gl =
+    init_setoid ();
+    let meta = Evarutil.new_meta() in
+(*     let gl = { gl with sigma = Typeclasses.mark_unresolvables gl.sigma } in *)
+     try cl_rewrite_clause_tac strat (mkMeta meta) clause gl
+      with RewriteFailure ->
+        tclFAIL 0 (str"setoid rewrite failed: strategy failed") gl
 
 let cl_rewrite_clause l left2right occs clause gl =
-  cl_rewrite_clause_strat (rewrite_with l left2right occs) clause gl
+  cl_rewrite_clause_strat (rewrite_with (general_rewrite_unif_flags ()) l left2right occs) clause gl
 
 open Pp
 open Pcoq
@@ -1093,18 +1324,10 @@ let occurrences_of = function
 	error "Illegal negative occurrence number.";
       (true,nl)
 
-let pr_gen_strategy pr_id = Pp.mt ()
-let pr_loc_strategy _ _ _ = Pp.mt ()
-let pr_strategy _ _ _ (s : strategy) = Pp.str "<strategy>"
-
-let intern_strategy ist gl c = c
-let interp_strategy ist gl c = c
-let glob_strategy ist l = l
-let subst_strategy evm l = l
-
-let apply_constr_expr c l2r occs = fun env sigma ->
-  let evd, c = Constrintern.interp_open_constr sigma env c in
-    apply_lemma (evd, (c, NoBindings)) l2r occs env sigma
+let apply_constr_expr c l2r occs = fun env avoid t ty cstr evars ->
+  let evd, c = Constrintern.interp_open_constr (goalevars evars) env c in
+    apply_lemma (general_rewrite_unif_flags ()) (evd, (c, NoBindings)) 
+      l2r occs env avoid t ty cstr (evd, cstrevars evars)
 
 let interp_constr_list env sigma =
   List.map (fun c -> 
@@ -1113,13 +1336,49 @@ let interp_constr_list env sigma =
 
 open Pcoq
 
-let (wit_strategy, globwit_strategy, rawwit_strategy) =
+type constr_expr_with_bindings = constr_expr with_bindings
+type glob_constr_with_bindings = glob_constr_and_expr with_bindings
+type glob_constr_with_bindings_sign = interp_sign * glob_constr_and_expr with_bindings
+
+let pr_glob_constr_with_bindings_sign _ _ _ (ge : glob_constr_with_bindings_sign) = Printer.pr_glob_constr (fst (fst (snd ge)))
+let pr_glob_constr_with_bindings _ _ _ (ge : glob_constr_with_bindings) = Printer.pr_glob_constr (fst (fst ge))
+let pr_constr_expr_with_bindings prc _ _ (ge : constr_expr_with_bindings) = prc (fst ge)
+let interp_glob_constr_with_bindings ist gl c = (ist, c)
+let glob_glob_constr_with_bindings ist l = Tacinterp.intern_constr_with_bindings ist l
+let subst_glob_constr_with_bindings s c = subst_glob_with_bindings s c
+
+
+ARGUMENT EXTEND glob_constr_with_bindings 
+    PRINTED BY pr_glob_constr_with_bindings_sign
+
+    INTERPRETED BY interp_glob_constr_with_bindings
+    GLOBALIZED BY glob_glob_constr_with_bindings
+    SUBSTITUTED BY subst_glob_constr_with_bindings
+
+    RAW_TYPED AS constr_expr_with_bindings
+    RAW_PRINTED BY pr_constr_expr_with_bindings
+
+    GLOB_TYPED AS glob_constr_with_bindings
+    GLOB_PRINTED BY pr_glob_constr_with_bindings
+   
+   [ constr_with_bindings(bl) ] -> [ bl ]
+END
+
+let _ =
   (Genarg.create_arg "strategy" :
       ((strategy, Genarg.tlevel) Genarg.abstract_argument_type *
 	  (strategy, Genarg.glevel) Genarg.abstract_argument_type *
 	  (strategy, Genarg.rlevel) Genarg.abstract_argument_type))
 
 
+
+let pr_strategy _ _ _ (s : strategy) = Pp.str "<strategy>"
+
+let interp_strategy ist gl c = c
+let glob_strategy ist l = l
+let subst_strategy evm l = l
+
+
 ARGUMENT EXTEND rewstrategy TYPED AS strategy
     PRINTED BY pr_strategy
     INTERPRETED BY interp_strategy
@@ -1146,57 +1405,62 @@ ARGUMENT EXTEND rewstrategy TYPED AS strategy
   | [ "choice" rewstrategy(h) rewstrategy(h') ] -> [ Strategies.choice h h' ]
   | [ "old_hints" preident(h) ] -> [ Strategies.old_hints h ]
   | [ "hints" preident(h) ] -> [ Strategies.hints h ]
-  | [ "terms" constr_list(h) ] -> [ fun env sigma -> 
-      Strategies.lemmas (interp_constr_list env sigma h) env sigma ]
-  | [ "eval" red_expr(r) ] -> [ fun env sigma -> 
-      Strategies.reduce (Tacinterp.interp_redexp env sigma r) env sigma ]
+  | [ "terms" constr_list(h) ] -> [ fun env avoid t ty cstr evars -> 
+      Strategies.lemmas rewrite_unif_flags (interp_constr_list env (goalevars evars) h) env avoid t ty cstr evars ]
+  | [ "eval" red_expr(r) ] -> [ fun env avoid t ty cstr evars -> 
+      Strategies.reduce (Tacinterp.interp_redexp env (goalevars evars) r) env avoid t ty cstr evars ]
+  | [ "fold" constr(c) ] -> [ Strategies.fold c ]
 END
 
-TACTIC EXTEND class_rewrite
-| [ "clrewrite" orient(o) constr_with_bindings(c) "in" hyp(id) "at" occurrences(occ) ] -> [ cl_rewrite_clause c o (occurrences_of occ) (Some id) ]
-| [ "clrewrite" orient(o) constr_with_bindings(c) "at" occurrences(occ) "in" hyp(id) ] -> [ cl_rewrite_clause c o (occurrences_of occ) (Some id) ]
-| [ "clrewrite" orient(o) constr_with_bindings(c) "in" hyp(id) ] -> [ cl_rewrite_clause c o all_occurrences (Some id) ]
-| [ "clrewrite" orient(o) constr_with_bindings(c) "at" occurrences(occ) ] -> [ cl_rewrite_clause c o (occurrences_of occ) None ]
-| [ "clrewrite" orient(o) constr_with_bindings(c) ] -> [ cl_rewrite_clause c o all_occurrences None ]
-    END
-
-TACTIC EXTEND class_rewrite_strat
-| [ "clrewrite_strat" rewstrategy(s) ] -> [ cl_rewrite_clause_strat s None ]
-(* | [ "clrewrite_strat" strategy(s) "in" hyp(id) ] -> [ cl_rewrite_clause_strat s (Some id) ] *)
+TACTIC EXTEND rewrite_strat
+| [ "rewrite_strat" rewstrategy(s) "in" hyp(id) ] -> [ cl_rewrite_clause_strat s (Some id) ]
+| [ "rewrite_strat" rewstrategy(s) ] -> [ cl_rewrite_clause_strat s None ]
 END
 
-
 let clsubstitute o c =
-  let is_tac id = match kind_of_term (fst c.it) with Var id' when id' = id -> true | _ -> false in
+  let is_tac id = match fst (fst (snd c)) with GVar (_, id') when id' = id -> true | _ -> false in
     Tacticals.onAllHypsAndConcl
       (fun cl ->
 	match cl with
 	  | Some id when is_tac id -> tclIDTAC
-	  | _ -> tclTRY (cl_rewrite_clause c o all_occurrences cl))
+	  | _ -> cl_rewrite_clause c o all_occurrences cl)
 
 TACTIC EXTEND substitute
-| [ "substitute" orient(o) constr_with_bindings(c) ] -> [ clsubstitute o c ]
+| [ "substitute" orient(o) glob_constr_with_bindings(c) ] -> [ clsubstitute o c ]
 END
 
 
 (* Compatibility with old Setoids *)
 
 TACTIC EXTEND setoid_rewrite
-   [ "setoid_rewrite" orient(o) constr_with_bindings(c) ]
+   [ "setoid_rewrite" orient(o) glob_constr_with_bindings(c) ]
    -> [ cl_rewrite_clause c o all_occurrences None ]
- | [ "setoid_rewrite" orient(o) constr_with_bindings(c) "in" hyp(id) ] ->
+ | [ "setoid_rewrite" orient(o) glob_constr_with_bindings(c) "in" hyp(id) ] ->
       [ cl_rewrite_clause c o all_occurrences (Some id)]
- | [ "setoid_rewrite" orient(o) constr_with_bindings(c) "at" occurrences(occ) ] ->
+ | [ "setoid_rewrite" orient(o) glob_constr_with_bindings(c) "at" occurrences(occ) ] ->
       [ cl_rewrite_clause c o (occurrences_of occ) None]
- | [ "setoid_rewrite" orient(o) constr_with_bindings(c) "at" occurrences(occ) "in" hyp(id)] ->
+ | [ "setoid_rewrite" orient(o) glob_constr_with_bindings(c) "at" occurrences(occ) "in" hyp(id)] ->
       [ cl_rewrite_clause c o (occurrences_of occ) (Some id)]
- | [ "setoid_rewrite" orient(o) constr_with_bindings(c) "in" hyp(id) "at" occurrences(occ)] ->
+ | [ "setoid_rewrite" orient(o) glob_constr_with_bindings(c) "in" hyp(id) "at" occurrences(occ)] ->
       [ cl_rewrite_clause c o (occurrences_of occ) (Some id)]
 END
 
-(* let solve_obligation lemma =  *)
-(*   tclTHEN (Tacinterp.interp (Tacexpr.TacAtom (dummy_loc, Tacexpr.TacAnyConstructor None))) *)
-(*     (eapply_with_bindings (Constrintern.interp_constr Evd.empty (Global.env()) lemma, NoBindings)) *)
+let cl_rewrite_clause_newtac_tac c o occ cl gl =
+  cl_rewrite_clause_newtac' c o occ cl;
+  tclIDTAC gl
+  
+TACTIC EXTEND GenRew
+| [ "rew" orient(o) glob_constr_with_bindings(c) "in" hyp(id) "at" occurrences(occ) ] ->
+    [ cl_rewrite_clause_newtac_tac c o (occurrences_of occ) (Some id) ]
+| [ "rew" orient(o) glob_constr_with_bindings(c) "at" occurrences(occ) "in" hyp(id) ] ->
+    [ cl_rewrite_clause_newtac_tac c o (occurrences_of occ) (Some id) ]
+| [ "rew" orient(o) glob_constr_with_bindings(c) "in" hyp(id) ] ->
+    [ cl_rewrite_clause_newtac_tac c o all_occurrences (Some id) ]
+| [ "rew" orient(o) glob_constr_with_bindings(c) "at" occurrences(occ) ] ->
+    [ cl_rewrite_clause_newtac_tac c o (occurrences_of occ) None ]
+| [ "rew" orient(o) glob_constr_with_bindings(c) ] ->
+    [ cl_rewrite_clause_newtac_tac c o all_occurrences None ]
+END
 
 let mkappc s l = CAppExpl (dummy_loc,(None,(Libnames.Ident (dummy_loc,id_of_string s))),l)
 
@@ -1207,78 +1471,75 @@ let declare_an_instance n s args =
 
 let declare_instance a aeq n s = declare_an_instance n s [a;aeq]
 
-let anew_instance binders instance fields =
-  new_instance binders instance (CRecord (dummy_loc,None,fields)) ~generalize:false None
+let anew_instance global binders instance fields =
+  new_instance binders instance (Some (CRecord (dummy_loc,None,fields)))
+    ~global:(not (Vernacexpr.use_section_locality ())) ~generalize:false None
 
-let require_library dirpath =
-  let qualid = (dummy_loc, Libnames.qualid_of_dirpath (Libnames.dirpath_of_string dirpath)) in
-    Library.require_library [qualid] (Some false)
-
-let declare_instance_refl binders a aeq n lemma =
+let declare_instance_refl global binders a aeq n lemma =
   let instance = declare_instance a aeq (add_suffix n "_Reflexive") "Coq.Classes.RelationClasses.Reflexive"
-  in anew_instance binders instance
+  in anew_instance global binders instance
        [(Ident (dummy_loc,id_of_string "reflexivity"),lemma)]
 
-let declare_instance_sym binders a aeq n lemma =
+let declare_instance_sym global binders a aeq n lemma =
   let instance = declare_instance a aeq (add_suffix n "_Symmetric") "Coq.Classes.RelationClasses.Symmetric"
-  in anew_instance binders instance
+  in anew_instance global binders instance
        [(Ident (dummy_loc,id_of_string "symmetry"),lemma)]
 
-let declare_instance_trans binders a aeq n lemma =
+let declare_instance_trans global binders a aeq n lemma =
   let instance = declare_instance a aeq (add_suffix n "_Transitive") "Coq.Classes.RelationClasses.Transitive"
-  in anew_instance binders instance
+  in anew_instance global binders instance
        [(Ident (dummy_loc,id_of_string "transitivity"),lemma)]
 
-let constr_tac = Tacinterp.interp (Tacexpr.TacAtom (dummy_loc, Tacexpr.TacAnyConstructor (false,None)))
-
 let declare_relation ?(binders=[]) a aeq n refl symm trans =
   init_setoid ();
+  let global = not (Vernacexpr.use_section_locality ()) in
   let instance = declare_instance a aeq (add_suffix n "_relation") "Coq.Classes.RelationClasses.RewriteRelation"
-  in ignore(anew_instance binders instance []);
+  in ignore(anew_instance global binders instance []);
   match (refl,symm,trans) with
       (None, None, None) -> ()
     | (Some lemma1, None, None) ->
-	ignore (declare_instance_refl binders a aeq n lemma1)
+	ignore (declare_instance_refl global binders a aeq n lemma1)
     | (None, Some lemma2, None) ->
-	ignore (declare_instance_sym binders a aeq n lemma2)
+	ignore (declare_instance_sym global binders a aeq n lemma2)
     | (None, None, Some lemma3) ->
-	ignore (declare_instance_trans binders a aeq n lemma3)
+	ignore (declare_instance_trans global binders a aeq n lemma3)
     | (Some lemma1, Some lemma2, None) ->
-	ignore (declare_instance_refl binders a aeq n lemma1);
-	ignore (declare_instance_sym binders a aeq n lemma2)
+	ignore (declare_instance_refl global binders a aeq n lemma1);
+	ignore (declare_instance_sym global binders a aeq n lemma2)
     | (Some lemma1, None, Some lemma3) ->
-	let _lemma_refl = declare_instance_refl binders a aeq n lemma1 in
-	let _lemma_trans = declare_instance_trans binders a aeq n lemma3 in
+	let _lemma_refl = declare_instance_refl global binders a aeq n lemma1 in
+	let _lemma_trans = declare_instance_trans global binders a aeq n lemma3 in
 	let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.PreOrder"
 	in ignore(
-	    anew_instance binders instance
+	    anew_instance global binders instance
 	      [(Ident (dummy_loc,id_of_string "PreOrder_Reflexive"), lemma1);
 	       (Ident (dummy_loc,id_of_string "PreOrder_Transitive"),lemma3)])
     | (None, Some lemma2, Some lemma3) ->
-	let _lemma_sym = declare_instance_sym binders a aeq n lemma2 in
-	let _lemma_trans = declare_instance_trans binders a aeq n lemma3 in
+	let _lemma_sym = declare_instance_sym global binders a aeq n lemma2 in
+	let _lemma_trans = declare_instance_trans global binders a aeq n lemma3 in
 	let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.PER"
 	in ignore(
-	    anew_instance binders instance
+	    anew_instance global binders instance
 	      [(Ident (dummy_loc,id_of_string "PER_Symmetric"), lemma2);
 	       (Ident (dummy_loc,id_of_string "PER_Transitive"),lemma3)])
      | (Some lemma1, Some lemma2, Some lemma3) ->
-	let _lemma_refl = declare_instance_refl binders a aeq n lemma1 in
-	let _lemma_sym = declare_instance_sym binders a aeq n lemma2 in
-	let _lemma_trans = declare_instance_trans binders a aeq n lemma3 in
+	let _lemma_refl = declare_instance_refl global binders a aeq n lemma1 in
+	let _lemma_sym = declare_instance_sym global binders a aeq n lemma2 in
+	let _lemma_trans = declare_instance_trans global binders a aeq n lemma3 in
 	let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.Equivalence"
 	in ignore(
-	  anew_instance binders instance
+	  anew_instance global binders instance
 	    [(Ident (dummy_loc,id_of_string "Equivalence_Reflexive"), lemma1);
 	     (Ident (dummy_loc,id_of_string "Equivalence_Symmetric"), lemma2);
 	     (Ident (dummy_loc,id_of_string "Equivalence_Transitive"), lemma3)])
 
 type 'a binders_argtype = (local_binder list, 'a) Genarg.abstract_argument_type
 
-let (wit_binders : Genarg.tlevel binders_argtype),
-  (globwit_binders : Genarg.glevel binders_argtype),
-  (rawwit_binders : Genarg.rlevel binders_argtype) =
-  Genarg.create_arg "binders"
+let _, _, rawwit_binders =
+ (Genarg.create_arg "binders" :
+    Genarg.tlevel binders_argtype *
+    Genarg.glevel binders_argtype *
+    Genarg.rlevel binders_argtype)
 
 open Pcoq.Constr
 
@@ -1349,9 +1610,6 @@ VERNAC COMMAND EXTEND AddParametricRelation3
       [ declare_relation ~binders:b a aeq n None None (Some lemma3) ]
 END
 
-let mk_qualid s =
-  Libnames.Qualid (dummy_loc, Libnames.qualid_of_string s)
-
 let cHole = CHole (dummy_loc, None)
 
 open Entries
@@ -1392,9 +1650,9 @@ let declare_projection n instance_id r =
   let typ = it_mkProd_or_LetIn typ ctx in
   let cst =
     { const_entry_body = term;
+      const_entry_secctx = None;
       const_entry_type = Some typ;
-      const_entry_opaque = false;
-      const_entry_boxed = false }
+      const_entry_opaque = false }
   in
     ignore(Declare.declare_constant n (Entries.DefinitionEntry cst, Decl_kinds.IsDefinition Decl_kinds.Definition))
 
@@ -1441,14 +1699,14 @@ let default_morphism sign m =
   let evars, mor = resolve_one_typeclass env (merge_evars evars) morph in
     mor, proper_projection mor morph
 
-let add_setoid binders a aeq t n =
+let add_setoid global binders a aeq t n =
   init_setoid ();
-  let _lemma_refl = declare_instance_refl binders a aeq n (mkappc "Seq_refl" [a;aeq;t]) in
-  let _lemma_sym = declare_instance_sym binders a aeq n (mkappc "Seq_sym" [a;aeq;t]) in
-  let _lemma_trans = declare_instance_trans binders a aeq n (mkappc "Seq_trans" [a;aeq;t]) in
+  let _lemma_refl = declare_instance_refl global binders a aeq n (mkappc "Seq_refl" [a;aeq;t]) in
+  let _lemma_sym = declare_instance_sym global binders a aeq n (mkappc "Seq_sym" [a;aeq;t]) in
+  let _lemma_trans = declare_instance_trans global binders a aeq n (mkappc "Seq_trans" [a;aeq;t]) in
   let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.Equivalence"
   in ignore(
-    anew_instance binders instance
+    anew_instance global binders instance
       [(Ident (dummy_loc,id_of_string "Equivalence_Reflexive"), mkappc "Seq_refl" [a;aeq;t]);
        (Ident (dummy_loc,id_of_string "Equivalence_Symmetric"), mkappc "Seq_sym" [a;aeq;t]);
        (Ident (dummy_loc,id_of_string "Equivalence_Transitive"), mkappc "Seq_trans" [a;aeq;t])])
@@ -1458,8 +1716,8 @@ let add_morphism_infer glob m n =
   let instance_id = add_suffix n "_Proper" in
   let instance = build_morphism_signature m in
     if Lib.is_modtype () then
-      let cst = Declare.declare_internal_constant instance_id
-				(Entries.ParameterEntry (instance,false), Decl_kinds.IsAssumption Decl_kinds.Logical)
+      let cst = Declare.declare_constant ~internal:Declare.KernelSilent instance_id
+				(Entries.ParameterEntry (None,instance,None), Decl_kinds.IsAssumption Decl_kinds.Logical)
       in
 	add_instance (Typeclasses.new_instance (Lazy.force proper_class) None glob (ConstRef cst));
 	declare_projection n instance_id (ConstRef cst)
@@ -1487,14 +1745,14 @@ let add_morphism glob binders m s n =
 	     [cHole; s; m]))
   in
   let tac = Tacinterp.interp <:tactic<add_morphism_tactic>> in
-    ignore(new_instance ~global:glob binders instance (CRecord (dummy_loc,None,[]))
+    ignore(new_instance ~global:glob binders instance (Some (CRecord (dummy_loc,None,[])))
 	      ~generalize:false ~tac ~hook:(declare_projection n instance_id) None)
 
 VERNAC COMMAND EXTEND AddSetoid1
    [ "Add" "Setoid" constr(a) constr(aeq) constr(t) "as" ident(n) ] ->
-     [ add_setoid [] a aeq t n ]
+     [ add_setoid (not (Vernacexpr.use_section_locality ())) [] a aeq t n ]
   | [ "Add" "Parametric" "Setoid" binders(binders) ":" constr(a) constr(aeq) constr(t) "as" ident(n) ] ->
-     [	add_setoid binders a aeq t n ]
+     [	add_setoid (not (Vernacexpr.use_section_locality ())) binders a aeq t n ]
   | [ "Add" "Morphism" constr(m) ":" ident(n) ] ->
       [ add_morphism_infer (not (Vernacexpr.use_section_locality ())) m n ]
   | [ "Add" "Morphism" constr(m) "with" "signature" lconstr(s) "as" ident(n) ] ->
@@ -1529,40 +1787,43 @@ let check_evar_map_of_evars_defs evd =
          check_freemetas_is_empty rebus2 freemetas2
    ) metas
 
-let unification_rewrite l2r c1 c2 cl car rel but gl =
+let unification_rewrite flags l2r c1 c2 cl car rel but gl =
   let env = pf_env gl in
   let (evd',c') =
     try
       (* ~flags:(false,true) to allow to mark occurrences that must not be
          rewritten simply by replacing them with let-defined definitions
          in the context *)
-      Unification.w_unify_to_subterm ~flags:rewrite_unif_flags env ((if l2r then c1 else c2),but) cl.evd
+      Unification.w_unify_to_subterm ~flags:rewrite_unif_flags env cl.evd ((if l2r then c1 else c2),but)
     with
 	Pretype_errors.PretypeError _ ->
 	  (* ~flags:(true,true) to make Ring work (since it really
              exploits conversion) *)
-	  Unification.w_unify_to_subterm ~flags:rewrite2_unif_flags
-	    env ((if l2r then c1 else c2),but) cl.evd
+	  Unification.w_unify_to_subterm ~flags:flags
+	    env cl.evd ((if l2r then c1 else c2),but)
   in
   let evd' = Typeclasses.resolve_typeclasses ~fail:false env evd' in
   let cl' = {cl with evd = evd'} in
-  let cl' =
-    let mvs = clenv_dependent false cl' in
-      clenv_pose_metas_as_evars cl' mvs
-  in
-  let nf c = Evarutil.nf_evar ( cl'.evd) (Clenv.clenv_nf_meta cl' c) in
+  let cl' = Clenvtac.clenv_pose_dependent_evars true cl' in
+  let nf c = Evarutil.nf_evar cl'.evd (Clenv.clenv_nf_meta cl' c) in
   let c1 = if l2r then nf c' else nf c1
   and c2 = if l2r then nf c2 else nf c'
   and car = nf car and rel = nf rel in
   check_evar_map_of_evars_defs cl'.evd;
   let prf = nf (Clenv.clenv_value cl') and prfty = nf (Clenv.clenv_type cl') in
   let cl' = { cl' with templval = mk_freelisted prf ; templtyp = mk_freelisted prfty } in
-    {cl=cl'; prf=(mkRel 1); car=car; rel=rel; l2r=l2r; c1=c1; c2=c2; c=None; abs=Some (prf, prfty)}
+    {cl=cl'; prf=(mkRel 1); car=car; rel=rel; l2r=l2r; c1=c1; c2=c2; c=None; abs=Some (prf, prfty);
+     flags = flags}
 
 let get_hyp gl evars (c,l) clause l2r =
-  let hi = decompose_applied_relation (pf_env gl) evars (c,l) l2r in
-  let but = match clause with Some id -> pf_get_hyp_typ gl id | None -> pf_concl gl in
-    unification_rewrite hi.l2r hi.c1 hi.c2 hi.cl hi.car hi.rel but gl
+  let flags = rewrite2_unif_flags in
+  let hi = decompose_applied_relation (pf_env gl) evars flags None (c,l) l2r in
+  let but = match clause with
+    | Some id -> pf_get_hyp_typ gl id 
+    | None -> Evarutil.nf_evar evars (pf_concl gl)
+  in
+    { unification_rewrite flags hi.l2r hi.c1 hi.c2 hi.cl hi.car hi.rel but gl with
+	flags = rewrite_unif_flags }
 
 let general_rewrite_flags = { under_lambdas = false; on_morphisms = true }
 
@@ -1578,13 +1839,14 @@ let general_s_rewrite cl l2r occs (c,l) ~new_goals gl =
   let meta = Evarutil.new_meta() in
   let hypinfo, strat = apply_lemma gl (c,l) cl l2r occs in
     try
-      tclTHEN
-        (Refiner.tclEVARS hypinfo.cl.evd)
-        (cl_rewrite_clause_aux ~abs:hypinfo.abs strat meta cl) gl
+      tclWEAK_PROGRESS 
+	(tclTHEN
+           (Refiner.tclEVARS hypinfo.cl.evd)
+	   (cl_rewrite_clause_tac ~abs:hypinfo.abs strat (mkMeta meta) cl)) gl
     with RewriteFailure ->
       let {l2r=l2r; c1=x; c2=y} = hypinfo in
 	raise (Pretype_errors.PretypeError
-		  (pf_env gl,
+		  (pf_env gl,project gl,
 		  Pretype_errors.NoOccurrenceFound ((if l2r then x else y), cl)))
 
 let general_s_rewrite_clause x =
@@ -1595,15 +1857,6 @@ let general_s_rewrite_clause x =
 
 let _ = Equality.register_general_rewrite_clause general_s_rewrite_clause
 
-let is_loaded d =
-  let d' = List.map id_of_string d in
-  let dir = make_dirpath (List.rev d') in
-    Library.library_is_loaded dir
-
-let try_loaded f gl =
-  if is_loaded ["Coq";"Classes";"RelationClasses"] then f gl
-  else tclFAIL 0 (str"You need to require Coq.Classes.RelationClasses first") gl
-
 (** [setoid_]{reflexivity,symmetry,transitivity} tactics *)
 
 let not_declared env ty rel =
@@ -1641,7 +1894,7 @@ let setoid_transitivity c gl =
       let proof = get_transitive_proof env evm car rel in
       match c with
       | None -> eapply proof
-      | Some c -> apply_with_bindings (proof,Rawterm.ImplicitBindings [ c ]))
+      | Some c -> apply_with_bindings (proof,Glob_term.ImplicitBindings [ c ]))
     (transitivity_red true c)
 
 let setoid_symmetry_in id gl =
@@ -1721,3 +1974,35 @@ TACTIC EXTEND fold_matches
   let c' = fold_matches (pf_env gl) (project gl) c in
     change (Some (snd (pattern_of_constr (project gl) c))) c' onConcl gl ]
 END
+
+TACTIC EXTEND myapply
+| [ "myapply" global(id) constr_list(l) ] -> [ 
+    fun gl -> 
+      let gr = id in
+      let _, impls = List.hd (Impargs.implicits_of_global gr) in
+      let ty = Global.type_of_global gr in
+      let env = pf_env gl in
+      let evars = ref (project gl) in
+      let app =
+	let rec aux ty impls args args' =
+	  match impls, kind_of_term ty with
+	  | Some (_, _, (_, _)) :: impls, Prod (n, t, t') ->
+	      let arg = Evarutil.e_new_evar evars env t in
+		aux (subst1 arg t') impls args (arg :: args')
+	  | None :: impls, Prod (n, t, t') ->
+	      (match args with
+	       | [] ->
+		   if dependent (mkRel 1) t' then
+		     let arg = Evarutil.e_new_evar evars env t in
+		       aux (subst1 arg t') impls args (arg :: args')
+		   else
+		     let arg = Evarutil.mk_new_meta () in
+		       evars := meta_declare (destMeta arg) t !evars;
+		       aux (subst1 arg t') impls args (arg :: args')
+	       | arg :: args -> 
+		   aux (subst1 arg t') impls args (arg :: args'))
+	  | _, _ -> mkApp (constr_of_global gr, Array.of_list (List.rev args'))
+	in aux ty impls l []
+      in
+	tclTHEN (Refiner.tclEVARS !evars) (apply app) gl ]
+END
diff --git a/tactics/tacinterp.ml b/tactics/tacinterp.ml
index 6a11384b..a41cd6e7 100644
--- a/tactics/tacinterp.ml
+++ b/tactics/tacinterp.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: tacinterp.ml 14677 2011-11-17 22:19:38Z herbelin $ *)
-
 open Constrintern
 open Closure
 open RedFlags
@@ -17,7 +15,7 @@ open Libobject
 open Pattern
 open Matching
 open Pp
-open Rawterm
+open Glob_term
 open Sign
 open Tacred
 open Util
@@ -48,6 +46,8 @@ open Pretyping
 open Pretyping.Default
 open Extrawit
 open Pcoq
+open Compat
+open Evd
 
 let safe_msgnl s =
     try msgnl s with e ->
@@ -60,20 +60,18 @@ let error_syntactic_metavariables_not_allowed loc =
     (loc,"out_ident",
      str "Syntactic metavariables allowed only in quotations.")
 
+let error_tactic_expected loc =
+  user_err_loc (loc,"",str "Tactic expected.")
+
 let error_global_not_found_loc (loc,qid) = error_global_not_found_loc loc qid
 
 let skip_metaid = function
   | AI x -> x
   | MetaId (loc,_) -> error_syntactic_metavariables_not_allowed loc
 
-type ltac_type =
-  | LtacFun of ltac_type
-  | LtacBasic
-  | LtacTactic
-
 (* Values for interpretation *)
 type value =
-  | VRTactic of (goal list sigma * validation) (* For Match results *)
+  | VRTactic of (goal list sigma) (* For Match results *)
                                                (* Not a true value *)
   | VFun of ltac_trace * (identifier*value) list *
       identifier option list * glob_tactic_expr
@@ -93,15 +91,15 @@ let dloc = dummy_loc
 let catch_error call_trace tac g =
   if call_trace = [] then tac g else try tac g with
   | LtacLocated _ as e -> raise e
-  | Stdpp.Exc_located (_,LtacLocated _) as e -> raise e
+  | Loc.Exc_located (_,LtacLocated _) as e -> raise e
   | e ->
     let (nrep,loc',c),tail = list_sep_last call_trace in
-    let loc,e' = match e with Stdpp.Exc_located(loc,e) -> loc,e | _ ->dloc,e in
+    let loc,e' = match e with Loc.Exc_located(loc,e) -> loc,e | _ ->dloc,e in
     if tail = [] then
       let loc = if loc = dloc then loc' else loc in
-      raise (Stdpp.Exc_located(loc,e'))
+      raise (Loc.Exc_located(loc,e'))
     else
-      raise (Stdpp.Exc_located(loc',LtacLocated((nrep,c,tail,loc),e')))
+      raise (Loc.Exc_located(loc',LtacLocated((nrep,c,tail,loc),e')))
 
 (* Signature for interpretation: val_interp and interpretation functions *)
 type interp_sign =
@@ -137,9 +135,9 @@ let rec pr_value env = function
   | VList (a::_) ->
       str "a list (first element is " ++ pr_value env a ++ str")"
 
-(* Transforms an id into a constr if possible, or fails *)
+(* Transforms an id into a constr if possible, or fails with Not_found *)
 let constr_of_id env id =
-  construct_reference (Environ.named_context env) id
+  Term.mkVar (let _ = Environ.lookup_named id env in id)
 
 (* To embed tactics *)
 let ((tactic_in : (interp_sign -> glob_tactic_expr) -> Dyn.t),
@@ -159,25 +157,6 @@ let valueOut = function
   | ast ->
     anomalylabstrm "valueOut" (str "Not a Dynamic ast: ")
 
-(* To embed constr *)
-let constrIn t = CDynamic (dummy_loc,constr_in t)
-let constrOut = function
-  | CDynamic (_,d) ->
-    if (Dyn.tag d) = "constr" then
-      constr_out d
-    else
-      anomalylabstrm "constrOut" (str "Dynamic tag should be constr")
-  | ast ->
-    anomalylabstrm "constrOut" (str "Not a Dynamic ast")
-
-(* Globalizes the identifier *)
-let find_reference env qid =
-  (* We first look for a variable of the current proof *)
-  match repr_qualid qid with
-    | (d,id) when repr_dirpath d = [] & List.mem id (ids_of_context env)
-	-> VarRef id
-    | _ -> Nametab.locate qid
-
 (* Table of "pervasives" macros tactics (e.g. auto, simpl, etc.) *)
 let atomic_mactab = ref Idmap.empty
 let add_primitive_tactic s tac =
@@ -213,7 +192,7 @@ let _ =
       (fun (s,t) -> add_primitive_tactic s t)
       [ "idtac",TacId [];
         "fail", TacFail(ArgArg 0,[]);
-        "fresh", TacArg(TacFreshId [])
+        "fresh", TacArg(dloc,TacFreshId [])
       ]
 
 let lookup_atomic id = Idmap.find id !atomic_mactab
@@ -347,15 +326,6 @@ let intern_name l ist = function
   | Anonymous -> Anonymous
   | Name id -> Name (intern_ident l ist id)
 
-let vars_of_ist (lfun,_,_,env) =
-  List.fold_left (fun s id -> Idset.add id s)
-    (vars_of_env env) lfun
-
-let get_current_context () =
-    try Pfedit.get_current_goal_context ()
-    with e when Logic.catchable_exception e ->
-      (Evd.empty, Global.env())
-
 let strict_check = ref false
 
 let adjust_loc loc = if !strict_check then dloc else loc
@@ -402,12 +372,12 @@ let intern_ltac_variable ist = function
 
 let intern_constr_reference strict ist = function
   | Ident (_,id) as r when not strict & find_hyp id ist ->
-      RVar (dloc,id), Some (CRef r)
+      GVar (dloc,id), Some (CRef r)
   | Ident (_,id) as r when find_ctxvar id ist ->
-      RVar (dloc,id), if strict then None else Some (CRef r)
+      GVar (dloc,id), if strict then None else Some (CRef r)
   | r ->
       let loc,_ as lqid = qualid_of_reference r in
-      RRef (loc,locate_global_with_alias lqid), if strict then None else Some (CRef r)
+      GRef (loc,locate_global_with_alias lqid), if strict then None else Some (CRef r)
 
 let intern_move_location ist = function
   | MoveAfter id -> MoveAfter (intern_hyp_or_metaid ist id)
@@ -525,12 +495,6 @@ let intern_bindings ist = function
 let intern_constr_with_bindings ist (c,bl) =
   (intern_constr ist c, intern_bindings ist bl)
 
-let intern_clause_pattern ist (l,occl) =
-  let rec check = function
-    | (hyp,l) :: rest -> (intern_hyp ist (skip_metaid hyp),l)::(check rest)
-    | [] -> []
-  in (l,check occl)
-
   (* TODO: catch ltac vars *)
 let intern_induction_arg ist = function
   | ElimOnConstr c -> ElimOnConstr (intern_constr_with_bindings ist c)
@@ -539,7 +503,7 @@ let intern_induction_arg ist = function
       if !strict_check then
 	(* If in a defined tactic, no intros-until *)
 	match intern_constr ist (CRef (Ident (dloc,id))) with
-	| RVar (loc,id),_ -> ElimOnIdent (loc,id)
+	| GVar (loc,id),_ -> ElimOnIdent (loc,id)
 	| c -> ElimOnConstr (c,NoBindings)
       else
 	ElimOnIdent (loc,id)
@@ -592,7 +556,7 @@ let intern_typed_pattern ist p =
   let dummy_pat = PRel 0 in
   (* we cannot ensure in non strict mode that the pattern is closed *)
   (* keeping a constr_expr copy is too complicated and we want anyway to *)
-  (* type it, so we remember the pattern as a rawconstr only *)
+  (* type it, so we remember the pattern as a glob_constr only *)
   (intern_constr_gen true false ist p,dummy_pat)
 
 let intern_typed_pattern_with_occurrences ist (l,p) =
@@ -735,7 +699,7 @@ let rec intern_atomic lf ist x =
       TacMutualCofix (b,intern_ident lf ist id, List.map f l)
   | TacCut c -> TacCut (intern_type ist c)
   | TacAssert (otac,ipat,c) ->
-      TacAssert (Option.map (intern_tactic ist) otac,
+      TacAssert (Option.map (intern_pure_tactic ist) otac,
                  Option.map (intern_intro_pattern lf ist) ipat,
                  intern_constr_gen false (otac<>None) ist c)
   | TacGeneralize cl ->
@@ -797,8 +761,8 @@ let rec intern_atomic lf ist x =
   | TacLeft (ev,bl) -> TacLeft (ev,intern_bindings ist bl)
   | TacRight (ev,bl) -> TacRight (ev,intern_bindings ist bl)
   | TacSplit (ev,b,bll) -> TacSplit (ev,b,List.map (intern_bindings ist) bll)
-  | TacAnyConstructor (ev,t) -> TacAnyConstructor (ev,Option.map (intern_tactic ist) t)
-  | TacConstructor (ev,n,bl) -> TacConstructor (ev,n,intern_bindings ist bl)
+  | TacAnyConstructor (ev,t) -> TacAnyConstructor (ev,Option.map (intern_pure_tactic ist) t)
+  | TacConstructor (ev,n,bl) -> TacConstructor (ev,intern_or_var ist n,intern_bindings ist bl)
 
   (* Conversion *)
   | TacReduce (r,cl) ->
@@ -826,7 +790,7 @@ let rec intern_atomic lf ist x =
 	(ev,
 	List.map (fun (b,m,c) -> (b,m,intern_constr_with_bindings ist c)) l,
 	clause_app (intern_hyp_location ist) cl,
-	Option.map (intern_tactic ist) by)
+	Option.map (intern_pure_tactic ist) by)
   | TacInversion (inv,hyp) ->
       TacInversion (intern_inversion_strength lf ist inv,
         intern_quantified_hypothesis ist hyp)
@@ -839,9 +803,9 @@ let rec intern_atomic lf ist x =
       let l = List.map (fun (id,a) -> (id,intern_genarg ist a)) l in
       TacAlias (loc,s,l,(dir,body))
 
-and intern_tactic ist tac = (snd (intern_tactic_seq ist tac) : glob_tactic_expr)
+and intern_tactic onlytac ist tac = snd (intern_tactic_seq onlytac ist tac)
 
-and intern_tactic_seq ist = function
+and intern_tactic_seq onlytac ist = function
   | TacAtom (loc,t) ->
       let lf = ref ist.ltacvars in
       let t = intern_atomic lf ist t in
@@ -851,50 +815,68 @@ and intern_tactic_seq ist = function
       let (l1,l2) = ist.ltacvars in
       let ist' = { ist with ltacvars = (extract_let_names l @ l1, l2) } in
       let l = List.map (fun (n,b) ->
-	  (n,intern_tacarg !strict_check (if isrec then ist' else ist) b)) l in
-      ist.ltacvars, TacLetIn (isrec,l,intern_tactic ist' u)
+	  (n,intern_tacarg !strict_check false (if isrec then ist' else ist) b)) l in
+      ist.ltacvars, TacLetIn (isrec,l,intern_tactic onlytac ist' u)
+
   | TacMatchGoal (lz,lr,lmr) ->
-      ist.ltacvars, TacMatchGoal(lz,lr, intern_match_rule ist lmr)
+      ist.ltacvars, TacMatchGoal(lz,lr, intern_match_rule onlytac ist lmr)
   | TacMatch (lz,c,lmr) ->
-      ist.ltacvars, TacMatch (lz,intern_tactic ist c,intern_match_rule ist lmr)
+      ist.ltacvars,
+      TacMatch (lz,intern_tactic_or_tacarg ist c,intern_match_rule onlytac ist lmr)
   | TacId l -> ist.ltacvars, TacId (intern_message ist l)
   | TacFail (n,l) ->
       ist.ltacvars, TacFail (intern_or_var ist n,intern_message ist l)
-  | TacProgress tac -> ist.ltacvars, TacProgress (intern_tactic ist tac)
-  | TacAbstract (tac,s) -> ist.ltacvars, TacAbstract (intern_tactic ist tac,s)
+  | TacProgress tac -> ist.ltacvars, TacProgress (intern_pure_tactic ist tac)
+  | TacAbstract (tac,s) ->
+      ist.ltacvars, TacAbstract (intern_pure_tactic ist tac,s)
   | TacThen (t1,[||],t2,[||]) ->
-      let lfun', t1 = intern_tactic_seq ist t1 in
-      let lfun'', t2 = intern_tactic_seq { ist with ltacvars = lfun' } t2 in
+      let lfun', t1 = intern_tactic_seq onlytac ist t1 in
+      let lfun'', t2 = intern_tactic_seq onlytac { ist with ltacvars = lfun' } t2 in
       lfun'', TacThen (t1,[||],t2,[||])
   | TacThen (t1,tf,t2,tl) ->
-      let lfun', t1 = intern_tactic_seq ist t1 in
+      let lfun', t1 = intern_tactic_seq onlytac ist t1 in
       let ist' = { ist with ltacvars = lfun' } in
       (* Que faire en cas de (tac complexe avec Match et Thens; tac2) ?? *)
-      lfun', TacThen (t1,Array.map (intern_tactic ist') tf,intern_tactic ist' t2,
-		       Array.map (intern_tactic ist') tl)
+      lfun', TacThen (t1,Array.map (intern_pure_tactic ist') tf,intern_pure_tactic ist' t2,
+		       Array.map (intern_pure_tactic ist') tl)
   | TacThens (t,tl) ->
-      let lfun', t = intern_tactic_seq ist t in
+      let lfun', t = intern_tactic_seq true ist t in
       let ist' = { ist with ltacvars = lfun' } in
       (* Que faire en cas de (tac complexe avec Match et Thens; tac2) ?? *)
-      lfun', TacThens (t, List.map (intern_tactic ist') tl)
+      lfun', TacThens (t, List.map (intern_pure_tactic ist') tl)
   | TacDo (n,tac) ->
-      ist.ltacvars, TacDo (intern_or_var ist n,intern_tactic ist tac)
-  | TacTry tac -> ist.ltacvars, TacTry (intern_tactic ist tac)
-  | TacInfo tac -> ist.ltacvars, TacInfo (intern_tactic ist tac)
-  | TacRepeat tac -> ist.ltacvars, TacRepeat (intern_tactic ist tac)
+      ist.ltacvars, TacDo (intern_or_var ist n,intern_pure_tactic ist tac)
+  | TacTry tac -> ist.ltacvars, TacTry (intern_pure_tactic ist tac)
+  | TacInfo tac -> ist.ltacvars, TacInfo (intern_pure_tactic ist tac)
+  | TacRepeat tac -> ist.ltacvars, TacRepeat (intern_pure_tactic ist tac)
+  | TacTimeout (n,tac) ->
+      ist.ltacvars, TacTimeout (intern_or_var ist n,intern_tactic onlytac ist tac)
   | TacOrelse (tac1,tac2) ->
-      ist.ltacvars, TacOrelse (intern_tactic ist tac1,intern_tactic ist tac2)
-  | TacFirst l -> ist.ltacvars, TacFirst (List.map (intern_tactic ist) l)
-  | TacSolve l -> ist.ltacvars, TacSolve (List.map (intern_tactic ist) l)
-  | TacComplete tac -> ist.ltacvars, TacComplete (intern_tactic ist tac)
-  | TacArg a -> ist.ltacvars, TacArg (intern_tacarg true ist a)
+      ist.ltacvars, TacOrelse (intern_pure_tactic ist tac1,intern_pure_tactic ist tac2)
+  | TacFirst l -> ist.ltacvars, TacFirst (List.map (intern_pure_tactic ist) l)
+  | TacSolve l -> ist.ltacvars, TacSolve (List.map (intern_pure_tactic ist) l)
+  | TacComplete tac -> ist.ltacvars, TacComplete (intern_pure_tactic ist tac)
+  | TacArg (loc,a) -> ist.ltacvars, intern_tactic_as_arg loc onlytac ist a
+
+and intern_tactic_as_arg loc onlytac ist a =
+  match intern_tacarg !strict_check onlytac ist a with
+  | TacCall _ | TacExternal _ | Reference _ | TacDynamic _ as a -> TacArg (loc,a)
+  | Tacexp a -> a
+  | TacVoid | IntroPattern _ | Integer _
+  | ConstrMayEval _ | TacFreshId _ as a ->
+      if onlytac then error_tactic_expected loc else TacArg (loc,a)
+  | MetaIdArg _ -> assert false
+
+and intern_tactic_or_tacarg ist = intern_tactic false ist
+
+and intern_pure_tactic ist = intern_tactic true ist
 
 and intern_tactic_fun ist (var,body) =
   let (l1,l2) = ist.ltacvars in
   let lfun' = List.rev_append (Option.List.flatten var) l1 in
-  (var,intern_tactic { ist with ltacvars = (lfun',l2) } body)
+  (var,intern_tactic_or_tacarg { ist with ltacvars = (lfun',l2) } body)
 
-and intern_tacarg strict ist = function
+and intern_tacarg strict onlytac ist = function
   | TacVoid -> TacVoid
   | Reference r -> intern_non_tactic_reference strict ist r
   | IntroPattern ipat ->
@@ -907,34 +889,35 @@ and intern_tacarg strict ist = function
       let id = id_of_string s in
       if find_ltacvar id ist then
 	if istac then Reference (ArgVar (adjust_loc loc,id))
-	else ConstrMayEval (ConstrTerm (RVar (adjust_loc loc,id), None))
+	else ConstrMayEval (ConstrTerm (GVar (adjust_loc loc,id), None))
       else error_syntactic_metavariables_not_allowed loc
   | TacCall (loc,f,[]) -> intern_isolated_tactic_reference strict ist f
   | TacCall (loc,f,l) ->
       TacCall (loc,
         intern_applied_tactic_reference ist f,
-        List.map (intern_tacarg !strict_check ist) l)
+        List.map (intern_tacarg !strict_check false ist) l)
   | TacExternal (loc,com,req,la) ->
-      TacExternal (loc,com,req,List.map (intern_tacarg !strict_check ist) la)
+      TacExternal (loc,com,req,List.map (intern_tacarg !strict_check false ist) la)
   | TacFreshId x -> TacFreshId (List.map (intern_or_var ist) x)
-  | Tacexp t -> Tacexp (intern_tactic ist t)
+  | Tacexp t -> Tacexp (intern_tactic onlytac ist t)
   | TacDynamic(loc,t) as x ->
       (match Dyn.tag t with
-	| "tactic" | "value" | "constr" -> x
+	| "tactic" | "value" -> x
+        | "constr" -> if onlytac then error_tactic_expected loc else x
 	| s -> anomaly_loc (loc, "",
                  str "Unknown dynamic: <" ++ str s ++ str ">"))
 
 (* Reads the rules of a Match Context or a Match *)
-and intern_match_rule ist = function
+and intern_match_rule onlytac ist = function
   | (All tc)::tl ->
-      All (intern_tactic ist tc) :: (intern_match_rule ist tl)
+      All (intern_tactic onlytac ist tc) :: (intern_match_rule onlytac ist tl)
   | (Pat (rl,mp,tc))::tl ->
       let {ltacvars=(lfun,l2); gsigma=sigma; genv=env} = ist in
       let lfun',metas1,hyps = intern_match_goal_hyps ist lfun rl in
       let ido,metas2,pat = intern_pattern ist lfun mp in
       let metas = list_uniquize (metas1@metas2) in
       let ist' = { ist with ltacvars = (metas@(Option.List.cons ido lfun'),l2) } in
-      Pat (hyps,pat,intern_tactic ist' tc) :: (intern_match_rule ist tl)
+      Pat (hyps,pat,intern_tactic onlytac ist' tc) :: (intern_match_rule onlytac ist tl)
   | [] -> []
 
 and intern_genarg ist x =
@@ -990,30 +973,16 @@ and intern_genarg ist x =
       match tactic_genarg_level s with
       | Some n ->
           (* Special treatment of tactic arguments *)
-          in_gen (globwit_tactic n) (intern_tactic ist
+          in_gen (globwit_tactic n) (intern_tactic_or_tacarg ist
 	    (out_gen (rawwit_tactic n) x))
       | None ->
           lookup_genarg_glob s ist x
 
-let intern_pure_tactic ist a =
-  match intern_tactic ist a with
-  | TacArg (TacCall _ | TacExternal _ | Reference _ | TacDynamic _ | Tacexp _) as a -> a
-  | TacArg _ | TacFun _ -> error "Tactic expected."
-  | a -> a
-
 (************* End globalization ************)
 
 (***************************************************************************)
 (* Evaluation/interpretation *)
 
-let constr_to_id loc = function
-  | VConstr ([],c) when isVar c -> destVar c
-  | _ -> invalid_arg_loc (loc, "Not an identifier")
-
-let constr_to_qid loc c =
-  try shortest_qualid_of_global Idset.empty (global_of_constr c)
-  with _ -> invalid_arg_loc (loc, "Not a global reference")
-
 let is_variable env id =
   List.mem id (ids_of_named_context (Environ.named_context env))
 
@@ -1053,7 +1022,7 @@ let try_interp_ltac_var coerce ist env (loc,id) =
 
 let interp_ltac_var coerce ist env locid =
   try try_interp_ltac_var coerce ist env locid
-  with Not_found -> anomaly "Detected as ltac var at interning time"
+  with Not_found -> anomaly ("Detected '" ^ (string_of_id (snd locid)) ^ "' as ltac var at interning time")
 
 (* Interprets an identifier which must be fresh *)
 let coerce_to_ident fresh env = function
@@ -1161,16 +1130,6 @@ let interp_hyp_list_as_list ist gl (loc,id as x) =
 let interp_hyp_list ist gl l =
   List.flatten (List.map (interp_hyp_list_as_list ist gl) l)
 
-let interp_clause_pattern ist gl (l,occl) =
-  let rec check acc = function
-    | (hyp,l) :: rest ->
-	let hyp = interp_hyp ist gl hyp in
-	if List.mem hyp acc then
-	  error ("Hypothesis "^(string_of_id hyp)^" occurs twice.");
-	(hyp,l)::(check (hyp::acc) rest)
-    | [] -> []
-  in (l,check [] occl)
-
 let interp_move_location ist gl = function
   | MoveAfter id -> MoveAfter (interp_hyp ist gl id)
   | MoveBefore id -> MoveBefore (interp_hyp ist gl id)
@@ -1284,58 +1243,6 @@ let interp_fresh_id ist env l =
 
 let pf_interp_fresh_id ist gl = interp_fresh_id ist (pf_env gl)
 
-let implicit_tactic = ref None
-
-let declare_implicit_tactic tac = implicit_tactic := Some tac
-
-open Evd
-
-let solvable_by_tactic env evi (ev,args) src =
-  match (!implicit_tactic, src) with
-  | Some tac, (ImplicitArg _ | QuestionMark _)
-      when
-	Environ.named_context_of_val evi.evar_hyps =
-	Environ.named_context env ->
-      let id = id_of_string "H" in
-      start_proof id (Local,Proof Lemma) evi.evar_hyps evi.evar_concl
-	(fun _ _ -> ());
-      begin
-	try
-	  by (tclCOMPLETE tac);
-	  let _,(const,_,_,_) = cook_proof ignore in
-	  delete_current_proof (); const.const_entry_body
-	with e when Logic.catchable_exception e ->
-	  delete_current_proof();
-	  raise Exit
-      end
-  | _ -> raise Exit
-
-let solve_remaining_evars fail_evar use_classes env initial_sigma evd c =
-  let evdref =
-    if use_classes then ref (Typeclasses.resolve_typeclasses ~fail:true env evd)
-    else ref evd in
-  let rec proc_rec c =
-    let c = Reductionops.whd_evar !evdref c in
-    match kind_of_term c with
-      | Evar (ev,args as k) when not (Evd.mem initial_sigma ev) ->
-            let (loc,src) = evar_source ev !evdref in
-	    let sigma =  !evdref in
-	    let evi = Evd.find sigma ev in
-	    (try
-	      let c = solvable_by_tactic env evi k src in
-	      evdref := Evd.define ev c !evdref;
-	      c
-	    with Exit ->
-              if fail_evar then
-	        Pretype_errors.error_unsolvable_implicit loc env sigma evi src None
-              else
-                c)
-      | _ -> map_constr proc_rec c
-  in
-  let c = proc_rec c in
-  (* Side-effect *)
-  !evdref,c
-
 let interp_gen kind ist allow_patvar expand_evar fail_evar use_classes env sigma (c,ce) =
   let (ltacvars,unbndltacvars as vars) = extract_ltac_constr_values ist env in
   let c = match ce with
@@ -1348,13 +1255,14 @@ let interp_gen kind ist allow_patvar expand_evar fail_evar use_classes env sigma
       intern_gen (kind = IsType) ~allow_patvar ~ltacvars:ltacdata sigma env c
   in
   let trace = push_trace (dloc,LtacConstrInterp (c,vars)) ist.trace in
-  let evd,c =
+  let evdc =
     catch_error trace (understand_ltac expand_evar sigma env vars kind) c in
-  let evd,c =
+  let (evd,c) =
     if expand_evar then
-      solve_remaining_evars fail_evar use_classes env sigma evd c
+      solve_remaining_evars fail_evar use_classes
+        solve_by_implicit_tactic env sigma evdc
     else
-      evd,c in
+      evdc in
   db_constr ist.debug env c;
   (evd,c)
 
@@ -1373,6 +1281,9 @@ let interp_open_constr_gen kind ist =
 let interp_open_constr ccl =
   interp_open_constr_gen (OfType ccl)
 
+let interp_pure_open_constr ist =
+  interp_gen (OfType None) ist false false false false
+
 let interp_typed_pattern ist env sigma (c,_) =
   let sigma, c =
     interp_gen (OfType None) ist true false false false env sigma c in
@@ -1393,7 +1304,7 @@ let constr_list_of_VList env = function
 let interp_constr_in_compound_list inj_fun dest_fun interp_fun ist env sigma l =
   let try_expand_ltac_var sigma x =
     try match dest_fun x with
-    | RVar (_,id), _ ->	
+    | GVar (_,id), _ ->	
         sigma,
         List.map inj_fun (constr_list_of_VList env (List.assoc id ist.lfun))
     | _ ->
@@ -1408,12 +1319,14 @@ let interp_constr_in_compound_list inj_fun dest_fun interp_fun ist env sigma l =
 let interp_constr_list ist env sigma c =
   snd (interp_constr_in_compound_list (fun x -> x) (fun x -> x) (fun ist env sigma c -> (Evd.empty, interp_constr ist env sigma c)) ist env sigma c)
 
-let inj_open c = (Evd.empty,c)
-
 let interp_open_constr_list =
   interp_constr_in_compound_list (fun x -> x) (fun x -> x)
     (interp_open_constr None)
 
+let interp_auto_lemmas ist env sigma lems =
+  let local_sigma, lems = interp_open_constr_list ist env sigma lems in
+  List.map (fun lem -> (local_sigma,lem)) lems
+
 (* Interprets a type expression *)
 let pf_interp_type ist gl =
   interp_type ist (pf_env gl) (project gl)
@@ -1476,7 +1389,7 @@ let interp_may_eval f ist gl = function
 	f ist gl c
      with e ->
        debugging_exception_step ist false e (fun () ->
-         str"interpretation of term " ++ pr_rawconstr_env (pf_env gl) (fst c));
+         str"interpretation of term " ++ pr_glob_constr_env (pf_env gl) (fst c));
        raise e
 
 (* Interprets a constr expression possibly to first evaluate *)
@@ -1612,41 +1525,48 @@ let interp_open_constr_with_bindings ist env sigma (c,bl) =
 
 let loc_of_bindings = function
 | NoBindings -> dummy_loc
-| ImplicitBindings l -> loc_of_rawconstr (fst (list_last l))
+| ImplicitBindings l -> loc_of_glob_constr (fst (list_last l))
 | ExplicitBindings l -> pi1 (list_last l)
 
 let interp_open_constr_with_bindings_loc ist env sigma ((c,_),bl as cb) =
-  let loc1 = loc_of_rawconstr c in
+  let loc1 = loc_of_glob_constr c in
   let loc2 = loc_of_bindings bl in
   let loc = if loc2 = dummy_loc then loc1 else join_loc loc1 loc2 in
   let sigma, cb = interp_open_constr_with_bindings ist env sigma cb in
   sigma, (loc,cb)
 
-let interp_induction_arg ist gl sigma arg =
-  let env = pf_env gl in
+let interp_induction_arg ist gl arg =
+  let env = pf_env gl and sigma = project gl in
   match arg with
   | ElimOnConstr c ->
-      let sigma', (c,b) = interp_constr_with_bindings ist env sigma c in
-      let sigma, c = solve_remaining_evars false true env sigma sigma' c in
-      sigma, ElimOnConstr (c,b)
-  | ElimOnAnonHyp n as x -> sigma, x
+      ElimOnConstr (interp_constr_with_bindings ist env sigma c)
+  | ElimOnAnonHyp n as x -> x
   | ElimOnIdent (loc,id) ->
       try
-	sigma,
         match List.assoc id ist.lfun with
-	| VInteger n -> ElimOnAnonHyp n
-	| VIntroPattern (IntroIdentifier id) -> ElimOnIdent (loc,id)
-	| VConstr ([],c) -> ElimOnConstr (c,NoBindings)
+	| VInteger n ->
+	    ElimOnAnonHyp n
+	| VIntroPattern (IntroIdentifier id') ->
+	    if Tactics.is_quantified_hypothesis id' gl
+	    then ElimOnIdent (loc,id')
+	    else
+	      (try ElimOnConstr (sigma,(constr_of_id env id',NoBindings))
+	       with Not_found ->
+		user_err_loc (loc,"",
+		pr_id id ++ strbrk " binds to " ++ pr_id id' ++ strbrk " which is neither a declared or a quantified hypothesis."))
+	| VConstr ([],c) ->
+	    ElimOnConstr (sigma,(c,NoBindings))
 	| _ -> user_err_loc (loc,"",
 	      strbrk "Cannot coerce " ++ pr_id id ++
 	      strbrk " neither to a quantified hypothesis nor to a term.")
       with Not_found ->
-	(* Interactive mode *)
+	(* We were in non strict (interactive) mode *)
 	if Tactics.is_quantified_hypothesis id gl then
-          sigma, ElimOnIdent (loc,id)
+          ElimOnIdent (loc,id)
 	else
-          let c = interp_constr ist env sigma (RVar (loc,id),Some (CRef (Ident (loc,id)))) in
-          sigma, ElimOnConstr (c,NoBindings)
+          let c = (GVar (loc,id),Some (CRef (Ident (loc,id)))) in
+          let c = interp_constr ist env sigma c in
+          ElimOnConstr (sigma,(c,NoBindings))
 
 (* Associates variables with values and gives the remaining variables and
    values *)
@@ -1811,11 +1731,11 @@ let mk_int_or_var_value ist c = VInteger (interp_int_or_var ist c)
 
 let pack_sigma (sigma,c) = {it=c;sigma=sigma}
 
-let extend_gl_hyps gl sign =
- { gl with
-   it = { gl.it with
-     evar_hyps = 
-     List.fold_right Environ.push_named_context_val sign gl.it.evar_hyps } }
+let extend_gl_hyps { it=gl ; sigma=sigma } sign =
+  let hyps = Goal.V82.hyps sigma gl in
+  let new_hyps = List.fold_right Environ.push_named_context_val sign hyps in
+  (* spiwack: (2010/01/13) if a bug was reintroduced in [change] in is probably here *)
+  Goal.V82.new_goal_with sigma gl new_hyps
 
 (* Interprets an l-tac expression into a value *)
 let rec val_interp ist gl (tac:glob_tactic_expr) =
@@ -1827,7 +1747,7 @@ let rec val_interp ist gl (tac:glob_tactic_expr) =
   | TacLetIn (false,l,u) -> interp_letin ist gl l u
   | TacMatchGoal (lz,lr,lmr) -> interp_match_goal ist gl lz lr lmr
   | TacMatch (lz,c,lmr) -> interp_match ist gl lz c lmr
-  | TacArg a -> interp_tacarg ist gl a
+  | TacArg (loc,a) -> interp_tacarg ist gl a
   (* Delayed evaluation *)
   | t -> VFun (ist.trace,ist.lfun,[],t)
 
@@ -1860,6 +1780,7 @@ and eval_tactic ist = function
 	(Array.map (interp_tactic ist) tf) (interp_tactic ist t) (Array.map (interp_tactic ist) tl)
   | TacThens (t1,tl) -> tclTHENS (interp_tactic ist t1) (List.map (interp_tactic ist) tl)
   | TacDo (n,tac) -> tclDO (interp_int_or_var ist n) (interp_tactic ist tac)
+  | TacTimeout (n,tac) -> tclTIMEOUT (interp_int_or_var ist n) (interp_tactic ist tac)
   | TacTry tac -> tclTRY (interp_tactic ist tac)
   | TacInfo tac ->
       let t = (interp_tactic ist tac) in
@@ -1867,7 +1788,7 @@ and eval_tactic ist = function
 	  begin
 	    match tac with
 		TacAtom (_,_) -> t
-	      | _ -> abstract_tactic_expr (TacArg (Tacexp tac)) t
+	      | _ -> abstract_tactic_expr (TacArg (dloc,Tacexp tac)) t
 	  end
   | TacRepeat tac -> tclREPEAT (interp_tactic ist tac)
   | TacOrelse (tac1,tac2) ->
@@ -1979,19 +1900,19 @@ and eval_with_fail ist is_lazy goal tac =
 	VRTactic (catch_error trace tac goal)
     | a -> a)
   with
-    | FailError (0,s) | Stdpp.Exc_located(_, FailError (0,s))
-    | Stdpp.Exc_located(_,LtacLocated (_,FailError (0,s))) ->
+    | FailError (0,s) | Loc.Exc_located(_, FailError (0,s))
+    | Loc.Exc_located(_,LtacLocated (_,FailError (0,s))) ->
 	raise (Eval_fail (Lazy.force s))
     | FailError (lvl,s) -> raise (FailError (lvl - 1, s))
-    | Stdpp.Exc_located(s,FailError (lvl,s')) ->
-	raise (Stdpp.Exc_located(s,FailError (lvl - 1, s')))
-    | Stdpp.Exc_located(s,LtacLocated (s'',FailError (lvl,s'))) ->
-	raise (Stdpp.Exc_located(s,LtacLocated (s'',FailError (lvl - 1, s'))))
+    | Loc.Exc_located(s,FailError (lvl,s')) ->
+	raise (Loc.Exc_located(s,FailError (lvl - 1, s')))
+    | Loc.Exc_located(s,LtacLocated (s'',FailError (lvl,s'))) ->
+	raise (Loc.Exc_located(s,LtacLocated (s'',FailError (lvl - 1, s'))))
 
 (* Interprets the clauses of a recursive LetIn *)
 and interp_letrec ist gl llc u =
   let lref = ref ist.lfun in
-  let lve = list_map_left (fun ((_,id),b) -> (id,VRec (lref,TacArg b))) llc in
+  let lve = list_map_left (fun ((_,id),b) -> (id,VRec (lref,TacArg (dloc,b)))) llc in
   lref := lve@ist.lfun;
   let ist = { ist with lfun = lve@ist.lfun } in
   val_interp ist gl u
@@ -2005,6 +1926,8 @@ and interp_letin ist gl llc u =
 
 (* Interprets the Match Context expressions *)
 and interp_match_goal ist goal lz lr lmr =
+  let (gl,sigma) = Goal.V82.nf_evar (project goal) (sig_it goal) in
+  let goal = { it = gl ; sigma = sigma } in
   let hyps = pf_hyps goal in
   let hyps = if lr then List.rev hyps else hyps in
   let concl = pf_concl goal in
@@ -2116,7 +2039,7 @@ and interp_genarg ist gl x =
       in_gen wit_sort
         (destSort
 	  (pf_interp_constr ist gl
-	    (RSort (dloc,out_gen globwit_sort x), None)))
+	    (GSort (dloc,out_gen globwit_sort x), None)))
   | ConstrArgType ->
       in_gen wit_constr (pf_interp_constr ist gl (out_gen globwit_constr x))
   | ConstrMayEvalArgType ->
@@ -2152,7 +2075,7 @@ and interp_genarg ist gl x =
       | Some n ->
           (* Special treatment of tactic arguments *)
           in_gen (wit_tactic n)
-	    (TacArg(valueIn(VFun(ist.trace,ist.lfun,[],
+	    (TacArg(dloc,valueIn(VFun(ist.trace,ist.lfun,[],
 				 out_gen (globwit_tactic n) x))))
       | None ->
           lookup_interp_genarg s ist gl x
@@ -2189,9 +2112,9 @@ and interp_match ist g lz constr lmr =
         match_next_pattern find_next' () in
     match_next_pattern (fun () -> match_subterm_gen app c csr) () in
   let rec apply_match ist csr = function
-    | (All t)::_ ->
+    | (All t)::tl ->
         (try eval_with_fail ist lz g t
-         with e when is_match_catchable e -> apply_match ist csr [])
+         with e when is_match_catchable e -> apply_match ist csr tl)
     | (Pat ([],Term c,mt))::tl ->
         (try
             let lmatch =
@@ -2337,23 +2260,31 @@ and interp_atomic ist gl tac =
   | TacGeneralizeDep c -> h_generalize_dep (pf_interp_constr ist gl c)
   | TacLetTac (na,c,clp,b) ->
       let clp = interp_clause ist gl clp in
-      h_let_tac b (interp_fresh_name ist env na) (pf_interp_constr ist gl c) clp
+      if clp = nowhere then
+        (* We try to fully-typechect the term *)
+        h_let_tac b (interp_fresh_name ist env na)
+          (pf_interp_constr ist gl c) clp
+      else
+        (* We try to keep the pattern structure as much as possible *)
+        h_let_pat_tac b (interp_fresh_name ist env na)
+          (interp_pure_open_constr ist env sigma c) clp
 
   (* Automation tactics *)
   | TacTrivial (lems,l) ->
-      Auto.h_trivial (interp_constr_list ist env sigma lems)
+      Auto.h_trivial
+	(interp_auto_lemmas ist env sigma lems)
 	(Option.map (List.map (interp_hint_base ist)) l)
   | TacAuto (n,lems,l) ->
       Auto.h_auto (Option.map (interp_int_or_var ist) n)
-      (interp_constr_list ist env sigma lems)
-      (Option.map (List.map (interp_hint_base ist)) l)
+	(interp_auto_lemmas ist env sigma lems)
+	(Option.map (List.map (interp_hint_base ist)) l)
   | TacAutoTDB n -> Dhyp.h_auto_tdb n
   | TacDestructHyp (b,id) -> Dhyp.h_destructHyp b (interp_hyp ist gl id)
   | TacDestructConcl -> Dhyp.h_destructConcl
   | TacSuperAuto (n,l,b1,b2) -> Auto.h_superauto n l b1 b2
   | TacDAuto (n,p,lems) ->
       Auto.h_dauto (Option.map (interp_int_or_var ist) n,p)
-      (interp_constr_list ist env sigma lems)
+      (interp_auto_lemmas ist env sigma lems)
 
   (* Derived basic tactics *)
   | TacSimpleInductionDestruct (isrec,h) ->
@@ -2361,8 +2292,7 @@ and interp_atomic ist gl tac =
   | TacInductionDestruct (isrec,ev,(l,cls)) ->
       let sigma, l =
         list_fold_map (fun sigma (lc,cbo,(ipato,ipats)) ->
-          let sigma,lc =
-            list_fold_map (interp_induction_arg ist gl) sigma lc in
+          let lc = List.map (interp_induction_arg ist gl) lc in
 	  let sigma,cbo =
             Option.fold_map (interp_constr_with_bindings ist env) sigma cbo in
           (sigma,(lc,cbo,
@@ -2410,7 +2340,7 @@ and interp_atomic ist gl tac =
         (Tactics.any_constructor ev (Option.map (interp_tactic ist) t))
   | TacConstructor (ev,n,bl) ->
       let sigma, bl = interp_bindings ist env sigma bl in
-      tclWITHHOLES ev (h_constructor ev (skip_metaid n)) sigma bl
+      tclWITHHOLES ev (h_constructor ev (interp_int_or_var ist n)) sigma bl
 
   (* Conversion *)
   | TacReduce (r,cl) ->
@@ -2553,7 +2483,7 @@ let make_empty_glob_sign () =
 (* Initial call for interpretation *)
 let interp_tac_gen lfun avoid_ids debug t gl =
   interp_tactic { lfun=lfun; avoid_ids=avoid_ids; debug=debug; trace=[] }
-    (intern_tactic {
+    (intern_tactic true {
       ltacvars = (List.map fst lfun, []); ltacrecvars = [];
       gsigma = project gl; genv = pf_env gl } t) gl
 
@@ -2566,18 +2496,18 @@ let interp t = interp_tac_gen [] [] (get_debug()) t
 let eval_ltac_constr gl t =
   interp_ltac_constr
     { lfun=[]; avoid_ids=[]; debug=get_debug(); trace=[] } gl
-    (intern_tactic (make_empty_glob_sign ()) t )
+    (intern_tactic_or_tacarg (make_empty_glob_sign ()) t )
 
 (* Hides interpretation for pretty-print *)
 let hide_interp t ot gl =
   let ist = { ltacvars = ([],[]); ltacrecvars = [];
             gsigma = project gl; genv = pf_env gl } in
-  let te = intern_tactic ist t in
+  let te = intern_tactic true ist t in
   let t = eval_tactic te in
   match ot with
-  | None -> abstract_tactic_expr (TacArg (Tacexp te)) t gl
+  | None -> abstract_tactic_expr (TacArg (dloc,Tacexp te)) t gl
   | Some t' ->
-      abstract_tactic_expr ~dflt:true (TacArg (Tacexp te)) (tclTHEN t t') gl
+      abstract_tactic_expr ~dflt:true (TacArg (dloc,Tacexp te)) (tclTHEN t t') gl
 
 (***************************************************************************)
 (* Substitution at module closing time *)
@@ -2586,25 +2516,25 @@ let subst_quantified_hypothesis _ x = x
 
 let subst_declared_or_quantified_hypothesis _ x = x
 
-let subst_rawconstr_and_expr subst (c,e) =
+let subst_glob_constr_and_expr subst (c,e) =
   assert (e=None); (* e<>None only for toplevel tactics *)
-  (Detyping.subst_rawconstr subst c,None)
+  (Detyping.subst_glob_constr subst c,None)
 
-let subst_rawconstr = subst_rawconstr_and_expr (* shortening *)
+let subst_glob_constr = subst_glob_constr_and_expr (* shortening *)
 
 let subst_binding subst (loc,b,c) =
-  (loc,subst_quantified_hypothesis subst b,subst_rawconstr subst c)
+  (loc,subst_quantified_hypothesis subst b,subst_glob_constr subst c)
 
 let subst_bindings subst = function
   | NoBindings -> NoBindings
-  | ImplicitBindings l -> ImplicitBindings (List.map (subst_rawconstr subst) l)
+  | ImplicitBindings l -> ImplicitBindings (List.map (subst_glob_constr subst) l)
   | ExplicitBindings l -> ExplicitBindings (List.map (subst_binding subst) l)
 
-let subst_raw_with_bindings subst (c,bl) =
-  (subst_rawconstr subst c, subst_bindings subst bl)
+let subst_glob_with_bindings subst (c,bl) =
+  (subst_glob_constr subst c, subst_bindings subst bl)
 
 let subst_induction_arg subst = function
-  | ElimOnConstr c -> ElimOnConstr (subst_raw_with_bindings subst c)
+  | ElimOnConstr c -> ElimOnConstr (subst_glob_with_bindings subst c)
   | ElimOnAnonHyp n as x -> x
   | ElimOnIdent id as x -> x
 
@@ -2645,17 +2575,17 @@ let subst_unfold subst (l,e) =
 let subst_flag subst red =
   { red with rConst = List.map (subst_evaluable subst) red.rConst }
 
-let subst_constr_with_occurrences subst (l,c) = (l,subst_rawconstr subst c)
+let subst_constr_with_occurrences subst (l,c) = (l,subst_glob_constr subst c)
 
-let subst_rawconstr_or_pattern subst (c,p) =
-  (subst_rawconstr subst c,subst_pattern subst p)
+let subst_glob_constr_or_pattern subst (c,p) =
+  (subst_glob_constr subst c,subst_pattern subst p)
 
 let subst_pattern_with_occurrences subst (l,p) =
-  (l,subst_rawconstr_or_pattern subst p)
+  (l,subst_glob_constr_or_pattern subst p)
 
 let subst_redexp subst = function
   | Unfold l -> Unfold (List.map (subst_unfold subst) l)
-  | Fold l -> Fold (List.map (subst_rawconstr subst) l)
+  | Fold l -> Fold (List.map (subst_glob_constr subst) l)
   | Cbv f -> Cbv (subst_flag subst f)
   | Lazy f -> Lazy (subst_flag subst f)
   | Pattern l -> Pattern (List.map (subst_constr_with_occurrences subst) l)
@@ -2663,14 +2593,14 @@ let subst_redexp subst = function
   | (Red _ | Hnf | ExtraRedExpr _ | CbvVm as r) -> r
 
 let subst_raw_may_eval subst = function
-  | ConstrEval (r,c) -> ConstrEval (subst_redexp subst r,subst_rawconstr subst c)
-  | ConstrContext (locid,c) -> ConstrContext (locid,subst_rawconstr subst c)
-  | ConstrTypeOf c -> ConstrTypeOf (subst_rawconstr subst c)
-  | ConstrTerm c -> ConstrTerm (subst_rawconstr subst c)
+  | ConstrEval (r,c) -> ConstrEval (subst_redexp subst r,subst_glob_constr subst c)
+  | ConstrContext (locid,c) -> ConstrContext (locid,subst_glob_constr subst c)
+  | ConstrTypeOf c -> ConstrTypeOf (subst_glob_constr subst c)
+  | ConstrTerm c -> ConstrTerm (subst_glob_constr subst c)
 
 let subst_match_pattern subst = function
-  | Subterm (b,ido,pc) -> Subterm (b,ido,(subst_rawconstr_or_pattern subst pc))
-  | Term pc -> Term (subst_rawconstr_or_pattern subst pc)
+  | Subterm (b,ido,pc) -> Subterm (b,ido,(subst_glob_constr_or_pattern subst pc))
+  | Term pc -> Term (subst_glob_constr_or_pattern subst pc)
 
 let rec subst_match_goal_hyps subst = function
   | Hyp (locs,mp) :: tl ->
@@ -2685,54 +2615,54 @@ let rec subst_atomic subst (t:glob_atomic_tactic_expr) = match t with
   (* Basic tactics *)
   | TacIntroPattern _ | TacIntrosUntil _ | TacIntroMove _ as x -> x
   | TacAssumption as x -> x
-  | TacExact c -> TacExact (subst_rawconstr subst c)
-  | TacExactNoCheck c -> TacExactNoCheck (subst_rawconstr subst c)
-  | TacVmCastNoCheck c -> TacVmCastNoCheck (subst_rawconstr subst c)
+  | TacExact c -> TacExact (subst_glob_constr subst c)
+  | TacExactNoCheck c -> TacExactNoCheck (subst_glob_constr subst c)
+  | TacVmCastNoCheck c -> TacVmCastNoCheck (subst_glob_constr subst c)
   | TacApply (a,ev,cb,cl) ->
-      TacApply (a,ev,List.map (subst_raw_with_bindings subst) cb,cl)
+      TacApply (a,ev,List.map (subst_glob_with_bindings subst) cb,cl)
   | TacElim (ev,cb,cbo) ->
-      TacElim (ev,subst_raw_with_bindings subst cb,
-               Option.map (subst_raw_with_bindings subst) cbo)
-  | TacElimType c -> TacElimType (subst_rawconstr subst c)
-  | TacCase (ev,cb) -> TacCase (ev,subst_raw_with_bindings subst cb)
-  | TacCaseType c -> TacCaseType (subst_rawconstr subst c)
+      TacElim (ev,subst_glob_with_bindings subst cb,
+               Option.map (subst_glob_with_bindings subst) cbo)
+  | TacElimType c -> TacElimType (subst_glob_constr subst c)
+  | TacCase (ev,cb) -> TacCase (ev,subst_glob_with_bindings subst cb)
+  | TacCaseType c -> TacCaseType (subst_glob_constr subst c)
   | TacFix (idopt,n) as x -> x
   | TacMutualFix (b,id,n,l) ->
-      TacMutualFix(b,id,n,List.map (fun (id,n,c) -> (id,n,subst_rawconstr subst c)) l)
+      TacMutualFix(b,id,n,List.map (fun (id,n,c) -> (id,n,subst_glob_constr subst c)) l)
   | TacCofix idopt as x -> x
   | TacMutualCofix (b,id,l) ->
-      TacMutualCofix (b,id, List.map (fun (id,c) -> (id,subst_rawconstr subst c)) l)
-  | TacCut c -> TacCut (subst_rawconstr subst c)
+      TacMutualCofix (b,id, List.map (fun (id,c) -> (id,subst_glob_constr subst c)) l)
+  | TacCut c -> TacCut (subst_glob_constr subst c)
   | TacAssert (b,na,c) ->
-      TacAssert (Option.map (subst_tactic subst) b,na,subst_rawconstr subst c)
+      TacAssert (Option.map (subst_tactic subst) b,na,subst_glob_constr subst c)
   | TacGeneralize cl ->
       TacGeneralize (List.map (on_fst (subst_constr_with_occurrences subst))cl)
-  | TacGeneralizeDep c -> TacGeneralizeDep (subst_rawconstr subst c)
-  | TacLetTac (id,c,clp,b) -> TacLetTac (id,subst_rawconstr subst c,clp,b)
+  | TacGeneralizeDep c -> TacGeneralizeDep (subst_glob_constr subst c)
+  | TacLetTac (id,c,clp,b) -> TacLetTac (id,subst_glob_constr subst c,clp,b)
 
   (* Automation tactics *)
-  | TacTrivial (lems,l) -> TacTrivial (List.map (subst_rawconstr subst) lems,l)
-  | TacAuto (n,lems,l) -> TacAuto (n,List.map (subst_rawconstr subst) lems,l)
+  | TacTrivial (lems,l) -> TacTrivial (List.map (subst_glob_constr subst) lems,l)
+  | TacAuto (n,lems,l) -> TacAuto (n,List.map (subst_glob_constr subst) lems,l)
   | TacAutoTDB n -> TacAutoTDB n
   | TacDestructHyp (b,id) -> TacDestructHyp(b,id)
   | TacDestructConcl -> TacDestructConcl
   | TacSuperAuto (n,l,b1,b2) -> TacSuperAuto (n,l,b1,b2)
-  | TacDAuto (n,p,lems) -> TacDAuto (n,p,List.map (subst_rawconstr subst) lems)
+  | TacDAuto (n,p,lems) -> TacDAuto (n,p,List.map (subst_glob_constr subst) lems)
 
   (* Derived basic tactics *)
   | TacSimpleInductionDestruct (isrec,h) as x -> x
   | TacInductionDestruct (isrec,ev,(l,cls)) ->
       TacInductionDestruct (isrec,ev,(List.map (fun (lc,cbo,ids) ->
 	List.map (subst_induction_arg subst) lc,
-        Option.map (subst_raw_with_bindings subst) cbo, ids) l, cls))
+        Option.map (subst_glob_with_bindings subst) cbo, ids) l, cls))
   | TacDoubleInduction (h1,h2) as x -> x
-  | TacDecomposeAnd c -> TacDecomposeAnd (subst_rawconstr subst c)
-  | TacDecomposeOr c -> TacDecomposeOr (subst_rawconstr subst c)
+  | TacDecomposeAnd c -> TacDecomposeAnd (subst_glob_constr subst c)
+  | TacDecomposeOr c -> TacDecomposeOr (subst_glob_constr subst c)
   | TacDecompose (l,c) ->
       let l = List.map (subst_or_var (subst_inductive subst)) l in
-      TacDecompose (l,subst_rawconstr subst c)
-  | TacSpecialize (n,l) -> TacSpecialize (n,subst_raw_with_bindings subst l)
-  | TacLApply c -> TacLApply (subst_rawconstr subst c)
+      TacDecompose (l,subst_glob_constr subst c)
+  | TacSpecialize (n,l) -> TacSpecialize (n,subst_glob_with_bindings subst l)
+  | TacLApply c -> TacLApply (subst_glob_constr subst c)
 
   (* Context management *)
   | TacClear _ as x -> x
@@ -2751,24 +2681,24 @@ let rec subst_atomic subst (t:glob_atomic_tactic_expr) = match t with
   (* Conversion *)
   | TacReduce (r,cl) -> TacReduce (subst_redexp subst r, cl)
   | TacChange (op,c,cl) ->
-      TacChange (Option.map (subst_rawconstr_or_pattern subst) op,
-        subst_rawconstr subst c, cl)
+      TacChange (Option.map (subst_glob_constr_or_pattern subst) op,
+        subst_glob_constr subst c, cl)
 
   (* Equivalence relations *)
   | TacReflexivity | TacSymmetry _ as x -> x
-  | TacTransitivity c -> TacTransitivity (Option.map (subst_rawconstr subst) c)
+  | TacTransitivity c -> TacTransitivity (Option.map (subst_glob_constr subst) c)
 
   (* Equality and inversion *)
   | TacRewrite (ev,l,cl,by) ->
       TacRewrite (ev,
 		  List.map (fun (b,m,c) ->
-			      b,m,subst_raw_with_bindings subst c) l,
+			      b,m,subst_glob_with_bindings subst c) l,
 		 cl,Option.map (subst_tactic subst) by)
   | TacInversion (DepInversion (k,c,l),hyp) ->
-     TacInversion (DepInversion (k,Option.map (subst_rawconstr subst) c,l),hyp)
+     TacInversion (DepInversion (k,Option.map (subst_glob_constr subst) c,l),hyp)
   | TacInversion (NonDepInversion _,_) as x -> x
   | TacInversion (InversionUsing (c,cl),hyp) ->
-      TacInversion (InversionUsing (subst_rawconstr subst c,cl),hyp)
+      TacInversion (InversionUsing (subst_glob_constr subst c,cl),hyp)
 
   (* For extensions *)
   | TacExtend (_loc,opn,l) ->
@@ -2796,6 +2726,7 @@ and subst_tactic subst (t:glob_tactic_expr) = match t with
   | TacThens (t,tl) ->
       TacThens (subst_tactic subst t, List.map (subst_tactic subst) tl)
   | TacDo (n,tac) -> TacDo (n,subst_tactic subst tac)
+  | TacTimeout (n,tac) -> TacTimeout (n,subst_tactic subst tac)
   | TacTry tac -> TacTry (subst_tactic subst tac)
   | TacInfo tac -> TacInfo (subst_tactic subst tac)
   | TacRepeat tac -> TacRepeat (subst_tactic subst tac)
@@ -2804,7 +2735,7 @@ and subst_tactic subst (t:glob_tactic_expr) = match t with
   | TacFirst l -> TacFirst (List.map (subst_tactic subst) l)
   | TacSolve l -> TacSolve (List.map (subst_tactic subst) l)
   | TacComplete tac -> TacComplete (subst_tactic subst tac)
-  | TacArg a -> TacArg (subst_tacarg subst a)
+  | TacArg (_,a) -> TacArg (dloc,subst_tacarg subst a)
 
 and subst_tactic_fun subst (var,body) = (var,subst_tactic subst body)
 
@@ -2855,7 +2786,7 @@ and subst_genarg subst (x:glob_generic_argument) =
   | SortArgType ->
       in_gen globwit_sort (out_gen globwit_sort x)
   | ConstrArgType ->
-      in_gen globwit_constr (subst_rawconstr subst (out_gen globwit_constr x))
+      in_gen globwit_constr (subst_glob_constr subst (out_gen globwit_constr x))
   | ConstrMayEvalArgType ->
       in_gen globwit_constr_may_eval (subst_raw_may_eval subst (out_gen globwit_constr_may_eval x))
   | QuantHypArgType ->
@@ -2866,10 +2797,10 @@ and subst_genarg subst (x:glob_generic_argument) =
       in_gen globwit_red_expr (subst_redexp subst (out_gen globwit_red_expr x))
   | OpenConstrArgType b ->
       in_gen (globwit_open_constr_gen b)
-        ((),subst_rawconstr subst (snd (out_gen (globwit_open_constr_gen b) x)))
+        ((),subst_glob_constr subst (snd (out_gen (globwit_open_constr_gen b) x)))
   | ConstrWithBindingsArgType ->
       in_gen globwit_constr_with_bindings
-        (subst_raw_with_bindings subst (out_gen globwit_constr_with_bindings x))
+        (subst_glob_with_bindings subst (out_gen globwit_constr_with_bindings x))
   | BindingsArgType ->
       in_gen globwit_bindings
         (subst_bindings subst (out_gen globwit_bindings x))
@@ -2889,11 +2820,6 @@ and subst_genarg subst (x:glob_generic_argument) =
 (***************************************************************************)
 (* Tactic registration *)
 
-(* For bad tactic calls *)
-let bad_tactic_args s =
-  anomalylabstrm s
-    (str "Tactic " ++ str s ++ str " called with bad arguments")
-
 (* Declaration of the TAC-DEFINITION object *)
 let add (kn,td) = mactab := Gmap.add kn td !mactab
 let replace (kn,td) = mactab := Gmap.add kn td (Gmap.remove kn !mactab)
@@ -2938,7 +2864,7 @@ let subst_md (subst,(local,defs)) =
 let classify_md (local,defs as o) =
   if local then Dispose else Substitute o
 
-let (inMD,outMD) =
+let inMD : bool * (tacdef_kind * glob_tactic_expr) list -> obj =
   declare_object {(default_object "TAC-DEFINITION") with
      cache_function  = cache_md;
      load_function   = load_md;
@@ -2946,12 +2872,22 @@ let (inMD,outMD) =
      subst_function = subst_md;
      classify_function = classify_md}
 
+let rec split_ltac_fun = function
+  | TacFun (l,t) -> (l,t)
+  | t -> ([],t)
+
+let pr_ltac_fun_arg = function
+  | None -> spc () ++ str "_"
+  | Some id -> spc () ++ pr_id id
+
 let print_ltac id =
  try
   let kn = Nametab.locate_tactic id in
-  let t = lookup kn in
-   str "Ltac" ++ spc() ++ pr_qualid id ++ str " :=" ++ spc() ++
-    Pptactic.pr_glob_tactic (Global.env ()) t
+  let l,t = split_ltac_fun (lookup kn) in
+  hv 2 (
+    hov 2 (str "Ltac" ++ spc() ++ pr_qualid id ++
+           prlist pr_ltac_fun_arg l ++ spc () ++ str ":=")
+    ++ spc() ++ Pptactic.pr_glob_tactic (Global.env ()) t)
  with
   Not_found ->
    errorlabstrm "print_ltac"
@@ -2991,7 +2927,7 @@ let add_tacdef local isrec tacl =
   let gtacl =
     List.map2 (fun (_,b,def) (id, qid) ->
       let k = if b then UpdateTac qid else NewTac (Option.get id) in
-      let t = Flags.with_option strict_check (intern_tactic ist) def in
+      let t = Flags.with_option strict_check (intern_tactic_or_tacarg ist) def in
 	(k, t))
       tacl rfun in
   let id0 = fst (List.hd rfun) in
@@ -3009,11 +2945,11 @@ let add_tacdef local isrec tacl =
 (* Other entry points *)
 
 let glob_tactic x =
-  Flags.with_option strict_check (intern_tactic (make_empty_glob_sign ())) x
+  Flags.with_option strict_check (intern_tactic true (make_empty_glob_sign ())) x
 
 let glob_tactic_env l env x =
   Flags.with_option strict_check
-  (intern_tactic
+  (intern_pure_tactic
     { ltacvars = (l,[]); ltacrecvars = []; gsigma = Evd.empty; genv = env })
     x
 
@@ -3025,14 +2961,16 @@ let interp_redexp env sigma r =
 (***************************************************************************)
 (* Embed tactics in raw or glob tactic expr *)
 
-let globTacticIn t = TacArg (TacDynamic (dummy_loc,tactic_in t))
+let globTacticIn t = TacArg (dloc,TacDynamic (dloc,tactic_in t))
 let tacticIn t =
   globTacticIn (fun ist ->
     try glob_tactic (t ist)
-    with e -> raise (AnomalyOnError ("Incorrect tactic expression", e)))
+    with e -> anomalylabstrm "tacticIn"
+      (str "Incorrect tactic expression. Received exception is:" ++
+       Errors.print e))
 
 let tacticOut = function
-  | TacArg (TacDynamic (_,d)) ->
+  | TacArg (_,TacDynamic (_,d)) ->
     if (Dyn.tag d) = "tactic" then
       tactic_out d
     else
@@ -3051,6 +2989,6 @@ let _ = Auto.set_extern_interp
 let _ = Auto.set_extern_intern_tac
   (fun l ->
     Flags.with_option strict_check
-    (intern_tactic {(make_empty_glob_sign()) with ltacvars=(l,[])}))
+    (intern_pure_tactic {(make_empty_glob_sign()) with ltacvars=(l,[])}))
 let _ = Auto.set_extern_subst_tactic subst_tactic
 let _ = Dhyp.set_extern_interp eval_tactic
diff --git a/tactics/tacinterp.mli b/tactics/tacinterp.mli
index 8f585781..d9dc8094 100644
--- a/tactics/tacinterp.mli
+++ b/tactics/tacinterp.mli
@@ -1,14 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: tacinterp.mli 14677 2011-11-17 22:19:38Z herbelin $ i*)
-
-(*i*)
 open Pp
 open Util
 open Names
@@ -21,11 +18,10 @@ open Genarg
 open Topconstr
 open Mod_subst
 open Redexpr
-(*i*)
 
-(* Values for interpretation *)
+(** Values for interpretation *)
 type value =
-  | VRTactic of (goal list sigma * validation)
+  | VRTactic of (goal list sigma)
   | VFun of ltac_trace * (identifier*value) list *
       identifier option list * glob_tactic_expr
   | VVoid
@@ -36,7 +32,7 @@ type value =
   | VList of value list
   | VRec of (identifier*value) list ref * glob_tactic_expr
 
-(* Signature for interpretation: val\_interp and interpretation functions *)
+(** Signature for interpretation: val\_interp and interpretation functions *)
 and interp_sign =
   { lfun : (identifier * value) list;
     avoid_ids : identifier list;
@@ -46,31 +42,27 @@ and interp_sign =
 val extract_ltac_constr_values : interp_sign -> Environ.env ->
   Pretyping.ltac_var_map
 
-(* Transforms an id into a constr if possible *)
-val constr_of_id : Environ.env -> identifier -> constr
-
-(* To embed several objects in Coqast.t *)
+(** To embed several objects in Coqast.t *)
 val tactic_in : (interp_sign -> glob_tactic_expr) -> Dyn.t
 val tactic_out : Dyn.t -> (interp_sign -> glob_tactic_expr)
 
 val tacticIn : (interp_sign -> raw_tactic_expr) -> raw_tactic_expr
 val globTacticIn : (interp_sign -> glob_tactic_expr) -> raw_tactic_expr
 val valueIn : value -> raw_tactic_arg
-val constrIn : constr -> constr_expr
 
-(* Sets the debugger mode *)
+(** Sets the debugger mode *)
 val set_debug : debug_info -> unit
 
-(* Gives the state of debug *)
+(** Gives the state of debug *)
 val get_debug : unit -> debug_info
 
-(* Adds a definition for tactics in the table *)
+(** Adds a definition for tactics in the table *)
 val add_tacdef :
   Vernacexpr.locality_flag -> bool ->
   (Libnames.reference * bool * raw_tactic_expr) list -> unit
 val add_primitive_tactic : string -> glob_tactic_expr -> unit
 
-(* Tactic extensions *)
+(** Tactic extensions *)
 val add_tactic :
   string -> (typed_generic_argument list -> tactic) -> unit
 val overwriting_add_tactic :
@@ -78,7 +70,7 @@ val overwriting_add_tactic :
 val lookup_tactic :
   string -> (typed_generic_argument list) -> tactic
 
-(* Adds an interpretation function for extra generic arguments *)
+(** Adds an interpretation function for extra generic arguments *)
 type glob_sign = {
   ltacvars : identifier list * identifier list;
   ltacrecvars : (identifier * Nametab.ltac_constant) list;
@@ -99,18 +91,15 @@ val interp_genarg :
 val intern_genarg :
   glob_sign -> raw_generic_argument -> glob_generic_argument
 
-val intern_tactic :
-  glob_sign -> raw_tactic_expr -> glob_tactic_expr
-
 val intern_pure_tactic :
   glob_sign -> raw_tactic_expr -> glob_tactic_expr
 
 val intern_constr :
-  glob_sign -> constr_expr -> rawconstr_and_expr
+  glob_sign -> constr_expr -> glob_constr_and_expr
 
 val intern_constr_with_bindings :
-  glob_sign -> constr_expr * constr_expr Rawterm.bindings ->
-  rawconstr_and_expr * rawconstr_and_expr Rawterm.bindings
+  glob_sign -> constr_expr * constr_expr Glob_term.bindings ->
+  glob_constr_and_expr * glob_constr_and_expr Glob_term.bindings
 
 val intern_hyp :
   glob_sign -> identifier Util.located -> identifier Util.located
@@ -118,28 +107,34 @@ val intern_hyp :
 val subst_genarg :
   substitution -> glob_generic_argument -> glob_generic_argument
 
-val subst_rawconstr_and_expr :
-  substitution -> rawconstr_and_expr -> rawconstr_and_expr
+val subst_glob_constr_and_expr :
+  substitution -> glob_constr_and_expr -> glob_constr_and_expr
 
-(* Interprets any expression *)
+val subst_glob_with_bindings :
+  substitution -> glob_constr_and_expr Glob_term.with_bindings -> glob_constr_and_expr Glob_term.with_bindings
+
+(** Interprets any expression *)
 val val_interp : interp_sign -> goal sigma -> glob_tactic_expr -> value
 
-(* Interprets an expression that evaluates to a constr *)
+(** Interprets an expression that evaluates to a constr *)
 val interp_ltac_constr : interp_sign -> goal sigma -> glob_tactic_expr ->
   constr
 
-(* Interprets redexp arguments *)
+(** Interprets redexp arguments *)
 val interp_redexp : Environ.env -> Evd.evar_map -> raw_red_expr -> red_expr
 
-(* Interprets tactic expressions *)
+(** Interprets tactic expressions *)
 val interp_tac_gen : (identifier * value) list -> identifier list ->
                  debug_info -> raw_tactic_expr -> tactic
 
 val interp_hyp :  interp_sign -> goal sigma -> identifier located -> identifier
 
-val interp_bindings : interp_sign -> Environ.env -> Evd.evar_map -> rawconstr_and_expr Rawterm.bindings -> Evd.evar_map * constr Rawterm.bindings
+val interp_bindings : interp_sign -> Environ.env -> Evd.evar_map -> glob_constr_and_expr Glob_term.bindings -> Evd.evar_map * constr Glob_term.bindings
+
+val interp_open_constr_with_bindings : interp_sign -> Environ.env -> Evd.evar_map -> 
+  glob_constr_and_expr Glob_term.with_bindings -> Evd.evar_map * constr Glob_term.with_bindings
 
-(* Initial call for interpretation *)
+(** Initial call for interpretation *)
 val glob_tactic : raw_tactic_expr -> glob_tactic_expr
 
 val glob_tactic_env : identifier list -> Environ.env -> raw_tactic_expr -> glob_tactic_expr
@@ -152,21 +147,18 @@ val eval_ltac_constr : goal sigma -> raw_tactic_expr -> constr
 
 val subst_tactic : substitution -> glob_tactic_expr -> glob_tactic_expr
 
-(* Hides interpretation for pretty-print *)
+(** Hides interpretation for pretty-print *)
 
 val hide_interp : raw_tactic_expr -> tactic option -> tactic
 
-(* Declare the default tactic to fill implicit arguments *)
-val declare_implicit_tactic : tactic -> unit
-
-(* Declare the xml printer *)
+(** Declare the xml printer *)
 val declare_xml_printer :
   (out_channel -> Environ.env -> Evd.evar_map -> constr -> unit) -> unit
 
-(* printing *)
+(** printing *)
 val print_ltac : Libnames.qualid -> std_ppcmds
 
-(* Internals that can be useful for syntax extensions. *)
+(** Internals that can be useful for syntax extensions. *)
 
 exception CannotCoerceTo of string
 
@@ -175,4 +167,3 @@ val interp_ltac_var : (value -> 'a) -> interp_sign -> Environ.env option -> iden
 val interp_int : interp_sign -> identifier located -> int
 
 val error_ltac_variable : loc -> identifier -> Environ.env option -> value -> string -> 'a
-
diff --git a/tactics/tactic_option.ml b/tactics/tactic_option.ml
index df5a3283..57b8c540 100644
--- a/tactics/tactic_option.ml
+++ b/tactics/tactic_option.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: subtac.ml 12623 2010-01-04 17:50:38Z letouzey $ *)
-
 open Libobject
 open Proof_type
 open Pp
@@ -27,7 +25,7 @@ let declare_tactic_option ?(default=Tacexpr.TacId []) name =
   let subst (s, (local, tac)) =
     (local, Tacinterp.subst_tactic s tac)
   in
-  let input, _output = 
+  let input : bool * Tacexpr.glob_tactic_expr -> obj =
     declare_object
       { (default_object name) with
 	cache_function = cache;
diff --git a/tactics/tactic_option.mli b/tactics/tactic_option.mli
index 890ba98e..8388738a 100644
--- a/tactics/tactic_option.mli
+++ b/tactics/tactic_option.mli
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: subtac.ml 12623 2010-01-04 17:50:38Z letouzey $ *)
-
 open Proof_type
 open Tacexpr
 open Vernacexpr
diff --git a/tactics/tacticals.ml b/tactics/tacticals.ml
index f0d4dc51..11625cbd 100644
--- a/tactics/tacticals.ml
+++ b/tactics/tacticals.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: tacticals.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Pp
 open Util
 open Names
@@ -23,7 +21,7 @@ open Refiner
 open Tacmach
 open Clenv
 open Clenvtac
-open Rawterm
+open Glob_term
 open Pattern
 open Matching
 open Genarg
@@ -61,8 +59,9 @@ let tclAT_LEAST_ONCE = Refiner.tclAT_LEAST_ONCE
 let tclFAIL          = Refiner.tclFAIL
 let tclFAIL_lazy     = Refiner.tclFAIL_lazy
 let tclDO            = Refiner.tclDO
-let tclPROGRESS      = Refiner.tclPROGRESS
+let tclTIMEOUT       = Refiner.tclTIMEOUT
 let tclWEAK_PROGRESS = Refiner.tclWEAK_PROGRESS
+let tclPROGRESS      = Refiner.tclPROGRESS
 let tclNOTSAMEGOAL   = Refiner.tclNOTSAMEGOAL
 let tclTHENTRY       = Refiner.tclTHENTRY
 let tclIFTHENELSE    = Refiner.tclIFTHENELSE
@@ -173,12 +172,9 @@ let fullGoal gl = None :: List.map Option.make (pf_ids_of_hyps gl)
 
 let onAllHyps tac gl = tclMAP tac (pf_ids_of_hyps gl) gl
 let onAllHypsAndConcl tac gl = tclMAP tac (fullGoal gl) gl
-let onAllHypsAndConclLR tac gl = tclMAP tac (List.rev (fullGoal gl)) gl
 
 let tryAllHyps tac gl = tclFIRST_PROGRESS_ON tac (pf_ids_of_hyps gl) gl
 let tryAllHypsAndConcl tac gl = tclFIRST_PROGRESS_ON tac (fullGoal gl) gl
-let tryAllHypsAndConclLR tac gl =
-  tclFIRST_PROGRESS_ON tac (List.rev (fullGoal gl)) gl
 
 let onClause tac cl gls = tclMAP tac (simple_clause_of cl gls) gls
 let onClauseLR tac cl gls = tclMAP tac (List.rev (simple_clause_of cl gls)) gls
@@ -292,7 +288,7 @@ let compute_construtor_signatures isrec (_,k as ity) =
     | Prod (_,_,c), recarg::rest ->
 	let b = match dest_recarg recarg with
 	  | Norec | Imbr _  -> false
-	  | Mrec j  -> isrec & j=k
+	  | Mrec (_,j)  -> isrec & j=k
 	in b :: (analrec c rest)
     | LetIn (_,_,_,c), rest -> false :: (analrec c rest)
     | _, [] -> []
@@ -367,7 +363,8 @@ let general_elim_then_using mk_elim
     match predicate with
        | None   -> elimclause'
        | Some p ->
-           clenv_unify true Reduction.CONV (mkMeta pmv) p elimclause'
+           clenv_unify ~flags:Unification.elim_flags
+             Reduction.CONV (mkMeta pmv) p elimclause'
   in
   elim_res_pf_THEN_i elimclause' branchtacs gl
 
diff --git a/tactics/tacticals.mli b/tactics/tacticals.mli
index 6466ab78..db9ab0c9 100644
--- a/tactics/tacticals.mli
+++ b/tactics/tacticals.mli
@@ -1,14 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: tacticals.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Pp
 open Util
 open Names
@@ -22,10 +19,9 @@ open Pattern
 open Genarg
 open Tacexpr
 open Termops
-open Rawterm
-(*i*)
+open Glob_term
 
-(* Tacticals i.e. functions from tactics to tactics. *)
+(** Tacticals i.e. functions from tactics to tactics. *)
 
 val tclNORMEVAR      : tactic
 val tclIDTAC         : tactic
@@ -55,8 +51,8 @@ val tclAT_LEAST_ONCE : tactic -> tactic
 val tclFAIL          : int -> std_ppcmds -> tactic
 val tclFAIL_lazy     : int -> std_ppcmds Lazy.t -> tactic
 val tclDO            : int -> tactic -> tactic
-val tclPROGRESS      : tactic -> tactic
 val tclWEAK_PROGRESS : tactic -> tactic
+val tclPROGRESS      : tactic -> tactic
 val tclNOTSAMEGOAL   : tactic -> tactic
 val tclTHENTRY       : tactic -> tactic -> tactic
 val tclMAP           : ('a -> tactic) -> 'a list -> tactic
@@ -68,7 +64,7 @@ val tclIFTHENTRYELSEMUST : tactic -> tactic -> tactic
 
 val tclFIRST_PROGRESS_ON : ('a -> tactic) -> 'a list -> tactic
 
-(*s Tacticals applying to hypotheses *)
+(** {6 Tacticals applying to hypotheses } *)
 
 val onNthHypId       : int -> (identifier -> tactic) -> tactic
 val onNthHyp         : int -> (constr -> tactic) -> tactic
@@ -96,14 +92,14 @@ val ifOnHyp     : (identifier * types -> bool) ->
 val onHyps      : (goal sigma -> named_context) ->
                   (named_context -> tactic) -> tactic
 
-(*s Tacticals applying to goal components *)
+(** {6 Tacticals applying to goal components } *)
 
-(* A [simple_clause] is a set of hypotheses, possibly extended with
+(** A [simple_clause] is a set of hypotheses, possibly extended with
    the conclusion (conclusion is represented by None) *)
 
 type simple_clause = identifier option list
 
-(* A [clause] denotes occurrences and hypotheses in a
+(** A [clause] denotes occurrences and hypotheses in a
    goal; in particular, it can abstractly refer to the set of
    hypotheses independently of the effective contents of the current goal *)
 
@@ -121,26 +117,25 @@ val tryAllHypsAndConcl  : (identifier option -> tactic) -> tactic
 
 val onAllHyps           : (identifier -> tactic) -> tactic
 val onAllHypsAndConcl   : (identifier option -> tactic) -> tactic
-val onAllHypsAndConclLR : (identifier option -> tactic) -> tactic
 
 val onClause   : (identifier option -> tactic) -> clause -> tactic
 val onClauseLR : (identifier option -> tactic) -> clause -> tactic
 
-(*s An intermediate form of occurrence clause with no mention of occurrences *)
+(** {6 An intermediate form of occurrence clause with no mention of occurrences } *)
 
-(* A [hyp_location] is an hypothesis together with a position, in
+(** A [hyp_location] is an hypothesis together with a position, in
    body if any, in type or in both *)
 
 type hyp_location = identifier * hyp_location_flag
 
-(* A [goal_location] is either an hypothesis (together with a position, in
+(** A [goal_location] is either an hypothesis (together with a position, in
    body if any, in type or in both) or the goal *)
 
 type goal_location = hyp_location option
 
-(*s A concrete view of occurrence clauses *)
+(** {6 A concrete view of occurrence clauses } *)
 
-(* [clause_atom] refers either to an hypothesis location (i.e. an
+(** [clause_atom] refers either to an hypothesis location (i.e. an
    hypothesis with occurrences and a position, in body if any, in type
    or in both) or to some occurrences of the conclusion *)
 
@@ -148,40 +143,40 @@ type clause_atom =
   | OnHyp of identifier * occurrences_expr * hyp_location_flag
   | OnConcl of occurrences_expr
 
-(* A [concrete_clause] is an effective collection of
+(** A [concrete_clause] is an effective collection of
   occurrences in the hypotheses and the conclusion *)
 
 type concrete_clause = clause_atom list
 
-(* This interprets an [clause] in a given [goal] context *)
+(** This interprets an [clause] in a given [goal] context *)
 val concrete_clause_of : clause -> goal sigma -> concrete_clause
 
-(*s Elimination tacticals. *)
+(** {6 Elimination tacticals. } *)
 
 type branch_args = {
-  ity        : inductive;   (* the type we were eliminating on *)
-  largs      : constr list; (* its arguments *)
-  branchnum  : int;         (* the branch number *)
-  pred       : constr;      (* the predicate we used *)
-  nassums    : int;         (* the number of assumptions to be introduced *)
-  branchsign : bool list;   (* the signature of the branch.
+  ity        : inductive;   (** the type we were eliminating on *)
+  largs      : constr list; (** its arguments *)
+  branchnum  : int;         (** the branch number *)
+  pred       : constr;      (** the predicate we used *)
+  nassums    : int;         (** the number of assumptions to be introduced *)
+  branchsign : bool list;   (** the signature of the branch.
                                true=recursive argument, false=constant *)
   branchnames : intro_pattern_expr located list}
 
 type branch_assumptions = {
-  ba        : branch_args;     (* the branch args *)
-  assums    : named_context}   (* the list of assumptions introduced *)
+  ba        : branch_args;     (** the branch args *)
+  assums    : named_context}   (** the list of assumptions introduced *)
 
-(* [check_disjunctive_pattern_size loc pats n] returns an appropriate *)
-(* error message if |pats| <> n *)
+(** [check_disjunctive_pattern_size loc pats n] returns an appropriate 
+   error message if |pats| <> n *)
 val check_or_and_pattern_size :
   Util.loc -> or_and_intro_pattern_expr -> int -> unit
 
-(* Tolerate "[]" to mean a disjunctive pattern of any length *)
+(** Tolerate "[]" to mean a disjunctive pattern of any length *)
 val fix_empty_or_and_pattern : int -> or_and_intro_pattern_expr ->
   or_and_intro_pattern_expr
 
-(* Useful for [as intro_pattern] modifier *)
+(** Useful for [as intro_pattern] modifier *)
 val compute_induction_names :
   int -> intro_pattern_expr located option ->
     intro_pattern_expr located list array
diff --git a/tactics/tactics.ml b/tactics/tactics.ml
index 186b5c48..988d9f53 100644
--- a/tactics/tactics.ml
+++ b/tactics/tactics.ml
@@ -1,13 +1,12 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: tactics.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
+open Compat
 open Pp
 open Util
 open Names
@@ -25,9 +24,8 @@ open Libnames
 open Evd
 open Pfedit
 open Tacred
-open Rawterm
+open Glob_term
 open Tacmach
-open Proof_trees
 open Proof_type
 open Logic
 open Evar_refiner
@@ -61,6 +59,8 @@ let inj_with_occurrences e = (all_occurrences_expr,e)
 
 let dloc = dummy_loc
 
+let typ_of = Retyping.get_type_of
+
 (* Option for 8.2 compatibility *)
 open Goptions
 let dependent_propositions_elimination = ref true
@@ -72,25 +72,15 @@ let use_dependent_propositions_elimination () =
 let _ =
   declare_bool_option
     { optsync  = true;
+      optdepr  = false;
       optname  = "dependent-propositions-elimination tactic";
       optkey   = ["Dependent";"Propositions";"Elimination"];
       optread  = (fun () -> !dependent_propositions_elimination) ;
       optwrite = (fun b -> dependent_propositions_elimination := b) }
 
-let apply_in_side_conditions_come_first = ref true
-
-let use_apply_in_side_conditions_come_first () =
-  !apply_in_side_conditions_come_first
-  && Flags.version_strictly_greater Flags.V8_2
-
-let _ =
-  declare_bool_option
-    { optsync  = true;
-      optname  = "apply-in side-conditions coming first";
-      optkey   = ["Side";"Conditions";"First";"For";"apply";"in"];
-      optread  = (fun () -> !dependent_propositions_elimination) ;
-      optwrite = (fun b -> dependent_propositions_elimination := b) }
-
+let finish_evar_resolution env initial_sigma c =
+  snd (Pretyping.solve_remaining_evars true true solve_by_implicit_tactic
+         env initial_sigma c)
 
 (*********************************************)
 (*                 Tactics                   *)
@@ -165,7 +155,6 @@ let internal_cut_rev_replace = internal_cut_rev_gen true
 (* Moving hypotheses *)
 let move_hyp        = Tacmach.move_hyp
 
-let order_hyps      = Tacmach.order_hyps
 
 (* Renaming hypotheses *)
 let rename_hyp      = Tacmach.rename_hyp
@@ -285,9 +274,12 @@ let reduct_in_hyp redfun (id,where) gl =
   convert_hyp_no_check
     (pf_reduce_decl redfun where (pf_get_hyp gl id) gl) gl
 
+let revert_cast (redfun,kind as r) =
+  if kind = DEFAULTcast then (redfun,REVERTcast) else r
+
 let reduct_option redfun = function
   | Some id -> reduct_in_hyp (fst redfun) id
-  | None    -> reduct_in_concl redfun
+  | None    -> reduct_in_concl (revert_cast redfun)
 
 (* Now we introduce different instances of the previous tacticals *)
 let change_and_check cv_pb t env sigma c =
@@ -323,35 +315,25 @@ let change chg c cls gl =
     cls gl
 
 (* Pour usage interne (le niveau User est pris en compte par reduce) *)
-let try_red_in_concl    = reduct_in_concl (try_red_product,DEFAULTcast)
-let red_in_concl        = reduct_in_concl (red_product,DEFAULTcast)
+let try_red_in_concl    = reduct_in_concl (try_red_product,REVERTcast)
+let red_in_concl        = reduct_in_concl (red_product,REVERTcast)
 let red_in_hyp          = reduct_in_hyp   red_product
-let red_option          = reduct_option   (red_product,DEFAULTcast)
-let hnf_in_concl        = reduct_in_concl (hnf_constr,DEFAULTcast)
+let red_option          = reduct_option   (red_product,REVERTcast)
+let hnf_in_concl        = reduct_in_concl (hnf_constr,REVERTcast)
 let hnf_in_hyp          = reduct_in_hyp   hnf_constr
-let hnf_option          = reduct_option   (hnf_constr,DEFAULTcast)
-let simpl_in_concl      = reduct_in_concl (simpl,DEFAULTcast)
+let hnf_option          = reduct_option   (hnf_constr,REVERTcast)
+let simpl_in_concl      = reduct_in_concl (simpl,REVERTcast)
 let simpl_in_hyp        = reduct_in_hyp   simpl
-let simpl_option        = reduct_option   (simpl,DEFAULTcast)
-let normalise_in_concl  = reduct_in_concl (compute,DEFAULTcast)
+let simpl_option        = reduct_option   (simpl,REVERTcast)
+let normalise_in_concl  = reduct_in_concl (compute,REVERTcast)
 let normalise_in_hyp    = reduct_in_hyp   compute
-let normalise_option    = reduct_option   (compute,DEFAULTcast)
+let normalise_option    = reduct_option   (compute,REVERTcast)
 let normalise_vm_in_concl = reduct_in_concl (Redexpr.cbv_vm,VMcast)
-let unfold_in_concl loccname = reduct_in_concl (unfoldn loccname,DEFAULTcast)
+let unfold_in_concl loccname = reduct_in_concl (unfoldn loccname,REVERTcast)
 let unfold_in_hyp   loccname = reduct_in_hyp   (unfoldn loccname)
 let unfold_option   loccname = reduct_option (unfoldn loccname,DEFAULTcast)
 let pattern_option l = reduct_option (pattern_occs l,DEFAULTcast)
 
-(* A function which reduces accordingly to a reduction expression,
-   as the command Eval does. *)
-
-let checking_fun = function
-  (* Expansion is not necessarily well-typed: e.g. expansion of t into x is
-     not well-typed in [H:(P t); x:=t |- G] because x is defined after H *)
-  | Fold _ -> with_check
-  | Pattern _ -> with_check
-  | _ -> (fun x -> x)
-
 (* The main reduction function *)
 
 let reduction_clause redexp cl =
@@ -433,31 +415,34 @@ let find_intro_names ctxt gl =
     ctxt (pf_env gl , []) in
   List.rev res
 
-let build_intro_tac id = function
-  | MoveToEnd true -> introduction id
-  | dest -> tclTHEN (introduction id) (move_hyp true id dest)
+let build_intro_tac id dest tac = match dest with
+  | MoveToEnd true -> tclTHEN (introduction id) (tac id)
+  | dest -> tclTHENLIST [introduction id; move_hyp true id dest; tac id]
 
-let rec intro_gen loc name_flag move_flag force_flag dep_flag gl =
+let rec intro_then_gen loc name_flag move_flag force_flag dep_flag tac gl =
   match kind_of_term (pf_concl gl) with
     | Prod (name,t,u) when not dep_flag or (dependent (mkRel 1) u) ->
-	build_intro_tac (find_name loc (name,None,t) gl name_flag) move_flag gl
+	build_intro_tac (find_name loc (name,None,t) gl name_flag) move_flag tac gl
     | LetIn (name,b,t,u) when not dep_flag or (dependent (mkRel 1) u) ->
-	build_intro_tac (find_name loc (name,Some b,t) gl name_flag) move_flag
+	build_intro_tac (find_name loc (name,Some b,t) gl name_flag) move_flag tac
 	  gl
     | _ ->
 	if not force_flag then raise (RefinerError IntroNeedsProduct);
 	try
 	  tclTHEN try_red_in_concl
-	    (intro_gen loc name_flag move_flag force_flag dep_flag) gl
+	    (intro_then_gen loc name_flag move_flag force_flag dep_flag tac) gl
 	with Redelimination ->
 	  user_err_loc(loc,"Intro",str "No product even after head-reduction.")
 
+let intro_gen loc n m f d = intro_then_gen loc n m f d (fun _ -> tclIDTAC)
 let intro_mustbe_force id = intro_gen dloc (IntroMustBe id) no_move true false
 let intro_using id = intro_gen dloc (IntroBasedOn (id,[])) no_move false false
+let intro_then = intro_then_gen dloc (IntroAvoid []) no_move false false
 let intro = intro_gen dloc (IntroAvoid []) no_move false false
 let introf = intro_gen dloc (IntroAvoid []) no_move true false
 let intro_avoiding l = intro_gen dloc (IntroAvoid l) no_move false false
-let introf_move_name destopt = intro_gen dloc (IntroAvoid []) destopt true false
+
+let intro_then_force = intro_then_gen dloc (IntroAvoid []) no_move true false
 
 (**** Multiple introduction tactics ****)
 
@@ -469,8 +454,13 @@ let intros = tclREPEAT intro
 
 let intro_erasing id = tclTHEN (thin [id]) (introduction id)
 
-let intro_forthcoming_gen loc name_flag move_flag dep_flag =
-    tclREPEAT (intro_gen loc name_flag  move_flag false dep_flag)
+let intro_forthcoming_then_gen loc name_flag move_flag dep_flag tac =
+  let rec aux ids =
+    tclORELSE0
+      (intro_then_gen loc name_flag  move_flag false dep_flag
+         (fun id -> aux (id::ids)))
+      (tac ids) in
+  aux []
 
 let rec get_next_hyp_position id = function
   | [] -> error ("No such hypothesis: " ^ string_of_id id)
@@ -517,8 +507,8 @@ let intro_move idopt hto = match idopt with
   | Some id -> intro_gen dloc (IntroMustBe id) hto true false
 
 let pf_lookup_hypothesis_as_renamed env ccl = function
-  | AnonHyp n -> pf_lookup_index_as_renamed env ccl n
-  | NamedHyp id -> pf_lookup_name_as_displayed env ccl id
+  | AnonHyp n -> Detyping.lookup_index_as_renamed env ccl n
+  | NamedHyp id -> Detyping.lookup_name_as_displayed env ccl id
 
 let pf_lookup_hypothesis_as_renamed_gen red h gl =
   let env = pf_env gl in
@@ -565,8 +555,13 @@ let intros_until = intros_until_gen true
 let intros_until_n = intros_until_n_gen true
 let intros_until_n_wored = intros_until_n_gen false
 
+let tclCHECKVAR id gl = ignore (pf_get_hyp gl id); tclIDTAC gl
+
+let try_intros_until_id_check id =
+  tclORELSE (intros_until_id id) (tclCHECKVAR id)
+
 let try_intros_until tac = function
-  | NamedHyp id -> tclTHEN (tclTRY (intros_until_id id)) (tac id)
+  | NamedHyp id -> tclTHEN (try_intros_until_id_check id) (tac id)
   | AnonHyp n -> tclTHEN (intros_until_n n) (onLastHypId tac)
 
 let rec intros_move = function
@@ -583,17 +578,32 @@ let dependent_in_decl a (_,c,t) =
 (* Apply a tactic on a quantified hypothesis, an hypothesis in context
    or a term with bindings *)
 
+let onOpenInductionArg tac = function
+  | ElimOnConstr cbl ->
+      tac cbl
+  | ElimOnAnonHyp n ->
+      tclTHEN
+        (intros_until_n n)
+        (onLastHyp (fun c -> tac (Evd.empty,(c,NoBindings))))
+  | ElimOnIdent (_,id) ->
+      (* A quantified hypothesis *)
+      tclTHEN
+        (try_intros_until_id_check id)
+        (tac (Evd.empty,(mkVar id,NoBindings)))
+
 let onInductionArg tac = function
-  | ElimOnConstr (c,lbindc as cbl) ->
-      if isVar c & lbindc = NoBindings then
-	tclTHEN (tclTRY (intros_until_id (destVar c))) (tac cbl)
-      else
-	tac cbl
+  | ElimOnConstr cbl ->
+      tac cbl
   | ElimOnAnonHyp n ->
       tclTHEN (intros_until_n n) (onLastHyp (fun c -> tac (c,NoBindings)))
   | ElimOnIdent (_,id) ->
-      (*Identifier apart because id can be quantified in goal and not typable*)
-      tclTHEN (tclTRY (intros_until_id id)) (tac (mkVar id,NoBindings))
+      (* A quantified hypothesis *)
+      tclTHEN (try_intros_until_id_check id) (tac (mkVar id,NoBindings))
+
+let map_induction_arg f = function
+  | ElimOnConstr (sigma,(c,bl)) -> ElimOnConstr (f (sigma,c),bl)
+  | ElimOnAnonHyp n -> ElimOnAnonHyp n
+  | ElimOnIdent id -> ElimOnIdent id
 
 (**************************)
 (*  Refinement tactics    *)
@@ -615,9 +625,9 @@ let bring_hyps hyps =
 
 let resolve_classes gl =
   let env = pf_env gl and evd = project gl in
-    if evd = Evd.empty then tclIDTAC gl
+    if Evd.is_empty evd then tclIDTAC gl
     else
-      let evd' = Typeclasses.resolve_typeclasses env (Evd.create_evar_defs evd) in
+      let evd' = Typeclasses.resolve_typeclasses env evd in
 	(tclTHEN (tclEVARS evd') tclNORMEVAR) gl
 
 (**************************)
@@ -723,24 +733,15 @@ let index_of_ind_arg t =
       | None -> error "Could not find inductive argument of elimination scheme."
   in aux None 0 t
 
-let elim_flags = {
-  modulo_conv_on_closed_terms = Some full_transparent_state;
-  use_metas_eagerly = true;
-  modulo_delta = empty_transparent_state;
-  resolve_evars = false;
-  use_evars_pattern_unification = true;
-}
-
-let elimination_clause_scheme with_evars allow_K i elimclause indclause gl =
+let elimination_clause_scheme with_evars ?(flags=elim_flags) i elimclause indclause gl =
   let indmv =
     (match kind_of_term (nth_arg i elimclause.templval.rebus) with
        | Meta mv -> mv
        | _  -> errorlabstrm "elimination_clause"
              (str "The type of elimination clause is not well-formed."))
   in
-  let elimclause' = clenv_fchain ~flags:elim_flags indmv elimclause indclause in
-  res_pf elimclause' ~with_evars:with_evars ~allow_K:allow_K ~flags:elim_flags
-    gl
+  let elimclause' = clenv_fchain ~flags indmv elimclause indclause in
+  res_pf elimclause' ~with_evars:with_evars ~flags gl
 
 (*
  * Elimination tactic with bindings and using an arbitrary
@@ -769,8 +770,8 @@ let general_elim_clause elimtac (c,lbindc) elim gl =
   let indclause  = make_clenv_binding gl (c,t) lbindc  in
     general_elim_clause_gen elimtac indclause elim gl
 
-let general_elim with_evars c e ?(allow_K=true) =
-  general_elim_clause (elimination_clause_scheme with_evars allow_K) c e
+let general_elim with_evars c e =
+  general_elim_clause (elimination_clause_scheme with_evars) c e
 
 (* Elimination tactic with bindings but using the default elimination
  * constant associated with the type. *)
@@ -786,15 +787,15 @@ let default_elim with_evars (c,_ as cx) gl =
 let elim_in_context with_evars c = function
   | Some elim ->
       general_elim with_evars c {elimindex = Some (-1); elimbody = elim}
-	~allow_K:true
   | None -> default_elim with_evars c
 
 let elim with_evars (c,lbindc as cx) elim =
   match kind_of_term c with
     | Var id when lbindc = NoBindings ->
-	tclTHEN (tclTRY (intros_until_id id))
+	tclTHEN (try_intros_until_id_check id)
 	  (elim_in_context with_evars cx elim)
-    | _ -> elim_in_context with_evars cx elim
+    | _ ->
+	elim_in_context with_evars cx elim
 
 (* The simplest elimination tactic, with no substitutions at all. *)
 
@@ -810,13 +811,13 @@ let simplest_elim c = default_elim false (c,NoBindings)
    (e.g. it could replace id:A->B->C by id:C, knowing A/\B)
 *)
 
-let clenv_fchain_in id elim_flags mv elimclause hypclause =
-  try clenv_fchain ~allow_K:false ~flags:elim_flags mv elimclause hypclause
-  with PretypeError (env,NoOccurrenceFound (op,_)) ->
+let clenv_fchain_in id ?(flags=elim_flags) mv elimclause hypclause =
+  try clenv_fchain ~flags mv elimclause hypclause
+  with PretypeError (env,evd,NoOccurrenceFound (op,_)) ->
     (* Set the hypothesis name in the message *)
-    raise (PretypeError (env,NoOccurrenceFound (op,Some id)))
+    raise (PretypeError (env,evd,NoOccurrenceFound (op,Some id)))
 
-let elimination_in_clause_scheme with_evars id i elimclause indclause gl =
+let elimination_in_clause_scheme with_evars ?(flags=elim_flags) id i elimclause indclause gl =
   let indmv = destMeta (nth_arg i elimclause.templval.rebus) in
   let hypmv =
     try match list_remove indmv (clenv_independent elimclause) with
@@ -824,12 +825,11 @@ let elimination_in_clause_scheme with_evars id i elimclause indclause gl =
       | _ -> failwith ""
     with Failure _ -> errorlabstrm "elimination_clause"
           (str "The type of elimination clause is not well-formed.") in
-  let elimclause'  = clenv_fchain indmv elimclause indclause in
+  let elimclause'  = clenv_fchain ~flags indmv elimclause indclause in
   let hyp = mkVar id in
   let hyp_typ = pf_type_of gl hyp in
   let hypclause = mk_clenv_from_n gl (Some 0) (hyp, hyp_typ) in
-  let elimclause'' =
-    clenv_fchain_in id elim_flags hypmv elimclause' hypclause in
+  let elimclause'' = clenv_fchain_in id ~flags hypmv elimclause' hypclause in
   let new_hyp_typ  = clenv_type elimclause'' in
   if eq_constr hyp_typ new_hyp_typ then
     errorlabstrm "general_rewrite_in"
@@ -855,8 +855,8 @@ let general_case_analysis_in_context with_evars (c,lbindc) gl =
 let general_case_analysis with_evars (c,lbindc as cx) =
   match kind_of_term c with
     | Var id when lbindc = NoBindings ->
-	tclTHEN (tclTRY (intros_until_id id))
-	(general_case_analysis_in_context with_evars cx)
+	tclTHEN (try_intros_until_id_check id)
+	  (general_case_analysis_in_context with_evars cx)
     | _ ->
 	general_case_analysis_in_context with_evars cx
 
@@ -871,6 +871,7 @@ type conjunction_status =
 let make_projection sigma params cstr sign elim i n c =
   let elim = match elim with
   | NotADefinedRecordUseScheme elim ->
+      (* bugs: goes from right to left when i increases! *)
       let (na,b,t) = List.nth cstr.cs_args i in
       let b = match b with None -> mkRel (i+1) | Some b -> b in
       let branch = it_mkLambda_or_LetIn b cstr.cs_args in
@@ -885,6 +886,7 @@ let make_projection sigma params cstr sign elim i n c =
       else
 	None
   | DefinedRecord l ->
+      (* goes from left to right when i increases! *)
       match List.nth l i with
       | Some proj ->
 	  let t = Typeops.type_of_constant (Global.env()) proj in
@@ -919,7 +921,7 @@ let descend_in_conjunctions tac exit c gl =
 	    | Some (p,pt) ->
 	    tclTHENS
 	      (internal_cut id pt)
-	      [refine_no_check p;
+	      [refine p; (* Might be ill-typed due to forbidden elimination. *)
 	       tclTHEN (tac (not isrec) (mkVar id)) (thin [id])] gl) n)
 	  gl
     | None ->
@@ -961,9 +963,9 @@ let general_apply with_delta with_destruct with_evars (loc,(c,lbind)) gl0 =
 	    with PretypeError _|RefinerError _|UserError _|Failure _|Exit ->
 	      if with_destruct then
                 descend_in_conjunctions
-                  try_main_apply (fun _ -> Stdpp.raise_with_loc loc exn) c gl
+                  try_main_apply (fun _ -> Loc.raise loc exn) c gl
 	      else
-		Stdpp.raise_with_loc loc exn
+		Loc.raise loc exn
 	in try_red_apply thm_ty0
   in
   try_main_apply with_destruct c gl0
@@ -1023,8 +1025,7 @@ let apply_in_once_main flags innerclause (d,lbind) gl =
 
 let apply_in_once sidecond_first with_delta with_destruct with_evars id
   (loc,(d,lbind)) gl0 =
-  let flags =
-    if with_delta then default_unify_flags else default_no_delta_unify_flags in
+  let flags = if with_delta then elim_flags else elim_no_delta_flags in
   let t' = pf_get_hyp_typ gl0 id in
   let innerclause = mk_clenv_from_n gl0 (Some 0) (mkVar id,t') in
   let rec aux with_destruct c gl =
@@ -1119,7 +1120,7 @@ let clear_wildcards ids =
     try with_check (Tacmach.thin_no_check [id]) gl
     with ClearDependencyError (id,err) ->
       (* Intercept standard [thin] error message *)
-      Stdpp.raise_with_loc loc
+      Loc.raise loc
         (error_clear_dependency (pf_env gl) (id_of_string "_") err))
     ids
 
@@ -1137,11 +1138,14 @@ let rec intros_clearing = function
 (* Modifying/Adding an hypothesis  *)
 
 let specialize mopt (c,lbind) g =
-  let term =
-    if lbind = NoBindings then c
+  let tac, term =
+    if lbind = NoBindings then 
+      let evd = Typeclasses.resolve_typeclasses (pf_env g) (project g) in
+	tclEVARS evd, nf_evar evd c
     else
       let clause = make_clenv_binding g (c,pf_type_of g c) lbind in
-      let clause = clenv_unify_meta_types clause in
+      let flags = { default_unify_flags with resolve_evars = true } in
+      let clause = clenv_unify_meta_types ~flags clause in
       let (thd,tstack) = whd_stack clause.evd (clenv_value clause) in
       let nargs = List.length tstack in
       let tstack = match mopt with
@@ -1158,16 +1162,18 @@ let specialize mopt (c,lbind) g =
 	errorlabstrm "" (str "Cannot infer an instance for " ++
           pr_name (meta_name clause.evd (List.hd (collect_metas term))) ++
 	  str ".");
-      term
+       tclEVARS clause.evd, term
   in
   match kind_of_term (fst(decompose_app (snd(decompose_lam_assum c)))) with
        | Var id when List.mem id (pf_ids_of_hyps g) ->
-	     tclTHENFIRST
+	   tclTHEN tac
+	     (tclTHENFIRST
 	       (fun g -> internal_cut_replace id (pf_type_of g term) g)
-	       (exact_no_check term) g
-       | _ -> tclTHENLAST
-                 (fun g -> cut (pf_type_of g term) g)
-                 (exact_no_check term) g
+	       (exact_no_check term)) g
+       | _ -> tclTHEN tac
+	   (tclTHENLAST
+              (fun g -> cut (pf_type_of g term) g)
+              (exact_no_check term)) g
 
 (* Keeping only a few hypotheses *)
 
@@ -1245,12 +1251,20 @@ let simplest_split = split NoBindings
 (* Decomposing introductions *)
 (*****************************)
 
+(* Rewriting function for rewriting one hypothesis at the time *)
 let forward_general_multi_rewrite =
   ref (fun _ -> failwith "general_multi_rewrite undefined")
 
+(* Rewriting function for substitution (x=t) everywhere at the same time *)
+let forward_subst_one =
+  ref (fun _ -> failwith "subst_one undefined")
+
 let register_general_multi_rewrite f =
   forward_general_multi_rewrite := f
 
+let register_subst_one f =
+  forward_subst_one := f
+
 let error_unexpected_extra_pattern loc nb pat =
   let s1,s2,s3 = match pat with
   | IntroIdentifier _ -> "name", (plural nb " introduction pattern"), "no"
@@ -1284,6 +1298,8 @@ let intro_or_and_pattern loc b ll l' tac id gl =
 let rewrite_hyp l2r id gl =
   let rew_on l2r =
     !forward_general_multi_rewrite l2r false (mkVar id,NoBindings) in
+  let subst_on l2r x rhs =
+    !forward_subst_one true x (id,rhs,l2r) in
   let clear_var_and_eq c =
     tclTRY (tclTHEN (clear [id]) (tclTRY (clear [destVar c]))) in
   let t = pf_whd_betadeltaiota gl (pf_type_of gl (mkVar id)) in
@@ -1291,9 +1307,9 @@ let rewrite_hyp l2r id gl =
   match match_with_equality_type t with
   | Some (hdcncl,[_;lhs;rhs]) ->
       if l2r & isVar lhs & not (occur_var (pf_env gl) (destVar lhs) rhs) then
-	tclTHEN (rew_on l2r allHypsAndConcl) (clear_var_and_eq lhs) gl
+	subst_on l2r (destVar lhs) rhs gl
       else if not l2r & isVar rhs & not (occur_var (pf_env gl) (destVar rhs) lhs) then
-	tclTHEN (rew_on l2r allHypsAndConcl) (clear_var_and_eq rhs) gl
+	subst_on l2r (destVar rhs) lhs gl
       else
 	tclTHEN (rew_on l2r onConcl) (tclTRY (clear [id])) gl
   | Some (hdcncl,[c]) ->
@@ -1315,57 +1331,65 @@ let rec explicit_intro_names = function
 | [] ->
     []
 
+let wild_id = id_of_string "_tmp"
+
+let rec list_mem_assoc_right id = function
+  | [] -> false
+  | (x,id')::l -> id = id' || list_mem_assoc_right id l
+
+let check_thin_clash_then id thin avoid tac =
+  if list_mem_assoc_right id thin then
+    let newid = next_ident_away (add_suffix id "'") avoid in
+    let thin =
+      List.map (on_snd (fun id' -> if id = id' then newid else id')) thin in
+    tclTHEN (rename_hyp [id,newid]) (tac thin)
+  else
+    tac thin
+
   (* We delay thinning until the completion of the whole intros tactic
      to ensure that dependent hypotheses are cleared in the right
      dependency order (see bug #1000); we use fresh names, not used in
      the tactic, for the hyps to clear *)
-let rec intros_patterns b avoid thin destopt = function
+let rec intros_patterns b avoid ids thin destopt tac = function
   | (loc, IntroWildcard) :: l ->
-      tclTHEN
-        (intro_gen loc (IntroAvoid(avoid@explicit_intro_names l))
-	  no_move true false)
-        (onLastHypId (fun id ->
-	  tclORELSE
-	    (tclTHEN (clear [id]) (intros_patterns b avoid thin destopt l))
-	    (intros_patterns b avoid ((loc,id)::thin) destopt l)))
+      intro_then_gen loc (IntroBasedOn(wild_id,avoid@explicit_intro_names l))
+	no_move true false
+        (fun id -> intros_patterns b avoid ids ((loc,id)::thin) destopt tac l)
   | (loc, IntroIdentifier id) :: l ->
-      tclTHEN
-        (intro_gen loc (IntroMustBe id) destopt true false)
-        (intros_patterns b avoid thin destopt l)
+      check_thin_clash_then id thin avoid (fun thin ->
+        intro_then_gen loc (IntroMustBe id) destopt true false
+          (fun id -> intros_patterns b avoid (id::ids) thin destopt tac l))
   | (loc, IntroAnonymous) :: l ->
-      tclTHEN
-        (intro_gen loc (IntroAvoid (avoid@explicit_intro_names l))
-	  destopt true false)
-        (intros_patterns b avoid thin destopt l)
+      intro_then_gen loc (IntroAvoid (avoid@explicit_intro_names l))
+	destopt true false
+        (fun id -> intros_patterns b avoid (id::ids) thin destopt tac l)
   | (loc, IntroFresh id) :: l ->
-      tclTHEN
-        (intro_gen loc (IntroBasedOn (id, avoid@explicit_intro_names l))
-	  destopt true false)
-        (intros_patterns b avoid thin destopt l)
+      (* todo: avoid thinned names to interfere with generation of fresh name *)
+      intro_then_gen loc (IntroBasedOn (id, avoid@explicit_intro_names l))
+	destopt true false
+        (fun id -> intros_patterns b avoid (id::ids) thin destopt tac l)
   | (loc, IntroForthcoming onlydeps) :: l ->
-      tclTHEN
-        (intro_forthcoming_gen loc (IntroAvoid (avoid@explicit_intro_names l))
-	  destopt onlydeps)
-        (intros_patterns b avoid thin destopt l)
+      intro_forthcoming_then_gen loc (IntroAvoid (avoid@explicit_intro_names l))
+	  destopt onlydeps
+        (fun ids -> intros_patterns b avoid ids thin destopt tac l)
   | (loc, IntroOrAndPattern ll) :: l' ->
-      tclTHEN
-        introf
-        (onLastHypId
-	  (intro_or_and_pattern loc b ll l'
-	    (intros_patterns b avoid thin destopt)))
+      intro_then_force
+	(intro_or_and_pattern loc b ll l'
+	   (intros_patterns b avoid ids thin destopt tac))
   | (loc, IntroRewrite l2r) :: l ->
-      tclTHEN
-        (intro_gen loc (IntroAvoid(avoid@explicit_intro_names l))
-	  no_move true false)
-        (onLastHypId (fun id ->
+      intro_then_gen loc (IntroAvoid(avoid@explicit_intro_names l))
+	no_move true false
+        (fun id ->
 	  tclTHENLAST (* Skip the side conditions of the rewriting step *)
 	    (rewrite_hyp l2r id)
-	    (intros_patterns b avoid thin destopt l)))
-  | [] -> clear_wildcards thin
+	    (intros_patterns b avoid ids thin destopt tac l))
+  | [] -> tac ids thin
 
-let intros_pattern = intros_patterns false [] []
+let intros_pattern destopt =
+  intros_patterns false [] [] [] destopt (fun _ -> clear_wildcards)
 
-let intro_pattern destopt pat = intros_patterns false [] [] destopt [dloc,pat]
+let intro_pattern destopt pat =
+  intros_pattern destopt [dloc,pat]
 
 let intro_patterns = function
   | [] -> tclREPEAT intro
@@ -1390,7 +1414,7 @@ let prepare_intros s ipat gl = match ipat with
   | IntroOrAndPattern ll -> make_id s gl,
       onLastHypId
 	(intro_or_and_pattern loc true ll []
-	  (intros_patterns true [] [] no_move))
+	  (intros_patterns true [] [] [] no_move (fun _ -> clear_wildcards)))
   | IntroForthcoming _ -> user_err_loc
       (loc,"",str "Introduction pattern for one hypothesis expected")
 
@@ -1400,7 +1424,8 @@ let ipat_of_name = function
 
 let allow_replace c gl = function (* A rather arbitrary condition... *)
   | Some (_, IntroIdentifier id) ->
-      fst (decompose_app ((strip_lam_assum c))) = mkVar id
+      let c = fst (decompose_app ((strip_lam_assum c))) in
+      isVar c && destVar c = id
   | _ ->
       false
 
@@ -1422,7 +1447,8 @@ let as_tac id ipat = match ipat with
   | Some (loc,IntroRewrite l2r) ->
       !forward_general_multi_rewrite l2r false (mkVar id,NoBindings) allHypsAndConcl
   | Some (loc,IntroOrAndPattern ll) ->
-      intro_or_and_pattern loc true ll [] (intros_patterns true [] [] no_move)
+      intro_or_and_pattern loc true ll []
+        (intros_patterns true [] [] [] no_move (fun _ -> clear_wildcards))
         id
   | Some (loc,
       (IntroIdentifier _ | IntroAnonymous | IntroFresh _ |
@@ -1484,7 +1510,7 @@ let generalize_goal gl i ((occs,c,b),na) cl =
   let decls,cl = decompose_prod_n_assum i cl in
   let dummy_prod = it_mkProd_or_LetIn mkProp decls in
   let newdecls,_ = decompose_prod_n_assum i (subst_term c dummy_prod) in
-  let cl' = subst_term_occ occs c (it_mkProd_or_LetIn cl newdecls) in
+  let cl' = subst_closed_term_occ occs c (it_mkProd_or_LetIn cl newdecls) in
   let na = generalized_name c t (pf_ids_of_hyps gl) cl' na in
     mkProd_or_LetIn (na,b,t) cl'
 
@@ -1659,14 +1685,48 @@ let letin_tac with_eq name c occs gl =
 (* Implementation without generalisation: abbrev will be lost in hyps in *)
 (* in the extracted proof *)
 
-let letin_abstract id c (occs,check_occs) gl =
+let default_matching_flags sigma = {
+  modulo_conv_on_closed_terms = Some empty_transparent_state;
+  use_metas_eagerly_in_conv_on_closed_terms = false;
+  modulo_delta = empty_transparent_state;
+  modulo_delta_types = full_transparent_state;
+  check_applied_meta_types = true;
+  resolve_evars = false;
+  use_pattern_unification = false;
+  use_meta_bound_pattern_unification = false;
+  frozen_evars =
+    fold_undefined (fun evk _ evars -> ExistentialSet.add evk evars)
+      sigma ExistentialSet.empty;
+  restrict_conv_on_strict_subterms = false;
+  modulo_betaiota = false;
+  modulo_eta = false;
+  allow_K_in_toplevel_higher_order_unification = false
+}
+
+let make_pattern_test env sigma0 (sigma,c) =
+  let flags = default_matching_flags sigma0 in
+  let matching_fun t =
+    try let sigma = w_unify env sigma Reduction.CONV ~flags c t in Some(sigma,t)
+    with _ -> raise NotUnifiable in
+  let merge_fun c1 c2 =
+    match c1, c2 with
+    | Some (_,c1), Some (_,c2) when not (is_fconv Reduction.CONV env sigma0 c1 c2) ->
+        raise NotUnifiable
+    | _ -> c1 in
+  { match_fun = matching_fun; merge_fun = merge_fun; 
+    testing_state = None; last_found = None },
+  (fun test -> match test.testing_state with
+   | None -> finish_evar_resolution env sigma0 (sigma,c)
+   | Some (sigma,_) -> nf_evar sigma c)
+
+let letin_abstract id c (test,out) (occs,check_occs) gl =
   let env = pf_env gl in
   let compute_dependency _ (hyp,_,_ as d) depdecls =
     match occurrences_of_hyp hyp occs with
       | None -> depdecls
       | Some occ ->
-          let newdecl = subst_term_occ_decl occ c d in
-          if occ = (all_occurrences,InHyp) & d = newdecl then
+          let newdecl = subst_closed_term_occ_decl_modulo occ test d in
+          if occ = (all_occurrences,InHyp) & eq_named_declaration d newdecl then
 	    if check_occs & not (in_every_hyp occs)
 	    then raise (RefinerError (DoesNotOccurIn (c,hyp)))
 	    else depdecls
@@ -1675,19 +1735,21 @@ let letin_abstract id c (occs,check_occs) gl =
   let depdecls = fold_named_context compute_dependency env ~init:[] in
   let ccl = match occurrences_of_goal occs with
     | None -> pf_concl gl
-    | Some occ -> subst1 (mkVar id) (subst_term_occ occ c (pf_concl gl)) in
+    | Some occ ->
+        subst1 (mkVar id) (subst_closed_term_occ_modulo occ test None (pf_concl gl)) in
   let lastlhyp =
     if depdecls = [] then no_move else MoveAfter(pi1(list_last depdecls)) in
-  (depdecls,lastlhyp,ccl)
+  (depdecls,lastlhyp,ccl,out test)
 
-let letin_tac_gen with_eq name c ty occs gl =
+let letin_tac_gen with_eq name (sigmac,c) test ty occs gl =
   let id =
-    let x = id_of_name_using_hdchar (Global.env()) (pf_type_of gl c) name in
+    let t = match ty with Some t -> t | None -> typ_of (pf_env gl) sigmac c in
+    let x = id_of_name_using_hdchar (Global.env()) t name in
     if name = Anonymous then fresh_id [] x gl else
       if not (mem_named_context x (pf_hyps gl)) then x else
 	error ("The variable "^(string_of_id x)^" is already declared.") in
-  let (depdecls,lastlhyp,ccl)= letin_abstract id c occs gl in
-  let t = match ty with Some t -> t | None -> pf_type_of gl c in
+  let (depdecls,lastlhyp,ccl,c) = letin_abstract id c test occs gl in
+  let t = match ty with Some t -> t | None -> pf_apply typ_of gl c in
   let newcl,eq_tac = match with_eq with
     | Some (lr,(loc,ido)) ->
       let heq = match ido with
@@ -1711,8 +1773,15 @@ let letin_tac_gen with_eq name c ty occs gl =
       tclMAP convert_hyp_no_check depdecls;
       eq_tac ] gl
 
-let letin_tac with_eq name c ty occs =
-  letin_tac_gen with_eq name c ty (occs,true)
+let make_eq_test c = (make_eq_test c,fun _ -> c)
+
+let letin_tac with_eq name c ty occs gl =
+  letin_tac_gen with_eq name (project gl,c) (make_eq_test c) ty (occs,true) gl
+
+let letin_pat_tac with_eq name c ty occs gl =
+  letin_tac_gen with_eq name c
+    (make_pattern_test (pf_env gl) (project gl) c)
+    ty (occs,true) gl
 
 (* Tactics "pose proof" (usetac=None) and "assert" (otherwise) *)
 let forward usetac ipat c gl =
@@ -1755,6 +1824,9 @@ let unfold_all x gl =
   if xval <> None then tclTHEN (unfold_body x) (clear [x]) gl
   else tclIDTAC gl
 
+(* Either unfold and clear if defined or simply clear if not a definition *)
+let expand_hyp id = tclTHEN (tclTRY (unfold_body id)) (clear [id])
+
 (*****************************)
 (* High-level induction      *)
 (*****************************)
@@ -1797,16 +1869,6 @@ let check_unused_names names =
       (str"Unused introduction " ++ str (plural (List.length names) "pattern")
        ++ str": " ++ prlist_with_sep spc pr_intro_pattern names)
 
-let rec first_name_buggy avoid gl (loc,pat) = match pat with
-  | IntroOrAndPattern [] -> no_move
-  | IntroOrAndPattern ([]::l) ->
-      first_name_buggy avoid gl (loc,IntroOrAndPattern l)
-  | IntroOrAndPattern ((p::_)::_) -> first_name_buggy avoid gl p
-  | IntroWildcard -> no_move
-  | IntroRewrite _ -> no_move
-  | IntroIdentifier id -> MoveAfter id
-  | IntroAnonymous | IntroFresh _ | IntroForthcoming _ -> (* buggy *) no_move
-
 let rec consume_pattern avoid id isdep gl = function
   | [] -> ((dloc, IntroIdentifier (fresh_id avoid id gl)), [])
   | (loc,IntroAnonymous)::names ->
@@ -1822,7 +1884,8 @@ let rec consume_pattern avoid id isdep gl = function
       ((loc,IntroIdentifier (fresh_id avoid id' gl)), names)
   | pat::names -> (pat,names)
 
-let re_intro_dependent_hypotheses (lstatus,rstatus) tophyp =
+let re_intro_dependent_hypotheses (lstatus,rstatus) (_,tophyp) =
+  let tophyp = match tophyp with None -> MoveToEnd true | Some hyp -> MoveAfter hyp in
   let newlstatus = (* if some IH has taken place at the top of hyps *)
     List.map (function (hyp,MoveToEnd true) -> (hyp,tophyp) | x -> x) lstatus
   in
@@ -1832,20 +1895,46 @@ let re_intro_dependent_hypotheses (lstatus,rstatus) tophyp =
 
 let update destopt tophyp = if destopt = no_move then tophyp else destopt
 
-let safe_dest_intros_patterns avoid dest pat gl =
-  try intros_patterns true avoid [] dest pat gl
+let safe_dest_intros_patterns avoid thin dest pat tac gl =
+  try intros_patterns true avoid [] thin dest tac pat gl
   with UserError ("move_hyp",_) ->
-    (* May happen if the lemma has dependent arguments that has resolved
-       only after cook_sign is called, e.g. as in 
+    (* May happen if the lemma has dependent arguments that are resolved
+       only after cook_sign is called, e.g. as in "destruct dec" in context
        "dec:forall x, {x=0}+{x<>0};  a:A  |- if dec a then True else False"
-       for argument a of dec which will be found only lately *)
-    intros_patterns true avoid [] no_move pat gl
+       where argument a of dec will be found only lately *)
+    intros_patterns true avoid [] [] no_move tac pat gl
 
 type elim_arg_kind = RecArg | IndArg | OtherArg
 
-let induct_discharge destopt avoid' tac (avoid,ra) names gl =
+type recarg_position =
+  | AfterFixedPosition of identifier option (* None = top of context *)
+
+let update_dest (recargdests,tophyp as dests) = function
+  | [] -> dests
+  | hyp::_ ->
+      (match recargdests with
+        | AfterFixedPosition None -> AfterFixedPosition (Some hyp)
+        | x -> x),
+       (match tophyp with None -> Some hyp | x -> x)
+
+let get_recarg_dest (recargdests,tophyp) =
+  match recargdests with
+  | AfterFixedPosition None -> MoveToEnd true
+  | AfterFixedPosition (Some id) -> MoveAfter id
+
+(* Current policy re-introduces recursive arguments of destructed
+   variable at the place of the original variable while induction
+   hypothesese are introduced at the top of the context. Since in the
+   general case of an inductive scheme, the induction hypotheses can
+   arrive just after the recursive arguments (e.g. as in "forall
+   t1:tree, P t1 -> forall t2:tree, P t2 -> P (node t1 t2)", we need
+   to update the position for t2 after "P t1" is introduced if ever t2
+   had to be introduced at the top of the context).
+*)
+
+let induct_discharge dests avoid' tac (avoid,ra) names gl =
   let avoid = avoid @ avoid' in
-  let rec peel_tac ra names tophyp gl =
+  let rec peel_tac ra dests names thin gl =
     match ra with
     | (RecArg,deprec,recvarname) ::
         (IndArg,depind,hyprecname) :: ra' ->
@@ -1855,37 +1944,33 @@ let induct_discharge destopt avoid' tac (avoid,ra) names gl =
 	      (pat, [dloc, IntroIdentifier id'])
           | _ -> consume_pattern avoid recvarname deprec gl names in
         let hyprec,names = consume_pattern avoid hyprecname depind gl names in
-        (* IH stays at top: we need to update tophyp *)
-        (* This is buggy for intro-or-patterns with different first hypnames *)
-        (* Would need to pass peel_tac as a continuation of intros_patterns *)
-        (* (or to have hypotheses classified by blocks...) *)
-        let newtophyp =
-	  if tophyp=no_move then first_name_buggy avoid gl hyprec else tophyp
-	in
-        tclTHENLIST
-	  [ safe_dest_intros_patterns avoid (update destopt tophyp) [recpat];
-	    safe_dest_intros_patterns avoid no_move [hyprec];
-	    peel_tac ra' names newtophyp] gl
+        let dest = get_recarg_dest dests in
+        safe_dest_intros_patterns avoid thin dest [recpat] (fun ids thin ->
+	safe_dest_intros_patterns avoid thin no_move [hyprec] (fun ids' thin ->
+	peel_tac ra' (update_dest dests ids') names thin))
+          gl
     | (IndArg,dep,hyprecname) :: ra' ->
 	(* Rem: does not happen in Coq schemes, only in user-defined schemes *)
         let pat,names = consume_pattern avoid hyprecname dep gl names in
-	tclTHEN (safe_dest_intros_patterns avoid (update destopt tophyp) [pat])
-          (peel_tac ra' names tophyp) gl
+	safe_dest_intros_patterns avoid thin no_move [pat] (fun ids thin ->
+        peel_tac ra' (update_dest dests ids) names thin) gl
     | (RecArg,dep,recvarname) :: ra' ->
         let pat,names = consume_pattern avoid recvarname dep gl names in
-	tclTHEN (safe_dest_intros_patterns avoid (update destopt tophyp) [pat])
-          (peel_tac ra' names tophyp) gl
+        let dest = get_recarg_dest dests in
+	safe_dest_intros_patterns avoid thin dest [pat] (fun ids thin ->
+        peel_tac ra' dests names thin) gl
     | (OtherArg,_,_) :: ra' ->
         let pat,names = match names with
           | [] -> (dloc, IntroAnonymous), []
           | pat::names -> pat,names in
-	tclTHEN (safe_dest_intros_patterns avoid (update destopt tophyp) [pat])
-          (peel_tac ra' names tophyp) gl
+        let dest = get_recarg_dest dests in
+	safe_dest_intros_patterns avoid thin dest [pat] (fun ids thin ->
+        peel_tac ra' dests names thin) gl
     | [] ->
         check_unused_names names;
-        tac tophyp gl
+        tclTHEN (clear_wildcards thin) (tac dests) gl
   in
-  peel_tac ra names no_move gl
+  peel_tac ra dests names [] gl
 
 (* - le recalcul de indtyp à chaque itération de atomize_one est pour ne pas
      s'embêter à regarder si un letin_tac ne fait pas des
@@ -2063,8 +2148,13 @@ let cook_sign hyp0_opt indvars env =
       fold_named_context_reverse compute_lstatus ~init:(MoveToEnd true) env in
     raise (Shunt (MoveToEnd true)) (* ?? FIXME *)
   with Shunt lhyp0 ->
+    let lhyp0 = match lhyp0 with
+      | MoveToEnd true -> None
+      | MoveAfter hyp -> Some hyp
+      | _ -> assert false in
     let statuslists = (!lstatus,List.rev !rstatus) in
-    (statuslists, (if hyp0_opt=None then MoveToEnd true else lhyp0),
+    let recargdests = AfterFixedPosition (if hyp0_opt=None then None else lhyp0) in
+    (statuslists, (recargdests,None),
      !indhyps, !decldeps)
 
 
@@ -2167,23 +2257,6 @@ let make_up_names n ind_opt cname =
       else avoid in
   id_of_string base, hyprecname, avoid
 
-let is_indhyp p n t =
-  let l, c = decompose_prod t in
-  let c,_ = decompose_app c in
-  let p = p + List.length l in
-  match kind_of_term c with
-    | Rel k when p < k & k <= p + n -> true
-    | _ -> false
-
-let chop_context n l =
-  let rec chop_aux acc = function
-    | n, (_,Some _,_ as h :: t) -> chop_aux (h::acc) (n, t)
-    | 0, l2 -> (List.rev acc, l2)
-    | n, (h::t) -> chop_aux (h::acc) (n-1, t)
-    | _, [] -> anomaly "chop_context"
-  in
-  chop_aux [] (n,l)
-
 let error_ind_scheme s =
   let s = if s <> "" then s^" " else s in
   error ("Cannot recognize "^s^"an induction scheme.")
@@ -2194,8 +2267,6 @@ let coq_eq_refl = lazy ((Coqlib.build_coq_eq_data ()).Coqlib.refl)
 let coq_heq = lazy (Coqlib.coq_constant "mkHEq" ["Logic";"JMeq"] "JMeq")
 let coq_heq_refl = lazy (Coqlib.coq_constant "mkHEq" ["Logic";"JMeq"] "JMeq_refl")
 
-let coq_block = lazy (Coqlib.coq_constant "tactics" ["Program";"Equality"] "block")
-
 let mkEq t x y = 
   mkApp (Lazy.force coq_eq, [| refresh_universes_strict t; x; y |])
     
@@ -2218,8 +2289,6 @@ let lift_togethern n l =
       l ([], n)
   in l'
 
-let lift_together l = lift_togethern 0 l
-
 let lift_list l = List.map (lift 1) l
 
 let ids_of_constr ?(all=false) vars c =
@@ -2267,11 +2336,11 @@ let make_abstract_generalize gl id concl dep ctx body c eqs args refls =
   in
     (* Abstract by equalitites *)
   let eqs = lift_togethern 1 eqs in (* lift together and past genarg *)
-  let abseqs = it_mkProd_or_LetIn ~init:(lift eqslen abshypeq) (List.map (fun x -> (Anonymous, None, x)) eqs) in
+  let abseqs = it_mkProd_or_LetIn (lift eqslen abshypeq) (List.map (fun x -> (Anonymous, None, x)) eqs) in
     (* Abstract by the "generalized" hypothesis. *)
   let genarg = mkProd_or_LetIn (Name id, body, c) abseqs in
     (* Abstract by the extension of the context *)
-  let genctyp = it_mkProd_or_LetIn ~init:genarg ctx in
+  let genctyp = it_mkProd_or_LetIn genarg ctx in
     (* The goal will become this product. *)
   let genc = mkCast (mkMeta meta, DEFAULTcast, genctyp) in
     (* Apply the old arguments giving the proper instantiation of the hyp *)
@@ -2282,17 +2351,6 @@ let make_abstract_generalize gl id concl dep ctx body c eqs args refls =
   let appeqs = mkApp (instc, Array.of_list refls) in
     (* Finaly, apply the reflexivity proof for the original hyp, to get a term of type gl again. *)
     mkApp (appeqs, abshypt)
-      
-let deps_of_var id env =
-  Environ.fold_named_context
-    (fun _ (n,b,t) (acc : Idset.t) -> 
-      if Option.cata (occur_var env id) false b || occur_var env id t then
-	Idset.add n acc
-      else acc)
-    env ~init:Idset.empty
-    
-let idset_of_list =
-  List.fold_left (fun s x -> Idset.add x s) Idset.empty
 
 let hyps_of_vars env sign nogen hyps =
   if Idset.is_empty hyps then [] 
@@ -2311,6 +2369,23 @@ let hyps_of_vars env sign nogen hyps =
         sign 
     in lh
 
+exception Seen
+
+let linear vars args = 
+  let seen = ref vars in
+    try 
+      Array.iter (fun i -> 
+	let rels = ids_of_constr ~all:true Idset.empty i in
+	let seen' = 
+	  Idset.fold (fun id acc ->
+	    if Idset.mem id acc then raise Seen
+	    else Idset.add id acc)
+	    rels !seen
+	in seen := seen')
+	args;
+      true
+    with Seen -> false
+
 let is_defined_variable env id =
   pi2 (lookup_named id env) <> None
 
@@ -2337,6 +2412,7 @@ let abstract_args gl generalize_vars dep id defined f args =
     in
     let argty = pf_type_of gl arg in
     let argty = refresh_universes_strict argty in 
+    let ty = refresh_universes_strict ty in
     let lenctx = List.length ctx in
     let liftargty = lift lenctx argty in
     let leq = constr_cmp Reduction.CUMUL liftargty ty in
@@ -2364,23 +2440,19 @@ let abstract_args gl generalize_vars dep id defined f args =
 	    nongenvars, Idset.union argvars vars, env)
   in 
   let f', args' = decompose_indapp f args in
-  let parvars = ids_of_constr ~all:true Idset.empty f' in
-  let seen = ref parvars in
   let dogen, f', args' =
-    let find i x = not (isVar x) || 
-      let v = destVar x in
-	if is_defined_variable env v || Idset.mem v !seen then true
-	else (seen := Idset.add v !seen; false)
-    in
-      match array_find_i find args' with
-      | None -> false, f', args'
-      | Some nonvar ->
-	  let before, after = array_chop nonvar args' in
-	    true, mkApp (f', before), after
+    let parvars = ids_of_constr ~all:true Idset.empty f' in
+      if not (linear parvars args') then true, f, args
+      else
+	match array_find_i (fun i x -> not (isVar x) || is_defined_variable env (destVar x)) args' with
+	| None -> false, f', args'
+	| Some nonvar ->
+	    let before, after = array_chop nonvar args' in
+	      true, mkApp (f', before), after
   in
     if dogen then
-      let arity, ctx, ctxenv, c', args, eqs, refls, nogen, vars, env =
-	Array.fold_left aux (pf_type_of gl f',[],env,f',[],[],[],!seen,Idset.empty,env) args'
+      let arity, ctx, ctxenv, c', args, eqs, refls, nogen, vars, env = 
+	Array.fold_left aux (pf_type_of gl f',[],env,f',[],[],[],Idset.empty,Idset.empty,env) args'
       in
       let args, refls = List.rev args, List.rev refls in
       let vars = 
@@ -2389,7 +2461,7 @@ let abstract_args gl generalize_vars dep id defined f args =
 	    hyps_of_vars (pf_env gl) (pf_hyps gl) nogen vars
 	else []
       in
-      let body, c' = if defined then Some c', Retyping.get_type_of ctxenv Evd.empty c' else None, c' in
+      let body, c' = if defined then Some c', typ_of ctxenv Evd.empty c' else None, c' in
 	Some (make_abstract_generalize gl id concl dep ctx body c' eqs args refls,
 	     dep, succ (List.length ctx), vars)
     else None
@@ -2429,20 +2501,20 @@ let abstract_generalize ?(generalize_vars=true) ?(force_dep=false) id gl =
 let specialize_eqs id gl =
   let env = pf_env gl in
   let ty = pf_get_hyp_typ gl id in
-  let evars = ref (create_evar_defs (project gl)) in
+  let evars = ref (project gl) in
   let unif env evars c1 c2 = Evarconv.e_conv env evars c2 c1 in
   let rec aux in_eqs ctx acc ty =
     match kind_of_term ty with
     | Prod (na, t, b) -> 
 	(match kind_of_term t with
-	| App (eq, [| eqty; x; y |]) when in_eqs && eq_constr eq (Lazy.force coq_eq) ->
+	| App (eq, [| eqty; x; y |]) when eq_constr eq (Lazy.force coq_eq) ->
 	    let c = if noccur_between 1 (List.length ctx) x then y else x in
 	    let pt = mkApp (Lazy.force coq_eq, [| eqty; c; c |]) in
 	    let p = mkApp (Lazy.force coq_eq_refl, [| eqty; c |]) in
 	      if unif (push_rel_context ctx env) evars pt t then
 		aux true ctx (mkApp (acc, [| p |])) (subst1 p b)
 	      else acc, in_eqs, ctx, ty
-	| App (heq, [| eqty; x; eqty'; y |]) when in_eqs && eq_constr heq (Lazy.force coq_heq) ->
+	| App (heq, [| eqty; x; eqty'; y |]) when eq_constr heq (Lazy.force coq_heq) ->
 	    let eqt, c = if noccur_between 1 (List.length ctx) x then eqty', y else eqty, x in
 	    let pt = mkApp (Lazy.force coq_heq, [| eqt; c; eqt; c |]) in
 	    let p = mkApp (Lazy.force coq_heq_refl, [| eqt; c |]) in
@@ -2454,10 +2526,8 @@ let specialize_eqs id gl =
 	    else 
 	      let e = e_new_evar evars (push_rel_context ctx env) t in
 		aux false ((na, Some e, t) :: ctx) (mkApp (lift 1 acc, [| mkRel 1 |])) b)
-    | App (f, args) when eq_constr f (Lazy.force coq_block) && not in_eqs ->
-	aux true ctx acc args.(1)
     | t -> acc, in_eqs, ctx, ty
-  in
+  in 
   let acc, worked, ctx, ty = aux false [] (mkVar id) ty in
   let ctx' = nf_rel_context_evar !evars ctx in
   let ctx'' = List.map (fun (n,b,t as decl) ->
@@ -2485,33 +2555,6 @@ let occur_rel n c =
   let res = not (noccurn n c) in
   res
 
-let list_filter_firsts f l =
-  let rec list_filter_firsts_aux f acc l =
-    match l with
-      | e::l' when f e -> list_filter_firsts_aux f (acc@[e]) l'
-      | _ -> acc,l
-  in
-  list_filter_firsts_aux f [] l
-
-let count_rels_from n c =
-  let rels = free_rels c in
-  let cpt,rg = ref 0, ref n in
-  while Intset.mem !rg rels do
-    cpt:= !cpt+1; rg:= !rg+1;
-  done;
-  !cpt
-
-let count_nonfree_rels_from n c =
-  let rels = free_rels c in
-  if Intset.exists (fun x -> x >= n) rels then
-    let cpt,rg = ref 0, ref n in
-    while not (Intset.mem !rg rels) do
-      cpt:= !cpt+1; rg:= !rg+1;
-    done;
-    !cpt
-  else raise Not_found
-
-
 (* cuts a list in two parts, first of size n. Size must be greater than n *)
 let cut_list n l =
   let rec cut_list_aux acc n l =
@@ -2671,83 +2714,62 @@ let compute_elim_sig ?elimc elimt =
 let compute_scheme_signature scheme names_info ind_type_guess =
   let f,l = decompose_app scheme.concl in
   (* Vérifier que les arguments de Qi sont bien les xi. *)
-  match scheme.indarg with
-    | Some (_,Some _,_) -> error "Strange letin, cannot recognize an induction scheme."
-    | None -> (* Non standard scheme *)
-	let is_pred n c =
-	  let hd = fst (decompose_app c) in match kind_of_term hd with
-	    | Rel q when n < q & q <= n+scheme.npredicates -> IndArg
-	    | _ when hd = ind_type_guess & not scheme.farg_in_concl -> RecArg
-	    | _ -> OtherArg in
-	let rec check_branch p c =
-	  match kind_of_term c with
-	    | Prod (_,t,c) ->
-		(is_pred p t, dependent (mkRel 1) c) :: check_branch (p+1) c
-	    | LetIn (_,_,_,c) ->
-		(OtherArg, dependent (mkRel 1) c) :: check_branch (p+1) c
-	    | _ when is_pred p c = IndArg -> []
-	    | _ -> raise Exit in
-	let rec find_branches p lbrch =
-	  match lbrch with
-	    | (_,None,t)::brs ->
-		(try
-		  let lchck_brch = check_branch p t in
-		  let n = List.fold_left
-		    (fun n (b,_) -> if b=RecArg then n+1 else n) 0 lchck_brch in
-		  let recvarname, hyprecname, avoid =
-		    make_up_names n scheme.indref names_info in
-		  let namesign =
-		    List.map (fun (b,dep) ->
-		      (b,dep,if b=IndArg then hyprecname else recvarname))
-		      lchck_brch in
-		  (avoid,namesign) :: find_branches (p+1) brs
-		with Exit-> error_ind_scheme "the branches of")
-	    | (_,Some _,_)::_ -> error_ind_scheme "the branches of"
-	    | [] -> [] in
-	Array.of_list (find_branches 0 (List.rev scheme.branches))
-
-    | Some ( _,None,ind) -> (* Standard scheme from an inductive type *)
-	let indhd,indargs = decompose_app ind in
-	let is_pred n c =
-	  let hd = fst (decompose_app c) in match kind_of_term hd with
-	    | Rel q when n < q & q <= n+scheme.npredicates -> IndArg
-	    | _ when hd = indhd -> RecArg
-	    | _ -> OtherArg in
-	let rec check_branch p c = match kind_of_term c with
-	  | Prod (_,t,c) ->
-	      (is_pred p t, dependent (mkRel 1) c) :: check_branch (p+1) c
-	  | LetIn (_,_,_,c) ->
-	      (OtherArg, dependent (mkRel 1) c) :: check_branch (p+1) c
-	  | _ when is_pred p c = IndArg -> []
-	  | _ -> raise Exit in
-	let rec find_branches p lbrch =
-	  match lbrch with
-	    | (_,None,t)::brs ->
-		(try
-		  let lchck_brch = check_branch p t in
-		  let n = List.fold_left
-		    (fun n (b,_) -> if b=RecArg then n+1 else n) 0 lchck_brch in
-		  let recvarname, hyprecname, avoid =
-		    make_up_names n scheme.indref names_info in
-		  let namesign =
-		    List.map (fun (b,dep) ->
-		      (b,dep,if b=IndArg then hyprecname else recvarname))
-		      lchck_brch in
-		  (avoid,namesign) :: find_branches (p+1) brs
-		with Exit -> error_ind_scheme "the branches of")
-	    | (_,Some _,_)::_ -> error_ind_scheme "the branches of"
-	    | [] ->
-		(* Check again conclusion *)
-
-		let ccl_arg_ok = is_pred (p + scheme.nargs + 1) f = IndArg in
-		let ind_is_ok =
-		  list_lastn scheme.nargs indargs
-		  = extended_rel_list 0 scheme.args in
-		if not (ccl_arg_ok & ind_is_ok) then
-		  error_ind_scheme "the conclusion of";
-		[]
-	in
-	Array.of_list (find_branches 0 (List.rev scheme.branches))
+  let cond, check_concl =
+    match scheme.indarg with
+      | Some (_,Some _,_) ->
+	  error "Strange letin, cannot recognize an induction scheme."
+      | None -> (* Non standard scheme *)
+	  let cond hd = eq_constr hd ind_type_guess && not scheme.farg_in_concl
+	  in (cond, fun _ _ -> ())
+      | Some ( _,None,ind) -> (* Standard scheme from an inductive type *)
+	  let indhd,indargs = decompose_app ind in
+	  let cond hd = eq_constr hd indhd in
+	  let check_concl is_pred p =
+	    (* Check again conclusion *)
+	    let ccl_arg_ok = is_pred (p + scheme.nargs + 1) f = IndArg in
+	    let ind_is_ok =
+	      list_equal eq_constr
+		(list_lastn scheme.nargs indargs)
+		(extended_rel_list 0 scheme.args) in
+	    if not (ccl_arg_ok & ind_is_ok) then
+	      error_ind_scheme "the conclusion of"
+	  in (cond, check_concl)
+  in
+  let is_pred n c =
+    let hd = fst (decompose_app c) in
+    match kind_of_term hd with
+      | Rel q when n < q & q <= n+scheme.npredicates -> IndArg
+      | _ when cond hd -> RecArg
+      | _ -> OtherArg
+  in
+  let rec check_branch p c =
+    match kind_of_term c with
+      | Prod (_,t,c) ->
+	(is_pred p t, dependent (mkRel 1) c) :: check_branch (p+1) c
+      | LetIn (_,_,_,c) ->
+	(OtherArg, dependent (mkRel 1) c) :: check_branch (p+1) c
+      | _ when is_pred p c = IndArg -> []
+      | _ -> raise Exit
+  in
+  let rec find_branches p lbrch =
+    match lbrch with
+      | (_,None,t)::brs ->
+	(try
+	   let lchck_brch = check_branch p t in
+	   let n = List.fold_left
+	     (fun n (b,_) -> if b=RecArg then n+1 else n) 0 lchck_brch in
+	   let recvarname, hyprecname, avoid =
+	     make_up_names n scheme.indref names_info in
+	   let namesign =
+	     List.map (fun (b,dep) ->
+	       (b,dep,if b=IndArg then hyprecname else recvarname))
+	       lchck_brch in
+	   (avoid,namesign) :: find_branches (p+1) brs
+	 with Exit-> error_ind_scheme "the branches of")
+      | (_,Some _,_)::_ -> error_ind_scheme "the branches of"
+      | [] -> check_concl is_pred p; []
+  in
+  Array.of_list (find_branches 0 (List.rev scheme.branches))
 
 (* Check that the elimination scheme has a form similar to the
    elimination schemes built by Coq. Schemes may have the standard
@@ -2885,7 +2907,7 @@ let induction_tac_felim with_evars indvars nparams elim gl =
   (* elimclause' is built from elimclause by instanciating all args and params. *)
   let elimclause' = recolle_clenv nparams indvars elimclause gl in
   (* one last resolution (useless?) *)
-  let resolved = clenv_unique_resolver true elimclause' gl in
+  let resolved = clenv_unique_resolver ~flags:elim_flags elimclause' gl in
   clenv_refine with_evars resolved gl
 
 (* Apply induction "in place" replacing the hypothesis on which
@@ -2895,7 +2917,9 @@ let apply_induction_with_discharge induct_tac elim indhyps destopt avoid names t
   let isrec, elim, indsign = get_eliminator elim gl in
   let names = compute_induction_names (Array.length indsign) names in
   (if isrec then tclTHENFIRSTn else tclTHENLASTn)
-    (tclTHEN (induct_tac elim) (tclTRY (thin indhyps)))
+    (tclTHEN
+       (induct_tac elim)
+       (tclMAP (fun id -> tclTRY (expand_hyp id)) (List.rev indhyps)))
     (array_map2 (induct_discharge destopt avoid tac) indsign names) gl
 
 (* Apply induction "in place" taking into account dependent
@@ -2979,7 +3003,7 @@ let induction_tac with_evars elim (varname,lbind) typ gl =
   let elimclause =
     make_clenv_binding gl
       (mkCast (elimc,DEFAULTcast,elimt),elimt) lbindelimc in
-  elimination_clause_scheme with_evars true i elimclause indclause gl
+  elimination_clause_scheme with_evars i elimclause indclause gl
 
 let induction_from_context isrec with_evars (indref,nparams,elim) (hyp0,lbind) names
   inhyps gl =
@@ -3017,14 +3041,6 @@ let induction_without_atomization isrec with_evars elim names lid gl =
   then error "Not the right number of induction arguments."
   else induction_from_context_l with_evars elim_info lid names gl
 
-let enforce_eq_name id gl = function
-  | (b,(loc,IntroAnonymous)) ->
-      (b,(loc,IntroIdentifier (fresh_id [id] (add_prefix "Heq" id) gl)))
-  | (b,(loc,IntroFresh heq_base)) ->
-      (b,(loc,IntroIdentifier (fresh_id [id] heq_base gl)))
-  | x ->
-      x
-
 let has_selected_occurrences = function
   | None -> false
   | Some cls ->
@@ -3054,7 +3070,7 @@ let clear_unselected_context id inhyps cls gl =
 	  thin ids gl
       | None -> tclIDTAC gl
 
-let new_induct_gen isrec with_evars elim (eqname,names) (c,lbind) cls gl =
+let new_induct_gen isrec with_evars elim (eqname,names) (sigma,(c,lbind)) cls gl =
   let inhyps = match cls with
   | Some {onhyps=Some hyps} -> List.map (fun ((_,id),_) -> id) hyps
   | _ -> [] in
@@ -3067,14 +3083,17 @@ let new_induct_gen isrec with_evars elim (eqname,names) (c,lbind) cls gl =
 	  (induction_with_atomization_of_ind_arg
 	    isrec with_evars elim names (id,lbind) inhyps) gl
     | _        ->
-	let x = id_of_name_using_hdchar (Global.env()) (pf_type_of gl c)
+	let x = id_of_name_using_hdchar (Global.env()) (typ_of (pf_env gl) sigma c)
 		  Anonymous in
 	let id = fresh_id [] x gl in
 	(* We need the equality name now *)
 	let with_eq = Option.map (fun eq -> (false,eq)) eqname in
 	(* TODO: if ind has predicate parameters, use JMeq instead of eq *)
 	tclTHEN
-	  (letin_tac_gen with_eq (Name id) c None (Option.default allHypsAndConcl cls,false))
+          (* Warning: letin is buggy when c is not of inductive type *)
+	  (letin_tac_gen with_eq (Name id) (sigma,c)
+             (make_pattern_test (pf_env gl) (project gl) (sigma,c))
+             None (Option.default allHypsAndConcl cls,false))
 	  (induction_with_atomization_of_ind_arg
 	     isrec with_evars elim names (id,lbind) inhyps) gl
 
@@ -3131,7 +3150,7 @@ let induct_destruct isrec with_evars (lc,elim,names,cls) gl =
   assert (List.length lc > 0); (* ensured by syntax, but if called inside caml? *)
   if List.length lc = 1 && not (is_functional_induction elim gl) then
     (* standard induction *)
-    onInductionArg
+    onOpenInductionArg
       (fun c -> new_induct_gen isrec with_evars elim names c cls)
       (List.hd lc) gl
   else begin
@@ -3143,6 +3162,8 @@ let induct_destruct isrec with_evars (lc,elim,names,cls) gl =
       str "Example: induction x1 x2 x3 using my_scheme.");
     if cls <> None then
       error "'in' clause not supported here.";
+    let lc = List.map
+      (map_induction_arg (pf_apply finish_evar_resolution gl)) lc in
     if List.length lc = 1 then
       (* Hook to recover standard induction on non-standard induction schemes *)
       (* will be removable when is_functional_induction will be more clever *)
@@ -3150,8 +3171,7 @@ let induct_destruct isrec with_evars (lc,elim,names,cls) gl =
 	(fun (c,lbind) ->
 	  if lbind <> NoBindings then
 	    error "'with' clause not supported here.";
-	  new_induct_gen_l isrec with_evars elim names [c])
-	(List.hd lc) gl
+	  new_induct_gen_l isrec with_evars elim names [c]) (List.hd lc) gl
     else
       let newlc =
 	List.map (fun x ->
@@ -3179,11 +3199,8 @@ let new_destruct ev lc e idl cls = induct_destruct false ev (lc,e,idl,cls)
 (* Induction tactics *)
 
 (* This was Induction before 6.3 (induction only in quantified premisses) *)
-let raw_induct s = tclTHEN (intros_until_id s) (onLastHyp simplest_elim)
-let raw_induct_nodep n = tclTHEN (intros_until_n n) (onLastHyp simplest_elim)
-
-let simple_induct_id hyp = raw_induct hyp
-let simple_induct_nodep = raw_induct_nodep
+let simple_induct_id s = tclTHEN (intros_until_id s) (onLastHyp simplest_elim)
+let simple_induct_nodep n = tclTHEN (intros_until_n n) (onLastHyp simplest_elim)
 
 let simple_induct = function
   | NamedHyp id -> simple_induct_id id
@@ -3213,9 +3230,9 @@ let elim_scheme_type elim t gl =
     | Meta mv ->
         let clause' =
 	  (* t is inductive, then CUMUL or CONV is irrelevant *)
-	  clenv_unify true Reduction.CUMUL t
+	  clenv_unify ~flags:elim_flags Reduction.CUMUL t
             (clenv_meta_type clause mv) clause in
-	res_pf clause' ~allow_K:true gl
+	res_pf clause' ~flags:elim_flags gl
     | _ -> anomaly "elim_scheme_type"
 
 let elim_type t gl =
@@ -3472,7 +3489,7 @@ let abstract_subproof id tac gl =
   let const = Pfedit.build_constant_by_tactic id secsign concl
     (tclCOMPLETE (tclTHEN (tclDO (List.length sign) intro) tac)) in
   let cd = Entries.DefinitionEntry const in
-  let lem = mkConst (Declare.declare_internal_constant id (cd,IsProof Lemma)) in
+  let lem = mkConst (Declare.declare_constant ~internal:Declare.KernelSilent id (cd,IsProof Lemma)) in
   exact_no_check
     (applist (lem,List.rev (Array.to_list (instance_from_named_context sign))))
     gl
@@ -3501,8 +3518,9 @@ let admit_as_an_axiom gl =
   let concl = it_mkNamedProd_or_LetIn (pf_concl gl) sign in
   if occur_existential concl then error"\"admit\" cannot handle existentials.";
   let axiom =
-    let cd = Entries.ParameterEntry (concl,false) in
-    let con = Declare.declare_internal_constant na (cd,IsAssumption Logical) in
+    let cd = 
+      Entries.ParameterEntry (Pfedit.get_used_variables(),concl,None) in
+    let con = Declare.declare_constant ~internal:Declare.KernelSilent na (cd,IsAssumption Logical) in
     constr_of_global (ConstRef con)
   in
   exact_no_check
@@ -3517,7 +3535,6 @@ let unify ?(state=full_transparent_state) x y gl =
 	modulo_delta = state;
 	modulo_conv_on_closed_terms = Some state}
     in
-    let evd = w_unify false (pf_env gl) Reduction.CONV
-      ~flags x y (Evd.create_evar_defs (project gl))
+    let evd = w_unify (pf_env gl) (project gl) Reduction.CONV ~flags x y
     in tclEVARS evd gl
   with _ -> tclFAIL 0 (str"Not unifiable") gl
diff --git a/tactics/tactics.mli b/tactics/tactics.mli
index 5ceade1f..f8f32b79 100644
--- a/tactics/tactics.mli
+++ b/tactics/tactics.mli
@@ -1,14 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: tactics.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Util
 open Names
 open Term
@@ -26,14 +23,14 @@ open Libnames
 open Genarg
 open Tacexpr
 open Nametab
-open Rawterm
+open Glob_term
 open Pattern
 open Termops
-(*i*)
+open Unification
 
-(* Main tactics. *)
+(** Main tactics. *)
 
-(*s General functions. *)
+(** {6 General functions. } *)
 
 val string_of_inductive : constr -> string
 val head_constr       : constr -> constr * constr list
@@ -42,7 +39,7 @@ val is_quantified_hypothesis : identifier -> goal sigma -> bool
 
 exception Bound
 
-(*s Primitive tactics. *)
+(** {6 Primitive tactics. } *)
 
 val introduction    : identifier -> tactic
 val refine          : constr -> tactic
@@ -55,7 +52,7 @@ val fix             : identifier option -> int -> tactic
 val mutual_cofix    : identifier -> (identifier * constr) list -> int -> tactic
 val cofix           : identifier option -> tactic
 
-(*s Introduction tactics. *)
+(** {6 Introduction tactics. } *)
 
 val fresh_id_in_env : identifier list -> identifier -> env -> identifier
 val fresh_id : identifier list -> identifier -> goal sigma -> identifier
@@ -65,20 +62,21 @@ val intro                : tactic
 val introf               : tactic
 val intro_move        : identifier option -> identifier move_location -> tactic
 
-  (* [intro_avoiding idl] acts as intro but prevents the new identifier
+  (** [intro_avoiding idl] acts as intro but prevents the new identifier
      to belong to [idl] *)
 val intro_avoiding       : identifier list -> tactic
 
 val intro_replacing      : identifier -> tactic
 val intro_using          : identifier -> tactic
 val intro_mustbe_force   : identifier -> tactic
+val intro_then           : (identifier -> tactic) -> tactic
 val intros_using         : identifier list -> tactic
 val intro_erasing        : identifier -> tactic
 val intros_replacing     : identifier list -> tactic
 
 val intros               : tactic
 
-(* [depth_of_quantified_hypothesis b h g] returns the index of [h] in
+(** [depth_of_quantified_hypothesis b h g] returns the index of [h] in
    the conclusion of goal [g], up to head-reduction if [b] is [true] *)
 val depth_of_quantified_hypothesis :
   bool -> quantified_hypothesis -> goal sigma -> int
@@ -88,7 +86,7 @@ val intros_until         : quantified_hypothesis -> tactic
 
 val intros_clearing      : bool list -> tactic
 
-(* Assuming a tactic [tac] depending on an hypothesis identifier,
+(** Assuming a tactic [tac] depending on an hypothesis identifier,
    [try_intros_until tac arg] first assumes that arg denotes a
    quantified hypothesis (denoted by name or by index) and try to
    introduce it in context before to apply [tac], otherwise assume the
@@ -97,21 +95,21 @@ val intros_clearing      : bool list -> tactic
 val try_intros_until :
   (identifier -> tactic) -> quantified_hypothesis -> tactic
 
-(* Apply a tactic on a quantified hypothesis, an hypothesis in context
+(** Apply a tactic on a quantified hypothesis, an hypothesis in context
    or a term with bindings *)
 
 val onInductionArg :
   (constr with_bindings -> tactic) ->
     constr with_bindings induction_arg -> tactic
 
-(*s Introduction tactics with eliminations. *)
+(** {6 Introduction tactics with eliminations. } *)
 
 val intro_pattern  : identifier move_location -> intro_pattern_expr -> tactic
 val intro_patterns : intro_pattern_expr located list -> tactic
 val intros_pattern :
   identifier move_location -> intro_pattern_expr located list -> tactic
 
-(*s Exact tactics. *)
+(** {6 Exact tactics. } *)
 
 val assumption       : tactic
 val exact_no_check   : constr -> tactic
@@ -119,7 +117,7 @@ val vm_cast_no_check : constr -> tactic
 val exact_check      : constr -> tactic
 val exact_proof      : Topconstr.constr_expr -> tactic
 
-(*s Reduction tactics. *)
+(** {6 Reduction tactics. } *)
 
 type tactic_reduction = env -> evar_map -> constr -> constr
 
@@ -156,7 +154,7 @@ val pattern_option    :
 val reduce            : red_expr -> clause -> tactic
 val unfold_constr     : global_reference -> tactic
 
-(*s Modification of the local context. *)
+(** {6 Modification of the local context. } *)
 
 val clear         : identifier list -> tactic
 val clear_body    : identifier list -> tactic
@@ -169,7 +167,7 @@ val rename_hyp    : (identifier * identifier) list -> tactic
 
 val revert        : identifier list -> tactic
 
-(*s Resolution tactics. *)
+(** {6 Resolution tactics. } *)
 
 val apply_type : constr -> constr list -> tactic
 val apply_term : constr -> constr list -> tactic
@@ -193,7 +191,7 @@ val apply_in :
 
 val simple_apply_in : identifier -> constr -> tactic
 
-(*s Elimination tactics. *)
+(** {6 Elimination tactics. } *)
 
 
 (*
@@ -219,52 +217,52 @@ val simple_apply_in : identifier -> constr -> tactic
   Principles taken from functional induction have the final (f...).
 *)
 
-(* [rel_contexts] and [rel_declaration] actually contain triples, and
+(** [rel_contexts] and [rel_declaration] actually contain triples, and
    lists are actually in reverse order to fit [compose_prod]. *)
 type elim_scheme = {
   elimc: constr with_bindings option;
   elimt: types;
   indref: global_reference option;
-  index: int;              (* index of the elimination type in the scheme *)
-  params: rel_context;     (* (prm1,tprm1);(prm2,tprm2)...(prmp,tprmp) *)
-  nparams: int;            (* number of parameters *)
-  predicates: rel_context; (* (Qq, (Tq_1 -> Tq_2 ->...-> Tq_nq)), (Q1,...) *)
-  npredicates: int;        (* Number of predicates *)
-  branches: rel_context;   (* branchr,...,branch1 *)
-  nbranches: int;          (* Number of branches *)
-  args: rel_context;       (* (xni, Ti_ni) ... (x1, Ti_1) *)
-  nargs: int;              (* number of arguments *)
-  indarg: rel_declaration option; (* Some (H,I prm1..prmp x1...xni)
+  index: int;              (** index of the elimination type in the scheme *)
+  params: rel_context;     (** (prm1,tprm1);(prm2,tprm2)...(prmp,tprmp) *)
+  nparams: int;            (** number of parameters *)
+  predicates: rel_context; (** (Qq, (Tq_1 -> Tq_2 ->...-> Tq_nq)), (Q1,...) *)
+  npredicates: int;        (** Number of predicates *)
+  branches: rel_context;   (** branchr,...,branch1 *)
+  nbranches: int;          (** Number of branches *)
+  args: rel_context;       (** (xni, Ti_ni) ... (x1, Ti_1) *)
+  nargs: int;              (** number of arguments *)
+  indarg: rel_declaration option; (** Some (H,I prm1..prmp x1...xni)
 				     if HI is in premisses, None otherwise *)
-  concl: types;            (* Qi x1...xni HI (f...), HI and (f...)
+  concl: types;            (** Qi x1...xni HI (f...), HI and (f...)
 			      are optional and mutually exclusive *)
-  indarg_in_concl: bool;   (* true if HI appears at the end of conclusion *)
-  farg_in_concl: bool;     (* true if (f...) appears at the end of conclusion *)
+  indarg_in_concl: bool;   (** true if HI appears at the end of conclusion *)
+  farg_in_concl: bool;     (** true if (f...) appears at the end of conclusion *)
 }
 
 
 val compute_elim_sig : ?elimc: constr with_bindings -> types -> elim_scheme
 val rebuild_elimtype_from_scheme: elim_scheme -> types
 
-(* elim principle with the index of its inductive arg *)
+(** elim principle with the index of its inductive arg *)
 type eliminator = {
-  elimindex : int option;  (* None = find it automatically *)
+  elimindex : int option;  (** None = find it automatically *)
   elimbody : constr with_bindings
 }
 
-val elimination_clause_scheme : evars_flag ->
-  bool -> int -> clausenv -> clausenv -> tactic
+val elimination_clause_scheme : evars_flag -> ?flags:unify_flags -> 
+  int -> clausenv -> clausenv -> tactic
 
-val elimination_in_clause_scheme : evars_flag -> identifier -> int ->
-  clausenv -> clausenv -> tactic
+val elimination_in_clause_scheme : evars_flag -> ?flags:unify_flags -> 
+  identifier -> int -> clausenv -> clausenv -> tactic
 
 val general_elim_clause_gen : (int -> Clenv.clausenv -> 'a -> tactic) ->
   'a -> eliminator -> tactic
 
 val general_elim  : evars_flag ->
-  constr with_bindings -> eliminator -> ?allow_K:bool -> tactic
-val general_elim_in : evars_flag ->
-  identifier -> constr with_bindings -> eliminator -> tactic
+  constr with_bindings -> eliminator -> tactic
+val general_elim_in : evars_flag -> identifier ->
+  constr with_bindings -> eliminator -> tactic
 
 val default_elim  : evars_flag -> constr with_bindings -> tactic
 val simplest_elim : constr -> tactic
@@ -273,37 +271,39 @@ val elim :
 
 val simple_induct : quantified_hypothesis -> tactic
 
-val new_induct : evars_flag -> constr with_bindings induction_arg list ->
+val new_induct : evars_flag -> 
+  (evar_map * constr with_bindings) induction_arg list ->
   constr with_bindings option ->
     intro_pattern_expr located option * intro_pattern_expr located option ->
       clause option -> tactic
 
-(*s Case analysis tactics. *)
+(** {6 Case analysis tactics. } *)
 
 val general_case_analysis : evars_flag -> constr with_bindings ->  tactic
 val simplest_case         : constr -> tactic
 
 val simple_destruct          : quantified_hypothesis -> tactic
-val new_destruct : evars_flag -> constr with_bindings induction_arg list ->
+val new_destruct : evars_flag ->
+  (evar_map * constr with_bindings) induction_arg list ->
   constr with_bindings option ->
     intro_pattern_expr located option * intro_pattern_expr located option ->
       clause option -> tactic
 
-(*s Generic case analysis / induction tactics. *)
+(** {6 Generic case analysis / induction tactics. } *)
 
 val induction_destruct : rec_flag -> evars_flag ->
-  (constr with_bindings induction_arg list *
+  ((evar_map * constr with_bindings) induction_arg list *
   constr with_bindings option *
   (intro_pattern_expr located option * intro_pattern_expr located option))
   list *
   clause option -> tactic
 
-(*s Eliminations giving the type instead of the proof. *)
+(** {6 Eliminations giving the type instead of the proof. } *)
 
 val case_type         : constr  -> tactic
 val elim_type         : constr  -> tactic
 
-(*s Some eliminations which are frequently used. *)
+(** {6 Some eliminations which are frequently used. } *)
 
 val impE : identifier -> tactic
 val andE : identifier -> tactic
@@ -313,7 +313,7 @@ val dAnd : clause -> tactic
 val dorE : bool -> clause ->tactic
 
 
-(*s Introduction tactics. *)
+(** {6 Introduction tactics. } *)
 
 val constructor_tac      : evars_flag -> int option -> int ->
   constr bindings -> tactic
@@ -332,7 +332,7 @@ val simplest_left        : tactic
 val simplest_right       : tactic
 val simplest_split       : tactic
 
-(*s Logical connective tactics. *)
+(** {6 Logical connective tactics. } *)
 
 val register_setoid_reflexivity : tactic -> unit
 val reflexivity_red             : bool -> tactic
@@ -362,13 +362,15 @@ val assert_as : bool -> intro_pattern_expr located option -> constr -> tactic
 val forward   : tactic option -> intro_pattern_expr located option -> constr -> tactic
 val letin_tac : (bool * intro_pattern_expr located) option -> name ->
   constr -> types option -> clause -> tactic
+val letin_pat_tac : (bool * intro_pattern_expr located) option -> name ->
+  evar_map * constr -> types option -> clause -> tactic
 val assert_tac : name -> types -> tactic
 val assert_by  : name -> types -> tactic -> tactic
 val pose_proof : name -> constr -> tactic
 
 val generalize      : constr list -> tactic
 val generalize_gen  : ((occurrences * constr) * name) list -> tactic
-val generalize_dep  : ?with_let:bool (* Don't lose let bindings *) -> constr  -> tactic
+val generalize_dep  : ?with_let:bool (** Don't lose let bindings *) -> constr  -> tactic
 
 val unify           : ?state:Names.transparent_state -> constr -> constr -> tactic
 val resolve_classes : tactic
@@ -382,3 +384,6 @@ val specialize_eqs : identifier -> tactic
 
 val register_general_multi_rewrite :
   (bool -> evars_flag -> constr with_bindings -> clause -> tactic) -> unit
+
+val register_subst_one :
+  (bool -> identifier -> identifier * constr * bool -> tactic) -> unit
diff --git a/tactics/tactics.mllib b/tactics/tactics.mllib
index b885b152..333d6a3a 100644
--- a/tactics/tactics.mllib
+++ b/tactics/tactics.mllib
@@ -19,6 +19,4 @@ Leminv
 Tacinterp
 Evar_tactics
 Autorewrite
-Decl_interp
-Decl_proof_instr
 Tactic_option
diff --git a/tactics/tauto.ml4 b/tactics/tauto.ml4
index a17aba76..b7a58be4 100644
--- a/tactics/tauto.ml4
+++ b/tactics/tauto.ml4
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,8 +8,6 @@
 
 (*i camlp4deps: "parsing/grammar.cma" i*)
 
-(*i $Id: tauto.ml4 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
 open Term
 open Hipattern
 open Names
@@ -55,6 +53,7 @@ open Goptions
 let _ =
   declare_bool_option
     { optsync  = true;
+      optdepr  = false;
       optname  = "unfolding of iff and not in intuition";
       optkey   = ["Intuition";"Iff";"Unfolding"];
       optread  = (fun () -> !iff_unfolding);
@@ -154,10 +153,12 @@ let flatten_contravariant_disj ist =
 	let hyp = valueIn (VConstr ([],hyp)) in
 	iter_tac (list_map_i (fun i arg ->
 	  let typ = valueIn (VConstr ([],mkArrow arg c)) in
+	  let i = Tacexpr.Integer i in
 	  <:tactic<
             let typ := $typ in
             let hyp := $hyp in
-	    assert typ by (intro; apply hyp; constructor $i; assumption)
+	    let i := $i in
+	    assert typ by (intro; apply hyp; constructor i; assumption)
 	  >>) 1 args) <:tactic< let hyp := $hyp in clear hyp >>
       else
 	<:tactic<fail>>
@@ -268,8 +269,6 @@ let t_reduction_not = tacticIn reduction_not
 let intuition_gen tac =
   interp (tacticIn (tauto_intuit t_reduction_not tac))
 
-let simplif_gen = interp (tacticIn simplif)
-
 let tauto_intuitionistic g =
   try intuition_gen <:tactic<fail>> g
   with
@@ -301,5 +300,5 @@ END
 
 TACTIC EXTEND intuition
 | [ "intuition" ] -> [ intuition_gen default_intuition_tac ]
-| [ "intuition" tactic(t) ] -> [ intuition_gen (fst t) ]
+| [ "intuition" tactic(t) ] -> [ intuition_gen t ]
 END
diff --git a/tactics/termdn.ml b/tactics/termdn.ml
index 17329b6f..443acc6f 100644
--- a/tactics/termdn.ml
+++ b/tactics/termdn.ml
@@ -1,19 +1,17 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: termdn.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
 open Util
 open Names
 open Nameops
 open Term
 open Pattern
-open Rawterm
+open Glob_term
 open Libnames
 open Nametab
 
diff --git a/tactics/termdn.mli b/tactics/termdn.mli
index ccfa91a9..c4e747be 100644
--- a/tactics/termdn.mli
+++ b/tactics/termdn.mli
@@ -1,25 +1,21 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: termdn.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
 open Term
 open Pattern
 open Libnames
 open Names
-(*i*)
 
-(* Discrimination nets of terms. *)
+(** Discrimination nets of terms. *)
 
-(* This module registers actions (typically tactics) mapped to patterns *)
+(** This module registers actions (typically tactics) mapped to patterns *)
 
-(* Patterns are stocked linearly as the list of its node in prefix
+(** Patterns are stocked linearly as the list of its node in prefix
 order in such a way patterns having the same prefix have this common
 prefix shared and the seek for the action associated to the patterns
 that a term matches are found in time proportional to the maximal
@@ -38,21 +34,21 @@ sig
     
   val create : unit -> t
     
-  (* [add t (c,a)] adds to table [t] pattern [c] associated to action [act] *)
+  (** [add t (c,a)] adds to table [t] pattern [c] associated to action [act] *)
     
   val add : t -> transparent_state -> (constr_pattern * Z.t) -> t
     
   val rmv : t -> transparent_state -> (constr_pattern * Z.t) -> t
     
-  (* [lookup t c] looks for patterns (with their action) matching term [c] *)
+  (** [lookup t c] looks for patterns (with their action) matching term [c] *)
     
   val lookup : t -> transparent_state -> constr -> (constr_pattern * Z.t) list
     
   val app : ((constr_pattern * Z.t) -> unit) -> t -> unit
 
     
-  (*i*)
-  (* These are for Nbtermdn *)
+  (**/**)
+  (** These are for Nbtermdn *)
  
   type term_label = 
     | GRLabel of global_reference
@@ -68,5 +64,5 @@ sig
   val constr_pat_discr : constr_pattern -> (term_label * constr_pattern list) option
   val constr_val_discr : constr -> (term_label * constr list) lookup_res
     
-(*i*)
+  (**/**)
 end