From: William Harold Newman Date: Thu, 6 Dec 2001 03:33:02 +0000 (+0000) Subject: 0.pre7.86.flaky7.23: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=ba7659c92f2b7fac7e9532a3db9114c5bdc4ab55;p=sbcl.git 0.pre7.86.flaky7.23: 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. --- diff --git a/src/code/cold-init.lisp b/src/code/cold-init.lisp index 6f70874..1e4a912 100644 --- a/src/code/cold-init.lisp +++ b/src/code/cold-init.lisp @@ -240,6 +240,7 @@ 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. diff --git a/src/code/debug.lisp b/src/code/debug.lisp index d39885a..f8c18b7 100644 --- a/src/code/debug.lisp +++ b/src/code/debug.lisp @@ -692,28 +692,32 @@ reset to ~S." (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 @@ -744,9 +748,11 @@ reset to ~S." (*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 @@ -761,6 +767,7 @@ reset to ~S." "~&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. @@ -1054,7 +1061,7 @@ argument") (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 @@ -1065,7 +1072,9 @@ argument") (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=)) @@ -1154,6 +1163,7 @@ argument") ;;; (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*) @@ -1171,6 +1181,7 @@ argument") (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 diff --git a/src/code/early-format.lisp b/src/code/early-format.lisp index 86bb31e..8e1bbe3 100644 --- a/src/code/early-format.lisp +++ b/src/code/early-format.lisp @@ -45,7 +45,7 @@ (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) diff --git a/src/code/error-error.lisp b/src/code/error-error.lisp index 0cd9a2f..5a0873a 100644 --- a/src/code/error-error.lisp +++ b/src/code/error-error.lisp @@ -20,7 +20,9 @@ (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) @@ -28,9 +30,12 @@ (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 diff --git a/src/code/fd-stream.lisp b/src/code/fd-stream.lisp index 06c75b4..20a8c2f 100644 --- a/src/code/fd-stream.lisp +++ b/src/code/fd-stream.lisp @@ -479,6 +479,7 @@ (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)))))) diff --git a/src/code/fop.lisp b/src/code/fop.lisp index d52941a..59761b5 100644 --- a/src/code/fop.lisp +++ b/src/code/fop.lisp @@ -153,6 +153,7 @@ (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 diff --git a/src/code/inspect.lisp b/src/code/inspect.lisp index 4c278b8..a764389 100644 --- a/src/code/inspect.lisp +++ b/src/code/inspect.lisp @@ -57,6 +57,7 @@ evaluated expressions. ;; 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))) @@ -81,6 +82,7 @@ evaluated expressions. (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)) diff --git a/src/code/late-format.lisp b/src/code/late-format.lisp index c24384f..db53996 100644 --- a/src/code/late-format.lisp +++ b/src/code/late-format.lisp @@ -460,6 +460,7 @@ :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) @@ -611,6 +612,7 @@ "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)) @@ -622,6 +624,7 @@ (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))) diff --git a/src/code/target-error.lisp b/src/code/target-error.lisp index 6f576f7..72ca0f0 100644 --- a/src/code/target-error.lisp +++ b/src/code/target-error.lisp @@ -17,10 +17,22 @@ ;;; 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 @@ -43,17 +55,6 @@ (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.") @@ -97,20 +98,19 @@ (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) @@ -122,11 +122,13 @@ "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) @@ -134,11 +136,14 @@ "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))) @@ -321,7 +326,7 @@ ;;;; 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 @@ -350,7 +355,12 @@ ;; 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"))) @@ -359,13 +369,18 @@ (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) @@ -375,27 +390,34 @@ (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 diff --git a/src/code/toplevel.lisp b/src/code/toplevel.lisp index b8fc243..85bc4c8 100644 --- a/src/code/toplevel.lisp +++ b/src/code/toplevel.lisp @@ -437,11 +437,14 @@ (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 @@ -490,17 +493,20 @@ *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, diff --git a/version.lisp-expr b/version.lisp-expr index 1796a28..ea6d336 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -18,4 +18,4 @@ ;;; 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"