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

Last change on this file since 11659 was 11659, checked in by mevenson, 9 years ago

Re-enable compilation of TRACE forms.

Introduces a bug by including a reference to CLOS in the TRACE
facility, which makes tracing of forms that access the compiler
(FORMAT et. al.) problematic.

Proposed solution to ship as 0.13.0. --Mark

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 5.8 KB
Line 
1;;; trace.lisp
2;;;
3;;; Copyright (C) 2003-2007 Peter Graves
4;;; $Id: trace.lisp 11659 2009-02-14 16:00:51Z mevenson $
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(require "CLOS") ;; XXX This eventually blows up in the compiler, but
38     ;; works for a while.
39
40(defvar *trace-info-hashtable* (make-hash-table :test #'equal))
41
42(defstruct trace-info name untraced-function breakp)
43
44(defvar *trace-depth* 0
45  "Current depth of stack push for use of TRACE facility.")
46;;  XXX How can we "punt" on this form ???
47(defmethod make-load-form ((object trace-info) &optional environment)
48  (make-load-form-saving-slots object :environment environment))
49
50(defun list-traced-functions ()
51  (copy-list *traced-names*))
52
53(defmacro trace (&rest args)
54  (if args
55      (expand-trace args)
56      `(list-traced-functions)))
57
58(defun expand-trace (args)
59  (let ((results ())
60        (breakp nil))
61    (let ((index (position :break args)))
62      (when index
63        (setf breakp (nth (1+ index) args))
64        (setf args (append (subseq args 0 index) (subseq args (+ index 2))))))
65    (dolist (arg args)
66      (let ((info (make-trace-info :name arg
67                                   :breakp breakp)))
68        (push `(trace-1 ',arg ,info) results)))
69    `(list ,@(nreverse results))))
70
71(defun trace-1 (name info)
72  (unless (fboundp name)
73    (error "~S is not the name of a function." name))
74  (if (member name *traced-names* :test #'equal)
75      (format t "~S is already being traced." name)
76      (let* ((untraced-function (fdefinition name))
77             (traced-function
78              (traced-function name info untraced-function)))
79        (setf (trace-info-untraced-function info) untraced-function)
80        (let ((*warn-on-redefinition* nil))
81          (setf (fdefinition name) traced-function))
82        (setf (gethash name *trace-info-hashtable*) info)
83        (push name *traced-names*)))
84  name)
85
86(defun traced-function (name info untraced-function)
87  (let ((breakp (trace-info-breakp info))
88  (*trace-depth* *trace-depth*))
89    (lambda (&rest args)
90      (with-standard-io-syntax
91        (let ((*print-readably* nil)
92              (*print-structure* nil))
93          (%format *trace-output* (indent "~D: ~S~%") *trace-depth*
94                  (cons name args))))
95      (when breakp
96        (break))
97      (incf *trace-depth*)
98      (let ((results (multiple-value-list
99                      (unwind-protect
100                           (apply untraced-function args)
101                        (decf *trace-depth*)))))
102        (with-standard-io-syntax
103          (let ((*print-readably* nil)
104                (*print-structure* nil))
105            (%format *trace-output* (indent "~D: ~A returned") *trace-depth* name)
106            (if results
107                (dolist (result results)
108                  (%format *trace-output* " ~S" result))
109                (%format *trace-output* " no values"))
110            (terpri *trace-output*)))
111        (values-list results)))))
112
113(defun untraced-function (name)
114  (let ((info (gethash name *trace-info-hashtable*)))
115    (and info (trace-info-untraced-function info))))
116
117(defun trace-redefined-update (name untraced-function)
118  (when (and *traced-names* (find name *traced-names* :test #'equal))
119    (let* ((info (gethash name *trace-info-hashtable*))
120           (traced-function (traced-function name info untraced-function)))
121      (setf (trace-info-untraced-function info) untraced-function)
122      (let ((*traced-names* '()))
123        (setf (fdefinition name) traced-function)))))
124
125(defun indent (string)
126  (concatenate 'string
127               (make-string (* (1+ *trace-depth*) 2) :initial-element #\space)
128               string))
129
130(defmacro untrace (&rest args)
131  (cond ((null args)
132         `(untrace-all))
133        (t
134         `(progn ,@(mapcar (lambda (arg) `(untrace-1 ',arg)) args) t))))
135
136(defun untrace-all ()
137  (dolist (arg *traced-names*)
138    (untrace-1 arg))
139  t)
140
141(defun untrace-1 (name)
142  (cond ((member name *traced-names* :test #'equal)
143         (let* ((trace-info (gethash name *trace-info-hashtable*))
144                (untraced-function (trace-info-untraced-function trace-info))
145                (*warn-on-redefinition* nil))
146           (remhash name *trace-info-hashtable*)
147           (setf *traced-names* (remove name *traced-names*))
148           (setf (fdefinition name) untraced-function)))
149        (t
150         (format t "~S is not being traced.~%" name)))
151  nil)
Note: See TracBrowser for help on using the repository browser.