about that debugger/restart/QUIT problem...
...added various new /SHOW-ish cruft
...rewrote HANDLER-BIND to be more nearly clearly compatible
with ANSI HANDLER-BIND clause syntax
The RESTART-NAME slot is constant and holds a symbol.
and so forth) unless RECKLESSLY-P is non-NIL. On UNIX-like systems,
UNIX-STATUS is used as the status code."
(declare (type (signed-byte 32) unix-status unix-code))
+ (/show0 "entering QUIT")
;; FIXME: UNIX-CODE was deprecated in sbcl-0.6.8, after having been
;; around for less than a year. It should be safe to remove it after
;; a year.
(internal-debug))))))
(defun show-restarts (restarts s)
- (when restarts
- (format s "~&restarts:~%")
- (let ((count 0)
- (names-used '(nil))
- (max-name-len 0))
- (dolist (restart restarts)
- (let ((name (restart-name restart)))
- (when name
- (let ((len (length (princ-to-string name))))
- (when (> len max-name-len)
- (setf max-name-len len))))))
- (unless (zerop max-name-len)
- (incf max-name-len 3))
- (dolist (restart restarts)
- (let ((name (restart-name restart)))
- (cond ((member name names-used)
- (format s "~& ~2D: ~@VT~A~%" count max-name-len restart))
- (t
- (format s "~& ~2D: [~VA] ~A~%"
- count (- max-name-len 3) name restart)
- (push name names-used))))
- (incf count)))))
+ (cond ((null restarts)
+ (format s
+ "~&(no restarts: If you didn't do this on purpose, ~
+ please report it as a bug.)~%"))
+ (t
+ (format s "~&restarts:~%")
+ (let ((count 0)
+ (names-used '(nil))
+ (max-name-len 0))
+ (dolist (restart restarts)
+ (let ((name (restart-name restart)))
+ (when name
+ (let ((len (length (princ-to-string name))))
+ (when (> len max-name-len)
+ (setf max-name-len len))))))
+ (unless (zerop max-name-len)
+ (incf max-name-len 3))
+ (dolist (restart restarts)
+ (let ((name (restart-name restart)))
+ (cond ((member name names-used)
+ (format s "~& ~2D: ~@VT~A~%" count max-name-len restart))
+ (t
+ (format s "~& ~2D: [~VA] ~A~%"
+ count (- max-name-len 3) name restart)
+ (push name names-used))))
+ (incf count))))))
;;; This calls DEBUG-LOOP, performing some simple initializations
;;; before doing so. INVOKE-DEBUGGER calls this to actually get into
(*stack-top* (or *stack-top-hint* *real-stack-top*))
(*stack-top-hint* nil)
(*current-frame* *stack-top*))
- (handler-bind ((sb!di:debug-condition (lambda (condition)
- (princ condition *debug-io*)
- (throw 'debug-loop-catcher nil))))
+ (handler-bind ((sb!di:debug-condition
+ (lambda (condition)
+ (princ condition *debug-io*)
+ (/show0 "handling d-c by THROWing DEBUG-LOOP-CATCHER")
+ (throw 'debug-loop-catcher nil))))
(fresh-line)
(print-frame-call *current-frame* :verbosity 2)
(loop
"~&error flushed (because ~
~S is set)"
'*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.
(setf (car cmds) (caar cmds))))))))
;;; Return a list of debug commands (in the same format as
-;;; *debug-commands*) that invoke each active restart.
+;;; *DEBUG-COMMANDS*) that invoke each active restart.
;;;
;;; Two commands are made for each restart: one for the number, and
;;; one for the restart name (unless it's been shadowed by an earlier
(dolist (restart restarts)
(let ((name (string (restart-name restart))))
(let ((restart-fun
- #'(lambda () (invoke-restart-interactively restart))))
+ #'(lambda ()
+ (/show0 "in restart-command closure, about to i-r-i")
+ (invoke-restart-interactively restart))))
(push (cons (format nil "~d" num) restart-fun) commands)
(unless (or (null (restart-name restart))
(find name commands :key #'car :test #'string=))
;;; (error "There is no restart named CONTINUE."))
(!def-debug-command "RESTART" ()
+ (/show0 "doing RESTART debug-command")
(let ((num (read-if-available :prompt)))
(when (eq num :prompt)
(show-restarts *debug-restarts* *debug-io*)
(t
(format t "~S is invalid as a restart name.~%" num)
(return-from restart-debug-command nil)))))
+ (/show0 "got RESTART")
(if restart
(invoke-restart-interactively restart)
;; FIXME: Even if this isn't handled by WARN, it probably
(defvar *only-simple-args*)
;;; Used by the expander stuff. We do an initial pass with this as NIL.
-;;; If someone doesn't like this, they (throw 'need-orig-args nil) and we try
+;;; If someone doesn't like this, they (THROW 'NEED-ORIG-ARGS NIL) and we try
;;; again with it bound to T. If this is T, we don't try to do anything
;;; fancy with args.
(defvar *orig-args-available* nil)
(defun error-error (&rest messages)
(let ((*error-error-depth* (1+ *error-error-depth*)))
(when (> *error-throw-up-count* 50)
+ (/show0 "*ERROR-THROW-UP-COUNT* too big, trying HALT")
(%primitive sb!c:halt)
+ (/show0 "*ERROR-THROW-UP-COUNT* too big, trying THROW")
(throw 'sb!impl::toplevel-catcher nil))
(case *error-error-depth*
(1)
(stream-cold-init-or-reset))
(3
(incf *error-throw-up-count*)
+ (/show0 "*ERROR-ERROR-DEPTH* too big, trying THROW")
(throw 'sb!impl::toplevel-catcher nil))
(t
+ (/show0 "*ERROR-ERROR-DEPTH* too big, trying HALT")
(%primitive sb!c:halt)
+ (/show0 "*ERROR-ERROR-DEPTH* too big, trying THROW")
(throw 'sb!impl::toplevel-catcher nil)))
(with-standard-io-syntax
(simple-stream-perror "couldn't read from ~S" stream errno)))
((zerop count)
(setf (fd-stream-listen stream) :eof)
+ (/show0 "THROWing EOF-INPUT-CATCHER")
(throw 'eof-input-catcher nil))
(t
(incf (fd-stream-ibuf-tail stream) count))))))
(find-and-init-or-check-layout name length inherits depthoid)))
(define-fop (fop-end-group 64 :nope)
+ (/show0 "THROWing FASL-GROUP-END")
(throw 'fasl-group-end t))
;;; In the normal loader, we just ignore these. GENESIS overwrites
;; thing to do (as opposed to e.g. handling it as U), we
;; could document it. Meanwhile, it seems more Unix-y to
;; do this than to signal an error.
+ (/show0 "THROWing QUIT-INSPECT for EOF")
(throw 'quit-inspect nil))
(integer
(let ((elements-length (length elements)))
(symbol
(case (find-symbol (symbol-name command) *keyword-package*)
((:q :e)
+ (/show0 "THROWing QUIT-INSPECT for :Q or :E")
(throw 'quit-inspect nil))
(:u
(return-from %inspect))
:complaint "no previous argument"))
(caar *simple-args*))
(t
+ (/show0 "THROWing NEED-ORIG-ARGS from tilde-P")
(throw 'need-orig-args nil)))))
(if atsignp
`(write-string (if (eql ,arg 1) "y" "ies") stream)
"both colon and atsign modifiers used simultaneously")
(expand-bind-defaults ((posn 0)) params
(unless *orig-args-available*
+ (/show0 "THROWing NEED-ORIG-ARGS from tilde-@*")
(throw 'need-orig-args nil))
`(if (<= 0 ,posn (length orig-args))
(setf args (nthcdr ,posn orig-args))
(if colonp
(expand-bind-defaults ((n 1)) params
(unless *orig-args-available*
+ (/show0 "THROWing NEED-ORIG-ARGS from tilde-:*")
(throw 'need-orig-args nil))
`(do ((cur-posn 0 (1+ cur-posn))
(arg-ptr orig-args (cdr arg-ptr)))
;;; a list of lists of restarts
(defvar *restart-clusters* '())
-;;; An ALIST (condition . restarts) which records the restarts currently
-;;; associated with Condition.
+;;; an ALIST (condition . restarts) which records the restarts currently
+;;; associated with Condition
(defvar *condition-restarts* ())
+(defstruct (restart (:copier nil) (:predicate nil))
+ (name (missing-arg) :type symbol :read-only t)
+ function
+ report-function
+ interactive-function
+ (test-function #'(lambda (cond) (declare (ignore cond)) t)))
+(def!method print-object ((restart restart) stream)
+ (if *print-escape*
+ (print-unreadable-object (restart stream :type t :identity t)
+ (prin1 (restart-name restart) stream))
+ (restart-report restart stream)))
+
(defun compute-restarts (&optional condition)
#!+sb-doc
"Return a list of all the currently active restarts ordered from most
(res restart))))
(res))))
-(defstruct (restart (:copier nil))
- name
- function
- report-function
- interactive-function
- (test-function #'(lambda (cond) (declare (ignore cond)) t)))
-(def!method print-object ((restart restart) stream)
- (if *print-escape*
- (print-unreadable-object (restart stream :type t :identity t))
- (restart-report restart stream)))
-
#!+sb-doc
(setf (fdocumentation 'restart-name 'function)
"Return the name of the given restart object.")
(warn "Unnamed restart does not have a ~
report function: ~S"
binding))
- `(make-restart
- :name ',(car binding)
- :function ,(cadr binding)
- ,@(cddr binding)))
+ `(make-restart :name ',(car binding)
+ :function ,(cadr binding)
+ ,@(cddr binding)))
bindings))
*restart-clusters*)))
,@forms))
(defun find-restart (name &optional condition)
#!+sb-doc
- "Return the first restart named name. If name is a restart, it is returned
- if it is currently active. If no such restart is found, nil is returned.
- It is an error to supply nil as a name. If Condition is specified and not
- NIL, then only restarts associated with that condition (or with no
+ "Return the first restart named NAME. If NAME names a restart, the restart
+ is returned if it is currently active. If no such restart is found, NIL is
+ returned. It is an error to supply NIL as a name. If CONDITION is specified
+ and not NIL, then only restarts associated with that condition (or with no
condition) will be returned."
(find-if #'(lambda (x)
(or (eq x name)
"Calls the function associated with the given restart, passing any given
arguments. If the argument restart is not a restart or a currently active
non-nil restart name, then a control-error is signalled."
+ (/show "entering INVOKE-RESTART" restart)
(let ((real-restart (find-restart restart)))
(unless real-restart
(error 'simple-control-error
:format-control "Restart ~S is not active."
:format-arguments (list restart)))
+ (/show (restart-name real-restart))
(apply (restart-function real-restart) values)))
(defun invoke-restart-interactively (restart)
"Calls the function associated with the given restart, prompting for any
necessary arguments. If the argument restart is not a restart or a
currently active non-nil restart name, then a control-error is signalled."
+ (/show "entering INVOKE-RESTART-INTERACTIVELY" restart)
(let ((real-restart (find-restart restart)))
(unless real-restart
(error 'simple-control-error
:format-control "Restart ~S is not active."
:format-arguments (list restart)))
+ (/show (restart-name real-restart))
+ (/show0 "falling through to APPLY of RESTART-FUNCTION")
(apply (restart-function real-restart)
(let ((interactive-function
(restart-interactive-function real-restart)))
\f
;;;; HANDLER-CASE
-(defmacro handler-case (form &rest cases)
+(defmacro handler-case (form &rest clauses)
"(HANDLER-CASE form
{ (type ([var]) body) }* )
Execute FORM in a context with handlers established for the condition
;; sbcl-0.pre7.14.flaky4.11, and reverted to the old code at that point.
;; The problem also occurs at least in sbcl-0.6.12.59 and
;; sbcl-0.6.13.) -- WHN
- (let ((no-error-clause (assoc ':no-error cases)))
+ ;;
+ ;; Note also: I think the old nested THROW/CATCH version became
+ ;; easier to read once I converted it to use DESTRUCTURING-BIND and
+ ;; mnemonic names, and it would probably be a useful to do that to
+ ;; the RETURN-FROM version when/if it's adopted.
+ (let ((no-error-clause (assoc ':no-error clauses)))
(if no-error-clause
(let ((normal-return (make-symbol "normal-return"))
(error-return (make-symbol "error-return")))
(block ,normal-return
(return-from ,error-return
(handler-case (return-from ,normal-return ,form)
- ,@(remove no-error-clause cases)))))))
- (let ((var (gensym))
- (outer-tag (gensym))
- (inner-tag (gensym))
- (tag-var (gensym))
- (annotated-cases (mapcar #'(lambda (case) (cons (gensym) case))
- cases)))
+ ;; FIXME: What if there's more than one :NO-ERROR
+ ;; clause? The code here and above doesn't seem
+ ;; either to remove both of them or to signal
+ ;; a good error, so it's probably wrong.
+ ,@(remove no-error-clause clauses)))))))
+ (let ((var (gensym "HC-VAR-"))
+ (outer-tag (gensym "OUTER-HC-TAG-"))
+ (inner-tag (gensym "INNER-HC-TAG-"))
+ (tag-var (gensym "HC-TAG-VAR-"))
+ (tagged-clauses (mapcar (lambda (clause)
+ (cons (gensym "HC-TAG-") clause))
+ clauses)))
`(let ((,outer-tag (cons nil nil))
(,inner-tag (cons nil nil))
,var ,tag-var)
(catch ,inner-tag
(throw ,outer-tag
(handler-bind
- ,(mapcar #'(lambda (annotated-case)
- `(,(cadr annotated-case)
- #'(lambda (temp)
- ,(if (caddr annotated-case)
- `(setq ,var temp)
- '(declare (ignore temp)))
- (setf ,tag-var
- ',(car annotated-case))
- (throw ,inner-tag nil))))
- annotated-cases)
+ ,(mapcar (lambda (tagged-clause)
+ (destructuring-bind
+ (tag typespec args &body body)
+ tagged-clause
+ (declare (ignore body))
+ `(,typespec
+ (lambda (temp)
+ ,(if args
+ `(setq ,var temp)
+ '(declare (ignore temp)))
+ (setf ,tag-var ',tag)
+ (/show "THROWing INNER-TAG from HANDLER-BIND closure for" ',typespec)
+ (throw ,inner-tag nil)))))
+ tagged-clauses)
,form)))
(case ,tag-var
- ,@(mapcar #'(lambda (annotated-case)
- (let ((body (cdddr annotated-case))
- (varp (caddr annotated-case)))
- `(,(car annotated-case)
- ,@(if varp
- `((let ((,(car varp) ,var))
- ,@body))
- body))))
- annotated-cases)))))))
+ ,@(mapcar (lambda (tagged-clause)
+ (destructuring-bind
+ (tag typespec args &body body)
+ tagged-clause
+ (declare (ignore typespec))
+ `(,tag
+ ,@(if args
+ (destructuring-bind (arg) args
+ `((let ((,arg ,var))
+ ,@body)))
+ body))))
+ tagged-clauses)))))))
#+nil ; MNA's patched version -- see FIXME above
(let ((no-error-clause (assoc ':no-error cases)))
(if no-error-clause
(eval eval)
(flush-standard-output-streams)))
(continue ()
- :report "Continue anyway (skipping to toplevel read/eval/print loop)."
- (values)) ; (no-op, just fall through)
+ :report
+ "Continue anyway (skipping to toplevel read/eval/print loop)."
+ (/show0 "CONTINUEing from pre-REPL RESTART-CASE")
+ (values)) ; (no-op, just fall through)
(quit ()
- :report "Quit SBCL (calling #'QUIT, killing the process)."
- (quit))))
+ :report "Quit SBCL (calling #'QUIT, killing the process)."
+ (/show0 "falling through to QUIT from pre-REPL RESTART-CASE")
+ (quit))))
;; one more time for good measure, in case we fell out of the
;; RESTART-CASE above before one of the flushes in the ordinary
*prompt*))
(flush-standard-output-streams))
(let ((form (read *standard-input* nil eof-marker)))
- (if (eq form eof-marker)
- (quit)
- (let ((results (multiple-value-list (interactive-eval form))))
- (unless noprint
- (dolist (result results)
- (fresh-line)
- (prin1 result)))))))))
+ (cond ((eq form eof-marker)
+ (/show0 "doing QUIT for EOF in REPL")
+ (quit))
+ (t
+ (let ((results (multiple-value-list (interactive-eval form))))
+ (unless noprint
+ (dolist (result results)
+ (fresh-line)
+ (prin1 result))))))))))
(defun noprogrammer-debugger-hook-fun (condition old-debugger-hook)
(declare (ignore old-debugger-hook))
(flet ((failure-quit (&key recklessly-p)
+ (/show0 "in FAILURE-QUIT (in noprogrammer debugger hook)")
(quit :unix-status 1 :recklessly-p recklessly-p)))
;; This HANDLER-CASE is here mostly to stop output immediately
;; (and fall through to QUIT) when there's an I/O error. Thus,
;;; for internal versions, especially for internal versions off the
;;; main CVS branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.pre7.86.flaky7.22"
+"0.pre7.86.flaky7.23"
projects / sbcl.git / commitdiff