src/mdebug.lisp

   1 (in-package :maxima)
   2
   3 (declaim (optimize (safety 2) (space 3)))
   4
   5 (eval-when
   6     (:compile-toplevel :execute)
   7
   8     (defmacro f (op &rest args)
   9       `(the fixnum (,op ,@ (mapcar #'(lambda (x) `(the fixnum ,x)) args))))
  10
  11     (defmacro fb (op &rest args)
  12       `(,op ,@ (mapcar #'(lambda (x) `(the fixnum ,x)) args))))
  13
  14 (defstruct (line-info (:type list)) line file)
  15
  16 (defstruct (bkpt (:type list)) form file file-line function)
  17
  18 ;; *mlambda-call-stack*
  19 ;; #(NIL ($X) (1) $FF ($BIL $X) ($Y) (36) $JOE ($Y $BIL $X) ($JJX) (36)
  20 ;; to get to current values in ff need to unbind bindlist downto ($BIL $X)
  21 ;; to get to current values in joe need to unbind bindlist downto ($Y $BIL $X)
  22
  23 (defvar *current-frame* 0)
  24
  25 (defvar $mdebug_print_length 100 "Length of forms to print out in debugger")
  26
  27 (defvar *lisp-quiet-suppressed-prompt* "" "The prompt lisp-quiet has suppressed")
  28
  29 (defun frame-info (n)
  30   (declare (fixnum n))
  31   (let* ((ar *mlambda-call-stack*)
  32          (m (length ar))
  33          fname vals params backtr lineinfo bdlist)
  34     (declare (fixnum m))
  35     ;; just in case we do not have an even multiple
  36     (setq m (f - m (f mod m 5) (* n 5)))
  37     (if (<= m 0) (return-from frame-info nil))
  38     (setq fname (aref ar (f- m 1)))
  39     (setq vals (aref ar (f- m 2)))
  40     (setq params (aref ar (f- m 3)))
  41     (setq backtr (aref ar (f- m 4)))
  42     (setq bdlist (if (< m (fill-pointer ar)) (aref ar m) bindlist))
  43                                         ; (setq lineinfo (get-lineinfo backtr))
  44     (setq lineinfo (if ( < m (fill-pointer ar))
  45                        (get-lineinfo (aref ar (f+ m 1)))
  46                        (get-lineinfo *last-meval1-form*)))
  47     (values fname vals params backtr lineinfo bdlist)))
  48
  49 (defun print-one-frame (n print-frame-number &aux val (st *debug-io*))
  50   (multiple-value-bind
  51         (fname vals params backtr lineinfo bdlist)
  52       (frame-info n)
  53     (cond (fname
  54            (princ (if print-frame-number
  55                       ($sconcat "#" n ": " fname "(")
  56                       ($sconcat  fname "("))
  57                   st)
  58            (loop for v on params for w in vals
  59                   do (setq val ($sconcat w))
  60                   (if (> (length val) 100)
  61                       (setq val ($sconcat (subseq val 0 100) "...")))
  62                   (format st "~(~a~)=~a~a" ($sconcat (car v)) val
  63                           (if (cdr v) "," "")))
  64            (princ ")" st)
  65            (and lineinfo
  66                 (format st (intl:gettext " (~a line ~a)")
  67                         (short-name (cadr lineinfo)) (car lineinfo)))
  68            (terpri st)
  69            (values fname vals params backtr lineinfo bdlist))
  70           (t nil))))
  71
  72 ;; these are in the system package in gcl...
  73 #-gcl
  74 (progn
  75   (defun break-call (key args prop &aux fun)
  76     (setq fun (complete-prop key 'keyword prop))
  77     (setq key fun)
  78     (or fun (return-from break-call nil))
  79     (setq fun (get fun prop))
  80     (unless (symbolp fun)
  81       (let ((gen (gensym)))
  82         (setf (symbol-function gen) fun) (setf (get key prop) gen)
  83         (setq fun gen)))
  84     (cond (fun
  85            (setq args (cons fun args))
  86                                         ; jfa temporary hack
  87            (eval args)
  88            )
  89           (t (format *debug-io*
  90                      (intl:gettext "~&~S is an undefined break command.~%")
  91                      key))))
  92
  93   (defun complete-prop (sym package prop &optional return-list)
  94     (cond ((and (symbolp sym)(get sym prop)(equal (symbol-package sym)
  95                                                   (find-package package)))
  96            (return-from complete-prop sym)))
  97     (loop for vv being the symbols of package
  98           when (and (get vv prop)
  99                     (eql #+gcl (string-match sym vv)
 100                          #-gcl (search (symbol-name sym)
 101                                        (symbol-name vv))
 102                          0))
 103             collect vv into all
 104           finally
 105
 106              (cond (return-list (return-from complete-prop all))
 107                    ((> (length all) 1)
 108                     (format *debug-io*
 109                             (intl:gettext "~&Break command '~(~s~)' is ambiguous.~%")
 110                             sym)
 111                     (format *debug-io*
 112                             (intl:gettext "Perhaps you meant one of the following: ~(~{~s~^, ~}~).")
 113                             all)
 114                     (finish-output *debug-io*))
 115                    ((null all)
 116                     (format *debug-io*
 117                             (intl:gettext "~&Break command '~(~s~)' does not exist.")
 118                             sym)
 119                     (finish-output *debug-io*))
 120                    (t (return-from complete-prop
 121                         (car all)))))))
 122
 123 (defmfun $backtrace (&optional (n 0 n-p))
 124   (unless (typep n '(integer 0))
 125     (merror
 126       (intl:gettext "backtrace: number of frames must be a nonnegative integer; got ~M~%")
 127       n))
 128   (let ($display2d)
 129     (loop for i from 0
 130           for j from *current-frame*
 131           when (and n-p (= i n))
 132             return nil
 133           while (print-one-frame j t))))
 134
 135 ;; if this is NIL then nothing more is checked in eval
 136
 137 (defvar *break-points* nil)
 138 (defvar *break-point-vector* (make-array 10 :fill-pointer 0 :adjustable t))
 139
 140 (defun init-break-points ()
 141   (setf (fill-pointer *break-point-vector*) 0)
 142   (setf *break-points* *break-point-vector*))
 143
 144 (defvar *break-step* nil)
 145 (defvar *step-next* nil)
 146
 147 (defun step-into (&optional ignored)
 148   (declare (ignore ignored))
 149   (or *break-points* (init-break-points))
 150   (setq *break-step* 'break-step-into)
 151   :resume)
 152
 153 (defun step-next (&optional (n 1))
 154   (let ((fun (current-step-fun)))
 155     (setq *step-next* (cons n fun))
 156     (or *break-points* (init-break-points))
 157     (setq *break-step* 'break-step-next)
 158     :resume))
 159
 160 (defun maybe-break (form line-info fun env &aux pos)
 161   (declare (ignore env))
 162   (cond ((setq pos (position form line-info))
 163          (setq *break-step* nil)
 164          (or (> (length *break-points*) 0)
 165              (setf *break-points* nil))
 166          (break-dbm-loop (make-break-point fun line-info pos))
 167          t)))
 168
 169 ;; These following functions, when they are the value of *break-step*
 170 ;; are invoked by an inner hook in eval. They may choose to stop things.
 171 (defun break-step-into (form &optional env)
 172   (let ((fun (current-step-fun)))
 173     (let ((line-info (set-full-lineinfo fun)))
 174       (and line-info
 175            (maybe-break form line-info fun env)))))
 176
 177 (defun break-step-next (form &optional env)
 178   (let ((fun (current-step-fun)))
 179     (cond ((eql (cdr *step-next*) fun)
 180            (let ((line-info (set-full-lineinfo fun)))
 181              (maybe-break form line-info fun env))))))
 182
 183 (defvar *lineinfo-array-internal* nil)
 184
 185 ;; the lineinfo for a function will be a vector of forms
 186 ;; such that each one is the first form on a line.
 187 ;; we will walk thru the tree taking the first occurrence
 188 ;; for each line.
 189 (defun set-full-lineinfo (fname &aux te)
 190   (let ((body (get fname 'lineinfo)))
 191     (cond ((atom body) (return-from set-full-lineinfo body))
 192           (t (cond ((null *lineinfo-array-internal*)
 193                     (setq *lineinfo-array-internal*
 194                           (make-array 20 :fill-pointer 0 :adjustable t)))
 195                    (t (setf (fill-pointer *lineinfo-array-internal*) 0)))
 196              (cond ((setq te (get-lineinfo body))
 197                     (vector-push (car te) *lineinfo-array-internal*)
 198                     (walk-get-lineinfo body  *lineinfo-array-internal*)))
 199              (cond ((> (fill-pointer *lineinfo-array-internal*) 0)
 200                     (setf (get fname 'lineinfo)
 201                           (copy-seq *lineinfo-array-internal*)))
 202                    (t (setf (get fname 'lineinfo) nil)))))))
 203
 204 (defun walk-get-lineinfo (form ar &aux (i 0) tem)
 205   (declare (type (vector t) ar) (fixnum i))
 206   (cond ((atom form) nil)
 207         ((setq tem (get-lineinfo form))
 208          (setq i (f - (line-info-line tem) (aref ar 0) -1))
 209          (cond ((< i (fill-pointer ar))
 210                 (or (aref ar i)
 211                     (setf (aref ar i) form)))
 212                (t
 213                 (unless (< i (array-total-size ar))
 214                   (setq ar (adjust-array ar (+ i 20) :fill-pointer
 215                                          (fill-pointer ar))))
 216                 (loop for j from (fill-pointer ar) below i
 217                    do (setf (aref ar j) nil))
 218                 (setf (fill-pointer ar) (f + i 1))
 219                 (setf (aref ar i) form)))
 220          (loop for v in (cdr form)
 221             do (or (atom v)
 222                    (walk-get-lineinfo v ar))))))
 223
 224 (defun first-form-line (form line &aux tem)
 225   (cond ((atom form) nil)
 226         ((and (setq tem (get-lineinfo form)) (eql (car tem) line))
 227          form)
 228         (t (loop for v in (cdr form)
 229                   when (setq tem (first-form-line v line))
 230                   do (return-from first-form-line tem)))))
 231
 232 (defvar *last-dbm-command* nil)
 233
 234 ;; split string into a list of strings, split by any of a list of characters
 235 ;; in bag.  Returns a list.  They will have fill pointers..
 236 (defun split-string (string  bag &optional (start 0) &aux all pos v l)
 237   (declare (fixnum start) (type string string))
 238   (loop for i from start below (length string)
 239          do (setq pos (position (setq v (aref string i)) bag))
 240          (setq start (+ start 1))
 241          (cond ((null pos) (push v all))
 242                (t (if all (loop-finish))))
 243          finally
 244          (if all
 245              (return-from split-string
 246                (cons
 247                 (make-array (setq l (length all))
 248                             :fill-pointer l
 249                             :adjustable t
 250                             :initial-contents (nreverse all)
 251                             :element-type
 252                             ' #.(array-element-type "ab"))
 253                 (split-string string bag start))))))
 254
 255 (declaim (special *mread-prompt*))
 256
 257 (defvar *need-prompt* t)
 258
 259 ;; STREAM, EOF-ERROR-P and EOF-VALUE are analogous to the corresponding
 260 ;; arguments to Lisp's READ.  REPEAT-IF-NEWLINE, when T, says to repeat
 261 ;; the last break command (if available) when only a newline is read.
 262 (defun dbm-read (&optional (stream *standard-input*) (eof-error-p t)
 263                  (eof-value nil) repeat-if-newline  &aux tem  ch
 264                  (mprompt *mread-prompt*) (*mread-prompt* ""))
 265   (if (and *need-prompt* (> (length mprompt) 0))
 266     (progn
 267       (fresh-line *standard-output*)
 268       (princ mprompt *standard-output*)
 269       (finish-output *standard-output*)
 270       (setf *prompt-on-read-hang* nil))
 271     (progn
 272       (setf *prompt-on-read-hang* t)
 273       (setf *read-hang-prompt* mprompt)))
 274
 275   ;; Read a character to see what we should do.
 276   (tagbody
 277    top
 278      (setq ch (read-char stream eof-error-p eof-value))
 279      (cond ((or (eql ch #\newline) (eql ch #\return))
 280             (if (and repeat-if-newline *last-dbm-command*)
 281                 (return-from dbm-read *last-dbm-command*))
 282             (go top))
 283            ((eq ch eof-value)
 284             (return-from dbm-read eof-value)))
 285      ;; Put that character back, so we can reread the line correctly.
 286      (unread-char ch stream))
 287
 288   ;; Figure out what to do
 289   (cond ((eql #\: ch)
 290          ;; This is a Maxima debugger command (I think)
 291          (let* ((line (read-line stream eof-error-p eof-value))
 292                 fun)
 293            (multiple-value-bind
 294                  (keyword n)
 295                (read-from-string line)
 296              (setq fun (complete-prop keyword 'keyword 'break-command))
 297              (and (consp fun) (setq fun (car fun)))
 298              ;;(print (list 'line line))
 299              (setq *last-dbm-command*
 300                    (cond ((null fun) '(:_none))
 301                          ((get fun 'maxima-read)
 302                           (cons keyword (mapcar 'macsyma-read-string
 303                                                 (split-string line " " n))))
 304                          (t (setq tem
 305                                   ($sconcat "(" (string-right-trim  ";" line)
 306                                             ")"))
 307                             ;;(print (list 'tem tem))
 308                             (read  (make-string-input-stream tem)
 309                                    eof-error-p eof-value)))))))
 310         ((eql #\? ch)
 311          ;; Process "?" lines.  This is either a call to describe or a
 312          ;; quick temporary escape to Lisp to call some Lisp function.
 313
 314          ;; First, read and discard the #\? since we don't need it anymore.
 315          (read-char stream)
 316          (let ((next (peek-char nil stream nil)))
 317            (cond ((member next '(#\space #\tab #\!))
 318                   ;; Got "? <stuff>" or "?! <stuff>".
 319                   ;; Invoke exact search on <stuff>.
 320                   (let* ((line (string-trim
 321                                 '(#\space #\tab #\; #\$)
 322                                 (subseq
 323                                  (read-line stream eof-error-p eof-value) 1))))
 324                     `((displayinput) nil (($describe) ,line $exact))))
 325                  ((equal next #\?)
 326                   ;; Got "?? <stuff>". Invoke inexact search on <stuff>.
 327                   (let* ((line (string-trim
 328                                 '(#\space #\tab #\; #\$)
 329                                 (subseq
 330                                  (read-line stream eof-error-p eof-value) 1))))
 331                     `((displayinput) nil (($describe) ,line $inexact))))
 332                  (t
 333                   ;; Got "?<stuff>" This means a call to a Lisp
 334                   ;; function.  Pass this on to mread which can handle
 335                   ;; this.
 336                   ;;
 337                   ;; Note: There appears to be a bug in Allegro 6.2
 338                   ;; where concatenated streams don't wait for input
 339                   ;; on *standard-input*.
 340                   (mread (make-concatenated-stream
 341                           (make-string-input-stream "?") stream)
 342                          eof-value)))))
 343         (t
 344          (setq *last-dbm-command* nil)
 345          (let ((result (mread stream eof-value))
 346                (next-char (read-char-no-hang stream eof-error-p eof-value)))
 347            (cond
 348              ((or (eql next-char nil) (equal next-char '(nil)))
 349               (setf *need-prompt* t))
 350              ((member next-char '(#\newline #\return))
 351               (setf *need-prompt* t))
 352              (t
 353               (setf *need-prompt* nil)
 354               (unread-char next-char stream)))
 355            result))))
 356
 357 (defvar *break-level* nil)
 358 (defvar *break-env* nil)
 359 (defvar *top-eof* (cons nil nil))
 360 (defvar *quit-tag* 'macsyma-quit)
 361
 362 (defvar *quit-tags* nil)
 363
 364 (defun set-env (bkpt)
 365   (format *debug-io*
 366           (intl:gettext "(~a line ~a~@[, in function ~a~])")
 367           (short-name (bkpt-file bkpt))
 368           (bkpt-file-line bkpt)
 369           (bkpt-function bkpt))
 370   (format *debug-io* "~&\x1a\x1a~a:~a::~%" (bkpt-file bkpt)
 371           (bkpt-file-line bkpt)))
 372
 373 (defvar *diff-mspeclist* nil)
 374 (defvar *diff-bindlist* nil)
 375
 376 (defun break-dbm-loop (at)
 377   (let* ((*quit-tags* (cons (cons *break-level* *quit-tag*) *quit-tags*))
 378          (*break-level* (if (not at) *break-level* (cons t *break-level*)))
 379          (*quit-tag* (cons nil nil))
 380          (*break-env* *break-env*)
 381          (*mread-prompt* "")
 382          (*diff-bindlist* nil)
 383          (*diff-mspeclist* nil)
 384          val)
 385     (declare (special *mread-prompt*))
 386     (and (consp at) (set-env at))
 387     (cond ((null at)
 388            (break-frame 0 nil)))
 389     (catch 'step-continue
 390       (catch *quit-tag*
 391         (unwind-protect
 392              (do () (())
 393                (format-prompt *debug-io* "~&~a"
 394                               (format nil "~@[(~a:~a) ~]"
 395                                       (unless (stringp at) "dbm")
 396                                       (length *quit-tags*)))
 397                (finish-output *debug-io*)
 398                (setq val
 399                      (catch 'macsyma-quit
 400                        (let ((res (dbm-read *debug-io*  nil *top-eof* t)))
 401                          (declare (special *mread-prompt*))
 402                          (cond ((and (consp res) (keywordp (car res)))
 403                                 (let ((value (break-call (car res)
 404                                                          (cdr res)
 405                                                          'break-command)))
 406                                   (cond ((eq value :resume) (return)))))
 407                                ((eq res *top-eof*)
 408                                 (funcall (get :top 'break-command)))
 409                                (t
 410                                 (setq $__ (nth 2 res))
 411                                 (setq $% (meval* $__))
 412                                 (setq $_ $__)
 413                                 (displa $%)))
 414                          nil)))
 415                (and (eql val 'top)
 416                     (throw-macsyma-top)))
 417           (restore-bindings))))))
 418
 419 (defun break-quit (&optional (level 0)
 420                    &aux (current-level (length *break-level*)))
 421   (when (and (>= level 0) (< level current-level))
 422     (let ((x (nth (- current-level level 1) *quit-tags*)))
 423       (if (eq (cdr x) 'macsyma-quit)
 424           (throw 'macsyma-quit 'top)
 425           (throw (cdr x) (cdr x)))))
 426   (throw 'macsyma-quit 'top))
 427
 428 (defun break-current ()
 429   (if *break-level*
 430       (format *debug-io*
 431               (intl:gettext "Back to level ~:@(~S~).")
 432               (length *break-level*))
 433       (format *debug-io* (intl:gettext "~&Top level.")))
 434   (values))
 435
 436 (defun def-break (keyword fun doc)
 437   (setf (get keyword 'break-command) fun)
 438   (and doc (setf (get keyword 'break-doc) doc)))
 439
 440 (defun break-help (&optional key)
 441   (cond (key
 442          (if (keywordp key)
 443              (dolist (v (complete-prop key 'keyword 'break-doc t))
 444                (format t "~&~%~(~s~)   ~a" v (get v 'break-doc)))))
 445         (t
 446          ; Skip any undocumented break commands
 447          (loop for vv being the symbols of 'keyword
 448                 when (and (get vv 'break-command) (get vv 'break-doc))
 449                 collect (cons vv (get vv 'break-doc))
 450                 into all
 451                 finally (setq all (sort all 'alphalessp))
 452               (format t (intl:gettext "~
 453 Break commands start with ':'. Any unique substring may be used,~%~
 454 eg :r :re :res all work for :resume.~2%~
 455 Command      Description~%~
 456 -----------  --------------------------------------"))
 457                 (loop for vv in all
 458                    do (format t "~% ~(~12s~)" (car vv))
 459                      (format t (cdr vv)))
 460                 (finish-output)))))
 461
 462 (def-break :help 'break-help
 463   "Print help on a break command or with no arguments on
 464              all break commands")
 465
 466 ;; This is an undocumented break command which gets placed in
 467 ;; *LAST-DBM-COMMAND* when an invalid (nonexistent or ambiguous)
 468 ;; break command is read in.
 469 (def-break :_none #'(lambda()) nil)
 470
 471 (def-break :next  'step-next
 472   "Like :step, except that subroutine calls are stepped over")
 473
 474 (def-break :step  'step-into
 475   "Step program until it reaches a new source line")
 476
 477 ;;(def-break :location  'loc "" )
 478
 479 (def-break :quit 'break-quit
 480   "Quit this level")
 481
 482 (def-break :top  #'(lambda( &rest l)l (throw 'macsyma-quit 'top))
 483   "Throw to top level")
 484
 485 (defun *break-points* (form)
 486   (let ((pos(position form *break-points* :key 'car)))
 487     (format *debug-io* "Bkpt ~a: " pos)
 488     (break-dbm-loop  (aref *break-points* pos))))
 489
 490 ;; fun = function name eg '$|odeSeriesSolve| and
 491 ;; li  = offset from beginning of function.
 492 ;; Or fun = string (filename) and li = absolute position.
 493
 494 (defun break-function (fun &optional (li 0) absolute
 495                            &aux i tem info form fun-line)
 496   (unless *mdebug*
 497     (format t "~&Turning on debugging debugmode(true)~%")
 498     (setq *mdebug* t))
 499   (cond ((stringp fun)
 500          (let ((file fun)  start)
 501            (loop named joe for vv being the symbols of 'maxima with tem with linfo
 502                   when (and (typep (setq tem (set-full-lineinfo vv))
 503                                    'vector)
 504                             (setq linfo (get-lineinfo (aref tem 1)))
 505                             (equal file (cadr linfo))
 506                             (fb >= li (setq start (aref tem 0)))
 507                             (fb <= li (+ start (length (the vector tem)))))
 508                   do (setq fun vv li (f- li start -1))
 509                                 ; (print (list 'found fun fun li  (aref tem 0)))
 510                   (return-from joe nil)
 511                   finally
 512                   (format t "No line info for ~a " fun)
 513                   (return-from break-function nil)))))
 514   (setq fun ($concat fun))
 515                                         ; (print (list 'fun fun 'hi))
 516   (cond ((and (setq tem (second (mgetl  fun '(mexpr mmacro))))
 517               (setq info (get-lineinfo (setq form (third tem))))
 518               (eq (third info) 'src))
 519          (setq fun-line (fifth info))
 520          (or (fixnump fun-line) (setq fun-line (line-info-line info)))
 521                                         ; (print (list 'fun-line fun-line))
 522          (setq form (first-form-line
 523                      form
 524                      (setq i (+
 525                               (if absolute 0 fun-line) li))))
 526          (unless form
 527            (if (eql li 0)
 528                (return-from break-function (break-function fun 1)))
 529            (format t "~& No instructions recorded for this line ~a of ~a" li
 530                    ($sconcat fun))
 531            (return-from break-function nil))
 532          (let ((n (insert-break-point    (make-bkpt :form form
 533                                                     :file-line i
 534                                                     :file (line-info-file info)
 535                                                     :function fun))))
 536            (format t "~&Bkpt ~a for ~a (in ~a line ~a) ~%"
 537                    n ($sconcat fun) (line-info-file info) i)
 538            n))
 539         (t (format t "No line info for ~a " fun))))
 540
 541 ;; note  need to make the redefine function, fixup the break point list..
 542
 543 (defun make-break-point (fun ar i)
 544   (declare (fixnum i) (type (vector t) ar))
 545   (let* ((tem (aref ar i))
 546          (linfo (get-lineinfo tem)))
 547     (and linfo (list tem (cadr linfo) (car linfo) fun))))
 548
 549 (defun dbm-up (n &aux (cur *current-frame*) (m (length *mlambda-call-stack*)))
 550   (declare (fixnum n m cur))
 551   (setq m (quotient m 5))
 552   (setq n (f + n cur))
 553   (cond ((fb > n m)
 554          (setq n m))
 555         ((fb < n 0)
 556          (setq n 0)))
 557   (break-frame  n nil))
 558
 559 (defun insert-break-point (bpt &aux at)
 560   (or *break-points* (init-break-points))
 561   (setq at (or (position nil *break-points*)
 562                (prog1 (length *break-points*)
 563                  (vector-push-extend  nil *break-points*))))
 564   (let ((fun (bkpt-function bpt)))
 565     (push at (get fun 'break-points)))
 566   (setf (aref *break-points* at) bpt)
 567   at)
 568
 569 (defun short-name (name)
 570   (let ((pos (position #\/ name :from-end t)))
 571     (if pos (subseq name (f + 1 pos)) name)))
 572
 573 (defun show-break-point (n &aux disabled)
 574   (let ((bpt (aref *break-points* n)))
 575     (when bpt
 576       (when (eq (car bpt) nil)
 577         (setq disabled t)
 578         (setq bpt (cdr bpt)))
 579       (format t "Bkpt ~a: (~a line ~a)~@[ (disabled)~]"
 580               n (short-name (second bpt))
 581               (third bpt) disabled)
 582       (let ((fun (fourth bpt)))
 583         (format t " (line ~a of ~a)" (relative-line fun (nth 2 bpt))
 584                 fun)))))
 585
 586 (defun relative-line (fun l)
 587   (let ((info (set-full-lineinfo fun)))
 588     (if info (f - l (aref info 0))
 589         0)))
 590
 591 (defun iterate-over-bkpts (l action)
 592   (dotimes (i (length *break-points*))
 593     (if (or (member i l)
 594             (null l))
 595         (let ((tem (aref *break-points* i)))
 596           (setf (aref *break-points* i)
 597                 (case action
 598                   (:delete
 599                    (unless (car tem)
 600                      (pop tem))     ; disabled or already deleted bkpt
 601                    (if tem
 602                        (setf (get (bkpt-function tem) 'break-points)
 603                              (delete i
 604                                      (get (bkpt-function tem) 'break-points))))
 605                    nil)
 606                   (:enable
 607                    (if (eq (car tem) nil) (cdr tem) tem))
 608                   (:disable
 609                    (if (and tem (not (eq (car tem) nil)))
 610                        (cons nil tem)
 611                        tem))
 612                   (:show
 613                    (when tem (show-break-point i)
 614                          (terpri)
 615                          (finish-output))
 616                    tem)))))))
 617
 618 ;; get the most recent function on the stack with step info.
 619
 620 (defun current-step-fun ( &aux fun)
 621   (loop for i below 100000
 622          while (setq fun (frame-info i))
 623          do (cond ((and (symbolp fun) (set-full-lineinfo fun))
 624                    (return-from current-step-fun fun)))))
 625
 626 (def-break :bt '$backtrace "Print a backtrace of the stack frames")
 627
 628 (def-break :info #'(lambda (&optional type)
 629                      (case type
 630                        (:bkpt  (iterate-over-bkpts nil :show)(values))
 631                        (otherwise
 632                         (format *debug-io*
 633                                 "usage: :info :bkpt -- show breakpoints"))))
 634   "Print information about item")
 635
 636 (defmacro lisp-quiet (&rest l-lisp-quiet)
 637   (if (not (string= *mread-prompt* ""))
 638       (setq *lisp-quiet-suppressed-prompt* *mread-prompt*))
 639   (setq *mread-prompt* "")
 640   (eval (cons 'progn l-lisp-quiet))
 641   nil)
 642
 643 (def-break :lisp-quiet 'lisp-quiet
 644   "Evaluate the lisp form without printing a prompt")
 645
 646 (def-break :lisp 'lisp-eval
 647   "Evaluate the lisp form following on the line")
 648
 649 (defmacro lisp-eval (&rest l-lisp-eval)
 650   (if (string= *mread-prompt* "")
 651       (setq *mread-prompt* *lisp-quiet-suppressed-prompt*))
 652
 653   (dolist (v-lisp-eval (multiple-value-list (eval (cons 'progn l-lisp-eval))))
 654     (fresh-line *standard-output*)
 655     (princ v-lisp-eval)))
 656
 657 (def-break :delete #'(lambda (&rest l) (iterate-over-bkpts l :delete) (values))
 658   "Delete all breakpoints, or if arguments are supplied delete the
 659              specified breakpoints")
 660
 661 (def-break :frame 'break-frame
 662   "With an argument print the selected stack frame.
 663              Otherwise the current frame.")
 664
 665 (def-break :resume  #'(lambda () :resume)
 666   "Continue the computation.")
 667
 668 (def-break :continue #'(lambda () :resume)
 669   "Continue the computation.")
 670
 671 (def-break :disable
 672     #'(lambda (&rest l) (iterate-over-bkpts l :disable)(values))
 673   "Disable the specified breakpoints, or all if none are specified")
 674
 675 (def-break :enable #'(lambda (&rest l) (iterate-over-bkpts l :enable)(values))
 676   "Enable the specified breakpoints, or all if none are specified")
 677
 678 (def-break :break 'do-break
 679   "Set a breakpoint in the specified FUNCTION at the
 680              specified LINE offset from the beginning of the function.
 681              If FUNCTION is given as a string, then it is presumed to be
 682              a FILE and LINE is the offset from the beginning of the file.")
 683
 684 ;; force the rest of the line to be broken at spaces,
 685 ;; and each item read as a maxima atom.
 686 (setf (get :break 'maxima-read) t)
 687
 688 (defmacro do-break (&optional name &rest l)
 689   (declare (special *last-dbl-break*))
 690   (cond ((null name)
 691          (if *last-dbl-break*
 692              (let ((fun  (nth 3 *last-dbl-break*)))
 693                (break-function fun (nth 2 *last-dbl-break*) t))))
 694         (t (eval `(break-function ',name ,@l)))))
 695
 696 ;; this just sets up a counter for each stream.. we want
 697 ;; it to start at one.
 698
 699 (defun get-lineinfo (form)
 700   (cond ((consp form)
 701          (if (consp (cadar form))
 702              (cadar form)
 703              (if (consp (caddar form))
 704                  (caddar form)
 705                  nil)))
 706         (t nil)))
 707
 708 ;; restore-bindings from an original binding list.
 709 (defun restore-bindings ()
 710   (mbind *diff-bindlist* *diff-mspeclist* nil)
 711   (setf *diff-bindlist* nil *diff-mspeclist* nil))
 712
 713 (defun remove-bindings (the-bindlist)
 714   (loop for v on bindlist with var
 715          while v
 716          until (eq v the-bindlist)
 717          do
 718          (setq var (car v))
 719          (push var *diff-bindlist*)
 720          (push (symbol-value var) *diff-mspeclist*)
 721          (cond ((eq (car mspeclist) munbound)
 722                 (makunbound var)
 723                 (setq $values (delete var $values :count 1 :test #'eq)))
 724                (t (let ((munbindp t)) (mset var (car mspeclist)))))
 725          (setq mspeclist (cdr mspeclist) bindlist (cdr bindlist))))
 726
 727 (defun break-frame (&optional (n 0) (print-frame-number t))
 728   (restore-bindings)
 729   (multiple-value-bind (fname vals params backtr lineinfo bdlist)
 730       (print-one-frame n print-frame-number)
 731     backtr params vals fname
 732     (remove-bindings bdlist)
 733     (when lineinfo
 734       (fresh-line *debug-io*)
 735       (format *debug-io* "\x1a\x1a~a:~a::~%" (cadr lineinfo) (+ 0 (car lineinfo))))
 736     (values)))