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