diff --git a/code/ntrace.lisp b/code/ntrace.lisp index 2a8ce7b3434d7eea906b9018ebe2b9aca9a43091..9707c33626cee4a09c81e4479fd6dff52f4e9245 100644 --- a/code/ntrace.lisp +++ b/code/ntrace.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/ntrace.lisp,v 1.35 2006/02/20 00:57:47 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/ntrace.lisp,v 1.36 2006/10/02 13:40:55 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -93,6 +93,9 @@ ;; The list of function names for wherein. NIL means unspecified. (wherein nil :type list) ;; + ;; Like wherein, but only if the caller is in the list. + (wherein-only nil :type list) + ;; ;; The following slots represent the forms that we are supposed to evaluate ;; on each iteration. Each form is represented by a cons (Form . Function), ;; where the Function is the cached result of coercing Form to a function. @@ -255,6 +258,16 @@ (when (member frame-name names :test #'equal) (return t))))) +;;; TRACE-WHEREIN-ONLY-P -- Internal +;;; +;;; Like, TRACE-WHEREIN-ONLY-P, except true only if the last stack +;;; frame Frame has the given name. +(defun trace-wherein-only-p (frame name) + (let ((caller-frame (di::frame-down frame))) + (when caller-frame + (let ((frame-name (di:debug-function-name (di:frame-debug-function caller-frame)))) + (member frame-name name :test #'equal))))) + ;;; TRACE-PRINT -- Internal ;;; ;;; Handle print and print-after options. @@ -308,13 +321,16 @@ (declare (ignore bpt)) (discard-invalid-entries frame) (let ((condition (trace-info-condition info)) - (wherein (trace-info-wherein info))) + (wherein (trace-info-wherein info)) + (wherein-only (trace-info-wherein-only info))) (setq conditionp (and (not *in-trace*) (or (not condition) (funcall (cdr condition) frame)) (or (not wherein) - (trace-wherein-p frame wherein))))) + (trace-wherein-p frame wherein)) + (or (not wherein-only) + (trace-wherein-only-p frame wherein-only))))) (when conditionp (let ((*print-length* (or *debug-print-length* *print-length*)) @@ -447,6 +463,7 @@ :named named :encapsulated encapsulated :wherein (trace-info-wherein info) + :wherein-only (trace-info-wherein-only info) :condition (coerce-form (trace-info-condition info) loc) :break (coerce-form (trace-info-break info) loc) :print (coerce-form-list (trace-info-print info) loc) @@ -456,13 +473,17 @@ :print-after (coerce-form-list (trace-info-print-after info) nil)))) - (dolist (wherein (trace-info-wherein info)) - (multiple-value-bind (validp block-name) - (ext:valid-function-name-p wherein) - (unless (or (stringp block-name) - (fboundp block-name)) - (warn ":WHEREIN name is not a defined global function: ~S" - wherein)))) + (flet ((verify-wherein (wherein type) + (dolist (wherein (trace-info-wherein info)) + (multiple-value-bind (validp block-name) + (ext:valid-function-name-p wherein) + (unless (or (stringp block-name) + (fboundp block-name)) + (warn "~S name is not a defined global function: ~S" + type wherein)))))) + (verify-wherein (trace-info-wherein info) :wherein) + (verify-wherein (trace-info-wherein-only info) :wherein-only)) + (cond (encapsulated @@ -522,63 +543,67 @@ ;;; (defun parse-trace-options (specs info) (let ((current specs)) - (loop - (when (endp current) (return)) - (let ((option (first current)) - (value (cons (second current) nil))) - (case option - (:condition (setf (trace-info-condition info) value)) - (:condition-after - (setf (trace-info-condition info) (cons nil nil)) - (setf (trace-info-condition-after info) value)) - (:condition-all - (setf (trace-info-condition info) value) - (setf (trace-info-condition-after info) value)) - (:wherein - (collect ((new-names)) - (dolist (name (if (listp (car value)) (car value) value)) - (cond ((and (consp name) (eq (car name) 'method) - (ext:valid-function-name-p name)) - ;; This needs to be coordinated with how the - ;; debugger prints method names. So this is - ;; what this code does. Any method qualifiers - ;; appear as a list in the debugger. No - ;; qualifiers show up as NIL. We also take the - ;; method and add a pcl::fast-method in case the - ;; method wasn't compiled. (Do we need to do this?) - (let ((method (cond ((atom (third name)) - `(,(second name) (,(third name)) ,@(cdddr name))) - (t - `(,(second name) nil ,@(cddr name)))))) - (new-names `(pcl::fast-method ,@method)) - (new-names `(method ,@method)))) - (t - (new-names name)))) - (setf (trace-info-wherein info) (new-names)))) - (:encapsulate - (setf (trace-info-encapsulated info) (car value))) - (:break (setf (trace-info-break info) value)) - (:break-after (setf (trace-info-break-after info) value)) - (:break-all - (setf (trace-info-break info) value) - (setf (trace-info-break-after info) value)) - (:print - (setf (trace-info-print info) - (append (trace-info-print info) (list value)))) - (:print-after - (setf (trace-info-print-after info) - (append (trace-info-print-after info) (list value)))) - (:print-all - (setf (trace-info-print info) - (append (trace-info-print info) (list value))) - (setf (trace-info-print-after info) - (append (trace-info-print-after info) (list value)))) - (t (return))) - (pop current) - (unless current - (error "Missing argument to ~S TRACE option." option)) - (pop current))) - current)) + (flet ((collect-names (value) + (collect ((new-names)) + (dolist (name (if (listp (car value)) (car value) value)) + (cond ((and (consp name) (eq (car name) 'method) + (ext:valid-function-name-p name)) + ;; This needs to be coordinated with how the + ;; debugger prints method names. So this is + ;; what this code does. Any method qualifiers + ;; appear as a list in the debugger. No + ;; qualifiers show up as NIL. We also take the + ;; method and add a pcl::fast-method in case the + ;; method wasn't compiled. (Do we need to do this?) + (let ((method (cond ((atom (third name)) + `(,(second name) (,(third name)) ,@(cdddr name))) + (t + `(,(second name) nil ,@(cddr name)))))) + (new-names `(pcl::fast-method ,@method)) + (new-names `(method ,@method)))) + (t + (new-names name)))) + (new-names)))) + (loop + (when (endp current) (return)) + (let ((option (first current)) + (value (cons (second current) nil))) + (case option + (:condition (setf (trace-info-condition info) value)) + (:condition-after + (setf (trace-info-condition info) (cons nil nil)) + (setf (trace-info-condition-after info) value)) + (:condition-all + (setf (trace-info-condition info) value) + (setf (trace-info-condition-after info) value)) + (:wherein + (setf (trace-info-wherein info) (collect-names value))) + (:wherein-only + (setf (trace-info-wherein-only info) (collect-names value))) + (:encapsulate + (setf (trace-info-encapsulated info) (car value))) + (:break (setf (trace-info-break info) value)) + (:break-after (setf (trace-info-break-after info) value)) + (:break-all + (setf (trace-info-break info) value) + (setf (trace-info-break-after info) value)) + (:print + (setf (trace-info-print info) + (append (trace-info-print info) (list value)))) + (:print-after + (setf (trace-info-print-after info) + (append (trace-info-print-after info) (list value)))) + (:print-all + (setf (trace-info-print info) + (append (trace-info-print info) (list value))) + (setf (trace-info-print-after info) + (append (trace-info-print-after info) (list value)))) + (t (return))) + (pop current) + (unless current + (error "Missing argument to ~S TRACE option." option)) + (pop current))) + current))) ;;; EXPAND-TRACE -- Internal @@ -673,6 +698,9 @@ nothing unless a call to one of those functions encloses the call to this function (i.e. it would appear in a backtrace.) Anonymous functions have string names like \"DEFUN FOO\". + :WHEREIN-ONLY Names + Like :WHEREIN, but only if the immediate caller is one of Names, + instead of being any where in a backtrace. :BREAK Form :BREAK-AFTER Form diff --git a/general-info/release-19d.txt b/general-info/release-19d.txt index c635e72bd782a722087b484919684692901061d2..6c1c6e517988664b8970d176cf7e85afc9e88d49 100644 --- a/general-info/release-19d.txt +++ b/general-info/release-19d.txt @@ -119,6 +119,10 @@ New in this release: The entry exists as long as the key or the value are alive. These tables are currently experimental, but appear to work. + - TRACE supports an extra option, :WHEREIN-ONLY. This is + similar to the :WHEREIN option, except :WHEREIN-ONLY only + traces the function if the immediate caller is the specified + function(s). * Numerous ANSI compliance fixes: