3 ;; JSCL is free software: you can redistribute it and/or
4 ;; modify it under the terms of the GNU General Public License as
5 ;; published by the Free Software Foundation, either version 3 of the
6 ;; License, or (at your option) any later version.
8 ;; JSCL is distributed in the hope that it will be useful, but
9 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
10 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
11 ;; General Public License for more details.
13 ;; You should have received a copy of the GNU General Public License
14 ;; along with JSCL. If not, see <http://www.gnu.org/licenses/>.
16 (/debug "loading misc.lisp!")
18 (defparameter *features* '(:jscl :common-lisp))
20 (defun lisp-implementation-type ()
24 (let ((start (gensym))
26 `(let ((,start (get-internal-real-time))
29 (setq ,end (get-internal-real-time))
30 (format t "Execution took ~a seconds.~%" (/ (- ,end ,start) 1000.0))))))
35 ;;; This trace implementation works on symbols, replacing the function
36 ;;; with a wrapper. So it will not trace calls to the function if they
37 ;;; got the function object before it was traced.
39 ;;; An alist of the form (NAME FUNCTION), where NAME is the name of a
40 ;;; function, and FUNCTION is the function traced.
41 (defvar *traced-functions* nil)
42 (defvar *trace-level* 0)
44 (defun trace-report-call (name args)
45 (dotimes (i *trace-level*) (write-string " "))
46 (format t "~a: ~S~%" *trace-level* (cons name args)))
48 (defun trace-report-return (name values)
49 (dotimes (i *trace-level*) (write-string " "))
50 (format t "~a: ~S returned " *trace-level* name)
51 (dolist (value values) (format t "~S " value))
54 (defun trace-functions (names)
56 (mapcar #'car *traced-functions*)
57 (dolist (name names names)
58 (if (find name *traced-functions* :key #'car)
59 (format t "`~S' is already traced.~%" name)
60 (let ((func (fdefinition name)))
61 (fset name (lambda (&rest args)
63 (trace-report-call name args)
64 (let ((*trace-level* (+ *trace-level* 1)))
65 (setq values (multiple-value-list (apply func args))))
66 (trace-report-return name values)
67 (values-list values))))
68 (push (cons name func) *traced-functions*))))))
70 (defun untrace-functions (names)
72 (setq names (mapcar #'car *traced-functions*)))
74 (let ((func (cdr (find name *traced-functions* :key #'car))))
77 (format t "~S is not being traced.~%" name)))))
79 (defmacro trace (&rest names)
80 `(trace-functions ',names))
82 (defmacro untrace (&rest names)
83 `(untrace-functions ',names))