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