157 |
(t2 (second pair))) |
(t2 (second pair))) |
158 |
(cond |
(cond |
159 |
((not (subtypep* t1 t2)) |
((not (subtypep* t1 t2)) |
160 |
(format t "~%~S not a subtype of ~S" t1 t2) |
(format t "~%Problem! Did not find ~S to be a subtype of ~S" t1 t2) |
161 |
t) |
t) |
162 |
(t nil)))) |
(t nil)))) |
163 |
*subtype-table*) |
*subtype-table*) |
226 |
(cond |
(cond |
227 |
((and (not (member tp '(sequence cons list t))) |
((and (not (member tp '(sequence cons list t))) |
228 |
(not (subtypep* tp 'atom))) |
(not (subtypep* tp 'atom))) |
229 |
(format t "~%Not an atomic type: ~S" tp) |
(format t "~%Problem! Did not find to be an atomic type: ~S" tp) |
230 |
t))))) |
t))))) |
231 |
|
|
232 |
(deftest types-6 |
(deftest types-6 |
259 |
(defvar *type-list* nil) |
(defvar *type-list* nil) |
260 |
(defvar *supertype-table* nil) |
(defvar *supertype-table* nil) |
261 |
|
|
262 |
|
;;; |
263 |
|
;;; TYPES-9 checks the transitivity of SUBTYPEP on pairs of types |
264 |
|
;;; occuring in *SUBTYPE-TABLE*, as well as the types KEYWORD, ATOM, |
265 |
|
;;; and LIST (the relationships given in *SUBTYPE-TABLE* are not used |
266 |
|
;;; here.) |
267 |
|
;;; |
268 |
|
|
269 |
(defun types-9-body () |
(defun types-9-body () |
270 |
(let ((tp-list (append '(keyword atom list) |
(let ((tp-list (append '(keyword atom list) |
271 |
(loop for p in *subtype-table* collect (car p)))) |
(loop for p in *subtype-table* collect (car p)))) |
272 |
(result-list)) |
(result-list)) |
273 |
(setf tp-list (remove-duplicates tp-list)) |
(setf tp-list (remove-duplicates tp-list)) |
274 |
|
;; TP-LIST is now a list of unique CL type names |
275 |
|
;; Store it in *TYPE-LIST* so we can inspect it later if this test |
276 |
|
;; fails. The variable is also used in test TYPES-9A |
277 |
(setf *type-list* tp-list) |
(setf *type-list* tp-list) |
278 |
|
;; Compute all pairwise SUBTYPEP relationships among |
279 |
|
;; the elements of *TYPE-LIST*. |
280 |
(let ((subs (make-hash-table :test #'eq)) |
(let ((subs (make-hash-table :test #'eq)) |
281 |
(sups (make-hash-table :test #'eq))) |
(sups (make-hash-table :test #'eq))) |
282 |
(loop |
(loop |
289 |
(when result |
(when result |
290 |
(pushnew x (gethash y subs)) |
(pushnew x (gethash y subs)) |
291 |
(pushnew y (gethash x sups)))))) |
(pushnew y (gethash x sups)))))) |
292 |
|
;; Store the supertype relations for later inspection |
293 |
|
;; and use in test TYPES-9A |
294 |
(setf *supertype-table* sups) |
(setf *supertype-table* sups) |
295 |
|
;; Check that the relation we just computed is transitive. |
296 |
|
;; Return a list of triples on which transitivity fails. |
297 |
(loop |
(loop |
298 |
for x in tp-list do |
for x in tp-list do |
299 |
(let ((sub-list (gethash x subs)) |
(let ((sub-list (gethash x subs)) |
310 |
|
|
311 |
result-list))) |
result-list))) |
312 |
|
|
313 |
|
;;; TYPES-9-BODY returns a list of triples (T1 T2 T3) |
314 |
|
;;; where (AND (SUBTYPEP T1 T2) (SUBTYPEP T2 T3) (NOT (SUBTYPEP T1 T3))) |
315 |
|
;;; (and where SUBTYPEP succeeds in each case, returning true as its |
316 |
|
;;; second return value.) |
317 |
(deftest types-9 |
(deftest types-9 |
318 |
(types-9-body) |
(types-9-body) |
319 |
nil) |
nil) |
320 |
|
|
321 |
|
;;; |
322 |
|
;;; TYPES-9A takes the supertype relationship computed by test TYPE-9 |
323 |
|
;;; and checks that TYPEP respects it for all elements of *UNIVERSE*. |
324 |
|
;;; That is, if T1 and T2 are two types, and X is an element of *UNIVERSE*, |
325 |
|
;;; then if (SUBTYPEP T1) then (TYPEP X T1) implies (TYPEP X T2). |
326 |
|
;;; |
327 |
|
;;; The function prints error messages when this fails, and returns the |
328 |
|
;;; number of occurences of failure. |
329 |
|
;;; |
330 |
|
;;; Test TYPES-9 must be run before this test. |
331 |
|
;;; |
332 |
(defun types-9a-body () |
(defun types-9a-body () |
333 |
(cond |
(cond |
334 |
((not (and *type-list* *supertype-table*)) |
((not (and *type-list* *supertype-table*)) |
352 |
(handler-case |
(handler-case |
353 |
(and (not (typep x tp2)) |
(and (not (typep x tp2)) |
354 |
(progn |
(progn |
355 |
(format t "Found element of ~S not in ~S ~S~%" |
(format t "Found element of ~S not in ~S: ~S~%" |
356 |
tp tp2 x) |
tp tp2 x) |
357 |
t)) |
t)) |
358 |
(condition (c) (format t "Error ~S occured: ~S~%" |
(condition (c) (format t "Error ~S occured: ~S~%" |
385 |
nil) |
nil) |
386 |
|
|
387 |
(deftest deftype-3 |
(deftest deftype-3 |
388 |
(not (not (typep (make-array '(10)) '(even-array t (*))))) |
(notnot (typep (make-array '(10)) '(even-array t (*)))) |
389 |
t) |
t) |
390 |
|
|
391 |
(deftest deftype-4 |
(deftest deftype-4 |
392 |
(typep (make-array '(5)) '(even-array t (*))) |
(typep (make-array '(5)) '(even-array t (*))) |
393 |
nil) |
nil) |
394 |
|
|
395 |
(deftest deftype-5 |
(deftest deftype-5 |
396 |
(not (not (typep (make-string 10) '(even-array character (*))))) |
(notnot (typep (make-string 10) '(even-array character (*)))) |
397 |
t) |
t) |
398 |
|
|
399 |
(deftest deftype-6 |
(deftest deftype-6 |
400 |
(not (not |
(notnot |
401 |
(typep (make-array '(3 5 6) :element-type '(unsigned-byte 8)) |
(typep (make-array '(3 5 6) :element-type '(unsigned-byte 8)) |
402 |
'(even-array (unsigned-byte 8))))) |
'(even-array (unsigned-byte 8)))) |
403 |
t) |
t) |
404 |
|
|
405 |
;; This should be greatly expanded |
;; This should be greatly expanded |
406 |
|
|
|
|
|
407 |
(defparameter *type-and-class-fns* |
(defparameter *type-and-class-fns* |
408 |
'(coerce subtypep type-of typep type-error-datum type-error-expected-type)) |
'(coerce subtypep type-of typep type-error-datum type-error-expected-type)) |
409 |
|
|