projects
/
sbcl.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
1.0.46.31: clean up mach port deallocation on x86
[sbcl.git]
/
src
/
code
/
target-error.lisp
diff --git
a/src/code/target-error.lisp
b/src/code/target-error.lisp
index
9bb1506
..
85b2215
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))
@@
-56,7
+57,6
@@
restarts associated with CONDITION (or with no condition) will be returned."
(setq other (append (cdr alist) other))))
(collect ((res))
(let ((stack *restart-test-stack*))
(setq other (append (cdr alist) other))))
(collect ((res))
(let ((stack *restart-test-stack*))
- (declare (optimize sb!c::stack-allocate-dynamic-extent))
(dolist (restart-cluster *restart-clusters*)
(dolist (restart restart-cluster)
(when (and (or (not condition)
(dolist (restart-cluster *restart-clusters*)
(dolist (restart restart-cluster)
(when (and (or (not condition)
@@
-69,7
+69,7
@@
restarts associated with CONDITION (or with no condition) will be returned."
;; duraction of the test call.
(not (memq restart stack))
(let ((*restart-test-stack* (cons restart stack)))
;; duraction of the test call.
(not (memq restart stack))
(let ((*restart-test-stack* (cons restart stack)))
- (declare (dynamic-extent *restart-test-stack*))
+ (declare (truly-dynamic-extent *restart-test-stack*))
(funcall (restart-test-function restart) condition)))
(res restart)))))
(res))))
(funcall (restart-test-function restart) condition)))
(res restart)))))
(res))))
@@
-156,8
+156,11
@@
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)
(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)
@@
-176,6
+179,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