trace: detect inheritance, change name and warn.

When a method is traced that is actually derived from
another struct type, we convert the (meth ...) name
to refer to that type and issue a warning.

* share/txr/stdlib/trace.tl (sys:trace-canonicalize-name): New
function.
(sys:trace): Canonicalize name, and trace the canonicalized
name. Warn if it is different from the original name.
(sys:untrace): Likewise for untracing.

1 files changed, 32 insertions, 10 deletions

diff --git a/share/txr/stdlib/trace.tl b/share/txr/stdlib/trace.tl
index 33a1bf08..a184dbc8 100644
--- a/share/txr/stdlib/trace.tl
+++ b/share/txr/stdlib/trace.tl
@@ -9,14 +9,30 @@
 (defun sys:trace-leave (name val)
   (format *trace-output* "~*a  ~s)\n" (* sys:*trace-level* 2) "" val))
 
+(defun sys:trace-canonicalize-name (name)
+  (if (and (consp name)
+           (eq (car name) 'meth))
+    (let* ((req-type (cadr name))
+           (sym (caddr name)))
+      (let ((actual-type (static-slot-home req-type sym)))
+        (if (eq req-type actual-type)
+          name
+          ^(meth ,actual-type ,sym))))
+    name))
+
 (defun sys:trace (names)
   (cond
     ((null names) (hash-keys sys:*trace-hash*))
     (t
-      (each ((n names))
+      (each ((orig-n names)
+             (n [mapcar sys:trace-canonicalize-name names]))
         (unless [sys:*trace-hash* n]
-          (let* ((name n)
-                 (prev (or (symbol-function n)
+          (when (neq n orig-n)
+            (catch
+              (throwf 'warning "~s: ~s is actually ~s: tracing that instead"
+                      'trace orig-n n)
+              (continue ())))
+          (let* ((prev (or (symbol-function n)
                            (throwf 'eval-error
                                    "~s: ~s does not name a function" 'trace n)))
                  (hook (lambda (. args)
@@ -24,26 +40,32 @@
                                (sys:*trace-level* (succ sys:*trace-level*)))
                            (unwind-protect
                              (progn
-                               (sys:trace-enter name args)
+                               (sys:trace-enter n args)
                                (let ((val (apply prev args)))
-                                 (sys:trace-leave name val)
+                                 (sys:trace-leave n val)
                                  (set abandoned nil)
                                  val))
                              (if abandoned
-                               (sys:trace-leave name :abandoned)))))))
+                               (sys:trace-leave n :abandoned)))))))
             (set [sys:*trace-hash* n] prev)
             (set (symbol-function n) hook)))))))
 
 (defun sys:untrace (names)
-  (flet ((disable (name)
+  (flet ((disable (name-orig name)
            (let ((prev (del [sys:*trace-hash* name])))
              (when prev
+               (when (neq name-orig name)
+                 (catch
+                   (throwf 'warning "~s: ~s is actually ~s: untracing that instead"
+                           'trace name-orig name)
+                   (continue ())))
                (set (symbol-function name) prev)))))
     (if names
-      (each ((n names))
-        (disable n))
+      (each ((n-orig names)
+             (n [mapcar sys:trace-canonicalize-name names]))
+        (disable n-orig n))
       (dohash (n v sys:*trace-hash*)
-        (disable n)))))
+        (disable n n)))))
 
 (defmacro trace (. names)
   ^(sys:trace ',names))