From: Nikodemus Siivola <nikodemus@random-state.net>
Date: Thu, 31 Jan 2008 13:04:30 +0000 (+0000)
Subject: 1.0.14.8: small TRACE and UNTRACE interface improvements
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=46c578f4cf21abde02e39a5da5a96dbd6653c4b8;p=sbcl.git

1.0.14.8: small TRACE and UNTRACE interface improvements

 * (TRACE "FOO") now traces SETF-functions as well.

 * (UNTRACE "FOO") is now supported.
---

diff --git a/NEWS b/NEWS
index 972c084..54bd730 100644
--- a/NEWS
+++ b/NEWS
@@ -3,6 +3,9 @@ changes in sbcl-1.0.15 relative to sbcl-1.0.14:
   * enhancement: cleaner backtraces for interactive interrupts, as
     well as other cases where the interesting frames used to be
     obscured by interrupt handling frames.
+  * enhancement: untracing a whole package using (UNTRACE "FOO") is
+    now supported, and tracing a whole package using (TRACE "FOO") now
+    traces SETF-functions as well.
   * bug fix: SORT was not interrupt safe.
   * bug fix: XREF accounts for the last node of each basic-block as
     well.
diff --git a/src/code/ntrace.lisp b/src/code/ntrace.lisp
index c9cca4d..b645387 100644
--- a/src/code/ntrace.lisp
+++ b/src/code/ntrace.lisp
@@ -513,11 +513,14 @@
            ((stringp name)
             (let ((package (find-undeleted-package-or-lose name)))
               (do-all-symbols (symbol (find-package name))
-                (when (and (eql package (symbol-package symbol))
-                           (fboundp symbol)
-                           (not (macro-function symbol))
-                           (not (special-operator-p symbol)))
-                  (forms `(trace-1 ',symbol ',options))))))
+                (when (eql package (symbol-package symbol))
+                  (when (and (fboundp symbol)
+                             (not (macro-function symbol))
+                             (not (special-operator-p symbol)))
+                    (forms `(trace-1 ',symbol ',options)))
+                  (let ((setf-name `(setf ,symbol)))
+                    (when (fboundp setf-name)
+                      (forms `(trace-1 ',setf-name ',options))))))))
            ;; special-case METHOD: it itself is not a general function
            ;; name symbol, but it (at least here) designates one of a
            ;; pair of such.
@@ -658,23 +661,30 @@ are evaluated in the null environment."
     (untrace-1 fun))
   t)
 
+(defun untrace-package (name)
+  (let ((package (find-package name)))
+    (when package
+      (dolist (fun (%list-traced-funs))
+        (cond ((and (symbolp fun) (eq package (symbol-package fun)))
+               (untrace-1 fun))
+              ((and (consp fun) (eq 'setf (car fun))
+                    (symbolp (second fun))
+                    (eq package (symbol-package (second fun))))
+               (untrace-1 fun)))))))
+
 (defmacro untrace (&rest specs)
   #+sb-doc
-  "Remove tracing from the specified functions. With no args, untrace all
-   functions."
-  ;; KLUDGE: Since we now allow (TRACE FOO BAR "SB-EXT") to trace not
-  ;; only #'FOO and #'BAR but also all the functions in #<PACKAGE "SB-EXT">,
-  ;; it would be probably be best for consistency to do something similar
-  ;; with UNTRACE. (But I leave it to someone who uses and cares about
-  ;; UNTRACE-with-args more often than I do.) -- WHN 2003-12-17
+  "Remove tracing from the specified functions. Untraces all
+functions when called with no arguments."
   (if specs
-      (collect ((res))
-        (let ((current specs))
-          (loop
-            (unless current (return))
-            (let ((name (pop current)))
-              (res (if (eq name :function)
-                       `(untrace-1 ,(pop current))
-                       `(untrace-1 ',name)))))
-          `(progn ,@(res) t)))
+      `(progn
+         ,@(loop while specs
+                 for name = (pop specs)
+                 collect (cond ((eq name :function)
+                                `(untrace-1 ,(pop specs)))
+                               ((stringp name)
+                                `(untrace-package ,name))
+                               (t
+                                `(untrace-1 ',name))))
+         t)
       '(untrace-all)))
diff --git a/version.lisp-expr b/version.lisp-expr
index 1f839d8..497066b 100644
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.14.7"
+"1.0.14.8"