Merge branch 'trunk' into pr379

83 files changed, 15159 insertions, 416 deletions

diff --git a/plugins/btauto/g_btauto.ml4 b/plugins/btauto/g_btauto.ml4
index f3e2c99f4..298027448 100644
--- a/plugins/btauto/g_btauto.ml4
+++ b/plugins/btauto/g_btauto.ml4
@@ -8,6 +8,8 @@
 
 (*i camlp4deps: "grammar/grammar.cma"  i*)
 
+open Ltac_plugin
+
 DECLARE PLUGIN "btauto_plugin"
 
 TACTIC EXTEND btauto
diff --git a/plugins/cc/g_congruence.ml4 b/plugins/cc/g_congruence.ml4
index 6f6811334..7e76854b1 100644
--- a/plugins/cc/g_congruence.ml4
+++ b/plugins/cc/g_congruence.ml4
@@ -8,6 +8,7 @@
 
 (*i camlp4deps: "grammar/grammar.cma" i*)
 
+open Ltac_plugin
 open Cctac
 open Stdarg
 
diff --git a/plugins/decl_mode/decl_interp.ml b/plugins/decl_mode/decl_interp.ml
index 828d634d0..3aa572529 100644
--- a/plugins/decl_mode/decl_interp.ml
+++ b/plugins/decl_mode/decl_interp.ml
@@ -6,6 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
+open Ltac_plugin
 open CErrors
 open Util
 open Names
diff --git a/plugins/decl_mode/decl_proof_instr.ml b/plugins/decl_mode/decl_proof_instr.ml
index 4fe59d755..2ea4538c3 100644
--- a/plugins/decl_mode/decl_proof_instr.ml
+++ b/plugins/decl_mode/decl_proof_instr.ml
@@ -6,6 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
+open Ltac_plugin
 open CErrors
 open Util
 open Pp
diff --git a/plugins/decl_mode/g_decl_mode.ml4 b/plugins/decl_mode/g_decl_mode.ml4
index 18a35c6cf..a71d20f0d 100644
--- a/plugins/decl_mode/g_decl_mode.ml4
+++ b/plugins/decl_mode/g_decl_mode.ml4
@@ -10,6 +10,7 @@
 
 DECLARE PLUGIN "decl_mode_plugin"
 
+open Ltac_plugin
 open Compat
 open Pp
 open Decl_expr
diff --git a/plugins/decl_mode/ppdecl_proof.ml b/plugins/decl_mode/ppdecl_proof.ml
index 93b98263e..92045e775 100644
--- a/plugins/decl_mode/ppdecl_proof.ml
+++ b/plugins/decl_mode/ppdecl_proof.ml
@@ -6,6 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
+open Ltac_plugin
 open CErrors
 open Pp
 open Decl_expr
diff --git a/plugins/extraction/common.ml b/plugins/extraction/common.ml
index de97ba97c..fc8d5356c 100644
--- a/plugins/extraction/common.ml
+++ b/plugins/extraction/common.ml
@@ -67,7 +67,9 @@ let pp_boxed_tuple f = function
     blocks is less that a line length. To avoid this awkward situation,
     we attach a big virtual size to [fnl] newlines. *)
 
-let fnl () = stras (1000000,"") ++ fnl ()
+(* EG: This looks quite suspicious... but beware of bugs *)
+(* let fnl () = stras (1000000,"") ++ fnl () *)
+let fnl () = fnl ()
 
 let fnl2 () = fnl () ++ fnl ()
 
@@ -91,10 +93,7 @@ let begins_with_CoqXX s =
 
 let unquote s =
   if lang () != Scheme then s
-  else
-    let s = String.copy s in
-    for i=0 to String.length s - 1 do if s.[i] == '\'' then s.[i] <- '~' done;
-    s
+  else String.map (fun c -> if c == '\'' then '~' else c) s
 
 let rec qualify delim = function
   | [] -> assert false
diff --git a/plugins/extraction/extract_env.ml b/plugins/extraction/extract_env.ml
index e019bb3c2..2b12462ad 100644
--- a/plugins/extraction/extract_env.ml
+++ b/plugins/extraction/extract_env.ml
@@ -472,13 +472,14 @@ let formatter dry file =
     if dry then Format.make_formatter (fun _ _ _ -> ()) (fun _ -> ())
     else
       match file with
-	| Some f -> Pp_control.with_output_to f
+	| Some f -> Topfmt.with_output_to f
 	| None -> Format.formatter_of_buffer buf
   in
+  (* XXX: Fixme, this shouldn't depend on Topfmt *)
   (* We never want to see ellipsis ... in extracted code *)
   Format.pp_set_max_boxes ft max_int;
   (* We reuse the width information given via "Set Printing Width" *)
-  (match Pp_control.get_margin () with
+  (match Topfmt.get_margin () with
     | None -> ()
     | Some i ->
       Format.pp_set_margin ft i;
@@ -518,8 +519,10 @@ let print_structure_to_file (fn,si,mo) dry struc =
     set_phase Impl;
     pp_with ft (d.preamble mo comment opened unsafe_needs);
     pp_with ft (d.pp_struct struc);
+    Format.pp_print_flush ft ();
     Option.iter close_out cout;
   with reraise ->
+    Format.pp_print_flush ft ();
     Option.iter close_out cout; raise reraise
   end;
   if not dry then Option.iter info_file fn;
@@ -532,8 +535,10 @@ let print_structure_to_file (fn,si,mo) dry struc =
 	 set_phase Intf;
 	 pp_with ft (d.sig_preamble mo comment opened unsafe_needs);
 	 pp_with ft (d.pp_sig (signature_of_structure struc));
+         Format.pp_print_flush ft ();
 	 close_out cout;
        with reraise ->
+         Format.pp_print_flush ft ();
 	 close_out cout; raise reraise
        end;
        info_file si)
diff --git a/plugins/extraction/g_extraction.ml4 b/plugins/extraction/g_extraction.ml4
index e1d6bb4a8..3ed959cf2 100644
--- a/plugins/extraction/g_extraction.ml4
+++ b/plugins/extraction/g_extraction.ml4
@@ -12,6 +12,7 @@ DECLARE PLUGIN "extraction_plugin"
 
 (* ML names *)
 
+open Ltac_plugin
 open Genarg
 open Stdarg
 open Pcoq.Prim
diff --git a/plugins/extraction/ocaml.ml b/plugins/extraction/ocaml.ml
index d89bf95ee..d8e382155 100644
--- a/plugins/extraction/ocaml.ml
+++ b/plugins/extraction/ocaml.ml
@@ -66,7 +66,7 @@ let pp_header_comment = function
   | None -> mt ()
   | Some com -> pp_comment com ++ fnl2 ()
 
-let then_nl pp = if Pp.is_empty pp then mt () else pp ++ fnl ()
+let then_nl pp = if Pp.ismt pp then mt () else pp ++ fnl ()
 
 let pp_tdummy usf =
   if usf.tdummy || usf.tunknown then str "type __ = Obj.t" ++ fnl () else mt ()
@@ -618,7 +618,7 @@ and pp_module_type params = function
       push_visible mp params;
       let try_pp_specif l x =
         let px = pp_specif x in
-        if Pp.is_empty px then l else px::l
+        if Pp.ismt px then l else px::l
       in
       (* We cannot use fold_right here due to side effects in pp_specif *)
       let l = List.fold_left try_pp_specif [] sign in
@@ -696,7 +696,7 @@ and pp_module_expr params = function
       push_visible mp params;
       let try_pp_structure_elem l x =
         let px = pp_structure_elem x in
-        if Pp.is_empty px then l else px::l
+        if Pp.ismt px then l else px::l
       in
       (* We cannot use fold_right here due to side effects in pp_structure_elem *)
       let l = List.fold_left try_pp_structure_elem [] sel in
@@ -714,7 +714,7 @@ let rec prlist_sep_nonempty sep f = function
   | h::t ->
      let e = f h in
      let r = prlist_sep_nonempty sep f t in
-     if Pp.is_empty e then r
+     if Pp.ismt e then r
      else e ++ sep () ++ r
 
 let do_struct f s =
diff --git a/plugins/extraction/scheme.ml b/plugins/extraction/scheme.ml
index a6309e61f..8d0cc4a0d 100644
--- a/plugins/extraction/scheme.ml
+++ b/plugins/extraction/scheme.ml
@@ -40,11 +40,7 @@ let preamble _ comment _ usf =
   (if usf.mldummy then str "(define __ (lambda (_) __))\n\n" else mt ())
 
 let pr_id id =
-  let s = Id.to_string id in
-  for i = 0 to String.length s - 1 do
-    if s.[i] == '\'' then s.[i] <- '~'
-  done;
-  str s
+  str @@ String.map (fun c -> if c == '\'' then '~' else c) (Id.to_string id)
 
 let paren = pp_par true
 
diff --git a/plugins/extraction/table.ml b/plugins/extraction/table.ml
index 5e7d810c9..d6a334c5f 100644
--- a/plugins/extraction/table.ml
+++ b/plugins/extraction/table.ml
@@ -773,9 +773,7 @@ let file_of_modfile mp =
     | MPfile f -> Id.to_string (List.hd (DirPath.repr f))
     | _ -> assert false
   in
-  let s = String.copy (string_of_modfile mp) in
-  if s.[0] != s0.[0] then s.[0] <- s0.[0];
-  s
+  String.mapi (fun i c -> if i = 0 then s0.[0] else c) (string_of_modfile mp)
 
 let add_blacklist_entries l =
   blacklist_table :=
diff --git a/plugins/firstorder/g_ground.ml4 b/plugins/firstorder/g_ground.ml4
index 260e86ad6..e28d6aa62 100644
--- a/plugins/firstorder/g_ground.ml4
+++ b/plugins/firstorder/g_ground.ml4
@@ -8,6 +8,7 @@
 
 (*i camlp4deps: "grammar/grammar.cma"  i*)
 
+open Ltac_plugin
 open Formula
 open Sequent
 open Ground
diff --git a/plugins/firstorder/ground.ml b/plugins/firstorder/ground.ml
index 628af4e71..d6cd7e2a0 100644
--- a/plugins/firstorder/ground.ml
+++ b/plugins/firstorder/ground.ml
@@ -6,6 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
+open Ltac_plugin
 open Formula
 open Sequent
 open Rules
diff --git a/plugins/fourier/Fourier.v b/plugins/fourier/Fourier.v
index 1d7ee93ea..a96254713 100644
--- a/plugins/fourier/Fourier.v
+++ b/plugins/fourier/Fourier.v
@@ -13,6 +13,6 @@ Require Export DiscrR.
 Require Export Fourier_util.
 Declare ML Module "fourier_plugin".
 
-Ltac fourier := abstract (fourierz; field; discrR).
+Ltac fourier := abstract (compute [IZR IPR IPR_2] in *; fourierz; field; discrR).
 
 Ltac fourier_eq := apply Rge_antisym; fourier.
diff --git a/plugins/fourier/g_fourier.ml4 b/plugins/fourier/g_fourier.ml4
index 7c665ae7b..1960fa835 100644
--- a/plugins/fourier/g_fourier.ml4
+++ b/plugins/fourier/g_fourier.ml4
@@ -8,6 +8,7 @@
 
 (*i camlp4deps: "grammar/grammar.cma" i*)
 
+open Ltac_plugin
 open FourierR
 
 DECLARE PLUGIN "fourier_plugin"
diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml
index bc64b079c..48c0f5f04 100644
--- a/plugins/funind/functional_principles_proofs.ml
+++ b/plugins/funind/functional_principles_proofs.ml
@@ -1228,7 +1228,7 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam
     let mk_fixes : tactic =
       let pre_info,infos = list_chop fun_num infos in
       match pre_info,infos with
-	| [],[] -> tclIDTAC
+	| _,[] -> tclIDTAC
 	| _, this_fix_info::others_infos ->
 	    let other_fix_infos =
 	      List.map
@@ -1244,7 +1244,6 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam
 	    else
 	      Proofview.V82.of_tactic (Tactics.mutual_fix this_fix_info.name (this_fix_info.idx + 1)
 		other_fix_infos 0)
-	| _ -> anomaly (Pp.str "Not a valid information")
     in
     let first_tac : tactic = (* every operations until fix creations *)
       tclTHENSEQ
diff --git a/plugins/funind/g_indfun.ml4 b/plugins/funind/g_indfun.ml4
index 27a892ca7..253f3ba72 100644
--- a/plugins/funind/g_indfun.ml4
+++ b/plugins/funind/g_indfun.ml4
@@ -6,6 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 (*i camlp4deps: "grammar/grammar.cma" i*)
+open Ltac_plugin
 open Compat
 open Util
 open Term
diff --git a/plugins/funind/invfun.ml b/plugins/funind/invfun.ml
index 8f1420940..2c2cd919b 100644
--- a/plugins/funind/invfun.ml
+++ b/plugins/funind/invfun.ml
@@ -6,6 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
+open Ltac_plugin
 open Tacexpr
 open Declarations
 open CErrors
diff --git a/plugins/ltac/Ltac.v b/plugins/ltac/Ltac.v
new file mode 100644
index 000000000..e69de29bb
--- /dev/null
+++ b/plugins/ltac/Ltac.v
diff --git a/plugins/ltac/coretactics.ml4 b/plugins/ltac/coretactics.ml4
new file mode 100644
index 000000000..28ff6df83
--- /dev/null
+++ b/plugins/ltac/coretactics.ml4
@@ -0,0 +1,329 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i camlp4deps: "grammar/grammar.cma" i*)
+
+open Util
+open Names
+open Locus
+open Misctypes
+open Genredexpr
+open Stdarg
+open Extraargs
+
+open Sigma.Notations
+
+DECLARE PLUGIN "coretactics"
+
+(** Basic tactics *)
+
+TACTIC EXTEND reflexivity
+  [ "reflexivity" ] -> [ Tactics.intros_reflexivity ]
+END
+
+TACTIC EXTEND exact
+  [ "exact" casted_constr(c) ] -> [ Tactics.exact_no_check c ]
+END
+
+TACTIC EXTEND assumption
+  [ "assumption" ] -> [ Tactics.assumption ]
+END
+
+TACTIC EXTEND etransitivity
+  [ "etransitivity" ] -> [ Tactics.intros_transitivity None ]
+END
+
+TACTIC EXTEND cut
+  [ "cut" constr(c) ] -> [ Tactics.cut c ]
+END
+
+TACTIC EXTEND exact_no_check
+  [ "exact_no_check" constr(c) ] -> [ Tactics.exact_no_check c ]
+END
+
+TACTIC EXTEND vm_cast_no_check
+  [ "vm_cast_no_check" constr(c) ] -> [ Tactics.vm_cast_no_check c ]
+END
+
+TACTIC EXTEND native_cast_no_check
+  [ "native_cast_no_check" constr(c) ] -> [ Tactics.native_cast_no_check c ]
+END
+
+TACTIC EXTEND casetype
+  [ "casetype" constr(c) ] -> [ Tactics.case_type c ]
+END
+
+TACTIC EXTEND elimtype
+  [ "elimtype" constr(c) ] -> [ Tactics.elim_type c ]
+END
+
+TACTIC EXTEND lapply
+  [ "lapply" constr(c) ] -> [ Tactics.cut_and_apply c ]
+END
+
+TACTIC EXTEND transitivity
+  [ "transitivity" constr(c) ] -> [ Tactics.intros_transitivity (Some c) ]
+END
+
+(** Left *)
+
+TACTIC EXTEND left
+  [ "left" ] -> [ Tactics.left_with_bindings false NoBindings ]
+END
+
+TACTIC EXTEND eleft
+  [ "eleft" ] -> [ Tactics.left_with_bindings true NoBindings ]
+END
+
+TACTIC EXTEND left_with
+  [ "left" "with" bindings(bl) ] -> [
+    Tacticals.New.tclDELAYEDWITHHOLES false bl (fun bl -> Tactics.left_with_bindings false bl)
+  ]
+END
+
+TACTIC EXTEND eleft_with
+  [ "eleft" "with" bindings(bl) ] -> [
+    Tacticals.New.tclDELAYEDWITHHOLES true bl (fun bl -> Tactics.left_with_bindings true bl)
+  ]
+END
+
+(** Right *)
+
+TACTIC EXTEND right
+  [ "right" ] -> [ Tactics.right_with_bindings false NoBindings ]
+END
+
+TACTIC EXTEND eright
+  [ "eright" ] -> [ Tactics.right_with_bindings true NoBindings ]
+END
+
+TACTIC EXTEND right_with
+  [ "right" "with" bindings(bl) ] -> [
+    Tacticals.New.tclDELAYEDWITHHOLES false bl (fun bl -> Tactics.right_with_bindings false bl)
+  ]
+END
+
+TACTIC EXTEND eright_with
+  [ "eright" "with" bindings(bl) ] -> [
+    Tacticals.New.tclDELAYEDWITHHOLES true bl (fun bl -> Tactics.right_with_bindings true bl)
+  ]
+END
+
+(** Constructor *)
+
+TACTIC EXTEND constructor
+  [ "constructor" ] -> [ Tactics.any_constructor false None ]
+| [ "constructor" int_or_var(i) ] -> [
+    Tactics.constructor_tac false None i NoBindings
+  ]
+| [ "constructor" int_or_var(i) "with" bindings(bl) ] -> [
+    let tac bl = Tactics.constructor_tac false None i bl in
+    Tacticals.New.tclDELAYEDWITHHOLES false bl tac
+  ]
+END
+
+TACTIC EXTEND econstructor
+  [ "econstructor" ] -> [ Tactics.any_constructor true None ]
+| [ "econstructor" int_or_var(i) ] -> [
+    Tactics.constructor_tac true None i NoBindings
+  ]
+| [ "econstructor" int_or_var(i) "with" bindings(bl) ] -> [
+    let tac bl = Tactics.constructor_tac true None i bl in
+    Tacticals.New.tclDELAYEDWITHHOLES true bl tac
+  ]
+END
+
+(** Specialize *)
+
+TACTIC EXTEND specialize
+  [ "specialize" constr_with_bindings(c) ] -> [
+    Tacticals.New.tclDELAYEDWITHHOLES false c (fun c -> Tactics.specialize c None)
+  ]
+| [ "specialize" constr_with_bindings(c) "as" intropattern(ipat) ] -> [
+    Tacticals.New.tclDELAYEDWITHHOLES false c (fun c -> Tactics.specialize c (Some ipat))
+  ]
+END
+
+TACTIC EXTEND symmetry
+  [ "symmetry" ] -> [ Tactics.intros_symmetry {onhyps=Some[];concl_occs=AllOccurrences} ]
+END
+
+TACTIC EXTEND symmetry_in
+| [ "symmetry" "in" in_clause(cl) ] -> [ Tactics.intros_symmetry cl ]
+END
+
+(** Split *)
+
+let rec delayed_list = function
+| [] -> { Tacexpr.delayed = fun _ sigma -> Sigma.here [] sigma }
+| x :: l ->
+  { Tacexpr.delayed = fun env sigma ->
+    let Sigma (x, sigma, p) = x.Tacexpr.delayed env sigma in
+    let Sigma (l, sigma, q) = (delayed_list l).Tacexpr.delayed env sigma in
+    Sigma (x :: l, sigma, p +> q) }
+
+TACTIC EXTEND split
+  [ "split" ] -> [ Tactics.split_with_bindings false [NoBindings] ]
+END
+
+TACTIC EXTEND esplit
+  [ "esplit" ] -> [ Tactics.split_with_bindings true [NoBindings] ]
+END
+
+TACTIC EXTEND split_with
+  [ "split" "with" bindings(bl) ] -> [
+    Tacticals.New.tclDELAYEDWITHHOLES false bl (fun bl -> Tactics.split_with_bindings false [bl])
+  ]
+END
+
+TACTIC EXTEND esplit_with
+  [ "esplit" "with" bindings(bl) ] -> [
+    Tacticals.New.tclDELAYEDWITHHOLES true bl (fun bl -> Tactics.split_with_bindings true [bl])
+  ]
+END
+
+TACTIC EXTEND exists
+  [ "exists" ] -> [ Tactics.split_with_bindings false [NoBindings] ]
+| [ "exists" ne_bindings_list_sep(bll, ",") ] -> [
+    Tacticals.New.tclDELAYEDWITHHOLES false (delayed_list bll) (fun bll -> Tactics.split_with_bindings false bll)
+  ]
+END
+
+TACTIC EXTEND eexists
+  [ "eexists" ] -> [ Tactics.split_with_bindings true [NoBindings] ]
+| [ "eexists" ne_bindings_list_sep(bll, ",") ] -> [
+    Tacticals.New.tclDELAYEDWITHHOLES true (delayed_list bll) (fun bll -> Tactics.split_with_bindings true bll)
+  ]
+END
+
+(** Intro *)
+
+TACTIC EXTEND intros_until
+  [ "intros" "until" quantified_hypothesis(h) ] -> [ Tactics.intros_until h ]
+END
+
+TACTIC EXTEND intro
+| [ "intro" ] -> [ Tactics.intro_move None MoveLast ]
+| [ "intro" ident(id) ] -> [ Tactics.intro_move (Some id) MoveLast ]
+| [ "intro" ident(id) "at" "top" ] -> [ Tactics.intro_move (Some id) MoveFirst ]
+| [ "intro" ident(id) "at" "bottom" ] -> [ Tactics.intro_move (Some id) MoveLast ]
+| [ "intro" ident(id) "after" hyp(h) ] -> [ Tactics.intro_move (Some id) (MoveAfter h) ]
+| [ "intro" ident(id) "before" hyp(h) ] -> [ Tactics.intro_move (Some id) (MoveBefore h) ]
+| [ "intro" "at" "top" ] -> [ Tactics.intro_move None MoveFirst ]
+| [ "intro" "at" "bottom" ] -> [ Tactics.intro_move None MoveLast ]
+| [ "intro" "after" hyp(h) ] -> [ Tactics.intro_move None (MoveAfter h) ]
+| [ "intro" "before" hyp(h) ] -> [ Tactics.intro_move None (MoveBefore h) ]
+END
+
+(** Move *)
+
+TACTIC EXTEND move
+  [ "move" hyp(id) "at" "top" ] -> [ Tactics.move_hyp id MoveFirst ]
+| [ "move" hyp(id) "at" "bottom" ] -> [ Tactics.move_hyp id MoveLast ]
+| [ "move" hyp(id) "after" hyp(h) ] -> [ Tactics.move_hyp id (MoveAfter h) ]
+| [ "move" hyp(id) "before" hyp(h) ] -> [ Tactics.move_hyp id (MoveBefore h) ]
+END
+
+(** Rename *)
+
+TACTIC EXTEND rename
+| [ "rename" ne_rename_list_sep(ids, ",") ] -> [ Tactics.rename_hyp ids ]
+END
+
+(** Revert *)
+
+TACTIC EXTEND revert
+  [ "revert" ne_hyp_list(hl) ] -> [ Tactics.revert hl ]
+END
+
+(** Simple induction / destruct *)
+
+TACTIC EXTEND simple_induction
+  [ "simple" "induction" quantified_hypothesis(h) ] -> [ Tactics.simple_induct h ]
+END
+
+TACTIC EXTEND simple_destruct
+  [ "simple" "destruct" quantified_hypothesis(h) ] -> [ Tactics.simple_destruct h ]
+END
+
+(** Double induction *)
+
+TACTIC EXTEND double_induction
+  [ "double" "induction" quantified_hypothesis(h1) quantified_hypothesis(h2) ] ->
+  [ Elim.h_double_induction h1 h2 ]
+END
+
+(* Admit *)
+
+TACTIC EXTEND admit
+ [ "admit" ] -> [ Proofview.give_up ]
+END
+
+(* Fix *)
+
+TACTIC EXTEND fix
+  [ "fix" natural(n) ] -> [ Tactics.fix None n ]
+| [ "fix" ident(id) natural(n) ] -> [ Tactics.fix (Some id) n ]
+END
+
+(* Cofix *)
+
+TACTIC EXTEND cofix
+  [ "cofix" ] -> [ Tactics.cofix None ]
+| [ "cofix" ident(id) ] -> [ Tactics.cofix (Some id) ]
+END
+
+(* Clear *)
+
+TACTIC EXTEND clear
+  [ "clear" hyp_list(ids) ] -> [
+    if List.is_empty ids then Tactics.keep []
+    else Tactics.clear ids
+  ]
+| [ "clear" "-" ne_hyp_list(ids) ] -> [ Tactics.keep ids ]
+END
+
+(* Clearbody *)
+
+TACTIC EXTEND clearbody
+  [ "clearbody" ne_hyp_list(ids) ] -> [ Tactics.clear_body ids ]
+END
+
+(* Generalize dependent *)
+
+TACTIC EXTEND generalize_dependent
+  [ "generalize" "dependent" constr(c) ] -> [ Tactics.generalize_dep c ]
+END
+
+(* Table of "pervasives" macros tactics (e.g. auto, simpl, etc.) *)
+
+open Tacexpr
+
+let initial_atomic () =
+  let dloc = Loc.ghost in
+  let nocl = {onhyps=Some[];concl_occs=AllOccurrences} in
+  let iter (s, t) =
+    let body = TacAtom (dloc, t) in
+    Tacenv.register_ltac false false (Id.of_string s) body
+  in
+  let () = List.iter iter
+      [ "red", TacReduce(Red false,nocl);
+        "hnf", TacReduce(Hnf,nocl);
+        "simpl", TacReduce(Simpl (Redops.all_flags,None),nocl);
+        "compute", TacReduce(Cbv Redops.all_flags,nocl);
+        "intros", TacIntroPattern (false,[]);
+      ]
+  in
+  let iter (s, t) = Tacenv.register_ltac false false (Id.of_string s) t in
+  List.iter iter
+      [ "idtac",TacId [];
+        "fail", TacFail(TacLocal,ArgArg 0,[]);
+        "fresh", TacArg(dloc,TacFreshId [])
+      ]
+
+let () = Mltop.declare_cache_obj initial_atomic "coretactics"
diff --git a/plugins/ltac/evar_tactics.ml b/plugins/ltac/evar_tactics.ml
new file mode 100644
index 000000000..5d3f6df03
--- /dev/null
+++ b/plugins/ltac/evar_tactics.ml
@@ -0,0 +1,119 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+open Util
+open Names
+open Term
+open EConstr
+open CErrors
+open Evar_refiner
+open Tacmach
+open Tacexpr
+open Refiner
+open Evd
+open Locus
+open Sigma.Notations
+open Proofview.Notations
+open Context.Named.Declaration
+
+module NamedDecl = Context.Named.Declaration
+
+(* The instantiate tactic *)
+
+let instantiate_evar evk (ist,rawc) sigma =
+  let evi = Evd.find sigma evk in
+  let filtered = Evd.evar_filtered_env evi in
+  let constrvars = Tacinterp.extract_ltac_constr_values ist filtered in
+  let lvar = {
+    Pretyping.ltac_constrs = constrvars;
+    ltac_uconstrs = Names.Id.Map.empty;
+    ltac_idents = Names.Id.Map.empty;
+    ltac_genargs = ist.Geninterp.lfun;
+  } in
+  let sigma' = w_refine (evk,evi) (lvar ,rawc) sigma in
+  tclEVARS sigma'
+
+let evar_list sigma c =
+  let rec evrec acc c =
+    match EConstr.kind sigma c with
+    | Evar (evk, _ as ev) -> ev :: acc
+    | _ -> EConstr.fold sigma evrec acc c in
+  evrec [] c
+
+let instantiate_tac n c ido =
+  Proofview.V82.tactic begin fun gl ->
+  let sigma = gl.sigma in
+  let evl =
+    match ido with
+	ConclLocation () -> evar_list sigma (pf_concl gl)
+      | HypLocation (id,hloc) ->
+	  let decl = Environ.lookup_named_val id (Goal.V82.hyps sigma (sig_it gl)) in
+	    match hloc with
+		InHyp ->
+		  (match decl with
+                    | LocalAssum (_,typ) -> evar_list sigma (EConstr.of_constr typ)
+		    | _ -> error
+			"Please be more specific: in type or value?")
+	      | InHypTypeOnly ->
+		  evar_list sigma (EConstr.of_constr (NamedDecl.get_type decl))
+	      | InHypValueOnly ->
+		  (match decl with
+		    | LocalDef (_,body,_) -> evar_list sigma (EConstr.of_constr body)
+		    | _ -> error "Not a defined hypothesis.") in
+  if List.length evl < n then
+    error "Not enough uninstantiated existential variables.";
+  if n <= 0 then error "Incorrect existential variable index.";
+  let evk,_ = List.nth evl (n-1) in
+  instantiate_evar evk c sigma gl
+  end
+
+let instantiate_tac_by_name id c =
+  Proofview.V82.tactic begin fun gl ->
+  let sigma = gl.sigma in
+  let evk =
+    try Evd.evar_key id sigma
+    with Not_found -> error "Unknown existential variable." in
+  instantiate_evar evk c sigma gl
+  end
+
+let let_evar name typ =
+  let src = (Loc.ghost,Evar_kinds.GoalEvar) in
+  Proofview.Goal.s_enter { s_enter = begin fun gl ->
+    let sigma = Tacmach.New.project gl in
+    let env = Proofview.Goal.env gl in
+    let sigma = ref sigma in
+    let _ = Typing.e_sort_of env sigma typ in
+    let sigma = !sigma in
+    let id = match name with
+    | Names.Anonymous -> 
+      let id = Namegen.id_of_name_using_hdchar env sigma typ name in
+      Namegen.next_ident_away_in_goal id (Termops.ids_of_named_context (Environ.named_context env))
+    | Names.Name id -> id
+    in
+    let sigma = Sigma.Unsafe.of_evar_map sigma in
+    let Sigma (evar, sigma, p) = Evarutil.new_evar env sigma ~src ~naming:(Misctypes.IntroFresh id) typ in
+    let tac =
+      (Tactics.letin_tac None (Names.Name id) evar None Locusops.nowhere)
+    in
+    Sigma (tac, sigma, p)
+  end }
+
+let hget_evar n =
+  let open EConstr in
+  Proofview.Goal.nf_enter { enter = begin fun gl ->
+  let sigma = Tacmach.New.project gl in
+  let concl = Proofview.Goal.concl gl in
+  let evl = evar_list sigma concl in
+  if List.length evl < n then
+    error "Not enough uninstantiated existential variables.";
+  if n <= 0 then error "Incorrect existential variable index.";
+  let ev = List.nth evl (n-1) in
+  let ev_type = EConstr.existential_type sigma ev in
+  Tactics.change_concl (mkLetIn (Anonymous,mkEvar ev,ev_type,concl))
+  end }
+
diff --git a/plugins/ltac/evar_tactics.mli b/plugins/ltac/evar_tactics.mli
new file mode 100644
index 000000000..cfe747665
--- /dev/null
+++ b/plugins/ltac/evar_tactics.mli
@@ -0,0 +1,21 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+open Names
+open Tacexpr
+open Locus
+
+val instantiate_tac : int -> Tacinterp.interp_sign * Glob_term.glob_constr ->
+  (Id.t * hyp_location_flag, unit) location -> unit Proofview.tactic
+
+val instantiate_tac_by_name : Id.t ->
+  Tacinterp.interp_sign * Glob_term.glob_constr -> unit Proofview.tactic
+
+val let_evar : Name.t -> EConstr.types -> unit Proofview.tactic
+
+val hget_evar : int -> unit Proofview.tactic
diff --git a/plugins/ltac/extraargs.ml4 b/plugins/ltac/extraargs.ml4
new file mode 100644
index 000000000..53b726432
--- /dev/null
+++ b/plugins/ltac/extraargs.ml4
@@ -0,0 +1,389 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i camlp4deps: "grammar/grammar.cma" i*)
+
+open Pp
+open Genarg
+open Stdarg
+open Tacarg
+open Pcoq.Prim
+open Pcoq.Constr
+open Names
+open Tacmach
+open Tacexpr
+open Taccoerce
+open Tacinterp
+open Misctypes
+open Locus
+
+(** Adding scopes for generic arguments not defined through ARGUMENT EXTEND *)
+
+let create_generic_quotation name e wit =
+  let inject (loc, v) = Tacexpr.TacGeneric (Genarg.in_gen (Genarg.rawwit wit) v) in
+  Tacentries.create_ltac_quotation name inject (e, None)
+
+let () = create_generic_quotation "integer" Pcoq.Prim.integer Stdarg.wit_int
+let () = create_generic_quotation "string" Pcoq.Prim.string Stdarg.wit_string
+
+let () = create_generic_quotation "ident" Pcoq.Prim.ident Stdarg.wit_ident
+let () = create_generic_quotation "reference" Pcoq.Prim.reference Stdarg.wit_ref
+let () = create_generic_quotation "uconstr" Pcoq.Constr.lconstr Stdarg.wit_uconstr
+let () = create_generic_quotation "constr" Pcoq.Constr.lconstr Stdarg.wit_constr
+let () = create_generic_quotation "ipattern" Pltac.simple_intropattern Stdarg.wit_intro_pattern
+let () = create_generic_quotation "open_constr" Pcoq.Constr.lconstr Stdarg.wit_open_constr
+let () =
+  let inject (loc, v) = Tacexpr.Tacexp v in
+  Tacentries.create_ltac_quotation "ltac" inject (Pltac.tactic_expr, Some 5)
+
+(** Backward-compatible tactic notation entry names *)
+
+let () =
+  let register name entry = Tacentries.register_tactic_notation_entry name entry in
+  register "hyp" wit_var;
+  register "simple_intropattern" wit_intro_pattern;
+  register "integer" wit_integer;
+  register "reference" wit_ref;
+  ()
+
+(* Rewriting orientation *)
+
+let _ = Metasyntax.add_token_obj "<-"
+let _ = Metasyntax.add_token_obj "->"
+
+let pr_orient _prc _prlc _prt = function
+  | true -> Pp.mt ()
+  | false -> Pp.str " <-"
+
+ARGUMENT EXTEND orient TYPED AS bool PRINTED BY pr_orient
+| [ "->" ] -> [ true ]
+| [ "<-" ] -> [ false ]
+| [ ] -> [ true ]
+END
+
+let pr_int _ _ _ i = Pp.int i
+
+let _natural = Pcoq.Prim.natural
+
+ARGUMENT EXTEND natural TYPED AS int PRINTED BY pr_int
+| [ _natural(i) ] -> [ i ]
+END
+
+let pr_orient = pr_orient () () ()
+
+
+let pr_int_list = Pp.pr_sequence Pp.int
+let pr_int_list_full _prc _prlc _prt l = pr_int_list l
+
+let pr_occurrences _prc _prlc _prt l =
+  match l with
+    | ArgArg x -> pr_int_list x
+    | ArgVar (loc, id) -> Nameops.pr_id id
+
+let occurrences_of = function
+  | [] -> NoOccurrences
+  | n::_ as nl when n < 0 -> AllOccurrencesBut (List.map abs nl)
+  | nl ->
+      if List.exists (fun n -> n < 0) nl then
+        CErrors.error "Illegal negative occurrence number.";
+      OnlyOccurrences nl
+
+let coerce_to_int v = match Value.to_int v with
+  | None -> raise (CannotCoerceTo "an integer")
+  | Some n -> n
+
+let int_list_of_VList v = match Value.to_list v with
+| Some l -> List.map (fun n -> coerce_to_int n) l
+| _ -> raise (CannotCoerceTo "an integer")
+
+let interp_occs ist gl l =
+  match l with
+    | ArgArg x -> x
+    | ArgVar (_,id as locid) ->
+	(try int_list_of_VList (Id.Map.find id ist.lfun)
+	  with Not_found | CannotCoerceTo _ -> [interp_int ist locid])
+let interp_occs ist gl l =
+  Tacmach.project gl , interp_occs ist gl l
+
+let glob_occs ist l = l
+
+let subst_occs evm l = l
+
+ARGUMENT EXTEND occurrences
+  TYPED AS int list
+  PRINTED BY pr_int_list_full
+
+  INTERPRETED BY interp_occs
+  GLOBALIZED BY glob_occs
+  SUBSTITUTED BY subst_occs
+
+  RAW_PRINTED BY pr_occurrences
+  GLOB_PRINTED BY pr_occurrences
+
+| [ ne_integer_list(l) ] -> [ ArgArg l ]
+| [ var(id) ] -> [ ArgVar id ]
+END
+
+let pr_occurrences = pr_occurrences () () ()
+
+let pr_gen prc _prlc _prtac c = prc c
+
+let pr_globc _prc _prlc _prtac (_,glob) = Printer.pr_glob_constr glob
+
+let interp_glob ist gl (t,_) = Tacmach.project gl , (ist,t)
+
+let glob_glob = Tacintern.intern_constr
+
+let pr_lconstr _ prc _ c = prc c
+
+let subst_glob = Tacsubst.subst_glob_constr_and_expr
+
+ARGUMENT EXTEND glob
+    PRINTED BY pr_globc
+
+     INTERPRETED BY interp_glob
+     GLOBALIZED BY glob_glob
+     SUBSTITUTED BY subst_glob
+
+     RAW_PRINTED BY pr_gen
+     GLOB_PRINTED BY pr_gen
+  [ constr(c) ] -> [ c ]
+END
+
+let l_constr = Pcoq.Constr.lconstr
+
+ARGUMENT EXTEND lconstr
+    TYPED AS constr
+    PRINTED BY pr_lconstr
+  [ l_constr(c) ] -> [ c ]
+END
+
+ARGUMENT EXTEND lglob
+  TYPED AS glob
+    PRINTED BY pr_globc
+
+     INTERPRETED BY interp_glob
+     GLOBALIZED BY glob_glob
+     SUBSTITUTED BY subst_glob
+
+     RAW_PRINTED BY pr_gen
+     GLOB_PRINTED BY pr_gen
+  [ lconstr(c) ] -> [ c ]
+END
+
+let interp_casted_constr ist gl c =
+  interp_constr_gen (Pretyping.OfType (pf_concl gl)) ist (pf_env gl) (project gl) c
+
+ARGUMENT EXTEND casted_constr
+  TYPED AS constr
+  PRINTED BY pr_gen
+  INTERPRETED BY interp_casted_constr
+  [ constr(c) ] -> [ c ]
+END
+
+type 'id gen_place= ('id * hyp_location_flag,unit) location
+
+type loc_place = Id.t Loc.located gen_place
+type place = Id.t gen_place
+
+let pr_gen_place pr_id = function
+    ConclLocation () -> Pp.mt ()
+  | HypLocation (id,InHyp) -> str "in " ++ pr_id id
+  | HypLocation (id,InHypTypeOnly) ->
+      str "in (Type of " ++ pr_id id ++ str ")"
+  | HypLocation (id,InHypValueOnly) ->
+      str "in (Value of " ++ pr_id id ++ str ")"
+
+let pr_loc_place _ _ _ = pr_gen_place (fun (_,id) -> Nameops.pr_id id)
+let pr_place _ _ _ = pr_gen_place Nameops.pr_id
+let pr_hloc = pr_loc_place () () ()
+
+let intern_place ist = function
+    ConclLocation () -> ConclLocation ()
+  | HypLocation (id,hl) -> HypLocation (Tacintern.intern_hyp ist id,hl)
+
+let interp_place ist env sigma = function
+    ConclLocation () -> ConclLocation ()
+  | HypLocation (id,hl) -> HypLocation (Tacinterp.interp_hyp ist env sigma id,hl)
+
+let interp_place ist gl p =
+  Tacmach.project gl , interp_place ist (Tacmach.pf_env gl) (Tacmach.project gl) p
+
+let subst_place subst pl = pl
+
+ARGUMENT EXTEND hloc
+    PRINTED BY pr_place
+    INTERPRETED BY interp_place
+    GLOBALIZED BY intern_place
+    SUBSTITUTED BY subst_place
+    RAW_PRINTED BY pr_loc_place
+    GLOB_PRINTED BY pr_loc_place
+  [ ] ->
+    [ ConclLocation () ]
+  |  [ "in" "|-" "*" ] ->
+    [ ConclLocation () ]
+| [ "in" ident(id) ] ->
+    [ HypLocation ((Loc.ghost,id),InHyp) ]
+| [ "in" "(" "Type" "of" ident(id) ")" ] ->
+    [ HypLocation ((Loc.ghost,id),InHypTypeOnly) ]
+| [ "in" "(" "Value" "of" ident(id) ")" ] ->
+    [ HypLocation ((Loc.ghost,id),InHypValueOnly) ]
+
+ END
+
+let pr_rename _ _ _ (n, m) = Nameops.pr_id n ++ str " into " ++ Nameops.pr_id m
+
+ARGUMENT EXTEND rename
+  TYPED AS ident * ident
+  PRINTED BY pr_rename
+| [ ident(n) "into" ident(m) ] -> [ (n, m) ]
+END
+
+(* Julien: Mise en commun des differentes version de replace with in by *)
+
+let pr_by_arg_tac _prc _prlc prtac opt_c =
+  match opt_c with
+    | None -> mt ()
+    | Some t -> hov 2 (str "by" ++ spc () ++ prtac (3,Ppextend.E) t)
+
+ARGUMENT EXTEND by_arg_tac
+  TYPED AS tactic_opt
+  PRINTED BY pr_by_arg_tac
+| [ "by" tactic3(c) ] -> [ Some c ]
+| [ ] -> [ None ]
+END
+
+let pr_by_arg_tac prtac opt_c = pr_by_arg_tac () () prtac opt_c
+
+let pr_in_clause _ _ _ cl = Pptactic.pr_in_clause Ppconstr.pr_lident cl
+let pr_in_top_clause _ _ _ cl = Pptactic.pr_in_clause Id.print cl
+let in_clause' = Pltac.in_clause
+
+ARGUMENT EXTEND in_clause
+  TYPED AS clause_dft_concl
+  PRINTED BY pr_in_top_clause
+  RAW_TYPED AS clause_dft_concl
+  RAW_PRINTED BY pr_in_clause
+  GLOB_TYPED AS clause_dft_concl
+  GLOB_PRINTED BY pr_in_clause
+| [ in_clause'(cl) ] -> [ cl ]
+END
+
+(* 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"
+    | Retroknowledge.Int31Constructor -> assert false
+    | Retroknowledge.Int31PlusC -> str "plusc"
+    | Retroknowledge.Int31PlusCarryC -> str "pluscarryc"
+    | Retroknowledge.Int31Minus -> str "minus"
+    | Retroknowledge.Int31MinusC -> str "minusc"
+    | Retroknowledge.Int31MinusCarryC -> str "minuscarryc"
+    | Retroknowledge.Int31TimesC -> str "timesc"
+    | Retroknowledge.Int31Div21 -> str "div21"
+    | Retroknowledge.Int31Div -> str "div"
+    | Retroknowledge.Int31Diveucl -> str "diveucl"
+    | Retroknowledge.Int31AddMulDiv -> str "addmuldiv"
+    | Retroknowledge.Int31Compare -> str "compare"
+    | Retroknowledge.Int31Head0 -> str "head0"
+    | Retroknowledge.Int31Tail0 -> str "tail0"
+    | Retroknowledge.Int31Lor -> str "lor"
+    | Retroknowledge.Int31Land -> str "land"
+    | Retroknowledge.Int31Lxor -> str "lxor"
+
+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) ++
+                                           spc () ++ str "in " ++ qs group
+
+VERNAC ARGUMENT EXTEND retroknowledge_nat
+PRINTED BY pr_r_nat_field
+| [ "nat" "type" ] -> [ Retroknowledge.NatType ]
+| [ "nat" "plus" ] -> [ Retroknowledge.NatPlus ]
+| [ "nat" "times" ] -> [ Retroknowledge.NatTimes ]
+END
+
+
+VERNAC ARGUMENT EXTEND retroknowledge_binary_n
+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
+
+VERNAC ARGUMENT EXTEND retroknowledge_int31
+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" "diveucl" ] -> [ Retroknowledge.Int31Diveucl ]
+| [ "int31" "addmuldiv" ] -> [ Retroknowledge.Int31AddMulDiv ]
+| [ "int31" "compare" ] -> [ Retroknowledge.Int31Compare ]
+| [ "int31" "head0" ] -> [ Retroknowledge.Int31Head0 ]
+| [ "int31" "tail0" ] -> [ Retroknowledge.Int31Tail0 ]
+| [ "int31" "lor" ] -> [ Retroknowledge.Int31Lor ]
+| [ "int31" "land" ] -> [ Retroknowledge.Int31Land ]
+| [ "int31" "lxor" ] -> [ Retroknowledge.Int31Lxor ]
+END
+
+VERNAC ARGUMENT EXTEND retroknowledge_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/plugins/ltac/extraargs.mli b/plugins/ltac/extraargs.mli
new file mode 100644
index 000000000..7d4bccfad
--- /dev/null
+++ b/plugins/ltac/extraargs.mli
@@ -0,0 +1,78 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+open Tacexpr
+open Names
+open Constrexpr
+open Glob_term
+open Misctypes
+
+val wit_orient : bool Genarg.uniform_genarg_type
+val orient : bool Pcoq.Gram.entry
+val pr_orient : bool -> Pp.std_ppcmds
+
+val wit_rename : (Id.t * Id.t) Genarg.uniform_genarg_type
+
+val occurrences : (int list or_var) Pcoq.Gram.entry
+val wit_occurrences : (int list or_var, int list or_var, int list) Genarg.genarg_type
+val pr_occurrences : int list or_var -> Pp.std_ppcmds
+val occurrences_of : int list -> Locus.occurrences
+
+val wit_natural : int Genarg.uniform_genarg_type
+
+val wit_glob :
+  (constr_expr,
+  Tacexpr.glob_constr_and_expr,
+  Tacinterp.interp_sign * glob_constr) Genarg.genarg_type
+
+val wit_lglob :
+  (constr_expr,
+  Tacexpr.glob_constr_and_expr,
+  Tacinterp.interp_sign * glob_constr) Genarg.genarg_type
+
+val wit_lconstr :
+  (constr_expr,
+  Tacexpr.glob_constr_and_expr,
+  EConstr.t) Genarg.genarg_type
+
+val wit_casted_constr :
+  (constr_expr,
+  Tacexpr.glob_constr_and_expr,
+  EConstr.t) Genarg.genarg_type
+
+val glob : constr_expr Pcoq.Gram.entry
+val lglob : constr_expr Pcoq.Gram.entry
+
+type 'id gen_place= ('id * Locus.hyp_location_flag,unit) location
+
+type loc_place = Id.t Loc.located gen_place
+type place = Id.t gen_place
+
+val wit_hloc : (loc_place, loc_place, place) Genarg.genarg_type
+val hloc : loc_place Pcoq.Gram.entry
+val pr_hloc : loc_place -> Pp.std_ppcmds
+
+val by_arg_tac : Tacexpr.raw_tactic_expr option Pcoq.Gram.entry
+val wit_by_arg_tac :
+  (raw_tactic_expr option,
+  glob_tactic_expr option,
+  Geninterp.Val.t option) Genarg.genarg_type
+
+val pr_by_arg_tac : 
+  (int * Ppextend.parenRelation -> raw_tactic_expr -> Pp.std_ppcmds) ->
+  raw_tactic_expr option -> Pp.std_ppcmds
+
+(** Spiwack: Primitive for retroknowledge registration *)
+
+val retroknowledge_field : Retroknowledge.field Pcoq.Gram.entry
+val wit_retroknowledge_field : (Retroknowledge.field, unit, unit) Genarg.genarg_type
+
+val wit_in_clause :
+  (Id.t Loc.located Locus.clause_expr,
+  Id.t Loc.located Locus.clause_expr,
+  Id.t Locus.clause_expr) Genarg.genarg_type
diff --git a/plugins/ltac/extratactics.ml4 b/plugins/ltac/extratactics.ml4
new file mode 100644
index 000000000..55108631b
--- /dev/null
+++ b/plugins/ltac/extratactics.ml4
@@ -0,0 +1,1109 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i camlp4deps: "grammar/grammar.cma" i*)
+
+open Pp
+open Genarg
+open Stdarg
+open Tacarg
+open Extraargs
+open Pcoq.Prim
+open Pltac
+open Mod_subst
+open Names
+open Tacexpr
+open Glob_ops
+open CErrors
+open Util
+open Evd
+open Termops
+open Equality
+open Misctypes
+open Sigma.Notations
+open Proofview.Notations
+
+DECLARE PLUGIN "extratactics"
+
+(**********************************************************************)
+(* replace, discriminate, injection, simplify_eq                      *)
+(* cutrewrite, dependent rewrite                                      *)
+
+let with_delayed_uconstr ist c tac =
+  let flags = {
+    Pretyping.use_typeclasses = false;
+    solve_unification_constraints = true;
+    use_hook = Some Pfedit.solve_by_implicit_tactic;
+    fail_evar = false;
+    expand_evars = true
+  } in
+  let c = Pretyping.type_uconstr ~flags ist c in
+  Tacticals.New.tclDELAYEDWITHHOLES false c tac
+
+let replace_in_clause_maybe_by ist c1 c2 cl tac =
+  with_delayed_uconstr ist c1
+  (fun c1 -> replace_in_clause_maybe_by c1 c2 cl (Option.map (Tacinterp.tactic_of_value ist) tac))
+
+let replace_term ist dir_opt c cl =
+  with_delayed_uconstr ist c (fun c -> replace_term dir_opt c cl)
+
+let clause = Pltac.clause_dft_concl
+
+TACTIC EXTEND replace
+   ["replace" uconstr(c1) "with" constr(c2) clause(cl) by_arg_tac(tac) ]
+-> [ replace_in_clause_maybe_by ist c1 c2 cl tac ]
+END
+
+TACTIC EXTEND replace_term_left
+  [ "replace"  "->" uconstr(c) clause(cl) ]
+  -> [ replace_term ist (Some true) c cl ]
+END
+
+TACTIC EXTEND replace_term_right
+  [ "replace"  "<-" uconstr(c) clause(cl) ]
+  -> [ replace_term ist (Some false) c cl ]
+END
+
+TACTIC EXTEND replace_term
+  [ "replace" uconstr(c) clause(cl) ]
+  -> [ replace_term ist None c cl ]
+END
+
+let induction_arg_of_quantified_hyp = function
+  | AnonHyp n -> None,ElimOnAnonHyp n
+  | NamedHyp id -> None,ElimOnIdent (Loc.ghost,id)
+
+(* Versions *_main must come first!! so that "1" is interpreted as a
+   ElimOnAnonHyp and not as a "constr", and "id" is interpreted as a
+   ElimOnIdent and not as "constr" *)
+
+let mytclWithHoles tac with_evars c =
+  Proofview.Goal.enter { enter = begin fun gl ->
+    let env = Tacmach.New.pf_env gl in
+    let sigma = Tacmach.New.project gl in
+    let sigma',c = Tactics.force_destruction_arg with_evars env sigma c in
+    Tacticals.New.tclWITHHOLES with_evars (tac with_evars (Some c)) sigma'
+  end }
+
+let elimOnConstrWithHoles tac with_evars c =
+  Tacticals.New.tclDELAYEDWITHHOLES with_evars c
+    (fun c -> tac with_evars (Some (None,ElimOnConstr c)))
+
+TACTIC EXTEND simplify_eq
+  [ "simplify_eq" ] -> [ dEq false None ]
+| [ "simplify_eq" destruction_arg(c) ] -> [ mytclWithHoles dEq false c ]
+END
+TACTIC EXTEND esimplify_eq
+| [ "esimplify_eq" ] -> [ dEq true None ]
+| [ "esimplify_eq" destruction_arg(c) ] -> [ mytclWithHoles dEq true c ]
+END
+
+let discr_main c = elimOnConstrWithHoles discr_tac false c
+
+TACTIC EXTEND discriminate
+| [ "discriminate" ] -> [ discr_tac false None ]
+| [ "discriminate" destruction_arg(c) ] ->
+    [ mytclWithHoles discr_tac false c ]
+END
+TACTIC EXTEND ediscriminate
+| [ "ediscriminate" ] -> [ discr_tac true None ]
+| [ "ediscriminate" destruction_arg(c) ] ->
+    [ mytclWithHoles discr_tac true c ]
+END
+
+let discrHyp id =
+  Proofview.tclEVARMAP >>= fun sigma ->
+  discr_main { delayed = fun env sigma -> Sigma.here (EConstr.mkVar id, NoBindings) sigma }
+
+let injection_main with_evars c =
+ elimOnConstrWithHoles (injClause None) with_evars c
+
+TACTIC EXTEND injection
+| [ "injection" ] -> [ injClause None false None ]
+| [ "injection" destruction_arg(c) ] -> [ mytclWithHoles (injClause None) false c ]
+END
+TACTIC EXTEND einjection
+| [ "einjection" ] -> [ injClause None true None ]
+| [ "einjection" destruction_arg(c) ] -> [ mytclWithHoles (injClause None) true c ]
+END
+TACTIC EXTEND injection_as
+| [ "injection" "as" intropattern_list(ipat)] ->
+    [ injClause (Some ipat) false None ]
+| [ "injection" destruction_arg(c) "as" intropattern_list(ipat)] ->
+    [ mytclWithHoles (injClause (Some ipat)) false c ]
+END
+TACTIC EXTEND einjection_as
+| [ "einjection" "as" intropattern_list(ipat)] ->
+    [ injClause (Some ipat) true None ]
+| [ "einjection" destruction_arg(c) "as" intropattern_list(ipat)] ->
+    [ mytclWithHoles (injClause (Some ipat)) true c ]
+END
+TACTIC EXTEND simple_injection
+| [ "simple" "injection" ] -> [ simpleInjClause false None ]
+| [ "simple" "injection" destruction_arg(c) ] -> [ mytclWithHoles simpleInjClause false c ]
+END
+
+let injHyp id =
+  Proofview.tclEVARMAP >>= fun sigma ->
+  injection_main false { delayed = fun env sigma -> Sigma.here (EConstr.mkVar id, NoBindings) sigma }
+
+TACTIC EXTEND dependent_rewrite
+| [ "dependent" "rewrite" orient(b) constr(c) ] -> [ rewriteInConcl b c ]
+| [ "dependent" "rewrite" orient(b) constr(c) "in" hyp(id) ]
+    -> [ rewriteInHyp b c id ]
+END
+
+(** To be deprecated?, "cutrewrite (t=u) as <-" is equivalent to
+    "replace u with t" or "enough (t=u) as <-" and 
+    "cutrewrite (t=u) as ->" is equivalent to "enough (t=u) as ->". *)
+
+TACTIC EXTEND cut_rewrite
+| [ "cutrewrite" orient(b) constr(eqn) ] -> [ cutRewriteInConcl b eqn ]
+| [ "cutrewrite" orient(b) constr(eqn) "in" hyp(id) ]
+    -> [ cutRewriteInHyp b eqn id ]
+END
+
+(**********************************************************************)
+(* Decompose                                                          *)
+
+TACTIC EXTEND decompose_sum
+| [ "decompose" "sum" constr(c) ] -> [ Elim.h_decompose_or c ]
+END
+
+TACTIC EXTEND decompose_record
+| [ "decompose" "record" constr(c) ] -> [ Elim.h_decompose_and c ]
+END
+
+(**********************************************************************)
+(* Contradiction                                                      *)
+
+open Contradiction
+
+TACTIC EXTEND absurd
+ [ "absurd" constr(c) ] -> [ absurd c ]
+END
+
+let onSomeWithHoles tac = function
+  | None -> tac None
+  | Some c -> Tacticals.New.tclDELAYEDWITHHOLES false c (fun c -> tac (Some c))
+
+TACTIC EXTEND contradiction
+ [ "contradiction" constr_with_bindings_opt(c) ] ->
+    [ onSomeWithHoles contradiction c ]
+END
+
+(**********************************************************************)
+(* AutoRewrite                                                        *)
+
+open Autorewrite
+
+let pr_orient _prc _prlc _prt = function
+  | true -> Pp.mt ()
+  | false -> Pp.str " <-"
+
+let pr_orient_string _prc _prlc _prt (orient, s) =
+  pr_orient _prc _prlc _prt orient ++ Pp.spc () ++ Pp.str s
+
+ARGUMENT EXTEND orient_string TYPED AS (bool * string) PRINTED BY pr_orient_string
+| [ orient(r) preident(i) ] -> [ r, i ]
+END
+
+TACTIC EXTEND autorewrite
+| [ "autorewrite" "with" ne_preident_list(l) clause(cl) ] ->
+    [ auto_multi_rewrite  l ( cl) ]
+| [ "autorewrite" "with" ne_preident_list(l) clause(cl) "using" tactic(t) ] ->
+    [
+      auto_multi_rewrite_with (Tacinterp.tactic_of_value ist t) l cl
+    ]
+END
+
+TACTIC EXTEND autorewrite_star
+| [ "autorewrite" "*" "with" ne_preident_list(l) clause(cl) ] ->
+    [ auto_multi_rewrite ~conds:AllMatches l cl ]
+| [ "autorewrite" "*" "with" ne_preident_list(l) clause(cl) "using" tactic(t) ] ->
+  [ auto_multi_rewrite_with ~conds:AllMatches (Tacinterp.tactic_of_value ist t) l cl ]
+END
+
+(**********************************************************************)
+(* Rewrite star                                                       *)
+
+let rewrite_star ist clause orient occs c (tac : Geninterp.Val.t option) =
+  let tac' = Option.map (fun t -> Tacinterp.tactic_of_value ist t, FirstSolved) tac in
+  with_delayed_uconstr ist c
+    (fun c -> general_rewrite_ebindings_clause clause orient occs ?tac:tac' true true (c,NoBindings) true)
+
+TACTIC EXTEND rewrite_star
+| [ "rewrite" "*" orient(o) uconstr(c) "in" hyp(id) "at" occurrences(occ) by_arg_tac(tac) ] ->
+    [ rewrite_star ist (Some id) o (occurrences_of occ) c tac ]
+| [ "rewrite" "*" orient(o) uconstr(c) "at" occurrences(occ) "in" hyp(id) by_arg_tac(tac) ] ->
+    [ rewrite_star ist (Some id) o (occurrences_of occ) c tac ]
+| [ "rewrite" "*" orient(o) uconstr(c) "in" hyp(id) by_arg_tac(tac) ] ->
+    [ rewrite_star ist (Some id) o Locus.AllOccurrences c tac ]
+| [ "rewrite" "*" orient(o) uconstr(c) "at" occurrences(occ) by_arg_tac(tac) ] ->
+    [ rewrite_star ist None o (occurrences_of occ) c tac ]
+| [ "rewrite" "*" orient(o) uconstr(c) by_arg_tac(tac) ] ->
+    [ rewrite_star ist None o Locus.AllOccurrences c tac ]
+    END
+
+(**********************************************************************)
+(* Hint Rewrite                                                       *)
+
+let add_rewrite_hint bases ort t lcsr =
+  let env = Global.env() in
+  let sigma = Evd.from_env env in
+  let poly = Flags.use_polymorphic_flag () in
+  let f ce = 
+    let c, ctx = Constrintern.interp_constr env sigma ce in
+    let ctx =
+      let ctx = UState.context_set ctx in
+        if poly then ctx
+	else (** This is a global universe context that shouldn't be
+	       refreshed at every use of the hint, declare it globally. *)
+	  (Declare.declare_universe_context false ctx;
+           Univ.ContextSet.empty)
+    in
+      Constrexpr_ops.constr_loc ce, (c, ctx), ort, Option.map (in_gen (rawwit wit_ltac)) t in
+  let eqs = List.map f lcsr in
+  let add_hints base = add_rew_rules base eqs in
+  List.iter add_hints bases
+
+let classify_hint _ = Vernacexpr.VtSideff [], Vernacexpr.VtLater
+
+VERNAC COMMAND EXTEND HintRewrite CLASSIFIED BY classify_hint
+  [ "Hint" "Rewrite" orient(o) ne_constr_list(l) ":" preident_list(bl) ] ->
+  [ add_rewrite_hint bl o None l ]
+| [ "Hint" "Rewrite" orient(o) ne_constr_list(l) "using" tactic(t)
+    ":" preident_list(bl) ] ->
+  [ add_rewrite_hint bl o (Some t) l ]
+| [ "Hint" "Rewrite" orient(o) ne_constr_list(l) ] ->
+  [ add_rewrite_hint ["core"] o None l ]
+| [ "Hint" "Rewrite" orient(o) ne_constr_list(l) "using" tactic(t) ] ->
+  [ add_rewrite_hint ["core"] o (Some t) l ]
+END
+
+(**********************************************************************)
+(* Hint Resolve                                                       *)
+
+open Term
+open EConstr
+open Vars
+open Coqlib
+
+let project_hint pri l2r r =
+  let gr = Smartlocate.global_with_alias r in
+  let env = Global.env() in
+  let sigma = Evd.from_env env in
+  let sigma, c = Evd.fresh_global env sigma gr in
+  let c = EConstr.of_constr c in
+  let t = Retyping.get_type_of env sigma c in
+  let t =
+    Tacred.reduce_to_quantified_ref env sigma (Lazy.force coq_iff_ref) t in
+  let sign,ccl = decompose_prod_assum sigma t in
+  let (a,b) = match snd (decompose_app sigma ccl) with
+    | [a;b] -> (a,b)
+    | _ -> assert false in
+  let p =
+    if l2r then build_coq_iff_left_proj () else build_coq_iff_right_proj () in
+  let p = EConstr.of_constr p in
+  let c = Reductionops.whd_beta sigma (mkApp (c, Context.Rel.to_extended_vect mkRel 0 sign)) in
+  let c = it_mkLambda_or_LetIn
+    (mkApp (p,[|mkArrow a (lift 1 b);mkArrow b (lift 1 a);c|])) sign in
+  let id =
+    Nameops.add_suffix (Nametab.basename_of_global gr) ("_proj_" ^ (if l2r then "l2r" else "r2l"))
+  in
+  let ctx = Evd.universe_context_set sigma in
+  let c = EConstr.to_constr sigma c in
+  let c = Declare.declare_definition ~internal:Declare.InternalTacticRequest id (c,ctx) in
+  let info = {Vernacexpr.hint_priority = pri; hint_pattern = None} in
+    (info,false,true,Hints.PathAny, Hints.IsGlobRef (Globnames.ConstRef c))
+
+let add_hints_iff l2r lc n bl =
+  let l = Locality.LocalityFixme.consume () in
+  Hints.add_hints (Locality.make_module_locality l) bl
+    (Hints.HintsResolveEntry (List.map (project_hint n l2r) lc))
+
+VERNAC COMMAND EXTEND HintResolveIffLR CLASSIFIED AS SIDEFF
+  [ "Hint" "Resolve" "->" ne_global_list(lc) natural_opt(n)
+    ":" preident_list(bl) ] ->
+  [ add_hints_iff true lc n bl ]
+| [ "Hint" "Resolve" "->" ne_global_list(lc) natural_opt(n) ] ->
+  [ add_hints_iff true lc n ["core"] ]
+END
+VERNAC COMMAND EXTEND HintResolveIffRL CLASSIFIED AS SIDEFF
+  [ "Hint" "Resolve" "<-" ne_global_list(lc) natural_opt(n)
+    ":" preident_list(bl) ] ->
+  [ add_hints_iff false lc n bl ]
+| [ "Hint" "Resolve" "<-" ne_global_list(lc) natural_opt(n) ] ->
+  [ add_hints_iff false lc n ["core"] ]
+END
+
+(**********************************************************************)
+(* Refine                                                             *)
+
+open EConstr
+open Vars
+
+let constr_flags = {
+  Pretyping.use_typeclasses = true;
+  Pretyping.solve_unification_constraints = true;
+  Pretyping.use_hook = Some Pfedit.solve_by_implicit_tactic;
+  Pretyping.fail_evar = false;
+  Pretyping.expand_evars = true }
+
+let refine_tac ist simple with_classes c =
+  Proofview.Goal.enter { enter = begin fun gl ->
+    let concl = Proofview.Goal.concl gl in
+    let env = Proofview.Goal.env gl in
+    let flags =
+      { constr_flags with Pretyping.use_typeclasses = with_classes } in
+    let expected_type = Pretyping.OfType concl in
+    let c = Pretyping.type_uconstr ~flags ~expected_type ist c in
+    let update = { run = fun sigma ->
+      let Sigma (c, sigma, p) = c.delayed env sigma in
+      Sigma (c, sigma, p)
+    } in
+    let refine = Refine.refine ~unsafe:true update in
+    if simple then refine
+    else refine <*>
+           Tactics.New.reduce_after_refine <*>
+           Proofview.shelve_unifiable
+  end }
+
+TACTIC EXTEND refine
+| [ "refine" uconstr(c) ] ->
+   [ refine_tac ist false true c ]
+END
+
+TACTIC EXTEND simple_refine
+| [ "simple" "refine" uconstr(c) ] ->
+   [ refine_tac ist true true c ]
+END
+
+TACTIC EXTEND notcs_refine
+| [ "notypeclasses" "refine" uconstr(c) ] ->
+   [ refine_tac ist false false c ]
+END
+
+TACTIC EXTEND notcs_simple_refine
+| [ "simple" "notypeclasses" "refine" uconstr(c) ] ->
+   [ refine_tac ist true false c ]
+END
+
+(* Solve unification constraints using heuristics or fail if any remain *)
+TACTIC EXTEND solve_constraints
+[ "solve_constraints" ] -> [ Refine.solve_constraints ]
+END
+
+(**********************************************************************)
+(* Inversion lemmas (Leminv)                                          *)
+
+open Inv
+open Leminv
+
+let seff id = Vernacexpr.VtSideff [id], Vernacexpr.VtLater
+
+VERNAC ARGUMENT EXTEND sort
+| [ "Set" ] -> [ GSet ]
+| [ "Prop" ] -> [ GProp ]
+| [ "Type" ] -> [ GType [] ]
+END
+
+VERNAC COMMAND EXTEND DeriveInversionClear
+| [ "Derive" "Inversion_clear" ident(na) "with" constr(c) "Sort" sort(s) ]
+  => [ seff na ]
+  -> [ add_inversion_lemma_exn na c s false inv_clear_tac ]
+
+| [ "Derive" "Inversion_clear" ident(na) "with" constr(c) ] => [ seff na ]
+  -> [ add_inversion_lemma_exn na c GProp false inv_clear_tac ]
+END
+
+VERNAC COMMAND EXTEND DeriveInversion
+| [ "Derive" "Inversion" ident(na) "with" constr(c) "Sort" sort(s) ]
+  => [ seff na ]
+  -> [ add_inversion_lemma_exn na c s false inv_tac ]
+
+| [ "Derive" "Inversion" ident(na) "with" constr(c) ] => [ seff na ]
+  -> [ add_inversion_lemma_exn na c GProp false inv_tac ]
+END
+
+VERNAC COMMAND EXTEND DeriveDependentInversion
+| [ "Derive" "Dependent" "Inversion" ident(na) "with" constr(c) "Sort" sort(s) ]
+  => [ seff na ]
+  -> [ add_inversion_lemma_exn na c s true dinv_tac ]
+END
+
+VERNAC COMMAND EXTEND DeriveDependentInversionClear
+| [ "Derive" "Dependent" "Inversion_clear" ident(na) "with" constr(c) "Sort" sort(s) ]
+  => [ seff na ]
+  -> [ add_inversion_lemma_exn na c s true dinv_clear_tac ]
+END
+
+(**********************************************************************)
+(* Subst                                                              *)
+
+TACTIC EXTEND subst
+| [ "subst" ne_var_list(l) ] -> [ subst l ]
+| [ "subst" ] -> [ subst_all () ]
+END
+
+let simple_subst_tactic_flags =
+  { only_leibniz = true; rewrite_dependent_proof = false }
+
+TACTIC EXTEND simple_subst
+| [ "simple" "subst" ] -> [ subst_all ~flags:simple_subst_tactic_flags () ]
+END
+
+open Evar_tactics
+
+(**********************************************************************)
+(* Evar creation                                                      *)
+
+(* TODO: add support for some test similar to g_constr.name_colon so that
+   expressions like "evar (list A)" do not raise a syntax error *)
+TACTIC EXTEND evar
+  [ "evar" "(" ident(id) ":" lconstr(typ) ")" ] -> [ let_evar (Name id) typ ]
+| [ "evar" constr(typ) ] -> [ let_evar Anonymous typ ]
+END
+
+TACTIC EXTEND instantiate
+  [ "instantiate" "(" ident(id) ":=" lglob(c) ")" ] ->
+    [ Tacticals.New.tclTHEN (instantiate_tac_by_name id c) Proofview.V82.nf_evar_goals ]
+| [ "instantiate" "(" integer(i) ":=" lglob(c) ")" hloc(hl) ] ->
+    [ Tacticals.New.tclTHEN (instantiate_tac i c hl) Proofview.V82.nf_evar_goals ]
+| [ "instantiate" ] -> [ Proofview.V82.nf_evar_goals ]
+END
+
+(**********************************************************************)
+(** Nijmegen "step" tactic for setoid rewriting                       *)
+
+open Tactics
+open Glob_term
+open Libobject
+open Lib
+
+(* Registered lemmas are expected to be of the form
+     x R y -> y == z -> x R z    (in the right table)
+     x R y -> x == z -> z R y    (in the left table)
+*)
+
+let transitivity_right_table = Summary.ref [] ~name:"transitivity-steps-r"
+let transitivity_left_table = Summary.ref [] ~name:"transitivity-steps-l"
+
+(* [step] tries to apply a rewriting lemma; then apply [tac] intended to
+   complete to proof of the last hypothesis (assumed to state an equality) *)
+
+let step left x tac =
+  let l =
+    List.map (fun lem ->
+      let lem = EConstr.of_constr lem in
+      Tacticals.New.tclTHENLAST
+        (apply_with_bindings (lem, ImplicitBindings [x]))
+        tac)
+      !(if left then transitivity_left_table else transitivity_right_table)
+  in
+  Tacticals.New.tclFIRST l
+
+(* Main function to push lemmas in persistent environment *)
+
+let cache_transitivity_lemma (_,(left,lem)) =
+  if left then
+    transitivity_left_table  := lem :: !transitivity_left_table
+  else
+    transitivity_right_table := lem :: !transitivity_right_table
+
+let subst_transitivity_lemma (subst,(b,ref)) = (b,subst_mps subst ref)
+
+let inTransitivity : bool * Constr.constr -> obj =
+  declare_object {(default_object "TRANSITIVITY-STEPS") with
+    cache_function = cache_transitivity_lemma;
+    open_function = (fun i o -> if Int.equal i 1 then cache_transitivity_lemma o);
+    subst_function = subst_transitivity_lemma;
+    classify_function = (fun o -> Substitute o) }
+
+(* Main entry points *)
+
+let add_transitivity_lemma left lem =
+  let env = Global.env () in
+  let sigma = Evd.from_env env in
+  let lem',ctx (*FIXME*) = Constrintern.interp_constr env sigma lem in
+  add_anonymous_leaf (inTransitivity (left,lem'))
+
+(* Vernacular syntax *)
+
+TACTIC EXTEND stepl
+| ["stepl" constr(c) "by" tactic(tac) ] -> [ step true c (Tacinterp.tactic_of_value ist tac) ]
+| ["stepl" constr(c) ] -> [ step true c (Proofview.tclUNIT ()) ]
+END
+
+TACTIC EXTEND stepr
+| ["stepr" constr(c) "by" tactic(tac) ] -> [ step false c (Tacinterp.tactic_of_value ist tac) ]
+| ["stepr" constr(c) ] -> [ step false c (Proofview.tclUNIT ()) ]
+END
+
+VERNAC COMMAND EXTEND AddStepl CLASSIFIED AS SIDEFF
+| [ "Declare" "Left" "Step" constr(t) ] ->
+    [ add_transitivity_lemma true t ]
+END
+
+VERNAC COMMAND EXTEND AddStepr CLASSIFIED AS SIDEFF
+| [ "Declare" "Right" "Step" constr(t) ] ->
+    [ add_transitivity_lemma false t ]
+END
+
+let cache_implicit_tactic (_,tac) = match tac with
+  | Some tac -> Pfedit.declare_implicit_tactic (Tacinterp.eval_tactic tac)
+  | None -> Pfedit.clear_implicit_tactic ()
+
+let subst_implicit_tactic (subst,tac) =
+  Option.map (Tacsubst.subst_tactic subst) tac
+
+let inImplicitTactic : glob_tactic_expr option -> obj =
+  declare_object {(default_object "IMPLICIT-TACTIC") with
+       open_function = (fun i o -> if Int.equal i 1 then cache_implicit_tactic o);
+       cache_function = cache_implicit_tactic;
+       subst_function = subst_implicit_tactic;
+       classify_function = (fun o -> Dispose)}
+
+let declare_implicit_tactic tac =
+  Lib.add_anonymous_leaf (inImplicitTactic (Some (Tacintern.glob_tactic tac)))
+
+let clear_implicit_tactic () =
+  Lib.add_anonymous_leaf (inImplicitTactic None)
+
+VERNAC COMMAND EXTEND ImplicitTactic CLASSIFIED AS SIDEFF
+| [ "Declare" "Implicit" "Tactic" tactic(tac) ] -> [ declare_implicit_tactic tac ]
+| [ "Clear" "Implicit" "Tactic" ] -> [ clear_implicit_tactic () ]
+END
+
+
+
+
+(**********************************************************************)
+(*spiwack : Vernac commands for retroknowledge                        *)
+
+VERNAC COMMAND EXTEND RetroknowledgeRegister CLASSIFIED AS SIDEFF
+ | [ "Register" constr(c) "as" retroknowledge_field(f) "by" constr(b)] ->
+           [ let tc,ctx = Constrintern.interp_constr (Global.env ()) Evd.empty c in
+             let tb,ctx(*FIXME*) = Constrintern.interp_constr (Global.env ()) Evd.empty b in
+             Global.register f tc tb ]
+END
+
+
+
+(**********************************************************************)
+(* 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 ~generalize_vars:false id ]
+END
+TACTIC EXTEND dep_generalize_eqs
+| ["dependent" "generalize_eqs" hyp(id) ] -> [ abstract_generalize ~generalize_vars:false ~force_dep:true id ]
+END
+TACTIC EXTEND generalize_eqs_vars
+| ["generalize_eqs_vars" hyp(id) ] -> [ abstract_generalize ~generalize_vars:true id ]
+END
+TACTIC EXTEND dep_generalize_eqs_vars
+| ["dependent" "generalize_eqs_vars" hyp(id) ] -> [ abstract_generalize ~force_dep:true ~generalize_vars:true id ]
+END
+
+(** Tactic to automatically simplify hypotheses of the form [Π Δ, x_i = t_i -> T] 
+    where [t_i] is closed w.r.t. Δ. Such hypotheses are automatically generated
+    during dependent induction. For internal use. *)
+
+TACTIC EXTEND specialize_eqs
+[ "specialize_eqs" hyp(id) ] -> [ specialize_eqs id ]
+END
+
+(**********************************************************************)
+(* A tactic that considers a given occurrence of [c] in [t] and       *)
+(* abstract the minimal set of all the occurrences of [c] so that the *)
+(* abstraction [fun x -> t[x/c]] is well-typed                        *)
+(*                                                                    *)
+(* Contributed by Chung-Kil Hur (Winter 2009)                         *)
+(**********************************************************************)
+
+let subst_var_with_hole occ tid t = 
+  let occref = if occ > 0 then ref occ else Find_subterm.error_invalid_occurrence [occ] in
+  let locref = ref 0 in
+  let rec substrec = function
+    | GVar (_,id) as x -> 
+        if Id.equal id tid 
+        then
+	  (decr occref;
+	   if Int.equal !occref 0 then x
+           else
+	     (incr locref;
+	      GHole (Loc.make_loc (!locref,0),
+		     Evar_kinds.QuestionMark(Evar_kinds.Define true),
+                     Misctypes.IntroAnonymous, None)))
+        else x
+    | c -> map_glob_constr_left_to_right substrec c in
+  let t' = substrec t
+  in
+  if !occref > 0 then Find_subterm.error_invalid_occurrence [occ] else t'
+
+let subst_hole_with_term occ tc t =
+  let locref = ref 0 in
+  let occref = ref occ in
+  let rec substrec = function
+    | GHole (_,Evar_kinds.QuestionMark(Evar_kinds.Define true),Misctypes.IntroAnonymous,s) ->
+        decr occref;
+        if Int.equal !occref 0 then tc
+        else
+	  (incr locref;
+	   GHole (Loc.make_loc (!locref,0),
+		  Evar_kinds.QuestionMark(Evar_kinds.Define true),Misctypes.IntroAnonymous,s))
+    | c -> map_glob_constr_left_to_right substrec c
+  in
+  substrec t
+
+open Tacmach
+
+let hResolve id c occ t =
+  Proofview.Goal.s_enter { s_enter = begin fun gl ->
+  let sigma = Proofview.Goal.sigma gl in
+  let sigma = Sigma.to_evar_map sigma in
+  let env = Termops.clear_named_body id (Proofview.Goal.env gl) in
+  let concl = Proofview.Goal.concl gl in
+  let env_ids = Termops.ids_of_context env in
+  let c_raw = Detyping.detype true env_ids env sigma c in
+  let t_raw = Detyping.detype true env_ids env sigma t in
+  let rec resolve_hole t_hole =
+    try 
+      Pretyping.understand env sigma t_hole
+    with
+      | Pretype_errors.PretypeError (_,_,Pretype_errors.UnsolvableImplicit _) as e ->
+          let (e, info) = CErrors.push e in
+          let loc = match Loc.get_loc info with None -> Loc.ghost | Some loc -> loc in
+          resolve_hole (subst_hole_with_term (fst (Loc.unloc loc)) c_raw t_hole)
+  in
+  let t_constr,ctx = resolve_hole (subst_var_with_hole occ id t_raw) in
+  let t_constr = EConstr.of_constr t_constr in
+  let sigma = Evd.merge_universe_context sigma ctx in
+  let t_constr_type = Retyping.get_type_of env sigma t_constr in
+  let tac =
+    (change_concl (mkLetIn (Anonymous,t_constr,t_constr_type,concl)))
+  in
+  Sigma.Unsafe.of_pair (tac, sigma)
+  end }
+
+let hResolve_auto id c t =
+  let rec resolve_auto n = 
+    try
+      hResolve id c n t
+    with
+    | UserError _ as e -> raise e
+    | e when CErrors.noncritical e -> resolve_auto (n+1)
+  in
+  resolve_auto 1
+
+TACTIC EXTEND hresolve_core
+| [ "hresolve_core" "(" ident(id) ":=" constr(c) ")" "at" int_or_var(occ) "in" constr(t) ] -> [ hResolve id c occ t ]
+| [ "hresolve_core" "(" ident(id) ":=" constr(c) ")" "in" constr(t) ] -> [ hResolve_auto id c t ]
+END
+
+(**
+   hget_evar
+*)
+
+TACTIC EXTEND hget_evar
+| [ "hget_evar" int_or_var(n) ] -> [ Evar_tactics.hget_evar n ]
+END
+
+(**********************************************************************)
+
+(**********************************************************************)
+(* A tactic that reduces one match t with ... by doing destruct t.    *)
+(* if t is not a variable, the tactic does                            *)
+(* case_eq t;intros ... heq;rewrite heq in *|-. (but heq itself is    *)
+(* preserved).                                                        *)
+(* Contributed by Julien Forest and Pierre Courtieu (july 2010)       *)
+(**********************************************************************)
+
+exception Found of unit Proofview.tactic
+
+let rewrite_except h =
+  Proofview.Goal.enter { enter = begin fun gl ->
+  let hyps = Tacmach.New.pf_ids_of_hyps gl in
+  Tacticals.New.tclMAP (fun id -> if Id.equal id h then Proofview.tclUNIT () else 
+      Tacticals.New.tclTRY (Equality.general_rewrite_in true Locus.AllOccurrences true true id (mkVar h) false))
+    hyps
+  end }
+
+
+let refl_equal = 
+  let coq_base_constant s =
+    Coqlib.gen_constant_in_modules "RecursiveDefinition"
+      (Coqlib.init_modules @ [["Coq";"Arith";"Le"];["Coq";"Arith";"Lt"]]) s in
+  function () -> (coq_base_constant "eq_refl")
+
+
+(* This is simply an implementation of the case_eq tactic.  this code
+  should be replaced by a call to the tactic but I don't know how to
+  call it before it is defined. *)
+let  mkCaseEq a  : unit Proofview.tactic =
+  Proofview.Goal.enter { enter = begin fun gl ->
+    let type_of_a = Tacmach.New.pf_unsafe_type_of gl a in
+       Tacticals.New.tclTHENLIST
+         [Tactics.generalize [(mkApp(EConstr.of_constr (delayed_force refl_equal), [| type_of_a; a|]))];
+          Proofview.Goal.enter { enter = begin fun gl ->
+            let concl = Proofview.Goal.concl gl in
+            let env = Proofview.Goal.env gl in
+            (** FIXME: this looks really wrong. Does anybody really use this tactic? *)
+            let Sigma (c, _, _) = (Tacred.pattern_occs [Locus.OnlyOccurrences [1], a]).Reductionops.e_redfun env (Sigma.Unsafe.of_evar_map Evd.empty) concl in
+	    change_concl c
+          end };
+	  simplest_case a]
+  end }
+
+
+let case_eq_intros_rewrite x =
+  Proofview.Goal.enter { enter = begin fun gl ->
+  let n = nb_prod (Tacmach.New.project gl) (Proofview.Goal.concl gl) in
+  (* Pp.msgnl (Printer.pr_lconstr x); *)
+  Tacticals.New.tclTHENLIST [
+      mkCaseEq x;
+    Proofview.Goal.enter { enter = begin fun gl ->
+      let concl = Proofview.Goal.concl gl in
+      let hyps = Tacmach.New.pf_ids_of_hyps gl in
+      let n' = nb_prod (Tacmach.New.project gl) concl in
+      let h = fresh_id_in_env hyps (Id.of_string "heq") (Proofview.Goal.env gl)  in
+      Tacticals.New.tclTHENLIST [
+                    Tacticals.New.tclDO (n'-n-1) intro;
+		    introduction h;
+		    rewrite_except h]
+    end }
+  ]
+  end }
+
+let rec find_a_destructable_match sigma t =
+  let cl = induction_arg_of_quantified_hyp (NamedHyp (Id.of_string "x")) in
+  let cl = [cl, (None, None), None], None in
+  let dest = TacAtom (Loc.ghost, TacInductionDestruct(false, false, cl)) in
+  match EConstr.kind sigma t with
+    | Case (_,_,x,_) when closed0 sigma x ->
+	if isVar sigma x then
+	  (* TODO check there is no rel n. *)
+	  raise (Found (Tacinterp.eval_tactic dest))
+	else
+	  (* let _ = Pp.msgnl (Printer.pr_lconstr x)  in *)
+	  raise (Found (case_eq_intros_rewrite x))
+    | _ -> EConstr.iter sigma (fun c -> find_a_destructable_match sigma c) t
+	
+
+let destauto t =
+  Proofview.tclEVARMAP >>= fun sigma ->
+  try find_a_destructable_match sigma t;
+    Tacticals.New.tclZEROMSG (str "No destructable match found")
+  with Found tac -> tac
+
+let destauto_in id = 
+  Proofview.Goal.enter { enter = begin fun gl ->
+  let ctype = Tacmach.New.pf_unsafe_type_of gl (mkVar id) in
+(*  Pp.msgnl (Printer.pr_lconstr (mkVar id)); *)
+(*  Pp.msgnl (Printer.pr_lconstr (ctype)); *)
+  destauto ctype
+  end }
+
+TACTIC EXTEND destauto
+| [ "destauto" ] -> [ Proofview.Goal.enter { enter = begin fun gl -> destauto (Proofview.Goal.concl gl) end } ]
+| [ "destauto" "in" hyp(id) ] -> [ destauto_in id ]
+END
+
+
+(* ********************************************************************* *)
+
+let eq_constr x y = 
+  Proofview.Goal.enter { enter = begin fun gl ->
+    let evd = Tacmach.New.project gl in
+      match EConstr.eq_constr_universes evd x y with
+      | Some _ -> Proofview.tclUNIT () 
+      | None -> Tacticals.New.tclFAIL 0 (str "Not equal")
+  end }
+
+TACTIC EXTEND constr_eq
+| [ "constr_eq" constr(x) constr(y) ] -> [ eq_constr x y ]
+END
+
+TACTIC EXTEND constr_eq_nounivs
+| [ "constr_eq_nounivs" constr(x) constr(y) ] -> [
+    Proofview.tclEVARMAP >>= fun sigma ->
+    if eq_constr_nounivs sigma x y then Proofview.tclUNIT () else Tacticals.New.tclFAIL 0 (str "Not equal") ]
+END
+
+TACTIC EXTEND is_evar
+| [ "is_evar" constr(x) ] -> [
+    Proofview.tclEVARMAP >>= fun sigma ->
+    match EConstr.kind sigma x with
+      | Evar _ -> Proofview.tclUNIT ()
+      | _ -> Tacticals.New.tclFAIL 0 (str "Not an evar")
+    ]
+END
+
+let has_evar sigma c =
+let rec has_evar x =
+  match EConstr.kind sigma x with
+    | Evar _ -> true
+    | Rel _ | Var _ | Meta _ | Sort _ | Const _ | Ind _ | Construct _ ->
+      false
+    | Cast (t1, _, t2) | Prod (_, t1, t2) | Lambda (_, t1, t2) ->
+      has_evar t1 || has_evar t2
+    | LetIn (_, t1, t2, t3) ->
+      has_evar t1 || has_evar t2 || has_evar t3
+    | App (t1, ts) ->
+      has_evar t1 || has_evar_array ts
+    | Case (_, t1, t2, ts) ->
+      has_evar t1 || has_evar t2 || has_evar_array ts
+    | Fix ((_, tr)) | CoFix ((_, tr)) ->
+      has_evar_prec tr
+    | Proj (p, c) -> has_evar c
+and has_evar_array x =
+  Array.exists has_evar x
+and has_evar_prec (_, ts1, ts2) =
+  Array.exists has_evar ts1 || Array.exists has_evar ts2
+in
+has_evar c
+
+TACTIC EXTEND has_evar
+| [ "has_evar" constr(x) ] -> [
+  Proofview.tclEVARMAP >>= fun sigma ->
+  if has_evar sigma x then Proofview.tclUNIT () else Tacticals.New.tclFAIL 0 (str "No evars")
+]
+END
+
+TACTIC EXTEND is_hyp
+| [ "is_var" constr(x) ] -> [
+  Proofview.tclEVARMAP >>= fun sigma ->
+  match EConstr.kind sigma x with
+    | Var _ ->  Proofview.tclUNIT ()
+    | _ -> Tacticals.New.tclFAIL 0 (str "Not a variable or hypothesis") ]
+END
+
+TACTIC EXTEND is_fix
+| [ "is_fix" constr(x) ] -> [
+  Proofview.tclEVARMAP >>= fun sigma ->
+  match EConstr.kind sigma x with
+    | Fix _ -> Proofview.tclUNIT ()
+    | _ -> Tacticals.New.tclFAIL 0 (Pp.str "not a fix definition") ]
+END;;
+
+TACTIC EXTEND is_cofix
+| [ "is_cofix" constr(x) ] -> [
+  Proofview.tclEVARMAP >>= fun sigma ->
+  match EConstr.kind sigma x with
+    | CoFix _ -> Proofview.tclUNIT ()
+    | _ -> Tacticals.New.tclFAIL 0 (Pp.str "not a cofix definition") ]
+END;;
+
+TACTIC EXTEND is_ind
+| [ "is_ind" constr(x) ] -> [
+  Proofview.tclEVARMAP >>= fun sigma ->
+  match EConstr.kind sigma x with
+    | Ind _ -> Proofview.tclUNIT ()
+    | _ -> Tacticals.New.tclFAIL 0 (Pp.str "not an (co)inductive datatype") ]
+END;;
+
+TACTIC EXTEND is_constructor
+| [ "is_constructor" constr(x) ] -> [
+  Proofview.tclEVARMAP >>= fun sigma ->
+  match EConstr.kind sigma x with
+    | Construct _ -> Proofview.tclUNIT ()
+    | _ -> Tacticals.New.tclFAIL 0 (Pp.str "not a constructor") ]
+END;;
+
+TACTIC EXTEND is_proj
+| [ "is_proj" constr(x) ] -> [
+  Proofview.tclEVARMAP >>= fun sigma ->
+  match EConstr.kind sigma x with
+    | Proj _ -> Proofview.tclUNIT ()
+    | _ -> Tacticals.New.tclFAIL 0 (Pp.str "not a primitive projection") ]
+END;;
+
+TACTIC EXTEND is_const
+| [ "is_const" constr(x) ] -> [
+  Proofview.tclEVARMAP >>= fun sigma ->
+  match EConstr.kind sigma x with
+    | Const _ -> Proofview.tclUNIT ()
+    | _ -> Tacticals.New.tclFAIL 0 (Pp.str "not a constant") ]
+END;;
+
+(* Command to grab the evars left unresolved at the end of a proof. *)
+(* spiwack: I put it in extratactics because it is somewhat tied with
+   the semantics of the LCF-style tactics, hence with the classic tactic
+   mode. *)
+VERNAC COMMAND EXTEND GrabEvars
+[ "Grab" "Existential" "Variables" ]
+  => [ Vernac_classifier.classify_as_proofstep ]
+  -> [ Proof_global.simple_with_current_proof (fun _ p  -> Proof.V82.grab_evars p) ]
+END
+
+(* Shelves all the goals under focus. *)
+TACTIC EXTEND shelve
+| [ "shelve" ] ->
+    [ Proofview.shelve ]
+END
+
+(* Shelves the unifiable goals under focus, i.e. the goals which
+   appear in other goals under focus (the unfocused goals are not
+   considered). *)
+TACTIC EXTEND shelve_unifiable
+| [ "shelve_unifiable" ] ->
+    [ Proofview.shelve_unifiable ]
+END
+
+(* Unshelves the goal shelved by the tactic. *)
+TACTIC EXTEND unshelve
+| [ "unshelve" tactic1(t) ] ->
+    [
+      Proofview.with_shelf (Tacinterp.tactic_of_value ist t) >>= fun (gls, ()) ->
+      Proofview.Unsafe.tclGETGOALS >>= fun ogls ->
+      Proofview.Unsafe.tclSETGOALS (gls @ ogls)
+    ]
+END
+
+(* Command to add every unshelved variables to the focus *)
+VERNAC COMMAND EXTEND Unshelve
+[ "Unshelve" ]
+  => [ Vernac_classifier.classify_as_proofstep ]
+  -> [ Proof_global.simple_with_current_proof (fun _ p  -> Proof.unshelve p) ]
+END
+
+(* Gives up on the goals under focus: the goals are considered solved,
+   but the proof cannot be closed until the user goes back and solve
+   these goals. *)
+TACTIC EXTEND give_up
+| [ "give_up" ] ->
+    [ Proofview.give_up ]
+END
+
+(* cycles [n] goals *)
+TACTIC EXTEND cycle
+| [ "cycle" int_or_var(n) ] -> [ Proofview.cycle n ]
+END
+
+(* swaps goals number [i] and [j] *)
+TACTIC EXTEND swap
+| [ "swap" int_or_var(i) int_or_var(j) ] -> [ Proofview.swap i j ]
+END
+
+(* reverses the list of focused goals *)
+TACTIC EXTEND revgoals
+| [ "revgoals" ] -> [ Proofview.revgoals ]
+END
+
+type cmp =
+  | Eq
+  | Lt | Le
+  | Gt | Ge
+
+type 'i test =
+  | Test of cmp * 'i * 'i
+
+let pr_cmp = function
+  | Eq -> Pp.str"="
+  | Lt -> Pp.str"<"
+  | Le -> Pp.str"<="
+  | Gt -> Pp.str">"
+  | Ge -> Pp.str">="
+
+let pr_cmp' _prc _prlc _prt = pr_cmp
+
+let pr_test_gen f (Test(c,x,y)) =
+  Pp.(f x ++ pr_cmp c ++ f y)
+
+let pr_test = pr_test_gen (Pputils.pr_or_var Pp.int)
+
+let pr_test' _prc _prlc _prt = pr_test
+
+let pr_itest = pr_test_gen Pp.int
+
+let pr_itest' _prc _prlc _prt = pr_itest
+
+
+
+ARGUMENT EXTEND comparison PRINTED BY pr_cmp'
+| [ "="  ] -> [ Eq ]
+| [ "<"  ] -> [ Lt ]
+| [ "<=" ] -> [ Le ]
+| [ ">"  ] -> [ Gt ]
+| [ ">=" ] -> [ Ge ]
+    END
+
+let interp_test ist gls = function
+  | Test (c,x,y) ->
+      project gls ,
+      Test(c,Tacinterp.interp_int_or_var ist x,Tacinterp.interp_int_or_var ist y)
+
+ARGUMENT EXTEND test
+  PRINTED BY pr_itest'
+  INTERPRETED BY interp_test
+  RAW_PRINTED BY pr_test'
+  GLOB_PRINTED BY pr_test'
+| [ int_or_var(x) comparison(c) int_or_var(y) ] -> [ Test(c,x,y) ]
+END
+
+let interp_cmp = function
+  | Eq -> Int.equal
+  | Lt -> ((<):int->int->bool)
+  | Le -> ((<=):int->int->bool)
+  | Gt -> ((>):int->int->bool)
+  | Ge -> ((>=):int->int->bool)
+
+let run_test = function
+  | Test(c,x,y) -> interp_cmp c x y
+
+let guard tst =
+  if run_test tst then
+    Proofview.tclUNIT ()
+  else
+    let msg = Pp.(str"Condition not satisfied:"++ws 1++(pr_itest tst)) in
+    Tacticals.New.tclZEROMSG msg
+
+
+TACTIC EXTEND guard
+| [ "guard" test(tst) ] -> [ guard tst ]
+END
+
+let decompose l c =
+  Proofview.Goal.enter { enter = begin fun gl ->
+    let sigma = Tacmach.New.project gl in
+    let to_ind c =
+      if isInd sigma c then Univ.out_punivs (destInd sigma c)
+      else error "not an inductive type"
+    in
+    let l = List.map to_ind l in
+    Elim.h_decompose l c
+  end }
+
+TACTIC EXTEND decompose
+| [ "decompose" "[" ne_constr_list(l) "]" constr(c) ] -> [ decompose l c ]
+END
+
+(** library/keys *)
+
+VERNAC COMMAND EXTEND Declare_keys CLASSIFIED AS SIDEFF
+| [ "Declare" "Equivalent" "Keys" constr(c) constr(c') ] -> [ 
+  let it c = EConstr.Unsafe.to_constr (snd (Constrintern.interp_open_constr (Global.env ()) Evd.empty c)) in 
+  let k1 = Keys.constr_key (it c) in
+  let k2 = Keys.constr_key (it c') in
+    match k1, k2 with
+    | Some k1, Some k2 -> Keys.declare_equiv_keys k1 k2
+    | _ -> () ]
+END
+
+VERNAC COMMAND EXTEND Print_keys CLASSIFIED AS QUERY
+| [ "Print" "Equivalent" "Keys" ] -> [ Feedback.msg_info (Keys.pr_keys Printer.pr_global) ]
+END
+
+
+VERNAC COMMAND EXTEND OptimizeProof
+| [ "Optimize" "Proof" ] => [ Vernac_classifier.classify_as_proofstep ] ->
+  [ Proof_global.compact_the_proof () ]
+| [ "Optimize" "Heap" ] => [ Vernac_classifier.classify_as_proofstep ] ->
+  [ Gc.compact () ]
+END
diff --git a/plugins/ltac/extratactics.mli b/plugins/ltac/extratactics.mli
new file mode 100644
index 000000000..18334dafe
--- /dev/null
+++ b/plugins/ltac/extratactics.mli
@@ -0,0 +1,14 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+val discrHyp : Names.Id.t -> unit Proofview.tactic
+val injHyp : Names.Id.t -> unit Proofview.tactic
+
+(* val refine_tac : Evd.open_constr -> unit Proofview.tactic *)
+
+val onSomeWithHoles : ('a option -> unit Proofview.tactic) -> 'a Tacexpr.delayed_open option -> unit Proofview.tactic
diff --git a/plugins/ltac/g_auto.ml4 b/plugins/ltac/g_auto.ml4
new file mode 100644
index 000000000..e9a6e9e04
--- /dev/null
+++ b/plugins/ltac/g_auto.ml4
@@ -0,0 +1,225 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i camlp4deps: "grammar/grammar.cma" i*)
+
+open Pp
+open Genarg
+open Stdarg
+open Pcoq.Prim
+open Pcoq.Constr
+open Pltac
+open Hints
+open Tacexpr
+open Proofview.Notations
+open Names
+
+DECLARE PLUGIN "g_auto"
+
+(* Hint bases *)
+
+
+TACTIC EXTEND eassumption
+| [ "eassumption" ] -> [ Eauto.e_assumption ]
+END
+
+TACTIC EXTEND eexact
+| [ "eexact" constr(c) ] -> [ Eauto.e_give_exact c ]
+END
+
+let pr_hintbases _prc _prlc _prt = Pptactic.pr_hintbases
+
+ARGUMENT EXTEND hintbases
+  TYPED AS preident_list_opt
+  PRINTED BY pr_hintbases
+| [ "with" "*" ] -> [ None ]
+| [ "with" ne_preident_list(l) ] -> [ Some l ]
+| [ ] -> [ Some [] ]
+END
+
+let eval_uconstrs ist cs =
+  let flags = {
+    Pretyping.use_typeclasses = false;
+    solve_unification_constraints = true;
+    use_hook = Some Pfedit.solve_by_implicit_tactic;
+    fail_evar = false;
+    expand_evars = true
+  } in
+  let map c = { delayed = fun env sigma ->
+    let Sigma.Sigma (c, sigma, p) = c.delayed env sigma in
+    Sigma.Sigma (c, sigma, p)
+  } in
+  List.map (fun c -> map (Pretyping.type_uconstr ~flags ist c)) cs
+
+let pr_auto_using_raw _ _ _  = Pptactic.pr_auto_using Ppconstr.pr_constr_expr
+let pr_auto_using_glob _ _ _ = Pptactic.pr_auto_using (fun (c,_) -> Printer.pr_glob_constr c)
+let pr_auto_using _ _ _ = Pptactic.pr_auto_using Printer.pr_closed_glob
+
+ARGUMENT EXTEND auto_using
+  TYPED AS uconstr_list
+  PRINTED BY pr_auto_using
+  RAW_TYPED AS uconstr_list
+  RAW_PRINTED BY pr_auto_using_raw
+  GLOB_TYPED AS uconstr_list
+  GLOB_PRINTED BY pr_auto_using_glob
+| [ "using" ne_uconstr_list_sep(l, ",") ] -> [ l ]
+| [ ] -> [ [] ]
+END
+
+(** Auto *)
+
+TACTIC EXTEND trivial
+| [ "trivial" auto_using(lems) hintbases(db) ] ->
+    [ Auto.h_trivial (eval_uconstrs ist lems) db ]
+END
+
+TACTIC EXTEND info_trivial
+| [ "info_trivial" auto_using(lems) hintbases(db) ] ->
+    [ Auto.h_trivial ~debug:Info (eval_uconstrs ist lems) db ]
+END
+
+TACTIC EXTEND debug_trivial
+| [ "debug" "trivial" auto_using(lems) hintbases(db) ] ->
+    [ Auto.h_trivial ~debug:Debug (eval_uconstrs ist lems) db ]
+END
+
+TACTIC EXTEND auto
+| [ "auto" int_or_var_opt(n) auto_using(lems) hintbases(db) ] ->
+    [ Auto.h_auto n (eval_uconstrs ist lems) db ]
+END
+
+TACTIC EXTEND info_auto
+| [ "info_auto" int_or_var_opt(n) auto_using(lems) hintbases(db) ] ->
+    [ Auto.h_auto ~debug:Info n (eval_uconstrs ist lems) db ]
+END
+
+TACTIC EXTEND debug_auto
+| [ "debug" "auto" int_or_var_opt(n) auto_using(lems) hintbases(db) ] ->
+    [ Auto.h_auto ~debug:Debug n (eval_uconstrs ist lems) db ]
+END
+
+(** Eauto *)
+
+TACTIC EXTEND prolog
+| [ "prolog" "[" uconstr_list(l) "]" int_or_var(n) ] ->
+    [ Eauto.prolog_tac (eval_uconstrs ist l) n ]
+END
+
+let make_depth n = snd (Eauto.make_dimension n None)
+
+TACTIC EXTEND eauto
+| [ "eauto" int_or_var_opt(n) int_or_var_opt(p) auto_using(lems)
+    hintbases(db) ] ->
+    [ Eauto.gen_eauto (Eauto.make_dimension n p) (eval_uconstrs ist lems) db ]
+END
+
+TACTIC EXTEND new_eauto
+| [ "new" "auto" int_or_var_opt(n) auto_using(lems)
+    hintbases(db) ] ->
+    [ match db with
+      | None -> Auto.new_full_auto (make_depth n) (eval_uconstrs ist lems)
+      | Some l -> Auto.new_auto (make_depth n) (eval_uconstrs ist lems) l ]
+END
+
+TACTIC EXTEND debug_eauto
+| [ "debug" "eauto" int_or_var_opt(n) int_or_var_opt(p) auto_using(lems)
+    hintbases(db) ] ->
+    [ Eauto.gen_eauto ~debug:Debug (Eauto.make_dimension n p) (eval_uconstrs ist lems) db ]
+END
+
+TACTIC EXTEND info_eauto
+| [ "info_eauto" int_or_var_opt(n) int_or_var_opt(p) auto_using(lems)
+    hintbases(db) ] ->
+    [ Eauto.gen_eauto ~debug:Info (Eauto.make_dimension n p) (eval_uconstrs ist lems) db ]
+END
+
+TACTIC EXTEND dfs_eauto
+| [ "dfs" "eauto" int_or_var_opt(p) auto_using(lems)
+      hintbases(db) ] ->
+    [ Eauto.gen_eauto (Eauto.make_dimension p None) (eval_uconstrs ist lems) db ]
+END
+
+TACTIC EXTEND autounfold
+| [ "autounfold" hintbases(db) clause_dft_concl(cl) ] -> [ Eauto.autounfold_tac db cl ]
+END
+
+TACTIC EXTEND autounfold_one
+| [ "autounfold_one" hintbases(db) "in" hyp(id) ] ->
+    [ Eauto.autounfold_one (match db with None -> ["core"] | Some x -> "core"::x) (Some (id, Locus.InHyp)) ]
+| [ "autounfold_one" hintbases(db) ] ->
+    [ Eauto.autounfold_one (match db with None -> ["core"] | Some x -> "core"::x) None ]
+      END
+
+TACTIC EXTEND unify
+| ["unify" constr(x) constr(y) ] -> [ Tactics.unify x y ]
+| ["unify" constr(x) constr(y) "with" preident(base)  ] -> [
+    let table = try Some (Hints.searchtable_map base) with Not_found -> None in
+    match table with
+    | None ->
+      let msg = str "Hint table " ++ str base ++ str " not found" in
+      Tacticals.New.tclZEROMSG msg
+    | Some t ->
+      let state = Hints.Hint_db.transparent_state t in
+      Tactics.unify ~state x y
+  ]
+END
+
+
+TACTIC EXTEND convert_concl_no_check
+| ["convert_concl_no_check" constr(x) ] -> [ Tactics.convert_concl_no_check x Term.DEFAULTcast ]
+END
+
+let pr_pre_hints_path_atom _ _ _ = Hints.pp_hints_path_atom Libnames.pr_reference
+let pr_hints_path_atom _ _ _ = Hints.pp_hints_path_atom Printer.pr_global
+let glob_hints_path_atom ist = Hints.glob_hints_path_atom
+
+ARGUMENT EXTEND hints_path_atom
+  PRINTED BY pr_hints_path_atom
+
+  GLOBALIZED BY glob_hints_path_atom
+
+  RAW_PRINTED BY pr_pre_hints_path_atom
+  GLOB_PRINTED BY pr_hints_path_atom
+| [ ne_global_list(g) ] -> [ Hints.PathHints g ]
+| [ "_" ] -> [ Hints.PathAny ]
+END
+
+let pr_hints_path prc prx pry c = Hints.pp_hints_path c
+let pr_pre_hints_path prc prx pry c = Hints.pp_hints_path_gen Libnames.pr_reference c
+let glob_hints_path ist = Hints.glob_hints_path
+							      
+ARGUMENT EXTEND hints_path
+PRINTED BY pr_hints_path
+
+GLOBALIZED BY glob_hints_path
+RAW_PRINTED BY pr_pre_hints_path
+GLOB_PRINTED BY pr_hints_path
+
+| [ "(" hints_path(p) ")"  ] -> [ p ]
+| [ hints_path(p) "*" ] -> [ Hints.PathStar p ]
+| [ "emp" ] -> [ Hints.PathEmpty ]
+| [ "eps" ] -> [ Hints.PathEpsilon ]
+| [ hints_path(p) "|" hints_path(q) ] -> [ Hints.PathOr (p, q) ]
+| [ hints_path_atom(a) ] -> [ Hints.PathAtom a ]
+| [ hints_path(p) hints_path(q) ] -> [ Hints.PathSeq (p, q) ]
+END
+
+ARGUMENT EXTEND opthints
+  TYPED AS preident_list_opt
+  PRINTED BY pr_hintbases
+| [ ":" ne_preident_list(l) ] -> [ Some l ]
+| [ ] -> [ None ]
+END
+
+VERNAC COMMAND EXTEND HintCut CLASSIFIED AS SIDEFF
+| [ "Hint" "Cut" "[" hints_path(p) "]" opthints(dbnames) ] -> [
+  let entry = Hints.HintsCutEntry (Hints.glob_hints_path p) in
+    Hints.add_hints (Locality.make_section_locality (Locality.LocalityFixme.consume ()))
+      (match dbnames with None -> ["core"] | Some l -> l) entry ]
+END
+
diff --git a/plugins/ltac/g_class.ml4 b/plugins/ltac/g_class.ml4
new file mode 100644
index 000000000..40f30c794
--- /dev/null
+++ b/plugins/ltac/g_class.ml4
@@ -0,0 +1,123 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i camlp4deps: "grammar/grammar.cma" i*)
+
+open Misctypes
+open Class_tactics
+open Pltac
+open Stdarg
+open Tacarg
+open Names
+
+DECLARE PLUGIN "g_class"
+
+(** Options: depth, debug and transparency settings. *)
+
+let set_transparency cl b =
+  List.iter (fun r ->
+    let gr = Smartlocate.global_with_alias r in
+    let ev = Tacred.evaluable_of_global_reference (Global.env ()) gr in
+      Classes.set_typeclass_transparency ev false b) cl
+
+VERNAC COMMAND EXTEND Typeclasses_Unfold_Settings CLASSIFIED AS SIDEFF
+| [ "Typeclasses" "Transparent" reference_list(cl) ] -> [
+    set_transparency cl true ]
+END
+
+VERNAC COMMAND EXTEND Typeclasses_Rigid_Settings CLASSIFIED AS SIDEFF
+| [ "Typeclasses" "Opaque" reference_list(cl) ] -> [
+    set_transparency cl false ]
+END
+
+open Genarg
+
+let pr_debug _prc _prlc _prt b =
+  if b then Pp.str "debug" else Pp.mt()
+
+ARGUMENT EXTEND debug TYPED AS bool PRINTED BY pr_debug
+| [ "debug" ] -> [ true ]
+| [ ] -> [ false ]
+END
+
+let pr_search_strategy _prc _prlc _prt = function
+  | Some Dfs -> Pp.str "dfs"
+  | Some Bfs -> Pp.str "bfs"
+  | None -> Pp.mt ()
+
+ARGUMENT EXTEND eauto_search_strategy PRINTED BY pr_search_strategy
+| [ "(bfs)" ] -> [ Some Bfs ]
+| [ "(dfs)" ] -> [ Some Dfs ]
+| [ ] -> [ None ] 
+END
+
+(* true = All transparent, false = Opaque if possible *)
+
+VERNAC COMMAND EXTEND Typeclasses_Settings CLASSIFIED AS SIDEFF
+ | [ "Typeclasses" "eauto" ":=" debug(d) eauto_search_strategy(s) int_opt(depth) ] -> [
+     set_typeclasses_debug d;
+     Option.iter set_typeclasses_strategy s;
+     set_typeclasses_depth depth
+   ]
+END
+
+(** Compatibility: typeclasses eauto has 8.5 and 8.6 modes *)
+TACTIC EXTEND typeclasses_eauto
+ | [ "typeclasses" "eauto" "bfs" int_or_var_opt(d) "with" ne_preident_list(l) ] ->
+    [ typeclasses_eauto ~strategy:Bfs ~depth:d l ]
+ | [ "typeclasses" "eauto" int_or_var_opt(d) "with" ne_preident_list(l) ] ->
+    [ typeclasses_eauto ~depth:d l ]
+ | [ "typeclasses" "eauto" int_or_var_opt(d) ] -> [
+     typeclasses_eauto ~only_classes:true ~depth:d [Hints.typeclasses_db] ]
+END
+
+TACTIC EXTEND head_of_constr
+  [ "head_of_constr" ident(h) constr(c) ] -> [ head_of_constr h c ]
+END
+
+TACTIC EXTEND not_evar
+  [ "not_evar" constr(ty) ] -> [ not_evar ty ]
+END
+
+TACTIC EXTEND is_ground
+  [ "is_ground" constr(ty) ] -> [ Proofview.V82.tactic (is_ground ty) ]
+END
+
+TACTIC EXTEND autoapply
+  [ "autoapply" constr(c) "using" preident(i) ] -> [ autoapply c i ]
+END
+
+(** TODO: DEPRECATE *)
+(* A progress test that allows to see if the evars have changed *)
+open Term
+open Proofview.Goal
+open Proofview.Notations
+
+let rec eq_constr_mod_evars sigma x y =
+  let open EConstr in
+  match EConstr.kind sigma x, EConstr.kind sigma y with
+  | Evar (e1, l1), Evar (e2, l2) when not (Evar.equal e1 e2) -> true
+  | _, _ -> compare_constr sigma (fun x y -> eq_constr_mod_evars sigma x y) x y
+
+let progress_evars t =
+  Proofview.Goal.enter { enter = begin fun gl ->
+    let concl = Proofview.Goal.concl gl in
+    let check =
+      Proofview.Goal.enter { enter = begin fun gl' ->
+        let sigma = Tacmach.New.project gl' in
+        let newconcl = Proofview.Goal.concl gl' in
+        if eq_constr_mod_evars sigma concl newconcl
+        then Tacticals.New.tclFAIL 0 (Pp.str"No progress made (modulo evars)")
+        else Proofview.tclUNIT ()
+      end }
+    in t <*> check
+  end }
+
+TACTIC EXTEND progress_evars
+  [ "progress_evars" tactic(t) ] -> [ progress_evars (Tacinterp.tactic_of_value ist t) ]
+END
diff --git a/plugins/ltac/g_eqdecide.ml4 b/plugins/ltac/g_eqdecide.ml4
new file mode 100644
index 000000000..679aa1127
--- /dev/null
+++ b/plugins/ltac/g_eqdecide.ml4
@@ -0,0 +1,28 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(************************************************************************)
+(*                              EqDecide                               *)
+(*   A tactic for deciding propositional equality on inductive types   *)
+(*                           by Eduardo Gimenez                        *)
+(************************************************************************)
+
+(*i camlp4deps: "grammar/grammar.cma" i*)
+
+open Eqdecide
+open Names
+
+DECLARE PLUGIN "g_eqdecide"
+
+TACTIC EXTEND decide_equality
+| [ "decide" "equality" ] -> [ decideEqualityGoal ]
+END
+
+TACTIC EXTEND compare
+| [ "compare" constr(c1) constr(c2) ] -> [ compare c1 c2 ]
+END
diff --git a/plugins/ltac/g_ltac.ml4 b/plugins/ltac/g_ltac.ml4
new file mode 100644
index 000000000..aab568746
--- /dev/null
+++ b/plugins/ltac/g_ltac.ml4
@@ -0,0 +1,527 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i camlp4deps: "grammar/grammar.cma" i*)
+
+open Util
+open Pp
+open Compat
+open Constrexpr
+open Tacexpr
+open Misctypes
+open Genarg
+open Genredexpr
+open Tok (* necessary for camlp4 *)
+open Names
+
+open Pcoq
+open Pcoq.Constr
+open Pcoq.Vernac_
+open Pcoq.Prim
+open Pltac
+
+let fail_default_value = ArgArg 0
+
+let arg_of_expr = function
+    TacArg (loc,a) -> a
+  | e -> Tacexp (e:raw_tactic_expr)
+
+let genarg_of_unit () = in_gen (rawwit Stdarg.wit_unit) ()
+let genarg_of_int n = in_gen (rawwit Stdarg.wit_int) n
+let genarg_of_ipattern pat = in_gen (rawwit Stdarg.wit_intro_pattern) pat
+let genarg_of_uconstr c = in_gen (rawwit Stdarg.wit_uconstr) c
+let in_tac tac = in_gen (rawwit Tacarg.wit_ltac) tac
+
+let reference_to_id = function
+  | Libnames.Ident (loc, id) -> (loc, id)
+  | Libnames.Qualid (loc,_) ->
+      CErrors.user_err ~loc 
+       (str "This expression should be a simple identifier.")
+
+let tactic_mode = Gram.entry_create "vernac:tactic_command"
+
+let new_entry name =
+  let e = Gram.entry_create name in
+  e
+
+let toplevel_selector = new_entry "vernac:toplevel_selector"
+let tacdef_body = new_entry "tactic:tacdef_body"
+
+(* Registers the Classic Proof Mode (which uses [tactic_mode] as a parser for
+    proof editing and changes nothing else). Then sets it as the default proof mode. *)
+let _ =
+  let mode = {
+    Proof_global.name = "Classic";
+    set = (fun () -> set_command_entry tactic_mode);
+    reset = (fun () -> set_command_entry Pcoq.Vernac_.noedit_mode);
+  } in
+  Proof_global.register_proof_mode mode
+
+(* Hack to parse "[ id" without dropping [ *)
+let test_bracket_ident =
+  Gram.Entry.of_parser "test_bracket_ident"
+    (fun strm ->
+      match get_tok (stream_nth 0 strm) with
+        | KEYWORD "[" ->
+            (match get_tok (stream_nth 1 strm) with
+              | IDENT _ -> ()
+	      | _ -> raise Stream.Failure)
+	| _ -> raise Stream.Failure)
+
+(* Tactics grammar rules *)
+
+let hint = G_proofs.hint
+
+let warn_deprecated_appcontext =
+  CWarnings.create ~name:"deprecated-appcontext" ~category:"deprecated"
+         (fun () -> strbrk "appcontext is deprecated and will be removed " ++
+                      strbrk "in a future version")
+
+GEXTEND Gram
+  GLOBAL: tactic tacdef_body tactic_expr binder_tactic tactic_arg command hint
+          tactic_mode constr_may_eval constr_eval toplevel_selector
+          operconstr;
+
+  tactic_then_last:
+    [ [ "|"; lta = LIST0 OPT tactic_expr SEP "|" ->
+          Array.map (function None -> TacId [] | Some t -> t) (Array.of_list lta)
+      | -> [||]
+    ] ]
+  ;
+  tactic_then_gen:
+    [ [ ta = tactic_expr; "|"; (first,last) = tactic_then_gen -> (ta::first, last)
+      | ta = tactic_expr; ".."; l = tactic_then_last -> ([], Some (ta, l))
+      | ".."; l = tactic_then_last -> ([], Some (TacId [], l))
+      | ta = tactic_expr -> ([ta], None)
+      | "|"; (first,last) = tactic_then_gen -> (TacId [] :: first, last)
+      | -> ([TacId []], None)
+    ] ]
+  ;
+  tactic_then_locality: (* [true] for the local variant [TacThens] and [false]
+                           for [TacExtend] *)
+  [ [ "[" ; l = OPT">" -> if Option.is_empty l then true else false ] ]
+  ;
+  tactic_expr:
+    [ "5" RIGHTA
+      [ te = binder_tactic -> te ]
+    | "4" LEFTA
+      [ ta0 = tactic_expr; ";"; ta1 = binder_tactic -> TacThen (ta0, ta1)
+      | ta0 = tactic_expr; ";"; ta1 = tactic_expr -> TacThen (ta0,ta1)
+      | ta0 = tactic_expr; ";"; l = tactic_then_locality; (first,tail) = tactic_then_gen; "]" ->
+	  match l , tail with
+          | false , Some (t,last) -> TacThen (ta0,TacExtendTac (Array.of_list first, t, last))
+	  | true  , Some (t,last) -> TacThens3parts (ta0, Array.of_list first, t, last)
+          | false , None -> TacThen (ta0,TacDispatch first)
+	  | true  , None -> TacThens (ta0,first) ]
+    | "3" RIGHTA
+      [ IDENT "try"; ta = tactic_expr -> TacTry ta
+      | IDENT "do"; n = int_or_var; ta = tactic_expr -> TacDo (n,ta)
+      | IDENT "timeout"; n = int_or_var; ta = tactic_expr -> TacTimeout (n,ta)
+      | IDENT "time"; s = OPT string; ta = tactic_expr -> TacTime (s,ta)
+      | IDENT "repeat"; ta = tactic_expr -> TacRepeat ta
+      | IDENT "progress"; ta = tactic_expr -> TacProgress ta
+      | IDENT "once"; ta = tactic_expr -> TacOnce ta
+      | IDENT "exactly_once"; ta = tactic_expr -> TacExactlyOnce ta
+      | IDENT "infoH"; ta = tactic_expr -> TacShowHyps ta
+(*To do: put Abstract in Refiner*)
+      | IDENT "abstract"; tc = NEXT -> TacAbstract (tc,None)
+      | IDENT "abstract"; tc = NEXT; "using";  s = ident ->
+          TacAbstract (tc,Some s)
+      | sel = selector; ta = tactic_expr -> TacSelect (sel, ta) ]
+(*End of To do*)
+    | "2" RIGHTA
+      [ ta0 = tactic_expr; "+"; ta1 = binder_tactic -> TacOr (ta0,ta1)
+      | ta0 = tactic_expr; "+"; ta1 = tactic_expr -> TacOr (ta0,ta1) 
+      | IDENT "tryif" ; ta = tactic_expr ;
+              "then" ; tat = tactic_expr ;
+              "else" ; tae = tactic_expr -> TacIfThenCatch(ta,tat,tae)
+      | ta0 = tactic_expr; "||"; ta1 = binder_tactic -> TacOrelse (ta0,ta1)
+      | ta0 = tactic_expr; "||"; ta1 = tactic_expr -> TacOrelse (ta0,ta1) ]
+    | "1" RIGHTA
+      [ b = match_key; IDENT "goal"; "with"; mrl = match_context_list; "end" ->
+          TacMatchGoal (b,false,mrl)
+      | b = match_key; IDENT "reverse"; IDENT "goal"; "with";
+        mrl = match_context_list; "end" ->
+          TacMatchGoal (b,true,mrl)
+      |	b = match_key; c = tactic_expr; "with"; mrl = match_list; "end" ->
+          TacMatch (b,c,mrl)
+      | IDENT "first" ; "["; l = LIST0 tactic_expr SEP "|"; "]" ->
+	  TacFirst l
+      | IDENT "solve" ; "["; l = LIST0 tactic_expr SEP "|"; "]" ->
+	  TacSolve l
+      | IDENT "idtac"; l = LIST0 message_token -> TacId l
+      | g=failkw; n = [ n = int_or_var -> n | -> fail_default_value ];
+	  l = LIST0 message_token -> TacFail (g,n,l)
+      | st = simple_tactic -> st
+      | a = tactic_arg -> TacArg(!@loc,a)
+      | r = reference; la = LIST0 tactic_arg_compat ->
+          TacArg(!@loc,TacCall (!@loc,r,la)) ]
+    | "0"
+      [ "("; a = tactic_expr; ")" -> a
+      | "["; ">"; (tf,tail) = tactic_then_gen; "]" ->
+          begin match tail with
+          | Some (t,tl) -> TacExtendTac(Array.of_list tf,t,tl)
+          | None -> TacDispatch tf
+          end
+      | a = tactic_atom -> TacArg (!@loc,a) ] ]
+  ;
+  failkw:
+  [ [ IDENT "fail" -> TacLocal | IDENT "gfail" -> TacGlobal ] ]
+  ;
+  (* binder_tactic: level 5 of tactic_expr *)
+  binder_tactic:
+    [ RIGHTA
+      [ "fun"; it = LIST1 input_fun ; "=>"; body = tactic_expr LEVEL "5" ->
+          TacFun (it,body)
+      | "let"; isrec = [IDENT "rec" -> true | -> false];
+          llc = LIST1 let_clause SEP "with"; "in";
+          body = tactic_expr LEVEL "5" -> TacLetIn (isrec,llc,body)
+      | IDENT "info"; tc = tactic_expr LEVEL "5" -> TacInfo tc ] ]
+  ;
+  (* Tactic arguments to the right of an application *)
+  tactic_arg_compat:
+    [ [ a = tactic_arg -> a
+      | c = Constr.constr -> (match c with CRef (r,None) -> Reference r | c -> ConstrMayEval (ConstrTerm c))
+      (* Unambiguous entries: tolerated w/o "ltac:" modifier *)
+      | "()" -> TacGeneric (genarg_of_unit ()) ] ]
+  ;
+  (* Can be used as argument and at toplevel in tactic expressions. *)
+  tactic_arg:
+    [ [ c = constr_eval -> ConstrMayEval c
+      | IDENT "fresh"; l = LIST0 fresh_id -> TacFreshId l
+      | IDENT "type_term"; c=uconstr -> TacPretype c
+      | IDENT "numgoals" -> TacNumgoals ] ]
+  ;
+  (* If a qualid is given, use its short name. TODO: have the shortest
+     non ambiguous name where dots are replaced by "_"? Probably too
+     verbose most of the time. *)
+  fresh_id:
+    [ [ s = STRING -> ArgArg s (*| id = ident -> ArgVar (!@loc,id)*)
+	| qid = qualid -> let (_pth,id) = Libnames.repr_qualid (snd qid) in ArgVar (!@loc,id) ] ]
+  ;
+  constr_eval:
+    [ [ IDENT "eval"; rtc = red_expr; "in"; c = Constr.constr ->
+          ConstrEval (rtc,c)
+      | IDENT "context"; id = identref; "["; c = Constr.lconstr; "]" ->
+          ConstrContext (id,c)
+      | IDENT "type"; IDENT "of"; c = Constr.constr ->
+          ConstrTypeOf c ] ]
+  ;
+  constr_may_eval: (* For extensions *)
+    [ [ c = constr_eval -> c
+      | c = Constr.constr -> ConstrTerm c ] ]
+  ;
+  tactic_atom:
+    [ [ n = integer -> TacGeneric (genarg_of_int n)
+      | r = reference -> TacCall (!@loc,r,[])
+      | "()" -> TacGeneric (genarg_of_unit ()) ] ]
+  ;
+  match_key:
+    [ [ "match" -> Once
+      | "lazymatch" -> Select
+      | "multimatch" -> General ] ]
+  ;
+  input_fun:
+    [ [ "_" -> Anonymous
+      | l = ident -> Name l ] ]
+  ;
+  let_clause:
+    [ [ id = identref; ":="; te = tactic_expr ->
+         (id, arg_of_expr te)
+      | id = identref; args = LIST1 input_fun; ":="; te = tactic_expr ->
+         (id, arg_of_expr (TacFun(args,te))) ] ]
+  ;
+  match_pattern:
+    [ [ IDENT "context";  oid = OPT Constr.ident;
+          "["; pc = Constr.lconstr_pattern; "]" ->
+        let mode = not (!Flags.tactic_context_compat) in
+        Subterm (mode, oid, pc)
+      | IDENT "appcontext";  oid = OPT Constr.ident;
+          "["; pc = Constr.lconstr_pattern; "]" ->
+        warn_deprecated_appcontext ~loc:!@loc ();
+        Subterm (true,oid, pc)
+      | pc = Constr.lconstr_pattern -> Term pc ] ]
+  ;
+  match_hyps:
+    [ [ na = name; ":"; mp =  match_pattern -> Hyp (na, mp)
+      | na = name; ":="; "["; mpv = match_pattern; "]"; ":"; mpt = match_pattern -> Def (na, mpv, mpt)
+      | na = name; ":="; mpv = match_pattern ->
+	  let t, ty =
+	    match mpv with
+	    | Term t -> (match t with
+	      | CCast (loc, t, (CastConv ty | CastVM ty | CastNative ty)) -> Term t, Some (Term ty)
+	      | _ -> mpv, None)
+	    | _ -> mpv, None
+	  in Def (na, t, Option.default (Term (CHole (Loc.ghost, None, IntroAnonymous, None))) ty)
+    ] ]
+  ;
+  match_context_rule:
+    [ [ largs = LIST0 match_hyps SEP ","; "|-"; mp = match_pattern;
+        "=>"; te = tactic_expr -> Pat (largs, mp, te)
+      | "["; largs = LIST0 match_hyps SEP ","; "|-"; mp = match_pattern;
+        "]"; "=>"; te = tactic_expr -> Pat (largs, mp, te)
+      | "_"; "=>"; te = tactic_expr -> All te ] ]
+  ;
+  match_context_list:
+    [ [ mrl = LIST1 match_context_rule SEP "|" -> mrl
+      | "|"; mrl = LIST1 match_context_rule SEP "|" -> mrl ] ]
+  ;
+  match_rule:
+    [ [ mp = match_pattern; "=>"; te = tactic_expr -> Pat ([],mp,te)
+      | "_"; "=>"; te = tactic_expr -> All te ] ]
+  ;
+  match_list:
+    [ [ mrl = LIST1 match_rule SEP "|" -> mrl
+      | "|"; mrl = LIST1 match_rule SEP "|" -> mrl ] ]
+  ;
+  message_token:
+    [ [ id = identref -> MsgIdent id
+      | s = STRING -> MsgString s
+      | n = integer -> MsgInt n ] ]
+  ;
+
+  ltac_def_kind:
+    [ [ ":=" -> false
+      | "::=" -> true ] ]
+  ;
+
+  (* Definitions for tactics *)
+  tacdef_body:
+    [ [ name = Constr.global; it=LIST1 input_fun; redef = ltac_def_kind; body = tactic_expr ->
+          if redef then Tacexpr.TacticRedefinition (name, TacFun (it, body))
+          else
+            let id = reference_to_id name in
+            Tacexpr.TacticDefinition (id, TacFun (it, body))
+      | name = Constr.global; redef = ltac_def_kind; body = tactic_expr ->
+          if redef then Tacexpr.TacticRedefinition (name, body)
+          else
+            let id = reference_to_id name in
+            Tacexpr.TacticDefinition (id, body)
+    ] ]
+  ;
+  tactic:
+    [ [ tac = tactic_expr -> tac ] ]
+  ;
+
+  range_selector:
+    [ [ n = natural ; "-" ; m = natural -> (n, m)
+      | n = natural -> (n, n) ] ]
+  ;
+  (* We unfold a range selectors list once so that we can make a special case
+   * for a unique SelectNth selector. *)
+  range_selector_or_nth:
+    [ [ n = natural ; "-" ; m = natural;
+        l = OPT [","; l = LIST1 range_selector SEP "," -> l] ->
+          SelectList ((n, m) :: Option.default [] l)
+      | n = natural;
+        l = OPT [","; l = LIST1 range_selector SEP "," -> l] ->
+          Option.cata (fun l -> SelectList ((n, n) :: l)) (SelectNth n) l ] ]
+  ;
+  selector_body:
+  [ [ l = range_selector_or_nth -> l
+    | test_bracket_ident; "["; id = ident; "]" -> SelectId id ] ]
+  ;
+  selector:
+    [ [ IDENT "only"; sel = selector_body; ":" -> sel ] ]
+  ;
+  toplevel_selector:
+    [ [ sel = selector_body; ":" -> sel
+    |   IDENT "all"; ":" -> SelectAll ] ]
+  ;
+  tactic_mode:
+    [ [ g = OPT toplevel_selector; tac = G_vernac.subgoal_command -> tac g ] ]
+  ;
+  command:
+    [ [ IDENT "Proof"; "with"; ta = Pltac.tactic; 
+        l = OPT [ "using"; l = G_vernac.section_subset_expr -> l ] ->
+          Vernacexpr.VernacProof (Some (in_tac ta), G_proofs.hint_proof_using G_vernac.section_subset_expr l)
+      | IDENT "Proof"; "using"; l = G_vernac.section_subset_expr;
+        ta = OPT [ "with"; ta = Pltac.tactic -> in_tac ta ] ->
+          Vernacexpr.VernacProof (ta,Some l) ] ]
+  ;
+  hint:
+    [ [ IDENT "Extern"; n = natural; c = OPT Constr.constr_pattern ; "=>";
+        tac = Pltac.tactic ->
+          Vernacexpr.HintsExtern (n,c, in_tac tac) ] ]
+  ;
+  operconstr: LEVEL "0"
+    [ [ IDENT "ltac"; ":"; "("; tac = Pltac.tactic_expr; ")" ->
+          let arg = Genarg.in_gen (Genarg.rawwit Tacarg.wit_tactic) tac in
+          CHole (!@loc, None, IntroAnonymous, Some arg) ] ]
+  ;
+  END
+
+open Stdarg
+open Tacarg
+open Vernacexpr
+open Vernac_classifier
+open Goptions
+open Libnames
+
+let print_info_trace = ref None
+
+let _ = declare_int_option {
+  optsync = true;
+  optdepr = false;
+  optname = "print info trace";
+  optkey = ["Info" ; "Level"];
+  optread = (fun () -> !print_info_trace);
+  optwrite = fun n -> print_info_trace := n;
+}
+
+let vernac_solve n info tcom b =
+  let status = Proof_global.with_current_proof (fun etac p ->
+    let with_end_tac = if b then Some etac else None in
+    let global = match n with SelectAll | SelectList _ -> true | _ -> false in
+    let info = Option.append info !print_info_trace in
+    let (p,status) =
+      Pfedit.solve n info (Tacinterp.hide_interp global tcom None) ?with_end_tac p
+    in
+    (* in case a strict subtree was completed,
+       go back to the top of the prooftree *)
+    let p = Proof.maximal_unfocus Vernacentries.command_focus p in
+    p,status) in
+    if not status then Feedback.feedback Feedback.AddedAxiom
+
+let pr_range_selector (i, j) =
+  if Int.equal i j then int i
+  else int i ++ str "-" ++ int j
+
+let pr_ltac_selector = function
+| SelectNth i -> int i ++ str ":"
+| SelectList l -> str "[" ++ prlist_with_sep (fun () -> str ", ") pr_range_selector l ++
+    str "]" ++ str ":"
+| SelectId id -> str "[" ++ Nameops.pr_id id ++ str "]" ++ str ":"
+| SelectAll -> str "all" ++ str ":"
+
+VERNAC ARGUMENT EXTEND ltac_selector PRINTED BY pr_ltac_selector
+| [ toplevel_selector(s) ] -> [ s ]
+END
+
+let pr_ltac_info n = str "Info" ++ spc () ++ int n
+
+VERNAC ARGUMENT EXTEND ltac_info PRINTED BY pr_ltac_info
+| [ "Info" natural(n) ] -> [ n ]
+END
+
+let pr_ltac_use_default b =
+  if b then (* Bug: a space is inserted before "..." *) str ".." else mt ()
+
+VERNAC ARGUMENT EXTEND ltac_use_default PRINTED BY pr_ltac_use_default
+| [ "." ] -> [ false ]
+| [ "..." ] -> [ true ]
+END
+
+let is_anonymous_abstract = function
+  | TacAbstract (_,None) -> true
+  | TacSolve [TacAbstract (_,None)] -> true
+  | _ -> false
+let rm_abstract = function
+  | TacAbstract (t,_) -> t
+  | TacSolve [TacAbstract (t,_)] -> TacSolve [t]
+  | x -> x
+let is_explicit_terminator = function TacSolve _ -> true | _ -> false
+
+VERNAC tactic_mode EXTEND VernacSolve
+| [ - ltac_selector_opt(g) ltac_info_opt(n) tactic(t) ltac_use_default(def) ] =>
+    [ classify_as_proofstep ] -> [
+    let g = Option.default (Proof_global.get_default_goal_selector ()) g in
+    vernac_solve g n t def
+  ]
+| [ - "par" ":" ltac_info_opt(n) tactic(t) ltac_use_default(def) ] =>
+    [
+      let anon_abstracting_tac = is_anonymous_abstract t in
+      let solving_tac = is_explicit_terminator t in
+      let parallel = `Yes (solving_tac,anon_abstracting_tac) in
+      let pbr = if solving_tac then Some "par" else None in
+      VtProofStep{ parallel = parallel; proof_block_detection = pbr },
+      VtLater
+    ] -> [
+      let t = rm_abstract t in
+      vernac_solve SelectAll n t def
+    ]
+END
+
+let pr_ltac_tactic_level n = str "(at level " ++ int n ++ str ")"
+
+VERNAC ARGUMENT EXTEND ltac_tactic_level PRINTED BY pr_ltac_tactic_level
+| [ "(" "at" "level" natural(n) ")" ] -> [ n ]
+END
+
+VERNAC ARGUMENT EXTEND ltac_production_sep
+| [ "," string(sep) ] -> [ sep ]
+END
+
+let pr_ltac_production_item = function
+| Tacentries.TacTerm s -> quote (str s)
+| Tacentries.TacNonTerm (_, (arg, sep), id) ->
+  let sep = match sep with
+  | None -> mt ()
+  | Some sep -> str "," ++ spc () ++ quote (str sep)
+  in
+  str arg ++ str "(" ++ Nameops.pr_id id ++ sep ++ str ")"
+
+VERNAC ARGUMENT EXTEND ltac_production_item PRINTED BY pr_ltac_production_item
+| [ string(s) ] -> [ Tacentries.TacTerm s ]
+| [ ident(nt) "(" ident(p) ltac_production_sep_opt(sep) ")" ] ->
+  [ Tacentries.TacNonTerm (loc, (Names.Id.to_string nt, sep), p) ]
+END
+
+VERNAC COMMAND EXTEND VernacTacticNotation
+| [ "Tactic" "Notation" ltac_tactic_level_opt(n) ne_ltac_production_item_list(r) ":=" tactic(e) ] =>
+  [ VtUnknown, VtNow ] ->
+  [
+    let l = Locality.LocalityFixme.consume () in
+    let n = Option.default 0 n in
+    Tacentries.add_tactic_notation (Locality.make_module_locality l) n r e
+  ]
+END
+
+VERNAC COMMAND EXTEND VernacPrintLtac CLASSIFIED AS QUERY
+| [ "Print" "Ltac" reference(r) ] ->
+  [ Feedback.msg_notice (Tacintern.print_ltac (snd (Libnames.qualid_of_reference r))) ]
+END
+
+let pr_ltac_ref = Libnames.pr_reference
+
+let pr_tacdef_body tacdef_body =
+  let id, redef, body =
+    match tacdef_body with
+    | TacticDefinition ((_,id), body) -> Nameops.pr_id id, false, body
+    | TacticRedefinition (id, body) -> pr_ltac_ref id, true, body
+  in
+  let idl, body =
+    match body with
+      | Tacexpr.TacFun (idl,b) -> idl,b
+      | _ -> [], body in
+  id ++
+    prlist (function Anonymous -> str " _"
+      | Name id -> spc () ++ Nameops.pr_id id) idl
+  ++ (if redef then str" ::=" else str" :=") ++ brk(1,1)
+  ++ Pptactic.pr_raw_tactic body
+
+VERNAC ARGUMENT EXTEND ltac_tacdef_body
+PRINTED BY pr_tacdef_body
+| [ tacdef_body(t) ] -> [ t ]
+END
+
+VERNAC COMMAND EXTEND VernacDeclareTacticDefinition
+| [ "Ltac" ne_ltac_tacdef_body_list_sep(l, "with") ] => [
+    VtSideff (List.map (function
+      | TacticDefinition ((_,r),_) -> r
+      | TacticRedefinition (Ident (_,r),_) -> r
+      | TacticRedefinition (Qualid (_,q),_) -> snd(repr_qualid q)) l), VtLater
+  ] -> [
+    let lc = Locality.LocalityFixme.consume () in
+    Tacentries.register_ltac (Locality.make_module_locality lc) l
+  ]
+END
+
+VERNAC COMMAND EXTEND VernacPrintLtacs CLASSIFIED AS QUERY
+| [ "Print" "Ltac" "Signatures" ] -> [ Tacentries.print_ltacs () ]
+END
diff --git a/plugins/ltac/g_obligations.ml4 b/plugins/ltac/g_obligations.ml4
new file mode 100644
index 000000000..d286a5870
--- /dev/null
+++ b/plugins/ltac/g_obligations.ml4
@@ -0,0 +1,161 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i camlp4deps: "grammar/grammar.cma" i*)
+
+(*
+  Syntax for the subtac terms and types.
+  Elaborated from correctness/psyntax.ml4 by Jean-Christophe Filliâtre *)
+
+
+open Libnames
+open Constrexpr
+open Constrexpr_ops
+open Stdarg
+open Tacarg
+open Extraargs
+
+let (set_default_tactic, get_default_tactic, print_default_tactic) = 
+  Tactic_option.declare_tactic_option "Program tactic"
+
+let () =
+  (** Delay to recover the tactic imperatively *)
+  let tac = Proofview.tclBIND (Proofview.tclUNIT ()) begin fun () ->
+    snd (get_default_tactic ())
+  end in
+  Obligations.default_tactic := tac
+
+let with_tac f tac =
+  let env = { Genintern.genv = Global.env (); ltacvars = Names.Id.Set.empty } in
+  let tac = match tac with
+  | None -> None
+  | Some tac ->
+    let tac = Genarg.in_gen (Genarg.rawwit wit_ltac) tac in
+    let _, tac = Genintern.generic_intern env tac in
+    Some tac
+  in
+  f tac
+
+(* We define new entries for programs, with the use of this module
+ * Subtac. These entries are named Subtac.<foo>
+ *)
+
+module Gram = Pcoq.Gram
+module Tactic = Pltac
+
+open Pcoq
+
+let sigref = mkRefC (Qualid (Loc.ghost, Libnames.qualid_of_string "Coq.Init.Specif.sig"))
+
+type 'a withtac_argtype = (Tacexpr.raw_tactic_expr option, 'a) Genarg.abstract_argument_type
+
+let wit_withtac : Tacexpr.raw_tactic_expr option Genarg.uniform_genarg_type =
+  Genarg.create_arg "withtac"
+
+let withtac = Pcoq.create_generic_entry Pcoq.utactic "withtac" (Genarg.rawwit wit_withtac)
+
+GEXTEND Gram
+  GLOBAL: withtac;
+
+  withtac:
+    [ [ "with"; t = Tactic.tactic -> Some t
+      | -> None ] ]
+  ;
+
+  Constr.closed_binder:
+    [[ "("; id=Prim.name; ":"; t=Constr.lconstr; "|"; c=Constr.lconstr; ")" ->
+	  let typ = mkAppC (sigref, [mkLambdaC ([id], default_binder_kind, t, c)]) in
+          [LocalRawAssum ([id], default_binder_kind, typ)]
+    ] ];
+
+  END
+
+open Obligations
+
+let obligation obl tac = with_tac (fun t -> Obligations.obligation obl t) tac
+let next_obligation obl tac = with_tac (fun t -> Obligations.next_obligation obl t) tac
+
+let classify_obbl _ = Vernacexpr.(VtStartProof ("Classic",Doesn'tGuaranteeOpacity,[]), VtLater)
+
+VERNAC COMMAND EXTEND Obligations CLASSIFIED BY classify_obbl
+| [ "Obligation" integer(num) "of" ident(name) ":" lglob(t) withtac(tac) ] ->
+    [ obligation (num, Some name, Some t) tac ]
+| [ "Obligation" integer(num) "of" ident(name) withtac(tac) ] ->
+    [ obligation (num, Some name, None) tac ]
+| [ "Obligation" integer(num) ":" lglob(t) withtac(tac) ] ->
+    [ obligation (num, None, Some t) tac ]
+| [ "Obligation" integer(num) withtac(tac) ] ->
+    [ obligation (num, None, None) tac ]
+| [ "Next" "Obligation" "of" ident(name) withtac(tac) ] ->
+    [ next_obligation (Some name) tac ]
+| [ "Next" "Obligation" withtac(tac) ] -> [ next_obligation None tac ]
+END
+
+VERNAC COMMAND EXTEND Solve_Obligation CLASSIFIED AS SIDEFF
+| [ "Solve" "Obligation" integer(num) "of" ident(name) "with" tactic(t) ] ->
+    [ try_solve_obligation num (Some name) (Some (Tacinterp.interp t)) ]
+| [ "Solve" "Obligation" integer(num) "with" tactic(t) ] ->
+    [ try_solve_obligation num None (Some (Tacinterp.interp t)) ]
+END
+
+VERNAC COMMAND EXTEND Solve_Obligations CLASSIFIED AS SIDEFF
+| [ "Solve" "Obligations" "of" ident(name) "with" tactic(t) ] ->
+    [ try_solve_obligations (Some name) (Some (Tacinterp.interp t)) ]
+| [ "Solve" "Obligations" "with" tactic(t) ] ->
+    [ try_solve_obligations None (Some (Tacinterp.interp t)) ]
+| [ "Solve" "Obligations" ] ->
+    [ try_solve_obligations None None ]
+END
+
+VERNAC COMMAND EXTEND Solve_All_Obligations CLASSIFIED AS SIDEFF
+| [ "Solve" "All" "Obligations" "with" tactic(t) ] ->
+    [ solve_all_obligations (Some (Tacinterp.interp t)) ]
+| [ "Solve" "All" "Obligations" ] ->
+    [ solve_all_obligations None ]
+END
+
+VERNAC COMMAND EXTEND Admit_Obligations CLASSIFIED AS SIDEFF
+| [ "Admit" "Obligations" "of" ident(name) ] -> [ admit_obligations (Some name) ]
+| [ "Admit" "Obligations" ] -> [ admit_obligations None ]
+END
+
+VERNAC COMMAND EXTEND Set_Solver CLASSIFIED AS SIDEFF
+| [ "Obligation" "Tactic" ":=" tactic(t) ] -> [
+    set_default_tactic
+      (Locality.make_section_locality (Locality.LocalityFixme.consume ()))
+      (Tacintern.glob_tactic t) ]
+END
+
+open Pp
+
+VERNAC COMMAND EXTEND Show_Solver CLASSIFIED AS QUERY
+| [ "Show" "Obligation" "Tactic" ] -> [
+    Feedback.msg_info (str"Program obligation tactic is " ++ print_default_tactic ()) ]
+END
+
+VERNAC COMMAND EXTEND Show_Obligations CLASSIFIED AS QUERY
+| [ "Obligations" "of" ident(name) ] -> [ show_obligations (Some name) ]
+| [ "Obligations" ] -> [ show_obligations None ]
+END
+
+VERNAC COMMAND EXTEND Show_Preterm CLASSIFIED AS QUERY
+| [ "Preterm" "of" ident(name) ] -> [ Feedback.msg_info (show_term (Some name)) ]
+| [ "Preterm" ] -> [ Feedback.msg_info (show_term None) ]
+END
+
+open Pp
+
+(* Declare a printer for the content of Program tactics *)
+let () =
+  let printer _ _ _ = function
+  | None -> mt ()
+  | Some tac -> str "with" ++ spc () ++ Pptactic.pr_raw_tactic tac
+  in
+  (* should not happen *)
+  let dummy _ _ _ expr = assert false in
+  Pptactic.declare_extra_genarg_pprule wit_withtac printer dummy dummy
diff --git a/plugins/ltac/g_rewrite.ml4 b/plugins/ltac/g_rewrite.ml4
new file mode 100644
index 000000000..b1c4f58eb
--- /dev/null
+++ b/plugins/ltac/g_rewrite.ml4
@@ -0,0 +1,274 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i camlp4deps: "grammar/grammar.cma" i*)
+
+(* Syntax for rewriting with strategies *)
+
+open Names
+open Misctypes
+open Locus
+open Constrexpr
+open Glob_term
+open Geninterp
+open Extraargs
+open Tacmach
+open Tacticals
+open Rewrite
+open Stdarg
+open Pcoq.Vernac_
+open Pcoq.Prim
+open Pcoq.Constr
+open Pltac
+
+DECLARE PLUGIN "g_rewrite"
+
+type constr_expr_with_bindings = constr_expr with_bindings
+type glob_constr_with_bindings = Tacexpr.glob_constr_and_expr with_bindings
+type glob_constr_with_bindings_sign = interp_sign * Tacexpr.glob_constr_and_expr with_bindings
+
+let pr_glob_constr_with_bindings_sign _ _ _ (ge : glob_constr_with_bindings_sign) = Printer.pr_glob_constr (fst (fst (snd ge)))
+let pr_glob_constr_with_bindings _ _ _ (ge : glob_constr_with_bindings) = Printer.pr_glob_constr (fst (fst ge))
+let pr_constr_expr_with_bindings prc _ _ (ge : constr_expr_with_bindings) = prc (fst ge)
+let interp_glob_constr_with_bindings ist gl c = Tacmach.project gl , (ist, c)
+let glob_glob_constr_with_bindings ist l = Tacintern.intern_constr_with_bindings ist l
+let subst_glob_constr_with_bindings s c =
+  Tacsubst.subst_glob_with_bindings s c
+
+ARGUMENT EXTEND glob_constr_with_bindings
+    PRINTED BY pr_glob_constr_with_bindings_sign
+
+    INTERPRETED BY interp_glob_constr_with_bindings
+    GLOBALIZED BY glob_glob_constr_with_bindings
+    SUBSTITUTED BY subst_glob_constr_with_bindings
+
+    RAW_PRINTED BY pr_constr_expr_with_bindings
+    GLOB_PRINTED BY pr_glob_constr_with_bindings
+
+   [ constr_with_bindings(bl) ] -> [ bl ]
+END
+
+type raw_strategy = (constr_expr, Tacexpr.raw_red_expr) strategy_ast
+type glob_strategy = (Tacexpr.glob_constr_and_expr, Tacexpr.raw_red_expr) strategy_ast
+
+let interp_strategy ist gl s = 
+  let sigma = project gl in
+    sigma, strategy_of_ast s
+let glob_strategy ist s = map_strategy (Tacintern.intern_constr ist) (fun c -> c) s
+let subst_strategy s str = str
+
+let pr_strategy _ _ _ (s : strategy) = Pp.str "<strategy>"
+let pr_raw_strategy prc prlc _ (s : raw_strategy) =
+  let prr = Pptactic.pr_red_expr (prc, prlc, Pputils.pr_or_by_notation Libnames.pr_reference, prc) in
+  Rewrite.pr_strategy prc prr s
+let pr_glob_strategy prc prlc _ (s : glob_strategy) =
+  let prr = Pptactic.pr_red_expr
+    (Ppconstr.pr_constr_expr,
+    Ppconstr.pr_lconstr_expr,
+    Pputils.pr_or_by_notation Libnames.pr_reference,
+    Ppconstr.pr_constr_expr)
+  in
+  Rewrite.pr_strategy prc prr s
+
+ARGUMENT EXTEND rewstrategy
+    PRINTED BY pr_strategy
+
+    INTERPRETED BY interp_strategy
+    GLOBALIZED BY glob_strategy
+    SUBSTITUTED BY subst_strategy
+
+    RAW_PRINTED BY pr_raw_strategy
+    GLOB_PRINTED BY pr_glob_strategy
+
+    [ glob(c) ] -> [ StratConstr (c, true) ]
+  | [ "<-" constr(c) ] -> [ StratConstr (c, false) ]
+  | [ "subterms" rewstrategy(h) ] -> [ StratUnary (Subterms, h) ]
+  | [ "subterm" rewstrategy(h) ] -> [ StratUnary (Subterm, h) ]
+  | [ "innermost" rewstrategy(h) ] -> [ StratUnary(Innermost, h) ]
+  | [ "outermost" rewstrategy(h) ] -> [ StratUnary(Outermost, h) ]
+  | [ "bottomup" rewstrategy(h) ] -> [ StratUnary(Bottomup, h) ]
+  | [ "topdown" rewstrategy(h) ] -> [ StratUnary(Topdown, h) ]
+  | [ "id" ] -> [ StratId ]
+  | [ "fail" ] -> [ StratFail ]
+  | [ "refl" ] -> [ StratRefl ]
+  | [ "progress" rewstrategy(h) ] -> [ StratUnary (Progress, h) ]
+  | [ "try" rewstrategy(h) ] -> [ StratUnary (Try, h) ]
+  | [ "any" rewstrategy(h) ] -> [ StratUnary (Any, h) ]
+  | [ "repeat" rewstrategy(h) ] -> [ StratUnary (Repeat, h) ]
+  | [ rewstrategy(h) ";" rewstrategy(h') ] -> [ StratBinary (Compose, h, h') ]
+  | [ "(" rewstrategy(h) ")" ] -> [ h ]
+  | [ "choice" rewstrategy(h) rewstrategy(h') ] -> [ StratBinary (Choice, h, h') ]
+  | [ "old_hints" preident(h) ] -> [ StratHints (true, h) ]
+  | [ "hints" preident(h) ] -> [ StratHints (false, h) ]
+  | [ "terms" constr_list(h) ] -> [ StratTerms h ]
+  | [ "eval" red_expr(r) ] -> [ StratEval r ]
+  | [ "fold" constr(c) ] -> [ StratFold c ]
+END
+
+(* By default the strategy for "rewrite_db" is top-down *)
+
+let db_strat db = StratUnary (Topdown, StratHints (false, db))
+let cl_rewrite_clause_db db = cl_rewrite_clause_strat (strategy_of_ast (db_strat db))
+
+TACTIC EXTEND rewrite_strat
+| [ "rewrite_strat" rewstrategy(s) "in" hyp(id) ] -> [ cl_rewrite_clause_strat s (Some id) ]
+| [ "rewrite_strat" rewstrategy(s) ] -> [ cl_rewrite_clause_strat s None ]
+| [ "rewrite_db" preident(db) "in" hyp(id) ] -> [ cl_rewrite_clause_db db (Some id) ]
+| [ "rewrite_db" preident(db) ] -> [ cl_rewrite_clause_db db None ]
+END
+
+let clsubstitute o c =
+  let is_tac id = match fst (fst (snd c)) with GVar (_, id') when Id.equal id' id -> true | _ -> false in
+    Tacticals.onAllHypsAndConcl
+      (fun cl ->
+        match cl with
+          | Some id when is_tac id -> tclIDTAC
+          | _ -> Proofview.V82.of_tactic (cl_rewrite_clause c o AllOccurrences cl))
+
+TACTIC EXTEND substitute
+| [ "substitute" orient(o) glob_constr_with_bindings(c) ] -> [ Proofview.V82.tactic (clsubstitute o c) ]
+END
+
+
+(* Compatibility with old Setoids *)
+
+TACTIC EXTEND setoid_rewrite
+   [ "setoid_rewrite" orient(o) glob_constr_with_bindings(c) ]
+   -> [ cl_rewrite_clause c o AllOccurrences None ]
+ | [ "setoid_rewrite" orient(o) glob_constr_with_bindings(c) "in" hyp(id) ] ->
+      [ cl_rewrite_clause c o AllOccurrences (Some id) ]
+ | [ "setoid_rewrite" orient(o) glob_constr_with_bindings(c) "at" occurrences(occ) ] ->
+      [ cl_rewrite_clause c o (occurrences_of occ) None ]
+ | [ "setoid_rewrite" orient(o) glob_constr_with_bindings(c) "at" occurrences(occ) "in" hyp(id)] ->
+      [ cl_rewrite_clause c o (occurrences_of occ) (Some id) ]
+ | [ "setoid_rewrite" orient(o) glob_constr_with_bindings(c) "in" hyp(id) "at" occurrences(occ)] ->
+      [ cl_rewrite_clause c o (occurrences_of occ) (Some id) ]
+END
+
+VERNAC COMMAND EXTEND AddRelation CLASSIFIED AS SIDEFF
+  | [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1)
+        "symmetry" "proved" "by" constr(lemma2) "as" ident(n) ] ->
+      [ declare_relation a aeq n (Some lemma1) (Some lemma2) None ]
+
+  | [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1)
+        "as" ident(n) ] ->
+      [ declare_relation a aeq n (Some lemma1) None None ]
+  | [ "Add" "Relation" constr(a) constr(aeq)  "as" ident(n) ] ->
+      [ declare_relation a aeq n None None None ]
+END
+
+VERNAC COMMAND EXTEND AddRelation2 CLASSIFIED AS SIDEFF
+    [ "Add" "Relation" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2)
+      "as" ident(n) ] ->
+      [ declare_relation a aeq n None (Some lemma2) None ]
+  | [ "Add" "Relation" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3)  "as" ident(n) ] ->
+      [ declare_relation a aeq n None (Some lemma2) (Some lemma3) ]
+END
+
+VERNAC COMMAND EXTEND AddRelation3 CLASSIFIED AS SIDEFF
+    [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1)
+      "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] ->
+      [ declare_relation a aeq n (Some lemma1) None (Some lemma3) ]
+  | [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1)
+      "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3)
+      "as" ident(n) ] ->
+      [ declare_relation a aeq n (Some lemma1) (Some lemma2) (Some lemma3) ]
+  | [ "Add" "Relation" constr(a) constr(aeq) "transitivity" "proved" "by" constr(lemma3)
+        "as" ident(n) ] ->
+      [ declare_relation a aeq n None None (Some lemma3) ]
+END
+
+type binders_argtype = local_binder list
+
+let wit_binders =
+ (Genarg.create_arg "binders" : binders_argtype Genarg.uniform_genarg_type)
+
+let binders = Pcoq.create_generic_entry Pcoq.utactic "binders" (Genarg.rawwit wit_binders)
+
+let () =
+  let raw_printer _ _ _ l = Pp.pr_non_empty_arg Ppconstr.pr_binders l in
+  let printer _ _ _ _ = Pp.str "<Unavailable printer for binders>" in
+  Pptactic.declare_extra_genarg_pprule wit_binders raw_printer printer printer
+
+open Pcoq
+
+GEXTEND Gram
+  GLOBAL: binders;
+    binders:
+    [ [ b = Pcoq.Constr.binders -> b ] ];
+END
+
+VERNAC COMMAND EXTEND AddParametricRelation CLASSIFIED AS SIDEFF
+  | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq)
+        "reflexivity" "proved" "by" constr(lemma1)
+        "symmetry" "proved" "by" constr(lemma2) "as" ident(n) ] ->
+      [ declare_relation ~binders:b a aeq n (Some lemma1) (Some lemma2) None ]
+  | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq)
+        "reflexivity" "proved" "by" constr(lemma1)
+        "as" ident(n) ] ->
+      [ declare_relation ~binders:b a aeq n (Some lemma1) None None ]
+  | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq)  "as" ident(n) ] ->
+      [ declare_relation ~binders:b a aeq n None None None ]
+END
+
+VERNAC COMMAND EXTEND AddParametricRelation2 CLASSIFIED AS SIDEFF
+    [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2)
+      "as" ident(n) ] ->
+      [ declare_relation ~binders:b a aeq n None (Some lemma2) None ]
+  | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3)  "as" ident(n) ] ->
+      [ declare_relation ~binders:b a aeq n None (Some lemma2) (Some lemma3) ]
+END
+
+VERNAC COMMAND EXTEND AddParametricRelation3 CLASSIFIED AS SIDEFF
+    [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1)
+      "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] ->
+      [ declare_relation ~binders:b a aeq n (Some lemma1) None (Some lemma3) ]
+  | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1)
+      "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3)
+      "as" ident(n) ] ->
+      [ declare_relation ~binders:b a aeq n (Some lemma1) (Some lemma2) (Some lemma3) ]
+  | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "transitivity" "proved" "by" constr(lemma3)
+        "as" ident(n) ] ->
+      [ declare_relation ~binders:b a aeq n None None (Some lemma3) ]
+END
+
+VERNAC COMMAND EXTEND AddSetoid1 CLASSIFIED AS SIDEFF
+   [ "Add" "Setoid" constr(a) constr(aeq) constr(t) "as" ident(n) ] ->
+     [ add_setoid (not (Locality.make_section_locality (Locality.LocalityFixme.consume ()))) [] a aeq t n ]
+  | [ "Add" "Parametric" "Setoid" binders(binders) ":" constr(a) constr(aeq) constr(t) "as" ident(n) ] ->
+     [  add_setoid (not (Locality.make_section_locality (Locality.LocalityFixme.consume ()))) binders a aeq t n ]
+  | [ "Add" "Morphism" constr(m) ":" ident(n) ]
+    (* This command may or may not open a goal *)
+    => [ Vernacexpr.VtUnknown, Vernacexpr.VtNow ]
+    -> [ add_morphism_infer (not (Locality.make_section_locality (Locality.LocalityFixme.consume ()))) m n ]
+  | [ "Add" "Morphism" constr(m) "with" "signature" lconstr(s) "as" ident(n) ]
+    => [ Vernacexpr.(VtStartProof("Classic",GuaranteesOpacity,[n]), VtLater) ]
+    -> [ add_morphism (not (Locality.make_section_locality (Locality.LocalityFixme.consume ()))) [] m s n ]
+  | [ "Add" "Parametric" "Morphism" binders(binders) ":" constr(m)
+        "with" "signature" lconstr(s) "as" ident(n) ]
+    => [ Vernacexpr.(VtStartProof("Classic",GuaranteesOpacity,[n]), VtLater) ]
+    -> [ add_morphism (not (Locality.make_section_locality (Locality.LocalityFixme.consume ()))) binders m s n ]
+END
+
+TACTIC EXTEND setoid_symmetry
+   [ "setoid_symmetry" ] -> [ setoid_symmetry ]
+ | [ "setoid_symmetry" "in" hyp(n) ] -> [ setoid_symmetry_in n ]
+END
+
+TACTIC EXTEND setoid_reflexivity
+[ "setoid_reflexivity" ] -> [ setoid_reflexivity ]
+END
+
+TACTIC EXTEND setoid_transitivity
+  [ "setoid_transitivity" constr(t) ] -> [ setoid_transitivity (Some t) ]
+| [ "setoid_etransitivity" ] -> [ setoid_transitivity None ]
+END
+
+VERNAC COMMAND EXTEND PrintRewriteHintDb CLASSIFIED AS QUERY
+  [ "Print" "Rewrite" "HintDb" preident(s) ] -> [ Feedback.msg_notice (Autorewrite.print_rewrite_hintdb s) ]
+END
diff --git a/plugins/ltac/g_tactic.ml4 b/plugins/ltac/g_tactic.ml4
new file mode 100644
index 000000000..fa01baab7
--- /dev/null
+++ b/plugins/ltac/g_tactic.ml4
@@ -0,0 +1,666 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+open Pp
+open CErrors
+open Util
+open Tacexpr
+open Genredexpr
+open Constrexpr
+open Libnames
+open Tok
+open Compat
+open Misctypes
+open Locus
+open Decl_kinds
+
+open Pcoq
+
+
+let all_with delta = Redops.make_red_flag [FBeta;FMatch;FFix;FCofix;FZeta;delta]
+
+let tactic_kw = [ "->"; "<-" ; "by" ]
+let _ = List.iter CLexer.add_keyword tactic_kw
+
+let err () = raise Stream.Failure
+
+(* Hack to parse "(x:=t)" as an explicit argument without conflicts with the *)
+(* admissible notation "(x t)" *)
+let test_lpar_id_coloneq =
+  Gram.Entry.of_parser "lpar_id_coloneq"
+    (fun strm ->
+      match get_tok (stream_nth 0 strm) with
+        | KEYWORD "(" ->
+            (match get_tok (stream_nth 1 strm) with
+              | IDENT _ ->
+                  (match get_tok (stream_nth 2 strm) with
+	            | KEYWORD ":=" -> ()
+	            | _ -> err ())
+	      | _ -> err ())
+	| _ -> err ())
+
+(* Hack to recognize "(x)" *)
+let test_lpar_id_rpar =
+  Gram.Entry.of_parser "lpar_id_coloneq"
+    (fun strm ->
+      match get_tok (stream_nth 0 strm) with
+        | KEYWORD "(" ->
+            (match get_tok (stream_nth 1 strm) with
+              | IDENT _ ->
+                  (match get_tok (stream_nth 2 strm) with
+	            | KEYWORD ")" -> ()
+	            | _ -> err ())
+	      | _ -> err ())
+	| _ -> err ())
+
+(* idem for (x:=t) and (1:=t) *)
+let test_lpar_idnum_coloneq =
+  Gram.Entry.of_parser "test_lpar_idnum_coloneq"
+    (fun strm ->
+      match get_tok (stream_nth 0 strm) with
+        | KEYWORD "(" ->
+            (match get_tok (stream_nth 1 strm) with
+              | IDENT _ | INT _ ->
+                  (match get_tok (stream_nth 2 strm) with
+                    | KEYWORD ":=" -> ()
+                    | _ -> err ())
+              | _ -> err ())
+        | _ -> err ())
+
+(* idem for (x:t) *)
+let test_lpar_id_colon =
+  Gram.Entry.of_parser "lpar_id_colon"
+    (fun strm ->
+      match get_tok (stream_nth 0 strm) with
+        | KEYWORD "(" ->
+            (match get_tok (stream_nth 1 strm) with
+              | IDENT _ ->
+                  (match get_tok (stream_nth 2 strm) with
+                    | KEYWORD ":" -> ()
+                    | _ -> err ())
+              | _ -> err ())
+        | _ -> err ())
+
+(* idem for (x1..xn:t) [n^2 complexity but exceptional use] *)
+let check_for_coloneq =
+  Gram.Entry.of_parser "lpar_id_colon"
+    (fun strm ->
+      let rec skip_to_rpar p n =
+	match get_tok (List.last (Stream.npeek n strm)) with
+        | KEYWORD "(" -> skip_to_rpar (p+1) (n+1)
+        | KEYWORD ")" -> if Int.equal p 0 then n+1 else skip_to_rpar (p-1) (n+1)
+	| KEYWORD "." -> err ()
+	| _ -> skip_to_rpar p (n+1) in
+      let rec skip_names n =
+	match get_tok (List.last (Stream.npeek n strm)) with
+        | IDENT _ | KEYWORD "_" -> skip_names (n+1)
+	| KEYWORD ":" -> skip_to_rpar 0 (n+1) (* skip a constr *)
+	| _ -> err () in
+      let rec skip_binders n =
+	match get_tok (List.last (Stream.npeek n strm)) with
+        | KEYWORD "(" -> skip_binders (skip_names (n+1))
+        | IDENT _ | KEYWORD "_" -> skip_binders (n+1)
+	| KEYWORD ":=" -> ()
+	| _ -> err () in
+      match get_tok (stream_nth 0 strm) with
+      | KEYWORD "(" -> skip_binders 2
+      | _ -> err ())
+
+let lookup_at_as_comma =
+  Gram.Entry.of_parser "lookup_at_as_comma"
+    (fun strm ->
+      match get_tok (stream_nth 0 strm) with
+	| KEYWORD (","|"at"|"as") -> ()
+	| _ -> err ())
+
+open Constr
+open Prim
+open Pltac
+
+let mk_fix_tac (loc,id,bl,ann,ty) =
+  let n =
+    match bl,ann with
+        [([_],_,_)], None -> 1
+      | _, Some x ->
+          let ids = List.map snd (List.flatten (List.map pi1 bl)) in
+          (try List.index Names.Name.equal (snd x) ids
+          with Not_found -> error "No such fix variable.")
+      | _ -> error "Cannot guess decreasing argument of fix." in
+  (id,n,CProdN(loc,bl,ty))
+
+let mk_cofix_tac (loc,id,bl,ann,ty) =
+  let _ = Option.map (fun (aloc,_) ->
+    user_err ~loc:aloc
+      ~hdr:"Constr:mk_cofix_tac"
+      (Pp.str"Annotation forbidden in cofix expression.")) ann in
+  (id,CProdN(loc,bl,ty))
+
+(* Functions overloaded by quotifier *)
+let destruction_arg_of_constr (c,lbind as clbind) = match lbind with
+  | NoBindings ->
+    begin
+      try ElimOnIdent (Constrexpr_ops.constr_loc c,snd(Constrexpr_ops.coerce_to_id c))
+      with e when CErrors.noncritical e -> ElimOnConstr clbind
+    end
+  | _ -> ElimOnConstr clbind
+
+let mkTacCase with_evar = function
+  | [(clear,ElimOnConstr cl),(None,None),None],None ->
+      TacCase (with_evar,(clear,cl))
+  (* Reinterpret numbers as a notation for terms *)
+  | [(clear,ElimOnAnonHyp n),(None,None),None],None ->
+      TacCase (with_evar,
+        (clear,(CPrim (Loc.ghost, Numeral (Bigint.of_int n)),
+	 NoBindings)))
+  (* Reinterpret ident as notations for variables in the context *)
+  (* because we don't know if they are quantified or not *)
+  | [(clear,ElimOnIdent id),(None,None),None],None ->
+      TacCase (with_evar,(clear,(CRef (Ident id,None),NoBindings)))
+  | ic ->
+      if List.exists (function ((_, ElimOnAnonHyp _),_,_) -> true | _ -> false) (fst ic)
+      then
+	error "Use of numbers as direct arguments of 'case' is not supported.";
+      TacInductionDestruct (false,with_evar,ic)
+
+let rec mkCLambdaN_simple_loc loc bll c =
+  match bll with
+  | ((loc1,_)::_ as idl,bk,t) :: bll ->
+      CLambdaN (loc,[idl,bk,t],mkCLambdaN_simple_loc (Loc.merge loc1 loc) bll c)
+  | ([],_,_) :: bll -> mkCLambdaN_simple_loc loc bll c
+  | [] -> c
+
+let mkCLambdaN_simple bl c = match bl with
+  | [] -> c
+  | h :: _ ->
+    let loc = Loc.merge (fst (List.hd (pi1 h))) (Constrexpr_ops.constr_loc c) in
+    mkCLambdaN_simple_loc loc bl c
+
+let loc_of_ne_list l = Loc.merge (fst (List.hd l)) (fst (List.last l))
+
+let map_int_or_var f = function
+  | ArgArg x -> ArgArg (f x)
+  | ArgVar _ as y -> y
+
+let all_concl_occs_clause = { onhyps=Some[]; concl_occs=AllOccurrences }
+
+let merge_occurrences loc cl = function
+  | None ->
+      if Locusops.clause_with_generic_occurrences cl then (None, cl)
+      else
+	user_err ~loc  (str "Found an \"at\" clause without \"with\" clause.")
+  | Some (occs, p) ->
+    let ans = match occs with
+    | AllOccurrences -> cl
+    | _ ->
+      begin match cl with
+      | { onhyps = Some []; concl_occs = AllOccurrences } ->
+        { onhyps = Some []; concl_occs = occs }
+      | { onhyps = Some [(AllOccurrences, id), l]; concl_occs = NoOccurrences } ->
+        { cl with onhyps = Some [(occs, id), l] }
+      | _ ->
+        if Locusops.clause_with_generic_occurrences cl then
+          user_err ~loc  (str "Unable to interpret the \"at\" clause; move it in the \"in\" clause.")
+        else
+          user_err ~loc  (str "Cannot use clause \"at\" twice.")
+      end
+    in
+    (Some p, ans)
+
+let warn_deprecated_eqn_syntax =
+  CWarnings.create ~name:"deprecated-eqn-syntax" ~category:"deprecated"
+         (fun arg -> strbrk (Printf.sprintf "Syntax \"_eqn:%s\" is deprecated. Please use \"eqn:%s\" instead." arg arg))
+
+(* Auxiliary grammar rules *)
+
+open Vernac_
+
+GEXTEND Gram
+  GLOBAL: simple_tactic constr_with_bindings quantified_hypothesis
+  bindings red_expr int_or_var open_constr uconstr
+  simple_intropattern in_clause clause_dft_concl hypident destruction_arg;
+
+  int_or_var:
+    [ [ n = integer  -> ArgArg n
+      | id = identref -> ArgVar id ] ]
+  ;
+  nat_or_var:
+    [ [ n = natural  -> ArgArg n
+      | id = identref -> ArgVar id ] ]
+  ;
+  (* An identifier or a quotation meta-variable *)
+  id_or_meta:
+    [ [ id = identref -> id ] ]
+  ;
+  open_constr:
+    [ [ c = constr -> c ] ]
+  ;
+  uconstr:
+    [ [ c = constr -> c ] ]
+  ;
+  destruction_arg:
+    [ [ n = natural -> (None,ElimOnAnonHyp n)
+      | test_lpar_id_rpar; c = constr_with_bindings ->
+        (Some false,destruction_arg_of_constr c)
+      | c = constr_with_bindings_arg -> on_snd destruction_arg_of_constr c
+    ] ]
+  ;
+  constr_with_bindings_arg:
+    [ [ ">"; c = constr_with_bindings -> (Some true,c)
+      | c = constr_with_bindings -> (None,c) ] ]
+  ;
+  quantified_hypothesis:
+    [ [ id = ident -> NamedHyp id
+      | n = natural -> AnonHyp n ] ]
+  ;
+  conversion:
+    [ [ c = constr -> (None, c)
+      | c1 = constr; "with"; c2 = constr -> (Some (AllOccurrences,c1),c2)
+      | c1 = constr; "at"; occs = occs_nums; "with"; c2 = constr ->
+          (Some (occs,c1), c2) ] ]
+  ;
+  occs_nums:
+    [ [ nl = LIST1 nat_or_var -> OnlyOccurrences nl
+      | "-"; n = nat_or_var; nl = LIST0 int_or_var ->
+	  (* have used int_or_var instead of nat_or_var for compatibility *)
+	   AllOccurrencesBut (List.map (map_int_or_var abs) (n::nl)) ] ]
+  ;
+  occs:
+    [ [ "at"; occs = occs_nums -> occs | -> AllOccurrences ] ]
+  ;
+  pattern_occ:
+    [ [ c = constr; nl = occs -> (nl,c) ] ]
+  ;
+  ref_or_pattern_occ:
+    (* If a string, it is interpreted as a ref
+       (anyway a Coq string does not reduce) *)
+    [ [ c = smart_global; nl = occs -> nl,Inl c
+      | c = constr; nl = occs -> nl,Inr c ] ]
+  ;
+  unfold_occ:
+    [ [ c = smart_global; nl = occs -> (nl,c) ] ]
+  ;
+  intropatterns:
+    [ [ l = LIST0 nonsimple_intropattern -> l ]]
+  ;
+  ne_intropatterns:
+    [ [ l = LIST1 nonsimple_intropattern -> l ]]
+  ;
+  or_and_intropattern:
+    [ [ "["; tc = LIST1 intropatterns SEP "|"; "]" -> IntroOrPattern tc
+      | "()" -> IntroAndPattern []
+      | "("; si = simple_intropattern; ")" -> IntroAndPattern [si]
+      | "("; si = simple_intropattern; ",";
+             tc = LIST1 simple_intropattern SEP "," ; ")" ->
+             IntroAndPattern (si::tc)
+      | "("; si = simple_intropattern; "&";
+	     tc = LIST1 simple_intropattern SEP "&" ; ")" ->
+	  (* (A & B & C) is translated into (A,(B,C)) *)
+	  let rec pairify = function
+	    | ([]|[_]|[_;_]) as l -> l
+	    | t::q -> [t;(loc_of_ne_list q,IntroAction (IntroOrAndPattern (IntroAndPattern (pairify q))))]
+	  in IntroAndPattern (pairify (si::tc)) ] ]
+  ;
+  equality_intropattern:
+    [ [ "->" -> IntroRewrite true
+      | "<-" -> IntroRewrite false
+      | "[="; tc = intropatterns; "]" -> IntroInjection tc ] ]
+  ;
+  naming_intropattern:
+    [ [ prefix = pattern_ident -> IntroFresh prefix
+      | "?" -> IntroAnonymous
+      | id = ident -> IntroIdentifier id ] ]
+  ;
+  nonsimple_intropattern:
+    [ [ l = simple_intropattern -> l
+      | "*" -> !@loc, IntroForthcoming true
+      | "**" -> !@loc, IntroForthcoming false ]]
+  ;
+  simple_intropattern:
+    [ [ pat = simple_intropattern_closed;
+        l = LIST0 ["%"; c = operconstr LEVEL "0" -> c] ->
+          let loc0,pat = pat in
+          let f c pat =
+            let loc1 = Constrexpr_ops.constr_loc c in
+            let loc = Loc.merge loc0 loc1 in
+            IntroAction (IntroApplyOn ((loc1,c),(loc,pat))) in
+          !@loc, List.fold_right f l pat ] ]
+  ;
+  simple_intropattern_closed:
+    [ [ pat = or_and_intropattern -> !@loc, IntroAction (IntroOrAndPattern pat)
+      | pat = equality_intropattern -> !@loc, IntroAction pat
+      | "_" -> !@loc, IntroAction IntroWildcard 
+      | pat = naming_intropattern -> !@loc, IntroNaming pat ] ]
+  ;
+  simple_binding:
+    [ [ "("; id = ident; ":="; c = lconstr; ")" -> (!@loc, NamedHyp id, c)
+      | "("; n = natural; ":="; c = lconstr; ")" -> (!@loc, AnonHyp n, c) ] ]
+  ;
+  bindings:
+    [ [ test_lpar_idnum_coloneq; bl = LIST1 simple_binding ->
+          ExplicitBindings bl
+      | bl = LIST1 constr -> ImplicitBindings bl ] ]
+  ;
+  constr_with_bindings:
+    [ [ c = constr; l = with_bindings -> (c, l) ] ]
+  ;
+  with_bindings:
+    [ [ "with"; bl = bindings -> bl | -> NoBindings ] ]
+  ;
+  red_flags:
+    [ [ IDENT "beta" -> [FBeta]
+      | IDENT "iota" -> [FMatch;FFix;FCofix]
+      | IDENT "match" -> [FMatch]
+      | IDENT "fix" -> [FFix]
+      | IDENT "cofix" -> [FCofix]
+      | IDENT "zeta" -> [FZeta]
+      | IDENT "delta"; d = delta_flag -> [d]
+    ] ]
+  ;
+  delta_flag:
+    [ [ "-"; "["; idl = LIST1 smart_global; "]" -> FDeltaBut idl
+      | "["; idl = LIST1 smart_global; "]" -> FConst idl
+      | -> FDeltaBut []
+    ] ]
+  ;
+  strategy_flag:
+    [ [ s = LIST1 red_flags -> Redops.make_red_flag (List.flatten s)
+      | d = delta_flag -> all_with d
+    ] ]
+  ;
+  red_expr:
+    [ [ IDENT "red" -> Red false
+      | IDENT "hnf" -> Hnf
+      | IDENT "simpl"; d = delta_flag; po = OPT ref_or_pattern_occ -> Simpl (all_with d,po)
+      | IDENT "cbv"; s = strategy_flag -> Cbv s
+      | IDENT "cbn"; s = strategy_flag -> Cbn s
+      | IDENT "lazy"; s = strategy_flag -> Lazy s
+      | IDENT "compute"; delta = delta_flag -> Cbv (all_with delta)
+      | IDENT "vm_compute"; po = OPT ref_or_pattern_occ -> CbvVm po
+      | IDENT "native_compute"; po = OPT ref_or_pattern_occ -> CbvNative po
+      | IDENT "unfold"; ul = LIST1 unfold_occ SEP "," -> Unfold ul
+      | IDENT "fold"; cl = LIST1 constr -> Fold cl
+      | IDENT "pattern"; pl = LIST1 pattern_occ SEP"," -> Pattern pl
+      | s = IDENT -> ExtraRedExpr s ] ]
+  ;
+  hypident:
+    [ [ id = id_or_meta ->
+          id,InHyp
+      | "("; IDENT "type"; IDENT "of"; id = id_or_meta; ")" ->
+	  id,InHypTypeOnly
+      | "("; IDENT "value"; IDENT "of"; id = id_or_meta; ")" ->
+	  id,InHypValueOnly
+    ] ]
+  ;
+  hypident_occ:
+    [ [ (id,l)=hypident; occs=occs -> ((occs,id),l) ] ]
+  ;
+  in_clause:
+    [ [ "*"; occs=occs ->
+          {onhyps=None; concl_occs=occs}
+      | "*"; "|-"; occs=concl_occ ->
+          {onhyps=None; concl_occs=occs}
+      | hl=LIST0 hypident_occ SEP","; "|-"; occs=concl_occ ->
+          {onhyps=Some hl; concl_occs=occs}
+      | hl=LIST0 hypident_occ SEP"," ->
+          {onhyps=Some hl; concl_occs=NoOccurrences} ] ]
+  ;
+  clause_dft_concl:
+    [ [ "in"; cl = in_clause -> cl
+      | occs=occs -> {onhyps=Some[]; concl_occs=occs}
+      | -> all_concl_occs_clause ] ]
+  ;
+  clause_dft_all:
+    [ [ "in"; cl = in_clause -> cl
+      | -> {onhyps=None; concl_occs=AllOccurrences} ] ]
+  ;
+  opt_clause:
+    [ [ "in"; cl = in_clause -> Some cl
+      | "at"; occs = occs_nums -> Some {onhyps=Some[]; concl_occs=occs}
+      | -> None ] ]
+  ;
+  concl_occ:
+    [ [ "*"; occs = occs -> occs
+      | -> NoOccurrences ] ]
+  ;
+  in_hyp_list:
+    [ [ "in"; idl = LIST1 id_or_meta -> idl
+      | -> [] ] ]
+  ;
+  in_hyp_as:
+    [ [ "in"; id = id_or_meta; ipat = as_ipat -> Some (id,ipat)
+      | -> None ] ]
+  ;
+  orient:
+    [ [ "->" -> true
+      | "<-" -> false
+      | -> true ]]
+  ;
+  simple_binder:
+    [ [ na=name -> ([na],Default Explicit,CHole (!@loc, Some (Evar_kinds.BinderType (snd na)), IntroAnonymous, None))
+      | "("; nal=LIST1 name; ":"; c=lconstr; ")" -> (nal,Default Explicit,c)
+    ] ]
+  ;
+  fixdecl:
+    [ [ "("; id = ident; bl=LIST0 simple_binder; ann=fixannot;
+        ":"; ty=lconstr; ")" -> (!@loc, id, bl, ann, ty) ] ]
+  ;
+  fixannot:
+    [ [ "{"; IDENT "struct"; id=name; "}" -> Some id
+      | -> None ] ]
+  ;
+  cofixdecl:
+    [ [ "("; id = ident; bl=LIST0 simple_binder; ":"; ty=lconstr; ")" ->
+        (!@loc, id, bl, None, ty) ] ]
+  ;
+  bindings_with_parameters:
+    [ [ check_for_coloneq; "(";  id = ident; bl = LIST0 simple_binder;
+        ":="; c = lconstr; ")" -> (id, mkCLambdaN_simple bl c) ] ]
+  ;
+  eliminator:
+    [ [ "using"; el = constr_with_bindings -> el ] ]
+  ;
+  as_ipat:
+    [ [ "as"; ipat = simple_intropattern -> Some ipat
+      | -> None ] ]
+  ;
+  or_and_intropattern_loc:
+    [ [ ipat = or_and_intropattern -> ArgArg (!@loc,ipat)
+      | locid = identref -> ArgVar locid ] ]
+  ;
+  as_or_and_ipat:
+    [ [ "as"; ipat = or_and_intropattern_loc -> Some ipat
+      | -> None ] ]
+  ;
+  eqn_ipat:
+    [ [ IDENT "eqn"; ":"; pat = naming_intropattern -> Some (!@loc, pat)
+      | IDENT "_eqn"; ":"; pat = naming_intropattern ->
+         let loc = !@loc in
+	 warn_deprecated_eqn_syntax ~loc "H"; Some (loc, pat)
+      | IDENT "_eqn" ->
+         let loc = !@loc in
+	 warn_deprecated_eqn_syntax ~loc "?"; Some (loc, IntroAnonymous)
+      | -> None ] ]
+  ;
+  as_name:
+    [ [ "as"; id = ident -> Names.Name id | -> Names.Anonymous ] ]
+  ;
+  by_tactic:
+    [ [ "by"; tac = tactic_expr LEVEL "3" -> Some tac
+    | -> None ] ]
+  ;
+  rewriter :
+    [ [ "!"; c = constr_with_bindings_arg -> (RepeatPlus,c)
+      | ["?"| LEFTQMARK]; c = constr_with_bindings_arg -> (RepeatStar,c)
+      | n = natural; "!"; c = constr_with_bindings_arg -> (Precisely n,c)
+      |	n = natural; ["?" | LEFTQMARK]; c = constr_with_bindings_arg -> (UpTo n,c)
+      | n = natural; c = constr_with_bindings_arg -> (Precisely n,c)
+      | c = constr_with_bindings_arg -> (Precisely 1, c)
+      ] ]
+  ;
+  oriented_rewriter :
+    [ [ b = orient; p = rewriter -> let (m,c) = p in (b,m,c) ] ]
+  ;
+  induction_clause:
+    [ [ c = destruction_arg; pat = as_or_and_ipat; eq = eqn_ipat;
+        cl = opt_clause -> (c,(eq,pat),cl) ] ]
+  ;
+  induction_clause_list:
+    [ [ ic = LIST1 induction_clause SEP ","; el = OPT eliminator;
+        cl_tolerance = opt_clause ->
+        (* Condition for accepting "in" at the end by compatibility *)
+        match ic,el,cl_tolerance with
+        | [c,pat,None],Some _,Some _ -> ([c,pat,cl_tolerance],el)
+        | _,_,Some _ -> err ()
+        | _,_,None -> (ic,el) ]]
+  ;
+  simple_tactic:
+    [ [
+      (* Basic tactics *)
+        IDENT "intros"; pl = ne_intropatterns ->
+          TacAtom (!@loc, TacIntroPattern (false,pl))
+      | IDENT "intros" ->
+          TacAtom (!@loc, TacIntroPattern (false,[!@loc,IntroForthcoming false]))
+      | IDENT "eintros"; pl = ne_intropatterns ->
+          TacAtom (!@loc, TacIntroPattern (true,pl))
+
+      | IDENT "apply"; cl = LIST1 constr_with_bindings_arg SEP ",";
+          inhyp = in_hyp_as -> TacAtom (!@loc, TacApply (true,false,cl,inhyp))
+      | IDENT "eapply"; cl = LIST1 constr_with_bindings_arg SEP ",";
+          inhyp = in_hyp_as -> TacAtom (!@loc, TacApply (true,true,cl,inhyp))
+      | IDENT "simple"; IDENT "apply";
+          cl = LIST1 constr_with_bindings_arg SEP ",";
+          inhyp = in_hyp_as -> TacAtom (!@loc, TacApply (false,false,cl,inhyp))
+      | IDENT "simple"; IDENT "eapply";
+          cl = LIST1 constr_with_bindings_arg SEP",";
+          inhyp = in_hyp_as -> TacAtom (!@loc, TacApply (false,true,cl,inhyp))
+      | IDENT "elim"; cl = constr_with_bindings_arg; el = OPT eliminator ->
+          TacAtom (!@loc, TacElim (false,cl,el))
+      | IDENT "eelim"; cl = constr_with_bindings_arg; el = OPT eliminator ->
+          TacAtom (!@loc, TacElim (true,cl,el))
+      | IDENT "case"; icl = induction_clause_list -> TacAtom (!@loc, mkTacCase false icl)
+      | IDENT "ecase"; icl = induction_clause_list -> TacAtom (!@loc, mkTacCase true icl)
+      | "fix"; id = ident; n = natural; "with"; fd = LIST1 fixdecl ->
+	  TacAtom (!@loc, TacMutualFix (id,n,List.map mk_fix_tac fd))
+      | "cofix"; id = ident; "with"; fd = LIST1 cofixdecl ->
+	  TacAtom (!@loc, TacMutualCofix (id,List.map mk_cofix_tac fd))
+
+      | IDENT "pose"; (id,b) = bindings_with_parameters ->
+	  TacAtom (!@loc, TacLetTac (Names.Name id,b,Locusops.nowhere,true,None))
+      | IDENT "pose"; b = constr; na = as_name ->
+	  TacAtom (!@loc, TacLetTac (na,b,Locusops.nowhere,true,None))
+      | IDENT "set"; (id,c) = bindings_with_parameters; p = clause_dft_concl ->
+	  TacAtom (!@loc, TacLetTac (Names.Name id,c,p,true,None))
+      | IDENT "set"; c = constr; na = as_name; p = clause_dft_concl ->
+          TacAtom (!@loc, TacLetTac (na,c,p,true,None))
+      | IDENT "remember"; c = constr; na = as_name; e = eqn_ipat;
+          p = clause_dft_all ->
+          TacAtom (!@loc, TacLetTac (na,c,p,false,e))
+
+      (* Alternative syntax for "pose proof c as id" *)
+      | IDENT "assert"; test_lpar_id_coloneq; "("; (loc,id) = identref; ":=";
+	  c = lconstr; ")" ->
+	  TacAtom (!@loc, TacAssert (true,None,Some (!@loc,IntroNaming (IntroIdentifier id)),c))
+
+      (* Alternative syntax for "assert c as id by tac" *)
+      | IDENT "assert"; test_lpar_id_colon; "("; (loc,id) = identref; ":";
+	  c = lconstr; ")"; tac=by_tactic ->
+	  TacAtom (!@loc, TacAssert (true,Some tac,Some (!@loc,IntroNaming (IntroIdentifier id)),c))
+
+      (* Alternative syntax for "enough c as id by tac" *)
+      | IDENT "enough"; test_lpar_id_colon; "("; (loc,id) = identref; ":";
+	  c = lconstr; ")"; tac=by_tactic ->
+	  TacAtom (!@loc, TacAssert (false,Some tac,Some (!@loc,IntroNaming (IntroIdentifier id)),c))
+
+      | IDENT "assert"; c = constr; ipat = as_ipat; tac = by_tactic ->
+	  TacAtom (!@loc, TacAssert (true,Some tac,ipat,c))
+      | IDENT "pose"; IDENT "proof"; c = lconstr; ipat = as_ipat ->
+	  TacAtom (!@loc, TacAssert (true,None,ipat,c))
+      | IDENT "enough"; c = constr; ipat = as_ipat; tac = by_tactic ->
+	  TacAtom (!@loc, TacAssert (false,Some tac,ipat,c))
+
+      | IDENT "generalize"; c = constr ->
+	  TacAtom (!@loc, TacGeneralize [((AllOccurrences,c),Names.Anonymous)])
+      | IDENT "generalize"; c = constr; l = LIST1 constr ->
+	  let gen_everywhere c = ((AllOccurrences,c),Names.Anonymous) in
+          TacAtom (!@loc, TacGeneralize (List.map gen_everywhere (c::l)))
+      | IDENT "generalize"; c = constr; lookup_at_as_comma; nl = occs;
+          na = as_name;
+          l = LIST0 [","; c = pattern_occ; na = as_name -> (c,na)] ->
+          TacAtom (!@loc, TacGeneralize (((nl,c),na)::l))
+
+      (* Derived basic tactics *)
+      | IDENT "induction"; ic = induction_clause_list ->
+	  TacAtom (!@loc, TacInductionDestruct (true,false,ic))
+      | IDENT "einduction"; ic = induction_clause_list ->
+	  TacAtom (!@loc, TacInductionDestruct(true,true,ic))
+      | IDENT "destruct"; icl = induction_clause_list ->
+	  TacAtom (!@loc, TacInductionDestruct(false,false,icl))
+      | IDENT "edestruct";  icl = induction_clause_list ->
+	  TacAtom (!@loc, TacInductionDestruct(false,true,icl))
+
+      (* Equality and inversion *)
+      | IDENT "rewrite"; l = LIST1 oriented_rewriter SEP ",";
+	  cl = clause_dft_concl; t=by_tactic -> TacAtom (!@loc, TacRewrite (false,l,cl,t))
+      | IDENT "erewrite"; l = LIST1 oriented_rewriter SEP ",";
+	  cl = clause_dft_concl; t=by_tactic -> TacAtom (!@loc, TacRewrite (true,l,cl,t))
+      | IDENT "dependent"; k =
+	  [ IDENT "simple"; IDENT "inversion" -> SimpleInversion
+	  | IDENT "inversion" -> FullInversion
+	  | IDENT "inversion_clear" -> FullInversionClear ];
+	  hyp = quantified_hypothesis;
+	  ids = as_or_and_ipat; co = OPT ["with"; c = constr -> c] ->
+	    TacAtom (!@loc, TacInversion (DepInversion (k,co,ids),hyp))
+      | IDENT "simple"; IDENT "inversion";
+	  hyp = quantified_hypothesis; ids = as_or_and_ipat;
+	  cl = in_hyp_list ->
+	    TacAtom (!@loc, TacInversion (NonDepInversion (SimpleInversion, cl, ids), hyp))
+      | IDENT "inversion";
+	  hyp = quantified_hypothesis; ids = as_or_and_ipat;
+	  cl = in_hyp_list ->
+	    TacAtom (!@loc, TacInversion (NonDepInversion (FullInversion, cl, ids), hyp))
+      | IDENT "inversion_clear";
+	  hyp = quantified_hypothesis; ids = as_or_and_ipat;
+	  cl = in_hyp_list ->
+	    TacAtom (!@loc, TacInversion (NonDepInversion (FullInversionClear, cl, ids), hyp))
+      | IDENT "inversion"; hyp = quantified_hypothesis;
+	  "using"; c = constr; cl = in_hyp_list ->
+	    TacAtom (!@loc, TacInversion (InversionUsing (c,cl), hyp))
+
+      (* Conversion *)
+      | IDENT "red"; cl = clause_dft_concl ->
+          TacAtom (!@loc, TacReduce (Red false, cl))
+      | IDENT "hnf"; cl = clause_dft_concl ->
+          TacAtom (!@loc, TacReduce (Hnf, cl))
+      | IDENT "simpl"; d = delta_flag; po = OPT ref_or_pattern_occ; cl = clause_dft_concl ->
+          TacAtom (!@loc, TacReduce (Simpl (all_with d, po), cl))
+      | IDENT "cbv"; s = strategy_flag; cl = clause_dft_concl ->
+          TacAtom (!@loc, TacReduce (Cbv s, cl))
+      | IDENT "cbn"; s = strategy_flag; cl = clause_dft_concl ->
+          TacAtom (!@loc, TacReduce (Cbn s, cl))
+      | IDENT "lazy"; s = strategy_flag; cl = clause_dft_concl ->
+          TacAtom (!@loc, TacReduce (Lazy s, cl))
+      | IDENT "compute"; delta = delta_flag; cl = clause_dft_concl ->
+          TacAtom (!@loc, TacReduce (Cbv (all_with delta), cl))
+      | IDENT "vm_compute"; po = OPT ref_or_pattern_occ; cl = clause_dft_concl ->
+          TacAtom (!@loc, TacReduce (CbvVm po, cl))
+      | IDENT "native_compute"; po = OPT ref_or_pattern_occ; cl = clause_dft_concl ->
+          TacAtom (!@loc, TacReduce (CbvNative po, cl))
+      | IDENT "unfold"; ul = LIST1 unfold_occ SEP ","; cl = clause_dft_concl ->
+          TacAtom (!@loc, TacReduce (Unfold ul, cl))
+      | IDENT "fold"; l = LIST1 constr; cl = clause_dft_concl ->
+          TacAtom (!@loc, TacReduce (Fold l, cl))
+      | IDENT "pattern"; pl = LIST1 pattern_occ SEP","; cl = clause_dft_concl ->
+          TacAtom (!@loc, TacReduce (Pattern pl, cl))
+
+      (* Change ne doit pas s'appliquer dans un Definition t := Eval ... *)
+      | IDENT "change"; (oc,c) = conversion; cl = clause_dft_concl ->
+	  let p,cl = merge_occurrences (!@loc) cl oc in
+	  TacAtom (!@loc, TacChange (p,c,cl))
+    ] ]
+  ;
+END;;
diff --git a/plugins/ltac/ltac_plugin.mlpack b/plugins/ltac/ltac_plugin.mlpack
new file mode 100644
index 000000000..af1c7149d
--- /dev/null
+++ b/plugins/ltac/ltac_plugin.mlpack
@@ -0,0 +1,27 @@
+Tacarg
+Pptactic
+Pltac
+Taccoerce
+Tacsubst
+Tacenv
+Tactic_debug
+Tacintern
+Tacentries
+Profile_ltac
+Tactic_matching
+Tacinterp
+Evar_tactics
+Tactic_option
+Extraargs
+G_obligations
+Coretactics
+Extratactics
+Profile_ltac_tactics
+G_auto
+G_class
+Rewrite
+G_rewrite
+Tauto
+G_eqdecide
+G_tactic
+G_ltac
diff --git a/plugins/ltac/pltac.ml b/plugins/ltac/pltac.ml
new file mode 100644
index 000000000..1d21118ae
--- /dev/null
+++ b/plugins/ltac/pltac.ml
@@ -0,0 +1,65 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+open Names
+open Pcoq
+
+(* Main entry for extensions *)
+let simple_tactic = Gram.entry_create "tactic:simple_tactic"
+
+let make_gen_entry _ name = Gram.entry_create ("tactic:" ^ name)
+
+(* Entries that can be referred via the string -> Gram.entry table *)
+(* Typically for tactic user extensions *)
+let open_constr =
+  make_gen_entry utactic "open_constr"
+let constr_with_bindings =
+  make_gen_entry utactic "constr_with_bindings"
+let bindings =
+  make_gen_entry utactic "bindings"
+let hypident = Gram.entry_create "hypident"
+let constr_may_eval = make_gen_entry utactic "constr_may_eval"
+let constr_eval = make_gen_entry utactic "constr_eval"
+let uconstr =
+  make_gen_entry utactic "uconstr"
+let quantified_hypothesis =
+  make_gen_entry utactic "quantified_hypothesis"
+let destruction_arg = make_gen_entry utactic "destruction_arg"
+let int_or_var = make_gen_entry utactic "int_or_var"
+let simple_intropattern =
+  make_gen_entry utactic "simple_intropattern"
+let in_clause = make_gen_entry utactic "in_clause"
+let clause_dft_concl = 
+  make_gen_entry utactic "clause"
+
+
+(* Main entries for ltac *)
+let tactic_arg = Gram.entry_create "tactic:tactic_arg"
+let tactic_expr = make_gen_entry utactic "tactic_expr"
+let binder_tactic = make_gen_entry utactic "binder_tactic"
+
+let tactic = make_gen_entry utactic "tactic"
+
+(* Main entry for quotations *)
+let tactic_eoi = eoi_entry tactic
+
+let () =
+  let open Stdarg in
+  let open Tacarg in
+  register_grammar wit_int_or_var (int_or_var);
+  register_grammar wit_intro_pattern (simple_intropattern);
+  register_grammar wit_quant_hyp (quantified_hypothesis);
+  register_grammar wit_uconstr (uconstr);
+  register_grammar wit_open_constr (open_constr);
+  register_grammar wit_constr_with_bindings (constr_with_bindings);
+  register_grammar wit_bindings (bindings);
+  register_grammar wit_tactic (tactic);
+  register_grammar wit_ltac (tactic);
+  register_grammar wit_clause_dft_concl (clause_dft_concl);
+  register_grammar wit_destruction_arg (destruction_arg);
+  ()
diff --git a/plugins/ltac/pltac.mli b/plugins/ltac/pltac.mli
new file mode 100644
index 000000000..810e1ec39
--- /dev/null
+++ b/plugins/ltac/pltac.mli
@@ -0,0 +1,38 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(** Ltac parsing entries *)
+
+open Loc
+open Names
+open Pcoq
+open Libnames
+open Constrexpr
+open Tacexpr
+open Genredexpr
+open Misctypes
+
+val open_constr : constr_expr Gram.entry
+val constr_with_bindings : constr_expr with_bindings Gram.entry
+val bindings : constr_expr bindings Gram.entry
+val hypident : (Id.t located * Locus.hyp_location_flag) Gram.entry
+val constr_may_eval : (constr_expr,reference or_by_notation,constr_expr) may_eval Gram.entry
+val constr_eval : (constr_expr,reference or_by_notation,constr_expr) may_eval Gram.entry
+val uconstr : constr_expr Gram.entry
+val quantified_hypothesis : quantified_hypothesis Gram.entry
+val destruction_arg : constr_expr with_bindings destruction_arg Gram.entry
+val int_or_var : int or_var Gram.entry
+val simple_tactic : raw_tactic_expr Gram.entry
+val simple_intropattern : constr_expr intro_pattern_expr located Gram.entry
+val in_clause : Names.Id.t Loc.located Locus.clause_expr Gram.entry
+val clause_dft_concl : Names.Id.t Loc.located Locus.clause_expr Gram.entry
+val tactic_arg : raw_tactic_arg Gram.entry
+val tactic_expr : raw_tactic_expr Gram.entry
+val binder_tactic : raw_tactic_expr Gram.entry
+val tactic : raw_tactic_expr Gram.entry
+val tactic_eoi : raw_tactic_expr Gram.entry
diff --git a/plugins/ltac/pptactic.ml b/plugins/ltac/pptactic.ml
new file mode 100644
index 000000000..39ae1f41d
--- /dev/null
+++ b/plugins/ltac/pptactic.ml
@@ -0,0 +1,1306 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+open Pp
+open Names
+open Namegen
+open CErrors
+open Util
+open Constrexpr
+open Tacexpr
+open Genarg
+open Geninterp
+open Stdarg
+open Tacarg
+open Libnames
+open Ppextend
+open Misctypes
+open Locus
+open Decl_kinds
+open Genredexpr
+open Pputils
+open Ppconstr
+open Printer
+
+module Tag =
+struct
+
+  let keyword   = "tactic.keyword"
+  let primitive = "tactic.primitive"
+  let string    = "tactic.string"
+
+end
+
+let tag t s = Pp.tag t s
+let do_not_tag _ x = x
+let tag_keyword                 = tag Tag.keyword
+let tag_primitive               = tag Tag.primitive
+let tag_string                  = tag Tag.string
+let tag_glob_tactic_expr        = do_not_tag
+let tag_glob_atomic_tactic_expr = do_not_tag
+let tag_raw_tactic_expr         = do_not_tag
+let tag_raw_atomic_tactic_expr  = do_not_tag
+let tag_atomic_tactic_expr      = do_not_tag
+
+let pr_global x = Nametab.pr_global_env Id.Set.empty x
+
+type 'a grammar_tactic_prod_item_expr =
+| TacTerm of string
+| TacNonTerm of Loc.t * 'a * Names.Id.t
+
+type grammar_terminals = Genarg.ArgT.any Extend.user_symbol grammar_tactic_prod_item_expr list
+
+type pp_tactic = {
+  pptac_level : int;
+  pptac_prods : grammar_terminals;
+}
+
+(* Tactic notations *)
+let prnotation_tab = Summary.ref ~name:"pptactic-notation" KNmap.empty
+
+let declare_notation_tactic_pprule kn pt =
+  prnotation_tab := KNmap.add kn pt !prnotation_tab
+
+type 'a raw_extra_genarg_printer =
+    (constr_expr -> std_ppcmds) ->
+    (constr_expr -> std_ppcmds) ->
+    (tolerability -> raw_tactic_expr -> std_ppcmds) ->
+    'a -> std_ppcmds
+
+type 'a glob_extra_genarg_printer =
+    (glob_constr_and_expr -> std_ppcmds) ->
+    (glob_constr_and_expr -> std_ppcmds) ->
+    (tolerability -> glob_tactic_expr -> std_ppcmds) ->
+    'a -> std_ppcmds
+
+type 'a extra_genarg_printer =
+    (EConstr.constr -> std_ppcmds) ->
+    (EConstr.constr -> std_ppcmds) ->
+    (tolerability -> Val.t -> std_ppcmds) ->
+    'a -> std_ppcmds
+
+  let keyword x = tag_keyword (str x)
+  let primitive x = tag_primitive (str x)
+
+  let has_type (Val.Dyn (tag, x)) t = match Val.eq tag t with
+  | None -> false
+  | Some _ -> true
+
+  let unbox : type a. Val.t -> a Val.typ -> a= fun (Val.Dyn (tag, x)) t ->
+  match Val.eq tag t with
+  | None -> assert false
+  | Some Refl -> x
+
+  let rec pr_value lev v : std_ppcmds =
+    if has_type v Val.typ_list then
+      pr_sequence (fun x -> pr_value lev x) (unbox v Val.typ_list)
+    else if has_type v Val.typ_opt then
+      pr_opt_no_spc (fun x -> pr_value lev x) (unbox v Val.typ_opt)
+    else if has_type v Val.typ_pair then
+      let (v1, v2) = unbox v Val.typ_pair in
+      str "(" ++ pr_value lev v1 ++ str ", " ++ pr_value lev v2 ++ str ")"
+    else
+      let Val.Dyn (tag, x) = v in
+      let name = Val.repr tag in
+      let default = str "<" ++ str name ++ str ">" in
+      match ArgT.name name with
+      | None -> default
+      | Some (ArgT.Any arg) ->
+        let wit = ExtraArg arg in
+        match val_tag (Topwit wit) with
+        | Val.Base t ->
+          begin match Val.eq t tag with
+          | None -> default
+          | Some Refl -> Genprint.generic_top_print (in_gen (Topwit wit) x)
+          end
+        | _ -> default
+
+  let pr_with_occurrences pr c = pr_with_occurrences pr keyword c
+  let pr_red_expr pr c = pr_red_expr pr keyword c
+
+  let pr_may_eval test prc prlc pr2 pr3 = function
+    | ConstrEval (r,c) ->
+      hov 0
+        (keyword "eval" ++ brk (1,1) ++
+           pr_red_expr (prc,prlc,pr2,pr3) r ++ spc () ++
+           keyword "in" ++ spc() ++ prc c)
+    | ConstrContext ((_,id),c) ->
+      hov 0
+        (keyword "context" ++ spc () ++ pr_id id ++ spc () ++
+           str "[ " ++ prlc c ++ str " ]")
+    | ConstrTypeOf c ->
+      hov 1 (keyword "type of" ++ spc() ++ prc c)
+    | ConstrTerm c when test c ->
+      h 0 (str "(" ++ prc c ++ str ")")
+    | ConstrTerm c ->
+      prc c
+
+  let pr_may_eval a =
+    pr_may_eval (fun _ -> false) a
+
+  let pr_arg pr x = spc () ++ pr x
+
+  let pr_and_short_name pr (c,_) = pr c
+
+  let pr_or_by_notation f = function
+    | AN v -> f v
+    | ByNotation (_,s,sc) -> qs s ++ pr_opt (fun sc -> str "%" ++ str sc) sc
+
+  let pr_located pr (loc,x) = pr x
+
+  let pr_evaluable_reference = function
+    | EvalVarRef id -> pr_id id
+    | EvalConstRef sp -> pr_global (Globnames.ConstRef sp)
+
+  let pr_quantified_hypothesis = function
+    | AnonHyp n -> int n
+    | NamedHyp id -> pr_id id
+
+  let pr_binding prc = function
+    | loc, NamedHyp id, c -> hov 1 (pr_id id ++ str " := " ++ cut () ++ prc c)
+    | loc, AnonHyp n, c -> hov 1 (int n ++ str " := " ++ cut () ++ prc c)
+
+  let pr_bindings prc prlc = function
+    | ImplicitBindings l ->
+      brk (1,1) ++ keyword "with" ++ brk (1,1) ++
+        hv 0 (prlist_with_sep spc prc l)
+    | ExplicitBindings l ->
+      brk (1,1) ++ keyword "with" ++ brk (1,1) ++
+        hv 0 (prlist_with_sep spc (fun b -> str"(" ++ pr_binding prlc b ++ str")") l)
+    | NoBindings -> mt ()
+
+  let pr_bindings_no_with prc prlc = function
+    | ImplicitBindings l ->
+      brk (0,1) ++
+        prlist_with_sep spc prc l
+    | ExplicitBindings l ->
+      brk (0,1) ++
+        prlist_with_sep spc (fun b -> str"(" ++ pr_binding prlc b ++ str")") l
+    | NoBindings -> mt ()
+
+  let pr_clear_flag clear_flag pp x =
+    match clear_flag with
+    | Some false -> surround (pp x)
+    | Some true -> str ">" ++ pp x
+    | None -> pp x
+
+  let pr_with_bindings prc prlc (c,bl) =
+    prc c ++ pr_bindings prc prlc bl
+
+  let pr_with_bindings_arg prc prlc (clear_flag,c) =
+    pr_clear_flag clear_flag (pr_with_bindings prc prlc) c
+
+  let pr_with_constr prc = function
+    | None -> mt ()
+    | Some c -> spc () ++ hov 1 (keyword "with" ++ spc () ++ prc c)
+
+  let pr_message_token prid = function
+    | MsgString s -> tag_string (qs s)
+    | MsgInt n -> int n
+    | MsgIdent id -> prid id
+
+  let pr_fresh_ids =
+    prlist (fun s -> spc() ++ pr_or_var (fun s -> tag_string (qs s)) s)
+
+  let with_evars ev s = if ev then "e" ^ s else s
+
+  let rec tacarg_using_rule_token pr_gen = function
+    | [] -> []
+    | TacTerm s :: l -> keyword s :: tacarg_using_rule_token pr_gen l
+    | TacNonTerm (_, (symb, arg), _) :: l  ->
+      pr_gen symb arg :: tacarg_using_rule_token pr_gen l
+
+  let pr_tacarg_using_rule pr_gen l =
+    let l = match l with
+    | TacTerm s :: l ->
+      (** First terminal token should be considered as the name of the tactic,
+          so we tag it differently than the other terminal tokens. *)
+      primitive s :: tacarg_using_rule_token pr_gen l
+    | _ -> tacarg_using_rule_token pr_gen l
+    in
+    pr_sequence (fun x -> x) l
+
+  let pr_extend_gen pr_gen lev { mltac_name = s; mltac_index = i } l =
+      let name =
+        str s.mltac_plugin ++ str "::" ++ str s.mltac_tactic ++
+        str "@" ++ int i
+      in
+      let args = match l with
+        | [] -> mt ()
+        | _ -> spc() ++ pr_sequence pr_gen l
+      in
+      str "<" ++ name ++ str ">" ++ args
+
+  let rec pr_user_symbol = function
+  | Extend.Ulist1 tkn -> "ne_" ^ pr_user_symbol tkn ^ "_list"
+  | Extend.Ulist1sep (tkn, _) -> "ne_" ^ pr_user_symbol tkn ^ "_list"
+  | Extend.Ulist0 tkn -> pr_user_symbol tkn ^ "_list"
+  | Extend.Ulist0sep (tkn, _) -> pr_user_symbol tkn ^ "_list"
+  | Extend.Uopt tkn -> pr_user_symbol tkn ^ "_opt"
+  | Extend.Uentry tag ->
+    let ArgT.Any tag = tag in
+    ArgT.repr tag
+  | Extend.Uentryl (tkn, lvl) -> "tactic" ^ string_of_int lvl
+
+  let pr_alias_key key =
+    try
+      let prods = (KNmap.find key !prnotation_tab).pptac_prods in
+      let rec pr = function
+      | TacTerm s -> primitive s
+      | TacNonTerm (_, symb, _) -> str (Printf.sprintf "(%s)" (pr_user_symbol symb))
+      in
+      pr_sequence pr prods
+    with Not_found ->
+      KerName.print key
+
+  let pr_alias_gen pr_gen lev key l =
+    try
+      let pp = KNmap.find key !prnotation_tab in
+      let rec pack prods args = match prods, args with
+      | [], [] -> []
+      | TacTerm s :: prods, args -> TacTerm s :: pack prods args
+      | TacNonTerm (loc, symb, id) :: prods, arg :: args ->
+        TacNonTerm (loc, (symb, arg), id) :: pack prods args
+      | _ -> raise Not_found
+      in
+      let prods = pack pp.pptac_prods l in
+      let p = pr_tacarg_using_rule pr_gen prods in
+      if pp.pptac_level > lev then surround p else p
+    with Not_found ->
+      let pr arg = str "_" in
+      KerName.print key ++ spc() ++ pr_sequence pr l ++ str" (* Generic printer *)"
+
+  let pr_farg prtac arg = prtac (1, Any) (TacArg (Loc.ghost, arg))
+
+  let is_genarg tag wit =
+    let ArgT.Any tag = tag in
+    argument_type_eq (ArgumentType (ExtraArg tag)) wit
+
+  let get_list : type l. l generic_argument -> l generic_argument list option =
+  function (GenArg (wit, arg)) -> match wit with
+  | Rawwit (ListArg wit) -> Some (List.map (in_gen (rawwit wit)) arg)
+  | Glbwit (ListArg wit) -> Some (List.map (in_gen (glbwit wit)) arg)
+  | _ -> None
+
+  let get_opt : type l. l generic_argument -> l generic_argument option option =
+  function (GenArg (wit, arg)) -> match wit with
+  | Rawwit (OptArg wit) -> Some (Option.map (in_gen (rawwit wit)) arg)
+  | Glbwit (OptArg wit) -> Some (Option.map (in_gen (glbwit wit)) arg)
+  | _ -> None
+
+  let rec pr_any_arg : type l. (_ -> l generic_argument -> std_ppcmds) -> _ -> l generic_argument -> std_ppcmds =
+  fun prtac symb arg -> match symb with
+  | Extend.Uentry tag when is_genarg tag (genarg_tag arg) -> prtac (1, Any) arg
+  | Extend.Ulist1 s | Extend.Ulist0 s ->
+    begin match get_list arg with
+    | None -> str "ltac:(" ++ prtac (1, Any) arg ++ str ")"
+    | Some l -> pr_sequence (pr_any_arg prtac s) l
+    end
+  | Extend.Ulist1sep (s, sep) | Extend.Ulist0sep (s, sep) ->
+    begin match get_list arg with
+    | None -> str "ltac:(" ++ prtac (1, Any) arg ++ str ")"
+    | Some l -> prlist_with_sep (fun () -> str sep) (pr_any_arg prtac s) l
+    end
+  | Extend.Uopt s ->
+    begin match get_opt arg with
+    | None -> str "ltac:(" ++ prtac (1, Any) arg ++ str ")"
+    | Some l -> pr_opt (pr_any_arg prtac s) l
+    end
+  | Extend.Uentry _ | Extend.Uentryl _ ->
+    str "ltac:(" ++ prtac (1, Any) arg ++ str ")"
+
+  let rec pr_targ prtac symb arg = match symb with
+  | Extend.Uentry tag when is_genarg tag (ArgumentType wit_tactic) ->
+    prtac (1, Any) arg
+  | Extend.Uentryl (_, l) -> prtac (l, Any) arg
+  | _ ->
+    match arg with
+    | TacGeneric arg ->
+      let pr l arg = prtac l (TacGeneric arg) in
+      pr_any_arg pr symb arg
+    | _ -> str "ltac:(" ++ prtac (1, Any) arg ++ str ")"
+
+  let pr_raw_extend_rec prc prlc prtac prpat =
+    pr_extend_gen (pr_farg prtac)
+  let pr_glob_extend_rec prc prlc prtac prpat =
+    pr_extend_gen (pr_farg prtac)
+
+  let pr_raw_alias prc prlc prtac prpat lev key args =
+    pr_alias_gen (pr_targ (fun l a -> prtac l (TacArg (Loc.ghost, a)))) lev key args
+  let pr_glob_alias prc prlc prtac prpat lev key args =
+    pr_alias_gen (pr_targ (fun l a -> prtac l (TacArg (Loc.ghost, a)))) lev key args
+
+  (**********************************************************************)
+  (* The tactic printer                                                 *)
+
+  let strip_prod_binders_expr n ty =
+    let rec strip_ty acc n ty =
+      match ty with
+          Constrexpr.CProdN(_,bll,a) ->
+            let nb =
+              List.fold_left (fun i (nal,_,_) -> i + List.length nal) 0 bll in
+            let bll = List.map (fun (x, _, y) -> x, y) bll in
+            if nb >= n then (List.rev (bll@acc)), a
+            else strip_ty (bll@acc) (n-nb) a
+        | _ -> error "Cannot translate fix tactic: not enough products" in
+    strip_ty [] n ty
+
+  let pr_ltac_or_var pr = function
+    | ArgArg x -> pr x
+    | ArgVar (loc,id) -> pr_with_comments loc (pr_id id)
+
+  let pr_ltac_constant kn =
+    if !Flags.in_debugger then pr_kn kn
+    else try
+           pr_qualid (Nametab.shortest_qualid_of_tactic kn)
+      with Not_found -> (* local tactic not accessible anymore *)
+        str "<" ++ pr_kn kn ++ str ">"
+
+  let pr_evaluable_reference_env env = function
+    | EvalVarRef id -> pr_id id
+    | EvalConstRef sp ->
+      Nametab.pr_global_env (Termops.vars_of_env env) (Globnames.ConstRef sp)
+
+  let pr_esubst prc l =
+    let pr_qhyp = function
+    (_,AnonHyp n,c) -> str "(" ++ int n ++ str" := " ++ prc c ++ str ")"
+      | (_,NamedHyp id,c) ->
+        str "(" ++ pr_id id ++ str" := " ++ prc c ++ str ")"
+    in
+    prlist_with_sep spc pr_qhyp l
+
+  let pr_bindings_gen for_ex prc prlc = function
+    | ImplicitBindings l ->
+      spc () ++
+        hv 2 ((if for_ex then mt() else keyword "with" ++ spc ()) ++
+                 prlist_with_sep spc prc l)
+    | ExplicitBindings l ->
+      spc () ++
+        hv 2 ((if for_ex then mt() else keyword "with" ++ spc ()) ++
+                 pr_esubst prlc l)
+    | NoBindings -> mt ()
+
+  let pr_bindings prc prlc = pr_bindings_gen false prc prlc
+
+  let pr_with_bindings prc prlc (c,bl) =
+    hov 1 (prc c ++ pr_bindings prc prlc bl)
+
+  let pr_as_disjunctive_ipat prc ipatl =
+    keyword "as" ++ spc () ++
+      pr_or_var (fun (loc,p) -> Miscprint.pr_or_and_intro_pattern prc p) ipatl
+
+  let pr_eqn_ipat (_,ipat) = keyword "eqn:" ++ Miscprint.pr_intro_pattern_naming ipat
+
+  let pr_with_induction_names prc = function
+    | None, None -> mt ()
+    | Some eqpat, None -> hov 1 (pr_eqn_ipat eqpat)
+    | None, Some ipat -> hov 1 (pr_as_disjunctive_ipat prc ipat)
+    | Some eqpat, Some ipat ->
+        hov 1 (pr_as_disjunctive_ipat prc ipat ++ spc () ++ pr_eqn_ipat eqpat)
+
+  let pr_as_intro_pattern prc ipat =
+    spc () ++ hov 1 (keyword "as" ++ spc () ++ Miscprint.pr_intro_pattern prc ipat)
+
+  let pr_with_inversion_names prc = function
+    | None -> mt ()
+    | Some ipat -> pr_as_disjunctive_ipat prc ipat
+
+  let pr_as_ipat prc = function
+    | None -> mt ()
+    | Some ipat -> pr_as_intro_pattern prc ipat
+
+  let pr_as_name = function
+    | Anonymous -> mt ()
+    | Name id -> spc () ++ keyword "as" ++ spc () ++ pr_lident (Loc.ghost,id)
+
+  let pr_pose_as_style prc na c =
+    spc() ++ prc c ++ pr_as_name na
+
+  let pr_pose prc prlc na c = match na with
+    | Anonymous -> spc() ++ prc c
+    | Name id -> spc() ++ surround (pr_id id ++ str " :=" ++ spc() ++ prlc c)
+
+  let pr_assertion prc prdc _prlc ipat c = match ipat with
+    (* Use this "optimisation" or use only the general case ?
+       | IntroIdentifier id ->
+       spc() ++ surround (pr_intro_pattern ipat ++ str " :" ++ spc() ++ prlc c)
+    *)
+    | ipat ->
+      spc() ++ prc c ++ pr_as_ipat prdc ipat
+
+  let pr_assumption prc prdc prlc ipat c = match ipat with
+    (* Use this "optimisation" or use only the general case ?*)
+    (* it seems that this "optimisation" is somehow more natural *)
+    | Some (_,IntroNaming (IntroIdentifier id)) ->
+      spc() ++ surround (pr_id id ++ str " :" ++ spc() ++ prlc c)
+    | ipat ->
+      spc() ++ prc c ++ pr_as_ipat prdc ipat
+
+  let pr_by_tactic prt = function
+    | Some tac -> keyword "by" ++ spc () ++ prt tac
+    | None -> mt()
+
+  let pr_hyp_location pr_id = function
+    | occs, InHyp -> pr_with_occurrences pr_id occs
+    | occs, InHypTypeOnly ->
+      pr_with_occurrences (fun id ->
+        str "(" ++ keyword "type of" ++ spc () ++ pr_id id ++ str ")"
+      ) occs
+    | occs, InHypValueOnly ->
+      pr_with_occurrences (fun id ->
+        str "(" ++ keyword "value of" ++ spc () ++ pr_id id ++ str ")"
+      ) occs
+
+  let pr_in pp = hov 0 (keyword "in" ++ pp)
+
+  let pr_simple_hyp_clause pr_id = function
+    | [] -> mt ()
+    | l -> pr_in (spc () ++ prlist_with_sep spc pr_id l)
+
+  let pr_in_hyp_as prc pr_id = function
+    | None -> mt ()
+    | Some (id,ipat) -> pr_in (spc () ++ pr_id id) ++ pr_as_ipat prc ipat
+
+  let pr_in_clause pr_id = function
+    | { onhyps=None; concl_occs=NoOccurrences } ->
+      (str "* |-")
+    | { onhyps=None; concl_occs=occs } ->
+      (pr_with_occurrences (fun () -> str "*") (occs,()))
+    | { onhyps=Some l; concl_occs=NoOccurrences } ->
+      prlist_with_sep (fun () -> str ", ") (pr_hyp_location pr_id) l
+    | { onhyps=Some l; concl_occs=occs } ->
+      let pr_occs = pr_with_occurrences (fun () -> str" |- *") (occs,()) in
+      (prlist_with_sep (fun () -> str", ") (pr_hyp_location pr_id) l ++ pr_occs)
+
+  let pr_clauses default_is_concl pr_id = function
+    | { onhyps=Some []; concl_occs=occs }
+        when (match default_is_concl with Some true -> true | _ -> false) ->
+      pr_with_occurrences mt (occs,())
+    | { onhyps=None; concl_occs=AllOccurrences }
+        when (match default_is_concl with Some false -> true | _ -> false) -> mt ()
+    | { onhyps=None; concl_occs=NoOccurrences } ->
+      pr_in (str " * |-")
+    | { onhyps=None; concl_occs=occs } ->
+      pr_in (pr_with_occurrences (fun () -> str " *") (occs,()))
+    | { onhyps=Some l; concl_occs=occs } ->
+      let pr_occs = match occs with
+        | NoOccurrences -> mt ()
+        | _ -> pr_with_occurrences (fun () -> str" |- *") (occs,())
+      in
+      pr_in
+        (prlist_with_sep (fun () -> str",")
+           (fun id -> spc () ++ pr_hyp_location pr_id id) l ++ pr_occs)
+
+  let pr_orient b = if b then mt () else str "<- "
+
+  let pr_multi = function
+    | Precisely 1 -> mt ()
+    | Precisely n -> int n ++ str "!"
+    | UpTo n -> int n ++ str "?"
+    | RepeatStar -> str "?"
+    | RepeatPlus -> str "!"
+
+  let pr_core_destruction_arg prc prlc = function
+    | ElimOnConstr c -> pr_with_bindings prc prlc c
+    | ElimOnIdent (loc,id) -> pr_with_comments loc (pr_id id)
+    | ElimOnAnonHyp n -> int n
+
+  let pr_destruction_arg prc prlc (clear_flag,h) =
+    pr_clear_flag clear_flag (pr_core_destruction_arg prc prlc) h
+                               
+  let pr_inversion_kind = function
+    | SimpleInversion -> primitive "simple inversion"
+    | FullInversion -> primitive "inversion"
+    | FullInversionClear -> primitive "inversion_clear"
+
+  let pr_range_selector (i, j) =
+    if Int.equal i j then int i
+    else int i ++ str "-" ++ int j
+
+  let pr_goal_selector = function
+    | SelectNth i -> int i ++ str ":"
+    | SelectList l -> str "[" ++ prlist_with_sep (fun () -> str ", ") pr_range_selector l ++
+        str "]" ++ str ":"
+    | SelectId id -> str "[" ++ Nameops.pr_id id ++ str "]" ++ str ":"
+    | SelectAll -> str "all" ++ str ":"
+
+  let pr_lazy = function
+    | General -> keyword "multi"
+    | Select -> keyword "lazy"
+    | Once -> mt ()
+
+  let pr_match_pattern pr_pat = function
+    | Term a -> pr_pat a
+    | Subterm (b,None,a) ->
+    (** ppedrot: we don't make difference between [appcontext] and [context]
+        anymore, and the interpretation is governed by a flag instead. *)
+      keyword "context" ++ str" [ " ++ pr_pat a ++ str " ]"
+    | Subterm (b,Some id,a) ->
+      keyword "context" ++ spc () ++ pr_id id ++ str "[ " ++ pr_pat a ++ str " ]"
+
+  let pr_match_hyps pr_pat = function
+    | Hyp (nal,mp) ->
+      pr_lname nal ++ str ":" ++ pr_match_pattern pr_pat mp
+    | Def (nal,mv,mp) ->
+      pr_lname nal ++ str ":=" ++ pr_match_pattern pr_pat mv
+      ++ str ":" ++ pr_match_pattern pr_pat mp
+
+  let pr_match_rule m pr pr_pat = function
+    | Pat ([],mp,t) when m ->
+      pr_match_pattern pr_pat mp ++
+        spc () ++ str "=>" ++ brk (1,4) ++ pr t
+    (*
+      | Pat (rl,mp,t) ->
+      hv 0 (prlist_with_sep pr_comma (pr_match_hyps pr_pat) rl ++
+      (if rl <> [] then spc () else mt ()) ++
+      hov 0 (str "|-" ++ spc () ++ pr_match_pattern pr_pat mp ++ spc () ++
+      str "=>" ++ brk (1,4) ++ pr t))
+    *)
+    | Pat (rl,mp,t) ->
+      hov 0 (
+        hv 0 (prlist_with_sep pr_comma (pr_match_hyps pr_pat) rl) ++
+          (if not (List.is_empty rl) then spc () else mt ()) ++
+          hov 0 (
+            str "|-" ++ spc () ++ pr_match_pattern pr_pat mp ++ spc () ++
+              str "=>" ++ brk (1,4) ++ pr t))
+    | All t -> str "_" ++ spc () ++ str "=>" ++ brk (1,4) ++ pr t
+
+  let pr_funvar n = spc () ++ pr_name n
+
+  let pr_let_clause k pr (id,(bl,t)) =
+    hov 0 (keyword k ++ spc () ++ pr_lident id ++ prlist pr_funvar bl ++
+             str " :=" ++ brk (1,1) ++ pr (TacArg (Loc.ghost,t)))
+
+  let pr_let_clauses recflag pr = function
+    | hd::tl ->
+      hv 0
+        (pr_let_clause (if recflag then "let rec" else "let") pr hd ++
+           prlist (fun t -> spc () ++ pr_let_clause "with" pr t) tl)
+    | [] -> anomaly (Pp.str "LetIn must declare at least one binding")
+
+  let pr_seq_body pr tl =
+    hv 0 (str "[ " ++
+            prlist_with_sep (fun () -> spc () ++ str "| ") pr tl ++
+            str " ]")
+
+  let pr_dispatch pr tl =
+    hv 0 (str "[>" ++
+            prlist_with_sep (fun () -> spc () ++ str "| ") pr tl ++
+            str " ]")
+
+  let pr_opt_tactic pr = function
+    | TacId [] -> mt ()
+    | t -> pr t
+
+  let pr_tac_extend_gen pr tf tm tl =
+    prvect_with_sep mt (fun t -> pr t ++ spc () ++ str "| ") tf ++
+      pr_opt_tactic pr tm ++ str ".." ++
+      prvect_with_sep mt (fun t -> spc () ++ str "| " ++ pr t) tl
+
+  let pr_then_gen pr tf tm tl =
+    hv 0 (str "[ " ++
+            pr_tac_extend_gen pr tf tm tl ++
+            str " ]")
+
+  let pr_tac_extend pr tf tm tl =
+    hv 0 (str "[>" ++
+            pr_tac_extend_gen pr tf tm tl ++
+            str " ]")
+
+  let pr_hintbases = function
+    | None -> keyword "with" ++ str" *"
+    | Some [] -> mt ()
+    | Some l -> hov 2 (keyword "with" ++ prlist (fun s -> spc () ++ str s) l)
+
+  let pr_auto_using prc = function
+    | [] -> mt ()
+    | l -> hov 2 (keyword "using" ++ spc () ++ prlist_with_sep pr_comma prc l)
+
+  let pr_then () = str ";"
+
+  let ltop = (5,E)
+  let lseq = 4
+  let ltactical = 3
+  let lorelse = 2
+  let llet = 5
+  let lfun = 5
+  let lcomplete = 1
+  let labstract = 3
+  let lmatch = 1
+  let latom = 0
+  let lcall = 1
+  let leval = 1
+  let ltatom = 1
+  let linfo = 5
+
+  let level_of (n,p) = match p with E -> n | L -> n-1 | Prec n -> n | Any -> lseq
+
+  (** A printer for tactics that polymorphically works on the three
+      "raw", "glob" and "typed" levels *)
+
+  type 'a printer = {
+    pr_tactic    : tolerability -> 'tacexpr -> std_ppcmds;
+    pr_constr    : 'trm -> std_ppcmds;
+    pr_lconstr   : 'trm -> std_ppcmds;
+    pr_dconstr   : 'dtrm -> std_ppcmds;
+    pr_pattern   : 'pat -> std_ppcmds;
+    pr_lpattern  : 'pat -> std_ppcmds;
+    pr_constant  : 'cst -> std_ppcmds;
+    pr_reference : 'ref -> std_ppcmds;
+    pr_name      : 'nam -> std_ppcmds;
+    pr_generic   : 'lev generic_argument -> std_ppcmds;
+    pr_extend    : int -> ml_tactic_entry -> 'a gen_tactic_arg list -> std_ppcmds;
+    pr_alias     : int -> KerName.t -> 'a gen_tactic_arg list -> std_ppcmds;
+  }
+
+  constraint 'a = <
+      term      :'trm;
+      dterm     :'dtrm;
+      pattern   :'pat;
+      constant  :'cst;
+      reference :'ref;
+      name      :'nam;
+      tacexpr   :'tacexpr;
+      level     :'lev
+    >
+
+    let pr_atom pr strip_prod_binders tag_atom =
+      let pr_with_bindings = pr_with_bindings pr.pr_constr pr.pr_lconstr in
+      let pr_with_bindings_arg_full = pr_with_bindings_arg in
+      let pr_with_bindings_arg = pr_with_bindings_arg pr.pr_constr pr.pr_lconstr in
+      let pr_red_expr = pr_red_expr (pr.pr_constr,pr.pr_lconstr,pr.pr_constant,pr.pr_pattern) in
+
+      let _pr_constrarg c = spc () ++ pr.pr_constr c in
+      let pr_lconstrarg c = spc () ++ pr.pr_lconstr c in
+      let pr_intarg n = spc () ++ int n in
+
+      (* Some printing combinators *)
+      let pr_eliminator cb = keyword "using" ++ pr_arg pr_with_bindings cb in
+
+      let pr_binder_fix (nal,t) =
+        (*  match t with
+            | CHole _ -> spc() ++ prlist_with_sep spc (pr_lname) nal
+            | _ ->*)
+        let s = prlist_with_sep spc pr_lname nal ++ str ":" ++ pr.pr_lconstr t in
+        spc() ++ hov 1 (str"(" ++ s ++ str")") in
+
+      let pr_fix_tac (id,n,c) =
+        let rec set_nth_name avoid n = function
+        (nal,ty)::bll ->
+          if n <= List.length nal then
+            match List.chop (n-1) nal with
+                _, (_,Name id) :: _ -> id, (nal,ty)::bll
+              | bef, (loc,Anonymous) :: aft ->
+                let id = next_ident_away (Id.of_string"y") avoid in
+                id, ((bef@(loc,Name id)::aft, ty)::bll)
+              | _ -> assert false
+          else
+            let (id,bll') = set_nth_name avoid (n-List.length nal) bll in
+            (id,(nal,ty)::bll')
+          | [] -> assert false in
+        let (bll,ty) = strip_prod_binders n c in
+        let names =
+          List.fold_left
+            (fun ln (nal,_) -> List.fold_left
+              (fun ln na -> match na with (_,Name id) -> id::ln | _ -> ln)
+              ln nal)
+            [] bll in
+        let idarg,bll = set_nth_name names n bll in
+        let annot = match names with
+          | [_] ->
+            mt ()
+          | _ ->
+            spc() ++ str"{"
+            ++ keyword "struct" ++ spc ()
+            ++ pr_id idarg ++ str"}"
+        in
+        hov 1 (str"(" ++ pr_id id ++
+                  prlist pr_binder_fix bll ++ annot ++ str" :" ++
+                  pr_lconstrarg ty ++ str")") in
+      (*  spc() ++
+          hov 0 (pr_id id ++ pr_intarg n ++ str":" ++ _pr_constrarg
+          c)
+      *)
+      let pr_cofix_tac (id,c) =
+        hov 1 (str"(" ++ pr_id id ++ str" :" ++ pr_lconstrarg c ++ str")") in
+
+      (* Printing tactics as arguments *)
+      let rec pr_atom0 a = tag_atom a (match a with
+        | TacIntroPattern (false,[]) -> primitive "intros"
+        | TacIntroPattern (true,[]) -> primitive "eintros"
+        | t -> str "(" ++ pr_atom1 t ++ str ")"
+      )
+
+      (* Main tactic printer *)
+      and pr_atom1 a = tag_atom a (match a with
+        (* Basic tactics *)
+        | TacIntroPattern (ev,[]) as t ->
+          pr_atom0 t
+        | TacIntroPattern (ev,(_::_ as p)) ->
+           hov 1 (primitive (if ev then "eintros" else "intros") ++ spc () ++
+                    prlist_with_sep spc (Miscprint.pr_intro_pattern pr.pr_dconstr) p)
+        | TacApply (a,ev,cb,inhyp) ->
+          hov 1 (
+            (if a then mt() else primitive "simple ") ++
+              primitive (with_evars ev "apply") ++ spc () ++
+              prlist_with_sep pr_comma pr_with_bindings_arg cb ++
+              pr_non_empty_arg (pr_in_hyp_as pr.pr_dconstr pr.pr_name) inhyp
+          )
+        | TacElim (ev,cb,cbo) ->
+          hov 1 (
+            primitive (with_evars ev "elim")
+            ++ pr_arg pr_with_bindings_arg cb
+            ++ pr_opt pr_eliminator cbo)
+        | TacCase (ev,cb) ->
+          hov 1 (primitive (with_evars ev "case") ++ spc () ++ pr_with_bindings_arg cb)
+        | TacMutualFix (id,n,l) ->
+          hov 1 (
+            primitive "fix" ++ spc () ++ pr_id id ++ pr_intarg n ++ spc()
+            ++ keyword "with" ++ spc () ++ prlist_with_sep spc pr_fix_tac l)
+        | TacMutualCofix (id,l) ->
+          hov 1 (
+            primitive "cofix" ++ spc () ++ pr_id id ++ spc()
+            ++ keyword "with" ++ spc () ++ prlist_with_sep spc pr_cofix_tac l
+          )
+        | TacAssert (b,Some tac,ipat,c) ->
+          hov 1 (
+            primitive (if b then "assert" else "enough") ++
+              pr_assumption pr.pr_constr pr.pr_dconstr pr.pr_lconstr ipat c ++
+              pr_non_empty_arg (pr_by_tactic (pr.pr_tactic (ltactical,E))) tac
+          )
+        | TacAssert (_,None,ipat,c) ->
+          hov 1 (
+            primitive "pose proof"
+            ++ pr_assertion pr.pr_constr pr.pr_dconstr pr.pr_lconstr ipat c
+          )
+        | TacGeneralize l ->
+          hov 1 (
+            primitive "generalize" ++ spc ()
+            ++ prlist_with_sep pr_comma (fun (cl,na) ->
+              pr_with_occurrences pr.pr_constr cl ++ pr_as_name na)
+              l
+          )
+        | TacLetTac (na,c,cl,true,_) when Locusops.is_nowhere cl ->
+          hov 1 (primitive "pose" ++ pr_pose pr.pr_constr pr.pr_lconstr na c)
+        | TacLetTac (na,c,cl,b,e) ->
+          hov 1 (
+            (if b then primitive "set" else primitive "remember") ++
+              (if b then pr_pose pr.pr_constr pr.pr_lconstr na c
+                else pr_pose_as_style pr.pr_constr na c) ++
+              pr_opt (fun p -> pr_eqn_ipat p ++ spc ()) e ++
+              pr_non_empty_arg (pr_clauses (Some b) pr.pr_name) cl)
+        (*  | TacInstantiate (n,c,ConclLocation ()) ->
+            hov 1 (str "instantiate" ++ spc() ++
+            hov 1 (str"(" ++ pr_arg int n ++ str" :=" ++
+            pr_lconstrarg c ++ str ")" ))
+            | TacInstantiate (n,c,HypLocation (id,hloc)) ->
+            hov 1 (str "instantiate" ++ spc() ++
+            hov 1 (str"(" ++ pr_arg int n ++ str" :=" ++
+            pr_lconstrarg c ++ str ")" )
+            ++ str "in" ++ pr_hyp_location pr.pr_name (id,[],(hloc,ref None)))
+        *)
+
+        (* Derived basic tactics *)
+        | TacInductionDestruct (isrec,ev,(l,el)) ->
+          hov 1 (
+            primitive (with_evars ev (if isrec then "induction" else "destruct"))
+            ++ spc ()
+            ++ prlist_with_sep pr_comma (fun (h,ids,cl) ->
+              pr_destruction_arg pr.pr_dconstr pr.pr_dconstr h ++
+                pr_non_empty_arg (pr_with_induction_names pr.pr_dconstr) ids ++
+                pr_opt (pr_clauses None pr.pr_name) cl) l ++
+              pr_opt pr_eliminator el
+          )
+
+        (* Conversion *)
+        | TacReduce (r,h) ->
+          hov 1 (
+            pr_red_expr r
+            ++ pr_non_empty_arg (pr_clauses (Some true) pr.pr_name) h
+          )
+        | TacChange (op,c,h) ->
+          hov 1 (
+            primitive "change" ++ brk (1,1)
+            ++ (
+              match op with
+                  None ->
+                    mt ()
+                | Some p ->
+                  pr.pr_pattern p ++ spc ()
+                  ++ keyword "with" ++ spc ()
+            ) ++ pr.pr_dconstr c ++ pr_non_empty_arg (pr_clauses (Some true) pr.pr_name) h
+          )
+
+        (* Equality and inversion *)
+        | TacRewrite (ev,l,cl,tac) ->
+          hov 1 (
+            primitive (with_evars ev "rewrite") ++ spc ()
+            ++ prlist_with_sep
+              (fun () -> str ","++spc())
+              (fun (b,m,c) ->
+                pr_orient b ++ pr_multi m ++
+                  pr_with_bindings_arg_full pr.pr_dconstr pr.pr_dconstr c)
+              l
+            ++ pr_non_empty_arg (pr_clauses (Some true) pr.pr_name) cl
+            ++ pr_non_empty_arg (pr_by_tactic (pr.pr_tactic (ltactical,E))) tac
+          )
+        | TacInversion (DepInversion (k,c,ids),hyp) ->
+          hov 1 (
+            primitive "dependent " ++ pr_inversion_kind k ++ spc ()
+            ++ pr_quantified_hypothesis hyp
+            ++ pr_with_inversion_names pr.pr_dconstr ids
+            ++ pr_with_constr pr.pr_constr c
+          )
+        | TacInversion (NonDepInversion (k,cl,ids),hyp) ->
+          hov 1 (
+            pr_inversion_kind k ++ spc ()
+            ++ pr_quantified_hypothesis hyp
+            ++ pr_non_empty_arg (pr_with_inversion_names pr.pr_dconstr) ids
+            ++ pr_non_empty_arg (pr_simple_hyp_clause pr.pr_name) cl
+          )
+        | TacInversion (InversionUsing (c,cl),hyp) ->
+          hov 1 (
+            primitive "inversion" ++ spc()
+            ++ pr_quantified_hypothesis hyp ++ spc ()
+            ++ keyword "using" ++ spc () ++ pr.pr_constr c
+            ++ pr_non_empty_arg (pr_simple_hyp_clause pr.pr_name) cl
+          )
+      )
+      in
+      pr_atom1
+
+    let make_pr_tac pr strip_prod_binders tag_atom tag =
+
+        let extract_binders = function
+          | Tacexp (TacFun (lvar,body)) -> (lvar,Tacexp body)
+          | body -> ([],body) in
+        let rec pr_tac inherited tac =
+          let return (doc, l) = (tag tac doc, l) in
+          let (strm, prec) = return (match tac with
+            | TacAbstract (t,None) ->
+              keyword "abstract " ++ pr_tac (labstract,L) t, labstract
+            | TacAbstract (t,Some s) ->
+              hov 0 (
+                keyword "abstract"
+                ++ str" (" ++ pr_tac (labstract,L) t ++ str")" ++ spc ()
+                ++ keyword "using" ++ spc () ++ pr_id s),
+              labstract
+            | TacLetIn (recflag,llc,u) ->
+              let llc = List.map (fun (id,t) -> (id,extract_binders t)) llc in
+              v 0
+                (hv 0 (
+                  pr_let_clauses recflag (pr_tac ltop) llc
+                  ++ spc () ++ keyword "in"
+                 ) ++ fnl () ++ pr_tac (llet,E) u),
+              llet
+            | TacMatch (lz,t,lrul) ->
+              hov 0 (
+                pr_lazy lz ++ keyword "match" ++ spc ()
+                ++ pr_tac ltop t ++ spc () ++ keyword "with"
+                ++ prlist (fun r ->
+                  fnl () ++ str "| "
+                  ++ pr_match_rule true (pr_tac ltop) pr.pr_lpattern r
+                ) lrul
+                ++ fnl() ++ keyword "end"),
+              lmatch
+            | TacMatchGoal (lz,lr,lrul) ->
+              hov 0 (
+                pr_lazy lz
+                ++ keyword (if lr then "match reverse goal with" else "match goal with")
+                ++ prlist (fun r ->
+                  fnl () ++ str "| "
+                  ++ pr_match_rule false (pr_tac ltop) pr.pr_lpattern r
+                ) lrul ++ fnl() ++ keyword "end"),
+              lmatch
+            | TacFun (lvar,body) ->
+              hov 2 (
+                keyword "fun"
+                ++ prlist pr_funvar lvar ++ str " =>" ++ spc ()
+                ++ pr_tac (lfun,E) body),
+              lfun
+            | TacThens (t,tl) ->
+              hov 1 (
+                pr_tac (lseq,E) t ++ pr_then () ++ spc ()
+                ++ pr_seq_body (pr_opt_tactic (pr_tac ltop)) tl),
+              lseq
+            | TacThen (t1,t2) ->
+              hov 1 (
+                pr_tac (lseq,E) t1 ++ pr_then () ++ spc ()
+                ++ pr_tac (lseq,L) t2),
+              lseq
+            | TacDispatch tl ->
+              pr_dispatch (pr_tac ltop) tl, lseq
+            | TacExtendTac (tf,t,tr) ->
+              pr_tac_extend (pr_tac ltop) tf t tr , lseq
+            | TacThens3parts (t1,tf,t2,tl) ->
+              hov 1 (
+                pr_tac (lseq,E) t1 ++ pr_then () ++ spc ()
+                ++ pr_then_gen (pr_tac ltop) tf t2 tl),
+              lseq
+            | TacTry t ->
+              hov 1 (
+                keyword "try" ++ spc () ++ pr_tac (ltactical,E) t),
+              ltactical
+            | TacDo (n,t) ->
+              hov 1 (
+                str "do" ++ spc ()
+                ++ pr_or_var int n ++ spc ()
+                ++ pr_tac (ltactical,E) t),
+              ltactical
+            | TacTimeout (n,t) ->
+              hov 1 (
+                keyword "timeout "
+                ++ pr_or_var int n ++ spc ()
+                ++ pr_tac (ltactical,E) t),
+              ltactical
+            | TacTime (s,t) ->
+              hov 1 (
+                keyword "time"
+                ++ pr_opt str s ++ spc ()
+                ++ pr_tac (ltactical,E) t),
+              ltactical
+            | TacRepeat t ->
+              hov 1 (
+                keyword "repeat" ++ spc ()
+                ++ pr_tac (ltactical,E) t),
+              ltactical
+            | TacProgress t ->
+              hov 1 (
+                keyword "progress" ++ spc ()
+                ++ pr_tac (ltactical,E) t),
+              ltactical
+            | TacShowHyps t ->
+              hov 1 (
+                keyword "infoH" ++ spc ()
+                ++ pr_tac (ltactical,E) t),
+              ltactical
+            | TacInfo t ->
+              hov 1 (
+                keyword "info" ++ spc ()
+                ++ pr_tac (ltactical,E) t),
+              linfo
+            | TacOr (t1,t2) ->
+              hov 1 (
+                pr_tac (lorelse,L) t1 ++ spc ()
+                ++ str "+" ++ brk (1,1)
+                ++ pr_tac (lorelse,E) t2),
+              lorelse
+            | TacOnce t ->
+              hov 1 (
+                keyword "once" ++ spc ()
+                ++ pr_tac (ltactical,E) t),
+              ltactical
+            | TacExactlyOnce t ->
+              hov 1 (
+                keyword "exactly_once" ++ spc ()
+                ++ pr_tac (ltactical,E) t),
+              ltactical
+            | TacIfThenCatch (t,tt,te) ->
+                hov 1 (
+                 str"tryif" ++ spc() ++ pr_tac (ltactical,E) t ++ brk(1,1) ++
+                 str"then" ++ spc() ++ pr_tac (ltactical,E) tt ++ brk(1,1) ++
+                 str"else" ++ spc() ++ pr_tac (ltactical,E) te ++ brk(1,1)),
+                ltactical
+            | TacOrelse (t1,t2) ->
+              hov 1 (
+                pr_tac (lorelse,L) t1 ++ spc ()
+                ++ str "||" ++ brk (1,1)
+                ++ pr_tac (lorelse,E) t2),
+              lorelse
+            | TacFail (g,n,l) ->
+              let arg =
+                match n with
+                  | ArgArg 0 -> mt ()
+                  | _ -> pr_arg (pr_or_var int) n
+              in
+              let name =
+                match g with
+                | TacGlobal -> keyword "gfail"
+                | TacLocal -> keyword "fail"
+              in
+              hov 1 (
+                name ++ arg
+                ++ prlist (pr_arg (pr_message_token pr.pr_name)) l),
+              latom
+            | TacFirst tl ->
+              keyword "first" ++ spc () ++ pr_seq_body (pr_tac ltop) tl, llet
+            | TacSolve tl ->
+              keyword "solve" ++ spc () ++ pr_seq_body (pr_tac ltop) tl, llet
+            | TacComplete t ->
+              pr_tac (lcomplete,E) t, lcomplete
+            | TacSelect (s, tac) -> pr_goal_selector s ++ spc () ++ pr_tac ltop tac, latom
+            | TacId l ->
+              keyword "idtac" ++ prlist (pr_arg (pr_message_token pr.pr_name)) l, latom
+            | TacAtom (loc,t) ->
+              pr_with_comments loc (hov 1 (pr_atom pr strip_prod_binders tag_atom t)), ltatom
+            | TacArg(_,Tacexp e) ->
+              pr.pr_tactic (latom,E) e, latom
+            | TacArg(_,ConstrMayEval (ConstrTerm c)) ->
+              keyword "constr:" ++ pr.pr_constr c, latom
+            | TacArg(_,ConstrMayEval c) ->
+              pr_may_eval pr.pr_constr pr.pr_lconstr pr.pr_constant pr.pr_pattern c, leval
+            | TacArg(_,TacFreshId l) ->
+              primitive "fresh" ++ pr_fresh_ids l, latom
+            | TacArg(_,TacGeneric arg) ->
+              pr.pr_generic arg, latom
+            | TacArg(_,TacCall(loc,f,[])) ->
+              pr.pr_reference f, latom
+            | TacArg(_,TacCall(loc,f,l)) ->
+              pr_with_comments loc (hov 1 (
+                pr.pr_reference f ++ spc ()
+                ++ prlist_with_sep spc pr_tacarg l)),
+              lcall
+            | TacArg (_,a) ->
+              pr_tacarg a, latom
+            | TacML (loc,s,l) ->
+              pr_with_comments loc (pr.pr_extend 1 s l), lcall
+            | TacAlias (loc,kn,l) ->
+              pr_with_comments loc (pr.pr_alias (level_of inherited) kn l), latom
+          )
+          in
+          if prec_less prec inherited then strm
+          else str"(" ++ strm ++ str")"
+
+        and pr_tacarg = function
+          | Reference r ->
+            pr.pr_reference r
+          | ConstrMayEval c ->
+            pr_may_eval pr.pr_constr pr.pr_lconstr pr.pr_constant pr.pr_pattern c
+          | TacFreshId l ->
+            keyword "fresh" ++ pr_fresh_ids l
+          | TacPretype c ->
+            keyword "type_term" ++ pr.pr_constr c
+          | TacNumgoals ->
+            keyword "numgoals"
+          | (TacCall _|Tacexp _ | TacGeneric _) as a ->
+            hov 0 (keyword "ltac:" ++ surround (pr_tac ltop (TacArg (Loc.ghost,a))))
+
+        in pr_tac
+
+  let strip_prod_binders_glob_constr n (ty,_) =
+    let rec strip_ty acc n ty =
+      if Int.equal n 0 then (List.rev acc, (ty,None)) else
+        match ty with
+            Glob_term.GProd(loc,na,Explicit,a,b) ->
+              strip_ty (([Loc.ghost,na],(a,None))::acc) (n-1) b
+          | _ -> error "Cannot translate fix tactic: not enough products" in
+    strip_ty [] n ty
+
+  let raw_printers =
+    (strip_prod_binders_expr)
+
+  let rec pr_raw_tactic_level n (t:raw_tactic_expr) =
+    let pr = {
+      pr_tactic = pr_raw_tactic_level;
+      pr_constr = pr_constr_expr;
+      pr_dconstr = pr_constr_expr;
+      pr_lconstr = pr_lconstr_expr;
+      pr_pattern = pr_constr_pattern_expr;
+      pr_lpattern = pr_lconstr_pattern_expr;
+      pr_constant = pr_or_by_notation pr_reference;
+      pr_reference = pr_reference;
+      pr_name = pr_lident;
+      pr_generic = (fun arg -> Pputils.pr_raw_generic (Global.env ()) arg);
+      pr_extend = pr_raw_extend_rec pr_constr_expr pr_lconstr_expr pr_raw_tactic_level pr_constr_pattern_expr;
+      pr_alias = pr_raw_alias pr_constr_expr pr_lconstr_expr pr_raw_tactic_level pr_constr_pattern_expr;
+    } in
+    make_pr_tac
+      pr raw_printers
+      tag_raw_atomic_tactic_expr tag_raw_tactic_expr
+      n t
+
+  let pr_raw_tactic = pr_raw_tactic_level ltop
+
+  let pr_and_constr_expr pr (c,_) = pr c
+
+  let pr_pat_and_constr_expr pr (_,(c,_),_) = pr c
+
+  let pr_glob_tactic_level env n t =
+    let glob_printers =
+      (strip_prod_binders_glob_constr)
+    in
+    let rec prtac n (t:glob_tactic_expr) =
+      let pr = {
+        pr_tactic = prtac;
+        pr_constr = pr_and_constr_expr (pr_glob_constr_env env);
+        pr_dconstr = pr_and_constr_expr (pr_glob_constr_env env);
+        pr_lconstr = pr_and_constr_expr (pr_lglob_constr_env env);
+        pr_pattern = pr_pat_and_constr_expr (pr_glob_constr_env env);
+        pr_lpattern = pr_pat_and_constr_expr (pr_lglob_constr_env env);
+        pr_constant = pr_or_var (pr_and_short_name (pr_evaluable_reference_env env));
+        pr_reference = pr_ltac_or_var (pr_located pr_ltac_constant);
+        pr_name = pr_lident;
+        pr_generic = (fun arg -> Pputils.pr_glb_generic (Global.env ()) arg);
+        pr_extend = pr_glob_extend_rec
+          (pr_and_constr_expr (pr_glob_constr_env env)) (pr_and_constr_expr (pr_lglob_constr_env env))
+          prtac (pr_pat_and_constr_expr (pr_glob_constr_env env));
+        pr_alias = pr_glob_alias
+          (pr_and_constr_expr (pr_glob_constr_env env)) (pr_and_constr_expr (pr_lglob_constr_env env))
+          prtac (pr_pat_and_constr_expr (pr_glob_constr_env env));
+      } in
+      make_pr_tac
+        pr glob_printers
+        tag_glob_atomic_tactic_expr tag_glob_tactic_expr
+        n t
+    in
+    prtac n t
+
+  let pr_glob_tactic env = pr_glob_tactic_level env ltop
+
+  let strip_prod_binders_constr n ty =
+    let ty = EConstr.Unsafe.to_constr ty in
+    let rec strip_ty acc n ty =
+      if n=0 then (List.rev acc, EConstr.of_constr ty) else
+        match Term.kind_of_term ty with
+            Term.Prod(na,a,b) ->
+              strip_ty (([Loc.ghost,na],EConstr.of_constr a)::acc) (n-1) b
+          | _ -> error "Cannot translate fix tactic: not enough products" in
+    strip_ty [] n ty
+
+  let pr_atomic_tactic_level env sigma n t =
+    let prtac n (t:atomic_tactic_expr) =
+      let pr = {
+        pr_tactic = (fun _ _ -> str "<tactic>");
+        pr_constr = (fun c -> pr_econstr_env env sigma c);
+        pr_dconstr = pr_and_constr_expr (pr_glob_constr_env env);
+        pr_lconstr = (fun c -> pr_leconstr_env env sigma c);
+        pr_pattern = pr_constr_pattern_env env sigma;
+        pr_lpattern = pr_lconstr_pattern_env env sigma;
+        pr_constant = pr_evaluable_reference_env env;
+        pr_reference = pr_located pr_ltac_constant;
+        pr_name = pr_id;
+        (** Those are not used by the atomic printer *)
+        pr_generic = (fun _ -> assert false);
+        pr_extend = (fun _ _ _ -> assert false);
+        pr_alias = (fun _ _ _ -> assert false);
+      }
+      in
+      pr_atom pr strip_prod_binders_constr tag_atomic_tactic_expr t
+    in
+    prtac n t
+
+  let pr_raw_generic = Pputils.pr_raw_generic
+
+  let pr_glb_generic = Pputils.pr_glb_generic
+
+  let pr_raw_extend env = pr_raw_extend_rec
+    pr_constr_expr pr_lconstr_expr pr_raw_tactic_level pr_constr_pattern_expr
+
+  let pr_glob_extend env = pr_glob_extend_rec
+    (pr_and_constr_expr (pr_glob_constr_env env)) (pr_and_constr_expr (pr_lglob_constr_env env))
+    (pr_glob_tactic_level env) (pr_pat_and_constr_expr (pr_glob_constr_env env))
+
+  let pr_alias pr lev key args =
+    pr_alias_gen (fun _ arg -> pr arg) lev key args
+
+  let pr_extend pr lev ml args =
+    pr_extend_gen pr lev ml args
+
+  let pr_atomic_tactic env sigma c = pr_atomic_tactic_level env sigma ltop c
+
+let declare_extra_genarg_pprule wit
+  (f : 'a raw_extra_genarg_printer)
+  (g : 'b glob_extra_genarg_printer)
+  (h : 'c extra_genarg_printer) =
+  begin match wit with
+    | ExtraArg s -> ()
+    | _          -> error "Can declare a pretty-printing rule only for extra argument types."
+  end;
+  let f x = f pr_constr_expr pr_lconstr_expr pr_raw_tactic_level x in
+  let g x =
+    let env = Global.env () in
+    g (pr_and_constr_expr (pr_glob_constr_env env)) (pr_and_constr_expr (pr_lglob_constr_env env)) (pr_glob_tactic_level env) x
+  in
+  let h x =
+    let env = Global.env () in
+    h (pr_econstr_env env Evd.empty) (pr_leconstr_env env Evd.empty) (fun _ _ -> str "<tactic>") x
+  in
+  Genprint.register_print0 wit f g h
+
+(** Registering *)
+
+let run_delayed c =
+  Sigma.run Evd.empty { Sigma.run = fun sigma -> c.delayed (Global.env ()) sigma }
+
+let run_delayed_destruction_arg = function (* HH: Using Evd.empty looks suspicious *)
+  | clear_flag,ElimOnConstr g -> clear_flag,ElimOnConstr (fst (run_delayed g))
+  | clear_flag,ElimOnAnonHyp n as x -> x
+  | clear_flag,ElimOnIdent id as x -> x
+
+let () =
+  let pr_bool b = if b then str "true" else str "false" in
+  let pr_unit _ = str "()" in
+  let pr_string s = str "\"" ++ str s ++ str "\"" in
+  Genprint.register_print0 wit_int_or_var
+    (pr_or_var int) (pr_or_var int) int;
+  Genprint.register_print0 wit_ref
+    pr_reference (pr_or_var (pr_located pr_global)) pr_global;
+  Genprint.register_print0 wit_ident
+    pr_id pr_id pr_id;
+  Genprint.register_print0 wit_var
+    (pr_located pr_id) (pr_located pr_id) pr_id;
+  Genprint.register_print0
+    wit_intro_pattern
+    (Miscprint.pr_intro_pattern pr_constr_expr)
+    (Miscprint.pr_intro_pattern (fun (c,_) -> pr_glob_constr c))
+    (Miscprint.pr_intro_pattern (fun c -> pr_econstr (fst (run_delayed c))));
+  Genprint.register_print0
+    wit_clause_dft_concl
+    (pr_clauses (Some true) pr_lident)
+    (pr_clauses (Some true) pr_lident)
+    (pr_clauses (Some true) (fun id -> pr_lident (Loc.ghost,id)))
+  ;
+  Genprint.register_print0
+    wit_constr
+    Ppconstr.pr_constr_expr
+    (fun (c, _) -> Printer.pr_glob_constr c)
+    Printer.pr_econstr
+  ;
+  Genprint.register_print0
+    wit_uconstr
+    Ppconstr.pr_constr_expr
+    (fun (c,_) -> Printer.pr_glob_constr c)
+    Printer.pr_closed_glob
+  ;
+  Genprint.register_print0
+    wit_open_constr
+    Ppconstr.pr_constr_expr
+    (fun (c, _) -> Printer.pr_glob_constr c)
+    Printer.pr_econstr
+  ;
+  Genprint.register_print0 wit_red_expr
+    (pr_red_expr (pr_constr_expr, pr_lconstr_expr, pr_or_by_notation pr_reference, pr_constr_pattern_expr))
+    (pr_red_expr (pr_and_constr_expr pr_glob_constr, pr_and_constr_expr pr_lglob_constr, pr_or_var (pr_and_short_name pr_evaluable_reference), pr_pat_and_constr_expr pr_glob_constr))
+    (pr_red_expr (pr_econstr, pr_leconstr, pr_evaluable_reference, pr_constr_pattern));
+  Genprint.register_print0 wit_quant_hyp pr_quantified_hypothesis pr_quantified_hypothesis pr_quantified_hypothesis;
+  Genprint.register_print0 wit_bindings
+    (pr_bindings_no_with pr_constr_expr pr_lconstr_expr)
+    (pr_bindings_no_with (pr_and_constr_expr pr_glob_constr) (pr_and_constr_expr pr_lglob_constr))
+    (fun it -> pr_bindings_no_with pr_econstr pr_leconstr (fst (run_delayed it)));
+  Genprint.register_print0 wit_constr_with_bindings
+    (pr_with_bindings pr_constr_expr pr_lconstr_expr)
+    (pr_with_bindings (pr_and_constr_expr pr_glob_constr) (pr_and_constr_expr pr_lglob_constr))
+    (fun it -> pr_with_bindings pr_econstr pr_leconstr (fst (run_delayed it)));
+  Genprint.register_print0 Tacarg.wit_destruction_arg
+    (pr_destruction_arg pr_constr_expr pr_lconstr_expr)
+    (pr_destruction_arg (pr_and_constr_expr pr_glob_constr) (pr_and_constr_expr pr_lglob_constr))
+    (fun it -> pr_destruction_arg pr_econstr pr_leconstr (run_delayed_destruction_arg it));
+  Genprint.register_print0 Stdarg.wit_int int int int;
+  Genprint.register_print0 Stdarg.wit_bool pr_bool pr_bool pr_bool;
+  Genprint.register_print0 Stdarg.wit_unit pr_unit pr_unit pr_unit;
+  Genprint.register_print0 Stdarg.wit_pre_ident str str str;
+  Genprint.register_print0 Stdarg.wit_string pr_string pr_string pr_string
+
+let () =
+  let printer _ _ prtac = prtac (0, E) in
+  declare_extra_genarg_pprule wit_tactic printer printer printer
+
+let () =
+  let pr_unit _ _ _ () = str "()" in
+  let printer _ _ prtac = prtac (0, E) in
+  declare_extra_genarg_pprule wit_ltac printer printer pr_unit
diff --git a/plugins/ltac/pptactic.mli b/plugins/ltac/pptactic.mli
new file mode 100644
index 000000000..729338fb9
--- /dev/null
+++ b/plugins/ltac/pptactic.mli
@@ -0,0 +1,121 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(** This module implements pretty-printers for tactic_expr syntactic
+    objects and their subcomponents. *)
+
+open Pp
+open Genarg
+open Geninterp
+open Names
+open Misctypes
+open Environ
+open Constrexpr
+open Tacexpr
+open Ppextend
+
+type 'a grammar_tactic_prod_item_expr =
+| TacTerm of string
+| TacNonTerm of Loc.t * 'a * Names.Id.t
+
+type 'a raw_extra_genarg_printer =
+    (constr_expr -> std_ppcmds) ->
+    (constr_expr -> std_ppcmds) ->
+    (tolerability -> raw_tactic_expr -> std_ppcmds) ->
+    'a -> std_ppcmds
+
+type 'a glob_extra_genarg_printer =
+    (glob_constr_and_expr -> std_ppcmds) ->
+    (glob_constr_and_expr -> std_ppcmds) ->
+    (tolerability -> glob_tactic_expr -> std_ppcmds) ->
+    'a -> std_ppcmds
+
+type 'a extra_genarg_printer =
+    (EConstr.t -> std_ppcmds) ->
+    (EConstr.t -> std_ppcmds) ->
+    (tolerability -> Val.t -> std_ppcmds) ->
+    'a -> std_ppcmds
+
+val declare_extra_genarg_pprule :
+  ('a, 'b, 'c) genarg_type ->
+  'a raw_extra_genarg_printer ->
+  'b glob_extra_genarg_printer ->
+  'c extra_genarg_printer -> unit
+
+type grammar_terminals = Genarg.ArgT.any Extend.user_symbol grammar_tactic_prod_item_expr list
+
+type pp_tactic = {
+  pptac_level : int;
+  pptac_prods : grammar_terminals;
+}
+
+val declare_notation_tactic_pprule : KerName.t -> pp_tactic -> unit
+
+val pr_with_occurrences :
+  ('a -> std_ppcmds) -> 'a Locus.with_occurrences -> std_ppcmds
+val pr_red_expr :
+  ('a -> std_ppcmds) * ('a -> std_ppcmds) * ('b -> std_ppcmds) * ('c -> std_ppcmds) ->
+  ('a,'b,'c) Genredexpr.red_expr_gen -> std_ppcmds
+val pr_may_eval :
+  ('a -> std_ppcmds) -> ('a -> std_ppcmds) -> ('b -> std_ppcmds) ->
+  ('c -> std_ppcmds) -> ('a,'b,'c) Genredexpr.may_eval -> std_ppcmds
+
+val pr_and_short_name : ('a -> std_ppcmds) -> 'a and_short_name -> std_ppcmds
+val pr_or_by_notation : ('a -> std_ppcmds) -> 'a or_by_notation -> std_ppcmds
+
+val pr_in_clause :
+  ('a -> Pp.std_ppcmds) -> 'a Locus.clause_expr -> Pp.std_ppcmds
+
+val pr_clauses :  bool option ->
+  ('a -> Pp.std_ppcmds) -> 'a Locus.clause_expr -> Pp.std_ppcmds
+
+val pr_raw_generic : env -> rlevel generic_argument -> std_ppcmds
+
+val pr_glb_generic : env -> glevel generic_argument -> std_ppcmds
+
+val pr_raw_extend: env -> int ->
+  ml_tactic_entry -> raw_tactic_arg list -> std_ppcmds
+
+val pr_glob_extend: env -> int ->
+  ml_tactic_entry -> glob_tactic_arg list -> std_ppcmds
+
+val pr_extend :
+  (Val.t -> std_ppcmds) -> int -> ml_tactic_entry -> Val.t list -> std_ppcmds
+
+val pr_alias_key : Names.KerName.t -> std_ppcmds
+
+val pr_alias : (Val.t -> std_ppcmds) ->
+  int -> Names.KerName.t -> Val.t list -> std_ppcmds
+
+val pr_ltac_constant : Nametab.ltac_constant -> std_ppcmds
+
+val pr_raw_tactic : raw_tactic_expr -> std_ppcmds
+
+val pr_raw_tactic_level : tolerability -> raw_tactic_expr -> std_ppcmds
+
+val pr_glob_tactic : env -> glob_tactic_expr -> std_ppcmds
+
+val pr_atomic_tactic : env -> Evd.evar_map -> atomic_tactic_expr -> std_ppcmds
+
+val pr_hintbases : string list option -> std_ppcmds
+
+val pr_auto_using : ('constr -> std_ppcmds) -> 'constr list -> std_ppcmds
+
+val pr_bindings :
+  ('constr -> std_ppcmds) ->
+  ('constr -> std_ppcmds) -> 'constr bindings -> std_ppcmds
+
+val pr_match_pattern : ('a -> std_ppcmds) -> 'a match_pattern -> std_ppcmds
+
+val pr_match_rule : bool -> ('a -> std_ppcmds) -> ('b -> std_ppcmds) ->
+  ('b, 'a) match_rule -> std_ppcmds
+
+val pr_value : tolerability -> Val.t -> std_ppcmds
+
+
+val ltop : tolerability
diff --git a/plugins/ltac/profile_ltac.ml b/plugins/ltac/profile_ltac.ml
new file mode 100644
index 000000000..58123f63e
--- /dev/null
+++ b/plugins/ltac/profile_ltac.ml
@@ -0,0 +1,420 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+open Unicode
+open Pp
+open Printer
+open Util
+
+module M = CString.Map
+
+(** [is_profiling] and the profiling info ([stack]) should be synchronized with
+    the document; the rest of the ref cells are either local to individual
+    tactic invocations, or global flags, and need not be synchronized, since no
+    document-level backtracking happens within tactics. We synchronize
+    is_profiling via an option. *)
+let is_profiling = Flags.profile_ltac
+
+let set_profiling b = is_profiling := b
+let get_profiling () = !is_profiling
+
+(** LtacProf cannot yet handle backtracking into multi-success tactics.
+    To properly support this, we'd have to somehow recreate our location in the
+    call-stack, and stop/restart the intervening timers. This is tricky and
+    possibly expensive, so instead we currently just emit a warning that
+    profiling results will be off. *)
+let encountered_multi_success_backtracking = ref false
+
+let warn_profile_backtracking =
+  CWarnings.create ~name:"profile-backtracking" ~category:"ltac"
+    (fun () -> strbrk "Ltac Profiler cannot yet handle backtracking \
+       into multi-success tactics; profiling results may be wildly inaccurate.")
+
+let warn_encountered_multi_success_backtracking () =
+  if !encountered_multi_success_backtracking then
+    warn_profile_backtracking ()
+
+let encounter_multi_success_backtracking () =
+  if not !encountered_multi_success_backtracking
+  then begin
+    encountered_multi_success_backtracking := true;
+    warn_encountered_multi_success_backtracking ()
+  end
+
+
+(* *************** tree data structure for profiling ****************** *)
+
+type treenode = {
+  name : M.key;
+  total : float;
+  local : float;
+  ncalls : int;
+  max_total : float;
+  children : treenode M.t
+}
+
+let empty_treenode name = {
+  name;
+  total = 0.0;
+  local = 0.0;
+  ncalls = 0;
+  max_total = 0.0;
+  children = M.empty;
+}
+
+let root = "root"
+
+module Local = Summary.Local
+
+let stack = Local.ref ~name:"LtacProf-stack" [empty_treenode root]
+
+let reset_profile_tmp () =
+  Local.(stack := [empty_treenode root]);
+  encountered_multi_success_backtracking := false
+
+(* ************** XML Serialization  ********************* *)
+
+let rec of_ltacprof_tactic (name, t) =
+  assert (String.equal name t.name);
+  let open Xml_datatype in
+  let total = string_of_float t.total in
+  let local = string_of_float t.local in
+  let ncalls = string_of_int t.ncalls in
+  let max_total = string_of_float t.max_total in
+  let children = List.map of_ltacprof_tactic (M.bindings t.children) in
+  Element ("ltacprof_tactic",
+    [ ("name", name); ("total",total); ("local",local);
+      ("ncalls",ncalls); ("max_total",max_total)],
+    children)
+
+let of_ltacprof_results t =
+  let open Xml_datatype in
+  assert(String.equal t.name root);
+  let children = List.map of_ltacprof_tactic (M.bindings t.children) in
+  Element ("ltacprof", [("total_time", string_of_float t.total)], children)
+
+let rec to_ltacprof_tactic m xml =
+  let open Xml_datatype in
+  match xml with
+  | Element ("ltacprof_tactic",
+     [("name", name); ("total",total); ("local",local);
+      ("ncalls",ncalls); ("max_total",max_total)], xs) ->
+      let node = {
+         name;
+         total = float_of_string total;
+         local = float_of_string local;
+         ncalls = int_of_string ncalls;
+         max_total = float_of_string max_total;
+         children = List.fold_left to_ltacprof_tactic M.empty xs;
+       } in
+      M.add name node m
+  | _ -> CErrors.anomaly Pp.(str "Malformed ltacprof_tactic XML")
+
+let to_ltacprof_results xml =
+  let open Xml_datatype in
+  match xml with
+  | Element ("ltacprof", [("total_time", t)], xs) ->
+     { name = root;
+       total = float_of_string t;
+       ncalls = 0;
+       max_total = 0.0;
+       local = 0.0;
+       children = List.fold_left to_ltacprof_tactic M.empty xs }
+  | _ -> CErrors.anomaly Pp.(str "Malformed ltacprof XML")
+
+let feedback_results results =
+  Feedback.(feedback
+    (Custom (Loc.dummy_loc, "ltacprof_results", of_ltacprof_results results)))
+
+(* ************** pretty printing ************************************* *)
+
+let format_sec x = (Printf.sprintf "%.3fs" x)
+let format_ratio x = (Printf.sprintf "%.1f%%" (100. *. x))
+let padl n s = ws (max 0 (n - utf8_length s)) ++ str s
+let padr n s = str s ++ ws (max 0 (n - utf8_length s))
+let padr_with c n s =
+  let ulength = utf8_length s in
+  str (utf8_sub s 0 n) ++ str (String.make (max 0 (n - ulength)) c)
+
+let rec list_iter_is_last f = function
+  | []      -> []
+  | [x]     -> [f true x]
+  | x :: xs -> f false x :: list_iter_is_last f xs
+
+let header =
+  str " tactic                                   local  total   calls       max " ++
+  fnl () ++
+  str "────────────────────────────────────────┴──────┴──────┴───────┴─────────┘" ++
+  fnl ()
+
+let rec print_node ~filter all_total indent prefix (s, e) =
+  h 0 (
+    padr_with '-' 40 (prefix ^ s ^ " ")
+    ++ padl 7 (format_ratio (e.local /. all_total))
+    ++ padl 7 (format_ratio (e.total /. all_total))
+    ++ padl 8 (string_of_int e.ncalls)
+    ++ padl 10 (format_sec (e.max_total))
+  ) ++
+  fnl () ++
+  print_table ~filter all_total indent false e.children
+
+and print_table ~filter all_total indent first_level table =
+  let fold _ n l =
+    let s, total = n.name, n.total in
+    if filter s total then (s, n) :: l else l in
+  let ls = M.fold fold table [] in
+  match ls with
+  | [s, n] when not first_level ->
+     v 0 (print_node ~filter all_total indent (indent ^ "â””") (s, n))
+  | _ ->
+    let ls =
+      List.sort (fun (_, { total = s1 }) (_, { total = s2}) ->
+                   compare s2 s1) ls in
+    let iter is_last =
+     let sep0 = if first_level then "" else if is_last then "  " else " │" in
+     let sep1 = if first_level then "─" else if is_last then " └─" else " ├─" in
+     print_node ~filter all_total (indent ^ sep0) (indent ^ sep1)
+    in
+    prlist (fun pr -> pr) (list_iter_is_last iter ls)
+
+let to_string ~filter ?(cutoff=0.0) node =
+  let tree = node.children in
+  let all_total = M.fold (fun _ { total } a -> total +. a) node.children 0.0 in
+  let flat_tree =
+    let global = ref M.empty in
+    let find_tactic tname l =
+      try M.find tname !global
+      with Not_found ->
+        let e = empty_treenode tname in
+        global := M.add tname e !global;
+        e in
+    let add_tactic tname stats = global := M.add tname stats !global in
+    let sum_stats add_total
+      { name; total = t1; local = l1; ncalls = n1; max_total = m1 }
+      {       total = t2; local = l2; ncalls = n2; max_total = m2 } = {
+          name;
+          total = if add_total then t1 +. t2 else t1;
+          local = l1 +. l2;
+          ncalls = n1 + n2;
+          max_total = if add_total then max m1 m2 else m1;
+          children = M.empty;
+      } in
+    let rec cumulate table =
+      let iter _ ({ name; children } as statistics) =
+        if filter name then begin
+          let stats' = find_tactic name global in
+          add_tactic name (sum_stats true stats' statistics);
+        end;
+        cumulate children
+      in
+      M.iter iter table
+    in
+    cumulate tree;
+    !global
+  in
+  warn_encountered_multi_success_backtracking ();
+  let filter s n = filter s && (all_total <= 0.0 || n /. all_total >= cutoff /. 100.0) in
+  let msg =
+    h 0 (str "total time: " ++ padl 11 (format_sec (all_total))) ++
+    fnl () ++
+    fnl () ++
+    header ++
+    print_table ~filter all_total "" true flat_tree ++
+    fnl () ++
+    header ++
+    print_table ~filter all_total "" true tree
+  in
+  msg
+
+(* ******************** profiling code ************************************** *)
+
+let get_child name node =
+  try M.find name node.children
+  with Not_found -> empty_treenode name
+
+let time () =
+  let times = Unix.times () in
+  times.Unix.tms_utime +. times.Unix.tms_stime
+
+let string_of_call ck =
+  let s =
+  string_of_ppcmds
+    (match ck with
+       | Tacexpr.LtacNotationCall s -> Pptactic.pr_alias_key s
+       | Tacexpr.LtacNameCall cst -> Pptactic.pr_ltac_constant cst
+       | Tacexpr.LtacVarCall (id, t) -> Nameops.pr_id id
+       | Tacexpr.LtacAtomCall te ->
+         (Pptactic.pr_glob_tactic (Global.env ())
+            (Tacexpr.TacAtom (Loc.ghost, te)))
+       | Tacexpr.LtacConstrInterp (c, _) ->
+         pr_glob_constr_env (Global.env ()) c
+       | Tacexpr.LtacMLCall te ->
+         (Pptactic.pr_glob_tactic (Global.env ())
+            te)
+    ) in
+  let s = String.map (fun c -> if c = '\n' then ' ' else c) s in
+  let s = try String.sub s 0 (CString.string_index_from s 0 "(*") with Not_found -> s in
+  CString.strip s
+
+let rec merge_sub_tree name tree acc =
+  try
+    let t = M.find name acc in
+    let t = {
+      name;
+      total = t.total +. tree.total;
+      ncalls = t.ncalls + tree.ncalls;
+      local = t.local +. tree.local;
+      max_total = max t.max_total tree.max_total;
+      children = M.fold merge_sub_tree tree.children t.children;
+    } in
+    M.add name t acc
+  with Not_found -> M.add name tree acc
+
+let merge_roots ?(disjoint=true) t1 t2 =
+  assert(String.equal t1.name t2.name);
+  { name = t1.name;
+    ncalls = t1.ncalls + t2.ncalls;
+    local = if disjoint then t1.local +. t2.local else t1.local;
+    total = if disjoint then t1.total +. t2.total else t1.total;
+    max_total = if disjoint then max t1.max_total t2.max_total else t1.max_total;
+    children =
+      M.fold merge_sub_tree t2.children t1.children }
+
+let rec find_in_stack what acc = function
+  | [] -> None
+  | { name } as x :: rest when String.equal name what -> Some(acc, x, rest)
+  | { name } as x :: rest -> find_in_stack what (x :: acc) rest
+
+let exit_tactic start_time c =
+  let diff = time () -. start_time in
+  match Local.(!stack) with
+  | [] | [_] ->
+    (* oops, our stack is invalid *)
+    encounter_multi_success_backtracking ();
+    reset_profile_tmp ()
+  | node :: (parent :: rest as full_stack) ->
+    let name = string_of_call c in
+    if not (String.equal name node.name) then
+      (* oops, our stack is invalid *)
+      encounter_multi_success_backtracking ();
+    let node = { node with
+      total = node.total +. diff;
+      local = node.local +. diff;
+      ncalls = node.ncalls + 1;
+      max_total = max node.max_total diff;
+    } in
+    (* updating the stack *)
+    let parent =
+      match find_in_stack node.name [] full_stack with
+      | None ->
+         (* no rec-call, we graft the subtree *)
+         let parent = { parent with
+           local = parent.local -. diff;
+           children = M.add node.name node parent.children } in
+         Local.(stack := parent :: rest);
+         parent
+      | Some(to_update, self, rest) ->
+         (* we coalesce the rec-call and update the lower stack *)
+         let self = merge_roots ~disjoint:false self node in
+         let updated_stack =
+           List.fold_left (fun s x ->
+             (try M.find x.name (List.hd s).children
+              with Not_found -> x) :: s) (self :: rest) to_update in
+         Local.(stack := updated_stack);
+         List.hd Local.(!stack)
+    in
+    (* Calls are over, we reset the stack and send back data *)
+    if rest == [] && get_profiling () then begin
+      assert(String.equal root parent.name);
+      reset_profile_tmp ();
+      feedback_results parent
+    end
+
+let tclFINALLY tac (finally : unit Proofview.tactic) =
+  let open Proofview.Notations in
+  Proofview.tclIFCATCH
+    tac
+    (fun v -> finally <*> Proofview.tclUNIT v)
+    (fun (exn, info) -> finally <*> Proofview.tclZERO ~info exn)
+
+let do_profile s call_trace tac =
+  let open Proofview.Notations in
+  Proofview.tclLIFT (Proofview.NonLogical.make (fun () ->
+  if !is_profiling then
+    match call_trace, Local.(!stack) with
+      | (_, c) :: _, parent :: rest ->
+        let name = string_of_call c in
+        let node = get_child name parent in
+        Local.(stack := node :: parent :: rest);
+        Some (time ())
+      | _ :: _, [] -> assert false
+      | _ -> None
+  else None)) >>= function
+  | Some start_time ->
+    tclFINALLY
+      tac
+      (Proofview.tclLIFT (Proofview.NonLogical.make (fun () ->
+        (match call_trace with
+        | (_, c) :: _ -> exit_tactic start_time c
+        | [] -> ()))))
+  | None -> tac
+
+(* ************** Accumulation of data from workers ************************* *)
+
+let get_local_profiling_results () = List.hd Local.(!stack)
+
+module SM = Map.Make(Stateid.Self)
+
+let data = ref SM.empty
+
+let _ =
+  Feedback.(add_feeder (function
+    | { id = State s; contents = Custom (_, "ltacprof_results", xml) } ->
+        let results = to_ltacprof_results xml in
+        let other_results = (* Multi success can cause this *)
+          try SM.find s !data
+          with Not_found -> empty_treenode root in
+        data := SM.add s (merge_roots results other_results) !data
+    | _ -> ()))
+
+let reset_profile () =
+  reset_profile_tmp ();
+  data := SM.empty
+
+(* ******************** *)
+
+let print_results_filter ~cutoff ~filter =
+  let valid id _ = Stm.state_of_id id <> `Expired in
+  data := SM.filter valid !data;
+  let results =
+    SM.fold (fun _ -> merge_roots ~disjoint:true) !data (empty_treenode root) in
+  let results = merge_roots results Local.(CList.last !stack) in
+  Feedback.msg_notice (to_string ~cutoff ~filter results)
+;;
+
+let print_results ~cutoff =
+  print_results_filter ~cutoff ~filter:(fun _ -> true)
+
+let print_results_tactic tactic =
+  print_results_filter ~cutoff:!Flags.profile_ltac_cutoff ~filter:(fun s ->
+    String.(equal tactic (sub (s ^ ".") 0 (min (1+length s) (length tactic)))))
+
+let do_print_results_at_close () =
+  if get_profiling () then print_results ~cutoff:!Flags.profile_ltac_cutoff
+
+let _ = Declaremods.append_end_library_hook do_print_results_at_close
+
+let _ =
+  let open Goptions in
+  declare_bool_option
+    { optsync  = true;
+      optdepr  = false;
+      optname  = "Ltac Profiling";
+      optkey   = ["Ltac"; "Profiling"];
+      optread  = get_profiling;
+      optwrite = set_profiling }
diff --git a/plugins/ltac/profile_ltac.mli b/plugins/ltac/profile_ltac.mli
new file mode 100644
index 000000000..e5e2e4197
--- /dev/null
+++ b/plugins/ltac/profile_ltac.mli
@@ -0,0 +1,48 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(** Ltac profiling primitives *)
+
+val do_profile :
+  string -> ('a * Tacexpr.ltac_call_kind) list ->
+    'b Proofview.tactic -> 'b Proofview.tactic
+
+val set_profiling : bool -> unit
+
+(* Cut off results < than specified cutoff *)
+val print_results : cutoff:float -> unit
+
+val print_results_tactic : string -> unit
+
+val reset_profile : unit -> unit
+
+val do_print_results_at_close : unit -> unit
+
+(* The collected statistics for a tactic. The timing data is collected over all
+ * instances of a given tactic from its parent. E.g. if tactic 'aaa' calls
+ * 'foo' twice, then 'aaa' will contain just one entry for 'foo' with the
+ * statistics of the two invocations combined, and also combined over all
+ * invocations of 'aaa'.
+ * total:     time spent running this tactic and its subtactics (seconds)
+ * local:      time spent running this tactic, minus its subtactics (seconds)
+ * ncalls: the number of invocations of this tactic that have been made
+ * max_total: the greatest running time of a single invocation (seconds)
+ *)
+type treenode = {
+  name : CString.Map.key;
+  total : float;
+  local : float;
+  ncalls : int;
+  max_total : float;
+  children : treenode CString.Map.t
+}
+
+(* Returns the profiling results known by the current process *)
+val get_local_profiling_results : unit -> treenode
+val feedback_results : treenode -> unit
+
diff --git a/plugins/ltac/profile_ltac_tactics.ml4 b/plugins/ltac/profile_ltac_tactics.ml4
new file mode 100644
index 000000000..8cb76d81c
--- /dev/null
+++ b/plugins/ltac/profile_ltac_tactics.ml4
@@ -0,0 +1,40 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i camlp4deps: "grammar/grammar.cma" i*)
+
+(** Ltac profiling entrypoints *)
+
+open Profile_ltac
+open Stdarg
+
+DECLARE PLUGIN "profile_ltac_plugin"
+
+let tclSET_PROFILING b =
+   Proofview.tclLIFT (Proofview.NonLogical.make (fun () -> set_profiling b))
+
+TACTIC EXTEND start_ltac_profiling
+| [ "start" "ltac" "profiling" ] -> [ tclSET_PROFILING true ]
+END
+
+TACTIC EXTEND stop_profiling
+| [ "stop" "ltac" "profiling" ] -> [ tclSET_PROFILING false ]
+END
+
+VERNAC COMMAND EXTEND ResetLtacProfiling CLASSIFIED AS SIDEFF
+  [ "Reset" "Ltac" "Profile" ] -> [ reset_profile() ]
+END
+
+VERNAC COMMAND EXTEND ShowLtacProfile CLASSIFIED AS QUERY
+| [ "Show" "Ltac" "Profile" ] -> [ print_results ~cutoff:!Flags.profile_ltac_cutoff ]
+| [ "Show" "Ltac" "Profile" "CutOff" int(n) ] -> [ print_results ~cutoff:(float_of_int n) ]
+END
+
+VERNAC COMMAND EXTEND ShowLtacProfileTactic CLASSIFIED AS QUERY
+  [ "Show" "Ltac" "Profile" string(s) ] -> [ print_results_tactic s ]
+END
diff --git a/plugins/ltac/rewrite.ml b/plugins/ltac/rewrite.ml
new file mode 100644
index 000000000..55172cba6
--- /dev/null
+++ b/plugins/ltac/rewrite.ml
@@ -0,0 +1,2237 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+open Names
+open Pp
+open CErrors
+open Util
+open Nameops
+open Namegen
+open Term
+open EConstr
+open Vars
+open Reduction
+open Tacticals.New
+open Tacmach
+open Tactics
+open Pretype_errors
+open Typeclasses
+open Classes
+open Constrexpr
+open Globnames
+open Evd
+open Misctypes
+open Locus
+open Locusops
+open Decl_kinds
+open Elimschemes
+open Environ
+open Termops
+open EConstr
+open Libnames
+open Sigma.Notations
+open Proofview.Notations
+open Context.Named.Declaration
+
+module NamedDecl = Context.Named.Declaration
+module RelDecl = Context.Rel.Declaration
+
+(** Typeclass-based generalized rewriting. *)
+
+(** Constants used by the tactic. *)
+
+let classes_dirpath =
+  Names.DirPath.make (List.map Id.of_string ["Classes";"Coq"])
+
+let init_relation_classes () =
+  if is_dirpath_prefix_of classes_dirpath (Lib.cwd ()) then ()
+  else Coqlib.check_required_library ["Coq";"Classes";"RelationClasses"]
+
+let init_setoid () =
+  if is_dirpath_prefix_of classes_dirpath (Lib.cwd ()) then ()
+  else Coqlib.check_required_library ["Coq";"Setoids";"Setoid"]
+
+let make_dir l = DirPath.make (List.rev_map Id.of_string l)
+
+let try_find_global_reference dir s =
+  let sp = Libnames.make_path (make_dir ("Coq"::dir)) (Id.of_string s) in
+    try Nametab.global_of_path sp
+    with Not_found -> 
+      anomaly (str "Global reference " ++ str s ++ str " not found in generalized rewriting")
+
+let find_reference dir s =
+  let gr = lazy (try_find_global_reference dir s) in
+    fun () -> Lazy.force gr
+
+type evars = evar_map * Evar.Set.t (* goal evars, constraint evars *)
+
+let find_global dir s =
+  let gr = lazy (try_find_global_reference dir s) in
+    fun (evd,cstrs) ->
+      let sigma = Sigma.Unsafe.of_evar_map evd in
+      let Sigma (c, sigma, _) = Evarutil.new_global sigma (Lazy.force gr) in
+      let evd = Sigma.to_evar_map sigma in
+	(evd, cstrs), c
+
+(** Utility for dealing with polymorphic applications *)
+
+(** Global constants. *)
+
+let coq_eq_ref = find_reference ["Init"; "Logic"] "eq"
+let coq_eq = find_global ["Init"; "Logic"] "eq"
+let coq_f_equal = find_global ["Init"; "Logic"] "f_equal"
+let coq_all = find_global ["Init"; "Logic"] "all"
+let impl = find_global ["Program"; "Basics"] "impl"
+
+(** Bookkeeping which evars are constraints so that we can 
+    remove them at the end of the tactic. *)
+
+let goalevars evars = fst evars
+let cstrevars evars = snd evars
+
+let new_cstr_evar (evd,cstrs) env t =
+  let s = Typeclasses.set_resolvable Evd.Store.empty false in
+  let evd = Sigma.Unsafe.of_evar_map evd in
+  let Sigma (t, evd', _) = Evarutil.new_evar ~store:s env evd t in
+  let evd' = Sigma.to_evar_map evd' in
+  let ev, _ = destEvar evd' t in
+    (evd', Evar.Set.add ev cstrs), t
+
+(** Building or looking up instances. *)
+let e_new_cstr_evar env evars t =
+  let evd', t = new_cstr_evar !evars env t in evars := evd'; t
+
+(** Building or looking up instances. *)
+
+let extends_undefined evars evars' =
+  let f ev evi found = found || not (Evd.mem evars ev)
+  in fold_undefined f evars' false
+
+let app_poly_check env evars f args =
+  let (evars, cstrs), fc = f evars in
+  let evdref = ref evars in 
+  let t = Typing.e_solve_evars env evdref (mkApp (fc, args)) in
+    (!evdref, cstrs), t
+
+let app_poly_nocheck env evars f args =
+  let evars, fc = f evars in 
+    evars, mkApp (fc, args)
+
+let app_poly_sort b =
+  if b then app_poly_nocheck
+  else app_poly_check
+    
+let find_class_proof proof_type proof_method env evars carrier relation =
+  try
+    let evars, goal = app_poly_check env evars proof_type [| carrier ; relation |] in
+    let evars', c = Typeclasses.resolve_one_typeclass env (goalevars evars) goal in
+      if extends_undefined (goalevars evars) evars' then raise Not_found
+      else app_poly_check env (evars',cstrevars evars) proof_method [| carrier; relation; c |]
+  with e when Logic.catchable_exception e -> raise Not_found
+ 
+(** Utility functions *)
+
+module GlobalBindings (M : sig
+  val relation_classes : string list
+  val morphisms : string list
+  val relation : string list * string
+  val app_poly : env -> evars -> (evars -> evars * constr) -> constr array -> evars * constr
+  val arrow : evars -> evars * constr
+end) = struct
+  open M
+  open Context.Rel.Declaration
+  let relation : evars -> evars * constr = find_global (fst relation) (snd relation)
+
+  let reflexive_type = find_global relation_classes "Reflexive"
+  let reflexive_proof = find_global relation_classes "reflexivity"
+    
+  let symmetric_type = find_global relation_classes "Symmetric"
+  let symmetric_proof = find_global relation_classes "symmetry"
+
+  let transitive_type = find_global relation_classes "Transitive"
+  let transitive_proof = find_global relation_classes "transitivity"
+
+  let forall_relation = find_global morphisms "forall_relation"
+  let pointwise_relation = find_global morphisms "pointwise_relation"
+
+  let forall_relation_ref = find_reference morphisms "forall_relation"
+  let pointwise_relation_ref = find_reference morphisms "pointwise_relation"
+
+  let respectful = find_global morphisms "respectful"
+  let respectful_ref = find_reference morphisms "respectful"
+
+  let default_relation = find_global ["Classes"; "SetoidTactics"] "DefaultRelation"
+
+  let coq_forall = find_global morphisms "forall_def"
+
+  let subrelation = find_global relation_classes "subrelation"
+  let do_subrelation = find_global morphisms "do_subrelation"
+  let apply_subrelation = find_global morphisms "apply_subrelation"
+
+  let rewrite_relation_class = find_global relation_classes "RewriteRelation"
+
+  let proper_class = lazy (class_info (try_find_global_reference morphisms "Proper"))
+  let proper_proxy_class = lazy (class_info (try_find_global_reference morphisms "ProperProxy"))
+    
+  let proper_proj = lazy (mkConst (Option.get (pi3 (List.hd (Lazy.force proper_class).cl_projs))))
+    
+  let proper_type = 
+    let l = lazy (Lazy.force proper_class).cl_impl in
+      fun (evd,cstrs) -> 
+        let sigma = Sigma.Unsafe.of_evar_map evd in
+        let Sigma (c, sigma, _) = Evarutil.new_global sigma (Lazy.force l) in
+        let evd = Sigma.to_evar_map sigma in
+	  (evd, cstrs), c
+	
+  let proper_proxy_type = 
+    let l = lazy (Lazy.force proper_proxy_class).cl_impl in
+      fun (evd,cstrs) -> 
+        let sigma = Sigma.Unsafe.of_evar_map evd in
+        let Sigma (c, sigma, _) = Evarutil.new_global sigma (Lazy.force l) in
+        let evd = Sigma.to_evar_map sigma in
+	  (evd, cstrs), c
+
+  let proper_proof env evars carrier relation x =
+    let evars, goal = app_poly env evars proper_proxy_type [| carrier ; relation; x |] in
+      new_cstr_evar evars env goal
+
+  let get_reflexive_proof env = find_class_proof reflexive_type reflexive_proof env
+  let get_symmetric_proof env = find_class_proof symmetric_type symmetric_proof env
+  let get_transitive_proof env = find_class_proof transitive_type transitive_proof env
+
+  let mk_relation env evd a = 
+    app_poly env evd relation [| a |]
+
+  (** Build an infered signature from constraints on the arguments and expected output
+      relation *)
+    
+  let build_signature evars env m (cstrs : (types * types option) option list)
+      (finalcstr : (types * types option) option) =
+    let mk_relty evars newenv ty obj =
+      match obj with
+      | None | Some (_, None) ->
+	let evars, relty = mk_relation env evars ty in
+	  if closed0 (goalevars evars) ty then 
+	    let env' = Environ.reset_with_named_context (Environ.named_context_val env) env in
+	      new_cstr_evar evars env' relty
+	  else new_cstr_evar evars newenv relty
+      | Some (x, Some rel) -> evars, rel
+    in
+    let rec aux env evars ty l =
+      let t = Reductionops.whd_all env (goalevars evars) ty in
+	match EConstr.kind (goalevars evars) t, l with
+	| Prod (na, ty, b), obj :: cstrs ->
+          let b = Reductionops.nf_betaiota (goalevars evars) b in
+	  if noccurn (goalevars evars) 1 b (* non-dependent product *) then
+	    let ty = Reductionops.nf_betaiota (goalevars evars) ty in
+	    let (evars, b', arg, cstrs) = aux env evars (subst1 mkProp b) cstrs in
+	    let evars, relty = mk_relty evars env ty obj in
+	    let evars, newarg = app_poly env evars respectful [| ty ; b' ; relty ; arg |] in
+	      evars, mkProd(na, ty, b), newarg, (ty, Some relty) :: cstrs
+	  else
+	    let (evars, b, arg, cstrs) =
+	      aux (push_rel (LocalAssum (na, ty)) env) evars b cstrs
+	    in
+	    let ty = Reductionops.nf_betaiota (goalevars evars) ty in
+	    let pred = mkLambda (na, ty, b) in
+	    let liftarg = mkLambda (na, ty, arg) in
+	    let evars, arg' = app_poly env evars forall_relation [| ty ; pred ; liftarg |] in
+	      if Option.is_empty obj then evars, mkProd(na, ty, b), arg', (ty, None) :: cstrs
+	      else error "build_signature: no constraint can apply on a dependent argument"
+	| _, obj :: _ -> anomaly ~label:"build_signature" (Pp.str "not enough products")
+	| _, [] ->
+	  (match finalcstr with
+	  | None | Some (_, None) ->
+	    let t = Reductionops.nf_betaiota (fst evars) ty in
+	    let evars, rel = mk_relty evars env t None in
+	      evars, t, rel, [t, Some rel]
+	  | Some (t, Some rel) -> evars, t, rel, [t, Some rel])
+    in aux env evars m cstrs
+
+  (** Folding/unfolding of the tactic constants. *)
+
+  let unfold_impl sigma t =
+    match EConstr.kind sigma t with
+    | App (arrow, [| a; b |])(*  when eq_constr arrow (Lazy.force impl) *) ->
+      mkProd (Anonymous, a, lift 1 b)
+    | _ -> assert false
+
+  let unfold_all sigma t =
+    match EConstr.kind sigma t with
+    | App (id, [| a; b |]) (* when eq_constr id (Lazy.force coq_all) *) ->
+      (match EConstr.kind sigma b with
+      | Lambda (n, ty, b) -> mkProd (n, ty, b)
+      | _ -> assert false)
+    | _ -> assert false
+
+  let unfold_forall sigma t =
+    match EConstr.kind sigma t with
+    | App (id, [| a; b |]) (* when eq_constr id (Lazy.force coq_all) *) ->
+      (match EConstr.kind sigma b with
+      | Lambda (n, ty, b) -> mkProd (n, ty, b)
+      | _ -> assert false)
+    | _ -> assert false
+
+  let arrow_morphism env evd ta tb a b =
+    let ap = is_Prop (goalevars evd) ta and bp = is_Prop (goalevars evd) tb in
+      if ap && bp then app_poly env evd impl [| a; b |], unfold_impl
+      else if ap then (* Domain in Prop, CoDomain in Type *)
+	(app_poly env evd arrow [| a; b |]), unfold_impl
+	(* (evd, mkProd (Anonymous, a, b)), (fun x -> x) *)
+      else if bp then (* Dummy forall *)
+	(app_poly env evd coq_all [| a; mkLambda (Anonymous, a, lift 1 b) |]), unfold_forall
+      else (* None in Prop, use arrow *)
+	(app_poly env evd arrow [| a; b |]), unfold_impl
+
+  let rec decomp_pointwise sigma n c =
+    if Int.equal n 0 then c
+    else
+      match EConstr.kind sigma c with
+      | App (f, [| a; b; relb |]) when Termops.is_global sigma (pointwise_relation_ref ()) f ->
+	decomp_pointwise sigma (pred n) relb
+      | App (f, [| a; b; arelb |]) when Termops.is_global sigma (forall_relation_ref ()) f ->
+	decomp_pointwise sigma (pred n) (Reductionops.beta_applist sigma (arelb, [mkRel 1]))
+      | _ -> invalid_arg "decomp_pointwise"
+
+  let rec apply_pointwise sigma rel = function
+    | arg :: args ->
+      (match EConstr.kind sigma rel with
+      | App (f, [| a; b; relb |]) when Termops.is_global sigma (pointwise_relation_ref ()) f ->
+	apply_pointwise sigma relb args
+      | App (f, [| a; b; arelb |]) when Termops.is_global sigma (forall_relation_ref ()) f ->
+	apply_pointwise sigma (Reductionops.beta_applist sigma (arelb, [arg])) args
+      | _ -> invalid_arg "apply_pointwise")
+    | [] -> rel
+
+  let pointwise_or_dep_relation env evd n t car rel =
+    if noccurn (goalevars evd) 1 car && noccurn (goalevars evd) 1 rel then
+      app_poly env evd pointwise_relation [| t; lift (-1) car; lift (-1) rel |]
+    else
+      app_poly env evd forall_relation
+	[| t; mkLambda (n, t, car); mkLambda (n, t, rel) |]
+
+  let lift_cstr env evars (args : constr list) c ty cstr =
+    let start evars env car =
+      match cstr with
+      | None | Some (_, None) -> 
+	let evars, rel = mk_relation env evars car in
+	  new_cstr_evar evars env rel
+      | Some (ty, Some rel) -> evars, rel
+    in
+    let rec aux evars env prod n = 
+      if Int.equal n 0 then start evars env prod
+      else
+        let sigma = goalevars evars in
+	match EConstr.kind sigma (Reductionops.whd_all env sigma prod) with
+	| Prod (na, ty, b) ->
+	  if noccurn sigma 1 b then
+	    let b' = lift (-1) b in
+	    let evars, rb = aux evars env b' (pred n) in
+	      app_poly env evars pointwise_relation [| ty; b'; rb |]
+	  else
+	    let evars, rb = aux evars (push_rel (LocalAssum (na, ty)) env) b (pred n) in
+	      app_poly env evars forall_relation
+		[| ty; mkLambda (na, ty, b); mkLambda (na, ty, rb) |]
+	| _ -> raise Not_found
+    in 
+    let rec find env c ty = function
+      | [] -> None
+      | arg :: args ->
+	try let evars, found = aux evars env ty (succ (List.length args)) in
+	      Some (evars, found, c, ty, arg :: args)
+	with Not_found ->
+          let sigma = goalevars evars in
+	  let ty = Reductionops.whd_all env sigma ty in
+	  find env (mkApp (c, [| arg |])) (prod_applist sigma ty [arg]) args
+    in find env c ty args
+
+  let unlift_cstr env sigma = function
+    | None -> None
+    | Some codom -> Some (decomp_pointwise (goalevars sigma) 1 codom)
+
+  (** Looking up declared rewrite relations (instances of [RewriteRelation]) *)
+  let is_applied_rewrite_relation env sigma rels t =
+    match EConstr.kind sigma t with
+    | App (c, args) when Array.length args >= 2 ->
+      let head = if isApp sigma c then fst (destApp sigma c) else c in
+	if Termops.is_global sigma (coq_eq_ref ()) head then None
+	else
+	  (try
+	   let params, args = Array.chop (Array.length args - 2) args in
+	   let env' = push_rel_context rels env in
+	   let sigma = Sigma.Unsafe.of_evar_map sigma in
+	   let Sigma ((evar, _), evars, _) = Evarutil.new_type_evar env' sigma Evd.univ_flexible in
+	   let evars = Sigma.to_evar_map evars in
+	   let evars, inst = 
+	     app_poly env (evars,Evar.Set.empty)
+	       rewrite_relation_class [| evar; mkApp (c, params) |] in
+	   let _ = Typeclasses.resolve_one_typeclass env' (goalevars evars) inst in
+	     Some (it_mkProd_or_LetIn t rels)
+	   with e when CErrors.noncritical e -> None)
+  | _ -> None
+
+
+end
+
+(* let my_type_of env evars c = Typing.e_type_of env evars c *)
+(* let mytypeofkey = Profile.declare_profile "my_type_of";; *)
+(* let my_type_of = Profile.profile3 mytypeofkey my_type_of *)
+
+
+let type_app_poly env env evd f args =
+  let evars, c = app_poly_nocheck env evd f args in
+  let evd', t = Typing.type_of env (goalevars evars) c in
+    (evd', cstrevars evars), c
+
+module PropGlobal = struct
+  module Consts =
+  struct 
+    let relation_classes = ["Classes"; "RelationClasses"]
+    let morphisms = ["Classes"; "Morphisms"]
+    let relation = ["Relations";"Relation_Definitions"], "relation"
+    let app_poly = app_poly_nocheck
+    let arrow = find_global ["Program"; "Basics"] "arrow"
+    let coq_inverse = find_global ["Program"; "Basics"] "flip"
+  end
+
+  module G = GlobalBindings(Consts)
+
+  include G
+  include Consts
+  let inverse env evd car rel = 
+    type_app_poly env env evd coq_inverse [| car ; car; mkProp; rel |]
+      (* app_poly env evd coq_inverse [| car ; car; mkProp; rel |] *)
+
+end
+
+module TypeGlobal = struct
+  module Consts = 
+    struct 
+      let relation_classes = ["Classes"; "CRelationClasses"]
+      let morphisms = ["Classes"; "CMorphisms"]
+      let relation = relation_classes, "crelation"
+      let app_poly = app_poly_check
+      let arrow = find_global ["Classes"; "CRelationClasses"] "arrow"
+      let coq_inverse = find_global ["Classes"; "CRelationClasses"] "flip"
+    end
+
+  module G = GlobalBindings(Consts)
+  include G
+  include Consts
+
+
+  let inverse env (evd,cstrs) car rel = 
+    let sigma = Sigma.Unsafe.of_evar_map evd in
+    let Sigma (sort, sigma, _) = Evarutil.new_Type ~rigid:Evd.univ_flexible env sigma in
+    let evd = Sigma.to_evar_map sigma in
+      app_poly_check env (evd,cstrs) coq_inverse [| car ; car; sort; rel |]
+
+end
+
+let sort_of_rel env evm rel =
+  Reductionops.sort_of_arity env evm (Retyping.get_type_of env evm rel)
+
+let is_applied_rewrite_relation = PropGlobal.is_applied_rewrite_relation
+
+(* let _ = *)
+(*   Hook.set Equality.is_applied_rewrite_relation is_applied_rewrite_relation *)
+
+let split_head = function
+    hd :: tl -> hd, tl
+  | [] -> assert(false)
+
+let eq_pb (ty, env, x, y as pb) (ty', env', x', y' as pb') =
+  pb == pb' || (ty == ty' && Constr.equal x x' && Constr.equal y y')
+
+let problem_inclusion x y =
+  List.for_all (fun pb -> List.exists (fun pb' -> eq_pb pb pb') y) x
+
+let evd_convertible env evd x y =
+  try
+    (* Unfortunately, the_conv_x might say they are unifiable even if some
+       unsolvable constraints remain, so we check that this unification
+       does not introduce any new problem. *)
+    let _, pbs = Evd.extract_all_conv_pbs evd in
+    let evd' = Evarconv.the_conv_x env x y evd in
+    let _, pbs' = Evd.extract_all_conv_pbs evd' in
+    if evd' == evd || problem_inclusion pbs' pbs then Some evd'
+    else None
+  with e when CErrors.noncritical e -> None
+
+let convertible env evd x y =
+  Reductionops.is_conv_leq env evd x y
+
+type hypinfo = {
+  prf : constr;
+  car : constr;
+  rel : constr;
+  sort : bool; (* true = Prop; false = Type *)
+  c1 : constr;
+  c2 : constr;
+  holes : Clenv.hole list;
+}
+
+let get_symmetric_proof b = 
+  if b then PropGlobal.get_symmetric_proof else TypeGlobal.get_symmetric_proof
+
+let error_no_relation () = error "Cannot find a relation to rewrite."
+
+let rec decompose_app_rel env evd t = 
+  (** Head normalize for compatibility with the old meta mechanism *)
+  let t = Reductionops.whd_betaiota evd t in
+  match EConstr.kind evd t with
+  | App (f, [||]) -> assert false
+  | App (f, [|arg|]) ->
+    let (f', argl, argr) = decompose_app_rel env evd arg in
+    let ty = Typing.unsafe_type_of env evd argl in
+    let f'' = mkLambda (Name default_dependent_ident, ty,
+      mkLambda (Name (Id.of_string "y"), lift 1 ty,
+        mkApp (lift 2 f, [| mkApp (lift 2 f', [| mkRel 2; mkRel 1 |]) |])))
+    in (f'', argl, argr)
+  | App (f, args) ->
+    let len = Array.length args in
+    let fargs = Array.sub args 0 (Array.length args - 2) in
+    let rel = mkApp (f, fargs) in
+    rel, args.(len - 2), args.(len - 1)
+  | _ -> error_no_relation ()
+
+let decompose_app_rel env evd t =
+  let (rel, t1, t2) = decompose_app_rel env evd t in
+  let ty = Retyping.get_type_of env evd rel in
+  let () = if not (Reductionops.is_arity env evd ty) then error_no_relation () in
+  (rel, t1, t2)
+
+let decompose_applied_relation env sigma (c,l) =
+  let open Context.Rel.Declaration in
+  let ctype = Retyping.get_type_of env sigma c in
+  let find_rel ty =
+    let sigma, cl = Clenv.make_evar_clause env sigma ty in
+    let sigma = Clenv.solve_evar_clause env sigma true cl l in
+    let { Clenv.cl_holes = holes; Clenv.cl_concl = t } = cl in
+    let (equiv, c1, c2) = decompose_app_rel env sigma t in
+    let ty1 = Retyping.get_type_of env sigma c1 in
+    let ty2 = Retyping.get_type_of env sigma c2 in
+    match evd_convertible env sigma ty1 ty2 with
+    | None -> None
+    | Some sigma ->
+      let sort = sort_of_rel env sigma equiv in
+      let args = Array.map_of_list (fun h -> h.Clenv.hole_evar) holes in
+      let value = mkApp (c, args) in
+        Some (sigma, { prf=value;
+                car=ty1; rel = equiv; sort = Sorts.is_prop sort;
+                c1=c1; c2=c2; holes })
+  in
+    match find_rel ctype with
+    | Some c -> c
+    | None ->
+	let ctx,t' = Reductionops.splay_prod env sigma ctype in (* Search for underlying eq *)
+	match find_rel (it_mkProd_or_LetIn t' (List.map (fun (n,t) -> LocalAssum (n, t)) ctx)) with
+	| Some c -> c
+	| None -> error "Cannot find an homogeneous relation to rewrite."
+
+let rewrite_db = "rewrite"
+
+let conv_transparent_state = (Id.Pred.empty, Cpred.full)
+
+let _ = 
+  Hints.add_hints_init
+    (fun () ->
+       Hints.create_hint_db false rewrite_db conv_transparent_state true)
+
+let rewrite_transparent_state () =
+  Hints.Hint_db.transparent_state (Hints.searchtable_map rewrite_db)
+
+let rewrite_core_unif_flags = {
+  Unification.modulo_conv_on_closed_terms = None;
+  Unification.use_metas_eagerly_in_conv_on_closed_terms = true;
+  Unification.use_evars_eagerly_in_conv_on_closed_terms = true;
+  Unification.modulo_delta = empty_transparent_state;
+  Unification.modulo_delta_types = full_transparent_state;
+  Unification.check_applied_meta_types = true;
+  Unification.use_pattern_unification = true;
+  Unification.use_meta_bound_pattern_unification = true;
+  Unification.frozen_evars = Evar.Set.empty;
+  Unification.restrict_conv_on_strict_subterms = false;
+  Unification.modulo_betaiota = false;
+  Unification.modulo_eta = true;
+}
+
+(* Flags used for the setoid variant of "rewrite" and for the strategies
+   "hints"/"old_hints"/"terms" of "rewrite_strat", and for solving pre-existing
+   evars in "rewrite" (see unify_abs) *)
+let rewrite_unif_flags =
+  let flags = rewrite_core_unif_flags in {
+  Unification.core_unify_flags = flags;
+  Unification.merge_unify_flags = flags;
+  Unification.subterm_unify_flags = flags;
+  Unification.allow_K_in_toplevel_higher_order_unification = true;
+  Unification.resolve_evars = true
+  }
+
+let rewrite_core_conv_unif_flags = {
+  rewrite_core_unif_flags with
+    Unification.modulo_conv_on_closed_terms = Some conv_transparent_state;
+    Unification.modulo_delta_types = conv_transparent_state;
+    Unification.modulo_betaiota = true
+}
+
+(* Fallback flags for the setoid variant of "rewrite" *)
+let rewrite_conv_unif_flags =
+  let flags = rewrite_core_conv_unif_flags in {
+  Unification.core_unify_flags = flags;
+  Unification.merge_unify_flags = flags;
+  Unification.subterm_unify_flags = flags;
+  Unification.allow_K_in_toplevel_higher_order_unification = true;
+  Unification.resolve_evars = true
+  }
+
+(* Flags for "setoid_rewrite c"/"rewrite_strat -> c" *)
+let general_rewrite_unif_flags () =
+  let ts = rewrite_transparent_state () in
+  let core_flags =
+    { rewrite_core_unif_flags with
+      Unification.modulo_conv_on_closed_terms = Some ts;
+      Unification.use_evars_eagerly_in_conv_on_closed_terms = true;
+      Unification.modulo_delta = ts;
+      Unification.modulo_delta_types = full_transparent_state;
+      Unification.modulo_betaiota = true }
+  in {
+    Unification.core_unify_flags = core_flags;
+    Unification.merge_unify_flags = core_flags;
+    Unification.subterm_unify_flags = { core_flags with Unification.modulo_delta = empty_transparent_state };
+    Unification.allow_K_in_toplevel_higher_order_unification = true;
+    Unification.resolve_evars = true
+  }
+
+let refresh_hypinfo env sigma (is, cb) =
+  let sigma, cbl = Tacinterp.interp_open_constr_with_bindings is env sigma cb in
+  let sigma, hypinfo = decompose_applied_relation env sigma cbl in
+  let { c1; c2; car; rel; prf; sort; holes } = hypinfo in
+  sigma, (car, rel, prf, c1, c2, holes, sort)
+
+(** FIXME: write this in the new monad interface *)
+let solve_remaining_by env sigma holes by =
+  match by with
+  | None -> sigma
+  | Some tac ->
+    let map h =
+      if h.Clenv.hole_deps then None
+      else match EConstr.kind sigma h.Clenv.hole_evar with
+      | Evar (evk, _) ->
+        Some evk
+      | _ -> None
+    in
+    (** Only solve independent holes *)
+    let indep = List.map_filter map holes in
+    let ist = { Geninterp.lfun = Id.Map.empty; extra = Geninterp.TacStore.empty } in
+    let solve_tac = match tac with
+    | Genarg.GenArg (Genarg.Glbwit tag, tac) ->
+      Ftactic.run (Geninterp.interp tag ist tac) (fun _ -> Proofview.tclUNIT ())
+    in
+    let solve_tac = tclCOMPLETE solve_tac in
+    let solve sigma evk =
+      let evi =
+        try Some (Evd.find_undefined sigma evk)
+        with Not_found -> None
+      in
+      match evi with
+      | None -> sigma
+        (** Evar should not be defined, but just in case *)
+      | Some evi ->
+        let env = Environ.reset_with_named_context evi.evar_hyps env in
+        let ty = EConstr.of_constr evi.evar_concl in
+        let c, sigma = Pfedit.refine_by_tactic env sigma ty solve_tac in
+        Evd.define evk c sigma
+    in
+    List.fold_left solve sigma indep
+
+let no_constraints cstrs = 
+  fun ev _ -> not (Evar.Set.mem ev cstrs)
+
+let all_constraints cstrs = 
+  fun ev _ -> Evar.Set.mem ev cstrs
+
+let poly_inverse sort =
+  if sort then PropGlobal.inverse else TypeGlobal.inverse
+
+type rewrite_proof = 
+  | RewPrf of constr * constr
+  (** A Relation (R : rew_car -> rew_car -> Prop) and a proof of R rew_from rew_to *)
+  | RewCast of cast_kind
+  (** A proof of convertibility (with casts) *)
+
+type rewrite_result_info = {
+  rew_car : constr ;
+  (** A type *)
+  rew_from : constr ;
+  (** A term of type rew_car *)
+  rew_to : constr ;
+  (** A term of type rew_car *)
+  rew_prf : rewrite_proof ;
+  (** A proof of rew_from == rew_to *)
+  rew_evars : evars;
+}
+
+type rewrite_result =
+| Fail
+| Identity
+| Success of rewrite_result_info
+
+type 'a strategy_input = { state : 'a ; (* a parameter: for instance, a state *)
+			   env : Environ.env ;
+			   unfresh : Id.t list ; (* Unfresh names *)
+			   term1 : constr ;
+			   ty1 : types ; (* first term and its type (convertible to rew_from) *)
+			   cstr : (bool (* prop *) * constr option) ;
+			   evars : evars }
+	       
+type 'a pure_strategy = { strategy :
+  'a strategy_input ->
+  'a * rewrite_result (* the updated state and the "result" *) }
+
+type strategy = unit pure_strategy
+
+let symmetry env sort rew =
+  let { rew_evars = evars; rew_car = car; } = rew in
+  let (rew_evars, rew_prf) = match rew.rew_prf with
+  | RewCast _ -> (rew.rew_evars, rew.rew_prf)
+  | RewPrf (rel, prf) ->
+    try
+      let evars, symprf = get_symmetric_proof sort env evars car rel in
+      let prf = mkApp (symprf, [| rew.rew_from ; rew.rew_to ; prf |]) in
+      (evars, RewPrf (rel, prf))
+    with Not_found ->
+      let evars, rel = poly_inverse sort env evars car rel in
+      (evars, RewPrf (rel, prf))
+  in
+  { rew with rew_from = rew.rew_to; rew_to = rew.rew_from; rew_prf; rew_evars; }
+
+(* Matching/unifying the rewriting rule against [t] *)
+let unify_eqn (car, rel, prf, c1, c2, holes, sort) l2r flags env (sigma, cstrs) by t =
+  try
+    let left = if l2r then c1 else c2 in
+    let sigma = Unification.w_unify ~flags env sigma CONV left t in
+    let sigma = Typeclasses.resolve_typeclasses ~filter:(no_constraints cstrs)
+      ~fail:true env sigma in
+    let evd = solve_remaining_by env sigma holes by in
+    let nf c = Reductionops.nf_evar evd (Reductionops.nf_meta evd c) in
+    let c1 = nf c1 and c2 = nf c2
+    and rew_car = nf car and rel = nf rel
+    and prf = nf prf in
+    let ty1 = Retyping.get_type_of env evd c1 in
+    let ty2 = Retyping.get_type_of env evd c2 in
+    let () = if not (convertible env evd ty2 ty1) then raise Reduction.NotConvertible in
+    let rew_evars = evd, cstrs in
+    let rew_prf = RewPrf (rel, prf) in
+    let rew = { rew_evars; rew_prf; rew_car; rew_from = c1; rew_to = c2; } in
+    let rew = if l2r then rew else symmetry env sort rew in
+    Some rew
+  with 
+  | e when Class_tactics.catchable e -> None
+  | Reduction.NotConvertible -> None
+
+let unify_abs (car, rel, prf, c1, c2) l2r sort env (sigma, cstrs) t =
+  try
+    let left = if l2r then c1 else c2 in
+    (* The pattern is already instantiated, so the next w_unify is
+       basically an eq_constr, except when preexisting evars occur in
+       either the lemma or the goal, in which case the eq_constr also
+       solved this evars *)
+    let sigma = Unification.w_unify ~flags:rewrite_unif_flags env sigma CONV left t in
+    let rew_evars = sigma, cstrs in
+    let rew_prf = RewPrf (rel, prf) in
+    let rew = { rew_car = car; rew_from = c1; rew_to = c2; rew_prf; rew_evars; } in
+    let rew = if l2r then rew else symmetry env sort rew in
+    Some rew
+  with 
+  | e when Class_tactics.catchable e -> None
+  | Reduction.NotConvertible -> None
+
+type rewrite_flags = { under_lambdas : bool; on_morphisms : bool }
+
+let default_flags = { under_lambdas = true; on_morphisms = true; }
+
+let get_opt_rew_rel = function RewPrf (rel, prf) -> Some rel | _ -> None
+
+let make_eq () =
+(*FIXME*) EConstr.of_constr (Universes.constr_of_global (Coqlib.build_coq_eq ()))
+let make_eq_refl () =
+(*FIXME*) EConstr.of_constr (Universes.constr_of_global (Coqlib.build_coq_eq_refl ()))
+
+let get_rew_prf r = match r.rew_prf with
+  | RewPrf (rel, prf) -> rel, prf 
+  | RewCast c ->
+    let rel = mkApp (make_eq (), [| r.rew_car |]) in
+      rel, mkCast (mkApp (make_eq_refl (), [| r.rew_car; r.rew_from |]),
+		   c, mkApp (rel, [| r.rew_from; r.rew_to |]))
+
+let poly_subrelation sort = 
+  if sort then PropGlobal.subrelation else TypeGlobal.subrelation
+
+let resolve_subrelation env avoid car rel sort prf rel' res =
+  if Termops.eq_constr (fst res.rew_evars) rel rel' then res
+  else
+    let evars, app = app_poly_check env res.rew_evars (poly_subrelation sort) [|car; rel; rel'|] in
+    let evars, subrel = new_cstr_evar evars env app in
+    let appsub = mkApp (subrel, [| res.rew_from ; res.rew_to ; prf |]) in
+      { res with
+	rew_prf = RewPrf (rel', appsub);
+	rew_evars = evars }
+
+let resolve_morphism env avoid oldt m ?(fnewt=fun x -> x) args args' (b,cstr) evars =
+  let evars, morph_instance, proj, sigargs, m', args, args' =
+    let first = match (Array.findi (fun _ b -> not (Option.is_empty b)) args') with
+    | Some i -> i
+    | None -> invalid_arg "resolve_morphism" in
+    let morphargs, morphobjs = Array.chop first args in
+    let morphargs', morphobjs' = Array.chop first args' in
+    let appm = mkApp(m, morphargs) in
+    let appmtype = Typing.unsafe_type_of env (goalevars evars) appm in
+    let cstrs = List.map 
+      (Option.map (fun r -> r.rew_car, get_opt_rew_rel r.rew_prf)) 
+      (Array.to_list morphobjs') 
+    in
+      (* Desired signature *)
+    let evars, appmtype', signature, sigargs = 
+      if b then PropGlobal.build_signature evars env appmtype cstrs cstr
+      else TypeGlobal.build_signature evars env appmtype cstrs cstr
+    in
+      (* Actual signature found *)
+    let cl_args = [| appmtype' ; signature ; appm |] in
+    let evars, app = app_poly_sort b env evars (if b then PropGlobal.proper_type else TypeGlobal.proper_type)
+      cl_args in
+    let env' = 
+      let dosub, appsub = 
+	if b then PropGlobal.do_subrelation, PropGlobal.apply_subrelation 
+	else TypeGlobal.do_subrelation, TypeGlobal.apply_subrelation
+      in
+	EConstr.push_named
+	  (LocalDef (Id.of_string "do_subrelation",
+	             snd (app_poly_sort b env evars dosub [||]),
+	             snd (app_poly_nocheck env evars appsub [||])))
+	  env
+    in
+    let evars, morph = new_cstr_evar evars env' app in
+      evars, morph, morph, sigargs, appm, morphobjs, morphobjs'
+  in
+  let projargs, subst, evars, respars, typeargs =
+    Array.fold_left2
+      (fun (acc, subst, evars, sigargs, typeargs') x y ->
+	let (carrier, relation), sigargs = split_head sigargs in
+	  match relation with
+	  | Some relation ->
+	      let carrier = substl subst carrier
+	      and relation = substl subst relation in
+	      (match y with
+	      | None ->
+		  let evars, proof = 
+		    (if b then PropGlobal.proper_proof else TypeGlobal.proper_proof) 
+		      env evars carrier relation x in
+		    [ proof ; x ; x ] @ acc, subst, evars, sigargs, x :: typeargs'
+	      | Some r ->
+		  [ snd (get_rew_prf r); r.rew_to; x ] @ acc, subst, evars, 
+	      sigargs, r.rew_to :: typeargs')
+	  | None ->
+	      if not (Option.is_empty y) then 
+		error "Cannot rewrite inside dependent arguments of a function";
+	      x :: acc, x :: subst, evars, sigargs, x :: typeargs')
+      ([], [], evars, sigargs, []) args args'
+  in
+  let proof = applist (proj, List.rev projargs) in
+  let newt = applist (m', List.rev typeargs) in
+    match respars with
+	[ a, Some r ] -> evars, proof, substl subst a, substl subst r, oldt, fnewt newt
+      | _ -> assert(false)
+
+let apply_constraint env avoid car rel prf cstr res =
+  match snd cstr with
+  | None -> res
+  | Some r -> resolve_subrelation env avoid car rel (fst cstr) prf r res
+
+let coerce env avoid cstr res = 
+  let rel, prf = get_rew_prf res in
+    apply_constraint env avoid res.rew_car rel prf cstr res
+
+let apply_rule unify loccs : int pure_strategy =
+  let (nowhere_except_in,occs) = convert_occs loccs in
+  let is_occ occ =
+    if nowhere_except_in 
+    then List.mem occ occs 
+    else not (List.mem occ occs) 
+  in
+  { strategy = fun { state = occ ; env ; unfresh ;
+		     term1 = t ; ty1 = ty ; cstr ; evars } ->
+      let unif = if isEvar (goalevars evars) t then None else unify env evars t in
+	match unif with
+	| None -> (occ, Fail)
+        | Some rew ->
+	  let occ = succ occ in
+	    if not (is_occ occ) then (occ, Fail)
+	    else if Termops.eq_constr (fst rew.rew_evars) t rew.rew_to then (occ, Identity)
+	    else
+	      let res = { rew with rew_car = ty } in
+              let rel, prf = get_rew_prf res in
+	      let res = Success (apply_constraint env unfresh rew.rew_car rel prf cstr res) in
+              (occ, res)
+    }
+
+let apply_lemma l2r flags oc by loccs : strategy = { strategy =
+  fun ({ state = () ; env ; term1 = t ; evars = (sigma, cstrs) } as input) ->
+    let sigma, c = oc sigma in
+    let sigma, hypinfo = decompose_applied_relation env sigma c in
+    let { c1; c2; car; rel; prf; sort; holes } = hypinfo in
+    let rew = (car, rel, prf, c1, c2, holes, sort) in
+    let evars = (sigma, cstrs) in
+    let unify env evars t =
+      let rew = unify_eqn rew l2r flags env evars by t in
+      match rew with
+      | None -> None
+      | Some rew -> Some rew
+    in
+    let _, res = (apply_rule unify loccs).strategy { input with
+						     state = 0 ;
+						     evars } in
+    (), res
+						   }
+
+let e_app_poly env evars f args =
+  let evars', c = app_poly_nocheck env !evars f args in
+    evars := evars';
+    c
+
+let make_leibniz_proof env c ty r =
+  let evars = ref r.rew_evars in
+  let prf = 
+    match r.rew_prf with
+    | RewPrf (rel, prf) -> 
+	let rel = e_app_poly env evars coq_eq [| ty |] in
+	let prf =
+	  e_app_poly env evars coq_f_equal
+		[| r.rew_car; ty;
+		   mkLambda (Anonymous, r.rew_car, c);
+		   r.rew_from; r.rew_to; prf |]
+	in RewPrf (rel, prf)
+    | RewCast k -> r.rew_prf
+  in
+    { rew_car = ty; rew_evars = !evars;
+      rew_from = subst1 r.rew_from c; rew_to = subst1 r.rew_to c; rew_prf = prf }
+
+let reset_env env =
+  let env' = Global.env_of_context (Environ.named_context_val env) in
+    Environ.push_rel_context (Environ.rel_context env) env'
+      
+let fold_match ?(force=false) env sigma c =
+  let (ci, p, c, brs) = destCase sigma c in
+  let cty = Retyping.get_type_of env sigma c in
+  let dep, pred, exists, (sk,eff) = 
+    let env', ctx, body =
+      let ctx, pred = decompose_lam_assum sigma p in
+      let env' = push_rel_context ctx env in
+	env', ctx, pred
+    in
+    let sortp = Retyping.get_sort_family_of env' sigma body in
+    let sortc = Retyping.get_sort_family_of env sigma cty in
+    let dep = not (noccurn sigma 1 body) in
+    let pred = if dep then p else
+	it_mkProd_or_LetIn (subst1 mkProp body) (List.tl ctx)
+    in
+    let sk = 
+      if sortp == InProp then
+	if sortc == InProp then
+	  if dep then case_dep_scheme_kind_from_prop
+	  else case_scheme_kind_from_prop
+	else (
+	  if dep
+	  then case_dep_scheme_kind_from_type_in_prop
+	  else case_scheme_kind_from_type)
+      else ((* sortc <> InProp by typing *)
+	if dep
+	then case_dep_scheme_kind_from_type
+	else case_scheme_kind_from_type)
+    in 
+    let exists = Ind_tables.check_scheme sk ci.ci_ind in
+      if exists || force then
+	dep, pred, exists, Ind_tables.find_scheme sk ci.ci_ind
+      else raise Not_found
+  in
+  let app =
+    let ind, args = Inductiveops.find_mrectype env sigma cty in
+    let pars, args = List.chop ci.ci_npar args in
+    let meths = List.map (fun br -> br) (Array.to_list brs) in
+      applist (mkConst sk, pars @ [pred] @ meths @ args @ [c])
+  in 
+    sk, (if exists then env else reset_env env), app, eff
+
+let unfold_match env sigma sk app =
+  match EConstr.kind sigma app with
+  | App (f', args) when eq_constant (fst (destConst sigma f')) sk ->
+      let v = Environ.constant_value_in (Global.env ()) (sk,Univ.Instance.empty)(*FIXME*) in
+      let v = EConstr.of_constr v in
+	Reductionops.whd_beta sigma (mkApp (v, args))
+  | _ -> app
+
+let is_rew_cast = function RewCast _ -> true | _ -> false
+
+let subterm all flags (s : 'a pure_strategy) : 'a pure_strategy =
+  let rec aux { state ; env ; unfresh ;
+		term1 = t ; ty1 = ty ; cstr = (prop, cstr) ; evars } =
+    let cstr' = Option.map (fun c -> (ty, Some c)) cstr in
+      match EConstr.kind (goalevars evars) t with
+      | App (m, args) ->
+	  let rewrite_args state success =
+	    let state, (args', evars', progress) =
+	      Array.fold_left
+		(fun (state, (acc, evars, progress)) arg ->
+		  if not (Option.is_empty progress) && not all then 
+		    state, (None :: acc, evars, progress)
+		  else
+		    let argty = Retyping.get_type_of env (goalevars evars) arg in
+		    let state, res = s.strategy { state ; env ;
+						  unfresh ;
+						  term1 = arg ;	ty1 = argty ;
+						  cstr = (prop,None) ;
+						  evars } in
+		    let res' = 
+		      match res with
+		      | Identity ->
+			let progress = if Option.is_empty progress then Some false else progress in
+			  (None :: acc, evars, progress)
+		      | Success r -> 
+			(Some r :: acc, r.rew_evars, Some true)
+		      | Fail -> (None :: acc, evars, progress)
+		    in state, res')
+		(state, ([], evars, success)) args
+	    in
+	    let res = 
+	      match progress with
+	      | None -> Fail
+	      | Some false -> Identity
+	      | Some true ->
+		let args' = Array.of_list (List.rev args') in
+		  if Array.exists
+		    (function 
+		      | None -> false 
+		      | Some r -> not (is_rew_cast r.rew_prf)) args'
+		  then
+		    let evars', prf, car, rel, c1, c2 = 
+		      resolve_morphism env unfresh t m args args' (prop, cstr') evars' 
+		    in
+		    let res = { rew_car = ty; rew_from = c1;
+				rew_to = c2; rew_prf = RewPrf (rel, prf);
+				rew_evars = evars' } 
+		    in Success res
+		  else 
+		    let args' = Array.map2
+		      (fun aorig anew ->
+			match anew with None -> aorig
+			| Some r -> r.rew_to) args args' 
+		    in
+		    let res = { rew_car = ty; rew_from = t;
+				rew_to = mkApp (m, args'); rew_prf = RewCast DEFAULTcast;
+				rew_evars = evars' }
+		    in Success res
+	    in state, res
+	  in
+	    if flags.on_morphisms then
+	      let mty = Retyping.get_type_of env (goalevars evars) m in
+	      let evars, cstr', m, mty, argsl, args = 
+		let argsl = Array.to_list args in
+		let lift = if prop then PropGlobal.lift_cstr else TypeGlobal.lift_cstr in
+		  match lift env evars argsl m mty None with
+		  | Some (evars, cstr', m, mty, args) -> 
+		    evars, Some cstr', m, mty, args, Array.of_list args
+		  | None -> evars, None, m, mty, argsl, args
+	      in
+	      let state, m' = s.strategy { state ; env ; unfresh ;
+					   term1 = m ; ty1 = mty ;
+					   cstr = (prop, cstr') ; evars } in
+		match m' with
+		| Fail -> rewrite_args state None (* Standard path, try rewrite on arguments *)
+		| Identity -> rewrite_args state (Some false)
+		| Success r ->
+		    (* We rewrote the function and get a proof of pointwise rel for the arguments.
+		       We just apply it. *)
+		    let prf = match r.rew_prf with
+		      | RewPrf (rel, prf) ->
+			let app = if prop then PropGlobal.apply_pointwise 
+			  else TypeGlobal.apply_pointwise 
+			in
+			  RewPrf (app (goalevars evars) rel argsl, mkApp (prf, args))
+		      | x -> x
+		    in
+		    let res =
+		      { rew_car = Reductionops.hnf_prod_appvect env (goalevars evars) r.rew_car args;
+			rew_from = mkApp(r.rew_from, args); rew_to = mkApp(r.rew_to, args);
+			rew_prf = prf; rew_evars = r.rew_evars }
+		    in 
+		    let res = 
+		      match prf with
+		      | RewPrf (rel, prf) ->
+			Success (apply_constraint env unfresh res.rew_car
+				      rel prf (prop,cstr) res)
+		      | _ -> Success res
+		    in state, res
+	    else rewrite_args state None
+	      
+      | Prod (n, x, b) when noccurn (goalevars evars) 1 b ->
+	  let b = subst1 mkProp b in
+	  let tx = Retyping.get_type_of env (goalevars evars) x
+	  and tb = Retyping.get_type_of env (goalevars evars) b in
+	  let arr = if prop then PropGlobal.arrow_morphism 
+	    else TypeGlobal.arrow_morphism 
+	  in
+	  let (evars', mor), unfold = arr env evars tx tb x b in
+	  let state, res = aux { state ; env ; unfresh ;
+				 term1 = mor ; ty1 = ty ;
+				 cstr = (prop,cstr) ; evars = evars' } in
+	  let res = 
+	    match res with
+	    | Success r -> Success { r with rew_to = unfold (goalevars r.rew_evars) r.rew_to }
+	    | Fail | Identity -> res
+	  in state, res
+
+      (* 		if x' = None && flags.under_lambdas then *)
+      (* 		  let lam = mkLambda (n, x, b) in *)
+      (* 		  let lam', occ = aux env lam occ None in *)
+      (* 		  let res =  *)
+      (* 		    match lam' with *)
+      (* 		    | None -> None *)
+      (* 		    | Some (prf, (car, rel, c1, c2)) -> *)
+      (* 			Some (resolve_morphism env sigma t *)
+      (* 				 ~fnewt:unfold_all *)
+      (* 				 (Lazy.force coq_all) [| x ; lam |] [| None; lam' |] *)
+      (* 				 cstr evars) *)
+      (* 		  in res, occ *)
+      (* 		else *)
+
+      | Prod (n, dom, codom) ->
+	  let lam = mkLambda (n, dom, codom) in
+	  let (evars', app), unfold = 
+	    if eq_constr (fst evars) ty mkProp then
+	      (app_poly_sort prop env evars coq_all [| dom; lam |]), TypeGlobal.unfold_all
+	    else 
+	      let forall = if prop then PropGlobal.coq_forall else TypeGlobal.coq_forall in
+		(app_poly_sort prop env evars forall [| dom; lam |]), TypeGlobal.unfold_forall
+	  in
+	  let state, res = aux { state ; env ; unfresh ;
+				 term1 = app ; ty1 = ty ;
+				 cstr = (prop,cstr) ; evars = evars' } in
+	  let res = 
+	    match res with
+	    | Success r -> Success { r with rew_to = unfold (goalevars r.rew_evars) r.rew_to }
+	    | Fail | Identity -> res
+	  in state, res
+
+(* TODO: real rewriting under binders: introduce x x' (H : R x x') and rewrite with 
+   H at any occurrence of x. Ask for (R ==> R') for the lambda. Formalize this.
+   B. Barras' idea is to have a context of relations, of length 1, with Σ for gluing
+   dependent relations and using projections to get them out.
+ *)
+      (* | Lambda (n, t, b) when flags.under_lambdas -> *)
+      (* 	  let n' = name_app (fun id -> Tactics.fresh_id_in_env avoid id env) n in *)
+      (* 	  let n'' = name_app (fun id -> Tactics.fresh_id_in_env avoid id env) n' in *)
+      (* 	  let n''' = name_app (fun id -> Tactics.fresh_id_in_env avoid id env) n'' in *)
+      (* 	  let rel = new_cstr_evar cstr env (mkApp (Lazy.force coq_relation, [|t|])) in *)
+      (* 	  let env' = Environ.push_rel_context [(n'',None,lift 2 rel);(n'',None,lift 1 t);(n', None, t)] env in *)
+      (* 	  let b' = s env' avoid b (Typing.type_of env' (goalevars evars) (lift 2 b)) (unlift_cstr env (goalevars evars) cstr) evars in *)
+      (* 	    (match b' with *)
+      (* 	    | Some (Some r) -> *)
+      (* 		let prf = match r.rew_prf with *)
+      (* 		  | RewPrf (rel, prf) -> *)
+      (* 		      let rel = pointwise_or_dep_relation n' t r.rew_car rel in *)
+      (* 		      let prf = mkLambda (n', t, prf) in *)
+      (* 			RewPrf (rel, prf) *)
+      (* 		  | x -> x *)
+      (* 		in *)
+      (* 		  Some (Some { r with *)
+      (* 		    rew_prf = prf; *)
+      (* 		    rew_car = mkProd (n, t, r.rew_car); *)
+      (* 		    rew_from = mkLambda(n, t, r.rew_from); *)
+      (* 		    rew_to = mkLambda (n, t, r.rew_to) }) *)
+      (* 	    | _ -> b') *)
+
+      | Lambda (n, t, b) when flags.under_lambdas ->
+        let n' = name_app (fun id -> Tactics.fresh_id_in_env unfresh id env) n in
+        let open Context.Rel.Declaration in
+	let env' = EConstr.push_rel (LocalAssum (n', t)) env in
+	let bty = Retyping.get_type_of env' (goalevars evars) b in
+	let unlift = if prop then PropGlobal.unlift_cstr else TypeGlobal.unlift_cstr in
+	let state, b' = s.strategy { state ; env = env' ; unfresh ;
+				     term1 = b ; ty1 = bty ;
+				     cstr = (prop, unlift env evars cstr) ;
+				     evars } in
+	let res = 
+	  match b' with
+	  | Success r ->
+	    let r = match r.rew_prf with
+	      | RewPrf (rel, prf) ->
+		let point = if prop then PropGlobal.pointwise_or_dep_relation else
+		    TypeGlobal.pointwise_or_dep_relation
+		in
+		let evars, rel = point env r.rew_evars n' t r.rew_car rel in
+		let prf = mkLambda (n', t, prf) in
+		  { r with rew_prf = RewPrf (rel, prf); rew_evars = evars }
+	      | x -> r
+	    in
+	      Success { r with
+		rew_car = mkProd (n, t, r.rew_car);
+		rew_from = mkLambda(n, t, r.rew_from);
+		rew_to = mkLambda (n, t, r.rew_to) }
+	  | Fail | Identity -> b'
+	in state, res
+	    
+      | Case (ci, p, c, brs) ->
+	let cty = Retyping.get_type_of env (goalevars evars) c in
+	let evars', eqty = app_poly_sort prop env evars coq_eq [| cty |] in
+	let cstr' = Some eqty in
+	let state, c' = s.strategy { state ; env ; unfresh ;
+				     term1 = c ; ty1 = cty ;
+				     cstr = (prop, cstr') ; evars = evars' } in
+	let state, res = 
+	  match c' with
+	  | Success r ->
+	    let case = mkCase (ci, lift 1 p, mkRel 1, Array.map (lift 1) brs) in
+	    let res = make_leibniz_proof env case ty r in
+	      state, Success (coerce env unfresh (prop,cstr) res)
+	  | Fail | Identity ->
+	    if Array.for_all (Int.equal 0) ci.ci_cstr_ndecls then
+	      let evars', eqty = app_poly_sort prop env evars coq_eq [| ty |] in
+	      let cstr = Some eqty in
+	      let state, found, brs' = Array.fold_left 
+		(fun (state, found, acc) br ->
+		  if not (Option.is_empty found) then 
+		    (state, found, fun x -> lift 1 br :: acc x)
+		  else
+		    let state, res = s.strategy { state ; env ; unfresh ;
+						  term1 = br ; ty1 = ty ;
+						  cstr = (prop,cstr) ; evars } in
+		      match res with
+		      | Success r -> (state, Some r, fun x -> mkRel 1 :: acc x)
+		      | Fail | Identity -> (state, None, fun x -> lift 1 br :: acc x))
+		(state, None, fun x -> []) brs
+	      in
+		match found with
+		| Some r ->
+		  let ctxc = mkCase (ci, lift 1 p, lift 1 c, Array.of_list (List.rev (brs' c'))) in
+		    state, Success (make_leibniz_proof env ctxc ty r)
+		| None -> state, c'
+	    else
+	      match try Some (fold_match env (goalevars evars) t) with Not_found -> None with
+	      | None -> state, c'
+	      | Some (cst, _, t', eff (*FIXME*)) ->
+		 let state, res = aux { state ; env ; unfresh ;
+					term1 = t' ; ty1 = ty ;
+					cstr = (prop,cstr) ; evars } in
+		let res = 
+		  match res with
+		  | Success prf -> 
+		    Success { prf with
+		      rew_from = t; 
+		      rew_to = unfold_match env (goalevars evars) cst prf.rew_to }
+		  | x' -> c'
+		in state, res
+	in 
+	let res = 
+	  match res with
+	  | Success r ->  
+	    let rel, prf = get_rew_prf r in
+	      Success (apply_constraint env unfresh r.rew_car rel prf (prop,cstr) r)
+	  | Fail | Identity -> res
+	in state, res
+      | _ -> state, Fail
+  in { strategy = aux }
+
+let all_subterms = subterm true default_flags
+let one_subterm = subterm false default_flags
+
+(** Requires transitivity of the rewrite step, if not a reduction.
+    Not tail-recursive. *)
+
+let transitivity state env unfresh prop (res : rewrite_result_info) (next : 'a pure_strategy) : 
+    'a * rewrite_result =
+  let state, nextres =
+    next.strategy { state ; env ; unfresh ;
+		    term1 = res.rew_to ; ty1 = res.rew_car ;
+		    cstr = (prop, get_opt_rew_rel res.rew_prf) ;
+		    evars = res.rew_evars }
+  in 
+  let res = 
+    match nextres with
+    | Fail -> Fail
+    | Identity -> Success res
+    | Success res' ->
+      match res.rew_prf with
+      | RewCast c -> Success { res' with rew_from = res.rew_from }
+      | RewPrf (rew_rel, rew_prf) ->
+	match res'.rew_prf with
+	| RewCast _ -> Success { res with rew_to = res'.rew_to }
+	| RewPrf (res'_rel, res'_prf) ->
+	  let trans = 
+	    if prop then PropGlobal.transitive_type 
+	    else TypeGlobal.transitive_type
+	  in
+	  let evars, prfty = 
+	    app_poly_sort prop env res'.rew_evars trans [| res.rew_car; rew_rel |] 
+	  in
+	  let evars, prf = new_cstr_evar evars env prfty in
+	  let prf = mkApp (prf, [|res.rew_from; res'.rew_from; res'.rew_to;
+				  rew_prf; res'_prf |])
+	  in Success { res' with rew_from = res.rew_from; 
+	    rew_evars = evars; rew_prf = RewPrf (res'_rel, prf) }
+  in state, res
+
+(** Rewriting strategies.
+
+    Inspired by ELAN's rewriting strategies:
+    http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.21.4049
+*)
+
+module Strategies =
+  struct
+
+    let fail : 'a pure_strategy =
+      { strategy = fun { state } -> state, Fail }
+
+    let id : 'a pure_strategy =
+      { strategy = fun { state } -> state, Identity }
+
+    let refl : 'a pure_strategy =
+      { strategy =
+	fun { state ; env ;
+	      term1 = t ; ty1 = ty ;
+	      cstr = (prop,cstr) ; evars } ->
+	let evars, rel = match cstr with
+	  | None -> 
+	    let mkr = if prop then PropGlobal.mk_relation else TypeGlobal.mk_relation in
+	    let evars, rty = mkr env evars ty in
+	      new_cstr_evar evars env rty
+	  | Some r -> evars, r
+	in
+	let evars, proof =
+	  let proxy = 
+	    if prop then PropGlobal.proper_proxy_type 
+	    else TypeGlobal.proper_proxy_type
+	  in
+	  let evars, mty = app_poly_sort prop env evars proxy [| ty ; rel; t |] in
+	    new_cstr_evar evars env mty
+	in
+	let res = Success { rew_car = ty; rew_from = t; rew_to = t;
+			       rew_prf = RewPrf (rel, proof); rew_evars = evars }
+	in state, res
+      }
+
+    let progress (s : 'a pure_strategy) : 'a pure_strategy = { strategy =
+      fun input ->
+	let state, res = s.strategy input in
+	  match res with
+	  | Fail -> state, Fail
+	  | Identity -> state, Fail
+	  | Success r -> state, Success r
+							     }
+	    
+    let seq first snd : 'a pure_strategy = { strategy =
+      fun ({ env ; unfresh ; cstr } as input) ->
+	let state, res = first.strategy input in
+	  match res with
+	  | Fail -> state, Fail
+	  | Identity -> snd.strategy { input with state }
+	  | Success res -> transitivity state env unfresh (fst cstr) res snd
+					   }
+	    
+    let choice fst snd : 'a pure_strategy = { strategy =
+      fun input ->
+	let state, res = fst.strategy input in
+	  match res with
+	  | Fail -> snd.strategy { input with state }
+	  | Identity | Success _ -> state, res
+					    }
+
+    let try_ str : 'a pure_strategy = choice str id
+
+    let check_interrupt str input =
+      Control.check_for_interrupt ();
+      str input
+
+    let fix (f : 'a pure_strategy -> 'a pure_strategy) : 'a pure_strategy =
+      let rec aux input = (f { strategy = fun input -> check_interrupt aux input }).strategy input in
+      { strategy = aux }
+    
+    let any (s : 'a pure_strategy) : 'a pure_strategy =
+      fix (fun any -> try_ (seq s any))
+
+    let repeat (s : 'a pure_strategy) : 'a pure_strategy =
+      seq s (any s)
+
+    let bu (s : 'a pure_strategy) : 'a pure_strategy =
+      fix (fun s' -> seq (choice (progress (all_subterms s')) s) (try_ s'))
+
+    let td (s : 'a pure_strategy) : 'a pure_strategy =
+      fix (fun s' -> seq (choice s (progress (all_subterms s'))) (try_ s'))
+
+    let innermost (s : 'a pure_strategy) : 'a pure_strategy =
+      fix (fun ins -> choice (one_subterm ins) s)
+
+    let outermost (s : 'a pure_strategy) : 'a pure_strategy =
+      fix (fun out -> choice s (one_subterm out))
+
+    let lemmas cs : 'a pure_strategy =
+      List.fold_left (fun tac (l,l2r,by) ->
+	choice tac (apply_lemma l2r rewrite_unif_flags l by AllOccurrences))
+	fail cs
+
+    let inj_open hint = (); fun sigma ->
+      let ctx = Evd.evar_universe_context_of hint.Autorewrite.rew_ctx in
+      let sigma = Evd.merge_universe_context sigma ctx in
+      (sigma, (EConstr.of_constr hint.Autorewrite.rew_lemma, NoBindings))
+
+    let old_hints (db : string) : 'a pure_strategy =
+      let rules = Autorewrite.find_rewrites db in
+	lemmas
+	  (List.map (fun hint -> (inj_open hint, hint.Autorewrite.rew_l2r,
+				  hint.Autorewrite.rew_tac)) rules)
+
+    let hints (db : string) : 'a pure_strategy = { strategy =
+      fun ({ term1 = t } as input) ->
+      let t = EConstr.Unsafe.to_constr t in
+      let rules = Autorewrite.find_matches db t in
+      let lemma hint = (inj_open hint, hint.Autorewrite.rew_l2r,
+			hint.Autorewrite.rew_tac) in
+      let lems = List.map lemma rules in
+      (lemmas lems).strategy input
+						 }
+
+    let reduce (r : Redexpr.red_expr) : 'a pure_strategy = { strategy =
+	fun { state = state ; env = env ; term1 = t ; ty1 = ty ; cstr = cstr ; evars = evars } ->
+          let rfn, ckind = Redexpr.reduction_of_red_expr env r in
+          let sigma = Sigma.Unsafe.of_evar_map (goalevars evars) in
+	  let Sigma (t', sigma, _) = rfn.Reductionops.e_redfun env sigma t in
+	  let evars' = Sigma.to_evar_map sigma in
+	    if Termops.eq_constr evars' t' t then
+	      state, Identity
+	    else
+	      state, Success { rew_car = ty; rew_from = t; rew_to = t';
+			       rew_prf = RewCast ckind; 
+			       rew_evars = evars', cstrevars evars }
+							   }
+	
+    let fold_glob c : 'a pure_strategy = { strategy =
+      fun { state ; env ; term1 = t ; ty1 = ty ; cstr ; evars } ->
+(* 	let sigma, (c,_) = Tacinterp.interp_open_constr_with_bindings is env (goalevars evars) c in *)
+	let sigma, c = Pretyping.understand_tcc env (goalevars evars) c in
+	let unfolded =
+	  try Tacred.try_red_product env sigma c
+	  with e when CErrors.noncritical e ->
+            error "fold: the term is not unfoldable !"
+	in
+	  try
+	    let sigma = Unification.w_unify env sigma CONV ~flags:(Unification.elim_flags ()) unfolded t in
+	    let c' = Reductionops.nf_evar sigma c in
+	      state, Success { rew_car = ty; rew_from = t; rew_to = c';
+				  rew_prf = RewCast DEFAULTcast;
+				  rew_evars = (sigma, snd evars) }
+	  with e when CErrors.noncritical e -> state, Fail
+					 }
+  
+
+end
+
+(** The strategy for a single rewrite, dealing with occurrences. *)
+
+(** A dummy initial clauseenv to avoid generating initial evars before
+    even finding a first application of the rewriting lemma, in setoid_rewrite
+    mode *)
+
+let rewrite_with l2r flags c occs : strategy = { strategy =
+  fun ({ state = () } as input) ->
+    let unify env evars t =
+      let (sigma, cstrs) = evars in
+      let (sigma, rew) = refresh_hypinfo env sigma c in
+      unify_eqn rew l2r flags env (sigma, cstrs) None t
+    in
+    let app = apply_rule unify occs in
+    let strat = 
+      Strategies.fix (fun aux -> 
+	Strategies.choice app (subterm true default_flags aux))
+    in
+    let _, res = strat.strategy { input with state = 0 } in
+    ((), res)
+					       }
+
+let apply_strategy (s : strategy) env unfresh concl (prop, cstr) evars =
+  let ty = Retyping.get_type_of env (goalevars evars) concl in
+  let _, res = s.strategy { state = () ; env ; unfresh ;
+			    term1 = concl ; ty1 = ty ;
+			    cstr = (prop, Some cstr) ; evars } in
+  res
+
+let solve_constraints env (evars,cstrs) =
+  let filter = all_constraints cstrs in
+    Typeclasses.resolve_typeclasses env ~filter ~split:false ~fail:true 
+      (Typeclasses.mark_resolvables ~filter evars)
+      
+let nf_zeta =
+  Reductionops.clos_norm_flags (CClosure.RedFlags.mkflags [CClosure.RedFlags.fZETA])
+
+exception RewriteFailure of Pp.std_ppcmds
+
+type result = (evar_map * constr option * types) option option
+
+let cl_rewrite_clause_aux ?(abs=None) strat env avoid sigma concl is_hyp : result =
+  let evdref = ref sigma in
+  let sort = Typing.e_sort_of env evdref concl in
+  let evars = (!evdref, Evar.Set.empty) in
+  let evars, cstr =
+    let prop, (evars, arrow) = 
+      if is_prop_sort sort then true, app_poly_sort true env evars impl [||]
+      else false, app_poly_sort false env evars TypeGlobal.arrow [||]
+    in
+      match is_hyp with
+      | None -> 
+	let evars, t = poly_inverse prop env evars (mkSort sort) arrow in 
+	  evars, (prop, t)
+      | Some _ -> evars, (prop, arrow)
+  in
+  let eq = apply_strategy strat env avoid concl cstr evars in
+    match eq with
+    | Fail -> None
+    | Identity -> Some None
+    | Success res ->
+      let (_, cstrs) = res.rew_evars in
+      let evars' = solve_constraints env res.rew_evars in
+      let newt = Reductionops.nf_evar evars' res.rew_to in
+      let evars = (* Keep only original evars (potentially instantiated) and goal evars,
+		     the rest has been defined and substituted already. *)
+	Evar.Set.fold 
+	  (fun ev acc -> 
+	   if not (Evd.is_defined acc ev) then 
+	     user_err ~hdr:"rewrite"
+			  (str "Unsolved constraint remaining: " ++ spc () ++
+			   Termops.pr_evar_info (Evd.find acc ev))
+	   else Evd.remove acc ev) 
+	  cstrs evars'
+      in
+      let res = match res.rew_prf with
+	| RewCast c -> None
+	| RewPrf (rel, p) ->
+	  let p = nf_zeta env evars' (Reductionops.nf_evar evars' p) in
+	  let term =
+	    match abs with
+	    | None -> p
+	    | Some (t, ty) ->
+              let t = Reductionops.nf_evar evars' t in
+              let ty = Reductionops.nf_evar evars' ty in
+		mkApp (mkLambda (Name (Id.of_string "lemma"), ty, p), [| t |])
+	  in
+	  let proof = match is_hyp with
+            | None -> term
+            | Some id -> mkApp (term, [| mkVar id |])
+          in Some proof
+      in Some (Some (evars, res, newt))
+
+(** Insert a declaration after the last declaration it depends on *)
+let rec insert_dependent env sigma decl accu hyps = match hyps with
+| [] -> List.rev_append accu [decl]
+| ndecl :: rem ->
+  if occur_var_in_decl env sigma (NamedDecl.get_id ndecl) decl then
+    List.rev_append accu (decl :: hyps)
+  else
+    insert_dependent env sigma decl (ndecl :: accu) rem
+
+let assert_replacing id newt tac = 
+  let prf = Proofview.Goal.enter { enter = begin fun gl ->
+    let concl = Proofview.Goal.concl gl in
+    let env = Proofview.Goal.env gl in
+    let sigma = Tacmach.New.project gl in
+    let ctx = named_context env in
+    let after, before = List.split_when (NamedDecl.get_id %> Id.equal id) ctx in
+    let nc = match before with
+    | [] -> assert false
+    | d :: rem -> insert_dependent env sigma (LocalAssum (NamedDecl.get_id d, newt)) [] after @ rem
+    in
+    let env' = Environ.reset_with_named_context (val_of_named_context nc) env in
+    Refine.refine ~unsafe:false { run = begin fun sigma ->
+      let Sigma (ev, sigma, p) = Evarutil.new_evar env' sigma concl in
+      let Sigma (ev', sigma, q) = Evarutil.new_evar env sigma newt in
+      let map d =
+        let n = NamedDecl.get_id d in
+        if Id.equal n id then ev' else mkVar n
+      in
+      let (e, _) = destEvar (Sigma.to_evar_map sigma) ev in
+      Sigma (mkEvar (e, Array.map_of_list map nc), sigma, p +> q)
+    end }
+  end } in
+  Proofview.tclTHEN prf (Proofview.tclFOCUS 2 2 tac)
+
+let newfail n s = 
+  Proofview.tclZERO (Refiner.FailError (n, lazy s))
+
+let cl_rewrite_clause_newtac ?abs ?origsigma ~progress strat clause =
+  let open Proofview.Notations in
+  (** For compatibility *)
+  let beta_red _ sigma c = Reductionops.nf_betaiota sigma c in
+  let beta = Tactics.reduct_in_concl (beta_red, DEFAULTcast) in
+  let beta_hyp id = Tactics.reduct_in_hyp beta_red (id, InHyp) in
+  let treat sigma res = 
+    match res with
+    | None -> newfail 0 (str "Nothing to rewrite")
+    | Some None -> if progress then newfail 0 (str"Failed to progress")
+		   else Proofview.tclUNIT ()
+    | Some (Some res) ->
+        let (undef, prf, newt) = res in
+        let fold ev _ accu = if Evd.mem sigma ev then accu else ev :: accu in
+        let gls = List.rev (Evd.fold_undefined fold undef []) in
+	match clause, prf with
+	| Some id, Some p ->
+            let tac = tclTHENLIST [
+              Refine.refine ~unsafe:false { run = fun h -> Sigma.here p h };
+              Proofview.Unsafe.tclNEWGOALS gls;
+            ] in
+            Proofview.Unsafe.tclEVARS undef <*>
+	    tclTHENFIRST (assert_replacing id newt tac) (beta_hyp id)
+	| Some id, None ->
+            Proofview.Unsafe.tclEVARS undef <*>
+            convert_hyp_no_check (LocalAssum (id, newt)) <*>
+            beta_hyp id
+	| None, Some p ->
+            Proofview.Unsafe.tclEVARS undef <*>
+            Proofview.Goal.enter { enter = begin fun gl ->
+            let env = Proofview.Goal.env gl in
+            let make = { run = begin fun sigma ->
+              let Sigma (ev, sigma, q) = Evarutil.new_evar env sigma newt in
+              Sigma (mkApp (p, [| ev |]), sigma, q)
+            end } in
+            Refine.refine ~unsafe:false make <*> Proofview.Unsafe.tclNEWGOALS gls
+            end }
+	| None, None ->
+            Proofview.Unsafe.tclEVARS undef <*>
+            convert_concl_no_check newt DEFAULTcast
+  in
+  Proofview.Goal.enter { enter = begin fun gl ->
+    let concl = Proofview.Goal.concl gl in
+    let env = Proofview.Goal.env gl in
+    let sigma = Tacmach.New.project gl in
+    let ty = match clause with
+    | None -> concl
+    | Some id -> EConstr.of_constr (Environ.named_type id env)
+    in
+    let env = match clause with
+    | None -> env
+    | Some id ->
+      (** Only consider variables not depending on [id] *)
+      let ctx = named_context env in
+      let filter decl = not (occur_var_in_decl env sigma id decl) in
+      let nctx = List.filter filter ctx in
+      Environ.reset_with_named_context (val_of_named_context nctx) env
+    in
+    try
+      let res =
+        cl_rewrite_clause_aux ?abs strat env [] sigma ty clause
+      in
+      let sigma = match origsigma with None -> sigma | Some sigma -> sigma in
+      treat sigma res <*>
+      (** For compatibility *)
+      beta <*> Proofview.shelve_unifiable
+    with
+    | PretypeError (env, evd, (UnsatisfiableConstraints _ as e)) ->
+      raise (RewriteFailure (Himsg.explain_pretype_error env evd e))
+  end }
+
+let tactic_init_setoid () = 
+  try init_setoid (); Proofview.tclUNIT ()
+  with e when CErrors.noncritical e -> Tacticals.New.tclFAIL 0 (str"Setoid library not loaded")
+
+let cl_rewrite_clause_strat progress strat clause =
+  tactic_init_setoid () <*>
+  (if progress then Proofview.tclPROGRESS else fun x -> x)
+   (Proofview.tclOR
+      (cl_rewrite_clause_newtac ~progress strat clause)
+      (fun (e, info) -> match e with
+       | RewriteFailure e ->
+	 tclZEROMSG (str"setoid rewrite failed: " ++ e)
+       | Refiner.FailError (n, pp) -> 
+	  tclFAIL n (str"setoid rewrite failed: " ++ Lazy.force pp)
+       | e -> Proofview.tclZERO ~info e))
+
+(** Setoid rewriting when called with "setoid_rewrite" *)
+let cl_rewrite_clause l left2right occs clause =
+  let strat = rewrite_with left2right (general_rewrite_unif_flags ()) l occs in
+    cl_rewrite_clause_strat true strat clause
+
+(** Setoid rewriting when called with "rewrite_strat" *)
+let cl_rewrite_clause_strat strat clause =
+  cl_rewrite_clause_strat false strat clause
+  
+let apply_glob_constr c l2r occs = (); fun ({ state = () ; env = env } as input) ->
+  let c sigma =
+    let (sigma, c) = Pretyping.understand_tcc env sigma c in
+    (sigma, (c, NoBindings))
+  in
+  let flags = general_rewrite_unif_flags () in
+  (apply_lemma l2r flags c None occs).strategy input
+
+let interp_glob_constr_list env =
+  let make c = (); fun sigma ->
+    let sigma, c = Pretyping.understand_tcc env sigma c in
+    (sigma, (c, NoBindings))
+  in
+  List.map (fun c -> make c, true, None)
+
+(* Syntax for rewriting with strategies *)
+
+type unary_strategy = 
+    Subterms | Subterm | Innermost | Outermost
+  | Bottomup | Topdown | Progress | Try | Any | Repeat
+
+type binary_strategy = 
+  | Compose | Choice
+
+type ('constr,'redexpr) strategy_ast = 
+  | StratId | StratFail | StratRefl
+  | StratUnary of unary_strategy * ('constr,'redexpr) strategy_ast
+  | StratBinary of binary_strategy 
+    * ('constr,'redexpr) strategy_ast * ('constr,'redexpr) strategy_ast
+  | StratConstr of 'constr * bool
+  | StratTerms of 'constr list
+  | StratHints of bool * string
+  | StratEval of 'redexpr 
+  | StratFold of 'constr
+
+let rec map_strategy (f : 'a -> 'a2) (g : 'b -> 'b2) : ('a,'b) strategy_ast -> ('a2,'b2) strategy_ast = function
+  | StratId | StratFail | StratRefl as s -> s
+  | StratUnary (s, str) -> StratUnary (s, map_strategy f g str)
+  | StratBinary (s, str, str') -> StratBinary (s, map_strategy f g str, map_strategy f g str')
+  | StratConstr (c, b) -> StratConstr (f c, b)
+  | StratTerms l -> StratTerms (List.map f l)
+  | StratHints (b, id) -> StratHints (b, id)
+  | StratEval r -> StratEval (g r)
+  | StratFold c -> StratFold (f c)
+
+let pr_ustrategy = function
+| Subterms -> str "subterms"
+| Subterm -> str "subterm"
+| Innermost -> str "innermost"
+| Outermost -> str "outermost"
+| Bottomup -> str "bottomup"
+| Topdown -> str "topdown"
+| Progress -> str "progress"
+| Try -> str "try"
+| Any -> str "any"
+| Repeat -> str "repeat"
+
+let paren p = str "(" ++ p ++ str ")"
+
+let rec pr_strategy prc prr = function
+| StratId -> str "id"
+| StratFail -> str "fail"
+| StratRefl -> str "refl"
+| StratUnary (s, str) ->
+  pr_ustrategy s ++ spc () ++ paren (pr_strategy prc prr str)
+| StratBinary (Choice, str1, str2) ->
+  str "choice" ++ spc () ++ paren (pr_strategy prc prr str1) ++ spc () ++
+    paren (pr_strategy prc prr str2)
+| StratBinary (Compose, str1, str2) ->
+  pr_strategy prc prr str1 ++ str ";" ++ spc () ++ pr_strategy prc prr str2
+| StratConstr (c, true) -> prc c
+| StratConstr (c, false) -> str "<-" ++ spc () ++ prc c
+| StratTerms cl -> str "terms" ++ spc () ++ pr_sequence prc cl
+| StratHints (old, id) ->
+  let cmd = if old then "old_hints" else "hints" in
+  str cmd ++ spc () ++ str id
+| StratEval r -> str "eval" ++ spc () ++ prr r
+| StratFold c -> str "fold" ++ spc () ++ prc c
+
+let rec strategy_of_ast = function
+  | StratId -> Strategies.id
+  | StratFail -> Strategies.fail
+  | StratRefl -> Strategies.refl
+  | StratUnary (f, s) -> 
+    let s' = strategy_of_ast s in
+    let f' = match f with
+      | Subterms -> all_subterms
+      | Subterm -> one_subterm
+      | Innermost -> Strategies.innermost
+      | Outermost -> Strategies.outermost
+      | Bottomup -> Strategies.bu
+      | Topdown -> Strategies.td
+      | Progress -> Strategies.progress
+      | Try -> Strategies.try_
+      | Any -> Strategies.any
+      | Repeat -> Strategies.repeat
+    in f' s'
+  | StratBinary (f, s, t) ->
+    let s' = strategy_of_ast s in
+    let t' = strategy_of_ast t in
+    let f' = match f with
+      | Compose -> Strategies.seq
+      | Choice -> Strategies.choice
+    in f' s' t'
+  | StratConstr (c, b) -> { strategy = apply_glob_constr (fst c) b AllOccurrences }
+  | StratHints (old, id) -> if old then Strategies.old_hints id else Strategies.hints id
+  | StratTerms l -> { strategy =
+    (fun ({ state = () ; env } as input) ->
+     let l' = interp_glob_constr_list env (List.map fst l) in
+     (Strategies.lemmas l').strategy input)
+		    }
+  | StratEval r -> { strategy =
+    (fun ({ state = () ; env ; evars } as input) ->
+     let (sigma,r_interp) = Tacinterp.interp_redexp env (goalevars evars) r in
+     (Strategies.reduce r_interp).strategy { input with
+					     evars = (sigma,cstrevars evars) }) }
+  | StratFold c -> Strategies.fold_glob (fst c)
+
+
+(* By default the strategy for "rewrite_db" is top-down *)
+
+let mkappc s l = CAppExpl (Loc.ghost,(None,(Libnames.Ident (Loc.ghost,Id.of_string s)),None),l)
+
+let declare_an_instance n s args =
+  (((Loc.ghost,Name n),None), Explicit,
+  CAppExpl (Loc.ghost, (None, Qualid (Loc.ghost, qualid_of_string s),None),
+	   args))
+
+let declare_instance a aeq n s = declare_an_instance n s [a;aeq]
+
+let anew_instance global binders instance fields =
+  new_instance (Flags.is_universe_polymorphism ()) 
+    binders instance (Some (true, CRecord (Loc.ghost,fields)))
+    ~global ~generalize:false ~refine:false Hints.empty_hint_info
+
+let declare_instance_refl global binders a aeq n lemma =
+  let instance = declare_instance a aeq (add_suffix n "_Reflexive") "Coq.Classes.RelationClasses.Reflexive"
+  in anew_instance global binders instance
+       [(Ident (Loc.ghost,Id.of_string "reflexivity"),lemma)]
+
+let declare_instance_sym global binders a aeq n lemma =
+  let instance = declare_instance a aeq (add_suffix n "_Symmetric") "Coq.Classes.RelationClasses.Symmetric"
+  in anew_instance global binders instance
+       [(Ident (Loc.ghost,Id.of_string "symmetry"),lemma)]
+
+let declare_instance_trans global binders a aeq n lemma =
+  let instance = declare_instance a aeq (add_suffix n "_Transitive") "Coq.Classes.RelationClasses.Transitive"
+  in anew_instance global binders instance
+       [(Ident (Loc.ghost,Id.of_string "transitivity"),lemma)]
+
+let declare_relation ?(binders=[]) a aeq n refl symm trans =
+  init_setoid ();
+  let global = not (Locality.make_section_locality (Locality.LocalityFixme.consume ())) in
+  let instance = declare_instance a aeq (add_suffix n "_relation") "Coq.Classes.RelationClasses.RewriteRelation"
+  in ignore(anew_instance global binders instance []);
+  match (refl,symm,trans) with
+      (None, None, None) -> ()
+    | (Some lemma1, None, None) ->
+	ignore (declare_instance_refl global binders a aeq n lemma1)
+    | (None, Some lemma2, None) ->
+	ignore (declare_instance_sym global binders a aeq n lemma2)
+    | (None, None, Some lemma3) ->
+	ignore (declare_instance_trans global binders a aeq n lemma3)
+    | (Some lemma1, Some lemma2, None) ->
+	ignore (declare_instance_refl global binders a aeq n lemma1);
+	ignore (declare_instance_sym global binders a aeq n lemma2)
+    | (Some lemma1, None, Some lemma3) ->
+	let _lemma_refl = declare_instance_refl global binders a aeq n lemma1 in
+	let _lemma_trans = declare_instance_trans global binders a aeq n lemma3 in
+	let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.PreOrder"
+	in ignore(
+	    anew_instance global binders instance
+	      [(Ident (Loc.ghost,Id.of_string "PreOrder_Reflexive"), lemma1);
+	       (Ident (Loc.ghost,Id.of_string "PreOrder_Transitive"),lemma3)])
+    | (None, Some lemma2, Some lemma3) ->
+	let _lemma_sym = declare_instance_sym global binders a aeq n lemma2 in
+	let _lemma_trans = declare_instance_trans global binders a aeq n lemma3 in
+	let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.PER"
+	in ignore(
+	    anew_instance global binders instance
+	      [(Ident (Loc.ghost,Id.of_string "PER_Symmetric"), lemma2);
+	       (Ident (Loc.ghost,Id.of_string "PER_Transitive"),lemma3)])
+     | (Some lemma1, Some lemma2, Some lemma3) ->
+	let _lemma_refl = declare_instance_refl global binders a aeq n lemma1 in
+	let _lemma_sym = declare_instance_sym global binders a aeq n lemma2 in
+	let _lemma_trans = declare_instance_trans global binders a aeq n lemma3 in
+	let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.Equivalence"
+	in ignore(
+	  anew_instance global binders instance
+	    [(Ident (Loc.ghost,Id.of_string "Equivalence_Reflexive"), lemma1);
+	     (Ident (Loc.ghost,Id.of_string "Equivalence_Symmetric"), lemma2);
+	     (Ident (Loc.ghost,Id.of_string "Equivalence_Transitive"), lemma3)])
+
+let cHole = CHole (Loc.ghost, None, Misctypes.IntroAnonymous, None)
+
+let proper_projection sigma r ty =
+  let rel_vect n m = Array.init m (fun i -> mkRel(n+m-i)) in
+  let ctx, inst = decompose_prod_assum sigma ty in
+  let mor, args = destApp sigma inst in
+  let instarg = mkApp (r, rel_vect 0 (List.length ctx)) in
+  let app = mkApp (Lazy.force PropGlobal.proper_proj,
+		  Array.append args [| instarg |]) in
+    it_mkLambda_or_LetIn app ctx
+
+let declare_projection n instance_id r =
+  let poly = Global.is_polymorphic r in
+  let env = Global.env () in
+  let sigma = Evd.from_env env in
+  let sigma,c = Evd.fresh_global env sigma r in
+  let c = EConstr.of_constr c in
+  let ty = Retyping.get_type_of env sigma c in
+  let term = proper_projection sigma c ty in
+  let sigma, typ = Typing.type_of env sigma term in
+  let ctx, typ = decompose_prod_assum sigma typ in
+  let typ =
+    let n =
+      let rec aux t =
+	match EConstr.kind sigma t with
+	| App (f, [| a ; a' ; rel; rel' |]) 
+	    when Termops.is_global sigma (PropGlobal.respectful_ref ()) f ->
+	  succ (aux rel')
+	| _ -> 0
+      in
+      let init =
+	match EConstr.kind sigma typ with
+	    App (f, args) when Termops.is_global sigma (PropGlobal.respectful_ref ()) f  ->
+	      mkApp (f, fst (Array.chop (Array.length args - 2) args))
+	  | _ -> typ
+      in aux init
+    in
+    let ctx,ccl = Reductionops.splay_prod_n env sigma (3 * n) typ
+    in it_mkProd_or_LetIn ccl ctx
+  in
+  let typ = it_mkProd_or_LetIn typ ctx in
+  let pl, ctx = Evd.universe_context sigma in
+  let typ = EConstr.to_constr sigma typ in
+  let term = EConstr.to_constr sigma term in
+  let cst = 
+    Declare.definition_entry ~types:typ ~poly ~univs:ctx term
+  in
+    ignore(Declare.declare_constant n 
+	   (Entries.DefinitionEntry cst, Decl_kinds.IsDefinition Decl_kinds.Definition))
+
+let build_morphism_signature env sigma m =
+  let m,ctx = Constrintern.interp_constr env sigma m in
+  let m = EConstr.of_constr m in
+  let sigma = Evd.from_ctx ctx in
+  let t = Typing.unsafe_type_of env sigma m in
+  let cstrs =
+    let rec aux t =
+      match EConstr.kind sigma t with
+	| Prod (na, a, b) ->
+	    None :: aux b
+	| _ -> []
+    in aux t
+  in
+  let evars, t', sig_, cstrs = 
+    PropGlobal.build_signature (sigma, Evar.Set.empty) env t cstrs None in
+  let evd = ref evars in
+  let _ = List.iter
+    (fun (ty, rel) ->
+      Option.iter (fun rel ->
+	let default = e_app_poly env evd PropGlobal.default_relation [| ty; rel |] in
+	  ignore(e_new_cstr_evar env evd default))
+	rel)
+    cstrs
+  in
+  let morph = e_app_poly env evd PropGlobal.proper_type [| t; sig_; m |] in
+  let evd = solve_constraints env !evd in
+  let evd = Evd.nf_constraints evd in
+  let m = Evarutil.nf_evars_universes evd (EConstr.Unsafe.to_constr morph) in
+  Pretyping.check_evars env Evd.empty evd (EConstr.of_constr m);
+  Evd.evar_universe_context evd, m
+
+let default_morphism sign m =
+  let env = Global.env () in
+  let sigma = Evd.from_env env in
+  let t = Typing.unsafe_type_of env sigma m in
+  let evars, _, sign, cstrs =
+    PropGlobal.build_signature (sigma, Evar.Set.empty) env t (fst sign) (snd sign)
+  in
+  let evars, morph = app_poly_check env evars PropGlobal.proper_type [| t; sign; m |] in
+  let evars, mor = resolve_one_typeclass env (goalevars evars) morph in
+    mor, proper_projection sigma mor morph
+
+let add_setoid global binders a aeq t n =
+  init_setoid ();
+  let _lemma_refl = declare_instance_refl global binders a aeq n (mkappc "Seq_refl" [a;aeq;t]) in
+  let _lemma_sym = declare_instance_sym global binders a aeq n (mkappc "Seq_sym" [a;aeq;t]) in
+  let _lemma_trans = declare_instance_trans global binders a aeq n (mkappc "Seq_trans" [a;aeq;t]) in
+  let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.Equivalence"
+  in ignore(
+    anew_instance global binders instance
+      [(Ident (Loc.ghost,Id.of_string "Equivalence_Reflexive"), mkappc "Seq_refl" [a;aeq;t]);
+       (Ident (Loc.ghost,Id.of_string "Equivalence_Symmetric"), mkappc "Seq_sym" [a;aeq;t]);
+       (Ident (Loc.ghost,Id.of_string "Equivalence_Transitive"), mkappc "Seq_trans" [a;aeq;t])])
+
+
+let make_tactic name =
+  let open Tacexpr in
+  let loc = Loc.ghost in
+  let tacpath = Libnames.qualid_of_string name in
+  let tacname = Qualid (loc, tacpath) in
+  TacArg (loc, TacCall (loc, tacname, []))
+
+let add_morphism_infer glob m n =
+  init_setoid ();
+  let poly = Flags.is_universe_polymorphism () in
+  let instance_id = add_suffix n "_Proper" in
+  let env = Global.env () in
+  let evd = Evd.from_env env in
+  let uctx, instance = build_morphism_signature env evd m in
+    if Lib.is_modtype () then
+      let cst = Declare.declare_constant ~internal:Declare.InternalTacticRequest instance_id
+				(Entries.ParameterEntry 
+				 (None,poly,(instance,Evd.evar_context_universe_context uctx),None), 
+				 Decl_kinds.IsAssumption Decl_kinds.Logical)
+      in
+	add_instance (Typeclasses.new_instance 
+			(Lazy.force PropGlobal.proper_class) Hints.empty_hint_info glob
+			poly (ConstRef cst));
+	declare_projection n instance_id (ConstRef cst)
+    else
+      let kind = Decl_kinds.Global, poly, 
+	Decl_kinds.DefinitionBody Decl_kinds.Instance 
+      in
+      let tac = make_tactic "Coq.Classes.SetoidTactics.add_morphism_tactic" in
+      let hook _ = function
+	| Globnames.ConstRef cst ->
+	  add_instance (Typeclasses.new_instance 
+			  (Lazy.force PropGlobal.proper_class) Hints.empty_hint_info
+			  glob poly (ConstRef cst));
+	  declare_projection n instance_id (ConstRef cst)
+	| _ -> assert false
+      in
+      let hook = Lemmas.mk_hook hook in
+	Flags.silently
+	  (fun () ->
+	    Lemmas.start_proof instance_id kind (Evd.from_ctx uctx) (EConstr.of_constr instance) hook;
+	    ignore (Pfedit.by (Tacinterp.interp tac))) ()
+
+let add_morphism glob binders m s n =
+  init_setoid ();
+  let poly = Flags.is_universe_polymorphism () in
+  let instance_id = add_suffix n "_Proper" in
+  let instance =
+    (((Loc.ghost,Name instance_id),None), Explicit,
+    CAppExpl (Loc.ghost,
+	     (None, Qualid (Loc.ghost, Libnames.qualid_of_string "Coq.Classes.Morphisms.Proper"),None),
+	     [cHole; s; m]))
+  in
+  let tac = Tacinterp.interp (make_tactic "add_morphism_tactic") in
+    ignore(new_instance ~global:glob poly binders instance 
+	     (Some (true, CRecord (Loc.ghost,[])))
+	      ~generalize:false ~tac ~hook:(declare_projection n instance_id) Hints.empty_hint_info)
+
+(** Bind to "rewrite" too *)
+
+(** Taken from original setoid_replace, to emulate the old rewrite semantics where
+    lemmas are first instantiated and then rewrite proceeds. *)
+
+let check_evar_map_of_evars_defs evd =
+ let metas = Evd.meta_list evd in
+ let check_freemetas_is_empty rebus =
+  Evd.Metaset.iter
+   (fun m ->
+     if Evd.meta_defined evd m then () else
+      raise
+	(Logic.RefinerError (Logic.UnresolvedBindings [Evd.meta_name evd m])))
+ in
+  List.iter
+   (fun (_,binding) ->
+     match binding with
+        Evd.Cltyp (_,{Evd.rebus=rebus; Evd.freemetas=freemetas}) ->
+         check_freemetas_is_empty rebus freemetas
+      | Evd.Clval (_,({Evd.rebus=rebus1; Evd.freemetas=freemetas1},_),
+                 {Evd.rebus=rebus2; Evd.freemetas=freemetas2}) ->
+         check_freemetas_is_empty rebus1 freemetas1 ;
+         check_freemetas_is_empty rebus2 freemetas2
+   ) metas
+
+(* Find a subterm which matches the pattern to rewrite for "rewrite" *)
+let unification_rewrite l2r c1 c2 sigma prf car rel but env =
+  let (sigma,c') =
+    try
+      (* ~flags:(false,true) to allow to mark occurrences that must not be
+         rewritten simply by replacing them with let-defined definitions
+         in the context *)
+      Unification.w_unify_to_subterm 
+       ~flags:rewrite_unif_flags
+        env sigma ((if l2r then c1 else c2),but)
+    with
+    | ex when Pretype_errors.precatchable_exception ex ->
+	(* ~flags:(true,true) to make Ring work (since it really
+           exploits conversion) *)
+      Unification.w_unify_to_subterm 
+        ~flags:rewrite_conv_unif_flags
+        env sigma ((if l2r then c1 else c2),but)
+  in
+  let nf c = Reductionops.nf_evar sigma c in
+  let c1 = if l2r then nf c' else nf c1
+  and c2 = if l2r then nf c2 else nf c'
+  and car = nf car and rel = nf rel in
+  check_evar_map_of_evars_defs sigma;
+  let prf = nf prf in
+  let prfty = nf (Retyping.get_type_of env sigma prf) in
+  let sort = sort_of_rel env sigma but in
+  let abs = prf, prfty in
+  let prf = mkRel 1 in
+  let res = (car, rel, prf, c1, c2) in
+  abs, sigma, res, Sorts.is_prop sort
+
+let get_hyp gl (c,l) clause l2r =
+  let evars = Tacmach.New.project gl in
+  let env = Tacmach.New.pf_env gl in
+  let sigma, hi = decompose_applied_relation env evars (c,l) in
+  let but = match clause with
+    | Some id -> Tacmach.New.pf_get_hyp_typ id gl
+    | None -> Reductionops.nf_evar evars (Tacmach.New.pf_concl gl)
+  in
+  unification_rewrite l2r hi.c1 hi.c2 sigma hi.prf hi.car hi.rel but env
+
+let general_rewrite_flags = { under_lambdas = false; on_morphisms = true }
+
+(* let rewriteclaustac_key = Profile.declare_profile "cl_rewrite_clause_tac";; *)
+(* let cl_rewrite_clause_tac = Profile.profile5 rewriteclaustac_key cl_rewrite_clause_tac *)
+
+(** Setoid rewriting when called with "rewrite" *)
+let general_s_rewrite cl l2r occs (c,l) ~new_goals =
+  Proofview.Goal.enter { enter = begin fun gl ->
+  let abs, evd, res, sort = get_hyp gl (c,l) cl l2r in
+  let unify env evars t = unify_abs res l2r sort env evars t in
+  let app = apply_rule unify occs in
+  let recstrat aux = Strategies.choice app (subterm true general_rewrite_flags aux) in
+  let substrat = Strategies.fix recstrat in
+  let strat = { strategy = fun ({ state = () } as input) ->
+    let _, res = substrat.strategy { input with state = 0 } in
+    (), res
+	      }
+  in
+  let origsigma = Tacmach.New.project gl in
+  tactic_init_setoid () <*>
+    Proofview.tclOR
+      (tclPROGRESS
+	(tclTHEN
+           (Proofview.Unsafe.tclEVARS evd)
+	    (cl_rewrite_clause_newtac ~progress:true ~abs:(Some abs) ~origsigma strat cl)))
+    (fun (e, info) -> match e with
+    | RewriteFailure e ->
+      tclFAIL 0 (str"setoid rewrite failed: " ++ e)
+    | e -> Proofview.tclZERO ~info e)
+  end }
+
+let _ = Hook.set Equality.general_setoid_rewrite_clause general_s_rewrite
+
+(** [setoid_]{reflexivity,symmetry,transitivity} tactics *)
+
+let not_declared env sigma ty rel =
+  tclFAIL 0
+    (str" The relation " ++ Printer.pr_econstr_env env sigma rel ++ str" is not a declared " ++
+     str ty ++ str" relation. Maybe you need to require the Coq.Classes.RelationClasses library")
+
+let setoid_proof ty fn fallback =
+  Proofview.Goal.enter { enter = begin fun gl ->
+    let env = Proofview.Goal.env gl in
+    let sigma = Tacmach.New.project gl in
+    let concl = Proofview.Goal.concl gl in
+    Proofview.tclORELSE
+      begin
+        try
+          let rel, _, _ = decompose_app_rel env sigma concl in
+          let (sigma, t) = Typing.type_of env sigma rel in
+          let car = snd (List.hd (fst (Reductionops.splay_prod env sigma t))) in
+	    (try init_relation_classes () with _ -> raise Not_found);
+            fn env sigma car rel
+        with e -> Proofview.tclZERO e
+      end
+      begin function
+        | e ->
+            Proofview.tclORELSE
+              fallback
+              begin function (e', info) -> match e' with
+                | Hipattern.NoEquationFound ->
+	            begin match e with
+	            | (Not_found, _) ->
+	                let rel, _, _ = decompose_app_rel env sigma concl in
+		        not_declared env sigma ty rel
+	            | (e, info) -> Proofview.tclZERO ~info e
+                    end
+                | e' -> Proofview.tclZERO ~info e'
+              end
+      end
+  end }
+
+let tac_open ((evm,_), c) tac = 
+    (tclTHEN (Proofview.Unsafe.tclEVARS evm) (tac c))
+
+let poly_proof getp gett env evm car rel =
+  if Sorts.is_prop (sort_of_rel env evm rel) then
+    getp env (evm,Evar.Set.empty) car rel
+  else gett env (evm,Evar.Set.empty) car rel
+
+let setoid_reflexivity =
+  setoid_proof "reflexive"
+    (fun env evm car rel -> 
+     tac_open (poly_proof PropGlobal.get_reflexive_proof
+			  TypeGlobal.get_reflexive_proof
+			  env evm car rel)
+	      (fun c -> tclCOMPLETE (apply c)))
+    (reflexivity_red true)
+
+let setoid_symmetry =
+  setoid_proof "symmetric"
+    (fun env evm car rel -> 
+      tac_open
+	(poly_proof PropGlobal.get_symmetric_proof TypeGlobal.get_symmetric_proof
+	   env evm car rel)
+	(fun c -> apply c))
+    (symmetry_red true)
+    
+let setoid_transitivity c =
+  setoid_proof "transitive"
+    (fun env evm car rel ->
+      tac_open (poly_proof PropGlobal.get_transitive_proof TypeGlobal.get_transitive_proof
+	   env evm car rel)
+	(fun proof -> match c with
+	| None -> eapply proof
+	| Some c -> apply_with_bindings (proof,ImplicitBindings [ c ])))
+    (transitivity_red true c)
+    
+let setoid_symmetry_in id =
+  Proofview.V82.tactic (fun gl ->
+  let sigma = project gl in
+  let ctype = pf_unsafe_type_of gl (mkVar id) in
+  let binders,concl = decompose_prod_assum sigma ctype in
+  let (equiv, args) = decompose_app sigma concl in
+  let rec split_last_two = function
+    | [c1;c2] -> [],(c1, c2)
+    | x::y::z -> let l,res = split_last_two (y::z) in x::l, res
+    | _ -> error "Cannot find an equivalence relation to rewrite."
+  in
+  let others,(c1,c2) = split_last_two args in
+  let he,c1,c2 =  mkApp (equiv, Array.of_list others),c1,c2 in
+  let new_hyp' =  mkApp (he, [| c2 ; c1 |]) in
+  let new_hyp = it_mkProd_or_LetIn new_hyp'  binders in
+   Proofview.V82.of_tactic
+    (tclTHENLAST
+      (Tactics.assert_after_replacing id new_hyp)
+      (tclTHENLIST [ intros; setoid_symmetry; apply (mkVar id); Tactics.assumption ]))
+      gl)
+
+let _ = Hook.set Tactics.setoid_reflexivity setoid_reflexivity
+let _ = Hook.set Tactics.setoid_symmetry setoid_symmetry
+let _ = Hook.set Tactics.setoid_symmetry_in setoid_symmetry_in
+let _ = Hook.set Tactics.setoid_transitivity setoid_transitivity
+
+let get_lemma_proof f env evm x y = 
+  let (evm, _), c = f env (evm,Evar.Set.empty) x y in
+    evm, c
+
+let get_reflexive_proof =
+  get_lemma_proof PropGlobal.get_reflexive_proof
+
+let get_symmetric_proof = 
+  get_lemma_proof PropGlobal.get_symmetric_proof
+
+let get_transitive_proof = 
+  get_lemma_proof PropGlobal.get_transitive_proof
+  
diff --git a/plugins/ltac/rewrite.mli b/plugins/ltac/rewrite.mli
new file mode 100644
index 000000000..10fec2032
--- /dev/null
+++ b/plugins/ltac/rewrite.mli
@@ -0,0 +1,118 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+open Names
+open Constr
+open Environ
+open EConstr
+open Constrexpr
+open Tacexpr
+open Misctypes
+open Evd
+open Proof_type
+open Tacinterp
+
+(** TODO: document and clean me! *)
+
+type unary_strategy = 
+    Subterms | Subterm | Innermost | Outermost
+  | Bottomup | Topdown | Progress | Try | Any | Repeat
+
+type binary_strategy = 
+  | Compose | Choice
+
+type ('constr,'redexpr) strategy_ast = 
+  | StratId | StratFail | StratRefl
+  | StratUnary of unary_strategy * ('constr,'redexpr) strategy_ast
+  | StratBinary of binary_strategy 
+    * ('constr,'redexpr) strategy_ast * ('constr,'redexpr) strategy_ast
+  | StratConstr of 'constr * bool
+  | StratTerms of 'constr list
+  | StratHints of bool * string
+  | StratEval of 'redexpr 
+  | StratFold of 'constr
+
+type rewrite_proof = 
+  | RewPrf of constr * constr
+  | RewCast of cast_kind
+
+type evars = evar_map * Evar.Set.t (* goal evars, constraint evars *)
+
+type rewrite_result_info = {
+  rew_car : constr;
+  rew_from : constr;
+  rew_to : constr;
+  rew_prf : rewrite_proof;
+  rew_evars : evars;
+}
+
+type rewrite_result =
+| Fail
+| Identity
+| Success of rewrite_result_info
+
+type strategy
+
+val strategy_of_ast : (glob_constr_and_expr, raw_red_expr) strategy_ast -> strategy
+
+val map_strategy : ('a -> 'b) -> ('c -> 'd) ->
+  ('a, 'c) strategy_ast -> ('b, 'd) strategy_ast
+
+val pr_strategy : ('a -> Pp.std_ppcmds) -> ('b -> Pp.std_ppcmds) ->
+  ('a, 'b) strategy_ast -> Pp.std_ppcmds
+
+(** Entry point for user-level "rewrite_strat" *)
+val cl_rewrite_clause_strat : strategy -> Id.t option -> unit Proofview.tactic
+
+(** Entry point for user-level "setoid_rewrite" *)
+val cl_rewrite_clause :
+  interp_sign * (glob_constr_and_expr * glob_constr_and_expr bindings) ->
+  bool -> Locus.occurrences -> Id.t option -> unit Proofview.tactic
+
+val is_applied_rewrite_relation :
+  env -> evar_map -> rel_context -> constr -> types option
+
+val declare_relation :
+  ?binders:local_binder list -> constr_expr -> constr_expr -> Id.t ->
+  constr_expr option -> constr_expr option -> constr_expr option -> unit
+
+val add_setoid :
+  bool -> local_binder list -> constr_expr -> constr_expr -> constr_expr ->
+  Id.t -> unit
+
+val add_morphism_infer : bool -> constr_expr -> Id.t -> unit
+
+val add_morphism :
+  bool -> local_binder list -> constr_expr -> constr_expr -> Id.t -> unit
+
+val get_reflexive_proof : env -> evar_map -> constr -> constr -> evar_map * constr
+
+val get_symmetric_proof : env -> evar_map -> constr -> constr -> evar_map * constr
+
+val get_transitive_proof : env -> evar_map -> constr -> constr -> evar_map * constr
+
+val default_morphism :
+  (types * constr option) option list * (types * types option) option ->
+  constr -> constr * constr
+
+val setoid_symmetry : unit Proofview.tactic
+
+val setoid_symmetry_in : Id.t -> unit Proofview.tactic
+
+val setoid_reflexivity : unit Proofview.tactic
+
+val setoid_transitivity : constr option -> unit Proofview.tactic
+
+
+val apply_strategy :
+  strategy ->
+  Environ.env ->
+  Names.Id.t list ->
+  constr ->
+  bool * constr ->
+  evars -> rewrite_result
diff --git a/plugins/ltac/tacarg.ml b/plugins/ltac/tacarg.ml
new file mode 100644
index 000000000..42552c484
--- /dev/null
+++ b/plugins/ltac/tacarg.ml
@@ -0,0 +1,26 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(** Generic arguments based on Ltac. *)
+
+open Genarg
+open Geninterp
+open Tacexpr
+
+let make0 ?dyn name =
+  let wit = Genarg.make0 name in
+  let () = Geninterp.register_val0 wit dyn in
+  wit
+
+let wit_tactic : (raw_tactic_expr, glob_tactic_expr, Val.t) genarg_type =
+  make0 "tactic"
+
+let wit_ltac = make0 ~dyn:(val_tag (topwit Stdarg.wit_unit)) "ltac"
+
+let wit_destruction_arg =
+  make0 "destruction_arg"
diff --git a/plugins/ltac/tacarg.mli b/plugins/ltac/tacarg.mli
new file mode 100644
index 000000000..bfa423db2
--- /dev/null
+++ b/plugins/ltac/tacarg.mli
@@ -0,0 +1,27 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+open Genarg
+open Tacexpr
+open Constrexpr
+open Misctypes
+
+(** Generic arguments based on Ltac. *)
+
+val wit_tactic : (raw_tactic_expr, glob_tactic_expr, Geninterp.Val.t) genarg_type
+
+(** [wit_ltac] is subtly different from [wit_tactic]: they only change for their
+    toplevel interpretation. The one of [wit_ltac] forces the tactic and
+    discards the result. *)
+val wit_ltac : (raw_tactic_expr, glob_tactic_expr, unit) genarg_type
+
+val wit_destruction_arg :
+  (constr_expr with_bindings Tacexpr.destruction_arg,
+   glob_constr_and_expr with_bindings Tacexpr.destruction_arg,
+   delayed_open_constr_with_bindings Tacexpr.destruction_arg) genarg_type
+
diff --git a/plugins/ltac/taccoerce.ml b/plugins/ltac/taccoerce.ml
new file mode 100644
index 000000000..114b8dda0
--- /dev/null
+++ b/plugins/ltac/taccoerce.ml
@@ -0,0 +1,345 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+open Util
+open Names
+open Term
+open EConstr
+open Pattern
+open Misctypes
+open Genarg
+open Stdarg
+open Geninterp
+
+exception CannotCoerceTo of string
+
+let (wit_constr_context : (Empty.t, Empty.t, EConstr.constr) Genarg.genarg_type) =
+  let wit = Genarg.create_arg "constr_context" in
+  let () = register_val0 wit None in
+  wit
+
+(* includes idents known to be bound and references *)
+let (wit_constr_under_binders : (Empty.t, Empty.t, constr_under_binders) Genarg.genarg_type) =
+  let wit = Genarg.create_arg "constr_under_binders" in
+  let () = register_val0 wit None in
+  wit
+
+(** All the types considered here are base types *)
+let val_tag wit = match val_tag wit with
+| Val.Base t -> t
+| _ -> assert false
+
+let has_type : type a. Val.t -> a typed_abstract_argument_type -> bool = fun v wit ->
+  let Val.Dyn (t, _) = v in
+  match Val.eq t (val_tag wit) with
+  | None -> false
+  | Some Refl -> true
+
+let prj : type a. a Val.typ -> Val.t -> a option = fun t v ->
+  let Val.Dyn (t', x) = v in
+  match Val.eq t t' with
+  | None -> None
+  | Some Refl -> Some x
+
+let in_gen wit v = Val.Dyn (val_tag wit, v)
+let out_gen wit v = match prj (val_tag wit) v with None -> assert false | Some x -> x
+
+module Value =
+struct
+
+type t = Val.t
+
+let normalize v = v
+
+let of_constr c = in_gen (topwit wit_constr) c
+
+let to_constr v =
+  let v = normalize v in
+  if has_type v (topwit wit_constr) then
+    let c = out_gen (topwit wit_constr) v in
+    Some c
+  else if has_type v (topwit wit_constr_under_binders) then
+    let vars, c = out_gen (topwit wit_constr_under_binders) v in
+    match vars with [] -> Some c | _ -> None
+  else None
+
+let of_uconstr c = in_gen (topwit wit_uconstr) c
+
+let to_uconstr v =
+  let v = normalize v in
+  if has_type v (topwit wit_uconstr) then
+    Some (out_gen (topwit wit_uconstr) v)
+  else None
+
+let of_int i = in_gen (topwit wit_int) i
+
+let to_int v =
+  let v = normalize v in
+  if has_type v (topwit wit_int) then
+    Some (out_gen (topwit wit_int) v)
+  else None
+
+let to_list v = prj Val.typ_list v
+
+let to_option v = prj Val.typ_opt v
+
+let to_pair v = prj Val.typ_pair v
+
+end
+
+let is_variable env id =
+  Id.List.mem id (Termops.ids_of_named_context (Environ.named_context env))
+
+(* Transforms an id into a constr if possible, or fails with Not_found *)
+let constr_of_id env id =
+  EConstr.mkVar (let _ = Environ.lookup_named id env in id)
+
+(* Gives the constr corresponding to a Constr_context tactic_arg *)
+let coerce_to_constr_context v =
+  let v = Value.normalize v in
+  if has_type v (topwit wit_constr_context) then
+    out_gen (topwit wit_constr_context) v
+  else raise (CannotCoerceTo "a term context")
+
+(* Interprets an identifier which must be fresh *)
+let coerce_var_to_ident fresh env sigma v =
+  let v = Value.normalize v in
+  let fail () = raise (CannotCoerceTo "a fresh identifier") in
+  if has_type v (topwit wit_intro_pattern) then
+    match out_gen (topwit wit_intro_pattern) v with
+    | _, IntroNaming (IntroIdentifier id) -> id
+    | _ -> fail ()
+  else if has_type v (topwit wit_var) then
+    out_gen (topwit wit_var) v
+  else match Value.to_constr v with
+  | None -> fail ()
+  | Some c ->
+    (* We need it fresh for intro e.g. in "Tac H = clear H; intro H" *)
+    if isVar sigma c && not (fresh && is_variable env (destVar sigma c)) then
+      destVar sigma c
+    else fail ()
+
+
+(* Interprets, if possible, a constr to an identifier which may not
+   be fresh but suitable to be given to the fresh tactic. Works for
+   vars, constants, inductive, constructors and sorts. *)
+let coerce_to_ident_not_fresh env sigma v =
+let g = sigma in
+let id_of_name = function
+  | Names.Anonymous -> Id.of_string "x"
+  | Names.Name x -> x in
+  let v = Value.normalize v in
+  let fail () = raise (CannotCoerceTo "an identifier") in
+  if has_type v (topwit wit_intro_pattern) then
+    match out_gen (topwit wit_intro_pattern) v with
+    | _, IntroNaming (IntroIdentifier id) -> id
+    | _ -> fail ()
+  else if has_type v (topwit wit_var) then
+    out_gen (topwit wit_var) v
+  else
+    match Value.to_constr v with
+    | None -> fail ()
+    | Some c ->
+       match EConstr.kind sigma c with
+       | Var id -> id 
+       | Meta m -> id_of_name (Evd.meta_name g m)
+       | Evar (kn,_) ->
+        begin match Evd.evar_ident kn g with
+        | None -> fail ()
+        | Some id -> id
+        end
+       | Const (cst,_) -> Label.to_id (Constant.label cst)
+       | Construct (cstr,_) ->
+	  let ref = Globnames.ConstructRef cstr in
+	  let basename = Nametab.basename_of_global ref in
+	  basename
+       | Ind (ind,_) ->
+	  let ref = Globnames.IndRef ind in
+	  let basename = Nametab.basename_of_global ref in
+	  basename
+       | Sort s ->
+	  begin
+	    match s with
+	    | Prop _ -> Label.to_id (Label.make "Prop")
+	    | Type _ -> Label.to_id (Label.make "Type")
+	  end
+       | _ -> fail()
+
+
+let coerce_to_intro_pattern env sigma v =
+  let v = Value.normalize v in
+  if has_type v (topwit wit_intro_pattern) then
+    snd (out_gen (topwit wit_intro_pattern) v)
+  else if has_type v (topwit wit_var) then
+    let id = out_gen (topwit wit_var) v in
+    IntroNaming (IntroIdentifier id)
+  else match Value.to_constr v with
+  | Some c when isVar sigma c ->
+      (* This happens e.g. in definitions like "Tac H = clear H; intro H" *)
+      (* but also in "destruct H as (H,H')" *)
+      IntroNaming (IntroIdentifier (destVar sigma c))
+  | _ -> raise (CannotCoerceTo "an introduction pattern")
+
+let coerce_to_intro_pattern_naming env sigma v =
+  match coerce_to_intro_pattern env sigma v with
+  | IntroNaming pat -> pat
+  | _ -> raise (CannotCoerceTo "a naming introduction pattern")
+
+let coerce_to_hint_base v =
+  let v = Value.normalize v in
+  if has_type v (topwit wit_intro_pattern) then
+    match out_gen (topwit wit_intro_pattern) v with
+    | _, IntroNaming (IntroIdentifier id) -> Id.to_string id
+    | _ -> raise (CannotCoerceTo "a hint base name")
+  else raise (CannotCoerceTo "a hint base name")
+
+let coerce_to_int v =
+  let v = Value.normalize v in
+  if has_type v (topwit wit_int) then
+    out_gen (topwit wit_int) v
+  else raise (CannotCoerceTo "an integer")
+
+let coerce_to_constr env v =
+  let v = Value.normalize v in
+  let fail () = raise (CannotCoerceTo "a term") in
+  if has_type v (topwit wit_intro_pattern) then
+    match out_gen (topwit wit_intro_pattern) v with
+    | _, IntroNaming (IntroIdentifier id) ->
+      (try ([], constr_of_id env id) with Not_found -> fail ())
+    | _ -> fail ()
+  else if has_type v (topwit wit_constr) then
+    let c = out_gen (topwit wit_constr) v in
+    ([], c)
+  else if has_type v (topwit wit_constr_under_binders) then
+    out_gen (topwit wit_constr_under_binders) v
+  else if has_type v (topwit wit_var) then
+    let id = out_gen (topwit wit_var) v in
+    (try [], constr_of_id env id with Not_found -> fail ())
+  else fail ()
+
+let coerce_to_uconstr env v =
+  let v = Value.normalize v in
+  if has_type v (topwit wit_uconstr) then
+    out_gen (topwit wit_uconstr) v
+  else
+    raise (CannotCoerceTo "an untyped term")
+
+let coerce_to_closed_constr env v =
+  let ids,c = coerce_to_constr env v in
+  let () = if not (List.is_empty ids) then raise (CannotCoerceTo "a term") in
+  c
+
+let coerce_to_evaluable_ref env sigma v =
+  let fail () = raise (CannotCoerceTo "an evaluable reference") in
+  let v = Value.normalize v in
+  let ev =
+  if has_type v (topwit wit_intro_pattern) then
+    match out_gen (topwit wit_intro_pattern) v with
+    | _, IntroNaming (IntroIdentifier id) when is_variable env id -> EvalVarRef id
+    | _ -> fail ()
+  else if has_type v (topwit wit_var) then
+    let id = out_gen (topwit wit_var) v in
+    if Id.List.mem id (Termops.ids_of_context env) then EvalVarRef id
+    else fail ()
+  else if has_type v (topwit wit_ref) then
+    let open Globnames in
+    let r = out_gen (topwit wit_ref) v in
+    match r with
+    | VarRef var -> EvalVarRef var
+    | ConstRef c -> EvalConstRef c
+    | IndRef _ | ConstructRef _ -> fail ()
+  else
+    match Value.to_constr v with
+    | Some c when isConst sigma c -> EvalConstRef (Univ.out_punivs (destConst sigma c))
+    | Some c when isVar sigma c -> EvalVarRef (destVar sigma c)
+    | _ -> fail ()
+  in if Tacred.is_evaluable env ev then ev else fail ()
+
+let coerce_to_constr_list env v =
+  let v = Value.to_list v in
+  match v with
+  | Some l ->
+    let map v = coerce_to_closed_constr env v in
+    List.map map l
+  | None -> raise (CannotCoerceTo "a term list")
+
+let coerce_to_intro_pattern_list loc env sigma v =
+  match Value.to_list v with
+  | None -> raise (CannotCoerceTo "an intro pattern list")
+  | Some l ->
+    let map v = (loc, coerce_to_intro_pattern env sigma v) in
+    List.map map l
+
+let coerce_to_hyp env sigma v =
+  let fail () = raise (CannotCoerceTo "a variable") in
+  let v = Value.normalize v in
+  if has_type v (topwit wit_intro_pattern) then
+    match out_gen (topwit wit_intro_pattern) v with
+    | _, IntroNaming (IntroIdentifier id) when is_variable env id -> id
+    | _ -> fail ()
+  else if has_type v (topwit wit_var) then
+    let id = out_gen (topwit wit_var) v in
+    if is_variable env id then id else fail ()
+  else match Value.to_constr v with
+  | Some c when isVar sigma c -> destVar sigma c
+  | _ -> fail ()
+
+let coerce_to_hyp_list env sigma v =
+  let v = Value.to_list v in
+  match v with
+  | Some l ->
+    let map n = coerce_to_hyp env sigma n in
+    List.map map l
+  | None -> raise (CannotCoerceTo "a variable list")
+
+(* Interprets a qualified name *)
+let coerce_to_reference env sigma v =
+  let v = Value.normalize v in
+  match Value.to_constr v with
+  | Some c ->
+    begin
+      try fst (Termops.global_of_constr sigma c)
+      with Not_found -> raise (CannotCoerceTo "a reference")
+    end
+  | None -> raise (CannotCoerceTo "a reference")
+
+(* Quantified named or numbered hypothesis or hypothesis in context *)
+(* (as in Inversion) *)
+let coerce_to_quantified_hypothesis sigma v =
+  let v = Value.normalize v in
+  if has_type v (topwit wit_intro_pattern) then
+    let v = out_gen (topwit wit_intro_pattern) v in
+    match v with
+    | _, IntroNaming (IntroIdentifier id) -> NamedHyp id
+    | _ -> raise (CannotCoerceTo "a quantified hypothesis")
+  else if has_type v (topwit wit_var) then
+    let id = out_gen (topwit wit_var) v in
+    NamedHyp id
+  else if has_type v (topwit wit_int) then
+    AnonHyp (out_gen (topwit wit_int) v)
+  else match Value.to_constr v with
+  | Some c when isVar sigma c -> NamedHyp (destVar sigma c)
+  | _ -> raise (CannotCoerceTo "a quantified hypothesis")
+
+(* Quantified named or numbered hypothesis or hypothesis in context *)
+(* (as in Inversion) *)
+let coerce_to_decl_or_quant_hyp env sigma v =
+  let v = Value.normalize v in
+  if has_type v (topwit wit_int) then
+    AnonHyp (out_gen (topwit wit_int) v)
+  else
+    try coerce_to_quantified_hypothesis sigma v
+    with CannotCoerceTo _ ->
+      raise (CannotCoerceTo "a declared or quantified hypothesis")
+
+let coerce_to_int_or_var_list v =
+  match Value.to_list v with
+  | None -> raise (CannotCoerceTo "an int list")
+  | Some l ->
+    let map n = ArgArg (coerce_to_int n) in
+    List.map map l
diff --git a/plugins/ltac/taccoerce.mli b/plugins/ltac/taccoerce.mli
new file mode 100644
index 000000000..9c4ac5265
--- /dev/null
+++ b/plugins/ltac/taccoerce.mli
@@ -0,0 +1,97 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+open Util
+open Names
+open Term
+open EConstr
+open Misctypes
+open Pattern
+open Genarg
+open Geninterp
+
+(** Coercions from highest level generic arguments to actual data used by Ltac
+    interpretation. Those functions examinate dynamic types and try to return
+    something sensible according to the object content. *)
+
+exception CannotCoerceTo of string
+(** Exception raised whenever a coercion failed. *)
+
+(** {5 High-level access to values}
+
+  The [of_*] functions cast a given argument into a value. The [to_*] do the
+  converse, and return [None] if there is a type mismatch.
+
+*)
+
+module Value :
+sig
+  type t = Val.t
+
+  val normalize : t -> t
+  (** Eliminated the leading dynamic type casts. *)
+
+  val of_constr : constr -> t
+  val to_constr : t -> constr option
+  val of_uconstr : Glob_term.closed_glob_constr -> t
+  val to_uconstr : t -> Glob_term.closed_glob_constr option
+  val of_int : int -> t
+  val to_int : t -> int option
+  val to_list : t -> t list option
+  val to_option : t -> t option option
+  val to_pair : t -> (t * t) option
+end
+
+(** {5 Coercion functions} *)
+
+val coerce_to_constr_context : Value.t -> constr
+
+val coerce_var_to_ident : bool -> Environ.env -> Evd.evar_map -> Value.t -> Id.t
+
+val coerce_to_ident_not_fresh : Environ.env -> Evd.evar_map -> Value.t -> Id.t
+
+val coerce_to_intro_pattern : Environ.env -> Evd.evar_map -> Value.t -> Tacexpr.delayed_open_constr intro_pattern_expr
+
+val coerce_to_intro_pattern_naming :
+  Environ.env -> Evd.evar_map -> Value.t -> intro_pattern_naming_expr
+
+val coerce_to_hint_base : Value.t -> string
+
+val coerce_to_int : Value.t -> int
+
+val coerce_to_constr : Environ.env -> Value.t -> constr_under_binders
+
+val coerce_to_uconstr : Environ.env -> Value.t -> Glob_term.closed_glob_constr
+
+val coerce_to_closed_constr : Environ.env -> Value.t -> constr
+
+val coerce_to_evaluable_ref :
+  Environ.env -> Evd.evar_map -> Value.t -> evaluable_global_reference
+
+val coerce_to_constr_list : Environ.env -> Value.t -> constr list
+
+val coerce_to_intro_pattern_list :
+  Loc.t -> Environ.env -> Evd.evar_map -> Value.t -> Tacexpr.intro_patterns
+
+val coerce_to_hyp : Environ.env -> Evd.evar_map -> Value.t -> Id.t
+
+val coerce_to_hyp_list : Environ.env -> Evd.evar_map -> Value.t -> Id.t list
+
+val coerce_to_reference : Environ.env -> Evd.evar_map -> Value.t -> Globnames.global_reference
+
+val coerce_to_quantified_hypothesis : Evd.evar_map -> Value.t -> quantified_hypothesis
+
+val coerce_to_decl_or_quant_hyp : Environ.env -> Evd.evar_map -> Value.t -> quantified_hypothesis
+
+val coerce_to_int_or_var_list : Value.t -> int or_var list
+
+(** {5 Missing generic arguments} *)
+
+val wit_constr_context : (Empty.t, Empty.t, EConstr.constr) genarg_type
+
+val wit_constr_under_binders : (Empty.t, Empty.t, constr_under_binders) genarg_type
diff --git a/plugins/ltac/tacentries.ml b/plugins/ltac/tacentries.ml
new file mode 100644
index 000000000..cd8c9e471
--- /dev/null
+++ b/plugins/ltac/tacentries.ml
@@ -0,0 +1,524 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+open Pp
+open CErrors
+open Util
+open Names
+open Libobject
+open Genarg
+open Extend
+open Pcoq
+open Egramml
+open Egramcoq
+open Vernacexpr
+open Libnames
+open Nameops
+
+type 'a grammar_tactic_prod_item_expr = 'a Pptactic.grammar_tactic_prod_item_expr =
+| TacTerm of string
+| TacNonTerm of Loc.t * 'a * Names.Id.t
+
+type raw_argument = string * string option
+type argument = Genarg.ArgT.any Extend.user_symbol
+
+(**********************************************************************)
+(* Interpret entry names of the form "ne_constr_list" as entry keys   *)
+
+let coincide s pat off =
+  let len = String.length pat in
+  let break = ref true in
+  let i = ref 0 in
+  while !break && !i < len do
+    let c = Char.code s.[off + !i] in
+    let d = Char.code pat.[!i] in
+    break := Int.equal c d;
+    incr i
+  done;
+  !break
+
+let atactic n =
+  if n = 5 then Aentry Pltac.binder_tactic
+  else Aentryl (Pltac.tactic_expr, n)
+
+type entry_name = EntryName :
+  'a raw_abstract_argument_type * (Tacexpr.raw_tactic_expr, 'a) Extend.symbol -> entry_name
+
+(** Quite ad-hoc *)
+let get_tacentry n m =
+  let check_lvl n =
+    Int.equal m n
+    && not (Int.equal m 5) (* Because tactic5 is at binder_tactic *)
+    && not (Int.equal m 0) (* Because tactic0 is at simple_tactic *)
+  in
+  if check_lvl n then EntryName (rawwit Tacarg.wit_tactic, Aself)
+  else if check_lvl (n + 1) then EntryName (rawwit Tacarg.wit_tactic, Anext)
+  else EntryName (rawwit Tacarg.wit_tactic, atactic n)
+
+let get_separator = function
+| None -> error "Missing separator."
+| Some sep -> sep
+
+let rec parse_user_entry s sep =
+  let l = String.length s in
+  if l > 8 && coincide s "ne_" 0 && coincide s "_list" (l - 5) then
+    let entry = parse_user_entry (String.sub s 3 (l-8)) None in
+    Ulist1 entry
+  else if l > 12 && coincide s "ne_" 0 &&
+                   coincide s "_list_sep" (l-9) then
+    let entry = parse_user_entry (String.sub s 3 (l-12)) None in
+    Ulist1sep (entry, get_separator sep)
+  else if l > 5 && coincide s "_list" (l-5) then
+    let entry = parse_user_entry (String.sub s 0 (l-5)) None in
+    Ulist0 entry
+  else if l > 9 && coincide s "_list_sep" (l-9) then
+    let entry = parse_user_entry (String.sub s 0 (l-9)) None in
+    Ulist0sep (entry, get_separator sep)
+  else if l > 4 && coincide s "_opt" (l-4) then
+    let entry = parse_user_entry (String.sub s 0 (l-4)) None in
+    Uopt entry
+  else if Int.equal l 7 && coincide s "tactic" 0 && '5' >= s.[6] && s.[6] >= '0' then
+    let n = Char.code s.[6] - 48 in
+    Uentryl ("tactic", n)
+  else
+    Uentry s
+
+let arg_list = function Rawwit t -> Rawwit (ListArg t)
+let arg_opt = function Rawwit t -> Rawwit (OptArg t)
+
+let interp_entry_name interp symb =
+  let rec eval = function
+  | Ulist1 e -> Ulist1 (eval e)
+  | Ulist1sep (e, sep) -> Ulist1sep (eval e, sep)
+  | Ulist0 e -> Ulist0 (eval e)
+  | Ulist0sep (e, sep) -> Ulist0sep (eval e, sep)
+  | Uopt e -> Uopt (eval e)
+  | Uentry s -> Uentry (interp s None)
+  | Uentryl (s, n) -> Uentryl (interp s (Some n), n)
+  in
+  eval symb
+
+(**********************************************************************)
+(** Grammar declaration for Tactic Notation (Coq level)               *)
+
+let get_tactic_entry n =
+  if Int.equal n 0 then
+    Pltac.simple_tactic, None
+  else if Int.equal n 5 then
+    Pltac.binder_tactic, None
+  else if 1<=n && n<5 then
+    Pltac.tactic_expr, Some (Extend.Level (string_of_int n))
+  else
+    error ("Invalid Tactic Notation level: "^(string_of_int n)^".")
+
+(**********************************************************************)
+(** State of the grammar extensions                                   *)
+
+type tactic_grammar = {
+  tacgram_level : int;
+  tacgram_prods : Pptactic.grammar_terminals;
+}
+
+(* Declaration of the tactic grammar rule *)
+
+let head_is_ident tg = match tg.tacgram_prods with
+| TacTerm _ :: _ -> true
+| _ -> false
+
+let rec prod_item_of_symbol lev = function
+| Extend.Ulist1 s ->
+  let EntryName (Rawwit typ, e) = prod_item_of_symbol lev s in
+  EntryName (Rawwit (ListArg typ), Alist1 e)
+| Extend.Ulist0 s ->
+  let EntryName (Rawwit typ, e) = prod_item_of_symbol lev s in
+  EntryName (Rawwit (ListArg typ), Alist0 e)
+| Extend.Ulist1sep (s, sep) ->
+  let EntryName (Rawwit typ, e) = prod_item_of_symbol lev s in
+  EntryName (Rawwit (ListArg typ), Alist1sep (e, Atoken (CLexer.terminal sep)))
+| Extend.Ulist0sep (s, sep) ->
+  let EntryName (Rawwit typ, e) = prod_item_of_symbol lev s in
+  EntryName (Rawwit (ListArg typ), Alist0sep (e, Atoken (CLexer.terminal sep)))
+| Extend.Uopt s ->
+  let EntryName (Rawwit typ, e) = prod_item_of_symbol lev s in
+  EntryName (Rawwit (OptArg typ), Aopt e)
+| Extend.Uentry arg ->
+  let ArgT.Any tag = arg in
+  let wit = ExtraArg tag in
+  EntryName (Rawwit wit, Extend.Aentry (genarg_grammar wit))
+| Extend.Uentryl (s, n) ->
+  let ArgT.Any tag = s in
+  assert (coincide (ArgT.repr tag) "tactic" 0);
+  get_tacentry n lev
+
+(** Tactic grammar extensions *)
+
+let add_tactic_entry (kn, ml, tg) state =
+  let open Tacexpr in
+  let entry, pos = get_tactic_entry tg.tacgram_level in
+  let mkact loc l =
+    let map arg =
+      (** HACK to handle especially the tactic(...) entry *)
+      let wit = Genarg.rawwit Tacarg.wit_tactic in
+      if Genarg.has_type arg wit && not ml then
+        Tacexp (Genarg.out_gen wit arg)
+      else
+        TacGeneric arg
+    in
+    let l = List.map map l in
+    (TacAlias (loc,kn,l):raw_tactic_expr)
+  in
+  let () =
+    if Int.equal tg.tacgram_level 0 && not (head_is_ident tg) then
+      error "Notation for simple tactic must start with an identifier."
+  in
+  let map = function
+  | TacTerm s -> GramTerminal s
+  | TacNonTerm (loc, s, _) ->
+    let EntryName (typ, e) = prod_item_of_symbol tg.tacgram_level s in
+    GramNonTerminal (loc, typ, e)
+  in
+  let prods = List.map map tg.tacgram_prods in
+  let rules = make_rule mkact prods in
+  let r = ExtendRule (entry, None, (pos, [(None, None, [rules])])) in
+  ([r], state)
+
+let tactic_grammar =
+  create_grammar_command "TacticGrammar" add_tactic_entry
+
+let extend_tactic_grammar kn ml ntn = extend_grammar_command tactic_grammar (kn, ml, ntn)
+
+(**********************************************************************)
+(* Tactic Notation                                                    *)
+
+let entry_names = ref String.Map.empty
+
+let register_tactic_notation_entry name entry =
+  let entry = match entry with
+  | ExtraArg arg -> ArgT.Any arg
+  | _ -> assert false
+  in
+  entry_names := String.Map.add name entry !entry_names
+
+let interp_prod_item = function
+  | TacTerm s -> TacTerm s
+  | TacNonTerm (loc, (nt, sep), id) ->
+    let symbol = parse_user_entry nt sep in
+    let interp s = function
+    | None ->
+      if String.Map.mem s !entry_names then String.Map.find s !entry_names
+      else begin match ArgT.name s with
+      | None -> error ("Unknown entry "^s^".")
+      | Some arg -> arg
+      end
+    | Some n ->
+      (** FIXME: do better someday *)
+      assert (String.equal s "tactic");
+      begin match Tacarg.wit_tactic with
+      | ExtraArg tag -> ArgT.Any tag
+      | _ -> assert false
+      end
+    in
+    let symbol = interp_entry_name interp symbol in
+    TacNonTerm (loc, symbol, id)
+
+let make_fresh_key =
+  let id = Summary.ref ~name:"TACTIC-NOTATION-COUNTER" 0 in
+  fun prods ->
+    let cur = incr id; !id in
+    let map = function
+    | TacTerm s -> s
+    | TacNonTerm _ -> "#"
+    in
+    let prods = String.concat "_" (List.map map prods) in
+    (** We embed the hash of the kernel name in the label so that the identifier
+        should be mostly unique. This ensures that including two modules
+        together won't confuse the corresponding labels. *)
+    let hash = (cur lxor (ModPath.hash (Lib.current_mp ()))) land 0x7FFFFFFF in
+    let lbl = Id.of_string_soft (Printf.sprintf "%s_%08X" prods hash) in
+    Lib.make_kn lbl
+
+type tactic_grammar_obj = {
+  tacobj_key : KerName.t;
+  tacobj_local : locality_flag;
+  tacobj_tacgram : tactic_grammar;
+  tacobj_body : Id.t list * Tacexpr.glob_tactic_expr;
+  tacobj_forml : bool;
+}
+
+let pprule pa = {
+  Pptactic.pptac_level = pa.tacgram_level;
+  pptac_prods = pa.tacgram_prods;
+}
+
+let check_key key =
+  if Tacenv.check_alias key then
+    error "Conflicting tactic notations keys. This can happen when including \
+    twice the same module."
+
+let cache_tactic_notation (_, tobj) =
+  let key = tobj.tacobj_key in
+  let () = check_key key in
+  Tacenv.register_alias key tobj.tacobj_body;
+  extend_tactic_grammar key tobj.tacobj_forml tobj.tacobj_tacgram;
+  Pptactic.declare_notation_tactic_pprule key (pprule tobj.tacobj_tacgram)
+
+let open_tactic_notation i (_, tobj) =
+  let key = tobj.tacobj_key in
+  if Int.equal i 1 && not tobj.tacobj_local then
+    extend_tactic_grammar key tobj.tacobj_forml tobj.tacobj_tacgram
+
+let load_tactic_notation i (_, tobj) =
+  let key = tobj.tacobj_key in
+  let () = check_key key in
+  (** Only add the printing and interpretation rules. *)
+  Tacenv.register_alias key tobj.tacobj_body;
+  Pptactic.declare_notation_tactic_pprule key (pprule tobj.tacobj_tacgram);
+  if Int.equal i 1 && not tobj.tacobj_local then
+    extend_tactic_grammar key tobj.tacobj_forml tobj.tacobj_tacgram
+
+let subst_tactic_notation (subst, tobj) =
+  let (ids, body) = tobj.tacobj_body in
+  { tobj with
+    tacobj_key = Mod_subst.subst_kn subst tobj.tacobj_key;
+    tacobj_body = (ids, Tacsubst.subst_tactic subst body);
+  }
+
+let classify_tactic_notation tacobj = Substitute tacobj
+
+let inTacticGrammar : tactic_grammar_obj -> obj =
+  declare_object {(default_object "TacticGrammar") with
+       open_function = open_tactic_notation;
+       load_function = load_tactic_notation;
+       cache_function = cache_tactic_notation;
+       subst_function = subst_tactic_notation;
+       classify_function = classify_tactic_notation}
+
+let cons_production_parameter = function
+| TacTerm _ -> None
+| TacNonTerm (_, _, id) -> Some id
+
+let add_glob_tactic_notation local ~level prods forml ids tac =
+  let parule = {
+    tacgram_level = level;
+    tacgram_prods = prods;
+  } in
+  let tacobj = {
+    tacobj_key = make_fresh_key prods;
+    tacobj_local = local;
+    tacobj_tacgram = parule;
+    tacobj_body = (ids, tac);
+    tacobj_forml = forml;
+  } in
+  Lib.add_anonymous_leaf (inTacticGrammar tacobj)
+
+let add_tactic_notation local n prods e =
+  let ids = List.map_filter cons_production_parameter prods in
+  let prods = List.map interp_prod_item prods in
+  let tac = Tacintern.glob_tactic_env ids (Global.env()) e in
+  add_glob_tactic_notation local n prods false ids tac
+
+(**********************************************************************)
+(* ML Tactic entries                                                  *)
+
+exception NonEmptyArgument
+
+(** ML tactic notations whose use can be restricted to an identifier are added
+    as true Ltac entries. *)
+let extend_atomic_tactic name entries =
+  let open Tacexpr in
+  let map_prod prods =
+    let (hd, rem) = match prods with
+    | TacTerm s :: rem -> (s, rem)
+    | _ -> assert false (** Not handled by the ML extension syntax *)
+    in
+    let empty_value = function
+    | TacTerm s -> raise NonEmptyArgument
+    | TacNonTerm (_, symb, _) ->
+      let EntryName (typ, e) = prod_item_of_symbol 0 symb in
+      let Genarg.Rawwit wit = typ in
+      let inj x = TacArg (Loc.ghost, TacGeneric (Genarg.in_gen typ x)) in
+      let default = epsilon_value inj e in
+      match default with
+      | None -> raise NonEmptyArgument
+      | Some def -> Tacintern.intern_tactic_or_tacarg Tacintern.fully_empty_glob_sign def
+    in
+    try Some (hd, List.map empty_value rem) with NonEmptyArgument -> None
+  in
+  let entries = List.map map_prod entries in
+  let add_atomic i args = match args with
+  | None -> ()
+  | Some (id, args) ->
+    let args = List.map (fun a -> Tacexp a) args in
+    let entry = { mltac_name = name; mltac_index = i } in
+    let body = TacML (Loc.ghost, entry, args) in
+    Tacenv.register_ltac false false (Names.Id.of_string id) body
+  in
+  List.iteri add_atomic entries
+
+let add_ml_tactic_notation name ~level prods =
+  let len = List.length prods in
+  let iter i prods =
+    let open Tacexpr in
+    let get_id = function
+    | TacTerm s -> None
+    | TacNonTerm (_, _, id) -> Some id
+    in
+    let ids = List.map_filter get_id prods in
+    let entry = { mltac_name = name; mltac_index = len - i - 1 } in
+    let map id = Reference (Misctypes.ArgVar (Loc.ghost, id)) in
+    let tac = TacML (Loc.ghost, entry, List.map map ids) in
+    add_glob_tactic_notation false ~level prods true ids tac
+  in
+  List.iteri iter (List.rev prods);
+  (** We call [extend_atomic_tactic] only for "basic tactics" (the ones at
+  tactic_expr level 0) *)
+  if Int.equal level 0 then extend_atomic_tactic name prods
+
+(**********************************************************************)
+(** Ltac quotations                                                   *)
+
+let ltac_quotations = ref String.Set.empty
+
+let create_ltac_quotation name cast (e, l) =
+  let () =
+    if String.Set.mem name !ltac_quotations then
+      failwith ("Ltac quotation " ^ name ^ " already registered")
+  in
+  let () = ltac_quotations := String.Set.add name !ltac_quotations in
+  let entry = match l with
+  | None -> Aentry e
+  | Some l -> Aentryl (e, l)
+  in
+(*   let level = Some "1" in *)
+  let level = None in
+  let assoc = None in
+  let rule =
+    Next (Next (Next (Next (Next (Stop,
+      Atoken (CLexer.terminal name)),
+      Atoken (CLexer.terminal ":")),
+      Atoken (CLexer.terminal "(")),
+      entry),
+      Atoken (CLexer.terminal ")"))
+  in
+  let action _ v _ _ _ loc = cast (loc, v) in
+  let gram = (level, assoc, [Rule (rule, action)]) in
+  Pcoq.grammar_extend Pltac.tactic_arg None (None, [gram])
+
+(** Command *)
+
+
+type tacdef_kind =
+  | NewTac of Id.t
+  | UpdateTac of Nametab.ltac_constant
+
+let is_defined_tac kn =
+  try ignore (Tacenv.interp_ltac kn); true with Not_found -> false
+
+let warn_unusable_identifier =
+  CWarnings.create ~name:"unusable-identifier" ~category:"parsing"
+      (fun id -> strbrk "The Ltac name" ++ spc () ++ pr_id id ++ spc () ++
+        strbrk "may be unusable because of a conflict with a notation.")
+
+let register_ltac local tacl =
+  let map tactic_body =
+    match tactic_body with
+    | Tacexpr.TacticDefinition ((loc,id), body) ->
+        let kn = Lib.make_kn id in
+        let id_pp = pr_id id in
+        let () = if is_defined_tac kn then
+          CErrors.user_err ~loc 
+            (str "There is already an Ltac named " ++ id_pp ++ str".")
+        in
+        let is_shadowed =
+          try
+            match Pcoq.parse_string Pltac.tactic (Id.to_string id) with
+            | Tacexpr.TacArg _ -> false
+            | _ -> true (* most probably TacAtom, i.e. a primitive tactic ident *)
+          with e when CErrors.noncritical e -> true (* prim tactics with args, e.g. "apply" *)
+        in
+        let () = if is_shadowed then warn_unusable_identifier id in
+        NewTac id, body
+    | Tacexpr.TacticRedefinition (ident, body) ->
+        let loc = loc_of_reference ident in
+        let kn =
+          try Nametab.locate_tactic (snd (qualid_of_reference ident))
+          with Not_found ->
+            CErrors.user_err ~loc 
+                       (str "There is no Ltac named " ++ pr_reference ident ++ str ".")
+        in
+        UpdateTac kn, body
+  in
+  let rfun = List.map map tacl in
+  let recvars =
+    let fold accu (op, _) = match op with
+    | UpdateTac _ -> accu
+    | NewTac id -> (Lib.make_path id, Lib.make_kn id) :: accu
+    in
+    List.fold_left fold [] rfun
+  in
+  let ist = Tacintern.make_empty_glob_sign () in
+  let map (name, body) =
+    let body = Flags.with_option Tacintern.strict_check (Tacintern.intern_tactic_or_tacarg ist) body in
+    (name, body)
+  in
+  let defs () =
+    (** Register locally the tactic to handle recursivity. This function affects
+        the whole environment, so that we transactify it afterwards. *)
+    let iter_rec (sp, kn) = Nametab.push_tactic (Nametab.Until 1) sp kn in
+    let () = List.iter iter_rec recvars in
+    List.map map rfun
+  in
+  let defs = Future.transactify defs () in
+  let iter (def, tac) = match def with
+  | NewTac id ->
+    Tacenv.register_ltac false local id tac;
+    Flags.if_verbose Feedback.msg_info (Nameops.pr_id id ++ str " is defined")
+  | UpdateTac kn ->
+    Tacenv.redefine_ltac local kn tac;
+    let name = Nametab.shortest_qualid_of_tactic kn in
+    Flags.if_verbose Feedback.msg_info (Libnames.pr_qualid name ++ str " is redefined")
+  in
+  List.iter iter defs
+
+(** Queries *)
+
+let print_ltacs () =
+  let entries = KNmap.bindings (Tacenv.ltac_entries ()) in
+  let sort (kn1, _) (kn2, _) = KerName.compare kn1 kn2 in
+  let entries = List.sort sort entries in
+  let map (kn, entry) =
+    let qid =
+      try Some (Nametab.shortest_qualid_of_tactic kn)
+      with Not_found -> None
+    in
+    match qid with
+    | None -> None
+    | Some qid -> Some (qid, entry.Tacenv.tac_body)
+  in
+  let entries = List.map_filter map entries in
+  let pr_entry (qid, body) =
+    let (l, t) = match body with
+    | Tacexpr.TacFun (l, t) -> (l, t)
+    | _ -> ([], body)
+    in
+    let pr_ltac_fun_arg n = spc () ++ pr_name n in
+    hov 2 (pr_qualid qid ++ prlist pr_ltac_fun_arg l)
+  in
+  Feedback.msg_notice (prlist_with_sep fnl pr_entry entries)
+
+(** Grammar *)
+
+let () =
+  let open Metasyntax in
+  let entries = [
+    AnyEntry Pltac.tactic_expr;
+    AnyEntry Pltac.binder_tactic;
+    AnyEntry Pltac.simple_tactic;
+    AnyEntry Pltac.tactic_arg;
+  ] in
+  register_grammar "tactic" entries
diff --git a/plugins/ltac/tacentries.mli b/plugins/ltac/tacentries.mli
new file mode 100644
index 000000000..069504473
--- /dev/null
+++ b/plugins/ltac/tacentries.mli
@@ -0,0 +1,64 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(** Ltac toplevel command entries. *)
+
+open Vernacexpr
+open Tacexpr
+
+(** {5 Tactic Definitions} *)
+
+val register_ltac : locality_flag -> Tacexpr.tacdef_body list -> unit
+(** Adds new Ltac definitions to the environment. *)
+
+(** {5 Tactic Notations} *)
+
+type 'a grammar_tactic_prod_item_expr = 'a Pptactic.grammar_tactic_prod_item_expr =
+| TacTerm of string
+| TacNonTerm of Loc.t * 'a * Names.Id.t
+
+type raw_argument = string * string option
+(** An argument type as provided in Tactic notations, i.e. a string like
+    "ne_foo_list_opt" together with a separator that only makes sense in the
+    "_sep" cases. *)
+
+type argument = Genarg.ArgT.any Extend.user_symbol
+(** A fully resolved argument type given as an AST with generic arguments on the
+    leaves. *)
+
+val add_tactic_notation :
+  locality_flag -> int -> raw_argument grammar_tactic_prod_item_expr list ->
+  raw_tactic_expr -> unit
+(** [add_tactic_notation local level prods expr] adds a tactic notation in the
+    environment at level [level] with locality [local] made of the grammar
+    productions [prods] and returning the body [expr] *)
+
+val register_tactic_notation_entry : string -> ('a, 'b, 'c) Genarg.genarg_type -> unit
+(** Register an argument under a given entry name for tactic notations. When
+    translating [raw_argument] into [argument], atomic names will be first
+    looked up according to names registered through this function and fallback
+    to finding an argument by name (as in {!Genarg}) if there is none
+    matching. *)
+
+val add_ml_tactic_notation : ml_tactic_name -> level:int ->
+  argument grammar_tactic_prod_item_expr list list -> unit
+(** A low-level variant of {!add_tactic_notation} used by the TACTIC EXTEND
+    ML-side macro. *)
+
+(** {5 Tactic Quotations} *)
+
+val create_ltac_quotation : string ->
+  ('grm Loc.located -> raw_tactic_arg) -> ('grm Pcoq.Gram.entry * int option) -> unit
+(** [create_ltac_quotation name f e] adds a quotation rule to Ltac, that is,
+    Ltac grammar now accepts arguments of the form ["name" ":" "(" <e> ")"], and
+    generates an argument using [f] on the entry parsed by [e]. *)
+
+(** {5 Queries} *)
+
+val print_ltacs : unit -> unit
+(** Display the list of ltac definitions currently available. *)
diff --git a/plugins/ltac/tacenv.ml b/plugins/ltac/tacenv.ml
new file mode 100644
index 000000000..e3c2b4ad5
--- /dev/null
+++ b/plugins/ltac/tacenv.ml
@@ -0,0 +1,143 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+open Util
+open Pp
+open Names
+open Tacexpr
+
+(** Tactic notations (TacAlias) *)
+
+type alias = KerName.t
+type alias_tactic = Id.t list * glob_tactic_expr
+
+let alias_map = Summary.ref ~name:"tactic-alias"
+  (KNmap.empty : alias_tactic KNmap.t)
+
+let register_alias key tac =
+  alias_map := KNmap.add key tac !alias_map
+
+let interp_alias key =
+  try KNmap.find key !alias_map
+  with Not_found -> CErrors.anomaly (str "Unknown tactic alias: " ++ KerName.print key)
+
+let check_alias key = KNmap.mem key !alias_map
+
+(** ML tactic extensions (TacML) *)
+
+type ml_tactic =
+  Geninterp.Val.t list -> Geninterp.interp_sign -> unit Proofview.tactic
+
+module MLName =
+struct
+  type t = ml_tactic_name
+  let compare tac1 tac2 =
+    let c = String.compare tac1.mltac_tactic tac2.mltac_tactic in
+    if c = 0 then String.compare tac1.mltac_plugin tac2.mltac_plugin
+    else c
+end
+
+module MLTacMap = Map.Make(MLName)
+
+let pr_tacname t =
+  str t.mltac_plugin ++ str "::" ++ str t.mltac_tactic
+
+let tac_tab = ref MLTacMap.empty
+
+let register_ml_tactic ?(overwrite = false) s (t : ml_tactic array) =
+  let () =
+    if MLTacMap.mem s !tac_tab then
+      if overwrite then
+        tac_tab := MLTacMap.remove s !tac_tab
+      else
+        CErrors.anomaly (str "Cannot redeclare tactic " ++ pr_tacname s ++ str ".")
+  in
+  tac_tab := MLTacMap.add s t !tac_tab
+
+let interp_ml_tactic { mltac_name = s; mltac_index = i } =
+  try
+    let tacs = MLTacMap.find s !tac_tab in
+    let () = if Array.length tacs <= i then raise Not_found in
+    tacs.(i)
+  with Not_found ->
+    CErrors.user_err 
+      (str "The tactic " ++ pr_tacname s ++ str " is not installed.")
+
+(***************************************************************************)
+(* Tactic registration *)
+
+(* Summary and Object declaration *)
+
+open Nametab
+open Libobject
+
+type ltac_entry = {
+  tac_for_ml : bool;
+  tac_body : glob_tactic_expr;
+  tac_redef : ModPath.t list;
+}
+
+let mactab =
+  Summary.ref (KNmap.empty : ltac_entry KNmap.t)
+    ~name:"tactic-definition"
+
+let ltac_entries () = !mactab
+
+let interp_ltac r = (KNmap.find r !mactab).tac_body
+
+let is_ltac_for_ml_tactic r = (KNmap.find r !mactab).tac_for_ml
+
+let add kn b t =
+  let entry = { tac_for_ml = b; tac_body = t; tac_redef = [] } in
+  mactab := KNmap.add kn entry !mactab
+
+let replace kn path t =
+  let (path, _, _) = KerName.repr path in
+  let entry _ e = { e with tac_body = t; tac_redef = path :: e.tac_redef } in
+  mactab := KNmap.modify kn entry !mactab
+
+let load_md i ((sp, kn), (local, id, b, t)) = match id with
+| None ->
+  let () = if not local then Nametab.push_tactic (Until i) sp kn in
+  add kn b t
+| Some kn0 -> replace kn0 kn t
+
+let open_md i ((sp, kn), (local, id, b, t)) = match id with
+| None ->
+  let () = if not local then Nametab.push_tactic (Exactly i) sp kn in
+  add kn b t
+| Some kn0 -> replace kn0 kn t
+
+let cache_md ((sp, kn), (local, id ,b, t)) = match id with
+| None ->
+  let () = Nametab.push_tactic (Until 1) sp kn in
+  add kn b t
+| Some kn0 -> replace kn0 kn t
+
+let subst_kind subst id = match id with
+| None -> None
+| Some kn -> Some (Mod_subst.subst_kn subst kn)
+
+let subst_md (subst, (local, id, b, t)) =
+  (local, subst_kind subst id, b, Tacsubst.subst_tactic subst t)
+
+let classify_md (local, _, _, _ as o) = Substitute o
+
+let inMD : bool * Nametab.ltac_constant option * bool * glob_tactic_expr -> obj =
+  declare_object {(default_object "TAC-DEFINITION") with
+     cache_function  = cache_md;
+     load_function   = load_md;
+     open_function   = open_md;
+     subst_function = subst_md;
+     classify_function = classify_md}
+
+let register_ltac for_ml local id tac =
+  ignore (Lib.add_leaf id (inMD (local, None, for_ml, tac)))
+
+let redefine_ltac local kn tac =
+  Lib.add_anonymous_leaf (inMD (local, Some kn, false, tac))
diff --git a/plugins/ltac/tacenv.mli b/plugins/ltac/tacenv.mli
new file mode 100644
index 000000000..94e14223a
--- /dev/null
+++ b/plugins/ltac/tacenv.mli
@@ -0,0 +1,75 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+open Genarg
+open Names
+open Tacexpr
+open Geninterp
+
+(** This module centralizes the various ways of registering tactics. *)
+
+(** {5 Tactic notations} *)
+
+type alias = KerName.t
+(** Type of tactic alias, used in the [TacAlias] node. *)
+
+type alias_tactic = Id.t list * glob_tactic_expr
+(** Contents of a tactic notation *)
+
+val register_alias : alias -> alias_tactic -> unit
+(** Register a tactic alias. *)
+
+val interp_alias : alias -> alias_tactic
+(** Recover the the body of an alias. Raises an anomaly if it does not exist. *)
+
+val check_alias : alias -> bool
+(** Returns [true] if an alias is defined, false otherwise. *)
+
+(** {5 Coq tactic definitions} *)
+
+val register_ltac : bool -> bool -> Id.t -> glob_tactic_expr -> unit
+(** Register a new Ltac with the given name and body.
+
+    The first boolean indicates whether this is done from ML side, rather than
+    Coq side. If the second boolean flag is set to true, then this is a local
+    definition. It also puts the Ltac name in the nametab, so that it can be
+    used unqualified. *)
+
+val redefine_ltac : bool -> KerName.t -> glob_tactic_expr -> unit
+(** Replace a Ltac with the given name and body. If the boolean flag is set
+    to true, then this is a local redefinition. *)
+
+val interp_ltac : KerName.t -> glob_tactic_expr
+(** Find a user-defined tactic by name. Raise [Not_found] if it is absent. *)
+
+val is_ltac_for_ml_tactic : KerName.t -> bool
+(** Whether the tactic is defined from ML-side *)
+
+type ltac_entry = {
+  tac_for_ml : bool;
+  (** Whether the tactic is defined from ML-side *)
+  tac_body : glob_tactic_expr;
+  (** The current body of the tactic *)
+  tac_redef : ModPath.t list;
+  (** List of modules redefining the tactic in reverse chronological order *)
+}
+
+val ltac_entries : unit -> ltac_entry KNmap.t
+(** Low-level access to all Ltac entries currently defined. *)
+
+(** {5 ML tactic extensions} *)
+
+type ml_tactic =
+  Val.t list -> Geninterp.interp_sign -> unit Proofview.tactic
+(** Type of external tactics, used by [TacML]. *)
+
+val register_ml_tactic : ?overwrite:bool -> ml_tactic_name -> ml_tactic array -> unit
+(** Register an external tactic. *)
+
+val interp_ml_tactic : ml_tactic_entry -> ml_tactic
+(** Get the named tactic. Raises a user error if it does not exist. *)
diff --git a/plugins/ltac/tacexpr.mli b/plugins/ltac/tacexpr.mli
new file mode 100644
index 000000000..8aefe7605
--- /dev/null
+++ b/plugins/ltac/tacexpr.mli
@@ -0,0 +1,396 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+open Loc
+open Names
+open Constrexpr
+open Libnames
+open Nametab
+open Genredexpr
+open Genarg
+open Pattern
+open Misctypes
+open Locus
+
+type direction_flag = bool (* true = Left-to-right    false = right-to-right *)
+type lazy_flag =
+  | General (* returns all possible successes *)
+  | Select  (* returns all successes of the first matching branch *)
+  | Once    (* returns the first success in a maching branch
+               (not necessarily the first) *)
+type global_flag = (* [gfail] or [fail] *)
+  | TacGlobal
+  | TacLocal
+type evars_flag = bool     (* true = pose evars       false = fail on evars *)
+type rec_flag = bool       (* true = recursive        false = not recursive *)
+type advanced_flag = bool  (* true = advanced         false = basic *)
+type letin_flag = bool     (* true = use local def    false = use Leibniz *)
+type clear_flag = bool option (* true = clear hyp, false = keep hyp, None = use default *)
+
+type goal_selector = Vernacexpr.goal_selector =
+  | SelectNth of int
+  | SelectList of (int * int) list
+  | SelectId of Id.t
+  | SelectAll
+
+type 'a core_destruction_arg = 'a Misctypes.core_destruction_arg =
+  | ElimOnConstr of 'a
+  | ElimOnIdent of Id.t located
+  | ElimOnAnonHyp of int
+
+type 'a destruction_arg =
+  clear_flag * 'a core_destruction_arg
+
+type inversion_kind = Misctypes.inversion_kind =
+  | SimpleInversion
+  | FullInversion
+  | FullInversionClear
+
+type ('c,'d,'id) inversion_strength =
+  | NonDepInversion of
+      inversion_kind * 'id list * 'd or_and_intro_pattern_expr located or_var option
+  | DepInversion of
+      inversion_kind * 'c option * 'd or_and_intro_pattern_expr located or_var option
+  | InversionUsing of 'c * 'id list
+
+type ('a,'b) location = HypLocation of 'a | ConclLocation of 'b
+
+type 'id message_token =
+  | MsgString of string
+  | MsgInt of int
+  | MsgIdent of 'id
+
+type ('dconstr,'id) induction_clause =
+    'dconstr with_bindings destruction_arg *
+    (intro_pattern_naming_expr located option (* eqn:... *)
+    * 'dconstr or_and_intro_pattern_expr located or_var option) (* as ... *)
+    * 'id clause_expr option (* in ... *)
+
+type ('constr,'dconstr,'id) induction_clause_list =
+    ('dconstr,'id) induction_clause list
+    * 'constr with_bindings option (* using ... *)
+
+type 'a with_bindings_arg = clear_flag * 'a with_bindings
+
+(* Type of patterns *)
+type 'a match_pattern =
+  | Term of 'a
+  | Subterm of bool * Id.t option * 'a
+
+(* Type of hypotheses for a Match Context rule *)
+type 'a match_context_hyps =
+  | Hyp of Name.t located * 'a match_pattern
+  | Def of Name.t located * 'a match_pattern * 'a match_pattern
+
+(* Type of a Match rule for Match Context and Match *)
+type ('a,'t) match_rule =
+  | Pat of 'a match_context_hyps list * 'a match_pattern * 't
+  | All of 't
+
+(** Extension indentifiers for the TACTIC EXTEND mechanism. *)
+type ml_tactic_name = {
+  (** Name of the plugin where the tactic is defined, typically coming from a
+      DECLARE PLUGIN statement in the source. *)
+  mltac_plugin : string;
+  (** Name of the tactic entry where the tactic is defined, typically found
+      after the TACTIC EXTEND statement in the source. *)
+  mltac_tactic : string;
+}
+
+type ml_tactic_entry = {
+  mltac_name : ml_tactic_name;
+  mltac_index : int;
+}
+
+(** Composite types *)
+
+type glob_constr_and_expr = Tactypes.glob_constr_and_expr
+
+type open_constr_expr = unit * constr_expr
+type open_glob_constr = unit * glob_constr_and_expr
+
+type binding_bound_vars = Constr_matching.binding_bound_vars
+type glob_constr_pattern_and_expr = binding_bound_vars * glob_constr_and_expr * constr_pattern
+
+type 'a delayed_open = 'a Tactypes.delayed_open =
+  { delayed : 'r. Environ.env -> 'r Sigma.t -> ('a, 'r) Sigma.sigma }
+
+type delayed_open_constr_with_bindings = EConstr.constr with_bindings delayed_open
+
+type delayed_open_constr = EConstr.constr delayed_open
+
+type intro_pattern = delayed_open_constr intro_pattern_expr located
+type intro_patterns = delayed_open_constr intro_pattern_expr located list
+type or_and_intro_pattern = delayed_open_constr or_and_intro_pattern_expr located
+type intro_pattern_naming = intro_pattern_naming_expr located
+
+(** Generic expressions for atomic tactics *)
+
+type 'a gen_atomic_tactic_expr =
+  (* Basic tactics *)
+  | TacIntroPattern of evars_flag * 'dtrm intro_pattern_expr located list
+  | TacApply of advanced_flag * evars_flag * 'trm with_bindings_arg list *
+      ('nam * 'dtrm intro_pattern_expr located option) option
+  | TacElim of evars_flag * 'trm with_bindings_arg * 'trm with_bindings option
+  | TacCase of evars_flag * 'trm with_bindings_arg
+  | TacMutualFix of Id.t * int * (Id.t * int * 'trm) list
+  | TacMutualCofix of Id.t * (Id.t * 'trm) list
+  | TacAssert of
+      bool * 'tacexpr option option *
+      'dtrm intro_pattern_expr located option * 'trm
+  | TacGeneralize of ('trm with_occurrences * Name.t) list
+  | TacLetTac of Name.t * 'trm * 'nam clause_expr * letin_flag *
+      intro_pattern_naming_expr located option
+
+  (* Derived basic tactics *)
+  | TacInductionDestruct of
+      rec_flag * evars_flag * ('trm,'dtrm,'nam) induction_clause_list
+
+  (* Conversion *)
+  | TacReduce of ('trm,'cst,'pat) red_expr_gen * 'nam clause_expr
+  | TacChange of 'pat option * 'dtrm * 'nam clause_expr
+
+  (* Equality and inversion *)
+  | TacRewrite of evars_flag *
+      (bool * multi * 'dtrm with_bindings_arg) list * 'nam clause_expr *
+      (* spiwack: using ['dtrm] here is a small hack, may not be
+         stable by a change in the representation of delayed
+         terms. Because, in fact, it is the whole "with_bindings"
+         which is delayed. But because the "t" level for ['dtrm] is
+         uninterpreted, it works fine here too, and avoid more
+         disruption of this file. *)
+      'tacexpr option
+  | TacInversion of ('trm,'dtrm,'nam) inversion_strength * quantified_hypothesis
+
+constraint 'a = <
+    term:'trm;
+    dterm: 'dtrm;
+    pattern:'pat;
+    constant:'cst;
+    reference:'ref;
+    name:'nam;
+    tacexpr:'tacexpr;
+    level:'lev
+>
+
+(** Possible arguments of a tactic definition *)
+
+type 'a gen_tactic_arg =
+  | TacGeneric     of 'lev generic_argument
+  | ConstrMayEval  of ('trm,'cst,'pat) may_eval
+  | Reference      of 'ref
+  | TacCall of Loc.t * 'ref *
+      'a gen_tactic_arg list
+  | TacFreshId of string or_var list
+  | Tacexp of 'tacexpr
+  | TacPretype of 'trm
+  | TacNumgoals
+
+constraint 'a = <
+    term:'trm;
+    dterm: 'dtrm;
+    pattern:'pat;
+    constant:'cst;
+    reference:'ref;
+    name:'nam;
+    tacexpr:'tacexpr;
+    level:'lev
+>
+
+(** Generic ltac expressions.
+    't : terms, 'p : patterns, 'c : constants, 'i : inductive,
+    'r : ltac refs, 'n : idents, 'l : levels *)
+
+and 'a gen_tactic_expr =
+  | TacAtom of Loc.t * 'a gen_atomic_tactic_expr
+  | TacThen of
+      'a gen_tactic_expr *
+      'a gen_tactic_expr
+  | TacDispatch of
+      'a gen_tactic_expr list
+  | TacExtendTac of
+      'a gen_tactic_expr array *
+      'a gen_tactic_expr *
+      'a gen_tactic_expr array
+  | TacThens of
+      'a gen_tactic_expr *
+      'a gen_tactic_expr list
+  | TacThens3parts of
+      'a gen_tactic_expr *
+      'a gen_tactic_expr array *
+      'a gen_tactic_expr *
+      'a gen_tactic_expr array
+  | TacFirst of 'a gen_tactic_expr list
+  | TacComplete of 'a gen_tactic_expr
+  | TacSolve of 'a gen_tactic_expr list
+  | TacTry of 'a gen_tactic_expr
+  | TacOr of
+      'a gen_tactic_expr *
+      'a gen_tactic_expr
+  | TacOnce of
+      'a gen_tactic_expr
+  | TacExactlyOnce of
+      'a gen_tactic_expr
+  | TacIfThenCatch of
+      'a gen_tactic_expr *
+      'a gen_tactic_expr *
+      'a gen_tactic_expr
+  | TacOrelse of
+      'a gen_tactic_expr *
+      'a gen_tactic_expr
+  | TacDo of int or_var * 'a gen_tactic_expr
+  | TacTimeout of int or_var * 'a gen_tactic_expr
+  | TacTime of string option * 'a gen_tactic_expr
+  | TacRepeat of 'a gen_tactic_expr
+  | TacProgress of 'a gen_tactic_expr
+  | TacShowHyps of 'a gen_tactic_expr
+  | TacAbstract of
+      'a gen_tactic_expr * Id.t option
+  | TacId of 'n message_token list
+  | TacFail of global_flag * int or_var * 'n message_token list
+  | TacInfo of 'a gen_tactic_expr
+  | TacLetIn of rec_flag *
+      (Id.t located * 'a gen_tactic_arg) list *
+      'a gen_tactic_expr
+  | TacMatch of lazy_flag *
+      'a gen_tactic_expr *
+      ('p,'a gen_tactic_expr) match_rule list
+  | TacMatchGoal of lazy_flag * direction_flag *
+      ('p,'a gen_tactic_expr) match_rule list
+  | TacFun of 'a gen_tactic_fun_ast
+  | TacArg of 'a gen_tactic_arg located
+  | TacSelect of goal_selector * 'a gen_tactic_expr
+  (* For ML extensions *)
+  | TacML of Loc.t * ml_tactic_entry * 'a gen_tactic_arg list
+  (* For syntax extensions *)
+  | TacAlias of Loc.t * KerName.t * 'a gen_tactic_arg list
+
+constraint 'a = <
+    term:'t;
+    dterm: 'dtrm;
+    pattern:'p;
+    constant:'c;
+    reference:'r;
+    name:'n;
+    tacexpr:'tacexpr;
+    level:'l
+>
+
+and 'a gen_tactic_fun_ast =
+    Name.t list * 'a gen_tactic_expr
+
+constraint 'a = <
+    term:'t;
+    dterm: 'dtrm;
+    pattern:'p;
+    constant:'c;
+    reference:'r;
+    name:'n;
+    tacexpr:'te;
+    level:'l
+>
+
+(** Globalized tactics *)
+
+type g_trm = glob_constr_and_expr
+type g_pat = glob_constr_pattern_and_expr
+type g_cst = evaluable_global_reference and_short_name or_var
+type g_ref = ltac_constant located or_var
+type g_nam  = Id.t located
+
+type g_dispatch =  <
+    term:g_trm;
+    dterm:g_trm;
+    pattern:g_pat;
+    constant:g_cst;
+    reference:g_ref;
+    name:g_nam;
+    tacexpr:glob_tactic_expr;
+    level:glevel
+>
+
+and glob_tactic_expr =
+    g_dispatch gen_tactic_expr
+
+type glob_atomic_tactic_expr =
+    g_dispatch gen_atomic_tactic_expr
+
+type glob_tactic_arg =
+    g_dispatch gen_tactic_arg
+
+(** Raw tactics *)
+
+type r_trm = constr_expr
+type r_pat = constr_pattern_expr
+type r_cst = reference or_by_notation
+type r_ref = reference
+type r_nam  = Id.t located
+type r_lev = rlevel
+
+type r_dispatch =  <
+    term:r_trm;
+    dterm:r_trm;
+    pattern:r_pat;
+    constant:r_cst;
+    reference:r_ref;
+    name:r_nam;
+    tacexpr:raw_tactic_expr;
+    level:rlevel
+>
+
+and raw_tactic_expr =
+    r_dispatch gen_tactic_expr
+
+type raw_atomic_tactic_expr =
+    r_dispatch gen_atomic_tactic_expr
+
+type raw_tactic_arg =
+    r_dispatch gen_tactic_arg
+
+(** Interpreted tactics *)
+
+type t_trm = EConstr.constr
+type t_pat = constr_pattern
+type t_cst = evaluable_global_reference
+type t_ref = ltac_constant located
+type t_nam  = Id.t
+
+type t_dispatch =  <
+    term:t_trm;
+    dterm:g_trm;
+    pattern:t_pat;
+    constant:t_cst;
+    reference:t_ref;
+    name:t_nam;
+    tacexpr:unit;
+    level:tlevel
+>
+
+type atomic_tactic_expr =
+    t_dispatch gen_atomic_tactic_expr
+
+(** Misc *)
+
+type raw_red_expr = (r_trm, r_cst, r_pat) red_expr_gen
+type glob_red_expr = (g_trm, g_cst, g_pat) red_expr_gen
+
+(** Traces *)
+
+type ltac_call_kind =
+  | LtacMLCall of glob_tactic_expr
+  | LtacNotationCall of KerName.t
+  | LtacNameCall of ltac_constant
+  | LtacAtomCall of glob_atomic_tactic_expr
+  | LtacVarCall of Id.t * glob_tactic_expr
+  | LtacConstrInterp of Glob_term.glob_constr * Pretyping.ltac_var_map
+
+type ltac_trace = (Loc.t * ltac_call_kind) list
+
+type tacdef_body =
+  | TacticDefinition of Id.t Loc.located * raw_tactic_expr  (* indicates that user employed ':=' in Ltac body *)
+  | TacticRedefinition of reference * raw_tactic_expr       (* indicates that user employed '::=' in Ltac body *)
diff --git a/plugins/ltac/tacintern.ml b/plugins/ltac/tacintern.ml
new file mode 100644
index 000000000..3f83f104e
--- /dev/null
+++ b/plugins/ltac/tacintern.ml
@@ -0,0 +1,811 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+open Pattern
+open Pp
+open Genredexpr
+open Glob_term
+open Tacred
+open CErrors
+open Util
+open Names
+open Nameops
+open Libnames
+open Globnames
+open Nametab
+open Smartlocate
+open Constrexpr
+open Termops
+open Tacexpr
+open Genarg
+open Stdarg
+open Tacarg
+open Misctypes
+open Locus
+
+(** Globalization of tactic expressions :
+    Conversion from [raw_tactic_expr] to [glob_tactic_expr] *)
+
+let dloc = Loc.ghost
+
+let error_tactic_expected ?loc =
+  user_err ?loc  (str "Tactic expected.")
+
+(** Generic arguments *)
+
+type glob_sign = Genintern.glob_sign = {
+  ltacvars : Id.Set.t;
+     (* ltac variables and the subset of vars introduced by Intro/Let/... *)
+  genv : Environ.env }
+
+let fully_empty_glob_sign =
+  { ltacvars = Id.Set.empty; genv = Environ.empty_env }
+
+let make_empty_glob_sign () =
+  { fully_empty_glob_sign with genv = Global.env () }
+
+(* We have identifier <| global_reference <| constr *)
+
+let find_ident id ist =
+  Id.Set.mem id ist.ltacvars ||
+  Id.List.mem id (ids_of_named_context (Environ.named_context ist.genv))
+
+(* a "var" is a ltac var or a var introduced by an intro tactic *)
+let find_var id ist = Id.Set.mem id ist.ltacvars
+
+let find_hyp id ist =
+  Id.List.mem id (ids_of_named_context (Environ.named_context ist.genv))
+
+(* Globalize a name introduced by Intro/LetTac/... ; it is allowed to *)
+(* be fresh in which case it is binding later on *)
+let intern_ident s ist id =
+  (* We use identifier both for variables and new names; thus nothing to do *)
+  if not (find_ident id ist) then s := Id.Set.add id !s;
+  id
+
+let intern_name l ist = function
+  | Anonymous -> Anonymous
+  | Name id -> Name (intern_ident l ist id)
+
+let strict_check = ref false
+
+let adjust_loc loc = if !strict_check then dloc else loc
+
+(* Globalize a name which must be bound -- actually just check it is bound *)
+let intern_hyp ist (loc,id as locid) =
+  if not !strict_check then
+    locid
+  else if find_ident id ist then
+    (dloc,id)
+  else
+    Pretype_errors.error_var_not_found ~loc id
+
+let intern_or_var f ist = function
+  | ArgVar locid -> ArgVar (intern_hyp ist locid)
+  | ArgArg x -> ArgArg (f x)
+
+let intern_int_or_var = intern_or_var (fun (n : int) -> n)
+let intern_string_or_var = intern_or_var (fun (s : string) -> s)
+
+let intern_global_reference ist = function
+  | Ident (loc,id) when find_var id ist -> ArgVar (loc,id)
+  | r ->
+      let loc,_ as lqid = qualid_of_reference r in
+      try ArgArg (loc,locate_global_with_alias lqid)
+      with Not_found -> error_global_not_found (snd lqid)
+
+let intern_ltac_variable ist = function
+  | Ident (loc,id) ->
+      if find_var id ist then
+	(* A local variable of any type *)
+	ArgVar (loc,id)
+      else raise Not_found
+  | _ ->
+      raise Not_found
+
+let intern_constr_reference strict ist = function
+  | Ident (_,id) as r when not strict && find_hyp id ist ->
+      GVar (dloc,id), Some (CRef (r,None))
+  | Ident (_,id) as r when find_var id ist ->
+      GVar (dloc,id), if strict then None else Some (CRef (r,None))
+  | r ->
+      let loc,_ as lqid = qualid_of_reference r in
+      GRef (loc,locate_global_with_alias lqid,None), 
+	if strict then None else Some (CRef (r,None))
+
+let intern_move_location ist = function
+  | MoveAfter id -> MoveAfter (intern_hyp ist id)
+  | MoveBefore id -> MoveBefore (intern_hyp ist id)
+  | MoveFirst -> MoveFirst
+  | MoveLast -> MoveLast
+
+(* Internalize an isolated reference in position of tactic *)
+
+let intern_isolated_global_tactic_reference r =
+  let (loc,qid) = qualid_of_reference r in
+  TacCall (loc,ArgArg (loc,locate_tactic qid),[])
+
+let intern_isolated_tactic_reference strict ist r =
+  (* An ltac reference *)
+  try Reference (intern_ltac_variable ist r)
+  with Not_found ->
+  (* A global tactic *)
+  try intern_isolated_global_tactic_reference r
+  with Not_found ->
+  (* Tolerance for compatibility, allow not to use "constr:" *)
+  try ConstrMayEval (ConstrTerm (intern_constr_reference strict ist r))
+  with Not_found ->
+  (* Reference not found *)
+  error_global_not_found (snd (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 (snd (qualid_of_reference r))
+
+(* Intern a reference parsed in a non-tactic entry *)
+
+let intern_non_tactic_reference strict ist r =
+  (* An ltac reference *)
+  try Reference (intern_ltac_variable ist r)
+  with Not_found ->
+  (* A constr reference *)
+  try ConstrMayEval (ConstrTerm (intern_constr_reference strict ist r))
+  with Not_found ->
+  (* Tolerance for compatibility, allow not to use "ltac:" *)
+  try intern_isolated_global_tactic_reference r
+  with Not_found ->
+  (* By convention, use IntroIdentifier for unbound ident, when not in a def *)
+  match r with
+  | Ident (loc,id) when not strict ->
+    let ipat = in_gen (glbwit wit_intro_pattern) (loc, IntroNaming (IntroIdentifier id)) in
+    TacGeneric ipat
+  | _ ->
+  (* Reference not found *)
+  error_global_not_found (snd (qualid_of_reference r))
+
+let intern_message_token ist = function
+  | (MsgString _ | MsgInt _ as x) -> x
+  | MsgIdent id -> MsgIdent (intern_hyp ist id)
+
+let intern_message ist = List.map (intern_message_token ist)
+
+let intern_quantified_hypothesis ist = function
+  | AnonHyp n -> AnonHyp n
+  | NamedHyp id ->
+      (* Uncomment to disallow "intros until n" in ltac when n is not bound *)
+      NamedHyp ((*snd (intern_hyp ist (dloc,*)id(* ))*))
+
+let intern_binding_name ist x =
+  (* We use identifier both for variables and binding names *)
+  (* Todo: consider the body of the lemma to which the binding refer
+     and if a term w/o ltac vars, check the name is indeed quantified *)
+  x
+
+let intern_constr_gen allow_patvar isarity {ltacvars=lfun; genv=env} c =
+  let warn = if !strict_check then fun x -> x else Constrintern.for_grammar in
+  let scope = if isarity then Pretyping.IsType else Pretyping.WithoutTypeConstraint in
+  let ltacvars = {
+    Constrintern.ltac_vars = lfun;
+    ltac_bound = Id.Set.empty;
+  } in
+  let c' =
+    warn (Constrintern.intern_gen scope ~allow_patvar ~ltacvars env) c
+  in
+  (c',if !strict_check then None else Some c)
+
+let intern_constr = intern_constr_gen false false
+let intern_type = intern_constr_gen false true
+
+(* Globalize bindings *)
+let intern_binding ist (loc,b,c) =
+  (loc,intern_binding_name ist b,intern_constr ist c)
+
+let intern_bindings ist = function
+  | NoBindings -> NoBindings
+  | ImplicitBindings l -> ImplicitBindings (List.map (intern_constr ist) l)
+  | ExplicitBindings l -> ExplicitBindings (List.map (intern_binding ist) l)
+
+let intern_constr_with_bindings ist (c,bl) =
+  (intern_constr ist c, intern_bindings ist bl)
+
+let intern_constr_with_bindings_arg ist (clear,c) =
+  (clear,intern_constr_with_bindings ist c)
+
+let rec intern_intro_pattern lf ist = function
+  | loc, IntroNaming pat ->
+      loc, IntroNaming (intern_intro_pattern_naming lf ist pat)
+  | loc, IntroAction pat ->
+      loc, IntroAction (intern_intro_pattern_action lf ist pat)
+  | loc, IntroForthcoming _ as x -> x
+
+and intern_intro_pattern_naming lf ist = function
+  | IntroIdentifier id ->
+      IntroIdentifier (intern_ident lf ist id)
+  | IntroFresh id ->
+      IntroFresh (intern_ident lf ist id)
+  | IntroAnonymous as x -> x
+
+and intern_intro_pattern_action lf ist = function
+  | IntroOrAndPattern l ->
+      IntroOrAndPattern (intern_or_and_intro_pattern lf ist l)
+  | IntroInjection l ->
+      IntroInjection (List.map (intern_intro_pattern lf ist) l)
+  | IntroWildcard | IntroRewrite _ as x -> x
+  | IntroApplyOn ((loc,c),pat) ->
+      IntroApplyOn ((loc,intern_constr ist c), intern_intro_pattern lf ist pat)
+
+and intern_or_and_intro_pattern lf ist = function
+   | IntroAndPattern l ->
+      IntroAndPattern (List.map (intern_intro_pattern lf ist) l)
+  | IntroOrPattern ll ->
+      IntroOrPattern (List.map (List.map (intern_intro_pattern lf ist)) ll)
+
+let intern_or_and_intro_pattern_loc lf ist = function
+  | ArgVar (_,id) as x ->
+      if find_var id ist then x
+      else error "Disjunctive/conjunctive introduction pattern expected."
+  | ArgArg (loc,l) -> ArgArg (loc,intern_or_and_intro_pattern lf ist l)
+
+let intern_intro_pattern_naming_loc lf ist (loc,pat) =
+  (loc,intern_intro_pattern_naming lf ist pat)
+
+  (* TODO: catch ltac vars *)
+let intern_destruction_arg ist = function
+  | clear,ElimOnConstr c -> clear,ElimOnConstr (intern_constr_with_bindings ist c)
+  | clear,ElimOnAnonHyp n as x -> x
+  | clear,ElimOnIdent (loc,id) ->
+      if !strict_check then
+	(* If in a defined tactic, no intros-until *)
+	match intern_constr ist (CRef (Ident (dloc,id), None)) with
+	| GVar (loc,id),_ -> clear,ElimOnIdent (loc,id)
+	| c -> clear,ElimOnConstr (c,NoBindings)
+      else
+	clear,ElimOnIdent (loc,id)
+
+let short_name = function
+  | AN (Ident (loc,id)) when not !strict_check -> Some (loc,id)
+  | _ -> None
+
+let intern_evaluable_global_reference ist r =
+  let lqid = qualid_of_reference r in
+  try evaluable_of_global_reference ist.genv (locate_global_with_alias ~head:true lqid)
+  with Not_found ->
+  match r with
+  | Ident (loc,id) when not !strict_check -> EvalVarRef id
+  | _ -> error_global_not_found (snd lqid)
+
+let intern_evaluable_reference_or_by_notation ist = function
+  | AN r -> intern_evaluable_global_reference ist r
+  | ByNotation (loc,ntn,sc) ->
+      evaluable_of_global_reference ist.genv
+      (Notation.interp_notation_as_global_reference loc
+        (function ConstRef _ | VarRef _ -> true | _ -> false) ntn sc)
+
+(* Globalize a reduction expression *)
+let intern_evaluable ist = function
+  | AN (Ident (loc,id)) when find_var id ist -> ArgVar (loc,id)
+  | AN (Ident (loc,id)) when not !strict_check && find_hyp id ist ->
+      ArgArg (EvalVarRef id, Some (loc,id))
+  | r ->
+      let e = intern_evaluable_reference_or_by_notation ist r in
+      let na = short_name r in
+      ArgArg (e,na)
+
+let intern_unfold ist (l,qid) = (l,intern_evaluable ist qid)
+
+let intern_flag ist red =
+  { red with rConst = List.map (intern_evaluable ist) red.rConst }
+
+let intern_constr_with_occurrences ist (l,c) = (l,intern_constr ist c)
+
+let intern_constr_pattern ist ~as_type ~ltacvars pc =
+  let ltacvars = {
+    Constrintern.ltac_vars = ltacvars;
+    ltac_bound = Id.Set.empty;
+  } in
+  let metas,pat = Constrintern.intern_constr_pattern
+    ist.genv ~as_type ~ltacvars pc
+  in
+  let (glob,_ as c) = intern_constr_gen true false ist pc in
+  let bound_names = Glob_ops.bound_glob_vars glob in
+  metas,(bound_names,c,pat)
+
+let dummy_pat = PRel 0
+
+let intern_typed_pattern ist p =
+  (* we cannot ensure in non strict mode that the pattern is closed *)
+  (* keeping a constr_expr copy is too complicated and we want anyway to *)
+  (* type it, so we remember the pattern as a glob_constr only *)
+  let (glob,_ as c) = intern_constr_gen true false ist p in
+  let bound_names = Glob_ops.bound_glob_vars glob in
+  (bound_names,c,dummy_pat)
+
+let intern_typed_pattern_or_ref_with_occurrences ist (l,p) =
+  let interp_ref r =
+    try Inl (intern_evaluable ist r)
+    with e when Logic.catchable_exception e ->
+      (* Compatibility. In practice, this means that the code above
+         is useless. Still the idea of having either an evaluable
+         ref or a pattern seems interesting, with "head" reduction
+         in case of an evaluable ref, and "strong" reduction in the
+         subterm matched when a pattern *)
+      let loc = loc_of_smart_reference r in
+      let r = match r with
+      | AN r -> r
+      | _ -> Qualid (loc,qualid_of_path (path_of_global (smart_global r))) in
+      let sign = { Constrintern.ltac_vars = ist.ltacvars; Constrintern.ltac_bound = Id.Set.empty } in
+      let c = Constrintern.interp_reference sign r in
+      match c with
+      | GRef (_,r,None) ->
+          Inl (ArgArg (evaluable_of_global_reference ist.genv r,None))
+      | GVar (_,id) ->
+          let r = evaluable_of_global_reference ist.genv (VarRef id) in
+          Inl (ArgArg (r,None))
+      | _ ->
+          let bound_names = Glob_ops.bound_glob_vars c in
+          Inr (bound_names,(c,None),dummy_pat) in
+  (l, match p with
+  | Inl r -> interp_ref r
+  | Inr (CAppExpl(_,(None,r,None),[])) ->
+      (* We interpret similarly @ref and ref *)
+      interp_ref (AN r)
+  | Inr c ->
+      Inr (intern_typed_pattern ist c))
+
+(* This seems fairly hacky, but it's the first way I've found to get proper
+   globalization of [unfold].  --adamc *)
+let dump_glob_red_expr = function
+  | Unfold occs -> List.iter (fun (_, r) ->
+    try
+      Dumpglob.add_glob (loc_of_or_by_notation Libnames.loc_of_reference r)
+	(Smartlocate.smart_global r)
+    with e when CErrors.noncritical e -> ()) occs
+  | Cbv grf | Lazy grf ->
+    List.iter (fun r ->
+      try
+        Dumpglob.add_glob (loc_of_or_by_notation Libnames.loc_of_reference r)
+	  (Smartlocate.smart_global r)
+      with e when CErrors.noncritical e -> ()) grf.rConst
+  | _ -> ()
+
+let intern_red_expr ist = function
+  | Unfold l -> Unfold (List.map (intern_unfold ist) l)
+  | Fold l -> Fold (List.map (intern_constr ist) l)
+  | Cbv f -> Cbv (intern_flag ist f)
+  | Cbn f -> Cbn (intern_flag ist f)
+  | Lazy f -> Lazy (intern_flag ist f)
+  | Pattern l -> Pattern (List.map (intern_constr_with_occurrences ist) l)
+  | Simpl (f,o) ->
+     Simpl (intern_flag ist f,
+	    Option.map (intern_typed_pattern_or_ref_with_occurrences ist) o)
+  | CbvVm o -> CbvVm (Option.map (intern_typed_pattern_or_ref_with_occurrences ist) o)
+  | CbvNative o -> CbvNative (Option.map (intern_typed_pattern_or_ref_with_occurrences ist) o)
+  | (Red _ | Hnf | ExtraRedExpr _ as r ) -> r
+
+let intern_in_hyp_as ist lf (id,ipat) =
+  (intern_hyp ist id, Option.map (intern_intro_pattern lf ist) ipat)
+
+let intern_hyp_list ist = List.map (intern_hyp ist)
+
+let intern_inversion_strength lf ist = function
+  | NonDepInversion (k,idl,ids) ->
+      NonDepInversion (k,intern_hyp_list ist idl,
+      Option.map (intern_or_and_intro_pattern_loc lf ist) ids)
+  | DepInversion (k,copt,ids) ->
+      DepInversion (k, Option.map (intern_constr ist) copt,
+      Option.map (intern_or_and_intro_pattern_loc lf ist) ids)
+  | InversionUsing (c,idl) ->
+      InversionUsing (intern_constr ist c, intern_hyp_list ist idl)
+
+(* Interprets an hypothesis name *)
+let intern_hyp_location ist ((occs,id),hl) =
+  ((Locusops.occurrences_map (List.map (intern_int_or_var ist)) occs,
+   intern_hyp ist id), hl)
+
+(* Reads a pattern *)
+let intern_pattern ist ?(as_type=false) ltacvars = function
+  | Subterm (b,ido,pc) ->
+      let (metas,pc) = intern_constr_pattern ist ~as_type:false ~ltacvars pc in
+      ido, metas, Subterm (b,ido,pc)
+  | Term pc ->
+      let (metas,pc) = intern_constr_pattern ist ~as_type ~ltacvars pc in
+      None, metas, Term pc
+
+let intern_constr_may_eval ist = function
+  | ConstrEval (r,c) -> ConstrEval (intern_red_expr ist r,intern_constr ist c)
+  | ConstrContext (locid,c) ->
+      ConstrContext (intern_hyp ist locid,intern_constr ist c)
+  | ConstrTypeOf c -> ConstrTypeOf (intern_constr ist c)
+  | ConstrTerm c -> ConstrTerm (intern_constr ist c)
+
+let name_cons accu = function
+| Anonymous -> accu
+| Name id -> Id.Set.add id accu
+
+let opt_cons accu = function
+| None -> accu
+| Some id -> Id.Set.add id accu
+
+(* Reads the hypotheses of a "match goal" rule *)
+let rec intern_match_goal_hyps ist ?(as_type=false) lfun = function
+  | (Hyp ((_,na) as locna,mp))::tl ->
+      let ido, metas1, pat = intern_pattern ist ~as_type:true lfun mp in
+      let lfun, metas2, hyps = intern_match_goal_hyps ist lfun tl in
+      let lfun' = name_cons (opt_cons lfun ido) na in
+      lfun', metas1@metas2, Hyp (locna,pat)::hyps
+  | (Def ((_,na) as locna,mv,mp))::tl ->
+      let ido, metas1, patv = intern_pattern ist ~as_type:false lfun mv in
+      let ido', metas2, patt = intern_pattern ist ~as_type:true lfun mp in
+      let lfun, metas3, hyps = intern_match_goal_hyps ist ~as_type lfun tl in
+      let lfun' = name_cons (opt_cons (opt_cons lfun ido) ido') na in
+      lfun', metas1@metas2@metas3, Def (locna,patv,patt)::hyps
+  | [] -> lfun, [], []
+
+(* Utilities *)
+let extract_let_names lrc =
+  let fold accu ((loc, name), _) =
+    if Id.Set.mem name accu then user_err ~loc
+      ~hdr:"glob_tactic" (str "This variable is bound several times.")
+    else Id.Set.add name accu
+  in
+  List.fold_left fold Id.Set.empty lrc
+
+let clause_app f = function
+    { onhyps=None; concl_occs=nl } ->
+      { onhyps=None; concl_occs=nl }
+  | { onhyps=Some l; concl_occs=nl } ->
+      { onhyps=Some(List.map f l); concl_occs=nl}
+
+(* Globalizes tactics : raw_tactic_expr -> glob_tactic_expr *)
+let rec intern_atomic lf ist x =
+  match (x:raw_atomic_tactic_expr) with
+  (* Basic tactics *)
+  | TacIntroPattern (ev,l) ->
+      TacIntroPattern (ev,List.map (intern_intro_pattern lf ist) l)
+  | TacApply (a,ev,cb,inhyp) ->
+      TacApply (a,ev,List.map (intern_constr_with_bindings_arg ist) cb,
+                Option.map (intern_in_hyp_as ist lf) inhyp)
+  | TacElim (ev,cb,cbo) ->
+      TacElim (ev,intern_constr_with_bindings_arg ist cb,
+               Option.map (intern_constr_with_bindings ist) cbo)
+  | TacCase (ev,cb) -> TacCase (ev,intern_constr_with_bindings_arg ist cb)
+  | TacMutualFix (id,n,l) ->
+      let f (id,n,c) = (intern_ident lf ist id,n,intern_type ist c) in
+      TacMutualFix (intern_ident lf ist id, n, List.map f l)
+  | TacMutualCofix (id,l) ->
+      let f (id,c) = (intern_ident lf ist id,intern_type ist c) in
+      TacMutualCofix (intern_ident lf ist id, List.map f l)
+  | TacAssert (b,otac,ipat,c) ->
+      TacAssert (b,Option.map (Option.map (intern_pure_tactic ist)) otac,
+                 Option.map (intern_intro_pattern lf ist) ipat,
+                 intern_constr_gen false (not (Option.is_empty otac)) ist c)
+  | TacGeneralize cl ->
+      TacGeneralize (List.map (fun (c,na) ->
+	               intern_constr_with_occurrences ist c,
+                       intern_name lf ist na) cl)
+  | TacLetTac (na,c,cls,b,eqpat) ->
+      let na = intern_name lf ist na in
+      TacLetTac (na,intern_constr ist c,
+                 (clause_app (intern_hyp_location ist) cls),b,
+		 (Option.map (intern_intro_pattern_naming_loc lf ist) eqpat))
+
+  (* Derived basic tactics *)
+  | TacInductionDestruct (ev,isrec,(l,el)) ->
+      TacInductionDestruct (ev,isrec,(List.map (fun (c,(ipato,ipats),cls) ->
+	      (intern_destruction_arg ist c,
+               (Option.map (intern_intro_pattern_naming_loc lf ist) ipato,
+               Option.map (intern_or_and_intro_pattern_loc lf ist) ipats),
+               Option.map (clause_app (intern_hyp_location ist)) cls)) l,
+               Option.map (intern_constr_with_bindings ist) el))
+  (* Conversion *)
+  | TacReduce (r,cl) ->
+      dump_glob_red_expr r;
+      TacReduce (intern_red_expr ist r, clause_app (intern_hyp_location ist) cl)
+  | TacChange (None,c,cl) ->
+      let is_onhyps = match cl.onhyps with
+      | None | Some [] -> true
+      | _ -> false
+      in
+      let is_onconcl = match cl.concl_occs with
+      | AllOccurrences | NoOccurrences -> true
+      | _ -> false
+      in
+      TacChange (None,
+        (if is_onhyps && is_onconcl
+         then intern_type ist c else intern_constr ist c),
+	clause_app (intern_hyp_location ist) cl)
+  | TacChange (Some p,c,cl) ->
+      TacChange (Some (intern_typed_pattern ist p),intern_constr ist c,
+	clause_app (intern_hyp_location ist) cl)
+
+  (* Equality and inversion *)
+  | TacRewrite (ev,l,cl,by) ->
+      TacRewrite
+	(ev,
+	List.map (fun (b,m,c) -> (b,m,intern_constr_with_bindings_arg ist c)) l,
+	clause_app (intern_hyp_location ist) cl,
+	Option.map (intern_pure_tactic ist) by)
+  | TacInversion (inv,hyp) ->
+      TacInversion (intern_inversion_strength lf ist inv,
+        intern_quantified_hypothesis ist hyp)
+
+and intern_tactic onlytac ist tac = snd (intern_tactic_seq onlytac ist tac)
+
+and intern_tactic_seq onlytac ist = function
+  | TacAtom (loc,t) ->
+      let lf = ref ist.ltacvars in
+      let t = intern_atomic lf ist t in
+      !lf, TacAtom (adjust_loc loc, t)
+  | TacFun tacfun -> ist.ltacvars, TacFun (intern_tactic_fun ist tacfun)
+  | TacLetIn (isrec,l,u) ->
+      let ltacvars = Id.Set.union (extract_let_names l) ist.ltacvars in
+      let ist' = { ist with ltacvars } in
+      let l = List.map (fun (n,b) ->
+	  (n,intern_tacarg !strict_check false (if isrec then ist' else ist) b)) l in
+      ist.ltacvars, TacLetIn (isrec,l,intern_tactic onlytac ist' u)
+
+  | TacMatchGoal (lz,lr,lmr) ->
+      ist.ltacvars, TacMatchGoal(lz,lr, intern_match_rule onlytac ist ~as_type:true lmr)
+  | TacMatch (lz,c,lmr) ->
+      ist.ltacvars,
+      TacMatch (lz,intern_tactic_or_tacarg ist c,intern_match_rule onlytac ist lmr)
+  | TacId l -> ist.ltacvars, TacId (intern_message ist l)
+  | TacFail (g,n,l) ->
+      ist.ltacvars, TacFail (g,intern_int_or_var ist n,intern_message ist l)
+  | TacProgress tac -> ist.ltacvars, TacProgress (intern_pure_tactic ist tac)
+  | TacShowHyps tac -> ist.ltacvars, TacShowHyps (intern_pure_tactic ist tac)
+  | TacAbstract (tac,s) ->
+      ist.ltacvars, TacAbstract (intern_pure_tactic ist tac,s)
+  | TacThen (t1,t2) ->
+      let lfun', t1 = intern_tactic_seq onlytac ist t1 in
+      let lfun'', t2 = intern_tactic_seq onlytac { ist with ltacvars = lfun' } t2 in
+      lfun'', TacThen (t1,t2)
+  | TacDispatch tl ->
+      ist.ltacvars , TacDispatch (List.map (intern_pure_tactic ist) tl)
+  | TacExtendTac (tf,t,tl) ->
+      ist.ltacvars ,
+      TacExtendTac (Array.map (intern_pure_tactic ist) tf,
+                    intern_pure_tactic ist t,
+		    Array.map (intern_pure_tactic ist) tl)
+  | TacThens3parts (t1,tf,t2,tl) ->
+      let lfun', t1 = intern_tactic_seq onlytac ist t1 in
+      let ist' = { ist with ltacvars = lfun' } in
+      (* Que faire en cas de (tac complexe avec Match et Thens; tac2) ?? *)
+      lfun', TacThens3parts (t1,Array.map (intern_pure_tactic ist') tf,intern_pure_tactic ist' t2,
+		       Array.map (intern_pure_tactic ist') tl)
+  | TacThens (t,tl) ->
+      let lfun', t = intern_tactic_seq true ist t in
+      let ist' = { ist with ltacvars = lfun' } in
+      (* Que faire en cas de (tac complexe avec Match et Thens; tac2) ?? *)
+      lfun', TacThens (t, List.map (intern_pure_tactic ist') tl)
+  | TacDo (n,tac) ->
+      ist.ltacvars, TacDo (intern_int_or_var ist n,intern_pure_tactic ist tac)
+  | TacTry tac -> ist.ltacvars, TacTry (intern_pure_tactic ist tac)
+  | TacInfo tac -> ist.ltacvars, TacInfo (intern_pure_tactic ist tac)
+  | TacRepeat tac -> ist.ltacvars, TacRepeat (intern_pure_tactic ist tac)
+  | TacTimeout (n,tac) ->
+      ist.ltacvars, TacTimeout (intern_int_or_var ist n,intern_tactic onlytac ist tac)
+  | TacTime (s,tac) ->
+      ist.ltacvars, TacTime (s,intern_tactic onlytac ist tac)
+  | TacOr (tac1,tac2) ->
+      ist.ltacvars, TacOr (intern_pure_tactic ist tac1,intern_pure_tactic ist tac2)
+  | TacOnce tac ->
+      ist.ltacvars, TacOnce (intern_pure_tactic ist tac)
+  | TacExactlyOnce tac ->
+      ist.ltacvars, TacExactlyOnce (intern_pure_tactic ist tac)
+  | TacIfThenCatch (tac,tact,tace) ->
+      ist.ltacvars,
+      TacIfThenCatch (
+        intern_pure_tactic ist tac,
+        intern_pure_tactic ist tact,
+        intern_pure_tactic ist tace)
+  | TacOrelse (tac1,tac2) ->
+      ist.ltacvars, TacOrelse (intern_pure_tactic ist tac1,intern_pure_tactic ist tac2)
+  | TacFirst l -> ist.ltacvars, TacFirst (List.map (intern_pure_tactic ist) l)
+  | TacSolve l -> ist.ltacvars, TacSolve (List.map (intern_pure_tactic ist) l)
+  | TacComplete tac -> ist.ltacvars, TacComplete (intern_pure_tactic ist tac)
+  | TacArg (loc,a) -> ist.ltacvars, intern_tactic_as_arg loc onlytac ist a
+  | TacSelect (sel, tac) ->
+      ist.ltacvars, TacSelect (sel, intern_pure_tactic ist tac)
+
+  (* For extensions *)
+  | TacAlias (loc,s,l) ->
+      let l = List.map (intern_tacarg !strict_check false ist) l in
+      ist.ltacvars, TacAlias (loc,s,l)
+  | TacML (loc,opn,l) ->
+      let _ignore = Tacenv.interp_ml_tactic opn in
+      ist.ltacvars, TacML (adjust_loc loc,opn,List.map (intern_tacarg !strict_check false ist) l)
+
+and intern_tactic_as_arg loc onlytac ist a =
+  match intern_tacarg !strict_check onlytac ist a with
+  | TacCall _ | Reference _
+  | TacGeneric _ as a -> TacArg (loc,a)
+  | Tacexp a -> a
+  | ConstrMayEval _ | TacFreshId _ | TacPretype _ | TacNumgoals as a ->
+      if onlytac then error_tactic_expected ~loc else TacArg (loc,a)
+
+and intern_tactic_or_tacarg ist = intern_tactic false ist
+
+and intern_pure_tactic ist = intern_tactic true ist
+
+and intern_tactic_fun ist (var,body) =
+  let lfun = List.fold_left name_cons ist.ltacvars var in
+  (var,intern_tactic_or_tacarg { ist with ltacvars = lfun } body)
+
+and intern_tacarg strict onlytac ist = function
+  | Reference r -> intern_non_tactic_reference strict ist r
+  | ConstrMayEval c -> ConstrMayEval (intern_constr_may_eval ist c)
+  | TacCall (loc,f,[]) -> intern_isolated_tactic_reference strict ist f
+  | TacCall (loc,f,l) ->
+      TacCall (loc,
+        intern_applied_tactic_reference ist f,
+        List.map (intern_tacarg !strict_check false ist) l)
+  | TacFreshId x -> TacFreshId (List.map (intern_string_or_var ist) x)
+  | TacPretype c -> TacPretype (intern_constr ist c)
+  | TacNumgoals -> TacNumgoals
+  | Tacexp t -> Tacexp (intern_tactic onlytac ist t)
+  | TacGeneric arg ->
+    let arg = intern_genarg ist arg in
+    TacGeneric arg
+
+(* Reads the rules of a Match Context or a Match *)
+and intern_match_rule onlytac ist ?(as_type=false) = function
+  | (All tc)::tl ->
+      All (intern_tactic onlytac ist tc) :: (intern_match_rule onlytac ist ~as_type tl)
+  | (Pat (rl,mp,tc))::tl ->
+      let {ltacvars=lfun; genv=env} = ist in
+      let lfun',metas1,hyps = intern_match_goal_hyps ist ~as_type lfun rl in
+      let ido,metas2,pat = intern_pattern ist ~as_type lfun mp in
+      let fold accu x = Id.Set.add x accu in
+      let ltacvars = List.fold_left fold (opt_cons lfun' ido) metas1 in
+      let ltacvars = List.fold_left fold ltacvars metas2 in
+      let ist' = { ist with ltacvars } in
+      Pat (hyps,pat,intern_tactic onlytac ist' tc) :: (intern_match_rule onlytac ist ~as_type tl)
+  | [] -> []
+
+and intern_genarg ist (GenArg (Rawwit wit, x)) =
+  match wit with
+  | ListArg wit ->
+      let map x =
+        let ans = intern_genarg ist (in_gen (rawwit wit) x) in
+        out_gen (glbwit wit) ans
+      in
+      in_gen (glbwit (wit_list wit)) (List.map map x)
+  | OptArg wit ->
+      let ans = match x with
+      | None -> in_gen (glbwit (wit_opt wit)) None
+      | Some x ->
+        let s = out_gen (glbwit wit) (intern_genarg ist (in_gen (rawwit wit) x)) in
+        in_gen (glbwit (wit_opt wit)) (Some s)
+      in
+      ans
+  | PairArg (wit1, wit2) ->
+      let p, q = x in
+      let p = out_gen (glbwit wit1) (intern_genarg ist (in_gen (rawwit wit1) p)) in
+      let q = out_gen (glbwit wit2) (intern_genarg ist (in_gen (rawwit wit2) q)) in
+      in_gen (glbwit (wit_pair wit1 wit2)) (p, q)
+  | ExtraArg s ->
+      snd (Genintern.generic_intern ist (in_gen (rawwit wit) x))
+
+(** Other entry points *)
+
+let glob_tactic x =
+  Flags.with_option strict_check
+    (intern_pure_tactic (make_empty_glob_sign ())) x
+
+let glob_tactic_env l env x =
+  let ltacvars =
+    List.fold_left (fun accu x -> Id.Set.add x accu) Id.Set.empty l in
+  Flags.with_option strict_check
+  (intern_pure_tactic
+    { ltacvars; genv = env })
+    x
+
+let split_ltac_fun = function
+  | TacFun (l,t) -> (l,t)
+  | t -> ([],t)
+
+let pr_ltac_fun_arg n = spc () ++ pr_name n
+
+let print_ltac id =
+ try
+  let kn = Nametab.locate_tactic id in
+  let entries = Tacenv.ltac_entries () in
+  let tac = KNmap.find kn entries in
+  let filter mp =
+    try Some (Nametab.shortest_qualid_of_module mp)
+    with Not_found -> None
+  in
+  let mods = List.map_filter filter tac.Tacenv.tac_redef in
+  let redefined = match mods with
+  | [] -> mt ()
+  | mods ->
+    let redef = prlist_with_sep fnl pr_qualid mods in
+    fnl () ++ str "Redefined by:" ++ fnl () ++ redef
+  in
+  let l,t = split_ltac_fun tac.Tacenv.tac_body in
+  hv 2 (
+    hov 2 (str "Ltac" ++ spc() ++ pr_qualid id ++
+           prlist pr_ltac_fun_arg l ++ spc () ++ str ":=")
+    ++ spc() ++ Pptactic.pr_glob_tactic (Global.env ()) t) ++ redefined
+ with
+  Not_found ->
+   user_err ~hdr:"print_ltac"
+    (pr_qualid id ++ spc() ++ str "is not a user defined tactic.")
+
+(** Registering *)
+
+let lift intern = (); fun ist x -> (ist, intern ist x)
+
+let () =
+  let intern_intro_pattern ist pat =
+    let lf = ref Id.Set.empty in
+    let ans = intern_intro_pattern lf ist pat in
+    let ist = { ist with ltacvars = !lf } in
+    (ist, ans)
+  in
+  Genintern.register_intern0 wit_intro_pattern intern_intro_pattern
+
+let () =
+  let intern_clause ist cl =
+    let ans = clause_app (intern_hyp_location ist) cl in
+    (ist, ans)
+  in
+  Genintern.register_intern0 wit_clause_dft_concl intern_clause
+
+let intern_ident' ist id =
+  let lf = ref Id.Set.empty in
+  (ist, intern_ident lf ist id)
+
+let intern_ltac ist tac =
+  Flags.with_option strict_check (fun () -> intern_pure_tactic ist tac) ()
+
+let () =
+  Genintern.register_intern0 wit_int_or_var (lift intern_int_or_var);
+  Genintern.register_intern0 wit_ref (lift intern_global_reference);
+  Genintern.register_intern0 wit_pre_ident (fun ist c -> (ist,c));
+  Genintern.register_intern0 wit_ident intern_ident';
+  Genintern.register_intern0 wit_var (lift intern_hyp);
+  Genintern.register_intern0 wit_tactic (lift intern_tactic_or_tacarg);
+  Genintern.register_intern0 wit_ltac (lift intern_ltac);
+  Genintern.register_intern0 wit_quant_hyp (lift intern_quantified_hypothesis);
+  Genintern.register_intern0 wit_constr (fun ist c -> (ist,intern_constr ist c));
+  Genintern.register_intern0 wit_uconstr (fun ist c -> (ist,intern_constr ist c));
+  Genintern.register_intern0 wit_open_constr (fun ist c -> (ist,intern_constr ist c));
+  Genintern.register_intern0 wit_red_expr (lift intern_red_expr);
+  Genintern.register_intern0 wit_bindings (lift intern_bindings);
+  Genintern.register_intern0 wit_constr_with_bindings (lift intern_constr_with_bindings);
+  Genintern.register_intern0 wit_destruction_arg (lift intern_destruction_arg);
+  ()
+
+(** Substitution for notations containing tactic-in-terms *)
+
+let notation_subst bindings tac =
+  let fold id c accu =
+    let loc = Glob_ops.loc_of_glob_constr (fst c) in
+    let c = ConstrMayEval (ConstrTerm c) in
+    ((loc, id), c) :: accu
+  in
+  let bindings = Id.Map.fold fold bindings [] in
+  (** This is theoretically not correct due to potential variable capture, but
+      Ltac has no true variables so one cannot simply substitute *)
+  TacLetIn (false, bindings, tac)
+
+let () = Genintern.register_ntn_subst0 wit_tactic notation_subst
diff --git a/plugins/ltac/tacintern.mli b/plugins/ltac/tacintern.mli
new file mode 100644
index 000000000..71ca354fa
--- /dev/null
+++ b/plugins/ltac/tacintern.mli
@@ -0,0 +1,64 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+open Pp
+open Names
+open Tacexpr
+open Genarg
+open Constrexpr
+open Misctypes
+
+(** Globalization of tactic expressions :
+    Conversion from [raw_tactic_expr] to [glob_tactic_expr] *)
+
+type glob_sign = Genintern.glob_sign = {
+  ltacvars : Id.Set.t;
+  genv : Environ.env }
+
+val fully_empty_glob_sign : glob_sign
+
+val make_empty_glob_sign : unit -> glob_sign
+ (** same as [fully_empty_glob_sign], but with [Global.env()] as
+     environment *)
+
+(** Main globalization functions *)
+
+val glob_tactic : raw_tactic_expr -> glob_tactic_expr
+
+val glob_tactic_env :
+  Id.t list -> Environ.env -> raw_tactic_expr -> glob_tactic_expr
+
+(** Low-level variants *)
+
+val intern_pure_tactic : glob_sign -> raw_tactic_expr -> glob_tactic_expr
+
+val intern_tactic_or_tacarg :
+  glob_sign -> raw_tactic_expr -> Tacexpr.glob_tactic_expr
+
+val intern_constr : glob_sign -> constr_expr -> glob_constr_and_expr
+
+val intern_constr_with_bindings :
+  glob_sign -> constr_expr * constr_expr bindings ->
+  glob_constr_and_expr * glob_constr_and_expr bindings
+
+val intern_hyp : glob_sign -> Id.t Loc.located -> Id.t Loc.located
+
+(** Adds a globalization function for extra generic arguments *)
+
+val intern_genarg : glob_sign -> raw_generic_argument -> glob_generic_argument
+
+(** printing *)
+val print_ltac : Libnames.qualid -> std_ppcmds
+
+(** Reduction expressions *)
+
+val intern_red_expr : glob_sign -> raw_red_expr -> glob_red_expr
+val dump_glob_red_expr : raw_red_expr -> unit
+
+(* Hooks *)
+val strict_check : bool ref
diff --git a/plugins/ltac/tacinterp.ml b/plugins/ltac/tacinterp.ml
new file mode 100644
index 000000000..928646bcb
--- /dev/null
+++ b/plugins/ltac/tacinterp.ml
@@ -0,0 +1,2165 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+open Constrintern
+open Patternops
+open Pp
+open Genredexpr
+open Glob_term
+open Glob_ops
+open Tacred
+open CErrors
+open Util
+open Names
+open Nameops
+open Libnames
+open Globnames
+open Nametab
+open Pfedit
+open Refiner
+open Tacmach.New
+open Tactic_debug
+open Constrexpr
+open Term
+open Termops
+open Tacexpr
+open Genarg
+open Geninterp
+open Stdarg
+open Tacarg
+open Printer
+open Pretyping
+open Misctypes
+open Locus
+open Tacintern
+open Taccoerce
+open Sigma.Notations
+open Proofview.Notations
+open Context.Named.Declaration
+
+let ltac_trace_info = Tactic_debug.ltac_trace_info
+
+let has_type : type a. Val.t -> a typed_abstract_argument_type -> bool = fun v wit ->
+  let Val.Dyn (t, _) = v in
+  let t' = match val_tag wit with
+  | Val.Base t' -> t'
+  | _ -> assert false (** not used in this module *)
+  in
+  match Val.eq t t' with
+  | None -> false
+  | Some Refl -> true
+
+let prj : type a. a Val.typ -> Val.t -> a option = fun t v ->
+  let Val.Dyn (t', x) = v in
+  match Val.eq t t' with
+  | None -> None
+  | Some Refl -> Some x
+
+let in_list tag v =
+  let tag = match tag with Val.Base tag -> tag | _ -> assert false in
+  Val.Dyn (Val.typ_list, List.map (fun x -> Val.Dyn (tag, x)) v)
+let in_gen wit v =
+  let t = match val_tag wit with
+  | Val.Base t -> t
+  | _ -> assert false (** not used in this module *)
+  in
+  Val.Dyn (t, v)
+let out_gen wit v =
+  let t = match val_tag wit with
+  | Val.Base t -> t
+  | _ -> assert false (** not used in this module *)
+  in
+  match prj t v with None -> assert false | Some x -> x
+
+let val_tag wit = val_tag (topwit wit)
+
+let pr_argument_type arg =
+  let Val.Dyn (tag, _) = arg in
+  Val.pr tag
+
+let safe_msgnl s =
+  Proofview.NonLogical.catch
+    (Proofview.NonLogical.print_debug (s++fnl()))
+    (fun _ -> Proofview.NonLogical.print_warning (str "bug in the debugger: an exception is raised while printing debug information"++fnl()))
+
+type value = Val.t
+
+(** Abstract application, to print ltac functions *)
+type appl =
+  | UnnamedAppl (** For generic applications: nothing is printed *)
+  | GlbAppl of (Names.kernel_name * Val.t list) list
+       (** For calls to global constants, some may alias other. *)
+let push_appl appl args =
+  match appl with
+  | UnnamedAppl -> UnnamedAppl
+  | GlbAppl l -> GlbAppl (List.map (fun (h,vs) -> (h,vs@args)) l)
+let pr_generic arg =
+    let Val.Dyn (tag, _) = arg in
+    str"<" ++ Val.pr tag ++ str ":(" ++ Pptactic.pr_value Pptactic.ltop arg ++ str ")>"
+let pr_appl h vs =
+  Pptactic.pr_ltac_constant  h ++ spc () ++
+  Pp.prlist_with_sep spc pr_generic vs
+let rec name_with_list appl t =
+  match appl with
+  | [] -> t
+  | (h,vs)::l -> Proofview.Trace.name_tactic (fun () -> pr_appl h vs) (name_with_list l t)
+let name_if_glob appl t =
+  match appl with
+  | UnnamedAppl -> t
+  | GlbAppl l -> name_with_list l t
+let combine_appl appl1 appl2 =
+  match appl1,appl2 with
+  | UnnamedAppl,a | a,UnnamedAppl -> a
+  | GlbAppl l1 , GlbAppl l2 -> GlbAppl (l2@l1)
+
+(* Values for interpretation *)
+type tacvalue =
+  | VFun of appl*ltac_trace * value Id.Map.t *
+      Name.t list * glob_tactic_expr
+  | VRec of value Id.Map.t ref * glob_tactic_expr
+
+let (wit_tacvalue : (Empty.t, tacvalue, tacvalue) Genarg.genarg_type) =
+  let wit = Genarg.create_arg "tacvalue" in
+  let () = register_val0 wit None in
+  wit
+
+let of_tacvalue v = in_gen (topwit wit_tacvalue) v
+let to_tacvalue v = out_gen (topwit wit_tacvalue) v
+
+(** More naming applications *)
+let name_vfun appl vle =
+  let vle = Value.normalize vle in
+  if has_type vle (topwit wit_tacvalue) then
+    match to_tacvalue vle with
+    | VFun (appl0,trace,lfun,vars,t) -> of_tacvalue (VFun (combine_appl appl0 appl,trace,lfun,vars,t))
+    | _ -> vle
+  else vle
+
+module TacStore = Geninterp.TacStore
+
+let f_avoid_ids : Id.t list TacStore.field = TacStore.field ()
+(* ids inherited from the call context (needed to get fresh ids) *)
+let f_debug : debug_info TacStore.field = TacStore.field ()
+let f_trace : ltac_trace TacStore.field = TacStore.field ()
+
+(* Signature for interpretation: val_interp and interpretation functions *)
+type interp_sign = Geninterp.interp_sign = {
+  lfun : value Id.Map.t;
+  extra : TacStore.t }
+
+let extract_trace ist = match TacStore.get ist.extra f_trace with
+| None -> []
+| Some l -> l
+
+module Value = struct
+
+  include Taccoerce.Value
+
+  let of_closure ist tac =
+    let closure = VFun (UnnamedAppl,extract_trace ist, ist.lfun, [], tac) in
+    of_tacvalue closure
+
+  let cast_error wit v =
+    let pr_v = Pptactic.pr_value Pptactic.ltop v in
+    let Val.Dyn (tag, _) = v in
+    let tag = Val.pr tag in
+    user_err  (str "Type error: value " ++ pr_v ++ str " is a " ++ tag
+      ++ str " while type " ++ Val.pr wit ++ str " was expected.")
+
+  let unbox wit v ans = match ans with
+  | None -> cast_error wit v
+  | Some x -> x
+
+  let rec prj : type a. a Val.tag -> Val.t -> a = fun tag v -> match tag with
+  | Val.List tag -> List.map (fun v -> prj tag v) (unbox Val.typ_list v (to_list v))
+  | Val.Opt tag -> Option.map (fun v -> prj tag v) (unbox Val.typ_opt v (to_option v))
+  | Val.Pair (tag1, tag2) ->
+    let (x, y) = unbox Val.typ_pair v (to_pair v) in
+    (prj tag1 x, prj tag2 y)
+  | Val.Base t ->
+    let Val.Dyn (t', x) = v in
+    match Val.eq t t' with
+    | None -> cast_error t v
+    | Some Refl -> x
+
+  let rec tag_of_arg : type a b c. (a, b, c) genarg_type -> c Val.tag = fun wit -> match wit with
+  | ExtraArg _ -> val_tag wit
+  | ListArg t -> Val.List (tag_of_arg t)
+  | OptArg t -> Val.Opt (tag_of_arg t)
+  | PairArg (t1, t2) -> Val.Pair (tag_of_arg t1, tag_of_arg t2)
+
+  let val_cast arg v = prj (tag_of_arg arg) v
+
+  let cast (Topwit wit) v = val_cast wit v
+
+end
+
+let print_top_val env v = Pptactic.pr_value Pptactic.ltop v
+
+let dloc = Loc.ghost
+
+let catching_error call_trace fail (e, info) =
+  let inner_trace =
+    Option.default [] (Exninfo.get info ltac_trace_info)
+  in
+  if List.is_empty call_trace && List.is_empty inner_trace then fail (e, info)
+  else begin
+    assert (CErrors.noncritical e); (* preserved invariant *)
+    let new_trace = inner_trace @ call_trace in
+    let located_exc = (e, Exninfo.add info ltac_trace_info new_trace) in
+    fail located_exc
+  end
+
+let catch_error call_trace f x =
+  try f x
+  with e when CErrors.noncritical e ->
+    let e = CErrors.push e in
+    catching_error call_trace iraise e
+
+let catch_error_tac call_trace tac =
+  Proofview.tclORELSE
+    tac
+    (catching_error call_trace (fun (e, info) -> Proofview.tclZERO ~info e))
+
+let curr_debug ist = match TacStore.get ist.extra f_debug with
+| None -> DebugOff
+| Some level -> level
+
+(** TODO: unify printing of generic Ltac values in case of coercion failure. *)
+
+(* Displays a value *)
+let pr_value env v =
+  let v = Value.normalize v in
+  if has_type v (topwit wit_tacvalue) then str "a tactic"
+  else if has_type v (topwit wit_constr_context) then
+    let c = out_gen (topwit wit_constr_context) v in
+    match env with
+    | Some (env,sigma) -> pr_leconstr_env env sigma c
+    | _ -> str "a term"
+  else if has_type v (topwit wit_constr) then
+    let c = out_gen (topwit wit_constr) v in
+    match env with
+    | Some (env,sigma) -> pr_leconstr_env env sigma c
+    | _ -> str "a term"
+  else if has_type v (topwit wit_constr_under_binders) then
+    let c = out_gen (topwit wit_constr_under_binders) v in
+    match env with
+    | Some (env,sigma) -> pr_lconstr_under_binders_env env sigma c
+    | _ -> str "a term"
+  else
+    str "a value of type" ++ spc () ++ pr_argument_type v
+
+let pr_closure env ist body =
+  let pp_body = Pptactic.pr_glob_tactic env body in
+  let pr_sep () = fnl () in
+  let pr_iarg (id, arg) =
+    let arg = pr_argument_type arg in
+    hov 0 (pr_id id ++ spc () ++ str ":" ++ spc () ++ arg)
+  in
+  let pp_iargs = v 0 (prlist_with_sep pr_sep pr_iarg (Id.Map.bindings ist)) in
+  pp_body ++ fnl() ++ str "in environment " ++ fnl() ++ pp_iargs
+
+let pr_inspect env expr result =
+  let pp_expr = Pptactic.pr_glob_tactic env expr in
+  let pp_result =
+    if has_type result (topwit wit_tacvalue) then
+    match to_tacvalue result with
+    | VFun (_,_, ist, ul, b) ->
+      let body = if List.is_empty ul then b else (TacFun (ul, b)) in
+      str "a closure with body " ++ fnl() ++ pr_closure env ist body
+    | VRec (ist, body) ->
+      str "a recursive closure" ++ fnl () ++ pr_closure env !ist body
+    else
+      let pp_type = pr_argument_type result in
+      str "an object of type" ++ spc () ++ pp_type
+  in
+  pp_expr ++ fnl() ++ str "this is " ++ pp_result
+
+(* Transforms an id into a constr if possible, or fails with Not_found *)
+let constr_of_id env id =
+  EConstr.mkVar (let _ = Environ.lookup_named id env in id)
+
+(** Generic arguments : table of interpretation functions *)
+
+(* Some of the code further down depends on the fact that push_trace does not modify sigma (the evar map) *)
+let push_trace call ist = match TacStore.get ist.extra f_trace with
+| None -> Proofview.tclUNIT [call]
+| Some trace -> Proofview.tclUNIT (call :: trace)
+
+let propagate_trace ist loc id v =
+  let v = Value.normalize v in
+  if has_type v (topwit wit_tacvalue) then
+    let tacv = to_tacvalue v in
+    match tacv with
+    | VFun (appl,_,lfun,it,b) ->
+        let t = if List.is_empty it then b else TacFun (it,b) in
+        push_trace(loc,LtacVarCall (id,t)) ist >>= fun trace ->
+        let ans = VFun (appl,trace,lfun,it,b) in
+        Proofview.tclUNIT (of_tacvalue ans)
+    | _ ->  Proofview.tclUNIT v
+  else Proofview.tclUNIT v
+
+let append_trace trace v =
+  let v = Value.normalize v in
+  if has_type v (topwit wit_tacvalue) then
+    match to_tacvalue v with
+    | VFun (appl,trace',lfun,it,b) -> of_tacvalue (VFun (appl,trace'@trace,lfun,it,b))
+    | _ -> v
+  else v
+
+(* Dynamically check that an argument is a tactic *)
+let coerce_to_tactic loc id v =
+  let v = Value.normalize v in
+  let fail () = user_err ~loc 
+    (str "Variable " ++ pr_id id ++ str " should be bound to a tactic.")
+  in
+  let v = Value.normalize v in
+  if has_type v (topwit wit_tacvalue) then
+    let tacv = to_tacvalue v in
+    match tacv with
+    | VFun _ -> v
+    | _ -> fail ()
+  else fail ()
+
+let intro_pattern_of_ident id = (Loc.ghost, IntroNaming (IntroIdentifier id))
+let value_of_ident id =
+  in_gen (topwit wit_intro_pattern) (intro_pattern_of_ident id)
+
+let (+++) lfun1 lfun2 = Id.Map.fold Id.Map.add lfun1 lfun2
+
+let extend_values_with_bindings (ln,lm) lfun =
+  let of_cub c = match c with
+  | [], c -> Value.of_constr c
+  | _ -> in_gen (topwit wit_constr_under_binders) c
+  in
+  (* For compatibility, bound variables are visible only if no other
+     binding of the same name exists *)
+  let accu = Id.Map.map value_of_ident ln in
+  let accu = lfun +++ accu in
+  Id.Map.fold (fun id c accu -> Id.Map.add id (of_cub c) accu) lm accu
+
+(***************************************************************************)
+(* Evaluation/interpretation *)
+
+let is_variable env id =
+  Id.List.mem id (ids_of_named_context (Environ.named_context env))
+
+(* Debug reference *)
+let debug = ref DebugOff
+
+(* Sets the debugger mode *)
+let set_debug pos = debug := pos
+
+(* Gives the state of debug *)
+let get_debug () = !debug
+
+let debugging_step ist pp = match curr_debug ist with
+  | DebugOn lev ->
+      safe_msgnl (str "Level " ++ int lev ++ str": " ++ pp () ++ fnl())
+  | _ -> Proofview.NonLogical.return ()
+
+let debugging_exception_step ist signal_anomaly e pp =
+  let explain_exc =
+    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  (str "Ltac variable " ++ pr_id id ++
+   strbrk " is bound to" ++ spc () ++ pr_value env v ++ spc () ++
+   strbrk "which cannot be coerced to " ++ str s ++ str".")
+
+(* Raise Not_found if not in interpretation sign *)
+let try_interp_ltac_var coerce ist env (loc,id) =
+  let v = Id.Map.find id ist.lfun in
+  try coerce v with CannotCoerceTo s -> error_ltac_variable loc id env v s
+
+let interp_ltac_var coerce ist env locid =
+  try try_interp_ltac_var coerce ist env locid
+  with Not_found -> anomaly (str "Detected '" ++ Id.print (snd locid) ++ str "' as ltac var at interning time")
+
+let interp_ident ist env sigma id =
+  try try_interp_ltac_var (coerce_var_to_ident false env sigma) ist (Some (env,sigma)) (dloc,id)
+  with Not_found -> id
+
+(* Interprets an optional identifier, bound or fresh *)
+let interp_name ist env sigma = function
+  | Anonymous -> Anonymous
+  | Name id -> Name (interp_ident ist env sigma id)
+
+let interp_intro_pattern_var loc ist env sigma id =
+  try try_interp_ltac_var (coerce_to_intro_pattern env sigma) ist (Some (env,sigma)) (loc,id)
+  with Not_found -> IntroNaming (IntroIdentifier id)
+
+let interp_intro_pattern_naming_var loc ist env sigma id =
+  try try_interp_ltac_var (coerce_to_intro_pattern_naming env sigma) ist (Some (env,sigma)) (loc,id)
+  with Not_found -> IntroIdentifier id
+
+let interp_int ist locid =
+  try try_interp_ltac_var coerce_to_int ist None locid
+  with Not_found ->
+    user_err ~loc:(fst locid) ~hdr:"interp_int"
+     (str "Unbound variable "  ++ pr_id (snd locid) ++ str".")
+
+let interp_int_or_var ist = function
+  | ArgVar locid -> interp_int ist locid
+  | ArgArg n -> n
+
+let interp_int_or_var_as_list ist = function
+  | ArgVar (_,id as locid) ->
+      (try coerce_to_int_or_var_list (Id.Map.find id ist.lfun)
+       with Not_found | CannotCoerceTo _ -> [ArgArg (interp_int ist locid)])
+  | ArgArg n as x -> [x]
+
+let interp_int_or_var_list ist l =
+  List.flatten (List.map (interp_int_or_var_as_list ist) l)
+
+(* Interprets a bound variable (especially an existing hypothesis) *)
+let interp_hyp ist env sigma (loc,id as locid) =
+  (* Look first in lfun for a value coercible to a variable *)
+  try try_interp_ltac_var (coerce_to_hyp env sigma) ist (Some (env,sigma)) locid
+  with Not_found ->
+  (* Then look if bound in the proof context at calling time *)
+  if is_variable env id then id
+  else Loc.raise ~loc (Logic.RefinerError (Logic.NoSuchHyp id))
+
+let interp_hyp_list_as_list ist env sigma (loc,id as x) =
+  try coerce_to_hyp_list env sigma (Id.Map.find id ist.lfun)
+  with Not_found | CannotCoerceTo _ -> [interp_hyp ist env sigma x]
+
+let interp_hyp_list ist env sigma l =
+  List.flatten (List.map (interp_hyp_list_as_list ist env sigma) l)
+
+let interp_move_location ist env sigma = function
+  | MoveAfter id -> MoveAfter (interp_hyp ist env sigma id)
+  | MoveBefore id -> MoveBefore (interp_hyp ist env sigma id)
+  | MoveFirst -> MoveFirst
+  | MoveLast -> MoveLast
+
+let interp_reference ist env sigma = function
+  | ArgArg (_,r) -> r
+  | ArgVar (loc, id) ->
+    try try_interp_ltac_var (coerce_to_reference env sigma) ist (Some (env,sigma)) (loc, id)
+    with Not_found ->
+      try
+        VarRef (get_id (Environ.lookup_named id env))
+      with Not_found -> error_global_not_found ~loc (qualid_of_ident id)
+
+let try_interp_evaluable env (loc, id) =
+  let v = Environ.lookup_named id env in
+  match v with
+  | LocalDef _ -> EvalVarRef id
+  | _ -> error_not_evaluable (VarRef id)
+
+let interp_evaluable ist env sigma = function
+  | ArgArg (r,Some (loc,id)) ->
+    (* Maybe [id] has been introduced by Intro-like tactics *)
+    begin
+      try try_interp_evaluable env (loc, id)
+      with Not_found ->
+        match r with
+        | EvalConstRef _ -> r
+        | _ -> error_global_not_found ~loc (qualid_of_ident id)
+    end
+  | ArgArg (r,None) -> r
+  | ArgVar (loc, id) ->
+    try try_interp_ltac_var (coerce_to_evaluable_ref env sigma) ist (Some (env,sigma)) (loc, id)
+    with Not_found ->
+      try try_interp_evaluable env (loc, id)
+      with Not_found -> error_global_not_found ~loc (qualid_of_ident id)
+
+(* Interprets an hypothesis name *)
+let interp_occurrences ist occs =
+  Locusops.occurrences_map (interp_int_or_var_list ist) occs
+
+let interp_hyp_location ist env sigma ((occs,id),hl) =
+  ((interp_occurrences ist occs,interp_hyp ist env sigma id),hl)
+
+let interp_hyp_location_list_as_list ist env sigma ((occs,id),hl as x) =
+  match occs,hl with
+  | AllOccurrences,InHyp ->
+      List.map (fun id -> ((AllOccurrences,id),InHyp))
+        (interp_hyp_list_as_list ist env sigma id)
+  | _,_ -> [interp_hyp_location ist env sigma x]
+
+let interp_hyp_location_list ist env sigma l =
+  List.flatten (List.map (interp_hyp_location_list_as_list ist env sigma) l)
+
+let interp_clause ist env sigma { onhyps=ol; concl_occs=occs } : clause =
+  { onhyps=Option.map (interp_hyp_location_list ist env sigma) ol;
+    concl_occs=interp_occurrences ist occs }
+
+(* Interpretation of constructions *)
+
+(* Extract the constr list from lfun *)
+let extract_ltac_constr_values ist env =
+  let fold id v accu =
+    try
+      let c = coerce_to_constr env v in
+      Id.Map.add id c accu
+    with CannotCoerceTo _ -> accu
+  in
+  Id.Map.fold fold ist.lfun Id.Map.empty
+(** ppedrot: I have changed the semantics here. Before this patch, closure was
+    implemented as a list and a variable could be bound several times with
+    different types, resulting in its possible appearance on both sides. This
+    could barely be defined as a feature... *)
+
+(* Extract the identifier list from lfun: join all branches (what to do else?)*)
+let rec intropattern_ids (loc,pat) = match pat with
+  | IntroNaming (IntroIdentifier id) -> [id]
+  | IntroAction (IntroOrAndPattern (IntroAndPattern l)) ->
+      List.flatten (List.map intropattern_ids l)
+  | IntroAction (IntroOrAndPattern (IntroOrPattern ll)) ->
+      List.flatten (List.map intropattern_ids (List.flatten ll))
+  | IntroAction (IntroInjection l) ->
+      List.flatten (List.map intropattern_ids l)
+  | IntroAction (IntroApplyOn ((_,c),pat)) -> intropattern_ids pat
+  | IntroNaming (IntroAnonymous | IntroFresh _)
+  | IntroAction (IntroWildcard | IntroRewrite _)
+  | IntroForthcoming _ -> []
+
+let extract_ids ids lfun =
+  let fold id v accu =
+    let v = Value.normalize v in
+    if has_type v (topwit wit_intro_pattern) then
+      let (_, ipat) = out_gen (topwit wit_intro_pattern) v in
+      if Id.List.mem id ids then accu
+      else accu @ intropattern_ids (dloc, ipat)
+    else accu
+  in
+  Id.Map.fold fold lfun []
+
+let default_fresh_id = Id.of_string "H"
+
+let interp_fresh_id ist env sigma l =
+  let extract_ident ist env sigma id =
+    try try_interp_ltac_var (coerce_to_ident_not_fresh env sigma)
+			    ist (Some (env,sigma)) (dloc,id)
+    with Not_found -> id in
+  let ids = List.map_filter (function ArgVar (_, id) -> Some id | _ -> None) l in
+  let avoid = match TacStore.get ist.extra f_avoid_ids with
+  | None -> []
+  | Some l -> l
+  in
+  let avoid = (extract_ids ids ist.lfun) @ avoid in
+  let id =
+    if List.is_empty l then default_fresh_id
+    else
+      let s =
+	String.concat "" (List.map (function
+	  | ArgArg s -> s
+	  | ArgVar (_,id) -> Id.to_string (extract_ident ist env sigma id)) l) in
+      let s = if CLexer.is_keyword s then s^"0" else s in
+      Id.of_string s in
+  Tactics.fresh_id_in_env avoid id env
+
+(* Extract the uconstr list from lfun *)
+let extract_ltac_constr_context ist env sigma =
+  let open Glob_term in
+  let add_uconstr id v map =
+    try Id.Map.add id (coerce_to_uconstr env v) map
+    with CannotCoerceTo _ -> map
+  in
+  let add_constr id v map =
+    try Id.Map.add id (coerce_to_constr env v) map
+    with CannotCoerceTo _ -> map
+  in
+  let add_ident id v map =
+    try Id.Map.add id (coerce_var_to_ident false env sigma v) map
+    with CannotCoerceTo _ -> map
+  in
+  let fold id v {idents;typed;untyped} =
+    let idents = add_ident id v idents in
+    let typed = add_constr id v typed in
+    let untyped = add_uconstr id v untyped in
+    { idents ; typed ; untyped }
+  in
+  let empty =  { idents = Id.Map.empty ;typed = Id.Map.empty ; untyped = Id.Map.empty } in
+  Id.Map.fold fold ist.lfun empty
+
+(** Significantly simpler than [interp_constr], to interpret an
+    untyped constr, it suffices to adjoin a closure environment. *)
+let interp_uconstr ist env sigma = function
+  | (term,None) ->
+      { closure = extract_ltac_constr_context ist env sigma; term }
+  | (_,Some ce) ->
+      let ( {typed ; untyped } as closure) = extract_ltac_constr_context ist env sigma in
+      let ltacvars = {
+        Constrintern.ltac_vars = Id.(Set.union (Map.domain typed) (Map.domain untyped));
+        ltac_bound = Id.Map.domain ist.lfun;
+      } in
+      { closure ; term =  intern_gen WithoutTypeConstraint ~ltacvars env ce }
+
+let interp_gen kind ist allow_patvar flags env sigma (c,ce) =
+  let constrvars = extract_ltac_constr_context ist env sigma in
+  let vars = {
+    Pretyping.ltac_constrs = constrvars.typed;
+    Pretyping.ltac_uconstrs = constrvars.untyped;
+    Pretyping.ltac_idents = constrvars.idents;
+    Pretyping.ltac_genargs = ist.lfun;
+  } in
+  let c = match ce with
+  | None -> c
+    (* If at toplevel (ce<>None), the error can be due to an incorrect
+       context at globalization time: we retype with the now known
+       intros/lettac/inversion hypothesis names *)
+  | Some c ->
+      let constr_context =
+        Id.Set.union
+          (Id.Map.domain constrvars.typed)
+       (Id.Set.union
+          (Id.Map.domain constrvars.untyped)
+          (Id.Map.domain constrvars.idents))
+      in
+      let ltacvars = {
+        ltac_vars = constr_context;
+        ltac_bound = Id.Map.domain ist.lfun;
+      } in
+      let kind_for_intern =
+        match kind with OfType _ -> WithoutTypeConstraint | _ -> kind in
+      intern_gen kind_for_intern ~allow_patvar ~ltacvars env c
+  in
+  (* Jason Gross: To avoid unnecessary modifications to tacinterp, as
+      suggested by Arnaud Spiwack, we run push_trace immediately.  We do
+      this with the kludge of an empty proofview, and rely on the
+      invariant that running the tactic returned by push_trace does
+      not modify sigma. *)
+  let (_, dummy_proofview) = Proofview.init sigma [] in
+  let (trace,_,_,_) = Proofview.apply env (push_trace (loc_of_glob_constr c,LtacConstrInterp (c,vars)) ist) dummy_proofview in
+  let (evd,c) =
+    catch_error trace (understand_ltac flags env sigma vars kind) c
+  in
+  (* spiwack: to avoid unnecessary modifications of tacinterp, as this
+     function already use effect, I call [run] hoping it doesn't mess
+     up with any assumption. *)
+  Proofview.NonLogical.run (db_constr (curr_debug ist) env evd c);
+  (evd,c)
+
+let constr_flags = {
+  use_typeclasses = true;
+  solve_unification_constraints = true;
+  use_hook = Some solve_by_implicit_tactic;
+  fail_evar = true;
+  expand_evars = true }
+
+(* Interprets a constr; expects evars to be solved *)
+let interp_constr_gen kind ist env sigma c =
+  interp_gen kind ist false constr_flags env sigma c
+
+let interp_constr = interp_constr_gen WithoutTypeConstraint
+
+let interp_type = interp_constr_gen IsType
+
+let open_constr_use_classes_flags = {
+  use_typeclasses = true;
+  solve_unification_constraints = true;
+  use_hook = Some solve_by_implicit_tactic;
+  fail_evar = false;
+  expand_evars = true }
+
+let open_constr_no_classes_flags = {
+  use_typeclasses = false;
+  solve_unification_constraints = true;
+  use_hook = Some solve_by_implicit_tactic;
+  fail_evar = false;
+  expand_evars = true }
+
+let pure_open_constr_flags = {
+  use_typeclasses = false;
+  solve_unification_constraints = true;
+  use_hook = None;
+  fail_evar = false;
+  expand_evars = false }
+
+(* Interprets an open constr *)
+let interp_open_constr ?(expected_type=WithoutTypeConstraint) ist =
+  let flags =
+    if expected_type == WithoutTypeConstraint then open_constr_no_classes_flags
+    else open_constr_use_classes_flags in
+  interp_gen expected_type ist false flags
+
+let interp_pure_open_constr ist =
+  interp_gen WithoutTypeConstraint ist false pure_open_constr_flags
+
+let interp_typed_pattern ist env sigma (_,c,_) =
+  let sigma, c =
+    interp_gen WithoutTypeConstraint ist true pure_open_constr_flags env sigma c in
+  (** FIXME: it is necessary to be unsafe here because of the way we handle
+      evars in the pretyper. Sometimes they get solved eagerly. *)
+  pattern_of_constr env sigma (EConstr.Unsafe.to_constr c)
+
+(* Interprets a constr expression *)
+let interp_constr_in_compound_list inj_fun dest_fun interp_fun ist env sigma l =
+  let try_expand_ltac_var sigma x =
+    try match dest_fun x with
+    | GVar (_,id), _ ->
+      let v = Id.Map.find id ist.lfun in
+      sigma, List.map inj_fun (coerce_to_constr_list env v)
+    | _ ->
+        raise Not_found
+    with CannotCoerceTo _ | Not_found ->
+      (* dest_fun, List.assoc may raise Not_found *)
+      let sigma, c = interp_fun ist env sigma x in
+      sigma, [c] in
+  let sigma, l = List.fold_map try_expand_ltac_var sigma l in
+  sigma, List.flatten l
+
+let interp_constr_list ist env sigma c =
+  interp_constr_in_compound_list (fun x -> x) (fun x -> x) interp_constr ist env sigma c
+
+let interp_open_constr_list =
+  interp_constr_in_compound_list (fun x -> x) (fun x -> x) interp_open_constr
+
+(* Interprets a reduction expression *)
+let interp_unfold ist env sigma (occs,qid) =
+  (interp_occurrences ist occs,interp_evaluable ist env sigma qid)
+
+let interp_flag ist env sigma red =
+  { red with rConst = List.map (interp_evaluable ist env sigma) red.rConst }
+
+let interp_constr_with_occurrences ist env sigma (occs,c) =
+  let (sigma,c_interp) = interp_constr ist env sigma c in
+  sigma , (interp_occurrences ist occs, c_interp)
+
+let interp_closed_typed_pattern_with_occurrences ist env sigma (occs, a) =
+  let p = match a with
+  | Inl (ArgVar (loc,id)) ->
+      (* This is the encoding of an ltac var supposed to be bound
+         prioritary to an evaluable reference and otherwise to a constr
+         (it is an encoding to satisfy the "union" type given to Simpl) *)
+    let coerce_eval_ref_or_constr x =
+      try Inl (coerce_to_evaluable_ref env sigma x)
+      with CannotCoerceTo _ ->
+        let c = coerce_to_closed_constr env x in
+        Inr (pattern_of_constr env sigma (EConstr.to_constr sigma c)) in
+    (try try_interp_ltac_var coerce_eval_ref_or_constr ist (Some (env,sigma)) (loc,id)
+     with Not_found ->
+       error_global_not_found ~loc (qualid_of_ident id))
+  | Inl (ArgArg _ as b) -> Inl (interp_evaluable ist env sigma b)
+  | Inr c -> Inr (interp_typed_pattern ist env sigma c) in
+  interp_occurrences ist occs, p
+
+let interp_constr_with_occurrences_and_name_as_list =
+  interp_constr_in_compound_list
+    (fun c -> ((AllOccurrences,c),Anonymous))
+    (function ((occs,c),Anonymous) when occs == AllOccurrences -> c
+      | _ -> raise Not_found)
+    (fun ist env sigma (occ_c,na) ->
+      let (sigma,c_interp) = interp_constr_with_occurrences ist env sigma occ_c in
+      sigma, (c_interp,
+       interp_name ist env sigma na))
+
+let interp_red_expr ist env sigma = function
+  | Unfold l -> sigma , Unfold (List.map (interp_unfold ist env sigma) l)
+  | Fold l ->
+    let (sigma,l_interp) = interp_constr_list ist env sigma l in
+    sigma , Fold l_interp
+  | Cbv f -> sigma , Cbv (interp_flag ist env sigma f)
+  | Cbn f -> sigma , Cbn (interp_flag ist env sigma f)
+  | Lazy f -> sigma , Lazy (interp_flag ist env sigma f)
+  | Pattern l ->
+      let (sigma,l_interp) =
+        Evd.MonadR.List.map_right
+          (fun c sigma -> interp_constr_with_occurrences ist env sigma c) l sigma
+      in
+      sigma , Pattern l_interp
+  | Simpl (f,o) ->
+     sigma , Simpl (interp_flag ist env sigma f,
+		    Option.map (interp_closed_typed_pattern_with_occurrences ist env sigma) o)
+  | CbvVm o ->
+    sigma , CbvVm (Option.map (interp_closed_typed_pattern_with_occurrences ist env sigma) o)
+  | CbvNative o ->
+    sigma , CbvNative (Option.map (interp_closed_typed_pattern_with_occurrences ist env sigma) o)
+  | (Red _ |  Hnf | ExtraRedExpr _ as r) -> sigma , r
+
+let interp_may_eval f ist env sigma = function
+  | ConstrEval (r,c) ->
+      let (sigma,redexp) = interp_red_expr ist env sigma r in
+      let (sigma,c_interp) = f ist env sigma c in
+      let (redfun, _) = Redexpr.reduction_of_red_expr env redexp in
+      let sigma = Sigma.Unsafe.of_evar_map sigma in
+      let Sigma (c, sigma, _) = redfun.Reductionops.e_redfun env sigma c_interp in
+      (Sigma.to_evar_map sigma, c)
+  | ConstrContext ((loc,s),c) ->
+      (try
+	let (sigma,ic) = f ist env sigma c in
+	let ctxt = coerce_to_constr_context (Id.Map.find s ist.lfun) in
+	let ctxt = EConstr.Unsafe.to_constr ctxt in
+	let evdref = ref sigma in
+	let ic = EConstr.Unsafe.to_constr ic in
+	let c = subst_meta [Constr_matching.special_meta,ic] ctxt in
+	let c = Typing.e_solve_evars env evdref (EConstr.of_constr c) in
+	!evdref , c
+      with
+	| Not_found ->
+	    user_err ~loc ~hdr:"interp_may_eval"
+	    (str "Unbound context identifier" ++ pr_id s ++ str"."))
+  | ConstrTypeOf c ->
+      let (sigma,c_interp) = f ist env sigma c in
+      let (sigma, t) = Typing.type_of ~refresh:true env sigma c_interp in
+      (sigma, t)
+  | ConstrTerm c ->
+     try
+	f ist env sigma c
+     with reraise ->
+       let reraise = CErrors.push reraise in
+       (* spiwack: to avoid unnecessary modifications of tacinterp, as this
+          function already use effect, I call [run] hoping it doesn't mess
+          up with any assumption. *)
+       Proofview.NonLogical.run (debugging_exception_step ist false (fst reraise) (fun () ->
+         str"interpretation of term " ++ pr_glob_constr_env env (fst c)));
+       iraise reraise
+
+(* Interprets a constr expression possibly to first evaluate *)
+let interp_constr_may_eval ist env sigma c =
+  let (sigma,csr) =
+    try
+      interp_may_eval interp_constr ist env sigma c
+    with reraise ->
+      let reraise = CErrors.push reraise in
+      (* spiwack: to avoid unnecessary modifications of tacinterp, as this
+          function already use effect, I call [run] hoping it doesn't mess
+          up with any assumption. *)
+       Proofview.NonLogical.run (debugging_exception_step ist false (fst reraise) (fun () -> str"evaluation of term"));
+      iraise reraise
+  in
+  begin
+    (* spiwack: to avoid unnecessary modifications of tacinterp, as this
+       function already use effect, I call [run] hoping it doesn't mess
+       up with any assumption. *)
+    Proofview.NonLogical.run (db_constr (curr_debug ist) env sigma csr);
+    sigma , csr
+  end
+
+(** TODO: should use dedicated printers *)
+let rec message_of_value v =
+  let v = Value.normalize v in
+  let open Ftactic in
+  if has_type v (topwit wit_tacvalue) then
+    Ftactic.return (str "<tactic>")
+  else if has_type v (topwit wit_constr) then
+    let v = out_gen (topwit wit_constr) v in
+    Ftactic.enter {enter = begin fun gl -> Ftactic.return (pr_econstr_env (pf_env gl) (project gl) v) end }
+  else if has_type v (topwit wit_constr_under_binders) then
+    let c = out_gen (topwit wit_constr_under_binders) v in
+    Ftactic.enter { enter = begin fun gl ->
+      Ftactic.return (pr_constr_under_binders_env (pf_env gl) (project gl) c)
+    end }
+  else if has_type v (topwit wit_unit) then
+    Ftactic.return (str "()")
+  else if has_type v (topwit wit_int) then
+    Ftactic.return (int (out_gen (topwit wit_int) v))
+  else if has_type v (topwit wit_intro_pattern) then
+    let p = out_gen (topwit wit_intro_pattern) v in
+    let print env sigma c =
+      let (c, sigma) = Tactics.run_delayed env sigma c in
+      pr_econstr_env env sigma c
+    in
+    Ftactic.enter { enter = begin fun gl ->
+      Ftactic.return (Miscprint.pr_intro_pattern (fun c -> print (pf_env gl) (project gl) c) p)
+    end }
+  else if has_type v (topwit wit_constr_context) then
+    let c = out_gen (topwit wit_constr_context) v in
+    Ftactic.enter { enter = begin fun gl -> Ftactic.return (pr_econstr_env (pf_env gl) (project gl) c) end }
+  else if has_type v (topwit wit_uconstr) then
+    let c = out_gen (topwit wit_uconstr) v in
+    Ftactic.enter { enter = begin fun gl ->
+      Ftactic.return (pr_closed_glob_env (pf_env gl)
+                        (project gl) c)
+    end }
+  else if has_type v (topwit wit_var) then
+    let id = out_gen (topwit wit_var) v in
+    Ftactic.enter { enter = begin fun gl -> Ftactic.return (pr_id id) end }
+  else match Value.to_list v with
+  | Some l ->
+    Ftactic.List.map message_of_value l >>= fun l ->
+    Ftactic.return (prlist_with_sep spc (fun x -> x) l)
+  | None ->
+    let tag = pr_argument_type v in
+    Ftactic.return (str "<" ++ tag ++ str ">") (** TODO *)
+
+let interp_message_token ist = function
+  | MsgString s -> Ftactic.return (str s)
+  | MsgInt n -> Ftactic.return (int n)
+  | MsgIdent (loc,id) ->
+    let v = try Some (Id.Map.find id ist.lfun) with Not_found -> None in
+    match v with
+    | None -> Ftactic.lift (Tacticals.New.tclZEROMSG (pr_id id ++ str" not found."))
+    | Some v -> message_of_value v
+
+let interp_message ist l =
+  let open Ftactic in
+  Ftactic.List.map (interp_message_token ist) l >>= fun l ->
+  Ftactic.return (prlist_with_sep spc (fun x -> x) l)
+
+let rec interp_intro_pattern ist env sigma = function
+  | loc, IntroAction pat ->
+      let (sigma,pat) = interp_intro_pattern_action ist env sigma pat in
+      sigma, (loc, IntroAction pat)
+  | loc, IntroNaming (IntroIdentifier id) ->
+      sigma, (loc, interp_intro_pattern_var loc ist env sigma id)
+  | loc, IntroNaming pat ->
+      sigma, (loc, IntroNaming (interp_intro_pattern_naming loc ist env sigma pat))
+  | loc, IntroForthcoming _  as x -> sigma, x
+
+and interp_intro_pattern_naming loc ist env sigma = function
+  | IntroFresh id -> IntroFresh (interp_ident ist env sigma id)
+  | IntroIdentifier id -> interp_intro_pattern_naming_var loc ist env sigma id
+  | IntroAnonymous as x -> x
+
+and interp_intro_pattern_action ist env sigma = function
+  | IntroOrAndPattern l ->
+      let (sigma,l) = interp_or_and_intro_pattern ist env sigma l in
+      sigma, IntroOrAndPattern l
+  | IntroInjection l ->
+      let sigma,l = interp_intro_pattern_list_as_list ist env sigma l in
+      sigma, IntroInjection l
+  | IntroApplyOn ((loc,c),ipat) ->
+      let c = { delayed = fun env sigma ->
+        let sigma = Sigma.to_evar_map sigma in
+        let (sigma, c) = interp_open_constr ist env sigma c in
+        Sigma.Unsafe.of_pair (c, sigma)
+      } in
+      let sigma,ipat = interp_intro_pattern ist env sigma ipat in
+      sigma, IntroApplyOn ((loc,c),ipat)
+  | IntroWildcard | IntroRewrite _ as x -> sigma, x
+
+and interp_or_and_intro_pattern ist env sigma = function
+  | IntroAndPattern l ->
+      let sigma, l = List.fold_map (interp_intro_pattern ist env) sigma l in
+      sigma, IntroAndPattern l
+  | IntroOrPattern ll ->
+      let sigma, ll = List.fold_map (interp_intro_pattern_list_as_list ist env) sigma ll in
+      sigma, IntroOrPattern ll
+
+and interp_intro_pattern_list_as_list ist env sigma = function
+  | [loc,IntroNaming (IntroIdentifier id)] as l ->
+      (try sigma, coerce_to_intro_pattern_list loc env sigma (Id.Map.find id ist.lfun)
+       with Not_found | CannotCoerceTo _ ->
+         List.fold_map (interp_intro_pattern ist env) sigma l)
+  | l -> List.fold_map (interp_intro_pattern ist env) sigma l
+
+let interp_intro_pattern_naming_option ist env sigma = function
+  | None -> None
+  | Some (loc,pat) -> Some (loc, interp_intro_pattern_naming loc ist env sigma pat)
+
+let interp_or_and_intro_pattern_option ist env sigma = function
+  | None -> sigma, None
+  | Some (ArgVar (loc,id)) ->
+      (match coerce_to_intro_pattern env sigma (Id.Map.find id ist.lfun) with
+      | IntroAction (IntroOrAndPattern l) -> sigma, Some (loc,l)
+      | _ ->
+        user_err ~loc (str "Cannot coerce to a disjunctive/conjunctive pattern."))
+  | Some (ArgArg (loc,l)) ->
+      let sigma,l = interp_or_and_intro_pattern ist env sigma l in
+      sigma, Some (loc,l)
+
+let interp_intro_pattern_option ist env sigma = function
+  | None -> sigma, None
+  | Some ipat ->
+      let sigma, ipat = interp_intro_pattern ist env sigma ipat in
+      sigma, Some ipat
+
+let interp_in_hyp_as ist env sigma (id,ipat) =
+  let sigma, ipat = interp_intro_pattern_option ist env sigma ipat in
+  sigma,(interp_hyp ist env sigma id,ipat)
+
+let interp_binding_name ist sigma = function
+  | AnonHyp n -> AnonHyp n
+  | NamedHyp id ->
+      (* If a name is bound, it has to be a quantified hypothesis *)
+      (* 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 sigma) ist None(dloc,id)
+      with Not_found -> NamedHyp id
+
+let interp_declared_or_quantified_hypothesis ist env sigma = function
+  | AnonHyp n -> AnonHyp n
+  | NamedHyp id ->
+      try try_interp_ltac_var
+	    (coerce_to_decl_or_quant_hyp env sigma) ist (Some (env,sigma)) (dloc,id)
+      with Not_found -> NamedHyp id
+
+let interp_binding ist env sigma (loc,b,c) =
+  let sigma, c = interp_open_constr ist env sigma c in
+  sigma, (loc,interp_binding_name ist sigma b,c)
+
+let interp_bindings ist env sigma = function
+| NoBindings ->
+    sigma, NoBindings
+| ImplicitBindings l ->
+    let sigma, l = interp_open_constr_list ist env sigma l in   
+    sigma, ImplicitBindings l
+| ExplicitBindings l ->
+    let sigma, l = List.fold_map (interp_binding ist env) sigma l in
+    sigma, ExplicitBindings l
+
+let interp_constr_with_bindings ist env sigma (c,bl) =
+  let sigma, bl = interp_bindings ist env sigma bl in
+  let sigma, c = interp_open_constr ist env sigma c in
+  sigma, (c,bl)
+
+let interp_open_constr_with_bindings ist env sigma (c,bl) =
+  let sigma, bl = interp_bindings ist env sigma bl in
+  let sigma, c = interp_open_constr ist env sigma c in
+  sigma, (c, bl)
+
+let loc_of_bindings = function
+| NoBindings -> Loc.ghost
+| ImplicitBindings l -> loc_of_glob_constr (fst (List.last l))
+| ExplicitBindings l -> pi1 (List.last l)
+
+let interp_open_constr_with_bindings_loc ist ((c,_),bl as cb) =
+  let loc1 = loc_of_glob_constr c in
+  let loc2 = loc_of_bindings bl in
+  let loc = if Loc.is_ghost loc2 then loc1 else Loc.merge loc1 loc2 in
+  let f = { delayed = fun env sigma ->
+    let sigma = Sigma.to_evar_map sigma in
+    let (sigma, c) = interp_open_constr_with_bindings ist env sigma cb in
+    Sigma.Unsafe.of_pair (c, sigma)
+  } in
+    (loc,f)
+
+let interp_destruction_arg ist gl arg =
+  match arg with
+  | keep,ElimOnConstr c ->
+      keep,ElimOnConstr { delayed = fun env sigma ->
+        let sigma = Sigma.to_evar_map sigma in
+        let (sigma, c) = interp_constr_with_bindings ist env sigma c in
+        Sigma.Unsafe.of_pair (c, sigma)
+      }
+  | keep,ElimOnAnonHyp n as x -> x
+  | keep,ElimOnIdent (loc,id) ->
+      let error () = user_err ~loc 
+       (strbrk "Cannot coerce " ++ pr_id id ++
+        strbrk " neither to a quantified hypothesis nor to a term.")
+      in
+      let try_cast_id id' =
+        if Tactics.is_quantified_hypothesis id' gl
+        then keep,ElimOnIdent (loc,id')
+        else
+          (keep, ElimOnConstr { delayed = begin fun env sigma ->
+          try Sigma.here (constr_of_id env id', NoBindings) sigma
+          with Not_found ->
+            user_err ~loc  ~hdr:"interp_destruction_arg" (
+            pr_id id ++ strbrk " binds to " ++ pr_id id' ++ strbrk " which is neither a declared nor a quantified hypothesis.")
+          end })
+      in
+      try
+        (** FIXME: should be moved to taccoerce *)
+        let v = Id.Map.find id ist.lfun in
+        let v = Value.normalize v in
+        if has_type v (topwit wit_intro_pattern) then
+          let v = out_gen (topwit wit_intro_pattern) v in
+          match v with
+          | _, IntroNaming (IntroIdentifier id) -> try_cast_id id
+          | _ -> error ()
+        else if has_type v (topwit wit_var) then
+          let id = out_gen (topwit wit_var) v in
+          try_cast_id id
+        else if has_type v (topwit wit_int) then
+          keep,ElimOnAnonHyp (out_gen (topwit wit_int) v)
+        else match Value.to_constr v with
+        | None -> error ()
+        | Some c -> keep,ElimOnConstr { delayed = fun env sigma -> Sigma ((c,NoBindings), sigma, Sigma.refl) }
+      with Not_found ->
+	(* We were in non strict (interactive) mode *)
+	if Tactics.is_quantified_hypothesis id gl then
+          keep,ElimOnIdent (loc,id)
+	else
+          let c = (GVar (loc,id),Some (CRef (Ident (loc,id),None))) in
+          let f = { delayed = fun env sigma ->
+            let sigma = Sigma.to_evar_map sigma in
+            let (sigma,c) = interp_open_constr ist env sigma c in
+            Sigma.Unsafe.of_pair ((c,NoBindings), sigma)
+          } in
+          keep,ElimOnConstr f
+
+(* Associates variables with values and gives the remaining variables and
+   values *)
+let head_with_value (lvar,lval) =
+  let rec head_with_value_rec lacc = function
+    | ([],[]) -> (lacc,[],[])
+    | (vr::tvr,ve::tve) ->
+      (match vr with
+      |	Anonymous -> head_with_value_rec lacc (tvr,tve)
+      | Name v -> head_with_value_rec ((v,ve)::lacc) (tvr,tve))
+    | (vr,[]) -> (lacc,vr,[])
+    | ([],ve) -> (lacc,[],ve)
+  in
+  head_with_value_rec [] (lvar,lval)
+
+(** [interp_context ctxt] interprets a context (as in
+    {!Matching.matching_result}) into a context value of Ltac.  *)
+let interp_context ctxt = in_gen (topwit wit_constr_context) ctxt
+
+(* Reads a pattern by substituting vars of lfun *)
+let use_types = false
+
+let eval_pattern lfun ist env sigma (bvars,(glob,_),pat as c) =
+  if use_types then
+    (bvars,interp_typed_pattern ist env sigma c)
+  else
+    (bvars,instantiate_pattern env sigma lfun pat)
+
+let read_pattern lfun ist env sigma = function
+  | Subterm (b,ido,c) -> Subterm (b,ido,eval_pattern lfun ist env sigma c)
+  | Term c -> Term (eval_pattern lfun ist env sigma c)
+
+(* Reads the hypotheses of a Match Context rule *)
+let cons_and_check_name id l =
+  if Id.List.mem id l then
+    user_err ~hdr:"read_match_goal_hyps" (
+      str "Hypothesis pattern-matching variable " ++ pr_id id ++
+      str " used twice in the same pattern.")
+  else id::l
+
+let rec read_match_goal_hyps lfun ist env sigma lidh = function
+  | (Hyp ((loc,na) as locna,mp))::tl ->
+      let lidh' = name_fold cons_and_check_name na lidh in
+      Hyp (locna,read_pattern lfun ist env sigma mp)::
+	(read_match_goal_hyps lfun ist env sigma lidh' tl)
+  | (Def ((loc,na) as locna,mv,mp))::tl ->
+      let lidh' = name_fold cons_and_check_name na lidh in
+      Def (locna,read_pattern lfun ist env sigma mv, read_pattern lfun ist env sigma mp)::
+	(read_match_goal_hyps lfun ist env sigma lidh' tl)
+  | [] -> []
+
+(* Reads the rules of a Match Context or a Match *)
+let rec read_match_rule lfun ist env sigma = function
+  | (All tc)::tl -> (All tc)::(read_match_rule lfun ist env sigma tl)
+  | (Pat (rl,mp,tc))::tl ->
+      Pat (read_match_goal_hyps lfun ist env sigma [] rl, read_pattern lfun ist env sigma mp,tc)
+      :: read_match_rule lfun ist env sigma tl
+  | [] -> []
+
+let warn_deprecated_info =
+  CWarnings.create ~name:"deprecated-info-tactical" ~category:"deprecated"
+         (fun () ->
+          strbrk "The general \"info\" tactic is currently not working." ++ spc()++
+            strbrk "There is an \"Info\" command to replace it." ++fnl () ++
+            strbrk "Some specific verbose tactics may also exist, such as info_eauto.")
+
+(* Interprets an l-tac expression into a value *)
+let rec val_interp ist ?(appl=UnnamedAppl) (tac:glob_tactic_expr) : Val.t Ftactic.t =
+  (* The name [appl] of applied top-level Ltac names is ignored in
+     [value_interp]. It is installed in the second step by a call to
+     [name_vfun], because it gives more opportunities to detect a
+     [VFun]. Otherwise a [Ltac t := let x := .. in tac] would never
+     register its name since it is syntactically a let, not a
+     function.  *)
+  let value_interp ist = match tac with
+  | TacFun (it, body) ->
+    Ftactic.return (of_tacvalue (VFun (UnnamedAppl,extract_trace ist, ist.lfun, it, body)))
+  | TacLetIn (true,l,u) -> interp_letrec ist l u
+  | TacLetIn (false,l,u) -> interp_letin ist l u
+  | TacMatchGoal (lz,lr,lmr) -> interp_match_goal ist lz lr lmr
+  | TacMatch (lz,c,lmr) -> interp_match ist lz c lmr
+  | TacArg (loc,a) -> interp_tacarg ist a
+  | t ->
+    (** Delayed evaluation *)
+    Ftactic.return (of_tacvalue (VFun (UnnamedAppl,extract_trace ist, ist.lfun, [], t)))
+  in
+  let open Ftactic in
+  Control.check_for_interrupt ();
+  match curr_debug ist with
+  | DebugOn lev ->
+        let eval v =
+          let ist = { ist with extra = TacStore.set ist.extra f_debug v } in
+          value_interp ist >>= fun v -> return (name_vfun appl v)
+        in
+	Tactic_debug.debug_prompt lev tac eval
+  | _ -> value_interp ist >>= fun v -> return (name_vfun appl v)
+      
+
+and eval_tactic ist tac : unit Proofview.tactic = match tac with
+  | TacAtom (loc,t) ->
+      let call = LtacAtomCall t in
+      push_trace(loc,call) ist >>= fun trace ->
+      Profile_ltac.do_profile "eval_tactic:2" trace
+        (catch_error_tac trace (interp_atomic ist t))
+  | TacFun _ | TacLetIn _ -> assert false
+  | TacMatchGoal _ | TacMatch _ -> assert false
+  | TacId [] -> Proofview.tclLIFT (db_breakpoint (curr_debug ist) [])
+  | TacId s ->
+      let msgnl =
+        let open Ftactic in
+        interp_message ist s >>= fun msg ->
+        return (hov 0 msg , hov 0 msg)
+      in
+      let print (_,msgnl) = Proofview.(tclLIFT (NonLogical.print_info msgnl)) in
+      let log (msg,_) = Proofview.Trace.log (fun () -> msg) in
+      let break = Proofview.tclLIFT (db_breakpoint (curr_debug ist) s) in
+      Ftactic.run msgnl begin fun msgnl ->
+        print msgnl <*> log msgnl <*> break
+      end
+  | TacFail (g,n,s) ->
+      let msg = interp_message ist s in
+      let tac l = Tacticals.New.tclFAIL (interp_int_or_var ist n) l in
+      let tac =
+        match g with
+        | TacLocal -> fun l -> Proofview.tclINDEPENDENT (tac l)
+        | TacGlobal -> tac
+      in
+      Ftactic.run msg tac
+  | TacProgress tac -> Tacticals.New.tclPROGRESS (interp_tactic ist tac)
+  | TacShowHyps tac ->
+         Proofview.V82.tactic begin
+           tclSHOWHYPS (Proofview.V82.of_tactic (interp_tactic ist tac))
+         end
+  | TacAbstract (tac,ido) ->
+      Proofview.Goal.enter { enter = begin fun gl -> Tactics.tclABSTRACT
+        (Option.map (interp_ident ist (pf_env gl) (project gl)) ido) (interp_tactic ist tac)
+      end }
+  | TacThen (t1,t) ->
+      Tacticals.New.tclTHEN (interp_tactic ist t1) (interp_tactic ist t)
+  | TacDispatch tl ->
+      Proofview.tclDISPATCH (List.map (interp_tactic ist) tl)
+  | TacExtendTac (tf,t,tl) ->
+      Proofview.tclEXTEND (Array.map_to_list (interp_tactic ist) tf)
+                          (interp_tactic ist t)
+                          (Array.map_to_list (interp_tactic ist) tl)
+  | TacThens (t1,tl) -> Tacticals.New.tclTHENS (interp_tactic ist t1) (List.map (interp_tactic ist) tl)
+  | TacThens3parts (t1,tf,t,tl) ->
+      Tacticals.New.tclTHENS3PARTS (interp_tactic ist t1)
+	(Array.map (interp_tactic ist) tf) (interp_tactic ist t) (Array.map (interp_tactic ist) tl)
+  | TacDo (n,tac) -> Tacticals.New.tclDO (interp_int_or_var ist n) (interp_tactic ist tac)
+  | TacTimeout (n,tac) -> Tacticals.New.tclTIMEOUT (interp_int_or_var ist n) (interp_tactic ist tac)
+  | TacTime (s,tac) -> Tacticals.New.tclTIME s (interp_tactic ist tac)
+  | TacTry tac -> Tacticals.New.tclTRY (interp_tactic ist tac)
+  | TacRepeat tac -> Tacticals.New.tclREPEAT (interp_tactic ist tac)
+  | TacOr (tac1,tac2) ->
+      Tacticals.New.tclOR (interp_tactic ist tac1) (interp_tactic ist tac2)
+  | TacOnce tac ->
+      Tacticals.New.tclONCE (interp_tactic ist tac)
+  | TacExactlyOnce tac ->
+      Tacticals.New.tclEXACTLY_ONCE (interp_tactic ist tac)
+  | TacIfThenCatch (t,tt,te) ->
+      Tacticals.New.tclIFCATCH
+        (interp_tactic ist t)
+        (fun () -> interp_tactic ist tt)
+        (fun () -> interp_tactic ist te)
+  | TacOrelse (tac1,tac2) ->
+      Tacticals.New.tclORELSE (interp_tactic ist tac1) (interp_tactic ist tac2)
+  | TacFirst l -> Tacticals.New.tclFIRST (List.map (interp_tactic ist) l)
+  | TacSolve l -> Tacticals.New.tclSOLVE (List.map (interp_tactic ist) l)
+  | TacComplete tac -> Tacticals.New.tclCOMPLETE (interp_tactic ist tac)
+  | TacArg a -> interp_tactic ist (TacArg a)
+  | TacInfo tac ->
+      warn_deprecated_info ();
+      eval_tactic ist tac
+  | TacSelect (sel, tac) -> Tacticals.New.tclSELECT sel (interp_tactic ist tac)
+  (* For extensions *)
+  | TacAlias (loc,s,l) ->
+      let (ids, body) = Tacenv.interp_alias s in
+      let (>>=) = Ftactic.bind in
+      let interp_vars = Ftactic.List.map (fun v -> interp_tacarg ist v) l in
+      let tac l =
+        let addvar x v accu = Id.Map.add x v accu in
+        let lfun = List.fold_right2 addvar ids l ist.lfun in
+        Ftactic.lift (push_trace (loc,LtacNotationCall s) ist) >>= fun trace ->
+        let ist = {
+          lfun = lfun;
+          extra = TacStore.set ist.extra f_trace trace; } in
+        val_interp ist body >>= fun v ->
+        Ftactic.lift (tactic_of_value ist v)
+      in
+      let tac =
+        Ftactic.with_env interp_vars >>= fun (env, lr) ->
+        let name () = Pptactic.pr_alias (fun v -> print_top_val env v) 0 s lr in
+        Proofview.Trace.name_tactic name (tac lr)
+      (* spiwack: this use of name_tactic is not robust to a
+         change of implementation of [Ftactic]. In such a situation,
+         some more elaborate solution will have to be used. *)
+      in
+      let tac =
+        let len1 = List.length ids in
+        let len2 = List.length l in
+        if len1 = len2 then tac
+        else Tacticals.New.tclZEROMSG (str "Arguments length mismatch: \
+          expected " ++ int len1 ++ str ", found " ++ int len2)
+      in
+      Ftactic.run tac (fun () -> Proofview.tclUNIT ())
+
+  | TacML (loc,opn,l) ->
+      push_trace (loc,LtacMLCall tac) ist >>= fun trace ->
+      let ist = { ist with extra = TacStore.set ist.extra f_trace trace; } in
+      let tac = Tacenv.interp_ml_tactic opn in
+      let args = Ftactic.List.map_right (fun a -> interp_tacarg ist a) l in
+      let tac args =
+        let name () = Pptactic.pr_extend (fun v -> print_top_val () v) 0 opn args in
+        Proofview.Trace.name_tactic name (catch_error_tac trace (tac args ist))
+      in
+      Ftactic.run args tac
+
+and force_vrec ist v : Val.t Ftactic.t =
+  let v = Value.normalize v in
+  if has_type v (topwit wit_tacvalue) then
+    let v = to_tacvalue v in
+    match v with
+    | VRec (lfun,body) -> val_interp {ist with lfun = !lfun} body
+    | v -> Ftactic.return (of_tacvalue v)
+  else Ftactic.return v
+
+and interp_ltac_reference loc' mustbetac ist r : Val.t Ftactic.t =
+  match r with
+  | ArgVar (loc,id) ->
+      let v =
+        try Id.Map.find id ist.lfun
+        with Not_found -> in_gen (topwit wit_var) id
+      in
+      let open Ftactic in
+      force_vrec ist v >>= begin fun v ->
+      Ftactic.lift (propagate_trace ist loc id v) >>= fun v ->
+      if mustbetac then Ftactic.return (coerce_to_tactic loc id v) else Ftactic.return v
+      end
+  | ArgArg (loc,r) ->
+      let ids = extract_ids [] ist.lfun in
+      let loc_info = ((if Loc.is_ghost loc' then loc else loc'),LtacNameCall r) in
+      let extra = TacStore.set ist.extra f_avoid_ids ids in
+      push_trace loc_info ist >>= fun trace ->
+      let extra = TacStore.set extra f_trace trace in
+      let ist = { lfun = Id.Map.empty; extra = extra; } in
+      let appl = GlbAppl[r,[]] in
+      val_interp ~appl ist (Tacenv.interp_ltac r)
+
+and interp_tacarg ist arg : Val.t Ftactic.t =
+  match arg with
+  | TacGeneric arg -> interp_genarg ist arg
+  | Reference r -> interp_ltac_reference dloc false ist r
+  | ConstrMayEval c ->
+      Ftactic.s_enter { s_enter = begin fun gl ->
+        let sigma = project gl in
+        let env = Proofview.Goal.env gl in
+        let (sigma,c_interp) = interp_constr_may_eval ist env sigma c in
+        Sigma.Unsafe.of_pair (Ftactic.return (Value.of_constr c_interp), sigma)
+      end }
+  | TacCall (loc,r,[]) ->
+      interp_ltac_reference loc true ist r
+  | TacCall (loc,f,l) ->
+      let (>>=) = Ftactic.bind in
+      interp_ltac_reference loc true ist f >>= fun fv ->
+      Ftactic.List.map (fun a -> interp_tacarg ist a) l >>= fun largs ->
+      interp_app loc ist fv largs
+  | TacFreshId l ->
+      Ftactic.enter { enter = begin fun gl ->
+        let id = interp_fresh_id ist (pf_env gl) (project gl) l in
+        Ftactic.return (in_gen (topwit wit_intro_pattern) (dloc, IntroNaming (IntroIdentifier id)))
+      end }
+  | TacPretype c ->
+      Ftactic.s_enter { s_enter = begin fun gl ->
+        let sigma = Proofview.Goal.sigma gl in
+        let env = Proofview.Goal.env gl in
+        let c = interp_uconstr ist env (Sigma.to_evar_map sigma) c in
+        let Sigma (c, sigma, p) = (type_uconstr ist c).delayed env sigma in
+        Sigma (Ftactic.return (Value.of_constr c), sigma, p)
+      end }
+  | TacNumgoals ->
+      Ftactic.lift begin
+        let open Proofview.Notations in
+        Proofview.numgoals >>= fun i ->
+        Proofview.tclUNIT (Value.of_int i)
+      end
+  | Tacexp t -> val_interp ist t
+
+(* Interprets an application node *)
+and interp_app loc ist fv largs : Val.t Ftactic.t =
+  let (>>=) = Ftactic.bind in
+  let fail = Tacticals.New.tclZEROMSG (str "Illegal tactic application.") in
+  let fv = Value.normalize fv in
+  if has_type fv (topwit wit_tacvalue) then
+  match to_tacvalue fv with
+     (* if var=[] and body has been delayed by val_interp, then body
+         is not a tactic that expects arguments.
+         Otherwise Ltac goes into an infinite loop (val_interp puts
+         a VFun back on body, and then interp_app is called again...) *)
+    | (VFun(appl,trace,olfun,(_::_ as var),body)
+      |VFun(appl,trace,olfun,([] as var),
+         (TacFun _|TacLetIn _|TacMatchGoal _|TacMatch _| TacArg _ as body))) ->
+	let (extfun,lvar,lval)=head_with_value (var,largs) in
+        let fold accu (id, v) = Id.Map.add id v accu in
+	let newlfun = List.fold_left fold olfun extfun in
+      if List.is_empty lvar then
+        begin Proofview.tclORELSE
+            begin
+              let ist = {
+                lfun = newlfun;
+                extra = TacStore.set ist.extra f_trace []; } in
+              catch_error_tac trace (val_interp ist body) >>= fun v ->
+              Ftactic.return (name_vfun (push_appl appl largs) v)
+            end
+	    begin fun (e, info) ->
+              Proofview.tclLIFT (debugging_exception_step ist false e (fun () -> str "evaluation")) <*>
+	      Proofview.tclZERO ~info e
+            end
+        end >>= fun v ->
+        (* No errors happened, we propagate the trace *)
+        let v = append_trace trace v in
+        Proofview.tclLIFT begin
+          debugging_step ist
+	    (fun () ->
+	      str"evaluation returns"++fnl()++pr_value None v)
+        end <*>
+        if List.is_empty lval then Ftactic.return v else interp_app loc ist v lval
+      else
+        Ftactic.return (of_tacvalue (VFun(push_appl appl largs,trace,newlfun,lvar,body)))
+    | _ -> fail
+  else fail
+
+(* Gives the tactic corresponding to the tactic value *)
+and tactic_of_value ist vle =
+  let vle = Value.normalize vle in
+  if has_type vle (topwit wit_tacvalue) then
+  match to_tacvalue vle with
+  | VFun (appl,trace,lfun,[],t) ->
+      let ist = {
+        lfun = lfun;
+        extra = TacStore.set ist.extra f_trace []; } in
+      let tac = name_if_glob appl (eval_tactic ist t) in
+      Profile_ltac.do_profile "tactic_of_value" trace (catch_error_tac trace tac)
+  | VFun (_, _, _,vars,_) ->
+    let numargs = List.length vars in
+    Tacticals.New.tclZEROMSG
+      (str "A fully applied tactic is expected:" ++ spc() ++ Pp.str "missing " ++
+       Pp.str (String.plural numargs "argument") ++ Pp.str " for " ++
+       Pp.str (String.plural numargs "variable") ++ Pp.str " " ++
+       pr_enum pr_name vars ++ Pp.str ".")
+  | VRec _ -> Tacticals.New.tclZEROMSG (str "A fully applied tactic is expected.")
+  else if has_type vle (topwit wit_tactic) then
+    let tac = out_gen (topwit wit_tactic) vle in
+    tactic_of_value ist tac
+  else Tacticals.New.tclZEROMSG (str "Expression does not evaluate to a tactic.")
+
+(* Interprets the clauses of a recursive LetIn *)
+and interp_letrec ist llc u =
+  Proofview.tclUNIT () >>= fun () -> (* delay for the effects of [lref], just in case. *)
+  let lref = ref ist.lfun in
+  let fold accu ((_, id), b) =
+    let v = of_tacvalue (VRec (lref, TacArg (dloc, b))) in
+    Id.Map.add id v accu
+  in
+  let lfun = List.fold_left fold ist.lfun llc in
+  let () = lref := lfun in
+  let ist = { ist with lfun } in
+  val_interp ist u
+
+(* Interprets the clauses of a LetIn *)
+and interp_letin ist llc u =
+  let rec fold lfun = function
+  | [] ->
+    let ist = { ist with lfun } in
+    val_interp ist u
+  | ((_, id), body) :: defs ->
+    Ftactic.bind (interp_tacarg ist body) (fun v ->
+    fold (Id.Map.add id v lfun) defs)
+  in
+  fold ist.lfun llc
+
+(** [interp_match_success lz ist succ] interprets a single matching success
+    (of type {!Tactic_matching.t}). *)
+and interp_match_success ist { Tactic_matching.subst ; context ; terms ; lhs } =
+  let (>>=) = Ftactic.bind in
+  let lctxt = Id.Map.map interp_context context in
+  let hyp_subst = Id.Map.map Value.of_constr terms in
+  let lfun = extend_values_with_bindings subst (lctxt +++ hyp_subst +++ ist.lfun) in
+  let ist = { ist with lfun } in
+  val_interp ist lhs >>= fun v ->
+  if has_type v (topwit wit_tacvalue) then match to_tacvalue v with
+  | VFun (appl,trace,lfun,[],t) ->
+      let ist = {
+        lfun = lfun;
+        extra = TacStore.set ist.extra f_trace trace; } in
+      let tac = eval_tactic ist t in
+      let dummy = VFun (appl,extract_trace ist, Id.Map.empty, [], TacId []) in
+      catch_error_tac trace (tac <*> Ftactic.return (of_tacvalue dummy))
+  | _ -> Ftactic.return v
+  else Ftactic.return v
+
+
+(** [interp_match_successes lz ist s] interprets the stream of
+    matching of successes [s]. If [lz] is set to true, then only the
+    first success is considered, otherwise further successes are tried
+    if the left-hand side fails. *)
+and interp_match_successes lz ist s =
+   let general =
+     let break (e, info) = match e with
+       | FailError (0, _) -> None
+       | FailError (n, s) -> Some (FailError (pred n, s), info)
+       | _ -> None
+     in
+     Proofview.tclBREAK break s >>= fun ans -> interp_match_success ist ans
+   in
+    match lz with
+    | General ->
+        general
+    | Select ->
+      begin
+        (** Only keep the first matching result, we don't backtrack on it *)
+        let s = Proofview.tclONCE s in
+        s >>= fun ans -> interp_match_success ist ans
+      end
+    | Once ->
+        (** Once a tactic has succeeded, do not backtrack anymore *)
+        Proofview.tclONCE general
+
+(* Interprets the Match expressions *)
+and interp_match ist lz constr lmr =
+  let (>>=) = Ftactic.bind in
+  begin Proofview.tclORELSE
+    (interp_ltac_constr ist constr)
+    begin function
+      | (e, info) ->
+          Proofview.tclLIFT (debugging_exception_step ist true e
+          (fun () -> str "evaluation of the matched expression")) <*>
+          Proofview.tclZERO ~info e
+    end
+  end >>= fun constr ->
+  Ftactic.enter { enter = begin fun gl ->
+    let sigma = project gl in
+    let env = Proofview.Goal.env gl in
+    let ilr = read_match_rule (extract_ltac_constr_values ist env) ist env sigma lmr in
+    interp_match_successes lz ist (Tactic_matching.match_term env sigma constr ilr)
+  end }
+
+(* Interprets the Match Context expressions *)
+and interp_match_goal ist lz lr lmr =
+    Ftactic.enter { enter = begin fun gl ->
+      let sigma = project gl in
+      let env = Proofview.Goal.env gl in
+      let hyps = Proofview.Goal.hyps gl in
+      let hyps = if lr then List.rev hyps else hyps in
+      let concl = Proofview.Goal.concl gl in
+      let ilr = read_match_rule (extract_ltac_constr_values ist env) ist env sigma lmr in
+      interp_match_successes lz ist (Tactic_matching.match_goal env sigma hyps concl ilr)
+    end }
+
+(* Interprets extended tactic generic arguments *)
+and interp_genarg ist x : Val.t Ftactic.t =
+    let open Ftactic.Notations in
+    (** Ad-hoc handling of some types. *)
+    let tag = genarg_tag x in
+    if argument_type_eq tag (unquote (topwit (wit_list wit_var))) then
+      interp_genarg_var_list ist x
+    else if argument_type_eq tag (unquote (topwit (wit_list wit_constr))) then
+      interp_genarg_constr_list ist x
+    else
+    let GenArg (Glbwit wit, x) = x in
+    match wit with
+    | ListArg wit ->
+      let map x = interp_genarg ist (Genarg.in_gen (glbwit wit) x) in
+      Ftactic.List.map map x >>= fun l ->
+      Ftactic.return (Val.Dyn (Val.typ_list, l))
+    | OptArg wit ->
+      begin match x with
+      | None -> Ftactic.return (Val.Dyn (Val.typ_opt, None))
+      | Some x ->
+        interp_genarg ist (Genarg.in_gen (glbwit wit) x) >>= fun x ->
+        Ftactic.return (Val.Dyn (Val.typ_opt, Some x))
+      end
+    | PairArg (wit1, wit2) ->
+      let (p, q) = x in
+      interp_genarg ist (Genarg.in_gen (glbwit wit1) p) >>= fun p ->
+      interp_genarg ist (Genarg.in_gen (glbwit wit2) q) >>= fun q ->
+      Ftactic.return (Val.Dyn (Val.typ_pair, (p, q)))
+    | ExtraArg s ->
+      Geninterp.interp wit ist x
+
+(** returns [true] for genargs which have the same meaning
+    independently of goals. *)
+
+and interp_genarg_constr_list ist x =
+  Ftactic.nf_s_enter { s_enter = begin fun gl ->
+  let env = Proofview.Goal.env gl in
+  let sigma = Sigma.to_evar_map (Proofview.Goal.sigma gl) in
+  let lc = Genarg.out_gen (glbwit (wit_list wit_constr)) x in
+  let (sigma,lc) = interp_constr_list ist env sigma lc in
+  let lc = in_list (val_tag wit_constr) lc in
+  Sigma.Unsafe.of_pair (Ftactic.return lc, sigma)
+  end }
+
+and interp_genarg_var_list ist x =
+  Ftactic.enter { enter = begin fun gl ->
+  let env = Proofview.Goal.env gl in
+  let sigma = Sigma.to_evar_map (Proofview.Goal.sigma gl) in
+  let lc = Genarg.out_gen (glbwit (wit_list wit_var)) x in
+  let lc = interp_hyp_list ist env sigma lc in
+  let lc = in_list (val_tag wit_var) lc in
+  Ftactic.return lc
+  end }
+
+(* Interprets tactic expressions : returns a "constr" *)
+and interp_ltac_constr ist e : EConstr.t Ftactic.t =
+  let (>>=) = Ftactic.bind in
+  begin Proofview.tclORELSE
+      (val_interp ist e)
+      begin function (err, info) -> match err with
+        | Not_found ->
+            Ftactic.enter { enter = begin fun gl ->
+              let env = Proofview.Goal.env gl in
+              Proofview.tclLIFT begin
+                debugging_step ist (fun () ->
+                  str "evaluation failed for" ++ fnl() ++
+                    Pptactic.pr_glob_tactic env e)
+              end
+            <*> Proofview.tclZERO Not_found
+            end }
+        | err -> Proofview.tclZERO ~info err
+      end
+  end >>= fun result ->
+  Ftactic.enter { enter = begin fun gl ->
+  let env = Proofview.Goal.env gl in
+  let sigma = project gl in
+  let result = Value.normalize result in
+  try
+    let cresult = coerce_to_closed_constr env result in
+    Proofview.tclLIFT begin
+      debugging_step ist (fun () ->
+        Pptactic.pr_glob_tactic env e ++ fnl() ++
+          str " has value " ++ fnl() ++
+          pr_econstr_env env sigma cresult)
+    end <*>
+    Ftactic.return cresult
+  with CannotCoerceTo _ ->
+    let env = Proofview.Goal.env gl in
+    Tacticals.New.tclZEROMSG (str "Must evaluate to a closed term" ++ fnl() ++
+      str "offending expression: " ++ fnl() ++ pr_inspect env e result)
+  end }
+
+
+(* Interprets tactic expressions : returns a "tactic" *)
+and interp_tactic ist tac : unit Proofview.tactic =
+  Ftactic.run (val_interp ist tac) (fun v -> tactic_of_value ist v)
+
+(* Provides a "name" for the trace to atomic tactics *)
+and name_atomic ?env tacexpr tac : unit Proofview.tactic =
+  begin match env with
+  | Some e -> Proofview.tclUNIT e
+  | None -> Proofview.tclENV
+  end >>= fun env ->
+  Proofview.tclEVARMAP >>= fun sigma ->
+  let name () = Pptactic.pr_atomic_tactic env sigma tacexpr in
+  Proofview.Trace.name_tactic name tac
+
+(* Interprets a primitive tactic *)
+and interp_atomic ist tac : unit Proofview.tactic =
+  match tac with
+  (* Basic tactics *)
+  | TacIntroPattern (ev,l) ->
+      Proofview.Goal.enter { enter = begin fun gl ->
+        let env = Proofview.Goal.env gl in
+        let sigma = project gl in
+        let sigma,l' = interp_intro_pattern_list_as_list ist env sigma l in
+        Tacticals.New.tclWITHHOLES ev
+        (name_atomic ~env
+          (TacIntroPattern (ev,l))
+          (* spiwack: print uninterpreted, not sure if it is the
+             expected behaviour. *)
+          (Tactics.intro_patterns ev l')) sigma
+      end }
+  | TacApply (a,ev,cb,cl) ->
+      (* spiwack: until the tactic is in the monad *)
+      Proofview.Trace.name_tactic (fun () -> Pp.str"<apply>") begin
+      Proofview.Goal.enter { enter = begin fun gl ->
+        let env = Proofview.Goal.env gl in
+        let sigma = project gl in
+	let l = List.map (fun (k,c) ->
+          let loc, f = interp_open_constr_with_bindings_loc ist c in
+	    (k,(loc,f))) cb 
+	in
+        let sigma,tac = match cl with
+          | None -> sigma, Tactics.apply_with_delayed_bindings_gen a ev l
+          | Some cl ->
+              let sigma,(id,cl) = interp_in_hyp_as ist env sigma cl in
+              sigma, Tactics.apply_delayed_in a ev id l cl in
+        Tacticals.New.tclWITHHOLES ev tac sigma
+      end }
+      end
+  | TacElim (ev,(keep,cb),cbo) ->
+      Proofview.Goal.enter { enter = begin fun gl ->
+        let env = Proofview.Goal.env gl in
+        let sigma = project gl in 
+        let sigma, cb = interp_constr_with_bindings ist env sigma cb in
+        let sigma, cbo = Option.fold_map (interp_constr_with_bindings ist env) sigma cbo in
+        let named_tac =
+          let tac = Tactics.elim ev keep cb cbo in
+          name_atomic ~env (TacElim (ev,(keep,cb),cbo)) tac
+        in
+        Tacticals.New.tclWITHHOLES ev named_tac sigma
+      end }
+  | TacCase (ev,(keep,cb)) ->
+      Proofview.Goal.enter { enter = begin fun gl ->
+        let sigma = project gl in
+        let env = Proofview.Goal.env gl in
+        let sigma, cb = interp_constr_with_bindings ist env sigma cb in
+        let named_tac =
+          let tac = Tactics.general_case_analysis ev keep cb in
+          name_atomic ~env (TacCase(ev,(keep,cb))) tac
+        in
+        Tacticals.New.tclWITHHOLES ev named_tac sigma
+      end }
+  | TacMutualFix (id,n,l) ->
+      (* spiwack: until the tactic is in the monad *)
+      Proofview.Trace.name_tactic (fun () -> Pp.str"<mutual fix>") begin
+      Proofview.Goal.nf_s_enter { s_enter = begin fun gl ->
+        let env = pf_env gl in
+        let f sigma (id,n,c) =
+          let (sigma,c_interp) = interp_type ist env sigma c in
+	  sigma , (interp_ident ist env sigma id,n,c_interp) in
+        let (sigma,l_interp) =
+          Evd.MonadR.List.map_right (fun c sigma -> f sigma c) l (project gl)
+        in
+        let tac = Tactics.mutual_fix (interp_ident ist env sigma id) n l_interp 0 in
+        Sigma.Unsafe.of_pair (tac, sigma)
+      end }
+      end
+  | TacMutualCofix (id,l) ->
+      (* spiwack: until the tactic is in the monad *)
+      Proofview.Trace.name_tactic (fun () -> Pp.str"<mutual cofix>") begin
+      Proofview.Goal.nf_s_enter { s_enter = begin fun gl ->
+        let env = pf_env gl in
+        let f sigma (id,c) =
+	  let (sigma,c_interp) = interp_type ist env sigma c in
+	  sigma , (interp_ident ist env sigma id,c_interp) in
+        let (sigma,l_interp) =
+          Evd.MonadR.List.map_right (fun c sigma -> f sigma c) l (project gl)
+        in
+        let tac = Tactics.mutual_cofix (interp_ident ist env sigma id) l_interp 0 in
+        Sigma.Unsafe.of_pair (tac, sigma)
+      end }
+      end
+  | TacAssert (b,t,ipat,c) ->
+      Proofview.Goal.enter { enter = begin fun gl ->
+        let env = Proofview.Goal.env gl in
+        let sigma = project gl in
+        let (sigma,c) = 
+          (if Option.is_empty t then interp_constr else interp_type) ist env sigma c
+        in
+        let sigma, ipat' = interp_intro_pattern_option ist env sigma ipat in
+        let tac = Option.map (Option.map (interp_tactic ist)) t in
+        Tacticals.New.tclWITHHOLES false
+        (name_atomic ~env
+          (TacAssert(b,Option.map (Option.map ignore) t,ipat,c))
+          (Tactics.forward b tac ipat' c)) sigma
+      end }
+  | TacGeneralize cl ->
+      Proofview.Goal.enter { enter = begin fun gl ->
+        let sigma = project gl in
+        let env = Proofview.Goal.env gl in
+        let sigma, cl = interp_constr_with_occurrences_and_name_as_list ist env sigma cl in
+        Tacticals.New.tclWITHHOLES false
+        (name_atomic ~env
+          (TacGeneralize cl)
+          (Tactics.generalize_gen cl)) sigma
+      end }
+  | TacLetTac (na,c,clp,b,eqpat) ->
+      Proofview.Goal.enter { enter = begin fun gl ->
+        let env = Proofview.Goal.env gl in
+        let sigma = project gl in
+        let clp = interp_clause ist env sigma clp in
+        let eqpat = interp_intro_pattern_naming_option ist env sigma eqpat in
+        if Locusops.is_nowhere clp then
+        (* We try to fully-typecheck the term *)
+          let (sigma,c_interp) = interp_constr ist env sigma c in
+          let let_tac b na c cl eqpat =
+            let id = Option.default (Loc.ghost,IntroAnonymous) eqpat in
+            let with_eq = if b then None else Some (true,id) in
+            Tactics.letin_tac with_eq na c None cl
+          in
+          let na = interp_name ist env sigma na in
+          Tacticals.New.tclWITHHOLES false
+          (name_atomic ~env
+            (TacLetTac(na,c_interp,clp,b,eqpat))
+            (let_tac b na c_interp clp eqpat)) sigma
+        else
+        (* We try to keep the pattern structure as much as possible *)
+          let let_pat_tac b na c cl eqpat =
+            let id = Option.default (Loc.ghost,IntroAnonymous) eqpat in
+            let with_eq = if b then None else Some (true,id) in
+            Tactics.letin_pat_tac with_eq na c cl
+          in
+          let (sigma',c) = interp_pure_open_constr ist env sigma c in
+          name_atomic ~env
+            (TacLetTac(na,c,clp,b,eqpat))
+	    (Tacticals.New.tclWITHHOLES false (*in hope of a future "eset/epose"*)
+               (let_pat_tac b (interp_name ist env sigma na)
+                  ((sigma,sigma'),c) clp eqpat) sigma')
+      end }
+
+  (* Derived basic tactics *)
+  | TacInductionDestruct (isrec,ev,(l,el)) ->
+      (* spiwack: some unknown part of destruct needs the goal to be
+         prenormalised. *)
+      Proofview.Goal.nf_s_enter { s_enter = begin fun gl ->
+        let env = Proofview.Goal.env gl in
+        let sigma = project gl in
+        let sigma,l =
+          List.fold_map begin fun sigma (c,(ipato,ipats),cls) ->
+            (* TODO: move sigma as a side-effect *)
+             (* spiwack: the [*p] variants are for printing *)
+            let cp = c in
+            let c = interp_destruction_arg ist gl c in
+            let ipato = interp_intro_pattern_naming_option ist env sigma ipato in
+            let ipatsp = ipats in
+            let sigma,ipats = interp_or_and_intro_pattern_option ist env sigma ipats in
+            let cls = Option.map (interp_clause ist env sigma) cls in
+            sigma,((c,(ipato,ipats),cls),(cp,(ipato,ipatsp),cls))
+          end sigma l
+        in
+        let l,lp = List.split l in
+        let sigma,el =
+          Option.fold_map (interp_constr_with_bindings ist env) sigma el in
+        let tac = name_atomic ~env
+          (TacInductionDestruct(isrec,ev,(lp,el)))
+            (Tactics.induction_destruct isrec ev (l,el))
+        in
+        Sigma.Unsafe.of_pair (tac, sigma)
+      end }
+
+  (* Conversion *)
+  | TacReduce (r,cl) ->
+      Proofview.Goal.nf_s_enter { s_enter = begin fun gl ->
+        let (sigma,r_interp) = interp_red_expr ist (pf_env gl) (project gl) r in
+        Sigma.Unsafe.of_pair (Tactics.reduce r_interp (interp_clause ist (pf_env gl) (project gl) cl), sigma)
+      end }
+  | TacChange (None,c,cl) ->
+      (* spiwack: until the tactic is in the monad *)
+      Proofview.Trace.name_tactic (fun () -> Pp.str"<change>") begin
+      Proofview.Goal.enter { enter = begin fun gl ->
+        let is_onhyps = match cl.onhyps with
+          | None | Some [] -> true
+          | _ -> false
+        in
+        let is_onconcl = match cl.concl_occs with
+          | AllOccurrences | NoOccurrences -> true
+          | _ -> false
+        in
+        let c_interp patvars = { Sigma.run = begin fun sigma ->
+	  let lfun' = Id.Map.fold (fun id c lfun ->
+	    Id.Map.add id (Value.of_constr c) lfun) 
+	    patvars ist.lfun
+	  in
+	  let sigma = Sigma.to_evar_map sigma in
+	  let ist = { ist with lfun = lfun' } in
+	  let (sigma, c) =
+            if is_onhyps && is_onconcl
+            then interp_type ist (pf_env gl) sigma c
+            else interp_constr ist (pf_env gl) sigma c
+          in
+          Sigma.Unsafe.of_pair (c, sigma)
+        end } in
+        Tactics.change None c_interp (interp_clause ist (pf_env gl) (project gl) cl)
+      end }
+      end
+  | TacChange (Some op,c,cl) ->
+      (* spiwack: until the tactic is in the monad *)
+      Proofview.Trace.name_tactic (fun () -> Pp.str"<change>") begin
+      Proofview.Goal.enter { enter = begin fun gl ->
+        let env = Proofview.Goal.env gl in
+        let sigma = project gl in
+        let op = interp_typed_pattern ist env sigma op in
+        let to_catch = function Not_found -> true | e -> CErrors.is_anomaly e in
+        let c_interp patvars = { Sigma.run = begin fun sigma ->
+          let lfun' = Id.Map.fold (fun id c lfun ->
+            Id.Map.add id (Value.of_constr c) lfun) 
+            patvars ist.lfun
+          in
+          let ist = { ist with lfun = lfun' } in
+            try
+              let sigma = Sigma.to_evar_map sigma in
+              let (sigma, c) = interp_constr ist env sigma c in
+              Sigma.Unsafe.of_pair (c, sigma)
+            with e when to_catch e (* Hack *) ->
+              user_err  (strbrk "Failed to get enough information from the left-hand side to type the right-hand side.")
+        end } in
+        Tactics.change (Some op) c_interp (interp_clause ist env sigma cl)
+      end }
+      end
+
+
+  (* Equality and inversion *)
+  | TacRewrite (ev,l,cl,by) ->
+      Proofview.Goal.enter { enter = begin fun gl ->
+        let l' = List.map (fun (b,m,(keep,c)) ->
+          let f = { delayed = fun env sigma ->
+            let sigma = Sigma.to_evar_map sigma in
+            let (sigma, c) = interp_open_constr_with_bindings ist env sigma c in
+            Sigma.Unsafe.of_pair (c, sigma)
+          } in
+	  (b,m,keep,f)) l in
+        let env = Proofview.Goal.env gl in
+        let sigma = project gl in
+        let cl = interp_clause ist env sigma cl in
+        name_atomic ~env
+          (TacRewrite (ev,l,cl,Option.map ignore by))
+          (Equality.general_multi_rewrite ev l' cl
+             (Option.map (fun by -> Tacticals.New.tclCOMPLETE (interp_tactic ist by),
+               Equality.Naive)
+                by))
+      end }
+  | TacInversion (DepInversion (k,c,ids),hyp) ->
+      Proofview.Goal.enter { enter = begin fun gl ->
+        let env = Proofview.Goal.env gl in
+        let sigma = project gl in
+        let (sigma,c_interp) =
+          match c with
+          | None -> sigma , None
+          | Some c ->
+              let (sigma,c_interp) = interp_constr ist env sigma c in
+              sigma , Some c_interp
+        in
+        let dqhyps = interp_declared_or_quantified_hypothesis ist env sigma hyp in
+        let sigma,ids_interp = interp_or_and_intro_pattern_option ist env sigma ids in
+        Tacticals.New.tclWITHHOLES false
+        (name_atomic ~env
+          (TacInversion(DepInversion(k,c_interp,ids),dqhyps))
+          (Inv.dinv k c_interp ids_interp dqhyps)) sigma
+      end }
+  | TacInversion (NonDepInversion (k,idl,ids),hyp) ->
+      Proofview.Goal.enter { enter = begin fun gl ->
+        let env = Proofview.Goal.env gl in
+        let sigma = project gl in
+        let hyps = interp_hyp_list ist env sigma idl in
+        let dqhyps = interp_declared_or_quantified_hypothesis ist env sigma hyp in
+        let sigma, ids_interp = interp_or_and_intro_pattern_option ist env sigma ids in
+        Tacticals.New.tclWITHHOLES false
+        (name_atomic ~env
+          (TacInversion (NonDepInversion (k,hyps,ids),dqhyps))
+          (Inv.inv_clause k ids_interp hyps dqhyps)) sigma
+      end }
+  | TacInversion (InversionUsing (c,idl),hyp) ->
+      Proofview.Goal.s_enter { s_enter = begin fun gl ->
+        let env = Proofview.Goal.env gl in
+        let sigma = project gl in
+        let (sigma,c_interp) = interp_constr ist env sigma c in
+        let dqhyps = interp_declared_or_quantified_hypothesis ist env sigma hyp in
+        let hyps = interp_hyp_list ist env sigma idl in
+        let tac = name_atomic ~env
+          (TacInversion (InversionUsing (c_interp,hyps),dqhyps))
+          (Leminv.lemInv_clause dqhyps c_interp hyps)
+        in
+        Sigma.Unsafe.of_pair (tac, sigma)
+      end }
+
+(* Initial call for interpretation *)
+
+let default_ist () =
+  let extra = TacStore.set TacStore.empty f_debug (get_debug ()) in
+  { lfun = Id.Map.empty; extra = extra }
+
+let eval_tactic t =
+  Proofview.tclUNIT () >>= fun () -> (* delay for [default_ist] *)
+  Proofview.tclLIFT db_initialize <*>
+  interp_tactic (default_ist ()) t
+
+let eval_tactic_ist ist t =
+  Proofview.tclLIFT db_initialize <*>
+  interp_tactic ist t
+
+(* globalization + interpretation *)
+
+
+let interp_tac_gen lfun avoid_ids debug t =
+  Proofview.Goal.enter { enter = begin fun gl ->
+  let env = Proofview.Goal.env gl in
+  let extra = TacStore.set TacStore.empty f_debug debug in
+  let extra = TacStore.set extra f_avoid_ids avoid_ids in
+  let ist = { lfun = lfun; extra = extra } in
+  let ltacvars = Id.Map.domain lfun in
+  interp_tactic ist
+    (intern_pure_tactic {
+      ltacvars; genv = env } t)
+  end }
+
+let interp t = interp_tac_gen Id.Map.empty [] (get_debug()) t
+
+(* Used to hide interpretation for pretty-print, now just launch tactics *)
+(* [global] means that [t] should be internalized outside of goals. *)
+let hide_interp global t ot =
+  let hide_interp env =
+    let ist = { ltacvars = Id.Set.empty; genv = env } in
+    let te = intern_pure_tactic ist t in
+    let t = eval_tactic te in
+    match ot with
+    | None -> t
+    | Some t' -> Tacticals.New.tclTHEN t t'
+  in
+  if global then
+    Proofview.tclENV >>= fun env ->
+    hide_interp env
+  else
+    Proofview.Goal.enter { enter = begin fun gl ->
+      hide_interp (Proofview.Goal.env gl)
+    end }
+
+(***************************************************************************)
+(** Register standard arguments *)
+
+let register_interp0 wit f =
+  let open Ftactic.Notations in
+  let interp ist v =
+    f ist v >>= fun v -> Ftactic.return (Val.inject (val_tag wit) v)
+  in
+  Geninterp.register_interp0 wit interp
+
+let def_intern ist x = (ist, x)
+let def_subst _ x = x
+let def_interp ist x = Ftactic.return x
+
+let declare_uniform t =
+  Genintern.register_intern0 t def_intern;
+  Genintern.register_subst0 t def_subst;
+  register_interp0 t def_interp
+
+let () =
+  declare_uniform wit_unit
+
+let () =
+  declare_uniform wit_int
+
+let () =
+  declare_uniform wit_bool
+
+let () =
+  declare_uniform wit_string
+
+let lift f = (); fun ist x -> Ftactic.enter { enter = begin fun gl ->
+  let env = Proofview.Goal.env gl in
+  let sigma = Sigma.to_evar_map (Proofview.Goal.sigma gl) in
+  Ftactic.return (f ist env sigma x)
+end }
+
+let lifts f = (); fun ist x -> Ftactic.nf_s_enter { s_enter = begin fun gl ->
+  let env = Proofview.Goal.env gl in
+  let sigma = Sigma.to_evar_map (Proofview.Goal.sigma gl) in
+  let (sigma, v) = f ist env sigma x in
+  Sigma.Unsafe.of_pair (Ftactic.return v, sigma)
+end }
+
+let interp_bindings' ist bl = Ftactic.return { delayed = fun env sigma ->
+  let (sigma, bl) = interp_bindings ist env (Sigma.to_evar_map sigma) bl in
+  Sigma.Unsafe.of_pair (bl, sigma)
+  }
+
+let interp_constr_with_bindings' ist c = Ftactic.return { delayed = fun env sigma ->
+  let (sigma, c) = interp_constr_with_bindings ist env (Sigma.to_evar_map sigma) c in
+  Sigma.Unsafe.of_pair (c, sigma)
+  }
+
+let interp_destruction_arg' ist c = Ftactic.enter { enter = begin fun gl ->
+  Ftactic.return (interp_destruction_arg ist gl c)
+end }
+
+let interp_pre_ident ist env sigma s =
+  s |> Id.of_string |> interp_ident ist env sigma |> Id.to_string
+
+let () =
+  register_interp0 wit_int_or_var (fun ist n -> Ftactic.return (interp_int_or_var ist n));
+  register_interp0 wit_ref (lift interp_reference);
+  register_interp0 wit_pre_ident (lift interp_pre_ident);
+  register_interp0 wit_ident (lift interp_ident);
+  register_interp0 wit_var (lift interp_hyp);
+  register_interp0 wit_intro_pattern (lifts interp_intro_pattern);
+  register_interp0 wit_clause_dft_concl (lift interp_clause);
+  register_interp0 wit_constr (lifts interp_constr);
+  register_interp0 wit_tacvalue (fun ist v -> Ftactic.return v);
+  register_interp0 wit_red_expr (lifts interp_red_expr);
+  register_interp0 wit_quant_hyp (lift interp_declared_or_quantified_hypothesis);
+  register_interp0 wit_open_constr (lifts interp_open_constr);
+  register_interp0 wit_bindings interp_bindings';
+  register_interp0 wit_constr_with_bindings interp_constr_with_bindings';
+  register_interp0 wit_destruction_arg interp_destruction_arg';
+  ()
+
+let () =
+  let interp ist tac = Ftactic.return (Value.of_closure ist tac) in
+  register_interp0 wit_tactic interp
+
+let () =
+  let interp ist tac = interp_tactic ist tac >>= fun () -> Ftactic.return () in
+  register_interp0 wit_ltac interp
+
+let () =
+  register_interp0 wit_uconstr (fun ist c -> Ftactic.enter { enter = begin fun gl ->
+    Ftactic.return (interp_uconstr ist (Proofview.Goal.env gl) (Tacmach.New.project gl) c)
+  end })
+
+(***************************************************************************)
+(* Other entry points *)
+
+let val_interp ist tac k = Ftactic.run (val_interp ist tac) k
+
+let interp_ltac_constr ist c k = Ftactic.run (interp_ltac_constr ist c) k
+
+let interp_redexp env sigma r =
+  let ist = default_ist () in
+  let gist = { fully_empty_glob_sign with genv = env; } in
+  interp_red_expr ist env sigma (intern_red_expr gist r)
+
+(***************************************************************************)
+(* Backwarding recursive needs of tactic glob/interp/eval functions *)
+
+let _ =
+  let eval ty env sigma lfun arg =
+    let ist = { lfun = lfun; extra = TacStore.empty; } in
+    if Genarg.has_type arg (glbwit wit_tactic) then
+      let tac = Genarg.out_gen (glbwit wit_tactic) arg in
+      let tac = interp_tactic ist tac in
+      let (c, sigma) = Pfedit.refine_by_tactic env sigma ty tac in
+      (EConstr.of_constr c, sigma)
+    else
+      failwith "not a tactic"
+  in
+  Hook.set Pretyping.genarg_interp_hook eval
+
+(** Used in tactic extension **)
+
+let dummy_id = Id.of_string "_"
+
+let lift_constr_tac_to_ml_tac vars tac =
+  let tac _ ist = Proofview.Goal.enter { enter = begin fun gl ->
+    let env = Proofview.Goal.env gl in
+    let sigma = project gl in
+    let map = function
+    | Anonymous -> None
+    | Name id ->
+      let c = Id.Map.find id ist.lfun in
+      try Some (coerce_to_closed_constr env c)
+      with CannotCoerceTo ty ->
+        error_ltac_variable Loc.ghost dummy_id (Some (env,sigma)) c ty
+    in
+    let args = List.map_filter map vars in
+    tac args ist
+  end } in
+  tac
+
+let vernac_debug b =
+  set_debug (if b then Tactic_debug.DebugOn 0 else Tactic_debug.DebugOff)
+
+let _ =
+  let open Goptions in
+  declare_bool_option
+    { optsync  = false;
+      optdepr  = false;
+      optname  = "Ltac debug";
+      optkey   = ["Ltac";"Debug"];
+      optread  = (fun () -> get_debug () != Tactic_debug.DebugOff);
+      optwrite = vernac_debug }
+
+let _ =
+  let open Goptions in
+  declare_bool_option
+    { optsync  = false;
+      optdepr  = false;
+      optname  = "Ltac debug";
+      optkey   = ["Debug";"Ltac"];
+      optread  = (fun () -> get_debug () != Tactic_debug.DebugOff);
+      optwrite = vernac_debug }
+
+let () = Hook.set Vernacentries.interp_redexp_hook interp_redexp
diff --git a/plugins/ltac/tacinterp.mli b/plugins/ltac/tacinterp.mli
new file mode 100644
index 000000000..1e5f6bd42
--- /dev/null
+++ b/plugins/ltac/tacinterp.mli
@@ -0,0 +1,123 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+open Names
+open Tactic_debug
+open Term
+open EConstr
+open Tacexpr
+open Genarg
+open Redexpr
+open Misctypes
+
+val ltac_trace_info : ltac_trace Exninfo.t
+
+module Value :
+sig
+  type t = Geninterp.Val.t
+  val of_constr : constr -> t
+  val to_constr : t -> constr option
+  val of_int : int -> t
+  val to_int : t -> int option
+  val to_list : t -> t list option
+  val of_closure : Geninterp.interp_sign -> glob_tactic_expr -> t
+  val cast : 'a typed_abstract_argument_type -> Geninterp.Val.t -> 'a
+end
+
+(** Values for interpretation *)
+type value = Value.t
+
+module TacStore : Store.S with
+  type t = Geninterp.TacStore.t
+  and type 'a field = 'a Geninterp.TacStore.field
+
+(** Signature for interpretation: val\_interp and interpretation functions *)
+type interp_sign = Geninterp.interp_sign = {
+  lfun : value Id.Map.t;
+  extra : TacStore.t }
+
+val f_avoid_ids : Id.t list TacStore.field
+val f_debug : debug_info TacStore.field
+
+val extract_ltac_constr_values : interp_sign -> Environ.env ->
+  Pattern.constr_under_binders Id.Map.t
+(** Given an interpretation signature, extract all values which are coercible to
+    a [constr]. *)
+
+(** Sets the debugger mode *)
+val set_debug : debug_info -> unit
+
+(** Gives the state of debug *)
+val get_debug : unit -> debug_info
+
+(** Adds an interpretation function for extra generic arguments *)
+
+val interp_genarg : interp_sign -> glob_generic_argument -> Value.t Ftactic.t
+
+(** Interprets any expression *)
+val val_interp : interp_sign -> glob_tactic_expr -> (value -> unit Proofview.tactic) -> unit Proofview.tactic
+
+(** Interprets an expression that evaluates to a constr *)
+val interp_ltac_constr : interp_sign -> glob_tactic_expr -> (constr -> unit Proofview.tactic) -> unit Proofview.tactic
+
+(** Interprets redexp arguments *)
+val interp_redexp : Environ.env -> Evd.evar_map -> raw_red_expr -> Evd.evar_map * red_expr
+
+(** Interprets tactic expressions *)
+
+val interp_hyp : interp_sign -> Environ.env -> Evd.evar_map ->
+  Id.t Loc.located -> Id.t
+
+val interp_constr_gen : Pretyping.typing_constraint -> interp_sign ->
+  Environ.env -> Evd.evar_map -> glob_constr_and_expr -> Evd.evar_map * constr
+
+val interp_bindings : interp_sign -> Environ.env -> Evd.evar_map ->
+ glob_constr_and_expr bindings -> Evd.evar_map * constr bindings
+
+val interp_open_constr_with_bindings : interp_sign -> Environ.env -> Evd.evar_map ->
+  glob_constr_and_expr with_bindings -> Evd.evar_map * EConstr.constr with_bindings
+
+(** Initial call for interpretation *)
+
+val eval_tactic : glob_tactic_expr -> unit Proofview.tactic
+
+val eval_tactic_ist : interp_sign -> glob_tactic_expr -> unit Proofview.tactic
+(** Same as [eval_tactic], but with the provided [interp_sign]. *)
+
+val tactic_of_value : interp_sign -> Value.t -> unit Proofview.tactic
+
+(** Globalization + interpretation *)
+
+val interp_tac_gen : value Id.Map.t -> Id.t list ->
+                 debug_info -> raw_tactic_expr -> unit Proofview.tactic
+
+val interp : raw_tactic_expr -> unit Proofview.tactic
+
+(** Hides interpretation for pretty-print *)
+
+val hide_interp : bool -> raw_tactic_expr -> unit Proofview.tactic option -> unit Proofview.tactic
+
+(** Internals that can be useful for syntax extensions. *)
+
+val interp_ltac_var : (value -> 'a) -> interp_sign ->
+  (Environ.env * Evd.evar_map) option -> Id.t Loc.located -> 'a
+
+val interp_int : interp_sign -> Id.t Loc.located -> int
+
+val interp_int_or_var : interp_sign -> int or_var -> int
+
+val error_ltac_variable : Loc.t -> Id.t ->
+  (Environ.env * Evd.evar_map) option -> value -> string -> 'a
+
+(** Transforms a constr-expecting tactic into a tactic finding its arguments in
+    the Ltac environment according to the given names. *)
+val lift_constr_tac_to_ml_tac : Name.t list ->
+  (constr list -> Geninterp.interp_sign -> unit Proofview.tactic) -> Tacenv.ml_tactic
+
+val default_ist : unit -> Geninterp.interp_sign
+(** Empty ist with debug set on the current value. *)
diff --git a/plugins/ltac/tacsubst.ml b/plugins/ltac/tacsubst.ml
new file mode 100644
index 000000000..fe3a9f3b2
--- /dev/null
+++ b/plugins/ltac/tacsubst.ml
@@ -0,0 +1,309 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+open Util
+open Tacexpr
+open Mod_subst
+open Genarg
+open Stdarg
+open Tacarg
+open Misctypes
+open Globnames
+open Term
+open Genredexpr
+open Patternops
+
+(** Substitution of tactics at module closing time *)
+
+(** For generic arguments, we declare and store substitutions
+    in a table *)
+
+let subst_quantified_hypothesis _ x = x
+
+let subst_declared_or_quantified_hypothesis _ x = x
+
+let subst_glob_constr_and_expr subst (c, e) =
+  (Detyping.subst_glob_constr subst c, e)
+
+let subst_glob_constr = subst_glob_constr_and_expr (* shortening *)
+
+let subst_binding subst (loc,b,c) =
+  (loc,subst_quantified_hypothesis subst b,subst_glob_constr subst c)
+
+let subst_bindings subst = function
+  | NoBindings -> NoBindings
+  | ImplicitBindings l -> ImplicitBindings (List.map (subst_glob_constr subst) l)
+  | ExplicitBindings l -> ExplicitBindings (List.map (subst_binding subst) l)
+
+let subst_glob_with_bindings subst (c,bl) =
+  (subst_glob_constr subst c, subst_bindings subst bl)
+
+let subst_glob_with_bindings_arg subst (clear,c) =
+  (clear,subst_glob_with_bindings subst c)
+
+let rec subst_intro_pattern subst = function
+  | loc,IntroAction p -> loc, IntroAction (subst_intro_pattern_action subst p)
+  | loc, IntroNaming _ | loc, IntroForthcoming _ as x -> x
+
+and subst_intro_pattern_action subst = function
+  | IntroApplyOn ((loc,t),pat) ->
+      IntroApplyOn ((loc,subst_glob_constr subst t),subst_intro_pattern subst pat)
+  | IntroOrAndPattern l ->
+      IntroOrAndPattern (subst_intro_or_and_pattern subst l)
+  | IntroInjection l -> IntroInjection (List.map (subst_intro_pattern subst) l)
+  | IntroWildcard | IntroRewrite _ as x -> x
+
+and subst_intro_or_and_pattern subst = function
+  | IntroAndPattern l ->
+      IntroAndPattern (List.map (subst_intro_pattern subst) l)
+  | IntroOrPattern ll ->
+      IntroOrPattern (List.map (List.map (subst_intro_pattern subst)) ll)
+
+let subst_destruction_arg subst = function
+  | clear,ElimOnConstr c -> clear,ElimOnConstr (subst_glob_with_bindings subst c)
+  | clear,ElimOnAnonHyp n as x -> x
+  | clear,ElimOnIdent id as x -> x
+
+let subst_and_short_name f (c,n) =
+(*  assert (n=None); *)(* since tacdef are strictly globalized *)
+  (f c,None)
+
+let subst_or_var f =  function
+  | ArgVar _ as x -> x
+  | ArgArg x -> ArgArg (f x)
+
+let dloc = Loc.ghost
+
+let subst_located f (_loc,id) = (dloc,f id)
+
+let subst_reference subst =
+  subst_or_var (subst_located (subst_kn subst))
+
+(*CSC: subst_global_reference is used "only" for RefArgType, that propagates
+  to the syntactic non-terminals "global", used in commands such as
+  Print. It is also used for non-evaluable references. *)
+open Pp
+open Printer
+
+let subst_global_reference subst =
+ let subst_global ref =
+  let ref',t' = subst_global subst ref in
+   if not (eq_constr (Universes.constr_of_global ref') t') then
+    Feedback.msg_warning (strbrk "The reference " ++ pr_global ref ++ str " is not " ++
+          str " expanded to \"" ++ pr_lconstr t' ++ str "\", but to " ++
+          pr_global ref') ;
+   ref'
+ in
+  subst_or_var (subst_located subst_global)
+
+let subst_evaluable subst =
+  let subst_eval_ref = subst_evaluable_reference subst in
+    subst_or_var (subst_and_short_name subst_eval_ref)
+
+let subst_constr_with_occurrences subst (l,c) = (l,subst_glob_constr subst c)
+
+let subst_glob_constr_or_pattern subst (bvars,c,p) =
+  (bvars,subst_glob_constr subst c,subst_pattern subst p)
+
+let subst_redexp subst =
+  Miscops.map_red_expr_gen
+    (subst_glob_constr subst)
+    (subst_evaluable subst)
+    (subst_glob_constr_or_pattern subst)
+
+let subst_raw_may_eval subst = function
+  | ConstrEval (r,c) -> ConstrEval (subst_redexp subst r,subst_glob_constr subst c)
+  | ConstrContext (locid,c) -> ConstrContext (locid,subst_glob_constr subst c)
+  | ConstrTypeOf c -> ConstrTypeOf (subst_glob_constr subst c)
+  | ConstrTerm c -> ConstrTerm (subst_glob_constr subst c)
+
+let subst_match_pattern subst = function
+  | Subterm (b,ido,pc) -> Subterm (b,ido,(subst_glob_constr_or_pattern subst pc))
+  | Term pc -> Term (subst_glob_constr_or_pattern subst pc)
+
+let rec subst_match_goal_hyps subst = function
+  | Hyp (locs,mp) :: tl ->
+      Hyp (locs,subst_match_pattern subst mp)
+      :: subst_match_goal_hyps subst tl
+  | Def (locs,mv,mp) :: tl ->
+      Def (locs,subst_match_pattern subst mv, subst_match_pattern subst mp)
+      :: subst_match_goal_hyps subst tl
+  | [] -> []
+
+let rec subst_atomic subst (t:glob_atomic_tactic_expr) = match t with
+  (* Basic tactics *)
+  | TacIntroPattern (ev,l) -> TacIntroPattern (ev,List.map (subst_intro_pattern subst) l)
+  | TacApply (a,ev,cb,cl) ->
+      TacApply (a,ev,List.map (subst_glob_with_bindings_arg subst) cb,cl)
+  | TacElim (ev,cb,cbo) ->
+      TacElim (ev,subst_glob_with_bindings_arg subst cb,
+               Option.map (subst_glob_with_bindings subst) cbo)
+  | TacCase (ev,cb) -> TacCase (ev,subst_glob_with_bindings_arg subst cb)
+  | TacMutualFix (id,n,l) ->
+      TacMutualFix(id,n,List.map (fun (id,n,c) -> (id,n,subst_glob_constr subst c)) l)
+  | TacMutualCofix (id,l) ->
+      TacMutualCofix (id, List.map (fun (id,c) -> (id,subst_glob_constr subst c)) l)
+  | TacAssert (b,otac,na,c) ->
+      TacAssert (b,Option.map (Option.map (subst_tactic subst)) otac,na,
+                 subst_glob_constr subst c)
+  | TacGeneralize cl ->
+      TacGeneralize (List.map (on_fst (subst_constr_with_occurrences subst))cl)
+  | TacLetTac (id,c,clp,b,eqpat) ->
+    TacLetTac (id,subst_glob_constr subst c,clp,b,eqpat)
+
+  (* Derived basic tactics *)
+  | TacInductionDestruct (isrec,ev,(l,el)) ->
+      let l' = List.map (fun (c,ids,cls) ->
+        subst_destruction_arg subst c, ids, cls) l in
+      let el' = Option.map (subst_glob_with_bindings subst) el in
+      TacInductionDestruct (isrec,ev,(l',el'))
+
+  (* Conversion *)
+  | TacReduce (r,cl) -> TacReduce (subst_redexp subst r, cl)
+  | TacChange (op,c,cl) ->
+      TacChange (Option.map (subst_glob_constr_or_pattern subst) op,
+        subst_glob_constr subst c, cl)
+
+  (* Equality and inversion *)
+  | TacRewrite (ev,l,cl,by) ->
+      TacRewrite (ev,
+		  List.map (fun (b,m,c) ->
+			      b,m,subst_glob_with_bindings_arg subst c) l,
+		 cl,Option.map (subst_tactic subst) by)
+  | TacInversion (DepInversion (k,c,l),hyp) ->
+     TacInversion (DepInversion (k,Option.map (subst_glob_constr subst) c,l),hyp)
+  | TacInversion (NonDepInversion _,_) as x -> x
+  | TacInversion (InversionUsing (c,cl),hyp) ->
+      TacInversion (InversionUsing (subst_glob_constr subst c,cl),hyp)
+
+and subst_tactic subst (t:glob_tactic_expr) = match t with
+  | TacAtom (_loc,t) -> TacAtom (dloc, subst_atomic subst t)
+  | TacFun tacfun -> TacFun (subst_tactic_fun subst tacfun)
+  | TacLetIn (r,l,u) ->
+      let l = List.map (fun (n,b) -> (n,subst_tacarg subst b)) l in
+      TacLetIn (r,l,subst_tactic subst u)
+  | TacMatchGoal (lz,lr,lmr) ->
+      TacMatchGoal(lz,lr, subst_match_rule subst lmr)
+  | TacMatch (lz,c,lmr) ->
+      TacMatch (lz,subst_tactic subst c,subst_match_rule subst lmr)
+  | TacId _ | TacFail _ as x -> x
+  | TacProgress tac -> TacProgress (subst_tactic subst tac:glob_tactic_expr)
+  | TacShowHyps tac -> TacShowHyps (subst_tactic subst tac:glob_tactic_expr)
+  | TacAbstract (tac,s) -> TacAbstract (subst_tactic subst tac,s)
+  | TacThen (t1,t2) ->
+      TacThen (subst_tactic subst t1, subst_tactic subst t2)
+  | TacDispatch tl -> TacDispatch (List.map (subst_tactic subst) tl)
+  | TacExtendTac (tf,t,tl) ->
+      TacExtendTac (Array.map (subst_tactic subst) tf,
+	            subst_tactic subst t,
+                    Array.map (subst_tactic subst) tl)
+  | TacThens (t,tl) ->
+      TacThens (subst_tactic subst t, List.map (subst_tactic subst) tl)
+  | TacThens3parts (t1,tf,t2,tl) ->
+      TacThens3parts (subst_tactic subst t1,Array.map (subst_tactic subst) tf,
+	       subst_tactic subst t2,Array.map (subst_tactic subst) tl)
+  | TacDo (n,tac) -> TacDo (n,subst_tactic subst tac)
+  | TacTimeout (n,tac) -> TacTimeout (n,subst_tactic subst tac)
+  | TacTime (s,tac) -> TacTime (s,subst_tactic subst tac)
+  | TacTry tac -> TacTry (subst_tactic subst tac)
+  | TacInfo tac -> TacInfo (subst_tactic subst tac)
+  | TacRepeat tac -> TacRepeat (subst_tactic subst tac)
+  | TacOr (tac1,tac2) ->
+      TacOr (subst_tactic subst tac1,subst_tactic subst tac2)
+  | TacOnce tac ->
+      TacOnce (subst_tactic subst tac)
+  | TacExactlyOnce tac ->
+      TacExactlyOnce (subst_tactic subst tac)
+  | TacIfThenCatch (tac,tact,tace) ->
+      TacIfThenCatch (
+        subst_tactic subst tac,
+        subst_tactic subst tact,
+        subst_tactic subst tace)
+  | TacOrelse (tac1,tac2) ->
+      TacOrelse (subst_tactic subst tac1,subst_tactic subst tac2)
+  | TacFirst l -> TacFirst (List.map (subst_tactic subst) l)
+  | TacSolve l -> TacSolve (List.map (subst_tactic subst) l)
+  | TacComplete tac -> TacComplete (subst_tactic subst tac)
+  | TacArg (_,a) -> TacArg (dloc,subst_tacarg subst a)
+  | TacSelect (s, tac) -> TacSelect (s, subst_tactic subst tac)
+
+  (* For extensions *)
+  | TacAlias (_,s,l) ->
+      let s = subst_kn subst s in
+      TacAlias (dloc,s,List.map (subst_tacarg subst) l)
+  | TacML (_loc,opn,l) -> TacML (dloc,opn,List.map (subst_tacarg subst) l)
+
+and subst_tactic_fun subst (var,body) = (var,subst_tactic subst body)
+
+and subst_tacarg subst = function
+  | Reference r -> Reference (subst_reference subst r)
+  | ConstrMayEval c -> ConstrMayEval (subst_raw_may_eval subst c)
+  | TacCall (_loc,f,l) ->
+      TacCall (_loc, subst_reference subst f, List.map (subst_tacarg subst) l)
+  | TacFreshId _ as x -> x
+  | TacPretype c -> TacPretype (subst_glob_constr subst c)
+  | TacNumgoals -> TacNumgoals
+  | Tacexp t -> Tacexp (subst_tactic subst t)
+  | TacGeneric arg -> TacGeneric (subst_genarg subst arg)
+
+(* Reads the rules of a Match Context or a Match *)
+and subst_match_rule subst = function
+  | (All tc)::tl ->
+      (All (subst_tactic subst tc))::(subst_match_rule subst tl)
+  | (Pat (rl,mp,tc))::tl ->
+      let hyps = subst_match_goal_hyps subst rl in
+      let pat = subst_match_pattern subst mp in
+      Pat (hyps,pat,subst_tactic subst tc)
+      ::(subst_match_rule subst tl)
+  | [] -> []
+
+and subst_genarg subst (GenArg (Glbwit wit, x)) =
+  match wit with
+  | ListArg wit ->
+    let map x =
+      let ans = subst_genarg subst (in_gen (glbwit wit) x) in
+      out_gen (glbwit wit) ans
+    in
+    in_gen (glbwit (wit_list wit)) (List.map map x)
+  | OptArg wit ->
+    let ans = match x with
+    | None -> in_gen (glbwit (wit_opt wit)) None
+    | Some x ->
+      let s = out_gen (glbwit wit) (subst_genarg subst (in_gen (glbwit wit) x)) in
+      in_gen (glbwit (wit_opt wit)) (Some s)
+    in
+    ans
+  | PairArg (wit1, wit2) ->
+    let p, q = x in
+    let p = out_gen (glbwit wit1) (subst_genarg subst (in_gen (glbwit wit1) p)) in
+    let q = out_gen (glbwit wit2) (subst_genarg subst (in_gen (glbwit wit2) q)) in
+    in_gen (glbwit (wit_pair wit1 wit2)) (p, q)
+  | ExtraArg s ->
+      Genintern.generic_substitute subst (in_gen (glbwit wit) x)
+
+(** Registering *)
+
+let () =
+  Genintern.register_subst0 wit_int_or_var (fun _ v -> v);
+  Genintern.register_subst0 wit_ref subst_global_reference;
+  Genintern.register_subst0 wit_pre_ident (fun _ v -> v);
+  Genintern.register_subst0 wit_ident (fun _ v -> v);
+  Genintern.register_subst0 wit_var (fun _ v -> v);
+  Genintern.register_subst0 wit_intro_pattern (fun _ v -> v);
+  Genintern.register_subst0 wit_tactic subst_tactic;
+  Genintern.register_subst0 wit_ltac subst_tactic;
+  Genintern.register_subst0 wit_constr subst_glob_constr;
+  Genintern.register_subst0 wit_clause_dft_concl (fun _ v -> v);
+  Genintern.register_subst0 wit_uconstr (fun subst c -> subst_glob_constr subst c);
+  Genintern.register_subst0 wit_open_constr (fun subst c -> subst_glob_constr subst c);
+  Genintern.register_subst0 wit_red_expr subst_redexp;
+  Genintern.register_subst0 wit_quant_hyp subst_declared_or_quantified_hypothesis;
+  Genintern.register_subst0 wit_bindings subst_bindings;
+  Genintern.register_subst0 wit_constr_with_bindings subst_glob_with_bindings;
+  Genintern.register_subst0 wit_destruction_arg subst_destruction_arg;
+  ()
diff --git a/plugins/ltac/tacsubst.mli b/plugins/ltac/tacsubst.mli
new file mode 100644
index 000000000..c1bf27257
--- /dev/null
+++ b/plugins/ltac/tacsubst.mli
@@ -0,0 +1,30 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+open Tacexpr
+open Mod_subst
+open Genarg
+open Misctypes
+
+(** Substitution of tactics at module closing time *)
+
+val subst_tactic : substitution -> glob_tactic_expr -> glob_tactic_expr
+
+(** For generic arguments, we declare and store substitutions
+    in a table *)
+
+val subst_genarg : substitution -> glob_generic_argument -> glob_generic_argument
+
+(** Misc *)
+
+val subst_glob_constr_and_expr :
+  substitution -> glob_constr_and_expr -> glob_constr_and_expr
+
+val subst_glob_with_bindings : substitution ->
+  glob_constr_and_expr with_bindings ->
+  glob_constr_and_expr with_bindings
diff --git a/plugins/ltac/tactic_debug.ml b/plugins/ltac/tactic_debug.ml
new file mode 100644
index 000000000..b2601ad32
--- /dev/null
+++ b/plugins/ltac/tactic_debug.ml
@@ -0,0 +1,422 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+open Util
+open Names
+open Pp
+open Tacexpr
+open Termops
+open Nameops
+open Proofview.Notations
+
+
+let (ltac_trace_info : ltac_trace Exninfo.t) = Exninfo.make ()
+
+let prtac x =
+  Pptactic.pr_glob_tactic (Global.env()) x
+let prmatchpatt env sigma hyp =
+  Pptactic.pr_match_pattern (Printer.pr_constr_pattern_env env sigma) hyp
+let prmatchrl rl =
+  Pptactic.pr_match_rule false (Pptactic.pr_glob_tactic (Global.env()))
+    (fun (_,p) -> Printer.pr_constr_pattern p) rl
+
+(* This module intends to be a beginning of debugger for tactic expressions.
+   Currently, it is quite simple and we can hope to have, in the future, a more
+   complete panel of commands dedicated to a proof assistant framework *)
+
+(* Debug information *)
+type debug_info =
+  | DebugOn of int
+  | DebugOff
+
+(* An exception handler *)
+let explain_logic_error e =
+  CErrors.print (fst (ExplainErr.process_vernac_interp_error (e, Exninfo.null)))
+
+let explain_logic_error_no_anomaly e =
+  CErrors.print_no_report
+    (fst (ExplainErr.process_vernac_interp_error (e, Exninfo.null)))
+
+let msg_tac_debug s = Proofview.NonLogical.print_debug (s++fnl())
+let msg_tac_notice s = Proofview.NonLogical.print_notice (s++fnl())
+
+(* Prints the goal *)
+
+let db_pr_goal gl =
+  let env = Proofview.Goal.env gl in
+  let concl = Proofview.Goal.concl gl in
+  let penv = print_named_context env in
+  let pc = print_constr_env env (Tacmach.New.project gl) concl in
+    str"  " ++ hv 0 (penv ++ fnl () ++
+                   str "============================" ++ fnl ()  ++
+                   str" "  ++ pc) ++ fnl ()
+
+let db_pr_goal =
+  Proofview.Goal.nf_enter { enter = begin fun gl ->
+  let pg = db_pr_goal gl in
+  Proofview.tclLIFT (msg_tac_notice (str "Goal:" ++ fnl () ++ pg))
+  end }
+
+
+(* Prints the commands *)
+let help () =
+  msg_tac_debug (str "Commands: <Enter> = Continue" ++ fnl() ++
+         str "          h/? = Help" ++ fnl() ++
+         str "          r <num> = Run <num> times" ++ fnl() ++
+         str "          r <string> = Run up to next idtac <string>" ++ fnl() ++
+         str "          s = Skip" ++ fnl() ++
+         str "          x = Exit")
+
+(* Prints the goal and the command to be executed *)
+let goal_com tac =
+  Proofview.tclTHEN
+    db_pr_goal
+    (Proofview.tclLIFT (msg_tac_debug (str "Going to execute:" ++ fnl () ++ prtac tac)))
+
+(* [run (new_ref _)] gives us a ref shared among [NonLogical.t]
+   expressions. It avoids parametrizing everything over a
+   reference. *)
+let skipped = Proofview.NonLogical.run (Proofview.NonLogical.ref 0)
+let skip = Proofview.NonLogical.run (Proofview.NonLogical.ref 0)
+let breakpoint = Proofview.NonLogical.run (Proofview.NonLogical.ref None)
+
+let rec drop_spaces inst i =
+  if String.length inst > i && inst.[i] == ' ' then drop_spaces inst (i+1)
+  else i
+
+let possibly_unquote s =
+  if String.length s >= 2 && s.[0] == '"' && s.[String.length s - 1] == '"' then
+    String.sub s 1 (String.length s - 2)
+  else
+    s
+
+(* (Re-)initialize debugger *)
+let db_initialize =
+  let open Proofview.NonLogical in
+  (skip:=0) >> (skipped:=0) >> (breakpoint:=None)
+
+let int_of_string s =
+  try Proofview.NonLogical.return (int_of_string s)
+  with e -> Proofview.NonLogical.raise e
+
+let string_get s i =
+  try Proofview.NonLogical.return (String.get s i)
+  with e -> Proofview.NonLogical.raise e
+
+(* Gives the number of steps or next breakpoint of a run command *)
+let run_com inst =
+  let open Proofview.NonLogical in
+  string_get inst 0 >>= fun first_char ->
+  if first_char ='r' then
+    let i = drop_spaces inst 1 in
+    if String.length inst > i then
+      let s = String.sub inst i (String.length inst - i) in
+      if inst.[0] >= '0' && inst.[0] <= '9' then
+        int_of_string s >>= fun num ->
+        (if num<0 then invalid_arg "run_com" else return ()) >>
+        (skip:=num) >> (skipped:=0)
+      else
+        breakpoint:=Some (possibly_unquote s)
+    else
+      invalid_arg "run_com"
+  else
+    invalid_arg "run_com"
+
+(* Prints the run counter *)
+let run ini =
+  let open Proofview.NonLogical in
+  if not ini then
+    begin
+      Proofview.NonLogical.print_notice (str"\b\r\b\r") >>
+      !skipped >>= fun skipped ->
+      msg_tac_debug (str "Executed expressions: " ++ int skipped ++ fnl())
+    end >>
+    !skipped >>= fun x ->
+    skipped := x+1
+  else
+    return ()
+
+(* Prints the prompt *)
+let rec prompt level =
+  (* spiwack: avoid overriding by the open below *)
+  let runtrue = run true in
+  begin
+    let open Proofview.NonLogical in
+    Proofview.NonLogical.print_notice (fnl () ++ str "TcDebug (" ++ int level ++ str ") > ") >>
+    let exit = (skip:=0) >> (skipped:=0) >> raise Sys.Break in
+    Proofview.NonLogical.catch Proofview.NonLogical.read_line
+      begin function (e, info) -> match e with
+        | End_of_file -> exit
+        | e -> raise ~info e
+      end
+    >>= fun inst ->
+    match inst with
+    | ""  -> return (DebugOn (level+1))
+    | "s" -> return (DebugOff)
+    | "x" -> Proofview.NonLogical.print_char '\b' >> exit
+    | "h"| "?" ->
+      begin
+        help () >>
+        prompt level
+      end
+    | _ ->
+        Proofview.NonLogical.catch (run_com inst >> runtrue >> return (DebugOn (level+1)))
+          begin function (e, info) -> match e with
+            | Failure _ | Invalid_argument _ -> prompt level
+            | e -> raise ~info e
+          end
+  end
+
+(* Prints the state and waits for an instruction *)
+(* spiwack: the only reason why we need to take the continuation [f]
+   as an argument rather than returning the new level directly seems to
+   be that [f] is wrapped in with "explain_logic_error". I don't think
+   it serves any purpose in the current design, so we could just drop
+   that. *)
+let debug_prompt lev tac f =
+  (* spiwack: avoid overriding by the open below *)
+  let runfalse = run false in
+  let open Proofview.NonLogical in
+  let (>=) = Proofview.tclBIND in
+  (* What to print and to do next *)
+  let newlevel =
+    Proofview.tclLIFT !skip >= fun initial_skip ->
+    if Int.equal initial_skip 0 then
+      Proofview.tclLIFT !breakpoint >= fun breakpoint ->
+      if Option.is_empty breakpoint then Proofview.tclTHEN (goal_com tac) (Proofview.tclLIFT (prompt lev))
+      else Proofview.tclLIFT(runfalse >> return (DebugOn (lev+1)))
+    else Proofview.tclLIFT begin
+      (!skip >>= fun s -> skip:=s-1) >>
+      runfalse >>
+      !skip >>= fun new_skip ->
+      (if Int.equal new_skip 0 then skipped:=0 else return ()) >>
+      return (DebugOn (lev+1))
+    end in
+  newlevel >= fun newlevel ->
+  (* What to execute *)
+  Proofview.tclOR
+    (f newlevel)
+    begin fun (reraise, info) ->
+      Proofview.tclTHEN
+        (Proofview.tclLIFT begin
+          (skip:=0) >> (skipped:=0) >>
+            if Logic.catchable_exception reraise then
+              msg_tac_debug (str "Level " ++ int lev ++ str ": " ++ explain_logic_error reraise)
+            else return ()
+        end)
+        (Proofview.tclZERO ~info reraise)
+    end
+
+let is_debug db =
+  let open Proofview.NonLogical in
+  !breakpoint >>= fun breakpoint ->
+  match db, breakpoint with
+  | DebugOff, _ -> return false
+  | _, Some _ -> return false
+  | _ ->
+      !skip >>= fun skip ->
+      return (Int.equal skip 0)
+
+(* Prints a constr *)
+let db_constr debug env sigma c =
+  let open Proofview.NonLogical in
+  is_debug debug >>= fun db ->
+  if db then
+    msg_tac_debug (str "Evaluated term: " ++ print_constr_env env sigma c)
+  else return ()
+
+(* Prints the pattern rule *)
+let db_pattern_rule debug num r =
+  let open Proofview.NonLogical in
+  is_debug debug >>= fun db ->
+  if db then
+  begin
+    msg_tac_debug (str "Pattern rule " ++ int num ++ str ":" ++ fnl () ++
+      str "|" ++ spc () ++ prmatchrl r)
+  end
+  else return ()
+
+(* Prints the hypothesis pattern identifier if it exists *)
+let hyp_bound = function
+  | Anonymous -> str " (unbound)"
+  | Name id -> str " (bound to " ++ pr_id id ++ str ")"
+
+(* Prints a matched hypothesis *)
+let db_matched_hyp debug env sigma (id,_,c) ido =
+  let open Proofview.NonLogical in
+  is_debug debug >>= fun db ->
+  if db then
+    msg_tac_debug (str "Hypothesis " ++ pr_id id ++ hyp_bound ido ++
+                str " has been matched: " ++ print_constr_env env sigma c)
+  else return ()
+
+(* Prints the matched conclusion *)
+let db_matched_concl debug env sigma c =
+  let open Proofview.NonLogical in
+  is_debug debug >>= fun db ->
+  if db then
+    msg_tac_debug (str "Conclusion has been matched: " ++ print_constr_env env sigma c)
+  else return ()
+
+(* Prints a success message when the goal has been matched *)
+let db_mc_pattern_success debug =
+  let open Proofview.NonLogical in
+  is_debug debug >>= fun db ->
+  if db then
+    msg_tac_debug (str "The goal has been successfully matched!" ++ fnl() ++
+           str "Let us execute the right-hand side part..." ++ fnl())
+  else return ()
+
+(* Prints a failure message for an hypothesis pattern *)
+let db_hyp_pattern_failure debug env sigma (na,hyp) =
+  let open Proofview.NonLogical in
+  is_debug debug >>= fun db ->
+  if db then
+    msg_tac_debug (str "The pattern hypothesis" ++ hyp_bound na ++
+                str " cannot match: " ++
+           prmatchpatt env sigma hyp)
+  else return ()
+
+(* Prints a matching failure message for a rule *)
+let db_matching_failure debug =
+  let open Proofview.NonLogical in
+  is_debug debug >>= fun db ->
+  if db then
+    msg_tac_debug (str "This rule has failed due to matching errors!" ++ fnl() ++
+           str "Let us try the next one...")
+  else return ()
+
+(* Prints an evaluation failure message for a rule *)
+let db_eval_failure debug s =
+  let open Proofview.NonLogical in
+  is_debug debug >>= fun db ->
+  if db then
+    let s = str "message \"" ++ s ++ str "\"" in
+    msg_tac_debug
+      (str "This rule has failed due to \"Fail\" tactic (" ++
+       s ++ str ", level 0)!" ++ fnl() ++ str "Let us try the next one...")
+  else return ()
+
+(* Prints a logic failure message for a rule *)
+let db_logic_failure debug err =
+  let open Proofview.NonLogical in
+  is_debug debug >>= fun db ->
+  if db then
+  begin
+    msg_tac_debug (explain_logic_error err) >>
+    msg_tac_debug (str "This rule has failed due to a logic error!" ++ fnl() ++
+           str "Let us try the next one...")
+  end
+  else return ()
+
+let is_breakpoint brkname s = match brkname, s with
+  | Some s, MsgString s'::_ -> String.equal s s'
+  | _ -> false
+
+let db_breakpoint debug s =
+  let open Proofview.NonLogical in
+  !breakpoint >>= fun opt_breakpoint ->
+  match debug with
+  | DebugOn lev when not (CList.is_empty s) && is_breakpoint opt_breakpoint s ->
+      breakpoint:=None
+  | _ ->
+      return ()
+
+(** Extrating traces *)
+
+let is_defined_ltac trace =
+  let rec aux = function
+  | (_, Tacexpr.LtacNameCall f) :: _ -> not (Tacenv.is_ltac_for_ml_tactic f)
+  | (_, Tacexpr.LtacNotationCall f) :: _ -> true
+  | (_, Tacexpr.LtacAtomCall _) :: _ -> false
+  | _ :: tail -> aux tail
+  | [] -> false in
+  aux (List.rev trace)
+
+let explain_ltac_call_trace last trace loc =
+  let calls = last :: List.rev_map snd trace in
+  let pr_call ck = match ck with
+    | Tacexpr.LtacNotationCall kn -> quote (Pptactic.pr_alias_key kn)
+  | Tacexpr.LtacNameCall cst -> quote (Pptactic.pr_ltac_constant cst)
+  | Tacexpr.LtacMLCall t ->
+      quote (Pptactic.pr_glob_tactic (Global.env()) t)
+  | Tacexpr.LtacVarCall (id,t) ->
+      quote (Nameops.pr_id id) ++ strbrk " (bound to " ++
+        Pptactic.pr_glob_tactic (Global.env()) t ++ str ")"
+  | Tacexpr.LtacAtomCall te ->
+      quote (Pptactic.pr_glob_tactic (Global.env())
+              (Tacexpr.TacAtom (Loc.ghost,te)))
+  | Tacexpr.LtacConstrInterp (c, { Pretyping.ltac_constrs = vars }) ->
+      quote (Printer.pr_glob_constr_env (Global.env()) c) ++
+        (if not (Id.Map.is_empty vars) then
+          strbrk " (with " ++
+            prlist_with_sep pr_comma
+            (fun (id,c) ->
+                pr_id id ++ str ":=" ++ Printer.pr_lconstr_under_binders c)
+            (List.rev (Id.Map.bindings vars)) ++ str ")"
+        else mt())
+  in
+  match calls with
+  | [] -> mt ()
+  | [a] -> hov 0 (str "Ltac call to " ++ pr_call a ++ str " failed.")
+  | _ ->
+    let kind_of_last_call = match List.last calls with
+    | Tacexpr.LtacConstrInterp _ -> ", last term evaluation failed."
+    | _ -> ", last call failed."
+    in
+    hov 0 (str "In nested Ltac calls to " ++
+           pr_enum pr_call calls ++ strbrk kind_of_last_call)
+
+let skip_extensions trace =
+  let rec aux = function
+  | (_,Tacexpr.LtacNameCall f as tac) :: _
+       when Tacenv.is_ltac_for_ml_tactic f -> [tac]
+  | (_,Tacexpr.LtacNotationCall _ as tac) :: (_,Tacexpr.LtacMLCall _) :: _ ->
+     (* Case of an ML defined tactic with entry of the form <<"foo" args>> *)
+     (* see tacextend.mlp *)
+     [tac]
+  | (_,Tacexpr.LtacMLCall _ as tac) :: _ -> [tac]
+  | t :: tail -> t :: aux tail
+  | [] -> [] in
+  List.rev (aux (List.rev trace))
+
+let finer_loc loc1 loc2 = Loc.merge loc1 loc2 = loc2
+
+let extract_ltac_trace trace eloc =
+  let trace = skip_extensions trace in
+  let (loc,c),tail = List.sep_last trace in
+  if is_defined_ltac trace then
+    (* We entered a user-defined tactic,
+       we display the trace with location of the call *)
+    let msg = hov 0 (explain_ltac_call_trace c tail eloc ++ fnl()) in
+    Some msg, if finer_loc eloc loc then eloc else loc
+  else
+    (* We entered a primitive tactic, we don't display trace but
+       report on the finest location *)
+    let best_loc =
+      (* trace is with innermost call coming first *)
+      let rec aux best_loc = function
+        | (loc,_)::tail ->
+           if Loc.is_ghost best_loc ||
+              not (Loc.is_ghost loc) && finer_loc loc best_loc
+           then
+             aux loc tail
+           else
+             aux best_loc tail
+        | [] -> best_loc in
+        aux eloc trace in
+    None, best_loc
+
+let get_ltac_trace (_, info) =
+  let ltac_trace = Exninfo.get info ltac_trace_info in
+  let loc = Option.default Loc.ghost (Loc.get_loc info) in
+  match ltac_trace with
+  | None -> None
+  | Some trace -> Some (extract_ltac_trace trace loc)
+
+let () = ExplainErr.register_additional_error_info get_ltac_trace
diff --git a/plugins/ltac/tactic_debug.mli b/plugins/ltac/tactic_debug.mli
new file mode 100644
index 000000000..7745d9b7b
--- /dev/null
+++ b/plugins/ltac/tactic_debug.mli
@@ -0,0 +1,81 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+open Environ
+open Pattern
+open Names
+open Tacexpr
+open Term
+open EConstr
+open Evd
+
+(** TODO: Move those definitions somewhere sensible *)
+
+val ltac_trace_info : ltac_trace Exninfo.t
+
+(** This module intends to be a beginning of debugger for tactic expressions.
+   Currently, it is quite simple and we can hope to have, in the future, a more
+   complete panel of commands dedicated to a proof assistant framework *)
+
+(** Debug information *)
+type debug_info =
+  | DebugOn of int
+  | DebugOff
+
+(** Prints the state and waits *)
+val debug_prompt :
+  int -> glob_tactic_expr -> (debug_info -> 'a Proofview.tactic) -> 'a Proofview.tactic
+
+(** Initializes debugger *)
+val db_initialize : unit Proofview.NonLogical.t
+
+(** Prints a constr *)
+val db_constr : debug_info -> env -> evar_map -> constr -> unit Proofview.NonLogical.t
+
+(** Prints the pattern rule *)
+val db_pattern_rule :
+  debug_info -> int -> (Tacexpr.glob_constr_and_expr * constr_pattern,glob_tactic_expr) match_rule -> unit Proofview.NonLogical.t
+
+(** Prints a matched hypothesis *)
+val db_matched_hyp :
+  debug_info -> env -> evar_map -> Id.t * constr option * constr -> Name.t -> unit Proofview.NonLogical.t
+
+(** Prints the matched conclusion *)
+val db_matched_concl : debug_info -> env -> evar_map -> constr -> unit Proofview.NonLogical.t
+
+(** Prints a success message when the goal has been matched *)
+val db_mc_pattern_success : debug_info -> unit Proofview.NonLogical.t
+
+(** Prints a failure message for an hypothesis pattern *)
+val db_hyp_pattern_failure :
+  debug_info -> env -> evar_map -> Name.t * constr_pattern match_pattern -> unit Proofview.NonLogical.t
+
+(** Prints a matching failure message for a rule *)
+val db_matching_failure : debug_info -> unit Proofview.NonLogical.t
+
+(** Prints an evaluation failure message for a rule *)
+val db_eval_failure : debug_info -> Pp.std_ppcmds -> unit Proofview.NonLogical.t
+
+(** An exception handler *)
+val explain_logic_error: exn -> Pp.std_ppcmds
+
+(** For use in the Ltac debugger: some exception that are usually
+   consider anomalies are acceptable because they are caught later in
+   the process that is being debugged.  One should not require
+   from users that they report these anomalies. *)
+val explain_logic_error_no_anomaly : exn -> Pp.std_ppcmds
+
+(** Prints a logic failure message for a rule *)
+val db_logic_failure : debug_info -> exn -> unit Proofview.NonLogical.t
+
+(** Prints a logic failure message for a rule *)
+val db_breakpoint : debug_info ->
+  Id.t Loc.located message_token list -> unit Proofview.NonLogical.t
+
+val extract_ltac_trace :
+  Tacexpr.ltac_trace -> Loc.t -> Pp.std_ppcmds option * Loc.t
diff --git a/plugins/ltac/tactic_matching.ml b/plugins/ltac/tactic_matching.ml
new file mode 100644
index 000000000..5b5cd06cc
--- /dev/null
+++ b/plugins/ltac/tactic_matching.ml
@@ -0,0 +1,377 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(** This file extends Matching with the main logic for Ltac's
+    (lazy)match and (lazy)match goal. *)
+
+open Names
+open Tacexpr
+open Context.Named.Declaration
+
+module NamedDecl = Context.Named.Declaration
+
+(** [t] is the type of matching successes. It ultimately contains a
+    {!Tacexpr.glob_tactic_expr} representing the left-hand side of the
+    corresponding matching rule, a matching substitution to be
+    applied, a context substitution mapping identifier to context like
+    those of {!Matching.matching_result}), and a {!Term.constr}
+    substitution mapping corresponding to matched hypotheses. *)
+type 'a t = {
+  subst : Constr_matching.bound_ident_map * Pattern.extended_patvar_map ;
+  context : EConstr.constr Id.Map.t;
+  terms : EConstr.constr Id.Map.t;
+  lhs : 'a;
+}
+
+
+
+(** {6 Utilities} *)
+
+
+(** Some of the functions of {!Matching} return the substitution with a
+    [patvar_map] instead of an [extended_patvar_map]. [adjust] coerces
+    substitution of the former type to the latter. *)
+let adjust : Constr_matching.bound_ident_map * Pattern.patvar_map ->
+             Constr_matching.bound_ident_map * Pattern.extended_patvar_map =
+  fun (l, lc) -> (l, Id.Map.map (fun c -> [], c) lc)
+
+
+(** Adds a binding to a {!Id.Map.t} if the identifier is [Some id] *)
+let id_map_try_add id x m =
+  match id with
+  | Some id -> Id.Map.add id x m
+  | None -> m
+
+(** Adds a binding to a {!Id.Map.t} if the name is [Name id] *)
+let id_map_try_add_name id x m =
+  match id with
+  | Name id -> Id.Map.add id x m
+  | Anonymous -> m
+
+(** Takes the union of two {!Id.Map.t}. If there is conflict,
+    the binding of the right-hand argument shadows that of the left-hand
+    argument. *)
+let id_map_right_biased_union m1 m2 =
+  if Id.Map.is_empty m1 then m2 (** Don't reconstruct the whole map *)
+  else Id.Map.fold Id.Map.add m2 m1
+
+(** Tests whether the substitution [s] is empty. *)
+let is_empty_subst (ln,lm) =
+  Id.Map.(is_empty ln && is_empty lm)
+
+(** {6 Non-linear patterns} *)
+
+
+(** The patterns of Ltac are not necessarily linear. Non-linear
+    pattern are partially handled by the {!Matching} module, however
+    goal patterns are not primitive to {!Matching}, hence we must deal
+    with non-linearity between hypotheses and conclusion. Subterms are
+    considered equal up to the equality implemented in
+    [equal_instances]. *)
+(* spiwack: it doesn't seem to be quite the same rule for non-linear
+   term patterns and non-linearity between hypotheses and/or
+   conclusion. Indeed, in [Matching], matching is made modulo
+   syntactic equality, and here we merge modulo conversion. It may be
+   a good idea to have an entry point of [Matching] with a partial
+   substitution as argument instead of merging substitution here. That
+   would ensure consistency. *)
+let equal_instances env sigma (ctx',c') (ctx,c) =
+  (* How to compare instances? Do we want the terms to be convertible?
+     unifiable? Do we want the universe levels to be relevant? 
+     (historically, conv_x is used) *)
+  CList.equal Id.equal ctx ctx' && Reductionops.is_conv env sigma c' c
+
+
+(** Merges two substitutions. Raises [Not_coherent_metas] when
+    encountering two instances of the same metavariable which are not
+    equal according to {!equal_instances}. *)
+exception Not_coherent_metas
+let verify_metas_coherence env sigma (ln1,lcm) (ln,lm) =
+  let merge id oc1 oc2 = match oc1, oc2 with
+    | None, None -> None
+    | None, Some c | Some c, None -> Some c
+    | Some c1, Some c2 ->
+        if equal_instances env sigma c1 c2 then Some c1
+        else raise Not_coherent_metas
+  in
+  let (+++) lfun1 lfun2 = Id.Map.fold Id.Map.add lfun1 lfun2 in
+  (** ppedrot: Is that even correct? *)
+  let merged = ln +++ ln1 in
+  (merged, Id.Map.merge merge lcm lm)
+
+let matching_error =
+  CErrors.UserError (Some "tactic matching" , Pp.str "No matching clauses for match.")
+
+let imatching_error = (matching_error, Exninfo.null)
+
+(** A functor is introduced to share the environment and the
+    evar_map. They do not change and it would be a pity to introduce
+    closures everywhere just for the occasional calls to
+    {!equal_instances}. *)
+module type StaticEnvironment = sig
+  val env : Environ.env
+  val sigma : Evd.evar_map
+end
+module PatternMatching (E:StaticEnvironment) = struct
+
+
+  (** {6 The pattern-matching monad } *)
+
+
+  (** To focus on the algorithmic portion of pattern-matching, the
+      bookkeeping is relegated to a monad: the composition of the
+      bactracking monad of {!IStream.t} with a "writer" effect. *)
+  (* spiwack: as we don't benefit from the various stream optimisations
+     of Haskell, it may be costly to give the monad in direct style such as
+     here. We may want to use some continuation passing style. *)
+  type 'a tac = 'a Proofview.tactic
+  type 'a m = { stream : 'r. ('a -> unit t -> 'r tac) -> unit t -> 'r tac }
+
+  (** The empty substitution. *)
+  let empty_subst = Id.Map.empty , Id.Map.empty
+
+  (** Composes two substitutions using {!verify_metas_coherence}. It
+      must be a monoid with neutral element {!empty_subst}. Raises
+      [Not_coherent_metas] when composition cannot be achieved. *)
+  let subst_prod s1 s2 =
+    if is_empty_subst s1 then s2
+    else if is_empty_subst s2 then s1
+    else verify_metas_coherence E.env E.sigma s1 s2
+
+  (** The empty context substitution. *)
+  let empty_context_subst = Id.Map.empty
+
+  (** Compose two context substitutions, in case of conflict the
+      right hand substitution shadows the left hand one. *)
+  let context_subst_prod = id_map_right_biased_union
+
+  (** The empty term substitution. *)
+  let empty_term_subst = Id.Map.empty
+
+  (** Compose two terms substitutions, in case of conflict the
+      right hand substitution shadows the left hand one. *)
+  let term_subst_prod = id_map_right_biased_union
+
+  (** Merge two writers (and ignore the first value component). *)
+  let merge m1 m2 =
+    try Some {
+      subst = subst_prod m1.subst m2.subst;
+      context = context_subst_prod m1.context m2.context;
+      terms = term_subst_prod m1.terms m2.terms;
+      lhs = m2.lhs;
+    }
+    with Not_coherent_metas -> None
+
+  (** Monadic [return]: returns a single success with empty substitutions. *)
+  let return (type a) (lhs:a) : a m =
+    { stream = fun k ctx -> k lhs ctx }
+
+  (** Monadic bind: each success of [x] is replaced by the successes
+      of [f x]. The substitutions of [x] and [f x] are composed,
+      dropping the apparent successes when the substitutions are not
+      coherent. *)
+  let (>>=) (type a) (type b) (m:a m) (f:a -> b m) : b m =
+    { stream = fun k ctx -> m.stream (fun x ctx -> (f x).stream k ctx) ctx }
+
+  (** A variant of [(>>=)] when the first argument returns [unit]. *)
+  let (<*>) (type a) (m:unit m) (y:a m) : a m =
+    { stream = fun k ctx -> m.stream (fun () ctx -> y.stream k ctx) ctx }
+
+  (** Failure of the pattern-matching monad: no success. *)
+  let fail (type a) : a m = { stream = fun _ _ -> Proofview.tclZERO matching_error }
+
+  let run (m : 'a m) =
+    let ctx = {
+      subst = empty_subst ;
+      context = empty_context_subst ;
+      terms = empty_term_subst ;
+      lhs = ();
+    } in
+    let eval lhs ctx = Proofview.tclUNIT { ctx with lhs } in
+    m.stream eval ctx
+
+  (** Chooses in a list, in the same order as the list *)
+  let rec pick (l:'a list) (e, info) : 'a m = match l with
+  | [] -> { stream = fun _ _ -> Proofview.tclZERO ~info e }
+  | x :: l ->
+    { stream = fun k ctx -> Proofview.tclOR (k x ctx) (fun e -> (pick l e).stream k ctx) }
+
+  let pick l = pick l imatching_error
+
+  (** Declares a subsitution, a context substitution and a term substitution. *)
+  let put subst context terms : unit m =
+    let s = { subst ; context ; terms ; lhs = () } in
+    { stream = fun k ctx -> match merge s ctx with None -> Proofview.tclZERO matching_error | Some s -> k () s }
+
+  (** Declares a substitution. *)
+  let put_subst subst : unit m = put subst empty_context_subst empty_term_subst
+
+  (** Declares a term substitution. *)
+  let put_terms terms : unit m = put empty_subst empty_context_subst terms
+
+
+
+  (** {6 Pattern-matching} *)
+
+
+  (** [wildcard_match_term lhs] matches a term against a wildcard
+      pattern ([_ => lhs]). It has a single success with an empty
+      substitution. *)
+  let wildcard_match_term = return
+
+  (** [pattern_match_term refresh pat term lhs] returns the possible
+      matchings of [term] with the pattern [pat => lhs]. If refresh is
+      true, refreshes the universes of [term]. *)
+  let pattern_match_term refresh pat term lhs = 
+(*     let term = if refresh then Termops.refresh_universes_strict term else term in *)
+    match pat with
+    | Term p ->
+        begin 
+          try
+            put_subst (Constr_matching.extended_matches E.env E.sigma p term) <*>
+            return lhs
+          with Constr_matching.PatternMatchingFailure -> fail
+        end
+    | Subterm (with_app_context,id_ctxt,p) ->
+
+      let rec map s (e, info) =
+        { stream = fun k ctx -> match IStream.peek s with
+          | IStream.Nil -> Proofview.tclZERO ~info e
+          | IStream.Cons ({ Constr_matching.m_sub ; m_ctx }, s) ->
+            let subst = adjust m_sub in
+            let context = id_map_try_add id_ctxt m_ctx Id.Map.empty in
+            let terms = empty_term_subst in
+            let nctx = { subst ; context ; terms ; lhs = () } in
+            match merge ctx nctx with
+            | None -> (map s (e, info)).stream k ctx
+            | Some nctx -> Proofview.tclOR (k lhs nctx) (fun e -> (map s e).stream k ctx)
+        }
+      in
+      map (Constr_matching.match_subterm_gen E.env E.sigma with_app_context p term) imatching_error
+
+
+  (** [rule_match_term term rule] matches the term [term] with the
+      matching rule [rule]. *)
+  let rule_match_term term = function
+    | All lhs -> wildcard_match_term lhs
+    | Pat ([],pat,lhs) -> pattern_match_term false pat term lhs
+    | Pat _ ->
+        (** Rules with hypotheses, only work in match goal. *)
+        fail
+
+  (** [match_term term rules] matches the term [term] with the set of
+      matching rules [rules].*)
+  let rec match_term (e, info) term rules = match rules with
+  | [] -> { stream = fun _ _ -> Proofview.tclZERO ~info e }
+  | r :: rules ->
+    { stream = fun k ctx ->
+      let head = rule_match_term term r in
+      let tail e = match_term e term rules in
+      Proofview.tclOR (head.stream k ctx) (fun e -> (tail e).stream k ctx)
+    }
+
+
+  (** [hyp_match_type hypname pat hyps] matches a single
+      hypothesis pattern [hypname:pat] against the hypotheses in
+      [hyps]. Tries the hypotheses in order. For each success returns
+      the name of the matched hypothesis. *)
+  let hyp_match_type hypname pat hyps =
+    pick hyps >>= fun decl ->
+    let id = NamedDecl.get_id decl in
+    let refresh = is_local_def decl in
+    pattern_match_term refresh pat (NamedDecl.get_type decl) () <*>
+    put_terms (id_map_try_add_name hypname (EConstr.mkVar id) empty_term_subst) <*>
+    return id
+
+  (** [hyp_match_type hypname bodypat typepat hyps] matches a single
+      hypothesis pattern [hypname := bodypat : typepat] against the
+      hypotheses in [hyps].Tries the hypotheses in order. For each
+      success returns the name of the matched hypothesis. *)
+  let hyp_match_body_and_type hypname bodypat typepat hyps =
+    pick hyps >>= function
+      | LocalDef (id,body,hyp) ->
+          pattern_match_term false bodypat body () <*>
+          pattern_match_term true typepat hyp () <*>
+          put_terms (id_map_try_add_name hypname (EConstr.mkVar id) empty_term_subst) <*>
+          return id
+      | LocalAssum (id,hyp) -> fail
+
+  (** [hyp_match pat hyps] dispatches to
+      {!hyp_match_type} or {!hyp_match_body_and_type} depending on whether
+      [pat] is [Hyp _] or [Def _]. *)
+  let hyp_match pat hyps =
+    match pat with
+    | Hyp ((_,hypname),typepat) ->
+        hyp_match_type hypname typepat hyps
+    | Def ((_,hypname),bodypat,typepat) ->
+        hyp_match_body_and_type hypname bodypat typepat hyps
+
+  (** [hyp_pattern_list_match pats hyps lhs], matches the list of
+      patterns [pats] against the hypotheses in [hyps], and eventually
+      returns [lhs]. *)
+  let rec hyp_pattern_list_match pats hyps lhs =
+    match pats with
+    | pat::pats ->
+        hyp_match pat hyps >>= fun matched_hyp ->
+        (* spiwack: alternatively it is possible to return the list
+           with the matched hypothesis removed directly in
+           [hyp_match]. *)
+        let select_matched_hyp decl = Id.equal (NamedDecl.get_id decl) matched_hyp in
+        let hyps = CList.remove_first select_matched_hyp hyps in
+        hyp_pattern_list_match pats hyps lhs
+    | [] -> return lhs
+
+  (** [rule_match_goal hyps concl rule] matches the rule [rule]
+      against the goal [hyps|-concl]. *)
+  let rule_match_goal hyps concl = function
+    | All lhs -> wildcard_match_term lhs
+    | Pat (hyppats,conclpat,lhs) ->
+        (* the rules are applied from the topmost one (in the concrete
+           syntax) to the bottommost. *)
+        let hyppats = List.rev hyppats in
+        pattern_match_term false conclpat concl () <*>
+        hyp_pattern_list_match hyppats hyps lhs
+
+  (** [match_goal hyps concl rules] matches the goal [hyps|-concl]
+      with the set of matching rules [rules]. *)
+  let rec match_goal (e, info) hyps concl rules = match rules with
+  | [] -> { stream = fun _ _ -> Proofview.tclZERO ~info e }
+  | r :: rules ->
+    { stream = fun k ctx ->
+      let head = rule_match_goal hyps concl r in
+      let tail e = match_goal e hyps concl rules in
+      Proofview.tclOR (head.stream k ctx) (fun e -> (tail e).stream k ctx)
+    }
+
+end
+
+(** [match_term env sigma term rules] matches the term [term] with the
+    set of matching rules [rules]. The environment [env] and the
+    evar_map [sigma] are not currently used, but avoid code
+    duplication. *)
+let match_term env sigma term rules =
+  let module E = struct
+    let env = env
+    let sigma = sigma
+  end in
+  let module M = PatternMatching(E) in
+  M.run (M.match_term imatching_error term rules)
+
+
+(** [match_goal env sigma hyps concl rules] matches the goal
+    [hyps|-concl] with the set of matching rules [rules]. The
+    environment [env] and the evar_map [sigma] are used to check
+    convertibility for pattern variables shared between hypothesis
+    patterns or the conclusion pattern. *)
+let match_goal env sigma hyps concl rules =
+  let module E = struct
+    let env = env
+    let sigma = sigma
+  end in
+  let module M = PatternMatching(E) in
+  M.run (M.match_goal imatching_error hyps concl rules)
diff --git a/plugins/ltac/tactic_matching.mli b/plugins/ltac/tactic_matching.mli
new file mode 100644
index 000000000..300b546f1
--- /dev/null
+++ b/plugins/ltac/tactic_matching.mli
@@ -0,0 +1,49 @@
+ (************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(** This file extends Matching with the main logic for Ltac's
+    (lazy)match and (lazy)match goal. *)
+
+
+(** [t] is the type of matching successes. It ultimately contains a
+    {!Tacexpr.glob_tactic_expr} representing the left-hand side of the
+    corresponding matching rule, a matching substitution to be
+    applied, a context substitution mapping identifier to context like
+    those of {!Matching.matching_result}), and a {!Term.constr}
+    substitution mapping corresponding to matched hypotheses. *)
+type 'a t = {
+  subst : Constr_matching.bound_ident_map * Pattern.extended_patvar_map ;
+  context : EConstr.constr Names.Id.Map.t;
+  terms : EConstr.constr Names.Id.Map.t;
+  lhs : 'a;
+}
+
+
+(** [match_term env sigma term rules] matches the term [term] with the
+    set of matching rules [rules]. The environment [env] and the
+    evar_map [sigma] are not currently used, but avoid code
+    duplication. *)
+val match_term :
+  Environ.env ->
+  Evd.evar_map ->
+  EConstr.constr ->
+  (Tacexpr.binding_bound_vars * Pattern.constr_pattern, Tacexpr.glob_tactic_expr) Tacexpr.match_rule list ->
+  Tacexpr.glob_tactic_expr t Proofview.tactic
+
+(** [match_goal env sigma hyps concl rules] matches the goal
+    [hyps|-concl] with the set of matching rules [rules]. The
+    environment [env] and the evar_map [sigma] are used to check
+    convertibility for pattern variables shared between hypothesis
+    patterns or the conclusion pattern. *)
+val match_goal:
+  Environ.env ->
+  Evd.evar_map ->
+  EConstr.named_context ->
+  EConstr.constr ->
+  (Tacexpr.binding_bound_vars * Pattern.constr_pattern, Tacexpr.glob_tactic_expr) Tacexpr.match_rule list ->
+  Tacexpr.glob_tactic_expr t Proofview.tactic
diff --git a/plugins/ltac/tactic_option.ml b/plugins/ltac/tactic_option.ml
new file mode 100644
index 000000000..a5ba3b837
--- /dev/null
+++ b/plugins/ltac/tactic_option.ml
@@ -0,0 +1,51 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+open Libobject
+open Pp
+
+let declare_tactic_option ?(default=Tacexpr.TacId []) name =
+  let locality = Summary.ref false ~name:(name^"-locality") in
+  let default_tactic_expr : Tacexpr.glob_tactic_expr ref =
+    Summary.ref default ~name:(name^"-default-tacexpr")
+  in
+  let default_tactic : Tacexpr.glob_tactic_expr ref =
+    Summary.ref !default_tactic_expr ~name:(name^"-default-tactic")
+  in
+  let set_default_tactic local t =
+    locality := local;
+    default_tactic_expr := t;
+    default_tactic := t
+  in
+  let cache (_, (local, tac)) = set_default_tactic local tac in
+  let load (_, (local, tac)) =
+    if not local then set_default_tactic local tac
+  in
+  let subst (s, (local, tac)) =
+    (local, Tacsubst.subst_tactic s tac)
+  in
+  let input : bool * Tacexpr.glob_tactic_expr -> obj =
+    declare_object
+      { (default_object name) with
+	cache_function = cache;
+	load_function = (fun _ -> load);
+	open_function = (fun _ -> load);
+	classify_function = (fun (local, tac) ->
+	  if local then Dispose else Substitute (local, tac));
+	subst_function = subst}
+  in
+  let put local tac =
+    set_default_tactic local tac;
+    Lib.add_anonymous_leaf (input (local, tac))
+  in
+  let get () = !locality, Tacinterp.eval_tactic !default_tactic in
+  let print () = 
+    Pptactic.pr_glob_tactic (Global.env ()) !default_tactic_expr ++
+      (if !locality then str" (locally defined)" else str" (globally defined)")
+  in
+  put, get, print
diff --git a/plugins/ltac/tactic_option.mli b/plugins/ltac/tactic_option.mli
new file mode 100644
index 000000000..ed759a76d
--- /dev/null
+++ b/plugins/ltac/tactic_option.mli
@@ -0,0 +1,15 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+open Tacexpr
+open Vernacexpr
+
+val declare_tactic_option : ?default:Tacexpr.glob_tactic_expr -> string -> 
+  (* put *) (locality_flag -> glob_tactic_expr -> unit) *
+  (* get *) (unit -> locality_flag * unit Proofview.tactic) *
+  (* print *) (unit -> Pp.std_ppcmds)
diff --git a/plugins/ltac/tauto.ml b/plugins/ltac/tauto.ml
new file mode 100644
index 000000000..dc7ee6a23
--- /dev/null
+++ b/plugins/ltac/tauto.ml
@@ -0,0 +1,288 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+open Term
+open EConstr
+open Hipattern
+open Names
+open Pp
+open Geninterp
+open Misctypes
+open Tacexpr
+open Tacinterp
+open Util
+open Tacticals.New
+open Proofview.Notations
+
+let tauto_plugin = "tauto"
+let () = Mltop.add_known_module tauto_plugin
+
+let assoc_var s ist =
+  let v = Id.Map.find (Names.Id.of_string s) ist.lfun in
+  match Value.to_constr v with
+    | Some c -> c
+    | None -> failwith "tauto: anomaly"
+
+(** Parametrization of tauto *)
+
+type tauto_flags = {
+
+(* Whether conjunction and disjunction are restricted to binary connectives *)
+  binary_mode : bool;
+
+(* Whether compatibility for buggy detection of binary connective is on *)
+  binary_mode_bugged_detection : bool;
+
+(* Whether conjunction and disjunction are restricted to the connectives *)
+(* having the structure of "and" and "or" (up to the choice of sorts) in *)
+(* contravariant position in an hypothesis *)
+  strict_in_contravariant_hyp : bool;
+
+(* Whether conjunction and disjunction are restricted to the connectives *)
+(* having the structure of "and" and "or" (up to the choice of sorts) in *)
+(* an hypothesis and in the conclusion *)
+  strict_in_hyp_and_ccl : bool;
+
+(* Whether unit type includes equality types *)
+  strict_unit : bool;
+}
+
+let tag_tauto_flags : tauto_flags Val.typ = Val.create "tauto_flags"
+
+let assoc_flags ist : tauto_flags =
+  let Val.Dyn (tag, v) = Id.Map.find (Names.Id.of_string "tauto_flags") ist.lfun in
+  match Val.eq tag tag_tauto_flags with
+  | None -> assert false
+  | Some Refl -> v
+
+(* Whether inner not are unfolded *)
+let negation_unfolding = ref true
+
+(* Whether inner iff are unfolded *)
+let iff_unfolding = ref false
+
+let unfold_iff () = !iff_unfolding || Flags.version_less_or_equal Flags.V8_2
+
+open Goptions
+let _ =
+  declare_bool_option
+    { optsync  = true;
+      optdepr  = false;
+      optname  = "unfolding of not in intuition";
+      optkey   = ["Intuition";"Negation";"Unfolding"];
+      optread  = (fun () -> !negation_unfolding);
+      optwrite = (:=) negation_unfolding }
+
+let _ =
+  declare_bool_option
+    { optsync  = true;
+      optdepr  = false;
+      optname  = "unfolding of iff in intuition";
+      optkey   = ["Intuition";"Iff";"Unfolding"];
+      optread  = (fun () -> !iff_unfolding);
+      optwrite = (:=) iff_unfolding }
+
+(** Base tactics *)
+
+let loc = Loc.ghost
+let idtac = Proofview.tclUNIT ()
+let fail = Proofview.tclINDEPENDENT (tclFAIL 0 (Pp.mt ()))
+
+let intro = Tactics.intro
+
+let assert_ ?by c =
+  let tac = match by with
+  | None -> None
+  | Some tac -> Some (Some tac)
+  in
+  Proofview.tclINDEPENDENT (Tactics.forward true tac None c)
+
+let apply c = Tactics.apply c
+
+let clear id = Tactics.clear [id]
+
+let assumption = Tactics.assumption
+
+let split = Tactics.split_with_bindings false [Misctypes.NoBindings]
+
+(** Test *)
+
+let is_empty _ ist =
+  Proofview.tclEVARMAP >>= fun sigma ->
+  if is_empty_type sigma (assoc_var "X1" ist) then idtac else fail
+
+(* Strictly speaking, this exceeds the propositional fragment as it
+   matches also equality types (and solves them if a reflexivity) *)
+let is_unit_or_eq _ ist =
+  Proofview.tclEVARMAP >>= fun sigma ->
+  let flags = assoc_flags ist in
+  let test = if flags.strict_unit then is_unit_type else is_unit_or_eq_type in
+  if test sigma (assoc_var "X1" ist) then idtac else fail
+
+let bugged_is_binary sigma t =
+  isApp sigma t &&
+  let (hdapp,args) = decompose_app sigma t in
+    match EConstr.kind sigma hdapp with
+    | Ind (ind,u)  ->
+        let (mib,mip) = Global.lookup_inductive ind in
+         Int.equal mib.Declarations.mind_nparams 2
+    | _ -> false
+
+(** Dealing with conjunction *)
+
+let is_conj _ ist =
+  Proofview.tclEVARMAP >>= fun sigma ->
+  let flags = assoc_flags ist in
+  let ind = assoc_var "X1" ist in
+    if (not flags.binary_mode_bugged_detection || bugged_is_binary sigma ind) &&
+       is_conjunction sigma
+         ~strict:flags.strict_in_hyp_and_ccl
+         ~onlybinary:flags.binary_mode ind
+    then idtac
+    else fail
+
+let flatten_contravariant_conj _ ist =
+  Proofview.tclEVARMAP >>= fun sigma ->
+  let flags = assoc_flags ist in
+  let typ = assoc_var "X1" ist in
+  let c = assoc_var "X2" ist in
+  let hyp = assoc_var "id" ist in
+  match match_with_conjunction sigma
+          ~strict:flags.strict_in_contravariant_hyp
+          ~onlybinary:flags.binary_mode typ
+  with
+  | Some (_,args) ->
+    let newtyp = List.fold_right mkArrow args c in
+    let intros = tclMAP (fun _ -> intro) args in
+    let by = tclTHENLIST [intros; apply hyp; split; assumption] in
+    tclTHENLIST [assert_ ~by newtyp; clear (destVar sigma hyp)]
+  | _ -> fail
+
+(** Dealing with disjunction *)
+
+let is_disj _ ist =
+  Proofview.tclEVARMAP >>= fun sigma ->
+  let flags = assoc_flags ist in
+  let t = assoc_var "X1" ist in
+  if (not flags.binary_mode_bugged_detection || bugged_is_binary sigma t) &&
+     is_disjunction sigma
+       ~strict:flags.strict_in_hyp_and_ccl
+       ~onlybinary:flags.binary_mode t
+  then idtac
+  else fail
+
+let flatten_contravariant_disj _ ist =
+  Proofview.tclEVARMAP >>= fun sigma ->
+  let flags = assoc_flags ist in
+  let typ = assoc_var "X1" ist in
+  let c = assoc_var "X2" ist in
+  let hyp = assoc_var "id" ist in
+  match match_with_disjunction sigma
+          ~strict:flags.strict_in_contravariant_hyp
+          ~onlybinary:flags.binary_mode
+          typ with
+  | Some (_,args) ->
+      let map i arg =
+        let typ = mkArrow arg c in
+        let ci = Tactics.constructor_tac false None (succ i) Misctypes.NoBindings in
+        let by = tclTHENLIST [intro; apply hyp; ci; assumption] in
+        assert_ ~by typ
+      in
+      let tacs = List.mapi map args in
+      let tac0 = clear (destVar sigma hyp) in
+      tclTHEN (tclTHENLIST tacs) tac0
+  | _ -> fail
+
+let make_unfold name =
+  let dir = DirPath.make (List.map Id.of_string ["Logic"; "Init"; "Coq"]) in
+  let const = Constant.make2 (MPfile dir) (Label.make name) in
+  (Locus.AllOccurrences, ArgArg (EvalConstRef const, None))
+
+let u_iff = make_unfold "iff"
+let u_not = make_unfold "not"
+
+let reduction_not_iff _ ist =
+  let make_reduce c = TacAtom (loc, TacReduce (Genredexpr.Unfold c, Locusops.allHypsAndConcl)) in
+  let tac = match !negation_unfolding, unfold_iff () with
+    | true, true -> make_reduce [u_not; u_iff]
+    | true, false -> make_reduce [u_not]
+    | false, true -> make_reduce [u_iff]
+    | false, false -> TacId []
+  in
+  eval_tactic_ist ist tac
+
+let coq_nnpp_path =
+  let dir = List.map Id.of_string ["Classical_Prop";"Logic";"Coq"] in
+  Libnames.make_path (DirPath.make dir) (Id.of_string "NNPP")
+
+let apply_nnpp _ ist =
+  Proofview.tclBIND
+    (Proofview.tclUNIT ())
+    begin fun () -> try
+      let nnpp = Universes.constr_of_global (Nametab.global_of_path coq_nnpp_path) in
+      let nnpp = EConstr.of_constr nnpp in
+      apply nnpp
+    with Not_found -> tclFAIL 0 (Pp.mt ())
+    end
+
+(* This is the uniform mode dealing with ->, not, iff and types isomorphic to
+   /\ and *, \/ and +, False and Empty_set, True and unit, _and_ eq-like types.
+   For the moment not and iff are still always unfolded. *)
+let tauto_uniform_unit_flags = {
+  binary_mode = true;
+  binary_mode_bugged_detection = false;
+  strict_in_contravariant_hyp = true;
+  strict_in_hyp_and_ccl = true;
+  strict_unit = false
+}
+
+(* This is the compatibility mode (not used) *)
+let tauto_legacy_flags = {
+  binary_mode = true;
+  binary_mode_bugged_detection = true;
+  strict_in_contravariant_hyp = true;
+  strict_in_hyp_and_ccl = false;
+  strict_unit = false
+}
+
+(* This is the improved mode *)
+let tauto_power_flags = {
+  binary_mode = false; (* support n-ary connectives *)
+  binary_mode_bugged_detection = false;
+  strict_in_contravariant_hyp = false; (* supports non-regular connectives *)
+  strict_in_hyp_and_ccl = false;
+  strict_unit = false
+}
+
+let with_flags flags _ ist =
+  let f = (loc, Id.of_string "f") in
+  let x = (loc, Id.of_string "x") in
+  let arg = Val.Dyn (tag_tauto_flags, flags) in
+  let ist = { ist with lfun = Id.Map.add (snd x) arg ist.lfun } in
+  eval_tactic_ist ist (TacArg (loc, TacCall (loc, ArgVar f, [Reference (ArgVar x)])))
+
+let register_tauto_tactic tac name0 args =
+  let ids = List.map (fun id -> Id.of_string id) args in
+  let ids = List.map (fun id -> Name id) ids in
+  let name = { mltac_plugin = tauto_plugin; mltac_tactic = name0; } in
+  let entry = { mltac_name = name; mltac_index = 0 } in
+  let () = Tacenv.register_ml_tactic name [| tac |] in
+  let tac = TacFun (ids, TacML (loc, entry, [])) in
+  let obj () = Tacenv.register_ltac true true (Id.of_string name0) tac in
+  Mltop.declare_cache_obj obj tauto_plugin
+
+let () = register_tauto_tactic is_empty "is_empty" ["tauto_flags"; "X1"]
+let () = register_tauto_tactic is_unit_or_eq "is_unit_or_eq" ["tauto_flags"; "X1"]
+let () = register_tauto_tactic is_disj "is_disj" ["tauto_flags"; "X1"]
+let () = register_tauto_tactic is_conj "is_conj" ["tauto_flags"; "X1"]
+let () = register_tauto_tactic flatten_contravariant_disj "flatten_contravariant_disj" ["tauto_flags"; "X1"; "X2"; "id"]
+let () = register_tauto_tactic flatten_contravariant_conj "flatten_contravariant_conj" ["tauto_flags"; "X1"; "X2"; "id"]
+let () = register_tauto_tactic apply_nnpp "apply_nnpp" []
+let () = register_tauto_tactic reduction_not_iff "reduction_not_iff" []
+let () = register_tauto_tactic (with_flags tauto_uniform_unit_flags) "with_uniform_flags" ["f"]
+let () = register_tauto_tactic (with_flags tauto_power_flags) "with_power_flags" ["f"]
diff --git a/plugins/ltac/tauto.mli b/plugins/ltac/tauto.mli
new file mode 100644
index 000000000..e69de29bb
--- /dev/null
+++ b/plugins/ltac/tauto.mli
diff --git a/plugins/ltac/vo.itarget b/plugins/ltac/vo.itarget
new file mode 100644
index 000000000..a28fb770b
--- /dev/null
+++ b/plugins/ltac/vo.itarget
@@ -0,0 +1 @@
+Ltac.vo
diff --git a/plugins/micromega/RMicromega.v b/plugins/micromega/RMicromega.v
index 2352d78d6..30e475b71 100644
--- a/plugins/micromega/RMicromega.v
+++ b/plugins/micromega/RMicromega.v
@@ -18,7 +18,7 @@ Require Import Refl.
 Require Import Raxioms RIneq Rpow_def DiscrR.
 Require Import QArith.
 Require Import Qfield.
-
+Require Import Qreals.
 
 Require Setoid.
 (*Declare ML Module "micromega_plugin".*)
@@ -38,15 +38,8 @@ Proof.
   exact Rplus_opp_r.
 Qed.
 
-Add Ring Rring : Rsrt.
 Open Scope R_scope.
 
-Lemma Rmult_neutral : forall x:R , 0 * x = 0.
-Proof.
-  intro ; ring.
-Qed.
-
-
 Lemma Rsor : SOR R0 R1 Rplus Rmult Rminus Ropp (@eq R)  Rle Rlt.
 Proof.
   constructor; intros ; subst ; try (intuition (subst; try ring ; auto with real)).
@@ -59,142 +52,41 @@ Proof.
   apply (Rlt_irrefl m) ; auto.
   apply Rnot_le_lt. auto with real.
   destruct (total_order_T n m) as [ [H1 | H1] | H1] ; auto.
-  intros.
-  rewrite <- (Rmult_neutral m).
-  apply (Rmult_lt_compat_r) ; auto.
-Qed.
-
-Definition IQR := fun x : Q => (IZR (Qnum x) * / IZR (' Qden x))%R.
-
-
-Lemma Rinv_elim : forall x y z, 
-  y <> 0 -> (z * y = x <->   x * / y = z).
-Proof.
-  intros.
-  split ; intros.
-  subst.
-  rewrite Rmult_assoc.
-  rewrite Rinv_r; auto.
-  ring.
-  subst.
-  rewrite Rmult_assoc.
-  rewrite (Rmult_comm (/ y)).
-  rewrite Rinv_r ; auto.
-  ring.
-Qed.  
-
-Ltac INR_nat_of_P :=
-  match goal with
-    | H : context[INR (Pos.to_nat ?X)] |- _ =>
-      revert H ; 
-      let HH := fresh in
-        assert (HH := pos_INR_nat_of_P X) ; revert HH ; generalize (INR (Pos.to_nat X))
-    | |- context[INR (Pos.to_nat ?X)] =>
-      let HH := fresh in
-        assert (HH := pos_INR_nat_of_P X) ; revert HH ; generalize (INR (Pos.to_nat X))
-  end.
-
-Ltac add_eq expr val := set (temp := expr) ; 
-  generalize (eq_refl temp) ;
-    unfold temp at 1 ; generalize temp ; intro val ; clear temp.
-
-Ltac Rinv_elim :=
-  match goal with
-    | |- context[?x * / ?y] => 
-      let z := fresh "v" in 
-      add_eq (x * / y) z  ;
-      let H := fresh in intro H ; rewrite <- Rinv_elim in H
-  end.
-
-Lemma Rlt_neq : forall r , 0 < r -> r <> 0.
-Proof.
-  red. intros.
-  subst.
-  apply (Rlt_irrefl 0 H).  
+  now apply Rmult_lt_0_compat.
 Qed.
 
+Notation IQR := Q2R (only parsing).
 
 Lemma Rinv_1 : forall x, x * / 1 = x.
 Proof.
   intro.
-  Rinv_elim.
-  subst ; ring.
-  apply R1_neq_R0.
+  rewrite Rinv_1.
+  apply Rmult_1_r.
 Qed.
 
-Lemma Qeq_true : forall x y,  
-  Qeq_bool x y = true -> 
-   IQR x = IQR y.
+Lemma Qeq_true : forall x y, Qeq_bool x y = true -> IQR x = IQR y.
 Proof.
-  unfold IQR.
-  simpl.
-  intros.
-  apply Qeq_bool_eq in H.
-  unfold Qeq in H.
-  assert (IZR (Qnum x * ' Qden y) = IZR (Qnum y * ' Qden x))%Z.
-     rewrite H. reflexivity.
-  repeat rewrite mult_IZR in H0.
-  simpl in H0.
-  revert H0.
-  repeat INR_nat_of_P.
   intros.
-  apply Rinv_elim in H2 ; [| apply Rlt_neq ; auto].
-  rewrite <- H2.
-  field.
-  split ; apply Rlt_neq ; auto.
+  now apply Qeq_eqR, Qeq_bool_eq.
 Qed.
 
 Lemma Qeq_false : forall x y, Qeq_bool x y = false -> IQR x <> IQR y.
 Proof.
   intros.
-  apply Qeq_bool_neq  in H.
-  intro. apply H.   clear H.
-  unfold Qeq,IQR in *.
-  simpl in *.
-  revert H0.
-  repeat Rinv_elim.
-  intros.
-  subst.
-  assert (IZR (Qnum x * ' Qden y)%Z = IZR (Qnum y * ' Qden x)%Z).
-  repeat rewrite mult_IZR.  
-  simpl.
-  rewrite <- H0. rewrite <- H.
-  ring.
-  apply eq_IZR ; auto.
-  INR_nat_of_P; intros; apply Rlt_neq ; auto. 
-  INR_nat_of_P; intros ; apply Rlt_neq ; auto. 
+  apply Qeq_bool_neq in H.
+  contradict H.
+  now apply eqR_Qeq.
 Qed.
 
-  
-
 Lemma Qle_true : forall x y : Q, Qle_bool x y = true -> IQR x <= IQR y.
 Proof.
   intros.
-  apply Qle_bool_imp_le in H.
-  unfold Qle in H.
-  unfold IQR.
-  simpl in *.
-  apply IZR_le in H.
-  repeat rewrite mult_IZR in H.
-  simpl in H.
-  repeat INR_nat_of_P; intros.
-  assert (Hr := Rlt_neq r H).
-  assert (Hr0 := Rlt_neq r0 H0).
-  replace (IZR (Qnum x) * / r) with ((IZR (Qnum x) * r0) * (/r * /r0)).
-  replace (IZR (Qnum y) * / r0) with ((IZR (Qnum y) * r) * (/r * /r0)).
-  apply Rmult_le_compat_r ; auto.
-  apply Rmult_le_pos.
-  unfold Rle. left. apply Rinv_0_lt_compat ; auto.
-  unfold Rle. left. apply Rinv_0_lt_compat ; auto.
-  field ; intuition.
-  field ; intuition.
+  now apply Qle_Rle, Qle_bool_imp_le.
 Qed.
 
-
-
 Lemma IQR_0 : IQR 0 = 0.
 Proof.
-  compute. apply Rinv_1.
+  apply Rmult_0_l.
 Qed.
 
 Lemma IQR_1 : IQR 1 = 1.
@@ -202,160 +94,6 @@ Proof.
   compute. apply Rinv_1.
 Qed.
 
-Lemma IQR_plus : forall x y, IQR (x + y) = IQR x + IQR y.
-Proof.
-  intros.
-  unfold IQR.
-  simpl in *.
-  rewrite plus_IZR in *.
-  rewrite mult_IZR in *.
-  simpl.  
-  rewrite Pos2Nat.inj_mul.
-  rewrite mult_INR.
-  rewrite mult_IZR.
-  simpl.
-  repeat INR_nat_of_P.
-  intros. field. 
-  split ; apply Rlt_neq ; auto.
-Qed.
-
-Lemma IQR_opp : forall x, IQR (- x) = - IQR x.
-Proof.
-  intros.
-  unfold IQR.
-  simpl.
-  rewrite opp_IZR.
-  ring.  
-Qed.
-
-Lemma IQR_minus : forall x y, IQR (x - y) = IQR x - IQR y.
-Proof.
-  intros.
-  unfold Qminus.
-  rewrite IQR_plus.
-  rewrite IQR_opp.
-  ring.
-Qed.
-
-
-Lemma IQR_mult : forall x y, IQR (x * y) = IQR x * IQR y.
-Proof.
-  unfold IQR ; intros.
-  simpl.
-  repeat rewrite mult_IZR.
-  rewrite Pos2Nat.inj_mul.
-  rewrite mult_INR.
-  repeat INR_nat_of_P.
-  intros. field ; split ; apply Rlt_neq ; auto.
-Qed.
-
-Lemma IQR_inv_lt : forall x, (0 < x)%Q -> 
-  IQR (/ x) =  / IQR x.
-Proof.
-  unfold IQR ; simpl.
-  intros.
-  unfold Qlt in H.
-  revert H.
-  simpl.
-  intros.
-  unfold Qinv.
-  destruct x.
-  destruct Qnum ; simpl in *.
-  exfalso. auto with zarith.
-  clear H.
-  repeat INR_nat_of_P.
-  intros.
-  assert (HH := Rlt_neq _ H).
-  assert (HH0 := Rlt_neq _ H0).
-  rewrite Rinv_mult_distr ; auto.
-  rewrite Rinv_involutive ; auto.
-  ring.
-  apply Rinv_0_lt_compat in H0.
-  apply Rlt_neq ; auto.
-  simpl in H.
-  exfalso.
-  rewrite Pos.mul_comm  in H.
-  compute in H.
-  discriminate.
-Qed.
-
-Lemma Qinv_opp : forall x, (- (/ x) = / ( -x))%Q.
-Proof.
-  destruct x ; destruct Qnum ; reflexivity.
-Qed.
-
-Lemma Qopp_involutive_strong : forall x, (- - x = x)%Q.
-Proof.
-  intros.
-  destruct x.
-  unfold Qopp.
-  simpl.
-  rewrite Z.opp_involutive.
-  reflexivity.
-Qed.
-
-Lemma Ropp_0 : forall r , - r = 0 -> r = 0.
-Proof.
-  intros.
-  rewrite <- (Ropp_involutive r).
-  apply Ropp_eq_0_compat ; auto.
-Qed.
-
-Lemma IQR_x_0 : forall x, IQR x = 0 -> x == 0%Q.
-Proof.
-  destruct x ; simpl.
-  unfold IQR.
-  simpl.
-  INR_nat_of_P.
-  intros.
-  apply Rmult_integral in H0.  
-  destruct H0.
-  apply eq_IZR_R0 in H0.
-  subst.
-  reflexivity.
-  exfalso.
-  apply Rinv_0_lt_compat in H.
-  rewrite <- H0 in H.
-  apply Rlt_irrefl in H. auto.
-Qed.
-  
-
-Lemma IQR_inv_gt : forall x, (0 > x)%Q -> 
-  IQR (/ x) =  / IQR x.
-Proof.
-  intros.
-  rewrite <- (Qopp_involutive_strong x).
-  rewrite <- Qinv_opp.
-  rewrite IQR_opp.
-  rewrite IQR_inv_lt.
-  repeat rewrite IQR_opp.
-  rewrite Ropp_inv_permute.
-  auto.
-  intro.
-  apply Ropp_0 in H0.
-  apply IQR_x_0 in H0.
-  rewrite H0 in H.
-  compute in H. discriminate.
-  unfold Qlt in *.
-  destruct x ; simpl in *.
-  auto with zarith.
-Qed.
-
-Lemma IQR_inv : forall x, ~ x ==  0 -> 
-  IQR (/ x) =  / IQR x.
-Proof.
-  intros.
-  assert ( 0 > x \/ 0 < x)%Q.
-   destruct x ; unfold Qlt, Qeq in * ; simpl in *.
-   rewrite Z.mul_1_r in *.
-   destruct Qnum ; simpl in * ; intuition auto.
-   right. reflexivity.
-   left ; reflexivity.
-  destruct H0.
-  apply IQR_inv_gt ; auto.
-  apply IQR_inv_lt ; auto.
-Qed.
-
 Lemma IQR_inv_ext : forall x, 
   IQR (/ x) = (if Qeq_bool x 0 then 0 else / IQR x).
 Proof.
@@ -366,18 +104,13 @@ Proof.
   destruct x ; simpl.
   unfold Qeq in H.
   simpl in H.
-  replace Qnum with 0%Z.
-  compute. rewrite Rinv_1.
-  reflexivity.
-  rewrite <- H. ring.
+  rewrite Zmult_1_r in H.
+  rewrite H.
+  apply Rmult_0_l.
   intros.
-  apply IQR_inv.
-  intro.
-  rewrite <- Qeq_bool_iff in H0.
-  congruence.
+  now apply Q2R_inv, Qeq_bool_neq.
 Qed.
 
-
 Notation to_nat := N.to_nat.
 
 Lemma QSORaddon :
@@ -391,10 +124,10 @@ Proof.
   constructor ; intros ; try reflexivity.
   apply IQR_0.
   apply IQR_1.
-  apply IQR_plus.
-  apply IQR_minus.
-  apply IQR_mult.
-  apply IQR_opp.
+  apply Q2R_plus.
+  apply Q2R_minus.
+  apply Q2R_mult.
+  apply Q2R_opp.
   apply Qeq_true ; auto.
   apply R_power_theory.
   apply Qeq_false.
@@ -453,13 +186,13 @@ Proof.
     apply IQR_1. 
     reflexivity.
     unfold IQR. simpl. rewrite Rinv_1. reflexivity.
-    apply IQR_plus.
-    apply IQR_minus.
-    apply IQR_mult.
+    apply Q2R_plus.
+    apply Q2R_minus.
+    apply Q2R_mult.
     rewrite <- IHc.
     apply IQR_inv_ext.
     rewrite <- IHc.
-    apply IQR_opp.
+    apply Q2R_opp.
   Qed.
 
 Require Import EnvRing.
diff --git a/plugins/micromega/coq_micromega.ml b/plugins/micromega/coq_micromega.ml
index 5b56fb35b..4b87e6e2e 100644
--- a/plugins/micromega/coq_micromega.ml
+++ b/plugins/micromega/coq_micromega.ml
@@ -368,6 +368,7 @@ struct
     [["Coq";"Reals" ; "Rdefinitions"];
      ["Coq";"Reals" ; "Rpow_def"] ;
      ["Coq";"Reals" ; "Raxioms"] ;
+     ["Coq";"QArith"; "Qreals"] ;
     ]
 
   let z_modules = [["Coq";"ZArith";"BinInt"]]
@@ -388,7 +389,6 @@ struct
   let coq_and = lazy (init_constant "and")
   let coq_or = lazy (init_constant "or")
   let coq_not = lazy (init_constant "not")
-  let coq_not_gl_ref = (Nametab.locate (  Libnames.qualid_of_string "Coq.Init.Logic.not"))
 
   let coq_iff = lazy (init_constant "iff")
   let coq_True = lazy (init_constant "True")
@@ -485,7 +485,7 @@ struct
   let coq_Rinv = lazy (r_constant "Rinv")
   let coq_Rpower = lazy (r_constant "pow")
   let coq_IZR    = lazy (r_constant "IZR")
-  let coq_IQR    = lazy (constant "IQR")
+  let coq_IQR    = lazy (r_constant "Q2R")
 
 
   let coq_PEX = lazy (constant "PEX" )
diff --git a/plugins/micromega/g_micromega.ml4 b/plugins/micromega/g_micromega.ml4
index 79020ed03..ccb6daa11 100644
--- a/plugins/micromega/g_micromega.ml4
+++ b/plugins/micromega/g_micromega.ml4
@@ -16,6 +16,7 @@
 
 (*i camlp4deps: "grammar/grammar.cma" i*)
 
+open Ltac_plugin
 open Stdarg
 open Tacarg
 
diff --git a/plugins/nsatz/g_nsatz.ml4 b/plugins/nsatz/g_nsatz.ml4
index a6749c347..759885253 100644
--- a/plugins/nsatz/g_nsatz.ml4
+++ b/plugins/nsatz/g_nsatz.ml4
@@ -1,5 +1,3 @@
-DECLARE PLUGIN "nsatz_plugin"
-
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
 (* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
@@ -10,6 +8,9 @@ DECLARE PLUGIN "nsatz_plugin"
 
 (*i camlp4deps: "grammar/grammar.cma" i*)
 
+open Ltac_plugin
+open Names
+
 DECLARE PLUGIN "nsatz_plugin"
 
 TACTIC EXTEND nsatz_compute
diff --git a/plugins/omega/g_omega.ml4 b/plugins/omega/g_omega.ml4
index 27115abec..6b711a176 100644
--- a/plugins/omega/g_omega.ml4
+++ b/plugins/omega/g_omega.ml4
@@ -17,6 +17,7 @@
 
 DECLARE PLUGIN "omega_plugin"
 
+open Ltac_plugin
 open Names
 open Coq_omega
 open Stdarg
diff --git a/plugins/quote/g_quote.ml4 b/plugins/quote/g_quote.ml4
index 40c1028e5..6c3e66112 100644
--- a/plugins/quote/g_quote.ml4
+++ b/plugins/quote/g_quote.ml4
@@ -8,6 +8,7 @@
 
 (*i camlp4deps: "grammar/grammar.cma" i*)
 
+open Ltac_plugin
 open Names
 open Misctypes
 open Tacexpr
diff --git a/plugins/romega/g_romega.ml4 b/plugins/romega/g_romega.ml4
index 2f38688d1..9a54ad778 100644
--- a/plugins/romega/g_romega.ml4
+++ b/plugins/romega/g_romega.ml4
@@ -10,6 +10,7 @@
 
 DECLARE PLUGIN "romega_plugin"
 
+open Ltac_plugin
 open Names
 open Refl_omega
 open Stdarg
diff --git a/plugins/rtauto/g_rtauto.ml4 b/plugins/rtauto/g_rtauto.ml4
index d27b04834..7e58ef9a3 100644
--- a/plugins/rtauto/g_rtauto.ml4
+++ b/plugins/rtauto/g_rtauto.ml4
@@ -8,6 +8,8 @@
 
 (*i camlp4deps: "grammar/grammar.cma"  i*)
 
+open Ltac_plugin
+
 DECLARE PLUGIN "rtauto_plugin"
 
 TACTIC EXTEND rtauto
diff --git a/plugins/rtauto/proof_search.ml b/plugins/rtauto/proof_search.ml
index 8b9261113..1ad4d622b 100644
--- a/plugins/rtauto/proof_search.ml
+++ b/plugins/rtauto/proof_search.ml
@@ -505,12 +505,12 @@ let pp_mapint map =
 		pp_form obj ++ str " => " ++
 				 pp_list (fun (i,f) -> pp_form f) l ++
 				 cut ()) ) map;
-    str "{ " ++ vb 0 ++  (!pp) ++ str " }" ++ close ()
+    str "{ " ++ hv 0 (!pp ++ str " }")
 
 let pp_connect (i,j,f1,f2) = pp_form f1 ++ str " => " ++ pp_form f2
 
 let pp_gl gl= cut () ++
-  str "{ " ++ vb 0 ++
+  str "{ " ++ hv 0 (
 	      begin
 		match gl.abs with
 		    None -> str ""
@@ -520,7 +520,7 @@ let pp_gl gl= cut () ++
   str "norev =" ++ pp_intmap gl.norev_hyps ++ cut () ++
   str "arrows=" ++ pp_mapint gl.right ++ cut () ++
   str "cnx   =" ++ pp_list pp_connect gl.cnx ++ cut () ++
-  str "goal  =" ++ pp_form gl.gl ++ str " }" ++ close ()
+  str "goal  =" ++ pp_form gl.gl ++ str " }")
 
 let pp =
   function
diff --git a/plugins/rtauto/refl_tauto.ml b/plugins/rtauto/refl_tauto.ml
index adb11f4f8..f30f8a943 100644
--- a/plugins/rtauto/refl_tauto.ml
+++ b/plugins/rtauto/refl_tauto.ml
@@ -8,6 +8,7 @@
 
 module Search = Explore.Make(Proof_search)
 
+open Ltac_plugin
 open CErrors
 open Util
 open Term
diff --git a/plugins/setoid_ring/RealField.v b/plugins/setoid_ring/RealField.v
index 293722125..facd2e062 100644
--- a/plugins/setoid_ring/RealField.v
+++ b/plugins/setoid_ring/RealField.v
@@ -59,11 +59,12 @@ Notation Rset := (Eqsth R).
 Notation Rext := (Eq_ext Rplus Rmult Ropp).
 
 Lemma Rlt_0_2 : 0 < 2.
+Proof.
 apply Rlt_trans with (0 + 1).
  apply Rlt_n_Sn.
  rewrite Rplus_comm.
    apply Rplus_lt_compat_l.
-    replace 1 with (0 + 1).
+    replace R1 with (0 + 1).
   apply Rlt_n_Sn.
   apply Rplus_0_l.
 Qed.
@@ -126,9 +127,17 @@ Ltac Rpow_tac t :=
   | _ => constr:(N.of_nat t)
   end.
 
-Add Field RField : Rfield
-   (completeness Zeq_bool_complete, power_tac R_power_theory [Rpow_tac]).
-
-
-
+Ltac IZR_tac t :=
+  match t with
+  | R0 => constr:(0%Z)
+  | R1 => constr:(1%Z)
+  | IZR ?u =>
+    match isZcst u with
+    | true => u
+    | _ => constr:(InitialRing.NotConstant)
+    end
+  | _ => constr:(InitialRing.NotConstant)
+  end.
 
+Add Field RField : Rfield
+   (completeness Zeq_bool_complete, constants [IZR_tac], power_tac R_power_theory [Rpow_tac]).
diff --git a/plugins/setoid_ring/g_newring.ml4 b/plugins/setoid_ring/g_newring.ml4
index b1882ae8a..05ab8ab32 100644
--- a/plugins/setoid_ring/g_newring.ml4
+++ b/plugins/setoid_ring/g_newring.ml4
@@ -8,6 +8,7 @@
 
 (*i camlp4deps: "grammar/grammar.cma" i*)
 
+open Ltac_plugin
 open Pp
 open Util
 open Libnames
diff --git a/plugins/setoid_ring/newring.ml b/plugins/setoid_ring/newring.ml
index f52557095..dd68eac24 100644
--- a/plugins/setoid_ring/newring.ml
+++ b/plugins/setoid_ring/newring.ml
@@ -6,6 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
+open Ltac_plugin
 open Pp
 open CErrors
 open Util
@@ -128,7 +129,7 @@ let closed_term_ast l =
     mltac_index = 0;
   } in
   let l = List.map (fun gr -> ArgArg(Loc.ghost,gr)) l in
-  TacFun([Some(Id.of_string"t")],
+  TacFun([Name(Id.of_string"t")],
   TacML(Loc.ghost,tacname,
   [TacGeneric (Genarg.in_gen (Genarg.glbwit Stdarg.wit_constr) (GVar(Loc.ghost,Id.of_string"t"),None));
    TacGeneric (Genarg.in_gen (Genarg.glbwit (Genarg.wit_list Stdarg.wit_ref)) l)]))
@@ -213,7 +214,7 @@ let exec_tactic env evd n f args =
   let lid = List.init n (fun i -> Id.of_string("x"^string_of_int i)) in
   let n = Genarg.in_gen (Genarg.glbwit Stdarg.wit_int) n in
   let get_res = TacML (Loc.ghost, get_res, [TacGeneric n]) in
-  let getter = Tacexp (TacFun (List.map (fun id -> Some id) lid, get_res)) in
+  let getter = Tacexp (TacFun (List.map (fun n -> Name n) lid, get_res)) in
   (** Evaluate the whole result *)
   let gl = dummy_goal env evd in
   let gls = Proofview.V82.of_tactic (Tacinterp.eval_tactic_ist ist (ltac_call f (args@[getter]))) gl in
@@ -331,14 +332,16 @@ let _ = add_map "ring"
   (map_with_eq
     [coq_cons,(function -1->Eval|2->Rec|_->Prot);
     coq_nil, (function -1->Eval|_ -> Prot);
+    my_reference "IDphi", (function _->Eval);
+    my_reference "gen_phiZ", (function _->Eval);
     (* Pphi_dev: evaluate polynomial and coef operations, protect
        ring operations and make recursive call on the var map *)
     pol_cst "Pphi_dev", (function -1|8|9|10|11|12|14->Eval|13->Rec|_->Prot);
     pol_cst "Pphi_pow",
-          (function -1|8|9|10|11|13|15|17->Eval|16->Rec|_->Prot);
+          (function -1|8|9|10|13|15|17->Eval|11|16->Rec|_->Prot);
     (* PEeval: evaluate morphism and polynomial, protect ring
        operations and make recursive call on the var map *)
-    pol_cst "PEeval", (function -1|7|9|12->Eval|11->Rec|_->Prot)])
+    pol_cst "PEeval", (function -1|8|10|13->Eval|12->Rec|_->Prot)])
 
 (****************************************************************************)
 (* Ring database *)
@@ -742,8 +745,8 @@ let ltac_ring_structure e =
   let pow_tac = tacarg e.ring_pow_tac in
   let lemma1 = carg e.ring_lemma1 in
   let lemma2 = carg e.ring_lemma2 in
-  let pretac = tacarg (TacFun([None],e.ring_pre_tac)) in
-  let posttac = tacarg (TacFun([None],e.ring_post_tac)) in
+  let pretac = tacarg (TacFun([Anonymous],e.ring_pre_tac)) in
+  let posttac = tacarg (TacFun([Anonymous],e.ring_post_tac)) in
   [req;sth;ext;morph;th;cst_tac;pow_tac;
    lemma1;lemma2;pretac;posttac]
 
@@ -775,12 +778,14 @@ let _ = add_map "field"
   (map_with_eq
     [coq_cons,(function -1->Eval|2->Rec|_->Prot);
     coq_nil, (function -1->Eval|_ -> Prot);
+    my_reference "IDphi", (function _->Eval);
+    my_reference "gen_phiZ", (function _->Eval);
     (* display_linear: evaluate polynomials and coef operations, protect
        field operations and make recursive call on the var map *)
     my_reference "display_linear",
       (function -1|9|10|11|12|13|15|16->Eval|14->Rec|_->Prot);
     my_reference "display_pow_linear",
-     (function -1|9|10|11|12|13|14|16|18|19->Eval|17->Rec|_->Prot);
+     (function -1|9|10|11|14|16|18|19->Eval|12|17->Rec|_->Prot);
    (* Pphi_dev: evaluate polynomial and coef operations, protect
        ring operations and make recursive call on the var map *)
     pol_cst "Pphi_dev", (function -1|8|9|10|11|12|14->Eval|13->Rec|_->Prot);
@@ -788,19 +793,20 @@ let _ = add_map "field"
           (function -1|8|9|10|11|13|15|17->Eval|16->Rec|_->Prot);
     (* PEeval: evaluate morphism and polynomial, protect ring
        operations and make recursive call on the var map *)
-    pol_cst "PEeval", (function -1|7|9|12->Eval|11->Rec|_->Prot);
+    pol_cst "PEeval", (function -1|8|10|13->Eval|12->Rec|_->Prot);
     (* FEeval: evaluate morphism, protect field
        operations and make recursive call on the var map *)
-    my_reference "FEeval", (function -1|8|9|10|11|14->Eval|13->Rec|_->Prot)]);;
+    my_reference "FEeval", (function -1|10|12|15->Eval|14->Rec|_->Prot)]);;
 
 let _ = add_map "field_cond"
   (map_without_eq
     [coq_cons,(function -1->Eval|2->Rec|_->Prot);
      coq_nil, (function -1->Eval|_ -> Prot);
-    (* PCond: evaluate morphism and denum list, protect ring
+     my_reference "IDphi", (function _->Eval);
+     my_reference "gen_phiZ", (function _->Eval);
+    (* PCond: evaluate denum list, protect ring
        operations and make recursive call on the var map *)
-     my_reference "PCond", (function -1|9|11|14->Eval|13->Rec|_->Prot)]);;
-(*                       (function -1|9|11->Eval|10->Rec|_->Prot)]);;*)
+     my_reference "PCond", (function -1|11|14->Eval|9|13->Rec|_->Prot)]);;
 
 
 let _ = Redexpr.declare_reduction "simpl_field_expr"
@@ -1025,8 +1031,8 @@ let ltac_field_structure e =
   let field_simpl_eq_ok = carg e.field_simpl_eq_ok in
   let field_simpl_eq_in_ok = carg e.field_simpl_eq_in_ok in
   let cond_ok = carg e.field_cond in
-  let pretac = tacarg (TacFun([None],e.field_pre_tac)) in
-  let posttac = tacarg (TacFun([None],e.field_post_tac)) in
+  let pretac = tacarg (TacFun([Anonymous],e.field_pre_tac)) in
+  let posttac = tacarg (TacFun([Anonymous],e.field_post_tac)) in
   [req;cst_tac;pow_tac;field_ok;field_simpl_ok;field_simpl_eq_ok;
    field_simpl_eq_in_ok;cond_ok;pretac;posttac]
 
diff --git a/plugins/ssrmatching/ssrmatching.ml4 b/plugins/ssrmatching/ssrmatching.ml4
index 1094d50af..01e20d0f1 100644
--- a/plugins/ssrmatching/ssrmatching.ml4
+++ b/plugins/ssrmatching/ssrmatching.ml4
@@ -15,6 +15,7 @@ let frozen_lexer = CLexer.freeze () ;;
 (*i camlp4use: "pa_extend.cmo" i*)
 (*i camlp4deps: "grammar/grammar.cma" i*)
 
+open Ltac_plugin
 open Names
 open Pp
 open Pcoq
@@ -1427,7 +1428,7 @@ let () =
   let name = { mltac_plugin = "ssrmatching_plugin"; mltac_tactic = "ssrpattern"; } in
   let () = Tacenv.register_ml_tactic name [|mltac|] in
   let tac =
-    TacFun ([Some (Id.of_string "pattern")],
+    TacFun ([Name (Id.of_string "pattern")],
       TacML (Loc.ghost, { mltac_name = name; mltac_index = 0 }, [])) in
   let obj () =
     Tacenv.register_ltac true false (Id.of_string "ssrpattern") tac in
diff --git a/plugins/syntax/r_syntax.ml b/plugins/syntax/r_syntax.ml
index 3ae2d45f3..8f065f528 100644
--- a/plugins/syntax/r_syntax.ml
+++ b/plugins/syntax/r_syntax.ml
@@ -9,6 +9,8 @@
 open Util
 open Names
 open Globnames
+open Glob_term
+open Bigint
 
 (* Poor's man DECLARE PLUGIN *)
 let __coq_plugin_name = "r_syntax_plugin"
@@ -17,95 +19,105 @@ let () = Mltop.add_known_module __coq_plugin_name
 exception Non_closed_number
 
 (**********************************************************************)
-(* Parsing R via scopes                                               *)
+(* Parsing positive via scopes                                        *)
 (**********************************************************************)
 
-open Glob_term
-open Bigint
+let binnums = ["Coq";"Numbers";"BinNums"]
 
 let make_dir l = DirPath.make (List.rev_map Id.of_string l)
-let rdefinitions = make_dir ["Coq";"Reals";"Rdefinitions"]
-let make_path dir id = Libnames.make_path dir (Id.of_string id)
+let make_path dir id = Libnames.make_path (make_dir dir) (Id.of_string id)
+
+let positive_path = make_path binnums "positive"
+
+(* TODO: temporary hack *)
+let make_kn dir id = Globnames.encode_mind dir id
+
+let positive_kn = make_kn (make_dir binnums) (Id.of_string "positive")
+let glob_positive = IndRef (positive_kn,0)
+let path_of_xI = ((positive_kn,0),1)
+let path_of_xO = ((positive_kn,0),2)
+let path_of_xH = ((positive_kn,0),3)
+let glob_xI = ConstructRef path_of_xI
+let glob_xO = ConstructRef path_of_xO
+let glob_xH = ConstructRef path_of_xH
+
+let pos_of_bignat dloc x =
+  let ref_xI = GRef (dloc, glob_xI, None) in
+  let ref_xH = GRef (dloc, glob_xH, None) in
+  let ref_xO = GRef (dloc, glob_xO, None) in
+  let rec pos_of x =
+    match div2_with_rest x with
+      | (q,false) -> GApp (dloc, ref_xO,[pos_of q])
+      | (q,true) when not (Bigint.equal q zero) -> GApp (dloc,ref_xI,[pos_of q])
+      | (q,true) -> ref_xH
+  in
+  pos_of x
+
+(**********************************************************************)
+(* Printing positive via scopes                                       *)
+(**********************************************************************)
+
+let rec bignat_of_pos = function
+  | GApp (_, GRef (_,b,_),[a]) when Globnames.eq_gr b glob_xO -> mult_2(bignat_of_pos a)
+  | GApp (_, GRef (_,b,_),[a]) when Globnames.eq_gr b glob_xI -> add_1(mult_2(bignat_of_pos a))
+  | GRef (_, a, _) when Globnames.eq_gr a glob_xH -> Bigint.one
+  | _ -> raise Non_closed_number
+
+(**********************************************************************)
+(* Parsing Z via scopes                                               *)
+(**********************************************************************)
 
+let z_path = make_path binnums "Z"
+let z_kn = make_kn (make_dir binnums) (Id.of_string "Z")
+let glob_z = IndRef (z_kn,0)
+let path_of_ZERO = ((z_kn,0),1)
+let path_of_POS = ((z_kn,0),2)
+let path_of_NEG = ((z_kn,0),3)
+let glob_ZERO = ConstructRef path_of_ZERO
+let glob_POS = ConstructRef path_of_POS
+let glob_NEG = ConstructRef path_of_NEG
+
+let z_of_int dloc n =
+  if not (Bigint.equal n zero) then
+    let sgn, n =
+      if is_pos_or_zero n then glob_POS, n else glob_NEG, Bigint.neg n in
+    GApp(dloc, GRef (dloc,sgn,None), [pos_of_bignat dloc n])
+  else
+    GRef (dloc, glob_ZERO, None)
+
+(**********************************************************************)
+(* Printing Z via scopes                                              *)
+(**********************************************************************)
+
+let bigint_of_z = function
+  | GApp (_, GRef (_,b,_),[a]) when Globnames.eq_gr b glob_POS -> bignat_of_pos a
+  | GApp (_, GRef (_,b,_),[a]) when Globnames.eq_gr b glob_NEG -> Bigint.neg (bignat_of_pos a)
+  | GRef (_, a, _) when Globnames.eq_gr a glob_ZERO -> Bigint.zero
+  | _ -> raise Non_closed_number
+
+(**********************************************************************)
+(* Parsing R via scopes                                               *)
+(**********************************************************************)
+
+let rdefinitions = ["Coq";"Reals";"Rdefinitions"]
 let r_path = make_path rdefinitions "R"
 
 (* TODO: temporary hack *)
 let make_path dir id = Globnames.encode_con dir (Id.of_string id)
 
-let r_kn = make_path rdefinitions "R"
-let glob_R = ConstRef r_kn
-let glob_R1 = ConstRef (make_path rdefinitions "R1")
-let glob_R0 = ConstRef (make_path rdefinitions "R0")
-let glob_Ropp = ConstRef (make_path rdefinitions "Ropp")
-let glob_Rplus = ConstRef (make_path rdefinitions "Rplus")
-let glob_Rmult = ConstRef (make_path rdefinitions "Rmult")
-
-let two = mult_2 one
-let three = add_1 two
-let four = mult_2 two
-
-(* Unary representation of strictly positive numbers *)
-let rec small_r dloc n =
-  if equal one n then GRef (dloc, glob_R1, None)
-  else GApp(dloc,GRef (dloc,glob_Rplus, None),
-            [GRef (dloc, glob_R1, None);small_r dloc (sub_1 n)])
-
-let r_of_posint dloc n =
-  let r1 = GRef (dloc, glob_R1, None) in
-  let r2 = small_r dloc two in
-  let rec r_of_pos n =
-    if less_than n four then small_r dloc n
-    else
-      let (q,r) = div2_with_rest n in
-      let b = GApp(dloc,GRef(dloc,glob_Rmult,None),[r2;r_of_pos q]) in
-      if r then GApp(dloc,GRef(dloc,glob_Rplus,None),[r1;b]) else b in
-  if not (Bigint.equal n zero) then r_of_pos n else GRef(dloc,glob_R0,None)
+let glob_IZR = ConstRef (make_path (make_dir rdefinitions) "IZR")
 
 let r_of_int dloc z =
-  if is_strictly_neg z then
-    GApp (dloc, GRef(dloc,glob_Ropp,None), [r_of_posint dloc (neg z)])
-  else
-    r_of_posint dloc z
+  GApp (dloc, GRef(dloc,glob_IZR,None), [z_of_int dloc z])
 
 (**********************************************************************)
 (* Printing R via scopes                                              *)
 (**********************************************************************)
 
-let bignat_of_r =
-(* for numbers > 1 *)
-let rec bignat_of_pos = function
-  (* 1+1 *)
-  | GApp (_,GRef (_,p,_), [GRef (_,o1,_); GRef (_,o2,_)])
-      when Globnames.eq_gr p glob_Rplus && Globnames.eq_gr o1 glob_R1 && Globnames.eq_gr o2 glob_R1 -> two
-  (* 1+(1+1) *)
-  | GApp (_,GRef (_,p1,_), [GRef (_,o1,_);
-      GApp(_,GRef (_,p2,_),[GRef(_,o2,_);GRef(_,o3,_)])])
-      when Globnames.eq_gr p1 glob_Rplus && Globnames.eq_gr p2 glob_Rplus &&
-           Globnames.eq_gr o1 glob_R1 && Globnames.eq_gr o2 glob_R1 && Globnames.eq_gr o3 glob_R1 -> three
-  (* (1+1)*b *)
-  | GApp (_,GRef (_,p,_), [a; b]) when Globnames.eq_gr p glob_Rmult ->
-      if not (Bigint.equal (bignat_of_pos a) two) then raise Non_closed_number;
-      mult_2 (bignat_of_pos b)
-  (* 1+(1+1)*b *)
-  | GApp (_,GRef (_,p1,_), [GRef (_,o,_); GApp (_,GRef (_,p2,_),[a;b])])
-      when Globnames.eq_gr p1 glob_Rplus && Globnames.eq_gr p2 glob_Rmult && Globnames.eq_gr o glob_R1  ->
-      if not (Bigint.equal (bignat_of_pos a) two) then raise Non_closed_number;
-        add_1 (mult_2 (bignat_of_pos b))
-  | _ -> raise Non_closed_number
-in
-let bignat_of_r = function
-  | GRef (_,a,_) when Globnames.eq_gr a glob_R0 -> zero
-  | GRef (_,a,_) when Globnames.eq_gr a glob_R1 -> one
-  | r -> bignat_of_pos r
-in
-bignat_of_r
-
 let bigint_of_r = function
-  | GApp (_,GRef (_,o,_), [a]) when Globnames.eq_gr o glob_Ropp ->
-      let n = bignat_of_r a in
-      if Bigint.equal n zero then raise Non_closed_number;
-      neg n
-  | a -> bignat_of_r a
+  | GApp (_,GRef (_,o,_), [a]) when Globnames.eq_gr o glob_IZR ->
+      bigint_of_z a
+  | _ -> raise Non_closed_number
 
 let uninterp_r p =
   try
@@ -113,12 +125,9 @@ let uninterp_r p =
   with Non_closed_number ->
     None
 
-let mkGRef gr = GRef (Loc.ghost,gr,None)
-
 let _ = Notation.declare_numeral_interpreter "R_scope"
   (r_path,["Coq";"Reals";"Rdefinitions"])
   r_of_int
-  (List.map mkGRef 
-    [glob_Ropp;glob_R0;glob_Rplus;glob_Rmult;glob_R1],
+  ([GRef (Loc.ghost,glob_IZR,None)],
     uninterp_r,
     false)