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

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

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

File size: 7.8 KB
Line 
1;-*- Mode:     Lisp -*-
2;;;; Author:   Paul Dietz
3;;;; Created:  Thu Mar 19 21:48:39 1998
4;;;; Contains: Data for testing type and class inclusions
5
6;; We should check for every type that NIL is a subtype, and T a supertype
7
8(in-package :cl-test)
9
10(compile-and-load "types-aux.lsp")
11
12(declaim (optimize (safety 3)))
13
14(deftest boolean-type.1
15  (notnot-mv (typep nil 'boolean))
16  t)
17
18(deftest boolean-type.2
19  (notnot-mv (typep t 'boolean))
20  t)
21
22(deftest boolean-type.3
23  (check-type-predicate 'is-t-or-nil 'boolean)
24  nil)
25
26(deftest types.3
27  (loop
28   for (t1 t2) in *subtype-table*
29   for m1 = (check-subtypep t1 t2 t t)
30   for m2 = (check-subtypep `(and ,t1 ,t2) t1 t)
31   for m3 = (check-subtypep `(and ,t2 ,t1) t1 t)
32   for m4 = (check-subtypep `(and ,t1 (not ,t2)) nil t)
33   for m5 = (check-subtypep `(and (not ,t2) ,t1) nil t)
34   when m1 collect m1
35   when m2 collect m2
36   when m3 collect m3
37   when m4 collect m4
38   when m5 collect m5)
39  nil)
40
41(declaim (special +float-types+ *subtype-table*))
42
43;;; This next test is all screwed up.  Basically, it assumes
44;;; incorrectly that certain subtype relationships that are
45;;; not specified in the spec cannot occur.
46#|
47(defun types.4-body ()
48  (let ((parent-table (make-hash-table :test #'equal))
49        (types nil))
50    (loop
51        for p in *subtype-table* do
52          (let ((tp (first p))
53                (parent (second p)))
54            (pushnew tp types)
55            (pushnew parent types)
56            (let ((parents (gethash tp parent-table)))
57              (pushnew parent parents)
58              ;; (format t "~S ==> ~S~%" tp parent)
59              (loop
60                  for pp in (gethash parent parent-table) do
61                    ;; (format t "~S ==> ~S~%" tp pp)
62                    (pushnew pp parents))
63              (setf (gethash tp parent-table) parents))))
64    ;; parent-table now contains lists of ancestors
65    (loop
66        for tp in types sum
67          (let ((parents (gethash tp parent-table)))
68            (loop
69                for tp2 in types sum
70                  (cond
71                   ((and (not (eqt tp tp2))
72                         (not (eqt tp2 'standard-object))
73                         (not (eqt tp2 'structure-object))
74                         (not (member tp2 parents))
75                         (subtypep* tp tp2)
76                         (not (and (member tp +float-types+)
77                                   (member tp2 +float-types+)))
78                         (not (and (eqt tp2 'structure-object)
79                                   (member 'standard-object parents))))
80                    (format t "~%Improper subtype: ~S of ~S"
81                            tp tp2)
82                    1)
83                   (t 0)))))
84    ))
85
86(deftest types.4
87  (types.4-body)
88  0)
89|#
90
91(deftest types.6
92  (types.6-body)
93  nil)
94
95(declaim (special *disjoint-types-list*))
96
97;;; Check that the disjoint types really are disjoint
98
99(deftest types.7b
100  (loop for e on *disjoint-types-list*
101        for tp1 = (first e)
102        append
103        (loop for tp2 in (rest e)
104              append (classes-are-disjoint tp1 tp2)))
105  nil)
106
107(deftest types.7c
108  (loop for e on *disjoint-types-list2*
109        for list1 = (first e)
110        append
111        (loop for tp1 in list1 append
112              (loop for list2 in (rest e)
113                    append
114                    (loop for tp2 in list2 append
115                          (classes-are-disjoint tp1 tp2)))))
116  nil)
117
118(deftest types.8
119  (loop
120   for tp in *disjoint-types-list* count
121   (cond
122    ((and (not (eqt tp 'cons))
123          (not (subtypep* tp 'atom)))
124     (format t "~%Should be atomic, but isn't: ~S" tp)
125     t)))
126  0)
127
128(declaim (special *type-list* *supertype-table*))
129
130;;;
131;;; TYPES.9 checks the transitivity of SUBTYPEP on pairs of types
132;;; occuring in *SUBTYPE-TABLE*, as well as the types KEYWORD, ATOM,
133;;; and LIST (the relationships given in *SUBTYPE-TABLE* are not used
134;;; here.)
135;;;
136
137(deftest types.9
138  (types.9-body)
139  nil)
140
141;;;
142;;; TYPES.9A takes the supertype relationship computed by test TYPE.9
143;;; and checks that TYPEP respects it for all elements of *UNIVERSE*.
144;;; That is, if T1 and T2 are two types, and X is an element of *UNIVERSE*,
145;;; then if (SUBTYPEP T1) then (TYPEP X T1) implies (TYPEP X T2).
146;;;
147;;; The function prints error messages when this fails, and returns the
148;;; number of occurences of failure.
149;;;
150;;; Test TYPES.9 must be run before this test.
151;;;
152
153(deftest types.9a
154  (types.9a-body)
155  0)
156
157
158;;; All class names in CL denote classes that are subtypep
159;;; equivalent to themselves
160(deftest all-classes-are-type-equivalent-to-their-names
161  (loop for sym being  the external-symbols of "COMMON-LISP"
162       for class = (find-class sym nil)
163       when class
164       append (check-equivalence sym class))
165  nil)
166
167(deftest all-classes-are-type-equivalent-to-their-names.2
168  (loop for x in *universe*
169        for cl = (class-of x)
170        for name = (class-name cl)
171        when name
172        append (check-equivalence name cl))
173  nil)
174
175;;; Check that all class names in CL that name standard-classes or
176;;; structure-classes are subtypes of standard-object and structure-object,
177;;; respectively
178
179(deftest all-standard-classes-are-subtypes-of-standard-object
180  (loop for sym being  the external-symbols of "COMMON-LISP"
181        for class = (find-class sym nil)
182        when (and class
183                  (typep class 'standard-class)
184                  (or (not (subtypep sym 'standard-object))
185                      (not (subtypep class 'standard-object))))
186        collect sym)
187  nil)
188
189(deftest all-standard-classes-are-subtypes-of-standard-object.2
190  (loop for x in *universe*
191        for class = (class-of x)
192        when (and (typep class 'standard-class)
193                  (not (subtypep class 'standard-object)))
194        collect x)
195  nil)
196
197(deftest all-structure-classes-are-subtypes-of-structure-object
198  (loop for sym being the external-symbols of "COMMON-LISP"
199        for class = (find-class sym nil)
200        when (and class
201                  (typep class 'structure-class)
202                  (or (not (subtypep sym 'structure-object))
203                      (not (subtypep class 'structure-object))))
204        collect sym)
205  nil)
206
207(deftest all-structure-classes-are-subtypes-of-structure-object.2
208  (loop for x in *universe*
209        for cl = (class-of x)
210        when (and (typep cl 'structure-class)
211                  (not (subtypep cl 'structure-object)))
212        collect x)
213  nil)
214                 
215;;; Confirm that only the symbols exported from CL that are supposed
216;;; to be types are actually classes (see section 11.1.2.1.1)
217
218(deftest all-exported-cl-class-names-are-valid
219  (loop for sym being the external-symbols of "COMMON-LISP"
220        when (and (find-class sym nil)
221                  (not (member sym *cl-all-type-symbols* :test #'eq)))
222        collect sym)
223  nil)
224
225;;; Confirm that all standard generic functions are instances of
226;;; the class standard-generic-function.
227
228(deftest all-standard-generic-functions-are-instances-of-that-class
229  (loop for sym in *cl-standard-generic-function-symbols*
230        for fun = (and (fboundp sym) (symbol-function sym))
231        unless (and (typep fun 'generic-function)
232                    (typep fun 'standard-generic-function))
233        collect (list sym fun))
234  nil)
235
236;;; Canonical metaobjects are in the right classes
237
238(deftest structure-object-is-in-structure-class
239  (notnot-mv (typep (find-class 'structure-object) 'structure-class))
240  t)
241
242(deftest standard-object-is-in-standard-class
243  (notnot-mv (typep (find-class 'standard-object) 'standard-class))
244  t)
245
246
247;; This should be greatly expanded
248
249(defparameter *type-and-class-fns*
250  '(coerce subtypep type-of typep type-error-datum type-error-expected-type))
251
252(deftest type-and-class-fns
253  (remove-if #'fboundp *type-and-class-fns*)
254  nil)
255
256(deftest type-and-class-macros
257  (notnot-mv (macro-function 'deftype))
258  t)
259
260;;; TYPE-ERROR accessors
261
262(deftest type-error-datum.1
263  (let ((c (make-condition 'type-error :datum 'a :expected-type 'integer)))
264    (type-error-datum c))
265  a)
266
267(deftest type-error-expected-type.1
268  (let ((c (make-condition 'type-error
269                           :datum 'a :expected-type 'integer)))
270    (type-error-expected-type c))
271  integer)
272
273;;; Error checking of type-related functions
274
275(deftest type-error-datum.error.1
276  (signals-error (type-error-datum) program-error)
277  t)
278
279(deftest type-error-datum.error.2
280  (signals-error
281   (let ((c (make-condition 'type-error :datum nil
282                            :expected-type t)))
283     (type-error-datum c nil))
284   program-error)
285  t)
286
287(deftest type-error-expected-type.error.1
288  (signals-error (type-error-expected-type)
289                 program-error)
290  t)
291
292(deftest type-error-expected-type.error.2
293  (signals-error
294   (let ((c (make-condition 'type-error :datum nil
295                            :expected-type t)))
296     (type-error-expected-type c nil))
297   program-error)
298  t)
299
Note: See TracBrowser for help on using the repository browser.