/[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.27 by pfdietz, Thu Feb 6 03:43:48 2003 UTC revision 1.28 by pfdietz, Sat Feb 15 05:11:12 2003 UTC
# Line 10  Line 10 
10    
11  (declaim (optimize (safety 3)))  (declaim (optimize (safety 3)))
12    
13  (deftest boolean-type-1  (deftest boolean-type.1
14    (notnot-mv (typep nil 'boolean))    (notnot-mv (typep nil 'boolean))
15    t)    t)
16    
17  (deftest boolean-type-2  (deftest boolean-type.2
18    (notnot-mv (typep t 'boolean))    (notnot-mv (typep t 'boolean))
19    t)    t)
20    
21  (deftest boolean-type-3  (deftest boolean-type.3
22    (check-type-predicate 'is-t-or-nil 'boolean)    (check-type-predicate 'is-t-or-nil 'boolean)
23    0)    0)
24    
# Line 30  Line 30 
30    
31    
32    
33  (deftest types-3  (deftest types.3
34    (loop    (loop
35     for (t1 t2) in *subtype-table*     for (t1 t2) in *subtype-table*
36     for m1 = (check-subtypep t1 t2 t t)     for m1 = (check-subtypep t1 t2 t t)
# Line 51  Line 51 
51  ;;; incorrectly that certain subtype relationships that are  ;;; incorrectly that certain subtype relationships that are
52  ;;; not specified in the spec cannot occur.  ;;; not specified in the spec cannot occur.
53  #|  #|
54  (defun types-4-body ()  (defun types.4-body ()
55    (let ((parent-table (make-hash-table :test #'equal))    (let ((parent-table (make-hash-table :test #'equal))
56          (types nil))          (types nil))
57      (loop      (loop
# Line 90  Line 90 
90                     (t 0)))))                     (t 0)))))
91      ))      ))
92    
93  (deftest types-4  (deftest types.4
94    (types-4-body)    (types.4-body)
95    0)    0)
96  |#  |#
97    
98  (deftest types-6  (deftest types.6
99    (types-6-body)    (types.6-body)
100    nil)    nil)
101    
102  (declaim (special *disjoint-types-list*))  (declaim (special *disjoint-types-list*))
103    
104  ;;; Check that the disjoint types really are disjoint  ;;; Check that the disjoint types really are disjoint
105    
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
# Line 111  Line 111 
111                append (classes-are-disjoint tp1 tp2)))                append (classes-are-disjoint tp1 tp2)))
112    nil)    nil)
113    
114  (deftest types-7c  (deftest types.7c
115    (loop for e on *disjoint-types-list2*    (loop for e on *disjoint-types-list2*
116          for list1 = (first e)          for list1 = (first e)
117          append          append
# Line 122  Line 122 
122                            (classes-are-disjoint tp1 tp2)))))                            (classes-are-disjoint tp1 tp2)))))
123    nil)    nil)
124    
125  (deftest types-8  (deftest types.8
126    (loop    (loop
127     for tp in *disjoint-types-list* count     for tp in *disjoint-types-list* count
128     (cond     (cond
# Line 135  Line 135 
135  (declaim (special *type-list* *supertype-table*))  (declaim (special *type-list* *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
139  ;;; occuring in *SUBTYPE-TABLE*, as well as the types KEYWORD, ATOM,  ;;; occuring in *SUBTYPE-TABLE*, as well as the types KEYWORD, ATOM,
140  ;;; and LIST (the relationships given in *SUBTYPE-TABLE* are not used  ;;; and LIST (the relationships given in *SUBTYPE-TABLE* are not used
141  ;;; here.)  ;;; here.)
142  ;;;  ;;;
143    
144  (deftest types-9  (deftest types.9
145    (types-9-body)    (types.9-body)
146    nil)    nil)
147    
148  ;;;  ;;;
149  ;;; TYPES-9A takes the supertype relationship computed by test TYPE-9  ;;; TYPES.9A takes the supertype relationship computed by test TYPE.9
150  ;;; and checks that TYPEP respects it for all elements of *UNIVERSE*.  ;;; and checks that TYPEP respects it for all elements of *UNIVERSE*.
151  ;;; That is, if T1 and T2 are two types, and X is an element of *UNIVERSE*,  ;;; That is, if T1 and T2 are two types, and X is an element of *UNIVERSE*,
152  ;;; then if (SUBTYPEP T1) then (TYPEP X T1) implies (TYPEP X T2).  ;;; then if (SUBTYPEP T1) then (TYPEP X T1) implies (TYPEP X T2).
# Line 154  Line 154 
154  ;;; The function prints error messages when this fails, and returns the  ;;; The function prints error messages when this fails, and returns the
155  ;;; number of occurences of failure.  ;;; number of occurences of failure.
156  ;;;  ;;;
157  ;;; Test TYPES-9 must be run before this test.  ;;; Test TYPES.9 must be run before this test.
158  ;;;  ;;;
159    
160  (deftest types-9a  (deftest types.9a
161    (types-9a-body)    (types.9a-body)
162    0)    0)
163    
164    
# Line 227  Line 227 
227    `(and (array ,type ,size)    `(and (array ,type ,size)
228          (satisfies even-size-p)))          (satisfies even-size-p)))
229    
230  (deftest deftype-1  (deftest deftype.1
231    (typep 1 '(even-array integer (10)))    (typep 1 '(even-array integer (10)))
232    nil)    nil)
233    
234  (deftest deftype-2  (deftest deftype.2
235    (typep nil '(even-array t (*)))    (typep nil '(even-array t (*)))
236    nil)    nil)
237    
238  (deftest deftype-3  (deftest deftype.3
239    (notnot-mv (typep (make-array '(10)) '(even-array t (*))))    (notnot-mv (typep (make-array '(10)) '(even-array t (*))))
240    t)    t)
241    
242  (deftest deftype-4  (deftest deftype.4
243    (typep (make-array '(5)) '(even-array t (*)))    (typep (make-array '(5)) '(even-array t (*)))
244    nil)    nil)
245    
246  (deftest deftype-5  (deftest deftype.5
247    (notnot-mv (typep (make-string 10) '(even-array character (*))))    (notnot-mv (typep (make-string 10) '(even-array character (*))))
248    t)    t)
249    
250  (deftest deftype-6  (deftest deftype.6
251    (notnot-mv    (notnot-mv
252     (typep (make-array '(3 5 6) :element-type '(unsigned-byte 8))     (typep (make-array '(3 5 6) :element-type '(unsigned-byte 8))
253            '(even-array (unsigned-byte 8))))            '(even-array (unsigned-byte 8))))

Legend:
Removed from v.1.27  
changed lines
  Added in v.1.28

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