From 6e3efcdb24e1a64e47268f0d27162f1c80aed064 Mon Sep 17 00:00:00 2001 From: gerd <gerd> Date: Sun, 26 Oct 2003 12:48:23 +0000 Subject: [PATCH] * src/code/error.lisp (handler-case): Delete unused old version. Wrap locally around single-element bodies, it can be a declaration. ANSI test HANDLER-CASE.29. --- code/error.lisp | 119 ++++++++++++------------------------------------ 1 file changed, 28 insertions(+), 91 deletions(-) diff --git a/code/error.lisp b/code/error.lisp index 8aae03703..351a563fb 100644 --- a/code/error.lisp +++ b/code/error.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/error.lisp,v 1.77 2003/10/24 02:56:59 toy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/error.lisp,v 1.78 2003/10/26 12:48:23 gerd Exp $") ;;; ;;; ********************************************************************** ;;; @@ -1071,65 +1071,6 @@ ;;;; HANDLER-CASE and IGNORE-ERRORS. -#| -;;; Version used in older versions of CMUCL which had lossage closing over -;;; tags. -;;; -(defmacro handler-case (form &rest cases) - "(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 - 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) - (declare (ignorable ,var)) - (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)))))))) -|# - ;;; This macro doesn't work in older version of CMUCL system due to lossage ;;; in closing over tags. The previous version sets up unique run-time tags. ;;; @@ -1146,48 +1087,44 @@ (let ((normal-return (make-symbol "normal-return")) (error-return (make-symbol "error-return"))) `(block ,error-return - (multiple-value-call #'(lambda ,@(cdr no-error-clause)) + (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 ((tag (gensym)) (var (gensym)) - (annotated-cases (mapcar #'(lambda (case) (cons (gensym) case)) + (annotated-cases (mapcar (lambda (case) (cons (gensym) case)) cases))) `(block ,tag (let ((,var nil)) (declare (ignorable ,var)) (tagbody - (handler-bind - ,(mapcar #'(lambda (annotated-case) - (list (cadr annotated-case) - `#'(lambda (temp) - ,(if (caddr annotated-case) - `(setq ,var temp) - '(declare (ignore temp))) - (go ,(car annotated-case))))) - annotated-cases) - (return-from ,tag - #-x86 ,form - #+x86 (multiple-value-prog1 ,form - ;; Need to catch FP errors here! - (kernel::float-wait)))) - ,@(mapcan - #'(lambda (annotated-case) - (list (car annotated-case) - (let ((body (cdddr annotated-case))) - `(return-from - ,tag - ,(cond ((caddr annotated-case) - `(let ((,(caaddr annotated-case) - ,var)) - ,@body)) - ((not (cdr body)) - (car body)) - (t - `(locally ,@body))))))) - annotated-cases)))))))) + (handler-bind + ,(mapcar (lambda (annotated-case) + (list (cadr annotated-case) + `#'(lambda (temp) + ,(if (caddr annotated-case) + `(setq ,var temp) + '(declare (ignore temp))) + (go ,(car annotated-case))))) + annotated-cases) + (return-from ,tag + #-x86 ,form + #+x86 (multiple-value-prog1 ,form + ;; Need to catch FP errors here! + (kernel::float-wait)))) + ,@(mapcan + (lambda (annotated-case) + (list (car annotated-case) + (let ((body (cdddr annotated-case))) + `(return-from + ,tag + ,(if (caddr annotated-case) + `(let ((,(caaddr annotated-case) ,var)) + ,@body) + `(locally ,@body)))))) + annotated-cases)))))))) (defmacro ignore-errors (&rest forms) "Executes forms after establishing a handler for all error conditions that -- GitLab