useful when the debugger was invoked to handle an error in
deeply nested input syntax, and now the reader is confused.)")
\f
+(defmacro with-debug-io-syntax (() &body body)
+ (let ((thunk (gensym "THUNK")))
+ `(dx-flet ((,thunk ()
+ ,@body))
+ (funcall-with-debug-io-syntax #',thunk))))
;;; If LOC is an unknown location, then try to find the block start
;;; location. Used by source printing to some information instead of
:INTERRUPTED-FRAME
specifies the first interrupted frame on the stack \(typically the frame
- where the error occured, as opposed to error handling frames) if any,
+ where the error occurred, as opposed to error handling frames) if any,
otherwise behaving as :CURRENT-FRAME.
:DEBUGGER-FRAME
corresponding to method functions are printed. Possible values
are :MINIMAL, :NORMAL, and :FULL. See *METHOD-FRAME-STYLE* for more
information."
- (fresh-line stream)
- (when print-thread
- (format stream "Backtrace for: ~S~%" sb!thread:*current-thread*))
- (let ((*suppress-print-errors* (if (subtypep 'serious-condition *suppress-print-errors*)
- *suppress-print-errors*
- 'serious-condition))
- (*print-circle* t)
- (n start))
- (handler-bind ((print-not-readable #'print-unreadably))
+ (with-debug-io-syntax ()
+ (fresh-line stream)
+ (when print-thread
+ (format stream "Backtrace for: ~S~%" sb!thread:*current-thread*))
+ (let ((*suppress-print-errors* (if (subtypep 'serious-condition *suppress-print-errors*)
+ *suppress-print-errors*
+ 'serious-condition))
+ (*print-circle* t)
+ (n start))
+ (handler-bind ((print-not-readable #'print-unreadably))
(map-backtrace (lambda (frame)
(print-frame-call frame stream
:number n
:from (backtrace-start-frame from)
:start start
:count count)))
- (fresh-line stream)
- (values))
+ (fresh-line stream)
+ (values)))
(defun list-backtrace (&key
(count *backtrace-frame-count*)
(sb!di:lambda-list-unavailable ()
(make-unprintable-object "unavailable lambda list"))))
-(defun clean-xep (name args info)
+(defun interrupted-frame-error (frame)
+ (when (and (sb!di::compiled-frame-p frame)
+ (sb!di::compiled-frame-escaped frame))
+ (let ((error-number (sb!vm:internal-error-args
+ (sb!di::compiled-frame-escaped frame))))
+ (when (array-in-bounds-p sb!c:*backend-internal-errors* error-number)
+ (car (svref sb!c:*backend-internal-errors* error-number))))))
+
+(defun clean-xep (frame name args info)
(values (second name)
(if (consp args)
(let* ((count (first args))
(real-args (rest args)))
- (if (fixnump count)
+ (if (and (integerp count)
+ (eq (interrupted-frame-error frame)
+ 'invalid-arg-count-error))
;; So, this is a cheap trick -- but makes backtraces for
;; too-many-arguments-errors much, much easier to to
;; understand. FIXME: For :EXTERNAL frames at least we
(values name args)))
(values cname cargs (cons :fast-method info))))
-(defun clean-frame-call (name args method-frame-style info)
- (if (consp name)
- (case (first name)
- ((sb!c::xep sb!c::tl-xep)
- (clean-xep name args info))
- ((sb!c::&more-processor)
- (clean-&more-processor name args info))
- ((sb!c::&optional-processor)
- (clean-frame-call (second name) args method-frame-style
- info))
- ((sb!pcl::fast-method)
- (clean-fast-method name args method-frame-style info))
- (t
- (values name args info)))
- (values name args info)))
+(defun clean-frame-call (frame name method-frame-style info)
+ (let ((args (frame-args-as-list frame)))
+ (if (consp name)
+ (case (first name)
+ ((sb!c::xep sb!c::tl-xep)
+ (clean-xep frame name args info))
+ ((sb!c::&more-processor)
+ (clean-&more-processor name args info))
+ ((sb!c::&optional-processor)
+ (clean-frame-call frame (second name) method-frame-style
+ info))
+ ((sb!pcl::fast-method)
+ (clean-fast-method name args method-frame-style info))
+ (t
+ (values name args info)))
+ (values name args info))))
(defun frame-call (frame &key (method-frame-style *method-frame-style*)
replace-dynamic-extent-objects)
(let* ((debug-fun (sb!di:frame-debug-fun frame))
(kind (sb!di:debug-fun-kind debug-fun)))
(multiple-value-bind (name args info)
- (clean-frame-call (sb!di:debug-fun-name debug-fun)
- (frame-args-as-list frame)
+ (clean-frame-call frame
+ (sb!di:debug-fun-name debug-fun)
method-frame-style
(when kind (list kind)))
(let ((args (if (and (consp args) replace-dynamic-extent-objects)
(package-name *package*))
(setf *package* (find-package :cl-user))
(format *error-output*
- "The value of ~S was not an undeleted PACKAGE. It has been
-reset to ~S."
+ "The value of ~S was not an undeleted PACKAGE. It has been ~
+ reset to ~S."
'*package* *package*))
;; Before we start our own output, finish any pending output.
;;; this function is for use in *INVOKE-DEBUGGER-HOOK* when ordinary
;;; ANSI behavior has been suppressed by the "--disable-debugger"
;;; command-line option
-(defun debugger-disabled-hook (condition me)
- (declare (ignore me))
+(defun debugger-disabled-hook (condition previous-hook)
+ (declare (ignore previous-hook))
;; There is no one there to interact with, so report the
;; condition and terminate the program.
- (flet ((failure-quit (&key abort)
+ (let ((*suppress-print-errors* t)
+ (condition-error-message
+ #.(format nil "A nested error within --disable-debugger error ~
+ handling prevents displaying the original error. Attempting ~
+ to print a backtrace."))
+ (backtrace-error-message
+ #.(format nil "A nested error within --disable-debugger error ~
+ handling prevents printing the backtrace. Sorry, exiting.")))
+ (labels
+ ((failure-quit (&key abort)
(/show0 "in FAILURE-QUIT (in --disable-debugger debugger hook)")
- (exit :code 1 :abort abort)))
- ;; This HANDLER-CASE is here mostly to stop output immediately
- ;; (and fall through to QUIT) when there's an I/O error. Thus,
- ;; when we're run under a shell script or something, we can die
- ;; cleanly when the script dies (and our pipes are cut), instead
- ;; of falling into ldb or something messy like that. Similarly, we
- ;; can terminate cleanly even if BACKTRACE dies because of bugs in
- ;; user PRINT-OBJECT methods.
- (handler-case
- (progn
- (format *error-output*
- "~&~@<unhandled ~S~@[ in thread ~S~]: ~2I~_~A~:>~2%"
- (type-of condition)
- #!+sb-thread sb!thread:*current-thread*
- #!-sb-thread nil
- condition)
- ;; Flush *ERROR-OUTPUT* even before the BACKTRACE, so that
- ;; even if we hit an error within BACKTRACE (e.g. a bug in
- ;; the debugger's own frame-walking code, or a bug in a user
- ;; PRINT-OBJECT method) we'll at least have the CONDITION
- ;; printed out before we die.
- (finish-output *error-output*)
- ;; (Where to truncate the BACKTRACE is of course arbitrary, but
- ;; it seems as though we should at least truncate it somewhere.)
- (print-backtrace :count 128 :stream *error-output*
- :from :interrupted-frame)
- (format
- *error-output*
- "~%unhandled condition in --disable-debugger mode, quitting~%")
- (finish-output *error-output*)
- (failure-quit))
- (condition ()
- ;; We IGNORE-ERRORS here because even %PRIMITIVE PRINT can
- ;; fail when our output streams are blown away, as e.g. when
- ;; we're running under a Unix shell script and it dies somehow
- ;; (e.g. because of a SIGINT). In that case, we might as well
- ;; just give it up for a bad job, and stop trying to notify
- ;; the user of anything.
- ;;
- ;; Actually, the only way I've run across to exercise the
- ;; problem is to have more than one layer of shell script.
- ;; I have a shell script which does
- ;; time nice -10 sh make.sh "$1" 2>&1 | tee make.tmp
- ;; and the problem occurs when I interrupt this with Ctrl-C
- ;; under Linux 2.2.14-5.0 and GNU bash, version 1.14.7(1).
- ;; I haven't figured out whether it's bash, time, tee, Linux, or
- ;; what that is responsible, but that it's possible at all
- ;; means that we should IGNORE-ERRORS here. -- WHN 2001-04-24
- (ignore-errors
- (%primitive print
- "Argh! error within --disable-debugger error handling"))
- (failure-quit :abort t)))))
+ (exit :code 1 :abort abort))
+ (display-condition ()
+ (handler-case
+ (handler-case
+ (print-condition)
+ (condition ()
+ ;; printing failed, try to describe it
+ (describe-condition)))
+ (condition ()
+ ;; ok, give up trying to display the error and inform the user about it
+ (finish-output *error-output*)
+ (%primitive print condition-error-message))))
+ (print-condition ()
+ (format *error-output*
+ "~&~@<Unhandled ~S~@[ in thread ~S~]: ~2I~_~A~:>~2%"
+ (type-of condition)
+ #!+sb-thread sb!thread:*current-thread*
+ #!-sb-thread nil
+ condition)
+ (finish-output *error-output*))
+ (describe-condition ()
+ (format *error-output*
+ "~&Unhandled ~S~@[ in thread ~S~]:~%"
+ (type-of condition)
+ #!+sb-thread sb!thread:*current-thread*
+ #!-sb-thread nil)
+ (describe condition *error-output*)
+ (finish-output *error-output*))
+ (display-backtrace ()
+ (handler-case
+ (print-backtrace :stream *error-output*
+ :from :interrupted-frame
+ :print-thread t)
+ (condition ()
+ (values)))
+ (finish-output *error-output*)))
+ ;; This HANDLER-CASE is here mostly to stop output immediately
+ ;; (and fall through to QUIT) when there's an I/O error. Thus,
+ ;; when we're run under a shell script or something, we can die
+ ;; cleanly when the script dies (and our pipes are cut), instead
+ ;; of falling into ldb or something messy like that. Similarly, we
+ ;; can terminate cleanly even if BACKTRACE dies because of bugs in
+ ;; user PRINT-OBJECT methods. Separate the error handling of the
+ ;; two phases to maximize the chance of emitting some useful
+ ;; information.
+ (handler-case
+ (progn
+ (display-condition)
+ (display-backtrace)
+ (format *error-output*
+ "~%unhandled condition in --disable-debugger mode, quitting~%")
+ (finish-output *error-output*)
+ (failure-quit))
+ (condition ()
+ ;; We IGNORE-ERRORS here because even %PRIMITIVE PRINT can
+ ;; fail when our output streams are blown away, as e.g. when
+ ;; we're running under a Unix shell script and it dies somehow
+ ;; (e.g. because of a SIGINT). In that case, we might as well
+ ;; just give it up for a bad job, and stop trying to notify
+ ;; the user of anything.
+ ;;
+ ;; Actually, the only way I've run across to exercise the
+ ;; problem is to have more than one layer of shell script.
+ ;; I have a shell script which does
+ ;; time nice -10 sh make.sh "$1" 2>&1 | tee make.tmp
+ ;; and the problem occurs when I interrupt this with Ctrl-C
+ ;; under Linux 2.2.14-5.0 and GNU bash, version 1.14.7(1).
+ ;; I haven't figured out whether it's bash, time, tee, Linux, or
+ ;; what that is responsible, but that it's possible at all
+ ;; means that we should IGNORE-ERRORS here. -- WHN 2001-04-24
+ (ignore-errors
+ (%primitive print backtrace-error-message))
+ (failure-quit :abort t))))))
(defvar *old-debugger-hook* nil)
"When set, avoid calling INVOKE-DEBUGGER recursively when errors occur while
executing in the debugger.")
-(defun debug-read (stream)
+(defun debug-read (stream eof-restart)
(declare (type stream stream))
(let* ((eof-marker (cons nil nil))
(form (read stream nil eof-marker)))
(if (eq form eof-marker)
- (abort)
+ (invoke-restart eof-restart)
form)))
(defun debug-loop-fun ()
'*flush-debug-errors*)
(/show0 "throwing DEBUG-LOOP-CATCHER")
(throw 'debug-loop-catcher nil)))))
- ;; We have to bind LEVEL for the restart function created by
- ;; WITH-SIMPLE-RESTART.
+ ;; We have to bind LEVEL for the restart function created
+ ;; by WITH-SIMPLE-RESTART, and we need the explicit ABORT
+ ;; restart that exists now so that EOF from read can drop
+ ;; one debugger level.
(let ((level *debug-command-level*)
- (restart-commands (make-restart-commands)))
+ (restart-commands (make-restart-commands))
+ (abort-restart-for-eof (find-restart 'abort)))
(flush-standard-output-streams)
(debug-prompt *debug-io*)
(force-output *debug-io*)
(with-simple-restart (abort
"~@<Reduce debugger level (to debug level ~W).~@:>"
level)
- (let* ((exp (debug-read *debug-io*))
+ (let* ((exp (debug-read *debug-io* abort-restart-for-eof))
(cmd-fun (debug-command-p exp restart-commands)))
(cond ((not cmd-fun)
(debug-eval-print exp))
(defvar *auto-eval-in-frame* t
#!+sb-doc
"When set (the default), evaluations in the debugger's command loop occur
- relative to the current frame's environment without the need of debugger
- forms that explicitly control this kind of evaluation.")
+relative to the current frame's environment without the need of debugger
+forms that explicitly control this kind of evaluation.")
(defun debug-eval (expr)
(cond ((not (and (fboundp 'compile) *auto-eval-in-frame*))
\f
;;;; source location printing
-;;; Stuff to clean up before saving a core
-(defun debug-deinit ()
- ;; Nothing to do right now. Once there was, maybe once there
- ;; will be again.
- )
-
(defun code-location-source-form (location context &optional (errorp t))
(let* ((start-location (maybe-block-start-location location))
(form-num (sb!di:code-location-form-number start-location)))
(sb!di:debug-var-info-available
(sb!di:code-location-debug-fun
(sb!di:frame-code-location frame))))
-
-;; Hack: ensure that *U-T-F-F* has a tls index.
-#!+unwind-to-frame-and-call-vop
-(let ((sb!vm::*unwind-to-frame-function* (lambda ()))))
-
\f
;;;; debug loop command utilities
projects / sbcl.git / blobdiff