1.0.31.23: OAOOize external-format support

[sbcl.git] / src / code / ntrace.lisp

diff --git a/src/code/ntrace.lisp b/src/code/ntrace.lisp
index 4404d66..ce60ee6 100644 (file)
--- a/src/code/ntrace.lisp
+++ b/src/code/ntrace.lisp
@@ -37,7 +37,7 @@
 
 ;;; a hash table that maps each traced function to the TRACE-INFO. The
 ;;; entry for a closure is the shared function entry object.
-(defvar *traced-funs* (make-hash-table :test 'eq))
+(defvar *traced-funs* (make-hash-table :test 'eq :synchronized t))
 
 ;;; A TRACE-INFO object represents all the information we need to
 ;;; trace a given function.
@@ -127,14 +127,17 @@
                 (values (fdefinition x) t))))
         (function x)
         (t (values (fdefinition x) t)))
-    (case (sb-kernel:widetag-of res)
-      (#.sb-vm:closure-header-widetag
+    (typecase res
+      (closure
        (values (sb-kernel:%closure-fun res)
                named-p
                :compiled-closure))
-      (#.sb-vm:funcallable-instance-header-widetag
+      (funcallable-instance
        (values res named-p :funcallable-instance))
-      (t (values res named-p :compiled)))))
+      ;; FIXME: What about SB!EVAL:INTERPRETED-FUNCTION -- it gets picked off
+      ;; by the FIN above, is that right?
+      (t
+       (values res named-p :compiled)))))
 
 ;;; When a function name is redefined, and we were tracing that name,
 ;;; then untrace the old definition and trace the new one.
@@ -513,11 +516,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 +664,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)))