Commit 534e43c9 authored by pfdietz's avatar pfdietz

Modified CLASSIFY-ERROR to EVAL its argument, so that errors that occur during...

Modified CLASSIFY-ERROR to EVAL its argument, so that errors that occur during macroexpansion are necessarily caught.  Changed some tests which this broke.  CLASSIFY-ERROR* has the old behavior.
parent 43040104
......@@ -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.
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -106,17 +106,6 @@
(deftest every.23
(classify-error (every #'eq () 'a))
type-error)
......
......@@ -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
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment