/[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.43.12.2 by rtoy, Tue Feb 9 23:42:32 2010 UTC revision 1.48 by rtoy, Tue Feb 22 22:56:15 2011 UTC
# Line 28  Line 28 
28  (use-package :fwrappers)  (use-package :fwrappers)
29    
30  (defvar *trace-values* nil  (defvar *trace-values* nil
31    _N"This is bound to the returned values when evaluating :BREAK-AFTER and    "This is bound to the returned values when evaluating :BREAK-AFTER and
32     :PRINT-AFTER forms.")     :PRINT-AFTER forms.")
33    
34  (defvar *max-trace-indentation* 40  (defvar *max-trace-indentation* 40
35    _N"If the trace indentation exceeds this value, then indentation restarts at    "If the trace indentation exceeds this value, then indentation restarts at
36     0.")     0.")
37    
38  (defvar *trace-encapsulate-default* :default  (defvar *trace-encapsulate-default* :default
39    _N"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*  (defvar *trace-encapsulate-package-names*
42    '("LISP"    '("LISP"
# Line 51  Line 51 
51      "SYSTEM"      "SYSTEM"
52      "COMPILER"      "COMPILER"
53      "TRACE")      "TRACE")
54    _N"List of package names.  Encapsulate functions from these packages    "List of package names.  Encapsulate functions from these packages
55     by default.  This should at least include the packages of functions     by default.  This should at least include the packages of functions
56     used by TRACE, directly or indirectly.")     used by TRACE, directly or indirectly.")
57    
# Line 163  Line 163 
163        (typecase x        (typecase x
164          (symbol          (symbol
165           (cond ((special-operator-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))))
# Line 302  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 398  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 458  Line 458 
458                      (nth-value 2 (trace-fdefinition definition))))                      (nth-value 2 (trace-fdefinition definition))))
459            (trace-fdefinition function-or-name))            (trace-fdefinition function-or-name))
460      (when (gethash (or local 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 :local-name local))      (let* ((debug-fun (di:function-debug-function fun :local-name local))
# Line 472  Line 472 
472                       encapsulate-p)                       encapsulate-p)
473                      (:compiled-closure                      (:compiled-closure
474                       (unless (functionp function-or-name)                       (unless (functionp function-or-name)
475                         (warn _"Tracing shared code for ~S:~%  ~S"                         (warn (intl:gettext "Tracing shared code for ~S:~%  ~S")
476                               function-or-name fun))                               function-or-name fun))
477                       encapsulate-p)                       encapsulate-p)
478                      ((:interpreted :interpreted-closure                      ((:interpreted :interpreted-closure
# Line 504  Line 504 
504                     (declare (ignore validp))                     (declare (ignore validp))
505                     (unless (or (stringp block-name)                     (unless (or (stringp block-name)
506                                 (fboundp block-name))                                 (fboundp block-name))
507                       (warn _"~S name is not a defined global function: ~S"                       (warn (intl:gettext "~S name is not a defined global function: ~S")
508                             type wherein))))))                             type wherein))))))
509          (verify-wherein (trace-info-wherein info) :wherein)          (verify-wherein (trace-info-wherein info) :wherein)
510          (verify-wherein (trace-info-wherein-only info) :wherein-only))          (verify-wherein (trace-info-wherein-only info) :wherein-only))
# Line 513  Line 513 
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.")
                  fun))  
         (when (listp fun)  
           (error _"Can't use encapsulation to trace local flet/labels function ~S."  
517                   fun))                   fun))
518            (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          (fwrap function-or-name #'trace-fwrapper :type 'trace
523                 :user-data info))                 :user-data info))
524         (t         (t
# Line 626  Line 627 
627               (t (return)))               (t (return)))
628             (pop current)             (pop current)
629             (unless current             (unless current
630               (error _"Missing argument to ~S TRACE option." option))               (error (intl:gettext "Missing argument to ~S TRACE option.") option))
631             (pop current)))             (pop current)))
632        current)))        current)))
633    
# Line 661  Line 662 
662                            (trace-1 name ',options))))))                            (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.             ;; Method name -> trace method functions.
668             ((and (consp name) (eq (car name) 'method))             ((and (consp name) (eq (car name) 'method))
# Line 689  Line 690 
690  ;;; TRACE -- Public.  ;;; TRACE -- Public.
691  ;;;  ;;;
692  (defmacro trace (&rest specs)  (defmacro trace (&rest specs)
693    _N"TRACE {Option Global-Value}* {Name {Option Value}*}*    "TRACE {Option Global-Value}* {Name {Option Value}*}*
694     TRACE is a debugging tool that prints information when specified functions     TRACE is a debugging tool that prints information when specified functions
695     are called.  In its simplest form:     are called.  In its simplest form:
696         (trace Name-1 Name-2 ...)         (trace Name-1 Name-2 ...)
# Line 786  Line 787 
787      (let* ((key (or local fun))      (let* ((key (or local fun))
788             (info (gethash key *traced-functions*)))             (info (gethash key *traced-functions*)))
789        (cond ((not info)        (cond ((not info)
790               (warn _"Function is not TRACE'd -- ~S." function-or-name))               (warn (intl:gettext "Function is not TRACE'd -- ~S.") function-or-name))
791              (t              (t
792               (cond ((trace-info-encapsulated info)               (cond ((trace-info-encapsulated info)
793                      (funwrap (trace-info-what info) :type 'trace))                      (funwrap (trace-info-what info) :type 'trace))
# Line 806  Line 807 
807    t)    t)
808    
809  (defmacro untrace (&rest specs)  (defmacro untrace (&rest specs)
810    _N"Removes tracing from the specified functions.  With no args, untraces all    "Removes tracing from the specified functions.  With no args, untraces all
811     functions."     functions."
812    (if specs    (if specs
813        (collect ((res))        (collect ((res))

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

  ViewVC Help
Powered by ViewVC 1.1.5