0.pre7.38:
[sbcl.git] / tests / type.impure.lisp
1 (in-package :cl-user)
2
3 (load "assertoid.lisp")
4
5 (defmacro assert-nil-nil (expr)
6   `(assert (equal '(nil nil) (multiple-value-list ,expr))))
7 (defmacro assert-nil-t (expr)
8   `(assert (equal '(nil t) (multiple-value-list ,expr))))
9 (defmacro assert-t-t (expr)
10   `(assert (equal '(t t) (multiple-value-list ,expr))))
11
12 (let ((types '(character
13                integer fixnum (integer 0 10)
14                single-float (single-float -1.0 1.0) (single-float 0.1)
15                (real 4 8) (real -1 7) (real 2 11)
16                (member #\a #\b #\c) (member 1 #\a) (member 3.0 3.3)
17                ;; FIXME: When bug 91 is fixed, add these to the list:
18                ;;   (INTEGER -1 1)
19                ;;   UNSIGNED-BYTE
20                ;;   (RATIONAL -1 7) (RATIONAL -2 4)
21                ;;   RATIO
22                )))
23   (dolist (i types)
24     (format t "type I=~S~%" i)
25     (dolist (j types)
26       (format t "  type J=~S~%" j)
27       (assert (subtypep i `(or ,i ,j)))
28       (assert (subtypep i `(or ,j ,i)))
29       (assert (subtypep i `(or ,i ,i ,j)))
30       (assert (subtypep i `(or ,j ,i)))
31       (dolist (k types)
32         (format t "    type K=~S~%" k)
33         (assert (subtypep `(or ,i ,j) `(or ,i ,j ,k)))
34         (assert (subtypep `(or ,i ,j) `(or ,k ,j ,i)))))))
35
36 ;;; gotchas that can come up in handling subtypeness as "X is a
37 ;;; subtype of Y if each of the elements of X is a subtype of Y"
38 (let ((subtypep-values (multiple-value-list
39                         (subtypep '(single-float -1.0 1.0)
40                                   '(or (real -100.0 0.0)
41                                        (single-float 0.0 100.0))))))
42   (assert (member subtypep-values
43                   '(;; The system isn't expected to
44                     ;; understand the subtype relationship.
45                     (nil nil)
46                     ;; But if it does, that'd be neat.
47                     (t t)
48                     ;; (And any other return would be wrong.)
49                     )
50                   :test #'equal)))
51
52 (defun type-evidently-= (x y)
53   (and (subtypep x y)
54        (subtypep y x)))
55
56 (assert (subtypep 'single-float 'float))
57
58 (assert (type-evidently-= '(integer 0 10) '(or (integer 0 5) (integer 4 10))))
59
60 ;;; sbcl-0.6.10 did (UPGRADED-ARRAY-ELEMENT-TYPE 'SOME-UNDEF-TYPE)=>T
61 ;;; and (UPGRADED-COMPLEX-PART-TYPE 'SOME-UNDEF-TYPE)=>T.
62 (assert (raises-error? (upgraded-array-element-type 'some-undef-type)))
63 (assert (eql (upgraded-array-element-type t) t))
64 (assert (raises-error? (upgraded-complex-part-type 'some-undef-type)))
65 (assert (subtypep (upgraded-complex-part-type 'fixnum) 'real))
66
67 ;;; Do reasonable things with undefined types, and with compound types
68 ;;; built from undefined types.
69 ;;;
70 ;;; part I: TYPEP
71 (assert (typep #(11) '(simple-array t 1)))
72 (assert (typep #(11) '(simple-array (or integer symbol) 1)))
73 ;;; FIXME: This is broken because of compiler bug 123: the compiler
74 ;;; optimizes the type test to T, so it never gets a chance to raise a
75 ;;; runtime error. (It used to work under the IR1 interpreter just
76 ;;; because the IR1 interpreter doesn't try to optimize TYPEP as hard
77 ;;; as the byte compiler does.)
78 #+nil (assert (raises-error? (typep #(11) '(simple-array undef-type 1))))
79 (assert (not (typep 11 '(simple-array undef-type 1))))
80 ;;; part II: SUBTYPEP
81 (assert (subtypep '(vector some-undef-type) 'vector))
82 (assert (not (subtypep '(vector some-undef-type) 'integer)))
83 (assert-nil-nil (subtypep 'utype-1 'utype-2))
84 (assert-nil-nil (subtypep '(vector utype-1) '(vector utype-2)))
85 (assert-nil-nil (subtypep '(vector utype-1) '(vector t)))
86 (assert-nil-nil (subtypep '(vector t) '(vector utype-2)))
87
88 ;;; ANSI specifically disallows bare AND and OR symbols as type specs.
89 #| ; Alas, this is part of bug 10, still unfixed as of sbcl-0.6.11.10.
90 (assert (raises-error? (typep 11 'and)))
91 (assert (raises-error? (typep 11 'or)))
92 |#
93 ;;; Of course empty lists of subtypes are still OK.
94 (assert (typep 11 '(and)))
95 (assert (not (typep 11 '(or))))
96
97 ;;; bug 12: type system didn't grok nontrivial intersections
98 (assert (subtypep '(and symbol (satisfies keywordp)) 'symbol))
99 (assert (not (subtypep '(and symbol (satisfies keywordp)) 'null)))
100 (assert (subtypep 'keyword 'symbol))
101 (assert (not (subtypep 'symbol 'keyword)))
102 (assert (subtypep 'ratio 'real))
103 (assert (subtypep 'ratio 'number))
104 \f
105 ;;;; Douglas Thomas Crosher rewrote the CMU CL type test system to
106 ;;;; allow inline type tests for CONDITIONs and STANDARD-OBJECTs, and
107 ;;;; generally be nicer, and Martin Atzmueller ported the patches.
108 ;;;; They look nice but they're nontrivial enough that it's not
109 ;;;; obvious from inspection that everything is OK. Let's make sure
110 ;;;; that things still basically work.
111
112 ;; structure type tests setup
113 (defstruct structure-foo1)
114 (defstruct (structure-foo2 (:include structure-foo1))
115   x)
116 (defstruct (structure-foo3 (:include structure-foo2)))
117 (defstruct (structure-foo4 (:include structure-foo3))
118   y z)
119
120 ;; structure-class tests setup
121 (defclass structure-class-foo1 () () (:metaclass cl:structure-class))
122 (defclass structure-class-foo2 (structure-class-foo1)
123   () (:metaclass cl:structure-class))
124 (defclass structure-class-foo3 (structure-class-foo2)
125   () (:metaclass cl:structure-class))
126 (defclass structure-class-foo4 (structure-class-foo3)
127   () (:metaclass cl:structure-class))
128
129 ;; standard-class tests setup
130 (defclass standard-class-foo1 () () (:metaclass cl:standard-class))
131 (defclass standard-class-foo2 (standard-class-foo1)
132   () (:metaclass cl:standard-class))
133 (defclass standard-class-foo3 (standard-class-foo2)
134   () (:metaclass cl:standard-class))
135 (defclass standard-class-foo4 (standard-class-foo3)
136   () (:metaclass cl:standard-class))
137
138 ;; condition tests setup
139 (define-condition condition-foo1 (condition) ())
140 (define-condition condition-foo2 (condition-foo1) ())
141 (define-condition condition-foo3 (condition-foo2) ())
142 (define-condition condition-foo4 (condition-foo3) ())
143
144 ;;; inline type tests
145 (format t "~&/setting up *TESTS-OF-INLINE-TYPE-TESTS*~%")
146 (defparameter *tests-of-inline-type-tests*
147   '(progn
148
149      ;; structure type tests
150      (assert (typep (make-structure-foo3) 'structure-foo2))
151      (assert (not (typep (make-structure-foo1) 'structure-foo4)))
152      (assert (typep (nth-value 1
153                                (ignore-errors (structure-foo2-x
154                                                (make-structure-foo1))))
155                     'type-error))
156      (assert (null (ignore-errors
157                      (setf (structure-foo2-x (make-structure-foo1)) 11))))
158
159      ;; structure-class tests
160      (assert (typep (make-instance 'structure-class-foo3)
161                     'structure-class-foo2))
162      (assert (not (typep (make-instance 'structure-class-foo1)
163                          'structure-class-foo4)))
164      (assert (null (ignore-errors
165                      (setf (slot-value (make-instance 'structure-class-foo1)
166                                        'x)
167                            11))))
168
169      ;; standard-class tests
170      (assert (typep (make-instance 'standard-class-foo3)
171                     'standard-class-foo2))
172      (assert (not (typep (make-instance 'standard-class-foo1)
173                          'standard-class-foo4)))
174      (assert (null (ignore-errors
175                      (setf (slot-value (make-instance 'standard-class-foo1) 'x)
176                            11))))
177
178      ;; condition tests
179      (assert (typep (make-condition 'condition-foo3)
180                     'condition-foo2))
181      (assert (not (typep (make-condition 'condition-foo1)
182                          'condition-foo4)))
183      (assert (null (ignore-errors
184                      (setf (slot-value (make-condition 'condition-foo1) 'x)
185                            11))))
186      (assert (subtypep 'error 't))
187      (assert (subtypep 'simple-condition 'condition))
188      (assert (subtypep 'simple-error 'simple-condition))
189      (assert (subtypep 'simple-error 'error))
190      (assert (not (subtypep 'condition 'simple-condition)))
191      (assert (not (subtypep 'error 'simple-error)))
192      (assert (eq (car (sb-kernel:class-direct-superclasses
193                        (find-class 'simple-condition)))
194                  (find-class 'condition)))
195
196      (assert (eq (car (sb-pcl:class-direct-superclasses (sb-pcl:find-class
197                                                          'simple-condition)))
198                  (sb-pcl:find-class 'condition)))
199      (assert (null (set-difference
200                     (sb-pcl:class-direct-subclasses (sb-pcl:find-class
201                                                      'simple-condition))
202                     (mapcar #'sb-pcl:find-class
203                             '(simple-type-error
204                               simple-error
205                               sb-int:simple-file-error
206                               sb-int:simple-style-warning)))))
207
208      ;; precedence lists
209      (assert (equal (sb-pcl:class-precedence-list
210                      (sb-pcl:find-class 'simple-condition))
211                     (mapcar #'sb-pcl:find-class '(simple-condition
212                                                   condition
213                                                   sb-kernel:instance
214                                                   t))))
215
216      ;; stream classes
217      (assert (null (sb-kernel:class-direct-superclasses
218                     (find-class 'fundamental-stream))))
219      (assert (equal (sb-pcl:class-direct-superclasses (sb-pcl:find-class
220                                                        'fundamental-stream))
221                     (mapcar #'sb-pcl:find-class '(standard-object stream))))
222      (assert (null (set-difference
223                     (sb-pcl:class-direct-subclasses (sb-pcl:find-class
224                                                      'fundamental-stream))
225                     (mapcar #'sb-pcl:find-class '(fundamental-binary-stream
226                                                   fundamental-character-stream
227                                                   fundamental-output-stream
228                                                   fundamental-input-stream)))))
229      (assert (equal (sb-pcl:class-precedence-list (sb-pcl:find-class
230                                                    'fundamental-stream))
231                     (mapcar #'sb-pcl:find-class '(fundamental-stream
232                                                   standard-object
233                                                   sb-pcl::std-object
234                                                   sb-pcl::slot-object
235                                                   stream
236                                                   sb-kernel:instance
237                                                   t))))
238      (assert (equal (sb-pcl:class-precedence-list (sb-pcl:find-class
239                                                    'fundamental-stream))
240                     (mapcar #'sb-pcl:find-class '(fundamental-stream
241                                                   standard-object
242                                                   sb-pcl::std-object
243                                                   sb-pcl::slot-object stream
244                                                   sb-kernel:instance t))))
245      (assert (subtypep (find-class 'stream) (find-class t)))
246      (assert (subtypep (find-class 'fundamental-stream) 'stream))
247      (assert (not (subtypep 'stream 'fundamental-stream)))))
248 ;;; Test under the interpreter.
249 (eval *tests-of-inline-type-tests*)
250 (format t "~&/done with interpreted *TESTS-OF-INLINE-TYPE-TESTS*~%")
251 ;;; Test under the compiler.
252 (defun tests-of-inline-type-tests ()
253   #.*tests-of-inline-type-tests*)
254 (tests-of-inline-type-tests)
255 (format t "~&/done with compiled (TESTS-OF-INLINE-TYPE-TESTS)~%")
256
257 ;;; success
258 (quit :unix-status 104)