Merge branch 'hashtables'
[jscl.git] / src / misc.lisp
1 ;;; misc.lisp --
2
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.
7 ;;
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.
12 ;;
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/>.
15
16 (/debug "loading misc.lisp!")
17
18 (defparameter *features* '(:jscl :common-lisp))
19
20 (defun lisp-implementation-type ()
21   "JSCL")
22
23 (defmacro time (form)
24   (let ((start (gensym))
25         (end (gensym)))
26     `(let ((,start (get-internal-real-time))
27            (,end))
28        (prog1 (progn ,form)
29          (setq ,end (get-internal-real-time))
30          (format t "Execution took ~a seconds.~%" (/ (- ,end ,start) 1000.0))))))
31
32
33 ;;;; TRACE
34
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.
38
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)
43
44 (defun trace-report-call (name args)
45   (dotimes (i *trace-level*) (write-string " "))
46   (format t "~a: ~S~%" *trace-level* (cons name args)))
47
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))
52   (format t "~%"))
53
54 (defun trace-functions (names)
55   (if (null 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)
62                            (let (values)
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*))))))
69
70 (defun untrace-functions (names)
71   (when (null names)
72     (setq names (mapcar #'car *traced-functions*)))
73   (dolist (name names)
74     (let ((func (cdr (find name *traced-functions* :key #'car))))
75       (if func
76           (fset name func)
77           (format t "~S is not being traced.~%" name)))))
78
79 (defmacro trace (&rest names)
80   `(trace-functions ',names))
81
82 (defmacro untrace (&rest names)
83   `(untrace-functions ',names))