source: trunk/source/tests/ansi-tests/subtypep.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: 4.8 KB
Line 
1;-*- Mode:     Lisp -*-
2;;;; Author:   Paul Dietz
3;;;; Created:  Wed Jan 29 17:28:19 2003
4;;;; Contains: Tests of SUBTYPEP
5
6(in-package :cl-test)
7
8(compile-and-load "types-aux.lsp")
9
10;;; More subtypep tests are in types-and-class.lsp
11
12(deftest subtypep.order.1
13  (let ((i 0) x y)
14    (values
15     (notnot (subtypep (progn (setf x (incf i)) t)
16                       (progn (setf y (incf i)) t)))
17     i x y))
18  t 2 1 2)
19
20(deftest simple-base-string-is-sequence
21    (subtypep* 'simple-base-string 'sequence)
22  t t)
23
24(deftest subtype.env.1
25  (mapcar #'notnot
26          (multiple-value-list (subtypep 'bit 'integer nil)))
27  (t t))
28
29(deftest subtype.env.2
30  (macrolet
31      ((%foo (&environment env)
32             (list 'quote
33                   (mapcar #'notnot
34                           (multiple-value-list
35                            (subtypep 'bit 'integer env))))))
36    (%foo))
37  (t t))
38
39(deftest subtype.env.3
40  (macrolet
41      ((%foo (&environment env)
42             (multiple-value-bind (sub good)
43                 (subtypep nil (type-of env))
44               (or (not good) (notnot sub)))))
45    (%foo))
46  t)
47
48(deftest subtype.env.4
49  (macrolet
50      ((%foo (&environment env)
51             (multiple-value-bind (sub good)
52                 (subtypep (type-of env) (type-of env))
53               (or (not good) (notnot sub)))))
54    (%foo))
55  t)
56
57(deftest subtype.env.5
58  (macrolet
59      ((%foo (&environment env)
60             (multiple-value-bind (sub good)
61                 (subtypep (type-of env) t)
62               (or (not good) (notnot sub)))))
63    (%foo))
64  t)
65
66(deftest subtypep.error.1
67  (signals-error (subtypep) program-error)
68  t)
69
70(deftest subtypep.error.2
71  (signals-error (subtypep t) program-error)
72  t)
73
74(deftest subtypep.error.3
75  (signals-error (subtypep t t nil nil) program-error)
76  t)
77
78;;; Special cases of types-6 that are/were causing problems in CMU CL
79
80(deftest keyword-is-subtype-of-atom
81  (subtypep* 'keyword 'atom)
82  t t)
83
84(deftest ratio-is-subtype-of-atom
85  (subtypep* 'ratio 'atom)
86  t t)
87
88(deftest extended-char-is-subtype-of-atom
89  (subtypep* 'extended-char 'atom)
90  t t)
91
92(deftest string-is-not-simple-vector
93  (subtypep* 'string 'simple-vector)
94  nil t)
95
96(deftest base-string-is-not-simple-vector
97  (subtypep* 'base-string 'simple-vector)
98  nil t)
99
100(deftest simple-string-is-not-simple-vector
101  (subtypep* 'simple-string 'simple-vector)
102  nil t)
103
104(deftest simple-base-string-is-not-simple-vector
105  (subtypep* 'simple-base-string 'simple-vector)
106  nil t)
107
108(deftest bit-vector-is-not-simple-vector
109  (subtypep* 'bit-vector 'simple-vector)
110  nil t)
111
112(deftest simple-bit-vector-is-not-simple-vector
113  (subtypep* 'simple-bit-vector 'simple-vector)
114  nil t)
115
116;;; Extended characters
117
118(deftest subtypep.extended-char.1
119  (if (subtypep* 'character 'base-char)
120      (subtypep* 'extended-char nil)
121    (values t t))
122  t t)
123
124(deftest subtypep.extended-char.2
125  (if (subtypep* 'extended-char nil)
126      (subtypep* 'character 'base-char)
127    (values t t))
128  t t)
129
130(deftest subtypep.extended-char.3
131  (check-equivalence 'extended-char '(and character (not base-char)))
132  nil)
133
134
135;;; Some and, or combinations
136
137(deftest subtypep.and/or.1
138  (check-equivalence
139   '(and (or symbol (integer 0 15))
140         (or symbol (integer 10 25)))
141   '(or symbol (integer 10 15)))
142  nil)
143
144(deftest subtypep.and/or.2
145  (check-equivalence
146   '(and (or (not symbol) (integer 0 10))
147         (or symbol (integer 11 25)))
148   '(integer 11 25))
149  nil)
150
151(deftest subtypep.and.1
152  (loop for type in *types-list3*
153        append (check-equivalence `(and ,type ,type) type))
154  nil)
155
156(deftest subtypep.or.1
157  (loop for type in *types-list3*
158        append (check-equivalence `(or ,type ,type) type))
159  nil)
160
161(deftest subtypep.and.2
162  (check-equivalence t '(and))
163  nil)
164
165(deftest subtypep.or.2
166  (check-equivalence nil '(or))
167  nil)
168
169(deftest subtypep.and.3
170  (loop for type in *types-list3*
171        append (check-equivalence `(and ,type) type))
172  nil)
173
174(deftest subtypep.or.3
175  (loop for type in *types-list3*
176        append (check-equivalence `(or ,type) type))
177  nil)
178
179(deftest subtypep.and.4
180  (let* ((n (length *types-list3*))
181         (a (make-array n :initial-contents *types-list3*)))
182    (trim-list
183     (loop for i below 1000
184           for tp1 = (aref a (random n))
185           for tp2 = (aref a (random n))
186           append (check-equivalence `(and ,tp1 ,tp2)
187                                     `(and ,tp2 ,tp1)))
188     100))
189  nil)
190
191(deftest subtypep.or.4
192  (let* ((n (length *types-list3*))
193         (a (make-array n :initial-contents *types-list3*)))
194    (trim-list
195     (loop for i below 1000
196           for tp1 = (aref a (random n))
197           for tp2 = (aref a (random n))
198           append (check-equivalence `(or ,tp1 ,tp2)
199                                     `(or ,tp2 ,tp1)))
200     100))
201  nil)
202
203;;; Check that types that are supposed to be nonempty are
204;;; not subtypes of NIL
205
206(deftest subtypep.nil.1
207  (loop for (type) in *subtype-table*
208        unless (member type '(nil extended-char))
209        append (check-all-not-subtypep type nil))
210  nil)
211
212(deftest subtypep.nil.2
213  (loop for (type) in *subtype-table*
214        for class = (find-class type nil)
215        unless (or (not class) (member type '(nil extended-char)))
216        append (check-all-not-subtypep class nil))
217  nil)
Note: See TracBrowser for help on using the repository browser.