Commit f179fd8f authored by pfdietz's avatar pfdietz

Fixed up some error tests, adding tests that hide the error form in a LOCALLY...

Fixed up some error tests, adding tests that hide the error form in a LOCALLY to possibly stimulate CMUCL compiler bugs.  Converted some uses of the old catch-type-error into classify-error.  Added safety proclamations in place of local safety declarations in eval-ed forms.
parent 1258638a
......@@ -48,3 +48,13 @@
`(adjustable-array-p ',e)))))
collect (list e why)))
nil)
(deftest adjustable-array-p.error.5
(classify-error (locally (adjustable-array-p 10)))
type-error)
(deftest adjustable-array-p.error.6
(classify-error (let ((x 10))
(locally (declare (optimize (safety 3)))
(adjustable-array-p x))))
type-error)
......@@ -219,8 +219,8 @@ the condition to go uncaught if it cannot be classified."
(defun classify-error** (form)
(handler-bind ((warning #'(lambda (c) (declare (ignore c))
(muffle-warning))))
(classify-error*
(eval `(locally (declare (optimize (safety 3))) ,form))
(proclaim '(optimize (safety 3)))
(classify-error* (eval form)
)))
(defmacro classify-error (form)
......
......@@ -58,3 +58,12 @@
`(array-dimensions ',e)))))
collect (list e why)))
nil)
(deftest array-dimensions.error.4
(classify-error (array-dimensions nil))
type-error)
(deftest array-dimensions.error.5
(classify-error (locally (array-dimensions nil)))
type-error)
......@@ -113,3 +113,12 @@
`(array-displacement ',e)))))
collect (list e why)))
nil)
(deftest array-displacement.error.4
(classify-error (array-displacement nil))
type-error)
(deftest array-displacement.error.5
(classify-error (let ((x nil)) (array-displacement x)))
type-error)
......@@ -35,3 +35,11 @@
'type-error)))
collect e)
nil)
(deftest array-rank.error.4
(classify-error (array-rank nil))
type-error)
(deftest array-rank.error.5
(classify-error (locally (array-rank nil) t))
type-error)
......@@ -50,3 +50,7 @@
(deftest array-total-size.error.4
(classify-error (array-total-size 0))
type-error)
(deftest array-total-size.error.5
(classify-error (locally (array-total-size 0) t))
type-error)
......@@ -25,6 +25,10 @@
(classify-error (boundp "abc"))
type-error)
(deftest boundp.error.6
(classify-error (locally (boundp "abc") t))
type-error)
;;; See other tests in cl-symbols.lsp
(deftest boundp.1
......
......@@ -1377,34 +1377,39 @@
;;; gensym should be implemented so that its only
;;; argument defaults to "G", with NIL causing an error.
(deftest gensym-14
(deftest gensym.error.1
(classify-error (gensym 'aaa))
type-error)
(deftest gensym-15
(deftest gensym.error.2
(classify-error (gensym 12.3))
type-error)
(deftest gensym-16
(deftest gensym.error.3
(classify-error (gensym t))
type-error)
(deftest gensym-17
(deftest gensym.error.4
(classify-error (gensym nil))
type-error) ;; NIL /= no argument!
(deftest gensym-18
(deftest gensym.error.5
(classify-error (gensym '(a)))
type-error)
(deftest gensym-19
(deftest gensym.error.6
(classify-error (gensym #\x))
type-error)
(deftest gensym-20
(deftest gensym.error.7
(classify-error (gensym 10 'foo))
program-error)
(deftest gensym.error.8
(classify-error (locally (gensym t) t))
type-error)
;;;;;;;;;;;;;;;;;;;;
;;; Tests of CL package constraints from section 11.1.2.1.1
......
......@@ -164,3 +164,7 @@
(deftest coerce.error.8
(classify-error (coerce 'x t 'foo))
program-error)
(deftest coerce.error.9
(classify-error (locally (coerce nil 'cons) t))
type-error)
......@@ -188,13 +188,16 @@
(deftest concatenate-error.1
(handler-case
(concatenate 'sequence '(a b c))
(progn (proclaim '(optimize (safety 3)))
(eval '(concatenate 'sequence '(a b c))))
(error () :caught))
:caught)
(deftest concatenate-error.2
(handler-case (concatenate 'fixnum '(a b c d e))
(error () :caught))
(handler-case
(progn (proclaim '(optimize (safety 3)))
(concatenate 'fixnum '(a b c d e)))
(error () :caught))
:caught)
(deftest concatenate-error.3
......@@ -204,3 +207,7 @@
(deftest concatenate-error.4
(classify-error (concatenate))
program-error)
(deftest concatenate-error.5
(classify-error (locally (concatenate '(vector * 3) '(a b c d e)) t))
type-error)
......@@ -388,6 +388,14 @@
(classify-error (rplaca (cons 'a 'b) (cons 'c 'd) 'garbage))
program-error)
(deftest rplaca.error.5
(classify-error (rplaca 'a 1))
type-error)
(deftest rplaca.error.6
(classify-error (locally (rplaca 'a 1) t))
type-error)
;; rplacd on a fixnum is a type error
(deftest rplacd.error.1
(loop for x in *universe*
......@@ -407,3 +415,10 @@
(classify-error (rplacd (cons 'a 'b) (cons 'c 'd) 'garbage))
program-error)
(deftest rplacd.error.5
(classify-error (rplacd 'a 1))
type-error)
(deftest rplacd.error.6
(classify-error (locally (rplacd 'a 1) t))
type-error)
......@@ -101,6 +101,14 @@
(classify-error (list-length nil nil))
program-error)
(deftest list-length.error.4
(classify-error (list-length 'a))
type-error)
(deftest list-length.error.5
(classify-error (locally (list-length 'a) t))
type-error)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; listp
......@@ -213,13 +221,11 @@
(make-list 5 :initial-element 'a :initial-element 'b)
(a a a a a))
(deftest make-list-type.error.1
(deftest make-list.error.1
(catch-type-error (make-list -1))
type-error)
;; This next test causes ACL 4.3 (Linux) to loop
#-allegro
(deftest make-list-type.error.2
(deftest make-list.error.2
(classify-error (make-list 'a))
type-error)
......@@ -242,3 +248,7 @@
(deftest make-list.error.7
(classify-error (make-list 5 :bad t :allow-other-keys nil))
program-error)
(deftest make-list.error.8
(classify-error (locally (make-list 'a) t))
type-error)
......@@ -42,3 +42,7 @@
(deftest endp.error.5
(classify-error (endp nil nil))
program-error)
(deftest endp.error.6
(catch-type-error (locally (endp 1)))
type-error)
......@@ -23,6 +23,10 @@
(classify-error (car 'a))
type-error)
(deftest car-symbol-error.2
(classify-error (locally (car 'a) t))
type-error)
(deftest cdr-1
(cdr '(a b))
(b))
......@@ -35,6 +39,10 @@
(classify-error (cdr 'a))
type-error)
(deftest cdr-symbol-error.2
(classify-error (locally (cdr 'a) t))
type-error)
(deftest list-length-4
(list-length (copy-tree '(a b c)))
3)
......@@ -434,3 +442,5 @@
(deftest cddddr.error.4
(classify-error (cddddr '(a c e . b)))
type-error)
;;; Need to add 'locally' wrapped forms of these
......@@ -47,91 +47,96 @@
nil)
(deftest butlast-5
(catch-type-error (butlast (copy-tree '(a b c . d)) 1))
(butlast (copy-tree '(a b c . d)) 1)
(a b))
(deftest butlast-6
(catch-type-error (butlast (copy-tree '(a b c d)) 'a))
(deftest butlast.error.1
(classify-error (butlast (copy-tree '(a b c d)) 'a))
type-error)
(deftest butlast-7
(catch-type-error (butlast 'a 0))
(deftest butlast.error.2
(classify-error (butlast 'a 0))
type-error)
(deftest butlast-8
(deftest butlast.error.3
(classify-error (butlast))
program-error)
(deftest butlast-9
(deftest butlast.error.4
(classify-error (butlast '(a b c) 3 3))
program-error)
(deftest butlast.error.5
(classify-error (locally (butlast 'a 0) t))
type-error)
;;; Tests of NBUTLAST
(deftest nbutlast-1
(let ((x (list 'a 'b 'c 'd 'e)))
(let ((y (cdr x))
(z (cddr x)))
(let ((result (nbutlast x 2)))
(and (eqt x result)
(eqt (cdr x) y)
(eqt (cddr x) z)
result))))
(let ((x (list 'a 'b 'c 'd 'e)))
(let ((y (cdr x))
(z (cddr x)))
(let ((result (nbutlast x 2)))
(and (eqt x result)
(eqt (cdr x) y)
(eqt (cddr x) z)
result))))
(a b c))
(deftest nbutlast-2
(let ((x (list 'a 'b 'c 'd 'e)))
(let ((result (nbutlast x 5)))
(list x result)))
(let ((x (list 'a 'b 'c 'd 'e)))
(let ((result (nbutlast x 5)))
(list x result)))
((a b c d e) nil))
(deftest nbutlast-3
(let ((x (list 'a 'b 'c 'd 'e)))
(let ((result (nbutlast x 500)))
(list x result)))
(let ((x (list 'a 'b 'c 'd 'e)))
(let ((result (nbutlast x 500)))
(list x result)))
((a b c d e) nil))
(deftest nbutlast-4
(let ((x (list* 'a 'b 'c 'd)))
(let ((result (catch-type-error (nbutlast x 1))))
(and (eqt result x)
result)))
(let ((x (list* 'a 'b 'c 'd)))
(let ((result (nbutlast x 1)))
(and (eqt result x)
result)))
(a b))
(deftest nbutlast-5
(let ((x (list* 'a 'b 'c 'd)))
(let ((result (catch-type-error (nbutlast x 'a))))
result))
(classify-error (let ((x (list* 'a 'b 'c 'd))) (nbutlast x 'a)))
type-error)
(deftest nbutlast-6
(catch-type-error (nbutlast 'a 10))
(classify-error (nbutlast 'a 10))
type-error)
(deftest nbutlast-7
(catch-type-error (nbutlast 2 10))
(classify-error (nbutlast 2 10))
type-error)
(deftest nbutlast-8
(catch-type-error (nbutlast #\w 10))
(classify-error (nbutlast #\w 10))
type-error)
(deftest nbutlast-9
(catch-type-error (nbutlast (list 'a 'b 'c 'd) -3))
(classify-error (nbutlast (list 'a 'b 'c 'd) -3))
type-error)
(deftest nbutlast-10
(nbutlast nil)
(nbutlast nil)
nil)
(deftest nbutlast-11
(nbutlast (list 'a))
(nbutlast (list 'a))
nil)
(deftest nbutlast-12
(catch-type-error (nbutlast (list 'a) 20.0))
(classify-error (nbutlast (list 'a) 20.0))
type-error)
(deftest nbutlast-13
(catch-type-error (nbutlast (list 'a) -100.0))
(classify-error (nbutlast (list 'a) -100.0))
type-error)
(deftest nbutlast-14
......@@ -141,3 +146,7 @@
(deftest nbutlast-15
(classify-error (nbutlast (list 'a 'b 'c) 3 3))
program-error)
(deftest nbutlast-16
(classify-error (locally (nbutlast 'a 10) t))
type-error)
......@@ -50,30 +50,34 @@
(last (cons 'a 'b) 2)
(a . b))
(deftest last-11
(catch-type-error (last (list 'a 'b 'c) -1))
(deftest last.error.1
(classify-error (last (list 'a 'b 'c) -1))
type-error)
(deftest last-12
(catch-type-error (last (list 'a 'b 'c) 'a))
(deftest last.error.2
(classify-error (last (list 'a 'b 'c) 'a))
type-error)
(deftest last-13
(catch-type-error (last (list 'a 'b 'c) 10.0))
(deftest last.error.3
(classify-error (last (list 'a 'b 'c) 10.0))
type-error)
(deftest last-14
(catch-type-error (last (list 'a 'b 'c) -10.0))
(deftest last.error.4
(classify-error (last (list 'a 'b 'c) -10.0))
type-error)
(deftest last-15
(catch-type-error (last (list 'a 'b 'c) #\w))
(deftest last.error.5
(classify-error (last (list 'a 'b 'c) #\w))
type-error)
(deftest last-16
(deftest last.error.6
(classify-error (last))
program-error)
(deftest last-17
(deftest last.error.7
(classify-error (last '(a b c) 2 nil))
program-error)
(deftest last.error.8
(classify-error (locally (last (list 'a 'b 'c) 'a) t))
type-error)
......@@ -35,7 +35,7 @@
(deftest ldiff-3
(let* ((x (copy-tree '(a b c d e . f)))
(xcopy (make-scaffold-copy x)))
(let ((result (catch-type-error (ldiff x 'a))))
(let ((result (ldiff x 'a)))
(and
(check-scaffold-copy x xcopy)
result)))
......@@ -46,7 +46,7 @@
(let* ((n 18)
(x (list* 'a 'b 'c 18))
(xcopy (make-scaffold-copy x)))
(let ((result (catch-type-error (ldiff x n))))
(let ((result (ldiff x n)))
(and
(check-scaffold-copy x xcopy)
result)))
......@@ -58,7 +58,7 @@
(let* ((n 18000000000000)
(x (list* 'a 'b 'c (1- 18000000000001)))
(xcopy (make-scaffold-copy x)))
(let ((result (catch-type-error (ldiff x n))))
(let ((result (ldiff x n)))
(and
(check-scaffold-copy x xcopy)
result)))
......@@ -69,7 +69,7 @@
(let* ((n (copy-seq "abcde"))
(x (list* 'a 'b 'c n))
(xcopy (make-scaffold-copy x)))
(let ((result (catch-type-error (ldiff x n))))
(let ((result (ldiff x n)))
(if (equal result (list 'a 'b 'c))
(check-scaffold-copy x xcopy)
result)))
......@@ -81,7 +81,7 @@
(let* ((n (copy-seq "abcde"))
(x (list* 'a 'b 'c n))
(xcopy (make-scaffold-copy x)))
(let ((result (catch-type-error (ldiff x (copy-seq n)))))
(let ((result (ldiff x (copy-seq n))))
(if (equal result x)
(check-scaffold-copy x xcopy)
result)))
......@@ -104,25 +104,25 @@
;; Error checking
(deftest ldiff.error.1
(catch-type-error (ldiff 10 'a))
(classify-error (ldiff 10 'a))
type-error)
;; Single atoms are not dotted lists, so the next
;; case should be a type-error
(deftest ldiff.error.2
(catch-type-error (ldiff 'a 'a))
(classify-error (ldiff 'a 'a))
type-error)
(deftest ldiff.error.3
(catch-type-error (ldiff (make-array '(10) :initial-element 'a) '(a)))
(classify-error (ldiff (make-array '(10) :initial-element 'a) '(a)))
type-error)
(deftest ldiff.error.4
(catch-type-error (ldiff 1.23 t))
(classify-error (ldiff 1.23 t))
type-error)
(deftest ldiff.error.5
(catch-type-error (ldiff #\w 'a))
(classify-error (ldiff #\w 'a))
type-error)
(deftest ldiff.error.6
......@@ -177,22 +177,21 @@
;; The next four tests test that tailp handles dotted lists. See
;; TAILP-NIL:T in the X3J13 documentation.
(deftest tailp.error.1
(catch-type-error (notnot-mv (tailp 'e (copy-tree '(a b c d . e)))))
(deftest tailp-2
(notnot-mv (tailp 'e (copy-tree '(a b c d . e))))
t)
(deftest tailp.error.2
(catch-type-error (tailp 'z (copy-tree '(a b c d . e))))
(deftest tailp-3
(tailp 'z (copy-tree '(a b c d . e)))
nil)
(deftest tailp.error.3
(catch-type-error (notnot-mv (tailp 10203040506070
(list* 'a 'b (1- 10203040506071)))))
(deftest tailp-4
(notnot-mv (tailp 10203040506070
(list* 'a 'b (1- 10203040506071))))
t)
(deftest tailp.error.4
(let ((x "abcde"))
(catch-type-error (tailp x (list* 'a 'b (copy-seq x)))))
(deftest tailp-5
(let ((x "abcde")) (tailp x (list* 'a 'b (copy-seq x))))
nil)
(deftest tailp.error.5
......
......@@ -11,27 +11,27 @@
;;; nthcdr
(deftest nthcdr.error.1
(catch-type-error (nthcdr nil (copy-tree '(a b c d))))
(classify-error (nthcdr nil (copy-tree '(a b c d))))
type-error)
(deftest nthcdr.error.2
(catch-type-error (nthcdr 'a (copy-tree '(a b c d))))
(classify-error (nthcdr 'a (copy-tree '(a b c d))))
type-error)
(deftest nthcdr.error.3
(catch-type-error (nthcdr 0.1 (copy-tree '(a b c d))))
(classify-error (nthcdr 0.1 (copy-tree '(a b c d))))
type-error)
(deftest nthcdr.error.4
(catch-type-error (nthcdr #\A (copy-tree '(a b c d))))
(classify-error (nthcdr #\A (copy-tree '(a b c d))))
type-error)
(deftest nthcdr.error.5
(catch-type-error (nthcdr '(a) (copy-tree '(a b c d))))
(classify-error (nthcdr '(a) (copy-tree '(a b c d))))
type-error)
(deftest nthcdr.error.6
(catch-type-error (nthcdr -10 (copy-tree '(a b c d))))
(classify-error (nthcdr -10 (copy-tree '(a b c d))))
type-error)
(deftest nthcdr.error.7
......@@ -47,27 +47,31 @@
program-error)
(deftest nthcdr.error.10
(catch-type-error (nthcdr 3 (cons 'a 'b)))
(classify-error (nthcdr 3 (cons 'a 'b)))
type-error)
(deftest nthcdr.error.11
(classify-error (locally (nthcdr 'a (copy-tree '(a b c d))) t))
type-error)
(deftest nthcdr-7
(nthcdr 0 (copy-tree '(a b c d . e)))
(nthcdr 0 (copy-tree '(a b c d . e)))
(a b c d . e))
(deftest nthcdr-8
(nthcdr 1 (copy-tree '(a b c d)))
(nthcdr 1 (copy-tree '(a b c d)))
(b c d))
(deftest nthcdr-9
(nthcdr 10 nil)
(nthcdr 10 nil)
nil)
(deftest nthcdr-10
(nthcdr 4 (list 'a 'b 'c))
(nthcdr 4 (list 'a 'b 'c))
nil)
(deftest nthcdr-11
(nthcdr 1 (cons 'a 'b))
(nthcdr 1 (cons 'a 'b))
b)
......@@ -75,7 +79,7 @@
;;; rest
(deftest rest-1
(rest (list 'a 'b 'c))
(rest (list 'a 'b 'c))
(b c))
(deftest rest.error.1
......
......@@ -172,31 +172,31 @@
;;; Error cases
(deftest member.error.1
(catch-type-error (member 'a 'b))
(classify-error (member 'a 'b))
type-error)
(deftest member.error.2
(catch-type-error (member 'a 1.3))
(classify-error (member 'a 1.3))
type-error)
(deftest member.error.3
(catch-type-error (member 'a 1))
(classify-error (member 'a 1))
type-error)
(deftest member.error.4
(catch-type-error (member 'a 0))
(classify-error (member 'a 0))
type-error)
(deftest member.error.5
(catch-type-error (member 'a "abcde"))
(classify-error (member 'a "abcde"))
type-error)
(deftest member.error.6
(catch-type-error (member 'a #\w))
(classify-error (member 'a #\w))
type-error)
(deftest member.error.7
(catch-type-error (member 'a t))
(classify-error (member 'a t))
type-error)
(deftest member.error.8
......@@ -222,3 +222,7 @@
(deftest member.error.13
(classify-error (member nil nil nil))
program-error)
(deftest member.error.14
(classify-error (locally (member 'a t) t))
type-error)
......@@ -170,6 +170,11 @@
(classify-error (member-if #'null '(a b c) 1 2))
program-error)
(deftest member-if.error.8
(classify-error (locally (member-if #'identity 'a) t))
type-error)
(deftest member-if-not.error.1
(classify-error (member-if-not #'identity 'a))
type-error)
......@@ -197,3 +202,7 @@
(deftest member-if-not.error.7
(classify-error (member-if-not #'null '(a b c) 1 2))
program-error)
(deftest member-if-not.error.8
(classify-error (locally (member-if-not #'identity 'a) t))
type-error)
......@@ -76,6 +76,10 @@
(classify-error (mapc #'append))
program-error)
(deftest mapc.error.4
(classify-error (locally (mapc #'identity 1) t))
type-error)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; mapcar
......@@ -151,6 +155,10 @@
(classify-error (mapcar #'append))
program-error)
(deftest mapcar.error.4
(classify-error (locally (mapcar #'identity 1) t))
type-error)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; mapcan
......@@ -229,6 +237,10 @@
(classify-error (mapcan #'append))
program-error)
(deftest mapcan.error.4
(classify-error (locally (mapcan #'identity 1) t))
type-error)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; mapl
......@@ -321,6 +333,10 @@
(classify-error (mapl #'append))
program-error)
(deftest mapl.error.4
(classify-error (locally (mapl #'identity 1) t))
type-error)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; maplist
......@@ -419,6 +435,9 @@
(classify-error (maplist #'append))
program-error)
(deftest maplist.error.7
(classify-error (locally (maplist #'identity 'a) t))
type-error)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; mapcan
......@@ -464,4 +483,9 @@
(classify-error (mapcon #'append))
program-error)
(deftest mapcon.error.4
(classify-error (locally (mapcon #'identity 1) t))
type-error)