Imported Upstream version 8.5~beta1+dfsg

83 files changed, 17625 insertions, 13231 deletions

diff --git a/tactics/auto.ml b/tactics/auto.ml
index 3451957e..45052685 100644
--- a/tactics/auto.ml
+++ b/tactics/auto.ml
@@ -1,1011 +1,29 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
+(*
+*)
 open Pp
 open Util
+open Errors
 open Names
-open Nameops
-open Namegen
-open Term
+open Vars
 open Termops
-open Inductiveops
-open Sign
 open Environ
-open Inductive
-open Evd
-open Reduction
-open Typing
-open Pattern
-open Matching
 open Tacmach
-open Proof_type
-open Pfedit
-open Glob_term
-open Evar_refiner
-open Tacred
+open Genredexpr
 open Tactics
 open Tacticals
 open Clenv
-open Hiddentac
-open Libnames
-open Nametab
-open Smartlocate
-open Libobject
-open Library
-open Printer
-open Declarations
 open Tacexpr
-open Mod_subst
-
-(****************************************************************************)
-(*            The Type of Constructions Autotactic Hints                    *)
-(****************************************************************************)
-
-type 'a auto_tactic =
-  | Res_pf     of constr * 'a (* Hint Apply *)
-  | ERes_pf    of constr * 'a (* Hint EApply *)
-  | Give_exact of constr
-  | Res_pf_THEN_trivial_fail of constr * 'a (* Hint Immediate *)
-  | Unfold_nth of evaluable_global_reference       (* Hint Unfold *)
-  | Extern     of glob_tactic_expr       (* Hint Extern *)
-
-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 *)
-  name  : hints_path_atom; (* A potential name to refer to the hint *) 
-  code : 'a auto_tactic     (* the tactic to apply when the concl matches pat *)
-}
-
-type pri_auto_tactic = clausenv gen_auto_tactic
-
-type 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
-    | [] -> [v]
-    | h::tl -> if pri_order v h then v::h::tl else h::(insrec tl)
-  in
-  insrec l
-
-(* Nov 98 -- Papageno *)
-(* 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.
-
-  Une hint_db est une table d'association fonctionelle constr -> search_entry
-  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 ont un pattern
-     - un discrimination net borné (Btermdn.t) constitué de tous les
-       patterns de la seconde liste de tactiques *)
-
-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 = 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) =
-  if x.pri = y.pri && x.pat = y.pat then
-    match x.code,y.code with
-      | Res_pf(cstr,_),Res_pf(cstr1,_) -> 
-	   eq_constr cstr cstr1
-      | ERes_pf(cstr,_),ERes_pf(cstr1,_) -> 
-	  eq_constr cstr cstr1
-      | Give_exact cstr,Give_exact cstr1  -> 
-	  eq_constr cstr cstr1
-      | Res_pf_THEN_trivial_fail(cstr,_)
-	  ,Res_pf_THEN_trivial_fail(cstr1,_) -> 
-	  eq_constr cstr cstr1
-      | _,_ -> false
-  else
-    false
-
-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)
-
-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' = List.stable_sort pri_order_int l' in
-    Sort.merge pri_order l sl'
-
-module Constr_map = Map.Make(RefOrdered)
-
-let is_transparent_gr (ids, csts) = function
-  | VarRef id -> Idpred.mem id ids
-  | ConstRef cst -> Cpred.mem cst csts
-  | IndRef _ | ConstructRef _ -> false
-
-let dummy_goal = Goal.V82.dummy_goal
-
-let translate_hint (go,p) =
-  let mk_clenv (c,t) =
-    let cl = mk_clenv_from dummy_goal (c,t) in {cl with env = empty_env }
-  in
-  let code = match p.code with
-    | Res_pf (c,t) -> Res_pf (c, mk_clenv (c,t))
-    | ERes_pf (c,t) -> ERes_pf (c, mk_clenv (c,t))
-    | Res_pf_THEN_trivial_fail (c,t) ->
-      Res_pf_THEN_trivial_fail (c, mk_clenv (c,t))
-    | Give_exact c -> Give_exact c
-    | Unfold_nth e -> Unfold_nth e
-    | Extern t -> Extern t
-  in
-  (go,{ p with code = code })
-
-let path_matches hp hints =
-  let rec aux hp hints k =
-    match hp, hints with
-    | PathAtom _, [] -> false
-    | PathAtom PathAny, (_ :: hints') -> k hints'
-    | PathAtom p, (h :: hints') -> 
-      if p = h then k hints' else false
-    | PathStar hp', hints -> 
-      k hints || aux hp' hints (fun hints' -> aux hp hints' k)
-    | PathSeq (hp, hp'), hints -> 
-      aux hp hints (fun hints' -> aux hp' hints' k)
-    | PathOr (hp, hp'), hints ->
-      aux hp hints k || aux hp' hints k
-    | PathEmpty, _ -> false
-    | PathEpsilon, hints -> k hints
-  in aux hp hints (fun hints' -> true)
-
-let rec matches_epsilon = function
-  | PathAtom _ -> false
-  | PathStar _ -> true
-  | PathSeq (p, p') -> matches_epsilon p && matches_epsilon p'
-  | PathOr (p, p') -> matches_epsilon p || matches_epsilon p'
-  | PathEmpty -> false
-  | PathEpsilon -> true
-
-let rec is_empty = function
-  | PathAtom _ -> false
-  | PathStar _ -> false
-  | PathSeq (p, p') -> is_empty p || is_empty p'
-  | PathOr (p, p') -> matches_epsilon p && matches_epsilon p'
-  | PathEmpty -> true
-  | PathEpsilon -> false
-
-let rec path_derivate hp hint =
-  let rec derivate_atoms hints hints' =
-    match hints, hints' with
-    | gr :: grs, gr' :: grs' when gr = gr' -> derivate_atoms grs grs'
-    | [], [] -> PathEpsilon
-    | [], hints -> PathEmpty
-    | grs, [] -> PathAtom (PathHints grs)
-    | _, _ -> PathEmpty 
-  in
-    match hp with
-    | PathAtom PathAny -> PathEpsilon
-    | PathAtom (PathHints grs) -> 
-      (match grs, hint with
-       | h :: hints, PathAny -> PathEmpty
-       | hints, PathHints hints' -> derivate_atoms hints hints'
-       | _, _ -> assert false)
-    | PathStar p -> if path_matches p [hint] then hp else PathEpsilon
-    | PathSeq (hp, hp') ->
-      let hpder = path_derivate hp hint in
-	if matches_epsilon hp then 
-	  PathOr (PathSeq (hpder, hp'), path_derivate hp' hint)
-	else if is_empty hpder then PathEmpty 
-	else PathSeq (hpder, hp')
-    | PathOr (hp, hp') ->
-      PathOr (path_derivate hp hint, path_derivate hp' hint)
-    | PathEmpty -> PathEmpty
-    | PathEpsilon -> PathEmpty
-
-let rec normalize_path h =
-  match h with
-  | PathStar PathEpsilon -> PathEpsilon
-  | PathSeq (PathEmpty, _) | PathSeq (_, PathEmpty) -> PathEmpty
-  | PathSeq (PathEpsilon, p) | PathSeq (p, PathEpsilon) -> normalize_path p
-  | PathOr (PathEmpty, p) | PathOr (p, PathEmpty) -> normalize_path p
-  | PathOr (p, q) -> 
-    let p', q' = normalize_path p, normalize_path q in
-      if p = p' && q = q' then h
-      else normalize_path (PathOr (p', q'))
-  | PathSeq (p, q) -> 
-    let p', q' = normalize_path p, normalize_path q in
-      if p = p' && q = q' then h
-      else normalize_path (PathSeq (p', q'))
-  | _ -> h
-
-let path_derivate hp hint = normalize_path (path_derivate hp hint)
-
-let rec pp_hints_path = function
-  | PathAtom (PathAny) -> str"."
-  | PathAtom (PathHints grs) -> prlist_with_sep pr_spc pr_global grs
-  | PathStar p -> str "(" ++ pp_hints_path p ++ str")*"
-  | PathSeq (p, p') -> pp_hints_path p ++ str" ; " ++ pp_hints_path p'
-  | PathOr (p, p') -> 
-    str "(" ++ pp_hints_path p ++ spc () ++ str"|" ++ spc () ++ pp_hints_path p' ++ str ")"
-  | PathEmpty -> str"Ø"
-  | PathEpsilon -> str"ε"
-
-let subst_path_atom subst p =
-  match p with
-  | PathAny -> p
-  | PathHints grs ->
-    let gr' gr = fst (subst_global subst gr) in
-    let grs' = list_smartmap gr' grs in
-      if grs' == grs then p else PathHints grs'
-
-let rec subst_hints_path subst hp =
-  match hp with
-  | PathAtom p ->
-    let p' = subst_path_atom subst p in
-      if p' == p then hp else PathAtom p'
-  | PathStar p -> let p' = subst_hints_path subst p in
-      if p' == p then hp else PathStar p'
-  | PathSeq (p, q) ->
-    let p' = subst_hints_path subst p in
-    let q' = subst_hints_path subst q in
-      if p' == p && q' == q then hp else PathSeq (p', q')
-  | PathOr (p, q) ->
-    let p' = subst_hints_path subst p in
-    let q' = subst_hints_path subst q in
-      if p' == p && q' == q then hp else PathOr (p', q')
-  | _ -> hp
-
-module Hint_db = struct
-
-  type t = {
-    hintdb_state : Names.transparent_state;
-    hintdb_cut : hints_path;
-    hintdb_unfolds : Idset.t * Cset.t;
-    mutable hintdb_max_id : int;
-    use_dn : bool;
-    hintdb_map : search_entry Constr_map.t;
-    (* A list of unindexed entries starting with an unfoldable constant
-       or with no associated pattern. *)
-    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 = [] }
-
-  let find key db =
-    try Constr_map.find key db.hintdb_map
-    with Not_found -> empty_se
- 
-  let map_none db =
-    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
-      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
-      List.map snd (Sort.merge pri_order (List.map snd db.hintdb_nopat) l')
-
-  let is_exact = function
-    | Give_exact _ -> true
-    | _ -> false
-
-  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 &&
-	  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,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 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,(id,v)) -> addkv gr id v db) db' db.hintdb_nopat
-
-  let add_one kv db =
-    let (k,v) = translate_hint kv in
-    let st',db,rebuild =
-      match v.code with
-      | Unfold_nth egr ->
-	  let addunf (ids,csts) (ids',csts') =
-	    match egr with
-	    | EvalVarRef id -> (Idpred.add id ids, csts), (Idset.add id ids', csts')
-	    | EvalConstRef cst -> (ids, Cpred.add cst csts), (ids', Cset.add cst csts')
-	  in 
-	  let state, unfs = addunf db.hintdb_state db.hintdb_unfolds in
-	    state, { db with hintdb_unfolds = unfs }, true
-      | _ -> db.hintdb_state, db, false
-    in
-    let db = if db.use_dn && rebuild then rebuild_db st' db else db
-    in addkv k (next_hint_id db) v db
-
-  let add_list l db = List.fold_left (fun db k -> add_one k db) db l
-
-  let 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 (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
-
-  let set_transparent_state db st =
-    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
-
-end
-
-module Hintdbmap = Gmap
-
-type hint_db = Hint_db.t
-
-type frozen_hint_db_table = (string,hint_db) Hintdbmap.t
-
-type hint_db_table = (string,hint_db) Hintdbmap.t ref
-
-type hint_db_name = string
-
-let searchtable = (ref Hintdbmap.empty : hint_db_table)
-
-let searchtable_map name =
-  Hintdbmap.find name !searchtable
-let searchtable_add (name,db) =
-  searchtable := Hintdbmap.add name db !searchtable
-let current_db_names () =
-  Hintdbmap.dom !searchtable
-
-(**************************************************************************)
-(*                       Definition of the summary                        *)
-(**************************************************************************)
-
-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
-let unfreeze fs = searchtable := fs
-
-let _ = Summary.declare_summary "search"
-	  { Summary.freeze_function   = freeze;
-	    Summary.unfreeze_function = unfreeze;
-	    Summary.init_function     = init }
-
-
-(**************************************************************************)
-(*             Auxiliary functions to prepare AUTOHINT objects            *)
-(**************************************************************************)
-
-let rec nb_hyp c = match kind_of_term c with
-  | Prod(_,_,c2) -> if noccurn 1 c2 then 1+(nb_hyp c2) else nb_hyp c2
-  | _ -> 0
-
-(* adding and removing tactics in the search table *)
-
-let try_head_pattern c =
-  try head_pattern_bound c
-  with BoundPattern -> error "Bound head variable."
-
-let name_of_constr c = try Some (global_of_constr c) with Not_found -> None
-
-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 hd =
-	  try head_pattern_bound pat
-	  with BoundPattern -> failwith "make_exact_entry"
-	in
-          (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 ?(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 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;
-	    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;
-	     name = name;
-             code = ERes_pf(c,cty) })
-        end
-    | _ -> failwith "make_apply_entry"
-
-(* flags is (e,h,v) with e=true if eapply and h=true if hnf and v=true if verbose
-   c is a constr
-   cty is the type of constr *)
-
-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 ?name; make_apply_entry env sigma flags pri ?name]
-  in
-  if ents = [] then
-    errorlabstrm "Hint"
-      (pr_lconstr c ++ spc() ++
-        (if pi1 flags then str"cannot be used as a hint."
-	else str "can be used as a hint only for eauto."));
-  ents
-
-(* 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 
-       ~name:(PathHints [VarRef hname])
-       (mkVar hname, htyp)]
-  with
-    | Failure _ -> []
-    | e when Logic.catchable_exception e -> anomaly "make_resolve_hyp"
-
-(* REM : in most cases hintname = id *)
-let make_unfold 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;
-     pat = pat;
-     name = PathAny;
-     code = Extern tacast })
-
-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)));
-	      name = name;
-              code=Res_pf_THEN_trivial_fail(c,t) })
-  
-open Vernacexpr
-
-(**************************************************************************)
-(*               declaration of the AUTOHINT library object               *)
-(**************************************************************************)
-
-(* If the database does not exist, it is created *)
-(* TODO: should a warning be printed in this case ?? *)
-
-let get_db dbname =
-  try searchtable_map dbname
-  with Not_found -> Hint_db.empty empty_transparent_state false
-
-let add_hint dbname hintlist = 
-  let db = get_db dbname in
-  let db' = Hint_db.add_list hintlist db in
-    searchtable_add (dbname,db')
-
-let add_transparency dbname grs b =
-  let db = get_db dbname in
-  let st = Hint_db.transparent_state db in
-  let st' =
-    List.fold_left (fun (ids, csts) gr ->
-      match gr with
-      | EvalConstRef c -> (ids, (if b then Cpred.add else Cpred.remove) c csts)
-      | EvalVarRef v -> (if b then Idpred.add else Idpred.remove) v ids, csts)
-      st grs
-  in searchtable_add (dbname, Hint_db.set_transparent_state db st')
-
-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
-  | 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 subst_key gr =
-    let (lab'', elab') = subst_global subst gr in
-    let gr' =
-      (try head_of_constr_reference (fst (head_constr_bound elab'))
-       with Tactics.Bound -> lab'')
-    in if gr' == gr then gr else gr'
-  in
-  let subst_hint (k,data as hint) =
-    let k' = Option.smartmap subst_key k in
-    let pat' = Option.smartmap (subst_pattern subst) data.pat in
-    let code' = match data.code with
-      | Res_pf (c,t) ->
-          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
-          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
-          if ref==ref' then data.code else Unfold_nth ref'
-      | Extern tac ->
-	  let tac' = !forward_subst_tactic subst tac in
-	  if tac==tac' then data.code else Extern tac'
-    in
-    let name' = subst_path_atom subst data.name in
-    let data' =
-      if data.pat==pat' && data.name == name' && data.code==code' then data
-      else { data with pat = pat'; name = name'; code = code' }
-    in
-    if k' == k && data' == data then hint else (k',data')
-  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))
-    | AddHints hintlist ->
-	let hintlist' = list_smartmap subst_hint hintlist in
-	  if hintlist' == hintlist then obj else
-	    (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 = (AddHints []) then Dispose else Substitute obj
-
-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; }
-
-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                      *)
-(**************************************************************************)
-let add_resolves env sigma clist local dbnames =
-  List.iter
-    (fun dbname ->
-       Lib.add_anonymous_leaf
-	 (inAutoHint
-	    (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, 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 =
-  List.iter
-    (fun dbname -> Lib.add_anonymous_leaf
-       (inAutoHint (local,dbname, AddTransparency (l, b))))
-    dbnames
-
-let add_extern pri pat tacast local dbname =
-  (* We check that all metas that appear in tacast have at least
-     one occurence in the left pattern pat *)
-  let tacmetas = [] in
-    match pat with
-    | Some (patmetas,pat) ->
-	(match (list_subtract tacmetas patmetas) with
-	| i::_ ->
-	    errorlabstrm "add_extern"
-	      (str "The meta-variable ?" ++ Ppconstr.pr_patvar i ++ str" is not bound.")
-	| []  ->
-	    Lib.add_anonymous_leaf
-	      (inAutoHint(local,dbname, AddHints [make_extern pri (Some pat) tacast])))
-    | None ->
-	Lib.add_anonymous_leaf
-	  (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
-
-let add_trivials env sigma l local dbnames =
-  List.iter
-    (fun dbname ->
-       Lib.add_anonymous_leaf (
-	 inAutoHint(local,dbname, 
-		    AddHints (List.map (fun (name, c) -> make_trivial env sigma ~name c) l))))
-    dbnames
-
-let forward_intern_tac =
-  ref (fun _ -> failwith "intern_tac is not installed for auto")
-
-let set_extern_intern_tac f = forward_intern_tac := f
-
-type hints_entry =
-  | HintsResolveEntry of (int option * bool * hints_path_atom * constr) list
-  | HintsImmediateEntry of (hints_path_atom * constr) list
-  | HintsCutEntry of hints_path
-  | HintsUnfoldEntry of evaluable_global_reference list
-  | HintsTransparencyEntry of evaluable_global_reference list * bool
-  | HintsExternEntry of
-      int * (patvar list * constr_pattern) option * glob_tactic_expr
-
-let h = id_of_string "H"
-
-exception Found of constr * types
-
-let prepare_hint env (sigma,c) =
-  let sigma = Typeclasses.resolve_typeclasses ~fail:false env sigma in
-  (* We re-abstract over uninstantiated evars.
-     It is actually a bit stupid to generalize over evars since the first
-     thing make_resolves will do is to re-instantiate the products *)
-  let c = drop_extra_implicit_args (Evarutil.nf_evar sigma c) in
-  let vars = ref (collect_vars c) in
-  let subst = ref [] in
-  let rec find_next_evar c = match kind_of_term c with
-    | Evar (evk,args as ev) ->
-      (* We skip the test whether args is the identity or not *)
-      let t = Evarutil.nf_evar sigma (existential_type sigma ev) in
-      let t = List.fold_right (fun (e,id) c -> replace_term e id c) !subst t in
-      if free_rels t <> Intset.empty then
-	error "Hints with holes dependent on a bound variable not supported.";
-      if occur_existential t then
-	(* Not clever enough to construct dependency graph of evars *)
-	error "Not clever enough to deal with evars dependent in other evars.";
-      raise (Found (c,t))
-    | _ -> iter_constr find_next_evar c in
-  let rec iter c =
-    try find_next_evar c; c
-    with Found (evar,t) ->
-      let id = next_ident_away_from h (fun id -> Idset.mem id !vars) in
-      vars := Idset.add id !vars;
-      subst := (evar,mkVar id)::!subst;
-      mkNamedLambda id t (iter (replace_term evar (mkVar id) c)) in
-  iter c
-
-let path_of_constr_expr c =
-  match c with
-  | Topconstr.CRef r ->
-    (try PathHints [global r] with e when Errors.noncritical e -> PathAny)
-  | _ -> PathAny
-      
-let interp_hints h =
-  let f 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 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
-	Dumpglob.dump_reference (fst (qualid_of_reference qid)) "<>" (string_of_reference qid) "ind";
-        list_tabulate (fun i -> let c = (ind,i+1) in
-			 None, true, PathHints [ConstructRef c], mkConstruct c)
-	  (nconstructors ind) in
-	HintsResolveEntry (List.flatten (List.map constr_hints_of_ind lqid))
-  | HintsExtern (pri, patcom, tacexp) ->
-      let pat =	Option.map fp patcom in
-      let tacexp = !forward_intern_tac (match pat with None -> [] | Some (l, _) -> l) tacexp in
-      HintsExternEntry (pri, pat, tacexp)
-
-let add_hints local dbnames0 h =
-  if List.mem "nocore" dbnames0 then
-    error "The hint database \"nocore\" is meant to stay empty.";
-  let dbnames = if dbnames0 = [] then ["core"] else dbnames0 in
-  let env = Global.env() and sigma = Evd.empty in
-  match h with
-  | HintsResolveEntry lhints -> add_resolves env sigma lhints local dbnames
-  | HintsImmediateEntry lhints -> add_trivials env sigma lhints local dbnames
-  | HintsCutEntry lhints -> add_cuts lhints local dbnames
-  | HintsUnfoldEntry lhints -> add_unfolds lhints local dbnames
-  | HintsTransparencyEntry (lhints, b) ->
-      add_transparency lhints b local dbnames
-  | HintsExternEntry (pri, pat, tacexp) ->
-      add_externs pri pat tacexp local dbnames
-
-(**************************************************************************)
-(*                    Functions for printing the hints                    *)
-(**************************************************************************)
-
-let pr_autotactic =
-  function
-  | Res_pf (c,clenv) -> (str"apply " ++ pr_constr c)
-  | ERes_pf (c,clenv) -> (str"eapply " ++ pr_constr c)
-  | Give_exact c -> (str"exact " ++ pr_constr c)
-  | Res_pf_THEN_trivial_fail (c,clenv) ->
-      (str"apply " ++ pr_constr c ++ str" ; trivial")
-  | Unfold_nth c -> (str"unfold " ++  pr_evaluable_reference c)
-  | Extern tac ->
-      let env =
-        try
-          let (_, env) = Pfedit.get_current_goal_context () in
-          env
-        with e when Errors.noncritical e -> Global.env ()
-      in
-      (str "(*external*) " ++ Pptactic.pr_glob_tactic env tac)
-
-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 ())
-
-let pr_hints_db (name,db,hintlist) =
-  (str "In the database " ++ str name ++ str ":" ++
-     if hintlist = [] then (str " nothing" ++ fnl ())
-     else (fnl () ++ pr_hint_list hintlist))
-
-(* Print all hints associated to head c in any database *)
-let pr_hint_list_for_head c =
-  let dbs = Hintdbmap.to_list !searchtable in
-  let valid_dbs =
-    map_succeed
-      (fun (name,db) -> (name,db, List.map (fun v -> 0, v) (Hint_db.map_all c db)))
-      dbs
-  in
-  if valid_dbs = [] then
-    (str "No hint declared for :" ++ pr_global c)
-  else
-    hov 0
-      (str"For " ++ pr_global c ++ str" -> " ++ fnl () ++
-	 hov 0 (prlist pr_hints_db valid_dbs))
-
-let pr_hint_ref ref = pr_hint_list_for_head ref
-
-(* Print all hints associated to head id in any database *)
-let print_hint_ref ref =  ppnl(pr_hint_ref ref)
-
-let pr_hint_term cl =
-  try
-    let dbs = Hintdbmap.to_list !searchtable in
-    let valid_dbs =
-      let fn = try
-	  let (hdc,args) = head_constr_bound cl in
-	  let hd = head_of_constr_reference hdc in
-	    if occur_existential cl then
-	      Hint_db.map_all hd
-	    else Hint_db.map_auto (hd, applist (hdc,args))
-	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
-	(str "No hint applicable for current goal")
-      else
-	(str "Applicable Hints :" ++ fnl () ++
-	    hov 0 (prlist pr_hints_db valid_dbs))
-  with Match_failure _ | Failure _ ->
-    (str "No hint applicable for current goal")
-
-let error_no_such_hint_database x =
-  error ("No such Hint database: "^x^".")
-
-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 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 =
-  let (ids, csts) = Hint_db.transparent_state db in
-  msgnl (hov 0
-	  ((if Hint_db.use_dn db then str"Discriminated database"
-	    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 (List.map (fun x -> (0,x)) hintlist)))
-      | None ->
-	  msg (hov 0
-		  (str "For any goal -> " ++
-		      pr_hint_list (List.map (fun x -> (0, x)) hintlist))))
-    db
-
-let print_hint_db_by_name dbname =
-  try
-    let db = searchtable_map dbname in print_hint_db db
-  with Not_found ->
-    error_no_such_hint_database dbname
-
-(* displays all the hints of all databases *)
-let print_searchtable () =
-  Hintdbmap.iter
-    (fun name db ->
-       msg (str "In the database " ++ str name ++ str ":" ++ fnl ());
-       print_hint_db db)
-    !searchtable
+open Locus
+open Proofview.Notations
+open Hints
 
 (**************************************************************************)
 (*                           Automatic tactics                            *)
@@ -1015,79 +33,82 @@ 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) -> Int.equal hint.pri 0) l
 
 (* tell auto not to reuse already instantiated metas in unification (for
    compatibility, since otherwise, apply succeeds oftener) *)
 
 open Unification
 
-let auto_unif_flags = {
-  modulo_conv_on_closed_terms = Some full_transparent_state;
-  use_metas_eagerly_in_conv_on_closed_terms = false;
-  modulo_delta = empty_transparent_state;
+let auto_core_unif_flags_of st1 st2 useeager = {
+  modulo_conv_on_closed_terms = Some st1;
+  use_metas_eagerly_in_conv_on_closed_terms = useeager;
+  use_evars_eagerly_in_conv_on_closed_terms = false;
+  modulo_delta = st2;
   modulo_delta_types = full_transparent_state;
-  modulo_delta_in_merge = None;
   check_applied_meta_types = false;
-  resolve_evars = true;
   use_pattern_unification = false;
   use_meta_bound_pattern_unification = true;
-  frozen_evars = ExistentialSet.empty;
+  frozen_evars = Evar.Set.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 *)
+let auto_unif_flags_of st1 st2 useeager =
+  let flags = auto_core_unif_flags_of st1 st2 useeager in {
+  core_unify_flags = flags;
+  merge_unify_flags = flags;
+  subterm_unify_flags = { flags with modulo_delta = empty_transparent_state };
+  allow_K_in_toplevel_higher_order_unification = false;
+  resolve_evars = true
+}
 
-let h_clenv_refine ev c clenv =
-  Refiner.abstract_tactic (TacApply (true,ev,[c,NoBindings],None))
-    (Clenvtac.clenv_refine ev clenv)
+let auto_unif_flags =
+  auto_unif_flags_of full_transparent_state empty_transparent_state false
 
-let unify_resolve_nodelta (c,clenv) gl =
-  let clenv' = connect_clenv gl clenv in
-  let clenv'' = clenv_unique_resolver ~flags:auto_unif_flags clenv' gl in
-  h_clenv_refine false c clenv'' gl
+let auto_flags_of_state st =
+  auto_unif_flags_of full_transparent_state st false
 
-let unify_resolve flags (c,clenv) gl =
-  let clenv' = connect_clenv gl clenv in
-  let clenv'' = clenv_unique_resolver ~flags clenv' gl in
-  h_clenv_refine false c clenv'' gl
+(* Try unification with the precompiled clause, then use registered Apply *)
 
-let unify_resolve_gen = function
-  | None -> unify_resolve_nodelta
-  | Some flags -> unify_resolve flags
+let unify_resolve_nodelta poly (c,clenv) =
+  Proofview.Goal.nf_enter begin fun gl ->
+  let clenv' = if poly then fst (Clenv.refresh_undefined_univs clenv) else clenv in
+  let clenv' = Tacmach.New.of_old connect_clenv gl clenv' in
+  let clenv'' = Tacmach.New.of_old (fun gl -> clenv_unique_resolver ~flags:auto_unif_flags clenv' gl) gl in
+  Clenvtac.clenv_refine false clenv''
+  end
+
+let unify_resolve poly flags (c,clenv) =
+  Proofview.Goal.nf_enter begin fun gl ->
+  let clenv' = if poly then fst (Clenv.refresh_undefined_univs clenv) else clenv in
+  let clenv' = Tacmach.New.of_old connect_clenv gl clenv' in
+  let clenv'' = Tacmach.New.of_old (fun gl -> clenv_unique_resolver ~flags clenv' gl) gl in
+  Clenvtac.clenv_refine false clenv''
+  end
+
+let unify_resolve_gen poly = function
+  | None -> unify_resolve_nodelta poly
+  | Some flags -> unify_resolve poly flags
+
+let exact poly (c,clenv) =
+  let ctx, c' = 
+    if poly then
+      let evd', subst = Evd.refresh_undefined_universes clenv.evd in
+      let ctx = Evd.evar_universe_context evd' in
+	ctx, subst_univs_level_constr subst c 
+    else 
+      let ctx = Evd.evar_universe_context clenv.evd in
+	ctx, c
+  in
+  Proofview.Goal.enter begin fun gl ->
+    let sigma = Evd.merge_universe_context (Proofview.Goal.sigma gl) ctx in
+    Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS sigma) (exact_check c')
+  end
 
 (* Util *)
 
-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)
-    | _ ->
-	[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 (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 ?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 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
    terme pour l'affichage ? (HH) *)
@@ -1100,19 +121,23 @@ si après Intros la conclusion matche le pattern.
 
 (* 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")
-
-let set_extern_interp f = forward_interp_tactic := f
+let (forward_interp_tactic, extern_interp) = Hook.make ()
 
-let conclPattern concl pat tac gl =
-  let constr_bindings =
+let conclPattern concl pat tac =
+  let constr_bindings env sigma =
     match pat with
-    | None -> []
+    | None -> Proofview.tclUNIT Id.Map.empty
     | Some pat ->
-	try matches pat concl
-	with PatternMatchingFailure -> error "conclPattern" in
-    !forward_interp_tactic constr_bindings tac gl
+	try
+	  Proofview.tclUNIT (Constr_matching.matches env sigma pat concl)
+	with Constr_matching.PatternMatchingFailure ->
+          Proofview.tclZERO (UserError ("conclPattern",str"conclPattern"))
+  in
+   Proofview.Goal.enter (fun gl ->
+     let env = Proofview.Goal.env gl in
+     let sigma = Proofview.Goal.sigma gl in
+       constr_bindings env sigma >>= fun constr_bindings ->
+     Hook.get forward_interp_tactic constr_bindings tac)
 
 (***********************************************************)
 (** A debugging / verbosity framework for trivial and auto *)
@@ -1147,8 +172,8 @@ let no_dbg () = (Off,0,ref [])
 
 let mk_trivial_dbg debug =
   let d =
-    if debug = Debug || !global_debug_trivial then Debug
-    else if debug = Info || !global_info_trivial then Info
+    if debug == Debug || !global_debug_trivial then Debug
+    else if debug == Info || !global_info_trivial then Info
     else Off
   in (d,0,ref [])
 
@@ -1157,8 +182,8 @@ let mk_trivial_dbg debug =
 
 let mk_auto_dbg debug =
   let d =
-    if debug = Debug || !global_debug_auto then Debug
-    else if debug = Info || !global_info_auto then Info
+    if debug == Debug || !global_debug_auto then Debug
+    else if debug == Info || !global_info_auto then Info
     else Off
   in (d,1,ref [])
 
@@ -1172,25 +197,27 @@ let tclLOG (dbg,depth,trace) pp tac =
     | Debug ->
        (* For "debug (trivial/auto)", we directly output messages *)
       let s = String.make depth '*' in
-      begin fun gl ->
+      Proofview.V82.tactic begin fun gl ->
 	try
-	  let out = tac gl in
+	  let out = Proofview.V82.of_tactic tac gl in
 	  msg_debug (str s ++ spc () ++ pp () ++ str ". (*success*)");
 	  out
 	with reraise ->
+          let reraise = Errors.push reraise in
 	  msg_debug (str s ++ spc () ++ pp () ++ str ". (*fail*)");
-	  raise reraise
+	  iraise reraise
       end
     | Info ->
       (* For "info (trivial/auto)", we store a log trace *)
-      begin fun gl ->
+      Proofview.V82.tactic begin fun gl ->
 	try
-	  let out = tac gl in
+	  let out = Proofview.V82.of_tactic tac gl in
 	  trace := (depth, Some pp) :: !trace;
 	  out
 	with reraise ->
+          let reraise = Errors.push reraise in
 	  trace := (depth, None) :: !trace;
-	  raise reraise
+	  iraise reraise
       end
 
 (** For info, from the linear trace information, we reconstitute the part
@@ -1207,37 +234,39 @@ let rec cleanup_info_trace depth acc = function
 
 and erase_subtree depth = function
   | [] -> []
-  | (d,_) :: l -> if d = depth then l else erase_subtree depth l
+  | (d,_) :: l -> if Int.equal d depth then l else erase_subtree depth l
 
 let pr_info_atom (d,pp) =
-  msg_debug (str (String.make d ' ') ++ pp () ++ str ".")
+  str (String.make d ' ') ++ pp () ++ str "."
 
 let pr_info_trace = function
   | (Info,_,{contents=(d,Some pp)::l}) ->
-      List.iter pr_info_atom (cleanup_info_trace d [(d,pp)] l)
-  | _ -> ()
+      prlist_with_sep fnl pr_info_atom (cleanup_info_trace d [(d,pp)] l)
+  | _ -> mt ()
 
 let pr_info_nop = function
-  | (Info,_,_) -> msg_debug (str "idtac.")
-  | _ -> ()
+  | (Info,_,_) -> str "idtac."
+  | _ -> mt ()
 
 let pr_dbg_header = function
-  | (Off,_,_) -> ()
-  | (Debug,0,_) -> msg_debug (str "(* debug trivial : *)")
-  | (Debug,_,_) -> msg_debug (str "(* debug auto : *)")
-  | (Info,0,_) -> msg_debug (str "(* info trivial : *)")
-  | (Info,_,_) -> msg_debug (str "(* info auto : *)")
+  | (Off,_,_) -> mt ()
+  | (Debug,0,_) -> str "(* debug trivial : *)"
+  | (Debug,_,_) -> str "(* debug auto : *)"
+  | (Info,0,_) -> str "(* info trivial : *)"
+  | (Info,_,_) -> str "(* info auto : *)"
 
 let tclTRY_dbg d tac =
-  tclORELSE0
-    (fun gl ->
-      pr_dbg_header d;
-      let out = tac gl in
-      pr_info_trace d;
-      out)
-    (fun gl ->
-      pr_info_nop d;
-      tclIDTAC gl)
+  let (level, _, _) = d in
+  let delay f = Proofview.tclUNIT () >>= fun () -> f () in
+  let tac = match level with
+  | Off -> tac
+  | Debug | Info -> delay (fun () -> msg_debug (pr_dbg_header d ++ fnl () ++ pr_info_trace d); tac)
+  in
+  let after = match level with
+  | Info -> delay (fun () -> msg_debug (pr_info_nop d); Proofview.tclUNIT ())
+  | Off | Debug -> Proofview.tclUNIT ()
+  in
+  Tacticals.New.tclORELSE0 tac after
 
 (**************************************************************************)
 (*                           The Trivial tactic                           *)
@@ -1247,16 +276,21 @@ let tclTRY_dbg d tac =
 (* 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 auto_unif_flags =
+  auto_unif_flags_of full_transparent_state empty_transparent_state false
+
 let flags_of_state st =
-  {auto_unif_flags with
-    modulo_conv_on_closed_terms = Some st; modulo_delta = st}
+  auto_unif_flags_of st st false
+
+let auto_flags_of_state st =
+  auto_unif_flags_of full_transparent_state st false
 
 let hintmap_of hdc concl =
   match hdc with
   | None -> Hint_db.map_none
   | Some hdc ->
-      if occur_existential concl then Hint_db.map_all hdc
-      else Hint_db.map_auto (hdc,concl)
+      if occur_existential concl then Hint_db.map_existential hdc concl
+      else Hint_db.map_auto hdc concl
 
 let exists_evaluable_reference env = function
   | EvalConstRef _ -> true
@@ -1265,41 +299,49 @@ let exists_evaluable_reference env = function
 let dbg_intro dbg = tclLOG dbg (fun () -> str "intro") intro
 let dbg_assumption dbg = tclLOG dbg (fun () -> str "assumption") assumption
 
-let rec trivial_fail_db dbg mod_delta db_list local_db gl =
+let rec trivial_fail_db dbg mod_delta db_list local_db =
   let intro_tac =
-    tclTHEN (dbg_intro dbg)
-      (fun g'->
-	 let hintl = make_resolve_hyp (pf_env g') (project g') (pf_last_hyp g')
-	 in trivial_fail_db dbg mod_delta db_list (Hint_db.add_list hintl local_db) g')
+    Tacticals.New.tclTHEN (dbg_intro dbg)
+      ( Proofview.Goal.enter begin fun gl ->
+          let sigma = Proofview.Goal.sigma gl in
+          let env = Proofview.Goal.env gl in
+          let nf c = Evarutil.nf_evar sigma c in
+          let decl = Tacmach.New.pf_last_hyp (Proofview.Goal.assume gl) in
+          let hyp = Context.map_named_declaration nf decl in
+	  let hintl = make_resolve_hyp env sigma hyp
+	  in trivial_fail_db dbg mod_delta db_list (Hint_db.add_list hintl local_db)
+      end)
   in
-  tclFIRST
-    ((dbg_assumption dbg)::intro_tac::
-     (List.map tclCOMPLETE
-       (trivial_resolve dbg mod_delta db_list local_db (pf_concl gl)))) gl
+  Proofview.Goal.enter begin fun gl ->
+    let concl = Tacmach.New.pf_nf_concl gl in
+    Tacticals.New.tclFIRST
+      ((dbg_assumption dbg)::intro_tac::
+          (List.map Tacticals.New.tclCOMPLETE
+             (trivial_resolve dbg mod_delta db_list local_db concl)))
+  end
 
 and my_find_search_nodelta db_list local_db hdc concl =
   List.map (fun hint -> (None,hint))
-    (list_map_append (hintmap_of hdc concl) (local_db::db_list))
+    (List.map_append (hintmap_of hdc concl) (local_db::db_list))
 
 and my_find_search mod_delta =
   if mod_delta then my_find_search_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_in_conv_on_closed_terms = true} in
   let f = hintmap_of hdc concl in
     if occur_existential concl then
-      list_map_append
+      List.map_append
 	(fun db ->
 	  if Hint_db.use_dn db then
 	    let flags = flags_of_state (Hint_db.transparent_state db) in
 	      List.map (fun x -> (Some flags,x)) (f db)
 	  else
-	    let flags = {flags with modulo_delta = Hint_db.transparent_state db} in
+	    let flags = auto_flags_of_state (Hint_db.transparent_state db) in
 	      List.map (fun x -> (Some flags,x)) (f db))
 	(local_db::db_list)
     else
-      list_map_append (fun db ->
+      List.map_append (fun db ->
 	if Hint_db.use_dn db then
 	  let flags = flags_of_state (Hint_db.transparent_state db) in
 	    List.map (fun x -> (Some flags, x)) (f db)
@@ -1309,39 +351,40 @@ and my_find_search_delta db_list local_db hdc concl =
 	    let l =
 	      match hdc with None -> Hint_db.map_none db
 	      | Some hdc ->
-		  if (Idpred.is_empty ids && Cpred.is_empty csts)
-		  then Hint_db.map_auto (hdc,concl) db
-		  else Hint_db.map_all hdc db
-	    in {flags with modulo_delta = st}, l
+		  if (Id.Pred.is_empty ids && Cpred.is_empty csts)
+		  then Hint_db.map_auto hdc concl db
+		  else Hint_db.map_existential hdc concl db
+	    in auto_flags_of_state st, l
 	  in List.map (fun x -> (Some flags,x)) l)
       	(local_db::db_list)
 
-and tac_of_hint dbg db_list local_db concl (flags, ({pat=p; code=t})) =
+and tac_of_hint dbg db_list local_db concl (flags, ({pat=p; code=t;poly=poly})) =
   let tactic = 
     match t with
-    | Res_pf (c,cl) -> unify_resolve_gen flags (c,cl)
-    | ERes_pf _ -> (fun gl -> error "eres_pf")
-    | Give_exact c  -> exact_check c
+    | Res_pf (c,cl) -> unify_resolve_gen poly flags (c,cl)
+    | ERes_pf _ -> Proofview.V82.tactic (fun gl -> error "eres_pf")
+    | Give_exact (c, cl)  -> exact poly (c, cl)
     | Res_pf_THEN_trivial_fail (c,cl) ->
-      tclTHEN
-        (unify_resolve_gen flags (c,cl))
+      Tacticals.New.tclTHEN
+        (unify_resolve_gen poly flags (c,cl))
 	(* With "(debug) trivial", we shouldn't end here, and
 	   with "debug auto" we don't display the details of inner trivial *)
-        (trivial_fail_db (no_dbg ()) (flags <> None) db_list local_db)
+        (trivial_fail_db (no_dbg ()) (not (Option.is_empty flags)) db_list local_db)
     | Unfold_nth c ->
-      (fun gl ->
+      Proofview.V82.tactic (fun gl ->
        if exists_evaluable_reference (pf_env gl) c then
-	 tclPROGRESS (h_reduce (Unfold [all_occurrences_expr,c]) onConcl) gl
+	 tclPROGRESS (reduce (Unfold [AllOccurrences,c]) Locusops.onConcl) gl
        else tclFAIL 0 (str"Unbound reference") gl)
-    | Extern tacast -> conclPattern concl p tacast
+    | Extern tacast -> 
+      conclPattern concl p tacast
   in
   tclLOG dbg (fun () -> pr_autotactic t) tactic
 
 and trivial_resolve dbg mod_delta db_list local_db cl =
   try
     let head =
-      try let hdconstr,_ = head_constr_bound cl in
-	    Some (head_of_constr_reference hdconstr)
+      try let hdconstr = decompose_app_bound cl in
+	    Some hdconstr
       with Bound -> None
     in
       List.map (tac_of_hint dbg db_list local_db cl)
@@ -1352,36 +395,33 @@ and trivial_resolve dbg mod_delta db_list local_db cl =
 (** 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 ?(debug=Off) lems dbnames gl =
+let trivial ?(debug=Off) lems dbnames =
+  Proofview.Goal.nf_enter begin fun gl ->
+  let env = Proofview.Goal.env gl in
+  let sigma = Proofview.Goal.sigma gl in
   let db_list = make_db_list dbnames in
   let d = mk_trivial_dbg debug in
+  let hints = make_local_hint_db env sigma false lems in
   tclTRY_dbg d
-    (trivial_fail_db d false db_list (make_local_hint_db false lems gl)) gl
-
-let full_trivial ?(debug=Off) lems gl =
-  let dbnames = Hintdbmap.dom !searchtable in
-  let dbnames = list_remove "v62" dbnames in
-  let db_list = List.map (fun x -> searchtable_map x) dbnames in
+    (trivial_fail_db d false db_list hints)
+  end
+
+let full_trivial ?(debug=Off) lems =
+  Proofview.Goal.nf_enter begin fun gl ->
+  let env = Proofview.Goal.env gl in
+  let sigma = Proofview.Goal.sigma gl in
+  let db_list = current_pure_db () in
   let d = mk_trivial_dbg debug in
+  let hints = make_local_hint_db env sigma false lems in
   tclTRY_dbg d
-    (trivial_fail_db d false db_list (make_local_hint_db false lems gl)) gl
+    (trivial_fail_db d false db_list hints)
+  end
 
 let gen_trivial ?(debug=Off) lems = function
   | None -> full_trivial ~debug lems
   | Some l -> trivial ~debug lems l
 
-let h_trivial ?(debug=Off) lems l =
-  Refiner.abstract_tactic (TacTrivial (debug,List.map snd lems,l))
-    (gen_trivial ~debug lems l)
+let h_trivial ?(debug=Off) lems l = gen_trivial ~debug lems l
 
 (**************************************************************************)
 (*                       The classical Auto tactic                        *)
@@ -1390,88 +430,90 @@ let h_trivial ?(debug=Off) lems l =
 let possible_resolve dbg mod_delta db_list local_db cl =
   try
     let head =
-      try let hdconstr,_ = head_constr_bound cl in
-	    Some (head_of_constr_reference hdconstr)
+      try let hdconstr = decompose_app_bound cl in
+	    Some hdconstr
       with Bound -> None
     in
       List.map (tac_of_hint dbg db_list local_db cl)
 	(my_find_search mod_delta db_list local_db head cl)
   with Not_found -> []
 
-let dbg_case dbg id =
-  tclLOG dbg (fun () -> str "case " ++ pr_id id) (simplest_case (mkVar id))
-
-let decomp_unary_term_then dbg (id,_,typc) kont1 kont2 gl =
-  try
-    let ccl = applist (head_constr typc) in
-    match Hipattern.match_with_conjunction ccl with
-    | Some (_,args) ->
-	tclTHEN (dbg_case dbg id) (kont1 (List.length args)) gl
-    | None ->
-	kont2 gl
-  with UserError _ -> kont2 gl
-
-let decomp_empty_term dbg (id,_,typc) gl =
-  if Hipattern.is_empty_type typc then
-    dbg_case dbg id gl
-  else
-    errorlabstrm "Auto.decomp_empty_term" (str "Not an empty type.")
-
-let extend_local_db gl decl db =
-  Hint_db.add_list (make_resolve_hyp (pf_env gl) (project gl) decl) db
+let extend_local_db decl db gl =
+  Hint_db.add_list (make_resolve_hyp (Tacmach.New.pf_env gl) (Proofview.Goal.sigma gl) decl) db
 
 (* Introduce an hypothesis, then call the continuation tactic [kont]
    with the hint db extended with the so-obtained hypothesis *)
 
 let intro_register dbg kont db =
-  tclTHEN (dbg_intro dbg)
-    (onLastDecl (fun decl gl -> kont (extend_local_db gl decl db) gl))
+  Tacticals.New.tclTHEN (dbg_intro dbg)
+    (Proofview.Goal.enter begin fun gl ->
+      let extend_local_db decl db = extend_local_db decl db gl in
+      Tacticals.New.onLastDecl (fun decl -> kont (extend_local_db decl db))
+    end)
 
 (* n is the max depth of search *)
 (* local_db contains the local Hypotheses *)
 
-exception Uplift of tactic list
-
 let search d n mod_delta db_list local_db =
   let rec search d n local_db =
-    if n=0 then (fun gl -> error "BOUND 2") else
-      tclORELSE0 (dbg_assumption d)
-	(tclORELSE0 (intro_register d (search d n) local_db)
-	   (fun gl ->
-	     let d' = incr_dbg d in
-	     tclFIRST
-	       (List.map
-		  (fun ntac -> tclTHEN ntac (search d' (n-1) local_db))
-		  (possible_resolve d mod_delta db_list local_db (pf_concl gl))) gl))
+    (* spiwack: the test of [n] to 0 must be done independently in
+       each goal. Hence the [tclEXTEND] *)
+    Proofview.tclEXTEND [] begin
+      if Int.equal n 0 then Proofview.tclZERO (Errors.UserError ("",str"BOUND 2")) else
+        Tacticals.New.tclORELSE0 (dbg_assumption d)
+	  (Tacticals.New.tclORELSE0 (intro_register d (search d n) local_db)
+	     ( Proofview.Goal.enter begin fun gl ->
+               let concl = Tacmach.New.pf_nf_concl gl in
+	       let d' = incr_dbg d in
+	       Tacticals.New.tclFIRST
+	         (List.map
+		    (fun ntac -> Tacticals.New.tclTHEN ntac (search d' (n-1) local_db))
+		    (possible_resolve d mod_delta db_list local_db concl))
+             end))
+    end []
   in
   search d n local_db
 
 let default_search_depth = ref 5
 
-let delta_auto ?(debug=Off) mod_delta n lems dbnames gl =
+let delta_auto debug mod_delta n lems dbnames =
+  Proofview.Goal.nf_enter begin fun gl ->
+  let env = Proofview.Goal.env gl in
+  let sigma = Proofview.Goal.sigma gl in
   let db_list = make_db_list dbnames in
   let d = mk_auto_dbg debug in
+  let hints = make_local_hint_db env sigma false lems in
   tclTRY_dbg d
-    (search d n mod_delta db_list (make_local_hint_db false lems gl)) gl
+    (search d n mod_delta db_list hints)
+  end
 
-let auto ?(debug=Off) n = delta_auto ~debug false n
+let delta_auto = 
+  if Flags.profile then
+    let key = Profile.declare_profile "delta_auto" in
+      Profile.profile5 key delta_auto
+  else delta_auto
 
-let new_auto ?(debug=Off) n = delta_auto ~debug true n
+let auto ?(debug=Off) n = delta_auto debug false n
+
+let new_auto ?(debug=Off) n = delta_auto debug true n
 
 let default_auto = auto !default_search_depth [] []
 
-let delta_full_auto ?(debug=Off) mod_delta n lems gl =
-  let dbnames = Hintdbmap.dom !searchtable in
-  let dbnames = list_remove "v62" dbnames in
-  let db_list = List.map (fun x -> searchtable_map x) dbnames in
+let delta_full_auto ?(debug=Off) mod_delta n lems =
+  Proofview.Goal.nf_enter begin fun gl ->
+  let env = Proofview.Goal.env gl in
+  let sigma = Proofview.Goal.sigma gl in
+  let db_list = current_pure_db () in
   let d = mk_auto_dbg debug in
+  let hints = make_local_hint_db env sigma false lems in
   tclTRY_dbg d
-    (search d n mod_delta db_list (make_local_hint_db false lems gl)) gl
+    (search d n mod_delta db_list hints)
+  end
 
 let full_auto ?(debug=Off) n = delta_full_auto ~debug false n
 let new_full_auto ?(debug=Off) n = delta_full_auto ~debug true n
 
-let default_full_auto gl = full_auto !default_search_depth [] gl
+let default_full_auto = full_auto !default_search_depth []
 
 let gen_auto ?(debug=Off) n lems dbnames =
   let n = match n with None -> !default_search_depth | Some n -> n in
@@ -1479,8 +521,4 @@ let gen_auto ?(debug=Off) n lems dbnames =
   | None -> full_auto ~debug n lems
   | Some l -> auto ~debug n lems l
 
-let inj_or_var = Option.map (fun n -> ArgArg n)
-
-let h_auto ?(debug=Off) n lems l =
-  Refiner.abstract_tactic (TacAuto (debug,inj_or_var n,List.map snd lems,l))
-    (gen_auto ~debug n lems l)
+let h_auto ?(debug=Off) n lems l = gen_auto ~debug n lems l
diff --git a/tactics/auto.mli b/tactics/auto.mli
index 5ac2de87..ea3f0ac0 100644
--- a/tactics/auto.mli
+++ b/tactics/auto.mli
@@ -1,268 +1,87 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-open Util
 open Names
 open Term
-open Sign
 open Proof_type
-open Tacmach
 open Clenv
 open Pattern
-open Environ
 open Evd
-open Libnames
-open Vernacexpr
-open Mod_subst
+open Decl_kinds
+open Hints
 
-(** Auto and related automation tactics *)
-
-type 'a auto_tactic =
-  | Res_pf     of constr * 'a    (** Hint Apply *)
-  | ERes_pf    of constr * 'a    (** Hint EApply *)
-  | Give_exact of constr
-  | Res_pf_THEN_trivial_fail of constr * 'a (** Hint Immediate *)
-  | Unfold_nth of evaluable_global_reference          (** Hint Unfold *)
-  | Extern     of Tacexpr.glob_tactic_expr   (** Hint Extern *)
-
-open Glob_term
-
-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 pri_auto_tactic = clausenv gen_auto_tactic
-
-type stored_data = int * clausenv gen_auto_tactic
-
-type search_entry
-
-(** The head may not be bound. *)
-
-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
-    type t
-    val empty : transparent_state -> bool -> t
-    val find : global_reference -> t -> search_entry
-    val map_none : t -> pri_auto_tactic list
-    val map_all : global_reference -> t -> pri_auto_tactic list
-    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 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
-
-type hint_db_name = string
-
-type hint_db = Hint_db.t
-
-type hints_entry =
-  | HintsResolveEntry of (int option * bool * hints_path_atom * constr) list
-  | HintsImmediateEntry of (hints_path_atom * constr) list
-  | HintsCutEntry of hints_path
-  | HintsUnfoldEntry of evaluable_global_reference list
-  | HintsTransparencyEntry of evaluable_global_reference list * bool
-  | HintsExternEntry of
-      int * (patvar list * constr_pattern) option * Tacexpr.glob_tactic_expr
-
-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].
-   [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 extern_interp :
+  (patvar_map -> Tacexpr.glob_tactic_expr -> unit Proofview.tactic) Hook.t
 
-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
-
-val print_hint_ref : global_reference -> unit
-
-val print_hint_db_by_name : hint_db_name -> unit
-
-val print_hint_db : Hint_db.t -> unit
-
-(** [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 -> ?name:hints_path_atom -> constr * constr -> hint_entry
-
-(** [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;
-   [c] is the term given as an exact proof to solve the goal;
-   [cty] is the type of [c]. *)
-
-val make_apply_entry :
-  env -> evar_map -> bool * bool * bool -> int option -> ?name:hints_path_atom -> 
-  constr * constr -> hint_entry
-
-(** 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 -> ?name:hints_path_atom -> 
-  constr -> hint_entry list
-
-(** [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. *)
-
-val make_resolve_hyp :
-  env -> evar_map -> named_declaration -> hint_entry list
-
-(** [make_extern pri pattern tactic_expr] *)
-
-val make_extern :
-  int -> constr_pattern option -> Tacexpr.glob_tactic_expr
-      -> hint_entry
-
-val set_extern_interp :
-  (patvar_map -> Tacexpr.glob_tactic_expr -> tactic) -> unit
-
-val set_extern_intern_tac :
-  (patvar list -> Tacexpr.raw_tactic_expr -> Tacexpr.glob_tactic_expr)
-  -> unit
-
-val set_extern_subst_tactic :
-  (substitution -> Tacexpr.glob_tactic_expr -> Tacexpr.glob_tactic_expr)
-  -> unit
-
-(** 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 : ?ts:transparent_state -> bool -> open_constr list -> goal sigma -> hint_db
+(** Auto and related automation tactics *)
 
 val priority : ('a * pri_auto_tactic) list -> ('a * pri_auto_tactic) list
 
 val default_search_depth : int ref
 
-val auto_unif_flags : Unification.unify_flags
+val auto_flags_of_state : transparent_state -> Unification.unify_flags
 
 (** Try unification with the precompiled clause, then use registered Apply *)
-val unify_resolve_nodelta : (constr * clausenv) -> tactic
+val unify_resolve_nodelta : polymorphic -> (constr * clausenv) -> unit Proofview.tactic
 
-val unify_resolve : Unification.unify_flags -> (constr * clausenv) -> tactic
+val unify_resolve : polymorphic -> Unification.unify_flags -> (constr * clausenv) -> unit Proofview.tactic
 
 (** [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
+val conclPattern : constr -> constr_pattern option -> Tacexpr.glob_tactic_expr -> unit Proofview.tactic
 
 (** The Auto tactic *)
 
 (** The use of the "core" database can be de-activated by passing
     "nocore" amongst the databases. *)
 
-val make_db_list : hint_db_name list -> hint_db list
-
 val auto : ?debug:Tacexpr.debug ->
-  int -> open_constr list -> hint_db_name list -> tactic
+  int -> open_constr list -> hint_db_name list -> unit Proofview.tactic
 
 (** Auto with more delta. *)
 
 val new_auto : ?debug:Tacexpr.debug ->
-  int -> open_constr list -> hint_db_name list -> tactic
+  int -> open_constr list -> hint_db_name list -> unit Proofview.tactic
 
 (** auto with default search depth and with the hint database "core" *)
-val default_auto : tactic
+val default_auto : unit Proofview.tactic
 
 (** auto with all hint databases except the "v62" compatibility database *)
 val full_auto : ?debug:Tacexpr.debug ->
-  int -> open_constr list -> tactic
+  int -> open_constr list -> unit Proofview.tactic
 
 (** auto with all hint databases except the "v62" compatibility database
    and doing delta *)
 val new_full_auto : ?debug:Tacexpr.debug ->
-  int -> open_constr list -> tactic
+  int -> open_constr list -> unit Proofview.tactic
 
 (** auto with default search depth and with all hint databases
    except the "v62" compatibility database *)
-val default_full_auto : tactic
+val default_full_auto : unit Proofview.tactic
 
 (** The generic form of auto (second arg [None] means all bases) *)
 val gen_auto : ?debug:Tacexpr.debug ->
-  int option -> open_constr list -> hint_db_name list option -> tactic
+  int option -> open_constr list -> hint_db_name list option -> unit Proofview.tactic
 
 (** The hidden version of auto *)
 val h_auto   : ?debug:Tacexpr.debug ->
-  int option -> open_constr list -> hint_db_name list option -> tactic
+  int option -> open_constr list -> hint_db_name list option -> unit Proofview.tactic
 
 (** Trivial *)
 
 val trivial : ?debug:Tacexpr.debug ->
-  open_constr list -> hint_db_name list -> tactic
+  open_constr list -> hint_db_name list -> unit Proofview.tactic
 val gen_trivial : ?debug:Tacexpr.debug ->
-  open_constr list -> hint_db_name list option -> tactic
+  open_constr list -> hint_db_name list option -> unit Proofview.tactic
 val full_trivial : ?debug:Tacexpr.debug ->
-  open_constr list -> tactic
+  open_constr list -> unit Proofview.tactic
 val h_trivial : ?debug:Tacexpr.debug ->
-  open_constr list -> hint_db_name list option -> tactic
-
-val pr_autotactic : 'a auto_tactic -> Pp.std_ppcmds
-
-(** Hook for changing the initialization of auto *)
-
-val add_auto_init : (unit -> unit) -> unit
+  open_constr list -> hint_db_name list option -> unit Proofview.tactic
diff --git a/tactics/autorewrite.ml b/tactics/autorewrite.ml
index 93441a93..ee8e1855 100644
--- a/tactics/autorewrite.ml
+++ b/tactics/autorewrite.ml
@@ -1,39 +1,37 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
 open Equality
-open Hipattern
 open Names
 open Pp
-open Proof_type
 open Tacticals
-open Tacinterp
 open Tactics
 open Term
 open Termops
+open Errors
 open Util
-open Glob_term
-open Vernacinterp
 open Tacexpr
 open Mod_subst
+open Locus
 
 (* Rewriting rules *)
 type rew_rule = { rew_lemma: constr;
 		  rew_type: types;
 		  rew_pat: constr;
+		  rew_ctx: Univ.universe_context_set;
 		  rew_l2r: bool;
-		  rew_tac: glob_tactic_expr }
+		  rew_tac: glob_tactic_expr option }
 
 let subst_hint subst hint =
   let cst' = subst_mps subst hint.rew_lemma in
   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
+  let t' = Option.smartmap (Tacsubst.subst_tactic subst) hint.rew_tac in
     if hint.rew_lemma == cst' && hint.rew_type == typ' && hint.rew_tac == t' then hint else
       { hint with
 	rew_lemma = cst'; rew_type = typ';
@@ -43,9 +41,7 @@ module HintIdent =
 struct
   type t = int * rew_rule
 
-  let compare (i,t) (i',t') =
-    Pervasives.compare i i'
-(*     Pervasives.compare t.rew_lemma t'.rew_lemma *)
+  let compare (i, t) (j, t') = i - j
 
   let subst s (i,t) = (i,subst_hint s t)
 
@@ -62,23 +58,15 @@ module HintDN = Term_dnet.Make(HintIdent)(HintOpt)
 
 (* Summary and Object declaration *)
 let rewtab =
-  ref (Stringmap.empty : HintDN.t Stringmap.t)
+  Summary.ref (String.Map.empty : HintDN.t String.Map.t) ~name:"autorewrite"
 
-let _ =
-  let init () = rewtab := Stringmap.empty in
-  let freeze () = !rewtab in
-  let unfreeze fs = rewtab := fs in
-  Summary.declare_summary "autorewrite"
-    { Summary.freeze_function   = freeze;
-      Summary.unfreeze_function = unfreeze;
-      Summary.init_function     = init }
+let raw_find_base bas = String.Map.find bas !rewtab
 
 let find_base bas =
- try Stringmap.find bas !rewtab
- with
-  Not_found ->
-   errorlabstrm "AutoRewrite"
-     (str ("Rewriting base "^(bas)^" does not exist."))
+  try raw_find_base bas
+  with Not_found ->
+    errorlabstrm "AutoRewrite"
+      (str ("Rewriting base "^(bas)^" does not exist."))
 
 let find_rewrites bas =
   List.rev_map snd (HintDN.find_all (find_base bas))
@@ -86,45 +74,55 @@ let find_rewrites bas =
 let find_matches bas pat =
   let base = find_base bas in
   let res = HintDN.search_pattern base pat in
-    List.map (fun ((_,rew), esubst, subst) -> rew) res
+  List.map snd res
 
 let print_rewrite_hintdb bas =
-  ppnl (str "Database " ++ str bas ++ (Pp.cut ()) ++
-	   prlist_with_sep Pp.cut
+  (str "Database " ++ str bas ++ fnl () ++
+	   prlist_with_sep fnl
 	   (fun h ->
 	     str (if h.rew_l2r then "rewrite -> " else "rewrite <- ") ++
 	       Printer.pr_lconstr h.rew_lemma ++ str " of type " ++ Printer.pr_lconstr h.rew_type ++
-	       str " then use tactic " ++
-	       Pptactic.pr_glob_tactic (Global.env()) h.rew_tac)
+	       Option.cata (fun tac -> str " then use tactic " ++
+	       Pptactic.pr_glob_tactic (Global.env()) tac) (mt ()) h.rew_tac)
 	   (find_rewrites bas))
 
-type raw_rew_rule = loc * constr * bool * raw_tactic_expr
+type raw_rew_rule = Loc.t * constr Univ.in_universe_context_set * bool * raw_tactic_expr option
 
 (* Applies all the rules of one base *)
 let one_base general_rewrite_maybe_in tac_main bas =
   let lrul = find_rewrites bas in
-  let lrul = List.map (fun h -> (h.rew_lemma,h.rew_l2r,Tacinterp.eval_tactic h.rew_tac)) lrul in
-    tclREPEAT_MAIN (tclPROGRESS (List.fold_left (fun tac (csr,dir,tc) ->
-      tclTHEN tac
-        (tclREPEAT_MAIN
-	    (tclTHENFIRST (general_rewrite_maybe_in dir csr tc) tac_main)))
-      tclIDTAC lrul))
+  let try_rewrite dir ctx c tc = Proofview.Goal.nf_enter (fun gl ->
+    let subst, ctx' = Universes.fresh_universe_context_set_instance ctx in
+    let c' = Vars.subst_univs_level_constr subst c in
+    let sigma = Proofview.Goal.sigma gl in
+    let sigma = Evd.merge_context_set Evd.univ_flexible sigma ctx' in
+    Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS sigma)
+      (general_rewrite_maybe_in dir c' tc)
+  ) in
+  let lrul = List.map (fun h -> 
+  let tac = match h.rew_tac with None -> Proofview.tclUNIT () | Some t -> Tacinterp.eval_tactic t in
+    (h.rew_ctx,h.rew_lemma,h.rew_l2r,tac)) lrul in
+    Tacticals.New.tclREPEAT_MAIN (Proofview.tclPROGRESS (List.fold_left (fun tac (ctx,csr,dir,tc) ->
+      Tacticals.New.tclTHEN tac
+        (Tacticals.New.tclREPEAT_MAIN
+	    (Tacticals.New.tclTHENFIRST (try_rewrite dir ctx csr tc) tac_main)))
+      (Proofview.tclUNIT()) lrul))
 
 (* The AutoRewrite tactic *)
 let autorewrite ?(conds=Naive) tac_main lbas =
-  tclREPEAT_MAIN (tclPROGRESS
+  Tacticals.New.tclREPEAT_MAIN (Proofview.tclPROGRESS
     (List.fold_left (fun tac bas ->
-       tclTHEN tac
+       Tacticals.New.tclTHEN tac
         (one_base (fun dir c tac ->
-	  let tac = tac, conds in
-	    general_rewrite dir all_occurrences true false ~tac c)
+	  let tac = (tac, conds) in
+	    general_rewrite dir AllOccurrences true false ~tac c)
 	  tac_main bas))
-      tclIDTAC lbas))
+      (Proofview.tclUNIT()) lbas))
 
-let autorewrite_multi_in ?(conds=Naive) idl tac_main lbas : tactic =
-  fun gl ->
+let autorewrite_multi_in ?(conds=Naive) idl tac_main lbas =
+ Proofview.Goal.nf_enter begin fun gl ->
  (* let's check at once if id exists (to raise the appropriate error) *)
- let _ = List.map (Tacmach.pf_get_hyp gl) idl in
+ let _ = List.map (fun id -> Tacmach.New.pf_get_hyp id gl) idl in
  let general_rewrite_in id =
   let id = ref id in
   let to_be_cleared = ref false in
@@ -133,15 +131,15 @@ let autorewrite_multi_in ?(conds=Naive) idl tac_main lbas : tactic =
      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) ^".")
+        raise (Logic.RefinerError (Logic.NoSuchHyp !id))
     in
-    let gl' = general_rewrite_in dir all_occurrences true ~tac:(tac, conds) false !id cstr false gl in
+    let gl' = Proofview.V82.of_tactic (general_rewrite_in dir AllOccurrences 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 (Goal.V82.hyps gl'.Evd.sigma g) with
             (lastid,_,_)::_ ->
-              if last_hyp_id <> lastid then
+              if not (Id.equal last_hyp_id lastid) then
                begin
                 let gl'' =
                   if !to_be_cleared then
@@ -159,11 +157,13 @@ let autorewrite_multi_in ?(conds=Naive) idl tac_main lbas : tactic =
           | _ -> assert false) (* there must be at least an hypothesis *)
      | _ -> assert false (* rewriting cannot complete a proof *)
  in
- tclMAP (fun id ->
-  tclREPEAT_MAIN (tclPROGRESS
+ let general_rewrite_in x y z w = Proofview.V82.tactic (general_rewrite_in x y z w) in
+ Tacticals.New.tclMAP (fun id ->
+  Tacticals.New.tclREPEAT_MAIN (Proofview.tclPROGRESS
     (List.fold_left (fun tac bas ->
-       tclTHEN tac (one_base (general_rewrite_in id) tac_main bas)) tclIDTAC lbas)))
-   idl gl
+       Tacticals.New.tclTHEN tac (one_base (general_rewrite_in id) tac_main bas)) (Proofview.tclUNIT()) lbas)))
+   idl
+ end
 
 let autorewrite_in ?(conds=Naive) id = autorewrite_multi_in ~conds [id]
 
@@ -171,53 +171,48 @@ let gen_auto_multi_rewrite conds tac_main lbas cl =
   let try_do_hyps treat_id l =
     autorewrite_multi_in ~conds (List.map treat_id l) tac_main lbas
   in
-  if cl.concl_occs <> all_occurrences_expr &
-     cl.concl_occs <> no_occurrences_expr
+  if cl.concl_occs != AllOccurrences &&
+     cl.concl_occs != NoOccurrences
   then
-    error "The \"at\" syntax isn't available yet for the autorewrite tactic."
+    Proofview.tclZERO (UserError("" , str"The \"at\" syntax isn't available yet for the autorewrite tactic."))
   else
     let compose_tac t1 t2 =
       match cl.onhyps with
 	| Some [] -> t1
-	| _ ->      tclTHENFIRST t1 t2
+	| _ ->      Tacticals.New.tclTHENFIRST t1 t2
     in
     compose_tac
-	(if cl.concl_occs <> no_occurrences_expr then autorewrite ~conds tac_main lbas else tclIDTAC)
+	(if cl.concl_occs != NoOccurrences then autorewrite ~conds tac_main lbas else Proofview.tclUNIT ())
 	(match cl.onhyps with
 	   | Some l -> try_do_hyps (fun ((_,id),_) -> id) l
 	   | None ->
-	       fun gl ->
 		 (* try to rewrite in all hypothesis
 		    (except maybe the rewritten one) *)
-		 let ids =  Tacmach.pf_ids_of_hyps gl
-		 in try_do_hyps (fun id -> id)  ids gl)
+               Proofview.Goal.nf_enter begin fun gl ->
+                 let ids = Tacmach.New.pf_ids_of_hyps gl in
+		 try_do_hyps (fun id -> id)  ids
+               end)
 
-let auto_multi_rewrite ?(conds=Naive) = gen_auto_multi_rewrite conds Refiner.tclIDTAC
+let auto_multi_rewrite ?(conds=Naive) = gen_auto_multi_rewrite conds (Proofview.tclUNIT())
 
-let auto_multi_rewrite_with ?(conds=Naive) tac_main lbas cl gl =
-  let onconcl = cl.Tacexpr.concl_occs <> no_occurrences_expr in
-  match onconcl,cl.Tacexpr.onhyps with
+let auto_multi_rewrite_with ?(conds=Naive) tac_main lbas cl =
+  let onconcl = match cl.Locus.concl_occs with NoOccurrences -> false | _ -> true in
+  match onconcl,cl.Locus.onhyps with
     | false,Some [_] | true,Some [] | false,Some [] ->
 	(* autorewrite with .... in clause using tac n'est sur que
 	   si clause represente soit le but soit UNE hypothese
 	*)
-	gen_auto_multi_rewrite conds tac_main lbas cl gl
+	gen_auto_multi_rewrite conds tac_main lbas cl
     | _ ->
-	    Util.errorlabstrm "autorewrite"
-	      (strbrk "autorewrite .. in .. using can only be used either with a unique hypothesis or on the conclusion.")
+        Proofview.tclZERO (UserError ("autorewrite",strbrk "autorewrite .. in .. using can only be used either with a unique hypothesis or on the conclusion."))
 
 (* Functions necessary to the library object declaration *)
 let cache_hintrewrite (_,(rbase,lrl)) =
-  let base =
-    try find_base rbase
-    with e when Errors.noncritical e -> HintDN.empty
-  in
-  let max =
-    try fst (Util.list_last (HintDN.find_all base))
-    with e when Errors.noncritical e -> 0
+  let base = try raw_find_base rbase with Not_found -> HintDN.empty in
+  let max = try fst (Util.List.last (HintDN.find_all base)) with Failure _ -> 0
   in
   let lrl = HintDN.map (fun (i,h) -> (i + max, h)) lrl in
-    rewtab:=Stringmap.add rbase (HintDN.union lrl base) !rewtab
+    rewtab:=String.Map.add rbase (HintDN.union lrl base) !rewtab
 
 
 let subst_hintrewrite (subst,(rbase,list as node)) =
@@ -250,12 +245,6 @@ type hypinfo = {
   hyp_right : constr;
 }
 
-let evd_convertible env evd x y =
-  try
-    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 e when Errors.noncritical e -> false
-
 let decompose_applied_relation metas env sigma c ctype left2right =
   let find_rel ty =
     let eqclause = Clenv.mk_clenv_from_env env sigma None (c,ty) in
@@ -296,7 +285,7 @@ let find_applied_relation metas loc env sigma c left2right =
     | Some c -> c
     | None ->
 	user_err_loc (loc, "decompose_applied_relation",
-		     str"The type" ++ spc () ++ Printer.pr_constr_env env ctype ++
+		     str"The type" ++ spc () ++ Printer.pr_constr_env env sigma ctype ++
 		       spc () ++ str"of this term does not end with an applied relation.")
 
 (* To add rewriting rules to a base *)
@@ -304,12 +293,12 @@ let add_rew_rules base lrul =
   let counter = ref 0 in
   let lrul =
     List.fold_left
-      (fun dn (loc,c,b,t) ->
+      (fun dn (loc,(c,ctx),b,t) ->
 	let info = find_applied_relation false loc (Global.env ()) Evd.empty c b in
 	let pat = if b then info.hyp_left else info.hyp_right in
 	let rul = { rew_lemma = c; rew_type = info.hyp_ty;
-		    rew_pat = pat; rew_l2r = b;
-		    rew_tac = Tacinterp.glob_tactic t}
+		    rew_pat = pat; rew_ctx = ctx; rew_l2r = b;
+		    rew_tac = Option.map Tacintern.glob_tactic t}
 	in incr counter;
 	  HintDN.add pat (!counter, rul) dn) HintDN.empty lrul
   in Lib.add_anonymous_leaf (inHintRewrite (base,lrul))
diff --git a/tactics/autorewrite.mli b/tactics/autorewrite.mli
index b0016449..9905b520 100644
--- a/tactics/autorewrite.mli
+++ b/tactics/autorewrite.mli
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,11 +8,10 @@
 
 open Term
 open Tacexpr
-open Tacmach
 open Equality
 
 (** Rewriting rules before tactic interpretation *)
-type raw_rew_rule = Util.loc * Term.constr * bool * Tacexpr.raw_tactic_expr
+type raw_rew_rule = Loc.t * Term.constr Univ.in_universe_context_set * bool * Tacexpr.raw_tactic_expr option
 
 (** To add rewriting rules to a base *)
 val add_rew_rules : string -> raw_rew_rule list -> unit
@@ -21,25 +20,26 @@ val add_rew_rules : string -> raw_rew_rule list -> unit
    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
+val autorewrite : ?conds:conditions -> unit Proofview.tactic -> string list -> unit Proofview.tactic
+val autorewrite_in : ?conds:conditions -> Names.Id.t -> unit Proofview.tactic -> string list -> unit Proofview.tactic
 
 (** Rewriting rules *)
 type rew_rule = { rew_lemma: constr;
 		  rew_type: types;
 		  rew_pat: constr;
+		  rew_ctx: Univ.universe_context_set;
 		  rew_l2r: bool;
-		  rew_tac: glob_tactic_expr }
+		  rew_tac: glob_tactic_expr option }
 
 val find_rewrites : string -> rew_rule list
 
 val find_matches : string -> constr -> rew_rule list
 
-val auto_multi_rewrite : ?conds:conditions -> string list -> Tacticals.clause -> tactic
+val auto_multi_rewrite : ?conds:conditions -> string list -> Locus.clause -> unit Proofview.tactic
 
-val auto_multi_rewrite_with : ?conds:conditions -> tactic -> string list -> Tacticals.clause -> tactic
+val auto_multi_rewrite_with : ?conds:conditions -> unit Proofview.tactic -> string list -> Locus.clause -> unit Proofview.tactic
 
-val print_rewrite_hintdb : string -> unit
+val print_rewrite_hintdb : string -> Pp.std_ppcmds
 
 open Clenv
 
@@ -56,6 +56,6 @@ type hypinfo = {
 }
 
 val find_applied_relation : bool ->
-  Util.loc ->
+  Loc.t ->
   Environ.env -> Evd.evar_map -> Term.constr -> bool -> hypinfo
 
diff --git a/tactics/btermdn.ml b/tactics/btermdn.ml
index 182cac7d..1f5177c3 100644
--- a/tactics/btermdn.ml
+++ b/tactics/btermdn.ml
@@ -1,16 +1,16 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
+open Util
 open Term
 open Names
-open Termdn
 open Pattern
-open Libnames
+open Globnames
 
 (* Discrimination nets with bounded depth.
    See the module dn.ml for further explanations.
@@ -18,133 +18,159 @@ open Libnames
 
 let dnet_depth = ref 8
 
+type term_label =
+| GRLabel of global_reference
+| ProdLabel
+| LambdaLabel
+| SortLabel
+
+let compare_term_label t1 t2 = match t1, t2 with
+| GRLabel gr1, GRLabel gr2 -> RefOrdered.compare gr1 gr2
+| _ -> Pervasives.compare t1 t2 (** OK *)
+
+type 'res lookup_res = 'res Dn.lookup_res = Label of 'res | Nothing | Everything
+
+let decomp_pat =
+  let rec decrec acc = function
+    | PApp (f,args) -> decrec (Array.to_list args @ acc) f
+    | PProj (p, c) -> (PRef (ConstRef (Projection.constant p)), c :: acc)
+    | c -> (c,acc)
+  in
+  decrec []
+
+let decomp =
+  let rec decrec acc c = match kind_of_term c with
+    | App (f,l) -> decrec (Array.fold_right (fun a l -> a::l) l acc) f
+    | Proj (p, c) -> (mkConst (Projection.constant p), c :: acc)
+    | Cast (c1,_,_) -> decrec acc c1
+    | _ -> (c,acc)
+  in
+    decrec []
+
+let constr_val_discr t =
+  let c, l = decomp t in
+    match kind_of_term c with
+    | Ind (ind_sp,u) -> Label(GRLabel (IndRef ind_sp),l)
+    | Construct (cstr_sp,u) -> Label(GRLabel (ConstructRef cstr_sp),l)
+    | Var id -> Label(GRLabel (VarRef id),l)
+    | Const _ -> Everything
+    | _ -> Nothing
+
+let constr_pat_discr t =
+  if not (Patternops.occur_meta_pattern t) then
+    None
+  else
+    match decomp_pat t with
+    | PRef ((IndRef _) as ref), args
+    | PRef ((ConstructRef _ ) as ref), args -> Some (GRLabel ref,args)
+    | PRef ((VarRef v) as ref), args -> Some(GRLabel ref,args)
+    | _ -> None
+
+let constr_val_discr_st (idpred,cpred) t =
+  let c, l = decomp t in
+    match kind_of_term c with
+    | Const (c,u) -> if Cpred.mem c cpred then Everything else Label(GRLabel (ConstRef c),l)
+    | Ind (ind_sp,u) -> Label(GRLabel (IndRef ind_sp),l)
+    | Construct (cstr_sp,u) -> Label(GRLabel (ConstructRef cstr_sp),l)
+    | Var id when not (Id.Pred.mem id idpred) -> Label(GRLabel (VarRef id),l)
+    | Prod (n, d, c) -> Label(ProdLabel, [d; c])
+    | Lambda (n, d, c) -> 
+      if List.is_empty l then 
+	Label(LambdaLabel, [d; c] @ l)
+      else Everything
+    | Sort _ -> Label(SortLabel, [])
+    | Evar _ -> Everything
+    | _ -> Nothing
+
+let constr_pat_discr_st (idpred,cpred) t =
+  match decomp_pat t with
+  | PRef ((IndRef _) as ref), args
+  | PRef ((ConstructRef _ ) as ref), args -> Some (GRLabel ref,args)
+  | PRef ((VarRef v) as ref), args when not (Id.Pred.mem v idpred) ->
+      Some(GRLabel ref,args)
+  | PVar v, args when not (Id.Pred.mem v idpred) ->
+      Some(GRLabel (VarRef v),args)
+  | PRef ((ConstRef c) as ref), args when not (Cpred.mem c cpred) ->
+      Some (GRLabel ref, args)
+  | PProd (_, d, c), [] -> Some (ProdLabel, [d ; c])
+  | PLambda (_, d, c), [] -> Some (LambdaLabel, [d ; c])
+  | PSort s, [] -> Some (SortLabel, [])
+  | _ -> None
+
+let bounded_constr_pat_discr_st st (t,depth) =
+  if Int.equal depth 0 then
+    None
+  else
+    match constr_pat_discr_st st t with
+      | None -> None
+      | Some (c,l) -> Some(c,List.map (fun c -> (c,depth-1)) l)
+
+let bounded_constr_val_discr_st st (t,depth) =
+  if Int.equal depth 0 then
+    Nothing
+  else
+    match constr_val_discr_st st t with
+      | Label (c,l) -> Label(c,List.map (fun c -> (c,depth-1)) l)
+      | Nothing -> Nothing
+      | Everything -> Everything
+
+let bounded_constr_pat_discr (t,depth) =
+  if Int.equal depth 0 then
+    None
+  else
+    match constr_pat_discr t with
+      | None -> None
+      | Some (c,l) -> Some(c,List.map (fun c -> (c,depth-1)) l)
+
+let bounded_constr_val_discr (t,depth) =
+  if Int.equal depth 0 then
+    Nothing
+  else
+    match constr_val_discr t with
+      | Label (c,l) -> Label(c,List.map (fun c -> (c,depth-1)) l)
+      | Nothing -> Nothing
+      | Everything -> Everything
 
 module Make =
   functor (Z : Map.OrderedType) ->
 struct
-  module Term_dn = Termdn.Make(Z)
-
-  module X = struct
-    type t = constr_pattern*int
-    let compare = Pervasives.compare 
-  end
-
- module Y = struct 
-     type t = Term_dn.term_label
-     let compare x y = 
-       let make_name n =
-	 match n with
-	 | Term_dn.GRLabel(ConstRef con) -> 
-	     Term_dn.GRLabel(ConstRef(constant_of_kn(canonical_con con)))
-	 | Term_dn.GRLabel(IndRef (kn,i)) ->
-	     Term_dn.GRLabel(IndRef(mind_of_kn(canonical_mind kn),i))
-	 | Term_dn.GRLabel(ConstructRef ((kn,i),j ))->
-	     Term_dn.GRLabel(ConstructRef((mind_of_kn(canonical_mind kn),i),j))
-	 | k -> k
-       in
-	 Pervasives.compare (make_name x) (make_name y)
+
+ module Y = struct
+    type t = term_label
+    let compare = compare_term_label
  end
- 
- module Dn = Dn.Make(X)(Y)(Z)
-  
+
+ module Dn = Dn.Make(Y)(Z)
+
  type t = Dn.t
 
   let create = Dn.create
 
-  let decomp = 
-    let rec decrec acc c = match kind_of_term c with
-      | App (f,l) -> decrec (Array.fold_right (fun a l -> a::l) l acc) f
-      | Cast (c1,_,_) -> decrec acc c1
-      | _ -> (c,acc)
-    in 
-      decrec []
-
-  let constr_val_discr t =
-    let c, l = decomp t in
-      match kind_of_term c with
-      | Ind ind_sp -> Dn.Label(Term_dn.GRLabel (IndRef ind_sp),l)
-      | Construct cstr_sp -> Dn.Label(Term_dn.GRLabel (ConstructRef cstr_sp),l)
-      | Var id -> Dn.Label(Term_dn.GRLabel (VarRef id),l)
-      | Const _ -> Dn.Everything
-      | _ -> Dn.Nothing
-	
-  let constr_val_discr_st (idpred,cpred) t =
-    let c, l = decomp t in
-      match kind_of_term c with
-      | Const c -> if Cpred.mem c cpred then Dn.Everything else Dn.Label(Term_dn.GRLabel (ConstRef c),l)
-      | Ind ind_sp -> Dn.Label(Term_dn.GRLabel (IndRef ind_sp),l)
-      | Construct cstr_sp -> Dn.Label(Term_dn.GRLabel (ConstructRef cstr_sp),l)
-      | Var id when not (Idpred.mem id idpred) -> Dn.Label(Term_dn.GRLabel (VarRef id),l)
-      | Prod (n, d, c) -> Dn.Label(Term_dn.ProdLabel, [d; c])
-      | Lambda (n, d, c) -> Dn.Label(Term_dn.LambdaLabel, [d; c] @ l)
-      | Sort _ -> Dn.Label(Term_dn.SortLabel, [])
-      | Evar _ -> Dn.Everything
-      | _ -> Dn.Nothing
-
-  let bounded_constr_pat_discr_st st (t,depth) =
-    if depth = 0 then 
-      None 
-    else
-      match Term_dn.constr_pat_discr_st st t with
-	| None -> None
-	| Some (c,l) -> Some(c,List.map (fun c -> (c,depth-1)) l)
-	    
-  let bounded_constr_val_discr_st st (t,depth) =
-    if depth = 0 then 
-      Dn.Nothing 
-    else
-      match constr_val_discr_st st t with
-	| Dn.Label (c,l) -> Dn.Label(c,List.map (fun c -> (c,depth-1)) l)
-	| Dn.Nothing -> Dn.Nothing
-	| Dn.Everything -> Dn.Everything
-
-  let bounded_constr_pat_discr (t,depth) =
-    if depth = 0 then 
-      None 
-    else
-      match Term_dn.constr_pat_discr t with
-	| None -> None
-	| Some (c,l) -> Some(c,List.map (fun c -> (c,depth-1)) l)
-	    
-  let bounded_constr_val_discr (t,depth) =
-    if depth = 0 then 
-      Dn.Nothing 
-    else
-      match constr_val_discr t with
-	| Dn.Label (c,l) -> Dn.Label(c,List.map (fun c -> (c,depth-1)) l)
-	| Dn.Nothing -> Dn.Nothing
-	| Dn.Everything -> Dn.Everything
-	    
-	    
   let add = function
-    | None -> 
-	(fun dn (c,v) -> 
+    | None ->
+	(fun dn (c,v) ->
 	   Dn.add dn bounded_constr_pat_discr ((c,!dnet_depth),v))
-    | Some st -> 
-	(fun dn (c,v) -> 
+    | Some st ->
+	(fun dn (c,v) ->
 	   Dn.add dn (bounded_constr_pat_discr_st st) ((c,!dnet_depth),v))
-	  
+
   let rmv = function
-    | None -> 
-	(fun dn (c,v) -> 
+    | None ->
+	(fun dn (c,v) ->
 	   Dn.rmv dn bounded_constr_pat_discr ((c,!dnet_depth),v))
-    | Some st -> 
-	(fun dn (c,v) -> 
+    | Some st ->
+	(fun dn (c,v) ->
 	 Dn.rmv dn (bounded_constr_pat_discr_st st) ((c,!dnet_depth),v))
-	  
+
   let lookup = function
-    | None -> 
+    | None ->
 	(fun dn t ->
-	   List.map 
-	     (fun ((c,_),v) -> (c,v)) 
-	     (Dn.lookup dn bounded_constr_val_discr (t,!dnet_depth)))
-    | Some st -> 
+	     Dn.lookup dn bounded_constr_val_discr (t,!dnet_depth))
+    | Some st ->
 	(fun dn t ->
-	   List.map 
-	     (fun ((c,_),v) -> (c,v)) 
-	     (Dn.lookup dn (bounded_constr_val_discr_st st) (t,!dnet_depth)))
-	  
-  let app f dn = Dn.app (fun ((c,_),v) -> f(c,v)) dn
-    
+	     Dn.lookup dn (bounded_constr_val_discr_st st) (t,!dnet_depth))
+
+  let app f dn = Dn.app f dn
+
 end
-    
+
diff --git a/tactics/btermdn.mli b/tactics/btermdn.mli
index f9c2271a..6c396b4c 100644
--- a/tactics/btermdn.mli
+++ b/tactics/btermdn.mli
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -11,6 +11,18 @@ open Pattern
 open Names
 
 (** Discrimination nets with bounded depth. *)
+
+(** This module registers actions (typically tactics) mapped to patterns *)
+
+(** 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
+number of nodes of the patterns matching the term. The [transparent_state]
+indicates which constants and variables can be considered as rigid.
+These dnets are able to cope with existential variables as well, which match
+[Everything]. *)
+
 module Make :
   functor (Z : Map.OrderedType) ->
 sig
@@ -21,9 +33,8 @@ sig
   val add : transparent_state option -> t -> (constr_pattern * Z.t) -> t
   val rmv : transparent_state option -> t -> (constr_pattern * Z.t) -> t
 
-  val lookup : transparent_state option -> t -> constr -> (constr_pattern * Z.t) list
-  val app : ((constr_pattern * Z.t) -> unit) -> t -> unit
+  val lookup : transparent_state option -> t -> constr -> Z.t list
+  val app : (Z.t -> unit) -> t -> unit
 end
-    
-val dnet_depth : int ref
 
+val dnet_depth : int ref
diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml
new file mode 100644
index 00000000..1c15fa40
--- /dev/null
+++ b/tactics/class_tactics.ml
@@ -0,0 +1,847 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+open Pp
+open Errors
+open Util
+open Names
+open Term
+open Termops
+open Reduction
+open Proof_type
+open Tacticals
+open Tacmach
+open Tactics
+open Patternops
+open Clenv
+open Typeclasses
+open Globnames
+open Evd
+open Locus
+open Misctypes
+open Proofview.Notations
+open Hints
+
+(** Hint database named "typeclass_instances", now created directly in Auto *)
+
+let typeclasses_debug = ref false
+let typeclasses_depth = ref None
+
+let typeclasses_modulo_eta = ref false
+let set_typeclasses_modulo_eta d = (:=) typeclasses_modulo_eta d
+let get_typeclasses_modulo_eta () = !typeclasses_modulo_eta
+
+let typeclasses_dependency_order = ref false
+let set_typeclasses_dependency_order d = (:=) typeclasses_dependency_order d
+let get_typeclasses_dependency_order () = !typeclasses_dependency_order
+
+open Goptions
+
+let set_typeclasses_modulo_eta =
+  declare_bool_option
+    { optsync  = true;
+      optdepr  = false;
+      optname  = "do typeclass search modulo eta conversion";
+      optkey   = ["Typeclasses";"Modulo";"Eta"];
+      optread  = get_typeclasses_modulo_eta;
+      optwrite = set_typeclasses_modulo_eta; }
+
+let set_typeclasses_dependency_order =
+  declare_bool_option
+    { optsync  = true;
+      optdepr  = false;
+      optname  = "during typeclass resolution, solve instances according to their dependency order";
+      optkey   = ["Typeclasses";"Dependency";"Order"];
+      optread  = get_typeclasses_dependency_order;
+      optwrite = set_typeclasses_dependency_order; }
+
+(** We transform the evars that are concerned by this resolution
+    (according to predicate p) into goals.
+    Invariant: function p only manipulates and returns undefined evars *)
+
+let top_sort evm undefs =
+  let l' = ref [] in
+  let tosee = ref undefs in
+  let rec visit ev evi = 
+    let evs = Evarutil.undefined_evars_of_evar_info evm evi in
+      Evar.Set.iter (fun ev -> 
+	if Evar.Map.mem ev !tosee then 
+	  visit ev (Evar.Map.find ev !tosee)) evs;
+      tosee := Evar.Map.remove ev !tosee;
+      l' := ev :: !l';
+  in
+    while not (Evar.Map.is_empty !tosee) do
+      let ev, evi = Evar.Map.min_binding !tosee in
+	visit ev evi
+    done;
+    List.rev !l'
+
+let evars_to_goals p evm =
+  let goals = ref Evar.Map.empty in
+  let map ev evi =
+    let evi, goal = p evm ev evi in
+    let () = if goal then goals := Evar.Map.add ev evi !goals in
+    evi
+  in
+  let evm = Evd.raw_map_undefined map evm in
+  if Evar.Map.is_empty !goals then None
+  else Some (!goals, evm)
+
+(** Typeclasses instance search tactic / eauto *)
+
+open Auto
+
+open Unification
+
+let auto_core_unif_flags st freeze = {
+  modulo_conv_on_closed_terms = Some st;
+  use_metas_eagerly_in_conv_on_closed_terms = true;
+  use_evars_eagerly_in_conv_on_closed_terms = false;
+  modulo_delta = st;
+  modulo_delta_types = st;
+  check_applied_meta_types = false;
+  use_pattern_unification = true;
+  use_meta_bound_pattern_unification = true;
+  frozen_evars = freeze;
+  restrict_conv_on_strict_subterms = false; (* ? *)
+  modulo_betaiota = true;
+  modulo_eta = !typeclasses_modulo_eta;
+}
+
+let auto_unif_flags freeze st = 
+  let fl = auto_core_unif_flags st freeze in
+  { core_unify_flags = fl;
+    merge_unify_flags = fl;
+    subterm_unify_flags = fl;
+    allow_K_in_toplevel_higher_order_unification = false;
+    resolve_evars = false
+}
+
+let rec eq_constr_mod_evars x y =
+  match kind_of_term x, kind_of_term y with
+  | Evar (e1, l1), Evar (e2, l2) when not (Evar.equal e1 e2) -> true
+  | _, _ -> compare_constr eq_constr_mod_evars x y
+
+let progress_evars t =
+  Proofview.Goal.nf_enter begin fun gl ->
+    let concl = Proofview.Goal.concl gl in
+    let check =
+      Proofview.Goal.nf_enter begin fun gl' ->
+        let newconcl = Proofview.Goal.concl gl' in
+        if eq_constr_mod_evars concl newconcl
+        then Tacticals.New.tclFAIL 0 (str"No progress made (modulo evars)")
+        else Proofview.tclUNIT ()
+      end
+    in t <*> check
+  end
+
+
+let e_give_exact flags poly (c,clenv) gl =
+  let c, gl =
+    if poly then
+      let clenv', subst = Clenv.refresh_undefined_univs clenv in
+      let clenv' = connect_clenv gl clenv' in
+      let c = Vars.subst_univs_level_constr subst c in
+	c, {gl with sigma = clenv'.evd}
+    else c, gl
+  in
+  let t1 = pf_type_of gl c in
+    tclTHEN (Proofview.V82.of_tactic (Clenvtac.unify ~flags t1)) (exact_no_check c) gl
+
+let unify_e_resolve poly flags (c,clenv) gls =
+  let clenv' = if poly then fst (Clenv.refresh_undefined_univs clenv) else clenv in
+  let clenv' = connect_clenv gls clenv' in
+  let clenv' = clenv_unique_resolver ~flags clenv' gls in
+  Proofview.V82.of_tactic (Clenvtac.clenv_refine true ~with_classes:false clenv') gls
+
+let unify_resolve poly flags (c,clenv) gls =
+  let clenv' = if poly then fst (Clenv.refresh_undefined_univs clenv) else clenv in
+  let clenv' = connect_clenv gls clenv' in
+  let clenv' = clenv_unique_resolver ~flags clenv' gls in
+  Proofview.V82.of_tactic 
+    (Clenvtac.clenv_refine false ~with_classes:false clenv') gls
+
+let clenv_of_prods poly nprods (c, clenv) gls =
+  if poly || Int.equal nprods 0 then Some clenv
+  else
+    let ty = pf_type_of gls c in
+    let diff = nb_prod ty - nprods in
+      if Pervasives.(>=) diff 0 then
+        (* Was Some clenv... *)
+	Some (mk_clenv_from_n gls (Some diff) (c,ty))
+      else None
+
+let with_prods nprods poly (c, clenv) f gls =
+  match clenv_of_prods poly nprods (c, clenv) gls with
+  | None -> tclFAIL 0 (str"Not enough premisses") gls
+  | Some clenv' -> f (c, clenv') gls
+
+(** Hack to properly solve dependent evars that are typeclasses *)
+
+let rec e_trivial_fail_db db_list local_db goal =
+  let tacl =
+    Eauto.registered_e_assumption ::
+    (tclTHEN (Proofview.V82.of_tactic Tactics.intro)
+       (function g'->
+	  let d = pf_last_hyp g' in
+	  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 (project goal) (pf_concl goal)))
+  in
+  tclFIRST (List.map tclCOMPLETE tacl) goal
+
+and e_my_find_search db_list local_db hdc complete sigma concl =
+  let prods, concl = decompose_prod_assum concl in
+  let nprods = List.length prods in
+  let freeze = 
+    try
+      let cl = Typeclasses.class_info (fst hdc) in
+	if cl.cl_strict then
+	  Evd.evars_of_term concl
+	else Evar.Set.empty
+    with _ -> Evar.Set.empty
+  in
+  let hintl =
+    List.map_append
+      (fun db ->
+	let tacs = 
+	  if Hint_db.use_dn db then (* Using dnet *)
+	    Hint_db.map_eauto hdc concl db
+	  else Hint_db.map_existential hdc concl db
+	in
+	let flags = auto_unif_flags freeze (Hint_db.transparent_state db) in
+	  List.map (fun x -> (flags, x)) tacs)
+      (local_db::db_list)
+  in
+  let tac_of_hint =
+    fun (flags, {pri = b; pat = p; poly = poly; code = t; name = name}) ->
+      let tac =
+	match t with
+	  | Res_pf (term,cl) -> with_prods nprods poly (term,cl) (unify_resolve poly flags)
+	  | ERes_pf (term,cl) -> with_prods nprods poly (term,cl) (unify_e_resolve poly flags)
+	  | Give_exact c -> e_give_exact flags poly c
+	  | Res_pf_THEN_trivial_fail (term,cl) ->
+              tclTHEN (with_prods nprods poly (term,cl) (unify_e_resolve poly flags))
+	        (if complete then tclIDTAC else e_trivial_fail_db db_list local_db)
+	  | Unfold_nth c -> tclWEAK_PROGRESS (unfold_in_concl [AllOccurrences,c])
+	  | Extern tacast ->
+	    Proofview.V82.of_tactic (conclPattern concl p tacast)
+      in
+      let tac = if complete then tclCOMPLETE tac else tac in
+	match t with
+	| 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 sigma concl =
+  try
+    e_my_find_search db_list local_db
+     (decompose_app_bound concl) true sigma concl
+  with Bound | Not_found -> []
+
+let e_possible_resolve db_list local_db sigma concl =
+  try
+    e_my_find_search db_list local_db
+      (decompose_app_bound concl) false sigma concl
+  with Bound | Not_found -> []
+
+let catchable = function
+  | Refiner.FailError _ -> true
+  | e -> Logic.catchable_exception e
+
+let pr_ev evs ev = Printer.pr_constr_env (Goal.V82.env evs ev) evs (Evarutil.nf_evar evs (Goal.V82.concl evs ev))
+
+let pr_depth l = prlist_with_sep (fun () -> str ".") int (List.rev l)
+
+type autoinfo = { hints : hint_db; is_evar: existential_key option;
+		  only_classes: bool; unique : 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
+
+type atac = auto_result tac
+
+(* Some utility types to avoid the need of -rectypes *)
+
+type 'a optionk =
+  | Nonek
+  | Somek of 'a * 'a optionk fk
+
+type ('a,'b) optionk2 =
+  | Nonek2
+  | Somek2 of 'a * 'b * ('a,'b) optionk2 fk
+
+let make_resolve_hyp env sigma st flags only_classes pri (id, _, cty) =
+  let cty = Evarutil.nf_evar sigma cty in
+  let rec iscl env ty =
+    let ctx, ar = decompose_prod_assum ty in
+      match kind_of_term (fst (decompose_app ar)) with
+      | Const (c,_) -> is_class (ConstRef c)
+      | Ind (i,_) -> is_class (IndRef i)
+      | _ ->
+	  let env' = Environ.push_rel_context ctx env in
+	  let ty' = whd_betadeltaiota env' ar in
+	       if not (Term.eq_constr ty' ar) then iscl env' ty'
+	       else false
+  in
+  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 (path,pri, c) -> make_resolves env sigma ~name:(PathHints path)
+		  (true,false,Flags.is_verbose()) pri false
+		 (IsConstr (c,Univ.ContextSet.empty)))
+	       hints)
+	else []
+      in
+        (hints @ List.map_filter
+	 (fun f -> try Some (f (c, cty, Univ.ContextSet.empty)) 
+	   with Failure _ | UserError _ -> None)
+	 [make_exact_entry ~name env sigma pri false; 
+	  make_apply_entry ~name env sigma flags pri false])
+    else []
+
+let pf_filtered_hyps gls =
+  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 ->
+      let consider =
+	try let (_, b, t) = Global.lookup_named (pi1 hyp) in
+	      (* Section variable, reindex only if the type changed *)
+	      not (Term.eq_constr t (pi3 hyp))
+	with Not_found -> true
+     in
+      if consider then 
+	let path, hint =
+	  PathEmpty, pf_apply make_resolve_hyp g st (true,false,false) only_classes None hyp
+	in
+	  (PathOr (paths, path), hint @ hints)
+      else (paths, hints))
+    (PathEmpty, []) sign
+  in Hint_db.add_list hintlist (Hint_db.empty st true)
+
+let make_autogoal_hints =
+  let cache = ref (true, Environ.empty_named_context_val, 
+		   Hint_db.empty full_transparent_state true) 
+  in
+    fun only_classes ?(st=full_transparent_state) g ->
+      let sign = pf_filtered_hyps g in
+      let (onlyc, sign', cached_hints) = !cache in
+	if onlyc == only_classes && 
+	  (sign == sign' || Environ.eq_named_context_val sign sign') then
+	  cached_hints
+	else
+	  let hints = make_hints g st only_classes (Environ.named_context_of_val sign) in
+	    cache := (only_classes, sign, hints); hints
+
+let lift_tactic tac (f : goal list sigma -> autoinfo -> autogoal list sigma) : 'a tac =
+  { skft = fun sk fk {it = gl,hints; sigma=s;} ->
+    let res = try Some (tac {it=gl; sigma=s;})
+              with e when catchable e -> None in
+      match res with
+      | Some gls -> sk (f gls hints) fk
+      | None -> fk () }
+
+let intro_tac : atac =
+  lift_tactic (Proofview.V82.of_tactic Tactics.intro)
+    (fun {it = gls; sigma = s} info ->
+      let gls' =
+	List.map (fun g' ->
+	  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 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 =
+  { 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 }
+
+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 is_Prop env sigma concl =
+  let ty = Retyping.get_type_of env sigma concl in
+  match kind_of_term ty with
+  | Sort (Prop Null) -> true
+  | _ -> false
+
+let is_unique env concl = 
+  try 
+    let (cl,u), args = dest_class_app env concl in
+      cl.cl_unique
+  with _ -> false
+
+let needs_backtrack env evd oev concl =
+  if Option.is_empty oev || is_Prop env evd concl then
+    occur_existential concl
+  else true
+
+let hints_tac hints =
+  { skft = fun sk fk {it = gl,info; sigma = s;} ->
+      let env = Goal.V82.env s gl in
+      let concl = Goal.V82.concl s gl in
+      let tacgl = {it = gl; sigma = s;} in
+      let poss = e_possible_resolve hints info.hints s concl in
+      let unique = is_unique env concl in
+      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
+	  (match res with
+	  | None -> aux i foundone tl
+	  | Some {it = gls; sigma = s';} ->
+	    if !typeclasses_debug then
+	      msg_debug (pr_depth (i :: info.auto_depth) ++ str": " ++ Lazy.force pp
+			 ++ str" on" ++ spc () ++ pr_ev s gl);
+	    let sgls =
+	      evars_to_goals
+		(fun evm ev evi ->
+		  if Typeclasses.is_resolvable evi && not (Evd.is_undefined s ev) &&
+		    (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') ->
+		  if not !typeclasses_dependency_order then
+		    (gls' @ List.map (fun (ev,_) -> (Some ev, ev)) (Evar.Map.bindings evgls), s')
+		  else 
+ 		    (* Reorder with dependent subgoals. *)
+		    let evm = List.fold_left 
+		      (fun acc g -> Evar.Map.add g (Evd.find_undefined s' g) acc) evgls gls in
+		    let gls = top_sort s' evm in
+		      (List.map (fun ev -> Some ev, ev) gls, 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
+	    let fk' =
+	      (fun () ->
+		let do_backtrack =
+		  if unique then occur_existential concl
+		  else if info.unique then true
+		  else if List.is_empty gls' then 
+		    needs_backtrack env s' info.is_evar concl
+		  else true
+		in
+		  if !typeclasses_debug then
+		    msg_debug 
+		      ((if do_backtrack then str"Backtracking after "
+			else str "Not backtracking after ")
+		       ++ Lazy.force pp);
+		  if do_backtrack then aux (succ i) true tl
+		  else fk ())
+	    in
+	      sk glsv fk')
+      | [] ->
+	if not foundone && !typeclasses_debug then
+	  msg_debug (pr_depth info.auto_depth ++ str": no match for " ++
+		       Printer.pr_constr_env (Goal.V82.env s gl) s concl ++
+		       spc () ++ str ", " ++ int (List.length poss) ++ str" possibilities");
+	fk ()
+      in aux 1 false poss }
+
+let then_list (second : atac) (sk : (auto_result, 'a) sk) : (auto_result, 'a) sk =
+  let rec aux s (acc : autogoal list list) fk = function
+    | (gl,info) :: gls ->
+	(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 fk'' =
+		   if not info.unique && List.is_empty gls' &&
+		     not (needs_backtrack (Goal.V82.env s gl) s
+			    info.is_evar (Goal.V82.concl s gl))
+		   then fk
+		   else fk'
+		 in
+		   aux s' (gls'::acc) fk'' gls)
+	       fk {it = (gl,info); sigma = s; })
+    | [] -> Somek2 (List.rev acc, s, fk)
+  in fun {it = gls; sigma = s; } fk ->
+    let rec aux' = function
+      | Nonek2 -> fk ()
+      | Somek2 (res, s', fk') ->
+	  let goals' = List.concat res in
+	    sk {it = goals'; sigma = s'; } (fun () -> aux' (fk' ()))
+    in aux' (aux s [] (fun () -> Nonek2) gls)
+
+let then_tac (first : atac) (second : atac) : atac =
+  { skft = fun sk fk -> first.skft (then_list second sk) fk }
+
+let run_tac (t : 'a tac) (gl : autogoal sigma) : auto_result option =
+  t.skft (fun x _ -> Some x) (fun _ -> None) gl
+
+type run_list_res = auto_result optionk
+
+let run_list_tac (t : 'a tac) p goals (gl : autogoal list sigma) : run_list_res =
+  (then_list t (fun x fk -> Somek (x, fk)))
+    gl
+    (fun _ -> Nonek)
+
+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 rec fix_limit limit (t : 'a tac) : 'a tac =
+  if Int.equal 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) ?(unique=false) ?(st=full_transparent_state) cut ev g =
+  let hints = make_autogoal_hints only_classes ~st g in
+    (g.it, { hints = hints ; is_evar = ev; unique = unique;
+	     only_classes = only_classes; auto_depth = []; auto_last_tac = lazy (str"none");
+	     auto_path = []; auto_cut = cut })
+
+
+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) ?(unique=false) 
+    ?(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 ~unique 
+      ~st cut (Some g) {it = g; sigma = evm'; } in
+      (gl, { auto with auto_depth = [i]})) 1 gs; sigma = evm'; }
+
+let get_result r =
+  match r with
+  | Nonek -> None
+  | Somek (gls, fk) -> Some (gls.sigma,fk)
+
+let run_on_evars ?(only_classes=true) ?(unique=false) ?(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 goals = 
+      if !typeclasses_dependency_order then
+	top_sort evm' goals
+      else List.map (fun (ev, _) -> ev) (Evar.Map.bindings goals)
+    in
+    let res = run_list_tac tac p goals 
+      (make_autogoals ~only_classes ~unique ~st hints goals evm') in
+      match get_result res with
+      | None -> raise Not_found
+      | Some (evm', fk) -> 
+	Some (evars_reset_evd ~with_conv_pbs:true ~with_univs:false evm' evm, fk)
+
+let eauto_tac hints =
+  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; } ->
+	{it = List.map fst goals; sigma = s;}
+
+let real_eauto ?limit unique st hints p evd =
+  let res =
+    run_on_evars ~st ~unique p evd hints (eauto_tac ?limit hints)
+  in
+    match res with
+    | None -> evd
+    | Some (evd', fk) -> 
+      if unique then
+	(match get_result (fk ()) with
+	| Some (evd'', fk') -> error "Typeclass resolution gives multiple solutions"
+	| None -> evd')
+      else evd'
+    
+let resolve_all_evars_once debug limit unique p evd =
+  let db = searchtable_map typeclasses_db in
+    real_eauto ?limit unique (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(Evar.Set)(Evar.Map)
+
+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 (Evar.Set.union evx evy) p)
+    cstrs
+
+let evar_dependencies evm p =
+  Evd.fold_undefined
+    (fun ev evi _ ->
+      let evars = Evar.Set.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 unique =
+  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' = eauto ?limit:!typeclasses_depth ~st:(Hint_db.transparent_state hints) [hints] gls in
+  let evd = sig_sig gls' 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_instantiation_problem := 
+    (fun x y z w -> resolve_one_typeclass x ~sigma:y z w)
+
+(** [split_evars] returns groups of undefined evars according to dependencies *)
+
+let split_evars evm =
+  let p = Intpart.create () in
+  evar_dependencies evm p;
+  deps_of_constraints (snd (extract_all_conv_pbs evm)) evm p;
+  Intpart.partition p
+
+let is_inference_forced p evd ev =
+  try
+    let evi = Evd.find_undefined evd ev in
+    if Typeclasses.is_resolvable evi && snd (p ev evi)
+    then
+      let (loc, k) = evar_source ev evd in
+      match k with
+	| Evar_kinds.ImplicitArg (_, _, b) -> b
+	| Evar_kinds.QuestionMark _ -> false
+	| _ -> true
+    else true
+  with Not_found -> assert false
+
+let is_mandatory p comp evd =
+  Evar.Set.exists (is_inference_forced p evd) comp
+
+(** In case of unsatisfiable constraints, build a nice error message *)
+
+let error_unresolvable env comp evd =
+  let evd = Evarutil.nf_evar_map_undefined evd in
+  let is_part ev = match comp with
+  | None -> true
+  | Some s -> Evar.Set.mem ev s
+  in
+  let fold ev evi (found, accu) =
+    let ev_class = class_of_constr evi.evar_concl in
+    if not (Option.is_empty ev_class) && is_part ev then
+      (* focus on one instance if only one was searched for *)
+      if not found then (true, Some ev)
+      else (found, None)
+    else (found, accu)
+   in
+  let (_, ev) = Evd.fold_undefined fold evd (true, None) in
+    Pretype_errors.unsatisfiable_constraints
+      (Evarutil.nf_env_evar evd env) evd ev comp
+
+(** 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 =
+  let check ev evi = snd (p oevd ev evi) in
+  Evar.Map.exists check (Evd.undefined_map evd)
+
+(** Revert the resolvability status of evars after resolution,
+    potentially unprotecting some evars that were set unresolvable
+    just for this call to resolution. *)
+
+let revert_resolvability oevd evd =
+  let map ev evi =
+    try
+      if not (Typeclasses.is_resolvable evi) then
+        let evi' = Evd.find_undefined oevd ev in
+        if Typeclasses.is_resolvable evi' then
+          Typeclasses.mark_resolvable evi
+        else evi
+      else evi
+    with Not_found -> evi
+  in
+  Evd.raw_map_undefined map evd
+
+(** 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 unique env p oevd do_split fail =
+  let split = if do_split then split_evars oevd else [Evar.Set.empty] in
+  let in_comp comp ev = if do_split then Evar.Set.mem ev comp else true
+  in
+  let rec docomp evd = function
+    | [] -> revert_resolvability oevd evd
+    | comp :: comps ->
+      let p = select_and_update_evars p oevd (in_comp comp) in
+      try
+	 let evd' = resolve_all_evars_once debug m unique 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. *)
+          let comp = if do_split then Some comp else None in
+	  error_unresolvable env comp evd
+	else (* Best effort: do nothing on this component *)
+	  docomp evd comps
+  in docomp oevd split
+
+let initial_select_evars filter =
+  fun evd ev evi ->
+    filter ev (snd evi.Evd.evar_source) &&
+    Typeclasses.is_class_evar evd evi
+
+let resolve_typeclass_evars debug m unique env evd filter split fail =
+  let evd =
+    try Evarconv.consider_remaining_unif_problems
+      ~ts:(Typeclasses.classes_transparent_state ()) env evd
+    with e when Errors.noncritical e -> evd
+  in
+    resolve_all_evars debug m unique env (initial_select_evars filter) evd split fail
+
+let solve_inst debug depth env evd filter unique split fail =
+  resolve_typeclass_evars debug depth unique env evd filter split fail
+
+let _ =
+  Typeclasses.solve_instantiations_problem :=
+    solve_inst false !typeclasses_depth
+
+let set_typeclasses_debug d = (:=) typeclasses_debug d;
+  Typeclasses.solve_instantiations_problem := solve_inst d !typeclasses_depth
+
+let get_typeclasses_debug () = !typeclasses_debug
+
+let set_typeclasses_depth d = (:=) typeclasses_depth d;
+  Typeclasses.solve_instantiations_problem := solve_inst !typeclasses_debug !typeclasses_depth
+
+let get_typeclasses_depth () = !typeclasses_depth
+
+open Goptions
+
+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 =
+  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 typeclasses_eauto ?(only_classes=false) ?(st=full_transparent_state) dbs gl =
+  try
+    let dbs = List.map_filter
+      (fun db -> try Some (searchtable_map db)
+        with e when Errors.noncritical e -> None)
+      dbs
+    in
+    let st = match dbs with x :: _ -> Hint_db.transparent_state x | _ -> st in
+      eauto ?limit:!typeclasses_depth ~only_classes ~st dbs gl
+   with Not_found -> tclFAIL 0 (str" typeclasses eauto failed on: " ++ Printer.pr_goal gl) gl
+
+(** Take the head of the arity of a constr.
+    Used in the partial application tactic. *)
+
+let rec head_of_constr t =
+  let t = strip_outer_cast(collapse_appl t) in
+    match kind_of_term t with
+    | Prod (_,_,c2)  -> head_of_constr c2
+    | LetIn (_,_,_,c2) -> head_of_constr c2
+    | App (f,args)  -> head_of_constr f
+    | _      -> t
+
+let head_of_constr h c =
+  let c = head_of_constr c in
+  letin_tac None (Name h) c None Locusops.allHyps
+
+let not_evar c = match kind_of_term c with
+| Evar _ -> Tacticals.New.tclFAIL 0 (str"Evar")
+| _ -> Proofview.tclUNIT ()
+
+let is_ground c gl =
+  if Evarutil.is_ground_term (project gl) c then tclIDTAC gl
+  else tclFAIL 0 (str"Not ground") gl
+
+let autoapply c i gl =
+  let flags = auto_unif_flags Evar.Set.empty 
+    (Hints.Hint_db.transparent_state (Hints.searchtable_map i)) in
+  let cty = pf_type_of gl c in
+  let ce = mk_clenv_from gl (c,cty) in
+  unify_e_resolve false flags (c,ce) gl
diff --git a/tactics/class_tactics.ml4 b/tactics/class_tactics.ml4
deleted file mode 100644
index 4a5f0e2c..00000000
--- a/tactics/class_tactics.ml4
+++ /dev/null
@@ -1,833 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(*i camlp4deps: "parsing/grammar.cma" i*)
-
-open Pp
-open Util
-open Names
-open Nameops
-open Term
-open Termops
-open Sign
-open Reduction
-open Proof_type
-open Declarations
-open Tacticals
-open Tacmach
-open Evar_refiner
-open Tactics
-open Pattern
-open Clenv
-open Auto
-open Glob_term
-open Hiddentac
-open Typeclasses
-open Typeclasses_errors
-open Classes
-open Topconstr
-open Pfedit
-open Command
-open Libnames
-open Evd
-open Compat
-
-let typeclasses_db = "typeclass_instances"
-let typeclasses_debug = ref false
-let typeclasses_depth = ref None
-
-let _ = 
-  Auto.add_auto_init 
-    (fun () -> Auto.create_hint_db false typeclasses_db full_transparent_state true)
-
-exception Found of evar_map
-
-(** 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_undefined
-      (fun ev evi (gls, evm') ->
-	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 Some (List.rev goals, evm')
-
-(** Typeclasses instance search tactic / eauto *)
-
-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
-
-open Unification
-
-let auto_unif_flags = {
-  modulo_conv_on_closed_terms = Some full_transparent_state;
-  use_metas_eagerly_in_conv_on_closed_terms = true;
-  modulo_delta = var_full_transparent_state;
-  modulo_delta_types = full_transparent_state;
-  modulo_delta_in_merge = None;
-  check_applied_meta_types = false;
-  resolve_evars = false;
-  use_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 =
-  match kind_of_term x, kind_of_term y with
-  | Evar (e1, l1), Evar (e2, l2) when e1 <> e2 -> true
-  | _, _ -> compare_constr eq_constr_mod_evars x y
-
-let progress_evars t gl =
-  let concl = pf_concl gl in
-  let check gl' = 
-    let newconcl = pf_concl gl' in
-      if eq_constr_mod_evars concl newconcl 
-      then tclFAIL 0 (str"No progress made (modulo evars)") gl'
-      else tclIDTAC gl'
-  in tclTHEN t check gl
-
-TACTIC EXTEND progress_evars
-  [ "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 ~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 ~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
-  else 
-    let ty = pf_type_of gls c in
-    let diff = nb_prod ty - nprods in
-      if diff >= 0 then
-	Some (mk_clenv_from_n gls (Some diff) (c,ty))
-      else None
-
-let with_prods nprods (c, clenv) f gls =
-  match clenv_of_prods nprods (c, clenv) gls with
-  | None -> tclFAIL 0 (str"Not enough premisses") gls
-  | Some clenv' -> f (c, clenv') gls
-
-(** Hack to properly solve dependent evars that are typeclasses *)
-
-let flags_of_state st =
-  {auto_unif_flags with
-    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 =
-    Eauto.registered_e_assumption ::
-    (tclTHEN Tactics.intro
-       (function g'->
-	  let d = pf_last_hyp g' in
-	  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)))
-  in 
-  tclFIRST (List.map tclCOMPLETE tacl) goal 
-
-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
-  let hintl =
-    list_map_append
-      (fun db ->
-	if Hint_db.use_dn db then
-	  let flags = flags_of_state (Hint_db.transparent_state db) in
-	    List.map (fun x -> (flags, x)) (Hint_db.map_auto (hdc,concl) db)
-	else
-	  let flags = flags_of_state (Hint_db.transparent_state db) in
-	    List.map (fun x -> (flags, x)) (Hint_db.map_all hdc db))
-      (local_db::db_list)
-  in
-  let tac_of_hint =
-    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)
-	  | ERes_pf (term,cl) -> with_prods nprods (term,cl) (unify_e_resolve flags)
-	  | Give_exact (c) -> e_give_exact flags c
-	  | Res_pf_THEN_trivial_fail (term,cl) ->
-              tclTHEN (with_prods nprods (term,cl) (unify_e_resolve flags))
-	        (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 -> 
-(* 	    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, 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)) true gl
-  with Bound | Not_found -> []
-
-let e_possible_resolve db_list local_db gl =
-  try
-    e_my_find_search db_list local_db
-      (fst (head_constr_bound gl)) false gl
-  with Bound | Not_found -> []
-
-let rec catchable = function
-  | Refiner.FailError _ -> true
-  | Loc.Exc_located (_, e) -> catchable e
-  | e -> Logic.catchable_exception e
-
-let nb_empty_evars s =
-  Evd.fold_undefined (fun ev evi acc -> succ acc) s 0
-
-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;
-		  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
-
-type atac = auto_result tac
-
-let make_resolve_hyp env sigma st flags only_classes pri (id, _, cty) =
-  let cty = Evarutil.nf_evar sigma cty in
-  let rec iscl env ty = 
-    let ctx, ar = decompose_prod_assum ty in
-      match kind_of_term (fst (decompose_app ar)) with
-      | Const c -> is_class (ConstRef c)
-      | Ind i -> is_class (IndRef i)
-      | _ -> 
-	  let env' = Environ.push_rel_context ctx env in
-	  let ty' = whd_betadeltaiota env' ar in
-	       if not (eq_constr ty' ar) then iscl env' ty'
-	       else false
-  in
-  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 = 
-  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 : (bool * 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 _ =
-  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 (onlyc, sign', hints) 
-	  when onlyc = only_classes && 
-	    Environ.eq_named_context_val sign sign' -> hints
-      | _ -> let hints = make_hints g st only_classes (Environ.named_context_of_val sign) in
-	  unfreeze (Some (only_classes, sign, hints)); hints
-	  
-let 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 -> sk (f gls hints) fk
-      | None -> fk () }
-
-let intro_tac : atac =
-  lift_tactic Tactics.intro
-    (fun {it = gls; sigma = s} info ->
-      let gls' =
-	List.map (fun g' ->
-	  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 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 = 
-  { 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 nbgoals s =
-    List.length (sig_it s) + nb_empty_evars (sig_sig s)
-  in
-  let pri = pri - pri' in
-    if pri <> 0 then pri
-    else nbgoals res - nbgoals 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 hints_tac hints =
-  { skft = fun sk fk {it = gl,info; sigma = s} ->
-      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 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
-	    (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 list) fk = function
-    | (gl,info) :: gls ->
-	(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} fk ->
-    let rec aux' = function
-      | None -> fk ()
-      | Some (res, s', 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 =
-  { skft = fun sk fk -> first.skft (then_list second sk) fk }
-
-let run_tac (t : 'a tac) (gl : autogoal sigma) : auto_result option =
-  t.skft (fun x _ -> Some x) (fun _ -> None) gl
-
-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 _ -> 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 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 (str"none");
-	     auto_path = []; auto_cut = cut })
-      
-
-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 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, 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 hints goals evm') in
-	match get_result res with
-	| None -> raise Not_found
-	| Some (evm', fk) -> Some (evars_reset_evd ~with_conv_pbs:true evm' evm, fk)
-	    
-let eauto_tac hints = 
-  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} ->
-	{it = List.map fst goals; sigma = s}
-
-let real_eauto st ?limit hints p evd =
-  let rec aux evd fails =
-    let res, 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
-	  | Some r -> res, fk :: fails
-	  | None -> get_result (fk ()), fails)
-	  fails (None, [])
-    in
-      match res with
-      | None -> evd
-      | Some (evd', fk) -> aux evd' (fk :: fails)
-  in aux evd []
-
-let resolve_all_evars_once debug limit p evd =
-  let db = searchtable_map typeclasses_db in
-    real_eauto ?limit (Hint_db.transparent_state db) [db] p evd
-
-(** We compute dependencies via a union-find algorithm.
-    Beware of the imperative effects on the partition structure,
-    it should not be shared, but only used locally. *)
-
-module Intpart = Unionfind.Make(Intset)(Intmap)
-
-let deps_of_constraints cstrs evm p =
-  List.iter (fun (_, _, x, y) ->
-    let evx = Evarutil.undefined_evars_of_term evm x in
-    let evy = Evarutil.undefined_evars_of_term evm y in
-    Intpart.union_set (Intset.union evx evy) p)
-    cstrs
-
-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 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' = eauto ?limit:!typeclasses_depth ~st:(Hint_db.transparent_state hints) [hints] gls in
-  let evd = sig_sig gls' in
-  let t' = let (ev, inst) = destEvar t in
-    mkEvar (ev, Array.of_list subst)
-  in
-  let term = Evarutil.nf_evar evd t' in
-    evd, term
-
-let _ =
-  Typeclasses.solve_instanciation_problem := (fun x y z -> resolve_one_typeclass x ~sigma:y z)
-
-(** [split_evars] returns groups of undefined evars according to dependencies *)
-
-let split_evars evm =
-  let p = Intpart.create () in
-  evar_dependencies evm p;
-  deps_of_constraints (snd (extract_all_conv_pbs evm)) evm p;
-  Intpart.partition p
-
-(** [evars_in_comp] filters an [evar_map], keeping only evars
-    that belongs to a certain component *)
-
-let evars_in_comp comp evm =
-  try
-    evars_reset_evd 
-      (Intset.fold (fun ev acc -> Evd.add acc ev (Evd.find_undefined evm ev))
-	 comp Evd.empty) evm
-  with Not_found -> assert false
-
-let is_inference_forced p evd ev =
-  try
-    let evi = Evd.find_undefined evd ev in
-    if Typeclasses.is_resolvable evi && snd (p ev evi)
-    then
-      let (loc, k) = evar_source ev evd in
-      match k with
-	| ImplicitArg (_, _, b) -> b
-	| QuestionMark _ -> false
-	| _ -> true
-    else true
-  with Not_found -> assert false
-
-let is_mandatory p comp evd =
-  Intset.exists (is_inference_forced p evd) comp
-
-(** In case of unsatisfiable constraints, build a nice error message *)
-
-let error_unresolvable env comp do_split evd =
-  let evd = Evarutil.nf_evar_map_undefined evd in
-  let evm = if do_split then evars_in_comp comp evd else evd in
-  let _, ev = Evd.fold_undefined
-    (fun ev evi (b,acc) ->
-      (* focus on one instance if only one was searched for *)
-      if class_of_constr evi.evar_concl <> None then
-	if not b (* || do_split *) then
-	  true, Some ev
-	else b, None
-      else b, acc) evm (false, None)
-  in
-  Typeclasses_errors.unsatisfiable_constraints
-    (Evarutil.nf_env_evar evm env) evm ev
-
-(** Check if an evar is concerned by the current resolution attempt,
-    (and in particular is in the current component), and also update
-    its evar_info.
-    Invariant : this should only be applied to undefined evars,
-    and return undefined evar_info *)
-
-let select_and_update_evars p oevd in_comp evd ev evi =
-  assert (evi.evar_body = Evar_empty);
-  try
-    let oevi = Evd.find_undefined oevd ev in
-    if Typeclasses.is_resolvable oevi then
-      Typeclasses.mark_unresolvable evi,
-      (in_comp ev && p evd ev evi)
-    else evi, false
-  with Not_found ->
-    Typeclasses.mark_unresolvable evi, p evd ev evi
-
-(** Do we still have unresolved evars that should be resolved ? *)
-
-let has_undefined p oevd evd =
-  Evd.fold_undefined (fun ev evi has -> has ||
-    snd (p oevd ev evi))
-    evd false
-
-(** Revert the resolvability status of evars after resolution,
-    potentially unprotecting some evars that were set unresolvable
-    just for this call to resolution. *)
-
-let revert_resolvability oevd evd = 
-  Evd.fold_undefined
-    (fun ev evi evm ->
-     try 
-       if not (Typeclasses.is_resolvable evi) then
-	 let evi' = Evd.find_undefined oevd ev in
-	   if Typeclasses.is_resolvable evi' then
-	     Evd.add evm ev (Typeclasses.mark_resolvable evi)
-	   else evm
-       else evm
-     with Not_found -> evm)
-  evd evd
-
-(** 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 in_comp comp ev = if do_split then Intset.mem ev comp else true
-  in
-  let rec docomp evd = function
-    | [] -> revert_resolvability oevd evd
-    | comp :: 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 initial_select_evars filter evd ev evi =
-  filter (snd evi.Evd.evar_source) &&
-  Typeclasses.is_class_evar evd evi
-
-let resolve_typeclass_evars debug m env evd filter split fail =
-  let evd = 
-    try Evarconv.consider_remaining_unif_problems
-      ~ts:(Typeclasses.classes_transparent_state ()) env evd
-    with e when Errors.noncritical e -> evd
-  in
-    resolve_all_evars debug m env (initial_select_evars filter) evd split fail
-
-let solve_inst debug depth env evd filter split fail =
-  resolve_typeclass_evars debug depth env evd filter split fail
-
-let _ =
-  Typeclasses.solve_instanciations_problem :=
-    solve_inst false !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 false b) cl
-
-VERNAC COMMAND EXTEND Typeclasses_Unfold_Settings
-| [ "Typeclasses" "Transparent" reference_list(cl) ] -> [
-    set_transparency cl true ]
-END
-
-VERNAC COMMAND EXTEND Typeclasses_Rigid_Settings
-| [ "Typeclasses" "Opaque" reference_list(cl) ] -> [
-    set_transparency cl false ]
-END
-
-open Genarg
-open Extraargs
-
-let pr_debug _prc _prlc _prt b =
-  if b then Pp.str "debug" else Pp.mt()
-
-ARGUMENT EXTEND debug TYPED AS bool PRINTED BY pr_debug
-| [ "debug" ] -> [ true ]
-| [ ] -> [ false ]
-END
-
-let pr_depth _prc _prlc _prt = function
-    Some i -> Util.pr_int i
-  | None -> Pp.mt()
-
-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) depth(depth) ] -> [
-     set_typeclasses_debug d;
-     set_typeclasses_depth depth
-   ]
-END
-
-let typeclasses_eauto ?(only_classes=false) ?(st=full_transparent_state) dbs gl =
-  try 
-    let dbs = list_map_filter
-      (fun db -> try Some (Auto.searchtable_map db)
-        with e when Errors.noncritical e -> None) dbs
-    in
-    let st = match dbs with x :: _ -> Hint_db.transparent_state x | _ -> st in
-      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 ]
-| [ "typeclasses" "eauto" ] -> [ typeclasses_eauto ~only_classes:true [typeclasses_db] ]
-END
-
-let _ = Classes.refine_ref := Refine.refine
-
-(** Take the head of the arity of a constr.
-    Used in the partial application tactic. *)
-
-let rec head_of_constr t =
-  let t = strip_outer_cast(collapse_appl t) in
-    match kind_of_term t with
-    | Prod (_,_,c2)  -> head_of_constr c2
-    | LetIn (_,_,_,c2) -> head_of_constr c2
-    | App (f,args)  -> head_of_constr f
-    | _      -> t
-
-TACTIC EXTEND head_of_constr
-  [ "head_of_constr" ident(h) constr(c) ] -> [
-    let c = head_of_constr c in
-      letin_tac None (Name h) c None allHyps
-  ]
-END
-
-TACTIC EXTEND not_evar
-  [ "not_evar" constr(ty) ] -> [
-    match kind_of_term ty with
-    | Evar _ -> tclFAIL 0 (str"Evar")
-    | _ -> tclIDTAC ]
-END
-
-TACTIC EXTEND is_ground
-  [ "is_ground" constr(ty) ] -> [ fun gl ->
-    if Evarutil.is_ground_term (project gl) ty then tclIDTAC gl
-    else tclFAIL 0 (str"Not ground") gl ]
-END
-
-TACTIC EXTEND autoapply
-  [ "autoapply" constr(c) "using" preident(i) ] -> [ fun gl ->
-    let flags = flags_of_state (Auto.Hint_db.transparent_state (Auto.searchtable_map i)) in
-    let cty = pf_type_of gl c in
-    let ce = mk_clenv_from gl (c,cty) in
-      unify_e_resolve flags (c,ce) gl ]
-END
diff --git a/tactics/class_tactics.mli b/tactics/class_tactics.mli
new file mode 100644
index 00000000..c6207ed6
--- /dev/null
+++ b/tactics/class_tactics.mli
@@ -0,0 +1,32 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+open Names
+open Constr
+open Tacmach
+
+val catchable : exn -> bool
+
+val set_typeclasses_debug : bool -> unit
+val get_typeclasses_debug : unit -> bool
+
+val set_typeclasses_depth : int option -> unit
+val get_typeclasses_depth : unit -> int option
+
+val progress_evars : unit Proofview.tactic -> unit Proofview.tactic
+
+val typeclasses_eauto : ?only_classes:bool -> ?st:transparent_state ->
+  Hints.hint_db_name list -> tactic
+
+val head_of_constr : Id.t -> Term.constr -> unit Proofview.tactic
+
+val not_evar : constr -> unit Proofview.tactic
+
+val is_ground : constr -> tactic
+
+val autoapply : constr -> Hints.hint_db_name -> tactic
diff --git a/tactics/contradiction.ml b/tactics/contradiction.ml
index 2a09f321..9ee14b80 100644
--- a/tactics/contradiction.ml
+++ b/tactics/contradiction.ml
@@ -1,90 +1,119 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-open Util
+open Errors
 open Term
-open Proof_type
 open Hipattern
 open Tacmach
 open Tacticals
 open Tactics
 open Coqlib
 open Reductionops
-open Glob_term
+open Misctypes
 
 (* Absurd *)
 
-let absurd c gls =
-  let env = pf_env gls and sigma = project gls in
-  let _,j = Coercion.Default.inh_coerce_to_sort dummy_loc env
-    (Evd.create_goal_evar_defs sigma) (Retyping.get_judgment_of env sigma c) in
-  let c = j.Environ.utj_val in
-  (tclTHENS
-     (tclTHEN (elim_type (build_coq_False ())) (cut c))
-     ([(tclTHENS
-          (cut (applist(build_coq_not (),[c])))
-	  ([(tclTHEN intros
-	       ((fun gl ->
-		   let ida = pf_nth_hyp_id gl 1
-                   and idna = pf_nth_hyp_id gl 2 in
-                   exact_no_check (applist(mkVar idna,[mkVar ida])) gl)));
-            tclIDTAC]));
-       tclIDTAC])) gls
+let mk_absurd_proof t =
+  let id = Namegen.default_dependent_ident in
+  mkLambda (Names.Name id,mkApp(build_coq_not (),[|t|]),
+    mkLambda (Names.Name id,t,mkApp (mkRel 2,[|mkRel 1|])))
+
+let absurd c =
+  Proofview.Goal.enter begin fun gl ->
+    let env = Proofview.Goal.env gl in
+    let sigma = Proofview.Goal.sigma gl in
+    let j = Retyping.get_judgment_of env sigma c in
+    let sigma, j = Coercion.inh_coerce_to_sort Loc.ghost env sigma j in
+    let t = j.Environ.utj_val in
+    Tacticals.New.tclTHENLIST [
+      Proofview.Unsafe.tclEVARS sigma;
+      elim_type (build_coq_False ());
+      Simple.apply (mk_absurd_proof t)
+    ]
+  end
+
+let absurd c = absurd c
 
 (* Contradiction *)
 
-let filter_hyp f tac gl =
+(** [f] does not assume its argument to be [nf_evar]-ed. *)
+let filter_hyp f tac =
   let rec seek = function
-    | [] -> raise Not_found
-    | (id,_,t)::rest when f t -> tac id gl
+    | [] -> Proofview.tclZERO Not_found
+    | (id,_,t)::rest when f t -> tac id
     | _::rest -> seek rest in
-  seek (pf_hyps gl)
+  Proofview.Goal.enter begin fun gl ->
+    let hyps = Proofview.Goal.hyps (Proofview.Goal.assume gl) in
+    seek hyps
+  end
 
-let contradiction_context gl =
-  let env = pf_env gl in
-  let sigma = project gl in
-  let rec seek_neg l gl = match l with
-    | [] ->  error "No such contradiction"
-    | (id,_,typ)::rest ->
-	let typ = whd_betadeltaiota env sigma typ in
-	if is_empty_type typ then
-	  simplest_elim (mkVar id) gl
-	else match kind_of_term typ with
+let contradiction_context =
+  Proofview.Goal.enter begin fun gl ->
+    let sigma = Proofview.Goal.sigma gl in
+    let env = Proofview.Goal.env gl in
+    let rec seek_neg l = match l with
+      | [] ->  Proofview.tclZERO (UserError ("" , Pp.str"No such contradiction"))
+      | (id,_,typ)::rest ->
+          let typ = nf_evar sigma typ in
+	  let typ = whd_betadeltaiota env sigma typ in
+	  if is_empty_type typ then
+	    simplest_elim (mkVar id)
+	  else match kind_of_term typ with
 	  | Prod (na,t,u) when is_empty_type u ->
-	      (try
-		filter_hyp (fun typ -> pf_conv_x_leq gl typ t)
-		  (fun id' -> simplest_elim (mkApp (mkVar id,[|mkVar id'|])))
-		  gl
-	      with Not_found -> seek_neg rest gl)
-	  | _ -> seek_neg rest gl in
-  seek_neg (pf_hyps gl) gl
+	      (Proofview.tclORELSE
+                 (Proofview.Goal.enter begin fun gl ->
+                   let is_conv_leq = Tacmach.New.pf_apply is_conv_leq gl in
+	           filter_hyp (fun typ -> is_conv_leq typ t)
+		     (fun id' -> simplest_elim (mkApp (mkVar id,[|mkVar id'|])))
+                 end)
+                 begin function (e, info) -> match e with
+	           | Not_found -> seek_neg rest
+                   | e -> Proofview.tclZERO ~info e
+                 end)
+	  | _ -> seek_neg rest
+    in
+    let hyps = Proofview.Goal.hyps (Proofview.Goal.assume gl) in
+    seek_neg hyps
+  end
 
 let is_negation_of env sigma typ t =
   match kind_of_term (whd_betadeltaiota env sigma t) with
-    | Prod (na,t,u) -> is_empty_type u & is_conv_leq env sigma typ t
+    | Prod (na,t,u) ->
+      let u = nf_evar sigma u in
+      is_empty_type u && is_conv_leq env sigma typ t
     | _ -> false
 
-let contradiction_term (c,lbind as cl) gl =
-  let env = pf_env gl in
-  let sigma = project gl in
-  let typ = pf_type_of gl c in
-  let _, ccl = splay_prod env sigma typ in
-  if is_empty_type ccl then
-    tclTHEN (elim false cl None) (tclTRY assumption) gl
-  else
-    try
-      if lbind = NoBindings then
-	filter_hyp (is_negation_of env sigma typ)
-	  (fun id -> simplest_elim (mkApp (mkVar id,[|c|]))) gl
-      else
-	raise Not_found
-    with Not_found -> error "Not a contradiction."
+let contradiction_term (c,lbind as cl) =
+  Proofview.Goal.nf_enter begin fun gl ->
+    let sigma = Proofview.Goal.sigma gl in
+    let env = Proofview.Goal.env gl in
+    let type_of = Tacmach.New.pf_type_of gl in
+    let typ = type_of c in
+    let _, ccl = splay_prod env sigma typ in
+    if is_empty_type ccl then
+      Tacticals.New.tclTHEN
+        (elim false None cl None)
+        (Tacticals.New.tclTRY assumption)
+    else
+      Proofview.tclORELSE
+        begin
+          if lbind = NoBindings then
+            filter_hyp (is_negation_of env sigma typ)
+              (fun id -> simplest_elim (mkApp (mkVar id,[|c|])))
+          else
+            Proofview.tclZERO Not_found
+        end
+        begin function (e, info) -> match e with
+          | Not_found -> Proofview.tclZERO (Errors.UserError ("",Pp.str"Not a contradiction."))
+          | e -> Proofview.tclZERO ~info e
+        end
+  end
 
 let contradiction = function
-  | None -> tclTHEN intros contradiction_context
+  | None -> Tacticals.New.tclTHEN intros contradiction_context
   | Some c -> contradiction_term c
diff --git a/tactics/contradiction.mli b/tactics/contradiction.mli
index 79da83e0..25d07e25 100644
--- a/tactics/contradiction.mli
+++ b/tactics/contradiction.mli
@@ -1,16 +1,13 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-open Names
 open Term
-open Proof_type
-open Glob_term
-open Genarg
+open Misctypes
 
-val absurd                      : constr -> tactic
-val contradiction               : constr with_bindings option -> tactic
+val absurd                      : constr -> unit Proofview.tactic
+val contradiction               : constr with_bindings option -> unit Proofview.tactic
diff --git a/tactics/coretactics.ml4 b/tactics/coretactics.ml4
new file mode 100644
index 00000000..5c039e72
--- /dev/null
+++ b/tactics/coretactics.ml4
@@ -0,0 +1,229 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i camlp4deps: "grammar/grammar.cma" i*)
+
+open Util
+open Names
+open Locus
+open Misctypes
+open Genredexpr
+
+open Proofview.Notations
+
+DECLARE PLUGIN "coretactics"
+
+TACTIC EXTEND reflexivity
+  [ "reflexivity" ] -> [ Tactics.intros_reflexivity ]
+END
+
+TACTIC EXTEND assumption
+  [ "assumption" ] -> [ Tactics.assumption ]
+END
+
+TACTIC EXTEND etransitivity
+  [ "etransitivity" ] -> [ Tactics.intros_transitivity None ]
+END
+
+TACTIC EXTEND cut
+  [ "cut" constr(c) ] -> [ Tactics.cut c ]
+END
+
+TACTIC EXTEND exact_no_check
+  [ "exact_no_check" constr(c) ] -> [ Proofview.V82.tactic (Tactics.exact_no_check c) ]
+END
+
+TACTIC EXTEND vm_cast_no_check
+  [ "vm_cast_no_check" constr(c) ] -> [ Proofview.V82.tactic (Tactics.vm_cast_no_check c) ]
+END
+
+TACTIC EXTEND casetype
+  [ "casetype" constr(c) ] -> [ Tactics.case_type c ]
+END
+
+TACTIC EXTEND elimtype
+  [ "elimtype" constr(c) ] -> [ Tactics.elim_type c ]
+END
+
+TACTIC EXTEND lapply
+  [ "lapply" constr(c) ] -> [ Tactics.cut_and_apply c ]
+END
+
+TACTIC EXTEND transitivity
+  [ "transitivity" constr(c) ] -> [ Tactics.intros_transitivity (Some c) ]
+END
+
+(** Left *)
+
+TACTIC EXTEND left
+  [ "left" ] -> [ Tactics.left_with_bindings false NoBindings ]
+END
+
+TACTIC EXTEND eleft
+  [ "eleft" ] -> [ Tactics.left_with_bindings true NoBindings ]
+END
+
+TACTIC EXTEND left_with
+  [ "left" "with" bindings(bl) ] -> [
+    let { Evd.sigma = sigma ; it = bl } = bl in
+    Proofview.Unsafe.tclEVARS sigma <*> Tactics.left_with_bindings false bl
+  ]
+END
+
+TACTIC EXTEND eleft_with
+  [ "eleft" "with" bindings(bl) ] -> [
+    let { Evd.sigma = sigma ; it = bl } = bl in
+    Tacticals.New.tclWITHHOLES true (Tactics.left_with_bindings true) sigma bl
+  ]
+END
+
+(** Right *)
+
+TACTIC EXTEND right
+  [ "right" ] -> [ Tactics.right_with_bindings false NoBindings ]
+END
+
+TACTIC EXTEND eright
+  [ "eright" ] -> [ Tactics.right_with_bindings true NoBindings ]
+END
+
+TACTIC EXTEND right_with
+  [ "right" "with" bindings(bl) ] -> [
+    let { Evd.sigma = sigma ; it = bl } = bl in
+    Proofview.Unsafe.tclEVARS sigma <*> Tactics.right_with_bindings false bl
+  ]
+END
+
+TACTIC EXTEND eright_with
+  [ "eright" "with" bindings(bl) ] -> [
+    let { Evd.sigma = sigma ; it = bl } = bl in
+    Tacticals.New.tclWITHHOLES true (Tactics.right_with_bindings true) sigma bl
+  ]
+END
+
+(** Constructor *)
+
+TACTIC EXTEND constructor
+  [ "constructor" ] -> [ Tactics.any_constructor false None ]
+| [ "constructor" int_or_var(i) ] -> [
+    let i = Tacinterp.interp_int_or_var ist i in
+    Tactics.constructor_tac false None i NoBindings
+  ]
+| [ "constructor" int_or_var(i) "with" bindings(bl) ] -> [
+    let { Evd.sigma = sigma; it = bl } = bl in
+    let i = Tacinterp.interp_int_or_var ist i in
+    let tac c = Tactics.constructor_tac false None i c in
+    Proofview.Unsafe.tclEVARS sigma <*> tac bl
+  ]
+END
+
+TACTIC EXTEND econstructor
+  [ "econstructor" ] -> [ Tactics.any_constructor true None ]
+| [ "econstructor" int_or_var(i) ] -> [
+    let i = Tacinterp.interp_int_or_var ist i in
+    Tactics.constructor_tac true None i NoBindings
+  ]
+| [ "econstructor" int_or_var(i) "with" bindings(bl) ] -> [
+    let { Evd.sigma = sigma; it = bl } = bl in
+    let i = Tacinterp.interp_int_or_var ist i in
+    let tac c = Tactics.constructor_tac true None i c in
+    Tacticals.New.tclWITHHOLES true tac sigma bl
+  ]
+END
+
+(** Specialize *)
+
+TACTIC EXTEND specialize
+  [ "specialize" constr_with_bindings(c) ] -> [
+    let { Evd.sigma = sigma; it = c } = c in
+    let specialize c = Proofview.V82.tactic (Tactics.specialize c) in
+    Proofview.Unsafe.tclEVARS sigma <*> specialize c
+  ]
+END
+
+TACTIC EXTEND symmetry
+  [ "symmetry" ] -> [ Tactics.intros_symmetry {onhyps=Some[];concl_occs=AllOccurrences} ]
+END
+
+(** Split *)
+
+TACTIC EXTEND split
+  [ "split" ] -> [ Tactics.split_with_bindings false [NoBindings] ]
+END
+
+TACTIC EXTEND esplit
+  [ "esplit" ] -> [ Tactics.split_with_bindings true [NoBindings] ]
+END
+
+TACTIC EXTEND split_with
+  [ "split" "with" bindings(bl) ] -> [
+    let { Evd.sigma = sigma ; it = bl } = bl in
+    Proofview.Unsafe.tclEVARS sigma <*> Tactics.split_with_bindings false [bl]
+  ]
+END
+
+TACTIC EXTEND esplit_with
+  [ "esplit" "with" bindings(bl) ] -> [
+    let { Evd.sigma = sigma ; it = bl } = bl in
+    Tacticals.New.tclWITHHOLES true (Tactics.split_with_bindings true) sigma [bl]
+  ]
+END
+
+(** Intro *)
+
+TACTIC EXTEND intros_until
+  [ "intros" "until" quantified_hypothesis(h) ] -> [ Tactics.intros_until h ]
+END
+
+(** Revert *)
+
+TACTIC EXTEND revert
+  [ "revert" ne_hyp_list(hl) ] -> [ Tactics.revert hl ]
+END
+
+(** Simple induction / destruct *)
+
+TACTIC EXTEND simple_induction
+  [ "simple" "induction" quantified_hypothesis(h) ] -> [ Tactics.simple_induct h ]
+END
+
+TACTIC EXTEND simple_destruct
+  [ "simple" "destruct" quantified_hypothesis(h) ] -> [ Tactics.simple_destruct h ]
+END
+
+(* Table of "pervasives" macros tactics (e.g. auto, simpl, etc.) *)
+
+open Tacexpr
+
+let initial_atomic () =
+  let dloc = Loc.ghost in
+  let nocl = {onhyps=Some[];concl_occs=AllOccurrences} in
+  let iter (s, t) =
+    let body = TacAtom (dloc, t) in
+    Tacenv.register_ltac false false (Id.of_string s) body
+  in
+  let () = List.iter iter
+      [ "red", TacReduce(Red false,nocl);
+        "hnf", TacReduce(Hnf,nocl);
+        "simpl", TacReduce(Simpl (Redops.all_flags,None),nocl);
+        "compute", TacReduce(Cbv Redops.all_flags,nocl);
+        "intro", TacIntroMove(None,MoveLast);
+        "intros", TacIntroPattern [];
+        "cofix", TacCofix None;
+        "trivial", TacTrivial (Off,[],None);
+        "auto", TacAuto(Off,None,[],None);
+      ]
+  in
+  let iter (s, t) = Tacenv.register_ltac false false (Id.of_string s) t in
+  List.iter iter
+      [ "idtac",TacId [];
+        "fail", TacFail(TacLocal,ArgArg 0,[]);
+        "fresh", TacArg(dloc,TacFreshId [])
+      ]
+
+let () = Mltop.declare_cache_obj initial_atomic "coretactics"
diff --git a/tactics/dn.ml b/tactics/dn.ml
index a0889ab8..3b1614d6 100644
--- a/tactics/dn.ml
+++ b/tactics/dn.ml
@@ -1,103 +1,101 @@
+open Util
 
+type 'res lookup_res = Label of 'res | Nothing | Everything
 
-
-
-
-module Make = 
-  functor (X : Set.OrderedType) ->
+module Make =
     functor (Y : Map.OrderedType) ->
       functor (Z : Map.OrderedType) ->
 struct
-  
+
   module Y_tries = struct
     type t = (Y.t * int) option
-    let compare x y = 
+    let compare x y =
       match x,y with
 	  None,None -> 0
-	| Some (l,n),Some (l',n') -> 
+	| Some (l,n),Some (l',n') ->
 	    let m = Y.compare l l' in
-	    if m = 0 then
-	      n-n' 
+	    if Int.equal m 0 then
+	      n-n'
 	    else m
 	| Some(l,n),None -> 1
 	| None, Some(l,n) -> -1
   end
-  module X_tries = struct
-    type t = X.t * Z.t
-    let compare (x1,x2) (y1,y2) = 
-      let m = (X.compare x1 y1) in
-      if m = 0 then (Z.compare x2 y2) else 
-	m
+  module ZSet = Set.Make(Z)
+  module X_tries =
+  struct
+    type t = ZSet.t
+    let nil = ZSet.empty
+    let is_nil = ZSet.is_empty
+    let add = ZSet.union
+    let sub = ZSet.diff
   end
 
-  module T = Tries.Make(X_tries)(Y_tries)
-    
-  type  decompose_fun = X.t -> (Y.t * X.t list) option
-    
-  type 'res lookup_res = Label of 'res | Nothing | Everything
-    
+  module Trie = Trie.Make(Y_tries)(X_tries)
+
+  type 'a decompose_fun = 'a -> (Y.t * 'a list) option
+
   type 'tree lookup_fun = 'tree -> (Y.t * 'tree list) lookup_res
 
-  type  t = T.t
+  type  t = Trie.t
 
-  let create () = T.empty
+  let create () = Trie.empty
 
-(* [path_of dna pat] returns the list of nodes of the pattern [pat] read in 
+(* [path_of dna pat] returns the list of nodes of the pattern [pat] read in
 prefix ordering, [dna] is the function returning the main node of a pattern *)
 
   let path_of dna =
     let rec path_of_deferred = function
       | [] -> []
       | h::tl -> pathrec tl h
-	  
+
     and pathrec deferred t =
       match dna t with
-	| None -> 
+	| None ->
 	    None :: (path_of_deferred deferred)
 	| Some (lbl,[]) ->
 	    (Some (lbl,0))::(path_of_deferred deferred)
 	| Some (lbl,(h::def_subl as v)) ->
 	    (Some (lbl,List.length v))::(pathrec (def_subl@deferred) h)
-    in 
+    in
       pathrec []
-	
+
   let tm_of tm lbl =
-    try [T.map tm lbl, true] with Not_found -> []
-      
+    try [Trie.next tm lbl, true] with Not_found -> []
+
   let rec skip_arg n tm =
-    if n = 0 then [tm,true]
+    if Int.equal n 0 then [tm, true]
     else
-      List.flatten 
-	(List.map 
-	   (fun a -> match a with
-	      | None -> skip_arg (pred n) (T.map tm a)
-	      | Some (lbl,m) -> 
-		  skip_arg (pred n + m) (T.map tm a)) 
-	   (T.dom tm))
-	
+      let labels = Trie.labels tm in
+      let map lbl = match lbl with
+      | None -> skip_arg (pred n) (Trie.next tm lbl)
+      | Some (_, m) ->
+        skip_arg (pred n + m) (Trie.next tm lbl)
+      in
+      List.flatten (List.map map labels)
+
   let lookup tm dna t =
     let rec lookrec t tm =
       match dna t with
 	| Nothing -> tm_of tm None
 	| Label(lbl,v) ->
 	    tm_of tm None@
-	      (List.fold_left 
-		 (fun l c -> 
+	      (List.fold_left
+		 (fun l c ->
 		List.flatten(List.map (fun (tm, b) ->
 					 if b then lookrec c tm
 					 else [tm,b]) l))
 		 (tm_of tm (Some(lbl,List.length v))) v)
 	| Everything -> skip_arg 1 tm
-    in 
-      List.flatten (List.map (fun (tm,b) -> T.xtract tm) (lookrec t tm))
-	
+    in
+    List.flatten (List.map (fun (tm,b) -> ZSet.elements (Trie.get tm)) (lookrec t tm))
+
   let add tm dna (pat,inf) =
-    let p = path_of dna pat in T.add tm (p,(pat,inf))
-				 
+    let p = path_of dna pat in Trie.add p (ZSet.singleton inf) tm
+
   let rmv tm dna (pat,inf) =
-  let p = path_of dna pat in T.rmv tm (p,(pat,inf))
-			       
-  let app f tm = T.app (fun (_,p) -> f p) tm
-    
+    let p = path_of dna pat in Trie.remove p (ZSet.singleton inf) tm
+
+  let app f tm = Trie.iter (fun _ p -> ZSet.iter f p) tm
+
 end
-  
+
diff --git a/tactics/dn.mli b/tactics/dn.mli
index 662ac19a..20407e9d 100644
--- a/tactics/dn.mli
+++ b/tactics/dn.mli
@@ -1,48 +1,39 @@
+type 'res lookup_res = Label of 'res | Nothing | Everything
 
 
-
-
-
-
-
-module Make : 
-  functor (X : Set.OrderedType) ->
+module Make :
     functor (Y : Map.OrderedType) ->
       functor (Z : Map.OrderedType) ->
 sig
 
-  type decompose_fun = X.t -> (Y.t * X.t list) option
-    
+  type 'a decompose_fun = 'a -> (Y.t * 'a list) option
+
   type t
 
   val create : unit -> t
-    
+
   (** [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
      the list of its subtree *)
-    
-  val add : t -> decompose_fun -> X.t * Z.t -> t
-    
-  val rmv : t -> decompose_fun -> X.t * Z.t -> t
-    
-  type 'res lookup_res = Label of 'res | Nothing | Everything
-      
+
+  val add : t -> 'a decompose_fun -> 'a * Z.t -> t
+
+  val rmv : t -> 'a decompose_fun -> 'a * Z.t -> t
+
   type 'tree lookup_fun = 'tree -> (Y.t * 'tree list) lookup_res
-    
+
 
 (** [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
    characterizing its root node and the list of its subtree *)
-    
+
   val lookup : t -> 'term lookup_fun -> 'term
-    -> (X.t * Z.t) list
-    
-  val app : ((X.t * Z.t) -> unit) -> t -> unit
-    
-  val skip_arg : int -> t -> (t * bool) list
-    
+    -> Z.t list
+
+  val app : (Z.t -> unit) -> t -> unit
+
 end
diff --git a/tactics/dnet.ml b/tactics/dnet.ml
new file mode 100644
index 00000000..61a35866
--- /dev/null
+++ b/tactics/dnet.ml
@@ -0,0 +1,291 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* Generic dnet implementation over non-recursive types *)
+
+module type Datatype =
+sig
+  type 'a t
+  val map : ('a -> 'b) -> 'a t -> 'b t
+  val map2 : ('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t
+  val fold : ('a -> 'b -> 'a) -> 'a -> 'b t -> 'a
+  val fold2 : ('a -> 'b -> 'c -> 'a)  -> 'a -> 'b t -> 'c t -> 'a
+  val compare : unit t -> unit t -> int
+  val terminal : 'a t -> bool
+  val choose : ('a -> 'b) -> 'a t -> 'b
+end
+
+module type S =
+sig
+  type t
+  type ident
+  type meta
+  type 'a structure
+  module Idset : Set.S with type elt=ident
+  type term_pattern =
+    | Term of term_pattern structure
+    | Meta of meta
+  val empty : t
+  val add : t -> term_pattern -> ident -> t
+  val find_all : t -> Idset.t
+  val fold_pattern :
+    ('a -> (Idset.t * meta * t) -> 'a) -> 'a -> term_pattern -> t -> Idset.t option * 'a
+  val find_match : term_pattern -> t -> Idset.t
+  val inter : t -> t -> t
+  val union : t -> t -> t
+  val map : (ident -> ident) -> (unit structure -> unit structure) -> t -> t
+end
+
+module Make =
+  functor (T:Datatype) ->
+  functor (Ident:Set.OrderedType) ->
+  functor (Meta:Set.OrderedType) ->
+struct
+
+  type ident = Ident.t
+  type meta = Meta.t
+
+  type 'a structure = 'a T.t
+
+  type term_pattern =
+    | Term of term_pattern structure
+    | Meta of meta
+
+  module Idset = Set.Make(Ident)
+  module Mmap = Map.Make(Meta)
+  module Tmap = Map.Make(struct type t = unit structure
+				let compare = T.compare end)
+
+  type idset = Idset.t
+
+
+
+  (* we store identifiers at the leaf of the dnet *)
+  type node =
+    | Node of t structure
+    | Terminal of t structure * idset
+
+  (* at each node, we have a bunch of nodes (actually a map between
+     the bare node and a subnet) and a bunch of metavariables *)
+  and t = Nodes of node Tmap.t * idset Mmap.t
+
+  let empty : t = Nodes (Tmap.empty, Mmap.empty)
+
+  (* the head of a data is of type unit structure *)
+  let head w = T.map (fun c -> ()) w
+
+  (* given a node of the net and a word, returns the subnet with the
+     same head as the word (with the rest of the nodes) *)
+  let split l (w:'a structure) : node * node Tmap.t =
+    let elt : node = Tmap.find (head w) l in
+    (elt, Tmap.remove (head w) l)
+
+  let select l w = Tmap.find (head w) l
+
+  let rec add (Nodes (t,m):t) (w:term_pattern) (id:ident) : t =
+    match w with Term w ->
+      ( try
+	  let (n,tl) = split t w in
+	  let new_node = match n with
+	    | Terminal (e,is) -> Terminal (e,Idset.add id is)
+	    | Node e -> Node (T.map2 (fun t p -> add t p id)  e w) in
+	  Nodes ((Tmap.add (head w) new_node tl), m)
+	with Not_found ->
+	  let new_content = T.map (fun p -> add empty p id) w in
+	  let new_node =
+	    if T.terminal w then
+	      Terminal (new_content, Idset.singleton id)
+	    else Node new_content in
+	  Nodes ((Tmap.add (head w) new_node t), m) )
+      | Meta i ->
+	  let m =
+	    try Mmap.add i (Idset.add id (Mmap.find i m)) m
+	    with Not_found -> Mmap.add i (Idset.singleton id) m in
+	  Nodes (t, m)
+
+  let add t w id = add t w id
+
+  let rec find_all (Nodes (t,m)) : idset =
+    Idset.union
+      (Mmap.fold (fun _ -> Idset.union) m Idset.empty)
+      (Tmap.fold
+	 ( fun _ n acc ->
+	     let s2 = match n with
+	       | Terminal (_,is) -> is
+	       | Node e -> T.choose find_all e in
+	     Idset.union acc s2
+	 ) t Idset.empty)
+
+(*   (\* optimization hack: Not_found is catched in fold_pattern *\) *)
+(*   let fast_inter s1 s2 = *)
+(*     if Idset.is_empty s1 || Idset.is_empty s2 then raise Not_found *)
+(*     else Idset.inter s1 s2 *)
+
+(*   let option_any2 f s1 s2 = match s1,s2 with *)
+(*     | Some s1, Some s2 -> f s1 s2 *)
+(*     | (Some s, _ | _, Some s) -> s *)
+(*     | _ -> raise Not_found *)
+
+(*   let fold_pattern ?(complete=true) f acc pat dn = *)
+(*     let deferred = ref [] in *)
+(*     let leafs,metas = ref None, ref None in *)
+(*     let leaf s = leafs := match !leafs with *)
+(*       | None -> Some s *)
+(*       | Some s' -> Some (fast_inter s s') in *)
+(*     let meta s = metas := match !metas with *)
+(*       | None -> Some s *)
+(*       | Some s' -> Some (Idset.union s s') in *)
+(*     let defer c = deferred := c::!deferred in *)
+(*     let rec fp_rec (p:term_pattern) (Nodes(t,m) as dn:t) = *)
+(*       Mmap.iter (fun _ -> meta) m; (\* TODO: gérer patterns nonlin ici *\) *)
+(*       match p with *)
+(* 	| Meta m -> defer (m,dn) *)
+(* 	| Term w -> *)
+(* 	    try match select t w with *)
+(* 	      | Terminal (_,is) -> leaf is *)
+(* 	      | Node e -> *)
+(* 		  if complete then T.fold2 (fun _ -> fp_rec) () w e else *)
+(* 		    if T.fold2 *)
+(* 		      (fun b p dn -> match p with *)
+(* 			 | Term _ -> fp_rec p dn; false *)
+(* 			 | Meta _ -> b *)
+(* 		      ) true w e *)
+(* 		    then T.choose (T.choose fp_rec w) e *)
+(* 	    with Not_found -> *)
+(* 	      if Mmap.is_empty m then raise Not_found else () *)
+(*     in try *)
+(*       fp_rec pat dn; *)
+(*       (try Some (option_any2 Idset.union !leafs !metas) with Not_found -> None), *)
+(*       List.fold_left (fun acc (m,dn) -> f m dn acc) acc !deferred *)
+(*     with Not_found -> None,acc *)
+
+  (* Sets with a neutral element for inter *)
+  module OSet (S:Set.S) = struct
+    type t = S.t option
+    let union s1 s2 : t = match s1,s2 with
+      | (None, _ | _, None) -> None
+      | Some a, Some b -> Some (S.union a b)
+    let inter s1 s2 : t = match s1,s2 with
+      | (None, a | a, None) -> a
+      | Some a, Some b -> Some (S.inter a b)
+    let is_empty : t -> bool = function 
+      | None -> false
+      | Some s -> S.is_empty s
+    (* optimization hack: Not_found is catched in fold_pattern *)
+    let fast_inter s1 s2 =
+      if is_empty s1 || is_empty s2 then raise Not_found
+      else let r = inter s1 s2 in 
+      if is_empty r then raise Not_found else r
+    let full = None
+    let empty = Some S.empty
+  end
+
+  module OIdset = OSet(Idset)
+
+  let fold_pattern ?(complete=true) f acc pat dn =
+    let deferred = ref [] in
+    let defer c = deferred := c::!deferred in
+
+    let rec fp_rec metas p (Nodes(t,m) as dn:t) =
+      (* TODO gérer les dnets non-linéaires *)
+      let metas = Mmap.fold (fun _ -> Idset.union) m metas in
+      match p with 
+	| Meta m -> defer (metas,m,dn); OIdset.full
+	| Term w ->
+	    let curm = Mmap.fold (fun _ -> Idset.union) m Idset.empty in
+	    try match select t w with
+	      | Terminal (_,is) -> Some (Idset.union curm is)
+	      | Node e -> 
+		  let ids = if complete then T.fold2
+		    (fun acc w e ->
+		       OIdset.fast_inter acc (fp_rec metas w e)
+		    ) OIdset.full w e 
+		  else
+		    let (all_metas, res) = T.fold2
+		      (fun (b,acc) w e -> match w with
+			 | Term _ -> false, OIdset.fast_inter acc (fp_rec metas w e)
+			 | Meta _ -> b, acc
+		      ) (true,OIdset.full) w e in
+		    if all_metas then T.choose (T.choose (fp_rec metas) w) e
+		    else res in
+		  OIdset.union ids (Some curm)
+	    with Not_found -> 
+	      if Idset.is_empty metas then raise Not_found else Some curm in
+    let cand = 
+      try fp_rec Idset.empty pat dn
+      with Not_found -> OIdset.empty in
+    let res = List.fold_left f acc !deferred in
+    cand, res
+
+  (* intersection of two dnets. keep only the common pairs *)
+  let rec inter (t1:t) (t2:t) : t =
+    let inter_map f (Nodes (t1,m1):t) (Nodes (t2,m2):t) : t =
+      Nodes
+	(Tmap.fold
+	   ( fun k e acc ->
+	       try Tmap.add k (f e (Tmap.find k t2)) acc
+	       with Not_found -> acc
+	   ) t1 Tmap.empty,
+	 Mmap.fold
+	   ( fun m s acc ->
+	       try Mmap.add m (Idset.inter s (Mmap.find m m2)) acc
+	       with Not_found -> acc
+	   ) m1 Mmap.empty
+	) in
+    inter_map
+      (fun n1 n2 -> match n1,n2 with
+	 | Terminal (e1,s1), Terminal (_,s2) -> Terminal (e1,Idset.inter s1 s2)
+	 | Node e1, Node e2 -> Node (T.map2 inter e1 e2)
+	 | _ -> assert false
+      ) t1 t2
+
+  let rec union (t1:t) (t2:t) : t =
+    let union_map f (Nodes (t1,m1):t) (Nodes (t2,m2):t) : t =
+      Nodes
+	(Tmap.fold
+	   ( fun k e acc ->
+	       try Tmap.add k (f e (Tmap.find k acc)) acc
+	       with Not_found -> Tmap.add k e acc
+	   ) t1 t2,
+	 Mmap.fold
+	   ( fun m s acc ->
+	       try Mmap.add m (Idset.inter s (Mmap.find m acc)) acc
+	       with Not_found -> Mmap.add m s acc
+	   ) m1 m2
+	) in
+    union_map
+      (fun n1 n2 -> match n1,n2 with
+	 | Terminal (e1,s1), Terminal (_,s2) -> Terminal (e1,Idset.union s1 s2)
+	 | Node e1, Node e2 -> Node (T.map2 union e1 e2)
+	 | _ -> assert false
+      ) t1 t2
+
+  let find_match (p:term_pattern) (t:t) : idset =
+    let metas = ref Mmap.empty in
+    let (mset,lset) = fold_pattern ~complete:false
+      (fun acc (mset,m,t) ->
+	 let all = OIdset.fast_inter acc
+	   (Some(let t = try inter t (Mmap.find m !metas) with Not_found -> t in
+		 metas := Mmap.add m t !metas;
+		 find_all t)) in
+	 OIdset.union (Some mset) all
+      ) None p t in
+    Option.get (OIdset.inter mset lset)
+
+  let fold_pattern f acc p dn = fold_pattern ~complete:true f acc p dn
+
+  let idset_map f is = Idset.fold (fun e acc -> Idset.add (f e) acc) is Idset.empty
+  let tmap_map f g m = Tmap.fold (fun k e acc -> Tmap.add (f k) (g e) acc) m Tmap.empty
+
+  let rec map sidset sterm (Nodes (t,m)) : t =
+    let snode = function
+      | Terminal (e,is) -> Terminal (e,idset_map sidset is)
+      | Node e -> Node (T.map (map sidset sterm) e) in
+    Nodes (tmap_map sterm snode t, Mmap.map (idset_map sidset) m)
+
+end
diff --git a/tactics/dnet.mli b/tactics/dnet.mli
new file mode 100644
index 00000000..4bfa7263
--- /dev/null
+++ b/tactics/dnet.mli
@@ -0,0 +1,124 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(** Generic discrimination net implementation over recursive
+   types. This module implements a association data structure similar
+   to tries but working on any types (not just lists). It is a term
+   indexing datastructure, a generalization of the discrimination nets
+   described for example in W.W.McCune, 1992, related also to
+   generalized tries [Hinze, 2000].
+
+   You can add pairs of (term,identifier) into a dnet, where the
+   identifier is *unique*, and search terms in a dnet filtering a
+   given pattern (retrievial of instances). It returns all identifiers
+   associated with terms matching the pattern. It also works the other
+   way around : You provide a set of patterns and a term, and it
+   returns all patterns which the term matches (retrievial of
+   generalizations). That's why you provide *patterns* everywhere.
+
+   Warning 1: Full unification doesn't work as for now. Make sure the
+   set of metavariables in the structure and in the queries are
+   distincts, or you'll get unexpected behaviours.
+
+   Warning 2: This structure is perfect, i.e. the set of candidates
+   returned is equal to the set of solutions. Beware of DeBruijn
+   shifts and sorts subtyping though (which makes the comparison not
+   symmetric, see term_dnet.ml).
+
+   The complexity of the search is (almost) the depth of the term.
+
+   To use it, you have to provide a module (Datatype) with the datatype
+   parametrized on the recursive argument. example:
+
+   type btree =                      type 'a btree0 =
+   | Leaf                    ===>    | Leaf
+   | Node of btree * btree           | Node of 'a * 'a
+
+*)
+
+(** datatype you want to build a dnet on *)
+module type Datatype =
+sig
+  (** parametric datatype. ['a] is morally the recursive argument *)
+  type 'a t
+
+  (** non-recursive mapping of subterms *)
+  val map : ('a -> 'b) -> 'a t -> 'b t
+  val map2 : ('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t
+
+  (** non-recursive folding of subterms *)
+  val fold : ('a -> 'b -> 'a) -> 'a -> 'b t -> 'a
+  val fold2 : ('a -> 'b -> 'c -> 'a) -> 'a -> 'b t -> 'c t -> 'a
+
+  (** comparison of constructors *)
+  val compare : unit t -> unit t -> int
+
+  (** for each constructor, is it not-parametric on 'a? *)
+  val terminal : 'a t -> bool
+
+  (** [choose f w] applies f on ONE of the subterms of w *)
+  val choose : ('a -> 'b) -> 'a t -> 'b
+end
+
+module type S =
+sig
+  type t
+
+  (** provided identifier type *)
+  type ident
+
+  (** provided metavariable type *)
+  type meta
+
+  (** provided parametrized datastructure *)
+  type 'a structure
+
+  (** returned sets of solutions *)
+  module Idset : Set.S with type elt=ident
+
+  (** a pattern is a term where each node can be a unification
+     variable *)
+  type term_pattern =
+    | Term of term_pattern structure
+    | Meta of meta
+
+  val empty : t
+
+  (** [add t w i] adds a new association (w,i) in t. *)
+  val add : t -> term_pattern -> ident -> t
+
+  (** [find_all t] returns all identifiers contained in t. *)
+  val find_all : t -> Idset.t
+
+  (** [fold_pattern f acc p dn] folds f on each meta of p, passing the
+     meta and the sub-dnet under it. The result includes:
+     - Some set if identifiers were gathered on the leafs of the term
+     - None if the pattern contains no leaf (only Metas at the leafs).
+  *)
+  val fold_pattern :
+    ('a -> (Idset.t * meta * t) -> 'a) -> 'a -> term_pattern -> t -> Idset.t option * 'a
+
+  (** [find_match p t] returns identifiers of all terms matching p in
+     t. *)
+  val find_match : term_pattern -> t -> Idset.t
+
+  (** set operations on dnets *)
+  val inter : t -> t -> t
+  val union : t -> t -> t
+
+  (** apply a function on each identifier and node of terms in a dnet *)
+  val map : (ident -> ident) -> (unit structure -> unit structure) -> t -> t
+end
+
+module Make :
+  functor (T:Datatype) ->
+  functor (Ident:Set.OrderedType) ->
+  functor (Meta:Set.OrderedType) ->
+    S with type ident = Ident.t
+      and  type meta = Meta.t
+      and  type 'a structure = 'a T.t
diff --git a/tactics/eauto.ml4 b/tactics/eauto.ml4
index 144100c9..30c5e686 100644
--- a/tactics/eauto.ml4
+++ b/tactics/eauto.ml4
@@ -1,40 +1,42 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i camlp4deps: "parsing/grammar.cma" i*)
+(*i camlp4deps: "grammar/grammar.cma" i*)
 
 open Pp
+open Errors
 open Util
 open Names
 open Nameops
 open Term
 open Termops
-open Sign
-open Reduction
 open Proof_type
-open Declarations
 open Tacticals
 open Tacmach
-open Evar_refiner
 open Tactics
-open Pattern
+open Patternops
 open Clenv
 open Auto
-open Glob_term
-open Hiddentac
+open Genredexpr
 open Tacexpr
+open Misctypes
+open Locus
+open Locusops
+open Hints
 
-let eauto_unif_flags = { auto_unif_flags with Unification.modulo_delta = full_transparent_state }
+DECLARE PLUGIN "eauto"
+
+let eauto_unif_flags = auto_flags_of_state full_transparent_state
 
 let e_give_exact ?(flags=eauto_unif_flags) c gl = let t1 = (pf_type_of gl c) and t2 = pf_concl gl in
-  if occur_existential t1 or occur_existential t2 then
-     tclTHEN (Clenvtac.unify ~flags t1) (exact_check c) gl
-  else exact_check c gl
+  if occur_existential t1 || occur_existential t2 then
+     tclTHEN (Proofview.V82.of_tactic (Clenvtac.unify ~flags t1)) (exact_no_check c) gl
+  else Proofview.V82.of_tactic (exact_check c) gl
 
 let assumption id = e_give_exact (mkVar id)
 
@@ -42,11 +44,11 @@ let e_assumption gl =
   tclFIRST (List.map assumption (pf_ids_of_hyps gl)) gl
 
 TACTIC EXTEND eassumption
-| [ "eassumption" ] -> [ e_assumption ]
+| [ "eassumption" ] -> [ Proofview.V82.tactic e_assumption ]
 END
 
 TACTIC EXTEND eexact
-| [ "eexact" constr(c) ] -> [ e_give_exact c ]
+| [ "eexact" constr(c) ] -> [ Proofview.V82.tactic (e_give_exact c) ]
 END
 
 let registered_e_assumption gl =
@@ -57,10 +59,29 @@ let registered_e_assumption gl =
 (*   PROLOG tactic                                                      *)
 (************************************************************************)
 
+(*s Tactics handling a list of goals. *)
+
+(* first_goal : goal list sigma -> goal sigma *)
+
+let first_goal gls =
+  let gl = gls.Evd.it and sig_0 = gls.Evd.sigma in
+  if List.is_empty gl then error "first_goal";
+  { Evd.it = List.hd gl; Evd.sigma = sig_0; }
+
+(* tactic -> tactic_list : Apply a tactic to the first goal in the list *)
+
+let apply_tac_list tac glls =
+  let (sigr,lg) = unpackage glls in
+  match lg with
+  | (g1::rest) ->
+      let gl = apply_sig_tac sigr tac g1 in
+      repackage sigr (gl@rest)
+  | _ -> error "apply_tac_list"
+
 let one_step l gl =
-  [Tactics.intro]
-  @ (List.map h_simplest_eapply (List.map mkVar (pf_ids_of_hyps gl)))
-  @ (List.map h_simplest_eapply l)
+  [Proofview.V82.of_tactic Tactics.intro]
+  @ (List.map (fun c -> Proofview.V82.of_tactic (Tactics.Simple.eapply c)) (List.map mkVar (pf_ids_of_hyps gl)))
+  @ (List.map (fun c -> Proofview.V82.of_tactic (Tactics.Simple.eapply c)) l)
   @ (List.map assumption (pf_ids_of_hyps gl))
 
 let rec prolog l n gl =
@@ -68,11 +89,15 @@ let rec prolog l n gl =
   let prol = (prolog l (n-1)) in
   (tclFIRST (List.map (fun t -> (tclTHEN t prol)) (one_step l gl))) gl
 
+let out_term = function
+  | IsConstr (c, _) -> c
+  | IsGlobRef gr -> fst (Universes.fresh_global_instance (Global.env ()) gr)
+
 let prolog_tac l n gl =
-  let l = List.map (prepare_hint (pf_env gl)) l in
+  let l = List.map (fun x -> out_term (pf_apply (prepare_hint false) gl x)) l in
   let n =
     match n with
-      |  ArgArg n -> n
+      | ArgArg n -> n
       | _ -> error "Prolog called with a non closed argument."
   in
   try (prolog l n gl)
@@ -80,7 +105,7 @@ let prolog_tac l n gl =
     errorlabstrm "Prolog.prolog" (str "Prolog failed.")
 
 TACTIC EXTEND prolog
-| [ "prolog" "[" open_constr_list(l) "]" int_or_var(n) ] -> [ prolog_tac l n ]
+| [ "prolog" "[" open_constr_list(l) "]" int_or_var(n) ] -> [ Proofview.V82.tactic (prolog_tac l n) ]
 END
 
 open Auto
@@ -90,17 +115,26 @@ open Unification
 (* A tactic similar to Auto, but using EApply, Assumption and e_give_exact *)
 (***************************************************************************)
 
-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 ~flags clenv' gls in
-  h_simplest_eapply c gls
-
+let priority l = List.map snd (List.filter (fun (pr,_) -> Int.equal pr 0) l)
+
+let unify_e_resolve poly flags (c,clenv) gls =
+  let clenv', subst = if poly then Clenv.refresh_undefined_univs clenv 
+  else clenv, Univ.empty_level_subst in
+  let clenv' = connect_clenv gls clenv' in
+  let clenv' = clenv_unique_resolver ~flags clenv' gls in
+    tclTHEN (Refiner.tclEVARUNIVCONTEXT (Evd.evar_universe_context clenv'.evd))
+      (Proofview.V82.of_tactic (Tactics.Simple.eapply (Vars.subst_univs_level_constr subst c))) gls
+
+let e_exact poly flags (c,clenv) =
+  let clenv', subst = 
+    if poly then Clenv.refresh_undefined_univs clenv 
+    else clenv, Univ.empty_level_subst
+  in e_give_exact (* ~flags *) (Vars.subst_univs_level_constr subst c)
+    
 let rec e_trivial_fail_db db_list local_db goal =
   let tacl =
     registered_e_assumption ::
-    (tclTHEN Tactics.intro
+    (tclTHEN (Proofview.V82.of_tactic Tactics.intro)
        (function g'->
 	  let d = pf_last_hyp g' in
 	  let hintl = make_resolve_hyp (pf_env g') (project g') d in
@@ -108,43 +142,35 @@ let rec e_trivial_fail_db db_list local_db goal =
 	      (Hint_db.add_list hintl local_db) g'))) ::
     (List.map fst (e_trivial_resolve db_list local_db (pf_concl goal)) )
   in
-  tclFIRST (List.map tclCOMPLETE tacl) goal
+    tclFIRST (List.map tclCOMPLETE tacl) goal
 
 and e_my_find_search db_list local_db hdc concl =
-  let hdc = head_of_constr_reference hdc in
   let hintl =
     if occur_existential concl then
-      list_map_append (fun db ->
-	let flags = {auto_unif_flags with modulo_delta = Hint_db.transparent_state db} in
-	  List.map (fun x -> flags, x) (Hint_db.map_all hdc db)) (local_db::db_list)
+      List.map_append (fun db ->
+	let flags = auto_flags_of_state (Hint_db.transparent_state db) in
+	  List.map (fun x -> flags, x) (Hint_db.map_existential hdc concl db)
+   (* FIXME: should be (Hint_db.map_eauto hdc concl db) *)) (local_db::db_list)
     else
-      list_map_append (fun db ->
-	let flags = {auto_unif_flags with modulo_delta = Hint_db.transparent_state db} in
-	  List.map (fun x -> flags, x) (Hint_db.map_auto (hdc,concl) db)) (local_db::db_list)
+      List.map_append (fun db ->
+	let flags = auto_flags_of_state (Hint_db.transparent_state db) in
+	  List.map (fun x -> flags, x) (Hint_db.map_auto hdc concl db)) (local_db::db_list)
   in
   let tac_of_hint =
-    fun (st, {pri=b; pat = p; code=t}) ->
+    fun (st, {pri = b; pat = p; code = t; poly = poly}) ->
       (b,
        let tac =
 	 match t with
-	   | Res_pf (term,cl) -> unify_resolve st (term,cl)
-	   | ERes_pf (term,cl) -> unify_e_resolve st (term,cl)
-	   | Give_exact (c) -> e_give_exact c
+	   | Res_pf (term,cl) -> Proofview.V82.of_tactic (unify_resolve poly st (term,cl))
+	   | ERes_pf (term,cl) -> unify_e_resolve poly st (term,cl)
+	   | Give_exact (c,cl) -> e_exact poly st (c,cl)
 	   | Res_pf_THEN_trivial_fail (term,cl) ->
-               tclTHEN (unify_e_resolve st (term,cl))
+               tclTHEN (unify_e_resolve poly st (term,cl))
 		 (e_trivial_fail_db db_list local_db)
-	   | Unfold_nth c -> h_reduce (Unfold [all_occurrences_expr,c]) onConcl
-	   | Extern tacast -> conclPattern concl p tacast
+	   | Unfold_nth c -> reduce (Unfold [AllOccurrences,c]) onConcl
+	   | Extern tacast -> Proofview.V82.of_tactic (conclPattern concl p tacast)
        in
        (tac,lazy (pr_autotactic t)))
-       (*i
-	 fun gls -> pPNL (pr_autotactic t); Format.print_flush ();
-                     try tac gls
-		     with e when Logic.catchable_exception(e) ->
-                            (Format.print_string "Fail\n";
-			     Format.print_flush ();
-			     raise e)
-       i*)
   in
   List.map tac_of_hint hintl
 
@@ -152,13 +178,13 @@ and e_trivial_resolve db_list local_db gl =
   try
     priority
       (e_my_find_search db_list local_db
-	 (fst (head_constr_bound gl)) gl)
+	 (decompose_app_bound gl) gl)
   with Bound | Not_found -> []
 
 let e_possible_resolve db_list local_db gl =
   try List.map snd
     (e_my_find_search db_list local_db
-	(fst (head_constr_bound gl)) gl)
+	(decompose_app_bound gl) gl)
   with Bound | Not_found -> []
 
 let find_first_goal gls =
@@ -171,8 +197,8 @@ type search_state = {
   depth : int; (*r depth of search before failing *)
   tacres : goal list sigma;
   last_tactic : std_ppcmds Lazy.t;
-  dblist : Auto.hint_db list;
-  localdb :  Auto.hint_db list;
+  dblist : hint_db list;
+  localdb :  hint_db list;
   prev : prev_search_state
 }
 
@@ -185,13 +211,9 @@ module SearchProblem = struct
 
   type state = search_state
 
-  let success s = (sig_it s.tacres) = []
+  let success s = List.is_empty (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_evar_map (Refiner.project gls) in
-      prlist (pr_ev evars) (sig_it gls)
+(*   let pr_ev evs ev = Printer.pr_constr_env (Evd.evar_env ev) (Evarutil.nf_evar evs ev.Evd.evar_concl) *)
 
   let filter_tactics glls l =
 (*     let _ = Proof_trees.db_pr_goal (List.hd (sig_it glls)) in *)
@@ -206,6 +228,7 @@ module SearchProblem = struct
 (* 	      msg (hov 1 (pptac ++ str" gives: \n" ++ pr_goals lgls ++ str"\n")); *)
 	      (lgls,pptac) :: aux tacl
 	  with e when Errors.noncritical e ->
+            let e = Errors.push e in
             Refiner.catch_failerror e; aux tacl
     in aux l
 
@@ -214,13 +237,13 @@ module SearchProblem = struct
   let compare s s' =
     let d = s'.depth - s.depth in
     let nbgoals s = List.length (sig_it s.tacres) in
-    if d <> 0 then d else nbgoals s - nbgoals s'
+    if not (Int.equal d 0) then d else nbgoals s - nbgoals s'
 
   let branching s =
-    if s.depth = 0 then
+    if Int.equal s.depth 0 then
       []
     else
-      let ps = if s.prev = Unknown then Unknown else State s in
+      let ps = if s.prev == Unknown then Unknown else State s in
       let lg = s.tacres in
       let nbgl = List.length (sig_it lg) in
       assert (nbgl > 0);
@@ -249,7 +272,7 @@ module SearchProblem = struct
 	     { depth = s.depth; tacres = res;
 	       last_tactic = pp; dblist = s.dblist;
 	       localdb = ldb :: List.tl s.localdb; prev = ps })
-	  (filter_tactics s.tacres [Tactics.intro,lazy (str "intro")])
+	  (filter_tactics s.tacres [Proofview.V82.of_tactic Tactics.intro,lazy (str "intro")])
       in
       let rec_tacs =
 	let l =
@@ -262,10 +285,18 @@ module SearchProblem = struct
 	       { depth = s.depth; tacres = res; last_tactic = pp; prev = ps;
 		 dblist = s.dblist; localdb = List.tl s.localdb }
 	     else
-	       { depth = pred s.depth; tacres = res;
-		 dblist = s.dblist; last_tactic = pp; prev = ps;
-		 localdb =
-		   list_addn (nbgl'-nbgl) (List.hd s.localdb) s.localdb })
+	       let newlocal = 
+		 let hyps = pf_hyps g in
+		   List.map (fun gl ->
+		     let gls = {Evd.it = gl; sigma = lgls.Evd.sigma } in
+		     let hyps' = pf_hyps gls in
+		       if hyps' == hyps then List.hd s.localdb
+		       else make_local_hint_db (pf_env gls) (project gls) ~ts:full_transparent_state true [])
+		     (List.firstn ((nbgl'-nbgl) + 1) (sig_it lgls))
+	       in
+		 { depth = pred s.depth; tacres = res;
+		   dblist = s.dblist; last_tactic = pp; prev = ps;
+		   localdb = newlocal @ List.tl s.localdb })
 	  l
       in
       List.sort compare (assumption_tacs @ intro_tac @ rec_tacs)
@@ -301,8 +332,8 @@ let _ =
       Goptions.optwrite = (:=) global_info_eauto }
 
 let mk_eauto_dbg d =
-  if d = Debug || !global_debug_eauto then Debug
-  else if d = Info || !global_info_eauto then Info
+  if d == Debug || !global_debug_eauto then Debug
+  else if d == Info || !global_info_eauto then Info
   else Off
 
 let pr_info_nop = function
@@ -315,7 +346,7 @@ let pr_dbg_header = function
   | Info -> msg_debug (str "(* info eauto : *)")
 
 let pr_info dbg s =
-  if dbg <> Info then ()
+  if dbg != Info then ()
   else
     let rec loop s =
       match s.prev with
@@ -336,11 +367,11 @@ let make_initial_state dbg n gl dblist localdb =
     last_tactic = lazy (mt());
     dblist = dblist;
     localdb = [localdb];
-    prev = if dbg=Info then Init else Unknown;
+    prev = if dbg == Info then Init else Unknown;
   }
 
 let e_search_auto debug (in_depth,p) lems db_list gl =
-  let local_db = make_local_hint_db ~ts:full_transparent_state true lems gl in
+  let local_db = make_local_hint_db (pf_env gl) (project gl) ~ts:full_transparent_state true lems in
   let d = mk_eauto_dbg debug in
   let tac = match in_depth,d with
     | (true,Debug) -> Search.debug_depth_first
@@ -357,7 +388,8 @@ let e_search_auto debug (in_depth,p) lems db_list gl =
     pr_info_nop d;
     error "eauto: search failed"
 
-open Evd
+(* let e_search_auto_key = Profile.declare_profile "e_search_auto" *)
+(* let e_search_auto = Profile.profile5 e_search_auto_key e_search_auto *)
 
 let eauto_with_bases ?(debug=Off) np lems db_list =
   tclTRY (e_search_auto debug np lems db_list)
@@ -368,8 +400,8 @@ let eauto ?(debug=Off) np lems dbnames =
 
 let full_eauto ?(debug=Off) n lems gl =
   let dbnames = current_db_names () in
-  let dbnames =  list_remove "v62" dbnames in
-  let db_list = List.map searchtable_map dbnames in
+  let dbnames =  String.Set.remove "v62" dbnames in
+  let db_list = List.map searchtable_map (String.Set.elements dbnames) in
   tclTRY (e_search_auto debug n lems db_list) gl
 
 let gen_eauto ?(debug=Off) np lems = function
@@ -422,7 +454,7 @@ END
 TACTIC EXTEND eauto
 | [ "eauto" int_or_var_opt(n) int_or_var_opt(p) auto_using(lems)
     hintbases(db) ] ->
-    [ gen_eauto (make_dimension n p) lems db ]
+    [ Proofview.V82.tactic (gen_eauto (make_dimension n p) lems db) ]
 END
 
 TACTIC EXTEND new_eauto
@@ -436,64 +468,70 @@ END
 TACTIC EXTEND debug_eauto
 | [ "debug" "eauto" int_or_var_opt(n) int_or_var_opt(p) auto_using(lems)
     hintbases(db) ] ->
-    [ gen_eauto ~debug:Debug (make_dimension n p) lems db ]
+    [ Proofview.V82.tactic (gen_eauto ~debug:Debug (make_dimension n p) lems db) ]
 END
 
 TACTIC EXTEND info_eauto
 | [ "info_eauto" int_or_var_opt(n) int_or_var_opt(p) auto_using(lems)
     hintbases(db) ] ->
-    [ gen_eauto ~debug:Info (make_dimension n p) lems db ]
+    [ Proofview.V82.tactic (gen_eauto ~debug:Info (make_dimension n p) lems db) ]
 END
 
 TACTIC EXTEND dfs_eauto
 | [ "dfs" "eauto" int_or_var_opt(p) auto_using(lems)
       hintbases(db) ] ->
-    [ gen_eauto (true, make_depth p) lems db ]
+    [ Proofview.V82.tactic (gen_eauto (true, make_depth p) lems db) ]
 END
 
 let cons a l = a :: l
 
-let autounfolds db occs =
+let autounfolds db occs cls gl =
   let unfolds = List.concat (List.map (fun dbname -> 
     let db = try searchtable_map dbname 
       with Not_found -> errorlabstrm "autounfold" (str "Unknown database " ++ str dbname)
     in
     let (ids, csts) = Hint_db.unfolds db in
-      Cset.fold (fun cst -> cons (all_occurrences, EvalConstRef cst)) csts
-	(Idset.fold (fun id -> cons (all_occurrences, EvalVarRef id)) ids [])) db)
-  in unfold_option unfolds
+    let hyps = pf_ids_of_hyps gl in
+    let ids = Idset.filter (fun id -> List.mem id hyps) ids in
+      Cset.fold (fun cst -> cons (AllOccurrences, EvalConstRef cst)) csts
+	(Id.Set.fold (fun id -> cons (AllOccurrences, EvalVarRef id)) ids [])) db)
+  in unfold_option unfolds cls gl
 
 let autounfold db cls gl =
-  let cls = concrete_clause_of cls gl in
+  let cls = concrete_clause_of (fun () -> pf_ids_of_hyps gl) cls in
   let tac = autounfolds db in
   tclMAP (function
     | OnHyp (id,occs,where) -> tac occs (Some (id,where))
     | OnConcl occs -> tac occs None)
     cls gl
 
-open Extraargs
+let autounfold_tac db cls gl =
+  let dbs = match db with
+  | None -> String.Set.elements (current_db_names ())
+  | Some [] -> ["core"]
+  | Some l -> l
+  in
+  autounfold dbs  cls gl
 
 TACTIC EXTEND autounfold
-| [ "autounfold" hintbases(db) in_arg_hyp(id) ] ->
-    [ autounfold (match db with None -> Auto.current_db_names () | Some [] -> ["core"] | Some x -> x) 
-	(glob_in_arg_hyp_to_clause id) ]
+| [ "autounfold" hintbases(db) clause(cl) ] -> [ Proofview.V82.tactic (autounfold_tac db cl) ]
 END
 
 let unfold_head env (ids, csts) c = 
   let rec aux c = 
     match kind_of_term c with
-    | Var id when Idset.mem id ids ->
+    | Var id when Id.Set.mem id ids ->
 	(match Environ.named_body id env with
 	| Some b -> true, b
 	| None -> false, c)
-    | Const cst when Cset.mem cst csts ->
-	true, Environ.constant_value env cst
+    | Const (cst,u as c) when Cset.mem cst csts ->
+	true, Environ.constant_value_in env c
     | App (f, args) ->
 	(match aux f with
 	| true, f' -> true, Reductionops.whd_betaiota Evd.empty (mkApp (f', args))
 	| false, _ -> 
 	    let done_, args' = 
-	      array_fold_left_i (fun i (done_, acc) arg -> 
+	      Array.fold_left_i (fun i (done_, acc) arg -> 
 		if done_ then done_, arg :: acc 
 		else match aux arg with
 		| true, arg' -> true, arg' :: acc
@@ -511,24 +549,30 @@ let unfold_head env (ids, csts) c =
 	in !done_, c'
   in aux c
 
-let autounfold_one db cl gl =
+let autounfold_one db cl =
+  Proofview.Goal.nf_enter begin fun gl ->
+  let env = Proofview.Goal.env gl in
+  let concl = Proofview.Goal.concl gl in
   let st =
     List.fold_left (fun (i,c) dbname -> 
       let db = try searchtable_map dbname 
 	with Not_found -> errorlabstrm "autounfold" (str "Unknown database " ++ str dbname)
       in
       let (ids, csts) = Hint_db.unfolds db in
-	(Idset.union ids i, Cset.union csts c)) (Idset.empty, Cset.empty) db
+	(Id.Set.union ids i, Cset.union csts c)) (Id.Set.empty, Cset.empty) db
+  in
+  let did, c' = unfold_head env st 
+    (match cl with Some (id, _) -> Tacmach.New.pf_get_hyp_typ id gl | None -> concl) 
   in
-  let did, c' = unfold_head (pf_env gl) st (match cl with Some (id, _) -> pf_get_hyp_typ gl id | None -> pf_concl gl) in
     if did then
       match cl with
-      | Some hyp -> change_in_hyp None c' hyp gl
-      | None -> convert_concl_no_check c' DEFAULTcast gl
-    else tclFAIL 0 (str "Nothing to unfold") gl
+      | Some hyp -> change_in_hyp None (fun sigma -> sigma, c') hyp
+      | None -> convert_concl_no_check c' DEFAULTcast
+    else Tacticals.New.tclFAIL 0 (str "Nothing to unfold")
+  end
 
 (* 	  Cset.fold (fun cst -> cons (all_occurrences, EvalConstRef cst)) csts *)
-(* 	    (Idset.fold (fun id -> cons (all_occurrences, EvalVarRef id)) ids [])) db) *)
+(* 	    (Id.Set.fold (fun id -> cons (all_occurrences, EvalVarRef id)) ids [])) db) *)
 (*       in unfold_option unfolds cl *)
 
 (*       let db = try searchtable_map dbname  *)
@@ -536,7 +580,7 @@ let autounfold_one db cl gl =
 (*       in *)
 (*       let (ids, csts) = Hint_db.unfolds db in *)
 (* 	Cset.fold (fun cst -> tclORELSE (unfold_option [(occ, EvalVarRef id)] cst)) csts *)
-(* 	  (Idset.fold (fun id -> tclORELSE (unfold_option [(occ, EvalVarRef id)] cl) ids acc))) *)
+(* 	  (Id.Set.fold (fun id -> tclORELSE (unfold_option [(occ, EvalVarRef id)] cl) ids acc))) *)
 (*       (tclFAIL 0 (mt())) db *)
       
 TACTIC EXTEND autounfold_one
@@ -548,16 +592,26 @@ TACTIC EXTEND autounfold_one
 
 TACTIC EXTEND autounfoldify
 | [ "autounfoldify" constr(x) ] -> [
+  Proofview.V82.tactic (
     let db = match kind_of_term x with
-      | Const c -> string_of_label (con_label c)
+      | Const (c,_) -> Label.to_string (con_label c)
       | _ -> assert false
-    in autounfold ["core";db] onConcl ]
+    in autounfold ["core";db] onConcl 
+  )]
 END
 
 TACTIC EXTEND unify
 | ["unify" constr(x) constr(y) ] -> [ unify x y ]
 | ["unify" constr(x) constr(y) "with" preident(base)  ] -> [
-    unify ~state:(Hint_db.transparent_state (searchtable_map base)) x y ]
+    let table = try Some (searchtable_map base) with Not_found -> None in
+    match table with
+    | None ->
+      let msg = str "Hint table " ++ str base ++ str " not found" in
+      Proofview.tclZERO (UserError ("", msg))
+    | Some t ->
+      let state = Hint_db.transparent_state t in
+      unify ~state x y
+  ]
 END
 
 
@@ -570,7 +624,7 @@ let pr_hints_path_atom prc _ _ a =
   match a with
   | PathAny -> str"."
   | PathHints grs ->
-    prlist_with_sep pr_spc Printer.pr_global grs
+    pr_sequence Printer.pr_global grs
 
 ARGUMENT EXTEND hints_path_atom
   TYPED AS hints_path_atom
@@ -610,9 +664,9 @@ ARGUMENT EXTEND opthints
 | [ ] -> [ None ]
 END
 
-VERNAC COMMAND EXTEND HintCut
+VERNAC COMMAND EXTEND HintCut CLASSIFIED AS SIDEFF
 | [ "Hint" "Cut" "[" hints_path(p) "]" opthints(dbnames) ] -> [
   let entry = HintsCutEntry p in
-    Auto.add_hints (Vernacexpr.use_section_locality ()) 
+    Hints.add_hints (Locality.make_section_locality (Locality.LocalityFixme.consume ()))
       (match dbnames with None -> ["core"] | Some l -> l) entry ]
 END
diff --git a/tactics/eauto.mli b/tactics/eauto.mli
index bfe52d9a..19e2f198 100644
--- a/tactics/eauto.mli
+++ b/tactics/eauto.mli
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,18 +8,19 @@
 
 open Term
 open Proof_type
-open Tacexpr
 open Auto
-open Topconstr
 open Evd
-open Environ
-open Explore
+open Hints
 
 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 : Genarg.open_constr_expr list raw_abstract_argument_type
+val wit_hintbases : hint_db_name list option Genarg.uniform_genarg_type
+
+val wit_auto_using :
+  (Tacexpr.open_constr_expr list,
+  Tacexpr.open_glob_constr list, Evd.open_constr list)
+    Genarg.genarg_type
+
 
 val e_assumption : tactic
 
@@ -33,6 +34,6 @@ val gen_eauto : ?debug:Tacexpr.debug -> bool * int -> open_constr list ->
 val eauto_with_bases :
   ?debug:Tacexpr.debug ->
   bool * int ->
-  open_constr list -> Auto.hint_db list -> Proof_type.tactic
+  open_constr list -> hint_db list -> Proof_type.tactic
 
-val autounfold : hint_db_name list -> Tacticals.clause -> tactic
+val autounfold : hint_db_name list -> Locus.clause -> tactic
diff --git a/tactics/elim.ml b/tactics/elim.ml
index ea5b4eed..b7d5b102 100644
--- a/tactics/elim.ml
+++ b/tactics/elim.ml
@@ -1,35 +1,28 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-open Pp
 open Util
 open Names
 open Term
 open Termops
-open Environ
-open Libnames
-open Reduction
 open Inductiveops
-open Proof_type
-open Clenv
 open Hipattern
-open Tacmach
-open Tacticals
+open Tacmach.New
+open Tacticals.New
 open Tactics
-open Hiddentac
-open Genarg
-open Tacexpr
+open Misctypes
+open Proofview.Notations
 
 let introElimAssumsThen tac ba =
   let nassums =
     List.fold_left
       (fun acc b -> if b then acc+2 else acc+1)
-      0 ba.branchsign
+      0 ba.Tacticals.branchsign
   in
   let introElimAssums = tclDO nassums intro in
   (tclTHEN introElimAssums (elim_on_ba tac ba))
@@ -38,17 +31,17 @@ let introCaseAssumsThen tac ba =
   let case_thin_sign =
     List.flatten
       (List.map (function b -> if b then [false;true] else [false])
-	ba.branchsign)
+	ba.Tacticals.branchsign)
   in
   let n1 = List.length case_thin_sign in
-  let n2 = List.length ba.branchnames in
+  let n2 = List.length ba.Tacticals.branchnames in
   let (l1,l2),l3 =
-    if n1 < n2 then list_chop n1 ba.branchnames, []
+    if n1 < n2 then List.chop n1 ba.Tacticals.branchnames, []
     else
-      (ba.branchnames, []),
-       if n1 > n2 then snd (list_chop n2 case_thin_sign) else [] in
+      (ba.Tacticals.branchnames, []),
+       if n1 > n2 then snd (List.chop n2 case_thin_sign) else [] in
   let introCaseAssums =
-    tclTHEN (intros_pattern no_move l1) (intros_clearing l3) in
+    tclTHEN (intro_patterns l1) (intros_clearing l3) in
   (tclTHEN introCaseAssums (case_on_ba (tac l2) ba))
 
 (* The following tactic Decompose repeatedly applies the
@@ -69,118 +62,120 @@ Another example :
    Qed.
 *)
 
-let elimHypThen tac id gl =
-  elimination_then tac ([],[]) (mkVar id) gl
+let elimHypThen tac id =
+  elimination_then tac (mkVar id)
 
 let rec general_decompose_on_hyp recognizer =
-  ifOnHyp recognizer (general_decompose_aux recognizer) (fun _ -> tclIDTAC)
+  ifOnHyp recognizer (general_decompose_aux recognizer) (fun _ -> Proofview.tclUNIT())
 
 and general_decompose_aux recognizer id =
   elimHypThen
     (introElimAssumsThen
        (fun bas ->
-	  tclTHEN (clear [id])
+	  tclTHEN (Proofview.V82.tactic (clear [id]))
 	    (tclMAP (general_decompose_on_hyp recognizer)
-               (ids_of_named_context bas.assums))))
+               (ids_of_named_context bas.Tacticals.assums))))
     id
 
-(* Faudrait ajouter un COMPLETE pour que l'hypothèse créée ne reste
-   pas si aucune élimination n'est possible *)
+(* We should add a COMPLETE to be sure that the created hypothesis
+   doesn't stay if no elimination is possible *)
 
-(* Meilleures stratégies mais perte de compatibilité *)
-let tmphyp_name = id_of_string "_TmpHyp"
+(* Best strategies but loss of compatibility *)
+let tmphyp_name = Id.of_string "_TmpHyp"
 let up_to_delta = ref false (* true *)
 
-let general_decompose recognizer c gl =
-  let typc = pf_type_of gl c in
-  tclTHENSV (cut typc)
-    [| tclTHEN (intro_using tmphyp_name)
+let general_decompose recognizer c =
+  Proofview.Goal.enter begin fun gl ->
+  let type_of = pf_type_of gl in
+  let typc = type_of c in
+  tclTHENS (cut typc)
+    [ tclTHEN (intro_using tmphyp_name)
          (onLastHypId
 	    (ifOnHyp recognizer (general_decompose_aux recognizer)
-	      (fun id -> clear [id])));
-       exact_no_check c |] gl
+	      (fun id -> Proofview.V82.tactic (clear [id]))));
+       Proofview.V82.tactic (exact_no_check c) ]
+  end
 
-let head_in gls indl t =
+let head_in indl t gl =
+  let env = Proofview.Goal.env gl in
+  let sigma = Proofview.Goal.sigma gl in
   try
     let ity,_ =
       if !up_to_delta
-      then find_mrectype (pf_env gls) (project gls) t
+      then find_mrectype env sigma t
       else extract_mrectype t
-    in List.mem ity indl
+    in List.exists (fun i -> eq_ind (fst i) (fst ity)) indl
   with Not_found -> false
 
-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
+let decompose_these c l =
+  Proofview.Goal.enter begin fun gl ->
+  let indl = List.map (fun x -> x, Univ.Instance.empty) l in
+  general_decompose (fun (_,t) -> head_in indl t gl) c
+  end
 
-let decompose_nonrec c gls =
-  general_decompose
-    (fun (_,t) -> is_non_recursive_type t)
-    c gls
-
-let decompose_and c gls =
+let decompose_and c =
   general_decompose
     (fun (_,t) -> is_record t)
-    c gls
+    c
 
-let decompose_or c gls =
+let decompose_or c =
   general_decompose
     (fun (_,t) -> is_disjunction t)
-    c gls
+    c
 
-let h_decompose l c =
-  Refiner.abstract_tactic (TacDecompose (l,c)) (decompose_these c l)
+let h_decompose l c = decompose_these c l
 
-let h_decompose_or c =
-  Refiner.abstract_tactic (TacDecomposeOr c) (decompose_or c)
+let h_decompose_or = decompose_or
 
-let h_decompose_and c =
-  Refiner.abstract_tactic (TacDecomposeAnd c) (decompose_and c)
+let h_decompose_and = decompose_and
 
 (* The tactic Double performs a double induction *)
 
-let simple_elimination c gls =
-  simple_elimination_then (fun _ -> tclIDTAC) c gls
+let simple_elimination c =
+  elimination_then (fun _ -> tclIDTAC) c
 
 let induction_trailer abs_i abs_j bargs =
   tclTHEN
     (tclDO (abs_j - abs_i) intro)
     (onLastHypId
-       (fun id gls ->
-	  let idty = pf_type_of gls (mkVar id) in
-	  let fvty = global_vars (pf_env gls) idty in
+       (fun id ->
+          Proofview.Goal.nf_enter begin fun gl ->
+	  let idty = pf_type_of gl (mkVar id) in
+	  let fvty = global_vars (pf_env gl) idty in
 	  let possible_bring_hyps =
-	    (List.tl (nLastDecls (abs_j - abs_i) gls)) @ bargs.assums
+	    (List.tl (nLastDecls gl (abs_j - abs_i))) @ bargs.Tacticals.assums
           in
 	  let (hyps,_) =
             List.fold_left
-	      (fun (bring_ids,leave_ids) (cid,_,cidty as d) ->
+	      (fun (bring_ids,leave_ids) (cid,_,_ as d) ->
                  if not (List.mem cid leave_ids)
                  then (d::bring_ids,leave_ids)
                  else (bring_ids,cid::leave_ids))
 	      ([],fvty) possible_bring_hyps
 	  in
           let ids = List.rev (ids_of_named_context hyps) in
-	  (tclTHENSEQ
-            [bring_hyps hyps; tclTRY (clear ids);
+	  (tclTHENLIST
+            [bring_hyps hyps; tclTRY (Proofview.V82.tactic (clear ids));
 	     simple_elimination (mkVar id)])
-          gls))
-
-let double_ind h1 h2 gls =
-  let abs_i = depth_of_quantified_hypothesis true h1 gls in
-  let abs_j = depth_of_quantified_hypothesis true h2 gls in
-  let (abs_i,abs_j) =
-    if abs_i < abs_j then (abs_i,abs_j) else
-    if abs_i > abs_j then (abs_j,abs_i) else
-      error "Both hypotheses are the same." in
+          end
+          ))
+
+let double_ind h1 h2 =
+  Proofview.Goal.nf_enter begin fun gl ->
+  let abs_i = of_old (depth_of_quantified_hypothesis true h1) gl in
+  let abs_j = of_old (depth_of_quantified_hypothesis true h2) gl in
+  let abs =
+    if abs_i < abs_j then Proofview.tclUNIT (abs_i,abs_j) else
+    if abs_i > abs_j then  Proofview.tclUNIT (abs_j,abs_i) else
+      tclZEROMSG (Pp.str "Both hypotheses are the same.") in
+  abs >>= fun (abs_i,abs_j) ->
   (tclTHEN (tclDO abs_i intro)
      (onLastHypId
        	(fun id ->
            elimination_then
-             (introElimAssumsThen (induction_trailer abs_i abs_j))
-             ([],[]) (mkVar id)))) gls
+             (introElimAssumsThen (induction_trailer abs_i abs_j)) (mkVar id))))
+  end
 
-let h_double_induction h1 h2 =
-  Refiner.abstract_tactic (TacDoubleInduction (h1,h2)) (double_ind h1 h2)
+let h_double_induction = double_ind
 
 
diff --git a/tactics/elim.mli b/tactics/elim.mli
index 2c6b8d96..8e98646e 100644
--- a/tactics/elim.mli
+++ b/tactics/elim.mli
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,27 +8,16 @@
 
 open Names
 open Term
-open Proof_type
-open Tacmach
-open Genarg
 open Tacticals
+open Misctypes
 
 (** Eliminations tactics. *)
 
-val introElimAssumsThen :
-  (branch_assumptions -> tactic) -> branch_args -> tactic
-
 val introCaseAssumsThen :
-  (intro_pattern_expr Util.located list -> branch_assumptions -> tactic) ->
-    branch_args -> tactic
-
-val general_decompose : (identifier * constr -> bool) -> constr -> tactic
-val decompose_nonrec  : constr -> tactic
-val decompose_and     : constr -> tactic
-val decompose_or      : constr -> tactic
-val h_decompose       : inductive list -> constr -> tactic
-val h_decompose_or    : constr -> tactic
-val h_decompose_and   : constr -> tactic
+  (Tacexpr.intro_patterns -> branch_assumptions -> unit Proofview.tactic) ->
+    branch_args -> unit Proofview.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
+val h_decompose       : inductive list -> constr -> unit Proofview.tactic
+val h_decompose_or    : constr -> unit Proofview.tactic
+val h_decompose_and   : constr -> unit Proofview.tactic
+val h_double_induction : quantified_hypothesis -> quantified_hypothesis-> unit Proofview.tactic
diff --git a/tactics/elimschemes.ml b/tactics/elimschemes.ml
index df4c0ebc..749e0d2b 100644
--- a/tactics/elimschemes.ml
+++ b/tactics/elimschemes.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -17,19 +17,21 @@ open Term
 open Indrec
 open Declarations
 open Typeops
-open Termops
 open Ind_tables
 
 (* Induction/recursion schemes *)
 
 let optimize_non_type_induction_scheme kind dep sort ind =
+  let env = Global.env () in
+  let sigma = Evd.from_env env in
   if check_scheme kind ind then
     (* in case the inductive has a type elimination, generates only one
        induction scheme, the other ones share the same code with the
        apropriate type *)
-    let cte = find_scheme kind ind in
-    let c = mkConst cte in
-    let t = type_of_constant (Global.env()) cte in
+    let cte, eff = find_scheme kind ind in
+    let sigma, cte = Evd.fresh_constant_instance env sigma cte in
+    let c = mkConstU cte in
+    let t = type_of_constant_in (Global.env()) cte in
     let (mib,mip) = Global.lookup_inductive ind in
     let npars =
       (* if a constructor of [ind] contains a recursive call, the scheme
@@ -39,28 +41,42 @@ let optimize_non_type_induction_scheme kind dep sort ind =
 	mib.mind_nparams_rec
       else
 	mib.mind_nparams in
-    snd (weaken_sort_scheme (new_sort_in_family sort) npars c t)
+    let sigma, sort = Evd.fresh_sort_in_family env sigma sort in
+    let sigma, t', c' = weaken_sort_scheme env sigma false sort npars c t in
+    let sigma, nf = Evarutil.nf_evars_and_universes sigma in
+      (nf c', Evd.evar_universe_context sigma), eff
   else
-    build_induction_scheme (Global.env()) Evd.empty ind dep sort
+    let mib,mip = Inductive.lookup_mind_specif env ind in
+    let ctx = Declareops.inductive_context mib in
+    let u = Univ.UContext.instance ctx in
+    let ctxset = Univ.ContextSet.of_context ctx in
+    let ectx = Evd.evar_universe_context_of ctxset in
+    let sigma, c = build_induction_scheme env (Evd.from_env ~ctx:ectx env) (ind,u) dep sort in
+      (c, Evd.evar_universe_context sigma), Declareops.no_seff
 
 let build_induction_scheme_in_type dep sort ind =
-  build_induction_scheme (Global.env()) Evd.empty ind dep sort
-
+  let env = Global.env () in
+  let ctx = 
+    let mib,mip = Inductive.lookup_mind_specif env ind in
+      Declareops.inductive_context mib
+  in
+  let u = Univ.UContext.instance ctx in
+  let ctxset = Univ.ContextSet.of_context ctx in
+  let ectx = Evd.evar_universe_context_of ctxset in
+  let sigma, c = build_induction_scheme env (Evd.from_env ~ctx:ectx env) (ind,u) dep sort in
+    c, Evd.evar_universe_context sigma
+ 
 let rect_scheme_kind_from_type =
   declare_individual_scheme_object "_rect_nodep"
-    (build_induction_scheme_in_type false InType)
+    (fun x -> build_induction_scheme_in_type false InType x, Declareops.no_seff)
 
 let rect_scheme_kind_from_prop =
   declare_individual_scheme_object "_rect" ~aux:"_rect_from_prop"
-    (build_induction_scheme_in_type false InType)
+    (fun x -> build_induction_scheme_in_type false InType x, Declareops.no_seff)
 
 let rect_dep_scheme_kind_from_type =
   declare_individual_scheme_object "_rect" ~aux:"_rect_from_type"
-    (build_induction_scheme_in_type true InType)
-
-let rect_dep_scheme_kind_from_prop =
-  declare_individual_scheme_object "_rect_dep"
-    (build_induction_scheme_in_type true InType)
+    (fun x -> build_induction_scheme_in_type true InType x, Declareops.no_seff)
 
 let ind_scheme_kind_from_type =
   declare_individual_scheme_object "_ind_nodep"
@@ -74,14 +90,6 @@ let ind_dep_scheme_kind_from_type =
   declare_individual_scheme_object "_ind" ~aux:"_ind_from_type"
   (optimize_non_type_induction_scheme rect_dep_scheme_kind_from_type true InProp)
 
-let ind_dep_scheme_kind_from_prop =
-  declare_individual_scheme_object "_ind_dep"
-  (optimize_non_type_induction_scheme rect_dep_scheme_kind_from_prop true InProp)
-
-let rec_scheme_kind_from_type =
-  declare_individual_scheme_object "_rec_nodep"
-  (optimize_non_type_induction_scheme rect_scheme_kind_from_type false InSet)
-
 let rec_scheme_kind_from_prop =
   declare_individual_scheme_object "_rec" ~aux:"_rec_from_prop"
   (optimize_non_type_induction_scheme rect_scheme_kind_from_prop false InSet)
@@ -90,35 +98,35 @@ let rec_dep_scheme_kind_from_type =
   declare_individual_scheme_object "_rec" ~aux:"_rec_from_type"
   (optimize_non_type_induction_scheme rect_dep_scheme_kind_from_type true InSet)
 
-let rec_dep_scheme_kind_from_prop =
-  declare_individual_scheme_object "_rec_dep"
-  (optimize_non_type_induction_scheme rect_dep_scheme_kind_from_prop true InSet)
-
 (* Case analysis *)
 
 let build_case_analysis_scheme_in_type dep sort ind =
-  build_case_analysis_scheme (Global.env()) Evd.empty ind dep sort
+  let env = Global.env () in
+  let sigma = Evd.from_env env in
+  let sigma, indu = Evd.fresh_inductive_instance env sigma ind in
+  let sigma, c = build_case_analysis_scheme env sigma indu dep sort in 
+    c, Evd.evar_universe_context sigma
 
 let case_scheme_kind_from_type =
   declare_individual_scheme_object "_case_nodep"
-  (build_case_analysis_scheme_in_type false InType)
+  (fun x -> build_case_analysis_scheme_in_type false InType x, Declareops.no_seff)
 
 let case_scheme_kind_from_prop =
   declare_individual_scheme_object "_case" ~aux:"_case_from_prop"
-  (build_case_analysis_scheme_in_type false InType)
+  (fun x -> build_case_analysis_scheme_in_type false InType x, Declareops.no_seff)
 
 let case_dep_scheme_kind_from_type =
   declare_individual_scheme_object "_case" ~aux:"_case_from_type"
-  (build_case_analysis_scheme_in_type true InType)
+  (fun x -> build_case_analysis_scheme_in_type true InType x, Declareops.no_seff)
 
 let case_dep_scheme_kind_from_type_in_prop =
   declare_individual_scheme_object "_casep_dep"
-  (build_case_analysis_scheme_in_type true InProp)
+  (fun x -> build_case_analysis_scheme_in_type true InProp x, Declareops.no_seff)
 
 let case_dep_scheme_kind_from_prop =
   declare_individual_scheme_object "_case_dep"
-  (build_case_analysis_scheme_in_type true InType)
+  (fun x -> build_case_analysis_scheme_in_type true InType x, Declareops.no_seff)
 
 let case_dep_scheme_kind_from_prop_in_prop =
   declare_individual_scheme_object "_casep"
-  (build_case_analysis_scheme_in_type true InProp)
+  (fun x -> build_case_analysis_scheme_in_type true InProp x, Declareops.no_seff)
diff --git a/tactics/elimschemes.mli b/tactics/elimschemes.mli
index c747b843..0b843b8f 100644
--- a/tactics/elimschemes.mli
+++ b/tactics/elimschemes.mli
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/tactics/eqdecide.ml b/tactics/eqdecide.ml
new file mode 100644
index 00000000..c2cd9e47
--- /dev/null
+++ b/tactics/eqdecide.ml
@@ -0,0 +1,212 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(************************************************************************)
+(*                              EqDecide                               *)
+(*   A tactic for deciding propositional equality on inductive types   *)
+(*                           by Eduardo Gimenez                        *)
+(************************************************************************)
+
+(*i camlp4deps: "grammar/grammar.cma" i*)
+
+open Errors
+open Util
+open Names
+open Namegen
+open Term
+open Declarations
+open Tactics
+open Tacticals.New
+open Auto
+open Constr_matching
+open Hipattern
+open Tacmach.New
+open Coqlib
+
+(* This file containts the implementation of the tactics ``Decide
+   Equality'' and ``Compare''. They can be used to decide the
+   propositional equality of two objects that belongs to a small
+   inductive datatype --i.e., an inductive set such that all the
+   arguments of its constructors are non-functional sets.
+
+   The procedure for proving (x,y:R){x=y}+{~x=y} can be scketched as
+   follows:
+   1. Eliminate x and then y.
+   2. Try discrimination to solve those goals where x and y has
+      been introduced by different constructors.
+   3. If x and y have been introduced by the same constructor,
+      then analyse one by one the corresponding pairs of arguments.
+      If they are equal, rewrite one into the other. If they are
+      not, derive a contradiction from the injectiveness of the
+      constructor.
+   4. Once all the arguments have been rewritten, solve the remaining half
+      of the disjunction by reflexivity.
+
+   Eduardo Gimenez (30/3/98).
+*)
+
+let clear ids = Proofview.V82.tactic (clear ids)
+let clear_last = (onLastHyp (fun c -> (clear [destVar c])))
+
+let choose_eq eqonleft =
+  if eqonleft then
+    left_with_bindings false Misctypes.NoBindings
+  else
+    right_with_bindings false Misctypes.NoBindings
+let choose_noteq eqonleft =
+  if eqonleft then
+    right_with_bindings false Misctypes.NoBindings
+  else
+    left_with_bindings false Misctypes.NoBindings
+
+let mkBranches c1 c2 =
+  tclTHENLIST
+    [Proofview.V82.tactic (generalize [c2]);
+     Simple.elim c1;
+     intros;
+     onLastHyp Simple.case;
+     clear_last;
+     intros]
+
+let solveNoteqBranch side =
+  tclTHEN (choose_noteq side)
+    (tclTHEN introf
+      (onLastHypId (fun id -> Extratactics.discrHyp id)))
+
+(* Constructs the type {c1=c2}+{~c1=c2} *)
+
+let make_eq () =
+(*FIXME*) Universes.constr_of_global (Coqlib.build_coq_eq ())
+
+let mkDecideEqGoal eqonleft op rectype c1 c2 =
+  let equality    = mkApp(make_eq(), [|rectype; c1; c2|]) in
+  let disequality = mkApp(build_coq_not (), [|equality|]) in
+  if eqonleft then mkApp(op, [|equality; disequality |])
+  else mkApp(op, [|disequality; equality |])
+
+
+(* Constructs the type (x1,x2:R){x1=x2}+{~x1=x2} *)
+
+let idx = Id.of_string "x"
+let idy = Id.of_string "y"
+
+let mkGenDecideEqGoal rectype g =
+  let hypnames = pf_ids_of_hyps g in
+  let xname    = next_ident_away idx hypnames
+  and yname    = next_ident_away idy hypnames in
+  (mkNamedProd xname rectype
+     (mkNamedProd yname rectype
+        (mkDecideEqGoal true (build_coq_sumbool ())
+          rectype (mkVar xname) (mkVar yname))))
+
+let eqCase tac =
+  (tclTHEN intro
+  (tclTHEN (onLastHyp Equality.rewriteLR)
+  (tclTHEN clear_last
+  tac)))
+
+let diseqCase eqonleft =
+  let diseq  = Id.of_string "diseq" in
+  let absurd = Id.of_string "absurd" in
+  (tclTHEN (intro_using diseq)
+  (tclTHEN (choose_noteq eqonleft)
+  (tclTHEN  (Proofview.V82.tactic red_in_concl)
+  (tclTHEN  (intro_using absurd)
+  (tclTHEN  (Simple.apply (mkVar diseq))
+  (tclTHEN  (Extratactics.injHyp absurd)
+            (full_trivial [])))))))
+
+open Proofview.Notations
+
+(* spiwack: a small wrapper around [Hipattern]. *)
+
+let match_eqdec c =
+  try Proofview.tclUNIT (match_eqdec c)
+  with PatternMatchingFailure -> Proofview.tclZERO PatternMatchingFailure
+
+(* /spiwack *)
+
+let solveArg eqonleft op a1 a2 tac =
+  Proofview.Goal.enter begin fun gl ->
+  let rectype = pf_type_of gl a1 in
+  let decide = mkDecideEqGoal eqonleft op rectype a1 a2 in
+  let subtacs =
+    if eqonleft then [eqCase tac;diseqCase eqonleft;default_auto]
+    else [diseqCase eqonleft;eqCase tac;default_auto] in
+  (tclTHENS (elim_type decide) subtacs)
+  end
+
+let solveEqBranch rectype =
+  Proofview.tclORELSE
+    begin
+      Proofview.Goal.enter begin fun gl ->
+        let concl = pf_nf_concl gl in
+        match_eqdec concl >>= fun (eqonleft,op,lhs,rhs,_) ->
+          let (mib,mip) = Global.lookup_inductive rectype in
+          let nparams   = mib.mind_nparams in
+          let getargs l = List.skipn nparams (snd (decompose_app l)) in
+          let rargs   = getargs rhs
+          and largs   = getargs lhs in
+          List.fold_right2
+            (solveArg eqonleft op) largs rargs
+            (tclTHEN (choose_eq eqonleft) intros_reflexivity)
+      end
+    end
+    begin function (e, info) -> match e with
+      | PatternMatchingFailure -> Proofview.tclZERO (UserError ("",Pp.str"Unexpected conclusion!"))
+      | e -> Proofview.tclZERO ~info e
+    end
+
+(* The tactic Decide Equality *)
+
+let hd_app c = match kind_of_term c with
+  | App (h,_) -> h
+  | _ -> c
+
+let decideGralEquality =
+  Proofview.tclORELSE
+    begin
+      Proofview.Goal.enter begin fun gl ->
+        let concl = pf_nf_concl gl in
+        match_eqdec concl >>= fun (eqonleft,_,c1,c2,typ) ->
+        let headtyp = hd_app (pf_compute gl typ) in
+        begin match kind_of_term headtyp with
+        | Ind (mi,_) -> Proofview.tclUNIT mi
+        | _ -> tclZEROMSG (Pp.str"This decision procedure only works for inductive objects.")
+        end >>= fun rectype ->
+          (tclTHEN
+             (mkBranches c1 c2)
+             (tclORELSE (solveNoteqBranch eqonleft) (solveEqBranch rectype)))
+      end
+    end
+    begin function (e, info) -> match e with
+      | PatternMatchingFailure ->
+          Proofview.tclZERO (UserError ("", Pp.str"The goal must be of the form {x<>y}+{x=y} or {x=y}+{x<>y}."))
+      | e -> Proofview.tclZERO ~info e
+    end
+
+let decideEqualityGoal = tclTHEN intros decideGralEquality
+
+let decideEquality rectype =
+  Proofview.Goal.enter begin fun gl ->
+  let decide = mkGenDecideEqGoal rectype gl in
+  (tclTHENS (cut decide) [default_auto;decideEqualityGoal])
+  end
+
+
+(* The tactic Compare *)
+
+let compare c1 c2 =
+  Proofview.Goal.enter begin fun gl ->
+  let rectype = pf_type_of gl c1 in
+  let decide = mkDecideEqGoal true (build_coq_sumbool ()) rectype c1 c2 in
+  (tclTHENS (cut decide)
+            [(tclTHEN  intro
+             (tclTHEN (onLastHyp simplest_case) clear_last));
+             decideEquality rectype])
+  end
diff --git a/tactics/eqdecide.ml4 b/tactics/eqdecide.ml4
deleted file mode 100644
index 4a11d586..00000000
--- a/tactics/eqdecide.ml4
+++ /dev/null
@@ -1,188 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(************************************************************************)
-(*                              EqDecide                               *)
-(*   A tactic for deciding propositional equality on inductive types   *)
-(*                           by Eduardo Gimenez                        *)
-(************************************************************************)
-
-(*i camlp4deps: "parsing/grammar.cma" i*)
-
-open Util
-open Names
-open Namegen
-open Term
-open Declarations
-open Tactics
-open Tacticals
-open Hiddentac
-open Equality
-open Auto
-open Pattern
-open Matching
-open Hipattern
-open Proof_type
-open Tacmach
-open Coqlib
-
-(* This file containts the implementation of the tactics ``Decide
-   Equality'' and ``Compare''. They can be used to decide the
-   propositional equality of two objects that belongs to a small
-   inductive datatype --i.e., an inductive set such that all the
-   arguments of its constructors are non-functional sets.
-
-   The procedure for proving (x,y:R){x=y}+{~x=y} can be scketched as
-   follows:
-   1. Eliminate x and then y.
-   2. Try discrimination to solve those goals where x and y has
-      been introduced by different constructors.
-   3. If x and y have been introduced by the same constructor,
-      then analyse one by one the corresponding pairs of arguments.
-      If they are equal, rewrite one into the other. If they are
-      not, derive a contradiction from the injectiveness of the
-      constructor.
-   4. Once all the arguments have been rewritten, solve the remaining half
-      of the disjunction by reflexivity.
-
-   Eduardo Gimenez (30/3/98).
-*)
-
-let clear_last = (onLastHyp (fun c -> (clear [destVar c])))
-
-let choose_eq eqonleft =
-  if eqonleft then h_simplest_left else h_simplest_right
-let choose_noteq eqonleft =
-  if eqonleft then h_simplest_right else h_simplest_left
-
-let mkBranches c1 c2 =
-  tclTHENSEQ
-    [generalize [c2];
-     h_simplest_elim c1;
-     intros;
-     onLastHyp h_simplest_case;
-     clear_last;
-     intros]
-
-let solveNoteqBranch side =
-  tclTHEN (choose_noteq side)
-    (tclTHEN introf
-      (onLastHypId (fun id -> Extratactics.h_discrHyp id)))
-
-let h_solveNoteqBranch side =
-  Refiner.abstract_extended_tactic "solveNoteqBranch" []
-    (solveNoteqBranch side)
-
-(* Constructs the type {c1=c2}+{~c1=c2} *)
-
-let mkDecideEqGoal eqonleft op rectype c1 c2 g =
-  let equality    = mkApp(build_coq_eq(), [|rectype; c1; c2|]) in
-  let disequality = mkApp(build_coq_not (), [|equality|]) in
-  if eqonleft then mkApp(op, [|equality; disequality |])
-  else mkApp(op, [|disequality; equality |])
-
-
-(* Constructs the type (x1,x2:R){x1=x2}+{~x1=x2} *)
-
-let mkGenDecideEqGoal rectype g =
-  let hypnames = pf_ids_of_hyps g in
-  let xname    = next_ident_away (id_of_string "x") hypnames
-  and yname    = next_ident_away (id_of_string "y") hypnames in
-  (mkNamedProd xname rectype
-     (mkNamedProd yname rectype
-        (mkDecideEqGoal true (build_coq_sumbool ())
-          rectype (mkVar xname) (mkVar yname) g)))
-
-let eqCase tac =
-  (tclTHEN intro
-  (tclTHEN (onLastHyp Equality.rewriteLR)
-  (tclTHEN clear_last
-  tac)))
-
-let diseqCase eqonleft =
-  let diseq  = id_of_string "diseq" in
-  let absurd = id_of_string "absurd" in
-  (tclTHEN (intro_using diseq)
-  (tclTHEN (choose_noteq eqonleft)
-  (tclTHEN  red_in_concl
-  (tclTHEN  (intro_using absurd)
-  (tclTHEN  (h_simplest_apply (mkVar diseq))
-  (tclTHEN  (Extratactics.h_injHyp absurd)
-            (full_trivial [])))))))
-
-let solveArg eqonleft op a1 a2 tac g =
-  let rectype = pf_type_of g a1 in
-  let decide  = mkDecideEqGoal eqonleft op rectype a1 a2 g in
-  let subtacs =
-    if eqonleft then [eqCase tac;diseqCase eqonleft;default_auto]
-    else [diseqCase eqonleft;eqCase tac;default_auto] in
-  (tclTHENS (h_elim_type decide) subtacs) g
-
-let solveEqBranch rectype g =
-  try
-    let (eqonleft,op,lhs,rhs,_) = match_eqdec (pf_concl g) in
-    let (mib,mip) = Global.lookup_inductive rectype in
-    let nparams   = mib.mind_nparams in
-    let getargs l = list_skipn nparams (snd (decompose_app l)) in
-    let rargs   = getargs rhs
-    and largs   = getargs lhs in
-    List.fold_right2
-      (solveArg eqonleft op) largs rargs
-      (tclTHEN (choose_eq eqonleft) h_reflexivity) g
-  with PatternMatchingFailure -> error "Unexpected conclusion!"
-
-(* The tactic Decide Equality *)
-
-let hd_app c = match kind_of_term c with
-  | App (h,_) -> h
-  | _ -> c
-
-let decideGralEquality g =
-  try
-    let eqonleft,_,c1,c2,typ = match_eqdec (pf_concl g) in
-    let headtyp = hd_app (pf_compute g typ) in
-    let rectype =
-      match kind_of_term headtyp with
-        | Ind mi -> mi
-	| _ -> error"This decision procedure only works for inductive objects."
-    in
-    (tclTHEN
-      (mkBranches c1 c2)
-      (tclORELSE (h_solveNoteqBranch eqonleft) (solveEqBranch rectype)))
-    g
-  with PatternMatchingFailure ->
-    error "The goal must be of the form {x<>y}+{x=y} or {x=y}+{x<>y}."
-
-let decideEqualityGoal = tclTHEN intros decideGralEquality
-
-let decideEquality rectype g =
-  let decide  = mkGenDecideEqGoal rectype g in
-  (tclTHENS (cut decide) [default_auto;decideEqualityGoal]) g
-
-
-(* The tactic Compare *)
-
-let compare c1 c2 g =
-  let rectype = pf_type_of g c1 in
-  let decide  = mkDecideEqGoal true (build_coq_sumbool ()) rectype c1 c2 g in
-  (tclTHENS (cut decide)
-            [(tclTHEN  intro
-             (tclTHEN (onLastHyp simplest_case)
-                       clear_last));
-             decideEquality (pf_type_of g c1)]) g
-
-
-(* User syntax *)
-
-TACTIC EXTEND decide_equality
-| [ "decide" "equality" ] -> [ decideEqualityGoal ]
-END
-
-TACTIC EXTEND compare
-| [ "compare" constr(c1) constr(c2) ] -> [ compare c1 c2 ]
-END
diff --git a/tactics/refine.mli b/tactics/eqdecide.mli
index 47c00983..864160f6 100644
--- a/tactics/refine.mli
+++ b/tactics/eqdecide.mli
@@ -1,11 +1,17 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-open Tacmach
+(************************************************************************)
+(*                              EqDecide                               *)
+(*   A tactic for deciding propositional equality on inductive types   *)
+(*                           by Eduardo Gimenez                        *)
+(************************************************************************)
+
+val decideEqualityGoal : unit Proofview.tactic
 
-val refine : Evd.open_constr -> tactic
+val compare : Constr.t -> Constr.t -> unit Proofview.tactic
diff --git a/tactics/eqschemes.ml b/tactics/eqschemes.ml
index 5a8d537e..8643fe10 100644
--- a/tactics/eqschemes.ml
+++ b/tactics/eqschemes.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -44,9 +44,12 @@
    natural expectation of the user.
 *)
 
+open Errors
 open Util
 open Names
 open Term
+open Vars
+open Context
 open Declarations
 open Environ
 open Inductive
@@ -56,16 +59,18 @@ open Inductiveops
 open Ind_tables
 open Indrec
 
-let hid = id_of_string "H"
-let xid = id_of_string "X"
+let hid = Id.of_string "H"
+let xid = Id.of_string "X"
 let default_id_of_sort = function InProp | InSet -> hid | InType -> xid
 let fresh env id = next_global_ident_away id []
+let with_context_set ctx (b, ctx') = 
+  (b, Univ.ContextSet.union ctx ctx')
 
 let build_dependent_inductive ind (mib,mip) =
-  let realargs,_ = list_chop mip.mind_nrealargs_ctxt mip.mind_arity_ctxt in
+  let realargs,_ = List.chop mip.mind_nrealdecls mip.mind_arity_ctxt in
   applist
-    (mkInd ind,
-       extended_rel_list mip.mind_nrealargs_ctxt mib.mind_params_ctxt
+    (mkIndU ind,
+       extended_rel_list mip.mind_nrealdecls mib.mind_params_ctxt
        @ extended_rel_list 0 realargs)
 
 let my_it_mkLambda_or_LetIn s c = it_mkLambda_or_LetIn c s
@@ -73,12 +78,13 @@ let my_it_mkProd_or_LetIn s c = it_mkProd_or_LetIn c s
 let my_it_mkLambda_or_LetIn_name s c =
   it_mkLambda_or_LetIn_name (Global.env()) c s
 
-let get_coq_eq () =
+let get_coq_eq ctx =
   try
-    let eq = Libnames.destIndRef Coqlib.glob_eq in
-    let _ = Global.lookup_inductive eq in
+    let eq = Globnames.destIndRef Coqlib.glob_eq in
     (* Do not force the lazy if they are not defined *)
-    mkInd eq, Coqlib.build_coq_eq_refl ()
+    let eq, ctx = with_context_set ctx 
+      (Universes.fresh_inductive_instance (Global.env ()) eq) in
+      mkIndU eq, mkConstructUi (eq,1), ctx
   with Not_found ->
     error "eq not found."
 
@@ -91,27 +97,30 @@ let get_coq_eq () =
 (* in which case, a symmetry lemma is definable                       *)
 (**********************************************************************)
 
-let get_sym_eq_data env ind =
+let get_sym_eq_data env (ind,u) =
   let (mib,mip as specif) = lookup_mind_specif env ind in
-  if Array.length mib.mind_packets <> 1 or Array.length mip.mind_nf_lc <> 1 then
+  if not (Int.equal (Array.length mib.mind_packets) 1) ||
+    not (Int.equal (Array.length mip.mind_nf_lc) 1) then
     error "Not an inductive type with a single constructor.";
-  let realsign,_ = list_chop mip.mind_nrealargs_ctxt mip.mind_arity_ctxt in
-  if List.exists (fun (_,b,_) -> b <> None) realsign then
+  let arityctxt = Vars.subst_instance_context u mip.mind_arity_ctxt in
+  let realsign,_ = List.chop mip.mind_nrealdecls arityctxt in
+  if List.exists (fun (_,b,_) -> not (Option.is_empty b)) realsign then
     error "Inductive equalities with local definitions in arity not supported.";
   let constrsign,ccl = decompose_prod_assum mip.mind_nf_lc.(0) in
   let _,constrargs = decompose_app ccl in
-  if rel_context_length constrsign<>rel_context_length mib.mind_params_ctxt then
+  if not (Int.equal (rel_context_length constrsign) (rel_context_length mib.mind_params_ctxt)) then
     error "Constructor must have no arguments"; (* This can be relaxed... *)
-  let params,constrargs = list_chop mib.mind_nparams constrargs in
+  let params,constrargs = List.chop mib.mind_nparams constrargs in
   if mip.mind_nrealargs > mib.mind_nparams then
     error "Constructors arguments must repeat the parameters.";
-  let _,params2 = list_chop (mib.mind_nparams-mip.mind_nrealargs) params in
+  let _,params2 = List.chop (mib.mind_nparams-mip.mind_nrealargs) params in
+  let paramsctxt = Vars.subst_instance_context u mib.mind_params_ctxt in
   let paramsctxt1,_ =
-    list_chop (mib.mind_nparams-mip.mind_nrealargs) mib.mind_params_ctxt in
-  if not (list_equal eq_constr params2 constrargs) then
+    List.chop (mib.mind_nparams-mip.mind_nrealargs) paramsctxt in
+  if not (List.equal eq_constr params2 constrargs) then
     error "Constructors arguments must repeat the parameters.";
   (* nrealargs_ctxt and nrealargs are the same here *)
-  (specif,mip.mind_nrealargs,realsign,mib.mind_params_ctxt,paramsctxt1)
+  (specif,mip.mind_nrealargs,realsign,paramsctxt,paramsctxt1)
 
 (**********************************************************************)
 (* Check if an inductive type [ind] has the form                      *)
@@ -123,19 +132,23 @@ let get_sym_eq_data env ind =
 (* such that symmetry is a priori definable                           *)
 (**********************************************************************)
 
-let get_non_sym_eq_data env ind =
+let get_non_sym_eq_data env (ind,u) =
   let (mib,mip as specif) = lookup_mind_specif env ind in
-  if Array.length mib.mind_packets <> 1 or Array.length mip.mind_nf_lc <> 1 then
+  if not (Int.equal (Array.length mib.mind_packets) 1) ||
+    not (Int.equal (Array.length mip.mind_nf_lc) 1) then
     error "Not an inductive type with a single constructor.";
-  let realsign,_ = list_chop mip.mind_nrealargs_ctxt mip.mind_arity_ctxt in
-  if List.exists (fun (_,b,_) -> b <> None) realsign then
+  let arityctxt = Vars.subst_instance_context u mip.mind_arity_ctxt in
+  let realsign,_ = List.chop mip.mind_nrealdecls arityctxt in
+  if List.exists (fun (_,b,_) -> not (Option.is_empty b)) realsign then
     error "Inductive equalities with local definitions in arity not supported";
   let constrsign,ccl = decompose_prod_assum mip.mind_nf_lc.(0) in
   let _,constrargs = decompose_app ccl in
-  if rel_context_length constrsign<>rel_context_length mib.mind_params_ctxt then
+  if not (Int.equal (rel_context_length constrsign) (rel_context_length mib.mind_params_ctxt)) then
     error "Constructor must have no arguments";
-  let _,constrargs = list_chop mib.mind_nparams constrargs in
-  (specif,constrargs,realsign,mip.mind_nrealargs)
+  let _,constrargs = List.chop mib.mind_nparams constrargs in
+  let constrargs = List.map (Vars.subst_instance_constr u) constrargs in
+  let paramsctxt = Vars.subst_instance_context u mib.mind_params_ctxt in
+  (specif,constrargs,realsign,paramsctxt,mip.mind_nrealargs)
 
 (**********************************************************************)
 (* Build the symmetry lemma associated to an inductive type           *)
@@ -152,30 +165,35 @@ let get_non_sym_eq_data env ind =
 (**********************************************************************)
 
 let build_sym_scheme env ind =
+  let (ind,u as indu), ctx = Universes.fresh_inductive_instance env ind in
   let (mib,mip as specif),nrealargs,realsign,paramsctxt,paramsctxt1 =
-    get_sym_eq_data env ind in
+    get_sym_eq_data env indu in
   let cstr n =
-    mkApp (mkConstruct(ind,1),extended_rel_vect n mib.mind_params_ctxt) in
+    mkApp (mkConstructUi(indu,1),extended_rel_vect n mib.mind_params_ctxt) in
   let varH = fresh env (default_id_of_sort (snd (mind_arity mip))) in
-  let applied_ind = build_dependent_inductive ind specif in
+  let applied_ind = build_dependent_inductive indu specif in
   let realsign_ind =
     name_context env ((Name varH,None,applied_ind)::realsign) in
   let ci = make_case_info (Global.env()) ind RegularStyle in
+  let c = 
   (my_it_mkLambda_or_LetIn mib.mind_params_ctxt
   (my_it_mkLambda_or_LetIn_name realsign_ind
   (mkCase (ci,
      my_it_mkLambda_or_LetIn_name
        (lift_rel_context (nrealargs+1) realsign_ind)
-       (mkApp (mkInd ind,Array.concat
+       (mkApp (mkIndU indu,Array.concat
 	  [extended_rel_vect (3*nrealargs+2) paramsctxt1;
 	   rel_vect 1 nrealargs;
 	   rel_vect (2*nrealargs+2) nrealargs])),
      mkRel 1 (* varH *),
        [|cstr (nrealargs+1)|]))))
+  in c, Evd.evar_universe_context_of ctx
 
 let sym_scheme_kind =
   declare_individual_scheme_object "_sym_internal"
-  (fun ind -> build_sym_scheme (Global.env() (* side-effect! *)) ind)
+  (fun ind -> 
+    let c, ctx = build_sym_scheme (Global.env() (* side-effect! *)) ind in
+      (c, ctx), Declareops.no_seff)
 
 (**********************************************************************)
 (* Build the involutivity of symmetry for an inductive type           *)
@@ -193,49 +211,59 @@ let sym_scheme_kind =
 (*                                                                    *)
 (**********************************************************************)
 
+let const_of_scheme kind env ind ctx = 
+  let sym_scheme, eff = (find_scheme kind ind) in
+  let sym, ctx = with_context_set ctx 
+    (Universes.fresh_constant_instance (Global.env()) sym_scheme) in
+    mkConstU sym, ctx, eff
+
 let build_sym_involutive_scheme env ind =
+  let (ind,u as indu), ctx = Universes.fresh_inductive_instance env ind in
   let (mib,mip as specif),nrealargs,realsign,paramsctxt,paramsctxt1 =
-    get_sym_eq_data env ind in
-  let sym = mkConst (find_scheme sym_scheme_kind ind) in
-  let (eq,eqrefl) = get_coq_eq () in
-  let cstr n = mkApp (mkConstruct(ind,1),extended_rel_vect n paramsctxt) in
+    get_sym_eq_data env indu in
+  let eq,eqrefl,ctx = get_coq_eq ctx in
+  let sym, ctx, eff = const_of_scheme sym_scheme_kind env ind ctx in
+  let cstr n = mkApp (mkConstructUi (indu,1),extended_rel_vect n paramsctxt) in
   let varH = fresh env (default_id_of_sort (snd (mind_arity mip))) in
-  let applied_ind = build_dependent_inductive ind specif in
+  let applied_ind = build_dependent_inductive indu specif in
   let applied_ind_C =
     mkApp
-      (mkInd ind, Array.append
+      (mkIndU indu, Array.append
          (extended_rel_vect (nrealargs+1) mib.mind_params_ctxt)
          (rel_vect (nrealargs+1) nrealargs)) in
   let realsign_ind =
     name_context env ((Name varH,None,applied_ind)::realsign) in
   let ci = make_case_info (Global.env()) ind RegularStyle in
-  (my_it_mkLambda_or_LetIn paramsctxt
-  (my_it_mkLambda_or_LetIn_name realsign_ind
-  (mkCase (ci,
-     my_it_mkLambda_or_LetIn_name
-       (lift_rel_context (nrealargs+1) realsign_ind)
-       (mkApp (eq,[|
-	 mkApp
-	   (mkInd ind, Array.concat
-	     [extended_rel_vect (3*nrealargs+2) paramsctxt1;
-	      rel_vect (2*nrealargs+2) nrealargs;
-	      rel_vect 1 nrealargs]);
-         mkApp (sym,Array.concat
-	   [extended_rel_vect (3*nrealargs+2) paramsctxt1;
-            rel_vect 1 nrealargs;
-            rel_vect (2*nrealargs+2) nrealargs;
-            [|mkApp (sym,Array.concat
-	      [extended_rel_vect (3*nrealargs+2) paramsctxt1;
-	       rel_vect (2*nrealargs+2) nrealargs;
-	       rel_vect 1 nrealargs;
-	       [|mkRel 1|]])|]]);
-	 mkRel 1|])),
-     mkRel 1 (* varH *),
-       [|mkApp(eqrefl,[|applied_ind_C;cstr (nrealargs+1)|])|]))))
+  let c = 
+    (my_it_mkLambda_or_LetIn paramsctxt
+     (my_it_mkLambda_or_LetIn_name realsign_ind
+      (mkCase (ci,
+	       my_it_mkLambda_or_LetIn_name
+	       (lift_rel_context (nrealargs+1) realsign_ind)
+	       (mkApp (eq,[|
+	       mkApp
+	       (mkIndU indu, Array.concat
+	       [extended_rel_vect (3*nrealargs+2) paramsctxt1;
+		rel_vect (2*nrealargs+2) nrealargs;
+		rel_vect 1 nrealargs]);
+               mkApp (sym,Array.concat
+	       [extended_rel_vect (3*nrealargs+2) paramsctxt1;
+		rel_vect 1 nrealargs;
+		rel_vect (2*nrealargs+2) nrealargs;
+		[|mkApp (sym,Array.concat
+		[extended_rel_vect (3*nrealargs+2) paramsctxt1;
+		 rel_vect (2*nrealargs+2) nrealargs;
+		 rel_vect 1 nrealargs;
+		 [|mkRel 1|]])|]]);
+	       mkRel 1|])),
+	       mkRel 1 (* varH *),
+	       [|mkApp(eqrefl,[|applied_ind_C;cstr (nrealargs+1)|])|]))))
+  in (c, Evd.evar_universe_context_of ctx), eff
 
 let sym_involutive_scheme_kind =
   declare_individual_scheme_object "_sym_involutive"
-  (fun ind -> build_sym_involutive_scheme (Global.env() (* side-effect! *)) ind)
+  (fun ind -> 
+    build_sym_involutive_scheme (Global.env() (* side-effect! *)) ind)
 
 (**********************************************************************)
 (* Build the left-to-right rewriting lemma for conclusion associated  *)
@@ -298,26 +326,27 @@ let sym_involutive_scheme_kind =
 (**********************************************************************)
 
 let build_l2r_rew_scheme dep env ind kind =
+  let (ind,u as indu), ctx = Universes.fresh_inductive_instance env ind in
   let (mib,mip as specif),nrealargs,realsign,paramsctxt,paramsctxt1 =
-    get_sym_eq_data env ind in
-  let sym = mkConst (find_scheme sym_scheme_kind ind) in
-  let sym_involutive = mkConst (find_scheme sym_involutive_scheme_kind ind) in
-  let (eq,eqrefl) = get_coq_eq () in
+    get_sym_eq_data env indu in
+  let sym, ctx, eff = const_of_scheme sym_scheme_kind env ind ctx in
+  let sym_involutive, ctx, eff' = const_of_scheme sym_involutive_scheme_kind env ind ctx in
+  let eq,eqrefl,ctx = get_coq_eq ctx in
   let cstr n p =
-    mkApp (mkConstruct(ind,1),
+    mkApp (mkConstructUi(indu,1),
       Array.concat [extended_rel_vect n paramsctxt1;
                     rel_vect p nrealargs]) in
   let varH = fresh env (default_id_of_sort (snd (mind_arity mip))) in
-  let varHC = fresh env (id_of_string "HC") in
-  let varP = fresh env (id_of_string "P") in
-  let applied_ind = build_dependent_inductive ind specif in
+  let varHC = fresh env (Id.of_string "HC") in
+  let varP = fresh env (Id.of_string "P") in
+  let applied_ind = build_dependent_inductive indu specif in
   let applied_ind_P =
-    mkApp (mkInd ind, Array.concat
+    mkApp (mkIndU indu, Array.concat
        [extended_rel_vect (3*nrealargs) paramsctxt1;
         rel_vect 0 nrealargs;
         rel_vect nrealargs nrealargs]) in
   let applied_ind_G =
-    mkApp (mkInd ind, Array.concat
+    mkApp (mkIndU indu, Array.concat
        [extended_rel_vect (3*nrealargs+3) paramsctxt1;
         rel_vect (nrealargs+3) nrealargs;
         rel_vect 0 nrealargs]) in
@@ -336,9 +365,11 @@ let build_l2r_rew_scheme dep env ind kind =
                      rel_vect (nrealargs+4) nrealargs;
                      rel_vect 1 nrealargs;
 		     [|mkRel 1|]]) in
-  let s = mkSort (new_sort_in_family kind) in
+  let s, ctx' = Universes.fresh_sort_in_family (Global.env ()) kind in
+  let ctx = Univ.ContextSet.union ctx ctx' in
+  let s = mkSort s in
   let ci = make_case_info (Global.env()) ind RegularStyle in
-  let cieq = make_case_info (Global.env()) (destInd eq) RegularStyle in
+  let cieq = make_case_info (Global.env()) (fst (destInd eq)) RegularStyle in
   let applied_PC =
     mkApp (mkVar varP,Array.append (extended_rel_vect 1 realsign)
            (if dep then [|cstr (2*nrealargs+1) 1|] else [||])) in
@@ -363,6 +394,7 @@ let build_l2r_rew_scheme dep env ind kind =
       my_it_mkLambda_or_LetIn_name realsign_ind_G applied_PG,
       applied_sym_C 3,
       [|mkVar varHC|]) in
+  let c = 
   (my_it_mkLambda_or_LetIn mib.mind_params_ctxt
   (my_it_mkLambda_or_LetIn_name realsign
   (mkNamedLambda varP
@@ -380,6 +412,7 @@ let build_l2r_rew_scheme dep env ind kind =
        [|main_body|])
    else
      main_body))))))
+  in (c, Evd.evar_universe_context_of ctx), Declareops.union_side_effects eff' eff
 
 (**********************************************************************)
 (* Build the left-to-right rewriting lemma for hypotheses associated  *)
@@ -408,23 +441,24 @@ let build_l2r_rew_scheme dep env ind kind =
 (**********************************************************************)
 
 let build_l2r_forward_rew_scheme dep env ind kind =
+  let (ind,u as indu), ctx = Universes.fresh_inductive_instance env ind in
   let (mib,mip as specif),nrealargs,realsign,paramsctxt,paramsctxt1 =
-    get_sym_eq_data env ind in
+    get_sym_eq_data env indu in
   let cstr n p =
-    mkApp (mkConstruct(ind,1),
+    mkApp (mkConstructUi(indu,1),
       Array.concat [extended_rel_vect n paramsctxt1;
                     rel_vect p nrealargs]) in
   let varH = fresh env (default_id_of_sort (snd (mind_arity mip))) in
-  let varHC = fresh env (id_of_string "HC") in
-  let varP = fresh env (id_of_string "P") in
-  let applied_ind = build_dependent_inductive ind specif in
+  let varHC = fresh env (Id.of_string "HC") in
+  let varP = fresh env (Id.of_string "P") in
+  let applied_ind = build_dependent_inductive indu specif in
   let applied_ind_P =
-    mkApp (mkInd ind, Array.concat
+    mkApp (mkIndU indu, Array.concat
        [extended_rel_vect (4*nrealargs+2) paramsctxt1;
         rel_vect 0 nrealargs;
         rel_vect (nrealargs+1) nrealargs]) in
   let applied_ind_P' =
-    mkApp (mkInd ind, Array.concat
+    mkApp (mkIndU indu, Array.concat
        [extended_rel_vect (3*nrealargs+1) paramsctxt1;
         rel_vect 0 nrealargs;
         rel_vect (2*nrealargs+1) nrealargs]) in
@@ -433,7 +467,9 @@ let build_l2r_forward_rew_scheme dep env ind kind =
     name_context env ((Name varH,None,applied_ind)::realsign) in
   let realsign_ind_P n aP =
     name_context env ((Name varH,None,aP)::realsign_P n) in
-  let s = mkSort (new_sort_in_family kind) in
+  let s, ctx' = Universes.fresh_sort_in_family (Global.env ()) kind in
+  let ctx = Univ.ContextSet.union ctx ctx' in
+  let s = mkSort s in
   let ci = make_case_info (Global.env()) ind RegularStyle in
   let applied_PC =
     mkApp (mkVar varP,Array.append
@@ -447,6 +483,7 @@ let build_l2r_forward_rew_scheme dep env ind kind =
   let applied_PG =
     mkApp (mkVar varP,Array.append (rel_vect 3 nrealargs)
            (if dep then [|cstr (3*nrealargs+4) 3|] else [||])) in
+  let c = 
   (my_it_mkLambda_or_LetIn mib.mind_params_ctxt
   (my_it_mkLambda_or_LetIn_name realsign
   (mkNamedLambda varH applied_ind
@@ -463,6 +500,7 @@ let build_l2r_forward_rew_scheme dep env ind kind =
 	  (if dep then realsign_ind_P 1 applied_ind_P' else realsign_P 2) s)
       (mkNamedLambda varHC applied_PC'
 	(mkVar varHC))|])))))
+  in c, Evd.evar_universe_context_of ctx
 
 (**********************************************************************)
 (* Build the right-to-left rewriting lemma for hypotheses associated  *)
@@ -494,19 +532,22 @@ let build_l2r_forward_rew_scheme dep env ind kind =
 (* statement but no need for symmetry of the equality.                *)
 (**********************************************************************)
 
-let build_r2l_forward_rew_scheme dep env ind kind =
-  let ((mib,mip as specif),constrargs,realsign,nrealargs) =
-    get_non_sym_eq_data env ind in
+let build_r2l_forward_rew_scheme dep env ind kind = 
+  let (ind,u as indu), ctx = Universes.fresh_inductive_instance env ind in
+  let ((mib,mip as specif),constrargs,realsign,paramsctxt,nrealargs) =
+    get_non_sym_eq_data env indu in
   let cstr n =
-    mkApp (mkConstruct(ind,1),extended_rel_vect n mib.mind_params_ctxt) in
+    mkApp (mkConstructUi(indu,1),extended_rel_vect n mib.mind_params_ctxt) in
   let constrargs_cstr = constrargs@[cstr 0] in
   let varH = fresh env (default_id_of_sort (snd (mind_arity mip))) in
-  let varHC = fresh env (id_of_string "HC") in
-  let varP = fresh env (id_of_string "P") in
-  let applied_ind = build_dependent_inductive ind specif in
+  let varHC = fresh env (Id.of_string "HC") in
+  let varP = fresh env (Id.of_string "P") in
+  let applied_ind = build_dependent_inductive indu specif in
   let realsign_ind =
     name_context env ((Name varH,None,applied_ind)::realsign) in
-  let s = mkSort (new_sort_in_family kind) in
+  let s, ctx' = Universes.fresh_sort_in_family (Global.env ()) kind in
+  let ctx = Univ.ContextSet.union ctx ctx' in
+  let s = mkSort s in
   let ci = make_case_info (Global.env()) ind RegularStyle in
   let applied_PC =
     applist (mkVar varP,if dep then constrargs_cstr else constrargs) in
@@ -514,7 +555,8 @@ let build_r2l_forward_rew_scheme dep env ind kind =
     mkApp (mkVar varP,
            if dep then extended_rel_vect 0 realsign_ind
 	   else extended_rel_vect 1 realsign) in
-  (my_it_mkLambda_or_LetIn mib.mind_params_ctxt
+  let c = 
+  (my_it_mkLambda_or_LetIn paramsctxt
   (my_it_mkLambda_or_LetIn_name realsign_ind
   (mkNamedLambda varP
     (my_it_mkProd_or_LetIn (lift_rel_context (nrealargs+1)
@@ -531,6 +573,7 @@ let build_r2l_forward_rew_scheme dep env ind kind =
 	   lift (nrealargs+3) applied_PC,
 	   mkRel 1)|]),
     [|mkVar varHC|]))))))
+  in c, Evd.evar_universe_context_of ctx
 
 (**********************************************************************)
 (* This function "repairs" the non-dependent r2l forward rewriting    *)
@@ -548,11 +591,12 @@ let build_r2l_forward_rew_scheme dep env ind kind =
 (*                                                                    *)
 (**********************************************************************)
 
-let fix_r2l_forward_rew_scheme c =
+let fix_r2l_forward_rew_scheme (c, ctx') =
   let t = Retyping.get_type_of (Global.env()) Evd.empty c in
   let ctx,_ = decompose_prod_assum t in
   match ctx with
   | hp :: p :: ind :: indargs ->
+     let c' = 
       my_it_mkLambda_or_LetIn indargs
 	(mkLambda_or_LetIn (map_rel_declaration (liftn (-1) 1) p)
 	  (mkLambda_or_LetIn (map_rel_declaration (liftn (-1) 2) hp)
@@ -560,7 +604,8 @@ let fix_r2l_forward_rew_scheme c =
 	      (Reductionops.whd_beta Evd.empty
 		(applist (c,
 	          extended_rel_list 3 indargs @ [mkRel 1;mkRel 3;mkRel 2]))))))
-  | _ -> anomaly "Ill-formed non-dependent left-to-right rewriting scheme"
+      in c', ctx'
+  | _ -> anomaly (Pp.str "Ill-formed non-dependent left-to-right rewriting scheme")
 
 (**********************************************************************)
 (* Build the right-to-left rewriting lemma for conclusion associated  *)
@@ -582,9 +627,16 @@ let fix_r2l_forward_rew_scheme c =
 (*          (H:I q1..qm a1..an),                                      *)
 (*          P b1..bn C -> P a1..an H                                  *)
 (**********************************************************************)
-
+ 
 let build_r2l_rew_scheme dep env ind k =
-  build_case_analysis_scheme env Evd.empty ind dep k
+  let sigma, indu = Evd.fresh_inductive_instance env (Evd.from_env env) ind in
+  let sigma', c = build_case_analysis_scheme env sigma indu dep k in
+    c, Evd.evar_universe_context sigma'
+
+let build_l2r_rew_scheme = build_l2r_rew_scheme
+let build_l2r_forward_rew_scheme = build_l2r_forward_rew_scheme
+let build_r2l_rew_scheme = build_r2l_rew_scheme
+let build_r2l_forward_rew_scheme = build_r2l_forward_rew_scheme
 
 (**********************************************************************)
 (* Register the rewriting schemes                                     *)
@@ -608,7 +660,7 @@ let rew_l2r_dep_scheme_kind =
 (**********************************************************************)
 let rew_r2l_dep_scheme_kind =
   declare_individual_scheme_object "_rew_dep"
-  (fun ind -> build_r2l_rew_scheme true (Global.env()) ind InType)
+  (fun ind -> build_r2l_rew_scheme true (Global.env()) ind InType,Declareops.no_seff)
 
 (**********************************************************************)
 (* Dependent rewrite from right-to-left in hypotheses                 *)
@@ -618,7 +670,7 @@ let rew_r2l_dep_scheme_kind =
 (**********************************************************************)
 let rew_r2l_forward_dep_scheme_kind =
   declare_individual_scheme_object "_rew_fwd_dep"
-  (fun ind -> build_r2l_forward_rew_scheme true (Global.env()) ind InType)
+  (fun ind -> build_r2l_forward_rew_scheme true (Global.env()) ind InType,Declareops.no_seff)
 
 (**********************************************************************)
 (* Dependent rewrite from left-to-right in hypotheses                 *)
@@ -628,7 +680,7 @@ let rew_r2l_forward_dep_scheme_kind =
 (**********************************************************************)
 let rew_l2r_forward_dep_scheme_kind =
   declare_individual_scheme_object "_rew_fwd_r_dep"
-  (fun ind -> build_l2r_forward_rew_scheme true (Global.env()) ind InType)
+  (fun ind -> build_l2r_forward_rew_scheme true (Global.env()) ind InType,Declareops.no_seff)
 
 (**********************************************************************)
 (* Non-dependent rewrite from either left-to-right in conclusion or   *)
@@ -642,7 +694,7 @@ let rew_l2r_forward_dep_scheme_kind =
 let rew_l2r_scheme_kind =
   declare_individual_scheme_object "_rew_r"
   (fun ind -> fix_r2l_forward_rew_scheme
-      (build_r2l_forward_rew_scheme false (Global.env()) ind InType))
+     (build_r2l_forward_rew_scheme false (Global.env()) ind InType), Declareops.no_seff)
 
 (**********************************************************************)
 (* Non-dependent rewrite from either right-to-left in conclusion or   *)
@@ -652,7 +704,7 @@ let rew_l2r_scheme_kind =
 (**********************************************************************)
 let rew_r2l_scheme_kind =
   declare_individual_scheme_object "_rew"
-  (fun ind -> build_r2l_rew_scheme false (Global.env()) ind InType)
+  (fun ind -> build_r2l_rew_scheme false (Global.env()) ind InType, Declareops.no_seff)
 
 (* End of rewriting schemes *)
 
@@ -671,35 +723,41 @@ let rew_r2l_scheme_kind =
 
 (* TODO: extend it to types with more than one index *)
 
-let build_congr env (eq,refl) ind =
+let build_congr env (eq,refl,ctx) ind =
+  let (ind,u as indu), ctx = with_context_set ctx 
+    (Universes.fresh_inductive_instance env ind) in
   let (mib,mip) = lookup_mind_specif env ind in
-  if Array.length mib.mind_packets <> 1 or Array.length mip.mind_nf_lc <> 1 then
+  if not (Int.equal (Array.length mib.mind_packets) 1) || not (Int.equal (Array.length mip.mind_nf_lc) 1) then
     error "Not an inductive type with a single constructor.";
-  if mip.mind_nrealargs <> 1 then
+  if not (Int.equal mip.mind_nrealargs 1) then
     error "Expect an inductive type with one predicate parameter.";
   let i = 1 in
-  let realsign,_ = list_chop mip.mind_nrealargs_ctxt mip.mind_arity_ctxt in
-  if List.exists (fun (_,b,_) -> b <> None) realsign then
+  let arityctxt = Vars.subst_instance_context u mip.mind_arity_ctxt in
+  let paramsctxt = Vars.subst_instance_context u mib.mind_params_ctxt in
+  let realsign,_ = List.chop mip.mind_nrealdecls arityctxt in
+  if List.exists (fun (_,b,_) -> not (Option.is_empty b)) realsign then
     error "Inductive equalities with local definitions in arity not supported.";
-  let env_with_arity = push_rel_context mip.mind_arity_ctxt env in
+  let env_with_arity = push_rel_context arityctxt env in
   let (_,_,ty) = lookup_rel (mip.mind_nrealargs - i + 1) env_with_arity in
   let constrsign,ccl = decompose_prod_assum mip.mind_nf_lc.(0) in
   let _,constrargs = decompose_app ccl in
-  if rel_context_length constrsign<>rel_context_length mib.mind_params_ctxt then
+  if Int.equal (rel_context_length constrsign) (rel_context_length mib.mind_params_ctxt) then
     error "Constructor must have no arguments";
   let b = List.nth constrargs (i + mib.mind_nparams - 1) in
-  let varB = fresh env (id_of_string "B") in
-  let varH = fresh env (id_of_string "H") in
-  let varf = fresh env (id_of_string "f") in
+  let varB = fresh env (Id.of_string "B") in
+  let varH = fresh env (Id.of_string "H") in
+  let varf = fresh env (Id.of_string "f") in
   let ci = make_case_info (Global.env()) ind RegularStyle in
-  my_it_mkLambda_or_LetIn mib.mind_params_ctxt
-     (mkNamedLambda varB (new_Type ())
+  let uni, ctx = Universes.extend_context (Universes.new_global_univ ()) ctx in
+  let c = 
+  my_it_mkLambda_or_LetIn paramsctxt
+     (mkNamedLambda varB (mkSort (Type uni))
      (mkNamedLambda varf (mkArrow (lift 1 ty) (mkVar varB))
      (my_it_mkLambda_or_LetIn_name (lift_rel_context 2 realsign)
      (mkNamedLambda varH
         (applist
-           (mkInd ind,
-	    extended_rel_list (mip.mind_nrealargs+2) mib.mind_params_ctxt @
+           (mkIndU indu,
+	    extended_rel_list (mip.mind_nrealargs+2) paramsctxt @
 	    extended_rel_list 0 realsign))
      (mkCase (ci,
        my_it_mkLambda_or_LetIn_name
@@ -707,20 +765,21 @@ let build_congr env (eq,refl) ind =
          (mkLambda
            (Anonymous,
             applist
-             (mkInd ind,
-	        extended_rel_list (2*mip.mind_nrealargs_ctxt+3)
-		  mib.mind_params_ctxt
+             (mkIndU indu,
+	        extended_rel_list (2*mip.mind_nrealdecls+3)
+		  paramsctxt
 	        @ extended_rel_list 0 realsign),
             mkApp (eq,
 	      [|mkVar varB;
-                mkApp (mkVar varf, [|lift (2*mip.mind_nrealargs_ctxt+4) b|]);
+                mkApp (mkVar varf, [|lift (2*mip.mind_nrealdecls+4) b|]);
 		mkApp (mkVar varf, [|mkRel (mip.mind_nrealargs - i + 2)|])|]))),
        mkVar varH,
        [|mkApp (refl,
           [|mkVar varB;
 	    mkApp (mkVar varf, [|lift (mip.mind_nrealargs+3) b|])|])|]))))))
+  in c, Evd.evar_universe_context_of ctx
 
 let congr_scheme_kind = declare_individual_scheme_object "_congr"
   (fun ind ->
     (* May fail if equality is not defined *)
-    build_congr (Global.env()) (get_coq_eq ()) ind)
+    build_congr (Global.env()) (get_coq_eq Univ.ContextSet.empty) ind, Declareops.no_seff)
diff --git a/tactics/eqschemes.mli b/tactics/eqschemes.mli
index 2f973e6d..6bb84808 100644
--- a/tactics/eqschemes.mli
+++ b/tactics/eqschemes.mli
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -22,22 +22,26 @@ val rew_l2r_forward_dep_scheme_kind : individual scheme_kind
 val rew_r2l_dep_scheme_kind : individual scheme_kind
 val rew_r2l_scheme_kind : individual scheme_kind
 
-val build_r2l_rew_scheme : bool -> env -> inductive -> sorts_family -> constr
-val build_l2r_rew_scheme : bool -> env -> inductive -> sorts_family -> constr
+val build_r2l_rew_scheme : bool -> env -> inductive -> sorts_family -> 
+  constr Evd.in_evar_universe_context
+val build_l2r_rew_scheme : bool -> env -> inductive -> sorts_family -> 
+  constr Evd.in_evar_universe_context * Declareops.side_effects
 val build_r2l_forward_rew_scheme :
-  bool -> env -> inductive -> sorts_family -> constr
+  bool -> env -> inductive -> sorts_family -> constr Evd.in_evar_universe_context
 val build_l2r_forward_rew_scheme :
-  bool -> env -> inductive -> sorts_family -> constr
+  bool -> env -> inductive -> sorts_family -> constr Evd.in_evar_universe_context
 
 (** Builds a symmetry scheme for a symmetrical equality type *)
 
-val build_sym_scheme : env -> inductive -> constr
+val build_sym_scheme : env -> inductive -> constr Evd.in_evar_universe_context
 val sym_scheme_kind : individual scheme_kind
 
-val build_sym_involutive_scheme : env -> inductive -> constr
+val build_sym_involutive_scheme : env -> inductive -> 
+  constr Evd.in_evar_universe_context * Declareops.side_effects
 val sym_involutive_scheme_kind : individual scheme_kind
 
 (** Builds a congruence scheme for an equality type *)
 
 val congr_scheme_kind : individual scheme_kind
-val build_congr : env -> constr * constr -> inductive -> constr
+val build_congr : env -> constr * constr * Univ.universe_context_set -> inductive -> 
+  constr Evd.in_evar_universe_context
diff --git a/tactics/equality.ml b/tactics/equality.ml
index 184f98ca..c130fa15 100644
--- a/tactics/equality.ml
+++ b/tactics/equality.ml
@@ -1,49 +1,47 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
 open Pp
+open Errors
 open Util
 open Names
 open Nameops
-open Univ
 open Term
+open Vars
 open Termops
 open Namegen
 open Inductive
 open Inductiveops
 open Environ
 open Libnames
+open Globnames
 open Reductionops
-open Typeops
 open Typing
 open Retyping
-open Tacmach
-open Proof_type
+open Tacmach.New
 open Logic
-open Evar_refiner
-open Pattern
-open Matching
 open Hipattern
 open Tacexpr
-open Tacticals
+open Tacticals.New
 open Tactics
 open Tacred
-open Glob_term
 open Coqlib
-open Vernacexpr
 open Declarations
 open Indrec
-open Printer
 open Clenv
-open Clenvtac
 open Evd
 open Ind_tables
 open Eqschemes
+open Locus
+open Locusops
+open Misctypes
+open Proofview.Notations
+open Unification
 
 (* Options *)
 
@@ -62,8 +60,28 @@ let _ =
       optread  = (fun () -> !discriminate_introduction);
       optwrite = (:=) discriminate_introduction }
 
+let injection_pattern_l2r_order = ref true
+
+let use_injection_pattern_l2r_order () =
+  !injection_pattern_l2r_order
+  && Flags.version_strictly_greater Flags.V8_4
+
+let _ =
+  declare_bool_option
+    { optsync  = true;
+      optdepr  = false;
+      optname  = "injection left-to-right pattern order";
+      optkey   = ["Injection";"L2R";"Pattern";"Order"];
+      optread  = (fun () -> !injection_pattern_l2r_order) ;
+      optwrite = (fun b -> injection_pattern_l2r_order := b) }
+
 (* Rewriting tactics *)
 
+let clear ids = Proofview.V82.tactic (clear ids)
+
+let tclNOTSAMEGOAL tac =
+  Proofview.V82.tactic (Tacticals.tclNOTSAMEGOAL (Proofview.V82.of_tactic tac))
+
 type dep_proof_flag = bool (* true = support rewriting dependent proofs *)
 type freeze_evars_flag = bool (* true = don't instantiate existing evars *)
 
@@ -82,35 +100,44 @@ type conditions =
    -- Eduardo (19/8/97)
 *)
 
+let rewrite_core_unif_flags = {
+  modulo_conv_on_closed_terms = None;
+  use_metas_eagerly_in_conv_on_closed_terms = true;
+  use_evars_eagerly_in_conv_on_closed_terms = false;
+  modulo_delta = empty_transparent_state;
+  modulo_delta_types = empty_transparent_state;
+  check_applied_meta_types = true;
+  use_pattern_unification = true;
+  use_meta_bound_pattern_unification = true;
+  frozen_evars = Evar.Set.empty;
+  restrict_conv_on_strict_subterms = false;
+  modulo_betaiota = false;
+  modulo_eta = true;
+}
+
 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 = empty_transparent_state;
-  Unification.modulo_delta_in_merge = None;
-  Unification.check_applied_meta_types = true;
-  Unification.resolve_evars = true;
-  Unification.use_pattern_unification = true;
-  Unification.use_meta_bound_pattern_unification = true;
-  Unification.frozen_evars = ExistentialSet.empty;
-  Unification.restrict_conv_on_strict_subterms = false;
-  Unification.modulo_betaiota = false;
-  Unification.modulo_eta = true;
-  Unification.allow_K_in_toplevel_higher_order_unification = false
+  core_unify_flags = rewrite_core_unif_flags;
+  merge_unify_flags = rewrite_core_unif_flags;
+  subterm_unify_flags = rewrite_core_unif_flags;
+  allow_K_in_toplevel_higher_order_unification = false;
     (* allow_K does not matter in practice because calls w_typed_unify *)
+  resolve_evars = true
 }
 
 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 newevars = Evd.evars_of_term (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 }
+      if Evar.Set.mem evk newevars then evars
+      else Evar.Set.add evk evars)
+      sigma Evar.Set.empty in
+  {flags with
+    core_unify_flags = {flags.core_unify_flags with frozen_evars = evars};
+    merge_unify_flags = {flags.merge_unify_flags with frozen_evars = evars};
+    subterm_unify_flags = {flags.subterm_unify_flags with frozen_evars = evars}}
 
 let make_flags frzevars sigma flags clause =
   if frzevars then freeze_initial_evars sigma flags clause else flags
@@ -118,89 +145,91 @@ let make_flags frzevars sigma flags clause =
 let side_tac tac sidetac =
   match sidetac with
   | None -> tac
-  | Some sidetac -> tclTHENSFIRSTn tac [|tclIDTAC|] sidetac
-
-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
-      | [c1;c2] -> [],(c1, c2)
-      | x::y::z ->
-	  let l,res = split_last_two (y::z) in x::l, res
-      | _ -> error "The term provided is not an applied relation." in
-  let others,(c1,c2) = split_last_two args in
+  | Some sidetac -> tclTHENSFIRSTn tac [|Proofview.tclUNIT ()|] sidetac
+
+let instantiate_lemma_all frzevars gl c ty l l2r concl =
+  let env = Proofview.Goal.env gl in
+  let eqclause = pf_apply Clenv.make_clenv_binding gl (c,ty) l in
+  let (equiv, args) = decompose_appvect (Clenv.clenv_type eqclause) in
+  let arglen = Array.length args in
+  let () = if arglen < 2 then error "The term provided is not an applied relation." in
+  let c1 = args.(arglen - 2) in
+  let c2 = args.(arglen - 1) in
   let try_occ (evd', c') =
-    clenv_pose_dependent_evars true {eqclause with evd = evd'}
+    Clenvtac.clenv_pose_dependent_evars true {eqclause with evd = evd'}
   in
-  let flags = make_flags frzevars sigma rewrite_unif_flags eqclause in
+  let flags = make_flags frzevars (Proofview.Goal.sigma gl) rewrite_unif_flags eqclause in
   let occs =
-    Unification.w_unify_to_subterm_all ~flags env eqclause.evd
+    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 =
-  let gl = { gl with sigma = sigma } in
+let instantiate_lemma gl c ty l l2r concl =
   let ct = pf_type_of gl c in
   let t = try snd (pf_reduce_to_quantified_ind gl ct) with UserError _ -> ct in
-  let eqclause = Clenv.make_clenv_binding gl (c,t) l in
+  let eqclause = pf_apply Clenv.make_clenv_binding gl (c,t) l in
    [eqclause]
 
-let rewrite_conv_closed_unif_flags = {
-  Unification.modulo_conv_on_closed_terms = Some full_transparent_state;
+let rewrite_conv_closed_core_unif_flags = {
+  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;
+  use_metas_eagerly_in_conv_on_closed_terms = true;
+  use_evars_eagerly_in_conv_on_closed_terms = false;
     (* Combined with modulo_conv_on_closed_terms, this flag allows since 8.2 *)
     (* to rewrite e.g. "?x+(2+?x)" in "1+(1+2)=0" *)
 
-  Unification.modulo_delta = empty_transparent_state;
-  Unification.modulo_delta_types = full_transparent_state;
-  Unification.modulo_delta_in_merge = None;
-  Unification.check_applied_meta_types = true;
-  Unification.resolve_evars = false;
-  Unification.use_pattern_unification = true;
+  modulo_delta = empty_transparent_state;
+  modulo_delta_types = full_transparent_state;
+  check_applied_meta_types = true;
+  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;
+  use_meta_bound_pattern_unification = true;
 
-  Unification.frozen_evars = ExistentialSet.empty;
+  frozen_evars = Evar.Set.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
+  restrict_conv_on_strict_subterms = false;
+  modulo_betaiota = false;
+  modulo_eta = true;
 }
 
-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_conv_closed_unif_flags = {
+  core_unify_flags = rewrite_conv_closed_core_unif_flags;
+  merge_unify_flags = rewrite_conv_closed_core_unif_flags;
+  subterm_unify_flags = rewrite_conv_closed_core_unif_flags;
+  allow_K_in_toplevel_higher_order_unification = false;
+  resolve_evars = false
+}
 
-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
+let rewrite_elim with_evars frzevars cls c e =
+  Proofview.Goal.enter begin fun gl ->
+  let flags = make_flags frzevars (Proofview.Goal.sigma gl) rewrite_conv_closed_unif_flags c in
+  general_elim_clause with_evars flags cls c e
+  end
 
 (* Ad hoc asymmetric general_elim_clause *)
 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 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,evd,Pretype_errors.NoOccurrenceFound (c', cls)))
-
-let general_elim_clause with_evars frzevars tac cls sigma c t l l2r elim gl =
+  let open Pretype_errors in
+  Proofview.tclORELSE
+    begin 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 frzevars cls rew elim)
+    | Some _ -> rewrite_elim with_evars frzevars cls rew elim
+    end
+    begin function (e, info) -> match e with
+    | PretypeError (env, evd, NoOccurrenceFound (c', _)) ->
+      Proofview.tclZERO (PretypeError (env, evd, NoOccurrenceFound (c', cls)))
+    | e -> Proofview.tclZERO ~info e
+    end
+
+let general_elim_clause with_evars frzevars tac cls c t l l2r elim =
   let all, firstonly, tac =
     match tac with
     | None -> false, false, None
@@ -208,20 +237,26 @@ let general_elim_clause with_evars frzevars tac cls sigma c t l l2r elim gl =
     | Some (tac, FirstSolved) -> true, true, Some (tclCOMPLETE tac)
     | Some (tac, AllMatches) -> true, false, Some (tclCOMPLETE tac)
   in
-  let cs =
-    (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 frzevars cls c elim)) tac
+         (Proofview.Unsafe.tclEVARS c.evd)
+         (general_elim_clause with_evars frzevars cls c elim))
+      tac
   in
-    if firstonly then
-      tclFIRST (List.map try_clause cs) gl
-    else tclMAP try_clause cs gl
+  Proofview.Goal.enter begin fun gl ->
+    let instantiate_lemma concl =
+      if not all then instantiate_lemma gl c t l l2r concl
+      else instantiate_lemma_all frzevars gl c t l l2r concl
+    in
+    let typ = match cls with
+    | None -> pf_nf_concl gl
+    | Some id -> pf_get_hyp_typ id (Proofview.Goal.assume gl)
+    in
+    let cs = instantiate_lemma typ in
+    if firstonly then tclFIRST (List.map try_clause cs)
+    else tclMAP try_clause cs
+  end
 
 (* The next function decides in particular whether to try a regular
   rewrite or a generalized rewrite.
@@ -230,11 +265,7 @@ let general_elim_clause with_evars frzevars tac cls sigma c t l l2r elim gl =
   If occurrences are set, use general rewrite.
 *)
 
-let general_rewrite_clause = ref (fun _ -> assert false)
-let register_general_rewrite_clause = (:=) general_rewrite_clause
-
-let is_applied_rewrite_relation = ref (fun _ _ _ _ -> None)
-let register_is_applied_rewrite_relation = (:=) is_applied_rewrite_relation
+let (forward_general_setoid_rewrite_clause, general_setoid_rewrite_clause) = Hook.make ()
 
 (* Do we have a JMeq instance on twice the same domains ? *)
 
@@ -242,46 +273,51 @@ let jmeq_same_dom gl = function
   | None -> true (* already checked in Hipattern.find_eq_data_decompose *)
   | Some t ->
     let rels, t = decompose_prod_assum t in
-    let env = Environ.push_rel_context rels (pf_env gl) in
+    let env = Environ.push_rel_context rels (Proofview.Goal.env gl) in
     match decompose_app t with
-      | _, [dom1; _; dom2;_] -> is_conv env (project gl) dom1 dom2
+      | _, [dom1; _; dom2;_] -> is_conv env (Proofview.Goal.sigma gl) dom1 dom2
       | _ -> false
 
 (* find_elim determines which elimination principle is necessary to
    eliminate lbeq on sort_of_gl. *)
 
 let find_elim hdcncl lft2rgt dep cls ot gl =
-  let inccl = not (Option.has_some cls) in
-  let hdcncl_is u = eq_constr hdcncl (constr_of_reference u) in
-  if (hdcncl_is (Coqlib.glob_eq) ||
-      hdcncl_is (Coqlib.glob_jmeq) && jmeq_same_dom gl ot)
-     && not dep
-     || Flags.version_less_or_equal Flags.V8_2
+  let inccl = Option.is_empty cls in
+  if (is_global Coqlib.glob_eq hdcncl ||
+      (is_global Coqlib.glob_jmeq hdcncl &&
+	 jmeq_same_dom gl ot)) && not dep
+    || Flags.version_less_or_equal Flags.V8_2
   then
-    match kind_of_term hdcncl with 
-      | Ind ind_sp -> 
+    let c = 
+      match kind_of_term hdcncl with 
+      | Ind (ind_sp,u) -> 
 	let pr1 = 
 	  lookup_eliminator ind_sp (elimination_sort_of_clause cls gl) 
-	in 
-	if lft2rgt = Some (cls=None) 
-	then
-	  let c1 = destConst pr1 in 
+	in
+        begin match lft2rgt, cls with
+        | Some true, None
+        | Some false, Some _ ->
+	  let c1 = destConstRef pr1 in 
 	  let mp,dp,l = repr_con (constant_of_kn (canonical_con c1)) in 
-	  let l' = label_of_id (add_suffix (id_of_label l) "_r")  in 
+	  let l' = Label.of_id (add_suffix (Label.to_id l) "_r")  in 
 	  let c1' = Global.constant_of_delta_kn (make_kn mp dp l') in
 	  begin 
 	    try 
 	      let _ = Global.lookup_constant c1' in
-	      mkConst c1'
+		c1'
 	    with Not_found -> 
-	      let rwr_thm = string_of_label l' in 
+	      let rwr_thm = Label.to_string l' in 
 	      error ("Cannot find rewrite principle "^rwr_thm^".")
 	  end
-	else pr1 
+	| _ -> destConstRef pr1
+        end
       | _ -> 
 	  (* cannot occur since we checked that we are in presence of 
 	     Logic.eq or Jmeq just before *)
 	assert false
+    in
+      let sigma, elim = Evd.fresh_global (Global.env ()) (Proofview.Goal.sigma gl) (ConstRef c) in
+	sigma, elim, Declareops.no_seff
   else
   let scheme_name = match dep, lft2rgt, inccl with
     (* Non dependent case *)
@@ -296,31 +332,39 @@ let find_elim hdcncl lft2rgt dep cls ot gl =
     | true, _, false -> rew_r2l_forward_dep_scheme_kind
   in
   match kind_of_term hdcncl with
-  | Ind ind -> mkConst (find_scheme scheme_name ind)
+  | Ind (ind,u) -> 
+      let c, eff = find_scheme scheme_name ind in 
+      (* MS: cannot use pf_constr_of_global as the eliminator might be generated by side-effect *)
+      let sigma, elim = Evd.fresh_global (Global.env ()) (Proofview.Goal.sigma gl) (ConstRef c) in
+	sigma, elim, eff
   | _ -> assert false
 
-let type_of_clause gl = function
-  | None -> pf_concl gl
-  | Some id -> pf_get_hyp_typ gl id
+let type_of_clause cls gl = match cls with
+  | None -> Proofview.Goal.concl gl
+  | Some id -> pf_get_hyp_typ id gl
 
-let leibniz_rewrite_ebindings_clause cls lft2rgt tac sigma c t l with_evars frzevars dep_proof_ok gl hdcncl =
+let leibniz_rewrite_ebindings_clause cls lft2rgt tac c t l with_evars frzevars dep_proof_ok hdcncl =
+  Proofview.Goal.nf_enter begin fun gl ->
   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 (Some t) gl in
-  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
+  let type_of_cls = type_of_clause cls gl in
+  let dep = dep_proof_ok && dep_fun c type_of_cls in
+  let (sigma,elim,effs) = find_elim hdcncl lft2rgt dep cls (Some t) gl in
+    Proofview.Unsafe.tclEVARS sigma <*> Proofview.tclEFFECTS effs <*>
+      general_elim_clause with_evars frzevars tac cls c t l
+      (match lft2rgt with None -> false | Some b -> b)
+      {elimindex = None; elimbody = (elim,NoBindings); elimrename = None}
+  end
 
 let adjust_rewriting_direction args lft2rgt =
-  if List.length args = 1 then begin
+  match args with
+  | [_] ->
     (* equality to a constant, like in eq_true *)
     (* more natural to see -> as the rewriting to the constant *)
     if not lft2rgt then
       error "Rewriting non-symmetric equality not allowed from right-to-left.";
     None
-  end
-  else
+  | _ ->
     (* other equality *)
     Some lft2rgt
 
@@ -329,34 +373,39 @@ 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 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)
+    ((c,l) : constr with_bindings) with_evars =
+  if occs != AllOccurrences then (
+    rewrite_side_tac (Hook.get forward_general_setoid_rewrite_clause cls lft2rgt occs (c,l) ~new_goals:[]) tac)
   else
-    let env = pf_env gl in
-    let sigma = project gl in
+    Proofview.Goal.enter begin fun gl ->
+      let sigma = Proofview.Goal.sigma gl in
+      let env = Proofview.Goal.env gl in
     let ctype = get_type_of env sigma c in
     let rels, t = decompose_prod_assum (whd_betaiotazeta sigma ctype) in
       match match_with_equality_type t with
       | 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 frzevars dep_proof_ok gl hdcncl
+          leibniz_rewrite_ebindings_clause cls lft2rgt tac c (it_mkProd_or_LetIn t rels)
+	    l with_evars frzevars dep_proof_ok hdcncl
       | None ->
-	  try
-	    rewrite_side_tac (!general_rewrite_clause cls
-				 lft2rgt occs (c,l) ~new_goals:[]) tac gl
-	  with e when Errors.noncritical e ->
-            (* Try to see if there's an equality hidden *)
-	    let env' = push_rel_context rels env in
-	    let rels',t' = splay_prod_assum env' sigma t in (* Search for underlying eq *)
-	      match match_with_equality_type t' with
-	      | Some (hdcncl,args) ->
+	  Proofview.tclORELSE
+            begin
+	      rewrite_side_tac (Hook.get forward_general_setoid_rewrite_clause cls
+				   lft2rgt occs (c,l) ~new_goals:[]) tac
+            end
+            begin function
+              | (e, info) ->
+	          let env' = push_rel_context rels env in
+	          let rels',t' = splay_prod_assum env' sigma t in (* Search for underlying eq *)
+	          match match_with_equality_type t' with
+	            | Some (hdcncl,args) ->
 		  let lft2rgt = adjust_rewriting_direction args lft2rgt in
-		    leibniz_rewrite_ebindings_clause cls lft2rgt tac sigma c
-		      (it_mkProd_or_LetIn t' (rels' @ rels)) l with_evars frzevars dep_proof_ok gl hdcncl
-	      | None -> raise e
-		  (* error "The provided term does not end with an equality or a declared rewrite relation." *)
+		  leibniz_rewrite_ebindings_clause cls lft2rgt tac c
+		    (it_mkProd_or_LetIn t' (rels' @ rels)) l with_evars frzevars dep_proof_ok hdcncl
+	            | None -> Proofview.tclZERO ~info e
+            (* error "The provided term does not end with an equality or a declared rewrite relation." *)  
+            end
+    end
 
 let general_rewrite_ebindings =
   general_rewrite_ebindings_clause None
@@ -380,8 +429,8 @@ 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
+let general_rewrite_clause l2r with_evars ?tac c cl =
+  let occs_of = occurrences_map (List.fold_left
     (fun acc ->
       function ArgArg x -> x :: acc | ArgVar _ -> acc)
     [])
@@ -391,108 +440,163 @@ let general_multi_rewrite l2r with_evars ?tac c cl =
 	(* If a precise list of locations is given, success is mandatory for
 	   each of these locations. *)
 	let rec do_hyps = function
-	  | [] -> tclIDTAC
+	  | [] -> Proofview.tclUNIT ()
 	  | ((occs,id),_) :: l ->
 	    tclTHENFIRST
 	      (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
+	if cl.concl_occs == NoOccurrences then do_hyps l else
 	  tclTHENFIRST
-	   (general_rewrite_ebindings l2r (occs_of cl.concl_occs) false true ?tac c with_evars)
-	   (do_hyps l)
+	    (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
            syntax "* |-", we fail iff all the different rewrites fail *)
 	let rec do_hyps_atleastonce = function
-	  | [] -> (fun gl -> error "Nothing to rewrite.")
+	  | [] -> Proofview.tclZERO (Errors.UserError ("",Pp.str"Nothing to rewrite."))
 	  | id :: l ->
 	    tclIFTHENTRYELSEMUST
-	     (general_rewrite_ebindings_in l2r all_occurrences false true ?tac id c with_evars)
+	     (general_rewrite_ebindings_in l2r AllOccurrences false true ?tac id c with_evars)
 	     (do_hyps_atleastonce l)
 	in
-	let do_hyps gl =
+	let do_hyps =
 	  (* If the term to rewrite uses an hypothesis H, don't rewrite in H *)
-	  let ids =
+	  let ids gl =
 	    let ids_in_c = Environ.global_vars_set (Global.env()) (fst c) in
-	      Idset.fold (fun id l -> list_remove id l) ids_in_c (pf_ids_of_hyps gl)
-	  in do_hyps_atleastonce ids gl
+            let ids_of_hyps = pf_ids_of_hyps gl in
+	    Id.Set.fold (fun id l -> List.remove Id.equal id l) ids_in_c ids_of_hyps
+	  in
+          Proofview.Goal.enter begin fun gl ->
+            do_hyps_atleastonce (ids gl)
+          end
 	in
-	if cl.concl_occs = no_occurrences_expr then do_hyps else
+	if cl.concl_occs == NoOccurrences then do_hyps else
 	  tclIFTHENTRYELSEMUST
 	   (general_rewrite_ebindings l2r (occs_of cl.concl_occs) false true ?tac c with_evars)
 	   do_hyps
 
+let apply_special_clear_request clear_flag f =
+  Proofview.Goal.enter begin fun gl ->
+    let sigma = Proofview.Goal.sigma gl in
+    let env = Proofview.Goal.env gl in
+    try
+      let sigma,(c,bl) = f env sigma in
+      apply_clear_request clear_flag (use_clear_hyp_by_default ()) c
+    with
+      e when catchable_exception e -> tclIDTAC
+  end
+
 type delayed_open_constr_with_bindings =
     env -> evar_map -> evar_map * constr with_bindings
 
-let general_multi_multi_rewrite with_evars l cl tac =
-  let do1 l2r f gl =
-    let sigma,c = f (pf_env gl) (project gl) in
-    Refiner.tclWITHHOLES with_evars
-      (general_multi_rewrite l2r with_evars ?tac c) sigma cl gl in
+let general_multi_rewrite with_evars l cl tac =
+  let do1 l2r f =
+    Proofview.Goal.enter begin fun gl ->
+      let sigma = Proofview.Goal.sigma gl in
+      let env = Proofview.Goal.env gl in
+      let sigma,c = f env sigma in
+      tclWITHHOLES with_evars
+        (general_rewrite_clause l2r with_evars ?tac c) sigma cl
+    end
+  in
   let rec doN l2r c = function
-    | Precisely n when n <= 0 -> tclIDTAC
+    | Precisely n when n <= 0 -> Proofview.tclUNIT ()
     | Precisely 1 -> do1 l2r c
     | Precisely n -> tclTHENFIRST (do1 l2r c) (doN l2r c (Precisely (n-1)))
     | RepeatStar -> tclREPEAT_MAIN (do1 l2r c)
     | RepeatPlus -> tclTHENFIRST (do1 l2r c) (doN l2r c RepeatStar)
-    | UpTo n when n<=0 -> tclIDTAC
+    | UpTo n when n<=0 -> Proofview.tclUNIT ()
     | UpTo n -> tclTHENFIRST (tclTRY (do1 l2r c)) (doN l2r c (UpTo (n-1)))
   in
   let rec loop = function
-    | [] -> tclIDTAC
-    | (l2r,m,c)::l -> tclTHENFIRST (doN l2r c m) (loop l)
+    | [] -> Proofview.tclUNIT ()
+    | (l2r,m,clear_flag,c)::l ->
+        tclTHENFIRST
+          (tclTHEN (doN l2r c m) (apply_special_clear_request clear_flag c)) (loop l)
   in loop l
 
-let rewriteLR = general_rewrite true all_occurrences true true
-let rewriteRL = general_rewrite false all_occurrences true true
+let rewriteLR = general_rewrite true AllOccurrences true true
+let rewriteRL = general_rewrite false AllOccurrences true true
 
 (* Replacing tactics *)
 
+let classes_dirpath =
+  DirPath.make (List.map Id.of_string ["Classes";"Coq"])
+
+let init_setoid () =
+  if is_dirpath_prefix_of classes_dirpath (Lib.cwd ()) then ()
+  else Coqlib.check_required_library ["Coq";"Setoids";"Setoid"]
+
+let check_setoid cl = 
+  Option.fold_left
+    ( List.fold_left 
+	(fun b ((occ,_),_) -> 
+	  b||(Locusops.occurrences_map (fun x -> x) occ <> AllOccurrences)
+	)
+    )
+    ((Locusops.occurrences_map (fun x -> x) cl.concl_occs <> AllOccurrences) &&
+	(Locusops.occurrences_map (fun x -> x) cl.concl_occs <> NoOccurrences))
+    cl.onhyps
+
+let replace_core clause l2r eq =
+  if check_setoid clause
+  then init_setoid ();
+  tclTHENFIRST
+    (assert_as false None eq)
+    (onLastHypId (fun id ->
+      tclTHEN
+        (tclTRY (general_rewrite_clause l2r false (mkVar id,NoBindings) clause))
+	(clear [id])))
+
 (* eq,sym_eq : equality on Type and its symmetry theorem
-   c2 c1 : c1 is to be replaced by c2
+   c1 c2 : c1 is to be replaced by c2
    unsafe : If true, do not check that c1 and c2 are convertible
    tac : Used to prove the equality c1 = c2
    gl : goal *)
 
-let multi_replace clause c2 c1 unsafe try_prove_eq_opt gl =
+let replace_using_leibniz clause c1 c2 l2r unsafe try_prove_eq_opt =
   let try_prove_eq =
     match try_prove_eq_opt with
-      | None -> tclIDTAC
+      | None -> Proofview.tclUNIT ()
       | Some tac ->  tclCOMPLETE tac
   in
-  let t1 = pf_apply get_type_of gl c1
-  and t2 = pf_apply get_type_of gl c2 in
-  if unsafe or (pf_conv_x gl t1 t2) then
+  Proofview.Goal.enter begin fun gl ->
+  let get_type_of = pf_apply get_type_of gl in
+  let t1 = get_type_of c1
+  and t2 = get_type_of c2 in
+  let evd = 
+    if unsafe then Some (Proofview.Goal.sigma gl)
+    else
+      try Some (Evarconv.the_conv_x (Proofview.Goal.env gl) t1 t2 (Proofview.Goal.sigma gl))
+      with Evarconv.UnableToUnify _ -> None
+  in
+  match evd with
+  | None ->
+    tclFAIL 0 (str"Terms do not have convertible types.")
+  | Some evd ->
     let e = build_coq_eq () in
     let sym = build_coq_eq_sym () in
+    Tacticals.New.pf_constr_of_global sym (fun sym ->
+    Tacticals.New.pf_constr_of_global e (fun e ->
     let eq = applist (e, [t1;c1;c2]) in
-    tclTHENS (assert_as false None eq)
-      [onLastHypId (fun id ->
-	tclTHEN
-	  (tclTRY (general_multi_rewrite false false (mkVar id,NoBindings) clause))
-	  (clear [id]));
-       tclFIRST
-	 [assumption;
-	  tclTHEN (apply sym) assumption;
-	  try_prove_eq
-	 ]
-      ] gl
-  else
-    error "Terms do not have convertible types."
-
-
-let replace c2 c1 gl = multi_replace onConcl c2 c1 false None gl
-
-let replace_in id c2 c1 gl = multi_replace (onHyp id) c2 c1 false None gl
+    tclTHENLAST
+      (replace_core clause l2r eq)
+      (tclFIRST
+         [assumption;
+          tclTHEN (apply sym) assumption;
+          try_prove_eq
+         ])))
+  end
 
-let replace_by c2 c1 tac gl = multi_replace onConcl c2 c1 false (Some tac) gl
+let replace c1 c2 =
+  replace_using_leibniz onConcl c2 c1 false false None
 
-let replace_in_by id c2 c1 tac gl = multi_replace (onHyp id) c2 c1 false (Some tac) gl
+let replace_by c1 c2 tac =
+  replace_using_leibniz onConcl c2 c1 false false (Some tac)
 
-let replace_in_clause_maybe_by c2 c1 cl tac_opt gl =
-  multi_replace cl c2 c1 false tac_opt gl
+let replace_in_clause_maybe_by c1 c2 cl tac_opt =
+  replace_using_leibniz cl c2 c1 false false tac_opt
 
 (* End of Eduardo's code. The rest of this file could be improved
    using the functions match_with_equation, etc that I defined
@@ -541,41 +645,64 @@ let replace_in_clause_maybe_by c2 c1 cl tac_opt gl =
 exception DiscrFound of
   (constructor * int) list * constructor * constructor
 
+let injection_on_proofs = ref false
+
+let _ =
+  declare_bool_option
+    { optsync  = true;
+      optdepr  = false;
+      optname  = "injection on prop arguments";
+      optkey   = ["Injection";"On";"Proofs"];
+      optread  = (fun () -> !injection_on_proofs) ;
+      optwrite = (fun b -> injection_on_proofs := b) }
+
+
 let find_positions env sigma t1 t2 =
+  let project env sorts posn t1 t2 =
+    let ty1 = get_type_of env sigma t1 in
+    let s = get_sort_family_of env sigma ty1 in
+    if Sorts.List.mem s sorts
+    then [(List.rev posn,t1,t2)] else []
+  in
   let rec findrec sorts posn t1 t2 =
     let hd1,args1 = whd_betadeltaiota_stack env sigma t1 in
     let hd2,args2 = whd_betadeltaiota_stack env sigma t2 in
     match (kind_of_term hd1, kind_of_term hd2) with
-
-      | Construct sp1, Construct sp2
-          when List.length args1 = mis_constructor_nargs_env env sp1
+      | Construct (sp1,_), Construct (sp2,_)
+          when Int.equal (List.length args1) (constructor_nallargs_env env sp1)
             ->
-	  let sorts = list_intersect sorts (allowed_sorts env (fst sp1)) in
+	  let sorts' =
+            Sorts.List.intersect sorts (allowed_sorts env (fst sp1))
+          in
           (* both sides are fully applied constructors, so either we descend,
              or we can discriminate here. *)
-	  if is_conv env sigma hd1 hd2 then
-	    let nrealargs = constructor_nrealargs env sp1 in
-	    let rargs1 = list_lastn nrealargs args1 in
-	    let rargs2 = list_lastn nrealargs args2 in
+	  if eq_constructor sp1 sp2 then
+	    let nrealargs = constructor_nrealargs_env env sp1 in
+	    let rargs1 = List.lastn nrealargs args1 in
+	    let rargs2 = List.lastn nrealargs args2 in
             List.flatten
-	      (list_map2_i (fun i -> findrec sorts ((sp1,i)::posn))
+	      (List.map2_i (fun i -> findrec sorts' ((sp1,i)::posn))
 		0 rargs1 rargs2)
-	  else if List.mem InType sorts then (* see build_discriminator *)
+	  else if Sorts.List.mem InType sorts'
+          then (* see build_discriminator *)
 	    raise (DiscrFound (List.rev posn,sp1,sp2))
-	  else []
-
+	  else 
+          (* if we cannot eliminate to Type, we cannot discriminate but we
+	     may still try to project *)
+	  project env sorts posn (applist (hd1,args1)) (applist (hd2,args2))
       | _ ->
 	  let t1_0 = applist (hd1,args1)
           and t2_0 = applist (hd2,args2) in
           if is_conv env sigma t1_0 t2_0 then
 	    []
           else
-	    let ty1_0 = get_type_of env sigma t1_0 in
-	    let s = get_sort_family_of env sigma ty1_0 in
-	    if List.mem s sorts then [(List.rev posn,t1_0,t2_0)] else [] in
+	    project env sorts posn t1_0 t2_0
+  in
   try
-    (* Rem: to allow injection on proofs objects, just add InProp *)
-    Inr (findrec [InSet;InType] [] t1 t2)
+    let sorts = if !injection_on_proofs then [InSet;InType;InProp]
+		else [InSet;InType]
+    in
+    Inr (findrec sorts [] t1 t2)
   with DiscrFound (path,c1,c2) ->
     Inl (path,c1,c2)
 
@@ -638,7 +765,7 @@ let injectable env sigma t1 t2 =
 
  *)
 
-(* [descend_then sigma env head dirn]
+(* [descend_then env sigma head dirn]
 
    returns the number of products introduced, and the environment
    which is active, in the body of the case-branch given by [dirn],
@@ -653,12 +780,13 @@ let injectable env sigma t1 t2 =
    the continuation then constructs the case-split.
  *)
 
-let descend_then sigma env head dirn =
+let descend_then env sigma head dirn =
   let IndType (indf,_) =
     try find_rectype env sigma (get_type_of env sigma head)
     with Not_found ->
       error "Cannot project on an inductive type derived from a dependency." in
-   let ind,_ = dest_ind_family indf in
+  let indp,_ = (dest_ind_family indf) in
+  let ind, _ = check_privacy env indp in
   let (mib,mip) = lookup_mind_specif env ind in
   let cstr = get_constructors env indf in
   let dirn_nlams = cstr.(dirn-1).cs_nargs in
@@ -670,11 +798,11 @@ let descend_then sigma env head dirn =
       let p =
 	it_mkLambda_or_LetIn (lift (mip.mind_nrealargs+1) resty) deparsign in
       let build_branch i =
-	let result = if i = dirn then dirnval else dfltval in
+	let result = if Int.equal i dirn then dirnval else dfltval in
 	it_mkLambda_or_LetIn_name env result cstr.(i-1).cs_args in
       let brl =
         List.map build_branch
-          (interval 1 (Array.length mip.mind_consnames)) in
+          (List.interval 1 (Array.length mip.mind_consnames)) in
       let ci = make_case_info env ind RegularStyle in
       mkCase (ci, p, head, Array.of_list brl)))
 
@@ -695,7 +823,7 @@ let descend_then sigma env head dirn =
    constructs a case-split on [headval], with the [dirn]-th branch
    giving [True], and all the rest giving False. *)
 
-let construct_discriminator sigma env dirn c sort =
+let construct_discriminator env sigma dirn c sort =
   let IndType(indf,_) =
     try find_rectype env sigma (get_type_of env sigma c)
     with Not_found ->
@@ -707,26 +835,27 @@ let construct_discriminator sigma env dirn c sort =
       errorlabstrm "Equality.construct_discriminator"
 	(str "Cannot discriminate on inductive constructors with \
 		 dependent types.") in
-  let (ind,_) = dest_ind_family indf in
+  let (indp,_) = dest_ind_family indf in
+  let ind, _ = check_privacy env indp in
   let (mib,mip) = lookup_mind_specif env ind in
   let (true_0,false_0,sort_0) = build_coq_True(),build_coq_False(),Prop Null in
   let deparsign = make_arity_signature env true indf in
   let p = it_mkLambda_or_LetIn (mkSort sort_0) deparsign in
   let cstrs = get_constructors env indf in
   let build_branch i =
-    let endpt = if i = dirn then true_0 else false_0 in
+    let endpt = if Int.equal i dirn then true_0 else false_0 in
     it_mkLambda_or_LetIn endpt cstrs.(i-1).cs_args in
   let brl =
-    List.map build_branch(interval 1 (Array.length mip.mind_consnames)) in
+    List.map build_branch(List.interval 1 (Array.length mip.mind_consnames)) in
   let ci = make_case_info env ind RegularStyle in
   mkCase (ci, p, c, Array.of_list brl)
 
-let rec build_discriminator sigma env dirn c sort = function
-  | [] -> construct_discriminator sigma env dirn c sort
+let rec build_discriminator env sigma dirn c sort = function
+  | [] -> construct_discriminator env sigma dirn c sort
   | ((sp,cnum),argnum)::l ->
-      let (cnum_nlams,cnum_env,kont) = descend_then sigma env c cnum in
+      let (cnum_nlams,cnum_env,kont) = descend_then env sigma c cnum in
       let newc = mkRel(cnum_nlams-argnum) in
-      let subval = build_discriminator sigma cnum_env dirn newc sort l  in
+      let subval = build_discriminator cnum_env sigma dirn newc sort l  in
       kont subval (build_coq_False (),mkSort (Prop Null))
 
 (* Note: discrimination could be more clever: if some elimination is
@@ -740,13 +869,16 @@ let rec build_discriminator sigma env dirn c sort = function
    Goal ~ c _ 0 0 = c _ 0 1. intro. discriminate H.
 *)
 
-let gen_absurdity id gl =
-  if is_empty_type (pf_get_hyp_typ gl id)
+let gen_absurdity id =
+  Proofview.Goal.enter begin fun gl ->
+  let hyp_typ = pf_get_hyp_typ id (Proofview.Goal.assume gl) in
+  let hyp_typ = pf_nf_evar gl hyp_typ in
+  if is_empty_type hyp_typ
   then
-    simplest_elim (mkVar id) gl
+    simplest_elim (mkVar id)
   else
-    errorlabstrm "Equality.gen_absurdity"
-      (str "Not the negation of an equality.")
+    Proofview.tclZERO (Errors.UserError ("Equality.gen_absurdity" , str "Not the negation of an equality."))
+  end
 
 (* Precondition: eq is leibniz equality
 
@@ -756,24 +888,25 @@ let gen_absurdity id gl =
 *)
 
 let ind_scheme_of_eq lbeq =
-  let (mib,mip) = Global.lookup_inductive (destInd lbeq.eq) in
+  let (mib,mip) = Global.lookup_inductive (destIndRef lbeq.eq) in
   let kind = inductive_sort_family mip in
   (* use ind rather than case by compatibility *)
   let kind =
-    if kind = InProp then Elimschemes.ind_scheme_kind_from_prop
+    if kind == InProp then Elimschemes.ind_scheme_kind_from_prop
     else Elimschemes.ind_scheme_kind_from_type in
-  mkConst (find_scheme kind (destInd lbeq.eq))
+  let c, eff = find_scheme kind (destIndRef lbeq.eq) in
+    ConstRef c, eff
 
 
-let discrimination_pf e (t,t1,t2) discriminator lbeq =
-  let i           = build_coq_I () in
-  let absurd_term = build_coq_False () in
-  let eq_elim     = ind_scheme_of_eq lbeq in
-  (applist (eq_elim, [t;t1;mkNamedLambda e t discriminator;i;t2]), absurd_term)
+let discrimination_pf env sigma e (t,t1,t2) discriminator lbeq =
+  let i            = build_coq_I () in
+  let absurd_term  = build_coq_False () in
+  let eq_elim, eff = ind_scheme_of_eq lbeq in
+  let sigma, eq_elim = Evd.fresh_global env sigma eq_elim in
+    sigma, (applist (eq_elim, [t;t1;mkNamedLambda e t discriminator;i;t2]), absurd_term),
+    eff
 
-exception NotDiscriminable
-
-let eq_baseid = id_of_string "e"
+let eq_baseid = Id.of_string "e"
 
 let apply_on_clause (f,t) clause =
   let sigma =  clause.evd in
@@ -788,44 +921,58 @@ let discr_positions env sigma (lbeq,eqn,(t,t1,t2)) eq_clause cpath dirn sort =
   let e = next_ident_away eq_baseid (ids_of_context env) in
   let e_env = push_named (e,None,t) env in
   let discriminator =
-    build_discriminator sigma e_env dirn (mkVar e) sort cpath in
-  let (pf, absurd_term) = discrimination_pf e (t,t1,t2) discriminator lbeq in
+    build_discriminator e_env sigma dirn (mkVar e) sort cpath in
+  let sigma,(pf, absurd_term), eff = 
+    discrimination_pf env sigma e (t,t1,t2) discriminator lbeq in
   let pf_ty = mkArrow eqn absurd_term in
   let absurd_clause = apply_on_clause (pf,pf_ty) eq_clause in
-  let pf = clenv_value_cast_meta absurd_clause in
-  tclTHENS (cut_intro absurd_term)
-    [onLastHypId gen_absurdity; refine pf]
+  let pf = Clenvtac.clenv_value_cast_meta absurd_clause in
+  Proofview.Unsafe.tclEVARS sigma <*>
+  Proofview.tclEFFECTS eff <*>
+  tclTHENS (assert_after Anonymous absurd_term)
+    [onLastHypId gen_absurdity; (Proofview.V82.tactic (refine pf))]
 
-let discrEq (lbeq,_,(t,t1,t2) as u) eq_clause gls =
+let discrEq (lbeq,_,(t,t1,t2) as u) eq_clause =
   let sigma = eq_clause.evd in
-  let env = pf_env gls in
-  match find_positions env sigma t1 t2 with
+  Proofview.Goal.nf_enter begin fun gl ->
+    let env = Proofview.Goal.env gl in
+    let concl = Proofview.Goal.concl gl in
+    match find_positions env sigma t1 t2 with
     | Inr _ ->
-	errorlabstrm "discr" (str"Not a discriminable equality.")
+	Proofview.tclZERO (Errors.UserError ("discr" , str"Not a discriminable equality."))
     | Inl (cpath, (_,dirn), _) ->
-	let sort = pf_apply get_type_of gls (pf_concl gls) in
-	discr_positions env sigma u eq_clause cpath dirn sort gls
-
-let onEquality with_evars tac (c,lbindc) gls =
-  let t = pf_type_of gls c in
-  let t' = try snd (pf_reduce_to_quantified_ind gls t) with UserError _ -> t in
-  let eq_clause = make_clenv_binding gls (c,t') lbindc in
-  let eq_clause' = clenv_pose_dependent_evars with_evars eq_clause in
+	let sort = pf_apply get_type_of gl concl in
+	discr_positions env sigma u eq_clause cpath dirn sort
+  end
+
+let onEquality with_evars tac (c,lbindc) =
+  Proofview.Goal.nf_enter begin fun gl ->
+  let type_of = pf_type_of gl in
+  let reduce_to_quantified_ind = pf_apply Tacred.reduce_to_quantified_ind gl in
+  let t = type_of c in
+  let t' = try snd (reduce_to_quantified_ind t) with UserError _ -> t in
+  let eq_clause = pf_apply make_clenv_binding gl (c,t') lbindc in
+  let eq_clause' = Clenvtac.clenv_pose_dependent_evars with_evars eq_clause in
   let eqn = clenv_type eq_clause' in
-  let eq,eq_args = find_this_eq_data_decompose gls eqn in
+  let (eq,u,eq_args) = find_this_eq_data_decompose gl eqn in
   tclTHEN
-    (Refiner.tclEVARS eq_clause'.evd)
-    (tac (eq,eqn,eq_args) eq_clause') gls
-
-let onNegatedEquality with_evars tac gls =
-  let ccl = pf_concl gls in
-  match kind_of_term (hnf_constr (pf_env gls) (project gls) ccl) with
-  | Prod (_,t,u) when is_empty_type u ->
-      tclTHEN introf
-        (onLastHypId (fun id ->
-          onEquality with_evars tac (mkVar id,NoBindings))) gls
-  | _ ->
-      errorlabstrm "" (str "Not a negated primitive equality.")
+    (Proofview.Unsafe.tclEVARS eq_clause'.evd)
+    (tac (eq,eqn,eq_args) eq_clause')
+  end
+
+let onNegatedEquality with_evars tac =
+  Proofview.Goal.nf_enter begin fun gl ->
+    let sigma = Proofview.Goal.sigma gl in
+    let ccl = Proofview.Goal.concl gl in
+    let env = Proofview.Goal.env gl in
+    match kind_of_term (hnf_constr env sigma ccl) with
+    | Prod (_,t,u) when is_empty_type u ->
+        tclTHEN introf
+          (onLastHypId (fun id ->
+            onEquality with_evars tac (mkVar id,NoBindings)))
+    | _ ->
+        Proofview.tclZERO (Errors.UserError ("" , str "Not a negated primitive equality."))
+  end
 
 let discrSimpleClause with_evars = function
   | None -> onNegatedEquality with_evars discrEq
@@ -842,25 +989,25 @@ let discrEverywhere with_evars =
     (if discr_do_intro () then
       (tclTHEN
 	(tclREPEAT introf)
-	(Tacticals.tryAllHyps
+	(tryAllHyps
           (fun id -> tclCOMPLETE (discr with_evars (mkVar id,NoBindings)))))
      else (* <= 8.2 compat *)
-       Tacticals.tryAllHypsAndConcl (discrSimpleClause with_evars))
+       tryAllHypsAndConcl (discrSimpleClause with_evars))
 (*    (fun gls ->
        errorlabstrm "DiscrEverywhere" (str"No discriminable equalities."))
 *)
 let discr_tac with_evars = function
   | None -> discrEverywhere with_evars
-  | Some c -> onInductionArg (discr with_evars) c
+  | Some c -> onInductionArg (fun clear_flag -> discr with_evars) c
 
-let discrConcl gls  = discrClause false onConcl gls
-let discrHyp id gls = discrClause false (onHyp id) gls
+let discrConcl = discrClause false onConcl
+let discrHyp id = discrClause false (onHyp id)
 
 (* returns the sigma type (sigS, sigT) with the respective
     constructor depending on the sort *)
 (* J.F.: correction du bug #1167 en accord avec Hugo. *)
 
-let find_sigma_data s = build_sigma_type ()
+let find_sigma_data env s = build_sigma_type ()
 
 (* [make_tuple env sigma (rterm,rty) lind] assumes [lind] is the lesser
    index bound in [rty]
@@ -874,16 +1021,18 @@ let find_sigma_data s = build_sigma_type ()
 
 let make_tuple env sigma (rterm,rty) lind =
   assert (dependent (mkRel lind) rty);
-  let {intro = exist_term; typ = sig_term} =
-    find_sigma_data (get_sort_of env sigma rty) in
-  let a = type_of env sigma (mkRel lind) in
+  let sigdata = find_sigma_data env (get_sort_of env sigma rty) in
+  let sigma, a = e_type_of ~refresh:true env sigma (mkRel lind) in
   let (na,_,_) = lookup_rel lind env in
   (* We move [lind] to [1] and lift other rels > [lind] by 1 *)
   let rty = lift (1-lind) (liftn lind (lind+1) rty) in
   (* Now [lind] is [mkRel 1] and we abstract on (na:a) *)
   let p = mkLambda (na, a, rty) in
-  (applist(exist_term,[a;p;(mkRel lind);rterm]),
-   applist(sig_term,[a;p]))
+  let sigma, exist_term = Evd.fresh_global env sigma sigdata.intro in
+  let sigma, sig_term = Evd.fresh_global env sigma sigdata.typ in
+    sigma,
+    (applist(exist_term,[a;p;(mkRel lind);rterm]),
+     applist(sig_term,[a;p]))
 
 (* check that the free-references of the type of [c] are contained in
    the free-references of the normal-form of that type. Strictly
@@ -896,7 +1045,7 @@ let minimal_free_rels env sigma (c,cty) =
   let cty_rels = free_rels cty in
   let cty' = simpl env sigma cty in
   let rels' = free_rels cty' in
-  if Intset.subset cty_rels rels' then
+  if Int.Set.subset cty_rels rels' then
     (cty,cty_rels)
   else
     (cty',rels')
@@ -906,10 +1055,10 @@ let minimal_free_rels env sigma (c,cty) =
 let minimal_free_rels_rec env sigma =
   let rec minimalrec_free_rels_rec prev_rels (c,cty) =
     let (cty,direct_rels) = minimal_free_rels env sigma (c,cty) in
-    let combined_rels = Intset.union prev_rels direct_rels in
+    let combined_rels = Int.Set.union prev_rels direct_rels in
     let folder rels i = snd (minimalrec_free_rels_rec rels (c, type_of env sigma (mkRel i)))
-    in (cty, List.fold_left folder combined_rels (Intset.elements (Intset.diff direct_rels prev_rels)))
-  in minimalrec_free_rels_rec Intset.empty
+    in (cty, List.fold_left folder combined_rels (Int.Set.elements (Int.Set.diff direct_rels prev_rels)))
+  in minimalrec_free_rels_rec Int.Set.empty
 
 (* [sig_clausal_form siglen ty]
 
@@ -948,22 +1097,23 @@ let minimal_free_rels_rec env sigma =
  *)
 
 let sig_clausal_form env sigma sort_of_ty siglen ty dflt =
-  let { intro = exist_term } = find_sigma_data sort_of_ty in
+  let sigdata = find_sigma_data env sort_of_ty in
   let evdref = ref (Evd.create_goal_evar_defs sigma) in
   let rec sigrec_clausal_form siglen p_i =
-    if siglen = 0 then
+    if Int.equal siglen 0 then
       (* is the default value typable with the expected type *)
       let dflt_typ = type_of env sigma dflt in
-      if Evarconv.e_cumul env evdref dflt_typ p_i then
-	(* the_conv_x had a side-effect on evdref *)
+      try
+	let () = evdref := Evarconv.the_conv_x_leq env dflt_typ p_i !evdref in
+	let () = evdref := Evarconv.consider_remaining_unif_problems env !evdref in
 	dflt
-      else
+      with Evarconv.UnableToUnify _ ->
 	error "Cannot solve a unification problem."
     else
       let (a,p_i_minus_1) = match whd_beta_stack !evdref p_i with
 	| (_sigS,[a;p]) -> (a,p)
- 	| _ -> anomaly "sig_clausal_form: should be a sigma type" in
-      let ev = Evarutil.e_new_evar evdref env a in
+ 	| _ -> anomaly ~label:"sig_clausal_form" (Pp.str "should be a sigma type") in
+      let ev = Evarutil.e_new_evar env evdref a in
       let rty = beta_applist(p_i_minus_1,[ev]) in
       let tuple_tail = sigrec_clausal_form (siglen-1) rty in
       match
@@ -973,13 +1123,14 @@ let sig_clausal_form env sigma sort_of_ty siglen ty dflt =
 	| Some w ->
             let w_type = type_of env sigma w in
             if Evarconv.e_cumul env evdref w_type a then
-              applist(exist_term,[w_type;p_i_minus_1;w;tuple_tail])
+	      let exist_term = Evarutil.evd_comb1 (Evd.fresh_global env) evdref sigdata.intro in
+              applist(exist_term,[a;p_i_minus_1;w;tuple_tail])
             else
               error "Cannot solve a unification problem."
-	| None -> anomaly "Not enough components to build the dependent tuple"
+	| None -> anomaly (Pp.str "Not enough components to build the dependent tuple")
   in
   let scf = sigrec_clausal_form siglen ty in
-  Evarutil.nf_evar !evdref scf
+    !evdref, Evarutil.nf_evar !evdref scf
 
 (* The problem is to build a destructor (a generalization of the
    predecessor) which, when applied to a term made of constructors
@@ -1012,7 +1163,7 @@ let sig_clausal_form env sigma sort_of_ty siglen ty dflt =
 
    If [zty] has no dependencies, this is simple. Otherwise, assume
    [zty] has free (de Bruijn) variables in,...i1 then the role of
-   [make_iterated_tuple sigma env (term,typ) (z,zty)] is to build the
+   [make_iterated_tuple env sigma (term,typ) (z,zty)] is to build the
    tuple
 
    [existT [xn]Pn Rel(in) .. (existT [x2]P2 Rel(i2) (existT [x1]P1 Rel(i1) z))]
@@ -1042,30 +1193,29 @@ let sig_clausal_form env sigma sort_of_ty siglen ty dflt =
 let make_iterated_tuple env sigma dflt (z,zty) =
   let (zty,rels) = minimal_free_rels_rec env sigma (z,zty) in
   let sort_of_zty = get_sort_of env sigma zty in
-  let sorted_rels = Sort.list (<) (Intset.elements rels) in
-  let (tuple,tuplety) =
-    List.fold_left (make_tuple env sigma) (z,zty) sorted_rels
+  let sorted_rels = Int.Set.elements rels in
+  let sigma, (tuple,tuplety) =
+    List.fold_left (fun (sigma, t) -> make_tuple env sigma t) (sigma, (z,zty)) sorted_rels
   in
   assert (closed0 tuplety);
   let n = List.length sorted_rels in
-  let dfltval = sig_clausal_form env sigma sort_of_zty n tuplety dflt in
-  (tuple,tuplety,dfltval)
+  let sigma, dfltval = sig_clausal_form env sigma sort_of_zty n tuplety dflt in
+    sigma, (tuple,tuplety,dfltval)
 
-let rec build_injrec sigma env dflt c = function
+let rec build_injrec env sigma dflt c = function
   | [] -> make_iterated_tuple env sigma dflt (c,type_of env sigma c)
   | ((sp,cnum),argnum)::l ->
     try
-      let (cnum_nlams,cnum_env,kont) = descend_then sigma env c cnum in
+      let (cnum_nlams,cnum_env,kont) = descend_then env sigma c cnum in
       let newc = mkRel(cnum_nlams-argnum) in
-      let (subval,tuplety,dfltval) = build_injrec sigma cnum_env dflt newc l in
-      (kont subval (dfltval,tuplety),
-      tuplety,dfltval)
+      let sigma, (subval,tuplety,dfltval) = build_injrec cnum_env sigma dflt newc l in
+	sigma, (kont subval (dfltval,tuplety), tuplety,dfltval)
     with
 	UserError _ -> failwith "caught"
 
-let build_injector sigma env dflt c cpath =
-  let (injcode,resty,_) = build_injrec sigma env dflt c cpath in
-  (injcode,resty)
+let build_injector env sigma dflt c cpath =
+  let sigma, (injcode,resty,_) = build_injrec env sigma dflt c cpath in
+    sigma, (injcode,resty)
 
 (*
 let try_delta_expand env sigma t =
@@ -1080,6 +1230,52 @@ let try_delta_expand env sigma t =
   hd_rec whdt
 *)
 
+let eq_dec_scheme_kind_name = ref (fun _ -> failwith "eq_dec_scheme undefined")
+let set_eq_dec_scheme_kind k = eq_dec_scheme_kind_name := (fun _ -> k)
+
+let eqdep_dec = qualid_of_string "Coq.Logic.Eqdep_dec"
+
+let inject_if_homogenous_dependent_pair ty =
+  Proofview.Goal.nf_enter begin fun gl ->
+  try
+    let eq,u,(t,t1,t2) = find_this_eq_data_decompose gl ty in
+    (* fetch the informations of the  pair *)
+    let ceq = Universes.constr_of_global Coqlib.glob_eq in
+    let sigTconstr () = (Coqlib.build_sigma_type()).Coqlib.typ in
+    let existTconstr () = (Coqlib.build_sigma_type()).Coqlib.intro in
+    (* check whether the equality deals with dep pairs or not *)
+    let eqTypeDest = fst (decompose_app t) in
+    if not (Globnames.is_global (sigTconstr()) eqTypeDest) then raise Exit;
+    let hd1,ar1 = decompose_app_vect t1 and
+        hd2,ar2 = decompose_app_vect t2 in
+    if not (Globnames.is_global (existTconstr()) hd1) then raise Exit;
+    if not (Globnames.is_global (existTconstr()) hd2) then raise Exit;
+    let ind,_ = try pf_apply find_mrectype gl ar1.(0) with Not_found -> raise Exit in
+    (* check if the user has declared the dec principle *)
+    (* and compare the fst arguments of the dep pair *)
+    (* Note: should work even if not an inductive type, but the table only *)
+    (* knows inductive types *)
+    if not (Ind_tables.check_scheme (!eq_dec_scheme_kind_name()) (fst ind) &&
+      pf_apply is_conv gl ar1.(2) ar2.(2)) then raise Exit;
+    Library.require_library [Loc.ghost,eqdep_dec] (Some false);
+    let new_eq_args = [|pf_type_of gl ar1.(3);ar1.(3);ar2.(3)|] in
+    let inj2 = Coqlib.coq_constant "inj_pair2_eq_dec is missing"
+      ["Logic";"Eqdep_dec"] "inj_pair2_eq_dec" in
+    let c, eff = find_scheme (!eq_dec_scheme_kind_name()) (Univ.out_punivs ind) in
+    (* cut with the good equality and prove the requested goal *)
+    tclTHENLIST
+      [Proofview.tclEFFECTS eff;
+       intro;
+       onLastHyp (fun hyp ->
+        tclTHENS (cut (mkApp (ceq,new_eq_args)))
+          [clear [destVar hyp];
+           Proofview.V82.tactic (refine
+             (mkApp(inj2,[|ar1.(0);mkConst c;ar1.(1);ar1.(2);ar1.(3);ar2.(3);hyp|])))
+          ])]
+  with Exit ->
+    Proofview.tclUNIT ()
+  end
+
 (* Given t1=t2 Inj calculates the whd normal forms of t1 and t2 and it
    expands then only when the whdnf has a constructor of an inductive type
    in hd position, otherwise delta expansion is not done *)
@@ -1091,141 +1287,114 @@ let simplify_args env sigma t =
     | eq, [t1;c1;t2;c2] -> applist (eq,[t1;simpl env sigma c1;t2;simpl env sigma c2])
     | _ -> t
 
-let inject_at_positions env sigma (eq,_,(t,t1,t2)) eq_clause posns tac =
+let inject_at_positions env sigma l2r (eq,_,(t,t1,t2)) eq_clause posns tac =
   let e = next_ident_away eq_baseid (ids_of_context env) in
-  let e_env = push_named (e,None,t) env in
-  let injectors =
-    map_succeed
-      (fun (cpath,t1',t2') ->
-        (* arbitrarily take t1' as the injector default value *)
-	let (injbody,resty) = build_injector sigma e_env t1' (mkVar e) cpath in
-	let injfun = mkNamedLambda e t injbody in
-	let pf = applist(eq.congr,[t;resty;injfun;t1;t2]) in
-	let pf_typ = get_type_of env sigma pf in
-	let inj_clause = apply_on_clause (pf,pf_typ) eq_clause in
-        let pf = clenv_value_cast_meta inj_clause in
-	let ty = simplify_args env sigma (clenv_type inj_clause) in
-	(pf,ty))
-      posns in
-  if injectors = [] then
-    errorlabstrm "Equality.inj" (str "Failed to decompose the equality.");
-  tclTHEN
-    (tclMAP
-      (fun (pf,ty) -> tclTHENS (cut ty) [tclIDTAC; refine pf])
-      injectors)
-    (tac (List.length injectors))
-
-exception Not_dep_pair
-
-let eq_dec_scheme_kind_name = ref (fun _ -> failwith "eq_dec_scheme undefined")
-let set_eq_dec_scheme_kind k = eq_dec_scheme_kind_name := (fun _ -> k)
-
-let injEq ipats (eq,_,(t,t1,t2) as u) eq_clause =
+  let e_env = push_named (e, None,t) env in
+  let evdref = ref sigma in
+  let filter (cpath, t1', t2') =
+    try
+      (* arbitrarily take t1' as the injector default value *)
+      let sigma, (injbody,resty) = build_injector e_env !evdref t1' (mkVar e) cpath in
+      let injfun = mkNamedLambda e t injbody in
+      let sigma,congr = Evd.fresh_global env sigma eq.congr in
+      let pf = applist(congr,[t;resty;injfun;t1;t2]) in
+      let sigma, pf_typ = Typing.e_type_of env sigma pf in
+      let inj_clause = apply_on_clause (pf,pf_typ) eq_clause in
+      let pf = Clenvtac.clenv_value_cast_meta inj_clause in
+      let ty = simplify_args env sigma (clenv_type inj_clause) in
+	evdref := sigma;
+	Some (pf, ty)
+    with Failure _ -> None
+  in
+  let injectors = List.map_filter filter posns in
+  if List.is_empty injectors then
+    Proofview.tclZERO (Errors.UserError ("Equality.inj" , str "Failed to decompose the equality."))
+  else
+    Proofview.tclTHEN (Proofview.Unsafe.tclEVARS !evdref)
+    (Proofview.tclBIND
+      (Proofview.Monad.List.map
+         (fun (pf,ty) -> tclTHENS (cut ty)
+           [inject_if_homogenous_dependent_pair ty;
+            Proofview.V82.tactic (refine pf)])
+         (if l2r then List.rev injectors else injectors))
+      (fun _ -> tac (List.length injectors)))
+
+let injEqThen tac l2r (eq,_,(t,t1,t2) as u) eq_clause =
   let sigma = eq_clause.evd in
   let env = eq_clause.env in
   match find_positions env sigma t1 t2 with
-    | Inl _ ->
-	errorlabstrm "Inj"
-	  (str"Not a projectable equality but a discriminable one.")
-    | 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
-	let t2 = try_delta_expand env sigma t2 in
-*)
-        try (
-(* fetch the informations of the  pair *)
-        let ceq = constr_of_global Coqlib.glob_eq in
-        let sigTconstr () = (Coqlib.build_sigma_type()).Coqlib.typ in
-        let eqTypeDest = fst (destApp t) in
-        let _,ar1 = destApp t1 and
-            _,ar2 = destApp t2 in
-        let ind = destInd ar1.(0) in
-        let inj2 = Coqlib.coq_constant "inj_pair2_eq_dec is missing"
-            ["Logic";"Eqdep_dec"] "inj_pair2_eq_dec" in
-(* check whether the equality deals with dep pairs or not *)
-(* if yes, check if the user has declared the dec principle *)
-(* and compare the fst arguments of the dep pair *)
-        let new_eq_args = [|type_of env sigma (ar1.(3));ar1.(3);ar2.(3)|] in
-        if ( (eqTypeDest = sigTconstr()) &&
-             (Ind_tables.check_scheme (!eq_dec_scheme_kind_name()) ind=true) &&
-             (is_conv env sigma (ar1.(2)) (ar2.(2)) = true))
-              then (
-(* Require Import Eqdec_dec copied from vernac_require in vernacentries.ml*)
-              let qidl = qualid_of_reference
-                (Ident (dummy_loc,id_of_string "Eqdep_dec")) in
-              Library.require_library [qidl] (Some false);
-(* cut with the good equality and prove the requested goal *)
-              tclTHENS (cut (mkApp (ceq,new_eq_args)) )
-               [tclIDTAC; tclTHEN (apply (
-                  mkApp(inj2,
-                        [|ar1.(0);mkConst (find_scheme (!eq_dec_scheme_kind_name()) ind);
-                          ar1.(1);ar1.(2);ar1.(3);ar2.(3)|])
-                  )) (Auto.trivial [] [])
-                ]
-(* not a dep eq or no decidable type found *)
-            ) else (raise Not_dep_pair)
-        ) with e when Errors.noncritical e ->
-	  inject_at_positions env sigma u eq_clause posns
-	    (fun _ -> intros_pattern no_move ipats)
-
-let inj ipats with_evars = onEquality with_evars (injEq ipats)
+  | Inl _ ->
+     Proofview.tclZERO (Errors.UserError ("Inj",strbrk"This equality is discriminable. You should use the discriminate tactic to solve the goal."))
+  | Inr [] ->
+     let suggestion = if !injection_on_proofs then "" else " You can try to use option Set Injection On Proofs." in
+     Proofview.tclZERO (Errors.UserError ("Equality.inj",strbrk("No information can be deduced from this equality and the injectivity of constructors. This may be because the terms are convertible, or due to pattern matching restrictions in the sort Prop." ^ suggestion)))
+  | Inr [([],_,_)] when Flags.version_strictly_greater Flags.V8_3 ->
+     Proofview.tclZERO (Errors.UserError ("Equality.inj" , str"Nothing to inject."))
+  | Inr posns ->
+      inject_at_positions env sigma l2r u eq_clause posns
+	(tac (clenv_value eq_clause))
+
+let use_clear_hyp_by_default () = false
+
+let postInjEqTac clear_flag ipats c n =
+  match ipats with
+  | Some ipats ->
+      let clear_tac =
+        let dft =
+          use_injection_pattern_l2r_order () || use_clear_hyp_by_default () in
+        tclTRY (apply_clear_request clear_flag dft c) in
+      let intro_tac =
+        if use_injection_pattern_l2r_order ()
+        then intro_patterns_bound_to n MoveLast ipats
+        else intro_patterns_to MoveLast ipats in
+      tclTHEN clear_tac intro_tac
+  | None -> tclIDTAC
+
+let injEq clear_flag ipats =
+  let l2r =
+    if use_injection_pattern_l2r_order () && not (Option.is_empty ipats) then true else false
+  in
+  injEqThen (fun c i -> postInjEqTac clear_flag ipats c i) l2r
+
+let inj ipats with_evars clear_flag = onEquality with_evars (injEq clear_flag ipats)
 
 let injClause ipats with_evars = function
-  | None -> onNegatedEquality with_evars (injEq ipats)
+  | None -> onNegatedEquality with_evars (injEq None ipats)
   | Some c -> onInductionArg (inj ipats with_evars) c
 
-let injConcl gls  = injClause [] false None gls
-let injHyp id gls = injClause [] false (Some (ElimOnIdent (dummy_loc,id))) gls
-
-let decompEqThen ntac (lbeq,_,(t,t1,t2) as u) clause gls =
-  let sort = pf_apply get_type_of gls (pf_concl gls) in
-  let sigma =  clause.evd in
-  let env = pf_env gls in
-  match find_positions env sigma t1 t2 with
-    | Inl (cpath, (_,dirn), _) ->
-	discr_positions env sigma u clause cpath dirn sort gls
-    | Inr [] -> (* Change: do not fail, simplify clear this trivial hyp *)
-        ntac 0 gls
+let injConcl = injClause None false None
+let injHyp clear_flag id = injClause None false (Some (clear_flag,ElimOnIdent (Loc.ghost,id)))
+
+let decompEqThen ntac (lbeq,_,(t,t1,t2) as u) clause =
+  Proofview.Goal.nf_enter begin fun gl ->
+    let sort = pf_apply get_type_of gl (Proofview.Goal.concl gl) in
+    let sigma =  clause.evd in
+    let env = Proofview.Goal.env gl in
+      match find_positions env sigma t1 t2 with
+      | Inl (cpath, (_,dirn), _) ->
+	  discr_positions env sigma u clause cpath dirn sort
+      | Inr [] -> (* Change: do not fail, simplify clear this trivial hyp *)
+        ntac (clenv_value clause) 0
     | Inr posns ->
-	inject_at_positions env sigma u clause (List.rev posns) ntac gls
+	inject_at_positions env sigma true u clause posns
+          (ntac (clenv_value clause))
+  end
 
 let dEqThen with_evars ntac = function
-  | None -> onNegatedEquality with_evars (decompEqThen ntac)
-  | Some c -> onInductionArg (onEquality with_evars (decompEqThen ntac)) c
-
-let dEq with_evars = dEqThen with_evars (fun x -> tclIDTAC)
-
-let swap_equality_args = function
-  | MonomorphicLeibnizEq (e1,e2) -> [e2;e1]
-  | PolymorphicLeibnizEq (t,e1,e2) -> [t;e2;e1]
-  | HeterogenousEq (t1,e1,t2,e2) -> [t2;e2;t1;e1]
-
-let swap_equands gls eqn =
-  let (lbeq,eq_args) = find_eq_data eqn in
-  applist(lbeq.eq,swap_equality_args eq_args)
-
-let swapEquandsInConcl gls =
-  let (lbeq,eq_args) = find_eq_data (pf_concl gls) in
-  let sym_equal = lbeq.sym in
-  refine
-    (applist(sym_equal,(swap_equality_args eq_args@[Evarutil.mk_new_meta()])))
-    gls
-
-(* Refine from [|- P e2] to [|- P e1] and [|- e1=e2:>t] (body is P (Rel 1)) *)
-
-let bareRevSubstInConcl lbeq body (t,e1,e2) gls =
-  (* find substitution scheme *)
-  let eq_elim = find_elim lbeq.eq (Some false) false None None gls in
-  (* build substitution predicate *)
-  let p = lambda_create (pf_env gls) (t,body) in
-  (* apply substitution scheme *)
-  refine (applist(eq_elim,[t;e1;p;Evarutil.mk_new_meta();
-                           e2;Evarutil.mk_new_meta()])) gls
+  | None -> onNegatedEquality with_evars (decompEqThen (ntac None))
+  | Some c -> onInductionArg (fun clear_flag -> onEquality with_evars (decompEqThen (ntac clear_flag))) c
+
+let dEq with_evars =
+  dEqThen with_evars (fun clear_flag c x ->
+    (apply_clear_request clear_flag (use_clear_hyp_by_default ()) c))
+
+let intro_decompe_eq tac data cl =
+  Proofview.Goal.enter begin fun gl ->
+    let cl = pf_apply make_clenv_binding gl cl NoBindings in
+    decompEqThen (fun _ -> tac) data cl
+  end
+
+let _ = declare_intro_decomp_eq intro_decompe_eq
 
 (* [subst_tuple_term dep_pair B]
 
@@ -1263,17 +1432,15 @@ let decomp_tuple_term env c t =
   let rec decomprec inner_code ex exty =
     let iterated_decomp =
     try
-      let {proj1=p1; proj2=p2},(a,p,car,cdr) = find_sigma_data_decompose ex in
-      let car_code = applist (p1,[a;p;inner_code])
-      and cdr_code = applist (p2,[a;p;inner_code]) in
+      let ({proj1=p1; proj2=p2}),(i,a,p,car,cdr) = find_sigma_data_decompose ex in
+      let car_code = applist (mkConstU (destConstRef p1,i),[a;p;inner_code])
+      and cdr_code = applist (mkConstU (destConstRef p2,i),[a;p;inner_code]) in
       let cdrtyp = beta_applist (p,[car]) in
       List.map (fun l -> ((car,a),car_code)::l) (decomprec cdr_code cdr cdrtyp)
-    with PatternMatchingFailure ->
+    with Constr_matching.PatternMatchingFailure ->
       []
-    in
-    [((ex,exty),inner_code)]::iterated_decomp
-  in
-  decomprec (mkRel 1) c t
+    in [((ex,exty),inner_code)]::iterated_decomp
+  in decomprec (mkRel 1) c t
 
 let subst_tuple_term env sigma dep_pair1 dep_pair2 b =
   let typ = get_type_of env sigma dep_pair1 in
@@ -1293,78 +1460,80 @@ let subst_tuple_term env sigma dep_pair1 dep_pair2 b =
     List.fold_right
       (fun (e,t) body -> lambda_create env (t,subst_term e body)) e1_list b in
   let pred_body = beta_applist(abst_B,proj_list) in
+  let body = mkApp (lambda_create env (typ,pred_body),[|dep_pair1|]) in
   let expected_goal = beta_applist (abst_B,List.map fst e2_list) in
   (* Simulate now the normalisation treatment made by Logic.mk_refgoals *)
   let expected_goal = nf_betaiota sigma expected_goal in
-  pred_body,expected_goal
+  (* Retype to get universes right *)
+  let sigma, expected_goal_ty = Typing.e_type_of env sigma expected_goal in
+  let sigma, _ = Typing.e_type_of env sigma body in
+    sigma,body,expected_goal
 
-(* Like "replace" but decompose dependent equalities *)
+(* Like "replace" but decompose dependent equalities                      *)
+(* i.e. if equality is "exists t v = exists u w", and goal is "phi(t,u)", *)
+(* then it uses the predicate "\x.phi(proj1_sig x,proj2_sig x)", and so   *)
+(* on for further iterated sigma-tuples                                   *)
 
 exception NothingToRewrite
 
-let cutSubstInConcl_RL eqn gls =
-  let (lbeq,(t,e1,e2 as eq)) = find_eq_data_decompose gls eqn in
-  let body,expected_goal = pf_apply subst_tuple_term gls e2 e1 (pf_concl gls) in
-  if not (dependent (mkRel 1) body) then raise NothingToRewrite;
+let cutSubstInConcl l2r eqn =
+  Proofview.Goal.nf_enter begin fun gl ->
+  let (lbeq,u,(t,e1,e2)) = find_eq_data_decompose gl eqn in
+  let typ = pf_concl gl in
+  let (e1,e2) = if l2r then (e1,e2) else (e2,e1) in
+  let sigma,typ,expected = pf_apply subst_tuple_term gl e1 e2 typ in
   tclTHENFIRST
-    (bareRevSubstInConcl lbeq body eq)
-    (convert_concl expected_goal DEFAULTcast) gls
+    (tclTHENLIST [
+       (Proofview.Unsafe.tclEVARS sigma);
+       (change_concl typ); (* Put in pattern form *)
+       (replace_core onConcl l2r eqn)
+    ])
+    (change_concl expected) (* Put in normalized form *)
+   end
+
+let cutSubstInHyp l2r eqn id =
+  Proofview.Goal.nf_enter begin fun gl ->
+  let (lbeq,u,(t,e1,e2)) = find_eq_data_decompose gl eqn in
+  let typ = pf_get_hyp_typ id gl in
+  let (e1,e2) = if l2r then (e1,e2) else (e2,e1) in
+  let sigma,typ,expected = pf_apply subst_tuple_term gl e1 e2 typ in
+  tclTHENFIRST
+    (tclTHENLIST [
+       (Proofview.Unsafe.tclEVARS sigma);
+       (change_in_hyp None (fun s -> s,typ) (id,InHypTypeOnly));
+       (replace_core (onHyp id) l2r eqn)
+    ])
+    (change_in_hyp None (fun s -> s,expected) (id,InHypTypeOnly))
+  end
 
-(* |- (P e1)
-     BY CutSubstInConcl_LR (eq T e1 e2)
-     |- (P e2)
-     |- (eq T e1 e2)
- *)
-let cutSubstInConcl_LR eqn gls =
-  (tclTHENS (cutSubstInConcl_RL (swap_equands gls eqn))
-     ([tclIDTAC;
-       swapEquandsInConcl])) gls
-
-let cutSubstInConcl l2r =if l2r then cutSubstInConcl_LR else cutSubstInConcl_RL
-
-let cutSubstInHyp_LR eqn id gls =
-  let (lbeq,(t,e1,e2 as eq)) = find_eq_data_decompose gls eqn in
-  let idtyp = pf_get_hyp_typ gls id in
-  let body,expected_goal = pf_apply subst_tuple_term gls e1 e2 idtyp in
-  if not (dependent (mkRel 1) body) then raise NothingToRewrite;
-  cut_replacing id expected_goal
-    (tclTHENFIRST
-      (bareRevSubstInConcl lbeq body eq)
-      (refine_no_check (mkVar id))) gls
-
-let cutSubstInHyp_RL eqn id gls =
-  (tclTHENS (cutSubstInHyp_LR (swap_equands gls eqn) id)
-     ([tclIDTAC;
-       swapEquandsInConcl])) gls
-
-let cutSubstInHyp l2r = if l2r then cutSubstInHyp_LR else cutSubstInHyp_RL
-
-let try_rewrite tac gls =
-  try
-    tac gls
-  with
-    | PatternMatchingFailure ->
-	errorlabstrm "try_rewrite" (str "Not a primitive equality here.")
+let try_rewrite tac =
+  Proofview.tclORELSE tac begin function (e, info) -> match e with
+    | Constr_matching.PatternMatchingFailure ->
+	tclZEROMSG (str "Not a primitive equality here.")
     | e when catchable_exception e ->
-	errorlabstrm "try_rewrite"
+	tclZEROMSG
           (strbrk "Cannot find a well-typed generalization of the goal that makes the proof progress.")
     | NothingToRewrite ->
-	errorlabstrm "try_rewrite"
+	tclZEROMSG
           (strbrk "Nothing to rewrite.")
+    | e -> Proofview.tclZERO ~info e
+  end
 
-let cutSubstClause l2r eqn cls gls =
+let cutSubstClause l2r eqn cls =
   match cls with
-    | None ->    cutSubstInConcl l2r eqn gls
-    | Some id -> cutSubstInHyp l2r eqn id gls
+    | None ->    cutSubstInConcl l2r eqn
+    | Some id -> cutSubstInHyp l2r eqn id
 
 let cutRewriteClause l2r eqn cls = try_rewrite (cutSubstClause l2r eqn cls)
 let cutRewriteInHyp l2r eqn id = cutRewriteClause l2r eqn (Some id)
 let cutRewriteInConcl l2r eqn = cutRewriteClause l2r eqn None
 
-let substClause l2r c cls gls =
-  let eq = pf_apply get_type_of gls c in
+let substClause l2r c cls =
+  Proofview.Goal.enter begin fun gl ->
+  let eq = pf_apply get_type_of gl c in
   tclTHENS (cutSubstClause l2r eq cls)
-    [tclIDTAC; exact_no_check c] gls
+    [Proofview.tclUNIT (); Proofview.V82.tactic (exact_no_check c)]
+  end
 
 let rewriteClause l2r c cls = try_rewrite (substClause l2r c cls)
 let rewriteInHyp l2r c id = rewriteClause l2r c (Some id)
@@ -1389,100 +1558,102 @@ user = raise user error specific to rewrite
 (**********************************************************************)
 (* Substitutions tactics (JCF) *)
 
-let unfold_body x gl =
-  let hyps = pf_hyps gl in
-  let xval =
-    match Sign.lookup_named x hyps with
-        (_,Some xval,_) -> xval
-      | _ -> errorlabstrm "unfold_body"
-          (pr_id x ++ str" is not a defined hypothesis.") in
-  let aft = afterHyp x gl in
+let unfold_body x =
+  Proofview.Goal.enter begin fun gl ->
+  (** We normalize the given hypothesis immediately. *)
+  let hyps = Proofview.Goal.hyps (Proofview.Goal.assume gl) in
+  let (_, xval, _) = Context.lookup_named x hyps in
+  let xval = match xval with
+  | None -> errorlabstrm "unfold_body"
+    (pr_id x ++ str" is not a defined hypothesis.")
+  | Some xval -> pf_nf_evar gl xval
+  in
+  afterHyp x begin fun aft ->
   let hl = List.fold_right (fun (y,yval,_) cl -> (y,InHyp) :: cl) aft [] in
   let xvar = mkVar x in
   let rfun _ _ c = replace_term xvar xval c in
-  tclTHENLIST
-    [tclMAP (fun h -> reduct_in_hyp rfun h) hl;
-     reduct_in_concl (rfun,DEFAULTcast)] gl
-
-
+  let reducth h = Proofview.V82.tactic (fun gl -> reduct_in_hyp rfun h gl) in
+  let reductc = Proofview.V82.tactic (fun gl -> reduct_in_concl (rfun, DEFAULTcast) gl) in
+  tclTHENLIST [tclMAP reducth hl; reductc]
+  end
+  end
 
 let restrict_to_eq_and_identity eq = (* compatibility *)
-  if eq <> constr_of_global glob_eq && eq <> constr_of_global glob_identity then
-    raise PatternMatchingFailure
+  if not (is_global glob_eq eq) &&
+    not (is_global glob_identity eq) 
+  then raise Constr_matching.PatternMatchingFailure
 
-exception FoundHyp of (identifier * constr * bool)
+exception FoundHyp of (Id.t * constr * bool)
 
 (* tests whether hyp [c] is [x = t] or [t = x], [x] not occuring in [t] *)
 let is_eq_x gl x (id,_,c) =
   try
-    let (_,lhs,rhs) = snd (find_eq_data_decompose gl c) in
-    if (eq_constr x lhs) && not (occur_term x rhs) then raise (FoundHyp (id,rhs,true));
-    if (eq_constr x rhs) && not (occur_term x lhs) then raise (FoundHyp (id,lhs,false))
-  with PatternMatchingFailure ->
+    let c = pf_nf_evar gl c in
+    let (_,lhs,rhs) = pi3 (find_eq_data_decompose gl c) in
+    if (Term.eq_constr x lhs) && not (occur_term x rhs) then raise (FoundHyp (id,rhs,true));
+    if (Term.eq_constr x rhs) && not (occur_term x lhs) then raise (FoundHyp (id,lhs,false))
+  with Constr_matching.PatternMatchingFailure ->
     ()
 
 (* 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 =
+let subst_one dep_proof_ok x (hyp,rhs,dir) =
+  Proofview.Goal.nf_enter begin fun gl ->
+  let env = Proofview.Goal.env gl in
+  let hyps = Proofview.Goal.hyps gl in
+  let concl = Proofview.Goal.concl gl in
   (* 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 (pf_hyps gl)) in
-  let dephyps = List.map (fun (id,_,_) -> id) depdecls in
+  let dephyps =
+    List.rev (snd (List.fold_right (fun (id,b,_ as dcl) (deps,allhyps) ->
+      if not (Id.equal id hyp)
+         && List.exists (fun y -> occur_var_in_decl env y dcl) deps
+      then
+        ((if b = None then deps else id::deps), id::allhyps)
+      else
+        (deps,allhyps))
+      hyps
+      ([x],[]))) in
   (* Decides if x appears in conclusion *)
-  let depconcl = occur_var (pf_env gl) x (pf_concl gl) in
-  (* The set of non-defined hypothesis: they must be abstracted,
-     rewritten and reintroduced *)
-  let abshyps =
-    map_succeed
-      (fun (id,v,_) -> if v=None then mkVar id else failwith "caught")
-      depdecls in
-  (* a tactic that either introduce an abstracted and rewritten hyp,
-     or introduce a definition where x was replaced *)
-  let introtac = function
-      (id,None,_) -> intro_using id
-    | (id,Some hval,htyp) ->
-        letin_tac None (Name id)
-	  (replace_term (mkVar x) rhs hval)
-	  (Some (replace_term (mkVar x) rhs htyp)) nowhere
-  in
-  let need_rewrite = dephyps <> [] || depconcl in
+  let depconcl = occur_var env x concl in
+  let need_rewrite = not (List.is_empty dephyps) || depconcl in
   tclTHENLIST
     ((if need_rewrite then
-      [generalize abshyps;
-       general_rewrite dir all_occurrences true dep_proof_ok (mkVar hyp);
-       thin dephyps;
-       tclMAP introtac depdecls]
+      [revert dephyps;
+       general_rewrite dir AllOccurrences true dep_proof_ok (mkVar hyp);
+       (tclMAP intro_using dephyps)]
       else
-       [tclIDTAC]) @
-     [tclTRY (clear [x;hyp])]) gl
+       [Proofview.tclUNIT ()]) @
+     [tclTRY (clear [x; hyp])])
+  end
 
 (* 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_one_var dep_proof_ok x =
+  Proofview.Goal.enter begin fun gl ->
+    let gl = Proofview.Goal.assume gl in
+    let (_,xval,_) = pf_get_hyp x gl in
+    (* If x has a body, simply replace x with body and clear x *)
+    if not (Option.is_empty xval) then tclTHEN (unfold_body x) (clear [x]) else
+      (* x is a variable: *)
+      let varx = mkVar x in
+      (* Find a non-recursive definition for x *)
+      let res =
+        try
+          (** [is_eq_x] ensures nf_evar on its side *)
+          let hyps = Proofview.Goal.hyps gl in
+          let test hyp _ = is_eq_x gl varx hyp in
+          Context.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 res
+  end
 
 let subst_gen dep_proof_ok ids =
-  tclTHEN tclNORMEVAR (tclMAP (subst_one_var dep_proof_ok) ids)
+  tclTHEN Proofview.V82.nf_evar_goals (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
@@ -1501,67 +1672,82 @@ let default_subst_tactic_flags () =
   else
     { only_leibniz = true; rewrite_dependent_proof = false }
 
-let subst_all ?(flags=default_subst_tactic_flags ()) gl =
+let subst_all ?(flags=default_subst_tactic_flags ()) () =
+  Proofview.Goal.nf_enter begin fun gl ->
+  let find_eq_data_decompose = find_eq_data_decompose gl in
   let test (_,c) =
     try
-      let lbeq,(_,x,y) = find_eq_data_decompose gl c in
-      if flags.only_leibniz then restrict_to_eq_and_identity lbeq.eq;
+      let lbeq,u,(_,x,y) = find_eq_data_decompose c in
+      let eq = Universes.constr_of_global_univ (lbeq.eq,u) in
+      if flags.only_leibniz then restrict_to_eq_and_identity eq;
       (* J.F.: added to prevent failure on goal containing x=x as an hyp *)
-      if eq_constr x y then failwith "caught";
+      if Term.eq_constr x y then failwith "caught";
       match kind_of_term x with Var x -> x | _ ->
       match kind_of_term y with Var y -> y | _ -> failwith "caught"
-    with PatternMatchingFailure -> failwith "caught"
+    with Constr_matching.PatternMatchingFailure -> failwith "caught"
   in
-  let ids = map_succeed test (pf_hyps_types gl) in
-  let ids = list_uniquize ids in
-  subst_gen flags.rewrite_dependent_proof ids gl
+  let test p = try Some (test p) with Failure _ -> None in
+  let hyps = pf_hyps_types gl in
+  let ids = List.map_filter test hyps in
+  let ids = List.uniquize ids in
+  subst_gen flags.rewrite_dependent_proof ids
+  end
 
-(* Rewrite the first assumption for which the condition faildir does not fail
+(* Rewrite the first assumption for which a condition holds
    and gives the direction of the rewrite *)
 
 let cond_eq_term_left c t gl =
   try
-    let (_,x,_) = snd (find_eq_data_decompose gl t) in
+    let (_,x,_) = pi3 (find_eq_data_decompose gl t) in
     if pf_conv_x gl c x then true else failwith "not convertible"
-  with PatternMatchingFailure -> failwith "not an equality"
+  with Constr_matching.PatternMatchingFailure -> failwith "not an equality"
 
 let cond_eq_term_right c t gl =
   try
-    let (_,_,x) = snd (find_eq_data_decompose gl t) in
+    let (_,_,x) = pi3 (find_eq_data_decompose gl t) in
     if pf_conv_x gl c x then false else failwith "not convertible"
-  with PatternMatchingFailure -> failwith "not an equality"
+  with Constr_matching.PatternMatchingFailure -> failwith "not an equality"
 
 let cond_eq_term c t gl =
   try
-    let (_,x,y) = snd (find_eq_data_decompose gl t) in
+    let (_,x,y) = pi3 (find_eq_data_decompose gl t) in
     if pf_conv_x gl c x then true
     else if pf_conv_x gl c y then false
     else failwith "not convertible"
-  with PatternMatchingFailure -> failwith "not an equality"
+  with Constr_matching.PatternMatchingFailure -> failwith "not an equality"
 
-let rewrite_multi_assumption_cond cond_eq_term cl gl =
-  let rec arec = function
+let rewrite_assumption_cond cond_eq_term cl =
+  let rec arec hyps gl = match hyps with
     | [] -> error "No such assumption."
     | (id,_,t) ::rest ->
 	begin
 	  try
-	    let dir = cond_eq_term t gl in
-	    general_multi_rewrite dir false (mkVar id,NoBindings) cl gl
-	  with | Failure _ | UserError _ -> arec rest
+            let dir = cond_eq_term t gl in
+	    general_rewrite_clause dir false (mkVar id,NoBindings) cl
+	  with | Failure _ | UserError _ -> arec rest gl
 	end
   in
-  arec (pf_hyps gl)
+  Proofview.Goal.nf_enter begin fun gl ->
+    let hyps = Proofview.Goal.hyps gl in
+    arec hyps gl
+  end
 
-let replace_multi_term dir_opt c  =
+(* Generalize "subst x" to substitution of subterm appearing as an
+   equation in the context, but not clearing the hypothesis *)
+
+let replace_term dir_opt c  =
   let cond_eq_fun =
     match dir_opt with
       | None -> cond_eq_term c
       | Some true -> cond_eq_term_left c
       | Some false -> cond_eq_term_right c
   in
-  rewrite_multi_assumption_cond cond_eq_fun
+  rewrite_assumption_cond cond_eq_fun
+
+(* Declare rewriting tactic for intro patterns "<-" and "->" *)
 
-let _ = Tactics.register_general_multi_rewrite
-  (fun b evars t cls -> general_multi_rewrite b evars t cls)
+let _ =
+  let gmr l2r with_evars tac c = general_rewrite_clause l2r with_evars tac c in
+  Hook.set Tactics.general_rewrite_clause gmr
 
-let _ = Tactics.register_subst_one (fun b -> subst_one b)
+let _ = Hook.set Tactics.subst_one subst_one
diff --git a/tactics/equality.mli b/tactics/equality.mli
index 75a59e6d..90d8a224 100644
--- a/tactics/equality.mli
+++ b/tactics/equality.mli
@@ -1,29 +1,21 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
 (*i*)
-open Util
 open Names
 open Term
-open Sign
 open Evd
 open Environ
-open Proof_type
 open Tacmach
-open Hipattern
-open Pattern
-open Tacticals
-open Tactics
 open Tacexpr
-open Termops
-open Glob_term
-open Genarg
 open Ind_tables
+open Locus
+open Misctypes
 (*i*)
 
 type dep_proof_flag = bool (* true = support rewriting dependent proofs *)
@@ -38,101 +30,91 @@ type conditions =
 
 val general_rewrite_bindings :
   orientation -> occurrences -> freeze_evars_flag -> dep_proof_flag ->
-  ?tac:(tactic * conditions) -> constr with_bindings -> evars_flag -> tactic
+  ?tac:(unit Proofview.tactic * conditions) -> constr with_bindings -> evars_flag -> unit Proofview.tactic
 val general_rewrite :
   orientation -> occurrences -> freeze_evars_flag -> dep_proof_flag ->
-  ?tac:(tactic * conditions) -> constr -> tactic
+  ?tac:(unit Proofview.tactic * conditions) -> constr -> unit Proofview.tactic
 
 (* Equivalent to [general_rewrite l2r] *)
-val rewriteLR : ?tac:(tactic * conditions) -> constr -> tactic
-val rewriteRL : ?tac:(tactic * conditions) -> constr  -> tactic
+val rewriteLR : ?tac:(unit Proofview.tactic * conditions) -> constr -> unit Proofview.tactic
+val rewriteRL : ?tac:(unit Proofview.tactic * conditions) -> constr  -> unit Proofview.tactic
 
 (* Warning: old [general_rewrite_in] is now [general_rewrite_bindings_in] *)
 
-val register_general_rewrite_clause :
-  (identifier option -> orientation ->
-    occurrences -> constr with_bindings -> new_goals:constr list -> tactic) -> unit
-val register_is_applied_rewrite_relation : (env -> evar_map -> rel_context -> constr -> constr option) -> unit
+val general_setoid_rewrite_clause :
+  (Id.t option -> orientation -> occurrences -> constr with_bindings ->
+   new_goals:constr list -> unit Proofview.tactic) Hook.t
 
-val general_rewrite_ebindings_clause : identifier option ->
+val general_rewrite_ebindings_clause : Id.t option ->
   orientation -> occurrences -> freeze_evars_flag -> dep_proof_flag ->
-  ?tac:(tactic * conditions) -> constr with_bindings -> evars_flag -> tactic
+  ?tac:(unit Proofview.tactic * conditions) -> constr with_bindings -> evars_flag -> unit Proofview.tactic
 
 val general_rewrite_bindings_in :
   orientation -> occurrences -> freeze_evars_flag -> dep_proof_flag ->
-  ?tac:(tactic * conditions) ->
-  identifier -> constr with_bindings -> evars_flag -> tactic
+  ?tac:(unit Proofview.tactic * conditions) ->
+  Id.t -> constr with_bindings -> evars_flag -> unit Proofview.tactic
 val general_rewrite_in          :
   orientation -> occurrences -> freeze_evars_flag -> dep_proof_flag -> 
-  ?tac:(tactic * conditions) -> identifier -> constr -> evars_flag -> tactic
+  ?tac:(unit Proofview.tactic * conditions) -> Id.t -> constr -> evars_flag -> unit Proofview.tactic
+
+val general_rewrite_clause :
+  orientation -> evars_flag -> ?tac:(unit Proofview.tactic * conditions) -> constr with_bindings -> clause -> unit Proofview.tactic
 
 val general_multi_rewrite :
-  orientation -> evars_flag -> ?tac:(tactic * conditions) -> constr with_bindings -> clause -> tactic
-
-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 ->
-    clause -> (tactic * conditions) option -> tactic
-
-val replace_in_clause_maybe_by : constr -> constr -> clause -> tactic option -> tactic
-val replace    : constr -> constr -> tactic
-val replace_in : identifier -> constr -> constr -> tactic
-val replace_by : constr -> constr -> tactic -> tactic
-val replace_in_by : identifier -> constr -> constr -> tactic -> tactic
-
-val discr        : evars_flag -> constr with_bindings -> tactic
-val discrConcl   : tactic
-val discrClause  : evars_flag -> clause -> tactic
-val discrHyp     : identifier -> tactic
-val discrEverywhere : evars_flag -> tactic
+  evars_flag -> (bool * multi * clear_flag * delayed_open_constr_with_bindings) list ->
+    clause -> (unit Proofview.tactic * conditions) option -> unit Proofview.tactic
+
+val replace_in_clause_maybe_by : constr -> constr -> clause -> unit Proofview.tactic option -> unit Proofview.tactic
+val replace    : constr -> constr -> unit Proofview.tactic
+val replace_by : constr -> constr -> unit Proofview.tactic -> unit Proofview.tactic
+
+val discr        : evars_flag -> constr with_bindings -> unit Proofview.tactic
+val discrConcl   : unit Proofview.tactic
+val discrHyp     : Id.t -> unit Proofview.tactic
+val discrEverywhere : evars_flag -> unit Proofview.tactic
 val discr_tac    : evars_flag ->
-  constr with_bindings induction_arg option -> tactic
-val inj          : intro_pattern_expr located list -> evars_flag ->
-  constr with_bindings -> tactic
-val injClause    : intro_pattern_expr located list -> evars_flag ->
-  constr with_bindings induction_arg option -> tactic
-val injHyp       : identifier -> tactic
-val injConcl     : tactic
+  constr with_bindings induction_arg option -> unit Proofview.tactic
+val inj          : intro_patterns option -> evars_flag ->
+  clear_flag -> constr with_bindings -> unit Proofview.tactic
+val injClause    : intro_patterns option -> evars_flag ->
+  constr with_bindings induction_arg option -> unit Proofview.tactic
+val injHyp       : clear_flag -> Id.t -> unit Proofview.tactic
+val injConcl     : unit Proofview.tactic
 
-val dEq : evars_flag -> constr with_bindings induction_arg option -> tactic
-val dEqThen : evars_flag -> (int -> tactic) -> constr with_bindings induction_arg option -> tactic
+val dEq : evars_flag -> constr with_bindings induction_arg option -> unit Proofview.tactic
+val dEqThen : evars_flag -> (clear_flag -> constr -> int -> unit Proofview.tactic) -> constr with_bindings induction_arg option -> unit Proofview.tactic
 
 val make_iterated_tuple :
-  env -> evar_map -> constr -> (constr * types) -> constr * constr * constr
+  env -> evar_map -> constr -> (constr * types) -> evar_map * (constr * constr * constr)
 
 (* The family cutRewriteIn expect an equality statement *)
-val cutRewriteInHyp : bool -> types -> identifier -> tactic
-val cutRewriteInConcl : bool -> constr -> tactic
+val cutRewriteInHyp : bool -> types -> Id.t -> unit Proofview.tactic
+val cutRewriteInConcl : bool -> constr -> unit Proofview.tactic
 
 (* The family rewriteIn expect the proof of an equality *)
-val rewriteInHyp : bool -> constr -> identifier -> tactic
-val rewriteInConcl : bool -> constr -> tactic
-
-(* Expect the proof of an equality; fails with raw internal errors *)
-val substClause : bool -> constr -> identifier option -> tactic
+val rewriteInHyp : bool -> constr -> Id.t -> unit Proofview.tactic
+val rewriteInConcl : bool -> constr -> unit Proofview.tactic
 
 val discriminable : env -> evar_map -> constr -> constr -> bool
 val injectable : env -> evar_map -> constr -> constr -> bool
 
 (* Subst *)
 
-val unfold_body : identifier -> tactic
+(* val unfold_body : Id.t -> tactic *)
 
 type subst_tactic_flags = {
   only_leibniz : bool;
   rewrite_dependent_proof : bool
 }
-val subst_gen : bool -> identifier list -> tactic
-val subst : identifier list -> tactic
-val subst_all : ?flags:subst_tactic_flags -> tactic
+val subst_gen : bool -> Id.t list -> unit Proofview.tactic
+val subst : Id.t list -> unit Proofview.tactic
+val subst_all : ?flags:subst_tactic_flags -> unit -> unit Proofview.tactic
 
 (* Replace term *)
-(* [replace_multi_term dir_opt c cl]
+(* [replace_term dir_opt c cl]
    perfoms replacement of [c] by the first value found in context
    (according to [dir] if given to get the rewrite direction)  in the clause [cl]
 *)
-val replace_multi_term : bool option -> constr -> clause -> tactic
+val replace_term : bool option -> constr -> clause -> unit Proofview.tactic
 
 val set_eq_dec_scheme_kind : mutual scheme_kind -> unit
diff --git a/tactics/evar_tactics.ml b/tactics/evar_tactics.ml
index e9a041d7..2aafaf08 100644
--- a/tactics/evar_tactics.ml
+++ b/tactics/evar_tactics.ml
@@ -1,57 +1,79 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-open Term
 open Util
+open Errors
 open Evar_refiner
 open Tacmach
 open Tacexpr
 open Refiner
-open Proof_type
 open Evd
-open Sign
-open Termops
+open Locus
 
 (* The instantiate tactic *)
 
-let instantiate n (ist,rawc) ido gl =
+let instantiate_evar evk (ist,rawc) sigma =
+  let evi = Evd.find sigma evk in
+  let filtered = Evd.evar_filtered_env evi in
+  let constrvars = Tacinterp.extract_ltac_constr_values ist filtered in
+  let lvar = {
+    Pretyping.ltac_constrs = constrvars;
+    ltac_uconstrs = Names.Id.Map.empty;
+    ltac_idents = Names.Id.Map.empty;
+    ltac_genargs = ist.Geninterp.lfun;
+  } in
+  let sigma' = w_refine (evk,evi) (lvar ,rawc) sigma in
+  tclEVARS sigma'
+
+let instantiate_tac n c ido =
+  Proofview.V82.tactic begin fun gl ->
   let sigma = gl.sigma in
   let evl =
     match ido with
-	ConclLocation () -> evar_list sigma (pf_concl gl)
+	ConclLocation () -> evar_list (pf_concl gl)
       | HypLocation (id,hloc) ->
 	  let decl = Environ.lookup_named_val id (Goal.V82.hyps sigma (sig_it gl)) in
 	    match hloc with
 		InHyp ->
 		  (match decl with
-		      (_,None,typ) -> evar_list sigma typ
+		      (_,None,typ) -> evar_list typ
 		    | _ -> error
 			"Please be more specific: in type or value?")
 	      | InHypTypeOnly ->
-		  let (_, _, typ) = decl in evar_list sigma typ
+		  let (_, _, typ) = decl in evar_list typ
 	      | InHypValueOnly ->
 		  (match decl with
-		      (_,Some body,_) -> evar_list sigma body
+		      (_,Some body,_) -> evar_list body
 		    | _ -> error "Not a defined hypothesis.") in
-    if List.length evl < n then
-      error "Not enough uninstantiated existential variables.";
-    if n <= 0 then error "Incorrect existential variable index.";
-    let evk,_ = List.nth evl (n-1) in
-    let evi = Evd.find sigma evk in
-    let ltac_vars = Tacinterp.extract_ltac_constr_values ist (Evd.evar_env evi) in
-    let sigma' = w_refine (evk,evi) (ltac_vars,rawc) sigma in
-      tclTHEN
-        (tclEVARS sigma')
-        tclNORMEVAR
-        gl
+  if List.length evl < n then
+    error "Not enough uninstantiated existential variables.";
+  if n <= 0 then error "Incorrect existential variable index.";
+  let evk,_ = List.nth evl (n-1) in
+  instantiate_evar evk c sigma gl
+  end
+
+let instantiate_tac_by_name id c =
+  Proofview.V82.tactic begin fun gl ->
+  let sigma = gl.sigma in
+  let evk =
+    try Evd.evar_key id sigma
+    with Not_found -> error "Unknown existential variable." in
+  instantiate_evar evk c sigma gl
+  end
 
-let let_evar name typ gls =
-  let src = (dummy_loc,GoalEvar) in
-  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
+let let_evar name typ =
+  let src = (Loc.ghost,Evar_kinds.GoalEvar) in
+  Proofview.Goal.enter begin fun gl ->
+    let sigma = Proofview.Goal.sigma gl in
+    let env = Proofview.Goal.env gl in
+    let id = Namegen.id_of_name_using_hdchar env typ name in
+    let id = Namegen.next_ident_away_in_goal id (Termops.ids_of_named_context (Environ.named_context env)) in
+    let sigma',evar = Evarutil.new_evar env sigma ~src ~naming:(Misctypes.IntroFresh id) typ in
+    Tacticals.New.tclTHEN (Proofview.V82.tactic (Refiner.tclEVARS sigma'))
+      (Tactics.letin_tac None (Names.Name id) evar None Locusops.nowhere)
+  end
diff --git a/tactics/evar_tactics.mli b/tactics/evar_tactics.mli
index f4e1ed80..42d00e1e 100644
--- a/tactics/evar_tactics.mli
+++ b/tactics/evar_tactics.mli
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -9,9 +9,12 @@
 open Tacmach
 open Names
 open Tacexpr
-open Termops
+open Locus
 
-val instantiate : int -> Tacinterp.interp_sign * Glob_term.glob_constr ->
-  (identifier * hyp_location_flag, unit) location -> tactic
+val instantiate_tac : int -> Tacinterp.interp_sign * Glob_term.glob_constr ->
+  (Id.t * hyp_location_flag, unit) location -> unit Proofview.tactic
 
-val let_evar : name -> Term.types -> tactic
+val instantiate_tac_by_name : Id.t ->
+  Tacinterp.interp_sign * Glob_term.glob_constr -> unit Proofview.tactic
+
+val let_evar : Name.t -> Term.types -> unit Proofview.tactic
diff --git a/tactics/extraargs.ml4 b/tactics/extraargs.ml4
index 88271fd6..47987e9e 100644
--- a/tactics/extraargs.ml4
+++ b/tactics/extraargs.ml4
@@ -1,20 +1,21 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i camlp4deps: "parsing/grammar.cma" i*)
+(*i camlp4deps: "grammar/grammar.cma" i*)
 
 open Pp
-open Pcoq
 open Genarg
 open Names
 open Tacexpr
+open Taccoerce
 open Tacinterp
-open Termops
+open Misctypes
+open Locus
 
 (* Rewriting orientation *)
 
@@ -34,29 +35,35 @@ END
 let pr_orient = pr_orient () () ()
 
 
-let pr_int_list = Util.pr_sequence Pp.int
+let pr_int_list = Pp.pr_sequence Pp.int
 let pr_int_list_full _prc _prlc _prt l = pr_int_list l
 
-open Glob_term
-
 let pr_occurrences _prc _prlc _prt l =
   match l with
     | ArgArg x -> pr_int_list x
     | ArgVar (loc, id) -> Nameops.pr_id id
 
-let coerce_to_int = function
-  | VInteger n -> n
-  | v -> raise (CannotCoerceTo "an integer")
+let occurrences_of = function
+  | [] -> NoOccurrences
+  | n::_ as nl when n < 0 -> AllOccurrencesBut (List.map abs nl)
+  | nl ->
+      if List.exists (fun n -> n < 0) nl then
+        Errors.error "Illegal negative occurrence number.";
+      OnlyOccurrences nl
+
+let coerce_to_int v = match Value.to_int v with
+  | None -> raise (CannotCoerceTo "an integer")
+  | Some n -> n
 
-let int_list_of_VList = function
-  | VList l -> List.map (fun n -> coerce_to_int n) l
-  | _ -> raise Not_found
+let int_list_of_VList v = match Value.to_list v with
+| Some l -> List.map (fun n -> coerce_to_int n) l
+| _ -> raise (CannotCoerceTo "an integer")
 
 let interp_occs ist gl l =
   match l with
     | ArgArg x -> x
     | ArgVar (_,id as locid) ->
-	(try int_list_of_VList (List.assoc id ist.lfun)
+	(try int_list_of_VList (Id.Map.find id ist.lfun)
 	  with Not_found | CannotCoerceTo _ -> [interp_int ist locid])
 let interp_occs ist gl l =
   Tacmach.project gl , interp_occs ist gl l
@@ -65,9 +72,6 @@ let glob_occs ist l = l
 
 let subst_occs evm l = l
 
-type occurrences_or_var = int list or_var
-type occurrences = int list
-
 ARGUMENT EXTEND occurrences
   PRINTED BY pr_int_list_full
 
@@ -93,9 +97,9 @@ let pr_globc _prc _prlc _prtac (_,glob) = Printer.pr_glob_constr glob
 
 let interp_glob ist gl (t,_) = Tacmach.project gl , (ist,t)
 
-let glob_glob = Tacinterp.intern_constr
+let glob_glob = Tacintern.intern_constr
 
-let subst_glob = Tacinterp.subst_glob_constr_and_expr
+let subst_glob = Tacsubst.subst_glob_constr_and_expr
 
 ARGUMENT EXTEND glob
     PRINTED BY pr_globc
@@ -109,14 +113,28 @@ ARGUMENT EXTEND glob
 
      GLOB_TYPED AS glob_constr_and_expr
      GLOB_PRINTED BY pr_gen
-  [ lconstr(c) ] -> [ c ]
+  [ constr(c) ] -> [ c ]
 END
 
+ARGUMENT EXTEND lglob
+    PRINTED BY pr_globc
+
+     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 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
-type place = identifier gen_place
+type loc_place = Id.t Loc.located gen_place
+type place = Id.t gen_place
 
 let pr_gen_place pr_id = function
     ConclLocation () -> Pp.mt ()
@@ -132,14 +150,14 @@ let pr_hloc = pr_loc_place () () ()
 
 let intern_place ist = function
     ConclLocation () -> ConclLocation ()
-  | HypLocation (id,hl) -> HypLocation (intern_hyp ist id,hl)
+  | HypLocation (id,hl) -> HypLocation (Tacintern.intern_hyp ist id,hl)
 
-let interp_place ist gl = function
+let interp_place ist env sigma = function
     ConclLocation () -> ConclLocation ()
-  | HypLocation (id,hl) -> HypLocation (interp_hyp ist gl id,hl)
+  | HypLocation (id,hl) -> HypLocation (Tacinterp.interp_hyp ist env sigma id,hl)
 
 let interp_place ist gl p =
-  Tacmach.project gl , interp_place ist gl p
+  Tacmach.project gl , interp_place ist (Tacmach.pf_env gl) (Tacmach.project gl) p
 
 let subst_place subst pl = pl
 
@@ -157,11 +175,11 @@ ARGUMENT EXTEND hloc
   |  [ "in" "|-" "*" ] ->
     [ ConclLocation () ]
 | [ "in" ident(id) ] ->
-    [ HypLocation ((Util.dummy_loc,id),InHyp) ]
+    [ HypLocation ((Loc.ghost,id),InHyp) ]
 | [ "in" "(" "Type" "of" ident(id) ")" ] ->
-    [ HypLocation ((Util.dummy_loc,id),InHypTypeOnly) ]
+    [ HypLocation ((Loc.ghost,id),InHypTypeOnly) ]
 | [ "in" "(" "Value" "of" ident(id) ")" ] ->
-    [ HypLocation ((Util.dummy_loc,id),InHypValueOnly) ]
+    [ HypLocation ((Loc.ghost,id),InHypValueOnly) ]
 
  END
 
@@ -187,115 +205,16 @@ 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
-    | Some [],true -> mt ()
-    | None,true -> str "in" ++ spc () ++ str "*"
-    | None,false -> str "in" ++ spc () ++ str "*" ++ spc () ++ str "|-"
-    | Some l,_ ->
-	str "in" ++
-         spc () ++ Util.prlist_with_sep Util.pr_comma pr_id l ++
-	  match concl with
-	    | true -> spc () ++ str "|-" ++ spc () ++ str "*"
-	    | _ -> mt ()
-
-
-let pr_in_arg_hyp _ _ _ = pr_in_hyp (fun (_,id) -> Ppconstr.pr_id id)
-
-let pr_in_arg_hyp_typed  _ _  _  = pr_in_hyp Ppconstr.pr_id
-
-
-let pr_var_list_gen pr_id = Util.prlist_with_sep (fun () -> str ",") pr_id
-
-let pr_var_list_typed _ _ _ =  pr_var_list_gen Ppconstr.pr_id
-
-let pr_var_list _ _ _ = pr_var_list_gen (fun (_,id) -> Ppconstr.pr_id id)
-
-
-ARGUMENT EXTEND comma_var_lne
-  PRINTED BY pr_var_list_typed
-  RAW_TYPED AS var list
-  RAW_PRINTED BY pr_var_list
-  GLOB_TYPED AS var list
-  GLOB_PRINTED BY pr_var_list
-| [ var(x) ] -> [ [x] ]
-| [ var(x) "," comma_var_lne(l) ] -> [x::l]
-END
-
-ARGUMENT EXTEND comma_var_l
-  PRINTED BY pr_var_list_typed
-  RAW_TYPED AS var list
-  RAW_PRINTED BY pr_var_list
-  GLOB_TYPED AS var list
-  GLOB_PRINTED BY pr_var_list
-| [  comma_var_lne(l) ] -> [l]
-| [] -> [ [] ]
-END
-
-let pr_in_concl _ _ _ = function true -> str "|- " ++ spc () ++ str "*" | _ -> str "|-"
-
-ARGUMENT EXTEND inconcl
-  TYPED AS bool
-  PRINTED BY pr_in_concl
-| [ "|-" "*" ] -> [ true ]
-| [ "|-" ] -> [ false ]
-END
-
-
-
-ARGUMENT EXTEND in_arg_hyp
-  PRINTED BY pr_in_arg_hyp_typed
-  RAW_TYPED AS var list option * bool
-  RAW_PRINTED BY pr_in_arg_hyp
-  GLOB_TYPED AS var list option * bool
-  GLOB_PRINTED BY pr_in_arg_hyp
-| [ "in" "*" ] -> [(None,true)]
-| [ "in" "*" inconcl_opt(b) ] -> [let onconcl = match b with Some b -> b | None -> true in (None,onconcl)]
-| [ "in" comma_var_l(l) inconcl_opt(b) ] -> [ let onconcl = match b with Some b -> b | None -> false in
-					      Some l, onconcl
-					   ]
-| [ ] -> [ (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=
-   Option.map
-     (fun l ->
-	List.map
-	  (fun id -> ( (all_occurrences_expr,trad_id id),InHyp))
-	  l
-     )
-     hyps;
-   Tacexpr.concl_occs = if concl then all_occurrences_expr else no_occurrences_expr}
-
-
-let raw_in_arg_hyp_to_clause = gen_in_arg_hyp_to_clause snd
-let glob_in_arg_hyp_to_clause = gen_in_arg_hyp_to_clause (fun x -> x)
-
-
-(* spiwack argument for the commands of the retroknowledge *)
-
-let (wit_r_nat_field, globwit_r_nat_field, rawwit_r_nat_field) =
-  Genarg.create_arg None "r_nat_field"
-let (wit_r_n_field, globwit_r_n_field, rawwit_r_n_field) =
-  Genarg.create_arg None "r_n_field"
-let (wit_r_int31_field, globwit_r_int31_field, rawwit_r_int31_field) =
-  Genarg.create_arg None "r_int31_field"
-let (wit_r_field, globwit_r_field, rawwit_r_field) =
-  Genarg.create_arg None "r_field"
-
 (* spiwack: the print functions are incomplete, but I don't know what they are
 	used for *)
-let pr_r_nat_field _ _ _ natf =
+let pr_r_nat_field natf =
   str "nat " ++
   match natf with
     | Retroknowledge.NatType -> str "type"
     | Retroknowledge.NatPlus -> str "plus"
     | Retroknowledge.NatTimes -> str "times"
 
-let pr_r_n_field _ _ _ nf =
+let pr_r_n_field  nf =
   str "binary N " ++
   match nf with
     | Retroknowledge.NPositive -> str "positive"
@@ -307,7 +226,7 @@ let pr_r_n_field _ _ _ nf =
     | Retroknowledge.NPlus -> str "plus"
     | Retroknowledge.NTimes -> str "times"
 
-let pr_r_int31_field _ _ _ i31f =
+let pr_r_int31_field i31f =
   str "int31 " ++
   match i31f with
     | Retroknowledge.Int31Bits -> str "bits"
@@ -320,16 +239,15 @@ let pr_r_int31_field _ _ _ i31f =
     | Retroknowledge.Int31Times -> str "times"
     | _ -> assert false
 
-let pr_retroknowledge_field _ _ _ f =
+let pr_retroknowledge_field f =
   match f with
  (* | Retroknowledge.KEq -> str "equality"
   | Retroknowledge.KNat natf -> pr_r_nat_field () () () natf
   | Retroknowledge.KN nf -> pr_r_n_field () () () nf *)
-  | Retroknowledge.KInt31 (group, i31f) -> (pr_r_int31_field () () () i31f) ++
+  | Retroknowledge.KInt31 (group, i31f) -> (pr_r_int31_field i31f) ++
                                            str "in " ++ str group
 
-ARGUMENT EXTEND retroknowledge_nat
-TYPED AS r_nat_field
+VERNAC ARGUMENT EXTEND retroknowledge_nat
 PRINTED BY pr_r_nat_field
 | [ "nat" "type" ] -> [ Retroknowledge.NatType ]
 | [ "nat" "plus" ] -> [ Retroknowledge.NatPlus ]
@@ -337,8 +255,7 @@ PRINTED BY pr_r_nat_field
 END
 
 
-ARGUMENT EXTEND retroknowledge_binary_n
-TYPED AS r_n_field
+VERNAC ARGUMENT EXTEND retroknowledge_binary_n
 PRINTED BY pr_r_n_field
 | [ "binary" "N" "positive" ] -> [ Retroknowledge.NPositive ]
 | [ "binary" "N" "type" ] -> [ Retroknowledge.NType ]
@@ -350,8 +267,7 @@ PRINTED BY pr_r_n_field
 | [ "binary" "N" "times" ] -> [ Retroknowledge.NTimes ]
 END
 
-ARGUMENT EXTEND retroknowledge_int31
-TYPED AS r_int31_field
+VERNAC ARGUMENT EXTEND retroknowledge_int31
 PRINTED BY pr_r_int31_field
 | [ "int31" "bits" ] -> [ Retroknowledge.Int31Bits ]
 | [ "int31" "type" ] -> [ Retroknowledge.Int31Type ]
@@ -369,15 +285,17 @@ PRINTED BY pr_r_int31_field
 | [ "int31" "timesc" ] -> [ Retroknowledge.Int31TimesC ]
 | [ "int31" "div21" ] -> [ Retroknowledge.Int31Div21 ]
 | [ "int31" "div" ] -> [ Retroknowledge.Int31Div ]
+| [ "int31" "diveucl" ] -> [ Retroknowledge.Int31Diveucl ]
 | [ "int31" "addmuldiv" ] -> [ Retroknowledge.Int31AddMulDiv ]
 | [ "int31" "compare" ] -> [ Retroknowledge.Int31Compare ]
 | [ "int31" "head0" ] -> [ Retroknowledge.Int31Head0 ]
 | [ "int31" "tail0" ] -> [ Retroknowledge.Int31Tail0 ]
-
+| [ "int31" "lor" ] -> [ Retroknowledge.Int31Lor ]
+| [ "int31" "land" ] -> [ Retroknowledge.Int31Land ]
+| [ "int31" "lxor" ] -> [ Retroknowledge.Int31Lxor ]
 END
 
-ARGUMENT EXTEND retroknowledge_field
-TYPED AS r_field
+VERNAC ARGUMENT EXTEND retroknowledge_field
 PRINTED BY pr_retroknowledge_field
 (*| [ "equality" ] -> [ Retroknowledge.KEq ]
 | [ retroknowledge_nat(n)] -> [ Retroknowledge.KNat n ]
diff --git a/tactics/extraargs.mli b/tactics/extraargs.mli
index 8a0ae066..ef084e9d 100644
--- a/tactics/extraargs.mli
+++ b/tactics/extraargs.mli
@@ -1,55 +1,54 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
 open Tacexpr
-open Term
 open Names
-open Proof_type
-open Topconstr
-open Termops
+open Constrexpr
 open Glob_term
+open Misctypes
 
-val rawwit_orient : bool raw_abstract_argument_type
-val globwit_orient : bool glob_abstract_argument_type
-val wit_orient : bool typed_abstract_argument_type
+val wit_orient : bool Genarg.uniform_genarg_type
 val orient : bool Pcoq.Gram.entry
 val pr_orient : bool -> Pp.std_ppcmds
 
 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 wit_occurrences : (int list or_var, int list or_var, int list) Genarg.genarg_type
+val pr_occurrences : int list or_var -> Pp.std_ppcmds
+val occurrences_of : int list -> Locus.occurrences
+
+val wit_glob :
+  (constr_expr,
+  Tacexpr.glob_constr_and_expr,
+  Tacinterp.interp_sign * glob_constr) Genarg.genarg_type
+
+val wit_lglob :
+  (constr_expr,
+  Tacexpr.glob_constr_and_expr,
+  Tacinterp.interp_sign * glob_constr) Genarg.genarg_type
 
-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
+val lglob : constr_expr Pcoq.Gram.entry
 
-type 'id gen_place= ('id * hyp_location_flag,unit) location
+type 'id gen_place= ('id * Locus.hyp_location_flag,unit) location
 
-type loc_place = identifier Util.located gen_place
-type place = identifier gen_place
+type loc_place = Id.t Loc.located gen_place
+type place = Id.t gen_place
 
-val rawwit_hloc : loc_place raw_abstract_argument_type
-val wit_hloc : place typed_abstract_argument_type
+val wit_hloc : (loc_place, loc_place, place) Genarg.genarg_type
 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
-val globwit_in_arg_hyp : (Names.identifier Util.located list option * bool) glob_abstract_argument_type
-val rawwit_in_arg_hyp : (Names.identifier Util.located list option * bool) raw_abstract_argument_type
-val wit_in_arg_hyp : (Names.identifier list option * bool) typed_abstract_argument_type
-val raw_in_arg_hyp_to_clause : (Names.identifier Util.located list option * bool) -> Tacticals.clause
-val glob_in_arg_hyp_to_clause :  (Names.identifier list option * bool)  -> Tacticals.clause
-val pr_in_arg_hyp : (Names.identifier list option * bool) -> Pp.std_ppcmds
-
 val by_arg_tac : Tacexpr.raw_tactic_expr option Pcoq.Gram.entry
-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 wit_by_arg_tac :
+  (raw_tactic_expr option,
+  glob_tactic_expr option,
+  glob_tactic_expr option) Genarg.genarg_type
+
 val pr_by_arg_tac : 
   (int * Ppextend.parenRelation -> raw_tactic_expr -> Pp.std_ppcmds) ->
   raw_tactic_expr option -> Pp.std_ppcmds
@@ -58,5 +57,4 @@ val pr_by_arg_tac :
 (** Spiwack: Primitive for retroknowledge registration *)
 
 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
+val wit_retroknowledge_field : (Retroknowledge.field, unit, unit) Genarg.genarg_type
diff --git a/tactics/extratactics.ml4 b/tactics/extratactics.ml4
index 6fd95f16..f3482c31 100644
--- a/tactics/extratactics.ml4
+++ b/tactics/extratactics.ml4
@@ -1,26 +1,29 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i camlp4deps: "parsing/grammar.cma" i*)
+(*i camlp4deps: "grammar/grammar.cma" i*)
 
 open Pp
-open Pcoq
 open Genarg
 open Extraargs
 open Mod_subst
 open Names
 open Tacexpr
-open Glob_term
+open Glob_ops
 open Tactics
+open Errors
 open Util
 open Evd
 open Equality
-open Compat
+open Misctypes
+open Proofview.Notations
+
+DECLARE PLUGIN "extratactics"
 
 (**********************************************************************)
 (* admit, replace, discriminate, injection, simplify_eq               *)
@@ -30,76 +33,46 @@ TACTIC EXTEND admit
   [ "admit" ] -> [ admit_as_an_axiom ]
 END
 
-
-
-let classes_dirpath =
-  make_dirpath (List.map id_of_string ["Classes";"Coq"])
-
-let init_setoid () =
-  if Libnames.is_dirpath_prefix_of classes_dirpath (Lib.cwd ()) then ()
-  else Coqlib.check_required_library ["Coq";"Setoids";"Setoid"]
-
-
-let occurrences_of occs = 
-  let loccs = match occs with 
-  | n::_ as nl when n < 0 -> (false,List.map (fun n -> ArgArg (abs n)) nl)
-  | nl ->
-      if List.exists (fun n -> n < 0) nl then
-	error "Illegal negative occurrence number.";
-      (true, List.map (fun n -> (ArgArg n)) nl)
-  in 
-  init_setoid ();
-  {onhyps = Some []; concl_occs =loccs}
-
-let replace_in_clause_maybe_by (sigma1,c1) c2 cl tac =
-  Refiner.tclWITHHOLES false
+let replace_in_clause_maybe_by (sigma,c1) c2 cl  tac =
+  Proofview.Unsafe.tclEVARS sigma <*>
     (replace_in_clause_maybe_by c1 c2 cl)
-    sigma1
     (Option.map Tacinterp.eval_tactic tac)
 
-let replace_multi_term dir_opt (sigma,c) in_hyp =
-  Refiner.tclWITHHOLES false
-    (replace_multi_term dir_opt c)
-    sigma
-    (glob_in_arg_hyp_to_clause in_hyp)
+let replace_term dir_opt (sigma,c) cl =
+  Proofview.Unsafe.tclEVARS sigma <*>
+    (replace_term dir_opt c) cl
 
 TACTIC EXTEND replace
-   ["replace" open_constr(c1) "with" constr(c2) in_arg_hyp(in_hyp) by_arg_tac(tac) ]
--> [ replace_in_clause_maybe_by c1 c2 (glob_in_arg_hyp_to_clause in_hyp) tac ]
-END
-
-TACTIC EXTEND replace_at
-   ["replace" open_constr(c1) "with" constr(c2) "at" occurrences(occs) by_arg_tac(tac) ]
--> [ replace_in_clause_maybe_by c1 c2 (occurrences_of occs) tac ]
+   ["replace" open_constr(c1) "with" constr(c2) clause(cl) by_arg_tac(tac) ]
+-> [ replace_in_clause_maybe_by c1 c2 cl tac ]
 END
 
-
 TACTIC EXTEND replace_term_left
-  [ "replace"  "->" open_constr(c) in_arg_hyp(in_hyp) ]
-  -> [ replace_multi_term (Some true) c in_hyp]
+  [ "replace"  "->" open_constr(c) clause(cl) ]
+  -> [ replace_term (Some true) c cl ]
 END
 
 TACTIC EXTEND replace_term_right
-  [ "replace"  "<-" open_constr(c) in_arg_hyp(in_hyp) ]
-  -> [replace_multi_term (Some false) c in_hyp]
+  [ "replace"  "<-" open_constr(c) clause(cl) ]
+  -> [ replace_term (Some false) c cl ]
 END
 
 TACTIC EXTEND replace_term
-  [ "replace" open_constr(c) in_arg_hyp(in_hyp) ]
-  -> [ replace_multi_term None c in_hyp ]
+  [ "replace" open_constr(c) clause(cl) ]
+  -> [ replace_term None c cl ]
 END
 
 let induction_arg_of_quantified_hyp = function
-  | AnonHyp n -> ElimOnAnonHyp n
-  | NamedHyp id -> ElimOnIdent (Util.dummy_loc,id)
+  | AnonHyp n -> None,ElimOnAnonHyp n
+  | NamedHyp id -> None,ElimOnIdent (Loc.ghost,id)
 
 (* Versions *_main must come first!! so that "1" is interpreted as a
    ElimOnAnonHyp and not as a "constr", and "id" is interpreted as a
    ElimOnIdent and not as "constr" *)
 
 let elimOnConstrWithHoles tac with_evars c =
-  Refiner.tclWITHHOLES with_evars (tac with_evars) 
-    c.sigma (Some (ElimOnConstr c.it))
+  Tacticals.New.tclWITHHOLES with_evars (tac with_evars) 
+    c.sigma (Some (None,ElimOnConstr c.it))
 
 TACTIC EXTEND simplify_eq_main
 | [ "simplify_eq" constr_with_bindings(c) ] ->
@@ -120,9 +93,11 @@ TACTIC EXTEND esimplify_eq
     [ dEq true (Some (induction_arg_of_quantified_hyp h)) ]
 END
 
+let discr_main c = elimOnConstrWithHoles discr_tac false c
+
 TACTIC EXTEND discriminate_main
 | [ "discriminate" constr_with_bindings(c) ] ->
-    [ elimOnConstrWithHoles discr_tac false c ]
+    [ discr_main c ]
 END
 TACTIC EXTEND discriminate
 | [ "discriminate" ] -> [ discr_tac false None ]
@@ -139,49 +114,55 @@ TACTIC EXTEND ediscriminate
     [ discr_tac true (Some (induction_arg_of_quantified_hyp h)) ]
 END
 
-let h_discrHyp id gl =
-  h_discriminate_main {it = Term.mkVar id,NoBindings; sigma = Refiner.project gl} gl
+open Proofview.Notations
+let discrHyp id =
+  Proofview.tclEVARMAP >>= fun sigma ->
+  discr_main {it = Term.mkVar id,NoBindings; sigma = sigma;}
+
+let injection_main c =
+ elimOnConstrWithHoles (injClause None) false c
 
 TACTIC EXTEND injection_main
 | [ "injection" constr_with_bindings(c) ] ->
-    [ elimOnConstrWithHoles (injClause []) false c ]
+    [ injection_main c ]
 END
 TACTIC EXTEND injection
-| [ "injection" ] -> [ injClause [] false None ]
+| [ "injection" ] -> [ injClause None false None ]
 | [ "injection" quantified_hypothesis(h) ] ->
-    [ injClause [] false (Some (induction_arg_of_quantified_hyp h)) ]
+    [ injClause None false (Some (induction_arg_of_quantified_hyp h)) ]
 END
 TACTIC EXTEND einjection_main
 | [ "einjection" constr_with_bindings(c) ] ->
-    [ elimOnConstrWithHoles (injClause []) true c ]
+    [ elimOnConstrWithHoles (injClause None) true c ]
 END
 TACTIC EXTEND einjection
-| [ "einjection" ] -> [ injClause [] true None ]
-| [ "einjection" quantified_hypothesis(h) ] -> [ injClause [] true (Some (induction_arg_of_quantified_hyp h)) ]
+| [ "einjection" ] -> [ injClause None true None ]
+| [ "einjection" quantified_hypothesis(h) ] -> [ injClause None true (Some (induction_arg_of_quantified_hyp h)) ]
 END
 TACTIC EXTEND injection_as_main
 | [ "injection" constr_with_bindings(c) "as" simple_intropattern_list(ipat)] ->
-    [ elimOnConstrWithHoles (injClause ipat) false c ]
+    [ elimOnConstrWithHoles (injClause (Some ipat)) false c ]
 END
 TACTIC EXTEND injection_as
 | [ "injection" "as" simple_intropattern_list(ipat)] ->
-    [ injClause ipat false None ]
+    [ injClause (Some ipat) false None ]
 | [ "injection" quantified_hypothesis(h) "as" simple_intropattern_list(ipat) ] ->
-    [ injClause ipat false (Some (induction_arg_of_quantified_hyp h)) ]
+    [ injClause (Some ipat) false (Some (induction_arg_of_quantified_hyp h)) ]
 END
 TACTIC EXTEND einjection_as_main
 | [ "einjection" constr_with_bindings(c) "as" simple_intropattern_list(ipat)] ->
-    [ elimOnConstrWithHoles (injClause ipat) true c ]
+    [ elimOnConstrWithHoles (injClause (Some ipat)) true c ]
 END
 TACTIC EXTEND einjection_as
 | [ "einjection" "as" simple_intropattern_list(ipat)] ->
-    [ injClause ipat true None ]
+    [ injClause (Some ipat) true None ]
 | [ "einjection" quantified_hypothesis(h) "as" simple_intropattern_list(ipat) ] ->
-    [ injClause ipat true (Some (induction_arg_of_quantified_hyp h)) ]
+    [ injClause (Some ipat) true (Some (induction_arg_of_quantified_hyp h)) ]
 END
 
-let h_injHyp id gl =
-  h_injection_main { it = Term.mkVar id,NoBindings; sigma = Refiner.project gl } gl
+let injHyp id =
+  Proofview.tclEVARMAP >>= fun sigma ->
+  injection_main { it = Term.mkVar id,NoBindings; sigma = sigma; }
 
 TACTIC EXTEND dependent_rewrite
 | [ "dependent" "rewrite" orient(b) constr(c) ] -> [ rewriteInConcl b c ]
@@ -189,6 +170,10 @@ TACTIC EXTEND dependent_rewrite
     -> [ rewriteInHyp b c id ]
 END
 
+(** To be deprecated?, "cutrewrite (t=u) as <-" is equivalent to
+    "replace u with t" or "enough (t=u) as <-" and 
+    "cutrewrite (t=u) as ->" is equivalent to "enough (t=u) as ->". *)
+
 TACTIC EXTEND cut_rewrite
 | [ "cutrewrite" orient(b) constr(eqn) ] -> [ cutRewriteInConcl b eqn ]
 | [ "cutrewrite" orient(b) constr(eqn) "in" hyp(id) ]
@@ -196,6 +181,17 @@ TACTIC EXTEND cut_rewrite
 END
 
 (**********************************************************************)
+(* Decompose                                                          *)
+
+TACTIC EXTEND decompose_sum
+| [ "decompose" "sum" constr(c) ] -> [ Elim.h_decompose_or c ]
+END
+
+TACTIC EXTEND decompose_record
+| [ "decompose" "record" constr(c) ] -> [ Elim.h_decompose_and c ]
+END
+
+(**********************************************************************)
 (* Contradiction                                                      *)
 
 open Contradiction
@@ -206,7 +202,7 @@ END
 
 let onSomeWithHoles tac = function
   | None -> tac None
-  | Some c -> Refiner.tclWITHHOLES false tac c.sigma (Some c.it)
+  | Some c -> Proofview.Unsafe.tclEVARS c.sigma <*> tac (Some c.it)
 
 TACTIC EXTEND contradiction
  [ "contradiction" constr_with_bindings_opt(c) ] ->
@@ -230,22 +226,19 @@ ARGUMENT EXTEND orient_string TYPED AS (bool * string) PRINTED BY pr_orient_stri
 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) ] ->
+| [ "autorewrite" "with" ne_preident_list(l) clause(cl) ] ->
+    [ auto_multi_rewrite  l ( cl) ]
+| [ "autorewrite" "with" ne_preident_list(l) clause(cl) "using" tactic(t) ] ->
     [
-      let cl =  glob_in_arg_hyp_to_clause cl in
       auto_multi_rewrite_with (Tacinterp.eval_tactic t) l cl
-
     ]
 END
 
 TACTIC EXTEND autorewrite_star
-| [ "autorewrite" "*" "with" ne_preident_list(l) in_arg_hyp(cl) ] ->
-    [ 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 (Tacinterp.eval_tactic t) l cl ]
+| [ "autorewrite" "*" "with" ne_preident_list(l) clause(cl) ] ->
+    [ auto_multi_rewrite ~conds:AllMatches l cl ]
+| [ "autorewrite" "*" "with" ne_preident_list(l) clause(cl) "using" tactic(t) ] ->
+  [ auto_multi_rewrite_with ~conds:AllMatches (Tacinterp.eval_tactic t) l cl ]
 END
 
 (**********************************************************************)
@@ -253,15 +246,8 @@ 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 true (c,NoBindings)) sigma true
-
-let occurrences_of = function
-  | n::_ as nl when n < 0 -> (false,List.map abs nl)
-  | nl ->
-      if List.exists (fun n -> n < 0) nl then
-	error "Illegal negative occurrence number.";
-      (true,nl)
+  Proofview.Unsafe.tclEVARS sigma <*>
+    general_rewrite_ebindings_clause clause orient occs ?tac:tac' true true (c,NoBindings) true
 
 TACTIC EXTEND rewrite_star
 | [ "rewrite" "*" orient(o) open_constr(c) "in" hyp(id) "at" occurrences(occ) by_arg_tac(tac) ] ->
@@ -269,45 +255,62 @@ 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 Termops.all_occurrences c tac ]
+    [ rewrite_star (Some id) o Locus.AllOccurrences 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 Termops.all_occurrences c tac ]
+    [ rewrite_star None o Locus.AllOccurrences c tac ]
     END
 
 (**********************************************************************)
 (* Hint Rewrite                                                       *)
 
-let add_rewrite_hint name ort t lcsr =
+let add_rewrite_hint bases ort t lcsr =
   let env = Global.env() and sigma = Evd.empty in
-  let f c = Topconstr.constr_loc c, Constrintern.interp_constr sigma env c, ort, t in
-  add_rew_rules name (List.map f lcsr)
-
-VERNAC COMMAND EXTEND HintRewrite
-  [ "Hint" "Rewrite" orient(o) ne_constr_list(l) ":" preident(b) ] ->
-  [ add_rewrite_hint b o (Tacexpr.TacId []) l ]
+  let poly = Flags.is_universe_polymorphism () in 
+  let f ce = 
+    let c, ctx = Constrintern.interp_constr env sigma ce in
+    let ctx =
+      if poly then 
+	Evd.evar_universe_context_set ctx
+      else 
+	let cstrs = Evd.evar_universe_context_constraints ctx in
+	  (Global.add_constraints cstrs; Univ.ContextSet.empty)
+    in
+      Constrexpr_ops.constr_loc ce, (c, ctx), ort, t in
+  let eqs = List.map f lcsr in
+  let add_hints base = add_rew_rules base eqs in
+  List.iter add_hints bases
+
+let classify_hint _ = Vernacexpr.VtSideff [], Vernacexpr.VtLater
+
+VERNAC COMMAND EXTEND HintRewrite CLASSIFIED BY classify_hint
+  [ "Hint" "Rewrite" orient(o) ne_constr_list(l) ":" preident_list(bl) ] ->
+  [ add_rewrite_hint bl o None l ]
 | [ "Hint" "Rewrite" orient(o) ne_constr_list(l) "using" tactic(t)
-    ":" preident(b) ] ->
-  [ add_rewrite_hint b o t l ]
+    ":" preident_list(bl) ] ->
+  [ add_rewrite_hint bl o (Some t) l ]
 | [ "Hint" "Rewrite" orient(o) ne_constr_list(l) ] ->
-  [ add_rewrite_hint "core" o (Tacexpr.TacId []) l ]
+  [ add_rewrite_hint ["core"] o None l ]
 | [ "Hint" "Rewrite" orient(o) ne_constr_list(l) "using" tactic(t) ] ->
-  [ add_rewrite_hint "core" o t l ]
+  [ add_rewrite_hint ["core"] o (Some t) l ]
 END
 
 (**********************************************************************)
 (* Hint Resolve                                                       *)
 
 open Term
+open Vars
 open Coqlib
 
-let project_hint pri l2r c =
+let project_hint pri l2r r =
+  let gr = Smartlocate.global_with_alias r in
   let env = Global.env() in
-  let c = Constrintern.interp_constr Evd.empty env c in
-  let t = Retyping.get_type_of env Evd.empty c in
+  let sigma = Evd.from_env env in
+  let sigma, c = Evd.fresh_global env sigma gr in
+  let t = Retyping.get_type_of env sigma c in
   let t =
-    Tacred.reduce_to_quantified_ref env Evd.empty (Lazy.force coq_iff_ref) t in
+    Tacred.reduce_to_quantified_ref env sigma (Lazy.force coq_iff_ref) t in
   let sign,ccl = decompose_prod_assum t in
   let (a,b) = match snd (decompose_app ccl) with
     | [a;b] -> (a,b)
@@ -317,82 +320,91 @@ 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,Auto.PathAny,c)
+  let id =
+    Nameops.add_suffix (Nametab.basename_of_global gr) ("_proj_" ^ (if l2r then "l2r" else "r2l"))
+  in
+  let ctx = Evd.universe_context_set sigma in
+  let c = Declare.declare_definition ~internal:Declare.KernelSilent id (c,ctx) in
+    (pri,false,true,Hints.PathAny, Hints.IsGlobRef (Globnames.ConstRef c))
 
 let add_hints_iff l2r lc n bl =
-  Auto.add_hints true bl
-    (Auto.HintsResolveEntry (List.map (project_hint n l2r) lc))
+  Hints.add_hints true bl
+    (Hints.HintsResolveEntry (List.map (project_hint n l2r) lc))
 
-VERNAC COMMAND EXTEND HintResolveIffLR
-  [ "Hint" "Resolve" "->" ne_constr_list(lc) natural_opt(n)
+VERNAC COMMAND EXTEND HintResolveIffLR CLASSIFIED AS SIDEFF
+  [ "Hint" "Resolve" "->" ne_global_list(lc) natural_opt(n)
     ":" preident_list(bl) ] ->
   [ add_hints_iff true lc n bl ]
-| [ "Hint" "Resolve" "->" ne_constr_list(lc) natural_opt(n) ] ->
+| [ "Hint" "Resolve" "->" ne_global_list(lc) natural_opt(n) ] ->
   [ add_hints_iff true lc n ["core"] ]
 END
-VERNAC COMMAND EXTEND HintResolveIffRL
-  [ "Hint" "Resolve" "<-" ne_constr_list(lc) natural_opt(n)
+VERNAC COMMAND EXTEND HintResolveIffRL CLASSIFIED AS SIDEFF
+  [ "Hint" "Resolve" "<-" ne_global_list(lc) natural_opt(n)
     ":" preident_list(bl) ] ->
   [ add_hints_iff false lc n bl ]
-| [ "Hint" "Resolve" "<-" ne_constr_list(lc) natural_opt(n) ] ->
+| [ "Hint" "Resolve" "<-" ne_global_list(lc) natural_opt(n) ] ->
   [ add_hints_iff false lc n ["core"] ]
 END
 
 (**********************************************************************)
 (* Refine                                                             *)
 
-open Refine
+let refine_tac {Glob_term.closure=closure;term=term} =
+  Proofview.Goal.nf_enter begin fun gl ->
+    let concl = Proofview.Goal.concl gl in
+    let env = Proofview.Goal.env gl in
+    let flags = Pretyping.all_no_fail_flags in
+    let tycon = Pretyping.OfType concl in
+    let lvar = { Pretyping.empty_lvar with
+      Pretyping.ltac_constrs = closure.Glob_term.typed;
+      Pretyping.ltac_uconstrs = closure.Glob_term.untyped;
+      Pretyping.ltac_idents = closure.Glob_term.idents;
+    } in
+    let update evd = Pretyping.understand_ltac flags env evd lvar tycon term in
+    Tactics.New.refine ~unsafe:false update
+  end
 
 TACTIC EXTEND refine
-  [ "refine" casted_open_constr(c) ] -> [ refine c ]
+  [ "refine" uconstr(c) ] -> [  refine_tac c ]
 END
 
-let refine_tac = h_refine
-
 (**********************************************************************)
 (* Inversion lemmas (Leminv)                                          *)
 
 open Inv
 open Leminv
 
-VERNAC COMMAND EXTEND DeriveInversionClear
-  [ "Derive" "Inversion_clear" ident(na) hyp(id) ]
-  -> [ inversion_lemma_from_goal 1 na id Term.prop_sort false inv_clear_tac ]
-
-| [ "Derive" "Inversion_clear" natural(n) ident(na) hyp(id) ]
-  -> [ inversion_lemma_from_goal n na id Term.prop_sort false inv_clear_tac ]
+let seff id = Vernacexpr.VtSideff [id], Vernacexpr.VtLater
 
+VERNAC COMMAND EXTEND DeriveInversionClear
 | [ "Derive" "Inversion_clear" ident(na) "with" constr(c) "Sort" sort(s) ]
+  => [ seff na ]
   -> [ 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 (Glob_term.GProp Term.Null) false inv_clear_tac ]
+| [ "Derive" "Inversion_clear" ident(na) "with" constr(c) ] => [ seff na ]
+  -> [ add_inversion_lemma_exn na c GProp false inv_clear_tac ]
 END
 
 open Term
-open Glob_term
 
 VERNAC COMMAND EXTEND DeriveInversion
 | [ "Derive" "Inversion" ident(na) "with" constr(c) "Sort" sort(s) ]
+  => [ seff na ]
   -> [ add_inversion_lemma_exn na c s false inv_tac ]
 
-| [ "Derive" "Inversion" ident(na) "with" constr(c) ]
-  -> [ 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 ]
-
-| [ "Derive" "Inversion" natural(n) ident(na) hyp(id) ]
-  -> [ inversion_lemma_from_goal n na id Term.prop_sort false inv_tac ]
+| [ "Derive" "Inversion" ident(na) "with" constr(c) ] => [ seff na ]
+  -> [ add_inversion_lemma_exn na c GProp false inv_tac ]
 END
 
 VERNAC COMMAND EXTEND DeriveDependentInversion
 | [ "Derive" "Dependent" "Inversion" ident(na) "with" constr(c) "Sort" sort(s) ]
+  => [ seff na ]
   -> [ add_inversion_lemma_exn na c s true dinv_tac ]
-    END
+END
 
 VERNAC COMMAND EXTEND DeriveDependentInversionClear
 | [ "Derive" "Dependent" "Inversion_clear" ident(na) "with" constr(c) "Sort" sort(s) ]
+  => [ seff na ]
   -> [ add_inversion_lemma_exn na c s true dinv_clear_tac ]
 END
 
@@ -401,14 +413,14 @@ END
 
 TACTIC EXTEND subst
 | [ "subst" ne_var_list(l) ] -> [ subst l ]
-| [ "subst" ] -> [ fun gl -> subst_all gl ]
+| [ "subst" ] -> [ subst_all () ]
 END
 
 let simple_subst_tactic_flags =
   { only_leibniz = true; rewrite_dependent_proof = false }
 
 TACTIC EXTEND simple_subst
-| [ "simple" "subst" ] -> [ subst_all ~flags:simple_subst_tactic_flags ]
+| [ "simple" "subst" ] -> [ subst_all ~flags:simple_subst_tactic_flags () ]
 END
 
 open Evar_tactics
@@ -416,29 +428,28 @@ open Evar_tactics
 (**********************************************************************)
 (* Evar creation                                                      *)
 
+(* TODO: add support for some test similar to g_constr.name_colon so that
+   expressions like "evar (list A)" do not raise a syntax error *)
 TACTIC EXTEND evar
   [ "evar" "(" ident(id) ":" lconstr(typ) ")" ] -> [ let_evar (Name id) typ ]
 | [ "evar" constr(typ) ] -> [ let_evar Anonymous typ ]
 END
 
-open Tacexpr
 open Tacticals
 
 TACTIC EXTEND instantiate
-  [ "instantiate" "(" integer(i) ":=" glob(c) ")" hloc(hl) ] ->
-    [instantiate i c hl  ]
-| [ "instantiate" ] -> [ tclNORMEVAR ]
+  [ "instantiate" "(" ident(id) ":=" lglob(c) ")" ] ->
+    [ Tacticals.New.tclTHEN (instantiate_tac_by_name id c) Proofview.V82.nf_evar_goals ]
+| [ "instantiate" "(" integer(i) ":=" lglob(c) ")" hloc(hl) ] ->
+    [ Tacticals.New.tclTHEN (instantiate_tac i c hl) Proofview.V82.nf_evar_goals ]
+| [ "instantiate" ] -> [ Proofview.V82.nf_evar_goals ]
 END
 
-
 (**********************************************************************)
 (** Nijmegen "step" tactic for setoid rewriting                       *)
 
 open Tactics
-open Tactics
-open Libnames
 open Glob_term
-open Summary
 open Libobject
 open Lib
 
@@ -447,8 +458,8 @@ open Lib
      x R y -> x == z -> z R y    (in the left table)
 *)
 
-let transitivity_right_table = ref []
-let transitivity_left_table = ref []
+let transitivity_right_table = Summary.ref [] ~name:"transitivity-steps-r"
+let transitivity_left_table = Summary.ref [] ~name:"transitivity-steps-l"
 
 (* [step] tries to apply a rewriting lemma; then apply [tac] intended to
    complete to proof of the last hypothesis (assumed to state an equality) *)
@@ -456,12 +467,12 @@ let transitivity_left_table = ref []
 let step left x tac =
   let l =
     List.map (fun lem ->
-      tclTHENLAST
-      (apply_with_bindings (lem, ImplicitBindings [x]))
+      Tacticals.New.tclTHENLAST
+        (apply_with_bindings (lem, ImplicitBindings [x]))
         tac)
       !(if left then transitivity_left_table else transitivity_right_table)
   in
-  tclFIRST l
+  Tacticals.New.tclFIRST l
 
 (* Main function to push lemmas in persistent environment *)
 
@@ -476,59 +487,43 @@ let subst_transitivity_lemma (subst,(b,ref)) = (b,subst_mps subst ref)
 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);
+    open_function = (fun i o -> if Int.equal i 1 then cache_transitivity_lemma o);
     subst_function = subst_transitivity_lemma;
     classify_function = (fun o -> Substitute o) }
 
-(* Synchronisation with reset *)
-
-let freeze () = !transitivity_left_table, !transitivity_right_table
-
-let unfreeze (l,r) =
-  transitivity_left_table := l;
-  transitivity_right_table := r
-
-let init () =
-  transitivity_left_table := [];
-  transitivity_right_table := []
-
-let _ =
-  declare_summary "transitivity-steps"
-    { freeze_function = freeze;
-      unfreeze_function = unfreeze;
-      init_function = init }
-
 (* Main entry points *)
 
 let add_transitivity_lemma left lem =
- let lem' = Constrintern.interp_constr Evd.empty (Global.env ()) lem in
+ let lem',ctx (*FIXME*) = Constrintern.interp_constr (Global.env ()) Evd.empty lem in
   add_anonymous_leaf (inTransitivity (left,lem'))
 
 (* Vernacular syntax *)
 
 TACTIC EXTEND stepl
 | ["stepl" constr(c) "by" tactic(tac) ] -> [ step true c (Tacinterp.eval_tactic tac) ]
-| ["stepl" constr(c) ] -> [ step true c tclIDTAC ]
+| ["stepl" constr(c) ] -> [ step true c (Proofview.tclUNIT ()) ]
 END
 
 TACTIC EXTEND stepr
 | ["stepr" constr(c) "by" tactic(tac) ] -> [ step false c (Tacinterp.eval_tactic tac) ]
-| ["stepr" constr(c) ] -> [ step false c tclIDTAC ]
+| ["stepr" constr(c) ] -> [ step false c (Proofview.tclUNIT ()) ]
 END
 
-VERNAC COMMAND EXTEND AddStepl
+VERNAC COMMAND EXTEND AddStepl CLASSIFIED AS SIDEFF
 | [ "Declare" "Left" "Step" constr(t) ] ->
     [ add_transitivity_lemma true t ]
 END
 
-VERNAC COMMAND EXTEND AddStepr
+VERNAC COMMAND EXTEND AddStepr CLASSIFIED AS SIDEFF
 | [ "Declare" "Right" "Step" constr(t) ] ->
     [ add_transitivity_lemma false t ]
 END
 
-VERNAC COMMAND EXTEND ImplicitTactic
+VERNAC COMMAND EXTEND ImplicitTactic CLASSIFIED AS SIDEFF
 | [ "Declare" "Implicit" "Tactic" tactic(tac) ] ->
     [ Pfedit.declare_implicit_tactic (Tacinterp.interp tac) ]
+| [ "Clear" "Implicit" "Tactic" ] ->
+    [ Pfedit.clear_implicit_tactic () ]
 END
 
 
@@ -537,10 +532,10 @@ END
 (**********************************************************************)
 (*spiwack : Vernac commands for retroknowledge                        *)
 
-VERNAC COMMAND EXTEND RetroknowledgeRegister
+VERNAC COMMAND EXTEND RetroknowledgeRegister CLASSIFIED AS SIDEFF
  | [ "Register" constr(c) "as" retroknowledge_field(f) "by" constr(b)] ->
-           [ let tc = Constrintern.interp_constr Evd.empty (Global.env ()) c in
-             let tb = Constrintern.interp_constr Evd.empty (Global.env ()) b in
+           [ let tc,ctx = Constrintern.interp_constr (Global.env ()) Evd.empty c in
+             let tb,ctx(*FIXME*) = Constrintern.interp_constr (Global.env ()) Evd.empty b in
              Global.register f tc tb ]
 END
 
@@ -567,7 +562,7 @@ END
     during dependent induction. For internal use. *)
 
 TACTIC EXTEND specialize_eqs
-[ "specialize_eqs" hyp(id) ] -> [ specialize_eqs id ]
+[ "specialize_eqs" hyp(id) ] -> [ Proofview.V82.tactic (specialize_eqs id) ]
 END
 
 (**********************************************************************)
@@ -579,26 +574,36 @@ END
 (**********************************************************************)
 
 let subst_var_with_hole occ tid t = 
-  let occref = if occ > 0 then ref occ else Termops.error_invalid_occurrence [occ] in
+  let occref = if occ > 0 then ref occ else Find_subterm.error_invalid_occurrence [occ] in
   let locref = ref 0 in
   let rec substrec = function
     | GVar (_,id) as x -> 
-        if id = tid 
-        then (decr occref; if !occref = 0 then x
-                           else (incr locref; GHole (make_loc (!locref,0),Evd.QuestionMark(Evd.Define true))))
+        if Id.equal id tid 
+        then
+	  (decr occref;
+	   if Int.equal !occref 0 then x
+           else
+	     (incr locref;
+	      GHole (Loc.make_loc (!locref,0),
+		     Evar_kinds.QuestionMark(Evar_kinds.Define true),
+                     Misctypes.IntroAnonymous, None)))
         else x
     | c -> map_glob_constr_left_to_right substrec c in
   let t' = substrec t
   in
-  if !occref > 0 then Termops.error_invalid_occurrence [occ] else t'
+  if !occref > 0 then Find_subterm.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
-    | GHole (_,Evd.QuestionMark(Evd.Define true)) -> 
-        decr occref; if !occref = 0 then tc
-                     else (incr locref; GHole (make_loc (!locref,0),Evd.QuestionMark(Evd.Define true)))
+    | GHole (_,Evar_kinds.QuestionMark(Evar_kinds.Define true),Misctypes.IntroAnonymous,s) ->
+        decr occref;
+        if Int.equal !occref 0 then tc
+        else
+	  (incr locref;
+	   GHole (Loc.make_loc (!locref,0),
+		  Evar_kinds.QuestionMark(Evar_kinds.Define true),Misctypes.IntroAnonymous,s))
     | c -> map_glob_constr_left_to_right substrec c
   in
   substrec t
@@ -606,31 +611,38 @@ let subst_hole_with_term occ tc t =
 open Tacmach
 
 let out_arg = function
-  | ArgVar _ -> anomaly "Unevaluated or_var variable"
+  | ArgVar _ -> anomaly (Pp.str "Unevaluated or_var variable")
   | ArgArg x -> x
 
-let hResolve id c occ t gl = 
-  let sigma = project gl in 
-  let env = Termops.clear_named_body id (pf_env gl) in
+let hResolve id c occ t =
+  Proofview.Goal.nf_enter begin fun gl ->
+  let sigma = Proofview.Goal.sigma gl in
+  let env = Termops.clear_named_body id (Proofview.Goal.env gl) in
+  let concl = Proofview.Goal.concl 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 c_raw = Detyping.detype true env_ids env sigma c in
+  let t_raw = Detyping.detype true env_ids env sigma t in
   let rec resolve_hole t_hole =
     try 
-      Pretyping.Default.understand sigma env t_hole
-    with 
-    | Loc.Exc_located (loc,Pretype_errors.PretypeError (_,_,Pretype_errors.UnsolvableImplicit _)) ->
-        resolve_hole (subst_hole_with_term (fst (unloc loc)) c_raw t_hole)
+      Pretyping.understand env sigma t_hole
+    with
+      | Pretype_errors.PretypeError (_,_,Pretype_errors.UnsolvableImplicit _) as e ->
+          let (e, info) = Errors.push e in
+          let loc = match Loc.get_loc info with None -> Loc.ghost | Some loc -> loc in
+          resolve_hole (subst_hole_with_term (fst (Loc.unloc loc)) c_raw t_hole)
   in
-  let t_constr = resolve_hole (subst_var_with_hole occ id t_raw) in
+  let t_constr,ctx = resolve_hole (subst_var_with_hole occ id t_raw) in
+  let sigma = Evd.merge_universe_context sigma ctx in
   let t_constr_type = Retyping.get_type_of env sigma t_constr in
-  change_in_concl None (mkLetIn (Anonymous,t_constr,t_constr_type,pf_concl gl)) gl
+  Tacticals.New.tclTHEN
+    (Proofview.Unsafe.tclEVARS sigma)
+    (change_concl (mkLetIn (Anonymous,t_constr,t_constr_type,concl)))
+  end
 
-let hResolve_auto id c t gl =
+let hResolve_auto id c t =
   let rec resolve_auto n = 
     try
-      hResolve id c n t gl
+      hResolve id c n t
     with
     | UserError _ as e -> raise e
     | e when Errors.noncritical e -> resolve_auto (n+1)
@@ -646,18 +658,18 @@ END
    hget_evar
 *)
 
-open Evar_refiner
-open Sign
-
-let hget_evar n gl =
-  let sigma = project gl in
-  let evl = evar_list sigma (pf_concl gl) in
+let hget_evar n =
+  Proofview.Goal.nf_enter begin fun gl ->
+  let sigma = Proofview.Goal.sigma gl in
+  let concl = Proofview.Goal.concl gl in
+  let evl = evar_list concl in
   if List.length evl < n then
     error "Not enough uninstantiated existential variables.";
   if n <= 0 then error "Incorrect existential variable index.";
   let ev = List.nth evl (n-1) in
   let ev_type = existential_type sigma ev in
-  change_in_concl None (mkLetIn (Anonymous,mkEvar ev,ev_type,pf_concl gl)) gl
+  change_concl (mkLetIn (Anonymous,mkEvar ev,ev_type,concl))
+  end
 
 TACTIC EXTEND hget_evar
 | [ "hget_evar" int_or_var(n) ] -> [ hget_evar (out_arg n) ]
@@ -673,12 +685,15 @@ END
 (* Contributed by Julien Forest and Pierre Courtieu (july 2010)       *)
 (**********************************************************************)
 
-exception Found of tactic
+exception Found of unit Proofview.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 rewrite_except h =
+  Proofview.Goal.nf_enter begin fun gl ->
+  let hyps = Tacmach.New.pf_ids_of_hyps gl in
+  Tacticals.New.tclMAP (fun id -> if Id.equal id h then Proofview.tclUNIT () else 
+      Tacticals.New.tclTRY (Equality.general_rewrite_in true Locus.AllOccurrences true true id (mkVar h) false))
+    hyps
+  end
 
 
 let refl_equal = 
@@ -691,31 +706,39 @@ let refl_equal =
 (* 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 [
+let  mkCaseEq a  : unit Proofview.tactic =
+  Proofview.Goal.nf_enter begin fun gl ->
+    let type_of_a = Tacmach.New.of_old (fun g -> Tacmach.pf_type_of g a) gl in
+       Tacticals.New.tclTHENLIST
+         [Proofview.V82.tactic (Tactics.Simple.generalize [mkApp(delayed_force refl_equal, [| type_of_a; a|])]);
+          Proofview.Goal.nf_enter begin fun gl ->
+            let concl = Proofview.Goal.concl gl in
+            let env = Proofview.Goal.env gl in
+	    change_concl
+	      (snd (Tacred.pattern_occs [Locus.OnlyOccurrences [1], a] env Evd.empty concl))
+          end;
+	  simplest_case a]
+  end
+
+
+let case_eq_intros_rewrite x =
+  Proofview.Goal.nf_enter begin fun gl ->
+  let n = nb_prod (Proofview.Goal.concl gl) in
+  (* Pp.msgnl (Printer.pr_lconstr x); *)
+  Tacticals.New.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
+    Proofview.Goal.nf_enter begin fun gl ->
+      let concl = Proofview.Goal.concl gl in
+      let hyps = Tacmach.New.pf_ids_of_hyps gl in
+      let n' = nb_prod concl in
+      let h = Tacmach.New.of_old (fun g -> fresh_id hyps (Id.of_string "heq") g) gl in
+      Tacticals.New.tclTHENLIST [
+                    Tacticals.New.tclDO (n'-n-1) intro;
+		    introduction h;
+		    rewrite_except h]
+    end
+  ]
+  end
 
 let rec find_a_destructable_match t =
   match kind_of_term t with
@@ -724,40 +747,52 @@ let rec find_a_destructable_match t =
 	  (* TODO check there is no rel n. *)
 	  raise (Found (Tacinterp.eval_tactic(<:tactic<destruct x>>)))
 	else
-	  let _ = Pp.msgnl (Printer.pr_lconstr x)  in
+	  (* 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"
+    Proofview.tclZERO (UserError ("",  str"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
+let destauto_in id = 
+  Proofview.Goal.nf_enter begin fun gl ->
+  let ctype = Tacmach.New.of_old (fun g -> Tacmach.pf_type_of g (mkVar id)) gl in
+(*  Pp.msgnl (Printer.pr_lconstr (mkVar id)); *)
+(*  Pp.msgnl (Printer.pr_lconstr (ctype)); *)
+  destauto ctype
+  end
 
 TACTIC EXTEND destauto
-| [ "destauto" ] -> [ (fun g -> destauto (Tacmach.pf_concl g) g) ]
+| [ "destauto" ] -> [ Proofview.Goal.nf_enter (fun gl -> destauto (Proofview.Goal.concl gl)) ]
 | [ "destauto" "in" hyp(id) ] -> [ destauto_in id ]
 END
 
 
 (* ********************************************************************* *)
 
+let eq_constr x y = 
+  Proofview.Goal.enter (fun gl ->
+    let evd = Proofview.Goal.sigma gl in
+      if Evd.eq_constr_univs_test evd x y then Proofview.tclUNIT () 
+      else Tacticals.New.tclFAIL 0 (str "Not equal"))
+
 TACTIC EXTEND constr_eq
-| [ "constr_eq" constr(x) constr(y) ] -> [
-    if eq_constr x y then tclIDTAC else tclFAIL 0 (str "Not equal") ]
+| [ "constr_eq" constr(x) constr(y) ] -> [ eq_constr x y ]
+END
+
+TACTIC EXTEND constr_eq_nounivs
+| [ "constr_eq_nounivs" constr(x) constr(y) ] -> [
+    if eq_constr_nounivs x y then Proofview.tclUNIT () else Tacticals.New.tclFAIL 0 (str "Not equal") ]
 END
 
 TACTIC EXTEND is_evar
 | [ "is_evar" constr(x) ] ->
     [ match kind_of_term x with
-        | Evar _ -> tclIDTAC
-        | _ -> tclFAIL 0 (str "Not an evar")
+        | Evar _ -> Proofview.tclUNIT ()
+        | _ -> Tacticals.New.tclFAIL 0 (str "Not an evar")
     ]
 END
 
@@ -776,28 +811,36 @@ let rec has_evar x =
       has_evar t1 || has_evar t2 || has_evar_array ts
     | Fix ((_, tr)) | CoFix ((_, tr)) ->
       has_evar_prec tr
+    | Proj (p, c) -> has_evar c
 and has_evar_array x =
-  array_exists has_evar x
+  Array.exists has_evar x
 and has_evar_prec (_, ts1, ts2) =
-  array_exists has_evar ts1 || array_exists has_evar ts2
+  Array.exists has_evar ts1 || Array.exists has_evar ts2
 
 TACTIC EXTEND has_evar
 | [ "has_evar" constr(x) ] ->
-    [ if has_evar x then tclIDTAC else tclFAIL 0 (str "No evars") ]
+    [ if has_evar x then Proofview.tclUNIT () else Tacticals.New.tclFAIL 0 (str "No evars") ]
 END
 
 TACTIC EXTEND is_hyp
 | [ "is_var" constr(x) ] ->
   [ match kind_of_term x with
-    | Var _ -> tclIDTAC
-    | _ -> tclFAIL 0 (str "Not a variable or hypothesis") ]
+    | Var _ ->  Proofview.tclUNIT ()
+    | _ -> Tacticals.New.tclFAIL 0 (str "Not a variable or hypothesis") ]
 END
 
 TACTIC EXTEND is_fix
 | [ "is_fix" constr(x) ] ->
   [ match kind_of_term x with
-    | Fix _ -> Tacticals.tclIDTAC
-    | _ -> Tacticals.tclFAIL 0 (Pp.str "not a fix definition") ]
+    | Fix _ -> Proofview.tclUNIT ()
+    | _ -> Tacticals.New.tclFAIL 0 (Pp.str "not a fix definition") ]
+END;;
+
+TACTIC EXTEND is_cofix
+| [ "is_cofix" constr(x) ] ->
+  [ match kind_of_term x with
+    | CoFix _ -> Proofview.tclUNIT ()
+    | _ -> Tacticals.New.tclFAIL 0 (Pp.str "not a cofix definition") ]
 END;;
 
 (* Command to grab the evars left unresolved at the end of a proof. *)
@@ -805,8 +848,169 @@ END;;
    the semantics of the LCF-style tactics, hence with the classic tactic
    mode. *)
 VERNAC COMMAND EXTEND GrabEvars
-[ "Grab" "Existential" "Variables" ] ->
-  [ let p = Proof_global.give_me_the_proof () in
-    Proof.V82.grab_evars p;
-    Flags.if_verbose (fun () -> Pp.msg (Printer.pr_open_subgoals ())) () ]
+[ "Grab" "Existential" "Variables" ]
+  => [ Vernacexpr.VtProofStep false, Vernacexpr.VtLater ]
+  -> [ Proof_global.simple_with_current_proof (fun _ p  -> Proof.V82.grab_evars p) ]
+END
+
+(* Shelves all the goals under focus. *)
+TACTIC EXTEND shelve
+| [ "shelve" ] ->
+    [ Proofview.shelve ]
+END
+
+(* Shelves the unifiable goals under focus, i.e. the goals which
+   appear in other goals under focus (the unfocused goals are not
+   considered). *)
+TACTIC EXTEND shelve_unifiable
+| [ "shelve_unifiable" ] ->
+    [ Proofview.shelve_unifiable ]
+END
+
+(* Command to add every unshelved variables to the focus *)
+VERNAC COMMAND EXTEND Unshelve
+[ "Unshelve" ]
+  => [ Vernacexpr.VtProofStep false, Vernacexpr.VtLater ]
+  -> [ Proof_global.simple_with_current_proof (fun _ p  -> Proof.unshelve p) ]
+END
+
+(* Gives up on the goals under focus: the goals are considered solved,
+   but the proof cannot be closed until the user goes back and solve
+   these goals. *)
+TACTIC EXTEND give_up
+| [ "give_up" ] ->
+    [ Proofview.give_up ]
+END
+
+(* cycles [n] goals *)
+TACTIC EXTEND cycle
+| [ "cycle" int_or_var(n) ] -> [ Proofview.cycle (out_arg n) ]
+END
+
+(* swaps goals number [i] and [j] *)
+TACTIC EXTEND swap
+| [ "swap" int_or_var(i) int_or_var(j) ] -> [ Proofview.swap (out_arg i) (out_arg j) ]
+END
+
+(* reverses the list of focused goals *)
+TACTIC EXTEND revgoals
+| [ "revgoals" ] -> [ Proofview.revgoals ]
+END
+
+
+type cmp =
+  | Eq
+  | Lt | Le
+  | Gt | Ge
+
+type 'i test =
+  | Test of cmp * 'i * 'i
+
+let wit_cmp : (cmp,cmp,cmp) Genarg.genarg_type = Genarg.make0 None "cmp"
+let wit_test : (int or_var test,int or_var test,int test) Genarg.genarg_type =
+  Genarg.make0 None "tactest"
+
+let pr_cmp = function
+  | Eq -> Pp.str"="
+  | Lt -> Pp.str"<"
+  | Le -> Pp.str"<="
+  | Gt -> Pp.str">"
+  | Ge -> Pp.str">="
+
+let pr_cmp' _prc _prlc _prt = pr_cmp
+
+let pr_test_gen f (Test(c,x,y)) =
+  Pp.(f x ++ pr_cmp c ++ f y)
+
+let pr_test = pr_test_gen (Pptactic.pr_or_var Pp.int)
+
+let pr_test' _prc _prlc _prt = pr_test
+
+let pr_itest = pr_test_gen Pp.int
+
+let pr_itest' _prc _prlc _prt = pr_itest
+
+
+
+ARGUMENT EXTEND comparison TYPED AS cmp PRINTED BY pr_cmp'
+| [ "="  ] -> [ Eq ]
+| [ "<"  ] -> [ Lt ]
+| [ "<=" ] -> [ Le ]
+| [ ">"  ] -> [ Gt ]
+| [ ">=" ] -> [ Ge ]
+    END
+
+let interp_test ist gls = function
+  | Test (c,x,y) ->
+      project gls ,
+      Test(c,Tacinterp.interp_int_or_var ist x,Tacinterp.interp_int_or_var ist y)
+
+ARGUMENT EXTEND test
+  PRINTED BY pr_itest'
+  INTERPRETED BY interp_test
+  RAW_TYPED AS test
+  RAW_PRINTED BY pr_test'
+  GLOB_TYPED AS test
+  GLOB_PRINTED BY pr_test'
+| [ int_or_var(x) comparison(c) int_or_var(y) ] -> [ Test(c,x,y) ]
+END
+
+let interp_cmp = function
+  | Eq -> Int.equal
+  | Lt -> ((<):int->int->bool)
+  | Le -> ((<=):int->int->bool)
+  | Gt -> ((>):int->int->bool)
+  | Ge -> ((>=):int->int->bool)
+
+let run_test = function
+  | Test(c,x,y) -> interp_cmp c x y
+
+let guard tst =
+  if run_test tst then
+    Proofview.tclUNIT ()
+  else
+    let msg = Pp.(str"Condition not satisfied:"++ws 1++(pr_itest tst)) in
+    Proofview.tclZERO (Errors.UserError("guard",msg))
+
+
+TACTIC EXTEND guard
+| [ "guard" test(tst) ] -> [ guard tst ]
+END
+
+let decompose l c =
+  Proofview.Goal.enter begin fun gl ->
+    let to_ind c =
+      if isInd c then Univ.out_punivs (destInd c)
+      else error "not an inductive type"
+    in
+    let l = List.map to_ind l in
+    Elim.h_decompose l c
+  end
+
+TACTIC EXTEND decompose
+| [ "decompose" "[" ne_constr_list(l) "]" constr(c) ] -> [ decompose l c ]
+END
+
+(** library/keys *)
+
+VERNAC COMMAND EXTEND Declare_keys CLASSIFIED AS SIDEFF
+| [ "Declare" "Equivalent" "Keys" constr(c) constr(c') ] -> [ 
+  let it c = snd (Constrintern.interp_open_constr (Global.env ()) Evd.empty c) in 
+  let k1 = Keys.constr_key (it c) in
+  let k2 = Keys.constr_key (it c') in
+    match k1, k2 with
+    | Some k1, Some k2 -> Keys.declare_equiv_keys k1 k2
+    | _ -> () ]
+END
+
+VERNAC COMMAND EXTEND Print_keys CLASSIFIED AS QUERY
+| [ "Print" "Equivalent" "Keys" ] -> [ msg_info (Keys.pr_keys Printer.pr_global) ]
+END
+
+
+VERNAC COMMAND EXTEND OptimizeProof
+| [ "Optimize" "Proof" ] => [ Vernac_classifier.classify_as_proofstep ] ->
+  [ Proof_global.compact_the_proof () ]
+| [ "Optimize" "Heap" ] => [ Vernac_classifier.classify_as_proofstep ] ->
+  [ Gc.compact () ]
 END
diff --git a/tactics/extratactics.mli b/tactics/extratactics.mli
index 934d94fc..72c2679c 100644
--- a/tactics/extratactics.mli
+++ b/tactics/extratactics.mli
@@ -1,16 +1,14 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-open Proof_type
+val discrHyp : Names.Id.t -> unit Proofview.tactic
+val injHyp : Names.Id.t -> unit Proofview.tactic
 
-val h_discrHyp : Names.identifier -> tactic
-val h_injHyp : Names.identifier -> tactic
+(* val refine_tac : Evd.open_constr -> unit Proofview.tactic *)
 
-val refine_tac : Evd.open_constr -> tactic
-
-val onSomeWithHoles : ('a option -> tactic) -> 'a Evd.sigma option -> tactic
+val onSomeWithHoles : ('a option -> unit Proofview.tactic) -> 'a Evd.sigma option -> unit Proofview.tactic
diff --git a/tactics/ftactic.ml b/tactics/ftactic.ml
new file mode 100644
index 00000000..fea0432a
--- /dev/null
+++ b/tactics/ftactic.ml
@@ -0,0 +1,86 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+open Proofview.Notations
+
+(** Focussing tactics *)
+
+type 'a focus =
+| Uniform of 'a
+| Depends of 'a list
+
+(** Type of tactics potentially goal-dependent. If it contains a [Depends],
+    then the length of the inner list is guaranteed to be the number of
+    currently focussed goals. Otherwise it means the tactic does not depends
+    on the current set of focussed goals. *)
+type 'a t = 'a focus Proofview.tactic
+
+let return (x : 'a) : 'a t = Proofview.tclUNIT (Uniform x)
+
+let bind (type a) (type b) (m : a t) (f : a -> b t) : b t = m >>= function
+| Uniform x -> f x
+| Depends l ->
+  let f arg = f arg >>= function
+  | Uniform x ->
+    (** We dispatch the uniform result on each goal under focus, as we know
+        that the [m] argument was actually dependent. *)
+    Proofview.Goal.goals >>= fun l ->
+    let ans = List.map (fun _ -> x) l in
+    Proofview.tclUNIT ans
+  | Depends l -> Proofview.tclUNIT l
+  in
+  Proofview.tclDISPATCHL (List.map f l) >>= fun l ->
+  Proofview.tclUNIT (Depends (List.concat l))
+
+let nf_enter f =
+  bind (Proofview.Goal.goals >>= fun l -> Proofview.tclUNIT (Depends l))
+    (fun gl ->
+      gl >>= fun gl ->
+      Proofview.Goal.normalize gl >>= fun nfgl ->
+      Proofview.V82.wrap_exceptions (fun () -> f nfgl))
+
+let enter f =
+  bind (Proofview.Goal.goals >>= fun l -> Proofview.tclUNIT (Depends l))
+    (fun gl -> gl >>= fun gl -> Proofview.V82.wrap_exceptions (fun () -> f gl))
+
+let with_env t =
+  t >>= function
+    | Uniform a ->
+        Proofview.tclENV >>= fun env -> Proofview.tclUNIT (Uniform (env,a))
+    | Depends l ->
+        Proofview.Goal.goals >>= fun gs ->
+        Proofview.Monad.(List.map (map Proofview.Goal.env) gs) >>= fun envs ->
+        Proofview.tclUNIT (Depends (List.combine envs l))
+
+let lift (type a) (t:a Proofview.tactic) : a t =
+  Proofview.tclBIND t (fun x -> Proofview.tclUNIT (Uniform x))
+
+(** If the tactic returns unit, we can focus on the goals if necessary. *)
+let run m k = m >>= function
+| Uniform v -> k v
+| Depends l ->
+  let tacs = List.map k l in
+  Proofview.tclDISPATCH tacs
+
+let (>>=) = bind
+
+let (<*>) = fun m n -> bind m (fun () -> n)
+
+module Self =
+struct
+  type 'a t = 'a focus Proofview.tactic
+  let return = return
+  let (>>=) = bind
+  let (>>) = (<*>)
+  let map f x = x >>= fun a -> return (f a)
+end
+
+module Ftac = Monad.Make(Self)
+module List = Ftac.List
+
+let debug_prompt = Tactic_debug.debug_prompt
diff --git a/tactics/ftactic.mli b/tactics/ftactic.mli
new file mode 100644
index 00000000..48351567
--- /dev/null
+++ b/tactics/ftactic.mli
@@ -0,0 +1,67 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(** Potentially focussing tactics *)
+
+type +'a focus
+
+type +'a t = 'a focus Proofview.tactic
+(** The type of focussing tactics. A focussing tactic is like a normal tactic,
+    except that it is able to remember it have entered a goal. Whenever this is
+    the case, each subsequent effect of the tactic is dispatched on the
+    focussed goals. This is a monad. *)
+
+(** {5 Monadic interface} *)
+
+val return : 'a -> 'a t
+(** The unit of the monad. *)
+
+val bind : 'a t -> ('a -> 'b t) -> 'b t
+(** The bind of the monad. *)
+
+(** {5 Operations} *)
+
+val lift : 'a Proofview.tactic -> 'a t
+(** Transform a tactic into a focussing tactic. The resulting tactic is not
+    focussed. *)
+
+val run : 'a t -> ('a -> unit Proofview.tactic) -> unit Proofview.tactic
+(** Given a continuation producing a tactic, evaluates the focussing tactic. If
+    the tactic has not focussed, then the continuation is evaluated once.
+    Otherwise it is called in each of the currently focussed goals. *)
+
+(** {5 Focussing} *)
+
+val nf_enter : ([ `NF ] Proofview.Goal.t -> 'a t) -> 'a t
+(** Enter a goal. The resulting tactic is focussed. *)
+
+val enter : ([ `LZ ] Proofview.Goal.t -> 'a t) -> 'a t
+(** Enter a goal, without evar normalization. The resulting tactic is
+    focussed. *)
+
+val with_env : 'a t -> (Environ.env*'a) t
+(** [with_env t] returns, in addition to the return type of [t], an
+    environment, which is the global environment if [t] does not focus on
+    goals, or the local goal environment if [t] focuses on goals. *)
+
+(** {5 Notations} *)
+
+val (>>=) : 'a t -> ('a -> 'b t) -> 'b t
+(** Notation for {!bind}. *)
+
+val (<*>) : unit t -> 'a t -> 'a t
+(** Sequence. *)
+
+(** {5 List operations} *)
+
+module List : Monad.ListS with type 'a t := 'a t
+
+(** {5 Debug} *)
+
+val debug_prompt :
+  int -> Tacexpr.glob_tactic_expr -> (Tactic_debug.debug_info -> 'a t) -> 'a t
diff --git a/tactics/g_class.ml4 b/tactics/g_class.ml4
new file mode 100644
index 00000000..a55da35e
--- /dev/null
+++ b/tactics/g_class.ml4
@@ -0,0 +1,84 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i camlp4deps: "grammar/grammar.cma" i*)
+
+open Misctypes
+open Class_tactics
+
+DECLARE PLUGIN "g_class"
+
+TACTIC EXTEND progress_evars
+  [ "progress_evars" tactic(t) ] -> [ progress_evars (Tacinterp.eval_tactic t) ]
+END
+
+(** Options: depth, debug and transparency settings. *)
+
+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 false b) cl
+
+VERNAC COMMAND EXTEND Typeclasses_Unfold_Settings CLASSIFIED AS SIDEFF
+| [ "Typeclasses" "Transparent" reference_list(cl) ] -> [
+    set_transparency cl true ]
+END
+
+VERNAC COMMAND EXTEND Typeclasses_Rigid_Settings CLASSIFIED AS SIDEFF
+| [ "Typeclasses" "Opaque" reference_list(cl) ] -> [
+    set_transparency cl false ]
+END
+
+open Genarg
+
+let pr_debug _prc _prlc _prt b =
+  if b then Pp.str "debug" else Pp.mt()
+
+ARGUMENT EXTEND debug TYPED AS bool PRINTED BY pr_debug
+| [ "debug" ] -> [ true ]
+| [ ] -> [ false ]
+END
+
+let pr_depth _prc _prlc _prt = function
+    Some i -> Pp.int i
+  | None -> Pp.mt()
+
+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 CLASSIFIED AS SIDEFF
+ | [ "Typeclasses" "eauto" ":=" debug(d) depth(depth) ] -> [
+     set_typeclasses_debug d;
+     set_typeclasses_depth depth
+   ]
+END
+
+TACTIC EXTEND typeclasses_eauto
+| [ "typeclasses" "eauto" "with" ne_preident_list(l) ] -> [ Proofview.V82.tactic (typeclasses_eauto l) ]
+| [ "typeclasses" "eauto" ] -> [ Proofview.V82.tactic (typeclasses_eauto ~only_classes:true [Hints.typeclasses_db]) ]
+END
+
+TACTIC EXTEND head_of_constr
+  [ "head_of_constr" ident(h) constr(c) ] -> [ head_of_constr h c ]
+END
+
+TACTIC EXTEND not_evar
+  [ "not_evar" constr(ty) ] -> [ not_evar ty ]
+END
+
+TACTIC EXTEND is_ground
+  [ "is_ground" constr(ty) ] -> [ Proofview.V82.tactic (is_ground ty) ]
+END
+
+TACTIC EXTEND autoapply
+  [ "autoapply" constr(c) "using" preident(i) ] -> [ Proofview.V82.tactic (autoapply c i) ]
+END
diff --git a/tactics/g_eqdecide.ml4 b/tactics/g_eqdecide.ml4
new file mode 100644
index 00000000..1bd8f075
--- /dev/null
+++ b/tactics/g_eqdecide.ml4
@@ -0,0 +1,27 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(************************************************************************)
+(*                              EqDecide                               *)
+(*   A tactic for deciding propositional equality on inductive types   *)
+(*                           by Eduardo Gimenez                        *)
+(************************************************************************)
+
+(*i camlp4deps: "grammar/grammar.cma" i*)
+
+open Eqdecide
+
+DECLARE PLUGIN "g_eqdecide"
+
+TACTIC EXTEND decide_equality
+| [ "decide" "equality" ] -> [ decideEqualityGoal ]
+END
+
+TACTIC EXTEND compare
+| [ "compare" constr(c1) constr(c2) ] -> [ compare c1 c2 ]
+END
diff --git a/tactics/g_rewrite.ml4 b/tactics/g_rewrite.ml4
new file mode 100644
index 00000000..d60cc126
--- /dev/null
+++ b/tactics/g_rewrite.ml4
@@ -0,0 +1,263 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i camlp4deps: "grammar/grammar.cma" i*)
+
+(* Syntax for rewriting with strategies *)
+
+open Names
+open Misctypes
+open Locus
+open Constrexpr
+open Glob_term
+open Geninterp
+open Extraargs
+open Tacmach
+open Tacticals
+open Rewrite
+
+DECLARE PLUGIN "g_rewrite"
+
+type constr_expr_with_bindings = constr_expr with_bindings
+type glob_constr_with_bindings = Tacexpr.glob_constr_and_expr with_bindings
+type glob_constr_with_bindings_sign = interp_sign * Tacexpr.glob_constr_and_expr with_bindings
+
+let pr_glob_constr_with_bindings_sign _ _ _ (ge : glob_constr_with_bindings_sign) = Printer.pr_glob_constr (fst (fst (snd ge)))
+let pr_glob_constr_with_bindings _ _ _ (ge : glob_constr_with_bindings) = Printer.pr_glob_constr (fst (fst ge))
+let pr_constr_expr_with_bindings prc _ _ (ge : constr_expr_with_bindings) = prc (fst ge)
+let interp_glob_constr_with_bindings ist gl c = Tacmach.project gl , (ist, c)
+let glob_glob_constr_with_bindings ist l = Tacintern.intern_constr_with_bindings ist l
+let subst_glob_constr_with_bindings s c =
+  Tacsubst.subst_glob_with_bindings s c
+
+ARGUMENT EXTEND glob_constr_with_bindings
+    PRINTED BY pr_glob_constr_with_bindings_sign
+
+    INTERPRETED BY interp_glob_constr_with_bindings
+    GLOBALIZED BY glob_glob_constr_with_bindings
+    SUBSTITUTED BY subst_glob_constr_with_bindings
+
+    RAW_TYPED AS constr_expr_with_bindings
+    RAW_PRINTED BY pr_constr_expr_with_bindings
+
+    GLOB_TYPED AS glob_constr_with_bindings
+    GLOB_PRINTED BY pr_glob_constr_with_bindings
+
+   [ constr_with_bindings(bl) ] -> [ bl ]
+END
+
+type raw_strategy = (constr_expr, Tacexpr.raw_red_expr) strategy_ast
+type glob_strategy = (Tacexpr.glob_constr_and_expr, Tacexpr.raw_red_expr) strategy_ast
+
+let interp_strategy ist gl s = 
+  let sigma = project gl in
+    sigma, strategy_of_ast s
+let glob_strategy ist s = map_strategy (Tacintern.intern_constr ist) (fun c -> c) s
+let subst_strategy s str = str
+
+let pr_strategy _ _ _ (s : strategy) = Pp.str "<strategy>"
+let pr_raw_strategy _ _ _ (s : raw_strategy) = Pp.str "<strategy>"
+let pr_glob_strategy _ _ _ (s : glob_strategy) = Pp.str "<strategy>"
+
+ARGUMENT EXTEND rewstrategy
+    PRINTED BY pr_strategy
+
+    INTERPRETED BY interp_strategy
+    GLOBALIZED BY glob_strategy
+    SUBSTITUTED BY subst_strategy
+
+    RAW_TYPED AS raw_strategy
+    RAW_PRINTED BY pr_raw_strategy
+
+    GLOB_TYPED AS glob_strategy
+    GLOB_PRINTED BY pr_glob_strategy
+
+    [ glob(c) ] -> [ StratConstr (c, true) ]
+  | [ "<-" constr(c) ] -> [ StratConstr (c, false) ]
+  | [ "subterms" rewstrategy(h) ] -> [ StratUnary (Subterms, h) ]
+  | [ "subterm" rewstrategy(h) ] -> [ StratUnary (Subterm, h) ]
+  | [ "innermost" rewstrategy(h) ] -> [ StratUnary(Innermost, h) ]
+  | [ "outermost" rewstrategy(h) ] -> [ StratUnary(Outermost, h) ]
+  | [ "bottomup" rewstrategy(h) ] -> [ StratUnary(Bottomup, h) ]
+  | [ "topdown" rewstrategy(h) ] -> [ StratUnary(Topdown, h) ]
+  | [ "id" ] -> [ StratId ]
+  | [ "fail" ] -> [ StratFail ]
+  | [ "refl" ] -> [ StratRefl ]
+  | [ "progress" rewstrategy(h) ] -> [ StratUnary (Progress, h) ]
+  | [ "try" rewstrategy(h) ] -> [ StratUnary (Try, h) ]
+  | [ "any" rewstrategy(h) ] -> [ StratUnary (Any, h) ]
+  | [ "repeat" rewstrategy(h) ] -> [ StratUnary (Repeat, h) ]
+  | [ rewstrategy(h) ";" rewstrategy(h') ] -> [ StratBinary (Compose, h, h') ]
+  | [ "(" rewstrategy(h) ")" ] -> [ h ]
+  | [ "choice" rewstrategy(h) rewstrategy(h') ] -> [ StratBinary (Choice, h, h') ]
+  | [ "old_hints" preident(h) ] -> [ StratHints (true, h) ]
+  | [ "hints" preident(h) ] -> [ StratHints (false, h) ]
+  | [ "terms" constr_list(h) ] -> [ StratTerms h ]
+  | [ "eval" red_expr(r) ] -> [ StratEval r ]
+  | [ "fold" constr(c) ] -> [ StratFold c ]
+END
+
+(* By default the strategy for "rewrite_db" is top-down *)
+
+let db_strat db = StratUnary (Topdown, StratHints (false, db))
+let cl_rewrite_clause_db db = cl_rewrite_clause_strat (strategy_of_ast (db_strat db))
+
+let cl_rewrite_clause_db = 
+  if Flags.profile then
+    let key = Profile.declare_profile "cl_rewrite_clause_db" in
+      Profile.profile3 key cl_rewrite_clause_db
+  else cl_rewrite_clause_db
+
+TACTIC EXTEND rewrite_strat
+| [ "rewrite_strat" rewstrategy(s) "in" hyp(id) ] -> [ Proofview.V82.tactic (cl_rewrite_clause_strat s (Some id)) ]
+| [ "rewrite_strat" rewstrategy(s) ] -> [ Proofview.V82.tactic (cl_rewrite_clause_strat s None) ]
+| [ "rewrite_db" preident(db) "in" hyp(id) ] -> [ Proofview.V82.tactic (cl_rewrite_clause_db db (Some id)) ]
+| [ "rewrite_db" preident(db) ] -> [ Proofview.V82.tactic (cl_rewrite_clause_db db None) ]
+END
+
+let clsubstitute o c =
+  let is_tac id = match fst (fst (snd c)) with GVar (_, id') when Id.equal id' id -> true | _ -> false in
+    Tacticals.onAllHypsAndConcl
+      (fun cl ->
+        match cl with
+          | Some id when is_tac id -> tclIDTAC
+          | _ -> cl_rewrite_clause c o AllOccurrences cl)
+
+TACTIC EXTEND substitute
+| [ "substitute" orient(o) glob_constr_with_bindings(c) ] -> [ Proofview.V82.tactic (clsubstitute o c) ]
+END
+
+
+(* Compatibility with old Setoids *)
+
+TACTIC EXTEND setoid_rewrite
+   [ "setoid_rewrite" orient(o) glob_constr_with_bindings(c) ]
+   -> [ Proofview.V82.tactic (cl_rewrite_clause c o AllOccurrences None) ]
+ | [ "setoid_rewrite" orient(o) glob_constr_with_bindings(c) "in" hyp(id) ] ->
+      [ Proofview.V82.tactic (cl_rewrite_clause c o AllOccurrences (Some id))]
+ | [ "setoid_rewrite" orient(o) glob_constr_with_bindings(c) "at" occurrences(occ) ] ->
+      [ Proofview.V82.tactic (cl_rewrite_clause c o (occurrences_of occ) None)]
+ | [ "setoid_rewrite" orient(o) glob_constr_with_bindings(c) "at" occurrences(occ) "in" hyp(id)] ->
+      [ Proofview.V82.tactic (cl_rewrite_clause c o (occurrences_of occ) (Some id))]
+ | [ "setoid_rewrite" orient(o) glob_constr_with_bindings(c) "in" hyp(id) "at" occurrences(occ)] ->
+      [ Proofview.V82.tactic (cl_rewrite_clause c o (occurrences_of occ) (Some id))]
+END
+
+VERNAC COMMAND EXTEND AddRelation CLASSIFIED AS SIDEFF
+  | [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1)
+        "symmetry" "proved" "by" constr(lemma2) "as" ident(n) ] ->
+      [ declare_relation a aeq n (Some lemma1) (Some lemma2) None ]
+
+  | [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1)
+        "as" ident(n) ] ->
+      [ declare_relation a aeq n (Some lemma1) None None ]
+  | [ "Add" "Relation" constr(a) constr(aeq)  "as" ident(n) ] ->
+      [ declare_relation a aeq n None None None ]
+END
+
+VERNAC COMMAND EXTEND AddRelation2 CLASSIFIED AS SIDEFF
+    [ "Add" "Relation" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2)
+      "as" ident(n) ] ->
+      [ declare_relation a aeq n None (Some lemma2) None ]
+  | [ "Add" "Relation" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3)  "as" ident(n) ] ->
+      [ declare_relation a aeq n None (Some lemma2) (Some lemma3) ]
+END
+
+VERNAC COMMAND EXTEND AddRelation3 CLASSIFIED AS SIDEFF
+    [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1)
+      "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] ->
+      [ declare_relation a aeq n (Some lemma1) None (Some lemma3) ]
+  | [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1)
+      "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3)
+      "as" ident(n) ] ->
+      [ declare_relation a aeq n (Some lemma1) (Some lemma2) (Some lemma3) ]
+  | [ "Add" "Relation" constr(a) constr(aeq) "transitivity" "proved" "by" constr(lemma3)
+        "as" ident(n) ] ->
+      [ declare_relation a aeq n None None (Some lemma3) ]
+END
+
+type binders_argtype = local_binder list
+
+let wit_binders =
+ (Genarg.create_arg None "binders" : binders_argtype Genarg.uniform_genarg_type)
+
+let binders = Pcoq.create_generic_entry "binders" (Genarg.rawwit wit_binders)
+
+open Pcoq
+
+GEXTEND Gram
+  GLOBAL: binders;
+    binders:
+    [ [ b = Pcoq.Constr.binders -> b ] ];
+END
+
+VERNAC COMMAND EXTEND AddParametricRelation CLASSIFIED AS SIDEFF
+  | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq)
+        "reflexivity" "proved" "by" constr(lemma1)
+        "symmetry" "proved" "by" constr(lemma2) "as" ident(n) ] ->
+      [ declare_relation ~binders:b a aeq n (Some lemma1) (Some lemma2) None ]
+  | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq)
+        "reflexivity" "proved" "by" constr(lemma1)
+        "as" ident(n) ] ->
+      [ declare_relation ~binders:b a aeq n (Some lemma1) None None ]
+  | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq)  "as" ident(n) ] ->
+      [ declare_relation ~binders:b a aeq n None None None ]
+END
+
+VERNAC COMMAND EXTEND AddParametricRelation2 CLASSIFIED AS SIDEFF
+    [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2)
+      "as" ident(n) ] ->
+      [ declare_relation ~binders:b a aeq n None (Some lemma2) None ]
+  | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3)  "as" ident(n) ] ->
+      [ declare_relation ~binders:b a aeq n None (Some lemma2) (Some lemma3) ]
+END
+
+VERNAC COMMAND EXTEND AddParametricRelation3 CLASSIFIED AS SIDEFF
+    [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1)
+      "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] ->
+      [ declare_relation ~binders:b a aeq n (Some lemma1) None (Some lemma3) ]
+  | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1)
+      "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3)
+      "as" ident(n) ] ->
+      [ declare_relation ~binders:b a aeq n (Some lemma1) (Some lemma2) (Some lemma3) ]
+  | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "transitivity" "proved" "by" constr(lemma3)
+        "as" ident(n) ] ->
+      [ declare_relation ~binders:b a aeq n None None (Some lemma3) ]
+END
+
+VERNAC COMMAND EXTEND AddSetoid1 CLASSIFIED AS SIDEFF
+   [ "Add" "Setoid" constr(a) constr(aeq) constr(t) "as" ident(n) ] ->
+     [ add_setoid (not (Locality.make_section_locality (Locality.LocalityFixme.consume ()))) [] a aeq t n ]
+  | [ "Add" "Parametric" "Setoid" binders(binders) ":" constr(a) constr(aeq) constr(t) "as" ident(n) ] ->
+     [  add_setoid (not (Locality.make_section_locality (Locality.LocalityFixme.consume ()))) binders a aeq t n ]
+  | [ "Add" "Morphism" constr(m) ":" ident(n) ]
+    (* This command may or may not open a goal *)
+    => [ Vernacexpr.VtUnknown, Vernacexpr.VtNow ]
+    -> [ add_morphism_infer (not (Locality.make_section_locality (Locality.LocalityFixme.consume ()))) m n ]
+  | [ "Add" "Morphism" constr(m) "with" "signature" lconstr(s) "as" ident(n) ]
+    => [ Vernacexpr.(VtStartProof("Classic",GuaranteesOpacity,[n]), VtLater) ]
+    -> [ add_morphism (not (Locality.make_section_locality (Locality.LocalityFixme.consume ()))) [] m s n ]
+  | [ "Add" "Parametric" "Morphism" binders(binders) ":" constr(m)
+        "with" "signature" lconstr(s) "as" ident(n) ]
+    => [ Vernacexpr.(VtStartProof("Classic",GuaranteesOpacity,[n]), VtLater) ]
+    -> [ add_morphism (not (Locality.make_section_locality (Locality.LocalityFixme.consume ()))) binders m s n ]
+END
+
+TACTIC EXTEND setoid_symmetry
+   [ "setoid_symmetry" ] -> [ setoid_symmetry ]
+ | [ "setoid_symmetry" "in" hyp(n) ] -> [ setoid_symmetry_in n ]
+END
+
+TACTIC EXTEND setoid_reflexivity
+[ "setoid_reflexivity" ] -> [ setoid_reflexivity ]
+END
+
+TACTIC EXTEND setoid_transitivity
+  [ "setoid_transitivity" constr(t) ] -> [ setoid_transitivity (Some t) ]
+| [ "setoid_etransitivity" ] -> [ setoid_transitivity None ]
+END
diff --git a/tactics/geninterp.ml b/tactics/geninterp.ml
new file mode 100644
index 00000000..d44c4ac3
--- /dev/null
+++ b/tactics/geninterp.ml
@@ -0,0 +1,38 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+open Names
+open Genarg
+
+module TacStore = Store.Make(struct end)
+
+type interp_sign = {
+  lfun : tlevel generic_argument Id.Map.t;
+  extra : TacStore.t }
+
+type ('glb, 'top) interp_fun = interp_sign ->
+    Goal.goal Evd.sigma -> 'glb -> Evd.evar_map * 'top
+
+module InterpObj =
+struct
+  type ('raw, 'glb, 'top) obj = ('glb, 'top) interp_fun
+  let name = "interp"
+  let default _ = None
+end
+
+module Interp = Register(InterpObj)
+
+let interp = Interp.obj
+let register_interp0 = Interp.register0
+
+let generic_interp ist gl v =
+  let unpacker wit v =
+    let (sigma, ans) = interp wit ist gl (glb v) in
+    (sigma, in_gen (topwit wit) ans)
+  in
+  unpack { unpacker; } v
diff --git a/tactics/geninterp.mli b/tactics/geninterp.mli
new file mode 100644
index 00000000..3c653697
--- /dev/null
+++ b/tactics/geninterp.mli
@@ -0,0 +1,28 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(** Interpretation functions for generic arguments. *)
+
+open Names
+open Genarg
+
+module TacStore : Store.S
+
+type interp_sign = {
+  lfun : tlevel generic_argument Id.Map.t;
+  extra : TacStore.t }
+
+type ('glb, 'top) interp_fun = interp_sign ->
+    Goal.goal Evd.sigma -> 'glb -> Evd.evar_map * 'top
+
+val interp : ('raw, 'glb, 'top) genarg_type -> ('glb, 'top) interp_fun
+
+val generic_interp : (glob_generic_argument, typed_generic_argument) interp_fun
+
+val register_interp0 :
+  ('raw, 'glb, 'top) genarg_type -> ('glb, 'top) interp_fun -> unit
diff --git a/tactics/hiddentac.ml b/tactics/hiddentac.ml
deleted file mode 100644
index 8bfebc03..00000000
--- a/tactics/hiddentac.ml
+++ /dev/null
@@ -1,142 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-open Term
-open Proof_type
-open Tacmach
-
-open Glob_term
-open Refiner
-open Genarg
-open Tacexpr
-open Tactics
-open Util
-
-(* Basic tactics *)
-let h_intro_move x y =
-  abstract_tactic (TacIntroMove (x, y)) (intro_move x y)
-let h_intro x        = h_intro_move (Some x) no_move
-let h_intros_until x = abstract_tactic (TacIntrosUntil x) (intros_until x)
-let h_assumption     = abstract_tactic TacAssumption assumption
-let h_exact c        = abstract_tactic (TacExact c) (exact_check c)
-let h_exact_no_check c =
-  abstract_tactic (TacExactNoCheck c) (exact_no_check c)
-let h_vm_cast_no_check c =
-  abstract_tactic (TacVmCastNoCheck c) (vm_cast_no_check c)
-let h_apply simple ev cb =
-  abstract_tactic (TacApply (simple,ev,List.map snd cb,None))
-    (apply_with_bindings_gen simple ev cb)
-let h_apply_in simple ev cb (id,ipat as inhyp) =
-  abstract_tactic (TacApply (simple,ev,List.map snd cb,Some inhyp))
-    (apply_in simple ev id cb ipat)
-let h_elim ev cb cbo    =
-  abstract_tactic (TacElim (ev,cb,cbo))
-    (elim ev cb cbo)
-let h_elim_type c    = abstract_tactic (TacElimType c) (elim_type c)
-let h_case ev cb     = abstract_tactic (TacCase (ev,cb)) (general_case_analysis ev cb)
-let h_case_type c    = abstract_tactic (TacCaseType c) (case_type c)
-let h_fix ido n      = abstract_tactic (TacFix (ido,n)) (fix ido n)
-let h_mutual_fix b id n l =
-  abstract_tactic
-    (TacMutualFix (b,id,n,l))
-    (mutual_fix id n l 0)
-
-let h_cofix ido      = abstract_tactic (TacCofix ido) (cofix ido)
-let h_mutual_cofix b id l =
-  abstract_tactic
-    (TacMutualCofix (b,id,l))
-    (mutual_cofix id l 0)
-
-let h_cut c          = abstract_tactic (TacCut c) (cut c)
-let h_generalize_gen cl =
-  abstract_tactic (TacGeneralize cl)
-    (generalize_gen (List.map (on_fst Redexpr.out_with_occurrences) cl))
-let h_generalize cl =
-  h_generalize_gen (List.map (fun c -> ((all_occurrences_expr,c),Names.Anonymous))
-    cl)
-let h_generalize_dep c =
-  abstract_tactic (TacGeneralizeDep c) (generalize_dep c)
-let h_let_tac b na c cl eqpat =
-  let id = Option.default (dummy_loc,IntroAnonymous) eqpat in
-  let with_eq = if b then None else Some (true,id) in
-  abstract_tactic (TacLetTac (na,c,cl,b,eqpat))
-    (letin_tac with_eq na c None cl)
-let h_let_pat_tac b na c cl eqpat =
-  let id = Option.default (dummy_loc,IntroAnonymous) eqpat in
-  let with_eq = if b then None else Some (true,id) in
-  abstract_tactic (TacLetTac (na,snd c,cl,b,eqpat))
-    (letin_pat_tac with_eq na c None cl)
-
-(* Derived basic tactics *)
-let h_simple_induction_destruct isrec h =
-  abstract_tactic (TacSimpleInductionDestruct (isrec,h))
-    (if isrec then (simple_induct h) else (simple_destruct 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 =
-  let lcl' = on_pi1 (List.map (fun (a,b) ->(out_indarg a,b))) lcl in
-  abstract_tactic (TacInductionDestruct (isrec,ev,lcl'))
-    (induction_destruct isrec ev lcl)
-let h_new_induction ev c idl e cl =
-  h_induction_destruct true ev ([c,idl],e,cl)
-let h_new_destruct ev c idl e cl = h_induction_destruct false ev ([c,idl],e,cl)
-
-let h_specialize n d = abstract_tactic (TacSpecialize (n,d)) (specialize n d)
-let h_lapply c = abstract_tactic (TacLApply c) (cut_and_apply c)
-
-(* Context management *)
-let h_clear b l = abstract_tactic (TacClear (b,l))
-  ((if b then keep else clear) l)
-let h_clear_body l = abstract_tactic (TacClearBody l) (clear_body l)
-let h_move dep id1 id2 =
-  abstract_tactic (TacMove (dep,id1,id2)) (move_hyp dep id1 id2)
-let h_rename l =
-  abstract_tactic (TacRename l) (rename_hyp l)
-let h_revert l = abstract_tactic (TacRevert l) (revert l)
-
-(* Constructors *)
-let h_left ev l  = abstract_tactic (TacLeft (ev,l)) (left_with_bindings ev l)
-let h_right ev l = abstract_tactic (TacRight (ev,l)) (right_with_bindings ev l)
-let h_split ev l = abstract_tactic (TacSplit (ev,false,l)) (split_with_bindings ev l)
-(* Moved to tacinterp because of dependencies in Tacinterp.interp
-let h_any_constructor t =
-  abstract_tactic (TacAnyConstructor t) (any_constructor t)
-*)
-let h_constructor ev n l =
-  abstract_tactic (TacConstructor(ev,ArgArg n,l))(constructor_tac ev None n l)
-let h_one_constructor n =
-  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
-
-(* Conversion *)
-let h_reduce r cl  =
-  abstract_tactic (TacReduce (r,cl)) (reduce r cl)
-let h_change op c cl =
-  abstract_tactic (TacChange (op,c,cl)) (change op c cl)
-
-(* Equivalence relations *)
-let h_reflexivity    = abstract_tactic TacReflexivity intros_reflexivity
-let h_symmetry c     = abstract_tactic (TacSymmetry c) (intros_symmetry c)
-let h_transitivity c =
-  abstract_tactic (TacTransitivity c)
-    (intros_transitivity c)
-
-let h_simplest_apply c = h_apply false false [dummy_loc,(c,NoBindings)]
-let h_simplest_eapply c = h_apply false true [dummy_loc,(c,NoBindings)]
-let h_simplest_elim c   = h_elim false (c,NoBindings) None
-let h_simplest_case   c = h_case false (c,NoBindings)
-
-let h_intro_patterns l = abstract_tactic (TacIntroPattern l) (intro_patterns l)
-
diff --git a/tactics/hiddentac.mli b/tactics/hiddentac.mli
deleted file mode 100644
index ae4e1f53..00000000
--- a/tactics/hiddentac.mli
+++ /dev/null
@@ -1,124 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-open Names
-open Util
-open Term
-open Proof_type
-open Tacmach
-open Genarg
-open Tacexpr
-open Glob_term
-open Evd
-open Clenv
-open Termops
-
-(** Tactics for the interpreter. They left a trace in the proof tree
-   when they are called. *)
-
-(** Basic tactics *)
-
-val h_intro_move      : identifier option -> identifier move_location -> tactic
-val h_intro           : identifier -> tactic
-val h_intros_until    : quantified_hypothesis -> tactic
-
-val h_assumption      : tactic
-val h_exact           : constr -> tactic
-val h_exact_no_check  : constr -> tactic
-val h_vm_cast_no_check  : constr -> tactic
-
-val h_apply           : advanced_flag -> evars_flag ->
-  constr with_bindings located list -> tactic
-val h_apply_in        : advanced_flag -> evars_flag ->
-  constr with_bindings located list ->
-  identifier * intro_pattern_expr located option -> tactic
-
-val h_elim            : evars_flag -> constr with_bindings ->
-                        constr with_bindings option -> tactic
-val h_elim_type       : constr -> tactic
-val h_case            : evars_flag -> constr with_bindings -> tactic
-val h_case_type       : constr -> tactic
-
-val h_mutual_fix      : hidden_flag -> identifier -> int ->
-                        (identifier * int * constr) list -> tactic
-val h_fix             : identifier option -> int -> tactic
-val h_mutual_cofix    : hidden_flag -> identifier ->
-                        (identifier * constr) list -> tactic
-val h_cofix           : identifier option -> tactic
-
-val h_cut             : constr -> tactic
-val h_generalize      : constr list -> tactic
-val h_generalize_gen  : (constr with_occurrences * name) list -> tactic
-val h_generalize_dep  : constr -> tactic
-val h_let_tac         : letin_flag -> name -> constr -> Tacticals.clause ->
-                        intro_pattern_expr located option -> tactic
-val h_let_pat_tac     : letin_flag -> name -> evar_map * constr ->
-                        Tacticals.clause -> intro_pattern_expr located option ->
-                        tactic
-
-(** Derived basic tactics *)
-
-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 ->
-  (evar_map * constr with_bindings) induction_arg ->
-  intro_pattern_expr located option * intro_pattern_expr located option ->
-  constr with_bindings option ->
-  Tacticals.clause option -> tactic
-val h_new_destruct    : evars_flag ->
-  (evar_map * constr with_bindings) induction_arg ->
-  intro_pattern_expr located option * intro_pattern_expr located option ->
-  constr with_bindings option ->
-  Tacticals.clause option -> tactic
-val h_induction_destruct : rec_flag -> evars_flag ->
-  ((evar_map * constr with_bindings) induction_arg *
-   (intro_pattern_expr located option * intro_pattern_expr located option)) list
-    * constr with_bindings option
-    * Tacticals.clause option -> tactic
-
-val h_specialize      : int option -> constr with_bindings -> tactic
-val h_lapply          : constr -> tactic
-
-(** Automation tactic : see Auto *)
-
-
-(** 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 *)
-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
-val h_split           : evars_flag -> constr bindings list -> tactic
-
-val h_one_constructor : int -> tactic
-val h_simplest_left   : tactic
-val h_simplest_right  : tactic
-
-
-(** Conversion *)
-val h_reduce          : Redexpr.red_expr -> Tacticals.clause -> tactic
-val h_change          :
-  Pattern.constr_pattern option -> constr -> Tacticals.clause -> tactic
-
-(** Equivalence relations *)
-val h_reflexivity     : tactic
-val h_symmetry        : Tacticals.clause -> tactic
-val h_transitivity    : constr option -> tactic
-
-val h_simplest_apply  : constr -> tactic
-val h_simplest_eapply : constr -> tactic
-val h_simplest_elim   : constr -> tactic
-val h_simplest_case   : constr -> tactic
-
-val h_intro_patterns  : intro_pattern_expr located list -> tactic
diff --git a/tactics/hightactics.mllib b/tactics/hightactics.mllib
index 7d12f9d0..ff2e1ff6 100644
--- a/tactics/hightactics.mllib
+++ b/tactics/hightactics.mllib
@@ -1,8 +1,11 @@
-Refine
 Extraargs
+Coretactics
 Extratactics
 Eauto
 Class_tactics
+G_class
 Rewrite
+G_rewrite
 Tauto
 Eqdecide
+G_eqdecide
diff --git a/tactics/hints.ml b/tactics/hints.ml
new file mode 100644
index 00000000..5621c365
--- /dev/null
+++ b/tactics/hints.ml
@@ -0,0 +1,1221 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+open Pp
+open Util
+open Errors
+open Names
+open Vars
+open Term
+open Environ
+open Mod_subst
+open Globnames
+open Libobject
+open Namegen
+open Libnames
+open Smartlocate
+open Misctypes
+open Evd
+open Termops
+open Inductiveops
+open Typing
+open Tacexpr
+open Decl_kinds
+open Pattern
+open Patternops
+open Clenv
+open Pfedit
+open Tacred
+open Printer
+open Vernacexpr
+
+(****************************************)
+(* General functions                    *)
+(****************************************)
+
+exception Bound
+
+let head_constr_bound t =
+  let t = strip_outer_cast t in
+  let _,ccl = decompose_prod_assum t in
+  let hd,args = decompose_app ccl in
+  match kind_of_term hd with
+    | Const _ | Ind _ | Construct _ | Var _ -> hd
+    | Proj (p, _) -> mkConst (Projection.constant p)
+    | _ -> raise Bound
+
+let head_constr c =
+  try head_constr_bound c with Bound -> error "Bound head variable."
+
+let decompose_app_bound t =
+  let t = strip_outer_cast t in
+  let _,ccl = decompose_prod_assum t in
+  let hd,args = decompose_app_vect ccl in
+  match kind_of_term hd with
+    | Const (c,u) -> ConstRef c, args
+    | Ind (i,u) -> IndRef i, args
+    | Construct (c,u) -> ConstructRef c, args
+    | Var id -> VarRef id, args
+    | Proj (p, c) -> ConstRef (Projection.constant p), Array.cons c args
+    | _ -> raise Bound
+
+(************************************************************************)
+(*           The Type of Constructions Autotactic Hints                 *)
+(************************************************************************)
+
+type 'a auto_tactic =
+  | Res_pf     of 'a (* Hint Apply *)
+  | ERes_pf    of 'a (* Hint EApply *)
+  | Give_exact of 'a
+  | Res_pf_THEN_trivial_fail of 'a (* Hint Immediate *)
+  | Unfold_nth of evaluable_global_reference       (* Hint Unfold *)
+  | Extern     of glob_tactic_expr       (* Hint Extern *)
+
+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 hint_term =
+  | IsGlobRef of global_reference
+  | IsConstr of constr * Univ.universe_context_set
+
+type 'a gen_auto_tactic = {
+  pri  : int;            (* A number lower is higher priority *)
+  poly  : polymorphic;    (** Is the hint polymorpic and hence should be refreshed at each application *)
+  pat  : constr_pattern option; (* A pattern for the concl of the Goal *)
+  name  : hints_path_atom; (* A potential name to refer to the hint *) 
+  code : 'a auto_tactic     (* the tactic to apply when the concl matches pat *)
+}
+
+type pri_auto_tactic = (constr * clausenv) gen_auto_tactic
+
+type hint_entry = global_reference option * 
+  (constr * types * Univ.universe_context_set) gen_auto_tactic
+
+let eq_hints_path_atom p1 p2 = match p1, p2 with
+| PathHints gr1, PathHints gr2 -> List.equal eq_gr gr1 gr2
+| PathAny, PathAny -> true
+| (PathHints _ | PathAny), _ -> false
+
+let eq_auto_tactic t1 t2 = match t1, t2 with
+| Res_pf (c1, _), Res_pf (c2, _) -> Constr.equal c1 c2
+| ERes_pf (c1, _), ERes_pf (c2, _) -> Constr.equal c1 c2
+| Give_exact (c1, _), Give_exact (c2, _) -> Constr.equal c1 c2
+| Res_pf_THEN_trivial_fail (c1, _), Res_pf_THEN_trivial_fail (c2, _) -> Constr.equal c1 c2
+| Unfold_nth gr1, Unfold_nth gr2 -> eq_egr gr1 gr2
+| Extern tac1, Extern tac2 -> tac1 == tac2 (** May cause redundancy in addkv *)
+| (Res_pf _ | ERes_pf _ | Give_exact _ | Res_pf_THEN_trivial_fail _
+  | Unfold_nth _ | Extern _), _ -> false
+
+let eq_gen_auto_tactic t1 t2 =
+  Int.equal t1.pri t2.pri &&
+  Option.equal constr_pattern_eq t1.pat t2.pat &&
+  eq_hints_path_atom t1.name t2.name &&
+  eq_auto_tactic t1.code t2.code
+
+let pri_order_int (id1, {pri=pri1}) (id2, {pri=pri2}) =
+  let d = pri1 - pri2 in
+    if Int.equal d 0 then id2 - id1
+    else d
+
+let pri_order t1 t2 = pri_order_int t1 t2 <= 0
+
+(* Nov 98 -- Papageno *)
+(* 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.
+
+  Une hint_db est une table d'association fonctionelle constr -> search_entry
+  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 ont un pattern
+     - un discrimination net borné (Btermdn.t) constitué de tous les
+       patterns de la seconde liste de tactiques *)
+
+type stored_data = int * pri_auto_tactic
+    (* First component is the index of insertion in the table, to keep most recent first semantics. *)
+
+module Bounded_net = Btermdn.Make(struct
+				    type t = stored_data
+				    let compare = pri_order_int
+				  end)
+
+type search_entry = stored_data list * stored_data list * Bounded_net.t * bool array list
+
+
+let empty_se = ([],[],Bounded_net.create (),[])
+
+let eq_pri_auto_tactic (_, x) (_, y) =
+  if Int.equal x.pri y.pri && Option.equal constr_pattern_eq x.pat y.pat then
+    match x.code,y.code with
+      | Res_pf (cstr,_),Res_pf (cstr1,_) -> 
+	  Term.eq_constr cstr cstr1
+      | ERes_pf (cstr,_),ERes_pf (cstr1,_) -> 
+	  Term.eq_constr cstr cstr1
+      | Give_exact (cstr,_),Give_exact (cstr1,_)  -> 
+	  Term.eq_constr cstr cstr1
+      | Res_pf_THEN_trivial_fail (cstr,_)
+	  ,Res_pf_THEN_trivial_fail (cstr1,_) -> 
+	  Term.eq_constr cstr cstr1
+      | _,_ -> false
+  else
+    false
+
+let add_tac pat t st (l,l',dn,m) =
+  match pat with
+  | None -> 
+    if not (List.exists (eq_pri_auto_tactic t) l) then (List.insert pri_order t l, l', dn, m) 
+    else (l, l', dn, m)
+  | Some pat -> 
+    if not (List.exists (eq_pri_auto_tactic t) l')
+    then (l, List.insert pri_order t l', Bounded_net.add st dn (pat,t), m) else (l, l', dn, m)
+
+let rebuild_dn st ((l,l',dn,m) : search_entry) =
+  let dn' = 
+    List.fold_left 
+      (fun dn (id, t) -> Bounded_net.add (Some st) dn (Option.get t.pat, (id, t)))
+      (Bounded_net.create ()) l'
+  in
+    (l, l', dn', m)
+
+let lookup_tacs concl st (l,l',dn) =
+  let l'  = Bounded_net.lookup st dn concl in
+  let sl' = List.stable_sort pri_order_int l' in
+    List.merge pri_order_int l sl'
+
+module Constr_map = Map.Make(RefOrdered)
+
+let is_transparent_gr (ids, csts) = function
+  | VarRef id -> Id.Pred.mem id ids
+  | ConstRef cst -> Cpred.mem cst csts
+  | IndRef _ | ConstructRef _ -> false
+
+let strip_params env c = 
+  match kind_of_term c with
+  | App (f, args) -> 
+    (match kind_of_term f with
+    | Const (p,_) ->
+      let cb = lookup_constant p env in
+	(match cb.Declarations.const_proj with
+	| Some pb -> 
+	  let n = pb.Declarations.proj_npars in
+	    if Array.length args > n then
+	      mkApp (mkProj (Projection.make p false, args.(n)), 
+		     Array.sub args (n+1) (Array.length args - (n + 1)))
+	    else c
+	| None -> c)
+    | _ -> c)
+  | _ -> c
+
+let instantiate_hint p =
+  let mk_clenv c cty ctx =
+    let env = Global.env () in
+    let sigma = Evd.merge_context_set univ_flexible (Evd.from_env env) ctx in
+    let cl = mk_clenv_from_env (Global.env()) sigma None (c,cty) in 
+      {cl with templval = 
+	  { cl.templval with rebus = strip_params env cl.templval.rebus };
+	env = empty_env}
+  in
+  let code = match p.code with
+    | Res_pf (c, cty, ctx) -> Res_pf (c, mk_clenv c cty ctx)
+    | ERes_pf (c, cty, ctx) -> ERes_pf (c, mk_clenv c cty ctx)
+    | Res_pf_THEN_trivial_fail (c, cty, ctx) ->
+      Res_pf_THEN_trivial_fail (c, mk_clenv c cty ctx)
+    | Give_exact (c, cty, ctx) -> Give_exact (c, mk_clenv c cty ctx)
+    | Unfold_nth e -> Unfold_nth e
+    | Extern t -> Extern t
+  in { pri = p.pri; poly = p.poly; name = p.name; pat = p.pat; code = code }
+
+let hints_path_atom_eq h1 h2 = match h1, h2 with
+| PathHints l1, PathHints l2 -> List.equal eq_gr l1 l2
+| PathAny, PathAny -> true
+| _ -> false
+
+let rec hints_path_eq h1 h2 = match h1, h2 with
+| PathAtom h1, PathAtom h2 -> hints_path_atom_eq h1 h2
+| PathStar h1, PathStar h2 -> hints_path_eq h1 h2
+| PathSeq (l1, r1), PathSeq (l2, r2) ->
+  hints_path_eq l1 l2 && hints_path_eq r1 r2
+| PathOr (l1, r1), PathOr (l2, r2) ->
+  hints_path_eq l1 l2 && hints_path_eq r1 r2
+| PathEmpty, PathEmpty -> true
+| PathEpsilon, PathEpsilon -> true
+| _ -> false
+
+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 hints_path_atom_eq 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 eq_gr 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 hints_path_eq p p' && hints_path_eq q q' then h
+      else normalize_path (PathOr (p', q'))
+  | PathSeq (p, q) -> 
+    let p', q' = normalize_path p, normalize_path q in
+      if hints_path_eq p p' && hints_path_eq 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) -> pr_sequence pr_global grs
+  | PathStar p -> str "(" ++ pp_hints_path p ++ str")*"
+  | PathSeq (p, p') -> pp_hints_path p ++ str" ; " ++ pp_hints_path p'
+  | PathOr (p, p') -> 
+    str "(" ++ pp_hints_path p ++ spc () ++ str"|" ++ spc () ++ pp_hints_path p' ++ str ")"
+  | PathEmpty -> str"Ø"
+  | PathEpsilon -> str"ε"
+
+let subst_path_atom subst p =
+  match p with
+  | PathAny -> p
+  | PathHints grs ->
+    let gr' gr = fst (subst_global subst gr) in
+    let grs' = List.smartmap gr' grs in
+      if grs' == grs then p else PathHints grs'
+
+let rec subst_hints_path subst hp =
+  match hp with
+  | PathAtom p ->
+    let p' = subst_path_atom subst p in
+      if p' == p then hp else PathAtom p'
+  | PathStar p -> let p' = subst_hints_path subst p in
+      if p' == p then hp else PathStar p'
+  | PathSeq (p, q) ->
+    let p' = subst_hints_path subst p in
+    let q' = subst_hints_path subst q in
+      if p' == p && q' == q then hp else PathSeq (p', q')
+  | PathOr (p, q) ->
+    let p' = subst_hints_path subst p in
+    let q' = subst_hints_path subst q in
+      if p' == p && q' == q then hp else PathOr (p', q')
+  | _ -> hp
+
+module Hint_db = struct
+
+  type t = {
+    hintdb_state : Names.transparent_state;
+    hintdb_cut : hints_path;
+    hintdb_unfolds : Id.Set.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
+       or with no associated pattern. *)
+    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 = (Id.Set.empty, Cset.empty);
+			  hintdb_max_id = 0;
+			  use_dn = use_dn;
+			  hintdb_map = Constr_map.empty;
+			  hintdb_nopat = [] }
+
+  let find key db =
+    try Constr_map.find key db.hintdb_map
+    with Not_found -> empty_se
+ 
+  let realize_tac (id,tac) = tac
+
+  let matches_mode args mode =
+    Array.length args == Array.length mode &&
+      Array.for_all2 (fun arg m -> not (m && occur_existential arg)) args mode
+      
+  let matches_modes args modes =
+    if List.is_empty modes then true
+    else List.exists (matches_mode args) modes
+
+  let map_none db =
+    List.map realize_tac (Sort.merge pri_order (List.map snd db.hintdb_nopat) [])
+    
+  let map_all k db =
+    let (l,l',_,_) = find k db in
+      List.map realize_tac (Sort.merge pri_order (List.map snd db.hintdb_nopat @ l) l')
+	
+  (** Precondition: concl has no existentials *)
+  let map_auto (k,args) concl db =
+    let (l,l',dn,m) = find k db in
+    let st = if db.use_dn then  (Some db.hintdb_state) else None in
+    let l' = lookup_tacs concl st (l,l',dn) in
+      List.map realize_tac (Sort.merge pri_order (List.map snd db.hintdb_nopat) l')
+
+  let map_existential (k,args) concl db =
+    let (l,l',_,m) = find k db in
+      if matches_modes args m then
+	List.map realize_tac (Sort.merge pri_order (List.map snd db.hintdb_nopat @ l) l')
+      else List.map realize_tac (List.map snd db.hintdb_nopat)
+
+  (* [c] contains an existential *)
+  let map_eauto (k,args) concl db =
+    let (l,l',dn,m) = find k db in
+      if matches_modes args m then
+	let st = if db.use_dn then Some db.hintdb_state else None in
+	let l' = lookup_tacs concl st (l,l',dn) in
+	  List.map realize_tac (Sort.merge pri_order (List.map snd db.hintdb_nopat) l')
+      else List.map realize_tac (List.map snd db.hintdb_nopat)
+
+  let is_exact = function
+    | Give_exact _ -> true
+    | _ -> false
+
+  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 &&
+	  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 ->
+          (** ppedrot: this equality here is dubious. Maybe we can remove it? *)
+          let is_present (_, (_, v')) = eq_gen_auto_tactic v v' in
+	  if not (List.exists is_present db.hintdb_nopat) then
+	    (** FIXME *)
+	    { db with hintdb_nopat = (gr,idv) :: db.hintdb_nopat }
+	  else db
+      | Some gr ->
+	  let oval = find gr db in
+	    { 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,(id,v)) -> addkv gr id v db) db' db.hintdb_nopat
+
+  let add_one (k, v) db =
+    let v = instantiate_hint v in
+    let st',db,rebuild =
+      match v.code with
+      | Unfold_nth egr ->
+	  let addunf (ids,csts) (ids',csts') =
+	    match egr with
+	    | EvalVarRef id -> (Id.Pred.add id ids, csts), (Id.Set.add id ids', csts')
+	    | EvalConstRef cst -> (ids, Cpred.add cst csts), (ids', Cset.add cst csts')
+	  in 
+	  let state, unfs = addunf db.hintdb_state db.hintdb_unfolds in
+	    state, { db with hintdb_unfolds = unfs }, true
+      | _ -> db.hintdb_state, db, false
+    in
+    let db = if db.use_dn && rebuild then rebuild_db st' db else db
+    in addkv k (next_hint_id db) v db
+
+  let add_list l db = List.fold_left (fun db k -> add_one k db) db l
+
+  let remove_sdl p sdl = List.smartfilter p sdl 
+  let remove_he st p (sl1, sl2, dn, m 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, m)
+
+  let remove_list grs db =
+    let filter (_, h) =
+      match h.name with PathHints [gr] -> not (List.mem_f eq_gr 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 (fun x -> realize_tac (snd x)) db.hintdb_nopat);
+    Constr_map.iter (fun k (l,l',_,m) -> f (Some k) m (List.map realize_tac (l@l'))) db.hintdb_map
+
+  let fold f db accu =
+    let accu = f None [] (List.map (fun x -> snd (snd x)) db.hintdb_nopat) accu in
+    Constr_map.fold (fun k (l,l',_,m) -> f (Some k) m (List.map snd (l@l'))) db.hintdb_map accu
+
+  let transparent_state db = db.hintdb_state
+
+  let set_transparent_state db st =
+    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 add_mode gr m db =
+    let (l,l',dn,ms) = find gr db in
+      { db with hintdb_map = Constr_map.add gr (l,l',dn,m :: ms) db.hintdb_map }
+
+  let cut db = db.hintdb_cut
+
+  let unfolds db = db.hintdb_unfolds
+
+  let use_dn db = db.use_dn
+
+end
+
+module Hintdbmap = String.Map
+
+type hint_db = Hint_db.t
+
+type hint_db_table = hint_db Hintdbmap.t ref
+
+type hint_db_name = string
+
+(** Initially created hint databases, for typeclasses and rewrite *)
+
+let typeclasses_db = "typeclass_instances"
+let rewrite_db = "rewrite"
+
+let auto_init_db =
+  Hintdbmap.add typeclasses_db (Hint_db.empty full_transparent_state true)
+    (Hintdbmap.add rewrite_db (Hint_db.empty cst_full_transparent_state true)
+       Hintdbmap.empty)
+
+let searchtable : hint_db_table = ref auto_init_db
+
+let searchtable_map name =
+  Hintdbmap.find name !searchtable
+let searchtable_add (name,db) =
+  searchtable := Hintdbmap.add name db !searchtable
+let current_db_names () = Hintdbmap.domain !searchtable
+let current_db () = Hintdbmap.bindings !searchtable
+
+let current_pure_db () =
+  List.map snd (Hintdbmap.bindings (Hintdbmap.remove "v62" !searchtable))
+
+let error_no_such_hint_database x =
+  error ("No such Hint database: "^x^".")
+
+(**************************************************************************)
+(*                       Definition of the summary                        *)
+(**************************************************************************)
+
+let hints_init : (unit -> unit) ref = ref (fun () -> ())
+let add_hints_init f =
+  let init = !hints_init in
+  hints_init := (fun () -> init (); f ())
+
+let init     () = searchtable := auto_init_db; !hints_init ()
+let freeze   _ = !searchtable
+let unfreeze fs = searchtable := fs
+
+let _ = Summary.declare_summary "search"
+	  { Summary.freeze_function   = freeze;
+	    Summary.unfreeze_function = unfreeze;
+	    Summary.init_function     = init }
+
+(**************************************************************************)
+(*             Auxiliary functions to prepare AUTOHINT objects            *)
+(**************************************************************************)
+
+let rec nb_hyp c = match kind_of_term c with
+  | Prod(_,_,c2) -> if noccurn 1 c2 then 1+(nb_hyp c2) else nb_hyp c2
+  | _ -> 0
+
+(* adding and removing tactics in the search table *)
+
+let try_head_pattern c =
+  try head_pattern_bound c
+  with BoundPattern -> error "Bound head variable."
+
+let make_exact_entry env sigma pri poly ?(name=PathAny) (c, cty, ctx) =
+  let cty = strip_outer_cast cty in
+    match kind_of_term cty with
+    | Prod _ -> failwith "make_exact_entry"
+    | _ ->
+	let pat = snd (Patternops.pattern_of_constr env sigma cty) in
+	let hd =
+	  try head_pattern_bound pat
+	  with BoundPattern -> failwith "make_exact_entry"
+	in
+          (Some hd,
+	  { pri = (match pri with None -> 0 | Some p -> p);
+	    poly = poly;
+	    pat = Some pat;
+	    name = name;
+	    code = Give_exact (c, cty, ctx) })
+
+let make_apply_entry env sigma (eapply,hnf,verbose) pri poly ?(name=PathAny) (c, cty, ctx) =
+  let cty = if hnf then hnf_constr env sigma cty else cty in
+    match kind_of_term cty with
+    | Prod _ ->
+        let sigma' = Evd.merge_context_set univ_flexible sigma ctx in
+        let ce = mk_clenv_from_env env sigma' None (c,cty) in
+	let c' = clenv_type (* ~reduce:false *) ce in
+	let pat = snd (Patternops.pattern_of_constr env ce.evd c') in
+        let hd =
+	  try head_pattern_bound pat
+          with BoundPattern -> failwith "make_apply_entry" in
+        let nmiss = List.length (clenv_missing ce) in
+	if Int.equal nmiss 0 then
+	  (Some hd,
+          { pri = (match pri with None -> nb_hyp cty | Some p -> p);
+	    poly = poly;
+            pat = Some pat;
+	    name = name;
+            code = Res_pf(c,cty,ctx) })
+	else begin
+	  if not eapply then failwith "make_apply_entry";
+          if verbose then
+	    msg_warning (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);
+	     poly = poly;
+             pat = Some pat;
+	     name = name;
+             code = ERes_pf(c,cty,ctx) })
+        end
+    | _ -> failwith "make_apply_entry"
+
+(* flags is (e,h,v) with e=true if eapply and h=true if hnf and v=true if verbose
+   c is a constr
+   cty is the type of constr *)
+
+let fresh_global_or_constr env sigma poly cr =
+  match cr with
+  | IsGlobRef gr -> Universes.fresh_global_instance env gr
+  | IsConstr (c, ctx) -> (c, ctx)
+
+let make_resolves env sigma flags pri poly ?name cr =
+  let c, ctx = fresh_global_or_constr env sigma poly cr in
+  let cty = Retyping.get_type_of env sigma c in
+  let try_apply f =
+    try Some (f (c, cty, ctx)) with Failure _ -> None in
+  let ents = List.map_filter try_apply
+    [make_exact_entry env sigma pri poly ?name; make_apply_entry env sigma flags pri poly ?name]
+  in
+  if List.is_empty ents then
+    errorlabstrm "Hint"
+      (pr_lconstr c ++ spc() ++
+        (if pi1 flags then str"cannot be used as a hint."
+	else str "can be used as a hint only for eauto."));
+  ents
+
+(* 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 false
+       ~name:(PathHints [VarRef hname])
+       (mkVar hname, htyp, Univ.ContextSet.empty)]
+  with
+    | Failure _ -> []
+    | e when Logic.catchable_exception e -> anomaly (Pp.str "make_resolve_hyp")
+
+(* REM : in most cases hintname = id *)
+let make_unfold eref =
+  let g = global_of_evaluable_reference eref in
+  (Some g,
+   { pri = 4;
+     poly = false;
+     pat = None;
+     name = PathHints [g];
+     code = Unfold_nth eref })
+
+let make_extern pri pat tacast =
+  let hdconstr = Option.map try_head_pattern pat in
+  (hdconstr,
+   { pri = pri;
+     poly = false;
+     pat = pat;
+     name = PathAny;
+     code = Extern tacast })  
+
+let make_mode ref m = 
+  let ty = Global.type_of_global_unsafe ref in
+  let ctx, t = decompose_prod ty in
+  let n = List.length ctx in
+  let m' = Array.of_list m in
+    if not (n == Array.length m') then
+      errorlabstrm "Hint"
+	(pr_global ref ++ str" has " ++ int n ++ 
+	   str" arguments while the mode declares " ++ int (Array.length m'))
+    else m'
+      
+let make_trivial env sigma poly ?(name=PathAny) r =
+  let c,ctx = fresh_global_or_constr env sigma poly r in
+  let sigma = Evd.merge_context_set univ_flexible sigma ctx in
+  let t = hnf_constr env sigma (type_of env sigma c) in
+  let hd = head_of_constr_reference (head_constr t) in
+  let ce = mk_clenv_from_env env sigma None (c,t) in
+  (Some hd, { pri=1;
+	      poly = poly;
+              pat = Some (snd (Patternops.pattern_of_constr env ce.evd (clenv_type ce)));
+	      name = name;
+              code=Res_pf_THEN_trivial_fail(c,t,ctx) })
+
+
+
+(**************************************************************************)
+(*               declaration of the AUTOHINT library object               *)
+(**************************************************************************)
+
+(* If the database does not exist, it is created *)
+(* TODO: should a warning be printed in this case ?? *)
+
+let get_db dbname =
+  try searchtable_map dbname
+  with Not_found -> Hint_db.empty empty_transparent_state false
+
+let add_hint dbname hintlist = 
+  let db = get_db dbname in
+  let db' = Hint_db.add_list hintlist db in
+    searchtable_add (dbname,db')
+
+let add_transparency dbname grs b =
+  let db = get_db dbname in
+  let st = Hint_db.transparent_state db in
+  let st' =
+    List.fold_left (fun (ids, csts) gr ->
+      match gr with
+      | EvalConstRef c -> (ids, (if b then Cpred.add else Cpred.remove) c csts)
+      | EvalVarRef v -> (if b then Id.Pred.add else Id.Pred.remove) v ids, csts)
+      st grs
+  in searchtable_add (dbname, Hint_db.set_transparent_state db st')
+
+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
+  | AddMode of global_reference * bool array
+
+let add_cut dbname path =
+  let db = get_db dbname in
+  let db' = Hint_db.add_cut path db in
+    searchtable_add (dbname, db')
+
+let add_mode dbname l m =
+  let db = get_db dbname in
+  let db' = Hint_db.add_mode l m 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
+  | AddHints hints -> add_hint name hints
+  | RemoveHints grs -> remove_hint name grs
+  | AddCut path -> add_cut name path
+  | AddMode (l, m) -> add_mode name l m
+
+let subst_autohint (subst,(local,name,hintlist as obj)) =
+  let subst_key gr =
+    let (lab'', elab') = subst_global subst gr in
+    let gr' =
+      (try head_of_constr_reference (head_constr_bound elab')
+       with Bound -> lab'')
+    in if gr' == gr then gr else gr'
+  in
+  let subst_hint (k,data as hint) =
+    let k' = Option.smartmap subst_key k in
+    let pat' = Option.smartmap (subst_pattern subst) data.pat in
+    let code' = match data.code with
+      | Res_pf (c,t,ctx) ->
+          let c' = subst_mps subst c in
+          let t' = subst_mps subst t in
+          if c==c' && t'==t then data.code else Res_pf (c', t',ctx)
+      | ERes_pf (c,t,ctx) ->
+          let c' = subst_mps subst c in
+          let t' = subst_mps subst t in
+          if c==c' && t'==t then data.code else ERes_pf (c',t',ctx)
+      | Give_exact (c,t,ctx) ->
+          let c' = subst_mps subst c in
+	  let t' = subst_mps subst t in
+          if c==c' && t'== t then data.code else Give_exact (c',t',ctx)
+      | Res_pf_THEN_trivial_fail (c,t,ctx) ->
+          let c' = subst_mps subst c in
+          let t' = subst_mps subst t in
+          if c==c' && t==t' then data.code else Res_pf_THEN_trivial_fail (c',t',ctx)
+      | Unfold_nth ref ->
+          let ref' = subst_evaluable_reference subst ref in
+          if ref==ref' then data.code else Unfold_nth ref'
+      | Extern tac ->
+	  let tac' = Tacsubst.subst_tactic subst tac in
+	  if tac==tac' then data.code else Extern tac'
+    in
+    let name' = subst_path_atom subst data.name in
+    let data' =
+      if data.pat==pat' && data.name == name' && data.code==code' then data
+      else { data with pat = pat'; name = name'; code = code' }
+    in
+    if k' == k && data' == data then hint else (k',data')
+  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))
+    | AddHints hintlist ->
+	let hintlist' = List.smartmap subst_hint hintlist in
+	  if hintlist' == hintlist then obj else
+	    (local,name,AddHints hintlist')
+    | RemoveHints grs ->
+	let grs' = List.smartmap (subst_global_reference subst) 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')
+    | AddMode (l,m) ->
+      let l' = subst_global_reference subst l in
+	(local, name, AddMode (l', m))
+
+let classify_autohint ((local,name,hintlist) as obj) =
+  match hintlist with
+  | AddHints [] -> Dispose
+  | _ -> if local then Dispose else Substitute obj
+
+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; }
+
+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 List.is_empty dbnames then ["core"] else dbnames in
+    List.iter
+      (fun dbname ->
+	 Lib.add_anonymous_leaf (inAutoHint(local, dbname, RemoveHints grs)))
+      dbnames
+
+(**************************************************************************)
+(*                     The "Hint" vernacular command                      *)
+(**************************************************************************)
+let add_resolves env sigma clist local dbnames =
+  List.iter
+    (fun dbname ->
+       Lib.add_anonymous_leaf
+	 (inAutoHint
+	    (local,dbname, AddHints
+     	      (List.flatten (List.map (fun (pri, poly, hnf, path, gr) ->
+	        make_resolves env sigma (true,hnf,Flags.is_verbose()) 
+		  pri poly ~name:path gr) clist)))))
+    dbnames
+
+let add_unfolds l local dbnames =
+  List.iter
+    (fun dbname -> Lib.add_anonymous_leaf
+       (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_mode l m local dbnames =
+  List.iter
+    (fun dbname -> Lib.add_anonymous_leaf
+      (let m' = make_mode l m in
+	 (inAutoHint (local,dbname, AddMode (l,m')))))
+    dbnames
+
+let add_transparency l b local dbnames =
+  List.iter
+    (fun dbname -> Lib.add_anonymous_leaf
+       (inAutoHint (local,dbname, AddTransparency (l, b))))
+    dbnames
+
+let add_extern pri pat tacast local dbname =
+  let pat = match pat with
+  | None -> None
+  | Some (_, pat) -> Some pat
+  in
+  let hint = local, dbname, AddHints [make_extern pri pat tacast] in
+  Lib.add_anonymous_leaf (inAutoHint hint)
+
+let add_externs pri pat tacast local dbnames =
+  List.iter (add_extern pri pat tacast local) dbnames
+
+let add_trivials env sigma l local dbnames =
+  List.iter
+    (fun dbname ->
+       Lib.add_anonymous_leaf (
+	 inAutoHint(local,dbname, 
+		    AddHints (List.map (fun (name, poly, c) -> make_trivial env sigma poly ~name c) l))))
+    dbnames
+
+let (forward_intern_tac, extern_intern_tac) = Hook.make ()
+
+type hnf = bool
+
+type hints_entry =
+  | HintsResolveEntry of (int option * polymorphic * hnf * hints_path_atom * hint_term) list
+  | HintsImmediateEntry of (hints_path_atom * polymorphic * hint_term) list
+  | HintsCutEntry of hints_path
+  | HintsUnfoldEntry of evaluable_global_reference list
+  | HintsTransparencyEntry of evaluable_global_reference list * bool
+  | HintsModeEntry of global_reference * bool list
+  | HintsExternEntry of
+      int * (patvar list * constr_pattern) option * glob_tactic_expr
+
+let default_prepare_hint_ident = Id.of_string "H"
+
+exception Found of constr * types
+
+let prepare_hint check env init (sigma,c) =
+  let sigma = Typeclasses.resolve_typeclasses ~fail:false env sigma in
+  (* We re-abstract over uninstantiated evars.
+     It is actually a bit stupid to generalize over evars since the first
+     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 not (Int.Set.is_empty (free_rels t)) 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 default_prepare_hint_ident (fun id -> Id.Set.mem id !vars) in
+      vars := Id.Set.add id !vars;
+      subst := (evar,mkVar id)::!subst;
+      mkNamedLambda id t (iter (replace_term evar (mkVar id) c)) in
+  let c' = iter c in
+    if check then Evarutil.check_evars (Global.env()) Evd.empty sigma c';
+    let diff = Univ.ContextSet.diff (Evd.universe_context_set sigma) (Evd.universe_context_set init) in
+      IsConstr (c', diff)
+
+let interp_hints poly =
+  fun h ->
+  let f c =
+    let evd,c = Constrintern.interp_open_constr (Global.env()) Evd.empty c in
+      prepare_hint true (Global.env()) Evd.empty (evd,c) in
+  let fref r =
+    let gr = global_with_alias r in
+    Dumpglob.add_glob (loc_of_reference r) gr;
+    gr in
+  let fr r = 
+    evaluable_of_global_reference (Global.env()) (fref r)
+  in
+  let fi c =
+    match c with
+    | HintsReference c ->
+      let gr = global_with_alias c in
+	(PathHints [gr], poly, IsGlobRef gr)
+    | HintsConstr c -> (PathAny, poly, f c)
+  in
+  let fres (pri, b, r) =
+    let path, poly, gr = fi r in
+      (pri, poly, b, path, gr)
+  in
+  let fp = Constrintern.intern_constr_pattern (Global.env()) in
+  match h with
+  | 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)
+  | HintsMode (r, l) -> HintsModeEntry (fref r, l)
+  | HintsConstructors lqid ->
+      let constr_hints_of_ind qid =
+        let ind = global_inductive_with_alias qid in
+	let mib,_ = Global.lookup_inductive ind in
+	Dumpglob.dump_reference (fst (qualid_of_reference qid)) "<>" (string_of_reference qid) "ind";
+          List.init (nconstructors ind) 
+	    (fun i -> let c = (ind,i+1) in
+		      let gr = ConstructRef c in
+			None, mib.Declarations.mind_polymorphic, true, 
+			PathHints [gr], IsGlobRef gr)
+      in HintsResolveEntry (List.flatten (List.map constr_hints_of_ind lqid))
+  | HintsExtern (pri, patcom, tacexp) ->
+      let pat =	Option.map fp patcom in
+      let l = match pat with None -> [] | Some (l, _) -> l in
+      let tacexp = Hook.get forward_intern_tac l tacexp in
+      HintsExternEntry (pri, pat, tacexp)
+
+let add_hints local dbnames0 h =
+  if String.List.mem "nocore" dbnames0 then
+    error "The hint database \"nocore\" is meant to stay empty.";
+  let dbnames = if List.is_empty 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
+  | HintsModeEntry (l,m) -> add_mode l m local dbnames
+  | HintsUnfoldEntry lhints -> add_unfolds lhints local dbnames
+  | HintsTransparencyEntry (lhints, b) ->
+      add_transparency lhints b local dbnames
+  | HintsExternEntry (pri, pat, tacexp) ->
+      add_externs pri pat tacexp local dbnames
+
+let expand_constructor_hints env sigma lems =
+  List.map_append (fun (evd,lem) ->
+    match kind_of_term lem with
+    | Ind (ind,u) ->
+	List.init (nconstructors ind) 
+	  (fun i -> IsConstr (mkConstructU ((ind,i+1),u), 
+			      Univ.ContextSet.empty))
+    | _ ->
+	[prepare_hint false env sigma (evd,lem)]) lems
+
+(* builds a hint database from a constr signature *)
+(* typically used with (lid, ltyp) = pf_hyps_types <some goal> *)
+
+let add_hint_lemmas env sigma eapply lems hint_db =
+  let lems = expand_constructor_hints env sigma lems in
+  let hintlist' =
+    List.map_append (make_resolves env sigma (eapply,true,false) None true) lems in
+  Hint_db.add_list hintlist' hint_db
+
+let make_local_hint_db env sigma ts eapply lems =
+  let sign = Environ.named_context env in
+  let ts = match ts with
+    | None -> Hint_db.transparent_state (searchtable_map "core") 
+    | Some ts -> ts
+  in
+  let hintlist = List.map_append (make_resolve_hyp env sigma) sign in
+  add_hint_lemmas env sigma eapply lems
+    (Hint_db.add_list hintlist (Hint_db.empty ts false))
+
+let make_local_hint_db = 
+  if Flags.profile then
+    let key = Profile.declare_profile "make_local_hint_db" in
+      Profile.profile4 key make_local_hint_db
+  else make_local_hint_db
+
+let make_local_hint_db env sigma ?ts eapply lems =
+  make_local_hint_db env sigma ts eapply lems
+
+let make_db_list dbnames =
+  let use_core = not (List.mem "nocore" dbnames) in
+  let dbnames = List.remove String.equal "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
+
+(**************************************************************************)
+(*                    Functions for printing the hints                    *)
+(**************************************************************************)
+
+let pr_autotactic =
+  function
+  | Res_pf (c,clenv) -> (str"apply " ++ pr_constr c)
+  | ERes_pf (c,clenv) -> (str"eapply " ++ pr_constr c)
+  | Give_exact (c,clenv) -> (str"exact " ++ pr_constr c)
+  | Res_pf_THEN_trivial_fail (c,clenv) ->
+      (str"apply " ++ pr_constr c ++ str" ; trivial")
+  | Unfold_nth c -> (str"unfold " ++  pr_evaluable_reference c)
+  | Extern tac ->
+      let env =
+        try
+          let (_, env) = Pfedit.get_current_goal_context () in
+          env
+        with e when Errors.noncritical e -> Global.env ()
+      in
+      (str "(*external*) " ++ Pptactic.pr_glob_tactic env tac)
+
+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 ())
+
+let pr_hints_db (name,db,hintlist) =
+  (str "In the database " ++ str name ++ str ":" ++
+     if List.is_empty hintlist then (str " nothing" ++ fnl ())
+     else (fnl () ++ pr_hint_list hintlist))
+
+(* Print all hints associated to head c in any database *)
+let pr_hint_list_for_head c =
+  let dbs = current_db () in
+  let validate (name, db) =
+    let hints = List.map (fun v -> 0, v) (Hint_db.map_all c db) in
+    (name, db, hints)
+  in
+  let valid_dbs = List.map validate dbs in
+  if List.is_empty valid_dbs then
+    (str "No hint declared for :" ++ pr_global c)
+  else
+    hov 0
+      (str"For " ++ pr_global c ++ str" -> " ++ fnl () ++
+	 hov 0 (prlist pr_hints_db valid_dbs))
+
+let pr_hint_ref ref = pr_hint_list_for_head ref
+
+(* Print all hints associated to head id in any database *)
+
+let pr_hint_term cl =
+  try
+    let dbs = current_db () in
+    let valid_dbs =
+      let fn = try
+	  let hdc = decompose_app_bound cl in
+	    if occur_existential cl then
+	      Hint_db.map_existential hdc cl
+	    else Hint_db.map_auto hdc cl
+	with Bound -> Hint_db.map_none
+      in
+      let fn db = List.map (fun x -> 0, x) (fn db) in
+      List.map (fun (name, db) -> (name, db, fn db)) dbs
+    in
+      if List.is_empty valid_dbs then
+	(str "No hint applicable for current goal")
+      else
+	(str "Applicable Hints :" ++ fnl () ++
+	    hov 0 (prlist pr_hints_db valid_dbs))
+  with Match_failure _ | Failure _ ->
+    (str "No hint applicable for current goal")
+
+(* print all hints that apply to the concl of the current goal *)
+let pr_applicable_hint () =
+  let pts = get_pftreestate () in
+  let glss = Proof.V82.subgoals pts in
+  match glss.Evd.it with
+  | [] -> Errors.error "No focused goal."
+  | g::_ ->
+    pr_hint_term (Goal.V82.concl glss.Evd.sigma g)
+
+(* displays the whole hint database db *)
+let pr_hint_db db =
+  let pr_mode = prvect_with_sep spc (fun x -> if x then str"+" else str"-") in
+  let pr_modes l = 
+    if List.is_empty l then mt ()
+    else str" (modes " ++ prlist_with_sep pr_comma pr_mode l ++ str")"
+  in
+  let content =
+    let fold head modes hintlist accu =
+      let goal_descr = match head with
+      | None -> str "For any goal"
+      | Some head -> str "For " ++ pr_global head ++ pr_modes modes
+      in
+      let hints = pr_hint_list (List.map (fun x -> (0, x)) hintlist) in
+      let hint_descr = hov 0 (goal_descr ++ str " -> " ++ hints) in
+      accu ++ hint_descr
+    in
+    Hint_db.fold fold db (mt ())
+  in
+  let (ids, csts) = Hint_db.transparent_state db in
+  hov 0
+    ((if Hint_db.use_dn db then str"Discriminated database"
+      else str"Non-discriminated database")) ++ fnl () ++
+  hov 2 (str"Unfoldable variable definitions: " ++ pr_idpred ids) ++ fnl () ++
+  hov 2 (str"Unfoldable constant definitions: " ++ pr_cpred csts) ++ fnl () ++
+  hov 2 (str"Cut: " ++ pp_hints_path (Hint_db.cut db)) ++ fnl () ++
+  content
+
+let pr_hint_db_by_name dbname =
+  try
+    let db = searchtable_map dbname in pr_hint_db db
+  with Not_found ->
+    error_no_such_hint_database dbname
+
+(* displays all the hints of all databases *)
+let pr_searchtable () =
+  let fold name db accu =
+    accu ++ str "In the database " ++ str name ++ str ":" ++ fnl () ++
+    pr_hint_db db ++ fnl ()
+  in
+  Hintdbmap.fold fold !searchtable (mt ())
+
diff --git a/tactics/hints.mli b/tactics/hints.mli
new file mode 100644
index 00000000..45cf562c
--- /dev/null
+++ b/tactics/hints.mli
@@ -0,0 +1,227 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+open Pp
+open Util
+open Names
+open Term
+open Context
+open Environ
+open Globnames
+open Decl_kinds
+open Evd
+open Misctypes
+open Clenv
+open Pattern
+open Vernacexpr
+
+(** {6 General functions. } *)
+
+exception Bound
+
+val decompose_app_bound : constr -> global_reference * constr array
+
+(** Pre-created hint databases *)
+
+type 'a auto_tactic =
+  | Res_pf     of 'a (* Hint Apply *)
+  | ERes_pf    of 'a (* Hint EApply *)
+  | Give_exact of 'a
+  | Res_pf_THEN_trivial_fail of 'a (* Hint Immediate *)
+  | Unfold_nth of evaluable_global_reference       (* Hint Unfold *)
+  | Extern     of Tacexpr.glob_tactic_expr       (* Hint Extern *)
+
+type hints_path_atom = 
+  | PathHints of global_reference list
+  | PathAny
+
+type 'a gen_auto_tactic = {
+  pri   : int;            (** A number between 0 and 4, 4 = lower priority *)
+  poly  : polymorphic;    (** Is the hint polymorpic and hence should be refreshed at each application *)
+  pat   : constr_pattern option; (** A pattern for the concl of the Goal *)
+  name  : hints_path_atom; (** A potential name to refer to the hint *) 
+  code  : 'a auto_tactic; (** the tactic to apply when the concl matches pat *)
+}
+
+type pri_auto_tactic = (constr * clausenv) gen_auto_tactic
+
+type search_entry
+
+(** The head may not be bound. *)
+
+type hint_entry = global_reference option * 
+  (constr * types * Univ.universe_context_set) 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
+    type t
+    val empty : transparent_state -> bool -> t
+    val find : global_reference -> t -> search_entry
+    val map_none : t -> pri_auto_tactic list
+
+    (** All hints associated to the reference *)
+    val map_all : global_reference -> t -> pri_auto_tactic list
+
+    (** All hints associated to the reference, respecting modes if evars appear in the 
+	arguments, _not_ using the discrimination net. *)
+    val map_existential : (global_reference * constr array) -> constr -> t -> pri_auto_tactic list
+
+    (** All hints associated to the reference, respecting modes if evars appear in the 
+	arguments and using the discrimination net. *)
+    val map_eauto : (global_reference * constr array) -> constr -> t -> pri_auto_tactic list
+
+    (** All hints associated to the reference, respecting modes if evars appear in the 
+	arguments. *)
+    val map_auto : (global_reference * constr array) -> constr -> t -> pri_auto_tactic list
+
+    val add_one : hint_entry -> t -> t
+    val add_list : (hint_entry) list -> t -> t
+    val remove_one : global_reference -> t -> t
+    val remove_list : global_reference list -> t -> t
+    val iter : (global_reference option -> bool array list -> 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 -> Id.Set.t * Cset.t
+  end
+
+type hint_db_name = string
+
+type hint_db = Hint_db.t
+
+type hnf = bool
+
+type hint_term =
+  | IsGlobRef of global_reference
+  | IsConstr of constr * Univ.universe_context_set
+
+type hints_entry =
+  | HintsResolveEntry of (int option * polymorphic * hnf * hints_path_atom * 
+			  hint_term) list
+  | HintsImmediateEntry of (hints_path_atom * polymorphic * hint_term) list
+  | HintsCutEntry of hints_path
+  | HintsUnfoldEntry of evaluable_global_reference list
+  | HintsTransparencyEntry of evaluable_global_reference list * bool
+  | HintsModeEntry of global_reference * bool list      
+  | HintsExternEntry of
+      int * (patvar list * constr_pattern) option * Tacexpr.glob_tactic_expr
+
+val searchtable_map : hint_db_name -> hint_db
+
+val searchtable_add : (hint_db_name * hint_db) -> unit
+
+(** [create_hint_db local name st use_dn].
+   [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 -> String.Set.t
+
+val current_pure_db : unit -> hint_db list
+
+val interp_hints : polymorphic -> hints_expr -> hints_entry
+
+val add_hints : locality_flag -> hint_db_name list -> hints_entry -> unit
+
+val prepare_hint : bool (* Check no remaining evars *) -> env -> evar_map -> 
+  open_constr -> hint_term
+
+(** [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 : env -> evar_map -> int option -> polymorphic -> ?name:hints_path_atom -> 
+  (constr * types * Univ.universe_context_set) -> hint_entry
+
+(** [make_apply_entry (eapply,hnf,verbose) pri (c,cty)].
+   [eapply] is true if this hint will be used only with EApply;
+   [hnf] should be true if we should expand the head of cty before searching for
+   products;
+   [c] is the term given as an exact proof to solve the goal;
+   [cty] is the type of [c]. *)
+
+val make_apply_entry :
+  env -> evar_map -> bool * bool * bool -> int option -> polymorphic -> ?name:hints_path_atom -> 
+  (constr * types * Univ.universe_context_set) -> hint_entry
+
+(** A constr which is Hint'ed will be:
+   - (1) used as an Exact, if it does not start with a product
+   - (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 -> polymorphic -> ?name:hints_path_atom -> 
+  hint_term -> hint_entry list
+
+(** [make_resolve_hyp hname htyp].
+   used to add an hypothesis to the local hint database;
+   Never raises a user exception;
+   If the hyp cannot be used as a Hint, the empty list is returned. *)
+
+val make_resolve_hyp :
+  env -> evar_map -> named_declaration -> hint_entry list
+
+(** [make_extern pri pattern tactic_expr] *)
+
+val make_extern :
+  int -> constr_pattern option -> Tacexpr.glob_tactic_expr
+      -> hint_entry
+
+val extern_intern_tac :
+  (patvar list -> Tacexpr.raw_tactic_expr -> Tacexpr.glob_tactic_expr) Hook.t
+
+(** 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 : env -> evar_map -> ?ts:transparent_state -> bool -> open_constr list -> hint_db
+
+val make_db_list : hint_db_name list -> hint_db list
+
+(** Initially created hint databases, for typeclasses and rewrite *)
+
+val typeclasses_db : hint_db_name
+val rewrite_db : hint_db_name
+
+(** Printing  hints *)
+
+val pr_searchtable : unit -> std_ppcmds
+val pr_applicable_hint : unit -> std_ppcmds
+val pr_hint_ref : global_reference -> std_ppcmds
+val pr_hint_db_by_name : hint_db_name -> std_ppcmds
+val pr_hint_db : Hint_db.t -> std_ppcmds
+val pr_autotactic : (constr * 'a) auto_tactic -> Pp.std_ppcmds
+
+(** Hook for changing the initialization of auto *)
+
+val add_hints_init : (unit -> unit) -> unit
+
diff --git a/tactics/hipattern.ml4 b/tactics/hipattern.ml4
index f8c1db27..4b94f420 100644
--- a/tactics/hipattern.ml4
+++ b/tactics/hipattern.ml4
@@ -1,29 +1,24 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i camlp4deps: "parsing/grammar.cma parsing/q_constr.cmo" i*)
+(*i camlp4deps: "grammar/grammar.cma grammar/q_constr.cmo" i*)
 
 open Pp
+open Errors
 open Util
 open Names
-open Nameops
 open Term
-open Sign
 open Termops
-open Reductionops
 open Inductiveops
-open Evd
-open Environ
-open Clenv
-open Pattern
-open Matching
+open Constr_matching
 open Coqlib
 open Declarations
+open Tacmach.New
 
 (* I implemented the following functions which test whether a term t
    is an inductive but non-recursive type, a general conjuction, a
@@ -52,8 +47,8 @@ let match_with_non_recursive_type t =
     | App _ ->
         let (hdapp,args) = decompose_app t in
         (match kind_of_term hdapp with
-           | Ind ind ->
-               if not (Global.lookup_mind (fst ind)).mind_finite then
+           | Ind (ind,u) ->
+               if (Global.lookup_mind (fst ind)).mind_finite == Decl_kinds.CoFinite then
 		 Some (hdapp,args)
 	       else
 		 None
@@ -83,55 +78,67 @@ let has_nodep_prod = has_nodep_prod_after 0
 
 (* style: None = record; Some false = conjunction; Some true = strict conj *)
 
-let match_with_one_constructor style allow_rec t =
+let is_strict_conjunction = function
+| Some true -> true
+| _ -> false
+
+let is_lax_conjunction = function
+| Some false -> true
+| _ -> false
+
+let match_with_one_constructor style onlybinary allow_rec t =
   let (hdapp,args) = decompose_app t in
-  match kind_of_term hdapp with
+  let res = match kind_of_term hdapp with
   | Ind ind ->
-      let (mib,mip) = Global.lookup_inductive ind in
-      if (Array.length mip.mind_consnames = 1)
-	&& (allow_rec or not (mis_is_recursive (ind,mib,mip)))
-        && (mip.mind_nrealargs = 0)
+      let (mib,mip) = Global.lookup_inductive (fst ind) in
+      if Int.equal (Array.length mip.mind_consnames) 1
+	&& (allow_rec || not (mis_is_recursive (fst ind,mib,mip)))
+        && (Int.equal mip.mind_nrealargs 0)
       then
-	if style = Some true (* strict conjunction *) then
+	if is_strict_conjunction style (* strict conjunction *) then
 	  let ctx =
 	    (prod_assum (snd
 	      (decompose_prod_n_assum mib.mind_nparams mip.mind_nf_lc.(0)))) in
 	  if
 	    List.for_all
-	      (fun (_,b,c) -> b=None && isRel c && destRel c = mib.mind_nparams) ctx
+	      (fun (_,b,c) -> Option.is_empty b && isRel c && Int.equal (destRel c) mib.mind_nparams) ctx
 	  then
 	    Some (hdapp,args)
 	  else None
 	else
 	  let ctyp = prod_applist mip.mind_nf_lc.(0) args in
 	  let cargs = List.map pi3 ((prod_assum ctyp)) in
-	  if style <> Some false || has_nodep_prod ctyp then
+	  if not (is_lax_conjunction style) || has_nodep_prod ctyp then
 	    (* Record or non strict conjunction *)
 	    Some (hdapp,List.rev cargs)
 	  else
 	      None
       else
 	None
+  | _ -> None in
+  match res with
+  | Some (hdapp, args) when not onlybinary -> res
+  | Some (hdapp, [_; _]) -> res
   | _ -> None
 
-let match_with_conjunction ?(strict=false) t =
-  match_with_one_constructor (Some strict) false t
+let match_with_conjunction ?(strict=false) ?(onlybinary=false) t =
+  match_with_one_constructor (Some strict) onlybinary false t
 
 let match_with_record t =
-  match_with_one_constructor None false t
+  match_with_one_constructor None false false t
 
-let is_conjunction ?(strict=false) t =
-  op2bool (match_with_conjunction ~strict t)
+let is_conjunction ?(strict=false) ?(onlybinary=false) t =
+  op2bool (match_with_conjunction ~strict ~onlybinary t)
 
 let is_record t =
   op2bool (match_with_record t)
 
 let match_with_tuple t =
-  let t = match_with_one_constructor None true t in
+  let t = match_with_one_constructor None false true t in
   Option.map (fun (hd,l) ->
     let ind = destInd hd in
-    let (mib,mip) = Global.lookup_inductive ind in
-    let isrec = mis_is_recursive (ind,mib,mip) in
+    let (mib,mip) = Global.lookup_pinductive ind in
+    let isrec = mis_is_recursive (fst ind,mib,mip) in
     (hd,l,isrec)) t
 
 let is_tuple t =
@@ -143,20 +150,20 @@ let is_tuple t =
    "Inductive I A1 ... An := C1 (_:A1) | ... | Cn : (_:An)" *)
 
 let test_strict_disjunction n lc =
-  array_for_all_i (fun i c ->
+  Array.for_all_i (fun i c ->
     match (prod_assum (snd (decompose_prod_n_assum n c))) with
-    | [_,None,c] -> isRel c && destRel c = (n - i)
+    | [_,None,c] -> isRel c && Int.equal (destRel c) (n - i)
     | _ -> false) 0 lc
 
-let match_with_disjunction ?(strict=false) t =
+let match_with_disjunction ?(strict=false) ?(onlybinary=false) t =
   let (hdapp,args) = decompose_app t in
-  match kind_of_term hdapp with
-  | Ind ind  ->
-      let car = mis_constr_nargs ind in
+  let res = match kind_of_term hdapp with
+  | Ind (ind,u)  ->
+      let car = constructors_nrealargs ind in
       let (mib,mip) = Global.lookup_inductive ind in
-      if array_for_all (fun ar -> ar = 1) car
-        && not (mis_is_recursive (ind,mib,mip))
-        && (mip.mind_nrealargs = 0)
+      if Array.for_all (fun ar -> Int.equal ar 1) car
+	&& not (mis_is_recursive (ind,mib,mip))
+        && (Int.equal mip.mind_nrealargs 0)
       then
 	if strict then
 	  if test_strict_disjunction mib.mind_nparams mip.mind_nf_lc then
@@ -170,10 +177,14 @@ let match_with_disjunction ?(strict=false) t =
 	  Some (hdapp,Array.to_list cargs)
       else
 	None
+  | _ -> None in
+  match res with
+  | Some (hdapp,args) when not onlybinary -> res
+  | Some (hdapp,[_; _]) -> res
   | _ -> None
 
-let is_disjunction ?(strict=false) t =
-  op2bool (match_with_disjunction ~strict t)
+let is_disjunction ?(strict=false) ?(onlybinary=false) t =
+  op2bool (match_with_disjunction ~strict ~onlybinary t)
 
 (* An empty type is an inductive type, possible with indices, that has no
    constructors *)
@@ -182,9 +193,9 @@ let match_with_empty_type t =
   let (hdapp,args) = decompose_app t in
   match (kind_of_term hdapp) with
     | Ind ind ->
-        let (mib,mip) = Global.lookup_inductive ind in
+        let (mib,mip) = Global.lookup_pinductive ind in
         let nconstr = Array.length mip.mind_consnames in
-	if nconstr = 0 then Some hdapp else None
+	if Int.equal nconstr 0 then Some hdapp else None
     | _ ->  None
 
 let is_empty_type t = op2bool (match_with_empty_type t)
@@ -196,11 +207,11 @@ let match_with_unit_or_eq_type t =
   let (hdapp,args) = decompose_app t in
   match (kind_of_term hdapp) with
     | Ind ind  ->
-        let (mib,mip) = Global.lookup_inductive ind in
+        let (mib,mip) = Global.lookup_pinductive ind in
         let constr_types = mip.mind_nf_lc in
         let nconstr = Array.length mip.mind_consnames in
-        let zero_args c = nb_prod c = mib.mind_nparams in
-	if nconstr = 1 && zero_args constr_types.(0) then
+        let zero_args c = Int.equal (nb_prod c) mib.mind_nparams in
+	if Int.equal nconstr 1 && zero_args constr_types.(0) then
 	  Some hdapp
 	else
 	  None
@@ -214,7 +225,7 @@ let is_unit_or_eq_type t = op2bool (match_with_unit_or_eq_type t)
 
 let is_unit_type t =
   match match_with_conjunction t with
-  | Some (_,t) when List.length t = 0 -> true
+  | Some (_,[]) -> true
   | _ -> false
 
 (* Checks if a given term is an application of an
@@ -232,27 +243,30 @@ let coq_refl_leibniz1_pattern = PATTERN [ forall x:_, _ x x ]
 let coq_refl_leibniz2_pattern = PATTERN [ forall A:_, forall x:A, _ A x x ]
 let coq_refl_jm_pattern       = PATTERN [ forall A:_, forall x:A, _ A x A x ]
 
-open Libnames
+open Globnames
+
+let is_matching x y = is_matching (Global.env ()) Evd.empty x y
+let matches x y = matches (Global.env ()) Evd.empty x y
 
 let match_with_equation t =
   if not (isApp t) then raise NoEquationFound;
   let (hdapp,args) = destApp t in
   match kind_of_term hdapp with
-  | Ind ind ->
-      if IndRef ind = glob_eq then
+  | Ind (ind,u) ->
+      if eq_gr (IndRef ind) glob_eq then
 	Some (build_coq_eq_data()),hdapp,
 	PolymorphicLeibnizEq(args.(0),args.(1),args.(2))
-      else if IndRef ind = glob_identity then
+      else if eq_gr (IndRef ind) glob_identity then
 	Some (build_coq_identity_data()),hdapp,
 	PolymorphicLeibnizEq(args.(0),args.(1),args.(2))
-      else if IndRef ind = glob_jmeq then
+      else if eq_gr (IndRef ind) glob_jmeq then
 	Some (build_coq_jmeq_data()),hdapp,
 	HeterogenousEq(args.(0),args.(1),args.(2),args.(3))
       else
         let (mib,mip) = Global.lookup_inductive ind in
         let constr_types = mip.mind_nf_lc in
         let nconstr = Array.length mip.mind_consnames in
-	if nconstr = 1 then
+	if Int.equal nconstr 1 then
           if is_matching coq_refl_leibniz1_pattern constr_types.(0) then
 	    None, hdapp, MonomorphicLeibnizEq(args.(0),args.(1))
 	  else if is_matching coq_refl_leibniz2_pattern constr_types.(0) then
@@ -263,25 +277,41 @@ let match_with_equation t =
         else raise NoEquationFound
     | _ -> raise NoEquationFound
 
+(* Note: An "equality type" is any type with a single argument-free
+   constructor: it captures eq, eq_dep, JMeq, eq_true, etc. but also
+   True/unit which is the degenerate equality type (isomorphic to ()=());
+   in particular, True/unit are provable by "reflexivity" *)
+
 let is_inductive_equality ind =
   let (mib,mip) = Global.lookup_inductive ind in
   let nconstr = Array.length mip.mind_consnames in
-  nconstr = 1 && constructor_nrealargs (Global.env()) (ind,1) = 0
+  Int.equal nconstr 1 && Int.equal (constructor_nrealargs (ind,1)) 0
 
 let match_with_equality_type t =
   let (hdapp,args) = decompose_app t in
   match (kind_of_term hdapp) with
-  | Ind ind when is_inductive_equality ind -> Some (hdapp,args)
+  | Ind (ind,_) when is_inductive_equality ind -> Some (hdapp,args)
   | _ -> None
 
 let is_equality_type t = op2bool (match_with_equality_type t)
 
+(* Arrows/Implication/Negation *)
+
 let coq_arrow_pattern = PATTERN [ ?X1 -> ?X2 ]
 
 let match_arrow_pattern t =
-  match matches coq_arrow_pattern t with
-    | [(m1,arg);(m2,mind)] -> assert (m1=meta1 & m2=meta2); (arg, mind)
-    | _ -> anomaly "Incorrect pattern matching"
+  let result = matches coq_arrow_pattern t in
+  match Id.Map.bindings result with
+    | [(m1,arg);(m2,mind)] ->
+      assert (Id.equal m1 meta1 && Id.equal m2 meta2); (arg, mind)
+    | _ -> anomaly (Pp.str "Incorrect pattern matching")
+
+let match_with_imp_term c=
+  match kind_of_term c with
+    | Prod (_,a,b) when not (dependent (mkRel 1) b) ->Some (a,b)
+    | _              -> None
+
+let is_imp_term c = op2bool (match_with_imp_term c)
 
 let match_with_nottype t =
   try
@@ -291,6 +321,8 @@ let match_with_nottype t =
 
 let is_nottype t = op2bool (match_with_nottype t)
 
+(* Forall *)
+
 let match_with_forall_term c=
   match kind_of_term c with
     | Prod (nam,a,b) -> Some (nam,a,b)
@@ -298,24 +330,17 @@ let match_with_forall_term c=
 
 let is_forall_term c = op2bool (match_with_forall_term c)
 
-let match_with_imp_term c=
-  match kind_of_term c with
-    | Prod (_,a,b) when not (dependent (mkRel 1) b) ->Some (a,b)
-    | _              -> None
-
-let is_imp_term c = op2bool (match_with_imp_term c)
-
 let match_with_nodep_ind t =
   let (hdapp,args) = decompose_app t in
     match (kind_of_term hdapp) with
       | Ind ind  ->
-          let (mib,mip) = Global.lookup_inductive ind in
+          let (mib,mip) = Global.lookup_pinductive ind in
 	    if Array.length (mib.mind_packets)>1 then None else
 	      let nodep_constr = has_nodep_prod_after mib.mind_nparams in
-		if array_for_all nodep_constr mip.mind_nf_lc then
+		if Array.for_all nodep_constr mip.mind_nf_lc then
 		  let params=
-		    if mip.mind_nrealargs=0 then args else
-		      fst (list_chop mib.mind_nparams args) in
+		    if Int.equal mip.mind_nrealargs 0 then args else
+		      fst (List.chop mib.mind_nparams args) in
 		    Some (hdapp,params,mip.mind_nrealargs)
 		else
 		  None
@@ -327,10 +352,10 @@ let match_with_sigma_type t=
   let (hdapp,args) = decompose_app t in
   match (kind_of_term hdapp) with
     | Ind ind  ->
-        let (mib,mip) = Global.lookup_inductive ind in
-          if (Array.length (mib.mind_packets)=1) &&
-	    (mip.mind_nrealargs=0) &&
-	    (Array.length mip.mind_consnames=1) &&
+        let (mib,mip) = Global.lookup_pinductive ind in
+          if Int.equal (Array.length (mib.mind_packets)) 1 &&
+	    (Int.equal mip.mind_nrealargs 0) &&
+	    (Int.equal (Array.length mip.mind_consnames)1) &&
 	    has_nodep_prod_after (mib.mind_nparams+1) mip.mind_nf_lc.(0) then
 	      (*allowing only 1 existential*)
 	      Some (hdapp,args)
@@ -344,9 +369,10 @@ let is_sigma_type t=op2bool (match_with_sigma_type t)
 
 let rec first_match matcher = function
   | [] -> raise PatternMatchingFailure
-  | (pat,build_set)::l ->
-      try (build_set (),matcher pat)
-      with PatternMatchingFailure -> first_match matcher l
+  | (pat,check,build_set)::l when check () ->
+      (try (build_set (),matcher pat)
+       with PatternMatchingFailure -> first_match matcher l)
+  | _::l -> first_match matcher l
 
 (*** Equality *)
 
@@ -355,50 +381,48 @@ let coq_eq_pattern_gen eq = lazy PATTERN [ %eq ?X1 ?X2 ?X3 ]
 let coq_eq_pattern = coq_eq_pattern_gen coq_eq_ref
 let coq_identity_pattern = coq_eq_pattern_gen coq_identity_ref
 let coq_jmeq_pattern = lazy PATTERN [ %coq_jmeq_ref ?X1 ?X2 ?X3 ?X4 ]
-let coq_eq_true_pattern = lazy PATTERN [ %coq_eq_true_ref ?X1 ]
 
 let match_eq eqn eq_pat =
   let pat =
     try Lazy.force eq_pat
     with e when Errors.noncritical e -> raise PatternMatchingFailure
   in
-  match matches pat eqn with
+  match Id.Map.bindings (matches pat eqn) with
     | [(m1,t);(m2,x);(m3,y)] ->
-	assert (m1 = meta1 & m2 = meta2 & m3 = meta3);
-	PolymorphicLeibnizEq (t,x,y)
+	assert (Id.equal m1 meta1 && Id.equal m2 meta2 && Id.equal m3 meta3);
+        PolymorphicLeibnizEq (t,x,y)
     | [(m1,t);(m2,x);(m3,t');(m4,x')] ->
-	assert (m1 = meta1 & m2 = meta2 & m3 = meta3 & m4 = meta4);
+        assert (Id.equal m1 meta1 && Id.equal m2 meta2 && Id.equal m3 meta3 && Id.equal m4 meta4);
 	HeterogenousEq (t,x,t',x')
-    | _ -> anomaly "match_eq: an eq pattern should match 3 or 4 terms"
+    | _ -> anomaly ~label:"match_eq" (Pp.str "an eq pattern should match 3 or 4 terms")
+
+let no_check () = true
+let check_jmeq_loaded () = Library.library_is_loaded Coqlib.jmeq_module
 
 let equalities =
-  [coq_eq_pattern, build_coq_eq_data;
-   coq_jmeq_pattern, build_coq_jmeq_data;
-   coq_identity_pattern, build_coq_identity_data]
+  [coq_eq_pattern, no_check, build_coq_eq_data;
+   coq_jmeq_pattern, check_jmeq_loaded, build_coq_jmeq_data;
+   coq_identity_pattern, no_check, build_coq_identity_data]
 
 let find_eq_data eqn = (* fails with PatternMatchingFailure *)
-  first_match (match_eq eqn) equalities
+  let d,k = first_match (match_eq eqn) equalities in
+  let hd,u = destInd (fst (destApp eqn)) in
+    d,u,k
 
 let extract_eq_args gl = function
   | MonomorphicLeibnizEq (e1,e2) ->
-      let t = Tacmach.pf_type_of gl e1 in (t,e1,e2)
+      let t = pf_type_of gl e1 in (t,e1,e2)
   | PolymorphicLeibnizEq (t,e1,e2) -> (t,e1,e2)
   | HeterogenousEq (t1,e1,t2,e2) ->
-      if Tacmach.pf_conv_x gl t1 t2 then (t1,e1,e2)
+      if pf_conv_x gl t1 t2 then (t1,e1,e2)
       else raise PatternMatchingFailure
 
 let find_eq_data_decompose gl eqn =
-  let (lbeq,eq_args) = find_eq_data eqn in
-  (lbeq,extract_eq_args gl eq_args)
-
-let inversible_equalities =
-  [coq_eq_pattern, build_coq_inversion_eq_data;
-   coq_jmeq_pattern, build_coq_inversion_jmeq_data;
-   coq_identity_pattern, build_coq_inversion_identity_data;
-   coq_eq_true_pattern, build_coq_inversion_eq_true_data]
+  let (lbeq,u,eq_args) = find_eq_data eqn in
+  (lbeq,u,extract_eq_args gl eq_args)
 
 let find_this_eq_data_decompose gl eqn =
-  let (lbeq,eq_args) =
+  let (lbeq,u,eq_args) =
     try (*first_match (match_eq eqn) inversible_equalities*)
       find_eq_data eqn
     with PatternMatchingFailure ->
@@ -407,17 +431,14 @@ let find_this_eq_data_decompose gl eqn =
     try extract_eq_args gl eq_args
     with PatternMatchingFailure ->
       error "Don't know what to do with JMeq on arguments not of same type." in
-  (lbeq,eq_args)
-
-open Tacmach
-open Tacticals
+  (lbeq,u,eq_args)
 
 let match_eq_nf gls eqn eq_pat =
-  match pf_matches gls (Lazy.force eq_pat) eqn with
+  match Id.Map.bindings (pf_matches gls (Lazy.force eq_pat) eqn) with
     | [(m1,t);(m2,x);(m3,y)] ->
-	assert (m1 = meta1 & m2 = meta2 & m3 = meta3);
+        assert (Id.equal m1 meta1 && Id.equal m2 meta2 && Id.equal m3 meta3);
 	(t,pf_whd_betadeltaiota gls x,pf_whd_betadeltaiota gls y)
-    | _ -> anomaly "match_eq: an eq pattern should match 3 terms"
+    | _ -> anomaly ~label:"match_eq" (Pp.str "an eq pattern should match 3 terms")
 
 let dest_nf_eq gls eqn =
   try
@@ -427,31 +448,24 @@ let dest_nf_eq gls eqn =
 
 (*** Sigma-types *)
 
-(* 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
-    | [(m1,a);(m2,p);(m3,car);(m4,cdr)] ->
-	assert (m1=meta1 & m2=meta2 & m3=meta3 & m4=meta4);
-	(a,p,car,cdr)
-    | _ ->
-	anomaly "match_sigma: a successful sigma pattern should match 4 terms"
-
+let match_sigma ex =
+  match kind_of_term ex with
+  | App (f, [| a; p; car; cdr |]) when is_global (Lazy.force coq_exist_ref) f -> 
+      build_sigma (), (snd (destConstruct f), a, p, car, cdr)
+  | App (f, [| a; p; car; cdr |]) when is_global (Lazy.force coq_existT_ref) f -> 
+    build_sigma_type (), (snd (destConstruct f), a, p, car, cdr)
+  | _ -> raise PatternMatchingFailure
+    
 let find_sigma_data_decompose ex = (* fails with PatternMatchingFailure *)
-  first_match (match_sigma ex)
-    [coq_existT_pattern, build_sigma_type;
-     coq_exist_pattern, build_sigma]
+  match_sigma ex
 
 (* Pattern "(sig ?1 ?2)" *)
 let coq_sig_pattern = lazy PATTERN [ %coq_sig_ref ?X1 ?X2 ]
 
 let match_sigma t =
-  match matches (Lazy.force coq_sig_pattern) t with
+  match Id.Map.bindings (matches (Lazy.force coq_sig_pattern) t) with
     | [(_,a); (_,p)] -> (a,p)
-    | _ -> anomaly "Unexpected pattern"
+    | _ -> anomaly (Pp.str "Unexpected pattern")
 
 let is_matching_sigma t = is_matching (Lazy.force coq_sig_pattern) t
 
@@ -486,10 +500,10 @@ let match_eqdec t =
     try true,op_or,matches (Lazy.force coq_eqdec_pattern) t
     with PatternMatchingFailure ->
         false,op_or,matches (Lazy.force coq_eqdec_rev_pattern) t in
-  match subst with
+  match Id.Map.bindings subst with
   | [(_,typ);(_,c1);(_,c2)] ->
-      eqonleft, Libnames.constr_of_global (Lazy.force op), c1, c2, typ
-  | _ -> anomaly "Unexpected pattern"
+      eqonleft, Universes.constr_of_global (Lazy.force op), c1, c2, typ
+  | _ -> anomaly (Pp.str "Unexpected pattern")
 
 (* Patterns "~ ?" and "? -> False" *)
 let coq_not_pattern = lazy PATTERN [ ~ _ ]
diff --git a/tactics/hipattern.mli b/tactics/hipattern.mli
index 31dd0361..c200871e 100644
--- a/tactics/hipattern.mli
+++ b/tactics/hipattern.mli
@@ -1,17 +1,14 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-open Util
 open Names
 open Term
-open Sign
 open Evd
-open Pattern
 open Coqlib
 
 (** High-order patterns *)
@@ -52,13 +49,13 @@ val is_non_recursive_type         : testing_function
 
 (** 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
+val match_with_disjunction : ?strict:bool -> ?onlybinary:bool -> (constr * constr list) matching_function
+val is_disjunction         : ?strict:bool -> ?onlybinary:bool -> testing_function
 
 (** 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
+val match_with_conjunction : ?strict:bool -> ?onlybinary:bool -> (constr * constr list) matching_function
+val is_conjunction         : ?strict:bool -> ?onlybinary:bool -> testing_function
 
 (** Non recursive tuple, possibly with inner dependencies *)
 val match_with_record      : (constr * constr list) matching_function
@@ -87,7 +84,7 @@ val is_equality_type       : testing_function
 val match_with_nottype     : (constr * constr) matching_function
 val is_nottype             : testing_function
 
-val match_with_forall_term    : (name * constr * constr) matching_function
+val match_with_forall_term    : (Name.t * constr * constr) matching_function
 val is_forall_term            : testing_function
 
 val match_with_imp_term    : (constr * constr) matching_function
@@ -123,20 +120,20 @@ val match_with_equation:
 
 (** Match terms [eq A t u], [identity A t u] or [JMeq A t A u] 
    Returns associated lemmas and [A,t,u] or fails PatternMatchingFailure *)
-val find_eq_data_decompose : Proof_type.goal sigma -> constr ->
-      coq_eq_data * (types * constr * constr)
+val find_eq_data_decompose : [ `NF ] Proofview.Goal.t -> constr ->
+      coq_eq_data * Univ.universe_instance * (types * constr * constr)
 
 (** Idem but fails with an error message instead of PatternMatchingFailure *)
-val find_this_eq_data_decompose : Proof_type.goal sigma -> constr ->
-      coq_eq_data * (types * constr * constr)
+val find_this_eq_data_decompose : [ `NF ] Proofview.Goal.t -> constr ->
+      coq_eq_data * Univ.universe_instance * (types * constr * constr)
 
 (** A variant that returns more informative structure on the equality found *)
-val find_eq_data : constr -> coq_eq_data * equation_kind
+val find_eq_data : constr -> coq_eq_data * Univ.universe_instance * equation_kind
 
 (** Match a term of the form [(existT A P t p)] 
    Returns associated lemmas and [A,P,t,p] *)
 val find_sigma_data_decompose : constr ->
-  coq_sigma_data * (constr * constr * constr * constr)
+  coq_sigma_data * (Univ.universe_instance * constr * constr * constr * constr)
 
 (** Match a term of the form [{x:A|P}], returns [A] and [P] *)
 val match_sigma : constr -> constr * constr
@@ -150,7 +147,7 @@ val match_eqdec : constr -> bool * constr * constr * constr * constr
 (** 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)
+val dest_nf_eq : [ `NF ] Proofview.Goal.t -> constr -> (constr * constr * constr)
 
 (** Match a negation *)
 val is_matching_not : constr -> bool
diff --git a/tactics/inv.ml b/tactics/inv.ml
index 73edaf86..5502356f 100644
--- a/tactics/inv.ml
+++ b/tactics/inv.ml
@@ -1,63 +1,40 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
 open Pp
+open Errors
 open Util
 open Names
 open Nameops
 open Term
+open Vars
+open Context
 open Termops
 open Namegen
-open Global
-open Sign
 open Environ
 open Inductiveops
 open Printer
-open Reductionops
 open Retyping
-open Tacmach
-open Proof_type
-open Evar_refiner
-open Clenv
-open Tactics
-open Tacticals
+open Tacmach.New
+open Tacticals.New
 open Tactics
 open Elim
 open Equality
-open Typing
-open Pattern
-open Matching
-open Glob_term
-open Genarg
+open Misctypes
 open Tacexpr
+open Proofview.Notations
 
-let collect_meta_variables c =
-  let rec collrec acc c = match kind_of_term c with
-    | Meta mv -> mv::acc
-    | _ -> fold_constr collrec acc c
-  in
-  collrec [] c
-
-let check_no_metas clenv ccl =
-  if occur_meta ccl then
-    let metas = List.filter (fun m -> not (Evd.meta_defined clenv.evd m))
-      (collect_meta_variables ccl) in
-    let metas = List.map (Evd.meta_name clenv.evd) metas in
-    errorlabstrm "inversion"
-      (str ("Cannot find an instantiation for variable"^
-	       (if List.length metas = 1 then " " else "s ")) ++
-	 prlist_with_sep pr_comma pr_name metas
-	 (* ajouter "in " ++ pr_lconstr ccl mais il faut le bon contexte *))
+let clear hyps = Proofview.V82.tactic (clear hyps)
 
 let var_occurs_in_pf gl id =
-  let env = pf_env gl in
-  occur_var env id (pf_concl gl) or
-  List.exists (occur_var_in_decl env id) (pf_hyps gl)
+  let env = Proofview.Goal.env gl in
+  occur_var env id (Proofview.Goal.concl gl) ||
+  List.exists (occur_var_in_decl env id) (Proofview.Goal.hyps gl)
 
 (* [make_inv_predicate (ity,args) C]
 
@@ -88,16 +65,16 @@ let var_occurs_in_pf gl id =
 type inversion_status = Dep of constr option | NoDep
 
 let compute_eqn env sigma n i ai =
-  (ai, (mkRel (n-i),get_type_of env sigma (mkRel (n-i))))
+  (mkRel (n-i),get_type_of env sigma (mkRel (n-i)))
 
-let make_inv_predicate env sigma indf realargs id status concl =
+let make_inv_predicate env evd indf realargs id status concl =
   let nrealargs = List.length realargs in
   let (hyps,concl) =
     match status with
       | NoDep ->
 	  (* We push the arity and leave concl unchanged *)
 	  let hyps_arity,_ = get_arity env indf in
-	  (hyps_arity,concl)
+	    (hyps_arity,concl)
       | Dep dflt_concl ->
 	  if not (occur_var env id concl) then
 	    errorlabstrm "make_inv_predicate"
@@ -109,41 +86,53 @@ let make_inv_predicate env sigma indf realargs id status concl =
             match dflt_concl with
               | Some concl -> concl (*assumed it's some [x1..xn,H:I(x1..xn)]C*)
               | None ->
-		let sort = get_sort_family_of env sigma concl in
-		let p = make_arity env true indf (new_sort_in_family sort) in
-		Unification.abstract_list_all env (Evd.create_evar_defs sigma)
-		  p concl (realargs@[mkVar id]) in
+		let sort = get_sort_family_of env !evd concl in
+		let sort = Evarutil.evd_comb1 (Evd.fresh_sort_in_family env) evd sort in
+		let p = make_arity env true indf sort in
+		let evd',(p,ptyp) = Unification.abstract_list_all env
+                  !evd p concl (realargs@[mkVar id])
+		in evd := evd'; p in
 	  let hyps,bodypred = decompose_lam_n_assum (nrealargs+1) pred in
 	  (* We lift to make room for the equations *)
 	  (hyps,lift nrealargs bodypred)
   in
   let nhyps = rel_context_length hyps in
   let env' = push_rel_context hyps env in
-  let realargs' = List.map (lift nhyps) realargs in
-  let pairs = list_map_i (compute_eqn env' sigma nhyps) 0 realargs' in
   (* Now the arity is pushed, and we need to construct the pairs
    * ai,mkRel(n-i+1) *)
   (* Now, we can recurse down this list, for each ai,(mkRel k) whether to
      push <Ai>(mkRel k)=ai (when   Ai is closed).
    In any case, we carry along the rest of pairs *)
-  let rec build_concl eqns n = function
-    | [] -> (it_mkProd concl eqns,n)
-    | (ai,(xi,ti))::restlist ->
+  let eqdata = Coqlib.build_coq_eq_data () in
+  let rec build_concl eqns args n = function
+    | [] -> it_mkProd concl eqns, Array.rev_of_list args
+    | ai :: restlist ->
+        let ai = lift nhyps ai in
+        let (xi, ti) = compute_eqn env' !evd nhyps n ai in
         let (lhs,eqnty,rhs) =
           if closed0 ti then
 	    (xi,ti,ai)
           else
-	    make_iterated_tuple env' sigma ai (xi,ti)
+	    let sigma, res = make_iterated_tuple env' !evd ai (xi,ti) in
+	      evd := sigma; res
 	in
-        let eq_term = Coqlib.build_coq_eq () in
-        let eqn = applist (eq_term ,[eqnty;lhs;rhs]) in
-	build_concl ((Anonymous,lift n eqn)::eqns) (n+1) restlist
+        let eq_term = eqdata.Coqlib.eq in
+	let eq = Evarutil.evd_comb1 (Evd.fresh_global env) evd eq_term in
+        let eqn = applist (eq,[eqnty;lhs;rhs]) in
+        let eqns = (Anonymous, lift n eqn) :: eqns in
+        let refl_term = eqdata.Coqlib.refl in
+	let refl_term = Evarutil.evd_comb1 (Evd.fresh_global env) evd refl_term in
+        let refl = mkApp (refl_term, [|eqnty; rhs|]) in
+	let _ = Evarutil.evd_comb1 (Typing.e_type_of env) evd refl in
+        let args = refl :: args in
+        build_concl eqns args (succ n) restlist
   in
-  let (newconcl,neqns) = build_concl [] 0 pairs in
+  let (newconcl, args) = build_concl [] [] 0 realargs in
   let predicate = it_mkLambda_or_LetIn_name env newconcl hyps in
+  let _ = Evarutil.evd_comb1 (Typing.e_type_of env) evd predicate in
   (* OK - this predicate should now be usable by res_elimination_then to
      do elimination on the conclusion. *)
-  (predicate,neqns)
+  predicate, args
 
 (* The result of the elimination is a bunch of goals like:
 
@@ -189,13 +178,13 @@ let make_inv_predicate env sigma indf realargs id status concl =
    and introduces generalized hypotheis.
    Precondition: t=(mkVar id) *)
 
-let rec dependent_hyps id idlist gl =
+let dependent_hyps env id idlist gl =
   let rec dep_rec =function
     | [] -> []
     | (id1,_,_)::l ->
 	(* Update the type of id1: it may have been subject to rewriting *)
-	let d = pf_get_hyp gl id1 in
-	if occur_var_in_decl (Global.env()) id d
+	let d = pf_get_hyp id1 gl in
+	if occur_var_in_decl env id d
         then d :: dep_rec l
         else dep_rec l
   in
@@ -207,8 +196,6 @@ let split_dep_and_nodep hyps gl =
        if var_occurs_in_pf gl id then (d::l1,l2) else (l1,d::l2))
     hyps ([],[])
 
-open Coqlib
-
 (* Computation of dids is late; must have been done in rewrite_equations*)
 (* Will keep generalizing and introducing back and forth... *)
 (* Moreover, others hyps depending of dids should have been *)
@@ -280,21 +267,62 @@ Summary: nine useless hypotheses!
 Nota: with Inversion_clear, only four useless hypotheses
 *)
 
-let generalizeRewriteIntros tac depids id gls =
-  let dids = dependent_hyps id depids gls in
-  (tclTHENSEQ
+let generalizeRewriteIntros as_mode tac depids id =
+  Proofview.tclENV >>= fun env ->
+  Proofview.Goal.nf_enter begin fun gl ->
+  let dids = dependent_hyps env id depids gl in
+  let reintros = if as_mode then intros_replacing else intros_possibly_replacing in
+  (tclTHENLIST
     [bring_hyps dids; tac;
      (* may actually fail to replace if dependent in a previous eq *)
-     intros_replacing (ids_of_named_context dids)])
-  gls
-
-let rec tclMAP_i n tacfun = function
-  | [] -> tclDO n (tacfun None)
-  | a::l ->
-      if n=0 then error "Too many names."
-      else tclTHEN (tacfun (Some a)) (tclMAP_i (n-1) tacfun l)
+     reintros (ids_of_named_context dids)])
+  end
+
+let error_too_many_names pats =
+  let loc = Loc.join_loc (fst (List.hd pats)) (fst (List.last pats)) in
+  Proofview.tclENV >>= fun env ->
+  tclZEROMSG ~loc (
+    str "Unexpected " ++
+    str (String.plural (List.length pats) "introduction pattern") ++
+    str ": " ++ pr_enum (Miscprint.pr_intro_pattern (fun c -> Printer.pr_constr (snd (c env Evd.empty)))) pats ++
+    str ".")
+
+let rec get_names (allow_conj,issimple) (loc,pat as x) = match pat with
+  | IntroNaming IntroAnonymous | IntroForthcoming _ ->
+      error "Anonymous pattern not allowed for inversion equations."
+  | IntroNaming (IntroFresh _) ->
+      error "Fresh pattern not allowed for inversion equations."
+  | IntroAction IntroWildcard ->
+      error "Discarding pattern not allowed for inversion equations."
+  | IntroAction (IntroRewrite _) ->
+      error "Rewriting pattern not allowed for inversion equations."
+  | IntroAction (IntroOrAndPattern [[]]) when allow_conj -> (None, [])
+  | IntroAction (IntroOrAndPattern [(_,IntroNaming (IntroIdentifier id)) :: _ as l])
+      when allow_conj -> (Some id,l)
+  | IntroAction (IntroOrAndPattern [_]) ->
+      if issimple then
+        error"Conjunctive patterns not allowed for simple inversion equations."
+      else
+        error"Nested conjunctive patterns not allowed for inversion equations."
+  | IntroAction (IntroInjection l) ->
+      error "Injection patterns not allowed for inversion equations."
+  | IntroAction (IntroOrAndPattern l) ->
+      error "Disjunctive patterns not allowed for inversion equations."
+  | IntroAction (IntroApplyOn (c,pat)) ->
+      error "Apply patterns not allowed for inversion equations."
+  | IntroNaming (IntroIdentifier id) ->
+      (Some id,[x])
+
+let rec tclMAP_i allow_conj n tacfun = function
+  | [] -> tclDO n (tacfun (None,[]))
+  | a::l as l' ->
+      if Int.equal n 0 then error_too_many_names l'
+      else
+        tclTHEN
+          (tacfun (get_names allow_conj a))
+          (tclMAP_i allow_conj (n-1) tacfun l)
 
-let remember_first_eq id x = if !x = no_move then x := MoveAfter id
+let remember_first_eq id x = if !x == MoveLast then x := MoveAfter id
 
 (* invariant: ProjectAndApply is responsible for erasing the clause
    which it is given as input
@@ -304,217 +332,177 @@ let remember_first_eq id x = if !x = no_move then x := MoveAfter id
    If it can discriminate then the goal is proved, if not tries to use it as
    a rewrite rule. It erases the clause which is given as input *)
 
-let projectAndApply thin id eqname names depids gls =
+let projectAndApply as_mode thin avoid id eqname names depids =
   let subst_hyp l2r id =
     tclTHEN (tclTRY(rewriteInConcl l2r (mkVar id)))
       (if thin then clear [id] else (remember_first_eq id eqname; tclIDTAC))
   in
-  let substHypIfVariable tac id gls =
-    let (t,t1,t2) = Hipattern.dest_nf_eq gls (pf_get_hyp_typ gls id) in
+  let substHypIfVariable tac id =
+    Proofview.Goal.nf_enter begin fun gl ->
+    (** We only look at the type of hypothesis "id" *)
+    let hyp = pf_nf_evar gl (pf_get_hyp_typ id (Proofview.Goal.assume gl)) in
+    let (t,t1,t2) = Hipattern.dest_nf_eq gl hyp in
     match (kind_of_term t1, kind_of_term t2) with
-    | Var id1, _ -> generalizeRewriteIntros (subst_hyp true id) depids id1 gls
-    | _, Var id2 -> generalizeRewriteIntros (subst_hyp false id) depids id2 gls
-    | _ -> tac id gls
+    | Var id1, _ -> generalizeRewriteIntros as_mode (subst_hyp true id) depids id1
+    | _, Var id2 -> generalizeRewriteIntros as_mode (subst_hyp false id) depids id2
+    | _ -> tac id
+    end
   in
-  let deq_trailer id neqns =
-    tclTHENSEQ
-      [(if names <> [] then clear [id] else tclIDTAC);
-       (tclMAP_i neqns (fun idopt ->
+  let deq_trailer id clear_flag _ neqns =
+    assert (clear_flag == None);
+    tclTHENLIST
+      [if as_mode then clear [id] else tclIDTAC;
+       (tclMAP_i (false,false) neqns (function (idopt,_) ->
 	 tclTRY (tclTHEN
-	   (intro_move idopt no_move)
+	   (intro_move_avoid idopt avoid MoveLast)
 	   (* try again to substitute and if still not a variable after *)
 	   (* decomposition, arbitrarily try to rewrite RL !? *)
-	   (tclTRY (onLastHypId (substHypIfVariable (subst_hyp false))))))
+	   (tclTRY (onLastHypId (substHypIfVariable (fun id -> subst_hyp false id))))))
 	 names);
-       (if names = [] then clear [id] else tclIDTAC)]
+       (if as_mode then tclIDTAC else clear [id])]
+          (* Doing the above late breaks the computation of dids in 
+             generalizeRewriteIntros, and hence breaks proper intros_replacing
+             but it is needed for compatibility *)
   in
   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 (ElimOnConstr (mkVar id,NoBindings))))
+	(Some (None,ElimOnConstr (mkVar id,NoBindings))))
     id
-    gls
-
-(* Inversion qui n'introduit pas les hypotheses, afin de pouvoir les nommer
-   soi-meme (proposition de Valerie). *)
-let rewrite_equations_gene othin neqns ba gl =
-  let (depids,nodepids) = split_dep_and_nodep ba.assums gl in
-  let rewrite_eqns =
-    match othin with
-      | Some thin ->
-          onLastHypId
-            (fun last ->
-              tclTHENSEQ
-                [tclDO neqns
-                     (tclTHEN intro
-                        (onLastHypId
-                           (fun id ->
-                              tclTRY
-			        (projectAndApply thin id (ref no_move)
-				  [] depids))));
-                 onHyps (compose List.rev (afterHyp last)) bring_hyps;
-                 onHyps (afterHyp last)
-                   (compose clear ids_of_named_context)])
-      | None -> tclIDTAC
-  in
-  (tclTHENSEQ
-    [tclDO neqns intro;
-     bring_hyps nodepids;
-     clear (ids_of_named_context nodepids);
-     onHyps (compose List.rev (nLastDecls neqns)) bring_hyps;
-     onHyps (nLastDecls neqns) (compose clear ids_of_named_context);
-     rewrite_eqns;
-     tclMAP (fun (id,_,_ as d) ->
-               (tclORELSE (clear [id])
-                 (tclTHEN (bring_hyps [d]) (clear [id]))))
-       depids])
-  gl
+
+let nLastDecls i tac =
+  Proofview.Goal.nf_enter (fun gl -> tac (nLastDecls gl i))
 
 (* Introduction of the equations on arguments
    othin: discriminates Simple Inversion, Inversion and Inversion_clear
      None: the equations are introduced, but not rewritten
      Some thin: the equations are rewritten, and cleared if thin is true *)
 
-let rec get_names allow_conj (loc,pat) = match pat with
-  | IntroWildcard ->
-      error "Discarding pattern not allowed for inversion equations."
-  | IntroAnonymous | IntroForthcoming _ ->
-      error "Anonymous pattern not allowed for inversion equations."
-  | IntroFresh _ ->
-      error "Fresh pattern not allowed for inversion equations."
-  | IntroRewrite _->
-      error "Rewriting pattern not allowed for inversion equations."
-  | IntroOrAndPattern [l] ->
-      if allow_conj then
-	if l = [] then (None,[]) else
-	  let l = List.map (fun id -> Option.get (fst (get_names false id))) l in
-	  (Some (List.hd l), l)
-      else
-	error"Nested conjunctive patterns not allowed for inversion equations."
-  | IntroOrAndPattern l ->
-      error "Disjunctive patterns not allowed for inversion equations."
-  | IntroIdentifier id ->
-      (Some id,[id])
-
-let extract_eqn_names = function
-  | None -> None,[]
-  | Some x -> x
-
-let rewrite_equations othin neqns names ba gl =
-  let names = List.map (get_names true) names in
-  let (depids,nodepids) = split_dep_and_nodep ba.assums gl in
-  let rewrite_eqns =
-    let first_eq = ref no_move in
-    match othin with
-      | Some thin ->
-          tclTHENSEQ
-            [onHyps (compose List.rev (nLastDecls neqns)) bring_hyps;
-             onHyps (nLastDecls neqns) (compose clear ids_of_named_context);
-	     tclMAP_i neqns (fun o ->
-	       let idopt,names = extract_eqn_names o in
+let rewrite_equations as_mode othin neqns names ba =
+  Proofview.Goal.nf_enter begin fun gl ->
+  let (depids,nodepids) = split_dep_and_nodep ba.Tacticals.assums gl in
+  let first_eq = ref MoveLast in
+  let avoid = if as_mode then List.map pi1 nodepids else [] in
+  match othin with
+    | Some thin ->
+        tclTHENLIST
+            [tclDO neqns intro;
+             bring_hyps nodepids;
+             clear (ids_of_named_context nodepids);
+             (nLastDecls neqns (fun ctx -> bring_hyps (List.rev ctx)));
+             (nLastDecls neqns (fun ctx -> clear (ids_of_named_context ctx)));
+	     tclMAP_i (true,false) neqns (fun (idopt,names) ->
                (tclTHEN
-		 (intro_move idopt no_move)
+		 (intro_move_avoid idopt avoid MoveLast)
 		 (onLastHypId (fun id ->
-		   tclTRY (projectAndApply thin id first_eq names depids)))))
+		   tclTRY (projectAndApply as_mode thin avoid id first_eq names depids)))))
 	       names;
-	     tclMAP (fun (id,_,_) gl ->
-	       intro_move None (if thin then no_move else !first_eq) gl)
+	     tclMAP (fun (id,_,_) -> tclIDTAC >>= fun () -> (* delay for [first_eq]. *)
+               let idopt = if as_mode then Some id else None in
+	       intro_move idopt (if thin then MoveLast else !first_eq))
 	       nodepids;
-	     tclMAP (fun (id,_,_) -> tclTRY (clear [id])) depids]
-      | None -> tclIDTAC
-  in
-  (tclTHENSEQ
-    [tclDO neqns intro;
-     bring_hyps nodepids;
-     clear (ids_of_named_context nodepids);
-     rewrite_eqns])
-  gl
+	     (tclMAP (fun (id,_,_) -> tclTRY (clear [id])) depids)]
+    | None ->
+        (* simple inversion *)
+        if as_mode then
+          tclMAP_i (false,true) neqns (fun (idopt,_) ->
+	    intro_move idopt MoveLast) names
+        else
+          (tclTHENLIST
+             [tclDO neqns intro;
+              bring_hyps nodepids;
+              clear (ids_of_named_context nodepids)])
+  end
 
 let interp_inversion_kind = function
   | SimpleInversion -> None
   | FullInversion -> Some false
   | FullInversionClear -> Some true
 
-let rewrite_equations_tac (gene, othin) id neqns names ba =
+let rewrite_equations_tac as_mode othin id neqns names ba =
   let othin = interp_inversion_kind othin in
-  let tac =
-    if gene then rewrite_equations_gene othin neqns ba
-    else rewrite_equations othin neqns names ba in
-  if othin = Some true (* if Inversion_clear, clear the hypothesis *) then
+  let tac = rewrite_equations as_mode othin neqns names ba in
+  match othin with
+  | Some true (* if Inversion_clear, clear the hypothesis *) ->
     tclTHEN tac (tclTRY (clear [id]))
-  else
+  | _ ->
     tac
 
-
-let raw_inversion inv_kind id status names gl =
-  let env = pf_env gl and sigma = project gl in
-  let c = mkVar id in
-  let (ind,t) =
-    try pf_reduce_to_atomic_ind gl (pf_type_of gl c)
-    with UserError _ ->
-      errorlabstrm "raw_inversion"
-	(str ("The type of "^(string_of_id id)^" is not inductive.")) in
-  let indclause = mk_clenv_from gl (c,t) in
-  let ccl = clenv_type indclause in
-  check_no_metas indclause ccl;
-  let IndType (indf,realargs) = find_rectype env sigma ccl in
-  let (elim_predicate,neqns) =
-    make_inv_predicate env sigma indf realargs id status (pf_concl gl) in
-  let (cut_concl,case_tac) =
-    if status <> NoDep & (dependent c (pf_concl gl)) then
-      Reduction.beta_appvect elim_predicate (Array.of_list (realargs@[c])),
-      case_then_using
-    else
-      Reduction.beta_appvect elim_predicate (Array.of_list realargs),
-      case_nodep_then_using
-  in
-  (tclTHENS
-     (assert_tac Anonymous cut_concl)
-     [case_tac names
-       (introCaseAssumsThen (rewrite_equations_tac inv_kind id neqns))
-       (Some elim_predicate) ([],[]) ind indclause;
-      onLastHypId
-        (fun id ->
-           (tclTHEN
-              (apply_term (mkVar id)
-                 (list_tabulate (fun _ -> Evarutil.mk_new_meta()) neqns))
-              reflexivity))])
-  gl
+let raw_inversion inv_kind id status names =
+  Proofview.Goal.nf_enter begin fun gl ->
+    let sigma = Proofview.Goal.sigma gl in
+    let env = Proofview.Goal.env gl in
+    let concl = Proofview.Goal.concl gl in
+    let c = mkVar id in
+    let (ind, t) =
+      try pf_apply Tacred.reduce_to_atomic_ind gl (pf_type_of gl c)
+      with UserError _ ->
+        let msg = str "The type of " ++ pr_id id ++ str " is not inductive." in
+        Errors.errorlabstrm "" msg
+    in
+    let IndType (indf,realargs) = find_rectype env sigma t in
+    let evdref = ref sigma in
+    let (elim_predicate, args) =
+      make_inv_predicate env evdref indf realargs id status concl in
+    let sigma = !evdref in
+    let (cut_concl,case_tac) =
+      if status != NoDep && (dependent c concl) then
+        Reduction.beta_appvect elim_predicate (Array.of_list (realargs@[c])),
+        case_then_using
+      else
+        Reduction.beta_appvect elim_predicate (Array.of_list realargs),
+        case_nodep_then_using
+    in
+    let refined id =
+      let prf = mkApp (mkVar id, args) in
+      Proofview.Refine.refine (fun h -> h, prf)
+    in
+    let neqns = List.length realargs in
+    let as_mode = names != None in
+    tclTHEN (Proofview.Unsafe.tclEVARS sigma)
+      (tclTHENS
+        (assert_before Anonymous cut_concl)
+        [case_tac names
+            (introCaseAssumsThen
+               (rewrite_equations_tac as_mode inv_kind id neqns))
+            (Some elim_predicate) ind (c, t);
+        onLastHypId (fun id -> tclTHEN (refined id) reflexivity)])
+  end
 
 (* Error messages of the inversion tactics *)
-let wrap_inv_error id = function
+let wrap_inv_error id = function (e, info) -> match e with
   | Indrec.RecursionSchemeError
       (Indrec.NotAllowedCaseAnalysis (_,(Type _ | Prop Pos as k),i)) ->
-      errorlabstrm ""
+      Proofview.tclENV >>= fun env ->
+      tclZEROMSG (
 	(strbrk "Inversion would require case analysis on sort " ++
-	pr_sort k ++
+	pr_sort Evd.empty k ++
 	strbrk " which is not allowed for inductive definition " ++
-	pr_inductive (Global.env()) i ++ str ".")
-  | e -> raise e
+	pr_inductive env (fst i) ++ str "."))
+  | e -> Proofview.tclZERO ~info e
 
 (* The most general inversion tactic *)
-let inversion inv_kind status names id gls =
-  try (raw_inversion inv_kind id status names) gls
-  with e when Errors.noncritical e -> wrap_inv_error id e
+let inversion inv_kind status names id =
+  Proofview.tclORELSE
+    (raw_inversion inv_kind id status names)
+    (wrap_inv_error id)
 
 (* Specializing it... *)
 
-let inv_gen gene thin status names =
-  try_intros_until (inversion (gene,thin) status names)
+let inv_gen thin status names =
+  try_intros_until (inversion thin status names)
 
 open Tacexpr
 
-let inv k = inv_gen false k NoDep
+let inv k = inv_gen k NoDep
 
-let half_inv_tac id  = inv SimpleInversion None (NamedHyp id)
 let inv_tac id       = inv FullInversion None (NamedHyp id)
 let inv_clear_tac id = inv FullInversionClear None (NamedHyp id)
 
-let dinv k c = inv_gen false k (Dep c)
+let dinv k c = inv_gen k (Dep c)
 
-let half_dinv_tac id  = dinv SimpleInversion None None (NamedHyp id)
 let dinv_tac id       = dinv FullInversion None None (NamedHyp id)
 let dinv_clear_tac id = dinv FullInversionClear None None (NamedHyp id)
 
@@ -522,25 +510,30 @@ let dinv_clear_tac id = dinv FullInversionClear None None (NamedHyp id)
  * perform inversion on the named hypothesis.  After, it will intro them
  * back to their places in the hyp-list. *)
 
-let invIn k names ids id gls =
-  let hyps = List.map (pf_get_hyp gls) ids in
-  let nb_prod_init = nb_prod (pf_concl gls) in
-  let intros_replace_ids gls =
-    let nb_of_new_hyp =
-      nb_prod (pf_concl gls) - (List.length hyps + nb_prod_init)
+let invIn k names ids id =
+  Proofview.Goal.nf_enter begin fun gl ->
+    let hyps = List.map (fun id -> pf_get_hyp id gl) ids in
+    let concl = Proofview.Goal.concl gl in
+    let nb_prod_init = nb_prod concl in
+    let intros_replace_ids =
+      Proofview.Goal.enter begin fun gl ->
+        let concl = pf_nf_concl gl in
+        let nb_of_new_hyp =
+          nb_prod concl - (List.length hyps + nb_prod_init)
+        in
+        if nb_of_new_hyp < 1 then
+          intros_replacing ids
+        else
+          tclTHEN (tclDO nb_of_new_hyp intro) (intros_replacing ids)
+      end
     in
-    if nb_of_new_hyp < 1 then
-      intros_replacing ids gls
-    else
-      tclTHEN (tclDO nb_of_new_hyp intro) (intros_replacing ids) gls
-  in
-  try
-    (tclTHENSEQ
-      [bring_hyps hyps;
-       inversion (false,k) NoDep names id;
-       intros_replace_ids])
-    gls
-  with e when Errors.noncritical e -> wrap_inv_error id e
+    Proofview.tclORELSE
+      (tclTHENLIST
+         [bring_hyps hyps;
+          inversion k NoDep names id;
+          intros_replace_ids])
+      (wrap_inv_error id)
+  end
 
 let invIn_gen k names idl = try_intros_until (invIn k names idl)
 
diff --git a/tactics/inv.mli b/tactics/inv.mli
index ca87e0fc..b3478dda 100644
--- a/tactics/inv.mli
+++ b/tactics/inv.mli
@@ -1,41 +1,30 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-open Util
+open Loc
 open Names
 open Term
-open Tacmach
-open Genarg
+open Misctypes
 open Tacexpr
-open Glob_term
 
 type inversion_status = Dep of constr option | NoDep
 
-val inv_gen :
-  bool -> inversion_kind -> inversion_status ->
-    intro_pattern_expr located option -> quantified_hypothesis -> tactic
-val invIn_gen :
-  inversion_kind -> intro_pattern_expr located option -> identifier list ->
-    quantified_hypothesis -> tactic
-
 val inv_clause :
-  inversion_kind -> intro_pattern_expr located option -> identifier list ->
-    quantified_hypothesis -> tactic
+  inversion_kind -> or_and_intro_pattern option -> Id.t list ->
+    quantified_hypothesis -> unit Proofview.tactic
 
-val inv : inversion_kind -> intro_pattern_expr located option ->
-  quantified_hypothesis -> tactic
+val inv : inversion_kind -> or_and_intro_pattern option ->
+  quantified_hypothesis -> unit Proofview.tactic
 
 val dinv : inversion_kind -> constr option ->
-  intro_pattern_expr located option -> quantified_hypothesis -> tactic
+  or_and_intro_pattern option -> quantified_hypothesis -> unit Proofview.tactic
 
-val half_inv_tac : identifier -> tactic
-val inv_tac : identifier -> tactic
-val inv_clear_tac : identifier -> tactic
-val half_dinv_tac : identifier -> tactic
-val dinv_tac : identifier -> tactic
-val dinv_clear_tac : identifier -> tactic
+val inv_tac : Id.t -> unit Proofview.tactic
+val inv_clear_tac : Id.t -> unit Proofview.tactic
+val dinv_tac : Id.t -> unit Proofview.tactic
+val dinv_clear_tac : Id.t -> unit Proofview.tactic
diff --git a/tactics/leminv.ml b/tactics/leminv.ml
index bae81df7..f00ecf8f 100644
--- a/tactics/leminv.ml
+++ b/tactics/leminv.ml
@@ -1,42 +1,36 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
 open Pp
+open Errors
 open Util
 open Names
-open Nameops
 open Term
+open Vars
 open Termops
 open Namegen
-open Sign
+open Context
 open Evd
 open Printer
 open Reductionops
-open Declarations
 open Entries
 open Inductiveops
 open Environ
-open Tacmach
-open Proof_type
-open Pfedit
-open Evar_refiner
+open Tacmach.New
 open Clenv
 open Declare
-open Tacticals
+open Tacticals.New
 open Tactics
-open Inv
-open Vernacexpr
-open Safe_typing
 open Decl_kinds
 
-let no_inductive_inconstr env constr =
+let no_inductive_inconstr env sigma constr =
   (str "Cannot recognize an inductive predicate in " ++
-     pr_lconstr_env env constr ++
+     pr_lconstr_env env sigma constr ++
      str "." ++ spc () ++ str "If there is one, may be the structure of the arity" ++
      spc () ++ str "or of the type of constructors" ++ spc () ++
      str "is hidden by constant definitions.")
@@ -146,7 +140,7 @@ let rec add_prods_sign env sigma t =
 let compute_first_inversion_scheme env sigma ind sort dep_option =
   let indf,realargs = dest_ind_type ind in
   let allvars = ids_of_context env in
-  let p = next_ident_away (id_of_string "P") allvars in
+  let p = next_ident_away (Id.of_string "P") allvars in
   let pty,goal =
     if dep_option  then
       let pty = make_arity env true indf sort in
@@ -161,7 +155,7 @@ let compute_first_inversion_scheme env sigma ind sort dep_option =
       let revargs,ownsign =
 	fold_named_context
 	  (fun env (id,_,_ as d) (revargs,hyps) ->
-             if List.mem id ivars then
+             if Id.List.mem id ivars then
 	       ((mkVar id)::revargs,add_named_decl d hyps)
 	     else
 	       (revargs,hyps))
@@ -187,21 +181,24 @@ let inversion_scheme env sigma t sort dep_option inv_op =
   let ind =
     try find_rectype env sigma i
     with Not_found ->
-      errorlabstrm "inversion_scheme" (no_inductive_inconstr env i)
+      errorlabstrm "inversion_scheme" (no_inductive_inconstr env sigma i)
   in
   let (invEnv,invGoal) =
     compute_first_inversion_scheme env sigma ind sort dep_option
   in
   assert
-    (list_subset
+    (List.subset
        (global_vars env invGoal)
        (ids_of_named_context (named_context invEnv)));
   (*
     errorlabstrm "lemma_inversion"
     (str"Computed inversion goal was not closed in initial signature.");
   *)
-  let pf = Proof.start [invEnv,invGoal] in
-  Proof.run_tactic env (Proofview.V82.tactic (tclTHEN intro (onLastHypId inv_op))) pf;
+  let pf = Proof.start (Evd.from_env ~ctx:(evar_universe_context sigma) invEnv) [invEnv,invGoal] in
+  let pf =
+    fst (Proof.run_tactic env (
+      tclTHEN intro (onLastHypId inv_op)) pf)
+  in
   let pfterm = List.hd (Proof.partial_proof pf) in
   let global_named_context = Global.named_context () in
   let ownSign = ref begin
@@ -216,7 +213,7 @@ let inversion_scheme env sigma t sort dep_option inv_op =
   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 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;
@@ -231,37 +228,21 @@ let inversion_scheme env sigma t sort dep_option inv_op =
 
 let add_inversion_lemma name env sigma t sort dep inv_op =
   let invProof = inversion_scheme env sigma t sort dep inv_op in
-  let _ =
-    declare_constant name
-    (DefinitionEntry
-       { const_entry_body = invProof;
-         const_entry_secctx = None;
-         const_entry_type = None;
-         const_entry_opaque = false },
-     IsProof Lemma)
-  in ()
+  let entry = definition_entry ~poly:true (*FIXME*) invProof in
+  let _ = declare_constant name (DefinitionEntry entry, IsProof Lemma) in
+  ()
 
 (* 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 { 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
-  add_inversion_lemma na env sigma t sort dep_option inv_op
-
 let add_inversion_lemma_exn na com comsort bool tac =
-  let env = Global.env () and sigma = Evd.empty in
-  let c = Constrintern.interp_type sigma env com in
-  let sort = Pretyping.interp_sort comsort in
+  let env = Global.env () and evd = ref Evd.empty in
+  let c = Constrintern.interp_type_evars env evd com in
+  let sigma, sort = Pretyping.interp_sort !evd comsort in
   try
     add_inversion_lemma na env sigma c sort bool tac
   with
-    |   UserError ("Case analysis",s) -> (* référence à Indrec *)
+    |   UserError ("Case analysis",s) -> (* Reference to Indrec *)
 	  errorlabstrm "Inv needs Nodep Prop Set" s
 
 (* ================================= *)
@@ -272,7 +253,7 @@ let lemInv id c gls =
   try
     let clause = mk_clenv_type_of gls c in
     let clause = clenv_constrain_last_binding (mkVar id) clause in
-    Clenvtac.res_pf clause ~flags:Unification.elim_flags gls
+    Proofview.V82.of_tactic (Clenvtac.res_pf clause ~flags:(Unification.elim_flags ()) ~with_evars:false) gls
   with
     | NoSuchBinding ->
 	errorlabstrm ""
@@ -280,21 +261,24 @@ let lemInv id c gls =
     | UserError (a,b) ->
 	 errorlabstrm "LemInv"
 	   (str "Cannot refine current goal with the lemma " ++
-	      pr_lconstr_env (Global.env()) c)
-
-let lemInv_gen id c = try_intros_until (fun id -> lemInv id c) id
-
-let lemInvIn id c ids gls =
-  let hyps = List.map (pf_get_hyp gls) ids in
-  let intros_replace_ids gls =
-    let nb_of_new_hyp  = nb_prod (pf_concl gls) - List.length ids in
-    if nb_of_new_hyp < 1  then
-      intros_replacing ids gls
-    else
-      (tclTHEN (tclDO nb_of_new_hyp intro) (intros_replacing ids)) gls
-  in
-  ((tclTHEN (tclTHEN (bring_hyps hyps) (lemInv id c))
-    (intros_replace_ids)) gls)
+	      pr_lconstr_env (Refiner.pf_env gls) (Refiner.project gls) c)
+
+let lemInv_gen id c = try_intros_until (fun id -> Proofview.V82.tactic (lemInv id c)) id
+
+let lemInvIn id c ids =
+  Proofview.Goal.nf_enter begin fun gl ->
+    let hyps = List.map (fun id -> pf_get_hyp id gl) ids in
+    let intros_replace_ids =
+      let concl = Proofview.Goal.concl gl in
+      let nb_of_new_hyp  = nb_prod concl - List.length ids in
+      if nb_of_new_hyp < 1  then
+        intros_replacing ids
+      else
+        (tclTHEN (tclDO nb_of_new_hyp intro) (intros_replacing ids))
+    in
+    ((tclTHEN (tclTHEN (bring_hyps hyps) (Proofview.V82.tactic (lemInv id c)))
+        (intros_replace_ids)))
+  end
 
 let lemInvIn_gen id c l = try_intros_until (fun id -> lemInvIn id c l) id
 
diff --git a/tactics/leminv.mli b/tactics/leminv.mli
index 233aeba3..47a4de44 100644
--- a/tactics/leminv.mli
+++ b/tactics/leminv.mli
@@ -1,19 +1,20 @@
-open Util
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+open Loc
 open Names
 open Term
-open Glob_term
-open Proof_type
-open Topconstr
-
-val lemInv_gen : quantified_hypothesis -> constr -> tactic
-val lemInvIn_gen : quantified_hypothesis -> constr -> identifier list -> tactic
+open Constrexpr
+open Misctypes
 
 val lemInv_clause :
-  quantified_hypothesis -> constr -> identifier list -> tactic
+  quantified_hypothesis -> constr -> Id.t list -> unit Proofview.tactic
 
-val inversion_lemma_from_goal :
-  int -> identifier -> identifier located -> sorts -> bool ->
-    (identifier -> tactic) -> unit
 val add_inversion_lemma_exn :
-  identifier -> constr_expr -> glob_sort -> bool -> (identifier -> tactic) ->
+  Id.t -> constr_expr -> glob_sort -> bool -> (Id.t -> unit Proofview.tactic) ->
     unit
diff --git a/tactics/nbtermdn.ml b/tactics/nbtermdn.ml
deleted file mode 100644
index 6d0f862f..00000000
--- a/tactics/nbtermdn.ml
+++ /dev/null
@@ -1,146 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-open Util
-open Names
-open Term
-open Libobject
-open Library
-open Pattern
-open Libnames
-
-(* Named, bounded-depth, term-discrimination nets.
-   Implementation:
-   Term-patterns are stored in discrimination-nets, which are
-   themselves stored in a hash-table, indexed by the first label.
-   They are also stored by name in a table on-the-side, so that we can
-   override them if needed. *)
-
-(* The former comments are from Chet.
-   See the module dn.ml for further explanations.
-   Eduardo (5/8/97) *)
-module Make = 
-  functor (Y:Map.OrderedType) ->
-struct
-  module X = struct
-    type t = constr_pattern*int
-    let compare = Pervasives.compare
-  end
-
-  module Term_dn = Termdn.Make(Y)
-  open Term_dn
-  module Z = struct 
-     type t = Term_dn.term_label
-     let compare x y =  
-       let make_name n =
-	 match n with
-	 | GRLabel(ConstRef con) -> 
-	     GRLabel(ConstRef(constant_of_kn(canonical_con con)))
-	 | GRLabel(IndRef (kn,i)) ->
-	     GRLabel(IndRef(mind_of_kn(canonical_mind kn),i))
-	 | GRLabel(ConstructRef ((kn,i),j ))->
-	     GRLabel(ConstructRef((mind_of_kn(canonical_mind kn),i),j))
-	 | k -> k
-       in
-	 Pervasives.compare (make_name x) (make_name y)
-  end
-
-  module Dn = Dn.Make(X)(Z)(Y)
-  module Bounded_net = Btermdn.Make(Y)
-
-    
-type 'na t = {
-  mutable table : ('na,constr_pattern * Y.t) Gmap.t;
-  mutable patterns : (Term_dn.term_label option,Bounded_net.t) Gmap.t }
-
-
-type 'na frozen_t = 
-    ('na,constr_pattern * Y.t) Gmap.t
-    * (Term_dn.term_label option, Bounded_net.t) Gmap.t
-
-let create () =
-  { table = Gmap.empty;
-    patterns = Gmap.empty }
-
-let get_dn dnm hkey =
-  try Gmap.find hkey dnm with Not_found -> Bounded_net.create ()
-
-let add dn (na,(pat,valu)) =
-  let hkey = Option.map fst (Term_dn.constr_pat_discr pat) in 
-  dn.table <- Gmap.add na (pat,valu) dn.table;
-  let dnm = dn.patterns in
-  dn.patterns <- Gmap.add hkey (Bounded_net.add None (get_dn dnm hkey) (pat,valu)) dnm
-
-let rmv dn na =
-  let (pat,valu) = Gmap.find na dn.table in
-  let hkey = Option.map fst (Term_dn.constr_pat_discr pat) in 
-  dn.table <- Gmap.remove na dn.table;
-  let dnm = dn.patterns in
-  dn.patterns <- Gmap.add hkey (Bounded_net.rmv None (get_dn dnm hkey) (pat,valu)) dnm
-
-let in_dn dn na = Gmap.mem na dn.table
-
-let remap ndn na (pat,valu) =
-  rmv ndn na;
-  add ndn (na,(pat,valu))
-
-let decomp = 
-  let rec decrec acc c = match kind_of_term c with
-    | App (f,l) -> decrec (Array.fold_right (fun a l -> a::l) l acc) f
-    | Cast (c1,_,_) -> decrec acc c1
-    | _ -> (c,acc)
-  in 
-  decrec []
-
-  let constr_val_discr t =
-  let c, l = decomp t in
-    match kind_of_term c with
-    | Ind ind_sp -> Dn.Label(Term_dn.GRLabel (IndRef ind_sp),l)
-    | Construct cstr_sp -> Dn.Label(Term_dn.GRLabel (ConstructRef cstr_sp),l)
-    | Var id -> Dn.Label(Term_dn.GRLabel (VarRef id),l)
-    | Const _ -> Dn.Everything
-    | _ -> Dn.Nothing
-
-let constr_val_discr_st (idpred,cpred) t =
-  let c, l = decomp t in
-    match kind_of_term c with
-    | Const c -> if Cpred.mem c cpred then Dn.Everything else Dn.Label(Term_dn.GRLabel (ConstRef c),l)
-    | Ind ind_sp -> Dn.Label(Term_dn.GRLabel (IndRef ind_sp),l)
-    | Construct cstr_sp -> Dn.Label(Term_dn.GRLabel (ConstructRef cstr_sp),l)
-    | Var id when not (Idpred.mem id idpred) -> Dn.Label(Term_dn.GRLabel (VarRef id),l)
-    | Prod (n, d, c) -> Dn.Label(Term_dn.ProdLabel, [d; c])
-    | Lambda (n, d, c) -> Dn.Label(Term_dn.LambdaLabel, [d; c] @ l)
-    | Sort _ -> Dn.Label(Term_dn.SortLabel, [])
-    | Evar _ -> Dn.Everything
-    | _ -> Dn.Nothing
-
-let lookup dn valu =
-  let hkey =
-    match (constr_val_discr valu) with
-    | Dn.Label(l,_) -> Some l
-    | _ -> None
-  in
-  try Bounded_net.lookup None (Gmap.find hkey dn.patterns) valu with Not_found -> []
-
-let app f dn = Gmap.iter f dn.table
-
-let dnet_depth = Btermdn.dnet_depth
-
-let freeze dn = (dn.table, dn.patterns)
-
-let unfreeze (fnm,fdnm) dn =
-  dn.table <- fnm;
-  dn.patterns <- fdnm
-
-let empty dn =
-  dn.table <- Gmap.empty;
-  dn.patterns <- Gmap.empty
-
-let to2lists dn =
-  (Gmap.to_list dn.table, Gmap.to_list dn.patterns)
-end
diff --git a/tactics/nbtermdn.mli b/tactics/nbtermdn.mli
deleted file mode 100644
index b15bc922..00000000
--- a/tactics/nbtermdn.mli
+++ /dev/null
@@ -1,47 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-open Term
-open Pattern
-open Libnames
-
-(** Named, bounded-depth, term-discrimination nets. *)
-module Make :
-  functor (Y:Map.OrderedType) ->
-sig
-  
-  module Term_dn : sig     
-    type term_label = 
-      | GRLabel of global_reference
-      | ProdLabel 
-      | LambdaLabel
-      | SortLabel
-  end 
-    
-  type 'na t
-  type 'na frozen_t
-    
-  val create : unit -> 'na t
-    
-  val add : 'na t -> ('na * (constr_pattern * Y.t)) -> unit
-  val rmv : 'na t -> 'na -> unit
-  val in_dn : 'na t -> 'na -> bool
-  val remap : 'na t -> 'na -> (constr_pattern * Y.t) -> unit
-    
-  val lookup : 'na t -> constr -> (constr_pattern * Y.t) list
-  val app : ('na -> (constr_pattern * Y.t) -> unit) -> 'na t -> unit
-    
-  val dnet_depth : int ref
-    
-
-  val freeze : 'na t -> 'na frozen_t
-  val unfreeze : 'na frozen_t -> 'na t -> unit
-  val empty : 'na t -> unit
-  val to2lists : 'na t -> ('na * (constr_pattern * Y.t)) list * 
-    (Term_dn.term_label option * Btermdn.Make(Y).t) list
-end
diff --git a/tactics/refine.ml b/tactics/refine.ml
deleted file mode 100644
index f0a3b352..00000000
--- a/tactics/refine.ml
+++ /dev/null
@@ -1,397 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(* JCF -- 6 janvier 1998  EXPERIMENTAL *)
-
-(*
- *  L'idée est, en quelque sorte, d'avoir de "vraies" métavariables
- *  dans Coq, c'est-à-dire de donner des preuves incomplètes -- mais
- *  où les trous sont typés -- et que les sous-buts correspondants
- *  soient engendrés pour finir la preuve.
- *
- *  Exemple :
- *    J'ai le but
- *        forall (x:nat), { y:nat | (minus y x) = x }
- *    et je donne la preuve incomplète
- *        fun (x:nat) => exist nat [y:nat]((minus y x)=x) (plus x x) ?
- *    ce qui engendre le but
- *        (minus (plus x x) x) = x
- *)
-
-(*  Pour cela, on procède de la manière suivante :
- *
- *  1. Un terme de preuve incomplet est un terme contenant des variables
- *     existentielles Evar i.e. "_" en syntaxe concrète.
- *     La résolution de ces variables n'est plus nécessairement totale
- *     (ise_resolve called with fail_evar=false) et les variables
- *     existentielles restantes sont remplacées par des méta-variables
- *     castées par leur types (celui est connu : soit donné, soit trouvé
- *     pendant la phase de résolution).
- *
- *  2. On met ensuite le terme "à plat" i.e. on n'autorise des MV qu'au
- *     permier niveau et pour chacune d'elles, si nécessaire, on donne
- *     à son tour un terme de preuve incomplet pour la résoudre.
- *     Exemple: le terme (f a _ (fun (x:nat) => e _)) donne
- *         (f a ?1 ?2) avec:
- *           - ?2 := fun (x:nat) => ?3
- *           - ?3 := e ?4
- *         ?1 et ?4 donneront des buts
- *
- *  3. On écrit ensuite une tactique tcc qui engendre les sous-buts
- *     à partir d'une preuve incomplète.
- *)
-
-open Pp
-open Util
-open Names
-open Term
-open Termops
-open Namegen
-open Tacmach
-open Sign
-open Environ
-open Reduction
-open Typing
-open Tactics
-open Tacticals
-open Printer
-
-type term_with_holes = TH of constr * meta_type_map * sg_proofs
-and  sg_proofs       = (term_with_holes option) list
-
-(* pour debugger *)
-
-let rec pp_th (TH(c,mm,sg)) =
-  (str"TH=[ " ++ hov 0 (pr_lconstr c ++ fnl () ++
-			      (* pp_mm mm ++ fnl () ++ *)
-			   pp_sg sg) ++ str "]")
-and pp_mm l =
-  hov 0 (prlist_with_sep (fun _ -> (fnl ()))
-	   (fun (n,c) -> (int n ++ str" --> " ++ pr_lconstr c)) l)
-and pp_sg sg =
-  hov 0 (prlist_with_sep (fun _ -> (fnl ()))
-	   (function None -> (str"None") | Some th -> (pp_th th)) sg)
-
-(*  compute_metamap : constr -> 'a evar_map -> term_with_holes
- *  réalise le 2. ci-dessus
- *
- *  Pour cela, on renvoie une meta_map qui indique pour chaque meta-variable
- *  si elle correspond à un but (None) ou si elle réduite à son tour
- *  par un terme de preuve incomplet (Some c).
- *
- *  On a donc l'INVARIANT suivant : le terme c rendu est "de niveau 1"
- *  -- i.e. à plat -- et la meta_map contient autant d'éléments qu'il y
- *  a de meta-variables dans c. On suppose de plus que l'ordre dans la
- *  meta_map correspond à celui des buts qui seront engendrés par le refine.
- *)
-
-let replace_by_meta env sigma = function
-  | TH (m, mm, sgp) when isMeta (strip_outer_cast m) -> m,mm,sgp
-  | (TH (c,mm,_)) as th ->
-      let n = Evarutil.new_meta() in
-      let m = mkMeta n in
-      (* quand on introduit une mv on calcule son type *)
-      let ty = match kind_of_term c with
-	| Lambda (Name id,c1,c2) when isCast c2 ->
-	    let _,_,t = destCast c2 in mkNamedProd id c1 t
-	| Lambda (Anonymous,c1,c2) when isCast c2 ->
-	    let _,_,t = destCast c2 in mkArrow c1 t
-	| _ -> (* (App _ | Case _) -> *)
-	    let sigma' =
-	      List.fold_right (fun (m,t) sigma -> Evd.meta_declare m t sigma)
-		mm sigma in
-	    Retyping.get_type_of env sigma' c
-	(*
-	| Fix ((_,j),(v,_,_)) ->
-	    v.(j) (* en pleine confiance ! *)
-	| _ -> invalid_arg "Tcc.replace_by_meta (TO DO)"
-        *)
-      in
-      mkCast (m,DEFAULTcast, ty),[n,ty],[Some th]
-
-exception NoMeta
-
-let replace_in_array keep_length env sigma a =
-  if array_for_all (function (TH (_,_,[])) -> true | _ -> false) a then
-    raise NoMeta;
-  let a' = Array.map (function
-			| (TH (c,mm,[])) when not keep_length -> c,mm,[]
-			| th -> replace_by_meta env sigma th) a
-  in
-  let v' = Array.map pi1 a' in
-  let mm = Array.fold_left (@) [] (Array.map pi2 a') in
-  let sgp = Array.fold_left (@) [] (Array.map pi3 a') in
-  v',mm,sgp
-
-let fresh env n =
-  let id = match n with Name x -> x | _ -> id_of_string "_H" in
-  next_ident_away_in_goal id (ids_of_named_context (named_context env))
-
-let rec compute_metamap env sigma c = match kind_of_term c with
-  (* le terme est directement une preuve *)
-  | (Const _ | Evar _ | Ind _ | Construct _ |
-    Sort _ | Var _ | Rel _) ->
-      TH (c,[],[])
-
-  (* le terme est une mv => un but *)
-  | Meta n ->
-      TH (c,[],[None])
-
-  | Cast (m,_, ty) when isMeta m ->
-      TH (c,[destMeta m,ty],[None])
-
-
-  (* abstraction => il faut décomposer si le terme dessous n'est pas pur
-   *    attention : dans ce cas il faut remplacer (Rel 1) par (Var x)
-   *    où x est une variable FRAICHE *)
-  | Lambda (name,c1,c2) ->
-      let v = fresh env name in
-      let env' = push_named (v,None,c1) env in
-      begin match compute_metamap env' sigma (subst1 (mkVar v) c2) with
-	(* terme de preuve complet *)
-	| TH (_,_,[]) -> TH (c,[],[])
-	(* terme de preuve incomplet *)
-	| th ->
-	    let m,mm,sgp = replace_by_meta env' sigma th in
-	    TH (mkLambda (Name v,c1,m), mm, sgp)
-      end
-
-  | LetIn (name, c1, t1, c2) ->
-      let v = fresh env name in
-      let th1 = compute_metamap env sigma c1 in
-      let env' = push_named (v,Some c1,t1) env in
-      let th2 = compute_metamap env' sigma (subst1 (mkVar v) c2) in
-      begin match th1,th2 with
-	(* terme de preuve complet *)
-	| TH (_,_,[]), TH (_,_,[]) -> TH (c,[],[])
-	(* terme de preuve incomplet *)
-	| TH (c1,mm1,sgp1), TH (c2,mm2,sgp2) ->
-	    let m1,mm1,sgp1 =
-              if sgp1=[] then (c1,mm1,[])
-              else replace_by_meta env sigma th1 in
-	    let m2,mm2,sgp2 =
-              if sgp2=[] then (c2,mm2,[])
-              else replace_by_meta env' sigma th2 in
-	    TH (mkNamedLetIn v m1 t1 m2, mm1@mm2, sgp1@sgp2)
-      end
-
-  (* 4. Application *)
-  | App (f,v) ->
-      let a = Array.map (compute_metamap env sigma) (Array.append [|f|] v) in
-      begin
-	try
-	  let v',mm,sgp = replace_in_array false env sigma a in
-          let v'' = Array.sub v' 1 (Array.length v) in
-          TH (mkApp(v'.(0), v''),mm,sgp)
-	with NoMeta ->
-	  TH (c,[],[])
-      end
-
-  | Case (ci,p,cc,v) ->
-      (* bof... *)
-      let nbr = Array.length v in
-      let v = Array.append [|p;cc|] v in
-      let a = Array.map (compute_metamap env sigma) v in
-      begin
-	try
-	  let v',mm,sgp = replace_in_array false env sigma a in
-	  let v'' = Array.sub v' 2 nbr in
-	  TH (mkCase (ci,v'.(0),v'.(1),v''),mm,sgp)
-	with NoMeta ->
-	  TH (c,[],[])
-      end
-
-  (* 5. Fix. *)
-  | Fix ((ni,i),(fi,ai,v)) ->
-      (* TODO: use a fold *)
-      let vi = Array.map (fresh env) fi in
-      let fi' = Array.map (fun id -> Name id) vi in
-      let env' = push_named_rec_types (fi',ai,v) env in
-      let a = Array.map
-		(compute_metamap env' sigma)
-		(Array.map (substl (List.map mkVar (Array.to_list vi))) v)
-      in
-      begin
-	try
-	  let v',mm,sgp = replace_in_array true env' sigma a in
-	  let fix = mkFix ((ni,i),(fi',ai,v')) in
-	  TH (fix,mm,sgp)
-	with NoMeta ->
-	  TH (c,[],[])
-      end
-
-  (* Cast. Est-ce bien exact ? *)
-  | Cast (c,_,t) -> compute_metamap env sigma c
-      (*let TH (c',mm,sgp) = compute_metamap sign c in
-	TH (mkCast (c',t),mm,sgp) *)
-
-  (* Produit. Est-ce bien exact ? *)
-  | Prod (_,_,_) ->
-      if occur_meta c then
-	error "refine: proof term contains metas in a product."
-      else
-      	TH (c,[],[])
-
-  (* Cofix. *)
-  | CoFix (i,(fi,ai,v)) ->
-      let vi = Array.map (fresh env) fi in
-      let fi' = Array.map (fun id -> Name id) vi in
-      let env' = push_named_rec_types (fi',ai,v) env in
-      let a = Array.map
-		(compute_metamap env' sigma)
-		(Array.map (substl (List.map mkVar (Array.to_list vi))) v)
-      in
-      begin
-	try
-	  let v',mm,sgp = replace_in_array true env' sigma a in
-	  let cofix = mkCoFix (i,(fi',ai,v')) in
-	  TH (cofix,mm,sgp)
-	with NoMeta ->
-	  TH (c,[],[])
-      end
-
-
-(*  tcc_aux : term_with_holes -> tactic
- *
- *  Réalise le 3. ci-dessus
- *)
-
-let ensure_products n =
-  let p = ref 0 in
-  let rec aux n gl =
-    if n = 0 then tclFAIL 0 (mt()) gl
-    else
-      tclTHEN
-        (tclORELSE intro (fun gl -> incr p; introf gl))
-        (aux (n-1)) gl in
-  tclORELSE
-    (aux n)
-    (* Now we know how many red are needed *)
-    (fun gl -> tclDO !p red_in_concl gl)
-
-let rec tcc_aux subst (TH (c,mm,sgp) as _th) gl =
-  let c = substl subst c in
-  match (kind_of_term c,sgp) with
-    (* mv => sous-but : on ne fait rien *)
-    | Meta _ , _ ->
-	tclIDTAC gl
-
-    | Cast (c,_,_), _ when isMeta c ->
-	tclIDTAC gl
-
-    (* terme pur => refine *)
-    | _,[] ->
-	refine c gl
-
-    (* abstraction => intro *)
-    | Lambda (Name id,_,m), _ ->
-	assert (isMeta (strip_outer_cast m));
-	begin match sgp with
-	  | [None] -> intro_mustbe_force id gl
-	  | [Some th] ->
-              tclTHEN (introduction id)
-                (onLastHypId (fun id -> tcc_aux (mkVar id::subst) th)) gl
-	  | _ -> assert false
-	end
-
-    | Lambda (Anonymous,_,m), _ -> (* if anon vars are allowed in evars *)
-        assert (isMeta (strip_outer_cast m));
-	begin match sgp with
-	  | [None] -> tclTHEN intro (onLastHypId (fun id -> clear [id])) gl
-	  | [Some th] ->
-              tclTHEN
-                intro
-                (onLastHypId (fun id ->
-                  tclTHEN
-                    (clear [id])
-                    (tcc_aux (mkVar (*dummy*) id::subst) th))) gl
-	  | _ -> assert false
-	end
-
-    (* let in without holes in the body => possibly dependent intro *)
-    | LetIn (Name id,c1,t1,c2), _ when not (isMeta (strip_outer_cast c1)) ->
-	let c = pf_concl gl in
-	let newc = mkNamedLetIn id c1 t1 c in
-	tclTHEN
-	  (change_in_concl None newc)
-	  (match sgp with
-	     | [None] -> introduction id
-	     | [Some th] ->
-                 tclTHEN (introduction id)
-                   (onLastHypId (fun id -> tcc_aux (mkVar id::subst) th))
-	     | _ -> assert false)
-	  gl
-
-    (* let in with holes in the body => unable to handle dependency
-       because of evars limitation, use non dependent assert instead *)
-    | LetIn (Name id,c1,t1,c2), _ ->
-	tclTHENS
-          (assert_tac (Name id) t1)
-	  [(match List.hd sgp with
-	     | None -> tclIDTAC
-	     | Some th -> onLastHypId (fun id -> tcc_aux (mkVar id::subst) th));
-           (match List.tl sgp with
-	     | [] -> refine (subst1 (mkVar id) c2)  (* a complete proof *)
-	     | [None] -> tclIDTAC                   (* a meta *)
-	     | [Some th] ->                         (* a partial proof *)
-                 onLastHypId (fun id -> tcc_aux (mkVar id::subst) th)
-             | _ -> assert false)]
-          gl
-
-    (* fix => tactique Fix *)
-    | Fix ((ni,j),(fi,ai,_)) , _ ->
-	let out_name = function
-	  | Name id -> id
-          | _ -> error "Recursive functions must have names."
-	in
-	let fixes = array_map3 (fun f n c -> (out_name f,succ n,c)) fi ni ai in
-	let firsts,lasts = list_chop j (Array.to_list fixes) in
-	tclTHENS
-	  (tclTHEN
-            (ensure_products (succ ni.(j)))
-            (mutual_fix (out_name fi.(j)) (succ ni.(j)) (firsts@List.tl lasts) j))
-	  (List.map (function
-		       | None -> tclIDTAC
-		       | Some th -> tcc_aux subst th) sgp)
-	  gl
-
-    (* cofix => tactique CoFix *)
-    | CoFix (j,(fi,ai,_)) , _ ->
-	let out_name = function
-	  | Name id -> id
-          | _ -> error "Recursive functions must have names."
-	in
-	let cofixes = array_map2 (fun f c -> (out_name f,c)) fi ai in
-	let firsts,lasts = list_chop j (Array.to_list cofixes) in
-	tclTHENS
-	  (mutual_cofix (out_name fi.(j)) (firsts@List.tl lasts) j)
-	  (List.map (function
-		       | None -> tclIDTAC
-		       | Some th -> tcc_aux subst th) sgp)
-	  gl
-
-    (* sinon on fait refine du terme puis appels rec. sur les sous-buts.
-     * c'est le cas pour App et MutCase. *)
-    | _ ->
-	tclTHENS
-	  (refine c)
-	  (List.map
-            (function None -> tclIDTAC | Some th -> tcc_aux subst th) sgp)
-	  gl
-
-(* Et finalement la tactique refine elle-même : *)
-
-let refine (evd,c) gl =
-  let sigma = project gl in
-  let evd = Typeclasses.resolve_typeclasses ~filter:Typeclasses.no_goals (pf_env gl) evd in
-  let c = Evarutil.nf_evar evd c in
-  let (evd,c) = Evarutil.evars_to_metas sigma (evd,c) in
-  (* Relies on Cast's put on Meta's by evars_to_metas, because it is otherwise
-     complicated to update meta types when passing through a binder *)
-  let th = compute_metamap (pf_env gl) evd c in
-  tclTHEN (Refiner.tclEVARS evd) (tcc_aux [] th) gl
diff --git a/tactics/rewrite.ml b/tactics/rewrite.ml
new file mode 100644
index 00000000..a3914da1
--- /dev/null
+++ b/tactics/rewrite.ml
@@ -0,0 +1,2099 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i camlp4deps: "grammar/grammar.cma" i*)
+
+open Names
+open Pp
+open Errors
+open Util
+open Nameops
+open Namegen
+open Term
+open Vars
+open Reduction
+open Tacticals
+open Tacmach
+open Tactics
+open Pretype_errors
+open Typeclasses
+open Classes
+open Constrexpr
+open Globnames
+open Evd
+open Misctypes
+open Locus
+open Locusops
+open Decl_kinds
+open Elimschemes
+open Environ
+open Termops
+open Libnames
+
+(** Typeclass-based generalized rewriting. *)
+
+(** Constants used by the tactic. *)
+
+let classes_dirpath =
+  Names.DirPath.make (List.map Id.of_string ["Classes";"Coq"])
+
+let init_setoid () =
+  if is_dirpath_prefix_of classes_dirpath (Lib.cwd ()) then ()
+  else Coqlib.check_required_library ["Coq";"Setoids";"Setoid"]
+
+let make_dir l = DirPath.make (List.rev_map Id.of_string l)
+
+let try_find_global_reference dir s =
+  let sp = Libnames.make_path (make_dir ("Coq"::dir)) (Id.of_string s) in
+    try Nametab.global_of_path sp
+    with Not_found -> 
+      anomaly (str ("Global reference " ^ s ^ " not found in generalized rewriting"))
+
+let find_reference dir s =
+  let gr = lazy (try_find_global_reference dir s) in
+    fun () -> Lazy.force gr
+
+type evars = evar_map * Evar.Set.t (* goal evars, constraint evars *)
+
+let find_global dir s =
+  let gr = lazy (try_find_global_reference dir s) in
+    fun (evd,cstrs) -> 
+      let evd, c = Evarutil.new_global evd (Lazy.force gr) in
+	(evd, cstrs), c
+
+(** Utility for dealing with polymorphic applications *)
+
+(** Global constants. *)
+
+let coq_eq_ref = find_reference ["Init"; "Logic"] "eq"
+let coq_eq = find_global ["Init"; "Logic"] "eq"
+let coq_f_equal = find_global ["Init"; "Logic"] "f_equal"
+let coq_all = find_global ["Init"; "Logic"] "all"
+let impl = find_global ["Program"; "Basics"] "impl"
+
+(* let coq_inverse = lazy (gen_constant ["Program"; "Basics"] "flip") *)
+
+(* let inverse car rel = mkApp (Lazy.force coq_inverse, [| car ; car; mkProp; rel |]) *)
+
+(* let forall_relation = lazy (gen_constant ["Classes"; "Morphisms"] "forall_relation") *)
+(* let pointwise_relation = lazy (gen_constant ["Classes"; "Morphisms"] "pointwise_relation") *)
+(* let respectful = lazy (gen_constant ["Classes"; "Morphisms"] "respectful") *)
+(* let default_relation = lazy (gen_constant ["Classes"; "SetoidTactics"] "DefaultRelation") *)
+(* let subrelation = lazy (gen_constant ["Classes"; "RelationClasses"] "subrelation") *)
+(* let do_subrelation = lazy (gen_constant ["Classes"; "Morphisms"] "do_subrelation") *)
+(* let apply_subrelation = lazy (gen_constant ["Classes"; "Morphisms"] "apply_subrelation") *)
+(* let coq_relation = lazy (gen_constant ["Relations";"Relation_Definitions"] "relation") *)
+(* let mk_relation a = mkApp (Lazy.force coq_relation, [| a |]) *)
+
+(* let proper_type = lazy (Universes.constr_of_global (Lazy.force proper_class).cl_impl) *)
+(* let proper_proxy_type = lazy (Universes.constr_of_global (Lazy.force proper_proxy_class).cl_impl) *)
+
+
+
+(** Bookkeeping which evars are constraints so that we can 
+    remove them at the end of the tactic. *)
+
+let goalevars evars = fst evars
+let cstrevars evars = snd evars
+
+let new_cstr_evar (evd,cstrs) env t =
+  let s = Typeclasses.set_resolvable Evd.Store.empty false in
+  let evd', t = Evarutil.new_evar ~store:s env evd t in
+  let ev, _ = destEvar t in
+    (evd', Evar.Set.add ev cstrs), t
+
+(** Building or looking up instances. *)
+let e_new_cstr_evar env evars t =
+  let evd', t = new_cstr_evar !evars env t in evars := evd'; t
+
+(** Building or looking up instances. *)
+
+let extends_undefined evars evars' =
+  let f ev evi found = found || not (Evd.mem evars ev)
+  in fold_undefined f evars' false
+
+let app_poly_check env evars f args =
+  let (evars, cstrs), fc = f evars in
+  let evdref = ref evars in 
+  let t = Typing.solve_evars env evdref (mkApp (fc, args)) in
+    (!evdref, cstrs), t
+
+let app_poly_nocheck env evars f args =
+  let evars, fc = f evars in 
+    evars, mkApp (fc, args)
+
+let app_poly_sort b =
+  if b then app_poly_nocheck
+  else app_poly_check
+    
+let find_class_proof proof_type proof_method env evars carrier relation =
+  try
+    let evars, goal = app_poly_check env evars proof_type [| carrier ; relation |] in
+    let evars', c = Typeclasses.resolve_one_typeclass env (goalevars evars) goal in
+      if extends_undefined (goalevars evars) evars' then raise Not_found
+      else app_poly_check env (evars',cstrevars evars) proof_method [| carrier; relation; c |]
+  with e when Logic.catchable_exception e -> raise Not_found
+ 
+(** Utility functions *)
+
+module GlobalBindings (M : sig
+  val relation_classes : string list
+  val morphisms : string list
+  val relation : string list * string
+  val app_poly : env -> evars -> (evars -> evars * constr) -> constr array -> evars * constr
+  val arrow : evars -> evars * constr
+end) = struct
+  open M
+  let relation : evars -> evars * constr = find_global (fst relation) (snd relation)
+
+  let reflexive_type = find_global relation_classes "Reflexive"
+  let reflexive_proof = find_global relation_classes "reflexivity"
+    
+  let symmetric_type = find_global relation_classes "Symmetric"
+  let symmetric_proof = find_global relation_classes "symmetry"
+
+  let transitive_type = find_global relation_classes "Transitive"
+  let transitive_proof = find_global relation_classes "transitivity"
+
+  let forall_relation = find_global morphisms "forall_relation"
+  let pointwise_relation = find_global morphisms "pointwise_relation"
+
+  let forall_relation_ref = find_reference morphisms "forall_relation"
+  let pointwise_relation_ref = find_reference morphisms "pointwise_relation"
+
+  let respectful = find_global morphisms "respectful"
+  let respectful_ref = find_reference morphisms "respectful"
+
+  let default_relation = find_global ["Classes"; "SetoidTactics"] "DefaultRelation"
+
+  let coq_forall = find_global morphisms "forall_def"
+
+  let subrelation = find_global relation_classes "subrelation"
+  let do_subrelation = find_global morphisms "do_subrelation"
+  let apply_subrelation = find_global morphisms "apply_subrelation"
+
+  let rewrite_relation_class = find_global relation_classes "RewriteRelation"
+
+  let proper_class = lazy (class_info (try_find_global_reference morphisms "Proper"))
+  let proper_proxy_class = lazy (class_info (try_find_global_reference morphisms "ProperProxy"))
+    
+  let proper_proj = lazy (mkConst (Option.get (pi3 (List.hd (Lazy.force proper_class).cl_projs))))
+    
+  let proper_type = 
+    let l = lazy (Lazy.force proper_class).cl_impl in
+      fun (evd,cstrs) -> 
+	let evd, c = Evarutil.new_global evd (Lazy.force l) in
+	  (evd, cstrs), c
+	
+  let proper_proxy_type = 
+    let l = lazy (Lazy.force proper_proxy_class).cl_impl in
+      fun (evd,cstrs) -> 
+	let evd, c = Evarutil.new_global evd (Lazy.force l) in
+	  (evd, cstrs), c
+
+  let proper_proof env evars carrier relation x =
+    let evars, goal = app_poly env evars proper_proxy_type [| carrier ; relation; x |] in
+      new_cstr_evar evars env goal
+
+  let get_reflexive_proof env = find_class_proof reflexive_type reflexive_proof env
+  let get_symmetric_proof env = find_class_proof symmetric_type symmetric_proof env
+  let get_transitive_proof env = find_class_proof transitive_type transitive_proof env
+
+  let mk_relation env evd a = 
+    app_poly env evd relation [| a |]
+
+  (** Build an infered signature from constraints on the arguments and expected output
+      relation *)
+    
+  let build_signature evars env m (cstrs : (types * types option) option list)
+      (finalcstr : (types * types option) option) =
+    let mk_relty evars newenv ty obj =
+      match obj with
+      | None | Some (_, None) ->
+	let evars, relty = mk_relation env evars ty in
+	  if closed0 ty then 
+	    let env' = Environ.reset_with_named_context (Environ.named_context_val env) env in
+	      new_cstr_evar evars env' relty
+	  else new_cstr_evar evars newenv relty
+      | Some (x, Some rel) -> evars, rel
+    in
+    let rec aux env evars ty l =
+      let t = Reductionops.whd_betadeltaiota env (goalevars evars) ty in
+	match kind_of_term t, l with
+	| Prod (na, ty, b), obj :: cstrs ->
+	  if noccurn 1 b (* non-dependent product *) then
+	    let ty = Reductionops.nf_betaiota (goalevars evars) ty in
+	    let (evars, b', arg, cstrs) = aux env evars (subst1 mkProp b) cstrs in
+	    let evars, relty = mk_relty evars env ty obj in
+	    let evars, newarg = app_poly env evars respectful [| ty ; b' ; relty ; arg |] in
+	      evars, mkProd(na, ty, b), newarg, (ty, Some relty) :: cstrs
+	  else
+	    let (evars, b, arg, cstrs) = 
+	      aux (Environ.push_rel (na, None, ty) env) evars b cstrs 
+	    in
+	    let ty = Reductionops.nf_betaiota (goalevars evars) ty in
+	    let pred = mkLambda (na, ty, b) in
+	    let liftarg = mkLambda (na, ty, arg) in
+	    let evars, arg' = app_poly env evars forall_relation [| ty ; pred ; liftarg |] in
+	      if Option.is_empty obj then evars, mkProd(na, ty, b), arg', (ty, None) :: cstrs
+	      else error "build_signature: no constraint can apply on a dependent argument"
+	| _, obj :: _ -> anomaly ~label:"build_signature" (Pp.str "not enough products")
+	| _, [] ->
+	  (match finalcstr with
+	  | None | Some (_, None) ->
+	    let t = Reductionops.nf_betaiota (fst evars) ty in
+	    let evars, rel = mk_relty evars env t None in
+	      evars, t, rel, [t, Some rel]
+	  | Some (t, Some rel) -> evars, t, rel, [t, Some rel])
+    in aux env evars m cstrs
+
+  (** Folding/unfolding of the tactic constants. *)
+
+  let unfold_impl t =
+    match kind_of_term t with
+    | App (arrow, [| a; b |])(*  when eq_constr arrow (Lazy.force impl) *) ->
+      mkProd (Anonymous, a, lift 1 b)
+    | _ -> assert false
+
+  let unfold_all t =
+    match kind_of_term t with
+    | App (id, [| a; b |]) (* when eq_constr id (Lazy.force coq_all) *) ->
+      (match kind_of_term b with
+      | Lambda (n, ty, b) -> mkProd (n, ty, b)
+      | _ -> assert false)
+    | _ -> assert false
+
+  let unfold_forall t =
+    match kind_of_term t with
+    | App (id, [| a; b |]) (* when eq_constr id (Lazy.force coq_all) *) ->
+      (match kind_of_term b with
+      | Lambda (n, ty, b) -> mkProd (n, ty, b)
+      | _ -> assert false)
+    | _ -> assert false
+
+  let arrow_morphism env evd ta tb a b =
+    let ap = is_Prop ta and bp = is_Prop tb in
+      if ap && bp then app_poly env evd impl [| a; b |], unfold_impl
+      else if ap then (* Domain in Prop, CoDomain in Type *)
+	(app_poly env evd arrow [| a; b |]), unfold_impl
+	(* (evd, mkProd (Anonymous, a, b)), (fun x -> x) *)
+      else if bp then (* Dummy forall *)
+	(app_poly env evd coq_all [| a; mkLambda (Anonymous, a, b) |]), unfold_forall
+      else (* None in Prop, use arrow *)
+	(app_poly env evd arrow [| a; b |]), unfold_impl
+
+  let rec decomp_pointwise n c =
+    if Int.equal n 0 then c
+    else
+      match kind_of_term c with
+      | App (f, [| a; b; relb |]) when Globnames.is_global (pointwise_relation_ref ()) f ->
+	decomp_pointwise (pred n) relb
+      | App (f, [| a; b; arelb |]) when Globnames.is_global (forall_relation_ref ()) f ->
+	decomp_pointwise (pred n) (Reductionops.beta_applist (arelb, [mkRel 1]))
+      | _ -> invalid_arg "decomp_pointwise"
+
+  let rec apply_pointwise rel = function
+    | arg :: args ->
+      (match kind_of_term rel with
+      | App (f, [| a; b; relb |]) when Globnames.is_global (pointwise_relation_ref ()) f ->
+	apply_pointwise relb args
+      | App (f, [| a; b; arelb |]) when Globnames.is_global (forall_relation_ref ()) f ->
+	apply_pointwise (Reductionops.beta_applist (arelb, [arg])) args
+      | _ -> invalid_arg "apply_pointwise")
+    | [] -> rel
+
+  let pointwise_or_dep_relation env evd n t car rel =
+    if noccurn 1 car && noccurn 1 rel then
+      app_poly env evd pointwise_relation [| t; lift (-1) car; lift (-1) rel |]
+    else
+      app_poly env evd forall_relation
+	[| t; mkLambda (n, t, car); mkLambda (n, t, rel) |]
+
+  let lift_cstr env evars (args : constr list) c ty cstr =
+    let start evars env car =
+      match cstr with
+      | None | Some (_, None) -> 
+	let evars, rel = mk_relation env evars car in
+	  new_cstr_evar evars env rel
+      | Some (ty, Some rel) -> evars, rel
+    in
+    let rec aux evars env prod n = 
+      if Int.equal n 0 then start evars env prod
+      else
+	match kind_of_term (Reduction.whd_betadeltaiota env prod) with
+	| Prod (na, ty, b) ->
+	  if noccurn 1 b then
+	    let b' = lift (-1) b in
+	    let evars, rb = aux evars env b' (pred n) in
+	      app_poly env evars pointwise_relation [| ty; b'; rb |]
+	  else
+	    let evars, rb = aux evars (Environ.push_rel (na, None, ty) env) b (pred n) in
+	      app_poly env evars forall_relation
+		[| ty; mkLambda (na, ty, b); mkLambda (na, ty, rb) |]
+	| _ -> raise Not_found
+    in 
+    let rec find env c ty = function
+      | [] -> None
+      | arg :: args ->
+	try let evars, found = aux evars env ty (succ (List.length args)) in
+	      Some (evars, found, c, ty, arg :: args)
+	with Not_found ->
+	  let ty = whd_betadeltaiota env ty in
+	  find env (mkApp (c, [| arg |])) (prod_applist ty [arg]) args
+    in find env c ty args
+
+  let unlift_cstr env sigma = function
+    | None -> None
+    | Some codom -> Some (decomp_pointwise 1 codom)
+
+  (** Looking up declared rewrite relations (instances of [RewriteRelation]) *)
+  let is_applied_rewrite_relation env sigma rels t =
+    match kind_of_term t with
+    | App (c, args) when Array.length args >= 2 ->
+      let head = if isApp c then fst (destApp c) else c in
+	if Globnames.is_global (coq_eq_ref ()) head then None
+	else
+	  (try
+	   let params, args = Array.chop (Array.length args - 2) args in
+	   let env' = Environ.push_rel_context rels env in
+	   let evars, (evar, _) = Evarutil.new_type_evar env' sigma Evd.univ_flexible in
+	   let evars, inst = 
+	     app_poly env (evars,Evar.Set.empty)
+	       rewrite_relation_class [| evar; mkApp (c, params) |] in
+	   let _ = Typeclasses.resolve_one_typeclass env' (goalevars evars) inst in
+	     Some (it_mkProd_or_LetIn t rels)
+	   with e when Errors.noncritical e -> None)
+  | _ -> None
+
+
+end
+
+(* let my_type_of env evars c = Typing.e_type_of env evars c *)
+(* let mytypeofkey = Profile.declare_profile "my_type_of";; *)
+(* let my_type_of = Profile.profile3 mytypeofkey my_type_of *)
+
+
+let type_app_poly env env evd f args =
+  let evars, c = app_poly_nocheck env evd f args in
+  let evd', t = Typing.e_type_of env (goalevars evars) c in
+    (evd', cstrevars evars), c
+
+module PropGlobal = struct
+  module Consts =
+  struct 
+    let relation_classes = ["Classes"; "RelationClasses"]
+    let morphisms = ["Classes"; "Morphisms"]
+    let relation = ["Relations";"Relation_Definitions"], "relation"
+    let app_poly = app_poly_nocheck
+    let arrow = find_global ["Program"; "Basics"] "arrow"
+    let coq_inverse = find_global ["Program"; "Basics"] "flip"
+  end
+
+  module G = GlobalBindings(Consts)
+
+  include G
+  include Consts
+  let inverse env evd car rel = 
+    type_app_poly env env evd coq_inverse [| car ; car; mkProp; rel |]
+      (* app_poly env evd coq_inverse [| car ; car; mkProp; rel |] *)
+
+end
+
+module TypeGlobal = struct
+  module Consts = 
+    struct 
+      let relation_classes = ["Classes"; "CRelationClasses"]
+      let morphisms = ["Classes"; "CMorphisms"]
+      let relation = relation_classes, "crelation"
+      let app_poly = app_poly_check
+      let arrow = find_global ["Classes"; "CRelationClasses"] "arrow"
+      let coq_inverse = find_global ["Classes"; "CRelationClasses"] "flip"
+    end
+
+  module G = GlobalBindings(Consts)
+  include G
+  include Consts
+
+
+  let inverse env (evd,cstrs) car rel = 
+    let evd, (sort,_) = Evarutil.new_type_evar env evd Evd.univ_flexible in
+      app_poly_check env (evd,cstrs) coq_inverse [| car ; car; sort; rel |]
+
+end
+
+let sort_of_rel env evm rel =
+  Reductionops.sort_of_arity env evm (Retyping.get_type_of env evm rel)
+
+let is_applied_rewrite_relation = PropGlobal.is_applied_rewrite_relation
+
+(* let _ = *)
+(*   Hook.set Equality.is_applied_rewrite_relation is_applied_rewrite_relation *)
+
+let split_head = function
+    hd :: tl -> hd, tl
+  | [] -> assert(false)
+
+let evd_convertible env evd x y =
+  try
+    let evd = Evarconv.the_conv_x env x y evd in
+    (* Unfortunately, the_conv_x might say they are unifiable even if some
+        unsolvable constraints remain, so we check them here *)
+    let evd = Evarconv.consider_remaining_unif_problems env evd in
+    let () = Evarconv.check_problems_are_solved env evd in
+    Some evd
+  with e when Errors.noncritical e -> None
+
+let convertible env evd x y =
+  Reductionops.is_conv_leq env evd x y
+
+type hypinfo = {
+  env : env;
+  prf : constr;
+  car : constr;
+  rel : constr;
+  sort : bool; (* true = Prop; false = Type *)
+  c1 : constr;
+  c2 : constr;
+  holes : Clenv.hole list;
+}
+
+let get_symmetric_proof b = 
+  if b then PropGlobal.get_symmetric_proof else TypeGlobal.get_symmetric_proof
+
+let rec decompose_app_rel env evd t = 
+  (** Head normalize for compatibility with the old meta mechanism *)
+  let t = Reductionops.whd_betaiota evd t in
+  match kind_of_term t with
+  | App (f, [||]) -> assert false
+  | App (f, [|arg|]) ->
+    let (f', argl, argr) = decompose_app_rel env evd arg in
+    let ty = Typing.type_of env evd argl in
+    let f'' = mkLambda (Name default_dependent_ident, ty,
+      mkLambda (Name (Id.of_string "y"), lift 1 ty,
+        mkApp (lift 2 f, [| mkApp (lift 2 f', [| mkRel 2; mkRel 1 |]) |])))
+    in (f'', argl, argr)
+  | App (f, args) ->
+    let len = Array.length args in
+    let fargs = Array.sub args 0 (Array.length args - 2) in
+    mkApp (f, fargs), args.(len - 2), args.(len - 1)
+  | _ -> error "Cannot find a relation to rewrite."
+
+let decompose_applied_relation env sigma (c,l) =
+  let ctype = Retyping.get_type_of env sigma c in
+  let find_rel ty =
+    let sigma, cl = Clenv.make_evar_clause env sigma ty in
+    let sigma = Clenv.solve_evar_clause env sigma true cl l in
+    let { Clenv.cl_holes = holes; Clenv.cl_concl = t } = cl in
+    let (equiv, c1, c2) = decompose_app_rel env sigma t in
+    let ty1 = Retyping.get_type_of env sigma c1 in
+    let ty2 = Retyping.get_type_of env sigma c2 in
+    match evd_convertible env sigma ty1 ty2 with
+    | None -> None
+    | Some sigma ->
+      let sort = sort_of_rel env sigma equiv in
+      let args = Array.map_of_list (fun h -> h.Clenv.hole_evar) holes in
+      let value = mkApp (c, args) in
+        Some (sigma, { env=env; prf=value;
+                car=ty1; rel = equiv; sort = Sorts.is_prop sort;
+                c1=c1; c2=c2; holes })
+  in
+    match find_rel ctype with
+    | Some c -> c
+    | None ->
+	let ctx,t' = Reductionops.splay_prod env sigma ctype in (* Search for underlying eq *)
+	match find_rel (it_mkProd_or_LetIn t' (List.map (fun (n,t) -> n, None, t) ctx)) with
+	| Some c -> c
+	| None -> error "Cannot find an homogeneous relation to rewrite."
+
+let decompose_applied_relation_expr env sigma (is, (c,l)) =
+  let sigma, cbl = Tacinterp.interp_open_constr_with_bindings is env sigma (c,l) in
+  decompose_applied_relation env sigma cbl
+
+let rewrite_db = "rewrite"
+
+let conv_transparent_state = (Id.Pred.empty, Cpred.full)
+
+let _ = 
+  Hints.add_hints_init
+    (fun () ->
+       Hints.create_hint_db false rewrite_db conv_transparent_state true)
+
+let rewrite_transparent_state () =
+  Hints.Hint_db.transparent_state (Hints.searchtable_map rewrite_db)
+
+let rewrite_core_unif_flags = {
+  Unification.modulo_conv_on_closed_terms = None;
+  Unification.use_metas_eagerly_in_conv_on_closed_terms = true;
+  Unification.use_evars_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.use_pattern_unification = true;
+  Unification.use_meta_bound_pattern_unification = true;
+  Unification.frozen_evars = Evar.Set.empty;
+  Unification.restrict_conv_on_strict_subterms = false;
+  Unification.modulo_betaiota = false;
+  Unification.modulo_eta = true;
+}
+
+(* Flags used for the setoid variant of "rewrite" and for the strategies
+   "hints"/"old_hints"/"terms" of "rewrite_strat", and for solving pre-existing
+   evars in "rewrite" (see unify_abs) *)
+let rewrite_unif_flags =
+  let flags = rewrite_core_unif_flags in {
+  Unification.core_unify_flags = flags;
+  Unification.merge_unify_flags = flags;
+  Unification.subterm_unify_flags = flags;
+  Unification.allow_K_in_toplevel_higher_order_unification = true;
+  Unification.resolve_evars = true
+  }
+
+let rewrite_core_conv_unif_flags = {
+  rewrite_core_unif_flags with
+    Unification.modulo_conv_on_closed_terms = Some conv_transparent_state;
+    Unification.modulo_delta_types = conv_transparent_state;
+    Unification.modulo_betaiota = true
+}
+
+(* Fallback flags for the setoid variant of "rewrite" *)
+let rewrite_conv_unif_flags =
+  let flags = rewrite_core_conv_unif_flags in {
+  Unification.core_unify_flags = flags;
+  Unification.merge_unify_flags = flags;
+  Unification.subterm_unify_flags = flags;
+  Unification.allow_K_in_toplevel_higher_order_unification = true;
+  Unification.resolve_evars = true
+  }
+
+(* Flags for "setoid_rewrite c"/"rewrite_strat -> c" *)
+let general_rewrite_unif_flags () =
+  let ts = rewrite_transparent_state () in
+  let core_flags =
+    { rewrite_core_unif_flags with
+      Unification.modulo_conv_on_closed_terms = Some ts;
+      Unification.use_evars_eagerly_in_conv_on_closed_terms = false;
+      Unification.modulo_delta = ts;
+      Unification.modulo_delta_types = ts;
+      Unification.modulo_betaiota = true }
+  in {
+    Unification.core_unify_flags = core_flags;
+    Unification.merge_unify_flags = core_flags;
+    Unification.subterm_unify_flags = { core_flags with Unification.modulo_delta = empty_transparent_state };
+    Unification.allow_K_in_toplevel_higher_order_unification = true;
+    Unification.resolve_evars = true
+  }
+
+let refresh_hypinfo env sigma hypinfo c =
+  let sigma, hypinfo = match hypinfo with
+  | None ->
+    decompose_applied_relation_expr env sigma c
+  | Some hypinfo ->
+    if hypinfo.env != env then
+      (* If the lemma actually generates existential variables, we cannot 
+          use it here as it will polute the evar map with existential variables
+          that might not ever get instantiated (e.g. if we rewrite under a
+          binder and need to refresh [c] again) *)
+      (* TODO: remove bindings in sigma corresponding to c *)
+      decompose_applied_relation_expr env sigma c
+    else sigma, hypinfo
+  in
+  let { c1; c2; car; rel; prf; sort; holes } = hypinfo in
+  sigma, (car, rel, prf, c1, c2, holes, sort)
+
+
+(** FIXME: write this in the new monad interface *)
+let solve_remaining_by env sigma holes by =
+  match by with
+  | None -> sigma
+  | Some tac ->
+    let map h =
+      if h.Clenv.hole_deps then None
+      else
+        let (evk, _) = destEvar (h.Clenv.hole_evar) in
+        Some evk
+    in
+    (** Only solve independent holes *)
+    let indep = List.map_filter map holes in
+    let solve_tac = Tacticals.New.tclCOMPLETE (Tacinterp.eval_tactic tac) in
+    let solve sigma evk =
+      let evi =
+        try Some (Evd.find_undefined sigma evk)
+        with Not_found -> None
+      in
+      match evi with
+      | None -> sigma
+        (** Evar should not be defined, but just in case *)
+      | Some evi ->
+        let ctx = Evd.evar_universe_context sigma in
+        let env = Environ.reset_with_named_context evi.evar_hyps env in
+        let ty = evi.evar_concl in
+        let c, _, ctx = Pfedit.build_by_tactic env ctx ty solve_tac in
+        let sigma = Evd.set_universe_context sigma ctx in
+        Evd.define evk c sigma
+    in
+    List.fold_left solve sigma indep
+
+let no_constraints cstrs = 
+  fun ev _ -> not (Evar.Set.mem ev cstrs)
+
+let all_constraints cstrs = 
+  fun ev _ -> Evar.Set.mem ev cstrs
+
+let poly_inverse sort =
+  if sort then PropGlobal.inverse else TypeGlobal.inverse
+
+type rewrite_proof = 
+  | RewPrf of constr * constr
+  | RewCast of cast_kind
+
+type rewrite_result_info = {
+  rew_car : constr;
+  rew_from : constr;
+  rew_to : constr;
+  rew_prf : rewrite_proof;
+  rew_evars : evars;
+}
+
+type rewrite_result =
+| Fail
+| Identity
+| Success of rewrite_result_info
+
+type 'a pure_strategy = 'a -> Environ.env -> Id.t list -> constr -> types ->
+  (bool (* prop *) * constr option) -> evars -> 
+    'a * rewrite_result
+
+type strategy = unit pure_strategy
+
+let symmetry env sort rew =
+  let { rew_evars = evars; rew_car = car; } = rew in
+  let (rew_evars, rew_prf) = match rew.rew_prf with
+  | RewCast _ -> (rew.rew_evars, rew.rew_prf)
+  | RewPrf (rel, prf) ->
+    try
+      let evars, symprf = get_symmetric_proof sort env evars car rel in
+      let prf = mkApp (symprf, [| rew.rew_from ; rew.rew_to ; prf |]) in
+      (evars, RewPrf (rel, prf))
+    with Not_found ->
+      let evars, rel = poly_inverse sort env evars car rel in
+      (evars, RewPrf (rel, prf))
+  in
+  { rew with rew_from = rew.rew_to; rew_to = rew.rew_from; rew_prf; rew_evars; }
+
+(* Matching/unifying the rewriting rule against [t] *)
+let unify_eqn (car, rel, prf, c1, c2, holes, sort) l2r flags env (sigma, cstrs) by t =
+  try
+    let left = if l2r then c1 else c2 in
+    let sigma = Unification.w_unify ~flags env sigma CONV left t in
+    let sigma = Typeclasses.resolve_typeclasses ~filter:(no_constraints cstrs)
+      ~fail:true env sigma in
+    let evd = solve_remaining_by env sigma holes by in
+    let nf c = Evarutil.nf_evar evd (Reductionops.nf_meta evd c) in
+    let c1 = nf c1 and c2 = nf c2
+    and rew_car = nf car and rel = nf rel
+    and prf = nf prf in
+    let ty1 = Retyping.get_type_of env evd c1 in
+    let ty2 = Retyping.get_type_of env evd c2 in
+    let () = if not (convertible env evd ty2 ty1) then raise Reduction.NotConvertible in
+    let rew_evars = evd, cstrs in
+    let rew_prf = RewPrf (rel, prf) in
+    let rew = { rew_evars; rew_prf; rew_car; rew_from = c1; rew_to = c2; } in
+    let rew = if l2r then rew else symmetry env sort rew in
+    Some rew
+  with 
+  | e when Class_tactics.catchable e -> None
+  | Reduction.NotConvertible -> None
+
+let unify_abs (car, rel, prf, c1, c2) l2r sort env (sigma, cstrs) t =
+  try
+    let left = if l2r then c1 else c2 in
+    (* The pattern is already instantiated, so the next w_unify is
+       basically an eq_constr, except when preexisting evars occur in
+       either the lemma or the goal, in which case the eq_constr also
+       solved this evars *)
+    let sigma = Unification.w_unify ~flags:rewrite_unif_flags env sigma CONV left t in
+    let rew_evars = sigma, cstrs in
+    let rew_prf = RewPrf (rel, prf) in
+    let rew = { rew_car = car; rew_from = c1; rew_to = c2; rew_prf; rew_evars; } in
+    let rew = if l2r then rew else symmetry env sort rew in
+    Some ((), rew)
+  with 
+  | e when Class_tactics.catchable e -> None
+  | Reduction.NotConvertible -> None
+
+type rewrite_flags = { under_lambdas : bool; on_morphisms : bool }
+
+let default_flags = { under_lambdas = true; on_morphisms = true; }
+
+let get_opt_rew_rel = function RewPrf (rel, prf) -> Some rel | _ -> None
+
+let make_eq () =
+(*FIXME*) Universes.constr_of_global (Coqlib.build_coq_eq ())
+let make_eq_refl () =
+(*FIXME*) Universes.constr_of_global (Coqlib.build_coq_eq_refl ())
+
+let get_rew_prf r = match r.rew_prf with
+  | RewPrf (rel, prf) -> rel, prf 
+  | RewCast c ->
+    let rel = mkApp (make_eq (), [| r.rew_car |]) in
+      rel, mkCast (mkApp (make_eq_refl (), [| r.rew_car; r.rew_from |]),
+		   c, mkApp (rel, [| r.rew_from; r.rew_to |]))
+
+let poly_subrelation sort = 
+  if sort then PropGlobal.subrelation else TypeGlobal.subrelation
+
+let resolve_subrelation env avoid car rel sort prf rel' res =
+  if eq_constr rel rel' then res
+  else
+    let evars, app = app_poly_check env res.rew_evars (poly_subrelation sort) [|car; rel; rel'|] in
+    let evars, subrel = new_cstr_evar evars env app in
+    let appsub = mkApp (subrel, [| res.rew_from ; res.rew_to ; prf |]) in
+      { res with
+	rew_prf = RewPrf (rel', appsub);
+	rew_evars = evars }
+
+let resolve_morphism env avoid oldt m ?(fnewt=fun x -> x) args args' (b,cstr) evars =
+  let evars, morph_instance, proj, sigargs, m', args, args' =
+    let first = match (Array.findi (fun _ b -> not (Option.is_empty b)) args') with
+    | Some i -> i
+    | None -> invalid_arg "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 (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 = 
+      if b then PropGlobal.build_signature evars env appmtype cstrs cstr
+      else TypeGlobal.build_signature evars env appmtype cstrs cstr
+    in
+      (* Actual signature found *)
+    let cl_args = [| appmtype' ; signature ; appm |] in
+    let evars, app = app_poly_sort b env evars (if b then PropGlobal.proper_type else TypeGlobal.proper_type)
+      cl_args in
+    let env' = 
+      let dosub, appsub = 
+	if b then PropGlobal.do_subrelation, PropGlobal.apply_subrelation 
+	else TypeGlobal.do_subrelation, TypeGlobal.apply_subrelation
+      in
+	Environ.push_named
+	  (Id.of_string "do_subrelation", 
+	   Some (snd (app_poly_sort b env evars dosub [||])), 
+	   snd (app_poly_nocheck env evars appsub [||]))
+	  env
+    in
+    let evars, morph = new_cstr_evar evars env' app in
+      evars, morph, morph, sigargs, appm, morphobjs, morphobjs'
+  in
+  let projargs, subst, evars, respars, typeargs =
+    Array.fold_left2
+      (fun (acc, subst, evars, sigargs, typeargs') x y ->
+	let (carrier, relation), sigargs = split_head sigargs in
+	  match relation with
+	  | Some relation ->
+	      let carrier = substl subst carrier
+	      and relation = substl subst relation in
+	      (match y with
+	      | None ->
+		  let evars, proof = 
+		    (if b then PropGlobal.proper_proof else TypeGlobal.proper_proof) 
+		      env evars carrier relation x in
+		    [ proof ; x ; x ] @ acc, subst, evars, sigargs, x :: typeargs'
+	      | Some r ->
+		  [ snd (get_rew_prf r); r.rew_to; x ] @ acc, subst, evars, 
+	      sigargs, r.rew_to :: typeargs')
+	  | None ->
+	      if not (Option.is_empty y) then 
+		error "Cannot rewrite inside dependent arguments of a function";
+	      x :: acc, x :: subst, evars, sigargs, x :: typeargs')
+      ([], [], evars, sigargs, []) args args'
+  in
+  let proof = applistc proj (List.rev projargs) in
+  let newt = applistc m' (List.rev typeargs) in
+    match respars with
+	[ a, Some r ] -> evars, proof, substl subst a, substl subst r, oldt, fnewt newt
+      | _ -> assert(false)
+
+let apply_constraint env avoid car rel prf cstr res =
+  match snd cstr with
+  | None -> res
+  | Some r -> resolve_subrelation env avoid car rel (fst cstr) prf r res
+
+let coerce env avoid cstr res = 
+  let rel, prf = get_rew_prf res in
+    apply_constraint env avoid res.rew_car rel prf cstr res
+
+let apply_rule unify loccs : ('a * int) pure_strategy =
+  let (nowhere_except_in,occs) = convert_occs loccs in
+  let is_occ occ =
+    if nowhere_except_in 
+    then List.mem occ occs 
+    else not (List.mem occ occs) 
+  in
+    fun (hypinfo, occ) env avoid t ty cstr evars ->
+      let unif = if isEvar t then None else unify hypinfo env evars t in
+	match unif with
+	| None -> ((hypinfo, occ), Fail)
+        | Some (hypinfo', rew) ->
+	  let occ = succ occ in
+	    if not (is_occ occ) then ((hypinfo, occ), Fail)
+	    else if eq_constr t rew.rew_to then ((hypinfo, occ), Identity)
+	    else
+	      let res = { rew with rew_car = ty } in
+              let rel, prf = get_rew_prf res in
+	      let res = Success (apply_constraint env avoid rew.rew_car rel prf cstr res) in
+		((hypinfo', occ), res)
+		  
+let apply_lemma l2r flags oc by loccs : strategy =
+  fun () env avoid t ty cstr (sigma, cstrs) ->
+    let sigma, c = oc sigma in
+    let sigma, hypinfo = decompose_applied_relation env sigma c in
+    let { c1; c2; car; rel; prf; sort; holes } = hypinfo in
+    let rew = (car, rel, prf, c1, c2, holes, sort) in
+    let evars = (sigma, cstrs) in
+    let unify () env evars t =
+      let rew = unify_eqn rew l2r flags env evars by t in
+      match rew with
+      | None -> None
+      | Some rew -> Some ((), rew)
+    in
+    let _, res = apply_rule unify loccs ((), 0) env avoid t ty cstr evars in
+    (), res
+
+let e_app_poly env evars f args =
+  let evars', c = app_poly_nocheck env !evars f args in
+    evars := evars';
+    c
+
+let make_leibniz_proof env c ty r =
+  let evars = ref r.rew_evars in
+  let prf = 
+    match r.rew_prf with
+    | RewPrf (rel, prf) -> 
+	let rel = e_app_poly env evars coq_eq [| ty |] in
+	let prf =
+	  e_app_poly env evars coq_f_equal
+		[| r.rew_car; ty;
+		   mkLambda (Anonymous, r.rew_car, c);
+		   r.rew_from; r.rew_to; prf |]
+	in RewPrf (rel, prf)
+    | RewCast k -> r.rew_prf
+  in
+    { rew_car = ty; rew_evars = !evars;
+      rew_from = subst1 r.rew_from c; rew_to = subst1 r.rew_to c; rew_prf = prf }
+
+let reset_env env =
+  let env' = Global.env_of_context (Environ.named_context_val env) in
+    Environ.push_rel_context (Environ.rel_context env) env'
+      
+let fold_match ?(force=false) env sigma c =
+  let (ci, p, c, brs) = destCase c in
+  let cty = Retyping.get_type_of env sigma c in
+  let dep, pred, exists, (sk,eff) = 
+    let env', ctx, body =
+      let ctx, pred = decompose_lam_assum p in
+      let env' = Environ.push_rel_context ctx env in
+	env', ctx, pred
+    in
+    let sortp = Retyping.get_sort_family_of env' sigma body in
+    let sortc = Retyping.get_sort_family_of env sigma cty in
+    let dep = not (noccurn 1 body) in
+    let pred = if dep then p else
+	it_mkProd_or_LetIn (subst1 mkProp body) (List.tl ctx)
+    in
+    let sk = 
+      if sortp == InProp then
+	if sortc == InProp then
+	  if dep then case_dep_scheme_kind_from_prop
+	  else case_scheme_kind_from_prop
+	else (
+	  if dep
+	  then case_dep_scheme_kind_from_type_in_prop
+	  else case_scheme_kind_from_type)
+      else ((* sortc <> InProp by typing *)
+	if dep
+	then case_dep_scheme_kind_from_type
+	else case_scheme_kind_from_type)
+    in 
+    let exists = Ind_tables.check_scheme sk ci.ci_ind in
+      if exists || force then
+	dep, pred, exists, Ind_tables.find_scheme sk ci.ci_ind
+      else raise Not_found
+  in
+  let app =
+    let ind, args = Inductive.find_rectype env cty in
+    let pars, args = List.chop ci.ci_npar args in
+    let meths = List.map (fun br -> br) (Array.to_list brs) in
+      applist (mkConst sk, pars @ [pred] @ meths @ args @ [c])
+  in 
+    sk, (if exists then env else reset_env env), app, eff
+
+let unfold_match env sigma sk app =
+  match kind_of_term app with
+  | App (f', args) when eq_constant (fst (destConst f')) sk ->
+      let v = Environ.constant_value_in (Global.env ()) (sk,Univ.Instance.empty)(*FIXME*) in
+	Reductionops.whd_beta sigma (mkApp (v, args))
+  | _ -> app
+
+let is_rew_cast = function RewCast _ -> true | _ -> false
+
+let subterm all flags (s : 'a pure_strategy) : 'a pure_strategy =
+  let rec aux state env avoid t ty (prop, cstr) evars =
+    let cstr' = Option.map (fun c -> (ty, Some c)) cstr in
+      match kind_of_term t with
+      | App (m, args) ->
+	  let rewrite_args state success =
+	    let state, (args', evars', progress) =
+	      Array.fold_left
+		(fun (state, (acc, evars, progress)) arg ->
+		  if not (Option.is_empty progress) && not all then 
+		    state, (None :: acc, evars, progress)
+		  else
+		    let argty = Retyping.get_type_of env (goalevars evars) arg in
+		    let state, res = s state env avoid arg argty (prop,None) evars in
+		    let res' = 
+		      match res with
+		      | Identity ->
+			let progress = if Option.is_empty progress then Some false else progress in
+			  (None :: acc, evars, progress)
+		      | Success r -> 
+			(Some r :: acc, r.rew_evars, Some true)
+		      | Fail -> (None :: acc, evars, progress)
+		    in state, res')
+		(state, ([], evars, success)) args
+	    in
+	    let res = 
+	      match progress with
+	      | None -> Fail
+	      | Some false -> Identity
+	      | Some true ->
+		let args' = Array.of_list (List.rev args') in
+		  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' (prop, cstr') evars' 
+		    in
+		    let res = { rew_car = ty; rew_from = c1;
+				rew_to = c2; rew_prf = RewPrf (rel, prf);
+				rew_evars = evars' } 
+		    in Success 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 Success res
+	    in state, res
+	  in
+	    if flags.on_morphisms then
+	      let mty = Retyping.get_type_of env (goalevars evars) m in
+	      let evars, cstr', m, mty, argsl, args = 
+		let argsl = Array.to_list args in
+		let lift = if prop then PropGlobal.lift_cstr else TypeGlobal.lift_cstr in
+		  match lift env evars argsl m mty None with
+		  | Some (evars, cstr', m, mty, args) -> 
+		    evars, Some cstr', m, mty, args, Array.of_list args
+		  | None -> evars, None, m, mty, argsl, args
+	      in
+	      let state, m' = s state env avoid m mty (prop, cstr') evars in
+		match m' with
+		| Fail -> rewrite_args state None (* Standard path, try rewrite on arguments *)
+		| Identity -> rewrite_args state (Some false)
+		| Success r ->
+		    (* We rewrote the function and get a proof of pointwise rel for the arguments.
+		       We just apply it. *)
+		    let prf = match r.rew_prf with
+		      | RewPrf (rel, prf) ->
+			let app = if prop then PropGlobal.apply_pointwise 
+			  else TypeGlobal.apply_pointwise 
+			in
+			  RewPrf (app rel argsl, mkApp (prf, args))
+		      | x -> x
+		    in
+		    let res =
+		      { rew_car = prod_appvect r.rew_car args;
+			rew_from = mkApp(r.rew_from, args); rew_to = mkApp(r.rew_to, args);
+			rew_prf = prf; rew_evars = r.rew_evars }
+		    in 
+		    let res = 
+		      match prf with
+		      | RewPrf (rel, prf) ->
+			Success (apply_constraint env avoid res.rew_car
+				      rel prf (prop,cstr) res)
+		      | _ -> Success res
+		    in state, res
+	    else rewrite_args state None
+	      
+      | Prod (n, x, b) when noccurn 1 b ->
+	  let b = subst1 mkProp b in
+	  let tx = Retyping.get_type_of env (goalevars evars) x 
+	  and tb = Retyping.get_type_of env (goalevars evars) b in
+	  let arr = if prop then PropGlobal.arrow_morphism 
+	    else TypeGlobal.arrow_morphism 
+	  in
+	  let (evars', mor), unfold = arr env evars tx tb x b in
+	  let state, res = aux state env avoid mor ty (prop,cstr) evars' in
+	  let res = 
+	    match res with
+	    | Success r -> Success { r with rew_to = unfold r.rew_to }
+	    | Fail | Identity -> res
+	  in state, res
+
+      (* 		if x' = None && flags.under_lambdas then *)
+      (* 		  let lam = mkLambda (n, x, b) in *)
+      (* 		  let lam', occ = aux env lam occ None in *)
+      (* 		  let res =  *)
+      (* 		    match lam' with *)
+      (* 		    | None -> None *)
+      (* 		    | Some (prf, (car, rel, c1, c2)) -> *)
+      (* 			Some (resolve_morphism env sigma t *)
+      (* 				 ~fnewt:unfold_all *)
+      (* 				 (Lazy.force coq_all) [| x ; lam |] [| None; lam' |] *)
+      (* 				 cstr evars) *)
+      (* 		  in res, occ *)
+      (* 		else *)
+
+      | Prod (n, dom, codom) ->
+	  let lam = mkLambda (n, dom, codom) in
+	  let (evars', app), unfold = 
+	    if eq_constr ty mkProp then
+	      (app_poly_sort prop env evars coq_all [| dom; lam |]), TypeGlobal.unfold_all
+	    else 
+	      let forall = if prop then PropGlobal.coq_forall else TypeGlobal.coq_forall in
+		(app_poly_sort prop env evars forall [| dom; lam |]), TypeGlobal.unfold_forall
+	  in
+	  let state, res = aux state env avoid app ty (prop,cstr) evars' in
+	  let res = 
+	    match res with
+	    | Success r -> Success { r with rew_to = unfold r.rew_to }
+	    | Fail | Identity -> res
+	  in state, res
+
+(* TODO: real rewriting under binders: introduce x x' (H : R x x') and rewrite with 
+   H at any occurrence of x. Ask for (R ==> R') for the lambda. Formalize this.
+   B. Barras' idea is to have a context of relations, of length 1, with Σ for gluing
+   dependent relations and using projections to get them out.
+ *)
+      (* | Lambda (n, t, b) when flags.under_lambdas -> *)
+      (* 	  let n' = name_app (fun id -> Tactics.fresh_id_in_env avoid id env) n in *)
+      (* 	  let n'' = name_app (fun id -> Tactics.fresh_id_in_env avoid id env) n' in *)
+      (* 	  let n''' = name_app (fun id -> Tactics.fresh_id_in_env avoid id env) n'' in *)
+      (* 	  let rel = new_cstr_evar cstr env (mkApp (Lazy.force coq_relation, [|t|])) in *)
+      (* 	  let env' = Environ.push_rel_context [(n'',None,lift 2 rel);(n'',None,lift 1 t);(n', None, t)] env in *)
+      (* 	  let b' = s env' avoid b (Typing.type_of env' (goalevars evars) (lift 2 b)) (unlift_cstr env (goalevars evars) cstr) evars in *)
+      (* 	    (match b' with *)
+      (* 	    | Some (Some r) -> *)
+      (* 		let prf = match r.rew_prf with *)
+      (* 		  | RewPrf (rel, prf) -> *)
+      (* 		      let rel = pointwise_or_dep_relation n' t r.rew_car rel in *)
+      (* 		      let prf = mkLambda (n', t, prf) in *)
+      (* 			RewPrf (rel, prf) *)
+      (* 		  | x -> x *)
+      (* 		in *)
+      (* 		  Some (Some { r with *)
+      (* 		    rew_prf = prf; *)
+      (* 		    rew_car = mkProd (n, t, r.rew_car); *)
+      (* 		    rew_from = mkLambda(n, t, r.rew_from); *)
+      (* 		    rew_to = mkLambda (n, t, r.rew_to) }) *)
+      (* 	    | _ -> b') *)
+
+      | Lambda (n, t, b) when flags.under_lambdas ->
+	let n' = name_app (fun id -> Tactics.fresh_id_in_env avoid id env) n in
+	let env' = Environ.push_rel (n', None, t) env in
+	let bty = Retyping.get_type_of env' (goalevars evars) b in
+	let unlift = if prop then PropGlobal.unlift_cstr else TypeGlobal.unlift_cstr in
+	let state, b' = s state env' avoid b bty (prop, unlift env evars cstr) evars in
+	let res = 
+	  match b' with
+	  | Success r ->
+	    let r = match r.rew_prf with
+	      | RewPrf (rel, prf) ->
+		let point = if prop then PropGlobal.pointwise_or_dep_relation else
+		    TypeGlobal.pointwise_or_dep_relation
+		in
+		let evars, rel = point env r.rew_evars n' t r.rew_car rel in
+		let prf = mkLambda (n', t, prf) in
+		  { r with rew_prf = RewPrf (rel, prf); rew_evars = evars }
+	      | x -> r
+	    in
+	      Success { r with
+		rew_car = mkProd (n, t, r.rew_car);
+		rew_from = mkLambda(n, t, r.rew_from);
+		rew_to = mkLambda (n, t, r.rew_to) }
+	  | Fail | Identity -> b'
+	in state, res
+	    
+      | Case (ci, p, c, brs) ->
+	let cty = Retyping.get_type_of env (goalevars evars) c in
+	let evars', eqty = app_poly_sort prop env evars coq_eq [| cty |] in
+	let cstr' = Some eqty in
+	let state, c' = s state env avoid c cty (prop, cstr') evars' in
+	let state, res = 
+	  match c' with
+	  | Success r ->
+	    let case = mkCase (ci, lift 1 p, mkRel 1, Array.map (lift 1) brs) in
+	    let res = make_leibniz_proof env case ty r in
+	      state, Success (coerce env avoid (prop,cstr) res)
+	  | Fail | Identity ->
+	    if Array.for_all (Int.equal 0) ci.ci_cstr_ndecls then
+	      let evars', eqty = app_poly_sort prop env evars coq_eq [| ty |] in
+	      let cstr = Some eqty in
+	      let state, found, brs' = Array.fold_left 
+		(fun (state, found, acc) br ->
+		  if not (Option.is_empty found) then 
+		    (state, found, fun x -> lift 1 br :: acc x)
+		  else
+		    let state, res = s state env avoid br ty (prop,cstr) evars in
+		      match res with
+		      | Success r -> (state, Some r, fun x -> mkRel 1 :: acc x)
+		      | Fail | Identity -> (state, None, fun x -> lift 1 br :: acc x))
+		(state, 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' c'))) in
+		    state, Success (make_leibniz_proof env ctxc ty r)
+		| None -> state, c'
+	    else
+	      match try Some (fold_match env (goalevars evars) t) with Not_found -> None with
+	      | None -> state, c'
+	      | Some (cst, _, t', eff (*FIXME*)) ->
+		let state, res = aux state env avoid t' ty (prop,cstr) evars in
+		let res = 
+		  match res with
+		  | Success prf -> 
+		    Success { prf with
+		      rew_from = t; 
+		      rew_to = unfold_match env (goalevars evars) cst prf.rew_to }
+		  | x' -> c'
+		in state, res
+	in 
+	let res = 
+	  match res with
+	  | Success r ->  
+	    let rel, prf = get_rew_prf r in
+	      Success (apply_constraint env avoid r.rew_car rel prf (prop,cstr) r)
+	  | Fail | Identity -> res
+	in state, res
+      | _ -> state, Fail
+  in aux
+
+let all_subterms = subterm true default_flags
+let one_subterm = subterm false default_flags
+
+(** Requires transitivity of the rewrite step, if not a reduction.
+    Not tail-recursive. *)
+
+let transitivity state env avoid prop (res : rewrite_result_info) (next : 'a pure_strategy) : 
+    'a * rewrite_result =
+  let state, nextres =
+    next state env avoid res.rew_to res.rew_car
+      (prop, get_opt_rew_rel res.rew_prf) res.rew_evars 
+  in 
+  let res = 
+    match nextres with
+    | Fail -> Fail
+    | Identity -> Success res
+    | Success res' ->
+      match res.rew_prf with
+      | RewCast c -> Success { res' with rew_from = res.rew_from }
+      | RewPrf (rew_rel, rew_prf) ->
+	match res'.rew_prf with
+	| RewCast _ -> Success { res with rew_to = res'.rew_to }
+	| RewPrf (res'_rel, res'_prf) ->
+	  let trans = 
+	    if prop then PropGlobal.transitive_type 
+	    else TypeGlobal.transitive_type
+	  in
+	  let evars, prfty = 
+	    app_poly_sort prop env res'.rew_evars trans [| res.rew_car; rew_rel |] 
+	  in
+	  let evars, prf = new_cstr_evar evars env prfty in
+	  let prf = mkApp (prf, [|res.rew_from; res'.rew_from; res'.rew_to;
+				  rew_prf; res'_prf |])
+	  in Success { res' with rew_from = res.rew_from; 
+	    rew_evars = evars; rew_prf = RewPrf (res'_rel, prf) }
+  in state, res
+
+(** Rewriting strategies.
+
+    Inspired by ELAN's rewriting strategies:
+    http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.21.4049
+*)
+
+module Strategies =
+  struct
+
+    let fail : 'a pure_strategy =
+      fun state env avoid t ty cstr evars ->
+	state, Fail
+
+    let id : 'a pure_strategy =
+      fun state env avoid t ty cstr evars -> 
+	state, Identity
+
+    let refl : 'a pure_strategy =
+      fun state env avoid t ty (prop,cstr) evars ->
+	let evars, rel = match cstr with
+	  | None -> 
+	    let mkr = if prop then PropGlobal.mk_relation else TypeGlobal.mk_relation in
+	    let evars, rty = mkr env evars ty in
+	      new_cstr_evar evars env rty
+	  | Some r -> evars, r
+	in
+	let evars, proof =
+	  let proxy = 
+	    if prop then PropGlobal.proper_proxy_type 
+	    else TypeGlobal.proper_proxy_type
+	  in
+	  let evars, mty = app_poly_sort prop env evars proxy [| ty ; rel; t |] in
+	    new_cstr_evar evars env mty
+	in
+	let res = Success { rew_car = ty; rew_from = t; rew_to = t;
+			       rew_prf = RewPrf (rel, proof); rew_evars = evars }
+	in state, res
+
+    let progress (s : 'a pure_strategy) : 'a pure_strategy =
+      fun state env avoid t ty cstr evars ->
+	let state, res = s state env avoid t ty cstr evars in
+	  match res with
+	  | Fail -> state, Fail
+	  | Identity -> state, Fail
+	  | Success r -> state, Success r
+	    
+    let seq first snd : 'a pure_strategy =
+      fun state env avoid t ty cstr evars ->
+	let state, res = first state env avoid t ty cstr evars in
+	  match res with
+	  | Fail -> state, Fail
+	  | Identity -> snd state env avoid t ty cstr evars
+	  | Success res -> transitivity state env avoid (fst cstr) res snd
+	    
+    let choice fst snd : 'a pure_strategy =
+      fun state env avoid t ty cstr evars ->
+	let state, res = fst state env avoid t ty cstr evars in
+	  match res with
+	  | Fail -> snd state env avoid t ty cstr evars
+	  | Identity | Success _ -> state, res
+
+    let try_ str : 'a pure_strategy = choice str id
+
+    let check_interrupt str s e l c t r ev =
+      Control.check_for_interrupt ();
+      str s e l c t r ev
+    
+    let fix (f : 'a pure_strategy -> 'a pure_strategy) : 'a pure_strategy =
+      let rec aux state = f (fun state -> check_interrupt aux state) state in aux
+    
+    let any (s : 'a pure_strategy) : 'a pure_strategy =
+      fix (fun any -> try_ (seq s any))
+
+    let repeat (s : 'a pure_strategy) : 'a pure_strategy =
+      seq s (any s)
+
+    let bu (s : 'a pure_strategy) : 'a pure_strategy =
+      fix (fun s' -> seq (choice (progress (all_subterms s')) s) (try_ s'))
+
+    let td (s : 'a pure_strategy) : 'a pure_strategy =
+      fix (fun s' -> seq (choice s (progress (all_subterms s'))) (try_ s'))
+
+    let innermost (s : 'a pure_strategy) : 'a pure_strategy =
+      fix (fun ins -> choice (one_subterm ins) s)
+
+    let outermost (s : 'a pure_strategy) : 'a pure_strategy =
+      fix (fun out -> choice s (one_subterm out))
+
+    let lemmas cs : 'a pure_strategy =
+      List.fold_left (fun tac (l,l2r,by) ->
+	choice tac (apply_lemma l2r rewrite_unif_flags l by AllOccurrences))
+	fail cs
+
+    let inj_open hint = (); fun sigma ->
+      let ctx = Evd.evar_universe_context_of hint.Autorewrite.rew_ctx in
+      let sigma = Evd.merge_universe_context sigma ctx in
+      (sigma, (hint.Autorewrite.rew_lemma, NoBindings))
+
+    let old_hints (db : string) : 'a pure_strategy =
+      let rules = Autorewrite.find_rewrites db in
+	lemmas
+	  (List.map (fun hint -> (inj_open hint, hint.Autorewrite.rew_l2r,
+				  hint.Autorewrite.rew_tac)) rules)
+
+    let hints (db : string) : 'a pure_strategy =
+      fun state env avoid t ty cstr evars ->
+      let rules = Autorewrite.find_matches db t in
+      let lemma hint = (inj_open hint, hint.Autorewrite.rew_l2r,
+			hint.Autorewrite.rew_tac) in
+      let lems = List.map lemma rules in
+	lemmas lems state env avoid t ty cstr evars
+
+    let reduce (r : Redexpr.red_expr) : 'a pure_strategy =
+	fun state env avoid t ty cstr evars ->
+          let rfn, ckind = Redexpr.reduction_of_red_expr env r in
+	  let evars', t' = rfn env (goalevars evars) t in
+	    if eq_constr t' t then
+	      state, Identity
+	    else
+	      state, Success { rew_car = ty; rew_from = t; rew_to = t';
+			       rew_prf = RewCast ckind; 
+			       rew_evars = evars', cstrevars evars }
+	
+    let fold_glob c : 'a pure_strategy =
+      fun state env avoid t ty cstr evars ->
+(* 	let sigma, (c,_) = Tacinterp.interp_open_constr_with_bindings is env (goalevars evars) c in *)
+	let sigma, c = Pretyping.understand_tcc env (goalevars evars) c in
+	let unfolded =
+	  try Tacred.try_red_product env sigma c
+	  with e when Errors.noncritical e ->
+            error "fold: the term is not unfoldable !"
+	in
+	  try
+	    let sigma = Unification.w_unify env sigma CONV ~flags:(Unification.elim_flags ()) unfolded t in
+	    let c' = Evarutil.nf_evar sigma c in
+	      state, Success { rew_car = ty; rew_from = t; rew_to = c';
+				  rew_prf = RewCast DEFAULTcast;
+				  rew_evars = (sigma, snd evars) }
+	  with e when Errors.noncritical e -> state, Fail
+  
+
+end
+
+(** The strategy for a single rewrite, dealing with occurences. *)
+
+(** A dummy initial clauseenv to avoid generating initial evars before
+    even finding a first application of the rewriting lemma, in setoid_rewrite
+    mode *)
+
+let rewrite_with l2r flags c occs : strategy =
+  fun () env avoid t ty cstr (sigma, cstrs) ->
+    let hypinfo = None in
+    let unify hypinfo env evars t =
+      let (sigma, cstrs) = evars in
+      let ans =
+        try Some (refresh_hypinfo env sigma hypinfo c)
+        with e when Class_tactics.catchable e -> None
+      in
+      match ans with
+      | None -> None
+      | Some (sigma, rew) ->
+        let rew = unify_eqn rew l2r flags env (sigma, cstrs) None t in
+        match rew with
+        | None -> None
+        | Some rew -> Some (None, rew) (** reset the hypinfo cache *)
+    in
+    let app = apply_rule unify occs in
+    let strat = 
+      Strategies.fix (fun aux -> 
+	Strategies.choice app (subterm true default_flags aux))
+    in
+    let _, res = strat (hypinfo, 0) env avoid t ty cstr (sigma, cstrs) in
+      ((), res)
+
+let apply_strategy (s : strategy) env avoid concl (prop, cstr) evars =
+  let ty = Retyping.get_type_of env (goalevars evars) concl in
+  let _, res = s () env avoid concl ty (prop, Some cstr) evars in
+  res
+
+let solve_constraints env (evars,cstrs) =
+  let filter = all_constraints cstrs in
+    Typeclasses.resolve_typeclasses env ~filter ~split:false ~fail:true 
+      (Typeclasses.mark_resolvables ~filter evars)
+      
+let nf_zeta =
+  Reductionops.clos_norm_flags (Closure.RedFlags.mkflags [Closure.RedFlags.fZETA])
+
+exception RewriteFailure of Pp.std_ppcmds
+
+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 evdref = ref sigma in
+  let sort = Typing.sort_of env evdref concl in
+  let evars = (!evdref, Evar.Set.empty) in
+  let evars, cstr =
+    let prop, (evars, arrow) = 
+      if is_prop_sort sort then true, app_poly_sort true env evars impl [||]
+      else false, app_poly_sort false env evars TypeGlobal.arrow [||]
+    in
+      match is_hyp with
+      | None -> 
+	let evars, t = poly_inverse prop env evars (mkSort sort) arrow in 
+	  evars, (prop, t)
+      | Some _ -> evars, (prop, arrow)
+  in
+  let eq = apply_strategy strat env avoid concl cstr evars in
+    match eq with
+    | Fail -> None
+    | Identity -> Some None
+    | Success res ->
+      let (_, cstrs) = res.rew_evars in
+      let evars' = solve_constraints env res.rew_evars in
+      let newt = Evarutil.nf_evar evars' res.rew_to in
+      let evars = (* Keep only original evars (potentially instantiated) and goal evars,
+		     the rest has been defined and substituted already. *)
+	Evar.Set.fold (fun ev acc -> Evd.remove acc ev) cstrs evars'
+      in
+      let res = match res.rew_prf with
+	| RewCast c -> None
+	| RewPrf (rel, p) ->
+	  let p = nf_zeta env evars' (Evarutil.nf_evar evars' p) in
+	  let term =
+	    match abs with
+	    | None -> p
+	    | Some (t, ty) ->
+              let t = Evarutil.nf_evar evars' t in
+              let ty = Evarutil.nf_evar evars' ty in
+		mkApp (mkLambda (Name (Id.of_string "lemma"), ty, p), [| t |])
+	  in
+	  let proof = match is_hyp with
+            | None -> term
+            | Some id -> mkApp (term, [| mkVar id |])
+          in Some proof
+      in Some (Some (evars, res, newt))
+
+let assert_replacing id newt tac = 
+  let prf = Proofview.Goal.nf_enter begin fun gl ->
+    let concl = Proofview.Goal.concl gl in
+    let env = Proofview.Goal.env gl in
+    let nc' =
+      Environ.fold_named_context
+        (fun _ (n, b, t as decl) nc' ->
+          if Id.equal n id then (n, b, newt) :: nc'
+          else decl :: nc')
+        env ~init:[]
+    in
+    Proofview.Refine.refine ~unsafe:false begin fun sigma ->
+      let env' = Environ.reset_with_named_context (val_of_named_context nc') env in
+      let sigma, ev = Evarutil.new_evar env' sigma concl in
+      let sigma, ev' = Evarutil.new_evar env sigma newt in
+      let fold _ (n, b, t) inst =
+        if Id.equal n id then ev' :: inst
+        else mkVar n :: inst
+      in
+      let inst = fold_named_context fold env ~init:[] in
+      let (e, args) = destEvar ev in
+      sigma, mkEvar (e, Array.of_list inst)
+    end
+  end in
+  Proofview.tclTHEN prf (Proofview.tclFOCUS 2 2 tac)
+
+let newfail n s = 
+  Proofview.tclZERO (Refiner.FailError (n, lazy s))
+
+let cl_rewrite_clause_newtac ?abs ?origsigma strat clause =
+  let open Proofview.Notations in
+  let treat sigma (res, is_hyp) = 
+    match res with
+    | None -> newfail 0 (str "Nothing to rewrite")
+    | Some None -> Proofview.tclUNIT ()
+    | Some (Some res) ->
+        let (undef, prf, newt) = res in
+        let fold ev _ accu = if Evd.mem sigma ev then accu else ev :: accu in
+        let gls = List.rev (Evd.fold_undefined fold undef []) in
+	match is_hyp, prf with
+	| Some id, Some p ->
+            let tac = Proofview.Refine.refine ~unsafe:false (fun h -> (h, p)) <*> Proofview.Unsafe.tclNEWGOALS gls in
+            Proofview.Unsafe.tclEVARS undef <*>
+	    assert_replacing id newt tac
+	| Some id, None ->
+            Proofview.Unsafe.tclEVARS undef <*>
+            convert_hyp_no_check (id, None, newt)
+	| None, Some p ->
+            Proofview.Unsafe.tclEVARS undef <*>
+            Proofview.Goal.enter begin fun gl ->
+            let env = Proofview.Goal.env gl in
+            let make sigma =
+              let (sigma, ev) = Evarutil.new_evar env sigma newt in
+              sigma, mkApp (p, [| ev |])
+            in
+            Proofview.Refine.refine ~unsafe:false make <*> Proofview.Unsafe.tclNEWGOALS gls
+            end
+	| None, None ->
+            Proofview.Unsafe.tclEVARS undef <*>
+            convert_concl_no_check newt DEFAULTcast
+  in
+  let beta_red _ sigma c = Reductionops.nf_betaiota sigma c in
+  let beta = Proofview.V82.tactic (Tactics.reduct_in_concl (beta_red, DEFAULTcast)) in
+  let opt_beta = match clause with
+  | None -> Proofview.tclUNIT ()
+  | Some id -> Proofview.V82.tactic (Tactics.reduct_in_hyp beta_red (id, InHyp))
+  in
+  Proofview.Goal.nf_enter begin fun gl ->
+    let concl = Proofview.Goal.concl gl in
+    let env = Proofview.Goal.env gl in
+    let sigma = Proofview.Goal.sigma gl in
+    let ty, is_hyp =
+      match clause with
+      | Some id -> Environ.named_type id env, Some id
+      | None -> concl, None
+    in
+    try
+      let res =
+        cl_rewrite_clause_aux ?abs strat env [] sigma ty is_hyp
+      in
+      let sigma = match origsigma with None -> sigma | Some sigma -> sigma in
+      treat sigma (res, is_hyp) <*>
+      (** For compatibility *)
+      beta <*> opt_beta <*> Proofview.shelve_unifiable
+    with
+    | PretypeError (env, evd, (UnsatisfiableConstraints _ as e)) ->
+      raise (RewriteFailure (Himsg.explain_pretype_error env evd e))
+  end
+
+let tactic_init_setoid () = 
+  try init_setoid (); tclIDTAC
+  with e when Errors.noncritical e -> tclFAIL 0 (str"Setoid library not loaded")
+
+(** Setoid rewriting when called with "rewrite_strat" *)
+let cl_rewrite_clause_strat strat clause =
+  tclTHEN (tactic_init_setoid ())
+  (fun gl -> 
+     try Proofview.V82.of_tactic (cl_rewrite_clause_newtac strat clause) gl
+     with RewriteFailure e ->
+       errorlabstrm "" (str"setoid rewrite failed: " ++ e)
+     | Refiner.FailError (n, pp) -> 
+       tclFAIL n (str"setoid rewrite failed: " ++ Lazy.force pp) gl)
+
+(** Setoid rewriting when called with "setoid_rewrite" *)
+let cl_rewrite_clause l left2right occs clause gl =
+  let strat = rewrite_with left2right (general_rewrite_unif_flags ()) l occs in
+    cl_rewrite_clause_strat strat clause gl
+
+let apply_glob_constr c l2r occs = (); fun () env avoid t ty cstr evars ->
+  let c sigma =
+    let (sigma, c) = Pretyping.understand_tcc env sigma c in
+    (sigma, (c, NoBindings))
+  in
+  let flags = general_rewrite_unif_flags () in
+  apply_lemma l2r flags c None occs () env avoid t ty cstr evars
+
+let interp_glob_constr_list env =
+  let make c = (); fun sigma ->
+    let sigma, c = Pretyping.understand_tcc env sigma c in
+    (sigma, (c, NoBindings))
+  in
+  List.map (fun c -> make c, true, None)
+
+(* Syntax for rewriting with strategies *)
+
+type unary_strategy = 
+    Subterms | Subterm | Innermost | Outermost
+  | Bottomup | Topdown | Progress | Try | Any | Repeat
+
+type binary_strategy = 
+  | Compose | Choice
+
+type ('constr,'redexpr) strategy_ast = 
+  | StratId | StratFail | StratRefl
+  | StratUnary of unary_strategy * ('constr,'redexpr) strategy_ast
+  | StratBinary of binary_strategy 
+    * ('constr,'redexpr) strategy_ast * ('constr,'redexpr) strategy_ast
+  | StratConstr of 'constr * bool
+  | StratTerms of 'constr list
+  | StratHints of bool * string
+  | StratEval of 'redexpr 
+  | StratFold of 'constr
+
+let rec map_strategy (f : 'a -> 'a2) (g : 'b -> 'b2) : ('a,'b) strategy_ast -> ('a2,'b2) strategy_ast = function
+  | StratId | StratFail | StratRefl as s -> s
+  | StratUnary (s, str) -> StratUnary (s, map_strategy f g str)
+  | StratBinary (s, str, str') -> StratBinary (s, map_strategy f g str, map_strategy f g str')
+  | StratConstr (c, b) -> StratConstr (f c, b)
+  | StratTerms l -> StratTerms (List.map f l)
+  | StratHints (b, id) -> StratHints (b, id)
+  | StratEval r -> StratEval (g r)
+  | StratFold c -> StratFold (f c)
+
+let rec strategy_of_ast = function
+  | StratId -> Strategies.id
+  | StratFail -> Strategies.fail
+  | StratRefl -> Strategies.refl
+  | StratUnary (f, s) -> 
+    let s' = strategy_of_ast s in
+    let f' = match f with
+      | Subterms -> all_subterms
+      | Subterm -> one_subterm
+      | Innermost -> Strategies.innermost
+      | Outermost -> Strategies.outermost
+      | Bottomup -> Strategies.bu
+      | Topdown -> Strategies.td
+      | Progress -> Strategies.progress
+      | Try -> Strategies.try_
+      | Any -> Strategies.any
+      | Repeat -> Strategies.repeat
+    in f' s'
+  | StratBinary (f, s, t) ->
+    let s' = strategy_of_ast s in
+    let t' = strategy_of_ast t in
+    let f' = match f with
+      | Compose -> Strategies.seq
+      | Choice -> Strategies.choice
+    in f' s' t'
+  | StratConstr (c, b) -> apply_glob_constr (fst c) b AllOccurrences
+  | StratHints (old, id) -> if old then Strategies.old_hints id else Strategies.hints id
+  | StratTerms l -> 
+    (fun () env avoid t ty cstr evars ->
+     let l' = interp_glob_constr_list env (List.map fst l) in
+       Strategies.lemmas l' () env avoid t ty cstr evars)
+  | StratEval r -> 
+    (fun () env avoid t ty cstr evars ->
+     let (sigma,r_interp) = Tacinterp.interp_redexp env (goalevars evars) r in
+       Strategies.reduce r_interp () env avoid t ty cstr (sigma,cstrevars evars))
+  | StratFold c -> Strategies.fold_glob (fst c)
+
+
+(* By default the strategy for "rewrite_db" is top-down *)
+
+let mkappc s l = CAppExpl (Loc.ghost,(None,(Libnames.Ident (Loc.ghost,Id.of_string s)),None),l)
+
+let declare_an_instance n s args =
+  ((Loc.ghost,Name n), Explicit,
+  CAppExpl (Loc.ghost, (None, Qualid (Loc.ghost, qualid_of_string s),None),
+	   args))
+
+let declare_instance a aeq n s = declare_an_instance n s [a;aeq]
+
+let anew_instance global binders instance fields =
+  new_instance (Flags.is_universe_polymorphism ()) 
+    binders instance (Some (true, CRecord (Loc.ghost,None,fields)))
+    ~global ~generalize:false None
+
+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 global binders instance
+       [(Ident (Loc.ghost,Id.of_string "reflexivity"),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 global binders instance
+       [(Ident (Loc.ghost,Id.of_string "symmetry"),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 global binders instance
+       [(Ident (Loc.ghost,Id.of_string "transitivity"),lemma)]
+
+let declare_relation ?(binders=[]) a aeq n refl symm trans =
+  init_setoid ();
+  let global = not (Locality.make_section_locality (Locality.LocalityFixme.consume ())) in
+  let instance = declare_instance a aeq (add_suffix n "_relation") "Coq.Classes.RelationClasses.RewriteRelation"
+  in ignore(anew_instance global binders instance []);
+  match (refl,symm,trans) with
+      (None, None, None) -> ()
+    | (Some lemma1, None, None) ->
+	ignore (declare_instance_refl global binders a aeq n lemma1)
+    | (None, Some lemma2, None) ->
+	ignore (declare_instance_sym global binders a aeq n lemma2)
+    | (None, None, Some lemma3) ->
+	ignore (declare_instance_trans global binders a aeq n lemma3)
+    | (Some lemma1, Some lemma2, None) ->
+	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 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 global binders instance
+	      [(Ident (Loc.ghost,Id.of_string "PreOrder_Reflexive"), lemma1);
+	       (Ident (Loc.ghost,Id.of_string "PreOrder_Transitive"),lemma3)])
+    | (None, Some lemma2, Some lemma3) ->
+	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 global binders instance
+	      [(Ident (Loc.ghost,Id.of_string "PER_Symmetric"), lemma2);
+	       (Ident (Loc.ghost,Id.of_string "PER_Transitive"),lemma3)])
+     | (Some lemma1, Some lemma2, Some lemma3) ->
+	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 global binders instance
+	    [(Ident (Loc.ghost,Id.of_string "Equivalence_Reflexive"), lemma1);
+	     (Ident (Loc.ghost,Id.of_string "Equivalence_Symmetric"), lemma2);
+	     (Ident (Loc.ghost,Id.of_string "Equivalence_Transitive"), lemma3)])
+
+let cHole = CHole (Loc.ghost, None, Misctypes.IntroAnonymous, None)
+
+let proper_projection r ty =
+  let ctx, inst = decompose_prod_assum ty in
+  let mor, args = destApp inst in
+  let instarg = mkApp (r, rel_vect 0 (List.length ctx)) in
+  let app = mkApp (Lazy.force PropGlobal.proper_proj,
+		  Array.append args [| instarg |]) in
+    it_mkLambda_or_LetIn app ctx
+
+let declare_projection n instance_id r =
+  let c,uctx = Universes.fresh_global_instance (Global.env()) r in
+  let poly = Global.is_polymorphic r in
+  let ty = Retyping.get_type_of (Global.env ()) Evd.empty c in
+  let term = proper_projection c ty in
+  let typ = Typing.type_of (Global.env ()) Evd.empty term in
+  let ctx, typ = decompose_prod_assum typ in
+  let typ =
+    let n =
+      let rec aux t =
+	match kind_of_term t with
+	| App (f, [| a ; a' ; rel; rel' |]) 
+	    when Globnames.is_global (PropGlobal.respectful_ref ()) f ->
+	  succ (aux rel')
+	| _ -> 0
+      in
+      let init =
+	match kind_of_term typ with
+	    App (f, args) when Globnames.is_global (PropGlobal.respectful_ref ()) f  ->
+	      mkApp (f, fst (Array.chop (Array.length args - 2) args))
+	  | _ -> typ
+      in aux init
+    in
+    let ctx,ccl = Reductionops.splay_prod_n (Global.env()) Evd.empty (3 * n) typ
+    in it_mkProd_or_LetIn ccl ctx
+  in
+  let typ = it_mkProd_or_LetIn typ ctx in
+  let cst = 
+    Declare.definition_entry ~types:typ ~poly ~univs:(Univ.ContextSet.to_context uctx) 
+      term 
+  in
+    ignore(Declare.declare_constant n 
+	   (Entries.DefinitionEntry cst, Decl_kinds.IsDefinition Decl_kinds.Definition))
+
+let build_morphism_signature m =
+  let env = Global.env () in
+  let m,ctx = Constrintern.interp_constr env Evd.empty m in
+  let sigma = Evd.from_env ~ctx env in
+  let t = Typing.type_of env sigma m in
+  let cstrs =
+    let rec aux t =
+      match kind_of_term t with
+	| Prod (na, a, b) ->
+	    None :: aux b
+	| _ -> []
+    in aux t
+  in
+  let evars, t', sig_, cstrs = 
+    PropGlobal.build_signature (Evd.empty, Evar.Set.empty) env t cstrs None in
+  let evd = ref evars in
+  let _ = List.iter
+    (fun (ty, rel) ->
+      Option.iter (fun rel ->
+	let default = e_app_poly env evd PropGlobal.default_relation [| ty; rel |] in
+	  ignore(e_new_cstr_evar env evd default))
+	rel)
+    cstrs
+  in
+  let morph = e_app_poly env evd PropGlobal.proper_type [| t; sig_; m |] in
+  let evd = solve_constraints env !evd in
+  let m = Evarutil.nf_evar evd morph in
+    Evarutil.check_evars env Evd.empty evd m; m
+
+let default_morphism sign m =
+  let env = Global.env () in
+  let t = Typing.type_of env Evd.empty m in
+  let evars, _, sign, cstrs =
+    PropGlobal.build_signature (Evd.empty, Evar.Set.empty) env t (fst sign) (snd sign)
+  in
+  let evars, morph = app_poly_check env evars PropGlobal.proper_type [| t; sign; m |] in
+  let evars, mor = resolve_one_typeclass env (goalevars evars) morph in
+    mor, proper_projection mor morph
+
+let add_setoid global binders a aeq t n =
+  init_setoid ();
+  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 global binders instance
+      [(Ident (Loc.ghost,Id.of_string "Equivalence_Reflexive"), mkappc "Seq_refl" [a;aeq;t]);
+       (Ident (Loc.ghost,Id.of_string "Equivalence_Symmetric"), mkappc "Seq_sym" [a;aeq;t]);
+       (Ident (Loc.ghost,Id.of_string "Equivalence_Transitive"), mkappc "Seq_trans" [a;aeq;t])])
+
+
+let make_tactic name =
+  let open Tacexpr in
+  let loc = Loc.ghost in
+  let tacpath = Libnames.qualid_of_string name in
+  let tacname = Qualid (loc, tacpath) in
+  TacArg (loc, TacCall (loc, tacname, []))
+
+let add_morphism_infer glob m n =
+  init_setoid ();
+  let poly = Flags.is_universe_polymorphism () in
+  let instance_id = add_suffix n "_Proper" in
+  let instance = build_morphism_signature m in
+  let evd = Evd.empty (*FIXME *) in
+    if Lib.is_modtype () then
+      let cst = Declare.declare_constant ~internal:Declare.KernelSilent instance_id
+				(Entries.ParameterEntry 
+				 (None,poly,(instance,Univ.UContext.empty),None), 
+				 Decl_kinds.IsAssumption Decl_kinds.Logical)
+      in
+	add_instance (Typeclasses.new_instance 
+			(Lazy.force PropGlobal.proper_class) None glob 
+			poly (ConstRef cst));
+	declare_projection n instance_id (ConstRef cst)
+    else
+      let kind = Decl_kinds.Global, poly, 
+	Decl_kinds.DefinitionBody Decl_kinds.Instance 
+      in
+      let tac = make_tactic "Coq.Classes.SetoidTactics.add_morphism_tactic" in
+      let hook _ = function
+	| Globnames.ConstRef cst ->
+	  add_instance (Typeclasses.new_instance 
+			  (Lazy.force PropGlobal.proper_class) None
+			  glob poly (ConstRef cst));
+	  declare_projection n instance_id (ConstRef cst)
+	| _ -> assert false
+      in
+      let hook = Lemmas.mk_hook hook in
+	Flags.silently
+	  (fun () ->
+	    Lemmas.start_proof instance_id kind evd instance hook;
+	    ignore (Pfedit.by (Tacinterp.interp tac))) ()
+
+let add_morphism glob binders m s n =
+  init_setoid ();
+  let poly = Flags.is_universe_polymorphism () in
+  let instance_id = add_suffix n "_Proper" in
+  let instance =
+    ((Loc.ghost,Name instance_id), Explicit,
+    CAppExpl (Loc.ghost,
+	     (None, Qualid (Loc.ghost, Libnames.qualid_of_string "Coq.Classes.Morphisms.Proper"),None),
+	     [cHole; s; m]))
+  in
+  let tac = Tacinterp.interp (make_tactic "add_morphism_tactic") in
+    ignore(new_instance ~global:glob poly binders instance 
+	     (Some (true, CRecord (Loc.ghost,None,[])))
+	      ~generalize:false ~tac ~hook:(declare_projection n instance_id) None)
+
+(** Bind to "rewrite" too *)
+
+(** Taken from original setoid_replace, to emulate the old rewrite semantics where
+    lemmas are first instantiated and then rewrite proceeds. *)
+
+let check_evar_map_of_evars_defs evd =
+ let metas = Evd.meta_list evd in
+ let check_freemetas_is_empty rebus =
+  Evd.Metaset.iter
+   (fun m ->
+     if Evd.meta_defined evd m then () else
+      raise
+	(Logic.RefinerError (Logic.UnresolvedBindings [Evd.meta_name evd m])))
+ in
+  List.iter
+   (fun (_,binding) ->
+     match binding with
+        Evd.Cltyp (_,{Evd.rebus=rebus; Evd.freemetas=freemetas}) ->
+         check_freemetas_is_empty rebus freemetas
+      | Evd.Clval (_,({Evd.rebus=rebus1; Evd.freemetas=freemetas1},_),
+                 {Evd.rebus=rebus2; Evd.freemetas=freemetas2}) ->
+         check_freemetas_is_empty rebus1 freemetas1 ;
+         check_freemetas_is_empty rebus2 freemetas2
+   ) metas
+
+(* Find a subterm which matches the pattern to rewrite for "rewrite" *)
+let unification_rewrite l2r c1 c2 sigma prf car rel but env =
+  let (sigma,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 sigma ((if l2r then c1 else c2),but)
+    with
+    | ex when Pretype_errors.precatchable_exception ex ->
+	(* ~flags:(true,true) to make Ring work (since it really
+           exploits conversion) *)
+      Unification.w_unify_to_subterm 
+        ~flags:rewrite_conv_unif_flags
+        env sigma ((if l2r then c1 else c2),but)
+  in
+  let nf c = Evarutil.nf_evar sigma 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 sigma;
+  let prf = nf prf in
+  let prfty = nf (Retyping.get_type_of env sigma prf) in
+  let sort = sort_of_rel env sigma but in
+  let abs = prf, prfty in
+  let prf = mkRel 1 in
+  let res = (car, rel, prf, c1, c2) in
+  abs, sigma, res, Sorts.is_prop sort
+
+let get_hyp gl (c,l) clause l2r =
+  let evars = project gl in
+  let env = pf_env gl in
+  let sigma, hi = decompose_applied_relation env evars (c,l) 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 l2r hi.c1 hi.c2 sigma hi.prf hi.car hi.rel but env
+
+let general_rewrite_flags = { under_lambdas = false; on_morphisms = true }
+
+(* let rewriteclaustac_key = Profile.declare_profile "cl_rewrite_clause_tac";; *)
+(* let cl_rewrite_clause_tac = Profile.profile5 rewriteclaustac_key cl_rewrite_clause_tac *)
+
+(** Setoid rewriting when called with "rewrite" *)
+let general_s_rewrite cl l2r occs (c,l) ~new_goals gl =
+  let abs, evd, res, sort = get_hyp gl (c,l) cl l2r in
+  let unify () env evars t = unify_abs res l2r sort env evars t in
+  let app = apply_rule unify occs in
+  let recstrat aux = Strategies.choice app (subterm true general_rewrite_flags aux) in
+  let substrat = Strategies.fix recstrat in
+  let strat () env avoid t ty cstr evars =
+    let _, res = substrat ((), 0) env avoid t ty cstr evars in
+    (), res
+  in
+  let origsigma = project gl in
+  init_setoid ();
+    try
+      tclWEAK_PROGRESS 
+	(tclTHEN
+           (Refiner.tclEVARS evd)
+	   (Proofview.V82.of_tactic (cl_rewrite_clause_newtac ~abs:(Some abs) ~origsigma strat cl))) gl
+    with RewriteFailure e ->
+      tclFAIL 0 (str"setoid rewrite failed: " ++ e) gl
+
+let general_s_rewrite_clause x =
+  match x with
+    | None -> general_s_rewrite None
+    | Some id -> general_s_rewrite (Some id)
+
+let general_s_rewrite_clause x y z w ~new_goals =
+  Proofview.V82.tactic (general_s_rewrite_clause x y z w ~new_goals)
+
+let _ = Hook.set Equality.general_setoid_rewrite_clause general_s_rewrite_clause
+
+(** [setoid_]{reflexivity,symmetry,transitivity} tactics *)
+
+let not_declared env ty rel =
+  Tacticals.New.tclFAIL 0 (str" The relation " ++ Printer.pr_constr_env env Evd.empty rel ++ str" is not a declared " ++
+		str ty ++ str" relation. Maybe you need to require the Setoid library")
+
+let setoid_proof ty fn fallback =
+  Proofview.Goal.nf_enter begin fun gl ->
+    let env = Proofview.Goal.env gl in
+    let sigma = Proofview.Goal.sigma gl in
+    let concl = Proofview.Goal.concl gl in
+    Proofview.tclORELSE
+      begin
+        try
+          let rel, _, _ = decompose_app_rel env sigma concl in
+          let evm = sigma in
+          let car = pi3 (List.hd (fst (Reduction.dest_prod env (Typing.type_of env evm rel)))) in
+	    (try init_setoid () with _ -> raise Not_found);
+            fn env sigma car rel
+        with e -> Proofview.tclZERO e
+      end
+      begin function
+        | e ->
+            Proofview.tclORELSE
+              fallback
+              begin function (e', info) -> match e' with
+                | Hipattern.NoEquationFound ->
+	            begin match e with
+	            | (Not_found, _) ->
+	                let rel, _, _ = decompose_app_rel env sigma concl in
+		        not_declared env ty rel
+	            | (e, info) -> Proofview.tclZERO ~info e
+                    end
+                | e' -> Proofview.tclZERO ~info e'
+              end
+      end
+  end
+
+let tac_open ((evm,_), c) tac = 
+  Proofview.V82.tactic 
+    (tclTHEN (Refiner.tclEVARS evm) (tac c))
+
+let poly_proof getp gett env evm car rel =
+  if Sorts.is_prop (sort_of_rel env evm rel) then
+    getp env (evm,Evar.Set.empty) car rel
+  else gett env (evm,Evar.Set.empty) car rel
+
+let setoid_reflexivity =
+  setoid_proof "reflexive"
+    (fun env evm car rel -> 
+      tac_open (poly_proof PropGlobal.get_reflexive_proof TypeGlobal.get_reflexive_proof
+		  env evm car rel) (fun c -> Proofview.V82.of_tactic (apply c)))
+    (reflexivity_red true)
+
+let setoid_symmetry =
+  setoid_proof "symmetric"
+    (fun env evm car rel -> 
+      tac_open
+	(poly_proof PropGlobal.get_symmetric_proof TypeGlobal.get_symmetric_proof
+	   env evm car rel)
+	(fun c -> Proofview.V82.of_tactic (apply c)))
+    (symmetry_red true)
+    
+let setoid_transitivity c =
+  setoid_proof "transitive"
+    (fun env evm car rel ->
+      tac_open (poly_proof PropGlobal.get_transitive_proof TypeGlobal.get_transitive_proof
+	   env evm car rel)
+	(fun proof -> match c with
+	| None -> Proofview.V82.of_tactic (eapply proof)
+	| Some c -> Proofview.V82.of_tactic (apply_with_bindings (proof,ImplicitBindings [ c ]))))
+    (transitivity_red true c)
+    
+let setoid_symmetry_in id =
+  Proofview.V82.tactic (fun gl ->
+  let ctype = pf_type_of gl (mkVar id) in
+  let binders,concl = decompose_prod_assum ctype in
+  let (equiv, args) = decompose_app concl in
+  let rec split_last_two = function
+    | [c1;c2] -> [],(c1, c2)
+    | x::y::z -> let l,res = split_last_two (y::z) in x::l, res
+    | _ -> error "Cannot find an equivalence relation to rewrite."
+  in
+  let others,(c1,c2) = split_last_two args in
+  let he,c1,c2 =  mkApp (equiv, Array.of_list others),c1,c2 in
+  let new_hyp' =  mkApp (he, [| c2 ; c1 |]) in
+  let new_hyp = it_mkProd_or_LetIn new_hyp'  binders in
+   Proofview.V82.of_tactic
+    (Tacticals.New.tclTHENLAST
+      (Tactics.assert_after_replacing id new_hyp)
+      (Tacticals.New.tclTHENLIST [ intros; setoid_symmetry; apply (mkVar id); Tactics.assumption ]))
+      gl)
+
+let _ = Hook.set Tactics.setoid_reflexivity setoid_reflexivity
+let _ = Hook.set Tactics.setoid_symmetry setoid_symmetry
+let _ = Hook.set Tactics.setoid_symmetry_in setoid_symmetry_in
+let _ = Hook.set Tactics.setoid_transitivity setoid_transitivity
+
+let get_lemma_proof f env evm x y = 
+  let (evm, _), c = f env (evm,Evar.Set.empty) x y in
+    evm, c
+
+let get_reflexive_proof =
+  get_lemma_proof PropGlobal.get_reflexive_proof
+
+let get_symmetric_proof = 
+  get_lemma_proof PropGlobal.get_symmetric_proof
+
+let get_transitive_proof = 
+  get_lemma_proof PropGlobal.get_transitive_proof
+  
diff --git a/tactics/rewrite.ml4 b/tactics/rewrite.ml4
deleted file mode 100644
index 41944125..00000000
--- a/tactics/rewrite.ml4
+++ /dev/null
@@ -1,2121 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(*i camlp4deps: "parsing/grammar.cma" i*)
-
-open Pp
-open Util
-open Names
-open Nameops
-open Namegen
-open Term
-open Termops
-open Sign
-open Reduction
-open Proof_type
-open Declarations
-open Tacticals
-open Tacmach
-open Evar_refiner
-open Tactics
-open Pattern
-open Clenv
-open Auto
-open Glob_term
-open Hiddentac
-open Typeclasses
-open Typeclasses_errors
-open Classes
-open Topconstr
-open Pfedit
-open Command
-open Libnames
-open Evd
-open Compat
-
-(** Typeclass-based generalized rewriting. *)
-
-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 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"))))
-
-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 (pi3 (List.hd (Lazy.force proper_class).cl_projs))))
-
-let make_dir l = make_dirpath (List.map id_of_string (List.rev l))
-
-let try_find_global_reference dir s =
-  let sp = Libnames.make_path (make_dir ("Coq"::dir)) (id_of_string s) in
-    Nametab.global_of_path sp
-
-let try_find_reference dir s =
-  constr_of_global (try_find_global_reference dir s)
-
-let gen_constant dir s = Coqlib.gen_constant "rewrite" dir s
-let coq_eq = lazy(gen_constant ["Init"; "Logic"] "eq")
-let coq_f_equal = lazy (gen_constant ["Init"; "Logic"] "f_equal")
-let coq_all = lazy (gen_constant ["Init"; "Logic"] "all")
-let coq_forall = lazy (gen_constant ["Classes"; "Morphisms"] "forall_def")
-let impl = lazy (gen_constant ["Program"; "Basics"] "impl")
-let arrow = lazy (gen_constant ["Program"; "Basics"] "arrow")
-
-let reflexive_type = lazy (try_find_reference ["Classes"; "RelationClasses"] "Reflexive")
-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 transitive_type = lazy (try_find_reference ["Classes"; "RelationClasses"] "Transitive")
-let transitive_proof = lazy (try_find_reference ["Classes"; "RelationClasses"] "transitivity")
-
-let coq_inverse = lazy (gen_constant (* ["Classes"; "RelationClasses"] "inverse" *)
-			   ["Program"; "Basics"] "flip")
-
-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 forall_relation = lazy (gen_constant ["Classes"; "Morphisms"] "forall_relation")
-let pointwise_relation = lazy (gen_constant ["Classes"; "Morphisms"] "pointwise_relation")
-
-let respectful = lazy (gen_constant ["Classes"; "Morphisms"] "respectful")
-
-let default_relation = lazy (gen_constant ["Classes"; "SetoidTactics"] "DefaultRelation")
-
-let subrelation = lazy (gen_constant ["Classes"; "RelationClasses"] "subrelation")
-let do_subrelation = lazy (gen_constant ["Classes"; "Morphisms"] "do_subrelation")
-let apply_subrelation = lazy (gen_constant ["Classes"; "Morphisms"] "apply_subrelation")
-
-let coq_relation = lazy (gen_constant ["Relations";"Relation_Definitions"] "relation")
-let mk_relation a = mkApp (Lazy.force coq_relation, [| a |])
-(* let mk_relation a = mkProd (Anonymous, a, mkProd (Anonymous, a, new_Type ())) *)
-
-let rewrite_relation_class = lazy (gen_constant ["Classes"; "RelationClasses"] "RewriteRelation")
-
-let proper_type = lazy (constr_of_global (Lazy.force proper_class).cl_impl)
-
-let proper_proxy_type = lazy (constr_of_global (Lazy.force proper_proxy_class).cl_impl)
-
-let is_applied_rewrite_relation env sigma rels t =
-  match kind_of_term t with
-  | App (c, args) when Array.length args >= 2 ->
-      let head = if isApp c then fst (destApp c) else c in
-	if eq_constr (Lazy.force coq_eq) head then None
-	else
-	  (try
-	      let params, args = array_chop (Array.length args - 2) args in
-	      let env' = Environ.push_rel_context rels env in
-	      let evd, evar = Evarutil.new_evar sigma env' (new_Type ()) in
-	      let inst = mkApp (Lazy.force rewrite_relation_class, [| evar; mkApp (c, params) |]) in
-	      let _ = Typeclasses.resolve_one_typeclass env' evd inst in
-		Some (it_mkProd_or_LetIn t rels)
-	  with e when Errors.noncritical e -> None)
-  | _ -> None
-
-let _ =
-  Equality.register_is_applied_rewrite_relation is_applied_rewrite_relation
-
-let split_head = function
-    hd :: tl -> hd, tl
-  | [] -> assert(false)
-
-let new_cstr_evar (goal,cstr) env t =
-  let cstr', t = Evarutil.new_evar cstr env t in
-    (goal, cstr'), t
-
-let new_goal_evar (goal,cstr) env t =
-  let goal', t = Evarutil.new_evar goal env t in
-    (goal', cstr), t
-
-let build_signature evars env m (cstrs : (types * types option) option list)
-    (finalcstr : (types * types option) option) =
-  let new_evar evars env t =
-    new_cstr_evar evars env
-      (* ~src:(dummy_loc, ImplicitArg (ConstRef (Lazy.force respectful), (n, Some na))) *) t
-  in
-  let mk_relty evars newenv ty obj =
-    match obj with
-      | None | Some (_, None) ->
-	  let relty = mk_relation ty in
-	    if closed0 ty then 
-	      let env' = Environ.reset_with_named_context (Environ.named_context_val env) env in
-		new_evar evars env' relty
-	    else new_evar evars newenv relty
-      | Some (x, Some rel) -> evars, rel
-  in
-  let rec aux env evars ty l =
-    let t = Reductionops.whd_betadeltaiota env (fst evars) ty in
-      match kind_of_term t, l with
-      | Prod (na, ty, b), obj :: cstrs ->
-	  if noccurn 1 b (* non-dependent product *) then
-	    let ty = Reductionops.nf_betaiota (fst evars) ty in
-	    let (evars, b', arg, cstrs) = aux env evars (subst1 mkProp b) cstrs in
-	    let evars, relty = mk_relty evars env ty obj in
-	    let newarg = mkApp (Lazy.force respectful, [| ty ; b' ; relty ; arg |]) in
-	      evars, mkProd(na, ty, b), newarg, (ty, Some relty) :: cstrs
-	  else
-	    let (evars, b, arg, cstrs) = aux (Environ.push_rel (na, None, ty) env) evars b cstrs in
-	    let ty = Reductionops.nf_betaiota (fst evars) ty in
-	    let pred = mkLambda (na, ty, b) in
-	    let liftarg = mkLambda (na, ty, arg) in
-	    let arg' = mkApp (Lazy.force forall_relation, [| ty ; pred ; liftarg |]) in
-	      if obj = None then evars, mkProd(na, ty, b), arg', (ty, None) :: cstrs
-	      else error "build_signature: no constraint can apply on a dependent argument"
-      | _, obj :: _ -> anomaly "build_signature: not enough products"
-      | _, [] ->
-	  (match finalcstr with
-	  | None | Some (_, None) ->
-	      let t = Reductionops.nf_betaiota (fst evars) ty in
-	      let evars, rel = mk_relty evars env t None in
-		evars, t, rel, [t, Some rel]
-	  | Some (t, Some rel) -> evars, t, rel, [t, Some rel])
-  in aux env evars m cstrs
-
-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
-      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
-let get_symmetric_proof env = find_class_proof symmetric_type symmetric_proof env
-let get_transitive_proof env = find_class_proof transitive_type transitive_proof env
-
-exception FoundInt of int
-
-let array_find (arr: 'a array) (pred: int -> 'a -> bool): int =
-  try
-    for i=0 to Array.length arr - 1 do if pred i (arr.(i)) then raise (FoundInt i) done;
-    raise Not_found
-  with FoundInt i -> i
-
-type hypinfo = {
-  cl : clausenv;
-  prf : constr;
-  car : constr;
-  rel : constr;
-  l2r : bool;
-  c1 : constr;
-  c2 : constr;
-  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 e when Errors.noncritical e -> false
-
-let rec decompose_app_rel env evd t = 
-  match kind_of_term t with
-  | App (f, args) -> 
-      if Array.length args > 1 then 
-	let fargs, args = array_chop (Array.length args - 2) args in
-	  mkApp (f, fargs), args
-      else 
-	let (f', args) = decompose_app_rel env evd args.(0) in
-	let ty = Typing.type_of env evd args.(0) in
-	let f'' = mkLambda (Name (id_of_string "x"), ty,
-	  mkLambda (Name (id_of_string "y"), lift 1 ty,
-	    mkApp (lift 2 f, [| mkApp (lift 2 f', [| mkRel 2; mkRel 1 |]) |])))
-	in (f'', args)
-  | _ -> error "The term provided is not an applied relation."
-
-(*   let nc, c', cl = push_rel_context_to_named_context env c in *)
-(*   let env' = reset_with_named_context nc env in *)
-
-let decompose_applied_relation env sigma flags orig (c,l) left2right =
-  let c' = c in
-  let ctype = Typing.type_of env sigma c' in
-  let find_rel ty =
-    let eqclause = Clenv.make_clenv_binding_env_apply env sigma None (c',ty) l in
-    let (equiv, args) = decompose_app_rel env eqclause.evd (Clenv.clenv_type eqclause) in
-    let c1 = args.(0) and c2 = args.(1) in 
-    let ty1, ty2 =
-      Typing.type_of env eqclause.evd c1, Typing.type_of env eqclause.evd c2
-    in
-      if not (evd_convertible env eqclause.evd ty1 ty2) then None
-      else
-	Some { cl=eqclause; prf=(Clenv.clenv_value eqclause);
-	       car=ty1; rel = equiv;
-	       l2r=left2right; c1=c1; c2=c2; c=orig; abs=None;
-	       flags = flags }
-  in
-    match find_rel ctype with
-    | Some c -> c
-    | None ->
-	let ctx,t' = Reductionops.splay_prod_assum env sigma ctype in (* Search for underlying eq *)
-	match find_rel (it_mkProd_or_LetIn t' ctx) with
-	| Some c -> c
-	| None -> error "The term does not end with an applied homogeneous relation."
-
-open Tacinterp
-let decompose_applied_relation_expr env sigma flags (is, (c,l)) left2right =
-  let sigma, cbl = Tacinterp.interp_open_constr_with_bindings false 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 _ = 
-  Auto.add_auto_init
-    (fun () ->
-       Auto.create_hint_db false rewrite_db conv_transparent_state true)
-
-let rewrite_transparent_state () =
-  Auto.Hint_db.transparent_state (Auto.searchtable_map rewrite_db)
-
-let rewrite_unif_flags = {
-  Unification.modulo_conv_on_closed_terms = None;
-  Unification.use_metas_eagerly_in_conv_on_closed_terms = true;
-  Unification.modulo_delta = empty_transparent_state;
-  Unification.modulo_delta_types = full_transparent_state;
-  Unification.modulo_delta_in_merge = None;
-  Unification.check_applied_meta_types = true;
-  Unification.resolve_evars = true;
-  Unification.use_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 rewrite2_unif_flags =
-  {  Unification.modulo_conv_on_closed_terms = Some conv_transparent_state;
-     Unification.use_metas_eagerly_in_conv_on_closed_terms = true;
-     Unification.modulo_delta = empty_transparent_state;
-     Unification.modulo_delta_types = conv_transparent_state;
-     Unification.modulo_delta_in_merge = None;
-     Unification.check_applied_meta_types = true;
-     Unification.resolve_evars = true;
-     Unification.use_pattern_unification = true;
-     Unification.use_meta_bound_pattern_unification = true;
-     Unification.frozen_evars = ExistentialSet.empty;
-     Unification.restrict_conv_on_strict_subterms = false;
-     Unification.modulo_betaiota = true;
-     Unification.modulo_eta = true;
-     Unification.allow_K_in_toplevel_higher_order_unification = true
-  }
-
-let general_rewrite_unif_flags () = 
-  let ts = rewrite_transparent_state () in
-    {  Unification.modulo_conv_on_closed_terms = Some ts;
-       Unification.use_metas_eagerly_in_conv_on_closed_terms = true;
-       Unification.modulo_delta = ts;
-       Unification.modulo_delta_types = ts;
-       Unification.modulo_delta_in_merge = None;
-       Unification.check_applied_meta_types = true;
-       Unification.resolve_evars = true;
-       Unification.use_pattern_unification = true;
-       Unification.use_meta_bound_pattern_unification = true;
-       Unification.frozen_evars = ExistentialSet.empty;
-       Unification.restrict_conv_on_strict_subterms = false;
-       Unification.modulo_betaiota = true;
-       Unification.modulo_eta = true;
-       Unification.allow_K_in_toplevel_higher_order_unification = true }
-
-let convertible env evd x y =
-  Reductionops.is_conv env evd x y
-
-let refresh_hypinfo env sigma hypinfo =
-  if hypinfo.abs = None then
-    let {l2r=l2r; c=c;cl=cl;flags=flags} = hypinfo in
-      match c with
-	| Some c ->
-	    (* Refresh the clausenv to not get the same meta twice in the goal. *)
-	    decompose_applied_relation_expr env sigma flags c l2r;
-	| _ -> hypinfo
-  else hypinfo
-
-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 env', prf, c1, c2, car, rel =
-      match abs with
-      | Some (absprf, absprfty) ->
-	  let env' = clenv_unify ~flags:rewrite_unif_flags CONV left t cl in
-	    env', prf, c1, c2, car, rel
-      | None ->
-	  let env' = clenv_unify ~flags:!hypinfo.flags CONV left t cl
-	  in
-	  let env' = Clenvtac.clenv_pose_dependent_evars true env' in
-(* 	  let 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
-	  let c1 = nf c1 and c2 = nf c2
-	  and car = nf car and rel = nf rel
-	  and prf = nf (Clenv.clenv_value env') in
-	  let ty1 = Typing.type_of env'.env env'.evd c1
-	  and ty2 = Typing.type_of env'.env env'.evd c2
-	  in
-	    if convertible env env'.evd ty1 ty2 then (
-	      if 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 env'.evd car rel,
-		   [| c1 ; c2 ; prf |]),
-	    (car, rel, c2, c1))
-	with Not_found ->
-	  (prf, (car, inverse car rel, c2, c1))
-    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_all t =
-  match kind_of_term t with
-    | App (id, [| a; b |]) (* when eq_constr id (Lazy.force coq_all) *) ->
-	(match kind_of_term b with
-	  | Lambda (n, ty, b) -> mkProd (n, ty, b)
-	  | _ -> assert false)
-    | _ -> assert false
-
-let unfold_forall t =
-  match kind_of_term t with
-    | App (id, [| a; b |]) (* when eq_constr id (Lazy.force coq_all) *) ->
-	(match kind_of_term b with
-	  | Lambda (n, ty, b) -> mkProd (n, ty, b)
-	  | _ -> assert false)
-    | _ -> assert false
-
-let arrow_morphism ta tb a b =
-  let ap = is_Prop ta and bp = is_Prop tb in
-    if ap && bp then mkApp (Lazy.force impl, [| a; b |]), unfold_impl
-    else if ap then (* Domain in Prop, CoDomain in Type *)
-      mkProd (Anonymous, a, b), (fun x -> x)
-    else if bp then (* Dummy forall *)
-      mkApp (Lazy.force coq_all, [| a; mkLambda (Anonymous, a, b) |]), unfold_forall
-    else (* None in Prop, use arrow *)
-      mkApp (Lazy.force arrow, [| a; b |]), unfold_impl
-
-let rec decomp_pointwise n c =
-  if n = 0 then c
-  else
-    match kind_of_term c with
-    | App (f, [| a; b; relb |]) when eq_constr f (Lazy.force pointwise_relation) ->
-	decomp_pointwise (pred n) relb
-    | App (f, [| a; b; arelb |]) when eq_constr f (Lazy.force forall_relation) ->
-	decomp_pointwise (pred n) (Reductionops.beta_applist (arelb, [mkRel 1]))
-    | _ -> raise (Invalid_argument "decomp_pointwise")
-	
-let rec apply_pointwise rel = function
-  | arg :: args ->
-      (match kind_of_term rel with
-      | App (f, [| a; b; relb |]) when eq_constr f (Lazy.force pointwise_relation) ->
-	  apply_pointwise relb args
-      | App (f, [| a; b; arelb |]) when eq_constr f (Lazy.force forall_relation) ->
-	  apply_pointwise (Reductionops.beta_applist (arelb, [arg])) args
-      | _ -> raise (Invalid_argument "apply_pointwise"))
-  | [] -> rel
-
-let pointwise_or_dep_relation n t car rel =
-  if noccurn 1 car && noccurn 1 rel then
-    mkApp (Lazy.force pointwise_relation, [| t; lift (-1) car; lift (-1) rel |])
-  else
-    mkApp (Lazy.force forall_relation, 
-	  [| t; mkLambda (n, t, car); mkLambda (n, t, rel) |])
-
-let lift_cstr env 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 = 
-    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) in
-	      mkApp (Lazy.force pointwise_relation, [| ty; b'; rb |])
-	  else
-	    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
-  | Some codom -> Some (decomp_pointwise 1 codom)
-
-type rewrite_flags = { under_lambdas : bool; on_morphisms : bool }
-
-let default_flags = { under_lambdas = true; on_morphisms = true; }
-
-type evars = evar_map * evar_map (* goal evars, constraint evars *)
-
-type rewrite_proof = 
-  | RewPrf of constr * constr
-  | RewCast of cast_kind
-
-let get_opt_rew_rel = function RewPrf (rel, prf) -> Some rel | _ -> None
-
-type rewrite_result_info = {
-  rew_car : constr;
-  rew_from : constr;
-  rew_to : constr;
-  rew_prf : rewrite_proof;
-  rew_evars : evars;
-}
-
-type rewrite_result = rewrite_result_info option
-
-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) -> rel, prf 
-  | RewCast c ->
-    let rel = mkApp (Coqlib.build_coq_eq (), [| r.rew_car |]) in
-      rel, mkCast (mkApp (Coqlib.build_coq_eq_refl (), [| r.rew_car; r.rew_from |]),
-		   c, mkApp (rel, [| r.rew_from; r.rew_to |]))
-
-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 *)
-(* 	{ res with rew_evars = evd' } *)
-(*   with NotConvertible -> *)
-    let app = mkApp (Lazy.force subrelation, [|car; rel; rel'|]) in
-    let evars, subrel = new_cstr_evar res.rew_evars env app in
-    let appsub = mkApp (subrel, [| res.rew_from ; res.rew_to ; prf |]) in
-      { res with
-	rew_prf = RewPrf (rel', appsub);
-	rew_evars = evars }
-
-let resolve_morphism env avoid oldt m ?(fnewt=fun x -> x) args args' cstr evars =
-  let 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 (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
-    in
-      (* Actual signature found *)
-    let cl_args = [| appmtype' ; signature ; appm |] in
-    let app = mkApp (Lazy.force proper_type, cl_args) in
-    let env' = Environ.push_named
-      (id_of_string "do_subrelation", Some (Lazy.force do_subrelation), Lazy.force apply_subrelation)
-      env
-    in
-    let evars, morph = new_cstr_evar evars env' app in
-      evars, morph, morph, sigargs, appm, morphobjs, morphobjs'
-  in
-  let projargs, subst, evars, respars, typeargs =
-    array_fold_left2
-      (fun (acc, subst, evars, sigargs, typeargs') x y ->
-	let (carrier, relation), sigargs = split_head sigargs in
-	  match relation with
-	  | Some relation ->
-	      let carrier = substl subst carrier
-	      and relation = substl subst relation in
-	      (match y with
-	      | None ->
-		  let evars, proof = proper_proof env evars carrier relation x in
-		    [ proof ; x ; x ] @ acc, subst, evars, sigargs, x :: typeargs'
-	      | Some r ->
-		  [ snd (get_rew_prf r); r.rew_to; x ] @ acc, subst, evars, 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')
-      ([], [], evars, sigargs, []) args args'
-  in
-  let proof = applistc proj (List.rev projargs) in
-  let newt = applistc m' (List.rev typeargs) in
-    match respars with
-	[ a, Some r ] -> evars, proof, a, r, oldt, fnewt newt
-      | _ -> assert(false)
-
-let apply_constraint env avoid car rel prf cstr res =
-  match cstr with
-  | None -> res
-  | Some r -> resolve_subrelation env avoid car rel prf r res
-
-let eq_env x y = x == y
-
-let apply_rule hypinfo loccs : strategy =
-  let (nowhere_except_in,occs) = loccs in
-  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 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 (evd', (prf, (car, rel, c1, c2))) when is_occ !occ ->
-	    begin
-	      if eq_constr t c2 then Some None
-	      else
-		let res = { rew_car = ty; rew_from = c1;
-			    rew_to = c2; rew_prf = RewPrf (rel, prf); 
-			    rew_evars = evd', cstrevars evars }
-		in Some (Some (apply_constraint env avoid car rel prf cstr res))
-	    end
-	| _ -> None
-
-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 = 
-    match r.rew_prf with
-    | RewPrf (rel, prf) -> 
-	let rel = mkApp (Lazy.force coq_eq, [| ty |]) in
-	let prf =
-	  mkApp (Lazy.force coq_f_equal,
-		[| r.rew_car; ty;
-		   mkLambda (Anonymous, r.rew_car, c);
-		   r.rew_from; r.rew_to; prf |])
-	in RewPrf (rel, prf)
-    | RewCast k -> r.rew_prf
-  in
-    { r with rew_car = ty; 
-      rew_from = subst1 r.rew_from c; rew_to = subst1 r.rew_to c; rew_prf = prf }
-
-open Elimschemes
-
-let reset_env env =
-  let env' = Global.env_of_context (Environ.named_context_val env) in
-    Environ.push_rel_context (Environ.rel_context env) env'
-      
-let fold_match ?(force=false) env sigma c =
-  let (ci, p, c, brs) = destCase c in
-  let cty = Retyping.get_type_of env sigma c in
-  let dep, pred, exists, sk = 
-    let env', ctx, body =
-      let ctx, pred = decompose_lam_assum p in
-      let env' = Environ.push_rel_context ctx env in
-	env', ctx, pred
-    in
-    let sortp = Retyping.get_sort_family_of env' sigma body in
-    let sortc = Retyping.get_sort_family_of env sigma cty in
-    let dep = not (noccurn 1 body) in
-    let pred = if dep then p else
-	it_mkProd_or_LetIn (subst1 mkProp body) (List.tl ctx)
-    in
-    let sk = 
-      if sortp = InProp then
-	if sortc = InProp then
-	  if dep then case_dep_scheme_kind_from_prop
-	  else case_scheme_kind_from_prop
-	else (
-	  if dep
-	  then case_dep_scheme_kind_from_type_in_prop
-	  else case_scheme_kind_from_type)
-      else ((* sortc <> InProp by typing *)
-	if dep
-	then case_dep_scheme_kind_from_type
-	else case_scheme_kind_from_type)
-    in 
-    let exists = Ind_tables.check_scheme sk ci.ci_ind in
-      if exists || force then
-	dep, pred, exists, Ind_tables.find_scheme sk ci.ci_ind
-      else raise Not_found
-  in
-  let app =
-    let ind, args = Inductive.find_rectype env cty in
-    let pars, args = list_chop ci.ci_npar args in
-    let meths = List.map (fun br -> br) (Array.to_list brs) in
-      applist (mkConst sk, pars @ [pred] @ meths @ args @ [c])
-  in 
-    sk, (if exists then env else reset_env env), app
-      
-let unfold_match env sigma sk app =
-  match kind_of_term app with
-  | App (f', args) when f' = mkConst sk ->
-      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 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) ->
-	  let rewrite_args success =
-	    let args', evars', progress =
-	      Array.fold_left
-		(fun (acc, evars, progress) arg ->
-		  if progress <> None && not all then (None :: acc, evars, progress)
-		  else
-		    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)
-		      | None -> (None :: acc, evars, progress))
-		([], evars, success) args
-	    in
-	      match progress with
-	      | None -> None
-	      | Some false -> Some None
-	      | Some true ->
-		  let args' = Array.of_list (List.rev args') in
-		    if array_exists
-		      (function 
-			 | None -> false 
-			 | 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 (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)
-		| Some (Some r) ->
-		    (* We rewrote the function and get a proof of pointwise rel for the arguments.
-		       We just apply it. *)
-		    let prf = match r.rew_prf with
-		      | RewPrf (rel, prf) ->
-			  RewPrf (apply_pointwise rel argsl, mkApp (prf, args))
-		      | x -> x
-		    in
-		    let res =
-		      { rew_car = prod_appvect r.rew_car args;
-			rew_from = mkApp(r.rew_from, args); rew_to = mkApp(r.rew_to, args);
-			rew_prf = prf;
-			rew_evars = r.rew_evars }
-		    in 
-		      match prf with
-		      | RewPrf (rel, prf) ->
-			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 (goalevars evars) x and tb = Typing.type_of env (goalevars evars) b in
-	  let mor, unfold = arrow_morphism tx tb x b in
-	  let res = aux env avoid mor ty cstr evars in
-	    (match res with
-	    | Some (Some r) -> Some (Some { r with rew_to = unfold r.rew_to })
-	    | _ -> res)
-
-      (* 		if x' = None && flags.under_lambdas then *)
-      (* 		  let lam = mkLambda (n, x, b) in *)
-      (* 		  let lam', occ = aux env lam occ None in *)
-      (* 		  let res =  *)
-      (* 		    match lam' with *)
-      (* 		    | None -> None *)
-      (* 		    | Some (prf, (car, rel, c1, c2)) -> *)
-      (* 			Some (resolve_morphism env sigma t *)
-      (* 				 ~fnewt:unfold_all *)
-      (* 				 (Lazy.force coq_all) [| x ; lam |] [| None; lam' |] *)
-      (* 				 cstr evars) *)
-      (* 		  in res, occ *)
-      (* 		else *)
-
-      | Prod (n, dom, codom) ->
-	  let lam = mkLambda (n, dom, codom) 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 r.rew_to })
-	     | _ -> res)
-
-      | Lambda (n, t, b) when flags.under_lambdas ->
-	  let n' = name_app (fun id -> Tactics.fresh_id_in_env avoid id env) n in
-	  let env' = Environ.push_rel (n', None, t) env in
-	  let 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
-			RewPrf (rel, prf)
-		  | x -> x
-		in
-		  Some (Some { r with
-		    rew_prf = prf;
-		    rew_car = mkProd (n, t, r.rew_car);
-		    rew_from = mkLambda(n, t, r.rew_from);
-		    rew_to = mkLambda (n, t, r.rew_to) })
-	    | _ -> b')
-
-      | Case (ci, p, c, brs) ->
-	  let cty = Typing.type_of env (goalevars evars) c in
-	  let cstr' = Some (mkApp (Lazy.force coq_eq, [| cty |])) in
-	  let c' = s env avoid c cty cstr' evars in
-	  let res = 
-	    match c' with
-	    | Some (Some 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_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
-	      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
-let one_subterm = subterm false default_flags
-
-(** Requires transitivity of the rewrite step, if not a reduction.
-    Not tail-recursive. *)
-
-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') ->
-      match res.rew_prf with
-      | RewCast c -> Some (Some { res' with rew_from = res.rew_from })
-      | RewPrf (rew_rel, rew_prf) ->
-	  match res'.rew_prf with
-	  | RewCast _ -> Some (Some ({ res with rew_to = res'.rew_to }))
-	  | RewPrf (res'_rel, res'_prf) ->
-	      let prfty = mkApp (Lazy.force transitive_type, [| res.rew_car; rew_rel |]) in
-	      let evars, prf = new_cstr_evar res'.rew_evars env prfty in
-	      let prf = mkApp (prf, [|res.rew_from; res'.rew_from; res'.rew_to;
-				      rew_prf; res'_prf |])
-	      in Some (Some { res' with rew_from = res.rew_from; 
-		rew_evars = evars; rew_prf = RewPrf (res'_rel, prf) })
-		
-(** Rewriting strategies.
-
-    Inspired by ELAN's rewriting strategies:
-    http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.21.4049
-*)
-
-module Strategies =
-  struct
-
-    let fail : strategy =
-      fun env avoid t ty cstr evars -> None
-
-    let id : strategy =
-      fun env avoid t ty cstr evars -> Some None
-
-    let refl : strategy =
-      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
-	in
-	let evars, proof =
-	  let mty = mkApp (Lazy.force proper_proxy_type, [| ty ; rel; t |]) in
-	    new_cstr_evar evars env mty
-	in
-	  Some (Some { rew_car = ty; rew_from = t; rew_to = t;
-		       rew_prf = RewPrf (rel, proof); rew_evars = evars })
-
-    let progress (s : strategy) : strategy =
-      fun env avoid t ty cstr evars ->
-	match s env avoid t ty cstr evars with
-	| None -> None
-	| Some None -> None
-	| r -> r
-
-    let seq fst snd : strategy =
-      fun env avoid t ty cstr evars ->
-	match fst env avoid t ty cstr evars with
-	| None -> None
-	| Some None -> snd env avoid t ty cstr evars
-	| Some (Some res) -> transitivity env avoid res snd
-
-    let choice fst snd : strategy =
-      fun env avoid t ty cstr evars ->
-	match fst env avoid t ty cstr evars with
-	| None -> snd env avoid t ty cstr evars
-	| res -> res
-
-    let try_ str : strategy = choice str id
-
-    let fix (f : strategy -> strategy) : strategy =
-      let rec aux env = f (fun env -> aux env) env in aux
-
-    let any (s : strategy) : strategy =
-      fix (fun any -> try_ (seq s any))
-
-    let repeat (s : strategy) : strategy =
-      seq s (any s)
-
-    let bu (s : strategy) : strategy =
-      fix (fun s' -> seq (choice (progress (all_subterms s')) s) (try_ s'))
-
-    let td (s : strategy) : strategy =
-      fix (fun s' -> seq (choice s (progress (all_subterms s'))) (try_ s'))
-
-    let innermost (s : strategy) : strategy =
-      fix (fun ins -> choice (one_subterm ins) s)
-
-    let outermost (s : strategy) : strategy =
-      fix (fun out -> choice s (one_subterm out))
-
-    let lemmas flags cs : strategy =
-      List.fold_left (fun tac (l,l2r) ->
-	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 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 avoid t ty cstr evars ->
-      let rules = Autorewrite.find_matches db t in
-      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 avoid t ty cstr evars ->
-	  let t' = rfn env (goalevars evars) t in
-	    if eq_constr t' t then
-	      Some None
-	    else
-	      Some (Some { rew_car = ty; rew_from = t; rew_to = t';
-			   rew_prf = RewCast ckind; rew_evars = evars })
-	
-    let fold c : strategy =
-      fun env avoid t ty cstr evars ->
-(* 	let sigma, (c,_) = Tacinterp.interp_open_constr_with_bindings is env (goalevars evars) c in *)
-	let sigma, c = Constrintern.interp_open_constr (goalevars evars) env c in
-	let unfolded =
-	  try Tacred.try_red_product env sigma c
-	  with e when Errors.noncritical e ->
-            error "fold: the term is not unfoldable !"
-	in
-	  try
-	    let sigma = Unification.w_unify env sigma CONV ~flags:Unification.elim_flags unfolded t in
-	    let c' = Evarutil.nf_evar sigma c in
-	      Some (Some { rew_car = ty; rew_from = t; rew_to = c';
-			   rew_prf = RewCast DEFAULTcast; 
-			   rew_evars = sigma, cstrevars evars })
-	  with e when Errors.noncritical e -> None
-
-    let fold_glob c : strategy =
-      fun env avoid t ty cstr evars ->
-(* 	let sigma, (c,_) = Tacinterp.interp_open_constr_with_bindings is env (goalevars evars) c in *)
-	let sigma, c = Pretyping.Default.understand_tcc (goalevars evars) env c in
-	let unfolded =
-	  try Tacred.try_red_product env sigma c
-	  with e when Errors.noncritical e ->
-            error "fold: the term is not unfoldable !"
-	in
-	  try
-	    let sigma = Unification.w_unify env sigma CONV ~flags:Unification.elim_flags unfolded t in
-	    let c' = Evarutil.nf_evar sigma c in
-	      Some (Some { rew_car = ty; rew_from = t; rew_to = c';
-			   rew_prf = RewCast DEFAULTcast; 
-			   rew_evars = sigma, cstrevars evars })
-	  with e when Errors.noncritical e -> None
-  
-
-end
-
-(** The strategy for a single rewrite, dealing with occurences. *)
-
-let rewrite_strat flags occs hyp =
-  let app = apply_rule hyp occs in
-  let rec aux () =
-    Strategies.choice app (subterm true flags (fun env -> aux () env))
-  in aux ()
-
-let get_hypinfo_ids {c = opt} =
-  match opt with
-  | None -> []
-  | Some (is, gc) -> List.map fst is.lfun @ is.avoid_ids
-
-let rewrite_with flags c left2right loccs : strategy =
-  fun env avoid t ty cstr evars ->
-    let gevars = goalevars evars in
-    let hypinfo = ref (decompose_applied_relation_expr env gevars flags c left2right) in
-    let avoid = get_hypinfo_ids !hypinfo @ avoid in
-      rewrite_strat default_flags loccs hypinfo env avoid t ty cstr (gevars, cstrevars evars)
-
-let apply_strategy (s : strategy) env avoid concl cstr evars =
-  let res =
-    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) ->
-	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)
-
-let nf_zeta =
-  Reductionops.clos_norm_flags (Closure.RedFlags.mkflags [Closure.RedFlags.fZETA])
-
-let map_rewprf f = function
-  | RewPrf (rel, prf) -> RewPrf (f rel, f prf)
-  | RewCast c -> RewCast c
-
-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
-      match is_hyp with
-      | None -> (sort, inverse sort impl)
-      | Some _ -> (sort, impl)
-  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, evars, car, oldt, newt)) ->
-	let evars' = solve_constraints env evars in
-	let p = map_rewprf (fun p -> nf_zeta env evars' (Evarutil.nf_evar evars' p)) p in
-	let newt = Evarutil.nf_evar evars' newt in
-	let abs = Option.map (fun (x, y) ->
-				Evarutil.nf_evar evars' x, Evarutil.nf_evar evars' y) abs in
-	let evars = (* Keep only original evars (potentially instantiated) and goal evars,
-		       the rest has been defined and substituted already. *)
-(* 	  let cstrs = cstrevars evars in *)
-	    (* cstrs is small *)
-	  let gevars = goalevars evars in
-	    Evd.fold (fun ev evi acc -> 
-			if Evd.mem gevars ev then Evd.add acc ev evi
-			else acc) evars' Evd.empty
-(* 	    Evd.fold (fun ev evi acc -> Evd.remove acc ev) cstrs evars' *)
-	in
-	let res =
-	  match is_hyp with
-	  | Some id ->
-	      (match p with
-	       | RewPrf (rel, p) ->
-		   let term =
-		     match abs with
-		     | None -> p
-		     | Some (t, ty) ->
-			 mkApp (mkLambda (Name (id_of_string "lemma"), ty, p), [| t |])
-		   in
-		     Some (evars, Some (mkApp (term, [| mkVar id |])), newt)
-	       | RewCast c ->
-		   Some (evars, None, newt))
-		
-	  | None ->
-	      (match p with
-	       | RewPrf (rel, p) ->
-		   (match abs with
-		    | None -> Some (evars, Some p, newt)
-		    | Some (t, ty) ->
-			let proof = mkApp (mkLambda (Name (id_of_string "lemma"), ty, p), [| t |]) in
-			  Some (evars, Some proof, newt))
-	       | RewCast c -> Some (evars, None, newt))
-	in Some res
-    | Some None -> Some None
-    | None -> None
-		   
-let rewrite_refine (evd,c) = 
-  Tacmach.refine c
-
-let cl_rewrite_clause_tac ?abs strat meta clause gl =
-  let evartac evd = Refiner.tclEVARS evd in
-  let treat res =
-    match res with
-    | None -> tclFAIL 0 (str "Nothing to rewrite")
-    | Some None ->
-	tclFAIL 0 (str"No progress made")
-    | Some (Some (undef, p, newt)) ->
-	let tac = 
-	  match clause, p with
-	  | Some id, Some p ->
-	      cut_replacing id newt (Tacmach.refine p)
-	  | Some id, None -> 
-	      change_in_hyp None newt (id, InHypTypeOnly)
-	  | None, Some p ->
-	      let name = next_name_away_with_default "H" Anonymous (pf_ids_of_hyps gl) in
-		tclTHENLAST
-		  (Tacmach.internal_cut_no_check false name newt)
-		  (tclTHEN (Tactics.revert [name]) (Tacmach.refine p))
-	  | None, None -> change_in_concl None newt
-	in tclTHEN (evartac undef) tac
-  in
-  let tac =
-    try
-      let concl, is_hyp =
-	match clause with
-	| Some id -> pf_get_hyp_typ gl id, Some id
-	| None -> pf_concl gl, None
-      in
-      let sigma = project gl in
-      let concl = Evarutil.nf_evar sigma concl in 
-      let res = cl_rewrite_clause_aux ?abs strat (pf_env gl) [] sigma concl is_hyp in
-	treat res
-    with
-    | Loc.Exc_located (_, TypeClassError (env, (UnsatisfiableConstraints _ as e)))
-    | TypeClassError (env, (UnsatisfiableConstraints _ as e)) ->
-	Refiner.tclFAIL_lazy 0
-	  (lazy (str"Unable to satisfy the rewriting constraints."
-		 ++ fnl () ++ Himsg.explain_typeclass_error env e))
-  in tac gl
-
-open Goal
-open Environ
-
-let bind_gl_info f =
-  bind concl (fun c -> bind env (fun v -> bind defs (fun ev -> f c v ev))) 
-
-let fail l s =
-  raise (Refiner.FailError (l, lazy s))
-
-let new_refine c : Goal.subgoals Goal.sensitive =
-  let refable = Goal.Refinable.make
-    (fun handle -> Goal.Refinable.constr_of_open_constr handle true c) 
-  in Goal.bind refable Goal.refine
-
-let assert_replacing id newt tac = 
-  let sens = bind_gl_info 
-    (fun concl env sigma ->
-       let nc' = 
-	 Environ.fold_named_context
-	   (fun _ (n, b, t as decl) nc' ->
-	      if n = id then (n, b, newt) :: nc'
-	      else decl :: nc')
-	   env ~init:[]
-       in
-       let reft = Refinable.make 
-	 (fun h -> 
-	    Goal.bind (Refinable.mkEvar h
-			 (Environ.reset_with_named_context (val_of_named_context nc') env) concl)
-	      (fun ev -> 
-		 Goal.bind (Refinable.mkEvar h env newt)
-		   (fun ev' ->
-		      let inst = 
-			fold_named_context
-			  (fun _ (n, b, t) inst ->
-			     if n = id then ev' :: inst
-			     else if b = None then mkVar n :: inst else inst)
-			  env ~init:[]
-		      in
-		      let (e, args) = destEvar ev in
-			Goal.return (mkEvar (e, Array.of_list inst)))))
-       in Goal.bind reft Goal.refine)
-  in Proofview.tclTHEN (Proofview.tclSENSITIVE sens) 
-       (Proofview.tclFOCUS 2 2 tac)
-
-let newfail n s = 
-  Proofview.tclZERO (Refiner.FailError (n, lazy s))
-
-let cl_rewrite_clause_newtac ?abs strat clause =
-  let treat (res, is_hyp) = 
-    match res with
-    | None -> newfail 0 (str "Nothing to rewrite")
-    | Some None ->
-	newfail 0 (str"No progress made")
-    | Some (Some res) ->
-	match is_hyp, res with
-	| Some id, (undef, Some p, newt) ->
-	    assert_replacing id newt (Proofview.tclSENSITIVE (new_refine (undef, p)))
-	| Some id, (undef, None, newt) -> 
-	    Proofview.tclSENSITIVE (Goal.convert_hyp false (id, None, newt))
-	| None, (undef, Some p, newt) ->
-	    let refable = Goal.Refinable.make
-	      (fun handle -> 
-		 Goal.bind env
-		   (fun env -> Goal.bind (Refinable.mkEvar handle env newt)
-		      (fun ev ->
-			 Goal.Refinable.constr_of_open_constr handle true 
-			   (undef, mkApp (p, [| ev |])))))
-	    in
-	      Proofview.tclSENSITIVE (Goal.bind refable Goal.refine)
-	| None, (undef, None, newt) ->
-	    Proofview.tclSENSITIVE (Goal.convert_concl false newt)
-  in
-  let info =
-    bind_gl_info
-      (fun concl env sigma ->
-	 let ty, is_hyp =
-	   match clause with
-	   | Some id -> Environ.named_type id env, Some id
-	   | None -> concl, None
-	 in
-	 let res = 
-	   try cl_rewrite_clause_aux ?abs strat env [] sigma ty is_hyp 
-	   with
-	   | Loc.Exc_located (_, TypeClassError (env, (UnsatisfiableConstraints _ as e)))
-	   | TypeClassError (env, (UnsatisfiableConstraints _ as e)) ->
-	       fail 0 (str"setoid rewrite failed: unable to satisfy the rewriting constraints."
-		       ++ fnl () ++ Himsg.explain_typeclass_error env e)
-	 in return (res, is_hyp))
-  in Proofview.tclGOALBINDU info (fun i -> treat i)
-  
-let cl_rewrite_clause_new_strat ?abs strat clause =
-  init_setoid ();
-  cl_rewrite_clause_newtac ?abs strat clause
-
-let cl_rewrite_clause_newtac' l left2right occs clause =
-  Proof_global.run_tactic 
-    (Proofview.tclFOCUS 1 1 
-       (cl_rewrite_clause_new_strat (rewrite_with rewrite_unif_flags l left2right occs) clause))
-
-
-let tactic_init_setoid () = 
-  init_setoid (); tclIDTAC
-
-let cl_rewrite_clause_strat strat clause =
-  tclTHEN (tactic_init_setoid ())
-  (fun gl ->
-   let meta = Evarutil.new_meta() in
-     try cl_rewrite_clause_tac strat (mkMeta meta) clause gl
-     with
-     | Refiner.FailError (n, pp) -> 
-       tclFAIL n (str"setoid rewrite failed: " ++ Lazy.force pp) gl)
-
-let cl_rewrite_clause l left2right occs clause gl =
-  cl_rewrite_clause_strat (rewrite_with (general_rewrite_unif_flags ()) l left2right occs) clause gl
-
-open Pp
-open Pcoq
-open Names
-open Tacexpr
-open Tacinterp
-open Termops
-open Genarg
-open Extraargs
-
-let occurrences_of = function
-  | n::_ as nl when n < 0 -> (false,List.map abs nl)
-  | nl ->
-      if List.exists (fun n -> n < 0) nl then
-	error "Illegal negative occurrence number.";
-      (true,nl)
-
-let apply_constr_expr c l2r occs = fun env avoid t ty cstr evars ->
-  let evd, c = Constrintern.interp_open_constr (goalevars evars) env c in
-    apply_lemma (general_rewrite_unif_flags ()) (evd, (c, NoBindings)) 
-      l2r occs env avoid t ty cstr (evd, cstrevars evars)
-
-let apply_glob_constr c l2r occs = fun env avoid t ty cstr evars ->
-  let evd, c = (Pretyping.Default.understand_tcc (goalevars evars) env c) in
-    apply_lemma (general_rewrite_unif_flags ()) (evd, (c, NoBindings)) 
-      l2r occs env avoid t ty cstr (evd, cstrevars evars)
-
-let interp_constr_list env sigma =
-  List.map (fun c -> 
-	      let evd, c = Constrintern.interp_open_constr sigma env c in
-		(evd, (c, NoBindings)), true)
-
-let interp_glob_constr_list env sigma =
-  List.map (fun c -> 
-	      let evd, c = Pretyping.Default.understand_tcc sigma env c in
-		(evd, (c, NoBindings)), true)
-
-open Pcoq
-
-(* Syntax for rewriting with strategies *)
-
-type constr_expr_with_bindings = constr_expr with_bindings
-type glob_constr_with_bindings = glob_constr_and_expr with_bindings
-type glob_constr_with_bindings_sign = interp_sign * glob_constr_and_expr with_bindings
-
-let pr_glob_constr_with_bindings_sign _ _ _ (ge : glob_constr_with_bindings_sign) = Printer.pr_glob_constr (fst (fst (snd ge)))
-let pr_glob_constr_with_bindings _ _ _ (ge : glob_constr_with_bindings) = Printer.pr_glob_constr (fst (fst ge))
-let pr_constr_expr_with_bindings prc _ _ (ge : constr_expr_with_bindings) = prc (fst ge)
-let interp_glob_constr_with_bindings ist gl c = Tacmach.project gl , (ist, c)
-let glob_glob_constr_with_bindings ist l = Tacinterp.intern_constr_with_bindings ist l
-let subst_glob_constr_with_bindings s c = subst_glob_with_bindings s c
-
-
-ARGUMENT EXTEND glob_constr_with_bindings 
-    PRINTED BY pr_glob_constr_with_bindings_sign
-
-    INTERPRETED BY interp_glob_constr_with_bindings
-    GLOBALIZED BY glob_glob_constr_with_bindings
-    SUBSTITUTED BY subst_glob_constr_with_bindings
-
-    RAW_TYPED AS constr_expr_with_bindings
-    RAW_PRINTED BY pr_constr_expr_with_bindings
-
-    GLOB_TYPED AS glob_constr_with_bindings
-    GLOB_PRINTED BY pr_glob_constr_with_bindings
-   
-   [ constr_with_bindings(bl) ] -> [ bl ]
-END
-
-type ('constr,'redexpr) strategy_ast = 
-  | StratId | StratFail | StratRefl
-  | StratUnary of string * ('constr,'redexpr) strategy_ast
-  | StratBinary of string * ('constr,'redexpr) strategy_ast * ('constr,'redexpr) strategy_ast
-  | StratConstr of 'constr * bool
-  | StratTerms of 'constr list
-  | StratHints of bool * string
-  | StratEval of 'redexpr 
-  | StratFold of 'constr
-
-let rec map_strategy (f : 'a -> 'a2) (g : 'b -> 'b2) : ('a,'b) strategy_ast -> ('a2,'b2) strategy_ast = function
-  | StratId | StratFail | StratRefl as s -> s
-  | StratUnary (s, str) -> StratUnary (s, map_strategy f g str)
-  | StratBinary (s, str, str') -> StratBinary (s, map_strategy f g str, map_strategy f g str')
-  | StratConstr (c, b) -> StratConstr (f c, b)
-  | StratTerms l -> StratTerms (List.map f l)
-  | StratHints (b, id) -> StratHints (b, id)
-  | StratEval r -> StratEval (g r)
-  | StratFold c -> StratFold (f c)
-
-let rec strategy_of_ast = function
-  | StratId -> Strategies.id
-  | StratFail -> Strategies.fail
-  | StratRefl -> Strategies.refl
-  | StratUnary (f, s) -> 
-    let s' = strategy_of_ast s in
-    let f' = match f with
-      | "subterms" -> all_subterms
-      | "subterm" -> one_subterm
-      | "innermost" -> Strategies.innermost
-      | "outermost" -> Strategies.outermost
-      | "bottomup" -> Strategies.bu
-      | "topdown" -> Strategies.td
-      | "progress" -> Strategies.progress
-      | "try" -> Strategies.try_
-      | "any" -> Strategies.any
-      | "repeat" -> Strategies.repeat
-      | _ -> anomalylabstrm "strategy_of_ast" (str"Unkwnon strategy: " ++ str f)
-    in f' s'
-  | StratBinary (f, s, t) ->
-    let s' = strategy_of_ast s in
-    let t' = strategy_of_ast t in
-    let f' = match f with
-      | "compose" -> Strategies.seq
-      | "choice" -> Strategies.choice
-      | _ -> anomalylabstrm "strategy_of_ast" (str"Unkwnon strategy: " ++ str f)
-    in f' s' t'
-  | StratConstr (c, b) -> apply_glob_constr (fst c) b all_occurrences
-  | StratHints (old, id) -> if old then Strategies.old_hints id else Strategies.hints id
-  | StratTerms l -> 
-    (fun env avoid t ty cstr evars ->
-     let l' = interp_glob_constr_list env (goalevars evars) (List.map fst l) in
-       Strategies.lemmas rewrite_unif_flags l' env avoid t ty cstr evars)
-  | StratEval r -> 
-    (fun env avoid t ty cstr evars ->
-     let (sigma,r_interp) = Tacinterp.interp_redexp env (goalevars evars) r in
-       Strategies.reduce r_interp env avoid t ty cstr (sigma,cstrevars evars))
-  | StratFold c -> Strategies.fold_glob (fst c)
-
-
-type raw_strategy = (constr_expr, Tacexpr.raw_red_expr) strategy_ast
-type glob_strategy = (glob_constr_and_expr, Tacexpr.raw_red_expr) strategy_ast
-
-let interp_strategy ist gl s = 
-  let sigma = project gl in
-    sigma, strategy_of_ast s
-let glob_strategy ist s = map_strategy (Tacinterp.intern_constr ist) (fun c -> c) s
-let subst_strategy s str = str
-
-let pr_strategy _ _ _ (s : strategy) = Pp.str "<strategy>"
-let pr_raw_strategy _ _ _ (s : raw_strategy) = Pp.str "<strategy>"
-let pr_glob_strategy _ _ _ (s : glob_strategy) = Pp.str "<strategy>"
-
-ARGUMENT EXTEND rewstrategy
-    PRINTED BY pr_strategy
-
-    INTERPRETED BY interp_strategy
-    GLOBALIZED BY glob_strategy
-    SUBSTITUTED BY subst_strategy
-
-    RAW_TYPED AS raw_strategy
-    RAW_PRINTED BY pr_raw_strategy
-
-    GLOB_TYPED AS glob_strategy
-    GLOB_PRINTED BY pr_glob_strategy
-
-    [ glob(c) ] -> [ StratConstr (c, true) ]
-  | [ "<-" constr(c) ] -> [ StratConstr (c, false) ]
-  | [ "subterms" rewstrategy(h) ] -> [ StratUnary ("all_subterms", h) ]
-  | [ "subterm" rewstrategy(h) ] -> [ StratUnary ("one_subterm", h) ]
-  | [ "innermost" rewstrategy(h) ] -> [ StratUnary("innermost", h) ]
-  | [ "outermost" rewstrategy(h) ] -> [ StratUnary("outermost", h) ]
-  | [ "bottomup" rewstrategy(h) ] -> [ StratUnary("bottomup", h) ]
-  | [ "topdown" rewstrategy(h) ] -> [ StratUnary("topdown", h) ]
-  | [ "id" ] -> [ StratId ]
-  | [ "fail" ] -> [ StratFail ]
-  | [ "refl" ] -> [ StratRefl ]
-  | [ "progress" rewstrategy(h) ] -> [ StratUnary ("progress", h) ]
-  | [ "try" rewstrategy(h) ] -> [ StratUnary ("try", h) ]
-  | [ "any" rewstrategy(h) ] -> [ StratUnary ("any", h) ]
-  | [ "repeat" rewstrategy(h) ] -> [ StratUnary ("repeat", h) ]
-  | [ rewstrategy(h) ";" rewstrategy(h') ] -> [ StratBinary ("compose", h, h') ]
-  | [ "(" rewstrategy(h) ")" ] -> [ h ]
-  | [ "choice" rewstrategy(h) rewstrategy(h') ] -> [ StratBinary ("choice", h, h') ]
-  | [ "old_hints" preident(h) ] -> [ StratHints (true, h) ]
-  | [ "hints" preident(h) ] -> [ StratHints (false, h) ]
-  | [ "terms" constr_list(h) ] -> [ StratTerms h ]
-  | [ "eval" red_expr(r) ] -> [ StratEval r ]
-  | [ "fold" constr(c) ] -> [ StratFold c ]
-END
-
-(* By default the strategy for "rewrite_db" is top-down *)
-
-let db_strat db = Strategies.td (Strategies.hints db)
-let cl_rewrite_clause_db db cl = cl_rewrite_clause_strat (db_strat db) cl
-
-TACTIC EXTEND rewrite_strat
-| [ "rewrite_strat" rewstrategy(s) "in" hyp(id) ] -> [ cl_rewrite_clause_strat s (Some id) ]
-| [ "rewrite_strat" rewstrategy(s) ] -> [ cl_rewrite_clause_strat s None ]
-| [ "rewrite_db" preident(db) "in" hyp(id) ] -> [ cl_rewrite_clause_db db (Some id) ]
-| [ "rewrite_db" preident(db) ] -> [ cl_rewrite_clause_db db None ]
-END
-
-let clsubstitute o c =
-  let is_tac id = match 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
-	  | _ -> cl_rewrite_clause c o all_occurrences cl)
-
-open Extraargs
-
-TACTIC EXTEND substitute
-| [ "substitute" orient(o) glob_constr_with_bindings(c) ] -> [ clsubstitute o c ]
-END
-
-
-(* Compatibility with old Setoids *)
-
-TACTIC EXTEND setoid_rewrite
-   [ "setoid_rewrite" orient(o) glob_constr_with_bindings(c) ]
-   -> [ cl_rewrite_clause c o all_occurrences None ]
- | [ "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) glob_constr_with_bindings(c) "at" occurrences(occ) ] ->
-      [ cl_rewrite_clause c o (occurrences_of occ) None]
- | [ "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) glob_constr_with_bindings(c) "in" hyp(id) "at" occurrences(occ)] ->
-      [ cl_rewrite_clause c o (occurrences_of occ) (Some id)]
-END
-
-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)
-
-let declare_an_instance n s args =
-  ((dummy_loc,Name n), Explicit,
-  CAppExpl (dummy_loc, (None, Qualid (dummy_loc, qualid_of_string s)),
-	   args))
-
-let declare_instance a aeq n s = declare_an_instance n s [a;aeq]
-
-let anew_instance global binders instance fields =
-  new_instance binders instance (Some (CRecord (dummy_loc,None,fields)))
-    ~global:(not (Vernacexpr.use_section_locality ())) ~generalize:false None
-
-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 global binders instance
-       [(Ident (dummy_loc,id_of_string "reflexivity"),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 global binders instance
-       [(Ident (dummy_loc,id_of_string "symmetry"),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 global binders instance
-       [(Ident (dummy_loc,id_of_string "transitivity"),lemma)]
-
-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 global binders instance []);
-  match (refl,symm,trans) with
-      (None, None, None) -> ()
-    | (Some lemma1, None, None) ->
-	ignore (declare_instance_refl global binders a aeq n lemma1)
-    | (None, Some lemma2, None) ->
-	ignore (declare_instance_sym global binders a aeq n lemma2)
-    | (None, None, Some lemma3) ->
-	ignore (declare_instance_trans global binders a aeq n lemma3)
-    | (Some lemma1, Some lemma2, None) ->
-	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 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 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 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 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 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 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 _, _, rawwit_binders =
- (Genarg.create_arg None "binders" :
-    Genarg.tlevel binders_argtype *
-    Genarg.glevel binders_argtype *
-    Genarg.rlevel binders_argtype)
-
-open Pcoq.Constr
-
-VERNAC COMMAND EXTEND AddRelation
-  | [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1)
-	"symmetry" "proved" "by" constr(lemma2) "as" ident(n) ] ->
-      [ declare_relation a aeq n (Some lemma1) (Some lemma2) None ]
-
-  | [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1)
-	"as" ident(n) ] ->
-      [ declare_relation a aeq n (Some lemma1) None None ]
-  | [ "Add" "Relation" constr(a) constr(aeq)  "as" ident(n) ] ->
-      [ declare_relation a aeq n None None None ]
-END
-
-VERNAC COMMAND EXTEND AddRelation2
-    [ "Add" "Relation" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2)
-      "as" ident(n) ] ->
-      [ declare_relation a aeq n None (Some lemma2) None ]
-  | [ "Add" "Relation" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3)  "as" ident(n) ] ->
-      [ declare_relation a aeq n None (Some lemma2) (Some lemma3) ]
-END
-
-VERNAC COMMAND EXTEND AddRelation3
-    [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1)
-      "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] ->
-      [ declare_relation a aeq n (Some lemma1) None (Some lemma3) ]
-  | [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1)
-      "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3)
-      "as" ident(n) ] ->
-      [ declare_relation a aeq n (Some lemma1) (Some lemma2) (Some lemma3) ]
-  | [ "Add" "Relation" constr(a) constr(aeq) "transitivity" "proved" "by" constr(lemma3)
-	"as" ident(n) ] ->
-      [ declare_relation a aeq n None None (Some lemma3) ]
-END
-
-VERNAC COMMAND EXTEND AddParametricRelation
-  | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq)
-	"reflexivity" "proved" "by" constr(lemma1)
-	"symmetry" "proved" "by" constr(lemma2) "as" ident(n) ] ->
-      [ declare_relation ~binders:b a aeq n (Some lemma1) (Some lemma2) None ]
-  | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq)
-	"reflexivity" "proved" "by" constr(lemma1)
-	"as" ident(n) ] ->
-      [ declare_relation ~binders:b a aeq n (Some lemma1) None None ]
-  | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq)  "as" ident(n) ] ->
-      [ declare_relation ~binders:b a aeq n None None None ]
-END
-
-VERNAC COMMAND EXTEND AddParametricRelation2
-    [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2)
-      "as" ident(n) ] ->
-      [ declare_relation ~binders:b a aeq n None (Some lemma2) None ]
-  | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3)  "as" ident(n) ] ->
-      [ declare_relation ~binders:b a aeq n None (Some lemma2) (Some lemma3) ]
-END
-
-VERNAC COMMAND EXTEND AddParametricRelation3
-    [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1)
-      "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] ->
-      [ declare_relation ~binders:b a aeq n (Some lemma1) None (Some lemma3) ]
-  | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1)
-      "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3)
-      "as" ident(n) ] ->
-      [ declare_relation ~binders:b a aeq n (Some lemma1) (Some lemma2) (Some lemma3) ]
-  | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "transitivity" "proved" "by" constr(lemma3)
-	"as" ident(n) ] ->
-      [ declare_relation ~binders:b a aeq n None None (Some lemma3) ]
-END
-
-let cHole = CHole (dummy_loc, None)
-
-open Entries
-open Libnames
-
-let proper_projection r ty =
-  let ctx, inst = decompose_prod_assum ty in
-  let mor, args = destApp inst in
-  let instarg = mkApp (r, rel_vect 0 (List.length ctx)) in
-  let app = mkApp (Lazy.force proper_proj,
-		  Array.append args [| instarg |]) in
-    it_mkLambda_or_LetIn app ctx
-
-let declare_projection n instance_id r =
-  let ty = Global.type_of_global r in
-  let c = constr_of_global r in
-  let term = proper_projection c ty in
-  let typ = Typing.type_of (Global.env ()) Evd.empty term in
-  let ctx, typ = decompose_prod_assum typ in
-  let typ =
-    let n =
-      let rec aux t =
-	match kind_of_term t with
-	    App (f, [| a ; a' ; rel; rel' |]) when eq_constr f (Lazy.force respectful) ->
-	      succ (aux rel')
-	  | _ -> 0
-      in
-      let init =
-	match kind_of_term typ with
-	    App (f, args) when eq_constr f (Lazy.force respectful) ->
-	      mkApp (f, fst (array_chop (Array.length args - 2) args))
-	  | _ -> typ
-      in aux init
-    in
-    let ctx,ccl = Reductionops.splay_prod_n (Global.env()) Evd.empty (3 * n) typ
-    in it_mkProd_or_LetIn ccl ctx
-  in
-  let typ = it_mkProd_or_LetIn typ ctx in
-  let cst =
-    { const_entry_body = term;
-      const_entry_secctx = None;
-      const_entry_type = Some typ;
-      const_entry_opaque = false }
-  in
-    ignore(Declare.declare_constant n (Entries.DefinitionEntry cst, Decl_kinds.IsDefinition Decl_kinds.Definition))
-
-let build_morphism_signature m =
-  let env = Global.env () in
-  let m = Constrintern.interp_constr Evd.empty env m in
-  let t = Typing.type_of env Evd.empty m in
-  let isevars = ref (Evd.empty, Evd.empty) in
-  let cstrs =
-    let rec aux t =
-      match kind_of_term t with
-	| Prod (na, a, b) ->
-	    None :: aux b
-	| _ -> []
-    in aux t
-  in
-  let evars, t', sig_, cstrs = build_signature !isevars env t cstrs None in
-  let _ = isevars := evars in
-  let _ = List.iter
-    (fun (ty, rel) ->
-      Option.iter (fun rel ->
-	let default = mkApp (Lazy.force default_relation, [| ty; rel |]) in
-	let evars,c = new_cstr_evar !isevars env default in
-	  isevars := evars)
-	rel)
-    cstrs
-  in
-  let morph =
-    mkApp (Lazy.force proper_type, [| t; sig_; m |])
-  in
-  let evd = solve_constraints env !isevars in
-  let m = Evarutil.nf_evar evd morph in
-    Evarutil.check_evars env Evd.empty evd m; m
-
-let default_morphism sign m =
-  let env = Global.env () in
-  let t = Typing.type_of env Evd.empty m in
-  let evars, _, sign, cstrs =
-    build_signature (Evd.empty,Evd.empty) env t (fst sign) (snd sign)
-  in
-  let morph =
-    mkApp (Lazy.force proper_type, [| t; sign; m |])
-  in
-  let evars, mor = resolve_one_typeclass env (merge_evars evars) morph in
-    mor, proper_projection mor morph
-
-let add_setoid global binders a aeq t n =
-  init_setoid ();
-  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 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])])
-
-let add_morphism_infer glob m n =
-  init_setoid ();
-  let instance_id = add_suffix n "_Proper" in
-  let instance = build_morphism_signature m in
-    if Lib.is_modtype () then
-      let cst = Declare.declare_constant ~internal:Declare.KernelSilent instance_id
-				(Entries.ParameterEntry (None,instance,None), Decl_kinds.IsAssumption Decl_kinds.Logical)
-      in
-	add_instance (Typeclasses.new_instance (Lazy.force proper_class) None glob (ConstRef cst));
-	declare_projection n instance_id (ConstRef cst)
-    else
-      let kind = Decl_kinds.Global, Decl_kinds.DefinitionBody Decl_kinds.Instance in
-	Flags.silently
-	  (fun () ->
-	    Lemmas.start_proof instance_id kind instance
-	      (fun _ -> function
-		Libnames.ConstRef cst ->
-		  add_instance (Typeclasses.new_instance (Lazy.force proper_class) None
-				   glob (ConstRef cst));
-		  declare_projection n instance_id (ConstRef cst)
-		| _ -> assert false);
-	    Pfedit.by (Tacinterp.interp <:tactic< Coq.Classes.SetoidTactics.add_morphism_tactic>>)) ();
-	Flags.if_verbose (fun x -> msg (Printer.pr_open_subgoals x)) ()
-
-let add_morphism glob binders m s n =
-  init_setoid ();
-  let instance_id = add_suffix n "_Proper" in
-  let instance =
-    ((dummy_loc,Name instance_id), Explicit,
-    CAppExpl (dummy_loc,
-	     (None, Qualid (dummy_loc, Libnames.qualid_of_string "Coq.Classes.Morphisms.Proper")),
-	     [cHole; s; m]))
-  in
-  let tac = Tacinterp.interp <:tactic<add_morphism_tactic>> in
-    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 (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 (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) ] ->
-      [ add_morphism (not (Vernacexpr.use_section_locality ())) [] m s n ]
-  | [ "Add" "Parametric" "Morphism" binders(binders) ":" constr(m)
-	"with" "signature" lconstr(s) "as" ident(n) ] ->
-      [ add_morphism (not (Vernacexpr.use_section_locality ())) binders m s n ]
-END
-
-(** Bind to "rewrite" too *)
-
-(** Taken from original setoid_replace, to emulate the old rewrite semantics where
-    lemmas are first instantiated and then rewrite proceeds. *)
-
-let check_evar_map_of_evars_defs evd =
- let metas = Evd.meta_list evd in
- let check_freemetas_is_empty rebus =
-  Evd.Metaset.iter
-   (fun m ->
-     if Evd.meta_defined evd m then () else
-      raise
-	(Logic.RefinerError (Logic.UnresolvedBindings [Evd.meta_name evd m])))
- in
-  List.iter
-   (fun (_,binding) ->
-     match binding with
-        Evd.Cltyp (_,{Evd.rebus=rebus; Evd.freemetas=freemetas}) ->
-         check_freemetas_is_empty rebus freemetas
-      | Evd.Clval (_,({Evd.rebus=rebus1; Evd.freemetas=freemetas1},_),
-                 {Evd.rebus=rebus2; Evd.freemetas=freemetas2}) ->
-         check_freemetas_is_empty rebus1 freemetas1 ;
-         check_freemetas_is_empty rebus2 freemetas2
-   ) metas
-
-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 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: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' = 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);
-     flags = flags}
-
-let get_hyp gl evars (c,l) clause l2r =
-  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 }
-
-let apply_lemma gl (c,l) cl l2r occs =
-  let sigma = project gl in
-  let hypinfo = ref (get_hyp gl sigma (c,l) cl l2r) in
-  let app = apply_rule hypinfo occs in
-  let rec aux () =
-    Strategies.choice app (subterm true general_rewrite_flags (fun env -> aux () env))
-  in !hypinfo, aux ()
-
-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
-    tclWEAK_PROGRESS 
-      (tclTHEN
-       (Refiner.tclEVARS hypinfo.cl.evd)
-       (cl_rewrite_clause_tac ~abs:hypinfo.abs strat (mkMeta meta) cl)) gl
-
-let general_s_rewrite_clause x =
-  init_setoid ();
-  match x with
-    | None -> general_s_rewrite None
-    | Some id -> general_s_rewrite (Some id)
-
-let _ = Equality.register_general_rewrite_clause general_s_rewrite_clause
-
-(** [setoid_]{reflexivity,symmetry,transitivity} tactics *)
-
-let not_declared env ty rel =
-  tclFAIL 0 (str" The relation " ++ Printer.pr_constr_env env rel ++ str" is not a declared " ++
-		str ty ++ str" relation. Maybe you need to require the Setoid library")
-
-let setoid_proof gl ty fn fallback =
-  let env = pf_env gl in
-    try
-      let rel, args = decompose_app_rel env (project gl) (pf_concl gl) in
-      let evm = project gl in
-      let car = pi3 (List.hd (fst (Reduction.dest_prod env (Typing.type_of env evm rel)))) in
-	fn env evm car rel gl
-    with e when Errors.noncritical e ->
-      try fallback gl
-      with Hipattern.NoEquationFound ->
-	  match e with
-	  | Not_found ->
-	      let rel, args = decompose_app_rel env (project gl) (pf_concl gl) in
-		not_declared env ty rel gl
-	  | _ -> raise e
-
-let setoid_reflexivity gl =
-  setoid_proof gl "reflexive"
-    (fun env evm car rel -> apply (get_reflexive_proof env evm car rel))
-    (reflexivity_red true)
-
-let setoid_symmetry gl =
-  setoid_proof gl "symmetric"
-    (fun env evm car rel -> apply (get_symmetric_proof env evm car rel))
-    (symmetry_red true)
-
-let setoid_transitivity c gl =
-  setoid_proof gl "transitive"
-    (fun env evm car rel ->
-      let proof = get_transitive_proof env evm car rel in
-      match c with
-      | None -> eapply proof
-      | Some c -> apply_with_bindings (proof,Glob_term.ImplicitBindings [ c ]))
-    (transitivity_red true c)
-
-let setoid_symmetry_in id gl =
-  let ctype = pf_type_of gl (mkVar id) in
-  let binders,concl = decompose_prod_assum ctype in
-  let (equiv, args) = decompose_app concl in
-  let rec split_last_two = function
-    | [c1;c2] -> [],(c1, c2)
-    | x::y::z -> let l,res = split_last_two (y::z) in x::l, res
-    | _ -> error "The term provided is not an equivalence."
-  in
-  let others,(c1,c2) = split_last_two args in
-  let he,c1,c2 =  mkApp (equiv, Array.of_list others),c1,c2 in
-  let new_hyp' =  mkApp (he, [| c2 ; c1 |]) in
-  let new_hyp = it_mkProd_or_LetIn new_hyp'  binders in
-    tclTHENS (Tactics.cut new_hyp)
-      [ intro_replacing id;
-	tclTHENLIST [ intros; setoid_symmetry; apply (mkVar id); Tactics.assumption ] ]
-      gl
-
-let _ = Tactics.register_setoid_reflexivity setoid_reflexivity
-let _ = Tactics.register_setoid_symmetry setoid_symmetry
-let _ = Tactics.register_setoid_symmetry_in setoid_symmetry_in
-let _ = Tactics.register_setoid_transitivity setoid_transitivity
-
-TACTIC EXTEND setoid_symmetry
-   [ "setoid_symmetry" ] -> [ setoid_symmetry ]
- | [ "setoid_symmetry" "in" hyp(n) ] -> [ setoid_symmetry_in n ]
-END
-
-TACTIC EXTEND setoid_reflexivity
-[ "setoid_reflexivity" ] -> [ setoid_reflexivity ]
-END
-
-TACTIC EXTEND setoid_transitivity
-  [ "setoid_transitivity" constr(t) ] -> [ setoid_transitivity (Some t) ]
-| [ "setoid_etransitivity" ] -> [ setoid_transitivity None ]
-END
-
-let implify id gl =
-  let (_, b, ctype) = pf_get_hyp gl id in
-  let binders,concl = decompose_prod_assum ctype in
-  let ctype' =
-    match binders with
-    | (_, None, ty as hd) :: tl when noccurn 1 concl ->
-	let env = Environ.push_rel_context tl (pf_env gl) in
-	let sigma = project gl in
-	let tyhd = Typing.type_of env sigma ty
-	and tyconcl = Typing.type_of (Environ.push_rel hd env) sigma concl in
-	let app, unfold = arrow_morphism tyhd (subst1 mkProp tyconcl) ty (subst1 mkProp concl) in
-	  it_mkProd_or_LetIn app tl
-    | _ -> ctype
-  in convert_hyp_no_check (id, b, ctype') gl
-
-TACTIC EXTEND implify
-[ "implify" hyp(n) ] -> [ implify n ]
-END
-
-let rec fold_matches env sigma c =
-  map_constr_with_full_binders Environ.push_rel 
-    (fun env c ->
-      match kind_of_term c with
-      | Case _ ->
-          let cst, env, c' = fold_match ~force:true env sigma c in
-	    fold_matches env sigma c'
-      | _ -> fold_matches env sigma c)
-    env c
-
-TACTIC EXTEND fold_match
-[ "fold_match" constr(c) ] -> [ fun gl -> 
-  let _, _, c' = fold_match ~force:true (pf_env gl) (project gl) c in
-    change (Some (snd (pattern_of_constr (project gl) c))) c' onConcl gl ]
-END
-
-TACTIC EXTEND fold_matches
-| [ "fold_matches" constr(c) ] -> [ fun gl -> 
-  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/rewrite.mli b/tactics/rewrite.mli
new file mode 100644
index 00000000..cae00f5a
--- /dev/null
+++ b/tactics/rewrite.mli
@@ -0,0 +1,117 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+open Names
+open Constr
+open Environ
+open Constrexpr
+open Tacexpr
+open Misctypes
+open Evd
+open Proof_type
+open Tacinterp
+
+(** TODO: document and clean me! *)
+
+type unary_strategy = 
+    Subterms | Subterm | Innermost | Outermost
+  | Bottomup | Topdown | Progress | Try | Any | Repeat
+
+type binary_strategy = 
+  | Compose | Choice
+
+type ('constr,'redexpr) strategy_ast = 
+  | StratId | StratFail | StratRefl
+  | StratUnary of unary_strategy * ('constr,'redexpr) strategy_ast
+  | StratBinary of binary_strategy 
+    * ('constr,'redexpr) strategy_ast * ('constr,'redexpr) strategy_ast
+  | StratConstr of 'constr * bool
+  | StratTerms of 'constr list
+  | StratHints of bool * string
+  | StratEval of 'redexpr 
+  | StratFold of 'constr
+
+type rewrite_proof = 
+  | RewPrf of constr * constr
+  | RewCast of cast_kind
+
+type evars = evar_map * Evar.Set.t (* goal evars, constraint evars *)
+
+type rewrite_result_info = {
+  rew_car : constr;
+  rew_from : constr;
+  rew_to : constr;
+  rew_prf : rewrite_proof;
+  rew_evars : evars;
+}
+
+type rewrite_result =
+| Fail
+| Identity
+| Success of rewrite_result_info
+
+type 'a pure_strategy = 'a -> Environ.env -> Id.t list -> constr -> types ->
+  (bool (* prop *) * constr option) -> evars -> 'a * rewrite_result
+
+type strategy = unit pure_strategy
+
+val strategy_of_ast : (glob_constr_and_expr, raw_red_expr) strategy_ast -> strategy
+
+val map_strategy : ('a -> 'b) -> ('c -> 'd) ->
+  ('a, 'c) strategy_ast -> ('b, 'd) strategy_ast
+
+(** Entry point for user-level "rewrite_strat" *)
+val cl_rewrite_clause_strat : strategy -> Id.t option -> tactic
+
+(** Entry point for user-level "setoid_rewrite" *)
+val cl_rewrite_clause :
+  interp_sign * (glob_constr_and_expr * glob_constr_and_expr bindings) ->
+  bool -> Locus.occurrences -> Id.t option -> tactic
+
+val is_applied_rewrite_relation :
+  env -> evar_map -> Context.rel_context -> constr -> types option
+
+val declare_relation :
+  ?binders:local_binder list -> constr_expr -> constr_expr -> Id.t ->
+  constr_expr option -> constr_expr option -> constr_expr option -> unit
+
+val add_setoid :
+  bool -> local_binder list -> constr_expr -> constr_expr -> constr_expr ->
+  Id.t -> unit
+
+val add_morphism_infer : bool -> constr_expr -> Id.t -> unit
+
+val add_morphism :
+  bool -> local_binder list -> constr_expr -> constr_expr -> Id.t -> unit
+
+val get_reflexive_proof : env -> evar_map -> constr -> constr -> evar_map * constr
+
+val get_symmetric_proof : env -> evar_map -> constr -> constr -> evar_map * constr
+
+val get_transitive_proof : env -> evar_map -> constr -> constr -> evar_map * constr
+
+val default_morphism :
+  (types * constr option) option list * (types * types option) option ->
+  constr -> constr * constr
+
+val setoid_symmetry : unit Proofview.tactic
+
+val setoid_symmetry_in : Id.t -> unit Proofview.tactic
+
+val setoid_reflexivity : unit Proofview.tactic
+
+val setoid_transitivity : constr option -> unit Proofview.tactic
+
+
+val apply_strategy :
+  strategy ->
+  Environ.env ->
+  Names.Id.t list ->
+  Term.constr ->
+  bool * Term.constr ->
+  evars -> rewrite_result
diff --git a/tactics/taccoerce.ml b/tactics/taccoerce.ml
new file mode 100644
index 00000000..215713d9
--- /dev/null
+++ b/tactics/taccoerce.ml
@@ -0,0 +1,269 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+open Util
+open Names
+open Term
+open Pattern
+open Misctypes
+open Genarg
+open Stdarg
+open Constrarg
+
+exception CannotCoerceTo of string
+
+let (wit_constr_context : (Empty.t, Empty.t, constr) Genarg.genarg_type) =
+  Genarg.create_arg None "constr_context"
+
+(* includes idents known to be bound and references *)
+let (wit_constr_under_binders : (Empty.t, Empty.t, constr_under_binders) Genarg.genarg_type) =
+  Genarg.create_arg None "constr_under_binders"
+
+module Value =
+struct
+
+type t = tlevel generic_argument
+
+let rec normalize v =
+  if has_type v (topwit wit_genarg) then
+    normalize (out_gen (topwit wit_genarg) v)
+  else v
+
+let of_constr c = in_gen (topwit wit_constr) c
+
+let to_constr v =
+  let v = normalize v in
+  if has_type v (topwit wit_constr) then
+    let c = out_gen (topwit wit_constr) v in
+    Some c
+  else if has_type v (topwit wit_constr_under_binders) then
+    let vars, c = out_gen (topwit wit_constr_under_binders) v in
+    match vars with [] -> Some c | _ -> None
+  else None
+
+let of_uconstr c = in_gen (topwit wit_uconstr) c
+
+let to_uconstr v =
+  let v = normalize v in
+  if has_type v (topwit wit_uconstr) then
+    Some (out_gen (topwit wit_uconstr) v)
+  else None
+
+let of_int i = in_gen (topwit wit_int) i
+
+let to_int v =
+  let v = normalize v in
+  if has_type v (topwit wit_int) then
+    Some (out_gen (topwit wit_int) v)
+  else None
+
+let to_list v =
+  let v = normalize v in
+  let list_unpacker wit l = List.map (fun v -> in_gen (topwit wit) v) (top l) in
+  try Some (list_unpack { list_unpacker } v)
+  with Failure _ -> None
+
+end
+
+let is_variable env id =
+  Id.List.mem id (Termops.ids_of_named_context (Environ.named_context env))
+
+(* Transforms an id into a constr if possible, or fails with Not_found *)
+let constr_of_id env id =
+  Term.mkVar (let _ = Environ.lookup_named id env in id)
+
+(* Gives the constr corresponding to a Constr_context tactic_arg *)
+let coerce_to_constr_context v =
+  let v = Value.normalize v in
+  if has_type v (topwit wit_constr_context) then
+    out_gen (topwit wit_constr_context) v
+  else raise (CannotCoerceTo "a term context")
+
+(* Interprets an identifier which must be fresh *)
+let coerce_to_ident fresh env v =
+  let v = Value.normalize v in
+  let fail () = raise (CannotCoerceTo "a fresh identifier") in
+  if has_type v (topwit wit_intro_pattern) then
+    match out_gen (topwit wit_intro_pattern) v with
+    | _, IntroNaming (IntroIdentifier id) -> id
+    | _ -> fail ()
+  else if has_type v (topwit wit_var) then
+    out_gen (topwit wit_var) v
+  else match Value.to_constr v with
+  | None -> fail ()
+  | Some c ->
+    (* We need it fresh for intro e.g. in "Tac H = clear H; intro H" *)
+    if isVar c && not (fresh && is_variable env (destVar c)) then
+      destVar c
+    else fail ()
+
+let coerce_to_intro_pattern env v =
+  let v = Value.normalize v in
+  if has_type v (topwit wit_intro_pattern) then
+    snd (out_gen (topwit wit_intro_pattern) v)
+  else if has_type v (topwit wit_var) then
+    let id = out_gen (topwit wit_var) v in
+    IntroNaming (IntroIdentifier id)
+  else match Value.to_constr v with
+  | Some c when isVar c ->
+      (* This happens e.g. in definitions like "Tac H = clear H; intro H" *)
+      (* but also in "destruct H as (H,H')" *)
+      IntroNaming (IntroIdentifier (destVar c))
+  | _ -> raise (CannotCoerceTo "an introduction pattern")
+
+let coerce_to_intro_pattern_naming env v =
+  match coerce_to_intro_pattern env v with
+  | IntroNaming pat -> pat
+  | _ -> raise (CannotCoerceTo "a naming introduction pattern")
+
+let coerce_to_hint_base v =
+  let v = Value.normalize v in
+  if has_type v (topwit wit_intro_pattern) then
+    match out_gen (topwit wit_intro_pattern) v with
+    | _, IntroNaming (IntroIdentifier id) -> Id.to_string id
+    | _ -> raise (CannotCoerceTo "a hint base name")
+  else raise (CannotCoerceTo "a hint base name")
+
+let coerce_to_int v =
+  let v = Value.normalize v in
+  if has_type v (topwit wit_int) then
+    out_gen (topwit wit_int) v
+  else raise (CannotCoerceTo "an integer")
+
+let coerce_to_constr env v =
+  let v = Value.normalize v in
+  let fail () = raise (CannotCoerceTo "a term") in
+  if has_type v (topwit wit_intro_pattern) then
+    match out_gen (topwit wit_intro_pattern) v with
+    | _, IntroNaming (IntroIdentifier id) ->
+      (try ([], constr_of_id env id) with Not_found -> fail ())
+    | _ -> fail ()
+  else if has_type v (topwit wit_constr) then
+    let c = out_gen (topwit wit_constr) v in
+    ([], c)
+  else if has_type v (topwit wit_constr_under_binders) then
+    out_gen (topwit wit_constr_under_binders) v
+  else if has_type v (topwit wit_var) then
+    let id = out_gen (topwit wit_var) v in
+    (try [], constr_of_id env id with Not_found -> fail ())
+  else fail ()
+
+let coerce_to_uconstr env v =
+  let v = Value.normalize v in
+  if has_type v (topwit wit_uconstr) then
+    out_gen (topwit wit_uconstr) v
+  else
+    raise (CannotCoerceTo "an untyped term")
+
+let coerce_to_closed_constr env v =
+  let ids,c = coerce_to_constr env v in
+  let () = if not (List.is_empty ids) then raise (CannotCoerceTo "a term") in
+  c
+
+let coerce_to_evaluable_ref env v =
+  let fail () = raise (CannotCoerceTo "an evaluable reference") in
+  let v = Value.normalize v in
+  if has_type v (topwit wit_intro_pattern) then
+    match out_gen (topwit wit_intro_pattern) v with
+    | _, IntroNaming (IntroIdentifier id) when is_variable env id -> EvalVarRef id
+    | _ -> fail ()
+  else if has_type v (topwit wit_var) then
+    let id = out_gen (topwit wit_var) v in
+    if Id.List.mem id (Termops.ids_of_context env) then EvalVarRef id
+    else fail ()
+  else
+    let ev = match Value.to_constr v with
+    | Some c when isConst c -> EvalConstRef (Univ.out_punivs (destConst c))
+    | Some c when isVar c -> EvalVarRef (destVar c)
+    | _ -> fail ()
+    in
+    if Tacred.is_evaluable env ev then ev else fail ()
+
+let coerce_to_constr_list env v =
+  let v = Value.to_list v in
+  match v with
+  | Some l ->
+    let map v = coerce_to_closed_constr env v in
+    List.map map l
+  | None -> raise (CannotCoerceTo "a term list")
+
+let coerce_to_intro_pattern_list loc env v =
+  match Value.to_list v with
+  | None -> raise (CannotCoerceTo "an intro pattern list")
+  | Some l ->
+    let map v = (loc, coerce_to_intro_pattern env v) in
+    List.map map l
+
+let coerce_to_hyp env v =
+  let fail () = raise (CannotCoerceTo "a variable") in
+  let v = Value.normalize v in
+  if has_type v (topwit wit_intro_pattern) then
+    match out_gen (topwit wit_intro_pattern) v with
+    | _, IntroNaming (IntroIdentifier id) when is_variable env id -> id
+    | _ -> fail ()
+  else if has_type v (topwit wit_var) then
+    let id = out_gen (topwit wit_var) v in
+    if is_variable env id then id else fail ()
+  else match Value.to_constr v with
+  | Some c when isVar c -> destVar c
+  | _ -> fail ()
+
+let coerce_to_hyp_list env v =
+  let v = Value.to_list v in
+  match v with
+  | Some l ->
+    let map n = coerce_to_hyp env n in
+    List.map map l
+  | None -> raise (CannotCoerceTo "a variable list")
+
+(* Interprets a qualified name *)
+let coerce_to_reference env v =
+  let v = Value.normalize v in
+  match Value.to_constr v with
+  | Some c ->
+    begin
+      try Globnames.global_of_constr c
+      with Not_found -> raise (CannotCoerceTo "a reference")
+    end
+  | None -> raise (CannotCoerceTo "a reference")
+
+(* Quantified named or numbered hypothesis or hypothesis in context *)
+(* (as in Inversion) *)
+let coerce_to_quantified_hypothesis v =
+  let v = Value.normalize v in
+  if has_type v (topwit wit_intro_pattern) then
+    let v = out_gen (topwit wit_intro_pattern) v in
+    match v with
+    | _, IntroNaming (IntroIdentifier id) -> NamedHyp id
+    | _ -> raise (CannotCoerceTo "a quantified hypothesis")
+  else if has_type v (topwit wit_var) then
+    let id = out_gen (topwit wit_var) v in
+    NamedHyp id
+  else if has_type v (topwit wit_int) then
+    AnonHyp (out_gen (topwit wit_int) v)
+  else match Value.to_constr v with
+  | Some c when isVar c -> NamedHyp (destVar c)
+  | _ -> raise (CannotCoerceTo "a quantified hypothesis")
+
+(* Quantified named or numbered hypothesis or hypothesis in context *)
+(* (as in Inversion) *)
+let coerce_to_decl_or_quant_hyp env v =
+  let v = Value.normalize v in
+  if has_type v (topwit wit_int) then
+    AnonHyp (out_gen (topwit wit_int) v)
+  else
+    try coerce_to_quantified_hypothesis v
+    with CannotCoerceTo _ ->
+      raise (CannotCoerceTo "a declared or quantified hypothesis")
+
+let coerce_to_int_or_var_list v =
+  match Value.to_list v with
+  | None -> raise (CannotCoerceTo "an int list")
+  | Some l ->
+    let map n = ArgArg (coerce_to_int n) in
+    List.map map l
diff --git a/tactics/taccoerce.mli b/tactics/taccoerce.mli
new file mode 100644
index 00000000..85bad364
--- /dev/null
+++ b/tactics/taccoerce.mli
@@ -0,0 +1,95 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+open Util
+open Names
+open Term
+open Misctypes
+open Pattern
+open Genarg
+
+(** Coercions from highest level generic arguments to actual data used by Ltac
+    interpretation. Those functions examinate dynamic types and try to return
+    something sensible according to the object content. *)
+
+exception CannotCoerceTo of string
+(** Exception raised whenever a coercion failed. *)
+
+(** {5 High-level access to values}
+
+  The [of_*] functions cast a given argument into a value. The [to_*] do the
+  converse, and return [None] if there is a type mismatch.
+
+*)
+
+module Value :
+sig
+  type t = tlevel generic_argument
+  (** Tactics manipulate [tlevel generic_argument]. *)
+
+  val normalize : t -> t
+  (** Eliminated the leading dynamic type casts. *)
+
+  val of_constr : constr -> t
+  val to_constr : t -> constr option
+  val of_uconstr : Glob_term.closed_glob_constr -> t
+  val to_uconstr : t -> Glob_term.closed_glob_constr option
+  val of_int : int -> t
+  val to_int : t -> int option
+  val to_list : t -> t list option
+end
+
+(** {5 Coercion functions} *)
+
+val coerce_to_constr_context : Value.t -> constr
+
+val coerce_to_ident : bool -> Environ.env -> Value.t -> Id.t
+
+val coerce_to_intro_pattern : Environ.env -> Value.t -> Tacexpr.delayed_open_constr intro_pattern_expr
+
+val coerce_to_intro_pattern_naming :
+  Environ.env -> Value.t -> intro_pattern_naming_expr
+
+val coerce_to_intro_pattern_naming :
+  Environ.env -> Value.t -> intro_pattern_naming_expr
+
+val coerce_to_hint_base : Value.t -> string
+
+val coerce_to_int : Value.t -> int
+
+val coerce_to_constr : Environ.env -> Value.t -> constr_under_binders
+
+val coerce_to_uconstr : Environ.env -> Value.t -> Glob_term.closed_glob_constr
+
+val coerce_to_closed_constr : Environ.env -> Value.t -> constr
+
+val coerce_to_evaluable_ref :
+  Environ.env -> Value.t -> evaluable_global_reference
+
+val coerce_to_constr_list : Environ.env -> Value.t -> constr list
+
+val coerce_to_intro_pattern_list :
+  Loc.t -> Environ.env -> Value.t -> Tacexpr.intro_patterns
+
+val coerce_to_hyp : Environ.env -> Value.t -> Id.t
+
+val coerce_to_hyp_list : Environ.env -> Value.t -> Id.t list
+
+val coerce_to_reference : Environ.env -> Value.t -> Globnames.global_reference
+
+val coerce_to_quantified_hypothesis : Value.t -> quantified_hypothesis
+
+val coerce_to_decl_or_quant_hyp : Environ.env -> Value.t -> quantified_hypothesis
+
+val coerce_to_int_or_var_list : Value.t -> int or_var list
+
+(** {5 Missing generic arguments} *)
+
+val wit_constr_context : (Empty.t, Empty.t, constr) genarg_type
+
+val wit_constr_under_binders : (Empty.t, Empty.t, constr_under_binders) genarg_type
diff --git a/tactics/tacenv.ml b/tactics/tacenv.ml
new file mode 100644
index 00000000..cb20fc93
--- /dev/null
+++ b/tactics/tacenv.ml
@@ -0,0 +1,128 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+open Util
+open Genarg
+open Pp
+open Names
+open Tacexpr
+
+(** Tactic notations (TacAlias) *)
+
+type alias = KerName.t
+
+let alias_map = Summary.ref ~name:"tactic-alias"
+  (KNmap.empty : glob_tactic_expr KNmap.t)
+
+let register_alias key tac =
+  alias_map := KNmap.add key tac !alias_map
+
+let interp_alias key =
+  try KNmap.find key !alias_map
+  with Not_found -> Errors.anomaly (str "Unknown tactic alias: " ++ KerName.print key)
+
+(** ML tactic extensions (TacML) *)
+
+type ml_tactic =
+  typed_generic_argument list -> Geninterp.interp_sign -> unit Proofview.tactic
+
+module MLName =
+struct
+  type t = ml_tactic_name
+  let compare tac1 tac2 =
+    let c = String.compare tac1.mltac_tactic tac2.mltac_tactic in
+    if c = 0 then String.compare tac1.mltac_plugin tac2.mltac_plugin
+    else c
+end
+
+module MLTacMap = Map.Make(MLName)
+
+let pr_tacname t =
+  t.mltac_plugin ^ "::" ^ t.mltac_tactic
+
+let tac_tab = ref MLTacMap.empty
+
+let register_ml_tactic ?(overwrite = false) s (t : ml_tactic) =
+  let () =
+    if MLTacMap.mem s !tac_tab then
+      if overwrite then
+        let () = tac_tab := MLTacMap.remove s !tac_tab in
+        msg_warning (str ("Overwriting definition of tactic " ^ pr_tacname s))
+      else
+        Errors.anomaly (str ("Cannot redeclare tactic " ^ pr_tacname s ^ "."))
+  in
+  tac_tab := MLTacMap.add s t !tac_tab
+
+let interp_ml_tactic s =
+  try
+    MLTacMap.find s !tac_tab
+  with Not_found ->
+    Errors.errorlabstrm ""
+      (str "The tactic " ++ str (pr_tacname s) ++ str " is not installed.")
+
+(***************************************************************************)
+(* Tactic registration *)
+
+(* Summary and Object declaration *)
+
+open Nametab
+open Libnames
+open Libobject
+
+let mactab =
+  Summary.ref (KNmap.empty : (bool * glob_tactic_expr) KNmap.t)
+    ~name:"tactic-definition"
+
+let interp_ltac r = snd (KNmap.find r !mactab)
+
+let is_ltac_for_ml_tactic r = fst (KNmap.find r !mactab)
+
+(* Declaration of the TAC-DEFINITION object *)
+let add (kn,td) = mactab := KNmap.add kn td !mactab
+let replace (kn,td) = mactab := KNmap.add kn td !mactab
+
+let load_md i ((sp, kn), (local, id, b, t)) = match id with
+| None ->
+  let () = if not local then Nametab.push_tactic (Until i) sp kn in
+  add (kn, (b,t))
+| Some kn -> add (kn, (b,t))
+
+let open_md i ((sp, kn), (local, id, b, t)) = match id with
+| None ->
+  let () = if not local then Nametab.push_tactic (Exactly i) sp kn in
+  add (kn, (b,t))
+| Some kn -> add (kn, (b,t))
+
+let cache_md ((sp, kn), (local, id ,b, t)) = match id with
+| None ->
+  let () = Nametab.push_tactic (Until 1) sp kn in
+  add (kn, (b,t))
+| Some kn -> add (kn, (b,t))
+
+let subst_kind subst id = match id with
+| None -> None
+| Some kn -> Some (Mod_subst.subst_kn subst kn)
+
+let subst_md (subst, (local, id, b, t)) =
+  (local, subst_kind subst id, b, Tacsubst.subst_tactic subst t)
+
+let classify_md (local, _, _, _ as o) = Substitute o
+
+let inMD : bool * Nametab.ltac_constant option * bool * glob_tactic_expr -> obj =
+  declare_object {(default_object "TAC-DEFINITION") with
+     cache_function  = cache_md;
+     load_function   = load_md;
+     open_function   = open_md;
+     subst_function = subst_md;
+     classify_function = classify_md}
+
+let register_ltac for_ml local id tac =
+  ignore (Lib.add_leaf id (inMD (local, None, for_ml, tac)))
+
+let redefine_ltac local kn tac =
+  Lib.add_anonymous_leaf (inMD (local, Some kn, false, tac))
diff --git a/tactics/tacenv.mli b/tactics/tacenv.mli
new file mode 100644
index 00000000..29677fd4
--- /dev/null
+++ b/tactics/tacenv.mli
@@ -0,0 +1,55 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+open Genarg
+open Names
+open Tacexpr
+
+(** This module centralizes the various ways of registering tactics. *)
+
+(** {5 Tactic notations} *)
+
+type alias = KerName.t
+(** Type of tactic alias, used in the [TacAlias] node. *)
+
+val register_alias : alias -> glob_tactic_expr -> unit
+(** Register a tactic alias. *)
+
+val interp_alias : alias -> glob_tactic_expr
+(** Recover the the body of an alias. Raises an anomaly if it does not exist. *)
+
+(** {5 Coq tactic definitions} *)
+
+val register_ltac : bool -> bool -> Id.t -> glob_tactic_expr -> unit
+(** Register a new Ltac with the given name and body.
+
+    The first boolean indicates whether this is done from ML side, rather than
+    Coq side. If the second boolean flag is set to true, then this is a local
+    definition. It also puts the Ltac name in the nametab, so that it can be
+    used unqualified. *)
+
+val redefine_ltac : bool -> KerName.t -> glob_tactic_expr -> unit
+(** Replace a Ltac with the given name and body. If the boolean flag is set
+    to true, then this is a local redefinition. *)
+
+val interp_ltac : KerName.t -> glob_tactic_expr
+(** Find a user-defined tactic by name. Raise [Not_found] if it is absent. *)
+
+val is_ltac_for_ml_tactic : KerName.t -> bool
+
+(** {5 ML tactic extensions} *)
+
+type ml_tactic =
+  typed_generic_argument list -> Geninterp.interp_sign -> unit Proofview.tactic
+(** Type of external tactics, used by [TacML]. *)
+
+val register_ml_tactic : ?overwrite:bool -> ml_tactic_name -> ml_tactic -> unit
+(** Register an external tactic. *)
+
+val interp_ml_tactic : ml_tactic_name -> ml_tactic
+(** Get the named tactic. Raises a user error if it does not exist. *)
diff --git a/tactics/tacintern.ml b/tactics/tacintern.ml
new file mode 100644
index 00000000..c8b9a208
--- /dev/null
+++ b/tactics/tacintern.ml
@@ -0,0 +1,867 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+open Pattern
+open Pp
+open Genredexpr
+open Glob_term
+open Tacred
+open Errors
+open Util
+open Names
+open Nameops
+open Libnames
+open Globnames
+open Nametab
+open Smartlocate
+open Constrexpr
+open Termops
+open Tacexpr
+open Genarg
+open Constrarg
+open Misctypes
+open Locus
+
+(** Globalization of tactic expressions :
+    Conversion from [raw_tactic_expr] to [glob_tactic_expr] *)
+
+let dloc = Loc.ghost
+
+let error_global_not_found_loc (loc,qid) =
+  error_global_not_found_loc loc qid
+
+let error_syntactic_metavariables_not_allowed loc =
+  user_err_loc
+    (loc,"out_ident",
+     str "Syntactic metavariables allowed only in quotations.")
+
+let error_tactic_expected loc =
+  user_err_loc (loc,"",str "Tactic expected.")
+
+(** Generic arguments *)
+
+type glob_sign = Genintern.glob_sign = {
+  ltacvars : Id.Set.t;
+     (* ltac variables and the subset of vars introduced by Intro/Let/... *)
+  ltacrecvars : ltac_constant Id.Map.t;
+     (* ltac recursive names *)
+  genv : Environ.env }
+
+let fully_empty_glob_sign =
+  { ltacvars = Id.Set.empty; ltacrecvars = Id.Map.empty; genv = Environ.empty_env }
+
+let make_empty_glob_sign () =
+  { fully_empty_glob_sign with genv = Global.env () }
+
+(* We have identifier <| global_reference <| constr *)
+
+let find_ident id ist =
+  Id.Set.mem id ist.ltacvars ||
+  Id.List.mem id (ids_of_named_context (Environ.named_context ist.genv))
+
+let find_recvar qid ist = Id.Map.find qid ist.ltacrecvars
+
+(* a "var" is a ltac var or a var introduced by an intro tactic *)
+let find_var id ist = Id.Set.mem id ist.ltacvars
+
+let find_hyp id ist =
+  Id.List.mem id (ids_of_named_context (Environ.named_context ist.genv))
+
+(* Globalize a name introduced by Intro/LetTac/... ; it is allowed to *)
+(* be fresh in which case it is binding later on *)
+let intern_ident s ist id =
+  (* We use identifier both for variables and new names; thus nothing to do *)
+  if not (find_ident id ist) then s := Id.Set.add id !s;
+  id
+
+let intern_name l ist = function
+  | Anonymous -> Anonymous
+  | Name id -> Name (intern_ident l ist id)
+
+let strict_check = ref false
+
+let adjust_loc loc = if !strict_check then dloc else loc
+
+(* Globalize a name which must be bound -- actually just check it is bound *)
+let intern_hyp ist (loc,id as locid) =
+  if not !strict_check then
+    locid
+  else if find_ident id ist then
+    (dloc,id)
+  else
+    Pretype_errors.error_var_not_found_loc loc id
+
+let intern_or_var f ist = function
+  | ArgVar locid -> ArgVar (intern_hyp ist locid)
+  | ArgArg x -> ArgArg (f x)
+
+let intern_int_or_var = intern_or_var (fun (n : int) -> n)
+let intern_id_or_var = intern_or_var (fun (id : Id.t) -> id)
+let intern_string_or_var = intern_or_var (fun (s : string) -> s)
+
+let intern_global_reference ist = function
+  | Ident (loc,id) when find_var id ist -> ArgVar (loc,id)
+  | r ->
+      let loc,_ as lqid = qualid_of_reference r in
+      try ArgArg (loc,locate_global_with_alias lqid)
+      with Not_found -> error_global_not_found_loc lqid
+
+let intern_ltac_variable ist = function
+  | Ident (loc,id) ->
+      if find_var id ist then
+	(* A local variable of any type *)
+	ArgVar (loc,id)
+      else
+      (* A recursive variable *)
+      ArgArg (loc,find_recvar id ist)
+  | _ ->
+      raise Not_found
+
+let intern_constr_reference strict ist = function
+  | Ident (_,id) as r when not strict && find_hyp id ist ->
+      GVar (dloc,id), Some (CRef (r,None))
+  | Ident (_,id) as r when find_var id ist ->
+      GVar (dloc,id), if strict then None else Some (CRef (r,None))
+  | r ->
+      let loc,_ as lqid = qualid_of_reference r in
+      GRef (loc,locate_global_with_alias lqid,None), 
+	if strict then None else Some (CRef (r,None))
+
+let intern_move_location ist = function
+  | MoveAfter id -> MoveAfter (intern_hyp ist id)
+  | MoveBefore id -> MoveBefore (intern_hyp ist id)
+  | MoveFirst -> MoveFirst
+  | MoveLast -> MoveLast
+
+(* Internalize an isolated reference in position of tactic *)
+
+let intern_isolated_global_tactic_reference r =
+  let (loc,qid) = qualid_of_reference r in
+  TacCall (loc,ArgArg (loc,locate_tactic qid),[])
+
+let intern_isolated_tactic_reference strict ist r =
+  (* An ltac reference *)
+  try Reference (intern_ltac_variable ist r)
+  with Not_found ->
+  (* A global tactic *)
+  try intern_isolated_global_tactic_reference r
+  with Not_found ->
+  (* Tolerance for compatibility, allow not to use "constr:" *)
+  try ConstrMayEval (ConstrTerm (intern_constr_reference strict ist r))
+  with Not_found ->
+  (* Reference not found *)
+  error_global_not_found_loc (qualid_of_reference r)
+
+(* Internalize an applied tactic reference *)
+
+let intern_applied_global_tactic_reference r =
+  let (loc,qid) = qualid_of_reference r in
+  ArgArg (loc,locate_tactic qid)
+
+let intern_applied_tactic_reference ist r =
+  (* An ltac reference *)
+  try intern_ltac_variable ist r
+  with Not_found ->
+  (* A global tactic *)
+  try intern_applied_global_tactic_reference r
+  with Not_found ->
+  (* Reference not found *)
+  error_global_not_found_loc (qualid_of_reference r)
+
+(* Intern a reference parsed in a non-tactic entry *)
+
+let intern_non_tactic_reference strict ist r =
+  (* An ltac reference *)
+  try Reference (intern_ltac_variable ist r)
+  with Not_found ->
+  (* A constr reference *)
+  try ConstrMayEval (ConstrTerm (intern_constr_reference strict ist r))
+  with Not_found ->
+  (* Tolerance for compatibility, allow not to use "ltac:" *)
+  try intern_isolated_global_tactic_reference r
+  with Not_found ->
+  (* By convention, use IntroIdentifier for unbound ident, when not in a def *)
+  match r with
+  | Ident (loc,id) when not strict ->
+    let ipat = in_gen (glbwit wit_intro_pattern) (loc, IntroNaming (IntroIdentifier id)) in
+    TacGeneric ipat
+  | _ ->
+  (* Reference not found *)
+  error_global_not_found_loc (qualid_of_reference r)
+
+let intern_message_token ist = function
+  | (MsgString _ | MsgInt _ as x) -> x
+  | MsgIdent id -> MsgIdent (intern_hyp ist id)
+
+let intern_message ist = List.map (intern_message_token ist)
+
+let intern_quantified_hypothesis ist = function
+  | AnonHyp n -> AnonHyp n
+  | NamedHyp id ->
+      (* Uncomment to disallow "intros until n" in ltac when n is not bound *)
+      NamedHyp ((*snd (intern_hyp ist (dloc,*)id(* ))*))
+
+let intern_binding_name ist x =
+  (* We use identifier both for variables and binding names *)
+  (* Todo: consider the body of the lemma to which the binding refer
+     and if a term w/o ltac vars, check the name is indeed quantified *)
+  x
+
+let intern_constr_gen allow_patvar isarity {ltacvars=lfun; genv=env} c =
+  let warn = if !strict_check then fun x -> x else Constrintern.for_grammar in
+  let scope = if isarity then Pretyping.IsType else Pretyping.WithoutTypeConstraint in
+  let ltacvars = {
+    Constrintern.ltac_vars = lfun;
+    ltac_bound = Id.Set.empty;
+  } in
+  let c' =
+    warn (Constrintern.intern_gen scope ~allow_patvar ~ltacvars env) c
+  in
+  (c',if !strict_check then None else Some c)
+
+let intern_constr = intern_constr_gen false false
+let intern_type = intern_constr_gen false true
+
+(* Globalize bindings *)
+let intern_binding ist (loc,b,c) =
+  (loc,intern_binding_name ist b,intern_constr ist c)
+
+let intern_bindings ist = function
+  | NoBindings -> NoBindings
+  | ImplicitBindings l -> ImplicitBindings (List.map (intern_constr ist) l)
+  | ExplicitBindings l -> ExplicitBindings (List.map (intern_binding ist) l)
+
+let intern_constr_with_bindings ist (c,bl) =
+  (intern_constr ist c, intern_bindings ist bl)
+
+let intern_constr_with_bindings_arg ist (clear,c) =
+  (clear,intern_constr_with_bindings ist c)
+
+let rec intern_intro_pattern lf ist = function
+  | loc, IntroNaming pat ->
+      loc, IntroNaming (intern_intro_pattern_naming lf ist pat)
+  | loc, IntroAction pat ->
+      loc, IntroAction (intern_intro_pattern_action lf ist pat)
+  | loc, IntroForthcoming _ as x -> x
+
+and intern_intro_pattern_naming lf ist = function
+  | IntroIdentifier id ->
+      IntroIdentifier (intern_ident lf ist id)
+  | IntroFresh id ->
+      IntroFresh (intern_ident lf ist id)
+  | IntroAnonymous as x -> x
+
+and intern_intro_pattern_action lf ist = function
+  | IntroOrAndPattern l ->
+      IntroOrAndPattern (intern_or_and_intro_pattern lf ist l)
+  | IntroInjection l ->
+      IntroInjection (List.map (intern_intro_pattern lf ist) l)
+  | IntroWildcard | IntroRewrite _ as x -> x
+  | IntroApplyOn (c,pat) ->
+      IntroApplyOn (intern_constr ist c, intern_intro_pattern lf ist pat)
+
+and intern_or_and_intro_pattern lf ist =
+  List.map (List.map (intern_intro_pattern lf ist))
+
+let intern_or_and_intro_pattern_loc lf ist = function
+  | ArgVar (_,id) as x ->
+      if find_var id ist then x
+      else error "Disjunctive/conjunctive introduction pattern expected."
+  | ArgArg (loc,l) -> ArgArg (loc,intern_or_and_intro_pattern lf ist l)
+
+let intern_intro_pattern_naming_loc lf ist (loc,pat) =
+  (loc,intern_intro_pattern_naming lf ist pat)
+
+  (* TODO: catch ltac vars *)
+let intern_induction_arg ist = function
+  | clear,ElimOnConstr c -> clear,ElimOnConstr (intern_constr_with_bindings ist c)
+  | clear,ElimOnAnonHyp n as x -> x
+  | clear,ElimOnIdent (loc,id) ->
+      if !strict_check then
+	(* If in a defined tactic, no intros-until *)
+	match intern_constr ist (CRef (Ident (dloc,id), None)) with
+	| GVar (loc,id),_ -> clear,ElimOnIdent (loc,id)
+	| c -> clear,ElimOnConstr (c,NoBindings)
+      else
+	clear,ElimOnIdent (loc,id)
+
+let short_name = function
+  | AN (Ident (loc,id)) when not !strict_check -> Some (loc,id)
+  | _ -> None
+
+let intern_evaluable_global_reference ist r =
+  let lqid = qualid_of_reference r in
+  try evaluable_of_global_reference ist.genv (locate_global_with_alias ~head:true lqid)
+  with Not_found ->
+  match r with
+  | Ident (loc,id) when not !strict_check -> EvalVarRef id
+  | _ -> error_global_not_found_loc lqid
+
+let intern_evaluable_reference_or_by_notation ist = function
+  | AN r -> intern_evaluable_global_reference ist r
+  | ByNotation (loc,ntn,sc) ->
+      evaluable_of_global_reference ist.genv
+      (Notation.interp_notation_as_global_reference loc
+        (function ConstRef _ | VarRef _ -> true | _ -> false) ntn sc)
+
+(* Globalize a reduction expression *)
+let intern_evaluable ist = function
+  | AN (Ident (loc,id)) when find_var id ist -> ArgVar (loc,id)
+  | AN (Ident (loc,id)) when not !strict_check && find_hyp id ist ->
+      ArgArg (EvalVarRef id, Some (loc,id))
+  | r ->
+      let e = intern_evaluable_reference_or_by_notation ist r in
+      let na = short_name r in
+      ArgArg (e,na)
+
+let intern_unfold ist (l,qid) = (l,intern_evaluable ist qid)
+
+let intern_flag ist red =
+  { red with rConst = List.map (intern_evaluable ist) red.rConst }
+
+let intern_constr_with_occurrences ist (l,c) = (l,intern_constr ist c)
+
+let intern_constr_pattern ist ~as_type ~ltacvars pc =
+  let ltacvars = {
+    Constrintern.ltac_vars = ltacvars;
+    ltac_bound = Id.Set.empty;
+  } in
+  let metas,pat = Constrintern.intern_constr_pattern
+    ist.genv ~as_type ~ltacvars pc
+  in
+  let c = intern_constr_gen true false ist pc in
+  metas,(c,pat)
+
+let dummy_pat = PRel 0
+
+let intern_typed_pattern ist p =
+  (* 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 glob_constr only *)
+  (intern_constr_gen true false ist p,dummy_pat)
+
+let rec intern_typed_pattern_or_ref_with_occurrences ist (l,p) =
+  let interp_ref r =
+    try l, Inl (intern_evaluable ist r)
+    with e when Logic.catchable_exception e ->
+      (* Compatibility. In practice, this means that the code above
+         is useless. Still the idea of having either an evaluable
+         ref or a pattern seems interesting, with "head" reduction
+         in case of an evaluable ref, and "strong" reduction in the
+         subterm matched when a pattern *)
+      let loc = loc_of_smart_reference r in
+      let r = match r with
+      | AN r -> r
+      | _ -> Qualid (loc,qualid_of_path (path_of_global (smart_global r))) in
+      let sign = { Constrintern.ltac_vars = ist.ltacvars; Constrintern.ltac_bound = Id.Set.empty } in
+      let c = Constrintern.interp_reference sign r in
+      match c with
+      | GRef (_,r,None) ->
+          l, Inl (ArgArg (evaluable_of_global_reference ist.genv r,None))
+      | GVar (_,id) ->
+          let r = evaluable_of_global_reference ist.genv (VarRef id) in
+          l, Inl (ArgArg (r,None))
+      | _ ->
+          l, Inr ((c,None),dummy_pat) in
+  match p with
+  | Inl r -> interp_ref r
+  | Inr (CAppExpl(_,(None,r,None),[])) ->
+      (* We interpret similarly @ref and ref *)
+      interp_ref (AN r)
+  | Inr c ->
+      l, Inr (intern_typed_pattern ist c)
+
+(* This seems fairly hacky, but it's the first way I've found to get proper
+   globalization of [unfold].  --adamc *)
+let dump_glob_red_expr = function
+  | Unfold occs -> List.iter (fun (_, r) ->
+    try
+      Dumpglob.add_glob (loc_of_or_by_notation Libnames.loc_of_reference r)
+	(Smartlocate.smart_global r)
+    with e when Errors.noncritical e -> ()) occs
+  | Cbv grf | Lazy grf ->
+    List.iter (fun r ->
+      try
+        Dumpglob.add_glob (loc_of_or_by_notation Libnames.loc_of_reference r)
+	  (Smartlocate.smart_global r)
+      with e when Errors.noncritical e -> ()) grf.rConst
+  | _ -> ()
+
+let intern_red_expr ist = function
+  | Unfold l -> Unfold (List.map (intern_unfold ist) l)
+  | Fold l -> Fold (List.map (intern_constr ist) l)
+  | Cbv f -> Cbv (intern_flag ist f)
+  | Cbn f -> Cbn (intern_flag ist f)
+  | Lazy f -> Lazy (intern_flag ist f)
+  | Pattern l -> Pattern (List.map (intern_constr_with_occurrences ist) l)
+  | Simpl (f,o) ->
+     Simpl (intern_flag ist f,
+	    Option.map (intern_typed_pattern_or_ref_with_occurrences ist) o)
+  | CbvVm o -> CbvVm (Option.map (intern_typed_pattern_or_ref_with_occurrences ist) o)
+  | CbvNative o -> CbvNative (Option.map (intern_typed_pattern_or_ref_with_occurrences ist) o)
+  | (Red _ | Hnf | ExtraRedExpr _ as r ) -> r
+
+let intern_in_hyp_as ist lf (clear,id,ipat) =
+  (clear,intern_hyp ist id, Option.map (intern_intro_pattern lf ist) ipat)
+
+let intern_hyp_list ist = List.map (intern_hyp ist)
+
+let intern_inversion_strength lf ist = function
+  | NonDepInversion (k,idl,ids) ->
+      NonDepInversion (k,intern_hyp_list ist idl,
+      Option.map (intern_or_and_intro_pattern_loc lf ist) ids)
+  | DepInversion (k,copt,ids) ->
+      DepInversion (k, Option.map (intern_constr ist) copt,
+      Option.map (intern_or_and_intro_pattern_loc lf ist) ids)
+  | InversionUsing (c,idl) ->
+      InversionUsing (intern_constr ist c, intern_hyp_list ist idl)
+
+(* Interprets an hypothesis name *)
+let intern_hyp_location ist ((occs,id),hl) =
+  ((Locusops.occurrences_map (List.map (intern_int_or_var ist)) occs,
+   intern_hyp ist id), hl)
+
+(* Reads a pattern *)
+let intern_pattern ist ?(as_type=false) ltacvars = function
+  | Subterm (b,ido,pc) ->
+      let (metas,pc) = intern_constr_pattern ist ~as_type ~ltacvars pc in
+      ido, metas, Subterm (b,ido,pc)
+  | Term pc ->
+      let (metas,pc) = intern_constr_pattern ist ~as_type ~ltacvars pc in
+      None, metas, Term pc
+
+let intern_constr_may_eval ist = function
+  | ConstrEval (r,c) -> ConstrEval (intern_red_expr ist r,intern_constr ist c)
+  | ConstrContext (locid,c) ->
+      ConstrContext (intern_hyp ist locid,intern_constr ist c)
+  | ConstrTypeOf c -> ConstrTypeOf (intern_constr ist c)
+  | ConstrTerm c -> ConstrTerm (intern_constr ist c)
+
+let name_cons accu = function
+| Anonymous -> accu
+| Name id -> Id.Set.add id accu
+
+let opt_cons accu = function
+| None -> accu
+| Some id -> Id.Set.add id accu
+
+(* Reads the hypotheses of a "match goal" rule *)
+let rec intern_match_goal_hyps ist lfun = function
+  | (Hyp ((_,na) as locna,mp))::tl ->
+      let ido, metas1, pat = intern_pattern ist ~as_type:true lfun mp in
+      let lfun, metas2, hyps = intern_match_goal_hyps ist lfun tl in
+      let lfun' = name_cons (opt_cons lfun ido) na in
+      lfun', metas1@metas2, Hyp (locna,pat)::hyps
+  | (Def ((_,na) as locna,mv,mp))::tl ->
+      let ido, metas1, patv = intern_pattern ist ~as_type:false lfun mv in
+      let ido', metas2, patt = intern_pattern ist ~as_type:true lfun mp in
+      let lfun, metas3, hyps = intern_match_goal_hyps ist lfun tl in
+      let lfun' = name_cons (opt_cons (opt_cons lfun ido) ido') na in
+      lfun', metas1@metas2@metas3, Def (locna,patv,patt)::hyps
+  | [] -> lfun, [], []
+
+(* Utilities *)
+let extract_let_names lrc =
+  let fold accu ((loc, name), _) =
+    if Id.Set.mem name accu then user_err_loc
+      (loc, "glob_tactic", str "This variable is bound several times.")
+    else Id.Set.add name accu
+  in
+  List.fold_left fold Id.Set.empty lrc
+
+let clause_app f = function
+    { onhyps=None; concl_occs=nl } ->
+      { onhyps=None; concl_occs=nl }
+  | { onhyps=Some l; concl_occs=nl } ->
+      { onhyps=Some(List.map f l); concl_occs=nl}
+
+let map_raw wit f ist x =
+  in_gen (glbwit wit) (f ist (out_gen (rawwit wit) x))
+
+(* Globalizes tactics : raw_tactic_expr -> glob_tactic_expr *)
+let rec intern_atomic lf ist x =
+  match (x:raw_atomic_tactic_expr) with
+  (* Basic tactics *)
+  | TacIntroPattern l ->
+      TacIntroPattern (List.map (intern_intro_pattern lf ist) l)
+  | TacIntroMove (ido,hto) ->
+      TacIntroMove (Option.map (intern_ident lf ist) ido,
+                    intern_move_location ist hto)
+  | TacExact c -> TacExact (intern_constr ist c)
+  | TacApply (a,ev,cb,inhyp) ->
+      TacApply (a,ev,List.map (intern_constr_with_bindings_arg ist) cb,
+                Option.map (intern_in_hyp_as ist lf) inhyp)
+  | TacElim (ev,cb,cbo) ->
+      TacElim (ev,intern_constr_with_bindings_arg ist cb,
+               Option.map (intern_constr_with_bindings ist) cbo)
+  | TacCase (ev,cb) -> TacCase (ev,intern_constr_with_bindings_arg ist cb)
+  | TacFix (idopt,n) -> TacFix (Option.map (intern_ident lf ist) idopt,n)
+  | TacMutualFix (id,n,l) ->
+      let f (id,n,c) = (intern_ident lf ist id,n,intern_type ist c) in
+      TacMutualFix (intern_ident lf ist id, n, List.map f l)
+  | TacCofix idopt -> TacCofix (Option.map (intern_ident lf ist) idopt)
+  | TacMutualCofix (id,l) ->
+      let f (id,c) = (intern_ident lf ist id,intern_type ist c) in
+      TacMutualCofix (intern_ident lf ist id, List.map f l)
+  | TacAssert (b,otac,ipat,c) ->
+      TacAssert (b,Option.map (intern_pure_tactic ist) otac,
+                 Option.map (intern_intro_pattern lf ist) ipat,
+                 intern_constr_gen false (not (Option.is_empty otac)) ist c)
+  | TacGeneralize cl ->
+      TacGeneralize (List.map (fun (c,na) ->
+	               intern_constr_with_occurrences ist c,
+                       intern_name lf ist na) cl)
+  | TacGeneralizeDep c -> TacGeneralizeDep (intern_constr ist c)
+  | TacLetTac (na,c,cls,b,eqpat) ->
+      let na = intern_name lf ist na in
+      TacLetTac (na,intern_constr ist c,
+                 (clause_app (intern_hyp_location ist) cls),b,
+		 (Option.map (intern_intro_pattern_naming_loc lf ist) eqpat))
+
+  (* Automation tactics *)
+  | TacTrivial (d,lems,l) -> TacTrivial (d,List.map (intern_constr ist) lems,l)
+  | TacAuto (d,n,lems,l) ->
+      TacAuto (d,Option.map (intern_int_or_var ist) n,
+        List.map (intern_constr ist) lems,l)
+
+  (* Derived basic tactics *)
+  | TacInductionDestruct (ev,isrec,(l,el)) ->
+      TacInductionDestruct (ev,isrec,(List.map (fun (c,(ipato,ipats),cls) ->
+	      (intern_induction_arg ist c,
+               (Option.map (intern_intro_pattern_naming_loc lf ist) ipato,
+               Option.map (intern_or_and_intro_pattern_loc lf ist) ipats),
+               Option.map (clause_app (intern_hyp_location ist)) cls)) l,
+               Option.map (intern_constr_with_bindings ist) el))
+  | TacDoubleInduction (h1,h2) ->
+      let h1 = intern_quantified_hypothesis ist h1 in
+      let h2 = intern_quantified_hypothesis ist h2 in
+      TacDoubleInduction (h1,h2)
+  (* Context management *)
+  | TacClear (b,l) -> TacClear (b,List.map (intern_hyp ist) l)
+  | TacClearBody l -> TacClearBody (List.map (intern_hyp ist) l)
+  | TacMove (id1,id2) ->
+    TacMove (intern_hyp ist id1,intern_move_location ist id2)
+  | TacRename l ->
+      TacRename (List.map (fun (id1,id2) ->
+			     intern_hyp ist id1,
+			     intern_hyp ist id2) l)
+
+  (* Constructors *)
+  | TacSplit (ev,bll) -> TacSplit (ev,List.map (intern_bindings ist) bll)
+
+  (* Conversion *)
+  | TacReduce (r,cl) ->
+      dump_glob_red_expr r;
+      TacReduce (intern_red_expr ist r, clause_app (intern_hyp_location ist) cl)
+  | TacChange (None,c,cl) ->
+      let is_onhyps = match cl.onhyps with
+      | None | Some [] -> true
+      | _ -> false
+      in
+      let is_onconcl = match cl.concl_occs with
+      | AllOccurrences | NoOccurrences -> true
+      | _ -> false
+      in
+      TacChange (None,
+        (if is_onhyps && is_onconcl
+         then intern_type ist c else intern_constr ist c),
+	clause_app (intern_hyp_location ist) cl)
+  | TacChange (Some p,c,cl) ->
+      TacChange (Some (intern_typed_pattern ist p),intern_constr ist c,
+	clause_app (intern_hyp_location ist) cl)
+
+  (* Equivalence relations *)
+  | TacSymmetry idopt ->
+      TacSymmetry (clause_app (intern_hyp_location ist) idopt)
+
+  (* Equality and inversion *)
+  | TacRewrite (ev,l,cl,by) ->
+      TacRewrite
+	(ev,
+	List.map (fun (b,m,c) -> (b,m,intern_constr_with_bindings_arg ist c)) l,
+	clause_app (intern_hyp_location ist) cl,
+	Option.map (intern_pure_tactic ist) by)
+  | TacInversion (inv,hyp) ->
+      TacInversion (intern_inversion_strength lf ist inv,
+        intern_quantified_hypothesis ist hyp)
+
+and intern_tactic onlytac ist tac = snd (intern_tactic_seq onlytac ist tac)
+
+and intern_tactic_seq onlytac ist = function
+  | TacAtom (loc,t) ->
+      let lf = ref ist.ltacvars in
+      let t = intern_atomic lf ist t in
+      !lf, TacAtom (adjust_loc loc, t)
+  | TacFun tacfun -> ist.ltacvars, TacFun (intern_tactic_fun ist tacfun)
+  | TacLetIn (isrec,l,u) ->
+      let ltacvars = Id.Set.union (extract_let_names l) ist.ltacvars in
+      let ist' = { ist with ltacvars } in
+      let l = List.map (fun (n,b) ->
+	  (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 onlytac ist lmr)
+  | TacMatch (lz,c,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 (g,n,l) ->
+      ist.ltacvars, TacFail (g,intern_int_or_var ist n,intern_message ist l)
+  | TacProgress tac -> ist.ltacvars, TacProgress (intern_pure_tactic ist tac)
+  | TacShowHyps tac -> ist.ltacvars, TacShowHyps (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 onlytac ist t1 in
+      let lfun'', t2 = intern_tactic_seq onlytac { ist with ltacvars = lfun' } t2 in
+      lfun'', TacThen (t1,t2)
+  | TacDispatch tl ->
+      ist.ltacvars , TacDispatch (List.map (intern_pure_tactic ist) tl)
+  | TacExtendTac (tf,t,tl) ->
+      ist.ltacvars ,
+      TacExtendTac (Array.map (intern_pure_tactic ist) tf,
+                    intern_pure_tactic ist t,
+		    Array.map (intern_pure_tactic ist) tl)
+  | TacThens3parts (t1,tf,t2,tl) ->
+      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', TacThens3parts (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 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_pure_tactic ist') tl)
+  | TacDo (n,tac) ->
+      ist.ltacvars, TacDo (intern_int_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_int_or_var ist n,intern_tactic onlytac ist tac)
+  | TacTime (s,tac) ->
+      ist.ltacvars, TacTime (s,intern_tactic onlytac ist tac)
+  | TacOr (tac1,tac2) ->
+      ist.ltacvars, TacOr (intern_pure_tactic ist tac1,intern_pure_tactic ist tac2)
+  | TacOnce tac ->
+      ist.ltacvars, TacOnce (intern_pure_tactic ist tac)
+  | TacExactlyOnce tac ->
+      ist.ltacvars, TacExactlyOnce (intern_pure_tactic ist tac)
+  | TacIfThenCatch (tac,tact,tace) ->
+      ist.ltacvars,
+      TacIfThenCatch (
+        intern_pure_tactic ist tac,
+        intern_pure_tactic ist tact,
+        intern_pure_tactic ist tace)
+  | TacOrelse (tac1,tac2) ->
+      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
+
+  (* For extensions *)
+  | TacAlias (loc,s,l) ->
+      let l = List.map (fun (id,a) -> (id,intern_genarg ist a)) l in
+      ist.ltacvars, TacAlias (loc,s,l)
+  | TacML (loc,opn,l) ->
+      let _ignore = Tacenv.interp_ml_tactic opn in
+      ist.ltacvars, TacML (adjust_loc loc,opn,List.map (intern_genarg ist) l)
+
+and intern_tactic_as_arg loc onlytac ist a =
+  match intern_tacarg !strict_check onlytac ist a with
+  | TacCall _ | Reference _
+  | TacDynamic _ | TacGeneric _ as a -> TacArg (loc,a)
+  | Tacexp a -> a
+  | ConstrMayEval _ | UConstr _ | TacFreshId _ | TacPretype _ | TacNumgoals 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 lfun = List.fold_left opt_cons ist.ltacvars var in
+  (var,intern_tactic_or_tacarg { ist with ltacvars = lfun } body)
+
+and intern_tacarg strict onlytac ist = function
+  | Reference r -> intern_non_tactic_reference strict ist r
+  | ConstrMayEval c -> ConstrMayEval (intern_constr_may_eval ist c)
+  | UConstr c -> UConstr (intern_constr ist c)
+  | MetaIdArg (loc,istac,s) ->
+      (* $id can occur in Grammar tactic... *)
+      let id = Id.of_string s in
+      if find_var id ist then
+	if istac then Reference (ArgVar (adjust_loc loc,id))
+	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 false ist) l)
+  | TacFreshId x -> TacFreshId (List.map (intern_string_or_var ist) x)
+  | TacPretype c -> TacPretype (intern_constr ist c)
+  | TacNumgoals -> TacNumgoals
+  | Tacexp t -> Tacexp (intern_tactic onlytac ist t)
+  | TacGeneric arg ->
+    let (_, arg) = Genintern.generic_intern ist arg in
+    TacGeneric arg
+  | TacDynamic(loc,t) as x ->
+    if Dyn.has_tag t "tactic" || Dyn.has_tag t "value" then x
+    else if Dyn.has_tag t "constr" then
+      if onlytac then error_tactic_expected loc else x
+    else
+      let tag = Dyn.tag t in
+      anomaly ~loc (str "Unknown dynamic: <" ++ str tag ++ str ">")
+
+(* Reads the rules of a Match Context or a Match *)
+and intern_match_rule onlytac ist = function
+  | (All tc)::tl ->
+      All (intern_tactic onlytac ist tc) :: (intern_match_rule onlytac ist tl)
+  | (Pat (rl,mp,tc))::tl ->
+      let {ltacvars=lfun; 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 fold accu x = Id.Set.add x accu in
+      let ltacvars = List.fold_left fold (opt_cons lfun' ido) metas1 in
+      let ltacvars = List.fold_left fold ltacvars metas2 in
+      let ist' = { ist with ltacvars } in
+      Pat (hyps,pat,intern_tactic onlytac ist' tc) :: (intern_match_rule onlytac ist tl)
+  | [] -> []
+
+and intern_genarg ist x =
+  match genarg_tag x with
+  | IntOrVarArgType -> map_raw wit_int_or_var intern_int_or_var ist x
+  | IdentArgType ->
+    let lf = ref Id.Set.empty in
+    map_raw wit_ident (intern_ident lf) ist x
+  | VarArgType ->
+    map_raw wit_var intern_hyp ist x
+  | GenArgType ->
+    map_raw wit_genarg intern_genarg ist x
+  | ConstrArgType ->
+    map_raw wit_constr intern_constr ist x
+  | ConstrMayEvalArgType ->
+    map_raw wit_constr_may_eval intern_constr_may_eval ist x
+  | QuantHypArgType ->
+    map_raw wit_quant_hyp intern_quantified_hypothesis ist x
+  | RedExprArgType ->
+    map_raw wit_red_expr intern_red_expr ist x
+  | OpenConstrArgType ->
+    map_raw wit_open_constr (fun ist -> on_snd (intern_constr ist)) ist x
+  | ConstrWithBindingsArgType ->
+    map_raw wit_constr_with_bindings intern_constr_with_bindings ist x
+  | BindingsArgType ->
+    map_raw wit_bindings intern_bindings ist x
+  | ListArgType _ ->
+      let list_unpacker wit l =
+        let map x =
+          let ans = intern_genarg ist (in_gen (rawwit wit) x) in
+          out_gen (glbwit wit) ans
+        in
+        in_gen (glbwit (wit_list wit)) (List.map map (raw l))
+      in
+      list_unpack { list_unpacker } x
+  | OptArgType _ ->
+      let opt_unpacker wit o = match raw o with
+      | None -> in_gen (glbwit (wit_opt wit)) None
+      | Some x ->
+        let s = out_gen (glbwit wit) (intern_genarg ist (in_gen (rawwit wit) x)) in
+        in_gen (glbwit (wit_opt wit)) (Some s)
+      in
+      opt_unpack { opt_unpacker } x
+  | PairArgType _ ->
+      let pair_unpacker wit1 wit2 o =
+        let p, q = raw o in
+        let p = out_gen (glbwit wit1) (intern_genarg ist (in_gen (rawwit wit1) p)) in
+        let q = out_gen (glbwit wit2) (intern_genarg ist (in_gen (rawwit wit2) q)) in
+        in_gen (glbwit (wit_pair wit1 wit2)) (p, q)
+      in
+      pair_unpack { pair_unpacker } x
+  | ExtraArgType s ->
+      snd (Genintern.generic_intern ist x)
+
+(** Other entry points *)
+
+let glob_tactic x =
+  Flags.with_option strict_check
+    (intern_pure_tactic (make_empty_glob_sign ())) x
+
+let glob_tactic_env l env x =
+  let ltacvars =
+    List.fold_left (fun accu x -> Id.Set.add x accu) Id.Set.empty l in
+  Flags.with_option strict_check
+  (intern_pure_tactic
+    { ltacvars; ltacrecvars = Id.Map.empty; genv = env })
+    x
+
+let 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 l,t = split_ltac_fun (Tacenv.interp_ltac 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"
+    (pr_qualid id ++ spc() ++ str "is not a user defined tactic.")
+
+(** Registering *)
+
+let lift intern = (); fun ist x -> (ist, intern ist x)
+
+let () =
+  let intern_intro_pattern ist pat =
+    let lf = ref Id.Set.empty in
+    let ans = intern_intro_pattern lf ist pat in
+    let ist = { ist with ltacvars = !lf } in
+    (ist, ans)
+  in
+  Genintern.register_intern0 wit_intro_pattern intern_intro_pattern
+
+let () =
+  let intern_clause ist cl =
+    let ans = clause_app (intern_hyp_location ist) cl in
+    (ist, ans)
+  in
+  Genintern.register_intern0 wit_clause_dft_concl intern_clause
+
+let () =
+  Genintern.register_intern0 wit_ref (lift intern_global_reference);
+  Genintern.register_intern0 wit_tactic (lift intern_tactic_or_tacarg);
+  Genintern.register_intern0 wit_sort (fun ist s -> (ist, s))
+
+let () =
+  Genintern.register_intern0 wit_uconstr (fun ist c -> (ist,intern_constr ist c))
+
+(***************************************************************************)
+(* Backwarding recursive needs of tactic glob/interp/eval functions *)
+
+let _ =
+  let f l =
+    let ltacvars =
+      List.fold_left (fun accu x -> Id.Set.add x accu) Id.Set.empty l
+    in
+    Flags.with_option strict_check
+    (intern_pure_tactic { (make_empty_glob_sign()) with ltacvars })
+  in
+  Hook.set Hints.extern_intern_tac f
diff --git a/tactics/tacintern.mli b/tactics/tacintern.mli
new file mode 100644
index 00000000..2e662e58
--- /dev/null
+++ b/tactics/tacintern.mli
@@ -0,0 +1,66 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+open Pp
+open Names
+open Tacexpr
+open Genarg
+open Constrexpr
+open Misctypes
+open Nametab
+
+(** Globalization of tactic expressions :
+    Conversion from [raw_tactic_expr] to [glob_tactic_expr] *)
+
+type glob_sign = Genintern.glob_sign = {
+  ltacvars : Id.Set.t;
+  ltacrecvars : ltac_constant Id.Map.t;
+  genv : Environ.env }
+
+val fully_empty_glob_sign : glob_sign
+
+val make_empty_glob_sign : unit -> glob_sign
+ (** same as [fully_empty_glob_sign], but with [Global.env()] as
+     environment *)
+
+(** Main globalization functions *)
+
+val glob_tactic : raw_tactic_expr -> glob_tactic_expr
+
+val glob_tactic_env :
+  Id.t list -> Environ.env -> raw_tactic_expr -> glob_tactic_expr
+
+(** Low-level variants *)
+
+val intern_pure_tactic : glob_sign -> raw_tactic_expr -> glob_tactic_expr
+
+val intern_tactic_or_tacarg :
+  glob_sign -> raw_tactic_expr -> Tacexpr.glob_tactic_expr
+
+val intern_constr : glob_sign -> constr_expr -> glob_constr_and_expr
+
+val intern_constr_with_bindings :
+  glob_sign -> constr_expr * constr_expr bindings ->
+  glob_constr_and_expr * glob_constr_and_expr bindings
+
+val intern_hyp : glob_sign -> Id.t Loc.located -> Id.t Loc.located
+
+(** Adds a globalization function for extra generic arguments *)
+
+val intern_genarg : glob_sign -> raw_generic_argument -> glob_generic_argument
+
+(** printing *)
+val print_ltac : Libnames.qualid -> std_ppcmds
+
+(** Reduction expressions *)
+
+val intern_red_expr : glob_sign -> raw_red_expr -> glob_red_expr
+val dump_glob_red_expr : raw_red_expr -> unit
+
+(* Hooks *)
+val strict_check : bool ref
diff --git a/tactics/tacinterp.ml b/tactics/tacinterp.ml
index e5575a2c..23de47d5 100644
--- a/tactics/tacinterp.ml
+++ b/tactics/tacinterp.ml
@@ -1,1001 +1,287 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
 open Constrintern
-open Closure
-open RedFlags
-open Declarations
-open Entries
-open Libobject
-open Pattern
-open Matching
+open Patternops
 open Pp
+open Genredexpr
 open Glob_term
-open Sign
+open Glob_ops
 open Tacred
+open Errors
 open Util
 open Names
 open Nameops
 open Libnames
+open Globnames
 open Nametab
-open Smartlocate
 open Pfedit
 open Proof_type
 open Refiner
 open Tacmach
 open Tactic_debug
-open Topconstr
+open Constrexpr
 open Term
 open Termops
 open Tacexpr
-open Safe_typing
-open Typing
-open Hiddentac
 open Genarg
-open Decl_kinds
-open Mod_subst
+open Stdarg
+open Constrarg
 open Printer
-open Inductiveops
-open Syntax_def
 open Pretyping
-open Pretyping.Default
-open Extrawit
-open Pcoq
-open Compat
+module Monad_ = Monad
 open Evd
+open Misctypes
+open Locus
+open Tacintern
+open Taccoerce
+open Proofview.Notations
 
 let safe_msgnl s =
-    try msgnl s with e when Errors.noncritical e ->
-      msgnl
-	(str "bug in the debugger: " ++
-         str "an exception is raised while printing debug information")
-
-let error_syntactic_metavariables_not_allowed loc =
-  user_err_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
+  Proofview.NonLogical.catch
+    (Proofview.NonLogical.print (s++fnl()))
+    (fun _ -> Proofview.NonLogical.print (str "bug in the debugger: an exception is raised while printing debug information"++fnl()))
+
+type value = tlevel generic_argument
+
+(** Abstract application, to print ltac functions *)
+type appl =
+  | UnnamedAppl (** For generic applications: nothing is printed *)
+  | GlbAppl of (Names.kernel_name * typed_generic_argument list) list
+       (** For calls to global constants, some may alias other. *)
+let push_appl appl args =
+  match appl with
+  | UnnamedAppl -> UnnamedAppl
+  | GlbAppl l -> GlbAppl (List.map (fun (h,vs) -> (h,vs@args)) l)
+let pr_generic arg =
+  let pr_gtac _ x = Pptactic.pr_glob_tactic (Global.env()) x in
+  try
+    Pptactic.pr_top_generic pr_constr pr_lconstr pr_gtac pr_constr_pattern arg
+  with e when Errors.noncritical e -> str"<generic>"
+let pr_appl h vs =
+  Pptactic.pr_ltac_constant  h ++ spc () ++
+  Pp.prlist_with_sep spc pr_generic vs
+let rec name_with_list appl t =
+  match appl with
+  | [] -> t
+  | (h,vs)::l -> Proofview.Trace.name_tactic (fun () -> pr_appl h vs) (name_with_list l t)
+let name_if_glob appl t =
+  match appl with
+  | UnnamedAppl -> t
+  | GlbAppl l -> name_with_list l t
+let combine_appl appl1 appl2 =
+  match appl1,appl2 with
+  | UnnamedAppl,a | a,UnnamedAppl -> a
+  | GlbAppl l1 , GlbAppl l2 -> GlbAppl (l2@l1)
 
 (* Values for interpretation *)
-type value =
-  | 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
-  | VVoid
-  | VInteger of int
-  | VIntroPattern of intro_pattern_expr (* includes idents which are not *)
-                        (* bound as in "Intro H" but which may be bound *)
-                        (* later, as in "tac" in "Intro H; tac" *)
-  | VConstr of constr_under_binders
-                        (* includes idents known to be bound and references *)
-  | VConstr_context of constr
-  | VList of value list
-  | VRec of (identifier*value) list ref * glob_tactic_expr
-
-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
-  | Loc.Exc_located (_,LtacLocated _) as e -> raise e
-  | e when Errors.noncritical e ->
-    let (nrep,loc',c),tail = list_sep_last call_trace in
-    let loc,e' = match e with Loc.Exc_located(loc,e) -> loc,e | _ ->dloc,e in
-    if tail = [] then
-      let loc = if loc = dloc then loc' else loc in
-      raise (Loc.Exc_located(loc,e'))
-    else
-      raise (Loc.Exc_located(loc',LtacLocated((nrep,c,tail,loc),e')))
-
-(* Signature for interpretation: val_interp and interpretation functions *)
-type interp_sign =
-    { lfun : (identifier * value) list;
-      avoid_ids : identifier list; (* ids inherited from the call context
-				      (needed to get fresh ids) *)
-      debug : debug_info;
-      trace : ltac_trace }
-
-let check_is_value = function
-  | VRTactic _ -> (* These are goals produced by Match *)
-   error "Immediate match producing tactics not allowed in local definitions."
-  | _ -> ()
-
-(* Gives the constr corresponding to a Constr_context tactic_arg *)
-let constr_of_VConstr_context = function
-  | VConstr_context c -> c
-  | _ ->
-    errorlabstrm "constr_of_VConstr_context" (str "Not a context variable.")
-
-(* Displays a value *)
-let rec pr_value env = function
-  | VVoid -> str "()"
-  | VInteger n -> int n
-  | VIntroPattern ipat -> pr_intro_pattern (dloc,ipat)
-  | VConstr c ->
-      (match env with Some env ->
-	pr_lconstr_under_binders_env env c | _ -> str "a term")
-  | VConstr_context c ->
-      (match env with Some env -> pr_lconstr_env env c | _ -> str "a term")
-  | (VRTactic _ | VFun _ | VRec _) -> str "a tactic"
-  | VList [] -> str "an empty list"
-  | VList (a::_) ->
-      str "a list (first element is " ++ pr_value env a ++ str")"
-
-(* Transforms an id into a constr if possible, or fails with Not_found *)
-let constr_of_id env id =
-  Term.mkVar (let _ = Environ.lookup_named id env in id)
+type tacvalue =
+  | VFun of appl*ltac_trace * value Id.Map.t *
+      Id.t option list * glob_tactic_expr
+  | VRec of value Id.Map.t ref * glob_tactic_expr
 
-(* To embed tactics *)
-let ((tactic_in : (interp_sign -> glob_tactic_expr) -> Dyn.t),
-     (tactic_out : Dyn.t -> (interp_sign -> glob_tactic_expr))) =
-  Dyn.create "tactic"
+let (wit_tacvalue : (Empty.t, Empty.t, tacvalue) Genarg.genarg_type) =
+  Genarg.create_arg None "tacvalue"
 
-let ((value_in : value -> Dyn.t),
-     (value_out : Dyn.t -> value)) = Dyn.create "value"
+let of_tacvalue v = in_gen (topwit wit_tacvalue) v
+let to_tacvalue v = out_gen (topwit wit_tacvalue) v
 
-let valueIn t = TacDynamic (dummy_loc,value_in t)
-let valueOut = function
-  | TacDynamic (_,d) ->
-    if (Dyn.tag d) = "value" then
-      value_out d
-    else
-      anomalylabstrm "valueOut" (str "Dynamic tag should be value")
-  | ast ->
-    anomalylabstrm "valueOut" (str "Not a Dynamic ast: ")
+(** More naming applications *)
+let name_vfun appl vle =
+  let vle = Value.normalize vle in
+  if has_type vle (topwit wit_tacvalue) then
+    match to_tacvalue vle with
+    | VFun (appl0,trace,lfun,vars,t) -> of_tacvalue (VFun (combine_appl appl0 appl,trace,lfun,vars,t))
+    | _ -> vle
+  else vle
 
-(* Table of "pervasives" macros tactics (e.g. auto, simpl, etc.) *)
-let atomic_mactab = ref Idmap.empty
-let add_primitive_tactic s tac =
-  let id = id_of_string s in
-  atomic_mactab := Idmap.add id tac !atomic_mactab
+module TacStore = Geninterp.TacStore
 
-let _ =
-  let nocl = {onhyps=Some[];concl_occs=all_occurrences_expr} in
-  List.iter
-      (fun (s,t) -> add_primitive_tactic s (TacAtom(dloc,t)))
-      [ "red", TacReduce(Red false,nocl);
-        "hnf", TacReduce(Hnf,nocl);
-        "simpl", TacReduce(Simpl None,nocl);
-        "compute", TacReduce(Cbv all_flags,nocl);
-        "intro", TacIntroMove(None,no_move);
-        "intros", TacIntroPattern [];
-        "assumption", TacAssumption;
-        "cofix", TacCofix None;
-        "trivial", TacTrivial (Off,[],None);
-        "auto", TacAuto(Off,None,[],None);
-        "left", TacLeft(false,NoBindings);
-        "eleft", TacLeft(true,NoBindings);
-        "right", TacRight(false,NoBindings);
-        "eright", TacRight(true,NoBindings);
-        "split", TacSplit(false,false,[NoBindings]);
-        "esplit", TacSplit(true,false,[NoBindings]);
-        "constructor", TacAnyConstructor (false,None);
-        "econstructor", TacAnyConstructor (true,None);
-        "reflexivity", TacReflexivity;
-        "symmetry", TacSymmetry nocl
-      ];
-  List.iter
-      (fun (s,t) -> add_primitive_tactic s t)
-      [ "idtac",TacId [];
-        "fail", TacFail(ArgArg 0,[]);
-        "fresh", TacArg(dloc,TacFreshId [])
-      ]
-
-let lookup_atomic id = Idmap.find id !atomic_mactab
-let is_atomic_kn kn =
-  let (_,_,l) = repr_kn kn in
-  Idmap.mem (id_of_label l) !atomic_mactab
-
-(* Summary and Object declaration *)
-let mactab = ref Gmap.empty
-
-let lookup r = Gmap.find r !mactab
+let f_avoid_ids : Id.t list TacStore.field = TacStore.field ()
+(* ids inherited from the call context (needed to get fresh ids) *)
+let f_debug : debug_info TacStore.field = TacStore.field ()
+let f_trace : ltac_trace TacStore.field = TacStore.field ()
 
-let _ =
-  let init () = mactab := Gmap.empty in
-  let freeze () = !mactab in
-  let unfreeze fs = mactab := fs in
-  Summary.declare_summary "tactic-definition"
-    { Summary.freeze_function   = freeze;
-      Summary.unfreeze_function = unfreeze;
-      Summary.init_function     = init }
-
-(* Tactics table (TacExtend). *)
-
-let tac_tab = Hashtbl.create 17
-
-let add_tactic s t =
-  if Hashtbl.mem tac_tab s then
-    errorlabstrm ("Refiner.add_tactic: ")
-      (str ("Cannot redeclare tactic "^s^"."));
-  Hashtbl.add tac_tab s t
-
-let overwriting_add_tactic s t =
-  if Hashtbl.mem tac_tab s then begin
-    Hashtbl.remove tac_tab s;
-    msg_warn ("Overwriting definition of tactic "^s)
-  end;
-  Hashtbl.add tac_tab s t
-
-let lookup_tactic s =
-  try
-    Hashtbl.find tac_tab s
-  with Not_found ->
-    errorlabstrm "Refiner.lookup_tactic"
-      (str"The tactic " ++ str s ++ str" is not installed.")
-(*
-let vernac_tactic (s,args) =
-  let tacfun = lookup_tactic s args in
-  abstract_extended_tactic s args tacfun
-*)
-(* Interpretation of extra generic arguments *)
-type glob_sign = {
-  ltacvars : identifier list * identifier list;
-     (* ltac variables and the subset of vars introduced by Intro/Let/... *)
-  ltacrecvars : (identifier * ltac_constant) list;
-     (* ltac recursive names *)
-  gsigma : Evd.evar_map;
-  genv : Environ.env }
-
-type interp_genarg_type =
-  (glob_sign -> raw_generic_argument -> glob_generic_argument) *
-  (interp_sign -> goal sigma -> glob_generic_argument ->
-    Evd.evar_map * typed_generic_argument) *
-  (substitution -> glob_generic_argument -> glob_generic_argument)
-
-let extragenargtab =
-  ref (Gmap.empty : (string,interp_genarg_type) Gmap.t)
-let add_interp_genarg id f =
-  extragenargtab := Gmap.add id f !extragenargtab
-let lookup_genarg id =
-  try Gmap.find id !extragenargtab
-  with Not_found ->
-    let msg = "No interpretation function found for entry " ^ id in
-    msg_warn msg;
-    let f = (fun _ _ -> failwith msg), (fun _ _ _ -> failwith msg), (fun _ a -> a) in
-    add_interp_genarg id f;
-    f
-
-
-let lookup_genarg_glob   id = let (f,_,_) = lookup_genarg id in f
-let lookup_interp_genarg id = let (_,f,_) = lookup_genarg id in f
-let lookup_genarg_subst  id = let (_,_,f) = lookup_genarg id in f
-
-let push_trace (loc,ck) = function
-  | (n,loc',ck')::trl when ck=ck' -> (n+1,loc,ck)::trl
-  | trl -> (1,loc,ck)::trl
-
-let propagate_trace ist loc id = function
-  | VFun (_,lfun,it,b) ->
-      let t = if it=[] then b else TacFun (it,b) in
-      VFun (push_trace(loc,LtacVarCall (id,t)) ist.trace,lfun,it,b)
-  | x -> x
-
-(* Dynamically check that an argument is a tactic *)
-let coerce_to_tactic loc id = function
-  | VFun _ | VRTactic _ as a -> a
-  | _ -> user_err_loc
-  (loc, "", str "Variable " ++ pr_id id ++ str " should be bound to a tactic.")
-
-(*****************)
-(* Globalization *)
-(*****************)
+(* Signature for interpretation: val_interp and interpretation functions *)
+type interp_sign = Geninterp.interp_sign = {
+  lfun : value Id.Map.t;
+  extra : TacStore.t }
 
-(* We have identifier <| global_reference <| constr *)
+let extract_trace ist = match TacStore.get ist.extra f_trace with
+| None -> []
+| Some l -> l
 
-let find_ident id ist =
-  List.mem id (fst ist.ltacvars) or
-  List.mem id (ids_of_named_context (Environ.named_context ist.genv))
+module Value = struct
 
-let find_recvar qid ist = List.assoc qid ist.ltacrecvars
+  include Taccoerce.Value
 
-(* a "var" is a ltac var or a var introduced by an intro tactic *)
-let find_var id ist = List.mem id (fst ist.ltacvars)
+  let of_closure ist tac =
+    let closure = VFun (UnnamedAppl,extract_trace ist, ist.lfun, [], tac) in
+    of_tacvalue closure
 
-(* a "ctxvar" is a var introduced by an intro tactic (Intro/LetTac/...) *)
-let find_ctxvar id ist = List.mem id (snd ist.ltacvars)
+end
 
-(* a "ltacvar" is an ltac var (Let-In/Fun/...) *)
-let find_ltacvar id ist = find_var id ist & not (find_ctxvar id ist)
+let dloc = Loc.ghost
 
-let find_hyp id ist =
-  List.mem id (ids_of_named_context (Environ.named_context ist.genv))
+let catching_error call_trace fail (e, info) =
+  let inner_trace =
+    Option.default [] (Exninfo.get info ltac_trace_info)
+  in
+  if List.is_empty call_trace && List.is_empty inner_trace then fail (e, info)
+  else begin
+    assert (Errors.noncritical e); (* preserved invariant *)
+    let new_trace = inner_trace @ call_trace in
+    let located_exc = (e, Exninfo.add info ltac_trace_info new_trace) in
+    fail located_exc
+  end
 
-(* Globalize a name introduced by Intro/LetTac/... ; it is allowed to *)
-(* be fresh in which case it is binding later on *)
-let intern_ident l ist id =
-  (* We use identifier both for variables and new names; thus nothing to do *)
-  if not (find_ident id ist) then l:=(id::fst !l,id::snd !l);
-  id
+let catch_error call_trace f x =
+  try f x
+  with e when Errors.noncritical e ->
+    let e = Errors.push e in
+    catching_error call_trace iraise e
 
-let intern_name l ist = function
-  | Anonymous -> Anonymous
-  | Name id -> Name (intern_ident l ist id)
+let catch_error_tac call_trace tac =
+  Proofview.tclORELSE
+    tac
+    (catching_error call_trace (fun (e, info) -> Proofview.tclZERO ~info e))
 
-let strict_check = ref false
+let curr_debug ist = match TacStore.get ist.extra f_debug with
+| None -> DebugOff
+| Some level -> level
 
-let adjust_loc loc = if !strict_check then dloc else loc
+(** TODO: unify printing of generic Ltac values in case of coercion failure. *)
 
-(* Globalize a name which must be bound -- actually just check it is bound *)
-let intern_hyp ist (loc,id as locid) =
-  if not !strict_check then
-    locid
-  else if find_ident id ist then
-    (dloc,id)
+(* Displays a value *)
+let pr_value env v =
+  let v = Value.normalize v in
+  if has_type v (topwit wit_tacvalue) then str "a tactic"
+  else if has_type v (topwit wit_constr_context) then
+    let c = out_gen (topwit wit_constr_context) v in
+    match env with
+    | Some (env,sigma) -> pr_lconstr_env env sigma c
+    | _ -> str "a term"
+  else if has_type v (topwit wit_constr) then
+    let c = out_gen (topwit wit_constr) v in
+    match env with
+    | Some (env,sigma) -> pr_lconstr_env env sigma c
+    | _ -> str "a term"
+  else if has_type v (topwit wit_constr_under_binders) then
+    let c = out_gen (topwit wit_constr_under_binders) v in
+    match env with
+    | Some (env,sigma) -> pr_lconstr_under_binders_env env sigma c
+    | _ -> str "a term"
   else
-    Pretype_errors.error_var_not_found_loc loc id
-
-let intern_hyp_or_metaid ist id = intern_hyp ist (skip_metaid id)
-
-let intern_or_var ist = function
-  | ArgVar locid -> ArgVar (intern_hyp ist locid)
-  | ArgArg _ as x -> x
-
-let intern_inductive_or_by_notation = smart_global_inductive
-
-let intern_inductive ist = function
-  | AN (Ident (loc,id)) when find_var id ist -> ArgVar (loc,id)
-  | r -> ArgArg (intern_inductive_or_by_notation r)
-
-let intern_global_reference ist = function
-  | Ident (loc,id) when find_var id ist -> ArgVar (loc,id)
-  | r ->
-      let loc,_ as lqid = qualid_of_reference r in
-      try ArgArg (loc,locate_global_with_alias lqid)
-      with Not_found ->
-	error_global_not_found_loc lqid
-
-let intern_ltac_variable ist = function
-  | Ident (loc,id) ->
-      if find_ltacvar id ist then
-	(* A local variable of any type *)
-	ArgVar (loc,id)
-      else
-      (* A recursive variable *)
-      ArgArg (loc,find_recvar id ist)
-  | _ ->
-      raise Not_found
-
-let intern_constr_reference strict ist = function
-  | Ident (_,id) as r when not strict & find_hyp id ist ->
-      GVar (dloc,id), Some (CRef r)
-  | Ident (_,id) as r when find_ctxvar id ist ->
-      GVar (dloc,id), if strict then None else Some (CRef r)
-  | r ->
-      let loc,_ as lqid = qualid_of_reference r in
-      GRef (loc,locate_global_with_alias lqid), if strict then None else Some (CRef r)
-
-let intern_move_location ist = function
-  | MoveAfter id -> MoveAfter (intern_hyp_or_metaid ist id)
-  | MoveBefore id -> MoveBefore (intern_hyp_or_metaid ist id)
-  | MoveToEnd toleft as x -> x
-
-(* Internalize an isolated reference in position of tactic *)
-
-let intern_isolated_global_tactic_reference r =
-  let (loc,qid) = qualid_of_reference r in
-  try TacCall (loc,ArgArg (loc,locate_tactic qid),[])
-  with Not_found ->
-  match r with
-  | Ident (_,id) -> Tacexp (lookup_atomic id)
-  | _ -> raise Not_found
+    str "a value of type" ++ spc () ++ pr_argument_type (genarg_tag v)
+
+let pr_closure env ist body =
+  let pp_body = Pptactic.pr_glob_tactic env body in
+  let pr_sep () = fnl () in
+  let pr_iarg (id, arg) =
+    let arg = pr_argument_type (genarg_tag arg) in
+    hov 0 (pr_id id ++ spc () ++ str ":" ++ spc () ++ arg)
+  in
+  let pp_iargs = v 0 (prlist_with_sep pr_sep pr_iarg (Id.Map.bindings ist)) in
+  pp_body ++ fnl() ++ str "in environment " ++ fnl() ++ pp_iargs
+
+let pr_inspect env expr result =
+  let pp_expr = Pptactic.pr_glob_tactic env expr in
+  let pp_result =
+    if has_type result (topwit wit_tacvalue) then
+    match to_tacvalue result with
+    | VFun (_,_, ist, ul, b) ->
+      let body = if List.is_empty ul then b else (TacFun (ul, b)) in
+      str "a closure with body " ++ fnl() ++ pr_closure env ist body
+    | VRec (ist, body) ->
+      str "a recursive closure" ++ fnl () ++ pr_closure env !ist body
+    else
+      let pp_type = pr_argument_type (genarg_tag result) in
+      str "an object of type" ++ spc () ++ pp_type
+  in
+  pp_expr ++ fnl() ++ str "this is " ++ pp_result
 
-let intern_isolated_tactic_reference strict ist r =
-  (* An ltac reference *)
-  try Reference (intern_ltac_variable ist r)
-  with Not_found ->
-  (* A global tactic *)
-  try intern_isolated_global_tactic_reference r
-  with Not_found ->
-  (* Tolerance for compatibility, allow not to use "constr:" *)
-  try ConstrMayEval (ConstrTerm (intern_constr_reference strict ist r))
-  with Not_found ->
-  (* Reference not found *)
-  error_global_not_found_loc (qualid_of_reference r)
+(* Transforms an id into a constr if possible, or fails with Not_found *)
+let constr_of_id env id =
+  Term.mkVar (let _ = Environ.lookup_named id env in id)
 
-(* Internalize an applied tactic reference *)
+(* To embed tactics *)
 
-let intern_applied_global_tactic_reference r =
-  let (loc,qid) = qualid_of_reference r in
-  ArgArg (loc,locate_tactic qid)
+let ((tactic_in : (interp_sign -> glob_tactic_expr) -> Dyn.t),
+     (tactic_out : Dyn.t -> (interp_sign -> glob_tactic_expr))) =
+  Dyn.create "tactic"
 
-let intern_applied_tactic_reference ist r =
-  (* An ltac reference *)
-  try intern_ltac_variable ist r
-  with Not_found ->
-  (* A global tactic *)
-  try intern_applied_global_tactic_reference r
-  with Not_found ->
-  (* Reference not found *)
-  error_global_not_found_loc (qualid_of_reference r)
+let ((value_in : value -> Dyn.t),
+     (value_out : Dyn.t -> value)) = Dyn.create "value"
 
-(* Intern a reference parsed in a non-tactic entry *)
+let valueIn t = TacDynamic (Loc.ghost, value_in t)
+
+(** Generic arguments : table of interpretation functions *)
+
+let push_trace call ist = match TacStore.get ist.extra f_trace with
+| None -> [call]
+| Some trace -> call :: trace
+
+let propagate_trace ist loc id v =
+  let v = Value.normalize v in
+  if has_type v (topwit wit_tacvalue) then
+    let tacv = to_tacvalue v in
+    match tacv with
+    | VFun (appl,_,lfun,it,b) ->
+        let t = if List.is_empty it then b else TacFun (it,b) in
+        let ans = VFun (appl,push_trace(loc,LtacVarCall (id,t)) ist,lfun,it,b) in
+        of_tacvalue ans
+    | _ ->  v
+  else v
+
+let append_trace trace v =
+  let v = Value.normalize v in
+  if has_type v (topwit wit_tacvalue) then
+    match to_tacvalue v with
+    | VFun (appl,trace',lfun,it,b) -> of_tacvalue (VFun (appl,trace'@trace,lfun,it,b))
+    | _ -> v
+  else v
 
-let intern_non_tactic_reference strict ist r =
-  (* An ltac reference *)
-  try Reference (intern_ltac_variable ist r)
-  with Not_found ->
-  (* A constr reference *)
-  try ConstrMayEval (ConstrTerm (intern_constr_reference strict ist r))
-  with Not_found ->
-  (* Tolerance for compatibility, allow not to use "ltac:" *)
-  try intern_isolated_global_tactic_reference r
-  with Not_found ->
-  (* By convention, use IntroIdentifier for unbound ident, when not in a def *)
-  match r with
-  | Ident (loc,id) when not strict -> IntroPattern (loc,IntroIdentifier id)
-  | _ ->
-  (* Reference not found *)
-  error_global_not_found_loc (qualid_of_reference r)
-
-let intern_message_token ist = function
-  | (MsgString _ | MsgInt _ as x) -> x
-  | MsgIdent id -> MsgIdent (intern_hyp_or_metaid ist id)
-
-let intern_message ist = List.map (intern_message_token ist)
-
-let rec intern_intro_pattern lf ist = function
-  | loc, IntroOrAndPattern l ->
-      loc, IntroOrAndPattern (intern_or_and_intro_pattern lf ist l)
-  | loc, IntroIdentifier id ->
-      loc, IntroIdentifier (intern_ident lf ist id)
-  | loc, IntroFresh id ->
-      loc, IntroFresh (intern_ident lf ist id)
-  | loc, (IntroWildcard | IntroAnonymous | IntroRewrite _ | IntroForthcoming _)
-      as x -> x
-
-and intern_or_and_intro_pattern lf ist =
-  List.map (List.map (intern_intro_pattern lf ist))
-
-let intern_quantified_hypothesis ist = function
-  | AnonHyp n -> AnonHyp n
-  | NamedHyp id ->
-      (* Uncomment to disallow "intros until n" in ltac when n is not bound *)
-      NamedHyp ((*snd (intern_hyp ist (dloc,*)id(* ))*))
-
-let intern_binding_name ist x =
-  (* We use identifier both for variables and binding names *)
-  (* Todo: consider the body of the lemma to which the binding refer
-     and if a term w/o ltac vars, check the name is indeed quantified *)
-  x
-
-let intern_constr_gen allow_patvar isarity {ltacvars=lfun; gsigma=sigma; genv=env} c =
-  let warn = if !strict_check then fun x -> x else Constrintern.for_grammar in
-  let c' =
-    warn (Constrintern.intern_gen isarity ~allow_patvar ~ltacvars:(fst lfun,[]) sigma env) c
+(* Dynamically check that an argument is a tactic *)
+let coerce_to_tactic loc id v =
+  let v = Value.normalize v in
+  let fail () = user_err_loc
+    (loc, "", str "Variable " ++ pr_id id ++ str " should be bound to a tactic.")
   in
-  (c',if !strict_check then None else Some c)
-
-let intern_constr = intern_constr_gen false false
-let intern_type = intern_constr_gen false true
-
-(* Globalize bindings *)
-let intern_binding ist (loc,b,c) =
-  (loc,intern_binding_name ist b,intern_constr ist c)
-
-let intern_bindings ist = function
-  | NoBindings -> NoBindings
-  | ImplicitBindings l -> ImplicitBindings (List.map (intern_constr ist) l)
-  | ExplicitBindings l -> ExplicitBindings (List.map (intern_binding ist) l)
-
-let intern_constr_with_bindings ist (c,bl) =
-  (intern_constr ist c, intern_bindings ist bl)
-
-  (* TODO: catch ltac vars *)
-let intern_induction_arg ist = function
-  | ElimOnConstr c -> ElimOnConstr (intern_constr_with_bindings ist c)
-  | ElimOnAnonHyp n as x -> x
-  | ElimOnIdent (loc,id) ->
-      if !strict_check then
-	(* If in a defined tactic, no intros-until *)
-	match intern_constr ist (CRef (Ident (dloc,id))) with
-	| GVar (loc,id),_ -> ElimOnIdent (loc,id)
-	| c -> ElimOnConstr (c,NoBindings)
-      else
-	ElimOnIdent (loc,id)
+  let v = Value.normalize v in
+  if has_type v (topwit wit_tacvalue) then
+    let tacv = to_tacvalue v in
+    match tacv with
+    | VFun _ -> v
+    | _ -> fail ()
+  else fail ()
 
-let short_name = function
-  | AN (Ident (loc,id)) when not !strict_check -> Some (loc,id)
-  | _ -> None
+let value_of_ident id =
+  in_gen (topwit wit_intro_pattern)
+    (Loc.ghost, IntroNaming (IntroIdentifier id))
 
-let intern_evaluable_global_reference ist r =
-  let lqid = qualid_of_reference r in
-  try evaluable_of_global_reference ist.genv (locate_global_with_alias lqid)
-  with Not_found ->
-  match r with
-  | Ident (loc,id) when not !strict_check -> EvalVarRef id
-  | _ -> error_global_not_found_loc lqid
-
-let intern_evaluable_reference_or_by_notation ist = function
-  | AN r -> intern_evaluable_global_reference ist r
-  | ByNotation (loc,ntn,sc) ->
-      evaluable_of_global_reference ist.genv
-      (Notation.interp_notation_as_global_reference loc
-        (function ConstRef _ | VarRef _ -> true | _ -> false) ntn sc)
-
-(* Globalize a reduction expression *)
-let intern_evaluable ist = function
-  | AN (Ident (loc,id)) when find_ltacvar id ist -> ArgVar (loc,id)
-  | AN (Ident (loc,id)) when not !strict_check & find_hyp id ist ->
-      ArgArg (EvalVarRef id, Some (loc,id))
-  | AN (Ident (loc,id)) when find_ctxvar id ist ->
-      ArgArg (EvalVarRef id, if !strict_check then None else Some (loc,id))
-  | r ->
-      let e = intern_evaluable_reference_or_by_notation ist r in
-      let na = short_name r in
-      ArgArg (e,na)
-
-let intern_unfold ist (l,qid) = (l,intern_evaluable ist qid)
-
-let intern_flag ist red =
-  { red with rConst = List.map (intern_evaluable ist) red.rConst }
-
-let intern_constr_with_occurrences ist (l,c) = (l,intern_constr ist c)
-
-let intern_constr_pattern ist ltacvars pc =
-  let metas,pat =
-    Constrintern.intern_constr_pattern ist.gsigma ist.genv ~ltacvars pc in
-  let c = intern_constr_gen true false ist pc in
-  metas,(c,pat)
-
-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 glob_constr only *)
-  (intern_constr_gen true false ist p,dummy_pat)
-
-let intern_typed_pattern_with_occurrences ist (l,p) =
-  (l,intern_typed_pattern ist p)
-
-(* This seems fairly hacky, but it's the first way I've found to get proper
-   globalization of [unfold].  --adamc *)
-let dump_glob_red_expr = function
-  | Unfold occs -> List.iter (fun (_, r) ->
-    try
-      Dumpglob.add_glob (loc_of_or_by_notation Libnames.loc_of_reference r)
-	(Smartlocate.smart_global r)
-    with e when Errors.noncritical e -> ()) occs
-  | Cbv grf | Lazy grf ->
-    List.iter (fun r ->
-      try
-        Dumpglob.add_glob (loc_of_or_by_notation Libnames.loc_of_reference r)
-	  (Smartlocate.smart_global r)
-      with e when Errors.noncritical e -> ()) grf.rConst
-  | _ -> ()
-
-let intern_red_expr ist = function
-  | Unfold l -> Unfold (List.map (intern_unfold ist) l)
-  | Fold l -> Fold (List.map (intern_constr ist) l)
-  | Cbv f -> Cbv (intern_flag ist f)
-  | Lazy f -> Lazy (intern_flag ist f)
-  | Pattern l -> Pattern (List.map (intern_constr_with_occurrences ist) l)
-  | Simpl o -> Simpl (Option.map (intern_typed_pattern_with_occurrences ist) o)
-  | (Red _ | Hnf | ExtraRedExpr _ | CbvVm as r ) -> r
-
-let intern_in_hyp_as ist lf (id,ipat) =
-  (intern_hyp_or_metaid ist id, Option.map (intern_intro_pattern lf ist) ipat)
-
-let intern_hyp_list ist = List.map (intern_hyp_or_metaid ist)
-
-let intern_inversion_strength lf ist = function
-  | NonDepInversion (k,idl,ids) ->
-      NonDepInversion (k,intern_hyp_list ist idl,
-      Option.map (intern_intro_pattern lf ist) ids)
-  | DepInversion (k,copt,ids) ->
-      DepInversion (k, Option.map (intern_constr ist) copt,
-      Option.map (intern_intro_pattern lf ist) ids)
-  | InversionUsing (c,idl) ->
-      InversionUsing (intern_constr ist c, intern_hyp_list ist idl)
-
-(* Interprets an hypothesis name *)
-let intern_hyp_location ist (((b,occs),id),hl) =
-  (((b,List.map (intern_or_var ist) occs),intern_hyp_or_metaid ist id), hl)
-
-(* Reads a pattern *)
-let intern_pattern ist ?(as_type=false) lfun = function
-  | Subterm (b,ido,pc) ->
-      let ltacvars = (lfun,[]) in
-      let (metas,pc) = intern_constr_pattern ist ltacvars pc in
-      ido, metas, Subterm (b,ido,pc)
-  | Term pc ->
-      let ltacvars = (lfun,[]) in
-      let (metas,pc) = intern_constr_pattern ist ltacvars pc in
-      None, metas, Term pc
-
-let intern_constr_may_eval ist = function
-  | ConstrEval (r,c) -> ConstrEval (intern_red_expr ist r,intern_constr ist c)
-  | ConstrContext (locid,c) ->
-      ConstrContext (intern_hyp ist locid,intern_constr ist c)
-  | ConstrTypeOf c -> ConstrTypeOf (intern_constr ist c)
-  | ConstrTerm c -> ConstrTerm (intern_constr ist c)
-
-(* External tactics *)
-let print_xml_term = ref (fun _ -> failwith "print_xml_term unset")
-let declare_xml_printer f = print_xml_term := f
-
-let internalise_tacarg ch = G_xml.parse_tactic_arg ch
-
-let extern_tacarg ch env sigma = function
-  | VConstr ([],c) -> !print_xml_term ch env sigma c
-  | VRTactic _ | VFun _ | VVoid | VInteger _ | VConstr_context _
-  | VIntroPattern _  | VRec _ | VList _ | VConstr _ ->
-      error "Only externing of closed terms is implemented."
-
-let extern_request ch req gl la =
-  output_string ch "<REQUEST req=\""; output_string ch req;
-  output_string ch "\">\n";
-  List.iter (pf_apply (extern_tacarg ch) gl) la;
-  output_string ch "</REQUEST>\n"
-
-let value_of_ident id = VIntroPattern (IntroIdentifier id)
+let (+++) lfun1 lfun2 = Id.Map.fold Id.Map.add lfun1 lfun2
 
 let extend_values_with_bindings (ln,lm) lfun =
-  let lnames = List.map (fun (id,id') ->(id,value_of_ident id')) ln in
-  let lmatch = List.map (fun (id,(ids,c)) -> (id,VConstr (ids,c))) lm in
+  let of_cub c = match c with
+  | [], c -> Value.of_constr c
+  | _ -> in_gen (topwit wit_constr_under_binders) c
+  in
   (* For compatibility, bound variables are visible only if no other
      binding of the same name exists *)
-  lmatch@lfun@lnames
-
-(* Reads the hypotheses of a "match goal" rule *)
-let rec intern_match_goal_hyps ist lfun = function
-  | (Hyp ((_,na) as locna,mp))::tl ->
-      let ido, metas1, pat = intern_pattern ist ~as_type:true lfun mp in
-      let lfun, metas2, hyps = intern_match_goal_hyps ist lfun tl in
-      let lfun' = name_cons na (Option.List.cons ido lfun) in
-      lfun', metas1@metas2, Hyp (locna,pat)::hyps
-  | (Def ((_,na) as locna,mv,mp))::tl ->
-      let ido, metas1, patv = intern_pattern ist ~as_type:false lfun mv in
-      let ido', metas2, patt = intern_pattern ist ~as_type:true lfun mp in
-      let lfun, metas3, hyps = intern_match_goal_hyps ist lfun tl in
-      let lfun' = name_cons na (Option.List.cons ido' (Option.List.cons ido lfun)) in
-      lfun', metas1@metas2@metas3, Def (locna,patv,patt)::hyps
-  | [] -> lfun, [], []
-
-(* Utilities *)
-let extract_let_names lrc =
-  List.fold_right
-    (fun ((loc,name),_) l ->
-      if List.mem name l then
-	user_err_loc
-	  (loc, "glob_tactic", str "This variable is bound several times.");
-      name::l)
-    lrc []
-
-let clause_app f = function
-    { onhyps=None; concl_occs=nl } ->
-      { onhyps=None; concl_occs=nl }
-  | { onhyps=Some l; concl_occs=nl } ->
-      { onhyps=Some(List.map f l); concl_occs=nl}
-
-(* Globalizes tactics : raw_tactic_expr -> glob_tactic_expr *)
-let rec intern_atomic lf ist x =
-  match (x:raw_atomic_tactic_expr) with
-  (* Basic tactics *)
-  | TacIntroPattern l ->
-      TacIntroPattern (List.map (intern_intro_pattern lf ist) l)
-  | TacIntrosUntil hyp -> TacIntrosUntil (intern_quantified_hypothesis ist hyp)
-  | TacIntroMove (ido,hto) ->
-      TacIntroMove (Option.map (intern_ident lf ist) ido,
-                    intern_move_location ist hto)
-  | TacAssumption -> TacAssumption
-  | TacExact c -> TacExact (intern_constr ist c)
-  | TacExactNoCheck c -> TacExactNoCheck (intern_constr ist c)
-  | TacVmCastNoCheck c -> TacVmCastNoCheck (intern_constr ist c)
-  | TacApply (a,ev,cb,inhyp) ->
-      TacApply (a,ev,List.map (intern_constr_with_bindings ist) cb,
-                Option.map (intern_in_hyp_as ist lf) inhyp)
-  | TacElim (ev,cb,cbo) ->
-      TacElim (ev,intern_constr_with_bindings ist cb,
-               Option.map (intern_constr_with_bindings ist) cbo)
-  | TacElimType c -> TacElimType (intern_type ist c)
-  | TacCase (ev,cb) -> TacCase (ev,intern_constr_with_bindings ist cb)
-  | TacCaseType c -> TacCaseType (intern_type ist c)
-  | TacFix (idopt,n) -> TacFix (Option.map (intern_ident lf ist) idopt,n)
-  | TacMutualFix (b,id,n,l) ->
-      let f (id,n,c) = (intern_ident lf ist id,n,intern_type ist c) in
-      TacMutualFix (b,intern_ident lf ist id, n, List.map f l)
-  | TacCofix idopt -> TacCofix (Option.map (intern_ident lf ist) idopt)
-  | TacMutualCofix (b,id,l) ->
-      let f (id,c) = (intern_ident lf ist id,intern_type ist c) in
-      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_pure_tactic ist) otac,
-                 Option.map (intern_intro_pattern lf ist) ipat,
-                 intern_constr_gen false (otac<>None) ist c)
-  | TacGeneralize cl ->
-      TacGeneralize (List.map (fun (c,na) ->
-	               intern_constr_with_occurrences ist c,
-                       intern_name lf ist na) cl)
-  | TacGeneralizeDep c -> TacGeneralizeDep (intern_constr ist c)
-  | TacLetTac (na,c,cls,b,eqpat) ->
-      let na = intern_name lf ist na in
-      TacLetTac (na,intern_constr ist c,
-                 (clause_app (intern_hyp_location ist) cls),b,
-		 (Option.map (intern_intro_pattern lf ist) eqpat))
-
-  (* Automation tactics *)
-  | TacTrivial (d,lems,l) -> TacTrivial (d,List.map (intern_constr ist) lems,l)
-  | TacAuto (d,n,lems,l) ->
-      TacAuto (d,Option.map (intern_or_var ist) n,
-        List.map (intern_constr ist) lems,l)
-
-  (* Derived basic tactics *)
-  | TacSimpleInductionDestruct (isrec,h) ->
-      TacSimpleInductionDestruct (isrec,intern_quantified_hypothesis ist h)
-  | TacInductionDestruct (ev,isrec,(l,el,cls)) ->
-      TacInductionDestruct (ev,isrec,(List.map (fun (c,(ipato,ipats)) ->
-	      (intern_induction_arg ist c,
-               (Option.map (intern_intro_pattern lf ist) ipato,
-	        Option.map (intern_intro_pattern lf ist) ipats))) l,
-               Option.map (intern_constr_with_bindings ist) el,
-               Option.map (clause_app (intern_hyp_location ist)) cls))
-  | TacDoubleInduction (h1,h2) ->
-      let h1 = intern_quantified_hypothesis ist h1 in
-      let h2 = intern_quantified_hypothesis ist h2 in
-      TacDoubleInduction (h1,h2)
-  | TacDecomposeAnd c -> TacDecomposeAnd (intern_constr ist c)
-  | TacDecomposeOr c -> TacDecomposeOr (intern_constr ist c)
-  | TacDecompose (l,c) -> let l = List.map (intern_inductive ist) l in
-      TacDecompose (l,intern_constr ist c)
-  | TacSpecialize (n,l) -> TacSpecialize (n,intern_constr_with_bindings ist l)
-  | TacLApply c -> TacLApply (intern_constr ist c)
-
-  (* Context management *)
-  | TacClear (b,l) -> TacClear (b,List.map (intern_hyp_or_metaid ist) l)
-  | TacClearBody l -> TacClearBody (List.map (intern_hyp_or_metaid ist) l)
-  | TacMove (dep,id1,id2) ->
-    TacMove (dep,intern_hyp_or_metaid ist id1,intern_move_location ist id2)
-  | TacRename l ->
-      TacRename (List.map (fun (id1,id2) ->
-			     intern_hyp_or_metaid ist id1,
-			     intern_hyp_or_metaid ist id2) l)
-  | TacRevert l -> TacRevert (List.map (intern_hyp_or_metaid ist) l)
-
-  (* Constructors *)
-  | 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_pure_tactic ist) t)
-  | TacConstructor (ev,n,bl) -> TacConstructor (ev,intern_or_var ist n,intern_bindings ist bl)
-
-  (* Conversion *)
-  | TacReduce (r,cl) ->
-      dump_glob_red_expr r;
-      TacReduce (intern_red_expr ist r, clause_app (intern_hyp_location ist) cl)
-  | TacChange (None,c,cl) ->
-      TacChange (None,
-        (if (cl.onhyps = None or cl.onhyps = Some []) &
-	    (cl.concl_occs = all_occurrences_expr or
-	     cl.concl_occs = no_occurrences_expr)
-         then intern_type ist c else intern_constr ist c),
-	clause_app (intern_hyp_location ist) cl)
-  | TacChange (Some p,c,cl) ->
-      TacChange (Some (intern_typed_pattern ist p),intern_constr ist c,
-	clause_app (intern_hyp_location ist) cl)
-
-  (* Equivalence relations *)
-  | TacReflexivity -> TacReflexivity
-  | TacSymmetry idopt ->
-      TacSymmetry (clause_app (intern_hyp_location ist) idopt)
-  | TacTransitivity c -> TacTransitivity (Option.map (intern_constr ist) c)
-
-  (* Equality and inversion *)
-  | TacRewrite (ev,l,cl,by) ->
-      TacRewrite
-	(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_pure_tactic ist) by)
-  | TacInversion (inv,hyp) ->
-      TacInversion (intern_inversion_strength lf ist inv,
-        intern_quantified_hypothesis ist hyp)
-
-  (* For extensions *)
-  | TacExtend (loc,opn,l) ->
-      let _ = lookup_tactic opn in
-      TacExtend (adjust_loc loc,opn,List.map (intern_genarg ist) l)
-  | TacAlias (loc,s,l,(dir,body)) ->
-      let l = List.map (fun (id,a) -> (id,intern_genarg ist a)) l in
-      TacAlias (loc,s,l,(dir,body))
-
-and intern_tactic onlytac ist tac = snd (intern_tactic_seq onlytac ist tac)
-
-and intern_tactic_seq onlytac ist = function
-  | TacAtom (loc,t) ->
-      let lf = ref ist.ltacvars in
-      let t = intern_atomic lf ist t in
-      !lf, TacAtom (adjust_loc loc, t)
-  | TacFun tacfun -> ist.ltacvars, TacFun (intern_tactic_fun ist tacfun)
-  | TacLetIn (isrec,l,u) ->
-      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 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 onlytac ist lmr)
-  | TacMatch (lz,c,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_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 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 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_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 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_pure_tactic ist') tl)
-  | TacDo (n,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_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_or_tacarg { ist with ltacvars = (lfun',l2) } body)
-
-and intern_tacarg strict onlytac ist = function
-  | TacVoid -> TacVoid
-  | Reference r -> intern_non_tactic_reference strict ist r
-  | IntroPattern ipat ->
-      let lf = ref([],[]) in (*How to know what names the intropattern binds?*)
-      IntroPattern (intern_intro_pattern lf ist ipat)
-  | Integer n -> Integer n
-  | ConstrMayEval c -> ConstrMayEval (intern_constr_may_eval ist c)
-  | MetaIdArg (loc,istac,s) ->
-      (* $id can occur in Grammar tactic... *)
-      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 (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 false ist) l)
-  | TacExternal (loc,com,req,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 onlytac ist t)
-  | TacDynamic(loc,t) as x ->
-      (match Dyn.tag t with
-	| "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 onlytac ist = function
-  | (All tc)::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 onlytac ist' tc) :: (intern_match_rule onlytac ist tl)
-  | [] -> []
-
-and intern_genarg ist x =
-  match genarg_tag x with
-  | BoolArgType -> in_gen globwit_bool (out_gen rawwit_bool x)
-  | IntArgType -> in_gen globwit_int (out_gen rawwit_int x)
-  | IntOrVarArgType ->
-      in_gen globwit_int_or_var
-        (intern_or_var ist (out_gen rawwit_int_or_var x))
-  | StringArgType ->
-      in_gen globwit_string (out_gen rawwit_string x)
-  | PreIdentArgType ->
-      in_gen globwit_pre_ident (out_gen rawwit_pre_ident x)
-  | IntroPatternArgType ->
-      let lf = ref ([],[]) in
-      (* how to know which names are bound by the intropattern *)
-      in_gen globwit_intro_pattern
-        (intern_intro_pattern lf ist (out_gen rawwit_intro_pattern x))
-  | IdentArgType b ->
-      let lf = ref ([],[]) in
-      in_gen (globwit_ident_gen b)
-	(intern_ident lf ist (out_gen (rawwit_ident_gen b) x))
-  | VarArgType ->
-      in_gen globwit_var (intern_hyp ist (out_gen rawwit_var x))
-  | RefArgType ->
-      in_gen globwit_ref (intern_global_reference ist (out_gen rawwit_ref x))
-  | SortArgType ->
-      in_gen globwit_sort (out_gen rawwit_sort x)
-  | ConstrArgType ->
-      in_gen globwit_constr (intern_constr ist (out_gen rawwit_constr x))
-  | ConstrMayEvalArgType ->
-      in_gen globwit_constr_may_eval
-        (intern_constr_may_eval ist (out_gen rawwit_constr_may_eval x))
-  | QuantHypArgType ->
-      in_gen globwit_quant_hyp
-        (intern_quantified_hypothesis ist (out_gen rawwit_quant_hyp x))
-  | RedExprArgType ->
-      in_gen globwit_red_expr (intern_red_expr ist (out_gen rawwit_red_expr x))
-  | OpenConstrArgType (b1,b2) ->
-      in_gen (globwit_open_constr_gen (b1,b2))
-        ((),intern_constr ist (snd (out_gen (rawwit_open_constr_gen (b1,b2)) x)))
-  | ConstrWithBindingsArgType ->
-      in_gen globwit_constr_with_bindings
-        (intern_constr_with_bindings ist (out_gen rawwit_constr_with_bindings x))
-  | BindingsArgType ->
-      in_gen globwit_bindings
-        (intern_bindings ist (out_gen rawwit_bindings x))
-  | List0ArgType _ -> app_list0 (intern_genarg ist) x
-  | List1ArgType _ -> app_list1 (intern_genarg ist) x
-  | OptArgType _ -> app_opt (intern_genarg ist) x
-  | PairArgType _ -> app_pair (intern_genarg ist) (intern_genarg ist) x
-  | ExtraArgType s ->
-      match tactic_genarg_level s with
-      | Some n ->
-          (* Special treatment of tactic arguments *)
-          in_gen (globwit_tactic n) (intern_tactic_or_tacarg ist
-	    (out_gen (rawwit_tactic n) x))
-      | None ->
-          lookup_genarg_glob s ist x
-
-(************* End globalization ************)
+  let accu = Id.Map.map value_of_ident ln in
+  let accu = lfun +++ accu in
+  Id.Map.fold (fun id c accu -> Id.Map.add id (of_cub c) accu) lm accu
 
 (***************************************************************************)
 (* Evaluation/interpretation *)
 
 let is_variable env id =
-  List.mem id (ids_of_named_context (Environ.named_context env))
+  Id.List.mem id (ids_of_named_context (Environ.named_context env))
 
 (* Debug reference *)
 let debug = ref DebugOff
@@ -1006,11 +292,10 @@ let set_debug pos = debug := pos
 (* Gives the state of debug *)
 let get_debug () = !debug
 
-let debugging_step ist pp =
-  match ist.debug with
+let debugging_step ist pp = match curr_debug ist with
   | DebugOn lev ->
       safe_msgnl (str "Level " ++ int lev ++ str": " ++ pp () ++ fnl())
-  | _ -> ()
+  | _ -> Proofview.NonLogical.return ()
 
 let debugging_exception_step ist signal_anomaly e pp =
   let explain_exc =
@@ -1024,63 +309,40 @@ let error_ltac_variable loc id env v s =
    strbrk " is bound to" ++ spc () ++ pr_value env v ++ spc () ++
    strbrk "which cannot be coerced to " ++ str s ++ str".")
 
-exception CannotCoerceTo of string
-
 (* Raise Not_found if not in interpretation sign *)
 let try_interp_ltac_var coerce ist env (loc,id) =
-  let v = List.assoc id ist.lfun in
+  let v = Id.Map.find id ist.lfun in
   try coerce v with CannotCoerceTo s -> error_ltac_variable loc id env v s
 
 let interp_ltac_var coerce ist env locid =
   try try_interp_ltac_var coerce ist env locid
-  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
-  | VIntroPattern (IntroIdentifier id) -> id
-  | VConstr ([],c) when isVar c & not (fresh & is_variable env (destVar c)) ->
-      (* We need it fresh for intro e.g. in "Tac H = clear H; intro H" *)
-      destVar c
-  | v -> raise (CannotCoerceTo "a fresh identifier")
-
-let interp_ident_gen fresh ist env id =
-  try try_interp_ltac_var (coerce_to_ident fresh env) ist (Some env) (dloc,id)
+  with Not_found -> anomaly (str "Detected '" ++ Id.print (snd locid) ++ str "' as ltac var at interning time")
+
+let interp_ident_gen fresh ist env sigma id =
+  try try_interp_ltac_var (coerce_to_ident fresh env) ist (Some (env,sigma)) (dloc,id)
   with Not_found -> id
 
 let interp_ident = interp_ident_gen false
 let interp_fresh_ident = interp_ident_gen true
-let pf_interp_ident id gl = interp_ident_gen false id (pf_env gl)
-let pf_interp_fresh_ident id gl = interp_ident_gen true id (pf_env gl)
+let pf_interp_ident id gl = interp_ident_gen false id (pf_env gl) (project gl)
 
 (* Interprets an optional identifier which must be fresh *)
-let interp_fresh_name ist env = function
+let interp_fresh_name ist env sigma = function
   | Anonymous -> Anonymous
-  | Name id -> Name (interp_fresh_ident ist env id)
-
-let coerce_to_intro_pattern env = function
-  | VIntroPattern ipat -> ipat
-  | VConstr ([],c) when isVar c ->
-      (* This happens e.g. in definitions like "Tac H = clear H; intro H" *)
-      (* but also in "destruct H as (H,H')" *)
-      IntroIdentifier (destVar c)
-  | v -> raise (CannotCoerceTo "an introduction pattern")
-
-let interp_intro_pattern_var loc ist env id =
-  try try_interp_ltac_var (coerce_to_intro_pattern env) ist (Some env) (loc,id)
-  with Not_found -> IntroIdentifier id
+  | Name id -> Name (interp_fresh_ident ist env sigma id)
 
-let coerce_to_hint_base = function
-  | VIntroPattern (IntroIdentifier id) -> string_of_id id
-  | _ -> raise (CannotCoerceTo "a hint base name")
+let interp_intro_pattern_var loc ist env sigma id =
+  try try_interp_ltac_var (coerce_to_intro_pattern env) ist (Some (env,sigma)) (loc,id)
+  with Not_found -> IntroNaming (IntroIdentifier id)
+
+let interp_intro_pattern_naming_var loc ist env sigma id =
+  try try_interp_ltac_var (coerce_to_intro_pattern_naming env) ist (Some (env,sigma)) (loc,id)
+  with Not_found -> IntroIdentifier id
 
 let interp_hint_base ist s =
-  try try_interp_ltac_var coerce_to_hint_base ist None (dloc,id_of_string s)
+  try try_interp_ltac_var coerce_to_hint_base ist None (dloc,Id.of_string s)
   with Not_found -> s
 
-let coerce_to_int = function
-  | VInteger n -> n
-  | v -> raise (CannotCoerceTo "an integer")
-
 let interp_int ist locid =
   try try_interp_ltac_var coerce_to_int ist None locid
   with Not_found ->
@@ -1091,252 +353,313 @@ let interp_int_or_var ist = function
   | ArgVar locid -> interp_int ist locid
   | ArgArg n -> n
 
-let int_or_var_list_of_VList = function
-  | VList l -> List.map (fun n -> ArgArg (coerce_to_int n)) l
-  | _ -> raise Not_found
-
 let interp_int_or_var_as_list ist = function
   | ArgVar (_,id as locid) ->
-      (try int_or_var_list_of_VList (List.assoc id ist.lfun)
+      (try coerce_to_int_or_var_list (Id.Map.find id ist.lfun)
        with Not_found | CannotCoerceTo _ -> [ArgArg (interp_int ist locid)])
   | ArgArg n as x -> [x]
 
 let interp_int_or_var_list ist l =
   List.flatten (List.map (interp_int_or_var_as_list ist) l)
 
-let constr_of_value env = function
-  | VConstr csr -> csr
-  | VIntroPattern (IntroIdentifier id) -> ([],constr_of_id env id)
-  | _ -> raise Not_found
-
-let closed_constr_of_value env v =
-  let ids,c = constr_of_value env v in
-  if ids <> [] then raise Not_found;
-  c
-
-let coerce_to_hyp env = function
-  | VConstr ([],c) when isVar c -> destVar c
-  | VIntroPattern (IntroIdentifier id) when is_variable env id -> id
-  | _ -> raise (CannotCoerceTo "a variable")
-
 (* Interprets a bound variable (especially an existing hypothesis) *)
-let interp_hyp ist gl (loc,id as locid) =
-  let env = pf_env gl in
+let interp_hyp ist env sigma (loc,id as locid) =
   (* Look first in lfun for a value coercible to a variable *)
-  try try_interp_ltac_var (coerce_to_hyp env) ist (Some env) locid
+  try try_interp_ltac_var (coerce_to_hyp env) ist (Some (env,sigma)) locid
   with Not_found ->
   (* Then look if bound in the proof context at calling time *)
   if is_variable env id then id
-  else user_err_loc (loc,"eval_variable",
-    str "No such hypothesis: " ++ pr_id id ++ str ".")
-
-let hyp_list_of_VList env = function
-  | VList l -> List.map (coerce_to_hyp env) l
-  | _ -> raise Not_found
+  else Loc.raise loc (Logic.RefinerError (Logic.NoSuchHyp id))
 
-let interp_hyp_list_as_list ist gl (loc,id as x) =
-  try hyp_list_of_VList (pf_env gl) (List.assoc id ist.lfun)
-  with Not_found | CannotCoerceTo _ -> [interp_hyp ist gl x]
+let interp_hyp_list_as_list ist env sigma (loc,id as x) =
+  try coerce_to_hyp_list env (Id.Map.find id ist.lfun)
+  with Not_found | CannotCoerceTo _ -> [interp_hyp ist env sigma x]
 
-let interp_hyp_list ist gl l =
-  List.flatten (List.map (interp_hyp_list_as_list ist gl) l)
+let interp_hyp_list ist env sigma l =
+  List.flatten (List.map (interp_hyp_list_as_list ist env sigma) l)
 
-let interp_move_location ist gl = function
-  | MoveAfter id -> MoveAfter (interp_hyp ist gl id)
-  | MoveBefore id -> MoveBefore (interp_hyp ist gl id)
-  | MoveToEnd toleft as x -> x
+let interp_move_location ist env sigma = function
+  | MoveAfter id -> MoveAfter (interp_hyp ist env sigma id)
+  | MoveBefore id -> MoveBefore (interp_hyp ist env sigma id)
+  | MoveFirst -> MoveFirst
+  | MoveLast -> MoveLast
 
-(* Interprets a qualified name *)
-let coerce_to_reference env v =
-  try match v with
-  | VConstr ([],c) -> global_of_constr c (* may raise Not_found *)
-  | _ -> raise Not_found
-  with Not_found -> raise (CannotCoerceTo "a reference")
-
-let interp_reference ist env = function
+let interp_reference ist env sigma = function
   | ArgArg (_,r) -> r
-  | ArgVar locid ->
-      interp_ltac_var (coerce_to_reference env) ist (Some env) locid
-
-let pf_interp_reference ist gl = interp_reference ist (pf_env gl)
-
-let coerce_to_inductive = function
-  | VConstr ([],c) when isInd c -> destInd c
-  | _ -> raise (CannotCoerceTo "an inductive type")
-
-let interp_inductive ist = function
-  | ArgArg r -> r
-  | ArgVar locid -> interp_ltac_var coerce_to_inductive ist None locid
-
-let coerce_to_evaluable_ref env v =
-  let ev = match v with
-    | VConstr ([],c) when isConst c -> EvalConstRef (destConst c)
-    | VConstr ([],c) when isVar c -> EvalVarRef (destVar c)
-    | VIntroPattern (IntroIdentifier id) when List.mem id (ids_of_context env)
-	-> EvalVarRef id
-    | _ -> raise (CannotCoerceTo "an evaluable reference")
-  in
-  if not (Tacred.is_evaluable env ev) then
-    raise (CannotCoerceTo "an evaluable reference")
-  else
-    ev
+  | ArgVar (loc, id) ->
+    try try_interp_ltac_var (coerce_to_reference env) ist (Some (env,sigma)) (loc, id)
+    with Not_found ->
+      try
+        let (v, _, _) = Environ.lookup_named id env in
+        VarRef v
+      with Not_found -> error_global_not_found_loc loc (qualid_of_ident id)
 
-let interp_evaluable ist env = function
+let try_interp_evaluable env (loc, id) =
+  let v = Environ.lookup_named id env in
+  match v with
+  | (_, Some _, _) -> EvalVarRef id
+  | _ -> error_not_evaluable (VarRef id)
+
+let interp_evaluable ist env sigma = function
   | ArgArg (r,Some (loc,id)) ->
-      (* Maybe [id] has been introduced by Intro-like tactics *)
-      (try match Environ.lookup_named id env with
-       | (_,Some _,_) -> EvalVarRef id
-       | _ -> error_not_evaluable (VarRef id)
-       with Not_found ->
-       match r with
-       | EvalConstRef _ -> r
-       | _ -> error_global_not_found_loc (loc,qualid_of_ident id))
+    (* Maybe [id] has been introduced by Intro-like tactics *)
+    begin
+      try try_interp_evaluable env (loc, id)
+      with Not_found ->
+        match r with
+        | EvalConstRef _ -> r
+        | _ -> error_global_not_found_loc loc (qualid_of_ident id)
+    end
   | ArgArg (r,None) -> r
-  | ArgVar locid ->
-      interp_ltac_var (coerce_to_evaluable_ref env) ist (Some env) locid
+  | ArgVar (loc, id) ->
+    try try_interp_ltac_var (coerce_to_evaluable_ref env) ist (Some (env,sigma)) (loc, id)
+    with Not_found ->
+      try try_interp_evaluable env (loc, id)
+      with Not_found -> error_global_not_found_loc loc (qualid_of_ident id)
 
 (* Interprets an hypothesis name *)
-let interp_occurrences ist (b,occs) =
-  (b,interp_int_or_var_list ist occs)
+let interp_occurrences ist occs =
+  Locusops.occurrences_map (interp_int_or_var_list ist) occs
+
+let interp_hyp_location ist env sigma ((occs,id),hl) =
+  ((interp_occurrences ist occs,interp_hyp ist env sigma id),hl)
 
-let interp_hyp_location ist gl ((occs,id),hl) =
-  ((interp_occurrences ist occs,interp_hyp ist gl id),hl)
+let interp_hyp_location_list_as_list ist env sigma ((occs,id),hl as x) =
+  match occs,hl with
+  | AllOccurrences,InHyp ->
+      List.map (fun id -> ((AllOccurrences,id),InHyp))
+        (interp_hyp_list_as_list ist env sigma id)
+  | _,_ -> [interp_hyp_location ist env sigma x]
 
-let interp_clause ist gl { onhyps=ol; concl_occs=occs } =
-  { onhyps=Option.map(List.map (interp_hyp_location ist gl)) ol;
+let interp_hyp_location_list ist env sigma l =
+  List.flatten (List.map (interp_hyp_location_list_as_list ist env sigma) l)
+
+let interp_clause ist env sigma { onhyps=ol; concl_occs=occs } : clause =
+  { onhyps=Option.map (interp_hyp_location_list ist env sigma) ol;
     concl_occs=interp_occurrences ist occs }
 
 (* Interpretation of constructions *)
 
 (* Extract the constr list from lfun *)
 let extract_ltac_constr_values ist env =
-  let rec aux = function
-  | (id,v)::tl ->
-      let (l1,l2) = aux tl in
-      (try ((id,constr_of_value env v)::l1,l2)
-       with Not_found ->
-	 let ido = match v with
-	   | VIntroPattern (IntroIdentifier id0) -> Some id0
-	   | _ -> None in
-	 (l1,(id,ido)::l2))
-  | [] -> ([],[]) in
-  aux ist.lfun
+  let fold id v accu =
+    try
+      let c = coerce_to_constr env v in
+      Id.Map.add id c accu
+    with CannotCoerceTo _ -> accu
+  in
+  Id.Map.fold fold ist.lfun Id.Map.empty
+(** ppedrot: I have changed the semantics here. Before this patch, closure was
+    implemented as a list and a variable could be bound several times with
+    different types, resulting in its possible appearance on both sides. This
+    could barely be defined as a feature... *)
 
 (* Extract the identifier list from lfun: join all branches (what to do else?)*)
 let rec intropattern_ids (loc,pat) = match pat with
-  | IntroIdentifier id -> [id]
-  | IntroOrAndPattern ll ->
+  | IntroNaming (IntroIdentifier id) -> [id]
+  | IntroAction (IntroOrAndPattern ll) ->
       List.flatten (List.map intropattern_ids (List.flatten ll))
-  | IntroWildcard | IntroAnonymous | IntroFresh _ | IntroRewrite _
+  | IntroAction (IntroInjection l) ->
+      List.flatten (List.map intropattern_ids l)
+  | IntroAction (IntroApplyOn (c,pat)) -> intropattern_ids pat
+  | IntroNaming (IntroAnonymous | IntroFresh _)
+  | IntroAction (IntroWildcard | IntroRewrite _)
   | IntroForthcoming _ -> []
 
-let rec extract_ids ids = function
-  | (id,VIntroPattern ipat)::tl when not (List.mem id ids) ->
-      intropattern_ids (dloc,ipat) @ extract_ids ids tl
-  | _::tl -> extract_ids ids tl
-  | [] -> []
+let extract_ids ids lfun =
+  let fold id v accu =
+    let v = Value.normalize v in
+    if has_type v (topwit wit_intro_pattern) then
+      let (_, ipat) = out_gen (topwit wit_intro_pattern) v in
+      if Id.List.mem id ids then accu
+      else accu @ intropattern_ids (dloc, ipat)
+    else accu
+  in
+  Id.Map.fold fold lfun []
 
-let default_fresh_id = id_of_string "H"
+let default_fresh_id = Id.of_string "H"
 
-let interp_fresh_id ist env l =
-  let ids = map_succeed (function ArgVar(_,id) -> id | _ -> failwith "") l in
-  let avoid = (extract_ids ids ist.lfun) @ ist.avoid_ids in
+let interp_fresh_id ist env sigma l =
+  let ids = List.map_filter (function ArgVar (_, id) -> Some id | _ -> None) l in
+  let avoid = match TacStore.get ist.extra f_avoid_ids with
+  | None -> []
+  | Some l -> l
+  in
+  let avoid = (extract_ids ids ist.lfun) @ avoid in
   let id =
-    if l = [] then default_fresh_id
+    if List.is_empty l then default_fresh_id
     else
       let s =
 	String.concat "" (List.map (function
 	  | ArgArg s -> s
-	  | ArgVar (_,id) -> string_of_id (interp_ident ist env id)) l) in
+	  | ArgVar (_,id) -> Id.to_string (interp_ident ist env sigma id)) l) in
       let s = if Lexer.is_keyword s then s^"0" else s in
-      id_of_string s in
+      Id.of_string s in
   Tactics.fresh_id_in_env avoid id env
 
-let pf_interp_fresh_id ist gl = interp_fresh_id ist (pf_env gl)
 
-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
+
+(* Extract the uconstr list from lfun *)
+let extract_ltac_constr_context ist env =
+  let open Glob_term in
+  let add_uconstr id env v map =
+    try Id.Map.add id (coerce_to_uconstr env v) map
+    with CannotCoerceTo _ -> map
+  in
+  let add_constr id env v map =
+    try Id.Map.add id (coerce_to_constr env v) map
+    with CannotCoerceTo _ -> map
+  in
+  let add_ident id env v map =
+    try Id.Map.add id (coerce_to_ident false env v) map
+    with CannotCoerceTo _ -> map
+  in
+  let fold id v {idents;typed;untyped} =
+    let idents = add_ident id env v idents in
+    let typed = add_constr id env v typed in
+    let untyped = add_uconstr id env v untyped in
+    { idents ; typed ; untyped }
+  in
+  let empty =  { idents = Id.Map.empty ;typed = Id.Map.empty ; untyped = Id.Map.empty } in
+  Id.Map.fold fold ist.lfun empty
+
+(** Significantly simpler than [interp_constr], to interpret an
+    untyped constr, it suffices to adjoin a closure environment. *)
+let interp_uconstr ist env = function
+  | (term,None) ->
+      { closure = extract_ltac_constr_context ist env ; term }
+  | (_,Some ce) ->
+      let ( {typed ; untyped } as closure) = extract_ltac_constr_context ist env in
+      let ltacvars = {
+        Constrintern.ltac_vars = Id.(Set.union (Map.domain typed) (Map.domain untyped));
+        ltac_bound = Id.Map.domain ist.lfun;
+      } in
+      { closure ; term =  intern_gen WithoutTypeConstraint ~ltacvars env ce }
+
+let interp_gen kind ist allow_patvar flags env sigma (c,ce) =
+  let constrvars = extract_ltac_constr_context ist env in
+  let vars = {
+    Pretyping.ltac_constrs = constrvars.typed;
+    Pretyping.ltac_uconstrs = constrvars.untyped;
+    Pretyping.ltac_idents = constrvars.idents;
+    Pretyping.ltac_genargs = ist.lfun;
+  } in
   let c = match ce with
   | None -> c
     (* If at toplevel (ce<>None), the error can be due to an incorrect
        context at globalization time: we retype with the now known
        intros/lettac/inversion hypothesis names *)
   | Some c ->
-      let ltacdata = (List.map fst ltacvars,unbndltacvars) in
-      intern_gen (kind = IsType) ~allow_patvar ~ltacvars:ltacdata sigma env c
+      let constr_context =
+        Id.Set.union
+          (Id.Map.domain constrvars.typed)
+       (Id.Set.union
+          (Id.Map.domain constrvars.untyped)
+          (Id.Map.domain constrvars.idents))
+      in
+      let ltacvars = {
+        ltac_vars = constr_context;
+        ltac_bound = Id.Map.domain ist.lfun;
+      } in
+      intern_gen kind ~allow_patvar ~ltacvars env c
   in
-  let trace = push_trace (dloc,LtacConstrInterp (c,vars)) ist.trace in
-  let evdc =
-    catch_error trace 
-      (understand_ltac ~resolve_classes:use_classes expand_evar sigma env vars kind) c in
+  let trace =
+    push_trace (loc_of_glob_constr c,LtacConstrInterp (c,vars)) ist in
   let (evd,c) =
-    if expand_evar then
-      solve_remaining_evars fail_evar use_classes
-        solve_by_implicit_tactic env sigma evdc
-    else
-      evdc in
-  db_constr ist.debug env c;
+    catch_error trace (understand_ltac flags env sigma vars kind) c
+  in
+  (* spiwack: to avoid unnecessary modifications of tacinterp, as this
+     function already use effect, I call [run] hoping it doesn't mess
+     up with any assumption. *)
+  Proofview.NonLogical.run (db_constr (curr_debug ist) env c);
   (evd,c)
 
+let constr_flags = {
+  use_typeclasses = true;
+  use_unif_heuristics = true;
+  use_hook = Some solve_by_implicit_tactic;
+  fail_evar = true;
+  expand_evars = true }
+
 (* Interprets a constr; expects evars to be solved *)
 let interp_constr_gen kind ist env sigma c =
-  interp_gen kind ist false true true true env sigma c
+  interp_gen kind ist false constr_flags env sigma c
 
-let interp_constr = interp_constr_gen (OfType None)
+let interp_constr = interp_constr_gen WithoutTypeConstraint
 
 let interp_type = interp_constr_gen IsType
 
-(* Interprets an open constr *)
-let interp_open_constr_gen kind ist =
-  interp_gen kind ist false true false false
+let open_constr_use_classes_flags = {
+  use_typeclasses = true;
+  use_unif_heuristics = true;
+  use_hook = Some solve_by_implicit_tactic;
+  fail_evar = false;
+  expand_evars = true }
+
+let open_constr_no_classes_flags = {
+  use_typeclasses = false;
+  use_unif_heuristics = true;
+  use_hook = Some solve_by_implicit_tactic;
+  fail_evar = false;
+  expand_evars = true }
+
+let pure_open_constr_flags = {
+  use_typeclasses = false;
+  use_unif_heuristics = true;
+  use_hook = None;
+  fail_evar = false;
+  expand_evars = false }
 
-(* wTC is for retrocompatibility: TC resolution started only if needed *)
-let interp_open_constr ccl wTC ist e s t =
-  try interp_gen (OfType ccl) ist false true false (ccl<>None) e s t
-  with ex when Pretype_errors.precatchable_exception ex && ccl = None && wTC ->
-    interp_gen (OfType ccl) ist false true false true e s t
+(* Interprets an open constr *)
+let interp_open_constr ?(expected_type=WithoutTypeConstraint) ist =
+  let flags =
+    if expected_type == WithoutTypeConstraint then open_constr_no_classes_flags
+    else open_constr_use_classes_flags in
+  interp_gen expected_type ist false flags
 
 let interp_pure_open_constr ist =
-  interp_gen (OfType None) ist false false false false
+  interp_gen WithoutTypeConstraint ist false pure_open_constr_flags
 
 let interp_typed_pattern ist env sigma (c,_) =
   let sigma, c =
-    interp_gen (OfType None) ist true false false false env sigma c in
-  pattern_of_constr sigma c
+    interp_gen WithoutTypeConstraint ist true pure_open_constr_flags env sigma c in
+  pattern_of_constr env sigma c
 
 (* Interprets a constr expression casted by the current goal *)
 let pf_interp_casted_constr ist gl c =
-  interp_constr_gen (OfType (Some (pf_concl gl))) ist (pf_env gl) (project gl) c
+  interp_constr_gen (OfType (pf_concl gl)) ist (pf_env gl) (project gl) c
 
 (* Interprets a constr expression *)
 let pf_interp_constr ist gl =
   interp_constr ist (pf_env gl) (project gl)
 
-let constr_list_of_VList env = function
-  | VList l -> List.map (closed_constr_of_value env) l
-  | _ -> raise Not_found
+let new_interp_constr ist c k =
+  let open Proofview in
+  Proofview.Goal.enter begin fun gl ->
+    let (sigma, c) = interp_constr ist (Goal.env gl) (Goal.sigma gl) c in
+    Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) (k c)
+  end
 
 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
-    | GVar (_,id), _ ->	
-        sigma,
-        List.map inj_fun (constr_list_of_VList env (List.assoc id ist.lfun))
+    | GVar (_,id), _ ->
+      let v = Id.Map.find id ist.lfun in
+      sigma, List.map inj_fun (coerce_to_constr_list env v)
     | _ ->
         raise Not_found
-    with Not_found ->
-      (*all of dest_fun, List.assoc, constr_list_of_VList may raise Not_found*)
+    with CannotCoerceTo _ | Not_found ->
+      (* dest_fun, List.assoc may raise Not_found *)
       let sigma, c = interp_fun ist env sigma x in
       sigma, [c] in
-  let sigma, l = list_fold_map try_expand_ltac_var sigma l in
+  let sigma, l = List.fold_map try_expand_ltac_var sigma l in
   sigma, List.flatten l
 
 let interp_constr_list ist env sigma c =
   interp_constr_in_compound_list (fun x -> x) (fun x -> x) interp_constr ist env sigma c
 
 let interp_open_constr_list =
-  interp_constr_in_compound_list (fun x -> x) (fun x -> x)
-    (interp_open_constr None false)
+  interp_constr_in_compound_list (fun x -> x) (fun x -> x) interp_open_constr
 
 let interp_auto_lemmas ist env sigma lems =
   let local_sigma, lems = interp_open_constr_list ist env sigma lems in
@@ -1347,154 +670,231 @@ let pf_interp_type ist gl =
   interp_type ist (pf_env gl) (project gl)
 
 (* Interprets a reduction expression *)
-let interp_unfold ist env (occs,qid) =
-  (interp_occurrences ist occs,interp_evaluable ist env qid)
+let interp_unfold ist env sigma (occs,qid) =
+  (interp_occurrences ist occs,interp_evaluable ist env sigma qid)
 
-let interp_flag ist env red =
-  { red with rConst = List.map (interp_evaluable ist env) red.rConst }
+let interp_flag ist env sigma red =
+  { red with rConst = List.map (interp_evaluable ist env sigma) red.rConst }
 
-let interp_constr_with_occurrences ist sigma env (occs,c) =
-  let (sigma,c_interp) = interp_constr ist sigma env c in
+let interp_constr_with_occurrences ist env sigma (occs,c) =
+  let (sigma,c_interp) = interp_constr ist env sigma c in
   sigma , (interp_occurrences ist occs, c_interp)
 
-let interp_typed_pattern_with_occurrences ist env sigma (occs,c) =
-  let sign,p = interp_typed_pattern ist env sigma c in
-  sign, (interp_occurrences ist occs, p)
-
-let interp_closed_typed_pattern_with_occurrences ist env sigma occl =
-  snd (interp_typed_pattern_with_occurrences ist env sigma occl)
+let interp_closed_typed_pattern_with_occurrences ist env sigma (occs, a) =
+  let p = match a with
+  | Inl b -> Inl (interp_evaluable ist env sigma b)
+  | Inr c -> Inr (snd (interp_typed_pattern ist env sigma c)) in
+  interp_occurrences ist occs, p
 
 let interp_constr_with_occurrences_and_name_as_list =
   interp_constr_in_compound_list
-    (fun c -> ((all_occurrences_expr,c),Anonymous))
-    (function ((occs,c),Anonymous) when occs = all_occurrences_expr -> c
+    (fun c -> ((AllOccurrences,c),Anonymous))
+    (function ((occs,c),Anonymous) when occs == AllOccurrences -> c
       | _ -> raise Not_found)
     (fun ist env sigma (occ_c,na) ->
       let (sigma,c_interp) = interp_constr_with_occurrences ist env sigma occ_c in
       sigma, (c_interp,
-       interp_fresh_name ist env na))
+       interp_fresh_name ist env sigma na))
 
-let interp_red_expr ist sigma env = function
-  | Unfold l -> sigma , Unfold (List.map (interp_unfold ist env) l)
+let interp_red_expr ist env sigma = function
+  | Unfold l -> sigma , Unfold (List.map (interp_unfold ist env sigma) l)
   | Fold l ->
     let (sigma,l_interp) = interp_constr_list ist env sigma l in
     sigma , Fold l_interp
-  | Cbv f -> sigma , Cbv (interp_flag ist env f)
-  | Lazy f -> sigma , Lazy (interp_flag ist env f)
+  | Cbv f -> sigma , Cbv (interp_flag ist env sigma f)
+  | Cbn f -> sigma , Cbn (interp_flag ist env sigma f)
+  | Lazy f -> sigma , Lazy (interp_flag ist env sigma f)
   | Pattern l ->
-    let (sigma,l_interp) =
-      List.fold_right begin fun c (sigma,acc) ->
-	let (sigma,c_interp) = interp_constr_with_occurrences ist env sigma c in
-	sigma , c_interp :: acc
-      end l (sigma,[])
-    in
-    sigma , Pattern l_interp
-  | Simpl o ->
-      sigma , Simpl(Option.map (interp_closed_typed_pattern_with_occurrences ist env sigma) o)
-  | (Red _ |  Hnf | ExtraRedExpr _ | CbvVm as r) -> sigma , r
-
-let pf_interp_red_expr ist gl = interp_red_expr ist (project gl) (pf_env gl)
-
-let interp_may_eval f ist gl = function
+      let (sigma,l_interp) =
+        Evd.MonadR.List.map_right
+          (fun c sigma -> interp_constr_with_occurrences ist env sigma c) l sigma
+      in
+      sigma , Pattern l_interp
+  | Simpl (f,o) ->
+     sigma , Simpl (interp_flag ist env sigma f,
+		    Option.map (interp_closed_typed_pattern_with_occurrences ist env sigma) o)
+  | CbvVm o ->
+    sigma , CbvVm (Option.map (interp_closed_typed_pattern_with_occurrences ist env sigma) o)
+  | CbvNative o ->
+    sigma , CbvNative (Option.map (interp_closed_typed_pattern_with_occurrences ist env sigma) o)
+  | (Red _ |  Hnf | ExtraRedExpr _ as r) -> sigma , r
+
+let interp_may_eval f ist env sigma = function
   | ConstrEval (r,c) ->
-      let (sigma,redexp) = pf_interp_red_expr ist gl r in
-      let (sigma,c_interp) = f ist { gl with sigma=sigma } c in
-      sigma , pf_reduction_of_red_expr gl redexp c_interp
+      let (sigma,redexp) = interp_red_expr ist env sigma r in
+      let (sigma,c_interp) = f ist env sigma c in
+      (fst (Redexpr.reduction_of_red_expr env redexp) env sigma c_interp)
   | ConstrContext ((loc,s),c) ->
       (try
-	let (sigma,ic) = f ist gl c
-	and ctxt = constr_of_VConstr_context (List.assoc s ist.lfun) in
-	sigma , subst_meta [special_meta,ic] ctxt
+	let (sigma,ic) = f ist env sigma c in
+	let ctxt = coerce_to_constr_context (Id.Map.find s ist.lfun) in
+	let evdref = ref sigma in
+	let c = subst_meta [Constr_matching.special_meta,ic] ctxt in
+	let c = Typing.solve_evars env evdref c in
+	!evdref , c
       with
 	| Not_found ->
 	    user_err_loc (loc, "interp_may_eval",
 	    str "Unbound context identifier" ++ pr_id s ++ str"."))
   | ConstrTypeOf c ->
-      let (sigma,c_interp) = f ist gl c in
-      sigma , pf_type_of gl c_interp
+      let (sigma,c_interp) = f ist env sigma c in
+      Typing.e_type_of ~refresh:true env sigma c_interp
   | ConstrTerm c ->
      try
-	f ist gl c
+	f ist env sigma c
      with reraise ->
-       debugging_exception_step ist false reraise (fun () ->
-         str"interpretation of term " ++ pr_glob_constr_env (pf_env gl) (fst c));
-       raise reraise
+       let reraise = Errors.push reraise in
+       (* spiwack: to avoid unnecessary modifications of tacinterp, as this
+          function already use effect, I call [run] hoping it doesn't mess
+          up with any assumption. *)
+       Proofview.NonLogical.run (debugging_exception_step ist false (fst reraise) (fun () ->
+         str"interpretation of term " ++ pr_glob_constr_env env (fst c)));
+       iraise reraise
 
 (* Interprets a constr expression possibly to first evaluate *)
-let interp_constr_may_eval ist gl c =
+let interp_constr_may_eval ist env sigma c =
   let (sigma,csr) =
     try
-      interp_may_eval pf_interp_constr ist gl c
+      interp_may_eval interp_constr ist env sigma c
     with reraise ->
-      debugging_exception_step ist false reraise (fun () ->
-        str"evaluation of term");
-      raise reraise
+      let reraise = Errors.push reraise in
+      (* spiwack: to avoid unnecessary modifications of tacinterp, as this
+          function already use effect, I call [run] hoping it doesn't mess
+          up with any assumption. *)
+       Proofview.NonLogical.run (debugging_exception_step ist false (fst reraise) (fun () -> str"evaluation of term"));
+      iraise reraise
   in
   begin
-    db_constr ist.debug (pf_env gl) csr;
+    (* spiwack: to avoid unnecessary modifications of tacinterp, as this
+       function already use effect, I call [run] hoping it doesn't mess
+       up with any assumption. *)
+    Proofview.NonLogical.run (db_constr (curr_debug ist) env csr);
     sigma , csr
   end
 
-let rec message_of_value gl = function
-  | VVoid -> str "()"
-  | VInteger n -> int n
-  | VIntroPattern ipat -> pr_intro_pattern (dloc,ipat)
-  | VConstr_context c -> pr_constr_env (pf_env gl) c
-  | VConstr c -> pr_constr_under_binders_env (pf_env gl) c
-  | VRec _ | VRTactic _ | VFun _ -> str "<tactic>"
-  | VList l -> prlist_with_sep spc (message_of_value gl) l
-
-let rec interp_message_token ist gl = function
-  | MsgString s -> str s
-  | MsgInt n -> int n
+(** TODO: should use dedicated printers *)
+let rec message_of_value v =
+  let v = Value.normalize v in
+  let open Tacmach.New in
+  let open Ftactic in
+  if has_type v (topwit wit_tacvalue) then
+    Ftactic.return (str "<tactic>")
+  else if has_type v (topwit wit_constr) then
+    let v = out_gen (topwit wit_constr) v in
+    Ftactic.nf_enter begin fun gl -> Ftactic.return (pr_constr_env (pf_env gl) (Proofview.Goal.sigma gl) v) end
+  else if has_type v (topwit wit_constr_under_binders) then
+    let c = out_gen (topwit wit_constr_under_binders) v in
+    Ftactic.nf_enter begin fun gl ->
+      Ftactic.return (pr_constr_under_binders_env (pf_env gl) (Proofview.Goal.sigma gl) c)
+    end
+  else if has_type v (topwit wit_unit) then
+    Ftactic.return (str "()")
+  else if has_type v (topwit wit_int) then
+    Ftactic.return (int (out_gen (topwit wit_int) v))
+  else if has_type v (topwit wit_intro_pattern) then
+    let p = out_gen (topwit wit_intro_pattern) v in
+    let print env sigma c = pr_constr_env env sigma (snd (c env Evd.empty)) in
+    Ftactic.nf_enter begin fun gl ->
+      Ftactic.return (Miscprint.pr_intro_pattern (fun c -> print (pf_env gl) (Proofview.Goal.sigma gl) c) p)
+    end
+  else if has_type v (topwit wit_constr_context) then
+    let c = out_gen (topwit wit_constr_context) v in
+    Ftactic.nf_enter begin fun gl -> Ftactic.return (pr_constr_env (pf_env gl) (Proofview.Goal.sigma gl) c) end
+  else if has_type v (topwit wit_uconstr) then
+    let c = out_gen (topwit wit_uconstr) v in
+    Ftactic.nf_enter begin fun gl ->
+      Ftactic.return (pr_closed_glob_env (pf_env gl)
+                        (Proofview.Goal.sigma gl) c)
+    end
+  else match Value.to_list v with
+  | Some l ->
+    Ftactic.List.map message_of_value l >>= fun l ->
+    Ftactic.return (prlist_with_sep spc (fun x -> x) l)
+  | None ->
+    let tag = pr_argument_type (genarg_tag v) in
+    Ftactic.return (str "<" ++ tag ++ str ">") (** TODO *)
+
+let interp_message_token ist = function
+  | MsgString s -> Ftactic.return (str s)
+  | MsgInt n -> Ftactic.return (int n)
   | MsgIdent (loc,id) ->
-      let v =
-	try List.assoc id ist.lfun
-	with Not_found -> user_err_loc (loc,"",pr_id id ++ str" not found.") in
-      message_of_value gl v
-
-let rec interp_message_nl ist gl = function
-  | [] -> mt()
-  | l -> prlist_with_sep spc (interp_message_token ist gl) l ++ fnl()
-
-let interp_message ist gl l =
-  (* Force evaluation of interp_message_token so that potential errors
-     are raised now and not at printing time *)
-  prlist (fun x -> spc () ++ x) (List.map (interp_message_token ist gl) l)
-
-let intro_pattern_list_of_Vlist loc env = function
-  | VList l -> List.map (fun a -> loc,coerce_to_intro_pattern env a) l
-  | _ -> raise Not_found
-
-let rec interp_intro_pattern ist gl = function
-  | loc, IntroOrAndPattern l ->
-      loc, IntroOrAndPattern (interp_or_and_intro_pattern ist gl l)
-  | loc, IntroIdentifier id ->
-      loc, interp_intro_pattern_var loc ist (pf_env gl) id
-  | loc, IntroFresh id ->
-      loc, IntroFresh (interp_fresh_ident ist (pf_env gl) id)
-  | loc, (IntroWildcard | IntroAnonymous | IntroRewrite _ | IntroForthcoming _)
-      as x -> x
-
-and interp_or_and_intro_pattern ist gl =
-  List.map (interp_intro_pattern_list_as_list ist gl)
-
-and interp_intro_pattern_list_as_list ist gl = function
-  | [loc,IntroIdentifier id] as l ->
-      (try intro_pattern_list_of_Vlist loc (pf_env gl) (List.assoc id ist.lfun)
+    let v = try Some (Id.Map.find id ist.lfun) with Not_found -> None in
+    match v with
+    | None -> Ftactic.lift (Tacticals.New.tclZEROMSG (pr_id id ++ str" not found."))
+    | Some v -> message_of_value v
+
+let interp_message ist l =
+  let open Ftactic in
+  Ftactic.List.map (interp_message_token ist) l >>= fun l ->
+  Ftactic.return (prlist_with_sep spc (fun x -> x) l)
+
+let interp_message ist l =
+  let open Ftactic in
+  Ftactic.List.map (interp_message_token ist) l >>= fun l ->
+  Ftactic.return (prlist_with_sep spc (fun x -> x) l)
+
+let rec interp_intro_pattern ist env sigma = function
+  | loc, IntroAction pat ->
+      let (sigma,pat) = interp_intro_pattern_action ist env sigma pat in
+      sigma, (loc, IntroAction pat)
+  | loc, IntroNaming (IntroIdentifier id) ->
+      sigma, (loc, interp_intro_pattern_var loc ist env sigma id)
+  | loc, IntroNaming pat ->
+      sigma, (loc, IntroNaming (interp_intro_pattern_naming loc ist env sigma pat))
+  | loc, IntroForthcoming _  as x -> sigma, x
+
+and interp_intro_pattern_naming loc ist env sigma = function
+  | IntroFresh id -> IntroFresh (interp_fresh_ident ist env sigma id)
+  | IntroIdentifier id -> interp_intro_pattern_naming_var loc ist env sigma id
+  | IntroAnonymous as x -> x
+
+and interp_intro_pattern_action ist env sigma = function
+  | IntroOrAndPattern l ->
+      let (sigma,l) = interp_or_and_intro_pattern ist env sigma l in
+      sigma, IntroOrAndPattern l
+  | IntroInjection l ->
+      let sigma,l = interp_intro_pattern_list_as_list ist env sigma l in
+      sigma, IntroInjection l
+  | IntroApplyOn (c,ipat) ->
+      let c = fun env sigma -> interp_constr ist env sigma c in
+      let sigma,ipat = interp_intro_pattern ist env sigma ipat in
+      sigma, IntroApplyOn (c,ipat)
+  | IntroWildcard | IntroRewrite _ as x -> sigma, x
+
+and interp_or_and_intro_pattern ist env sigma =
+  List.fold_map (interp_intro_pattern_list_as_list ist env) sigma
+
+and interp_intro_pattern_list_as_list ist env sigma = function
+  | [loc,IntroNaming (IntroIdentifier id)] as l ->
+      (try sigma, coerce_to_intro_pattern_list loc env (Id.Map.find id ist.lfun)
        with Not_found | CannotCoerceTo _ ->
-	List.map (interp_intro_pattern ist gl) l)
-  | l -> List.map (interp_intro_pattern ist gl) l
-
-let interp_in_hyp_as ist gl (id,ipat) =
-  (interp_hyp ist gl id,Option.map (interp_intro_pattern ist gl) ipat)
-
-(* Quantified named or numbered hypothesis or hypothesis in context *)
-(* (as in Inversion) *)
-let coerce_to_quantified_hypothesis = function
-  | VInteger n -> AnonHyp n
-  | VIntroPattern (IntroIdentifier id) -> NamedHyp id
-  | v -> raise (CannotCoerceTo "a quantified hypothesis")
+         List.fold_map (interp_intro_pattern ist env) sigma l)
+  | l -> List.fold_map (interp_intro_pattern ist env) sigma l
+
+let interp_intro_pattern_naming_option ist env sigma = function
+  | None -> None
+  | Some (loc,pat) -> Some (loc, interp_intro_pattern_naming loc ist env sigma pat)
+
+let interp_or_and_intro_pattern_option ist env sigma = function
+  | None -> sigma, None
+  | Some (ArgVar (loc,id)) ->
+      (match coerce_to_intro_pattern env (Id.Map.find id ist.lfun) with
+      | IntroAction (IntroOrAndPattern l) -> sigma, Some (loc,l)
+      | _ ->
+        raise (CannotCoerceTo "a disjunctive/conjunctive introduction pattern"))
+  | Some (ArgArg (loc,l)) ->
+      let sigma,l = interp_or_and_intro_pattern ist env sigma l in
+      sigma, Some (loc,l)
+
+let interp_intro_pattern_option ist env sigma = function
+  | None -> sigma, None
+  | Some ipat ->
+      let sigma, ipat = interp_intro_pattern ist env sigma ipat in
+      sigma, Some ipat
+
+let interp_in_hyp_as ist env sigma (clear,id,ipat) =
+  let sigma, ipat = interp_intro_pattern_option ist env sigma ipat in
+  sigma,(clear,interp_hyp ist env sigma id,ipat)
 
 let interp_quantified_hypothesis ist = function
   | AnonHyp n -> AnonHyp n
@@ -1511,25 +911,15 @@ let interp_binding_name ist = function
       try try_interp_ltac_var coerce_to_quantified_hypothesis ist None(dloc,id)
       with Not_found -> NamedHyp id
 
-(* Quantified named or numbered hypothesis or hypothesis in context *)
-(* (as in Inversion) *)
-let coerce_to_decl_or_quant_hyp env = function
-  | VInteger n -> AnonHyp n
-  | v ->
-      try NamedHyp (coerce_to_hyp env v)
-      with CannotCoerceTo _ ->
-	raise (CannotCoerceTo "a declared or quantified hypothesis")
-
-let interp_declared_or_quantified_hypothesis ist gl = function
+let interp_declared_or_quantified_hypothesis ist env sigma = function
   | AnonHyp n -> AnonHyp n
   | NamedHyp id ->
-      let env = pf_env gl in
       try try_interp_ltac_var
-	    (coerce_to_decl_or_quant_hyp env) ist (Some env) (dloc,id)
+	    (coerce_to_decl_or_quant_hyp env) ist (Some (env,sigma)) (dloc,id)
       with Not_found -> NamedHyp id
 
 let interp_binding ist env sigma (loc,b,c) =
-  let sigma, c = interp_open_constr None false ist env sigma c in
+  let sigma, c = interp_open_constr ist env sigma c in
   sigma, (loc,interp_binding_name ist b,c)
 
 let interp_bindings ist env sigma = function
@@ -1539,63 +929,85 @@ let interp_bindings ist env sigma = function
     let sigma, l = interp_open_constr_list ist env sigma l in   
     sigma, ImplicitBindings l
 | ExplicitBindings l ->
-    let sigma, l = list_fold_map (interp_binding ist env) sigma l in
+    let sigma, l = List.fold_map (interp_binding ist env) sigma l in
     sigma, ExplicitBindings l
 
 let interp_constr_with_bindings ist env sigma (c,bl) =
   let sigma, bl = interp_bindings ist env sigma bl in
-  let sigma, c = interp_open_constr None false ist env sigma c in
+  let sigma, c = interp_open_constr ist env sigma c in
   sigma, (c,bl)
 
-let interp_open_constr_with_bindings wTC ist env sigma (c,bl) =
+let interp_constr_with_bindings_arg ist env sigma (keep,c) =
+  let sigma, c = interp_constr_with_bindings ist env sigma c in
+  sigma, (keep,c)
+
+let interp_open_constr_with_bindings ist env sigma (c,bl) =
   let sigma, bl = interp_bindings ist env sigma bl in
-  let sigma, c = interp_open_constr None wTC ist env sigma c in
+  let sigma, c = interp_open_constr ist env sigma c in
   sigma, (c, bl)
 
+let interp_open_constr_with_bindings_arg ist env sigma (keep,c) =
+  let sigma, c = interp_open_constr_with_bindings ist env sigma c in
+  sigma,(keep,c)
+
 let loc_of_bindings = function
-| NoBindings -> dummy_loc
-| ImplicitBindings l -> loc_of_glob_constr (fst (list_last l))
-| ExplicitBindings l -> pi1 (list_last l)
+| NoBindings -> Loc.ghost
+| ImplicitBindings l -> loc_of_glob_constr (fst (List.last l))
+| ExplicitBindings l -> pi1 (List.last l)
 
-let interp_open_constr_with_bindings_loc wTC ist env sigma ((c,_),bl as cb) =
+let interp_open_constr_with_bindings_loc ist ((c,_),bl as cb) =
   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 wTC ist env sigma cb in
-  sigma, (loc,cb)
+  let loc = if Loc.is_ghost loc2 then loc1 else Loc.merge loc1 loc2 in
+  let f env sigma = interp_open_constr_with_bindings ist env sigma cb in
+    (loc,f)
 
 let interp_induction_arg ist gl arg =
-  let env = pf_env gl and sigma = project gl in
   match arg with
-  | ElimOnConstr c ->
-      ElimOnConstr (interp_constr_with_bindings ist env sigma c)
-  | ElimOnAnonHyp n as x -> x
-  | ElimOnIdent (loc,id) ->
+  | keep,ElimOnConstr c ->
+      keep,ElimOnConstr (fun env sigma -> interp_constr_with_bindings ist env sigma c)
+  | keep,ElimOnAnonHyp n as x -> x
+  | keep,ElimOnIdent (loc,id) ->
+      let error () = user_err_loc (loc, "",
+        strbrk "Cannot coerce " ++ pr_id id ++
+        strbrk " neither to a quantified hypothesis nor to a term.")
+      in
+      let try_cast_id id' =
+        if Tactics.is_quantified_hypothesis id' gl
+        then keep,ElimOnIdent (loc,id')
+        else
+          (try keep,ElimOnConstr (fun env sigma -> 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."))
+      in
       try
-        match List.assoc id ist.lfun with
-	| 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.")
+        (** FIXME: should be moved to taccoerce *)
+        let v = Id.Map.find id ist.lfun in
+        let v = Value.normalize v in
+        if has_type v (topwit wit_intro_pattern) then
+          let v = out_gen (topwit wit_intro_pattern) v in
+          match v with
+          | _, IntroNaming (IntroIdentifier id) -> try_cast_id id
+          | _ -> error ()
+        else if has_type v (topwit wit_var) then
+          let id = out_gen (topwit wit_var) v in
+          try_cast_id id
+        else if has_type v (topwit wit_int) then
+          keep,ElimOnAnonHyp (out_gen (topwit wit_int) v)
+        else match Value.to_constr v with
+        | None -> error ()
+        | Some c -> keep,ElimOnConstr (fun env sigma -> sigma,(c,NoBindings))
       with Not_found ->
 	(* We were in non strict (interactive) mode *)
 	if Tactics.is_quantified_hypothesis id gl then
-          ElimOnIdent (loc,id)
+          keep,ElimOnIdent (loc,id)
 	else
-          let c = (GVar (loc,id),Some (CRef (Ident (loc,id)))) in
-          let (sigma,c) = interp_constr ist env sigma c in
-          ElimOnConstr (sigma,(c,NoBindings))
+          let c = (GVar (loc,id),Some (CRef (Ident (loc,id),None))) in
+          let f env sigma = 
+            let (sigma,c) = interp_open_constr ist env sigma c in
+            sigma,(c,NoBindings) in
+          keep,ElimOnConstr f
 
 (* Associates variables with values and gives the remaining variables and
    values *)
@@ -1609,12 +1021,11 @@ let head_with_value (lvar,lval) =
     | (vr,[]) -> (lacc,vr,[])
     | ([],ve) -> (lacc,[],ve)
   in
-    head_with_value_rec [] (lvar,lval)
+  head_with_value_rec [] (lvar,lval)
 
-(* Gives a context couple if there is a context identifier *)
-let give_context ctxt = function
-  | None -> []
-  | Some id -> [id,VConstr_context ctxt]
+(** [interp_context ctxt] interprets a context (as in
+    {!Matching.matching_result}) into a context value of Ltac.  *)
+let interp_context ctxt = in_gen (topwit wit_constr_context) ctxt
 
 (* Reads a pattern by substituting vars of lfun *)
 let use_types = false
@@ -1623,7 +1034,7 @@ let eval_pattern lfun ist env sigma (_,pat as c) =
   if use_types then
     snd (interp_typed_pattern ist env sigma c)
   else
-    instantiate_pattern sigma lfun pat
+    instantiate_pattern env sigma lfun pat
 
 let read_pattern lfun ist env sigma = function
   | Subterm (b,ido,c) -> Subterm (b,ido,eval_pattern lfun ist env sigma c)
@@ -1631,9 +1042,9 @@ let read_pattern lfun ist env sigma = function
 
 (* Reads the hypotheses of a Match Context rule *)
 let cons_and_check_name id l =
-  if List.mem id l then
+  if Id.List.mem id l then
     user_err_loc (dloc,"read_match_goal_hyps",
-      strbrk ("Hypothesis pattern-matching variable "^(string_of_id id)^
+      strbrk ("Hypothesis pattern-matching variable "^(Id.to_string id)^
       " used twice in the same pattern."))
   else id::l
 
@@ -1656,1532 +1067,1267 @@ let rec read_match_rule lfun ist env sigma = function
       :: read_match_rule lfun ist env sigma tl
   | [] -> []
 
-(* For Match Context and Match *)
-exception Not_coherent_metas
-exception Eval_fail of std_ppcmds
-
-let is_match_catchable = function
-  | PatternMatchingFailure | Eval_fail _ -> true
-  | e -> Logic.catchable_exception e
-
-let equal_instances gl (ctx',c') (ctx,c) =
-  (* How to compare instances? Do we want the terms to be convertible?
-     unifiable? Do we want the universe levels to be relevant? 
-     (historically, conv_x is used) *)
-  ctx = ctx' & pf_conv_x gl c' c
-
-(* Verifies if the matched list is coherent with respect to lcm *)
-(* While non-linear matching is modulo eq_constr in matches, merge of *)
-(* different instances of the same metavars is here modulo conversion... *)
-let verify_metas_coherence gl (ln1,lcm) (ln,lm) =
-  let rec aux = function
-  | (id,c as x)::tl ->
-      if List.for_all (fun (id',c') -> id'<>id or equal_instances gl c' c) lcm
-      then
-	x :: aux tl
-      else
-	raise Not_coherent_metas
-  | [] -> lcm in
-  (ln@ln1,aux lm)
-
-let adjust (l,lc) = (l,List.map (fun (id,c) -> (id,([],c))) lc)
-
-(* Tries to match one hypothesis pattern with a list of hypotheses *)
-let apply_one_mhyp_context ist env gl lmatch (hypname,patv,pat) lhyps =
-  let get_id_couple id = function
-    | Name idpat -> [idpat,VConstr ([],mkVar id)]
-    | Anonymous -> [] in
-  let match_pat lmatch hyp pat =
-    match pat with
-    | Term t ->
-        let lmeta = extended_matches t hyp in
-        (try
-            let lmeta = verify_metas_coherence gl lmatch lmeta in
-            ([],lmeta,(fun () -> raise PatternMatchingFailure))
-          with
-            | Not_coherent_metas -> raise PatternMatchingFailure);
-    | Subterm (b,ic,t) ->
-        let rec match_next_pattern find_next () =
-          let (lmeta,ctxt,find_next') = find_next () in
-          try
-            let lmeta = verify_metas_coherence gl lmatch (adjust lmeta) in
-            (give_context ctxt ic,lmeta,match_next_pattern find_next')
-          with
-            | Not_coherent_metas -> match_next_pattern find_next' () in
-        match_next_pattern (fun () -> match_subterm_gen b t hyp) () in
-  let rec apply_one_mhyp_context_rec = function
-    | (id,b,hyp as hd)::tl ->
-	(match patv with
-	| None ->
-            let rec match_next_pattern find_next () =
-              try
-                let (ids, lmeta, find_next') = find_next () in
-		(get_id_couple id hypname@ids, lmeta, hd,
-                 match_next_pattern find_next')
-              with
-                | PatternMatchingFailure -> apply_one_mhyp_context_rec tl in
-            match_next_pattern (fun () ->
-	      let hyp = if b<>None then refresh_universes_strict hyp else hyp in
-	      match_pat lmatch hyp pat) ()
-	| Some patv ->
-	    match b with
-	    | Some body ->
-                let rec match_next_pattern_in_body next_in_body () =
-                  try
-                    let (ids,lmeta,next_in_body') = next_in_body() in
-                    let rec match_next_pattern_in_typ next_in_typ () =
-                      try
-                        let (ids',lmeta',next_in_typ') = next_in_typ() in
-		        (get_id_couple id hypname@ids@ids', lmeta', hd,
-                         match_next_pattern_in_typ next_in_typ')
-                      with
-                        | PatternMatchingFailure ->
-                            match_next_pattern_in_body next_in_body' () in
-                    match_next_pattern_in_typ
-                      (fun () ->
-			let hyp = refresh_universes_strict hyp in
-			match_pat lmeta hyp pat) ()
-                  with PatternMatchingFailure -> apply_one_mhyp_context_rec tl
-                in
-                match_next_pattern_in_body
-                  (fun () -> match_pat lmatch body patv) ()
-            | None -> apply_one_mhyp_context_rec tl)
-    | [] ->
-        db_hyp_pattern_failure ist.debug env (hypname,pat);
-        raise PatternMatchingFailure
-  in
-    apply_one_mhyp_context_rec lhyps
 
 (* misc *)
 
 let mk_constr_value ist gl c =
   let (sigma,c_interp) = pf_interp_constr ist gl c in
-  sigma,VConstr ([],c_interp)
-let mk_open_constr_value wTC ist gl c = 
-  let (sigma,c_interp) = pf_apply (interp_open_constr None wTC ist) gl c in
-  sigma,VConstr ([],c_interp)
-let mk_hyp_value ist gl c = VConstr ([],mkVar (interp_hyp ist gl c))
-let mk_int_or_var_value ist c = VInteger (interp_int_or_var ist c)
-
-let pack_sigma (sigma,c) = {it=c;sigma=sigma}
+  sigma, Value.of_constr c_interp
+let mk_open_constr_value ist gl c = 
+  let (sigma,c_interp) = pf_apply (interp_open_constr ist) gl c in
+  sigma, Value.of_constr c_interp
+let mk_hyp_value ist env sigma c =
+  Value.of_constr (mkVar (interp_hyp ist env sigma c))
+let mk_int_or_var_value ist c = in_gen (topwit wit_int) (interp_int_or_var ist c)
 
-let extend_gl_hyps { it=gl ; sigma=sigma } sign =
-  Goal.V82.new_goal_with sigma gl sign
+let pack_sigma (sigma,c) = {it=c;sigma=sigma;}
 
 (* Interprets an l-tac expression into a value *)
-let rec val_interp ist gl (tac:glob_tactic_expr) =
+let rec val_interp ist ?(appl=UnnamedAppl) (tac:glob_tactic_expr) : typed_generic_argument Ftactic.t =
+  (* The name [appl] of applied top-level Ltac names is ignored in
+     [value_interp]. It is installed in the second step by a call to
+     [name_vfun], because it gives more opportunities to detect a
+     [VFun]. Otherwise a [Ltac t := let x := .. in tac] would never
+     register its name since it is syntactically a let, not a
+     function.  *)
   let value_interp ist = match tac with
-  (* Immediate evaluation *)
-  | TacFun (it,body) -> project gl , VFun (ist.trace,ist.lfun,it,body)
-  | TacLetIn (true,l,u) -> interp_letrec ist gl l u
-  | TacLetIn (false,l,u) -> interp_letin ist gl l u
-  | TacMatchGoal (lz,lr,lmr) -> interp_match_goal ist gl lz lr lmr
-  | TacMatch (lz,c,lmr) -> interp_match ist gl lz c lmr
-  | TacArg (loc,a) -> interp_tacarg ist gl a
-  (* Delayed evaluation *)
-  | t -> project gl , VFun (ist.trace,ist.lfun,[],t)
-
-  in check_for_interrupt ();
-    match ist.debug with
-    | DebugOn lev ->
-	debug_prompt lev gl tac (fun v -> value_interp {ist with debug=v})
-    | _ -> value_interp ist
-
-and eval_tactic ist = function
+  | TacFun (it, body) ->
+    Ftactic.return (of_tacvalue (VFun (UnnamedAppl,extract_trace ist, ist.lfun, it, body)))
+  | TacLetIn (true,l,u) -> interp_letrec ist l u
+  | TacLetIn (false,l,u) -> interp_letin ist l u
+  | TacMatchGoal (lz,lr,lmr) -> interp_match_goal ist lz lr lmr
+  | TacMatch (lz,c,lmr) -> interp_match ist lz c lmr
+  | TacArg (loc,a) -> interp_tacarg ist a
+  | t ->
+    (** Delayed evaluation *)
+    Ftactic.return (of_tacvalue (VFun (UnnamedAppl,extract_trace ist, ist.lfun, [], t)))
+  in
+  let open Ftactic in
+  Control.check_for_interrupt ();
+  match curr_debug ist with
+  | DebugOn lev ->
+        let eval v =
+          let ist = { ist with extra = TacStore.set ist.extra f_debug v } in
+          value_interp ist >>= fun v -> return (name_vfun appl v)
+        in
+	Ftactic.debug_prompt lev tac eval
+  | _ -> value_interp ist >>= fun v -> return (name_vfun appl v)
+      
+
+and eval_tactic ist tac : unit Proofview.tactic = match tac with
   | TacAtom (loc,t) ->
-      fun gl ->
-	let box = ref None in abstract_tactic_box := box;
-	let call = LtacAtomCall (t,box) in
-	let tac = (* catch error in the interpretation *)
-	  catch_error (push_trace(dloc,call)ist.trace)
-	    (interp_atomic ist gl) t	in
-	(* catch error in the evaluation *)
-	catch_error (push_trace(loc,call)ist.trace) tac gl
+      let call = LtacAtomCall t in
+      catch_error_tac (push_trace(loc,call) ist) (interp_atomic ist t)
   | TacFun _ | TacLetIn _ -> assert false
   | TacMatchGoal _ | TacMatch _ -> assert false
-  | TacId s -> fun gl ->
-      let res = tclIDTAC_MESSAGE (interp_message_nl ist gl s) gl in
-      db_breakpoint ist.debug s; res
-  | TacFail (n,s) -> fun gl -> tclFAIL (interp_int_or_var ist n) (interp_message ist gl s) gl
-  | TacProgress tac -> tclPROGRESS (interp_tactic ist tac)
+  | TacId [] -> Proofview.tclLIFT (db_breakpoint (curr_debug ist) [])
+  | TacId s ->
+      let msgnl =
+        let open Ftactic in
+        interp_message ist s >>= fun msg ->
+        return (hov 0 msg , hov 0 msg)
+      in
+      let print (_,msgnl) = Proofview.(tclLIFT (NonLogical.print msgnl)) in
+      let log (msg,_) = Proofview.Trace.log (fun () -> msg) in
+      let break = Proofview.tclLIFT (db_breakpoint (curr_debug ist) s) in
+      Ftactic.run msgnl begin fun msgnl ->
+        print msgnl <*> log msgnl <*> break
+      end
+  | TacFail (g,n,s) ->
+      let msg = interp_message ist s in
+      let tac l = Tacticals.New.tclFAIL (interp_int_or_var ist n) l in
+      let tac =
+        match g with
+        | TacLocal -> fun l -> Proofview.tclINDEPENDENT (tac l)
+        | TacGlobal -> tac
+      in
+      Ftactic.run msg tac
+  | TacProgress tac -> Tacticals.New.tclPROGRESS (interp_tactic ist tac)
+  | TacShowHyps tac ->
+         Proofview.V82.tactic begin
+           tclSHOWHYPS (Proofview.V82.of_tactic (interp_tactic ist tac))
+         end
   | TacAbstract (tac,ido) ->
-      fun gl -> Tactics.tclABSTRACT
-        (Option.map (pf_interp_ident ist gl) ido) (interp_tactic ist tac) gl
-  | TacThen (t1,tf,t,tl) ->
-      tclTHENS3PARTS (interp_tactic ist t1)
+      Proofview.Goal.nf_enter begin fun gl -> Tactics.tclABSTRACT
+        (Option.map (Tacmach.New.of_old (pf_interp_ident ist) gl) ido) (interp_tactic ist tac)
+      end
+  | TacThen (t1,t) ->
+      Tacticals.New.tclTHEN (interp_tactic ist t1) (interp_tactic ist t)
+  | TacDispatch tl ->
+      Proofview.tclDISPATCH (List.map (interp_tactic ist) tl)
+  | TacExtendTac (tf,t,tl) ->
+      Proofview.tclEXTEND (Array.map_to_list (interp_tactic ist) tf)
+                          (interp_tactic ist t)
+                          (Array.map_to_list (interp_tactic ist) tl)
+  | TacThens (t1,tl) -> Tacticals.New.tclTHENS (interp_tactic ist t1) (List.map (interp_tactic ist) tl)
+  | TacThens3parts (t1,tf,t,tl) ->
+      Tacticals.New.tclTHENS3PARTS (interp_tactic ist t1)
 	(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)
-  | TacRepeat tac -> tclREPEAT (interp_tactic ist tac)
+  | TacDo (n,tac) -> Tacticals.New.tclDO (interp_int_or_var ist n) (interp_tactic ist tac)
+  | TacTimeout (n,tac) -> Tacticals.New.tclTIMEOUT (interp_int_or_var ist n) (interp_tactic ist tac)
+  | TacTime (s,tac) -> Tacticals.New.tclTIME s (interp_tactic ist tac)
+  | TacTry tac -> Tacticals.New.tclTRY (interp_tactic ist tac)
+  | TacRepeat tac -> Tacticals.New.tclREPEAT (interp_tactic ist tac)
+  | TacOr (tac1,tac2) ->
+      Tacticals.New.tclOR (interp_tactic ist tac1) (interp_tactic ist tac2)
+  | TacOnce tac ->
+      Tacticals.New.tclONCE (interp_tactic ist tac)
+  | TacExactlyOnce tac ->
+      Tacticals.New.tclEXACTLY_ONCE (interp_tactic ist tac)
+  | TacIfThenCatch (t,tt,te) ->
+      Tacticals.New.tclIFCATCH
+        (interp_tactic ist t)
+        (fun () -> interp_tactic ist tt)
+        (fun () -> interp_tactic ist te)
   | TacOrelse (tac1,tac2) ->
-        tclORELSE (interp_tactic ist tac1) (interp_tactic ist tac2)
-  | TacFirst l -> tclFIRST (List.map (interp_tactic ist) l)
-  | TacSolve l -> tclSOLVE (List.map (interp_tactic ist) l)
-  | TacComplete tac -> tclCOMPLETE (interp_tactic ist tac)
+      Tacticals.New.tclORELSE (interp_tactic ist tac1) (interp_tactic ist tac2)
+  | TacFirst l -> Tacticals.New.tclFIRST (List.map (interp_tactic ist) l)
+  | TacSolve l -> Tacticals.New.tclSOLVE (List.map (interp_tactic ist) l)
+  | TacComplete tac -> Tacticals.New.tclCOMPLETE (interp_tactic ist tac)
   | TacArg a -> interp_tactic ist (TacArg a)
   | TacInfo tac ->
       msg_warning
-	(str "The general \"info\" tactic is currently not working.\n" ++
-	 str "Some specific verbose tactics may exist instead, such as\n" ++
-	 str "info_trivial, info_auto, info_eauto.");
+	(strbrk "The general \"info\" tactic is currently not working." ++ spc()++
+           strbrk "There is an \"Info\" command to replace it." ++fnl () ++
+	   strbrk "Some specific verbose tactics may also exist, such as info_trivial, info_auto, info_eauto.");
       eval_tactic ist tac
-
-and force_vrec ist gl = function
-  | VRec (lfun,body) -> val_interp {ist with lfun = !lfun} gl body
-  | v -> project gl , v
-
-and interp_ltac_reference loc' mustbetac ist gl = function
+  (* For extensions *)
+  | TacAlias (loc,s,l) ->
+      let body = Tacenv.interp_alias s in
+      let rec f x = match genarg_tag x with
+      | QuantHypArgType | RedExprArgType
+      | ConstrWithBindingsArgType
+      | BindingsArgType
+      | OptArgType _ | PairArgType _ -> (** generic handler *)
+        Ftactic.nf_enter begin fun gl ->
+          let sigma = Proofview.Goal.sigma gl in
+          let env = Proofview.Goal.env gl in
+          let concl = Proofview.Goal.concl gl in
+          let goal = Proofview.Goal.goal gl in
+          let (sigma, arg) = interp_genarg ist env sigma concl goal x in
+          Ftactic.(lift (Proofview.Unsafe.tclEVARS sigma) <*> return arg)
+        end
+      | _ as tag -> (** Special treatment. TODO: use generic handler  *)
+        Ftactic.nf_enter begin fun gl ->
+          let sigma = Proofview.Goal.sigma gl in
+          let env = Proofview.Goal.env gl in
+          match tag with
+          | IntOrVarArgType ->
+              Ftactic.return (mk_int_or_var_value ist (out_gen (glbwit wit_int_or_var) x))
+          | IdentArgType ->
+              Ftactic.return (value_of_ident (interp_fresh_ident ist env sigma
+                                               (out_gen (glbwit wit_ident) x)))
+          | VarArgType ->
+              Ftactic.return (mk_hyp_value ist env sigma (out_gen (glbwit wit_var) x))
+          | GenArgType -> f (out_gen (glbwit wit_genarg) x)
+          | ConstrArgType ->
+              let (sigma,v) =
+                Tacmach.New.of_old (fun gl -> mk_constr_value ist gl (out_gen (glbwit wit_constr) x)) gl
+              in
+              Ftactic.(lift (Proofview.Unsafe.tclEVARS sigma) <*> return v)
+          | OpenConstrArgType ->
+              let (sigma,v) =
+                Tacmach.New.of_old (fun gl -> mk_open_constr_value ist gl (snd (out_gen (glbwit wit_open_constr) x))) gl in
+              Ftactic.(lift (Proofview.Unsafe.tclEVARS sigma) <*> return v)
+          | ConstrMayEvalArgType ->
+              let (sigma,c_interp) =
+                interp_constr_may_eval ist env sigma
+                  (out_gen (glbwit wit_constr_may_eval) x)
+              in
+              Ftactic.(lift (Proofview.Unsafe.tclEVARS sigma) <*> return (Value.of_constr c_interp))
+          | ListArgType ConstrArgType ->
+              let wit = glbwit (wit_list wit_constr) in
+              let (sigma,l_interp) = Tacmach.New.of_old begin fun gl ->
+                Evd.MonadR.List.map_right
+                  (fun c sigma -> mk_constr_value ist { gl with sigma=sigma } c)
+                  (out_gen wit x)
+                  (project gl)
+              end gl in
+              Ftactic.(lift (Proofview.Unsafe.tclEVARS sigma) <*> return (in_gen (topwit (wit_list wit_genarg)) l_interp))
+          | ListArgType VarArgType ->
+              let wit = glbwit (wit_list wit_var) in
+              Ftactic.return (
+                let ans = List.map (mk_hyp_value ist env sigma) (out_gen wit x) in
+                in_gen (topwit (wit_list wit_genarg)) ans
+              )
+          | ListArgType IntOrVarArgType ->
+              let wit = glbwit (wit_list wit_int_or_var) in
+              let ans = List.map (mk_int_or_var_value ist) (out_gen wit x) in
+              Ftactic.return (in_gen (topwit (wit_list wit_genarg)) ans)
+          | ListArgType IdentArgType ->
+              let wit = glbwit (wit_list wit_ident) in
+              let mk_ident x = value_of_ident (interp_fresh_ident ist env sigma x) in
+              let ans = List.map mk_ident (out_gen wit x) in
+              Ftactic.return (in_gen (topwit (wit_list wit_genarg)) ans)
+          | ListArgType t  ->
+              let open Ftactic in
+              let list_unpacker wit l =
+                let map x =
+                  f (in_gen (glbwit wit) x) >>= fun v ->
+                  Ftactic.return (out_gen (topwit wit) v)
+                in
+                Ftactic.List.map map (glb l) >>= fun l ->
+                Ftactic.return (in_gen (topwit (wit_list wit)) l)
+              in
+              list_unpack { list_unpacker } x
+          | ExtraArgType _ ->
+              (** Special treatment of tactics *)
+              if has_type x (glbwit wit_tactic) then
+                let tac = out_gen (glbwit wit_tactic) x in
+                val_interp ist tac
+              else
+                let goal = Proofview.Goal.goal gl in
+                let (newsigma,v) = Geninterp.generic_interp ist {Evd.it=goal;sigma} x in
+                Ftactic.(lift (Proofview.Unsafe.tclEVARS newsigma) <*> return v)
+          | _ -> assert false
+        end
+      in
+      let (>>=) = Ftactic.bind in
+      let interp_vars =
+        Ftactic.List.map (fun (x,v) -> f v >>= fun v -> Ftactic.return (x,v)) l
+      in
+      let addvar (x, v) accu = Id.Map.add x v accu in
+      let tac l =
+        let lfun = List.fold_right addvar l ist.lfun in
+        let trace = push_trace (loc,LtacNotationCall s) ist in
+        let ist = {
+          lfun = lfun;
+          extra = TacStore.set ist.extra f_trace trace; } in
+        val_interp ist body >>= fun v ->
+        Ftactic.lift (tactic_of_value ist v)
+      in
+      let tac =
+        Ftactic.with_env interp_vars >>= fun (env,l) ->
+        let name () = Pptactic.pr_tactic env (TacAlias(loc,s,l)) in
+        Proofview.Trace.name_tactic name (tac l)
+      (* spiwack: this use of name_tactic is not robust to a
+         change of implementation of [Ftactic]. In such a situation,
+         some more elaborate solution will have to be used. *)
+      in
+      Ftactic.run tac (fun () -> Proofview.tclUNIT ())
+
+  | TacML (loc,opn,l) when List.for_all global_genarg l ->
+      let trace = push_trace (loc,LtacMLCall tac) ist in
+      let ist = { ist with extra = TacStore.set ist.extra f_trace trace; } in
+      (* spiwack: a special case for tactics (from TACTIC EXTEND) when
+         every argument can be interpreted without a
+         [Proofview.Goal.nf_enter]. *)
+      let tac = Tacenv.interp_ml_tactic opn in
+      (* dummy values, will be ignored *)
+      let env = Environ.empty_env in
+      let sigma = Evd.empty in
+      let concl = Term.mkRel (-1) in
+      let goal = Evar.unsafe_of_int (-1) in
+      (* /dummy values *)
+      let args = List.map (fun a -> snd(interp_genarg ist env sigma concl goal a)) l in
+      let name () = Pptactic.pr_tactic env (TacML(loc,opn,args)) in
+      Proofview.Trace.name_tactic name
+        (catch_error_tac trace (tac args ist))
+  | TacML (loc,opn,l) ->
+      let trace = push_trace (loc,LtacMLCall tac) ist in
+      let ist = { ist with extra = TacStore.set ist.extra f_trace trace; } in
+      Proofview.Goal.nf_enter begin fun gl ->
+        let env = Proofview.Goal.env gl in
+        let goal_sigma = Proofview.Goal.sigma gl in
+        let concl = Proofview.Goal.concl gl in
+        let goal = Proofview.Goal.goal gl in
+        let tac = Tacenv.interp_ml_tactic opn in
+        let (sigma,args) =
+          Evd.MonadR.List.map_right
+            (fun a sigma -> interp_genarg ist env sigma concl goal a) l goal_sigma
+        in
+        Proofview.Unsafe.tclEVARS sigma <*>
+        let name () = Pptactic.pr_tactic env (TacML(loc,opn,args)) in
+        Proofview.Trace.name_tactic name
+          (catch_error_tac trace (tac args ist))
+      end
+
+and force_vrec ist v : typed_generic_argument Ftactic.t =
+  let v = Value.normalize v in
+  if has_type v (topwit wit_tacvalue) then
+    let v = to_tacvalue v in
+    match v with
+    | VRec (lfun,body) -> val_interp {ist with lfun = !lfun} body
+    | v -> Ftactic.return (of_tacvalue v)
+  else Ftactic.return v
+
+and interp_ltac_reference loc' mustbetac ist r : typed_generic_argument Ftactic.t =
+  match r with
   | ArgVar (loc,id) ->
-      let v = List.assoc id ist.lfun in
-      let (sigma,v) = force_vrec ist gl v in
+      let v =
+        try Id.Map.find id ist.lfun
+        with Not_found -> in_gen (topwit wit_var) id
+      in
+      Ftactic.bind (force_vrec ist v) begin fun v ->
       let v = propagate_trace ist loc id v in
-      sigma , if mustbetac then coerce_to_tactic loc id v else v
+      if mustbetac then Ftactic.return (coerce_to_tactic loc id v) else Ftactic.return v
+      end
   | ArgArg (loc,r) ->
       let ids = extract_ids [] ist.lfun in
-      let loc_info = ((if loc' = dloc then loc else loc'),LtacNameCall r) in
-      let ist =
-        { lfun=[]; debug=ist.debug; avoid_ids=ids;
-          trace = push_trace loc_info ist.trace } in
-      val_interp ist gl (lookup r)
-
-and interp_tacarg ist gl arg =
-  let evdref = ref (project gl) in
-  let v = match arg with
-    | TacVoid -> VVoid
-    | Reference r ->
-      let (sigma,v) = interp_ltac_reference dloc false ist gl r in
-      evdref := sigma;
-      v
-    | Integer n -> VInteger n
-    | IntroPattern ipat -> VIntroPattern (snd (interp_intro_pattern ist gl ipat))
-    | ConstrMayEval c ->
-      let (sigma,c_interp) = interp_constr_may_eval ist gl c in
-      evdref := sigma;
-      VConstr ([],c_interp)
-    | MetaIdArg (loc,_,id) -> assert false
-    | TacCall (loc,r,[]) ->
-      let (sigma,v) = interp_ltac_reference loc true ist gl r in
-      evdref := sigma;
-      v
-    | TacCall (loc,f,l) ->
-        let (sigma,fv) = interp_ltac_reference loc true ist gl f in
-	let (sigma,largs) =
-	  List.fold_right begin fun a (sigma',acc) ->
-	    let (sigma', a_interp) = interp_tacarg ist gl a in
-	    sigma' , a_interp::acc
-	  end l (sigma,[])
-	in
-	List.iter check_is_value largs;
-	let (sigma,v) = interp_app loc ist { gl with sigma=sigma } fv largs in
-	evdref:= sigma;
-	v
-    | TacExternal (loc,com,req,la) ->
-        let (sigma,la_interp) =
-	  List.fold_right begin fun a (sigma,acc) ->
-	    let (sigma,a_interp) = interp_tacarg ist {gl with sigma=sigma} a in
-	    sigma , a_interp::acc
-	  end la (project gl,[])
-	in
-        let (sigma,v) = interp_external loc ist { gl with sigma=sigma } com req la_interp in
-	evdref := sigma;
-	v
-    | TacFreshId l ->
-        let id = pf_interp_fresh_id ist gl l in
-	VIntroPattern (IntroIdentifier id)
-    | Tacexp t ->
-      let (sigma,v) = val_interp ist gl t in
-      evdref := sigma;
-      v
-    | TacDynamic(_,t) ->
-        let tg = (Dyn.tag t) in
-	if tg = "tactic" then
-          let (sigma,v) = val_interp ist gl (tactic_out t ist) in
-	  evdref := sigma;
-	  v
-	else if tg = "value" then
-          value_out t
-	else if tg = "constr" then
-        VConstr ([],constr_out t)
-	else
-          anomaly_loc (dloc, "Tacinterp.val_interp",
-		       (str "Unknown dynamic: <" ++ str (Dyn.tag t) ++ str ">"))
-  in
-  !evdref , v
+      let loc_info = ((if Loc.is_ghost loc' then loc else loc'),LtacNameCall r) in
+      let extra = TacStore.set ist.extra f_avoid_ids ids in 
+      let extra = TacStore.set extra f_trace (push_trace loc_info ist) in
+      let ist = { lfun = Id.Map.empty; extra = extra; } in
+      let appl = GlbAppl[r,[]] in
+      val_interp ~appl ist (Tacenv.interp_ltac r)
+
+and interp_tacarg ist arg : typed_generic_argument Ftactic.t =
+  match arg with
+  | TacGeneric arg ->
+      Ftactic.nf_enter begin fun gl ->
+        let sigma = Proofview.Goal.sigma gl in
+        let goal = Proofview.Goal.goal gl in
+        let (sigma,v) = Geninterp.generic_interp ist {Evd.it=goal;sigma} arg in
+        Ftactic.(lift (Proofview.Unsafe.tclEVARS sigma) <*> return v)
+      end
+  | Reference r -> interp_ltac_reference dloc false ist r
+  | ConstrMayEval c ->
+      Ftactic.enter begin fun gl ->
+        let sigma = Proofview.Goal.sigma gl in
+        let env = Proofview.Goal.env gl in
+        let (sigma,c_interp) = interp_constr_may_eval ist env sigma c in
+        Ftactic.(lift (Proofview.Unsafe.tclEVARS sigma) <*> return (Value.of_constr c_interp))
+      end
+  | UConstr c ->
+      Ftactic.enter begin fun gl ->
+        let env = Proofview.Goal.env gl in
+        Ftactic.return (Value.of_uconstr (interp_uconstr ist env c))
+      end
+  | MetaIdArg (loc,_,id) -> assert false
+  | TacCall (loc,r,[]) ->
+      interp_ltac_reference loc true ist r
+  | TacCall (loc,f,l) ->
+      let (>>=) = Ftactic.bind in
+      interp_ltac_reference loc true ist f >>= fun fv ->
+      Ftactic.List.map (fun a -> interp_tacarg ist a) l >>= fun largs ->
+      interp_app loc ist fv largs
+  | TacFreshId l ->
+      Ftactic.enter begin fun gl ->
+        let id = interp_fresh_id ist (Tacmach.New.pf_env gl) (Proofview.Goal.sigma gl) l in
+        Ftactic.return (in_gen (topwit wit_intro_pattern) (dloc, IntroNaming (IntroIdentifier id)))
+      end
+  | TacPretype c ->
+      Ftactic.enter begin fun gl ->
+        let sigma = Proofview.Goal.sigma gl in
+        let env = Proofview.Goal.env gl in
+        let {closure;term} = interp_uconstr ist env c in
+        let vars = {
+          Pretyping.ltac_constrs = closure.typed;
+          Pretyping.ltac_uconstrs = closure.untyped;
+          Pretyping.ltac_idents = closure.idents;
+          Pretyping.ltac_genargs = ist.lfun;
+        } in
+        let (sigma,c_interp) =
+          Pretyping.understand_ltac constr_flags env sigma vars WithoutTypeConstraint term
+        in
+        Ftactic.(lift (Proofview.Unsafe.tclEVARS sigma) <*> return (Value.of_constr c_interp))
+      end
+  | TacNumgoals ->
+      Ftactic.lift begin
+        let open Proofview.Notations in
+        Proofview.numgoals >>= fun i ->
+        Proofview.tclUNIT (Value.of_int i)
+      end
+  | Tacexp t -> val_interp ist t
+  | TacDynamic(_,t) ->
+      let tg = (Dyn.tag t) in
+      if String.equal tg "tactic" then
+        val_interp ist (tactic_out t ist)
+      else if String.equal tg "value" then
+        Ftactic.return (value_out t)
+      else if String.equal tg "constr" then
+        Ftactic.return (Value.of_constr (constr_out t))
+      else
+        Errors.anomaly ~loc:dloc ~label:"Tacinterp.val_interp"
+	  (str "Unknown dynamic: <" ++ str (Dyn.tag t) ++ str ">")
 
 (* Interprets an application node *)
-and interp_app loc ist gl fv largs =
-  match fv with
+and interp_app loc ist fv largs : typed_generic_argument Ftactic.t =
+  let (>>=) = Ftactic.bind in
+  let fail = Tacticals.New.tclZEROMSG (str "Illegal tactic application.") in
+  let fv = Value.normalize fv in
+  if has_type fv (topwit wit_tacvalue) then
+  match to_tacvalue fv with
      (* if var=[] and body has been delayed by val_interp, then body
          is not a tactic that expects arguments.
          Otherwise Ltac goes into an infinite loop (val_interp puts
          a VFun back on body, and then interp_app is called again...) *)
-    | (VFun(trace,olfun,(_::_ as var),body)
-      |VFun(trace,olfun,([] as var),
+    | (VFun(appl,trace,olfun,(_::_ as var),body)
+      |VFun(appl,trace,olfun,([] as var),
          (TacFun _|TacLetIn _|TacMatchGoal _|TacMatch _| TacArg _ as body))) ->
-	let (newlfun,lvar,lval)=head_with_value (var,largs) in
-	if lvar=[] then
-	  let (sigma,v) =
-	    try
-	      catch_error trace
-		(val_interp {ist with lfun=newlfun@olfun; trace=trace} gl) body
-	    with reraise ->
-              debugging_exception_step ist false reraise
-                (fun () -> str "evaluation");
-	      raise reraise
-          in
-	  let gl = { gl with sigma=sigma } in
+	let (extfun,lvar,lval)=head_with_value (var,largs) in
+        let fold accu (id, v) = Id.Map.add id v accu in
+	let newlfun = List.fold_left fold olfun extfun in
+      if List.is_empty lvar then
+        begin Proofview.tclORELSE
+            begin
+              let ist = {
+                lfun = newlfun;
+                extra = TacStore.set ist.extra f_trace []; } in
+              catch_error_tac trace (val_interp ist body) >>= fun v ->
+              Ftactic.return (name_vfun (push_appl appl largs) v)
+            end
+	    begin fun (e, info) ->
+              Proofview.tclLIFT (debugging_exception_step ist false e (fun () -> str "evaluation")) <*>
+	      Proofview.tclZERO ~info e
+            end
+        end >>= fun v ->
+        (* No errors happened, we propagate the trace *)
+        let v = append_trace trace v in
+        Proofview.tclLIFT begin
           debugging_step ist
 	    (fun () ->
-	       str"evaluation returns"++fnl()++pr_value (Some (pf_env gl)) v);
-          if lval=[] then sigma,v else interp_app loc ist gl v lval
-	else
-          project gl , VFun(trace,newlfun@olfun,lvar,body)
-    | _ ->
-	user_err_loc (loc, "Tacinterp.interp_app",
-          (str"Illegal tactic application."))
+	      str"evaluation returns"++fnl()++pr_value None v)
+        end <*>
+        if List.is_empty lval then Ftactic.return v else interp_app loc ist v lval
+      else
+        Ftactic.return (of_tacvalue (VFun(push_appl appl largs,trace,newlfun,lvar,body)))
+    | _ -> fail
+  else fail
 
 (* Gives the tactic corresponding to the tactic value *)
-and tactic_of_value ist vle g =
-  match vle with
-  | VRTactic res -> res
-  | VFun (trace,lfun,[],t) ->
-      let tac = eval_tactic {ist with lfun=lfun; trace=trace} t in
-      catch_error trace tac g
-  | (VFun _|VRec _) -> error "A fully applied tactic is expected."
-  | VConstr _ -> errorlabstrm "" (str"Value is a term. Expected a tactic.")
-  | VConstr_context _ ->
-      errorlabstrm "" (str"Value is a term context. Expected a tactic.")
-  | VIntroPattern _ ->
-      errorlabstrm "" (str"Value is an intro pattern. Expected a tactic.")
-  | _ -> errorlabstrm "" (str"Expression does not evaluate to a tactic.")
-
-(* Evaluation with FailError catching *)
-and eval_with_fail ist is_lazy goal tac =
-  try
-    let (sigma,v) = val_interp ist goal tac in
-    sigma ,
-    (match v with
-    | VFun (trace,lfun,[],t) when not is_lazy ->
-	let tac = eval_tactic {ist with lfun=lfun; trace=trace} t in
-	VRTactic (catch_error trace tac { goal with sigma=sigma })
-    | a -> a)
-  with
-    | 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))
-    | 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'))))
+and tactic_of_value ist vle =
+  let vle = Value.normalize vle in
+  if has_type vle (topwit wit_tacvalue) then
+  match to_tacvalue vle with
+  | VFun (appl,trace,lfun,[],t) ->
+      let ist = {
+        lfun = lfun;
+        extra = TacStore.set ist.extra f_trace []; } in
+      let tac = name_if_glob appl (eval_tactic ist t) in
+      catch_error_tac trace tac
+  | (VFun _|VRec _) -> Proofview.tclZERO (UserError ("" , str "A fully applied tactic is expected."))
+  else if has_type vle (topwit wit_tactic) then
+    let tac = out_gen (topwit wit_tactic) vle in
+    eval_tactic ist tac
+  else Proofview.tclZERO (UserError ("" , str"Expression does not evaluate to a tactic."))
 
 (* Interprets the clauses of a recursive LetIn *)
-and interp_letrec ist gl llc u =
+and interp_letrec ist llc u =
+  Proofview.tclUNIT () >>= fun () -> (* delay for the effects of [lref], just in case. *)
   let lref = ref ist.lfun 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
+  let fold accu ((_, id), b) =
+    let v = of_tacvalue (VRec (lref, TacArg (dloc, b))) in
+    Id.Map.add id v accu
+  in
+  let lfun = List.fold_left fold ist.lfun llc in
+  let () = lref := lfun in
+  let ist = { ist with lfun } in
+  val_interp ist u
 
 (* Interprets the clauses of a LetIn *)
-and interp_letin ist gl llc u =
-  let (sigma,lve) =
-    List.fold_right begin fun ((_,id),body) (sigma,acc) ->
-      let (sigma,v) = interp_tacarg ist { gl with sigma=sigma } body in
-      check_is_value v;
-      sigma, (id,v)::acc
-    end llc (project gl,[])
+and interp_letin ist llc u =
+  let rec fold lfun = function
+  | [] ->
+    let ist = { ist with lfun } in
+    val_interp ist u
+  | ((_, id), body) :: defs ->
+    Ftactic.bind (interp_tacarg ist body) (fun v ->
+    fold (Id.Map.add id v lfun) defs)
   in
-  let ist = { ist with lfun = lve@ist.lfun } in
-  val_interp ist { gl with sigma=sigma } u
+  fold ist.lfun llc
+
+(** [interp_match_success lz ist succ] interprets a single matching success
+    (of type {!Tactic_matching.t}). *)
+and interp_match_success ist { Tactic_matching.subst ; context ; terms ; lhs } =
+  let (>>=) = Ftactic.bind in
+  let lctxt = Id.Map.map interp_context context in
+  let hyp_subst = Id.Map.map Value.of_constr terms in
+  let lfun = extend_values_with_bindings subst (lctxt +++ hyp_subst +++ ist.lfun) in
+  let ist = { ist with lfun } in
+  val_interp ist lhs >>= fun v ->
+  if has_type v (topwit wit_tacvalue) then match to_tacvalue v with
+  | VFun (appl,trace,lfun,[],t) ->
+      let ist = {
+        lfun = lfun;
+        extra = TacStore.set ist.extra f_trace trace; } in
+      let tac = eval_tactic ist t in
+      let dummy = VFun (appl,extract_trace ist, Id.Map.empty, [], TacId []) in
+      catch_error_tac trace (tac <*> Ftactic.return (of_tacvalue dummy))
+  | _ -> Ftactic.return v
+  else Ftactic.return v
+
+
+(** [interp_match_successes lz ist s] interprets the stream of
+    matching of successes [s]. If [lz] is set to true, then only the
+    first success is considered, otherwise further successes are tried
+    if the left-hand side fails. *)
+and interp_match_successes lz ist s =
+   let general =
+     let break (e, info) = match e with
+       | FailError (0, _) -> None
+       | FailError (n, s) -> Some (FailError (pred n, s), info)
+       | _ -> None
+     in
+     Proofview.tclBREAK break s >>= fun ans -> interp_match_success ist ans
+   in
+    match lz with
+    | General ->
+        general
+    | Select ->
+      begin
+        (** Only keep the first matching result, we don't backtrack on it *)
+        let s = Proofview.tclONCE s in
+        s >>= fun ans -> interp_match_success ist ans
+      end
+    | Once ->
+        (** Once a tactic has succeeded, do not backtrack anymore *)
+        Proofview.tclONCE general
+
+(* Interprets the Match expressions *)
+and interp_match ist lz constr lmr =
+  let (>>=) = Ftactic.bind in
+  begin Proofview.tclORELSE
+    (interp_ltac_constr ist constr)
+    begin function
+      | (e, info) ->
+          Proofview.tclLIFT (debugging_exception_step ist true e
+          (fun () -> str "evaluation of the matched expression")) <*>
+          Proofview.tclZERO ~info e
+    end
+  end >>= fun constr ->
+  Ftactic.enter begin fun gl ->
+    let sigma = Proofview.Goal.sigma gl in
+    let env = Proofview.Goal.env gl in
+    let ilr = read_match_rule (extract_ltac_constr_values ist env) ist env sigma lmr in
+    interp_match_successes lz ist (Tactic_matching.match_term env sigma constr ilr)
+  end
 
 (* 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
-  let env = pf_env goal in
-  let rec apply_goal_sub app ist (id,c) csr mt mhyps hyps =
-    let rec match_next_pattern find_next () =
-      let (lgoal,ctxt,find_next') = find_next () in
-      let lctxt = give_context ctxt id in
-      try apply_hyps_context ist env lz goal mt lctxt (adjust lgoal) mhyps hyps
-      with e when is_match_catchable e -> match_next_pattern find_next' () in
-    match_next_pattern (fun () -> match_subterm_gen app c csr) () in
-  let rec apply_match_goal ist env goal nrs lex lpt =
-    begin
-      if lex<>[] then db_pattern_rule ist.debug nrs (List.hd lex);
-      match lpt with
-	| (All t)::tl ->
-	    begin
-              db_mc_pattern_success ist.debug;
-              try eval_with_fail ist lz goal t
-              with e when is_match_catchable e ->
-		apply_match_goal ist env goal (nrs+1) (List.tl lex) tl
-	    end
-	| (Pat (mhyps,mgoal,mt))::tl ->
-            let mhyps = List.rev mhyps (* Sens naturel *) in
-	    (match mgoal with
-             | Term mg ->
-		 (try
-		     let lmatch = extended_matches mg concl in
-		     db_matched_concl ist.debug env concl;
-		     apply_hyps_context ist env lz goal mt [] lmatch mhyps hyps
-		   with e when is_match_catchable e ->
-		     (match e with
-		       | PatternMatchingFailure -> db_matching_failure ist.debug
-		       | Eval_fail s -> db_eval_failure ist.debug s
-		       | _ -> db_logic_failure ist.debug e);
-		     apply_match_goal ist env goal (nrs+1) (List.tl lex) tl)
-	     | Subterm (b,id,mg) ->
-		 (try apply_goal_sub b ist (id,mg) concl mt mhyps hyps
-		   with
-		     | PatternMatchingFailure ->
-			 apply_match_goal ist env goal (nrs+1) (List.tl lex) tl))
-	| _ ->
-	    errorlabstrm "Tacinterp.apply_match_goal"
-              (v 0 (str "No matching clauses for match goal" ++
-		      (if ist.debug=DebugOff then
-			 fnl() ++ str "(use \"Set Ltac Debug\" for more info)"
-		       else mt()) ++ str"."))
-    end in
-    apply_match_goal ist env goal 0 lmr
-      (read_match_rule (fst (extract_ltac_constr_values ist env))
-	ist env (project goal) lmr)
-
-(* Tries to match the hypotheses in a Match Context *)
-and apply_hyps_context ist env lz goal mt lctxt lgmatch mhyps hyps =
-  let rec apply_hyps_context_rec lfun lmatch lhyps_rest = function
-    | hyp_pat::tl ->
-	let (hypname, _, _ as hyp_pat) =
-	  match hyp_pat with
-	  | Hyp ((_,hypname),mhyp) -> hypname,  None, mhyp
-	  | Def ((_,hypname),mbod,mhyp) -> hypname, Some mbod, mhyp
-	in
-        let rec match_next_pattern find_next =
-          let (lids,lm,hyp_match,find_next') = find_next () in
-          db_matched_hyp ist.debug (pf_env goal) hyp_match hypname;
-	  try
-            let id_match = pi1 hyp_match in
-            let nextlhyps = list_remove_assoc_in_triple id_match lhyps_rest in
-            apply_hyps_context_rec (lfun@lids) lm nextlhyps tl
-          with e when is_match_catchable e ->
-	    match_next_pattern find_next' in
-        let init_match_pattern () =
-          apply_one_mhyp_context ist env goal lmatch hyp_pat lhyps_rest in
-        match_next_pattern init_match_pattern
-    | [] ->
-        let lfun = extend_values_with_bindings lmatch (lfun@ist.lfun) in
-        db_mc_pattern_success ist.debug;
-        eval_with_fail {ist with lfun=lfun} lz goal mt
-  in
-  apply_hyps_context_rec lctxt lgmatch hyps mhyps
-
-and interp_external loc ist gl com req la =
-  let f ch = extern_request ch req gl la in
-  let g ch = internalise_tacarg ch in
-  interp_tacarg ist gl (System.connect f g com)
-
-  (* Interprets extended tactic generic arguments *)
-and interp_genarg ist gl x =
-  let evdref = ref (project gl) in
-  let rec interp_genarg ist gl x =
-    let gl = { gl with sigma = !evdref } in
+and interp_match_goal ist lz lr lmr =
+    Ftactic.nf_enter begin fun gl ->
+      let sigma = Proofview.Goal.sigma gl in
+      let env = Proofview.Goal.env gl in
+      let hyps = Proofview.Goal.hyps gl in
+      let hyps = if lr then List.rev hyps else hyps in
+      let concl = Proofview.Goal.concl gl in
+      let ilr = read_match_rule (extract_ltac_constr_values ist env) ist env sigma lmr in
+      interp_match_successes lz ist (Tactic_matching.match_goal env sigma hyps concl ilr)
+    end
+
+(* Interprets extended tactic generic arguments *)
+(* spiwack: interp_genarg has an argument [concl] for the case of
+   "casted open constr". And [gl] for [Geninterp]. I haven't changed
+   the interface for geninterp yet as it is used by ARGUMENT EXTEND
+   (in turn used by plugins). At the time I'm writing this comment
+   though, the only concerned plugins are the declarative mode (which
+   needs the [extra] field of goals to interprete rules) and ssreflect
+   (a handful of time). I believe we'd need to address "casted open
+   constr" and the declarative mode rules to provide a reasonable
+   interface. *)
+and interp_genarg ist env sigma concl gl x =
+  let evdref = ref sigma in
+  let rec interp_genarg x =
     match genarg_tag x with
-    | BoolArgType -> in_gen wit_bool (out_gen globwit_bool x)
-    | IntArgType -> in_gen wit_int (out_gen globwit_int x)
     | IntOrVarArgType ->
-      in_gen wit_int_or_var
-        (ArgArg (interp_int_or_var ist (out_gen globwit_int_or_var x)))
-    | StringArgType ->
-      in_gen wit_string (out_gen globwit_string x)
-    | PreIdentArgType ->
-      in_gen wit_pre_ident (out_gen globwit_pre_ident x)
-    | IntroPatternArgType ->
-      in_gen wit_intro_pattern
-        (interp_intro_pattern ist gl (out_gen globwit_intro_pattern x))
-    | IdentArgType b ->
-      in_gen (wit_ident_gen b)
-        (pf_interp_fresh_ident ist gl (out_gen (globwit_ident_gen b) x))
+      in_gen (topwit wit_int_or_var)
+        (ArgArg (interp_int_or_var ist (out_gen (glbwit wit_int_or_var) x)))
+    | IdentArgType ->
+      in_gen (topwit wit_ident)
+        (interp_fresh_ident ist env sigma (out_gen (glbwit wit_ident) x))
     | VarArgType ->
-      in_gen wit_var (interp_hyp ist gl (out_gen globwit_var x))
-    | RefArgType ->
-      in_gen wit_ref (pf_interp_reference ist gl (out_gen globwit_ref x))
-    | SortArgType ->
+      in_gen (topwit wit_var) (interp_hyp ist env sigma (out_gen (glbwit wit_var) x))
+    | GenArgType ->
+      in_gen (topwit wit_genarg) (interp_genarg (out_gen (glbwit wit_genarg) x))
+    | ConstrArgType ->
       let (sigma,c_interp) =
-	pf_interp_constr ist gl
-	  (GSort (dloc,out_gen globwit_sort x), None)
+        interp_constr ist env !evdref (out_gen (glbwit wit_constr) x)
       in
       evdref := sigma;
-      in_gen wit_sort
-        (destSort c_interp)
-    | ConstrArgType ->
-      let (sigma,c_interp) = pf_interp_constr ist gl (out_gen globwit_constr x) in
-      evdref := sigma;
-      in_gen wit_constr c_interp
+      in_gen (topwit wit_constr) c_interp
     | ConstrMayEvalArgType ->
-      let (sigma,c_interp) = interp_constr_may_eval ist gl (out_gen globwit_constr_may_eval x) in
+      let (sigma,c_interp) = interp_constr_may_eval ist env !evdref (out_gen (glbwit wit_constr_may_eval) x) in
       evdref := sigma;
-      in_gen wit_constr_may_eval c_interp
+      in_gen (topwit wit_constr_may_eval) c_interp
     | QuantHypArgType ->
-      in_gen wit_quant_hyp
-        (interp_declared_or_quantified_hypothesis ist gl
-           (out_gen globwit_quant_hyp x))
+      in_gen (topwit wit_quant_hyp)
+        (interp_declared_or_quantified_hypothesis ist env sigma
+           (out_gen (glbwit wit_quant_hyp) x))
     | RedExprArgType ->
-      let (sigma,r_interp) = pf_interp_red_expr ist gl (out_gen globwit_red_expr x) in
+      let (sigma,r_interp) =
+        interp_red_expr ist env !evdref (out_gen (glbwit wit_red_expr) x)
+      in
       evdref := sigma;
-      in_gen wit_red_expr r_interp
-    | OpenConstrArgType (casted,wTC) ->
-      in_gen (wit_open_constr_gen (casted,wTC))
-        (interp_open_constr (if casted then Some (pf_concl gl) else None) wTC
-           ist (pf_env gl) (project gl)
-           (snd (out_gen (globwit_open_constr_gen (casted,wTC)) x)))
+      in_gen (topwit wit_red_expr) r_interp
+    | OpenConstrArgType ->
+      let expected_type = WithoutTypeConstraint in
+      in_gen (topwit wit_open_constr)
+        (interp_open_constr ~expected_type
+           ist env !evdref
+           (snd (out_gen (glbwit wit_open_constr) x)))
     | ConstrWithBindingsArgType ->
-      in_gen wit_constr_with_bindings
-        (pack_sigma (interp_constr_with_bindings ist (pf_env gl) (project gl)
-		       (out_gen globwit_constr_with_bindings x)))
+      in_gen (topwit wit_constr_with_bindings)
+        (pack_sigma (interp_constr_with_bindings ist env !evdref
+		       (out_gen (glbwit wit_constr_with_bindings) x)))
     | BindingsArgType ->
-      in_gen wit_bindings
-        (pack_sigma (interp_bindings ist (pf_env gl) (project gl) (out_gen globwit_bindings x)))
-    | List0ArgType ConstrArgType ->
-        let (sigma,v) = interp_genarg_constr_list0 ist gl x in
-	evdref := sigma;
-	v
-    | List1ArgType ConstrArgType ->
-        let (sigma,v) = interp_genarg_constr_list1 ist gl x in
+      in_gen (topwit wit_bindings)
+        (pack_sigma (interp_bindings ist env !evdref (out_gen (glbwit wit_bindings) x)))
+    | ListArgType ConstrArgType ->
+        let (sigma,v) = interp_genarg_constr_list ist env !evdref x in
 	evdref := sigma;
 	v
-    | List0ArgType VarArgType -> interp_genarg_var_list0 ist gl x
-    | List1ArgType VarArgType -> interp_genarg_var_list1 ist gl x
-    | List0ArgType _ -> app_list0 (interp_genarg ist gl) x
-    | List1ArgType _ -> app_list1 (interp_genarg ist gl) x
-    | OptArgType _ -> app_opt (interp_genarg ist gl) x
-    | PairArgType _ -> app_pair (interp_genarg ist gl) (interp_genarg ist gl) x
+    | ListArgType VarArgType -> interp_genarg_var_list ist env sigma x
+    | ListArgType _ ->
+      let list_unpacker wit l =
+        let map x =
+          out_gen (topwit wit) (interp_genarg (in_gen (glbwit wit) x))
+        in
+        in_gen (topwit (wit_list wit)) (List.map map (glb l))
+      in
+      list_unpack { list_unpacker } x
+    | OptArgType _ ->
+      let opt_unpacker wit o = match glb o with
+      | None -> in_gen (topwit (wit_opt wit)) None
+      | Some x ->
+        let x = out_gen (topwit wit) (interp_genarg (in_gen (glbwit wit) x)) in
+        in_gen (topwit (wit_opt wit)) (Some x)
+      in
+      opt_unpack { opt_unpacker } x
+    | PairArgType _ ->
+      let pair_unpacker wit1 wit2 o =
+        let (p, q) = glb o in
+        let p = out_gen (topwit wit1) (interp_genarg (in_gen (glbwit wit1) p)) in
+        let q = out_gen (topwit wit2) (interp_genarg (in_gen (glbwit wit2) q)) in
+        in_gen (topwit (wit_pair wit1 wit2)) (p, q)
+      in
+      pair_unpack { pair_unpacker } x
     | ExtraArgType s ->
-      match tactic_genarg_level s with
-      | Some n ->
-          (* Special treatment of tactic arguments *)
-        in_gen (wit_tactic n)
-	  (TacArg(dloc,valueIn(VFun(ist.trace,ist.lfun,[],
-				    out_gen (globwit_tactic n) x))))
-      | None ->
-        let (sigma,v) = lookup_interp_genarg s ist gl x in
+        let (sigma,v) = Geninterp.generic_interp ist { Evd.it=gl;sigma=(!evdref) } x in
 	evdref:=sigma;
 	v
   in
-  let v = interp_genarg ist gl x in
+  let v = interp_genarg x in
   !evdref , v
 
-and interp_genarg_constr_list0 ist gl x =
-  let lc = out_gen (wit_list0 globwit_constr) x in
-  let (sigma,lc) = pf_apply (interp_constr_list ist) gl lc in
-  sigma , in_gen (wit_list0 wit_constr) lc
 
-and interp_genarg_constr_list1 ist gl x =
-  let lc = out_gen (wit_list1 globwit_constr) x in
-  let (sigma,lc) = pf_apply (interp_constr_list ist) gl lc in
-  sigma , in_gen (wit_list1 wit_constr) lc
+(** returns [true] for genargs which have the same meaning
+    independently of goals. *)
 
-and interp_genarg_var_list0 ist gl x =
-  let lc = out_gen (wit_list0 globwit_var) x in
-  let lc = interp_hyp_list ist gl lc in
-  in_gen (wit_list0 wit_var) lc
+and global_genarg =
+  let rec global_tag = function
+    | IntOrVarArgType | GenArgType -> true
+    | ListArgType t | OptArgType t -> global_tag t
+    | PairArgType (t1,t2) -> global_tag t1 && global_tag t2
+    | _ -> false
+  in
+  fun x -> global_tag (genarg_tag x)
 
-and interp_genarg_var_list1 ist gl x =
-  let lc = out_gen (wit_list1 globwit_var) x in
-  let lc = interp_hyp_list ist gl lc in
-  in_gen (wit_list1 wit_var) lc
+and interp_genarg_constr_list ist env sigma x =
+  let lc = out_gen (glbwit (wit_list wit_constr)) x in
+  let (sigma,lc) = interp_constr_list ist env sigma lc in
+  sigma , in_gen (topwit (wit_list wit_constr)) lc
 
-(* Interprets the Match expressions *)
-and interp_match ist g lz constr lmr =
-  let rec apply_match_subterm app ist (id,c) csr mt =
-    let rec match_next_pattern find_next () =
-      let (lmatch,ctxt,find_next') = find_next () in
-      let lctxt = give_context ctxt id in
-      let lfun = extend_values_with_bindings (adjust lmatch) (lctxt@ist.lfun) in
-      try eval_with_fail {ist with lfun=lfun} lz g mt
-      with e when is_match_catchable e ->
-        match_next_pattern find_next' () in
-    match_next_pattern (fun () -> match_subterm_gen app c csr) () in
-  let rec apply_match ist sigma csr = let g = { g with sigma=sigma } in function
-    | (All t)::tl ->
-        (try eval_with_fail ist lz g t
-         with e when is_match_catchable e -> apply_match ist sigma csr tl)
-    | (Pat ([],Term c,mt))::tl ->
-        (try
-            let lmatch =
-              try extended_matches c csr
-              with reraise ->
-                debugging_exception_step ist false reraise (fun () ->
-                  str "matching with pattern" ++ fnl () ++
-                  pr_constr_pattern_env (pf_env g) c);
-                raise reraise
-            in
-            try
-              let lfun = extend_values_with_bindings lmatch ist.lfun in
-              eval_with_fail { ist with lfun=lfun } lz g mt
-            with reraise ->
-              debugging_exception_step ist false reraise (fun () ->
-                str "rule body for pattern" ++
-                pr_constr_pattern_env (pf_env g) c);
-              raise reraise
-         with e when is_match_catchable e ->
-           debugging_step ist (fun () -> str "switching to the next rule");
-           apply_match ist sigma csr tl)
-
-    | (Pat ([],Subterm (b,id,c),mt))::tl ->
-        (try apply_match_subterm b ist (id,c) csr mt
-         with PatternMatchingFailure -> apply_match ist sigma csr tl)
-    | _ ->
-      errorlabstrm "Tacinterp.apply_match" (str
-        "No matching clauses for match.") in
-  let (sigma,csr) =
-      try interp_ltac_constr ist g constr with reraise ->
-        debugging_exception_step ist true reraise
-          (fun () -> str "evaluation of the matched expression");
-        raise reraise in
-  let ilr = read_match_rule (fst (extract_ltac_constr_values ist (pf_env g))) ist (pf_env g) sigma lmr in
-  let res =
-     try apply_match ist sigma csr ilr with reraise ->
-       debugging_exception_step ist true reraise
-         (fun () -> str "match expression");
-       raise reraise in
-  debugging_step ist (fun () ->
-    str "match expression returns " ++ pr_value (Some (pf_env g)) (snd res));
-  res
+and interp_genarg_var_list ist env sigma x =
+  let lc = out_gen (glbwit (wit_list wit_var)) x in
+  let lc = interp_hyp_list ist env sigma lc in
+  in_gen (topwit (wit_list wit_var)) lc
 
 (* Interprets tactic expressions : returns a "constr" *)
-and interp_ltac_constr ist gl e =
-  let (sigma, result) =
-  try val_interp ist gl e with Not_found ->
-    debugging_step ist (fun () ->
-      str "evaluation failed for" ++ fnl() ++
-      Pptactic.pr_glob_tactic (pf_env gl) e);
-    raise Not_found in
+and interp_ltac_constr ist e : constr Ftactic.t =
+  let (>>=) = Ftactic.bind in
+  begin Proofview.tclORELSE
+      (val_interp ist e)
+      begin function (err, info) -> match err with
+        | Not_found ->
+            Ftactic.enter begin fun gl ->
+              let env = Proofview.Goal.env gl in
+              Proofview.tclLIFT begin
+                debugging_step ist (fun () ->
+                  str "evaluation failed for" ++ fnl() ++
+                    Pptactic.pr_glob_tactic env e)
+              end
+            <*> Proofview.tclZERO Not_found
+            end
+        | err -> Proofview.tclZERO ~info err
+      end
+  end >>= fun result ->
+  Ftactic.enter begin fun gl ->
+  let env = Proofview.Goal.env gl in
+  let sigma = Proofview.Goal.sigma gl in
+  let result = Value.normalize result in
   try
-    let cresult = constr_of_value (pf_env gl) result in
-    debugging_step ist (fun () ->
-      Pptactic.pr_glob_tactic (pf_env gl) e ++ fnl() ++
-      str " has value " ++ fnl() ++
-      pr_constr_under_binders_env (pf_env gl) cresult);
-    if fst cresult <> [] then raise Not_found;
-    sigma , snd cresult
-  with Not_found ->
-    errorlabstrm ""
+    let cresult = coerce_to_closed_constr env result in
+    Proofview.tclLIFT begin
+      debugging_step ist (fun () ->
+        Pptactic.pr_glob_tactic env e ++ fnl() ++
+          str " has value " ++ fnl() ++
+          pr_constr_env env sigma cresult)
+    end <*>
+    Ftactic.return cresult
+  with CannotCoerceTo _ ->
+    let env = Proofview.Goal.env gl in
+    Proofview.tclZERO (UserError ( "",
+      errorlabstrm ""
       (str "Must evaluate to a closed term" ++ fnl() ++
-	  str "offending expression: " ++ fnl() ++
-          Pptactic.pr_glob_tactic (pf_env gl) e ++ fnl() ++ str "this is a " ++
-          (match result with
-            | VRTactic _ -> str "VRTactic"
-            | VFun (_,il,ul,b) ->
-                (str "VFun with body " ++ fnl() ++
-                    Pptactic.pr_glob_tactic (pf_env gl) b ++ fnl() ++
-		    str "instantiated arguments " ++ fnl() ++
-                    List.fold_right
-                    (fun p s ->
-                      let (i,v) = p in str (string_of_id i) ++ str ", " ++ s)
-                    il (str "") ++
-                    str "uninstantiated arguments " ++ fnl() ++
-                    List.fold_right
-                    (fun opt_id s ->
-                      (match opt_id with
-                          Some id -> str (string_of_id id)
-                        | None -> str "_") ++ str ", " ++ s)
-                    ul (mt()))
-            | VVoid -> str "VVoid"
-            | VInteger _ -> str "VInteger"
-            | VConstr _ -> str "VConstr"
-            | VIntroPattern _ -> str "VIntroPattern"
-            | VConstr_context _ -> str "VConstrr_context"
-            | VRec _ -> str "VRec"
-            | VList _ -> str "VList") ++ str".")
+      str "offending expression: " ++ fnl() ++ pr_inspect env e result)))
+  end
+
 
 (* Interprets tactic expressions : returns a "tactic" *)
-and interp_tactic ist tac gl =
-  let (sigma,v) = val_interp ist gl tac in
-  tactic_of_value ist v { gl with sigma=sigma }
+and interp_tactic ist tac : unit Proofview.tactic =
+  Ftactic.run (val_interp ist tac) (fun v -> tactic_of_value ist v)
+
+(* Provides a "name" for the trace to atomic tactics *)
+and name_atomic ?env tacexpr tac : unit Proofview.tactic =
+  begin match env with
+  | Some e -> Proofview.tclUNIT e
+  | None -> Proofview.tclENV
+  end >>= fun env ->
+  let name () = Pptactic.pr_tactic env (TacAtom (Loc.ghost,tacexpr)) in
+  Proofview.Trace.name_tactic name tac
 
 (* Interprets a primitive tactic *)
-and interp_atomic ist gl tac =
-  let env = pf_env gl and sigma = project gl in
+and interp_atomic ist tac : unit Proofview.tactic =
   match tac with
   (* Basic tactics *)
   | TacIntroPattern l ->
-      h_intro_patterns (interp_intro_pattern_list_as_list ist gl l)
-  | TacIntrosUntil hyp ->
-      h_intros_until (interp_quantified_hypothesis ist hyp)
+      Proofview.Goal.enter begin fun gl ->
+        let env = Proofview.Goal.env gl in
+        let sigma = Proofview.Goal.sigma gl in
+        let sigma,l' = interp_intro_pattern_list_as_list ist env sigma l in
+        Proofview.Unsafe.tclEVARS sigma <*>
+        name_atomic ~env
+          (TacIntroPattern l)
+          (* spiwack: print uninterpreted, not sure if it is the
+             expected behaviour. *)
+          (Tactics.intros_patterns l')
+      end
   | TacIntroMove (ido,hto) ->
-      h_intro_move (Option.map (interp_fresh_ident ist env) ido)
-                   (interp_move_location ist gl hto)
-  | TacAssumption -> h_assumption
+      Proofview.Goal.enter begin fun gl ->
+        let env = Proofview.Goal.env gl in
+        let sigma = Proofview.Goal.sigma gl in
+        let mloc = interp_move_location ist env sigma hto in
+        let ido = Option.map (interp_fresh_ident ist env sigma) ido in
+        name_atomic ~env
+          (TacIntroMove(ido,mloc))
+          (Tactics.intro_move ido mloc)
+      end
   | TacExact c ->
-      let (sigma,c_interp) = pf_interp_casted_constr ist gl c in
-      tclTHEN
-	(tclEVARS sigma)
-	(h_exact c_interp)
-  | TacExactNoCheck c ->
-      let (sigma,c_interp) = pf_interp_constr ist gl c in
-      tclTHEN
-	(tclEVARS sigma)
-	(h_exact_no_check c_interp)
-  | TacVmCastNoCheck c ->
-      let (sigma,c_interp) = pf_interp_constr ist gl c in
-      tclTHEN
-	(tclEVARS sigma)
-	(h_vm_cast_no_check c_interp)
+      (* spiwack: until the tactic is in the monad *)
+      Proofview.Trace.name_tactic (fun () -> Pp.str"<exact>") begin
+      Proofview.V82.tactic begin fun gl -> 
+        let (sigma,c_interp) = pf_interp_casted_constr ist gl c in
+        tclTHEN
+	  (tclEVARS sigma)
+	  (Tactics.exact_no_check c_interp)
+          gl
+      end
+      end
   | TacApply (a,ev,cb,cl) ->
-      let sigma, l =
-        list_fold_map (interp_open_constr_with_bindings_loc true ist env) sigma cb
-      in
-      let tac = match cl with
-        | None -> h_apply a ev
-        | Some cl ->
-            (fun l -> h_apply_in a ev l (interp_in_hyp_as ist gl cl)) in
-      tclWITHHOLES ev tac sigma l
-  | TacElim (ev,cb,cbo) ->
-      let sigma, cb = interp_constr_with_bindings ist env sigma cb in
-      let sigma, cbo = Option.fold_map (interp_constr_with_bindings ist env) sigma cbo in
-      tclWITHHOLES ev (h_elim ev cb) sigma cbo
-  | TacElimType c ->
-      let (sigma,c_interp) = pf_interp_type ist gl c in
-      tclTHEN
-	(tclEVARS sigma)
-	(h_elim_type c_interp)
-  | TacCase (ev,cb) ->
-      let sigma, cb = interp_constr_with_bindings ist env sigma cb in
-      tclWITHHOLES ev (h_case ev) sigma cb
-  | TacCaseType c ->
-      let (sigma,c_interp) = pf_interp_type ist gl c in
-      tclTHEN
-	(tclEVARS sigma)
-	(h_case_type c_interp)
-  | TacFix (idopt,n) -> h_fix (Option.map (interp_fresh_ident ist env) idopt) n
-  | TacMutualFix (b,id,n,l) ->
-      let f sigma (id,n,c) =
-	let (sigma,c_interp) = pf_interp_type ist { gl with sigma=sigma } c in
-	sigma , (interp_fresh_ident ist env id,n,c_interp) in
-      let (sigma,l_interp) =
-	List.fold_right begin fun c (sigma,acc) ->
-	  let (sigma,c_interp) = f sigma c in
-	  sigma , c_interp::acc
-	end l (project gl,[])
-      in
-      tclTHEN
-	(tclEVARS sigma)
-	(h_mutual_fix b (interp_fresh_ident ist env id) n l_interp)
-  | TacCofix idopt -> h_cofix (Option.map (interp_fresh_ident ist env) idopt)
-  | TacMutualCofix (b,id,l) ->
-      let f sigma (id,c) =
-	let (sigma,c_interp) = pf_interp_type ist { gl with sigma=sigma } c in
-	sigma , (interp_fresh_ident ist env id,c_interp) in
-      let (sigma,l_interp) =
-	List.fold_right begin fun c (sigma,acc) ->
-	  let (sigma,c_interp) = f sigma c in
-	  sigma , c_interp::acc
-	end l (project gl,[])
-      in
-      tclTHEN
-	(tclEVARS sigma)
-	(h_mutual_cofix b (interp_fresh_ident ist env id) l_interp)
-  | TacCut c ->
-      let (sigma,c_interp) = pf_interp_type ist gl c in
-      tclTHEN
-	(tclEVARS sigma)
-	(h_cut c_interp)
-  | TacAssert (t,ipat,c) ->
-      let (sigma,c) = (if t=None then interp_constr else interp_type) ist env sigma c in
-      tclTHEN
-	(tclEVARS sigma)
-	(abstract_tactic (TacAssert (t,ipat,c))
-           (Tactics.forward (Option.map (interp_tactic ist) t)
-	      (Option.map (interp_intro_pattern ist gl) ipat) c))
+      (* spiwack: until the tactic is in the monad *)
+      Proofview.Trace.name_tactic (fun () -> Pp.str"<apply>") begin
+      Proofview.Goal.enter begin fun gl ->
+        let env = Proofview.Goal.env gl in
+        let sigma = Proofview.Goal.sigma gl in
+	let l = List.map (fun (k,c) ->
+          let loc, f = interp_open_constr_with_bindings_loc ist c in
+	    (k,(loc,f))) cb 
+	in
+        let sigma,tac = match cl with
+          | None -> sigma, fun l -> Tactics.apply_with_delayed_bindings_gen a ev l
+          | Some cl ->
+              let sigma,(clear,id,cl) = interp_in_hyp_as ist env sigma cl in
+              sigma, fun l -> Tactics.apply_delayed_in a ev clear id l cl in
+        Tacticals.New.tclWITHHOLES ev tac sigma l
+      end
+      end
+  | TacElim (ev,(keep,cb),cbo) ->
+      Proofview.Goal.enter begin fun gl ->
+        let env = Proofview.Goal.env gl in
+        let sigma = Proofview.Goal.sigma gl in 
+        let sigma, cb = interp_constr_with_bindings ist env sigma cb in
+        let sigma, cbo = Option.fold_map (interp_constr_with_bindings ist env) sigma cbo in
+        let named_tac cbo =
+          let tac = Tactics.elim ev keep cb cbo in
+          name_atomic ~env (TacElim (ev,(keep,cb),cbo)) tac
+        in
+        Tacticals.New.tclWITHHOLES ev named_tac sigma cbo
+      end
+  | TacCase (ev,(keep,cb)) ->
+      Proofview.Goal.enter begin fun gl ->
+        let sigma = Proofview.Goal.sigma gl in
+        let env = Proofview.Goal.env gl in
+        let sigma, cb = interp_constr_with_bindings ist env sigma cb in
+        let named_tac cb =
+          let tac = Tactics.general_case_analysis ev keep cb in
+          name_atomic ~env (TacCase(ev,(keep,cb))) tac
+        in
+        Tacticals.New.tclWITHHOLES ev named_tac sigma cb
+      end
+  | TacFix (idopt,n) ->
+      Proofview.Goal.enter begin fun gl ->
+        let env = Proofview.Goal.env gl in
+        let sigma = Proofview.Goal.sigma gl in
+        let idopt = Option.map (interp_fresh_ident ist env sigma) idopt in
+        name_atomic ~env
+          (TacFix(idopt,n))
+          (Proofview.V82.tactic (Tactics.fix idopt n))
+      end
+  | TacMutualFix (id,n,l) ->
+      (* spiwack: until the tactic is in the monad *)
+      Proofview.Trace.name_tactic (fun () -> Pp.str"<mutual fix>") begin
+      Proofview.V82.tactic begin fun gl ->
+        let env = pf_env gl in
+        let f sigma (id,n,c) =
+	  let (sigma,c_interp) = pf_interp_type ist { gl with sigma=sigma } c in
+	  sigma , (interp_fresh_ident ist env sigma id,n,c_interp) in
+        let (sigma,l_interp) =
+          Evd.MonadR.List.map_right (fun c sigma -> f sigma c) l (project gl)
+        in
+        tclTHEN
+	  (tclEVARS sigma)
+	  (Tactics.mutual_fix (interp_fresh_ident ist env sigma id) n l_interp 0)
+          gl
+      end
+      end
+  | TacCofix idopt ->
+      Proofview.Goal.enter begin fun gl ->
+        let env = Proofview.Goal.env gl in
+        let sigma = Proofview.Goal.sigma gl in
+        let idopt = Option.map (interp_fresh_ident ist env sigma) idopt in
+        name_atomic ~env
+          (TacCofix (idopt))
+          (Proofview.V82.tactic (Tactics.cofix idopt))
+      end
+  | TacMutualCofix (id,l) ->
+      (* spiwack: until the tactic is in the monad *)
+      Proofview.Trace.name_tactic (fun () -> Pp.str"<mutual cofix>") begin
+      Proofview.V82.tactic begin fun gl ->
+        let env = pf_env gl in
+        let f sigma (id,c) =
+	  let (sigma,c_interp) = pf_interp_type ist { gl with sigma=sigma } c in
+	  sigma , (interp_fresh_ident ist env sigma id,c_interp) in
+        let (sigma,l_interp) =
+          Evd.MonadR.List.map_right (fun c sigma -> f sigma c) l (project gl)
+        in
+        tclTHEN
+	  (tclEVARS sigma)
+	  (Tactics.mutual_cofix (interp_fresh_ident ist env sigma id) l_interp 0)
+          gl
+      end
+      end
+  | TacAssert (b,t,ipat,c) ->
+      Proofview.Goal.enter begin fun gl ->
+        let env = Proofview.Goal.env gl in
+        let sigma = Proofview.Goal.sigma gl in
+        let (sigma,c) = 
+          (if Option.is_empty t then interp_constr else interp_type) ist env sigma c
+        in
+        let sigma, ipat' = interp_intro_pattern_option ist env sigma ipat in
+        let tac = Option.map (interp_tactic ist) t in
+        Proofview.Unsafe.tclEVARS sigma <*>
+        name_atomic ~env
+          (TacAssert(b,t,ipat,c))
+          (Tactics.forward b tac ipat' c)
+      end
   | TacGeneralize cl ->
-      let sigma, cl = interp_constr_with_occurrences_and_name_as_list ist env sigma cl in
-      tclWITHHOLES false (h_generalize_gen) sigma cl
+      Proofview.Goal.enter begin fun gl ->
+        let sigma = Proofview.Goal.sigma gl in
+        let env = Proofview.Goal.env gl in
+        let sigma, cl = interp_constr_with_occurrences_and_name_as_list ist env sigma cl in
+        Proofview.Unsafe.tclEVARS sigma <*>
+        name_atomic ~env
+          (TacGeneralize cl)
+          (Proofview.V82.tactic (Tactics.Simple.generalize_gen cl))
+      end
   | TacGeneralizeDep c ->
-      let (sigma,c_interp) = pf_interp_constr ist gl c in
-      tclTHEN
-	(tclEVARS sigma)
-	(h_generalize_dep c_interp)
+      (new_interp_constr ist c) (fun c ->
+        name_atomic (* spiwack: probably needs a goal environment *)
+        (TacGeneralizeDep c)
+        (Proofview.V82.tactic (Tactics.generalize_dep c))
+       )
   | TacLetTac (na,c,clp,b,eqpat) ->
-      let clp = interp_clause ist gl clp in
-      let eqpat = Option.map (interp_intro_pattern ist gl) eqpat in
-      if clp = nowhere then
+      Proofview.V82.nf_evar_goals <*>
+      Proofview.Goal.nf_enter begin fun gl ->
+        let env = Proofview.Goal.env gl in
+        let sigma = Proofview.Goal.sigma gl in
+        let clp = interp_clause ist env sigma clp in
+        let eqpat = interp_intro_pattern_naming_option ist env sigma eqpat in
+        if Locusops.is_nowhere clp then
         (* We try to fully-typecheck the term *)
-	let (sigma,c_interp) = pf_interp_constr ist gl c in
-	tclTHEN
-	  (tclEVARS sigma)
-          (h_let_tac b (interp_fresh_name ist env na) c_interp clp eqpat)
-      else
+          let (sigma,c_interp) =
+            Tacmach.New.of_old (fun gl -> pf_interp_constr ist gl c) gl
+          in
+          let let_tac b na c cl eqpat =
+            let id = Option.default (Loc.ghost,IntroAnonymous) eqpat in
+            let with_eq = if b then None else Some (true,id) in
+            Tactics.letin_tac with_eq na c None cl
+          in
+	  Proofview.Unsafe.tclEVARS sigma <*>
+          let na = interp_fresh_name ist env sigma na in
+          name_atomic ~env
+            (TacLetTac(na,c_interp,clp,b,eqpat))
+            (let_tac b na c_interp clp eqpat)
+        else
         (* We try to keep the pattern structure as much as possible *)
-        h_let_pat_tac b (interp_fresh_name ist env na)
-          (interp_pure_open_constr ist env sigma c) clp eqpat
+          let let_pat_tac b na c cl eqpat =
+            let id = Option.default (Loc.ghost,IntroAnonymous) eqpat in
+            let with_eq = if b then None else Some (true,id) in
+            Tactics.letin_pat_tac with_eq na c cl
+          in
+          let (sigma',c) = interp_pure_open_constr ist env sigma c in
+          name_atomic ~env
+            (TacLetTac(na,c,clp,b,eqpat))
+	    (Tacticals.New.tclWITHHOLES false (*in hope of a future "eset/epose"*)
+               (let_pat_tac b (interp_fresh_name ist env sigma na)
+                  ((sigma,sigma'),c) clp) sigma' eqpat)
+      end
 
   (* Automation tactics *)
   | TacTrivial (debug,lems,l) ->
-      Auto.h_trivial ~debug
-	(interp_auto_lemmas ist env sigma lems)
-	(Option.map (List.map (interp_hint_base ist)) l)
+      Proofview.Goal.enter begin fun gl ->
+        let env = Proofview.Goal.env gl in
+        let sigma = Proofview.Goal.sigma gl in
+        let lems = interp_auto_lemmas ist env sigma lems in
+        name_atomic ~env
+          (TacTrivial(debug,List.map snd lems,l))
+          (Auto.h_trivial ~debug
+	     lems
+	     (Option.map (List.map (interp_hint_base ist)) l))
+      end
   | TacAuto (debug,n,lems,l) ->
-      Auto.h_auto ~debug (Option.map (interp_int_or_var ist) n)
-	(interp_auto_lemmas ist env sigma lems)
-	(Option.map (List.map (interp_hint_base ist)) l)
+      Proofview.Goal.enter begin fun gl ->
+        let env = Proofview.Goal.env gl in
+        let sigma = Proofview.Goal.sigma gl in
+        let lems = interp_auto_lemmas ist env sigma lems in
+        name_atomic ~env
+          (TacAuto(debug,n,List.map snd lems,l))
+          (Auto.h_auto ~debug (Option.map (interp_int_or_var ist) n)
+	     lems
+	     (Option.map (List.map (interp_hint_base ist)) l))
+      end
 
   (* Derived basic tactics *)
-  | TacSimpleInductionDestruct (isrec,h) ->
-      h_simple_induction_destruct isrec (interp_quantified_hypothesis ist h)
-  | TacInductionDestruct (isrec,ev,(l,el,cls)) ->
-      let sigma, l =
-        list_fold_map (fun sigma (c,(ipato,ipats)) ->
-          let c = interp_induction_arg ist gl c in
-          (sigma,(c,
-            (Option.map (interp_intro_pattern ist gl) ipato,
-	     Option.map (interp_intro_pattern ist gl) ipats)))) sigma l in
-      let sigma,el =
-        Option.fold_map (interp_constr_with_bindings ist env) sigma el in
-      let cls = Option.map (interp_clause ist gl) cls in
-      tclWITHHOLES ev (h_induction_destruct isrec ev) sigma (l,el,cls)
+  | TacInductionDestruct (isrec,ev,(l,el)) ->
+      (* spiwack: some unknown part of destruct needs the goal to be
+         prenormalised. *)
+      Proofview.V82.nf_evar_goals <*>
+      Proofview.Goal.nf_enter begin fun gl ->
+        let env = Proofview.Goal.env gl in
+        let sigma = Proofview.Goal.sigma gl in
+        let sigma,l =
+          List.fold_map begin fun sigma (c,(ipato,ipats),cls) ->
+            (* TODO: move sigma as a side-effect *)
+             (* spiwack: the [*p] variants are for printing *)
+            let cp = c in
+            let c = Tacmach.New.of_old (fun gl -> interp_induction_arg ist gl c) gl in
+            let ipato = interp_intro_pattern_naming_option ist env sigma ipato in
+            let ipatsp = ipats in
+            let sigma,ipats = interp_or_and_intro_pattern_option ist env sigma ipats in
+            let cls = Option.map (interp_clause ist env sigma) cls in
+            sigma,((c,(ipato,ipats),cls),(cp,(ipato,ipatsp),cls))
+          end sigma l
+        in
+        let l,lp = List.split l in
+        let sigma,el =
+          Option.fold_map (interp_constr_with_bindings ist env) sigma el in
+        name_atomic ~env
+          (TacInductionDestruct(isrec,ev,(lp,el)))
+          (Tacticals.New.tclTHEN
+             (Proofview.Unsafe.tclEVARS sigma)
+             (Tactics.induction_destruct isrec ev (l,el)))
+      end
   | TacDoubleInduction (h1,h2) ->
       let h1 = interp_quantified_hypothesis ist h1 in
       let h2 = interp_quantified_hypothesis ist h2 in
-      Elim.h_double_induction h1 h2
-  | TacDecomposeAnd c ->
-      let (sigma,c_interp) = pf_interp_constr ist gl c in
-      tclTHEN
-	(tclEVARS sigma)
-	(Elim.h_decompose_and c_interp)
-  | TacDecomposeOr c ->
-      let (sigma,c_interp) = pf_interp_constr ist gl c in
-      tclTHEN
-	(tclEVARS sigma)
-	(Elim.h_decompose_or c_interp)
-  | TacDecompose (l,c) ->
-      let l = List.map (interp_inductive ist) l in
-      let (sigma,c_interp) = pf_interp_constr ist gl c in
-      tclTHEN
-	(tclEVARS sigma)
-	(Elim.h_decompose l c_interp)
-  | TacSpecialize (n,cb) ->
-      let sigma, cb = interp_constr_with_bindings ist env sigma cb in
-      tclWITHHOLES false (h_specialize n) sigma cb
-  | TacLApply c ->
-      let (sigma,c_interp) = pf_interp_constr ist gl c in
-      tclTHEN
-	(tclEVARS sigma)
-	(h_lapply c_interp)
-
+      name_atomic
+        (TacDoubleInduction (h1,h2))
+        (Elim.h_double_induction h1 h2)
   (* Context management *)
-  | TacClear (b,l) -> h_clear b (interp_hyp_list ist gl l)
-  | TacClearBody l -> h_clear_body (interp_hyp_list ist gl l)
-  | TacMove (dep,id1,id2) ->
-      h_move dep (interp_hyp ist gl id1) (interp_move_location ist gl id2)
+  | TacClear (b,l) ->
+      Proofview.Goal.enter begin fun gl ->
+        let env = Tacmach.New.pf_env gl in
+        let sigma = Proofview.Goal.sigma gl in
+        let l = interp_hyp_list ist env sigma l in
+        if b then name_atomic ~env (TacClear (b, l)) (Tactics.keep l)
+        else
+          (* spiwack: until the tactic is in the monad *)
+          let tac = Proofview.V82.tactic (fun gl -> Tactics.clear l gl) in
+          Proofview.Trace.name_tactic (fun () -> Pp.str"<clear>") tac
+      end
+  | TacClearBody l ->
+      Proofview.Goal.enter begin fun gl ->
+        let env = Tacmach.New.pf_env gl in
+        let sigma = Proofview.Goal.sigma gl in
+        let l = interp_hyp_list ist env sigma l in
+        name_atomic ~env
+          (TacClearBody l)
+          (Tactics.clear_body l)
+      end
+  | TacMove (id1,id2) ->
+      Proofview.V82.tactic begin fun gl -> 
+        Tactics.move_hyp (interp_hyp ist (pf_env gl) (project gl) id1)
+                   (interp_move_location ist (pf_env gl) (project gl) id2)
+                   gl
+      end
   | TacRename l ->
-      h_rename (List.map (fun (id1,id2) ->
-			    interp_hyp ist gl id1,
-			    interp_fresh_ident ist env (snd id2)) l)
-  | TacRevert l -> h_revert (interp_hyp_list ist gl l)
+      Proofview.Goal.enter begin fun gl ->
+        let env = Tacmach.New.pf_env gl in
+        let sigma = Proofview.Goal.sigma gl in
+        let l =
+          List.map (fun (id1,id2) ->
+	    interp_hyp ist env sigma id1,
+	    interp_fresh_ident ist env sigma (snd id2)) l
+        in
+        name_atomic ~env
+          (TacRename l)
+          (Tactics.rename_hyp l)
+      end
 
   (* Constructors *)
-  | TacLeft (ev,bl) ->
-      let sigma, bl = interp_bindings ist env sigma bl in
-      tclWITHHOLES ev (h_left ev) sigma bl
-  | TacRight (ev,bl) ->
-      let sigma, bl = interp_bindings ist env sigma bl in
-      tclWITHHOLES ev (h_right ev) sigma bl
-  | TacSplit (ev,_,bll) ->
-      let sigma, bll = list_fold_map (interp_bindings ist env) sigma bll in
-      tclWITHHOLES ev (h_split ev) sigma bll
-  | TacAnyConstructor (ev,t) ->
-      abstract_tactic (TacAnyConstructor (ev,t))
-        (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 (interp_int_or_var ist n)) sigma bl
-
+  | TacSplit (ev,bll) ->
+      Proofview.Goal.enter begin fun gl ->
+        let env = Proofview.Goal.env gl in
+        let sigma = Proofview.Goal.sigma gl in
+        let sigma, bll = List.fold_map (interp_bindings ist env) sigma bll in
+        let named_tac bll =
+          let tac = Tactics.split_with_bindings ev bll in
+          name_atomic ~env (TacSplit (ev, bll)) tac
+        in
+        Tacticals.New.tclWITHHOLES ev named_tac sigma bll
+      end
   (* Conversion *)
   | TacReduce (r,cl) ->
-      let (sigma,r_interp) = pf_interp_red_expr ist gl r in
-      tclTHEN
-	(tclEVARS sigma)
-	(h_reduce r_interp (interp_clause ist gl cl))
+      (* spiwack: until the tactic is in the monad *)
+      Proofview.Trace.name_tactic (fun () -> Pp.str"<reduce>") begin
+      Proofview.V82.tactic begin fun gl -> 
+        let (sigma,r_interp) = interp_red_expr ist (pf_env gl) (project gl) r in
+        tclTHEN
+	  (tclEVARS sigma)
+	  (Tactics.reduce r_interp (interp_clause ist (pf_env gl) (project gl) cl))
+          gl
+      end
+      end
   | TacChange (None,c,cl) ->
-      let (sigma,c_interp) =
-	if (cl.onhyps = None or cl.onhyps = Some []) &
-	    (cl.concl_occs = all_occurrences_expr or
-	     cl.concl_occs = no_occurrences_expr)
-	 then pf_interp_type ist gl c
-	 else pf_interp_constr ist gl c
-      in
-      tclTHEN
-	(tclEVARS sigma)
-	(h_change None c_interp (interp_clause ist gl cl))
+      (* spiwack: until the tactic is in the monad *)
+      Proofview.Trace.name_tactic (fun () -> Pp.str"<change>") begin
+      Proofview.V82.nf_evar_goals <*>
+      Proofview.V82.tactic begin fun gl ->
+        let is_onhyps = match cl.onhyps with
+          | None | Some [] -> true
+          | _ -> false
+        in
+        let is_onconcl = match cl.concl_occs with
+          | AllOccurrences | NoOccurrences -> true
+          | _ -> false
+        in
+        let c_interp sigma =
+	  if is_onhyps && is_onconcl
+	  then interp_type ist (pf_env gl) sigma c
+	  else interp_constr ist (pf_env gl) sigma c
+        in
+	  (Tactics.change None c_interp (interp_clause ist (pf_env gl) (project gl) cl))
+          gl
+      end
+      end
   | TacChange (Some op,c,cl) ->
-      let sign,op = interp_typed_pattern ist env sigma op in
-      (* spiwack: (2012/04/18) the evar_map output by pf_interp_constr
-	 is dropped as the evar_map taken as input (from
-	 extend_gl_hyps) is incorrect.  This means that evar
-	 instantiated by pf_interp_constr may be lost, there. *)
-      let (_,c_interp) =
-	try pf_interp_constr ist (extend_gl_hyps gl sign) c
-	with Not_found | Anomaly _ (* Hack *) ->
-	   errorlabstrm "" (strbrk "Failed to get enough information from the left-hand side to type the right-hand side.")
-      in
-      tclTHEN
-	(tclEVARS sigma)
-	(h_change (Some op) c_interp (interp_clause ist { gl with sigma=sigma } cl))
+      (* spiwack: until the tactic is in the monad *)
+      Proofview.Trace.name_tactic (fun () -> Pp.str"<change>") begin
+      Proofview.V82.nf_evar_goals <*>
+      Proofview.Goal.enter begin fun gl ->
+        let env = Proofview.Goal.env gl in
+        let sigma = Proofview.Goal.sigma gl in
+        Proofview.V82.tactic begin fun gl -> 
+          let sign,op = interp_typed_pattern ist env sigma op in
+          let to_catch = function Not_found -> true | e -> Errors.is_anomaly e in
+	  let env' = Environ.push_named_context sign env in
+          let c_interp sigma =
+	      try interp_constr ist env' sigma c
+	      with e when to_catch e (* Hack *) ->
+		errorlabstrm "" (strbrk "Failed to get enough information from the left-hand side to type the right-hand side.")
+          in
+	      (Tactics.change (Some op) c_interp (interp_clause ist env sigma cl))
+		gl
+        end
+      end
+      end
 
   (* Equivalence relations *)
-  | TacReflexivity -> h_reflexivity
-  | TacSymmetry c -> h_symmetry (interp_clause ist gl c)
-  | TacTransitivity c ->
-    begin match c with
-    | None -> h_transitivity None
-    | Some c ->
-      let (sigma,c_interp) = pf_interp_constr ist gl c in
-      tclTHEN
-	(tclEVARS sigma)
-	(h_transitivity (Some c_interp))
-    end
+  | TacSymmetry c ->
+      Proofview.Goal.enter begin fun gl ->
+        let env = Proofview.Goal.env gl in
+        let sigma = Proofview.Goal.sigma gl in
+        let cl = interp_clause ist env sigma c in
+        name_atomic ~env
+          (TacSymmetry cl)
+          (Tactics.intros_symmetry cl)
+      end
 
   (* Equality and inversion *)
   | TacRewrite (ev,l,cl,by) ->
-      let l = List.map (fun (b,m,c) ->
-        let f env sigma = interp_open_constr_with_bindings false ist env sigma c in
-	(b,m,f)) l in
-      let cl = interp_clause ist gl cl in
-      Equality.general_multi_multi_rewrite ev l cl
-        (Option.map (fun by -> tclCOMPLETE (interp_tactic ist by), Equality.Naive) by)
+      Proofview.Goal.enter begin fun gl ->
+        let l' = List.map (fun (b,m,(keep,c)) ->
+          let f env sigma = interp_open_constr_with_bindings ist env sigma c in
+	  (b,m,keep,f)) l in
+        let env = Proofview.Goal.env gl in
+        let sigma = Proofview.Goal.sigma gl in
+        let cl = interp_clause ist env sigma cl in
+        name_atomic ~env
+          (TacRewrite (ev,l,cl,by))
+          (Equality.general_multi_rewrite ev l' cl
+             (Option.map (fun by -> Tacticals.New.tclCOMPLETE (interp_tactic ist by),
+               Equality.Naive)
+                by))
+      end
   | TacInversion (DepInversion (k,c,ids),hyp) ->
-      let (sigma,c_interp) =
-	match c with
-	| None -> sigma , None
-	| Some c ->
-	  let (sigma,c_interp) = pf_interp_constr ist gl c in
-	  sigma , Some c_interp
-      in
-      Inv.dinv k c_interp
-        (Option.map (interp_intro_pattern ist gl) ids)
-        (interp_declared_or_quantified_hypothesis ist gl hyp)
+      Proofview.Goal.nf_enter begin fun gl ->
+        let env = Proofview.Goal.env gl in
+        let sigma = Proofview.Goal.sigma gl in
+        let (sigma,c_interp) =
+          match c with
+          | None -> sigma , None
+          | Some c ->
+              let (sigma,c_interp) =
+                Tacmach.New.of_old (fun gl -> pf_interp_constr ist gl c) gl
+              in
+              sigma , Some c_interp
+        in
+        let dqhyps = interp_declared_or_quantified_hypothesis ist env sigma hyp in
+        let sigma,ids_interp = interp_or_and_intro_pattern_option ist env sigma ids in
+        Proofview.Unsafe.tclEVARS sigma <*>
+        name_atomic ~env
+          (TacInversion(DepInversion(k,c_interp,ids),dqhyps))
+          (Inv.dinv k c_interp ids_interp dqhyps)
+      end
   | TacInversion (NonDepInversion (k,idl,ids),hyp) ->
-      Inv.inv_clause k
-        (Option.map (interp_intro_pattern ist gl) ids)
-        (interp_hyp_list ist gl idl)
-        (interp_declared_or_quantified_hypothesis ist gl hyp)
+      Proofview.Goal.enter begin fun gl ->
+        let env = Proofview.Goal.env gl in
+        let sigma = Proofview.Goal.sigma gl in
+        let hyps = interp_hyp_list ist env sigma idl in
+        let dqhyps = interp_declared_or_quantified_hypothesis ist env sigma hyp in
+        let sigma, ids_interp = interp_or_and_intro_pattern_option ist env sigma ids in
+        Proofview.Unsafe.tclEVARS sigma <*>
+        name_atomic ~env
+          (TacInversion (NonDepInversion (k,hyps,ids),dqhyps))
+          (Inv.inv_clause k ids_interp hyps dqhyps)
+      end
   | TacInversion (InversionUsing (c,idl),hyp) ->
-      let (sigma,c_interp) = pf_interp_constr ist gl c in
-      Leminv.lemInv_clause (interp_declared_or_quantified_hypothesis ist gl hyp)
-        c_interp
-        (interp_hyp_list ist gl idl)
-
-  (* For extensions *)
-  | TacExtend (loc,opn,l) ->
-      let tac = lookup_tactic opn in
-      let (sigma,args) = 
-	List.fold_right begin fun a (sigma,acc) ->
-	  let (sigma,a_interp) = interp_genarg ist { gl with sigma=sigma } a in
-	  sigma , a_interp::acc
-	end l (project gl,[])
-      in
-      abstract_extended_tactic opn args (tac args)
-  | TacAlias (loc,s,l,(_,body)) -> fun gl ->
-    let evdref = ref gl.sigma in
-    let rec f x = match genarg_tag x with
-    | IntArgType ->
-        VInteger (out_gen globwit_int x)
-    | IntOrVarArgType ->
-        mk_int_or_var_value ist (out_gen globwit_int_or_var x)
-    | PreIdentArgType ->
-	failwith "pre-identifiers cannot be bound"
-    | IntroPatternArgType ->
-	VIntroPattern
-	  (snd (interp_intro_pattern ist gl (out_gen globwit_intro_pattern x)))
-    | IdentArgType b ->
-	value_of_ident (interp_fresh_ident ist env
-	  (out_gen (globwit_ident_gen b) x))
-    | VarArgType ->
-        mk_hyp_value ist gl (out_gen globwit_var x)
-    | RefArgType ->
-        VConstr ([],constr_of_global
-          (pf_interp_reference ist gl (out_gen globwit_ref x)))
-    | SortArgType ->
-        VConstr ([],mkSort (interp_sort (out_gen globwit_sort x)))
-    | ConstrArgType ->
-        let (sigma,v) = mk_constr_value ist gl (out_gen globwit_constr x) in
-	evdref := sigma;
-	v
-    | OpenConstrArgType (false,true) ->
-        let (sigma,v) = mk_open_constr_value true ist gl (snd (out_gen globwit_open_constr_wTC x)) in
-	evdref := sigma;
-	v
-    | OpenConstrArgType (false,false) ->
-        let (sigma,v) = mk_open_constr_value false ist gl (snd (out_gen globwit_open_constr x)) in
-	evdref := sigma;
-	v
-    | ConstrMayEvalArgType ->
-        let (sigma,c_interp) = interp_constr_may_eval ist gl (out_gen globwit_constr_may_eval x) in
-	evdref := sigma;
-	VConstr ([],c_interp)
-    | ExtraArgType s when tactic_genarg_level s <> None ->
-          (* Special treatment of tactic arguments *)
-	let (sigma,v) = val_interp ist gl
-          (out_gen (globwit_tactic (Option.get (tactic_genarg_level s))) x)
-	in
-	evdref := sigma;
-	v
-    | List0ArgType ConstrArgType ->
-        let wit = wit_list0 globwit_constr in
-	let (sigma,l_interp) =
-	  List.fold_right begin fun c (sigma,acc) ->
-	    let (sigma,c_interp) = mk_constr_value ist { gl with sigma=sigma } c in
-	    sigma , c_interp::acc
-	  end (out_gen wit x) (project gl,[])
-	in
-	evdref := sigma;
-        VList (l_interp)
-    | List0ArgType VarArgType ->
-        let wit = wit_list0 globwit_var in
-        VList (List.map (mk_hyp_value ist gl) (out_gen wit x))
-    | List0ArgType IntArgType ->
-        let wit = wit_list0 globwit_int in
-        VList (List.map (fun x -> VInteger x) (out_gen wit x))
-    | List0ArgType IntOrVarArgType ->
-        let wit = wit_list0 globwit_int_or_var in
-        VList (List.map (mk_int_or_var_value ist) (out_gen wit x))
-    | List0ArgType (IdentArgType b) ->
-        let wit = wit_list0 (globwit_ident_gen b) in
-	let mk_ident x = value_of_ident (interp_fresh_ident ist env x) in
-        VList (List.map mk_ident (out_gen wit x))
-    | List0ArgType IntroPatternArgType ->
-        let wit = wit_list0 globwit_intro_pattern in
-	let mk_ipat x = VIntroPattern (snd (interp_intro_pattern ist gl x)) in
-        VList (List.map mk_ipat (out_gen wit x))
-    | List1ArgType ConstrArgType ->
-        let wit = wit_list1 globwit_constr in
-	let (sigma, l_interp) =
-	  List.fold_right begin fun c (sigma,acc) ->
-	    let (sigma,c_interp) = mk_constr_value ist { gl with sigma=sigma } c in
-	    sigma , c_interp::acc
-	  end (out_gen wit x) (project gl,[])
-	in
-	evdref:=sigma;
-        VList l_interp
-    | List1ArgType VarArgType ->
-        let wit = wit_list1 globwit_var in
-        VList (List.map (mk_hyp_value ist gl) (out_gen wit x))
-    | List1ArgType IntArgType ->
-        let wit = wit_list1 globwit_int in
-        VList (List.map (fun x -> VInteger x) (out_gen wit x))
-    | List1ArgType IntOrVarArgType ->
-        let wit = wit_list1 globwit_int_or_var in
-        VList (List.map (mk_int_or_var_value ist) (out_gen wit x))
-    | List1ArgType (IdentArgType b) ->
-        let wit = wit_list1 (globwit_ident_gen b) in
-	let mk_ident x = value_of_ident (interp_fresh_ident ist env x) in
-        VList (List.map mk_ident (out_gen wit x))
-    | List1ArgType IntroPatternArgType ->
-        let wit = wit_list1 globwit_intro_pattern in
-	let mk_ipat x = VIntroPattern (snd (interp_intro_pattern ist gl x)) in
-        VList (List.map mk_ipat (out_gen wit x))
-    | StringArgType | BoolArgType
-    | QuantHypArgType | RedExprArgType
-    | OpenConstrArgType _ | ConstrWithBindingsArgType
-    | ExtraArgType _ | BindingsArgType
-    | OptArgType _ | PairArgType _
-    | List0ArgType _ | List1ArgType _
-	-> error "This argument type is not supported in tactic notations."
-
-    in
-    let lfun = (List.map (fun (x,c) -> (x,f c)) l)@ist.lfun in
-    let trace = push_trace (loc,LtacNotationCall s) ist.trace in
-    let gl = { gl with sigma = !evdref } in
-    interp_tactic { ist with lfun=lfun; trace=trace } body gl
-
-let make_empty_glob_sign () =
-  { ltacvars = ([],[]); ltacrecvars = [];
-    gsigma = Evd.empty; genv = Global.env() }
-
-let fully_empty_glob_sign =
-  { ltacvars = ([],[]); ltacrecvars = [];
-    gsigma = Evd.empty; genv = Environ.empty_env }
+      Proofview.Goal.enter begin fun gl ->
+        let env = Proofview.Goal.env gl in
+        let sigma = Proofview.Goal.sigma gl in
+        let (sigma,c_interp) = interp_constr ist env sigma c in
+        let dqhyps = interp_declared_or_quantified_hypothesis ist env sigma hyp in
+        let hyps = interp_hyp_list ist env sigma idl in
+        Proofview.Unsafe.tclEVARS sigma <*>
+        name_atomic ~env
+          (TacInversion (InversionUsing (c_interp,hyps),dqhyps))
+          (Leminv.lemInv_clause dqhyps c_interp hyps)
+      end
 
 (* 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 true {
-      ltacvars = (List.map fst lfun, []); ltacrecvars = [];
-      gsigma = project gl; genv = pf_env gl } t) gl
-
-let eval_tactic t gls =
-  db_initialize ();
-  interp_tactic { lfun=[]; avoid_ids=[]; debug=get_debug(); trace=[] }
-    t gls
-
-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_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 true ist t in
-  let t = eval_tactic te in
-  match ot with
-  | None -> abstract_tactic_expr (TacArg (dloc,Tacexp te)) t gl
-  | Some t' ->
-      abstract_tactic_expr ~dflt:true (TacArg (dloc,Tacexp te)) (tclTHEN t t') gl
-
-(***************************************************************************)
-(* Substitution at module closing time *)
-
-let subst_quantified_hypothesis _ x = x
-
-let subst_declared_or_quantified_hypothesis _ x = x
-
-let subst_glob_constr_and_expr subst (c,e) =
-  assert (e=None); (* e<>None only for toplevel tactics *)
-  (Detyping.subst_glob_constr subst c,None)
-
-let subst_glob_constr = subst_glob_constr_and_expr (* shortening *)
-
-let subst_binding subst (loc,b,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_glob_constr subst) l)
-  | ExplicitBindings l -> ExplicitBindings (List.map (subst_binding subst) l)
-
-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_glob_with_bindings subst c)
-  | ElimOnAnonHyp n as x -> x
-  | ElimOnIdent id as x -> x
-
-let subst_and_short_name f (c,n) =
-(*  assert (n=None); *)(* since tacdef are strictly globalized *)
-  (f c,None)
-
-let subst_or_var f =  function
-  | ArgVar _ as x -> x
-  | ArgArg x -> ArgArg (f x)
-
-let subst_located f (_loc,id) = (dloc,f id)
-
-let subst_reference subst =
-  subst_or_var (subst_located (subst_kn subst))
-
-(*CSC: subst_global_reference is used "only" for RefArgType, that propagates
-  to the syntactic non-terminals "global", used in commands such as
-  Print. It is also used for non-evaluable references. *)
-let subst_global_reference subst =
- let subst_global ref =
-  let ref',t' = subst_global subst ref in
-   if not (eq_constr (constr_of_global ref') t') then
-    ppnl (str "Warning: The reference " ++ pr_global ref ++ str " is not " ++
-          str " expanded to \"" ++ pr_lconstr t' ++ str "\", but to " ++
-          pr_global ref') ;
-   ref'
- in
-  subst_or_var (subst_located subst_global)
-
-let subst_evaluable subst =
-  let subst_eval_ref = subst_evaluable_reference subst in
-    subst_or_var (subst_and_short_name subst_eval_ref)
-
-let subst_unfold subst (l,e) =
-  (l,subst_evaluable subst 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_glob_constr subst c)
-
-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_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_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)
-  | Simpl o -> Simpl (Option.map (subst_pattern_with_occurrences subst) o)
-  | (Red _ | Hnf | ExtraRedExpr _ | CbvVm as r) -> r
-
-let subst_raw_may_eval subst = function
-  | 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_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 ->
-      Hyp (locs,subst_match_pattern subst mp)
-      :: subst_match_goal_hyps subst tl
-  | Def (locs,mv,mp) :: tl ->
-      Def (locs,subst_match_pattern subst mv, subst_match_pattern subst mp)
-      :: subst_match_goal_hyps subst tl
-  | [] -> []
-
-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_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_glob_with_bindings subst) cb,cl)
-  | TacElim (ev,cb,cbo) ->
-      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_glob_constr subst c)) l)
-  | TacCofix idopt as x -> x
-  | TacMutualCofix (b,id,l) ->
-      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_glob_constr subst c)
-  | TacGeneralize cl ->
-      TacGeneralize (List.map (on_fst (subst_constr_with_occurrences subst))cl)
-  | TacGeneralizeDep c -> TacGeneralizeDep (subst_glob_constr subst c)
-  | TacLetTac (id,c,clp,b,eqpat) ->
-    TacLetTac (id,subst_glob_constr subst c,clp,b,eqpat)
 
-  (* Automation tactics *)
-  | TacTrivial (d,lems,l) -> TacTrivial (d,List.map (subst_glob_constr subst) lems,l)
-  | TacAuto (d,n,lems,l) -> TacAuto (d,n,List.map (subst_glob_constr subst) lems,l)
-
-  (* Derived basic tactics *)
-  | TacSimpleInductionDestruct (isrec,h) as x -> x
-  | TacInductionDestruct (isrec,ev,(l,el,cls)) ->
-      let l' = List.map (fun (c,ids) -> subst_induction_arg subst c, ids) l in
-      let el' = Option.map (subst_glob_with_bindings subst) el in
-      TacInductionDestruct (isrec,ev,(l',el',cls))
-  | TacDoubleInduction (h1,h2) as x -> x
-  | TacDecomposeAnd c -> TacDecomposeAnd (subst_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_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
-  | TacClearBody l as x -> x
-  | TacMove (dep,id1,id2) as x -> x
-  | TacRename l as x -> x
-  | TacRevert _ as x -> x
-
-  (* Constructors *)
-  | TacLeft (ev,bl) -> TacLeft (ev,subst_bindings subst bl)
-  | TacRight (ev,bl) -> TacRight (ev,subst_bindings subst bl)
-  | TacSplit (ev,b,bll) -> TacSplit (ev,b,List.map (subst_bindings subst) bll)
-  | TacAnyConstructor (ev,t) -> TacAnyConstructor (ev,Option.map (subst_tactic subst) t)
-  | TacConstructor (ev,n,bl) -> TacConstructor (ev,n,subst_bindings subst bl)
-
-  (* Conversion *)
-  | TacReduce (r,cl) -> TacReduce (subst_redexp subst r, cl)
-  | TacChange (op,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_glob_constr subst) c)
-
-  (* Equality and inversion *)
-  | TacRewrite (ev,l,cl,by) ->
-      TacRewrite (ev,
-		  List.map (fun (b,m,c) ->
-			      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_glob_constr subst) c,l),hyp)
-  | TacInversion (NonDepInversion _,_) as x -> x
-  | TacInversion (InversionUsing (c,cl),hyp) ->
-      TacInversion (InversionUsing (subst_glob_constr subst c,cl),hyp)
-
-  (* For extensions *)
-  | TacExtend (_loc,opn,l) ->
-      TacExtend (dloc,opn,List.map (subst_genarg subst) l)
-  | TacAlias (_,s,l,(dir,body)) ->
-      TacAlias (dloc,s,List.map (fun (id,a) -> (id,subst_genarg subst a)) l,
-        (dir,subst_tactic subst body))
-
-and subst_tactic subst (t:glob_tactic_expr) = match t with
-  | TacAtom (_loc,t) -> TacAtom (dloc, subst_atomic subst t)
-  | TacFun tacfun -> TacFun (subst_tactic_fun subst tacfun)
-  | TacLetIn (r,l,u) ->
-      let l = List.map (fun (n,b) -> (n,subst_tacarg subst b)) l in
-      TacLetIn (r,l,subst_tactic subst u)
-  | TacMatchGoal (lz,lr,lmr) ->
-      TacMatchGoal(lz,lr, subst_match_rule subst lmr)
-  | TacMatch (lz,c,lmr) ->
-      TacMatch (lz,subst_tactic subst c,subst_match_rule subst lmr)
-  | TacId _ | TacFail _ as x -> x
-  | TacProgress tac -> TacProgress (subst_tactic subst tac:glob_tactic_expr)
-  | TacAbstract (tac,s) -> TacAbstract (subst_tactic subst tac,s)
-  | TacThen (t1,tf,t2,tl) ->
-      TacThen (subst_tactic subst t1,Array.map (subst_tactic subst) tf,
-	       subst_tactic subst t2,Array.map (subst_tactic subst) tl)
-  | 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)
-  | TacOrelse (tac1,tac2) ->
-      TacOrelse (subst_tactic subst tac1,subst_tactic subst tac2)
-  | 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 (dloc,subst_tacarg subst a)
-
-and subst_tactic_fun subst (var,body) = (var,subst_tactic subst body)
-
-and subst_tacarg subst = function
-  | Reference r -> Reference (subst_reference subst r)
-  | ConstrMayEval c -> ConstrMayEval (subst_raw_may_eval subst c)
-  | MetaIdArg (_loc,_,_) -> assert false
-  | TacCall (_loc,f,l) ->
-      TacCall (_loc, subst_reference subst f, List.map (subst_tacarg subst) l)
-  | TacExternal (_loc,com,req,la) ->
-      TacExternal (_loc,com,req,List.map (subst_tacarg subst) la)
-  | (TacVoid | IntroPattern _ | Integer _ | TacFreshId _) as x -> x
-  | Tacexp t -> Tacexp (subst_tactic subst t)
-  | TacDynamic(the_loc,t) as x ->
-      (match Dyn.tag t with
-	| "tactic" | "value" -> x
-        | "constr" ->
-          TacDynamic(the_loc, constr_in (subst_mps subst (constr_out t)))
-	| s -> anomaly_loc (dloc, "Tacinterp.val_interp",
-                 str "Unknown dynamic: <" ++ str s ++ str ">"))
-
-(* Reads the rules of a Match Context or a Match *)
-and subst_match_rule subst = function
-  | (All tc)::tl ->
-      (All (subst_tactic subst tc))::(subst_match_rule subst tl)
-  | (Pat (rl,mp,tc))::tl ->
-      let hyps = subst_match_goal_hyps subst rl in
-      let pat = subst_match_pattern subst mp in
-      Pat (hyps,pat,subst_tactic subst tc)
-      ::(subst_match_rule subst tl)
-  | [] -> []
+let default_ist () =
+  let extra = TacStore.set TacStore.empty f_debug (get_debug ()) in
+  { lfun = Id.Map.empty; extra = extra }
+
+let eval_tactic t =
+  Proofview.tclUNIT () >>= fun () -> (* delay for [default_ist] *)
+  Proofview.tclLIFT db_initialize <*>
+  interp_tactic (default_ist ()) t
+
+let eval_tactic_ist ist t =
+  Proofview.tclLIFT db_initialize <*>
+  interp_tactic ist t
+
+(* globalization + interpretation *)
+
+
+let interp_tac_gen lfun avoid_ids debug t =
+  Proofview.Goal.enter begin fun gl ->
+  let env = Proofview.Goal.env gl in
+  let extra = TacStore.set TacStore.empty f_debug debug in
+  let extra = TacStore.set extra f_avoid_ids avoid_ids in
+  let ist = { lfun = lfun; extra = extra } in
+  let ltacvars = Id.Map.domain lfun in
+  interp_tactic ist
+    (intern_pure_tactic {
+      ltacvars; ltacrecvars = Id.Map.empty;
+      genv = env } t)
+  end
 
-and subst_genarg subst (x:glob_generic_argument) =
-  match genarg_tag x with
-  | BoolArgType -> in_gen globwit_bool (out_gen globwit_bool x)
-  | IntArgType -> in_gen globwit_int (out_gen globwit_int x)
-  | IntOrVarArgType -> in_gen globwit_int_or_var (out_gen globwit_int_or_var x)
-  | StringArgType -> in_gen globwit_string (out_gen globwit_string x)
-  | PreIdentArgType -> in_gen globwit_pre_ident (out_gen globwit_pre_ident x)
-  | IntroPatternArgType ->
-      in_gen globwit_intro_pattern (out_gen globwit_intro_pattern x)
-  | IdentArgType b ->
-      in_gen (globwit_ident_gen b) (out_gen (globwit_ident_gen b) x)
-  | VarArgType -> in_gen globwit_var (out_gen globwit_var x)
-  | RefArgType ->
-      in_gen globwit_ref (subst_global_reference subst
-	(out_gen globwit_ref x))
-  | SortArgType ->
-      in_gen globwit_sort (out_gen globwit_sort x)
-  | ConstrArgType ->
-      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 ->
-      in_gen globwit_quant_hyp
-        (subst_declared_or_quantified_hypothesis subst
-          (out_gen globwit_quant_hyp x))
-  | RedExprArgType ->
-      in_gen globwit_red_expr (subst_redexp subst (out_gen globwit_red_expr x))
-  | OpenConstrArgType (b1,b2) ->
-      in_gen (globwit_open_constr_gen (b1,b2))
-        ((),subst_glob_constr subst (snd (out_gen (globwit_open_constr_gen (b1,b2)) x)))
-  | ConstrWithBindingsArgType ->
-      in_gen globwit_constr_with_bindings
-        (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))
-  | List0ArgType _ -> app_list0 (subst_genarg subst) x
-  | List1ArgType _ -> app_list1 (subst_genarg subst) x
-  | OptArgType _ -> app_opt (subst_genarg subst) x
-  | PairArgType _ -> app_pair (subst_genarg subst) (subst_genarg subst) x
-  | ExtraArgType s ->
-      match tactic_genarg_level s with
-      | Some n ->
-          (* Special treatment of tactic arguments *)
-          in_gen (globwit_tactic n)
-            (subst_tactic subst (out_gen (globwit_tactic n) x))
-      | None ->
-          lookup_genarg_subst s subst x
+let interp t = interp_tac_gen Id.Map.empty [] (get_debug()) t
+let _ = Proof_global.set_interp_tac interp
+
+(* Used to hide interpretation for pretty-print, now just launch tactics *)
+(* [global] means that [t] should be internalized outside of goals. *)
+let hide_interp global t ot =
+  let hide_interp env =
+    let ist = { ltacvars = Id.Set.empty; ltacrecvars = Id.Map.empty;
+                genv = env } in
+    let te = intern_pure_tactic ist t in
+    let t = eval_tactic te in
+    match ot with
+    | None -> t
+    | Some t' -> Tacticals.New.tclTHEN t t'
+  in
+  if global then
+    Proofview.tclENV >>= fun env ->
+    hide_interp env
+  else
+    Proofview.Goal.enter begin fun gl ->
+      hide_interp (Proofview.Goal.env gl)
+    end
 
 (***************************************************************************)
-(* Tactic registration *)
-
-(* 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)
-
-type tacdef_kind = | NewTac of identifier
-		   | UpdateTac of ltac_constant
-
-let load_md i ((sp,kn),(local,defs)) =
-  let dp,_ = repr_path sp in
-  let mp,dir,_ = repr_kn kn in
-  List.iter (fun (id,t) ->
-    match id with
-	NewTac id ->
-	  let sp = Libnames.make_path dp id in
-	  let kn = Names.make_kn mp dir (label_of_id id) in
-	    Nametab.push_tactic (Until i) sp kn;
-	    add (kn,t)
-      | UpdateTac kn -> replace (kn,t)) defs
-
-let open_md i ((sp,kn),(local,defs)) =
-  let dp,_ = repr_path sp in
-  let mp,dir,_ = repr_kn kn in
-  List.iter (fun (id,t) ->
-    match id with
-	NewTac id ->
-	  let sp = Libnames.make_path dp id in
-	  let kn = Names.make_kn mp dir (label_of_id id) in
-	    Nametab.push_tactic (Exactly i) sp kn
-      | UpdateTac kn -> ()) defs
-
-let cache_md x = load_md 1 x
-
-let subst_kind subst id =
-  match id with
-    | NewTac _ -> id
-    | UpdateTac kn -> UpdateTac (subst_kn subst kn)
-
-let subst_md (subst,(local,defs)) =
-  (local,
-   List.map (fun (id,t) -> (subst_kind subst id,subst_tactic subst t)) defs)
-
-let classify_md (local,defs as o) =
-  if local then Dispose else Substitute o
-
-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;
-     open_function   = open_md;
-     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 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"
-    (pr_qualid id ++ spc() ++ str "is not a user defined tactic.")
-
-open Libnames
+(** Register standard arguments *)
+
+let def_intern ist x = (ist, x)
+let def_subst _ x = x
+let def_interp ist gl x = (project gl, x)
+
+let declare_uniform t =
+  Genintern.register_intern0 t def_intern;
+  Genintern.register_subst0 t def_subst;
+  Geninterp.register_interp0 t def_interp
+
+let () =
+  declare_uniform wit_unit
+
+let () =
+  declare_uniform wit_int
+
+let () =
+  declare_uniform wit_bool
+
+let () =
+  declare_uniform wit_string
+
+let () =
+  declare_uniform wit_pre_ident
+
+let () =
+  let interp ist gl ref = (project gl, interp_reference ist (pf_env gl) (project gl) ref) in
+  Geninterp.register_interp0 wit_ref interp;
+  let interp ist gl pat = interp_intro_pattern ist (pf_env gl) (project gl) pat in
+  Geninterp.register_interp0 wit_intro_pattern interp;
+  let interp ist gl pat = (project gl, interp_clause ist (pf_env gl) (project gl) pat) in
+  Geninterp.register_interp0 wit_clause_dft_concl interp;
+  let interp ist gl s = interp_sort (project gl) s in
+  Geninterp.register_interp0 wit_sort interp
+
+let () =
+  let interp ist gl tac =
+    let f = VFun (UnnamedAppl,extract_trace ist, ist.lfun, [], tac) in
+    (project gl, TacArg (dloc, valueIn (of_tacvalue f)))
+  in
+  Geninterp.register_interp0 wit_tactic interp
 
-(* Adds a definition for tactics in the table *)
-let make_absolute_name ident repl =
-  let loc = loc_of_reference ident in
-  try
-    let id, kn =
-      if repl then None, Nametab.locate_tactic (snd (qualid_of_reference ident))
-      else let id = coerce_reference_to_id ident in
-	     Some id, Lib.make_kn id
-    in
-      if Gmap.mem kn !mactab then
-	if repl then id, kn
-	else
-	  user_err_loc (loc,"Tacinterp.add_tacdef",
-		       str "There is already an Ltac named " ++ pr_reference ident ++ str".")
-      else if is_atomic_kn kn then
-	user_err_loc (loc,"Tacinterp.add_tacdef",
-		     str "Reserved Ltac name " ++ pr_reference ident ++ str".")
-      else id, kn
-  with Not_found ->
-    user_err_loc (loc,"Tacinterp.add_tacdef",
-		 str "There is no Ltac named " ++ pr_reference ident ++ str".")
-
-let add_tacdef local isrec tacl =
-  let rfun = List.map (fun (ident, b, _) -> make_absolute_name ident b) tacl in
-  let ist =
-    {(make_empty_glob_sign()) with ltacrecvars =
-	if isrec then list_map_filter
-	  (function (Some id, qid) -> Some (id, qid) | (None, _) -> None) rfun
-	else []} in
-  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_or_tacarg ist) def in
-	(k, t))
-      tacl rfun in
-  let id0 = fst (List.hd rfun) in
-  let _ = match id0 with
-    | Some id0 -> ignore(Lib.add_leaf id0 (inMD (local,gtacl)))
-    | _ -> Lib.add_anonymous_leaf (inMD (local,gtacl)) in
-  List.iter
-    (fun (id,b,_) ->
-      Flags.if_verbose msgnl (Libnames.pr_reference id ++
-				 (if b then str " is redefined"
-				   else str " is defined")))
-    tacl
+let () =
+  Geninterp.register_interp0 wit_uconstr (fun ist gl c ->
+     project gl , interp_uconstr ist (pf_env gl) c
+  )
 
 (***************************************************************************)
 (* Other entry points *)
 
-let glob_tactic x =
-  Flags.with_option strict_check (intern_tactic true (make_empty_glob_sign ())) x
+let val_interp ist tac k = Ftactic.run (val_interp ist tac) k
 
-let glob_tactic_env l env x =
-  Flags.with_option strict_check
-  (intern_pure_tactic
-    { ltacvars = (l,[]); ltacrecvars = []; gsigma = Evd.empty; genv = env })
-    x
+let interp_ltac_constr ist c k = Ftactic.run (interp_ltac_constr ist c) k
 
 let interp_redexp env sigma r =
-  let ist = { lfun=[]; avoid_ids=[]; debug=get_debug (); trace=[] } in
-  let gist = {(make_empty_glob_sign ()) with genv = env; gsigma = sigma } in
-  interp_red_expr ist sigma env (intern_red_expr gist r)
+  let ist = default_ist () in
+  let gist = { fully_empty_glob_sign with genv = env; } in
+  interp_red_expr ist env sigma (intern_red_expr gist r)
 
 (***************************************************************************)
 (* Embed tactics in raw or glob tactic expr *)
@@ -3190,30 +2336,80 @@ let globTacticIn t = TacArg (dloc,TacDynamic (dloc,tactic_in t))
 let tacticIn t =
   globTacticIn (fun ist ->
     try glob_tactic (t ist)
-    with e when Errors.noncritical e ->
-      anomalylabstrm "tacticIn"
+    with e when Errors.noncritical e -> anomaly ~label:"tacticIn"
       (str "Incorrect tactic expression. Received exception is:" ++
        Errors.print e))
 
-let tacticOut = function
-  | TacArg (_,TacDynamic (_,d)) ->
-    if (Dyn.tag d) = "tactic" then
-      tactic_out d
-    else
-      anomalylabstrm "tacticOut" (str "Dynamic tag should be tactic")
-  | ast ->
-    anomalylabstrm "tacticOut"
-      (str "Not a Dynamic ast: " (* ++ print_ast ast*) )
-
 (***************************************************************************)
 (* Backwarding recursive needs of tactic glob/interp/eval functions *)
 
-let _ = Auto.set_extern_interp
-  (fun l ->
-    let l = List.map (fun (id,c) -> (id,VConstr ([],c))) l in
-    interp_tactic {lfun=l;avoid_ids=[];debug=get_debug(); trace=[]})
-let _ = Auto.set_extern_intern_tac
+let _ =
+  let eval ty env sigma lfun arg =
+    let ist = { lfun = lfun; extra = TacStore.empty; } in
+    if has_type arg (glbwit wit_tactic) then
+      let tac = out_gen (glbwit wit_tactic) arg in
+      let tac = interp_tactic ist tac in
+      (** Save the initial side-effects to restore them afterwards. We set the
+          current set of side-effects to be empty so that we can retrieve the
+          ones created during the tactic invocation easily. *)
+      let eff = Evd.eval_side_effects sigma in
+      let sigma = Evd.drop_side_effects sigma in
+      (** Start a proof *)
+      let prf = Proof.start sigma [env, ty] in
+      let (prf, _) =
+        try Proof.run_tactic env tac prf
+        with Logic_monad.TacticFailure e as src ->
+          (** Catch the inner error of the monad tactic *)
+          let (_, info) = Errors.push src in
+          iraise (e, info)
+      in
+      (** Plug back the retrieved sigma *)
+      let sigma = Proof.in_proof prf (fun sigma -> sigma) in
+      let ans = match Proof.initial_goals prf with
+      | [c, _] -> c
+      | _ -> assert false
+      in
+      let ans = Reductionops.nf_evar sigma ans in
+      (** [neff] contains the freshly generated side-effects *)
+      let neff = Evd.eval_side_effects sigma in
+      (** Reset the old side-effects *)
+      let sigma = Evd.drop_side_effects sigma in
+      let sigma = Evd.emit_side_effects eff sigma in
+      (** Get rid of the fresh side-effects by internalizing them in the term
+          itself. Note that this is unsound, because the tactic may have solved
+          other goals that were already present during its invocation, so that
+          those goals rely on effects that are not present anymore. Hopefully,
+          this hack will work in most cases. *)
+      let ans = Term_typing.handle_side_effects env ans neff in
+      ans, sigma
+    else
+      failwith "not a tactic"
+  in
+  Hook.set Pretyping.genarg_interp_hook eval
+
+let _ = Hook.set Auto.extern_interp
   (fun l ->
-    Flags.with_option strict_check
-    (intern_pure_tactic {(make_empty_glob_sign()) with ltacvars=(l,[])}))
-let _ = Auto.set_extern_subst_tactic subst_tactic
+    let lfun = Id.Map.map (fun c -> Value.of_constr c) l in
+    let ist = { (default_ist ()) with lfun; } in
+    interp_tactic ist)
+
+(** Used in tactic extension **)
+
+let dummy_id = Id.of_string "_"
+
+let lift_constr_tac_to_ml_tac vars tac =
+  let tac _ ist = Proofview.Goal.enter begin fun gl ->
+    let env = Proofview.Goal.env gl in
+    let sigma = Proofview.Goal.sigma gl in
+    let map = function
+    | None -> None
+    | Some id ->
+      let c = Id.Map.find id ist.lfun in
+      try Some (coerce_to_closed_constr env c)
+      with CannotCoerceTo ty ->
+        error_ltac_variable Loc.ghost dummy_id (Some (env,sigma)) c ty
+    in
+    let args = List.map_filter map vars in
+    tac args ist
+  end in
+  tac
diff --git a/tactics/tacinterp.mli b/tactics/tacinterp.mli
index 5df6a6cd..7605c915 100644
--- a/tactics/tacinterp.mli
+++ b/tactics/tacinterp.mli
@@ -1,46 +1,49 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-open Pp
-open Util
 open Names
-open Proof_type
-open Tacmach
 open Tactic_debug
 open Term
 open Tacexpr
 open Genarg
-open Topconstr
-open Mod_subst
 open Redexpr
+open Misctypes
+
+module Value :
+sig
+  type t = tlevel generic_argument
+  val of_constr : constr -> t
+  val to_constr : t -> constr option
+  val of_int : int -> t
+  val to_int : t -> int option
+  val to_list : t -> t list option
+  val of_closure : Geninterp.interp_sign -> glob_tactic_expr -> t
+end
 
 (** Values for interpretation *)
-type value =
-  | VRTactic of (goal list sigma)
-  | VFun of ltac_trace * (identifier*value) list *
-      identifier option list * glob_tactic_expr
-  | VVoid
-  | VInteger of int
-  | VIntroPattern of intro_pattern_expr
-  | VConstr of Pattern.constr_under_binders
-  | VConstr_context of constr
-  | VList of value list
-  | VRec of (identifier*value) list ref * glob_tactic_expr
+type value = Value.t
+
+module TacStore : Store.S with
+  type t = Geninterp.TacStore.t
+  and type 'a field = 'a Geninterp.TacStore.field
 
 (** Signature for interpretation: val\_interp and interpretation functions *)
-and interp_sign =
-  { lfun : (identifier * value) list;
-    avoid_ids : identifier list;
-    debug : debug_info;
-    trace : ltac_trace }
+type interp_sign = Geninterp.interp_sign = {
+  lfun : value Id.Map.t;
+  extra : TacStore.t }
+
+val f_avoid_ids : Id.t list TacStore.field
+val f_debug : debug_info TacStore.field
 
 val extract_ltac_constr_values : interp_sign -> Environ.env ->
-  Pretyping.ltac_var_map
+  Pattern.constr_under_binders Id.Map.t
+(** Given an interpretation signature, extract all values which are coercible to
+    a [constr]. *)
 
 (** To embed several objects in Coqast.t *)
 val tactic_in : (interp_sign -> glob_tactic_expr) -> Dyn.t
@@ -56,118 +59,67 @@ val set_debug : debug_info -> unit
 (** Gives the state of debug *)
 val get_debug : unit -> debug_info
 
-(** 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 *)
-val add_tactic :
-  string -> (typed_generic_argument list -> tactic) -> unit
-val overwriting_add_tactic :
-  string -> (typed_generic_argument list -> tactic) -> unit
-val lookup_tactic :
-  string -> (typed_generic_argument list) -> tactic
-
 (** Adds an interpretation function for extra generic arguments *)
-type glob_sign = {
-  ltacvars : identifier list * identifier list;
-  ltacrecvars : (identifier * Nametab.ltac_constant) list;
-  gsigma : Evd.evar_map;
-  genv : Environ.env }
-
-val fully_empty_glob_sign : glob_sign
-
-val add_interp_genarg :
-  string ->
-    (glob_sign -> raw_generic_argument -> glob_generic_argument) *
-    (interp_sign -> goal sigma -> glob_generic_argument ->
-      Evd.evar_map * typed_generic_argument) *
-    (substitution -> glob_generic_argument -> glob_generic_argument)
-    -> unit
-
-val interp_genarg :
-  interp_sign -> goal sigma -> glob_generic_argument -> Evd.evar_map * typed_generic_argument
-
-val intern_genarg :
-  glob_sign -> raw_generic_argument -> glob_generic_argument
 
-val intern_pure_tactic :
-  glob_sign -> raw_tactic_expr -> glob_tactic_expr
-
-val intern_constr :
-  glob_sign -> constr_expr -> glob_constr_and_expr
-
-val intern_constr_with_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
-
-val subst_genarg :
-  substitution -> glob_generic_argument -> glob_generic_argument
-
-val subst_glob_constr_and_expr :
-  substitution -> glob_constr_and_expr -> glob_constr_and_expr
-
-val subst_glob_with_bindings :
-  substitution -> glob_constr_and_expr Glob_term.with_bindings -> glob_constr_and_expr Glob_term.with_bindings
+(* spiwack: the [Term.constr] argument is the conclusion of the goal,
+   for "casted open constr" *)
+val interp_genarg : interp_sign -> Environ.env -> Evd.evar_map -> Term.constr -> Goal.goal ->
+  glob_generic_argument -> Evd.evar_map * typed_generic_argument
 
 (** Interprets any expression *)
-val val_interp : interp_sign -> goal sigma -> glob_tactic_expr -> Evd.evar_map * value
+val val_interp : interp_sign -> glob_tactic_expr -> (value -> unit Proofview.tactic) -> unit Proofview.tactic
 
 (** Interprets an expression that evaluates to a constr *)
-val interp_ltac_constr : interp_sign -> goal sigma -> glob_tactic_expr ->
-  Evd.evar_map * constr
+val interp_ltac_constr : interp_sign -> glob_tactic_expr -> (constr -> unit Proofview.tactic) -> unit Proofview.tactic
 
 (** Interprets redexp arguments *)
-val dump_glob_red_expr : raw_red_expr -> unit
 val interp_redexp : Environ.env -> Evd.evar_map -> raw_red_expr -> Evd.evar_map * red_expr
 
 (** Interprets tactic expressions *)
-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_hyp : interp_sign -> Environ.env -> Evd.evar_map ->
+  Id.t Loc.located -> Id.t
 
-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_bindings : interp_sign -> Environ.env -> Evd.evar_map ->
+ glob_constr_and_expr bindings -> Evd.evar_map * constr bindings
 
-(* first arguments mean wTC (with type classes resolution) *)
-val interp_open_constr_with_bindings : bool -> interp_sign -> Environ.env -> Evd.evar_map -> 
-  glob_constr_and_expr Glob_term.with_bindings -> Evd.evar_map * constr Glob_term.with_bindings
+val interp_open_constr_with_bindings : interp_sign -> Environ.env -> Evd.evar_map ->
+  glob_constr_and_expr with_bindings -> Evd.evar_map * constr with_bindings
 
 (** 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
+val eval_tactic : glob_tactic_expr -> unit Proofview.tactic
 
-val eval_tactic : glob_tactic_expr -> tactic
+val eval_tactic_ist : interp_sign -> glob_tactic_expr -> unit Proofview.tactic
+(** Same as [eval_tactic], but with the provided [interp_sign]. *)
 
-val interp : raw_tactic_expr -> tactic
+(** Globalization + interpretation *)
 
-val eval_ltac_constr : goal sigma -> raw_tactic_expr -> Evd.evar_map * constr
+val interp_tac_gen : value Id.Map.t -> Id.t list ->
+                 debug_info -> raw_tactic_expr -> unit Proofview.tactic
 
-val subst_tactic : substitution -> glob_tactic_expr -> glob_tactic_expr
+val interp : raw_tactic_expr -> unit Proofview.tactic
 
 (** Hides interpretation for pretty-print *)
 
-val hide_interp : raw_tactic_expr -> tactic option -> tactic
+val hide_interp : bool -> raw_tactic_expr -> unit Proofview.tactic option -> unit Proofview.tactic
 
-(** Declare the xml printer *)
-val declare_xml_printer :
-  (out_channel -> Environ.env -> Evd.evar_map -> constr -> unit) -> unit
+(** Internals that can be useful for syntax extensions. *)
 
-(** printing *)
-val print_ltac : Libnames.qualid -> std_ppcmds
+val interp_ltac_var : (value -> 'a) -> interp_sign ->
+  (Environ.env * Evd.evar_map) option -> Id.t Loc.located -> 'a
 
-(** Internals that can be useful for syntax extensions. *)
+val interp_int : interp_sign -> Id.t Loc.located -> int
 
-exception CannotCoerceTo of string
+val interp_int_or_var : interp_sign -> int or_var -> int
 
-val interp_ltac_var : (value -> 'a) -> interp_sign -> Environ.env option -> identifier located -> 'a
+val error_ltac_variable : Loc.t -> Id.t ->
+  (Environ.env * Evd.evar_map) option -> value -> string -> 'a
 
-val interp_int : interp_sign -> identifier located -> int
+(** Transforms a constr-expecting tactic into a tactic finding its arguments in
+    the Ltac environment according to the given names. *)
+val lift_constr_tac_to_ml_tac : Id.t option list ->
+  (constr list -> Geninterp.interp_sign -> unit Proofview.tactic) -> Tacenv.ml_tactic
 
-val error_ltac_variable : loc -> identifier -> Environ.env option -> value -> string -> 'a
+val default_ist : unit -> Geninterp.interp_sign
+(** Empty ist with debug set on the current value. *)
diff --git a/tactics/tacsubst.ml b/tactics/tacsubst.ml
new file mode 100644
index 00000000..59cd065d
--- /dev/null
+++ b/tactics/tacsubst.ml
@@ -0,0 +1,360 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+open Util
+open Tacexpr
+open Mod_subst
+open Genarg
+open Constrarg
+open Misctypes
+open Globnames
+open Term
+open Genredexpr
+open Patternops
+open Pretyping
+
+(** Substitution of tactics at module closing time *)
+
+(** For generic arguments, we declare and store substitutions
+    in a table *)
+
+let subst_quantified_hypothesis _ x = x
+
+let subst_declared_or_quantified_hypothesis _ x = x
+
+let subst_glob_constr_and_expr subst (c,e) =
+  assert (Option.is_empty e); (* e<>None only for toplevel tactics *)
+  (Detyping.subst_glob_constr subst c,None)
+
+let subst_glob_constr = subst_glob_constr_and_expr (* shortening *)
+
+let subst_binding subst (loc,b,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_glob_constr subst) l)
+  | ExplicitBindings l -> ExplicitBindings (List.map (subst_binding subst) l)
+
+let subst_glob_with_bindings subst (c,bl) =
+  (subst_glob_constr subst c, subst_bindings subst bl)
+
+let subst_glob_with_bindings_arg subst (clear,c) =
+  (clear,subst_glob_with_bindings subst c)
+
+let rec subst_intro_pattern subst = function
+  | loc,IntroAction p -> loc, IntroAction (subst_intro_pattern_action subst p)
+  | loc, IntroNaming _ | loc, IntroForthcoming _ as x -> x
+
+and subst_intro_pattern_action subst = function
+  | IntroApplyOn (t,pat) ->
+      IntroApplyOn (subst_glob_constr subst t,subst_intro_pattern subst pat)
+  | IntroOrAndPattern l ->
+      IntroOrAndPattern (List.map (List.map (subst_intro_pattern subst)) l)
+  | IntroInjection l -> IntroInjection (List.map (subst_intro_pattern subst) l)
+  | IntroWildcard | IntroRewrite _ as x -> x
+
+let subst_induction_arg subst = function
+  | clear,ElimOnConstr c -> clear,ElimOnConstr (subst_glob_with_bindings subst c)
+  | clear,ElimOnAnonHyp n as x -> x
+  | clear,ElimOnIdent id as x -> x
+
+let subst_and_short_name f (c,n) =
+(*  assert (n=None); *)(* since tacdef are strictly globalized *)
+  (f c,None)
+
+let subst_or_var f =  function
+  | ArgVar _ as x -> x
+  | ArgArg x -> ArgArg (f x)
+
+let dloc = Loc.ghost
+
+let subst_located f (_loc,id) = (dloc,f id)
+
+let subst_reference subst =
+  subst_or_var (subst_located (subst_kn subst))
+
+(*CSC: subst_global_reference is used "only" for RefArgType, that propagates
+  to the syntactic non-terminals "global", used in commands such as
+  Print. It is also used for non-evaluable references. *)
+open Pp
+open Printer
+
+let subst_global_reference subst =
+ let subst_global ref =
+  let ref',t' = subst_global subst ref in
+   if not (eq_constr (Universes.constr_of_global ref') t') then
+    msg_warning (strbrk "The reference " ++ pr_global ref ++ str " is not " ++
+          str " expanded to \"" ++ pr_lconstr t' ++ str "\", but to " ++
+          pr_global ref') ;
+   ref'
+ in
+  subst_or_var (subst_located subst_global)
+
+let subst_evaluable subst =
+  let subst_eval_ref = subst_evaluable_reference subst in
+    subst_or_var (subst_and_short_name subst_eval_ref)
+
+let subst_unfold subst (l,e) =
+  (l,subst_evaluable subst 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_glob_constr subst c)
+
+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_glob_constr_or_pattern subst p)
+
+let subst_redexp subst =
+  Miscops.map_red_expr_gen
+    (subst_glob_constr subst)
+    (subst_evaluable subst)
+    (subst_glob_constr_or_pattern subst)
+
+let subst_raw_may_eval subst = function
+  | 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_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 ->
+      Hyp (locs,subst_match_pattern subst mp)
+      :: subst_match_goal_hyps subst tl
+  | Def (locs,mv,mp) :: tl ->
+      Def (locs,subst_match_pattern subst mv, subst_match_pattern subst mp)
+      :: subst_match_goal_hyps subst tl
+  | [] -> []
+
+let rec subst_atomic subst (t:glob_atomic_tactic_expr) = match t with
+  (* Basic tactics *)
+  | TacIntroPattern l -> TacIntroPattern (List.map (subst_intro_pattern subst) l)
+  | TacIntroMove _ as x -> x
+  | TacExact c -> TacExact (subst_glob_constr subst c)
+  | TacApply (a,ev,cb,cl) ->
+      TacApply (a,ev,List.map (subst_glob_with_bindings_arg subst) cb,cl)
+  | TacElim (ev,cb,cbo) ->
+      TacElim (ev,subst_glob_with_bindings_arg subst cb,
+               Option.map (subst_glob_with_bindings subst) cbo)
+  | TacCase (ev,cb) -> TacCase (ev,subst_glob_with_bindings_arg subst cb)
+  | TacFix (idopt,n) as x -> x
+  | TacMutualFix (id,n,l) ->
+      TacMutualFix(id,n,List.map (fun (id,n,c) -> (id,n,subst_glob_constr subst c)) l)
+  | TacCofix idopt as x -> x
+  | TacMutualCofix (id,l) ->
+      TacMutualCofix (id, List.map (fun (id,c) -> (id,subst_glob_constr subst c)) l)
+  | TacAssert (b,otac,na,c) ->
+      TacAssert (b,Option.map (subst_tactic subst) otac,na,subst_glob_constr subst c)
+  | TacGeneralize cl ->
+      TacGeneralize (List.map (on_fst (subst_constr_with_occurrences subst))cl)
+  | TacGeneralizeDep c -> TacGeneralizeDep (subst_glob_constr subst c)
+  | TacLetTac (id,c,clp,b,eqpat) ->
+    TacLetTac (id,subst_glob_constr subst c,clp,b,eqpat)
+
+  (* Automation tactics *)
+  | TacTrivial (d,lems,l) -> TacTrivial (d,List.map (subst_glob_constr subst) lems,l)
+  | TacAuto (d,n,lems,l) -> TacAuto (d,n,List.map (subst_glob_constr subst) lems,l)
+
+  (* Derived basic tactics *)
+  | TacInductionDestruct (isrec,ev,(l,el)) ->
+      let l' = List.map (fun (c,ids,cls) ->
+        subst_induction_arg subst c, ids, cls) l in
+      let el' = Option.map (subst_glob_with_bindings subst) el in
+      TacInductionDestruct (isrec,ev,(l',el'))
+  | TacDoubleInduction (h1,h2) as x -> x
+
+  (* Context management *)
+  | TacClear _ as x -> x
+  | TacClearBody l as x -> x
+  | TacMove (id1,id2) as x -> x
+  | TacRename l as x -> x
+
+  (* Constructors *)
+  | TacSplit (ev,bll) -> TacSplit (ev,List.map (subst_bindings subst) bll)
+
+  (* Conversion *)
+  | TacReduce (r,cl) -> TacReduce (subst_redexp subst r, cl)
+  | TacChange (op,c,cl) ->
+      TacChange (Option.map (subst_glob_constr_or_pattern subst) op,
+        subst_glob_constr subst c, cl)
+
+  (* Equivalence relations *)
+  | TacSymmetry _ as x -> x
+
+  (* Equality and inversion *)
+  | TacRewrite (ev,l,cl,by) ->
+      TacRewrite (ev,
+		  List.map (fun (b,m,c) ->
+			      b,m,subst_glob_with_bindings_arg subst c) l,
+		 cl,Option.map (subst_tactic subst) by)
+  | TacInversion (DepInversion (k,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_glob_constr subst c,cl),hyp)
+
+and subst_tactic subst (t:glob_tactic_expr) = match t with
+  | TacAtom (_loc,t) -> TacAtom (dloc, subst_atomic subst t)
+  | TacFun tacfun -> TacFun (subst_tactic_fun subst tacfun)
+  | TacLetIn (r,l,u) ->
+      let l = List.map (fun (n,b) -> (n,subst_tacarg subst b)) l in
+      TacLetIn (r,l,subst_tactic subst u)
+  | TacMatchGoal (lz,lr,lmr) ->
+      TacMatchGoal(lz,lr, subst_match_rule subst lmr)
+  | TacMatch (lz,c,lmr) ->
+      TacMatch (lz,subst_tactic subst c,subst_match_rule subst lmr)
+  | TacId _ | TacFail _ as x -> x
+  | TacProgress tac -> TacProgress (subst_tactic subst tac:glob_tactic_expr)
+  | TacShowHyps tac -> TacShowHyps (subst_tactic subst tac:glob_tactic_expr)
+  | TacAbstract (tac,s) -> TacAbstract (subst_tactic subst tac,s)
+  | TacThen (t1,t2) ->
+      TacThen (subst_tactic subst t1, subst_tactic subst t2)
+  | TacDispatch tl -> TacDispatch (List.map (subst_tactic subst) tl)
+  | TacExtendTac (tf,t,tl) ->
+      TacExtendTac (Array.map (subst_tactic subst) tf,
+	            subst_tactic subst t,
+                    Array.map (subst_tactic subst) tl)
+  | TacThens (t,tl) ->
+      TacThens (subst_tactic subst t, List.map (subst_tactic subst) tl)
+  | TacThens3parts (t1,tf,t2,tl) ->
+      TacThens3parts (subst_tactic subst t1,Array.map (subst_tactic subst) tf,
+	       subst_tactic subst t2,Array.map (subst_tactic subst) tl)
+  | TacDo (n,tac) -> TacDo (n,subst_tactic subst tac)
+  | TacTimeout (n,tac) -> TacTimeout (n,subst_tactic subst tac)
+  | TacTime (s,tac) -> TacTime (s,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)
+  | TacOr (tac1,tac2) ->
+      TacOr (subst_tactic subst tac1,subst_tactic subst tac2)
+  | TacOnce tac ->
+      TacOnce (subst_tactic subst tac)
+  | TacExactlyOnce tac ->
+      TacExactlyOnce (subst_tactic subst tac)
+  | TacIfThenCatch (tac,tact,tace) ->
+      TacIfThenCatch (
+        subst_tactic subst tac,
+        subst_tactic subst tact,
+        subst_tactic subst tace)
+  | TacOrelse (tac1,tac2) ->
+      TacOrelse (subst_tactic subst tac1,subst_tactic subst tac2)
+  | 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 (dloc,subst_tacarg subst a)
+
+  (* For extensions *)
+  | TacAlias (_,s,l) ->
+      let s = subst_kn subst s in
+      TacAlias (dloc,s,List.map (fun (id,a) -> (id,subst_genarg subst a)) l)
+  | TacML (_loc,opn,l) -> TacML (dloc,opn,List.map (subst_genarg subst) l)
+
+and subst_tactic_fun subst (var,body) = (var,subst_tactic subst body)
+
+and subst_tacarg subst = function
+  | Reference r -> Reference (subst_reference subst r)
+  | ConstrMayEval c -> ConstrMayEval (subst_raw_may_eval subst c)
+  | UConstr c -> UConstr (subst_glob_constr subst c)
+  | MetaIdArg (_loc,_,_) -> assert false
+  | TacCall (_loc,f,l) ->
+      TacCall (_loc, subst_reference subst f, List.map (subst_tacarg subst) l)
+  | TacFreshId _ as x -> x
+  | TacPretype c -> TacPretype (subst_glob_constr subst c)
+  | TacNumgoals -> TacNumgoals
+  | Tacexp t -> Tacexp (subst_tactic subst t)
+  | TacGeneric arg -> TacGeneric (Genintern.generic_substitute subst arg)
+  | TacDynamic(the_loc,t) as x ->
+      (match Dyn.tag t with
+	| "tactic" | "value" -> x
+        | "constr" ->
+          TacDynamic(the_loc, constr_in (subst_mps subst (constr_out t)))
+	| s -> Errors.anomaly ~loc:dloc ~label:"Tacinterp.val_interp"
+                 (str "Unknown dynamic: <" ++ str s ++ str ">"))
+
+(* Reads the rules of a Match Context or a Match *)
+and subst_match_rule subst = function
+  | (All tc)::tl ->
+      (All (subst_tactic subst tc))::(subst_match_rule subst tl)
+  | (Pat (rl,mp,tc))::tl ->
+      let hyps = subst_match_goal_hyps subst rl in
+      let pat = subst_match_pattern subst mp in
+      Pat (hyps,pat,subst_tactic subst tc)
+      ::(subst_match_rule subst tl)
+  | [] -> []
+
+and subst_genarg subst (x:glob_generic_argument) =
+  match genarg_tag x with
+  | IntOrVarArgType -> in_gen (glbwit wit_int_or_var) (out_gen (glbwit wit_int_or_var) x)
+  | IdentArgType ->
+      in_gen (glbwit wit_ident) (out_gen (glbwit wit_ident) x)
+  | VarArgType -> in_gen (glbwit wit_var) (out_gen (glbwit wit_var) x)
+  | GenArgType -> in_gen (glbwit wit_genarg) (subst_genarg subst (out_gen (glbwit wit_genarg) x))
+  | ConstrArgType ->
+      in_gen (glbwit wit_constr) (subst_glob_constr subst (out_gen (glbwit wit_constr) x))
+  | ConstrMayEvalArgType ->
+      in_gen (glbwit wit_constr_may_eval) (subst_raw_may_eval subst (out_gen (glbwit wit_constr_may_eval) x))
+  | QuantHypArgType ->
+      in_gen (glbwit wit_quant_hyp)
+        (subst_declared_or_quantified_hypothesis subst
+          (out_gen (glbwit wit_quant_hyp) x))
+  | RedExprArgType ->
+      in_gen (glbwit wit_red_expr) (subst_redexp subst (out_gen (glbwit wit_red_expr) x))
+  | OpenConstrArgType ->
+      in_gen (glbwit wit_open_constr)
+        ((),subst_glob_constr subst (snd (out_gen (glbwit wit_open_constr) x)))
+  | ConstrWithBindingsArgType ->
+      in_gen (glbwit wit_constr_with_bindings)
+        (subst_glob_with_bindings subst (out_gen (glbwit wit_constr_with_bindings) x))
+  | BindingsArgType ->
+      in_gen (glbwit wit_bindings)
+        (subst_bindings subst (out_gen (glbwit wit_bindings) x))
+  | ListArgType _ ->
+    let list_unpacker wit l =
+      let map x =
+        let ans = subst_genarg subst (in_gen (glbwit wit) x) in
+        out_gen (glbwit wit) ans
+      in
+      in_gen (glbwit (wit_list wit)) (List.map map (glb l))
+    in
+    list_unpack { list_unpacker } x
+  | OptArgType _ ->
+    let opt_unpacker wit o = match glb o with
+    | None -> in_gen (glbwit (wit_opt wit)) None
+    | Some x ->
+      let s = out_gen (glbwit wit) (subst_genarg subst (in_gen (glbwit wit) x)) in
+      in_gen (glbwit (wit_opt wit)) (Some s)
+    in
+    opt_unpack { opt_unpacker } x
+  | PairArgType _ ->
+      let pair_unpacker wit1 wit2 o =
+        let p, q = glb o in
+        let p = out_gen (glbwit wit1) (subst_genarg subst (in_gen (glbwit wit1) p)) in
+        let q = out_gen (glbwit wit2) (subst_genarg subst (in_gen (glbwit wit2) q)) in
+        in_gen (glbwit (wit_pair wit1 wit2)) (p, q)
+      in
+      pair_unpack { pair_unpacker } x
+  | ExtraArgType s ->
+      Genintern.generic_substitute subst x
+
+(** Registering *)
+
+let () =
+  Genintern.register_subst0 wit_ref subst_global_reference;
+  Genintern.register_subst0 wit_intro_pattern (fun _ v -> v);
+  Genintern.register_subst0 wit_tactic subst_tactic;
+  Genintern.register_subst0 wit_sort (fun _ v -> v);
+  Genintern.register_subst0 wit_clause_dft_concl (fun _ v -> v);
+  Genintern.register_subst0 wit_uconstr (fun subst c -> subst_glob_constr subst c)
diff --git a/tactics/tacsubst.mli b/tactics/tacsubst.mli
new file mode 100644
index 00000000..52f21ed7
--- /dev/null
+++ b/tactics/tacsubst.mli
@@ -0,0 +1,30 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+open Tacexpr
+open Mod_subst
+open Genarg
+open Misctypes
+
+(** Substitution of tactics at module closing time *)
+
+val subst_tactic : substitution -> glob_tactic_expr -> glob_tactic_expr
+
+(** For generic arguments, we declare and store substitutions
+    in a table *)
+
+val subst_genarg : substitution -> glob_generic_argument -> glob_generic_argument
+
+(** Misc *)
+
+val subst_glob_constr_and_expr :
+  substitution -> glob_constr_and_expr -> glob_constr_and_expr
+
+val subst_glob_with_bindings : substitution ->
+  glob_constr_and_expr with_bindings ->
+  glob_constr_and_expr with_bindings
diff --git a/tactics/tactic_matching.ml b/tactics/tactic_matching.ml
new file mode 100644
index 00000000..4e3624fb
--- /dev/null
+++ b/tactics/tactic_matching.ml
@@ -0,0 +1,373 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(** This file extends Matching with the main logic for Ltac's
+    (lazy)match and (lazy)match goal. *)
+
+open Names
+open Tacexpr
+
+(** [t] is the type of matching successes. It ultimately contains a
+    {!Tacexpr.glob_tactic_expr} representing the left-hand side of the
+    corresponding matching rule, a matching substitution to be
+    applied, a context substitution mapping identifier to context like
+    those of {!Matching.matching_result}), and a {!Term.constr}
+    substitution mapping corresponding to matched hypotheses. *)
+type 'a t = {
+  subst : Constr_matching.bound_ident_map * Pattern.extended_patvar_map ;
+  context : Term.constr Id.Map.t;
+  terms : Term.constr Id.Map.t;
+  lhs : 'a;
+}
+
+
+
+(** {6 Utilities} *)
+
+
+(** Some of the functions of {!Matching} return the substitution with a
+    [patvar_map] instead of an [extended_patvar_map]. [adjust] coerces
+    substitution of the former type to the latter. *)
+let adjust : Constr_matching.bound_ident_map * Pattern.patvar_map ->
+             Constr_matching.bound_ident_map * Pattern.extended_patvar_map =
+  fun (l, lc) -> (l, Id.Map.map (fun c -> [], c) lc)
+
+
+(** Adds a binding to a {!Id.Map.t} if the identifier is [Some id] *)
+let id_map_try_add id x m =
+  match id with
+  | Some id -> Id.Map.add id x m
+  | None -> m
+
+(** Adds a binding to a {!Id.Map.t} if the name is [Name id] *)
+let id_map_try_add_name id x m =
+  match id with
+  | Name id -> Id.Map.add id x m
+  | Anonymous -> m
+
+(** Takes the union of two {!Id.Map.t}. If there is conflict,
+    the binding of the right-hand argument shadows that of the left-hand
+    argument. *)
+let id_map_right_biased_union m1 m2 =
+  if Id.Map.is_empty m1 then m2 (** Don't reconstruct the whole map *)
+  else Id.Map.fold Id.Map.add m2 m1
+
+(** Tests whether the substitution [s] is empty. *)
+let is_empty_subst (ln,lm) =
+  Id.Map.(is_empty ln && is_empty lm)
+
+(** {6 Non-linear patterns} *)
+
+
+(** The patterns of Ltac are not necessarily linear. Non-linear
+    pattern are partially handled by the {!Matching} module, however
+    goal patterns are not primitive to {!Matching}, hence we must deal
+    with non-linearity between hypotheses and conclusion. Subterms are
+    considered equal up to the equality implemented in
+    [equal_instances]. *)
+(* spiwack: it doesn't seem to be quite the same rule for non-linear
+   term patterns and non-linearity between hypotheses and/or
+   conclusion. Indeed, in [Matching], matching is made modulo
+   syntactic equality, and here we merge modulo conversion. It may be
+   a good idea to have an entry point of [Matching] with a partial
+   substitution as argument instead of merging substitution here. That
+   would ensure consistency. *)
+let equal_instances env sigma (ctx',c') (ctx,c) =
+  (* How to compare instances? Do we want the terms to be convertible?
+     unifiable? Do we want the universe levels to be relevant? 
+     (historically, conv_x is used) *)
+  CList.equal Id.equal ctx ctx' && Reductionops.is_conv env sigma c' c
+
+
+(** Merges two substitutions. Raises [Not_coherent_metas] when
+    encountering two instances of the same metavariable which are not
+    equal according to {!equal_instances}. *)
+exception Not_coherent_metas
+let verify_metas_coherence env sigma (ln1,lcm) (ln,lm) =
+  let merge id oc1 oc2 = match oc1, oc2 with
+    | None, None -> None
+    | None, Some c | Some c, None -> Some c
+    | Some c1, Some c2 ->
+        if equal_instances env sigma c1 c2 then Some c1
+        else raise Not_coherent_metas
+  in
+  let (+++) lfun1 lfun2 = Id.Map.fold Id.Map.add lfun1 lfun2 in
+  (** ppedrot: Is that even correct? *)
+  let merged = ln +++ ln1 in
+  (merged, Id.Map.merge merge lcm lm)
+
+let matching_error =
+  Errors.UserError ("tactic matching" , Pp.str "No matching clauses for match.")
+
+let imatching_error = (matching_error, Exninfo.null)
+
+(** A functor is introduced to share the environment and the
+    evar_map. They do not change and it would be a pity to introduce
+    closures everywhere just for the occasional calls to
+    {!equal_instances}. *)
+module type StaticEnvironment = sig
+  val env : Environ.env
+  val sigma : Evd.evar_map
+end
+module PatternMatching (E:StaticEnvironment) = struct
+
+
+  (** {6 The pattern-matching monad } *)
+
+
+  (** To focus on the algorithmic portion of pattern-matching, the
+      bookkeeping is relegated to a monad: the composition of the
+      bactracking monad of {!IStream.t} with a "writer" effect. *)
+  (* spiwack: as we don't benefit from the various stream optimisations
+     of Haskell, it may be costly to give the monad in direct style such as
+     here. We may want to use some continuation passing style. *)
+  type 'a tac = 'a Proofview.tactic
+  type 'a m = { stream : 'r. ('a -> unit t -> 'r tac) -> unit t -> 'r tac }
+
+  (** The empty substitution. *)
+  let empty_subst = Id.Map.empty , Id.Map.empty
+
+  (** Composes two substitutions using {!verify_metas_coherence}. It
+      must be a monoid with neutral element {!empty_subst}. Raises
+      [Not_coherent_metas] when composition cannot be achieved. *)
+  let subst_prod s1 s2 =
+    if is_empty_subst s1 then s2
+    else if is_empty_subst s2 then s1
+    else verify_metas_coherence E.env E.sigma s1 s2
+
+  (** The empty context substitution. *)
+  let empty_context_subst = Id.Map.empty
+
+  (** Compose two context substitutions, in case of conflict the
+      right hand substitution shadows the left hand one. *)
+  let context_subst_prod = id_map_right_biased_union
+
+  (** The empty term substitution. *)
+  let empty_term_subst = Id.Map.empty
+
+  (** Compose two terms substitutions, in case of conflict the
+      right hand substitution shadows the left hand one. *)
+  let term_subst_prod = id_map_right_biased_union
+
+  (** Merge two writers (and ignore the first value component). *)
+  let merge m1 m2 =
+    try Some {
+      subst = subst_prod m1.subst m2.subst;
+      context = context_subst_prod m1.context m2.context;
+      terms = term_subst_prod m1.terms m2.terms;
+      lhs = m2.lhs;
+    }
+    with Not_coherent_metas -> None
+
+  (** Monadic [return]: returns a single success with empty substitutions. *)
+  let return (type a) (lhs:a) : a m =
+    { stream = fun k ctx -> k lhs ctx }
+
+  (** Monadic bind: each success of [x] is replaced by the successes
+      of [f x]. The substitutions of [x] and [f x] are composed,
+      dropping the apparent successes when the substitutions are not
+      coherent. *)
+  let (>>=) (type a) (type b) (m:a m) (f:a -> b m) : b m =
+    { stream = fun k ctx -> m.stream (fun x ctx -> (f x).stream k ctx) ctx }
+
+  (** A variant of [(>>=)] when the first argument returns [unit]. *)
+  let (<*>) (type a) (m:unit m) (y:a m) : a m =
+    { stream = fun k ctx -> m.stream (fun () ctx -> y.stream k ctx) ctx }
+
+  (** Failure of the pattern-matching monad: no success. *)
+  let fail (type a) : a m = { stream = fun _ _ -> Proofview.tclZERO matching_error }
+
+  let run (m : 'a m) =
+    let ctx = {
+      subst = empty_subst ;
+      context = empty_context_subst ;
+      terms = empty_term_subst ;
+      lhs = ();
+    } in
+    let eval lhs ctx = Proofview.tclUNIT { ctx with lhs } in
+    m.stream eval ctx
+
+  (** Chooses in a list, in the same order as the list *)
+  let rec pick (l:'a list) (e, info) : 'a m = match l with
+  | [] -> { stream = fun _ _ -> Proofview.tclZERO ~info e }
+  | x :: l ->
+    { stream = fun k ctx -> Proofview.tclOR (k x ctx) (fun e -> (pick l e).stream k ctx) }
+
+  let pick l = pick l imatching_error
+
+  (** Declares a subsitution, a context substitution and a term substitution. *)
+  let put subst context terms : unit m =
+    let s = { subst ; context ; terms ; lhs = () } in
+    { stream = fun k ctx -> match merge s ctx with None -> Proofview.tclZERO matching_error | Some s -> k () s }
+
+  (** Declares a substitution. *)
+  let put_subst subst : unit m = put subst empty_context_subst empty_term_subst
+
+  (** Declares a term substitution. *)
+  let put_terms terms : unit m = put empty_subst empty_context_subst terms
+
+
+
+  (** {6 Pattern-matching} *)
+
+
+  (** [wildcard_match_term lhs] matches a term against a wildcard
+      pattern ([_ => lhs]). It has a single success with an empty
+      substitution. *)
+  let wildcard_match_term = return
+
+  (** [pattern_match_term refresh pat term lhs] returns the possible
+      matchings of [term] with the pattern [pat => lhs]. If refresh is
+      true, refreshes the universes of [term]. *)
+  let pattern_match_term refresh pat term lhs = 
+(*     let term = if refresh then Termops.refresh_universes_strict term else term in *)
+    match pat with
+    | Term p ->
+        begin 
+          try
+            put_subst (Constr_matching.extended_matches E.env E.sigma p term) <*>
+            return lhs
+          with Constr_matching.PatternMatchingFailure -> fail
+        end
+    | Subterm (with_app_context,id_ctxt,p) ->
+
+      let rec map s (e, info) =
+        { stream = fun k ctx -> match IStream.peek s with
+          | IStream.Nil -> Proofview.tclZERO ~info e
+          | IStream.Cons ({ Constr_matching.m_sub ; m_ctx }, s) ->
+            let subst = adjust m_sub in
+            let context = id_map_try_add id_ctxt m_ctx Id.Map.empty in
+            let terms = empty_term_subst in
+            let nctx = { subst ; context ; terms ; lhs = () } in
+            match merge ctx nctx with
+            | None -> (map s (e, info)).stream k ctx
+            | Some nctx -> Proofview.tclOR (k lhs nctx) (fun e -> (map s e).stream k ctx)
+        }
+      in
+      map (Constr_matching.match_subterm_gen E.env E.sigma with_app_context p term) imatching_error
+
+
+  (** [rule_match_term term rule] matches the term [term] with the
+      matching rule [rule]. *)
+  let rule_match_term term = function
+    | All lhs -> wildcard_match_term lhs
+    | Pat ([],pat,lhs) -> pattern_match_term false pat term lhs
+    | Pat _ ->
+        (** Rules with hypotheses, only work in match goal. *)
+        fail
+
+  (** [match_term term rules] matches the term [term] with the set of
+      matching rules [rules].*)
+  let rec match_term (e, info) term rules = match rules with
+  | [] -> { stream = fun _ _ -> Proofview.tclZERO ~info e }
+  | r :: rules ->
+    { stream = fun k ctx ->
+      let head = rule_match_term term r in
+      let tail e = match_term e term rules in
+      Proofview.tclOR (head.stream k ctx) (fun e -> (tail e).stream k ctx)
+    }
+
+
+  (** [hyp_match_type hypname pat hyps] matches a single
+      hypothesis pattern [hypname:pat] against the hypotheses in
+      [hyps]. Tries the hypotheses in order. For each success returns
+      the name of the matched hypothesis. *)
+  let hyp_match_type hypname pat hyps =
+    pick hyps >>= fun (id,b,hyp) ->
+    let refresh = not (Option.is_empty b) in
+    pattern_match_term refresh pat hyp () <*>
+    put_terms (id_map_try_add_name hypname (Term.mkVar id) empty_term_subst) <*>
+    return id
+
+  (** [hyp_match_type hypname bodypat typepat hyps] matches a single
+      hypothesis pattern [hypname := bodypat : typepat] against the
+      hypotheses in [hyps].Tries the hypotheses in order. For each
+      success returns the name of the matched hypothesis. *)
+  let hyp_match_body_and_type hypname bodypat typepat hyps =
+    pick hyps >>= function
+      | (id,Some body,hyp) ->
+          pattern_match_term false bodypat body () <*>
+          pattern_match_term true typepat hyp () <*>
+          put_terms (id_map_try_add_name hypname (Term.mkVar id) empty_term_subst) <*>
+          return id
+      | (id,None,hyp) -> fail
+
+  (** [hyp_match pat hyps] dispatches to
+      {!hyp_match_type} or {!hyp_match_body_and_type} depending on whether
+      [pat] is [Hyp _] or [Def _]. *)
+  let hyp_match pat hyps =
+    match pat with
+    | Hyp ((_,hypname),typepat) ->
+        hyp_match_type hypname typepat hyps
+    | Def ((_,hypname),bodypat,typepat) ->
+        hyp_match_body_and_type hypname bodypat typepat hyps
+
+  (** [hyp_pattern_list_match pats hyps lhs], matches the list of
+      patterns [pats] against the hypotheses in [hyps], and eventually
+      returns [lhs]. *)
+  let rec hyp_pattern_list_match pats hyps lhs =
+    match pats with
+    | pat::pats ->
+        hyp_match pat hyps >>= fun matched_hyp ->
+        (* spiwack: alternatively it is possible to return the list
+           with the matched hypothesis removed directly in
+           [hyp_match]. *)
+        let select_matched_hyp (id,_,_) = Id.equal id matched_hyp in
+        let hyps = CList.remove_first select_matched_hyp hyps in
+        hyp_pattern_list_match pats hyps lhs
+    | [] -> return lhs
+
+  (** [rule_match_goal hyps concl rule] matches the rule [rule]
+      against the goal [hyps|-concl]. *)
+  let rule_match_goal hyps concl = function
+    | All lhs -> wildcard_match_term lhs
+    | Pat (hyppats,conclpat,lhs) ->
+        (* the rules are applied from the topmost one (in the concrete
+           syntax) to the bottommost. *)
+        let hyppats = List.rev hyppats in
+        pattern_match_term false conclpat concl () <*>
+        hyp_pattern_list_match hyppats hyps lhs
+
+  (** [match_goal hyps concl rules] matches the goal [hyps|-concl]
+      with the set of matching rules [rules]. *)
+  let rec match_goal (e, info) hyps concl rules = match rules with
+  | [] -> { stream = fun _ _ -> Proofview.tclZERO ~info e }
+  | r :: rules ->
+    { stream = fun k ctx ->
+      let head = rule_match_goal hyps concl r in
+      let tail e = match_goal e hyps concl rules in
+      Proofview.tclOR (head.stream k ctx) (fun e -> (tail e).stream k ctx)
+    }
+
+end
+
+(** [match_term env sigma term rules] matches the term [term] with the
+    set of matching rules [rules]. The environment [env] and the
+    evar_map [sigma] are not currently used, but avoid code
+    duplication. *)
+let match_term env sigma term rules =
+  let module E = struct
+    let env = env
+    let sigma = sigma
+  end in
+  let module M = PatternMatching(E) in
+  M.run (M.match_term imatching_error term rules)
+
+
+(** [match_goal env sigma hyps concl rules] matches the goal
+    [hyps|-concl] with the set of matching rules [rules]. The
+    environment [env] and the evar_map [sigma] are used to check
+    convertibility for pattern variables shared between hypothesis
+    patterns or the conclusion pattern. *)
+let match_goal env sigma hyps concl rules =
+  let module E = struct
+    let env = env
+    let sigma = sigma
+  end in
+  let module M = PatternMatching(E) in
+  M.run (M.match_goal imatching_error hyps concl rules)
diff --git a/tactics/tactic_matching.mli b/tactics/tactic_matching.mli
new file mode 100644
index 00000000..abeb47c3
--- /dev/null
+++ b/tactics/tactic_matching.mli
@@ -0,0 +1,49 @@
+ (************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(** This file extends Matching with the main logic for Ltac's
+    (lazy)match and (lazy)match goal. *)
+
+
+(** [t] is the type of matching successes. It ultimately contains a
+    {!Tacexpr.glob_tactic_expr} representing the left-hand side of the
+    corresponding matching rule, a matching substitution to be
+    applied, a context substitution mapping identifier to context like
+    those of {!Matching.matching_result}), and a {!Term.constr}
+    substitution mapping corresponding to matched hypotheses. *)
+type 'a t = {
+  subst : Constr_matching.bound_ident_map * Pattern.extended_patvar_map ;
+  context : Term.constr Names.Id.Map.t;
+  terms : Term.constr Names.Id.Map.t;
+  lhs : 'a;
+}
+
+
+(** [match_term env sigma term rules] matches the term [term] with the
+    set of matching rules [rules]. The environment [env] and the
+    evar_map [sigma] are not currently used, but avoid code
+    duplication. *)
+val match_term :
+  Environ.env ->
+  Evd.evar_map ->
+  Term.constr ->
+  (Pattern.constr_pattern, Tacexpr.glob_tactic_expr) Tacexpr.match_rule list ->
+  Tacexpr.glob_tactic_expr t Proofview.tactic
+
+(** [match_goal env sigma hyps concl rules] matches the goal
+    [hyps|-concl] with the set of matching rules [rules]. The
+    environment [env] and the evar_map [sigma] are used to check
+    convertibility for pattern variables shared between hypothesis
+    patterns or the conclusion pattern. *)
+val match_goal:
+  Environ.env ->
+  Evd.evar_map ->
+  Context.named_context ->
+  Term.constr ->
+  (Pattern.constr_pattern, Tacexpr.glob_tactic_expr) Tacexpr.match_rule list ->
+  Tacexpr.glob_tactic_expr t Proofview.tactic
diff --git a/tactics/tactic_option.ml b/tactics/tactic_option.ml
index 1ea8dbcb..34245c6a 100644
--- a/tactics/tactic_option.ml
+++ b/tactics/tactic_option.ml
@@ -1,29 +1,33 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
 open Libobject
-open Proof_type
 open Pp
 
 let declare_tactic_option ?(default=Tacexpr.TacId []) name =
-  let default_tactic_expr : Tacexpr.glob_tactic_expr ref = ref default in
-  let default_tactic : Proof_type.tactic ref = ref (Tacinterp.eval_tactic !default_tactic_expr) in
-  let locality = ref false in
-  let set_default_tactic local t = 
+  let locality = Summary.ref false ~name:(name^"-locality") in
+  let default_tactic_expr : Tacexpr.glob_tactic_expr ref =
+    Summary.ref default ~name:(name^"-default-tacexpr")
+  in
+  let default_tactic : Tacexpr.glob_tactic_expr ref =
+    Summary.ref !default_tactic_expr ~name:(name^"-default-tactic")
+  in
+  let set_default_tactic local t =
     locality := local;
-    default_tactic_expr := t; default_tactic := Tacinterp.eval_tactic t 
+    default_tactic_expr := t;
+    default_tactic := t
   in
   let cache (_, (local, tac)) = set_default_tactic local tac in
   let load (_, (local, tac)) =
     if not local then set_default_tactic local tac
   in
   let subst (s, (local, tac)) =
-    (local, Tacinterp.subst_tactic s tac)
+    (local, Tacsubst.subst_tactic s tac)
   in
   let input : bool * Tacexpr.glob_tactic_expr -> obj =
     declare_object
@@ -39,17 +43,9 @@ let declare_tactic_option ?(default=Tacexpr.TacId []) name =
     set_default_tactic local tac;
     Lib.add_anonymous_leaf (input (local, tac))
   in
-  let get () = !locality, !default_tactic in
+  let get () = !locality, Tacinterp.eval_tactic !default_tactic in
   let print () = 
     Pptactic.pr_glob_tactic (Global.env ()) !default_tactic_expr ++
       (if !locality then str" (locally defined)" else str" (globally defined)")
   in
-  let freeze () = !locality, !default_tactic_expr in
-  let unfreeze (local, t) = set_default_tactic local t in
-  let init () = () in
-    Summary.declare_summary name
-      { Summary.freeze_function = freeze;
-        Summary.unfreeze_function = unfreeze;
-        Summary.init_function = init };
-    put, get, print
-      
+  put, get, print
diff --git a/tactics/tactic_option.mli b/tactics/tactic_option.mli
index 1e59b901..ffbd5116 100644
--- a/tactics/tactic_option.mli
+++ b/tactics/tactic_option.mli
@@ -1,16 +1,15 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-open Proof_type
 open Tacexpr
 open Vernacexpr
 
 val declare_tactic_option : ?default:Tacexpr.glob_tactic_expr -> string -> 
   (* put *) (locality_flag -> glob_tactic_expr -> unit) *
-  (* get *) (unit -> locality_flag * tactic) *
+  (* get *) (unit -> locality_flag * unit Proofview.tactic) *
   (* print *) (unit -> Pp.std_ppcmds)
diff --git a/tactics/tacticals.ml b/tactics/tacticals.ml
index dcc70edb..cf2126f8 100644
--- a/tactics/tacticals.ml
+++ b/tactics/tacticals.ml
@@ -1,37 +1,27 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
 open Pp
+open Errors
 open Util
 open Names
 open Term
 open Termops
-open Sign
+open Context
 open Declarations
-open Inductive
-open Reduction
-open Environ
-open Libnames
-open Refiner
 open Tacmach
 open Clenv
-open Clenvtac
-open Glob_term
-open Pattern
-open Matching
-open Genarg
-open Tacexpr
+open Misctypes
 
 (************************************************************************)
 (* Tacticals re-exported from the Refiner module                        *)
 (************************************************************************)
 
-let tclNORMEVAR      = Refiner.tclNORMEVAR
 let tclIDTAC         = Refiner.tclIDTAC
 let tclIDTAC_MESSAGE = Refiner.tclIDTAC_MESSAGE
 let tclORELSE0       = Refiner.tclORELSE0
@@ -58,9 +48,9 @@ let tclAT_LEAST_ONCE = Refiner.tclAT_LEAST_ONCE
 let tclFAIL          = Refiner.tclFAIL
 let tclFAIL_lazy     = Refiner.tclFAIL_lazy
 let tclDO            = Refiner.tclDO
-let tclTIMEOUT       = Refiner.tclTIMEOUT
 let tclWEAK_PROGRESS = Refiner.tclWEAK_PROGRESS
 let tclPROGRESS      = Refiner.tclPROGRESS
+let tclSHOWHYPS      = Refiner.tclSHOWHYPS
 let tclNOTSAMEGOAL   = Refiner.tclNOTSAMEGOAL
 let tclTHENTRY       = Refiner.tclTHENTRY
 let tclIFTHENELSE    = Refiner.tclIFTHENELSE
@@ -72,13 +62,6 @@ let tclIFTHENTRYELSEMUST = Refiner.tclIFTHENTRYELSEMUST
 
 let tclTHENSEQ       = tclTHENLIST
 
-(* Experimental *)
-
-let rec tclFIRST_PROGRESS_ON tac = function
-  | []    -> tclFAIL 0 (str "No applicable tactic")
-  | [a]   -> tac a (* so that returned failure is the one from last item *)
-  | a::tl -> tclORELSE (tac a) (tclFIRST_PROGRESS_ON tac tl)
-
 (************************************************************************)
 (* Tacticals applying on hypotheses                                     *)
 (************************************************************************)
@@ -95,7 +78,7 @@ let lastHypId gl  = nthHypId 1 gl
 let lastHyp gl    = nthHyp 1 gl
 
 let nLastDecls n gl =
-  try list_firstn n (pf_hyps gl)
+  try List.firstn n (pf_hyps gl)
   with Failure _ -> error "Not enough hypotheses in the goal."
 
 let nLastHypsId n gl = List.map pi1 (nLastDecls n gl)
@@ -116,7 +99,7 @@ let onNLastHypsId n tac = onHyps (nLastHypsId n) tac
 let onNLastHyps n tac   = onHyps (nLastHyps n) tac
 
 let afterHyp id gl =
-  fst (list_split_when (fun (hyp,_,_) -> hyp = id) (pf_hyps gl))
+  fst (List.split_when (fun (hyp,_,_) -> Id.equal hyp id) (pf_hyps gl))
 
 (***************************************)
 (*           Clause Tacticals          *)
@@ -130,53 +113,17 @@ let afterHyp id gl =
    --Eduardo (8/8/97)
 *)
 
-(* A [simple_clause] is a set of hypotheses, possibly extended with
-   the conclusion (conclusion is represented by None) *)
-
-type simple_clause = identifier option list
-
-(* An [clause] is the algebraic form of a
-   [concrete_clause]; it may refer to all hypotheses
-   independently of the effective contents of the current goal *)
-
-type clause = identifier gclause
-
-let allHypsAndConcl = { onhyps=None; concl_occs=all_occurrences_expr }
-let allHyps = { onhyps=None; concl_occs=no_occurrences_expr }
-let onConcl = { onhyps=Some[]; concl_occs=all_occurrences_expr }
-let onHyp id =
-  { onhyps=Some[((all_occurrences_expr,id),InHyp)];
-    concl_occs=no_occurrences_expr }
-
-let simple_clause_of cl gls =
-  let error_occurrences () =
-    error "This tactic does not support occurrences selection" in
-  let error_body_selection () =
-    error "This tactic does not support body selection" in
-  let hyps =
-    match cl.onhyps with
-    | None ->
-	List.map Option.make (pf_ids_of_hyps gls)
-    | Some l ->
-	List.map (fun ((occs,id),w) ->
-	  if occs <> all_occurrences_expr then error_occurrences ();
-	  if w = InHypValueOnly then error_body_selection ();
-	  Some id) l in
-  if cl.concl_occs = no_occurrences_expr then hyps
-  else
-    if cl.concl_occs <> all_occurrences_expr then error_occurrences ()
-    else None :: hyps
-
 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 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 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
+let onClause tac cl gls =
+  let hyps () = pf_ids_of_hyps gls in
+  tclMAP tac (Locusops.simple_clause_of hyps cl) gls
+let onClauseLR tac cl gls =
+  let hyps () = pf_ids_of_hyps gls in
+  tclMAP tac (List.rev (Locusops.simple_clause_of hyps cl)) gls
 
 let ifOnHyp pred tac1 tac2 id gl =
   if pred (id,pf_get_hyp_typ gl id) then
@@ -184,52 +131,6 @@ let ifOnHyp pred tac1 tac2 id gl =
   else
     tac2 id gl
 
-
-(************************************************************************)
-(* An intermediate form of occurrence clause that select components     *)
-(* of a definition, hypotheses and possibly the goal                    *)
-(* (used for reduction tactics)                                         *)
-(************************************************************************)
-
-(* 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
-   body if any, in type or in both) or the goal *)
-
-type goal_location = hyp_location option
-
-(************************************************************************)
-(* An intermediate structure for dealing with occurrence clauses        *)
-(************************************************************************)
-
-(* [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 *)
-
-type clause_atom =
-  | OnHyp of identifier * occurrences_expr * hyp_location_flag
-  | OnConcl of occurrences_expr
-
-(* A [concrete_clause] is an effective collection of
-  occurrences in the hypotheses and the conclusion *)
-
-type concrete_clause = clause_atom list
-
-let concrete_clause_of cl gls =
-  let hyps =
-    match cl.onhyps with
-    | None ->
-	let f id = OnHyp (id,all_occurrences_expr,InHyp) in
-	List.map f (pf_ids_of_hyps gls)
-    | Some l ->
-	List.map (fun ((occs,id),w) -> OnHyp (id,occs,w)) l in
-  if cl.concl_occs = no_occurrences_expr then hyps
-  else
-    OnConcl cl.concl_occs :: hyps
-
 (************************************************************************)
 (* Elimination Tacticals                                                *)
 (************************************************************************)
@@ -243,14 +144,14 @@ let concrete_clause_of cl gls =
   the elimination. *)
 
 type branch_args = {
-  ity        : inductive;   (* the type we were eliminating on *)
+  ity        : pinductive;   (* the type we were eliminating on *)
   largs      : constr list; (* its arguments *)
   branchnum  : int;         (* the branch number *)
   pred       : constr;      (* the predicate we used *)
   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}
+  branchnames : Tacexpr.intro_patterns}
 
 type branch_assumptions = {
   ba        : branch_args;     (* the branch args *)
@@ -261,11 +162,13 @@ let fix_empty_or_and_pattern nv l =
      names and "[ ]" for no clause at all *)
   (* 2- More generally, we admit "[ ]" for any disjunctive pattern of
      arbitrary length *)
-  if l = [[]] then list_make nv [] else l
+  match l with
+  | [[]] -> List.make nv []
+  | _ -> l
 
 let check_or_and_pattern_size loc names n =
-  if List.length names <> n then
-    if n = 1 then
+  if not (Int.equal (List.length names) n) then
+    if Int.equal n 1 then
       user_err_loc (loc,"",str "Expects a conjunctive pattern.")
     else
       user_err_loc (loc,"",str "Expects a disjunctive pattern with " ++ int n
@@ -274,31 +177,29 @@ let check_or_and_pattern_size loc names n =
 let compute_induction_names n = function
   | None ->
       Array.make n []
-  | Some (loc,IntroOrAndPattern names) ->
+  | Some (loc,names) ->
       let names = fix_empty_or_and_pattern n names in
       check_or_and_pattern_size loc names n;
       Array.of_list names
-  | Some (loc,_) ->
-      user_err_loc (loc,"",str "Disjunctive/conjunctive introduction pattern expected.")
 
-let compute_construtor_signatures isrec (_,k as ity) =
+let compute_construtor_signatures isrec ((_,k as ity),u) =
   let rec analrec c recargs =
     match kind_of_term c, recargs with
     | Prod (_,_,c), recarg::rest ->
-	let b = match dest_recarg recarg with
+	let b = match Declareops.dest_recarg recarg with
 	  | Norec | Imbr _  -> false
-	  | Mrec (_,j)  -> isrec & j=k
+	  | Mrec (_,j)  -> isrec && Int.equal j k
 	in b :: (analrec c rest)
     | LetIn (_,_,_,c), rest -> false :: (analrec c rest)
     | _, [] -> []
-    | _ -> anomaly "compute_construtor_signatures"
+    | _ -> anomaly (Pp.str "compute_construtor_signatures")
   in
   let (mib,mip) = Global.lookup_inductive ity in
   let n = mib.mind_nparams in
   let lc =
     Array.map (fun c -> snd (decompose_prod_n_assum n c)) mip.mind_nf_lc in
-  let lrecargs = dest_subterms mip.mind_recargs in
-  array_map2 analrec lc lrecargs
+  let lrecargs = Declareops.dest_subterms mip.mind_recargs in
+  Array.map2 analrec lc lrecargs
 
 let elimination_sort_of_goal gl =
   pf_apply Retyping.get_sort_family_of gl (pf_concl gl)
@@ -310,67 +211,19 @@ let elimination_sort_of_clause = function
   | None -> elimination_sort_of_goal
   | Some id -> elimination_sort_of_hyp id
 
-(* Find the right elimination suffix corresponding to the sort of the goal *)
-(* c should be of type A1->.. An->B with B an inductive definition *)
-
-let general_elim_then_using mk_elim
-  isrec allnames tac predicate (indbindings,elimbindings)
-  ind indclause gl =
-  let elim = mk_elim ind gl in
-  (* applying elimination_scheme just a little modified *)
-  let indclause' = clenv_match_args indbindings indclause in
-  let elimclause = mk_clenv_from gl (elim,pf_type_of gl elim) in
-  let indmv =
-    match kind_of_term (last_arg elimclause.templval.Evd.rebus) with
-      | Meta mv -> mv
-      | _         -> anomaly "elimination"
-  in
-  let pmv =
-    let p, _ = decompose_app elimclause.templtyp.Evd.rebus in
-    match kind_of_term p with
-      | Meta p -> p
-      | _ ->
-	  let name_elim =
-	    match kind_of_term elim with
-	      | Const kn -> string_of_con kn
-	      | Var id -> string_of_id id
-	      | _ -> "\b"
-	  in
-	  error ("The elimination combinator " ^ name_elim ^ " is unknown.")
-  in
-  let elimclause' = clenv_fchain indmv elimclause indclause' in
-  let elimclause' = clenv_match_args elimbindings elimclause' in
-  let branchsigns = compute_construtor_signatures isrec ind in
-  let brnames = compute_induction_names (Array.length branchsigns) allnames in
-  let after_tac ce i gl =
-    let (hd,largs) = decompose_app ce.templtyp.Evd.rebus in
-    let ba = { branchsign = branchsigns.(i);
-               branchnames = brnames.(i);
-               nassums =
-		 List.fold_left
-                   (fun acc b -> if b then acc+2 else acc+1)
-                   0 branchsigns.(i);
-               branchnum = i+1;
-               ity = ind;
-               largs = List.map (clenv_nf_meta ce) largs;
-               pred = clenv_nf_meta ce hd }
-    in
-    tac ba gl
-  in
-  let branchtacs ce = Array.init (Array.length branchsigns) (after_tac ce) in
-  let elimclause' =
-    match predicate with
-       | None   -> elimclause'
-       | Some p ->
-           clenv_unify ~flags:Unification.elim_flags
-             Reduction.CONV (mkMeta pmv) p elimclause'
-  in
-  elim_res_pf_THEN_i elimclause' branchtacs gl
+
+let pf_with_evars glsev k gls = 
+  let evd, a = glsev gls in
+    tclTHEN (Refiner.tclEVARS evd) (k a) gls
+
+let pf_constr_of_global gr k =
+  pf_with_evars (fun gls -> pf_apply Evd.fresh_global gls gr) k
 
 (* computing the case/elim combinators *)
 
 let gl_make_elim ind gl =
-  Indrec.lookup_eliminator ind (elimination_sort_of_goal gl)
+  let gr = Indrec.lookup_eliminator (fst ind) (elimination_sort_of_goal gl) in
+    pf_apply Evd.fresh_global gl gr
 
 let gl_make_case_dep ind gl =
   pf_apply Indrec.build_case_analysis_scheme gl ind true
@@ -380,22 +233,6 @@ let gl_make_case_nodep ind gl =
   pf_apply Indrec.build_case_analysis_scheme gl ind false
     (elimination_sort_of_goal gl)
 
-let elimination_then_using tac predicate bindings c gl =
-  let (ind,t) = pf_reduce_to_quantified_ind gl (pf_type_of gl c) in
-  let indclause  = mk_clenv_from gl (c,t) in
-  general_elim_then_using gl_make_elim
-    true None tac predicate bindings ind indclause gl
-
-let case_then_using =
-  general_elim_then_using gl_make_case_dep false
-
-let case_nodep_then_using =
-  general_elim_then_using gl_make_case_nodep false
-
-let elimination_then tac        = elimination_then_using tac None
-let simple_elimination_then tac = elimination_then tac ([],[])
-
-
 let make_elim_branch_assumptions ba gl =
   let rec makerec (assums,cargs,constargs,recargs,indargs) lb lc =
     match lb,lc with
@@ -414,11 +251,11 @@ let make_elim_branch_assumptions ba gl =
 		   id::constargs,
 		   recargs,
 		   indargs) tl idtl
-      | (_, _) -> anomaly "make_elim_branch_assumptions"
+      | (_, _) -> anomaly (Pp.str "make_elim_branch_assumptions")
   in
   makerec ([],[],[],[],[]) ba.branchsign
-    (try list_firstn ba.nassums (pf_hyps gl)
-     with Failure _ -> anomaly "make_elim_branch_assumptions")
+    (try List.firstn ba.nassums (pf_hyps gl)
+     with Failure _ -> anomaly (Pp.str "make_elim_branch_assumptions"))
 
 let elim_on_ba tac ba gl = tac (make_elim_branch_assumptions ba gl) gl
 
@@ -438,11 +275,435 @@ let make_case_branch_assumptions ba gl =
 		   id::cargs,
 		   recargs,
 		   id::constargs) tl idtl
-      | (_, _) -> anomaly "make_case_branch_assumptions"
+      | (_, _) -> anomaly (Pp.str "make_case_branch_assumptions")
   in
   makerec ([],[],[],[]) ba.branchsign
-    (try list_firstn ba.nassums (pf_hyps gl)
-     with Failure _ -> anomaly "make_case_branch_assumptions")
+    (try List.firstn ba.nassums (pf_hyps gl)
+     with Failure _ -> anomaly (Pp.str "make_case_branch_assumptions"))
 
 let case_on_ba tac ba gl = tac (make_case_branch_assumptions ba gl) gl
 
+
+(** Tacticals of Ltac defined directly in term of Proofview *)
+module New = struct
+  open Proofview
+  open Proofview.Notations
+  open Tacmach.New
+
+  let tclIDTAC = tclUNIT ()
+
+  let tclTHEN t1 t2 =
+    t1 <*> t2
+
+  let tclFAIL lvl msg =
+    tclZERO (Refiner.FailError (lvl,lazy msg))
+
+  let tclZEROMSG ?loc msg =
+    let err = UserError ("", msg) in
+    let info = match loc with
+    | None -> Exninfo.null
+    | Some loc -> Loc.add_loc Exninfo.null loc
+    in
+    tclZERO ~info err
+
+  let catch_failerror e =
+    try
+      Refiner.catch_failerror e;
+      tclUNIT ()
+    with e -> tclZERO e
+
+  (* spiwack: I chose to give the Ltac + the same semantics as
+     [Proofview.tclOR], however, for consistency with the or-else
+     tactical, we may consider wrapping the first argument with
+     [tclPROGRESS]. It strikes me as a bad idea, but consistency can be
+     considered valuable. *)
+  let tclOR t1 t2 =
+    tclINDEPENDENT begin
+      Proofview.tclOR
+        t1
+        begin fun e ->
+          catch_failerror e <*> t2
+        end
+    end
+
+  let tclORD t1 t2 =
+    tclINDEPENDENT begin
+      Proofview.tclOR
+        t1
+        begin fun e ->
+          catch_failerror e <*> t2 ()
+        end
+    end
+
+  let tclONCE = Proofview.tclONCE
+
+  let tclEXACTLY_ONCE t = Proofview.tclEXACTLY_ONCE (Refiner.FailError(0,lazy (assert false))) t
+
+  let tclIFCATCH t tt te =
+    tclINDEPENDENT begin
+      Proofview.tclIFCATCH t
+        tt
+        (fun e -> catch_failerror e <*> te ())
+    end
+
+  let tclORELSE0 t1 t2 =
+    tclINDEPENDENT begin
+      tclORELSE
+        t1
+        begin fun e ->
+          catch_failerror e <*> t2
+        end
+    end
+  let tclORELSE t1 t2 =
+    tclORELSE0 (tclPROGRESS t1) t2
+
+  let tclTHENS3PARTS t1 l1 repeat l2 =
+    tclINDEPENDENT begin
+      t1 <*>
+        Proofview.tclORELSE (* converts the [SizeMismatch] error into an ltac error *)
+          begin tclEXTEND (Array.to_list l1) repeat (Array.to_list l2) end
+          begin function (e, info) -> match e with
+            | SizeMismatch (i,_)->
+                let errmsg =
+                  str"Incorrect number of goals" ++ spc() ++
+                  str"(expected "++int i++str(String.plural i " tactic") ++ str")"
+                in
+                tclFAIL 0 errmsg
+            | reraise -> tclZERO ~info reraise
+          end
+    end
+  let tclTHENSFIRSTn t1 l repeat =
+    tclTHENS3PARTS t1 l repeat [||]
+  let tclTHENFIRSTn t1 l =
+    tclTHENSFIRSTn t1 l (tclUNIT())
+  let tclTHENFIRST t1 t2 =
+    tclTHENFIRSTn t1 [|t2|]
+  let tclTHENLASTn t1 l =
+    tclTHENS3PARTS t1 [||] (tclUNIT()) l
+  let tclTHENLAST t1 t2 = tclTHENLASTn t1 [|t2|]
+  let tclTHENS t l =
+    tclINDEPENDENT begin
+      t <*>Proofview.tclORELSE (* converts the [SizeMismatch] error into an ltac error *)
+          begin tclDISPATCH l end
+          begin function (e, info) -> match e with
+            | SizeMismatch (i,_)->
+                let errmsg =
+                  str"Incorrect number of goals" ++ spc() ++
+                  str"(expected "++int i++str(String.plural i " tactic") ++ str")"
+                in
+                tclFAIL 0 errmsg
+            | reraise -> tclZERO ~info reraise
+          end
+    end
+  let tclTHENLIST l =
+    List.fold_left tclTHEN (tclUNIT()) l
+
+
+  (* [tclMAP f [x1..xn]] builds [(f x1);(f x2);...(f xn)] *)
+  let tclMAP tacfun l =
+    List.fold_right (fun x -> (tclTHEN (tacfun x))) l (tclUNIT())
+
+  let tclTRY t =
+    tclORELSE0 t (tclUNIT ())
+
+  let tclIFTHENELSE t1 t2 t3 =
+    tclINDEPENDENT begin
+      Proofview.tclIFCATCH t1
+        (fun () -> t2)
+        (fun (e, info) -> Proofview.tclORELSE t3 (fun e' -> tclZERO ~info e))
+    end
+  let tclIFTHENSVELSE t1 a t3 =
+    Proofview.tclIFCATCH t1
+      (fun () -> tclDISPATCH (Array.to_list a))
+      (fun _ -> t3)
+  let tclIFTHENTRYELSEMUST t1 t2 =
+    tclIFTHENELSE t1 (tclTRY t2) t2
+
+  (* Try the first tactic that does not fail in a list of tactics *)
+  let rec tclFIRST = function
+    | [] -> tclZERO (Errors.UserError ("Tacticals.New.tclFIRST",str"No applicable tactic."))
+    |  t::rest -> tclORELSE0 t (tclFIRST rest)
+
+  let rec tclFIRST_PROGRESS_ON tac = function
+    | []    -> tclFAIL 0 (str "No applicable tactic")
+    | [a]   -> tac a (* so that returned failure is the one from last item *)
+    | a::tl -> tclORELSE (tac a) (tclFIRST_PROGRESS_ON tac tl)
+
+  let rec tclDO n t =
+    if n < 0 then
+      tclZERO (Errors.UserError (
+        "Refiner.tclDO",
+        str"Wrong argument : Do needs a positive integer.")
+      )
+    else if n = 0 then tclUNIT ()
+    else if n = 1 then t
+    else tclTHEN t (tclDO (n-1) t)
+
+  let rec tclREPEAT0 t =
+    tclINDEPENDENT begin
+      Proofview.tclIFCATCH t
+        (fun () -> tclCHECKINTERRUPT <*> tclREPEAT0 t)
+        (fun e -> catch_failerror e <*> tclUNIT ())
+    end
+  let tclREPEAT t =
+    tclREPEAT0 (tclPROGRESS t)
+  let rec tclREPEAT_MAIN0 t =
+    Proofview.tclIFCATCH t
+      (fun () -> tclTRYFOCUS 1 1 (tclREPEAT_MAIN0 t))
+      (fun e -> catch_failerror e <*> tclUNIT ())
+  let tclREPEAT_MAIN t =
+    tclREPEAT_MAIN0 (tclPROGRESS t)
+
+  let tclCOMPLETE t =
+    t >>= fun res ->
+      (tclINDEPENDENT
+         (tclZERO (Errors.UserError ("",str"Proof is not complete.")))
+      ) <*>
+        tclUNIT res
+
+  (* Try the first thats solves the current goal *)
+  let tclSOLVE tacl = tclFIRST (List.map tclCOMPLETE tacl)
+
+  let tclPROGRESS t =
+    Proofview.tclINDEPENDENT (Proofview.tclPROGRESS t)
+
+  (* Check that holes in arguments have been resolved *)
+
+  let check_evars env sigma extsigma origsigma =
+    let rec is_undefined_up_to_restriction sigma evk =
+      let evi = Evd.find sigma evk in
+      match Evd.evar_body evi with
+      | Evd.Evar_empty -> Some (evk,evi)
+      | Evd.Evar_defined c -> match Term.kind_of_term c with
+        | Term.Evar (evk,l) -> is_undefined_up_to_restriction sigma evk
+        | _ -> 
+          (* We make the assumption that there is no way to refine an
+            evar remaining after typing from the initial term given to
+            apply/elim and co tactics, is it correct? *)
+          None in
+    let rest =
+      Evd.fold_undefined (fun evk evi acc ->
+        match is_undefined_up_to_restriction sigma evk with
+        | Some (evk',evi) when not (Evd.mem origsigma evk) -> (evk',evi)::acc
+        | _ -> acc)
+        extsigma []
+    in
+    match rest with
+    | [] -> ()
+    | (evk,evi) :: _ ->
+      let (loc,_) = evi.Evd.evar_source in
+      Pretype_errors.error_unsolvable_implicit loc env sigma evk None
+
+  let tclWITHHOLES accept_unresolved_holes tac sigma x =
+    tclEVARMAP >>= fun sigma_initial ->
+      if sigma == sigma_initial then tac x
+      else
+        let check_evars env new_sigma sigma initial_sigma =
+          try
+            check_evars env new_sigma sigma initial_sigma;
+            tclUNIT ()
+          with e when Errors.noncritical e ->
+            tclZERO e
+        in
+        let check_evars_if =
+          if not accept_unresolved_holes then
+            tclEVARMAP >>= fun sigma_final ->
+              tclENV >>= fun env ->
+                check_evars env sigma_final sigma sigma_initial
+          else
+            tclUNIT ()
+        in
+        Proofview.Unsafe.tclEVARS sigma <*> tac x <*> check_evars_if
+
+  let tclTIMEOUT n t =
+    Proofview.tclOR
+      (Proofview.tclTIMEOUT n t)
+      begin function (e, info) -> match e with
+        | Proofview.Timeout as e -> Proofview.tclZERO (Refiner.FailError (0,lazy (Errors.print e)))
+        | e -> Proofview.tclZERO ~info e
+      end
+
+  let tclTIME s t =
+    Proofview.tclTIME s t
+
+  let nthDecl m gl =
+    let hyps = Proofview.Goal.hyps gl in
+    try
+      List.nth hyps (m-1)
+    with Failure _ -> Errors.error "No such assumption."
+
+  let nLastDecls gl n =
+    try List.firstn n (Proofview.Goal.hyps gl)
+    with Failure _ -> error "Not enough hypotheses in the goal."
+
+  let nthHypId m gl =
+    (** We only use [id] *)
+    let gl = Proofview.Goal.assume gl in
+    let (id,_,_) = nthDecl m gl in
+    id
+  let nthHyp m gl = 
+    mkVar (nthHypId m gl)
+
+  let onNthHypId m tac =
+    Proofview.Goal.enter begin fun gl -> tac (nthHypId m gl) end
+  let onNthHyp m tac =
+    Proofview.Goal.enter begin fun gl -> tac (nthHyp m gl) end
+
+  let onLastHypId = onNthHypId 1
+  let onLastHyp   = onNthHyp 1
+
+  let onNthDecl m tac =
+    Proofview.Goal.nf_enter begin fun gl ->
+      Proofview.tclUNIT (nthDecl m gl) >>= tac
+    end
+  let onLastDecl  = onNthDecl 1
+
+  let ifOnHyp pred tac1 tac2 id =
+    Proofview.Goal.nf_enter begin fun gl ->
+    let typ = Tacmach.New.pf_get_hyp_typ id gl in
+    if pred (id,typ) then
+      tac1 id
+    else
+      tac2 id
+    end
+
+  let onHyps find tac = Proofview.Goal.nf_enter (fun gl -> tac (find gl))
+
+  let afterHyp id tac =
+    Proofview.Goal.nf_enter begin fun gl ->
+    let hyps = Proofview.Goal.hyps gl in
+    let rem, _ = List.split_when (fun (hyp,_,_) -> Id.equal hyp id) hyps in
+    tac rem
+    end
+
+  let fullGoal gl =
+    let hyps = Tacmach.New.pf_ids_of_hyps gl in
+    None :: List.map Option.make hyps
+
+  let tryAllHyps tac =
+    Proofview.Goal.enter begin fun gl ->
+    let hyps = Tacmach.New.pf_ids_of_hyps gl in
+    tclFIRST_PROGRESS_ON tac hyps
+    end
+  let tryAllHypsAndConcl tac =
+    Proofview.Goal.enter begin fun gl ->
+      tclFIRST_PROGRESS_ON tac (fullGoal gl)
+    end
+
+  let onClause tac cl =
+    Proofview.Goal.enter begin fun gl ->
+    let hyps = Tacmach.New.pf_ids_of_hyps gl in
+    tclMAP tac (Locusops.simple_clause_of (fun () -> hyps) cl)
+    end
+
+  (* Find the right elimination suffix corresponding to the sort of the goal *)
+  (* c should be of type A1->.. An->B with B an inductive definition *)
+  let general_elim_then_using mk_elim
+      isrec allnames tac predicate ind (c, t) =
+    Proofview.Goal.nf_enter begin fun gl ->
+    let indclause = Tacmach.New.of_old (fun gl -> mk_clenv_from gl (c, t)) gl in
+    (** FIXME: evar leak. *)
+    let sigma, elim = Tacmach.New.of_old (mk_elim ind) gl in
+    (* applying elimination_scheme just a little modified *)
+    let elimclause = Tacmach.New.of_old (fun gls -> mk_clenv_from gls (elim,Tacmach.New.pf_type_of gl elim)) gl in
+    let indmv =
+      match kind_of_term (last_arg elimclause.templval.Evd.rebus) with
+      | Meta mv -> mv
+      | _         -> anomaly (str"elimination")
+    in
+    let pmv =
+      let p, _ = decompose_app elimclause.templtyp.Evd.rebus in
+      match kind_of_term p with
+      | Meta p -> p
+      | _ ->
+	  let name_elim =
+	    match kind_of_term elim with
+	    | Const (kn, _) -> string_of_con kn
+	    | Var id -> string_of_id id
+	    | _ -> "\b"
+	  in
+	  error ("The elimination combinator " ^ name_elim ^ " is unknown.")
+    in
+    let elimclause' = clenv_fchain indmv elimclause indclause in
+    let branchsigns = compute_construtor_signatures isrec ind in
+    let brnames = compute_induction_names (Array.length branchsigns) allnames in
+    let flags = Unification.elim_flags () in
+    let elimclause' =
+      match predicate with
+      | None   -> elimclause'
+      | Some p -> clenv_unify ~flags Reduction.CONV (mkMeta pmv) p elimclause'
+    in
+    let clenv' = Tacmach.New.of_old (clenv_unique_resolver ~flags elimclause') gl in
+    let after_tac i =
+      let (hd,largs) = decompose_app clenv'.templtyp.Evd.rebus in
+      let ba = { branchsign = branchsigns.(i);
+                 branchnames = brnames.(i);
+                 nassums =
+          List.fold_left
+            (fun acc b -> if b then acc+2 else acc+1)
+            0 branchsigns.(i);
+                 branchnum = i+1;
+                 ity = ind;
+                 largs = List.map (clenv_nf_meta clenv') largs;
+                 pred = clenv_nf_meta clenv' hd }
+      in
+      tac ba
+    in
+    let branchtacs = List.init (Array.length branchsigns) after_tac in
+    Proofview.tclTHEN
+      (Clenvtac.clenv_refine false clenv')
+      (Proofview.tclEXTEND [] tclIDTAC branchtacs)
+    end
+
+  let elimination_then tac c =
+    Proofview.Goal.nf_enter begin fun gl ->
+    let (ind,t) = pf_reduce_to_quantified_ind gl (pf_type_of gl c) in
+    let isrec,mkelim =
+      match (Global.lookup_mind (fst (fst ind))).mind_record with
+      | None -> true,gl_make_elim
+      | Some _ -> false,gl_make_case_dep
+    in
+    general_elim_then_using mkelim isrec None tac None ind (c, t)
+    end
+
+  let case_then_using =
+    general_elim_then_using gl_make_case_dep false
+
+  let case_nodep_then_using =
+    general_elim_then_using gl_make_case_nodep false
+
+  let elim_on_ba tac ba =
+    Proofview.Goal.nf_enter begin fun gl ->
+    let branches = Tacmach.New.of_old (make_elim_branch_assumptions ba) gl in
+    tac branches
+    end
+
+  let case_on_ba tac ba = 
+    Proofview.Goal.nf_enter begin fun gl ->
+    let branches = Tacmach.New.of_old (make_case_branch_assumptions ba) gl in
+    tac branches
+    end
+
+  let elimination_sort_of_goal gl =
+    (** Retyping will expand evars anyway. *)
+    let c = Proofview.Goal.concl (Goal.assume gl) in
+    pf_apply Retyping.get_sort_family_of gl c
+
+  let elimination_sort_of_hyp id gl =
+    (** Retyping will expand evars anyway. *)
+    let c = pf_get_hyp_typ id (Goal.assume gl) in
+    pf_apply Retyping.get_sort_family_of gl c
+
+  let elimination_sort_of_clause id gl = match id with
+  | None -> elimination_sort_of_goal gl
+  | Some id -> elimination_sort_of_hyp id gl
+
+  let pf_constr_of_global ref tac =
+    Proofview.Goal.nf_enter begin fun gl ->
+      let env = Proofview.Goal.env gl in
+      let sigma = Proofview.Goal.sigma gl in
+      let (sigma, c) = Evd.fresh_global env sigma ref in
+      Proofview.Unsafe.tclEVARS sigma <*> (tac c)
+    end
+
+end
diff --git a/tactics/tacticals.mli b/tactics/tacticals.mli
index ee88caa9..6249bbc5 100644
--- a/tactics/tacticals.mli
+++ b/tactics/tacticals.mli
@@ -1,29 +1,25 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
+open Loc
 open Pp
-open Util
 open Names
 open Term
-open Sign
+open Context
 open Tacmach
 open Proof_type
 open Clenv
-open Reduction
-open Pattern
-open Genarg
 open Tacexpr
-open Termops
-open Glob_term
+open Locus
+open Misctypes
 
 (** Tacticals i.e. functions from tactics to tactics. *)
 
-val tclNORMEVAR      : tactic
 val tclIDTAC         : tactic
 val tclIDTAC_MESSAGE : std_ppcmds -> tactic
 val tclORELSE0       : tactic -> tactic -> tactic
@@ -52,6 +48,7 @@ val tclFAIL_lazy     : int -> std_ppcmds Lazy.t -> tactic
 val tclDO            : int -> tactic -> tactic
 val tclWEAK_PROGRESS : tactic -> tactic
 val tclPROGRESS      : tactic -> tactic
+val tclSHOWHYPS      : tactic -> tactic
 val tclNOTSAMEGOAL   : tactic -> tactic
 val tclTHENTRY       : tactic -> tactic -> tactic
 val tclMAP           : ('a -> tactic) -> 'a list -> tactic
@@ -61,106 +58,57 @@ val tclIFTHENSELSE       : tactic -> tactic list -> tactic -> tactic
 val tclIFTHENSVELSE      : tactic -> tactic array -> tactic -> tactic
 val tclIFTHENTRYELSEMUST : tactic -> tactic -> tactic
 
-val tclFIRST_PROGRESS_ON : ('a -> tactic) -> 'a list -> tactic
-
 (** {6 Tacticals applying to hypotheses } *)
 
-val onNthHypId       : int -> (identifier -> tactic) -> tactic
+val onNthHypId       : int -> (Id.t -> tactic) -> tactic
 val onNthHyp         : int -> (constr -> tactic) -> tactic
 val onNthDecl        : int -> (named_declaration -> tactic) -> tactic
-val onLastHypId      : (identifier -> tactic) -> tactic
+val onLastHypId      : (Id.t -> tactic) -> tactic
 val onLastHyp        : (constr -> tactic) -> tactic
 val onLastDecl       : (named_declaration -> tactic) -> tactic
-val onNLastHypsId    : int -> (identifier list -> tactic) -> tactic
+val onNLastHypsId    : int -> (Id.t list -> tactic) -> tactic
 val onNLastHyps      : int -> (constr list -> tactic) -> tactic
 val onNLastDecls     : int -> (named_context -> tactic) -> tactic
 
-val lastHypId   : goal sigma -> identifier
+val lastHypId   : goal sigma -> Id.t
 val lastHyp     : goal sigma -> constr
 val lastDecl    : goal sigma -> named_declaration
-val nLastHypsId : int -> goal sigma -> identifier list
+val nLastHypsId : int -> goal sigma -> Id.t list
 val nLastHyps   : int -> goal sigma -> constr list
 val nLastDecls  : int -> goal sigma -> named_context
 
-val afterHyp    : identifier -> goal sigma -> named_context
+val afterHyp    : Id.t -> goal sigma -> named_context
 
-val ifOnHyp     : (identifier * types -> bool) ->
-                  (identifier -> tactic) -> (identifier -> tactic) ->
-		   identifier -> tactic
+val ifOnHyp     : (Id.t * types -> bool) ->
+                  (Id.t -> tactic) -> (Id.t -> tactic) ->
+		   Id.t -> tactic
 
 val onHyps      : (goal sigma -> named_context) ->
                   (named_context -> tactic) -> tactic
 
 (** {6 Tacticals applying to goal components } *)
 
-(** 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
    goal; in particular, it can abstractly refer to the set of
    hypotheses independently of the effective contents of the current goal *)
 
-type clause = identifier gclause
-
-val simple_clause_of : clause -> goal sigma -> simple_clause
-
-val allHypsAndConcl : clause
-val allHyps         : clause
-val onHyp           : identifier -> clause
-val onConcl         : clause
-
-val tryAllHyps          : (identifier -> tactic) -> tactic
-val tryAllHypsAndConcl  : (identifier option -> tactic) -> tactic
-
-val onAllHyps           : (identifier -> tactic) -> tactic
-val onAllHypsAndConcl   : (identifier option -> tactic) -> tactic
-
-val onClause   : (identifier option -> tactic) -> clause -> tactic
-val onClauseLR : (identifier option -> tactic) -> clause -> tactic
-
-(** {6 An intermediate form of occurrence clause with no mention of occurrences } *)
-
-(** 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
-   body if any, in type or in both) or the goal *)
+val onAllHyps           : (Id.t -> tactic) -> tactic
+val onAllHypsAndConcl   : (Id.t option -> tactic) -> tactic
 
-type goal_location = hyp_location option
-
-(** {6 A concrete view of occurrence clauses } *)
-
-(** [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 *)
-
-type clause_atom =
-  | OnHyp of identifier * occurrences_expr * hyp_location_flag
-  | OnConcl of occurrences_expr
-
-(** 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 *)
-val concrete_clause_of : clause -> goal sigma -> concrete_clause
+val onClause   : (Id.t option -> tactic) -> clause -> tactic
+val onClauseLR : (Id.t option -> tactic) -> clause -> tactic
 
 (** {6 Elimination tacticals. } *)
 
 type branch_args = {
-  ity        : inductive;   (** the type we were eliminating on *)
+  ity        : pinductive;   (** the type we were eliminating on *)
   largs      : constr list; (** its arguments *)
   branchnum  : int;         (** the branch number *)
   pred       : constr;      (** the predicate we used *)
   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}
+  branchnames : intro_patterns}
 
 type branch_assumptions = {
   ba        : branch_args;     (** the branch args *)
@@ -169,47 +117,151 @@ type branch_assumptions = {
 (** [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
+  Loc.t -> delayed_open_constr or_and_intro_pattern_expr -> int -> unit
 
 (** 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
+val fix_empty_or_and_pattern : int -> 
+  delayed_open_constr or_and_intro_pattern_expr ->
+  delayed_open_constr or_and_intro_pattern_expr
 
 (** Useful for [as intro_pattern] modifier *)
 val compute_induction_names :
-  int -> intro_pattern_expr located option ->
-    intro_pattern_expr located list array
+  int -> or_and_intro_pattern option -> intro_patterns array
 
 val elimination_sort_of_goal : goal sigma -> sorts_family
-val elimination_sort_of_hyp  : identifier -> goal sigma -> sorts_family
-val elimination_sort_of_clause : identifier option -> goal sigma -> sorts_family
+val elimination_sort_of_hyp  : Id.t -> goal sigma -> sorts_family
+val elimination_sort_of_clause : Id.t option -> goal sigma -> sorts_family
 
-val general_elim_then_using :
-  (inductive -> goal sigma -> constr) -> rec_flag ->
-  intro_pattern_expr located option -> (branch_args -> tactic) ->
-    constr option -> (arg_bindings * arg_bindings) -> inductive -> clausenv ->
-    tactic
-
-val elimination_then_using :
-  (branch_args -> tactic) -> constr option ->
-    (arg_bindings * arg_bindings) -> constr -> tactic
-
-val elimination_then :
-  (branch_args -> tactic) ->
-    (arg_bindings * arg_bindings) -> constr -> tactic
-
-val case_then_using :
-  intro_pattern_expr located option -> (branch_args -> tactic) ->
-    constr option -> (arg_bindings * arg_bindings) ->
-      inductive -> clausenv -> tactic
-
-val case_nodep_then_using :
-  intro_pattern_expr located option -> (branch_args -> tactic) ->
-    constr option -> (arg_bindings * arg_bindings) ->
-      inductive -> clausenv -> tactic
-
-val simple_elimination_then :
-  (branch_args -> tactic) -> constr -> tactic
+val pf_with_evars :  (goal sigma -> Evd.evar_map * 'a) -> ('a -> tactic) -> tactic
+val pf_constr_of_global : Globnames.global_reference -> (constr -> tactic) -> tactic
 
 val elim_on_ba : (branch_assumptions -> tactic) -> branch_args  -> tactic
 val case_on_ba : (branch_assumptions -> tactic) -> branch_args  -> tactic
+
+(** Tacticals defined directly in term of Proofview *)
+
+(** The tacticals in the module [New] are the tactical of Ltac. Their
+    semantics is an extension of the tacticals in this file for the
+    multi-goal backtracking tactics. They do not have the same
+    semantics as the similarly named tacticals in [Proofview]. The
+    tactical of [Proofview] are used in the definition of the
+    tacticals of [Tacticals.New], but they are more atomic. In
+    particular [Tacticals.New.tclORELSE] sees like of progress as a
+    failure, whereas [Proofview.tclORELSE] doesn't. Additionally every
+    tactic which can catch failure ([tclOR], [tclORELSE], [tclTRY],
+    [tclREPEAt], etc…) are run into each goal independently (failures
+    and backtracks are localised to a given goal). *)
+module New : sig
+  open Proofview
+
+  (** [catch_failerror e] fails and decreases the level if [e] is an
+      Ltac error with level more than 0. Otherwise succeeds. *)
+  val catch_failerror : Util.iexn -> unit tactic
+
+  val tclIDTAC : unit tactic
+  val tclTHEN : unit tactic -> unit tactic -> unit tactic
+  (* [tclFAIL n msg] fails with [msg] as an error message at level [n]
+     (meaning that it will jump over [n] error catching tacticals FROM
+     THIS MODULE. *)
+  val tclFAIL : int -> Pp.std_ppcmds -> 'a tactic
+
+  val tclZEROMSG : ?loc:Loc.t -> Pp.std_ppcmds -> 'a tactic
+  (** Fail with a [User_Error] containing the given message. *)
+
+  val tclOR : unit tactic -> unit tactic -> unit tactic
+  val tclORD : unit tactic -> (unit -> unit tactic) -> unit tactic
+  (** Like {!tclOR} but accepts a delayed tactic as a second argument
+      in the form of a function which will be run only in case of
+      backtracking. *)
+
+  val tclONCE : unit tactic -> unit tactic
+  val tclEXACTLY_ONCE : unit tactic -> unit tactic
+
+  val tclIFCATCH :
+             unit tactic  ->
+    (unit -> unit tactic) ->
+    (unit -> unit tactic) -> unit tactic
+
+  val tclORELSE0 : unit tactic -> unit tactic -> unit tactic
+  val tclORELSE  : unit tactic -> unit tactic -> unit tactic
+
+  (** [tclTHENS3PARTS tac1 [|t1 ; ... ; tn|] tac2 [|t'1 ; ... ; t'm|]
+      gls] applies the tactic [tac1] to [gls] then, applies [t1], ...,
+      [tn] to the first [n] resulting subgoals, [t'1], ..., [t'm] to the
+      last [m] subgoals and [tac2] to the rest of the subgoals in the
+      middle. Raises an error if the number of resulting subgoals is
+      strictly less than [n+m] *)
+  val tclTHENS3PARTS     : unit tactic -> unit tactic array -> unit tactic -> unit tactic array -> unit tactic
+  val tclTHENSFIRSTn : unit tactic -> unit tactic array -> unit tactic -> unit tactic
+  val tclTHENFIRSTn : unit tactic -> unit tactic array -> unit tactic
+  (** [tclTHENFIRST tac1 tac2 gls] applies the tactic [tac1] to [gls]
+      and [tac2] to the first resulting subgoal *)
+  val tclTHENFIRST : unit tactic -> unit tactic -> unit tactic
+  val tclTHENLASTn : unit tactic -> unit tactic array -> unit tactic
+  val tclTHENLAST  : unit tactic -> unit tactic -> unit tactic
+  (* [tclTHENS t l = t <*> tclDISPATCH l] *)
+  val tclTHENS : unit tactic -> unit tactic list -> unit tactic
+  (* [tclTHENLIST [t1;…;tn]] is [t1<*>…<*>tn] *)
+  val tclTHENLIST : unit tactic list -> unit tactic
+
+  (** [tclMAP f [x1..xn]] builds [(f x1);(f x2);...(f xn)] *)
+  val tclMAP : ('a -> unit tactic) -> 'a list -> unit tactic
+
+  val tclTRY : unit tactic -> unit tactic
+  val tclFIRST : unit tactic list -> unit tactic
+  val tclIFTHENELSE : unit tactic -> unit tactic -> unit tactic -> unit tactic
+  val tclIFTHENSVELSE : unit tactic -> unit tactic array -> unit tactic -> unit tactic
+  val tclIFTHENTRYELSEMUST : unit tactic -> unit tactic -> unit tactic
+
+  val tclDO : int -> unit tactic -> unit tactic
+  val tclREPEAT : unit tactic -> unit tactic
+  (* Repeat on the first subgoal (no failure if no more subgoal) *)
+  val tclREPEAT_MAIN : unit tactic -> unit tactic
+  val tclCOMPLETE : 'a tactic -> 'a tactic
+  val tclSOLVE : unit tactic list -> unit tactic
+  val tclPROGRESS : unit tactic -> unit tactic
+  val tclWITHHOLES : bool -> ('a -> unit tactic) -> Evd.evar_map -> 'a -> unit tactic
+
+  val tclTIMEOUT : int -> unit tactic -> unit tactic
+  val tclTIME : string option -> 'a tactic -> 'a tactic
+
+  val nLastDecls  : [ `NF ] Proofview.Goal.t -> int -> named_context
+
+  val ifOnHyp     : (identifier * types -> bool) ->
+    (identifier -> unit Proofview.tactic) -> (identifier -> unit Proofview.tactic) ->
+    identifier -> unit Proofview.tactic
+
+  val onNthHypId : int -> (identifier -> unit tactic) -> unit tactic
+  val onLastHypId      : (identifier -> unit tactic) -> unit tactic
+  val onLastHyp        : (constr -> unit tactic) -> unit tactic
+  val onLastDecl       : (named_declaration -> unit tactic) -> unit tactic
+
+  val onHyps      : ([ `NF ] Proofview.Goal.t -> named_context) ->
+                    (named_context -> unit tactic) -> unit tactic
+  val afterHyp    : Id.t -> (named_context -> unit tactic) -> unit tactic
+
+  val tryAllHyps          : (identifier -> unit tactic) -> unit tactic
+  val tryAllHypsAndConcl  : (identifier option -> unit tactic) -> unit tactic
+  val onClause   : (identifier option -> unit tactic) -> clause -> unit tactic
+
+  val elimination_sort_of_goal : 'a Proofview.Goal.t -> sorts_family
+  val elimination_sort_of_hyp  : Id.t -> 'a Proofview.Goal.t -> sorts_family
+  val elimination_sort_of_clause : Id.t option -> 'a Proofview.Goal.t -> sorts_family
+
+  val elimination_then :
+    (branch_args -> unit Proofview.tactic) ->
+    constr -> unit Proofview.tactic
+
+  val case_then_using :
+    or_and_intro_pattern option -> (branch_args -> unit Proofview.tactic) ->
+    constr option -> pinductive -> Term.constr * Term.types -> unit Proofview.tactic
+
+  val case_nodep_then_using :
+    or_and_intro_pattern option -> (branch_args -> unit Proofview.tactic) ->
+    constr option -> pinductive -> Term.constr * Term.types -> unit Proofview.tactic
+
+  val elim_on_ba : (branch_assumptions -> unit Proofview.tactic) -> branch_args  -> unit Proofview.tactic
+  val case_on_ba : (branch_assumptions -> unit Proofview.tactic) -> branch_args  -> unit Proofview.tactic
+
+  val pf_constr_of_global : Globnames.global_reference -> (constr -> unit Proofview.tactic) -> unit Proofview.tactic
+end
diff --git a/tactics/tactics.ml b/tactics/tactics.ml
index b6407340..f1f1248d 100644
--- a/tactics/tactics.ml
+++ b/tactics/tactics.ml
@@ -1,52 +1,50 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-open Compat
 open Pp
+open Errors
 open Util
 open Names
 open Nameops
-open Sign
 open Term
+open Vars
+open Context
 open Termops
+open Find_subterm
 open Namegen
 open Declarations
-open Inductive
 open Inductiveops
 open Reductionops
 open Environ
-open Libnames
+open Globnames
 open Evd
 open Pfedit
 open Tacred
-open Glob_term
+open Genredexpr
 open Tacmach
-open Proof_type
 open Logic
-open Evar_refiner
 open Clenv
-open Clenvtac
 open Refiner
 open Tacticals
 open Hipattern
 open Coqlib
-open Nametab
-open Genarg
 open Tacexpr
 open Decl_kinds
 open Evarutil
 open Indrec
 open Pretype_errors
 open Unification
+open Locus
+open Locusops
+open Misctypes
+open Proofview.Notations
 
-exception Bound
-
-let rec nb_prod x =
+let nb_prod x =
   let rec count n c =
     match kind_of_term c with
         Prod(_,_,t) -> count (n+1) t
@@ -55,14 +53,30 @@ let rec nb_prod x =
       | _ -> n
   in count 0 x
 
-let inj_with_occurrences e = (all_occurrences_expr,e)
+let inj_with_occurrences e = (AllOccurrences,e)
 
-let dloc = dummy_loc
+let dloc = Loc.ghost
 
 let typ_of = Retyping.get_type_of
 
-(* Option for 8.2 compatibility *)
+(* Option for 8.4 compatibility *)
 open Goptions
+let legacy_elim_if_not_fully_applied_argument = ref false
+
+let use_legacy_elim_if_not_fully_applied_argument () =
+  !legacy_elim_if_not_fully_applied_argument
+  || Flags.version_less_or_equal Flags.V8_4
+
+let _ =
+  declare_bool_option
+    { optsync  = true;
+      optdepr  = false;
+      optname  = "partially applied elimination argument legacy";
+      optkey   = ["Legacy";"Partially";"Applied";"Elimination";"Argument"];
+      optread  = (fun () -> !legacy_elim_if_not_fully_applied_argument) ;
+      optwrite = (fun b -> legacy_elim_if_not_fully_applied_argument := b) }
+
+(* Option for 8.2 compatibility *)
 let dependent_propositions_elimination = ref true
 
 let use_dependent_propositions_elimination () =
@@ -78,86 +92,226 @@ let _ =
       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)
+let _ =
+  declare_bool_option
+    { optsync  = true;
+      optdepr  = false;
+      optname  = "trigger bugged context matching compatibility";
+      optkey   = ["Tactic";"Compat";"Context"];
+      optread  = (fun () -> !Flags.tactic_context_compat) ;
+      optwrite = (fun b -> Flags.tactic_context_compat := b) }
+
+let apply_solve_class_goals = ref (false)
+let _ = Goptions.declare_bool_option {
+  Goptions.optsync = true; Goptions.optdepr = false;
+  Goptions.optname =
+    "Perform typeclass resolution on apply-generated subgoals.";
+  Goptions.optkey = ["Typeclass";"Resolution";"After";"Apply"];
+  Goptions.optread = (fun () -> !apply_solve_class_goals);
+  Goptions.optwrite = (fun a -> apply_solve_class_goals:=a);
+}
+
+let clear_hyp_by_default = ref false
+
+let use_clear_hyp_by_default () = !clear_hyp_by_default
+
+let _ =
+  declare_bool_option
+    { optsync  = true;
+      optdepr  = false;
+      optname  = "default clearing of hypotheses after use";
+      optkey   = ["Default";"Clearing";"Used";"Hypotheses"];
+      optread  = (fun () -> !clear_hyp_by_default) ;
+      optwrite = (fun b -> clear_hyp_by_default := b) }
 
 (*********************************************)
 (*                 Tactics                   *)
 (*********************************************)
 
-(****************************************)
-(* General functions                    *)
-(****************************************)
-
-let string_of_inductive c =
-  try match kind_of_term c with
-  | Ind ind_sp ->
-      let (mib,mip) = Global.lookup_inductive ind_sp in
-      string_of_id mip.mind_typename
-  | _ -> raise Bound
-  with Bound -> error "Bound head variable."
-
-let rec head_constr_bound t =
-  let t = strip_outer_cast t in
-  let _,ccl = decompose_prod_assum t in
-  let hd,args = decompose_app ccl in
-  match kind_of_term hd with
-    | Const _ | Ind _ | Construct _ | Var _ -> (hd,args)
-    | _ -> raise Bound
-
-let head_constr c =
-  try head_constr_bound c with Bound -> error "Bound head variable."
-
 (******************************************)
 (*           Primitive tactics            *)
 (******************************************)
 
-let introduction    = Tacmach.introduction
+(** This tactic creates a partial proof realizing the introduction rule, but
+    does not check anything. *)
+let unsafe_intro env store (id, c, t) b =
+  Proofview.Refine.refine ~unsafe:true begin fun sigma ->
+    let ctx = named_context_val env in
+    let nctx = push_named_context_val (id, c, t) ctx in
+    let inst = List.map (fun (id, _, _) -> mkVar id) (named_context env) in
+    let ninst = mkRel 1 :: inst in
+    let nb = subst1 (mkVar id) b in
+    let sigma, ev = new_evar_instance nctx sigma nb ~store ninst in
+    sigma, mkNamedLambda_or_LetIn (id, c, t) ev
+  end
+
+let introduction ?(check=true) id =
+  Proofview.Goal.enter begin fun gl ->
+    let gl = Proofview.Goal.assume gl in
+    let concl = Proofview.Goal.concl gl in
+    let sigma = Proofview.Goal.sigma gl in
+    let hyps = Proofview.Goal.hyps gl in
+    let store = Proofview.Goal.extra gl in
+    let env = Proofview.Goal.env gl in
+    let () = if check && mem_named_context id hyps then
+      error ("Variable " ^ Id.to_string id ^ " is already declared.")
+    in
+    match kind_of_term (whd_evar sigma concl) with
+    | Prod (_, t, b) -> unsafe_intro env store (id, None, t) b
+    | LetIn (_, c, t, b) -> unsafe_intro env store (id, Some c, t) b
+    | _ -> raise (RefinerError IntroNeedsProduct)
+  end
+
 let refine          = Tacmach.refine
-let convert_concl   = Tacmach.convert_concl
-let convert_hyp     = Tacmach.convert_hyp
-let thin_body       = Tacmach.thin_body
 
-let error_clear_dependency env id = function
+let convert_concl ?(check=true) ty k =
+  Proofview.Goal.enter begin fun gl ->
+    let env = Proofview.Goal.env gl in
+    let store = Proofview.Goal.extra gl in
+    let conclty = Proofview.Goal.raw_concl gl in
+    Proofview.Refine.refine ~unsafe:true begin fun sigma ->
+      let sigma =
+        if check then begin
+          ignore (Typing.type_of env sigma ty);
+          let sigma,b = Reductionops.infer_conv env sigma ty conclty in
+          if not b then error "Not convertible.";
+          sigma
+        end else sigma in
+      let (sigma,x) = Evarutil.new_evar env sigma ~principal:true ~store ty in
+      (sigma, if k == DEFAULTcast then x else mkCast(x,k,conclty))
+    end
+  end
+
+let convert_hyp ?(check=true) d =
+  Proofview.Goal.enter begin fun gl ->
+    let env = Proofview.Goal.env gl in
+    let sigma = Proofview.Goal.sigma gl in
+    let ty = Proofview.Goal.raw_concl gl in
+    let store = Proofview.Goal.extra gl in
+    let sign = convert_hyp check (named_context_val env) sigma d in
+    let env = reset_with_named_context sign env in
+    Proofview.Refine.refine ~unsafe:true (fun sigma -> Evarutil.new_evar env sigma ~principal:true ~store ty)
+  end
+
+let convert_concl_no_check = convert_concl ~check:false
+let convert_hyp_no_check = convert_hyp ~check:false
+
+let convert_gen pb x y =
+  Proofview.Goal.enter begin fun gl ->
+    try
+      let sigma = Tacmach.New.pf_apply Evd.conversion gl pb x y in
+      Proofview.Unsafe.tclEVARS sigma
+    with (* Reduction.NotConvertible *) _ ->
+      (** FIXME: Sometimes an anomaly is raised from conversion *)
+      Tacticals.New.tclFAIL 0 (str "Not convertible")
+end
+
+let convert x y = convert_gen Reduction.CONV x y
+let convert_leq x y = convert_gen Reduction.CUMUL x y
+
+let clear_dependency_msg env sigma id = function
   | Evarutil.OccurHypInSimpleClause None ->
-      errorlabstrm "" (pr_id id ++ str " is used in conclusion.")
+      pr_id id ++ str " is used in conclusion."
   | Evarutil.OccurHypInSimpleClause (Some id') ->
-      errorlabstrm ""
-        (pr_id id ++ strbrk " is used in hypothesis " ++ pr_id id' ++ str".")
+      pr_id id ++ strbrk " is used in hypothesis " ++ pr_id id' ++ str"."
   | Evarutil.EvarTypingBreak ev ->
-      errorlabstrm ""
-        (str "Cannot remove " ++ pr_id id ++
-	 strbrk " without breaking the typing of " ++
-	 Printer.pr_existential env ev ++ str".")
+      str "Cannot remove " ++ pr_id id ++
+      strbrk " without breaking the typing of " ++
+      Printer.pr_existential env sigma ev ++ str"."
 
-let thin l gl =
-  try thin l gl
-  with Evarutil.ClearDependencyError (id,err) ->
-    error_clear_dependency (pf_env gl) id err
+let error_clear_dependency env sigma id err =
+  errorlabstrm "" (clear_dependency_msg env sigma id err)
 
-let internal_cut_gen b d t gl =
-  try internal_cut b d t gl
-  with Evarutil.ClearDependencyError (id,err) ->
-    error_clear_dependency (pf_env gl) id err
+let replacing_dependency_msg env sigma id = function
+  | Evarutil.OccurHypInSimpleClause None ->
+      str "Cannot change " ++ pr_id id ++ str ", it is used in conclusion."
+  | Evarutil.OccurHypInSimpleClause (Some id') ->
+      str "Cannot change " ++ pr_id id ++
+      strbrk ", it is used in hypothesis " ++ pr_id id' ++ str"."
+  | Evarutil.EvarTypingBreak ev ->
+      str "Cannot change " ++ pr_id id ++
+      strbrk " without breaking the typing of " ++
+      Printer.pr_existential env sigma ev ++ str"."
 
-let internal_cut = internal_cut_gen false
-let internal_cut_replace = internal_cut_gen true
+let error_replacing_dependency env sigma id err =
+  errorlabstrm "" (replacing_dependency_msg env sigma id err)
 
-let internal_cut_rev_gen b d t gl =
-  try internal_cut_rev b d t gl
+let thin l gl =
+  try thin l gl
   with Evarutil.ClearDependencyError (id,err) ->
-    error_clear_dependency (pf_env gl) id err
+    error_clear_dependency (pf_env gl) (project gl) id err
 
-let internal_cut_rev = internal_cut_rev_gen false
-let internal_cut_rev_replace = internal_cut_rev_gen true
+let thin_for_replacing l gl =
+  try Tacmach.thin l gl
+  with Evarutil.ClearDependencyError (id,err) ->
+    error_replacing_dependency (pf_env gl) (project gl) id err
+
+let apply_clear_request clear_flag dft c =
+  let check_isvar c =
+    if not (isVar c) then
+      error "keep/clear modifiers apply only to hypothesis names." in
+  let clear = match clear_flag with
+    | None -> dft && isVar c
+    | Some clear -> check_isvar c; clear in
+  if clear then Proofview.V82.tactic (thin [destVar c])
+  else Tacticals.New.tclIDTAC
 
 (* Moving hypotheses *)
-let move_hyp        = Tacmach.move_hyp
-
+let move_hyp id dest gl = Tacmach.move_hyp id dest gl
 
 (* Renaming hypotheses *)
-let rename_hyp      = Tacmach.rename_hyp
+let rename_hyp repl =
+  let fold accu (src, dst) = match accu with
+  | None -> None
+  | Some (srcs, dsts) ->
+    if Id.Set.mem src srcs then None
+    else if Id.Set.mem dst dsts then None
+    else
+      let srcs = Id.Set.add src srcs in
+      let dsts = Id.Set.add dst dsts in
+      Some (srcs, dsts)
+  in
+  let init = Some (Id.Set.empty, Id.Set.empty) in
+  let dom = List.fold_left fold init repl in
+  match dom with
+  | None -> Tacticals.New.tclZEROMSG (str "Not a one-to-one name mapping")
+  | Some (src, dst) ->
+    Proofview.Goal.enter begin fun gl ->
+      let gl = Proofview.Goal.assume gl in
+      let hyps = Proofview.Goal.hyps gl in
+      let concl = Proofview.Goal.concl gl in
+      let store = Proofview.Goal.extra gl in
+      (** Check that we do not mess variables *)
+      let fold accu (id, _, _) = Id.Set.add id accu in
+      let vars = List.fold_left fold Id.Set.empty hyps in
+      let () =
+        if not (Id.Set.subset src vars) then
+          let hyp = Id.Set.choose (Id.Set.diff src vars) in
+          raise (RefinerError (NoSuchHyp hyp))
+      in
+      let mods = Id.Set.diff vars src in
+      let () =
+        try
+          let elt = Id.Set.choose (Id.Set.inter dst mods) in
+          Errors.errorlabstrm "" (pr_id elt ++ str " is already used")
+        with Not_found -> ()
+      in
+      (** All is well *)
+      let make_subst (src, dst) = (src, mkVar dst) in
+      let subst = List.map make_subst repl in
+      let subst c = Vars.replace_vars subst c in
+      let map (id, body, t) =
+        let id = try List.assoc_f Id.equal id repl with Not_found -> id in
+        (id, Option.map subst body, subst t)
+      in
+      let nhyps = List.map map hyps in
+      let nconcl = subst concl in
+      let nctx = Environ.val_of_named_context nhyps in
+      let instance = List.map (fun (id, _, _) -> mkVar id) hyps in
+      Proofview.Refine.refine ~unsafe:true begin fun sigma ->
+        Evarutil.new_evar_instance nctx sigma nconcl ~store instance
+      end
+    end
 
 (**************************************************************)
 (*          Fresh names                                       *)
@@ -169,6 +323,90 @@ let fresh_id_in_env avoid id env =
 let fresh_id avoid id gl =
   fresh_id_in_env avoid id (pf_env gl)
 
+let new_fresh_id avoid id gl =
+  fresh_id_in_env avoid id (Proofview.Goal.env gl)
+
+let id_of_name_with_default id = function
+  | Anonymous -> id
+  | Name id   -> id
+
+let default_id_of_sort s =
+  if Sorts.is_small s then default_small_ident else default_type_ident
+
+let default_id env sigma = function
+  | (name,None,t) ->
+      let dft = default_id_of_sort (Retyping.get_sort_of env sigma t) in
+      id_of_name_with_default dft name
+  | (name,Some b,_) -> id_of_name_using_hdchar env b name
+
+(* Non primitive introduction tactics are treated by intro_then_gen
+   There is possibly renaming, with possibly names to avoid and
+   possibly a move to do after the introduction *)
+
+type name_flag =
+  | NamingAvoid of Id.t list
+  | NamingBasedOn of Id.t * Id.t list
+  | NamingMustBe of Loc.t * Id.t
+
+let naming_of_name = function
+  | Anonymous -> NamingAvoid []
+  | Name id -> NamingMustBe (dloc,id)
+
+let find_name mayrepl decl naming gl = match naming with
+  | NamingAvoid idl ->
+      (* this case must be compatible with [find_intro_names] below. *)
+      let env = Proofview.Goal.env gl in
+      let sigma = Proofview.Goal.sigma gl in
+      new_fresh_id idl (default_id env sigma decl) gl
+  | NamingBasedOn (id,idl) ->  new_fresh_id idl id gl
+  | NamingMustBe (loc,id) ->
+      (* When name is given, we allow to hide a global name *)
+      let ids_of_hyps = Tacmach.New.pf_ids_of_hyps gl in
+      let id' = next_ident_away id ids_of_hyps in
+      if not mayrepl && not (Id.equal id' id) then
+        user_err_loc (loc,"",pr_id id ++ str" is already used.");
+      id
+
+(**************************************************************)
+(*            Cut rule                                        *)
+(**************************************************************)
+
+let assert_before_then_gen b naming t tac =
+  Proofview.Goal.enter begin fun gl ->
+    let id = find_name b (Anonymous,None,t) naming gl in
+    Tacticals.New.tclTHENLAST
+      (Proofview.V82.tactic
+         (fun gl ->
+           try internal_cut b id t gl
+           with Evarutil.ClearDependencyError (id,err) ->
+             error_replacing_dependency (pf_env gl) (project gl) id err))
+      (tac id)
+  end
+
+let assert_before_gen b naming t =
+  assert_before_then_gen b naming t (fun _ -> Proofview.tclUNIT ())
+
+let assert_before na = assert_before_gen false (naming_of_name na)
+let assert_before_replacing id = assert_before_gen true (NamingMustBe (dloc,id))
+
+let assert_after_then_gen b naming t tac =
+  Proofview.Goal.enter begin fun gl ->
+    let id = find_name b (Anonymous,None,t) naming gl in
+    Tacticals.New.tclTHENFIRST
+      (Proofview.V82.tactic
+         (fun gl ->
+           try internal_cut_rev b id t gl
+           with Evarutil.ClearDependencyError (id,err) ->
+             error_replacing_dependency (pf_env gl) (project gl) id err))
+      (tac id)
+  end
+
+let assert_after_gen b naming t =
+  assert_after_then_gen b naming t (fun _ -> (Proofview.tclUNIT ()))
+
+let assert_after na = assert_after_gen false (naming_of_name na)
+let assert_after_replacing id = assert_after_gen true (NamingMustBe (dloc,id))
+
 (**************************************************************)
 (*          Fixpoints and CoFixpoints                         *)
 (**************************************************************)
@@ -201,12 +439,12 @@ let pf_reduce_decl redfun where (id,c,ty) gl =
   let redfun' = pf_reduce redfun gl in
   match c with
   | None ->
-      if where = InHypValueOnly then
+      if where == InHypValueOnly then
 	errorlabstrm "" (pr_id id ++ str "has no value.");
       (id,None,redfun' ty)
   | Some b ->
-      let b' = if where <> InHypTypeOnly then redfun' b else b in
-      let ty' =	if where <> InHypValueOnly then redfun' ty else ty in
+      let b' = if where != InHypTypeOnly then redfun' b else b in
+      let ty' =	if where != InHypValueOnly then redfun' ty else ty in
       (id,Some b',ty')
 
 (* Possibly equip a reduction with the occurrences mentioned in an
@@ -227,11 +465,11 @@ let bind_change_occurrences occs = function
 
 let bind_red_expr_occurrences occs nbcl redexp =
   let has_at_clause = function
-    | Unfold l -> List.exists (fun (occl,_) -> occl <> all_occurrences_expr) l
-    | Pattern l -> List.exists (fun (occl,_) -> occl <> all_occurrences_expr) l
-    | Simpl (Some (occl,_)) -> occl <> all_occurrences_expr
+    | Unfold l -> List.exists (fun (occl,_) -> occl != AllOccurrences) l
+    | Pattern l -> List.exists (fun (occl,_) -> occl != AllOccurrences) l
+    | Simpl (_,Some (occl,_)) -> occl != AllOccurrences
     | _ -> false in
-  if occs = all_occurrences_expr then
+  if occs == AllOccurrences then
     if nbcl > 1 && has_at_clause redexp then
       error_illegal_non_atomic_clause ()
     else
@@ -241,24 +479,34 @@ let bind_red_expr_occurrences occs nbcl redexp =
     | Unfold (_::_::_) ->
 	error_illegal_clause ()
     | Unfold [(occl,c)] ->
-	if occl <> all_occurrences_expr then
+	if occl != AllOccurrences then
 	  error_illegal_clause ()
 	else
 	  Unfold [(occs,c)]
     | Pattern (_::_::_) ->
 	error_illegal_clause ()
     | Pattern [(occl,c)] ->
-	if occl <> all_occurrences_expr then
+	if occl != AllOccurrences then
 	  error_illegal_clause ()
 	else
 	  Pattern [(occs,c)]
-    | Simpl (Some (occl,c)) ->
-	if occl <> all_occurrences_expr then
+    | Simpl (f,Some (occl,c)) ->
+	if occl != AllOccurrences then
 	  error_illegal_clause ()
 	else
-	  Simpl (Some (occs,c))
-    | Red _ | Hnf | Cbv _ | Lazy _
-    | ExtraRedExpr _ | CbvVm | Fold _ | Simpl None ->
+	  Simpl (f,Some (occs,c))
+    | CbvVm (Some (occl,c)) ->
+        if occl != AllOccurrences then
+          error_illegal_clause ()
+        else
+          CbvVm (Some (occs,c))
+    | CbvNative (Some (occl,c)) ->
+        if occl != AllOccurrences then
+          error_illegal_clause ()
+        else
+          CbvNative (Some (occs,c))
+    | Red _ | Hnf | Cbv _ | Lazy _ | Cbn _
+    | ExtraRedExpr _ | Fold _ | Simpl (_,None) | CbvVm None | CbvNative None ->
 	error_occurrences_not_unsupported ()
     | Unfold [] | Pattern [] ->
 	assert false
@@ -268,71 +516,177 @@ let bind_red_expr_occurrences occs nbcl redexp =
    certain hypothesis *)
 
 let reduct_in_concl (redfun,sty) gl =
-  convert_concl_no_check (pf_reduce redfun gl (pf_concl gl)) sty gl
+  Proofview.V82.of_tactic (convert_concl_no_check (pf_reduce redfun gl (pf_concl gl)) sty) gl
 
-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 reduct_in_hyp ?(check=false) redfun (id,where) gl =
+  Proofview.V82.of_tactic (convert_hyp ~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
+  if kind == DEFAULTcast then (redfun,REVERTcast) else r
 
-let reduct_option redfun = function
-  | Some id -> reduct_in_hyp (fst redfun) id
+let reduct_option ?(check=false) redfun = function
+  | Some id -> reduct_in_hyp ~check (fst redfun) id
   | 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 =
-  if is_fconv cv_pb env sigma t c then
-    t
+(** Tactic reduction modulo evars (for universes essentially) *)
+
+let pf_e_reduce_decl redfun where (id,c,ty) gl =
+  let sigma = project gl in
+  let redfun = redfun (pf_env gl) in
+  match c with
+  | None ->
+      if where == InHypValueOnly then
+	errorlabstrm "" (pr_id id ++ str "has no value.");
+    let sigma, ty' = redfun sigma ty in
+      sigma, (id,None,ty')
+  | Some b ->
+      let sigma, b' = if where != InHypTypeOnly then redfun sigma b else sigma, b in
+      let sigma, ty' = if where != InHypValueOnly then redfun sigma ty else sigma, ty in
+	sigma, (id,Some b',ty')
+
+let e_reduct_in_concl (redfun,sty) gl =
+  Proofview.V82.of_tactic
+    (let sigma, c' = (pf_apply redfun gl (pf_concl gl)) in
+       Proofview.Unsafe.tclEVARS sigma <*> 
+	 convert_concl_no_check c' sty) gl
+
+let e_reduct_in_hyp ?(check=false) redfun (id,where) gl =
+  Proofview.V82.of_tactic 
+    (let sigma, decl' = pf_e_reduce_decl redfun where (pf_get_hyp gl id) gl in
+       Proofview.Unsafe.tclEVARS sigma <*> 
+	 convert_hyp ~check decl') gl
+
+let e_reduct_option ?(check=false) redfun = function
+  | Some id -> e_reduct_in_hyp ~check (fst redfun) id
+  | None    -> e_reduct_in_concl (revert_cast redfun)
+
+(** Versions with evars to maintain the unification of universes resulting
+    from conversions. *)
+
+let tclWITHEVARS f k =
+  Proofview.Goal.enter begin fun gl ->
+  let evm, c' = f gl in
+  Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS evm) (k c')
+  end
+
+let e_change_in_concl (redfun,sty) =
+  tclWITHEVARS
+    (fun gl -> redfun (Proofview.Goal.env gl) (Proofview.Goal.sigma gl)
+        (Proofview.Goal.raw_concl gl))
+    (fun c -> convert_concl_no_check c sty)
+
+let e_pf_change_decl (redfun : bool -> e_reduction_function) where (id,c,ty) env sigma =
+  match c with
+  | None ->
+      if where == InHypValueOnly then
+	errorlabstrm "" (pr_id id ++ str "has no value.");
+    let sigma',ty' = redfun false env sigma ty in
+      sigma', (id,None,ty')
+  | Some b ->
+      let sigma',b' = if where != InHypTypeOnly then redfun true env sigma b else sigma, b in
+      let sigma',ty' = if where != InHypValueOnly then redfun false env sigma ty else sigma', ty in
+	sigma', (id,Some b',ty')
+
+let e_change_in_hyp redfun (id,where) =
+  tclWITHEVARS
+    (fun gl -> e_pf_change_decl redfun where
+      (Tacmach.New.pf_get_hyp id (Proofview.Goal.assume gl))
+      (Proofview.Goal.env gl) (Proofview.Goal.sigma gl))
+    convert_hyp
+
+type change_arg = evar_map -> evar_map * constr
+
+let check_types env sigma mayneedglobalcheck deep newc origc =
+  let t1 = Retyping.get_type_of env sigma newc in
+  if deep then begin
+    let t2 = Retyping.get_type_of env sigma origc in
+    let sigma, t2 = Evarsolve.refresh_universes ~onlyalg:true (Some false) env sigma t2 in
+    if not (snd (infer_conv ~pb:Reduction.CUMUL env sigma t1 t2)) then
+      if
+        isSort (whd_betadeltaiota env sigma t1) &&
+        isSort (whd_betadeltaiota env sigma t2)
+      then
+        mayneedglobalcheck := true
+      else
+        errorlabstrm "convert-check-hyp" (str "Types are incompatible.")
+  end
   else
-    errorlabstrm "convert-check-hyp" (str "Not convertible.")
+    if not (isSort (whd_betadeltaiota env sigma t1)) then
+      errorlabstrm "convert-check-hyp" (str "Not a type.")
+
+(* Now we introduce different instances of the previous tacticals *)
+let change_and_check cv_pb mayneedglobalcheck deep t env sigma c =
+  let sigma, t' = t sigma in
+  check_types env sigma mayneedglobalcheck deep t' c;
+  let sigma, b = infer_conv ~pb:cv_pb env sigma t' c in
+  if not b then errorlabstrm "convert-check-hyp" (str "Not convertible.");
+  sigma, t'
+
+let change_and_check_subst cv_pb mayneedglobalcheck subst t env sigma c =
+  let t' sigma =
+    let sigma, t = t sigma in
+      sigma, replace_vars (Id.Map.bindings subst) t 
+  in change_and_check cv_pb mayneedglobalcheck true t' env sigma c
 
 (* Use cumulativity only if changing the conclusion not a subterm *)
-let change_on_subterm cv_pb t = function
-  | None -> change_and_check cv_pb t
+let change_on_subterm cv_pb deep t where env sigma c =
+  let mayneedglobalcheck = ref false in
+  let sigma,c = match where with
+  | None -> change_and_check cv_pb mayneedglobalcheck deep t env sigma c
   | Some occl ->
-      contextually false occl
-        (fun subst -> change_and_check Reduction.CONV (replace_vars subst t))
+      e_contextually false occl
+        (fun subst ->
+          change_and_check_subst Reduction.CONV mayneedglobalcheck subst t)
+        env sigma c in
+  if !mayneedglobalcheck then
+    begin
+      try ignore (Typing.type_of env sigma c)
+      with e when catchable_exception e ->
+        error "Replacement would lead to an ill-typed term."
+    end;
+  sigma,c
 
 let change_in_concl occl t =
-  reduct_in_concl ((change_on_subterm Reduction.CUMUL t occl),DEFAULTcast)
+  e_change_in_concl ((change_on_subterm Reduction.CUMUL false t occl),DEFAULTcast)
 
 let change_in_hyp occl t id  =
-  with_check (reduct_in_hyp (change_on_subterm Reduction.CONV t occl) id)
+  e_change_in_hyp (fun x -> change_on_subterm Reduction.CONV x t occl) id
 
 let change_option occl t = function
   | Some id -> change_in_hyp occl t id
   | None -> change_in_concl occl t
 
 let change chg c cls gl =
-  let cls = concrete_clause_of cls gl in
-  tclMAP (function
+  let cls = concrete_clause_of (fun () -> pf_ids_of_hyps gl) cls in
+  Proofview.V82.of_tactic (Tacticals.New.tclMAP (function
     | OnHyp (id,occs,where) ->
        change_option (bind_change_occurrences occs chg) c (Some (id,where))
     | OnConcl occs ->
        change_option (bind_change_occurrences occs chg) c None)
-    cls gl
+    cls) gl
+
+let change_concl t = 
+  change_in_concl None (fun sigma -> sigma, t)
 
 (* Pour usage interne (le niveau User est pris en compte par reduce) *)
-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_in_hyp          = reduct_in_hyp    red_product
 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_in_hyp          = reduct_in_hyp    hnf_constr
 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_in_hyp        = reduct_in_hyp    simpl
 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_in_hyp    = reduct_in_hyp    compute
 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,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)
+let pattern_option l = e_reduct_option (pattern_occs l,DEFAULTcast)
 
 (* The main reduction function *)
 
@@ -345,10 +699,11 @@ let reduction_clause redexp cl =
 	(None, bind_red_expr_occurrences occs nbcl redexp)) cl
 
 let reduce redexp cl goal =
-  let cl = concrete_clause_of cl goal in
+  let cl = concrete_clause_of (fun () -> pf_ids_of_hyps goal) cl in
   let redexps = reduction_clause redexp cl in
   let tac = tclMAP (fun (where,redexp) ->
-    reduct_option (Redexpr.reduction_of_red_expr redexp) where) redexps in
+    e_reduct_option ~check:true
+      (Redexpr.reduction_of_red_expr (pf_env goal) redexp) where) redexps in
   match redexp with
   | Fold _ | Pattern _ -> with_check tac goal
   | _ -> tac goal
@@ -356,49 +711,14 @@ let reduce redexp cl goal =
 (* Unfolding occurrences of a constant *)
 
 let unfold_constr = function
-  | ConstRef sp -> unfold_in_concl [all_occurrences,EvalConstRef sp]
-  | VarRef id -> unfold_in_concl [all_occurrences,EvalVarRef id]
+  | ConstRef sp -> unfold_in_concl [AllOccurrences,EvalConstRef sp]
+  | VarRef id -> unfold_in_concl [AllOccurrences,EvalVarRef id]
   | _ -> errorlabstrm "unfold_constr" (str "Cannot unfold a non-constant.")
 
 (*******************************************)
 (*         Introduction tactics            *)
 (*******************************************)
 
-let id_of_name_with_default id = function
-  | Anonymous -> id
-  | Name id   -> id
-
-let hid = id_of_string "H"
-let xid = id_of_string "X"
-
-let default_id_of_sort = function Prop _ -> hid | Type _ -> xid
-
-let default_id env sigma = function
-  | (name,None,t) ->
-      let dft = default_id_of_sort (Typing.sort_of env sigma t) in
-      id_of_name_with_default dft name
-  | (name,Some b,_) -> id_of_name_using_hdchar env b name
-
-(* Non primitive introduction tactics are treated by central_intro
-   There is possibly renaming, with possibly names to avoid and
-   possibly a move to do after the introduction *)
-
-type intro_name_flag =
-  | IntroAvoid of identifier list
-  | IntroBasedOn of identifier * identifier list
-  | IntroMustBe of identifier
-
-let find_name loc decl gl = function
-  | IntroAvoid idl ->
-      (* this case must be compatible with [find_intro_names] below. *)
-      let id = fresh_id idl (default_id (pf_env gl) gl.sigma decl) gl in id
-  | IntroBasedOn (id,idl) -> fresh_id idl id gl
-  | IntroMustBe id ->
-      (* When name is given, we allow to hide a global name *)
-      let id' = next_ident_away id (pf_ids_of_hyps gl) in
-      if id'<>id then user_err_loc (loc,"",pr_id id ++ str" is already used.");
-      id'
-
 (* Returns the names that would be created by intros, without doing
    intros.  This function is supposed to be compatible with an
    iteration of [find_name] above. As [default_id] checks the sort of
@@ -416,95 +736,138 @@ let find_intro_names ctxt gl =
   List.rev res
 
 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_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 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 tac
-	  gl
+  | MoveLast -> Tacticals.New.tclTHEN (introduction id) (tac id)
+  | dest -> Tacticals.New.tclTHENLIST 
+    [introduction id; 
+     Proofview.V82.tactic (move_hyp id dest); tac id]
+    
+let rec intro_then_gen name_flag move_flag force_flag dep_flag tac =
+  Proofview.Goal.enter begin fun gl ->
+    let concl = Proofview.Goal.concl (Proofview.Goal.assume gl) in
+    let concl = nf_evar (Proofview.Goal.sigma gl) concl in
+    match kind_of_term concl with
+    | Prod (name,t,u) when not dep_flag || (dependent (mkRel 1) u) ->
+        let name = find_name false (name,None,t) name_flag gl in
+	build_intro_tac name move_flag tac
+    | LetIn (name,b,t,u) when not dep_flag || (dependent (mkRel 1) u) ->
+        let name = find_name false (name,Some b,t) name_flag gl in
+	build_intro_tac name move_flag tac
     | _ ->
-	if not force_flag then raise (RefinerError IntroNeedsProduct);
-	try
-	  tclTHEN try_red_in_concl
-	    (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 intro_then_force = intro_then_gen dloc (IntroAvoid []) no_move true false
+	begin if not force_flag then Proofview.tclZERO (RefinerError IntroNeedsProduct)
+            (* Note: red_in_concl includes betaiotazeta and this was like *)
+            (* this since at least V6.3 (a pity *)
+            (* that intro do betaiotazeta only when reduction is needed; and *)
+            (* probably also a pity that intro does zeta *)
+          else Proofview.tclUNIT ()
+        end <*>
+	  Proofview.tclORELSE
+	  (Tacticals.New.tclTHEN (Proofview.V82.tactic hnf_in_concl)
+	     (intro_then_gen name_flag move_flag false dep_flag tac))
+          begin function (e, info) -> match e with
+            | RefinerError IntroNeedsProduct ->
+                Proofview.tclZERO 
+		  (Errors.UserError("Intro",str "No product even after head-reduction."))
+            | e -> Proofview.tclZERO ~info e
+          end
+  end
 
-(**** Multiple introduction tactics ****)
+let intro_gen n m f d = intro_then_gen n m f d (fun _ -> Proofview.tclUNIT ())
+let intro_mustbe_force id = intro_gen (NamingMustBe (dloc,id)) MoveLast true false
+let intro_using id = intro_gen (NamingBasedOn (id,[])) MoveLast false false
 
-let rec intros_using = function
-  | []     -> tclIDTAC
-  | str::l -> tclTHEN (intro_using str) (intros_using l)
+let intro_then = intro_then_gen (NamingAvoid []) MoveLast false false
+let intro = intro_gen (NamingAvoid []) MoveLast false false
+let introf = intro_gen (NamingAvoid []) MoveLast true false
+let intro_avoiding l = intro_gen (NamingAvoid l) MoveLast false false
 
-let intros = tclREPEAT intro
+let intro_then_force = intro_then_gen (NamingAvoid []) MoveLast true false
 
-let intro_erasing id = tclTHEN (thin [id]) (introduction id)
+let intro_move_avoid idopt avoid hto = match idopt with
+  | None -> intro_gen (NamingAvoid avoid) hto true false
+  | Some id -> intro_gen (NamingMustBe (dloc,id)) hto true false
 
-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 intro_move idopt hto = intro_move_avoid idopt [] hto
 
-let rec get_next_hyp_position id = function
-  | [] -> error ("No such hypothesis: " ^ string_of_id id)
-  | (hyp,_,_) :: right ->
-      if hyp = id then
-	match right with (id,_,_)::_ -> MoveBefore id | [] -> MoveToEnd true
-      else
-	get_next_hyp_position id right
+(**** Multiple introduction tactics ****)
 
-let thin_for_replacing l gl =
-  try Tacmach.thin l gl
-  with Evarutil.ClearDependencyError (id,err) -> match err with
-  | Evarutil.OccurHypInSimpleClause None ->
-      errorlabstrm ""
-      (str "Cannot change " ++ pr_id id ++ str ", it is used in conclusion.")
-  | Evarutil.OccurHypInSimpleClause (Some id') ->
-      errorlabstrm ""
-        (str "Cannot change " ++ pr_id id ++
-	 strbrk ", it is used in hypothesis " ++ pr_id id' ++ str".")
-  | Evarutil.EvarTypingBreak ev ->
-      errorlabstrm ""
-        (str "Cannot change " ++ pr_id id ++
-	 strbrk " without breaking the typing of " ++
-	 Printer.pr_existential (pf_env gl) ev ++ str".")
+let rec intros_using = function
+  | []     -> Proofview.tclUNIT()
+  | str::l -> Tacticals.New.tclTHEN (intro_using str) (intros_using l)
+
+let intros = Tacticals.New.tclREPEAT intro
+
+let intro_forthcoming_then_gen name_flag move_flag dep_flag n bound tac =
+  let rec aux n ids =
+    (* Note: we always use the bound when there is one for "*" and "**" *)
+    if (match bound with None -> true | Some (_,p) -> n < p) then
+    Proofview.tclORELSE
+      begin
+      intro_then_gen name_flag move_flag false dep_flag
+         (fun id -> aux (n+1) (id::ids))
+      end
+      begin function (e, info) -> match e with
+      | RefinerError IntroNeedsProduct ->
+          tac ids
+      | e -> Proofview.tclZERO ~info e
+      end
+    else
+      tac ids
+  in
+  aux n []
 
-let intro_replacing id gl =
-  let next_hyp = get_next_hyp_position id (pf_hyps gl) in
-  tclTHENLIST
-    [thin_for_replacing [id]; introduction id; move_hyp true id next_hyp] gl
-
-let intros_replacing ids gl =
-  let rec introrec = function
-    | [] -> tclIDTAC
-    | id::tl ->
-	tclTHEN (tclORELSE (intro_replacing id) (intro_using id))
-           (introrec tl)
+let get_next_hyp_position id gl =
+  let rec get_next_hyp_position id = function
+  | [] -> raise (RefinerError (NoSuchHyp id))
+  | (hyp,_,_) :: right ->
+    if Id.equal hyp id then
+      match right with (id,_,_)::_ -> MoveBefore id | [] -> MoveLast
+    else
+      get_next_hyp_position id right
   in
-  introrec ids gl
+  let hyps = Proofview.Goal.hyps (Proofview.Goal.assume gl) in
+  get_next_hyp_position id hyps
+
+let intro_replacing id =
+  Proofview.Goal.enter begin fun gl ->
+  let next_hyp = get_next_hyp_position id gl in
+  Tacticals.New.tclTHENLIST [
+    Proofview.V82.tactic (thin_for_replacing [id]);
+    introduction id;
+    Proofview.V82.tactic (move_hyp id next_hyp);
+  ]
+  end
 
-(* User-level introduction tactics *)
+(* We have e.g. [x, y, y', x', y'' |- forall y y' y'', G] and want to
+   reintroduce y, y,' y''. Note that we have to clear y, y' and y''
+   before introducing y because y' or y'' can e.g. depend on old y. *)
+
+(* This version assumes that replacement is actually possible *)
+(* (ids given in the introduction order) *)
+(* We keep a sub-optimality in cleaing for compatibility with *)
+(* the behavior of inversion *)
+let intros_possibly_replacing ids =
+  let suboptimal = true in
+  Proofview.Goal.enter begin fun gl ->
+    let posl = List.map (fun id -> (id, get_next_hyp_position id gl)) ids in
+    Tacticals.New.tclTHEN
+      (Tacticals.New.tclMAP (fun id -> 
+	Tacticals.New.tclTRY (Proofview.V82.tactic (thin_for_replacing [id])))
+	 (if suboptimal then ids else List.rev ids))
+      (Tacticals.New.tclMAP (fun (id,pos) ->
+        Tacticals.New.tclORELSE (intro_move (Some id) pos) (intro_using id))
+         posl)
+  end
+
+(* This version assumes that replacement is actually possible *)
+let intros_replacing ids =
+  Proofview.Goal.enter begin fun gl ->
+    let posl = List.map (fun id -> (id, get_next_hyp_position id gl)) ids in
+    Tacticals.New.tclTHEN
+      (Proofview.V82.tactic (thin_for_replacing ids))
+      (Tacticals.New.tclMAP (fun (id,pos) -> intro_move (Some id) pos) posl)
+  end
 
-let intro_move idopt hto = match idopt with
-  | None -> intro_gen dloc (IntroAvoid []) hto true false
-  | Some id -> intro_gen dloc (IntroMustBe id) hto true false
+(* User-level introduction tactics *)
 
 let pf_lookup_hypothesis_as_renamed env ccl = function
   | AnonHyp n -> Detyping.lookup_index_as_renamed env ccl n
@@ -516,15 +879,15 @@ let pf_lookup_hypothesis_as_renamed_gen red h gl =
     match pf_lookup_hypothesis_as_renamed env ccl h with
       | None when red ->
           aux
-	    ((fst (Redexpr.reduction_of_red_expr (Red true)))
-	       env (project gl) ccl)
+	    (snd ((fst (Redexpr.reduction_of_red_expr env (Red true)))
+	       env (project gl) ccl))
       | x -> x
   in
   try aux (pf_concl gl)
   with Redelimination -> None
 
 let is_quantified_hypothesis id g =
-  match pf_lookup_hypothesis_as_renamed_gen true (NamedHyp id) g with
+  match pf_lookup_hypothesis_as_renamed_gen false (NamedHyp id) g with
     | Some _ -> true
     | None -> false
 
@@ -545,167 +908,167 @@ let depth_of_quantified_hypothesis red h gl =
 	  (if red then strbrk " even after head-reduction" else mt ()) ++
 	  str".")
 
-let intros_until_gen red h g =
-  tclDO (depth_of_quantified_hypothesis red h g) (if red then introf else intro) g
+let intros_until_gen red h =
+  Proofview.Goal.nf_enter begin fun gl ->
+  let n = Tacmach.New.of_old (depth_of_quantified_hypothesis red h) gl in
+  Tacticals.New.tclDO n (if red then introf else intro)
+  end
 
-let intros_until_id id = intros_until_gen true (NamedHyp id)
+let intros_until_id id = intros_until_gen false (NamedHyp id)
 let intros_until_n_gen red n = intros_until_gen red (AnonHyp n)
 
 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)
+  Tacticals.New.tclORELSE (intros_until_id id) (Proofview.V82.tactic (tclCHECKVAR id))
 
 let try_intros_until tac = function
-  | NamedHyp id -> tclTHEN (try_intros_until_id_check id) (tac id)
-  | AnonHyp n -> tclTHEN (intros_until_n n) (onLastHypId tac)
+  | NamedHyp id -> Tacticals.New.tclTHEN (try_intros_until_id_check id) (tac id)
+  | AnonHyp n -> Tacticals.New.tclTHEN (intros_until_n n) (Tacticals.New.onLastHypId tac)
 
 let rec intros_move = function
-  | [] -> tclIDTAC
+  | [] -> Proofview.tclUNIT ()
   | (hyp,destopt) :: rest ->
-      tclTHEN (intro_gen dloc (IntroMustBe hyp) destopt false false)
+      Tacticals.New.tclTHEN (intro_gen (NamingMustBe (dloc,hyp)) destopt false false)
 	(intros_move rest)
 
-let dependent_in_decl a (_,c,t) =
-  match c with
-    | None -> dependent a t
-    | Some body -> dependent a body || dependent a 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
+let onOpenInductionArg env sigma tac = function
+  | clear_flag,ElimOnConstr f ->
+      let (sigma',cbl) = f env sigma in
+      let pending = (sigma,sigma') in
+      Tacticals.New.tclTHEN
+        (Proofview.Unsafe.tclEVARS sigma')
+        (tac clear_flag (pending,cbl))
+  | clear_flag,ElimOnAnonHyp n ->
+      Tacticals.New.tclTHEN
         (intros_until_n n)
-        (onLastHyp (fun c -> tac (Evd.empty,(c,NoBindings))))
-  | ElimOnIdent (_,id) ->
+        (Tacticals.New.onLastHyp
+           (fun c ->
+             Proofview.Goal.enter begin fun gl ->
+             let sigma = Proofview.Goal.sigma gl in
+             let pending = (sigma,sigma) in
+             tac clear_flag (pending,(c,NoBindings))
+             end))
+  | clear_flag,ElimOnIdent (_,id) ->
       (* A quantified hypothesis *)
-      tclTHEN
+      Tacticals.New.tclTHEN
         (try_intros_until_id_check id)
-        (tac (Evd.empty,(mkVar id,NoBindings)))
+        (Proofview.Goal.enter begin fun gl ->
+         let sigma = Proofview.Goal.sigma gl in
+         let pending = (sigma,sigma) in
+         tac clear_flag (pending,(mkVar id,NoBindings))
+        end)
 
 let onInductionArg tac = function
-  | ElimOnConstr cbl ->
-      tac cbl
-  | ElimOnAnonHyp n ->
-      tclTHEN (intros_until_n n) (onLastHyp (fun c -> tac (c,NoBindings)))
-  | ElimOnIdent (_,id) ->
+  | clear_flag,ElimOnConstr cbl ->
+      tac clear_flag cbl
+  | clear_flag,ElimOnAnonHyp n ->
+      Tacticals.New.tclTHEN
+        (intros_until_n n)
+        (Tacticals.New.onLastHyp (fun c -> tac clear_flag (c,NoBindings)))
+  | clear_flag,ElimOnIdent (_,id) ->
       (* A quantified hypothesis *)
-      tclTHEN (try_intros_until_id_check id) (tac (mkVar id,NoBindings))
+      Tacticals.New.tclTHEN
+        (try_intros_until_id_check id)
+        (tac clear_flag (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    *)
-(**************************)
+  | clear_flag,ElimOnConstr g -> clear_flag,ElimOnConstr (f g)
+  | clear_flag,ElimOnAnonHyp n as x -> x
+  | clear_flag,ElimOnIdent id as x -> x
 
-let apply_type hdcty argl gl =
-  refine (applist (mkCast (Evarutil.mk_new_meta(),DEFAULTcast, hdcty),argl)) gl
-
-let apply_term hdc argl gl =
-  refine (applist (hdc,argl)) gl
+(****************************************)
+(* tactic "cut" (actually modus ponens) *)
+(****************************************)
 
-let bring_hyps hyps =
-  if hyps = [] then Refiner.tclIDTAC
-  else
-    (fun gl ->
-      let newcl = List.fold_right mkNamedProd_or_LetIn hyps (pf_concl gl) in
-      let f = mkCast (Evarutil.mk_new_meta(),DEFAULTcast, newcl) in
-      refine_no_check (mkApp (f, instance_from_named_context hyps)) gl)
-
-let resolve_classes gl =
-  let env = pf_env gl and evd = project gl in
-    if Evd.is_empty evd then tclIDTAC gl
+let cut c =
+  Proofview.Goal.enter begin fun gl ->
+    let env = Proofview.Goal.env gl in
+    let sigma = Proofview.Goal.sigma gl in
+    let concl = Tacmach.New.pf_nf_concl gl in
+    let is_sort =
+      try
+        (** Backward compat: ensure that [c] is well-typed. *)
+        let typ = Typing.type_of env sigma c in
+        let typ = whd_betadeltaiota env sigma typ in
+        match kind_of_term typ with
+        | Sort _ -> true
+        | _ -> false
+      with e when Pretype_errors.precatchable_exception e -> false
+    in
+    if is_sort then
+      let id = next_name_away_with_default "H" Anonymous (Tacmach.New.pf_ids_of_hyps gl) in
+      (** Backward compat: normalize [c]. *)
+      let c = local_strong whd_betaiota sigma c in
+      Proofview.Refine.refine ~unsafe:true begin fun h ->
+        let (h, f) = Evarutil.new_evar ~principal:true env h (mkArrow c (Vars.lift 1 concl)) in
+        let (h, x) = Evarutil.new_evar env h c in
+        let f = mkLambda (Name id, c, mkApp (Vars.lift 1 f, [|mkRel 1|])) in
+        (h, mkApp (f, [|x|]))
+      end
     else
-      let evd' = Typeclasses.resolve_typeclasses env evd in
-	(tclTHEN (tclEVARS evd') tclNORMEVAR) gl
-
-(**************************)
-(*     Cut tactics        *)
-(**************************)
-
-let cut c gl =
-  match kind_of_term (pf_hnf_type_of gl c) with
-    | Sort _ ->
-        let id=next_name_away_with_default "H" Anonymous (pf_ids_of_hyps gl) in
-        let t = mkProd (Anonymous, c, pf_concl gl) in
-          tclTHENFIRST
-            (internal_cut_rev id c)
-            (tclTHEN (apply_type t [mkVar id]) (thin [id]))
-            gl
-    | _  -> error "Not a proposition or a type."
-
-let cut_intro t = tclTHENFIRST (cut t) intro
-
-(* [assert_replacing id T tac] adds the subgoals of the proof of [T]
-   before the current goal
-
-   id:T0                 id:T0    id:T     
-   =====   ------>   tac(=====) + ==== 
-    G                     T        G
-
-   It fails if the hypothesis to replace appears in the goal or in
-   another hypothesis.
-*) 
-
-let assert_replacing id t tac = tclTHENFIRST (internal_cut_replace id t) tac
-
-(* [cut_replacing id T tac] adds the subgoals of the proof of [T]
-   after the current goal
-
-   id:T0             id:T       id:T0
-   =====   ------>   ==== + tac(=====)
-    G                 G          T
-
-   It fails if the hypothesis to replace appears in the goal or in
-   another hypothesis.
-*)
-
-let cut_replacing id t tac = tclTHENLAST (internal_cut_rev_replace id t) tac
-
-let cut_in_parallel l =
-  let rec prec = function
-    | [] -> tclIDTAC
-    | h::t -> tclTHENFIRST (cut h) (prec t)
-  in
-    prec (List.rev l)
+      Tacticals.New.tclZEROMSG (str "Not a proposition or a type.")
+  end
 
 let error_uninstantiated_metas t clenv =
   let na = meta_name clenv.evd (List.hd (Metaset.elements (metavars_of t))) in
-  let id = match na with Name id -> id | _ -> anomaly "unnamed dependent meta"
+  let id = match na with Name id -> id | _ -> anomaly (Pp.str "unnamed dependent meta")
   in errorlabstrm "" (str "Cannot find an instance for " ++ pr_id id ++ str".")
 
+let check_unresolved_evars_of_metas sigma clenv =
+  (* This checks that Metas turned into Evars by *)
+  (* Refiner.pose_all_metas_as_evars are resolved *)
+  List.iter (fun (mv,b) -> match b with
+  | Clval (_,(c,_),_) ->
+    (match kind_of_term c.rebus with
+    | Evar (evk,_) when Evd.is_undefined clenv.evd evk
+                     && not (Evd.mem sigma evk) ->
+      error_uninstantiated_metas (mkMeta mv) clenv
+    | _ -> ())
+  | _ -> ())
+  (meta_list clenv.evd)
+
+let do_replace id = function
+  | NamingMustBe (_,id') when Option.equal Id.equal id (Some id') -> true
+  | _ -> false
+
 (* For a clenv expressing some lemma [C[?1:T1,...,?n:Tn] : P] and some
    goal [G], [clenv_refine_in] returns [n+1] subgoals, the [n] last
    ones (resp [n] first ones if [sidecond_first] is [true]) being the
    [Ti] and the first one (resp last one) being [G] whose hypothesis
    [id] is replaced by P using the proof given by [tac] *)
 
-let clenv_refine_in ?(sidecond_first=false) with_evars ?(with_classes=true) id clenv gl =
-  let clenv = clenv_pose_dependent_evars with_evars clenv in
+let clenv_refine_in ?(sidecond_first=false) with_evars ?(with_classes=true) 
+    targetid id sigma0 clenv tac =
+  let clenv = Clenvtac.clenv_pose_dependent_evars with_evars clenv in
   let clenv =
     if with_classes then
-      { clenv with evd = Typeclasses.resolve_typeclasses ~fail:(not with_evars) clenv.env clenv.evd }
+      { clenv with evd = Typeclasses.resolve_typeclasses 
+	  ~fail:(not with_evars) clenv.env clenv.evd }
     else clenv
   in
   let new_hyp_typ = clenv_type clenv in
-  if not with_evars & occur_meta new_hyp_typ then
+  if not with_evars then check_unresolved_evars_of_metas sigma0 clenv;
+  if not with_evars && occur_meta new_hyp_typ then
     error_uninstantiated_metas new_hyp_typ clenv;
   let new_hyp_prf = clenv_value clenv in
-  tclTHEN
-    (tclEVARS clenv.evd)
-    ((if sidecond_first then assert_replacing else cut_replacing)
-      id new_hyp_typ (refine_no_check new_hyp_prf)) gl
+  let exact_tac = Proofview.V82.tactic (refine_no_check new_hyp_prf) in
+  let naming = NamingMustBe (dloc,targetid) in
+  let with_clear = do_replace (Some id) naming in
+  Tacticals.New.tclTHEN
+    (Proofview.Unsafe.tclEVARS clenv.evd)
+    (if sidecond_first then
+       Tacticals.New.tclTHENFIRST
+         (assert_before_then_gen with_clear naming new_hyp_typ tac) exact_tac
+     else
+       Tacticals.New.tclTHENLAST
+         (assert_after_then_gen with_clear naming new_hyp_typ tac) exact_tac)
 
 (********************************************)
 (*       Elimination tactics                *)
@@ -713,14 +1076,14 @@ let clenv_refine_in ?(sidecond_first=false) with_evars ?(with_classes=true) id c
 
 let last_arg c = match kind_of_term c with
   | App (f,cl) ->
-      array_last cl
-  | _ -> anomaly "last_arg"
+      Array.last cl
+  | _ -> anomaly (Pp.str "last_arg")
 
 let nth_arg i c =
-  if i = -1 then last_arg c else
+  if Int.equal i (-1) then last_arg c else
   match kind_of_term c with
   | App (f,cl) -> cl.(i)
-  | _ -> anomaly "nth_arg"
+  | _ -> anomaly (Pp.str "nth_arg")
 
 let index_of_ind_arg t =
   let rec aux i j t = match kind_of_term t with
@@ -733,7 +1096,51 @@ let index_of_ind_arg t =
       | None -> error "Could not find inductive argument of elimination scheme."
   in aux None 0 t
 
-let elimination_clause_scheme with_evars ?(flags=elim_flags) i elimclause indclause gl =
+let enforce_prop_bound_names rename tac =
+  match rename with
+  | Some (isrec,nn) when Namegen.use_h_based_elimination_names () ->
+      (* Rename dependent arguments in Prop with name "H" *)
+      (* so as to avoid having hypothesis such as "t:True", "n:~A" when calling *)
+      (* elim or induction with schemes built by Indrec.build_induction_scheme *)
+      let rec aux env sigma i t =
+        if i = 0 then t else match kind_of_term t with
+        | Prod (Name _ as na,t,t') ->
+            let very_standard = true in
+            let na =
+              if Retyping.get_sort_family_of env sigma t = InProp then
+                (* "very_standard" says that we should have "H" names only, but
+                   this would break compatibility even more... *)
+                let s = match Namegen.head_name t with
+                  | Some id when not very_standard -> string_of_id id
+                  | _ -> "" in
+                Name (add_suffix Namegen.default_prop_ident s)
+              else
+                na in
+            mkProd (na,t,aux (push_rel (na,None,t) env) sigma (i-1) t')
+        | Prod (Anonymous,t,t') ->
+            mkProd (Anonymous,t,aux (push_rel (Anonymous,None,t) env) sigma (i-1) t')
+        | LetIn (na,c,t,t') ->
+            mkLetIn (na,c,t,aux (push_rel (na,Some c,t) env) sigma (i-1) t')
+        | _ -> print_int i; Pp.msg (print_constr t); assert false in
+      let rename_branch i =
+        Proofview.Goal.nf_enter begin fun gl ->
+          let env = Proofview.Goal.env gl in
+          let sigma = Proofview.Goal.sigma gl in
+          let t = Proofview.Goal.concl gl in
+          change_concl (aux env sigma i t)
+        end in
+      (if isrec then Tacticals.New.tclTHENFIRSTn else Tacticals.New.tclTHENLASTn)
+        tac
+        (Array.map rename_branch nn)
+  | _ ->
+      tac
+
+let elimination_clause_scheme with_evars ?(with_classes=true) ?(flags=elim_flags ()) 
+    rename i (elim, elimty, bindings) indclause =
+  Proofview.Goal.enter begin fun gl ->
+  let env = Proofview.Goal.env gl in
+  let sigma = Proofview.Goal.sigma gl in
+  let elimclause = make_clenv_binding env sigma (elim, elimty) bindings in
   let indmv =
     (match kind_of_term (nth_arg i elimclause.templval.rebus) with
        | Meta mv -> mv
@@ -741,7 +1148,8 @@ let elimination_clause_scheme with_evars ?(flags=elim_flags) i elimclause indcla
              (str "The type of elimination clause is not well-formed."))
   in
   let elimclause' = clenv_fchain ~flags indmv elimclause indclause in
-  res_pf elimclause' ~with_evars:with_evars ~flags gl
+  enforce_prop_bound_names rename (Clenvtac.res_pf elimclause' ~with_evars ~with_classes ~flags)
+  end
 
 (*
  * Elimination tactic with bindings and using an arbitrary
@@ -753,53 +1161,116 @@ let elimination_clause_scheme with_evars ?(flags=elim_flags) i elimclause indcla
 
 type eliminator = {
   elimindex : int option;  (* None = find it automatically *)
+  elimrename : (bool * int array) option; (** None = don't rename Prop hyps with H-names *)
   elimbody : constr with_bindings
 }
 
-let general_elim_clause_gen elimtac indclause elim gl =
+let general_elim_clause_gen elimtac indclause elim =
+  Proofview.Goal.enter begin fun gl ->
+  let env = Proofview.Goal.env gl in
+  let sigma = Proofview.Goal.sigma gl in
   let (elimc,lbindelimc) = elim.elimbody in
-  let elimt = pf_type_of gl elimc in
+  let elimt = Retyping.get_type_of env sigma elimc in
   let i =
     match elim.elimindex with None -> index_of_ind_arg elimt | Some i -> i in
-  let elimclause = make_clenv_binding gl (elimc,elimt) lbindelimc in
-  elimtac i elimclause indclause gl
+  elimtac elim.elimrename i (elimc, elimt, lbindelimc) indclause
+  end
 
-let general_elim_clause elimtac (c,lbindc) elim gl =
-  let ct = pf_type_of gl c in
-  let t = try snd (pf_reduce_to_quantified_ind gl ct) with UserError _ -> ct in
-  let indclause  = make_clenv_binding gl (c,t) lbindc  in
-    general_elim_clause_gen elimtac indclause elim gl
+let general_elim with_evars clear_flag (c, lbindc) elim =
+  Proofview.Goal.enter begin fun gl ->
+  let env = Proofview.Goal.env gl in
+  let sigma = Proofview.Goal.sigma gl in
+  let ct = Retyping.get_type_of env sigma c in
+  let t = try snd (reduce_to_quantified_ind env sigma ct) with UserError _ -> ct in
+  let elimtac = elimination_clause_scheme with_evars in
+  let indclause  = make_clenv_binding env sigma (c, t) lbindc in
+  Tacticals.New.tclTHEN
+    (general_elim_clause_gen elimtac indclause elim)
+    (apply_clear_request clear_flag (use_clear_hyp_by_default ()) c)
+  end
 
-let general_elim with_evars c e =
-  general_elim_clause (elimination_clause_scheme with_evars) c e
+(* Case analysis tactics *)
+
+let general_case_analysis_in_context with_evars clear_flag (c,lbindc) =
+  Proofview.Goal.nf_enter begin fun gl ->
+  let env = Proofview.Goal.env gl in
+  let sigma = Proofview.Goal.sigma gl in
+  let concl = Proofview.Goal.concl gl in
+  let t = Retyping.get_type_of env sigma c in
+  let (mind,_) = reduce_to_quantified_ind env sigma t in
+  let sort = Tacticals.New.elimination_sort_of_goal gl in
+  let sigma, elim =
+    if occur_term c concl then
+      build_case_analysis_scheme env sigma mind true sort
+    else
+      build_case_analysis_scheme_default env sigma mind sort in
+  Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS sigma)
+  (general_elim with_evars clear_flag (c,lbindc)
+   {elimindex = None; elimbody = (elim,NoBindings);
+    elimrename = Some (false, constructors_nrealdecls (fst mind))})
+  end
+
+let general_case_analysis with_evars clear_flag (c,lbindc as cx) =
+  match kind_of_term c with
+    | Var id when lbindc == NoBindings ->
+	Tacticals.New.tclTHEN (try_intros_until_id_check id)
+	  (general_case_analysis_in_context with_evars clear_flag cx)
+    | _ ->
+        general_case_analysis_in_context with_evars clear_flag cx
+
+let simplest_case c = general_case_analysis false None (c,NoBindings)
 
 (* Elimination tactic with bindings but using the default elimination
  * constant associated with the type. *)
 
-let find_eliminator c gl =
-  let (ind,t) = pf_reduce_to_quantified_ind gl (pf_type_of gl c) in
-  let c = lookup_eliminator ind (elimination_sort_of_goal gl) in
-  {elimindex = None; elimbody = (c,NoBindings)}
+exception IsNonrec
+
+let is_nonrec mind = (Global.lookup_mind (fst mind)).mind_finite == Decl_kinds.BiFinite
 
-let default_elim with_evars (c,_ as cx) gl =
-  general_elim with_evars cx (find_eliminator c gl) gl
+let find_ind_eliminator ind s gl =
+  let gr = lookup_eliminator ind s in
+  let evd, c = Tacmach.New.pf_apply Evd.fresh_global gl gr in
+    evd, c
 
-let elim_in_context with_evars c = function
+let find_eliminator c gl =
+  let ((ind,u),t) = Tacmach.New.pf_reduce_to_quantified_ind gl (Tacmach.New.pf_type_of gl c) in
+  if is_nonrec ind then raise IsNonrec;
+  let evd, c = find_ind_eliminator ind (Tacticals.New.elimination_sort_of_goal gl) gl in
+    evd, {elimindex = None; elimbody = (c,NoBindings);
+          elimrename = Some (true, constructors_nrealdecls ind)}
+
+let default_elim with_evars clear_flag (c,_ as cx) =
+  Proofview.tclORELSE
+    (Proofview.Goal.enter begin fun gl ->
+      let evd, elim = find_eliminator c gl in
+	Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS evd)
+	  (general_elim with_evars clear_flag cx elim)
+    end)
+    begin function (e, info) -> match e with
+      | IsNonrec ->
+          (* For records, induction principles aren't there by default
+             anymore.  Instead, we do a case analysis instead. *)
+          general_case_analysis with_evars clear_flag cx
+      | e -> Proofview.tclZERO ~info e
+    end
+
+let elim_in_context with_evars clear_flag c = function
   | Some elim ->
-      general_elim with_evars c {elimindex = Some (-1); elimbody = elim}
-  | None -> default_elim with_evars c
+      general_elim with_evars clear_flag c
+        {elimindex = Some (-1); elimbody = elim; elimrename = None}
+  | None -> default_elim with_evars clear_flag c
 
-let elim with_evars (c,lbindc as cx) elim =
+let elim with_evars clear_flag (c,lbindc as cx) elim =
   match kind_of_term c with
-    | Var id when lbindc = NoBindings ->
-	tclTHEN (try_intros_until_id_check id)
-	  (elim_in_context with_evars cx elim)
+    | Var id when lbindc == NoBindings ->
+	Tacticals.New.tclTHEN (try_intros_until_id_check id)
+	  (elim_in_context with_evars clear_flag cx elim)
     | _ ->
-	elim_in_context with_evars cx elim
+	elim_in_context with_evars clear_flag cx elim
 
 (* The simplest elimination tactic, with no substitutions at all. *)
 
-let simplest_elim c = default_elim false (c,NoBindings)
+let simplest_elim c = default_elim false None (c,NoBindings)
 
 (* Elimination in hypothesis *)
 (* Typically, elimclause := (eq_ind ?x ?P ?H ?y ?Heq : ?P ?y)
@@ -811,56 +1282,44 @@ let simplest_elim c = default_elim false (c,NoBindings)
    (e.g. it could replace id:A->B->C by id:C, knowing A/\B)
 *)
 
-let clenv_fchain_in id ?(flags=elim_flags) mv elimclause hypclause =
+let clenv_fchain_in id ?(flags=elim_flags ()) mv elimclause hypclause =
   try clenv_fchain ~flags mv elimclause hypclause
   with PretypeError (env,evd,NoOccurrenceFound (op,_)) ->
     (* Set the hypothesis name in the message *)
     raise (PretypeError (env,evd,NoOccurrenceFound (op,Some id)))
 
-let elimination_in_clause_scheme with_evars ?(flags=elim_flags) id i elimclause indclause gl =
+let elimination_in_clause_scheme with_evars ?(flags=elim_flags ()) 
+    id rename i (elim, elimty, bindings) indclause =
+  Proofview.Goal.enter begin fun gl ->
+  let env = Proofview.Goal.env gl in
+  let sigma = Proofview.Goal.sigma gl in
+  let elimclause = make_clenv_binding env sigma (elim, elimty) bindings in
   let indmv = destMeta (nth_arg i elimclause.templval.rebus) in
   let hypmv =
-    try match list_remove indmv (clenv_independent elimclause) with
+    try match List.remove Int.equal indmv (clenv_independent elimclause) with
       | [a] -> a
       | _ -> failwith ""
     with Failure _ -> errorlabstrm "elimination_clause"
           (str "The type of elimination clause is not well-formed.") 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 hyp_typ = Retyping.get_type_of env sigma hyp in
+  let hypclause = mk_clenv_from_env env sigma (Some 0) (hyp, hyp_typ) 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
+  if Term.eq_constr hyp_typ new_hyp_typ then
     errorlabstrm "general_rewrite_in"
       (str "Nothing to rewrite in " ++ pr_id id ++ str".");
-  clenv_refine_in with_evars id elimclause'' gl
-
-let general_elim_in with_evars id =
-  general_elim_clause (elimination_in_clause_scheme with_evars id)
-
-(* Case analysis tactics *)
-
-let general_case_analysis_in_context with_evars (c,lbindc) gl =
-  let (mind,_) = pf_reduce_to_quantified_ind gl (pf_type_of gl c) in
-  let sort = elimination_sort_of_goal gl in
-  let elim =
-    if occur_term c (pf_concl gl) then
-      pf_apply build_case_analysis_scheme gl mind true sort
-    else
-      pf_apply build_case_analysis_scheme_default gl mind sort in
-  general_elim with_evars (c,lbindc)
-    {elimindex = None; elimbody = (elim,NoBindings)} gl
-
-let general_case_analysis with_evars (c,lbindc as cx) =
-  match kind_of_term c with
-    | Var id when lbindc = NoBindings ->
-	tclTHEN (try_intros_until_id_check id)
-	  (general_case_analysis_in_context with_evars cx)
-    | _ ->
-	general_case_analysis_in_context with_evars cx
+  clenv_refine_in with_evars id id sigma elimclause''
+    (fun id -> Proofview.tclUNIT ())
+  end
 
-let simplest_case c = general_case_analysis false (c,NoBindings)
+let general_elim_clause with_evars flags id c e =
+  let elim = match id with
+  | None -> elimination_clause_scheme with_evars ~with_classes:true ~flags
+  | Some id -> elimination_in_clause_scheme with_evars ~flags id
+  in
+  general_elim_clause_gen elim c e
 
 (* Apply a tactic below the products of the conclusion of a lemma *)
 
@@ -868,7 +1327,7 @@ type conjunction_status =
   | DefinedRecord of constant option list
   | NotADefinedRecordUseScheme of constr
 
-let make_projection sigma params cstr sign elim i n c =
+let make_projection env sigma params cstr sign elim i n c u =
   let elim = match elim with
   | NotADefinedRecordUseScheme elim ->
       (* bugs: goes from right to left when i increases! *)
@@ -878,111 +1337,205 @@ let make_projection sigma params cstr sign elim i n c =
       if
 	(* excludes dependent projection types *)
 	noccur_between 1 (n-i-1) t
-	(* excludes flexible projection types *)
+	(* to avoid surprising unifications, excludes flexible
+	projection types or lambda which will be instantiated by Meta/Evar *)
 	&& not (isEvar (fst (whd_betaiota_stack sigma t)))
+	&& not (isRel t && destRel t > n-i)
       then
         let t = lift (i+1-n) t in
-	Some (beta_applist (elim,params@[t;branch]),t)
+	let abselim = beta_applist (elim,params@[t;branch]) in
+	let c = beta_applist (abselim, [mkApp (c, extended_rel_vect 0 sign)]) in
+	  Some (it_mkLambda_or_LetIn c sign, it_mkProd_or_LetIn t sign)
       else
 	None
   | DefinedRecord l ->
       (* goes from left to right when i increases! *)
       match List.nth l i with
       | Some proj ->
-	  let t = Typeops.type_of_constant (Global.env()) proj in
 	  let args = extended_rel_vect 0 sign in
-	  Some (beta_applist (mkConst proj,params),prod_applist t (params@[mkApp (c,args)]))
+	  let proj =
+	    if Environ.is_projection proj env then
+	      mkProj (Projection.make proj false, mkApp (c, args))
+	    else
+	      mkApp (mkConstU (proj,u), Array.append (Array.of_list params)
+		[|mkApp (c, args)|])
+	  in
+	  let app = it_mkLambda_or_LetIn proj sign in
+	  let t = Retyping.get_type_of env sigma app in
+	    Some (app, t)
       | None -> None
-  in Option.map (fun (abselim,elimt) -> 
-    let c = beta_applist (abselim,[mkApp (c,extended_rel_vect 0 sign)]) in
-    (it_mkLambda_or_LetIn c sign, it_mkProd_or_LetIn elimt sign)) elim
+  in elim
 
-let descend_in_conjunctions tac exit c gl =
+let descend_in_conjunctions avoid tac exit c =
+  Proofview.Goal.nf_enter begin fun gl ->
+  let env = Proofview.Goal.env gl in
+  let sigma = Proofview.Goal.sigma gl in
   try
-    let (ind,t) = pf_reduce_to_quantified_ind gl (pf_type_of gl c) in
+    let t = Retyping.get_type_of env sigma c in
+    let ((ind,u),t) = reduce_to_quantified_ind env sigma t in
     let sign,ccl = decompose_prod_assum t in
     match match_with_tuple ccl with
     | Some (_,_,isrec) ->
-	let n = (mis_constr_nargs ind).(0) in
-	let sort = elimination_sort_of_goal gl in
-	let id = fresh_id [] (id_of_string "H") gl in
-	let IndType (indf,_) = pf_apply find_rectype gl ccl in
-	let params = snd (dest_ind_family indf) in
-	let cstr = (get_constructors (pf_env gl) indf).(0) in
+	let n = (constructors_nrealargs ind).(0) in
+	let sort = Tacticals.New.elimination_sort_of_goal gl in
+	let IndType (indf,_) = find_rectype env sigma ccl in
+	let (_,inst), params = dest_ind_family indf in
+	let cstr = (get_constructors env indf).(0) in
 	let elim =
 	  try DefinedRecord (Recordops.lookup_projections ind)
 	  with Not_found ->
-	    let elim = pf_apply build_case_analysis_scheme gl ind false sort in
-	    NotADefinedRecordUseScheme elim in
-	tclFIRST
-	  (list_tabulate (fun i gl ->
-	    match make_projection (project gl) params cstr sign elim i n c with
-	    | None -> tclFAIL 0 (mt()) gl
+	    let elim = build_case_analysis_scheme env sigma (ind,u) false sort in
+	    NotADefinedRecordUseScheme (snd elim) in
+	Tacticals.New.tclFIRST
+	  (List.init n (fun i ->
+            Proofview.Goal.enter begin fun gl ->
+            let env = Proofview.Goal.env gl in
+            let sigma = Proofview.Goal.sigma gl in
+	    match make_projection env sigma params cstr sign elim i n c u with
+	    | None -> Tacticals.New.tclFAIL 0 (mt())
 	    | Some (p,pt) ->
-	    tclTHENS
-	      (internal_cut id pt)
-	      [refine p; (* Might be ill-typed due to forbidden elimination. *)
-	       tclTHEN (tac (not isrec) (mkVar id)) (thin [id])] gl) n)
-	  gl
+	      Tacticals.New.tclTHENS
+		(assert_before_gen false (NamingAvoid avoid) pt)
+		[Proofview.V82.tactic (refine p);
+		 (* Might be ill-typed due to forbidden elimination. *)
+		 Tacticals.New.onLastHypId (tac (not isrec))]
+           end))
     | None ->
 	raise Exit
   with RefinerError _|UserError _|Exit -> exit ()
+  end
 
 (****************************************************)
 (*            Resolution tactics                    *)
 (****************************************************)
 
-let general_apply with_delta with_destruct with_evars (loc,(c,lbind)) gl0 =
+let solve_remaining_apply_goals =
+  Proofview.Goal.nf_enter begin fun gl ->
+  if !apply_solve_class_goals then
+    try 
+      let env = Proofview.Goal.env gl in
+      let sigma = Proofview.Goal.sigma gl in
+      let concl = Proofview.Goal.concl gl in
+      if Typeclasses.is_class_type sigma concl then
+        let evd', c' = Typeclasses.resolve_one_typeclass env sigma concl in
+	Tacticals.New.tclTHEN
+          (Proofview.Unsafe.tclEVARS evd')
+          (Proofview.V82.tactic (refine_no_check c'))
+	else Proofview.tclUNIT ()
+    with Not_found -> Proofview.tclUNIT ()
+  else Proofview.tclUNIT ()
+  end
+  
+let general_apply with_delta with_destruct with_evars clear_flag (loc,(c,lbind)) =
+  Proofview.Goal.nf_enter begin fun gl ->
+  let concl = Proofview.Goal.concl gl in
   let flags =
-    if with_delta then default_unify_flags else default_no_delta_unify_flags in
+    if with_delta then default_unify_flags () else default_no_delta_unify_flags () in
   (* The actual type of the theorem. It will be matched against the
   goal. If this fails, then the head constant will be unfolded step by
   step. *)
-  let concl_nprod = nb_prod (pf_concl gl0) in
-  let rec try_main_apply with_destruct c gl =
-    let thm_ty0 = nf_betaiota (project gl) (pf_type_of gl c) in
+  let concl_nprod = nb_prod concl in
+  let rec try_main_apply with_destruct c =
+    Proofview.Goal.enter begin fun gl ->
+    let env = Proofview.Goal.env gl in
+    let sigma = Proofview.Goal.sigma gl in
+
+    let thm_ty0 = nf_betaiota sigma (Retyping.get_type_of env sigma c) in
     let try_apply thm_ty nprod =
-      let n = nb_prod thm_ty - nprod in
-	if n<0 then error "Applied theorem has not enough premisses.";
-	let clause = make_clenv_binding_apply gl (Some n) (c,thm_ty) lbind in
-	Clenvtac.res_pf clause ~with_evars:with_evars ~flags:flags gl
+      try
+        let n = nb_prod thm_ty - nprod in
+        if n<0 then error "Applied theorem has not enough premisses.";
+        let clause = make_clenv_binding_apply env sigma (Some n) (c,thm_ty) lbind in
+        Clenvtac.res_pf clause ~with_evars ~flags
+      with UserError _ as exn ->
+        Proofview.tclZERO exn
     in
-      try try_apply thm_ty0 concl_nprod
-      with PretypeError _|RefinerError _|UserError _|Failure _ as exn ->
+    Proofview.tclORELSE
+      (try_apply thm_ty0 concl_nprod)
+      (function (e, info) -> match e with
+        | PretypeError _|RefinerError _|UserError _|Failure _ as exn0 ->
 	let rec try_red_apply thm_ty =
-	  try
+          try 
             (* Try to head-reduce the conclusion of the theorem *)
-            let red_thm = try_red_product (pf_env gl) (project gl) thm_ty in
-              try try_apply red_thm concl_nprod
-              with PretypeError _|RefinerError _|UserError _|Failure _ ->
+            let red_thm = try_red_product env sigma thm_ty in
+            Proofview.tclORELSE
+              (try_apply red_thm concl_nprod)
+              (function (e, info) -> match e with
+              | PretypeError _|RefinerError _|UserError _|Failure _ ->
 		try_red_apply red_thm
-	  with Redelimination ->
+              | exn -> iraise (exn, info))
+          with Redelimination ->
             (* Last chance: if the head is a variable, apply may try
 	       second order unification *)
-	    try if concl_nprod <> 0 then try_apply thm_ty 0 else raise Exit
-	    with PretypeError _|RefinerError _|UserError _|Failure _|Exit ->
+            let tac =
 	      if with_destruct then
-                descend_in_conjunctions
-                  try_main_apply (fun _ -> Loc.raise loc exn) c gl
+                descend_in_conjunctions []
+                  (fun b id ->
+                    Tacticals.New.tclTHEN
+                      (try_main_apply b (mkVar id))
+                      (Proofview.V82.tactic (thin [id])))
+                  (fun _ ->
+                    let info = Loc.add_loc info loc in
+                    Proofview.tclZERO ~info exn0) c
 	      else
-		Loc.raise loc exn
+                let info = Loc.add_loc info loc in
+		Proofview.tclZERO ~info exn0 in
+            if not (Int.equal concl_nprod 0) then
+              try
+                Proofview.tclORELSE
+                  (try_apply thm_ty 0)
+                  (function (e, info) -> match e with
+                  | PretypeError _|RefinerError _|UserError _|Failure _->
+                    tac
+                  | exn -> iraise (exn, info))
+              with UserError _ | Exit ->
+                tac
+            else
+              tac
 	in try_red_apply thm_ty0
+      | exn -> iraise (exn, info))
+    end
   in
-  try_main_apply with_destruct c gl0
+    Tacticals.New.tclTHENLIST [
+      try_main_apply with_destruct c;
+      solve_remaining_apply_goals;
+      apply_clear_request clear_flag (use_clear_hyp_by_default ()) c
+    ]
+  end
 
 let rec apply_with_bindings_gen b e = function
-  | [] -> tclIDTAC
-  | [cb] -> general_apply b b e cb
-  | cb::cbl ->
-      tclTHENLAST (general_apply b b e cb) (apply_with_bindings_gen b e cbl)
+  | [] -> Proofview.tclUNIT ()
+  | [k,cb] -> general_apply b b e k cb
+  | (k,cb)::cbl ->
+      Tacticals.New.tclTHENLAST
+        (general_apply b b e k cb)
+        (apply_with_bindings_gen b e cbl)
+
+let apply_with_delayed_bindings_gen b e l = 
+  let one k (loc, f) =
+    Proofview.Goal.enter begin fun gl ->
+      let sigma = Proofview.Goal.sigma gl in
+      let env = Proofview.Goal.env gl in
+      let sigma, cb = f env sigma in
+	Tacticals.New.tclWITHHOLES e
+          (general_apply b b e k) sigma (loc,cb)
+    end
+  in
+  let rec aux = function
+    | [] -> Proofview.tclUNIT ()
+    | [k,f] -> one k f
+    | (k,f)::cbl ->
+      Tacticals.New.tclTHENLAST
+        (one k f) (aux cbl)
+  in aux l
 
-let apply_with_bindings cb = apply_with_bindings_gen false false [dloc,cb]
+let apply_with_bindings cb = apply_with_bindings_gen false false [None,(dloc,cb)]
 
-let eapply_with_bindings cb = apply_with_bindings_gen false true [dloc,cb]
+let eapply_with_bindings cb = apply_with_bindings_gen false true [None,(dloc,cb)]
 
-let apply c = apply_with_bindings_gen false false [dloc,(c,NoBindings)]
+let apply c = apply_with_bindings_gen false false [None,(dloc,(c,NoBindings))]
 
-let eapply c = apply_with_bindings_gen false true [dloc,(c,NoBindings)]
+let eapply c = apply_with_bindings_gen false true [None,(dloc,(c,NoBindings))]
 
 let apply_list = function
   | c::l -> apply_with_bindings (c,ImplicitBindings l)
@@ -1001,41 +1554,76 @@ let apply_list = function
 let find_matching_clause unifier clause =
   let rec find clause =
     try unifier clause
-    with exn when catchable_exception exn ->
+    with e when catchable_exception e ->
     try find (clenv_push_prod clause)
     with NotExtensibleClause -> failwith "Cannot apply"
   in find clause
 
 let progress_with_clause flags innerclause clause =
   let ordered_metas = List.rev (clenv_independent clause) in
-  if ordered_metas = [] then error "Statement without assumptions.";
+  if List.is_empty ordered_metas then error "Statement without assumptions.";
   let f mv =
-    find_matching_clause (clenv_fchain mv ~flags clause) innerclause in
-  try list_try_find f ordered_metas
-  with Failure _ -> error "Unable to unify."
+    try Some (find_matching_clause (clenv_fchain mv ~flags clause) innerclause)
+    with Failure _ -> None
+  in
+  try List.find_map f ordered_metas
+  with Not_found -> error "Unable to unify."
 
-let apply_in_once_main flags innerclause (d,lbind) gl =
-  let thm = nf_betaiota gl.sigma (pf_type_of gl d) in
+let apply_in_once_main flags innerclause env sigma (d,lbind) =
+  let thm = nf_betaiota sigma (Retyping.get_type_of env sigma d) in
   let rec aux clause =
     try progress_with_clause flags innerclause clause
-    with err when Errors.noncritical err ->
+    with e when Errors.noncritical e ->
+    let e = Errors.push e in
     try aux (clenv_push_prod clause)
-    with NotExtensibleClause -> raise err in
-  aux (make_clenv_binding gl (d,thm) lbind)
-
-let apply_in_once sidecond_first with_delta with_destruct with_evars id
-  (loc,(d,lbind)) gl0 =
-  let flags = if with_delta then 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 =
+    with NotExtensibleClause -> iraise e
+  in
+  aux (make_clenv_binding env sigma (d,thm) lbind)
+
+let apply_in_once sidecond_first with_delta with_destruct with_evars naming
+    id (clear_flag,(loc,(d,lbind))) tac =
+  Proofview.Goal.nf_enter begin fun gl ->
+  let env = Proofview.Goal.env gl in
+  let sigma = Proofview.Goal.sigma gl in
+  let flags =
+    if with_delta then default_unify_flags () else default_no_delta_unify_flags () in
+  let t' = Tacmach.New.pf_get_hyp_typ id gl in
+  let innerclause = mk_clenv_from_env env sigma (Some 0) (mkVar id,t') in
+  let targetid = find_name true (Anonymous,None,t') naming gl in
+  let rec aux idstoclear with_destruct c =
+    Proofview.Goal.enter begin fun gl ->
+    let env = Proofview.Goal.env gl in
+    let sigma = Proofview.Goal.sigma gl in
     try
-      let clause = apply_in_once_main flags innerclause (c,lbind) gl in
-      clenv_refine_in ~sidecond_first with_evars id clause gl
-    with exn when with_destruct ->
-      descend_in_conjunctions aux (fun _ -> raise exn) c gl
+      let clause = apply_in_once_main flags innerclause env sigma (c,lbind) in
+      clenv_refine_in ~sidecond_first with_evars targetid id sigma clause
+        (fun id ->
+          Tacticals.New.tclTHENLIST [
+            apply_clear_request clear_flag false c;
+            Proofview.V82.tactic (thin idstoclear);
+            tac id
+          ])
+    with e when with_destruct && Errors.noncritical e ->
+      let e = Errors.push e in
+        (descend_in_conjunctions [targetid]
+           (fun b id -> aux (id::idstoclear) b (mkVar id))
+           (fun _ -> iraise e) c)
+    end
   in
-  aux with_destruct d gl0
+  aux [] with_destruct d
+  end
+
+let apply_in_delayed_once sidecond_first with_delta with_destruct with_evars naming
+    id (clear_flag,(loc,f)) tac =
+  Proofview.Goal.enter begin fun gl ->
+    let env = Proofview.Goal.env gl in
+    let sigma = Proofview.Goal.sigma gl in
+    let sigma, c = f env sigma in
+    Tacticals.New.tclWITHHOLES with_evars 
+      (apply_in_once sidecond_first with_delta with_destruct with_evars
+         naming id (clear_flag,(loc,c)))
+      sigma tac
+  end
 
 (* A useful resolution tactic which, if c:A->B, transforms |- C into
    |- B -> C and |- A
@@ -1054,26 +1642,45 @@ let apply_in_once sidecond_first with_delta with_destruct with_evars id
   end.
 *)
 
-let cut_and_apply c gl =
-  let goal_constr = pf_concl gl in
-    match kind_of_term (pf_hnf_constr gl (pf_type_of gl c)) with
+let cut_and_apply c =
+  Proofview.Goal.nf_enter begin fun gl ->
+    match kind_of_term (Tacmach.New.pf_hnf_constr gl (Tacmach.New.pf_type_of gl c)) with
       | Prod (_,c1,c2) when not (dependent (mkRel 1) c2) ->
-	  tclTHENLAST
-	    (apply_type (mkProd (Anonymous,c2,goal_constr)) [mkMeta(new_meta())])
-	    (apply_term c [mkMeta (new_meta())]) gl
+        let concl = Proofview.Goal.concl gl in
+        let env = Tacmach.New.pf_env gl in
+        Proofview.Refine.refine begin fun sigma ->
+          let typ = mkProd (Anonymous, c2, concl) in
+          let (sigma, f) = Evarutil.new_evar env sigma typ in
+          let (sigma, x) = Evarutil.new_evar env sigma c1 in
+          let ans = mkApp (f, [|mkApp (c, [|x|])|]) in
+          (sigma, ans)
+        end
       | _ -> error "lapply needs a non-dependent product."
+  end
 
 (********************************************************************)
 (*               Exact tactics                                      *)
 (********************************************************************)
 
-let exact_check c gl =
-  let concl = (pf_concl gl) in
-  let ct = pf_type_of gl c in
-  if pf_conv_x_leq gl ct concl then
-    refine_no_check c gl
-  else
-    error "Not an exact proof."
+(* let convert_leqkey = Profile.declare_profile "convert_leq";; *)
+(* let convert_leq = Profile.profile3 convert_leqkey convert_leq *)
+
+(* let refine_no_checkkey = Profile.declare_profile "refine_no_check";; *)
+(* let refine_no_check = Profile.profile2 refine_no_checkkey refine_no_check *)
+
+let new_exact_no_check c =
+  Proofview.Refine.refine ~unsafe:true (fun h -> (h, c))
+
+let exact_check c =
+  Proofview.Goal.enter begin fun gl ->
+  (** We do not need to normalize the goal because we just check convertibility *)
+  let concl = Proofview.Goal.concl (Proofview.Goal.assume gl) in
+  let env = Proofview.Goal.env gl in
+  let sigma = Proofview.Goal.sigma gl in
+  let sigma, ct = Typing.e_type_of env sigma c in
+    Proofview.Unsafe.tclEVARS sigma <*>
+      Tacticals.New.tclTHEN (convert_leq ct concl) (new_exact_no_check c)
+  end
 
 let exact_no_check = refine_no_check
 
@@ -1083,23 +1690,35 @@ let vm_cast_no_check c gl =
 
 
 let exact_proof c gl =
-  (* on experimente la synthese d'ise dans exact *)
-  let c = Constrintern.interp_casted_constr (project gl) (pf_env gl) c (pf_concl gl)
-  in refine_no_check c gl
-
-let (assumption : tactic) = fun gl ->
-  let concl =  pf_concl gl in
-  let hyps = pf_hyps gl in
-  let rec arec only_eq = function
-    | [] ->
-        if only_eq then arec false hyps else error "No such assumption."
-    | (id,c,t)::rest ->
-	if (only_eq & eq_constr t concl)
-          or (not only_eq & pf_conv_x_leq gl t concl)
-        then refine_no_check (mkVar id) gl
-	else arec only_eq rest
+  let c,ctx = Constrintern.interp_casted_constr (pf_env gl) (project gl) c (pf_concl gl)
+  in tclTHEN (tclEVARUNIVCONTEXT ctx) (refine_no_check c) gl
+
+let assumption =
+  let rec arec gl only_eq = function
+  | [] ->
+    if only_eq then
+      let hyps = Proofview.Goal.hyps gl in
+      arec gl false hyps
+    else Tacticals.New.tclZEROMSG (str "No such assumption.")
+  | (id, c, t)::rest ->
+    let concl = Proofview.Goal.concl gl in
+    let sigma = Proofview.Goal.sigma gl in
+    let (sigma, is_same_type) =
+      if only_eq then (sigma, Constr.equal t concl)
+      else
+        let env = Proofview.Goal.env gl in
+        infer_conv env sigma t concl
+    in
+    if is_same_type then
+      (Proofview.Unsafe.tclEVARS sigma) <*>
+	Proofview.Refine.refine ~unsafe:true (fun h -> (h, mkVar id))
+    else arec gl only_eq rest
+  in
+  let assumption_tac gl =
+    let hyps = Proofview.Goal.hyps gl in
+    arec gl true hyps
   in
-  arec true hyps
+  Proofview.Goal.nf_enter assumption_tac
 
 (*****************************************************************)
 (*          Modification of a local context                      *)
@@ -1111,52 +1730,111 @@ let (assumption : tactic) = fun gl ->
  * goal. *)
 
 let clear ids = (* avant seul dyn_clear n'echouait pas en [] *)
-  if ids=[] then tclIDTAC else thin ids
+  if List.is_empty ids then tclIDTAC else thin ids
+
+let on_the_bodies = function
+| [] -> assert false
+| [id] -> str " depends on the body of " ++ pr_id id
+| l -> str " depends on the bodies of " ++ pr_sequence pr_id l
+
+let check_is_type env ty msg =
+  Proofview.tclEVARMAP >>= fun sigma ->
+  let evdref = ref sigma in
+  try
+    let _ = Typing.sort_of env evdref ty in
+    Proofview.Unsafe.tclEVARS !evdref
+  with e when Errors.noncritical e ->
+    msg e
 
-let clear_body = thin_body
+let check_decl env (_, c, ty) msg =
+  Proofview.tclEVARMAP >>= fun sigma ->
+  let evdref = ref sigma in
+  try
+    let _ = Typing.sort_of env evdref ty in
+    let _ = match c with
+    | None -> ()
+    | Some c -> Typing.check env evdref c ty
+    in
+    Proofview.Unsafe.tclEVARS !evdref
+  with e when Errors.noncritical e ->
+    msg e
+
+let clear_body ids =
+  Proofview.Goal.enter begin fun gl ->
+    let env = Proofview.Goal.env gl in
+    let concl = Proofview.Goal.concl (Proofview.Goal.assume gl) in
+    let ctx = named_context env in
+    let map (id, body, t as decl) = match body with
+    | None ->
+      let () = if List.mem_f Id.equal id ids then
+        errorlabstrm "" (str "Hypothesis " ++ pr_id id ++ str " is not a local definition")
+      in
+      decl
+    | Some _ ->
+      if List.mem_f Id.equal id ids then (id, None, t) else decl
+    in
+    let ctx = List.map map ctx in
+    let base_env = reset_context env in
+    let env = push_named_context ctx base_env in
+    let check_hyps =
+      let check env (id, _, _ as decl) =
+        let msg _ = Tacticals.New.tclZEROMSG
+          (str "Hypothesis " ++ pr_id id ++ on_the_bodies ids)
+        in
+        check_decl env decl msg <*> Proofview.tclUNIT (push_named decl env)
+      in
+      let checks = Proofview.Monad.List.fold_left check base_env (List.rev ctx) in
+      Proofview.tclIGNORE checks
+    in
+    let check_concl =
+      let msg _ = Tacticals.New.tclZEROMSG
+        (str "Conclusion" ++ on_the_bodies ids)
+      in
+      check_is_type env concl msg
+    in
+    check_hyps <*> check_concl <*>
+    Proofview.Refine.refine ~unsafe:true begin fun sigma ->
+      Evarutil.new_evar env sigma concl
+    end
+  end
 
 let clear_wildcards ids =
-  tclMAP (fun (loc,id) gl ->
+  Proofview.V82.tactic (tclMAP (fun (loc,id) gl ->
     try with_check (Tacmach.thin_no_check [id]) gl
     with ClearDependencyError (id,err) ->
       (* Intercept standard [thin] error message *)
       Loc.raise loc
-        (error_clear_dependency (pf_env gl) (id_of_string "_") err))
-    ids
+        (error_clear_dependency (pf_env gl) (project gl) (Id.of_string "_") err))
+    ids)
 
 (*   Takes a list of booleans, and introduces all the variables
  *  quantified in the goal which are associated with a value
  *  true  in the boolean list. *)
 
 let rec intros_clearing = function
-  | []          -> tclIDTAC
-  | (false::tl) -> tclTHEN intro (intros_clearing tl)
+  | []          -> Proofview.tclUNIT ()
+  | (false::tl) -> Tacticals.New.tclTHEN intro (intros_clearing tl)
   | (true::tl)  ->
-      tclTHENLIST
-        [ intro; onLastHypId (fun id -> clear [id]); intros_clearing tl]
+      Tacticals.New.tclTHENLIST
+        [ intro; Tacticals.New.onLastHypId (fun id -> Proofview.V82.tactic (clear [id])); intros_clearing tl]
 
 (* Modifying/Adding an hypothesis  *)
 
-let specialize mopt (c,lbind) g =
+let specialize (c,lbind) g =
   let tac, term =
-    if lbind = NoBindings then 
+    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 flags = { default_unify_flags with resolve_evars = true } in
+      let clause = pf_apply make_clenv_binding g (c,pf_type_of g c) lbind in
+      let flags = { (default_unify_flags ()) with resolve_evars = true } in
       let 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
-	| Some m ->
-	    if m < nargs then list_firstn m tstack else tstack
-	| None ->
-	    let rec chk = function
-	      | [] -> []
-	      | t::l -> if occur_meta t then [] else t :: chk l
-	    in chk tstack
+      let (thd,tstack) = whd_nored_stack clause.evd (clenv_value clause) in
+      let rec chk = function
+      | [] -> []
+      | t::l -> if occur_meta t then [] else t :: chk l
       in
+      let tstack = chk tstack in
       let term = applist(thd,List.map (nf_evar clause.evd) tstack) in
       if occur_meta term then
 	errorlabstrm "" (str "Cannot infer an instance for " ++
@@ -1165,55 +1843,69 @@ let specialize mopt (c,lbind) g =
        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) ->
+       | Var id when Id.List.mem id (pf_ids_of_hyps g) ->
 	   tclTHEN tac
 	     (tclTHENFIRST
-	       (fun g -> internal_cut_replace id (pf_type_of g term) g)
+	       (fun g -> Proofview.V82.of_tactic (assert_before_replacing id (pf_type_of g term)) g)
 	       (exact_no_check term)) g
        | _ -> tclTHEN tac
 	   (tclTHENLAST
-              (fun g -> cut (pf_type_of g term) g)
+              (fun g -> Proofview.V82.of_tactic (cut (pf_type_of g term)) g)
               (exact_no_check term)) g
 
 (* Keeping only a few hypotheses *)
 
-let keep hyps gl =
-  let env = Global.env() in
-  let ccl = pf_concl gl in
+let keep hyps =
+  Proofview.Goal.nf_enter begin fun gl ->
+  Proofview.tclENV >>= fun env ->
+  let ccl = Proofview.Goal.concl gl in
   let cl,_ =
     fold_named_context_reverse (fun (clear,keep) (hyp,_,_ as decl) ->
-      if List.mem hyp hyps
-	or List.exists (occur_var_in_decl env hyp) keep
-	or occur_var env hyp ccl
+      if Id.List.mem hyp hyps
+        || List.exists (occur_var_in_decl env hyp) keep
+	|| occur_var env hyp ccl
       then (clear,decl::keep)
       else (hyp::clear,keep))
-      ~init:([],[]) (pf_env gl)
-  in thin cl gl
+      ~init:([],[]) (Proofview.Goal.env gl)
+  in
+  Proofview.V82.tactic (fun gl -> thin cl gl)
+  end
 
 (************************)
 (* Introduction tactics *)
 (************************)
 
 let check_number_of_constructors expctdnumopt i nconstr =
-  if i=0 then error "The constructors are numbered starting from 1.";
+  if Int.equal i 0 then error "The constructors are numbered starting from 1.";
   begin match expctdnumopt with
-    | Some n when n <> nconstr ->
+    | Some n when not (Int.equal n nconstr) ->
 	error ("Not an inductive goal with "^
-	       string_of_int n^plural n " constructor"^".")
+	       string_of_int n ^ String.plural n " constructor"^".")
     | _ -> ()
   end;
   if i > nconstr then error "Not enough constructors."
 
-let constructor_tac with_evars expctdnumopt i lbind gl =
-  let cl = pf_concl gl in
-  let (mind,redcl) = pf_reduce_to_quantified_ind gl cl in
-  let nconstr =
-    Array.length (snd (Global.lookup_inductive mind)).mind_consnames in
-  check_number_of_constructors expctdnumopt i nconstr;
-  let cons = mkConstruct (ith_constructor_of_inductive mind i) in
-  let apply_tac = general_apply true false with_evars (dloc,(cons,lbind)) in
-  (tclTHENLIST
-     [convert_concl_no_check redcl DEFAULTcast; intros; apply_tac]) gl
+let constructor_tac with_evars expctdnumopt i lbind =
+  Proofview.Goal.enter begin fun gl ->
+    let cl = Tacmach.New.pf_nf_concl gl in
+    let reduce_to_quantified_ind =
+      Tacmach.New.pf_apply Tacred.reduce_to_quantified_ind gl
+    in
+    let (mind,redcl) = reduce_to_quantified_ind cl in
+    let nconstr =
+      Array.length (snd (Global.lookup_inductive (fst mind))).mind_consnames in
+      check_number_of_constructors expctdnumopt i nconstr;
+
+      let sigma, cons = Evd.fresh_constructor_instance
+	(Proofview.Goal.env gl) (Proofview.Goal.sigma gl) (fst mind, i) in
+      let cons = mkConstructU cons in
+	
+      let apply_tac = general_apply true false with_evars None (dloc,(cons,lbind)) in
+	(Tacticals.New.tclTHENLIST
+           [Proofview.Unsafe.tclEVARS sigma; 
+	    convert_concl_no_check redcl DEFAULTcast;
+	    intros; apply_tac])
+  end
 
 let one_constructor i lbind = constructor_tac false None i lbind
 
@@ -1222,21 +1914,30 @@ let one_constructor i lbind = constructor_tac false None i lbind
    Should be generalize in Constructor (Fun c : I -> tactic)
  *)
 
-let any_constructor with_evars tacopt gl =
-  let t = match tacopt with None -> tclIDTAC | Some t -> t in
-  let mind = fst (pf_reduce_to_quantified_ind gl (pf_concl gl)) in
-  let nconstr =
-    Array.length (snd (Global.lookup_inductive mind)).mind_consnames in
-  if nconstr = 0 then error "The type has no constructors.";
-  tclFIRST
-    (List.map
-      (fun i -> tclTHEN (constructor_tac with_evars None i NoBindings) t)
-      (interval 1 nconstr)) gl
+let rec tclANY tac = function
+| [] -> Tacticals.New.tclZEROMSG (str "No applicable tactic.")
+| arg :: l ->
+  Tacticals.New.tclORD (tac arg) (fun () -> tclANY tac l)
+
+let any_constructor with_evars tacopt =
+  let t = match tacopt with None -> Proofview.tclUNIT () | Some t -> t in
+  let tac i = Tacticals.New.tclTHEN (constructor_tac with_evars None i NoBindings) t in
+  Proofview.Goal.enter begin fun gl ->
+    let cl = Tacmach.New.pf_nf_concl gl in
+    let reduce_to_quantified_ind =
+      Tacmach.New.pf_apply Tacred.reduce_to_quantified_ind gl
+    in
+    let mind = fst (reduce_to_quantified_ind cl) in
+    let nconstr =
+      Array.length (snd (Global.lookup_inductive (fst mind))).mind_consnames in
+    if Int.equal nconstr 0 then error "The type has no constructors.";
+    tclANY tac (List.interval 1 nconstr)
+ end
 
 let left_with_bindings  with_evars = constructor_tac with_evars (Some 2) 1
 let right_with_bindings with_evars = constructor_tac with_evars (Some 2) 2
 let split_with_bindings with_evars l =
-  tclMAP (constructor_tac with_evars (Some 1) 1) l
+  Tacticals.New.tclMAP (constructor_tac with_evars (Some 1) 1) l
 
 let left           = left_with_bindings false
 let simplest_left  = left NoBindings
@@ -1252,246 +1953,484 @@ let simplest_split = split NoBindings
 (*****************************)
 
 (* Rewriting function for rewriting one hypothesis at the time *)
-let forward_general_multi_rewrite =
-  ref (fun _ -> failwith "general_multi_rewrite undefined")
+let (forward_general_rewrite_clause, general_rewrite_clause) = Hook.make ()
 
 (* 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 (forward_subst_one, subst_one) = Hook.make ()
 
-let error_unexpected_extra_pattern loc nb pat =
+let error_unexpected_extra_pattern loc bound pat =
+  let _,nb = Option.get bound in
   let s1,s2,s3 = match pat with
-  | IntroIdentifier _ -> "name", (plural nb " introduction pattern"), "no"
+  | IntroNaming (IntroIdentifier _) ->
+      "name", (String.plural nb " introduction pattern"), "no"
   | _ -> "introduction pattern", "", "none" in
   user_err_loc (loc,"",str "Unexpected " ++ str s1 ++ str " (" ++
-    (if nb = 0 then (str s3 ++ str s2) else
+    (if Int.equal nb 0 then (str s3 ++ str s2) else
       (str "at most " ++ int nb ++ str s2)) ++ spc () ++
-       str (if nb = 1 then "was" else "were") ++
+       str (if Int.equal nb 1 then "was" else "were") ++
       strbrk " expected in the branch).")
 
-let intro_or_and_pattern loc b ll l' tac id gl =
-    let c = mkVar id in
-    let ind,_ = pf_reduce_to_quantified_ind gl (pf_type_of gl c) in
-    let nv = mis_constr_nargs ind in
-    let bracketed = b or not (l'=[]) in
-    let rec adjust_names_length nb n = function
-      | [] when n = 0 or not bracketed -> []
-      | [] -> (dloc,IntroAnonymous) :: adjust_names_length nb (n-1) []
-      | (loc',pat) :: _ as l when n = 0 ->
-	  if bracketed then error_unexpected_extra_pattern loc' nb pat;
-	  l
-      | ip :: l -> ip :: adjust_names_length nb (n-1) l in
-    let ll = fix_empty_or_and_pattern (Array.length nv) ll in
-    check_or_and_pattern_size loc ll (Array.length nv);
-    tclTHENLASTn
-      (tclTHEN (simplest_case c) (clear [id]))
-      (array_map2 (fun n l -> tac ((adjust_names_length n n l)@l'))
-	nv (Array.of_list ll))
-      gl
-
-let rewrite_hyp l2r id gl =
+let intro_decomp_eq_function = ref (fun _ -> failwith "Not implemented")
+
+let declare_intro_decomp_eq f = intro_decomp_eq_function := f
+
+let my_find_eq_data_decompose gl t =
+  try find_eq_data_decompose gl t
+  with e when is_anomaly e
+    (* Hack in case equality is not yet defined... one day, maybe,
+       known equalities will be dynamically registered *)
+      -> raise Constr_matching.PatternMatchingFailure
+
+let intro_decomp_eq loc l thin tac id =
+  Proofview.Goal.nf_enter begin fun gl ->
+  let c = mkVar id in
+  let t = Tacmach.New.pf_type_of gl c in
+  let _,t = Tacmach.New.pf_reduce_to_quantified_ind gl t in
+  let eq,u,eq_args = my_find_eq_data_decompose gl t in
+  !intro_decomp_eq_function
+    (fun n -> tac ((dloc,id)::thin) (Some (true,n)) l)
+    (eq,t,eq_args) (c, t)
+  end
+
+let intro_or_and_pattern loc bracketed ll thin tac id =
+  Proofview.Goal.enter begin fun gl ->
+  let c = mkVar id in
+  let t = Tacmach.New.pf_type_of gl c in
+  let ((ind,u),t) = Tacmach.New.pf_reduce_to_quantified_ind gl t in
+  let nv = constructors_nrealargs ind in
+  let ll = fix_empty_or_and_pattern (Array.length nv) ll in
+  check_or_and_pattern_size loc ll (Array.length nv);
+  Tacticals.New.tclTHENLASTn
+    (Tacticals.New.tclTHEN (simplest_case c) (Proofview.V82.tactic (clear [id])))
+    (Array.map2 (fun n l -> tac thin (Some (bracketed,n)) l)
+       nv (Array.of_list ll))
+  end
+
+let rewrite_hyp assert_style l2r id =
   let rew_on l2r =
-    !forward_general_multi_rewrite l2r false (mkVar id,NoBindings) in
+    Hook.get forward_general_rewrite_clause 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
-  (* TODO: detect setoid equality? better detect the different equalities *)
-  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
-	subst_on l2r (destVar lhs) rhs gl
-      else if not l2r & isVar rhs & not (occur_var (pf_env gl) (destVar rhs) lhs) then
-	subst_on l2r (destVar rhs) lhs gl
-      else
-	tclTHEN (rew_on l2r onConcl) (tclTRY (clear [id])) gl
-  | Some (hdcncl,[c]) ->
-      let l2r = not l2r in (* equality of the form eq_true *)
-      if isVar c then
-	tclTHEN (rew_on l2r allHypsAndConcl) (clear_var_and_eq c) gl
-      else
-	tclTHEN (rew_on l2r onConcl) (tclTRY (clear [id])) gl
-  | _ ->
-      error "Cannot find a known equation."
+    Hook.get forward_subst_one true x (id,rhs,l2r) in
+  let clear_var_and_eq c = tclTHEN (clear [id]) (clear [destVar c]) in
+  Proofview.Goal.enter begin fun gl ->
+    let env = Proofview.Goal.env gl in
+    let type_of = Tacmach.New.pf_type_of gl in
+    let whd_betadeltaiota = Tacmach.New.pf_apply whd_betadeltaiota gl in
+    let t = whd_betadeltaiota (type_of (mkVar id)) in
+    match match_with_equality_type t with
+    | Some (hdcncl,[_;lhs;rhs]) ->
+        if l2r && isVar lhs && not (occur_var env (destVar lhs) rhs) then
+          subst_on l2r (destVar lhs) rhs
+        else if not l2r && isVar rhs && not (occur_var env (destVar rhs) lhs) then
+          subst_on l2r (destVar rhs) lhs
+        else
+          Tacticals.New.tclTHEN (rew_on l2r onConcl) (Proofview.V82.tactic (clear [id]))
+    | Some (hdcncl,[c]) ->
+        let l2r = not l2r in (* equality of the form eq_true *)
+        if isVar c then
+          Tacticals.New.tclTHEN (rew_on l2r allHypsAndConcl) 
+	    (Proofview.V82.tactic (clear_var_and_eq c))
+        else
+          Tacticals.New.tclTHEN (rew_on l2r onConcl) (Proofview.V82.tactic (clear [id]))
+    | _ ->
+        Tacticals.New.tclTHEN (rew_on l2r onConcl) (Proofview.V82.tactic (clear [id]))
+  end
+
+let rec prepare_naming loc = function
+  | IntroIdentifier id -> NamingMustBe (loc,id)
+  | IntroAnonymous -> NamingAvoid []
+  | IntroFresh id -> NamingBasedOn (id,[])
 
 let rec explicit_intro_names = function
-| (_, IntroIdentifier id) :: l ->
-    id :: explicit_intro_names l
-| (_, (IntroWildcard | IntroAnonymous | IntroFresh _
-      | IntroRewrite _ | IntroForthcoming _)) :: l -> explicit_intro_names l
-| (_, IntroOrAndPattern ll) :: l' ->
+| (_, IntroForthcoming _) :: l -> explicit_intro_names l
+| (_, IntroNaming (IntroIdentifier id)) :: l -> id :: explicit_intro_names l
+| (_, IntroAction (IntroOrAndPattern ll)) :: l' ->
     List.flatten (List.map (fun l -> explicit_intro_names (l@l')) ll)
-| [] ->
-    []
+| (_, IntroAction (IntroInjection l)) :: l' ->
+    explicit_intro_names (l@l')
+| (_, IntroAction (IntroApplyOn (c,pat))) :: l' ->
+    explicit_intro_names (pat::l')
+| (_, (IntroNaming (IntroAnonymous | IntroFresh _)
+     | IntroAction (IntroWildcard | IntroRewrite _))) :: l ->
+     explicit_intro_names l
+| [] -> []
 
-let wild_id = id_of_string "_tmp"
+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
+  | (x,id')::l -> Id.equal 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)
+      List.map (on_snd (fun id' -> if Id.equal id id' then newid else id')) thin in
+    Tacticals.New.tclTHEN (rename_hyp [id,newid]) (tac thin)
   else
     tac thin
 
+let make_tmp_naming avoid l = function
+  (* In theory, we could use a tmp id like "wild_id" for all actions
+     but we prefer to avoid it to avoid this kind of "ugly" names *)
+  (* Alternatively, we could have called check_thin_clash_then on
+     IntroAnonymous, but at the cost of a "renaming"; Note that in the
+     case of IntroFresh, we should use check_thin_clash_then anyway to
+     prevent the case of an IntroFresh precisely using the wild_id *)
+  | IntroWildcard -> NamingBasedOn (wild_id,avoid@explicit_intro_names l)
+  | _ -> NamingAvoid(avoid@explicit_intro_names l)
+
+let fit_bound n = function
+  | None -> true
+  | Some (use_bound,n') -> not use_bound || n = n'
+
+let exceed_bound n = function
+  | None -> false
+  | Some (use_bound,n') -> use_bound && n >= n'
+
   (* 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 ids thin destopt tac = function
-  | (loc, IntroWildcard) :: 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 ->
+let rec intro_patterns_core b avoid ids thin destopt bound n tac = function
+  | [] when fit_bound n bound ->
+      tac ids thin
+  | [] ->
+      (* Behave as IntroAnonymous *)
+      intro_patterns_core b avoid ids thin destopt bound n tac
+        [dloc,IntroNaming IntroAnonymous]
+  | (loc,pat) :: l ->
+  if exceed_bound n bound then error_unexpected_extra_pattern loc bound pat else
+  match pat with
+  | IntroForthcoming onlydeps ->
+      intro_forthcoming_then_gen (NamingAvoid (avoid@explicit_intro_names l))
+	  destopt onlydeps n bound
+        (fun ids -> intro_patterns_core b avoid ids thin destopt bound
+          (n+List.length ids) tac l)
+  | IntroAction pat ->
+      intro_then_gen (make_tmp_naming avoid l pat)
+	MoveLast true false
+        (intro_pattern_action loc (b || not (List.is_empty l)) false pat thin
+          (fun thin bound' -> intro_patterns_core b avoid ids thin destopt bound' 0
+            (fun ids thin ->
+              intro_patterns_core b avoid ids thin destopt bound (n+1) tac l)))
+  | IntroNaming pat ->
+      intro_pattern_naming loc b avoid ids pat thin destopt bound n tac l
+
+and intro_pattern_naming loc b avoid ids pat thin destopt bound n tac l =
+  match pat with
+  | IntroIdentifier id ->
       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 ->
-      intro_then_gen loc (IntroAvoid (avoid@explicit_intro_names l))
+        intro_then_gen (NamingMustBe (loc,id)) destopt true false
+          (fun id -> intro_patterns_core b avoid (id::ids) thin destopt bound (n+1) tac l))
+  | IntroAnonymous ->
+      intro_then_gen (NamingAvoid (avoid@explicit_intro_names l))
 	destopt true false
-        (fun id -> intros_patterns b avoid (id::ids) thin destopt tac l)
-  | (loc, IntroFresh id) :: l ->
+        (fun id -> intro_patterns_core b avoid (id::ids) thin destopt bound (n+1) tac l)
+  | IntroFresh id ->
       (* todo: avoid thinned names to interfere with generation of fresh name *)
-      intro_then_gen loc (IntroBasedOn (id, avoid@explicit_intro_names l))
+      intro_then_gen (NamingBasedOn (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 ->
-      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' ->
-      intro_then_force
-	(intro_or_and_pattern loc b ll l'
-	   (intros_patterns b avoid ids thin destopt tac))
-  | (loc, IntroRewrite l2r) :: l ->
-      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 ids thin destopt tac l))
-  | [] -> tac ids thin
+        (fun id -> intro_patterns_core b avoid (id::ids) thin destopt bound (n+1) tac l)
+
+and intro_pattern_action loc b style pat thin tac id = match pat with
+  | IntroWildcard ->
+      tac ((loc,id)::thin) None []
+  | IntroOrAndPattern ll ->
+      intro_or_and_pattern loc b ll thin tac id
+  | IntroInjection l' ->
+      intro_decomp_eq loc l' thin tac id
+  | IntroRewrite l2r ->
+      Tacticals.New.tclTHENLAST
+        (* Skip the side conditions of the rewriting step *)
+	(rewrite_hyp style l2r id)
+        (tac thin None [])
+  | IntroApplyOn (f,(loc,pat)) ->
+      let naming,tac_ipat = prepare_intros_loc loc (IntroIdentifier id) pat in
+      Proofview.Goal.enter begin fun gl ->
+        let sigma = Proofview.Goal.sigma gl in
+        let env = Proofview.Goal.env gl in
+        let sigma,c = f env sigma in
+        Proofview.Unsafe.tclEVARS sigma <*>
+          (Tacticals.New.tclTHENFIRST
+             (* Skip the side conditions of the apply *)
+             (apply_in_once false true true true naming id
+                (None,(sigma,(c,NoBindings))) tac_ipat))
+	  (tac thin None [])
+      end
+
+and prepare_intros_loc loc dft = function
+  | IntroNaming ipat ->
+      prepare_naming loc ipat,
+      (fun _ -> Proofview.tclUNIT ())
+  | IntroAction ipat ->
+      prepare_naming loc dft,
+      (let tac thin bound =
+        intro_patterns_core true [] [] thin MoveLast bound 0
+          (fun _ l -> clear_wildcards l) in
+      fun id -> intro_pattern_action loc true true ipat [] tac id)
+  | IntroForthcoming _ -> user_err_loc
+      (loc,"",str "Introduction pattern for one hypothesis expected.")
+
+let intro_patterns_bound_to n destopt =
+  intro_patterns_core true [] [] [] destopt
+    (Some (true,n)) 0 (fun _ -> clear_wildcards)
+
+(* The following boolean governs what "intros []" do on examples such
+   as "forall x:nat*nat, x=x"; if true, it behaves as "intros [? ?]";
+   if false, it behaves as "intro H; case H; clear H" for fresh H.
+   Kept as false for compatibility.
+ *)
+let bracketing_last_or_and_intro_pattern = false 
+
+let intro_patterns_to destopt =
+  intro_patterns_core bracketing_last_or_and_intro_pattern
+    [] [] [] destopt None 0 (fun _ l -> clear_wildcards l)
 
-let intros_pattern destopt =
-  intros_patterns false [] [] [] destopt (fun _ -> clear_wildcards)
+let intro_pattern_to destopt pat =
+  intro_patterns_to destopt [dloc,pat]
 
-let intro_pattern destopt pat =
-  intros_pattern destopt [dloc,pat]
+let intro_patterns = intro_patterns_to MoveLast
 
-let intro_patterns = function
-  | [] -> tclREPEAT intro
-  | l  -> intros_pattern no_move l
+(* Implements "intros" *)
+let intros_patterns = function
+  | [] -> intros
+  | l -> intro_patterns_to MoveLast l
 
 (**************************)
-(*   Other cut tactics    *)
+(*   Forward reasoning    *)
 (**************************)
 
-let make_id s = fresh_id [] (default_id_of_sort s)
-
-let prepare_intros s ipat gl = match ipat with
-  | None -> make_id s gl, tclIDTAC
-  | Some (loc,ipat) -> match ipat with
-  | IntroIdentifier id -> id, tclIDTAC
-  | IntroAnonymous -> make_id s gl, tclIDTAC
-  | IntroFresh id -> fresh_id [] id gl, tclIDTAC
-  | IntroWildcard -> let id = make_id s gl in id, clear_wildcards [dloc,id]
-  | IntroRewrite l2r ->
-      let id = make_id s gl in
-      id, !forward_general_multi_rewrite l2r false (mkVar id,NoBindings) allHypsAndConcl
-  | IntroOrAndPattern ll -> make_id s gl,
-      onLastHypId
-	(intro_or_and_pattern loc true ll []
-	  (intros_patterns true [] [] [] no_move (fun _ -> clear_wildcards)))
-  | IntroForthcoming _ -> user_err_loc
-      (loc,"",str "Introduction pattern for one hypothesis expected")
+let prepare_intros dft = function
+  | None -> prepare_naming dloc dft, (fun _id -> Proofview.tclUNIT ())
+  | Some (loc,ipat) -> prepare_intros_loc loc dft ipat
 
 let ipat_of_name = function
   | Anonymous -> None
-  | Name id -> Some (dloc, IntroIdentifier id)
+  | Name id -> Some (dloc, IntroNaming (IntroIdentifier id))
 
-let allow_replace c gl = function (* A rather arbitrary condition... *)
-  | Some (_, IntroIdentifier id) ->
-      let c = fst (decompose_app ((strip_lam_assum c))) in
-      isVar c && destVar c = id
-  | _ ->
-      false
-
-let assert_as first ipat c gl =
-  match kind_of_term (pf_hnf_type_of gl c) with
-  | Sort s ->
-      let id,tac = prepare_intros s ipat gl in
-      let repl = allow_replace c gl ipat in
-      tclTHENS
-	((if first then internal_cut_gen else internal_cut_rev_gen) repl id c)
-	(if first then [tclIDTAC; tac] else [tac; tclIDTAC]) gl
-  | _  -> error "Not a proposition or a type."
+ let head_ident c =
+   let c = fst (decompose_app ((strip_lam_assum c))) in
+   if isVar c then Some (destVar c) else None
 
-let assert_tac na = assert_as true (ipat_of_name na)
+let assert_as first ipat c =
+  let naming,tac = prepare_intros IntroAnonymous ipat in
+  let repl = do_replace (head_ident c) naming in
+  if first then assert_before_then_gen repl naming c tac
+  else assert_after_then_gen repl naming c tac
 
 (* apply in as *)
 
-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 (fun _ -> clear_wildcards))
-        id
-  | Some (loc,
-      (IntroIdentifier _ | IntroAnonymous | IntroFresh _ |
-       IntroWildcard | IntroForthcoming _)) ->
-      user_err_loc (loc,"", str "Disjunctive/conjunctive pattern expected")
-  | None -> tclIDTAC
-
-let tclMAPLAST tacfun l =
-  List.fold_right (fun x -> tclTHENLAST (tacfun x)) l tclIDTAC
-
-let tclMAPFIRST tacfun l =
-  List.fold_right (fun x -> tclTHENFIRST (tacfun x)) l tclIDTAC
-
-let general_apply_in sidecond_first with_delta with_destruct with_evars 
-    id lemmas ipat =
+let general_apply_in sidecond_first with_delta with_destruct with_evars
+    with_clear id lemmas ipat =
+  let tac (naming,lemma) tac id =
+    apply_in_delayed_once sidecond_first with_delta with_destruct with_evars
+      naming id lemma tac in
+  let naming,ipat_tac = prepare_intros (IntroIdentifier id) ipat in
+  let lemmas_target, last_lemma_target =
+    let last,first = List.sep_last lemmas in
+    List.map (fun lem -> (NamingMustBe (dloc,id),lem)) first, (naming,last)
+  in
+  (* We chain apply_in_once, ending with an intro pattern *)
+  List.fold_right tac lemmas_target (tac last_lemma_target ipat_tac) id
+
+(*
   if sidecond_first then
     (* Skip the side conditions of the applied lemma *)
-    tclTHENLAST
-      (tclMAPLAST
-	(apply_in_once sidecond_first with_delta with_destruct with_evars id) 
-	lemmas)
-      (as_tac id ipat)
-  else 
-    tclTHENFIRST
-      (tclMAPFIRST
-	(apply_in_once sidecond_first with_delta with_destruct with_evars id) 
-	lemmas)
-      (as_tac id ipat)
-
-let apply_in simple with_evars id lemmas ipat =
-  general_apply_in false simple simple with_evars id lemmas ipat
-
-let simple_apply_in id c =
-  general_apply_in false false false false id [dloc,(c,NoBindings)] None
+    Tacticals.New.tclTHENLAST (tclMAPLAST tac lemmas_target) (ipat_tac id)
+  else
+    Tacticals.New.tclTHENFIRST (tclMAPFIRST tac lemmas_target) (ipat_tac id)
+*)
 
-(**************************)
-(*   Generalize tactics   *)
-(**************************)
+let apply_in simple with_evars clear_flag id lemmas ipat =
+  let lemmas = List.map (fun (k,(loc,l)) -> k, (loc, fun _ sigma -> sigma, l)) lemmas in
+  general_apply_in false simple simple with_evars clear_flag id lemmas ipat
+
+let apply_delayed_in simple with_evars clear_flag id lemmas ipat =
+  general_apply_in false simple simple with_evars clear_flag id lemmas ipat
+
+(*****************************)
+(* Tactics abstracting terms *)
+(*****************************)
+
+(* Implementation without generalisation: abbrev will be lost in hyps in *)
+(* in the extracted proof *)
+
+let tactic_infer_flags with_evar = {
+  Pretyping.use_typeclasses = true;
+  Pretyping.use_unif_heuristics = true;
+  Pretyping.use_hook = Some solve_by_implicit_tactic;
+  Pretyping.fail_evar = not with_evar;
+  Pretyping.expand_evars = true }
+
+let decode_hyp = function
+  | None -> MoveLast
+  | Some id -> MoveAfter id
+
+(* [letin_tac b (... abstract over c ...) gl] transforms
+   [...x1:T1(c),...,x2:T2(c),... |- G(c)] into
+   [...x:T;Heqx:(x=c);x1:T1(x),...,x2:T2(x),... |- G(x)] if [b] is false or
+   [...x:=c:T;x1:T1(x),...,x2:T2(x),... |- G(x)] if [b] is true
+*)
+
+let letin_tac_gen with_eq (id,depdecls,lastlhyp,ccl,c) ty =
+  Proofview.Goal.enter begin fun gl ->
+    let env = Proofview.Goal.env gl in
+    let sigma = Proofview.Goal.sigma gl in
+    let t = match ty with Some t -> t | _ -> typ_of env sigma c in
+    let eq_tac gl = match with_eq with
+      | Some (lr,(loc,ido)) ->
+          let heq = match ido with
+            | IntroAnonymous -> new_fresh_id [id] (add_prefix "Heq" id) gl
+            | IntroFresh heq_base -> new_fresh_id [id] heq_base gl
+            | IntroIdentifier id -> id in
+          let eqdata = build_coq_eq_data () in
+          let args = if lr then [t;mkVar id;c] else [t;c;mkVar id]in
+          let sigma, eq = Evd.fresh_global env sigma eqdata.eq in
+          let sigma, refl = Evd.fresh_global env sigma eqdata.refl in
+          let eq = applist (eq,args) in
+          let refl = applist (refl, [t;mkVar id]) in
+	  let term = mkNamedLetIn id c t (mkLetIn (Name heq, refl, eq, ccl)) in
+	  let sigma, _ = Typing.e_type_of env sigma term in
+            sigma, term,
+            Tacticals.New.tclTHEN
+	      (intro_gen (NamingMustBe (loc,heq)) (decode_hyp lastlhyp) true false)
+	      (clear_body [heq;id])
+      | None ->
+	  (sigma, mkNamedLetIn id c t ccl, Proofview.tclUNIT ()) in
+    let (sigma,newcl,eq_tac) = eq_tac gl in
+    Tacticals.New.tclTHENLIST
+      [ Proofview.Unsafe.tclEVARS sigma;
+	convert_concl_no_check newcl DEFAULTcast;
+        intro_gen (NamingMustBe (dloc,id)) (decode_hyp lastlhyp) true false;
+        Tacticals.New.tclMAP convert_hyp_no_check depdecls;
+        eq_tac ]
+  end
+
+let insert_before decls lasthyp env =
+  match lasthyp with
+  | None -> push_named_context decls env
+  | Some id ->
+  Environ.fold_named_context
+    (fun _ (id',_,_ as d) env ->
+      let env = if Id.equal id id' then push_named_context decls env else env in
+      push_named d env)
+    ~init:(reset_context env) env
+
+(* unsafe *)
+
+let mkletin_goal env sigma store with_eq dep (id,lastlhyp,ccl,c) ty =
+  let body = if dep then Some c else None in
+  let t = match ty with Some t -> t | _ -> typ_of env sigma c in
+  match with_eq with
+  | Some (lr,(loc,ido)) ->
+      let heq = match ido with
+      | IntroAnonymous -> fresh_id_in_env [id] (add_prefix "Heq" id) env
+      | IntroFresh heq_base -> fresh_id_in_env [id] heq_base env
+      | IntroIdentifier id -> id in
+      let eqdata = build_coq_eq_data () in
+      let args = if lr then [t;mkVar id;c] else [t;c;mkVar id]in
+      let sigma, eq = Evd.fresh_global env sigma eqdata.eq in
+      let sigma, refl = Evd.fresh_global env sigma eqdata.refl in
+      let eq = applist (eq,args) in
+      let refl = applist (refl, [t;mkVar id]) in
+      let newenv = insert_before [heq,None,eq;id,body,t] lastlhyp env in
+      let (sigma,x) = new_evar newenv sigma ~principal:true ~store ccl in
+      (sigma,mkNamedLetIn id c t (mkNamedLetIn heq refl eq x))
+  | None ->
+      let newenv = insert_before [id,body,t] lastlhyp env in
+      let (sigma,x) = new_evar newenv sigma ~principal:true ~store ccl in
+      (sigma,mkNamedLetIn id c t x)
+
+let letin_tac with_eq id c ty occs =
+  Proofview.Goal.nf_enter begin fun gl ->
+    let env = Proofview.Goal.env gl in
+    let sigma = Proofview.Goal.sigma gl in
+    let ccl = Proofview.Goal.concl gl in
+    let abs = AbstractExact (id,c,ty,occs,true) in
+    let (id,_,depdecls,lastlhyp,ccl,_) = make_abstraction env sigma ccl abs in
+    (* We keep the original term to match *)
+    letin_tac_gen with_eq (id,depdecls,lastlhyp,ccl,c) ty
+  end
+
+let letin_pat_tac with_eq id c occs =
+  Proofview.Goal.nf_enter begin fun gl ->
+    let env = Proofview.Goal.env gl in
+    let sigma = Proofview.Goal.sigma gl in
+    let ccl = Proofview.Goal.concl gl in
+    let check t = true in
+    let abs = AbstractPattern (false,check,id,c,occs,false) in
+    let (id,_,depdecls,lastlhyp,ccl,res) = make_abstraction env sigma ccl abs in
+    let sigma,c = match res with
+    | None -> finish_evar_resolution ~flags:(tactic_infer_flags false) env sigma c
+    | Some (sigma,c) -> (sigma,c) in
+    Tacticals.New.tclTHEN
+      (Proofview.Unsafe.tclEVARS sigma)
+      (letin_tac_gen with_eq (id,depdecls,lastlhyp,ccl,c) None)
+  end
+
+(* Tactics "pose proof" (usetac=None) and "assert"/"enough" (otherwise) *)
+let forward b usetac ipat c =
+  match usetac with
+  | None ->
+      Proofview.Goal.enter begin fun gl ->
+      let t = Tacmach.New.pf_type_of gl  c in
+      Tacticals.New.tclTHENFIRST (assert_as true ipat t)
+	(Proofview.V82.tactic (exact_no_check c))
+      end
+  | Some tac ->
+      if b then
+        Tacticals.New.tclTHENFIRST (assert_as b ipat c) tac
+      else
+        Tacticals.New.tclTHENS3PARTS
+          (assert_as b ipat c) [||] tac [|Tacticals.New.tclIDTAC|]
+
+let pose_proof na c = forward true None (ipat_of_name na) c
+let assert_by na t tac = forward true (Some tac) (ipat_of_name na) t
+let enough_by na t tac = forward false (Some tac) (ipat_of_name na) t
+
+(***************************)
+(*  Generalization tactics *)
+(***************************)
+
+(* Given a type [T] convertible to [forall x1..xn:A1..An(x1..xn-1), G(x1..xn)]
+   and [a1..an:A1..An(a1..an-1)] such that the goal is [G(a1..an)],
+   this generalizes [hyps |- goal] into [hyps |- T] *)
+
+let apply_type hdcty argl gl =
+  refine (applist (mkCast (Evarutil.mk_new_meta(),DEFAULTcast, hdcty),argl)) gl
+
+(* Given a context [hyps] with domain [x1..xn], possibly with let-ins,
+   and well-typed in the current goal, [bring_hyps hyps] generalizes
+   [ctxt |- G(x1..xn] into [ctxt |- forall hyps, G(x1..xn)] *)
+
+let bring_hyps hyps =
+  if List.is_empty hyps then Tacticals.New.tclIDTAC
+  else
+    Proofview.Goal.enter begin fun gl ->
+      let env = Proofview.Goal.env gl in
+      let concl = Tacmach.New.pf_nf_concl gl in
+      let newcl = List.fold_right mkNamedProd_or_LetIn hyps concl in
+      let args = Array.of_list (instance_from_named_context hyps) in
+      Proofview.Refine.refine begin fun sigma ->
+        let (sigma, ev) = Evarutil.new_evar env sigma newcl in
+        (sigma, (mkApp (ev, args)))
+      end
+    end
+
+let revert hyps = 
+  Proofview.Goal.enter begin fun gl ->
+    let gl = Proofview.Goal.assume gl in
+    let ctx = List.map (fun id -> Tacmach.New.pf_get_hyp id gl) hyps in
+      (bring_hyps ctx) <*> (Proofview.V82.tactic (clear hyps))
+  end
+
+(* Compute a name for a generalization *)
 
 let generalized_name c t ids cl = function
   | Name id as na ->
-      if List.mem id ids then
-	errorlabstrm "" (pr_id id ++ str " is already used");
+      if Id.List.mem id ids then
+	errorlabstrm "" (pr_id id ++ str " is already used.");
       na
   | Anonymous ->
       match kind_of_term c with
@@ -1505,72 +2444,105 @@ let generalized_name c t ids cl = function
                constante dont on aurait pu prendre directement le nom *)
 	    named_hd (Global.env()) t Anonymous
 
-let generalize_goal gl i ((occs,c,b),na) cl =
-  let t = pf_type_of gl c in
+(* Abstract over [c] in [forall x1:A1(c)..xi:Ai(c).T(c)] producing
+   [forall x, x1:A1(x1), .., xi:Ai(x). T(x)] with all [c] abtracted in [Ai]
+   but only those at [occs] in [T] *)
+
+let generalize_goal_gen env ids i ((occs,c,b),na) t (cl,evd) =
   let decls,cl = decompose_prod_n_assum i cl in
   let dummy_prod = it_mkProd_or_LetIn mkProp decls in
-  let newdecls,_ = decompose_prod_n_assum i (subst_term c dummy_prod) in
-  let cl' = subst_closed_term_occ occs c (it_mkProd_or_LetIn cl newdecls) in
-  let na = generalized_name c t (pf_ids_of_hyps gl) cl' na in
-    mkProd_or_LetIn (na,b,t) cl'
+  let newdecls,_ = decompose_prod_n_assum i (subst_term_gen eq_constr_nounivs c dummy_prod) in
+  let cl',evd' = subst_closed_term_occ env evd (AtOccs occs) c (it_mkProd_or_LetIn cl newdecls) in
+  let na = generalized_name c t ids cl' na in
+    mkProd_or_LetIn (na,b,t) cl', evd'
+
+let generalize_goal gl i ((occs,c,b),na as o) cl =
+  let t = pf_type_of gl c in
+  let env = pf_env gl in
+    generalize_goal_gen env (pf_ids_of_hyps gl) i o t cl
 
 let generalize_dep ?(with_let=false) c gl =
   let env = pf_env gl in
   let sign = pf_hyps gl in
   let init_ids = ids_of_named_context (Global.named_context()) in
-  let rec seek d toquant =
+  let seek d toquant =
     if List.exists (fun (id,_,_) -> occur_var_in_decl env id d) toquant
-      or dependent_in_decl c d then
+      || dependent_in_decl c d then
       d::toquant
     else
       toquant in
-  let to_quantify = Sign.fold_named_context seek sign ~init:[] in
+  let to_quantify = Context.fold_named_context seek sign ~init:[] in
   let to_quantify_rev = List.rev to_quantify in
   let qhyps = List.map (fun (id,_,_) -> id) to_quantify_rev in
-  let tothin = List.filter (fun id -> not (List.mem id init_ids)) qhyps in
+  let tothin = List.filter (fun id -> not (Id.List.mem id init_ids)) qhyps in
   let tothin' =
     match kind_of_term c with
-      | Var id when mem_named_context id sign & not (List.mem id init_ids)
+      | Var id when mem_named_context id sign && not (Id.List.mem id init_ids)
 	  -> id::tothin
       | _ -> tothin
   in
   let cl' = it_mkNamedProd_or_LetIn (pf_concl gl) to_quantify in
-  let body = 
+  let body =
     if with_let then
-      match kind_of_term c with 
+      match kind_of_term c with
       | Var id -> pi2 (pf_get_hyp gl id)
       | _ -> None
     else None
   in
-  let cl'' = generalize_goal gl 0 ((all_occurrences,c,body),Anonymous) cl' in
-  let args = Array.to_list (instance_from_named_context to_quantify_rev) in
-  tclTHEN
-    (apply_type cl'' (if body = None then c::args else args))
-    (thin (List.rev tothin'))
+  let cl'',evd = generalize_goal gl 0 ((AllOccurrences,c,body),Anonymous)
+    (cl',project gl) in
+  let args = instance_from_named_context to_quantify_rev in
+  tclTHENLIST
+    [tclEVARS evd;
+     apply_type cl'' (if Option.is_empty body then c::args else args);
+     thin (List.rev tothin')]
     gl
 
+(**  *)
 let generalize_gen_let lconstr gl =
-  let newcl =
-    list_fold_right_i (generalize_goal gl) 0 lconstr (pf_concl gl) in
-  apply_type newcl (list_map_filter (fun ((_,c,b),_) -> 
-    if b = None then Some c else None) lconstr) gl
+  let newcl, evd =
+    List.fold_right_i (generalize_goal gl) 0 lconstr
+      (pf_concl gl,project gl)
+  in
+  tclTHEN (tclEVARS evd)
+    (apply_type newcl (List.map_filter (fun ((_,c,b),_) ->
+      if Option.is_empty b then Some c else None) lconstr)) gl
+
+let new_generalize_gen_let lconstr =
+  Proofview.Goal.enter begin fun gl ->
+    let gl = Proofview.Goal.assume gl in
+    let concl = Proofview.Goal.concl gl in
+    let sigma = Proofview.Goal.sigma gl in
+    let env = Proofview.Goal.env gl in
+    let ids = Tacmach.New.pf_ids_of_hyps gl in
+    let (newcl, sigma), args =
+      List.fold_right_i 
+	(fun i ((_,c,b),_ as o) (cl, args) ->
+	  let t = Tacmach.New.pf_type_of gl c in
+	  let args = if Option.is_empty b then c :: args else args in
+	    generalize_goal_gen env ids i o t cl, args)
+	0 lconstr ((concl, sigma), [])
+    in
+      Proofview.Unsafe.tclEVARS sigma <*>
+	Proofview.Refine.refine begin fun sigma ->
+          let (sigma, ev) = Evarutil.new_evar env sigma newcl in
+            (sigma, (applist (ev, args)))
+	end
+  end
 
 let generalize_gen lconstr =
   generalize_gen_let (List.map (fun ((occs,c),na) ->
     (occs,c,None),na) lconstr)
+
+let new_generalize_gen lconstr =
+  new_generalize_gen_let (List.map (fun ((occs,c),na) ->
+    (occs,c,None),na) lconstr)
     
 let generalize l =
-  generalize_gen_let (List.map (fun c -> ((all_occurrences,c,None),Anonymous)) l)
+  generalize_gen_let (List.map (fun c -> ((AllOccurrences,c,None),Anonymous)) l)
 
-let pf_get_hyp_val gl id =
-  let (_, b, _) = pf_get_hyp gl id in
-    b
-
-let revert hyps gl = 
-  let lconstr = List.map (fun id -> 
-    ((all_occurrences, mkVar id, pf_get_hyp_val gl id), Anonymous)) 
-    hyps 
-  in tclTHEN (generalize_gen_let lconstr) (clear hyps) gl
+let new_generalize l =
+  new_generalize_gen_let (List.map (fun c -> ((AllOccurrences,c,None),Anonymous)) l)
 
 (* Faudra-t-il une version avec plusieurs args de generalize_dep ?
 Cela peut-être troublant de faire "Generalize Dependent H n" dans
@@ -1584,218 +2556,6 @@ let quantify lconstr =
    tclIDTAC
 *)
 
-(* A dependent cut rule à la sequent calculus
-   ------------------------------------------
-   Sera simplifiable le jour où il y aura un let in primitif dans constr
-
-   [letin_tac b na c (occ_hyp,occ_ccl) gl] transforms
-   [...x1:T1(c),...,x2:T2(c),... |- G(c)] into
-   [...x:T;Heqx:(x=c);x1:T1(x),...,x2:T2(x),... |- G(x)] if [b] is false or
-   [...x:=c:T;x1:T1(x),...,x2:T2(x),... |- G(x)] if [b] is true
-
-   [occ_hyp,occ_ccl] tells which occurrences of [c] have to be substituted;
-   if [occ_hyp = []] and [occ_ccl = None] then [c] is substituted
-   wherever it occurs, otherwise [c] is substituted only in hyps
-   present in [occ_hyps] at the specified occurrences (everywhere if
-   the list of occurrences is empty), and in the goal at the specified
-   occurrences if [occ_goal] is not [None];
-
-   if name = Anonymous, the name is build from the first letter of the type;
-
-   The tactic first quantify the goal over x1, x2,... then substitute then
-   re-intro x1, x2,... at their initial place ([marks] is internally
-   used to remember the place of x1, x2, ...: it is the list of hypotheses on
-   the left of each x1, ...).
-*)
-
-let out_arg = function
-  | ArgVar _ -> anomaly "Unevaluated or_var variable"
-  | ArgArg x -> x
-
-let occurrences_of_hyp id cls =
-  let rec hyp_occ = function
-      [] -> None
-    | (((b,occs),id'),hl)::_ when id=id' -> Some ((b,List.map out_arg occs),hl)
-    | _::l -> hyp_occ l in
-  match cls.onhyps with
-      None -> Some (all_occurrences,InHyp)
-    | Some l -> hyp_occ l
-
-let occurrences_of_goal cls =
-  if cls.concl_occs = no_occurrences_expr then None
-  else Some (on_snd (List.map out_arg) cls.concl_occs)
-
-let in_every_hyp cls = (cls.onhyps=None)
-
-(*
-(* Implementation with generalisation then re-intro: introduces noise *)
-(* in proofs *)
-
-let letin_abstract id c occs gl =
-  let env = pf_env gl in
-  let compute_dependency _ (hyp,_,_ as d) ctxt =
-    let d' =
-      try
-	match occurrences_of_hyp hyp occs with
-	  | None -> raise Not_found
-	  | Some occ ->
-              let newdecl = subst_term_occ_decl occ c d in
-              if occ = [] & d = newdecl then
-		if not (in_every_hyp occs)
-		then raise (RefinerError (DoesNotOccurIn (c,hyp)))
-		else raise Not_found
-              else
-		(subst1_named_decl (mkVar id) newdecl, true)
-	with Not_found ->
-	  (d,List.exists
-	      (fun ((id,_,_),dep) -> dep && occur_var_in_decl env id d) ctxt)
-    in d'::ctxt
-  in
-  let ctxt' = fold_named_context compute_dependency env ~init:[] in
-  let compute_marks ((depdecls,marks as accu),lhyp) ((hyp,_,_) as d,b) =
-    if b then ((d::depdecls,(hyp,lhyp)::marks), lhyp)
-    else (accu, Some hyp) in
-  let (depdecls,marks),_ = List.fold_left compute_marks (([],[]),None) ctxt' 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
-  (depdecls,marks,ccl)
-
-let letin_tac with_eq name c occs gl =
-  let x = id_of_name_using_hdchar (Global.env()) (pf_type_of gl c) name in
-  let id =
-    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,marks,ccl)= letin_abstract id c occs gl in
-  let t = pf_type_of gl c in
-  let tmpcl = List.fold_right mkNamedProd_or_LetIn depdecls ccl in
-  let args = Array.to_list (instance_from_named_context depdecls) in
-  let newcl = mkNamedLetIn id c t tmpcl in
-  let lastlhyp = if marks=[] then None else snd (List.hd marks) in
-  tclTHENLIST
-    [ apply_type newcl args;
-      thin (List.map (fun (id,_,_) -> id) depdecls);
-      intro_gen (IntroMustBe id) lastlhyp false;
-      if with_eq then tclIDTAC else thin_body [id];
-      intros_move marks ] gl
-*)
-
-(* Implementation without generalisation: abbrev will be lost in hyps in *)
-(* in the extracted proof *)
-
-let default_matching_flags sigma = {
-  modulo_conv_on_closed_terms = Some empty_transparent_state;
-  use_metas_eagerly_in_conv_on_closed_terms = false;
-  modulo_delta = empty_transparent_state;
-  modulo_delta_types = full_transparent_state;
-  modulo_delta_in_merge = Some full_transparent_state;
-  check_applied_meta_types = true;
-  resolve_evars = false;
-  use_pattern_unification = false;
-  use_meta_bound_pattern_unification = false;
-  frozen_evars =
-    fold_undefined (fun evk _ evars -> ExistentialSet.add evk evars)
-      sigma ExistentialSet.empty;
-  restrict_conv_on_strict_subterms = false;
-  modulo_betaiota = false;
-  modulo_eta = false;
-  allow_K_in_toplevel_higher_order_unification = false
-}
-
-let make_pattern_test env sigma0 (sigma,c) =
-  let flags = default_matching_flags sigma0 in
-  let matching_fun t =
-    try let sigma = w_unify env sigma Reduction.CONV ~flags c t in Some(sigma,t)
-    with e when Errors.noncritical e -> raise NotUnifiable in
-  let merge_fun c1 c2 =
-    match c1, c2 with
-    | Some (_,c1), Some (_,c2) when not (is_fconv Reduction.CONV env sigma0 c1 c2) ->
-        raise NotUnifiable
-    | _ -> c1 in
-  { match_fun = matching_fun; merge_fun = merge_fun; 
-    testing_state = None; last_found = None },
-  (fun test -> match test.testing_state with
-   | None -> finish_evar_resolution env sigma0 (sigma,c)
-   | Some (sigma,_) -> nf_evar sigma c)
-
-let letin_abstract id c (test,out) (occs,check_occs) gl =
-  let env = pf_env gl in
-  let compute_dependency _ (hyp,_,_ as d) depdecls =
-    match occurrences_of_hyp hyp occs with
-      | None -> depdecls
-      | Some occ ->
-          let newdecl = subst_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
-          else
-	    (subst1_named_decl (mkVar id) newdecl)::depdecls in
-  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_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,out test)
-
-let letin_tac_gen with_eq name (sigmac,c) test ty occs gl =
-  let id =
-    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,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
-        | IntroAnonymous -> fresh_id [id] (add_prefix "Heq" id) gl
-	| IntroFresh heq_base -> fresh_id [id] heq_base gl
-        | IntroIdentifier id -> id
-	| _ -> error"Expect an introduction pattern naming one hypothesis." in
-      let eqdata = build_coq_eq_data () in
-      let args = if lr then [t;mkVar id;c] else [t;c;mkVar id]in
-      let eq = applist (eqdata.eq,args) in
-      let refl = applist (eqdata.refl, [t;mkVar id]) in
-      mkNamedLetIn id c t (mkLetIn (Name heq, refl, eq, ccl)),
-      tclTHEN
-	(intro_gen loc (IntroMustBe heq) lastlhyp true false)
-	(thin_body [heq;id])
-    | None ->
-	mkNamedLetIn id c t ccl, tclIDTAC in
-  tclTHENLIST
-    [ convert_concl_no_check newcl DEFAULTcast;
-      intro_gen dloc (IntroMustBe id) lastlhyp true false;
-      tclMAP convert_hyp_no_check depdecls;
-      eq_tac ] gl
-
-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 =
-  match usetac with
-  | None ->
-      let t = pf_type_of gl c in
-      tclTHENFIRST (assert_as true ipat t) (exact_no_check c) gl
-  | Some tac ->
-      tclTHENFIRST (assert_as true ipat c) tac gl
-
-let pose_proof na c = forward None (ipat_of_name na) c
-let assert_by na t tac = forward (Some tac) (ipat_of_name na) t
-
 (*****************************)
 (* Ad hoc unfold             *)
 (*****************************)
@@ -1805,7 +2565,7 @@ let assert_by na t tac = forward (Some tac) (ipat_of_name na) t
 let unfold_body x gl =
   let hyps = pf_hyps gl in
   let xval =
-    match Sign.lookup_named x hyps with
+    match Context.lookup_named x hyps with
         (_,Some xval,_) -> xval
       | _ -> errorlabstrm "unfold_body"
           (pr_id x ++ str" is not a defined hypothesis.") in
@@ -1817,14 +2577,6 @@ let unfold_body x gl =
     [tclMAP (fun h -> reduct_in_hyp rfun h) hl;
      reduct_in_concl (rfun,DEFAULTcast)] gl
 
-(* Unfolds x by its definition everywhere and clear x. This may raise
-   an error if x is not defined. *)
-let unfold_all x gl =
-  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 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])
 
@@ -1849,7 +2601,7 @@ let expand_hyp id = tclTHEN (tclTRY (unfold_body id)) (clear [id])
     move the subterms of [hyp0succ] in the i-th branch where it is supposed
     to be the i-th constructor of the inductive type.
 
-  Strategy: (cf in [induction_from_context])
+  Strategy: (cf in [induction_with_atomization_of_ind_arg])
   - requantify and clear all [dephyps]
   - apply induction on [hyp0]
   - clear [indhyps] and [hyp0]
@@ -1865,50 +2617,61 @@ let expand_hyp id = tclTHEN (tclTRY (unfold_body id)) (clear [id])
  *)
 
 let check_unused_names names =
-  if names <> [] & Flags.is_verbose () then
+  if not (List.is_empty names) && Flags.is_verbose () then
     msg_warning
-      (str"Unused introduction " ++ str (plural (List.length names) "pattern")
-       ++ str": " ++ prlist_with_sep spc pr_intro_pattern names)
+      (str"Unused introduction " ++ str (String.plural (List.length names) "pattern")
+       ++ str": " ++ prlist_with_sep spc 
+	 (Miscprint.pr_intro_pattern 
+	    (fun c -> Printer.pr_constr (snd (c (Global.env()) Evd.empty)))) names)
 
-let rec consume_pattern avoid id isdep gl = function
-  | [] -> ((dloc, IntroIdentifier (fresh_id avoid id gl)), [])
-  | (loc,IntroAnonymous)::names ->
-      let avoid = avoid@explicit_intro_names names in
-      ((loc,IntroIdentifier (fresh_id avoid id gl)), names)
+let intropattern_of_name gl avoid = function
+  | Anonymous -> IntroNaming IntroAnonymous
+  | Name id -> IntroNaming (IntroIdentifier (new_fresh_id avoid id gl))
+
+let rec consume_pattern avoid na isdep gl = function
+  | [] -> ((dloc, intropattern_of_name gl avoid na), [])
   | (loc,IntroForthcoming true)::names when not isdep ->
-      consume_pattern avoid id isdep gl names
+      consume_pattern avoid na isdep gl names
   | (loc,IntroForthcoming _)::names as fullpat ->
       let avoid = avoid@explicit_intro_names names in
-      ((loc,IntroIdentifier (fresh_id avoid id gl)), fullpat)
-  | (loc,IntroFresh id')::names ->
+      ((loc,intropattern_of_name gl avoid na), fullpat)
+  | (loc,IntroNaming IntroAnonymous)::names ->
       let avoid = avoid@explicit_intro_names names in
-      ((loc,IntroIdentifier (fresh_id avoid id' gl)), names)
+      ((loc,intropattern_of_name gl avoid na), names)
+  | (loc,IntroNaming (IntroFresh id'))::names ->
+      let avoid = avoid@explicit_intro_names names in
+      ((loc,IntroNaming (IntroIdentifier (new_fresh_id avoid id' gl))), names)
   | pat::names -> (pat,names)
 
 let re_intro_dependent_hypotheses (lstatus,rstatus) (_,tophyp) =
-  let tophyp = match tophyp with None -> MoveToEnd true | Some hyp -> MoveAfter hyp in
+  let tophyp = match tophyp with None -> MoveLast | 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
+    List.map (function (hyp,MoveLast) -> (hyp,tophyp) | x -> x) lstatus
   in
-  tclTHEN
+  Tacticals.New.tclTHEN
     (intros_move rstatus)
     (intros_move newlstatus)
 
-let update destopt tophyp = if destopt = no_move then tophyp else destopt
-
-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 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"
-       where argument a of dec will be found only lately *)
-    intros_patterns true avoid [] [] no_move tac pat gl
+let dest_intro_patterns avoid thin dest pat tac =
+  intro_patterns_core true avoid [] thin dest None 0 tac pat
+
+let safe_dest_intro_patterns avoid thin dest pat tac =
+  Proofview.tclORELSE
+    (dest_intro_patterns avoid thin dest pat tac)
+    begin function (e, info) -> match e with
+      | UserError ("move_hyp",_) ->
+       (* May happen e.g. with "destruct x using s" with an hypothesis
+          which is morally an induction hypothesis to be "MoveLast" if
+          known as such but which is considered instead as a subterm of
+          a constructor to be move at the place of x. *)
+          dest_intro_patterns avoid thin MoveLast pat tac
+      | e -> Proofview.tclZERO ~info e
+    end
 
 type elim_arg_kind = RecArg | IndArg | OtherArg
 
 type recarg_position =
-  | AfterFixedPosition of identifier option (* None = top of context *)
+  | AfterFixedPosition of Id.t option (* None = top of context *)
 
 let update_dest (recargdests,tophyp as dests) = function
   | [] -> dests
@@ -1920,7 +2683,7 @@ let update_dest (recargdests,tophyp as dests) = function
 
 let get_recarg_dest (recargdests,tophyp) =
   match recargdests with
-  | AfterFixedPosition None -> MoveToEnd true
+  | AfterFixedPosition None -> MoveLast
   | AfterFixedPosition (Some id) -> MoveAfter id
 
 (* Current policy re-introduces recursive arguments of destructed
@@ -1933,45 +2696,56 @@ let get_recarg_dest (recargdests,tophyp) =
    had to be introduced at the top of the context).
 *)
 
-let induct_discharge dests avoid' tac (avoid,ra) names gl =
+let induct_discharge dests avoid' tac (avoid,ra) names =
   let avoid = avoid @ avoid' in
-  let rec peel_tac ra dests names thin gl =
+  let rec peel_tac ra dests names thin =
     match ra with
     | (RecArg,deprec,recvarname) ::
         (IndArg,depind,hyprecname) :: ra' ->
-        let recpat,names = match names with
-          | [loc,IntroIdentifier id as pat] ->
+        Proofview.Goal.enter begin fun gl ->
+        let (recpat,names) = match names with
+          | [loc,IntroNaming (IntroIdentifier id) as pat] ->
               let id' = next_ident_away (add_prefix "IH" id) avoid in
-	      (pat, [dloc, IntroIdentifier id'])
-          | _ -> consume_pattern avoid recvarname deprec gl names in
-        let hyprec,names = consume_pattern avoid hyprecname depind gl names in
+	      (pat, [dloc, IntroNaming (IntroIdentifier id')])
+          | _ -> consume_pattern avoid (Name recvarname) deprec gl names in
         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
+        dest_intro_patterns avoid thin dest [recpat] (fun ids thin ->
+        Proofview.Goal.enter begin fun gl ->
+          let (hyprec,names) =
+            consume_pattern avoid (Name hyprecname) depind gl names
+          in
+	  dest_intro_patterns avoid thin MoveLast [hyprec] (fun ids' thin ->
+	    peel_tac ra' (update_dest dests ids') names thin)
+        end)
+        end
     | (IndArg,dep,hyprecname) :: ra' ->
+        Proofview.Goal.enter begin fun gl ->
 	(* Rem: does not happen in Coq schemes, only in user-defined schemes *)
-        let pat,names = consume_pattern avoid hyprecname dep gl names in
-	safe_dest_intros_patterns avoid thin no_move [pat] (fun ids thin ->
-        peel_tac ra' (update_dest dests ids) names thin) gl
+        let pat,names =
+          consume_pattern avoid (Name hyprecname) dep gl names in
+	dest_intro_patterns avoid thin MoveLast [pat] (fun ids thin ->
+        peel_tac ra' (update_dest dests ids) names thin)
+        end
     | (RecArg,dep,recvarname) :: ra' ->
-        let pat,names = consume_pattern avoid recvarname dep gl names in
+        Proofview.Goal.enter begin fun gl ->
+        let (pat,names) =
+          consume_pattern avoid (Name recvarname) dep gl names in
         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
+	dest_intro_patterns avoid thin dest [pat] (fun ids thin ->
+        peel_tac ra' dests names thin)
+        end
+    | (OtherArg,dep,_) :: ra' ->
+        Proofview.Goal.enter begin fun gl ->
+        let (pat,names) = consume_pattern avoid Anonymous dep gl names in
         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
+	safe_dest_intro_patterns avoid thin dest [pat] (fun ids thin ->
+        peel_tac ra' dests names thin)
+        end
     | [] ->
         check_unused_names names;
-        tclTHEN (clear_wildcards thin) (tac dests) gl
+        Tacticals.New.tclTHEN (clear_wildcards thin) (tac dests)
   in
-  peel_tac ra dests names [] gl
+  peel_tac ra dests names []
 
 (* - 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
@@ -1979,58 +2753,67 @@ let induct_discharge dests avoid' tac (avoid,ra) names gl =
 
 (* Marche pas... faut prendre en compte l'occurrence précise... *)
 
-let atomize_param_of_ind (indref,nparams,_) hyp0 gl =
-  let tmptyp0 = pf_get_hyp_typ gl hyp0 in
-  let typ0 = pf_apply reduce_to_quantified_ref gl indref tmptyp0 in
+let atomize_param_of_ind_then (indref,nparams,_) hyp0 tac =
+  Proofview.Goal.enter begin fun gl ->
+  let env = Proofview.Goal.env gl in
+  let tmptyp0 = Tacmach.New.pf_get_hyp_typ hyp0 (Proofview.Goal.assume gl) in
+  let reduce_to_quantified_ref = Tacmach.New.pf_apply reduce_to_quantified_ref gl in
+  let typ0 = reduce_to_quantified_ref indref tmptyp0 in
   let prods, indtyp = decompose_prod typ0 in
-  let argl = snd (decompose_app indtyp) in
-  let params = list_firstn nparams argl in
+  let hd,argl = decompose_app indtyp in
+  let params = List.firstn nparams argl in
   (* le gl est important pour ne pas préévaluer *)
-  let rec atomize_one i avoid gl =
-    if i<>nparams then
-      let tmptyp0 = pf_get_hyp_typ gl hyp0 in
-      (* If argl <> [], we expect typ0 not to be quantified, in order to
-         avoid bound parameters... then we call pf_reduce_to_atomic_ind *)
-      let indtyp = pf_apply reduce_to_atomic_ref gl indref tmptyp0 in
-      let argl = snd (decompose_app indtyp) in
+  let rec atomize_one i args avoid =
+    if Int.equal i nparams then
+      let t = applist (hd, params@args) in
+      Tacticals.New.tclTHEN
+        (change_in_hyp None (fun sigma -> sigma, t) (hyp0,InHypTypeOnly))
+        (tac avoid)
+    else
       let c = List.nth argl (i-1) in
       match kind_of_term c with
-	| Var id when not (List.exists (occur_var (pf_env gl) id) avoid) ->
-	    atomize_one (i-1) ((mkVar id)::avoid) gl
-	| Var id ->
-	    let x = fresh_id [] id gl in
-	    tclTHEN
-	      (letin_tac None (Name x) (mkVar id) None allHypsAndConcl)
-	      (atomize_one (i-1) ((mkVar x)::avoid)) gl
+	| Var id when not (List.exists (occur_var env id) args) &&
+                      not (List.exists (occur_var env id) params) ->
+            (* Based on the knowledge given by the user, all
+               constraints on the variable are generalizable in the
+               current environment so that it is clearable after destruction *)
+	    atomize_one (i-1) (c::args) (id::avoid)
 	| _ ->
-	    let id = id_of_name_using_hdchar (Global.env()) (pf_type_of gl c)
-		       Anonymous in
-	    let x = fresh_id [] id gl in
-	    tclTHEN
+            if List.exists (dependent c) params ||
+               List.exists (dependent c) args
+            then
+              (* This is a case where the argument is constrained in a
+                 way which would require some kind of inversion; we
+                 follow the (old) discipline of not generalizing over
+                 this term, since we don't try to invert the
+                 constraint anyway. *)
+	      atomize_one (i-1) (c::args) avoid
+            else
+            (* We reason blindly on the term and do as if it were
+               generalizable, ignoring the constraints coming from
+               its structure *)
+            let id = match kind_of_term c with
+            | Var id -> id
+            | _ ->
+            let type_of = Tacmach.New.pf_type_of gl in
+            id_of_name_using_hdchar (Global.env()) (type_of c) Anonymous in
+            let x = fresh_id_in_env avoid id env in
+	    Tacticals.New.tclTHEN
 	      (letin_tac None (Name x) c None allHypsAndConcl)
-	      (atomize_one (i-1) ((mkVar x)::avoid)) gl
-    else
-      tclIDTAC gl
+	      (atomize_one (i-1) (mkVar x::args) (x::avoid))
   in
-  atomize_one (List.length argl) params gl
+  atomize_one (List.length argl) [] []
+  end
 
 let find_atomic_param_of_ind nparams indtyp =
   let argl = snd (decompose_app indtyp) in
-  let argv = Array.of_list argl in
-  let params = list_firstn nparams argl in
-  let indvars = ref Idset.empty in
-  for i = nparams to (Array.length argv)-1 do
-    match kind_of_term argv.(i) with
-      | Var id
-          when not (List.exists (occur_var (Global.env()) id) params) ->
-	  indvars := Idset.add id !indvars
-      | _ -> ()
-  done;
-  Idset.elements !indvars;
-
-
-(* [cook_sign] builds the lists [indhyps] of hyps that must be
-   erased, the lists of hyps to be generalize [(hdeps,tdeps)] on the
+  let params,args = List.chop nparams argl in
+  let test c = isVar c && not (List.exists (dependent c) params) in
+  List.map destVar (List.filter test args)
+
+(* [cook_sign] builds the lists [beforetoclear] (preceding the
+   ind. var.) and [aftertoclear] (coming after the ind. var.)  of hyps
+   that must be erased, the lists of hyps to be generalize [decldeps] on the
    goal together with the places [(lstatus,rstatus)] where to re-intro
    them after induction. To know where to re-intro the dep hyp, we
    remember the name of the hypothesis [lhyp] after which (if the dep
@@ -2080,7 +2863,7 @@ let find_atomic_param_of_ind nparams indtyp =
    would have posed no problem. But for uniformity, we decided to use
    the right hyp for all hyps on the right of H4.
 
-   Others solutions are welcome
+   Other solutions are welcome
 
    PC 9 fev 06: Adapted to accept multi argument principle with no
    main arg hyp. hyp0 is now optional, meaning that it is possible
@@ -2092,72 +2875,81 @@ let find_atomic_param_of_ind nparams indtyp =
 
 *)
 
-exception Shunt of identifier move_location
+exception Shunt of Id.t move_location
 
-let cook_sign hyp0_opt indvars env =
-  let hyp0,inhyps =
-  match hyp0_opt with
-  | None -> List.hd (List.rev indvars), []
-  | Some (hyp0,at_least_in_hyps) -> hyp0, at_least_in_hyps in
+let cook_sign hyp0_opt inhyps indvars env =
   (* First phase from L to R: get [indhyps], [decldep] and [statuslist]
      for the hypotheses before (= more ancient than) hyp0 (see above) *)
-  let allindhyps = hyp0::indvars in
-  let indhyps = ref [] in
+  let toclear = ref [] in
+  let avoid = ref [] in
   let decldeps = ref [] in
   let ldeps = ref [] in
   let rstatus = ref [] in
   let lstatus = ref [] in
   let before = ref true in
+  let maindep = ref false in
   let seek_deps env (hyp,_,_ as decl) rhyp =
-    if hyp = hyp0 then begin
+    if (match hyp0_opt with Some hyp0 -> Id.equal hyp hyp0 | _ -> false)
+    then begin
       before:=false;
-      (* If there was no main induction hypotheses, then hyp is one of
-         indvars too, so add it to indhyps. *)
-      (if hyp0_opt=None then indhyps := hyp::!indhyps);
-      MoveToEnd false (* fake value *)
-    end else if List.mem hyp indvars then begin
-      (* warning: hyp can still occur after induction *)
-      (* e.g. if the goal (t hyp hyp0) with other occs of hyp in t *)
-      indhyps := hyp::!indhyps;
+      (* Note that if there was no main induction hypotheses, then hyp
+         is one of indvars too *)
+      toclear := hyp::!toclear;
+      MoveFirst (* fake value *)
+    end else if Id.List.mem hyp indvars then begin
+      (* The variables in indvars are such that they don't occur any
+         more after generalization, so declare them to clear. *)
+      toclear := hyp::!toclear;
       rhyp
     end else
-      if inhyps <> [] && List.mem hyp inhyps || inhyps = [] &&
-	(List.exists (fun id -> occur_var_in_decl env id decl) allindhyps ||
+      let dephyp0 = List.is_empty inhyps && 
+	(Option.cata (fun id -> occur_var_in_decl env id decl) false hyp0_opt)
+      in
+      let depother = List.is_empty inhyps &&
+	(List.exists (fun id -> occur_var_in_decl env id decl) indvars ||
          List.exists (fun (id,_,_) -> occur_var_in_decl env id decl) !decldeps)
+      in
+      if not (List.is_empty inhyps) && Id.List.mem hyp inhyps
+         || dephyp0 || depother
       then begin
 	decldeps := decl::!decldeps;
-	if !before then
+	avoid := hyp::!avoid;
+        maindep := dephyp0 || !maindep;
+	if !before then begin
+          toclear := hyp::!toclear;
 	  rstatus := (hyp,rhyp)::!rstatus
-	else
-	  ldeps := hyp::!ldeps; (* status computed in 2nd phase *)
+        end
+	else begin
+	  toclear := hyp::!toclear;
+	  ldeps := hyp::!ldeps (* status computed in 2nd phase *)
+        end;
 	MoveBefore hyp end
       else
 	MoveBefore hyp
   in
-  let _ = fold_named_context seek_deps env ~init:(MoveToEnd false) in
+  let _ = fold_named_context seek_deps env ~init:MoveFirst in
   (* 2nd phase from R to L: get left hyp of [hyp0] and [lhyps] *)
   let compute_lstatus lhyp (hyp,_,_) =
-    if hyp = hyp0 then raise (Shunt lhyp);
-    if List.mem hyp !ldeps then begin
+    if (match hyp0_opt with Some hyp0 -> Id.equal hyp hyp0 | _ -> false) then
+      raise (Shunt lhyp);
+    if Id.List.mem hyp !ldeps then begin
       lstatus := (hyp,lhyp)::!lstatus;
       lhyp
     end else
-      if List.mem hyp !indhyps then lhyp else MoveAfter hyp
+      if Id.List.mem hyp !toclear then lhyp else MoveAfter hyp
   in
   try
     let _ =
-      fold_named_context_reverse compute_lstatus ~init:(MoveToEnd true) env in
-    raise (Shunt (MoveToEnd true)) (* ?? FIXME *)
+      fold_named_context_reverse compute_lstatus ~init:MoveLast env in
+    raise (Shunt MoveLast) (* ?? FIXME *)
   with Shunt lhyp0 ->
     let lhyp0 = match lhyp0 with
-      | MoveToEnd true -> None
+      | MoveLast -> None
       | MoveAfter hyp -> Some hyp
       | _ -> assert false in
     let statuslists = (!lstatus,List.rev !rstatus) in
-    let recargdests = AfterFixedPosition (if hyp0_opt=None then None else lhyp0) in
-    (statuslists, (recargdests,None),
-     !indhyps, !decldeps)
-
+    let recargdests = AfterFixedPosition (if Option.is_empty hyp0_opt then None else lhyp0) in
+    (statuslists, (recargdests,None), !toclear, !decldeps, !avoid, !maindep)
 
 (*
    The general form of an induction principle is the following:
@@ -2187,7 +2979,6 @@ 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,...) *)
@@ -2209,7 +3000,6 @@ let empty_scheme =
     elimc = None;
     elimt = mkProp;
     indref = None;
-    index = -1;
     params = [];
     nparams = 0;
     predicates = [];
@@ -2225,62 +3015,65 @@ let empty_scheme =
   }
 
 let make_base n id =
-  if n=0 or n=1 then id
+  if Int.equal n 0 || Int.equal n 1 then id
   else
     (* This extends the name to accept new digits if it already ends with *)
     (* digits *)
-    id_of_string (atompart_of_id (make_ident (string_of_id id) (Some 0)))
+    Id.of_string (atompart_of_id (make_ident (Id.to_string id) (Some 0)))
 
 (* Builds two different names from an optional inductive type and a
    number, also deals with a list of names to avoid. If the inductive
    type is None, then hyprecname is IHi where i is a number. *)
 let make_up_names n ind_opt cname =
-  let is_hyp = atompart_of_id cname = "H" in
-  let base = string_of_id (make_base n cname) in
+  let is_hyp = String.equal (atompart_of_id cname) "H" in
+  let base = Id.to_string (make_base n cname) in
   let ind_prefix = "IH" in
   let base_ind =
     if is_hyp then
       match ind_opt with
-	| None -> id_of_string ind_prefix
+	| None -> Id.of_string ind_prefix
 	| Some ind_id -> add_prefix ind_prefix (Nametab.basename_of_global ind_id)
     else add_prefix ind_prefix cname in
   let hyprecname = make_base n base_ind in
   let avoid =
-    if n=1 (* Only one recursive argument *) or n=0 then []
+    if Int.equal n 1 (* Only one recursive argument *) || Int.equal n 0 then []
     else
       (* Forbid to use cname, cname0, hyprecname and hyprecname0 *)
       (* in order to get names such as f1, f2, ... *)
       let avoid =
-        (make_ident (string_of_id hyprecname) None) ::
-        (make_ident (string_of_id hyprecname) (Some 0)) :: [] in
-      if atompart_of_id cname <> "H" then
+        (make_ident (Id.to_string hyprecname) None) ::
+        (make_ident (Id.to_string hyprecname) (Some 0)) :: [] in
+      if not (String.equal (atompart_of_id cname) "H") then
         (make_ident base (Some 0)) :: (make_ident base None) :: avoid
       else avoid in
-  id_of_string base, hyprecname, avoid
+  Id.of_string base, hyprecname, avoid
 
 let error_ind_scheme s =
-  let s = if s <> "" then s^" " else s in
+  let s = if not (String.is_empty s) then s^" " else s in
   error ("Cannot recognize "^s^"an induction scheme.")
 
-let coq_eq = Lazy.lazy_from_fun Coqlib.build_coq_eq
-let coq_eq_refl = lazy ((Coqlib.build_coq_eq_data ()).Coqlib.refl)
+let glob = Universes.constr_of_global
+
+let coq_eq = lazy (glob (Coqlib.build_coq_eq ()))
+let coq_eq_refl = lazy (glob (Coqlib.build_coq_eq_refl ()))
 
 let coq_heq = lazy (Coqlib.coq_constant "mkHEq" ["Logic";"JMeq"] "JMeq")
 let coq_heq_refl = lazy (Coqlib.coq_constant "mkHEq" ["Logic";"JMeq"] "JMeq_refl")
 
-let mkEq t x y = 
-  mkApp (Lazy.force coq_eq, [| refresh_universes_strict t; x; y |])
-    
-let mkRefl t x = 
-  mkApp (Lazy.force coq_eq_refl, [| refresh_universes_strict t; x |])
+
+let mkEq t x y =
+  mkApp (Lazy.force coq_eq, [| t; x; y |])
+
+let mkRefl t x =
+  mkApp (Lazy.force coq_eq_refl, [| t; x |])
 
 let mkHEq t x u y =
   mkApp (Lazy.force coq_heq,
-	[| refresh_universes_strict t; x; refresh_universes_strict u; y |])
-    
+	[| t; x; u; y |])
+
 let mkHRefl t x =
   mkApp (Lazy.force coq_heq_refl,
-	[| refresh_universes_strict t; x |])
+	[| t; x |])
 
 let lift_togethern n l =
   let l', _ =
@@ -2295,26 +3088,26 @@ let lift_list l = List.map (lift 1) l
 let ids_of_constr ?(all=false) vars c =
   let rec aux vars c =
     match kind_of_term c with
-    | Var id -> Idset.add id vars
-    | App (f, args) -> 
+    | Var id -> Id.Set.add id vars
+    | App (f, args) ->
 	(match kind_of_term f with
-	| Construct (ind,_)
-	| Ind ind ->
+	| Construct ((ind,_),_)
+	| Ind (ind,_) ->
             let (mib,mip) = Global.lookup_inductive ind in
-	      array_fold_left_from
+	      Array.fold_left_from
 		(if all then 0 else mib.Declarations.mind_nparams)
 		aux vars args
 	| _ -> fold_constr aux vars c)
     | _ -> fold_constr aux vars c
   in aux vars c
-    
+
 let decompose_indapp f args =
   match kind_of_term f with
-  | Construct (ind,_) 
-  | Ind ind ->
+  | Construct ((ind,_),_)
+  | Ind (ind,_) ->
       let (mib,mip) = Global.lookup_inductive ind in
       let first = mib.Declarations.mind_nparams_rec in
-      let pars, args = array_chop first args in
+      let pars, args = Array.chop first args in
 	mkApp (f, pars), args
   | _ -> f, args
 
@@ -2354,41 +3147,42 @@ let make_abstract_generalize gl id concl dep ctx body c eqs args refls =
     mkApp (appeqs, abshypt)
 
 let hyps_of_vars env sign nogen hyps =
-  if Idset.is_empty hyps then [] 
+  if Id.Set.is_empty hyps then []
   else
     let (_,lh) =
-      Sign.fold_named_context_reverse
+      Context.fold_named_context_reverse
         (fun (hs,hl) (x,_,_ as d) ->
-	  if Idset.mem x nogen then (hs,hl)
-	  else if Idset.mem x hs then (hs,x::hl)
+	  if Id.Set.mem x nogen then (hs,hl)
+	  else if Id.Set.mem x hs then (hs,x::hl)
 	  else
 	    let xvars = global_vars_set_of_decl env d in
-	      if not (Idset.equal (Idset.diff xvars hs) Idset.empty) then
-		(Idset.add x hs, x :: hl)
+	      if not (Id.Set.is_empty (Id.Set.diff xvars hs)) then
+		(Id.Set.add x hs, x :: hl)
 	      else (hs, hl))
         ~init:(hyps,[])
-        sign 
+        sign
     in lh
 
 exception Seen
 
-let linear vars args = 
+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)
+    try
+      Array.iter (fun i ->
+	let rels = ids_of_constr ~all:true Id.Set.empty i in
+	let seen' =
+	  Id.Set.fold (fun id acc ->
+	    if Id.Set.mem id acc then raise Seen
+	    else Id.Set.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
+let is_defined_variable env id = match lookup_named id env with
+| (_, None, _) -> false
+| (_, Some _, _) -> true
 
 let abstract_args gl generalize_vars dep id defined f args =
   let sigma = project gl in
@@ -2397,13 +3191,13 @@ let abstract_args gl generalize_vars dep id defined f args =
   let dep = dep || dependent (mkVar id) concl in
   let avoid = ref [] in
   let get_id name =
-    let id = fresh_id !avoid (match name with Name n -> n | Anonymous -> id_of_string "gen_x") gl in
+    let id = fresh_id !avoid (match name with Name n -> n | Anonymous -> Id.of_string "gen_x") gl in
       avoid := id :: !avoid; id
   in
     (* Build application generalized w.r.t. the argument plus the necessary eqs.
        From env |- c : forall G, T and args : G we build
        (T[G'], G' : ctx, env ; G' |- args' : G, eqs := G'_i = G_i, refls : G' = G, vars to generalize)
-       
+
        eqs are not lifted w.r.t. each other yet. (* will be needed when going to dependent indexes *)
     *)
   let aux (prod, ctx, ctxenv, c, args, eqs, refls, nongenvars, vars, env) arg =
@@ -2412,15 +3206,14 @@ let abstract_args gl generalize_vars dep id defined f args =
 	List.hd rel, c
     in
     let argty = pf_type_of gl arg in
-    let argty = refresh_universes_strict argty in 
-    let ty = refresh_universes_strict ty in
+    let ty = (* refresh_universes_strict *) ty in
     let lenctx = List.length ctx in
     let liftargty = lift lenctx argty in
     let leq = constr_cmp Reduction.CUMUL liftargty ty in
       match kind_of_term arg with
-      | Var id when not (is_defined_variable env id) && leq && not (Idset.mem id nongenvars) ->
+      | Var id when not (is_defined_variable env id) && leq && not (Id.Set.mem id nongenvars) ->
       	  (subst1 arg arity, ctx, ctxenv, mkApp (c, [|arg|]), args, eqs, refls,
-      	  Idset.add id nongenvars, Idset.remove id vars, env)
+      	  Id.Set.add id nongenvars, Id.Set.remove id vars, env)
       | _ ->
 	  let name = get_id name in
 	  let decl = (Name name, None, ty) in
@@ -2437,28 +3230,28 @@ let abstract_args gl generalize_vars dep id defined f args =
 	  let eqs = eq :: lift_list eqs in
 	  let refls = refl :: refls in
 	  let argvars = ids_of_constr vars arg in
-	    (arity, ctx, push_rel decl ctxenv, c', args, eqs, refls, 
-	    nongenvars, Idset.union argvars vars, env)
-  in 
+	    (arity, ctx, push_rel decl ctxenv, c', args, eqs, refls,
+	    nongenvars, Id.Set.union argvars vars, env)
+  in
   let f', args' = decompose_indapp f args in
   let dogen, f', args' =
-    let parvars = ids_of_constr ~all:true Idset.empty f' in
+    let parvars = ids_of_constr ~all:true Id.Set.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
+	match Array.findi (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
+	    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',[],[],[],Idset.empty,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',[],[],[],Id.Set.empty,Id.Set.empty,env) args'
       in
       let args, refls = List.rev args, List.rev refls in
-      let vars = 
+      let vars =
 	if generalize_vars then
-	  let nogen = Idset.add id nogen in
+	  let nogen = Id.Set.add id nogen in
 	    hyps_of_vars (pf_env gl) (pf_hyps gl) nogen vars
 	else []
       in
@@ -2466,38 +3259,41 @@ let abstract_args gl generalize_vars dep id defined f args =
 	Some (make_abstract_generalize gl id concl dep ctx body c' eqs args refls,
 	     dep, succ (List.length ctx), vars)
     else None
-      
-let abstract_generalize ?(generalize_vars=true) ?(force_dep=false) id gl =
-  Coqlib.check_required_library ["Coq";"Logic";"JMeq"];
-  let f, args, def, id, oldid = 
-    let oldid = pf_get_new_id id gl in
-    let (_, b, t) = pf_get_hyp gl id in
+
+let abstract_generalize ?(generalize_vars=true) ?(force_dep=false) id =
+  Proofview.Goal.nf_enter begin fun gl ->
+  Coqlib.check_required_library Coqlib.jmeq_module_name;
+  let (f, args, def, id, oldid) =
+    let oldid = Tacmach.New.pf_get_new_id id gl in
+    let (_, b, t) = Tacmach.New.pf_get_hyp id gl in
       match b with
       | None -> let f, args = decompose_app t in
-		  f, args, false, id, oldid
-      | Some t -> 
+	        (f, args, false, id, oldid)
+      | Some t ->
 	  let f, args = decompose_app t in
-	    f, args, true, id, oldid
+	  (f, args, true, id, oldid)
   in
-  if args = [] then tclIDTAC gl
-  else 
+  if List.is_empty args then Proofview.tclUNIT ()
+  else
     let args = Array.of_list args in
-    let newc = abstract_args gl generalize_vars force_dep id def f args in
+    let newc = Tacmach.New.of_old (fun gl -> abstract_args gl generalize_vars force_dep id def f args) gl in
       match newc with
-      | None -> tclIDTAC gl
-      | Some (newc, dep, n, vars) -> 
+      | None -> Proofview.tclUNIT ()
+      | Some (newc, dep, n, vars) ->
 	  let tac =
 	    if dep then
-	      tclTHENLIST [refine newc; rename_hyp [(id, oldid)]; tclDO n intro; 
-			   generalize_dep ~with_let:true (mkVar oldid)]	      
+	      Tacticals.New.tclTHENLIST [Proofview.V82.tactic (refine newc); rename_hyp [(id, oldid)]; Tacticals.New.tclDO n intro;
+			   Proofview.V82.tactic (generalize_dep ~with_let:true (mkVar oldid))]
 	    else
-	      tclTHENLIST [refine newc; clear [id]; tclDO n intro]
-	  in 
-	    if vars = [] then tac gl
-	    else tclTHEN tac 
-	      (fun gl -> tclFIRST [revert vars ;
-				   tclMAP (fun id -> 
-				     tclTRY (generalize_dep ~with_let:true (mkVar id))) vars] gl) gl
+	      Tacticals.New.tclTHENLIST [Proofview.V82.tactic (refine newc); Proofview.V82.tactic (clear [id]); Tacticals.New.tclDO n intro]
+	  in
+	    if List.is_empty vars then tac
+	    else Tacticals.New.tclTHEN tac
+              (Tacticals.New.tclFIRST
+                [revert vars ;
+		 Proofview.V82.tactic (fun gl -> tclMAP (fun id ->
+				     tclTRY (generalize_dep ~with_let:true (mkVar id))) vars gl)])
+  end
 
 let rec compare_upto_variables x y =
   if (isVar x || isRel x) && (isVar y || isRel y) then true
@@ -2507,34 +3303,34 @@ let specialize_eqs id gl =
   let env = pf_env gl in
   let ty = pf_get_hyp_typ gl id in
   let evars = ref (project gl) in
-  let unif env evars c1 c2 = 
-    compare_upto_variables c1 c2 && Evarconv.e_conv env evars c1 c2 
+  let unif env evars c1 c2 =
+    compare_upto_variables c1 c2 && Evarconv.e_conv env evars c1 c2
   in
   let rec aux in_eqs ctx acc ty =
     match kind_of_term ty with
-    | Prod (na, t, b) -> 
+    | Prod (na, t, b) ->
 	(match kind_of_term t with
-	| App (eq, [| eqty; x; y |]) when eq_constr eq (Lazy.force coq_eq) ->
+	| App (eq, [| eqty; x; y |]) when Term.eq_constr (Lazy.force coq_eq) eq ->
 	    let c = if noccur_between 1 (List.length ctx) x then y else x in
 	    let pt = mkApp (Lazy.force coq_eq, [| eqty; c; c |]) in
 	    let p = mkApp (Lazy.force coq_eq_refl, [| eqty; c |]) in
 	      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 eq_constr heq (Lazy.force coq_heq) ->
+	| App (heq, [| eqty; x; eqty'; y |]) when Term.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
 	      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
-	| _ -> 
+	| _ ->
 	    if in_eqs then acc, in_eqs, ctx, ty
-	    else 
-	      let e = e_new_evar evars (push_rel_context ctx env) t in
+	    else
+	      let e = e_new_evar (push_rel_context ctx env) evars t in
 		aux false ((na, Some e, t) :: ctx) (mkApp (lift 1 acc, [| mkRel 1 |])) b)
     | 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) ->
@@ -2544,38 +3340,27 @@ let specialize_eqs id gl =
   in
   let ty' = it_mkProd_or_LetIn ty ctx'' in
   let acc' = it_mkLambda_or_LetIn acc ctx'' in
-  let ty' = Tacred.whd_simpl env !evars ty' 
+  let ty' = Tacred.whd_simpl env !evars ty'
   and acc' = Tacred.whd_simpl env !evars acc' in
   let ty' = Evarutil.nf_evar !evars ty' in
     if worked then
       tclTHENFIRST (Tacmach.internal_cut true id ty')
-	(exact_no_check (refresh_universes_strict acc')) gl
+	(exact_no_check ((* refresh_universes_strict *) acc')) gl
     else tclFAIL 0 (str "Nothing to do in hypothesis " ++ pr_id id) gl
-      
+
 
 let specialize_eqs id gl =
   if
     (try ignore(clear [id] gl); false
      with e when Errors.noncritical e -> true)
   then
-    tclFAIL 0 (str "Specialization not allowed on dependent hypotheses") gl 
+    tclFAIL 0 (str "Specialization not allowed on dependent hypotheses") gl
   else specialize_eqs id gl
 
 let occur_rel n c =
   let res = not (noccurn n c) in
   res
 
-(* 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 =
-    if n<=0 then acc,l
-    else match l with
-      | [] -> assert false
-      | e::l' -> cut_list_aux (acc@[e]) (n-1) l' in
-  let res = cut_list_aux [] n l in
-  res
-
-
 (* This function splits the products of the induction scheme [elimt] into four
    parts:
    - branches, easily detectable (they are not referred by rels in the subterm)
@@ -2607,39 +3392,20 @@ let decompose_paramspred_branch_args elimt =
      type (See for example Empty_set_ind, as False would actually be ok). Then
      we must find the predicate of the conclusion to separate params_pred from
      args. We suppose there is only one predicate here. *)
-  if List.length acc2 <> 0 then acc1, acc2 , acc3, ccl
-  else
+  match acc2 with
+  | [] ->
     let hyps,ccl = decompose_prod_assum elimt in
     let hd_ccl_pred,_ = decompose_app ccl in
-    match kind_of_term hd_ccl_pred with
-      | Rel i  -> let acc3,acc1 = cut_list (i-1) hyps in acc1 , [] , acc3 , ccl
+    begin match kind_of_term hd_ccl_pred with
+      | Rel i  -> let acc3,acc1 = List.chop (i-1) hyps in acc1 , [] , acc3 , ccl
       | _ -> error_ind_scheme ""
+    end
+  | _ -> acc1, acc2 , acc3, ccl
 
 
 let exchange_hd_app subst_hd t =
   let hd,args= decompose_app t in mkApp (subst_hd,Array.of_list args)
 
-
-
-(* [rebuild_elimtype_from_scheme scheme] rebuilds the type of an
-   eliminator from its [scheme_info]. The idea is to build variants of
-   eliminator by modifying their scheme_info, then rebuild the
-   eliminator type, then prove it (with tactics). *)
-let rebuild_elimtype_from_scheme (scheme:elim_scheme): types =
-  let hiconcl =
-    match scheme.indarg with
-      | None -> scheme.concl
-      | Some x -> mkProd_or_LetIn x scheme.concl in
-  let xihiconcl = it_mkProd_or_LetIn hiconcl scheme.args in
-  let brconcl = it_mkProd_or_LetIn xihiconcl scheme.branches in
-  let predconcl = it_mkProd_or_LetIn brconcl scheme.predicates in
-  let paramconcl = it_mkProd_or_LetIn predconcl scheme.params in
-  paramconcl
-
-
-exception NoLastArg
-exception NoLastArgCcl
-
 (* Builds an elim_scheme from its type and calling form (const+binding). We
    first separate branches.  We obtain branches, hyps before (params + preds),
    hyps after (args <+ indarg if present>) and conclusion.  Then we proceed as
@@ -2660,10 +3426,10 @@ let compute_elim_sig ?elimc elimt =
   let params_preds,branches,args_indargs,conclusion =
     decompose_paramspred_branch_args elimt in
 
-  let ccl = exchange_hd_app (mkVar (id_of_string "__QI_DUMMY__")) conclusion in
+  let ccl = exchange_hd_app (mkVar (Id.of_string "__QI_DUMMY__")) conclusion in
   let concl_with_args = it_mkProd_or_LetIn ccl args_indargs in
-  let nparams = Intset.cardinal (free_rels concl_with_args) in
-  let preds,params = cut_list (List.length params_preds - nparams) params_preds in
+  let nparams = Int.Set.cardinal (free_rels concl_with_args) in
+  let preds,params = List.chop (List.length params_preds - nparams) params_preds in
 
   (* A first approximation, further analysis will tweak it *)
   let res = ref { empty_scheme with
@@ -2686,7 +3452,7 @@ let compute_elim_sig ?elimc elimt =
       raise Exit
     end;
     (* 2- If no args_indargs (=!res.nargs at this point) then no indarg *)
-    if !res.nargs=0 then raise Exit;
+    if Int.equal !res.nargs 0 then raise Exit;
     (* 3- Look at last arg: is it the indarg? *)
     ignore (
       match List.hd args_indargs with
@@ -2701,9 +3467,9 @@ let compute_elim_sig ?elimc elimt =
 		| Construct _ -> true
 		| _ -> false in
 	    let hi_args_enough = (* hi a le bon nbre d'arguments *)
-	      List.length hi_args = List.length params + !res.nargs -1 in
+	      Int.equal (List.length hi_args) (List.length params + !res.nargs -1) in
 	    (* FIXME: Ces deux tests ne sont pas suffisants. *)
-	    if not (hi_is_ind & hi_args_enough) then raise Exit (* No indarg *)
+	    if not (hi_is_ind && hi_args_enough) then raise Exit (* No indarg *)
 	    else (* Last arg is the indarg *)
 	      res := {!res with
 		indarg = Some (List.hd !res.args);
@@ -2712,7 +3478,7 @@ let compute_elim_sig ?elimc elimt =
 	      };
 	    raise Exit);
     raise Exit(* exit anyway *)
-  with Exit -> (* Ending by computing indrev: *)
+  with Exit -> (* Ending by computing indref: *)
     match !res.indarg with
       | None -> !res (* No indref *)
       | Some ( _,Some _,_) -> error_ind_scheme ""
@@ -2720,7 +3486,7 @@ let compute_elim_sig ?elimc elimt =
 	  let indhd,indargs = decompose_app ind in
 	  try {!res with indref = Some (global_of_constr indhd) }
 	  with e when Errors.noncritical e ->
-            error "Cannot find the inductive type of the inductive scheme.";;
+            error "Cannot find the inductive type of the inductive scheme."
 
 let compute_scheme_signature scheme names_info ind_type_guess =
   let f,l = decompose_app scheme.concl in
@@ -2730,26 +3496,26 @@ let compute_scheme_signature scheme names_info ind_type_guess =
       | 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
+	  let cond hd = Term.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 cond hd = Term.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 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)
+	      List.equal Term.eq_constr
+		(List.lastn scheme.nargs indargs)
 		(extended_rel_list 0 scheme.args) in
-	    if not (ccl_arg_ok & ind_is_ok) then
+	    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
+      | Rel q when n < q && q <= n+scheme.npredicates -> IndArg
       | _ when cond hd -> RecArg
       | _ -> OtherArg
   in
@@ -2759,7 +3525,7 @@ let compute_scheme_signature scheme names_info ind_type_guess =
 	(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 -> []
+      | _ when is_pred p c == IndArg -> []
       | _ -> raise Exit
   in
   let rec find_branches p lbrch =
@@ -2768,12 +3534,12 @@ let compute_scheme_signature scheme names_info ind_type_guess =
 	(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
+	     (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))
+	       (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")
@@ -2789,88 +3555,80 @@ let compute_scheme_signature scheme names_info ind_type_guess =
    extra final argument of the form (f x y ...) in the conclusion. In
    the non standard case, naming of generated hypos is slightly
    different. *)
-let compute_elim_signature ((elimc,elimt),ind_type_guess) names_info =
+let compute_elim_signature (evd,(elimc,elimt),ind_type_guess) names_info =
   let scheme = compute_elim_sig ~elimc:elimc elimt in
-  compute_scheme_signature scheme names_info ind_type_guess, scheme
-
-let guess_elim isrec hyp0 gl =
-  let tmptyp0 =	pf_get_hyp_typ gl hyp0 in
-  let mind,_ = pf_reduce_to_quantified_ind gl tmptyp0 in
-  let s = elimination_sort_of_goal gl in
-  let elimc =
-    if isrec then lookup_eliminator mind s
+    evd, (compute_scheme_signature scheme names_info ind_type_guess, scheme)
+
+let guess_elim isrec dep s hyp0 gl =
+  let tmptyp0 =	Tacmach.New.pf_get_hyp_typ hyp0 gl in
+  let mind,_ = Tacmach.New.pf_reduce_to_quantified_ind gl tmptyp0 in
+  let evd, elimc =
+    if isrec && not (is_nonrec (fst mind)) then find_ind_eliminator (fst mind) s gl
     else
-      if use_dependent_propositions_elimination () &&
-	dependent_no_evar (mkVar hyp0) (pf_concl gl)
+      if use_dependent_propositions_elimination () && dep
       then
-	pf_apply build_case_analysis_scheme gl mind true s
+	Tacmach.New.pf_apply build_case_analysis_scheme gl mind true s
       else
-	pf_apply build_case_analysis_scheme_default gl mind s in
-  let elimt = pf_type_of gl elimc in
-  ((elimc, NoBindings), elimt), mkInd mind
+	Tacmach.New.pf_apply build_case_analysis_scheme_default gl mind s in
+  let elimt = Tacmach.New.pf_type_of gl elimc in
+    evd, ((elimc, NoBindings), elimt), mkIndU mind
 
 let given_elim hyp0 (elimc,lbind as e) gl =
-  let tmptyp0 = pf_get_hyp_typ gl hyp0 in
+  let tmptyp0 = Tacmach.New.pf_get_hyp_typ hyp0 gl in
   let ind_type_guess,_ = decompose_app ((strip_prod tmptyp0)) in
-  (e, pf_type_of gl elimc), ind_type_guess
-
-let find_elim isrec elim hyp0 gl =
-  match elim with
-    | None -> guess_elim isrec hyp0 gl
-    | Some e -> given_elim hyp0 e gl
+  Proofview.Goal.sigma gl, (e, Tacmach.New.pf_type_of gl elimc), ind_type_guess
 
 type scheme_signature =
-    (identifier list * (elim_arg_kind * bool * identifier) list) array
+    (Id.t list * (elim_arg_kind * bool * Id.t) list) array
 
 type eliminator_source =
   | ElimUsing of (eliminator * types) * scheme_signature
-  | ElimOver of bool * identifier
+  | ElimOver of bool * Id.t
 
 let find_induction_type isrec elim hyp0 gl =
   let scheme,elim =
     match elim with
     | None ->
-	let (elimc,elimt),_ = guess_elim isrec hyp0 gl in
+       let sort = Tacticals.New.elimination_sort_of_goal gl in
+       let _, (elimc,elimt),_ = 
+	 guess_elim isrec (* dummy: *) true sort hyp0 gl in
 	let scheme = compute_elim_sig ~elimc elimt in
 	(* We drop the scheme waiting to know if it is dependent *)
 	scheme, ElimOver (isrec,hyp0)
     | Some e ->
-	let (elimc,elimt),ind_guess = given_elim hyp0 e gl in
+	let evd, (elimc,elimt),ind_guess = given_elim hyp0 e gl in
 	let scheme = compute_elim_sig ~elimc elimt in
-	if scheme.indarg = None then error "Cannot find induction type";
+	if Option.is_empty scheme.indarg then error "Cannot find induction type";
 	let indsign = compute_scheme_signature scheme hyp0 ind_guess in
-	let elim = ({elimindex = Some(-1); elimbody = elimc},elimt) in
+	let elim = ({elimindex = Some(-1); elimbody = elimc; elimrename = None},elimt) in
 	scheme, ElimUsing (elim,indsign) in
-  Option.get scheme.indref,scheme.nparams, elim
+  (Option.get scheme.indref,scheme.nparams, elim)
 
-let find_elim_signature isrec elim hyp0 gl =
-  compute_elim_signature (find_elim isrec elim hyp0 gl) hyp0
+let get_elim_signature elim hyp0 gl =
+  compute_elim_signature (given_elim hyp0 elim gl) hyp0
 
-let is_functional_induction elim gl =
-  match elim with
-  | Some elimc ->
-      let scheme = compute_elim_sig ~elimc (pf_type_of gl (fst elimc)) in
-      (* The test is not safe: with non-functional induction on non-standard
-         induction scheme, this may fail *)
-      scheme.indarg = None
-  | None ->
-      false
+let is_functional_induction elimc gl =
+  let scheme = compute_elim_sig ~elimc (Tacmach.New.pf_type_of gl (fst elimc)) in
+  (* The test is not safe: with non-functional induction on non-standard
+     induction scheme, this may fail *)
+  Option.is_empty scheme.indarg
 
 (* Wait the last moment to guess the eliminator so as to know if we
    need a dependent one or not *)
 
-let get_eliminator elim gl = match elim with
+let get_eliminator elim dep s gl = match elim with
   | ElimUsing (elim,indsign) ->
-      (* bugged, should be computed *) true, elim, indsign
+      Proofview.Goal.sigma gl, (* bugged, should be computed *) true, elim, indsign
   | ElimOver (isrec,id) ->
-      let (elimc,elimt),_ as elims = guess_elim isrec id gl in
-      isrec, ({elimindex = None; elimbody = elimc}, elimt),
-      fst (compute_elim_signature elims id)
+      let evd, (elimc,elimt),_ as elims = guess_elim isrec dep s id gl in
+      let _, (l, s) = compute_elim_signature elims id in
+      let branchlengthes = List.map (fun (_,b,c) -> assert (b=None); pi1 (decompose_prod_letin c)) (List.rev s.branches) in
+      evd, isrec, ({elimindex = None; elimbody = elimc; elimrename = Some (isrec,Array.of_list branchlengthes)}, elimt), l
 
 (* Instantiate all meta variables of elimclause using lid, some elts
    of lid are parameters (first ones), the other are
    arguments. Returns the clause obtained.  *)
-let recolle_clenv nparams lid elimclause gl =
+let recolle_clenv i params args elimclause gl =
   let _,arr = destApp elimclause.templval.rebus in
   let lindmv =
     Array.map
@@ -2880,18 +3638,14 @@ let recolle_clenv nparams lid elimclause gl =
 	  | _  -> errorlabstrm "elimination_clause"
               (str "The type of the elimination clause is not well-formed."))
       arr in
-  let nmv = Array.length lindmv in
-  let lidparams,lidargs = cut_list nparams lid in
-  let nidargs = List.length lidargs in
+  let k = match i with -1 -> Array.length lindmv - List.length args | _ -> i in
   (* parameters correspond to first elts of lid. *)
   let clauses_params =
-    list_map_i (fun i id -> mkVar id , pf_get_hyp_typ gl id , lindmv.(i))
-      0 lidparams in
-  (* arguments correspond to last elts of lid. *)
+    List.map_i (fun i id -> mkVar id , pf_get_hyp_typ gl id , lindmv.(i))
+      0 params in
   let clauses_args =
-    list_map_i
-      (fun i id -> mkVar id , pf_get_hyp_typ gl id , lindmv.(nmv-nidargs+i))
-      0 lidargs in
+    List.map_i (fun i id -> mkVar id , pf_get_hyp_typ gl id , lindmv.(k+i))
+      0 args in
   let clauses = clauses_params@clauses_args in
   (* iteration of clenv_fchain with all infos we have. *)
   List.fold_right
@@ -2910,306 +3664,411 @@ let recolle_clenv nparams lid elimclause gl =
    (elimc ?i ?j ?k...?l). This solves partly meta variables (and may
     produce new ones). Then refine with the resulting term with holes.
 *)
-let induction_tac_felim with_evars indvars nparams elim gl =
-  let {elimbody=(elimc,lbindelimc)},elimt = elim in
+let induction_tac with_evars params indvars elim gl =
+  let ({elimindex=i;elimbody=(elimc,lbindelimc);elimrename=rename},elimt) = elim in
+  let i = match i with None -> index_of_ind_arg elimt | Some i -> i in
   (* elimclause contains this: (elimc ?i ?j ?k...?l) *)
+  let elimc = mkCast (elimc, DEFAULTcast, elimt) in
   let elimclause =
-    make_clenv_binding gl (mkCast (elimc,DEFAULTcast, elimt),elimt) lbindelimc in
+    pf_apply make_clenv_binding gl (elimc,elimt) lbindelimc in
   (* elimclause' is built from elimclause by instanciating all args and params. *)
-  let elimclause' = recolle_clenv nparams indvars elimclause gl in
+  let elimclause' = recolle_clenv i params indvars elimclause gl in
   (* one last resolution (useless?) *)
-  let resolved = clenv_unique_resolver ~flags:elim_flags elimclause' gl in
-  clenv_refine with_evars resolved gl
+  let resolved = clenv_unique_resolver ~flags:(elim_flags ()) elimclause' gl in
+  Proofview.V82.of_tactic (enforce_prop_bound_names rename (Clenvtac.clenv_refine with_evars resolved)) gl
 
-(* Apply induction "in place" replacing the hypothesis on which
+(* Apply induction "in place" taking into account dependent
+   hypotheses from the context, replacing the main hypothesis on which
    induction applies with the induction hypotheses *)
 
-let apply_induction_with_discharge induct_tac elim indhyps destopt avoid names tac gl =
-  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)
-       (tclMAP (fun id -> tclTRY (expand_hyp id)) (List.rev indhyps)))
-    (array_map2 (induct_discharge destopt avoid tac) indsign names) gl
+let apply_induction_in_context hyp0 inhyps elim indvars names induct_tac =
+  Proofview.Goal.enter begin fun gl ->
+    let env = Proofview.Goal.env gl in
+    let sigma = Proofview.Goal.sigma gl in
+    let concl = Tacmach.New.pf_nf_concl gl in
+    let statuslists,lhyp0,toclear,deps,avoid,dep = cook_sign hyp0 inhyps indvars env in
+    let dep = dep || Option.cata (fun id -> occur_var env id concl) false hyp0 in
+    let tmpcl = it_mkNamedProd_or_LetIn concl deps in
+    let s = Retyping.get_sort_family_of env sigma tmpcl in
+    let deps_cstr =
+      List.fold_left
+        (fun a (id,b,_) -> if Option.is_empty b then (mkVar id)::a else a) [] deps in
+    let (sigma, isrec, elim, indsign) = get_eliminator elim dep s (Proofview.Goal.assume gl) in
+    let names = compute_induction_names (Array.length indsign) names in
+    (if isrec then Tacticals.New.tclTHENFIRSTn else Tacticals.New.tclTHENLASTn)
+      (Tacticals.New.tclTHENLIST [
+        Proofview.Unsafe.tclEVARS sigma;
+        (* Generalize dependent hyps (but not args) *)
+        if deps = [] then Proofview.tclUNIT () else Proofview.V82.tactic (apply_type tmpcl deps_cstr);
+        (* side-conditions in elim (resp case) schemes come last (resp first) *)
+        induct_tac elim;
+        Proofview.V82.tactic (tclMAP expand_hyp toclear)
+      ])
+      (Array.map2
+         (induct_discharge lhyp0 avoid (re_intro_dependent_hypotheses statuslists))
+         indsign names)
+  end
 
-(* Apply induction "in place" taking into account dependent
-   hypotheses from the context *)
+let induction_with_atomization_of_ind_arg isrec with_evars elim names hyp0 inhyps =
+  Proofview.Goal.enter begin fun gl ->
+  let elim_info = find_induction_type isrec elim hyp0 (Proofview.Goal.assume gl) in
+  atomize_param_of_ind_then elim_info hyp0 (fun indvars ->
+    apply_induction_in_context (Some hyp0) inhyps (pi3 elim_info) indvars names
+      (fun elim -> Proofview.V82.tactic (induction_tac with_evars [] [hyp0] elim)))
+  end
 
-let apply_induction_in_context hyp0 elim indvars names induct_tac gl =
-  let env = pf_env gl in
-  let statuslists,lhyp0,indhyps,deps = cook_sign hyp0 indvars env in
-  let deps = List.map (on_pi3 refresh_universes_strict) deps in
-  let tmpcl = it_mkNamedProd_or_LetIn (pf_concl gl) deps in
-  let dephyps = List.map (fun (id,_,_) -> id) deps in
-  let deps_cstr =
-    List.fold_left
-      (fun a (id,b,_) -> if b = None then (mkVar id)::a else a) [] deps in
-  tclTHENLIST
-    [
-      (* Generalize dependent hyps (but not args) *)
-      if deps = [] then tclIDTAC else apply_type tmpcl deps_cstr;
-      (* clear dependent hyps *)
-      thin dephyps;
-      (* side-conditions in elim (resp case) schemes come last (resp first) *)
-      apply_induction_with_discharge
-	induct_tac elim (List.rev indhyps) lhyp0 (List.rev dephyps) names
-        (re_intro_dependent_hypotheses statuslists)
-    ]
-    gl
+let msg_not_right_number_induction_arguments scheme =
+  str"Not the right number of induction arguments (expected " ++
+  pr_enum (fun x -> x) [
+    if scheme.farg_in_concl then str "the function name" else mt();
+    if scheme.nparams != 0 then int scheme.nparams ++ str (String.plural scheme.nparams " parameter") else mt ();
+    if scheme.nargs != 0 then int scheme.nargs ++ str (String.plural scheme.nargs " argument") else mt ()] ++ str ")."
 
-(* Induction with several induction arguments, main differences with
-   induction_from_context is that there is no main induction argument,
-   so we choose one to be the positioning reference. On the other hand,
-   all args and params must be given, so we help a bit the unifier by
-   making the "pattern" by hand before calling induction_tac_felim
-   FIXME: REUNIF AVEC induction_tac_felim? *)
-let induction_from_context_l with_evars elim_info lid names gl =
-  let indsign,scheme = elim_info in
-  (* number of all args, counting farg and indarg if present. *)
-  let nargs_indarg_farg = scheme.nargs
-    + (if scheme.farg_in_concl then 1 else 0)
-    + (if scheme.indarg <> None then 1 else 0) in
-  (* Number of given induction args must be exact. *)
-  if List.length lid <> nargs_indarg_farg + scheme.nparams then
-      error "Not the right number of arguments given to induction scheme.";
-  (* hyp0 is used for re-introducing hyps at the right place afterward.
-     We chose the first element of the list of variables on which to
-     induct. It is probably the first of them appearing in the
-     context. *)
-  let hyp0,indvars,lid_params =
-    match lid with
-      | []  -> anomaly "induction_from_context_l"
-      | e::l ->
-	  let nargs_without_first = nargs_indarg_farg - 1 in
-	  let ivs,lp = cut_list nargs_without_first l in
-	  e, ivs, lp in
+(* Induction on a list of induction arguments. Analyze the elim
+   scheme (which is mandatory for multiple ind args), check that all
+   parameters and arguments are given (mandatory too).
+   Main differences with induction_from_context is that there is no
+   main induction argument. On the other hand, all args and params
+   must be given, so we help a bit the unifier by making the "pattern"
+   by hand before calling induction_tac *)
+let induction_without_atomization isrec with_evars elim names lid =
+  Proofview.Goal.nf_enter begin fun gl ->
+  let sigma, (indsign,scheme) = get_elim_signature elim (List.hd lid) gl in
+  let nargs_indarg_farg =
+    scheme.nargs + (if scheme.farg_in_concl then 1 else 0) in
+  if not (Int.equal (List.length lid) (scheme.nparams + nargs_indarg_farg))
+  then
+    Tacticals.New.tclZEROMSG (msg_not_right_number_induction_arguments scheme)
+  else
+  let indvars,lid_params = List.chop nargs_indarg_farg lid in
   (* terms to patternify we must patternify indarg or farg if present in concl *)
-  let lid_in_pattern =
-    if scheme.indarg <> None & not scheme.indarg_in_concl then List.rev indvars
-    else List.rev (hyp0::indvars) in
-  let lidcstr = List.map (fun x -> mkVar x) lid_in_pattern in
-  let realindvars = (* hyp0 is a real induction arg if it is not the
-		       farg in the conclusion of the induction scheme *)
-    List.rev ((if scheme.farg_in_concl then indvars else hyp0::indvars) @ lid_params) in
-  let induct_tac elim = tclTHENLIST [
+  let realindvars = List.rev (if scheme.farg_in_concl then List.tl indvars else indvars) in
+  let lidcstr = List.map mkVar (List.rev indvars) in
+  let params = List.rev lid_params in
+  let indvars =
+    (* Temporary hack for compatibility, while waiting for better
+       analysis of the form of induction schemes: a scheme like
+       gt_wf_rec was taken as a functional scheme with no parameters,
+       but by chance, because of the addition of at least hyp0 for
+       cook_sign, it behaved as if there was a real induction arg. *)
+    if indvars = [] then [List.hd lid_params] else indvars in
+  let induct_tac elim = Proofview.V82.tactic (tclTHENLIST [
     (* pattern to make the predicate appear. *)
     reduce (Pattern (List.map inj_with_occurrences lidcstr)) onConcl;
     (* Induction by "refine (indscheme ?i ?j ?k...)" + resolution of all
        possible holes using arguments given by the user (but the
        functional one). *)
     (* FIXME: Tester ca avec un principe dependant et non-dependant *)
-    induction_tac_felim with_evars realindvars scheme.nparams elim
-  ] in
-  let elim = ElimUsing (({elimindex = Some scheme.index; elimbody = Option.get scheme.elimc}, scheme.elimt), indsign) in
-  apply_induction_in_context
-    None elim (hyp0::indvars) names induct_tac gl
-
-(* Unification between ((elimc:elimt) ?i ?j ?k ?l ... ?m) and the
-   hypothesis on which the induction is made *)
-let induction_tac with_evars elim (varname,lbind) typ gl =
-  let ({elimindex=i;elimbody=(elimc,lbindelimc)},elimt) = elim in
-  let indclause = make_clenv_binding gl (mkVar varname,typ) lbind  in
-  let i = match i with None -> index_of_ind_arg elimt | Some i -> i in
-  let elimclause =
-    make_clenv_binding gl
-      (mkCast (elimc,DEFAULTcast,elimt),elimt) lbindelimc in
-  elimination_clause_scheme with_evars i elimclause indclause gl
-
-let induction_from_context isrec with_evars (indref,nparams,elim) (hyp0,lbind) names
-  inhyps gl =
-  let tmptyp0 =	pf_get_hyp_typ gl hyp0 in
-  let typ0 = pf_apply reduce_to_quantified_ref gl indref tmptyp0 in
-  let indvars = find_atomic_param_of_ind nparams ((strip_prod typ0)) in
-  let induct_tac elim = tclTHENLIST [
-    induction_tac with_evars elim (hyp0,lbind) typ0;
-    tclTRY (unfold_body hyp0);
-    thin [hyp0]
-  ] in
-  apply_induction_in_context
-    (Some (hyp0,inhyps)) elim indvars names induct_tac gl
-
-let induction_with_atomization_of_ind_arg isrec with_evars elim names (hyp0,lbind) inhyps gl =
-  let elim_info = find_induction_type isrec elim hyp0 gl in
-  tclTHEN
-    (atomize_param_of_ind elim_info hyp0)
-    (induction_from_context isrec with_evars elim_info
-      (hyp0,lbind) names inhyps) gl
-
-(* Induction on a list of induction arguments. Analyse the elim
-   scheme (which is mandatory for multiple ind args), check that all
-   parameters and arguments are given (mandatory too). *)
-let induction_without_atomization isrec with_evars elim names lid gl =
-  let (indsign,scheme as elim_info) =
-    find_elim_signature isrec elim (List.hd lid) gl in
-  let awaited_nargs =
-    scheme.nparams + scheme.nargs
-    + (if scheme.farg_in_concl then 1 else 0)
-    + (if scheme.indarg <> None then 1 else 0)
-  in
-  let nlid = List.length lid in
-  if nlid <> awaited_nargs
-  then error "Not the right number of induction arguments."
-  else induction_from_context_l with_evars elim_info lid names gl
-
-let has_selected_occurrences = function
-  | None -> false
-  | Some cls ->
-      cls.concl_occs <> all_occurrences_expr ||
-	cls.onhyps <> None && List.exists (fun ((occs,_),hl) ->
-          occs <> all_occurrences_expr || hl <> InHyp) (Option.get cls.onhyps)
+    induction_tac with_evars params realindvars elim
+  ]) in
+  let elim = ElimUsing (({elimindex = Some (-1); elimbody = Option.get scheme.elimc; elimrename = None}, scheme.elimt), indsign) in
+  apply_induction_in_context None [] elim indvars names induct_tac
+  end
 
 (* assume that no occurrences are selected *)
 let clear_unselected_context id inhyps cls gl =
-  match cls with
+  if occur_var (pf_env gl) id (pf_concl gl) &&
+    cls.concl_occs == NoOccurrences
+  then errorlabstrm ""
+    (str "Conclusion must be mentioned: it depends on " ++ pr_id id
+     ++ str ".");
+  match cls.onhyps with
+  | Some hyps ->
+      let to_erase (id',_,_ as d) =
+	if Id.List.mem id' inhyps then (* if selected, do not erase *) None
+	else
+	  (* erase if not selected and dependent on id or selected hyps *)
+	  let test id = occur_var_in_decl (pf_env gl) id d in
+	  if List.exists test (id::inhyps) then Some id' else None in
+      let ids = List.map_filter to_erase (pf_hyps gl) in
+      thin ids gl
   | None -> tclIDTAC gl
-  | Some cls ->
-      if occur_var (pf_env gl) id (pf_concl gl) &&
-	 cls.concl_occs = no_occurrences_expr
-      then errorlabstrm ""
-	    (str "Conclusion must be mentioned: it depends on " ++ pr_id id
-	     ++ str ".");
-      match cls.onhyps with
-      | Some hyps ->
-	  let to_erase (id',_,_ as d) =
-	    if List.mem id' inhyps then (* if selected, do not erase *) None
-	    else
-	      (* erase if not selected and dependent on id or selected hyps *)
-	      let test id = occur_var_in_decl (pf_env gl) id d in
-	      if List.exists test (id::inhyps) then Some id' else None in
-	  let ids = list_map_filter to_erase (pf_hyps gl) in
-	  thin ids gl
-      | None -> tclIDTAC gl
-
-let new_induct_gen isrec with_evars elim (eqname,names) (sigma,(c,lbind)) cls gl =
+
+let use_bindings env sigma elim (c,lbind) typ =
+  let typ =
+    if elim == None then
+      (* w/o an scheme, the term has to be applied at least until
+         obtaining an inductive type (even though the arity might be
+         known only by pattern-matching, as in the case of a term of
+         the form "nat_rect ?A ?o ?s n", with ?A to be inferred by
+         matching. *)
+      let sign,t = splay_prod env sigma typ in it_mkProd t sign
+    else
+      (* Otherwise, we exclude the case of an induction argument in an
+         explicitly functional type. Henceforth, we can complete the
+         pattern until it has as type an atomic type (even though this
+         atomic type can hide a functional type, for which the "using"
+         clause has a scheme). *)
+      typ in
+  let rec find_clause typ =
+    try
+      let indclause = make_clenv_binding env sigma (c,typ) lbind in
+      (* We lose the possibility of coercions in with-bindings *)
+      pose_all_metas_as_evars env indclause.evd (clenv_value indclause)
+    with e when catchable_exception e ->
+    try find_clause (try_red_product env sigma typ)
+    with Redelimination -> raise e in
+  find_clause typ
+
+let check_expected_type env sigma (elimc,bl) elimt =
+  (* Compute the expected template type of the term in case a using
+     clause is given *)
+  let sign,_ = splay_prod env sigma elimt in
+  let n = List.length sign in
+  if n == 0 then error "Scheme cannot be applied.";
+  let sigma,cl = make_evar_clause env sigma ~len:(n - 1) elimt in
+  let sigma = solve_evar_clause env sigma true cl bl in
+  let (_,u,_) = destProd cl.cl_concl in
+  fun t -> Evarconv.e_cumul env (ref sigma) t u
+
+let check_enough_applied env sigma elim =
+  (* A heuristic to decide whether the induction arg is enough applied *)
+  match elim with
+  | None ->
+      (* No eliminator given *)
+      fun u ->
+      let t,_ = decompose_app (whd_betadeltaiota env sigma u) in isInd t
+  | Some elimc ->
+      let elimt = typ_of env sigma (fst elimc) in
+      let scheme = compute_elim_sig ~elimc elimt in
+      match scheme.indref with
+      | None ->
+         (* in the absence of information, do not assume it may be
+            partially applied *)
+          fun _ -> true
+      | Some _ ->
+          (* Last argument is supposed to be the induction argument *)
+          check_expected_type env sigma elimc elimt
+
+let pose_induction_arg_then isrec with_evars (is_arg_pure_hyp,from_prefix) elim
+     id ((pending,(c0,lbind)),(eqname,names)) t0 inhyps cls tac =
+  Proofview.Goal.enter begin fun gl ->
+  let env = Proofview.Goal.env gl in
+  let sigma = Proofview.Goal.sigma gl in
+  let ccl = Proofview.Goal.raw_concl gl in
+  let store = Proofview.Goal.extra gl in
+  let check = check_enough_applied env sigma elim in
+  let (sigma',c) = use_bindings env sigma elim (c0,lbind) t0 in
+  let abs = AbstractPattern (from_prefix,check,Name id,(pending,c),cls,false) in
+  let (id,sign,_,lastlhyp,ccl,res) = make_abstraction env sigma' ccl abs in
+  match res with
+  | None ->
+      (* pattern not found *)
+      let with_eq = Option.map (fun eq -> (false,eq)) eqname in
+      (* we restart using bindings after having tried type-class
+         resolution etc. on the term given by the user *)
+      let flags = tactic_infer_flags (with_evars && (* do not give a success semantics to edestruct on an open term yet *) false) in
+      let (sigma,c0) = finish_evar_resolution ~flags env sigma (pending,c0) in
+      (if isrec then
+          (* Historically, induction has side conditions last *)
+          Tacticals.New.tclTHENFIRST
+       else
+          (* and destruct has side conditions first *)
+          Tacticals.New.tclTHENLAST)
+      (Tacticals.New.tclTHENLIST [
+        Proofview.Unsafe.tclEVARS sigma;
+        Proofview.Refine.refine ~unsafe:true (fun sigma ->
+          let (sigma,c) = use_bindings env sigma elim (c0,lbind) t0 in
+          let t = Retyping.get_type_of env sigma c in
+          mkletin_goal env sigma store with_eq false (id,lastlhyp,ccl,c) (Some t));
+        Proofview.(if with_evars then shelve_unifiable else guard_no_unifiable);
+        if is_arg_pure_hyp
+        then Tacticals.New.tclTRY (Proofview.V82.tactic (thin [destVar c0]))
+        else Proofview.tclUNIT ();
+        if isrec then Proofview.cycle (-1) else Proofview.tclUNIT ()
+      ])
+      tac
+
+  | Some (sigma',c) ->
+      (* pattern found *)
+      let with_eq = Option.map (fun eq -> (false,eq)) eqname in
+      (* TODO: if ind has predicate parameters, use JMeq instead of eq *)
+      let env = reset_with_named_context sign env in
+      Tacticals.New.tclTHENLIST [
+        Proofview.Unsafe.tclEVARS sigma';
+        Proofview.Refine.refine ~unsafe:true (fun sigma ->
+          mkletin_goal env sigma store with_eq true (id,lastlhyp,ccl,c) None);
+        tac
+      ]
+  end
+
+let has_generic_occurrences_but_goal cls id env ccl =
+  clause_with_generic_context_selection cls &&
+  (* TODO: whd_evar of goal *)
+  (cls.concl_occs != NoOccurrences || not (occur_var env id ccl))
+
+let induction_gen clear_flag isrec with_evars elim
+    ((_pending,(c,lbind)),(eqname,names) as arg) cls =
   let inhyps = match cls with
   | Some {onhyps=Some hyps} -> List.map (fun ((_,id),_) -> id) hyps
   | _ -> [] in
-  match kind_of_term c with
-    | Var id when not (mem_named_context id (Global.named_context()))
-	        & lbind = NoBindings & not with_evars & eqname = None
-                & not (has_selected_occurrences cls) ->
-	tclTHEN
-          (clear_unselected_context id inhyps cls)
-	  (induction_with_atomization_of_ind_arg
-	    isrec with_evars elim names (id,lbind) inhyps) gl
-    | _        ->
-	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
-          (* 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
+  Proofview.Goal.enter begin fun gl ->
+  let env = Proofview.Goal.env gl in
+  let sigma = Proofview.Goal.sigma gl in
+  let ccl = Proofview.Goal.raw_concl gl in
+  let cls = Option.default allHypsAndConcl cls in
+  let t = typ_of env sigma c in
+  let is_arg_pure_hyp =
+    isVar c && not (mem_named_context (destVar c) (Global.named_context()))
+    && lbind == NoBindings && not with_evars && Option.is_empty eqname
+    && clear_flag == None
+    && has_generic_occurrences_but_goal cls (destVar c) env ccl in
+  let enough_applied = check_enough_applied env sigma elim t in
+  if is_arg_pure_hyp && enough_applied then
+    (* First case: induction on a variable already in an inductive type and
+       with maximal abstraction over the variable.
+       This is a situation where the induction argument is a
+       clearable variable of the goal w/o occurrence selection
+       and w/o equality kept: no need to generalize *)
+    let id = destVar c in
+    Tacticals.New.tclTHEN
+      (Proofview.V82.tactic (clear_unselected_context id inhyps cls))
+      (induction_with_atomization_of_ind_arg
+         isrec with_evars elim names id inhyps)
+  else
+  (* Otherwise, we look for the pattern, possibly adding missing arguments and
+     declaring the induction argument as a new local variable *)
+    let id =
+    (* Type not the right one if partially applied but anyway for internal use*)
+      let x = id_of_name_using_hdchar (Global.env()) t Anonymous in
+      new_fresh_id [] x gl in
+    let info_arg = (is_arg_pure_hyp, not enough_applied) in
+    pose_induction_arg_then
+      isrec with_evars info_arg elim id arg t inhyps cls
+    (induction_with_atomization_of_ind_arg
+       isrec with_evars elim names id inhyps)
+  end
 
 (* Induction on a list of arguments. First make induction arguments
    atomic (using letins), then do induction. The specificity here is
    that all arguments and parameters of the scheme are given
    (mandatory for the moment), so we don't need to deal with
-    parameters of the inductive type as in new_induct_gen. *)
-let new_induct_gen_l isrec with_evars elim (eqname,names) lc gl =
-  if eqname <> None then
-    errorlabstrm "" (str "Do not know what to do with " ++
-      pr_intro_pattern (Option.get eqname));
+    parameters of the inductive type as in induction_gen. *)
+let induction_gen_l isrec with_evars elim names lc =
   let newlc = ref [] in
-  let letids = ref [] in
-  let rec atomize_list l gl =
+  let lc = List.map (function
+    | (c,None) -> c
+    | (c,Some(loc,eqname)) ->
+      user_err_loc (loc,"",str "Do not know what to do with " ++
+                         Miscprint.pr_intro_pattern_naming eqname)) lc in
+  let rec atomize_list l =
     match l with
-      | [] -> tclIDTAC gl
+      | [] -> Proofview.tclUNIT ()
       | c::l' ->
 	  match kind_of_term c with
 	    | Var id when not (mem_named_context id (Global.named_context()))
-		& not with_evars ->
+		&& not with_evars ->
 		let _ = newlc:= id::!newlc in
-		atomize_list l' gl
+		atomize_list l'
 
 	    | _ ->
-		let x =
-		  id_of_name_using_hdchar (Global.env()) (pf_type_of gl c) Anonymous in
+                Proofview.Goal.enter begin fun gl ->
+                let type_of = Tacmach.New.pf_type_of gl in
+                let x =
+		  id_of_name_using_hdchar (Global.env()) (type_of c) Anonymous in
 
-		let id = fresh_id [] x gl in
+                let id = new_fresh_id [] x gl in
 		let newl' = List.map (replace_term c (mkVar id)) l' in
 		let _ = newlc:=id::!newlc in
-		let _ = letids:=id::!letids in
-		tclTHEN
+		Tacticals.New.tclTHEN
 		  (letin_tac None (Name id) c None allHypsAndConcl)
-		  (atomize_list newl') gl in
-  tclTHENLIST
+		  (atomize_list newl')
+                end in
+  Tacticals.New.tclTHENLIST
     [
       (atomize_list lc);
-      (fun gl' -> (* recompute each time to have the new value of newlc *)
-	induction_without_atomization isrec with_evars elim names !newlc gl') ;
-      (* after induction, try to unfold all letins created by atomize_list
-         FIXME: unfold_all does not exist anywhere else? *)
-      (fun gl' -> (* recompute each time to have the new value of letids *)
-	tclMAP (fun x -> tclTRY (unfold_all x)) !letids gl')
+      (Proofview.tclUNIT () >>= fun () -> (* ensure newlc has been computed *)
+	induction_without_atomization isrec with_evars elim names !newlc)
     ]
-    gl
 
 (* Induction either over a term, over a quantified premisse, or over
    several quantified premisses (like with functional induction
    principles).
    TODO: really unify induction with one and induction with several
    args *)
-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 *)
-    onOpenInductionArg
-      (fun c -> new_induct_gen isrec with_evars elim names c cls)
-      (List.hd lc) gl
-  else begin
-    (* functional induction *)
-    (* Several induction hyps: induction scheme is mandatory *)
-    if elim = None
-    then
-      errorlabstrm "" (strbrk "Induction scheme must be given when several induction hypotheses are given.\n" ++
-      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 *)
+let induction_destruct isrec with_evars (lc,elim) =
+  match lc with
+  | [] -> assert false (* ensured by syntax, but if called inside caml? *)
+  | [c,(eqname,names as allnames),cls] ->
+    Proofview.Goal.nf_enter begin fun gl ->
+    let env = Proofview.Goal.env gl in
+    let sigma = Proofview.Goal.sigma gl in
+    match elim with
+    | Some elim when is_functional_induction elim gl ->
+      (* Standard induction on non-standard induction schemes *)
       (* will be removable when is_functional_induction will be more clever *)
+      if not (Option.is_empty cls) then error "'in' clause not supported here.";
+      let finish_evar_resolution f =
+        let (sigma',(c,lbind)) = f env sigma in
+        let pending = (sigma,sigma') in
+        snd (finish_evar_resolution env sigma' (pending,c)),lbind in
+      let c = map_induction_arg finish_evar_resolution c in
       onInductionArg
-	(fun (c,lbind) ->
-	  if lbind <> NoBindings then
+	(fun _clear_flag (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
-    else
+	  induction_gen_l isrec with_evars elim names [c,eqname]) c
+    | _ ->
+      (* standard induction *)
+      onOpenInductionArg env sigma
+      (fun clear_flag c -> induction_gen clear_flag isrec with_evars elim (c,allnames) cls) c
+    end
+  | _ ->
+    Proofview.Goal.enter begin fun gl ->
+    let env = Proofview.Goal.env gl in
+    let sigma = Proofview.Goal.sigma gl in
+    match elim with
+    | None ->
+      (* Several arguments, without "using" clause *)
+      (* TODO: Do as if the arguments after the first one were called with *)
+      (* "destruct", but selecting occurrences on the initial copy of *)
+      (* the goal *)
+      let (a,b,cl) = List.hd lc in
+      let l = List.tl lc in
+      (* TODO *)
+      Tacticals.New.tclTHEN
+        (onOpenInductionArg env sigma (fun clear_flag a ->
+          induction_gen clear_flag isrec with_evars None (a,b) cl) a)
+        (Tacticals.New.tclMAP (fun (a,b,cl) ->
+          Proofview.Goal.enter begin fun gl ->
+          let env = Proofview.Goal.env gl in
+          let sigma = Proofview.Goal.sigma gl in      
+          onOpenInductionArg env sigma (fun clear_flag a ->
+            induction_gen clear_flag false with_evars None (a,b) cl) a
+          end) l)
+    | Some elim ->
+      (* Several induction hyps with induction scheme *)
+      let finish_evar_resolution f =
+        let (sigma',(c,lbind)) = f env sigma in
+        let pending = (sigma,sigma') in
+	if lbind != NoBindings then
+	  error "'with' clause not supported here.";
+        snd (finish_evar_resolution env sigma' (pending,c)) in
+      let lc = List.map (on_pi1 (map_induction_arg finish_evar_resolution)) lc in
       let newlc =
-	List.map (fun x ->
+        List.map (fun (x,(eqn,names),cls) ->
+          if cls != None then error "'in' clause not yet supported here.";
 	  match x with (* FIXME: should we deal with ElimOnIdent? *)
-	  | ElimOnConstr (x,NoBindings) -> x
+          | _clear_flag,ElimOnConstr x ->
+              if eqn <> None then error "'eqn' clause not supported here.";
+              (x,names)
 	  | _ -> error "Don't know where to find some argument.")
 	  lc in
-      new_induct_gen_l isrec with_evars elim names newlc gl
-  end
-
-let induction_destruct isrec with_evars = function
-  | [],_,_ -> tclIDTAC
-  | [a,b],el,cl -> induct_destruct isrec with_evars ([a],el,b,cl)
-  | (a,b)::l,None,cl ->
-      tclTHEN
-        (induct_destruct isrec with_evars ([a],None,b,cl))
-        (tclMAP (fun (a,b) -> induct_destruct false with_evars ([a],None,b,cl)) l)
-  | l,Some el,cl ->
-      let check_basic_using = function
-        | a,(None,None) -> a
-	| _ -> error "Unsupported syntax for \"using\"."
-      in
-      let l' = List.map check_basic_using l in
-      induct_destruct isrec with_evars (l', Some el, (None,None), cl)
-
-let new_induct ev lc e idl cls = induct_destruct true ev (lc,e,idl,cls)
-let new_destruct ev lc e idl cls = induct_destruct false ev (lc,e,idl,cls)
+      (* Check that "as", if any, is given only on the last argument *)
+      let names,rest = List.sep_last (List.map snd newlc) in
+      if List.exists (fun n -> not (Option.is_empty n)) rest then
+        error "'as' clause with multiple arguments and 'using' clause can only occur last.";
+      let newlc = List.map (fun (x,_) -> (x,None)) newlc in
+      induction_gen_l isrec with_evars elim names newlc
+    end
+
+let induction ev clr c l e =
+  induction_gen clr true ev e 
+    (((Evd.empty,Evd.empty),(c,NoBindings)),(None,l)) None
+
+let destruct ev clr c l e =
+  induction_gen clr false ev e
+    (((Evd.empty,Evd.empty),(c,NoBindings)),(None,l)) None
 
 (* The registered tactic, which calls the default elimination
  * if no elimination constant is provided. *)
@@ -3217,8 +4076,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 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_id s = Tacticals.New.tclTHEN (intros_until_id s) (Tacticals.New.onLastHyp simplest_elim)
+let simple_induct_nodep n = Tacticals.New.tclTHEN (intros_until_n n) (Tacticals.New.onLastHyp simplest_elim)
 
 let simple_induct = function
   | NamedHyp id -> simple_induct_id id
@@ -3227,9 +4086,9 @@ let simple_induct = function
 (* Destruction tactics *)
 
 let simple_destruct_id s    =
-  (tclTHEN (intros_until_id s) (onLastHyp simplest_case))
+  (Tacticals.New.tclTHEN (intros_until_id s) (Tacticals.New.onLastHyp simplest_case))
 let simple_destruct_nodep n =
-  (tclTHEN (intros_until_n n)    (onLastHyp simplest_case))
+  (Tacticals.New.tclTHEN (intros_until_n n)    (Tacticals.New.onLastHyp simplest_case))
 
 let simple_destruct = function
   | NamedHyp id -> simple_destruct_id id
@@ -3242,90 +4101,35 @@ let simple_destruct = function
  * May be they should be integrated into Elim ...
  *)
 
-let elim_scheme_type elim t gl =
-  let clause = mk_clenv_type_of gl elim in
+let elim_scheme_type elim t =
+  Proofview.Goal.nf_enter begin fun gl ->
+  let clause = Tacmach.New.of_old (fun gl -> mk_clenv_type_of gl elim) gl in
   match kind_of_term (last_arg clause.templval.rebus) with
     | Meta mv ->
         let clause' =
 	  (* t is inductive, then CUMUL or CONV is irrelevant *)
-	  clenv_unify ~flags:elim_flags Reduction.CUMUL t
+	  clenv_unify ~flags:(elim_flags ()) Reduction.CUMUL t
             (clenv_meta_type clause mv) clause in
-	res_pf clause' ~flags:elim_flags gl
-    | _ -> anomaly "elim_scheme_type"
-
-let elim_type t gl =
-  let (ind,t) = pf_reduce_to_atomic_ind gl t in
-  let elimc = lookup_eliminator ind (elimination_sort_of_goal gl) in
-  elim_scheme_type elimc t gl
-
-let case_type t gl =
-  let (ind,t) = pf_reduce_to_atomic_ind gl t in
-  let elimc = pf_apply build_case_analysis_scheme_default gl ind (elimination_sort_of_goal gl) in
-  elim_scheme_type elimc t gl
-
-
-(* Some eliminations frequently used *)
-
-(* These elimination tactics are particularly adapted for sequent
-   calculus.  They take a clause as argument, and yield the
-   elimination rule if the clause is of the form (Some id) and a
-   suitable introduction rule otherwise. They do not depend on
-   the name of the eliminated constant, so they can be also
-   used on ad-hoc disjunctions and conjunctions introduced by
-   the user.
-   -- Eduardo Gimenez (11/8/97)
-
-   HH (29/5/99) replaces failures by specific error messages
- *)
-
-let andE id gl =
-  let t = pf_get_hyp_typ gl id in
-  if is_conjunction (pf_hnf_constr gl t) then
-    (tclTHEN (simplest_elim (mkVar id)) (tclDO 2 intro)) gl
-  else
-    errorlabstrm "andE"
-      (str("Tactic andE expects "^(string_of_id id)^" is a conjunction."))
+	Clenvtac.res_pf clause' ~flags:(elim_flags ()) ~with_evars:false
+    | _ -> anomaly (Pp.str "elim_scheme_type")
+  end
 
-let dAnd cls =
-  onClause
-    (function
-      | None    -> simplest_split
-      | Some id -> andE id)
-    cls
-
-let orE id gl =
-  let t = pf_get_hyp_typ gl id in
-  if is_disjunction (pf_hnf_constr gl t) then
-    (tclTHEN (simplest_elim (mkVar id)) intro) gl
-  else
-    errorlabstrm "orE"
-      (str("Tactic orE expects "^(string_of_id id)^" is a disjunction."))
+let elim_type t =
+  Proofview.Goal.enter begin fun gl ->
+  let (ind,t) = Tacmach.New.pf_apply reduce_to_atomic_ind gl t in
+  let evd, elimc = find_ind_eliminator (fst ind) (Tacticals.New.elimination_sort_of_goal gl) gl in
+  Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS evd) (elim_scheme_type elimc t)
+  end
 
-let dorE b cls =
-  onClause
-    (function
-      | Some id -> orE id
-      | None    -> (if b then right else left) NoBindings)
-    cls
-
-let impE id gl =
-  let t = pf_get_hyp_typ gl id in
-  if is_imp_term (pf_hnf_constr gl t) then
-    let (dom, _, rng) = destProd (pf_hnf_constr gl t) in
-    tclTHENLAST
-      (cut_intro rng)
-      (apply_term (mkVar id) [mkMeta (new_meta())]) gl
-  else
-    errorlabstrm "impE"
-      (str("Tactic impE expects "^(string_of_id id)^
-	      " is a an implication."))
+let case_type t =
+  Proofview.Goal.enter begin fun gl ->
+  let (ind,t) = Tacmach.New.pf_apply reduce_to_atomic_ind gl t in
+  let evd, elimc =
+    Tacmach.New.pf_apply build_case_analysis_scheme_default gl ind (Tacticals.New.elimination_sort_of_goal gl)
+  in
+  Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS evd) (elim_scheme_type elimc t)
+  end
 
-let dImp cls =
-  onClause
-    (function
-      | None    -> intro
-      | Some id -> impE id)
-    cls
 
 (************************************************)
 (*  Tactics related with logic connectives      *)
@@ -3333,24 +4137,36 @@ let dImp cls =
 
 (* Reflexivity tactics *)
 
-let setoid_reflexivity = ref (fun _ -> assert false)
-let register_setoid_reflexivity f = setoid_reflexivity := f
+let (forward_setoid_reflexivity, setoid_reflexivity) = Hook.make ()
 
-let reflexivity_red allowred gl =
+let maybe_betadeltaiota_concl allowred gl =
+  let concl = Tacmach.New.pf_nf_concl gl in
+  let sigma = Proofview.Goal.sigma gl in
+  if not allowred then concl
+  else
+    let env = Proofview.Goal.env gl in
+    whd_betadeltaiota env sigma concl
+
+let reflexivity_red allowred =
+  Proofview.Goal.enter begin fun gl ->
   (* PL: usual reflexivity don't perform any reduction when searching
      for an equality, but we may need to do some when called back from
      inside setoid_reflexivity (see Optimize cases in setoid_replace.ml). *)
-  let concl = if not allowred then pf_concl gl
-  else whd_betadeltaiota (pf_env gl) (project gl) (pf_concl gl)
-  in
+    let concl = maybe_betadeltaiota_concl allowred gl in
     match match_with_equality_type concl with
-    | None -> raise NoEquationFound
-    | Some _ -> one_constructor 1 NoBindings gl
+    | None -> Proofview.tclZERO NoEquationFound
+    | Some _ -> one_constructor 1 NoBindings
+  end
 
-let reflexivity gl =
-  try reflexivity_red false gl with NoEquationFound -> !setoid_reflexivity gl
+let reflexivity =
+  Proofview.tclORELSE
+    (reflexivity_red false)
+    begin function (e, info) -> match e with
+      | NoEquationFound -> Hook.get forward_setoid_reflexivity
+      | e -> Proofview.tclZERO ~info e
+    end
 
-let intros_reflexivity  = (tclTHEN intros reflexivity)
+let intros_reflexivity  = (Tacticals.New.tclTHEN intros reflexivity)
 
 (* Symmetry tactics *)
 
@@ -3359,8 +4175,7 @@ let intros_reflexivity  = (tclTHEN intros reflexivity)
    defined and the conclusion is a=b, it solves the goal doing (Cut
    b=a;Intro H;Case H;Constructor 1) *)
 
-let setoid_symmetry = ref (fun _ -> assert false)
-let register_setoid_symmetry f = setoid_symmetry := f
+let (forward_setoid_symmetry, setoid_symmetry) = Hook.make ()
 
 (* This is probably not very useful any longer *)
 let prove_symmetry hdcncl eq_kind =
@@ -3369,51 +4184,70 @@ let prove_symmetry hdcncl eq_kind =
     | MonomorphicLeibnizEq (c1,c2) -> mkApp(hdcncl,[|c2;c1|])
     | PolymorphicLeibnizEq (typ,c1,c2) -> mkApp(hdcncl,[|typ;c2;c1|])
     | HeterogenousEq (t1,c1,t2,c2) -> mkApp(hdcncl,[|t2;c2;t1;c1|]) in
-  tclTHENFIRST (cut symc)
-    (tclTHENLIST
+  Tacticals.New.tclTHENFIRST (cut symc)
+    (Tacticals.New.tclTHENLIST
       [ intro;
-        onLastHyp simplest_case;
+        Tacticals.New.onLastHyp simplest_case;
 	one_constructor 1 NoBindings ])
 
-let symmetry_red allowred gl =
+let match_with_equation c =
+  try
+    let res = match_with_equation c in
+    Proofview.tclUNIT res
+  with NoEquationFound ->
+    Proofview.tclZERO NoEquationFound
+
+let symmetry_red allowred =
+  Proofview.Goal.enter begin fun gl ->
   (* PL: usual symmetry don't perform any reduction when searching
      for an equality, but we may need to do some when called back from
      inside setoid_reflexivity (see Optimize cases in setoid_replace.ml). *)
-  let concl =
-    if not allowred then pf_concl gl else pf_whd_betadeltaiota gl (pf_concl gl)
-  in
-  match match_with_equation concl with
+  let concl = maybe_betadeltaiota_concl allowred gl in
+  match_with_equation concl >>= fun with_eqn ->
+  match with_eqn with
   | Some eq_data,_,_ ->
-      tclTHEN
+      Tacticals.New.tclTHEN
         (convert_concl_no_check concl DEFAULTcast)
-      (apply eq_data.sym) gl
-  | None,eq,eq_kind -> prove_symmetry eq eq_kind gl
+        (Tacticals.New.pf_constr_of_global eq_data.sym apply)
+  | None,eq,eq_kind -> prove_symmetry eq eq_kind
+  end
 
-let symmetry gl =
-  try symmetry_red false gl with NoEquationFound -> !setoid_symmetry gl
+let symmetry =
+  Proofview.tclORELSE
+    (symmetry_red false)
+    begin function (e, info) -> match e with
+      | NoEquationFound -> Hook.get forward_setoid_symmetry
+      | e -> Proofview.tclZERO ~info e
+    end
 
-let setoid_symmetry_in = ref (fun _ _ -> assert false)
-let register_setoid_symmetry_in f = setoid_symmetry_in := f
+let (forward_setoid_symmetry_in, setoid_symmetry_in) = Hook.make ()
 
-let symmetry_in id gl =
-  let ctype = pf_type_of gl (mkVar id) in
+
+let symmetry_in id =
+  Proofview.Goal.enter begin fun gl ->
+  let ctype = Tacmach.New.pf_type_of gl (mkVar id) in
   let sign,t = decompose_prod_assum ctype in
-  try
-    let _,hdcncl,eq = match_with_equation t in
-    let symccl = match eq with
-      | MonomorphicLeibnizEq (c1,c2) -> mkApp (hdcncl, [| c2; c1 |])
-      | PolymorphicLeibnizEq (typ,c1,c2) -> mkApp (hdcncl, [| typ; c2; c1 |])
-      | HeterogenousEq (t1,c1,t2,c2) -> mkApp (hdcncl, [| t2; c2; t1; c1 |]) in
-    tclTHENS (cut (it_mkProd_or_LetIn symccl sign))
-      [ intro_replacing id;
-        tclTHENLIST [ intros; symmetry; apply (mkVar id); assumption ] ]
-      gl
-  with NoEquationFound -> !setoid_symmetry_in id gl
+  Proofview.tclORELSE
+    begin
+      match_with_equation t >>= fun (_,hdcncl,eq) ->
+        let symccl = match eq with
+          | MonomorphicLeibnizEq (c1,c2) -> mkApp (hdcncl, [| c2; c1 |])
+          | PolymorphicLeibnizEq (typ,c1,c2) -> mkApp (hdcncl, [| typ; c2; c1 |])
+          | HeterogenousEq (t1,c1,t2,c2) -> mkApp (hdcncl, [| t2; c2; t1; c1 |]) in
+        Tacticals.New.tclTHENS (cut (it_mkProd_or_LetIn symccl sign))
+          [ intro_replacing id;
+            Tacticals.New.tclTHENLIST [ intros; symmetry; apply (mkVar id); assumption ] ]
+    end
+    begin function (e, info) -> match e with
+      | NoEquationFound -> Hook.get forward_setoid_symmetry_in id
+      | e -> Proofview.tclZERO ~info e
+    end
+  end
 
 let intros_symmetry =
-  onClause
+  Tacticals.New.onClause
     (function
-      | None -> tclTHEN intros symmetry
+      | None -> Tacticals.New.tclTHEN intros symmetry
       | Some id -> symmetry_in id)
 
 (* Transitivity tactics *)
@@ -3428,132 +4262,217 @@ let intros_symmetry =
    --Eduardo (19/8/97)
 *)
 
-let setoid_transitivity = ref (fun _ _ -> assert false)
-let register_setoid_transitivity f = setoid_transitivity := f
+let (forward_setoid_transitivity, setoid_transitivity) = Hook.make ()
+
 
 (* This is probably not very useful any longer *)
-let prove_transitivity hdcncl eq_kind t gl =
-  let eq1,eq2 =
-    match eq_kind with
-    | MonomorphicLeibnizEq (c1,c2) ->
-      (mkApp (hdcncl, [| c1; t|]), mkApp (hdcncl, [| t; c2 |]))
+let prove_transitivity hdcncl eq_kind t =
+  Proofview.Goal.enter begin fun gl ->
+  let (eq1,eq2) = match eq_kind with
+  | MonomorphicLeibnizEq (c1,c2) ->
+      mkApp (hdcncl, [| c1; t|]), mkApp (hdcncl, [| t; c2 |])
   | PolymorphicLeibnizEq (typ,c1,c2) ->
-      (mkApp (hdcncl, [| typ; c1; t |]), mkApp (hdcncl, [| typ; t; c2 |]))
+      mkApp (hdcncl, [| typ; c1; t |]), mkApp (hdcncl, [| typ; t; c2 |])
   | HeterogenousEq (typ1,c1,typ2,c2) ->
-      let typt = pf_type_of gl t in
-      (mkApp(hdcncl, [| typ1; c1; typt ;t |]),
-       mkApp(hdcncl, [| typt; t; typ2; c2 |])) in
-  tclTHENFIRST (cut eq2)
-    (tclTHENFIRST (cut eq1)
-      (tclTHENLIST
-	[ tclDO 2 intro;
-	  onLastHyp simplest_case;
-	  assumption ])) gl
-
-let transitivity_red allowred t gl =
+      let env = Proofview.Goal.env gl in
+      let sigma = Proofview.Goal.sigma gl in
+      let type_of = Typing.type_of env sigma in
+      let typt = type_of t in
+        (mkApp(hdcncl, [| typ1; c1; typt ;t |]),
+         mkApp(hdcncl, [| typt; t; typ2; c2 |]))
+  in
+  Tacticals.New.tclTHENFIRST (cut eq2)
+    (Tacticals.New.tclTHENFIRST (cut eq1)
+       (Tacticals.New.tclTHENLIST
+	  [ Tacticals.New.tclDO 2 intro;
+	    Tacticals.New.onLastHyp simplest_case;
+	    assumption ]))
+  end
+
+let transitivity_red allowred t =
+  Proofview.Goal.enter begin fun gl ->
   (* PL: usual transitivity don't perform any reduction when searching
      for an equality, but we may need to do some when called back from
      inside setoid_reflexivity (see Optimize cases in setoid_replace.ml). *)
-  let concl =
-    if not allowred then pf_concl gl else pf_whd_betadeltaiota gl (pf_concl gl)
-  in
-  match match_with_equation concl with
+  let concl = maybe_betadeltaiota_concl allowred gl in
+  match_with_equation concl >>= fun with_eqn ->
+  match with_eqn with
   | Some eq_data,_,_ ->
-      tclTHEN
+      Tacticals.New.tclTHEN
         (convert_concl_no_check concl DEFAULTcast)
         (match t with
-	 | None -> eapply eq_data.trans
-	 | Some t -> apply_list [eq_data.trans;t]) gl
-  | None,eq,eq_kind ->
+	  | None -> Tacticals.New.pf_constr_of_global eq_data.trans eapply
+	  | Some t -> Tacticals.New.pf_constr_of_global eq_data.trans (fun trans -> apply_list [trans;t]))
+   | None,eq,eq_kind ->
       match t with
-      | None -> error "etransitivity not supported for this relation."
-      | Some t -> prove_transitivity eq eq_kind t gl
+      | None -> Tacticals.New.tclZEROMSG (str"etransitivity not supported for this relation.")
+      | Some t -> prove_transitivity eq eq_kind t
+  end
 
-let transitivity_gen t gl =
-  try transitivity_red false t gl
-  with NoEquationFound -> !setoid_transitivity t gl
+let transitivity_gen t =
+  Proofview.tclORELSE
+    (transitivity_red false t)
+    begin function (e, info) -> match e with
+      | NoEquationFound -> Hook.get forward_setoid_transitivity t
+      | e -> Proofview.tclZERO ~info e
+    end
 
 let etransitivity = transitivity_gen None
 let transitivity t = transitivity_gen (Some t)
 
-let intros_transitivity  n  = tclTHEN intros (transitivity_gen n)
+let intros_transitivity  n  = Tacticals.New.tclTHEN intros (transitivity_gen n)
 
 (* tactical to save as name a subproof such that the generalisation of
    the current goal, abstracted with respect to the local signature,
    is solved by tac *)
 
-let interpretable_as_section_decl d1 d2 = match d1,d2 with
+(** d1 is the section variable in the global context, d2 in the goal context *)
+let interpretable_as_section_decl evd d1 d2 = match d2,d1 with
   | (_,Some _,_), (_,None,_) -> false
-  | (_,Some b1,t1), (_,Some b2,t2) -> eq_constr b1 b2 & eq_constr t1 t2
-  | (_,None,t1), (_,_,t2) -> eq_constr t1 t2
-
-let abstract_subproof id tac gl =
+  | (_,Some b1,t1), (_,Some b2,t2) -> 
+    e_eq_constr_univs evd b1 b2 && e_eq_constr_univs evd t1 t2
+  | (_,None,t1), (_,_,t2) -> e_eq_constr_univs evd t1 t2
+
+let abstract_subproof id gk tac =
+  let open Tacticals.New in
+  let open Tacmach.New in
+  let open Proofview.Notations in
+  Proofview.Goal.nf_enter begin fun gl ->
   let current_sign = Global.named_context()
-  and global_sign = pf_hyps gl in
+  and global_sign = Proofview.Goal.hyps gl in
+  let evdref = ref (Proofview.Goal.sigma gl) in
   let sign,secsign =
     List.fold_right
       (fun (id,_,_ as d) (s1,s2) ->
-	if mem_named_context id current_sign &
-          interpretable_as_section_decl (Sign.lookup_named id current_sign) d
+	if mem_named_context id current_sign &&
+          interpretable_as_section_decl evdref (Context.lookup_named id current_sign) d
         then (s1,push_named_context_val d s2)
 	else (add_named_decl d s1,s2))
       global_sign (empty_named_context,empty_named_context_val) in
   let id = next_global_ident_away id (pf_ids_of_hyps gl) in
-  let concl = it_mkNamedProd_or_LetIn (pf_concl gl) sign in
+  let concl = it_mkNamedProd_or_LetIn (Proofview.Goal.concl gl) sign in
   let concl =
-    try flush_and_check_evars (project gl) concl
+    try flush_and_check_evars !evdref concl
     with Uninstantiated_evar _ ->
       error "\"abstract\" cannot handle existentials." in
-  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_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
 
-let tclABSTRACT name_op tac gl =
-  let s = match name_op with
-    | Some s -> s
-    | None   -> add_suffix (get_current_proof_name ()) "_subproof"
+  let evd, ctx, concl =
+    (* FIXME: should be done only if the tactic succeeds *)
+    let evd, nf = nf_evars_and_universes !evdref in
+    let ctx = Evd.universe_context_set evd in
+      evd, ctx, nf concl
   in
-  abstract_subproof s tac gl
-
+  let solve_tac = tclCOMPLETE (tclTHEN (tclDO (List.length sign) intro) tac) in
+  let ectx = Evd.evar_universe_context evd in
+  let (const, safe, ectx) =
+    try Pfedit.build_constant_by_tactic ~goal_kind:gk id ectx secsign concl solve_tac
+    with Logic_monad.TacticFailure e as src ->
+    (* if the tactic [tac] fails, it reports a [TacticFailure e],
+       which is an error irrelevant to the proof system (in fact it
+       means that [e] comes from [tac] failing to yield enough
+       success). Hence it reraises [e]. *)
+    let (_, info) = Errors.push src in
+    iraise (e, info)
+  in
+  let cd = Entries.DefinitionEntry const in
+  let decl = (cd, IsProof Lemma) in
+  (** ppedrot: seems legit to have abstracted subproofs as local*)
+  let cst = Declare.declare_constant ~internal:Declare.KernelSilent ~local:true id decl in
+  (* let evd, lem = Evd.fresh_global (Global.env ()) evd (ConstRef cst) in *)
+  let lem, ctx = Universes.unsafe_constr_of_global (ConstRef cst) in
+  let evd = Evd.set_universe_context evd ectx in
+  let open Declareops in
+  let eff = Safe_typing.sideff_of_con (Global.safe_env ()) cst in
+  let effs = cons_side_effects eff
+    Entries.(snd (Future.force const.const_entry_body)) in
+  let args = List.rev (instance_from_named_context sign) in
+  let solve =
+    Proofview.Unsafe.tclEVARS evd <*>
+    Proofview.tclEFFECTS effs <*>
+    new_exact_no_check (applist (lem, args))
+  in
+  if not safe then Proofview.mark_as_unsafe <*> solve else solve
+  end
 
-let admit_as_an_axiom gl =
-  let current_sign = Global.named_context()
-  and global_sign = pf_hyps gl in
-  let sign,secsign =
-    List.fold_right
-      (fun (id,_,_ as d) (s1,s2) ->
-	 if mem_named_context id current_sign &
-           interpretable_as_section_decl (Sign.lookup_named id current_sign) d
-         then (s1,add_named_decl d s2)
-	 else (add_named_decl d s1,s2))
-      global_sign (empty_named_context,empty_named_context) in
-  let name = add_suffix (get_current_proof_name ()) "_admitted" in
-  let na = next_global_ident_away name (pf_ids_of_hyps gl) in
-  let 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 (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)
+let anon_id = Id.of_string "anonymous"
+
+let tclABSTRACT name_op tac =
+  let open Proof_global in
+  let default_gk = (Global, false, Proof Theorem) in
+  let s, gk = match name_op with
+    | Some s ->
+      (try let _, gk, _ = current_proof_statement () in s, gk
+       with NoCurrentProof -> s, default_gk)
+    | None   ->
+      let name, gk =
+	try let name, gk, _ = current_proof_statement () in name, gk
+	with NoCurrentProof -> anon_id, default_gk in
+      add_suffix name "_subproof", gk
   in
-  exact_no_check
-    (applist (axiom,
-              List.rev (Array.to_list (instance_from_named_context sign))))
-    gl
+  abstract_subproof s gk tac
+
+let admit_as_an_axiom =
+  Proofview.tclUNIT () >>= fun () -> (* delay for Coqlib.build_coq_proof_admitted *)
+  simplest_case (Coqlib.build_coq_proof_admitted ()) <*>
+  Proofview.mark_as_unsafe
 
-let unify ?(state=full_transparent_state) x y gl =
+let unify ?(state=full_transparent_state) x y =
+  Proofview.Goal.nf_enter begin fun gl ->
   try
-    let flags =
-      {default_unify_flags with
+    let core_flags =
+      { (default_unify_flags ()).core_unify_flags with
 	modulo_delta = state;
-	modulo_conv_on_closed_terms = Some state}
+	modulo_conv_on_closed_terms = Some state} in
+    (* What to do on merge and subterm flags?? *)
+    let flags = { (default_unify_flags ()) with
+      core_unify_flags = core_flags;
+      merge_unify_flags = core_flags;
+      subterm_unify_flags = { core_flags with modulo_delta = empty_transparent_state } }
     in
-    let evd = w_unify (pf_env gl) (project gl) Reduction.CONV ~flags x y
-    in tclEVARS evd gl
-  with e when Errors.noncritical e ->
-    tclFAIL 0 (str"Not unifiable") gl
+    let evd = w_unify (Tacmach.New.pf_env gl) (Proofview.Goal.sigma gl) Reduction.CONV ~flags x y
+    in Proofview.Unsafe.tclEVARS evd
+  with e when Errors.noncritical e -> Tacticals.New.tclFAIL 0 (str"Not unifiable")
+  end
+
+module Simple = struct
+  (** Simplified version of some of the above tactics *)
+
+  let intro x = intro_move (Some x) MoveLast
+
+  let generalize_gen cl =
+    generalize_gen (List.map (on_fst Redexpr.out_with_occurrences) cl)
+  let generalize cl =
+    generalize_gen (List.map (fun c -> ((AllOccurrences,c),Names.Anonymous))
+                        cl)
+
+  let apply c =
+    apply_with_bindings_gen false false [None,(Loc.ghost,(c,NoBindings))]
+  let eapply c =
+    apply_with_bindings_gen false true [None,(Loc.ghost,(c,NoBindings))]
+  let elim c   = elim false None (c,NoBindings) None
+  let case   c = general_case_analysis false None (c,NoBindings)
+
+  let apply_in id c =
+    apply_in false false None id [None,(Loc.ghost, (c, NoBindings))] None
+
+end
+
+
+(** Tacticals defined directly in term of Proofview *)
+module New = struct
+  open Proofview.Notations
+
+  let exact_proof c = Proofview.V82.tactic (exact_proof c)
+
+  open Genredexpr
+  open Locus
+
+  let reduce_after_refine =
+    Proofview.V82.tactic (reduce
+      (Lazy {rBeta=true;rIota=true;rZeta=false;rDelta=false;rConst=[]})
+      {onhyps=None; concl_occs=AllOccurrences })
+
+  let refine ?unsafe c =
+    Proofview.Refine.refine ?unsafe c <*>
+    reduce_after_refine
+end
diff --git a/tactics/tactics.mli b/tactics/tactics.mli
index e82ee021..6025883f 100644
--- a/tactics/tactics.mli
+++ b/tactics/tactics.mli
@@ -1,133 +1,139 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-open Util
+open Loc
 open Names
 open Term
+open Context
 open Environ
-open Sign
-open Tacmach
 open Proof_type
-open Reduction
 open Evd
-open Evar_refiner
 open Clenv
 open Redexpr
-open Tacticals
-open Libnames
-open Genarg
+open Globnames
 open Tacexpr
-open Nametab
-open Glob_term
 open Pattern
-open Termops
 open Unification
+open Misctypes
+open Locus
 
 (** Main tactics. *)
 
 (** {6 General functions. } *)
 
-val string_of_inductive : constr -> string
-val head_constr       : constr -> constr * constr list
-val head_constr_bound : constr -> constr * constr list
-val is_quantified_hypothesis : identifier -> goal sigma -> bool
-
-exception Bound
+val is_quantified_hypothesis : Id.t -> goal sigma -> bool
 
 (** {6 Primitive tactics. } *)
 
-val introduction    : identifier -> tactic
+val introduction    : ?check:bool -> Id.t -> unit Proofview.tactic
 val refine          : constr -> tactic
-val convert_concl   : constr -> cast_kind -> tactic
-val convert_hyp     : named_declaration -> tactic
-val thin            : identifier list -> tactic
+val convert_concl   : ?check:bool -> types -> cast_kind -> unit Proofview.tactic
+val convert_hyp     : ?check:bool -> named_declaration -> unit Proofview.tactic
+val convert_concl_no_check : types -> cast_kind -> unit Proofview.tactic
+val convert_hyp_no_check : named_declaration -> unit Proofview.tactic
+val thin            : Id.t list -> tactic
 val mutual_fix      :
-  identifier -> int -> (identifier * int * constr) list -> int -> tactic
-val fix             : identifier option -> int -> tactic
-val mutual_cofix    : identifier -> (identifier * constr) list -> int -> tactic
-val cofix           : identifier option -> tactic
+  Id.t -> int -> (Id.t * int * constr) list -> int -> tactic
+val fix             : Id.t option -> int -> tactic
+val mutual_cofix    : Id.t -> (Id.t * constr) list -> int -> tactic
+val cofix           : Id.t option -> tactic
+
+val convert         : constr -> constr -> unit Proofview.tactic
+val convert_leq     : constr -> constr -> unit Proofview.tactic
 
 (** {6 Introduction tactics. } *)
 
-val fresh_id_in_env : identifier list -> identifier -> env -> identifier
-val fresh_id : identifier list -> identifier -> goal sigma -> identifier
-val find_intro_names : rel_context -> goal sigma -> identifier list
+val fresh_id_in_env : Id.t list -> Id.t -> env -> Id.t
+val fresh_id : Id.t list -> Id.t -> goal sigma -> Id.t
+val find_intro_names : rel_context -> goal sigma -> Id.t list
 
-val intro                : tactic
-val introf               : tactic
-val intro_move        : identifier option -> identifier move_location -> tactic
+val intro                : unit Proofview.tactic
+val introf               : unit Proofview.tactic
+val intro_move        : Id.t option -> Id.t move_location -> unit Proofview.tactic
+val intro_move_avoid  : Id.t option -> Id.t list -> Id.t move_location -> unit Proofview.tactic
 
-  (** [intro_avoiding idl] acts as intro but prevents the new identifier
+  (** [intro_avoiding idl] acts as intro but prevents the new Id.t
      to belong to [idl] *)
-val intro_avoiding       : identifier list -> tactic
+val intro_avoiding       : Id.t list -> unit Proofview.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 intro_replacing      : Id.t -> unit Proofview.tactic
+val intro_using          : Id.t -> unit Proofview.tactic
+val intro_mustbe_force   : Id.t -> unit Proofview.tactic
+val intro_then           : (Id.t -> unit Proofview.tactic) -> unit Proofview.tactic
+val intros_using         : Id.t list -> unit Proofview.tactic
+val intros_replacing     : Id.t list -> unit Proofview.tactic
+val intros_possibly_replacing : Id.t list -> unit Proofview.tactic
 
-val intros               : tactic
+val intros               : unit Proofview.tactic
 
 (** [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
 
-val intros_until_n_wored : int -> tactic
-val intros_until         : quantified_hypothesis -> tactic
+val intros_until         : quantified_hypothesis -> unit Proofview.tactic
 
-val intros_clearing      : bool list -> tactic
+val intros_clearing      : bool list -> unit Proofview.tactic
 
-(** Assuming a tactic [tac] depending on an hypothesis identifier,
+(** Assuming a tactic [tac] depending on an hypothesis Id.t,
    [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
    hypothesis is already in context and directly apply [tac] *)
 
 val try_intros_until :
-  (identifier -> tactic) -> quantified_hypothesis -> tactic
+  (Id.t -> unit Proofview.tactic) -> quantified_hypothesis -> unit Proofview.tactic
 
 (** 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
+  (clear_flag -> constr with_bindings -> unit Proofview.tactic) ->
+    constr with_bindings induction_arg -> unit Proofview.tactic
+
+(** Tell if a used hypothesis should be cleared by default or not *)
+
+val use_clear_hyp_by_default : unit -> bool
 
 (** {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
+val intro_patterns : intro_patterns -> unit Proofview.tactic
+val intro_patterns_to : Id.t move_location -> intro_patterns ->
+  unit Proofview.tactic
+val intro_patterns_bound_to : int -> Id.t move_location -> intro_patterns ->
+  unit Proofview.tactic
+val intro_pattern_to : Id.t move_location -> delayed_open_constr intro_pattern_expr ->
+  unit Proofview.tactic
+
+(** Implements user-level "intros", with [] standing for "**" *)
+val intros_patterns : intro_patterns -> unit Proofview.tactic
 
 (** {6 Exact tactics. } *)
 
-val assumption       : tactic
+val assumption       : unit Proofview.tactic
 val exact_no_check   : constr -> tactic
 val vm_cast_no_check : constr -> tactic
-val exact_check      : constr -> tactic
-val exact_proof      : Topconstr.constr_expr -> tactic
+val exact_check      : constr -> unit Proofview.tactic
+val exact_proof      : Constrexpr.constr_expr -> tactic
 
 (** {6 Reduction tactics. } *)
 
 type tactic_reduction = env -> evar_map -> constr -> constr
 
-val reduct_in_hyp     : tactic_reduction -> hyp_location -> tactic
-val reduct_option     : tactic_reduction * cast_kind -> goal_location -> tactic
+type change_arg = evar_map -> evar_map * constr
+
+val reduct_in_hyp     : ?check:bool -> tactic_reduction -> hyp_location -> tactic
+val reduct_option     : ?check:bool -> tactic_reduction * cast_kind -> goal_location -> tactic
 val reduct_in_concl   : tactic_reduction * cast_kind -> tactic
-val change_in_concl   : (occurrences * constr_pattern) option -> constr -> 
-                        tactic
-val change_in_hyp     : (occurrences * constr_pattern) option -> constr ->
-                        hyp_location -> tactic
+val change_in_concl   : (occurrences * constr_pattern) option -> change_arg -> unit Proofview.tactic
+val change_concl      : constr -> unit Proofview.tactic
+val change_in_hyp     : (occurrences * constr_pattern) option -> change_arg ->
+                        hyp_location -> unit Proofview.tactic
 val red_in_concl      : tactic
 val red_in_hyp        : hyp_location -> tactic
 val red_option        : goal_location -> tactic
@@ -148,7 +154,7 @@ val unfold_in_hyp     :
 val unfold_option     :
   (occurrences * evaluable_global_reference) list -> goal_location -> tactic
 val change            :
-  constr_pattern option -> constr -> clause -> tactic
+  constr_pattern option -> change_arg -> clause -> tactic
 val pattern_option    :
   (occurrences * constr) list -> goal_location -> tactic
 val reduce            : red_expr -> clause -> tactic
@@ -156,44 +162,50 @@ val unfold_constr     : global_reference -> tactic
 
 (** {6 Modification of the local context. } *)
 
-val clear         : identifier list -> tactic
-val clear_body    : identifier list -> tactic
-val keep          : identifier list -> tactic
+val clear         : Id.t list -> tactic
+val clear_body    : Id.t list -> unit Proofview.tactic
+val unfold_body   : Id.t -> tactic
+val keep          : Id.t list -> unit Proofview.tactic
+val apply_clear_request : clear_flag -> bool -> constr -> unit Proofview.tactic
 
-val specialize    : int option -> constr with_bindings -> tactic
+val specialize    : constr with_bindings -> tactic
 
-val move_hyp      : bool -> identifier -> identifier move_location -> tactic
-val rename_hyp    : (identifier * identifier) list -> tactic
+val move_hyp      : Id.t -> Id.t move_location -> tactic
+val rename_hyp    : (Id.t * Id.t) list -> unit Proofview.tactic
 
-val revert        : identifier list -> tactic
+val revert        : Id.t list -> unit Proofview.tactic
 
 (** {6 Resolution tactics. } *)
 
 val apply_type : constr -> constr list -> tactic
-val apply_term : constr -> constr list -> tactic
-val bring_hyps : named_context -> tactic
+val bring_hyps : named_context -> unit Proofview.tactic
 
-val apply                 : constr -> tactic
-val eapply                : constr -> tactic
+val apply                 : constr -> unit Proofview.tactic
+val eapply                : constr -> unit Proofview.tactic
 
 val apply_with_bindings_gen :
-  advanced_flag -> evars_flag -> constr with_bindings located list -> tactic
+  advanced_flag -> evars_flag -> (clear_flag * constr with_bindings located) list -> unit Proofview.tactic
 
-val apply_with_bindings   : constr with_bindings -> tactic
-val eapply_with_bindings  : constr with_bindings -> tactic
+val apply_with_delayed_bindings_gen :
+  advanced_flag -> evars_flag -> (clear_flag * delayed_open_constr_with_bindings located) list -> unit Proofview.tactic
 
-val cut_and_apply         : constr -> tactic
+val apply_with_bindings   : constr with_bindings -> unit Proofview.tactic
+val eapply_with_bindings  : constr with_bindings -> unit Proofview.tactic
+
+val cut_and_apply         : constr -> unit Proofview.tactic
 
 val apply_in :
-  advanced_flag -> evars_flag -> identifier -> 
-    constr with_bindings located list ->
-    intro_pattern_expr located option -> tactic
+  advanced_flag -> evars_flag -> clear_flag -> Id.t -> 
+    (clear_flag * constr with_bindings located) list ->
+    intro_pattern option -> unit Proofview.tactic
 
-val simple_apply_in : identifier -> constr -> tactic
+val apply_delayed_in :
+  advanced_flag -> evars_flag -> clear_flag -> Id.t -> 
+    (clear_flag * delayed_open_constr_with_bindings located) list ->
+    intro_pattern option -> unit Proofview.tactic
 
 (** {6 Elimination tactics. } *)
 
-
 (*
    The general form of an induction principle is the following:
 
@@ -223,7 +235,6 @@ 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,...) *)
@@ -240,150 +251,192 @@ type elim_scheme = {
   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 *)
 type eliminator = {
   elimindex : int option;  (** None = find it automatically *)
+  elimrename : (bool * int array) option; (** None = don't rename Prop hyps with H-names *)
   elimbody : constr with_bindings
 }
 
-val elimination_clause_scheme : evars_flag -> ?flags:unify_flags -> 
-  int -> clausenv -> clausenv -> tactic
+val general_elim  : evars_flag -> clear_flag ->
+  constr with_bindings -> eliminator -> unit Proofview.tactic
 
-val elimination_in_clause_scheme : evars_flag -> ?flags:unify_flags -> 
-  identifier -> int -> clausenv -> clausenv -> tactic
+val general_elim_clause : evars_flag -> unify_flags -> identifier option ->
+  clausenv -> eliminator -> unit Proofview.tactic
 
-val general_elim_clause_gen : (int -> Clenv.clausenv -> 'a -> tactic) ->
-  'a -> eliminator -> tactic
-
-val general_elim  : evars_flag ->
-  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
+val default_elim  : evars_flag -> clear_flag -> constr with_bindings ->
+  unit Proofview.tactic
+val simplest_elim : constr -> unit Proofview.tactic
 val elim :
-  evars_flag -> constr with_bindings -> constr with_bindings option -> tactic
+  evars_flag -> clear_flag -> constr with_bindings -> constr with_bindings option -> unit Proofview.tactic
 
-val simple_induct : quantified_hypothesis -> tactic
+val simple_induct : quantified_hypothesis -> unit Proofview.tactic
 
-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
+val induction : evars_flag -> clear_flag -> constr -> or_and_intro_pattern option ->
+  constr with_bindings option -> unit Proofview.tactic
 
 (** {6 Case analysis tactics. } *)
 
-val general_case_analysis : evars_flag -> constr with_bindings ->  tactic
-val simplest_case         : constr -> tactic
+val general_case_analysis : evars_flag -> clear_flag -> constr with_bindings ->  unit Proofview.tactic
+val simplest_case         : constr -> unit Proofview.tactic
 
-val simple_destruct          : quantified_hypothesis -> tactic
-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
+val simple_destruct       : quantified_hypothesis -> unit Proofview.tactic
+val destruct : evars_flag -> clear_flag -> constr -> or_and_intro_pattern option ->
+  constr with_bindings option -> unit Proofview.tactic
 
 (** {6 Generic case analysis / induction tactics. } *)
 
+(** Implements user-level "destruct" and "induction" *)
+
 val induction_destruct : rec_flag -> evars_flag ->
-  ((evar_map * constr with_bindings) induction_arg *
-  (intro_pattern_expr located option * intro_pattern_expr located option))
-  list *
-  constr with_bindings option *
-  clause option -> tactic
+  (delayed_open_constr_with_bindings induction_arg
+   * (intro_pattern_naming option * or_and_intro_pattern option)
+   * clause option) list *
+  constr with_bindings option -> unit Proofview.tactic
 
 (** {6 Eliminations giving the type instead of the proof. } *)
 
-val case_type         : constr  -> tactic
-val elim_type         : constr  -> tactic
+val case_type         : types -> unit Proofview.tactic
+val elim_type         : types -> unit Proofview.tactic
 
-(** {6 Some eliminations which are frequently used. } *)
+(** {6 Constructor tactics. } *)
 
-val impE : identifier -> tactic
-val andE : identifier -> tactic
-val orE  : identifier -> tactic
-val dImp : clause -> tactic
-val dAnd : clause -> tactic
-val dorE : bool -> clause ->tactic
+val constructor_tac      : evars_flag -> int option -> int ->
+  constr bindings -> unit Proofview.tactic
+val any_constructor      : evars_flag -> unit Proofview.tactic option -> unit Proofview.tactic
+val one_constructor      : int -> constr bindings  -> unit Proofview.tactic
 
+val left                 : constr bindings -> unit Proofview.tactic
+val right                : constr bindings -> unit Proofview.tactic
+val split                : constr bindings -> unit Proofview.tactic
 
-(** {6 Introduction tactics. } *)
+val left_with_bindings  : evars_flag -> constr bindings -> unit Proofview.tactic
+val right_with_bindings : evars_flag -> constr bindings -> unit Proofview.tactic
+val split_with_bindings : evars_flag -> constr bindings list -> unit Proofview.tactic
 
-val constructor_tac      : evars_flag -> int option -> int ->
-  constr bindings -> tactic
-val any_constructor      : evars_flag -> tactic option -> tactic
-val one_constructor      : int -> constr bindings  -> tactic
-
-val left                 : constr bindings -> tactic
-val right                : constr bindings -> tactic
-val split                : constr bindings -> tactic
-
-val left_with_bindings  : evars_flag -> constr bindings -> tactic
-val right_with_bindings : evars_flag -> constr bindings -> tactic
-val split_with_bindings : evars_flag -> constr bindings list -> tactic
-
-val simplest_left        : tactic
-val simplest_right       : tactic
-val simplest_split       : tactic
-
-(** {6 Logical connective tactics. } *)
-
-val register_setoid_reflexivity : tactic -> unit
-val reflexivity_red             : bool -> tactic
-val reflexivity                 : tactic
-val intros_reflexivity          : tactic
-
-val register_setoid_symmetry : tactic -> unit
-val symmetry_red                : bool -> tactic
-val symmetry                    : tactic
-val register_setoid_symmetry_in : (identifier -> tactic) -> unit
-val symmetry_in                 : identifier -> tactic
-val intros_symmetry             : clause -> tactic
-
-val register_setoid_transitivity : (constr option -> tactic) -> unit
-val transitivity_red            : bool -> constr option -> tactic
-val transitivity                : constr -> tactic
-val etransitivity               : tactic
-val intros_transitivity         : constr option -> tactic
-
-val cut                         : constr -> tactic
-val cut_intro                   : constr -> tactic
-val assert_replacing            : identifier -> types -> tactic -> tactic
-val cut_replacing               : identifier -> types -> tactic -> tactic
-val cut_in_parallel             : constr list -> tactic
-
-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 simplest_left        : unit Proofview.tactic
+val simplest_right       : unit Proofview.tactic
+val simplest_split       : unit Proofview.tactic
+
+(** {6 Equality tactics. } *)
+
+val setoid_reflexivity : unit Proofview.tactic Hook.t
+val reflexivity_red             : bool -> unit Proofview.tactic
+val reflexivity                 : unit Proofview.tactic
+val intros_reflexivity          : unit Proofview.tactic
+
+val setoid_symmetry : unit Proofview.tactic Hook.t
+val symmetry_red                : bool -> unit Proofview.tactic
+val symmetry                    : unit Proofview.tactic
+val setoid_symmetry_in : (Id.t -> unit Proofview.tactic) Hook.t
+val intros_symmetry             : clause -> unit Proofview.tactic
+
+val setoid_transitivity : (constr option -> unit Proofview.tactic) Hook.t
+val transitivity_red            : bool -> constr option -> unit Proofview.tactic
+val transitivity                : constr -> unit Proofview.tactic
+val etransitivity               : unit Proofview.tactic
+val intros_transitivity         : constr option -> unit Proofview.tactic
+
+(** {6 Cut tactics. } *)
+
+val assert_before_replacing: Id.t -> types -> unit Proofview.tactic
+val assert_after_replacing : Id.t -> types -> unit Proofview.tactic
+val assert_before : Name.t -> types -> unit Proofview.tactic
+val assert_after  : Name.t -> types -> unit Proofview.tactic
+
+val assert_as     : (* true = before *) bool ->
+  intro_pattern option -> constr -> unit Proofview.tactic
+
+(** Implements the tactics assert, enough and pose proof; note that "by"
+    applies on the first goal for both assert and enough *)
+
+val assert_by  : Name.t -> types -> unit Proofview.tactic ->
+  unit Proofview.tactic
+val enough_by  : Name.t -> types -> unit Proofview.tactic ->
+  unit Proofview.tactic
+val pose_proof : Name.t -> constr ->
+  unit Proofview.tactic
+
+(** Common entry point for user-level "assert", "enough" and "pose proof" *)
+
+val forward   : bool -> unit Proofview.tactic option ->
+  intro_pattern option -> constr -> unit Proofview.tactic
+
+(** Implements the tactic cut, actually a modus ponens rule *)
+
+val cut        : types -> unit Proofview.tactic
+
+(** {6 Tactics for adding local definitions. } *)
+
+val letin_tac : (bool * intro_pattern_naming) option ->
+  Name.t -> constr -> types option -> clause -> unit Proofview.tactic
+
+(** Common entry point for user-level "set", "pose" and "remember" *)
+
+val letin_pat_tac : (bool * intro_pattern_naming) option ->
+  Name.t -> pending_constr -> clause -> unit Proofview.tactic
+
+(** {6 Generalize tactics. } *)
 
 val generalize      : constr list -> tactic
-val generalize_gen  : ((occurrences * constr) * name) list -> tactic
+val generalize_gen  : ((occurrences * constr) * Name.t) list -> tactic
+val new_generalize  : constr list -> unit Proofview.tactic
+val new_generalize_gen  : ((occurrences * constr) * Name.t) list -> unit Proofview.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
+(** {6 Other tactics. } *)
+
+val unify           : ?state:Names.transparent_state -> constr -> constr -> unit Proofview.tactic
+
+val tclABSTRACT : Id.t option -> unit Proofview.tactic -> unit Proofview.tactic
+
+val admit_as_an_axiom : unit Proofview.tactic
+
+val abstract_generalize : ?generalize_vars:bool -> ?force_dep:bool -> Id.t -> unit Proofview.tactic
+val specialize_eqs : Id.t -> tactic
+
+val general_rewrite_clause :
+  (bool -> evars_flag -> constr with_bindings -> clause -> unit Proofview.tactic) Hook.t
+
+val subst_one :
+  (bool -> Id.t -> Id.t * constr * bool -> unit Proofview.tactic) Hook.t
+
+val declare_intro_decomp_eq :
+  ((int -> unit Proofview.tactic) -> Coqlib.coq_eq_data * types *
+   (types * constr * constr) ->
+   constr * types -> unit Proofview.tactic) -> unit
+
+(** {6 Simple form of basic tactics. } *)
+
+module Simple : sig
+  (** Simplified version of some of the above tactics *)
+
+  val intro           : Id.t -> unit Proofview.tactic
+  val generalize      : constr list -> tactic
+  val generalize_gen  : (constr Locus.with_occurrences * Name.t) list -> tactic
+
+  val apply  : constr -> unit Proofview.tactic
+  val eapply : constr -> unit Proofview.tactic
+  val elim   : constr -> unit Proofview.tactic
+  val case   : constr -> unit Proofview.tactic
+  val apply_in : identifier -> constr -> unit Proofview.tactic
+
+end
 
-val tclABSTRACT : identifier option -> tactic -> tactic
+(** {6 Tacticals defined directly in term of Proofview} *)
 
-val admit_as_an_axiom : tactic
+module New : sig
 
-val abstract_generalize : ?generalize_vars:bool -> ?force_dep:bool -> identifier -> tactic
-val specialize_eqs : identifier -> tactic
+  val refine : ?unsafe:bool -> (Evd.evar_map -> Evd.evar_map*constr) -> unit Proofview.tactic
+  (** [refine ?unsafe c] is [Proofview.Refine.refine ?unsafe c]
+      followed by beta-iota-reduction of the conclusion. *)
 
-val register_general_multi_rewrite :
-  (bool -> evars_flag -> constr with_bindings -> clause -> tactic) -> unit
+  val reduce_after_refine : unit Proofview.tactic
+  (** The reducing tactic called after {!refine}. *)
 
-val register_subst_one :
-  (bool -> identifier -> identifier * constr * bool -> tactic) -> unit
+  open Proofview
+  val exact_proof : Constrexpr.constr_expr -> unit tactic
+end
diff --git a/tactics/tactics.mllib b/tactics/tactics.mllib
index f1324809..2c5edc20 100644
--- a/tactics/tactics.mllib
+++ b/tactics/tactics.mllib
@@ -1,21 +1,28 @@
+Ftactic
+Geninterp
+Dnet
 Dn
-Termdn
 Btermdn
-Nbtermdn
 Tacticals
 Hipattern
 Ind_tables
 Eqschemes
 Elimschemes
 Tactics
-Hiddentac
 Elim
-Auto
 Equality
 Contradiction
 Inv
 Leminv
+Tacsubst
+Taccoerce
+Tacenv
+Hints
+Auto
+Tacintern
+Tactic_matching
 Tacinterp
 Evar_tactics
+Term_dnet
 Autorewrite
 Tactic_option
diff --git a/tactics/tauto.ml4 b/tactics/tauto.ml4
index 042e2a7d..4b03ff24 100644
--- a/tactics/tauto.ml4
+++ b/tactics/tauto.ml4
@@ -1,48 +1,58 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i camlp4deps: "parsing/grammar.cma" i*)
+(*i camlp4deps: "grammar/grammar.cma" i*)
 
 open Term
 open Hipattern
 open Names
-open Libnames
 open Pp
-open Proof_type
-open Tacticals
+open Genarg
+open Stdarg
 open Tacinterp
 open Tactics
+open Errors
 open Util
-open Genarg
+
+DECLARE PLUGIN "tauto"
 
 let assoc_var s ist =
-  match List.assoc (Names.id_of_string s) ist.lfun with
-    | VConstr ([],c) -> c
-    | _ -> failwith "tauto: anomaly"
+  let v = Id.Map.find (Names.Id.of_string s) ist.lfun in
+  match Value.to_constr v with
+    | Some c -> c
+    | None -> failwith "tauto: anomaly"
 
 (** Parametrization of tauto *)
 
+type tauto_flags = {
+
 (* Whether conjunction and disjunction are restricted to binary connectives *)
-(* (this is the compatibility mode) *)
-let binary_mode = true
+  binary_mode : bool;
+
+(* Whether compatibility for buggy detection of binary connective is on *)
+  binary_mode_bugged_detection : bool;
 
 (* Whether conjunction and disjunction are restricted to the connectives *)
 (* having the structure of "and" and "or" (up to the choice of sorts) in *)
-(* contravariant position in an hypothesis (this is the compatibility mode) *)
-let strict_in_contravariant_hyp = true
+(* contravariant position in an hypothesis *)
+  strict_in_contravariant_hyp : bool;
 
 (* Whether conjunction and disjunction are restricted to the connectives *)
 (* having the structure of "and" and "or" (up to the choice of sorts) in *)
 (* an hypothesis and in the conclusion *)
-let strict_in_hyp_and_ccl = false
+  strict_in_hyp_and_ccl : bool;
 
 (* Whether unit type includes equality types *)
-let strict_unit = false
+  strict_unit : bool;
+}
+
+(* Whether inner not are unfolded *)
+let negation_unfolding = ref true
 
 (* Whether inner iff are unfolded *)
 let iff_unfolding = ref false
@@ -54,13 +64,26 @@ let _ =
   declare_bool_option
     { optsync  = true;
       optdepr  = false;
-      optname  = "unfolding of iff and not in intuition";
+      optname  = "unfolding of not in intuition";
+      optkey   = ["Intuition";"Negation";"Unfolding"];
+      optread  = (fun () -> !negation_unfolding);
+      optwrite = (:=) negation_unfolding }
+
+let _ =
+  declare_bool_option
+    { optsync  = true;
+      optdepr  = false;
+      optname  = "unfolding of iff in intuition";
       optkey   = ["Intuition";"Iff";"Unfolding"];
       optread  = (fun () -> !iff_unfolding);
       optwrite = (:=) iff_unfolding }
 
 (** Test *)
 
+let make_lfun l =
+  let fold accu (id, v) = Id.Map.add (Id.of_string id) v accu in
+  List.fold_left fold Id.Map.empty l
+
 let is_empty ist =
   if is_empty_type (assoc_var "X1" ist) then
     <:tactic<idtac>>
@@ -69,8 +92,8 @@ let is_empty ist =
 
 (* Strictly speaking, this exceeds the propositional fragment as it
    matches also equality types (and solves them if a reflexivity) *)
-let is_unit_or_eq ist =
-  let test = if strict_unit then is_unit_type else is_unit_or_eq_type in
+let is_unit_or_eq flags ist =
+  let test = if flags.strict_unit then is_unit_type else is_unit_or_eq_type in
   if test (assoc_var "X1" ist) then
     <:tactic<idtac>>
   else
@@ -79,18 +102,18 @@ let is_unit_or_eq ist =
 let is_record t =
   let (hdapp,args) = decompose_app t in
     match (kind_of_term hdapp) with
-      | Ind ind  ->
+      | Ind (ind,u) ->
           let (mib,mip) = Global.lookup_inductive ind in
-	    mib.Declarations.mind_record
+	    mib.Declarations.mind_record <> None
       | _ -> false
 
-let is_binary t =
+let bugged_is_binary t =
   isApp t &&
   let (hdapp,args) = decompose_app t in
     match (kind_of_term hdapp) with
-    | Ind ind  ->
+    | Ind (ind,u)  ->
         let (mib,mip) = Global.lookup_inductive ind in
-	  mib.Declarations.mind_nparams = 2
+         Int.equal mib.Declarations.mind_nparams 2
     | _ -> false
 
 let iter_tac tacl =
@@ -98,70 +121,76 @@ let iter_tac tacl =
 
 (** Dealing with conjunction *)
 
-let is_conj ist =
+let is_conj flags ist =
   let ind = assoc_var "X1" ist in
-    if (not binary_mode || is_binary ind) (* && not (is_record ind) *)
-      && is_conjunction ~strict:strict_in_hyp_and_ccl ind
+    if (not flags.binary_mode_bugged_detection || bugged_is_binary ind) &&
+       is_conjunction
+         ~strict:flags.strict_in_hyp_and_ccl
+         ~onlybinary:flags.binary_mode ind
     then
       <:tactic<idtac>>
     else
       <:tactic<fail>>
 
-let flatten_contravariant_conj ist =
+let flatten_contravariant_conj flags ist =
   let typ = assoc_var "X1" ist in
   let c = assoc_var "X2" ist in
   let hyp = assoc_var "id" ist in
-  match match_with_conjunction ~strict:strict_in_contravariant_hyp typ with
+  match match_with_conjunction
+          ~strict:flags.strict_in_contravariant_hyp
+          ~onlybinary:flags.binary_mode typ
+  with
   | Some (_,args) ->
-      let i = List.length args in
-      if not binary_mode || i = 2 then
-	let newtyp = valueIn (VConstr ([],List.fold_right mkArrow args c)) in
-	let hyp = valueIn (VConstr ([],hyp)) in
-	let intros =
-	  iter_tac (List.map (fun _ -> <:tactic< intro >>) args)
-	  <:tactic< idtac >> in
-	<:tactic<
-          let newtyp := $newtyp in
-          let hyp := $hyp in
-	  assert newtyp by ($intros; apply hyp; split; assumption);
-	  clear hyp
-	>>
-      else
-	<:tactic<fail>>
+      let newtyp = valueIn (Value.of_constr (List.fold_right mkArrow args c)) in
+      let hyp = valueIn (Value.of_constr hyp) in
+      let intros =
+	iter_tac (List.map (fun _ -> <:tactic< intro >>) args)
+	<:tactic< idtac >> in
+      <:tactic<
+        let newtyp := $newtyp in
+        let hyp := $hyp in
+	assert newtyp by ($intros; apply hyp; split; assumption);
+	clear hyp
+      >>
   | _ ->
       <:tactic<fail>>
 
 (** Dealing with disjunction *)
 
-let is_disj ist =
+let constructor i =
+  let name = { Tacexpr.mltac_plugin = "coretactics"; mltac_tactic = "constructor" } in
+  let i = in_gen (rawwit Constrarg.wit_int_or_var) (Misctypes.ArgArg i) in
+  Tacexpr.TacML (Loc.ghost, name, [i])
+
+let is_disj flags ist =
   let t = assoc_var "X1" ist in
-  if (not binary_mode || is_binary t) &&
-    is_disjunction ~strict:strict_in_hyp_and_ccl t
+  if (not flags.binary_mode_bugged_detection || bugged_is_binary t) &&
+     is_disjunction
+       ~strict:flags.strict_in_hyp_and_ccl
+       ~onlybinary:flags.binary_mode t
   then
     <:tactic<idtac>>
   else
     <:tactic<fail>>
 
-let flatten_contravariant_disj ist =
+let flatten_contravariant_disj flags ist =
   let typ = assoc_var "X1" ist in
   let c = assoc_var "X2" ist in
   let hyp = assoc_var "id" ist in
-  match match_with_disjunction ~strict:strict_in_contravariant_hyp typ with
+  match match_with_disjunction
+          ~strict:flags.strict_in_contravariant_hyp
+          ~onlybinary:flags.binary_mode
+          typ with
   | Some (_,args) ->
-      let i = List.length args in
-      if not binary_mode || i = 2 then
-	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
-	    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>>
+      let hyp = valueIn (Value.of_constr hyp) in
+      iter_tac (List.map_i (fun i arg ->
+	let typ = valueIn (Value.of_constr (mkArrow arg c)) in
+	let ci = constructor i in
+	<:tactic<
+          let typ := $typ in
+          let hyp := $hyp in
+	  assert typ by (intro; apply hyp; $ci; assumption)
+	>>) 1 args) <:tactic< let hyp := $hyp in clear hyp >>
   | _ ->
       <:tactic<fail>>
 
@@ -171,30 +200,30 @@ let flatten_contravariant_disj ist =
 let not_dep_intros ist =
   <:tactic<
   repeat match goal with
-  | |- (?X1 -> ?X2) => intro
-  | |- (Coq.Init.Logic.not _)   => unfold Coq.Init.Logic.not at 1
-  | H:(Coq.Init.Logic.not _)|-_    => unfold Coq.Init.Logic.not at 1 in H
-  | H:(Coq.Init.Logic.not _)->_|-_    => unfold Coq.Init.Logic.not at 1 in H
+  | |- (forall (_: ?X1), ?X2) => intro
+  | |- (Coq.Init.Logic.not _) => unfold Coq.Init.Logic.not at 1; intro
   end >>
 
-let axioms ist =
-  let t_is_unit_or_eq = tacticIn is_unit_or_eq
+let axioms flags ist =
+  let t_is_unit_or_eq = tacticIn (is_unit_or_eq flags)
   and t_is_empty = tacticIn is_empty in
+  let c1 = constructor 1 in
     <:tactic<
     match reverse goal with
-      | |- ?X1 => $t_is_unit_or_eq; constructor 1
+      | |- ?X1 => $t_is_unit_or_eq; $c1
       | _:?X1 |- _ => $t_is_empty; elimtype X1; assumption
       | _:?X1 |- ?X1 => assumption
     end >>
 
 
-let simplif ist =
-  let t_is_unit_or_eq = tacticIn is_unit_or_eq
-  and t_is_conj = tacticIn is_conj
-  and t_flatten_contravariant_conj = tacticIn flatten_contravariant_conj
-  and t_flatten_contravariant_disj = tacticIn flatten_contravariant_disj
-  and t_is_disj = tacticIn is_disj
+let simplif flags ist =
+  let t_is_unit_or_eq = tacticIn (is_unit_or_eq flags)
+  and t_is_conj = tacticIn (is_conj flags)
+  and t_flatten_contravariant_conj = tacticIn (flatten_contravariant_conj flags)
+  and t_flatten_contravariant_disj = tacticIn (flatten_contravariant_disj flags)
+  and t_is_disj = tacticIn (is_disj flags)
   and t_not_dep_intros = tacticIn not_dep_intros in
+  let c1 = constructor 1 in
   <:tactic<
     $t_not_dep_intros;
     repeat
@@ -203,25 +232,25 @@ let simplif ist =
         | id: (Coq.Init.Logic.iff _ _) |- _ => elim id; do 2 intro; clear id
         | id: (Coq.Init.Logic.not _) |- _ => red in id
         | id: ?X1 |- _ => $t_is_disj; elim id; intro; clear id
-        | id0: ?X1 -> ?X2, id1: ?X1|- _ =>
+        | id0: (forall (_: ?X1), ?X2), id1: ?X1|- _ =>
 	    (* generalize (id0 id1); intro; clear id0 does not work
 	       (see Marco Maggiesi's bug PR#301)
 	    so we instead use Assert and exact. *)
 	    assert X2; [exact (id0 id1) | clear id0]
-        | id: ?X1 -> ?X2|- _ =>
+        | id: forall (_ : ?X1), ?X2|- _ =>
           $t_is_unit_or_eq; cut X2;
 	    [ intro; clear id
-	    | (* id : ?X1 -> ?X2 |- ?X2 *)
-	      cut X1; [exact id| constructor 1; fail]
+	    | (* id : forall (_: ?X1), ?X2 |- ?X2 *)
+	      cut X1; [exact id| $c1; fail]
 	    ]
-        | id: ?X1 -> ?X2|- _ =>
+        | id: forall (_ : ?X1), ?X2|- _ =>
           $t_flatten_contravariant_conj
 	  (* moved from "id:(?A/\?B)->?X2|-" to "?A->?B->?X2|-" *)
-        | id: (Coq.Init.Logic.iff ?X1 ?X2) -> ?X3|- _ =>
-          assert ((X1 -> X2) -> (X2 -> X1) -> X3)
+        | id: forall (_: Coq.Init.Logic.iff ?X1 ?X2), ?X3|- _ =>
+          assert (forall (_: forall _:X1, X2), forall (_: forall _: X2, X1), X3)
 	    by (do 2 intro; apply id; split; assumption);
             clear id
-        | id: ?X1 -> ?X2|- _ =>
+        | id: forall (_:?X1), ?X2|- _ =>
           $t_flatten_contravariant_disj
 	  (* moved from "id:(?A\/?B)->?X2|-" to "?A->?X2,?B->?X2|-" *)
         | |- ?X1 => $t_is_conj; split
@@ -230,75 +259,140 @@ let simplif ist =
         end;
         $t_not_dep_intros) >>
 
-let rec tauto_intuit t_reduce solver ist =
-  let t_axioms = tacticIn axioms
-  and t_simplif = tacticIn simplif
-  and t_is_disj = tacticIn is_disj
-  and t_tauto_intuit = tacticIn (tauto_intuit t_reduce solver) in
-  let t_solver = globTacticIn (fun _ist -> solver) in
-  <:tactic<
+let rec tauto_intuit flags t_reduce solver =
+  let t_axioms = tacticIn (axioms flags)
+  and t_simplif = tacticIn (simplif flags)
+  and t_is_disj = tacticIn (is_disj flags) in
+  let lfun = make_lfun [("t_solver", solver)] in
+  let ist = { default_ist () with lfun = lfun; } in
+  let vars = [Id.of_string "t_solver"] in
+  (vars, ist, <:tactic<
+   let rec t_tauto_intuit :=
    ($t_simplif;$t_axioms
    || match reverse goal with
-      | id:(?X1 -> ?X2)-> ?X3|- _ =>
+      | id:forall(_: forall (_: ?X1), ?X2), ?X3|- _ =>
 	  cut X3;
-	    [ intro; clear id; $t_tauto_intuit
-	    | cut (X1 -> X2);
+	    [ intro; clear id; t_tauto_intuit
+	    | cut (forall (_: X1), X2);
 		[ exact id
 		| generalize (fun y:X2 => id (fun x:X1 => y)); intro; clear id;
-		  solve [ $t_tauto_intuit ]]]
+		  solve [ t_tauto_intuit ]]]
+      | id:forall (_:not ?X1), ?X3|- _ =>
+	  cut X3;
+	    [ intro; clear id; t_tauto_intuit
+	    | cut (not X1); [ exact id | clear id; intro; solve [t_tauto_intuit ]]]
       | |- ?X1 =>
-          $t_is_disj; solve [left;$t_tauto_intuit | right;$t_tauto_intuit]
+          $t_is_disj; solve [left;t_tauto_intuit | right;t_tauto_intuit]
       end
     ||
     (* NB: [|- _ -> _] matches any product *)
-    match goal with | |- _ -> _ => intro; $t_tauto_intuit
-    |  |- _  => $t_reduce;$t_solver
+    match goal with | |- forall (_ : _),  _ => intro; t_tauto_intuit
+    |  |- _  => $t_reduce;t_solver
     end
     ||
-    $t_solver
-   ) >>
-
-let reduction_not _ist =
-  if unfold_iff () then
-    <:tactic< unfold Coq.Init.Logic.not, Coq.Init.Logic.iff in * >>
-  else
-    <:tactic< unfold Coq.Init.Logic.not in * >>
-
-let t_reduction_not = tacticIn reduction_not
-
-let intuition_gen tac =
-  interp (tacticIn (tauto_intuit t_reduction_not tac))
-
-let tauto_intuitionistic g =
-  try intuition_gen <:tactic<fail>> g
-  with
-    Refiner.FailError _ | UserError _ ->
-      errorlabstrm "tauto" (str "tauto failed.")
+    t_solver
+   ) in t_tauto_intuit >>)
+
+let reduction_not_iff _ist =
+  match !negation_unfolding, unfold_iff () with
+    | true, true -> <:tactic< unfold Coq.Init.Logic.not, Coq.Init.Logic.iff in * >>
+    | true, false -> <:tactic< unfold Coq.Init.Logic.not in * >>
+    | false, true -> <:tactic< unfold Coq.Init.Logic.iff in * >>
+    | false, false -> <:tactic< idtac >>
+
+let t_reduction_not_iff = tacticIn reduction_not_iff
+
+let intuition_gen ist flags tac =
+  Proofview.Goal.enter begin fun gl ->
+  let tac = Value.of_closure ist tac in
+  let env = Proofview.Goal.env gl in
+  let vars, ist, intuition = tauto_intuit flags t_reduction_not_iff tac in
+  let glb_intuition = Tacintern.glob_tactic_env vars env intuition in
+  eval_tactic_ist ist glb_intuition
+  end
+
+let tauto_intuitionistic flags =
+  Proofview.tclORELSE
+    (intuition_gen (default_ist ()) flags <:tactic<fail>>)
+    begin function (e, info) -> match e with
+      | Refiner.FailError _ | UserError _ ->
+          Proofview.tclZERO (UserError ("tauto" , str "tauto failed."))
+      | e -> Proofview.tclZERO ~info e
+    end
 
 let coq_nnpp_path =
-  let dir = List.map id_of_string ["Classical_Prop";"Logic";"Coq"] in
-  Libnames.make_path (make_dirpath dir) (id_of_string "NNPP")
-
-let tauto_classical nnpp g =
-  try tclTHEN (apply nnpp) tauto_intuitionistic g
-  with UserError _ -> errorlabstrm "tauto" (str "Classical tauto failed.")
+  let dir = List.map Id.of_string ["Classical_Prop";"Logic";"Coq"] in
+  Libnames.make_path (DirPath.make dir) (Id.of_string "NNPP")
+
+let tauto_classical flags nnpp =
+  Proofview.tclORELSE
+    (Tacticals.New.tclTHEN (apply nnpp) (tauto_intuitionistic flags))
+    begin function (e, info) -> match e with
+      | UserError _ -> Proofview.tclZERO (UserError ("tauto" , str "Classical tauto failed."))
+      | e -> Proofview.tclZERO ~info e
+    end
 
-let tauto g =
-  try
-    let nnpp = constr_of_global (Nametab.global_of_path coq_nnpp_path) in
+let tauto_gen flags =
+  (* spiwack: I use [tclBIND (tclUNIT ())] as a way to delay the effect
+     (in [constr_of_global]) to the application of the tactic. *)
+  Proofview.tclBIND
+    (Proofview.tclUNIT ())
+    begin fun () -> try
+      let nnpp = Universes.constr_of_global (Nametab.global_of_path coq_nnpp_path) in
     (* try intuitionistic version first to avoid an axiom if possible *)
-    tclORELSE tauto_intuitionistic (tauto_classical nnpp) g
-  with Not_found ->
-    tauto_intuitionistic g
-
+      Tacticals.New.tclORELSE (tauto_intuitionistic flags) (tauto_classical flags nnpp)
+    with Not_found ->
+      tauto_intuitionistic flags
+    end
 
 let default_intuition_tac = <:tactic< auto with * >>
 
+(* This is the uniform mode dealing with ->, not, iff and types isomorphic to
+   /\ and *, \/ and +, False and Empty_set, True and unit, _and_ eq-like types.
+   For the moment not and iff are still always unfolded. *)
+let tauto_uniform_unit_flags = {
+  binary_mode = true;
+  binary_mode_bugged_detection = false;
+  strict_in_contravariant_hyp = true;
+  strict_in_hyp_and_ccl = true;
+  strict_unit = false
+}
+
+(* This is the compatibility mode (not used) *)
+let tauto_legacy_flags = {
+  binary_mode = true;
+  binary_mode_bugged_detection = true;
+  strict_in_contravariant_hyp = true;
+  strict_in_hyp_and_ccl = false;
+  strict_unit = false
+}
+
+(* This is the improved mode *)
+let tauto_power_flags = {
+  binary_mode = false; (* support n-ary connectives *)
+  binary_mode_bugged_detection = false;
+  strict_in_contravariant_hyp = false; (* supports non-regular connectives *)
+  strict_in_hyp_and_ccl = false;
+  strict_unit = false
+}
+
+let tauto = tauto_gen tauto_uniform_unit_flags
+let dtauto = tauto_gen tauto_power_flags
+
 TACTIC EXTEND tauto
 | [ "tauto" ] -> [ tauto ]
 END
 
+TACTIC EXTEND dtauto
+| [ "dtauto" ] -> [ dtauto ]
+END
+
 TACTIC EXTEND intuition
-| [ "intuition" ] -> [ intuition_gen default_intuition_tac ]
-| [ "intuition" tactic(t) ] -> [ intuition_gen t ]
+| [ "intuition" ] -> [ intuition_gen ist tauto_uniform_unit_flags default_intuition_tac ]
+| [ "intuition" tactic(t) ] -> [ intuition_gen ist tauto_uniform_unit_flags t ]
+END
+
+TACTIC EXTEND dintuition
+| [ "dintuition" ] -> [ intuition_gen ist tauto_power_flags default_intuition_tac ]
+| [ "dintuition" tactic(t) ] -> [ intuition_gen ist tauto_power_flags t ]
 END
diff --git a/tactics/term_dnet.ml b/tactics/term_dnet.ml
new file mode 100644
index 00000000..e637b2e3
--- /dev/null
+++ b/tactics/term_dnet.ml
@@ -0,0 +1,388 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i*)
+open Util
+open Term
+open Names
+open Globnames
+open Mod_subst
+open Pp (* debug *)
+(*i*)
+
+
+(* Representation/approximation of terms to use in the dnet:
+ *
+ * - no meta or evar (use ['a pattern] for that)
+ *
+ * - [Rel]s and [Sort]s are not taken into account (that's why we need
+ *   a second pass of linear filterin on the results - it's not a perfect
+ *   term indexing structure)
+
+ * - Foralls and LetIns are represented by a context DCtx (a list of
+ *   generalization, similar to rel_context, and coded with DCons and
+ *   DNil). This allows for matching under an unfinished context
+ *)
+
+module DTerm =
+struct
+
+  type 't t =
+    | DRel
+    | DSort
+    | DRef    of global_reference
+    | DCtx    of 't * 't (* (binding list, subterm) = Prods and LetIns *)
+    | DLambda of 't * 't
+    | DApp    of 't * 't (* binary app *)
+    | DCase   of case_info * 't * 't * 't array
+    | DFix    of int array * int * 't array * 't array
+    | DCoFix  of int * 't array * 't array
+
+    (* special constructors only inside the left-hand side of DCtx or
+       DApp. Used to encode lists of foralls/letins/apps as contexts *)
+    | DCons   of ('t * 't option) * 't
+    | DNil
+
+  (* debug *)
+  let pr_dconstr f : 'a t -> std_ppcmds = function
+    | DRel -> str "*"
+    | DSort -> str "Sort"
+    | DRef _ -> str "Ref"
+    | DCtx (ctx,t) -> f ctx ++ spc() ++ str "|-" ++ spc () ++ f t
+    | DLambda (t1,t2) -> str "fun"++ spc() ++ f t1 ++ spc() ++ str"->" ++ spc() ++ f t2
+    | DApp (t1,t2) -> f t1 ++ spc() ++ f t2
+    | DCase (_,t1,t2,ta) -> str "case"
+    | DFix _ -> str "fix"
+    | DCoFix _ -> str "cofix"
+    | DCons ((t,dopt),tl) -> f t ++ (match dopt with
+	  Some t' -> str ":=" ++ f t'
+	| None -> str "") ++ spc() ++ str "::" ++ spc() ++ f tl
+    | DNil -> str "[]"
+
+  (*
+   * Functional iterators for the t datatype
+   * a.k.a boring and error-prone boilerplate code
+   *)
+
+  let map f = function
+    | (DRel | DSort | DNil | DRef _) as c -> c
+    | DCtx (ctx,c) -> DCtx (f ctx, f c)
+    | DLambda (t,c) -> DLambda (f t, f c)
+    | DApp (t,u) -> DApp (f t,f u)
+    | DCase (ci,p,c,bl) -> DCase (ci, f p, f c, Array.map f bl)
+    | DFix (ia,i,ta,ca) ->
+	DFix (ia,i,Array.map f ta,Array.map f ca)
+    | DCoFix(i,ta,ca) ->
+	DCoFix (i,Array.map f ta,Array.map f ca)
+    | DCons ((t,topt),u) -> DCons ((f t,Option.map f topt), f u)
+
+  let compare_ci ci1 ci2 =
+    let c = ind_ord ci1.ci_ind ci2.ci_ind in
+    if c = 0 then
+      let c = Int.compare ci1.ci_npar ci2.ci_npar in
+      if c = 0 then
+        let c = Array.compare Int.compare ci1.ci_cstr_ndecls ci2.ci_cstr_ndecls in
+        if c = 0 then
+          Array.compare Int.compare ci1.ci_cstr_nargs ci2.ci_cstr_nargs
+        else c
+      else c
+    else c
+
+  let compare cmp t1 t2 = match t1, t2 with
+  | DRel, DRel -> 0
+  | DSort, DSort -> 0
+  | DRef gr1, DRef gr2 -> RefOrdered.compare gr1 gr2
+  | DCtx (tl1, tr1), DCtx (tl2, tr2)
+  | DLambda (tl1, tr1), DCtx (tl2, tr2)
+  | DApp (tl1, tr1), DCtx (tl2, tr2) ->
+    let c = cmp tl1 tl2 in
+    if c = 0 then cmp tr1 tr2 else c
+
+  | DCase (ci1, c1, t1, p1), DCase (ci2, c2, t2, p2) ->
+    let c = cmp c1 c2 in
+    if c = 0 then
+      let c = cmp t1 t2 in
+      if c = 0 then
+        let c = Array.compare cmp p1 p2 in
+        if c = 0 then compare_ci ci1 ci2
+        else c
+      else c
+    else c
+
+  | DFix (i1, j1, tl1, pl1), DFix (i2, j2, tl2, pl2) ->
+    let c = Int.compare j1 j2 in
+    if c = 0 then
+      let c = Array.compare Int.compare i1 i2 in
+      if c = 0 then
+        let c = Array.compare cmp tl1 tl2 in
+        if c = 0 then Array.compare cmp pl1 pl2
+        else c
+      else c
+    else c
+  | DCoFix (i1, tl1, pl1), DCoFix (i2, tl2, pl2) ->
+    let c = Int.compare i1 i2 in
+    if c = 0 then
+      let c = Array.compare cmp tl1 tl2 in
+      if c = 0 then Array.compare cmp pl1 pl2
+      else c
+    else c
+  | _ -> Pervasives.compare t1 t2 (** OK **)
+
+  let fold f acc = function
+    | (DRel | DNil | DSort | DRef _) -> acc
+    | DCtx (ctx,c) -> f (f acc ctx) c
+    | DLambda (t,c) -> f (f acc t) c
+    | DApp (t,u) -> f (f acc t) u
+    | DCase (ci,p,c,bl) -> Array.fold_left f (f (f acc p) c) bl
+    | DFix (ia,i,ta,ca) ->
+	Array.fold_left f (Array.fold_left f acc ta) ca
+    | DCoFix(i,ta,ca) ->
+	Array.fold_left f (Array.fold_left f acc ta) ca
+    | DCons ((t,topt),u) -> f (Option.fold_left f (f acc t) topt) u
+
+  let choose f = function
+    | (DRel | DSort | DNil | DRef _) -> invalid_arg "choose"
+    | DCtx (ctx,c) -> f ctx
+    | DLambda (t,c) -> f t
+    | DApp (t,u) -> f u
+    | DCase (ci,p,c,bl) -> f c
+    | DFix (ia,i,ta,ca) -> f ta.(0)
+    | DCoFix (i,ta,ca) -> f ta.(0)
+    | DCons ((t,topt),u) -> f u
+
+  let dummy_cmp () () = 0
+
+  let fold2 (f:'a -> 'b -> 'c -> 'a) (acc:'a) (c1:'b t) (c2:'c t) : 'a =
+    let head w = map (fun _ -> ()) w in
+    if not (Int.equal (compare dummy_cmp (head c1) (head c2)) 0)
+    then invalid_arg "fold2:compare" else
+      match c1,c2 with
+	| (DRel, DRel | DNil, DNil | DSort, DSort | DRef _, DRef _) -> acc
+	| (DCtx (c1,t1), DCtx (c2,t2)
+	  | DApp (c1,t1), DApp (c2,t2)
+	  | DLambda (c1,t1), DLambda (c2,t2)) -> f (f acc c1 c2) t1 t2
+	| DCase (ci,p1,c1,bl1),DCase (_,p2,c2,bl2) ->
+	    Array.fold_left2 f (f (f acc p1 p2) c1 c2) bl1 bl2
+	| DFix (ia,i,ta1,ca1), DFix (_,_,ta2,ca2) ->
+	    Array.fold_left2 f (Array.fold_left2 f acc ta1 ta2) ca1 ca2
+	| DCoFix(i,ta1,ca1), DCoFix(_,ta2,ca2) ->
+	    Array.fold_left2 f (Array.fold_left2 f acc ta1 ta2) ca1 ca2
+	| DCons ((t1,topt1),u1), DCons ((t2,topt2),u2) ->
+	    f (Option.fold_left2 f (f acc t1 t2) topt1 topt2) u1 u2
+	| _ -> assert false
+
+  let map2 (f:'a -> 'b -> 'c) (c1:'a t) (c2:'b t) : 'c t =
+    let head w = map (fun _ -> ()) w in
+    if not (Int.equal (compare dummy_cmp (head c1) (head c2)) 0)
+    then invalid_arg "map2_t:compare" else
+      match c1,c2 with
+	| (DRel, DRel | DSort, DSort | DNil, DNil | DRef _, DRef _) as cc ->
+	    let (c,_) = cc in c
+	| DCtx (c1,t1), DCtx (c2,t2) -> DCtx (f c1 c2, f t1 t2)
+	| DLambda (t1,c1), DLambda (t2,c2) -> DLambda (f t1 t2, f c1 c2)
+	| DApp (t1,u1), DApp (t2,u2) -> DApp (f t1 t2,f u1 u2)
+	| DCase (ci,p1,c1,bl1), DCase (_,p2,c2,bl2) ->
+	    DCase (ci, f p1 p2, f c1 c2, Array.map2 f bl1 bl2)
+	| DFix (ia,i,ta1,ca1), DFix (_,_,ta2,ca2) ->
+	    DFix (ia,i,Array.map2 f ta1 ta2,Array.map2 f ca1 ca2)
+	| DCoFix (i,ta1,ca1), DCoFix (_,ta2,ca2) ->
+	    DCoFix (i,Array.map2 f ta1 ta2,Array.map2 f ca1 ca2)
+	| DCons ((t1,topt1),u1), DCons ((t2,topt2),u2) ->
+	    DCons ((f t1 t2,Option.lift2 f topt1 topt2), f u1 u2)
+	| _ -> assert false
+
+  let terminal = function
+    | (DRel | DSort | DNil | DRef _) -> true
+    | _ -> false
+
+  let compare t1 t2 = compare dummy_cmp t1 t2
+
+end
+
+(*
+ * Terms discrimination nets
+ * Uses the general dnet datatype on DTerm.t
+ * (here you can restart reading)
+ *)
+
+(*
+ * Construction of the module
+ *)
+
+module type IDENT =
+sig
+  type t
+  val compare : t -> t -> int
+  val subst : substitution -> t -> t
+  val constr_of : t -> constr
+end
+
+module type OPT =
+sig
+  val reduce : constr -> constr
+  val direction : bool
+end
+
+module Make =
+  functor (Ident : IDENT) ->
+  functor (Opt : OPT) ->
+struct
+
+  module TDnet : Dnet.S with type ident=Ident.t
+			and  type 'a structure = 'a DTerm.t
+			and  type meta = int
+    = Dnet.Make(DTerm)(Ident)(Int)
+
+  type t = TDnet.t
+
+  type ident = TDnet.ident
+
+  (** We will freshen metas on the fly, to cope with the implementation defect
+      of Term_dnet which requires metas to be all distinct. *)
+  let fresh_meta =
+    let index = ref 0 in
+    fun () ->
+      let ans = !index in
+      let () = index := succ ans in
+      ans
+
+  open DTerm
+  open TDnet
+
+  let pat_of_constr c : term_pattern =
+    (** To each evar we associate a unique identifier. *)
+    let metas = ref Evar.Map.empty in
+    let rec pat_of_constr c = match kind_of_term c with
+    | Rel _          -> Term DRel
+    | Sort _         -> Term DSort
+    | Var i          -> Term (DRef (VarRef i))
+    | Const (c,u)    -> Term (DRef (ConstRef c))
+    | Ind (i,u)      -> Term (DRef (IndRef i))
+    | Construct (c,u)-> Term (DRef (ConstructRef c))
+    | Term.Meta _    -> assert false
+    | Evar (i,_)     ->
+      let meta =
+        try Evar.Map.find i !metas
+        with Not_found ->
+          let meta = fresh_meta () in
+          let () = metas := Evar.Map.add i meta !metas in
+          meta
+      in
+      Meta meta
+    | Case (ci,c1,c2,ca)     ->
+      Term(DCase(ci,pat_of_constr c1,pat_of_constr c2,Array.map pat_of_constr ca))
+    | Fix ((ia,i),(_,ta,ca)) ->
+      Term(DFix(ia,i,Array.map pat_of_constr ta, Array.map pat_of_constr ca))
+    | CoFix (i,(_,ta,ca))    ->
+      Term(DCoFix(i,Array.map pat_of_constr ta,Array.map pat_of_constr ca))
+    | Cast (c,_,_)   -> pat_of_constr c
+    | Lambda (_,t,c) -> Term(DLambda (pat_of_constr t, pat_of_constr c))
+    | (Prod (_,_,_) | LetIn(_,_,_,_))   ->
+      let (ctx,c) = ctx_of_constr (Term DNil) c in Term (DCtx (ctx,c))
+    | App (f,ca)     ->
+      Array.fold_left (fun c a -> Term (DApp (c,a)))
+        (pat_of_constr f) (Array.map pat_of_constr ca)
+    | Proj (p,c) -> 
+        Term (DApp (Term (DRef (ConstRef (Projection.constant p))), pat_of_constr c))
+
+    and ctx_of_constr ctx c = match kind_of_term c with
+    | Prod (_,t,c)   -> ctx_of_constr (Term(DCons((pat_of_constr t,None),ctx))) c
+    | LetIn(_,d,t,c) -> ctx_of_constr (Term(DCons((pat_of_constr t, Some (pat_of_constr d)),ctx))) c
+    | _ -> ctx,pat_of_constr c
+    in
+    pat_of_constr c
+
+  let empty_ctx : term_pattern -> term_pattern = function
+    | Meta _ as c -> c
+    | Term (DCtx(_,_)) as c -> c
+    | c -> Term (DCtx (Term DNil, c))
+
+  (*
+   * Basic primitives
+   *)
+
+  let empty = TDnet.empty
+
+  let subst s t =
+    let sleaf id = Ident.subst s id in
+    let snode = function
+      | DTerm.DRef gr -> DTerm.DRef (fst (subst_global s gr))
+      | n -> n in
+    TDnet.map sleaf snode t
+
+  let union = TDnet.union
+
+  let add (c:constr) (id:Ident.t) (dn:t) =
+    let c = Opt.reduce c in
+    let c = empty_ctx (pat_of_constr c) in
+    TDnet.add dn c id
+
+
+  let new_meta () = Meta (fresh_meta ())
+
+  let rec remove_cap : term_pattern -> term_pattern = function
+    | Term (DCons (t,u)) -> Term (DCons (t,remove_cap u))
+    | Term DNil -> new_meta()
+    | Meta _ as m -> m
+    | _ -> assert false
+
+  let under_prod : term_pattern -> term_pattern = function
+    | Term (DCtx (t,u)) -> Term (DCtx (remove_cap t,u))
+    | Meta m -> Term (DCtx(new_meta(), Meta m))
+    | _ -> assert false
+
+  (* debug *)
+(*  let rec pr_term_pattern p =
+    (fun pr_t -> function
+       | Term t -> pr_t t
+       | Meta m -> str"["++Pp.int (Obj.magic m)++str"]"
+    ) (pr_dconstr pr_term_pattern) p*)
+
+  let search_pat cpat dpat dn =
+    let whole_c = cpat in
+    (* if we are at the root, add an empty context *)
+    let dpat = under_prod (empty_ctx dpat) in
+    TDnet.Idset.fold
+      (fun id acc ->
+	 let c_id = Opt.reduce (Ident.constr_of id) in
+	 let (ctx,wc) =
+	   try Termops.align_prod_letin whole_c c_id
+	   with Invalid_argument _ -> [],c_id in
+	 let wc,whole_c = if Opt.direction then whole_c,wc else wc,whole_c in
+	 try
+          let _ = Termops.filtering ctx Reduction.CUMUL wc whole_c in
+          id :: acc
+	 with Termops.CannotFilter -> (* msgnl(str"recon "++Termops.print_constr_env (Global.env()) wc); *) acc
+      ) (TDnet.find_match dpat dn) []
+
+  (*
+   * High-level primitives describing specific search problems
+   *)
+
+  let search_pattern dn pat =
+    let pat = Opt.reduce pat in
+    search_pat pat (empty_ctx (pat_of_constr pat)) dn
+
+  let find_all dn = Idset.elements (TDnet.find_all dn)
+
+  let map f dn = TDnet.map f (fun x -> x) dn
+end
+
+module type S =
+sig
+  type t
+  type ident
+
+  val empty : t
+  val add : constr -> ident -> t -> t
+  val union : t -> t -> t
+  val subst : substitution -> t -> t
+  val search_pattern : t -> constr -> ident list
+  val find_all : t -> ident list
+  val map : (ident -> ident) -> t -> t
+end
diff --git a/tactics/term_dnet.mli b/tactics/term_dnet.mli
new file mode 100644
index 00000000..a5c80cc0
--- /dev/null
+++ b/tactics/term_dnet.mli
@@ -0,0 +1,88 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+open Term
+open Mod_subst
+
+(** Dnets on constr terms.
+
+   An instantiation of Dnet on (an approximation of) constr. It
+   associates a term (possibly with Evar) with an
+   identifier. Identifiers must be unique (no two terms sharing the
+   same ident), and there must be a way to recover the full term from
+   the identifier (function constr_of).
+
+   Optionally, a pre-treatment on terms can be performed before adding
+   or searching (reduce). Practically, it is used to do some kind of
+   delta-reduction on terms before indexing them.
+
+   The results returned here are perfect, since post-filtering is done
+   inside here.
+
+   See lib/dnet.mli for more details.
+*)
+
+(** Identifiers to store (right hand side of the association) *)
+module type IDENT = sig
+  type t
+  val compare : t -> t -> int
+
+  (** how to substitute them for storage *)
+  val subst : substitution -> t -> t
+
+  (** how to recover the term from the identifier *)
+  val constr_of : t -> constr
+end
+
+(** Options : *)
+module type OPT = sig
+
+  (** pre-treatment to terms before adding or searching *)
+  val reduce : constr -> constr
+
+  (** direction of post-filtering w.r.t sort subtyping :
+     - true means query <= terms in the structure
+     - false means terms <= query
+ *)
+  val direction : bool
+end
+
+module type S =
+sig
+  type t
+  type ident
+
+  val empty : t
+
+  (** [add c i dn] adds the binding [(c,i)] to [dn]. [c] can be a
+     closed term or a pattern (with untyped Evars). No Metas accepted *)
+  val add : constr -> ident -> t -> t
+
+  (** merge of dnets. Faster than re-adding all terms *)
+  val union : t -> t -> t
+
+  val subst : substitution -> t -> t
+
+  (*
+   * High-level primitives describing specific search problems
+   *)
+
+  (** [search_pattern dn c] returns all terms/patterns in dn
+     matching/matched by c *)
+  val search_pattern : t -> constr -> ident list
+
+  (** [find_all dn] returns all idents contained in dn *)
+  val find_all : t -> ident list
+
+  val map : (ident -> ident) -> t -> t
+end
+
+module Make :
+  functor (Ident : IDENT) ->
+  functor (Opt : OPT) ->
+    S with type ident = Ident.t
diff --git a/tactics/termdn.ml b/tactics/termdn.ml
deleted file mode 100644
index 447ff327..00000000
--- a/tactics/termdn.ml
+++ /dev/null
@@ -1,135 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-open Util
-open Names
-open Nameops
-open Term
-open Pattern
-open Glob_term
-open Libnames
-open Nametab
-
-(* Discrimination nets of terms.
-   See the module dn.ml for further explanations.
-   Eduardo (5/8/97) *)
-module Make =
-  functor (Z : Map.OrderedType) ->
-struct
-
-  module X = struct
-    type t = constr_pattern
-    let compare = Pervasives.compare
-  end
-
-  type term_label = 
-    | GRLabel of global_reference
-    | ProdLabel 
-    | LambdaLabel
-    | SortLabel
-	
-  module Y =  struct 
-     type t = term_label
-        let compare x y = 
-       let make_name n =
-	 match n with
-	 | GRLabel(ConstRef con) -> 
-	     GRLabel(ConstRef(constant_of_kn(canonical_con con)))
-	 | GRLabel(IndRef (kn,i)) ->
-	     GRLabel(IndRef(mind_of_kn(canonical_mind kn),i))
-	 | GRLabel(ConstructRef ((kn,i),j ))->
-	     GRLabel(ConstructRef((mind_of_kn(canonical_mind kn),i),j))
-	 | k -> k
-       in
-	 Pervasives.compare (make_name x) (make_name y)
-  end
-       
-      
-  module Dn = Dn.Make(X)(Y)(Z)
-      
-  type t = Dn.t
-
-  type 'a lookup_res = 'a Dn.lookup_res
-
-(*If we have: f a b c ..., decomp gives: (f,[a;b;c;...])*)
-
-let decomp =
-  let rec decrec acc c = match kind_of_term c with
-    | App (f,l) -> decrec (Array.fold_right (fun a l -> a::l) l acc) f
-    | Cast (c1,_,_) -> decrec acc c1
-    | _ -> (c,acc)
-  in
-  decrec []
-
-let decomp_pat =
-  let rec decrec acc = function
-    | PApp (f,args) -> decrec (Array.to_list args @ acc) f
-    | c -> (c,acc)
-  in
-  decrec []
-
-let constr_pat_discr t =
-  if not (occur_meta_pattern t) then
-    None
-  else
-    match decomp_pat t with
-    | PRef ((IndRef _) as ref), args
-    | PRef ((ConstructRef _ ) as ref), args -> Some (GRLabel ref,args)
-    | PRef ((VarRef v) as ref), args -> Some(GRLabel ref,args)
-    | _ -> None
-
-let constr_pat_discr_st (idpred,cpred) t =
-  match decomp_pat t with
-  | PRef ((IndRef _) as ref), args
-  | PRef ((ConstructRef _ ) as ref), args -> Some (GRLabel ref,args)
-  | PRef ((VarRef v) as ref), args when not (Idpred.mem v idpred) ->
-      Some(GRLabel ref,args)
-  | PVar v, args when not (Idpred.mem v idpred) ->
-      Some(GRLabel (VarRef v),args)
-  | PRef ((ConstRef c) as ref), args when not (Cpred.mem c cpred) ->
-      Some (GRLabel ref, args)
-  | PProd (_, d, c), [] -> Some (ProdLabel, [d ; c])
-  | PLambda (_, d, c), l -> Some (LambdaLabel, [d ; c] @ l)
-  | PSort s, [] -> Some (SortLabel, [])
-  | _ -> None
-
-open Dn
-
-let constr_val_discr t =
-  let c, l = decomp t in
-    match kind_of_term c with
-    | Ind ind_sp -> Label(GRLabel (IndRef ind_sp),l)
-    | Construct cstr_sp -> Label(GRLabel (ConstructRef cstr_sp),l)
-    | Var id -> Label(GRLabel (VarRef id),l)
-    | Const _ -> Everything
-    | _ -> Nothing
-
-let constr_val_discr_st (idpred,cpred) t =
-  let c, l = decomp t in
-    match kind_of_term c with
-    | Const c -> if Cpred.mem c cpred then Everything else Label(GRLabel (ConstRef c),l)
-    | Ind ind_sp -> Label(GRLabel (IndRef ind_sp),l)
-    | Construct cstr_sp -> Label(GRLabel (ConstructRef cstr_sp),l)
-    | Var id when not (Idpred.mem id idpred) -> Label(GRLabel (VarRef id),l)
-    | Prod (n, d, c) -> Label(ProdLabel, [d; c])
-    | Lambda (n, d, c) -> Label(LambdaLabel, [d; c] @ l)
-    | Sort _ -> Label (SortLabel, [])
-    | Evar _ -> Everything
-    | _ -> Nothing
-
-let create = Dn.create
-
-let add dn st = Dn.add dn (constr_pat_discr_st st)
-
-let rmv dn st = Dn.rmv dn (constr_pat_discr_st st)
-
-let lookup dn st t = Dn.lookup dn (constr_val_discr_st st) t
-
-let app f dn = Dn.app f dn
-
-end
diff --git a/tactics/termdn.mli b/tactics/termdn.mli
deleted file mode 100644
index b13d639e..00000000
--- a/tactics/termdn.mli
+++ /dev/null
@@ -1,68 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-open Term
-open Pattern
-open Libnames
-open Names
-
-(** Discrimination nets of terms. *)
-
-(** This module registers actions (typically tactics) mapped to patterns *)
-
-(** 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
-number of nodes of the patterns matching the term. The [transparent_state]
-indicates which constants and variables can be considered as rigid.
-These dnets are able to cope with existential variables as well, which match
-[Everything]. *)
-
-module Make :
-  functor (Z : Map.OrderedType) ->
-sig
-  
-  type t
-    
-  type 'a lookup_res
-    
-  val create : unit -> t
-    
-  (** [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] *)
-    
-  val lookup : t -> transparent_state -> constr -> (constr_pattern * Z.t) list
-    
-  val app : ((constr_pattern * Z.t) -> unit) -> t -> unit
-
-    
-  (**/**)
-  (** These are for Nbtermdn *)
- 
-  type term_label = 
-    | GRLabel of global_reference
-    | ProdLabel 
-    | LambdaLabel
-    | SortLabel
-	
-  val constr_pat_discr_st : transparent_state ->
-    constr_pattern -> (term_label * constr_pattern list) option
-  val constr_val_discr_st : transparent_state ->
-    constr -> (term_label * constr list) lookup_res
-    
-  val constr_pat_discr : constr_pattern -> (term_label * constr_pattern list) option
-  val constr_val_discr : constr -> (term_label * constr list) lookup_res
-    
-  (**/**)
-end