1 ;;;; This file contains the definition of non-CLASS types (e.g.
2 ;;;; subtypes of interesting BUILT-IN-CLASSes) and the interfaces to
3 ;;;; the type system. Common Lisp type specifiers are parsed into a
4 ;;;; somewhat canonical internal type representation that supports
5 ;;;; type union, intersection, etc. (Except that ALIEN types have
8 ;;;; This software is part of the SBCL system. See the README file for
11 ;;;; This software is derived from the CMU CL system, which was
12 ;;;; written at Carnegie Mellon University and released into the
13 ;;;; public domain. The software is in the public domain and is
14 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
15 ;;;; files for more information.
17 (in-package "SB!KERNEL")
19 (/show0
"late-type.lisp 19")
21 (!begin-collecting-cold-init-forms
)
23 ;;; ### Remaining incorrectnesses:
25 ;;; There are all sorts of nasty problems with open bounds on FLOAT
26 ;;; types (and probably FLOAT types in general.)
28 ;;; This condition is signalled whenever we make a UNKNOWN-TYPE so that
29 ;;; compiler warnings can be emitted as appropriate.
30 (define-condition parse-unknown-type
(condition)
31 ((specifier :reader parse-unknown-type-specifier
:initarg
:specifier
)))
33 ;;; These functions are used as method for types which need a complex
34 ;;; subtypep method to handle some superclasses, but cover a subtree
35 ;;; of the type graph (i.e. there is no simple way for any other type
36 ;;; class to be a subtype.) There are always still complex ways,
37 ;;; namely UNION and MEMBER types, so we must give TYPE1's method a
38 ;;; chance to run, instead of immediately returning NIL, T.
39 (defun delegate-complex-subtypep-arg2 (type1 type2
)
41 (type-class-complex-subtypep-arg1
42 (type-class-info type1
))))
44 (funcall subtypep-arg1 type1 type2
)
46 (defun delegate-complex-intersection2 (type1 type2
)
47 (let ((method (type-class-complex-intersection2 (type-class-info type1
))))
48 (if (and method
(not (eq method
#'delegate-complex-intersection2
)))
49 (funcall method type2 type1
)
50 (hierarchical-intersection2 type1 type2
))))
52 ;;; This is used by !DEFINE-SUPERCLASSES to define the SUBTYPE-ARG1
53 ;;; method. INFO is a list of conses
54 ;;; (SUPERCLASS-CLASS . {GUARD-TYPE-SPECIFIER | NIL}).
55 (defun !has-superclasses-complex-subtypep-arg1
(type1 type2 info
)
56 ;; If TYPE2 might be concealing something related to our class
58 (if (type-might-contain-other-types-p type2
)
59 ;; too confusing, gotta punt
61 ;; ordinary case expected by old CMU CL code, where the taxonomy
62 ;; of TYPE2's representation accurately reflects the taxonomy of
65 ;; FIXME: This old CMU CL code probably deserves a comment
66 ;; explaining to us mere mortals how it works...
67 (and (sb!xc
:typep type2
'classoid
)
69 (when (or (not (cdr x
))
70 (csubtypep type1
(specifier-type (cdr x
))))
72 (or (eq type2
(car x
))
73 (let ((inherits (layout-inherits
74 (classoid-layout (car x
)))))
75 (dotimes (i (length inherits
) nil
)
76 (when (eq type2
(layout-classoid (svref inherits i
)))
80 ;;; This function takes a list of specs, each of the form
81 ;;; (SUPERCLASS-NAME &OPTIONAL GUARD).
82 ;;; Consider one spec (with no guard): any instance of the named
83 ;;; TYPE-CLASS is also a subtype of the named superclass and of any of
84 ;;; its superclasses. If there are multiple specs, then some will have
85 ;;; guards. We choose the first spec whose guard is a supertype of
86 ;;; TYPE1 and use its superclass. In effect, a sequence of guards
89 ;;; G0,(and G1 (not G0)), (and G2 (not (or G0 G1))).
91 ;;; WHEN controls when the forms are executed.
92 (defmacro !define-superclasses
(type-class-name specs when
)
93 (with-unique-names (type-class info
)
95 (let ((,type-class
(type-class-or-lose ',type-class-name
))
96 (,info
(mapcar (lambda (spec)
98 (super &optional guard
)
100 (cons (find-classoid super
) guard
)))
102 (setf (type-class-complex-subtypep-arg1 ,type-class
)
103 (lambda (type1 type2
)
104 (!has-superclasses-complex-subtypep-arg1 type1 type2
,info
)))
105 (setf (type-class-complex-subtypep-arg2 ,type-class
)
106 #'delegate-complex-subtypep-arg2
)
107 (setf (type-class-complex-intersection2 ,type-class
)
108 #'delegate-complex-intersection2
)))))
110 ;;;; FUNCTION and VALUES types
112 ;;;; Pretty much all of the general type operations are illegal on
113 ;;;; VALUES types, since we can't discriminate using them, do
114 ;;;; SUBTYPEP, etc. FUNCTION types are acceptable to the normal type
115 ;;;; operations, but are generally considered to be equivalent to
116 ;;;; FUNCTION. These really aren't true types in any type theoretic
117 ;;;; sense, but we still parse them into CTYPE structures for two
120 ;;;; -- Parsing and unparsing work the same way, and indeed we can't
121 ;;;; tell whether a type is a function or values type without
123 ;;;; -- Many of the places that can be annotated with real types can
124 ;;;; also be annotated with function or values types.
126 ;;; the description of a &KEY argument
127 (defstruct (key-info #-sb-xc-host
(:pure t
)
129 ;; the key (not necessarily a keyword in ANSI Common Lisp)
130 (name (missing-arg) :type symbol
)
131 ;; the type of the argument value
132 (type (missing-arg) :type ctype
))
134 (!define-type-method
(values :simple-subtypep
:complex-subtypep-arg1
)
136 (declare (ignore type2
))
137 ;; FIXME: should be TYPE-ERROR, here and in next method
138 (error "SUBTYPEP is illegal on this type:~% ~S" (type-specifier type1
)))
140 (!define-type-method
(values :complex-subtypep-arg2
)
142 (declare (ignore type1
))
143 (error "SUBTYPEP is illegal on this type:~% ~S" (type-specifier type2
)))
145 (!define-type-method
(values :negate
) (type)
146 (error "NOT VALUES too confusing on ~S" (type-specifier type
)))
148 (!define-type-method
(values :unparse
) (type)
150 (let ((unparsed (unparse-args-types type
)))
151 (if (or (values-type-optional type
)
152 (values-type-rest type
)
153 (values-type-allowp type
))
155 (nconc unparsed
'(&optional
))))))
157 ;;; Return true if LIST1 and LIST2 have the same elements in the same
158 ;;; positions according to TYPE=. We return NIL, NIL if there is an
159 ;;; uncertain comparison.
160 (defun type=-list
(list1 list2
)
161 (declare (list list1 list2
))
162 (do ((types1 list1
(cdr types1
))
163 (types2 list2
(cdr types2
)))
164 ((or (null types1
) (null types2
))
165 (if (or types1 types2
)
168 (multiple-value-bind (val win
)
169 (type= (first types1
) (first types2
))
171 (return (values nil nil
)))
173 (return (values nil t
))))))
175 (!define-type-method
(values :simple-
=) (type1 type2
)
176 (type=-args type1 type2
))
178 (!define-type-class function
)
180 ;;; a flag that we can bind to cause complex function types to be
181 ;;; unparsed as FUNCTION. This is useful when we want a type that we
182 ;;; can pass to TYPEP.
183 (defvar *unparse-fun-type-simplify
*)
184 (!cold-init-forms
(setq *unparse-fun-type-simplify
* nil
))
186 (!define-type-method
(function :negate
) (type)
187 (make-negation-type :type type
))
189 (!define-type-method
(function :unparse
) (type)
190 (if *unparse-fun-type-simplify
*
193 (if (fun-type-wild-args type
)
195 (unparse-args-types type
))
197 (fun-type-returns type
)))))
199 ;;; The meaning of this is a little confused. On the one hand, all
200 ;;; function objects are represented the same way regardless of the
201 ;;; arglists and return values, and apps don't get to ask things like
202 ;;; (TYPEP #'FOO (FUNCTION (FIXNUM) *)) in any meaningful way. On the
203 ;;; other hand, Python wants to reason about function types. So...
204 (!define-type-method
(function :simple-subtypep
) (type1 type2
)
205 (flet ((fun-type-simple-p (type)
206 (not (or (fun-type-rest type
)
207 (fun-type-keyp type
))))
208 (every-csubtypep (types1 types2
)
212 do
(multiple-value-bind (res sure-p
)
214 (unless res
(return (values res sure-p
))))
215 finally
(return (values t t
)))))
216 (and/type
(values-subtypep (fun-type-returns type1
)
217 (fun-type-returns type2
))
218 (cond ((fun-type-wild-args type2
) (values t t
))
219 ((fun-type-wild-args type1
)
220 (cond ((fun-type-keyp type2
) (values nil nil
))
221 ((not (fun-type-rest type2
)) (values nil t
))
222 ((not (null (fun-type-required type2
)))
224 (t (and/type
(type= *universal-type
*
225 (fun-type-rest type2
))
230 ((not (and (fun-type-simple-p type1
)
231 (fun-type-simple-p type2
)))
233 (t (multiple-value-bind (min1 max1
) (fun-type-nargs type1
)
234 (multiple-value-bind (min2 max2
) (fun-type-nargs type2
)
235 (cond ((or (> max1 max2
) (< min1 min2
))
237 ((and (= min1 min2
) (= max1 max2
))
238 (and/type
(every-csubtypep
239 (fun-type-required type1
)
240 (fun-type-required type2
))
242 (fun-type-optional type1
)
243 (fun-type-optional type2
))))
246 (fun-type-required type1
)
247 (fun-type-optional type1
))
249 (fun-type-required type2
)
250 (fun-type-optional type2
))))))))))))
252 (!define-superclasses function
((function)) !cold-init-forms
)
254 ;;; The union or intersection of two FUNCTION types is FUNCTION.
255 (!define-type-method
(function :simple-union2
) (type1 type2
)
256 (declare (ignore type1 type2
))
257 (specifier-type 'function
))
258 (!define-type-method
(function :simple-intersection2
) (type1 type2
)
259 (let ((ftype (specifier-type 'function
)))
260 (cond ((eq type1 ftype
) type2
)
261 ((eq type2 ftype
) type1
)
262 (t (let ((rtype (values-type-intersection (fun-type-returns type1
)
263 (fun-type-returns type2
))))
264 (flet ((change-returns (ftype rtype
)
265 (declare (type fun-type ftype
) (type ctype rtype
))
266 (make-fun-type :required
(fun-type-required ftype
)
267 :optional
(fun-type-optional ftype
)
268 :keyp
(fun-type-keyp ftype
)
269 :keywords
(fun-type-keywords ftype
)
270 :allowp
(fun-type-allowp ftype
)
273 ((fun-type-wild-args type1
)
274 (if (fun-type-wild-args type2
)
275 (make-fun-type :wild-args t
277 (change-returns type2 rtype
)))
278 ((fun-type-wild-args type2
)
279 (change-returns type1 rtype
))
280 (t (multiple-value-bind (req opt rest
)
281 (args-type-op type1 type2
#'type-intersection
#'max
)
282 (make-fun-type :required req
286 :allowp
(and (fun-type-allowp type1
)
287 (fun-type-allowp type2
))
288 :returns rtype
))))))))))
290 ;;; The union or intersection of a subclass of FUNCTION with a
291 ;;; FUNCTION type is somewhat complicated.
292 (!define-type-method
(function :complex-intersection2
) (type1 type2
)
294 ((type= type1
(specifier-type 'function
)) type2
)
295 ((csubtypep type1
(specifier-type 'function
)) nil
)
296 (t :call-other-method
)))
297 (!define-type-method
(function :complex-union2
) (type1 type2
)
298 (declare (ignore type2
))
299 ;; TYPE2 is a FUNCTION type. If TYPE1 is a classoid type naming
300 ;; FUNCTION, then it is the union of the two; otherwise, there is no
303 ((type= type1
(specifier-type 'function
)) type1
)
306 (!define-type-method
(function :simple-
=) (type1 type2
)
307 (macrolet ((compare (comparator field
)
308 (let ((reader (symbolicate '#:fun-type- field
)))
309 `(,comparator
(,reader type1
) (,reader type2
)))))
310 (and/type
(compare type
= returns
)
311 (cond ((neq (fun-type-wild-args type1
) (fun-type-wild-args type2
))
313 ((eq (fun-type-wild-args type1
) t
)
315 (t (type=-args type1 type2
))))))
317 (!define-type-class constant
:inherits values
)
319 (!define-type-method
(constant :negate
) (type)
320 (error "NOT CONSTANT too confusing on ~S" (type-specifier type
)))
322 (!define-type-method
(constant :unparse
) (type)
323 `(constant-arg ,(type-specifier (constant-type-type type
))))
325 (!define-type-method
(constant :simple-
=) (type1 type2
)
326 (type= (constant-type-type type1
) (constant-type-type type2
)))
328 (!def-type-translator constant-arg
(type)
329 (make-constant-type :type
(single-value-specifier-type type
)))
331 ;;; Return the lambda-list-like type specification corresponding
333 (declaim (ftype (function (args-type) list
) unparse-args-types
))
334 (defun unparse-args-types (type)
337 (dolist (arg (args-type-required type
))
338 (result (type-specifier arg
)))
340 (when (args-type-optional type
)
342 (dolist (arg (args-type-optional type
))
343 (result (type-specifier arg
))))
345 (when (args-type-rest type
)
347 (result (type-specifier (args-type-rest type
))))
349 (when (args-type-keyp type
)
351 (dolist (key (args-type-keywords type
))
352 (result (list (key-info-name key
)
353 (type-specifier (key-info-type key
))))))
355 (when (args-type-allowp type
)
356 (result '&allow-other-keys
))
360 (!def-type-translator function
(&optional
(args '*) (result '*))
361 (make-fun-type :args args
362 :returns
(coerce-to-values (values-specifier-type result
))))
364 (!def-type-translator values
(&rest values
)
365 (make-values-type :args values
))
367 ;;;; VALUES types interfaces
369 ;;;; We provide a few special operations that can be meaningfully used
370 ;;;; on VALUES types (as well as on any other type).
372 (defun type-single-value-p (type)
373 (and (values-type-p type
)
374 (not (values-type-rest type
))
375 (null (values-type-optional type
))
376 (singleton-p (values-type-required type
))))
378 ;;; Return the type of the first value indicated by TYPE. This is used
379 ;;; by people who don't want to have to deal with VALUES types.
380 #!-sb-fluid
(declaim (freeze-type values-type
))
381 ; (inline single-value-type))
382 (defun single-value-type (type)
383 (declare (type ctype type
))
384 (cond ((eq type
*wild-type
*)
386 ((eq type
*empty-type
*)
388 ((not (values-type-p type
))
390 (t (or (car (args-type-required type
))
391 (car (args-type-optional type
))
392 (args-type-rest type
)
393 (specifier-type 'null
)))))
395 ;;; Return the minimum number of arguments that a function can be
396 ;;; called with, and the maximum number or NIL. If not a function
397 ;;; type, return NIL, NIL.
398 (defun fun-type-nargs (type)
399 (declare (type ctype type
))
400 (if (and (fun-type-p type
) (not (fun-type-wild-args type
)))
401 (let ((fixed (length (args-type-required type
))))
402 (if (or (args-type-rest type
)
403 (args-type-keyp type
)
404 (args-type-allowp type
))
406 (values fixed
(+ fixed
(length (args-type-optional type
))))))
409 ;;; Determine whether TYPE corresponds to a definite number of values.
410 ;;; The first value is a list of the types for each value, and the
411 ;;; second value is the number of values. If the number of values is
412 ;;; not fixed, then return NIL and :UNKNOWN.
413 (defun values-types (type)
414 (declare (type ctype type
))
415 (cond ((or (eq type
*wild-type
*) (eq type
*empty-type
*))
416 (values nil
:unknown
))
417 ((or (args-type-optional type
)
418 (args-type-rest type
))
419 (values nil
:unknown
))
421 (let ((req (args-type-required type
)))
422 (values req
(length req
))))))
424 ;;; Return two values:
425 ;;; 1. A list of all the positional (fixed and optional) types.
426 ;;; 2. The &REST type (if any). If no &REST, then the DEFAULT-TYPE.
427 (defun values-type-types (type &optional
(default-type *empty-type
*))
428 (declare (type ctype type
))
429 (if (eq type
*wild-type
*)
430 (values nil
*universal-type
*)
431 (values (append (args-type-required type
)
432 (args-type-optional type
))
433 (cond ((args-type-rest type
))
436 ;;; types of values in (the <type> (values o_1 ... o_n))
437 (defun values-type-out (type count
)
438 (declare (type ctype type
) (type unsigned-byte count
))
439 (if (eq type
*wild-type
*)
440 (make-list count
:initial-element
*universal-type
*)
442 (flet ((process-types (types)
443 (loop for type in types
447 (process-types (values-type-required type
))
448 (process-types (values-type-optional type
))
450 (loop with rest
= (the ctype
(values-type-rest type
))
455 ;;; types of variable in (m-v-bind (v_1 ... v_n) (the <type> ...
456 (defun values-type-in (type count
)
457 (declare (type ctype type
) (type unsigned-byte count
))
458 (if (eq type
*wild-type
*)
459 (make-list count
:initial-element
*universal-type
*)
461 (let ((null-type (specifier-type 'null
)))
462 (loop for type in
(values-type-required type
)
466 (loop for type in
(values-type-optional type
)
469 do
(res (type-union type null-type
)))
471 (loop with rest
= (acond ((values-type-rest type
)
472 (type-union it null-type
))
478 ;;; Return a list of OPERATION applied to the types in TYPES1 and
479 ;;; TYPES2, padding with REST2 as needed. TYPES1 must not be shorter
480 ;;; than TYPES2. The second value is T if OPERATION always returned a
481 ;;; true second value.
482 (defun fixed-values-op (types1 types2 rest2 operation
)
483 (declare (list types1 types2
) (type ctype rest2
) (type function operation
))
485 (values (mapcar (lambda (t1 t2
)
486 (multiple-value-bind (res win
)
487 (funcall operation t1 t2
)
493 (make-list (- (length types1
) (length types2
))
494 :initial-element rest2
)))
497 ;;; If TYPE isn't a values type, then make it into one.
498 (defun-cached (%coerce-to-values
500 :hash-function
(lambda (type)
501 (logand (type-hash-value type
)
504 (cond ((multiple-value-bind (res sure
)
505 (csubtypep (specifier-type 'null
) type
)
506 (and (not res
) sure
))
507 ;; FIXME: What should we do with (NOT SURE)?
508 (make-values-type :required
(list type
) :rest
*universal-type
*))
510 (make-values-type :optional
(list type
) :rest
*universal-type
*))))
512 (defun coerce-to-values (type)
513 (declare (type ctype type
))
514 (cond ((or (eq type
*universal-type
*)
515 (eq type
*wild-type
*))
517 ((values-type-p type
)
519 (t (%coerce-to-values type
))))
521 ;;; Return type, corresponding to ANSI short form of VALUES type
523 (defun make-short-values-type (types)
524 (declare (list types
))
525 (let ((last-required (position-if
527 (not/type
(csubtypep (specifier-type 'null
) type
)))
531 (make-values-type :required
(subseq types
0 (1+ last-required
))
532 :optional
(subseq types
(1+ last-required
))
533 :rest
*universal-type
*)
534 (make-values-type :optional types
:rest
*universal-type
*))))
536 (defun make-single-value-type (type)
537 (make-values-type :required
(list type
)))
539 ;;; Do the specified OPERATION on TYPE1 and TYPE2, which may be any
540 ;;; type, including VALUES types. With VALUES types such as:
543 ;;; we compute the more useful result
544 ;;; (VALUES (<operation> a0 b0) (<operation> a1 b1))
545 ;;; rather than the precise result
546 ;;; (<operation> (values a0 a1) (values b0 b1))
547 ;;; This has the virtue of always keeping the VALUES type specifier
548 ;;; outermost, and retains all of the information that is really
549 ;;; useful for static type analysis. We want to know what is always
550 ;;; true of each value independently. It is worthless to know that if
551 ;;; the first value is B0 then the second will be B1.
553 ;;; If the VALUES count signatures differ, then we produce a result with
554 ;;; the required VALUE count chosen by NREQ when applied to the number
555 ;;; of required values in TYPE1 and TYPE2. Any &KEY values become
556 ;;; &REST T (anyone who uses keyword values deserves to lose.)
558 ;;; The second value is true if the result is definitely empty or if
559 ;;; OPERATION returned true as its second value each time we called
560 ;;; it. Since we approximate the intersection of VALUES types, the
561 ;;; second value being true doesn't mean the result is exact.
562 (defun args-type-op (type1 type2 operation nreq
)
563 (declare (type ctype type1 type2
)
564 (type function operation nreq
))
565 (when (eq type1 type2
)
567 (multiple-value-bind (types1 rest1
)
568 (values-type-types type1
)
569 (multiple-value-bind (types2 rest2
)
570 (values-type-types type2
)
571 (multiple-value-bind (rest rest-exact
)
572 (funcall operation rest1 rest2
)
573 (multiple-value-bind (res res-exact
)
574 (if (< (length types1
) (length types2
))
575 (fixed-values-op types2 types1 rest1 operation
)
576 (fixed-values-op types1 types2 rest2 operation
))
577 (let* ((req (funcall nreq
578 (length (args-type-required type1
))
579 (length (args-type-required type2
))))
580 (required (subseq res
0 req
))
581 (opt (subseq res req
)))
582 (values required opt rest
583 (and rest-exact res-exact
))))))))
585 (defun values-type-op (type1 type2 operation nreq
)
586 (multiple-value-bind (required optional rest exactp
)
587 (args-type-op type1 type2 operation nreq
)
588 (values (make-values-type :required required
593 (defun type=-args
(type1 type2
)
594 (macrolet ((compare (comparator field
)
595 (let ((reader (symbolicate '#:args-type- field
)))
596 `(,comparator
(,reader type1
) (,reader type2
)))))
598 (cond ((null (args-type-rest type1
))
599 (values (null (args-type-rest type2
)) t
))
600 ((null (args-type-rest type2
))
603 (compare type
= rest
)))
604 (and/type
(and/type
(compare type
=-list required
)
605 (compare type
=-list optional
))
606 (if (or (args-type-keyp type1
) (args-type-keyp type2
))
610 ;;; Do a union or intersection operation on types that might be values
611 ;;; types. The result is optimized for utility rather than exactness,
612 ;;; but it is guaranteed that it will be no smaller (more restrictive)
613 ;;; than the precise result.
615 ;;; The return convention seems to be analogous to
616 ;;; TYPES-EQUAL-OR-INTERSECT. -- WHN 19990910.
617 (defun-cached (values-type-union :hash-function type-cache-hash
620 :init-wrapper
!cold-init-forms
)
621 ((type1 eq
) (type2 eq
))
622 (declare (type ctype type1 type2
))
623 (cond ((or (eq type1
*wild-type
*) (eq type2
*wild-type
*)) *wild-type
*)
624 ((eq type1
*empty-type
*) type2
)
625 ((eq type2
*empty-type
*) type1
)
627 (values (values-type-op type1 type2
#'type-union
#'min
)))))
629 (defun-cached (values-type-intersection :hash-function type-cache-hash
631 :default
(values nil
)
632 :init-wrapper
!cold-init-forms
)
633 ((type1 eq
) (type2 eq
))
634 (declare (type ctype type1 type2
))
635 (cond ((eq type1
*wild-type
*)
636 (coerce-to-values type2
))
637 ((or (eq type2
*wild-type
*) (eq type2
*universal-type
*))
639 ((or (eq type1
*empty-type
*) (eq type2
*empty-type
*))
641 ((and (not (values-type-p type2
))
642 (values-type-required type1
))
643 (let ((req1 (values-type-required type1
)))
644 (make-values-type :required
(cons (type-intersection (first req1
) type2
)
646 :optional
(values-type-optional type1
)
647 :rest
(values-type-rest type1
)
648 :allowp
(values-type-allowp type1
))))
650 (values (values-type-op type1
(coerce-to-values type2
)
654 ;;; This is like TYPES-EQUAL-OR-INTERSECT, except that it sort of
655 ;;; works on VALUES types. Note that due to the semantics of
656 ;;; VALUES-TYPE-INTERSECTION, this might return (VALUES T T) when
657 ;;; there isn't really any intersection.
658 (defun values-types-equal-or-intersect (type1 type2
)
659 (cond ((or (eq type1
*empty-type
*) (eq type2
*empty-type
*))
661 ((or (eq type1
*wild-type
*) (eq type2
*wild-type
*))
664 (let ((res (values-type-intersection type1 type2
)))
665 (values (not (eq res
*empty-type
*))
668 ;;; a SUBTYPEP-like operation that can be used on any types, including
670 (defun-cached (values-subtypep :hash-function type-cache-hash
673 :default
(values nil
:empty
)
674 :init-wrapper
!cold-init-forms
)
675 ((type1 eq
) (type2 eq
))
676 (declare (type ctype type1 type2
))
677 (cond ((or (eq type2
*wild-type
*) (eq type2
*universal-type
*)
678 (eq type1
*empty-type
*))
680 ((eq type1
*wild-type
*)
681 (values (eq type2
*wild-type
*) t
))
682 ((or (eq type2
*empty-type
*)
683 (not (values-types-equal-or-intersect type1 type2
)))
685 ((and (not (values-type-p type2
))
686 (values-type-required type1
))
687 (csubtypep (first (values-type-required type1
))
689 (t (setq type2
(coerce-to-values type2
))
690 (multiple-value-bind (types1 rest1
) (values-type-types type1
)
691 (multiple-value-bind (types2 rest2
) (values-type-types type2
)
692 (cond ((< (length (values-type-required type1
))
693 (length (values-type-required type2
)))
695 ((< (length types1
) (length types2
))
698 (do ((t1 types1
(rest t1
))
699 (t2 types2
(rest t2
)))
701 (csubtypep rest1 rest2
))
702 (multiple-value-bind (res win-p
)
703 (csubtypep (first t1
) (first t2
))
705 (return (values nil nil
)))
707 (return (values nil t
))))))))))))
709 ;;;; type method interfaces
711 ;;; like SUBTYPEP, only works on CTYPE structures
712 (defun-cached (csubtypep :hash-function type-cache-hash
715 :default
(values nil
:empty
)
716 :init-wrapper
!cold-init-forms
)
717 ((type1 eq
) (type2 eq
))
718 (declare (type ctype type1 type2
))
719 (cond ((or (eq type1 type2
)
720 (eq type1
*empty-type
*)
721 (eq type2
*universal-type
*))
724 ((eq type1
*universal-type
*)
727 (!invoke-type-method
:simple-subtypep
:complex-subtypep-arg2
729 :complex-arg1
:complex-subtypep-arg1
))))
731 ;;; Just parse the type specifiers and call CSUBTYPE.
732 (defun sb!xc
:subtypep
(type1 type2
&optional environment
)
734 "Return two values indicating the relationship between type1 and type2.
735 If values are T and T, type1 definitely is a subtype of type2.
736 If values are NIL and T, type1 definitely is not a subtype of type2.
737 If values are NIL and NIL, it couldn't be determined."
738 (declare (ignore environment
))
739 (csubtypep (specifier-type type1
) (specifier-type type2
)))
741 ;;; If two types are definitely equivalent, return true. The second
742 ;;; value indicates whether the first value is definitely correct.
743 ;;; This should only fail in the presence of HAIRY types.
744 (defun-cached (type= :hash-function type-cache-hash
747 :default
(values nil
:empty
)
748 :init-wrapper
!cold-init-forms
)
749 ((type1 eq
) (type2 eq
))
750 (declare (type ctype type1 type2
))
753 (!invoke-type-method
:simple-
= :complex-
= type1 type2
)))
755 ;;; Not exactly the negation of TYPE=, since when the relationship is
756 ;;; uncertain, we still return NIL, NIL. This is useful in cases where
757 ;;; the conservative assumption is =.
758 (defun type/= (type1 type2
)
759 (declare (type ctype type1 type2
))
760 (multiple-value-bind (res win
) (type= type1 type2
)
765 ;;; the type method dispatch case of TYPE-UNION2
766 (defun %type-union2
(type1 type2
)
767 ;; As in %TYPE-INTERSECTION2, it seems to be a good idea to give
768 ;; both argument orders a chance at COMPLEX-INTERSECTION2. Unlike
769 ;; %TYPE-INTERSECTION2, though, I don't have a specific case which
770 ;; demonstrates this is actually necessary. Also unlike
771 ;; %TYPE-INTERSECTION2, there seems to be no need to distinguish
772 ;; between not finding a method and having a method return NIL.
774 (!invoke-type-method
:simple-union2
:complex-union2
777 (declare (inline 1way
))
778 (or (1way type1 type2
)
779 (1way type2 type1
))))
781 ;;; Find a type which includes both types. Any inexactness is
782 ;;; represented by the fuzzy element types; we return a single value
783 ;;; that is precise to the best of our knowledge. This result is
784 ;;; simplified into the canonical form, thus is not a UNION-TYPE
785 ;;; unless we find no other way to represent the result.
786 (defun-cached (type-union2 :hash-function type-cache-hash
788 :init-wrapper
!cold-init-forms
)
789 ((type1 eq
) (type2 eq
))
790 ;; KLUDGE: This was generated from TYPE-INTERSECTION2 by Ye Olde Cut And
791 ;; Paste technique of programming. If it stays around (as opposed to
792 ;; e.g. fading away in favor of some CLOS solution) the shared logic
793 ;; should probably become shared code. -- WHN 2001-03-16
794 (declare (type ctype type1 type2
))
796 (cond ((eq type1 type2
)
798 ;; CSUBTYPEP for array-types answers questions about the
799 ;; specialized type, yet for union we want to take the
800 ;; expressed type in account too.
801 ((and (not (and (array-type-p type1
) (array-type-p type2
)))
802 (or (setf t2
(csubtypep type1 type2
))
803 (csubtypep type2 type1
)))
805 ((or (union-type-p type1
)
806 (union-type-p type2
))
807 ;; Unions of UNION-TYPE should have the UNION-TYPE-TYPES
808 ;; values broken out and united separately. The full TYPE-UNION
809 ;; function knows how to do this, so let it handle it.
810 (type-union type1 type2
))
812 ;; the ordinary case: we dispatch to type methods
813 (%type-union2 type1 type2
)))))
815 ;;; the type method dispatch case of TYPE-INTERSECTION2
816 (defun %type-intersection2
(type1 type2
)
817 ;; We want to give both argument orders a chance at
818 ;; COMPLEX-INTERSECTION2. Without that, the old CMU CL type
819 ;; methods could give noncommutative results, e.g.
820 ;; (TYPE-INTERSECTION2 *EMPTY-TYPE* SOME-HAIRY-TYPE)
822 ;; (TYPE-INTERSECTION2 SOME-HAIRY-TYPE *EMPTY-TYPE*)
823 ;; => #<NAMED-TYPE NIL>, T
824 ;; We also need to distinguish between the case where we found a
825 ;; type method, and it returned NIL, and the case where we fell
826 ;; through without finding any type method. An example of the first
827 ;; case is the intersection of a HAIRY-TYPE with some ordinary type.
828 ;; An example of the second case is the intersection of two
829 ;; completely-unrelated types, e.g. CONS and NUMBER, or SYMBOL and
832 ;; (Why yes, CLOS probably *would* be nicer..)
834 (!invoke-type-method
:simple-intersection2
:complex-intersection2
836 :default
:call-other-method
)))
837 (declare (inline 1way
))
838 (let ((xy (1way type1 type2
)))
839 (or (and (not (eql xy
:call-other-method
)) xy
)
840 (let ((yx (1way type2 type1
)))
841 (or (and (not (eql yx
:call-other-method
)) yx
)
842 (cond ((and (eql xy
:call-other-method
)
843 (eql yx
:call-other-method
))
848 (defun-cached (type-intersection2 :hash-function type-cache-hash
852 :init-wrapper
!cold-init-forms
)
853 ((type1 eq
) (type2 eq
))
854 (declare (type ctype type1 type2
))
855 (cond ((eq type1 type2
)
856 ;; FIXME: For some reason, this doesn't catch e.g. type1 =
857 ;; type2 = (SPECIFIER-TYPE
858 ;; 'SOME-UNKNOWN-TYPE). Investigate. - CSR, 2002-04-10
860 ((or (intersection-type-p type1
)
861 (intersection-type-p type2
))
862 ;; Intersections of INTERSECTION-TYPE should have the
863 ;; INTERSECTION-TYPE-TYPES values broken out and intersected
864 ;; separately. The full TYPE-INTERSECTION function knows how
865 ;; to do that, so let it handle it.
866 (type-intersection type1 type2
))
868 ;; the ordinary case: we dispatch to type methods
869 (%type-intersection2 type1 type2
))))
871 ;;; Return as restrictive and simple a type as we can discover that is
872 ;;; no more restrictive than the intersection of TYPE1 and TYPE2. At
873 ;;; worst, we arbitrarily return one of the arguments as the first
874 ;;; value (trying not to return a hairy type).
875 (defun type-approx-intersection2 (type1 type2
)
876 (cond ((type-intersection2 type1 type2
))
877 ((hairy-type-p type1
) type2
)
880 ;;; a test useful for checking whether a derived type matches a
883 ;;; The first value is true unless the types don't intersect and
884 ;;; aren't equal. The second value is true if the first value is
885 ;;; definitely correct. NIL is considered to intersect with any type.
886 ;;; If T is a subtype of either type, then we also return T, T. This
887 ;;; way we recognize that hairy types might intersect with T.
888 (defun types-equal-or-intersect (type1 type2
)
889 (declare (type ctype type1 type2
))
890 (if (or (eq type1
*empty-type
*) (eq type2
*empty-type
*))
892 (let ((intersection2 (type-intersection2 type1 type2
)))
893 (cond ((not intersection2
)
894 (if (or (csubtypep *universal-type
* type1
)
895 (csubtypep *universal-type
* type2
))
898 ((eq intersection2
*empty-type
*) (values nil t
))
901 ;;; Return a Common Lisp type specifier corresponding to the TYPE
903 (defun type-specifier (type)
904 (declare (type ctype type
))
905 (funcall (type-class-unparse (type-class-info type
)) type
))
907 (defun-cached (type-negation :hash-function
(lambda (type)
908 (logand (type-hash-value type
)
913 :init-wrapper
!cold-init-forms
)
915 (declare (type ctype type
))
916 (funcall (type-class-negate (type-class-info type
)) type
))
918 ;;; (VALUES-SPECIFIER-TYPE and SPECIFIER-TYPE moved from here to
919 ;;; early-type.lisp by WHN ca. 19990201.)
921 ;;; Take a list of type specifiers, computing the translation of each
922 ;;; specifier and defining it as a builtin type.
923 (declaim (ftype (function (list) (values)) precompute-types
))
924 (defun precompute-types (specs)
926 (let ((res (specifier-type spec
)))
927 (unless (unknown-type-p res
)
928 (setf (info :type
:builtin spec
) res
)
929 ;; KLUDGE: the three copies of this idiom in this file (and
930 ;; the one in class.lisp as at sbcl-0.7.4.1x) should be
931 ;; coalesced, or perhaps the error-detecting code that
932 ;; disallows redefinition of :PRIMITIVE types should be
933 ;; rewritten to use *TYPE-SYSTEM-FINALIZED* (rather than
934 ;; *TYPE-SYSTEM-INITIALIZED*). The effect of this is not to
935 ;; cause redefinition errors when precompute-types is called
936 ;; for a second time while building the target compiler using
937 ;; the cross-compiler. -- CSR, trying to explain why this
938 ;; isn't completely wrong, 2002-06-07
939 (setf (info :type
:kind spec
) #+sb-xc-host
:defined
#-sb-xc-host
:primitive
))))
942 ;;;; general TYPE-UNION and TYPE-INTERSECTION operations
944 ;;;; These are fully general operations on CTYPEs: they'll always
945 ;;;; return a CTYPE representing the result.
947 ;;; shared logic for unions and intersections: Return a list of
948 ;;; types representing the same types as INPUT-TYPES, but with
949 ;;; COMPOUND-TYPEs satisfying %COMPOUND-TYPE-P broken up into their
950 ;;; component types, and with any SIMPLY2 simplifications applied.
952 ((def (name compound-type-p simplify2
)
953 `(defun ,name
(types)
955 (multiple-value-bind (first rest
)
956 (if (,compound-type-p
(car types
))
957 (values (car (compound-type-types (car types
)))
958 (append (cdr (compound-type-types (car types
)))
960 (values (car types
) (cdr types
)))
961 (let ((rest (,name rest
)) u
)
962 (dolist (r rest
(cons first rest
))
963 (when (setq u
(,simplify2 first r
))
964 (return (,name
(nsubstitute u r rest
)))))))))))
965 (def simplify-intersections intersection-type-p type-intersection2
)
966 (def simplify-unions union-type-p type-union2
))
968 (defun maybe-distribute-one-union (union-type types
)
969 (let* ((intersection (apply #'type-intersection types
))
970 (union (mapcar (lambda (x) (type-intersection x intersection
))
971 (union-type-types union-type
))))
972 (if (notany (lambda (x) (or (hairy-type-p x
)
973 (intersection-type-p x
)))
978 (defun type-intersection (&rest input-types
)
979 (%type-intersection input-types
))
980 (defun-cached (%type-intersection
:hash-bits
8
981 :hash-function
(lambda (x)
982 (logand (sxhash x
) #xff
)))
983 ((input-types equal
))
984 (let ((simplified-types (simplify-intersections input-types
)))
985 (declare (type list simplified-types
))
986 ;; We want to have a canonical representation of types (or failing
987 ;; that, punt to HAIRY-TYPE). Canonical representation would have
988 ;; intersections inside unions but not vice versa, since you can
989 ;; always achieve that by the distributive rule. But we don't want
990 ;; to just apply the distributive rule, since it would be too easy
991 ;; to end up with unreasonably huge type expressions. So instead
992 ;; we try to generate a simple type by distributing the union; if
993 ;; the type can't be made simple, we punt to HAIRY-TYPE.
994 (if (and (cdr simplified-types
) (some #'union-type-p simplified-types
))
995 (let* ((first-union (find-if #'union-type-p simplified-types
))
996 (other-types (coerce (remove first-union simplified-types
)
998 (distributed (maybe-distribute-one-union first-union
1001 (apply #'type-union distributed
)
1003 :specifier
`(and ,@(map 'list
1005 simplified-types
)))))
1007 ((null simplified-types
) *universal-type
*)
1008 ((null (cdr simplified-types
)) (car simplified-types
))
1009 (t (%make-intersection-type
1010 (some #'type-enumerable simplified-types
)
1011 simplified-types
))))))
1013 (defun type-union (&rest input-types
)
1014 (%type-union input-types
))
1015 (defun-cached (%type-union
:hash-bits
8
1016 :hash-function
(lambda (x)
1017 (logand (sxhash x
) #xff
)))
1018 ((input-types equal
))
1019 (let ((simplified-types (simplify-unions input-types
)))
1021 ((null simplified-types
) *empty-type
*)
1022 ((null (cdr simplified-types
)) (car simplified-types
))
1024 (every #'type-enumerable simplified-types
)
1025 simplified-types
)))))
1029 (!define-type-class named
)
1032 (macrolet ((frob (name var
)
1034 (setq ,var
(make-named-type :name
',name
))
1035 (setf (info :type
:kind
',name
)
1036 #+sb-xc-host
:defined
#-sb-xc-host
:primitive
)
1037 (setf (info :type
:builtin
',name
) ,var
))))
1038 ;; KLUDGE: In ANSI, * isn't really the name of a type, it's just a
1039 ;; special symbol which can be stuck in some places where an
1040 ;; ordinary type can go, e.g. (ARRAY * 1) instead of (ARRAY T 1).
1041 ;; In SBCL it also used to denote universal VALUES type.
1042 (frob * *wild-type
*)
1043 (frob nil
*empty-type
*)
1044 (frob t
*universal-type
*)
1045 ;; new in sbcl-0.9.5: these used to be CLASSOID types, but that
1046 ;; view of them was incompatible with requirements on the MOP
1047 ;; metaobject class hierarchy: the INSTANCE and
1048 ;; FUNCALLABLE-INSTANCE types are disjoint (instances have
1049 ;; instance-pointer-lowtag; funcallable-instances have
1050 ;; fun-pointer-lowtag), while FUNCALLABLE-STANDARD-OBJECT is
1051 ;; required to be a subclass of STANDARD-OBJECT. -- CSR,
1053 (frob instance
*instance-type
*)
1054 (frob funcallable-instance
*funcallable-instance-type
*)
1055 ;; new in sbcl-1.0.3.3: necessary to act as a join point for the
1056 ;; extended sequence hierarchy. (Might be removed later if we use
1057 ;; a dedicated FUNDAMENTAL-SEQUENCE class for this.)
1058 (frob extended-sequence
*extended-sequence-type
*))
1059 (setf *universal-fun-type
*
1060 (make-fun-type :wild-args t
1061 :returns
*wild-type
*)))
1063 (!define-type-method
(named :simple-
=) (type1 type2
)
1064 ;;(aver (not (eq type1 *wild-type*))) ; * isn't really a type.
1065 (values (eq type1 type2
) t
))
1067 (defun cons-type-might-be-empty-type (type)
1068 (declare (type cons-type type
))
1069 (let ((car-type (cons-type-car-type type
))
1070 (cdr-type (cons-type-cdr-type type
)))
1072 (if (cons-type-p car-type
)
1073 (cons-type-might-be-empty-type car-type
)
1074 (multiple-value-bind (yes surep
)
1075 (type= car-type
*empty-type
*)
1078 (if (cons-type-p cdr-type
)
1079 (cons-type-might-be-empty-type cdr-type
)
1080 (multiple-value-bind (yes surep
)
1081 (type= cdr-type
*empty-type
*)
1085 (!define-type-method
(named :complex-
=) (type1 type2
)
1087 ((and (eq type2
*empty-type
*)
1088 (or (and (intersection-type-p type1
)
1089 ;; not allowed to be unsure on these... FIXME: keep
1090 ;; the list of CL types that are intersection types
1091 ;; once and only once.
1092 (not (or (type= type1
(specifier-type 'ratio
))
1093 (type= type1
(specifier-type 'keyword
)))))
1094 (and (cons-type-p type1
)
1095 (cons-type-might-be-empty-type type1
))))
1096 ;; things like (AND (EQL 0) (SATISFIES ODDP)) or (AND FUNCTION
1097 ;; STREAM) can get here. In general, we can't really tell
1098 ;; whether these are equal to NIL or not, so
1100 ((type-might-contain-other-types-p type1
)
1101 (invoke-complex-=-other-method type1 type2
))
1102 (t (values nil t
))))
1104 (!define-type-method
(named :simple-subtypep
) (type1 type2
)
1105 (aver (not (eq type1
*wild-type
*))) ; * isn't really a type.
1106 (aver (not (eq type1 type2
)))
1107 (values (or (eq type1
*empty-type
*)
1108 (eq type2
*wild-type
*)
1109 (eq type2
*universal-type
*)) t
))
1111 (!define-type-method
(named :complex-subtypep-arg1
) (type1 type2
)
1112 ;; This AVER causes problems if we write accurate methods for the
1113 ;; union (and possibly intersection) types which then delegate to
1114 ;; us; while a user shouldn't get here, because of the odd status of
1115 ;; *wild-type* a type-intersection executed by the compiler can. -
1118 ;; (aver (not (eq type1 *wild-type*))) ; * isn't really a type.
1119 (cond ((eq type1
*empty-type
*)
1121 (;; When TYPE2 might be the universal type in disguise
1122 (type-might-contain-other-types-p type2
)
1123 ;; Now that the UNION and HAIRY COMPLEX-SUBTYPEP-ARG2 methods
1124 ;; can delegate to us (more or less as CALL-NEXT-METHOD) when
1125 ;; they're uncertain, we can't just barf on COMPOUND-TYPE and
1126 ;; HAIRY-TYPEs as we used to. Instead we deal with the
1127 ;; problem (where at least part of the problem is cases like
1128 ;; (SUBTYPEP T '(SATISFIES FOO))
1130 ;; (SUBTYPEP T '(AND (SATISFIES FOO) (SATISFIES BAR)))
1131 ;; where the second type is a hairy type like SATISFIES, or
1132 ;; is a compound type which might contain a hairy type) by
1133 ;; returning uncertainty.
1135 ((eq type1
*funcallable-instance-type
*)
1136 (values (eq type2
(specifier-type 'function
)) t
))
1138 ;; This case would have been picked off by the SIMPLE-SUBTYPEP
1139 ;; method, and so shouldn't appear here.
1140 (aver (not (named-type-p type2
)))
1141 ;; Since TYPE2 is not EQ *UNIVERSAL-TYPE* and is not another
1142 ;; named type in disguise, TYPE2 is not a superset of TYPE1.
1145 (!define-type-method
(named :complex-subtypep-arg2
) (type1 type2
)
1146 (aver (not (eq type2
*wild-type
*))) ; * isn't really a type.
1147 (cond ((eq type2
*universal-type
*)
1149 ;; some CONS types can conceal danger
1150 ((and (cons-type-p type1
) (cons-type-might-be-empty-type type1
))
1152 ((type-might-contain-other-types-p type1
)
1153 ;; those types can be other types in disguise. So we'd
1155 (invoke-complex-subtypep-arg1-method type1 type2
))
1156 ((and (or (eq type2
*instance-type
*)
1157 (eq type2
*funcallable-instance-type
*))
1158 (member-type-p type1
))
1159 ;; member types can be subtypep INSTANCE and
1160 ;; FUNCALLABLE-INSTANCE in surprising ways.
1161 (invoke-complex-subtypep-arg1-method type1 type2
))
1162 ((and (eq type2
*extended-sequence-type
*) (classoid-p type1
))
1163 (let* ((layout (classoid-layout type1
))
1164 (inherits (layout-inherits layout
))
1165 (sequencep (find (classoid-layout (find-classoid 'sequence
))
1167 (values (if sequencep t nil
) t
)))
1168 ((and (eq type2
*instance-type
*) (classoid-p type1
))
1169 (if (member type1
*non-instance-classoid-types
* :key
#'find-classoid
)
1171 (let* ((layout (classoid-layout type1
))
1172 (inherits (layout-inherits layout
))
1173 (functionp (find (classoid-layout (find-classoid 'function
))
1178 ((eq type1
(find-classoid 'function
))
1180 ((or (structure-classoid-p type1
)
1182 (condition-classoid-p type1
))
1184 (t (values nil nil
))))))
1185 ((and (eq type2
*funcallable-instance-type
*) (classoid-p type1
))
1186 (if (member type1
*non-instance-classoid-types
* :key
#'find-classoid
)
1188 (let* ((layout (classoid-layout type1
))
1189 (inherits (layout-inherits layout
))
1190 (functionp (find (classoid-layout (find-classoid 'function
))
1192 (values (if functionp t nil
) t
))))
1194 ;; FIXME: This seems to rely on there only being 4 or 5
1195 ;; NAMED-TYPE values, and the exclusion of various
1196 ;; possibilities above. It would be good to explain it and/or
1197 ;; rewrite it so that it's clearer.
1200 (!define-type-method
(named :complex-intersection2
) (type1 type2
)
1201 ;; FIXME: This assertion failed when I added it in sbcl-0.6.11.13.
1202 ;; Perhaps when bug 85 is fixed it can be reenabled.
1203 ;;(aver (not (eq type2 *wild-type*))) ; * isn't really a type.
1205 ((eq type2
*extended-sequence-type
*)
1207 (structure-classoid *empty-type
*)
1209 (if (member type1
*non-instance-classoid-types
* :key
#'find-classoid
)
1211 (if (find (classoid-layout (find-classoid 'sequence
))
1212 (layout-inherits (classoid-layout type1
)))
1216 (if (or (type-might-contain-other-types-p type1
)
1217 (member-type-p type1
))
1220 ((eq type2
*instance-type
*)
1222 (structure-classoid type1
)
1224 (if (and (not (member type1
*non-instance-classoid-types
*
1225 :key
#'find-classoid
))
1226 (not (eq type1
(find-classoid 'function
)))
1227 (not (find (classoid-layout (find-classoid 'function
))
1228 (layout-inherits (classoid-layout type1
)))))
1232 (if (or (type-might-contain-other-types-p type1
)
1233 (member-type-p type1
))
1236 ((eq type2
*funcallable-instance-type
*)
1238 (structure-classoid *empty-type
*)
1240 (if (member type1
*non-instance-classoid-types
* :key
#'find-classoid
)
1242 (if (find (classoid-layout (find-classoid 'function
))
1243 (layout-inherits (classoid-layout type1
)))
1245 (if (type= type1
(find-classoid 'function
))
1250 (if (or (type-might-contain-other-types-p type1
)
1251 (member-type-p type1
))
1254 (t (hierarchical-intersection2 type1 type2
))))
1256 (!define-type-method
(named :complex-union2
) (type1 type2
)
1257 ;; Perhaps when bug 85 is fixed this can be reenabled.
1258 ;;(aver (not (eq type2 *wild-type*))) ; * isn't really a type.
1260 ((eq type2
*extended-sequence-type
*)
1261 (if (classoid-p type1
)
1262 (if (or (member type1
*non-instance-classoid-types
*
1263 :key
#'find-classoid
)
1264 (not (find (classoid-layout (find-classoid 'sequence
))
1265 (layout-inherits (classoid-layout type1
)))))
1269 ((eq type2
*instance-type
*)
1270 (if (classoid-p type1
)
1271 (if (or (member type1
*non-instance-classoid-types
*
1272 :key
#'find-classoid
)
1273 (find (classoid-layout (find-classoid 'function
))
1274 (layout-inherits (classoid-layout type1
))))
1278 ((eq type2
*funcallable-instance-type
*)
1279 (if (classoid-p type1
)
1280 (if (or (member type1
*non-instance-classoid-types
*
1281 :key
#'find-classoid
)
1282 (not (find (classoid-layout (find-classoid 'function
))
1283 (layout-inherits (classoid-layout type1
)))))
1285 (if (eq type1
(specifier-type 'function
))
1289 (t (hierarchical-union2 type1 type2
))))
1291 (!define-type-method
(named :negate
) (x)
1292 (aver (not (eq x
*wild-type
*)))
1294 ((eq x
*universal-type
*) *empty-type
*)
1295 ((eq x
*empty-type
*) *universal-type
*)
1296 ((or (eq x
*instance-type
*)
1297 (eq x
*funcallable-instance-type
*)
1298 (eq x
*extended-sequence-type
*))
1299 (make-negation-type :type x
))
1300 (t (bug "NAMED type unexpected: ~S" x
))))
1302 (!define-type-method
(named :unparse
) (x)
1303 (named-type-name x
))
1305 ;;;; hairy and unknown types
1307 (!define-type-method
(hairy :negate
) (x)
1308 (make-negation-type :type x
))
1310 (!define-type-method
(hairy :unparse
) (x)
1311 (hairy-type-specifier x
))
1313 (!define-type-method
(hairy :simple-subtypep
) (type1 type2
)
1314 (let ((hairy-spec1 (hairy-type-specifier type1
))
1315 (hairy-spec2 (hairy-type-specifier type2
)))
1316 (cond ((equal-but-no-car-recursion hairy-spec1 hairy-spec2
)
1319 (values nil nil
)))))
1321 (!define-type-method
(hairy :complex-subtypep-arg2
) (type1 type2
)
1322 (invoke-complex-subtypep-arg1-method type1 type2
))
1324 (!define-type-method
(hairy :complex-subtypep-arg1
) (type1 type2
)
1325 (declare (ignore type1 type2
))
1328 (!define-type-method
(hairy :complex-
=) (type1 type2
)
1329 (if (and (unknown-type-p type2
)
1330 (let* ((specifier2 (unknown-type-specifier type2
))
1331 (name2 (if (consp specifier2
)
1334 (info :type
:kind name2
)))
1335 (let ((type2 (specifier-type (unknown-type-specifier type2
))))
1336 (if (unknown-type-p type2
)
1338 (type= type1 type2
)))
1341 (!define-type-method
(hairy :simple-intersection2
:complex-intersection2
)
1343 (if (type= type1 type2
)
1347 (!define-type-method
(hairy :simple-union2
)
1349 (if (type= type1 type2
)
1353 (!define-type-method
(hairy :simple-
=) (type1 type2
)
1354 (if (equal-but-no-car-recursion (hairy-type-specifier type1
)
1355 (hairy-type-specifier type2
))
1359 (!def-type-translator satisfies
(&whole whole fun
)
1360 (declare (ignore fun
))
1361 ;; Check legality of arguments.
1362 (destructuring-bind (satisfies predicate-name
) whole
1363 (declare (ignore satisfies
))
1364 (unless (symbolp predicate-name
)
1365 (error 'simple-type-error
1366 :datum predicate-name
1367 :expected-type
'symbol
1368 :format-control
"The SATISFIES predicate name is not a symbol: ~S"
1369 :format-arguments
(list predicate-name
))))
1371 (make-hairy-type :specifier whole
))
1375 (!define-type-method
(negation :negate
) (x)
1376 (negation-type-type x
))
1378 (!define-type-method
(negation :unparse
) (x)
1379 (if (type= (negation-type-type x
) (specifier-type 'cons
))
1381 `(not ,(type-specifier (negation-type-type x
)))))
1383 (!define-type-method
(negation :simple-subtypep
) (type1 type2
)
1384 (csubtypep (negation-type-type type2
) (negation-type-type type1
)))
1386 (!define-type-method
(negation :complex-subtypep-arg2
) (type1 type2
)
1387 (let* ((complement-type2 (negation-type-type type2
))
1388 (intersection2 (type-intersection2 type1
1391 ;; FIXME: if uncertain, maybe try arg1?
1392 (type= intersection2
*empty-type
*)
1393 (invoke-complex-subtypep-arg1-method type1 type2
))))
1395 (!define-type-method
(negation :complex-subtypep-arg1
) (type1 type2
)
1396 ;; "Incrementally extended heuristic algorithms tend inexorably toward the
1397 ;; incomprehensible." -- http://www.unlambda.com/~james/lambda/lambda.txt
1399 ;; You may not believe this. I couldn't either. But then I sat down
1400 ;; and drew lots of Venn diagrams. Comments involving a and b refer
1401 ;; to the call (subtypep '(not a) 'b) -- CSR, 2002-02-27.
1403 ;; (Several logical truths in this block are true as long as
1404 ;; b/=T. As of sbcl-0.7.1.28, it seems impossible to construct a
1405 ;; case with b=T where we actually reach this type method, but
1406 ;; we'll test for and exclude this case anyway, since future
1407 ;; maintenance might make it possible for it to end up in this
1409 (multiple-value-bind (equal certain
)
1410 (type= type2
*universal-type
*)
1412 (return (values nil nil
)))
1414 (return (values t t
))))
1415 (let ((complement-type1 (negation-type-type type1
)))
1416 ;; Do the special cases first, in order to give us a chance if
1417 ;; subtype/supertype relationships are hairy.
1418 (multiple-value-bind (equal certain
)
1419 (type= complement-type1 type2
)
1420 ;; If a = b, ~a is not a subtype of b (unless b=T, which was
1423 (return (values nil nil
)))
1425 (return (values nil t
))))
1426 ;; KLUDGE: ANSI requires that the SUBTYPEP result between any
1427 ;; two built-in atomic type specifiers never be uncertain. This
1428 ;; is hard to do cleanly for the built-in types whose
1429 ;; definitions include (NOT FOO), i.e. CONS and RATIO. However,
1430 ;; we can do it with this hack, which uses our global knowledge
1431 ;; that our implementation of the type system uses disjoint
1432 ;; implementation types to represent disjoint sets (except when
1433 ;; types are contained in other types). (This is a KLUDGE
1434 ;; because it's fragile. Various changes in internal
1435 ;; representation in the type system could make it start
1436 ;; confidently returning incorrect results.) -- WHN 2002-03-08
1437 (unless (or (type-might-contain-other-types-p complement-type1
)
1438 (type-might-contain-other-types-p type2
))
1439 ;; Because of the way our types which don't contain other
1440 ;; types are disjoint subsets of the space of possible values,
1441 ;; (SUBTYPEP '(NOT AA) 'B)=NIL when AA and B are simple (and B
1442 ;; is not T, as checked above).
1443 (return (values nil t
)))
1444 ;; The old (TYPE= TYPE1 TYPE2) branch would never be taken, as
1445 ;; TYPE1 and TYPE2 will only be equal if they're both NOT types,
1446 ;; and then the :SIMPLE-SUBTYPEP method would be used instead.
1447 ;; But a CSUBTYPEP relationship might still hold:
1448 (multiple-value-bind (equal certain
)
1449 (csubtypep complement-type1 type2
)
1450 ;; If a is a subtype of b, ~a is not a subtype of b (unless
1451 ;; b=T, which was excluded above).
1453 (return (values nil nil
)))
1455 (return (values nil t
))))
1456 (multiple-value-bind (equal certain
)
1457 (csubtypep type2 complement-type1
)
1458 ;; If b is a subtype of a, ~a is not a subtype of b. (FIXME:
1459 ;; That's not true if a=T. Do we know at this point that a is
1462 (return (values nil nil
)))
1464 (return (values nil t
))))
1465 ;; old CSR comment ca. 0.7.2, now obsoleted by the SIMPLE-CTYPE?
1466 ;; KLUDGE case above: Other cases here would rely on being able
1467 ;; to catch all possible cases, which the fragility of this type
1468 ;; system doesn't inspire me; for instance, if a is type= to ~b,
1469 ;; then we want T, T; if this is not the case and the types are
1470 ;; disjoint (have an intersection of *empty-type*) then we want
1471 ;; NIL, T; else if the union of a and b is the *universal-type*
1472 ;; then we want T, T. So currently we still claim to be unsure
1473 ;; about e.g. (subtypep '(not fixnum) 'single-float).
1475 ;; OTOH we might still get here:
1478 (!define-type-method
(negation :complex-
=) (type1 type2
)
1479 ;; (NOT FOO) isn't equivalent to anything that's not a negation
1480 ;; type, except possibly a type that might contain it in disguise.
1481 (declare (ignore type2
))
1482 (if (type-might-contain-other-types-p type1
)
1486 (!define-type-method
(negation :simple-intersection2
) (type1 type2
)
1487 (let ((not1 (negation-type-type type1
))
1488 (not2 (negation-type-type type2
)))
1490 ((csubtypep not1 not2
) type2
)
1491 ((csubtypep not2 not1
) type1
)
1492 ;; Why no analagous clause to the disjoint in the SIMPLE-UNION2
1493 ;; method, below? The clause would read
1495 ;; ((EQ (TYPE-UNION NOT1 NOT2) *UNIVERSAL-TYPE*) *EMPTY-TYPE*)
1497 ;; but with proper canonicalization of negation types, there's
1498 ;; no way of constructing two negation types with union of their
1499 ;; negations being the universal type.
1501 (aver (not (eq (type-union not1 not2
) *universal-type
*)))
1504 (!define-type-method
(negation :complex-intersection2
) (type1 type2
)
1506 ((csubtypep type1
(negation-type-type type2
)) *empty-type
*)
1507 ((eq (type-intersection type1
(negation-type-type type2
)) *empty-type
*)
1511 (!define-type-method
(negation :simple-union2
) (type1 type2
)
1512 (let ((not1 (negation-type-type type1
))
1513 (not2 (negation-type-type type2
)))
1515 ((csubtypep not1 not2
) type1
)
1516 ((csubtypep not2 not1
) type2
)
1517 ((eq (type-intersection not1 not2
) *empty-type
*)
1521 (!define-type-method
(negation :complex-union2
) (type1 type2
)
1523 ((csubtypep (negation-type-type type2
) type1
) *universal-type
*)
1524 ((eq (type-intersection type1
(negation-type-type type2
)) *empty-type
*)
1528 (!define-type-method
(negation :simple-
=) (type1 type2
)
1529 (type= (negation-type-type type1
) (negation-type-type type2
)))
1531 (!def-type-translator not
(typespec)
1532 (type-negation (specifier-type typespec
)))
1536 (!define-type-class number
)
1538 (declaim (inline numeric-type-equal
))
1539 (defun numeric-type-equal (type1 type2
)
1540 (and (eq (numeric-type-class type1
) (numeric-type-class type2
))
1541 (eq (numeric-type-format type1
) (numeric-type-format type2
))
1542 (eq (numeric-type-complexp type1
) (numeric-type-complexp type2
))))
1544 (!define-type-method
(number :simple-
=) (type1 type2
)
1546 (and (numeric-type-equal type1 type2
)
1547 (equalp (numeric-type-low type1
) (numeric-type-low type2
))
1548 (equalp (numeric-type-high type1
) (numeric-type-high type2
)))
1551 (!define-type-method
(number :negate
) (type)
1552 (if (and (null (numeric-type-low type
)) (null (numeric-type-high type
)))
1553 (make-negation-type :type type
)
1556 :type
(modified-numeric-type type
:low nil
:high nil
))
1558 ((null (numeric-type-low type
))
1559 (modified-numeric-type
1561 :low
(let ((h (numeric-type-high type
)))
1562 (if (consp h
) (car h
) (list h
)))
1564 ((null (numeric-type-high type
))
1565 (modified-numeric-type
1568 :high
(let ((l (numeric-type-low type
)))
1569 (if (consp l
) (car l
) (list l
)))))
1571 (modified-numeric-type
1574 :high
(let ((l (numeric-type-low type
)))
1575 (if (consp l
) (car l
) (list l
))))
1576 (modified-numeric-type
1578 :low
(let ((h (numeric-type-high type
)))
1579 (if (consp h
) (car h
) (list h
)))
1582 (!define-type-method
(number :unparse
) (type)
1583 (let* ((complexp (numeric-type-complexp type
))
1584 (low (numeric-type-low type
))
1585 (high (numeric-type-high type
))
1586 (base (case (numeric-type-class type
)
1588 (rational 'rational
)
1589 (float (or (numeric-type-format type
) 'float
))
1592 (cond ((and (eq base
'integer
) high low
)
1593 (let ((high-count (logcount high
))
1594 (high-length (integer-length high
)))
1596 (cond ((= high
0) '(integer 0 0))
1598 ((and (= high-count high-length
)
1599 (plusp high-length
))
1600 `(unsigned-byte ,high-length
))
1602 `(mod ,(1+ high
)))))
1603 ((and (= low sb
!xc
:most-negative-fixnum
)
1604 (= high sb
!xc
:most-positive-fixnum
))
1606 ((and (= low
(lognot high
))
1607 (= high-count high-length
)
1609 `(signed-byte ,(1+ high-length
)))
1611 `(integer ,low
,high
)))))
1612 (high `(,base
,(or low
'*) ,high
))
1614 (if (and (eq base
'integer
) (= low
0))
1622 (aver (neq base
+bounds
'real
))
1623 `(complex ,base
+bounds
))
1625 (aver (eq base
+bounds
'real
))
1628 ;;; Return true if X is "less than or equal" to Y, taking open bounds
1629 ;;; into consideration. CLOSED is the predicate used to test the bound
1630 ;;; on a closed interval (e.g. <=), and OPEN is the predicate used on
1631 ;;; open bounds (e.g. <). Y is considered to be the outside bound, in
1632 ;;; the sense that if it is infinite (NIL), then the test succeeds,
1633 ;;; whereas if X is infinite, then the test fails (unless Y is also
1636 ;;; This is for comparing bounds of the same kind, e.g. upper and
1637 ;;; upper. Use NUMERIC-BOUND-TEST* for different kinds of bounds.
1638 (defmacro numeric-bound-test
(x y closed open
)
1643 (,closed
(car ,x
) (car ,y
))
1644 (,closed
(car ,x
) ,y
)))
1650 ;;; This is used to compare upper and lower bounds. This is different
1651 ;;; from the same-bound case:
1652 ;;; -- Since X = NIL is -infinity, whereas y = NIL is +infinity, we
1653 ;;; return true if *either* arg is NIL.
1654 ;;; -- an open inner bound is "greater" and also squeezes the interval,
1655 ;;; causing us to use the OPEN test for those cases as well.
1656 (defmacro numeric-bound-test
* (x y closed open
)
1661 (,open
(car ,x
) (car ,y
))
1662 (,open
(car ,x
) ,y
)))
1668 ;;; Return whichever of the numeric bounds X and Y is "maximal"
1669 ;;; according to the predicates CLOSED (e.g. >=) and OPEN (e.g. >).
1670 ;;; This is only meaningful for maximizing like bounds, i.e. upper and
1671 ;;; upper. If MAX-P is true, then we return NIL if X or Y is NIL,
1672 ;;; otherwise we return the other arg.
1673 (defmacro numeric-bound-max
(x y closed open max-p
)
1676 `(cond ((not ,n-x
) ,(if max-p nil n-y
))
1677 ((not ,n-y
) ,(if max-p nil n-x
))
1680 (if (,closed
(car ,n-x
) (car ,n-y
)) ,n-x
,n-y
)
1681 (if (,open
(car ,n-x
) ,n-y
) ,n-x
,n-y
)))
1684 (if (,open
(car ,n-y
) ,n-x
) ,n-y
,n-x
)
1685 (if (,closed
,n-y
,n-x
) ,n-y
,n-x
))))))
1687 (!define-type-method
(number :simple-subtypep
) (type1 type2
)
1688 (let ((class1 (numeric-type-class type1
))
1689 (class2 (numeric-type-class type2
))
1690 (complexp2 (numeric-type-complexp type2
))
1691 (format2 (numeric-type-format type2
))
1692 (low1 (numeric-type-low type1
))
1693 (high1 (numeric-type-high type1
))
1694 (low2 (numeric-type-low type2
))
1695 (high2 (numeric-type-high type2
)))
1696 ;; If one is complex and the other isn't, they are disjoint.
1697 (cond ((not (or (eq (numeric-type-complexp type1
) complexp2
)
1700 ;; If the classes are specified and different, the types are
1701 ;; disjoint unless type2 is RATIONAL and type1 is INTEGER.
1702 ;; [ or type1 is INTEGER and type2 is of the form (RATIONAL
1703 ;; X X) for integral X, but this is dealt with in the
1704 ;; canonicalization inside MAKE-NUMERIC-TYPE ]
1705 ((not (or (eq class1 class2
)
1707 (and (eq class1
'integer
) (eq class2
'rational
))))
1709 ;; If the float formats are specified and different, the types
1711 ((not (or (eq (numeric-type-format type1
) format2
)
1714 ;; Check the bounds.
1715 ((and (numeric-bound-test low1 low2
>= >)
1716 (numeric-bound-test high1 high2
<= <))
1721 (!define-superclasses number
((number)) !cold-init-forms
)
1723 ;;; If the high bound of LOW is adjacent to the low bound of HIGH,
1724 ;;; then return true, otherwise NIL.
1725 (defun numeric-types-adjacent (low high
)
1726 (let ((low-bound (numeric-type-high low
))
1727 (high-bound (numeric-type-low high
)))
1728 (cond ((not (and low-bound high-bound
)) nil
)
1729 ((and (consp low-bound
) (consp high-bound
)) nil
)
1731 (let ((low-value (car low-bound
)))
1732 (or (eql low-value high-bound
)
1734 (load-time-value (make-unportable-float
1735 :single-float-negative-zero
)))
1736 (eql high-bound
0f0
))
1737 (and (eql low-value
0f0
)
1739 (load-time-value (make-unportable-float
1740 :single-float-negative-zero
))))
1742 (load-time-value (make-unportable-float
1743 :double-float-negative-zero
)))
1744 (eql high-bound
0d0
))
1745 (and (eql low-value
0d0
)
1747 (load-time-value (make-unportable-float
1748 :double-float-negative-zero
)))))))
1750 (let ((high-value (car high-bound
)))
1751 (or (eql high-value low-bound
)
1752 (and (eql high-value
1753 (load-time-value (make-unportable-float
1754 :single-float-negative-zero
)))
1755 (eql low-bound
0f0
))
1756 (and (eql high-value
0f0
)
1758 (load-time-value (make-unportable-float
1759 :single-float-negative-zero
))))
1760 (and (eql high-value
1761 (load-time-value (make-unportable-float
1762 :double-float-negative-zero
)))
1763 (eql low-bound
0d0
))
1764 (and (eql high-value
0d0
)
1766 (load-time-value (make-unportable-float
1767 :double-float-negative-zero
)))))))
1768 ((and (eq (numeric-type-class low
) 'integer
)
1769 (eq (numeric-type-class high
) 'integer
))
1770 (eql (1+ low-bound
) high-bound
))
1774 ;;; Return a numeric type that is a supertype for both TYPE1 and TYPE2.
1776 ;;; Old comment, probably no longer applicable:
1778 ;;; ### Note: we give up early to keep from dropping lots of
1779 ;;; information on the floor by returning overly general types.
1780 (!define-type-method
(number :simple-union2
) (type1 type2
)
1781 (declare (type numeric-type type1 type2
))
1782 (cond ((csubtypep type1 type2
) type2
)
1783 ((csubtypep type2 type1
) type1
)
1785 (let ((class1 (numeric-type-class type1
))
1786 (format1 (numeric-type-format type1
))
1787 (complexp1 (numeric-type-complexp type1
))
1788 (class2 (numeric-type-class type2
))
1789 (format2 (numeric-type-format type2
))
1790 (complexp2 (numeric-type-complexp type2
)))
1792 ((and (eq class1 class2
)
1793 (eq format1 format2
)
1794 (eq complexp1 complexp2
)
1795 (or (numeric-types-intersect type1 type2
)
1796 (numeric-types-adjacent type1 type2
)
1797 (numeric-types-adjacent type2 type1
)))
1802 :low
(numeric-bound-max (numeric-type-low type1
)
1803 (numeric-type-low type2
)
1805 :high
(numeric-bound-max (numeric-type-high type1
)
1806 (numeric-type-high type2
)
1808 ;; FIXME: These two clauses are almost identical, and the
1809 ;; consequents are in fact identical in every respect.
1810 ((and (eq class1
'rational
)
1811 (eq class2
'integer
)
1812 (eq format1 format2
)
1813 (eq complexp1 complexp2
)
1814 (integerp (numeric-type-low type2
))
1815 (integerp (numeric-type-high type2
))
1816 (= (numeric-type-low type2
) (numeric-type-high type2
))
1817 (or (numeric-types-adjacent type1 type2
)
1818 (numeric-types-adjacent type2 type1
)))
1823 :low
(numeric-bound-max (numeric-type-low type1
)
1824 (numeric-type-low type2
)
1826 :high
(numeric-bound-max (numeric-type-high type1
)
1827 (numeric-type-high type2
)
1829 ((and (eq class1
'integer
)
1830 (eq class2
'rational
)
1831 (eq format1 format2
)
1832 (eq complexp1 complexp2
)
1833 (integerp (numeric-type-low type1
))
1834 (integerp (numeric-type-high type1
))
1835 (= (numeric-type-low type1
) (numeric-type-high type1
))
1836 (or (numeric-types-adjacent type1 type2
)
1837 (numeric-types-adjacent type2 type1
)))
1842 :low
(numeric-bound-max (numeric-type-low type1
)
1843 (numeric-type-low type2
)
1845 :high
(numeric-bound-max (numeric-type-high type1
)
1846 (numeric-type-high type2
)
1852 (setf (info :type
:kind
'number
)
1853 #+sb-xc-host
:defined
#-sb-xc-host
:primitive
)
1854 (setf (info :type
:builtin
'number
)
1855 (make-numeric-type :complexp nil
)))
1857 (!def-type-translator complex
(&optional
(typespec '*))
1858 (if (eq typespec
'*)
1859 (specifier-type '(complex real
))
1860 (labels ((not-numeric ()
1861 (error "The component type for COMPLEX is not numeric: ~S"
1864 (error "The component type for COMPLEX is not a subtype of REAL: ~S"
1866 (complex1 (component-type)
1867 (unless (numeric-type-p component-type
)
1869 (when (eq (numeric-type-complexp component-type
) :complex
)
1871 (if (csubtypep component-type
(specifier-type '(eql 0)))
1873 (modified-numeric-type component-type
1874 :complexp
:complex
)))
1877 ((eq ctype
*empty-type
*) *empty-type
*)
1878 ((eq ctype
*universal-type
*) (not-real))
1879 ((typep ctype
'numeric-type
) (complex1 ctype
))
1880 ((typep ctype
'union-type
)
1882 (mapcar #'do-complex
(union-type-types ctype
))))
1883 ((typep ctype
'member-type
)
1885 (mapcar-member-type-members
1886 (lambda (x) (do-complex (ctype-of x
)))
1888 ((and (typep ctype
'intersection-type
)
1889 ;; FIXME: This is very much a
1890 ;; not-quite-worst-effort, but we are required to do
1891 ;; something here because of our representation of
1892 ;; RATIO as (AND RATIONAL (NOT INTEGER)): we must
1893 ;; allow users to ask about (COMPLEX RATIO). This
1894 ;; will of course fail to work right on such types
1895 ;; as (AND INTEGER (SATISFIES ZEROP))...
1896 (let ((numbers (remove-if-not
1898 (intersection-type-types ctype
))))
1900 (null (cdr numbers
))
1901 (eq (numeric-type-complexp (car numbers
)) :real
)
1902 (complex1 (car numbers
))))))
1904 (multiple-value-bind (subtypep certainly
)
1905 (csubtypep ctype
(specifier-type 'real
))
1906 (if (and (not subtypep
) certainly
)
1908 ;; ANSI just says that TYPESPEC is any subtype of
1909 ;; type REAL, not necessarily a NUMERIC-TYPE. In
1910 ;; particular, at this point TYPESPEC could legally
1911 ;; be a hairy type like (AND NUMBER (SATISFIES
1912 ;; REALP) (SATISFIES ZEROP)), in which case we fall
1913 ;; through the logic above and end up here,
1915 (bug "~@<(known bug #145): The type ~S is too hairy to be ~
1916 used for a COMPLEX component.~:@>"
1918 (let ((ctype (specifier-type typespec
)))
1919 (do-complex ctype
)))))
1921 ;;; If X is *, return NIL, otherwise return the bound, which must be a
1922 ;;; member of TYPE or a one-element list of a member of TYPE.
1923 #!-sb-fluid
(declaim (inline canonicalized-bound
))
1924 (defun canonicalized-bound (bound type
)
1925 (cond ((eq bound
'*) nil
)
1926 ((or (sb!xc
:typep bound type
)
1928 (sb!xc
:typep
(car bound
) type
)
1929 (null (cdr bound
))))
1932 (error "Bound is not ~S, a ~S or a list of a ~S: ~S"
1938 (!def-type-translator integer
(&optional
(low '*) (high '*))
1939 (let* ((l (canonicalized-bound low
'integer
))
1940 (lb (if (consp l
) (1+ (car l
)) l
))
1941 (h (canonicalized-bound high
'integer
))
1942 (hb (if (consp h
) (1- (car h
)) h
)))
1943 (if (and hb lb
(< hb lb
))
1945 (make-numeric-type :class
'integer
1947 :enumerable
(not (null (and l h
)))
1951 (defmacro !def-bounded-type
(type class format
)
1952 `(!def-type-translator
,type
(&optional
(low '*) (high '*))
1953 (let ((lb (canonicalized-bound low
',type
))
1954 (hb (canonicalized-bound high
',type
)))
1955 (if (not (numeric-bound-test* lb hb
<= <))
1957 (make-numeric-type :class
',class
1962 (!def-bounded-type rational rational nil
)
1964 ;;; Unlike CMU CL, we represent the types FLOAT and REAL as
1965 ;;; UNION-TYPEs of more primitive types, in order to make
1966 ;;; type representation more unique, avoiding problems in the
1967 ;;; simplification of things like
1968 ;;; (subtypep '(or (single-float -1.0 1.0) (single-float 0.1))
1969 ;;; '(or (real -1 7) (single-float 0.1) (single-float -1.0 1.0)))
1970 ;;; When we allowed REAL to remain as a separate NUMERIC-TYPE,
1971 ;;; it was too easy for the first argument to be simplified to
1972 ;;; '(SINGLE-FLOAT -1.0), and for the second argument to be simplified
1973 ;;; to '(OR (REAL -1 7) (SINGLE-FLOAT 0.1)) and then for the
1974 ;;; SUBTYPEP to fail (returning NIL,T instead of T,T) because
1975 ;;; the first argument can't be seen to be a subtype of any of the
1976 ;;; terms in the second argument.
1978 ;;; The old CMU CL way was:
1979 ;;; (!def-bounded-type float float nil)
1980 ;;; (!def-bounded-type real nil nil)
1982 ;;; FIXME: If this new way works for a while with no weird new
1983 ;;; problems, we can go back and rip out support for separate FLOAT
1984 ;;; and REAL flavors of NUMERIC-TYPE. The new way was added in
1985 ;;; sbcl-0.6.11.22, 2001-03-21.
1987 ;;; FIXME: It's probably necessary to do something to fix the
1988 ;;; analogous problem with INTEGER and RATIONAL types. Perhaps
1989 ;;; bounded RATIONAL types should be represented as (OR RATIO INTEGER).
1990 (defun coerce-bound (bound type upperp inner-coerce-bound-fun
)
1991 (declare (type function inner-coerce-bound-fun
))
1994 (funcall inner-coerce-bound-fun bound type upperp
)))
1995 (defun inner-coerce-real-bound (bound type upperp
)
1996 #+sb-xc-host
(declare (ignore upperp
))
1997 (let #+sb-xc-host
()
1999 ((nl (load-time-value (symbol-value 'sb
!xc
:most-negative-long-float
)))
2000 (pl (load-time-value (symbol-value 'sb
!xc
:most-positive-long-float
))))
2001 (let ((nbound (if (consp bound
) (car bound
) bound
))
2002 (consp (consp bound
)))
2006 (list (rational nbound
))
2010 ((floatp nbound
) bound
)
2012 ;; Coerce to the widest float format available, to avoid
2013 ;; unnecessary loss of precision, but don't coerce
2014 ;; unrepresentable numbers, except on the host where we
2015 ;; shouldn't be making these types (but KLUDGE: can't even
2016 ;; assert portably that we're not).
2020 (when (< nbound nl
) (return-from inner-coerce-real-bound nl
)))
2022 (when (> nbound pl
) (return-from inner-coerce-real-bound pl
))))
2023 (let ((result (coerce nbound
'long-float
)))
2024 (if consp
(list result
) result
)))))))))
2025 (defun inner-coerce-float-bound (bound type upperp
)
2026 #+sb-xc-host
(declare (ignore upperp
))
2027 (let #+sb-xc-host
()
2029 ((nd (load-time-value (symbol-value 'sb
!xc
:most-negative-double-float
)))
2030 (pd (load-time-value (symbol-value 'sb
!xc
:most-positive-double-float
)))
2031 (ns (load-time-value (symbol-value 'sb
!xc
:most-negative-single-float
)))
2032 (ps (load-time-value
2033 (symbol-value 'sb
!xc
:most-positive-single-float
))))
2034 (let ((nbound (if (consp bound
) (car bound
) bound
))
2035 (consp (consp bound
)))
2039 ((typep nbound
'single-float
) bound
)
2044 (when (< nbound ns
) (return-from inner-coerce-float-bound ns
)))
2046 (when (> nbound ps
) (return-from inner-coerce-float-bound ps
))))
2047 (let ((result (coerce nbound
'single-float
)))
2048 (if consp
(list result
) result
)))))
2051 ((typep nbound
'double-float
) bound
)
2056 (when (< nbound nd
) (return-from inner-coerce-float-bound nd
)))
2058 (when (> nbound pd
) (return-from inner-coerce-float-bound pd
))))
2059 (let ((result (coerce nbound
'double-float
)))
2060 (if consp
(list result
) result
)))))))))
2061 (defun coerced-real-bound (bound type upperp
)
2062 (coerce-bound bound type upperp
#'inner-coerce-real-bound
))
2063 (defun coerced-float-bound (bound type upperp
)
2064 (coerce-bound bound type upperp
#'inner-coerce-float-bound
))
2065 (!def-type-translator real
(&optional
(low '*) (high '*))
2066 (specifier-type `(or (float ,(coerced-real-bound low
'float nil
)
2067 ,(coerced-real-bound high
'float t
))
2068 (rational ,(coerced-real-bound low
'rational nil
)
2069 ,(coerced-real-bound high
'rational t
)))))
2070 (!def-type-translator float
(&optional
(low '*) (high '*))
2072 `(or (single-float ,(coerced-float-bound low
'single-float nil
)
2073 ,(coerced-float-bound high
'single-float t
))
2074 (double-float ,(coerced-float-bound low
'double-float nil
)
2075 ,(coerced-float-bound high
'double-float t
))
2076 #!+long-float
,(error "stub: no long float support yet"))))
2078 (defmacro !define-float-format
(f)
2079 `(!def-bounded-type
,f float
,f
))
2081 (!define-float-format short-float
)
2082 (!define-float-format single-float
)
2083 (!define-float-format double-float
)
2084 (!define-float-format long-float
)
2086 (defun numeric-types-intersect (type1 type2
)
2087 (declare (type numeric-type type1 type2
))
2088 (let* ((class1 (numeric-type-class type1
))
2089 (class2 (numeric-type-class type2
))
2090 (complexp1 (numeric-type-complexp type1
))
2091 (complexp2 (numeric-type-complexp type2
))
2092 (format1 (numeric-type-format type1
))
2093 (format2 (numeric-type-format type2
))
2094 (low1 (numeric-type-low type1
))
2095 (high1 (numeric-type-high type1
))
2096 (low2 (numeric-type-low type2
))
2097 (high2 (numeric-type-high type2
)))
2098 ;; If one is complex and the other isn't, then they are disjoint.
2099 (cond ((not (or (eq complexp1 complexp2
)
2100 (null complexp1
) (null complexp2
)))
2102 ;; If either type is a float, then the other must either be
2103 ;; specified to be a float or unspecified. Otherwise, they
2105 ((and (eq class1
'float
)
2106 (not (member class2
'(float nil
)))) nil
)
2107 ((and (eq class2
'float
)
2108 (not (member class1
'(float nil
)))) nil
)
2109 ;; If the float formats are specified and different, the
2110 ;; types are disjoint.
2111 ((not (or (eq format1 format2
) (null format1
) (null format2
)))
2114 ;; Check the bounds. This is a bit odd because we must
2115 ;; always have the outer bound of the interval as the
2117 (if (numeric-bound-test high1 high2
<= <)
2118 (or (and (numeric-bound-test low1 low2
>= >)
2119 (numeric-bound-test* low1 high2
<= <))
2120 (and (numeric-bound-test low2 low1
>= >)
2121 (numeric-bound-test* low2 high1
<= <)))
2122 (or (and (numeric-bound-test* low2 high1
<= <)
2123 (numeric-bound-test low2 low1
>= >))
2124 (and (numeric-bound-test high2 high1
<= <)
2125 (numeric-bound-test* high2 low1
>= >))))))))
2127 ;;; Take the numeric bound X and convert it into something that can be
2128 ;;; used as a bound in a numeric type with the specified CLASS and
2129 ;;; FORMAT. If UP-P is true, then we round up as needed, otherwise we
2130 ;;; round down. UP-P true implies that X is a lower bound, i.e. (N) > N.
2132 ;;; This is used by NUMERIC-TYPE-INTERSECTION to mash the bound into
2133 ;;; the appropriate type number. X may only be a float when CLASS is
2136 ;;; ### Note: it is possible for the coercion to a float to overflow
2137 ;;; or underflow. This happens when the bound doesn't fit in the
2138 ;;; specified format. In this case, we should really return the
2139 ;;; appropriate {Most | Least}-{Positive | Negative}-XXX-Float float
2140 ;;; of desired format. But these conditions aren't currently signalled
2141 ;;; in any useful way.
2143 ;;; Also, when converting an open rational bound into a float we
2144 ;;; should probably convert it to a closed bound of the closest float
2145 ;;; in the specified format. KLUDGE: In general, open float bounds are
2146 ;;; screwed up. -- (comment from original CMU CL)
2147 (defun round-numeric-bound (x class format up-p
)
2149 (let ((cx (if (consp x
) (car x
) x
)))
2153 (if (and (consp x
) (integerp cx
))
2154 (if up-p
(1+ cx
) (1- cx
))
2155 (if up-p
(ceiling cx
) (floor cx
))))
2159 ((and format
(subtypep format
'double-float
))
2160 (if (<= most-negative-double-float cx most-positive-double-float
)
2164 (if (<= most-negative-single-float cx most-positive-single-float
)
2166 (coerce cx
(or format
'single-float
))
2168 (if (consp x
) (list res
) res
)))))
2171 ;;; Handle the case of type intersection on two numeric types. We use
2172 ;;; TYPES-EQUAL-OR-INTERSECT to throw out the case of types with no
2173 ;;; intersection. If an attribute in TYPE1 is unspecified, then we use
2174 ;;; TYPE2's attribute, which must be at least as restrictive. If the
2175 ;;; types intersect, then the only attributes that can be specified
2176 ;;; and different are the class and the bounds.
2178 ;;; When the class differs, we use the more restrictive class. The
2179 ;;; only interesting case is RATIONAL/INTEGER, since RATIONAL includes
2182 ;;; We make the result lower (upper) bound the maximum (minimum) of
2183 ;;; the argument lower (upper) bounds. We convert the bounds into the
2184 ;;; appropriate numeric type before maximizing. This avoids possible
2185 ;;; confusion due to mixed-type comparisons (but I think the result is
2187 (!define-type-method
(number :simple-intersection2
) (type1 type2
)
2188 (declare (type numeric-type type1 type2
))
2189 (if (numeric-types-intersect type1 type2
)
2190 (let* ((class1 (numeric-type-class type1
))
2191 (class2 (numeric-type-class type2
))
2192 (class (ecase class1
2194 ((integer float
) class1
)
2195 (rational (if (eq class2
'integer
)
2198 (format (or (numeric-type-format type1
)
2199 (numeric-type-format type2
))))
2203 :complexp
(or (numeric-type-complexp type1
)
2204 (numeric-type-complexp type2
))
2205 :low
(numeric-bound-max
2206 (round-numeric-bound (numeric-type-low type1
)
2208 (round-numeric-bound (numeric-type-low type2
)
2211 :high
(numeric-bound-max
2212 (round-numeric-bound (numeric-type-high type1
)
2214 (round-numeric-bound (numeric-type-high type2
)
2219 ;;; Given two float formats, return the one with more precision. If
2220 ;;; either one is null, return NIL.
2221 (defun float-format-max (f1 f2
)
2223 (dolist (f *float-formats
* (error "bad float format: ~S" f1
))
2224 (when (or (eq f f1
) (eq f f2
))
2227 ;;; Return the result of an operation on TYPE1 and TYPE2 according to
2228 ;;; the rules of numeric contagion. This is always NUMBER, some float
2229 ;;; format (possibly complex) or RATIONAL. Due to rational
2230 ;;; canonicalization, there isn't much we can do here with integers or
2231 ;;; rational complex numbers.
2233 ;;; If either argument is not a NUMERIC-TYPE, then return NUMBER. This
2234 ;;; is useful mainly for allowing types that are technically numbers,
2235 ;;; but not a NUMERIC-TYPE.
2236 (defun numeric-contagion (type1 type2
)
2237 (if (and (numeric-type-p type1
) (numeric-type-p type2
))
2238 (let ((class1 (numeric-type-class type1
))
2239 (class2 (numeric-type-class type2
))
2240 (format1 (numeric-type-format type1
))
2241 (format2 (numeric-type-format type2
))
2242 (complexp1 (numeric-type-complexp type1
))
2243 (complexp2 (numeric-type-complexp type2
)))
2244 (cond ((or (null complexp1
)
2246 (specifier-type 'number
))
2250 :format
(ecase class2
2251 (float (float-format-max format1 format2
))
2252 ((integer rational
) format1
)
2254 ;; A double-float with any real number is a
2257 (if (eq format1
'double-float
)
2260 ;; A long-float with any real number is a
2263 (if (eq format1
'long-float
)
2266 :complexp
(if (or (eq complexp1
:complex
)
2267 (eq complexp2
:complex
))
2270 ((eq class2
'float
) (numeric-contagion type2 type1
))
2271 ((and (eq complexp1
:real
) (eq complexp2
:real
))
2273 :class
(and class1 class2
'rational
)
2276 (specifier-type 'number
))))
2277 (specifier-type 'number
)))
2281 (!define-type-class array
)
2283 (!define-type-method
(array :simple-
=) (type1 type2
)
2284 (cond ((not (and (equal (array-type-dimensions type1
)
2285 (array-type-dimensions type2
))
2286 (eq (array-type-complexp type1
)
2287 (array-type-complexp type2
))))
2289 ((or (unknown-type-p (array-type-element-type type1
))
2290 (unknown-type-p (array-type-element-type type2
)))
2291 (multiple-value-bind (equalp certainp
)
2292 (type= (array-type-element-type type1
)
2293 (array-type-element-type type2
))
2294 ;; By its nature, the call to TYPE= should never return
2295 ;; NIL, T, as we don't know what the UNKNOWN-TYPE will grow
2296 ;; up to be. -- CSR, 2002-08-19
2297 (aver (not (and (not equalp
) certainp
)))
2298 (values equalp certainp
)))
2300 (values (type= (array-type-specialized-element-type type1
)
2301 (array-type-specialized-element-type type2
))
2304 (!define-type-method
(array :negate
) (type)
2305 ;; FIXME (and hint to PFD): we're vulnerable here to attacks of the
2306 ;; form "are (AND ARRAY (NOT (ARRAY T))) and (OR (ARRAY BIT) (ARRAY
2307 ;; NIL) (ARRAY CHAR) ...) equivalent?" -- CSR, 2003-12-10
2308 (make-negation-type :type type
))
2310 (!define-type-method
(array :unparse
) (type)
2311 (let ((dims (array-type-dimensions type
))
2312 (eltype (type-specifier (array-type-element-type type
)))
2313 (complexp (array-type-complexp type
)))
2316 (if complexp
'array
'simple-array
)
2317 (if complexp
`(array ,eltype
) `(simple-array ,eltype
))))
2318 ((= (length dims
) 1)
2320 (if (eq (car dims
) '*)
2323 ((base-char #!-sb-unicode character
) 'base-string
)
2325 (t `(vector ,eltype
)))
2327 (bit `(bit-vector ,(car dims
)))
2328 ((base-char #!-sb-unicode character
)
2329 `(base-string ,(car dims
)))
2330 (t `(vector ,eltype
,(car dims
)))))
2331 (if (eq (car dims
) '*)
2333 (bit 'simple-bit-vector
)
2334 ((base-char #!-sb-unicode character
) 'simple-base-string
)
2335 ((t) 'simple-vector
)
2336 (t `(simple-array ,eltype
(*))))
2338 (bit `(simple-bit-vector ,(car dims
)))
2339 ((base-char #!-sb-unicode character
)
2340 `(simple-base-string ,(car dims
)))
2341 ((t) `(simple-vector ,(car dims
)))
2342 (t `(simple-array ,eltype
,dims
))))))
2345 `(array ,eltype
,dims
)
2346 `(simple-array ,eltype
,dims
))))))
2348 (!define-type-method
(array :simple-subtypep
) (type1 type2
)
2349 (let ((dims1 (array-type-dimensions type1
))
2350 (dims2 (array-type-dimensions type2
))
2351 (complexp2 (array-type-complexp type2
)))
2352 (cond (;; not subtypep unless dimensions are compatible
2353 (not (or (eq dims2
'*)
2354 (and (not (eq dims1
'*))
2355 ;; (sbcl-0.6.4 has trouble figuring out that
2356 ;; DIMS1 and DIMS2 must be lists at this
2357 ;; point, and knowing that is important to
2358 ;; compiling EVERY efficiently.)
2359 (= (length (the list dims1
))
2360 (length (the list dims2
)))
2361 (every (lambda (x y
)
2362 (or (eq y
'*) (eql x y
)))
2364 (the list dims2
)))))
2366 ;; not subtypep unless complexness is compatible
2367 ((not (or (eq complexp2
:maybe
)
2368 (eq (array-type-complexp type1
) complexp2
)))
2370 ;; Since we didn't fail any of the tests above, we win
2371 ;; if the TYPE2 element type is wild.
2372 ((eq (array-type-element-type type2
) *wild-type
*)
2374 (;; Since we didn't match any of the special cases above, if
2375 ;; either element type is unknown we can only give a good
2376 ;; answer if they are the same.
2377 (or (unknown-type-p (array-type-element-type type1
))
2378 (unknown-type-p (array-type-element-type type2
)))
2379 (if (type= (array-type-element-type type1
)
2380 (array-type-element-type type2
))
2383 (;; Otherwise, the subtype relationship holds iff the
2384 ;; types are equal, and they're equal iff the specialized
2385 ;; element types are identical.
2387 (values (type= (array-type-specialized-element-type type1
)
2388 (array-type-specialized-element-type type2
))
2391 (!define-superclasses array
2392 ((vector vector
) (array))
2395 (defun array-types-intersect (type1 type2
)
2396 (declare (type array-type type1 type2
))
2397 (let ((dims1 (array-type-dimensions type1
))
2398 (dims2 (array-type-dimensions type2
))
2399 (complexp1 (array-type-complexp type1
))
2400 (complexp2 (array-type-complexp type2
)))
2401 ;; See whether dimensions are compatible.
2402 (cond ((not (or (eq dims1
'*) (eq dims2
'*)
2403 (and (= (length dims1
) (length dims2
))
2404 (every (lambda (x y
)
2405 (or (eq x
'*) (eq y
'*) (= x y
)))
2408 ;; See whether complexpness is compatible.
2409 ((not (or (eq complexp1
:maybe
)
2410 (eq complexp2
:maybe
)
2411 (eq complexp1 complexp2
)))
2415 ;; If either element type is wild, then they intersect.
2416 ;; Otherwise, the types must be identical.
2418 ;; FIXME: There seems to have been a fair amount of
2419 ;; confusion about the distinction between requested element
2420 ;; type and specialized element type; here is one of
2421 ;; them. If we request an array to hold objects of an
2422 ;; unknown type, we can do no better than represent that
2423 ;; type as an array specialized on wild-type. We keep the
2424 ;; requested element-type in the -ELEMENT-TYPE slot, and
2425 ;; *WILD-TYPE* in the -SPECIALIZED-ELEMENT-TYPE. So, here,
2426 ;; we must test for the SPECIALIZED slot being *WILD-TYPE*,
2427 ;; not just the ELEMENT-TYPE slot. Maybe the return value
2428 ;; in that specific case should be T, NIL? Or maybe this
2429 ;; function should really be called
2430 ;; ARRAY-TYPES-COULD-POSSIBLY-INTERSECT? In any case, this
2431 ;; was responsible for bug #123, and this whole issue could
2432 ;; do with a rethink and/or a rewrite. -- CSR, 2002-08-21
2433 ((or (eq (array-type-specialized-element-type type1
) *wild-type
*)
2434 (eq (array-type-specialized-element-type type2
) *wild-type
*)
2435 (type= (array-type-specialized-element-type type1
)
2436 (array-type-specialized-element-type type2
)))
2442 (!define-type-method
(array :simple-union2
) (type1 type2
)
2443 (let* ((dims1 (array-type-dimensions type1
))
2444 (dims2 (array-type-dimensions type2
))
2445 (complexp1 (array-type-complexp type1
))
2446 (complexp2 (array-type-complexp type2
))
2447 (eltype1 (array-type-element-type type1
))
2448 (eltype2 (array-type-element-type type2
))
2449 (stype1 (array-type-specialized-element-type type1
))
2450 (stype2 (array-type-specialized-element-type type2
))
2451 (wild1 (eq eltype1
*wild-type
*))
2452 (wild2 (eq eltype2
*wild-type
*))
2454 (when (or wild1 wild2
2455 (and (or (setf e2
(csubtypep eltype1 eltype2
))
2456 (csubtypep eltype2 eltype1
))
2457 (type= stype1 stype2
)))
2459 :dimensions
(cond ((or (eq dims1
'*) (eq dims2
'*))
2461 ((equal dims1 dims2
)
2463 ((= (length dims1
) (length dims2
))
2464 (mapcar (lambda (x y
) (if (eq x y
) x
'*))
2468 :complexp
(if (eq complexp1 complexp2
) complexp1
:maybe
)
2469 :element-type
(if (or wild2 e2
) eltype2 eltype1
)
2470 :specialized-element-type
(if wild2 stype2 stype1
)))))
2472 (!define-type-method
(array :simple-intersection2
) (type1 type2
)
2473 (declare (type array-type type1 type2
))
2474 (if (array-types-intersect type1 type2
)
2475 (let ((dims1 (array-type-dimensions type1
))
2476 (dims2 (array-type-dimensions type2
))
2477 (complexp1 (array-type-complexp type1
))
2478 (complexp2 (array-type-complexp type2
))
2479 (eltype1 (array-type-element-type type1
))
2480 (eltype2 (array-type-element-type type2
))
2481 (stype1 (array-type-specialized-element-type type1
))
2482 (stype2 (array-type-specialized-element-type type2
)))
2483 (flet ((intersect ()
2485 :dimensions
(cond ((eq dims1
'*) dims2
)
2486 ((eq dims2
'*) dims1
)
2488 (mapcar (lambda (x y
) (if (eq x
'*) y x
))
2490 :complexp
(if (eq complexp1
:maybe
) complexp2 complexp1
)
2492 ((eq eltype1
*wild-type
*) eltype2
)
2493 ((eq eltype2
*wild-type
*) eltype1
)
2494 (t (type-intersection eltype1 eltype2
))))))
2495 (if (or (eq stype1
*wild-type
*) (eq stype2
*wild-type
*))
2496 (specialize-array-type (intersect))
2497 (let ((type (intersect)))
2498 (aver (type= stype1 stype2
))
2499 (setf (array-type-specialized-element-type type
) stype1
)
2503 ;;; Check a supplied dimension list to determine whether it is legal,
2504 ;;; and return it in canonical form (as either '* or a list).
2505 (defun canonical-array-dimensions (dims)
2510 (error "Arrays can't have a negative number of dimensions: ~S" dims
))
2511 (when (>= dims sb
!xc
:array-rank-limit
)
2512 (error "array type with too many dimensions: ~S" dims
))
2513 (make-list dims
:initial-element
'*))
2515 (when (>= (length dims
) sb
!xc
:array-rank-limit
)
2516 (error "array type with too many dimensions: ~S" dims
))
2519 (unless (and (integerp dim
)
2521 (< dim sb
!xc
:array-dimension-limit
))
2522 (error "bad dimension in array type: ~S" dim
))))
2525 (error "Array dimensions is not a list, integer or *:~% ~S" dims
))))
2529 (!define-type-class member
)
2531 (!define-type-method
(member :negate
) (type)
2532 (let ((xset (member-type-xset type
))
2533 (fp-zeroes (member-type-fp-zeroes type
)))
2535 ;; Hairy case, which needs to do a bit of float type
2536 ;; canonicalization.
2537 (apply #'type-intersection
2538 (if (xset-empty-p xset
)
2541 :type
(make-member-type :xset xset
)))
2544 (let* ((opposite (neg-fp-zero x
))
2545 (type (ctype-of opposite
)))
2548 :type
(modified-numeric-type type
:low nil
:high nil
))
2549 (modified-numeric-type type
:low nil
:high
(list opposite
))
2550 (make-member-type :members
(list opposite
))
2551 (modified-numeric-type type
:low
(list opposite
) :high nil
))))
2554 (make-negation-type :type type
))))
2556 (!define-type-method
(member :unparse
) (type)
2557 (let ((members (member-type-members type
)))
2559 ((equal members
'(nil)) 'null
)
2560 ((type= type
(specifier-type 'standard-char
)) 'standard-char
)
2561 (t `(member ,@members
)))))
2563 (!define-type-method
(member :simple-subtypep
) (type1 type2
)
2564 (values (and (xset-subset-p (member-type-xset type1
)
2565 (member-type-xset type2
))
2566 (subsetp (member-type-fp-zeroes type1
)
2567 (member-type-fp-zeroes type2
)))
2570 (!define-type-method
(member :complex-subtypep-arg1
) (type1 type2
)
2572 (mapc-member-type-members
2574 (multiple-value-bind (ok surep
) (ctypep elt type2
)
2576 (return-from punt
(values nil nil
)))
2578 (return-from punt
(values nil t
)))))
2582 ;;; We punt if the odd type is enumerable and intersects with the
2583 ;;; MEMBER type. If not enumerable, then it is definitely not a
2584 ;;; subtype of the MEMBER type.
2585 (!define-type-method
(member :complex-subtypep-arg2
) (type1 type2
)
2586 (cond ((not (type-enumerable type1
)) (values nil t
))
2587 ((types-equal-or-intersect type1 type2
)
2588 (invoke-complex-subtypep-arg1-method type1 type2
))
2589 (t (values nil t
))))
2591 (!define-type-method
(member :simple-intersection2
) (type1 type2
)
2592 (make-member-type :xset
(xset-intersection (member-type-xset type1
)
2593 (member-type-xset type2
))
2594 :fp-zeroes
(intersection (member-type-fp-zeroes type1
)
2595 (member-type-fp-zeroes type2
))))
2597 (!define-type-method
(member :complex-intersection2
) (type1 type2
)
2599 (let ((xset (alloc-xset))
2601 (mapc-member-type-members
2603 (multiple-value-bind (ok sure
) (ctypep member type1
)
2605 (return-from punt nil
))
2607 (if (fp-zero-p member
)
2608 (pushnew member fp-zeroes
)
2609 (add-to-xset member xset
)))))
2611 (if (and (xset-empty-p xset
) (not fp-zeroes
))
2613 (make-member-type :xset xset
:fp-zeroes fp-zeroes
)))))
2615 ;;; We don't need a :COMPLEX-UNION2, since the only interesting case is
2616 ;;; a union type, and the member/union interaction is handled by the
2617 ;;; union type method.
2618 (!define-type-method
(member :simple-union2
) (type1 type2
)
2619 (make-member-type :xset
(xset-union (member-type-xset type1
)
2620 (member-type-xset type2
))
2621 :fp-zeroes
(union (member-type-fp-zeroes type1
)
2622 (member-type-fp-zeroes type2
))))
2624 (!define-type-method
(member :simple-
=) (type1 type2
)
2625 (let ((xset1 (member-type-xset type1
))
2626 (xset2 (member-type-xset type2
))
2627 (l1 (member-type-fp-zeroes type1
))
2628 (l2 (member-type-fp-zeroes type2
)))
2629 (values (and (eql (xset-count xset1
) (xset-count xset2
))
2630 (xset-subset-p xset1 xset2
)
2631 (xset-subset-p xset2 xset1
)
2636 (!define-type-method
(member :complex-
=) (type1 type2
)
2637 (if (type-enumerable type1
)
2638 (multiple-value-bind (val win
) (csubtypep type2 type1
)
2639 (if (or val
(not win
))
2644 (!def-type-translator member
(&rest members
)
2646 (let (ms numbers char-codes
)
2647 (dolist (m (remove-duplicates members
))
2649 (float (if (zerop m
)
2651 (push (ctype-of m
) numbers
)))
2652 (real (push (ctype-of m
) numbers
))
2653 (character (push (sb!xc
:char-code m
) char-codes
))
2657 (make-member-type :members ms
)
2660 (make-character-set-type
2661 :pairs
(mapcar (lambda (x) (cons x x
))
2662 (sort char-codes
#'<)))
2664 (nreverse numbers
)))
2667 ;;;; intersection types
2669 ;;;; Until version 0.6.10.6, SBCL followed the original CMU CL approach
2670 ;;;; of punting on all AND types, not just the unreasonably complicated
2671 ;;;; ones. The change was motivated by trying to get the KEYWORD type
2672 ;;;; to behave sensibly:
2673 ;;;; ;; reasonable definition
2674 ;;;; (DEFTYPE KEYWORD () '(AND SYMBOL (SATISFIES KEYWORDP)))
2675 ;;;; ;; reasonable behavior
2676 ;;;; (AVER (SUBTYPEP 'KEYWORD 'SYMBOL))
2677 ;;;; Without understanding a little about the semantics of AND, we'd
2678 ;;;; get (SUBTYPEP 'KEYWORD 'SYMBOL)=>NIL,NIL and, for entirely
2679 ;;;; parallel reasons, (SUBTYPEP 'RATIO 'NUMBER)=>NIL,NIL. That's
2682 ;;;; We still follow the example of CMU CL to some extent, by punting
2683 ;;;; (to the opaque HAIRY-TYPE) on sufficiently complicated types
2686 (!define-type-class intersection
)
2688 (!define-type-method
(intersection :negate
) (type)
2690 (mapcar #'type-negation
(intersection-type-types type
))))
2692 ;;; A few intersection types have special names. The others just get
2693 ;;; mechanically unparsed.
2694 (!define-type-method
(intersection :unparse
) (type)
2695 (declare (type ctype type
))
2696 (or (find type
'(ratio keyword compiled-function
) :key
#'specifier-type
:test
#'type
=)
2697 `(and ,@(mapcar #'type-specifier
(intersection-type-types type
)))))
2699 ;;; shared machinery for type equality: true if every type in the set
2700 ;;; TYPES1 matches a type in the set TYPES2 and vice versa
2701 (defun type=-set
(types1 types2
)
2702 (flet ((type<=-set
(x y
)
2703 (declare (type list x y
))
2704 (every/type
(lambda (x y-element
)
2705 (any/type
#'type
= y-element x
))
2707 (and/type
(type<=-set types1 types2
)
2708 (type<=-set types2 types1
))))
2710 ;;; Two intersection types are equal if their subtypes are equal sets.
2712 ;;; FIXME: Might it be better to use
2713 ;;; (AND (SUBTYPEP X Y) (SUBTYPEP Y X))
2714 ;;; instead, since SUBTYPEP is the usual relationship that we care
2715 ;;; most about, so it would be good to leverage any ingenuity there
2716 ;;; in this more obscure method?
2717 (!define-type-method
(intersection :simple-
=) (type1 type2
)
2718 (type=-set
(intersection-type-types type1
)
2719 (intersection-type-types type2
)))
2721 (defun %intersection-complex-subtypep-arg1
(type1 type2
)
2722 (type= type1
(type-intersection type1 type2
)))
2724 (defun %intersection-simple-subtypep
(type1 type2
)
2725 (every/type
#'%intersection-complex-subtypep-arg1
2727 (intersection-type-types type2
)))
2729 (!define-type-method
(intersection :simple-subtypep
) (type1 type2
)
2730 (%intersection-simple-subtypep type1 type2
))
2732 (!define-type-method
(intersection :complex-subtypep-arg1
) (type1 type2
)
2733 (%intersection-complex-subtypep-arg1 type1 type2
))
2735 (defun %intersection-complex-subtypep-arg2
(type1 type2
)
2736 (every/type
#'csubtypep type1
(intersection-type-types type2
)))
2738 (!define-type-method
(intersection :complex-subtypep-arg2
) (type1 type2
)
2739 (%intersection-complex-subtypep-arg2 type1 type2
))
2741 ;;; FIXME: This will look eeriely familiar to readers of the UNION
2742 ;;; :SIMPLE-INTERSECTION2 :COMPLEX-INTERSECTION2 method. That's
2743 ;;; because it was generated by cut'n'paste methods. Given that
2744 ;;; intersections and unions have all sorts of symmetries known to
2745 ;;; mathematics, it shouldn't be beyond the ken of some programmers to
2746 ;;; reflect those symmetries in code in a way that ties them together
2747 ;;; more strongly than having two independent near-copies :-/
2748 (!define-type-method
(intersection :simple-union2
:complex-union2
)
2750 ;; Within this method, type2 is guaranteed to be an intersection
2752 (aver (intersection-type-p type2
))
2753 ;; Make sure to call only the applicable methods...
2754 (cond ((and (intersection-type-p type1
)
2755 (%intersection-simple-subtypep type1 type2
)) type2
)
2756 ((and (intersection-type-p type1
)
2757 (%intersection-simple-subtypep type2 type1
)) type1
)
2758 ((and (not (intersection-type-p type1
))
2759 (%intersection-complex-subtypep-arg2 type1 type2
))
2761 ((and (not (intersection-type-p type1
))
2762 (%intersection-complex-subtypep-arg1 type2 type1
))
2764 ;; KLUDGE: This special (and somewhat hairy) magic is required
2765 ;; to deal with the RATIONAL/INTEGER special case. The UNION
2766 ;; of (INTEGER * -1) and (AND (RATIONAL * -1/2) (NOT INTEGER))
2767 ;; should be (RATIONAL * -1/2) -- CSR, 2003-02-28
2768 ((and (csubtypep type2
(specifier-type 'ratio
))
2769 (numeric-type-p type1
)
2770 (csubtypep type1
(specifier-type 'integer
))
2775 :low
(if (null (numeric-type-low type1
))
2777 (list (1- (numeric-type-low type1
))))
2778 :high
(if (null (numeric-type-high type1
))
2780 (list (1+ (numeric-type-high type1
)))))))
2782 (apply #'type-intersection
2783 (remove (specifier-type '(not integer
))
2784 (intersection-type-types type2
)
2787 (let ((accumulator *universal-type
*))
2788 (do ((t2s (intersection-type-types type2
) (cdr t2s
)))
2789 ((null t2s
) accumulator
)
2790 (let ((union (type-union type1
(car t2s
))))
2791 (when (union-type-p union
)
2792 ;; we have to give up here -- there are all sorts of
2793 ;; ordering worries, but it's better than before.
2794 ;; Doing exactly the same as in the UNION
2795 ;; :SIMPLE/:COMPLEX-INTERSECTION2 method causes stack
2796 ;; overflow with the mutual recursion never bottoming
2798 (if (and (eq accumulator
*universal-type
*)
2800 ;; KLUDGE: if we get here, we have a partially
2801 ;; simplified result. While this isn't by any
2802 ;; means a universal simplification, including
2803 ;; this logic here means that we can get (OR
2804 ;; KEYWORD (NOT KEYWORD)) canonicalized to T.
2808 (type-intersection accumulator union
))))))))
2810 (!def-type-translator and
(&whole whole
&rest type-specifiers
)
2811 (apply #'type-intersection
2812 (mapcar #'specifier-type type-specifiers
)))
2816 (!define-type-class union
)
2818 (!define-type-method
(union :negate
) (type)
2819 (declare (type ctype type
))
2820 (apply #'type-intersection
2821 (mapcar #'type-negation
(union-type-types type
))))
2823 ;;; The LIST, FLOAT and REAL types have special names. Other union
2824 ;;; types just get mechanically unparsed.
2825 (!define-type-method
(union :unparse
) (type)
2826 (declare (type ctype type
))
2828 ((type= type
(specifier-type 'list
)) 'list
)
2829 ((type= type
(specifier-type 'float
)) 'float
)
2830 ((type= type
(specifier-type 'real
)) 'real
)
2831 ((type= type
(specifier-type 'sequence
)) 'sequence
)
2832 ((type= type
(specifier-type 'bignum
)) 'bignum
)
2833 ((type= type
(specifier-type 'simple-string
)) 'simple-string
)
2834 ((type= type
(specifier-type 'string
)) 'string
)
2835 ((type= type
(specifier-type 'complex
)) 'complex
)
2836 ((type= type
(specifier-type 'standard-char
)) 'standard-char
)
2837 (t `(or ,@(mapcar #'type-specifier
(union-type-types type
))))))
2839 ;;; Two union types are equal if they are each subtypes of each
2840 ;;; other. We need to be this clever because our complex subtypep
2841 ;;; methods are now more accurate; we don't get infinite recursion
2842 ;;; because the simple-subtypep method delegates to complex-subtypep
2843 ;;; of the individual types of type1. - CSR, 2002-04-09
2845 ;;; Previous comment, now obsolete, but worth keeping around because
2846 ;;; it is true, though too strong a condition:
2848 ;;; Two union types are equal if their subtypes are equal sets.
2849 (!define-type-method
(union :simple-
=) (type1 type2
)
2850 (multiple-value-bind (subtype certain?
)
2851 (csubtypep type1 type2
)
2853 (csubtypep type2 type1
)
2854 ;; we might as well become as certain as possible.
2857 (multiple-value-bind (subtype certain?
)
2858 (csubtypep type2 type1
)
2859 (declare (ignore subtype
))
2860 (values nil certain?
))))))
2862 (!define-type-method
(union :complex-
=) (type1 type2
)
2863 (declare (ignore type1
))
2864 (if (some #'type-might-contain-other-types-p
2865 (union-type-types type2
))
2869 ;;; Similarly, a union type is a subtype of another if and only if
2870 ;;; every element of TYPE1 is a subtype of TYPE2.
2871 (defun union-simple-subtypep (type1 type2
)
2872 (every/type
(swapped-args-fun #'union-complex-subtypep-arg2
)
2874 (union-type-types type1
)))
2876 (!define-type-method
(union :simple-subtypep
) (type1 type2
)
2877 (union-simple-subtypep type1 type2
))
2879 (defun union-complex-subtypep-arg1 (type1 type2
)
2880 (every/type
(swapped-args-fun #'csubtypep
)
2882 (union-type-types type1
)))
2884 (!define-type-method
(union :complex-subtypep-arg1
) (type1 type2
)
2885 (union-complex-subtypep-arg1 type1 type2
))
2887 (defun union-complex-subtypep-arg2 (type1 type2
)
2888 ;; At this stage, we know that type2 is a union type and type1
2889 ;; isn't. We might as well check this, though:
2890 (aver (union-type-p type2
))
2891 (aver (not (union-type-p type1
)))
2892 ;; was: (any/type #'csubtypep type1 (union-type-types type2)), which
2893 ;; turns out to be too restrictive, causing bug 91.
2895 ;; the following reimplementation might look dodgy. It is dodgy. It
2896 ;; depends on the union :complex-= method not doing very much work
2897 ;; -- certainly, not using subtypep. Reasoning:
2899 ;; A is a subset of (B1 u B2)
2900 ;; <=> A n (B1 u B2) = A
2901 ;; <=> (A n B1) u (A n B2) = A
2903 ;; But, we have to be careful not to delegate this type= to
2904 ;; something that could invoke subtypep, which might get us back
2905 ;; here -> stack explosion. We therefore ensure that the second type
2906 ;; (which is the one that's dispatched on) is either a union type
2907 ;; (where we've ensured that the complex-= method will not call
2908 ;; subtypep) or something with no union types involved, in which
2909 ;; case we'll never come back here.
2911 ;; If we don't do this, then e.g.
2912 ;; (SUBTYPEP '(MEMBER 3) '(OR (SATISFIES FOO) (SATISFIES BAR)))
2913 ;; would loop infinitely, as the member :complex-= method is
2914 ;; implemented in terms of subtypep.
2916 ;; Ouch. - CSR, 2002-04-10
2917 (multiple-value-bind (sub-value sub-certain?
)
2920 (mapcar (lambda (x) (type-intersection type1 x
))
2921 (union-type-types type2
))))
2923 (values sub-value sub-certain?
)
2924 ;; The ANY/TYPE expression above is a sufficient condition for
2925 ;; subsetness, but not a necessary one, so we might get a more
2926 ;; certain answer by this CALL-NEXT-METHOD-ish step when the
2927 ;; ANY/TYPE expression is uncertain.
2928 (invoke-complex-subtypep-arg1-method type1 type2
))))
2930 (!define-type-method
(union :complex-subtypep-arg2
) (type1 type2
)
2931 (union-complex-subtypep-arg2 type1 type2
))
2933 (!define-type-method
(union :simple-intersection2
:complex-intersection2
)
2935 ;; The CSUBTYPEP clauses here let us simplify e.g.
2936 ;; (TYPE-INTERSECTION2 (SPECIFIER-TYPE 'LIST)
2937 ;; (SPECIFIER-TYPE '(OR LIST VECTOR)))
2938 ;; (where LIST is (OR CONS NULL)).
2940 ;; The tests are more or less (CSUBTYPEP TYPE1 TYPE2) and vice
2941 ;; versa, but it's important that we pre-expand them into
2942 ;; specialized operations on individual elements of
2943 ;; UNION-TYPE-TYPES, instead of using the ordinary call to
2944 ;; CSUBTYPEP, in order to avoid possibly invoking any methods which
2945 ;; might in turn invoke (TYPE-INTERSECTION2 TYPE1 TYPE2) and thus
2946 ;; cause infinite recursion.
2948 ;; Within this method, type2 is guaranteed to be a union type:
2949 (aver (union-type-p type2
))
2950 ;; Make sure to call only the applicable methods...
2951 (cond ((and (union-type-p type1
)
2952 (union-simple-subtypep type1 type2
)) type1
)
2953 ((and (union-type-p type1
)
2954 (union-simple-subtypep type2 type1
)) type2
)
2955 ((and (not (union-type-p type1
))
2956 (union-complex-subtypep-arg2 type1 type2
))
2958 ((and (not (union-type-p type1
))
2959 (union-complex-subtypep-arg1 type2 type1
))
2962 ;; KLUDGE: This code accumulates a sequence of TYPE-UNION2
2963 ;; operations in a particular order, and gives up if any of
2964 ;; the sub-unions turn out not to be simple. In other cases
2965 ;; ca. sbcl-0.6.11.15, that approach to taking a union was a
2966 ;; bad idea, since it can overlook simplifications which
2967 ;; might occur if the terms were accumulated in a different
2968 ;; order. It's possible that that will be a problem here too.
2969 ;; However, I can't think of a good example to demonstrate
2970 ;; it, and without an example to demonstrate it I can't write
2971 ;; test cases, and without test cases I don't want to
2972 ;; complicate the code to address what's still a hypothetical
2973 ;; problem. So I punted. -- WHN 2001-03-20
2974 (let ((accumulator *empty-type
*))
2975 (dolist (t2 (union-type-types type2
) accumulator
)
2977 (type-union accumulator
2978 (type-intersection type1 t2
))))))))
2980 (!def-type-translator or
(&rest type-specifiers
)
2982 (mapcar #'specifier-type
2987 (!define-type-class cons
)
2989 (!def-type-translator cons
(&optional
(car-type-spec '*) (cdr-type-spec '*))
2990 (let ((car-type (single-value-specifier-type car-type-spec
))
2991 (cdr-type (single-value-specifier-type cdr-type-spec
)))
2992 (make-cons-type car-type cdr-type
)))
2994 (!define-type-method
(cons :negate
) (type)
2995 (if (and (eq (cons-type-car-type type
) *universal-type
*)
2996 (eq (cons-type-cdr-type type
) *universal-type
*))
2997 (make-negation-type :type type
)
2999 (make-negation-type :type
(specifier-type 'cons
))
3001 ((and (not (eq (cons-type-car-type type
) *universal-type
*))
3002 (not (eq (cons-type-cdr-type type
) *universal-type
*)))
3005 (type-negation (cons-type-car-type type
))
3009 (type-negation (cons-type-cdr-type type
)))))
3010 ((not (eq (cons-type-car-type type
) *universal-type
*))
3012 (type-negation (cons-type-car-type type
))
3014 ((not (eq (cons-type-cdr-type type
) *universal-type
*))
3017 (type-negation (cons-type-cdr-type type
))))
3018 (t (bug "Weird CONS type ~S" type
))))))
3020 (!define-type-method
(cons :unparse
) (type)
3021 (let ((car-eltype (type-specifier (cons-type-car-type type
)))
3022 (cdr-eltype (type-specifier (cons-type-cdr-type type
))))
3023 (if (and (member car-eltype
'(t *))
3024 (member cdr-eltype
'(t *)))
3026 `(cons ,car-eltype
,cdr-eltype
))))
3028 (!define-type-method
(cons :simple-
=) (type1 type2
)
3029 (declare (type cons-type type1 type2
))
3030 (multiple-value-bind (car-match car-win
)
3031 (type= (cons-type-car-type type1
) (cons-type-car-type type2
))
3032 (multiple-value-bind (cdr-match cdr-win
)
3033 (type= (cons-type-cdr-type type1
) (cons-type-cdr-type type2
))
3034 (cond ((and car-match cdr-match
)
3035 (aver (and car-win cdr-win
))
3039 ;; FIXME: Ideally we would like to detect and handle
3040 ;; (CONS UNKNOWN INTEGER) (CONS UNKNOWN SYMBOL) => NIL, T
3041 ;; but just returning a secondary true on (and car-win cdr-win)
3042 ;; unfortunately breaks other things. --NS 2006-08-16
3043 (and (or (and (not car-match
) car-win
)
3044 (and (not cdr-match
) cdr-win
))
3045 (not (and (cons-type-might-be-empty-type type1
)
3046 (cons-type-might-be-empty-type type2
))))))))))
3048 (!define-type-method
(cons :simple-subtypep
) (type1 type2
)
3049 (declare (type cons-type type1 type2
))
3050 (multiple-value-bind (val-car win-car
)
3051 (csubtypep (cons-type-car-type type1
) (cons-type-car-type type2
))
3052 (multiple-value-bind (val-cdr win-cdr
)
3053 (csubtypep (cons-type-cdr-type type1
) (cons-type-cdr-type type2
))
3054 (if (and val-car val-cdr
)
3055 (values t
(and win-car win-cdr
))
3056 (values nil
(or (and (not val-car
) win-car
)
3057 (and (not val-cdr
) win-cdr
)))))))
3059 ;;; Give up if a precise type is not possible, to avoid returning
3060 ;;; overly general types.
3061 (!define-type-method
(cons :simple-union2
) (type1 type2
)
3062 (declare (type cons-type type1 type2
))
3063 (let ((car-type1 (cons-type-car-type type1
))
3064 (car-type2 (cons-type-car-type type2
))
3065 (cdr-type1 (cons-type-cdr-type type1
))
3066 (cdr-type2 (cons-type-cdr-type type2
))
3069 ;; UGH. -- CSR, 2003-02-24
3070 (macrolet ((frob-car (car1 car2 cdr1 cdr2
3071 &optional
(not1 nil not1p
))
3073 (make-cons-type ,car1
(type-union ,cdr1
,cdr2
))
3075 (type-intersection ,car2
3078 `(type-negation ,car1
)))
3080 (cond ((type= car-type1 car-type2
)
3081 (make-cons-type car-type1
3082 (type-union cdr-type1 cdr-type2
)))
3083 ((type= cdr-type1 cdr-type2
)
3084 (make-cons-type (type-union car-type1 car-type2
)
3086 ((csubtypep car-type1 car-type2
)
3087 (frob-car car-type1 car-type2 cdr-type1 cdr-type2
))
3088 ((csubtypep car-type2 car-type1
)
3089 (frob-car car-type2 car-type1 cdr-type2 cdr-type1
))
3090 ;; more general case of the above, but harder to compute
3092 (setf car-not1
(type-negation car-type1
))
3093 (multiple-value-bind (yes win
)
3094 (csubtypep car-type2 car-not1
)
3095 (and (not yes
) win
)))
3096 (frob-car car-type1 car-type2 cdr-type1 cdr-type2 car-not1
))
3098 (setf car-not2
(type-negation car-type2
))
3099 (multiple-value-bind (yes win
)
3100 (csubtypep car-type1 car-not2
)
3101 (and (not yes
) win
)))
3102 (frob-car car-type2 car-type1 cdr-type2 cdr-type1 car-not2
))
3103 ;; Don't put these in -- consider the effect of taking the
3104 ;; union of (CONS (INTEGER 0 2) (INTEGER 5 7)) and
3105 ;; (CONS (INTEGER 0 3) (INTEGER 5 6)).
3107 ((csubtypep cdr-type1 cdr-type2
)
3108 (frob-cdr car-type1 car-type2 cdr-type1 cdr-type2
))
3110 ((csubtypep cdr-type2 cdr-type1
)
3111 (frob-cdr car-type2 car-type1 cdr-type2 cdr-type1
))))))
3113 (!define-type-method
(cons :simple-intersection2
) (type1 type2
)
3114 (declare (type cons-type type1 type2
))
3115 (let ((car-int2 (type-intersection2 (cons-type-car-type type1
)
3116 (cons-type-car-type type2
)))
3117 (cdr-int2 (type-intersection2 (cons-type-cdr-type type1
)
3118 (cons-type-cdr-type type2
))))
3120 ((and car-int2 cdr-int2
) (make-cons-type car-int2 cdr-int2
))
3121 (car-int2 (make-cons-type car-int2
3123 (cons-type-cdr-type type1
)
3124 (cons-type-cdr-type type2
))))
3125 (cdr-int2 (make-cons-type
3126 (type-intersection (cons-type-car-type type1
)
3127 (cons-type-car-type type2
))
3130 (!define-superclasses cons
((cons)) !cold-init-forms
)
3132 ;;;; CHARACTER-SET types
3134 (!define-type-class character-set
)
3136 (!def-type-translator character-set
3137 (&optional
(pairs '((0 .
#.
(1- sb
!xc
:char-code-limit
)))))
3138 (make-character-set-type :pairs pairs
))
3140 (!define-type-method
(character-set :negate
) (type)
3141 (let ((pairs (character-set-type-pairs type
)))
3142 (if (and (= (length pairs
) 1)
3144 (= (cdar pairs
) (1- sb
!xc
:char-code-limit
)))
3145 (make-negation-type :type type
)
3146 (let ((not-character
3148 :type
(make-character-set-type
3149 :pairs
'((0 .
#.
(1- sb
!xc
:char-code-limit
)))))))
3152 (make-character-set-type
3153 :pairs
(let (not-pairs)
3154 (when (> (caar pairs
) 0)
3155 (push (cons 0 (1- (caar pairs
))) not-pairs
))
3156 (do* ((tail pairs
(cdr tail
))
3157 (high1 (cdar tail
) (cdar tail
))
3158 (low2 (caadr tail
) (caadr tail
)))
3160 (when (< (cdar tail
) (1- sb
!xc
:char-code-limit
))
3161 (push (cons (1+ (cdar tail
))
3162 (1- sb
!xc
:char-code-limit
))
3164 (nreverse not-pairs
))
3165 (push (cons (1+ high1
) (1- low2
)) not-pairs
)))))))))
3167 (!define-type-method
(character-set :unparse
) (type)
3169 ((type= type
(specifier-type 'character
)) 'character
)
3170 ((type= type
(specifier-type 'base-char
)) 'base-char
)
3171 ((type= type
(specifier-type 'extended-char
)) 'extended-char
)
3172 ((type= type
(specifier-type 'standard-char
)) 'standard-char
)
3173 (t (let ((pairs (character-set-type-pairs type
)))
3174 `(member ,@(loop for
(low . high
) in pairs
3175 nconc
(loop for code from low upto high
3176 collect
(sb!xc
:code-char code
))))))))
3178 (!define-type-method
(character-set :simple-
=) (type1 type2
)
3179 (let ((pairs1 (character-set-type-pairs type1
))
3180 (pairs2 (character-set-type-pairs type2
)))
3181 (values (equal pairs1 pairs2
) t
)))
3183 (!define-type-method
(character-set :simple-subtypep
) (type1 type2
)
3185 (dolist (pair (character-set-type-pairs type1
) t
)
3186 (unless (position pair
(character-set-type-pairs type2
)
3187 :test
(lambda (x y
) (and (>= (car x
) (car y
))
3188 (<= (cdr x
) (cdr y
)))))
3192 (!define-type-method
(character-set :simple-union2
) (type1 type2
)
3193 ;; KLUDGE: the canonizing in the MAKE-CHARACTER-SET-TYPE function
3194 ;; actually does the union for us. It might be a little fragile to
3196 (make-character-set-type
3198 (copy-alist (character-set-type-pairs type1
))
3199 (copy-alist (character-set-type-pairs type2
))
3202 (!define-type-method
(character-set :simple-intersection2
) (type1 type2
)
3203 ;; KLUDGE: brute force.
3206 (dolist (pair1 (character-set-type-pairs type1
)
3207 (make-character-set-type
3208 :pairs
(sort pairs
#'< :key
#'car
)))
3209 (dolist (pair2 (character-set-type-pairs type2
))
3211 ((<= (car pair1
) (car pair2
) (cdr pair1
))
3212 (push (cons (car pair2
) (min (cdr pair1
) (cdr pair2
))) pairs
))
3213 ((<= (car pair2
) (car pair1
) (cdr pair2
))
3214 (push (cons (car pair1
) (min (cdr pair1
) (cdr pair2
))) pairs
))))))
3216 (make-character-set-type
3217 :pairs
(intersect-type-pairs
3218 (character-set-type-pairs type1
)
3219 (character-set-type-pairs type2
))))
3222 ;;; Intersect two ordered lists of pairs
3223 ;;; Each list is of the form ((start1 . end1) ... (startn . endn)),
3224 ;;; where start1 <= end1 < start2 <= end2 < ... < startn <= endn.
3225 ;;; Each pair represents the integer interval start..end.
3227 (defun intersect-type-pairs (alist1 alist2
)
3228 (if (and alist1 alist2
)
3230 (pair1 (pop alist1
))
3231 (pair2 (pop alist2
)))
3233 (when (> (car pair1
) (car pair2
))
3234 (rotatef pair1 pair2
)
3235 (rotatef alist1 alist2
))
3236 (let ((pair1-cdr (cdr pair1
)))
3238 ((> (car pair2
) pair1-cdr
)
3239 ;; No over lap -- discard pair1
3240 (unless alist1
(return))
3241 (setq pair1
(pop alist1
)))
3242 ((<= (cdr pair2
) pair1-cdr
)
3243 (push (cons (car pair2
) (cdr pair2
)) res
)
3245 ((= (cdr pair2
) pair1-cdr
)
3246 (unless alist1
(return))
3247 (unless alist2
(return))
3248 (setq pair1
(pop alist1
)
3249 pair2
(pop alist2
)))
3250 (t ;; (< (cdr pair2) pair1-cdr)
3251 (unless alist2
(return))
3252 (setq pair1
(cons (1+ (cdr pair2
)) pair1-cdr
))
3253 (setq pair2
(pop alist2
)))))
3254 (t ;; (> (cdr pair2) (cdr pair1))
3255 (push (cons (car pair2
) pair1-cdr
) res
)
3256 (unless alist1
(return))
3257 (setq pair2
(cons (1+ pair1-cdr
) (cdr pair2
)))
3258 (setq pair1
(pop alist1
))))))
3263 ;;; Return the type that describes all objects that are in X but not
3264 ;;; in Y. If we can't determine this type, then return NIL.
3266 ;;; For now, we only are clever dealing with union and member types.
3267 ;;; If either type is not a union type, then we pretend that it is a
3268 ;;; union of just one type. What we do is remove from X all the types
3269 ;;; that are a subtype any type in Y. If any type in X intersects with
3270 ;;; a type in Y but is not a subtype, then we give up.
3272 ;;; We must also special-case any member type that appears in the
3273 ;;; union. We remove from X's members all objects that are TYPEP to Y.
3274 ;;; If Y has any members, we must be careful that none of those
3275 ;;; members are CTYPEP to any of Y's non-member types. We give up in
3276 ;;; this case, since to compute that difference we would have to break
3277 ;;; the type from X into some collection of types that represents the
3278 ;;; type without that particular element. This seems too hairy to be
3279 ;;; worthwhile, given its low utility.
3280 (defun type-difference (x y
)
3281 (let ((x-types (if (union-type-p x
) (union-type-types x
) (list x
)))
3282 (y-types (if (union-type-p y
) (union-type-types y
) (list y
))))
3284 (dolist (x-type x-types
)
3285 (if (member-type-p x-type
)
3286 (let ((xset (alloc-xset))
3288 (mapc-member-type-members
3290 (multiple-value-bind (ok sure
) (ctypep elt y
)
3292 (return-from type-difference nil
))
3295 (pushnew elt fp-zeroes
)
3296 (add-to-xset elt xset
)))))
3298 (unless (and (xset-empty-p xset
) (not fp-zeroes
))
3299 (res (make-member-type :xset xset
:fp-zeroes fp-zeroes
))))
3300 (dolist (y-type y-types
(res x-type
))
3301 (multiple-value-bind (val win
) (csubtypep x-type y-type
)
3302 (unless win
(return-from type-difference nil
))
3304 (when (types-equal-or-intersect x-type y-type
)
3305 (return-from type-difference nil
))))))
3306 (let ((y-mem (find-if #'member-type-p y-types
)))
3308 (dolist (x-type x-types
)
3309 (unless (member-type-p x-type
)
3310 (mapc-member-type-members
3312 (multiple-value-bind (ok sure
) (ctypep member x-type
)
3313 (when (or (not sure
) ok
)
3314 (return-from type-difference nil
))))
3316 (apply #'type-union
(res)))))
3318 (!def-type-translator array
(&optional
(element-type '*)
3320 (specialize-array-type
3321 (make-array-type :dimensions
(canonical-array-dimensions dimensions
)
3323 :element-type
(if (eq element-type
'*)
3325 (specifier-type element-type
)))))
3327 (!def-type-translator simple-array
(&optional
(element-type '*)
3329 (specialize-array-type
3330 (make-array-type :dimensions
(canonical-array-dimensions dimensions
)
3332 :element-type
(if (eq element-type
'*)
3334 (specifier-type element-type
)))))
3336 ;;;; utilities shared between cross-compiler and target system
3338 ;;; Does the type derived from compilation of an actual function
3339 ;;; definition satisfy declarations of a function's type?
3340 (defun defined-ftype-matches-declared-ftype-p (defined-ftype declared-ftype
)
3341 (declare (type ctype defined-ftype declared-ftype
))
3342 (flet ((is-built-in-class-function-p (ctype)
3343 (and (built-in-classoid-p ctype
)
3344 (eq (built-in-classoid-name ctype
) 'function
))))
3345 (cond (;; DECLARED-FTYPE could certainly be #<BUILT-IN-CLASS FUNCTION>;
3346 ;; that's what happens when we (DECLAIM (FTYPE FUNCTION FOO)).
3347 (is-built-in-class-function-p declared-ftype
)
3348 ;; In that case, any definition satisfies the declaration.
3350 (;; It's not clear whether or how DEFINED-FTYPE might be
3351 ;; #<BUILT-IN-CLASS FUNCTION>, but it's not obviously
3352 ;; invalid, so let's handle that case too, just in case.
3353 (is-built-in-class-function-p defined-ftype
)
3354 ;; No matter what DECLARED-FTYPE might be, we can't prove
3355 ;; that an object of type FUNCTION doesn't satisfy it, so
3356 ;; we return success no matter what.
3358 (;; Otherwise both of them must be FUN-TYPE objects.
3360 ;; FIXME: For now we only check compatibility of the return
3361 ;; type, not argument types, and we don't even check the
3362 ;; return type very precisely (as per bug 94a). It would be
3363 ;; good to do a better job. Perhaps to check the
3364 ;; compatibility of the arguments, we should (1) redo
3365 ;; VALUES-TYPES-EQUAL-OR-INTERSECT as
3366 ;; ARGS-TYPES-EQUAL-OR-INTERSECT, and then (2) apply it to
3367 ;; the ARGS-TYPE slices of the FUN-TYPEs. (ARGS-TYPE
3368 ;; is a base class both of VALUES-TYPE and of FUN-TYPE.)
3369 (values-types-equal-or-intersect
3370 (fun-type-returns defined-ftype
)
3371 (fun-type-returns declared-ftype
))))))
3373 ;;; This messy case of CTYPE for NUMBER is shared between the
3374 ;;; cross-compiler and the target system.
3375 (defun ctype-of-number (x)
3376 (let ((num (if (complexp x
) (realpart x
) x
)))
3377 (multiple-value-bind (complexp low high
)
3379 (let ((imag (imagpart x
)))
3380 (values :complex
(min num imag
) (max num imag
)))
3381 (values :real num num
))
3382 (make-numeric-type :class
(etypecase num
3383 (integer (if (complexp x
)
3384 (if (integerp (imagpart x
))
3388 (rational 'rational
)
3390 :format
(and (floatp num
) (float-format-name num
))
3396 ;; Why SAFETY 0? To suppress the is-it-the-right-structure-type
3397 ;; checking for declarations in structure accessors. Otherwise we
3398 ;; can get caught in a chicken-and-egg bootstrapping problem, whose
3399 ;; symptom on x86 OpenBSD sbcl-0.pre7.37.flaky5.22 is an illegal
3400 ;; instruction trap. I haven't tracked it down, but I'm guessing it
3401 ;; has to do with setting LAYOUTs when the LAYOUT hasn't been set
3403 (declare (optimize (safety 0)))
3404 (!defun-from-collected-cold-init-forms
!late-type-cold-init
))
3406 (/show0
"late-type.lisp end of file")
