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

Last change on this file was 14443, checked in by ehuelsmann, 8 years ago

Take advantage of PRINT-OBJECT functions having been defined
to create (humanly) readable output for complex data structures.

  • 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 14443 2013-03-23 00:02:10Z 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(defvar *trace-info-hashtable* (make-hash-table :test #'equal))
39
40(defstruct trace-info name untraced-function breakp)
41
42(defvar *trace-depth* 0
43  "Current depth of stack push for use of TRACE facility.")
44
45(defun list-traced-functions ()
46  (copy-list *traced-names*))
47
48(defmacro trace (&rest args)
49  (if args
50      (expand-trace args)
51      `(list-traced-functions)))
52
53(defun expand-trace (args)
54  (let ((results ())
55        (breakp nil))
56    (let ((index (position :break args)))
57      (when index
58        (setf breakp (nth (1+ index) args))
59        (setf args (append (subseq args 0 index) (subseq args (+ index 2))))))
60    (dolist (arg args)
61      (push `(trace-1 ',arg (make-trace-info :name ',arg
62                                             :breakp ,breakp)) results))
63    `(list ,@(nreverse results))))
64
65(defun trace-1 (name info)
66  (unless (fboundp name)
67    (error "~S is not the name of a function." name))
68  (if (member name *traced-names* :test #'equal)
69      (format t "~S is already being traced." name)
70      (let* ((untraced-function (fdefinition name))
71             (traced-function
72              (traced-function name info untraced-function)))
73        (setf (trace-info-untraced-function info) untraced-function)
74        (let ((*warn-on-redefinition* nil))
75          (setf (fdefinition name) traced-function))
76        (setf (gethash name *trace-info-hashtable*) info)
77        (push name *traced-names*)))
78  name)
79
80(defun traced-function (name info untraced-function)
81  (let ((breakp (trace-info-breakp info))
82  (*trace-depth* *trace-depth*))
83    (lambda (&rest args)
84      (with-standard-io-syntax
85        (let ((*print-readably* nil)
86              (*print-structure* nil))
87          (format *trace-output* (indent "~D: ~S~%") *trace-depth*
88                  (cons name args))))
89      (when breakp
90        (break))
91      (incf *trace-depth*)
92      (let ((results (multiple-value-list
93                      (unwind-protect
94                           (apply untraced-function args)
95                        (decf *trace-depth*)))))
96        (with-standard-io-syntax
97          (let ((*print-readably* nil)
98                (*print-structure* nil))
99            (format *trace-output* (indent "~D: ~A returned") *trace-depth* name)
100            (if results
101                (dolist (result results)
102                  (format *trace-output* " ~S" result))
103                (format *trace-output* " no values"))
104            (terpri *trace-output*)))
105        (values-list results)))))
106
107(defun untraced-function (name)
108  (let ((info (gethash name *trace-info-hashtable*)))
109    (and info (trace-info-untraced-function info))))
110
111(defun trace-redefined-update (name untraced-function)
112  (when (and *traced-names* (find name *traced-names* :test #'equal))
113    (let* ((info (gethash name *trace-info-hashtable*))
114           (traced-function (traced-function name info untraced-function)))
115      (setf (trace-info-untraced-function info) untraced-function)
116      (let ((*traced-names* '()))
117        (setf (fdefinition name) traced-function)))))
118
119(defun indent (string)
120  (concatenate 'string
121               (make-string (* (1+ *trace-depth*) 2) :initial-element #\space)
122               string))
123
124(defmacro untrace (&rest args)
125  (cond ((null args)
126         `(untrace-all))
127        (t
128         `(progn ,@(mapcar (lambda (arg) `(untrace-1 ',arg)) args) t))))
129
130(defun untrace-all ()
131  (dolist (arg *traced-names*)
132    (untrace-1 arg))
133  t)
134
135(defun untrace-1 (name)
136  (cond ((member name *traced-names* :test #'equal)
137         (let* ((trace-info (gethash name *trace-info-hashtable*))
138                (untraced-function (trace-info-untraced-function trace-info))
139                (*warn-on-redefinition* nil))
140           (remhash name *trace-info-hashtable*)
141           (setf *traced-names* (remove name *traced-names*))
142           (setf (fdefinition name) untraced-function)))
143        (t
144         (format t "~S is not being traced.~%" name)))
145  nil)
Note: See TracBrowser for help on using the repository browser.