From cc5aac3f7d005ed8749f807eb1fc767ad74af40e Mon Sep 17 00:00:00 2001 From: pfdietz <pfdietz@localhost> Date: Tue, 5 Nov 2002 12:44:24 +0000 Subject: [PATCH] Added comments to some TYPES tests explaining what they do, and made the diagnostic outputs more understandable. --- ansi-tests/types-and-class.lsp | 50 +++++++++++++++++++++++++++------- 1 file changed, 40 insertions(+), 10 deletions(-) diff --git a/ansi-tests/types-and-class.lsp b/ansi-tests/types-and-class.lsp index f7105eb9..87dd79ac 100644 --- a/ansi-tests/types-and-class.lsp +++ b/ansi-tests/types-and-class.lsp @@ -157,7 +157,7 @@ (t2 (second pair))) (cond ((not (subtypep* t1 t2)) - (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) t) (t nil)))) *subtype-table*) @@ -226,7 +226,7 @@ (cond ((and (not (member tp '(sequence cons list t))) (not (subtypep* tp 'atom))) - (format t "~%Not an atomic type: ~S" tp) + (format t "~%Problem! Did not find to be an atomic type: ~S" tp) t))))) (deftest types-6 @@ -259,12 +259,24 @@ (defvar *type-list* nil) (defvar *supertype-table* nil) +;;; +;;; TYPES-9 checks the transitivity of SUBTYPEP on pairs of types +;;; occuring in *SUBTYPE-TABLE*, as well as the types KEYWORD, ATOM, +;;; and LIST (the relationships given in *SUBTYPE-TABLE* are not used +;;; here.) +;;; + (defun types-9-body () (let ((tp-list (append '(keyword atom list) (loop for p in *subtype-table* collect (car p)))) (result-list)) (setf tp-list (remove-duplicates tp-list)) + ;; TP-LIST is now a list of unique CL type names + ;; Store it in *TYPE-LIST* so we can inspect it later if this test + ;; fails. The variable is also used in test TYPES-9A (setf *type-list* tp-list) + ;; Compute all pairwise SUBTYPEP relationships among + ;; the elements of *TYPE-LIST*. (let ((subs (make-hash-table :test #'eq)) (sups (make-hash-table :test #'eq))) (loop @@ -277,7 +289,11 @@ (when result (pushnew x (gethash y subs)) (pushnew y (gethash x sups)))))) + ;; Store the supertype relations for later inspection + ;; and use in test TYPES-9A (setf *supertype-table* sups) + ;; Check that the relation we just computed is transitive. + ;; Return a list of triples on which transitivity fails. (loop for x in tp-list do (let ((sub-list (gethash x subs)) @@ -294,10 +310,25 @@ result-list))) +;;; TYPES-9-BODY returns a list of triples (T1 T2 T3) +;;; where (AND (SUBTYPEP T1 T2) (SUBTYPEP T2 T3) (NOT (SUBTYPEP T1 T3))) +;;; (and where SUBTYPEP succeeds in each case, returning true as its +;;; second return value.) (deftest types-9 (types-9-body) nil) +;;; +;;; TYPES-9A takes the supertype relationship computed by test TYPE-9 +;;; and checks that TYPEP respects it for all elements of *UNIVERSE*. +;;; That is, if T1 and T2 are two types, and X is an element of *UNIVERSE*, +;;; then if (SUBTYPEP T1) then (TYPEP X T1) implies (TYPEP X T2). +;;; +;;; The function prints error messages when this fails, and returns the +;;; number of occurences of failure. +;;; +;;; Test TYPES-9 must be run before this test. +;;; (defun types-9a-body () (cond ((not (and *type-list* *supertype-table*)) @@ -321,7 +352,7 @@ (handler-case (and (not (typep x tp2)) (progn - (format t "Found element of ~S not in ~S ~S~%" + (format t "Found element of ~S not in ~S: ~S~%" tp tp2 x) t)) (condition (c) (format t "Error ~S occured: ~S~%" @@ -354,26 +385,25 @@ nil) (deftest deftype-3 - (not (not (typep (make-array '(10)) '(even-array t (*))))) + (notnot (typep (make-array '(10)) '(even-array t (*)))) t) (deftest deftype-4 - (typep (make-array '(5)) '(even-array t (*))) + (typep (make-array '(5)) '(even-array t (*))) nil) (deftest deftype-5 - (not (not (typep (make-string 10) '(even-array character (*))))) + (notnot (typep (make-string 10) '(even-array character (*)))) t) (deftest deftype-6 - (not (not - (typep (make-array '(3 5 6) :element-type '(unsigned-byte 8)) - '(even-array (unsigned-byte 8))))) + (notnot + (typep (make-array '(3 5 6) :element-type '(unsigned-byte 8)) + '(even-array (unsigned-byte 8)))) t) ;; This should be greatly expanded - (defparameter *type-and-class-fns* '(coerce subtypep type-of typep type-error-datum type-error-expected-type)) -- GitLab