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