source: trunk/source/tests/ansi-tests/types-aux.lsp @ 8991

Last change on this file since 8991 was 8991, checked in by gz, 11 years ago

Check in the gcl ansi test suite (original, in preparation for making local changes)

File size: 6.0 KB
Line 
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)))
Note: See TracBrowser for help on using the repository browser.