/[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 by rtoy, Wed Mar 11 01:19:27 2009 UTC revision 1.44 by rtoy, Fri Mar 19 15:18:59 2010 UTC
# Line 16  Line 16 
16  ;;; **********************************************************************  ;;; **********************************************************************
17  ;;;  ;;;
18  (in-package "LISP")  (in-package "LISP")
19    (intl:textdomain "cmucl")
20    
21  (export '(trace untrace))  (export '(trace untrace))
22    
# Line 27  Line 28 
28  (use-package :fwrappers)  (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    _N"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    "If the trace indentation exceeds this value, then indentation restarts at    _N"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    "The default value for the :ENCAPSULATE option to trace.")    _N"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 50  Line 51 
51      "SYSTEM"      "SYSTEM"
52      "COMPILER"      "COMPILER"
53      "TRACE")      "TRACE")
54    "List of package names.  Encapsulate functions from these packages    _N"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 162  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 _"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 301  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 _"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 397  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 _"~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 457  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 _"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 471  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 _"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 503  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 _"~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 512  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 _"Can't use encapsulation to trace anonymous function ~S."
517                   fun))                   fun))
518          (when (listp fun)          (when (listp fun)
519            (error "Can't use encapsulation to trace local flet/labels function ~S."            (error _"Can't use encapsulation to trace local flet/labels function ~S."
520                   fun))                   fun))
521          (fwrap function-or-name #'trace-fwrapper :type 'trace          (fwrap function-or-name #'trace-fwrapper :type 'trace
522                 :user-data info))                 :user-data info))
# Line 625  Line 626 
626               (t (return)))               (t (return)))
627             (pop current)             (pop current)
628             (unless current             (unless current
629               (error "Missing argument to ~S TRACE option." option))               (error _"Missing argument to ~S TRACE option." option))
630             (pop current)))             (pop current)))
631        current)))        current)))
632    
# Line 660  Line 661 
661                            (trace-1 name ',options))))))                            (trace-1 name ',options))))))
662             ((and (keywordp name)             ((and (keywordp name)
663                   (not (or (fboundp name) (macro-function name))))                   (not (or (fboundp name) (macro-function name))))
664              (error "Unknown TRACE option: ~S" name))              (error _"Unknown TRACE option: ~S" name))
665             ;;             ;;
666             ;; Method name -> trace method functions.             ;; Method name -> trace method functions.
667             ((and (consp name) (eq (car name) 'method))             ((and (consp name) (eq (car name) 'method))
# Line 688  Line 689 
689  ;;; TRACE -- Public.  ;;; TRACE -- Public.
690  ;;;  ;;;
691  (defmacro trace (&rest specs)  (defmacro trace (&rest specs)
692    "TRACE {Option Global-Value}* {Name {Option Value}*}*    _N"TRACE {Option Global-Value}* {Name {Option Value}*}*
693     TRACE is a debugging tool that prints information when specified functions     TRACE is a debugging tool that prints information when specified functions
694     are called.  In its simplest form:     are called.  In its simplest form:
695         (trace Name-1 Name-2 ...)         (trace Name-1 Name-2 ...)
# Line 785  Line 786 
786      (let* ((key (or local fun))      (let* ((key (or local fun))
787             (info (gethash key *traced-functions*)))             (info (gethash key *traced-functions*)))
788        (cond ((not info)        (cond ((not info)
789               (warn "Function is not TRACE'd -- ~S." function-or-name))               (warn _"Function is not TRACE'd -- ~S." function-or-name))
790              (t              (t
791               (cond ((trace-info-encapsulated info)               (cond ((trace-info-encapsulated info)
792                      (funwrap (trace-info-what info) :type 'trace))                      (funwrap (trace-info-what info) :type 'trace))
# Line 805  Line 806 
806    t)    t)
807    
808  (defmacro untrace (&rest specs)  (defmacro untrace (&rest specs)
809    "Removes tracing from the specified functions.  With no args, untraces all    _N"Removes tracing from the specified functions.  With no args, untraces all
810     functions."     functions."
811    (if specs    (if specs
812        (collect ((res))        (collect ((res))

Legend:
Removed from v.1.43  
changed lines
  Added in v.1.44

  ViewVC Help
Powered by ViewVC 1.1.5