home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 9 / 09.iso / e / e070 / 4.ddi / LISPLIB / TRACE.LSP < prev    next >
Encoding:
Text File  |  1984-11-06  |  2.4 KB  |  72 lines
  1. ;;; (C) Copyright 1984 by Gold Hill Computers
  2.  
  3. ;;; The TRACE facility
  4.  
  5. ;;; the interface macros are:
  6.  
  7. ;;;    (TRACE &REST functions)
  8. ;;;      TRACE of no args returns a list of the functions currently
  9. ;;;      being traced.
  10.  
  11. ;;;    (UNTRACE &rest fcns)
  12. ;;;      UNTRACE of no args untraces all the functions currently traced.
  13.  
  14. (defvar *trace-func-spec*)    
  15. (defvar *trace-func*)
  16. (defvar *trace-cnt* 0)
  17.  
  18. ;; TOPLEVEL macro
  19. (defmacro trace x
  20.   `(trace1 ',x))
  21.  
  22. (defun trace1 (fcns &aux *trace-func*)
  23.   (if (null fcns)
  24.       (get 'trace 'traced-funcs)
  25.       (progn
  26.         (when fcns (untrace1 fcns))
  27.         (dolist (*trace-func-spec* fcns t)
  28.           (cond ((fboundp *trace-func-spec*)
  29.                  (untrace *trace-func-spec*)
  30.                  (setq *trace-func* (symbol-function *trace-func-spec*))
  31.                  (fset *trace-func-spec* 
  32.                        (closure '(*trace-func* *trace-func-spec*)
  33.                                 'trace-internal))
  34.                  (setf (get 'trace 'traced-funcs)
  35.                        (cons *trace-func-spec* (get 'trace 'traced-funcs))))
  36.                 (t (error "~S is not a defined function."
  37.               *trace-func-spec*)))))))
  38.  
  39. ;; TOPLEVEL macro
  40. (defmacro untrace x
  41.   `(untrace1 ',x))
  42.  
  43. (defun untrace1 (funcs &aux untrace)
  44.   (when (null funcs) (setq funcs (get 'trace 'traced-funcs)))
  45.   (dolist (f funcs)
  46.     (when (member f (get 'trace 'traced-funcs))
  47.       (push f untrace)
  48.       (fset (getf (cdr (symbol-function f)) '*trace-func-spec*)
  49.             (getf (cdr (symbol-function f)) '*trace-func*))
  50.       (setf (get 'trace 'traced-funcs)
  51.         (delete f (get 'trace 'traced-funcs)))))
  52.   untrace)
  53.       
  54. ;; Function that is executed during a trace.
  55. (defun trace-internal (&rest arglist &aux value)
  56.   (funcall *trace-output* :fresh-line)
  57.   (dotimes (i *trace-cnt*) (funcall *trace-output* :WRITE-CHAR #\SPACE))
  58.   (format *trace-output* "Entering: ~S, Argument list: ~S~%"
  59.     *trace-func-spec* arglist)
  60.   (incf *trace-cnt*)
  61.   (unwind-protect
  62.     (progn
  63.       (setq value (multiple-value-list (apply *trace-func* arglist)))
  64.       (funcall *trace-output* :fresh-line)
  65.       (dotimes (i (1- *trace-cnt*)) 
  66.     (funcall *trace-output* :WRITE-CHAR #\SPACE))
  67.       (format *trace-output* "Exiting: ~S, Value~:[~;s list~]: ~S~%"
  68.         *trace-func-spec* (> (length value) 1)
  69.     (if (> (length value) 1) value (car value)))
  70.       (values-list value))
  71.     (decf *trace-cnt*)))
  72.