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

Last change on this file since 8333 was 8333, checked in by piso, 17 years ago

Work in progress: (trace foo :break t)

File size: 3.4 KB
Line 
1;;; trace.lisp
2;;;
3;;; Copyright (C) 2003-2004 Peter Graves
4;;; $Id: trace.lisp,v 1.8 2005-01-10 15:42:52 piso Exp $
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(in-package #:system)
21
22(defconstant *untraced-function* (make-symbol "untraced-function"))
23
24(defvar *traced-functions* nil)
25
26(defvar *trace-depth* 0)
27
28(defun list-traced-functions ()
29  *traced-functions*)
30
31(defmacro trace (&rest args)
32  (setf *trace-depth* 0)
33  (if args
34      (expand-trace args)
35      '(list-traced-functions)))
36
37(defun expand-trace (args)
38  (let ((results ())
39        (breakp nil))
40    (let ((index (position :break args)))
41      (when index
42        (setf breakp (nth (1+ index) args))
43        (setf args (append (subseq args 0 index) (subseq args (+ index 2))))))
44    (dolist (arg args)
45      (if (trace-1 arg breakp)
46          (push arg results)))
47    `',results))
48
49(defun trace-1 (symbol breakp)
50  (unless (fboundp symbol)
51    (error "~S is not the name of a function" symbol))
52  (if (member symbol *traced-functions*)
53      (%format t "~S is already being traced." symbol)
54      (let* ((untraced-function (symbol-function symbol))
55             (trace-function
56              (lambda (&rest args)
57                (with-standard-io-syntax
58                    (%format t (indent "~D: ~S~%") *trace-depth*
59                             (append (list symbol) args)))
60                (when breakp
61                  (break))
62                (incf *trace-depth*)
63                (let ((r (multiple-value-list (apply untraced-function args))))
64                  (decf *trace-depth*)
65                  (with-standard-io-syntax
66                    (%format t (indent "~D: ~A returned") *trace-depth* symbol)
67                      (dolist (val r)
68                        (%format t " ~S" val))
69                      (%format t "~%"))
70                  (values-list r)))))
71        (setf (symbol-function symbol) trace-function)
72        (setf (get symbol *untraced-function*) untraced-function)
73        (push symbol *traced-functions*)
74        symbol)))
75
76(defun indent (string)
77  (concatenate 'string
78               (make-string (* (1+ *trace-depth*) 2) :initial-element #\space)
79               string))
80
81(defmacro untrace (&rest args)
82  (setf *trace-depth* 0)
83  (if (null args)
84      (untrace-all)
85      (dolist (arg args)
86        (if (member arg *traced-functions*)
87            (untrace-1 arg)
88            (%format t "~S is not being traced.~%" arg)))))
89
90(defun untrace-all ()
91  (dolist (arg *traced-functions*)
92    (untrace-1 arg)))
93
94(defun untrace-1 (symbol)
95  (let ((untraced-function (get symbol *untraced-function*)))
96    (setf (symbol-function symbol) untraced-function)
97    (remprop symbol *untraced-function*)
98    (setf *traced-functions* (remove symbol *traced-functions*))))
Note: See TracBrowser for help on using the repository browser.