X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-error.lisp;h=be8c31901e0a5d51a4d7e34d0a9f4efb168f3172;hb=cee8ef591040db9a79cdd19297867672a9529051;hp=2406d7b6b16c0ce606be04b906f8cd0ef6e4c9f5;hpb=4898ef32c639b1c7f4ee13a5ba566ce6debd03e6;p=sbcl.git diff --git a/src/code/target-error.lisp b/src/code/target-error.lisp index 2406d7b..be8c319 100644 --- a/src/code/target-error.lisp +++ b/src/code/target-error.lisp @@ -19,7 +19,16 @@ ;;; associated with Condition (defvar *condition-restarts* ()) -(defvar *handler-clusters* nil) +(defun muffle-warning-p (warning) + (declare (special *muffled-warnings*)) + (typep warning *muffled-warnings*)) + +(defun initial-handler-clusters () + `(((warning . ,#'(lambda (warning) + (when (muffle-warning-p warning) + (muffle-warning warning))))))) + +(defvar *handler-clusters* (initial-handler-clusters)) (defstruct (restart (:copier nil) (:predicate nil)) (name (missing-arg) :type symbol :read-only t) @@ -33,12 +42,13 @@ (prin1 (restart-name restart) stream)) (restart-report restart stream))) +(defvar *restart-test-stack* nil) + (defun compute-restarts (&optional condition) #!+sb-doc - "Return a list of all the currently active restarts ordered from most - recently established to less recently established. If CONDITION is - specified, then only restarts associated with CONDITION (or with no - condition) will be returned." + "Return a list of all the currently active restarts ordered from most recently +established to less recently established. If CONDITION is specified, then only +restarts associated with CONDITION (or with no condition) will be returned." (let ((associated ()) (other ())) (dolist (alist *condition-restarts*) @@ -46,14 +56,22 @@ (setq associated (cdr alist)) (setq other (append (cdr alist) other)))) (collect ((res)) - (dolist (restart-cluster *restart-clusters*) - (dolist (restart restart-cluster) - (when (and (or (not condition) - (member restart associated) - (not (member restart other))) - (funcall (restart-test-function restart) - condition)) - (res restart)))) + (let ((stack *restart-test-stack*)) + (dolist (restart-cluster *restart-clusters*) + (dolist (restart restart-cluster) + (when (and (or (not condition) + (memq restart associated) + (not (memq restart other))) + ;; A call to COMPUTE-RESTARTS -- from an error, from + ;; user code, whatever -- inside the test function + ;; would cause infinite recursion here, so we disable + ;; each restart using *restart-test-stack* for the + ;; duraction of the test call. + (not (memq restart stack)) + (let ((*restart-test-stack* (cons restart stack))) + (declare (truly-dynamic-extent *restart-test-stack*)) + (funcall (restart-test-function restart) condition))) + (res restart))))) (res)))) #!+sb-doc @@ -68,19 +86,18 @@ (format stream "~S" restart))))) stream)) -(defun find-restart (name &optional condition) +(defun find-restart (identifier &optional condition) #!+sb-doc - "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." - (let ((restarts (compute-restarts condition))) - (declare (type list restarts)) - (find-if (lambda (x) - (or (eq x name) - (eq (restart-name x) name))) - restarts))) + "Return the first restart identified by IDENTIFIER. If IDENTIFIER is a symbol, +then the innermost applicable restart with that name is returned. If IDENTIFIER +is a restart, it is returned if it is currently active. Otherwise NIL is +returned. If CONDITION is specified and not NIL, then only restarts associated +with that condition (or with no condition) will be returned." + ;; see comment above + (if (typep identifier 'restart) + (and (find-if (lambda (cluster) (find identifier cluster)) *restart-clusters*) + identifier) + (find identifier (compute-restarts condition) :key #'restart-name))) ;;; helper for the various functions which are ANSI-spec'ed to do ;;; something with a restart or signal CONTROL-ERROR if there is none @@ -114,33 +131,35 @@ (args (interactive-restart-arguments real-restart))) (apply (restart-function real-restart) args))) -(defun assert-error (assertion places datum &rest arguments) +(defun assert-error (assertion args-and-values places datum &rest arguments) (let ((cond (if datum - (coerce-to-condition datum - arguments - 'simple-error - 'error) - (make-condition 'simple-error - :format-control "The assertion ~S failed." - :format-arguments (list assertion))))) + (coerce-to-condition + datum arguments 'simple-error 'error) + (make-condition + 'simple-error + :format-control "~@" + :format-arguments (list assertion args-and-values))))) (restart-case (error cond) (continue () - :report (lambda (stream) - (format stream "Retry assertion") - (if places - (format stream - " with new value~P for ~{~S~^, ~}." - (length places) - places) - (format stream "."))) - nil)))) + :report (lambda (stream) + (format stream "Retry assertion") + (if places + (format stream " with new value~P for ~{~S~^, ~}." + (length places) places) + (format stream "."))) + nil)))) ;;; READ-EVALUATED-FORM is used as the interactive method for restart cases ;;; setup by the Common Lisp "casing" (e.g., CCASE and CTYPECASE) macros ;;; and by CHECK-TYPE. -(defun read-evaluated-form () - (format *query-io* "~&Type a form to be evaluated:~%") +(defun read-evaluated-form (&optional (prompt-control nil promptp) + &rest prompt-args) + (apply #'format *query-io* + (if promptp prompt-control "~&Type a form to be evaluated: ") + prompt-args) + (finish-output *query-io*) (list (eval (read *query-io*)))) (defun check-type-error (place place-value type type-string) @@ -159,6 +178,15 @@ :interactive read-evaluated-form value)))) +(defun case-failure (name value keys) + (error 'case-failure + :name name + :datum value + :expected-type (if (eq name 'ecase) + `(member ,@keys) + `(or ,@keys)) + :possibilities keys)) + (defun case-body-error (name keyform keyform-value expected-type keys) (restart-case (error 'case-failure