Commit 60b12ff5 authored by pfdietz's avatar pfdietz

Added a large number of tests to check error handling on badly formatted calls in safe code.

parent 0d46fa84
...@@ -63,6 +63,14 @@ ...@@ -63,6 +63,14 @@
(character.2.body) (character.2.body)
nil) nil)
(deftest character.3
(classify-error (character))
program-error)
(deftest character.4
(classify-error (character #\a #\a))
program-error)
(deftest characterp.1 (deftest characterp.1
(every #'characterp +standard-chars+) (every #'characterp +standard-chars+)
t) t)
...@@ -75,6 +83,15 @@ ...@@ -75,6 +83,15 @@
(characterp.3.body) (characterp.3.body)
t) t)
(deftest characterp.error.1
(classify-error (characterp))
program-error)
(deftest characterp.error.2
(classify-error (characterp #\a #\b))
program-error)
(deftest alpha-char-p.1 (deftest alpha-char-p.1
(loop for c across +standard-chars+ (loop for c across +standard-chars+
always always
...@@ -90,6 +107,14 @@ ...@@ -90,6 +107,14 @@
(char-type-error-check #'alpha-char-p) (char-type-error-check #'alpha-char-p)
t) t)
(deftest alpha-char-p.error.1
(classify-error (alpha-char-p))
program-error)
(deftest alpha-char-p.error.2
(classify-error (alpha-char-p #\a #\b))
program-error)
(deftest alphanumericp.1 (deftest alphanumericp.1
(loop for c across +standard-chars+ (loop for c across +standard-chars+
always always
...@@ -114,6 +139,14 @@ ...@@ -114,6 +139,14 @@
(alphanumericp.5.body) (alphanumericp.5.body)
t) t)
(deftest alphanumericp.error.1
(classify-error (alphanumericp))
program-error)
(deftest alphanumericp.error.2
(classify-error (alphanumericp #\a #\b))
program-error)
(deftest digit-char.1 (deftest digit-char.1
(digit-char.1.body) (digit-char.1.body)
t) t)
...@@ -125,6 +158,14 @@ ...@@ -125,6 +158,14 @@
nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
nil nil nil nil nil nil nil nil nil nil)) nil nil nil nil nil nil nil nil nil nil))
(deftest digit-char.error.1
(classify-error (digit-char))
program-error)
(deftest digit-char.error.2
(classify-error (digit-char 0 10 'foo))
program-error)
(deftest digit-char-p.1 (deftest digit-char-p.1
(digit-char-p.1.body) (digit-char-p.1.body)
t) t)
...@@ -154,6 +195,15 @@ ...@@ -154,6 +195,15 @@
always (eqlt (digit-char-p c) i)) always (eqlt (digit-char-p c) i))
t) t)
(deftest digit-char-p.error.1
(classify-error (digit-char-p))
program-error)
(deftest digit-char-p.error.2
(classify-error (digit-char-p #\1 10 'foo))
program-error)
(deftest graphic-char-p.1 (deftest graphic-char-p.1
(loop for c across +standard-chars+ (loop for c across +standard-chars+
always (if (eqlt c #\Newline) always (if (eqlt c #\Newline)
...@@ -172,6 +222,14 @@ ...@@ -172,6 +222,14 @@
(char-type-error-check #'graphic-char-p) (char-type-error-check #'graphic-char-p)
t) t)
(deftest graphic-char-p.error.1
(classify-error (graphic-char-p))
program-error)
(deftest graphic-char-p.error.2
(classify-error (graphic-char-p #\a #\a))
program-error)
(deftest standard-char-p.1 (deftest standard-char-p.1
(every #'standard-char-p +standard-chars+) (every #'standard-char-p +standard-chars+)
t) t)
...@@ -188,6 +246,15 @@ ...@@ -188,6 +246,15 @@
(char-type-error-check #'standard-char-p) (char-type-error-check #'standard-char-p)
t) t)
(deftest standard-char-p.error.1
(classify-error (standard-char-p))
program-error)
(deftest standard-char-p.error.2
(classify-error (standard-char-p #\a #\a))
program-error)
(deftest char-upcase.1 (deftest char-upcase.1
(char-upcase.1.body) (char-upcase.1.body)
t) t)
...@@ -202,7 +269,15 @@ ...@@ -202,7 +269,15 @@
(deftest char-upcase.4 (deftest char-upcase.4
(char-type-error-check #'char-upcase) (char-type-error-check #'char-upcase)
t) t)
(deftest char-upcase.error.1
(classify-error (char-upcase))
program-error)
(deftest char-upcase.error.2
(classify-error (char-upcase #\a #\a))
program-error)
(deftest char-downcase.1 (deftest char-downcase.1
(char-downcase.1.body) (char-downcase.1.body)
...@@ -220,6 +295,14 @@ ...@@ -220,6 +295,14 @@
(char-type-error-check #'char-downcase) (char-type-error-check #'char-downcase)
t) t)
(deftest char-downcase.error.1
(classify-error (char-downcase))
program-error)
(deftest char-downcase.error.2
(classify-error (char-downcase #\A #\A))
program-error)
(deftest upper-case-p.1 (deftest upper-case-p.1
(find-if-not #'upper-case-p +standard-chars+ :start 26 :end 52) (find-if-not #'upper-case-p +standard-chars+ :start 26 :end 52)
nil) nil)
...@@ -236,6 +319,14 @@ ...@@ -236,6 +319,14 @@
(char-type-error-check #'upper-case-p) (char-type-error-check #'upper-case-p)
t) t)
(deftest upper-case-p.error.1
(classify-error (upper-case-p))
program-error)
(deftest upper-case-p.error.2
(classify-error (upper-case-p #\a #\A))
program-error)
(deftest lower-case-p.1 (deftest lower-case-p.1
(find-if-not #'lower-case-p +standard-chars+ :end 26) (find-if-not #'lower-case-p +standard-chars+ :end 26)
nil) nil)
...@@ -248,6 +339,14 @@ ...@@ -248,6 +339,14 @@
(char-type-error-check #'lower-case-p) (char-type-error-check #'lower-case-p)
t) t)
(deftest lower-case-p.error.1
(classify-error (lower-case-p))
program-error)
(deftest lower-case-p.error.2
(classify-error (lower-case-p #\a #\a))
program-error)
(deftest both-case-p.1 (deftest both-case-p.1
(both-case-p.1.body) (both-case-p.1.body)
t) t)
...@@ -260,6 +359,14 @@ ...@@ -260,6 +359,14 @@
(char-type-error-check #'both-case-p) (char-type-error-check #'both-case-p)
t) t)
(deftest both-case-p.error.1
(classify-error (both-case-p))
program-error)
(deftest both-case-p.error.2
(classify-error (both-case-p #\a #\a))
program-error)
(deftest char-code.1 (deftest char-code.1
(char-type-error-check #'char-code) (char-type-error-check #'char-code)
t) t)
...@@ -268,11 +375,27 @@ ...@@ -268,11 +375,27 @@
(char-code.2.body) (char-code.2.body)
t) t)
(deftest char-code.error.1
(classify-error (char-code))
program-error)
(deftest char-code.error.2
(classify-error (char-code #\a #\a))
program-error)
(deftest code-char.1 (deftest code-char.1
(loop for x across +standard-chars+ (loop for x across +standard-chars+
always (eqlt (code-char (char-code x)) x)) always (eqlt (code-char (char-code x)) x))
t) t)
(deftest code-char.error.1
(classify-error (code-char))
program-error)
(deftest code-char.error.2
(classify-error (code-char 1 1))
program-error)
(deftest char-int.1 (deftest char-int.1
(loop for x across +standard-chars+ (loop for x across +standard-chars+
always (eqlt (char-int x) (char-code x))) always (eqlt (char-int x) (char-code x)))
...@@ -282,6 +405,14 @@ ...@@ -282,6 +405,14 @@
(char-int.2.fn) (char-int.2.fn)
t) t)
(deftest char-int.error.1
(classify-error (char-int))
program-error)
(deftest char-int.error.2
(classify-error (char-int #\a #\a))
program-error)
(deftest char-name.1 (deftest char-name.1
(char-name.1.fn) (char-name.1.fn)
t) t)
...@@ -316,6 +447,14 @@ ...@@ -316,6 +447,14 @@
(char-type-error-check #'char-name) (char-type-error-check #'char-name)
t) t)
(deftest char-name.error.1
(classify-error (char-name))
program-error)
(deftest char-name.error.2
(classify-error (char-name #\a #\a))
program-error)
(deftest name-char.1 (deftest name-char.1
(name-char.1.body) (name-char.1.body)
t) t)
...@@ -330,3 +469,11 @@ ...@@ -330,3 +469,11 @@
(c4 (name-char s))) (c4 (name-char s)))
(and (eqlt c1 c2) (eqlt c2 c3) (eqlt c3 c4)))) (and (eqlt c1 c2) (eqlt c2 c3) (eqlt c3 c4))))
t) t)
(deftest name-char.error.1
(classify-error (name-char))
program-error)
(deftest name-char.error.2
(classify-error (name-char "space" "space"))
program-error)
...@@ -1005,7 +1005,7 @@ ...@@ -1005,7 +1005,7 @@
(multiple-value-bind (sym status) (multiple-value-bind (sym status)
(find-symbol (symbol-name s) keyword-package) (find-symbol (symbol-name s) keyword-package)
(cond (cond
((not (eqt s sym)) (push (list s sym) results)) ((not (eqt s sym)) (push (list s sym) result))
((eqt status :internal) ((eqt status :internal)
(push (list s status) result)) (push (list s status) result))
((eqt status :external) ((eqt status :external)
...@@ -1052,6 +1052,14 @@ ...@@ -1052,6 +1052,14 @@
(classify-error (special-operator-p 1)) (classify-error (special-operator-p 1))
type-error) type-error)
(deftest special-operator-p.4
(classify-error (special-operator-p))
program-error)
(deftest special-operator-p.5
(classify-error (special-operator-p 'cons 'cons))
program-error)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; keywordp ;;; keywordp
...@@ -1068,6 +1076,8 @@ ...@@ -1068,6 +1076,8 @@
;;; This next test was busted. ::foo is not portable syntax ;;; This next test was busted. ::foo is not portable syntax
;;(deftest keywordp-11 (not (not (keywordp ::foo))) t) ;;(deftest keywordp-11 (not (not (keywordp ::foo))) t)
(deftest keywordp-12 (keywordp t) nil) (deftest keywordp-12 (keywordp t) nil)
(deftest keywordp-13 (classify-error (keywordp)) program-error)
(deftest keywordp-14 (classify-error (keywordp :x :x)) program-error)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; symbol-name ;;; symbol-name
...@@ -1100,6 +1110,14 @@ ...@@ -1100,6 +1110,14 @@
(symbol-name :|abcdefg|) (symbol-name :|abcdefg|)
"abcdefg") "abcdefg")
(deftest symbol-name-8
(classify-error (symbol-name))
program-error)
(deftest symbol-name-9
(classify-error (symbol-name 'a 'b))
program-error)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; make-symbol ;;; make-symbol
...@@ -1176,6 +1194,14 @@ ...@@ -1176,6 +1194,14 @@
(symbol-name (safe-make-symbol "")) (symbol-name (safe-make-symbol ""))
"") "")
(deftest make-symbol-19
(classify-error (make-symbol))
program-error)
(deftest make-symbol-20
(classify-error (make-symbol "a" "a"))
program-error)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; copy-symbol ;;; copy-symbol
...@@ -1251,6 +1277,14 @@ ...@@ -1251,6 +1277,14 @@
(eqt (copy-symbol 'a) (copy-symbol 'a)) (eqt (copy-symbol 'a) (copy-symbol 'a))
nil) nil)
(deftest copy-symbol-5
(classify-error (copy-symbol))
program-error)
(deftest copy-symbol-6
(classify-error (copy-symbol 'a t 'foo))
program-error)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; gensym ;;; gensym
...@@ -1348,29 +1382,33 @@ ...@@ -1348,29 +1382,33 @@
;;; argument defaults to "G", with NIL causing an error. ;;; argument defaults to "G", with NIL causing an error.
(deftest gensym-14 (deftest gensym-14
(catch-type-error (gensym 'aaa)) (classify-error (gensym 'aaa))
type-error) type-error)
(deftest gensym-15 (deftest gensym-15
(catch-type-error (gensym 12.3)) (classify-error (gensym 12.3))
type-error) type-error)
(deftest gensym-16 (deftest gensym-16
(catch-type-error (gensym t)) (classify-error (gensym t))
type-error) type-error)
(deftest gensym-17 (deftest gensym-17
(catch-type-error (gensym nil)) (classify-error (gensym nil))
type-error) ;; NIL /= no argument! type-error) ;; NIL /= no argument!
(deftest gensym-18 (deftest gensym-18
(catch-type-error (gensym '(a))) (classify-error (gensym '(a)))
type-error) type-error)
(deftest gensym-19 (deftest gensym-19
(catch-type-error (gensym #\x)) (classify-error (gensym #\x))
type-error) type-error)
(deftest gensym-20
(classify-error (gensym 10 'foo))
program-error)
;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;
;;; Tests of CL package constraints from section 11.1.2.1.1 ;;; Tests of CL package constraints from section 11.1.2.1.1
...@@ -1435,3 +1473,62 @@ ...@@ -1435,3 +1473,62 @@
(typep c 'class)) (typep c 'class))
collect s) collect s)
nil) nil)
;;; Various error cases for symbol-related functions
(deftest symbolp.error.1
(classify-error (symbolp))
program-error)
(deftest symbolp.error.2
(classify-error (symbolp nil nil))
program-error)
(deftest keywordp.error.1
(classify-error (keywordp))
program-error)
(deftest keywordp.error.2
(classify-error (keywordp nil nil))
program-error)
(deftest symbol-function.error.1
(classify-error (symbol-function))
program-error)
(deftest symbol-function.error.2
(classify-error (symbol-function 'cons nil))
program-error)
(deftest symbol-name.error.1
(classify-error (symbol-name))
program-error)
(deftest symbol-name.error.2
(classify-error (symbol-name 'cons nil))
program-error)
(deftest symbol-package.error.1
(classify-error (symbol-package))
program-error)
(deftest symbol-package.error.2
(classify-error (symbol-package 'cons nil))
program-error)
(deftest symbol-plist.error.1
(classify-error (symbol-plist))
program-error)
(deftest symbol-plist.error.2
(classify-error (symbol-plist 'cons nil))
program-error)
(deftest symbol-value.error.1
(classify-error (symbol-value))
program-error)
(deftest symbol-value.error.2
(classify-error (symbol-value '*package* nil))
program-error)
...@@ -151,7 +151,14 @@ ...@@ -151,7 +151,14 @@
(error () :caught)) (error () :caught))
:caught) :caught)
(deftest coerce.error.6
(classify-error (coerce))
program-error)
(deftest coerce.error.7
(classify-error (coerce t))
program-error)
(deftest coerce.error.8
(classify-error (coerce 'x t 'foo))
\ No newline at end of file program-error)
...@@ -87,3 +87,11 @@ ...@@ -87,3 +87,11 @@
(let ((x (list 'a 'b))) (let ((x (list 'a 'b)))
(eqt x (funcall (compile nil `(lambda () ',x))))) (eqt x (funcall (compile nil `(lambda () ',x)))))
t) t)
(deftest compile.9
(classify-error (compile))
program-error)
(deftest compile.10
(classify-error (compile nil '(lambda () nil) 'garbage))
program-error)
...@@ -26,3 +26,14 @@ ...@@ -26,3 +26,14 @@
(push #\a x) (push #\a x)
(apply (cl::complement #'char=) x)))) (apply (cl::complement #'char=) x))))
t) t)
(deftest complement.5
(classify-error (complement))
program-error)
(deftest complement.6
(classify-error (complement #'not t))
program-error)
...@@ -200,3 +200,7 @@ ...@@ -200,3 +200,7 @@
(deftest concatenate-error.3 (deftest concatenate-error.3
(classify-error (concatenate '(vector * 3) '(a b c d e))) (classify-error (concatenate '(vector * 3) '(a b c d e)))
type-error) type-error)
(deftest concatenate-error.4
(classify-error (concatenate))
program-error)
...@@ -188,6 +188,22 @@ ...@@ -188,6 +188,22 @@
(check-type-predicate 'consp 'cons) (check-type-predicate 'consp 'cons)
0) 0)
(deftest consp.error.1
(classify-error (consp))
program-error)
(deftest consp.error.2
(classify-error (consp 'a 'b))
program-error)
(deftest atom.error.1
(classify-error (atom))
program-error)
(deftest atom.error.2
(classify-error (atom 'a 'b))
program-error)
;; Tests of car, cdr and compound forms ;; Tests of car, cdr and compound forms
(deftest cons-23 (deftest cons-23
(car '(a)) (car '(a))
...@@ -322,6 +338,18 @@ ...@@ -322,6 +338,18 @@
(cddddr *cons-test-4*) (cddddr *cons-test-4*)
p) p)
(deftest cons.error.1
(classify-error (cons))
program-error)
(deftest cons.error.2
(classify-error (cons 'a))
program-error)
(deftest cons.error.3
(classify-error (cons 'a 'b 'c))
program-error)
;; Test rplaca, rplacd ;; Test rplaca, rplacd
(deftest rplaca-1 (deftest rplaca-1
...@@ -343,15 +371,40 @@ ...@@ -343,15 +371,40 @@
t) t)
;; rplaca on a fixnum is a type error ;; rplaca on a fixnum is a type error
(deftest rplaca-error-1 (deftest rplaca.error.1
(loop for x in *universe* (loop for x in *universe*
thereis (and (not (consp x)) thereis (and (not (consp x))
(not (eq (catch-type-error (rplaca x 1)) 'type-error)))) (not (eq (catch-type-error (rplaca x 1)) 'type-error))))
nil) nil)
(deftest rplaca.error.2
(classify-error (rplaca))
program-error)
(deftest rplaca.error.3
(classify-error (rplaca (cons 'a 'b)))
program-error)
(deftest rplaca.error.4
(classify-error (rplaca (cons 'a 'b) (cons 'c 'd) 'garbage))
program-error)
;; rplacd on a fixnum is a type error ;; rplacd on a fixnum is a type error
(deftest rplacd-error-1 (deftest rplacd.error.1
(loop for x in *universe* (loop for x in *universe*
thereis (and (not (consp x)) thereis (and (not (consp x))
(not (eq (catch-type-error (rplacd x 1)) 'type-error)))) (not (eq (catch-type-error (rplacd x 1)) 'type-error))))
nil) nil)
(deftest rplacd.error.2
(classify-error (rplacd))
program-error)
(deftest rplacd.error.3
(classify-error (rplacd (cons 'a 'b)))
program-error)
(deftest rplacd.error.4
(classify-error (rplacd (cons 'a 'b) (cons 'c 'd) 'garbage))
program-error)
...@@ -29,6 +29,14 @@ ...@@ -29,6 +29,14 @@
(check-cons-copy x y))) (check-cons-copy x y)))
t) t)
(deftest copy-tree.error.1
(classify-error (copy-tree))
program-error)
(deftest copy-tree.error.2
(classify-error (copy-tree 'a 'b))
program-error)
(deftest sublis-1 (deftest sublis-1
(check-sublis '((a b) g (d e 10 g h) 15 . g)