1 | ;-*- Mode: Lisp -*- |
---|
2 | ;;;; Author: Paul Dietz |
---|
3 | ;;;; Created: Mon Jun 21 20:14:38 2004 |
---|
4 | ;;;; Contains: Aux. functions for types tests |
---|
5 | |
---|
6 | (in-package :cl-test) |
---|
7 | |
---|
8 | (defun classes-are-disjoint (c1 c2) |
---|
9 | "If either c1 or c2 is a builtin class or the name of a builtin |
---|
10 | class, then check for disjointness. Return a non-NIL list |
---|
11 | of failed subtypep relationships, if any." |
---|
12 | (and (or (is-builtin-class c1) |
---|
13 | (is-builtin-class c2)) |
---|
14 | (check-disjointness c1 c2))) |
---|
15 | |
---|
16 | (declaim (special *subtype-table*)) |
---|
17 | |
---|
18 | (defun types.6-body () |
---|
19 | (loop |
---|
20 | for p in *subtype-table* |
---|
21 | for tp = (car p) |
---|
22 | append |
---|
23 | (and (not (member tp '(sequence cons list t))) |
---|
24 | (let ((message (check-subtypep tp 'atom t t))) |
---|
25 | (if message (list message)))))) |
---|
26 | |
---|
27 | (defparameter *type-list* nil) |
---|
28 | (defparameter *supertype-table* nil) |
---|
29 | |
---|
30 | (defun types.9-body () |
---|
31 | (let ((tp-list (append '(keyword atom list) |
---|
32 | (loop for p in *subtype-table* collect (car p)))) |
---|
33 | (result-list)) |
---|
34 | (setf tp-list (remove-duplicates tp-list)) |
---|
35 | ;; TP-LIST is now a list of unique CL type names |
---|
36 | ;; Store it in *TYPE-LIST* so we can inspect it later if this test |
---|
37 | ;; fails. The variable is also used in test TYPES.9A |
---|
38 | (setf *type-list* tp-list) |
---|
39 | ;; Compute all pairwise SUBTYPEP relationships among |
---|
40 | ;; the elements of *TYPE-LIST*. |
---|
41 | (let ((subs (make-hash-table :test #'eq)) |
---|
42 | (sups (make-hash-table :test #'eq))) |
---|
43 | (loop |
---|
44 | for x in tp-list do |
---|
45 | (loop |
---|
46 | for y in tp-list do |
---|
47 | (multiple-value-bind (result good) |
---|
48 | (subtypep* x y) |
---|
49 | (declare (ignore good)) |
---|
50 | (when result |
---|
51 | (pushnew x (gethash y subs)) |
---|
52 | (pushnew y (gethash x sups)))))) |
---|
53 | ;; Store the supertype relations for later inspection |
---|
54 | ;; and use in test TYPES.9A |
---|
55 | (setf *supertype-table* sups) |
---|
56 | ;; Check that the relation we just computed is transitive. |
---|
57 | ;; Return a list of triples on which transitivity fails. |
---|
58 | (loop |
---|
59 | for x in tp-list do |
---|
60 | (let ((sub-list (gethash x subs)) |
---|
61 | (sup-list (gethash x sups))) |
---|
62 | (loop |
---|
63 | for t1 in sub-list do |
---|
64 | (loop |
---|
65 | for t2 in sup-list do |
---|
66 | (multiple-value-bind (result good) |
---|
67 | (subtypep* t1 t2) |
---|
68 | (when (and good (not result)) |
---|
69 | (pushnew (list t1 x t2) result-list |
---|
70 | :test #'equal))))))) |
---|
71 | |
---|
72 | result-list))) |
---|
73 | |
---|
74 | ;;; TYPES.9-BODY returns a list of triples (T1 T2 T3) |
---|
75 | ;;; where (AND (SUBTYPEP T1 T2) (SUBTYPEP T2 T3) (NOT (SUBTYPEP T1 T3))) |
---|
76 | ;;; (and where SUBTYPEP succeeds in each case, returning true as its |
---|
77 | ;;; second return value.) |
---|
78 | |
---|
79 | (defun types.9a-body () |
---|
80 | (cond |
---|
81 | ((not (and *type-list* *supertype-table*)) |
---|
82 | (format nil "Run test type.9 first~%") |
---|
83 | nil) |
---|
84 | (t |
---|
85 | (loop |
---|
86 | for tp in *type-list* |
---|
87 | sum |
---|
88 | (let ((sups (gethash tp *supertype-table*))) |
---|
89 | (loop |
---|
90 | for x in *universe* |
---|
91 | sum |
---|
92 | (handler-case |
---|
93 | (cond |
---|
94 | ((not (typep x tp)) 0) |
---|
95 | (t |
---|
96 | (loop |
---|
97 | for tp2 in sups |
---|
98 | count |
---|
99 | (handler-case |
---|
100 | (and (not (typep x tp2)) |
---|
101 | (progn |
---|
102 | (format t "Found element of ~S not in ~S: ~S~%" |
---|
103 | tp tp2 x) |
---|
104 | t)) |
---|
105 | (condition (c) (format t "Error ~S occured: ~S~%" |
---|
106 | c tp2) |
---|
107 | t))))) |
---|
108 | (condition (c) (format t "Error ~S occured: ~S~%" c tp) |
---|
109 | 1)))))))) |
---|
110 | |
---|
111 | (defun check-subtypep (type1 type2 is-sub &optional should-be-valid) |
---|
112 | (multiple-value-bind |
---|
113 | (sub valid) |
---|
114 | (subtypep type1 type2) |
---|
115 | (unless (constantp type1) (setq type1 (list 'quote type1))) |
---|
116 | (unless (constantp type2) (setq type2 (list 'quote type2))) |
---|
117 | (if (or (and valid sub (not is-sub)) |
---|
118 | (and valid (not sub) is-sub) |
---|
119 | (and (not valid) should-be-valid)) |
---|
120 | `(((SUBTYPEP ,type1 ,type2) :==> ,sub ,valid)) |
---|
121 | nil))) |
---|
122 | |
---|
123 | ;;; Check that the subtype relationships implied |
---|
124 | ;;; by disjointness are not contradicted. Return NIL |
---|
125 | ;;; if ok, or a list of error messages if not. |
---|
126 | |
---|
127 | ;;; Assumes the types are nonempty. |
---|
128 | |
---|
129 | (defun check-disjointness (type1 type2) |
---|
130 | (append |
---|
131 | (check-subtypep type1 type2 nil) |
---|
132 | (check-subtypep type2 type1 nil) |
---|
133 | (check-subtypep type1 `(not ,type2) t) |
---|
134 | (check-subtypep type2 `(not ,type1) t) |
---|
135 | (check-subtypep `(and ,type1 ,type2) nil t) |
---|
136 | (check-subtypep `(and ,type2 ,type1) nil t) |
---|
137 | (check-subtypep `(and ,type1 (not ,type2)) type1 t) |
---|
138 | (check-subtypep `(and (not ,type2) ,type1) type1 t) |
---|
139 | (check-subtypep `(and ,type2 (not ,type1)) type2 t) |
---|
140 | (check-subtypep `(and (not ,type1) ,type2) type2 t) |
---|
141 | ;;; (check-subtypep type1 `(or ,type1 (not ,type2)) t) |
---|
142 | ;;; (check-subtypep type1 `(or (not ,type2) ,type1) t) |
---|
143 | ;;; (check-subtypep type2 `(or ,type2 (not ,type1)) t) |
---|
144 | ;;; (check-subtypep type2 `(or (not ,type1) ,type2) t) |
---|
145 | (check-subtypep t `(or (not ,type1) (not ,type2)) t) |
---|
146 | (check-subtypep t `(or (not ,type2) (not ,type1)) t) |
---|
147 | )) |
---|
148 | |
---|
149 | (defun check-equivalence (type1 type2) |
---|
150 | (append |
---|
151 | (check-subtypep type1 type2 t) |
---|
152 | (check-subtypep type2 type1 t) |
---|
153 | (check-subtypep `(not ,type1) `(not ,type2) t) |
---|
154 | (check-subtypep `(not ,type2) `(not ,type1) t) |
---|
155 | (check-subtypep `(and ,type1 (not ,type2)) nil t) |
---|
156 | (check-subtypep `(and ,type2 (not ,type1)) nil t) |
---|
157 | (check-subtypep `(and (not ,type2) ,type1) nil t) |
---|
158 | (check-subtypep `(and (not ,type1) ,type2) nil t) |
---|
159 | (check-subtypep t `(or ,type1 (not ,type2)) t) |
---|
160 | (check-subtypep t `(or ,type2 (not ,type1)) t) |
---|
161 | (check-subtypep t `(or (not ,type2) ,type1) t) |
---|
162 | (check-subtypep t `(or (not ,type1) ,type2) t))) |
---|
163 | |
---|
164 | (defun check-all-subtypep (type1 type2) |
---|
165 | (append |
---|
166 | (check-subtypep type1 type2 t) |
---|
167 | (check-subtypep `(not ,type2) `(not ,type1) t) |
---|
168 | (check-subtypep `(and ,type1 (not ,type2)) nil t) |
---|
169 | (check-subtypep t `(or (not ,type1) ,type2) t))) |
---|
170 | |
---|
171 | (defun check-all-not-subtypep (type1 type2) |
---|
172 | (append |
---|
173 | (check-subtypep type1 type2 nil) |
---|
174 | (check-subtypep `(not ,type2) `(not ,type1) nil))) |
---|
175 | |
---|
176 | (defun subtypep-and-contrapositive-are-consistent (t1 t2) |
---|
177 | (multiple-value-bind (sub1 success1) |
---|
178 | (subtypep* t1 t2) |
---|
179 | (multiple-value-bind (sub2 success2) |
---|
180 | (subtypep* `(not ,t2) `(not ,t1)) |
---|
181 | (or (not success1) |
---|
182 | (not success2) |
---|
183 | (eqlt sub1 sub2))))) |
---|
184 | |
---|
185 | ;;; For use in deftype tests |
---|
186 | (deftype even-array (&optional type size) |
---|
187 | `(and (array ,type ,size) |
---|
188 | (satisfies even-size-p))) |
---|