projects
/
sbcl.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
remove a stray debugging PRINT
[sbcl.git]
/
src
/
code
/
target-error.lisp
diff --git
a/src/code/target-error.lisp
b/src/code/target-error.lisp
index
845c647
..
e431146
100644
(file)
--- a/
src/code/target-error.lisp
+++ b/
src/code/target-error.lisp
@@
-19,12
+19,13
@@
;;; associated with Condition
(defvar *condition-restarts* ())
;;; associated with Condition
(defvar *condition-restarts* ())
+(defun muffle-warning-p (warning)
+ (declare (special *muffled-warnings*))
+ (typep warning *muffled-warnings*))
+
(defun initial-handler-clusters ()
`(((warning . ,#'(lambda (warning)
(defun initial-handler-clusters ()
`(((warning . ,#'(lambda (warning)
- (when (typep warning
- (locally
- (declare (special sb!ext:*muffled-warnings*))
- sb!ext:*muffled-warnings*))
+ (when (muffle-warning-p warning)
(muffle-warning warning)))))))
(defvar *handler-clusters* (initial-handler-clusters))
(muffle-warning warning)))))))
(defvar *handler-clusters* (initial-handler-clusters))
@@
-155,8
+156,12
@@
with that condition (or with no condition) will be returned."
;;; 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.
;;; 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)
(list (eval (read *query-io*))))
(defun check-type-error (place place-value type type-string)
@@
-175,6
+180,15
@@
with that condition (or with no condition) will be returned."
:interactive read-evaluated-form
value))))
: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
(defun case-body-error (name keyform keyform-value expected-type keys)
(restart-case
(error 'case-failure