src/code/debug.lisp

   1 ;;;; the debugger
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; This software is derived from the CMU CL system, which was
   7 ;;;; written at Carnegie Mellon University and released into the
   8 ;;;; public domain. The software is in the public domain and is
   9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  10 ;;;; files for more information.
  11
  12 (in-package "SB!DEBUG")
  13 \f
  14 ;;;; variables and constants
  15
  16 ;;; things to consider when tweaking these values:
  17 ;;;   * We're afraid to just default them to NIL and NIL, in case the
  18 ;;;     user inadvertently causes a hairy data structure to be printed
  19 ;;;     when he inadvertently enters the debugger.
  20 ;;;   * We don't want to truncate output too much. These days anyone
  21 ;;;     can easily run their Lisp in a windowing system or under Emacs,
  22 ;;;     so it's not the end of the world even if the worst case is a
  23 ;;;     few thousand lines of output.
  24 ;;;   * As condition :REPORT methods are converted to use the pretty
  25 ;;;     printer, they acquire *PRINT-LEVEL* constraints, so e.g. under
  26 ;;;     sbcl-0.7.1.28's old value of *DEBUG-PRINT-LEVEL*=3, an
  27 ;;;     ARG-COUNT-ERROR printed as
  28 ;;;       error while parsing arguments to DESTRUCTURING-BIND:
  29 ;;;         invalid number of elements in
  30 ;;;           #
  31 ;;;         to satisfy lambda list
  32 ;;;           #:
  33 ;;;         exactly 2 expected, but 5 found
  34 (defvar *debug-print-variable-alist* nil
  35   #!+sb-doc
  36   "an association list describing new bindings for special variables
  37 to be used within the debugger. Eg.
  38
  39  ((*PRINT-LENGTH* . 10) (*PRINT-LEVEL* . 6) (*PRINT-PRETTY* . NIL))
  40
  41 The variables in the CAR positions are bound to the values in the CDR
  42 during the execution of some debug commands. When evaluating arbitrary
  43 expressions in the debugger, the normal values of the printer control
  44 variables are in effect.
  45
  46 Initially empty, *DEBUG-PRINT-VARIABLE-ALIST* is typically used to
  47 provide bindings for printer control variables.")
  48
  49 (defvar *debug-readtable*
  50   ;; KLUDGE: This can't be initialized in a cold toplevel form,
  51   ;; because the *STANDARD-READTABLE* isn't initialized until after
  52   ;; cold toplevel forms have run. So instead we initialize it
  53   ;; immediately after *STANDARD-READTABLE*. -- WHN 20000205
  54   nil
  55   #!+sb-doc
  56   "*READTABLE* for the debugger")
  57
  58 (defvar *in-the-debugger* nil
  59   #!+sb-doc
  60   "This is T while in the debugger.")
  61
  62 ;;; nestedness inside debugger command loops
  63 (defvar *debug-command-level* 0)
  64
  65 ;;; If this is bound before the debugger is invoked, it is used as the
  66 ;;; stack top by the debugger.
  67 (defvar *stack-top-hint* nil)
  68
  69 (defvar *stack-top* nil)
  70 (defvar *real-stack-top* nil)
  71
  72 (defvar *current-frame* nil)
  73
  74 ;;; Beginner-oriented help messages are important because you end up
  75 ;;; in the debugger whenever something bad happens, or if you try to
  76 ;;; get out of the system with Ctrl-C or (EXIT) or EXIT or whatever.
  77 ;;; But after memorizing them the wasted screen space gets annoying..
  78 (defvar *debug-beginner-help-p* t
  79   "Should the debugger display beginner-oriented help messages?")
  80
  81 (defun debug-prompt (stream)
  82   (sb!thread::get-foreground)
  83   (format stream
  84           "~%~W~:[~;[~W~]] "
  85           (sb!di:frame-number *current-frame*)
  86           (> *debug-command-level* 1)
  87           *debug-command-level*))
  88
  89 (defparameter *debug-help-string*
  90 "The debug prompt is square brackets, with number(s) indicating the current
  91   control stack level and, if you've entered the debugger recursively, how
  92   deeply recursed you are.
  93 Any command -- including the name of a restart -- may be uniquely abbreviated.
  94 The debugger rebinds various special variables for controlling i/o, sometimes
  95   to defaults (much like WITH-STANDARD-IO-SYNTAX does) and sometimes to
  96   its own special values, based on SB-EXT:*DEBUG-PRINT-VARIABLE-ALIST*.
  97 Debug commands do not affect *, //, and similar variables, but evaluation in
  98   the debug loop does affect these variables.
  99 SB-DEBUG:*FLUSH-DEBUG-ERRORS* controls whether errors at the debug prompt
 100   drop you deeper into the debugger. The default NIL allows recursive entry
 101   to debugger.
 102
 103 Getting in and out of the debugger:
 104   TOPLEVEL, TOP  exits debugger and returns to top level REPL
 105   RESTART        invokes restart numbered as shown (prompt if not given).
 106   ERROR          prints the error condition and restart cases.
 107
 108   The number of any restart, or its name, or a unique abbreviation for its
 109    name, is a valid command, and is the same as using RESTART to invoke
 110    that restart.
 111
 112 Changing frames:
 113   UP     up frame         DOWN     down frame
 114   BOTTOM bottom frame     FRAME n  frame n (n=0 for top frame)
 115
 116 Inspecting frames:
 117   BACKTRACE [n]  shows n frames going down the stack.
 118   LIST-LOCALS, L lists locals in current frame.
 119   PRINT, P       displays function call for current frame.
 120   SOURCE [n]     displays frame's source form with n levels of enclosing forms.
 121
 122 Stepping:
 123   STEP  Selects the CONTINUE restart if one exists and starts
 124         single-stepping. Single stepping affects only code compiled with
 125         under high DEBUG optimization quality. See User Manual for details.
 126
 127 Function and macro commands:
 128  (SB-DEBUG:ARG n)
 129     Return the n'th argument in the current frame.
 130  (SB-DEBUG:VAR string-or-symbol [id])
 131     Returns the value of the specified variable in the current frame.
 132
 133 Other commands:
 134   RETURN expr
 135     Return the values resulting from evaluation of expr from the
 136     current frame, if this frame was compiled with a sufficiently high
 137     DEBUG optimization quality.
 138
 139   SLURP
 140     Discard all pending input on *STANDARD-INPUT*. (This can be
 141     useful when the debugger was invoked to handle an error in
 142     deeply nested input syntax, and now the reader is confused.)")
 143 \f
 144
 145 ;;; If LOC is an unknown location, then try to find the block start
 146 ;;; location. Used by source printing to some information instead of
 147 ;;; none for the user.
 148 (defun maybe-block-start-location (loc)
 149   (if (sb!di:code-location-unknown-p loc)
 150       (let* ((block (sb!di:code-location-debug-block loc))
 151              (start (sb!di:do-debug-block-locations (loc block)
 152                       (return loc))))
 153         (cond ((and (not (sb!di:debug-block-elsewhere-p block))
 154                     start)
 155                (format *debug-io* "~%unknown location: using block start~%")
 156                start)
 157               (t
 158                loc)))
 159       loc))
 160 \f
 161 ;;;; BACKTRACE
 162
 163 (defun backtrace (&optional (count most-positive-fixnum) (stream *debug-io*))
 164   #!+sb-doc
 165   "Show a listing of the call stack going down from the current frame.
 166 In the debugger, the current frame is indicated by the prompt. COUNT
 167 is how many frames to show."
 168   (fresh-line stream)
 169   (do ((frame (if *in-the-debugger* *current-frame* (sb!di:top-frame))
 170               (sb!di:frame-down frame))
 171        (count count (1- count)))
 172       ((or (null frame) (zerop count)))
 173     (print-frame-call frame stream :number t))
 174   (fresh-line stream)
 175   (values))
 176
 177 (defun backtrace-as-list (&optional (count most-positive-fixnum))
 178   #!+sb-doc "Return a list representing the current BACKTRACE."
 179   (do ((reversed-result nil)
 180        (frame (if *in-the-debugger* *current-frame* (sb!di:top-frame))
 181               (sb!di:frame-down frame))
 182        (count count (1- count)))
 183       ((or (null frame) (zerop count))
 184        (nreverse reversed-result))
 185     (push (frame-call-as-list frame) reversed-result)))
 186
 187 (defun frame-call-as-list (frame)
 188   (multiple-value-bind (name args) (frame-call frame)
 189     (cons name args)))
 190 \f
 191 ;;;; frame printing
 192
 193 (eval-when (:compile-toplevel :execute)
 194
 195 ;;; This is a convenient way to express what to do for each type of
 196 ;;; lambda-list element.
 197 (sb!xc:defmacro lambda-list-element-dispatch (element
 198                                               &key
 199                                               required
 200                                               optional
 201                                               rest
 202                                               keyword
 203                                               deleted)
 204   `(etypecase ,element
 205      (sb!di:debug-var
 206       ,@required)
 207      (cons
 208       (ecase (car ,element)
 209         (:optional ,@optional)
 210         (:rest ,@rest)
 211         (:keyword ,@keyword)))
 212      (symbol
 213       (aver (eq ,element :deleted))
 214       ,@deleted)))
 215
 216 (sb!xc:defmacro lambda-var-dispatch (variable location deleted valid other)
 217   (let ((var (gensym)))
 218     `(let ((,var ,variable))
 219        (cond ((eq ,var :deleted) ,deleted)
 220              ((eq (sb!di:debug-var-validity ,var ,location) :valid)
 221               ,valid)
 222              (t ,other)))))
 223
 224 ) ; EVAL-WHEN
 225
 226 ;;; Extract the function argument values for a debug frame.
 227 (defun frame-args-as-list (frame)
 228   (let ((debug-fun (sb!di:frame-debug-fun frame))
 229         (loc (sb!di:frame-code-location frame))
 230         (reversed-result nil))
 231     (handler-case
 232         (progn
 233           (dolist (ele (sb!di:debug-fun-lambda-list debug-fun))
 234             (lambda-list-element-dispatch ele
 235              :required ((push (frame-call-arg ele loc frame) reversed-result))
 236              :optional ((push (frame-call-arg (second ele) loc frame)
 237                               reversed-result))
 238              :keyword ((push (second ele) reversed-result)
 239                        (push (frame-call-arg (third ele) loc frame)
 240                              reversed-result))
 241              :deleted ((push (frame-call-arg ele loc frame) reversed-result))
 242              :rest ((lambda-var-dispatch (second ele) loc
 243                      nil
 244                      (progn
 245                        (setf reversed-result
 246                              (append (reverse (sb!di:debug-var-value
 247                                                (second ele) frame))
 248                                      reversed-result))
 249                        (return))
 250                      (push (make-unprintable-object
 251                             "unavailable &REST argument")
 252                      reversed-result)))))
 253           ;; As long as we do an ordinary return (as opposed to SIGNALing
 254           ;; a CONDITION) from the DOLIST above:
 255           (nreverse reversed-result))
 256       (sb!di:lambda-list-unavailable
 257        ()
 258        (make-unprintable-object "unavailable lambda list")))))
 259 (legal-fun-name-p '(lambda ()))
 260 (defvar *show-entry-point-details* nil)
 261
 262 (defun clean-xep (name args)
 263   (values (second name)
 264           (if (consp args)
 265               (let ((count (first args))
 266                     (real-args (rest args)))
 267                 (if (fixnump count)
 268                     (subseq real-args 0
 269                             (min count (length real-args)))
 270                     real-args))
 271               args)))
 272
 273 (defun clean-&more-processor (name args)
 274   (values (second name)
 275           (if (consp args)
 276               (let* ((more (last args 2))
 277                      (context (first more))
 278                      (count (second more)))
 279                 (append
 280                  (butlast args 2)
 281                  (if (fixnump count)
 282                      (multiple-value-list
 283                       (sb!c:%more-arg-values context 0 count))
 284                      (list
 285                       (make-unprintable-object "more unavailable arguments")))))
 286               args)))
 287
 288 (defun frame-call (frame)
 289   (labels ((clean-name-and-args (name args)
 290              (if (and (consp name) (not *show-entry-point-details*))
 291                  ;; FIXME: do we need to deal with
 292                  ;; HAIRY-FUNCTION-ENTRY here? I can't make it or
 293                  ;; &AUX-BINDINGS appear in backtraces, so they are
 294                  ;; left alone for now. --NS 2005-02-28
 295                  (case (first name)
 296                    ((sb!c::xep sb!c::tl-xep)
 297                     (clean-xep name args))
 298                    ((sb!c::&more-processor)
 299                     (clean-&more-processor name args))
 300                    ((sb!c::hairy-arg-processor
 301                      sb!c::varargs-entry sb!c::&optional-processor)
 302                     (clean-name-and-args (second name) args))
 303                    (t
 304                     (values name args)))
 305                  (values name args))))
 306     (let ((debug-fun (sb!di:frame-debug-fun frame)))
 307       (multiple-value-bind (name args)
 308           (clean-name-and-args (sb!di:debug-fun-name debug-fun)
 309                                 (frame-args-as-list frame))
 310         (values name args
 311                 (when *show-entry-point-details*
 312                   (sb!di:debug-fun-kind debug-fun)))))))
 313
 314 (defun ensure-printable-object (object)
 315   (handler-case
 316       (with-open-stream (out (make-broadcast-stream))
 317         (prin1 object out)
 318         object)
 319     (error (cond)
 320       (declare (ignore cond))
 321       (make-unprintable-object "error printing object"))))
 322
 323 (defun frame-call-arg (var location frame)
 324   (lambda-var-dispatch var location
 325     (make-unprintable-object "unused argument")
 326     (sb!di:debug-var-value var frame)
 327     (make-unprintable-object "unavailable argument")))
 328
 329 ;;; Prints a representation of the function call causing FRAME to
 330 ;;; exist. VERBOSITY indicates the level of information to output;
 331 ;;; zero indicates just printing the DEBUG-FUN's name, and one
 332 ;;; indicates displaying call-like, one-liner format with argument
 333 ;;; values.
 334 (defun print-frame-call (frame stream &key (verbosity 1) (number nil))
 335   (when number
 336     (format stream "~&~S: " (sb!di:frame-number frame)))
 337   (if (zerop verbosity)
 338       (let ((*print-readably* nil))
 339         (prin1 frame stream))
 340       (multiple-value-bind (name args kind) (frame-call frame)
 341         (pprint-logical-block (stream nil :prefix "(" :suffix ")")
 342           ;; Since we go to some trouble to make nice informative function
 343           ;; names like (PRINT-OBJECT :AROUND (CLOWN T)), let's make sure
 344           ;; that they aren't truncated by *PRINT-LENGTH* and *PRINT-LEVEL*.
 345           ;; For the function arguments, we can just print normally.
 346           (let ((*print-length* nil)
 347                 (*print-level* nil))
 348             (prin1 (ensure-printable-object name) stream))
 349           ;; If we hit a &REST arg, then print as many of the values as
 350           ;; possible, punting the loop over lambda-list variables since any
 351           ;; other arguments will be in the &REST arg's list of values.
 352           (let ((args (ensure-printable-object args)))
 353             (if (listp args)
 354                 (format stream "~{ ~_~S~}" args)
 355                 (format stream " ~S" args))))
 356         (when kind
 357           (format stream "[~S]" kind))))
 358   (when (>= verbosity 2)
 359     (let ((loc (sb!di:frame-code-location frame)))
 360       (handler-case
 361           (progn
 362             ;; FIXME: Is this call really necessary here? If it is,
 363             ;; then the reason for it should be unobscured.
 364             (sb!di:code-location-debug-block loc)
 365             (format stream "~%source: ")
 366             (prin1 (code-location-source-form loc 0) stream))
 367         (sb!di:debug-condition (ignore)
 368           ignore)
 369         (error (c)
 370           (format stream "~&error finding source: ~A" c))))))
 371 \f
 372 ;;;; INVOKE-DEBUGGER
 373
 374 (defvar *debugger-hook* nil
 375   #!+sb-doc
 376   "This is either NIL or a function of two arguments, a condition and the value
 377    of *DEBUGGER-HOOK*. This function can either handle the condition or return
 378    which causes the standard debugger to execute. The system passes the value
 379    of this variable to the function because it binds *DEBUGGER-HOOK* to NIL
 380    around the invocation.")
 381
 382 (defvar *invoke-debugger-hook* nil
 383   #!+sb-doc
 384   "This is either NIL or a designator for a function of two arguments,
 385    to be run when the debugger is about to be entered.  The function is
 386    run with *INVOKE-DEBUGGER-HOOK* bound to NIL to minimize recursive
 387    errors, and receives as arguments the condition that triggered
 388    debugger entry and the previous value of *INVOKE-DEBUGGER-HOOK*
 389
 390    This mechanism is an SBCL extension similar to the standard *DEBUGGER-HOOK*.
 391    In contrast to *DEBUGGER-HOOK*, it is observed by INVOKE-DEBUGGER even when
 392    called by BREAK.")
 393
 394 ;;; These are bound on each invocation of INVOKE-DEBUGGER.
 395 (defvar *debug-restarts*)
 396 (defvar *debug-condition*)
 397 (defvar *nested-debug-condition*)
 398
 399 ;;; Oh, what a tangled web we weave when we preserve backwards
 400 ;;; compatibility with 1968-style use of global variables to control
 401 ;;; per-stream i/o properties; there's really no way to get this
 402 ;;; quite right, but we do what we can.
 403 (defun funcall-with-debug-io-syntax (fun &rest rest)
 404   (declare (type function fun))
 405   ;; Try to force the other special variables into a useful state.
 406   (let (;; Protect from WITH-STANDARD-IO-SYNTAX some variables where
 407         ;; any default we might use is less useful than just reusing
 408         ;; the global values.
 409         (original-package *package*)
 410         (original-print-pretty *print-pretty*))
 411     (with-standard-io-syntax
 412       (with-sane-io-syntax
 413           (let (;; We want the printer and reader to be in a useful
 414                 ;; state, regardless of where the debugger was invoked
 415                 ;; in the program. WITH-STANDARD-IO-SYNTAX and
 416                 ;; WITH-SANE-IO-SYNTAX do much of what we want, but
 417                 ;;   * It doesn't affect our internal special variables
 418                 ;;     like *CURRENT-LEVEL-IN-PRINT*.
 419                 ;;   * It isn't customizable.
 420                 ;;   * It sets *PACKAGE* to COMMON-LISP-USER, which is not
 421                 ;;     helpful behavior for a debugger.
 422                 ;;   * There's no particularly good debugger default for
 423                 ;;     *PRINT-PRETTY*, since T is usually what you want
 424                 ;;     -- except absolutely not what you want when you're
 425                 ;;     debugging failures in PRINT-OBJECT logic.
 426                 ;; We try to address all these issues with explicit
 427                 ;; rebindings here.
 428                 (sb!kernel:*current-level-in-print* 0)
 429                 (*package* original-package)
 430                 (*print-pretty* original-print-pretty)
 431                 ;; Clear the circularity machinery to try to to reduce the
 432                 ;; pain from sharing the circularity table across all
 433                 ;; streams; if these are not rebound here, then setting
 434                 ;; *PRINT-CIRCLE* within the debugger when debugging in a
 435                 ;; state where something circular was being printed (e.g.,
 436                 ;; because the debugger was entered on an error in a
 437                 ;; PRINT-OBJECT method) makes a hopeless mess. Binding them
 438                 ;; here does seem somewhat ugly because it makes it more
 439                 ;; difficult to debug the printing-of-circularities code
 440                 ;; itself; however, as far as I (WHN, 2004-05-29) can see,
 441                 ;; that's almost entirely academic as long as there's one
 442                 ;; shared *C-H-T* for all streams (i.e., it's already
 443                 ;; unreasonably difficult to debug print-circle machinery
 444                 ;; given the buggy crosstalk between the debugger streams
 445                 ;; and the stream you're trying to watch), and any fix for
 446                 ;; that buggy arrangement will likely let this hack go away
 447                 ;; naturally.
 448                 (sb!impl::*circularity-hash-table* . nil)
 449                 (sb!impl::*circularity-counter* . nil)
 450                 (*readtable* *debug-readtable*))
 451             (progv
 452                 ;; (Why NREVERSE? PROGV makes the later entries have
 453                 ;; precedence over the earlier entries.
 454                 ;; *DEBUG-PRINT-VARIABLE-ALIST* is called an alist, so it's
 455                 ;; expected that its earlier entries have precedence. And
 456                 ;; the earlier-has-precedence behavior is mostly more
 457                 ;; convenient, so that programmers can use PUSH or LIST* to
 458                 ;; customize *DEBUG-PRINT-VARIABLE-ALIST*.)
 459                 (nreverse (mapcar #'car *debug-print-variable-alist*))
 460                 (nreverse (mapcar #'cdr *debug-print-variable-alist*))
 461               (apply fun rest)))))))
 462
 463 (defun invoke-debugger (condition)
 464   #!+sb-doc
 465   "Enter the debugger."
 466
 467   ;; call *INVOKE-DEBUGGER-HOOK* first, so that *DEBUGGER-HOOK* is not
 468   ;; called when the debugger is disabled
 469   (let ((old-hook *invoke-debugger-hook*))
 470     (when old-hook
 471       (let ((*invoke-debugger-hook* nil))
 472         (funcall old-hook condition old-hook))))
 473   (let ((old-hook *debugger-hook*))
 474     (when old-hook
 475       (let ((*debugger-hook* nil))
 476         (funcall old-hook condition old-hook))))
 477
 478   ;; We definitely want *PACKAGE* to be of valid type.
 479   ;;
 480   ;; Elsewhere in the system, we use the SANE-PACKAGE function for
 481   ;; this, but here causing an exception just as we're trying to handle
 482   ;; an exception would be confusing, so instead we use a special hack.
 483   (unless (and (packagep *package*)
 484                (package-name *package*))
 485     (setf *package* (find-package :cl-user))
 486     (format *error-output*
 487             "The value of ~S was not an undeleted PACKAGE. It has been
 488 reset to ~S."
 489             '*package* *package*))
 490
 491   ;; Before we start our own output, finish any pending output.
 492   ;; Otherwise, if the user tried to track the progress of his program
 493   ;; using PRINT statements, he'd tend to lose the last line of output
 494   ;; or so, which'd be confusing.
 495   (flush-standard-output-streams)
 496
 497   (funcall-with-debug-io-syntax #'%invoke-debugger condition))
 498
 499 (defun %print-debugger-invocation-reason (condition stream)
 500   (format stream "~2&")
 501   ;; Note: Ordinarily it's only a matter of taste whether to use
 502   ;; FORMAT "~<...~:>" or to use PPRINT-LOGICAL-BLOCK directly, but
 503   ;; until bug 403 is fixed, PPRINT-LOGICAL-BLOCK (STREAM NIL) is
 504   ;; definitely preferred, because the FORMAT alternative was acting odd.
 505   (pprint-logical-block (stream nil)
 506     (format stream
 507             "debugger invoked on a ~S~@[ in thread ~A~]: ~2I~_~A"
 508             (type-of condition)
 509             #!+sb-thread sb!thread:*current-thread*
 510             #!-sb-thread nil
 511             condition))
 512   (terpri stream))
 513
 514 (defun %invoke-debugger (condition)
 515
 516   (let ((*debug-condition* condition)
 517         (*debug-restarts* (compute-restarts condition))
 518         (*nested-debug-condition* nil))
 519     (handler-case
 520         ;; (The initial output here goes to *ERROR-OUTPUT*, because the
 521         ;; initial output is not interactive, just an error message, and
 522         ;; when people redirect *ERROR-OUTPUT*, they could reasonably
 523         ;; expect to see error messages logged there, regardless of what
 524         ;; the debugger does afterwards.)
 525         (%print-debugger-invocation-reason condition *error-output*)
 526       (error (condition)
 527         (setf *nested-debug-condition* condition)
 528         (let ((ndc-type (type-of *nested-debug-condition*)))
 529           (format *error-output*
 530                   "~&~@<(A ~S was caught when trying to print ~S when ~
 531                       entering the debugger. Printing was aborted and the ~
 532                       ~S was stored in ~S.)~@:>~%"
 533                   ndc-type
 534                   '*debug-condition*
 535                   ndc-type
 536                   '*nested-debug-condition*))
 537         (when (typep *nested-debug-condition* 'cell-error)
 538           ;; what we really want to know when it's e.g. an UNBOUND-VARIABLE:
 539           (format *error-output*
 540                   "~&(CELL-ERROR-NAME ~S) = ~S~%"
 541                   '*nested-debug-condition*
 542                   (cell-error-name *nested-debug-condition*)))))
 543
 544     (let ((background-p (sb!thread::debugger-wait-until-foreground-thread
 545                          *debug-io*)))
 546
 547       ;; After the initial error/condition/whatever announcement to
 548       ;; *ERROR-OUTPUT*, we become interactive, and should talk on
 549       ;; *DEBUG-IO* from now on. (KLUDGE: This is a normative
 550       ;; statement, not a description of reality.:-| There's a lot of
 551       ;; older debugger code which was written to do i/o on whatever
 552       ;; stream was in fashion at the time, and not all of it has
 553       ;; been converted to behave this way. -- WHN 2000-11-16)
 554
 555       (unwind-protect
 556            (let (;; We used to bind *STANDARD-OUTPUT* to *DEBUG-IO*
 557                  ;; here as well, but that is probably bogus since it
 558                  ;; removes the users ability to do output to a redirected
 559                  ;; *S-O*. Now we just rebind it so that users can temporarily
 560                  ;; frob it. FIXME: This and other "what gets bound when"
 561                  ;; behaviour should be documented in the manual.
 562                  (*standard-output* *standard-output*)
 563                  ;; This seems reasonable: e.g. if the user has redirected
 564                  ;; *ERROR-OUTPUT* to some log file, it's probably wrong
 565                  ;; to send errors which occur in interactive debugging to
 566                  ;; that file, and right to send them to *DEBUG-IO*.
 567                  (*error-output* *debug-io*))
 568              (unless (typep condition 'step-condition)
 569                (when *debug-beginner-help-p*
 570                  (format *debug-io*
 571                          "~%~@<Type HELP for debugger help, or ~
 572                                (SB-EXT:QUIT) to exit from SBCL.~:@>~2%"))
 573                (show-restarts *debug-restarts* *debug-io*))
 574              (internal-debug))
 575         (when background-p
 576           (sb!thread::release-foreground))))))
 577
 578 ;;; this function is for use in *INVOKE-DEBUGGER-HOOK* when ordinary
 579 ;;; ANSI behavior has been suppressed by the "--disable-debugger"
 580 ;;; command-line option
 581 (defun debugger-disabled-hook (condition me)
 582   (declare (ignore me))
 583   ;; There is no one there to interact with, so report the
 584   ;; condition and terminate the program.
 585   (flet ((failure-quit (&key recklessly-p)
 586            (/show0 "in FAILURE-QUIT (in --disable-debugger debugger hook)")
 587            (quit :unix-status 1 :recklessly-p recklessly-p)))
 588     ;; This HANDLER-CASE is here mostly to stop output immediately
 589     ;; (and fall through to QUIT) when there's an I/O error. Thus,
 590     ;; when we're run under a shell script or something, we can die
 591     ;; cleanly when the script dies (and our pipes are cut), instead
 592     ;; of falling into ldb or something messy like that. Similarly, we
 593     ;; can terminate cleanly even if BACKTRACE dies because of bugs in
 594     ;; user PRINT-OBJECT methods.
 595     (handler-case
 596         (progn
 597           (format *error-output*
 598                   "~&~@<unhandled ~S~@[ in thread ~S~]: ~2I~_~A~:>~2%"
 599                   (type-of condition)
 600                   #!+sb-thread sb!thread:*current-thread*
 601                   #!-sb-thread nil
 602                   condition)
 603           ;; Flush *ERROR-OUTPUT* even before the BACKTRACE, so that
 604           ;; even if we hit an error within BACKTRACE (e.g. a bug in
 605           ;; the debugger's own frame-walking code, or a bug in a user
 606           ;; PRINT-OBJECT method) we'll at least have the CONDITION
 607           ;; printed out before we die.
 608           (finish-output *error-output*)
 609           ;; (Where to truncate the BACKTRACE is of course arbitrary, but
 610           ;; it seems as though we should at least truncate it somewhere.)
 611           (sb!debug:backtrace 128 *error-output*)
 612           (format
 613            *error-output*
 614            "~%unhandled condition in --disable-debugger mode, quitting~%")
 615           (finish-output *error-output*)
 616           (failure-quit))
 617       (condition ()
 618         ;; We IGNORE-ERRORS here because even %PRIMITIVE PRINT can
 619         ;; fail when our output streams are blown away, as e.g. when
 620         ;; we're running under a Unix shell script and it dies somehow
 621         ;; (e.g. because of a SIGINT). In that case, we might as well
 622         ;; just give it up for a bad job, and stop trying to notify
 623         ;; the user of anything.
 624         ;;
 625         ;; Actually, the only way I've run across to exercise the
 626         ;; problem is to have more than one layer of shell script.
 627         ;; I have a shell script which does
 628         ;;   time nice -10 sh make.sh "$1" 2>&1 | tee make.tmp
 629         ;; and the problem occurs when I interrupt this with Ctrl-C
 630         ;; under Linux 2.2.14-5.0 and GNU bash, version 1.14.7(1).
 631         ;; I haven't figured out whether it's bash, time, tee, Linux, or
 632         ;; what that is responsible, but that it's possible at all
 633         ;; means that we should IGNORE-ERRORS here. -- WHN 2001-04-24
 634         (ignore-errors
 635          (%primitive print
 636                      "Argh! error within --disable-debugger error handling"))
 637         (failure-quit :recklessly-p t)))))
 638
 639 (defvar *old-debugger-hook* nil)
 640
 641 ;;; halt-on-failures and prompt-on-failures modes, suitable for
 642 ;;; noninteractive and interactive use respectively
 643 (defun disable-debugger ()
 644   ;; *DEBUG-IO* used to be set here to *ERROR-OUTPUT* which is sort
 645   ;; of unexpected but mostly harmless, but then ENABLE-DEBUGGER had
 646   ;; to set it to a suitable value again and be very careful,
 647   ;; especially if the user has also set it. -- MG 2005-07-15
 648   (unless (eq *invoke-debugger-hook* 'debugger-disabled-hook)
 649     (setf *old-debugger-hook* *invoke-debugger-hook*
 650           *invoke-debugger-hook* 'debugger-disabled-hook))
 651   ;; This is not inside the UNLESS to ensure that LDB is disabled
 652   ;; regardless of what the old value of *INVOKE-DEBUGGER-HOOK* was.
 653   ;; This might matter for example when restoring a core.
 654   (sb!alien:alien-funcall (sb!alien:extern-alien "disable_lossage_handler"
 655                                                  (function sb!alien:void))))
 656
 657 (defun enable-debugger ()
 658   (when (eql *invoke-debugger-hook* 'debugger-disabled-hook)
 659     (setf *invoke-debugger-hook* *old-debugger-hook*
 660           *old-debugger-hook* nil))
 661   (sb!alien:alien-funcall (sb!alien:extern-alien "enable_lossage_handler"
 662                                                  (function sb!alien:void))))
 663
 664 (defun show-restarts (restarts s)
 665   (cond ((null restarts)
 666          (format s
 667                  "~&(no restarts: If you didn't do this on purpose, ~
 668                   please report it as a bug.)~%"))
 669         (t
 670          (format s "~&restarts (invokable by number or by ~
 671                     possibly-abbreviated name):~%")
 672          (let ((count 0)
 673                (names-used '(nil))
 674                (max-name-len 0))
 675            (dolist (restart restarts)
 676              (let ((name (restart-name restart)))
 677                (when name
 678                  (let ((len (length (princ-to-string name))))
 679                    (when (> len max-name-len)
 680                      (setf max-name-len len))))))
 681            (unless (zerop max-name-len)
 682              (incf max-name-len 3))
 683            (dolist (restart restarts)
 684              (let ((name (restart-name restart)))
 685                ;; FIXME: maybe it would be better to display later names
 686                ;; in parens instead of brakets, not just omit them fully.
 687                ;; Call BREAK, call BREAK in the debugger, and tell me
 688                ;; it's not confusing looking. --NS 20050310
 689                (cond ((member name names-used)
 690                       (format s "~& ~2D: ~V@T~A~%" count max-name-len restart))
 691                      (t
 692                       (format s "~& ~2D: [~VA] ~A~%"
 693                               count (- max-name-len 3) name restart)
 694                       (push name names-used))))
 695              (incf count))))))
 696
 697 (defvar *debug-loop-fun* #'debug-loop-fun
 698   "a function taking no parameters that starts the low-level debug loop")
 699
 700 ;;; This calls DEBUG-LOOP, performing some simple initializations
 701 ;;; before doing so. INVOKE-DEBUGGER calls this to actually get into
 702 ;;; the debugger. SB!KERNEL::ERROR-ERROR calls this in emergencies
 703 ;;; to get into a debug prompt as quickly as possible with as little
 704 ;;; risk as possible for stepping on whatever is causing recursive
 705 ;;; errors.
 706 (defun internal-debug ()
 707   (let ((*in-the-debugger* t)
 708         (*read-suppress* nil))
 709     (unless (typep *debug-condition* 'step-condition)
 710       (clear-input *debug-io*))
 711     (funcall *debug-loop-fun*)))
 712 \f
 713 ;;;; DEBUG-LOOP
 714
 715 ;;; Note: This defaulted to T in CMU CL. The changed default in SBCL
 716 ;;; was motivated by desire to play nicely with ILISP.
 717 (defvar *flush-debug-errors* nil
 718   #!+sb-doc
 719   "When set, avoid calling INVOKE-DEBUGGER recursively when errors occur while
 720    executing in the debugger.")
 721
 722 (defun debug-read (stream)
 723   (declare (type stream stream))
 724   (let* ((eof-marker (cons nil nil))
 725          (form (read stream nil eof-marker)))
 726     (if (eq form eof-marker)
 727         (abort)
 728         form)))
 729
 730 (defun debug-loop-fun ()
 731   (let* ((*debug-command-level* (1+ *debug-command-level*))
 732          (*real-stack-top* (sb!di:top-frame))
 733          (*stack-top* (or *stack-top-hint* *real-stack-top*))
 734          (*stack-top-hint* nil)
 735          (*current-frame* *stack-top*))
 736     (handler-bind ((sb!di:debug-condition
 737                     (lambda (condition)
 738                       (princ condition *debug-io*)
 739                       (/show0 "handling d-c by THROWing DEBUG-LOOP-CATCHER")
 740                       (throw 'debug-loop-catcher nil))))
 741       (terpri *debug-io*)
 742       (print-frame-call *current-frame* *debug-io* :verbosity 2)
 743       (loop
 744        (catch 'debug-loop-catcher
 745          (handler-bind ((error (lambda (condition)
 746                                  (when *flush-debug-errors*
 747                                    (clear-input *debug-io*)
 748                                    (princ condition *debug-io*)
 749                                    (format *debug-io*
 750                                            "~&error flushed (because ~
 751                                              ~S is set)"
 752                                            '*flush-debug-errors*)
 753                                    (/show0 "throwing DEBUG-LOOP-CATCHER")
 754                                    (throw 'debug-loop-catcher nil)))))
 755            ;; We have to bind LEVEL for the restart function created by
 756            ;; WITH-SIMPLE-RESTART.
 757            (let ((level *debug-command-level*)
 758                  (restart-commands (make-restart-commands)))
 759              (flush-standard-output-streams)
 760              (debug-prompt *debug-io*)
 761              (force-output *debug-io*)
 762              (let* ((exp (debug-read *debug-io*))
 763                     (cmd-fun (debug-command-p exp restart-commands)))
 764                (with-simple-restart (abort
 765                                      "~@<Reduce debugger level (to debug level ~W).~@:>"
 766                                      level)
 767                  (cond ((not cmd-fun)
 768                         (debug-eval-print exp))
 769                        ((consp cmd-fun)
 770                         (format *debug-io*
 771                                 "~&Your command, ~S, is ambiguous:~%"
 772                                 exp)
 773                         (dolist (ele cmd-fun)
 774                           (format *debug-io* "   ~A~%" ele)))
 775                        (t
 776                         (funcall cmd-fun))))))))))))
 777
 778 (defun debug-eval-print (expr)
 779   (/noshow "entering DEBUG-EVAL-PRINT" expr)
 780   (let ((values (multiple-value-list (interactive-eval expr))))
 781     (/noshow "done with EVAL in DEBUG-EVAL-PRINT")
 782     (dolist (value values)
 783       (fresh-line *debug-io*)
 784       (prin1 value *debug-io*)))
 785   (force-output *debug-io*))
 786 \f
 787 ;;;; debug loop functions
 788
 789 ;;; These commands are functions, not really commands, so that users
 790 ;;; can get their hands on the values returned.
 791
 792 (eval-when (:execute :compile-toplevel)
 793
 794 (sb!xc:defmacro define-var-operation (ref-or-set &optional value-var)
 795   `(let* ((temp (etypecase name
 796                   (symbol (sb!di:debug-fun-symbol-vars
 797                            (sb!di:frame-debug-fun *current-frame*)
 798                            name))
 799                   (simple-string (sb!di:ambiguous-debug-vars
 800                                   (sb!di:frame-debug-fun *current-frame*)
 801                                   name))))
 802           (location (sb!di:frame-code-location *current-frame*))
 803           ;; Let's only deal with valid variables.
 804           (vars (remove-if-not (lambda (v)
 805                                  (eq (sb!di:debug-var-validity v location)
 806                                      :valid))
 807                                temp)))
 808      (declare (list vars))
 809      (cond ((null vars)
 810             (error "No known valid variables match ~S." name))
 811            ((= (length vars) 1)
 812             ,(ecase ref-or-set
 813                (:ref
 814                 '(sb!di:debug-var-value (car vars) *current-frame*))
 815                (:set
 816                 `(setf (sb!di:debug-var-value (car vars) *current-frame*)
 817                        ,value-var))))
 818            (t
 819             ;; Since we have more than one, first see whether we have
 820             ;; any variables that exactly match the specification.
 821             (let* ((name (etypecase name
 822                            (symbol (symbol-name name))
 823                            (simple-string name)))
 824                    ;; FIXME: REMOVE-IF-NOT is deprecated, use STRING/=
 825                    ;; instead.
 826                    (exact (remove-if-not (lambda (v)
 827                                            (string= (sb!di:debug-var-symbol-name v)
 828                                                     name))
 829                                          vars))
 830                    (vars (or exact vars)))
 831               (declare (simple-string name)
 832                        (list exact vars))
 833               (cond
 834                ;; Check now for only having one variable.
 835                ((= (length vars) 1)
 836                 ,(ecase ref-or-set
 837                    (:ref
 838                     '(sb!di:debug-var-value (car vars) *current-frame*))
 839                    (:set
 840                     `(setf (sb!di:debug-var-value (car vars) *current-frame*)
 841                            ,value-var))))
 842                ;; If there weren't any exact matches, flame about
 843                ;; ambiguity unless all the variables have the same
 844                ;; name.
 845                ((and (not exact)
 846                      (find-if-not
 847                       (lambda (v)
 848                         (string= (sb!di:debug-var-symbol-name v)
 849                                  (sb!di:debug-var-symbol-name (car vars))))
 850                       (cdr vars)))
 851                 (error "specification ambiguous:~%~{   ~A~%~}"
 852                        (mapcar #'sb!di:debug-var-symbol-name
 853                                (delete-duplicates
 854                                 vars :test #'string=
 855                                 :key #'sb!di:debug-var-symbol-name))))
 856                ;; All names are the same, so see whether the user
 857                ;; ID'ed one of them.
 858                (id-supplied
 859                 (let ((v (find id vars :key #'sb!di:debug-var-id)))
 860                   (unless v
 861                     (error
 862                      "invalid variable ID, ~W: should have been one of ~S"
 863                      id
 864                      (mapcar #'sb!di:debug-var-id vars)))
 865                   ,(ecase ref-or-set
 866                      (:ref
 867                       '(sb!di:debug-var-value v *current-frame*))
 868                      (:set
 869                       `(setf (sb!di:debug-var-value v *current-frame*)
 870                              ,value-var)))))
 871                (t
 872                 (error "Specify variable ID to disambiguate ~S. Use one of ~S."
 873                        name
 874                        (mapcar #'sb!di:debug-var-id vars)))))))))
 875
 876 ) ; EVAL-WHEN
 877
 878 ;;; FIXME: This doesn't work. It would be real nice we could make it
 879 ;;; work! Alas, it doesn't seem to work in CMU CL X86 either..
 880 (defun var (name &optional (id 0 id-supplied))
 881   #!+sb-doc
 882   "Return a variable's value if possible. NAME is a simple-string or symbol.
 883    If it is a simple-string, it is an initial substring of the variable's name.
 884    If name is a symbol, it has the same name and package as the variable whose
 885    value this function returns. If the symbol is uninterned, then the variable
 886    has the same name as the symbol, but it has no package.
 887
 888    If name is the initial substring of variables with different names, then
 889    this return no values after displaying the ambiguous names. If name
 890    determines multiple variables with the same name, then you must use the
 891    optional id argument to specify which one you want. If you left id
 892    unspecified, then this returns no values after displaying the distinguishing
 893    id values.
 894
 895    The result of this function is limited to the availability of variable
 896    information. This is SETF'able."
 897   (define-var-operation :ref))
 898 (defun (setf var) (value name &optional (id 0 id-supplied))
 899   (define-var-operation :set value))
 900
 901 ;;; This returns the COUNT'th arg as the user sees it from args, the
 902 ;;; result of SB!DI:DEBUG-FUN-LAMBDA-LIST. If this returns a
 903 ;;; potential DEBUG-VAR from the lambda-list, then the second value is
 904 ;;; T. If this returns a keyword symbol or a value from a rest arg,
 905 ;;; then the second value is NIL.
 906 ;;;
 907 ;;; FIXME: There's probably some way to merge the code here with
 908 ;;; FRAME-ARGS-AS-LIST. (A fair amount of logic is already shared
 909 ;;; through LAMBDA-LIST-ELEMENT-DISPATCH, but I suspect more could be.)
 910 (declaim (ftype (function (index list)) nth-arg))
 911 (defun nth-arg (count args)
 912   (let ((n count))
 913     (dolist (ele args (error "The argument specification ~S is out of range."
 914                              n))
 915       (lambda-list-element-dispatch ele
 916         :required ((if (zerop n) (return (values ele t))))
 917         :optional ((if (zerop n) (return (values (second ele) t))))
 918         :keyword ((cond ((zerop n)
 919                          (return (values (second ele) nil)))
 920                         ((zerop (decf n))
 921                          (return (values (third ele) t)))))
 922         :deleted ((if (zerop n) (return (values ele t))))
 923         :rest ((let ((var (second ele)))
 924                  (lambda-var-dispatch var (sb!di:frame-code-location
 925                                            *current-frame*)
 926                    (error "unused &REST argument before n'th argument")
 927                    (dolist (value
 928                             (sb!di:debug-var-value var *current-frame*)
 929                             (error
 930                              "The argument specification ~S is out of range."
 931                              n))
 932                      (if (zerop n)
 933                          (return-from nth-arg (values value nil))
 934                          (decf n)))
 935                    (error "invalid &REST argument before n'th argument")))))
 936       (decf n))))
 937
 938 (defun arg (n)
 939   #!+sb-doc
 940   "Return the N'th argument's value if possible. Argument zero is the first
 941    argument in a frame's default printed representation. Count keyword/value
 942    pairs as separate arguments."
 943   (multiple-value-bind (var lambda-var-p)
 944       (nth-arg n (handler-case (sb!di:debug-fun-lambda-list
 945                                 (sb!di:frame-debug-fun *current-frame*))
 946                    (sb!di:lambda-list-unavailable ()
 947                      (error "No argument values are available."))))
 948     (if lambda-var-p
 949         (lambda-var-dispatch var (sb!di:frame-code-location *current-frame*)
 950           (error "Unused arguments have no values.")
 951           (sb!di:debug-var-value var *current-frame*)
 952           (error "invalid argument value"))
 953         var)))
 954 \f
 955 ;;;; machinery for definition of debug loop commands
 956
 957 (defvar *debug-commands* nil)
 958
 959 ;;; Interface to *DEBUG-COMMANDS*. No required arguments in args are
 960 ;;; permitted.
 961 (defmacro !def-debug-command (name args &rest body)
 962   (let ((fun-name (symbolicate name "-DEBUG-COMMAND")))
 963     `(progn
 964        (setf *debug-commands*
 965              (remove ,name *debug-commands* :key #'car :test #'string=))
 966        (defun ,fun-name ,args
 967          (unless *in-the-debugger*
 968            (error "invoking debugger command while outside the debugger"))
 969          ,@body)
 970        (push (cons ,name #',fun-name) *debug-commands*)
 971        ',fun-name)))
 972
 973 (defun !def-debug-command-alias (new-name existing-name)
 974   (let ((pair (assoc existing-name *debug-commands* :test #'string=)))
 975     (unless pair (error "unknown debug command name: ~S" existing-name))
 976     (push (cons new-name (cdr pair)) *debug-commands*))
 977   new-name)
 978
 979 ;;; This takes a symbol and uses its name to find a debugger command,
 980 ;;; using initial substring matching. It returns the command function
 981 ;;; if form identifies only one command, but if form is ambiguous,
 982 ;;; this returns a list of the command names. If there are no matches,
 983 ;;; this returns nil. Whenever the loop that looks for a set of
 984 ;;; possibilities encounters an exact name match, we return that
 985 ;;; command function immediately.
 986 (defun debug-command-p (form &optional other-commands)
 987   (if (or (symbolp form) (integerp form))
 988       (let* ((name
 989               (if (symbolp form)
 990                   (symbol-name form)
 991                   (format nil "~W" form)))
 992              (len (length name))
 993              (res nil))
 994         (declare (simple-string name)
 995                  (fixnum len)
 996                  (list res))
 997
 998         ;; Find matching commands, punting if exact match.
 999         (flet ((match-command (ele)
1000                  (let* ((str (car ele))
1001                         (str-len (length str)))
1002                    (declare (simple-string str)
1003                             (fixnum str-len))
1004                    (cond ((< str-len len))
1005                          ((= str-len len)
1006                           (when (string= name str :end1 len :end2 len)
1007                             (return-from debug-command-p (cdr ele))))
1008                          ((string= name str :end1 len :end2 len)
1009                           (push ele res))))))
1010           (mapc #'match-command *debug-commands*)
1011           (mapc #'match-command other-commands))
1012
1013         ;; Return the right value.
1014         (cond ((not res) nil)
1015               ((= (length res) 1)
1016                (cdar res))
1017               (t ; Just return the names.
1018                (do ((cmds res (cdr cmds)))
1019                    ((not cmds) res)
1020                  (setf (car cmds) (caar cmds))))))))
1021
1022 ;;; Return a list of debug commands (in the same format as
1023 ;;; *DEBUG-COMMANDS*) that invoke each active restart.
1024 ;;;
1025 ;;; Two commands are made for each restart: one for the number, and
1026 ;;; one for the restart name (unless it's been shadowed by an earlier
1027 ;;; restart of the same name, or it is NIL).
1028 (defun make-restart-commands (&optional (restarts *debug-restarts*))
1029   (let ((commands)
1030         (num 0))                        ; better be the same as show-restarts!
1031     (dolist (restart restarts)
1032       (let ((name (string (restart-name restart))))
1033         (let ((restart-fun
1034                 (lambda ()
1035                   (/show0 "in restart-command closure, about to i-r-i")
1036                   (invoke-restart-interactively restart))))
1037           (push (cons (prin1-to-string num) restart-fun) commands)
1038           (unless (or (null (restart-name restart))
1039                       (find name commands :key #'car :test #'string=))
1040             (push (cons name restart-fun) commands))))
1041     (incf num))
1042   commands))
1043 \f
1044 ;;;; frame-changing commands
1045
1046 (!def-debug-command "UP" ()
1047   (let ((next (sb!di:frame-up *current-frame*)))
1048     (cond (next
1049            (setf *current-frame* next)
1050            (print-frame-call next *debug-io*))
1051           (t
1052            (format *debug-io* "~&Top of stack.")))))
1053
1054 (!def-debug-command "DOWN" ()
1055   (let ((next (sb!di:frame-down *current-frame*)))
1056     (cond (next
1057            (setf *current-frame* next)
1058            (print-frame-call next *debug-io*))
1059           (t
1060            (format *debug-io* "~&Bottom of stack.")))))
1061
1062 (!def-debug-command-alias "D" "DOWN")
1063
1064 (!def-debug-command "BOTTOM" ()
1065   (do ((prev *current-frame* lead)
1066        (lead (sb!di:frame-down *current-frame*) (sb!di:frame-down lead)))
1067       ((null lead)
1068        (setf *current-frame* prev)
1069        (print-frame-call prev *debug-io*))))
1070
1071 (!def-debug-command-alias "B" "BOTTOM")
1072
1073 (!def-debug-command "FRAME" (&optional
1074                              (n (read-prompting-maybe "frame number: ")))
1075   (setf *current-frame*
1076         (multiple-value-bind (next-frame-fun limit-string)
1077             (if (< n (sb!di:frame-number *current-frame*))
1078                 (values #'sb!di:frame-up "top")
1079               (values #'sb!di:frame-down "bottom"))
1080           (do ((frame *current-frame*))
1081               ((= n (sb!di:frame-number frame))
1082                frame)
1083             (let ((next-frame (funcall next-frame-fun frame)))
1084               (cond (next-frame
1085                      (setf frame next-frame))
1086                     (t
1087                      (format *debug-io*
1088                              "The ~A of the stack was encountered.~%"
1089                              limit-string)
1090                      (return frame)))))))
1091   (print-frame-call *current-frame* *debug-io*))
1092
1093 (!def-debug-command-alias "F" "FRAME")
1094 \f
1095 ;;;; commands for entering and leaving the debugger
1096
1097 (!def-debug-command "TOPLEVEL" ()
1098   (throw 'toplevel-catcher nil))
1099
1100 ;;; make T safe
1101 (!def-debug-command-alias "TOP" "TOPLEVEL")
1102
1103 (!def-debug-command "RESTART" ()
1104   (/show0 "doing RESTART debug-command")
1105   (let ((num (read-if-available :prompt)))
1106     (when (eq num :prompt)
1107       (show-restarts *debug-restarts* *debug-io*)
1108       (write-string "restart: " *debug-io*)
1109       (force-output *debug-io*)
1110       (setf num (read *debug-io*)))
1111     (let ((restart (typecase num
1112                      (unsigned-byte
1113                       (nth num *debug-restarts*))
1114                      (symbol
1115                       (find num *debug-restarts* :key #'restart-name
1116                             :test (lambda (sym1 sym2)
1117                                     (string= (symbol-name sym1)
1118                                              (symbol-name sym2)))))
1119                      (t
1120                       (format *debug-io* "~S is invalid as a restart name.~%"
1121                               num)
1122                       (return-from restart-debug-command nil)))))
1123       (/show0 "got RESTART")
1124       (if restart
1125           (invoke-restart-interactively restart)
1126           (princ "There is no such restart." *debug-io*)))))
1127 \f
1128 ;;;; information commands
1129
1130 (!def-debug-command "HELP" ()
1131   ;; CMU CL had a little toy pager here, but "if you aren't running
1132   ;; ILISP (or a smart windowing system, or something) you deserve to
1133   ;; lose", so we've dropped it in SBCL. However, in case some
1134   ;; desperate holdout is running this on a dumb terminal somewhere,
1135   ;; we tell him where to find the message stored as a string.
1136   (format *debug-io*
1137           "~&~A~2%(The HELP string is stored in ~S.)~%"
1138           *debug-help-string*
1139           '*debug-help-string*))
1140
1141 (!def-debug-command-alias "?" "HELP")
1142
1143 (!def-debug-command "ERROR" ()
1144   (format *debug-io* "~A~%" *debug-condition*)
1145   (show-restarts *debug-restarts* *debug-io*))
1146
1147 (!def-debug-command "BACKTRACE" ()
1148   (backtrace (read-if-available most-positive-fixnum)))
1149
1150 (!def-debug-command "PRINT" ()
1151   (print-frame-call *current-frame* *debug-io*))
1152
1153 (!def-debug-command-alias "P" "PRINT")
1154
1155 (!def-debug-command "LIST-LOCALS" ()
1156   (let ((d-fun (sb!di:frame-debug-fun *current-frame*)))
1157     (if (sb!di:debug-var-info-available d-fun)
1158         (let ((*standard-output* *debug-io*)
1159               (location (sb!di:frame-code-location *current-frame*))
1160               (prefix (read-if-available nil))
1161               (any-p nil)
1162               (any-valid-p nil))
1163           (dolist (v (sb!di:ambiguous-debug-vars
1164                         d-fun
1165                         (if prefix (string prefix) "")))
1166             (setf any-p t)
1167             (when (eq (sb!di:debug-var-validity v location) :valid)
1168               (setf any-valid-p t)
1169               (format *debug-io* "~S~:[#~W~;~*~]  =  ~S~%"
1170                       (sb!di:debug-var-symbol v)
1171                       (zerop (sb!di:debug-var-id v))
1172                       (sb!di:debug-var-id v)
1173                       (sb!di:debug-var-value v *current-frame*))))
1174
1175           (cond
1176            ((not any-p)
1177             (format *debug-io*
1178                     "There are no local variables ~@[starting with ~A ~]~
1179                     in the function."
1180                     prefix))
1181            ((not any-valid-p)
1182             (format *debug-io*
1183                     "All variables ~@[starting with ~A ~]currently ~
1184                     have invalid values."
1185                     prefix))))
1186         (write-line "There is no variable information available."
1187                     *debug-io*))))
1188
1189 (!def-debug-command-alias "L" "LIST-LOCALS")
1190
1191 (!def-debug-command "SOURCE" ()
1192   (print (code-location-source-form (sb!di:frame-code-location *current-frame*)
1193                                     (read-if-available 0))
1194          *debug-io*))
1195 \f
1196 ;;;; source location printing
1197
1198 ;;; We cache a stream to the last valid file debug source so that we
1199 ;;; won't have to repeatedly open the file.
1200 ;;;
1201 ;;; KLUDGE: This sounds like a bug, not a feature. Opening files is fast
1202 ;;; in the 1990s, so the benefit is negligible, less important than the
1203 ;;; potential of extra confusion if someone changes the source during
1204 ;;; a debug session and the change doesn't show up. And removing this
1205 ;;; would simplify the system, which I like. -- WHN 19990903
1206 (defvar *cached-debug-source* nil)
1207 (declaim (type (or sb!di:debug-source null) *cached-debug-source*))
1208 (defvar *cached-source-stream* nil)
1209 (declaim (type (or stream null) *cached-source-stream*))
1210
1211 ;;; To suppress the read-time evaluation #. macro during source read,
1212 ;;; *READTABLE* is modified. *READTABLE* is cached to avoid
1213 ;;; copying it each time, and invalidated when the
1214 ;;; *CACHED-DEBUG-SOURCE* has changed.
1215 (defvar *cached-readtable* nil)
1216 (declaim (type (or readtable null) *cached-readtable*))
1217
1218 ;;; Stuff to clean up before saving a core
1219 (defun debug-deinit ()
1220   (setf *cached-debug-source* nil
1221         *cached-source-stream* nil
1222         *cached-readtable* nil))
1223
1224 ;;; We also cache the last toplevel form that we printed a source for
1225 ;;; so that we don't have to do repeated reads and calls to
1226 ;;; FORM-NUMBER-TRANSLATIONS.
1227 (defvar *cached-toplevel-form-offset* nil)
1228 (declaim (type (or index null) *cached-toplevel-form-offset*))
1229 (defvar *cached-toplevel-form*)
1230 (defvar *cached-form-number-translations*)
1231
1232 ;;; Given a code location, return the associated form-number
1233 ;;; translations and the actual top level form. We check our cache ---
1234 ;;; if there is a miss, we dispatch on the kind of the debug source.
1235 (defun get-toplevel-form (location)
1236   (let ((d-source (sb!di:code-location-debug-source location)))
1237     (if (and (eq d-source *cached-debug-source*)
1238              (eql (sb!di:code-location-toplevel-form-offset location)
1239                   *cached-toplevel-form-offset*))
1240         (values *cached-form-number-translations* *cached-toplevel-form*)
1241         (let* ((offset (sb!di:code-location-toplevel-form-offset location))
1242                (res
1243                 (ecase (sb!di:debug-source-from d-source)
1244                   (:file (get-file-toplevel-form location))
1245                   (:lisp (svref (sb!di:debug-source-name d-source) offset)))))
1246           (setq *cached-toplevel-form-offset* offset)
1247           (values (setq *cached-form-number-translations*
1248                         (sb!di:form-number-translations res offset))
1249                   (setq *cached-toplevel-form* res))))))
1250
1251 ;;; Locate the source file (if it still exists) and grab the top level
1252 ;;; form. If the file is modified, we use the top level form offset
1253 ;;; instead of the recorded character offset.
1254 (defun get-file-toplevel-form (location)
1255   (let* ((d-source (sb!di:code-location-debug-source location))
1256          (tlf-offset (sb!di:code-location-toplevel-form-offset location))
1257          (local-tlf-offset (- tlf-offset
1258                               (sb!di:debug-source-root-number d-source)))
1259          (char-offset
1260           (aref (or (sb!di:debug-source-start-positions d-source)
1261                     (error "no start positions map"))
1262                 local-tlf-offset))
1263          (name (sb!di:debug-source-name d-source)))
1264     (unless (eq d-source *cached-debug-source*)
1265       (unless (and *cached-source-stream*
1266                    (equal (pathname *cached-source-stream*)
1267                           (pathname name)))
1268         (setq *cached-readtable* nil)
1269         (when *cached-source-stream* (close *cached-source-stream*))
1270         (setq *cached-source-stream* (open name :if-does-not-exist nil))
1271         (unless *cached-source-stream*
1272           (error "The source file no longer exists:~%  ~A" (namestring name)))
1273         (format *debug-io* "~%; file: ~A~%" (namestring name)))
1274
1275         (setq *cached-debug-source*
1276               (if (= (sb!di:debug-source-created d-source)
1277                      (file-write-date name))
1278                   d-source nil)))
1279
1280     (cond
1281      ((eq *cached-debug-source* d-source)
1282       (file-position *cached-source-stream* char-offset))
1283      (t
1284       (format *debug-io*
1285               "~%; File has been modified since compilation:~%;   ~A~@
1286                  ; Using form offset instead of character position.~%"
1287               (namestring name))
1288       (file-position *cached-source-stream* 0)
1289       (let ((*read-suppress* t))
1290         (dotimes (i local-tlf-offset)
1291           (read *cached-source-stream*)))))
1292     (unless *cached-readtable*
1293       (setq *cached-readtable* (copy-readtable))
1294       (set-dispatch-macro-character
1295        #\# #\.
1296        (lambda (stream sub-char &rest rest)
1297          (declare (ignore rest sub-char))
1298          (let ((token (read stream t nil t)))
1299            (format nil "#.~S" token)))
1300        *cached-readtable*))
1301     (let ((*readtable* *cached-readtable*))
1302       (read *cached-source-stream*))))
1303
1304 (defun code-location-source-form (location context)
1305   (let* ((location (maybe-block-start-location location))
1306          (form-num (sb!di:code-location-form-number location)))
1307     (multiple-value-bind (translations form) (get-toplevel-form location)
1308       (unless (< form-num (length translations))
1309         (error "The source path no longer exists."))
1310       (sb!di:source-path-context form
1311                                  (svref translations form-num)
1312                                  context))))
1313 \f
1314 ;;; step to the next steppable form
1315 (!def-debug-command "STEP" ()
1316   (let ((restart (find-restart 'continue *debug-condition*)))
1317     (cond (restart
1318            (setf *stepping* t
1319                  *step* t)
1320            (invoke-restart restart))
1321           (t
1322            (format *debug-io* "~&Non-continuable error, cannot step.~%")))))
1323
1324 ;;; miscellaneous commands
1325
1326 (!def-debug-command "DESCRIBE" ()
1327   (let* ((curloc (sb!di:frame-code-location *current-frame*))
1328          (debug-fun (sb!di:code-location-debug-fun curloc))
1329          (function (sb!di:debug-fun-fun debug-fun)))
1330     (if function
1331         (describe function)
1332         (format *debug-io* "can't figure out the function for this frame"))))
1333
1334 (!def-debug-command "SLURP" ()
1335   (loop while (read-char-no-hang *standard-input*)))
1336
1337 (!def-debug-command "RETURN" (&optional
1338                               (return (read-prompting-maybe
1339                                        "return: ")))
1340   (let ((tag (find-if (lambda (x)
1341                         (and (typep (car x) 'symbol)
1342                              (not (symbol-package (car x)))
1343                              (string= (car x) "SB-DEBUG-CATCH-TAG")))
1344                       (sb!di::frame-catches *current-frame*))))
1345     (if tag
1346         (throw (car tag)
1347           (funcall (sb!di:preprocess-for-eval
1348                     return
1349                     (sb!di:frame-code-location *current-frame*))
1350                    *current-frame*))
1351         (format *debug-io*
1352                 "~@<can't find a tag for this frame ~
1353                  ~2I~_(hint: try increasing the DEBUG optimization quality ~
1354                  and recompiling)~:@>"))))
1355 \f
1356 ;;;; debug loop command utilities
1357
1358 (defun read-prompting-maybe (prompt)
1359   (unless (sb!int:listen-skip-whitespace *debug-io*)
1360     (princ prompt *debug-io*)
1361     (force-output *debug-io*))
1362   (read *debug-io*))
1363
1364 (defun read-if-available (default)
1365   (if (sb!int:listen-skip-whitespace *debug-io*)
1366       (read *debug-io*)
1367       default))