src/lsp/stepper.lsp

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