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