home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / gcl-1.000 / gcl-1 / gcl-1.0 / lsp / trace.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1994-05-07  |  15.1 KB  |  454 lines
  1. ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa
  2.  
  3. ;; This file is part of GNU Common Lisp, herein referred to as GCL
  4. ;;
  5. ;; GCL is free software; you can redistribute it and/or modify it under
  6. ;;  the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by
  7. ;; the Free Software Foundation; either version 2, or (at your option)
  8. ;; any later version.
  9. ;; 
  10. ;; GCL is distributed in the hope that it will be useful, but WITHOUT
  11. ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  12. ;; FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Library General Public 
  13. ;; License for more details.
  14. ;; 
  15. ;; You should have received a copy of the GNU Library General Public License 
  16. ;; along with GCL; see the file COPYING.  If not, write to the Free Software
  17. ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  18.  
  19.  
  20. ;;;;        trace.lsp 
  21. ;;;;
  22. ;;;;        Tracer package for Common Lisp
  23.  
  24. ;;;;;; Modified by Matt Kaufmann to allow tracing options.
  25.  
  26.  
  27. ;; If you are working in another package you should (import 'si::arglist)
  28. ;; to avoid typing the si::
  29.  
  30. (in-package 'lisp)
  31.  
  32. (export '(trace untrace))
  33. (export 'step)
  34.  
  35.  
  36. (in-package 'system)
  37.  
  38. ;;(proclaim '(optimize (safety 2) (space 3)))
  39.  
  40.  
  41. (defvar *trace-level* 0)
  42. (defvar *trace-list* nil)
  43.  
  44.  
  45. (defmacro trace (&rest r)
  46.   (if (null r)
  47.       '(mapcar #'car *trace-list*)
  48.     `(let ((old (copy-list *trace-list*)) finish-flg)
  49.        (unwind-protect
  50.        (prog1 (mapcan #'trace-one ',r)
  51.          (setq finish-flg t))
  52.      (when (null finish-flg)
  53.            (format *standard-output* "~%Newly traced functions:  ~S"
  54.                (mapcar #'car (set-difference *trace-list* old :test #'equal))))))))
  55.  
  56. (defmacro untrace (&rest r)
  57.   (if (null r)
  58.       '(mapcan #'untrace-one (mapcar #'car *trace-list*))
  59.       `(mapcan #'untrace-one ',r)))
  60.  
  61. (defun trace-one-preprocess (x)
  62.   (cond
  63.    ((symbolp x)
  64.     (trace-one-preprocess (list x)))
  65.    (t                    ; We've checked for CONSP with null last CDR
  66.     (do ((tail (cdr x) (cddr tail))
  67.      (declarations)
  68.      (entryform `(cons (quote ,(car x)) arglist))
  69.      (exitform `(cons (quote ,(car x)) values))
  70.      (condform t)
  71.      (entrycondform t)
  72.      (exitcondform t)
  73.      (depth) (depthvar))
  74.     ((null tail)
  75.      (when depth
  76.            ;; Modify the :cond so that it first checks depth, and then
  77.            ;; modify the :entry so that it first increments depth.  Notice
  78.            ;; that :cond will be fully evaluated before depth is incremented.
  79.            (setq depthvar (gensym))
  80.            ;; now reset the condform
  81.            (if
  82.         (eq condform t)
  83.         (setq condform
  84.               `(< ,depthvar ,depth))
  85.          (setq condform `(if (< ,depthvar ,depth) ,condform nil)))
  86.            (setq declarations (cons (cons depthvar 0) declarations))
  87.            ;; I'll have the depth be incremented for all the entry stuff and no exit stuff,
  88.            ;; since I don't see any more uniform, logical way to do this.
  89.            (setq entrycondform
  90.              `(progn
  91.             (setq ,depthvar (1+ ,depthvar))
  92.             ,entrycondform))
  93.            (setq exitcondform
  94.              `(progn
  95.               (setq ,depthvar (1- ,depthvar))
  96.             ,exitcondform)))
  97.      `(,(car x) ,declarations
  98.        (quote ,condform)
  99.        (quote ,entrycondform) (quote ,entryform)
  100.        (quote ,exitcondform) (quote ,exitform)))
  101.     (case (car tail)
  102.           (:declarations
  103.            (setq declarations
  104.              (do ((decls (cadr tail) (cdr decls))
  105.               (result))
  106.              ((null decls) result)
  107.              (setq result
  108.                    (cons (if (symbolp (car decls))
  109.                      (cons (car decls) nil)
  110.                        (cons (caar decls) (eval (cadar decls))))
  111.                      result)))))
  112.           (:cond (setq condform (cadr tail)))
  113.           (:entrycond (setq entrycondform (cadr tail)))
  114.           (:entry (setq entryform (cadr tail)))
  115.           (:exitcond (setq exitcondform (cadr tail)))
  116.           (:exit (setq exitform (cadr tail))) 
  117.           (:depth (setq depth (cadr tail)))
  118.           (otherwise nil))))))
  119.  
  120. (defun check-trace-spec (form)
  121.   (or (symbolp form)
  122.       (if (and (consp form) (null (cdr (last form))))
  123.       (check-trace-args form (cdr form) nil)
  124.     (error "Each trace spec must be a symbol or a list terminating in NIL, but ~S is not~&."
  125.            form))))
  126.  
  127. (defun check-declarations (declarations &aux decl)
  128.   (when (consp declarations)
  129.     (setq decl (if (consp (car declarations)) (car declarations) (list (car declarations) nil)))
  130.     (when (not (symbolp (car decl)))
  131.           (error "Declarations are supposed to be of symbols, but ~S is not a symbol.~&"
  132.              (car decl)))
  133.     (when (cddr decl)
  134.           (error "Expected a CDDR of NIL in ~S.~&"
  135.              decl))
  136.     (when (assoc (car decl) (all-trace-declarations))
  137.           (error "The variable ~A is already declared for tracing"
  138.              (car decl)))))
  139.  
  140. (defun check-trace-args (form args acc-keywords)
  141.   (when args
  142.     (cond
  143.      ((null (cdr args))
  144.       (error "A trace spec must have odd length, but ~S does not.~&"
  145.          form))
  146.      ((member (car args) acc-keywords)
  147.       (error "The keyword ~A occurred twice in the spec ~S~&"
  148.          (car args) form))
  149.      (t
  150.       (case (car args)
  151.         ((:entry :exit :cond :entrycond :exitcond)
  152.          (check-trace-args form (cddr args) (cons (car args) acc-keywords)))
  153.         (:depth
  154.          (when (not (and (integerp (cadr args))
  155.                  (> (cadr args) 0)))
  156.                (error
  157.             "~&Specified depth should be a positive integer, but~&~S is not.~&"
  158.             (cadr args)))
  159.          (check-trace-args form (cddr args) (cons :depth acc-keywords)))
  160.         (:declarations
  161.          (check-declarations (cadr args))
  162.          (check-trace-args form (cddr args) (cons :declarations acc-keywords)))
  163.         (otherwise
  164.          (error "Expected :entry, :exit, :cond, :depth, or :declarations~&~
  165.                          in ~S where instead there was ~S~&"
  166.             form (car args))))))))
  167.  
  168. (defun trace-one (form &aux f (fname (if (consp form) (car form) form)))
  169.   (when (null (fboundp fname))
  170.         (format *trace-output* "The function ~S is not defined.~%" fname)
  171.         (return-from trace-one nil))
  172.   (when (special-form-p fname)
  173.         (format *trace-output* "~S is a special form.~%" fname)
  174.         (return-from trace-one nil))
  175.   (when (macro-function fname)
  176.         (format *trace-output* "~S is a macro.~%" fname)
  177.         (return-from trace-one nil))
  178.   (when (get fname 'traced)
  179.     (untrace-one fname))
  180.   (check-trace-spec form)
  181.   (setq form (trace-one-preprocess form))
  182.   (si:fset (setq f (gensym)) (symbol-function fname))
  183.   (eval `(defun ,fname (&rest args)
  184.        (trace-call ',f args
  185.                ,@(cddr form))))
  186.   (si:putprop fname f 'traced)
  187.   (setq *trace-list* (cons (cons fname (cadr form)) *trace-list*))
  188.   (list fname))
  189.  
  190. (defun reset-trace-declarations (declarations)
  191.   (when declarations
  192.     (set (caar declarations) (cdar declarations))
  193.     (reset-trace-declarations (cdr declarations))))
  194.  
  195. (defun all-trace-declarations ( &aux result)
  196.   (dolist (v *trace-list*)
  197.       (setq result (append result (cdr v))))
  198.   result)
  199.       
  200. (defun trace-call (temp-name args cond entrycond entry exitcond exit
  201.              &aux (*trace-level* *trace-level*) vals indent)
  202.   (when (= *trace-level* 0)
  203.     (reset-trace-declarations (all-trace-declarations)))
  204.   (cond
  205.    ((eval `(let ((arglist (quote ,args))) ,cond))
  206.     (setq *trace-level* (1+ *trace-level*))
  207.     (setq indent (min (* *trace-level* 2) 20))
  208.     (fresh-line *trace-output*)
  209.     (when (or (eq entrycond t)        ;optimization for common value
  210.           (eval `(let ((arglist (quote ,args))) ,entrycond)))
  211.       ;; put out the prompt before evaluating
  212.       (format *trace-output*
  213.           "~V@T~D> "
  214.           indent *trace-level*)
  215.       (format *trace-output*
  216.           "~S~%"
  217.           (eval `(let ((arglist (quote ,args))) ,entry)))
  218.       (fresh-line *trace-output*))
  219.     (setq vals (multiple-value-list (apply temp-name args)))
  220.     (when (or (eq exitcond t)        ;optimization for common value
  221.           (eval `(let ((arglist (quote ,args)) (values (quote ,vals)))
  222.                ,exitcond)))
  223.       ;; put out the prompt before evaluating
  224.       (format *trace-output*
  225.           "~V@T<~D "
  226.           indent
  227.           *trace-level*) 
  228.       (format *trace-output*
  229.           "~S~%"
  230.           (eval `(let ((arglist (quote ,args)) (values (quote ,vals))) ,exit))))
  231.     (setq *trace-level* (1- *trace-level*))
  232.     (values-list vals))
  233.    (t (apply temp-name args))))
  234.  
  235. (defun untrace-one (fname &aux sym)
  236.   (cond ((setq sym (get fname 'traced))
  237.      (remprop fname 'traced)
  238.      (cond
  239.       ((not (fboundp fname))
  240.        (format *trace-output*
  241.            "The function ~S was traced, but is no longer defined.~%"
  242.            fname))
  243.  
  244.       ;;(LAMBDA-BLOCK block-name lambda-list (TRACE-CALL ... ))
  245.       ((and (consp (symbol-function fname))
  246.         (consp (nth 3 (symbol-function fname)))
  247.         (eq (car (nth 3 (symbol-function fname))) 'trace-call))
  248.        (si:fset fname (symbol-function sym)))
  249.       (t
  250.        (format *trace-output*
  251.            "The function ~S was traced, but redefined.~%"
  252.            fname)))
  253.      (setq *trace-list*
  254.            (delete-if #'(lambda (u) (eq (car u) fname))
  255.               *trace-list* :count 1))
  256.      (list fname))
  257.         (t
  258.          (format *trace-output* "The function ~S is not traced.~%" fname)
  259.          nil)))
  260.  
  261. #| Example of tracing a function "fact" so that only the outermost call is traced.
  262.  
  263. (defun fact (n) (if (= n 0) 1 (* n (fact (1- n)))))
  264.  
  265. ;(defvar in-fact nil)
  266. (trace (fact :declarations ((in-fact nil))
  267.          :cond
  268.          (null in-fact)
  269.          :entry
  270.          (progn
  271.            (setq in-fact t)
  272.            (princ "Here comes input ")
  273.            (cons 'fact arglist))
  274.              :exit
  275.              (progn (setq in-fact nil)
  276.             (princ "Here comes output ")
  277.                     (cons 'fact values))))
  278.  
  279. ; Example of tracing fact so that only three levels are traced
  280.  
  281. (trace (fact :declarations
  282.          ((fact-depth 0))
  283.          :cond
  284.          (and (< fact-depth 3)
  285.           (setq fact-depth (1+ fact-depth)))
  286.          :exit
  287.          (progn (setq fact-depth (1- fact-depth)) (cons 'fact values))))
  288. |#
  289.  
  290.  
  291.  
  292. (defvar *step-level* 0)
  293. (defvar *step-quit* nil)
  294. (defvar *step-function* nil)
  295.  
  296. (defvar *old-print-level* nil)
  297. (defvar *old-print-length* nil)
  298.  
  299.  
  300. (defun step-read-line ()
  301.   (do ((char (read-char *debug-io*) (read-char *debug-io*)))
  302.       ((or (char= char #\Newline) (char= char #\Return)))))
  303.  
  304. (defmacro if-error (error-form form)
  305.   (let ((v (gensym)) (f (gensym)) (b (gensym)))
  306.     `(let (,v ,f)
  307.        (block ,b
  308.          (unwind-protect (setq ,v ,form ,f t)
  309.            (return-from ,b (if ,f ,v ,error-form)))))))
  310.  
  311. (defmacro step (form)
  312.   `(let* ((*old-print-level* *print-level*)
  313.           (*old-print-length* *print-length*)
  314.           (*print-level* 2)
  315.           (*print-length* 2))
  316.      (read-line)
  317.      (format *debug-io* "Type ? and a newline for help.~%")
  318.      (setq *step-quit* nil)
  319.      (stepper ',form nil)))
  320.  
  321. (defun stepper (form &optional env
  322.                 &aux values (*step-level* *step-level*) indent)
  323.   (when (eq *step-quit* t)
  324.     (return-from stepper (evalhook form nil nil env)))
  325.   (when (numberp *step-quit*)
  326.     (if (>= (1+ *step-level*) *step-quit*)
  327.         (return-from stepper (evalhook form nil nil env))
  328.         (setq *step-quit* nil)))
  329.   (when *step-function*
  330.     (if (and (consp form) (eq (car form) *step-function*))
  331.         (let ((*step-function* nil))
  332.           (return-from stepper (stepper form env)))
  333.         (return-from stepper (evalhook form #'stepper nil env))))
  334.   (setq *step-level* (1+ *step-level*))
  335.   (setq indent (min (* *step-level* 2) 20))
  336.   (loop
  337.     (format *debug-io* "~VT~S " indent form)
  338.     (finish-output *debug-io*)
  339.     (case (do ((char (read-char *debug-io*) (read-char *debug-io*)))
  340.               ((and (char/= char #\Space) (char/= char #\Tab)) char))
  341.           ((#\Newline #\Return)
  342.            (setq values
  343.                  (multiple-value-list
  344.                   (evalhook form #'stepper nil env)))
  345.            (return))
  346.           ((#\n #\N)
  347.            (step-read-line)
  348.            (setq values
  349.                  (multiple-value-list
  350.                   (evalhook form #'stepper nil env)))
  351.            (return))
  352.           ((#\s #\S)
  353.            (step-read-line)
  354.            (setq values
  355.                  (multiple-value-list
  356.                   (evalhook form nil nil env)))
  357.            (return))
  358.           ((#\p #\P)
  359.            (step-read-line)
  360.            (write form
  361.                   :stream *debug-io*
  362.                   :pretty t :level nil :length nil)
  363.            (terpri))
  364.           ((#\f #\F)
  365.            (let ((*step-function*
  366.                   (if-error nil
  367.                             (prog1 (read-preserving-whitespace *debug-io*)
  368.                                    (step-read-line)))))
  369.              (setq values
  370.                    (multiple-value-list
  371.                     (evalhook form #'stepper nil env)))
  372.              (return)))
  373.           ((#\q #\Q)
  374.            (step-read-line)
  375.            (setq *step-quit* t)
  376.            (setq values
  377.                  (multiple-value-list
  378.                   (evalhook form nil nil env)))
  379.            (return))
  380.           ((#\u #\U)
  381.            (step-read-line)
  382.            (setq *step-quit* *step-level*)
  383.            (setq values
  384.                  (multiple-value-list
  385.                   (evalhook form nil nil env)))
  386.            (return))
  387.           ((#\e #\E)
  388.            (let ((env1 env))
  389.              (dolist (x
  390.                       (if-error nil
  391.                                 (multiple-value-list
  392.                                  (evalhook
  393.                                   (if-error nil
  394.                                             (prog1
  395.                                              (read-preserving-whitespace
  396.                                               *debug-io*)
  397.                                              (step-read-line)))
  398.                                   nil nil env1))))
  399.                      (write x
  400.                             :stream *debug-io*
  401.                             :level *old-print-level*
  402.                             :length *old-print-length*)
  403.                      (terpri *debug-io*))))
  404.           ((#\r #\R)
  405.            (let ((env1 env))
  406.              (setq values
  407.                    (if-error nil
  408.                              (multiple-value-list
  409.                               (evalhook
  410.                                (if-error nil
  411.                                          (prog1
  412.                                           (read-preserving-whitespace
  413.                                            *debug-io*)
  414.                                           (step-read-line)))
  415.                                nil nil env1)))))
  416.            (return))
  417.           ((#\b #\B)
  418.            (step-read-line)
  419.            (let ((*ihs-base* (1+ *ihs-top*))
  420.                  (*ihs-top* (1- (ihs-top)))
  421.                  (*current-ihs* *ihs-top*))
  422.              (simple-backtrace)))
  423.           (t
  424.            (step-read-line)
  425.            (terpri)
  426.            (format *debug-io*
  427.                   "Stepper commands:~%~
  428.         n (or N or Newline):    advances to the next form.~%~
  429.         s (or S):        skips the form.~%~
  430.         p (or P):        pretty-prints the form.~%~
  431.                 f (or F) FUNCTION:    skips until the FUNCTION is called.~%~
  432.                 q (or Q):        quits.~%~
  433.                 u (or U):        goes up to the enclosing form.~%~
  434.                 e (or E) FORM:        evaluates the FORM ~
  435.                     and prints the value(s).~%~
  436.                 r (or R) FORM:        evaluates the FORM ~
  437.                     and returns the value(s).~%~
  438.                 b (or B):        prints backtrace.~%~
  439.         ?:            prints this.~%")
  440.            (terpri))))
  441.   (when (or (constantp form) (and (consp form) (eq (car form) 'quote)))
  442.         (return-from stepper (car values)))
  443.   (if (endp values)
  444.       (format *debug-io* "~V@T=~%" indent)
  445.       (do ((l values (cdr l))
  446.            (b t nil))
  447.           ((endp l))
  448.         (if b
  449.             (format *debug-io* "~V@T= ~S~%" indent (car l))
  450.             (format *debug-io* "~V@T& ~S~%" indent (car l)))))
  451.   (setq *step-level* (- *step-level* 1))
  452.   (values-list values))
  453.  
  454.