From db2d654347e06fe7e40a498eee02e523936f4a53 Mon Sep 17 00:00:00 2001
From: Kaz Kylheku <kaz@kylheku.com>
Date: Fri, 17 Mar 2017 06:47:48 -0700
Subject: trace: implement redefinition checks.

The tracing module should warn when traced functions or
methods are being redefined, and stop tracing the original
methods.

* eval.c (trace_check): New function. Calls
sys:trace-redefined-check if the trace module has been
loaded, otherwise does nothing.
(op_defun, op_defmacro): Call trace_check to have a warning
issued for a redefined traced function or macro.

* eval.h (trace_check): Declared.

* lisplib.c (trace_loaded): New global variable.
(trace_instantiate): Flip trace_loaded to t.

* lisplib.h (trace_loaded): Declared.

* share/txr/stdlib/trace.tl (sys:trace-redefine-check): New
function. Checks two situations: traced function or method
is redefined (neither old nor new is traced any longer),
and traced method is overridden (base method continues to be
traced, override is not traced).

* struct.c (static_slot_ensure): Do a trace check here,
taking care of defmeth.
---
 eval.c                    | 15 +++++++++++++++
 eval.h                    |  1 +
 lisplib.c                 |  2 ++
 lisplib.h                 |  1 +
 share/txr/stdlib/trace.tl | 15 +++++++++++++++
 struct.c                  |  6 ++++++
 6 files changed, 40 insertions(+)

diff --git a/eval.c b/eval.c
index 873c810c..6f5d89c3 100644
--- a/eval.c
+++ b/eval.c
@@ -1775,6 +1775,17 @@ static val op_defsymacro(val form, val env)
 
 static val op_defmacro(val form, val env);
 
+void trace_check(val name)
+{
+  if (trace_loaded) {
+    val trcheck = lookup_fun(nil,
+                             intern(lit("trace-redefine-check"),
+                                    system_package));
+    if (trcheck)
+      funcall1(cdr(trcheck), name);
+  }
+}
+
 static val op_defun(val form, val env)
 {
   val args = rest(form);
@@ -1782,6 +1793,8 @@ static val op_defun(val form, val env)
   val params = second(args);
   val body = rest(rest(args));
 
+  trace_check(name);
+
   if (!consp(name)) {
     val block = cons(block_s, cons(name, body));
     val fun = cons(name, cons(params, cons(block, nil)));
@@ -1858,6 +1871,8 @@ static val op_defmacro(val form, val env)
   if (gethash(op_table, name))
     eval_error(form, lit("defmacro: ~s is a special operator"), name, nao);
 
+  trace_check(name);
+
   /* defmacro captures lexical environment, so env is passed */
   sethash(top_mb, name,
           rlcp_tree(cons(name, func_f2(cons(env, cons(params, cons(block, nil))),
diff --git a/eval.h b/eval.h
index bf97af3c..69391879 100644
--- a/eval.h
+++ b/eval.h
@@ -68,6 +68,7 @@ val apply_intrinsic(val fun, val args);
 val eval_progn(val forms, val env, val ctx_form);
 val eval(val form, val env, val ctx_form);
 val eval_intrinsic(val form, val env);
+void trace_check(val name);
 val format_field(val string_or_list, val modifier, val filter, val eval_fun);
 val subst_vars(val forms, val env, val filter);
 val expand_quasi(val quasi_forms, val menv);
diff --git a/lisplib.c b/lisplib.c
index 9d708a1c..cbe2de5d 100644
--- a/lisplib.c
+++ b/lisplib.c
@@ -44,6 +44,7 @@
 
 val dl_table;
 int opt_dbg_autoload;
+val trace_loaded;
 
 void set_dlt_entries(val dlt, val *name, val fun)
 {
@@ -392,6 +393,7 @@ static val trace_instantiate(val set_fun)
 {
   funcall1(set_fun, nil);
   load(format(nil, lit("~atrace.tl"), stdlib_path, nao));
+  trace_loaded = t;
   return nil;
 }
 
diff --git a/lisplib.h b/lisplib.h
index 57a98d6e..e54ec5c6 100644
--- a/lisplib.h
+++ b/lisplib.h
@@ -26,6 +26,7 @@
  */
 
 extern val dl_table;
+extern val trace_loaded;
 void lisplib_init(void);
 val lisplib_try_load(val sym);
 void set_dlt_entries(val dlt, val *name, val fun);
diff --git a/share/txr/stdlib/trace.tl b/share/txr/stdlib/trace.tl
index a184dbc8..940425c2 100644
--- a/share/txr/stdlib/trace.tl
+++ b/share/txr/stdlib/trace.tl
@@ -67,6 +67,21 @@
       (dohash (n v sys:*trace-hash*)
         (disable n n)))))
 
+(defun sys:trace-redefine-check (orig-name)
+  (let ((name (sys:trace-canonicalize-name orig-name)))
+    (when [sys:*trace-hash* name]
+      (catch
+        (cond
+          ((neq name orig-name)
+             (throwf 'warning "~!~s won't be traced, though it overrides\n\
+                               ~s which is currently traced"
+                      name orig-name))
+          (t (throwf 'warning "previously traced ~s is redefined and no\ \
+                               longer traced"
+                      name)
+             (sys:untrace (list name))))
+        (continue ())))))
+
 (defmacro trace (. names)
   ^(sys:trace ',names))
 
diff --git a/struct.c b/struct.c
index a4e9eb8f..bd9644be 100644
--- a/struct.c
+++ b/struct.c
@@ -1123,6 +1123,12 @@ val static_slot_ensure(val stype, val sym, val newval, val no_error_p)
     uw_throwf(error_s, lit("~a: ~s isn't a valid slot name"),
               self, sym, nao);
 
+  if (trace_loaded) {
+    struct struct_type *st = stype_handle(&stype, self);
+    val name = list(meth_s, st->name, sym, nao);
+    trace_check(name);
+  }
+
   no_error_p = default_bool_arg(no_error_p);
   return static_slot_ens_rec(stype, sym, newval, no_error_p, self, 0);
 }
-- 
cgit v1.2.3