10 |
|
|
11 |
(declaim (optimize (safety 3))) |
(declaim (optimize (safety 3))) |
12 |
|
|
13 |
(deftest boolean-type-1 |
(deftest boolean-type.1 |
14 |
(notnot-mv (typep nil 'boolean)) |
(notnot-mv (typep nil 'boolean)) |
15 |
t) |
t) |
16 |
|
|
17 |
(deftest boolean-type-2 |
(deftest boolean-type.2 |
18 |
(notnot-mv (typep t 'boolean)) |
(notnot-mv (typep t 'boolean)) |
19 |
t) |
t) |
20 |
|
|
21 |
(deftest boolean-type-3 |
(deftest boolean-type.3 |
22 |
(check-type-predicate 'is-t-or-nil 'boolean) |
(check-type-predicate 'is-t-or-nil 'boolean) |
23 |
0) |
0) |
24 |
|
|
30 |
|
|
31 |
|
|
32 |
|
|
33 |
(deftest types-3 |
(deftest types.3 |
34 |
(loop |
(loop |
35 |
for (t1 t2) in *subtype-table* |
for (t1 t2) in *subtype-table* |
36 |
for m1 = (check-subtypep t1 t2 t t) |
for m1 = (check-subtypep t1 t2 t t) |
51 |
;;; incorrectly that certain subtype relationships that are |
;;; incorrectly that certain subtype relationships that are |
52 |
;;; not specified in the spec cannot occur. |
;;; not specified in the spec cannot occur. |
53 |
#| |
#| |
54 |
(defun types-4-body () |
(defun types.4-body () |
55 |
(let ((parent-table (make-hash-table :test #'equal)) |
(let ((parent-table (make-hash-table :test #'equal)) |
56 |
(types nil)) |
(types nil)) |
57 |
(loop |
(loop |
90 |
(t 0))))) |
(t 0))))) |
91 |
)) |
)) |
92 |
|
|
93 |
(deftest types-4 |
(deftest types.4 |
94 |
(types-4-body) |
(types.4-body) |
95 |
0) |
0) |
96 |
|# |
|# |
97 |
|
|
98 |
(deftest types-6 |
(deftest types.6 |
99 |
(types-6-body) |
(types.6-body) |
100 |
nil) |
nil) |
101 |
|
|
102 |
(declaim (special *disjoint-types-list*)) |
(declaim (special *disjoint-types-list*)) |
103 |
|
|
104 |
;;; Check that the disjoint types really are disjoint |
;;; Check that the disjoint types really are disjoint |
105 |
|
|
106 |
(deftest types-7b |
(deftest types.7b |
107 |
(loop for e on *disjoint-types-list* |
(loop for e on *disjoint-types-list* |
108 |
for tp1 = (first e) |
for tp1 = (first e) |
109 |
append |
append |
111 |
append (classes-are-disjoint tp1 tp2))) |
append (classes-are-disjoint tp1 tp2))) |
112 |
nil) |
nil) |
113 |
|
|
114 |
(deftest types-7c |
(deftest types.7c |
115 |
(loop for e on *disjoint-types-list2* |
(loop for e on *disjoint-types-list2* |
116 |
for list1 = (first e) |
for list1 = (first e) |
117 |
append |
append |
122 |
(classes-are-disjoint tp1 tp2))))) |
(classes-are-disjoint tp1 tp2))))) |
123 |
nil) |
nil) |
124 |
|
|
125 |
(deftest types-8 |
(deftest types.8 |
126 |
(loop |
(loop |
127 |
for tp in *disjoint-types-list* count |
for tp in *disjoint-types-list* count |
128 |
(cond |
(cond |
135 |
(declaim (special *type-list* *supertype-table*)) |
(declaim (special *type-list* *supertype-table*)) |
136 |
|
|
137 |
;;; |
;;; |
138 |
;;; TYPES-9 checks the transitivity of SUBTYPEP on pairs of types |
;;; TYPES.9 checks the transitivity of SUBTYPEP on pairs of types |
139 |
;;; occuring in *SUBTYPE-TABLE*, as well as the types KEYWORD, ATOM, |
;;; occuring in *SUBTYPE-TABLE*, as well as the types KEYWORD, ATOM, |
140 |
;;; and LIST (the relationships given in *SUBTYPE-TABLE* are not used |
;;; and LIST (the relationships given in *SUBTYPE-TABLE* are not used |
141 |
;;; here.) |
;;; here.) |
142 |
;;; |
;;; |
143 |
|
|
144 |
(deftest types-9 |
(deftest types.9 |
145 |
(types-9-body) |
(types.9-body) |
146 |
nil) |
nil) |
147 |
|
|
148 |
;;; |
;;; |
149 |
;;; TYPES-9A takes the supertype relationship computed by test TYPE-9 |
;;; TYPES.9A takes the supertype relationship computed by test TYPE.9 |
150 |
;;; and checks that TYPEP respects it for all elements of *UNIVERSE*. |
;;; and checks that TYPEP respects it for all elements of *UNIVERSE*. |
151 |
;;; That is, if T1 and T2 are two types, and X is an element of *UNIVERSE*, |
;;; That is, if T1 and T2 are two types, and X is an element of *UNIVERSE*, |
152 |
;;; then if (SUBTYPEP T1) then (TYPEP X T1) implies (TYPEP X T2). |
;;; then if (SUBTYPEP T1) then (TYPEP X T1) implies (TYPEP X T2). |
154 |
;;; The function prints error messages when this fails, and returns the |
;;; The function prints error messages when this fails, and returns the |
155 |
;;; number of occurences of failure. |
;;; number of occurences of failure. |
156 |
;;; |
;;; |
157 |
;;; Test TYPES-9 must be run before this test. |
;;; Test TYPES.9 must be run before this test. |
158 |
;;; |
;;; |
159 |
|
|
160 |
(deftest types-9a |
(deftest types.9a |
161 |
(types-9a-body) |
(types.9a-body) |
162 |
0) |
0) |
163 |
|
|
164 |
|
|
227 |
`(and (array ,type ,size) |
`(and (array ,type ,size) |
228 |
(satisfies even-size-p))) |
(satisfies even-size-p))) |
229 |
|
|
230 |
(deftest deftype-1 |
(deftest deftype.1 |
231 |
(typep 1 '(even-array integer (10))) |
(typep 1 '(even-array integer (10))) |
232 |
nil) |
nil) |
233 |
|
|
234 |
(deftest deftype-2 |
(deftest deftype.2 |
235 |
(typep nil '(even-array t (*))) |
(typep nil '(even-array t (*))) |
236 |
nil) |
nil) |
237 |
|
|
238 |
(deftest deftype-3 |
(deftest deftype.3 |
239 |
(notnot-mv (typep (make-array '(10)) '(even-array t (*)))) |
(notnot-mv (typep (make-array '(10)) '(even-array t (*)))) |
240 |
t) |
t) |
241 |
|
|
242 |
(deftest deftype-4 |
(deftest deftype.4 |
243 |
(typep (make-array '(5)) '(even-array t (*))) |
(typep (make-array '(5)) '(even-array t (*))) |
244 |
nil) |
nil) |
245 |
|
|
246 |
(deftest deftype-5 |
(deftest deftype.5 |
247 |
(notnot-mv (typep (make-string 10) '(even-array character (*)))) |
(notnot-mv (typep (make-string 10) '(even-array character (*)))) |
248 |
t) |
t) |
249 |
|
|
250 |
(deftest deftype-6 |
(deftest deftype.6 |
251 |
(notnot-mv |
(notnot-mv |
252 |
(typep (make-array '(3 5 6) :element-type '(unsigned-byte 8)) |
(typep (make-array '(3 5 6) :element-type '(unsigned-byte 8)) |
253 |
'(even-array (unsigned-byte 8)))) |
'(even-array (unsigned-byte 8)))) |