;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.
-(in-package "SB!CONDITIONS")
-
-(sb!int:file-comment
- "$Header$")
+(in-package "SB!KERNEL")
\f
;;;; restarts
(res restart))))
(res))))
-(defstruct restart
+(defstruct (restart (:copier nil))
name
function
report-function
',name)))
`(with-condition-restarts
,n-cond
- (list ,@(mapcar #'(lambda (da)
- `(find-restart ',(nth 0 da)))
+ (list ,@(mapcar (lambda (da)
+ `(find-restart ',(nth 0 da)))
data))
,(if (eq name 'cerror)
`(cerror ,(second expression) ,n-cond)
bindings))
*handler-clusters*)))
(multiple-value-prog1
- ,@forms
- ;; Wait for any float exceptions
- #!+x86 (float-wait))))
+ (progn
+ ,@forms)
+ ;; Wait for any float exceptions.
+ #!+x86 (float-wait))))
\f
;;;; HANDLER-CASE and IGNORE-ERRORS
(defmacro handler-case (form &rest cases)
- #!+sb-doc
"(HANDLER-CASE form
{ (type ([var]) body) }* )
- Executes form in a context with handlers established for the condition
+ Execute FORM in a context with handlers established for the condition
types. A peculiar property allows type to be :no-error. If such a clause
occurs, and form returns normally, all its values are passed to this clause
- as if by MULTIPLE-VALUE-CALL. The :no-error clause accepts more than one
- var specification."
- (let ((no-error-clause (assoc ':no-error cases)))
- (if no-error-clause
- (let ((normal-return (make-symbol "normal-return"))
- (error-return (make-symbol "error-return")))
- `(block ,error-return
- (multiple-value-call #'(lambda ,@(cdr no-error-clause))
- (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)))
- `(let ((,outer-tag (cons nil nil))
- (,inner-tag (cons nil nil))
- ,var ,tag-var)
- ;; FIXME: should be (DECLARE (IGNORABLE ,VAR))
- ,var ;ignoreable
- (catch ,outer-tag
- (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)
- ,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))))))))
-
-;;; FIXME: Delete this when the system is stable.
-#|
-This macro doesn't work in our system due to lossage in closing over tags.
-The previous version sets up unique run-time tags.
-
-(defmacro handler-case (form &rest cases)
- #!+sb-doc
- "(HANDLER-CASE form
- { (type ([var]) body) }* )
- Executes form in a context with handlers established for the condition
- types. A peculiar property allows type to be :no-error. If such a clause
- occurs, and form returns normally, all its values are passed to this clause
- as if by MULTIPLE-VALUE-CALL. The :no-error clause accepts more than one
+ as if by MULTIPLE-VALUE-CALL. The :NO-ERROR clause accepts more than one
var specification."
(let ((no-error-clause (assoc ':no-error cases)))
(if no-error-clause
cases)))
`(block ,tag
(let ((,var nil))
- ,var ;ignorable
+ (declare (ignorable ,var))
(tagbody
- (handler-bind
- ,(mapcar #'(lambda (annotated-case)
+ (handler-bind
+ ,(mapcar #'(lambda (annotated-case)
(list (cadr annotated-case)
`#'(lambda (temp)
- ,(if (caddr annotated-case)
- `(setq ,var temp)
- '(declare (ignore temp)))
+ ,(if (caddr annotated-case)
+ `(setq ,var temp)
+ '(declare (ignore temp)))
(go ,(car annotated-case)))))
- annotated-cases)
- (return-from ,tag ,form))
+ annotated-cases)
+ (return-from ,tag
+ #-x86 ,form
+ #+x86 (multiple-value-prog1 ,form
+ ;; Need to catch FP errors here!
+ (float-wait))))
,@(mapcan
#'(lambda (annotated-case)
(list (car annotated-case)
(t
`(progn ,@body)))))))
annotated-cases))))))))
-|#
(defmacro ignore-errors (&rest forms)
#!+sb-doc
- "Executes forms after establishing a handler for all error conditions that
- returns from this form NIL and the condition signalled."
+ "Execute FORMS handling ERROR conditions, returning the result of the last
+ form, or (VALUES NIL the-ERROR-that-was-caught) if an ERROR was handled."
`(handler-case (progn ,@forms)
(error (condition) (values nil condition))))
\f
-;;;; helper functions for restartable error handling which couldn't be defined
-;;;; 'til now 'cause they use the RESTART-CASE macro
+;;;; helper functions for restartable error handling which couldn't be
+;;;; defined 'til now 'cause they use the RESTART-CASE macro
(defun assert-error (assertion places datum &rest arguments)
(let ((cond (if datum
- (sb!conditions::coerce-to-condition datum
+ (coerce-to-condition datum
arguments
'simple-error
'error)
(defun case-body-error (name keyform keyform-value expected-type keys)
(restart-case
- (error 'sb!conditions::case-failure
+ (error 'case-failure
:name name
:datum keyform-value
:expected-type expected-type
projects / sbcl.git / blobdiff