source: trunk/j/src/org/armedbear/lisp/trace.lisp @ 11391

Last change on this file since 11391 was 11391, checked in by vvoutilainen, 13 years ago

ABCL license is GPL + Classpath exception. This was intended
by Peter Graves, the original author. For reference, see
http://sourceforge.net/mailarchive/forum.php?thread_name=20040721115302.839%40prufrock&forum_name=armedbear-j-announce

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 5.5 KB
Line 
1;;; trace.lisp
2;;;
3;;; Copyright (C) 2003-2007 Peter Graves
4;;; $Id: trace.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $
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 (apply untraced-function args))))
98        (decf *trace-depth*)
99        (with-standard-io-syntax
100          (let ((*print-readably* nil)
101                (*print-structure* nil))
102            (format *trace-output* (indent "~D: ~A returned") *trace-depth* name)
103            (if results
104                (dolist (result results)
105                  (format *trace-output* " ~S" result))
106                (format *trace-output* " no values"))
107            (terpri *trace-output*)))
108        (values-list results)))))
109
110(defun untraced-function (name)
111  (let ((info (gethash name *trace-info-hashtable*)))
112    (and info (trace-info-untraced-function info))))
113
114(defun trace-redefined-update (name untraced-function)
115  (when (and *traced-names* (find name *traced-names* :test #'equal))
116    (let* ((info (gethash name *trace-info-hashtable*))
117           (traced-function (traced-function name info untraced-function)))
118      (setf (trace-info-untraced-function info) untraced-function)
119      (let ((*traced-names* '()))
120        (setf (fdefinition name) traced-function)))))
121
122(defun indent (string)
123  (concatenate 'string
124               (make-string (* (1+ *trace-depth*) 2) :initial-element #\space)
125               string))
126
127(defmacro untrace (&rest args)
128  (cond ((null args)
129         `(untrace-all))
130        (t
131         `(progn ,@(mapcar (lambda (arg) `(untrace-1 ',arg)) args) t))))
132
133(defun untrace-all ()
134  (dolist (arg *traced-names*)
135    (untrace-1 arg))
136  t)
137
138(defun untrace-1 (name)
139  (cond ((member name *traced-names* :test #'equal)
140         (let* ((trace-info (gethash name *trace-info-hashtable*))
141                (untraced-function (trace-info-untraced-function trace-info))
142                (*warn-on-redefinition* nil))
143           (remhash name *trace-info-hashtable*)
144           (setf *traced-names* (remove name *traced-names*))
145           (setf (fdefinition name) untraced-function)))
146        (t
147         (format t "~S is not being traced.~%" name)))
148  nil)
Note: See TracBrowser for help on using the repository browser.