home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / xl21hos2.zip / STEPPER.LSP < prev    next >
Lisp/Scheme  |  1995-12-27  |  18KB  |  464 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. ;; Modifications -
  19. ;;
  20. ;; Function : Eval-hook-function
  21. ;;
  22. ;; Modifcation :- MCG 5/5/93
  23. ;;
  24. ;;  "is-brk-in-form" function added to look in advance
  25. ;;  to see if any break points are in the current form.
  26. ;;  If not, then the stepper will step over the form
  27. ;;  without evaluating the sub-forms within the current form
  28. ;; (as original did); if break point found then it steps into
  29. ;; the form.
  30. ;; The Advantage is when you have a break point at the end of 
  31. ;; a prog with massive amounts of DO loops, you don't want to waste
  32. ;; time stepping into the do loop!
  33. ;; Also I've modified it for use on COMMON LISP and XLISP
  34. ;; See notes at bottom.
  35. ;; Problems: in CL, step into LOOP's/ PROGN's  before 
  36. ;;           excuting the "g" command!
  37. ;; Future Updates : further investigation of LOOPS and PROGn's as above.
  38.  
  39. ;; Modification: TAA 5/5/93 
  40.  
  41. ;; I made the Common Lisp vs. Xlisp choice automatic via conditional
  42. ;; compilation (Gee, I was hoping to find a good use for this feature!)
  43.  
  44.  
  45. #+:packages
  46. (unless (find-package "TOOLS")
  47.     (make-package "TOOLS" :use '("XLISP")))
  48.  
  49. (in-package "TOOLS")
  50.  
  51. (export '(step))
  52.  
  53.  
  54. (defmacro while (test &rest forms) `(do () ((not ,test)) ,@forms))
  55.  
  56. (defparameter *hooklevel* 0)            ;create the nesting level counter.
  57. (defvar *pdepth*        3)              ;create depth counter
  58. (defvar *plen*          3)              ;create length counter
  59. (defparameter *fcn*     '*all*)         ;create "one-shot" breakpoint specifier
  60. (defvar *steplist*      nil)            ;create breakpoint list
  61. (defparameter *steptrace* '(t . t))     ;create stepping flags
  62. (defparameter *callist* nil)            ;create call list for backtrace
  63.  
  64.  
  65. ; this macro invokes the stepper - MCG 5/5/93 step -> usr-step , CL mod.
  66. (defmacro #+:xlisp step #-:xlisp usr-step (form &aux val)
  67.   `(progn
  68.      (setq *hooklevel*  0               ;init nesting counter
  69.            *fcn*        '*all*          ;init break-point specifier
  70.            *steptrace*  '(t . t))
  71.      (setq *callist* (list (car ',form))) ;init call list
  72.      (terpri *debug-io*)
  73.      (step-flush)
  74.      (princ *hooklevel* *debug-io*)
  75.      (princ " >==> " *debug-io*)
  76.      (prin1 ',form *debug-io*)          ;print the form
  77.      (setq val (evalhook ',form         ;eval, and kick off stepper
  78.                          #'eval-hook-function
  79.                          nil
  80.                          nil))
  81.      (terpri *debug-io*)
  82.      (princ *hooklevel* *debug-io*)     ;print returned value
  83.      (princ " <==< " *debug-io*)
  84.      (prin1 val *debug-io*)
  85.      (terpri *debug-io*)
  86.      val))                              ;and return it
  87.  
  88. (defun eval-hook-function (form env &aux val cmd)
  89.   (setq *hooklevel* (1+ *hooklevel*))   ;incr. the nesting level
  90.   (cond ((consp form)                   ;if interpreted function ...
  91.          (step-add-level form env)  ;; add to *call-list*  TAA
  92.          (tagbody
  93.           (loop                         ;repeat forever ...
  94.                                         ;check for a breakpoint
  95.            (when (and (not (equal *fcn* '*all*))
  96.                       (not (equal *fcn* (car form)))
  97.                       (not (and (numberp *fcn*) (>= *fcn* *hooklevel*))))
  98.                  (unless (and *fcn* (member (car form) *steplist*))
  99.  
  100.                                         ;no breakpoint reached -- continue
  101.                          (setf (cdr *steptrace*) nil)
  102.                          (when (car *steptrace*)
  103.                                (setf (cdr *steptrace*) t)
  104.                                (step-print-compressed form))
  105.  
  106.                          (cond                                ;- MCG 5/5/93
  107.                           ((is-brk-in-form form *steplist*)   
  108.                                   (setq val (list     form
  109.                                                       #'eval-hook-function
  110.                                                       nil
  111.                                                       env)))
  112.                           (t  (setq val (list form nil nil env))))                           
  113.  
  114.                                                      
  115.                          (go next)))
  116.  
  117.                                         ;breakpoint reached -- fix things & get a command
  118.            (step-print-compressed form)
  119.            (setf (cdr *steptrace*) t)
  120.            (setq *fcn* '*all*)          ;reset breakpoint specifier
  121.            (princ " :" *debug-io*)      ;prompt user
  122.  
  123. #-:xlisp
  124.            (setq cmd                    ;get command from user 
  125.                  (get-key))
  126.  
  127. #+:xlisp
  128.            (setq cmd                    ;get command from user
  129.                  (char-downcase (code-char (get-key))))
  130.  
  131.                                         ;process user's command
  132.            (cond
  133.             ((or (eql cmd #\n) (eql cmd #\Space)) ;step into function
  134.              (setq val (list     form
  135.                                  #'eval-hook-function
  136.                                  nil
  137.                                  env))
  138.              (go next))
  139.             ((or (eql cmd #\s)          ;step over function
  140.  
  141. #+:xlisp         (eql cmd #\Newline)
  142. #+:xlisp         (eql cmd #\C-M)
  143.  
  144.              ) ;; Added check for control-M TAA
  145.              (setq val (list form nil nil env))
  146.              (go next))
  147.             ((eql cmd #\g)              ;go until breakpt. reached
  148.              (setq *fcn* t)
  149.              (setq val (list     form
  150.                                  #'eval-hook-function
  151.                                  nil
  152.                                  env))
  153.              (go next))
  154.             ((eql cmd #\w)              ;backtrace
  155.              (step-baktrace))
  156.             ((eql cmd #\h)              ;display help
  157.              (step-help))
  158.             ((eql cmd #\p)              ;pretty-print form
  159.              (terpri *debug-io*)
  160.              (pprint form *debug-io*))
  161.             ((eql cmd #\f)              ;set function breakpoint
  162.              (princ "Go to fn.: " *debug-io*)
  163.              (setq *fcn* (read *debug-io*))
  164.              (step-flush))
  165.             ((eql cmd #\u)              ;go up one level
  166.              (setq *fcn* (1- *hooklevel*)))
  167.             ((eql cmd #\b)              ;set breakpoint
  168.              (princ "Bkpt.: " *debug-io*)
  169.              (step-set-breaks (read *debug-io*))
  170.              (step-flush))
  171.             ((eql cmd #\c)              ;clear a breakpoint
  172.              (princ "Clear: " *debug-io*)
  173.              (step-clear-breaks (read *debug-io*))
  174.              (step-flush))
  175.             ((eql cmd #\t)              ;toggle trace mode
  176.              (setf (car *steptrace*)
  177.                    (not (car *steptrace*)))
  178.              (princ "Trace = " *debug-io*)
  179.              (prin1 (car *steptrace*) *debug-io*))
  180.             ((eql cmd #\q)              ;quit stepper
  181.              (setq *fcn* nil))
  182.             ((eql cmd #\x)              ;evaluate a form
  183.              (princ "Eval: " *debug-io*)
  184.              (step-do-form (read *debug-io*) env)
  185.              (step-flush))
  186.             ((eql cmd #\r)              ;return given expression
  187.              (princ "Return: " *debug-io*)
  188.              (setq val (list (read *debug-io*) nil nil env))
  189.              (step-flush)
  190.              (go next))
  191.             ((eql cmd #\#)              ;set new compress level
  192.              (princ "Depth: " *debug-io*)
  193.              (step-set-depth (read *debug-io*))
  194.              (step-flush))
  195.             ((eql cmd #\.)
  196.              (princ "Len.: " *debug-io*)
  197.              (step-set-length (read *debug-io*))
  198.              (step-flush))
  199.             ((eql cmd #\e)              ;print environment
  200.              (step-print-env env))
  201.             (t (princ "Bad command.  Type h for help\n" *debug-io*))))
  202.  
  203.           next                          ;exit from loop
  204.           ;; call of evalhook was done prior to "go next" in the loop above.
  205.           ;; now it's done outside the loop to solve problems handling
  206.           ;; return.  TAA
  207.           (step-fix-levels)
  208.           (setq val (apply #'evalhook val))
  209.           (step-fix-throw)
  210.           (when (cdr *steptrace*)
  211.                 (terpri *debug-io*)
  212.                 (step-spaces *hooklevel*)
  213.                 (princ *hooklevel* *debug-io*)
  214.                 (princ " <==< " *debug-io*) ;print the result
  215.                 (prin1 val *debug-io*))
  216.           (step-prune-level))) ;; step-prune-level replaces inline code TAA
  217.  
  218.                         ;not an interpreted function -- just trace thru.
  219.         (t (unless (not (symbolp form))
  220.                    (when (car *steptrace*)
  221.                          (terpri *debug-io*)
  222.                          (step-spaces *hooklevel*) ;if form is a symbol ...
  223.                          (princ "         " *debug-io*)
  224.                          (prin1 form *debug-io*) ;... print the form ...
  225.                          (princ " = " *debug-io*)))
  226.            (setq val (evalhook form nil nil env)) ;eval it
  227.            (setq *hooklevel* (1- *hooklevel*))  ;decrement level
  228.            (unless (not (symbolp form))
  229.                    (when (car *steptrace*)
  230.                          (prin1 val *debug-io*))))) ;... and the value
  231.   val)                                  ;and return the value
  232.  
  233.  
  234. ;; Made compress local function
  235. ;; and changed name fcprt to step-print-compressed  TAA
  236.  
  237. ;compress and print a form
  238. (defun step-print-compressed (form)
  239.        (terpri *debug-io*)
  240.        (step-spaces (min 20 *hooklevel*))
  241.        (princ *hooklevel* *debug-io*)
  242.        (princ " >==> " *debug-io*)
  243.        (let ((*print-level* *pdepth*)
  244.          (*print-length* *plen*))
  245.         (prin1 form *debug-io*))
  246.        (princ " " *debug-io*))
  247.  
  248. ;a non-recursive fn to print spaces (not as elegant, easier on the gc)
  249. (defun step-spaces (n) (dotimes (i n) (princ " " *debug-io*)))
  250.  
  251. ;and one to clear the input buffer
  252. (defun step-flush () (while (not (eql (read-char *debug-io*) #\newline))))
  253.  
  254. ;print help
  255. (defun step-help ()
  256.   (terpri *debug-io*)
  257.   (format *debug-io* "Stepper Commands~%" )
  258.  
  259.   (format  *debug-io* "----------------~%" )
  260.  
  261.   (format  *debug-io* " n or space - next form~%" )
  262.  
  263.   (format  *debug-io* " s or <cr>  - step over form~%" )
  264.  
  265.   (format  *debug-io* " f FUNCTION - go until FUNCTION is called~%" )
  266.  
  267.   (format  *debug-io* " b FUNCTION - set breakpoint at FUNCTION~%" )
  268.  
  269.   (format  *debug-io* " b <list>   - set breakpoint at each function in list~%" )
  270.  
  271.   (format  *debug-io* " c FUNCTION - clear breakpoint at FUNCTION~%" )
  272.   (format  *debug-io* " c <list>   - clear breakpoint at each function in list~%" )
  273.   (format  *debug-io* " c *all*    - clear all breakpoints~%" )
  274.   (format  *debug-io* "          g - go until a breakpoint is reached~%" )
  275.   (format  *debug-io* "          u - go up; continue until enclosing form is done~%" )
  276.  
  277.   
  278.   (format   *debug-io*"          w - where am I? -- backtrace~%" )
  279.   (format   *debug-io*"          t - toggle trace on/off~%" )
  280.   (format  *debug-io* "          q - quit stepper, continue execution~%" )
  281.  
  282.  
  283.   (format  *debug-io* "          p - pretty-print current form (uncompressed)~%" )
  284.   (format  *debug-io* "          e - print environment~%" )
  285.   (format  *debug-io* "   x <expr> - execute expression in current environment~%" )
  286.   (format  *debug-io* "   r <expr> - execute and return expression~%" )
  287.  
  288.   (format  *debug-io* "       # nn - set print depth to nn~%" )
  289.   (format  *debug-io* "       . nn - set print length to nn~%" )
  290.  
  291.   (format  *debug-io* "          h - print this summary~%" )
  292.   (terpri *debug-io*))
  293.  
  294.  
  295. ;evaluate a form in the given environment
  296. (defun step-do-form (f1 env)
  297.   (step-spaces *hooklevel*)
  298.   (princ *hooklevel* *debug-io*)
  299.   (princ " res: " *debug-io*)
  300.   (prin1 (evalhook f1 nil nil env) *debug-io*)) ;print result
  301.  
  302. ;set new print depth
  303. (defun step-set-depth (cf)
  304.   (cond ((numberp cf)
  305.          (setq *pdepth* (truncate cf)))
  306.         (t (setq *pdepth* 3))))
  307.  
  308. ;set new print length
  309. (defun step-set-length (cf)
  310.   (cond ((numberp cf)
  311.          (setq *plen* (truncate cf)))
  312.         (t (setq *plen* 3))))
  313.  
  314. ;print environment
  315. (defun step-print-env (env)
  316.   (terpri *debug-io*)
  317.   (step-spaces *hooklevel*)
  318.   (princ *hooklevel* *debug-io*)
  319.   (princ " env: " *debug-io*)
  320.   (prin1 env *debug-io*)
  321.   (terpri *debug-io*))
  322.  
  323. ;set breakpoints
  324. (defun step-set-breaks (l)
  325.   (cond ((null l) t)
  326.         ((symbolp l) (setq *steplist* (cons l *steplist*)))
  327.         ((listp l)
  328.          (step-set-breaks (car l))
  329.          (step-set-breaks (cdr l)))))
  330.  
  331. ;clear breakpoints
  332. (defun step-clear-breaks (l)
  333.   (cond ((null l) t)
  334.         ((eql l '*all*) (setq *steplist* nil))
  335.         ((symbolp l) (delete l *steplist*))
  336.         ((listp l)
  337.          (step-clear-breaks (car l))
  338.          (step-clear-breaks (cdr l)))))
  339.  
  340. ;print backtrace
  341. (defun step-baktrace (&aux l n)
  342.   (setq l *callist*
  343.         n *hooklevel*)
  344.   (while (>= n 0)
  345.     (terpri *debug-io*)
  346.     (step-spaces n)
  347.     (prin1 n *debug-io*)
  348.     (princ " " *debug-io*)
  349.     (if (consp (car l)) ;; must handle case where item is list TAA
  350.         (format *debug-io* "~s ~s" (caar l) (cdar l))
  351.         (prin1 (car l) *debug-io*))
  352.     (setq l (cdr l))
  353.     (setq n (1- n)))
  354.   (terpri *debug-io*))
  355.  
  356. ;; Added function step-add-level for clarity, since function has
  357. ;; become more complex. TAA
  358.  
  359. (defun step-add-level (form env)
  360.        (setq *callist*  ;; Modified so that callist entry can be
  361.                         ;; list where cadr is a tag saved for later
  362.                         ;; match. This us used for block, return-from,
  363.                         ;; catch, and throw.
  364.              (cons (case (car form)
  365.                          ((block return-from)
  366.                           (cons (car form) (cadr form)))
  367.                          ((catch throw) ;; we may need to eval symbol
  368.                           (if (symbolp (cadr form))
  369.                               (cons (car form) 
  370.                                     (evalhook (cadr form) nil nil env))
  371.                               (if (eq (caadr form) 'quote) ;; quoted tag
  372.                                   (cons (car form) (cadadr form))
  373.                                   nil))) ;; out of luck!
  374.                          (t (car form)))
  375.                    *callist*))) ;add fn. to call list
  376.  
  377. ;; Added function step-prune-level for clarity  TAA
  378.  
  379. (defun step-prune-level ()
  380.        (setq *hooklevel* (1- *hooklevel*))
  381.        (setq *callist* (cdr *callist*)))
  382.  
  383. ;; Deleted fix-go, replaced with step-fix-levels which handles go, return,
  384. ;; and return-from. TAA
  385.  
  386. (defun step-fix-levels ()
  387.   (cond ((eq (car *callist*) 'go) ;; go -- prune back to tagbody
  388.          (loop
  389.           (when (null *callist*) (return))      ;; we are lost!
  390.           (when (member (car *callist*)
  391.                         '(loop do do* dolist dotimes prog prog* tagbody))
  392.                 (return))
  393.           (step-prune-level)))
  394.  
  395.  
  396.         ((or (eq (car *callist*) 'return) ;; return -- prune back before block
  397.              (and (consp (car *callist*)) ;; return-from nil is same
  398.                   (eq (caar *callist*) 'return-from) 
  399.                   (null (cdar *callist*))))
  400.          (loop
  401.           (step-prune-level)
  402.           (when (null *callist*) (return))      ;; we are lost!
  403.           (when (member (car *callist*)
  404.                         '(loop do do* dolist dotimes prog prog*))
  405.                 (return))))
  406.  
  407.         ((and (consp (car *callist*)) ;; return-from - prune back before block
  408.               (eq (caar *callist*) 'return-from))
  409.          (let ((target (cdar *callist*)))
  410.               (loop
  411.                (step-prune-level)
  412.                (when (null *callist*) (return)) ;; we are lost!
  413.                (when (or (eq target (car *callist*))
  414.                          (and (consp (car *callist*))
  415.                               (eq (caar *callist*) 'block)
  416.                               (eq (cdar *callist*) target)))
  417.                      (return)))))))
  418.  
  419. ;; Added step-fix-throw TAA
  420.  
  421. (defun step-fix-throw () ;; fix levels after evalhook for throw
  422.        (when (and (consp (car *callist*))
  423.                   (eq (caar *callist*) 'throw))
  424.              (let ((target (cdar *callist*)))
  425.                   (loop
  426.                    (step-prune-level)
  427.                    (when (null *callist*) (return))     ;; we are lost!
  428.                    (when (and (consp (car *callist*))
  429.                               (eq (caar *callist*) 'catch)
  430.                               (eq (cdar *callist*) target))
  431.                          (return))))))
  432.  
  433. ;;-- Modification MCG 5/5/93
  434.  
  435. (defun is-brk-in-form (form brklst)
  436.  (prog () 
  437.   (mapcar #'(lambda (x)
  438.               (cond
  439.                ((listp x) (if (is-brk-in-form x brklst) (return t)))
  440.                ((and (functionp x) (member x brklst)) (return t)))
  441.             )
  442.    form)
  443.    (return nil)))                                         
  444.  
  445. ;; Common Lisp - remove if using in COMMON LISP
  446. #+(and :xlisp :packages (not :common))
  447. (shadow 'functionp)
  448. #+(and :xlisp (not :common))
  449. (defun functionp (x)
  450.     (if (typep x '(or closure subr symbol))
  451.         t
  452.         (and (consp x) (eq (car x) 'lambda))))
  453.  
  454. ;; Use this function  for common LISP 
  455. #-:xlisp
  456. (defun get-key ()
  457.   (let ((val nil))
  458.   (while (or (null val) (eq val #\newline))
  459.          (setq val (read-char))
  460.    ) 
  461.  (char-downcase val)))
  462.  
  463.        
  464.