source: trunk/source/tests/ansi-tests/types-and-class-2.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: 4.1 KB
Line 
1;-*- Mode:     Lisp -*-
2;;;; Author:   Paul Dietz
3;;;; Created:  Wed Feb  5 21:20:05 2003
4;;;; Contains: More tests of types and classes
5
6(in-package :cl-test)
7
8(compile-and-load "types-aux.lsp")
9
10;;; Union of a type with its complement is universal
11
12(deftest type-or-not-type-is-everything
13  (loop for l in *disjoint-types-list2*
14        append
15        (loop
16         for type in l
17         append (check-subtypep t `(or ,type (not ,type)) t)
18         append (check-subtypep t `(or (not ,type) ,type) t)))
19  nil)
20
21(defclass tac-1-class () (a b c))
22(defclass tac-1a-class (tac-1-class) (d e))
23(defclass tac-1b-class (tac-1-class) (f g))
24
25(deftest user-class-disjointness
26  (loop for l in *disjoint-types-list2*
27        append
28        (loop
29         for type in l
30         append (classes-are-disjoint type 'tac-1-class)))
31  nil)
32
33(deftest user-class-disjointness-2
34  (check-disjointness 'tac-1a-class 'tac-1b-class)
35  nil)
36
37(defstruct tac-2-struct a b c)
38(defstruct (tac-2a-struct (:include tac-2-struct)) d e)
39(defstruct (tac-2b-struct (:include tac-2-struct)) f g)
40
41(deftest user-struct-disjointness
42  (loop for l in *disjoint-types-list2*
43        append
44        (loop
45         for type in l
46         append (check-disjointness type 'tac-2-struct)))
47  nil)
48
49(deftest user-struct-disjointness-2
50  (check-disjointness 'tac-2a-struct 'tac-2b-struct)
51  nil)
52
53(defclass tac-3-a () (x))
54(defclass tac-3-b () (y))
55(defclass tac-3-c () (z))
56
57(defclass tac-3-ab (tac-3-a tac-3-b) ())
58(defclass tac-3-ac (tac-3-a tac-3-c) ())
59(defclass tac-3-bc (tac-3-b tac-3-c) ())
60
61(defclass tac-3-abc (tac-3-ab tac-3-ac tac-3-bc) ())
62
63(deftest tac-3.1
64  (subtypep* 'tac-3-ab 'tac-3-a)
65  t t)
66
67(deftest tac-3.2
68  (subtypep* 'tac-3-ab 'tac-3-b)
69  t t)
70
71(deftest tac-3.3
72  (subtypep* 'tac-3-ab 'tac-3-c)
73  nil t)
74
75(deftest tac-3.4
76  (subtypep* 'tac-3-a 'tac-3-ab)
77  nil t)
78
79(deftest tac-3.5
80  (subtypep* 'tac-3-b 'tac-3-ab)
81  nil t)
82
83(deftest tac-3.6
84  (subtypep* 'tac-3-c 'tac-3-ab)
85  nil t)
86
87(deftest tac-3.7
88  (subtypep* 'tac-3-abc 'tac-3-a)
89  t t)
90
91(deftest tac-3.8
92  (subtypep* 'tac-3-abc 'tac-3-b)
93  t t)
94
95(deftest tac-3.9
96  (subtypep* 'tac-3-abc 'tac-3-c)
97  t t)
98
99(deftest tac-3.10
100  (subtypep* 'tac-3-abc 'tac-3-ab)
101  t t)
102
103(deftest tac-3.11
104  (subtypep* 'tac-3-abc 'tac-3-ac)
105  t t)
106
107(deftest tac-3.12
108  (subtypep* 'tac-3-abc 'tac-3-bc)
109  t t)
110
111(deftest tac-3.13
112  (subtypep* 'tac-3-ab 'tac-3-abc)
113  nil t)
114
115(deftest tac-3.14
116  (subtypep* 'tac-3-ac 'tac-3-abc)
117  nil t)
118
119(deftest tac-3.15
120  (subtypep* 'tac-3-bc 'tac-3-abc)
121  nil t)
122
123(deftest tac-3.16
124  (check-equivalence '(and tac-3-a tac-3-b) 'tac-3-ab)
125  nil)
126
127(deftest tac-3.17
128  (check-equivalence '(and (or tac-3-a tac-3-b)
129                           (or (not tac-3-a) (not tac-3-b))
130                           (or tac-3-a tac-3-c)
131                           (or (not tac-3-a) (not tac-3-c))
132                           (or tac-3-b tac-3-c)
133                           (or (not tac-3-b) (not tac-3-c)))
134                     nil)
135  nil)
136
137;;;
138;;; Check that disjointness of types in *disjoint-types-list*
139;;; is respected by all the elements of *universe*
140;;;
141(deftest universe-elements-in-at-most-one-disjoint-type
142  (loop for e in *universe*
143        for types = (remove-if-not #'(lambda (x) (typep e x))
144                                   *disjoint-types-list*)
145        when (> (length types) 1)
146        collect (list e types))
147  nil)
148
149
150
151;;;;;
152
153(deftest integer-and-ratio-are-disjoint
154  (classes-are-disjoint 'integer 'ratio)
155  nil)
156
157(deftest bignum-and-ratio-are-disjoint
158  (classes-are-disjoint 'bignum 'ratio)
159  nil)
160
161(deftest bignum-and-fixnum-are-disjoint
162  (classes-are-disjoint 'bignum 'fixnum)
163  nil)
164
165(deftest fixnum-and-ratio-are-disjoint
166  (classes-are-disjoint 'fixnum 'ratio)
167  nil)
168
169(deftest byte8-and-ratio-are-disjoint
170  (classes-are-disjoint '(unsigned-byte 8) 'ratio)
171  nil)
172
173(deftest bit-and-ratio-are-disjoint
174  (classes-are-disjoint 'bit 'ratio)
175  nil)
176
177(deftest integer-and-float-are-disjoint
178  (classes-are-disjoint 'integer 'float)
179  nil)
180
181(deftest ratio-and-float-are-disjoint
182  (classes-are-disjoint 'ratio 'float)
183  nil)
184
185(deftest complex-and-float-are-disjoint
186  (classes-are-disjoint 'complex 'float)
187  nil)
188
189(deftest integer-subranges-are-disjoint
190  (classes-are-disjoint '(integer 0 (10)) '(integer 10 (20)))
191  nil)
192
193(deftest keyword-and-null-are-disjoint
194  (classes-are-disjoint 'keyword 'null)
195  nil)
196
197(deftest keyword-and-boolean-are-disjoint
198  (classes-are-disjoint 'keyword 'boolean)
199  nil)
Note: See TracBrowser for help on using the repository browser.