xlisponly/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
   8 ;; problem it was discovered that the nesting 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 ;; Modification :- 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 ;;           executing 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 ;; Modification: LSG 5/7/96 Leo Sarasua
  45
  46 ;; I added char-downcase-safe to prevent aborting the execution
  47 ;; when pressing an arrow or a control key. Now it is possible to use the
  48 ;; arrows and recall the previous input lines of the internal xlisp line
  49 ;; editor.
  50 ;; Also the breakpoints couldn't be deleted. I've solved that too.
  51 ;; Another problem was with functions returning multiple values. The
  52 ;; secondary values were getting lost. Now they are correctly handled.
  53 ;; Finally, I added an extra feature: conditional breakpoints. They act
  54 ;; when a predefined test function returns non-nil. They are useful when
  55 ;; trying to trap a certain condition and you don't know where it is
  56 ;; originated. Also, when you have long loops and you only want to break
  57 ;; after a certain number of iterations, without having to step manually
  58 ;; into the loop each time.
  59 ;; Type ! and then the function, to create the conditional breakpoint function.
  60 ;; Example: ! (> n 100) and then 'g' will run until (> n 100) returns t
  61 ;; in the current environment.
  62
  63
  64 #+:packages
  65 (unless (find-package "TOOLS")
  66         (make-package "TOOLS" :use '("XLISP")))
  67
  68 (in-package "TOOLS")
  69
  70 (export '(step))
  71
  72
  73 (defmacro while (test &rest forms) `(do () ((not ,test)) ,@forms))
  74
  75 (defparameter *hooklevel* 0)        ;create the nesting level counter.
  76 (defvar       *pdepth*    3)        ;create depth counter
  77 (defvar       *plen*      3)        ;create length counter
  78 (defparameter *fcn*       '*all*)   ;create "one-shot" breakpoint specifier
  79 (defvar       *break-point-fn*  nil);create conditional breakpoint ; LSG
  80 (defvar       *steplist*  nil)      ;create breakpoint list
  81 (defparameter *steptrace* '(t . t)) ;create stepping flags
  82 (defparameter *callist*   nil)      ;create call list for backtrace
  83
  84
  85 ; This macro invokes the stepper - MCG 5/5/93 step -> usr-step , CL mod.
  86 (defmacro #+:xlisp step #-:xlisp usr-step (form &aux val)
  87   `(progn
  88      (setq *hooklevel*  0               ;init nesting counter
  89            *fcn*        '*all*          ;init break-point specifier
  90            *break-point-fn*  nil
  91            *steptrace*  '(t . t))
  92      (setq *callist* (list (car ',form))) ;init call list
  93      (terpri *debug-io*)
  94      (step-flush)
  95      (princ *hooklevel* *debug-io*)
  96      (princ " >==> " *debug-io*)
  97      (prin1 ',form *debug-io*)          ;print the form
  98      (setq val
  99         (multiple-value-list
 100             (evalhook ',form            ;eval, and kick off stepper
 101                        #'eval-hook-function
 102                        nil
 103                        nil)))
 104      (terpri *debug-io*)
 105      (princ *hooklevel* *debug-io*)     ;print returned value
 106      (princ " <==< " *debug-io*)
 107      (format *debug-io* "~{~a ~}~%" val)  ; LSG
 108      (values-list val)))                ;and return it. LSG
 109
 110
 111 (defun eval-hook-function (form env &aux val cmd condtbrk)
 112   (setq *hooklevel* (1+ *hooklevel*));; Incr. the nesting level
 113   (setq condtbrk                     ;;
 114         (and *break-point-fn*
 115              (step-break-point-form *break-point-fn* env) )) ; LSG
 116   (cond
 117      ((consp form)                   ;; If interpreted function ...
 118       (step-add-level form env)      ;; add to *call-list*  TAA
 119       (tagbody
 120         (loop                         ;repeat forever ...
 121                                        ;check for a breakpoint
 122           (when (and (not (equal *fcn* '*all*))
 123                      (not (equal *fcn* (car form)))
 124                      (not (and (numberp *fcn*) (>= *fcn* *hooklevel*)))
 125                      (not condtbrk) ) ; LSG
 126                 (unless (and *fcn* (member (car form) *steplist*))
 127                     ;no breakpoint reached -- continue
 128                         (setf (cdr *steptrace*) nil)
 129                         (when (car *steptrace*)
 130                               (setf (cdr *steptrace*) t)
 131                               (step-print-compressed form))
 132
 133                         (if (or (is-brk-in-form form *steplist*) ;- MCG 5/5/93
 134                                 *break-point-fn* ) ; LSG
 135                             (setq val (list form
 136                                             #'eval-hook-function
 137                                             nil
 138                                             env ))
 139                             (setq val (list form nil nil env)) )
 140                         (go next)))
 141
 142          ;breakpoint reached -- fix things & get a command
 143           (step-print-compressed form)
 144           (setf (cdr *steptrace*) t)
 145           (setq *fcn* '*all*)          ;reset breakpoint specifier
 146           (princ " :" *debug-io*)      ;prompt user
 147
 148 #-:xlisp
 149           (setq cmd (get-key))         ;get command from user
 150
 151 #+:xlisp
 152           (setq cmd                    ;get command from user
 153                 (char-downcase-safe (code-char (get-key))))  ; LSG
 154
 155                                         ;process user's command
 156           (cond
 157             ((or (eql cmd #\n) (eql cmd #\Space)) ;step into function
 158              (setq val (list form
 159                              #'eval-hook-function
 160                              nil
 161                              env ))
 162              (go next))
 163             ((or (eql cmd #\s)          ;step over function
 164
 165 #+:xlisp         (eql cmd #\Newline)
 166 #+:xlisp         (eql cmd #\C-M)
 167
 168              ) ;; Added check for control-M TAA
 169              (setq val (list form nil nil env))
 170              (go next))
 171             ((eql cmd #\g)              ;go until breakpt. reached
 172              (setq *fcn* t)
 173              (setq val (list form
 174                              #'eval-hook-function
 175                              nil
 176                              env ))
 177              (go next))
 178             ((eql cmd #\w)              ;backtrace
 179              (step-baktrace))
 180             ((eql cmd #\h)              ;display help
 181              (step-help))
 182             ((eql cmd #\p)              ;pretty-print form
 183              (terpri *debug-io*)
 184              (pprint form *debug-io*))
 185             ((eql cmd #\f)              ;set function breakpoint
 186              (princ "Go to fn.: " *debug-io*)
 187              (setq *fcn* (read *debug-io*))
 188              (step-flush))
 189             ((eql cmd #\u)              ;go up one level
 190              (setq *fcn* (1- *hooklevel*)))
 191             ((eql cmd #\b)              ;set breakpoint
 192              (princ "Bkpt.: " *debug-io*)
 193              (step-set-breaks (read *debug-io*))
 194              (step-flush))
 195             ((eql cmd #\!)              ;set breakpoint test condition LSG
 196              (princ "Bkpt. Function: " *debug-io*)
 197              (step-set-cond-breaks (read *debug-io*))
 198              (step-flush))
 199             ((eql cmd #\/)              ;cancel breakpoint condition LSG
 200              (when *break-point-fn*
 201                 (setq *break-point-fn* nil)
 202                 (setq condtbrk nil)
 203                 (princ "Breakpoint condition cancelled" *debug-io*) ))
 204             ((eql cmd #\c)              ;clear a breakpoint
 205              (princ "Clear: " *debug-io*)
 206              (step-clear-breaks (read *debug-io*))
 207              (step-flush))
 208             ((eql cmd #\t)              ;toggle trace mode
 209              (setf (car *steptrace*)
 210                    (not (car *steptrace*)))
 211              (princ "Trace = " *debug-io*)
 212              (prin1 (car *steptrace*) *debug-io*))
 213             ((eql cmd #\q)              ;quit stepper
 214              (setq *fcn* nil)
 215              (setq condtbrk nil)
 216              (setq *break-point-fn* nil) ) ; LSG
 217             ((eql cmd #\x)              ;evaluate a form
 218              (princ "Eval: " *debug-io*)
 219              (step-do-form (read *debug-io*) env)
 220              (step-flush))
 221             ((eql cmd #\r)              ;return given expression
 222              (princ "Return: " *debug-io*)
 223              (setq val (list (read *debug-io*) nil nil env))
 224              (step-flush)
 225              (go next))
 226             ((eql cmd #\#)              ;set new compress level
 227              (princ "Depth: " *debug-io*)
 228              (step-set-depth (read *debug-io*))
 229              (step-flush))
 230             ((eql cmd #\.)
 231              (princ "Len.: " *debug-io*)
 232              (step-set-length (read *debug-io*))
 233              (step-flush))
 234             ((eql cmd #\e)              ;print environment
 235              (step-print-env env))
 236             (t (princ "Bad command.  Type h for help\n" *debug-io*))))
 237
 238           next                          ;exit from loop
 239
 240           ;; call of evalhook was done prior to "go next" in the loop above.
 241           ;; now it's done outside the loop to solve problems handling
 242           ;; return.  TAA
 243           (step-fix-levels)
 244           (setq val (multiple-value-list (apply #'evalhook val))) ; LSG
 245           (step-fix-throw)
 246           (when (cdr *steptrace*)
 247                 (terpri *debug-io*)
 248                 (step-spaces *hooklevel*)
 249                 (princ *hooklevel* *debug-io*)
 250                 (princ " <==< " *debug-io*) ;print the result
 251                 (format *debug-io* "~{~a ~}" val))
 252           (step-prune-level))) ;; step-prune-level replaces inline code TAA
 253
 254    ;; Not an interpreted function -- just trace thru.
 255      (t (when (symbolp form)
 256               (when (car *steptrace*)
 257                     (terpri *debug-io*)
 258                     (step-spaces *hooklevel*)  ; If form is a symbol ...
 259                     (princ "         " *debug-io*)
 260                     (prin1 form *debug-io*)    ; ... print the form ...
 261                     (princ " = " *debug-io*) ))
 262         (setq val
 263               (multiple-value-list
 264                  (evalhook form nil nil env))) ; Eval it. LSG
 265         (setq *hooklevel* (1- *hooklevel*))  ;decrement level
 266         (when (symbolp form) ; LSG
 267               (when (car *steptrace*)
 268                     (format *debug-io* "~{~a ~}" val))))) ; Print the value
 269   (values-list val))                                      ; and return it
 270
 271
 272
 273 ;; Made compress local function
 274 ;; and changed name fcprt to step-print-compressed  TAA
 275
 276 ;compress and print a form
 277 (defun step-print-compressed (form)
 278   (terpri *debug-io*)
 279   (step-spaces (min 20 *hooklevel*))
 280   (princ *hooklevel* *debug-io*)
 281   (princ " >==> " *debug-io*)
 282   (let ((*print-level* *pdepth*)
 283         (*print-length* *plen*) )
 284     (prin1 form *debug-io*) )
 285   (princ " " *debug-io*) )
 286
 287 ;a non-recursive fn to print spaces (not as elegant, easier on the gc)
 288 (defun step-spaces (n) (dotimes (i n) (princ " " *debug-io*)))
 289
 290 ;and one to clear the input buffer
 291 (defun step-flush () (while (not (eql (read-char *debug-io*) #\newline))))
 292
 293 ;print help
 294 (defun step-help () ; LSG
 295   (terpri *debug-io*)
 296   (format  *debug-io* "
 297                        Stepper Commands
 298        ~%")
 299   (format  *debug-io* "  n or space - next form
 300        ~%")
 301   (format  *debug-io* "  s or <CR>  - step over form
 302        ~%")
 303   (format  *debug-io* "  f <fcn>    - go until <fcn> is called
 304        ~%")
 305   (format  *debug-io* "  b <fcn>    - set breakpoint at <fcn>
 306        ~%")
 307   (format  *debug-io* "  b <list>   - set breakpoint at each function in list
 308        ~%")
 309   (format  *debug-io* "  c <fcn>    - clear breakpoint at <fcn>
 310        ~%")
 311   (format  *debug-io* "  c <list>   - clear breakpoint at each function in list
 312        ~%")
 313   (format  *debug-io* "  c *all*    - clear all breakpoints
 314        ~%")
 315   (format  *debug-io* "  ! <test>   - set breakpoint when <test> returns non-nil
 316        ~%")
 317   (format  *debug-io* "  / <fcn>    - cancel breakpoint set with !
 318        ~%")
 319   (format  *debug-io* "  g          - go until a breakpoint is reached
 320        ~%")
 321   (format  *debug-io* "  u          - go up; continue until enclosing form is do
 322 ne     ~%")
 323   (format  *debug-io* "  w          - where am I? -- backtrace
 324        ~%")
 325   (format  *debug-io* "  t          - toggle trace on/off
 326        ~%")
 327   (format  *debug-io* "  q          - quit stepper, continue execution
 328        ~%")
 329   (format  *debug-io* "  p          - pretty-print current form (uncompressed)
 330        ~%")
 331   (format  *debug-io* "  e          - print environment
 332        ~%")
 333   (format  *debug-io* "  x <expr>   - execute expression in current environment
 334        ~%")
 335   (format  *debug-io* "  r <expr>   - execute and return expression
 336        ~%")
 337   (format  *debug-io* "  # nn       - set print depth to nn
 338        ~%")
 339   (format  *debug-io* "  . nn       - set print length to nn
 340        ~%")
 341   (format  *debug-io* "  h          - print this summary
 342        ~%")
 343   (format  *debug-io* "
 344        ")
 345   )
 346
 347
 348 ;evaluate a form in the given environment
 349 (defun step-do-form (f1 env)
 350   (step-spaces *hooklevel*)
 351   (princ *hooklevel* *debug-io*)
 352   (princ " res: " *debug-io*)
 353   (prin1 (evalhook f1 nil nil env) *debug-io*)) ;print result
 354
 355 ;evaluate break-point form in the given environment LSG
 356 (defun step-break-point-form (f1 env)
 357   (evalhook f1 nil nil env) )
 358
 359 (defun step-set-cond-breaks (l)
 360    (setq *break-point-fn* l) )
 361
 362 ;set new print depth
 363 (defun step-set-depth (cf)
 364   (cond ((numberp cf)
 365          (setq *pdepth* (truncate cf)))
 366         (t (setq *pdepth* 3))))
 367
 368 ;set new print length
 369 (defun step-set-length (cf)
 370   (cond ((numberp cf)
 371          (setq *plen* (truncate cf)))
 372         (t (setq *plen* 3))))
 373
 374 ;print environment
 375 (defun step-print-env (env)
 376   (terpri *debug-io*)
 377   (step-spaces *hooklevel*)
 378   (princ *hooklevel* *debug-io*)
 379   (princ " env: " *debug-io*)
 380   (prin1 env *debug-io*)
 381   (terpri *debug-io*))
 382
 383 ;set breakpoints
 384 (defun step-set-breaks (l)
 385   (cond ((null l) t)
 386         ((symbolp l) (setq *steplist* (cons l *steplist*)))
 387         ((listp l)
 388          (step-set-breaks (car l))
 389          (step-set-breaks (cdr l)))))
 390
 391 ;clear breakpoints
 392 (defun step-clear-breaks (l)
 393   (cond ((null l) t)
 394         ((eql l '*all*) (setq *steplist* nil))
 395         ((symbolp l) (setq *steplist* (delete l *steplist*))) ; LSG
 396         ((listp l)
 397          (step-clear-breaks (car l))
 398          (step-clear-breaks (cdr l)))))
 399
 400 ;print backtrace
 401 (defun step-baktrace (&aux l n)
 402   (setq l *callist*
 403         n *hooklevel*)
 404   (while (>= n 0)
 405     (terpri *debug-io*)
 406     (step-spaces n)
 407     (prin1 n *debug-io*)
 408     (princ " " *debug-io*)
 409     (if (consp (car l)) ;; must handle case where item is list TAA
 410         (format *debug-io* "~s ~s" (caar l) (cdar l))
 411         (prin1 (car l) *debug-io*))
 412     (setq l (cdr l))
 413     (setq n (1- n)))
 414   (terpri *debug-io*))
 415
 416 ;; Added function step-add-level for clarity, since function has
 417 ;; become more complex. TAA
 418
 419 (defun step-add-level (form env)
 420    (setq *callist*  ;; Modified so that callist entry can be
 421                     ;; list where cadr is a tag saved for later
 422                     ;; match. This us used for block, return-from,
 423                     ;; catch, and throw.
 424        (cons (case (car form)
 425                  ((block return-from)
 426                   (cons (car form) (cadr form)))
 427                  ((catch throw) ;; we may need to eval symbol
 428                   (if (symbolp (cadr form))
 429                       (cons (car form)
 430                             (evalhook (cadr form) nil nil env))
 431                       (if (eq (caadr form) 'quote) ;; quoted tag
 432                           (cons (car form) (cadadr form))
 433                           nil))) ;; out of luck!
 434                  (t (car form)))
 435              *callist*))) ;add fn. to call list
 436
 437 ;; Added function step-prune-level for clarity  TAA
 438
 439 (defun step-prune-level ()
 440        (setq *hooklevel* (1- *hooklevel*))
 441        (setq *callist* (cdr *callist*)))
 442
 443 ;; Deleted fix-go, replaced with step-fix-levels which handles go, return,
 444 ;; and return-from. TAA
 445
 446 (defun step-fix-levels ()
 447   (cond ((eq (car *callist*) 'go) ;; go -- prune back to tagbody
 448          (loop
 449           (when (null *callist*) (return))      ;; we are lost!
 450           (when (member (car *callist*)
 451                         '(loop do do* dolist dotimes prog prog* tagbody))
 452                 (return))
 453           (step-prune-level)))
 454
 455
 456         ((or (eq (car *callist*) 'return) ;; return -- prune back before block
 457              (and (consp (car *callist*)) ;; return-from nil is same
 458                   (eq (caar *callist*) 'return-from)
 459                   (null (cdar *callist*))))
 460          (loop
 461           (step-prune-level)
 462           (when (null *callist*) (return))      ;; we are lost!
 463           (when (member (car *callist*)
 464                         '(loop do do* dolist dotimes prog prog*))
 465                 (return))))
 466
 467         ((and (consp (car *callist*)) ;; return-from - prune back before block
 468               (eq (caar *callist*) 'return-from))
 469          (let ((target (cdar *callist*)))
 470               (loop
 471                (step-prune-level)
 472                (when (null *callist*) (return)) ;; we are lost!
 473                (when (or (eq target (car *callist*))
 474                          (and (consp (car *callist*))
 475                               (eq (caar *callist*) 'block)
 476                               (eq (cdar *callist*) target)))
 477                      (return)))))))
 478
 479 ;; Added step-fix-throw TAA
 480
 481 (defun step-fix-throw () ;; fix levels after evalhook for throw
 482        (when (and (consp (car *callist*))
 483                   (eq (caar *callist*) 'throw))
 484              (let ((target (cdar *callist*)))
 485                   (loop
 486                    (step-prune-level)
 487                    (when (null *callist*) (return))     ;; we are lost!
 488                    (when (and (consp (car *callist*))
 489                               (eq (caar *callist*) 'catch)
 490                               (eq (cdar *callist*) target))
 491                          (return))))))
 492
 493 ;;-- Modification MCG 5/5/93
 494
 495 (defun is-brk-in-form (form brklst)
 496  (prog ()
 497   (mapcar #'(lambda (x)
 498               (cond
 499                ((listp x) (if (is-brk-in-form x brklst) (return t)))
 500                ((and (functionp x) (member x brklst)) (return t)))
 501             )
 502    form)
 503    (return nil)))
 504
 505 ;; Common Lisp - remove if using in COMMON LISP
 506 #+(and :xlisp :packages (not :common))
 507 (shadow 'functionp)
 508 #+(and :xlisp (not :common))
 509 (defun functionp (x)
 510     (if (typep x '(or closure subr symbol))
 511         t
 512         (and (consp x) (eq (car x) 'lambda))))
 513
 514 ;; Use this function  for common LISP
 515 #-:xlisp
 516 (defun get-key ()
 517   (let ((val nil))
 518   (while (or (null val) (eq val #\newline))
 519          (setq val (read-char))
 520    )
 521  (char-downcase val)))
 522
 523
 524 #+:xlisp
 525 (defun char-downcase-safe (char) ; LSG
 526    (when char (char-downcase char)) )
 527