/[cmucl]/src/code/ntrace.lisp
ViewVC logotype

Diff of /src/code/ntrace.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.8.1.1 by ram, Tue Dec 8 23:29:07 1992 UTC revision 1.48 by rtoy, Tue Feb 22 22:56:15 2011 UTC
# Line 3  Line 3 
3  ;;; **********************************************************************  ;;; **********************************************************************
4  ;;; This code was written as part of the CMU Common Lisp project at  ;;; This code was written as part of the CMU Common Lisp project at
5  ;;; Carnegie Mellon University, and has been placed in the public domain.  ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;; If you want to use this code or any part of CMU Common Lisp, please contact  
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.  
6  ;;;  ;;;
7  (ext:file-comment  (ext:file-comment
8    "$Header$")    "$Header$")
# Line 18  Line 16 
16  ;;; **********************************************************************  ;;; **********************************************************************
17  ;;;  ;;;
18  (in-package "LISP")  (in-package "LISP")
19    (intl:textdomain "cmucl")
20    
21  (export '(trace untrace))  (export '(trace untrace))
22    
23  (in-package "DEBUG")  (in-package "DEBUG")
24    
25  (export '(*trace-values* *max-trace-indentation* *trace-encapsulate-default*))  (export '(*trace-values* *max-trace-indentation* *trace-encapsulate-default*
26              *trace-encapsulate-package-names*))
27    
28    (use-package :fwrappers)
29    
30  (defvar *trace-values* nil  (defvar *trace-values* nil
31    "This is bound to the returned values when evaluating :BREAK-AFTER and    "This is bound to the returned values when evaluating :BREAK-AFTER and
# Line 36  Line 38 
38  (defvar *trace-encapsulate-default* :default  (defvar *trace-encapsulate-default* :default
39    "The default value for the :ENCAPSULATE option to trace.")    "The default value for the :ENCAPSULATE option to trace.")
40    
41    (defvar *trace-encapsulate-package-names*
42      '("LISP"
43        "COMMON-LISP"
44        "CONDITIONS"
45        "DEBUG"
46        "EXTENSIONS"
47        "FORMAT"
48        "KERNEL"
49        "LOOP"
50        "PRETTY-PRINT"
51        "SYSTEM"
52        "COMPILER"
53        "TRACE")
54      "List of package names.  Encapsulate functions from these packages
55       by default.  This should at least include the packages of functions
56       used by TRACE, directly or indirectly.")
57    
58    
59  ;;;; Internal state:  ;;;; Internal state:
60    
61  ;;; A hash-table that maps each traced function to the TRACE-INFO.  The entry  ;;; A hash-table that maps each traced function to the TRACE-INFO.  The entry
62  ;;; for a closure is the shared function-entry object.  ;;; for a closure is the shared function-entry object.
63  ;;;  ;;;
64  (defvar *traced-functions* (make-hash-table :test #'eq))  (defvar *traced-functions* (make-hash-table :test #'equal))
65    
66  ;;; The TRACE-INFO structure represents all the information we need to trace a  ;;; The TRACE-INFO structure represents all the information we need to trace a
67  ;;; given function.  ;;; given function.
# Line 75  Line 94 
94    ;; The list of function names for wherein.  NIL means unspecified.    ;; The list of function names for wherein.  NIL means unspecified.
95    (wherein nil :type list)    (wherein nil :type list)
96    ;;    ;;
97      ;; Like wherein, but only if the caller is in the list.
98      (wherein-only nil :type list)
99      ;;
100    ;; The following slots represent the forms that we are supposed to evaluate    ;; The following slots represent the forms that we are supposed to evaluate
101    ;; on each iteration.  Each form is represented by a cons (Form . Function),    ;; on each iteration.  Each form is represented by a cons (Form . Function),
102    ;; where the Function is the cached result of coercing Form to a function.    ;; where the Function is the cached result of coercing Form to a function.
# Line 137  Line 159 
159  ;;; :FUNCALLABLE-INSTANCE.  ;;; :FUNCALLABLE-INSTANCE.
160  ;;;  ;;;
161  (defun trace-fdefinition (x)  (defun trace-fdefinition (x)
162    (multiple-value-bind    (multiple-value-bind (res named-p local)
       (res named-p)  
163        (typecase x        (typecase x
164          (symbol          (symbol
165           (cond ((special-form-p x)           (cond ((special-operator-p x)
166                  (error "Can't trace special form ~S." x))                  (error (intl:gettext "Can't trace special form ~S.") x))
167                 ((macro-function x))                 ((macro-function x))
168                 (t                 (t
169                  (values (fdefinition x) t))))                  (values (fdefinition x) t))))
170          (function x)          (function x)
171            ((cons (member flet labels))
172             ;; An extended function name for flet/labels functions.
173             (values (fdefinition (car (last x))) t x))
174          (t (values (fdefinition x) t)))          (t (values (fdefinition x) t)))
175      (if (eval:interpreted-function-p res)      (if (eval:interpreted-function-p res)
176          (values res named-p (if (eval:interpreted-function-closure res)          (values res named-p (if (eval:interpreted-function-closure res)
# Line 156  Line 180 
180             (values (kernel:%closure-function res) named-p :compiled-closure))             (values (kernel:%closure-function res) named-p :compiled-closure))
181            (#.vm:funcallable-instance-header-type            (#.vm:funcallable-instance-header-type
182             (values res named-p :funcallable-instance))             (values res named-p :funcallable-instance))
183            (t (values res named-p :compiled))))))            (t (values res named-p :compiled local))))))
184    
185    
186  ;;; TRACE-REDEFINED-UPDATE  --  Internal  ;;; TRACE-REDEFINED-UPDATE  --  Internal
# Line 166  Line 190 
190  ;;;  ;;;
191  (defun trace-redefined-update (fname new-value)  (defun trace-redefined-update (fname new-value)
192    (when (fboundp fname)    (when (fboundp fname)
193      (let* ((fun (trace-fdefinition fname))      (multiple-value-bind (fun named kind local)
194             (info (gethash fun *traced-functions*)))          (trace-fdefinition fname)
195        (when (and info (trace-info-named info))        (let* ((fkey (or local fun))
196          (untrace-1 fname)               (info (gethash fkey *traced-functions*)))
197          (trace-1 fname info new-value)))))          (flet ((handle-local-funs ()
198                     ;; FIXME: This is gross.  We need to grovel over the
199                     ;; *traced-functions* to see if any flet/labels functions
200                     ;; have been traced in the function we're redefining.
201                     (maphash #'(lambda (key info)
202                                  (when (and (listp key)
203                                             (eq fname (car (last key))))
204                                    (when info
205                                      (untrace-1 key)
206                                      (trace-1 key info new-value))))
207                              *traced-functions*)))
208              (when (and info (trace-info-named info))
209                (untrace-1 fname)
210                (trace-1 fname info new-value))
211              (handle-local-funs))))))
212    
213  ;;;  ;;;
214  (push #'trace-redefined-update ext:*setf-fdefinition-hook*)  (push #'trace-redefined-update ext:*setf-fdefinition-hook*)
215    
# Line 231  Line 270 
270  (defun trace-wherein-p (frame names)  (defun trace-wherein-p (frame names)
271    (do ((frame (di:frame-down frame) (di:frame-down frame)))    (do ((frame (di:frame-down frame) (di:frame-down frame)))
272        ((not frame) nil)        ((not frame) nil)
273      (when (member (di:debug-function-name (di:frame-debug-function frame))      (let ((frame-name (di:debug-function-name (di:frame-debug-function frame))))
274                    names :test #'equal)        (when (member frame-name names :test #'equal)
275        (return t))))          (return t)))))
276    
277    ;;; TRACE-WHEREIN-ONLY-P -- Internal
278    ;;;
279    ;;;    Like, TRACE-WHEREIN-ONLY-P, except true only if the last stack
280    ;;;    frame Frame has the given name.
281    (defun trace-wherein-only-p (frame name)
282      (let ((caller-frame (di::frame-down frame)))
283        (when caller-frame
284          (let ((frame-name (di:debug-function-name (di:frame-debug-function caller-frame))))
285            (member frame-name name :test #'equal)))))
286    
287  ;;; TRACE-PRINT  --  Internal  ;;; TRACE-PRINT  --  Internal
288  ;;;  ;;;
# Line 253  Line 302 
302    (when (and break (funcall (cdr break) frame))    (when (and break (funcall (cdr break) frame))
303      (di:flush-frames-above frame)      (di:flush-frames-above frame)
304      (let ((*stack-top-hint* frame))      (let ((*stack-top-hint* frame))
305        (break "Breaking ~A traced call to ~S:" where        (break (intl:gettext "Breaking ~A traced call to ~S:") where
306               (trace-info-what info)))))               (trace-info-what info)))))
307    
308  ;;; DISCARD-INVALID-ENTRIES  --  Internal  ;;; DISCARD-INVALID-ENTRIES  --  Internal
# Line 288  Line 337 
337           (declare (ignore bpt))           (declare (ignore bpt))
338           (discard-invalid-entries frame)           (discard-invalid-entries frame)
339           (let ((condition (trace-info-condition info))           (let ((condition (trace-info-condition info))
340                 (wherein (trace-info-wherein info)))                 (wherein (trace-info-wherein info))
341                   (wherein-only (trace-info-wherein-only info)))
342             (setq conditionp             (setq conditionp
343                   (and (not *in-trace*)                   (and (not *in-trace*)
344                        (or (not condition)                        (or (not condition)
345                            (funcall (cdr condition) frame))                            (funcall (cdr condition) frame))
346                        (or (not wherein)                        (or (not wherein)
347                            (trace-wherein-p frame wherein)))))                            (trace-wherein-p frame wherein))
348                          (or (not wherein-only)
349                              (trace-wherein-only-p frame wherein-only)))))
350    
351           (when conditionp           (when conditionp
352             (let ((*print-length* (or *debug-print-length* *print-length*))             (let ((*print-length* (or *debug-print-length* *print-length*))
# Line 307  Line 359 
359               (if (trace-info-encapsulated info)               (if (trace-info-encapsulated info)
360                   (locally (declare (special basic-definition argument-list))                   (locally (declare (special basic-definition argument-list))
361                     (prin1 `(,(trace-info-what info) ,@argument-list)))                     (prin1 `(,(trace-info-what info) ,@argument-list)))
362                   (print-frame-call-1 frame nil))                   (print-frame-call frame :verbosity 1))
363               (terpri)               (terpri)
364               (trace-print frame (trace-info-print info)))               (trace-print frame (trace-info-print info)))
365             (trace-maybe-break info (trace-info-break info) "before" frame)))             (trace-maybe-break info (trace-info-break info) "before" frame)))
# Line 346  Line 398 
398              (pprint-logical-block (*standard-output* nil)              (pprint-logical-block (*standard-output* nil)
399                (print-trace-indentation)                (print-trace-indentation)
400                (pprint-indent :current 2)                (pprint-indent :current 2)
401                (format t "~S returned" (trace-info-what info))                (format t (intl:gettext "~S returned") (trace-info-what info))
402                (dolist (v *trace-values*)                (dolist (v *trace-values*)
403                  (write-char #\space)                  (write-char #\space)
404                  (pprint-newline :linear)                  (pprint-newline :linear)
# Line 357  Line 409 
409                               "after" frame)))))                               "after" frame)))))
410    
411    
412  ;;; TRACE-CALL  --  Internal  ;;; TRACE-FWRAPPER  --  Internal
413  ;;;  ;;;
414  ;;;    This function is called by the trace encapsulation.  It calls the  ;;;    This function is called by the trace encapsulation.  It calls the
415  ;;; breakpoint hook functions with NIL for the breakpoint and cookie, which  ;;; breakpoint hook functions with NIL for the breakpoint and cookie, which
416  ;;; we have cleverly contrived to work for our hook functions.  ;;; we have cleverly contrived to work for our hook functions.
417  ;;;  ;;;
418  (defun trace-call (info)  (define-fwrapper trace-fwrapper (&rest args)
419    (multiple-value-bind    (let* ((info (fwrapper-user-data fwrapper))
420        (start cookie)           (name (trace-info-what info))
421        (trace-start-breakpoint-fun info)           (fdefn (lisp::fdefinition-object name nil))
422      (let ((frame (di:frame-down (di:top-frame))))           (basic-definition (fwrapper-next fwrapper))
423        (funcall start frame nil)           (argument-list args))
424        (let ((*traced-entries* *traced-entries*))      (declare (special basic-definition argument-list))
425          (declare (special basic-definition argument-list))      (letf (((lisp::fdefn-function fdefn) basic-definition))
426          (funcall cookie frame nil)        (multiple-value-bind (start cookie)
427          (let ((vals            (trace-start-breakpoint-fun info)
428                 (multiple-value-list          (let ((frame (di:frame-down (di:top-frame))))
429                  (apply basic-definition argument-list))))            (funcall start frame nil)
430            (funcall (trace-end-breakpoint-fun info) frame nil vals nil)            (let ((*traced-entries* *traced-entries*))
431            (values-list vals))))))              (funcall cookie frame nil)
432                (let ((vals (multiple-value-list (call-next-function))))
433                  (funcall (trace-end-breakpoint-fun info) frame nil vals nil)
434                  (values-list vals))))))))
435    
436    
437  ;;; TRACE-1 -- Internal.  ;;; TRACE-1 -- Internal.
# Line 389  Line 444 
444  ;;; automatically retracing; this  ;;; automatically retracing; this
445  ;;;  ;;;
446  (defun trace-1 (function-or-name info &optional definition)  (defun trace-1 (function-or-name info &optional definition)
447    (multiple-value-bind    (multiple-value-bind (fun named kind local)
448        (fun named kind)      (if definition
449        (if definition          ;; Tracing a new definition.  If function-or-name looks like a
450            (values definition t          ;; local function, we trace the new definition with the local
451                    (nth-value 2 (trace-fdefinition definition)))          ;; function.  Otherwise, we do what we used to do.
452            (if (and (valid-function-name-p function-or-name)
453                     (typep function-or-name '(cons (member flet labels))))
454                (multiple-value-bind (fun named kind)
455                    (trace-fdefinition definition)
456                  (values fun t kind function-or-name))
457                (values definition t
458                        (nth-value 2 (trace-fdefinition definition))))
459            (trace-fdefinition function-or-name))            (trace-fdefinition function-or-name))
460      (when (gethash fun *traced-functions*)      (when (gethash (or local fun) *traced-functions*)
461        (warn "Function ~S already TRACE'd, retracing it." function-or-name)        (warn (intl:gettext "Function ~S already TRACE'd, retracing it.") function-or-name)
462        (untrace-1 fun))        (untrace-1 fun))
463    
464      (let* ((debug-fun (di:function-debug-function fun))      (let* ((debug-fun (di:function-debug-function fun :local-name local))
465             (encapsulated             (encapsulated
466              (if (eq (trace-info-encapsulated info) :default)              (if (eq (trace-info-encapsulated info) :default)
467                  (ecase kind                  (let ((encapsulate-p
468                    (:compiled nil)                         (or (not (di::can-set-function-end-breakpoint-p debug-fun))
469                    (:compiled-closure                             (encapsulate-by-package-p function-or-name))))
470                     (unless (functionp function-or-name)                    (ecase kind
471                       (warn "Tracing shared code for ~S:~%  ~S"                      (:compiled
472                             function-or-name fun))                       encapsulate-p)
473                     nil)                      (:compiled-closure
474                    ((:interpreted :interpreted-closure :funcallable-instance)                       (unless (functionp function-or-name)
475                     t))                         (warn (intl:gettext "Tracing shared code for ~S:~%  ~S")
476                                 function-or-name fun))
477                         encapsulate-p)
478                        ((:interpreted :interpreted-closure
479                                       :funcallable-instance)
480                         t)))
481                  (trace-info-encapsulated info)))                  (trace-info-encapsulated info)))
482             (loc (if encapsulated             (loc (if encapsulated
483                      :encapsulated                      :encapsulated
# Line 420  Line 487 
487                    :named named                    :named named
488                    :encapsulated encapsulated                    :encapsulated encapsulated
489                    :wherein (trace-info-wherein info)                    :wherein (trace-info-wherein info)
490                      :wherein-only (trace-info-wherein-only info)
491                    :condition (coerce-form (trace-info-condition info) loc)                    :condition (coerce-form (trace-info-condition info) loc)
492                    :break (coerce-form (trace-info-break info) loc)                    :break (coerce-form (trace-info-break info) loc)
493                    :print (coerce-form-list (trace-info-print info) loc)                    :print (coerce-form-list (trace-info-print info) loc)
# Line 429  Line 497 
497                    :print-after                    :print-after
498                    (coerce-form-list (trace-info-print-after info) nil))))                    (coerce-form-list (trace-info-print-after info) nil))))
499    
500        (dolist (wherein (trace-info-wherein info))        (flet ((verify-wherein (wherein-info type)
501          (unless (or (stringp wherein)                 (dolist (wherein wherein-info)
502                      (fboundp wherein))                   (multiple-value-bind (validp block-name)
503            (warn ":WHEREIN name is not a defined global function: ~S"                       (ext:valid-function-name-p wherein)
504                  wherein)))                     (declare (ignore validp))
505                       (unless (or (stringp block-name)
506                                   (fboundp block-name))
507                         (warn (intl:gettext "~S name is not a defined global function: ~S")
508                               type wherein))))))
509            (verify-wherein (trace-info-wherein info) :wherein)
510            (verify-wherein (trace-info-wherein-only info) :wherein-only))
511    
512    
513        (cond        (cond
514         (encapsulated         (encapsulated
515          (unless named          (unless named
516            (error "Can't use encapsulation to trace anonymous function ~S."            (error (intl:gettext "Can't use encapsulation to trace anonymous function ~S.")
517                   fun))                   fun))
518          (ext:encapsulate function-or-name 'trace `(trace-call ',info)))          (when (and (listp function-or-name)
519                       (member function-or-name '(flet labels)))
520              (error (intl:gettext "Can't use encapsulation to trace local flet/labels function ~S.")
521                     function-or-name))
522            (fwrap function-or-name #'trace-fwrapper :type 'trace
523                   :user-data info))
524         (t         (t
525          (multiple-value-bind          (multiple-value-bind
526              (start-fun cookie-fun)              (start-fun cookie-fun)
# Line 462  Line 542 
542              (di:activate-breakpoint start)              (di:activate-breakpoint start)
543              (di:activate-breakpoint end)))))              (di:activate-breakpoint end)))))
544    
545        (setf (gethash fun *traced-functions*) info)))        (setf (gethash (or local fun) *traced-functions*) info)))
546    
547    function-or-name)    function-or-name)
548    
549    ;;;
550    ;;; Return true if FUNCTION-OR-NAME's package indicates that TRACE
551    ;;; should use encapsulation instead of function-end breakpoints.
552    ;;;
553    (defun encapsulate-by-package-p (function-or-name)
554      (multiple-value-bind (valid block)
555          (valid-function-name-p function-or-name)
556        (when (and valid (symbolp block))
557          (let* ((pkg (symbol-package block))
558                 (pkg-name (and pkg (package-name pkg))))
559            (member pkg-name *trace-encapsulate-package-names* :test #'equal)))))
560    
561    
562  ;;;; The TRACE macro:  ;;;; The TRACE macro:
563    
# Line 477  Line 569 
569  ;;;  ;;;
570  (defun parse-trace-options (specs info)  (defun parse-trace-options (specs info)
571    (let ((current specs))    (let ((current specs))
572      (loop      (flet ((collect-names (value)
573        (when (endp current) (return))               (collect ((new-names))
574        (let ((option (first current))                 (dolist (name (if (listp (car value)) (car value) value))
575              (value (cons (second current) nil)))                   (cond ((and (consp name) (eq (car name) 'method)
576          (case option                               (ext:valid-function-name-p name))
577            (:condition (setf (trace-info-condition info) value))                          ;; This needs to be coordinated with how the
578            (:condition-after                          ;; debugger prints method names.  So this is
579             (setf (trace-info-condition info) (cons nil nil))                          ;; what this code does.  Any method qualifiers
580             (setf (trace-info-condition-after info) value))                          ;; appear as a list in the debugger.  No
581            (:condition-all                          ;; qualifiers show up as NIL.  We also take the
582             (setf (trace-info-condition info) value)                          ;; method and add a pcl::fast-method in case the
583             (setf (trace-info-condition-after info) value))                          ;; method wasn't compiled.  (Do we need to do this?)
584            (:wherein                          (let ((method (cond ((atom (third name))
585             (setf (trace-info-wherein info)                                               `(,(second name) (,(third name)) ,@(cdddr name)))
586                   (if (listp (car value)) (car value) value)))                                              (t
587            (:encapsulate                                               `(,(second name) nil ,@(cddr name))))))
588             (setf (trace-info-encapsulated info) (car value)))                            (new-names `(pcl::fast-method ,@method))
589            (:break (setf (trace-info-break info) value))                            (new-names `(method ,@method))))
590            (:break-after (setf (trace-info-break-after info) value))                         (t
591            (:break-all                          (new-names name))))
592             (setf (trace-info-break info) value)                 (new-names))))
593             (setf (trace-info-break-after info) value))        (loop
594            (:print           (when (endp current) (return))
595             (setf (trace-info-print info)           (let ((option (first current))
596                   (append (trace-info-print info) (list value))))                 (value (cons (second current) nil)))
597            (:print-after             (case option
598             (setf (trace-info-print-after info)               (:condition (setf (trace-info-condition info) value))
599                   (append (trace-info-print-after info) (list value))))               (:condition-after
600            (:print-all                (setf (trace-info-condition info) (cons nil nil))
601             (setf (trace-info-print info)                (setf (trace-info-condition-after info) value))
602                   (append (trace-info-print info) (list value)))               (:condition-all
603             (setf (trace-info-print-after info)                (setf (trace-info-condition info) value)
604                   (append (trace-info-print-after info) (list value))))                (setf (trace-info-condition-after info) value))
605            (t (return)))               (:wherein
606          (pop current)                (setf (trace-info-wherein info) (collect-names value)))
607          (unless current               (:wherein-only
608            (error "Missing argument to ~S TRACE option." option))                (setf (trace-info-wherein-only info) (collect-names value)))
609          (pop current)))               (:encapsulate
610      current))                (setf (trace-info-encapsulated info) (car value)))
611                 (:break (setf (trace-info-break info) value))
612                 (:break-after (setf (trace-info-break-after info) value))
613                 (:break-all
614                  (setf (trace-info-break info) value)
615                  (setf (trace-info-break-after info) value))
616                 (:print
617                  (setf (trace-info-print info)
618                        (append (trace-info-print info) (list value))))
619                 (:print-after
620                  (setf (trace-info-print-after info)
621                        (append (trace-info-print-after info) (list value))))
622                 (:print-all
623                  (setf (trace-info-print info)
624                        (append (trace-info-print info) (list value)))
625                  (setf (trace-info-print-after info)
626                        (append (trace-info-print-after info) (list value))))
627                 (t (return)))
628               (pop current)
629               (unless current
630                 (error (intl:gettext "Missing argument to ~S TRACE option.") option))
631               (pop current)))
632          current)))
633    
634    
635  ;;; EXPAND-TRACE  --  Internal  ;;; EXPAND-TRACE  --  Internal
# Line 538  Line 652 
652              (let ((temp (gensym)))              (let ((temp (gensym)))
653                (binds `(,temp ,(pop current)))                (binds `(,temp ,(pop current)))
654                (forms `(trace-1 ,temp ',options))))                (forms `(trace-1 ,temp ',options))))
655               ;;
656               ;; Generic function -> trace all method functions.
657               ((eq name :methods)
658                (let ((tem (gensym)))
659                  (binds `(,tem ,(pop current)))
660                  (forms `(dolist (name (all-method-function-names ,tem))
661                            (when (fboundp name)
662                              (trace-1 name ',options))))))
663             ((and (keywordp name)             ((and (keywordp name)
664                   (not (or (fboundp name) (macro-function name))))                   (not (or (fboundp name) (macro-function name))))
665              (error "Unknown TRACE option: ~S" name))              (error (intl:gettext "Unknown TRACE option: ~S") name))
666               ;;
667               ;; Method name -> trace method functions.
668               ((and (consp name) (eq (car name) 'method))
669                (when (fboundp name)
670                  (forms `(trace-1 ',name ',options)))
671                (let ((name `(pcl::fast-method ,@(cdr name))))
672                  (when (fboundp name)
673                    (forms `(trace-1 ',name ',options)))))
674             (t             (t
675              (forms `(trace-1 ',name ',options))))              (forms `(trace-1 ',name ',options))))
676            (setq current (parse-trace-options current options)))))            (setq current (parse-trace-options current options)))))
# Line 565  Line 695 
695     are called.  In its simplest form:     are called.  In its simplest form:
696         (trace Name-1 Name-2 ...)         (trace Name-1 Name-2 ...)
697    
698       CLOS methods can be traced by specifying a name of the form
699       (METHOD {Qualifier}* ({Specializer}*)).
700    
701       Labels and Flet functions can be traced by specifying a name of the form
702       (LABELS <lfun> <fun>) or (FLET <lfun> <fun>) where <lfun> is the Labels/Flet
703       function in <fun>.
704    
705     TRACE causes a printout on *TRACE-OUTPUT* each time that one of the named     TRACE causes a printout on *TRACE-OUTPUT* each time that one of the named
706     functions is entered or returns (the Names are not evaluated.)  The output     functions is entered or returns (the Names are not evaluated.)  The output
707     is indented according to the number of pending traced calls, and this trace     is indented according to the number of pending traced calls, and this trace
# Line 591  Line 728 
728         nothing unless a call to one of those functions encloses the call to         nothing unless a call to one of those functions encloses the call to
729         this function (i.e. it would appear in a backtrace.)  Anonymous         this function (i.e. it would appear in a backtrace.)  Anonymous
730         functions have string names like \"DEFUN FOO\".         functions have string names like \"DEFUN FOO\".
731       :WHEREIN-ONLY Names
732           Like :WHEREIN, but only if the immediate caller is one of Names,
733           instead of being any where in a backtrace.
734    
735     :BREAK Form     :BREAK Form
736     :BREAK-AFTER Form     :BREAK-AFTER Form
# Line 602  Line 742 
742     :PRINT Form     :PRINT Form
743     :PRINT-AFTER Form     :PRINT-AFTER Form
744     :PRINT-ALL Form     :PRINT-ALL Form
745         In addition to the usual prinout, he result of evaluating Form is         In addition to the usual printout, the result of evaluating FORM is
746         printed at the start of the function, at the end of the function, or         printed at the start of the function, at the end of the function, or
747         both, according to the respective option.  Multiple print options cause         both, according to the respective option.  Multiple print options cause
748         multiple values to be printed.         multiple values to be printed.
# Line 612  Line 752 
752         what function to trace.  The Function-Form is evaluated immediately,         what function to trace.  The Function-Form is evaluated immediately,
753         and the resulting function is traced.         and the resulting function is traced.
754    
755       :METHODS Function-Form
756           This is a not really an option, but rather a way of specifying
757           that all methods of a generic functions should be traced.  The
758           Function-Form is evaluated immediately, and the methods of the resulting
759           generic function are traced.
760    
761     :ENCAPSULATE {:DEFAULT | T | NIL}     :ENCAPSULATE {:DEFAULT | T | NIL}
762         If T, the tracing is done via encapsulation (redefining the function         If T, the tracing is done via encapsulation (redefining the function
763         name) rather than by modifying the function.  :DEFAULT is the default,         name) rather than by modifying the function.  :DEFAULT is the default,
# Line 635  Line 781 
781  ;;;    Untrace one function.  ;;;    Untrace one function.
782  ;;;  ;;;
783  (defun untrace-1 (function-or-name)  (defun untrace-1 (function-or-name)
784    (let* ((fun (trace-fdefinition function-or-name))    (multiple-value-bind (fun named kind local)
785           (info (gethash fun *traced-functions*)))        (trace-fdefinition function-or-name)
786      (cond      (declare (ignore named kind))
787       ((not info) (warn "Function is not TRACE'd -- ~S." function-or-name))      (let* ((key (or local fun))
788       (t             (info (gethash key *traced-functions*)))
789        (cond        (cond ((not info)
790         ((trace-info-encapsulated info)               (warn (intl:gettext "Function is not TRACE'd -- ~S.") function-or-name))
791          (ext:unencapsulate (trace-info-what info) 'trace))              (t
792         (t               (cond ((trace-info-encapsulated info)
793          (di:delete-breakpoint (trace-info-start-breakpoint info))                      (funwrap (trace-info-what info) :type 'trace))
794          (di:delete-breakpoint (trace-info-end-breakpoint info))))                     (t
795        (setf (trace-info-untraced info) t)                      (di:delete-breakpoint (trace-info-start-breakpoint info))
796        (remhash fun *traced-functions*)))))                      (di:delete-breakpoint (trace-info-end-breakpoint info))))
797                 (setf (trace-info-untraced info) t)
798                 (remhash key *traced-functions*))))))
799    
800  ;;; UNTRACE-ALL  --  Internal  ;;; UNTRACE-ALL  --  Internal
801  ;;;  ;;;
# Line 667  Line 815 
815            (loop            (loop
816              (unless current (return))              (unless current (return))
817              (let ((name (pop current)))              (let ((name (pop current)))
818                (res (if (eq name :function)                (cond ((eq name :function)
819                         `(untrace-1 ,(pop current))                       (res `(untrace-1 ,(pop current))))
820                         `(untrace-1 ',name)))))                      ;;
821                        ;; Method name -> untrace existing method functions.
822                        ((and (consp name)
823                              (eq (car name) 'method))
824                         (when (fboundp name)
825                           (res `(untrace-1 ',name)))
826                         (let ((name `(pcl::fast-method ,@(cdr name))))
827                           (when (fboundp name)
828                             (res `(untrace-1 ',name)))))
829                        ;;
830                        ;; Generic function -> untrace all method functions.
831                        ((eq name :methods)
832                         (res
833                          `(dolist (name (all-method-function-names ,(pop current)))
834                             (when (fboundp name)
835                               (untrace-1 name)))))
836                        (t
837                         (res `(untrace-1 ',name))))))
838            `(progn ,@(res) t)))            `(progn ,@(res) t)))
839        '(untrace-all)))        '(untrace-all)))

Legend:
Removed from v.1.8.1.1  
changed lines
  Added in v.1.48

  ViewVC Help
Powered by ViewVC 1.1.5