src/mdebug.lisp

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