Closures now wear the constant they originated from.

5 files changed, 16 insertions, 11 deletions

diff --git a/src/tac2core.ml b/src/tac2core.ml
index f4486bf0c8..793cb3e535 100644
--- a/src/tac2core.ml
+++ b/src/tac2core.ml
@@ -647,6 +647,7 @@ let () = define1 "case" begin fun f ->
   Proofview.tclCASE (thaw f) >>= begin function
   | Proofview.Next (x, k) ->
     let k = {
+      clos_ref = None;
       clos_env = Id.Map.singleton k_var (Value.of_ext Value.val_kont k);
       clos_var = [Name e_var];
       clos_exp = GTacPrm (prm_apply_kont_h, [GTacVar k_var; GTacVar e_var]);
diff --git a/src/tac2entries.ml b/src/tac2entries.ml
index 34022b86c9..0754108505 100644
--- a/src/tac2entries.ml
+++ b/src/tac2entries.ml
@@ -792,7 +792,7 @@ let call ~default e =
   let loc = loc_of_tacexpr e in
   let (e, t) = intern e in
   let () = check_unit ?loc t in
-  let tac = Tac2interp.interp Id.Map.empty e in
+  let tac = Tac2interp.interp Tac2interp.empty_environment e in
   solve default (Proofview.tclIGNORE tac)
 
 (** Primitive algebraic types than can't be defined Coq-side *)
diff --git a/src/tac2env.ml b/src/tac2env.ml
index 9aaaae0465..c04eaf7b0c 100644
--- a/src/tac2env.ml
+++ b/src/tac2env.ml
@@ -53,30 +53,32 @@ let empty_state = {
 let ltac_state = Summary.ref empty_state ~name:"ltac2-state"
 
 (** Get a dynamic value from syntactical value *)
-let rec eval_pure = function
+let rec eval_pure kn = function
 | GTacAtm (AtmInt n) -> ValInt n
 | GTacRef kn ->
   let { gdata_expr = e } =
     try KNmap.find kn ltac_state.contents.ltac_tactics
     with Not_found -> assert false
   in
-  eval_pure e
+  eval_pure (Some kn) e
 | GTacFun (na, e) ->
-  ValCls { clos_env = Id.Map.empty; clos_var = na; clos_exp = e }
+  ValCls { clos_ref = kn; clos_env = Id.Map.empty; clos_var = na; clos_exp = e }
 | GTacCst (_, n, []) -> ValInt n
-| GTacCst (_, n, el) -> ValBlk (n, Array.map_of_list eval_pure el)
-| GTacOpn (kn, el) -> ValOpn (kn, Array.map_of_list eval_pure el)
+| GTacCst (_, n, el) -> ValBlk (n, Array.map_of_list eval_unnamed el)
+| GTacOpn (kn, el) -> ValOpn (kn, Array.map_of_list eval_unnamed el)
 | GTacAtm (AtmStr _) | GTacLet _ | GTacVar _ | GTacSet _
 | GTacApp _ | GTacCse _ | GTacPrj _ | GTacPrm _ | GTacExt _ | GTacWth _ ->
   anomaly (Pp.str "Term is not a syntactical value")
 
+and eval_unnamed e = eval_pure None e
+
 let define_global kn e =
   let state = !ltac_state in
   ltac_state := { state with ltac_tactics = KNmap.add kn e state.ltac_tactics }
 
 let interp_global kn =
   let data = KNmap.find kn ltac_state.contents.ltac_tactics in
-  (data, eval_pure data.gdata_expr)
+  (data, eval_pure (Some kn) data.gdata_expr)
 
 let define_constructor kn t =
   let state = !ltac_state in
diff --git a/src/tac2expr.mli b/src/tac2expr.mli
index 1045063cd2..470323e7c7 100644
--- a/src/tac2expr.mli
+++ b/src/tac2expr.mli
@@ -201,6 +201,8 @@ and closure = {
   (** Bound variables *)
   clos_exp : glb_tacexpr;
   (** Body *)
+  clos_ref : ltac_constant option;
+  (** Global constant from which the closure originates *)
 }
 
 type ml_tactic = valexpr list -> valexpr Proofview.tactic
diff --git a/src/tac2interp.ml b/src/tac2interp.ml
index c15331571b..7bcfad1be1 100644
--- a/src/tac2interp.ml
+++ b/src/tac2interp.ml
@@ -47,7 +47,7 @@ let rec interp ist = function
 | GTacVar id -> return (get_var ist id)
 | GTacRef qid -> return (get_ref ist qid)
 | GTacFun (ids, e) ->
-  let cls = { clos_env = ist; clos_var = ids; clos_exp = e } in
+  let cls = { clos_ref = None; clos_env = ist; clos_var = ids; clos_exp = e } in
   return (ValCls cls)
 | GTacApp (f, args) ->
   interp ist f >>= fun f ->
@@ -63,7 +63,7 @@ let rec interp ist = function
 | GTacLet (true, el, e) ->
   let map (na, e) = match e with
   | GTacFun (ids, e) ->
-    let cls = { clos_env = ist; clos_var = ids; clos_exp = e } in
+    let cls = { clos_ref = None; clos_env = ist; clos_var = ids; clos_exp = e } in
     na, cls
   | _ -> anomaly (str "Ill-formed recursive function")
   in
@@ -102,12 +102,12 @@ let rec interp ist = function
   tpe.Tac2env.ml_interp ist e
 
 and interp_app f args = match f with
-| ValCls { clos_env = ist; clos_var = ids; clos_exp = e } ->
+| ValCls { clos_env = ist; clos_var = ids; clos_exp = e; clos_ref = kn } ->
   let rec push ist ids args = match ids, args with
   | [], [] -> interp ist e
   | [], _ :: _ -> interp ist e >>= fun f -> interp_app f args
   | _ :: _, [] ->
-    let cls = { clos_env = ist; clos_var = ids; clos_exp = e } in
+    let cls = { clos_ref = kn; clos_env = ist; clos_var = ids; clos_exp = e } in
     return (ValCls cls)
   | id :: ids, arg :: args -> push (push_name ist id arg) ids args
   in