Imported Upstream version 8.2~beta3+dfsgupstream/8.2.beta3+dfsg

37 files changed, 5258 insertions, 2421 deletions

diff --git a/tactics/auto.ml b/tactics/auto.ml
index 3cd1591d..2a5bb95c 100644
--- a/tactics/auto.ml
+++ b/tactics/auto.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: auto.ml 9154 2006-09-20 17:18:18Z corbinea $ *)
+(* $Id: auto.ml 11094 2008-06-10 19:35:23Z herbelin $ *)
 
 open Pp
 open Util
@@ -93,8 +93,8 @@ let empty_se = ([],[],Btermdn.create ())
 
 let add_tac t (l,l',dn) =
   match t.pat with
-      None -> (insert t l, l', dn)
-    | Some pat -> (l, insert t l', Btermdn.add dn (pat,t))
+      None -> if not (List.mem t l) then (insert t l, l', dn) else (l, l', dn)
+    | Some pat -> if not (List.mem t l') then (l, insert t l', Btermdn.add dn (pat,t)) else (l, l', dn)
 
 
 let lookup_tacs (hdc,c) (l,l',dn) =
@@ -137,14 +137,16 @@ end
 
 module Hintdbmap = Gmap
 
-type frozen_hint_db_table = (string,Hint_db.t) Hintdbmap.t 
+type hint_db = Names.transparent_state * Hint_db.t
 
-type hint_db_table = (string,Hint_db.t) Hintdbmap.t ref
+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) = 
@@ -182,23 +184,20 @@ let try_head_pattern c =
   try head_pattern_bound c
   with BoundPattern -> error "Bound head variable"
 
-let make_exact_entry (c,cty) =
+let make_exact_entry pri (c,cty) =
   let cty = strip_outer_cast cty in
   match kind_of_term cty with
     | Prod (_,_,_) -> 
 	failwith "make_exact_entry"
     | _ ->
 	(head_of_constr_reference (List.hd (head_constr cty)),
-	   { pri=0; pat=None; code=Give_exact c })
+	   { pri=(match pri with Some pri -> pri | None -> 0); pat=None; code=Give_exact c })
 
-let dummy_goal =
-  {it={evar_hyps=empty_named_context_val;
-       evar_concl=mkProp;
-       evar_body=Evar_empty;
-       evar_extra=None};
-   sigma=Evd.empty}
+let dummy_goal = 
+  {it = make_evar empty_named_context_val mkProp;
+   sigma = empty}
 
-let make_apply_entry env sigma (eapply,verbose) (c,cty) =
+let make_apply_entry env sigma (eapply,verbose) pri (c,cty) =
   let cty = hnf_constr env sigma cty in
   match kind_of_term cty with
     | Prod _ ->
@@ -207,45 +206,47 @@ let make_apply_entry env sigma (eapply,verbose) (c,cty) =
 	let pat = Pattern.pattern_of_constr 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 eapply & (nmiss <> 0) then begin
-          if verbose then 
+        let nmiss = List.length (clenv_missing ce) in
+	if nmiss = 0 then 
+	  (hd,
+          { pri = (match pri with None -> nb_hyp cty | Some p -> p);
+            pat = Some pat;
+            code = Res_pf(c,{ce with env=empty_env}) })
+	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"); 
+	    str " will only be used by eauto");
           (hd,
-           { pri = nb_hyp cty + nmiss;
-             pat = Some pat;
-             code = ERes_pf(c,{ce with templenv=empty_env}) })
-        end else 
-	  (hd,
-           { pri = nb_hyp cty;
-             pat = Some pat;
-             code = Res_pf(c,{ce with templenv=empty_env}) })
+            { pri = (match pri with None -> nb_hyp cty + nmiss | Some p -> p);
+              pat = Some pat;
+              code = ERes_pf(c,{ce with env=empty_env}) })
+        end
     | _ -> failwith "make_apply_entry"
  
-(* eap is (e,v) with e=true if eapply and v=true if verbose 
+(* flags is (e,v) with e=true if eapply and v=true if verbose 
    c is a constr
    cty is the type of constr *)
 
-let make_resolves env sigma eap c =
+let make_resolves env sigma flags pri c =
   let cty = type_of env sigma c in
   let ents = 
     map_succeed 
       (fun f -> f (c,cty)) 
-      [make_exact_entry; make_apply_entry env sigma (eap,Options.is_verbose())]
+      [make_exact_entry pri; make_apply_entry env sigma flags pri]
   in 
   if ents = [] then
     errorlabstrm "Hint" 
-      (pr_lconstr c ++ spc() ++ str"cannot be used as a hint");
+      (pr_lconstr c ++ spc() ++ 
+        (if fst 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, false)
-       (mkVar hname,  htyp)]
+    [make_apply_entry env sigma (true, false) None
+       (mkVar hname, htyp)]
   with 
     | Failure _ -> []
     | e when Logic.catchable_exception e -> anomaly "make_resolve_hyp"
@@ -270,7 +271,7 @@ let make_trivial env sigma c =
   let ce = mk_clenv_from dummy_goal (c,t) in
   (hd, { pri=1;
          pat = Some (Pattern.pattern_of_constr (clenv_type ce));
-         code=Res_pf_THEN_trivial_fail(c,{ce with templenv=empty_env}) })
+         code=Res_pf_THEN_trivial_fail(c,{ce with env=empty_env}) })
 
 open Vernacexpr
 
@@ -278,18 +279,32 @@ open Vernacexpr
 (*               declaration of the AUTOHINT library object               *)
 (**************************************************************************)
 
+let add_hint_list hintlist (st,db) =
+  let db' = Hint_db.add_list hintlist db in
+  let st' = 
+    List.fold_left 
+      (fun (ids, csts as st) (_, hint) -> 
+	match hint.code with
+	  | Unfold_nth egr ->
+	      (match egr with
+		| EvalVarRef id -> (Idpred.add id ids, csts)
+		| EvalConstRef cst -> (ids, Cpred.add cst csts))
+	  | _ -> st)
+      st hintlist
+  in (st', db')
+
 (* If the database does not exist, it is created *)
 (* TODO: should a warning be printed in this case ?? *)
 let add_hint dbname hintlist = 
   try 
     let db = searchtable_map dbname in
-    let db' = Hint_db.add_list hintlist db in
+    let db' = add_hint_list hintlist db in
     searchtable_add (dbname,db')
   with Not_found -> 
-    let db = Hint_db.add_list hintlist Hint_db.empty in
+    let db = add_hint_list hintlist (empty_transparent_state, Hint_db.empty) in
     searchtable_add (dbname,db)
 
-let cache_autohint (_,(local,name,hintlist)) = add_hint name hintlist
+let cache_autohint (_,(local,name,hints)) = add_hint name hints
 
 let forward_subst_tactic = 
   ref (fun _ -> failwith "subst_tactic is not installed for auto")
@@ -300,7 +315,7 @@ let subst_autohint (_,subst,(local,name,hintlist as obj)) =
   let trans_clenv clenv = Clenv.subst_clenv subst clenv in
   let trans_data data code = 	      
     { data with
-	pat = option_smartmap (subst_pattern subst) data.pat ;
+	pat = Option.smartmap (subst_pattern subst) data.pat ;
 	code = code ;
     }
   in
@@ -367,7 +382,8 @@ let add_resolves env sigma clist local dbnames =
        Lib.add_anonymous_leaf
 	 (inAutoHint
 	    (local,dbname,
-     	     List.flatten (List.map (make_resolves env sigma true) clist))))
+     	     List.flatten (List.map (fun (x, y) ->
+	       make_resolves env sigma (true,Flags.is_verbose()) x y) clist))))
     dbnames
 
 
@@ -411,29 +427,30 @@ let add_hints local dbnames0 h =
   let f = Constrintern.interp_constr sigma env in
   match h with
   | HintsResolve lhints ->	
-      add_resolves env sigma (List.map f lhints) local dbnames
+      add_resolves env sigma (List.map (fun (pri, x) -> pri, f x) lhints) local dbnames
   | HintsImmediate lhints ->
       add_trivials env sigma (List.map f lhints) local dbnames
   | HintsUnfold lhints ->
-      let f qid =
-	let r = Nametab.global qid in
-        let r' = match r with
+      let f r =
+	let gr = Syntax_def.global_with_alias r in
+        let r' = match gr with
          | ConstRef c -> EvalConstRef c
          | VarRef c -> EvalVarRef c
          | _ -> 
            errorlabstrm "evalref_of_ref"
-            (str "Cannot coerce" ++ spc () ++ pr_global r ++ spc () ++
+            (str "Cannot coerce" ++ spc () ++ pr_global gr ++ spc () ++
              str "to an evaluable reference")
         in
-	 (r,r') in
+	  if !Flags.dump then Constrintern.add_glob (loc_of_reference r) gr;
+	 (gr,r') in
       add_unfolds (List.map f lhints) local dbnames
   | HintsConstructors lqid ->
       let add_one qid =
         let env = Global.env() and sigma = Evd.empty in
-        let isp = global_inductive qid in
+        let isp = inductive_of_reference qid in
         let consnames = (snd (Global.lookup_inductive isp)).mind_consnames in
         let lcons = list_tabulate
-          (fun i -> mkConstruct (isp,i+1)) (Array.length consnames) in
+          (fun i -> None, mkConstruct (isp,i+1)) (Array.length consnames) in
         add_resolves env sigma lcons local dbnames in
       List.iter add_one lqid
   | HintsExtern (pri, patcom, tacexp) ->
@@ -476,7 +493,7 @@ let fmt_hint_list_for_head c =
   let dbs = Hintdbmap.to_list !searchtable in
   let valid_dbs = 
     map_succeed 
-      (fun (name,db) -> (name,db,Hint_db.map_all c db)) 
+      (fun (name,(_,db)) -> (name,db,Hint_db.map_all c db)) 
       dbs 
   in
   if valid_dbs = [] then 
@@ -502,11 +519,11 @@ let fmt_hint_term cl =
     let valid_dbs = 
       if occur_existential cl then 
 	map_succeed 
-	  (fun (name, db) -> (name, db, Hint_db.map_all hd db)) 
+	  (fun (name, (_, db)) -> (name, db, Hint_db.map_all hd db)) 
 	  dbs
       else 
 	map_succeed 
-	  (fun (name, db) -> 
+	  (fun (name, (_, db)) -> 
 	     (name, db, Hint_db.map_auto (hd,applist(hdc,args)) db)) 
 	  dbs
     in 
@@ -527,7 +544,10 @@ let print_applicable_hint () =
   print_hint_term (pf_concl gl)
     
 (* displays the whole hint database db *)
-let print_hint_db db =
+let print_hint_db ((ids, csts),db) =
+  msg (hov 0
+	  (str"Unfoldable variable definitions: " ++ pr_idpred ids ++ fnl () ++
+	   str"Unfoldable constant definitions: " ++ pr_cpred csts ++ fnl ()));
   Hint_db.iter 
     (fun head hintlist ->
        msg (hov 0 
@@ -559,22 +579,38 @@ let print_searchtable () =
 
 let priority l = List.map snd (List.filter (fun (pr,_) -> pr = 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 = false;
+  modulo_delta = empty_transparent_state;
+}
 
 (* Try unification with the precompiled clause, then use registered Apply *)
 
-let unify_resolve (c,clenv) gls = 
+let unify_resolve_nodelta (c,clenv) gls = 
   let clenv' = connect_clenv gls clenv in
-  let _ = clenv_unique_resolver false clenv' gls in  
+  let _ = clenv_unique_resolver false ~flags:auto_unif_flags clenv' gls in  
   h_simplest_apply c gls
 
+let unify_resolve flags (c,clenv) gls = 
+  let clenv' = connect_clenv gls clenv in
+  let _ = clenv_unique_resolver false ~flags clenv' gls in  
+  h_apply true false (c,NoBindings) gls
+
+
 (* builds a hint database from a constr signature *)
 (* typically used with (lid, ltyp) = pf_hyps_types <some goal> *)
 
-let make_local_hint_db lems g =
+let make_local_hint_db eapply lems g =
   let sign = pf_hyps g in
   let hintlist = list_map_append (pf_apply make_resolve_hyp g) sign in
-  let hintlist' = list_map_append (pf_apply make_resolves g true) lems in
-  Hint_db.add_list hintlist' (Hint_db.add_list hintlist Hint_db.empty)
+  let hintlist' = list_map_append (pf_apply make_resolves g (eapply,false) None) lems in
+    (empty_transparent_state, Hint_db.add_list hintlist' (Hint_db.add_list hintlist Hint_db.empty))
 
 (* 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
@@ -607,47 +643,90 @@ let conclPattern concl pat tac gl =
 (* 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 rec trivial_fail_db db_list local_db gl =
+let rec trivial_fail_db mod_delta db_list local_db gl =
   let intro_tac = 
     tclTHEN intro 
       (fun g'->
 	 let hintl = make_resolve_hyp (pf_env g') (project g') (pf_last_hyp g')
-	 in trivial_fail_db db_list (Hint_db.add_list hintl local_db) g')
+	 in trivial_fail_db mod_delta db_list (add_hint_list hintl local_db) g')
   in
   tclFIRST 
     (assumption::intro_tac::
      (List.map tclCOMPLETE 
-	(trivial_resolve db_list local_db (pf_concl gl)))) gl
+       (trivial_resolve mod_delta db_list local_db (pf_concl gl)))) gl
 
-and my_find_search db_list local_db hdc concl =
+and my_find_search_nodelta db_list local_db hdc concl =
   let tacl = 
     if occur_existential concl then 
-      list_map_append (fun db -> Hint_db.map_all hdc db) (local_db::db_list)
-    else 
-      list_map_append (fun db -> Hint_db.map_auto (hdc,concl) db)
+      list_map_append
+	(fun (st, db) -> (Hint_db.map_all hdc db))
+	(local_db::db_list)
+    else
+      list_map_append (fun (_, db) -> 
+	Hint_db.map_auto (hdc,concl) db)
       	(local_db::db_list)
   in
-  List.map 
-    (fun {pri=b; pat=p; code=t} -> 
-       (b,
+    List.map 
+      (fun {pri=b; pat=p; code=t} -> 
+	(b,
 	match t with
-	  | Res_pf (term,cl)  -> unify_resolve (term,cl)
+	  | Res_pf (term,cl) -> unify_resolve_nodelta (term,cl)
 	  | ERes_pf (_,c) -> (fun gl -> error "eres_pf")
 	  | Give_exact c  -> exact_check c
 	  | Res_pf_THEN_trivial_fail (term,cl) -> 
 	      tclTHEN 
-		(unify_resolve (term,cl)) 
-		(trivial_fail_db db_list local_db)
-	  | Unfold_nth c -> unfold_in_concl [[],c]
+		(unify_resolve_nodelta (term,cl)) 
+		(trivial_fail_db false db_list local_db)
+	  | Unfold_nth c -> unfold_in_concl [all_occurrences,c]
 	  | Extern tacast -> 
-	      conclPattern concl (out_some p) tacast))
+	      conclPattern concl (Option.get p) tacast))
     tacl
 
-and trivial_resolve db_list local_db cl = 
+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 = true} in
+  let tacl = 
+    if occur_existential concl then 
+      list_map_append
+	(fun (st, db) -> 
+	  let st = {flags with modulo_delta = st} in
+	    List.map (fun x -> (st,x)) (Hint_db.map_all hdc db))
+	(local_db::db_list)
+    else
+      list_map_append (fun ((ids, csts as st), db) -> 
+	let st, l = 
+	  let l =
+	    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
+	in List.map (fun x -> (st,x)) l)
+      	(local_db::db_list)
+  in
+    List.map 
+      (fun (st, {pri=b; pat=p; code=t}) -> 
+	(b,
+	match t with
+	  | Res_pf (term,cl) -> unify_resolve st (term,cl)
+	  | ERes_pf (_,c) -> (fun gl -> error "eres_pf")
+	  | Give_exact c  -> exact_check c
+	  | Res_pf_THEN_trivial_fail (term,cl) -> 
+	      tclTHEN 
+		(unify_resolve st (term,cl)) 
+		(trivial_fail_db true db_list local_db)
+	  | Unfold_nth c -> unfold_in_concl [all_occurrences,c]
+	  | Extern tacast -> 
+	      conclPattern concl (Option.get p) tacast))
+      tacl
+      
+and trivial_resolve mod_delta db_list local_db cl = 
   try 
     let hdconstr = List.hd (head_constr_bound cl []) in
     priority 
-      (my_find_search db_list local_db (head_of_constr_reference hdconstr) cl)
+      (my_find_search mod_delta db_list local_db (head_of_constr_reference hdconstr) cl)
   with Bound | Not_found -> 
     []
 
@@ -661,30 +740,33 @@ let trivial lems dbnames gl =
 	   error ("trivial: "^x^": No such Hint database"))
       ("core"::dbnames) 
   in
-  tclTRY (trivial_fail_db db_list (make_local_hint_db lems gl)) gl 
+  tclTRY (trivial_fail_db false db_list (make_local_hint_db false lems gl)) gl 
     
 let full_trivial lems gl =
   let dbnames = Hintdbmap.dom !searchtable in
   let dbnames = list_subtract dbnames ["v62"] in
   let db_list = List.map (fun x -> searchtable_map x) dbnames in
-  tclTRY (trivial_fail_db db_list (make_local_hint_db lems gl)) gl
+  tclTRY (trivial_fail_db false db_list (make_local_hint_db false lems gl)) gl
 
 let gen_trivial lems = function
   | None -> full_trivial lems
   | Some l -> trivial lems l
 
+let inj_open c = (Evd.empty,c)
+
 let h_trivial lems l =
-  Refiner.abstract_tactic (TacTrivial (lems,l)) (gen_trivial lems l)
+  Refiner.abstract_tactic (TacTrivial (List.map inj_open lems,l))
+    (gen_trivial lems l)
 
 (**************************************************************************)
 (*                       The classical Auto tactic                        *)
 (**************************************************************************)
 
-let possible_resolve db_list local_db cl =
+let possible_resolve mod_delta db_list local_db cl =
   try 
     let hdconstr = List.hd (head_constr_bound cl []) in
     List.map snd 
-      (my_find_search db_list local_db (head_of_constr_reference hdconstr) cl)
+      (my_find_search mod_delta db_list local_db (head_of_constr_reference hdconstr) cl)
   with Bound | Not_found -> 
     []
 
@@ -710,7 +792,7 @@ let decomp_empty_term c gls =
 (* n is the max depth of search *)
 (* local_db contains the local Hypotheses *)
 
-let rec search_gen decomp n db_list local_db extra_sign goal =
+let rec search_gen decomp n mod_delta db_list local_db extra_sign goal =
   if n=0 then error "BOUND 2";
   let decomp_tacs = match decomp with 
     | 0 -> [] 
@@ -721,7 +803,7 @@ let rec search_gen decomp n db_list local_db extra_sign goal =
 	   (fun id -> tclTHENSEQ
                [decomp_unary_term (mkVar id);
                 clear [id];
-		search_gen decomp p db_list local_db []])
+		search_gen decomp p mod_delta db_list local_db []])
 	   (pf_ids_of_hyps goal)) 
   in
   let intro_tac = 
@@ -731,18 +813,18 @@ let rec search_gen decomp n db_list local_db extra_sign goal =
 	 let hintl = 
 	   try 
 	     [make_apply_entry (pf_env g') (project g')
-		(true,false) 
+		(true,false) None
 		(mkVar hid, htyp)]
 	   with Failure _ -> [] 
 	 in
-         search_gen decomp n db_list (Hint_db.add_list hintl local_db) [d] g') 
+         search_gen decomp n mod_delta db_list (add_hint_list hintl local_db) [d] g') 
   in
   let rec_tacs = 
     List.map 
       (fun ntac -> 
 	 tclTHEN ntac
-	   (search_gen decomp (n-1) db_list local_db empty_named_context))
-      (possible_resolve db_list local_db (pf_concl goal))
+	   (search_gen decomp (n-1) mod_delta db_list local_db empty_named_context))
+      (possible_resolve mod_delta db_list local_db (pf_concl goal))
   in 
   tclFIRST (assumption::(decomp_tacs@(intro_tac::rec_tacs))) goal
 
@@ -751,7 +833,7 @@ let search = search_gen 0
 
 let default_search_depth = ref 5
 
-let auto n lems dbnames gl =
+let delta_auto mod_delta n lems dbnames gl =
   let db_list = 
     List.map
       (fun x -> 
@@ -762,17 +844,24 @@ let auto n lems dbnames gl =
       ("core"::dbnames) 
   in
   let hyps = pf_hyps gl in
-  tclTRY (search n db_list (make_local_hint_db lems gl) hyps) gl
+  tclTRY (search n mod_delta db_list (make_local_hint_db false lems gl) hyps) gl
+
+let auto = delta_auto false
+
+let new_auto = delta_auto true
 
 let default_auto = auto !default_search_depth [] []
 
-let full_auto n lems gl = 
+let delta_full_auto mod_delta n lems gl = 
   let dbnames = Hintdbmap.dom !searchtable in
   let dbnames = list_subtract dbnames ["v62"] in
   let db_list = List.map (fun x -> searchtable_map x) dbnames in
   let hyps = pf_hyps gl in
-  tclTRY (search n db_list (make_local_hint_db lems gl) hyps) gl
-  
+  tclTRY (search n mod_delta db_list (make_local_hint_db false lems gl) hyps) gl
+
+let full_auto = delta_full_auto false
+let new_full_auto = delta_full_auto true
+
 let default_full_auto gl = full_auto !default_search_depth [] gl
 
 let gen_auto n lems dbnames =
@@ -781,10 +870,11 @@ let gen_auto n lems dbnames =
   | None -> full_auto n lems
   | Some l -> auto n lems l
 
-let inj_or_var = option_map (fun n -> ArgArg n)
+let inj_or_var = Option.map (fun n -> ArgArg n)
 
 let h_auto n lems l =
-  Refiner.abstract_tactic (TacAuto (inj_or_var n,lems,l)) (gen_auto n lems l)
+  Refiner.abstract_tactic (TacAuto (inj_or_var n,List.map inj_open lems,l))
+    (gen_auto n lems l)
 
 (**************************************************************************)
 (*                  The "destructing Auto" from Eduardo                   *)
@@ -796,23 +886,23 @@ let h_auto n lems l =
    l'instant *)
 let default_search_decomp = ref 1
 
-let destruct_auto des_opt n gl = 
+let destruct_auto des_opt lems n gl = 
   let hyps = pf_hyps gl in
-  search_gen des_opt n [searchtable_map "core"] 
-    (make_local_hint_db [] gl) hyps gl
+  search_gen des_opt n false (List.map searchtable_map ["core";"extcore"])
+    (make_local_hint_db false lems gl) hyps gl
     
-let dautomatic des_opt n = tclTRY (destruct_auto des_opt n)
+let dautomatic des_opt lems n = tclTRY (destruct_auto des_opt lems n)
 
-let default_dauto = dautomatic !default_search_decomp !default_search_depth
+let dauto (n,p) lems =
+  let p = match p with Some p -> p | None -> !default_search_decomp in
+  let n = match n with Some n -> n | None -> !default_search_depth in
+  dautomatic p lems n
 
-let dauto = function
-  | None, None     -> default_dauto
-  | Some n, None   -> dautomatic !default_search_decomp n
-  | Some n, Some p -> dautomatic p n
-  | None, Some p   -> dautomatic p !default_search_depth
+let default_dauto = dauto (None,None) []
 
-let h_dauto (n,p) =
-  Refiner.abstract_tactic (TacDAuto (inj_or_var n,p)) (dauto (n,p))
+let h_dauto (n,p) lems =
+  Refiner.abstract_tactic (TacDAuto (inj_or_var n,p,List.map inj_open lems))
+    (dauto (n,p) lems)
 
 (***************************************)
 (*** A new formulation of Auto *********)
@@ -822,7 +912,7 @@ let make_resolve_any_hyp env sigma (id,_,ty) =
   let ents = 
     map_succeed
       (fun f -> f (mkVar id,ty)) 
-      [make_exact_entry; make_apply_entry env sigma (true,false)]
+      [make_exact_entry None; make_apply_entry env sigma (true,false) None]
   in 
   ents
 
@@ -866,14 +956,14 @@ let rec super_search n db_list local_db argl goal =
      (tclTHEN intro 
         (fun g -> 
 	   let hintl = pf_apply make_resolve_any_hyp g (pf_last_hyp g) in
-	   super_search n db_list (Hint_db.add_list hintl local_db)
+	   super_search n db_list (add_hint_list hintl local_db)
 	     argl g))
      ::
      ((List.map 
          (fun ntac -> 
             tclTHEN ntac 
               (super_search (n-1) db_list local_db argl))
-         (possible_resolve db_list local_db (pf_concl goal)))
+         (possible_resolve false db_list local_db (pf_concl goal)))
       @
       (compileAutoArgList  
          (super_search (n-1) db_list local_db argl) argl))) goal
@@ -884,7 +974,7 @@ let search_superauto n to_add argl g =
       (fun (id,c) -> add_named_decl (id, None, pf_type_of g c))
       to_add empty_named_context in
   let db0 = list_map_append (make_resolve_hyp (pf_env g) (project g)) sigma in
-  let db = Hint_db.add_list db0 (make_local_hint_db [] g) in
+  let db = add_hint_list db0 (make_local_hint_db false [] g) in
   super_search n [Hintdbmap.find "core" !searchtable] db argl g
 
 let superauto n to_add argl  = 
@@ -892,8 +982,8 @@ let superauto n to_add argl  =
 
 let default_superauto g = superauto !default_search_depth [] [] g
 
-let interp_to_add gl locqid =
-  let r = Nametab.global locqid in
+let interp_to_add gl r =
+  let r = Syntax_def.locate_global_with_alias (qualid_of_reference r) in
   let id = id_of_global r in
   (next_ident_away id (pf_ids_of_hyps gl), constr_of_global r)
 
diff --git a/tactics/auto.mli b/tactics/auto.mli
index ecd20f0d..37406a30 100644
--- a/tactics/auto.mli
+++ b/tactics/auto.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: auto.mli 7937 2006-01-28 19:58:11Z herbelin $ i*)
+(*i $Id: auto.mli 10868 2008-04-29 12:30:25Z msozeau $ i*)
 
 (*i*)
 open Util
@@ -58,10 +58,14 @@ module Hint_db :
 
 type hint_db_name = string
 
-val searchtable_map : hint_db_name -> Hint_db.t
+type hint_db = transparent_state * Hint_db.t
+
+val searchtable_map : hint_db_name -> hint_db
 
 val current_db_names : unit -> hint_db_name list
 
+val add_hint_list : (global_reference * pri_auto_tactic) list -> hint_db -> hint_db
+
 val add_hints : locality_flag -> hint_db_name list -> hints -> unit
 
 val print_searchtable : unit -> unit
@@ -72,19 +76,19 @@ val print_hint_ref : global_reference -> unit
 
 val print_hint_db_by_name : hint_db_name -> unit
 
-(* [make_exact_entry hint_name (c, ctyp)]. 
+(* [make_exact_entry pri (c, ctyp)]. 
    [c] is the term given as an exact proof to solve the goal;
-   [ctyp] is the type of [hc]. *)
+   [ctyp] is the type of [c]. *)
 
-val make_exact_entry : constr * constr -> global_reference * pri_auto_tactic
+val make_exact_entry : int option -> constr * constr -> global_reference * pri_auto_tactic
 
-(* [make_apply_entry (eapply,verbose) (c,cty)].
+(* [make_apply_entry (eapply,verbose) pri (c,cty)].
    [eapply] is true if this hint will be used only with EApply;
    [c] is the term given as an exact proof to solve the goal;
    [cty] is the type of [hc]. *)
 
 val make_apply_entry :
-  env -> evar_map -> bool * bool -> constr * constr
+  env -> evar_map -> bool * bool -> int option -> constr * constr
       -> global_reference * pri_auto_tactic
 
 (* A constr which is Hint'ed will be:
@@ -95,7 +99,7 @@ val make_apply_entry :
        has missing arguments. *)
 
 val make_resolves :
-  env -> evar_map -> bool -> constr -> 
+  env -> evar_map -> bool * bool -> int option -> constr -> 
       (global_reference * pri_auto_tactic) list
 
 (* [make_resolve_hyp hname htyp].
@@ -125,16 +129,21 @@ val set_extern_subst_tactic :
   -> unit
 
 (* Create a Hint database from the pairs (name, constr).
-   Useful to take the current goal hypotheses as hints *)
+   Useful to take the current goal hypotheses as hints;
+   Boolean tells if lemmas with evars are allowed *)
 
-val make_local_hint_db : constr list -> goal sigma -> Hint_db.t
+val make_local_hint_db : bool -> constr list -> goal sigma -> hint_db
 
 val priority : (int * 'a) list -> 'a list
 
 val default_search_depth : int ref
 
+val auto_unif_flags : Unification.unify_flags
+
 (* Try unification with the precompiled clause, then use registered Apply *)
-val unify_resolve : (constr * clausenv) -> tactic
+val unify_resolve_nodelta : (constr * clausenv) -> tactic
+
+val unify_resolve : Unification.unify_flags -> (constr * clausenv) -> tactic
 
 (* [ConclPattern concl pat tacast]:
    if the term concl matches the pattern pat, (in sense of 
@@ -147,12 +156,20 @@ val conclPattern : constr -> constr_pattern -> Tacexpr.glob_tactic_expr -> tacti
 
 val auto : int -> constr list -> hint_db_name list -> tactic
 
+(* Auto with more delta. *)
+
+val new_auto : int -> constr list -> hint_db_name list -> tactic
+
 (* auto with default search depth and with the hint database "core" *)
 val default_auto : tactic
 
 (* auto with all hint databases except the "v62" compatibility database *)
 val full_auto : int -> constr list -> tactic
 
+(* auto with all hint databases except the "v62" compatibility database
+   and doing delta *)
+val new_full_auto : int -> constr list -> tactic
+
 (* auto with default search depth and with all hint databases 
    except the "v62" compatibility database *)
 val default_full_auto : tactic
@@ -174,11 +191,11 @@ val fmt_autotactic : auto_tactic -> Pp.std_ppcmds
 (*s The following is not yet up to date -- Papageno. *)
 
 (* DAuto *)
-val dauto : int option * int option -> tactic
+val dauto : int option * int option -> constr list -> tactic
 val default_search_decomp : int ref
 val default_dauto : tactic
 
-val h_dauto : int option * int option -> tactic
+val h_dauto : int option * int option -> constr list -> tactic
 (* SuperAuto *)
 
 type autoArguments =
diff --git a/tactics/autorewrite.ml b/tactics/autorewrite.ml
index 872b8697..1d096ec7 100644
--- a/tactics/autorewrite.ml
+++ b/tactics/autorewrite.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: autorewrite.ml 9157 2006-09-21 15:10:08Z herbelin $ *)
+(* $Id: autorewrite.ml 11094 2008-06-10 19:35:23Z herbelin $ *)
 
 open Equality
 open Hipattern
@@ -17,7 +17,9 @@ open Tacticals
 open Tacinterp
 open Tactics
 open Term
+open Termops
 open Util
+open Rawterm
 open Vernacinterp
 open Tacexpr
 open Mod_subst
@@ -80,9 +82,12 @@ let one_base general_rewrite_maybe_in tac_main bas =
 let autorewrite tac_main lbas =
   tclREPEAT_MAIN (tclPROGRESS
     (List.fold_left (fun tac bas -> 
-       tclTHEN tac (one_base general_rewrite tac_main bas)) tclIDTAC lbas))
+       tclTHEN tac
+        (one_base (fun dir -> general_rewrite dir all_occurrences)
+	  tac_main bas))
+      tclIDTAC lbas))
 
-let autorewrite_mutlti_in idl tac_main lbas : tactic =
+let autorewrite_multi_in idl tac_main lbas : tactic =
   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
@@ -96,7 +101,7 @@ let autorewrite_mutlti_in idl tac_main lbas : tactic =
       | _ -> (* even the hypothesis id is missing *)
              error ("No such hypothesis : " ^ (string_of_id !id))
     in
-    let gl' = general_rewrite_in dir !id cstr gl in
+    let gl' = general_rewrite_in dir all_occurrences !id cstr false gl in
     let gls = (fst gl').Evd.it in
     match gls with
        g::_ ->
@@ -126,13 +131,15 @@ let autorewrite_mutlti_in idl tac_main lbas : tactic =
        tclTHEN tac (one_base (general_rewrite_in id) tac_main bas)) tclIDTAC lbas)))
    idl gl
 
-let autorewrite_in id = autorewrite_mutlti_in [id]
+let autorewrite_in id = autorewrite_multi_in [id]
 
 let gen_auto_multi_rewrite tac_main lbas cl = 
   let try_do_hyps treat_id l = 
-    autorewrite_mutlti_in (List.map treat_id l) tac_main lbas
+    autorewrite_multi_in (List.map treat_id l) tac_main lbas
   in 
-  if cl.concl_occs <> [] then 
+  if cl.concl_occs <> all_occurrences_expr &
+     cl.concl_occs <> no_occurrences_expr
+  then 
     error "The \"at\" syntax isn't available yet for the autorewrite tactic"
   else 
     let compose_tac t1 t2 = 
@@ -141,7 +148,7 @@ let gen_auto_multi_rewrite tac_main lbas cl =
 	| _ ->      tclTHENFIRST t1 t2
     in
     compose_tac
-	(if cl.onconcl then autorewrite tac_main lbas else tclIDTAC)
+	(if cl.concl_occs <> no_occurrences_expr then autorewrite tac_main lbas else tclIDTAC)
 	(match cl.onhyps with 
 	   | Some l -> try_do_hyps (fun ((_,id),_) -> id) l
 	   | None -> 
@@ -153,11 +160,12 @@ let gen_auto_multi_rewrite tac_main lbas cl =
 
 let auto_multi_rewrite = gen_auto_multi_rewrite Refiner.tclIDTAC
 
-let auto_multi_rewrite_with tac_main lbas cl gl = 
-  match cl.Tacexpr.onconcl,cl.Tacexpr.onhyps with 
+let auto_multi_rewrite_with tac_main lbas cl gl =
+  let onconcl = cl.Tacexpr.concl_occs <> no_occurrences_expr in
+  match onconcl,cl.Tacexpr.onhyps with 
     | false,Some [_] | true,Some [] | false,Some [] ->   
 	(* autorewrite with .... in clause using tac n'est sur que 
-	   si clause reprensente soit le but soit UNE hypothse 
+	   si clause represente soit le but soit UNE hypothese 
 	*)
 	gen_auto_multi_rewrite tac_main  lbas cl gl
     | _ -> 
@@ -207,7 +215,7 @@ let classify_hintrewrite (_,x) = Libobject.Substitute x
 
 
 (* Declaration of the Hint Rewrite library object *)
-let (in_hintrewrite,out_hintrewrite)=
+let (inHintRewrite,outHintRewrite)=
   Libobject.declare_object {(Libobject.default_object "HINT_REWRITE") with
        Libobject.cache_function = cache_hintrewrite;
        Libobject.load_function = (fun _ -> cache_hintrewrite);
@@ -223,4 +231,4 @@ let add_rew_rules base lrul =
       (c,mkProp (* dummy value *), b,Tacinterp.glob_tactic t)
     ) lrul
   in
-   Lib.add_anonymous_leaf (in_hintrewrite (base,lrul))
+   Lib.add_anonymous_leaf (inHintRewrite (base,lrul))
diff --git a/tactics/class_tactics.ml4 b/tactics/class_tactics.ml4
new file mode 100644
index 00000000..9a1a3042
--- /dev/null
+++ b/tactics/class_tactics.ml4
@@ -0,0 +1,1692 @@
+(* -*- compile-command: "make -C .. bin/coqtop.byte" -*- *)
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i camlp4deps: "parsing/grammar.cma" i*)
+
+(* $Id: class_tactics.ml4 11150 2008-06-19 11:38:27Z msozeau $ *)
+
+open Pp
+open Util
+open Names
+open Nameops
+open Term
+open Termops
+open Sign
+open Reduction
+open Proof_type
+open Proof_trees
+open Declarations
+open Tacticals
+open Tacmach
+open Evar_refiner
+open Tactics
+open Pattern
+open Clenv
+open Auto
+open Rawterm
+open Hiddentac
+open Typeclasses
+open Typeclasses_errors
+open Classes
+open Topconstr
+open Pfedit
+open Command
+open Libnames
+open Evd
+
+let default_eauto_depth = 100
+let typeclasses_db = "typeclass_instances"
+
+let check_imported_library d =
+  let d' = List.map id_of_string d in
+  let dir = make_dirpath (List.rev d') in
+  if not (Library.library_is_loaded dir) then
+    error ("Library "^(list_last d)^" has to be imported first")
+      
+let classes_dirpath =
+  make_dirpath (List.map id_of_string ["Classes";"Coq"])
+  
+let init_setoid () =
+  if is_dirpath_prefix_of classes_dirpath (Lib.cwd ()) then ()
+  else check_imported_library ["Coq";"Setoids";"Setoid"]
+
+(** Typeclasses instance search tactic / eauto *)
+
+open Auto
+
+let e_give_exact 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 t1) (exact_check c) gl
+  else exact_check c gl
+
+let assumption id = e_give_exact (mkVar id)
+
+open Unification
+
+let auto_unif_flags = {
+  modulo_conv_on_closed_terms = Some full_transparent_state;
+  use_metas_eagerly = true;
+  modulo_delta = var_full_transparent_state;
+}
+
+let unify_e_resolve st (c,clenv) gls = 
+  let clenv' = connect_clenv gls clenv in
+  let clenv' = clenv_unique_resolver false
+    ~flags:{auto_unif_flags with modulo_delta = st} clenv' gls 
+  in
+    Clenvtac.clenv_refine true clenv' gls
+      
+let unify_resolve st (c,clenv) gls = 
+  let clenv' = connect_clenv gls clenv in
+  let clenv' = clenv_unique_resolver false
+    ~flags:{auto_unif_flags with modulo_delta = st} clenv' gls 
+  in
+    Clenvtac.clenv_refine false clenv' gls
+
+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
+	     (add_hint_list hintl local_db) g'))) ::
+    (List.map pi1 (e_trivial_resolve db_list local_db (pf_concl goal)) )
+  in 
+  tclFIRST (List.map tclCOMPLETE tacl) goal 
+
+and e_my_find_search db_list local_db hdc concl = 
+  let hdc = head_of_constr_reference hdc in
+  let hintl =
+    if occur_existential concl then
+      list_map_append
+	(fun (st, db) -> List.map (fun x -> (st, x)) (Hint_db.map_all hdc db))
+	(local_db::db_list)
+    else
+      list_map_append
+	(fun (st, db) -> List.map (fun x -> (st, 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}) -> 
+      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_THEN_trivial_fail (term,cl) ->
+              tclTHEN (unify_e_resolve st (term,cl)) 
+		(e_trivial_fail_db db_list local_db)
+	  | Unfold_nth c -> unfold_in_concl [all_occurrences,c]
+	  | Extern tacast -> conclPattern concl 
+	      (Option.get p) tacast
+      in 
+	(tac,b,fmt_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 
+      (List.hd (head_constr_bound gl [])) gl
+  with Bound | Not_found -> []
+
+let e_possible_resolve db_list local_db gl =
+  try 
+    e_my_find_search db_list local_db 
+      (List.hd (head_constr_bound gl [])) gl
+  with Bound | Not_found -> []
+
+let find_first_goal gls = 
+  try first_goal gls with UserError _ -> assert false
+
+
+type search_state = { 
+  depth : int; (*r depth of search before failing *)
+  tacres : goal list sigma * validation;
+  pri : int;
+  last_tactic : std_ppcmds;
+  dblist : Auto.hint_db list;
+  localdb :  Auto.hint_db list }
+    
+let filter_hyp t = 
+  match kind_of_term t with
+    | Evar _ | Meta _ | Sort _ -> false
+    | _ -> true
+
+let rec catchable = function
+  | Refiner.FailError _ -> true
+  | Stdpp.Exc_located (_, e) -> catchable e
+  | e -> Logic.catchable_exception e
+
+module SearchProblem = struct
+    
+  type state = search_state
+
+  let debug = ref false
+
+  let success s = (sig_it (fst s.tacres)) = []
+
+  let pr_ev evs ev = Printer.pr_constr_env (Evd.evar_env ev) (Evarutil.nf_evar evs ev.Evd.evar_concl)
+    
+  let pr_goals gls =
+    let evars = Evarutil.nf_evars (Refiner.project gls) in
+      prlist (pr_ev evars) (sig_it gls)
+	
+  let filter_tactics (glls,v) l =
+(*     if !debug then *)
+(*       (let _ = Proof_trees.db_pr_goal (List.hd (sig_it glls)) in *)
+(*       let evars = Evarutil.nf_evars (Refiner.project glls) in *)
+(*     	msg (str"Goal: " ++ pr_ev evars (List.hd (sig_it glls)) ++ str"\n")); *)
+    let rec aux = function
+      | [] -> []
+      | (tac,pri,pptac) :: tacl -> 
+	  try 
+(* 	    if !debug then msg (str"\nTrying tactic: " ++ pptac ++ str"\n"); *)
+	    let (lgls,ptl) = apply_tac_list tac glls in 
+	    let v' p = v (ptl p) in
+(* 	      	      if !debug then *)
+(* 	      		begin *)
+(* 	      		  let evars = Evarutil.nf_evars (Refiner.project glls) in *)
+(* 	      		    msg (str"\nOn goal: " ++ pr_ev evars (List.hd (sig_it glls)) ++ str"\n"); *)
+(* 	      		    msg (hov 1 (pptac ++ str" gives: \n" ++ pr_goals lgls ++ str"\n")) *)
+(* 	      		end; *)
+	      ((lgls,v'),pri,pptac) :: aux tacl
+	  with e when catchable e -> aux tacl
+    in aux l
+      
+  let nb_empty_evars s = 
+    Evd.fold (fun ev evi acc -> if evi.evar_body = Evar_empty then succ acc else acc) s 0
+
+  (* Ordering of states is lexicographic on depth (greatest first) then
+     priority (lowest pri means higher priority), then number of remaining goals. *)
+  let compare s s' =
+    let d = s'.depth - s.depth in
+    let nbgoals s = 
+      List.length (sig_it (fst s.tacres)) + 
+	nb_empty_evars (sig_sig (fst s.tacres))
+    in
+      if d <> 0 && d <> 1 then d else
+	let pri = s.pri - s'.pri in
+	  if pri <> 0 then pri
+	  else nbgoals s - nbgoals s'
+
+  let branching s = 
+    if s.depth = 0 then 
+      []
+    else      
+      let lg = fst s.tacres in
+      let nbgl = List.length (sig_it lg) in
+      assert (nbgl > 0);
+      let g = find_first_goal lg in
+      let assumption_tacs = 
+	let l = 
+	  filter_tactics s.tacres
+	    (List.map 
+		(fun id -> (Eauto.e_give_exact_constr (mkVar id), 0,
+			   (str "exact" ++ spc () ++ pr_id id)))
+		(List.filter (fun id -> filter_hyp (pf_get_hyp_typ g id))
+		    (pf_ids_of_hyps g)))
+	in
+	  List.map (fun (res,pri,pp) -> { s with tacres = res; pri = 0;
+	    last_tactic = pp; localdb = List.tl s.localdb }) l
+      in
+(*       let intro_tac =  *)
+(* 	List.map  *)
+(* 	  (fun ((lgls,_) as res,pri,pp) ->  *)
+(* 	     let g' = first_goal lgls in  *)
+(* 	     let hintl =  *)
+(* 	       make_resolve_hyp (pf_env g') (project g') (pf_last_hyp g') *)
+(* 	     in	        *)
+(*              let ldb = Hint_db.add_list hintl (match s.localdb with [] -> assert false | hd :: _ -> hd) in *)
+(* 	       { s with tacres = res;  *)
+(* 		 last_tactic = pp; *)
+(* 		 pri = pri; *)
+(* 		 localdb = ldb :: List.tl s.localdb }) *)
+(* 	  (filter_tactics s.tacres [Tactics.intro,1,(str "intro")]) *)
+(*       in *)
+      let possible_resolve ((lgls,_) as res, pri, pp) =
+	let nbgl' = List.length (sig_it lgls) in
+	  if nbgl' < nbgl then
+	    { s with tacres = res; last_tactic = pp; pri = pri;
+	      localdb = List.tl s.localdb }
+	  else 
+	    { s with 
+	      depth = pred s.depth; tacres = res; 
+	      last_tactic = pp; pri = pri;
+	      localdb = 
+		list_addn (nbgl'-nbgl) (List.hd s.localdb) s.localdb }
+      in
+      let rec_tacs = 
+	let l = 
+	  filter_tactics s.tacres (e_possible_resolve s.dblist (List.hd s.localdb) (pf_concl g))
+	in
+	List.map possible_resolve l
+      in
+      List.sort compare (assumption_tacs (* @intro_tac  @ custom_tac *) @ rec_tacs)
+
+  let pp s = 
+    msg (hov 0 (str " depth=" ++ int s.depth ++ spc () ++ 
+		  s.last_tactic ++ str "\n"))
+
+end
+
+module Search = Explore.Make(SearchProblem)
+
+
+let filter_pat c =
+  try
+    let morg = Nametab.global (Qualid (dummy_loc, qualid_of_string "Coq.Classes.Morphisms.Morphism")) in
+    let morc = constr_of_global morg in
+	match kind_of_term c with
+	  | App(morph, [| t; r; m |]) when eq_constr morph morc ->
+	      (fun y ->
+		(match y.pat with
+		    Some (PApp (PRef mor, [| t'; r'; m' |])) when mor = morg ->
+		      (match m' with
+			| PRef c -> if isConst m then eq_constr (constr_of_global c) m else false
+			| _ -> true)
+		  | _ -> true))
+	  | _ -> fun _ -> true
+  with _ -> fun _ -> true
+
+let morphism_class = 
+  lazy (class_info (Nametab.global (Qualid (dummy_loc, qualid_of_string "Coq.Classes.Morphisms.Morphism"))))
+
+let morphism_proxy_class = 
+  lazy (class_info (Nametab.global (Qualid (dummy_loc, qualid_of_string "Coq.Classes.Morphisms.MorphismProxy"))))
+    
+let filter c =
+  try let morc = constr_of_global (Nametab.global (Qualid (dummy_loc, qualid_of_string "Coq.Classes.Morphisms.Morphism"))) in
+	match kind_of_term c with
+	  | App(morph, [| t; r; m |]) when eq_constr morph morc ->
+	      (fun y ->
+		let (_, r) = decompose_prod y in
+		  (match kind_of_term r with
+		      App (morph', [| t'; r'; m' |]) when eq_constr morph' morc ->
+			(match kind_of_term m' with
+			  | Rel n -> true
+			  | Const c -> eq_constr m m'
+			  | App _ -> true
+			  | _ -> false)
+		    | _ -> false))
+	  | _ -> fun _ -> true
+  with _ -> fun _ -> true
+
+let make_initial_state n gls dblist localdbs =
+  { depth = n;
+    tacres = gls;
+    pri = 0;
+    last_tactic = (mt ());
+    dblist = dblist;
+    localdb = localdbs }
+
+let e_depth_search debug s =
+  let tac = if debug then
+    (SearchProblem.debug := true; Search.debug_depth_first) else Search.depth_first in
+  let s = tac s in
+    s.tacres
+
+let e_breadth_search debug s =
+  try
+    let tac = 
+      if debug then Search.debug_breadth_first else Search.breadth_first 
+    in let s = tac s in s.tacres
+  with Not_found -> error "EAuto: breadth first search failed"
+
+let e_search_auto debug (in_depth,p) lems db_list gls = 
+  let sigma = Evd.sig_sig (fst gls) and gls' = Evd.sig_it (fst gls) in
+  let local_dbs = List.map (fun gl -> make_local_hint_db true lems ({it = gl; sigma = sigma})) gls' in
+  let state = make_initial_state p gls db_list local_dbs in
+  if in_depth then 
+    e_depth_search debug state
+  else
+    e_breadth_search debug state
+
+let full_eauto debug n lems gls = 
+  let dbnames = current_db_names () in
+  let dbnames =  list_subtract dbnames ["v62"] in
+  let db_list = List.map searchtable_map dbnames in
+    e_search_auto debug n lems db_list gls
+
+let nf_goal (gl, valid) =
+  { gl with sigma = Evarutil.nf_evars gl.sigma }, valid
+
+let typeclasses_eauto debug n lems gls =
+  let dbnames = [typeclasses_db] in
+  let db_list = List.map
+    (fun x -> 
+      try searchtable_map x 
+      with Not_found -> (empty_transparent_state, Hint_db.empty))
+    dbnames 
+  in
+    e_search_auto debug n lems db_list gls
+
+exception Found of evar_map
+
+let valid goals p res_sigma l = 
+  let evm = 
+    List.fold_left2 
+      (fun sigma (ev, evi) prf ->
+	let cstr, obls = Refiner.extract_open_proof !res_sigma prf in
+	  if not (Evd.is_defined sigma ev) then
+	    Evd.define sigma ev cstr
+	  else sigma)
+      !res_sigma goals l
+  in raise (Found evm)
+    
+let resolve_all_evars_once debug (mode, depth) env p evd =
+  let evm = Evd.evars_of evd in
+  let goals, evm' = 
+    Evd.fold
+      (fun ev evi (gls, evm) ->
+	if evi.evar_body = Evar_empty 
+	  && Typeclasses.is_resolvable evi
+	  && p ev evi then ((ev,evi) :: gls, Evd.add evm ev (Typeclasses.mark_unresolvable evi)) else 
+	  (gls, Evd.add evm ev evi))
+      evm ([], Evd.empty)
+  in
+  let goals = List.rev goals in
+  let gls = { it = List.map snd goals; sigma = evm' } in
+  let res_sigma = ref evm' in
+  let gls', valid' = typeclasses_eauto debug (mode, depth) [] (gls, valid goals p res_sigma) in
+    res_sigma := Evarutil.nf_evars (sig_sig gls');
+    try ignore(valid' []); assert(false) 
+    with Found evm' -> Evarutil.nf_evar_defs (Evd.evars_reset_evd evm' evd)
+
+exception FoundTerm of constr
+
+let resolve_one_typeclass env gl =
+  let gls = { it = [ Evd.make_evar (Environ.named_context_val env) gl ] ; sigma = Evd.empty } in
+  let valid x = raise (FoundTerm (fst (Refiner.extract_open_proof Evd.empty (List.hd x)))) in
+  let gls', valid' = typeclasses_eauto false (true, default_eauto_depth) [] (gls, valid) in
+    try ignore(valid' []); assert false with FoundTerm t -> 
+      let term = Evarutil.nf_evar (sig_sig gls') t in
+	if occur_existential term then raise Not_found else term
+
+let has_undefined p oevd evd =
+  Evd.fold (fun ev evi has -> has ||
+    (evi.evar_body = Evar_empty && p ev evi && 
+	(try Typeclasses.is_resolvable (Evd.find oevd ev) with _ -> true)))
+    (Evd.evars_of evd) false
+
+let evars_of_term init c = 
+  let rec evrec acc c =
+    match kind_of_term c with
+    | Evar (n, _) -> Intset.add n acc
+    | _ -> fold_constr evrec acc c
+  in 
+    evrec init c
+
+let intersects s t =
+  Intset.exists (fun el -> Intset.mem el t) s
+
+let rec merge_deps deps = function
+  | [] -> [deps]
+  | hd :: tl -> 
+      if intersects deps hd then 
+	merge_deps (Intset.union deps hd) tl
+      else hd :: merge_deps deps tl
+	
+let split_evars evm =
+  Evd.fold (fun ev evi acc ->
+    let deps = evars_of_term (Intset.singleton ev) evi.evar_concl in
+      merge_deps deps acc)
+    evm []
+
+let select_evars evs evm =
+  Evd.fold (fun ev evi acc ->
+    if Intset.mem ev evs then Evd.add acc ev evi else acc)
+    evm Evd.empty
+
+let resolve_all_evars debug m env p oevd do_split fail =
+  let oevm = Evd.evars_of oevd in
+  let split = if do_split then split_evars (Evd.evars_of (Evd.undefined_evars oevd)) else [Intset.empty] in
+  let p = if do_split then 
+    fun comp ev evi -> (Intset.mem ev comp || not (Evd.mem oevm ev)) && p ev evi
+    else fun _ -> p 
+  in
+  let rec aux n p evd =
+    if has_undefined p oevm evd then
+      if n > 0 then
+	let evd' = resolve_all_evars_once debug m env p evd in
+	  aux (pred n) p evd'
+      else None
+    else Some evd
+  in 
+  let rec docomp evd = function
+    | [] -> evd
+    | comp :: comps ->
+	let res = try aux 3 (p comp) evd with Not_found -> None in
+	  match res with
+	  | None -> 
+	      if fail then 
+		(* Unable to satisfy the constraints. *)
+		let evm = Evd.evars_of evd in
+		let evm = if do_split then select_evars comp evm else evm in
+		let _, ev = Evd.fold 
+		  (fun ev evi (b,acc) -> 
+		    (* focus on one instance if only one was searched for *)
+		    if class_of_constr evi.evar_concl <> None then
+		      if not b then
+			true, Some ev 
+		      else b, None
+		    else b, acc) evm (false, None)
+		in
+		  Typeclasses_errors.unsatisfiable_constraints env (Evd.evars_reset_evd evm evd) ev
+	      else (* Best effort: do nothing *) oevd
+	  | Some evd' -> docomp evd' comps
+  in docomp oevd split
+
+(* let resolve_all_evars debug m env p oevd = *)
+(*   let oevm = Evd.evars_of oevd in *)
+(*   try *)
+(*     let rec aux n evd = *)
+(*       if has_undefined p oevm evd then *)
+(* 	if n > 0 then *)
+(* 	  let evd' = resolve_all_evars_once debug m env p evd in *)
+(* 	    aux (pred n) evd' *)
+(* 	else None *)
+(*       else Some evd *)
+(*     in aux 3 oevd *)
+(*   with Not_found -> None *)
+    
+VERNAC COMMAND EXTEND Typeclasses_Unfold_Settings
+| [ "Typeclasses" "unfold" reference_list(cl) ] -> [
+    add_hints false [typeclasses_db] (Vernacexpr.HintsUnfold cl)
+  ]
+END
+
+(** Typeclass-based rewriting. *)
+
+let respect_proj = lazy (mkConst (snd (List.hd (Lazy.force morphism_class).cl_projs)))
+
+let make_dir l = make_dirpath (List.map id_of_string (List.rev l))
+
+let try_find_reference dir s =
+  let sp = Libnames.make_path (make_dir ("Coq"::dir)) (id_of_string s) in
+    constr_of_global (Nametab.absolute_reference sp)
+
+let gen_constant dir s = Coqlib.gen_constant "Class_setoid" dir s
+let coq_proj1 = lazy(gen_constant ["Init"; "Logic"] "proj1")
+let coq_proj2 = lazy(gen_constant ["Init"; "Logic"] "proj2")
+let iff = lazy (gen_constant ["Init"; "Logic"] "iff")
+let coq_all = lazy (gen_constant ["Init"; "Logic"] "all")
+let impl = lazy (gen_constant ["Program"; "Basics"] "impl")
+let arrow = lazy (gen_constant ["Program"; "Basics"] "arrow")
+let coq_id = lazy (gen_constant ["Program"; "Basics"] "id")
+
+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 complement = lazy (gen_constant ["Classes"; "RelationClasses"] "complement")
+let pointwise_relation = lazy (gen_constant ["Classes"; "RelationClasses"] "pointwise_relation")
+
+let respectful_dep = lazy (gen_constant ["Classes"; "Morphisms"] "respectful_dep")
+let respectful = lazy (gen_constant ["Classes"; "Morphisms"] "respectful")
+
+let equivalence = lazy (gen_constant ["Classes"; "RelationClasses"] "Equivalence")
+let default_relation = lazy (gen_constant ["Classes"; "SetoidTactics"] "DefaultRelation")
+
+let coq_relation = lazy (gen_constant ["Relations";"Relation_Definitions"] "relation")
+let mk_relation a = mkApp (Lazy.force coq_relation, [| a |])
+let coq_relationT = lazy (gen_constant ["Classes";"Relations"] "relationT")
+
+let setoid_refl_proj = lazy (gen_constant ["Classes"; "SetoidClass"] "Equivalence_Reflexive")
+
+let setoid_equiv = lazy (gen_constant ["Classes"; "SetoidClass"] "equiv")
+let setoid_morphism = lazy (gen_constant ["Classes"; "SetoidClass"] "setoid_morphism")
+let setoid_refl_proj = lazy (gen_constant ["Classes"; "SetoidClass"] "Equivalence_Reflexive")
+  
+let arrow_morphism a b = 
+  if isprop a && isprop b then
+    Lazy.force impl
+  else
+    mkApp(Lazy.force arrow, [|a;b|])
+
+let setoid_refl pars x = 
+  applistc (Lazy.force setoid_refl_proj) (pars @ [x])
+      
+let morphism_type = lazy (constr_of_global (Lazy.force morphism_class).cl_impl)
+
+let morphism_proxy_type = lazy (constr_of_global (Lazy.force morphism_proxy_class).cl_impl)
+
+exception Found of (constr * constr * (types * types) list * constr * constr array *
+		       (constr * (constr * constr * constr * constr)) option array)
+
+let is_equiv env sigma t = 
+  isConst t && Reductionops.is_conv env sigma (Lazy.force setoid_equiv) t
+
+let split_head = function
+    hd :: tl -> hd, tl
+  | [] -> assert(false)
+
+exception DependentMorphism
+
+let build_signature isevars env m (cstrs : 'a option list) (finalcstr : 'a Lazy.t option) (f : 'a -> constr) =
+  let new_evar isevars env t =
+    Evarutil.e_new_evar isevars env
+      (* ~src:(dummy_loc, ImplicitArg (ConstRef (Lazy.force respectful), (n, Some na))) *) t
+  in
+  let mk_relty ty obj =
+    match obj with
+      | None -> 
+	  let relty = mk_relation ty in
+	    new_evar isevars env relty
+      | Some x -> f x
+  in
+  let rec aux env ty l =
+    let t = Reductionops.whd_betadeltaiota env (Evd.evars_of !isevars) ty in
+      match kind_of_term t, l with
+      | Prod (na, ty, b), obj :: cstrs -> 
+	  if dependent (mkRel 1) ty then raise DependentMorphism;
+	  let (b, arg, evars) = aux (Environ.push_rel (na, None, ty) env) b cstrs in
+	  let ty = Reductionops.nf_betaiota ty in
+	  let relty = mk_relty ty obj in
+	  let arg' = mkApp (Lazy.force respectful, [| ty ; b ; relty ; arg |]) in
+	    mkProd(na, ty, b), arg', (ty, relty) :: evars
+      | _, obj :: _ -> anomaly "build_signature: not enough products"
+      | _, [] -> 
+	  (match finalcstr with
+	      None -> 
+		let t = Reductionops.nf_betaiota ty in
+		let rel = mk_relty t None in 
+		  t, rel, [t, rel]
+	    | Some codom -> let (t, rel) = Lazy.force codom in
+			      t, rel, [t, rel])
+  in aux env m cstrs
+
+let morphism_proof env evars carrier relation x =
+  let goal =
+    mkApp (Lazy.force morphism_proxy_type, [| carrier ; relation; x |])
+  in Evarutil.e_new_evar evars env goal
+
+let find_class_proof proof_type proof_method env carrier relation =
+  try 
+    let goal =
+      mkApp (Lazy.force proof_type, [| carrier ; relation |])
+    in
+    let inst = resolve_one_typeclass env goal in
+      mkApp (Lazy.force proof_method, [| carrier ; relation ; inst |])
+  with e when Logic.catchable_exception e -> raise Not_found
+
+let reflexive_proof env = find_class_proof reflexive_type reflexive_proof env
+let symmetric_proof env = find_class_proof symmetric_type symmetric_proof env
+let 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
+
+let resolve_morphism env sigma oldt m ?(fnewt=fun x -> x) args args' cstr evars =
+  let morph_instance, proj, sigargs, m', args, args' = 
+    let first = try (array_find args' (fun i b -> b <> None)) with Not_found -> raise (Invalid_argument "resolve_morphism") in
+    let morphargs, morphobjs = array_chop first args in
+    let morphargs', morphobjs' = array_chop first args' in
+    let appm = mkApp(m, morphargs) in
+    let appmtype = Typing.type_of env sigma appm in
+    let cstrs = List.map (function None -> None | Some (_, (a, r, _, _)) -> Some (a, r)) (Array.to_list morphobjs') in
+    let appmtype', signature, sigargs = build_signature evars env appmtype cstrs cstr (fun (a, r) -> r) in
+    let cl_args = [| appmtype' ; signature ; appm |] in
+    let app = mkApp (Lazy.force morphism_type, cl_args) in
+    let morph = Evarutil.e_new_evar evars env app in
+    let proj = 
+      mkApp (Lazy.force respect_proj, 
+	    Array.append cl_args [|morph|])
+    in
+      morph, proj, sigargs, appm, morphobjs, morphobjs'
+  in 
+  let projargs, respars, typeargs = 
+    array_fold_left2 
+      (fun (acc, sigargs, typeargs') x y -> 
+	let (carrier, relation), sigargs = split_head sigargs in
+	  match y with
+	      None ->
+		let proof = morphism_proof env evars carrier relation x in
+		  [ proof ; x ; x ] @ acc, sigargs, x :: typeargs'
+	    | Some (p, (_, _, _, t')) ->
+		[ p ; t'; x ] @ acc, sigargs, t' :: typeargs')
+      ([], sigargs, []) args args'
+  in
+  let proof = applistc proj (List.rev projargs) in
+  let newt = applistc m' (List.rev typeargs) in
+    match respars with
+	[ a, r ] -> (proof, (a, r, oldt, fnewt newt))
+      | _ -> assert(false)
+
+(* Adapted from setoid_replace. *)
+
+type hypinfo = {
+  cl : clausenv;
+  prf : constr;
+  car : constr;
+  rel : constr;
+  l2r : bool;
+  c1 : constr;
+  c2 : constr;
+  c  : constr option;
+  abs : (constr * types) option;
+}
+
+let evd_convertible env evd x y =
+  try ignore(Evarconv.the_conv_x env x y evd); true 
+  with _ -> false
+  
+let decompose_setoid_eqhyp env sigma c left2right =
+  let ctype = Typing.type_of env sigma c in
+  let eqclause = Clenv.mk_clenv_from_env env sigma None (c,ctype) 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
+  let ty1, ty2 = 
+    Typing.mtype_of env eqclause.evd c1, Typing.mtype_of env eqclause.evd c2
+  in
+    if not (evd_convertible env eqclause.evd ty1 ty2) then
+      error "The term does not end with an applied homogeneous relation"
+    else
+      { cl=eqclause; prf=(Clenv.clenv_value eqclause);
+	car=ty1; rel=mkApp (equiv, Array.of_list others);
+	l2r=left2right; c1=c1; c2=c2; c=Some c; abs=None }
+
+let rewrite_unif_flags = {
+  Unification.modulo_conv_on_closed_terms = None;
+  Unification.use_metas_eagerly = true;
+  Unification.modulo_delta = empty_transparent_state;
+}
+
+let conv_transparent_state = (Idpred.empty, Cpred.full)
+
+let rewrite2_unif_flags = {
+  Unification.modulo_conv_on_closed_terms = Some conv_transparent_state;
+  Unification.use_metas_eagerly = true;
+  Unification.modulo_delta = empty_transparent_state;
+}
+
+let convertible env evd x y =
+  Reductionops.is_conv env (Evd.evars_of evd) x y
+  
+let allowK = true
+
+let refresh_hypinfo env sigma hypinfo = 
+  if !hypinfo.abs = None then
+    let {l2r=l2r; c = c} = !hypinfo in
+      match c with 
+	| Some c ->
+	    (* Refresh the clausenv to not get the same meta twice in the goal. *)
+	    hypinfo := decompose_setoid_eqhyp env sigma c l2r;
+	| _ -> ()
+  else ()
+
+let unify_eqn env sigma hypinfo t = 
+  try 
+    let {cl=cl; prf=prf; car=car; rel=rel; l2r=l2r; c1=c1; c2=c2; c=c; abs=abs} = !hypinfo in
+    let env', prf, c1, c2, car, rel =
+      let left = if l2r then c1 else c2 in
+	match abs with
+	    Some (absprf, absprfty) -> 
+	      (*if convertible env cl.evd left t then
+		cl, prf, c1, c2, car, rel
+	      else raise Not_found*)
+	      let env' = clenv_unify allowK ~flags:rewrite2_unif_flags CONV left t cl in
+	      let env' =
+		let mvs = clenv_dependent false env' in
+		  clenv_pose_metas_as_evars env' mvs
+	      in
+	      let c1 = Clenv.clenv_nf_meta env' c1
+	      and c2 = Clenv.clenv_nf_meta env' c2
+	      and car = Clenv.clenv_nf_meta env' car
+	      and rel = Clenv.clenv_nf_meta env' rel in
+		hypinfo := { !hypinfo with
+		  cl = env';
+		  abs = Some (Clenv.clenv_value env', Clenv.clenv_type env') };
+		env', prf, c1, c2, car, rel
+	  | None ->
+	      let env' =
+		try clenv_unify allowK ~flags:rewrite_unif_flags
+		  CONV left t cl
+		with Pretype_errors.PretypeError _ ->
+		  (* For Ring essentially, only when doing setoid_rewrite *)
+		  clenv_unify allowK ~flags:rewrite2_unif_flags
+		    CONV left t cl
+	      in
+	      let env' = 
+		let mvs = clenv_dependent false env' in
+		  clenv_pose_metas_as_evars env' mvs
+	      in
+	      let c1 = Clenv.clenv_nf_meta env' c1 
+	      and c2 = Clenv.clenv_nf_meta env' c2
+	      and car = Clenv.clenv_nf_meta env' car
+	      and rel = Clenv.clenv_nf_meta env' rel in
+	      let prf = Clenv.clenv_value env' in
+	      let ty1 = Typing.mtype_of env'.env env'.evd c1 
+	      and ty2 = Typing.mtype_of env'.env env'.evd c2
+	      in
+		if convertible env env'.evd ty1 ty2 then (
+		  if occur_meta prf then refresh_hypinfo env sigma 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 (symmetric_proof env car rel, [| c1 ; c2 ; prf |]), (car, rel, c2, c1))
+	with Not_found ->
+	  (prf, (car, inverse car rel, c2, c1))
+    in Some (env', res)
+  with _ -> None
+
+let unfold_impl t =
+  match kind_of_term t with
+    | App (arrow, [| a; b |])(*  when eq_constr arrow (Lazy.force impl) *) -> 
+	mkProd (Anonymous, a, lift 1 b)
+    | _ -> assert false
+
+let unfold_id t = 
+  match kind_of_term t with
+    | App (id, [| a; b |]) (* when eq_constr id (Lazy.force coq_id) *) -> 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 decomp_prod env evm n c = 
+  snd (Reductionops.decomp_n_prod env evm n c)
+
+let rec decomp_pointwise n c =
+  if n = 0 then c
+  else
+    match kind_of_term c with
+      | App (pointwise, [| a; b; relb |]) -> decomp_pointwise (pred n) relb
+      | _ -> raise Not_found
+	  
+let lift_cstr env sigma evars args cstr =
+  let cstr () =
+    let start = 
+      match cstr with
+	| Some codom -> Lazy.force codom
+	| None -> let car = Evarutil.e_new_evar evars env (new_Type ()) in
+	  let rel = Evarutil.e_new_evar evars env (mk_relation car) in
+	    (car, rel)
+    in
+      Array.fold_right
+	(fun arg (car, rel) -> 
+	  let ty = Typing.type_of env sigma arg in
+	  let car' = mkProd (Anonymous, ty, car) in
+	  let rel' = mkApp (Lazy.force pointwise_relation, [| ty; car; rel |]) in
+	    (car', rel'))
+	args start
+  in Some (Lazy.lazy_from_fun cstr)
+
+let unlift_cstr env sigma = function
+  | None -> None
+  | Some codom -> 
+      let cstr () =
+	let car, rel = Lazy.force codom in
+	  decomp_prod env sigma 1 car, decomp_pointwise 1 rel
+      in Some (Lazy.lazy_from_fun cstr)
+
+type rewrite_flags = { under_lambdas : bool; on_morphisms : bool }
+
+let default_flags = { under_lambdas = true; on_morphisms = true; }
+
+let build_new gl env sigma flags loccs hypinfo concl cstr evars =
+  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 rec aux env t occ cstr =
+    let unif = unify_eqn env sigma hypinfo t in
+    let occ = if unif = None then occ else succ occ in
+      match unif with
+      | Some (env', (prf, hypinfo as x)) when is_occ occ -> 
+	  begin 
+	    evars := Evd.evar_merge !evars 
+	      (Evd.evars_of (Evd.undefined_evars (Evarutil.nf_evar_defs env'.evd)));
+	    match cstr with
+	    | None -> Some x, occ
+	    | Some _ ->
+		let (car, r, orig, dest) = hypinfo in
+		let res = 
+		  resolve_morphism env sigma t ~fnewt:unfold_id
+		    (mkApp (Lazy.force coq_id, [| car |]))
+		    [| orig |] [| Some x |] cstr evars
+		in Some res, occ
+	  end
+      | _ -> 
+	  match kind_of_term t with
+	  | App (m, args) ->
+	      let rewrite_args occ = 
+		let args', occ = 
+		  Array.fold_left 
+		    (fun (acc, occ) arg -> let res, occ = aux env arg occ None in (res :: acc, occ))
+		    ([], occ) args
+		in
+		let res =
+		  if List.for_all (fun x -> x = None) args' then None
+		  else 
+		    let args' = Array.of_list (List.rev args') in
+		      (Some (resolve_morphism env sigma t m args args' cstr evars))
+		in res, occ
+	      in
+		if flags.on_morphisms then
+		  let m', occ = aux env m occ (lift_cstr env sigma evars args cstr) in
+		    match m' with
+		    | None -> rewrite_args occ (* Standard path, try rewrite on arguments *)
+		    | Some (prf, (car, rel, c1, c2)) -> 
+			(* We rewrote the function and get a proof of pointwise rel for the arguments.
+			   We just apply it. *)
+			let nargs = Array.length args in
+			let res = 
+			  mkApp (prf, args),
+			  (decomp_prod env (Evd.evars_of !evars) nargs car, 
+			  decomp_pointwise nargs rel, mkApp(c1, args), mkApp(c2, args))
+			in Some res, occ
+		else rewrite_args occ
+		
+	  | Prod (n, x, b) when not (dependent (mkRel 1) b) -> 
+	      let x', occ = aux env x occ None in
+(* 		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 *)
+		  let b = subst1 mkProp b in
+		  let b', occ = aux env b occ None in
+		  let res = 
+		    if x' = None && b' = None then None
+		    else 
+		      Some (resolve_morphism env sigma t
+			       ~fnewt:unfold_impl
+			       (arrow_morphism (Typing.type_of env sigma x) (Typing.type_of env sigma b))
+			       [| x ; b |] [| x' ; b' |]
+			       cstr evars)
+		  in res, occ
+		    
+	  | Prod (n, ty, b) ->
+	      let lam = mkLambda (n, ty, 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) [| ty ; lam |] [| None; lam' |]
+			     cstr evars)
+	      in res, occ
+		
+	  | Lambda (n, t, b) when flags.under_lambdas ->
+	      let env' = Environ.push_rel (n, None, t) env in
+		refresh_hypinfo env' sigma hypinfo;
+		let b', occ = aux env' b occ (unlift_cstr env sigma cstr) in
+		let res =
+		  match b' with
+		  | None -> None
+		  | Some (prf, (car, rel, c1, c2)) ->
+		      let prf' = mkLambda (n, t, prf) in
+		      let car' = mkProd (n, t, car) in
+		      let rel' = mkApp (Lazy.force pointwise_relation, [| t; car; rel |]) in
+		      let c1' = mkLambda(n, t, c1) and c2' = mkLambda (n, t, c2) in
+			Some (prf', (car', rel', c1', c2'))
+		in res, occ
+	  | _ -> None, occ
+  in
+  let eq,nbocc_min_1 = aux env concl 0 cstr in
+  let rest = List.filter (fun o -> o > nbocc_min_1) occs in
+  if rest <> [] then error_invalid_occurrence rest;
+  eq
+    
+let resolve_typeclass_evars d p env evd onlyargs split fail =
+  let pred = 
+    if onlyargs then 
+      (fun ev evi -> Typeclasses.is_implicit_arg (snd (Evd.evar_source ev evd)) &&
+	class_of_constr evi.Evd.evar_concl <> None)
+    else
+      (fun ev evi -> class_of_constr evi.Evd.evar_concl <> None)
+  in resolve_all_evars d p env pred evd split fail
+      
+let cl_rewrite_clause_aux ?(flags=default_flags) hypinfo goal_meta occs clause gl =
+  let concl, is_hyp = 
+    match clause with
+	Some ((_, id), _) -> pf_get_hyp_typ gl id, Some id
+      | None -> pf_concl gl, None
+  in
+  let cstr = 
+    match is_hyp with
+	None -> (mkProp, inverse mkProp (Lazy.force impl))
+      | Some _ -> (mkProp, Lazy.force impl)
+  in
+  let evars = ref (Evd.create_evar_defs Evd.empty) in
+  let env = pf_env gl in
+  let sigma = project gl in
+  let eq = build_new gl env sigma flags occs hypinfo concl (Some (Lazy.lazy_from_val cstr)) evars 
+  in
+    match eq with  
+    | Some (p, (_, _, oldt, newt)) -> 
+	(try 
+	  evars := Typeclasses.resolve_typeclasses env ~split:false ~fail:true !evars;
+	  let p = Evarutil.nf_isevar !evars p in
+	  let newt = Evarutil.nf_isevar !evars newt in
+	  let undef = Evd.undefined_evars !evars in
+	  let abs = Option.map (fun (x, y) -> Evarutil.nf_isevar !evars x,
+	    Evarutil.nf_isevar !evars y) !hypinfo.abs in
+	  let rewtac = 
+	    match is_hyp with
+	    | Some id -> 
+		let term = 
+		  match abs with
+		  | None -> p
+		  | Some (t, ty) -> 
+		      mkApp (mkLambda (Name (id_of_string "lemma"), ty, p), [| t |])
+		in
+		  cut_replacing id newt 
+		    (fun x -> Tactics.refine (mkApp (term, [| mkVar id |])))
+	    | None -> 
+		(match abs with
+		| None -> 
+		    let name = next_name_away_with_default "H" Anonymous (pf_ids_of_hyps gl) in
+		      tclTHENLAST
+			(Tacmach.internal_cut_no_check name newt)
+			(tclTHEN (Tactics.revert [name]) (Tactics.refine p))
+		| Some (t, ty) -> 
+		    Tactics.refine
+		      (mkApp (mkLambda (Name (id_of_string "newt"), newt,
+				       mkLambda (Name (id_of_string "lemma"), ty,
+						mkApp (p, [| mkRel 2 |]))),
+			     [| mkMeta goal_meta; t |])))
+	  in
+	  let evartac = 
+	    let evd = Evd.evars_of undef in
+	      if not (evd = Evd.empty) then Refiner.tclEVARS (Evd.merge sigma evd)
+	      else tclIDTAC
+	  in tclTHENLIST [evartac; rewtac] gl
+	  with 
+	  | Stdpp.Exc_located (_, TypeClassError (env, (UnsatisfiableConstraints _ as e)))
+	  | TypeClassError (env, (UnsatisfiableConstraints _ as e)) ->
+	      tclFAIL 0 (str" setoid rewrite failed: unable to satisfy the rewriting constraints." 
+			  ++ fnl () ++ Himsg.explain_typeclass_error env e) gl)
+	  (* 	      | Not_found -> *)
+	  (* 		  tclFAIL 0 (str" setoid rewrite failed: unable to satisfy the rewriting constraints.") gl) *)
+    | None -> 
+	let {l2r=l2r; c1=x; c2=y} = !hypinfo in
+	  raise (Pretype_errors.PretypeError 
+		    (pf_env gl, 
+		    Pretype_errors.NoOccurrenceFound ((if l2r then x else y), is_hyp)))
+	    (* tclFAIL 1 (str"setoid rewrite failed") gl *)
+	  
+let cl_rewrite_clause_aux ?(flags=default_flags) hypinfo goal_meta occs clause gl =
+  try cl_rewrite_clause_aux ~flags hypinfo goal_meta occs clause gl
+  with DependentMorphism -> tclFAIL 0 (str " setoid rewrite failed: cannot handle dependent morphisms") gl
+
+let cl_rewrite_clause c left2right occs clause gl =
+  init_setoid ();
+  let meta = Evarutil.new_meta() in
+  let gl = { gl with sigma = Typeclasses.mark_unresolvables gl.sigma } in
+  let hypinfo = ref (decompose_setoid_eqhyp (pf_env gl) (project gl) c left2right) in
+    cl_rewrite_clause_aux hypinfo meta occs clause gl
+
+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)
+
+TACTIC EXTEND class_rewrite
+| [ "clrewrite" orient(o) constr(c) "in" hyp(id) "at" occurrences(occ) ] -> [ cl_rewrite_clause c o (occurrences_of occ) (Some (([],id), [])) ]
+| [ "clrewrite" orient(o) constr(c) "at" occurrences(occ) "in" hyp(id) ] -> [ cl_rewrite_clause c o (occurrences_of occ) (Some (([],id), [])) ]
+| [ "clrewrite" orient(o) constr(c) "in" hyp(id) ] -> [ cl_rewrite_clause c o all_occurrences (Some (([],id), [])) ]
+| [ "clrewrite" orient(o) constr(c) "at" occurrences(occ) ] -> [ cl_rewrite_clause c o (occurrences_of occ) None ]
+| [ "clrewrite" orient(o) constr(c) ] -> [ cl_rewrite_clause c o all_occurrences None ]
+END
+
+
+let clsubstitute o c =
+  let is_tac id = match kind_of_term c with Var id' when id' = id -> true | _ -> false in
+    Tacticals.onAllClauses 
+      (fun cl -> 
+	match cl with
+	  | Some ((_,id),_) when is_tac id -> tclIDTAC
+	  | _ -> tclTRY (cl_rewrite_clause c o all_occurrences cl))
+
+TACTIC EXTEND substitute
+| [ "substitute" orient(o) constr(c) ] -> [ clsubstitute o c ]
+END
+
+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_mode _prc _prlc _prt m =
+  match m with
+      Some b ->
+	if b then Pp.str "depth-first" else Pp.str "breadth-fist" 
+    | None -> Pp.mt()
+	
+ARGUMENT EXTEND search_mode TYPED AS bool option PRINTED BY pr_mode
+| [ "dfs" ] -> [ Some true ]
+| [ "bfs" ] -> [ Some false ]
+| [] -> [ None ]
+END
+
+let pr_depth _prc _prlc _prt = function
+    Some i -> Util.pr_int i
+  | None -> Pp.mt()
+	
+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
+	
+let solve_inst debug mode depth env evd onlyargs split fail =
+  resolve_typeclass_evars debug (mode, depth) env evd onlyargs split fail
+
+let _ = 
+  Typeclasses.solve_instanciations_problem :=
+    solve_inst false true default_eauto_depth
+      
+VERNAC COMMAND EXTEND Typeclasses_Settings
+ | [ "Typeclasses" "eauto" ":=" debug(d) search_mode(s) depth(depth) ] -> [ 
+     let mode = match s with Some t -> t | None -> true in
+     let depth = match depth with Some i -> i | None -> default_eauto_depth in
+       Typeclasses.solve_instanciations_problem :=
+	 solve_inst d mode depth
+   ]
+END
+
+TACTIC EXTEND typeclasses_eauto
+| [ "typeclasses" "eauto" debug(d) search_mode(s) depth(depth) ] -> [ 
+    let mode = match s with Some t -> t | None -> true in
+    let depth = match depth with Some i -> i | None -> default_eauto_depth in
+      fun gl -> 
+	let gls = {it = [sig_it gl]; sigma = project gl} in
+	let vals v = List.hd v in
+	  typeclasses_eauto d (mode, depth) [] (gls, vals) ]
+END
+
+
+(*     fun gl -> *)
+(*     let env = pf_env gl in *)
+(*     let sigma = project gl in *)
+(*     let proj = sig_it gl in *)
+(*     let evd = Evd.create_evar_defs (Evd.add Evd.empty 1 proj) in *)
+(*     let mode = match s with Some t -> t | None -> true in *)
+(*     let depth = match depth with Some i -> i | None -> default_eauto_depth in *)
+(*       match resolve_typeclass_evars d (mode, depth) env evd false with *)
+(*       | Some evd' ->  *)
+(* 	  let goal = Evd.find (Evd.evars_of evd') 1 in *)
+(* 	    (match goal.evar_body with *)
+(* 	    | Evar_empty -> tclIDTAC gl *)
+(* 	    | Evar_defined b -> refine b gl) *)
+(*       | None -> tclIDTAC gl *)
+(*   ] *)
+
+let _ = 
+  Classes.refine_ref := Refine.refine
+
+(* Compatibility with old Setoids *)
+  
+TACTIC EXTEND setoid_rewrite
+   [ "setoid_rewrite" orient(o) constr(c) ]
+   -> [ cl_rewrite_clause c o all_occurrences None ]
+ | [ "setoid_rewrite" orient(o) constr(c) "in" hyp(id) ] ->
+      [ cl_rewrite_clause c o all_occurrences (Some (([],id), []))]
+ | [ "setoid_rewrite" orient(o) constr(c) "at" occurrences(occ) ] ->
+      [ cl_rewrite_clause c o (occurrences_of occ) None]
+ | [ "setoid_rewrite" orient(o) constr(c) "at" occurrences(occ) "in" hyp(id)] ->
+      [ cl_rewrite_clause c o (occurrences_of occ) (Some (([],id), []))]
+ | [ "setoid_rewrite" orient(o) constr(c) "in" hyp(id) "at" occurrences(occ)] ->
+      [ cl_rewrite_clause c o (occurrences_of occ) (Some (([],id), []))]
+END
+
+(* let solve_obligation lemma =  *)
+(*   tclTHEN (Tacinterp.interp (Tacexpr.TacAtom (dummy_loc, Tacexpr.TacAnyConstructor None))) *)
+(*     (eapply_with_bindings (Constrintern.interp_constr Evd.empty (Global.env()) lemma, NoBindings)) *)
+
+let 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 binders instance fields = 
+  new_instance binders instance fields 
+    ~on_free_vars:Classes.fail_on_free_vars
+    None
+
+let require_library dirpath =
+  let qualid = (dummy_loc, Libnames.qualid_of_dirpath (Libnames.dirpath_of_string dirpath)) in
+    Library.require_library [qualid] (Some false)
+
+let declare_instance_refl binders a aeq n lemma = 
+  let instance = declare_instance a aeq (add_suffix n "_Reflexive") "Coq.Classes.RelationClasses.Reflexive" 
+  in anew_instance binders instance 
+       [((dummy_loc,id_of_string "reflexivity"),[],lemma)]
+
+let declare_instance_sym binders a aeq n lemma = 
+  let instance = declare_instance a aeq (add_suffix n "_Symmetric") "Coq.Classes.RelationClasses.Symmetric"
+  in anew_instance binders instance 
+       [((dummy_loc,id_of_string "symmetry"),[],lemma)]
+
+let declare_instance_trans binders a aeq n lemma = 
+  let instance = declare_instance a aeq (add_suffix n "_Transitive") "Coq.Classes.RelationClasses.Transitive" 
+  in anew_instance binders instance 
+       [((dummy_loc,id_of_string "transitivity"),[],lemma)]
+
+let constr_tac = Tacinterp.interp (Tacexpr.TacAtom (dummy_loc, Tacexpr.TacAnyConstructor (false,None)))
+
+let declare_relation ?(binders=[]) a aeq n refl symm trans = 
+  init_setoid ();
+  match (refl,symm,trans) with 
+      (None, None, None) -> 
+	let instance = declare_instance a aeq n "Coq.Classes.SetoidTactics.DefaultRelation"
+	in ignore(anew_instance binders instance [])
+    | (Some lemma1, None, None) -> 
+	ignore (declare_instance_refl binders a aeq n lemma1)
+    | (None, Some lemma2, None) -> 
+	ignore (declare_instance_sym binders a aeq n lemma2)
+    | (None, None, Some lemma3) -> 
+	ignore (declare_instance_trans binders a aeq n lemma3)
+    | (Some lemma1, Some lemma2, None) -> 
+	ignore (declare_instance_refl binders a aeq n lemma1); 
+	ignore (declare_instance_sym binders a aeq n lemma2)
+    | (Some lemma1, None, Some lemma3) -> 
+	let _lemma_refl = declare_instance_refl binders a aeq n lemma1 in
+	let _lemma_trans = declare_instance_trans binders a aeq n lemma3 in
+	let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.PreOrder" 
+	in ignore(
+	    anew_instance binders instance 
+	      [((dummy_loc,id_of_string "PreOrder_Reflexive"), [], lemma1);
+	       ((dummy_loc,id_of_string "PreOrder_Transitive"),[], lemma3)])
+    | (None, Some lemma2, Some lemma3) -> 
+	let _lemma_sym = declare_instance_sym binders a aeq n lemma2 in
+	let _lemma_trans = declare_instance_trans binders a aeq n lemma3 in
+	let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.PER" 
+	in ignore(
+	    anew_instance binders instance 
+	      [((dummy_loc,id_of_string "PER_Symmetric"), [], lemma2);
+	       ((dummy_loc,id_of_string "PER_Transitive"),[], lemma3)])
+     | (Some lemma1, Some lemma2, Some lemma3) -> 
+	let _lemma_refl = declare_instance_refl binders a aeq n lemma1 in 
+	let _lemma_sym = declare_instance_sym binders a aeq n lemma2 in
+	let _lemma_trans = declare_instance_trans binders a aeq n lemma3 in
+	let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.Equivalence" 
+	in ignore(
+	  anew_instance binders instance 
+	    [((dummy_loc,id_of_string "Equivalence_Reflexive"), [], lemma1);
+	     ((dummy_loc,id_of_string "Equivalence_Symmetric"),  [], lemma2);
+	     ((dummy_loc,id_of_string "Equivalence_Transitive"),[], lemma3)])
+
+type 'a binders_let_argtype = (local_binder list, 'a) Genarg.abstract_argument_type
+
+let (wit_binders_let : Genarg.tlevel binders_let_argtype),
+  (globwit_binders_let : Genarg.glevel binders_let_argtype),
+  (rawwit_binders_let : Genarg.rlevel binders_let_argtype) =
+  Genarg.create_arg "binders_let"
+
+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_let(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_let(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_let(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_let(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_let(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_let(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_let(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_let(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 mk_qualid s =
+  Libnames.Qualid (dummy_loc, Libnames.qualid_of_string s)
+
+let cHole = CHole (dummy_loc, None)
+
+open Entries
+open Libnames
+
+let respect_projection r ty =
+  let ctx, inst = Sign.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 respect_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 = respect_projection c ty in
+  let typ = Typing.type_of (Global.env ()) Evd.empty term in
+  let ctx, typ = Sign.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.decomp_n_prod (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_type = Some typ;
+      const_entry_opaque = false;
+      const_entry_boxed = 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.create_evar_defs 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 t', sig_, evars = build_signature isevars env t cstrs None snd in
+  let _ = List.iter
+    (fun (ty, rel) -> 
+      let default = mkApp (Lazy.force default_relation, [| ty; rel |]) in
+	ignore (Evarutil.e_new_evar isevars env default))
+    evars
+  in
+  let morph = 
+    mkApp (Lazy.force morphism_type, [| t; sig_; m |])
+  in
+  let evd = 
+    Typeclasses.resolve_typeclasses ~fail:true ~onlyargs:false env !isevars in
+  let m = Evarutil.nf_isevar evd morph in
+    Evarutil.check_evars env Evd.empty evd m; m
+	
+let default_morphism sign m =
+  let env = Global.env () in
+  let isevars = ref (Evd.create_evar_defs Evd.empty) in
+  let t = Typing.type_of env Evd.empty m in
+  let _, sign, evars =
+    try build_signature isevars env t (fst sign) (snd sign) (fun (ty, rel) -> rel)
+    with DependentMorphism -> error "Cannot infer the signature of dependent morphisms"
+  in
+  let morph =
+    mkApp (Lazy.force morphism_type, [| t; sign; m |])
+  in
+  let mor = resolve_one_typeclass env morph in
+    mor, respect_projection mor morph
+    	  
+let add_setoid binders a aeq t n =
+  init_setoid ();
+  let _lemma_refl = declare_instance_refl binders a aeq n (mkappc "Seq_refl" [a;aeq;t]) in 
+  let _lemma_sym = declare_instance_sym binders a aeq n (mkappc "Seq_sym" [a;aeq;t]) in
+  let _lemma_trans = declare_instance_trans binders a aeq n (mkappc "Seq_trans" [a;aeq;t])  in
+  let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.Equivalence"
+  in ignore(
+    anew_instance binders instance
+      [((dummy_loc,id_of_string "Equivalence_Reflexive"), [], mkappc "Seq_refl" [a;aeq;t]);
+       ((dummy_loc,id_of_string "Equivalence_Symmetric"),  [], mkappc "Seq_sym" [a;aeq;t]);
+       ((dummy_loc,id_of_string "Equivalence_Transitive"),[], mkappc "Seq_trans" [a;aeq;t])])
+
+let add_morphism_infer m n =
+  init_setoid ();
+  let instance_id = add_suffix n "_Morphism" in
+  let instance = try build_morphism_signature m 
+    with DependentMorphism -> error "Cannot infer the signature of dependent morphisms"
+  in
+    if Lib.is_modtype () then 
+      let cst = Declare.declare_internal_constant instance_id
+	(Entries.ParameterEntry (instance,false), Decl_kinds.IsAssumption Decl_kinds.Logical)
+      in
+	add_instance (Typeclasses.new_instance (Lazy.force morphism_class) None false cst);
+	declare_projection n instance_id (ConstRef cst)
+    else
+      let kind = Decl_kinds.Global, Decl_kinds.DefinitionBody Decl_kinds.Instance in
+	Flags.silently 
+	  (fun () ->
+	    Command.start_proof instance_id kind instance 
+	      (fun _ -> function
+		  Libnames.ConstRef cst -> 
+		    add_instance (Typeclasses.new_instance (Lazy.force morphism_class) None false 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 binders m s n =
+  init_setoid ();
+  let instance_id = add_suffix n "_Morphism" in
+  let instance = 
+    ((dummy_loc,Name instance_id), Explicit,
+    CAppExpl (dummy_loc, 
+	     (None, Qualid (dummy_loc, Libnames.qualid_of_string "Coq.Classes.Morphisms.Morphism")), 
+	     [cHole; s; m]))
+  in	  
+  let tac = Tacinterp.interp <:tactic<add_morphism_tactic>> in
+    ignore(new_instance binders instance []
+	      ~on_free_vars:Classes.fail_on_free_vars
+	      ~tac ~hook:(fun cst -> declare_projection n instance_id (ConstRef cst))
+	      None)
+
+VERNAC COMMAND EXTEND AddSetoid1
+   [ "Add" "Setoid" constr(a) constr(aeq) constr(t) "as" ident(n) ] ->
+     [ add_setoid [] a aeq t n ]
+  | [ "Add" "Parametric" "Setoid" binders_let(binders) ":" constr(a) constr(aeq) constr(t) "as" ident(n) ] ->
+     [	add_setoid binders a aeq t n ]
+  | [ "Add" "Morphism" constr(m) ":" ident(n) ] ->
+      [ add_morphism_infer m n ]
+  | [ "Add" "Morphism" constr(m) "with" "signature" lconstr(s) "as" ident(n) ] ->
+      [ add_morphism [] m s n ]
+  | [ "Add" "Parametric" "Morphism" binders_let(binders) ":" constr(m) "with" "signature" lconstr(s) "as" ident(n) ] ->
+      [ add_morphism 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 l2r c1 c2 cl car rel but gl = 
+  let (env',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 (pf_env gl) ((if l2r then c1 else c2),but) cl.evd
+    with
+	Pretype_errors.PretypeError _ ->
+	  (* ~flags:(true,true) to make Ring work (since it really
+             exploits conversion) *)
+	  Unification.w_unify_to_subterm ~flags:rewrite2_unif_flags
+	    (pf_env gl) ((if l2r then c1 else c2),but) cl.evd
+  in
+  let cl' = {cl with evd = env'} in
+  let c1 = Clenv.clenv_nf_meta cl' c1 
+  and c2 = Clenv.clenv_nf_meta cl' c2 in
+  check_evar_map_of_evars_defs env';
+  let prf = Clenv.clenv_value cl' in
+  let prfty = 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)}
+
+let get_hyp gl c clause l2r = 
+  let hi = decompose_setoid_eqhyp (pf_env gl) (project gl) c l2r in
+  let but = match clause with Some id -> pf_get_hyp_typ gl id | None -> pf_concl gl in
+    unification_rewrite hi.l2r hi.c1 hi.c2 hi.cl hi.car hi.rel but gl
+	
+let general_rewrite_flags = { under_lambdas = false; on_morphisms = false }
+
+let general_s_rewrite l2r occs c ~new_goals gl =
+  let meta = Evarutil.new_meta() in
+  let hypinfo = ref (get_hyp gl c None l2r) in
+    cl_rewrite_clause_aux ~flags:general_rewrite_flags hypinfo meta occs None gl
+
+let general_s_rewrite_in id l2r occs c ~new_goals gl =
+  let meta = Evarutil.new_meta() in
+  let hypinfo = ref (get_hyp gl c (Some id) l2r) in
+    cl_rewrite_clause_aux ~flags:general_rewrite_flags hypinfo meta occs (Some (([],id), [])) gl
+
+let general_s_rewrite_clause x =
+  init_setoid ();
+  match x with
+    | None -> general_s_rewrite
+    | Some id -> general_s_rewrite_in id
+	
+let _ = Equality.register_general_setoid_rewrite_clause general_s_rewrite_clause
+
+(* [setoid_]{reflexivity,symmetry,transitivity} tactics *)
+
+let relation_of_constr c = 
+  match kind_of_term c with
+    | App (f, args) when Array.length args >= 2 -> 
+	let relargs, args = array_chop (Array.length args - 2) args in
+	  mkApp (f, relargs), args
+    | _ -> error "Not an applied relation"
+
+let is_loaded d =
+  let d' = List.map id_of_string d in
+  let dir = make_dirpath (List.rev d') in
+    Library.library_is_loaded dir
+
+let try_loaded f gl =
+  if is_loaded ["Coq";"Classes";"RelationClasses"] then f gl
+  else tclFAIL 0 (str"You need to require Coq.Classes.RelationClasses first") gl
+    
+let setoid_reflexivity gl =
+  let env = pf_env gl in
+  let rel, args = relation_of_constr (pf_concl gl) in
+    try
+      apply (reflexive_proof env (pf_type_of gl args.(0)) rel) gl
+    with Not_found -> 
+      tclFAIL 0 (str" The relation " ++ Printer.pr_constr_env env rel ++ str" is not a declared reflexive relation")
+	gl
+	  
+let setoid_symmetry gl =
+  let env = pf_env gl in
+  let rel, args = relation_of_constr (pf_concl gl) in
+    try
+      apply (symmetric_proof env (pf_type_of gl args.(0)) rel) gl
+    with Not_found -> 
+      tclFAIL 0 (str" The relation " ++ Printer.pr_constr_env env rel ++ str" is not a declared symmetric relation")
+	gl
+	
+let setoid_transitivity c gl =
+  let env = pf_env gl in
+  let rel, args = relation_of_constr (pf_concl gl) in
+    try
+      apply_with_bindings
+	((transitive_proof env (pf_type_of gl args.(0)) rel),
+	Rawterm.ExplicitBindings [ dummy_loc, Rawterm.NamedHyp (id_of_string "y"), c ]) gl
+    with Not_found -> 
+      tclFAIL 0
+	(str" The relation " ++ Printer.pr_constr_env env rel ++ str" is not a declared transitive relation") gl
+
+let setoid_symmetry_in id gl =
+  let ctype = pf_type_of gl (mkVar id) in
+  let binders,concl = Sign.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 (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 t ]
+END
+
+let try_classes t gls = 
+  try t gls
+  with (Pretype_errors.PretypeError _) as e -> raise e
+
+TACTIC EXTEND try_classes
+  [ "try_classes" tactic(t) ] -> [ try_classes (snd t) ]
+END
+
+open Rawterm
+
+let constrexpr = Pcoq.Tactic.open_constr
+type 'a constr_expr_argtype = (open_constr_expr, 'a) Genarg.abstract_argument_type
+
+let (wit_constrexpr : Genarg.tlevel constr_expr_argtype),
+  (globwit_constrexpr : Genarg.glevel constr_expr_argtype),
+  (rawwit_const_expr : Genarg.rlevel constr_expr_argtype) =
+  Genarg.create_arg "constrexpr"
+			    
+open Environ
+open Refiner
+
+TACTIC EXTEND apply_typeclasses
+   [ "typeclass_app" raw(t) ] -> [ fun gl ->
+     let nprod = nb_prod (pf_concl gl) in
+     let env = pf_env gl in
+     let evars = ref (create_evar_defs (project gl)) in
+     let j = Pretyping.Default.understand_judgment_tcc evars env t in
+     let n = nb_prod j.uj_type - nprod in
+       if n<0 then error "Apply_tc: theorem has not enough premisses.";
+       Refiner.tclTHEN (Refiner.tclEVARS (Evd.evars_of !evars))
+	 (fun gl ->
+	   let clause = make_clenv_binding_apply gl (Some n) (j.uj_val,j.uj_type) NoBindings in
+	   let cl' = evar_clenv_unique_resolver true ~flags:default_unify_flags clause gl in
+	   let evd' = Typeclasses.resolve_typeclasses cl'.env ~fail:true cl'.evd in
+	     Clenvtac.clenv_refine true {cl' with evd = evd'} gl) gl
+   ]
+END
diff --git a/tactics/contradiction.ml b/tactics/contradiction.ml
index eca16066..a2c840a1 100644
--- a/tactics/contradiction.ml
+++ b/tactics/contradiction.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: contradiction.ml 9269 2006-10-24 13:01:55Z herbelin $ *)
+(* $Id: contradiction.ml 10169 2007-10-03 12:31:45Z herbelin $ *)
 
 open Util
 open Term
@@ -24,7 +24,7 @@ open Rawterm
 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_evar_defs sigma) (Retyping.get_judgment_of env sigma c) in
+    (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)) 
@@ -77,7 +77,7 @@ let contradiction_term (c,lbind as cl) gl =
   let typ = pf_type_of gl c in
   let _, ccl = splay_prod env sigma typ in
   if is_empty_type ccl then
-    tclTHEN (elim cl None) (tclTRY assumption) gl
+    tclTHEN (elim false cl None) (tclTRY assumption) gl
   else
     try
       if lbind = NoBindings then
diff --git a/tactics/contradiction.mli b/tactics/contradiction.mli
index d94a1ef2..e417f500 100644
--- a/tactics/contradiction.mli
+++ b/tactics/contradiction.mli
@@ -6,14 +6,15 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: contradiction.mli 5920 2004-07-16 20:01:26Z herbelin $ i*)
+(*i $Id: contradiction.mli 9842 2007-05-20 17:44:23Z herbelin $ i*)
 
 (*i*)
 open Names
 open Term
 open Proof_type
 open Rawterm
+open Genarg
 (*i*)
 
 val absurd                      : constr -> tactic
-val contradiction               : constr with_bindings option -> tactic
+val contradiction               : constr with_ebindings option -> tactic
diff --git a/tactics/decl_interp.ml b/tactics/decl_interp.ml
index 87a47200..d96fa720 100644
--- a/tactics/decl_interp.ml
+++ b/tactics/decl_interp.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id$ *)
+(*i $Id: decl_interp.ml 10739 2008-04-01 14:45:20Z herbelin $ i*)
 
 open Util
 open Names
@@ -25,10 +25,10 @@ open Pp
 let raw_app (loc,hd,args) = if args =[] then hd else RApp(loc,hd,args) 
 
 let intern_justification_items globs = 
-  option_map (List.map (intern_constr globs))
+  Option.map (List.map (intern_constr globs))
 
 let intern_justification_method globs = 
-  option_map (intern_tactic globs)
+  Option.map (intern_tactic globs)
 
 let intern_statement intern_it globs st =
   {st_label=st.st_label;
@@ -52,7 +52,7 @@ let add_name nam globs=
 
 let intern_hyp iconstr globs = function 
     Hvar (loc,(id,topt)) -> add_var id globs,
-      Hvar (loc,(id,option_map (intern_constr globs) topt))
+      Hvar (loc,(id,Option.map (intern_constr globs) topt))
   | Hprop st -> add_name st.st_label globs,
       Hprop (intern_statement iconstr globs st)
 
@@ -73,7 +73,7 @@ let intern_casee globs = function
 let intern_hyp_list args globs =
   let intern_one globs (loc,(id,opttyp)) =
     (add_var id globs),
-    (loc,(id,option_map (intern_constr globs) opttyp)) in
+    (loc,(id,Option.map (intern_constr globs) opttyp)) in
   list_fold_map intern_one globs args 
 
 let intern_suffices_clause globs (hyps,c) = 
@@ -141,7 +141,7 @@ let rec intern_proof_instr globs instr=
 (* INTERP *)
 
 let interp_justification_items sigma env =
-    option_map (List.map (fun c ->understand sigma env (fst c)))
+    Option.map (List.map (fun c ->understand sigma env (fst c)))
 
 let interp_constr check_sort sigma env c = 
   if check_sort then 
@@ -153,7 +153,7 @@ let special_whd env =
   let infos=Closure.create_clos_infos Closure.betadeltaiota env in
     (fun t -> Closure.whd_val infos (Closure.inject t))
 
-let _eq = Libnames.constr_of_reference (Coqlib.glob_eq)
+let _eq = Libnames.constr_of_global (Coqlib.glob_eq)
 
 let decompose_eq env id =
   let typ = Environ.named_type id env in
@@ -166,11 +166,7 @@ let decompose_eq env id =
       | _ -> error "previous step is not an equality"
 
 let get_eq_typ info env =
-  let last_id = 	    
-    match info.pm_last with
-	None -> error "no previous equality"
-      | Some (id,_) -> id in
-  let typ = decompose_eq env last_id in  
+  let typ = decompose_eq env (get_last env) in  
     typ
 
 let interp_constr_in_type typ sigma env c =
@@ -186,17 +182,17 @@ let interp_constr_or_thesis check_sort sigma env = function
 
 let type_tester_var body typ = 
   raw_app(dummy_loc,
-       RLambda(dummy_loc,Anonymous,typ,
+       RLambda(dummy_loc,Anonymous,Explicit,typ,
 	       RSort (dummy_loc,RProp Null)),body)
 
 let abstract_one_hyp inject h raw = 
   match h with 
       Hvar (loc,(id,None)) ->  
-	RProd (dummy_loc,Name id, RHole (loc,Evd.BinderType (Name id)), raw)
+	RProd (dummy_loc,Name id, Explicit, RHole (loc,Evd.BinderType (Name id)), raw)
     | Hvar (loc,(id,Some typ)) ->  
-	RProd (dummy_loc,Name id,fst typ, raw)
+	RProd (dummy_loc,Name id, Explicit, fst typ, raw)
     | Hprop st -> 
-	RProd (dummy_loc,st.st_label,inject st.st_it, raw)
+	RProd (dummy_loc,st.st_label, Explicit, inject st.st_it, raw)
 
 let rawconstr_of_hyps inject hyps head = 
   List.fold_right (abstract_one_hyp inject) hyps head
@@ -258,18 +254,18 @@ let rec raw_of_pat =
 let prod_one_hyp = function
     (loc,(id,None)) ->
       (fun raw ->  
-	 RProd (dummy_loc,Name id, 
+	 RProd (dummy_loc,Name id, Explicit,
 		RHole (loc,Evd.BinderType (Name id)), raw))
   | (loc,(id,Some typ)) -> 
       (fun raw ->  
-	 RProd (dummy_loc,Name id,fst typ, raw))
+	 RProd (dummy_loc,Name id, Explicit, fst typ, raw))
 
 let prod_one_id (loc,id) raw =
-  RProd (dummy_loc,Name id,
+  RProd (dummy_loc,Name id, Explicit,
 	 RHole (loc,Evd.BinderType (Name id)), raw)
 
 let let_in_one_alias (id,pat) raw =
-  RLetIn (dummy_loc,Name id,raw_of_pat pat, raw)
+  RLetIn (dummy_loc,Name id, raw_of_pat pat, raw)
 
 let rec bind_primary_aliases map pat =
   match pat with 
@@ -352,8 +348,6 @@ let interp_cases info sigma env params (pat:cases_pattern_expr) hyps =
   let pat_vars,aliases,patt = interp_pattern env pat in
   let inject = function
       Thesis (Plain) -> Rawterm.RSort(dummy_loc,RProp Null)
-    | Thesis (Sub n) ->
-	error "thesis[_] is not allowed here"
     | Thesis (For rec_occ) ->
 	if not (List.mem rec_occ pat_vars) then 
 	  errorlabstrm "suppose it is" 
@@ -405,7 +399,7 @@ let interp_suffices_clause sigma env (hyps,cot)=
 	This (c,_) -> 
 	  let nhyps,nc = interp_hyps_gen fst (fun x _ -> x) sigma env hyps c in
 	  nhyps,This nc
-      | Thesis (Plain| Sub _) as th  -> interp_hyps sigma env hyps,th
+      | Thesis Plain as th  -> interp_hyps sigma env hyps,th
       | Thesis (For n) -> error "\"thesis for\" is not applicable here" in
   let push_one hyp env0 =
     match hyp with
@@ -423,11 +417,11 @@ let interp_casee sigma env = function
 let abstract_one_arg = function
     (loc,(id,None)) ->
       (fun raw ->  
-	 RLambda (dummy_loc,Name id, 
+	 RLambda (dummy_loc,Name id, Explicit, 
 		RHole (loc,Evd.BinderType (Name id)), raw))
   | (loc,(id,Some typ)) -> 
       (fun raw ->  
-	 RLambda (dummy_loc,Name id,fst typ, raw))
+	 RLambda (dummy_loc,Name id, Explicit, fst typ, raw))
 
 let rawconstr_of_fun args body = 
   List.fold_right abstract_one_arg args (fst body)
diff --git a/tactics/decl_interp.mli b/tactics/decl_interp.mli
index bd085938..59b3b530 100644
--- a/tactics/decl_interp.mli
+++ b/tactics/decl_interp.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id$ *)
+(* $Id: decl_interp.mli 10739 2008-04-01 14:45:20Z herbelin $ *)
 
 open Tacinterp
 open Decl_expr
diff --git a/tactics/decl_proof_instr.ml b/tactics/decl_proof_instr.ml
index a34446d8..895b97fe 100644
--- a/tactics/decl_proof_instr.ml
+++ b/tactics/decl_proof_instr.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id$ *)
+(* $Id: decl_proof_instr.ml 11072 2008-06-08 16:13:37Z herbelin $ *)
 
 open Util
 open Pp
@@ -22,6 +22,7 @@ open Decl_mode
 open Decl_interp
 open Rawterm
 open Names
+open Nameops
 open Declarations
 open Tactics
 open Tacticals
@@ -30,6 +31,7 @@ open Termops
 open Reductionops
 open Goptions
 
+
 (* Strictness option *)
 
 let get_its_info gls = get_info gls.it
@@ -81,42 +83,34 @@ let check_not_per pts =
 Please \"suppose\" something or \"end\" it now."
       | _ -> ()
 
-let get_thesis gls0 = 
- let info = get_its_info gls0 in  
-    match info.pm_subgoals with
-	[m,thesis] -> thesis
-      | _ -> error "Thesis is split"
-
 let mk_evd metalist gls =
-  let evd0= create_evar_defs (sig_sig gls) in
+  let evd0= create_goal_evar_defs (sig_sig gls) in
   let add_one (meta,typ) evd = 
     meta_declare meta typ evd in
     List.fold_right add_one metalist evd0
 
-let set_last cpl gls = 
-  let info = get_its_info gls in
-    tclTHEN 
-      begin 
-	match info.pm_last with 
-	    Some (lid,false) when 
-	      not (occur_id [] lid info.pm_partial_goal) -> 
-		tclTRY (clear [lid])
-	  | _ -> tclIDTAC
-      end
-      begin
-	tcl_change_info 
-	  {info with 
-	    pm_last=Some cpl }
-      end gls
-	  
+let is_tmp id = (string_of_id id).[0] = '_'    
+
+let tmp_ids gls = 
+  let ctx = pf_hyps gls in
+    match ctx with 
+	[] -> []
+      | _::q -> List.filter is_tmp (ids_of_named_context q) 
+
+let clean_tmp gls = 
+  let clean_id id0 gls0 = 
+      tclTRY (clear [id0]) gls0 in
+  let rec clean_all = function
+      [] -> tclIDTAC
+    | id :: rest -> tclTHEN (clean_id id) (clean_all rest)
+  in
+    clean_all (tmp_ids gls) gls
+
 (* start a proof *)
 
 let start_proof_tac gls=
   let gl=sig_it gls in
-  let info={pm_last=None;
-	    pm_partial_goal=mkMeta 1; 
-	    pm_subgoals= [1,gl.evar_concl];
-	    pm_stack=[]} in
+  let info={pm_stack=[]} in
     {it=[{gl with evar_extra=Some (pm_in info)}];sigma=sig_sig gls}, 
   function 
       [pftree] ->
@@ -267,7 +261,8 @@ let add_justification_hyps keep items gls =
       | _ -> 
 	  let id=pf_get_new_id local_hyp_prefix gls in 
 	    keep:=Idset.add id !keep; 
-	    letin_tac false (Names.Name id) c Tacexpr.nowhere gls in 
+	    tclTHEN (letin_tac None (Names.Name id) c Tacexpr.nowhere)
+              (thin_body [id]) gls in 
     tclMAP add_aux items gls   
 
 let prepare_goal items gls =
@@ -292,14 +287,36 @@ let justification tac gls=
 	   error "insufficient justification" 
 	 else
 	   begin
-	     msgnl (str "Warning: insufficient justification");  
+	     msg_warning (str "insufficient justification");  
 	     daimon_tac gls
 	   end) gls
 
 let default_justification elems gls=
   justification (tclTHEN (prepare_goal elems) automation_tac) gls
 
-(* code for have/then/thus/hence *)
+(* code for conclusion refining *)
+
+let constant dir s = lazy (Coqlib.gen_constant "Declarative" dir s)
+
+let _and       = constant ["Init";"Logic"] "and"
+
+let _and_rect  = constant ["Init";"Logic"] "and_rect"
+
+let _prod      = constant ["Init";"Datatypes"] "prod"
+
+let _prod_rect = constant ["Init";"Datatypes"] "prod_rect"
+
+let _ex        = constant ["Init";"Logic"] "ex"
+
+let _ex_ind    = constant ["Init";"Logic"] "ex_ind"
+
+let _sig       = constant ["Init";"Specif"] "sig"
+
+let _sig_rect  = constant ["Init";"Specif"] "sig_rect"
+
+let _sigT      = constant ["Init";"Specif"] "sigT"
+
+let _sigT_rect = constant ["Init";"Specif"] "sigT_rect"
 
 type stackd_elt =
 {se_meta:metavariable;
@@ -336,7 +353,8 @@ let enstack_subsubgoals env se stack gls=
 	    let (nlast,holes,nmetas) = 
 		meta_aux se.se_last_meta [] (List.rev rc) in
 	    let refiner = applist (appterm,List.rev holes) in
-	    let evd = meta_assign se.se_meta refiner se.se_evd in
+	    let evd = meta_assign se.se_meta 
+              (refiner,(ConvUpToEta 0,TypeProcessed (* ? *))) se.se_evd in
 	    let ncreated = replace_in_list 
 	      se.se_meta nmetas se.se_meta_list in
 	    let evd0 = List.fold_left 
@@ -352,19 +370,28 @@ let enstack_subsubgoals env se stack gls=
 	    Array.iteri process gentypes
       | _ -> ()
 
-let find_subsubgoal env c ctyp skip evd metas submetas gls =
+let rec nf_list evd = 
+  function
+      [] -> []  
+    | (m,typ)::others -> 
+	if meta_defined evd m then 
+	    nf_list evd others
+	else
+	  (m,nf_meta evd typ)::nf_list evd others
+
+let find_subsubgoal c ctyp skip submetas gls =
+  let env= pf_env gls in
+  let concl = pf_concl gls in
+  let evd = mk_evd ((0,concl)::submetas) gls in
   let stack = Stack.create () in
   let max_meta = 
-    let tmp = List.fold_left (fun a (m,_) -> max a m) 0 metas in
-      List.fold_left (fun a (m,_) -> max a m) tmp submetas in
-  let _ = 
-    List.iter (fun (m,typ) -> 
-		 Stack.push 
-		   {se_meta=m;
-		    se_type=typ;
-		    se_last_meta=max_meta;
-		    se_meta_list=metas;
-		    se_evd=evd} stack) (List.rev metas) in
+      List.fold_left (fun a (m,_) -> max a m) 0 submetas in
+  let _ = Stack.push 
+		{se_meta=0;
+		 se_type=concl;
+		 se_last_meta=max_meta;
+		 se_meta_list=[0,concl];
+		 se_evd=evd} stack  in
   let rec dfs n = 
     let se = Stack.pop stack in
       try 
@@ -372,10 +399,11 @@ let find_subsubgoal env c ctyp skip evd metas submetas gls =
 	  Unification.w_unify true env Reduction.CUMUL 
 	    ctyp se.se_type se.se_evd in
 	  if n <= 0 then 
-	    {se with 
-	       se_evd=meta_assign se.se_meta c unifier;
-	       se_meta_list=replace_in_list 
-		se.se_meta submetas se.se_meta_list}
+	      {se with 
+		 se_evd=meta_assign se.se_meta
+                  (c,(ConvUpToEta 0,TypeNotProcessed (* ?? *))) unifier;
+	         se_meta_list=replace_in_list 
+		  se.se_meta submetas se.se_meta_list}
 	  else
 	      dfs (pred n)
       with _ -> 
@@ -384,85 +412,86 @@ let find_subsubgoal env c ctyp skip evd metas submetas gls =
 	  dfs n
 	end in
   let nse= try dfs skip with Stack.Empty -> raise Not_found in
-    nse.se_meta_list,nse.se_evd
-
-let rec nf_list evd = 
-  function
-      [] -> []  
-    | (m,typ)::others -> 
-	if meta_defined evd m then 
-	    nf_list evd others
-	else
-	  (m,nf_meta evd typ)::nf_list evd others
-
-let rec max_linear_context meta_one c =
-  if !meta_one = None then
-     if isMeta c then
-       	begin
-	  meta_one:= Some c;
-          mkMeta 1
-	end
-     else
-       try
-	 map_constr (max_linear_context meta_one) c
-       with Not_found -> 
-	 begin
-	   meta_one:= Some c;
-           mkMeta 1
-	 end
-  else   
-    if isMeta c then 
-      raise Not_found
-    else
-      map_constr (max_linear_context meta_one) c
+    nf_list nse.se_evd nse.se_meta_list,nf_meta nse.se_evd (mkMeta 0)
+
+let concl_refiner metas body gls =
+  let concl = pf_concl gls in
+  let evd = sig_sig gls in
+  let env = pf_env gls in
+  let sort = family_of_sort (Typing.sort_of env evd concl) in  
+  let rec aux env avoid subst = function
+      [] -> anomaly "concl_refiner: cannot happen"
+    | (n,typ)::rest ->
+	let _A = subst_meta subst typ in 
+	let x = id_of_name_using_hdchar env _A Anonymous in 
+	let _x = fresh_id avoid x gls in
+	let nenv = Environ.push_named (_x,None,_A) env in
+	let asort = family_of_sort (Typing.sort_of nenv evd _A) in
+	let nsubst = (n,mkVar _x)::subst in
+	  if rest = [] then 
+	    asort,_A,mkNamedLambda _x _A (subst_meta nsubst body)
+	  else
+	    let bsort,_B,nbody = 
+	      aux nenv (_x::avoid) ((n,mkVar _x)::subst) rest in
+	    let body = mkNamedLambda _x _A nbody in
+	      if occur_term (mkVar _x) _B then
+	        begin
+		  let _P = mkNamedLambda _x _A _B in
+		    match bsort,sort with
+			InProp,InProp ->
+			  let _AxB = mkApp(Lazy.force _ex,[|_A;_P|]) in
+			    InProp,_AxB,
+			  mkApp(Lazy.force _ex_ind,[|_A;_P;concl;body|])
+		    | InProp,_ ->
+			let _AxB = mkApp(Lazy.force _sig,[|_A;_P|]) in
+			let _P0 = mkLambda(Anonymous,_AxB,concl) in
+			  InType,_AxB,
+			mkApp(Lazy.force _sig_rect,[|_A;_P;_P0;body|])
+		    | _,_ -> 
+			let _AxB = mkApp(Lazy.force _sigT,[|_A;_P|]) in
+			let _P0 = mkLambda(Anonymous,_AxB,concl) in
+			  InType,_AxB,
+			mkApp(Lazy.force _sigT_rect,[|_A;_P;_P0;body|])
+		end
+	      else
+		begin
+		  match asort,bsort with
+		      InProp,InProp ->
+			let _AxB = mkApp(Lazy.force _and,[|_A;_B|]) in
+			  InProp,_AxB,
+		     mkApp(Lazy.force _and_rect,[|_A;_B;concl;body|])
+		    |_,_ ->
+		       let _AxB = mkApp(Lazy.force _prod,[|_A;_B|]) in
+		       let _P0 = mkLambda(Anonymous,_AxB,concl) in
+			 InType,_AxB,
+			mkApp(Lazy.force _prod_rect,[|_A;_B;_P0;body|])
+		end
+  in
+  let (_,_,prf) = aux env [] [] metas in
+    mkApp(prf,[|mkMeta 1|])
 
 let thus_tac c ctyp submetas gls =  
-  let info = get_its_info gls in
-  let evd0 = mk_evd (info.pm_subgoals@submetas) gls in
-  let list,evd = 
+  let list,proof = 
     try
-      find_subsubgoal (pf_env gls) c ctyp 0 evd0 info.pm_subgoals submetas gls
+      find_subsubgoal c ctyp 0 submetas gls
     with Not_found -> 
       error "I could not relate this statement to the thesis" in
-  let nflist = nf_list evd list in
-  let nfgoal = nf_meta evd info.pm_partial_goal in
-(*  let _ = msgnl (str "Partial goal : " ++ 
-		   print_constr_env (pf_env gls) nfgoal) in *)
-  let rgl = ref None in
-  let refiner = max_linear_context rgl nfgoal in
-    match !rgl with
-	None -> exact_check refiner gls
-      | Some pgl when not (isMeta refiner) ->
-	  let ninfo={info with
-		       pm_partial_goal = pgl;
-		       pm_subgoals = nflist} in
-	    tclTHEN
-	      (Tactics.refine refiner)
-	      (tcl_change_info ninfo) 
-	      gls
-      | _ -> 
-	  let ninfo={info with
-		       pm_partial_goal = nfgoal;
-		       pm_subgoals = nflist} in
-	    tcl_change_info ninfo gls
+  if list = [] then
+    exact_check proof gls 
+  else
+    let refiner = concl_refiner list proof gls in
+      Tactics.refine refiner gls
 
-let anon_id_base = id_of_string "__" 
+(* general forward step *)
 
 
-let mk_stat_or_thesis info = function  
+let anon_id_base = id_of_string "__" 
+
+let mk_stat_or_thesis info gls = function  
     This c -> c
   | Thesis (For _ ) -> 
       error "\"thesis for ...\" is not applicable here" 
-  | Thesis (Sub n) ->
-      begin
-	try List.assoc n info.pm_subgoals 
-	with Not_found -> error "No such part in thesis."
-      end
-  | Thesis Plain ->   
-      match info.pm_subgoals with
-	  [_,c] -> c
-	| _ -> error 
-	    "\"thesis\" is split, please specify which part you refer to."
+  | Thesis Plain -> pf_concl gls
 
 let just_tac _then cut info gls0 =
   let items_tac gls =
@@ -470,11 +499,10 @@ let just_tac _then cut info gls0 =
 	None -> tclIDTAC gls
       | Some items -> 
 	  let items_ = 
-	    if _then then
-	      match info.pm_last with
-		  None -> error "no previous statement to use"
-		| Some (id,_) -> (mkVar id)::items
-	    else items
+	    if _then then 
+	      let last_id = get_last (pf_env gls) in
+		(mkVar last_id)::items
+	    else items 
 	  in prepare_goal items_ gls in
   let method_tac gls = 
     match cut.cut_using with
@@ -487,23 +515,23 @@ let just_tac _then cut info gls0 =
 let instr_cut mkstat _thus _then cut gls0 = 
   let info = get_its_info gls0 in 
   let stat = cut.cut_stat in
-  let (c_id,_) as cpl = match stat.st_label with 
+  let (c_id,_) = match stat.st_label with 
       Anonymous -> 
 	pf_get_new_id (id_of_string "_fact") gls0,false 
     | Name id -> id,true in
-  let c_stat = mkstat info stat.st_it in
+  let c_stat = mkstat info gls0 stat.st_it in
   let thus_tac gls= 
     if _thus then 
       thus_tac (mkVar c_id) c_stat [] gls
     else tclIDTAC gls in
     tclTHENS (internal_cut c_id c_stat) 
       [tclTHEN tcl_erase_info (just_tac _then cut info);
-       tclTHEN (set_last cpl) thus_tac] gls0
+       thus_tac] gls0
 
 
 
 (* iterated equality *)
-let _eq = Libnames.constr_of_reference (Coqlib.glob_eq)
+let _eq = Libnames.constr_of_global (Coqlib.glob_eq)
 
 let decompose_eq id gls =
   let typ = pf_get_hyp_typ gls id in
@@ -518,11 +546,8 @@ let decompose_eq id gls =
       | _ -> error "previous step is not an equality"
 	  
 let instr_rew _thus rew_side cut gls0 = 
-  let info = get_its_info gls0 in
-  let last_id = 	    
-    match info.pm_last with
-	None -> error "no previous equality"
-      | Some (id,_) -> id in
+  let last_id = 
+    try get_last (pf_env gls0) with _ -> error "no previous equality" in
   let typ,lhs,rhs = decompose_eq last_id gls0 in  
   let items_tac gls =
     match cut.cut_by with
@@ -536,7 +561,7 @@ let instr_rew _thus rew_side cut gls0 =
 	  (Tacinterp.eval_tactic tac) gls in
   let just_tac gls =
     justification (tclTHEN items_tac method_tac) gls in
-  let (c_id,_) as cpl = match cut.cut_stat.st_label with 
+  let (c_id,_) = match cut.cut_stat.st_label with 
       Anonymous -> 
 	pf_get_new_id (id_of_string "_eq") gls0,false 
     | Name id -> id,true in
@@ -551,14 +576,14 @@ let instr_rew _thus rew_side cut gls0 =
 	      [tclTHEN tcl_erase_info 
 		 (tclTHENS (transitivity lhs) 
 		    [just_tac;exact_check (mkVar last_id)]);
-	       tclTHEN (set_last cpl) (thus_tac new_eq)] gls0
+	       thus_tac new_eq] gls0
       | Rhs ->
 	  let new_eq = mkApp(_eq,[|typ;lhs;cut.cut_stat.st_it|]) in
 	    tclTHENS (internal_cut c_id new_eq) 
 	      [tclTHEN tcl_erase_info 
 		 (tclTHENS (transitivity rhs) 
 		    [exact_check (mkVar last_id);just_tac]);
-	       tclTHEN (set_last cpl) (thus_tac new_eq)] gls0
+	       thus_tac new_eq] gls0
 	      
 
 
@@ -566,48 +591,29 @@ let instr_rew _thus rew_side cut gls0 =
 
 let instr_claim _thus st gls0 = 
   let info = get_its_info gls0 in  
-  let (id,_) as cpl = match st.st_label with 
+  let (id,_) = match st.st_label with 
       Anonymous -> pf_get_new_id (id_of_string "_claim") gls0,false 
     | Name id -> id,true in
   let thus_tac gls= 
     if _thus then 
       thus_tac (mkVar id) st.st_it [] gls
     else tclIDTAC gls in
-  let ninfo1 = {info with 
-		  pm_stack=
-      (if _thus then Focus_claim else Claim)::info.pm_stack;
-		  pm_partial_goal=mkMeta 1;
-	          pm_subgoals = [1,st.st_it]} in
+  let ninfo1 = {pm_stack=
+      (if _thus then Focus_claim else Claim)::info.pm_stack} in
     tclTHENS (internal_cut id st.st_it) 
       [tcl_change_info ninfo1;
-       tclTHEN (set_last cpl) thus_tac] gls0
+       thus_tac] gls0
 
 (* tactics for assume *)
 
-let reset_concl gls =
-  let info = get_its_info gls in
-    tcl_change_info 
-      {info with 
-	 pm_partial_goal=mkMeta 1;
-	 pm_subgoals= [1,gls.it.evar_concl]} gls
-
-
-let intro_pm id gls=
-  let info = get_its_info gls in
-    match info.pm_subgoals with
-	[(_,typ)] -> 
-	  tclTHEN (intro_mustbe_force id) reset_concl gls
-      | _ -> error "Goal is split"
-
 let push_intro_tac coerce nam gls = 
-      let (hid,_) as cpl =
+      let (hid,_) =
 	match nam with 
 	    Anonymous -> pf_get_new_id (id_of_string "_hyp") gls,false 
 	  | Name id -> id,true in
 	tclTHENLIST 
-	  [intro_pm hid;
-	   coerce hid;
-	   set_last cpl]
+	  [intro_mustbe_force hid;
+	   coerce hid]
 	  gls 
 
 let assume_tac hyps gls = 
@@ -652,10 +658,6 @@ let assume_st_letin hyps gls =
 
 (* suffices *)
 
-let free_meta info = 
-  let max_next (i,_) j  = if j <= i then succ i else j in
-  List.fold_right max_next info.pm_subgoals 1
-
 let rec metas_from n hyps = 
   match hyps with
       _ :: q -> n :: metas_from (succ n) q
@@ -683,31 +685,21 @@ let instr_suffices _then cut gls0 =
   let info = get_its_info gls0 in 
   let c_id = pf_get_new_id (id_of_string "_cofact") gls0 in 
   let ctx,hd = cut.cut_stat in
-  let c_stat = build_product ctx (mk_stat_or_thesis info hd) in
-  let metas = metas_from (free_meta info) ctx in
+  let c_stat = build_product ctx (mk_stat_or_thesis info gls0 hd) in
+  let metas = metas_from 1 ctx in
   let c_ctx,c_head = build_applist c_stat metas in
   let c_term = applist (mkVar c_id,List.map mkMeta metas) in  
   let thus_tac gls= 
     thus_tac c_term c_head c_ctx gls in
    tclTHENS (internal_cut c_id c_stat) 
      [tclTHENLIST 
-	 [ tcl_change_info 
-	     {info with 
-	       pm_partial_goal=mkMeta 1;
-	       pm_subgoals=[1,c_stat]};
-	   assume_tac ctx;   
+	 [ assume_tac ctx;   
 	   tcl_erase_info;
 	   just_tac _then cut info];
-      tclTHEN (set_last (c_id,false)) thus_tac] gls0
+      thus_tac] gls0
 
 (* tactics for consider/given *)
 
-let update_goal_info gls =
-  let info = get_its_info gls in
-    match info.pm_subgoals with
-	[m,_] -> tcl_change_info {info with pm_subgoals =[m,pf_concl gls]} gls
-      | _ -> error "thesis is split"
-
 let conjunction_arity id gls =
   let typ = pf_get_hyp_typ gls id  in
   let hd,params = decompose_app (special_whd gls typ) in
@@ -726,30 +718,18 @@ let conjunction_arity id gls =
 
 let rec intron_then n ids ltac gls = 
   if n<=0 then 
-    tclTHEN
-    (fun gls -> 
-       if List.exists (fun id -> occur_id [] id (pf_concl gls)) ids  then 
-	 update_goal_info gls
-       else 
-	 tclIDTAC gls)
-    (ltac ids)
-      gls
+    ltac ids gls
   else  
     let id = pf_get_new_id (id_of_string "_tmp") gls in 
       tclTHEN 
 	(intro_mustbe_force id) 
 	(intron_then (pred n) (id::ids) ltac) gls 
 
-let pm_rename_hyp id hid gls =
-  if occur_id [] id (pf_concl gls) then
-    tclTHEN (rename_hyp id hid) update_goal_info gls
-  else
-    rename_hyp id hid gls 
 
 let rec consider_match may_intro introduced available expected gls =
   match available,expected with 
       [],[] ->
-	  set_last (List.hd introduced) gls
+	  tclIDTAC gls
     | _,[] -> error "last statements do not match a complete hypothesis" 
 	(* should tell which ones *)
     | [],hyps -> 
@@ -757,7 +737,7 @@ let rec consider_match may_intro introduced available expected gls =
 	  begin
  	    let id = pf_get_new_id (id_of_string "_tmp") gls in
 	      tclIFTHENELSE 
-		(intro_pm id)
+		(intro_mustbe_force id)
 		(consider_match true [] [id] hyps) 
 		(fun _ -> 
 		   error "not enough sub-hypotheses to match statements")
@@ -774,7 +754,7 @@ let rec consider_match may_intro introduced available expected gls =
 		  consider_match may_intro ((id,false)::introduced) rest_ids rest
 	      | Name hid -> 
 		  tclTHENLIST 
-		    [pm_rename_hyp id hid;
+		    [rename_hyp [id,hid];
 		     consider_match may_intro ((hid,true)::introduced) rest_ids rest]
 	  end
 	  begin
@@ -783,7 +763,7 @@ let rec consider_match may_intro introduced available expected gls =
 		 try conjunction_arity id gls with 
 		     Not_found -> error "matching hypothesis not found" in 
 		 tclTHENLIST 
-		   [general_case_analysis (mkVar id,NoBindings);
+		   [general_case_analysis false (mkVar id,NoBindings);
 		    intron_then nhyps []
 		      (fun l -> consider_match may_intro introduced 
 			 (List.rev_append l rest_ids) expected)] gls)
@@ -828,49 +808,74 @@ let rec build_function args body =
 
 let define_tac id args body gls =
   let t = build_function args body in
-    letin_tac true (Name id) t Tacexpr.nowhere gls
+    letin_tac None (Name id) t Tacexpr.nowhere gls
 
 (* tactics for reconsider *)
 
 let cast_tac id_or_thesis typ gls = 
-  let info = get_its_info gls in
   match id_or_thesis with
       This id ->
 	let (_,body,_) = pf_get_hyp gls id in
 	  convert_hyp (id,body,typ) gls
     | Thesis (For _ ) -> 
 	error "\"thesis for ...\" is not applicable here" 
-    | Thesis (Sub n) ->
-	begin
-	  let old_typ = 
-	    try List.assoc n info.pm_subgoals 
-	    with Not_found -> error "No such part in thesis." in
-	  if is_conv_leq (pf_env gls) (sig_sig gls) typ old_typ then
-	    let new_sg = List.merge  
-	      (fun (n,_) (p,_) -> Pervasives.compare n p) 
-	      [n,typ] (List.remove_assoc n info.pm_subgoals) in
-	      tcl_change_info {info with pm_subgoals=new_sg} gls
-	  else 
-	    error "not convertible"
-	end
-    | Thesis Plain ->   
-	match info.pm_subgoals with 
-	    [m,c] -> 
-	      tclTHEN 
-		(convert_concl typ DEFAULTcast) 
-	        (tcl_change_info {info with pm_subgoals= [m,typ]}) gls
-	  | _ -> error 
-	      "\"thesis\" is split, please specify which part you refer to."
-  
+    | Thesis Plain ->    
+          convert_concl typ DEFAULTcast gls
       
 (* per cases *)
 
-let start_tree env ind = 
-  let constrs = (snd (Inductive.lookup_mind_specif env ind)).mind_consnames in
-    Split (Idset.empty,ind,Array.map (fun _ -> None) constrs)
+let is_rec_pos (main_ind,wft) =
+  match main_ind with
+      None -> false
+    | Some index -> 
+	match fst (Rtree.dest_node wft) with
+	    Mrec i when i = index -> true
+	  | _ -> false
+
+let rec constr_trees (main_ind,wft) ind =
+    match Rtree.dest_node wft with
+      Norec,_ -> 
+	let itree = 
+	  (snd (Global.lookup_inductive ind)).mind_recargs in 
+	  constr_trees (None,itree) ind
+    | _,constrs -> main_ind,constrs
+
+let constr_args rp constr =
+  let main_ind,constrs = constr_trees rp (fst constr) in
+  let ctree = constrs.(pred (snd constr)) in
+    array_map_to_list (fun t -> main_ind,t) 
+      (snd (Rtree.dest_node ctree))
+
+let ind_args rp ind =
+    let main_ind,constrs = constr_trees rp ind in
+    let args ctree =     
+      Array.map (fun t -> main_ind,t) (snd (Rtree.dest_node ctree)) in
+      Array.map args constrs
+
+let init_tree ids ind rp nexti =
+  let indargs = ind_args rp ind in
+  let do_i i arp = (Array.map is_rec_pos arp),nexti i arp in
+    Split_patt (ids,ind,Array.mapi do_i indargs)
+
+let map_tree_rp rp id_fun mapi = function
+    Split_patt (ids,ind,branches) ->
+  let indargs = ind_args rp ind in 
+  let do_i i (recargs,bri) = recargs,mapi i indargs.(i) bri in
+    Split_patt (id_fun ids,ind,Array.mapi do_i branches)
+  | _ -> failwith "map_tree_rp: not a splitting node"
+
+let map_tree id_fun mapi = function
+    Split_patt (ids,ind,branches) ->
+  let do_i i (recargs,bri) = recargs,mapi i bri in
+    Split_patt (id_fun ids,ind,Array.mapi do_i branches)
+  | _ -> failwith "map_tree: not a splitting node"
+
+
+let start_tree env ind rp = 
+  init_tree Idset.empty ind rp (fun _ _ -> None)
 
 let build_per_info etype casee gls = 
-  let concl=get_thesis gls in
+  let concl=pf_concl gls in
   let env=pf_env gls in
   let ctyp=pf_type_of gls casee in
   let is_dep = dependent casee concl in 
@@ -880,11 +885,11 @@ let build_per_info etype casee gls =
       destInd hd 
     with _ -> 
       error "Case analysis must be done on an inductive object" in
-  let nparams =
-    let mind = fst (Global.lookup_inductive ind) in
-     match etype with
-	 ET_Induction -> mind.mind_nparams_rec
-       | _ -> mind.mind_nparams in
+  let mind,oind = Global.lookup_inductive ind in
+  let nparams,index =
+    match etype with
+	ET_Induction -> mind.mind_nparams_rec,Some (snd ind)
+      | _ -> mind.mind_nparams,None in
   let params,real_args = list_chop nparams args in
   let abstract_obj c body = 
     let typ=pf_type_of gls c in 
@@ -898,7 +903,8 @@ let build_per_info etype casee gls =
    per_pred=pred;
    per_args=real_args;
    per_params=params;
-   per_nparams=nparams}
+   per_nparams=nparams;   
+   per_wf=index,oind.mind_recargs}
 
 let per_tac etype casee gls=
   let env=pf_env gls in
@@ -908,25 +914,24 @@ let per_tac etype casee gls=
 	  let is_dep,per_info = build_per_info etype c gls in
 	  let ek = 
 	    if is_dep then
-	      EK_dep (start_tree env per_info.per_ind)
+	      EK_dep (start_tree env per_info.per_ind per_info.per_wf)
 	    else EK_unknown in
 	    tcl_change_info 
-	      {info with 
-		 pm_stack=
+	      {pm_stack=
 		  Per(etype,per_info,ek,[])::info.pm_stack} gls
       | Virtual cut ->
 	  assert (cut.cut_stat.st_label=Anonymous);
-	  let id = pf_get_new_id (id_of_string "_matched") gls in
+	  let id = pf_get_new_id (id_of_string "anonymous_matched") gls in
 	  let c = mkVar id in
 	  let modified_cut = 
 	    {cut with cut_stat={cut.cut_stat with st_label=Name id}} in
 	    tclTHEN 
-	      (instr_cut (fun _ c -> c) false false modified_cut)
+	      (instr_cut (fun _ _ c -> c) false false modified_cut)
 	      (fun gls0 ->
 		 let is_dep,per_info = build_per_info etype c gls0 in
 		   assert (not is_dep);
 		   tcl_change_info 
-		     {info with pm_stack=
+		     {pm_stack=
 			 Per(etype,per_info,EK_unknown,[])::info.pm_stack} gls0)
 	      gls
 
@@ -944,16 +949,12 @@ let register_nodep_subcase id= function
 
 let suppose_tac hyps gls0 = 
   let info = get_its_info gls0 in
-  let thesis = get_thesis gls0 in
-  let id = pf_get_new_id (id_of_string "_subcase") gls0 in
+  let thesis = pf_concl gls0 in
+  let id = pf_get_new_id (id_of_string "subcase_") gls0 in
   let clause = build_product hyps thesis in
-  let ninfo1 = {info with 
-		  pm_stack=Suppose_case::info.pm_stack;
-		  pm_partial_goal=mkMeta 1;
-		  pm_subgoals = [1,clause]} in
+  let ninfo1 = {pm_stack=Suppose_case::info.pm_stack} in
   let old_clauses,stack = register_nodep_subcase id info.pm_stack in
-  let ninfo2 = {info with 
-		  pm_stack=stack} in
+  let ninfo2 = {pm_stack=stack} in
     tclTHENS (internal_cut id clause) 
       [tclTHENLIST [tcl_change_info ninfo1;
 		    assume_tac hyps;
@@ -964,120 +965,109 @@ let suppose_tac hyps gls0 =
 
 (* pattern matching compiling *)
 
-let rec nb_prod_after n c=
-  match kind_of_term c with
-    | Prod (_,_,b) ->if n>0 then nb_prod_after (n-1) b else 
-	1+(nb_prod_after 0 b)
-    | _ -> 0
-
-let constructor_arities env ind =
-  let nparams = (fst (Global.lookup_inductive ind)).mind_nparams in
-  let constr_types = Inductiveops.arities_of_constructors env ind in 
-  let hyp = nb_prod_after nparams in	
-    Array.map hyp constr_types
-
-let rec n_push rest ids n = 
-  if n<=0 then Pop rest else Push (ids,n_push rest ids (pred n)) 
-
-let explode_branches ids env ind rest=
-  Array.map (fun n -> Some (Idset.empty,n_push rest ids n)) (constructor_arities env ind)
+let rec skip_args rest ids n =
+  if n <= 0 then
+    Close_patt rest
+  else
+    Skip_patt (ids,skip_args rest ids (pred n))
 
-let rec tree_of_pats env ((id,_) as cpl) pats =
+let rec tree_of_pats ((id,_) as cpl) pats =
   match pats with 
-      [] -> End_of_branch cpl
+      [] -> End_patt cpl
     | args::stack ->
 	match args with
-	    [] -> Pop (tree_of_pats env cpl stack)
-	  | patt :: rest_args ->
+	    [] -> Close_patt (tree_of_pats cpl stack)
+	  | (patt,rp) :: rest_args ->
 	      match patt with
 		  PatVar (_,v) -> 
-		    Push (Idset.singleton id,
-			  tree_of_pats env cpl (rest_args::stack))
-		|  PatCstr (_,(ind,cnum),args,nam) ->
-		     let _,mind = Inductive.lookup_mind_specif env ind in
-		     let br= Array.map (fun _ -> None) mind.mind_consnames in
-		       br.(pred cnum) <- 
-			 Some (Idset.singleton id,
-			       tree_of_pats env cpl (args::rest_args::stack));
-		       Split(Idset.empty,ind,br)
-
-let rec add_branch env ((id,_) as cpl) pats tree=
+		    Skip_patt (Idset.singleton id,
+			       tree_of_pats cpl (rest_args::stack))
+		| PatCstr (_,(ind,cnum),args,nam) ->
+		    let nexti i ati =
+		      if i = pred cnum then 
+			let nargs = 
+			  list_map_i (fun j a -> (a,ati.(j))) 0 args in
+			  Some (Idset.singleton id,
+				tree_of_pats cpl (nargs::rest_args::stack))
+		      else None
+		      in init_tree Idset.empty ind rp nexti
+
+let rec add_branch ((id,_) as cpl) pats tree=
   match pats with 
       [] -> 
 	begin
 	  match tree with
-	      End_of_branch cpl0 -> End_of_branch cpl0 
-		(* this ensures precedence *) 
+	      End_patt cpl0 -> End_patt cpl0 
+		(* this ensures precedence for overlapping patterns *) 
 	    | _ -> anomaly "tree is expected to end here"
 	end
     | args::stack ->
 	match args with 
 	    [] ->
 	      begin
-		match tree with 
-		    Pop t -> Pop (add_branch env cpl stack t)
+		match tree with
+		   Close_patt t -> 
+		     Close_patt (add_branch cpl stack t)
 		  | _ -> anomaly "we should pop here" 
 	      end
-	  | patt :: rest_args ->
+	  | (patt,rp) :: rest_args ->
 	      match patt with
 		  PatVar (_,v) ->
 		    begin
 		      match tree with 
-			  Push (ids,t) -> 
-			    Push (Idset.add id ids,
-				  add_branch env cpl (rest_args::stack) t)
-			| Split (ids,ind,br) ->
-			    Split (Idset.add id ids,
-				   ind,array_map2 
-				     (append_branch env cpl 1 
-					(rest_args::stack)) 
-				     (constructor_arities env ind) br)
+			  Skip_patt (ids,t) -> 
+			    Skip_patt (Idset.add id ids,
+				       add_branch cpl (rest_args::stack) t)
+			| Split_patt (_,_,_) ->
+			    map_tree (Idset.add id)
+			      (fun i bri ->  
+				 append_branch cpl 1 (rest_args::stack) bri) 
+			      tree
 			| _ -> anomaly "No pop/stop expected here"  
 		    end
 		| PatCstr (_,(ind,cnum),args,nam) ->
-		    match tree with
-			Push (ids,t) ->
-			  let br = explode_branches ids env ind t in
-			  let _ =
-			    br.(pred cnum)<- 
-			      option_map
-			      (fun (ids,tree) -> 
-				 Idset.add id ids,
-				 add_branch env cpl 
-				   (args::rest_args::stack) tree) 
-			      br.(pred cnum) in
-			    Split (ids,ind,br)
-		      | Split (ids,ind0,br0) ->
+		      match tree with
+			Skip_patt (ids,t) ->
+			  let nexti i ati =
+			    if i = pred cnum then 
+			      let nargs = 
+				list_map_i (fun j a -> (a,ati.(j))) 0 args in
+				Some (Idset.add id ids,
+				      add_branch cpl (nargs::rest_args::stack)
+					(skip_args t ids (Array.length ati)))
+			    else 
+			      Some (ids,
+				    skip_args t ids (Array.length ati))
+			  in init_tree ids ind rp nexti
+		      | Split_patt (_,ind0,_) ->
 			  if (ind <> ind0) then error
 			    (* this can happen with coercions *)
-	                      "Case pattern belongs to wrong inductive type";
-			  let br=Array.copy br0 in
-			  let ca = constructor_arities env ind in
-			  let _= br.(pred cnum)<-
-			    append_branch env cpl 0 (args::rest_args::stack) 
-			    ca.(pred cnum) br.(pred cnum) in 
-			    Split (ids,ind,br)
+	                    "Case pattern belongs to wrong inductive type";
+			  let mapi i ati bri =
+			    if i = pred cnum then 
+			      let nargs = 
+				list_map_i (fun j a -> (a,ati.(j))) 0 args in
+				append_branch cpl 0 
+				  (nargs::rest_args::stack) bri
+			    else bri in
+			    map_tree_rp rp (fun ids -> ids) mapi tree
 		      | _ -> anomaly "No pop/stop expected here"
-and append_branch env ((id,_) as cpl) depth pats nargs = function
+and append_branch ((id,_) as cpl) depth pats = function
     Some (ids,tree) -> 
-      Some (Idset.add id ids,append_tree env cpl depth pats tree)
+      Some (Idset.add id ids,append_tree cpl depth pats tree)
   | None ->
-      Some (* (n_push (tree_of_pats env cpl pats) 
-	      (Idset.singleton id) nargs) *)
-	   (Idset.singleton id,tree_of_pats env cpl pats)
-and append_tree env ((id,_) as cpl) depth pats tree =
-  if depth<=0 then add_branch env cpl pats tree
+      Some (Idset.singleton id,tree_of_pats cpl pats)
+and append_tree ((id,_) as cpl) depth pats tree =
+  if depth<=0 then add_branch cpl pats tree
   else match tree with
-      Pop t -> Pop (append_tree env cpl (pred depth) pats t)
-    | Push (ids,t) -> Push (Idset.add id ids,
-				   append_tree env cpl depth pats t)
-    | End_of_branch _ -> anomaly "Premature end of branch"
-    | Split (ids,ind,branches) -> 
-	Split (Idset.add id ids,ind,
-	       array_map2 
-		 (append_branch env cpl (succ depth) pats) 
-		 (constructor_arities env ind)
-		 branches)
+      Close_patt t -> 
+	Close_patt (append_tree cpl (pred depth) pats t)
+    | Skip_patt (ids,t) -> 
+	Skip_patt (Idset.add id ids,append_tree cpl depth pats t)
+    | End_patt _ -> anomaly "Premature end of branch"
+    | Split_patt (_,_,_) -> 
+	map_tree (Idset.add id) 
+	  (fun i bri -> append_branch cpl (succ depth) pats bri) tree 
 
 (* suppose it is *)
 
@@ -1129,8 +1119,7 @@ let rec build_product_dep pat_info per_info args body gls =
 		  with Not_found -> 
 		    snd (st_assoc (Name id) pat_info.pat_aliases) in
 		  thesis_for obj typ per_info (pf_env gls)
-	    | Plain -> get_thesis gls 
-	    | Sub n -> anomaly "Subthesis in cases" in
+	    | Plain -> pf_concl gls in
 	  mkProd (st.st_label,ptyp,lbody)
     | [] -> body 
 
@@ -1156,26 +1145,22 @@ let rec register_dep_subcase id env per_info pat = function
     EK_nodep -> error  "Only \"suppose it is\" can be used here."
   | EK_unknown -> 
       register_dep_subcase id env per_info pat
-	(EK_dep (start_tree env per_info.per_ind))
-  | EK_dep tree -> EK_dep (add_branch env id [[pat]] tree)
+	(EK_dep (start_tree env per_info.per_ind per_info.per_wf))
+  | EK_dep tree -> EK_dep (add_branch id [[pat,per_info.per_wf]] tree)
   
 let case_tac params pat_info hyps gls0 =
   let info = get_its_info gls0 in
-  let id = pf_get_new_id (id_of_string "_subcase") gls0 in
+  let id = pf_get_new_id (id_of_string "subcase_") gls0 in
   let et,per_info,ek,old_clauses,rest =
     match info.pm_stack with
 	Per (et,pi,ek,old_clauses)::rest -> (et,pi,ek,old_clauses,rest) 
       | _ -> anomaly "wrong place for cases" in
   let clause = build_dep_clause params pat_info per_info hyps gls0 in
-  let ninfo1 = {info with 
-		  pm_stack=Suppose_case::info.pm_stack;
-		  pm_partial_goal=mkMeta 1;
-		  pm_subgoals = [1,clause]} in
+  let ninfo1 = {pm_stack=Suppose_case::info.pm_stack} in
   let nek = 
     register_dep_subcase (id,List.length hyps) (pf_env gls0) per_info 
       pat_info.pat_pat ek in  
-  let ninfo2 = {info with 
-		  pm_stack=Per(et,per_info,nek,id::old_clauses)::rest} in
+  let ninfo2 = {pm_stack=Per(et,per_info,nek,id::old_clauses)::rest} in
     tclTHENS (internal_cut id clause) 
       [tclTHENLIST 
 	 [tcl_change_info ninfo1; 
@@ -1188,181 +1173,152 @@ let case_tac params pat_info hyps gls0 =
 (* end cases *)
 
 type instance_stack =
-    (constr option*bool*(constr list) list) list
+    (constr option*(constr list) list) list
 
 let initial_instance_stack ids =
-  List.map (fun id -> id,[None,false,[]]) ids
+  List.map (fun id -> id,[None,[]]) ids
 
 let push_one_arg arg = function 
     [] -> anomaly "impossible"
-  | (head,is_rec,args) :: ctx -> 
-      ((head,is_rec,(arg::args)) :: ctx)
+  | (head,args) :: ctx -> 
+      ((head,(arg::args)) :: ctx)
 
 let push_arg arg stacks =
   List.map (fun (id,stack) -> (id,push_one_arg arg stack)) stacks
   
 
-let push_one_head c is_rec ids (id,stack) = 
+let push_one_head c ids (id,stack) = 
   let head = if Idset.mem id ids then Some c else None in
-    id,(head,is_rec,[]) :: stack
+    id,(head,[]) :: stack
 
-let push_head c is_rec ids stacks =
-  List.map (push_one_head c is_rec ids) stacks
+let push_head c ids stacks =
+  List.map (push_one_head c ids) stacks
 
-let pop_one rec_flag (id,stack) =  
+let pop_one (id,stack) =  
   let nstack=
     match stack with
 	[] -> anomaly "impossible"
       | [c] as l -> l
-      | (Some head,is_rec,args)::(head0,is_rec0,args0)::ctx ->
+      | (Some head,args)::(head0,args0)::ctx ->
 	  let arg = applist (head,(List.rev args)) in
-	    rec_flag:= !rec_flag || is_rec;
-	    (head0,is_rec0,(arg::args0))::ctx
-     | (None,is_rec,args)::(head0,is_rec0,args0)::ctx ->
-	 rec_flag:= !rec_flag || is_rec;
-	 (head0,is_rec0,(args@args0))::ctx
+	    (head0,(arg::args0))::ctx
+     | (None,args)::(head0,args0)::ctx ->
+	 (head0,(args@args0))::ctx
   in id,nstack
 
 let pop_stacks stacks =
-  let rec_flag= ref false in 
-  let nstacks = List.map (pop_one rec_flag) stacks in
-    !rec_flag , nstacks
+  List.map pop_one stacks
 
 let patvar_base = id_of_string "__"
 
-let test_fun (str:string) = ()
-
-let hrec_for obj_id fix_id per_info gls=
+let hrec_for fix_id per_info gls obj_id =
   let obj=mkVar obj_id in
   let typ=pf_get_hyp_typ gls obj_id in
   let rc,hd1=decompose_prod typ in
   let cind,all_args=decompose_app typ in
-    match kind_of_term cind with
-	Ind ind when ind=per_info.per_ind ->
-	  let params,args= list_chop per_info.per_nparams all_args in 
-	    if try 
-	      (List.for_all2 eq_constr params per_info.per_params)
-	    with Invalid_argument _ -> false then
-	      let hd2 = applist (mkVar fix_id,args@[obj]) in
-		Some (compose_lam rc (whd_beta hd2))
-	    else None
-      | _ -> None
-
-
-(* custom elim performs the case analysis of hypothesis id from the local 
-context, 
-
-- generalizing hypotheses below id
-- computing the elimination predicate (abstract inductive predicate) 
-- build case analysis term 
-- generalize rec_calls (use wf_paths)
-- vector of introduced identifiers per branch 
-
-match id in t return p with
- C1 ... => ?1 
-|C2 ... => ?2
-...
-end*)
-
-
-    
-
-
-
-
-
-
-let rec execute_cases at_top fix_name per_info kont0 stacks tree gls = 
-	      match tree with
-      Pop t ->  
-	let is_rec,nstacks =  pop_stacks stacks in
-	  if is_rec then
-	    let _ = test_fun "is_rec=true" in
-	     let c_id = pf_get_new_id (id_of_string "_hrec") gls in
-	       tclTHEN 
-		 (intro_mustbe_force c_id)
-		 (execute_cases false fix_name per_info kont0 nstacks t) gls
-	  else
-	    execute_cases false fix_name per_info kont0 nstacks t gls
-    | Push (_,t) -> 
-	let id = pf_get_new_id patvar_base gls in
-	let nstacks = push_arg (mkVar id) stacks in
-	let kont = execute_cases false fix_name per_info kont0 nstacks t in
-	  tclTHEN
-	    (intro_mustbe_force id)
-	    begin
-	      match fix_name with
-		  Anonymous -> kont
-		| Name fix_id ->  
-		    (fun gls -> 
-		       if at_top then
-			 kont gls
-		       else
-			 match hrec_for id fix_id per_info gls with
-			     None -> kont gls
-			   | Some c_obj ->
-			       let c_id = 
-				 pf_get_new_id (id_of_string "_hrec") gls in
-				 tclTHENLIST 
-				   [generalize [c_obj];
-				    intro_mustbe_force c_id;
-				    kont] gls)
-	    end gls
-    | Split(ids,ind,br) ->
-	let (_,typ,_)= 
-	  try destProd (pf_concl gls) with Invalid_argument _ ->
-  	    anomaly "Sub-object not found." in
-	let hd,args=decompose_app (special_whd gls typ) in
-	  if try ind <> destInd hd with Invalid_argument _ -> true then
-	      (* argument of an inductive family : intro + discard *)
-	      tclTHEN intro
-  		(execute_cases at_top fix_name per_info kont0 stacks tree) gls
-	    else
-	      begin
-		let nparams = (fst (Global.lookup_inductive ind)).mind_nparams in
-		let params = list_firstn nparams args in
-		let constr i =applist (mkConstruct(ind,succ i),params) in
-		let next_tac is_rec i = function
-		    Some (sub_ids,tree) ->
-		      let br_stacks =
-			List.filter (fun (id,_) -> Idset.mem id sub_ids) stacks in
-		      let p_stacks = 
-			push_head (constr i) is_rec ids br_stacks in
-			execute_cases false fix_name per_info kont0 p_stacks tree 
-		  | None -> 
-		      msgnl (str "Warning : missing case");
-		      kont0 (mkMeta 1) 
-		in
-		let id = pf_get_new_id patvar_base gls in
-		let kont is_rec = 			
-		  tclTHENSV
-		    (general_case_analysis (mkVar id,NoBindings))
-		    (Array.mapi (next_tac is_rec) br) in
-		  tclTHEN 
-		    (intro_mustbe_force id)
-		    begin
-		      match fix_name with
-			  Anonymous -> kont false
-			| Name fix_id ->  
-			    (fun gls -> 
-			      if at_top then
-				kont false gls
-			    else
-				match hrec_for id fix_id per_info gls with
-				    None -> kont false gls
-				  | Some c_obj ->
-				      tclTHENLIST 
-					[generalize [c_obj];
-					 kont true] gls)
-		    end gls
-	      end
-    | End_of_branch (id,nhyps) -> 
-	match List.assoc id stacks with
-	    [None,_,args] -> 
-	      let metas = list_tabulate (fun n -> mkMeta (succ n)) nhyps in
-		kont0 (applist (mkVar id,List.rev_append args metas)) gls
-	  | _ -> anomaly "wrong stack size"
-
+  let ind = destInd cind in assert (ind=per_info.per_ind);
+  let params,args= list_chop per_info.per_nparams all_args in 
+  assert begin
+    try List.for_all2 eq_constr params per_info.per_params with 
+        Invalid_argument _ -> false end;
+  let hd2 = applist (mkVar fix_id,args@[obj]) in 
+    compose_lam rc (whd_beta hd2)
+
+let rec execute_cases fix_name per_info tacnext args objs nhrec tree gls =
+  match tree, objs  with
+      Close_patt t,_ ->  
+	let args0 = pop_stacks args in	
+	  execute_cases fix_name per_info tacnext args0 objs nhrec t gls
+    | Skip_patt (_,t),skipped::next_objs -> 
+	let args0 = push_arg skipped args in
+	  execute_cases fix_name per_info tacnext args0 next_objs nhrec t gls
+    | End_patt (id,nhyps),[] -> 
+	begin
+	  match List.assoc id args with
+	      [None,br_args] -> 
+		let metas = 
+		  list_tabulate (fun n -> mkMeta (succ n)) nhyps in
+		  tclTHEN
+		    (tclDO nhrec introf)
+		    (tacnext 
+		       (applist (mkVar id,List.rev_append br_args metas))) gls
+	    | _ -> anomaly "wrong stack size"
+	end
+    | Split_patt (ids,ind,br), casee::next_objs ->
+	let (mind,oind) as spec = Global.lookup_inductive ind in
+	let nparams = mind.mind_nparams in
+	let concl=pf_concl gls in
+	let env=pf_env gls in
+	let ctyp=pf_type_of gls casee in
+	let hd,all_args = decompose_app (special_whd gls ctyp) in
+	let _ = assert (destInd hd = ind) in (* just in case *)
+	let params,real_args = list_chop nparams all_args in
+	let abstract_obj c body = 
+	  let typ=pf_type_of gls c in 
+	    lambda_create env (typ,subst_term c body) in
+	let elim_pred = List.fold_right abstract_obj    
+	  real_args (lambda_create env (ctyp,subst_term casee concl)) in
+	let case_info = Inductiveops.make_case_info env ind RegularStyle in
+	let gen_arities = Inductive.arities_of_constructors ind spec in
+	let f_ids typ = 
+	  let sign = 
+	    fst (Sign.decompose_prod_assum (Term.prod_applist typ params)) in
+	    find_intro_names sign gls in
+	let constr_args_ids = Array.map f_ids gen_arities in
+	let case_term =	 
+	  mkCase(case_info,elim_pred,casee,
+		 Array.mapi (fun i _ -> mkMeta (succ i)) constr_args_ids) in
+	let branch_tac i (recargs,bro) gls0 =
+	  let args_ids = constr_args_ids.(i) in
+	  let rec aux n = function
+	      [] -> 
+		assert (n=Array.length recargs); 
+		next_objs,[],nhrec
+	    | id :: q -> 
+		let objs,recs,nrec = aux (succ n) q in
+		  if recargs.(n) 
+		  then (mkVar id::objs),(id::recs),succ nrec 
+		  else (mkVar id::objs),recs,nrec in
+	  let objs,recs,nhrec = aux 0 args_ids in
+	    tclTHENLIST
+	      [tclMAP intro_mustbe_force args_ids;
+	       begin
+		 fun gls1 -> 
+		   let hrecs = 
+		     List.map 
+		       (fun id -> 
+			  hrec_for (out_name fix_name) per_info gls1 id) 
+		       recs in
+		     generalize hrecs gls1
+	       end;
+	       match bro with
+		   None -> 
+		     msg_warning (str "missing case");
+		     tacnext (mkMeta 1)
+		 | Some (sub_ids,tree) ->
+		     let br_args =
+		       List.filter 
+			 (fun (id,_) -> Idset.mem id sub_ids) args in 
+		     let construct = 
+		       applist (mkConstruct(ind,succ i),params) in
+		     let p_args = 
+		       push_head construct ids br_args in
+		       execute_cases fix_name per_info tacnext 
+			 p_args objs nhrec tree] gls0 in
+	  tclTHENSV 
+	    (refine case_term)
+	    (Array.mapi branch_tac br) gls
+    | Split_patt (_, _, _) , [] -> 
+	anomaly "execute_cases : Nothing to split"
+    | Skip_patt _ , [] -> 
+	anomaly "execute_cases : Nothing to skip"
+    | End_patt (_,_) , _ :: _  -> 
+	anomaly "execute_cases : End of branch with garbage left"
+
+
+
+(* end focus/claim *)
+		
 let end_tac et2 gls =
   let info = get_its_info gls in
   let et1,pi,ek,clauses = 
@@ -1392,7 +1348,7 @@ let end_tac et2 gls =
 	      tclSOLVE [simplest_elim pi.per_casee]	
 	  | ET_Case_analysis,EK_nodep ->
 	      tclTHEN 
-		(general_case_analysis (pi.per_casee,NoBindings))
+		(general_case_analysis false (pi.per_casee,NoBindings))
 		(default_justification (List.map mkVar clauses))
 	  | ET_Induction,EK_nodep ->
 	      tclTHENLIST
@@ -1400,31 +1356,35 @@ let end_tac et2 gls =
 		 simple_induct (AnonHyp (succ (List.length pi.per_args)));
 		 default_justification (List.map mkVar clauses)]
 	  | ET_Case_analysis,EK_dep tree ->
-	      tclTHENLIST 
-		[generalize (pi.per_args@[pi.per_casee]);
-		 execute_cases true Anonymous pi 
+		 execute_cases Anonymous pi 
 		   (fun c -> tclTHENLIST 
 		      [refine c;
 		       clear clauses;
 		       justification assumption])
-		   (initial_instance_stack clauses) tree]	
+		   (initial_instance_stack clauses) [pi.per_casee] 0 tree
 	  | ET_Induction,EK_dep tree ->
-	      tclTHEN (generalize (pi.per_args@[pi.per_casee]))
-		begin
-		  fun gls0 -> 
-		    let fix_id = pf_get_new_id (id_of_string "_fix") gls0 in
-		      tclTHEN 
-			(fix (Some fix_id) (succ (List.length pi.per_args))) 
-			(execute_cases true (Name fix_id) pi 
-			   (fun c ->
-			      tclTHENLIST 
-				[clear [fix_id];
-				 refine c;
-				 clear clauses;
-				 justification assumption
-				 (* justification automation_tac *)])
-			   (initial_instance_stack clauses) tree) gls0
-		end	
+	      let nargs = (List.length pi.per_args) in
+		tclTHEN (generalize (pi.per_args@[pi.per_casee]))
+		  begin
+		    fun gls0 -> 
+		      let fix_id = 
+			pf_get_new_id (id_of_string "_fix") gls0 in
+		      let c_id = 
+			pf_get_new_id (id_of_string "_main_arg") gls0 in
+			tclTHENLIST
+			  [fix (Some fix_id) (succ nargs);
+			   tclDO nargs introf;
+			   intro_mustbe_force c_id;
+			   execute_cases (Name fix_id) pi 
+			     (fun c ->
+				tclTHENLIST 
+				  [clear [fix_id];
+				   refine c;
+				   clear clauses;
+				   justification assumption])
+			     (initial_instance_stack clauses) 
+			     [mkVar c_id]  0 tree] gls0
+		  end	
       end gls
 
 (* escape *)
@@ -1432,25 +1392,13 @@ let end_tac et2 gls =
 let rec abstract_metas n avoid head = function
     [] -> 1,head,[]
   | (meta,typ)::rest -> 
-      let id = Nameops.next_ident_away (id_of_string "_sbgl") avoid in
+      let id = next_ident_away (id_of_string "_sbgl") avoid in
       let p,term,args = abstract_metas (succ n) (id::avoid) head rest in 
 	succ p,mkLambda(Name id,typ,subst_meta [meta,mkRel p] term),
       (mkMeta n)::args 
 
-let build_refining_context gls =
-  let info = get_its_info gls in
-  let avoid=pf_ids_of_hyps gls in
-  let _,fn,args=abstract_metas 1 avoid info.pm_partial_goal info.pm_subgoals in
-    applist (fn,args)
     
-let escape_command pts =
-  let pts1 = nth_unproven 1 pts in
-  let gls = top_goal_of_pftreestate pts1 in
-  let term = build_refining_context gls in
-  let tac = tclTHEN 
-    (abstract_operation (Proof_instr (true,{emph=0;instr=Pescape})) tcl_erase_info)
-    (Tactics.refine term) in
-    traverse 1 (solve_pftreestate tac pts1)
+let escape_tac gls =  tcl_erase_info gls
 
 (* General instruction engine *)
 
@@ -1485,7 +1433,8 @@ let rec do_proof_instr_gen _thus _then instr =
     | Psuppose hyps      -> suppose_tac hyps
     | Pcase (params,pat_info,hyps) -> case_tac params pat_info hyps
     | Pend (B_elim et) -> end_tac et
-    | Pend _ | Pescape -> anomaly "Not applicable"
+    | Pend _ -> anomaly "Not applicable"
+    | Pescape -> escape_tac
  
 let eval_instr {instr=instr} =
   do_proof_instr_gen false false instr   
@@ -1500,7 +1449,7 @@ let rec preprocess pts instr =
       true,pts
   | Pescape -> 
       check_not_per pts;
-      false,pts
+      true,pts
   | Pcase _ | Psuppose _ | Pend (B_elim _) -> 
       true,close_previous_case pts
   | Pend bt -> 
@@ -1511,8 +1460,8 @@ let rec postprocess pts instr =
       Phence i | Pthus i | Pthen i -> postprocess pts i
     | Pcut _ | Psuffices _ | Passume _ | Plet _ | Pconsider (_,_) | Pcast (_,_)
     | Pgiven _ | Ptake _ | Pdefine (_,_,_) | Prew (_,_) -> pts
-    | Pclaim _ | Pfocus _ | Psuppose _ | Pcase _ | Pper _ -> nth_unproven 1 pts
-    | Pescape -> escape_command pts
+    | Pclaim _ | Pfocus _ | Psuppose _ | Pcase _ | Pper _ 
+    | Pescape -> nth_unproven 1 pts
     | Pend (B_elim ET_Induction) ->
   	begin
 	  let pf = proof_of_pftreestate pts in
@@ -1523,7 +1472,7 @@ let rec postprocess pts instr =
 	      goto_current_focus_or_top (mark_as_done pts)
  	    with 
 		Type_errors.TypeError(env,
-				      Type_errors.IllFormedRecBody(_,_,_)) ->
+				      Type_errors.IllFormedRecBody(_,_,_,_,_)) ->
 		  anomaly "\"end induction\" generated an ill-formed fixpoint"
 	end
     | Pend _ -> 
@@ -1544,7 +1493,7 @@ let do_instr raw_instr pts =
       let lock_focus = is_focussing_instr instr.instr in
       let marker= Proof_instr (lock_focus,instr) in
 	solve_nth_pftreestate 1 
-	  (abstract_operation marker (eval_instr instr)) pts1
+	  (abstract_operation marker (tclTHEN (eval_instr instr) clean_tmp)) pts1
     else pts1 in
       postprocess pts2 raw_instr.instr
 
diff --git a/tactics/decl_proof_instr.mli b/tactics/decl_proof_instr.mli
index 642f2755..2e235a01 100644
--- a/tactics/decl_proof_instr.mli
+++ b/tactics/decl_proof_instr.mli
@@ -6,12 +6,13 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id$ *)
+(* $Id: decl_proof_instr.mli 10739 2008-04-01 14:45:20Z herbelin $ *)
 
 open Refiner
 open Names
 open Term
 open Tacmach
+open Decl_mode
 
 val go_to_proof_mode: unit -> unit
 val return_from_tactic_mode: unit -> unit
@@ -22,6 +23,8 @@ val automation_tac : tactic
 
 val daimon_subtree: pftreestate -> pftreestate
 
+val concl_refiner: Termops.metamap -> constr -> Proof_type.goal sigma -> constr
+
 val do_instr: Decl_expr.raw_proof_instr -> pftreestate -> pftreestate
 val proof_instr: Decl_expr.raw_proof_instr -> unit
 
@@ -31,37 +34,29 @@ val mark_proof_tree_as_done : Proof_type.proof_tree -> Proof_type.proof_tree
 
 val mark_as_done : pftreestate -> pftreestate
 
-val execute_cases : bool ->
+val execute_cases :
     Names.name ->
     Decl_mode.per_info ->
     (Term.constr -> Proof_type.tactic) ->
-    (Names.Idset.elt * (Term.constr option * bool * Term.constr list) list) 
-      list ->
-    Decl_mode.split_tree -> Proof_type.tactic
+    (Names.Idset.elt * (Term.constr option * Term.constr list) list) list ->
+    Term.constr list -> int -> Decl_mode.split_tree -> Proof_type.tactic
+
+val tree_of_pats : 
+  identifier * int -> (Rawterm.cases_pattern*recpath) list list ->
+  split_tree
+
+val add_branch : 
+  identifier * int -> (Rawterm.cases_pattern*recpath) list list ->
+  split_tree -> split_tree
 
-val tree_of_pats :
-    Environ.env ->
-    Names.Idset.elt * int ->
-    Rawterm.cases_pattern list list -> Decl_mode.split_tree
-val add_branch :
-    Environ.env ->
-    Names.Idset.elt * int ->
-    Rawterm.cases_pattern list list ->
-    Decl_mode.split_tree -> Decl_mode.split_tree
 val append_branch :
-    Environ.env ->
-    Names.Idset.elt * int ->
-    int ->
-    Rawterm.cases_pattern list list ->
-    int ->
-    (Names.Idset.t * Decl_mode.split_tree) option ->
-    (Names.Idset.t * Decl_mode.split_tree) option
-
-val append_tree :   Environ.env ->
-    Names.Idset.elt * int ->
-    int ->
-    Rawterm.cases_pattern list list ->
-    Decl_mode.split_tree -> Decl_mode.split_tree
+  identifier * int -> int -> (Rawterm.cases_pattern*recpath) list list ->
+  (Names.Idset.t * Decl_mode.split_tree) option ->
+  (Names.Idset.t * Decl_mode.split_tree) option
+
+val append_tree :
+  identifier * int -> int -> (Rawterm.cases_pattern*recpath) list list ->
+  split_tree -> split_tree
 
 val build_dep_clause :   Term.types Decl_expr.statement list ->
     Decl_expr.proof_pattern ->
@@ -80,35 +75,29 @@ val thesis_for :     Term.constr ->
 
 val close_previous_case : pftreestate -> pftreestate
 
-val test_fun : string -> unit
-
-
 val pop_stacks :
   (Names.identifier * 
-     (Term.constr option * bool * Term.constr list) list) list ->
-  bool * 
-    (Names.identifier * 
-       (Term.constr option * bool * Term.constr list) list) list
-
+     (Term.constr option * Term.constr list) list) list -> 
+  (Names.identifier * 
+     (Term.constr option * Term.constr list) list) list
 
 val push_head :   Term.constr ->
-  bool ->
   Names.Idset.t ->
   (Names.identifier * 
-     (Term.constr option * bool * Term.constr list) list) list ->
+     (Term.constr option * Term.constr list) list) list ->
   (Names.identifier * 
-     (Term.constr option * bool * Term.constr list) list) list
+     (Term.constr option * Term.constr list) list) list
 
 val push_arg : Term.constr ->
   (Names.identifier * 
-     (Term.constr option * bool * Term.constr list) list) list ->
+     (Term.constr option * Term.constr list) list) list ->
   (Names.identifier * 
-     (Term.constr option * bool * Term.constr list) list) list
+     (Term.constr option * Term.constr list) list) list
 
 val hrec_for: 
     Names.identifier ->
-    Names.identifier ->
-    Decl_mode.per_info -> Proof_type.goal Tacmach.sigma -> Term.constr option
+    Decl_mode.per_info -> Proof_type.goal Tacmach.sigma -> 
+    Names.identifier -> Term.constr
 
 val consider_match :
    bool ->
@@ -117,10 +106,12 @@ val consider_match :
     (Term.types Decl_expr.statement, Term.types) Decl_expr.hyp list ->
     Proof_type.tactic
 
-val thus_tac : constr -> constr -> (metavariable * types) list ->
-  tactic
-
-val build_applist :    Term.types ->
-    Term.metavariable list ->
-    (Term.metavariable * Term.types) list * Term.types
+val init_tree:
+    Names.Idset.t ->
+    Names.inductive ->
+    int option * Declarations.wf_paths ->
+    (int ->
+     (int option * Declarations.recarg Rtree.t) array ->
+     (Names.Idset.t * Decl_mode.split_tree) option) ->
+    Decl_mode.split_tree
 
diff --git a/tactics/dhyp.ml b/tactics/dhyp.ml
index f82b1f82..5dd7f5fd 100644
--- a/tactics/dhyp.ml
+++ b/tactics/dhyp.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: dhyp.ml 8878 2006-05-30 16:44:25Z herbelin $ *)
+(* $Id: dhyp.ml 11094 2008-06-10 19:35:23Z herbelin $ *)
 
 (* Chet's comments about this tactic :
  
@@ -261,11 +261,13 @@ let add_destructor_hint local na loc pat pri code =
     (inDD (local,na,{ d_pat = pat; d_pri=pri; d_code=code }))
 
 let match_dpat dp cls gls =
+  let onconcl = cls.concl_occs <> no_occurrences_expr in
   match (cls,dp) with
-    | ({onhyps=lo;onconcl=false},HypLocation(_,hypd,concld)) ->
+    | ({onhyps=lo},HypLocation(_,hypd,concld)) when not onconcl ->
         let hl = match lo with
             Some l -> l
-          | None -> List.map (fun id -> (([],id),InHyp)) (pf_ids_of_hyps gls) in
+          | None -> List.map (fun id -> ((all_occurrences_expr,id),InHyp))
+	              (pf_ids_of_hyps gls) in
         if not
           (List.for_all
             (fun ((_,id),hl) ->
@@ -278,7 +280,7 @@ let match_dpat dp cls gls =
               (is_matching concld.d_sort (pf_type_of gls cl)))
             hl)
         then error "No match"
-    | ({onhyps=Some[];onconcl=true},ConclLocation concld) ->
+    | ({onhyps=Some[]},ConclLocation concld) when onconcl ->
         let cl = pf_concl gls in
         if not
           ((is_matching concld.d_typ cl) &
@@ -300,7 +302,7 @@ let applyDestructor cls discard dd gls =
         | Some ((_,id),_), (Some x, tac) -> 
 	    let arg =
               ConstrMayEval(ConstrTerm (RRef(dummy_loc,VarRef id),None)) in
-            TacLetIn ([(dummy_loc, x), None, arg], tac)
+            TacLetIn (false, [(dummy_loc, x), arg], tac)
         | None, (None, tac) -> tac
         | _, (Some _,_) -> error "Destructor expects an hypothesis"
         | _, (None,_) -> error "Destructor is for conclusion")
diff --git a/tactics/eauto.ml4 b/tactics/eauto.ml4
index 6da0dd49..2effe103 100644
--- a/tactics/eauto.ml4
+++ b/tactics/eauto.ml4
@@ -8,7 +8,7 @@
 
 (*i camlp4deps: "parsing/grammar.cma" i*)
 
-(* $Id: eauto.ml4 9277 2006-10-25 13:02:22Z herbelin $ *)
+(* $Id: eauto.ml4 11094 2008-06-10 19:35:23Z herbelin $ *)
 
 open Pp
 open Util
@@ -29,6 +29,7 @@ open Pattern
 open Clenv
 open Auto
 open Rawterm
+open Hiddentac
 
 let e_give_exact c gl = let t1 = (pf_type_of gl c) and t2 = pf_concl gl in 
   if occur_existential t1 or occur_existential t2 then 
@@ -44,13 +45,6 @@ TACTIC EXTEND eassumption
 | [ "eassumption" ] -> [ e_assumption ]
 END
 
-let e_resolve_with_bindings_tac  (c,lbind) gl = 
-  let t = pf_hnf_constr gl (pf_type_of gl c) in 
-  let clause = make_clenv_binding_apply gl None (c,t) lbind in 
-  Clenvtac.e_res_pf clause gl
-
-let e_resolve_constr c gls = e_resolve_with_bindings_tac (c,NoBindings) gls
-			     
 TACTIC EXTEND eexact
 | [ "eexact" constr(c) ] -> [ e_give_exact c ]
 END
@@ -61,84 +55,14 @@ let registered_e_assumption gl =
   tclFIRST (List.map (fun id gl -> e_give_exact_constr (mkVar id) gl) 
               (pf_ids_of_hyps gl)) gl
 
-(* This automatically define h_eApply (among other things) *)
-TACTIC EXTEND eapply
-  [ "eapply" constr_with_bindings(c) ] -> [ e_resolve_with_bindings_tac c ]
-END
-
-let vernac_e_resolve_constr c = h_eapply (c,NoBindings)
-
-let e_constructor_tac boundopt 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
-  if i=0 then error "The constructors are numbered starting from 1";
-  if i > nconstr then error "Not enough constructors";
-  begin match boundopt with 
-    | Some expctdnum -> 
-        if expctdnum <> nconstr then 
-	  error "Not the expected number of constructors"
-    | None -> ()
-  end;
-  let cons = mkConstruct (ith_constructor_of_inductive mind i) in
-  let apply_tac = e_resolve_with_bindings_tac (cons,lbind) in
-  (tclTHENLIST [convert_concl_no_check redcl DEFAULTcast
-; intros; apply_tac]) gl
-
-let e_one_constructor i = e_constructor_tac None i
-
-let e_any_constructor 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 (e_one_constructor i NoBindings) t) 
-              (interval 1 nconstr)) gl
-
-let e_left = e_constructor_tac (Some 2) 1
-
-let e_right = e_constructor_tac (Some 2) 2
-
-let e_split = e_constructor_tac (Some 1) 1
-
-(* This automatically define h_econstructor (among other things) *)
-TACTIC EXTEND econstructor
-  [ "econstructor" integer(n) "with" bindings(c) ] -> [ e_constructor_tac None n c ]
-| [ "econstructor" integer(n) ] -> [ e_constructor_tac None n NoBindings ]
-| [ "econstructor" tactic_opt(t) ] -> [ e_any_constructor (option_map Tacinterp.eval_tactic t) ] 
-      END
-
-TACTIC EXTEND eleft
-  [ "eleft" "with" bindings(l) ] -> [e_left l]
-| [ "eleft"] -> [e_left NoBindings]
-END
-
-TACTIC EXTEND eright
-  [ "eright" "with" bindings(l) ] -> [e_right l]
-| [ "eright" ] -> [e_right NoBindings]
-END
-
-TACTIC EXTEND esplit
-  [ "esplit" "with" bindings(l) ] -> [e_split l]
-| [ "esplit"] -> [e_split NoBindings]
-END
-
-
-TACTIC EXTEND eexists
-  [ "eexists" bindings(l) ] -> [e_split l]
-END
-
-
 (************************************************************************)
 (*   PROLOG tactic                                                      *)
 (************************************************************************)
 
 let one_step l gl =
   [Tactics.intro]
-  @ (List.map e_resolve_constr (List.map mkVar (pf_ids_of_hyps gl)))
-  @ (List.map e_resolve_constr l)
+  @ (List.map h_simplest_eapply (List.map mkVar (pf_ids_of_hyps gl)))
+  @ (List.map h_simplest_eapply l)
   @ (List.map assumption (pf_ids_of_hyps gl))
 
 let rec prolog l n gl =
@@ -161,51 +85,103 @@ TACTIC EXTEND prolog
 END
 
 open Auto
+open Unification
 
 (***************************************************************************)
 (* A tactic similar to Auto, but using EApply, Assumption and e_give_exact *)
 (***************************************************************************)
 
-let unify_e_resolve  (c,clenv) gls = 
+(* no delta yet *)
+
+let unify_e_resolve flags (c,clenv) gls = 
+  let clenv' = connect_clenv gls clenv in
+  let _ = clenv_unique_resolver false ~flags clenv' gls in
+  h_simplest_eapply c gls
+
+let unify_e_resolve_nodelta (c,clenv) gls = 
   let clenv' = connect_clenv gls clenv in
   let _ = clenv_unique_resolver false clenv' gls in
-  vernac_e_resolve_constr c gls
+  h_simplest_eapply c gls
 
-let rec e_trivial_fail_db db_list local_db goal =
+let rec e_trivial_fail_db mod_delta db_list local_db goal =
   let tacl = 
     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 fst (e_trivial_resolve db_list local_db (pf_concl goal)) )
+          (e_trivial_fail_db mod_delta db_list
+	     (add_hint_list hintl local_db) g'))) ::
+    (List.map fst (e_trivial_resolve mod_delta db_list local_db (pf_concl goal)) )
   in 
   tclFIRST (List.map tclCOMPLETE tacl) goal 
 
-and e_my_find_search db_list local_db hdc concl = 
+and e_my_find_search mod_delta =
+  if mod_delta then e_my_find_search_delta
+  else e_my_find_search_nodelta
+
+and e_my_find_search_nodelta db_list local_db hdc concl = 
   let hdc = head_of_constr_reference hdc in
   let hintl =
     if occur_existential concl then 
-      list_map_append (Hint_db.map_all hdc) (local_db::db_list)
+      list_map_append (fun (st, db) -> Hint_db.map_all hdc db) (local_db::db_list)
     else 
-      list_map_append (Hint_db.map_auto (hdc,concl)) (local_db::db_list)
+      list_map_append (fun (st, db) -> 
+	Hint_db.map_auto (hdc,concl) db) (local_db::db_list)
   in 
   let tac_of_hint = 
     fun {pri=b; pat = p; code=t} -> 
       (b, 
        let tac =
 	 match t with
-	   | Res_pf (term,cl) -> unify_resolve (term,cl)
-	   | ERes_pf (term,cl) -> unify_e_resolve (term,cl)
+	   | Res_pf (term,cl) -> unify_resolve_nodelta (term,cl)
+	   | ERes_pf (term,cl) -> unify_e_resolve_nodelta (term,cl)
 	   | Give_exact (c) -> e_give_exact_constr c
 	   | Res_pf_THEN_trivial_fail (term,cl) ->
-               tclTHEN (unify_e_resolve (term,cl)) 
-		 (e_trivial_fail_db db_list local_db)
-	   | Unfold_nth c -> unfold_in_concl [[],c]
+               tclTHEN (unify_e_resolve_nodelta (term,cl)) 
+		 (e_trivial_fail_db false db_list local_db)
+	   | Unfold_nth c -> unfold_in_concl [all_occurrences,c]
 	   | Extern tacast -> conclPattern concl 
-	       (out_some p) tacast
+	       (Option.get p) tacast
+       in 
+       (tac,fmt_autotactic t))
+       (*i
+	 fun gls -> pPNL (fmt_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
+
+and e_my_find_search_delta 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 (st, db) -> 
+	let flags = {auto_unif_flags with modulo_delta = st} in
+	  List.map (fun x -> flags, x) (Hint_db.map_all hdc db)) (local_db::db_list)
+    else 
+      list_map_append (fun (st, db) -> 
+	let flags = {auto_unif_flags with modulo_delta = st} 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}) -> 
+      (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_constr c
+	   | Res_pf_THEN_trivial_fail (term,cl) ->
+               tclTHEN (unify_e_resolve st (term,cl)) 
+		 (e_trivial_fail_db true db_list local_db)
+	   | Unfold_nth c -> unfold_in_concl [all_occurrences,c]
+	   | Extern tacast -> conclPattern concl 
+	       (Option.get p) tacast
        in 
        (tac,fmt_autotactic t))
        (*i
@@ -219,16 +195,17 @@ and e_my_find_search db_list local_db hdc concl =
   in 
   List.map tac_of_hint hintl
     
-and e_trivial_resolve db_list local_db gl = 
+and e_trivial_resolve mod_delta db_list local_db gl = 
   try 
     Auto.priority 
-      (e_my_find_search db_list local_db 
+      (e_my_find_search mod_delta db_list local_db 
 	 (List.hd (head_constr_bound gl [])) gl)
   with Bound | Not_found -> []
 
-let e_possible_resolve db_list local_db gl =
-  try List.map snd (e_my_find_search db_list local_db 
-		      (List.hd (head_constr_bound gl [])) gl)
+let e_possible_resolve mod_delta db_list local_db gl =
+  try List.map snd 
+    (e_my_find_search mod_delta db_list local_db 
+	(List.hd (head_constr_bound gl [])) gl)
   with Bound | Not_found -> []
 
 let assumption_tac_list id = apply_tac_list (e_give_exact_constr (mkVar id))
@@ -238,31 +215,42 @@ let find_first_goal gls =
 
 (*s The following module [SearchProblem] is used to instantiate the generic
     exploration functor [Explore.Make]. *)
-      
+
+type search_state = { 
+  depth : int; (*r depth of search before failing *)
+  tacres : goal list sigma * validation;
+  last_tactic : std_ppcmds;
+  dblist : Auto.hint_db list;
+  localdb :  Auto.hint_db list }
+    
 module SearchProblem = struct
+    
+  type state = search_state
 
-  type state = { 
-    depth : int; (*r depth of search before failing *)
-    tacres : goal list sigma * validation;
-    last_tactic : std_ppcmds;
-    dblist : Auto.Hint_db.t list;
-    localdb :  Auto.Hint_db.t list }
-		 
   let success s = (sig_it (fst s.tacres)) = []
 
-  let rec filter_tactics (glls,v) = function
-    | [] -> []
-    | (tac,pptac) :: tacl -> 
-	try 
-	  let (lgls,ptl) = apply_tac_list tac glls in 
-	  let v' p = v (ptl p) in
-	  ((lgls,v'),pptac) :: filter_tactics (glls,v) tacl
-	with e when Logic.catchable_exception e ->
-	  filter_tactics (glls,v) tacl
-
-  let rec list_addn n x l = 
-    if n = 0 then l else x :: (list_addn (pred n) x l)
-
+  let pr_ev evs ev = Printer.pr_constr_env (Evd.evar_env ev) (Evarutil.nf_evar evs ev.Evd.evar_concl)
+    
+  let pr_goals gls =
+    let evars = Evarutil.nf_evars (Refiner.project gls) in
+      prlist (pr_ev evars) (sig_it gls)
+	
+  let filter_tactics (glls,v) l =
+(*     let _ = Proof_trees.db_pr_goal (List.hd (sig_it glls)) in *)
+(*     let evars = Evarutil.nf_evars (Refiner.project glls) in *)
+(*     msg (str"Goal:" ++ pr_ev evars (List.hd (sig_it glls)) ++ str"\n"); *)
+    let rec aux = function
+      | [] -> []
+      | (tac,pptac) :: tacl -> 
+	  try 
+	    let (lgls,ptl) = apply_tac_list tac glls in 
+	    let v' p = v (ptl p) in
+(* 	    let gl = Proof_trees.db_pr_goal (List.hd (sig_it glls)) in *)
+(* 	      msg (hov 1 (pptac ++ str" gives: \n" ++ pr_goals lgls ++ str"\n")); *)
+	      ((lgls,v'),pptac) :: aux tacl
+	  with e -> Refiner.catch_failerror e; aux tacl
+    in aux l
+      
   (* Ordering of states is lexicographic on depth (greatest first) then
      number of remaining goals. *)
   let compare s s' =
@@ -297,7 +285,8 @@ module SearchProblem = struct
 	     let hintl = 
 	       make_resolve_hyp (pf_env g') (project g') (pf_last_hyp g')
 	     in
-             let ldb = Hint_db.add_list hintl (List.hd s.localdb) in
+	       
+             let ldb = add_hint_list hintl (List.hd s.localdb) in
 	     { depth = s.depth; tacres = res; 
 	       last_tactic = pp; dblist = s.dblist;
 	       localdb = ldb :: List.tl s.localdb })
@@ -305,8 +294,7 @@ module SearchProblem = struct
       in
       let rec_tacs = 
 	let l = 
-	  filter_tactics s.tacres
-	    (e_possible_resolve s.dblist (List.hd s.localdb) (pf_concl g))
+	  filter_tactics s.tacres (e_possible_resolve false s.dblist (List.hd s.localdb) (pf_concl g))
 	in
 	List.map 
 	  (fun ((lgls,_) as res, pp) -> 
@@ -332,17 +320,19 @@ end
 module Search = Explore.Make(SearchProblem)
 
 let make_initial_state n gl dblist localdb =
-  { SearchProblem.depth = n;
-    SearchProblem.tacres = tclIDTAC gl;
-    SearchProblem.last_tactic = (mt ());
-    SearchProblem.dblist = dblist;
-    SearchProblem.localdb = [localdb] }
+  { depth = n;
+    tacres = tclIDTAC gl;
+    last_tactic = (mt ());
+    dblist = dblist;
+    localdb = [localdb] }
+
+let debug_depth_first = Search.debug_depth_first
 
 let e_depth_search debug p db_list local_db gl =
   try
     let tac = if debug then Search.debug_depth_first else Search.depth_first in
     let s = tac (make_initial_state p gl db_list local_db) in
-    s.SearchProblem.tacres
+    s.tacres
   with Not_found -> error "EAuto: depth first search failed"
 
 let e_breadth_search debug n db_list local_db gl =
@@ -351,17 +341,22 @@ let e_breadth_search debug n db_list local_db gl =
       if debug then Search.debug_breadth_first else Search.breadth_first 
     in
     let s = tac (make_initial_state n gl db_list local_db) in
-    s.SearchProblem.tacres
+    s.tacres
   with Not_found -> error "EAuto: breadth first search failed"
 
 let e_search_auto debug (in_depth,p) lems db_list gl = 
-  let local_db = make_local_hint_db lems gl in 
+  let local_db = make_local_hint_db true lems gl in 
   if in_depth then 
     e_depth_search debug p db_list local_db gl
   else 
     e_breadth_search debug p db_list local_db gl
 
-let eauto debug np lems dbnames =
+open Evd
+
+let eauto_with_bases debug np lems db_list = 
+  tclTRY (e_search_auto debug np lems db_list)
+
+let eauto debug np lems dbnames = 
   let db_list =
     List.map
       (fun x -> 
@@ -370,7 +365,7 @@ let eauto debug np lems dbnames =
       ("core"::dbnames) 
   in
   tclTRY (e_search_auto debug np lems db_list)
-
+  
 let full_eauto debug n lems gl = 
   let dbnames = current_db_names () in
   let dbnames =  list_subtract dbnames ["v62"] in
@@ -428,3 +423,41 @@ TACTIC EXTEND eauto
     hintbases(db) ] ->
     [ gen_eauto false (make_dimension n p) lems db ]
 END
+
+TACTIC EXTEND new_eauto
+| [ "new" "auto" int_or_var_opt(n) auto_using(lems) 
+    hintbases(db) ] ->
+    [ match db with
+      | None -> new_full_auto (make_depth n) lems
+      | Some l ->
+	  new_auto (make_depth n) lems l ]
+END
+      
+TACTIC EXTEND debug_eauto
+| [ "debug" "eauto" int_or_var_opt(n) int_or_var_opt(p) auto_using(lems) 
+    hintbases(db) ] ->
+    [ gen_eauto true (make_dimension n p) lems db ]
+END
+
+TACTIC EXTEND dfs_eauto
+| [ "dfs" "eauto" int_or_var_opt(p) auto_using(lems) 
+      hintbases(db) ] ->
+    [ gen_eauto false (true, make_depth p) lems db ]
+END
+
+let autosimpl db cl =
+  let unfold_of_elts constr (b, elts) =
+    if not b then 
+      List.map (fun c -> all_occurrences, constr c) elts
+    else []
+  in
+  let unfolds = List.concat (List.map (fun dbname -> 
+    let ((ids, csts), _) = searchtable_map dbname in
+      unfold_of_elts (fun x -> EvalConstRef x) (Cpred.elements csts) @
+      unfold_of_elts (fun x -> EvalVarRef x) (Idpred.elements ids)) db)
+  in unfold_option unfolds cl
+
+TACTIC EXTEND autosimpl
+| [ "autosimpl" hintbases(db) ] ->
+    [ autosimpl (match db with None -> ["core"] | Some x -> "core"::x) None ]
+END
diff --git a/tactics/eauto.mli b/tactics/eauto.mli
index 4621088e..1c6f9920 100644
--- a/tactics/eauto.mli
+++ b/tactics/eauto.mli
@@ -12,6 +12,9 @@ open Proof_type
 open Tacexpr
 open Auto
 open Topconstr
+open Evd
+open Environ
+open Explore
 (*i*)
 
 val rawwit_hintbases : hint_db_name list option raw_abstract_argument_type
@@ -22,12 +25,13 @@ val e_assumption : tactic
 
 val registered_e_assumption : tactic
 
-val e_resolve_constr :  constr -> tactic
-
-val vernac_e_resolve_constr :  constr -> tactic
-
 val e_give_exact_constr : constr -> tactic
 
 val gen_eauto : bool -> bool * int -> constr list -> 
   hint_db_name list option -> tactic
 
+
+val eauto_with_bases :
+  bool ->
+  bool * int ->
+  Term.constr list -> Auto.hint_db list -> Proof_type.tactic
diff --git a/tactics/elim.ml b/tactics/elim.ml
index 2e079567..889ead5e 100644
--- a/tactics/elim.ml
+++ b/tactics/elim.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: elim.ml 7538 2005-11-08 17:14:52Z herbelin $ *)
+(* $Id: elim.ml 9842 2007-05-20 17:44:23Z herbelin $ *)
 
 open Pp
 open Util
@@ -136,14 +136,16 @@ let decompose_or c gls =
     (fun (_,t) -> is_disjunction t)
     c gls
 
+let inj_open c = (Evd.empty,c)
+
 let h_decompose l c =
-  Refiner.abstract_tactic (TacDecompose (l,c)) (decompose_these c l)
+  Refiner.abstract_tactic (TacDecompose (l,inj_open c)) (decompose_these c l)
 
 let h_decompose_or c =
-  Refiner.abstract_tactic (TacDecomposeOr c) (decompose_or c)
+  Refiner.abstract_tactic (TacDecomposeOr (inj_open c)) (decompose_or c)
 
 let h_decompose_and c =
-  Refiner.abstract_tactic (TacDecomposeAnd c) (decompose_and c)
+  Refiner.abstract_tactic (TacDecomposeAnd (inj_open c)) (decompose_and c)
 
 (* The tactic Double performs a double induction *)
 
diff --git a/tactics/eqdecide.ml4 b/tactics/eqdecide.ml4
index 0a33164e..8e0b2ca3 100644
--- a/tactics/eqdecide.ml4
+++ b/tactics/eqdecide.ml4
@@ -14,7 +14,7 @@
 
 (*i camlp4deps: "parsing/grammar.cma" i*)
 
-(* $Id: eqdecide.ml4 8780 2006-05-02 21:58:58Z letouzey $ *)
+(* $Id: eqdecide.ml4 11166 2008-06-22 13:23:35Z herbelin $ *)
 
 open Util
 open Names
@@ -75,7 +75,7 @@ let mkBranches c1 c2 =
 let solveNoteqBranch side = 
   tclTHEN (choose_noteq side)
     (tclTHEN (intro_force true)
-      (onLastHyp (fun id -> Extratactics.h_discrHyp (Rawterm.NamedHyp id))))
+      (onLastHyp (fun id -> Extratactics.h_discrHyp id)))
 
 let h_solveNoteqBranch side =
   Refiner.abstract_extended_tactic "solveNoteqBranch" [] 
@@ -115,7 +115,7 @@ let diseqCase eqonleft =
   (tclTHEN  red_in_concl
   (tclTHEN  (intro_using absurd)
   (tclTHEN  (h_simplest_apply (mkVar diseq))
-  (tclTHEN  (Extratactics.h_injHyp (Rawterm.NamedHyp absurd))
+  (tclTHEN  (Extratactics.h_injHyp absurd)
             (full_trivial [])))))))
 
 let solveArg eqonleft op a1 a2 tac g = 
diff --git a/tactics/equality.ml b/tactics/equality.ml
index 24a7e34e..a475b392 100644
--- a/tactics/equality.ml
+++ b/tactics/equality.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: equality.ml 9835 2007-05-17 22:23:03Z jforest $ *)
+(* $Id: equality.ml 11166 2008-06-22 13:23:35Z herbelin $ *)
 
 open Pp
 open Util
@@ -40,6 +40,9 @@ open Vernacexpr
 open Setoid_replace
 open Declarations
 open Indrec
+open Printer
+open Clenv
+open Clenvtac
 
 (* Rewriting tactics *)
 
@@ -51,20 +54,22 @@ open Indrec
    -- Eduardo (19/8/97)
 *)
 
-let general_s_rewrite_clause = function
-  | None -> general_s_rewrite
-  | Some id -> general_s_rewrite_in id
-
 (* Ad hoc asymmetric general_elim_clause *)
-let general_elim_clause cls c elim = 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 (general_elim c elim ~allow_K:false)
-  | Some id ->
-      general_elim_in id c elim 
-
+let general_elim_clause with_evars cls c 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 (general_elim with_evars c elim ~allow_K:false)
+      | Some id ->
+	  general_elim_in with_evars id c elim)
+  with Pretype_errors.PretypeError (env,
+				   (Pretype_errors.NoOccurrenceFound (c', _))) ->
+    raise (Pretype_errors.PretypeError
+	      (env, (Pretype_errors.NoOccurrenceFound (c', cls))))
+      
 let elimination_sort_of_clause = function
   | None -> elimination_sort_of_goal
   | Some id -> elimination_sort_of_hyp id
@@ -81,14 +86,21 @@ let elimination_sort_of_clause = function
    else back to the old approach
 *)
 
-let general_rewrite_bindings_clause cls lft2rgt (c,l) gl =
+let general_s_rewrite_clause = function
+  | None -> general_s_rewrite
+  | Some id -> general_s_rewrite_in id
+
+let general_setoid_rewrite_clause = ref general_s_rewrite_clause
+let register_general_setoid_rewrite_clause = (:=) general_setoid_rewrite_clause
+
+let general_rewrite_ebindings_clause cls lft2rgt occs (c,l) with_evars gl =
   let ctype = pf_apply get_type_of gl c in 
   (* A delta-reduction would be here too strong, since it would 
      break search for a defined setoid relation in head position. *)
   let t = snd (decompose_prod (whd_betaiotazeta ctype)) in 
   let head = if isApp t then fst (destApp t) else t in 
     if relation_table_mem head && l = NoBindings then 
-      general_s_rewrite_clause cls lft2rgt c [] gl
+      !general_setoid_rewrite_clause cls lft2rgt occs c ~new_goals:[] gl
     else 
       (* Original code. In particular, [splay_prod] performs delta-reduction. *)
       let env = pf_env gl in
@@ -97,80 +109,128 @@ let general_rewrite_bindings_clause cls lft2rgt (c,l) gl =
 	match match_with_equation t with
 	  | None -> 
 	      if l = NoBindings
-	      then general_s_rewrite_clause cls lft2rgt c [] gl
+	      then !general_setoid_rewrite_clause cls lft2rgt occs c ~new_goals:[] gl
 	      else error "The term provided does not end with an equation" 
 	  | Some (hdcncl,_) -> 
-              let hdcncls = string_of_inductive hdcncl in 
-	      let suffix = elimination_suffix (elimination_sort_of_clause cls gl) in
-              let dir = if cls=None then lft2rgt else not lft2rgt in
-              let rwr_thm = if dir then hdcncls^suffix^"_r" else hdcncls^suffix in
-              let elim =
-		try pf_global gl (id_of_string rwr_thm)
-		with Not_found ->
-		  error ("Cannot find rewrite principle "^rwr_thm)
-              in 
-		general_elim_clause cls (c,l) (elim,NoBindings) gl
-
-let general_rewrite_bindings = general_rewrite_bindings_clause None
-let general_rewrite l2r c = general_rewrite_bindings l2r (c,NoBindings)
-
-let general_rewrite_bindings_in l2r id =
-  general_rewrite_bindings_clause (Some id) l2r
-let general_rewrite_in l2r id c = 
-  general_rewrite_bindings_clause (Some id) l2r (c,NoBindings)
-
-let general_multi_rewrite l2r c cl = 
-  if cl.concl_occs <> [] then 
-    error "The \"at\" syntax isn't available yet for the rewrite/replace tactic"
-  else match cl.onhyps with 
+	      if occs <> all_occurrences then (
+		!general_setoid_rewrite_clause cls lft2rgt occs c ~new_goals:[] gl)
+	      else
+		let hdcncls = string_of_inductive hdcncl in 
+		let suffix = elimination_suffix (elimination_sort_of_clause cls gl) in
+		let dir = if cls=None then lft2rgt else not lft2rgt in
+		let rwr_thm = if dir then hdcncls^suffix^"_r" else hdcncls^suffix in
+		let elim =
+		  try pf_global gl (id_of_string rwr_thm)
+		  with Not_found ->
+		    error ("Cannot find rewrite principle "^rwr_thm)
+		in 
+		  try general_elim_clause with_evars cls (c,l) (elim,NoBindings) gl
+		  with e -> 
+		    let eq = build_coq_eq () in
+		      if not (eq_constr eq head) then
+			try !general_setoid_rewrite_clause cls lft2rgt occs c ~new_goals:[] gl
+			with _ -> raise e
+		      else raise e
+			
+let general_rewrite_ebindings = 
+  general_rewrite_ebindings_clause None
+let general_rewrite_bindings l2r occs (c,bl) = 
+  general_rewrite_ebindings_clause None l2r occs (c,inj_ebindings bl)
+
+let general_rewrite l2r occs c =
+  general_rewrite_bindings l2r occs (c,NoBindings) false
+
+let general_rewrite_ebindings_in l2r occs id =
+  general_rewrite_ebindings_clause (Some id) l2r occs
+let general_rewrite_bindings_in l2r occs id (c,bl) =
+  general_rewrite_ebindings_clause (Some id) l2r occs (c,inj_ebindings bl)
+let general_rewrite_in l2r occs id c = 
+  general_rewrite_ebindings_clause (Some id) l2r occs (c,NoBindings)
+
+let general_multi_rewrite l2r with_evars c cl = 
+  let occs_of = on_snd (List.fold_left 
+    (fun acc ->
+      function ArgArg x -> x :: acc | ArgVar _ -> acc)
+    [])
+  in
+  match cl.onhyps with 
     | Some l -> 
 	(* If a precise list of locations is given, success is mandatory for
 	   each of these locations. *)
 	let rec do_hyps = function 
 	  | [] -> tclIDTAC
-	  | ((_,id),_) :: l -> 
-	      tclTHENFIRST (general_rewrite_bindings_in l2r id c) (do_hyps l)
+	  | ((occs,id),_) :: l -> 
+	    tclTHENFIRST
+	      (general_rewrite_ebindings_in l2r (occs_of occs) id c with_evars)
+	      (do_hyps l)
 	in 
-	if not cl.onconcl then do_hyps l 
-	else tclTHENFIRST (general_rewrite_bindings l2r c) (do_hyps l)
+	if cl.concl_occs = no_occurrences_expr then do_hyps l else
+	  tclTHENFIRST
+	   (general_rewrite_ebindings l2r (occs_of cl.concl_occs) 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.")
 	  | id :: l -> 
-	      tclIFTHENTRYELSEMUST 
-		(general_rewrite_bindings_in l2r id c) 
-		(do_hyps_atleastonce l)
+	    tclIFTHENTRYELSEMUST 
+	     (general_rewrite_ebindings_in l2r all_occurrences id c with_evars)
+	     (do_hyps_atleastonce l)
 	in 
 	let do_hyps gl = 
-	  (* If the term to rewrite is an hypothesis, don't rewrite in itself *)
-	  let ids = match kind_of_term (fst c) with 
-	    | Var id -> list_remove id (pf_ids_of_hyps gl)
-	    | _ -> pf_ids_of_hyps gl
+	  (* If the term to rewrite uses an hypothesis H, don't rewrite in H *)
+	  let ids = 
+	    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
 	in 
-	if not cl.onconcl then do_hyps 
-	else tclIFTHENTRYELSEMUST (general_rewrite_bindings l2r c) do_hyps
+	if cl.concl_occs = no_occurrences_expr then do_hyps else
+	  tclIFTHENTRYELSEMUST 
+	   (general_rewrite_ebindings l2r (occs_of cl.concl_occs) c with_evars)
+	   do_hyps
+
+let general_multi_multi_rewrite with_evars l cl tac = 
+  let do1 l2r c = 
+    match tac with
+	None -> general_multi_rewrite l2r with_evars c cl
+      | Some tac -> tclTHENSFIRSTn (general_multi_rewrite l2r with_evars c cl)
+	  [|tclIDTAC|] (tclCOMPLETE tac)
+  in
+  let rec doN l2r c = function 
+    | Precisely n when n <= 0 -> tclIDTAC
+    | 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 -> 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)
+  in loop l
 
 (* Conditional rewriting, the success of a rewriting is related 
    to the resolution of the conditions by a given tactic *)
 
 let conditional_rewrite lft2rgt tac (c,bl) = 
-  tclTHENSFIRSTn (general_rewrite_bindings lft2rgt (c,bl))
+  tclTHENSFIRSTn
+    (general_rewrite_ebindings lft2rgt all_occurrences (c,bl) false)
     [|tclIDTAC|] (tclCOMPLETE tac)
 
-let rewriteLR_bindings = general_rewrite_bindings true
-let rewriteRL_bindings = general_rewrite_bindings false
+let rewriteLR_bindings = general_rewrite_bindings true all_occurrences
+let rewriteRL_bindings = general_rewrite_bindings false all_occurrences
 
-let rewriteLR = general_rewrite true
-let rewriteRL = general_rewrite false
+let rewriteLR = general_rewrite true all_occurrences
+let rewriteRL = general_rewrite false all_occurrences
 
-let rewriteLRin_bindings = general_rewrite_bindings_in true
-let rewriteRLin_bindings = general_rewrite_bindings_in false
+let rewriteLRin_bindings = general_rewrite_bindings_in true all_occurrences
+let rewriteRLin_bindings = general_rewrite_bindings_in false all_occurrences
 
 let conditional_rewrite_in lft2rgt id tac (c,bl) = 
-  tclTHENSFIRSTn (general_rewrite_bindings_in lft2rgt id (c,bl))
+  tclTHENSFIRSTn
+    (general_rewrite_ebindings_in lft2rgt all_occurrences id (c,bl) false)
     [|tclIDTAC|] (tclCOMPLETE tac)
 
 let rewriteRL_clause = function
@@ -189,7 +249,7 @@ let multi_replace clause c2 c1 unsafe try_prove_eq_opt gl =
   let try_prove_eq = 
     match try_prove_eq_opt with 
       | None -> tclIDTAC
-      | Some tac ->  tclTRY (tclCOMPLETE tac)
+      | Some tac ->  tclCOMPLETE tac
   in
   let t1 = pf_apply get_type_of gl c1 
   and t2 = pf_apply get_type_of gl c2 in
@@ -200,7 +260,7 @@ let multi_replace clause c2 c1 unsafe try_prove_eq_opt gl =
     tclTHENS (assert_tac false Anonymous eq)
       [onLastHyp (fun id -> 
 	tclTHEN 
-	  (tclTRY (general_multi_rewrite false (mkVar id,NoBindings) clause))
+	  (tclTRY (general_multi_rewrite false false (mkVar id,NoBindings) clause))
 	  (clear [id]));
        tclFIRST
 	 [assumption;
@@ -319,7 +379,6 @@ let injectable env sigma t1 t2 =
     | Inr _ -> true
 
 
-
 (* Once we have found a position, we need to project down to it.  If
    we are discriminating, then we need to produce False on one of the
    branches of the discriminator, and True on the other one.  So the
@@ -404,7 +463,7 @@ let descend_then sigma env head dirn =
       let brl =
         List.map build_branch
           (interval 1 (Array.length mip.mind_consnames)) in
-      let ci = make_default_case_info env RegularStyle ind in
+      let ci = make_case_info env ind RegularStyle in
       mkCase (ci, p, head, Array.of_list brl)))
   
 (* Now we need to construct the discriminator, given a discriminable
@@ -447,7 +506,7 @@ let construct_discriminator sigma env dirn c sort =
     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
-  let ci = make_default_case_info env RegularStyle ind 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
@@ -494,66 +553,83 @@ exception NotDiscriminable
 
 let eq_baseid = id_of_string "e"
 
-let discr_positions env sigma (lbeq,(t,t1,t2)) id cpath dirn sort =
+let apply_on_clause (f,t) clause =
+  let sigma = Evd.evars_of clause.evd in
+  let f_clause = mk_clenv_from_env clause.env sigma None (f,t) in
+  let argmv = 
+    (match kind_of_term (last_arg f_clause.templval.Evd.rebus) with
+     | Meta mv -> mv
+     | _  -> errorlabstrm "" (str "Ill-formed clause applicator")) in
+  clenv_fchain argmv f_clause clause
+
+let discr_positions env sigma (lbeq,(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 eqn = mkApp(lbeq.eq,[|t;t1;t2|]) 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
-  tclCOMPLETE 
-    ((tclTHENS (cut_intro absurd_term)
-      [onLastHyp gen_absurdity; 
-       refine (mkApp (pf,[|mkVar id|]))]))
-
-let discrEq (lbeq,(t,t1,t2) as u) id gls =
-  let sigma = project gls 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)
+    [onLastHyp gen_absurdity; refine pf]
+
+let discrEq (lbeq,(t,t1,t2) as u) eq_clause gls =
+  let sigma = Evd.evars_of eq_clause.evd in
   let env = pf_env gls in
   match find_positions env sigma t1 t2 with
     | Inr _ ->
-	errorlabstrm "discr" (str" Not a discriminable equality")
+	errorlabstrm "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 id cpath dirn sort gls
-
-let onEquality tac id gls =
-  let eqn = pf_whd_betadeltaiota gls (pf_get_hyp_typ gls id) 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 eqn = clenv_type eq_clause' in
   let eq =
     try find_eq_data_decompose eqn
     with PatternMatchingFailure ->
-      errorlabstrm "" (pr_id id ++ str": not a primitive equality") 
-  in tac eq id gls
+      errorlabstrm "" (str"No primitive equality found") in
+  tclTHEN
+    (Refiner.tclEVARS (Evd.evars_of eq_clause'.evd)) 
+    (tac eq eq_clause') gls
 
-let onNegatedEquality tac gls =
+let onNegatedEquality with_evars tac gls =
   let ccl = pf_concl gls in
-  let eq =
-    try match kind_of_term (hnf_constr (pf_env gls) (project gls) ccl) with
-      | Prod (_,t,u) when is_empty_type u ->
-          find_eq_data_decompose (pf_whd_betadeltaiota gls t)
-      | _ -> raise PatternMatchingFailure
-    with PatternMatchingFailure ->
+  match kind_of_term (hnf_constr (pf_env gls) (project gls) ccl) with
+  | Prod (_,t,u) when is_empty_type u ->
+      tclTHEN introf
+        (onLastHyp (fun id -> 
+          onEquality with_evars tac (mkVar id,NoBindings))) gls
+  | _ -> 
       errorlabstrm "" (str "Not a negated primitive equality")
-  in tclTHEN introf (onLastHyp (tac eq)) gls
 
-let discrSimpleClause = function
-  | None -> onNegatedEquality discrEq
-  | Some ((_,id),_) -> onEquality discrEq id
+let discrSimpleClause with_evars = function
+  | None -> onNegatedEquality with_evars discrEq
+  | Some ((_,id),_) -> onEquality with_evars discrEq (mkVar id,NoBindings)
 
-let discr = onEquality discrEq
+let discr with_evars = onEquality with_evars discrEq
 
-let discrClause = onClauses discrSimpleClause
+let discrClause with_evars = onClauses (discrSimpleClause with_evars)
 
-let discrEverywhere = 
+let discrEverywhere with_evars = 
   tclORELSE
-    (Tacticals.tryAllClauses discrSimpleClause)
+    (Tacticals.tryAllClauses
+      (fun cl -> tclCOMPLETE (discrSimpleClause with_evars cl)))
     (fun gls -> 
        errorlabstrm "DiscrEverywhere" (str"No discriminable equalities"))
 
-let discr_tac = function
-  | None -> discrEverywhere
-  | Some id -> try_intros_until discr id
+let discr_tac with_evars = function
+  | None -> discrEverywhere with_evars
+  | Some c -> onInductionArg (discr with_evars) c
 
-let discrConcl gls  = discrClause onConcl gls
-let discrHyp id gls = discrClause (onHyp id) gls
+let discrConcl gls  = discrClause false onConcl gls
+let discrHyp id gls = discrClause false (onHyp id) gls
 
 (* returns the sigma type (sigS, sigT) with the respective
     constructor depending on the sort *)
@@ -585,18 +661,20 @@ let make_tuple env sigma (rterm,rty) lind =
    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.  If the normal
-   form of the type contains fewer references, we want to return that
-   instead. *)
+   the free-references of the normal-form of that type. Strictly
+   computing the exact set of free rels would require full
+   normalization but this is not reasonable (e.g. in presence of
+   records that contains proofs). We restrict ourself to a "simpl"
+   normalization *)
 
 let minimal_free_rels env sigma (c,cty) =
   let cty_rels = free_rels cty in
-  let nf_cty = nf_betadeltaiota env sigma cty in
-  let nf_rels = free_rels nf_cty in
-  if Intset.subset cty_rels nf_rels then
+  let cty' = simpl env sigma cty in
+  let rels' = free_rels cty' in
+  if Intset.subset cty_rels rels' then
     (cty,cty_rels)
   else
-    (nf_cty,nf_rels)
+    (cty',rels')
 
 (* [sig_clausal_form siglen ty]
     
@@ -636,13 +714,13 @@ let minimal_free_rels env sigma (c,cty) =
 
 let sig_clausal_form env sigma sort_of_ty siglen ty dflt =
   let { intro = exist_term } = find_sigma_data sort_of_ty in 
-  let isevars = ref (Evd.create_evar_defs sigma) in
+  let evdref = ref (Evd.create_goal_evar_defs sigma) in
   let rec sigrec_clausal_form siglen p_i =
     if 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 isevars dflt_typ p_i then
-	(* the_conv_x had a side-effect on isevars *)
+      if Evarconv.e_cumul env evdref dflt_typ p_i then
+	(* the_conv_x had a side-effect on evdref *)
 	dflt
       else
 	error "Cannot solve an unification problem"
@@ -650,18 +728,18 @@ let sig_clausal_form env sigma sort_of_ty siglen ty dflt =
       let (a,p_i_minus_1) = match whd_beta_stack p_i with
 	| (_sigS,[a;p]) -> (a,p)
  	| _ -> anomaly "sig_clausal_form: should be a sigma type" in
-      let ev = Evarutil.e_new_evar isevars env a in
+      let ev = Evarutil.e_new_evar evdref env a in
       let rty = beta_applist(p_i_minus_1,[ev]) in
       let tuple_tail = sigrec_clausal_form (siglen-1) rty in
       match
-	Evd.existential_opt_value (Evd.evars_of !isevars) 
+	Evd.existential_opt_value (Evd.evars_of !evdref) 
 	(destEvar ev)
       with
 	| Some w -> applist(exist_term,[a;p_i_minus_1;w;tuple_tail])
 	| None -> anomaly "Not enough components to build the dependent tuple"
   in
   let scf = sigrec_clausal_form siglen ty in
-  Evarutil.nf_evar (Evd.evars_of !isevars) scf
+  Evarutil.nf_evar (Evd.evars_of !evdref) scf
 
 (* The problem is to build a destructor (a generalization of the
    predecessor) which, when applied to a term made of constructors
@@ -770,7 +848,7 @@ let simplify_args env sigma t =
     | eq, [t1;c1;t2;c2] -> applist (eq,[t1;nf env sigma c1;t2;nf env sigma c2])
     | _ -> t
 
-let inject_at_positions env sigma (eq,(t,t1,t2)) id posns =
+let inject_at_positions env sigma (eq,(t,t1,t2)) eq_clause posns =
   let e = next_ident_away eq_baseid (ids_of_context env) in
   let e_env = push_named (e,None,t) env in
   let injectors =
@@ -779,8 +857,11 @@ let inject_at_positions env sigma (eq,(t,t1,t2)) id posns =
         (* 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;mkVar id]) in
-	let ty = simplify_args env sigma (get_type_of env sigma pf) 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
@@ -789,14 +870,16 @@ let inject_at_positions env sigma (eq,(t,t1,t2)) id posns =
     (fun (pf,ty) -> tclTHENS (cut ty) [tclIDTAC; refine pf])
     injectors
 
-let injEq ipats (eq,(t,t1,t2)) id gls =
-  let sigma = project gls in
-  let env = pf_env gls in
+exception Not_dep_pair
+
+
+let injEq ipats (eq,(t,t1,t2)) eq_clause =
+  let sigma = Evd.evars_of eq_clause.evd in
+  let env = eq_clause.env in
   match find_positions env sigma t1 t2 with
     | Inl _ ->
 	errorlabstrm "Inj"
-	  (str (string_of_id id) ++
-	    str" is not a projectable equality but a discriminable one")
+	  (str"Not a projectable equality but a discriminable one")
     | Inr [] ->
 	errorlabstrm "Equality.inj" 
 	   (str"Nothing to do, it is an equality between convertible terms")
@@ -805,40 +888,73 @@ let injEq ipats (eq,(t,t1,t2)) id gls =
 	let t1 = try_delta_expand env sigma t1 in
 	let t2 = try_delta_expand env sigma t2 in
 *)
-	tclTHEN 
-	  (inject_at_positions env sigma (eq,(t,t1,t2)) id posns)
+        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_dec_proof 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);Ind_tables.find_eq_dec_proof 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 _ ->
+	tclTHEN
+	  (inject_at_positions env sigma (eq,(t,t1,t2)) eq_clause posns)
 	  (intros_pattern None ipats)
-	  gls
 
-let inj ipats = onEquality (injEq ipats)
+let inj ipats with_evars = onEquality with_evars (injEq ipats)
 
-let injClause ipats = function
-  | None -> onNegatedEquality (injEq ipats)
-  | Some id -> try_intros_until (inj ipats) id
+let injClause ipats with_evars = function
+  | None -> onNegatedEquality with_evars (injEq ipats)
+  | Some c -> onInductionArg (inj ipats with_evars) c
 
-let injConcl gls  = injClause [] None gls
-let injHyp id gls = injClause [] (Some id) gls
+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) 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 = project gls in
+  let sigma = Evd.evars_of 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 id cpath dirn sort gls
+	discr_positions env sigma u clause cpath dirn sort gls
     | Inr [] -> (* Change: do not fail, simplify clear this trivial hyp *)
         ntac 0 gls
     | Inr posns ->
 	tclTHEN
-	  (inject_at_positions env sigma (lbeq,(t,t1,t2)) id (List.rev posns))
+	  (inject_at_positions env sigma (lbeq,(t,t1,t2)) clause
+	    (List.rev posns))
 	  (ntac (List.length posns))
 	  gls
 
-let dEqThen ntac = function
-  | None -> onNegatedEquality (decompEqThen ntac)
-  | Some id -> try_intros_until (onEquality (decompEqThen ntac)) id
+let dEqThen with_evars ntac = function
+  | None -> onNegatedEquality with_evars (decompEqThen ntac)
+  | Some c -> onInductionArg (onEquality with_evars (decompEqThen ntac)) c
 
-let dEq = dEqThen (fun x -> tclIDTAC)
+let dEq with_evars = dEqThen with_evars (fun x -> tclIDTAC)
 
 let rewrite_msg = function 
   | None -> str "passed term is not a primitive equality" 
@@ -1031,7 +1147,8 @@ let unfold_body x gl =
       | _ -> errorlabstrm "unfold_body"
           (pr_id x ++ str" is not a defined hypothesis") in
   let aft = afterHyp x gl in
-  let hl = List.fold_right (fun (y,yval,_) cl -> (([],y),InHyp) :: cl) aft [] in
+  let hl = List.fold_right 
+    (fun (y,yval,_) cl -> ((all_occurrences_expr,y),InHyp) :: cl) aft [] in
   let xvar = mkVar x in
   let rfun _ _ c = replace_term xvar xval c in
   tclTHENLIST
@@ -1088,7 +1205,7 @@ let subst_one x gl =
   let introtac = function
       (id,None,_) -> intro_using id
     | (id,Some hval,htyp) ->
-        letin_tac true (Name id)
+        letin_tac None (Name id)
 	  (mkCast(replace_term varx rhs hval,DEFAULTcast,
 	          replace_term varx rhs htyp)) nowhere
   in
@@ -1144,14 +1261,14 @@ let cond_eq_term c t gl =
     else failwith "not convertible"
   with PatternMatchingFailure -> failwith "not an equality"
 
-let rewrite_mutli_assumption_cond cond_eq_term cl gl = 
+let rewrite_multi_assumption_cond cond_eq_term cl gl = 
   let rec arec = function 
     | [] -> error "No such assumption"
     | (id,_,t) ::rest -> 
 	begin 
 	  try 
 	    let dir = cond_eq_term t gl in 
-	    general_multi_rewrite dir (mkVar id,NoBindings) cl gl
+	    general_multi_rewrite dir false (mkVar id,NoBindings) cl gl
 	  with | Failure _ | UserError _ -> arec rest
 	end
   in 
@@ -1164,7 +1281,7 @@ let replace_multi_term dir_opt c  =
       | Some true -> cond_eq_term_left c
       | Some false -> cond_eq_term_right c
   in 
-  rewrite_mutli_assumption_cond cond_eq_fun 
+  rewrite_multi_assumption_cond cond_eq_fun 
 
 (* JF. old version 
 let rewrite_assumption_cond faildir gl =
@@ -1221,3 +1338,4 @@ let replace_term_in t hyp = replace_multi_term None t (Tacticals.onHyp hyp)
 
 let _ = Setoid_replace.register_replace (fun tac_opt c2 c1 gl ->  replace_in_clause_maybe_by c2 c1 onConcl tac_opt gl)
 let _ = Setoid_replace.register_general_rewrite general_rewrite
+let _ = Tactics.register_general_multi_rewrite general_multi_rewrite
diff --git a/tactics/equality.mli b/tactics/equality.mli
index 93cf53bd..42c502be 100644
--- a/tactics/equality.mli
+++ b/tactics/equality.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: equality.mli 9835 2007-05-17 22:23:03Z jforest $ i*)
+(*i $Id: equality.mli 11166 2008-06-22 13:23:35Z herbelin $ i*)
 
 (*i*)
 open Names
@@ -21,12 +21,15 @@ open Pattern
 open Tacticals
 open Tactics
 open Tacexpr
+open Termops
 open Rawterm
 open Genarg
 (*i*)
 
-val general_rewrite_bindings : bool -> constr with_bindings -> tactic
-val general_rewrite          : bool -> constr -> tactic
+val general_rewrite_bindings : 
+  bool -> occurrences -> constr with_bindings -> evars_flag -> tactic
+val general_rewrite : 
+  bool -> occurrences -> constr -> tactic
 
 (* Obsolete, use [general_rewrite_bindings l2r]
 [val rewriteLR_bindings       : constr with_bindings -> tactic]
@@ -39,17 +42,24 @@ val rewriteRL   : constr  -> tactic
 
 (* Warning: old [general_rewrite_in] is now [general_rewrite_bindings_in] *)
 
+val register_general_setoid_rewrite_clause :
+  (identifier option -> bool ->
+    occurrences -> constr -> new_goals:constr list -> tactic) -> unit
+
 val general_rewrite_bindings_in :
-  bool -> identifier -> constr with_bindings -> tactic
+  bool -> occurrences -> identifier -> constr with_bindings -> evars_flag -> tactic
 val general_rewrite_in          :
-  bool -> identifier -> constr -> tactic
+  bool -> occurrences -> identifier -> constr -> evars_flag -> tactic
 
 val general_multi_rewrite : 
-  bool -> constr with_bindings -> clause -> tactic
+  bool -> evars_flag -> constr with_ebindings -> clause -> tactic
+val general_multi_multi_rewrite : 
+  evars_flag -> (bool * multi * constr with_ebindings) list -> clause -> 
+  tactic option -> tactic
 
-val conditional_rewrite : bool -> tactic -> constr with_bindings -> tactic
+val conditional_rewrite : bool -> tactic -> constr with_ebindings -> tactic
 val conditional_rewrite_in :
-  bool -> identifier -> tactic -> constr with_bindings -> tactic
+  bool -> identifier -> tactic -> constr with_ebindings -> tactic
 
 val replace_in_clause_maybe_by : constr -> constr -> clause -> tactic option -> tactic
 val replace    : constr -> constr -> tactic
@@ -57,18 +67,22 @@ 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        : identifier -> tactic
+val discr        : evars_flag -> constr with_ebindings -> tactic
 val discrConcl   : tactic
-val discrClause  : clause -> tactic
+val discrClause  : evars_flag -> clause -> tactic
 val discrHyp     : identifier -> tactic
-val discrEverywhere     : tactic
-val discr_tac    : quantified_hypothesis option -> tactic
-val inj          : intro_pattern_expr list -> identifier -> tactic
-val injClause    : intro_pattern_expr list -> quantified_hypothesis option ->
-                   tactic
-
-val dEq : quantified_hypothesis option -> tactic
-val dEqThen : (int -> tactic) -> quantified_hypothesis option -> tactic
+val discrEverywhere : evars_flag -> tactic
+val discr_tac    : evars_flag -> 
+  constr with_ebindings induction_arg option -> tactic
+val inj          : intro_pattern_expr list -> evars_flag ->
+  constr with_ebindings -> tactic
+val injClause    : intro_pattern_expr list -> evars_flag -> 
+  constr with_ebindings induction_arg option -> tactic
+val injHyp       : identifier -> tactic
+val injConcl     : tactic
+
+val dEq : evars_flag -> constr with_ebindings induction_arg option -> tactic
+val dEqThen : evars_flag -> (int -> tactic) -> constr with_ebindings induction_arg option -> tactic
 
 val make_iterated_tuple : 
   env -> evar_map -> constr -> (constr * types) -> constr * constr * constr
diff --git a/tactics/evar_tactics.ml b/tactics/evar_tactics.ml
index ed40af1c..b4a39a24 100644
--- a/tactics/evar_tactics.ml
+++ b/tactics/evar_tactics.ml
@@ -6,13 +6,14 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: evar_tactics.ml 9154 2006-09-20 17:18:18Z corbinea $ *)
+(* $Id: evar_tactics.ml 11072 2008-06-08 16:13:37Z herbelin $ *)
 
 open Term
 open Util
 open Evar_refiner
 open Tacmach
 open Tacexpr
+open Refiner
 open Proof_type
 open Evd
 open Sign
@@ -38,21 +39,24 @@ let instantiate n rawc ido gl =
 	    match hloc with
 		InHyp ->  
 		  (match decl with 
-		       (_,None,typ) -> evar_list sigma typ
-		     | _ -> error 
-			 "please be more specific : in type or value ?")
+		      (_,None,typ) -> evar_list sigma typ
+		    | _ -> error 
+			"please be more specific : in type or value ?")
 	      | InHypTypeOnly ->
 		  let (_, _, typ) = decl in evar_list sigma typ
 	      | InHypValueOnly ->
 		  (match decl with 
-		       (_,Some body,_) -> evar_list sigma body
-		     | _ -> error "not a let .. in  hypothesis") in
+		      (_,Some body,_) -> evar_list sigma body
+		    | _ -> error "not a let .. in  hypothesis") in
     if List.length evl < n then
       error "not enough uninstantiated existential variables";
     if n <= 0 then error "incorrect existential variable index";
     let ev,_ =  destEvar (List.nth evl (n-1)) in
-    let evd' = w_refine ev rawc (create_evar_defs sigma)  in
-    Refiner.tclEVARS (evars_of evd') gl
+    let evd' = w_refine ev rawc (create_goal_evar_defs sigma) in
+      tclTHEN
+        (tclEVARS (evars_of evd'))
+        tclNORMEVAR
+        gl
 	
 (*
 let pfic gls c =
@@ -68,8 +72,8 @@ let instantiate_tac = function
 *)
 
 let let_evar name typ gls =
-  let evd = Evd.create_evar_defs gls.sigma in
+  let evd = Evd.create_goal_evar_defs gls.sigma in
   let evd',evar = Evarutil.new_evar evd (pf_env gls) typ in
   Refiner.tclTHEN (Refiner.tclEVARS (evars_of evd'))
-    (Tactics.letin_tac true name evar nowhere) gls
+    (Tactics.letin_tac None name evar nowhere) gls
  
diff --git a/tactics/extraargs.ml4 b/tactics/extraargs.ml4
index 3c7d76b2..a0230b28 100644
--- a/tactics/extraargs.ml4
+++ b/tactics/extraargs.ml4
@@ -8,7 +8,7 @@
 
 (*i camlp4deps: "parsing/grammar.cma" i*)
 
-(* $Id: extraargs.ml4 9076 2006-08-23 15:05:54Z jforest $ *)
+(* $Id: extraargs.ml4 11094 2008-06-10 19:35:23Z herbelin $ *)
 
 open Pp
 open Pcoq
@@ -33,6 +33,70 @@ ARGUMENT EXTEND orient TYPED AS bool PRINTED BY pr_orient
 | [ ] -> [ true ]
 END
 
+let pr_int_list _prc _prlc _prt l =
+  let rec aux = function
+    | i :: l -> Pp.int i ++ Pp.spc () ++ aux l
+    | [] -> Pp.mt()
+  in aux l
+
+ARGUMENT EXTEND int_nelist
+  TYPED AS int list 
+  PRINTED BY pr_int_list
+  RAW_TYPED AS int list 
+  RAW_PRINTED BY pr_int_list
+  GLOB_TYPED AS int list
+  GLOB_PRINTED BY pr_int_list
+| [ integer(x) int_nelist(l) ] -> [x::l]
+| [ integer(x) ] -> [ [x] ]
+END
+
+open Rawterm
+
+let pr_occurrences _prc _prlc _prt l =
+  match l with
+    | ArgArg x -> pr_int_list _prc _prlc _prt x
+    | ArgVar (loc, id) -> Nameops.pr_id id
+
+let coerce_to_int = function
+  | VInteger n -> n
+  | v -> raise (CannotCoerceTo "an integer")
+
+let int_list_of_VList = function
+  | VList l -> List.map (fun n -> coerce_to_int n) l
+  | _ -> raise Not_found
+      
+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)
+	  with Not_found | CannotCoerceTo _ -> [interp_int ist locid])
+
+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
+  TYPED AS occurrences
+  PRINTED BY pr_int_list
+
+  INTERPRETED BY interp_occs
+  GLOBALIZED BY glob_occs
+  SUBSTITUTED BY subst_occs
+
+  RAW_TYPED AS occurrences_or_var
+  RAW_PRINTED BY pr_occurrences
+
+  GLOB_TYPED AS occurrences_or_var
+  GLOB_PRINTED BY pr_occurrences
+
+| [ int_nelist(l) ] -> [ ArgArg l ]
+| [ var(id) ] -> [ ArgVar id ]
+END
+
 (* For Setoid rewrite *)
 let pr_morphism_signature _ _ _ s =
   spc () ++ Setoid_replace.pr_morphism_signature s
@@ -221,18 +285,126 @@ END
 
 let gen_in_arg_hyp_to_clause trad_id (hyps ,concl) : Tacticals.clause = 
   {Tacexpr.onhyps=
-   Util.option_map 
+   Option.map 
      (fun l -> 
 	List.map 
-	  (fun id -> ( ([],trad_id id) ,Tacexpr.InHyp))
+	  (fun id -> ( (all_occurrences_expr,trad_id id) ,Tacexpr.InHyp))
 	  l
      )
      hyps;
-   Tacexpr.onconcl=concl;
-   Tacexpr.concl_occs = []}
+   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 "r_nat_field"
+let (wit_r_n_field, globwit_r_n_field, rawwit_r_n_field) =
+  Genarg.create_arg "r_n_field"
+let (wit_r_int31_field, globwit_r_int31_field, rawwit_r_int31_field) =
+  Genarg.create_arg "r_int31_field"
+let (wit_r_field, globwit_r_field, rawwit_r_field) =
+  Genarg.create_arg "r_field"
+
+(* spiwack: the print functions are incomplete, but I don't know what they are
+	used for *)
+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 =
+  str "binary N " ++
+  match nf with
+    | Retroknowledge.NPositive -> str "positive"
+    | Retroknowledge.NType -> str "type"
+    | Retroknowledge.NTwice -> str "twice"
+    | Retroknowledge.NTwicePlusOne -> str "twice plus one"
+    | Retroknowledge.NPhi -> str "phi"
+    | Retroknowledge.NPhiInv -> str "phi inv"
+    | Retroknowledge.NPlus -> str "plus"
+    | Retroknowledge.NTimes -> str "times"
+
+let pr_r_int31_field _ _ _ i31f =
+  str "int31 " ++
+  match i31f with
+    | Retroknowledge.Int31Bits -> str "bits"
+    | Retroknowledge.Int31Type -> str "type"
+    | Retroknowledge.Int31Twice -> str "twice"
+    | Retroknowledge.Int31TwicePlusOne -> str "twice plus one"
+    | Retroknowledge.Int31Phi -> str "phi"
+    | Retroknowledge.Int31PhiInv -> str "phi inv"
+    | Retroknowledge.Int31Plus -> str "plus"
+    | Retroknowledge.Int31Times -> str "times"
+    | _ -> assert false	
+
+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) ++
+                                           str "in " ++ str group 
+
+ARGUMENT EXTEND retroknowledge_nat
+TYPED AS r_nat_field
+PRINTED BY pr_r_nat_field
+| [ "nat" "type" ] -> [ Retroknowledge.NatType ]
+| [ "nat" "plus" ] -> [ Retroknowledge.NatPlus ]
+| [ "nat" "times" ] -> [ Retroknowledge.NatTimes ]
+END
+
+
+ARGUMENT EXTEND retroknowledge_binary_n
+TYPED AS r_n_field 
+PRINTED BY pr_r_n_field
+| [ "binary" "N" "positive" ] -> [ Retroknowledge.NPositive ]
+| [ "binary" "N" "type" ] -> [ Retroknowledge.NType ]
+| [ "binary" "N" "twice" ] -> [ Retroknowledge.NTwice ]
+| [ "binary" "N" "twice" "plus" "one" ] -> [ Retroknowledge.NTwicePlusOne ]
+| [ "binary" "N" "phi" ] -> [ Retroknowledge.NPhi ]
+| [ "binary" "N" "phi" "inv" ] -> [ Retroknowledge.NPhiInv ]
+| [ "binary" "N" "plus" ] -> [ Retroknowledge.NPlus ]
+| [ "binary" "N" "times" ] -> [ Retroknowledge.NTimes ]
+END
+
+ARGUMENT EXTEND retroknowledge_int31
+TYPED AS r_int31_field 
+PRINTED BY pr_r_int31_field
+| [ "int31" "bits" ] -> [ Retroknowledge.Int31Bits ]
+| [ "int31" "type" ] -> [ Retroknowledge.Int31Type ]
+| [ "int31" "twice" ] -> [ Retroknowledge.Int31Twice ]
+| [ "int31" "twice" "plus" "one" ] -> [ Retroknowledge.Int31TwicePlusOne ]
+| [ "int31" "phi" ] -> [ Retroknowledge.Int31Phi ]
+| [ "int31" "phi" "inv" ] -> [ Retroknowledge.Int31PhiInv ]
+| [ "int31" "plus" ] -> [ Retroknowledge.Int31Plus ]
+| [ "int31" "plusc" ] -> [ Retroknowledge.Int31PlusC ]
+| [ "int31" "pluscarryc" ] -> [ Retroknowledge.Int31PlusCarryC ]
+| [ "int31" "minus" ] -> [ Retroknowledge.Int31Minus ]
+| [ "int31" "minusc" ] -> [ Retroknowledge.Int31MinusC ]
+| [ "int31" "minuscarryc" ] -> [ Retroknowledge.Int31MinusCarryC ]
+| [ "int31" "times" ] -> [ Retroknowledge.Int31Times ]
+| [ "int31" "timesc" ] -> [ Retroknowledge.Int31TimesC ]
+| [ "int31" "div21" ] -> [ Retroknowledge.Int31Div21 ]
+| [ "int31" "div" ] -> [ Retroknowledge.Int31Div ]
+| [ "int31" "addmuldiv" ] -> [ Retroknowledge.Int31AddMulDiv ]
+| [ "int31" "compare" ] -> [ Retroknowledge.Int31Compare ]
+| [ "int31" "head0" ] -> [ Retroknowledge.Int31Head0 ]
+| [ "int31" "tail0" ] -> [ Retroknowledge.Int31Tail0 ]
+
+END
+
+ARGUMENT EXTEND retroknowledge_field 
+TYPED AS r_field 
+PRINTED BY pr_retroknowledge_field
+(*| [ "equality" ] -> [ Retroknowledge.KEq ]
+| [ retroknowledge_nat(n)] -> [ Retroknowledge.KNat n ]
+| [ retroknowledge_binary_n (n)] -> [ Retroknowledge.KN n ]*)
+| [ retroknowledge_int31 (i) "in" string(g)] -> [ Retroknowledge.KInt31(g,i) ]
+END
diff --git a/tactics/extraargs.mli b/tactics/extraargs.mli
index 4a9a0c5f..74296ab0 100644
--- a/tactics/extraargs.mli
+++ b/tactics/extraargs.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: extraargs.mli 9076 2006-08-23 15:05:54Z jforest $ i*)
+(*i $Id: extraargs.mli 10820 2008-04-20 18:18:49Z msozeau $ i*)
 
 open Tacexpr
 open Term
@@ -16,18 +16,22 @@ open Topconstr
 open Rawterm
 
 val rawwit_orient : bool raw_abstract_argument_type
-val wit_orient : bool closed_abstract_argument_type
+val wit_orient : bool typed_abstract_argument_type
 val orient : bool Pcoq.Gram.Entry.e
 
+val occurrences : (int list or_var) Pcoq.Gram.Entry.e
+val rawwit_occurrences : (int list or_var) raw_abstract_argument_type
+val wit_occurrences : (int list) typed_abstract_argument_type
+
 val rawwit_morphism_signature :
  Setoid_replace.morphism_signature raw_abstract_argument_type
 val wit_morphism_signature :
- Setoid_replace.morphism_signature closed_abstract_argument_type
+ Setoid_replace.morphism_signature typed_abstract_argument_type
 val morphism_signature :
  Setoid_replace.morphism_signature Pcoq.Gram.Entry.e
 
 val rawwit_raw : constr_expr raw_abstract_argument_type
-val wit_raw : rawconstr closed_abstract_argument_type
+val wit_raw : rawconstr typed_abstract_argument_type
 val raw : constr_expr Pcoq.Gram.Entry.e
 
 type 'id gen_place= ('id * hyp_location_flag,unit) location
@@ -36,17 +40,25 @@ type loc_place = identifier Util.located gen_place
 type place = identifier gen_place
 
 val rawwit_hloc : loc_place raw_abstract_argument_type
-val wit_hloc : place closed_abstract_argument_type
+val wit_hloc : place typed_abstract_argument_type
 val hloc : loc_place Pcoq.Gram.Entry.e
 
 
 val in_arg_hyp:  (Names.identifier Util.located list option * bool)  Pcoq.Gram.Entry.e
 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) closed_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 by_arg_tac : Tacexpr.raw_tactic_expr option Pcoq.Gram.Entry.e
 val rawwit_by_arg_tac :  raw_tactic_expr option raw_abstract_argument_type
-val wit_by_arg_tac : glob_tactic_expr option closed_abstract_argument_type
+val wit_by_arg_tac : glob_tactic_expr option typed_abstract_argument_type
+
+
+
+(* Spiwack: Primitive for retroknowledge registration *)
+
+val retroknowledge_field : Retroknowledge.field Pcoq.Gram.Entry.e
+val rawwit_retroknowledge_field :  Retroknowledge.field raw_abstract_argument_type
+val wit_retroknowledge_field : Retroknowledge.field typed_abstract_argument_type
diff --git a/tactics/extratactics.ml4 b/tactics/extratactics.ml4
index d6de2666..885138e4 100644
--- a/tactics/extratactics.ml4
+++ b/tactics/extratactics.ml4
@@ -8,7 +8,7 @@
 
 (*i camlp4deps: "parsing/grammar.cma" i*)
 
-(* $Id: extratactics.ml4 9430 2006-12-12 08:25:19Z herbelin $ *)
+(* $Id: extratactics.ml4 11166 2008-06-22 13:23:35Z herbelin $ *)
 
 open Pp
 open Pcoq
@@ -16,6 +16,8 @@ open Genarg
 open Extraargs
 open Mod_subst
 open Names
+open Tacexpr
+open Rawterm
 
 (* Equality *)
 open Equality
@@ -23,7 +25,7 @@ open Equality
 
 TACTIC EXTEND replace 
    ["replace" 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) (Util.option_map Tacinterp.eval_tactic tac) ]
+-> [ replace_in_clause_maybe_by c1 c2 (glob_in_arg_hyp_to_clause in_hyp) (Option.map Tacinterp.eval_tactic tac) ]
 END
 
 TACTIC EXTEND replace_term_left
@@ -41,25 +43,93 @@ TACTIC EXTEND replace_term
   -> [ replace_multi_term None c (glob_in_arg_hyp_to_clause in_hyp) ]
 END
 
+let induction_arg_of_quantified_hyp = function
+  | AnonHyp n -> ElimOnAnonHyp n
+  | NamedHyp id -> ElimOnIdent (Util.dummy_loc,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" *)
+
+TACTIC EXTEND simplify_eq_main
+| [ "simplify_eq" constr_with_bindings(c) ] ->
+    [ dEq false (Some (ElimOnConstr c)) ]
+END
 TACTIC EXTEND simplify_eq
-  [ "simplify_eq" quantified_hypothesis_opt(h) ] -> [ dEq h ]
+  [ "simplify_eq" ] -> [ dEq false None ]
+| [ "simplify_eq" quantified_hypothesis(h) ] ->
+    [ dEq false (Some (induction_arg_of_quantified_hyp h)) ]
+END
+TACTIC EXTEND esimplify_eq_main
+| [ "esimplify_eq" constr_with_bindings(c) ] ->
+    [ dEq true (Some (ElimOnConstr c)) ]
+END
+TACTIC EXTEND esimplify_eq
+| [ "esimplify_eq" ] -> [ dEq true None ]
+| [ "esimplify_eq" quantified_hypothesis(h) ] ->
+    [ dEq true (Some (induction_arg_of_quantified_hyp h)) ]
 END
 
+TACTIC EXTEND discriminate_main
+| [ "discriminate" constr_with_bindings(c) ] ->
+    [ discr_tac false (Some (ElimOnConstr c)) ]
+END
 TACTIC EXTEND discriminate
-  [ "discriminate" quantified_hypothesis_opt(h) ] -> [ discr_tac h ]
+| [ "discriminate" ] -> [ discr_tac false None ]
+| [ "discriminate" quantified_hypothesis(h) ] ->
+    [ discr_tac false (Some (induction_arg_of_quantified_hyp h)) ]
+END
+TACTIC EXTEND ediscriminate_main
+| [ "ediscriminate" constr_with_bindings(c) ] ->
+    [ discr_tac true (Some (ElimOnConstr c)) ]
+END
+TACTIC EXTEND ediscriminate
+| [ "ediscriminate" ] -> [ discr_tac true None ]
+| [ "ediscriminate" quantified_hypothesis(h) ] ->
+    [ discr_tac true (Some (induction_arg_of_quantified_hyp h)) ]
 END
 
-let h_discrHyp id = h_discriminate (Some id)
+let h_discrHyp id = h_discriminate_main (Term.mkVar id,NoBindings)
 
+TACTIC EXTEND injection_main
+| [ "injection" constr_with_bindings(c) ] ->
+    [ injClause [] false (Some (ElimOnConstr c)) ]
+END 
 TACTIC EXTEND injection
-  [ "injection" quantified_hypothesis_opt(h) ] -> [ injClause [] h ]
+| [ "injection" ] -> [ injClause [] false None ]
+| [ "injection" quantified_hypothesis(h) ] -> 
+    [ injClause [] false (Some (induction_arg_of_quantified_hyp h)) ]
+END
+TACTIC EXTEND einjection_main
+| [ "einjection" constr_with_bindings(c) ] ->
+    [ injClause [] true (Some (ElimOnConstr c)) ]
+END
+TACTIC EXTEND einjection
+| [ "einjection" ] -> [ injClause [] true None ]
+| [ "einjection" quantified_hypothesis(h) ] -> [ injClause [] true (Some (induction_arg_of_quantified_hyp h)) ]
+END 
+TACTIC EXTEND injection_as_main
+| [ "injection" constr_with_bindings(c) "as" simple_intropattern_list(ipat)] ->
+    [ injClause ipat false (Some (ElimOnConstr c)) ]
 END 
 TACTIC EXTEND injection_as
-  [ "injection" quantified_hypothesis_opt(h) 
-    "as" simple_intropattern_list(ipat)] -> [ injClause ipat h ]
+| [ "injection" "as" simple_intropattern_list(ipat)] ->
+    [ injClause ipat false None ]
+| [ "injection" quantified_hypothesis(h) "as" simple_intropattern_list(ipat) ] ->
+    [ injClause 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)] ->
+    [ injClause ipat true (Some (ElimOnConstr c)) ]
+END 
+TACTIC EXTEND einjection_as
+| [ "einjection" "as" simple_intropattern_list(ipat)] ->
+    [ injClause ipat true None ]
+| [ "einjection" quantified_hypothesis(h) "as" simple_intropattern_list(ipat) ] ->
+    [ injClause ipat true (Some (induction_arg_of_quantified_hyp h)) ]
 END
 
-let h_injHyp id = h_injection (Some id)
+let h_injHyp id = h_injection_main (Term.mkVar id,NoBindings)
 
 TACTIC EXTEND conditional_rewrite
 | [ "conditional" tactic(tac) "rewrite" orient(b) constr_with_bindings(c) ]
@@ -150,82 +220,82 @@ let refine_tac = h_refine
 
 open Setoid_replace
 
-TACTIC EXTEND setoid_replace
-   [ "setoid_replace" constr(c1) "with" constr(c2) by_arg_tac(tac)] ->
-     [ setoid_replace  (Util.option_map Tacinterp.eval_tactic tac) None c1 c2 ~new_goals:[] ]
- | [ "setoid_replace" constr(c1) "with" constr(c2) "using" "relation" constr(rel) by_arg_tac(tac)] ->
-     [ setoid_replace  (Util.option_map Tacinterp.eval_tactic tac) (Some rel) c1 c2 ~new_goals:[] ]
- | [ "setoid_replace" constr(c1) "with" constr(c2) "generate" "side" "conditions" constr_list(l) by_arg_tac(tac) ] ->
-     [ setoid_replace  (Util.option_map Tacinterp.eval_tactic tac) None c1 c2 ~new_goals:l ]
- | [ "setoid_replace" constr(c1) "with" constr(c2) "using" "relation" constr(rel) "generate" "side" "conditions" constr_list(l) by_arg_tac(tac) ] ->
-     [ setoid_replace  (Util.option_map Tacinterp.eval_tactic tac) (Some rel) c1 c2 ~new_goals:l ]
- | [ "setoid_replace" constr(c1) "with" constr(c2) "in" hyp(h) by_arg_tac(tac) ] ->
-     [ setoid_replace_in  (Util.option_map Tacinterp.eval_tactic tac) h None c1 c2 ~new_goals:[] ]
- | [ "setoid_replace" constr(c1) "with" constr(c2) "in" hyp(h) "using" "relation" constr(rel) by_arg_tac(tac)] ->
-     [ setoid_replace_in  (Util.option_map Tacinterp.eval_tactic tac) h (Some rel) c1 c2 ~new_goals:[] ]
- | [ "setoid_replace" constr(c1) "with" constr(c2) "in" hyp(h) "generate" "side" "conditions" constr_list(l) by_arg_tac(tac)] ->
-     [ setoid_replace_in  (Util.option_map Tacinterp.eval_tactic tac) h None c1 c2 ~new_goals:l ]
- | [ "setoid_replace" constr(c1) "with" constr(c2) "in" hyp(h) "using" "relation" constr(rel) "generate" "side" "conditions" constr_list(l) by_arg_tac(tac)] ->
-     [ setoid_replace_in  (Util.option_map Tacinterp.eval_tactic tac) h (Some rel) c1 c2 ~new_goals:l ]
-END
-
-TACTIC EXTEND setoid_rewrite
-   [ "setoid_rewrite" orient(b) constr(c) ]
-   -> [ general_s_rewrite b c ~new_goals:[] ]
- | [ "setoid_rewrite" orient(b) constr(c) "generate" "side" "conditions" constr_list(l) ]
-   -> [ general_s_rewrite b c ~new_goals:l ]
- | [ "setoid_rewrite" orient(b) constr(c) "in" hyp(h) ] ->
-      [ general_s_rewrite_in h b c ~new_goals:[] ]
- | [ "setoid_rewrite" orient(b) constr(c) "in" hyp(h) "generate" "side" "conditions" constr_list(l) ] ->
-      [ general_s_rewrite_in h b c ~new_goals:l ]
-END
-
-VERNAC COMMAND EXTEND AddSetoid1
-  [ "Add" "Setoid" constr(a) constr(aeq) constr(t) "as" ident(n) ] ->
-   [ add_setoid n a aeq t ]
-| [ "Add" "Morphism" constr(m) ":" ident(n) ] ->
-   [ new_named_morphism n m None ]
-| [ "Add" "Morphism" constr(m) "with" "signature" morphism_signature(s) "as" ident(n) ] ->
-   [ new_named_morphism n m (Some s)]
-END
-
-VERNAC COMMAND EXTEND AddRelation1
-  [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(t) "symmetry" "proved" "by" constr(t') "as" ident(n) ] ->
-   [ add_relation n a aeq (Some t) (Some t') None ]
-| [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(t)  "as" ident(n) ] ->
-   [ add_relation n a aeq (Some t) None None ]
-| [ "Add" "Relation" constr(a) constr(aeq)  "as" ident(n) ] ->
-   [ add_relation n a aeq None None None ]
-END
-
-VERNAC COMMAND EXTEND AddRelation2
-  [ "Add" "Relation" constr(a) constr(aeq) "symmetry" "proved" "by" constr(t') "as" ident(n) ] ->
-   [ add_relation n a aeq None (Some t') None ]
-| [ "Add" "Relation" constr(a) constr(aeq) "symmetry" "proved" "by" constr(t') "transitivity" "proved" "by" constr(t'')  "as" ident(n) ] ->
-   [ add_relation n a aeq None (Some t') (Some t'') ]
-END
-
-VERNAC COMMAND EXTEND AddRelation3
-  [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(t) "transitivity" "proved" "by" constr(t') "as" ident(n) ] ->
-   [ add_relation n a aeq (Some t) None (Some t') ]
-| [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(t) "symmetry" "proved" "by" constr(t') "transitivity" "proved" "by" constr(t'') "as" ident(n) ] ->
-   [ add_relation n a aeq (Some t) (Some t') (Some t'') ]
-| [ "Add" "Relation" constr(a) constr(aeq) "transitivity" "proved" "by" constr(t) "as" ident(n) ] ->
-   [ add_relation n a aeq None None (Some t) ]
-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 t ]
-END
+(* TACTIC EXTEND setoid_replace *)
+(*    [ "setoid_replace" constr(c1) "with" constr(c2) by_arg_tac(tac)] -> *)
+(*      [ setoid_replace  (Option.map Tacinterp.eval_tactic tac) None c1 c2 ~new_goals:[] ] *)
+(*  | [ "setoid_replace" constr(c1) "with" constr(c2) "using" "relation" constr(rel) by_arg_tac(tac)] -> *)
+(*      [ setoid_replace  (Option.map Tacinterp.eval_tactic tac) (Some rel) c1 c2 ~new_goals:[] ] *)
+(*  | [ "setoid_replace" constr(c1) "with" constr(c2) "generate" "side" "conditions" constr_list(l) by_arg_tac(tac) ] -> *)
+(*      [ setoid_replace  (Option.map Tacinterp.eval_tactic tac) None c1 c2 ~new_goals:l ] *)
+(*  | [ "setoid_replace" constr(c1) "with" constr(c2) "using" "relation" constr(rel) "generate" "side" "conditions" constr_list(l) by_arg_tac(tac) ] -> *)
+(*      [ setoid_replace  (Option.map Tacinterp.eval_tactic tac) (Some rel) c1 c2 ~new_goals:l ] *)
+(*  | [ "setoid_replace" constr(c1) "with" constr(c2) "in" hyp(h) by_arg_tac(tac) ] -> *)
+(*      [ setoid_replace_in  (Option.map Tacinterp.eval_tactic tac) h None c1 c2 ~new_goals:[] ] *)
+(*  | [ "setoid_replace" constr(c1) "with" constr(c2) "in" hyp(h) "using" "relation" constr(rel) by_arg_tac(tac)] -> *)
+(*      [ setoid_replace_in  (Option.map Tacinterp.eval_tactic tac) h (Some rel) c1 c2 ~new_goals:[] ] *)
+(*  | [ "setoid_replace" constr(c1) "with" constr(c2) "in" hyp(h) "generate" "side" "conditions" constr_list(l) by_arg_tac(tac)] -> *)
+(*      [ setoid_replace_in  (Option.map Tacinterp.eval_tactic tac) h None c1 c2 ~new_goals:l ] *)
+(*  | [ "setoid_replace" constr(c1) "with" constr(c2) "in" hyp(h) "using" "relation" constr(rel) "generate" "side" "conditions" constr_list(l) by_arg_tac(tac)] -> *)
+(*      [ setoid_replace_in  (Option.map Tacinterp.eval_tactic tac) h (Some rel) c1 c2 ~new_goals:l ] *)
+(* END *)
+
+(* TACTIC EXTEND setoid_rewrite *)
+(*    [ "setoid_rewrite" orient(b) constr(c) ] *)
+(*    -> [ general_s_rewrite b c ~new_goals:[] ] *)
+(*  | [ "setoid_rewrite" orient(b) constr(c) "generate" "side" "conditions" constr_list(l) ] *)
+(*    -> [ general_s_rewrite b c ~new_goals:l ] *)
+(*  | [ "setoid_rewrite" orient(b) constr(c) "in" hyp(h) ] -> *)
+(*       [ general_s_rewrite_in h b c ~new_goals:[] ] *)
+(*  | [ "setoid_rewrite" orient(b) constr(c) "in" hyp(h) "generate" "side" "conditions" constr_list(l) ] -> *)
+(*       [ general_s_rewrite_in h b c ~new_goals:l ] *)
+(* END *)
+
+(* VERNAC COMMAND EXTEND AddSetoid1 *)
+(*   [ "Add" "Setoid" constr(a) constr(aeq) constr(t) "as" ident(n) ] -> *)
+(*    [ add_setoid n a aeq t ] *)
+(* | [ "Add" "Morphism" constr(m) ":" ident(n) ] -> *)
+(*    [ new_named_morphism n m None ] *)
+(* | [ "Add" "Morphism" constr(m) "with" "signature" morphism_signature(s) "as" ident(n) ] -> *)
+(*    [ new_named_morphism n m (Some s)] *)
+(* END *)
+
+(* VERNAC COMMAND EXTEND AddRelation1 *)
+(*   [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(t) "symmetry" "proved" "by" constr(t') "as" ident(n) ] -> *)
+(*    [ add_relation n a aeq (Some t) (Some t') None ] *)
+(* | [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(t)  "as" ident(n) ] -> *)
+(*    [ add_relation n a aeq (Some t) None None ] *)
+(* | [ "Add" "Relation" constr(a) constr(aeq)  "as" ident(n) ] -> *)
+(*    [ add_relation n a aeq None None None ] *)
+(* END *)
+
+(* VERNAC COMMAND EXTEND AddRelation2 *)
+(*   [ "Add" "Relation" constr(a) constr(aeq) "symmetry" "proved" "by" constr(t') "as" ident(n) ] -> *)
+(*    [ add_relation n a aeq None (Some t') None ] *)
+(* | [ "Add" "Relation" constr(a) constr(aeq) "symmetry" "proved" "by" constr(t') "transitivity" "proved" "by" constr(t'')  "as" ident(n) ] -> *)
+(*    [ add_relation n a aeq None (Some t') (Some t'') ] *)
+(* END *)
+
+(* VERNAC COMMAND EXTEND AddRelation3 *)
+(*   [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(t) "transitivity" "proved" "by" constr(t') "as" ident(n) ] -> *)
+(*    [ add_relation n a aeq (Some t) None (Some t') ] *)
+(* | [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(t) "symmetry" "proved" "by" constr(t') "transitivity" "proved" "by" constr(t'') "as" ident(n) ] -> *)
+(*    [ add_relation n a aeq (Some t) (Some t') (Some t'') ] *)
+(* | [ "Add" "Relation" constr(a) constr(aeq) "transitivity" "proved" "by" constr(t) "as" ident(n) ] -> *)
+(*    [ add_relation n a aeq None None (Some t) ] *)
+(* 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 t ] *)
+(* END *)
 
 (* Inversion lemmas (Leminv) *)
 
@@ -234,10 +304,10 @@ open Leminv
 
 VERNAC COMMAND EXTEND DeriveInversionClear
   [ "Derive" "Inversion_clear" ident(na) hyp(id) ]
-  -> [ inversion_lemma_from_goal 1 na id Term.mk_Prop false inv_clear_tac ]
+  -> [ 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.mk_Prop false inv_clear_tac ]
+  -> [ inversion_lemma_from_goal n na id Term.prop_sort false inv_clear_tac ]
 
 | [ "Derive" "Inversion_clear" ident(na) "with" constr(c) "Sort" sort(s) ]
   -> [ add_inversion_lemma_exn na c s false inv_clear_tac ]
@@ -257,10 +327,10 @@ VERNAC COMMAND EXTEND DeriveInversion
   -> [ add_inversion_lemma_exn na c (RProp Null) false inv_tac ]
 
 | [ "Derive" "Inversion" ident(na) hyp(id) ]
-  -> [ inversion_lemma_from_goal 1 na id Term.mk_Prop false inv_tac ]
+  -> [ 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.mk_Prop false inv_tac ]
+  -> [ inversion_lemma_from_goal n na id Term.prop_sort false inv_tac ]
 END
 
 VERNAC COMMAND EXTEND DeriveDependentInversion
@@ -290,16 +360,17 @@ TACTIC EXTEND evar
 END
 
 open Tacexpr
+open Tacticals
 
 TACTIC EXTEND instantiate
   [ "instantiate" "(" integer(i) ":=" raw(c) ")" hloc(hl) ] ->
     [instantiate i c hl  ]
+| [ "instantiate" ] -> [ tclNORMEVAR ]
 END
 
 
 (** Nijmegen "step" tactic for setoid rewriting *)
 
-open Tacticals
 open Tactics
 open Tactics
 open Libnames
@@ -400,8 +471,36 @@ VERNAC COMMAND EXTEND ImplicitTactic
     [ Tacinterp.declare_implicit_tactic (Tacinterp.interp tac) ]
 END
 
+
+
+
+(*spiwack : Vernac commands for retroknowledge *)
+
+VERNAC COMMAND EXTEND RetroknowledgeRegister
+ | [ "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
+             Global.register f tc tb ]
+END
+
+
+
 TACTIC EXTEND apply_in
-| ["apply" constr_with_bindings(c) "in" hyp(id) ] -> [ apply_in id [c] ]
+| ["apply" constr_with_bindings(c) "in" hyp(id) ] -> [ apply_in false id [c] ]
 | ["apply" constr_with_bindings(c) "," constr_with_bindings_list_sep(cl,",") 
-   "in" hyp(id) ] -> [ apply_in id (c::cl) ]
+   "in" hyp(id) ] -> [ apply_in false id (c::cl) ]
 END
+
+
+TACTIC EXTEND eapply_in
+| ["eapply" constr_with_bindings(c) "in" hyp(id) ] -> [ apply_in true id [c] ]
+| ["epply" constr_with_bindings(c) "," constr_with_bindings_list_sep(cl,",") 
+   "in" hyp(id) ] -> [ apply_in true id (c::cl) ]
+END
+
+(* sozeau: abs/gen for induction on instantiated dependent inductives, using "Ford" induction as 
+  defined by Conor McBride *)
+TACTIC EXTEND generalize_eqs
+| ["generalize_eqs" hyp(id) ] -> [ abstract_generalize id ]
+END
+
diff --git a/tactics/extratactics.mli b/tactics/extratactics.mli
index 234c0161..d43e4581 100644
--- a/tactics/extratactics.mli
+++ b/tactics/extratactics.mli
@@ -6,19 +6,12 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: extratactics.mli 9073 2006-08-22 08:54:29Z jforest $ i*)
+(*i $Id: extratactics.mli 11166 2008-06-22 13:23:35Z herbelin $ i*)
 
-open Util
-open Names
-open Term
 open Proof_type
-open Rawterm
-open Tacexpr
-open Topconstr
-open Genarg
 
-val h_discrHyp : quantified_hypothesis -> tactic
-val h_injHyp : quantified_hypothesis -> tactic
+val h_discrHyp : Names.identifier -> tactic
+val h_injHyp : Names.identifier -> tactic
 
-val refine_tac : Genarg.open_constr -> tactic
+val refine_tac : Evd.open_constr -> tactic
 
diff --git a/tactics/hiddentac.ml b/tactics/hiddentac.ml
index 4133a3f6..190a7ba2 100644
--- a/tactics/hiddentac.ml
+++ b/tactics/hiddentac.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: hiddentac.ml 9551 2007-01-29 15:13:35Z bgregoir $ *)
+(* $Id: hiddentac.ml 11094 2008-06-10 19:35:23Z herbelin $ *)
 
 open Term
 open Proof_type
@@ -20,34 +20,58 @@ open Tactics
 open Util
 
 let inj_id id = (dummy_loc,id)
+let inj_open c = (Evd.empty,c)
+let inj_open_wb (c,b) = ((Evd.empty,c),b)
+let inj_ia = function
+  | ElimOnConstr c -> ElimOnConstr (inj_open_wb c)
+  | ElimOnIdent id -> ElimOnIdent id
+  | ElimOnAnonHyp n -> ElimOnAnonHyp n
+let inj_occ (occ,c) = (occ,inj_open c)
 
 (* Basic tactics *)
 let h_intro_move x y =
-  abstract_tactic (TacIntroMove (x, option_map inj_id y)) (intro_move x y)
+  abstract_tactic (TacIntroMove (x, Option.map inj_id y)) (intro_move x y)
 let h_intro x        = h_intro_move (Some x) None
 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_exact c        = abstract_tactic (TacExact (inj_open c)) (exact_check c)
+let h_exact_no_check c =
+  abstract_tactic (TacExactNoCheck (inj_open c)) (exact_no_check c)
 let h_vm_cast_no_check c = 
-  abstract_tactic (TacVmCastNoCheck c) (vm_cast_no_check c)
-let h_apply cb       = abstract_tactic (TacApply cb) (apply_with_bindings cb)
-let h_elim cb cbo    = abstract_tactic (TacElim (cb,cbo)) (elim cb cbo)
-let h_elim_type c    = abstract_tactic (TacElimType c) (elim_type c)
-let h_case cb        = abstract_tactic (TacCase cb) (general_case_analysis cb)
-let h_case_type c    = abstract_tactic (TacCaseType c) (case_type c)
+  abstract_tactic (TacVmCastNoCheck (inj_open c)) (vm_cast_no_check c)
+let h_apply simple ev cb    =
+  abstract_tactic (TacApply (simple,ev,inj_open_wb cb))
+    (apply_with_ebindings_gen simple ev cb)
+let h_elim ev cb cbo    =
+  abstract_tactic (TacElim (ev,inj_open_wb cb,Option.map inj_open_wb cbo))
+    (elim ev cb cbo)
+let h_elim_type c    = abstract_tactic (TacElimType (inj_open c)) (elim_type c)
+let h_case ev cb     = abstract_tactic (TacCase (ev,inj_open_wb cb)) (general_case_analysis ev cb)
+let h_case_type c    = abstract_tactic (TacCaseType (inj_open c)) (case_type c)
 let h_fix ido n      = abstract_tactic (TacFix (ido,n)) (fix ido n)
-let h_mutual_fix id n l =
-  abstract_tactic (TacMutualFix (id,n,l)) (mutual_fix id n l)
+let h_mutual_fix b id n l =
+  abstract_tactic
+    (TacMutualFix (b,id,n,List.map (fun (id,n,c) -> (id,n,inj_open c)) l))
+    (mutual_fix id n l)
+
 let h_cofix ido      = abstract_tactic (TacCofix ido) (cofix ido)
-let h_mutual_cofix id l =
-  abstract_tactic (TacMutualCofix (id,l)) (mutual_cofix id l)
+let h_mutual_cofix b id l =
+  abstract_tactic
+    (TacMutualCofix (b,id,List.map (fun (id,c) -> (id,inj_open c)) l)) 
+    (mutual_cofix id l)
 
-let h_cut c          = abstract_tactic (TacCut c) (cut c)
-let h_generalize cl  = abstract_tactic (TacGeneralize cl) (generalize cl)
-let h_generalize_dep c = abstract_tactic (TacGeneralizeDep c)(generalize_dep c)
-let h_let_tac na c cl =
-  abstract_tactic (TacLetTac (na,c,cl)) (letin_tac true na c cl)
+let h_cut c          = abstract_tactic (TacCut (inj_open c)) (cut c)
+let h_generalize_gen cl =
+  abstract_tactic (TacGeneralize (List.map (on_fst inj_occ) 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 (inj_open c))(generalize_dep c)
+let h_let_tac b na c cl =
+  let with_eq = if b then None else Some true in
+  abstract_tactic (TacLetTac (na,inj_open c,cl,b)) (letin_tac with_eq na c cl)
 let h_instantiate n c ido = 
 (Evar_tactics.instantiate n c ido)
   (* abstract_tactic (TacInstantiate (n,c,cls))
@@ -58,12 +82,14 @@ let h_simple_induction h =
   abstract_tactic (TacSimpleInduction h) (simple_induct h)
 let h_simple_destruct h  =
   abstract_tactic (TacSimpleDestruct h) (simple_destruct h)
-let h_new_induction c e idl =
-  abstract_tactic (TacNewInduction (c,e,idl)) (new_induct c e idl)
-let h_new_destruct c e idl =
-  abstract_tactic (TacNewDestruct (c,e,idl)) (new_destruct c e idl)
-let h_specialize n d = abstract_tactic (TacSpecialize (n,d)) (new_hyp n d)
-let h_lapply c = abstract_tactic (TacLApply c) (cut_and_apply c)
+let h_new_induction ev c e idl cl =
+  abstract_tactic (TacNewInduction (ev,List.map inj_ia c,Option.map inj_open_wb e,idl,cl))
+    (new_induct ev c e idl cl)
+let h_new_destruct ev c e idl cl =
+  abstract_tactic (TacNewDestruct (ev,List.map inj_ia c,Option.map inj_open_wb e,idl,cl))
+    (new_destruct ev c e idl cl)
+let h_specialize n d = abstract_tactic (TacSpecialize (n,inj_open_wb d)) (specialize n d)
+let h_lapply c = abstract_tactic (TacLApply (inj_open c)) (cut_and_apply c)
 
 (* Context management *)
 let h_clear b l = abstract_tactic (TacClear (b,l))
@@ -71,38 +97,41 @@ let h_clear b l = abstract_tactic (TacClear (b,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 id1 id2 =
-  abstract_tactic (TacRename (id1,id2)) (rename_hyp 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 l          = abstract_tactic (TacLeft l) (left l)
-let h_right l         = abstract_tactic (TacLeft l) (right l)
-let h_split l         = abstract_tactic (TacSplit (false,l)) (split l)
-(* Moved to tacinterp because of dependence in Tacinterp.interp
+let h_left ev l  = abstract_tactic (TacLeft (ev,l)) (left_with_ebindings ev l)
+let h_right ev l = abstract_tactic (TacLeft (ev,l)) (right_with_ebindings ev l)
+let h_split ev l = abstract_tactic (TacSplit (ev,false,l)) (split_with_ebindings 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 n l =
-  abstract_tactic (TacConstructor(AI n,l))(constructor_tac None n l)
-let h_one_constructor n = h_constructor n NoBindings
-let h_simplest_left   = h_left NoBindings
-let h_simplest_right  = h_right NoBindings
+let h_constructor ev n l =
+  abstract_tactic (TacConstructor(ev,AI n,l))(constructor_tac ev None n l)
+let h_one_constructor n = h_constructor false 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_reduce r cl  = 
+  abstract_tactic (TacReduce (inj_red_expr r,cl)) (reduce r cl)
 let h_change oc c cl =
-  abstract_tactic (TacChange (oc,c,cl))
-    (change (option_map Redexpr.out_with_occurrences oc) c cl)
+  abstract_tactic (TacChange (Option.map inj_occ oc,inj_open c,cl))
+    (change (Option.map Redexpr.out_with_occurrences oc) 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)
+  abstract_tactic (TacTransitivity (inj_open c)) (intros_transitivity c)
 
-let h_simplest_apply c  = h_apply (c,NoBindings)
-let h_simplest_elim c   = h_elim (c,NoBindings) None
-let h_simplest_case   c = h_case (c,NoBindings)
+let h_simplest_apply c  = h_apply false false (c,NoBindings)
+let h_simplest_eapply c = h_apply false true (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
index 1456601b..eed3b1da 100644
--- a/tactics/hiddentac.mli
+++ b/tactics/hiddentac.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: hiddentac.mli 9551 2007-01-29 15:13:35Z bgregoir $ i*)
+(*i $Id: hiddentac.mli 11072 2008-06-08 16:13:37Z herbelin $ i*)
 
 (*i*)
 open Names
@@ -16,6 +16,8 @@ open Tacmach
 open Genarg
 open Tacexpr
 open Rawterm
+open Evd
+open Clenv
 (*i*)
 
 (* Tactics for the interpreter. They left a trace in the proof tree
@@ -32,24 +34,28 @@ val h_exact           : constr -> tactic
 val h_exact_no_check  : constr -> tactic
 val h_vm_cast_no_check  : constr -> tactic
 
-val h_apply           : constr with_bindings -> tactic
+val h_apply           : advanced_flag -> evars_flag -> 
+                        constr with_ebindings -> tactic
 
-val h_elim            : constr with_bindings ->
-                        constr with_bindings option -> tactic
+val h_elim            : evars_flag -> constr with_ebindings ->
+                        constr with_ebindings option -> tactic
 val h_elim_type       : constr -> tactic
-val h_case            : constr with_bindings -> tactic
+val h_case            : evars_flag -> constr with_ebindings -> tactic
 val h_case_type       : constr -> tactic
 
-val h_mutual_fix      : identifier -> int ->
+val h_mutual_fix      : hidden_flag -> identifier -> int ->
                         (identifier * int * constr) list -> tactic
 val h_fix             : identifier option -> int -> tactic
-val h_mutual_cofix    : identifier -> (identifier * constr) list -> 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         : name -> constr -> Tacticals.clause -> tactic
+val h_let_tac         : letin_flag -> name -> constr -> 
+                        Tacticals.clause -> tactic
 val h_instantiate     : int -> Rawterm.rawconstr ->
   (identifier * hyp_location_flag, unit) location -> tactic
 
@@ -58,12 +64,14 @@ val h_instantiate     : int -> Rawterm.rawconstr ->
 val h_simple_induction   : quantified_hypothesis -> tactic
 val h_simple_destruct    : quantified_hypothesis -> tactic
 val h_new_induction   :
-  constr induction_arg list -> constr with_bindings option ->
-  intro_pattern_expr -> tactic
+  evars_flag -> constr with_ebindings induction_arg list ->
+    constr with_ebindings option -> intro_pattern_expr ->
+      Tacticals.clause option -> tactic
 val h_new_destruct    :
-  constr induction_arg list -> constr with_bindings option -> 
-  intro_pattern_expr -> tactic
-val h_specialize      : int option -> constr with_bindings -> tactic
+  evars_flag -> constr with_ebindings induction_arg list ->
+    constr with_ebindings option -> intro_pattern_expr ->
+      Tacticals.clause option -> tactic
+val h_specialize      : int option -> constr with_ebindings -> tactic
 val h_lapply          : constr -> tactic
 
 (* Automation tactic : see Auto *)
@@ -73,14 +81,14 @@ val h_lapply          : constr -> tactic
 val h_clear           : bool -> identifier list -> tactic
 val h_clear_body      : identifier list -> tactic
 val h_move            : bool -> identifier -> identifier -> tactic
-val h_rename          : identifier -> identifier -> tactic
-
+val h_rename          : (identifier*identifier) list -> tactic
+val h_revert          : identifier list -> tactic
 
 (* Constructors *)
-val h_constructor     : int -> constr bindings -> tactic
-val h_left            : constr bindings -> tactic
-val h_right           : constr bindings -> tactic
-val h_split           : constr bindings -> tactic
+val h_constructor     : evars_flag -> int -> open_constr bindings -> tactic
+val h_left            : evars_flag -> open_constr bindings -> tactic
+val h_right           : evars_flag -> open_constr bindings -> tactic
+val h_split           : evars_flag -> open_constr bindings -> tactic
 
 val h_one_constructor : int -> tactic
 val h_simplest_left   : tactic
@@ -98,6 +106,7 @@ val h_symmetry        : Tacticals.clause -> tactic
 val h_transitivity    : constr -> 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
 
diff --git a/tactics/inv.ml b/tactics/inv.ml
index c48a90ac..8bd10a4d 100644
--- a/tactics/inv.ml
+++ b/tactics/inv.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: inv.ml 7880 2006-01-16 13:59:08Z herbelin $ *)
+(* $Id: inv.ml 11166 2008-06-22 13:23:35Z herbelin $ *)
 
 open Pp
 open Util
@@ -47,7 +47,7 @@ let collect_meta_variables c =
 let check_no_metas clenv ccl =
   if occur_meta ccl then
     let metas = List.filter (fun na -> na<>Anonymous)
-      (List.map (Evd.meta_name clenv.env) (collect_meta_variables ccl)) in
+      (List.map (Evd.meta_name clenv.evd) (collect_meta_variables ccl)) in
     errorlabstrm "inversion" 
       (str ("Cannot find an instantiation for variable"^
 	       (if List.length metas = 1 then " " else "s ")) ++
@@ -111,12 +111,13 @@ let make_inv_predicate env sigma indf realargs id status concl =
               | None ->
 		let sort = get_sort_of env sigma concl in
 		let p = make_arity env true indf sort in
-		Unification.abstract_list_all env sigma p concl (realargs@[mkVar id]) in
+		Unification.abstract_list_all env (Evd.create_evar_defs sigma)
+		  p concl (realargs@[mkVar id]) 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 = List.length hyps 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
@@ -330,7 +331,7 @@ let projectAndApply thin id eqname names depids gls =
   substHypIfVariable
     (* If no immediate variable in the equation, try to decompose it *)
     (* and apply a trailer which again try to substitute *)
-    (fun id -> dEqThen (deq_trailer id) (Some (NamedHyp id)))
+    (fun id -> dEqThen false (deq_trailer id) (Some (ElimOnIdent (dummy_loc,id))))
     id
     gls
 
@@ -379,10 +380,14 @@ let rec get_names allow_conj = function
       error "Discarding pattern not allowed for inversion equations"
   | IntroAnonymous ->
       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 -> out_some (fst (get_names false id))) l in
+	  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"
@@ -441,20 +446,18 @@ let rewrite_equations_tac (gene, othin) id neqns names ba =
     tac
 
 
-let raw_inversion inv_kind indbinding id status names gl =
+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 t = strong_prodspine (pf_whd_betadeltaiota gl) (pf_type_of gl c) in
-  let indclause = mk_clenv_from gl (c,t) in
-  let indclause' = clenv_constrain_with_bindings indbinding indclause in
-  let newc = clenv_value indclause' in
-  let ccl = clenv_type indclause' in
-  check_no_metas indclause' ccl;
-  let IndType (indf,realargs) =
-    try find_rectype env sigma ccl
-    with Not_found ->
+  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) =
@@ -469,7 +472,7 @@ let raw_inversion inv_kind indbinding id status names gl =
      (true_cut Anonymous cut_concl)
      [case_tac names 
        (introCaseAssumsThen (rewrite_equations_tac inv_kind id neqns))
-       (Some elim_predicate) ([],[]) newc;
+       (Some elim_predicate) ([],[]) ind indclause;
       onLastHyp
         (fun id ->
            (tclTHEN
@@ -503,13 +506,13 @@ let wrap_inv_error id = function
   | UserError ("Case analysis",s) -> errorlabstrm "Inv needs Nodep Prop Set" s
   | UserError("mind_specif_of_mind",_)  -> not_inductive_here id
   | UserError (a,b)  -> errorlabstrm "Inv" b
-  | Invalid_argument (*"it_list2"*) "List.fold_left2" -> dep_prop_prop_message id
+  | Invalid_argument "List.fold_left2" -> dep_prop_prop_message id
   | Not_found  ->  errorlabstrm "Inv" (not_found_message [id]) 
   | e -> raise e
 
 (* The most general inversion tactic *)
 let inversion inv_kind status names id gls =
-  try (raw_inversion inv_kind [] id status names) gls
+  try (raw_inversion inv_kind id status names) gls
   with e -> wrap_inv_error id e
 
 (* Specializing it... *)
diff --git a/tactics/leminv.ml b/tactics/leminv.ml
index 9507ce5f..70e8c375 100644
--- a/tactics/leminv.ml
+++ b/tactics/leminv.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: leminv.ml 9154 2006-09-20 17:18:18Z corbinea $ *)
+(* $Id: leminv.ml 10348 2007-12-06 17:36:14Z aspiwack $ *)
 
 open Pp
 open Util
@@ -249,7 +249,7 @@ let add_inversion_lemma name env sigma t sort dep inv_op =
        { const_entry_body = invProof;
          const_entry_type = None;
          const_entry_opaque = false;
-	 const_entry_boxed = true && (Options.boxed_definitions())}, 
+	 const_entry_boxed = true && (Flags.boxed_definitions())}, 
      IsProof Lemma)
   in ()
 
@@ -292,7 +292,7 @@ let add_inversion_lemma_exn na com comsort bool tac =
 let lemInv id c gls =
   try
     let clause = mk_clenv_type_of gls c in
-    let clause = clenv_constrain_with_bindings [(-1,mkVar id)] clause in
+    let clause = clenv_constrain_last_binding (mkVar id) clause in
     Clenvtac.res_pf clause ~allow_K:true gls
   with 
     |  UserError (a,b) -> 
diff --git a/tactics/nbtermdn.ml b/tactics/nbtermdn.ml
index 554ce2e9..d9d0a799 100644
--- a/tactics/nbtermdn.ml
+++ b/tactics/nbtermdn.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: nbtermdn.ml 8752 2006-04-27 19:37:33Z herbelin $ *)
+(* $Id: nbtermdn.ml 10346 2007-12-05 21:11:19Z aspiwack $ *)
 
 open Util
 open Names
@@ -43,14 +43,14 @@ let get_dn dnm hkey =
   try Gmap.find hkey dnm with Not_found -> Btermdn.create ()
 
 let add dn (na,(pat,valu)) =
-  let hkey = option_map fst (Termdn.constr_pat_discr pat) in 
+  let hkey = Option.map fst (Termdn.constr_pat_discr pat) in 
   dn.table <- Gmap.add na (pat,valu) dn.table;
   let dnm = dn.patterns in
   dn.patterns <- Gmap.add hkey (Btermdn.add (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 (Termdn.constr_pat_discr pat) in 
+  let hkey = Option.map fst (Termdn.constr_pat_discr pat) in 
   dn.table <- Gmap.remove na dn.table;
   let dnm = dn.patterns in
   dn.patterns <- Gmap.add hkey (Btermdn.rmv (get_dn dnm hkey) (pat,valu)) dnm
@@ -62,7 +62,7 @@ let remap ndn na (pat,valu) =
   add ndn (na,(pat,valu))
 
 let lookup dn valu =
-  let hkey = option_map fst (Termdn.constr_val_discr valu) in 
+  let hkey = Option.map fst (Termdn.constr_val_discr valu) in 
   try Btermdn.lookup (Gmap.find hkey  dn.patterns) valu with Not_found -> []
 
 let app f dn = Gmap.iter f dn.table
diff --git a/tactics/refine.ml b/tactics/refine.ml
index 5b162729..84e9dccc 100644
--- a/tactics/refine.ml
+++ b/tactics/refine.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: refine.ml 9364 2006-11-11 11:59:42Z herbelin $ *)
+(* $Id: refine.ml 9841 2007-05-19 21:13:42Z herbelin $ *)
 
 (* JCF -- 6 janvier 1998  EXPERIMENTAL *)
 
@@ -125,7 +125,7 @@ let replace_in_array keep_length env sigma a =
   v',mm,sgp
     
 let fresh env n =
-  let id = match n with Name x -> x | _ -> id_of_string "_" in
+  let id = match n with Name x -> x | _ -> id_of_string "_H" in
   next_global_ident_away true id (ids_of_named_context (named_context env))
 
 let rec compute_metamap env sigma c = match kind_of_term c with
@@ -158,17 +158,22 @@ let rec compute_metamap env sigma c = match kind_of_term c with
       end
 
   | LetIn (name, c1, t1, c2) ->
-      if occur_meta c1 then 
-	error "Refine: body of let-in cannot contain existentials";
       let v = fresh env name in
+      let th1 = compute_metamap env sigma c1 in
       let env' = push_named (v,Some c1,t1) env in
-      begin match compute_metamap env' sigma (subst1 (mkVar v) c2) with
+      let th2 = compute_metamap env' sigma (subst1 (mkVar v) c2) in
+      begin match th1,th2 with
 	(* terme de preuve complet *)
-	| TH (_,_,[]) -> TH (c,[],[])
+	| TH (_,_,[]), TH (_,_,[]) -> TH (c,[],[])
 	(* terme de preuve incomplet *)    
-	| th ->
-	    let m,mm,sgp = replace_by_meta env' sigma th in
-	    TH (mkLetIn (Name v,c1,t1,m), mm, sgp)
+	| 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 *)
@@ -267,7 +272,8 @@ let rec tcc_aux subst (TH (c,mm,sgp) as _th) gl =
 	refine c gl
 	
     (* abstraction => intro *)
-    | Lambda (Name id,_,m), _ when isMeta (strip_outer_cast m) ->
+    | Lambda (Name id,_,m), _ ->
+	assert (isMeta (strip_outer_cast m));
 	begin match sgp with
 	  | [None] -> introduction id gl
 	  | [Some th] ->
@@ -275,12 +281,23 @@ let rec tcc_aux subst (TH (c,mm,sgp) as _th) gl =
                 (onLastHyp (fun id -> tcc_aux (mkVar id::subst) th)) gl
 	  | _ -> assert false
 	end
-	
-    | Lambda _, _ ->
-	anomaly "invalid lambda passed to function tcc_aux"
 
-    (* let in *)
-    | LetIn (Name id,c1,t1,c2), _ when isMeta (strip_outer_cast c2) ->
+    | Lambda (Anonymous,_,m), _ -> (* if anon vars are allowed in evars *)
+        assert (isMeta (strip_outer_cast m));
+	begin match sgp with
+	  | [None] -> tclTHEN intro (onLastHyp (fun id -> clear [id])) gl
+	  | [Some th] ->
+              tclTHEN
+                intro
+                (onLastHyp (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 
@@ -293,8 +310,21 @@ let rec tcc_aux subst (TH (c,mm,sgp) as _th) gl =
 	     | _ -> assert false) 
 	  gl
 
-    | LetIn _, _ ->
-	anomaly "invalid let-in passed to function tcc_aux"
+    (* 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 true (Name id) t1) 
+	  [(match List.hd sgp with 
+	     | None -> tclIDTAC
+	     | Some th -> onLastHyp (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 *)
+                 onLastHyp (fun id -> tcc_aux (mkVar id::subst) th)
+             | _ -> assert false)]
+          gl
 
     (* fix => tactique Fix *)
     | Fix ((ni,_),(fi,ai,_)) , _ ->
diff --git a/tactics/setoid_replace.ml b/tactics/setoid_replace.ml
index 9c23dda5..95d56f11 100644
--- a/tactics/setoid_replace.ml
+++ b/tactics/setoid_replace.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: setoid_replace.ml 10213 2007-10-10 13:05:59Z letouzey $ *)
+(* $Id: setoid_replace.ml 11094 2008-06-10 19:35:23Z herbelin $ *)
 
 open Tacmach
 open Proof_type
@@ -85,7 +85,7 @@ type morphism_class =
 let subst_mps_in_relation_class subst =
  function
     Relation  t -> Relation  (subst_mps subst t)
-  | Leibniz t -> Leibniz (option_map (subst_mps subst) t) 
+  | Leibniz t -> Leibniz (Option.map (subst_mps subst) t) 
 
 let subst_mps_in_argument_class subst (variance,rel) =
  variance, subst_mps_in_relation_class subst rel
@@ -108,7 +108,9 @@ let current_constant id =
   try
     global_reference id
   with Not_found ->
-    anomaly ("Setoid: cannot find " ^ (string_of_id id))
+    anomalylabstrm ""
+      (str "Setoid: cannot find " ++ pr_id id ++
+       str "(if loading Setoid.v under coqtop, use option \"-top Coq.Setoids.Setoid_tac\")")
 
 (* From Setoid.v *)
 
@@ -121,69 +123,69 @@ let coq_transitive =
 let coq_relation =
  lazy(gen_constant ["Relations"; "Relation_Definitions"] "relation")
 
-let coq_Relation_Class = lazy(constant ["Setoid"] "Relation_Class")
-let coq_Argument_Class = lazy(constant ["Setoid"] "Argument_Class")
+let coq_Relation_Class = lazy(constant ["Setoid_tac"] "Relation_Class")
+let coq_Argument_Class = lazy(constant ["Setoid_tac"] "Argument_Class")
 let coq_Setoid_Theory = lazy(constant ["Setoid"] "Setoid_Theory")
-let coq_Morphism_Theory = lazy(constant ["Setoid"] "Morphism_Theory")
-let coq_Build_Morphism_Theory= lazy(constant ["Setoid"] "Build_Morphism_Theory")
-let coq_Compat = lazy(constant ["Setoid"] "Compat")
+let coq_Morphism_Theory = lazy(constant ["Setoid_tac"] "Morphism_Theory")
+let coq_Build_Morphism_Theory= lazy(constant ["Setoid_tac"] "Build_Morphism_Theory")
+let coq_Compat = lazy(constant ["Setoid_tac"] "Compat")
 
-let coq_AsymmetricReflexive = lazy(constant ["Setoid"] "AsymmetricReflexive")
-let coq_SymmetricReflexive = lazy(constant ["Setoid"] "SymmetricReflexive")
-let coq_SymmetricAreflexive = lazy(constant ["Setoid"] "SymmetricAreflexive")
-let coq_AsymmetricAreflexive = lazy(constant ["Setoid"] "AsymmetricAreflexive")
-let coq_Leibniz = lazy(constant ["Setoid"] "Leibniz")
+let coq_AsymmetricReflexive = lazy(constant ["Setoid_tac"] "AsymmetricReflexive")
+let coq_SymmetricReflexive = lazy(constant ["Setoid_tac"] "SymmetricReflexive")
+let coq_SymmetricAreflexive = lazy(constant ["Setoid_tac"] "SymmetricAreflexive")
+let coq_AsymmetricAreflexive = lazy(constant ["Setoid_tac"] "AsymmetricAreflexive")
+let coq_Leibniz = lazy(constant ["Setoid_tac"] "Leibniz")
 
-let coq_RAsymmetric = lazy(constant ["Setoid"] "RAsymmetric")
-let coq_RSymmetric = lazy(constant ["Setoid"] "RSymmetric")
-let coq_RLeibniz = lazy(constant ["Setoid"] "RLeibniz")
+let coq_RAsymmetric = lazy(constant ["Setoid_tac"] "RAsymmetric")
+let coq_RSymmetric = lazy(constant ["Setoid_tac"] "RSymmetric")
+let coq_RLeibniz = lazy(constant ["Setoid_tac"] "RLeibniz")
 
-let coq_ASymmetric = lazy(constant ["Setoid"] "ASymmetric")
-let coq_AAsymmetric = lazy(constant ["Setoid"] "AAsymmetric")
+let coq_ASymmetric = lazy(constant ["Setoid_tac"] "ASymmetric")
+let coq_AAsymmetric = lazy(constant ["Setoid_tac"] "AAsymmetric")
 
 let coq_seq_refl = lazy(constant ["Setoid"] "Seq_refl")
 let coq_seq_sym = lazy(constant ["Setoid"] "Seq_sym")
 let coq_seq_trans = lazy(constant ["Setoid"] "Seq_trans")
 
-let coq_variance = lazy(constant ["Setoid"] "variance")
-let coq_Covariant = lazy(constant ["Setoid"] "Covariant")
-let coq_Contravariant = lazy(constant ["Setoid"] "Contravariant")
-let coq_Left2Right = lazy(constant ["Setoid"] "Left2Right")
-let coq_Right2Left = lazy(constant ["Setoid"] "Right2Left")
-let coq_MSNone = lazy(constant ["Setoid"] "MSNone")
-let coq_MSCovariant = lazy(constant ["Setoid"] "MSCovariant")
-let coq_MSContravariant = lazy(constant ["Setoid"] "MSContravariant")
+let coq_variance = lazy(constant ["Setoid_tac"] "variance")
+let coq_Covariant = lazy(constant ["Setoid_tac"] "Covariant")
+let coq_Contravariant = lazy(constant ["Setoid_tac"] "Contravariant")
+let coq_Left2Right = lazy(constant ["Setoid_tac"] "Left2Right")
+let coq_Right2Left = lazy(constant ["Setoid_tac"] "Right2Left")
+let coq_MSNone = lazy(constant ["Setoid_tac"] "MSNone")
+let coq_MSCovariant = lazy(constant ["Setoid_tac"] "MSCovariant")
+let coq_MSContravariant = lazy(constant ["Setoid_tac"] "MSContravariant")
 
-let coq_singl = lazy(constant ["Setoid"] "singl")
-let coq_cons = lazy(constant ["Setoid"] "necons")
+let coq_singl = lazy(constant ["Setoid_tac"] "singl")
+let coq_cons = lazy(constant ["Setoid_tac"] "necons")
 
 let coq_equality_morphism_of_asymmetric_areflexive_transitive_relation =
- lazy(constant ["Setoid"]
+ lazy(constant ["Setoid_tac"]
   "equality_morphism_of_asymmetric_areflexive_transitive_relation")
 let coq_equality_morphism_of_symmetric_areflexive_transitive_relation =
- lazy(constant ["Setoid"]
+ lazy(constant ["Setoid_tac"]
   "equality_morphism_of_symmetric_areflexive_transitive_relation")
 let coq_equality_morphism_of_asymmetric_reflexive_transitive_relation =
- lazy(constant ["Setoid"]
+ lazy(constant ["Setoid_tac"]
   "equality_morphism_of_asymmetric_reflexive_transitive_relation")
 let coq_equality_morphism_of_symmetric_reflexive_transitive_relation =
- lazy(constant ["Setoid"]
+ lazy(constant ["Setoid_tac"]
   "equality_morphism_of_symmetric_reflexive_transitive_relation")
 let coq_make_compatibility_goal =
- lazy(constant ["Setoid"] "make_compatibility_goal")
+ lazy(constant ["Setoid_tac"] "make_compatibility_goal")
 let coq_make_compatibility_goal_eval_ref =
- lazy(eval_reference ["Setoid"] "make_compatibility_goal")
+ lazy(eval_reference ["Setoid_tac"] "make_compatibility_goal")
 let coq_make_compatibility_goal_aux_eval_ref =
- lazy(eval_reference ["Setoid"] "make_compatibility_goal_aux")
+ lazy(eval_reference ["Setoid_tac"] "make_compatibility_goal_aux")
 
-let coq_App = lazy(constant ["Setoid"] "App")
-let coq_ToReplace = lazy(constant ["Setoid"] "ToReplace")
-let coq_ToKeep = lazy(constant ["Setoid"] "ToKeep")
-let coq_ProperElementToKeep = lazy(constant ["Setoid"] "ProperElementToKeep")
-let coq_fcl_singl = lazy(constant ["Setoid"] "fcl_singl")
-let coq_fcl_cons = lazy(constant ["Setoid"] "fcl_cons")
+let coq_App = lazy(constant ["Setoid_tac"] "App")
+let coq_ToReplace = lazy(constant ["Setoid_tac"] "ToReplace")
+let coq_ToKeep = lazy(constant ["Setoid_tac"] "ToKeep")
+let coq_ProperElementToKeep = lazy(constant ["Setoid_tac"] "ProperElementToKeep")
+let coq_fcl_singl = lazy(constant ["Setoid_tac"] "fcl_singl")
+let coq_fcl_cons = lazy(constant ["Setoid_tac"] "fcl_cons")
 
-let coq_setoid_rewrite = lazy(constant ["Setoid"] "setoid_rewrite")
+let coq_setoid_rewrite = lazy(constant ["Setoid_tac"] "setoid_rewrite")
 let coq_proj1 = lazy(gen_constant ["Init"; "Logic"] "proj1")
 let coq_proj2 = lazy(gen_constant ["Init"; "Logic"] "proj2")
 let coq_unit = lazy(gen_constant ["Init"; "Datatypes"] "unit")
@@ -191,24 +193,26 @@ let coq_tt = lazy(gen_constant ["Init"; "Datatypes"] "tt")
 let coq_eq = lazy(gen_constant ["Init"; "Logic"] "eq")
 
 let coq_morphism_theory_of_function =
- lazy(constant ["Setoid"] "morphism_theory_of_function")
+ lazy(constant ["Setoid_tac"] "morphism_theory_of_function")
 let coq_morphism_theory_of_predicate =
- lazy(constant ["Setoid"] "morphism_theory_of_predicate")
+ lazy(constant ["Setoid_tac"] "morphism_theory_of_predicate")
 let coq_relation_of_relation_class =
- lazy(eval_reference ["Setoid"] "relation_of_relation_class")
+ lazy(eval_reference ["Setoid_tac"] "relation_of_relation_class")
 let coq_directed_relation_of_relation_class =
- lazy(eval_reference ["Setoid"] "directed_relation_of_relation_class")
-let coq_interp = lazy(eval_reference ["Setoid"] "interp")
+ lazy(eval_reference ["Setoid_tac"] "directed_relation_of_relation_class")
+let coq_interp = lazy(eval_reference ["Setoid_tac"] "interp")
 let coq_Morphism_Context_rect2 =
- lazy(eval_reference ["Setoid"] "Morphism_Context_rect2")
+ lazy(eval_reference ["Setoid_tac"] "Morphism_Context_rect2")
 let coq_iff = lazy(gen_constant ["Init";"Logic"] "iff")
-let coq_impl = lazy(constant ["Setoid"] "impl")
+let coq_impl = lazy(constant ["Setoid_tac"] "impl")
 
 
 (************************* Table of declared relations **********************)
 
 
-(* Relations are stored in a table which is synchronised with the Reset mechanism. *)
+(* Relations are stored in a table which is synchronised with the
+   Reset mechanism. The table maps the term denoting the relation to
+   the data of type relation that characterises the relation *)
 
 let relation_table = ref Gmap.empty
 
@@ -257,8 +261,8 @@ let default_relation_for_carrier ?(filter=fun _ -> true) a =
     [] -> Leibniz (Some a)
   | relation::tl ->
      if tl <> [] then
-      ppnl
-       (str "Warning: There are several relations on the carrier \"" ++
+      Flags.if_warn msg_warning
+       (str "There are several relations on the carrier \"" ++
          pr_lconstr a ++ str "\". The relation " ++ prrelation relation ++
          str " is chosen.") ;
      Relation relation
@@ -295,9 +299,9 @@ let relation_morphism_of_constr_morphism =
 let subst_relation subst relation = 
   let rel_a' = subst_mps subst relation.rel_a in
   let rel_aeq' = subst_mps subst relation.rel_aeq in
-  let rel_refl' = option_map (subst_mps subst) relation.rel_refl in
-  let rel_sym' = option_map (subst_mps subst) relation.rel_sym in
-  let rel_trans' = option_map (subst_mps subst) relation.rel_trans in
+  let rel_refl' = Option.map (subst_mps subst) relation.rel_refl in
+  let rel_sym' = Option.map (subst_mps subst) relation.rel_sym in
+  let rel_trans' = Option.map (subst_mps subst) relation.rel_trans in
   let rel_X_relation_class' = subst_mps subst relation.rel_X_relation_class in
   let rel_Xreflexive_relation_class' =
    subst_mps subst relation.rel_Xreflexive_relation_class
@@ -345,29 +349,29 @@ let (relation_to_obj, obj_to_relation)=
           match th.rel_sym with
              None -> old_relation.rel_sym
            | Some t -> Some t} in
-        ppnl
-         (str "Warning: The relation " ++ prrelation th' ++
-          str " is redeclared. The new declaration" ++
+        Flags.if_warn msg_warning 
+         (strbrk "The relation " ++ prrelation th' ++
+          strbrk " is redeclared. The new declaration" ++
            (match th'.rel_refl with
-              None -> str ""
-            | Some t -> str " (reflevity proved by " ++ pr_lconstr t) ++
+              None -> mt ()
+            | Some t -> strbrk " (reflexivity proved by " ++ pr_lconstr t) ++
            (match th'.rel_sym with
-               None -> str ""
+               None -> mt ()
              | Some t ->
-                (if th'.rel_refl = None then str " (" else str " and ") ++
-                str "symmetry proved by " ++ pr_lconstr t) ++
+                (if th'.rel_refl = None then strbrk " (" else strbrk " and ")
+		++ strbrk "symmetry proved by " ++ pr_lconstr t) ++
            (if th'.rel_refl <> None && th'.rel_sym <> None then
              str ")" else str "") ++
-           str " replaces the old declaration" ++
+           strbrk " replaces the old declaration" ++
            (match old_relation.rel_refl with
               None -> str ""
-            | Some t -> str " (reflevity proved by " ++ pr_lconstr t) ++
+            | Some t -> strbrk " (reflexivity proved by " ++ pr_lconstr t) ++
            (match old_relation.rel_sym with
                None -> str ""
              | Some t ->
                 (if old_relation.rel_refl = None then
-                  str " (" else str " and ") ++
-                str "symmetry proved by " ++ pr_lconstr t) ++
+                  strbrk " (" else strbrk " and ") ++
+                strbrk "symmetry proved by " ++ pr_lconstr t) ++
            (if old_relation.rel_refl <> None && old_relation.rel_sym <> None
             then str ")" else str "") ++
            str ".");
@@ -410,12 +414,12 @@ let morphism_table_add (m,c) =
     List.find
      (function mor -> mor.args = c.args && mor.output = c.output) old
    in
-    ppnl
-     (str "Warning: The morphism " ++ prmorphism m old_morph ++
-      str " is redeclared. " ++
-      str "The new declaration whose compatibility is proved by " ++
-       pr_lconstr c.lem ++ str " replaces the old declaration whose" ++
-       str " compatibility was proved by " ++
+    Flags.if_warn msg_warning
+     (strbrk "The morphism " ++ prmorphism m old_morph ++
+      strbrk " is redeclared. " ++
+      strbrk "The new declaration whose compatibility is proved by " ++
+       pr_lconstr c.lem ++ strbrk " replaces the old declaration whose" ++
+       strbrk " compatibility was proved by " ++
        pr_lconstr old_morph.lem ++ str ".")
   with
    Not_found -> morphism_table := Gmap.add m (c::old) !morphism_table
@@ -425,10 +429,10 @@ let default_morphism ?(filter=fun _ -> true) m =
       [] -> raise Not_found
     | m1::ml ->
         if ml <> [] then
-          ppnl
-            (str "Warning: There are several morphisms associated to \"" ++
-            pr_lconstr m ++ str"\". Morphism " ++ prmorphism m m1 ++
-            str " is randomly chosen.");
+          Flags.if_warn msg_warning
+            (strbrk "There are several morphisms associated to \"" ++
+            pr_lconstr m ++ strbrk "\". Morphism " ++ prmorphism m m1 ++
+            strbrk " is randomly chosen.");
         relation_morphism_of_constr_morphism m1
 
 let subst_morph subst morph = 
@@ -638,9 +642,9 @@ let apply_to_relation subst rel =
    assert (new_quantifiers_no >= 0) ;
    { rel_a = mkApp (rel.rel_a, subst) ;
      rel_aeq = mkApp (rel.rel_aeq, subst) ;
-     rel_refl = option_map (fun c -> mkApp (c,subst)) rel.rel_refl ; 
-     rel_sym = option_map (fun c -> mkApp (c,subst)) rel.rel_sym;
-     rel_trans = option_map (fun c -> mkApp (c,subst)) rel.rel_trans;
+     rel_refl = Option.map (fun c -> mkApp (c,subst)) rel.rel_refl ; 
+     rel_sym = Option.map (fun c -> mkApp (c,subst)) rel.rel_sym;
+     rel_trans = Option.map (fun c -> mkApp (c,subst)) rel.rel_trans;
      rel_quantifiers_no = new_quantifiers_no;
      rel_X_relation_class = mkApp (rel.rel_X_relation_class, subst);
      rel_Xreflexive_relation_class =
@@ -687,7 +691,7 @@ let add_morphism lemma_infos mor_name (m,quantifiers_rev,args,output) =
                   apply_to_rels mext quantifiers_rev |]));
           const_entry_type = None;
           const_entry_opaque = false;
-          const_entry_boxed = Options.boxed_definitions()},
+          const_entry_boxed = Flags.boxed_definitions()},
 	IsDefinition Definition)) ;
      mext 
  in
@@ -703,17 +707,18 @@ let add_morphism lemma_infos mor_name (m,quantifiers_rev,args,output) =
         output = output_constr;
         lem = lem;
         morphism_theory = mmor }));
-   Options.if_verbose ppnl (pr_lconstr m ++ str " is registered as a morphism")   
+   Flags.if_verbose ppnl (pr_lconstr m ++ str " is registered as a morphism")
+
+let error_cannot_unify_signature env k t t' =
+  errorlabstrm "New Morphism"
+   (str "One morphism argument or its output has type" ++ spc() ++
+    pr_lconstr_env env t ++ strbrk " but the signature requires an argument" ++
+    (if k = 0 then strbrk " of type " else
+    strbrk "whose type is an instance of ") ++ pr_lconstr_env env t' ++
+    str ".")
 
 (* first order matching with a bit of conversion *)
 let unify_relation_carrier_with_type env rel t =
- let raise_error quantifiers_no =
-  errorlabstrm "New Morphism"
-   (str "One morphism argument or its output has type " ++ 
-    pr_lconstr_env env t ++
-    str " but the signature requires an argument of type \"" ++
-    pr_lconstr_env env rel.rel_a ++ prvect_with_sep mt (fun _ -> str " ?")
-     (Array.make quantifiers_no 0) ++ str "\"") in
  let args =
   match kind_of_term t with
      App (he',args') ->
@@ -723,31 +728,15 @@ let unify_relation_carrier_with_type env rel t =
        if is_conv env Evd.empty rel.rel_a (mkApp (he',args1)) then
         args2
        else
-        raise_error rel.rel_quantifiers_no
+	error_cannot_unify_signature env rel.rel_quantifiers_no t rel.rel_a
    | _  ->
-     if rel.rel_quantifiers_no = 0 && is_conv env Evd.empty rel.rel_a t then
-      [||] 
-     else
-      begin
-        let evars,args,instantiated_rel_a =
-         let ty = Typing.type_of env Evd.empty rel.rel_a in
-         let evd = Evd.create_evar_defs Evd.empty in
-         let evars,args,concl =
-          Clenv.clenv_environments_evars env evd
-           (Some rel.rel_quantifiers_no) ty
-         in
-          evars, args,
-          nf_betaiota
-           (match args with [] -> rel.rel_a | _ -> applist (rel.rel_a,args))
-        in
-         let evars' =
-          w_unify true (*??? or false? *) env Reduction.CONV (*??? or cumul? *)
-           ~mod_delta:true (*??? or true? *) t instantiated_rel_a evars in
-         let args' =
-          List.map (Reductionops.nf_evar (Evd.evars_of evars')) args
-         in
-          Array.of_list args'
-      end
+       try
+       let args =
+         Clenv.clenv_conv_leq env Evd.empty t rel.rel_a rel.rel_quantifiers_no
+       in
+       Array.of_list args
+       with Reduction.NotConvertible -> 
+	error_cannot_unify_signature env rel.rel_quantifiers_no t rel.rel_a
  in
   apply_to_relation args rel
 
@@ -757,11 +746,7 @@ let unify_relation_class_carrier_with_type env rel t =
      if is_conv env Evd.empty t t' then
       rel
      else
-      errorlabstrm "New Morphism"
-       (str "One morphism argument or its output has type " ++ 
-        pr_lconstr_env env t ++
-        str " but the signature requires an argument of type " ++
-        pr_lconstr_env env t')
+      error_cannot_unify_signature env 0 t t'
   | Leibniz None -> Leibniz (Some t)
   | Relation rel -> Relation (unify_relation_carrier_with_type env rel t)
 
@@ -863,7 +848,7 @@ let new_morphism m signature id hook =
 	    if number_of_quantifiers < 0 then
               errorlabstrm "New Morphism"
 		(str "The morphism " ++ pr_lconstr m ++ str " has type " ++
-		    pr_lconstr typeofm ++ str " that attends at most " ++ int args_ty_len ++
+		    pr_lconstr typeofm ++ str " that expects at most " ++ int args_ty_len ++
 		    str " arguments. The signature that you specified requires " ++
 		    int number_of_arguments ++ str " arguments.")
 	    else
@@ -922,12 +907,12 @@ let new_morphism m signature id hook =
       (Closure.unfold_red(Lazy.force coq_make_compatibility_goal_aux_eval_ref))
       env Evd.empty lem in
     (* "simpl" *)
-  let lem = Tacred.nf env Evd.empty lem in
+  let lem = Tacred.simpl env Evd.empty lem in
     if Lib.is_modtype () then
       begin
 	ignore
 	  (Declare.declare_internal_constant id
-              (ParameterEntry lem, IsAssumption Logical)) ;
+              (ParameterEntry (lem,false), IsAssumption Logical)) ;
 	let mor_name = morphism_theory_id_of_morphism_proof_id id in
 	let lemma_infos = Some (id,argsconstr,outputconstr) in
 	  add_morphism lemma_infos mor_name
@@ -938,9 +923,9 @@ let new_morphism m signature id hook =
 	new_edited id
 	  (m,args_ty_quantifiers_rev,args,argsconstr,output,outputconstr);
 	Pfedit.start_proof id (Global, Proof Lemma) 
-	  (Declare.clear_proofs (Global.named_context ()))
+	  (Decls.clear_proofs (Global.named_context ()))
 	  lem hook;
-	Options.if_verbose msg (Printer.pr_open_subgoals ());
+	Flags.if_verbose msg (Printer.pr_open_subgoals ());
       end
 
 let morphism_hook _ ref =
@@ -960,6 +945,7 @@ type morphism_signature =
  (bool option * Topconstr.constr_expr) list * Topconstr.constr_expr
 
 let new_named_morphism id m sign =
+  Coqlib.check_required_library ["Coq";"Setoids";"Setoid_tac"];
  let sign =
   match sign with
      None -> None
@@ -1028,9 +1014,9 @@ let int_add_relation id a aeq refl sym trans =
  let env = Global.env () in
  let a_quantifiers_rev = check_a env a in
   check_eq env a_quantifiers_rev a aeq  ;
-  option_iter (check_refl env a_quantifiers_rev a aeq) refl ;
-  option_iter (check_sym env a_quantifiers_rev a aeq) sym ;
-  option_iter (check_trans env a_quantifiers_rev a aeq) trans ;
+  Option.iter (check_refl env a_quantifiers_rev a aeq) refl ;
+  Option.iter (check_sym env a_quantifiers_rev a aeq) sym ;
+  Option.iter (check_trans env a_quantifiers_rev a aeq) trans ;
   let quantifiers_no = List.length a_quantifiers_rev in
   let aeq_rel =
    { rel_a = a;
@@ -1059,7 +1045,7 @@ let int_add_relation id a aeq refl sym trans =
             a_quantifiers_rev);
        const_entry_type = None;
        const_entry_opaque = false;
-       const_entry_boxed = Options.boxed_definitions()},
+       const_entry_boxed = Flags.boxed_definitions()},
       IsDefinition Definition) in
   let id_precise = id_of_string (string_of_id id ^ "_precise_relation_class") in
   let xreflexive_relation_class =
@@ -1076,14 +1062,14 @@ let int_add_relation id a aeq refl sym trans =
         Sign.it_mkLambda_or_LetIn xreflexive_relation_class a_quantifiers_rev;
        const_entry_type = None;
        const_entry_opaque = false;
-       const_entry_boxed = Options.boxed_definitions() },
+       const_entry_boxed = Flags.boxed_definitions() },
       IsDefinition Definition) in
   let aeq_rel =
    { aeq_rel with
       rel_X_relation_class = current_constant id;
       rel_Xreflexive_relation_class = current_constant id_precise } in
   Lib.add_anonymous_leaf (relation_to_obj (aeq, aeq_rel)) ;
-  Options.if_verbose ppnl (pr_lconstr aeq ++ str " is registered as a relation");
+  Flags.if_verbose ppnl (pr_lconstr aeq ++ str " is registered as a relation");
   match trans with
      None -> ()
    | Some trans ->
@@ -1091,9 +1077,9 @@ let int_add_relation id a aeq refl sym trans =
       let a_instance = apply_to_rels a a_quantifiers_rev in
       let aeq_instance = apply_to_rels aeq a_quantifiers_rev in
       let sym_instance =
-       option_map (fun x -> apply_to_rels x a_quantifiers_rev) sym in
+       Option.map (fun x -> apply_to_rels x a_quantifiers_rev) sym in
       let refl_instance =
-       option_map (fun x -> apply_to_rels x a_quantifiers_rev) refl in
+       Option.map (fun x -> apply_to_rels x a_quantifiers_rev) refl in
       let trans_instance = apply_to_rels trans a_quantifiers_rev in
       let aeq_rel_class_and_var1, aeq_rel_class_and_var2, lemma, output =
        match sym_instance, refl_instance with
@@ -1136,7 +1122,7 @@ let int_add_relation id a aeq refl sym trans =
           {const_entry_body = Sign.it_mkLambda_or_LetIn lemma a_quantifiers_rev;
            const_entry_type = None;
            const_entry_opaque = false;
-          const_entry_boxed = Options.boxed_definitions()},
+          const_entry_boxed = Flags.boxed_definitions()},
           IsDefinition Definition)
       in
        let a_quantifiers_rev =
@@ -1147,21 +1133,23 @@ let int_add_relation id a aeq refl sym trans =
 
 (* The vernac command "Add Relation ..." *)
 let add_relation id a aeq refl sym trans =
- int_add_relation id (constr_of a) (constr_of aeq) (option_map constr_of refl)
-  (option_map constr_of sym) (option_map constr_of trans)
+  Coqlib.check_required_library ["Coq";"Setoids";"Setoid_tac"];
+  int_add_relation id (constr_of a) (constr_of aeq) (Option.map constr_of refl)
+    (Option.map constr_of sym) (Option.map constr_of trans)
 
 (************************ Add Setoid ******************************************)
 
 (* The vernac command "Add Setoid" *)
 let add_setoid id a aeq th =
- let a = constr_of a in
- let aeq = constr_of aeq in
- let th = constr_of th in
- let env = Global.env () in
- let a_quantifiers_rev = check_a env a in
+  Coqlib.check_required_library ["Coq";"Setoids";"Setoid_tac"];
+  let a = constr_of a in
+  let aeq = constr_of aeq in
+  let th = constr_of th in
+  let env = Global.env () in
+  let a_quantifiers_rev = check_a env a in
   check_eq env a_quantifiers_rev a aeq  ;
   check_setoid_theory env a_quantifiers_rev a aeq  th ;
-   let a_instance = apply_to_rels a a_quantifiers_rev in
+  let a_instance = apply_to_rels a a_quantifiers_rev in
    let aeq_instance = apply_to_rels aeq a_quantifiers_rev in
    let th_instance = apply_to_rels th a_quantifiers_rev in
    let refl =
@@ -1478,12 +1466,9 @@ let mark_occur gl ~new_goals t in_c input_relation input_direction =
                           (MApp (func,mor,a,output_direction)))
 			  output_directions @ res
                     ) [] a'
-              | (he::tl) as a->
+              | (he::tl) ->
                  let typnf = Reduction.whd_betadeltaiota env typ in
                   match kind_of_term typnf with
-                    Cast (typ,_,_) ->
-                     find_non_dependent_function env c c_args_rev typ
-                      f_args_rev a_rev a
                   | Prod (name,s,t) ->
                      let env' = push_rel (name,None,s) env in
                      let he =
@@ -1578,12 +1563,12 @@ let mark_occur gl ~new_goals t in_c input_relation input_direction =
   match res' with
      [] when res = [] ->
       errorlabstrm "Setoid_rewrite"
-       (str "Either the term " ++ pr_lconstr t ++ str " that must be " ++
-        str "rewritten occurs in a covariant position or the goal is not " ++
-        str "made of morphism applications only. You can replace only " ++
-        str "occurrences that are in a contravariant position and such that " ++
-        str "the context obtained by abstracting them is made of morphism " ++
-        str "applications only.")
+       (strbrk "Either the term " ++ pr_lconstr t ++ strbrk " that must be " ++
+        strbrk "rewritten occurs in a covariant position or the goal is not" ++
+        strbrk " made of morphism applications only. You can replace only " ++
+        strbrk "occurrences that are in a contravariant position and such " ++
+        strbrk "that the context obtained by abstracting them is made of " ++
+        strbrk "morphism applications only.")
    | [] ->
       errorlabstrm "Setoid_rewrite"
        (str "No generated set of side conditions is a superset of those " ++
@@ -1594,16 +1579,16 @@ let mark_occur gl ~new_goals t in_c input_relation input_direction =
           (fun i (_,_,mc) -> pr_new_goals i mc) res)
    | [he] -> he
    | he::_ ->
-      ppnl
-       (str "Warning: The application of the tactic is subject to one of " ++
-        str "the \nfollowing set of side conditions that the user needs " ++
-        str "to prove:" ++
+      Flags.if_warn msg_warning
+       (strbrk "The application of the tactic is subject to one of " ++
+        strbrk "the following set of side conditions that the user needs " ++
+        strbrk "to prove:" ++
          pr_fnl () ++
          prlist_with_sepi pr_fnl
           (fun i (_,_,mc) -> pr_new_goals i mc) res' ++ pr_fnl () ++
-         str "The first set is randomly chosen. Use the syntax " ++
-         str "\"setoid_rewrite ... generate side conditions ...\" to choose " ++
-         str "a different set.") ;
+         strbrk "The first set is randomly chosen. Use the syntax " ++
+         strbrk "\"setoid_rewrite ... generate side conditions ...\" to choose " ++
+         strbrk "a different set.") ;
       he
 
 let cic_morphism_context_list_of_list hole_relation hole_direction out_direction
@@ -1727,14 +1712,14 @@ let check_evar_map_of_evars_defs evd =
   Evd.Metaset.iter
    (fun m ->
      if Evd.meta_defined evd m then () else
-      raise (Logic.RefinerError (Logic.OccurMetaGoal rebus)))
+      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.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
@@ -1746,20 +1731,33 @@ let check_evar_map_of_evars_defs evd =
 (* [unification_rewrite] searchs a match for [c1] in [but] and then 
    returns the modified objects (in particular [c1] and [c2]) *)  
 
+let rewrite_unif_flags = {
+  modulo_conv_on_closed_terms = None;
+  use_metas_eagerly = true;
+  modulo_delta = empty_transparent_state;
+}
+
+let rewrite2_unif_flags = {
+  modulo_conv_on_closed_terms = Some full_transparent_state;
+  use_metas_eagerly = true;
+  modulo_delta = empty_transparent_state;
+}
+
 let unification_rewrite c1 c2 cl but gl = 
   let (env',c1) =
     try
-      (* ~mod_delta:false to allow to mark occurences that must not be
+      (* ~flags:(false,true) to allow to mark occurences that must not be
          rewritten simply by replacing them with let-defined definitions
          in the context *)
-      w_unify_to_subterm ~mod_delta:false (pf_env gl) (c1,but) cl.env
+      w_unify_to_subterm ~flags:rewrite_unif_flags (pf_env gl) (c1,but) cl.evd
     with
 	Pretype_errors.PretypeError _ ->
-	  (* ~mod_delta:true to make Ring work (since it really
+	  (* ~flags:(true,true) to make Ring work (since it really
              exploits conversion) *)
-	  w_unify_to_subterm ~mod_delta:true (pf_env gl) (c1,but) cl.env
+	  w_unify_to_subterm ~flags:rewrite2_unif_flags
+	    (pf_env gl) (c1,but) cl.evd
   in
-  let cl' = {cl with env = env' } in
+  let cl' = {cl with evd = env' } in
   let c2 = Clenv.clenv_nf_meta cl' c2 in
   check_evar_map_of_evars_defs env' ;
   env',Clenv.clenv_value cl', c1, c2
@@ -1808,7 +1806,7 @@ let relation_rewrite_no_unif c1 c2 hyp ~new_goals sigma gl =
      if_output_relation_is_if gl
   with
     Optimize ->
-      !general_rewrite (fst hyp = Left2Right) (snd hyp) gl
+      !general_rewrite (fst hyp = Left2Right) all_occurrences (snd hyp) gl
 
 let relation_rewrite c1 c2 (input_direction,cl) ~new_goals gl =
  let (sigma,cl,c1,c2) = unification_rewrite c1 c2 cl (pf_concl gl) gl in 
@@ -1826,7 +1824,9 @@ let analyse_hypothesis gl c =
  let others,(c1,c2) = split_last_two args in
   eqclause,mkApp (equiv, Array.of_list others),c1,c2
 
-let general_s_rewrite lft2rgt c ~new_goals gl =
+let general_s_rewrite lft2rgt occs c ~new_goals gl =
+  if occs <> all_occurrences then
+    warning "Rewriting at selected occurrences not supported";
   let eqclause,_,c1,c2 = analyse_hypothesis gl c in
   if lft2rgt then 
     relation_rewrite c1 c2 (Left2Right,eqclause) ~new_goals gl
@@ -1863,7 +1863,9 @@ let relation_rewrite_in id c1 c2 (direction,eqclause) ~new_goals gl =
             (relation_rewrite_no_unif c2 c1 (oppdir,cl) ~new_goals sigma))))
    gl
 
-let general_s_rewrite_in id lft2rgt c ~new_goals gl =
+let general_s_rewrite_in id lft2rgt occs c ~new_goals gl =
+  if occs <> all_occurrences then
+    warning "Rewriting at selected occurrences not supported";
   let eqclause,_,c1,c2 = analyse_hypothesis gl c in
   if lft2rgt then 
     relation_rewrite_in id c1 c2 (Left2Right,eqclause) ~new_goals gl
@@ -1918,7 +1920,7 @@ let general_setoid_replace rewrite_tac try_prove_eq_tac_opt relation c1 c2 ~new_
       tclTHENS (assert_tac false Anonymous eq)
 	[onLastHyp (fun id ->
           tclTHEN
-            (rewrite_tac dir (mkVar id) ~new_goals)
+            (rewrite_tac dir all_occurrences (mkVar id) ~new_goals)
             (clear [id]));
 	 try_prove_eq_tac]
     in
@@ -1930,7 +1932,7 @@ let general_setoid_replace rewrite_tac try_prove_eq_tac_opt relation c1 c2 ~new_
 	  tclTHENS (assert_tac false Anonymous eq)
 	    [onLastHyp (fun id ->
 	      tclTHEN
-		(rewrite_tac false (mkVar id) ~new_goals)
+		(rewrite_tac false all_occurrences (mkVar id) ~new_goals)
 		(clear [id]));
 	     try_prove_eq_tac] gl
       
@@ -2019,7 +2021,3 @@ let setoid_transitivity c gl =
   Optimize -> transitivity_red true c gl
 ;;
 
-Tactics.register_setoid_reflexivity setoid_reflexivity;;
-Tactics.register_setoid_symmetry setoid_symmetry;;
-Tactics.register_setoid_symmetry_in setoid_symmetry_in;;
-Tactics.register_setoid_transitivity setoid_transitivity;;
diff --git a/tactics/setoid_replace.mli b/tactics/setoid_replace.mli
index eb71f68e..6d736a0a 100644
--- a/tactics/setoid_replace.mli
+++ b/tactics/setoid_replace.mli
@@ -6,12 +6,13 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: setoid_replace.mli 9073 2006-08-22 08:54:29Z jforest $ i*)
+(*i $Id: setoid_replace.mli 11094 2008-06-10 19:35:23Z herbelin $ i*)
 
 open Term
 open Proof_type
 open Topconstr
 open Names
+open Termops
 
 type relation =
    { rel_a: constr ;
@@ -40,7 +41,7 @@ type morphism_signature = (bool option * constr_expr) list * constr_expr
 val pr_morphism_signature : morphism_signature -> Pp.std_ppcmds
 
 val register_replace : (tactic option -> constr -> constr -> tactic) -> unit
-val register_general_rewrite : (bool -> constr -> tactic) -> unit
+val register_general_rewrite : (bool -> occurrences -> constr -> tactic) -> unit
 
 val print_setoids : unit -> unit
 
@@ -58,9 +59,10 @@ val setoid_replace_in :
  identifier -> constr option -> constr -> constr -> new_goals:constr list ->
   tactic
 
-val general_s_rewrite : bool -> constr -> new_goals:constr list -> tactic
+val general_s_rewrite :
+  bool -> occurrences -> constr -> new_goals:constr list -> tactic
 val general_s_rewrite_in :
- identifier -> bool -> constr -> new_goals:constr list -> tactic
+  identifier -> bool -> occurrences -> constr -> new_goals:constr list -> tactic
 
 val setoid_reflexivity : tactic
 val setoid_symmetry : tactic
@@ -79,3 +81,5 @@ val new_named_morphism :
 
 val relation_table_find : constr -> relation
 val relation_table_mem : constr -> bool
+
+val prrelation : relation -> Pp.std_ppcmds
diff --git a/tactics/tacinterp.ml b/tactics/tacinterp.ml
index 37b3cbcb..f4547930 100644
--- a/tactics/tacinterp.ml
+++ b/tactics/tacinterp.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: tacinterp.ml 10135 2007-09-21 14:28:12Z herbelin $ *)
+(* $Id: tacinterp.ml 11166 2008-06-22 13:23:35Z herbelin $ *)
 
 open Constrintern
 open Closure
@@ -59,6 +59,8 @@ let error_syntactic_metavariables_not_allowed loc =
     (loc,"out_ident",
      str "Syntactic metavariables allowed only in quotations")
 
+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
@@ -82,7 +84,7 @@ type value =
   | VConstr of constr   (* includes idents known to be bound and references *)
   | VConstr_context of constr
   | VList of value list
-  | VRec of value ref
+  | VRec of (identifier*value) list ref * glob_tactic_expr
 
 let locate_tactic_call loc = function
   | VTactic (_,t) -> VTactic (loc,t)
@@ -101,8 +103,11 @@ let catch_error loc tac g =
 
 (* Signature for interpretation: val_interp and interpretation functions *)
 type interp_sign =
-  { lfun : (identifier * value) list;
-    debug : debug_info }
+    { lfun : (identifier * value) list;
+      avoid_ids : identifier list; (* ids inherited from the call context
+				      (needed to get fresh ids) *)
+      debug : debug_info;
+      last_loc : loc }
 
 let check_is_value = function
   | VRTactic _ -> (* These are goals produced by Match *)
@@ -199,7 +204,7 @@ let add_primitive_tactic s tac =
   atomic_mactab := Idmap.add id tac !atomic_mactab
 
 let _ =
-  let nocl = {onhyps=Some[];onconcl=true; concl_occs=[]} in
+  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);
@@ -212,10 +217,14 @@ let _ =
         "cofix", TacCofix None;
         "trivial", TacTrivial ([],None);
         "auto", TacAuto(None,[],None);
-        "left", TacLeft NoBindings;
-        "right", TacRight NoBindings;
-        "split", TacSplit(false,NoBindings);
-        "constructor", TacAnyConstructor 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
       ];
@@ -227,10 +236,9 @@ let _ =
       ]
  
 let lookup_atomic id = Idmap.find id !atomic_mactab
-let is_atomic id = Idmap.mem id !atomic_mactab
 let is_atomic_kn kn =
   let (_,_,l) = repr_kn kn in
-  is_atomic (id_of_label l)
+  Idmap.mem (id_of_label l) !atomic_mactab
 
 (* Summary and Object declaration *)
 let mactab = ref Gmap.empty
@@ -288,7 +296,7 @@ type glob_sign = {
 type interp_genarg_type =
   (glob_sign -> raw_generic_argument -> glob_generic_argument) *
   (interp_sign -> goal sigma -> glob_generic_argument -> 
-    closed_generic_argument) *
+    typed_generic_argument) *
   (substitution -> glob_generic_argument -> glob_generic_argument)
 
 let extragenargtab =
@@ -305,7 +313,6 @@ let lookup_genarg_subst  id = let (_,_,f) = lookup_genarg id in f
 
 (* Dynamically check that an argument is a tactic, possibly unboxing VRec *)
 let coerce_to_tactic loc id = function
-  | VRec v -> !v
   | VTactic _ | VFun _ | VRTactic _ as a -> a
   | _ -> user_err_loc 
   (loc, "", str "variable " ++  pr_id id ++ str " should be bound to a tactic")
@@ -373,52 +380,105 @@ let intern_or_var ist = function
   | ArgVar locid -> ArgVar (intern_hyp ist locid)
   | ArgArg _ as x -> x
 
+let loc_of_by_notation f = function
+  | AN c -> f c
+  | ByNotation (loc,s) -> loc
+
+let destIndRef = function IndRef ind -> ind | _ -> failwith "destIndRef"
+
+let intern_inductive_or_by_notation = function
+  | AN r -> Nametab.inductive_of_reference r
+  | ByNotation (loc,ntn) ->
+      destIndRef (Notation.interp_notation_as_global_reference loc
+        (function IndRef ind -> true | _ -> false) ntn)
+
 let intern_inductive ist = function
-  | Ident (loc,id) when find_var id ist -> ArgVar (loc,id)
-  | r -> ArgArg (Nametab.global_inductive r)
+  | 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,qid = qualid_of_reference r in
-      try ArgArg (loc,locate_global qid)
-      with _ -> 
-	error_global_not_found_loc loc qid
+      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_tac_ref ist = function
-  | Ident (loc,id) when find_ltacvar id ist -> ArgVar (loc,id)
+let intern_ltac_variable ist = function
   | Ident (loc,id) ->
-      ArgArg (loc,
-         try find_recvar id ist 
-         with Not_found -> locate_tactic (make_short_qualid id))
-  | r -> 
-      let (loc,qid) = qualid_of_reference r in
-      ArgArg (loc,locate_tactic qid)
-
-let intern_tactic_reference ist r =
-  try intern_tac_ref ist r
-  with Not_found -> 
-    let (loc,qid) = qualid_of_reference r in
-    error_global_not_found_loc loc qid
+      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) when (not strict & find_hyp id ist) or find_ctxvar id ist ->
       RVar (dloc,id), None
   | r ->
-      let loc,qid = qualid_of_reference r in
-      RRef (loc,locate_global qid), if strict then None else Some (CRef r)
-
-let intern_reference strict ist r =
-  (try Reference (intern_tac_ref ist r)
-   with Not_found ->
-     (try ConstrMayEval (ConstrTerm (intern_constr_reference strict ist r))
-      with Not_found ->
-        (match r with
-          | Ident (loc,id) when is_atomic id -> Tacexp (lookup_atomic id)
-          | Ident (loc,id) when not strict -> IntroPattern (IntroIdentifier id)
-          | _ ->
-              let (loc,qid) = qualid_of_reference r in
-              error_global_not_found_loc loc qid)))
+      let loc,_ as lqid = qualid_of_reference r in
+      RRef (loc,locate_global_with_alias lqid), if strict then None else Some (CRef r)
+
+(* 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
+
+let intern_isolated_tactic_reference 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 true 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 (_,id) when not strict -> IntroPattern (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
@@ -431,7 +491,7 @@ let rec intern_intro_pattern lf ist = function
       IntroOrAndPattern (intern_case_intro_pattern lf ist l)
   | IntroIdentifier id ->
       IntroIdentifier (intern_ident lf ist id)
-  | IntroWildcard | IntroAnonymous as x -> x
+  | IntroWildcard | IntroAnonymous | IntroFresh _ | IntroRewrite _ as x -> x
 
 and intern_case_intro_pattern lf ist =
   List.map (List.map (intern_intro_pattern lf ist))
@@ -478,53 +538,64 @@ let intern_clause_pattern ist (l,occl) =
 
   (* TODO: catch ltac vars *)
 let intern_induction_arg ist = function
-  | ElimOnConstr c -> ElimOnConstr (intern_constr ist c)
+  | 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 *)
-	ElimOnConstr (intern_constr ist (CRef (Ident (dloc,id))))
+	ElimOnConstr (intern_constr ist (CRef (Ident (dloc,id))),NoBindings)
       else
 	ElimOnIdent (loc,id)
 
+let evaluable_of_global_reference = function
+  | ConstRef c -> EvalConstRef c
+  | VarRef c -> EvalVarRef c
+  | r -> error_not_evaluable (pr_global r)
+
+let short_name = function
+  | AN (Ident (loc,id)) when not !strict_check -> Some (loc,id)
+  | _ -> None
+
+let interp_global_reference r =
+  let lqid = qualid_of_reference r in
+  try locate_global_with_alias lqid
+  with Not_found ->
+  match r with 
+  | Ident (loc,id) when not !strict_check -> VarRef id
+  | _ -> error_global_not_found_loc lqid
+
+let intern_evaluable_reference_or_by_notation = function
+  | AN r -> evaluable_of_global_reference (interp_global_reference r)
+  | ByNotation (loc,ntn) ->
+      evaluable_of_global_reference
+      (Notation.interp_notation_as_global_reference loc
+        (function ConstRef _ | VarRef _ -> true | _ -> false) ntn)
+
 (* Globalizes a reduction expression *)
 let intern_evaluable ist = function
-  | Ident (loc,id) when find_ltacvar id ist -> ArgVar (loc,id)
-  | Ident (_,id) when
+  | AN (Ident (loc,id)) when find_ltacvar id ist -> ArgVar (loc,id)
+  | AN (Ident (_,id)) when
       (not !strict_check & find_hyp id ist) or find_ctxvar id ist ->
       ArgArg (EvalVarRef id, None)
   | r ->
-      let loc,qid = qualid_of_reference r in
-      try
-	let e = match locate_global qid with
-	  | ConstRef c -> EvalConstRef c
-	  | VarRef c -> EvalVarRef c
-	  | _ -> error_not_evaluable (pr_reference r) in
-        let short_name = match r with
-	  | Ident (loc,id) when not !strict_check -> Some (loc,id)
-	  | _ -> None in
-        ArgArg (e,short_name)
-      with
-	| Not_found ->
-	match r with 
-	  | Ident (loc,id) when not !strict_check ->
-	      ArgArg (EvalVarRef id, Some (loc,id))
-	  | _ -> error_global_not_found_loc loc qid
+      let e = intern_evaluable_reference_or_by_notation 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_occurrence ist (l,c) = (l,intern_constr ist c)
+let intern_constr_with_occurrences ist (l,c) = (l,intern_constr ist c)
 
 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_occurrence ist) l)
-  | Simpl o -> Simpl (option_map (intern_constr_occurrence ist) o)
+  | Pattern l -> Pattern (List.map (intern_constr_with_occurrences ist) l)
+  | Simpl o -> Simpl (Option.map (intern_constr_with_occurrences ist) o)
   | (Red _ | Hnf | ExtraRedExpr _ | CbvVm as r ) -> r
   
 
@@ -533,27 +604,27 @@ let intern_inversion_strength lf ist = function
       NonDepInversion (k,List.map (intern_hyp_or_metaid ist) idl,
       intern_intro_pattern lf ist ids)
   | DepInversion (k,copt,ids) ->
-      DepInversion (k, option_map (intern_constr ist) copt,
+      DepInversion (k, Option.map (intern_constr ist) copt,
       intern_intro_pattern lf ist ids)
   | InversionUsing (c,idl) ->
       InversionUsing (intern_constr ist c, List.map (intern_hyp_or_metaid ist) idl)
 
 (* Interprets an hypothesis name *)
-let intern_hyp_location ist ((occs,id),hl) =
-  ((List.map (intern_or_var ist) occs,intern_hyp ist (skip_metaid id)), hl)
+let intern_hyp_location ist (((b,occs),id),hl) =
+  (((b,List.map (intern_or_var ist) occs),intern_hyp ist (skip_metaid id)), hl)
 
-let interp_constrpattern_gen sigma env ltacvar c =
-  let c = intern_gen false ~allow_soapp:true ~ltacvars:(ltacvar,[])
+let interp_constrpattern_gen sigma env ?(as_type=false) ltacvar c =
+  let c = intern_gen as_type ~allow_patvar:true ~ltacvars:(ltacvar,[])
                      sigma env c in
   pattern_of_rawconstr c
 
 (* Reads a pattern *)
-let intern_pattern sigma env lfun = function
+let intern_pattern sigma env ?(as_type=false) lfun = function
   | Subterm (ido,pc) ->
       let (metas,pat) = interp_constrpattern_gen sigma env lfun pc in
       ido, metas, Subterm (ido,pat)
   | Term pc ->
-      let (metas,pat) = interp_constrpattern_gen sigma env lfun pc  in
+      let (metas,pat) = interp_constrpattern_gen sigma env ~as_type lfun pc  in
       None, metas, Term pat
 
 let intern_constr_may_eval ist = function
@@ -584,30 +655,16 @@ let extern_request ch req gl la =
 (* Reads the hypotheses of a Match Context rule *)
 let rec intern_match_context_hyps sigma env lfun = function
   | (Hyp ((_,na) as locna,mp))::tl ->
-      let ido, metas1, pat = intern_pattern sigma env lfun mp in
+      let ido, metas1, pat = intern_pattern sigma env ~as_type:true lfun mp in
       let lfun, metas2, hyps = intern_match_context_hyps sigma env lfun tl in
-      let lfun' = name_cons na (option_cons ido lfun) in
+      let lfun' = name_cons na (Option.List.cons ido lfun) in
       lfun', metas1@metas2, Hyp (locna,pat)::hyps
   | [] -> lfun, [], []
 
 (* Utilities *)
-let rec filter_some = function
-  | None :: l -> filter_some l
-  | Some a :: l -> a :: filter_some l
-  | [] -> []
-
-let extract_names lrc =
-  List.fold_right 
-    (fun ((loc,name),_) l ->
-      if List.mem name l then
-	user_err_loc
-	  (loc, "intern_tactic", str "This variable is bound several times");
-      name::l)
-    lrc []
-
 let extract_let_names lrc =
   List.fold_right 
-    (fun ((loc,name),_,_) l ->
+    (fun ((loc,name),_) l ->
       if List.mem name l then
 	user_err_loc
 	  (loc, "glob_tactic", str "This variable is bound several times");
@@ -615,10 +672,10 @@ let extract_let_names lrc =
     lrc []
 
 let clause_app f = function
-    { onhyps=None; onconcl=b;concl_occs=nl } ->
-      { onhyps=None; onconcl=b; concl_occs=nl }
-  | { onhyps=Some l; onconcl=b;concl_occs=nl } ->
-      { onhyps=Some(List.map f l); onconcl=b;concl_occs=nl}
+    { 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 =
@@ -628,70 +685,70 @@ let rec intern_atomic lf ist x =
       TacIntroPattern (List.map (intern_intro_pattern lf ist) l)
   | TacIntrosUntil hyp -> TacIntrosUntil (intern_quantified_hypothesis ist hyp)
   | TacIntroMove (ido,ido') ->
-      TacIntroMove (option_map (intern_ident lf ist) ido,
-          option_map (intern_hyp ist) ido')
+      TacIntroMove (Option.map (intern_ident lf ist) ido,
+          Option.map (intern_hyp ist) ido')
   | TacAssumption -> TacAssumption
   | TacExact c -> TacExact (intern_constr ist c)
   | TacExactNoCheck c -> TacExactNoCheck (intern_constr ist c)
   | TacVmCastNoCheck c -> TacVmCastNoCheck (intern_constr ist c)
-  | TacApply cb -> TacApply (intern_constr_with_bindings ist cb)
-  | TacElim (cb,cbo) ->
-      TacElim (intern_constr_with_bindings ist cb,
-               option_map (intern_constr_with_bindings ist) cbo)
+  | TacApply (a,ev,cb) -> TacApply (a,ev,intern_constr_with_bindings ist cb)
+  | 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 cb -> TacCase (intern_constr_with_bindings ist cb)
+  | 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 (id,n,l) ->
+  | 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 (intern_ident lf ist id, n, List.map f l)
-  | TacCofix idopt -> TacCofix (option_map (intern_ident lf ist) idopt)
-  | TacMutualCofix (id,l) ->
+      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 (intern_ident lf ist id, List.map f l)
+      TacMutualCofix (b,intern_ident lf ist id, List.map f l)
   | TacCut c -> TacCut (intern_type ist c)
   | TacAssert (otac,ipat,c) ->
-      TacAssert (option_map (intern_tactic ist) otac,
+      TacAssert (Option.map (intern_tactic ist) otac,
                  intern_intro_pattern lf ist ipat,
                  intern_constr_gen (otac<>None) ist c)
-  | TacGeneralize cl -> TacGeneralize (List.map (intern_constr ist) cl)
+  | 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) ->
+  | TacLetTac (na,c,cls,b) ->
       let na = intern_name lf ist na in
       TacLetTac (na,intern_constr ist c,
-                 (clause_app (intern_hyp_location ist) cls))
-(*  | TacInstantiate (n,c,idh) -> 
-      TacInstantiate (n,intern_constr ist c,
-		      (match idh with
-			   ConclLocation () -> ConclLocation ()
-			 | HypLocation (id,hloc) -> 
-			      HypLocation(intern_hyp_or_metaid ist id,hloc))) 
-*)
+                 (clause_app (intern_hyp_location ist) cls),b)
 
   (* Automation tactics *)
   | TacTrivial (lems,l) -> TacTrivial (List.map (intern_constr ist) lems,l)
   | TacAuto (n,lems,l) ->
-      TacAuto (option_map (intern_or_var ist) n,
+      TacAuto (Option.map (intern_or_var ist) n,
         List.map (intern_constr ist) lems,l)
   | TacAutoTDB n -> TacAutoTDB n
   | TacDestructHyp (b,id) -> TacDestructHyp(b,intern_hyp ist id)
   | TacDestructConcl -> TacDestructConcl
   | TacSuperAuto (n,l,b1,b2) -> TacSuperAuto (n,l,b1,b2)
-  | TacDAuto (n,p) -> TacDAuto (option_map (intern_or_var ist) n,p)
+  | TacDAuto (n,p,lems) ->
+      TacDAuto (Option.map (intern_or_var ist) n,p,
+        List.map (intern_constr ist) lems)
 
   (* Derived basic tactics *)
   | TacSimpleInduction h ->
       TacSimpleInduction (intern_quantified_hypothesis ist h)
-  | TacNewInduction (lc,cbo,ids) ->
-      TacNewInduction (List.map (intern_induction_arg ist) lc,
-               option_map (intern_constr_with_bindings ist) cbo,
-               (intern_intro_pattern lf ist ids))
+  | TacNewInduction (ev,lc,cbo,ids,cls) ->
+      TacNewInduction (ev,List.map (intern_induction_arg ist) lc,
+               Option.map (intern_constr_with_bindings ist) cbo,
+               intern_intro_pattern lf ist ids,
+               Option.map (clause_app (intern_hyp_location ist)) cls)
   | TacSimpleDestruct h ->
       TacSimpleDestruct (intern_quantified_hypothesis ist h)
-  | TacNewDestruct (c,cbo,ids) ->
-      TacNewDestruct (List.map (intern_induction_arg ist) c,
-               option_map (intern_constr_with_bindings ist) cbo,
-	       (intern_intro_pattern lf ist ids))
+  | TacNewDestruct (ev,c,cbo,ids,cls) ->
+      TacNewDestruct (ev,List.map (intern_induction_arg ist) c,
+               Option.map (intern_constr_with_bindings ist) cbo,
+	       intern_intro_pattern lf ist ids,
+               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
@@ -708,21 +765,28 @@ let rec intern_atomic lf ist x =
   | TacClearBody l -> TacClearBody (List.map (intern_hyp_or_metaid ist) l)
   | TacMove (dep,id1,id2) ->
     TacMove (dep,intern_hyp_or_metaid ist id1,intern_hyp_or_metaid ist id2)
-  | TacRename (id1,id2) -> TacRename (intern_hyp_or_metaid ist id1, intern_hyp_or_metaid 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 bl -> TacLeft (intern_bindings ist bl)
-  | TacRight bl -> TacRight (intern_bindings ist bl)
-  | TacSplit (b,bl) -> TacSplit (b,intern_bindings ist bl)
-  | TacAnyConstructor t -> TacAnyConstructor (option_map (intern_tactic ist) t)
-  | TacConstructor (n,bl) -> TacConstructor (n, intern_bindings ist bl)
+  | TacLeft (ev,bl) -> TacLeft (ev,intern_bindings ist bl)
+  | TacRight (ev,bl) -> TacRight (ev,intern_bindings ist bl)
+  | TacSplit (ev,b,bl) -> TacSplit (ev,b,intern_bindings ist bl)
+  | TacAnyConstructor (ev,t) -> TacAnyConstructor (ev,Option.map (intern_tactic ist) t)
+  | TacConstructor (ev,n,bl) -> TacConstructor (ev,n,intern_bindings ist bl)
 
   (* Conversion *)
   | TacReduce (r,cl) ->
       TacReduce (intern_red_expr ist r, clause_app (intern_hyp_location ist) cl)
   | TacChange (occl,c,cl) ->
-      TacChange (option_map (intern_constr_occurrence ist) occl,
-        (if occl = None then intern_type ist c else intern_constr ist c),
+      TacChange (Option.map (intern_constr_with_occurrences ist) occl,
+        (if occl = None & (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)
 
   (* Equivalence relations *)
@@ -732,9 +796,12 @@ let rec intern_atomic lf ist x =
   | TacTransitivity c -> TacTransitivity (intern_constr ist c)
 
   (* Equality and inversion *)
-  | TacRewrite (b,c,cl) -> 
-      TacRewrite (b,intern_constr_with_bindings ist c,
-		  clause_app (intern_hyp_location ist) cl)
+  | 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_tactic ist) by)
   | TacInversion (inv,hyp) ->
       TacInversion (intern_inversion_strength lf ist inv,
         intern_quantified_hypothesis ist hyp)
@@ -756,19 +823,12 @@ and intern_tactic_seq ist = function
       let t = intern_atomic lf ist t in
       !lf, TacAtom (adjust_loc loc, t)
   | TacFun tacfun -> ist.ltacvars, TacFun (intern_tactic_fun ist tacfun)
-  | TacLetRecIn (lrc,u) ->
-      let names = extract_names lrc in
+  | TacLetIn (isrec,l,u) ->
       let (l1,l2) = ist.ltacvars in
-      let ist = { ist with ltacvars = (names@l1,l2) } in
-      let lrc = List.map (fun (n,b) -> (n,intern_tactic_fun ist b)) lrc in
-      ist.ltacvars, TacLetRecIn (lrc,intern_tactic ist u)
-  | TacLetIn (l,u) ->
-      let l = List.map
-        (fun (n,c,b) ->
-          (n,option_map (intern_tactic ist) c, intern_tacarg !strict_check ist b)) l in
-      let (l1,l2) = ist.ltacvars in
-      let ist' = { ist with ltacvars = ((extract_let_names l)@l1,l2) } in
-      ist.ltacvars, TacLetIn (l,intern_tactic ist' u)
+      let ist' = { ist with ltacvars = (extract_let_names l @ l1, l2) } in
+      let l = List.map (fun (n,b) -> 
+	  (n,intern_tacarg !strict_check (if isrec then ist' else ist) b)) l in
+      ist.ltacvars, TacLetIn (isrec,l,intern_tactic ist' u)
   | TacMatchContext (lz,lr,lmr) ->
       ist.ltacvars, TacMatchContext(lz,lr, intern_match_rule ist lmr)
   | TacMatch (lz,c,lmr) ->
@@ -778,15 +838,21 @@ and intern_tactic_seq ist = function
       ist.ltacvars, TacFail (intern_or_var ist n,intern_message ist l)
   | TacProgress tac -> ist.ltacvars, TacProgress (intern_tactic ist tac)
   | TacAbstract (tac,s) -> ist.ltacvars, TacAbstract (intern_tactic ist tac,s)
-  | TacThen (t1,t2) ->
+  | TacThen (t1,[||],t2,[||]) ->
       let lfun', t1 = intern_tactic_seq ist t1 in
       let lfun'', t2 = intern_tactic_seq { ist with ltacvars = lfun' } t2 in
-      lfun'', TacThen (t1,t2)
+      lfun'', TacThen (t1,[||],t2,[||])
+  | TacThen (t1,tf,t2,tl) ->
+      let lfun', t1 = intern_tactic_seq ist t1 in
+      let ist' = { ist with ltacvars = lfun' } in
+      (* Que faire en cas de (tac complexe avec Match et Thens; tac2) ?? *)
+      lfun', TacThen (t1,Array.map (intern_tactic ist') tf,intern_tactic ist' t2,
+		       Array.map (intern_tactic ist') tl)
   | TacThens (t,tl) ->
       let lfun', t = intern_tactic_seq ist t in
+      let ist' = { ist with ltacvars = lfun' } in
       (* Que faire en cas de (tac complexe avec Match et Thens; tac2) ?? *)
-      lfun',
-      TacThens (t, List.map (intern_tactic { ist with ltacvars = lfun' }) tl)
+      lfun', TacThens (t, List.map (intern_tactic ist') tl)
   | TacDo (n,tac) -> 
       ist.ltacvars, TacDo (intern_or_var ist n,intern_tactic ist tac)
   | TacTry tac -> ist.ltacvars, TacTry (intern_tactic ist tac)
@@ -801,25 +867,28 @@ and intern_tactic_seq ist = function
 
 and intern_tactic_fun ist (var,body) = 
   let (l1,l2) = ist.ltacvars in
-  let lfun' = List.rev_append (filter_some var) l1 in
+  let lfun' = List.rev_append (Option.List.flatten var) l1 in
   (var,intern_tactic { ist with ltacvars = (lfun',l2) } body)
 
 and intern_tacarg strict ist = function
   | TacVoid -> TacVoid
-  | Reference r -> intern_reference strict ist r
+  | 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,s) ->
+  | MetaIdArg (loc,istac,s) ->
       (* $id can occur in Grammar tactic... *)
       let id = id_of_string s in
-      if find_ltacvar id ist then Reference (ArgVar (adjust_loc loc,id))
+      if find_ltacvar id ist then
+	if istac then Reference (ArgVar (adjust_loc loc,id))
+	else ConstrMayEval (ConstrTerm (RVar (adjust_loc loc,id), None))
       else error_syntactic_metavariables_not_allowed loc
+  | TacCall (loc,f,[]) -> intern_isolated_tactic_reference ist f
   | TacCall (loc,f,l) ->
       TacCall (loc,
-        intern_tactic_reference ist f,
+        intern_applied_tactic_reference ist f,
         List.map (intern_tacarg !strict_check ist) l)
   | TacExternal (loc,com,req,la) -> 
       TacExternal (loc,com,req,List.map (intern_tacarg !strict_check ist) la)
@@ -840,7 +909,7 @@ and intern_match_rule ist = function
       let lfun',metas1,hyps = intern_match_context_hyps sigma env lfun rl in
       let ido,metas2,pat = intern_pattern sigma env lfun mp in
       let metas = list_uniquize (metas1@metas2) in
-      let ist' = { ist with ltacvars = (metas@(option_cons ido lfun'),l2) } in
+      let ist' = { ist with ltacvars = (metas@(Option.List.cons ido lfun'),l2) } in
       Pat (hyps,pat,intern_tactic ist' tc) :: (intern_match_rule ist tl)
   | [] -> []
 
@@ -1026,10 +1095,23 @@ let set_debug pos = debug := pos
 (* Gives the state of debug *)
 let get_debug () = !debug
 
+let debugging_step ist pp =
+  match ist.debug with
+  | DebugOn lev ->
+      safe_msgnl (str "Level " ++ int lev ++ str": " ++ pp () ++ fnl())
+  | _ -> ()
+
+let debugging_exception_step ist signal_anomaly e pp =
+  let explain_exc =
+    if signal_anomaly then explain_logic_error
+    else explain_logic_error_no_anomaly in
+  debugging_step ist (fun () -> 
+    pp() ++ spc() ++ str "raised the exception" ++ fnl() ++ !explain_exc e)
+
 let error_ltac_variable loc id env v s =
    user_err_loc (loc, "", str "Ltac variable " ++ pr_id id ++ 
    str " is bound to" ++ spc () ++ pr_value env v ++ spc () ++ 
-   str "which cannot be coerced to " ++ str s)
+   strbrk "which cannot be coerced to " ++ str s)
 
 exception CannotCoerceTo of string
 
@@ -1043,22 +1125,25 @@ let interp_ltac_var coerce ist env locid =
   with Not_found -> anomaly "Detected as ltac var at interning time"
 
 (* Interprets an identifier which must be fresh *)
-let coerce_to_ident env = function
+let coerce_to_ident fresh env = function
   | VIntroPattern (IntroIdentifier id) -> id
-  | VConstr c when isVar c & not (is_variable env (destVar c)) ->
-      (* This happens e.g. in definitions like "Tac H = clear H; intro H" *)
+  | 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 ist gl id =
+let interp_ident_gen fresh ist gl id =
   let env = pf_env gl in
-  try try_interp_ltac_var (coerce_to_ident env) ist (Some env) (dloc,id)
+  try try_interp_ltac_var (coerce_to_ident fresh env) ist (Some env) (dloc,id)
   with Not_found -> id
 
+let interp_ident = interp_ident_gen false 
+let interp_fresh_ident = interp_ident_gen true
+
 (* Interprets an optional identifier which must be fresh *)
-let interp_name ist gl = function
+let interp_fresh_name ist gl = function
   | Anonymous -> Anonymous
-  | Name id -> Name (interp_ident ist gl id)
+  | Name id -> Name (interp_fresh_ident ist gl id)
 
 let coerce_to_intro_pattern env = function
   | VIntroPattern ipat -> ipat
@@ -1086,7 +1171,8 @@ let coerce_to_int = function
 
 let interp_int ist locid =
   try try_interp_ltac_var coerce_to_int ist None locid
-  with Not_found -> user_err_loc(fst locid,"interp_int",str "Unbound variable")
+  with Not_found -> user_err_loc(fst locid,"interp_int",
+				str "Unbound variable"  ++ pr_id (snd locid))
 
 let interp_int_or_var ist = function
   | ArgVar locid -> interp_int ist locid
@@ -1196,13 +1282,15 @@ let interp_evaluable ist env = function
       interp_ltac_var (coerce_to_evaluable_ref env) ist (Some env) locid
 
 (* Interprets an hypothesis name *)
+let interp_occurrences ist (b,occs) =
+  (b,interp_int_or_var_list ist occs)
+
 let interp_hyp_location ist gl ((occs,id),hl) =
-  ((interp_int_or_var_list ist occs,interp_hyp ist gl id),hl)
+  ((interp_occurrences ist occs,interp_hyp ist gl id),hl)
 
-let interp_clause ist gl { onhyps=ol; onconcl=b; concl_occs=occs } =
-  { onhyps=option_map(List.map (interp_hyp_location ist gl)) ol;
-    onconcl=b;
-    concl_occs=interp_int_or_var_list ist occs }
+let interp_clause ist gl { onhyps=ol; concl_occs=occs } =
+  { onhyps=Option.map(List.map (interp_hyp_location ist gl)) ol;
+    concl_occs=interp_occurrences ist occs }
 
 (* Interpretation of constructions *)
 
@@ -1220,12 +1308,12 @@ let rec constr_list_aux env = function
 
 let constr_list ist env = constr_list_aux env ist.lfun
 
-(*Extract the identifier list from lfun: join all branches (what to do else?)*)
+(* Extract the identifier list from lfun: join all branches (what to do else?)*)
 let rec intropattern_ids = function
   | IntroIdentifier id -> [id]
   | IntroOrAndPattern ll -> 
       List.flatten (List.map intropattern_ids (List.flatten ll))
-  | IntroWildcard | IntroAnonymous -> []
+  | IntroWildcard | IntroAnonymous | IntroFresh _ | IntroRewrite _ -> []
 
 let rec extract_ids ids = function
   | (id,VIntroPattern ipat)::tl when not (List.mem id ids) ->
@@ -1237,13 +1325,16 @@ let default_fresh_id = id_of_string "H"
 
 let interp_fresh_id ist gl l =
   let ids = map_succeed (function ArgVar(_,id) -> id | _ -> failwith "") l in
-  let avoid = extract_ids ids ist.lfun in
+  let avoid = (extract_ids ids ist.lfun) @ ist.avoid_ids in
   let id = 
     if l = [] then default_fresh_id 
     else
-      id_of_string (String.concat "" (List.map (function
-	| ArgArg s -> s
-	| ArgVar (_,id) -> string_of_id (interp_ident ist gl id)) l)) in 
+      let s =
+	String.concat "" (List.map (function
+	  | ArgArg s -> s
+	  | ArgVar (_,id) -> string_of_id (interp_ident ist gl id)) l) in
+      let s = if Lexer.is_keyword s then s^"0" else s in
+      id_of_string s in
   Tactics.fresh_id avoid id gl
 
 (* To retype a list of key*constr with undefined key *)
@@ -1270,7 +1361,7 @@ let solvable_by_tactic env evi (ev,args) src =
       begin
 	try
 	  by (tclCOMPLETE tac);
-	  let _,(const,_,_) = cook_proof () in 
+	  let _,(const,_,_) = cook_proof ignore in 
 	  delete_current_proof (); const.const_entry_body
 	with e when Logic.catchable_exception e -> 
 	  delete_current_proof();
@@ -1278,20 +1369,20 @@ let solvable_by_tactic env evi (ev,args) src =
       end
   | _ -> raise Exit
 
-let solve_remaining_evars env initial_sigma evars c =
-  let isevars = ref evars in
+let solve_remaining_evars env initial_sigma evd c =
+  let evdref = ref (Typeclasses.resolve_typeclasses ~fail:true env evd) in
   let rec proc_rec c =
-    match kind_of_term (Reductionops.whd_evar (evars_of !isevars) c) with
+    match kind_of_term (Reductionops.whd_evar (evars_of !evdref) c) with
       | Evar (ev,args as k) when not (Evd.mem initial_sigma ev) ->
-            let (loc,src) = evar_source ev !isevars in
-	    let sigma = evars_of !isevars in
+            let (loc,src) = evar_source ev !evdref in
+	    let sigma = evars_of !evdref in
+	    let evi = Evd.find sigma ev in
 	    (try 
-	      let evi = Evd.find sigma ev in
 	      let c = solvable_by_tactic env evi k src in
-	      isevars := Evd.evar_define ev c !isevars;
+	      evdref := Evd.evar_define ev c !evdref;
 	      c
 	    with Exit ->
-	      Pretype_errors.error_unsolvable_implicit loc env sigma src)
+	      Pretype_errors.error_unsolvable_implicit loc env sigma evi src None)
       | _ -> map_constr proc_rec c      
   in
   proc_rec c
@@ -1318,8 +1409,8 @@ let interp_econstr kind ist sigma env cc =
 
 (* Interprets an open constr *)
 let interp_open_constr ccl ist sigma env cc =
-  let isevars,c = interp_gen (OfType ccl) ist sigma env cc in
-  (evars_of isevars,c)
+  let evd,c = interp_gen (OfType ccl) ist sigma env cc in
+  (evars_of evd,c)
 
 let interp_constr = interp_econstr (OfType None)
 
@@ -1341,32 +1432,82 @@ let pf_interp_constr ist gl =
 let constr_list_of_VList env = function
   | VList l -> List.map (constr_of_value env) l
   | _ -> raise Not_found
-      
+
+let pf_interp_constr_in_compound_list inj_fun dest_fun interp_fun ist gl l =
+  let env = pf_env gl in
+  let try_expand_ltac_var x =
+    try match dest_fun x with
+    | RVar (_,id), _ ->
+	List.map inj_fun (constr_list_of_VList env (List.assoc id ist.lfun))
+    | _ ->
+	raise Not_found
+    with Not_found ->
+      (*all of dest_fun, List.assoc, constr_list_of_VList may raise Not_found*)
+      [interp_fun ist gl x] in
+  List.flatten (List.map try_expand_ltac_var l)
+
+let pf_interp_constr_list =
+  pf_interp_constr_in_compound_list (fun x -> x) (fun x -> x)
+    (fun ist gl -> interp_constr ist (project gl) (pf_env gl))
+
+(*
 let pf_interp_constr_list_as_list ist gl (c,_ as x) =
   match c with
     | RVar (_,id) ->
         (try constr_list_of_VList (pf_env gl) (List.assoc id ist.lfun)
-        with Not_found -> [interp_constr ist (project gl) (pf_env gl) x])
+        with Not_found -> [])
     | _ -> [interp_constr ist (project gl) (pf_env gl) x]
 
 let pf_interp_constr_list ist gl l =
   List.flatten (List.map (pf_interp_constr_list_as_list ist gl) l)
+*)
+
+let inj_open c = (Evd.empty,c)
+
+let pf_interp_open_constr_list =
+  pf_interp_constr_in_compound_list inj_open (fun x -> x)
+    (fun ist gl -> interp_open_constr None ist (project gl) (pf_env gl))
+
+(*
+let pf_interp_open_constr_list_as_list ist gl (c,_ as x) =
+  match c with
+    | RVar (_,id) ->
+        (try List.map inj_open 
+	       (constr_list_of_VList (pf_env gl) (List.assoc id ist.lfun))
+        with Not_found ->
+	  [interp_open_constr None ist (project gl) (pf_env gl) x])
+    | _ ->
+	[interp_open_constr None ist (project gl) (pf_env gl) x]
+
+let pf_interp_open_constr_list ist gl l =
+  List.flatten (List.map (pf_interp_open_constr_list_as_list ist gl) l)
+*)
 
 (* Interprets a type expression *)
 let pf_interp_type ist gl =
   interp_type ist (project gl) (pf_env gl)
 
 (* Interprets a reduction expression *)
-let interp_unfold ist env (l,qid) =
-  (interp_int_or_var_list ist l,interp_evaluable ist env qid)
+let interp_unfold ist env (occs,qid) =
+  (interp_occurrences ist occs,interp_evaluable ist env qid)
 
 let interp_flag ist env red =
   { red with rConst = List.map (interp_evaluable ist env) red.rConst }
 
-let interp_pattern ist sigma env (l,c) = 
-  (interp_int_or_var_list ist l, interp_constr ist sigma env c)
+let interp_pattern ist sigma env (occs,c) = 
+  (interp_occurrences ist occs, interp_constr ist sigma env c)
+
+let pf_interp_constr_with_occurrences ist gl =
+  interp_pattern ist (project gl) (pf_env gl)
 
-let pf_interp_pattern ist gl = interp_pattern ist (project gl) (pf_env gl)
+let pf_interp_constr_with_occurrences_and_name_as_list = 
+  pf_interp_constr_in_compound_list
+    (fun c -> ((all_occurrences_expr,c),Anonymous))
+    (function ((occs,c),Anonymous) when occs = all_occurrences_expr -> c 
+      | _ -> raise Not_found)
+    (fun ist gl (occ_c,na) ->
+      (interp_pattern ist (project gl) (pf_env gl) occ_c,
+       interp_fresh_name ist gl na))
 
 let interp_red_expr ist sigma env = function
   | Unfold l -> Unfold (List.map (interp_unfold ist env) l)
@@ -1374,7 +1515,7 @@ let interp_red_expr ist sigma env = function
   | Cbv f -> Cbv (interp_flag ist env f)
   | Lazy f -> Lazy (interp_flag ist env f)
   | Pattern l -> Pattern (List.map (interp_pattern ist sigma env) l)
-  | Simpl o -> Simpl (option_map (interp_pattern ist sigma env) o)
+  | Simpl o -> Simpl (Option.map (interp_pattern ist sigma env) o)
   | (Red _ |  Hnf | ExtraRedExpr _ | CbvVm as r) -> r
 
 let pf_interp_red_expr ist gl = interp_red_expr ist (project gl) (pf_env gl)
@@ -1396,34 +1537,18 @@ let interp_may_eval f ist gl = function
   | ConstrTerm c -> 
      try 
 	f ist gl c
-     with e -> 
-	begin 
-	  match ist.debug with 
-	    DebugOn lev -> 
-	    safe_msgnl (str "Level " ++ int lev ++
-                          str ": interpretation of term " ++ 
-			   Printer.pr_rawconstr_env (pf_env gl) (fst c) ++
-			   str " raised an exception" ++
-			   fnl() ++
-			   !Tactic_debug.explain_logic_error_no_anomaly e)
-	| _ -> ()
-     end;
-     raise e  
+     with e ->
+       debugging_exception_step ist false e (fun () ->
+         str"interpretation of term " ++ pr_rawconstr_env (pf_env gl) (fst c));
+       raise e  
 
 (* Interprets a constr expression possibly to first evaluate *)
 let interp_constr_may_eval ist gl c =
   let csr = 
     try
       interp_may_eval pf_interp_constr ist gl c
-    with e -> 
-      begin match ist.debug with
-	  DebugOn lev -> 
-	    safe_msgnl (str "Level " ++ int lev ++
-                           str ": evaluation of term raised an exception" ++
-			   fnl() ++
-			   !Tactic_debug.explain_logic_error_no_anomaly e)
-	| _ -> ()
-      end;
+    with e ->
+      debugging_exception_step ist false e (fun () -> str"evaluation of term");
       raise e
   in
   begin
@@ -1431,6 +1556,12 @@ let interp_constr_may_eval ist gl c =
     csr
   end
 
+let inj_may_eval = function
+  | ConstrTerm c -> ConstrTerm (inj_open c)
+  | ConstrEval (r,c) -> ConstrEval (Tactics.inj_red_expr r,inj_open c)
+  | ConstrContext (id,c) -> ConstrContext (id,inj_open c)
+  | ConstrTypeOf c -> ConstrTypeOf (inj_open c)
+
 let message_of_value = function
   | VVoid -> str "()"
   | VInteger n -> int n
@@ -1456,7 +1587,7 @@ let rec interp_message_nl ist = function
 let rec interp_intro_pattern ist gl = function
   | IntroOrAndPattern l -> IntroOrAndPattern (interp_case_intro_pattern ist gl l)
   | IntroIdentifier id -> interp_intro_pattern_var ist (pf_env gl) id
-  | IntroWildcard | IntroAnonymous as x -> x
+  | IntroWildcard | IntroAnonymous | IntroFresh _ | IntroRewrite _ as x -> x
 
 and interp_case_intro_pattern ist gl =
   List.map (List.map (interp_intro_pattern ist gl))
@@ -1472,8 +1603,7 @@ let interp_quantified_hypothesis ist = function
   | AnonHyp n -> AnonHyp n
   | NamedHyp id ->
       try try_interp_ltac_var coerce_to_quantified_hypothesis ist None(dloc,id)
-      with Not_found | Stdpp.Exc_located (_, UserError _) | UserError _
-   -> NamedHyp id
+      with Not_found -> NamedHyp id
 
 let interp_binding_name ist = function
   | AnonHyp n -> AnonHyp n
@@ -1482,8 +1612,7 @@ let interp_binding_name ist = function
       (* user has to use other names for variables if these ones clash with *)
       (* a name intented to be used as a (non-variable) identifier *)
       try try_interp_ltac_var coerce_to_quantified_hypothesis ist None(dloc,id)
-      with Not_found | Stdpp.Exc_located (_, UserError _) | UserError _ 
-   -> NamedHyp id
+      with Not_found -> NamedHyp id
 
 (* Quantified named or numbered hypothesis or hypothesis in context *)
 (* (as in Inversion) *)
@@ -1502,25 +1631,29 @@ let interp_declared_or_quantified_hypothesis ist gl = function
 	    (coerce_to_decl_or_quant_hyp env) ist (Some env) (dloc,id)
       with Not_found -> NamedHyp id
 
-let interp_induction_arg ist gl = function
-  | ElimOnConstr c -> ElimOnConstr (pf_interp_constr ist gl c)
-  | ElimOnAnonHyp n as x -> x
-  | ElimOnIdent (loc,id) ->
-      if Tactics.is_quantified_hypothesis id gl then ElimOnIdent (loc,id)
-      else ElimOnConstr
-	(pf_interp_constr ist gl (RVar (loc,id),Some (CRef (Ident (loc,id)))))
-
 let interp_binding ist gl (loc,b,c) =
-  (loc,interp_binding_name ist b,pf_interp_constr ist gl c)
+  (loc,interp_binding_name ist b,pf_interp_open_constr false ist gl c)
 
 let interp_bindings ist gl = function
 | NoBindings -> NoBindings
-| ImplicitBindings l -> ImplicitBindings (pf_interp_constr_list ist gl l)
+| ImplicitBindings l -> ImplicitBindings (pf_interp_open_constr_list ist gl l)
 | ExplicitBindings l -> ExplicitBindings (List.map (interp_binding ist gl) l)
 
 let interp_constr_with_bindings ist gl (c,bl) =
   (pf_interp_constr ist gl c, interp_bindings ist gl bl)
 
+let interp_open_constr_with_bindings ist gl (c,bl) =
+  (pf_interp_open_constr false ist gl c, interp_bindings ist gl bl)
+
+let interp_induction_arg ist gl = function
+  | ElimOnConstr c -> ElimOnConstr (interp_constr_with_bindings ist gl c)
+  | ElimOnAnonHyp n as x -> x
+  | ElimOnIdent (loc,id) ->
+      if Tactics.is_quantified_hypothesis id gl then ElimOnIdent (loc,id)
+      else ElimOnConstr
+	(pf_interp_constr ist gl (RVar (loc,id),Some (CRef (Ident (loc,id)))),
+	 NoBindings)
+
 let mk_constr_value ist gl c = VConstr (pf_interp_constr ist gl c)
 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)
@@ -1531,15 +1664,13 @@ let rec val_interp ist gl (tac:glob_tactic_expr) =
   let value_interp ist = match tac with
   (* Immediate evaluation *)
   | TacFun (it,body) -> VFun (ist.lfun,it,body)
-  | TacLetRecIn (lrc,u) -> letrec_interp ist gl lrc u
-  | TacLetIn (l,u) ->
-      let addlfun = interp_letin ist gl l in
-      val_interp { ist with lfun=addlfun@ist.lfun } gl u
+  | TacLetIn (true,l,u) -> interp_letrec ist gl l u
+  | TacLetIn (false,l,u) -> interp_letin ist gl l u
   | TacMatchContext (lz,lr,lmr) -> interp_match_context ist gl lz lr lmr 
   | TacMatch (lz,c,lmr) -> interp_match ist gl lz c lmr
   | TacArg a -> interp_tacarg ist gl a
   (* Delayed evaluation *)
-  | t -> VTactic (dloc,eval_tactic ist t)
+  | t -> VTactic (ist.last_loc,eval_tactic ist t)
 
   in check_for_interrupt (); 
     match ist.debug with
@@ -1549,18 +1680,28 @@ let rec val_interp ist gl (tac:glob_tactic_expr) =
 
 and eval_tactic ist = function
   | TacAtom (loc,t) -> fun gl -> catch_error loc (interp_atomic ist gl t) gl
-  | TacFun _ | TacLetRecIn _ | TacLetIn _ -> assert false
+  | TacFun _ | TacLetIn _ -> assert false
   | TacMatchContext _ | TacMatch _ -> assert false
   | TacId s -> tclIDTAC_MESSAGE (interp_message_nl ist s)
   | TacFail (n,s) -> tclFAIL (interp_int_or_var ist n) (interp_message ist s)
   | TacProgress tac -> tclPROGRESS (interp_tactic ist tac)
-  | TacAbstract (tac,s) -> Tactics.tclABSTRACT s (interp_tactic ist tac)
-  | TacThen (t1,t2) -> tclTHEN (interp_tactic ist t1) (interp_tactic ist t2)
-  | TacThens (t,tl) ->
-      tclTHENS (interp_tactic ist t) (List.map (interp_tactic ist) tl)
+  | TacAbstract (tac,ido) ->
+      fun gl -> Tactics.tclABSTRACT
+        (Option.map (interp_ident ist gl) ido) (interp_tactic ist tac) gl
+  | TacThen (t1,tf,t,tl) -> 
+      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)
   | TacTry tac -> tclTRY (interp_tactic ist tac)
-  | TacInfo tac -> tclINFO (interp_tactic ist tac)
+  | TacInfo tac -> 
+      let t = (interp_tactic ist tac) in
+	tclINFO 
+	  begin
+	    match tac with
+		TacAtom (_,_) -> t
+	      | _ -> abstract_tactic_expr (TacArg (Tacexp tac)) t
+	  end
   | TacRepeat tac -> tclREPEAT (interp_tactic ist tac)
   | TacOrelse (tac1,tac2) ->
         tclORELSE (interp_tactic ist tac1) (interp_tactic ist tac2)
@@ -1569,13 +1710,21 @@ and eval_tactic ist = function
   | TacComplete tac -> tclCOMPLETE (interp_tactic ist tac)
   | TacArg a -> assert false
 
+and force_vrec ist gl = function
+  | VRec (lfun,body) -> val_interp {ist with lfun = !lfun} gl body
+  | v -> v
+
 and interp_ltac_reference isapplied mustbetac ist gl = function
   | ArgVar (loc,id) ->
       let v = List.assoc id ist.lfun in
+      let v = force_vrec ist gl v in
       if mustbetac then coerce_to_tactic loc id v else v
   | ArgArg (loc,r) ->
-      let v = val_interp {lfun=[];debug=ist.debug} gl (lookup r) in
-      if isapplied then v else locate_tactic_call loc v
+      let ids = extract_ids [] ist.lfun in
+      let ist = 
+        { lfun=[]; debug=ist.debug; avoid_ids=ids;
+          last_loc = if isapplied then ist.last_loc else loc } in
+      val_interp ist gl (lookup r)
 
 and interp_tacarg ist gl = function
   | TacVoid -> VVoid
@@ -1583,7 +1732,7 @@ and interp_tacarg ist gl = function
   | Integer n -> VInteger n
   | IntroPattern ipat -> VIntroPattern (interp_intro_pattern ist gl ipat)
   | ConstrMayEval c -> VConstr (interp_constr_may_eval ist gl c)
-  | MetaIdArg (loc,id) -> assert false
+  | MetaIdArg (loc,_,id) -> assert false
   | TacCall (loc,r,[]) -> interp_ltac_reference false true ist gl r
   | TacCall (loc,f,l) ->
       let fv = interp_ltac_reference true true ist gl f
@@ -1620,32 +1769,15 @@ and interp_app ist gl fv largs loc =
       let (newlfun,lvar,lval)=head_with_value (var,largs) in
       if lvar=[] then
 	let v = 
-          let res = 
-	    try
-	      val_interp { ist with lfun=newlfun@olfun } gl body
-	    with e ->
-	      begin match ist.debug with
-		  DebugOn lev -> 
-		    safe_msgnl 
-		      (str "Level " ++ int lev ++ 
-			  str ": evaluation raises an exception" ++
-                          fnl() ++
-			  !Tactic_debug.explain_logic_error_no_anomaly e)
-		| _ -> ()
-	      end;
-	      raise e
-	  in
-	    (match ist.debug with
-		DebugOn lev -> 
-		  safe_msgnl (str "Level " ++ int lev ++ 
-				 str ": evaluation returns" ++ fnl() ++
-				 pr_value (Some (pf_env gl)) res)
-	      | _ -> ());
-	    res
-	in
-
-        if lval=[] then locate_tactic_call loc v
-	else interp_app ist gl v lval loc
+	  try
+            let lloc = if lval=[] then loc else ist.last_loc in
+	    val_interp { ist with lfun=newlfun@olfun; last_loc=lloc } gl body
+	  with e ->
+            debugging_exception_step ist false e (fun () -> str "evaluation");
+	    raise e in
+        debugging_step ist (fun () ->
+	  str "evaluation returns" ++ fnl() ++ pr_value (Some (pf_env gl)) v);
+        if lval=[] then v else interp_app ist gl v lval loc
       else
         VFun(newlfun@olfun,lvar,body)
     | _ ->
@@ -1674,47 +1806,20 @@ and eval_with_fail ist is_lazy goal tac =
     | FailError (lvl,s) ->
 	raise (FailError (lvl - 1, s))
 
-(* Interprets recursive expressions *)
-and letrec_interp ist gl lrc u =
-  let lref = Array.to_list (Array.make (List.length lrc) (ref VVoid)) in
-  let lenv =
-    List.fold_right2 (fun ((loc,name),_) vref l -> (name,VRec vref)::l)
-      lrc lref [] in
-  let lve = List.map (fun ((loc,name),(var,body)) ->
-                          (name,VFun(lenv@ist.lfun,var,body))) lrc in
-  begin
-    List.iter2 (fun vref (_,ve) -> vref:=ve) lref lve;
-    val_interp { ist with lfun=lve@ist.lfun } gl u
-  end
+(* Interprets the clauses of a recursive LetIn *)
+and interp_letrec ist gl llc u =
+  let lref = ref ist.lfun in
+  let lve = list_map_left (fun ((_,id),b) -> (id,VRec (lref,TacArg b))) llc in
+  lref := lve@ist.lfun;
+  let ist = { ist with lfun = lve@ist.lfun } in
+  val_interp ist gl u
 
 (* Interprets the clauses of a LetIn *)
-and interp_letin ist gl = function
-  | [] -> []
-  | ((loc,id),None,t)::tl -> 
-      let v = interp_tacarg ist gl t in
-      check_is_value v;
-      (id,v):: (interp_letin ist gl tl)
-  | ((loc,id),Some com,tce)::tl ->
-    let env = pf_env gl in
-    let typ = constr_of_value env (val_interp ist gl com)
-    and v = interp_tacarg ist gl tce in
-    let csr = 
-      try
-	constr_of_value env v
-      with Not_found ->
-      try
-	let t = tactic_of_value v in
-	let ndc = Environ.named_context_val env in
-	start_proof id (Local,Proof Lemma) ndc typ (fun _ _ -> ());
-	by t;
-	let (_,({const_entry_body = pft},_,_)) = cook_proof () in
-	delete_proof (dloc,id);
-        pft
-      with | NotTactic ->
-	delete_proof (dloc,id);
-	errorlabstrm "Tacinterp.interp_letin"
-          (str "Term or fully applied tactic expected in Let")
-    in (id,VConstr (mkCast (csr,DEFAULTcast, typ)))::(interp_letin ist gl tl)
+and interp_letin ist gl llc u =
+  let lve = list_map_left (fun ((_,id),body) ->
+    let v = interp_tacarg ist gl body in check_is_value v; (id,v)) llc in
+  let ist = { ist with lfun = lve@ist.lfun } in
+  val_interp ist gl u
 
 (* Interprets the Match Context expressions *)
 and interp_match_context ist g lz lr lmr =
@@ -1761,7 +1866,7 @@ and interp_match_context ist g lz lr lmr =
 	    errorlabstrm "Tacinterp.apply_match_context"
               (v 0 (str "No matching clauses for match goal" ++
 		      (if ist.debug=DebugOff then
-			 fnl() ++ str "(use \"Debug On\" for more info)"
+			 fnl() ++ str "(use \"Set Ltac Debug\" for more info)"
 		       else mt())))
     end in
   let env = pf_env g in
@@ -1811,7 +1916,8 @@ and interp_genarg ist gl x =
       in_gen wit_intro_pattern
         (interp_intro_pattern ist gl (out_gen globwit_intro_pattern x))
   | IdentArgType ->
-      in_gen wit_ident (interp_ident ist gl (out_gen globwit_ident x))
+      in_gen wit_ident
+        (interp_fresh_ident ist gl (out_gen globwit_ident x))
   | VarArgType ->
       in_gen wit_var (interp_hyp ist gl (out_gen globwit_var x))
   | RefArgType ->
@@ -1892,34 +1998,25 @@ and interp_match ist g lz constr lmr =
         (try eval_with_fail ist lz g t
          with e when is_match_catchable e -> apply_match ist csr [])
     | (Pat ([],Term c,mt))::tl ->
-        (try let lm = 
-              (try matches c csr with 
-                e -> 
-                  (match ist.debug with
-                    DebugOn lev ->
-                      safe_msgnl (str "Level " ++ int lev ++
-                             str ": matching with pattern" ++ fnl() ++
-                         Printer.pr_constr_pattern_env (pf_env g) c ++ fnl() ++
-                         str "raised the exception" ++ fnl() ++
-                         !Tactic_debug.explain_logic_error_no_anomaly e)
-                  | _ -> ()); raise e) in
-            (try let lm = List.map (fun (id,c) -> (id,VConstr c)) lm in
-               eval_with_fail { ist with lfun=lm@ist.lfun } lz g mt
+        (try
+            let lm = 
+              try matches c csr
+              with e ->
+                debugging_exception_step ist false e (fun () ->
+                  str "matching with pattern" ++ fnl () ++
+                  pr_constr_pattern_env (pf_env g) c);
+                raise e in
+            try
+              let lm = List.map (fun (id,c) -> (id,VConstr c)) lm in
+              eval_with_fail { ist with lfun=lm@ist.lfun } lz g mt
             with e ->
-               (match ist.debug with
-                  DebugOn lev -> 
-                    safe_msgnl (str "rule body for pattern" ++ fnl() ++
-                    Printer.pr_constr_pattern_env (pf_env g) c ++ fnl() ++
-                    str "raised the exception" ++ fnl() ++
-                    !Tactic_debug.explain_logic_error_no_anomaly e)
-                | _ -> ()); raise e)
+              debugging_exception_step ist false e (fun () ->
+                str "rule body for pattern" ++
+                pr_constr_pattern_env (pf_env g) c);
+              raise e
          with e when is_match_catchable e ->
-            (match ist.debug with
-               DebugOn lev ->
-                 safe_msgnl (str "Level " ++ int lev ++ 
-                       str ":switching to the next rule");
-             | DebugOff -> ());
-            apply_match ist csr tl)
+           debugging_step ist (fun () -> str "switching to the next rule");
+           apply_match ist csr tl)
 
     | (Pat ([],Subterm (id,c),mt))::tl ->
         (try apply_match_subterm ist 0 (id,c) csr mt
@@ -1928,49 +2025,33 @@ and interp_match ist g lz constr lmr =
       errorlabstrm "Tacinterp.apply_match" (str
         "No matching clauses for match") in
   let csr = 
-      try interp_ltac_constr ist g constr with
-        e -> (match ist.debug with
-               DebugOn lev ->
-               safe_msgnl (str "Level " ++ int lev ++ 
-                      str ": evaluation of the matched expression raised " ++
-                      str "the exception" ++ fnl() ++
-                      !Tactic_debug.explain_logic_error e)
-             | _ -> ()); raise e in
+      try interp_ltac_constr ist g constr with e ->
+        debugging_exception_step ist true e
+          (fun () -> str "evaluation of the matched expression");
+        raise e in
   let ilr = read_match_rule (fst (constr_list ist (pf_env g))) lmr in
   let res = 
-     try apply_match ist csr ilr with
-       e -> 
-           begin match ist.debug with
-             DebugOn lev ->
-                safe_msgnl (str "Level " ++ int lev ++ 
-                        str ": match expression failed with error" ++ fnl() ++
-                    !Tactic_debug.explain_logic_error e)
-           | _ -> ()
-           end;
-           raise e in
-     (if ist.debug <> DebugOff then
-     safe_msgnl (str "match expression returns " ++
-            pr_value (Some (pf_env g)) res));
-     res
+     try apply_match ist csr ilr with e -> 
+       debugging_exception_step ist true e (fun () -> str "match expression");
+       raise e in
+  debugging_step ist (fun () ->
+    str "match expression returns " ++ pr_value (Some (pf_env g)) res);
+  res
 
 (* Interprets tactic expressions : returns a "constr" *)
 and interp_ltac_constr ist gl e =
   let result = 
-  try (val_interp ist gl e) with Not_found -> 
-    begin match ist.debug with
-      DebugOn lev ->
-       safe_msgnl (str "Level " ++ int lev ++ 
-                   str ": evaluation failed for" ++ fnl() ++
-                       Pptactic.pr_glob_tactic (pf_env gl) e)
-    | _ -> ()
-    end;
+  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
-  try let cresult = constr_of_value (pf_env gl) result in
-    (if !debug <> DebugOff then 
-        safe_msgnl (Pptactic.pr_glob_tactic (pf_env gl) e ++ fnl() ++
-        str " has value " ++ fnl() ++ print_constr_env (pf_env gl) cresult);
-     cresult)
-        
+  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() ++ print_constr_env (pf_env gl) cresult);
+    cresult
   with Not_found ->
     errorlabstrm ""
       (str "Must evaluate to a term" ++ fnl() ++ 
@@ -2016,72 +2097,72 @@ and interp_atomic ist gl = function
   | TacIntrosUntil hyp ->
       h_intros_until (interp_quantified_hypothesis ist hyp)
   | TacIntroMove (ido,ido') ->
-      h_intro_move (option_map (interp_ident ist gl) ido)
-      (option_map (interp_hyp ist gl) ido')
+      h_intro_move (Option.map (interp_fresh_ident ist gl) ido)
+      (Option.map (interp_hyp ist gl) ido')
   | TacAssumption -> h_assumption
   | TacExact c -> h_exact (pf_interp_casted_constr ist gl c)
   | TacExactNoCheck c -> h_exact_no_check (pf_interp_constr ist gl c)
   | TacVmCastNoCheck c -> h_vm_cast_no_check (pf_interp_constr ist gl c)
-  | TacApply cb -> h_apply (interp_constr_with_bindings ist gl cb)
-  | TacElim (cb,cbo) ->
-      h_elim (interp_constr_with_bindings ist gl cb)
-                (option_map (interp_constr_with_bindings ist gl) cbo)
+  | TacApply (a,ev,cb) -> h_apply a ev (interp_constr_with_bindings ist gl cb)
+  | TacElim (ev,cb,cbo) ->
+      h_elim ev (interp_constr_with_bindings ist gl cb)
+                (Option.map (interp_constr_with_bindings ist gl) cbo)
   | TacElimType c -> h_elim_type (pf_interp_type ist gl c)
-  | TacCase cb -> h_case (interp_constr_with_bindings ist gl cb)
+  | TacCase (ev,cb) -> h_case ev (interp_constr_with_bindings ist gl cb)
   | TacCaseType c -> h_case_type (pf_interp_type ist gl c)
-  | TacFix (idopt,n) -> h_fix (option_map (interp_ident ist gl) idopt) n
-  | TacMutualFix (id,n,l) ->
-      let f (id,n,c) = (interp_ident ist gl id,n,pf_interp_type ist gl c) in
-      h_mutual_fix (interp_ident ist gl id) n (List.map f l)
-  | TacCofix idopt -> h_cofix (option_map (interp_ident ist gl) idopt)
-  | TacMutualCofix (id,l) ->
-      let f (id,c) = (interp_ident ist gl id,pf_interp_type ist gl c) in
-      h_mutual_cofix (interp_ident ist gl id) (List.map f l)
+  | TacFix (idopt,n) -> h_fix (Option.map (interp_fresh_ident ist gl) idopt) n
+  | TacMutualFix (b,id,n,l) ->
+      let f (id,n,c) = (interp_fresh_ident ist gl id,n,pf_interp_type ist gl c)
+      in h_mutual_fix b (interp_fresh_ident ist gl id) n (List.map f l)
+  | TacCofix idopt -> h_cofix (Option.map (interp_fresh_ident ist gl) idopt)
+  | TacMutualCofix (b,id,l) ->
+      let f (id,c) = (interp_fresh_ident ist gl id,pf_interp_type ist gl c) in
+      h_mutual_cofix b (interp_fresh_ident ist gl id) (List.map f l)
   | TacCut c -> h_cut (pf_interp_type ist gl c)
   | TacAssert (t,ipat,c) ->
       let c = (if t=None then pf_interp_constr else pf_interp_type) ist gl c in
-      abstract_tactic (TacAssert (t,ipat,c))
-        (Tactics.forward (option_map (interp_tactic ist) t)
+      abstract_tactic (TacAssert (t,ipat,inj_open c))
+        (Tactics.forward (Option.map (interp_tactic ist) t)
 	  (interp_intro_pattern ist gl ipat) c)
-  | TacGeneralize cl -> h_generalize (pf_interp_constr_list ist gl cl)
+  | TacGeneralize cl ->
+      h_generalize_gen
+        (pf_interp_constr_with_occurrences_and_name_as_list ist gl cl)
   | TacGeneralizeDep c -> h_generalize_dep (pf_interp_constr ist gl c)
-  | TacLetTac (na,c,clp) ->
+  | TacLetTac (na,c,clp,b) ->
       let clp = interp_clause ist gl clp in
-      h_let_tac (interp_name ist gl na) (pf_interp_constr ist gl c) clp
-(* | TacInstantiate (n,c,idh) -> h_instantiate n (fst c) 
-      (* pf_interp_constr ist gl c *)
-      (match idh with
-	   ConclLocation () -> ConclLocation ()
-	 | HypLocation (id,hloc) -> 
-	     HypLocation(interp_hyp ist gl id,hloc))
-*)
+      h_let_tac b (interp_fresh_name ist gl na) (pf_interp_constr ist gl c) clp
+
   (* Automation tactics *)
   | TacTrivial (lems,l) -> 
       Auto.h_trivial (pf_interp_constr_list ist gl lems)
-	(option_map (List.map (interp_hint_base ist)) l)
+	(Option.map (List.map (interp_hint_base ist)) l)
   | TacAuto (n,lems,l) ->
-      Auto.h_auto (option_map (interp_int_or_var ist) n)
+      Auto.h_auto (Option.map (interp_int_or_var ist) n)
       (pf_interp_constr_list ist gl lems)
-      (option_map (List.map (interp_hint_base ist)) l)
+      (Option.map (List.map (interp_hint_base ist)) l)
   | TacAutoTDB n -> Dhyp.h_auto_tdb n
   | TacDestructHyp (b,id) -> Dhyp.h_destructHyp b (interp_hyp ist gl id)
   | TacDestructConcl -> Dhyp.h_destructConcl
   | TacSuperAuto (n,l,b1,b2) -> Auto.h_superauto n l b1 b2
-  | TacDAuto (n,p) -> Auto.h_dauto (option_map (interp_int_or_var ist) n,p)
+  | TacDAuto (n,p,lems) ->
+      Auto.h_dauto (Option.map (interp_int_or_var ist) n,p)
+      (pf_interp_constr_list ist gl lems)
 
   (* Derived basic tactics *)
   | TacSimpleInduction h ->
       h_simple_induction (interp_quantified_hypothesis ist h)
-  | TacNewInduction (lc,cbo,ids) ->
-      h_new_induction (List.map (interp_induction_arg ist gl) lc)
-        (option_map (interp_constr_with_bindings ist gl) cbo)
+  | TacNewInduction (ev,lc,cbo,ids,cls) ->
+      h_new_induction ev (List.map (interp_induction_arg ist gl) lc)
+        (Option.map (interp_constr_with_bindings ist gl) cbo)
         (interp_intro_pattern ist gl ids)
+        (Option.map (interp_clause ist gl) cls)
   | TacSimpleDestruct h ->
       h_simple_destruct (interp_quantified_hypothesis ist h)
-  | TacNewDestruct (c,cbo,ids) -> 
-      h_new_destruct (List.map (interp_induction_arg ist gl) c)
-        (option_map (interp_constr_with_bindings ist gl) cbo)
+  | TacNewDestruct (ev,c,cbo,ids,cls) -> 
+      h_new_destruct ev (List.map (interp_induction_arg ist gl) c)
+        (Option.map (interp_constr_with_bindings ist gl) cbo)
         (interp_intro_pattern ist gl ids)
+        (Option.map (interp_clause ist gl) cls)
   | TacDoubleInduction (h1,h2) ->
       let h1 = interp_quantified_hypothesis ist h1 in
       let h2 = interp_quantified_hypothesis ist h2 in
@@ -2100,25 +2181,31 @@ and interp_atomic ist gl = function
   | TacClearBody l -> h_clear_body (interp_hyp_list ist gl l)
   | TacMove (dep,id1,id2) ->
       h_move dep (interp_hyp ist gl id1) (interp_hyp ist gl id2)
-  | TacRename (id1,id2) ->
-      h_rename (interp_hyp ist gl id1) (interp_ident ist gl (snd id2))
+  | TacRename l ->
+      h_rename (List.map (fun (id1,id2) -> 
+			    interp_hyp ist gl id1, 
+			    interp_fresh_ident ist gl (snd id2)) l)
+  | TacRevert l -> h_revert (interp_hyp_list ist gl l)
 
   (* Constructors *)
-  | TacLeft bl -> h_left (interp_bindings ist gl bl)
-  | TacRight bl -> h_right (interp_bindings ist gl bl)
-  | TacSplit (_,bl) -> h_split (interp_bindings ist gl bl)
-  | TacAnyConstructor t ->
-      abstract_tactic (TacAnyConstructor t)
-        (Tactics.any_constructor (option_map (interp_tactic ist) t))
-  | TacConstructor (n,bl) ->
-      h_constructor (skip_metaid n) (interp_bindings ist gl bl)
+  | TacLeft (ev,bl) -> h_left ev (interp_bindings ist gl bl)
+  | TacRight (ev,bl) -> h_right ev (interp_bindings ist gl bl)
+  | TacSplit (ev,_,bl) -> h_split ev (interp_bindings ist gl bl)
+  | TacAnyConstructor (ev,t) ->
+      abstract_tactic (TacAnyConstructor (ev,t))
+        (Tactics.any_constructor ev (Option.map (interp_tactic ist) t))
+  | TacConstructor (ev,n,bl) ->
+      h_constructor ev (skip_metaid n) (interp_bindings ist gl bl)
 
   (* Conversion *)
   | TacReduce (r,cl) ->
       h_reduce (pf_interp_red_expr ist gl r) (interp_clause ist gl cl)
   | TacChange (occl,c,cl) ->
-      h_change (option_map (pf_interp_pattern ist gl) occl)
-        (if occl = None then pf_interp_type ist gl c 
+      h_change (Option.map (pf_interp_constr_with_occurrences ist gl) occl)
+        (if occl = None & (cl.onhyps = None or cl.onhyps = Some []) &
+	    (cl.concl_occs = all_occurrences_expr or
+	     cl.concl_occs = no_occurrences_expr)
+	 then pf_interp_type ist gl c 
 	 else pf_interp_constr ist gl c)
         (interp_clause ist gl cl)
 
@@ -2128,12 +2215,13 @@ and interp_atomic ist gl = function
   | TacTransitivity c -> h_transitivity (pf_interp_constr ist gl c)
 
   (* Equality and inversion *)
-  | TacRewrite (b,c,cl) -> 
-      Equality.general_multi_rewrite b 
-	(interp_constr_with_bindings ist gl c) 
+  | TacRewrite (ev,l,cl,by) -> 
+      Equality.general_multi_multi_rewrite ev
+	(List.map (fun (b,m,c) -> (b,m,interp_constr_with_bindings ist gl c)) l)
 	(interp_clause ist gl cl)
+	(Option.map (interp_tactic ist) by)
   | TacInversion (DepInversion (k,c,ids),hyp) ->
-      Inv.dinv k (option_map (pf_interp_constr ist gl) c)
+      Inv.dinv k (Option.map (pf_interp_constr ist gl) c)
         (interp_intro_pattern ist gl ids)
         (interp_declared_or_quantified_hypothesis ist gl hyp)
   | TacInversion (NonDepInversion (k,idl,ids),hyp) ->
@@ -2165,7 +2253,8 @@ and interp_atomic ist gl = function
 	  (interp_intro_pattern ist gl (out_gen globwit_intro_pattern x))
     | IdentArgType -> 
         VIntroPattern 
-	  (IntroIdentifier (interp_ident ist gl (out_gen globwit_ident x)))
+	  (IntroIdentifier
+              (interp_fresh_ident ist gl (out_gen globwit_ident x)))
     | VarArgType ->
         mk_hyp_value ist gl (out_gen globwit_var x)
     | RefArgType -> 
@@ -2181,7 +2270,7 @@ and interp_atomic ist gl = function
     | ExtraArgType s when tactic_genarg_level s <> None ->
           (* Special treatment of tactic arguments *)
 	val_interp ist gl 
-          (out_gen (globwit_tactic (out_some (tactic_genarg_level s))) x)
+          (out_gen (globwit_tactic (Option.get (tactic_genarg_level s))) x)
     | List0ArgType ConstrArgType -> 
         let wit = wit_list0 globwit_constr in
         VList (List.map (mk_constr_value ist gl) (out_gen wit x))
@@ -2226,18 +2315,21 @@ let make_empty_glob_sign () =
     gsigma = Evd.empty; genv = Global.env() }
 
 (* Initial call for interpretation *)
-let interp_tac_gen lfun debug t gl = 
-  interp_tactic { lfun=lfun; debug=debug } 
+let interp_tac_gen lfun avoid_ids debug t gl = 
+  interp_tactic { lfun=lfun; avoid_ids=avoid_ids; debug=debug; last_loc=dloc } 
     (intern_tactic {
       ltacvars = (List.map fst lfun, []); ltacrecvars = [];
       gsigma = project gl; genv = pf_env gl } t) gl
 
-let eval_tactic t gls = interp_tactic { lfun=[]; debug=get_debug() } t gls
+let eval_tactic t gls =
+  interp_tactic { lfun=[]; avoid_ids=[]; debug=get_debug(); last_loc=dloc }
+    t gls
 
-let interp t = interp_tac_gen [] (get_debug()) t
+let interp t = interp_tac_gen [] [] (get_debug()) t
 
 let eval_ltac_constr gl t =
-  interp_ltac_constr { lfun=[]; debug=get_debug() } gl
+  interp_ltac_constr 
+    { lfun=[]; avoid_ids=[]; debug=get_debug(); last_loc=dloc } gl
     (intern_tactic (make_empty_glob_sign ()) t )
 
 (* Hides interpretation for pretty-print *)
@@ -2276,7 +2368,7 @@ let subst_raw_with_bindings subst (c,bl) =
   (subst_rawconstr subst c, subst_bindings subst bl)
 
 let subst_induction_arg subst = function
-  | ElimOnConstr c -> ElimOnConstr (subst_rawconstr subst c)
+  | ElimOnConstr c -> ElimOnConstr (subst_raw_with_bindings subst c)
   | ElimOnAnonHyp n as x -> x
   | ElimOnIdent id as x -> x
 
@@ -2317,15 +2409,15 @@ let subst_unfold subst (l,e) =
 let subst_flag subst red =
   { red with rConst = List.map (subst_evaluable subst) red.rConst }
 
-let subst_constr_occurrence subst (l,c) = (l,subst_rawconstr subst c)
+let subst_constr_with_occurrences subst (l,c) = (l,subst_rawconstr subst c)
 
 let subst_redexp subst = function
   | Unfold l -> Unfold (List.map (subst_unfold subst) l)
   | Fold l -> Fold (List.map (subst_rawconstr subst) l)
   | Cbv f -> Cbv (subst_flag subst f)
   | Lazy f -> Lazy (subst_flag subst f)
-  | Pattern l -> Pattern (List.map (subst_constr_occurrence subst) l)
-  | Simpl o -> Simpl (option_map (subst_constr_occurrence subst) o)
+  | Pattern l -> Pattern (List.map (subst_constr_with_occurrences subst) l)
+  | Simpl o -> Simpl (Option.map (subst_constr_with_occurrences subst) o)
   | (Red _ | Hnf | ExtraRedExpr _ | CbvVm as r) -> r
 
 let subst_raw_may_eval subst = function
@@ -2351,27 +2443,27 @@ let rec subst_atomic subst (t:glob_atomic_tactic_expr) = match t with
   | TacExact c -> TacExact (subst_rawconstr subst c)
   | TacExactNoCheck c -> TacExactNoCheck (subst_rawconstr subst c)
   | TacVmCastNoCheck c -> TacVmCastNoCheck (subst_rawconstr subst c)
-  | TacApply cb -> TacApply (subst_raw_with_bindings subst cb)
-  | TacElim (cb,cbo) ->
-      TacElim (subst_raw_with_bindings subst cb,
-               option_map (subst_raw_with_bindings subst) cbo)
+  | TacApply (a,ev,cb) -> TacApply (a,ev,subst_raw_with_bindings subst cb)
+  | TacElim (ev,cb,cbo) ->
+      TacElim (ev,subst_raw_with_bindings subst cb,
+               Option.map (subst_raw_with_bindings subst) cbo)
   | TacElimType c -> TacElimType (subst_rawconstr subst c)
-  | TacCase cb -> TacCase (subst_raw_with_bindings subst cb)
+  | TacCase (ev,cb) -> TacCase (ev,subst_raw_with_bindings subst cb)
   | TacCaseType c -> TacCaseType (subst_rawconstr subst c)
   | TacFix (idopt,n) as x -> x
-  | TacMutualFix (id,n,l) ->
-      TacMutualFix(id,n,List.map (fun (id,n,c) -> (id,n,subst_rawconstr subst c)) l)
+  | TacMutualFix (b,id,n,l) ->
+      TacMutualFix(b,id,n,List.map (fun (id,n,c) -> (id,n,subst_rawconstr subst c)) l)
   | TacCofix idopt as x -> x
-  | TacMutualCofix (id,l) ->
-      TacMutualCofix (id, List.map (fun (id,c) -> (id,subst_rawconstr subst c)) l)
+  | TacMutualCofix (b,id,l) ->
+      TacMutualCofix (b,id, List.map (fun (id,c) -> (id,subst_rawconstr subst c)) l)
   | TacCut c -> TacCut (subst_rawconstr subst c)
   | TacAssert (b,na,c) ->
-      TacAssert (option_map (subst_tactic subst) b,na,subst_rawconstr subst c)
-  | TacGeneralize cl -> TacGeneralize (List.map (subst_rawconstr subst) cl)
+      TacAssert (Option.map (subst_tactic subst) b,na,subst_rawconstr subst c)
+  | TacGeneralize cl ->
+      TacGeneralize (List.map (on_fst (subst_constr_with_occurrences subst))cl)
   | TacGeneralizeDep c -> TacGeneralizeDep (subst_rawconstr subst c)
-  | TacLetTac (id,c,clp) -> TacLetTac (id,subst_rawconstr subst c,clp)
-(*| TacInstantiate (n,c,ido) -> TacInstantiate (n,subst_rawconstr subst c,ido)
-*)
+  | TacLetTac (id,c,clp,b) -> TacLetTac (id,subst_rawconstr subst c,clp,b)
+
   (* Automation tactics *)
   | TacTrivial (lems,l) -> TacTrivial (List.map (subst_rawconstr subst) lems,l)
   | TacAuto (n,lems,l) -> TacAuto (n,List.map (subst_rawconstr subst) lems,l)
@@ -2379,17 +2471,17 @@ let rec subst_atomic subst (t:glob_atomic_tactic_expr) = match t with
   | TacDestructHyp (b,id) -> TacDestructHyp(b,id)
   | TacDestructConcl -> TacDestructConcl
   | TacSuperAuto (n,l,b1,b2) -> TacSuperAuto (n,l,b1,b2)
-  | TacDAuto (n,p) -> TacDAuto (n,p)
+  | TacDAuto (n,p,lems) -> TacDAuto (n,p,List.map (subst_rawconstr subst) lems)
 
   (* Derived basic tactics *)
   | TacSimpleInduction h as x -> x
-  | TacNewInduction (lc,cbo,ids) -> (* Pierre C. est-ce correct? *)
-      TacNewInduction (List.map (subst_induction_arg subst) lc,
-               option_map (subst_raw_with_bindings subst) cbo, ids)
+  | TacNewInduction (ev,lc,cbo,ids,cls) ->
+      TacNewInduction (ev,List.map (subst_induction_arg subst) lc,
+               Option.map (subst_raw_with_bindings subst) cbo, ids, cls)
   | TacSimpleDestruct h as x -> x
-  | TacNewDestruct (c,cbo,ids) ->
-      TacNewDestruct (List.map (subst_induction_arg subst) c,  (* Julien F. est-ce correct? *)
-               option_map (subst_raw_with_bindings subst) cbo, ids)
+  | TacNewDestruct (ev,c,cbo,ids,cls) ->
+      TacNewDestruct (ev,List.map (subst_induction_arg subst) c,
+               Option.map (subst_raw_with_bindings subst) cbo, ids, cls)
   | TacDoubleInduction (h1,h2) as x -> x
   | TacDecomposeAnd c -> TacDecomposeAnd (subst_rawconstr subst c)
   | TacDecomposeOr c -> TacDecomposeOr (subst_rawconstr subst c)
@@ -2403,19 +2495,20 @@ let rec subst_atomic subst (t:glob_atomic_tactic_expr) = match t with
   | TacClear _ as x -> x
   | TacClearBody l as x -> x
   | TacMove (dep,id1,id2) as x -> x
-  | TacRename (id1,id2) as x -> x
+  | TacRename l as x -> x
+  | TacRevert _ as x -> x
 
   (* Constructors *)
-  | TacLeft bl -> TacLeft (subst_bindings subst bl)
-  | TacRight bl -> TacRight (subst_bindings subst bl)
-  | TacSplit (b,bl) -> TacSplit (b,subst_bindings subst bl)
-  | TacAnyConstructor t -> TacAnyConstructor (option_map (subst_tactic subst) t)
-  | TacConstructor (n,bl) -> TacConstructor (n, subst_bindings subst bl)
+  | TacLeft (ev,bl) -> TacLeft (ev,subst_bindings subst bl)
+  | TacRight (ev,bl) -> TacRight (ev,subst_bindings subst bl)
+  | TacSplit (ev,b,bl) -> TacSplit (ev,b,subst_bindings subst bl)
+  | 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 (occl,c,cl) ->
-      TacChange (option_map (subst_constr_occurrence subst) occl,
+      TacChange (Option.map (subst_constr_with_occurrences subst) occl,
         subst_rawconstr subst c, cl)
 
   (* Equivalence relations *)
@@ -2423,9 +2516,13 @@ let rec subst_atomic subst (t:glob_atomic_tactic_expr) = match t with
   | TacTransitivity c -> TacTransitivity (subst_rawconstr subst c)
 
   (* Equality and inversion *)
-  | TacRewrite (b,c,cl) -> TacRewrite (b, subst_raw_with_bindings subst c,cl)
+  | TacRewrite (ev,l,cl,by) -> 
+      TacRewrite (ev, 
+		  List.map (fun (b,m,c) ->
+			      b,m,subst_raw_with_bindings subst c) l,
+		 cl,Option.map (subst_tactic subst) by)
   | TacInversion (DepInversion (k,c,l),hyp) ->
-     TacInversion (DepInversion (k,option_map (subst_rawconstr subst) c,l),hyp)
+     TacInversion (DepInversion (k,Option.map (subst_rawconstr subst) c,l),hyp)
   | TacInversion (NonDepInversion _,_) as x -> x
   | TacInversion (InversionUsing (c,cl),hyp) ->
       TacInversion (InversionUsing (subst_rawconstr subst c,cl),hyp)
@@ -2440,12 +2537,9 @@ let rec subst_atomic subst (t:glob_atomic_tactic_expr) = match t with
 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)
-  | TacLetRecIn (lrc,u) ->
-      let lrc = List.map (fun (n,b) -> (n,subst_tactic_fun subst b)) lrc in
-      TacLetRecIn (lrc,(subst_tactic subst u:glob_tactic_expr))
-  | TacLetIn (l,u) ->
-      let l = List.map (fun (n,c,b) -> (n,option_map (subst_tactic subst) c,subst_tacarg subst b)) l in
-      TacLetIn (l,subst_tactic subst u)
+  | 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)
   | TacMatchContext (lz,lr,lmr) ->
       TacMatchContext(lz,lr, subst_match_rule subst lmr)
   | TacMatch (lz,c,lmr) ->
@@ -2453,8 +2547,9 @@ and subst_tactic subst (t:glob_tactic_expr) = match t with
   | 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,t2) ->
-      TacThen (subst_tactic subst t1,subst_tactic subst t2)
+  | 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)
@@ -2473,7 +2568,7 @@ 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
+  | 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) -> 
@@ -2558,27 +2653,46 @@ let bad_tactic_args s =
 (* Declaration of the TAC-DEFINITION object *)
 let add (kn,td) = mactab := Gmap.add kn td !mactab
 
+type tacdef_kind = | NewTac of identifier
+		   | UpdateTac of ltac_constant
+
 let load_md i ((sp,kn),defs) =
   let dp,_ = repr_path sp in
   let mp,dir,_ = repr_kn kn in
   List.iter (fun (id,t) -> 
-    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)) defs
-
+    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 ->
+	  mactab := Gmap.remove kn !mactab;
+	  add (kn,t)) defs
+    
 let open_md i((sp,kn),defs) =
   let dp,_ = repr_path sp in
   let mp,dir,_ = repr_kn kn in
   List.iter (fun (id,t) -> 
-    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) defs
+    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 -> 
+	  let (path, id) = decode_kn kn in
+	  let sp = Libnames.make_path path id in
+	  Nametab.push_tactic (Exactly i) sp kn) defs
 
 let cache_md x = load_md 1 x
 
+let subst_kind subst id = 
+  match id with
+    | NewTac _ -> id
+    | UpdateTac kn -> UpdateTac (Mod_subst.subst_kn subst kn)
+
 let subst_md (_,subst,defs) =
-  List.map (fun (id,t) -> (id,subst_tactic subst t)) defs
+  List.map (fun (id,t) -> (subst_kind subst id,subst_tactic subst t)) defs
 
 let (inMD,outMD) =
   declare_object {(default_object "TAC-DEFINITION") with
@@ -2600,28 +2714,61 @@ let print_ltac id =
    errorlabstrm "print_ltac"
     (pr_qualid id ++ spc() ++ str "is not a user defined tactic")
 
+open Libnames
+
 (* Adds a definition for tactics in the table *)
-let make_absolute_name (loc,id) =
-  let kn = Lib.make_kn id in
-  if Gmap.mem kn !mactab or is_atomic_kn kn then
+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 = Pcoq.coerce_global_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)
+      else if is_atomic_kn kn then 
+	user_err_loc (loc,"Tacinterp.add_tacdef",
+		     str "Reserved Ltac name " ++ pr_reference ident)
+      else id, kn
+  with Not_found ->
     user_err_loc (loc,"Tacinterp.add_tacdef",
-      str "There is already an Ltac named " ++ pr_id id);
-  kn
-
+		 str "There is no Ltac named " ++ pr_reference ident)
+
+let rec filter_map f l = 
+  let rec aux acc = function
+      [] -> acc
+    | hd :: tl -> 
+	match f hd with
+	    Some x -> aux (x :: acc) tl
+	  | None -> aux acc tl
+  in aux [] l
+      
 let add_tacdef isrec tacl =
-(*  let isrec = if !Options.p1 then isrec else true in*)
-  let rfun = List.map (fun ((loc,id as locid),_) -> (id,make_absolute_name locid)) tacl in
+  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 rfun else []} in
+    {(make_empty_glob_sign()) with ltacrecvars = 
+	if isrec then filter_map 
+	  (function (Some id, qid) -> Some (id, qid) | (None, _) -> None) rfun 
+	else []} in
   let gtacl =
-    List.map (fun ((_,id),def) ->
-      (id,Options.with_option strict_check (intern_tactic ist) def))
-      tacl in
+    List.map2 (fun (_,b,def) (id, qid) ->
+      let k = if b then UpdateTac qid else NewTac (Option.get id) in
+      let t = Flags.with_option strict_check (intern_tactic ist) def in
+	(k, t))
+      tacl rfun in
   let id0 = fst (List.hd rfun) in
-  let _ = Lib.add_leaf id0 (inMD gtacl) in
+  let _ = match id0 with Some id0 -> ignore(Lib.add_leaf id0 (inMD gtacl))
+    | _ -> Lib.add_anonymous_leaf (inMD gtacl) in
   List.iter
-    (fun (id,_) -> Options.if_verbose msgnl (pr_id id ++ str " is defined"))
-    rfun
+    (fun (id,b,_) -> 
+      Flags.if_verbose msgnl (Libnames.pr_reference id ++ 
+				 (if b then str " is redefined"
+				   else str " is defined")))
+    tacl
 
 (***************************************************************************)
 (* Other entry points *)
@@ -2629,13 +2776,13 @@ let add_tacdef isrec tacl =
 let glob_tactic x = intern_tactic (make_empty_glob_sign ()) x
 
 let glob_tactic_env l env x = 
-  Options.with_option strict_check
+  Flags.with_option strict_check
   (intern_tactic
     { ltacvars = (l,[]); ltacrecvars = []; gsigma = Evd.empty; genv = env })
     x
 
 let interp_redexp env sigma r = 
-  let ist = { lfun=[]; debug=get_debug () } in
+  let ist = { lfun=[]; avoid_ids=[]; debug=get_debug (); last_loc=dloc } in
   let gist = {(make_empty_glob_sign ()) with genv = env; gsigma = sigma } in
   interp_red_expr ist sigma env (intern_red_expr gist r)
 
@@ -2645,10 +2792,10 @@ let interp_redexp env sigma r =
 let _ = Auto.set_extern_interp
   (fun l -> 
     let l = List.map (fun (id,c) -> (id,VConstr c)) l in
-    interp_tactic {lfun=l;debug=get_debug()})
+    interp_tactic {lfun=l;avoid_ids=[];debug=get_debug(); last_loc=dloc})
 let _ = Auto.set_extern_intern_tac 
   (fun l ->
-    Options.with_option strict_check
+    Flags.with_option strict_check
     (intern_tactic {(make_empty_glob_sign()) with ltacvars=(l,[])}))
 let _ = Auto.set_extern_subst_tactic subst_tactic
 let _ = Dhyp.set_extern_interp eval_tactic
diff --git a/tactics/tacinterp.mli b/tactics/tacinterp.mli
index 01e7750a..87aa85dc 100644
--- a/tactics/tacinterp.mli
+++ b/tactics/tacinterp.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: tacinterp.mli 9178 2006-09-26 11:18:22Z barras $ i*)
+(*i $Id: tacinterp.mli 10919 2008-05-11 22:04:26Z msozeau $ i*)
 
 (*i*)
 open Dyn
@@ -35,12 +35,14 @@ type value =
   | VConstr of constr
   | VConstr_context of constr
   | VList of value list
-  | VRec of value ref
+  | VRec of (identifier*value) list ref * glob_tactic_expr
 
 (* Signature for interpretation: val\_interp and interpretation functions *)
 and interp_sign =
   { lfun : (identifier * value) list;
-    debug : debug_info }
+    avoid_ids : identifier list;
+    debug : debug_info;
+    last_loc : loc }
 
 (* Transforms an id into a constr if possible *)
 val constr_of_id : Environ.env -> identifier -> constr
@@ -61,16 +63,16 @@ val get_debug : unit -> debug_info
 
 (* Adds a definition for tactics in the table *)
 val add_tacdef :
-  bool -> (identifier Util.located * raw_tactic_expr) list -> unit
+  bool -> (Libnames.reference * bool * raw_tactic_expr) list -> unit
 val add_primitive_tactic : string -> glob_tactic_expr -> unit
 
 (* Tactic extensions *)
 val add_tactic :
-  string -> (closed_generic_argument list -> tactic) -> unit
+  string -> (typed_generic_argument list -> tactic) -> unit
 val overwriting_add_tactic :
-  string -> (closed_generic_argument list -> tactic) -> unit
+  string -> (typed_generic_argument list -> tactic) -> unit
 val lookup_tactic :
-  string -> (closed_generic_argument list) -> tactic
+  string -> (typed_generic_argument list) -> tactic
 
 (* Adds an interpretation function for extra generic arguments *)
 type glob_sign = {
@@ -83,12 +85,12 @@ val add_interp_genarg :
   string ->
     (glob_sign -> raw_generic_argument -> glob_generic_argument) *
     (interp_sign -> goal sigma -> glob_generic_argument -> 
-      closed_generic_argument) *
+      typed_generic_argument) *
     (substitution -> glob_generic_argument -> glob_generic_argument)
     -> unit
 
 val interp_genarg :
-  interp_sign -> goal sigma -> glob_generic_argument -> closed_generic_argument
+  interp_sign -> goal sigma -> glob_generic_argument -> typed_generic_argument
 
 val intern_genarg :
   glob_sign -> raw_generic_argument -> glob_generic_argument
@@ -119,7 +121,7 @@ val interp_ltac_constr : interp_sign -> goal sigma -> glob_tactic_expr ->
 val interp_redexp : Environ.env -> Evd.evar_map -> raw_red_expr -> red_expr
 
 (* Interprets tactic expressions *)
-val interp_tac_gen : (identifier * value) list -> 
+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
@@ -150,3 +152,14 @@ val declare_xml_printer :
 
 (* printing *)
 val print_ltac : Libnames.qualid -> std_ppcmds
+
+(* Internals that can be useful for syntax extensions. *)
+
+exception CannotCoerceTo of string
+
+val interp_ltac_var : (value -> 'a) -> interp_sign -> Environ.env option -> identifier located -> 'a
+
+val interp_int : interp_sign -> identifier located -> int
+
+val error_ltac_variable : loc -> identifier -> Environ.env option -> value -> string -> 'a
+
diff --git a/tactics/tacticals.ml b/tactics/tacticals.ml
index 06289169..eeca6301 100644
--- a/tactics/tacticals.ml
+++ b/tactics/tacticals.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: tacticals.ml 9211 2006-10-05 12:38:33Z letouzey $ *)
+(* $Id: tacticals.ml 11166 2008-06-22 13:23:35Z herbelin $ *)
 
 open Pp
 open Util
@@ -23,6 +23,7 @@ open Refiner
 open Tacmach
 open Clenv
 open Clenvtac
+open Rawterm
 open Pattern
 open Matching
 open Evar_refiner
@@ -37,6 +38,7 @@ open Tacexpr
 (* Tacticals re-exported from the Refiner module.*)
 (*************************************************)
 
+let tclNORMEVAR      = tclNORMEVAR
 let tclIDTAC         = tclIDTAC
 let tclIDTAC_MESSAGE = tclIDTAC_MESSAGE
 let tclORELSE        = tclORELSE
@@ -90,6 +92,10 @@ let tclNTH_HYP m (tac : constr->tactic) gl =
 
 let tclLAST_HYP = tclNTH_HYP 1
 
+let tclLAST_NHYPS n tac gl =
+  tac (try list_firstn n (pf_ids_of_hyps gl)
+       with Failure _ -> error "No such assumptions") gl
+
 let tclTRY_sign (tac : constr->tactic) sign gl =
   let rec arec = function
     | []      -> tclFAIL 0 (str "no applicable hypothesis")
@@ -118,17 +124,21 @@ let tclTRY_HYPS (tac : constr->tactic) gl =
 type simple_clause = identifier gsimple_clause
 type clause = identifier gclause
 
-let allClauses = { onhyps=None; onconcl=true; concl_occs=[] }
-let allHyps = { onhyps=None; onconcl=false; concl_occs=[] }
-let onHyp id = { onhyps=Some[(([],id),InHyp)]; onconcl=false; concl_occs=[] }
-let onConcl = { onhyps=Some[]; onconcl=true; concl_occs=[] }
+let allClauses = { 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_list_of cl gls =
   let hyps =
     match cl.onhyps with 
-        None -> List.map (fun id -> Some(([],id),InHyp)) (pf_ids_of_hyps gls)
-      | Some l -> List.map (fun h -> Some h) l in
-  if cl.onconcl then None::hyps else hyps
+    | None ->
+	let f id = Some((all_occurrences_expr,id),InHyp) in
+	List.map f (pf_ids_of_hyps gls)
+    | Some l ->
+	List.map (fun h -> Some h) l in
+  if cl.concl_occs = all_occurrences_expr then None::hyps else hyps
 
 
 (* OR-branch *)
@@ -315,16 +325,12 @@ let elimination_sort_of_hyp id gl =
 (* 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 last_arg c = match kind_of_term c with
-  | App (f,cl) -> array_last cl
-  | _ -> anomaly "last_arg"
-
-let general_elim_then_using 
-  elim isrec allnames tac predicate (indbindings,elimbindings) c gl =
-  let (ity,t) = pf_reduce_to_quantified_ind gl (pf_type_of gl c) in
+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  = mk_clenv_from gl (c,t) in
-  let indclause' = clenv_constrain_with_bindings indbindings indclause in
+  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
@@ -345,8 +351,8 @@ let general_elim_then_using
 	  error ("The elimination combinator " ^ name_elim ^ " is not known") 
   in
   let elimclause' = clenv_fchain indmv elimclause indclause' in
-  let elimclause' = clenv_constrain_with_bindings elimbindings elimclause' in
-  let branchsigns = compute_construtor_signatures isrec ity 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
@@ -357,7 +363,7 @@ let general_elim_then_using
                    (fun acc b -> if b then acc+2 else acc+1)
                    0 branchsigns.(i);
                branchnum = i+1;
-               ity = ity;
+               ity = ind;
                largs = List.map (clenv_nf_meta ce) largs;
                pred = clenv_nf_meta ce hd }
     in 
@@ -372,37 +378,32 @@ let general_elim_then_using
   in 
   elim_res_pf_THEN_i elimclause' branchtacs gl
 
+(* computing the case/elim combinators *)
+
+let gl_make_elim ind gl =
+  Indrec.lookup_eliminator ind (elimination_sort_of_goal gl)
+
+let gl_make_case_dep ind gl =
+  pf_apply Indrec.make_case_dep gl ind (elimination_sort_of_goal gl)
 
-let elimination_then_using tac predicate (indbindings,elimbindings) c gl = 
+let gl_make_case_nodep ind gl =
+  pf_apply Indrec.make_case_nodep gl ind (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 elim =
-    Indrec.lookup_eliminator ind (elimination_sort_of_goal gl) in
-  general_elim_then_using
-    elim true IntroAnonymous tac predicate (indbindings,elimbindings) c gl
+  let indclause  = mk_clenv_from gl (c,t) in
+  general_elim_then_using gl_make_elim
+    true IntroAnonymous 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 case_then_using allnames tac predicate (indbindings,elimbindings) c gl =
-  (* finding the case combinator *)
-  let (ity,t) = pf_reduce_to_quantified_ind gl (pf_type_of gl c) in
-  let sigma = project gl in 
-  let sort  = elimination_sort_of_goal gl  in
-  let elim  = Indrec.make_case_dep (pf_env gl) sigma ity sort in  
-  general_elim_then_using 
-    elim false allnames tac predicate (indbindings,elimbindings) c gl
-
-let case_nodep_then_using allnames tac predicate (indbindings,elimbindings)
-  c gl =
-  (* finding the case combinator *)
-  let (ity,t) = pf_reduce_to_quantified_ind gl (pf_type_of gl c) in
-  let sigma = project gl in 
-  let sort  = elimination_sort_of_goal gl  in
-  let elim  = Indrec.make_case_nodep (pf_env gl) sigma ity sort in  
-  general_elim_then_using 
-    elim false allnames tac predicate (indbindings,elimbindings) c gl
-
 
 let make_elim_branch_assumptions ba gl =   
   let rec makerec (assums,cargs,constargs,recargs,indargs) lb lc =
diff --git a/tactics/tacticals.mli b/tactics/tacticals.mli
index 458ab732..e97abe9f 100644
--- a/tactics/tacticals.mli
+++ b/tactics/tacticals.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: tacticals.mli 9211 2006-10-05 12:38:33Z letouzey $ i*)
+(*i $Id: tacticals.mli 10785 2008-04-13 21:41:54Z herbelin $ i*)
 
 (*i*)
 open Pp
@@ -24,6 +24,7 @@ open Tacexpr
 
 (* Tacticals i.e. functions from tactics to tactics. *)
 
+val tclNORMEVAR      : tactic
 val tclIDTAC         : tactic
 val tclIDTAC_MESSAGE : std_ppcmds -> tactic
 val tclORELSE        : tactic -> tactic -> tactic
@@ -57,6 +58,7 @@ val tclTHENTRY       : tactic -> tactic -> tactic
 val tclNTH_HYP       : int -> (constr -> tactic) -> tactic
 val tclMAP           : ('a -> tactic) -> 'a list -> tactic
 val tclLAST_HYP      : (constr -> tactic) -> tactic
+val tclLAST_NHYPS    : int -> (identifier list -> tactic) -> tactic
 val tclTRY_sign      : (constr -> tactic) -> named_context -> tactic
 val tclTRY_HYPS      : (constr -> tactic) -> tactic
 
@@ -136,9 +138,9 @@ val elimination_sort_of_goal : goal sigma -> sorts_family
 val elimination_sort_of_hyp  : identifier -> goal sigma -> sorts_family
 
 val general_elim_then_using :
-  constr -> (* isrec: *) bool -> intro_pattern_expr ->
+  (inductive -> goal sigma -> constr) -> rec_flag -> intro_pattern_expr ->
     (branch_args -> tactic) -> constr option -> 
-      (arg_bindings * arg_bindings) -> constr -> tactic
+      (arg_bindings * arg_bindings) -> inductive -> clausenv -> tactic
 	  
 val elimination_then_using :
   (branch_args -> tactic) -> constr option -> 
@@ -150,11 +152,13 @@ val elimination_then :
 
 val case_then_using :
   intro_pattern_expr -> (branch_args -> tactic) -> 
-    constr option -> (arg_bindings * arg_bindings) -> constr -> tactic
+    constr option -> (arg_bindings * arg_bindings) ->
+      inductive -> clausenv -> tactic
 
 val case_nodep_then_using :
   intro_pattern_expr -> (branch_args -> tactic) -> 
-    constr option -> (arg_bindings * arg_bindings) -> constr -> tactic
+    constr option -> (arg_bindings * arg_bindings) -> 
+      inductive -> clausenv -> tactic
 
 val simple_elimination_then :
   (branch_args -> tactic) -> constr -> tactic
diff --git a/tactics/tactics.ml b/tactics/tactics.ml
index c863a453..88274ef6 100644
--- a/tactics/tactics.ml
+++ b/tactics/tactics.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: tactics.ml 9853 2007-05-23 14:25:47Z letouzey $ *)
+(* $Id: tactics.ml 11166 2008-06-22 13:23:35Z herbelin $ *)
 
 open Pp
 open Util
@@ -42,6 +42,8 @@ open Tacexpr
 open Decl_kinds
 open Evarutil
 open Indrec
+open Pretype_errors
+open Unification
 
 exception Bound
 
@@ -54,6 +56,25 @@ let rec nb_prod x =
       | _ -> n
   in count 0 x
 
+let inj_with_occurrences e = (all_occurrences_expr,e)
+
+let inj_open c = (Evd.empty,c)
+
+let inj_occ (occ,c) = (occ,inj_open c)
+
+let inj_red_expr = function
+  | Simpl lo -> Simpl (Option.map inj_occ lo)
+  | Fold l -> Fold (List.map inj_open l)
+  | Pattern l -> Pattern (List.map inj_occ l)
+  | (ExtraRedExpr _ | CbvVm | Red _ | Hnf | Cbv _ | Lazy _ | Unfold _ as c)
+    -> c
+
+let inj_ebindings = function
+  | NoBindings -> NoBindings
+  | ImplicitBindings l -> ImplicitBindings (List.map inj_open l)
+  | ExplicitBindings l -> 
+      ExplicitBindings (List.map (fun (l,id,c) -> (l,id,inj_open c)) l)
+
 (*********************************************)
 (*                 Tactics                   *)
 (*********************************************)
@@ -149,7 +170,7 @@ let reduct_in_concl (redfun,sty) gl =
 
 let reduct_in_hyp redfun ((_,id),where) gl =
   let (_,c, ty) = pf_get_hyp gl id in
-  let redfun' = (*under_casts*) (pf_reduce redfun gl) in
+  let redfun' = pf_reduce redfun gl in
   match c with
   | None -> 
       if where = InHypValueOnly then
@@ -195,7 +216,8 @@ let change_option occl t = function
 
 let change occl c cls =
   (match cls, occl with
-      ({onhyps=(Some(_::_::_)|None)}|{onhyps=Some(_::_);onconcl=true}),
+      ({onhyps=(Some(_::_::_)|None)}
+      |{onhyps=Some(_::_);concl_occs=((false,_)|(true,_::_))}),
       Some _ ->
 	error "No occurrences expected when changing several hypotheses"
     | _ -> ());
@@ -208,9 +230,9 @@ let red_option          = reduct_option   (red_product,DEFAULTcast)
 let hnf_in_concl        = reduct_in_concl (hnf_constr,DEFAULTcast)
 let hnf_in_hyp          = reduct_in_hyp   hnf_constr
 let hnf_option          = reduct_option   (hnf_constr,DEFAULTcast)
-let simpl_in_concl      = reduct_in_concl (nf,DEFAULTcast)
-let simpl_in_hyp        = reduct_in_hyp   nf
-let simpl_option        = reduct_option   (nf,DEFAULTcast)
+let simpl_in_concl      = reduct_in_concl (simpl,DEFAULTcast)
+let simpl_in_hyp        = reduct_in_hyp   simpl
+let simpl_option        = reduct_option   (simpl,DEFAULTcast)
 let normalise_in_concl  = reduct_in_concl (compute,DEFAULTcast)
 let normalise_in_hyp    = reduct_in_hyp   compute
 let normalise_option    = reduct_option   (compute,DEFAULTcast)
@@ -237,8 +259,8 @@ let reduce redexp cl goal =
 (* Unfolding occurrences of a constant *)
 
 let unfold_constr = function 
-  | ConstRef sp -> unfold_in_concl [[],EvalConstRef sp]
-  | VarRef id -> unfold_in_concl [[],EvalVarRef id]
+  | ConstRef sp -> unfold_in_concl [all_occurrences,EvalConstRef sp]
+  | VarRef id -> unfold_in_concl [all_occurrences,EvalVarRef id]
   | _ -> errorlabstrm "unfold_constr" (str "Cannot unfold a non-constant.")
 
 (*******************************************)
@@ -340,7 +362,7 @@ let intros = tclREPEAT (intro_force false)
 
 let intro_erasing id = tclTHEN (thin [id]) (introduction id)
 
-let intros_replacing ids gls = 
+let intros_replacing ids gl = 
   let rec introrec = function
     | [] -> tclIDTAC
     | id::tl ->
@@ -349,7 +371,7 @@ let intros_replacing ids gls =
                        (intro_using id)))
            (introrec tl))
   in 
-  introrec ids gls
+  introrec ids gl
 
 (* User-level introduction tactics *)
 
@@ -381,7 +403,7 @@ let is_quantified_hypothesis id g =
 
 let msg_quantified_hypothesis = function
   | NamedHyp id -> 
-      str "hypothesis " ++ pr_id id
+      str "quantified hypothesis named " ++ pr_id id
   | AnonHyp n ->
       int n ++ str (match n with 1 -> "st" | 2 -> "nd" | _ -> "th") ++
       str " non dependent hypothesis"
@@ -392,8 +414,8 @@ let depth_of_quantified_hypothesis red h gl =
     | None ->
         errorlabstrm "lookup_quantified_hypothesis" 
           (str "No " ++ msg_quantified_hypothesis h ++
-	  str " in current goal" ++
-	  if red then str " even after head-reduction" else mt ())
+	  strbrk " in current goal" ++
+	  if red then strbrk " even after head-reduction" else mt ())
 
 let intros_until_gen red h g =
   tclDO (depth_of_quantified_hypothesis red h g) intro g
@@ -447,6 +469,21 @@ let rec intros_rmove = function
  		    move_to_rhyp destopt;
 		    intros_rmove rest ]
 
+(* Apply a tactic on a quantified hypothesis, an hypothesis in context
+   or a term with bindings *)
+
+let onInductionArg tac = function
+  | ElimOnConstr (c,lbindc as cbl) -> 
+      if isVar c & lbindc = NoBindings then 
+	tclTHEN (tclTRY (intros_until_id (destVar c))) (tac cbl)
+      else
+	tac cbl
+  | ElimOnAnonHyp n ->
+      tclTHEN (intros_until_n n) (tclLAST_HYP (fun c -> tac (c,NoBindings)))
+  | ElimOnIdent (_,id) ->
+      (*Identifier apart because id can be quantified in goal and not typable*)
+      tclTHEN (tclTRY (intros_until_id id)) (tac (mkVar id,NoBindings))
+
 (**************************)
 (*  Refinement tactics    *)
 (**************************)
@@ -504,55 +541,228 @@ let cut_in_parallel l =
     prec (List.rev l)
 
 let error_uninstantiated_metas t clenv =
-  let na = meta_name clenv.env (List.hd (Metaset.elements (metavars_of t))) in
+  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"
   in errorlabstrm "" (str "cannot find an instance for " ++ pr_id id)
 
-let clenv_refine_in id clenv gl =
+let clenv_refine_in with_evars id clenv gl =
+  let clenv = clenv_pose_dependent_evars with_evars clenv in
   let new_hyp_typ  = clenv_type clenv in
-  if occur_meta new_hyp_typ then error_uninstantiated_metas new_hyp_typ 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 (evars_of clenv.env))
+    (tclEVARS (evars_of clenv.evd))
     (cut_replacing id new_hyp_typ
       (fun x gl -> refine_no_check new_hyp_prf gl)) gl
 
+
+(********************************************)
+(*       Elimination tactics                *)
+(********************************************)
+
+let last_arg c = match kind_of_term c with
+  | App (f,cl) ->  
+      array_last cl
+  | _ -> anomaly "last_arg"
+
+let elim_flags = {
+  modulo_conv_on_closed_terms = Some full_transparent_state; 
+  use_metas_eagerly = true;
+  modulo_delta = empty_transparent_state;
+}
+
+let elimination_clause_scheme with_evars allow_K elimclause indclause gl = 
+  let indmv = 
+    (match kind_of_term (last_arg elimclause.templval.rebus) with
+       | Meta mv -> mv
+       | _  -> errorlabstrm "elimination_clause"
+             (str "The type of elimination clause is not well-formed")) 
+  in
+  let elimclause' = clenv_fchain indmv elimclause indclause in 
+  res_pf elimclause' ~with_evars:with_evars ~allow_K:allow_K ~flags:elim_flags
+    gl
+
+(* cast added otherwise tactics Case (n1,n2) generates (?f x y) and 
+ * refine fails *)
+
+let type_clenv_binding wc (c,t) lbind = 
+  clenv_type (make_clenv_binding wc (c,t) lbind)
+
+(* 
+ * Elimination tactic with bindings and using an arbitrary 
+ * elimination constant called elimc. This constant should end 
+ * with a clause (x:I)(P .. ), where P is a bound variable.
+ * The term c is of type t, which is a product ending with a type 
+ * matching I, lbindc are the expected terms for c arguments 
+ *)
+
+let general_elim_clause elimtac (c,lbindc) (elimc,lbindelimc) 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
+  let elimt      = pf_type_of gl elimc in
+  let elimclause = make_clenv_binding gl (elimc,elimt) lbindelimc in 
+    elimtac elimclause indclause gl
+
+let general_elim with_evars c e ?(allow_K=true) =
+  general_elim_clause (elimination_clause_scheme with_evars allow_K) c e
+
+(* 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
+  lookup_eliminator ind (elimination_sort_of_goal gl)
+
+let default_elim with_evars (c,_ as cx) gl = 
+  general_elim with_evars cx (find_eliminator c gl,NoBindings) gl
+
+let elim_in_context with_evars c = function
+  | Some elim -> general_elim with_evars c elim ~allow_K:true
+  | None -> default_elim with_evars c
+
+let elim with_evars (c,lbindc as cx) elim =
+  match kind_of_term c with
+    | Var id when lbindc = NoBindings ->
+	tclTHEN (tclTRY (intros_until_id id))
+	  (elim_in_context with_evars cx elim)
+    | _ -> elim_in_context with_evars cx elim
+
+(* The simplest elimination tactic, with no substitutions at all. *)
+
+let simplest_elim c = default_elim false (c,NoBindings)
+
+(* Elimination in hypothesis *)
+(* Typically, elimclause := (eq_ind ?x ?P ?H ?y ?Heq : ?P ?y)
+              indclause : forall ..., hyps -> a=b    (to take place of ?Heq)
+              id : phi(a)                            (to take place of ?H)
+      and the result is to overwrite id with the proof of phi(b)
+
+   but this generalizes to any elimination scheme with one constructor
+   (e.g. it could replace id:A->B->C by id:C, knowing A/\B)
+*)
+
+let elimination_in_clause_scheme with_evars id elimclause indclause gl =
+  let (hypmv,indmv) = 
+    match clenv_independent elimclause with
+        [k1;k2] -> (k1,k2)
+      | _  -> errorlabstrm "elimination_clause"
+          (str "The type of elimination clause is not well-formed") in
+  let elimclause'  = clenv_fchain indmv elimclause indclause in 
+  let hyp = mkVar id in
+  let hyp_typ = pf_type_of gl hyp in
+  let hypclause = mk_clenv_from_n gl (Some 0) (hyp, hyp_typ) in
+  let elimclause'' =
+    clenv_fchain ~allow_K:false ~flags:elim_flags hypmv elimclause' hypclause in
+  let new_hyp_typ  = clenv_type elimclause'' in
+  if eq_constr hyp_typ new_hyp_typ then
+    errorlabstrm "general_rewrite_in" 
+      (str "Nothing to rewrite in " ++ pr_id id);
+  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 case = 
+    if occur_term c (pf_concl gl) then make_case_dep else make_case_gen in
+  let elim     = pf_apply case gl mind sort in 
+  general_elim with_evars (c,lbindc) (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 (tclTRY (intros_until_id id))
+	(general_case_analysis_in_context with_evars cx)
+    | _ ->
+	general_case_analysis_in_context with_evars cx
+
+let simplest_case c = general_case_analysis false (c,NoBindings)
+
 (****************************************************)
 (*            Resolution tactics                    *)
 (****************************************************)
 
 (* Resolution with missing arguments *)
 
-let apply_with_bindings (c,lbind) gl = 
+let general_apply with_delta with_destruct with_evars (c,lbind) gl =
+  let flags = 
+    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 gl) in
+  let rec try_main_apply c gl =
   let thm_ty0 = nf_betaiota (pf_type_of gl c) in
-  let rec try_apply thm_ty =
-    try
-      let n = nb_prod thm_ty - nb_prod (pf_concl gl) in
-      if n<0 then error "Apply: theorem has not enough premisses.";
-      let clause = make_clenv_binding_apply gl (Some n) (c,thm_ty) lbind in
-      Clenvtac.res_pf clause gl
-    with (Pretype_errors.PretypeError _|RefinerError _|UserError _|Failure _) as exn ->
-      let red_thm =
-        try red_product (pf_env gl) (project gl) thm_ty
-        with (Redelimination | UserError _) -> raise exn in
-      try_apply red_thm in
-  try try_apply thm_ty0
-  with (Pretype_errors.PretypeError _|RefinerError _|UserError _|Failure _) ->
-    (* Last chance: if the head is a variable, apply may try
-       second order unification *)
-    let clause = make_clenv_binding_apply gl None (c,thm_ty0) lbind in 
-    Clenvtac.res_pf clause gl
-
-let apply c = apply_with_bindings (c,NoBindings)
+  let try_apply thm_ty nprod =
+    let n = nb_prod thm_ty - nprod in
+    if n<0 then error "Apply: 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 in
+  try try_apply thm_ty0 concl_nprod
+  with PretypeError _|RefinerError _|UserError _|Failure _ as exn ->
+    let rec try_red_apply thm_ty =
+      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 _ ->
+          try_red_apply red_thm
+      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 ->
+	  if with_destruct then
+	   try
+	    let (mind,t) = pf_reduce_to_quantified_ind gl (pf_type_of gl c) in
+	    match match_with_conjunction (snd (decompose_prod t)) with
+	    | Some _ ->
+	      let n = (mis_constr_nargs mind).(0) in
+	      let sort = elimination_sort_of_goal gl in
+	      let elim = pf_apply make_case_gen gl mind sort in
+	      tclTHENLAST
+		(general_elim with_evars (c,NoBindings) (elim,NoBindings))
+		(tclTHENLIST [
+		  tclDO n intro;
+		  tclLAST_NHYPS n (fun l ->
+		    tclFIRST
+		      (List.map (fun id ->
+			tclTHEN (try_main_apply (mkVar id)) (thin l)) l))
+		]) gl
+	    | None ->
+		raise Exit
+	   with RefinerError _|UserError _|Exit -> raise exn 
+	  else
+	    raise exn
+ in
+    try_red_apply thm_ty0 in
+  try_main_apply c gl
+
+let apply_with_ebindings_gen b = general_apply b b
+
+let apply_with_ebindings = apply_with_ebindings_gen false false
+let eapply_with_ebindings = apply_with_ebindings_gen false true
+
+let apply_with_bindings (c,bl) =
+  apply_with_ebindings (c,inj_ebindings bl)
+
+let eapply_with_bindings (c,bl) =
+  apply_with_ebindings_gen false true (c,inj_ebindings bl)
+
+let apply c =
+  apply_with_ebindings (c,NoBindings)
 
 let apply_list = function 
   | c::l -> apply_with_bindings (c,ImplicitBindings l)
   | _ -> assert false
 
-(* Resolution with no reduction on the type *)
+(* Resolution with no reduction on the type (used ?) *)
 
 let apply_without_reduce c gl = 
   let clause = mk_clenv_type_of gl c in 
@@ -576,20 +786,27 @@ let find_matching_clause unifier clause =
     with NotExtensibleClause -> failwith "Cannot apply"
   in find clause
 
-let apply_in_once gls innerclause (d,lbind) =
-  let thm = nf_betaiota (pf_type_of gls d) in
-  let clause = make_clenv_binding gls (d,thm) lbind in
+let progress_with_clause innerclause clause =
   let ordered_metas = List.rev (clenv_independent clause) in
   if ordered_metas = [] then error "Statement without assumptions";
   let f mv = find_matching_clause (clenv_fchain mv clause) innerclause in
   try list_try_find f ordered_metas
   with Failure _ -> error "Unable to unify"
 
-let apply_in id lemmas gls =
-  let t' = pf_get_hyp_typ gls id in
-  let innermostclause = mk_clenv_from_n gls (Some 0) (mkVar id,t') in
-  let clause = List.fold_left (apply_in_once gls) innermostclause lemmas in
-  clenv_refine_in id clause gls
+let apply_in_once gl innerclause (d,lbind) =
+  let thm = nf_betaiota (pf_type_of gl d) in
+  let rec aux clause =
+    try progress_with_clause innerclause clause
+    with err ->
+    try aux (clenv_push_prod clause)
+    with NotExtensibleClause -> raise err
+  in aux (make_clenv_binding gl (d,thm) lbind)
+
+let apply_in with_evars id lemmas gl =
+  let t' = pf_get_hyp_typ gl id in
+  let innermostclause = mk_clenv_from_n gl (Some 0) (mkVar id,t') in
+  let clause = List.fold_left (apply_in_once gl) innermostclause lemmas in
+  clenv_refine_in with_evars id clause gl
 
 (* A useful resolution tactic which, if c:A->B, transforms |- C into
    |- B -> C and |- A
@@ -612,7 +829,6 @@ 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
       | Prod (_,c1,c2) when not (dependent (mkRel 1) c2) ->
-	  let c2 = refresh_universes c2 in
 	  tclTHENLAST
 	    (apply_type (mkProd (Anonymous,c2,goal_constr)) [mkMeta(new_meta())])
 	    (apply_term c [mkMeta (new_meta())]) gl
@@ -681,21 +897,43 @@ let rec intros_clearing = function
       tclTHENLIST
         [ intro; onLastHyp (fun id -> clear [id]); intros_clearing tl]
 
-(* Adding new hypotheses  *)
-
-let new_hyp mopt (c,lbind) g =
-  let clause  = make_clenv_binding g (c,pf_type_of g c) lbind in
-  let (thd,tstack) = whd_stack (clenv_value clause) in
-  let nargs = List.length tstack in
-  let cut_pf = 
-    applist(thd, 
-            match mopt with
-	      | Some m -> if m < nargs then list_firstn m tstack else tstack
-	      | None   -> tstack)
-  in 
-  (tclTHENLAST (tclTHEN (tclEVARS (evars_of clause.env))
-               (cut (pf_type_of g cut_pf)))
-     ((tclORELSE (apply cut_pf) (exact_no_check cut_pf)))) g
+(* Modifying/Adding an hypothesis  *)
+
+let specialize mopt (c,lbind) g =
+  let evars, term = 
+    if lbind = NoBindings then None, c 
+    else 
+      let clause = make_clenv_binding g (c,pf_type_of g c) lbind in
+      let clause = clenv_unify_meta_types clause in
+      let (thd,tstack) = whd_stack (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
+      in 
+      let term = applist(thd,tstack) in 
+      if occur_meta term then
+	errorlabstrm "" (str "Cannot infer an instance for " ++
+          pr_name (meta_name clause.evd (List.hd (collect_metas term))));
+      Some (evars_of clause.evd), term
+  in
+  tclTHEN 
+    (match evars with Some e -> tclEVARS e | _ -> tclIDTAC)
+    (match kind_of_term (fst (decompose_app c)) with 
+       | Var id when List.exists (fun (i,_,_)-> i=id) (pf_hyps g) ->
+	   let id' = fresh_id [] id g in 
+	   tclTHENS (fun g -> internal_cut id' (pf_type_of g term) g)
+	     [ exact_no_check term; 
+	       tclTHEN (clear [id]) (rename_hyp [id',id]) ]
+       | _ -> tclTHENLAST 
+                 (fun g -> cut (pf_type_of g term) g)
+                 (exact_no_check term))
+    g
 
 (* Keeping only a few hypotheses *)
 
@@ -716,180 +954,112 @@ let keep hyps gl =
 (* Introduction tactics *)
 (************************)
 
-let constructor_tac boundopt i lbind gl =
+let check_number_of_constructors expctdnumopt i nconstr =
+  if i=0 then error "The constructors are numbered starting from 1";
+  begin match expctdnumopt with 
+    | Some n when n <> nconstr ->
+	error ("Not an inductive goal with "^
+	       string_of_int n^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
-  if i=0 then error "The constructors are numbered starting from 1";
-  if i > nconstr then error "Not enough constructors";
-  begin match boundopt with 
-    | Some expctdnum -> 
-        if expctdnum <> nconstr then 
-	  error "Not the expected number of constructors"
-    | None -> ()
-  end;
+  check_number_of_constructors expctdnumopt i nconstr;
   let cons = mkConstruct (ith_constructor_of_inductive mind i) in
-  let apply_tac = apply_with_bindings (cons,lbind) in
+  let apply_tac = general_apply true false with_evars (cons,lbind) in
   (tclTHENLIST 
      [convert_concl_no_check redcl DEFAULTcast; intros; apply_tac]) gl
 
-let one_constructor i = constructor_tac None i
+let one_constructor i = constructor_tac false None i
 
 (* Try to apply the constructor of the inductive definition followed by 
    a tactic t given as an argument.
    Should be generalize in Constructor (Fun c : I -> tactic)
  *)
 
-let any_constructor tacopt gl =
+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 (one_constructor i NoBindings) t) 
-              (interval 1 nconstr)) gl
+  tclFIRST
+    (List.map
+      (fun i -> tclTHEN (constructor_tac with_evars None i NoBindings) t) 
+      (interval 1 nconstr)) gl
 
-let left           = constructor_tac (Some 2) 1
-let simplest_left  = left NoBindings
+let left_with_ebindings  with_evars = constructor_tac with_evars (Some 2) 1
+let right_with_ebindings with_evars = constructor_tac with_evars (Some 2) 2
+let split_with_ebindings with_evars = constructor_tac with_evars (Some 1) 1
 
-let right          = constructor_tac (Some 2) 2
-let simplest_right = right NoBindings
+let left l             = left_with_ebindings false (inj_ebindings l)
+let simplest_left      = left NoBindings
 
-let split          = constructor_tac (Some 1) 1
-let simplest_split = split NoBindings
+let right l            = right_with_ebindings false (inj_ebindings l)
+let simplest_right     = right NoBindings
 
-(********************************************)
-(*       Elimination tactics                *)
-(********************************************)
-
-let last_arg c = match kind_of_term c with
-  | App (f,cl) ->  
-      array_last cl
-  | _ -> anomaly "last_arg"
-	
-let elimination_clause_scheme allow_K elimclause indclause gl = 
-  let indmv = 
-    (match kind_of_term (last_arg elimclause.templval.rebus) with
-       | Meta mv -> mv
-       | _  -> errorlabstrm "elimination_clause"
-             (str "The type of elimination clause is not well-formed")) 
-  in
-  let elimclause' = clenv_fchain indmv elimclause indclause in 
-  res_pf elimclause' ~allow_K:allow_K gl
+let split l            = split_with_ebindings false (inj_ebindings l)
+let simplest_split     = split NoBindings
 
-(* cast added otherwise tactics Case (n1,n2) generates (?f x y) and 
- * refine fails *)
-
-let type_clenv_binding wc (c,t) lbind = 
-  clenv_type (make_clenv_binding wc (c,t) lbind)
-
-(* 
- * Elimination tactic with bindings and using an arbitrary 
- * elimination constant called elimc. This constant should end 
- * with a clause (x:I)(P .. ), where P is a bound variable.
- * The term c is of type t, which is a product ending with a type 
- * matching I, lbindc are the expected terms for c arguments 
- *)
-
-let general_elim_clause elimtac (c,lbindc) (elimc,lbindelimc) 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
-  let elimt      = pf_type_of gl elimc in
-  let elimclause = make_clenv_binding gl (elimc,elimt) lbindelimc in 
-    elimtac elimclause indclause gl
-
-let general_elim c e ?(allow_K=true) =
-  general_elim_clause (elimination_clause_scheme allow_K) c e
-
-(* 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
-  lookup_eliminator ind (elimination_sort_of_goal gl)
-
-let default_elim (c,_ as cx) gl = 
-  general_elim cx (find_eliminator c gl,NoBindings) gl
-
-let elim_in_context c = function
-  | Some elim -> general_elim c elim ~allow_K:true
-  | None -> default_elim c
-
-let elim (c,lbindc as cx) elim =
-  match kind_of_term c with
-    | Var id when lbindc = NoBindings ->
-	tclTHEN (tclTRY (intros_until_id id)) (elim_in_context cx elim)
-    | _ -> elim_in_context cx elim
-
-(* The simplest elimination tactic, with no substitutions at all. *)
-
-let simplest_elim c = default_elim (c,NoBindings)
-
-(* Elimination in hypothesis *)
-(* Typically, elimclause := (eq_ind ?x ?P ?H ?y ?Heq : ?P ?y)
-              indclause : forall ..., hyps -> a=b    (to take place of ?Heq)
-              id : phi(a)                            (to take place of ?H)
-      and the result is to overwrite id with the proof of phi(b)
-
-   but this generalizes to any elimination scheme with one constructor
-   (e.g. it could replace id:A->B->C by id:C, knowing A/\B)
-*)
-
-let elimination_in_clause_scheme id elimclause indclause gl =
-  let (hypmv,indmv) = 
-    match clenv_independent elimclause with
-        [k1;k2] -> (k1,k2)
-      | _  -> errorlabstrm "elimination_clause"
-          (str "The type of elimination clause is not well-formed") in
-  let elimclause'  = clenv_fchain indmv elimclause indclause in 
-  let hyp = mkVar id in
-  let hyp_typ = pf_type_of gl hyp in
-  let hypclause = mk_clenv_from_n gl (Some 0) (hyp, hyp_typ) in
-  let elimclause'' = clenv_fchain hypmv elimclause' hypclause in  
-  let new_hyp_typ  = clenv_type elimclause'' in
-  if eq_constr hyp_typ new_hyp_typ then
-    errorlabstrm "general_rewrite_in" 
-      (str "Nothing to rewrite in " ++ pr_id id);
-  clenv_refine_in id elimclause'' gl
-
-let general_elim_in id =
-  general_elim_clause (elimination_in_clause_scheme id)
-
-(* Case analysis tactics *)
-
-let general_case_analysis_in_context (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 case = 
-    if occur_term c (pf_concl gl) then make_case_dep else make_case_gen in
-  let elim     = pf_apply case gl mind sort in 
-  general_elim (c,lbindc) (elim,NoBindings) gl
-
-let general_case_analysis (c,lbindc as cx) =
-  match kind_of_term c with
-    | Var id when lbindc = NoBindings ->
-	tclTHEN (tclTRY (intros_until_id id))
-	(general_case_analysis_in_context cx)
-    | _ ->
-	general_case_analysis_in_context cx
-
-let simplest_case c = general_case_analysis (c,NoBindings)
 
 (*****************************)
 (* Decomposing introductions *)
 (*****************************)
 
+let forward_general_multi_rewrite =
+  ref (fun _ -> failwith "general_multi_rewrite undefined")
+
+let register_general_multi_rewrite f =
+  forward_general_multi_rewrite := f
+
 let clear_last = tclLAST_HYP (fun c -> (clear [destVar c]))
 let case_last  = tclLAST_HYP simplest_case
 
+let fix_empty_case nv l =
+  (* The syntax does not distinguish between "[ ]" for one clause with no names
+     and "[ ]" for no clause at all; so we are a bit liberal here *)
+  if Array.length nv = 0 & l = [[]] then [] else l
+
+let intro_or_and_pattern ll l' tac =
+  tclLAST_HYP (fun c gl ->
+    let ind,_ = pf_reduce_to_quantified_ind gl (pf_type_of gl c) in
+    let nv = mis_constr_nargs ind in
+    let rec adjust_names_length tail n = function
+      | [] when n = 0 or tail -> []
+      | [] -> IntroAnonymous :: adjust_names_length tail (n-1) []
+      | _ :: _ as l when n = 0 -> 
+	  if tail then l else error "Too many names in some branch"
+      | ip :: l -> ip :: adjust_names_length tail (n-1) l in
+    let ll = fix_empty_case nv ll in
+    if List.length ll <> Array.length nv then
+      error "Not the right number of patterns";
+    tclTHENLASTn
+      (tclTHEN case_last clear_last)
+      (array_map2 (fun n l -> tac ((adjust_names_length (l'=[]) n l)@l'))
+	nv (Array.of_list ll))
+      gl)
+
+let clear_if_atomic l2r id gl =
+  let eq = pf_type_of gl (mkVar id) in
+  let (_,lhs,rhs) = snd (find_eq_data_decompose eq) in
+  if l2r & isVar lhs then tclTRY (clear [destVar lhs;id]) gl
+  else if not l2r & isVar rhs then tclTRY (clear [destVar rhs;id]) gl
+  else tclIDTAC gl
+
 let rec explicit_intro_names = function
-| (IntroWildcard | IntroAnonymous) :: l -> explicit_intro_names l
-| IntroIdentifier id :: l -> id :: explicit_intro_names l
+| IntroIdentifier id :: l ->
+    id :: explicit_intro_names l
+| (IntroWildcard | IntroAnonymous | IntroFresh _ | IntroRewrite _) :: l ->
+    explicit_intro_names l
 | IntroOrAndPattern ll :: l' -> 
     List.flatten (List.map (fun l -> explicit_intro_names (l@l')) ll)
-| [] -> []
+| [] ->
+    []
 
   (* We delay thinning until the completion of the whole intros tactic
      to ensure that dependent hypotheses are cleared in the right
@@ -911,12 +1081,23 @@ let rec intros_patterns avoid thin destopt = function
       tclTHEN
         (intro_gen (IntroAvoid (avoid@explicit_intro_names l)) destopt true)
         (intros_patterns avoid thin destopt l)
+  | IntroFresh id :: l ->
+      tclTHEN
+        (intro_gen (IntroBasedOn (id, avoid@explicit_intro_names l)) destopt true)
+        (intros_patterns avoid thin destopt l)
   | IntroOrAndPattern ll :: l' ->
       tclTHEN
         introf
-        (tclTHENS
-	  (tclTHEN case_last clear_last)
-	  (List.map (fun l -> intros_patterns avoid thin destopt (l@l')) ll))
+        (intro_or_and_pattern ll l' (intros_patterns avoid thin destopt))
+  | IntroRewrite l2r :: l ->
+      tclTHEN 
+        (intro_gen (IntroAvoid (avoid@explicit_intro_names l)) None true)
+        (onLastHyp (fun id ->
+	  tclTHENLIST [
+	    !forward_general_multi_rewrite l2r false (mkVar id,NoBindings) 
+	      allClauses;
+	    clear_if_atomic l2r id;
+	    intros_patterns avoid thin destopt l ]))
   | [] -> clear thin
 
 let intros_pattern = intros_patterns [] []
@@ -938,8 +1119,12 @@ let make_id s = fresh_id [] (match s with Prop _ -> hid | Type _ -> xid)
 
 let prepare_intros s ipat gl = match ipat with
   | IntroAnonymous -> make_id s gl, tclIDTAC
+  | IntroFresh id -> fresh_id [] id gl, tclIDTAC
   | IntroWildcard -> let id = make_id s gl in id, thin [id]
   | IntroIdentifier id -> id, tclIDTAC
+  | IntroRewrite l2r -> 
+      let id = make_id s gl in
+      id, !forward_general_multi_rewrite l2r false (mkVar id,NoBindings) allClauses
   | IntroOrAndPattern ll -> make_id s gl, 
     (tclTHENS 
       (tclTHEN case_last clear_last)
@@ -964,24 +1149,28 @@ let true_cut = assert_tac true
 (*   Generalize tactics   *)
 (**************************)
 
-let generalize_goal gl c cl =
-  let t = refresh_universes (pf_type_of gl c) in
-  match kind_of_term c with
-    | Var id ->
-	(* The choice of remembering or not a non dependent name has an impact
-	   on the future Intro naming strategy! *)
-	(* if dependent c cl then mkNamedProd id t cl
-	   else mkProd (Anonymous,t,cl) *)
-	mkNamedProd id t cl
-    | _        -> 
-        let cl' = subst_term c cl in
-        if noccurn 1 cl' then 
-	  mkProd (Anonymous,t,cl)
-          (* On ne se casse pas la tete : on prend pour nom de variable
-             la premiere lettre du type, meme si "ci" est une
-             constante et qu'on pourrait prendre directement son nom *)
-        else 
-	  prod_name (Global.env()) (Anonymous, t, cl')
+let generalized_name c t cl = function
+  | Name id as na -> na
+  | Anonymous -> 
+      match kind_of_term c with
+      | Var id ->
+	 (* Keep the name even if not occurring: may be used by intros later *)
+	  Name id
+      | _ ->
+	  if noccurn 1 cl then Anonymous else
+	    (* On ne s'etait pas casse la tete : on avait pris pour nom de 
+               variable la premiere lettre du type, meme si "c" avait ete une
+               constante dont on aurait pu prendre directement le nom *)
+	    named_hd (Global.env()) t Anonymous
+
+let generalize_goal gl i ((occs,c),na) cl =
+  let t = pf_type_of gl c in
+  let decls,cl = decompose_prod_n_assum i cl in
+  let dummy_prod = it_mkProd_or_LetIn mkProp decls in
+  let newdecls,_ = decompose_prod_n_assum i (subst_term c dummy_prod) in
+  let cl' = subst_term_occ occs c (it_mkProd_or_LetIn cl newdecls) in
+  let na = generalized_name c t cl' na in
+  mkProd (na,t,cl')
 
 let generalize_dep c gl =
   let env = pf_env gl in
@@ -1004,16 +1193,23 @@ let generalize_dep c gl =
       | _ -> tothin
   in
   let cl' = it_mkNamedProd_or_LetIn (pf_concl gl) to_quantify in
-  let cl'' = generalize_goal gl c cl' in
+  let cl'' = generalize_goal gl 0 ((all_occurrences,c),Anonymous) cl' in
   let args = Array.to_list (instance_from_named_context to_quantify_rev) in
   tclTHEN
     (apply_type cl'' (c::args))
     (thin (List.rev tothin'))
     gl
-    
-let generalize lconstr gl = 
-  let newcl = List.fold_right (generalize_goal gl) lconstr (pf_concl gl) in
-  apply_type newcl lconstr gl
+
+let generalize_gen lconstr gl =
+  let newcl =
+    list_fold_right_i (generalize_goal gl) 0 lconstr (pf_concl gl) in
+  apply_type newcl (List.map (fun ((_,c),_) -> c) lconstr) gl
+
+let generalize l =
+  generalize_gen (List.map (fun c -> ((all_occurrences,c),Anonymous)) l)
+
+let revert hyps gl = 
+  tclTHEN (generalize (List.map mkVar hyps)) (clear hyps) gl
 
 (* Faudra-t-il une version avec plusieurs args de generalize_dep ?
 Cela peut-être troublant de faire "Generalize Dependent H n" dans
@@ -1033,7 +1229,7 @@ let quantify lconstr =
 
    [letin_tac b na c (occ_hyp,occ_ccl) gl] transforms
    [...x1:T1(c),...,x2:T2(c),... |- G(c)] into
-   [...x:T;x1:T1(x),...,x2:T2(x),... |- G(x)] if [b] is false or
+   [...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;
@@ -1058,14 +1254,15 @@ let out_arg = function
 let occurrences_of_hyp id cls =
   let rec hyp_occ = function
       [] -> None
-    | ((occs,id'),hl)::_ when id=id' -> Some (List.map out_arg occs)
+    | (((b,occs),id'),hl)::_ when id=id' -> Some (b,List.map out_arg occs)
     | _::l -> hyp_occ l in
   match cls.onhyps with
-      None -> Some []
+      None -> Some (all_occurrences)
     | Some l -> hyp_occ l
 
 let occurrences_of_goal cls =
-  if cls.onconcl then Some (List.map out_arg cls.concl_occs) else None
+  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)
 
@@ -1134,7 +1331,7 @@ let letin_abstract id c occs gl =
       | None -> depdecls
       | Some occ ->
           let newdecl = subst_term_occ_decl occ c d in
-          if occ = [] & d = newdecl then
+          if occ = all_occurrences & d = newdecl then
 	    if not (in_every_hyp occs)
 	    then raise (RefinerError (DoesNotOccurIn (c,hyp)))
 	    else depdecls
@@ -1154,24 +1351,63 @@ let letin_tac with_eq name c occs gl =
       if not (mem_named_context x (pf_hyps gl)) then x else
 	error ("The variable "^(string_of_id x)^" is already declared") in
   let (depdecls,lastlhyp,ccl)= letin_abstract id c occs gl in 
-  let t = refresh_universes (pf_type_of gl c) in
-  let newcl = mkNamedLetIn id c t ccl in
+  let t = pf_type_of gl c in
+  let newcl,eq_tac = match with_eq with
+    | Some lr ->
+      let heq = fresh_id [] (add_prefix "Heq" id) gl 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 (IntroMustBe heq) lastlhyp true) (thin_body [heq;id])
+    | None ->
+	mkNamedLetIn id c t ccl, tclIDTAC in
   tclTHENLIST
     [ convert_concl_no_check newcl DEFAULTcast;
       intro_gen (IntroMustBe id) lastlhyp true;
-      if with_eq then tclIDTAC else thin_body [id];
+      eq_tac;
       tclMAP convert_hyp_no_check depdecls ] gl
   
 (* Tactics "pose proof" (usetac=None) and "assert" (otherwise) *)
 let forward usetac ipat c gl =
   match usetac with
   | None -> 
-      let t = refresh_universes (pf_type_of gl c) in
+      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
 
 (*****************************)
+(* Ad hoc unfold             *)
+(*****************************)
+
+(* The two following functions should already exist, but found nowhere *)
+(* Unfolds x by its definition everywhere *)
+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 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
+
+(* 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
+
+(*****************************)
 (* High-level induction      *)
 (*****************************)
 
@@ -1208,7 +1444,7 @@ let forward usetac ipat c gl =
  *)
 
 let check_unused_names names =
-  if names <> [] & Options.is_verbose () then
+  if names <> [] & Flags.is_verbose () then
     let s = if List.tl names = [] then " " else "s " in
     msg_warning 
       (str"Unused introduction pattern" ++ str s ++ 
@@ -1219,8 +1455,9 @@ let rec first_name_buggy = function
   | IntroOrAndPattern ([]::l) -> first_name_buggy (IntroOrAndPattern l)
   | IntroOrAndPattern ((p::_)::_) -> first_name_buggy p
   | IntroWildcard -> None
+  | IntroRewrite _ -> None
   | IntroIdentifier id -> Some id
-  | IntroAnonymous -> assert false
+  | IntroAnonymous | IntroFresh _ -> assert false
 
 let consume_pattern avoid id gl = function
   | [] -> (IntroIdentifier (fresh_id avoid id gl), [])
@@ -1306,14 +1543,14 @@ let atomize_param_of_ind (indref,nparams) hyp0 gl =
 	| Var id ->
 	    let x = fresh_id [] id gl in
 	    tclTHEN
-	      (letin_tac true (Name x) (mkVar id) allClauses)
+	      (letin_tac None (Name x) (mkVar id) allClauses)
 	      (atomize_one (i-1) ((mkVar x)::avoid)) gl
 	| _ ->
 	    let id = id_of_name_using_hdchar (Global.env()) (pf_type_of gl c)
 		       Anonymous in
 	    let x = fresh_id [] id gl in
 	    tclTHEN
-	      (letin_tac true (Name x) c allClauses)
+	      (letin_tac None (Name x) c allClauses)
 	      (atomize_one (i-1) ((mkVar x)::avoid)) gl
     else 
       tclIDTAC gl
@@ -1484,7 +1721,7 @@ let cook_sign hyp0_opt indvars_init env =
 (* [rel_contexts] and [rel_declaration] actually contain triples, and
    lists are actually in reverse order to fit [compose_prod]. *)
 type elim_scheme = { 
-  elimc: (Term.constr * constr Rawterm.bindings) option;
+  elimc: constr with_ebindings option;
   elimt: types;
   indref: global_reference option;
   params: rel_context;     (* (prm1,tprm1);(prm2,tprm2)...(prmp,tprmp) *)
@@ -1525,16 +1762,15 @@ let empty_scheme =
 
 (* Unification between ((elimc:elimt) ?i ?j ?k ?l ... ?m) and the
    hypothesis on which the induction is made *)
-let induction_tac varname typ scheme (*(elimc,lbindelimc),elimt*) gl =
+let induction_tac with_evars (varname,lbind) typ scheme gl =
   let elimc,lbindelimc = 
     match scheme.elimc with | Some x -> x | None -> error "No definition of the principle" in
   let elimt = scheme.elimt in
-  let c = mkVar varname in
-  let indclause  = make_clenv_binding gl (c,typ) NoBindings  in
+  let indclause = make_clenv_binding gl (mkVar varname,typ) lbind  in
   let elimclause =
     make_clenv_binding gl 
       (mkCast (elimc,DEFAULTcast, elimt),elimt) lbindelimc in
-  elimination_clause_scheme true elimclause indclause gl
+  elimination_clause_scheme with_evars true elimclause indclause gl
 
 let make_base n id =
   if n=0 or n=1 then id
@@ -1549,13 +1785,14 @@ let make_base n id =
 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 ind_prefix = "IH" in
   let base_ind = 
     if is_hyp then 
       match ind_opt with
-	| None -> id_of_string ""
-	| Some ind_id -> Nametab.id_of_global ind_id 
-    else cname in
-  let hyprecname = add_prefix "IH" (make_base n base_ind) in
+	| None -> id_of_string ind_prefix
+	| Some ind_id -> add_prefix ind_prefix (Nametab.id_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 []
     else
@@ -1590,7 +1827,151 @@ let error_ind_scheme s =
   let s = if s <> "" then s^" " else s in
   error ("Cannot recognise "^s^"an induction schema")
 
+let mkEq t x y = 
+  mkApp (build_coq_eq (), [| t; x; y |])
+    
+let mkRefl t x = 
+  mkApp ((build_coq_eq_data ()).refl, [| t; x |])
+
+let mkHEq t x u y = 
+  mkApp (coq_constant "mkHEq" ["Logic";"JMeq"] "JMeq",
+	[| t; x; u; y |])
+    
+let mkHRefl t x = 
+  mkApp (coq_constant "mkHEq" ["Logic";"JMeq"] "JMeq_refl",
+	[| t; x |])
 
+let mkCoe a x p px y eq = 
+  mkApp (Option.get (build_coq_eq_data ()).rect, [| a; x; p; px; y; eq |])
+
+let lift_togethern n l =
+  let l', _ =
+    List.fold_right
+      (fun x (acc, n) ->
+	(lift n x :: acc, succ n))
+      l ([], n)
+  in l'
+      
+let lift_together l = lift_togethern 0 l
+
+let lift_list l = List.map (lift 1) l
+
+let ids_of_constr vars c = 
+  let rec aux vars c = 
+    match kind_of_term c with
+    | Var id -> if List.mem id vars then vars else id :: vars
+    | _ -> fold_constr aux vars c
+  in aux vars c
+
+let make_abstract_generalize gl id concl dep ctx c eqs args refls = 
+  let meta = Evarutil.new_meta() in
+  let cstr =
+    (* Abstract by equalitites *)
+    let eqs = lift_togethern 1 eqs in
+    let abseqs = it_mkProd_or_LetIn ~init:concl (List.map (fun x -> (Anonymous, None, x)) eqs) in
+      (* Abstract by the "generalized" hypothesis and its equality proof *)
+    let term, typ = mkVar id, pf_get_hyp_typ gl id in
+    let abshyp = 
+      let abshypeq = 
+	if dep then 
+	  mkProd (Anonymous, mkHEq (lift 1 c) (mkRel 1) typ term, lift 1 abseqs)
+	else abseqs
+      in
+	mkProd (Name id, c, abshypeq)
+    in
+      (* Abstract by the extension of the context *)
+    let genctyp = it_mkProd_or_LetIn ~init:abshyp ctx in
+      (* The goal will become this product. *)
+    let genc = mkCast (mkMeta meta, DEFAULTcast, genctyp) in      
+      (* Apply the old arguments giving the proper instantiation of the hyp *)
+    let instc = mkApp (genc, Array.of_list args) in
+      (* Then apply to the original instanciated hyp. *)
+    let newc = mkApp (instc, [| mkVar id |]) in
+      (* Apply the reflexivity proof for the original hyp. *)
+    let newc = if dep then mkApp (newc, [| mkHRefl typ term |]) else newc in
+      (* Finaly, apply the remaining reflexivity proofs on the index, to get a term of type gl again *)
+    let appeqs = mkApp (newc, Array.of_list refls) in
+      appeqs
+  in cstr
+    
+let abstract_args gl id = 
+  let c = pf_get_hyp_typ gl id in
+  let sigma = project gl in
+  let env = pf_env gl in
+  let concl = pf_concl gl in
+  let 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 
+      avoid := id :: !avoid; id
+  in
+  match kind_of_term c with
+      App (f, args) -> 
+	(* 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, vars, env) arg =
+	  let (name, _, ty), arity = 
+	    let rel, c = Reductionops.decomp_n_prod env sigma 1 prod in
+	      List.hd rel, c
+	  in
+	  let argty = pf_type_of gl arg in
+	  let liftargty = lift (List.length ctx) argty in
+	  let convertible = Reductionops.is_conv_leq ctxenv sigma liftargty ty in
+	    match kind_of_term arg with
+	      | Var _ | Rel _ | Ind _ when convertible -> 
+		  (subst1 arg arity, ctx, ctxenv, mkApp (c, [|arg|]), args, eqs, refls, vars, env)
+	      | _ ->
+		  let name = get_id name in
+		  let decl = (Name name, None, ty) in
+		  let ctx = decl :: ctx in
+		  let c' = mkApp (lift 1 c, [|mkRel 1|]) in
+		  let args = arg :: args in
+		  let liftarg = lift (List.length ctx) arg in
+		  let eq, refl = 
+		    if convertible then
+		      mkEq (lift 1 ty) (mkRel 1) liftarg, mkRefl argty arg
+		    else
+		      mkHEq (lift 1 ty) (mkRel 1) liftargty liftarg, mkHRefl argty arg
+		  in
+		  let eqs = eq :: lift_list eqs in
+		  let refls = refl :: refls in
+		  let vars = ids_of_constr vars arg in
+		    (arity, ctx, push_rel decl ctxenv, c', args, eqs, refls, vars, env)
+	in 
+	let arity, ctx, ctxenv, c', args, eqs, refls, vars, env = 
+	  Array.fold_left aux (pf_type_of gl f,[],env,f,[],[],[],[],env) args
+	in
+	let args, refls = List.rev args, List.rev refls in
+	  Some (make_abstract_generalize gl id concl dep ctx c' eqs args refls,
+	       dep, succ (List.length ctx), vars)
+    | _ -> None
+
+let abstract_generalize id gl =
+  Coqlib.check_required_library ["Coq";"Logic";"JMeq"];
+(*   let qualid = (dummy_loc, qualid_of_dirpath (dirpath_of_string "Coq.Logic.JMeq")) in *)
+(*   Library.require_library [qualid] None; *)
+  let oldid = pf_get_new_id id gl in
+  let newc = abstract_args gl id in
+    match newc with
+      | None -> tclIDTAC gl
+      | Some (newc, dep, n, vars) -> 
+	  if dep then
+	    tclTHENLIST [refine newc;
+			 rename_hyp [(id, oldid)];
+			 tclDO n intro; 
+			 generalize_dep (mkVar oldid);
+			 tclMAP (fun id -> tclTRY (generalize_dep (mkVar id))) vars]
+	      gl
+	  else
+	    tclTHENLIST [refine newc;
+			 clear [id];
+			 tclDO n intro; 
+			 tclMAP (fun id -> tclTRY (generalize_dep (mkVar id))) vars]
+	      gl
 
 
 let occur_rel n c = 
@@ -1680,6 +2061,23 @@ 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 there 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
 
@@ -1708,13 +2106,13 @@ let compute_elim_sig ?elimc elimt =
   let nparams = Intset.cardinal (free_rels concl_with_args) in
   let preds,params = cut_list (List.length params_preds - nparams) params_preds in
   
-  (* A first approximation, further anlysis will tweak it *)
+  (* A first approximation, further analysis will tweak it *)
   let res = ref { empty_scheme with
     (* This fields are ok: *)
     elimc = elimc; elimt = elimt; concl = conclusion;
     predicates = preds; npredicates = List.length preds; 
     branches = branches; nbranches = List.length branches; 
-    farg_in_concl = (try isApp (last_arg ccl) with _ -> false);
+    farg_in_concl = isApp ccl && isApp (last_arg ccl);
     params = params; nparams = nparams; 
     (* all other fields are unsure at this point. Including these:*)
     args = args_indargs; nargs = List.length args_indargs; } in
@@ -1876,7 +2274,7 @@ let mapi f l =
   mapi_aux f 0 l
 
 
-(* Instanciate all meta variables of elimclause using lid, some elts
+(* 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 scheme lid elimclause gl = 
@@ -1919,13 +2317,11 @@ let recolle_clenv scheme lid elimclause gl =
     (List.rev clauses)
     elimclause
 
-
-
 (* Unification of the goal and the principle applied to meta variables:
    (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 indvars (* (elimc,lbindelimc) elimt *) scheme gl = 
+let induction_tac_felim with_evars indvars (* (elimc,lbindelimc) elimt *) scheme gl = 
   let elimt = scheme.elimt in
   let elimc,lbindelimc = 
     match scheme.elimc with | Some x -> x | None -> error "No definition of the principle" in
@@ -1936,7 +2332,7 @@ let induction_tac_felim indvars (* (elimc,lbindelimc) elimt *) scheme gl =
   let elimclause' = recolle_clenv scheme indvars elimclause gl in
   (* one last resolution (useless?) *)
   let resolved = clenv_unique_resolver true elimclause' gl in
-  clenv_refine resolved gl
+  clenv_refine with_evars resolved gl
 
 (* Induction with several induction arguments, main differences with
    induction_from_context is that there is no main induction argument,
@@ -1944,7 +2340,7 @@ let induction_tac_felim indvars (* (elimc,lbindelimc) elimt *) scheme gl =
    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 isrec elim_info lid names gl =
+let induction_from_context_l isrec 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
@@ -1986,14 +2382,14 @@ let induction_from_context_l isrec elim_info lid names gl =
       if deps = [] then tclIDTAC else apply_type tmpcl deps_cstr;
       thin dephyps; (* clear dependent hyps *)
       (* pattern to make the predicate appear. *)
-      reduce (Pattern (List.map (fun e -> ([],e)) lidcstr)) onConcl;
+      reduce (Pattern (List.map inj_with_occurrences lidcstr)) onConcl;
       (* FIXME: Tester ca avec un principe dependant et non-dependant *)
       (if isrec then tclTHENFIRSTn else tclTHENLASTn)
        	(tclTHENLIST [ 
 	  (* Induction by "refine (indscheme ?i ?j ?k...)" + resolution of all
 	     possible holes using arguments given by the user (but the
 	     functional one). *)
-	  induction_tac_felim realindvars scheme;
+	  induction_tac_felim with_evars realindvars scheme;
           tclTRY (thin (List.rev (indhyps)));
 	])
 	(array_map2 
@@ -2003,13 +2399,8 @@ let induction_from_context_l isrec elim_info lid names gl =
 
 
 
-let induction_from_context isrec elim_info hyp0 names gl =
-  (*test suivant sans doute inutile car refait par le letin_tac*)
-  if List.mem hyp0 (ids_of_named_context (Global.named_context())) then
-    errorlabstrm "induction" 
-      (str "Cannot generalize a global variable");
+let induction_from_context isrec with_evars elim_info (hyp0,lbind) names gl =
   let indsign,scheme = elim_info in
-
   let indref = match scheme.indref with | None -> assert false | Some x -> x in
   let tmptyp0 =	pf_get_hyp_typ gl hyp0 in
   let typ0 = pf_apply reduce_to_quantified_ref gl indref tmptyp0 in
@@ -2038,8 +2429,8 @@ let induction_from_context isrec elim_info hyp0 names gl =
       thin dephyps;
       (if isrec then tclTHENFIRSTn else tclTHENLASTn)
        	(tclTHENLIST
-	  [ induction_tac hyp0 typ0 scheme (*scheme.elimc,scheme.elimt*);
-	    thin [hyp0];
+	  [ induction_tac with_evars (hyp0,lbind) typ0 scheme;
+	    tclTHEN (tclTRY (unfold_body hyp0)) (thin [hyp0]);
             tclTRY (thin indhyps) ])
        	(array_map2
 	   (induct_discharge statlists lhyp0 (List.rev dephyps)) indsign names)
@@ -2050,22 +2441,22 @@ let induction_from_context isrec elim_info hyp0 names gl =
 
 exception TryNewInduct of exn
 
-let induction_with_atomization_of_ind_arg isrec elim names hyp0 gl =
+let induction_with_atomization_of_ind_arg isrec with_evars elim names (hyp0,lbind) gl =
   let (indsign,scheme as elim_info) = find_elim_signature isrec elim hyp0 gl in
   if scheme.indarg = None then (* This is not a standard induction scheme (the
 				  argument is probably a parameter) So try the
 				  more general induction mechanism. *)
-    induction_from_context_l isrec elim_info [hyp0] names gl
+    induction_from_context_l isrec with_evars elim_info [hyp0] names gl
   else
     let indref = match scheme.indref with | None -> assert false | Some x -> x in
     tclTHEN
       (atomize_param_of_ind (indref,scheme.nparams) hyp0)
-      (induction_from_context isrec elim_info hyp0 names) gl
+      (induction_from_context isrec with_evars elim_info (hyp0,lbind) names) 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 elim names lid gl =
+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 = 
@@ -2076,52 +2467,30 @@ let induction_without_atomization isrec elim names lid gl =
   let nlid = List.length lid in
   if nlid <> awaited_nargs
   then error "Not the right number of induction arguments"
-  else induction_from_context_l isrec elim_info lid names gl
+  else induction_from_context_l isrec with_evars elim_info lid names gl
 
-let new_induct_gen isrec elim names c gl =
+let new_induct_gen isrec with_evars elim names (c,lbind) cls gl =
   match kind_of_term c with
-    | Var id when not (mem_named_context id (Global.named_context())) ->
-	induction_with_atomization_of_ind_arg isrec elim names id gl
+    | Var id when not (mem_named_context id (Global.named_context()))
+	        & lbind = NoBindings & not with_evars & cls = None ->
+	induction_with_atomization_of_ind_arg
+	  isrec with_evars elim names (id,lbind) gl
     | _        ->
 	let x = id_of_name_using_hdchar (Global.env()) (pf_type_of gl c) 
 		  Anonymous in
 	let id = fresh_id [] x gl in
+	let with_eq = if cls <> None then Some (not (isVar c)) else None in
 	tclTHEN
-	  (letin_tac true (Name id) c allClauses)
-	  (induction_with_atomization_of_ind_arg isrec elim names id) gl
-
-(* The two following functions should already exist, but found nowhere *)
-(* Unfolds x by its definition everywhere *)
-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 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
-
-(* 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
-
+	  (letin_tac with_eq (Name id) c (Option.default allClauses cls))
+	  (induction_with_atomization_of_ind_arg
+	     isrec with_evars elim names (id,lbind)) gl
 
 (* 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 elim names lc gl =
+let new_induct_gen_l isrec with_evars elim names lc gl =
   let newlc = ref [] in
   let letids = ref [] in
   let rec atomize_list l gl =
@@ -2129,7 +2498,8 @@ let new_induct_gen_l isrec elim names lc gl =
       | [] -> tclIDTAC gl
       | c::l' ->
 	  match kind_of_term c with
-	    | Var id when not (mem_named_context id (Global.named_context())) -> 
+	    | Var id when not (mem_named_context id (Global.named_context()))
+		& not with_evars -> 
 		let _ = newlc:= id::!newlc in
 		atomize_list l' gl
 
@@ -2142,13 +2512,13 @@ let new_induct_gen_l isrec elim names lc gl =
 		let _ = newlc:=id::!newlc in
 		let _ = letids:=id::!letids in
 		tclTHEN 
-		  (letin_tac true (Name id) c allClauses)
+		  (letin_tac None (Name id) c allClauses)
 		  (atomize_list newl') gl in
   tclTHENLIST 
     [
       (atomize_list lc);
       (fun gl' -> (* recompute each time to have the new value of newlc *)
-	induction_without_atomization isrec elim names !newlc gl') ;
+	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 *)
@@ -2157,10 +2527,10 @@ let new_induct_gen_l isrec elim names lc gl =
     gl
 
 
-let induct_destruct_l isrec lc elim names = 
+let induct_destruct_l isrec with_evars lc elim names cls = 
   (* Several induction hyps: induction scheme is mandatory *)
   let _ = 
-    if elim = None 
+    if elim = None
     then 
       error ("Induction scheme must be given when several induction hypothesis.\n"
       ^ "Example: induction x1 x2 x3 using my_scheme.") in
@@ -2168,35 +2538,32 @@ let induct_destruct_l isrec lc elim names =
     List.map
       (fun x -> 
 	match x with (* FIXME: should we deal with ElimOnIdent? *)
-	  | ElimOnConstr x -> x
+	  | ElimOnConstr (x,NoBindings) -> x
 	  | _ -> error "don't know where to find some argument")
       lc in
-  new_induct_gen_l isrec elim names newlc
-
+  if cls <> None then
+    error
+      "'in' clause not supported when several induction hypothesis are given";
+  new_induct_gen_l isrec with_evars elim names newlc
 
 (* 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 lc elim names = 
+let induct_destruct isrec with_evars lc elim names cls =
   assert (List.length lc > 0); (* ensured by syntax, but if called inside caml? *)
   if List.length lc = 1 then (* induction on one arg: use old mechanism *)
-    try 
-      let c = List.hd lc in
-      match c with
-	| ElimOnConstr c -> new_induct_gen isrec elim names c
-	| ElimOnAnonHyp n ->
-	    tclTHEN (intros_until_n n)
-	      (tclLAST_HYP (new_induct_gen isrec elim names))
-	      (* Identifier apart because id can be quantified in goal and not typable *)
-	| ElimOnIdent (_,id) ->
-	    tclTHEN (tclTRY (intros_until_id id))
-	      (new_induct_gen isrec elim names (mkVar id))
+    try
+      onInductionArg
+	(fun c -> new_induct_gen isrec with_evars elim names c cls)
+	(List.hd lc)
     with (* If this fails, try with new mechanism but if it fails too,
 	    then the exception is the first one. *)
-      | x -> (try induct_destruct_l isrec lc elim names with _  -> raise x)
-  else induct_destruct_l isrec lc elim names
+      | x ->
+	  (try induct_destruct_l isrec with_evars lc elim names cls
+	   with _  -> raise x)
+  else induct_destruct_l isrec with_evars lc elim names cls
 
 
       
@@ -2477,9 +2844,9 @@ let interpretable_as_section_decl d1 d2 = match d1,d2 with
   | (_,Some b1,t1), (_,Some b2,t2) -> eq_constr b1 b2 & eq_constr t1 t2
   | (_,None,t1), (_,_,t2) -> eq_constr t1 t2
 
-let abstract_subproof name tac gls = 
+let abstract_subproof name tac gl = 
   let current_sign = Global.named_context()
-  and global_sign = pf_hyps gls in
+  and global_sign = pf_hyps gl in
   let sign,secsign = 
     List.fold_right
       (fun (id,_,_ as d) (s1,s2) -> 
@@ -2488,8 +2855,8 @@ let abstract_subproof name tac gls =
         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 na = next_global_ident_away false name (pf_ids_of_hyps gls) in
-  let concl = it_mkNamedProd_or_LetIn (pf_concl gls) sign in
+  let na = next_global_ident_away false name (pf_ids_of_hyps gl) in
+  let concl = it_mkNamedProd_or_LetIn (pf_concl gl) sign in
     if occur_existential concl then
       error "\"abstract\" cannot handle existentials";
     let lemme =
@@ -2497,10 +2864,11 @@ let abstract_subproof name tac gls =
       let _,(const,kind,_) =
 	try
 	  by (tclCOMPLETE (tclTHEN (tclDO (List.length sign) intro) tac)); 
-	  let r = cook_proof () in 
+	  let r = cook_proof ignore in 
 	    delete_current_proof (); r
-	with e -> 
-	  (delete_current_proof(); raise e)
+	with 
+	    e ->
+	      (delete_current_proof(); raise e)
       in   (* Faudrait un peu fonctionnaliser cela *)
       let cd = Entries.DefinitionEntry const in
       let con = Declare.declare_internal_constant na (cd,IsProof Lemma) in
@@ -2509,19 +2877,19 @@ let abstract_subproof name tac gls =
       exact_no_check 
 	(applist (lemme, 
 		 List.rev (Array.to_list (instance_from_named_context sign))))
-	gls
+	gl
 
-let tclABSTRACT name_op tac gls = 
+let tclABSTRACT name_op tac gl = 
   let s = match name_op with 
     | Some s -> s 
     | None   -> add_suffix (get_current_proof_name ()) "_subproof" 
   in  
-    abstract_subproof s tac gls
+  abstract_subproof s tac gl
 
 
-let admit_as_an_axiom gls =
+let admit_as_an_axiom gl =
   let current_sign = Global.named_context()
-  and global_sign = pf_hyps gls in
+  and global_sign = pf_hyps gl in
   let sign,secsign = 
     List.fold_right
       (fun (id,_,_ as d) (s1,s2) -> 
@@ -2531,15 +2899,15 @@ let admit_as_an_axiom gls =
 	 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 false name (pf_ids_of_hyps gls) in
-  let concl = it_mkNamedProd_or_LetIn (pf_concl gls) sign in
+  let na = next_global_ident_away false 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 concl in
+    let cd = Entries.ParameterEntry (concl,false) in
     let con = Declare.declare_internal_constant na (cd,IsAssumption Logical) in
     constr_of_global (ConstRef con)
   in
   exact_no_check 
     (applist (axiom, 
               List.rev (Array.to_list (instance_from_named_context sign))))
-    gls
+    gl
diff --git a/tactics/tactics.mli b/tactics/tactics.mli
index bb71afb9..b7ab31c4 100644
--- a/tactics/tactics.mli
+++ b/tactics/tactics.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: tactics.mli 9853 2007-05-23 14:25:47Z letouzey $ i*)
+(*i $Id: tactics.mli 11166 2008-06-22 13:23:35Z herbelin $ i*)
 
 (*i*)
 open Names
@@ -26,14 +26,19 @@ open Genarg
 open Tacexpr
 open Nametab
 open Rawterm
+open Termops
 (*i*)
 
+val inj_open : constr -> open_constr
+val inj_red_expr : red_expr -> (open_constr, evaluable_global_reference) red_expr_gen
+val inj_ebindings : constr bindings -> open_constr bindings
+
 (* Main tactics. *)
 
 (*s General functions. *)
 
 val type_clenv_binding : goal sigma ->
-  constr * constr -> constr bindings  -> constr
+  constr * constr -> open_constr bindings  -> constr
 
 val string_of_inductive : constr -> string
 val head_constr       : constr -> constr list
@@ -96,6 +101,13 @@ val intros_clearing      : bool list -> tactic
 val try_intros_until :
   (identifier -> tactic) -> quantified_hypothesis -> tactic
 
+(* Apply a tactic on a quantified hypothesis, an hypothesis in context
+   or a term with bindings *)
+
+val onInductionArg : 
+  (constr with_ebindings -> tactic) ->
+    constr with_ebindings induction_arg -> tactic
+
 (*s Introduction tactics with eliminations. *)
 
 val intro_pattern     : identifier option -> intro_pattern_expr      -> tactic
@@ -117,9 +129,9 @@ type tactic_reduction = env -> evar_map -> constr -> constr
 val reduct_in_hyp     : tactic_reduction -> hyp_location -> tactic
 val reduct_option     : tactic_reduction * cast_kind -> simple_clause -> tactic
 val reduct_in_concl   : tactic_reduction * cast_kind -> tactic
-val change_in_concl   : (int list * constr) option -> constr -> tactic
-val change_in_hyp     : (int list * constr) option -> constr -> hyp_location ->
-  tactic
+val change_in_concl   : (occurrences * constr) option -> constr -> tactic
+val change_in_hyp     : (occurrences * constr) option -> constr -> 
+                        hyp_location -> tactic
 val red_in_concl      : tactic
 val red_in_hyp        : hyp_location        -> tactic
 val red_option        : simple_clause -> tactic
@@ -133,18 +145,19 @@ val normalise_in_concl : tactic
 val normalise_in_hyp  : hyp_location        -> tactic
 val normalise_option  : simple_clause -> tactic
 val normalise_vm_in_concl : tactic
-val unfold_in_concl   : (int list * evaluable_global_reference) list -> tactic
+val unfold_in_concl   :
+  (occurrences * evaluable_global_reference) list -> tactic
 val unfold_in_hyp     : 
-  (int list * evaluable_global_reference) list -> hyp_location -> tactic
+  (occurrences * evaluable_global_reference) list -> hyp_location -> tactic
 val unfold_option     : 
-  (int list * evaluable_global_reference) list -> simple_clause
+  (occurrences * evaluable_global_reference) list -> simple_clause
     -> tactic
-val reduce            : red_expr -> clause -> tactic
 val change            :
-  (int list * constr) option -> constr -> clause -> tactic
-
+  (occurrences * constr) option -> constr -> clause -> tactic
+val pattern_option    : 
+  (occurrences * constr) list -> simple_clause -> tactic
+val reduce            : red_expr -> clause -> tactic
 val unfold_constr     : global_reference -> tactic
-val pattern_option  : (int list * constr) list -> simple_clause -> tactic
 
 (*s Modification of the local context. *)
 
@@ -152,10 +165,12 @@ val clear         : identifier list -> tactic
 val clear_body    : identifier list -> tactic
 val keep          : identifier list -> tactic
 
-val new_hyp       : int option -> constr with_bindings -> tactic
+val specialize    : int option -> constr with_ebindings -> tactic
 
 val move_hyp      : bool -> identifier -> identifier -> tactic
-val rename_hyp    : identifier -> identifier -> tactic
+val rename_hyp    : (identifier * identifier) list -> tactic
+
+val revert        : identifier list -> tactic
 
 (*s Resolution tactics. *)
 
@@ -166,11 +181,19 @@ val bring_hyps : named_context -> tactic
 val apply                 : constr      -> tactic
 val apply_without_reduce  : constr      -> tactic
 val apply_list            : constr list -> tactic
+
+val apply_with_ebindings_gen : 
+  advanced_flag -> evars_flag -> constr with_ebindings -> tactic
+
 val apply_with_bindings   : constr with_bindings -> tactic
+val eapply_with_bindings  : constr with_bindings -> tactic
+
+val apply_with_ebindings  : constr with_ebindings -> tactic
+val eapply_with_ebindings : constr with_ebindings -> tactic
 
 val cut_and_apply         : constr -> tactic
 
-val apply_in              : identifier -> constr with_bindings list -> tactic
+val apply_in : evars_flag -> identifier -> constr with_ebindings list -> tactic
 
 (*s Elimination tactics. *)
 
@@ -201,7 +224,7 @@ val apply_in              : identifier -> constr with_bindings list -> tactic
 (* [rel_contexts] and [rel_declaration] actually contain triples, and
    lists are actually in reverse order to fit [compose_prod]. *)
 type elim_scheme = { 
-  elimc: (Term.constr * constr Rawterm.bindings) option;
+  elimc: constr with_ebindings option;
   elimt: types;
   indref: global_reference option;
   params: rel_context;     (* (prm1,tprm1);(prm2,tprm2)...(prmp,tprmp) *)
@@ -221,29 +244,32 @@ type elim_scheme = {
 }
 
 
-val compute_elim_sig : ?elimc: (Term.constr * constr Rawterm.bindings) -> types -> elim_scheme
+val compute_elim_sig : ?elimc: constr with_ebindings -> types -> elim_scheme
+val rebuild_elimtype_from_scheme: elim_scheme -> types
 
-val general_elim  :
-  constr with_bindings -> constr with_bindings -> ?allow_K:bool -> tactic
-val general_elim_in :
-  identifier -> constr with_bindings -> constr with_bindings -> tactic
+val general_elim  : evars_flag ->
+  constr with_ebindings -> constr with_ebindings -> ?allow_K:bool -> tactic
+val general_elim_in : evars_flag -> 
+  identifier -> constr with_ebindings -> constr with_ebindings -> tactic
 
-val default_elim  : constr with_bindings -> tactic
+val default_elim  : evars_flag -> constr with_ebindings -> tactic
 val simplest_elim : constr -> tactic
-val elim          : constr with_bindings -> constr with_bindings option -> tactic
+val elim : 
+  evars_flag -> constr with_ebindings -> constr with_ebindings option -> tactic
+
 val simple_induct : quantified_hypothesis -> tactic
 
-val new_induct : constr induction_arg list -> constr with_bindings option ->
-  intro_pattern_expr -> tactic
+val new_induct : evars_flag -> constr with_ebindings induction_arg list -> 
+  constr with_ebindings option -> intro_pattern_expr -> clause option -> tactic
 
 (*s Case analysis tactics. *)
 
-val general_case_analysis : constr with_bindings ->  tactic
+val general_case_analysis : evars_flag -> constr with_ebindings ->  tactic
 val simplest_case         : constr -> tactic
 
 val simple_destruct          : quantified_hypothesis -> tactic
-val new_destruct : constr induction_arg list -> constr with_bindings option ->
-  intro_pattern_expr -> tactic
+val new_destruct : evars_flag -> constr with_ebindings induction_arg list -> 
+  constr with_ebindings option -> intro_pattern_expr -> clause option -> tactic
 
 (*s Eliminations giving the type instead of the proof. *)
 
@@ -262,16 +288,22 @@ val dorE : bool -> clause ->tactic
 
 (*s Introduction tactics. *)
 
-val constructor_tac            : int option -> int -> 
-                                 constr bindings  -> tactic
-val one_constructor            : int -> constr bindings  -> tactic
-val any_constructor            : tactic option -> tactic
-val left                       : constr bindings -> tactic
-val simplest_left              : tactic
-val right                      : constr bindings -> tactic
-val simplest_right             : tactic
-val split                      : constr bindings -> tactic
-val simplest_split             : tactic
+val constructor_tac      : evars_flag -> int option -> int -> 
+                           open_constr bindings  -> tactic
+val any_constructor      : evars_flag -> tactic option -> tactic
+val one_constructor      : int -> open_constr bindings  -> tactic
+
+val left                 : constr bindings -> tactic
+val right                : constr bindings -> tactic
+val split                : constr bindings -> tactic
+
+val left_with_ebindings  : evars_flag -> open_constr bindings -> tactic
+val right_with_ebindings : evars_flag -> open_constr bindings -> tactic
+val split_with_ebindings : evars_flag -> open_constr bindings -> tactic
+
+val simplest_left        : tactic
+val simplest_right       : tactic
+val simplest_split       : tactic
 
 (*s Logical connective tactics. *)
 
@@ -300,14 +332,18 @@ val cut_in_parallel             : constr list -> tactic
 
 val assert_as : bool -> intro_pattern_expr -> constr -> tactic
 val forward   : tactic option -> intro_pattern_expr -> constr -> tactic
-
+val letin_tac : bool option -> name -> constr -> clause -> tactic
 val true_cut                    : name -> constr -> tactic
-val letin_tac                   : bool -> name -> constr -> clause -> tactic
 val assert_tac                  : bool -> name -> constr -> tactic
-val generalize                  : constr list -> tactic
-val generalize_dep              : constr  -> tactic
+val generalize      : constr list -> tactic
+val generalize_gen  : ((occurrences * constr) * name) list -> tactic
+val generalize_dep  : constr  -> tactic
 
 val tclABSTRACT : identifier option -> tactic -> tactic
 
 val admit_as_an_axiom : tactic
 
+val abstract_generalize : identifier -> tactic
+
+val register_general_multi_rewrite : 
+  (bool -> evars_flag -> constr with_ebindings -> clause -> tactic) -> unit
diff --git a/tactics/tauto.ml4 b/tactics/tauto.ml4
index c91038fc..54094d99 100644
--- a/tactics/tauto.ml4
+++ b/tactics/tauto.ml4
@@ -8,7 +8,7 @@
 
 (*i camlp4deps: "parsing/grammar.cma" i*)
 
-(*i $Id: tauto.ml4 7732 2005-12-26 13:51:24Z herbelin $ i*)
+(*i $Id: tauto.ml4 10731 2008-03-30 22:30:44Z herbelin $ i*)
 
 open Hipattern
 open Names
@@ -23,7 +23,7 @@ open Util
 let assoc_last ist =
   match List.assoc (Names.id_of_string "X1") ist.lfun with
     | VConstr c -> c
-    | _ -> failwith "Tauto: anomaly"
+    | _ -> failwith "tauto: anomaly"
 
 let is_empty ist =
   if is_empty_type (assoc_last ist) then
@@ -165,7 +165,7 @@ let tauto g =
   try intuition_gen (interp <:tactic<fail>>) g
   with
     Refiner.FailError _ | UserError _ ->
-      errorlabstrm "tauto" [< str "Tauto failed" >]
+      errorlabstrm "tauto" [< str "tauto failed" >]
 
 let default_intuition_tac = interp <:tactic< auto with * >>