X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fearly-target-error.lisp;h=87bc24071f4549f429ea2380cea21f19d6a12a56;hb=7dd568fb64927be78556ac27f1f0dc60e79cf942;hp=8ea1f031ee8f203b77dc401446eb8332e263a20f;hpb=a530bbe337109d898d5b4a001fc8f1afa3b5dc39;p=sbcl.git diff --git a/src/code/early-target-error.lisp b/src/code/early-target-error.lisp index 8ea1f03..87bc240 100644 --- a/src/code/early-target-error.lisp +++ b/src/code/early-target-error.lisp @@ -10,10 +10,7 @@ ;;;; 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") ;;;; restarts @@ -46,7 +43,7 @@ (res restart)))) (res)))) -(defstruct restart +(defstruct (restart (:copier nil)) name function report-function @@ -168,8 +165,8 @@ ',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) @@ -317,81 +314,20 @@ 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)))) ;;;; 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 @@ -409,18 +345,22 @@ The previous version sets up unique run-time tags. 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) @@ -436,21 +376,20 @@ The previous version sets up unique run-time tags. (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)))) -;;;; 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) @@ -504,7 +443,7 @@ The previous version sets up unique run-time tags. (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