diff --git a/ansi-tests/ansi-aux.lsp b/ansi-tests/ansi-aux.lsp index 676398206f5909005ba8195f071ba918635c5511..e54e8fe5c5e47edb313fddf2d6eccdbcdb6db4a0 100644 --- a/ansi-tests/ansi-aux.lsp +++ b/ansi-tests/ansi-aux.lsp @@ -121,7 +121,7 @@ condition itself on other errors." (type-error () 'type-error) (error (c) c)))) -(defmacro classify-error (form) +(defmacro classify-error* (form) "Evaluate form in safe mode, returning its value if there is no error. If an error does occur, return a symbol classify the error, or allow the condition to go uncaught if it cannot be classified." @@ -134,6 +134,9 @@ the condition to go uncaught if it cannot be classified." (control-error () 'control-error) ))) +(defmacro classify-error (form) + `(classify-error* (eval ',form))) + ;;; ;;; A scaffold is a structure that is used to remember the object ;;; identities of the cons cells in a (noncircular) data structure. diff --git a/ansi-tests/ccase.lsp b/ansi-tests/ccase.lsp index 4cb43b04a76902975a011a5ece0e5284e379e99a..1d8c7361ab78f581e6b0ed9754677ffed8fb0e55 100644 --- a/ansi-tests/ccase.lsp +++ b/ansi-tests/ccase.lsp @@ -11,26 +11,29 @@ 2) (deftest ccase.2 - (let ((x 1)) - (classify-error (ccase x))) + (classify-error + (let ((x 1)) (ccase x))) type-error) (deftest ccase.3 - (let ((x 1)) - (classify-error (ccase x (a 1) (b 2) (c 3)))) + (classify-error + (let ((x 1)) + (ccase x (a 1) (b 2) (c 3)))) type-error) ;;; It is legal to use T or OTHERWISE as key designators ;;; in CCASE forms. They have no special meaning here. (deftest ccase.4 - (let ((x 1)) - (classify-error (ccase x (t nil)))) + (classify-error + (let ((x 1)) + (ccase x (t nil)))) type-error) (deftest ccase.5 - (let ((x 1)) - (classify-error (ccase x (otherwise nil)))) + (classify-error + (let ((x 1)) + (ccase x (otherwise nil)))) type-error) (deftest ccase.6 @@ -52,8 +55,9 @@ a) (deftest ccase.9 - (let (x) - (classify-error (ccase x (nil 'a)))) + (classify-error + (let (x) + (ccase x (nil 'a)))) type-error) (deftest ccase.10 @@ -67,8 +71,9 @@ 1 2 3) (deftest ccase.12 - (let ((x t)) - (classify-error (ccase x (a 10)))) + (classify-error + (let ((x t)) + (ccase x (a 10)))) type-error) (deftest ccase.13 @@ -82,23 +87,27 @@ 1) (deftest ccase.15 - (let ((x 'otherwise)) - (classify-error (ccase x ((t) 10)))) + (classify-error + (let ((x 'otherwise)) + (ccase x ((t) 10)))) type-error) (deftest ccase.16 - (let ((x t)) - (classify-error (ccase x ((otherwise) 10)))) + (classify-error + (let ((x t)) + (ccase x ((otherwise) 10)))) type-error) (deftest ccase.17 - (let ((x 'a)) - (classify-error (ccase x (b 0) (c 1) (otherwise 2)))) + (classify-error + (let ((x 'a)) + (ccase x (b 0) (c 1) (otherwise 2)))) type-error) (deftest ccase.19 - (let ((x 'a)) - (classify-error (ccase x (b 0) (c 1) ((t) 2)))) + (classify-error + (let ((x 'a)) + (ccase x (b 0) (c 1) ((t) 2)))) type-error) (deftest ccase.20 diff --git a/ansi-tests/char-compare.lsp b/ansi-tests/char-compare.lsp index e8449581e7191ff9cec50d1f70c471bde40e6525..23991c812d3a1f3c1dd2cbc8a8045cff7e9b8e49 100644 --- a/ansi-tests/char-compare.lsp +++ b/ansi-tests/char-compare.lsp @@ -11,7 +11,7 @@ (loop for f in '(char= char/= char< char> char<= char>= char-lessp char-greaterp char-equal char-not-lessp char-not-greaterp char-not-equal) - collect (classify-error (funcall f))) + collect (eval `(classify-error (funcall ',f)))) (program-error program-error program-error program-error program-error program-error program-error program-error program-error program-error program-error program-error diff --git a/ansi-tests/ctypecase.lsp b/ansi-tests/ctypecase.lsp index f0eb34932d9999fd02f0ef9f7ad36ef75a017546..a23aaed3747f6f818168034e03bcf01750f3df0a 100644 --- a/ansi-tests/ctypecase.lsp +++ b/ansi-tests/ctypecase.lsp @@ -11,8 +11,9 @@ a) (deftest ctypecase.2 - (let ((x 1)) - (classify-error (ctypecase x (symbol 'a)))) + (classify-error + (let ((x 1)) + (ctypecase x (symbol 'a)))) type-error) (deftest ctypecase.3 diff --git a/ansi-tests/elt.lsp b/ansi-tests/elt.lsp index f4c421151e6ecdf18372a72d43ed6b12dffb825d..ac30142b6f0363231510b0498a2375667404c522 100644 --- a/ansi-tests/elt.lsp +++ b/ansi-tests/elt.lsp @@ -8,7 +8,7 @@ (declaim (optimize (safety 3))) (defun safe-elt (x n) - (classify-error (elt x n))) + (classify-error* (elt x n))) ;; elt on lists diff --git a/ansi-tests/every.lsp b/ansi-tests/every.lsp index 04da1c98925006747736f221291a74e13c2e599e..07cb4cec1b1d47b24c64e18bb0679d60ba0cfd7e 100644 --- a/ansi-tests/every.lsp +++ b/ansi-tests/every.lsp @@ -106,17 +106,6 @@ (deftest every.23 (classify-error (every #'eq () 'a)) type-error) - - - - - - - - - - - diff --git a/ansi-tests/fill.lsp b/ansi-tests/fill.lsp index e3898dd1cf8559899098a99c33536184827b46ac..eb4812524de65c38d69fc2e7c32c08ec9bdc250a 100644 --- a/ansi-tests/fill.lsp +++ b/ansi-tests/fill.lsp @@ -54,23 +54,27 @@ t (x x x x x)) (deftest array-fill-7 - (let* ((a (make-array '(5)))) - (classify-error (fill a 'x :start -1))) + (classify-error + (let* ((a (make-array '(5)))) + (fill a 'x :start -1))) type-error) (deftest array-fill-8 - (let* ((a (make-array '(5)))) - (classify-error (fill a 'x :start 'a))) + (classify-error + (let* ((a (make-array '(5)))) + (fill a 'x :start 'a))) type-error) (deftest array-fill-9 - (let* ((a (make-array '(5)))) - (classify-error (fill a 'x :end -1))) + (classify-error + (let* ((a (make-array '(5)))) + (fill a 'x :end -1))) type-error) (deftest array-fill-10 - (let* ((a (make-array '(5)))) - (classify-error (fill a 'x :end 'a))) + (classify-error + (let* ((a (make-array '(5)))) + (fill a 'x :end 'a))) type-error) ;;; fill on arrays of fixnums @@ -118,23 +122,27 @@ t (-1 -1 -1 -1 -1)) (deftest array-fixnum-fill-7 - (let* ((a (make-array '(5) :element-type 'fixnum))) - (classify-error (fill a 10 :start -1))) + (classify-error + (let* ((a (make-array '(5) :element-type 'fixnum))) + (fill a 10 :start -1))) type-error) (deftest array-fixnum-fill-8 - (let* ((a (make-array '(5) :element-type 'fixnum))) - (classify-error (fill a 100 :start 'a))) + (classify-error + (let* ((a (make-array '(5) :element-type 'fixnum))) + (fill a 100 :start 'a))) type-error) (deftest array-fixnum-fill-9 - (let* ((a (make-array '(5) :element-type 'fixnum))) - (classify-error (fill a -5 :end -1))) + (classify-error + (let* ((a (make-array '(5) :element-type 'fixnum))) + (fill a -5 :end -1))) type-error) (deftest array-fixnum-fill-10 - (let* ((a (make-array '(5) :element-type 'fixnum))) - (classify-error (fill a 17 :end 'a))) + (classify-error + (let* ((a (make-array '(5) :element-type 'fixnum))) + (fill a 17 :end 'a))) type-error) ;;; fill on arrays of unsigned eight bit bytes