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 (defun lisp-implementation-version ()
  24   #.*version*)
  25
  26 ;;; Javascript has not access to the hardware. Would it make sense to
  27 ;;; have the browser data as machine abstraction instead?
  28
  29 (defun machine-instance ()
  30   nil)
  31
  32 (defun machine-version ()
  33   nil)
  34
  35 (defun machine-type ()
  36   nil)
  37
  38
  39 (defmacro time (form)
  40   (let ((start (gensym))
  41         (end (gensym)))
  42     `(let ((,start (get-internal-real-time))
  43            (,end))
  44        (prog1 (progn ,form)
  45          (setq ,end (get-internal-real-time))
  46          (format t "Execution took ~a seconds.~%" (/ (- ,end ,start) 1000.0))))))
  47
  48
  49 ;;;; TRACE
  50
  51 ;;; This trace implementation works on symbols, replacing the function
  52 ;;; with a wrapper. So it will not trace calls to the function if they
  53 ;;; got the function object before it was traced.
  54
  55 ;;; An alist of the form (NAME FUNCTION), where NAME is the name of a
  56 ;;; function, and FUNCTION is the function traced.
  57 (defvar *traced-functions* nil)
  58 (defvar *trace-level* 0)
  59
  60 (defun trace-report-call (name args)
  61   (dotimes (i *trace-level*) (write-string " "))
  62   (format t "~a: ~S~%" *trace-level* (cons name args)))
  63
  64 (defun trace-report-return (name values)
  65   (dotimes (i *trace-level*) (write-string " "))
  66   (format t "~a: ~S returned " *trace-level* name)
  67   (dolist (value values) (format t "~S " value))
  68   (format t "~%"))
  69
  70 (defun trace-functions (names)
  71   (if (null names)
  72       (mapcar #'car *traced-functions*)
  73       (dolist (name names names)
  74         (if (find name *traced-functions* :key #'car)
  75             (format t "`~S' is already traced.~%" name)
  76             (let ((func (fdefinition name)))
  77               (fset name (lambda (&rest args)
  78                            (let (values)
  79                              (trace-report-call name args)
  80                              (let ((*trace-level* (+ *trace-level* 1)))
  81                                (setq values (multiple-value-list (apply func args))))
  82                              (trace-report-return name values)
  83                              (values-list values))))
  84               (push (cons name func) *traced-functions*))))))
  85
  86 (defun untrace-functions (names)
  87   (when (null names)
  88     (setq names (mapcar #'car *traced-functions*)))
  89   (dolist (name names)
  90     (let ((func (cdr (find name *traced-functions* :key #'car))))
  91       (if func
  92           (fset name func)
  93           (format t "~S is not being traced.~%" name)))))
  94
  95 (defmacro trace (&rest names)
  96   `(trace-functions ',names))
  97
  98 (defmacro untrace (&rest names)
  99   `(untrace-functions ',names))