;
; File: NSTEP.LSP
; Author: Ray Comas (comas@math.lsa.umich.edu)
;
 
(defmacro while (test &rest forms) `(do () ((not ,test)) ,@forms))
(setf newline #\newline)  ;define newline
(setf *hooklevel* 0)	;create the nesting level counter.
(setf *cf* 2)		;create the compression counter
(setf *fcn* '*all*)	;create "one-shot" breakpoint specifier
(setf *steplist* nil)	;create breakpoint list
(setf *steptrace* '(T . T))
(setf *callist* nil)	;create call list for backtrace
 
;this macro invokes the stepper.
(defmacro step (form &aux val)
     `(progn
       (setf *hooklevel* 0)		;init nesting counter
       (setf *cf* 2)			;init compression counter
       (setf *fcn* '*all*)		;init break-point specifier
       (setf *callist* (list (car ',form)))  ;init call list
       (setf *steptrace* '(T . T))
 
       (prin1 ',form)			;print the form
       (terpri)
       (setf val (evalhook ',form		;eval, and kick off stepper
                           #'eval-hook-function
                           nil
                           nil))
       (princ *hooklevel*)           ;print returned value
       (princ " <==< ")
       (prin1 val)
       (terpri)
       val))                         ;and return it
 
(defun eval-hook-function (form env &aux val cmd)
     (setf *hooklevel* (1+ *hooklevel*))	;incr. the nesting level
     (cond ((consp form)			;if interpreted function ...
     	    (setf *callist*
		  (cons (car form) *callist*))  ;add fn. to call list
     	    (tagbody
	      (loop				;repeat forever ...
		;check for a breakpoint
		(when (and (not (equal *fcn* '*all*))
			   (not (equal *fcn* (car form))))
		    (unless (and *fcn* (member (car form) *steplist*))
 
		        ;no breakpoint reached -- continue
		        (setf (cdr *steptrace*) NIL)
		    	(when (car *steptrace*)
		    	      (setf (cdr *steptrace*) T)
			      (fcprt form)
			      (terpri))
                    	(setf val (evalhook form
					#'eval-hook-function
					nil
					env))
			(go next)))
 
		;breakpoint reached -- fix things & get a command
		(fcprt form)
		(setf (cdr *steptrace*) T)
		(setf *fcn* '*all*)	;reset breakpoint specifier
	        (princ ":")		;prompt user
	        (step-flush)		;clear garbage from input line
		(setf cmd (read-char))	;get command from user
 
		;process user's command
            	(cond
		  ((char-equal cmd #\n)		;step into function
                   (setf val (evalhook	form
					#'eval-hook-function
					nil
					env))
                   (go next))
                  ((char-equal cmd #\s)		;step over function
                       (setf val (evalhook form nil nil env))
                       (go next))
            	  ((char-equal cmd #\g)		;go until breakpt. reached
		   (terpri)
            	   (setf *fcn* t)
                   (setf val (evalhook form
				#'eval-hook-function
				nil
				env))
		   (go next))
		  ((char-equal cmd #\w)		;backtrace
		   (step-baktrace))
                  ((char-equal cmd #\h)		;display help
                    (step-help))
		  ((char-equal cmd #\p)		;pretty-print form
		       (terpri)
		       (pprint form))
            	  ((char-equal cmd #\f)		;set function breakpoint
            	   (setf *fcn* (read)))
		  ((char-equal cmd #\b)		;set breakpoint
		   (step-set-breaks (read)))
		  ((char-equal cmd #\c)		;clear a breakpoint
		   (step-clear-breaks (read)))
		  ((char-equal cmd #\t)		;toggle trace mode
		   (setf (car *steptrace*)
		   	 (not (car *steptrace*))))
		  ((char-equal cmd #\q)		;quit stepper
           	   (setf *fcn* nil))
		  ((char-equal cmd #\x)		;evaluate a form
            	   (step-do-form (read) env))
		  ((char-equal cmd #\*)		;set new compress level
		   (step-set-compression (read)))
		  ((char-equal cmd #\e)		;print environment
		   (step-print-env env))
		  (t (princ "Bad command.  Type h<cr> for help\n"))))
 
	next					;exit from loop
	      (setf *callist* (cdr *callist*))	;remove fn. from call list
	      (when (cdr *steptrace*)
		      (step-spaces *hooklevel*)
		      (princ *hooklevel*)
		      (princ " <==< ")       ;print the result
		      (prin1 val)
		      (terpri))))
 
	   ;not an interpreted function -- just trace thru.
           (t (unless (not (symbolp form))
		(when (car *steptrace*)
		        (step-spaces *hooklevel*) ;if form is a symbol ...
        	        (princ "         ")
                	(prin1 form)		  ;... print the form ...
	                (princ " = ")))
              (setf val (evalhook form nil nil env)) ;eval it
              (unless (not (symbolp form))
		(when (car *steptrace*)
	                (prin1 val)		     ;... and value
        	        (terpri)))))
     (setf *hooklevel* (1- *hooklevel*))     ;decrement level
     val)                                    ;and return the value
 
;compress a list
(defun compress (l cf)		;cf == compression factor
  (cond ((null l) nil)
	((atom l) l)
  	((eql cf 0) (if (atom l) l '**))
  	(T (cons (compress (car l) (1- cf)) (compress (cdr l) cf)))))
 
;compress and print a form
(defun fcprt (form)
  (step-spaces *hooklevel*)
  (princ *hooklevel*)
  (princ " >==> ")
  (prin1 (compress form *cf*))
  (princ " "))
 
;a non-recursive fn to print spaces (not as elegant, easier on the gc)
(defun step-spaces (n) (dotimes (i n) (princ " ")))
 
;and one to clear the input buffer
(defun step-flush () (while (not (eql (read-char) newline))))
 
;print help
(defun step-help ()
   (terpri)
   (princ "Stepper Commands\n")
   (princ "----------------\n")
   (princ "          n - next form\n")
   (princ "          s - step over form\n")
   (princ " f FUNCTION - go until FUNCTION is called\n")
   (princ " b FUNCTION - set breakpoint at FUNCTION\n")
   (princ " b <list>   - set breakpoint at each function in list\n")
   (princ " c FUNCTION - clear breakpoint at FUNCTION\n")
   (princ " c <list>   - clear breakpoint at each function in list\n")
   (princ " c *all*    - clear all breakpoints\n")
   (princ "          g - go until a breakpoint is reached\n")
   (princ "          w - where am I? -- backtrace\n")
   (princ "          t - toggle trace on/off\n")
   (princ "          q - quit stepper, continue execution\n")
   (princ "          p - pretty-print current form (uncompressed)\n")
   (princ "          e - print environment\n")
   (princ "   x <expr> - execute expression in current environment\n")
   (princ "       * nn - set list compression to nn\n")
   (princ "          h - print this summary\n")
   (princ "  All commands are terminated by <cr>\n")
   (terpri))
 
;evaluate a form in the given environment
(defun step-do-form (f1 env)
  (step-spaces *hooklevel*)
  (princ *hooklevel*)
  (princ " res: ")
  (prin1 (evalhook f1 nil nil env))   ;print result
  (princ " "))
 
;set new compression factor
(defun step-set-compression (cf)
  (cond ((numberp cf)
	 (setf *cf* (truncate cf)))
	(t (setf *cf* 2))))
 
;print environment
(defun step-print-env (env)
  (step-spaces *hooklevel*)
  (princ *hooklevel*)
  (princ " env: ")
  (prin1 env)
  (terpri))
 
;set breakpoints
(defun step-set-breaks (l)
  (cond ((null l) t)
	((symbolp l) (setf *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*) (setf *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)
  (setf l *callist*)
  (setf n *hooklevel*)
  (while (>= n 0)
    (step-spaces n)
    (prin1 n) (princ " ")
    (prin1 (car l))
    (terpri)
    (setf l (cdr l))
    (setf n (1- n))))