source: trunk/abcl/src/org/armedbear/lisp/trace.lisp @ 11627

Last change on this file since 11627 was 11627, checked in by ehuelsmann, 13 years ago

Make TRACE protect *TRACE-DEPTH* from non-local returns (such as RETURN to TOP-LEVEL restarts).
Also make TRACE no longer invoke CLOS (and thus the compiler,

making it possible to trace the compiler now, instead of getting a stack overflow.)

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 5.6 KB
Line 
1;;; trace.lisp
2;;;
3;;; Copyright (C) 2003-2007 Peter Graves
4;;; $Id: trace.lisp 11627 2009-02-05 20:13:27Z ehuelsmann $
5;;;
6;;; This program is free software; you can redistribute it and/or
7;;; modify it under the terms of the GNU General Public License
8;;; as published by the Free Software Foundation; either version 2
9;;; of the License, or (at your option) any later version.
10;;;
11;;; This program is distributed in the hope that it will be useful,
12;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14;;; GNU General Public License for more details.
15;;;
16;;; You should have received a copy of the GNU General Public License
17;;; along with this program; if not, write to the Free Software
18;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
19;;;
20;;; As a special exception, the copyright holders of this library give you
21;;; permission to link this library with independent modules to produce an
22;;; executable, regardless of the license terms of these independent
23;;; modules, and to copy and distribute the resulting executable under
24;;; terms of your choice, provided that you also meet, for each linked
25;;; independent module, the terms and conditions of the license of that
26;;; module.  An independent module is a module which is not derived from
27;;; or based on this library.  If you modify this library, you may extend
28;;; this exception to your version of the library, but you are not
29;;; obligated to do so.  If you do not wish to do so, delete this
30;;; exception statement from your version.
31
32(in-package "SYSTEM")
33
34(export 'untraced-function) ;; For FIND-GENERIC-FUNCTION in clos.lisp.
35
36(require "FORMAT")
37
38;;(require "CLOS")
39
40(defvar *trace-info-hashtable* (make-hash-table :test #'equal))
41
42(defstruct trace-info name untraced-function breakp)
43
44;;(defmethod make-load-form ((object trace-info) &optional environment)
45;;   (make-load-form-saving-slots object :environment environment))
46
47(defvar *trace-depth* 0)
48
49(defun list-traced-functions ()
50  (copy-list *traced-names*))
51
52(defmacro trace (&rest args)
53  (if args
54      (expand-trace args)
55      `(list-traced-functions)))
56
57(defun expand-trace (args)
58  (let ((results ())
59        (breakp nil))
60    (let ((index (position :break args)))
61      (when index
62        (setf breakp (nth (1+ index) args))
63        (setf args (append (subseq args 0 index) (subseq args (+ index 2))))))
64    (dolist (arg args)
65      (let ((info (make-trace-info :name arg
66                                   :breakp breakp)))
67        (push `(trace-1 ',arg ,info) results)))
68    `(list ,@(nreverse results))))
69
70(defun trace-1 (name info)
71  (unless (fboundp name)
72    (error "~S is not the name of a function." name))
73  (if (member name *traced-names* :test #'equal)
74      (format t "~S is already being traced." name)
75      (let* ((untraced-function (fdefinition name))
76             (traced-function
77              (traced-function name info untraced-function)))
78        (setf (trace-info-untraced-function info) untraced-function)
79        (let ((*warn-on-redefinition* nil))
80          (setf (fdefinition name) traced-function))
81        (setf (gethash name *trace-info-hashtable*) info)
82        (push name *traced-names*)))
83  name)
84
85(defun traced-function (name info untraced-function)
86  (let ((breakp (trace-info-breakp info))
87  (*trace-depth* *trace-depth*))
88    (lambda (&rest args)
89      (with-standard-io-syntax
90        (let ((*print-readably* nil)
91              (*print-structure* nil))
92          (%format *trace-output* (indent "~D: ~S~%") *trace-depth*
93                  (cons name args))))
94      (when breakp
95        (break))
96      (incf *trace-depth*)
97      (let ((results (multiple-value-list
98                      (unwind-protect
99                           (apply untraced-function args)
100                        (decf *trace-depth*)))))
101        (with-standard-io-syntax
102          (let ((*print-readably* nil)
103                (*print-structure* nil))
104            (%format *trace-output* (indent "~D: ~A returned") *trace-depth* name)
105            (if results
106                (dolist (result results)
107                  (%format *trace-output* " ~S" result))
108                (%format *trace-output* " no values"))
109            (terpri *trace-output*)))
110        (values-list results)))))
111
112(defun untraced-function (name)
113  (let ((info (gethash name *trace-info-hashtable*)))
114    (and info (trace-info-untraced-function info))))
115
116(defun trace-redefined-update (name untraced-function)
117  (when (and *traced-names* (find name *traced-names* :test #'equal))
118    (let* ((info (gethash name *trace-info-hashtable*))
119           (traced-function (traced-function name info untraced-function)))
120      (setf (trace-info-untraced-function info) untraced-function)
121      (let ((*traced-names* '()))
122        (setf (fdefinition name) traced-function)))))
123
124(defun indent (string)
125  (concatenate 'string
126               (make-string (* (1+ *trace-depth*) 2) :initial-element #\space)
127               string))
128
129(defmacro untrace (&rest args)
130  (cond ((null args)
131         `(untrace-all))
132        (t
133         `(progn ,@(mapcar (lambda (arg) `(untrace-1 ',arg)) args) t))))
134
135(defun untrace-all ()
136  (dolist (arg *traced-names*)
137    (untrace-1 arg))
138  t)
139
140(defun untrace-1 (name)
141  (cond ((member name *traced-names* :test #'equal)
142         (let* ((trace-info (gethash name *trace-info-hashtable*))
143                (untraced-function (trace-info-untraced-function trace-info))
144                (*warn-on-redefinition* nil))
145           (remhash name *trace-info-hashtable*)
146           (setf *traced-names* (remove name *traced-names*))
147           (setf (fdefinition name) untraced-function)))
148        (t
149         (format t "~S is not being traced.~%" name)))
150  nil)
Note: See TracBrowser for help on using the repository browser.