;;; 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)
(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*)
(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
(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
(args (interactive-restart-arguments real-restart)))
(apply (restart-function real-restart) args)))
\f
-(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 "~@<The assertion ~S failed~:[.~:; ~
+ with ~:*~{~{~S = ~S~}~^, ~}.~]~:@>"
+ :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)
: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
projects / sbcl.git / blobdiff