home *** CD-ROM | disk | FTP | other *** search
/ ftp.uni-stuttgart.de/pub/systems/acorn/ / Acorn.tar / Acorn / acornet / dev / xlisp+ / xlisp+.spk / lsp / stepper < prev    next >
Lisp/Scheme  |  1992-10-02  |  13KB  |  375 lines
  1. ;;
  2. ;; File: STEP.LSP
  3. ;; Author: Ray Comas (comas@math.lsa.umich.edu)
  4. ;;
  5. ;; Modifications and corrections by Tom Almy
  6. ;; The program did not correctly handle RETURN (as reported by Martin
  7. ;; Glanvill, mcg@waikato.ac.nz). In the process of fixing the the
  8. ;; problem it was discovered that the nexting printout did not work
  9. ;; properly for all return, return-from, throw, and many cases of go.
  10. ;; This version has been fixed for hopefully all of the above, although
  11. ;; go will still not produce proper printout if the jump is outside the
  12. ;; most enclosing tagbody, and the tag arguments of catch/throw must
  13. ;; either be symbols or quoted symbols.  I'm making no attempt here to
  14. ;; correctly handle tracing of unwind-protect, either!
  15. ;; Modifications marked "TAA"
  16. ;; Tom Almy  5/92
  17.  
  18. (defmacro while (test &rest forms) `(do () ((not ,test)) ,@forms))
  19.  
  20. (defparameter *hooklevel* 0)        ;create the nesting level counter.
  21. (defvar *pdepth*    3)        ;create depth counter
  22. (defvar *plen*        3)        ;create length counter
  23. (defparameter *fcn*    '*all*)        ;create "one-shot" breakpoint specifier
  24. (defvar *steplist*    nil)        ;create breakpoint list
  25. (defparameter *steptrace* '(t . t))    ;create stepping flags
  26. (defparameter *callist*    nil)        ;create call list for backtrace
  27.  
  28. ; this macro invokes the stepper.
  29. (defmacro step (form &aux val)
  30.   `(progn
  31.      (setq *hooklevel*    0        ;init nesting counter
  32.        *fcn*    '*all*        ;init break-point specifier
  33.        *steptrace*    '(t . t))
  34.      (setq *callist* (list (car ',form))) ;init call list
  35.      (terpri *debug-io*)
  36.      (step-flush)
  37.      (princ *hooklevel* *debug-io*)
  38.      (princ " >==> " *debug-io*)
  39.      (prin1 ',form *debug-io*)        ;print the form
  40.      (setq val (evalhook ',form        ;eval, and kick off stepper
  41.              #'eval-hook-function
  42.              nil
  43.              nil))
  44.      (terpri *debug-io*)
  45.      (princ *hooklevel* *debug-io*)    ;print returned value
  46.      (princ " <==< " *debug-io*)
  47.      (prin1 val *debug-io*)
  48.      (terpri *debug-io*)
  49.      val))                ;and return it
  50.  
  51. (defun eval-hook-function (form env &aux val cmd)
  52.   (setq *hooklevel* (1+ *hooklevel*))    ;incr. the nesting level
  53.   (cond ((consp form)            ;if interpreted function ...
  54.      (step-add-level form)    ;; add to *call-list*  TAA
  55.      (tagbody
  56.       (loop                ;repeat forever ...
  57.                     ;check for a breakpoint
  58.        (when (and (not (equal *fcn* '*all*))
  59.               (not (equal *fcn* (car form)))
  60.               (not (and (numberp *fcn*) (>= *fcn* *hooklevel*))))
  61.          (unless (and *fcn* (member (car form) *steplist*))
  62.  
  63.                     ;no breakpoint reached -- continue
  64.              (setf (cdr *steptrace*) nil)
  65.              (when (car *steptrace*)
  66.                    (setf (cdr *steptrace*) t)
  67.                    (step-print-compressed form))
  68.              (setq val (list     form
  69.                          #'eval-hook-function
  70.                          nil
  71.                          env))
  72.              (go next)))
  73.  
  74.                     ;breakpoint reached -- fix things & get a command
  75.        (step-print-compressed form)
  76.        (setf (cdr *steptrace*) t)
  77.        (setq *fcn* '*all*)        ;reset breakpoint specifier
  78.        (princ " :" *debug-io*)    ;prompt user
  79.        (setq cmd            ;get command from user
  80.          (char-downcase (code-char (get-key))))
  81.  
  82.                     ;process user's command
  83.        (cond
  84.         ((or (eql cmd #\n) (eql cmd #\Space)) ;step into function
  85.          (setq val (list     form
  86.                  #'eval-hook-function
  87.                  nil
  88.                  env))
  89.          (go next))
  90.         ((or (eql cmd #\s)        ;step over function
  91.          (eql cmd #\Newline)
  92.          (eql cmd #\C-M)) ;; Added check for control-M TAA
  93.          (setq val (list form nil nil env))
  94.          (go next))
  95.         ((eql cmd #\g)        ;go until breakpt. reached
  96.          (setq *fcn* t)
  97.          (setq val (list     form
  98.                  #'eval-hook-function
  99.                  nil
  100.                  env))
  101.          (go next))
  102.         ((eql cmd #\w)        ;backtrace
  103.          (step-baktrace))
  104.         ((eql cmd #\h)        ;display help
  105.          (step-help))
  106.         ((eql cmd #\p)        ;pretty-print form
  107.          (terpri *debug-io*)
  108.          (pprint form *debug-io*))
  109.         ((eql cmd #\f)        ;set function breakpoint
  110.          (princ "Go to fn.: " *debug-io*)
  111.          (setq *fcn* (read *debug-io*))
  112.          (step-flush))
  113.         ((eql cmd #\u)        ;go up one level
  114.          (setq *fcn* (1- *hooklevel*)))
  115.         ((eql cmd #\b)        ;set breakpoint
  116.          (princ "Bkpt.: " *debug-io*)
  117.          (step-set-breaks (read *debug-io*))
  118.          (step-flush))
  119.         ((eql cmd #\c)        ;clear a breakpoint
  120.          (princ "Clear: " *debug-io*)
  121.          (step-clear-breaks (read *debug-io*))
  122.          (step-flush))
  123.         ((eql cmd #\t)        ;toggle trace mode
  124.          (setf (car *steptrace*)
  125.            (not (car *steptrace*)))
  126.          (princ "Trace = " *debug-io*)
  127.          (prin1 (car *steptrace*) *debug-io*))
  128.         ((eql cmd #\q)        ;quit stepper
  129.          (setq *fcn* nil))
  130.         ((eql cmd #\x)        ;evaluate a form
  131.          (princ "Eval: " *debug-io*)
  132.          (step-do-form (read *debug-io*) env)
  133.          (step-flush))
  134.         ((eql cmd #\r)        ;return given expression
  135.          (princ "Return: " *debug-io*)
  136.          (setq val (list (read *debug-io*) nil nil env))
  137.          (step-flush)
  138.          (go next))
  139.         ((eql cmd #\#)        ;set new compress level
  140.          (princ "Depth: " *debug-io*)
  141.          (step-set-depth (read *debug-io*))
  142.          (step-flush))
  143.         ((eql cmd #\.)
  144.          (princ "Len.: " *debug-io*)
  145.          (step-set-length (read *debug-io*))
  146.          (step-flush))
  147.         ((eql cmd #\e)        ;print environment
  148.          (step-print-env env))
  149.         (t (princ "Bad command.  Type h for help\n" *debug-io*))))
  150.  
  151.       next                ;exit from loop
  152.       ;; call of evalhook was done prior to "go next" in the loop above.
  153.       ;; now it's done outside the loop to solve problems handling
  154.       ;; return.  TAA
  155.       (step-fix-levels)
  156.       (setq val (apply #'evalhook val))
  157.       (step-fix-throw)
  158.       (when (cdr *steptrace*)
  159.         (terpri *debug-io*)
  160.         (step-spaces *hooklevel*)
  161.         (princ *hooklevel* *debug-io*)
  162.         (princ " <==< " *debug-io*) ;print the result
  163.         (prin1 val *debug-io*))
  164.       (step-prune-level))) ;; step-prune-level replaces inline code TAA
  165.  
  166.             ;not an interpreted function -- just trace thru.
  167.     (t (unless (not (symbolp form))
  168.            (when (car *steptrace*)
  169.              (terpri *debug-io*)
  170.              (step-spaces *hooklevel*) ;if form is a symbol ...
  171.              (princ "         " *debug-io*)
  172.              (prin1 form *debug-io*) ;... print the form ...
  173.              (princ " = " *debug-io*)))
  174.        (setq val (evalhook form nil nil env)) ;eval it
  175.        (setq *hooklevel* (1- *hooklevel*))    ;decrement level
  176.        (unless (not (symbolp form))
  177.            (when (car *steptrace*)
  178.              (prin1 val *debug-io*))))) ;... and the value
  179.   val)                    ;and return the value
  180.  
  181.  
  182. ;; Made compress local function
  183. ;; and changed name fcprt to step-print-compressed  TAA
  184.  
  185. ;compress and print a form
  186. (defun step-print-compressed (form)
  187.        (labels ((compress (l cd cl ol)    ; cd = depth, cl = length, 
  188.                     ; ol = orig. length
  189.               (cond
  190.                ((null l) nil)
  191.                ((eql cl 0) '(...))
  192.                ((atom l) l)
  193.                ((eql cd 0) '#\#)
  194.                (t (cons (compress (car l) (1- cd) ol ol)
  195.                     (compress (cdr l) cd (1- cl) ol))))))
  196.            (terpri *debug-io*)
  197.            (step-spaces (min 20 *hooklevel*))
  198.            (princ *hooklevel* *debug-io*)
  199.            (princ " >==> " *debug-io*)
  200.            (prin1 (compress form *pdepth* *plen* *plen*) *debug-io*)
  201.            (princ " " *debug-io*)))
  202.  
  203. ;a non-recursive fn to print spaces (not as elegant, easier on the gc)
  204. (defun step-spaces (n) (dotimes (i n) (princ " " *debug-io*)))
  205.  
  206. ;and one to clear the input buffer
  207. (defun step-flush () (while (not (eql (read-char *debug-io*) #\newline))))
  208.  
  209. ;print help
  210. (defun step-help ()
  211.   (terpri *debug-io*)
  212.   (princ "Stepper Commands\n" *debug-io*)
  213.   (princ "----------------\n" *debug-io*)
  214.   (princ " n or space - next form\n" *debug-io*)
  215.   (princ " s or <cr>  - step over form\n" *debug-io*)
  216.   (princ " f FUNCTION - go until FUNCTION is called\n" *debug-io*)
  217.   (princ " b FUNCTION - set breakpoint at FUNCTION\n" *debug-io*)
  218.   (princ " b <list>   - set breakpoint at each function in list\n" *debug-io*)
  219.   (princ " c FUNCTION - clear breakpoint at FUNCTION\n" *debug-io*)
  220.   (princ " c <list>   - clear breakpoint at each function in list\n" *debug-io*)
  221.   (princ " c *all*    - clear all breakpoints\n" *debug-io*)
  222.   (princ "          g - go until a breakpoint is reached\n" *debug-io*)
  223.   (princ "          u - go up; continue until enclosing form is done\n" *debug-io*)
  224.   (princ "          w - where am I? -- backtrace\n" *debug-io*)
  225.   (princ "          t - toggle trace on/off\n" *debug-io*)
  226.   (princ "          q - quit stepper, continue execution\n" *debug-io*)
  227.   (princ "          p - pretty-print current form (uncompressed)\n" *debug-io*)
  228.   (princ "          e - print environment\n" *debug-io*)
  229.   (princ "   x <expr> - execute expression in current environment\n" *debug-io*)
  230.   (princ "   r <expr> - execute and return expression\n" *debug-io*)
  231.   (princ "       # nn - set print depth to nn\n" *debug-io*)
  232.   (princ "       . nn - set print length to nn\n" *debug-io*)
  233.   (princ "          h - print this summary\n" *debug-io*)
  234.   (terpri *debug-io*))
  235.  
  236. ;evaluate a form in the given environment
  237. (defun step-do-form (f1 env)
  238.   (step-spaces *hooklevel*)
  239.   (princ *hooklevel* *debug-io*)
  240.   (princ " res: " *debug-io*)
  241.   (prin1 (evalhook f1 nil nil env) *debug-io*))    ;print result
  242.  
  243. ;set new print depth
  244. (defun step-set-depth (cf)
  245.   (cond ((numberp cf)
  246.      (setq *pdepth* (truncate cf)))
  247.     (t (setq *pdepth* 3))))
  248.  
  249. ;set new print length
  250. (defun step-set-length (cf)
  251.   (cond ((numberp cf)
  252.      (setq *plen* (truncate cf)))
  253.     (t (setq *plen* 3))))
  254.  
  255. ;print environment
  256. (defun step-print-env (env)
  257.   (terpri *debug-io*)
  258.   (step-spaces *hooklevel*)
  259.   (princ *hooklevel* *debug-io*)
  260.   (princ " env: " *debug-io*)
  261.   (prin1 env *debug-io*)
  262.   (terpri *debug-io*))
  263.  
  264. ;set breakpoints
  265. (defun step-set-breaks (l)
  266.   (cond ((null l) t)
  267.     ((symbolp l) (setq *steplist* (cons l *steplist*)))
  268.     ((listp l)
  269.      (step-set-breaks (car l))
  270.      (step-set-breaks (cdr l)))))
  271.  
  272. ;clear breakpoints
  273. (defun step-clear-breaks (l)
  274.   (cond ((null l) t)
  275.     ((eql l '*all*) (setq *steplist* nil))
  276.     ((symbolp l) (delete l *steplist*))
  277.     ((listp l)
  278.      (step-clear-breaks (car l))
  279.      (step-clear-breaks (cdr l)))))
  280.  
  281. ;print backtrace
  282. (defun step-baktrace (&aux l n)
  283.   (setq l *callist*
  284.     n *hooklevel*)
  285.   (while (>= n 0)
  286.     (terpri *debug-io*)
  287.     (step-spaces n)
  288.     (prin1 n *debug-io*)
  289.     (princ " " *debug-io*)
  290.     (if (consp (car l))    ;; must handle case where item is list TAA
  291.     (format *debug-io* "~s ~s" (caar l) (cdar l))
  292.     (prin1 (car l) *debug-io*))
  293.     (setq l (cdr l))
  294.     (setq n (1- n)))
  295.   (terpri *debug-io*))
  296.  
  297. ;; Added function step-add-level for clarity, since function has
  298. ;; become more complex. TAA
  299.  
  300. (defun step-add-level (form)
  301.        (setq *callist*    ;; Modified so that callist entry can be
  302.             ;; list where cadr is a tag saved for later
  303.             ;; match. This us used for block, return-from,
  304.             ;; catch, and throw.
  305.          (cons (case (car form)
  306.              ((block return-from)
  307.               (cons (car form) (cadr form)))
  308.              ((catch throw) ;; we may need to eval symbol
  309.               (if (symbolp (cadr form))
  310.                   (cons (car form) 
  311.                     (evalhook (cadr form) nil nil env))
  312.                   (if (eq (caadr form) 'quote) ;; quoted tag
  313.                   (cons (car form) (cadadr form))
  314.                   nil))) ;; out of luck!
  315.              (t (car form)))
  316.            *callist*))) ;add fn. to call list
  317.  
  318. ;; Added function step-prune-level for clarity  TAA
  319.  
  320. (defun step-prune-level ()
  321.        (setq *hooklevel* (1- *hooklevel*))
  322.        (setq *callist* (cdr *callist*)))
  323.  
  324. ;; Deleted fix-go, replaced with step-fix-levels which handles go, return,
  325. ;; and return-from. TAA
  326.  
  327. (defun step-fix-levels ()
  328.   (cond ((eq (car *callist*) 'go) ;; go -- prune back to tagbody
  329.      (loop
  330.       (when (null *callist*) (return))    ;; we are lost!
  331.       (when (member (car *callist*)
  332.             '(loop do do* dolist dotimes prog prog* tagbody))
  333.         (return))
  334.       (step-prune-level)))
  335.  
  336.  
  337.     ((or (eq (car *callist*) 'return) ;; return -- prune back before block
  338.          (and (consp (car *callist*)) ;; return-from nil is same
  339.           (eq (caar *callist*) 'return-from) 
  340.           (null (cdar *callist*))))
  341.      (loop
  342.       (step-prune-level)
  343.       (when (null *callist*) (return))    ;; we are lost!
  344.       (when (member (car *callist*)
  345.             '(loop do do* dolist dotimes prog prog*))
  346.         (return))))
  347.  
  348.     ((and (consp (car *callist*)) ;; return-from - prune back before block
  349.           (eq (caar *callist*) 'return-from))
  350.      (let ((target (cdar *callist*)))
  351.           (loop
  352.            (step-prune-level)
  353.            (when (null *callist*) (return))    ;; we are lost!
  354.            (when (or (eq target (car *callist*))
  355.              (and (consp (car *callist*))
  356.                   (eq (caar *callist*) 'block)
  357.                   (eq (cdar *callist*) target)))
  358.              (return)))))))
  359.  
  360. ;; Added step-fix-throw TAA
  361.  
  362. (defun step-fix-throw () ;; fix levels after evalhook for throw
  363.        (when (and (consp (car *callist*))
  364.           (eq (caar *callist*) 'throw))
  365.          (let ((target (cdar *callist*)))
  366.           (loop
  367.            (step-prune-level)
  368.            (when (null *callist*) (return))    ;; we are lost!
  369.            (when (and (consp (car *callist*))
  370.                   (eq (caar *callist*) 'catch)
  371.                   (eq (cdar *callist*) target))
  372.              (return))))))
  373.  
  374.  
  375.