;;
;; File: STEPPER.LSP
;; Author: Ray Comas (comas@math.lsa.umich.edu)
;;
;; Modifications and corrections by Tom Almy
;; The program did not correctly handle RETURN (as reported by Martin
;; Glanvill, mcg@waikato.ac.nz). In the process of fixing the the
;; problem it was discovered that the nexting printout did not work
;; properly for all return, return-from, throw, and many cases of go.
;; This version has been fixed for hopefully all of the above, although
;; go will still not produce proper printout if the jump is outside the
;; most enclosing tagbody, and the tag arguments of catch/throw must
;; either be symbols or quoted symbols. I'm making no attempt here to
;; correctly handle tracing of unwind-protect, either!
;; Modifications marked "TAA"
;; Tom Almy 5/92
;;-----------------------------------------
;; Modifications -
;;
;; Function : Eval-hook-function
;;
;; Modifcation :- MCG 5/5/93
;;
;; "is-brk-in-form" function added to look in advance
;; to see if any break points are in the current form.
;; If not, then the stepper will step over the form
;; without evaluating the sub-forms within the current form
;; (as original did); if break point found then it steps into
;; the form.
;; The Advantage is when you have a break point at the end of
;; a prog with massive amounts of DO loops, you don't want to waste
;; time stepping into the do loop!
;; Also I've modified it for use on COMMON LISP and XLISP
;; See notes at bottom.
;; Problems: in CL, step into LOOP's/ PROGN's before
;; excuting the "g" command!
;; Future Updates : further investigation of LOOPS and PROGn's as above.
;; Modification: TAA 5/5/93
;; I made the Common Lisp vs. Xlisp choice automatic via conditional
;; compilation (Gee, I was hoping to find a good use for this feature!)
;; Modifications for use with XLISP-STAT:
;; moved step to XLISP package
;; removed conditionals
;; LT 2/9/94
(in-package "XLISP")
(export '(step *stepper-depth* *stepper-length*))
(defpackage "TOOLS" (:use "XLISP"))
(in-package "TOOLS")
(defmacro while (test &rest forms) `(do () ((not ,test)) ,@forms))
(defparameter *hooklevel* 0) ;create the nesting level counter.
(defvar *stepper-depth* 3) ;create depth counter
(defvar *stepper-length* 3) ;create length counter
(defparameter *fcn* '*all*) ;create "one-shot" breakpoint specifier
(defvar *steplist* nil) ;create breakpoint list
(defparameter *steptrace* '(t . t)) ;create stepping flags
(defparameter *callist* nil) ;create call list for backtrace
; this macro invokes the stepper - MCG 5/5/93 step -> usr-step , CL mod.
(defmacro xlisp::step (form &aux (val (gensym)))
`(let ((,val nil))
(setq *hooklevel* 0 ;init nesting counter
*fcn* '*all* ;init break-point specifier
*steptrace* '(t . t))
(setq *callist* (list (car ',form))) ;init call list
(terpri *debug-io*)
(step-flush)
(princ *hooklevel* *debug-io*)
(princ " >==> " *debug-io*)
(prin1 ',form *debug-io*) ;print the form
(setq ,val (evalhook ',form ;eval, and kick off stepper
#'eval-hook-function
nil
nil))
(terpri *debug-io*)
(princ *hooklevel* *debug-io*) ;print returned value
(princ " <==< " *debug-io*)
(prin1 ,val *debug-io*)
(terpri *debug-io*)
,val)) ;and return it
(defun eval-hook-function (form env &aux val cmd)
(setq *hooklevel* (1+ *hooklevel*)) ;incr. the nesting level
(cond ((consp form) ;if interpreted function ...
(step-add-level form env) ;; add to *call-list* TAA
(tagbody
(loop ;repeat forever ...
;check for a breakpoint
(when (and (not (equal *fcn* '*all*))
(not (equal *fcn* (car form)))
(not (and (numberp *fcn*) (>= *fcn* *hooklevel*))))
(unless (and *fcn* (member (car form) *steplist*))
;no breakpoint reached -- continue
(setf (cdr *steptrace*) nil)
(when (car *steptrace*)
(setf (cdr *steptrace*) t)
(step-print-compressed form))
(cond ;- MCG 5/5/93
((is-brk-in-form form *steplist*)
(setq val (list form
#'eval-hook-function
nil
env)))
(t (setq val (list form nil nil env))))
(go next)))
;breakpoint reached -- fix things & get a command
(step-print-compressed form)
(setf (cdr *steptrace*) t)
(setq *fcn* '*all*) ;reset breakpoint specifier
(princ " :" *debug-io*) ;prompt user
(setq cmd ;get command from user
(get-key))
;process user's command
(cond
((or (eql cmd #\n) (eql cmd #\Space)) ;step into function
(setq val (list form
#'eval-hook-function
nil
env))
(go next))
((or (eql cmd #\s) ;step over function
(eql cmd #\Newline)
) ;; Added check for control-M TAA
(setq val (list form nil nil env))
(go next))
((eql cmd #\g) ;go until breakpt. reached
(setq *fcn* t)
(setq val (list form
#'eval-hook-function
nil
env))
(go next))
((eql cmd #\w) ;backtrace
(step-baktrace))
((eql cmd #\h) ;display help
(step-help))
((eql cmd #\p) ;pretty-print form
(terpri *debug-io*)
(pprint form *debug-io*))
((eql cmd #\f) ;set function breakpoint
(princ "Go to fn.: " *debug-io*)
(setq *fcn* (read *debug-io*))
(step-flush))
((eql cmd #\u) ;go up one level
(setq *fcn* (1- *hooklevel*)))
((eql cmd #\b) ;set breakpoint
(princ "Bkpt.: " *debug-io*)
(step-set-breaks (read *debug-io*))
(step-flush))
((eql cmd #\c) ;clear a breakpoint
(princ "Clear: " *debug-io*)
(step-clear-breaks (read *debug-io*))
(step-flush))
((eql cmd #\t) ;toggle trace mode
(setf (car *steptrace*)
(not (car *steptrace*)))
(princ "Trace = " *debug-io*)
(prin1 (car *steptrace*) *debug-io*))
((eql cmd #\q) ;quit stepper
(setq *fcn* nil))
((eql cmd #\x) ;evaluate a form
(princ "Eval: " *debug-io*)
(step-do-form (read *debug-io*) env)
(step-flush))
((eql cmd #\r) ;return given expression
(princ "Return: " *debug-io*)
(setq val (list (read *debug-io*) nil nil env))
(step-flush)
(go next))
((eql cmd #\#) ;set new compress level
(princ "Depth: " *debug-io*)
(step-set-depth (read *debug-io*))
(step-flush))
((eql cmd #\.)
(princ "Len.: " *debug-io*)
(step-set-length (read *debug-io*))
(step-flush))
((eql cmd #\e) ;print environment
(step-print-env env))
(t (princ "Bad command. Type h for help\n" *debug-io*))))
next ;exit from loop
;; call of evalhook was done prior to "go next" in the loop above.
;; now it's done outside the loop to solve problems handling
;; return. TAA
(step-fix-levels)
(setq val (apply #'evalhook val))
(step-fix-throw)
(when (cdr *steptrace*)
(terpri *debug-io*)
(step-spaces *hooklevel*)
(princ *hooklevel* *debug-io*)
(princ " <==< " *debug-io*) ;print the result
(prin1 val *debug-io*))
(step-prune-level))) ;; step-prune-level replaces inline code TAA
;not an interpreted function -- just trace thru.
(t (unless (not (symbolp form))
(when (car *steptrace*)
(terpri *debug-io*)
(step-spaces *hooklevel*) ;if form is a symbol ...
(princ " " *debug-io*)
(prin1 form *debug-io*) ;... print the form ...
(princ " = " *debug-io*)))
(setq val (evalhook form nil nil env)) ;eval it
(setq *hooklevel* (1- *hooklevel*)) ;decrement level
(unless (not (symbolp form))
(when (car *steptrace*)
(prin1 val *debug-io*))))) ;... and the value
val) ;and return the value
;; Made compress local function
;; and changed name fcprt to step-print-compressed TAA
;compress and print a form
(defun step-print-compressed (form)
(terpri *debug-io*)
(step-spaces (min 20 *hooklevel*))
(princ *hooklevel* *debug-io*)
(princ " >==> " *debug-io*)
(let ((*print-level* *stepper-depth*)
(*print-length* *stepper-length*))
(prin1 form *debug-io*))
(princ " " *debug-io*))
;a non-recursive fn to print spaces (not as elegant, easier on the gc)
(defun step-spaces (n) (dotimes (i n) (princ " " *debug-io*)))
;and one to clear the input buffer
(defun step-flush () (while (not (eql (read-char *debug-io*) #\newline))))
;print help
(defun step-help ()
(terpri *debug-io*)
(format *debug-io* "Stepper Commands~%" )
(format *debug-io* "----------------~%" )
(format *debug-io* " n or space - next form~%" )
(format *debug-io* " s or <cr> - step over form~%" )
(format *debug-io* " f FUNCTION - go until FUNCTION is called~%" )
(format *debug-io* " b FUNCTION - set breakpoint at FUNCTION~%" )
(format *debug-io* " b <list> - set breakpoint at each function in list~%" )
(format *debug-io* " c FUNCTION - clear breakpoint at FUNCTION~%" )
(format *debug-io* " c <list> - clear breakpoint at each function in list~%" )
(format *debug-io* " c *all* - clear all breakpoints~%" )
(format *debug-io* " g - go until a breakpoint is reached~%" )
(format *debug-io* " u - go up; continue until enclosing form is done~%" )
(format *debug-io*" w - where am I? -- backtrace~%" )
(format *debug-io*" t - toggle trace on/off~%" )
(format *debug-io* " q - quit stepper, continue execution~%" )
(format *debug-io* " p - pretty-print current form (uncompressed)~%" )
(format *debug-io* " e - print environment~%" )
(format *debug-io* " x <expr> - execute expression in current environment~%" )
(format *debug-io* " r <expr> - execute and return expression~%" )
(format *debug-io* " # nn - set print depth to nn~%" )
(format *debug-io* " . nn - set print length to nn~%" )
(format *debug-io* " h - print this summary~%" )
(terpri *debug-io*))
;evaluate a form in the given environment
(defun step-do-form (f1 env)
(step-spaces *hooklevel*)
(princ *hooklevel* *debug-io*)
(princ " res: " *debug-io*)
(prin1 (evalhook f1 nil nil env) *debug-io*)) ;print result
;set new print depth
(defun step-set-depth (cf)
(cond ((numberp cf)
(setq *stepper-depth* (truncate cf)))
(t (setq *stepper-depth* 3))))
;set new print length
(defun step-set-length (cf)
(cond ((numberp cf)
(setq *stepper-length* (truncate cf)))
(t (setq *stepper-length* 3))))
;print environment
(defun step-print-env (env)
(terpri *debug-io*)
(step-spaces *hooklevel*)
(princ *hooklevel* *debug-io*)
(princ " env: " *debug-io*)
(prin1 env *debug-io*)
(terpri *debug-io*))
;set breakpoints
(defun step-set-breaks (l)
(cond ((null l) t)
((symbolp l) (setq *steplist* (cons l *steplist*)))
((listp l)
(step-set-breaks (car l))
(step-set-breaks (cdr l)))))
;clear breakpoints
(defun step-clear-breaks (l)
(cond ((null l) t)
((eql l '*all*) (setq *steplist* nil))
((symbolp l) (delete l *steplist*))
((listp l)
(step-clear-breaks (car l))
(step-clear-breaks (cdr l)))))
;print backtrace
(defun step-baktrace (&aux l n)
(setq l *callist*
n *hooklevel*)
(while (>= n 0)
(terpri *debug-io*)
(step-spaces n)
(prin1 n *debug-io*)
(princ " " *debug-io*)
(if (consp (car l)) ;; must handle case where item is list TAA
(format *debug-io* "~s ~s" (caar l) (cdar l))
(prin1 (car l) *debug-io*))
(setq l (cdr l))
(setq n (1- n)))
(terpri *debug-io*))
;; Added function step-add-level for clarity, since function has
;; become more complex. TAA
(defun step-add-level (form env)
(setq *callist* ;; Modified so that callist entry can be
;; list where cadr is a tag saved for later
;; match. This us used for block, return-from,
;; catch, and throw.
(cons (case (car form)
((block return-from)
(cons (car form) (cadr form)))
((catch throw) ;; we may need to eval symbol
(if (symbolp (cadr form))
(cons (car form)
(evalhook (cadr form) nil nil env))
(if (eq (caadr form) 'quote) ;; quoted tag
(cons (car form) (cadadr form))
nil))) ;; out of luck!
(t (car form)))
*callist*))) ;add fn. to call list
;; Added function step-prune-level for clarity TAA
(defun step-prune-level ()
(setq *hooklevel* (1- *hooklevel*))
(setq *callist* (cdr *callist*)))
;; Deleted fix-go, replaced with step-fix-levels which handles go, return,
;; and return-from. TAA
(defun step-fix-levels ()
(cond ((eq (car *callist*) 'go) ;; go -- prune back to tagbody
(loop
(when (null *callist*) (return)) ;; we are lost!
(when (member (car *callist*)
'(loop do do* dolist dotimes prog prog* tagbody))
(return))
(step-prune-level)))
((or (eq (car *callist*) 'return) ;; return -- prune back before block
(and (consp (car *callist*)) ;; return-from nil is same
(eq (caar *callist*) 'return-from)
(null (cdar *callist*))))
(loop
(step-prune-level)
(when (null *callist*) (return)) ;; we are lost!
(when (member (car *callist*)
'(loop do do* dolist dotimes prog prog*))
(return))))
((and (consp (car *callist*)) ;; return-from - prune back before block
(eq (caar *callist*) 'return-from))
(let ((target (cdar *callist*)))
(loop
(step-prune-level)
(when (null *callist*) (return)) ;; we are lost!
(when (or (eq target (car *callist*))
(and (consp (car *callist*))
(eq (caar *callist*) 'block)
(eq (cdar *callist*) target)))
(return)))))))
;; Added step-fix-throw TAA
(defun step-fix-throw () ;; fix levels after evalhook for throw
(when (and (consp (car *callist*))
(eq (caar *callist*) 'throw))
(let ((target (cdar *callist*)))
(loop
(step-prune-level)
(when (null *callist*) (return)) ;; we are lost!
(when (and (consp (car *callist*))
(eq (caar *callist*) 'catch)
(eq (cdar *callist*) target))
(return))))))
;;-- Modification MCG 5/5/93
(defun is-brk-in-form (form brklst)
(prog ()
(mapcar #'(lambda (x)
(cond
((listp x) (if (is-brk-in-form x brklst) (return t)))
((and (or (symbolp x) (functionp x))
(member x brklst))
(return t)))
)
form)
(return nil)))
;; Use this function for common LISP
(defun get-key ()
(let ((val nil))
(while (or (null val) (eq val #\newline))
(setq val (read-char))
)
(char-downcase val)))
syntax highlighted by Code2HTML, v. 0.9.1