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