File: type.pure.lisp

package info (click to toggle)
sbcl 1%3A0.9.16.0-1
  • links: PTS
  • area: main
  • in suites: etch, etch-m68k
  • size: 19,960 kB
  • ctags: 16,537
  • sloc: lisp: 231,164; ansic: 19,558; asm: 2,539; sh: 1,925; makefile: 308
file content (344 lines) | stat: -rw-r--r-- 14,033 bytes parent folder | download
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; While most of SBCL is derived from the CMU CL system, the test
;;;; files (like this one) were written from scratch after the fork
;;;; from CMU CL.
;;;;
;;;; This software is in the public domain and is provided with
;;;; absolutely no warranty. See the COPYING and CREDITS files for
;;;; more information.

(in-package "CL-USER")

(locally
  (declare (notinline mapcar))
  (mapcar (lambda (args)
            (destructuring-bind (obj type-spec result) args
              (flet ((matches-result? (x)
                       (eq (if x t nil) result)))
                (assert (matches-result? (typep obj type-spec)))
                (assert (matches-result? (sb-kernel:ctypep
                                          obj
                                          (sb-kernel:specifier-type
                                           type-spec)))))))
          '((nil (or null vector)              t)
            (nil (or number vector)            nil)
            (12  (or null vector)              nil)
            (12  (and (or number vector) real) t))))


;;; This test is motivated by bug #195, which previously had (THE REAL
;;; #(1 2 3)) give an error which prints as "This is not a (OR
;;; SINGLE-FLOAT DOUBLE-FLOAT RATIONAL)".  We ideally want all of the
;;; defined-by-ANSI types to unparse as themselves or at least
;;; something similar (e.g. CHARACTER can unparse to BASE-CHAR, since
;;; the types are equivalent in current SBCL, and EXTENDED-CHAR can
;;; unparse to NIL, since there are no EXTENDED-CHARs currently).
(let ((standard-types '(;; from table 4-2 in section 4.2.3 in the
                        ;; CLHS.
                        arithmetic-error
                        function
                        simple-condition
                        array
                        generic-function
                        simple-error
                        atom
                        hash-table
                        simple-string
                        base-char
                        integer
                        simple-type-error
                        base-string
                        keyword
                        simple-vector
                        bignum
                        list
                        simple-warning
                        bit
                        logical-pathname
                        single-float
                        bit-vector
                        long-float
                        standard-char
                        broadcast-stream
                        method
                        standard-class
                        built-in-class
                        method-combination
                        standard-generic-function
                        cell-error
                        nil
                        standard-method
                        character
                        null
                        standard-object
                        class
                        number
                        storage-condition
                        compiled-function
                        package
                        stream
                        complex
                        package-error
                        stream-error
                        concatenated-stream
                        parse-error
                        string
                        condition
                        pathname
                        string-stream
                        cons
                        print-not-readable
                        structure-class
                        control-error
                        program-error
                        structure-object
                        division-by-zero
                        random-state
                        style-warning
                        double-float
                        ratio
                        symbol
                        echo-stream
                        rational
                        synonym-stream
                        end-of-file
                        reader-error
                        t
                        error
                        readtable
                        two-way-stream
                        extended-char
                        real
                        type-error
                        file-error
                        restart
                        unbound-slot
                        file-stream
                        sequence
                        unbound-variable
                        fixnum
                        serious-condition
                        undefined-function
                        float
                        short-float
                        unsigned-byte
                        floating-point-inexact
                        signed-byte
                        vector
                        floating-point-invalid-operation
                        simple-array
                        warning
                        floating-point-overflow
                        simple-base-string
                        floating-point-underflow
                        simple-bit-vector)))
  (dolist (type standard-types)
    (format t "~&~S~%" type)
    (assert (not (sb-kernel:unknown-type-p (sb-kernel:specifier-type type))))
    (assert (atom (sb-kernel:type-specifier (sb-kernel:specifier-type type))))))

;;; a bug underlying the reported bug #221: The SB-KERNEL type code
;;; signalled an error on this expression.
(subtypep '(function (fixnum) (values package boolean))
          '(function (t) (values package boolean)))

;;; bug reported by Valtteri Vuorik
(compile nil '(lambda () (member (char "foo" 0) '(#\. #\/) :test #'char=)))
(assert (not (equal (multiple-value-list
                     (subtypep '(function ()) '(function (&rest t))))
                    '(nil t))))

(assert (not (equal (multiple-value-list
                     (subtypep '(function (&rest t)) '(function ())))
                    '(t t))))

(assert (subtypep '(function)
                  '(function (&optional * &rest t))))
(assert (equal (multiple-value-list
                (subtypep '(function)
                          '(function (t &rest t))))
               '(nil t)))
(assert (and (subtypep 'function '(function))
             (subtypep '(function) 'function)))

;;; Absent any exciting generalizations of |R, the type RATIONAL is
;;; partitioned by RATIO and INTEGER.  Ensure that the type system
;;; knows about this.  [ the type system is permitted to return NIL,
;;; NIL for these, so if future maintenance breaks these tests that
;;; way, that's fine.  What the SUBTYPEP calls are _not_ allowed to
;;; return is NIL, T, because that's completely wrong. ]
(assert (subtypep '(or integer ratio) 'rational))
(assert (subtypep 'rational '(or integer ratio)))
;;; Likewise, these are allowed to return NIL, NIL, but shouldn't
;;; return NIL, T:
(assert (subtypep t '(or real (not real))))
(assert (subtypep t '(or keyword (not keyword))))
(assert (subtypep '(and cons (not (cons symbol integer)))
                  '(or (cons (not symbol) *) (cons * (not integer)))))
(assert (subtypep '(or (cons (not symbol) *) (cons * (not integer)))
                  '(and cons (not (cons symbol integer)))))
(assert (subtypep '(or (eql 0) (rational (0) 10))
                  '(rational 0 10)))
(assert (subtypep '(rational 0 10)
                  '(or (eql 0) (rational (0) 10))))
;;; Until sbcl-0.7.13.7, union of CONS types when the CDRs were the
;;; same type gave exceedingly wrong results
(assert (null (subtypep '(or (cons fixnum single-float)
                             (cons bignum single-float))
                        '(cons single-float single-float))))
(assert (subtypep '(cons integer single-float)
                  '(or (cons fixnum single-float) (cons bignum single-float))))

(assert (not (nth-value 1 (subtypep '(and null some-unknown-type)
                                    'another-unknown-type))))

;;; bug 46c
(dolist (fun '(and if))
  (assert (raises-error? (coerce fun 'function) type-error)))

(dotimes (i 100)
  (let ((x (make-array 0 :element-type `(unsigned-byte ,(1+ i)))))
    (eval `(typep ,x (class-of ,x)))))

(assert (not (typep #c(1 2) '(member #c(2 1)))))
(assert (typep #c(1 2) '(member #c(1 2))))
(assert (subtypep 'nil '(complex nil)))
(assert (subtypep '(complex nil) 'nil))
(assert (subtypep 'nil '(complex (eql 0))))
(assert (subtypep '(complex (eql 0)) 'nil))
(assert (subtypep 'nil '(complex (integer 0 0))))
(assert (subtypep '(complex (integer 0 0)) 'nil))
(assert (subtypep 'nil '(complex (rational 0 0))))
(assert (subtypep '(complex (rational 0 0)) 'nil))
(assert (subtypep 'complex '(complex real)))
(assert (subtypep '(complex real) 'complex))
(assert (subtypep '(complex (eql 1)) '(complex (member 1 2))))
(assert (subtypep '(complex ratio) '(complex rational)))
(assert (subtypep '(complex ratio) 'complex))
(assert (equal (multiple-value-list
                (subtypep '(complex (integer 1 2))
                          '(member #c(1 1) #c(1 2) #c(2 1) #c(2 2))))
               '(nil t)))

(assert (typep 0 '(real #.(ash -1 10000) #.(ash 1 10000))))
(assert (subtypep '(real #.(ash -1 1000) #.(ash 1 1000))
                  '(real #.(ash -1 10000) #.(ash 1 10000))))
(assert (subtypep '(real (#.(ash -1 1000)) (#.(ash 1 1000)))
                  '(real #.(ash -1 1000) #.(ash 1 1000))))

;;; Bug, found by Paul F. Dietz
(let* ((x (eval #c(-1 1/2)))
       (type (type-of x)))
  (assert (subtypep type '(complex rational)))
  (assert (typep x type)))

;;; Test derivation of LOG{AND,IOR,XOR} bounds for unsigned arguments.
;;;
;;; Fear the Loop of Doom!
(let* ((bits 5)
       (size (ash 1 bits)))
  (flet ((brute-force (a b c d op minimize)
           (loop with extreme = (if minimize (ash 1 bits) 0)
                 with collector = (if minimize #'min #'max)
                 for i from a upto b do
                 (loop for j from c upto d do
                       (setf extreme (funcall collector
                                              extreme
                                              (funcall op i j))))
                 finally (return extreme))))
    (dolist (op '(logand logior logxor))
      (dolist (minimize '(t nil))
        (let ((deriver (intern (format nil "~A-DERIVE-UNSIGNED-~:[HIGH~;LOW~]-BOUND"
                                       op minimize)
                               (find-package :sb-c))))
          (loop for a from 0 below size do
                (loop for b from a below size do
                      (loop for c from 0 below size do
                            (loop for d from c below size do
                                  (let* ((brute (brute-force a b c d op minimize))
                                         (x-type (sb-c::specifier-type `(integer ,a ,b)))
                                         (y-type (sb-c::specifier-type `(integer ,c ,d)))
                                         (derived (funcall deriver x-type y-type)))
                                    (unless (= brute derived)
                                      (format t "FAIL: ~A [~D,~D] [~D,~D] ~A~%
ACTUAL ~D DERIVED ~D~%"
                                              op a b c d minimize brute derived)
                                      (assert (= brute derived)))))))))))))

;;; subtypep on CONS types wasn't taking account of the fact that a
;;; CONS type could be the empty type (but no other non-CONS type) in
;;; disguise.
(multiple-value-bind (yes win)
    (subtypep '(and function stream) 'nil)
  (multiple-value-bind (cyes cwin)
      (subtypep '(cons (and function stream) t)
                '(cons nil t))
    (assert (eq yes cyes))
    (assert (eq win cwin))))

;;; CONS type subtypep could be too enthusiastic about thinking it was
;;; certain
(multiple-value-bind (yes win)
    (subtypep '(satisfies foo) '(satisfies bar))
  (assert (null yes))
  (assert (null win))
  (multiple-value-bind (cyes cwin)
      (subtypep '(cons (satisfies foo) t)
                '(cons (satisfies bar) t))
    (assert (null cyes))
    (assert (null cwin))))

(multiple-value-bind (yes win)
    (subtypep 'generic-function 'function)
  (assert yes)
  (assert win))
;;; this would be in some internal test suite like type.before-xc.lisp
;;; except that generic functions don't exist at that stage.
(multiple-value-bind (yes win)
    (subtypep 'generic-function 'sb-kernel:funcallable-instance)
  (assert yes)
  (assert win))

;;; all sorts of answers are right for this one, but it used to
;;; trigger an AVER instead.
(subtypep '(function ()) '(and (function ()) (satisfies identity)))

(assert (sb-kernel:unknown-type-p (sb-kernel:specifier-type 'an-unkown-type)))

(assert
 (sb-kernel:type=
  (sb-kernel:specifier-type '(or (simple-array an-unkown-type (*))
                              (simple-array an-unkown-type)))
  (sb-kernel:specifier-type '(or (simple-array an-unkown-type (*))
                              (simple-array an-unkown-type)))))

(assert
 (sb-kernel:type=
  (sb-kernel:specifier-type '(simple-array an-unkown-type (*)))
  (sb-kernel:specifier-type '(simple-array an-unkown-type (*)))))

(assert
 (not
  (sb-kernel:type=
   (sb-kernel:specifier-type '(simple-array an-unkown-type (*)))
   (sb-kernel:specifier-type '(array an-unkown-type (*))))))

(assert
 (not
  (sb-kernel:type=
   (sb-kernel:specifier-type '(simple-array an-unkown-type (7)))
   (sb-kernel:specifier-type '(simple-array an-unkown-type (8))))))

(assert
 (sb-kernel:type/= (sb-kernel:specifier-type 'cons)
                   (sb-kernel:specifier-type '(cons single-float single-float))))

(multiple-value-bind (match win)
    (sb-kernel:type= (sb-kernel:specifier-type '(cons integer))
                     (sb-kernel:specifier-type '(cons)))
  (assert (and (not match) win)))

(assert (typep #p"" 'sb-kernel:instance))
(assert (subtypep '(member #p"") 'sb-kernel:instance))