← Back to branch summary

~ubuntu-branches/ubuntu/quantal/gclcvs/quantal

« back to all changes in this revision

Viewing changes to ansi-tests/types-and-class-2.lsp

  • Committer: Bazaar Package Importer
  • Author(s): Camm Maguire
  • Date: 2004-06-24 15:13:46 UTC
  • Revision ID: james.westby@ubuntu.com-20040624151346-xh0xaaktyyp7aorc
Tags: 2.7.0-26
C_GC_OFFSET is 2 on m68k-linux

Show diffs side-by-side

added added

removed removed

Lines of Context:
ansi-tests/types-and-class-2.lsp
 
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)