/[gcl]/gcl/ansi-tests/types-and-class.lsp
ViewVC logotype

Diff of /gcl/ansi-tests/types-and-class.lsp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.20 by pfdietz, Fri Jan 31 12:35:23 2003 UTC revision 1.21 by pfdietz, Sat Feb 1 00:57:37 2003 UTC
# Line 103  Line 103 
103    
104  ;;; Check that the disjoint types really are disjoint  ;;; Check that the disjoint types really are disjoint
105    
 (deftest types-7  
   (loop  
    for tp in *disjoint-types-list* sum  
    (loop for tp2 in *disjoint-types-list* count  
          (and (not (eqt tp tp2))  
               (subtypep* tp tp2))))  
   0)  
   
 (deftest types-7a  
   (loop  
    for tp in *disjoint-types-list* sum  
    (loop for tp2 in *disjoint-types-list* count  
          (and (not (eqt tp tp2))  
               (multiple-value-bind (sub valid)  
                   (subtypep `(not ,tp) `(not ,tp2))  
                 (and sub valid)))))  
   0)  
   
106  (deftest types-7b  (deftest types-7b
107    (loop for e on *disjoint-types-list*    (loop for e on *disjoint-types-list*
108          for tp1 = (first e)          for tp1 = (first e)
109          append          append
110          (loop for tp2 in (rest e)          (loop for tp2 in (rest e)
111                for result = (check-disjointness tp1 tp2)                append (classes-are-disjoint tp1 tp2)))
               append result))  
112    nil)    nil)
113    
114  (deftest types-7c  (deftest types-7c
# Line 135  Line 116 
116          for list1 = (first e)          for list1 = (first e)
117          append          append
118          (loop for tp1 in list1 append          (loop for tp1 in list1 append
119                (loop for list2 in (rest e) append                (loop for list2 in (rest e)
120                        append
121                      (loop for tp2 in list2 append                      (loop for tp2 in list2 append
122                            (check-disjointness tp1 tp2)))))                            (classes-are-disjoint tp1 tp2)))))
123    nil)      nil)
124    
125  (deftest types-8  (deftest types-8
126    (loop    (loop
# Line 150  Line 132 
132       t)))       t)))
133    0)    0)
134    
135  (declaim (special *type-list*  (declaim (special *type-list* *supertype-table*))
                   *supertype-table*))  
136    
137  ;;;  ;;;
138  ;;; TYPES-9 checks the transitivity of SUBTYPEP on pairs of types  ;;; TYPES-9 checks the transitivity of SUBTYPEP on pairs of types
# Line 192  Line 173 
173          collect (list e types))          collect (list e types))
174    nil)    nil)
175    
176    
177  (deftest integer-and-ratio-are-disjoint  (deftest integer-and-ratio-are-disjoint
178    (check-disjointness 'integer 'ratio)    (classes-are-disjoint 'integer 'ratio)
179    nil)    nil)
180    
181  (deftest bignum-and-ratio-are-disjoint  (deftest bignum-and-ratio-are-disjoint
182    (check-disjointness 'bignum 'ratio)    (classes-are-disjoint 'bignum 'ratio)
183    nil)    nil)
184    
185  (deftest bignum-and-fixnum-are-disjoint  (deftest bignum-and-fixnum-are-disjoint
186    (check-disjointness 'bignum 'fixnum)    (classes-are-disjoint 'bignum 'fixnum)
187    nil)    nil)
188    
189  (deftest fixnum-and-ratio-are-disjoint  (deftest fixnum-and-ratio-are-disjoint
190    (check-disjointness 'fixnum 'ratio)    (classes-are-disjoint 'fixnum 'ratio)
191    nil)    nil)
192    
193  (deftest byte8-and-ratio-are-disjoint  (deftest byte8-and-ratio-are-disjoint
194    (check-disjointness '(unsigned-byte 8) 'ratio)    (classes-are-disjoint '(unsigned-byte 8) 'ratio)
195    nil)    nil)
196    
197  (deftest bit-and-ratio-are-disjoint  (deftest bit-and-ratio-are-disjoint
198    (check-disjointness 'bit 'ratio)    (classes-are-disjoint 'bit 'ratio)
199    nil)    nil)
200    
201  (deftest integer-and-float-are-disjoint  (deftest integer-and-float-are-disjoint
202    (check-disjointness 'integer 'float)    (classes-are-disjoint 'integer 'float)
203    nil)    nil)
204    
205  (deftest ratio-and-float-are-disjoint  (deftest ratio-and-float-are-disjoint
206    (check-disjointness 'ratio 'float)    (classes-are-disjoint 'ratio 'float)
207    nil)    nil)
208    
209  (deftest complex-and-float-are-disjoint  (deftest complex-and-float-are-disjoint
210    (check-disjointness 'complex 'float)    (classes-are-disjoint 'complex 'float)
211    nil)    nil)
212    
213  (deftest integer-subranges-are-disjoint  (deftest integer-subranges-are-disjoint
214    (check-disjointness '(integer 0 (10)) '(integer 10 (20)))    (classes-are-disjoint '(integer 0 (10)) '(integer 10 (20)))
215    nil)    nil)
216    
217  (deftest keyword-and-null-are-disjoint  (deftest keyword-and-null-are-disjoint
218    (check-disjointness 'keyword 'null)    (classes-are-disjoint 'keyword 'null)
219    nil)    nil)
220    
221  (deftest keyword-and-boolean-are-disjoint  (deftest keyword-and-boolean-are-disjoint
222    (check-disjointness 'keyword 'boolean)    (classes-are-disjoint 'keyword 'boolean)
223    nil)    nil)
224    
225    
226    ;;; Check that all class names in CL that name standard-classes or
227    ;;; structure-classes are subtypes of standard-object and structure-object,
228    ;;; respectively
229    
230    (deftest all-standard-classes-are-subtypes-of-standard-object
231      (loop for sym being  the external-symbols of "COMMON-LISP"
232            for class = (find-class sym nil)
233            when (and class
234                      (typep class 'standard-class)
235                      (or (not (subtypep sym 'standard-object))
236                          (not (subtypep class 'standard-object))))
237            collect sym)
238      nil)
239    
240    (deftest all-structure-classes-are-subtypes-of-structure-object
241      (loop for sym being the external-symbols of "COMMON-LISP"
242            for class = (find-class sym nil)
243            when (and class
244                      (typep class 'structure-class)
245                      (or (not (subtypep sym 'structure-object))
246                          (not (subtypep class 'structure-object))))
247            collect sym)
248      nil)
249                      
250            
251    
252    
253    
# Line 250  Line 257 
257    
258  (deftype even-array (&optional type size)  (deftype even-array (&optional type size)
259    `(and (array ,type ,size)    `(and (array ,type ,size)
260         (satisfies even-size-p)))          (satisfies even-size-p)))
261    
262  (deftest deftype-1  (deftest deftype-1
263      (typep 1 '(even-array integer (10)))    (typep 1 '(even-array integer (10)))
264    nil)    nil)
265    
266  (deftest deftype-2  (deftest deftype-2
267      (typep nil '(even-array t (*)))    (typep nil '(even-array t (*)))
268    nil)    nil)
269    
270  (deftest deftype-3  (deftest deftype-3

Legend:
Removed from v.1.20  
changed lines
  Added in v.1.21

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26