home *** CD-ROM | disk | FTP | other *** search
/ Dream 52 / Amiga_Dream_52.iso / RiscOS / APP / DEVS / LISP / CLISP.ZIP / CLisp / lsp / stepper_o < prev    next >
Lisp/Scheme  |  1992-02-17  |  9KB  |  282 lines
  1. ;;
  2. ;; File: STEP.LSP
  3. ;; Author: Ray Comas (comas@math.lsa.umich.edu)
  4. ;;
  5.  
  6. (defmacro while (test &rest forms) `(do () ((not ,test)) ,@forms))
  7.  
  8. (defparameter *hooklevel* 0)        ;create the nesting level counter.
  9. (defvar *pdepth*    3)        ;create depth counter
  10. (defvar *plen*        3)        ;create length counter
  11. (defparameter *fcn*    '*all*)        ;create "one-shot" breakpoint specifier
  12. (defvar *steplist*    nil)        ;create breakpoint list
  13. (defparameter *steptrace* '(t . t))    ;create stepping flags
  14. (defparameter *callist*    nil)        ;create call list for backtrace
  15.  
  16. ; this macro invokes the stepper.
  17. (defmacro step (form &aux val)
  18.   `(progn
  19.      (setq *hooklevel*    0        ;init nesting counter
  20.        *fcn*    '*all*        ;init break-point specifier
  21.        *steptrace*    '(t . t))
  22.      (setq *callist* (list (car ',form))) ;init call list
  23.      (terpri *debug-io*)
  24.      (step-flush)
  25.      (princ *hooklevel* *debug-io*)
  26.      (princ " >==> " *debug-io*)
  27.      (prin1 ',form *debug-io*)        ;print the form
  28.      (setq val (evalhook ',form        ;eval, and kick off stepper
  29.              #'eval-hook-function
  30.              nil
  31.              nil))
  32.      (terpri *debug-io*)
  33.      (princ *hooklevel* *debug-io*)    ;print returned value
  34.      (princ " <==< " *debug-io*)
  35.      (prin1 val *debug-io*)
  36.      (terpri *debug-io*)
  37.      val))                ;and return it
  38.  
  39. (defun eval-hook-function (form env &aux val cmd)
  40.   (setq *hooklevel* (1+ *hooklevel*))    ;incr. the nesting level
  41.   (cond ((consp form)            ;if interpreted function ...
  42.      (setq *callist*
  43.            (cons (car form) *callist*)) ;add fn. to call list
  44.      (tagbody
  45.       (loop                ;repeat forever ...
  46.                     ;check for a breakpoint
  47.        (when (and (not (equal *fcn* '*all*))
  48.               (not (equal *fcn* (car form)))
  49.               (not (and (numberp *fcn*) (>= *fcn* *hooklevel*))))
  50.          (unless (and *fcn* (member (car form) *steplist*))
  51.  
  52.                     ;no breakpoint reached -- continue
  53.              (setf (cdr *steptrace*) nil)
  54.              (when (car *steptrace*)
  55.                    (setf (cdr *steptrace*) t)
  56.                    (fcprt form))
  57.              (fix-go)
  58.              (setq val (evalhook form
  59.                          #'eval-hook-function
  60.                          nil
  61.                          env))
  62.              (go next)))
  63.  
  64.                     ;breakpoint reached -- fix things & get a command
  65.        (fcprt form)
  66.        (setf (cdr *steptrace*) t)
  67.        (setq *fcn* '*all*)        ;reset breakpoint specifier
  68.        (princ " :" *debug-io*)    ;prompt user
  69.        (setq cmd            ;get command from user
  70.          (char-downcase (code-char (get-key))))
  71.  
  72.                     ;process user's command
  73.        (cond
  74.         ((or (eql cmd #\n) (eql cmd #\Space)) ;step into function
  75.          (fix-go)
  76.          (setq val (evalhook form
  77.                  #'eval-hook-function
  78.                  nil
  79.                  env))
  80.          (go next))
  81.         ((or (eql cmd #\s) (eql cmd #\Newline)) ;step over function
  82.          (fix-go)
  83.          (setq val (evalhook form nil nil env))
  84.          (go next))
  85.         ((eql cmd #\g)        ;go until breakpt. reached
  86.          (setq *fcn* t)
  87.          (fix-go)
  88.          (setq val (evalhook form
  89.                  #'eval-hook-function
  90.                  nil
  91.                  env))
  92.          (go next))
  93.         ((eql cmd #\w)        ;backtrace
  94.          (step-baktrace))
  95.         ((eql cmd #\h)        ;display help
  96.          (step-help))
  97.         ((eql cmd #\p)        ;pretty-print form
  98.          (terpri *debug-io*)
  99.          (pprint form *debug-io*))
  100.         ((eql cmd #\f)        ;set function breakpoint
  101.          (princ "Go to fn.: " *debug-io*)
  102.          (setq *fcn* (read *debug-io*))
  103.          (step-flush))
  104.         ((eql cmd #\u)        ;go up one level
  105.          (setq *fcn* (1- *hooklevel*)))
  106.         ((eql cmd #\b)        ;set breakpoint
  107.          (princ "Bkpt.: " *debug-io*)
  108.          (step-set-breaks (read *debug-io*))
  109.          (step-flush))
  110.         ((eql cmd #\c)        ;clear a breakpoint
  111.          (princ "Clear: " *debug-io*)
  112.          (step-clear-breaks (read *debug-io*))
  113.          (step-flush))
  114.         ((eql cmd #\t)        ;toggle trace mode
  115.          (setf (car *steptrace*)
  116.            (not (car *steptrace*)))
  117.          (princ "Trace = " *debug-io*)
  118.          (prin1 (car *steptrace*) *debug-io*))
  119.         ((eql cmd #\q)        ;quit stepper
  120.          (setq *fcn* nil))
  121.         ((eql cmd #\x)        ;evaluate a form
  122.          (princ "Eval: " *debug-io*)
  123.          (step-do-form (read *debug-io*) env)
  124.          (step-flush))
  125.         ((eql cmd #\r)        ;return given expression
  126.          (princ "Return: " *debug-io*)
  127.          (setq val (evalhook (read *debug-io*) nil nil env))
  128.          (step-flush)
  129.          (go next))
  130.         ((eql cmd #\#)        ;set new compress level
  131.          (princ "Depth: " *debug-io*)
  132.          (step-set-depth (read *debug-io*))
  133.          (step-flush))
  134.         ((eql cmd #\.)
  135.          (princ "Len.: " *debug-io*)
  136.          (step-set-length (read *debug-io*))
  137.          (step-flush))
  138.         ((eql cmd #\e)        ;print environment
  139.          (step-print-env env))
  140.         (t (princ "Bad command.  Type h for help\n" *debug-io*))))
  141.  
  142.       next                ;exit from loop
  143.       (setq *callist* (cdr *callist*)) ;remove fn. from call list
  144.       (when (cdr *steptrace*)
  145.         (terpri *debug-io*)
  146.         (step-spaces *hooklevel*)
  147.         (princ *hooklevel* *debug-io*)
  148.         (princ " <==< " *debug-io*) ;print the result
  149.         (prin1 val *debug-io*))))
  150.  
  151.                     ;not an interpreted function -- just trace thru.
  152.     (t (unless (not (symbolp form))
  153.            (when (car *steptrace*)
  154.              (terpri *debug-io*)
  155.              (step-spaces *hooklevel*) ;if form is a symbol ...
  156.              (princ "         " *debug-io*)
  157.              (prin1 form *debug-io*) ;... print the form ...
  158.              (princ " = " *debug-io*)))
  159.        (setq val (evalhook form nil nil env)) ;eval it
  160.        (unless (not (symbolp form))
  161.            (when (car *steptrace*)
  162.              (prin1 val *debug-io*))))) ;... and the value
  163.   (setq *hooklevel* (1- *hooklevel*))    ;decrement level
  164.   val)                    ;and return the value
  165.  
  166. ;compress a list
  167. (defun compress (l cd cl ol)        ;cd = depth, cl = length, ol = orig. length
  168.   (cond
  169.    ((null l) nil)
  170.    ((eql cl 0) '(...))
  171.    ((atom l) l)
  172.    ((eql cd 0) '#\#)
  173.    (t (cons (compress (car l) (1- cd) ol ol)
  174.         (compress (cdr l) cd (1- cl) ol)))))
  175.  
  176. ;compress and print a form
  177. (defun fcprt (form)
  178.   (terpri *debug-io*)
  179.   (step-spaces (min 20 *hooklevel*))
  180.   (princ *hooklevel* *debug-io*)
  181.   (princ " >==> " *debug-io*)
  182.   (prin1 (compress form *pdepth* *plen* *plen*) *debug-io*)
  183.   (princ " " *debug-io*))
  184.  
  185. ;a non-recursive fn to print spaces (not as elegant, easier on the gc)
  186. (defun step-spaces (n) (dotimes (i n) (princ " " *debug-io*)))
  187.  
  188. ;and one to clear the input buffer
  189. (defun step-flush () (while (not (eql (read-char *debug-io*) #\newline))))
  190.  
  191. ;print help
  192. (defun step-help ()
  193.   (terpri *debug-io*)
  194.   (princ "Stepper Commands\n" *debug-io*)
  195.   (princ "----------------\n" *debug-io*)
  196.   (princ " n or space - next form\n" *debug-io*)
  197.   (princ " s or <cr>  - step over form\n" *debug-io*)
  198.   (princ " f FUNCTION - go until FUNCTION is called\n" *debug-io*)
  199.   (princ " b FUNCTION - set breakpoint at FUNCTION\n" *debug-io*)
  200.   (princ " b <list>   - set breakpoint at each function in list\n" *debug-io*)
  201.   (princ " c FUNCTION - clear breakpoint at FUNCTION\n" *debug-io*)
  202.   (princ " c <list>   - clear breakpoint at each function in list\n" *debug-io*)
  203.   (princ " c *all*    - clear all breakpoints\n" *debug-io*)
  204.   (princ "          g - go until a breakpoint is reached\n" *debug-io*)
  205.   (princ "          u - go up; continue until enclosing form is done\n" *debug-io*)
  206.   (princ "          w - where am I? -- backtrace\n" *debug-io*)
  207.   (princ "          t - toggle trace on/off\n" *debug-io*)
  208.   (princ "          q - quit stepper, continue execution\n" *debug-io*)
  209.   (princ "          p - pretty-print current form (uncompressed)\n" *debug-io*)
  210.   (princ "          e - print environment\n" *debug-io*)
  211.   (princ "   x <expr> - execute expression in current environment\n" *debug-io*)
  212.   (princ "   r <expr> - execute and return expression\n" *debug-io*)
  213.   (princ "       # nn - set print depth to nn\n" *debug-io*)
  214.   (princ "       . nn - set print length to nn\n" *debug-io*)
  215.   (princ "          h - print this summary\n" *debug-io*)
  216.   (terpri *debug-io*))
  217.  
  218. ;evaluate a form in the given environment
  219. (defun step-do-form (f1 env)
  220.   (step-spaces *hooklevel*)
  221.   (princ *hooklevel* *debug-io*)
  222.   (princ " res: " *debug-io*)
  223.   (prin1 (evalhook f1 nil nil env) *debug-io*))    ;print result
  224.  
  225. ;set new print depth
  226. (defun step-set-depth (cf)
  227.   (cond ((numberp cf)
  228.      (setq *pdepth* (truncate cf)))
  229.     (t (setq *pdepth* 3))))
  230.  
  231. ;set new print length
  232. (defun step-set-length (cf)
  233.   (cond ((numberp cf)
  234.      (setq *plen* (truncate cf)))
  235.     (t (setq *plen* 3))))
  236.  
  237. ;print environment
  238. (defun step-print-env (env)
  239.   (terpri *debug-io*)
  240.   (step-spaces *hooklevel*)
  241.   (princ *hooklevel* *debug-io*)
  242.   (princ " env: " *debug-io*)
  243.   (prin1 env *debug-io*)
  244.   (terpri *debug-io*))
  245.  
  246. ;set breakpoints
  247. (defun step-set-breaks (l)
  248.   (cond ((null l) t)
  249.     ((symbolp l) (setq *steplist* (cons l *steplist*)))
  250.     ((listp l)
  251.      (step-set-breaks (car l))
  252.      (step-set-breaks (cdr l)))))
  253.  
  254. ;clear breakpoints
  255. (defun step-clear-breaks (l)
  256.   (cond ((null l) t)
  257.     ((eql l '*all*) (setq *steplist* nil))
  258.     ((symbolp l) (delete l *steplist*))
  259.     ((listp l)
  260.      (step-clear-breaks (car l))
  261.      (step-clear-breaks (cdr l)))))
  262.  
  263. ;print backtrace
  264. (defun step-baktrace (&aux l n)
  265.   (setq l *callist*
  266.     n *hooklevel*)
  267.   (while (>= n 0)
  268.     (terpri *debug-io*)
  269.     (step-spaces n)
  270.     (prin1 n *debug-io*)
  271.     (princ " " *debug-io*)
  272.     (prin1 (car l) *debug-io*)
  273.     (setq l (cdr l))
  274.     (setq n (1- n)))
  275.   (terpri *debug-io*))
  276.  
  277. (defun fix-go ()
  278.   (when (equal (car *callist*) 'go)
  279.     (setq *hooklevel* (1- *hooklevel*))
  280.     (setq *callist* (cdr *callist*))))
  281.  
  282.