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 :specifier
(missing-arg)))
35 ;;; This condition is signalled whenever we encounter a type (DEFTYPE,
36 ;;; structure, condition, class) that has been marked as deprecated.
37 (define-condition parse-deprecated-type
(condition)
38 ((specifier :reader parse-deprecated-type-specifier
:initarg
:specifier
))
40 :specifier
(missing-arg)))
42 ;;; These functions are used as method for types which need a complex
43 ;;; subtypep method to handle some superclasses, but cover a subtree
44 ;;; of the type graph (i.e. there is no simple way for any other type
45 ;;; class to be a subtype.) There are always still complex ways,
46 ;;; namely UNION and MEMBER types, so we must give TYPE1's method a
47 ;;; chance to run, instead of immediately returning NIL, T.
48 (defun delegate-complex-subtypep-arg2 (type1 type2
)
50 (type-class-complex-subtypep-arg1 (type-class-info type1
))))
52 (funcall subtypep-arg1 type1 type2
)
54 (defun delegate-complex-intersection2 (type1 type2
)
55 (let ((method (type-class-complex-intersection2 (type-class-info type1
))))
56 (if (and method
(not (eq method
#'delegate-complex-intersection2
)))
57 (funcall method type2 type1
)
58 (hierarchical-intersection2 type1 type2
))))
60 (defun contains-unknown-type-p (ctype)
63 (compound-type (some #'contains-unknown-type-p
(compound-type-types ctype
)))
64 (negation-type (contains-unknown-type-p (negation-type-type ctype
)))
65 (cons-type (or (contains-unknown-type-p (cons-type-car-type ctype
))
66 (contains-unknown-type-p (cons-type-cdr-type ctype
))))
67 (array-type (contains-unknown-type-p (array-type-element-type ctype
)))
69 (or (some #'contains-unknown-type-p
(args-type-required ctype
))
70 (some #'contains-unknown-type-p
(args-type-optional ctype
))
71 (acond ((args-type-rest ctype
) (contains-unknown-type-p it
)))
72 (some (lambda (x) (contains-unknown-type-p (key-info-type x
)))
73 (args-type-keywords ctype
))
74 (and (fun-type-p ctype
)
75 (contains-unknown-type-p (fun-type-returns ctype
)))))))
77 ;; Similar to (NOT CONTAINS-UNKNOWN-TYPE-P), but report that (SATISFIES F)
78 ;; is not a testable type unless F is currently bound.
79 (defun testable-type-p (ctype)
81 (unknown-type nil
) ; must precede HAIRY because an unknown is HAIRY
83 (let ((spec (hairy-type-specifier ctype
)))
84 ;; Anything other than (SATISFIES ...) is testable
85 ;; because there's no reason to suppose that it isn't.
86 (or (neq (car spec
) 'satisfies
) (fboundp (cadr spec
)))))
87 (compound-type (every #'testable-type-p
(compound-type-types ctype
)))
88 (negation-type (testable-type-p (negation-type-type ctype
)))
89 (cons-type (and (testable-type-p (cons-type-car-type ctype
))
90 (testable-type-p (cons-type-cdr-type ctype
))))
91 ;; This case could be too strict. I think an array type is testable
92 ;; if the upgraded type is testable. Probably nobody cares though.
93 (array-type (testable-type-p (array-type-element-type ctype
)))
96 ;;; This is used by !DEFINE-SUPERCLASSES to define the SUBTYPE-ARG1
97 ;;; method. INFO is a list of conses
98 ;;; (SUPERCLASS-CLASS . {GUARD-TYPE-SPECIFIER | NIL}).
99 (defun has-superclasses-complex-subtypep-arg1 (type1 type2 info
)
100 ;; If TYPE2 might be concealing something related to our class
102 (cond ((type-might-contain-other-types-p type2
)
103 ;; too confusing, gotta punt
105 ((fun-designator-type-p type1
)
108 ;; ordinary case expected by old CMU CL code, where the taxonomy
109 ;; of TYPE2's representation accurately reflects the taxonomy of
110 ;; the underlying set
112 ;; FIXME: This old CMU CL code probably deserves a comment
113 ;; explaining to us mere mortals how it works...
114 (and (sb!xc
:typep type2
'classoid
)
116 (let ((guard (cdr x
)))
117 (when (or (not guard
)
118 (csubtypep type1
(if (%instancep guard
)
121 (specifier-type guard
)))))
123 (or (eq type2
(car x
))
124 (let ((inherits (layout-inherits
125 (classoid-layout (car x
)))))
126 (dotimes (i (length inherits
) nil
)
127 (when (eq type2
(layout-classoid (svref inherits i
)))
131 ;;; This function takes a list of specs, each of the form
132 ;;; (SUPERCLASS-NAME &OPTIONAL GUARD).
133 ;;; Consider one spec (with no guard): any instance of the named
134 ;;; TYPE-CLASS is also a subtype of the named superclass and of any of
135 ;;; its superclasses. If there are multiple specs, then some will have
136 ;;; guards. We choose the first spec whose guard is a supertype of
137 ;;; TYPE1 and use its superclass. In effect, a sequence of guards
140 ;;; G0,(and G1 (not G0)), (and G2 (not (or G0 G1))).
142 ;;; WHEN controls when the forms are executed.
143 (defmacro !define-superclasses
(type-class-name specs progn-oid
)
144 (let ((defun-name (symbolicate type-class-name
"-COMPLEX-SUBTYPEP-ARG1")))
146 (defun ,defun-name
(type1 type2
)
147 (has-superclasses-complex-subtypep-arg1
150 (list ,@(mapcar (lambda (spec)
151 (destructuring-bind (super &optional guard
) spec
152 `(cons (find-classoid ',super
) ',guard
)))
153 specs
)) #-sb-xc-host t
)))
155 (let ((type-class (type-class-or-lose ',type-class-name
)))
156 (setf (type-class-complex-subtypep-arg1 type-class
) #',defun-name
)
157 (setf (type-class-complex-subtypep-arg2 type-class
)
158 #'delegate-complex-subtypep-arg2
)
159 (setf (type-class-complex-intersection2 type-class
)
160 #'delegate-complex-intersection2
))))))
162 ;;;; FUNCTION and VALUES types
164 ;;;; Pretty much all of the general type operations are illegal on
165 ;;;; VALUES types, since we can't discriminate using them, do
166 ;;;; SUBTYPEP, etc. FUNCTION types are acceptable to the normal type
167 ;;;; operations, but are generally considered to be equivalent to
168 ;;;; FUNCTION. These really aren't true types in any type theoretic
169 ;;;; sense, but we still parse them into CTYPE structures for two
172 ;;;; -- Parsing and unparsing work the same way, and indeed we can't
173 ;;;; tell whether a type is a function or values type without
175 ;;;; -- Many of the places that can be annotated with real types can
176 ;;;; also be annotated with function or values types.
178 (!define-type-method
(values :simple-subtypep
:complex-subtypep-arg1
)
180 (declare (ignore type2
))
181 ;; FIXME: should be TYPE-ERROR, here and in next method
182 (error "SUBTYPEP is illegal on this type:~% ~S" (type-specifier type1
)))
184 (!define-type-method
(values :complex-subtypep-arg2
)
186 (declare (ignore type1
))
187 (error "SUBTYPEP is illegal on this type:~% ~S" (type-specifier type2
)))
189 (!define-type-method
(values :negate
) (type)
190 (error "NOT VALUES too confusing on ~S" (type-specifier type
)))
192 (!define-type-method
(values :unparse
) (type)
194 (let ((unparsed (unparse-args-types type
)))
195 (if (or (values-type-optional type
)
196 (values-type-rest type
)
197 (values-type-allowp type
))
199 (nconc unparsed
'(&optional
))))))
201 ;;; Return true if LIST1 and LIST2 have the same elements in the same
202 ;;; positions according to TYPE=. We return NIL, NIL if there is an
203 ;;; uncertain comparison.
204 (defun type=-list
(list1 list2
)
205 (declare (list list1 list2
))
206 (do ((types1 list1
(cdr types1
))
207 (types2 list2
(cdr types2
)))
208 ((or (null types1
) (null types2
))
209 (if (or types1 types2
)
212 (multiple-value-bind (val win
)
213 (type= (first types1
) (first types2
))
215 (return (values nil nil
)))
217 (return (values nil t
))))))
219 (!define-type-method
(values :simple-
=) (type1 type2
)
220 (type=-args type1 type2
))
222 ;;; a flag that we can bind to cause complex function types to be
223 ;;; unparsed as FUNCTION. This is useful when we want a type that we
224 ;;; can pass to TYPEP.
225 (!defvar
*unparse-fun-type-simplify
* nil
)
226 ;;; A flag to prevent TYPE-OF calls by user applications from returning
227 ;;; (NOT x). TYPE-SPECIFIER usually allows it to preserve information.
228 (!defvar
*unparse-allow-negation
* t
)
230 (!define-type-method
(function :negate
) (type) (make-negation-type type
))
232 (!define-type-method
(function :unparse
) (type)
233 (let ((name (if (fun-designator-type-p type
)
236 (cond (*unparse-fun-type-simplify
*
240 (if (fun-type-wild-args type
)
242 (unparse-args-types type
))
244 (fun-type-returns type
)))))))
246 ;;; The meaning of this is a little confused. On the one hand, all
247 ;;; function objects are represented the same way regardless of the
248 ;;; arglists and return values, and apps don't get to ask things like
249 ;;; (TYPEP #'FOO (FUNCTION (FIXNUM) *)) in any meaningful way. On the
250 ;;; other hand, Python wants to reason about function types. So...
251 (!define-type-method
(function :simple-subtypep
) (type1 type2
)
252 (if (and (fun-designator-type-p type1
)
253 (not (fun-designator-type-p type2
)))
255 (flet ((fun-type-simple-p (type)
256 (not (or (fun-type-rest type
)
257 (fun-type-keyp type
))))
258 (every-csubtypep (types1 types2
)
262 do
(multiple-value-bind (res sure-p
)
264 (unless res
(return (values res sure-p
))))
265 finally
(return (values t t
)))))
266 (and/type
(values-subtypep (fun-type-returns type1
)
267 (fun-type-returns type2
))
268 (cond ((fun-type-wild-args type2
) (values t t
))
269 ((fun-type-wild-args type1
)
270 (cond ((fun-type-keyp type2
) (values nil nil
))
271 ((not (fun-type-rest type2
)) (values nil t
))
272 ((not (null (fun-type-required type2
)))
274 (t (and/type
(type= *universal-type
*
275 (fun-type-rest type2
))
280 ((not (and (fun-type-simple-p type1
)
281 (fun-type-simple-p type2
)))
283 (t (multiple-value-bind (min1 max1
) (fun-type-nargs type1
)
284 (multiple-value-bind (min2 max2
) (fun-type-nargs type2
)
285 (cond ((or (> max1 max2
) (< min1 min2
))
287 ((and (= min1 min2
) (= max1 max2
))
288 (and/type
(every-csubtypep
289 (fun-type-required type1
)
290 (fun-type-required type2
))
292 (fun-type-optional type1
)
293 (fun-type-optional type2
))))
296 (fun-type-required type1
)
297 (fun-type-optional type1
))
299 (fun-type-required type2
)
300 (fun-type-optional type2
)))))))))))))
302 (!define-superclasses function
((function)) !cold-init-forms
)
304 ;;; The union or intersection of two FUNCTION types is FUNCTION.
305 (!define-type-method
(function :simple-union2
) (type1 type2
)
306 (if (or (fun-designator-type-p type1
)
307 (fun-designator-type-p type2
))
308 (specifier-type '(or function symbol
))
309 (specifier-type 'function
)))
311 (!define-type-method
(function :simple-intersection2
) (type1 type2
)
312 (let ((ftype (specifier-type 'function
)))
313 (cond ((eq type1 ftype
) type2
)
314 ((eq type2 ftype
) type1
)
315 (t (let ((rtype (values-type-intersection (fun-type-returns type1
)
316 (fun-type-returns type2
)))
318 (and (fun-designator-type-p type1
)
319 (fun-designator-type-p type2
))))
320 (flet ((change-returns (ftype rtype
)
321 (declare (type fun-type ftype
) (type ctype rtype
))
322 (make-fun-type :required
(fun-type-required ftype
)
323 :optional
(fun-type-optional ftype
)
324 :keyp
(fun-type-keyp ftype
)
325 :keywords
(fun-type-keywords ftype
)
326 :allowp
(fun-type-allowp ftype
)
328 :designator designator
)))
330 ((fun-type-wild-args type1
)
331 (if (fun-type-wild-args type2
)
332 (make-fun-type :wild-args t
334 :designator designator
)
335 (change-returns type2 rtype
)))
336 ((fun-type-wild-args type2
)
337 (change-returns type1 rtype
))
338 (t (multiple-value-bind (req opt rest
)
339 (args-type-op type1 type2
#'type-intersection
#'max
)
340 (make-fun-type :required req
344 :allowp
(and (fun-type-allowp type1
)
345 (fun-type-allowp type2
))
347 :designator designator
))))))))))
349 ;;; The union or intersection of a subclass of FUNCTION with a
350 ;;; FUNCTION type is somewhat complicated.
351 (!define-type-method
(function :complex-intersection2
) (type1 type2
)
353 ((and (fun-designator-type-p type2
)
354 (or (csubtypep type1
(specifier-type 'symbol
))
355 (csubtypep type1
(specifier-type 'function
))))
357 ((type= type1
(specifier-type 'function
)) type2
)
358 ((csubtypep type1
(specifier-type 'function
)) nil
)
359 (t :call-other-method
)))
360 (!define-type-method
(function :complex-union2
) (type1 type2
)
361 (declare (ignore type2
))
362 ;; TYPE2 is a FUNCTION type. If TYPE1 is a classoid type naming
363 ;; FUNCTION, then it is the union of the two; otherwise, there is no
366 ((type= type1
(specifier-type 'function
)) type1
)
369 (!define-type-method
(function :simple-
=) (type1 type2
)
370 (if (or (and (fun-designator-type-p type1
)
371 (not (fun-designator-type-p type2
)))
372 (and (not (fun-designator-type-p type1
))
373 (fun-designator-type-p type2
)))
375 (macrolet ((compare (comparator field
)
376 (let ((reader (symbolicate '#:fun-type- field
)))
377 `(,comparator
(,reader type1
) (,reader type2
)))))
378 (and/type
(compare type
= returns
)
379 (cond ((neq (fun-type-wild-args type1
) (fun-type-wild-args type2
))
381 ((eq (fun-type-wild-args type1
) t
)
383 (t (type=-args type1 type2
)))))))
385 (!define-type-class constant
:inherits values
)
387 (!define-type-method
(constant :negate
) (type)
388 (error "NOT CONSTANT too confusing on ~S" (type-specifier type
)))
390 (!define-type-method
(constant :unparse
) (type)
391 `(constant-arg ,(type-specifier (constant-type-type type
))))
393 (!define-type-method
(constant :simple-
=) (type1 type2
)
394 (type= (constant-type-type type1
) (constant-type-type type2
)))
396 (!def-type-translator constant-arg
((:context context
) type
)
397 (make-constant-type :type
(single-value-specifier-type-r context type
)))
399 ;;; Return the lambda-list-like type specification corresponding
401 (declaim (ftype (function (args-type) list
) unparse-args-types
))
402 (defun unparse-args-types (type)
405 (dolist (arg (args-type-required type
))
406 (result (type-specifier arg
)))
408 (when (args-type-optional type
)
410 (dolist (arg (args-type-optional type
))
411 (result (type-specifier arg
))))
413 (when (args-type-rest type
)
415 (result (type-specifier (args-type-rest type
))))
417 (when (args-type-keyp type
)
419 (dolist (key (args-type-keywords type
))
420 (result (list (key-info-name key
)
421 (type-specifier (key-info-type key
))))))
423 (when (args-type-allowp type
)
424 (result '&allow-other-keys
))
428 (defun translate-fun-type (context args result
430 (let ((result (coerce-to-values (values-specifier-type-r context result
))))
432 (multiple-value-bind (llks required optional rest keywords
)
433 (parse-args-types context args
:function-type
)
434 (if (and (null required
)
436 (eq rest
*universal-type
*)
437 (not (ll-kwds-keyp llks
)))
438 (if (eq result
*wild-type
*)
439 (specifier-type 'function
)
440 (make-fun-type :wild-args t
:returns result
441 :designator designator
))
442 (make-fun-type :required required
445 :keyp
(ll-kwds-keyp llks
)
447 :allowp
(ll-kwds-allowp llks
)
449 :designator designator
))))
450 ((eq result
*wild-type
*)
456 (make-fun-type :wild-args t
:returns result
457 :designator designator
)))))
459 (!def-type-translator function
((:context context
)
460 &optional
(args '*) (result '*))
461 (translate-fun-type context args result
))
463 (!def-type-translator function-designator
((:context context
)
464 &optional
(args '*) (result '*))
465 (translate-fun-type context args result
:designator t
))
467 (!def-type-translator values
:list
((:context context
) &rest values
)
470 (multiple-value-bind (llks required optional rest
)
471 (parse-args-types context values
:values-type
)
473 (make-values-type :required required
:optional optional
:rest rest
)
474 (make-short-values-type required
)))))
476 ;;;; VALUES types interfaces
478 ;;;; We provide a few special operations that can be meaningfully used
479 ;;;; on VALUES types (as well as on any other type).
481 ;;; Return the minimum number of values possibly matching VALUES type
483 (defun values-type-min-value-count (type)
486 (ecase (named-type-name type
)
490 (length (values-type-required type
)))))
492 ;;; Return the maximum number of values possibly matching VALUES type
494 (defun values-type-max-value-count (type)
497 (ecase (named-type-name type
)
498 ((t *) call-arguments-limit
)
501 (if (values-type-rest type
)
503 (+ (length (values-type-optional type
))
504 (length (values-type-required type
)))))))
506 (defun values-type-may-be-single-value-p (type)
507 (<= (values-type-min-value-count type
)
509 (values-type-max-value-count type
)))
511 ;;; VALUES type with a single value.
512 (defun type-single-value-p (type)
513 (and (%values-type-p type
)
514 (not (values-type-rest type
))
515 (null (values-type-optional type
))
516 (singleton-p (values-type-required type
))))
518 ;;; Return the type of the first value indicated by TYPE. This is used
519 ;;; by people who don't want to have to deal with VALUES types.
520 #!-sb-fluid
(declaim (freeze-type values-type
))
521 ; (inline single-value-type))
522 (defun single-value-type (type)
523 (declare (type ctype type
))
524 (cond ((eq type
*wild-type
*)
526 ((eq type
*empty-type
*)
528 ((not (values-type-p type
))
530 ((car (args-type-required type
)))
531 (t (type-union (specifier-type 'null
)
532 (or (car (args-type-optional type
))
533 (args-type-rest type
)
534 (specifier-type 'null
))))))
536 ;;; Return the minimum number of arguments that a function can be
537 ;;; called with, and the maximum number or NIL. If not a function
538 ;;; type, return NIL, NIL.
539 (defun fun-type-nargs (type)
540 (declare (type ctype type
))
541 (if (and (fun-type-p type
) (not (fun-type-wild-args type
)))
542 (let ((fixed (length (args-type-required type
))))
543 (if (or (args-type-rest type
)
544 (args-type-keyp type
)
545 (args-type-allowp type
))
547 (values fixed
(+ fixed
(length (args-type-optional type
))))))
550 ;;; Determine whether TYPE corresponds to a definite number of values.
551 ;;; The first value is a list of the types for each value, and the
552 ;;; second value is the number of values. If the number of values is
553 ;;; not fixed, then return NIL and :UNKNOWN.
554 (defun values-types (type)
555 (declare (type ctype type
))
556 (cond ((or (eq type
*wild-type
*) (eq type
*empty-type
*))
557 (values nil
:unknown
))
558 ((or (args-type-optional type
)
559 (args-type-rest type
))
560 (values nil
:unknown
))
562 (let ((req (args-type-required type
)))
563 (values req
(length req
))))))
565 ;;; Return two values:
566 ;;; 1. A list of all the positional (fixed and optional) types.
567 ;;; 2. The &REST type (if any). If no &REST, then the DEFAULT-TYPE.
568 (defun values-type-types (type &optional
(default-type *empty-type
*))
569 (declare (type ctype type
))
570 (if (eq type
*wild-type
*)
571 (values nil
*universal-type
*)
572 (values (append (args-type-required type
)
573 (args-type-optional type
))
574 (or (args-type-rest type
)
577 ;;; types of values in (the <type> (values o_1 ... o_n))
578 (defun values-type-out (type count
)
579 (declare (type ctype type
) (type unsigned-byte count
))
580 (if (eq type
*wild-type
*)
581 (make-list count
:initial-element
*universal-type
*)
583 (flet ((process-types (types)
584 (loop for type in types
588 (process-types (values-type-required type
))
589 (process-types (values-type-optional type
))
590 (let ((rest (values-type-rest type
)))
596 ;;; types of variable in (m-v-bind (v_1 ... v_n) (the <type> ...
597 (defun values-type-in (type count
)
598 (declare (type ctype type
) (type unsigned-byte count
))
599 (if (eq type
*wild-type
*)
600 (make-list count
:initial-element
*universal-type
*)
602 (let ((null-type (specifier-type 'null
)))
603 (loop for type in
(values-type-required type
)
607 (loop for type in
(values-type-optional type
)
610 do
(res (type-union type null-type
)))
612 (loop with rest
= (acond ((values-type-rest type
)
613 (type-union it null-type
))
619 ;;; Return a list of OPERATION applied to the types in TYPES1 and
620 ;;; TYPES2, padding with REST2 as needed. TYPES1 must not be shorter
621 ;;; than TYPES2. The second value is T if OPERATION always returned a
622 ;;; true second value.
623 (defun fixed-values-op (types1 types2 rest2 operation
)
624 (declare (list types1 types2
) (type ctype rest2
) (type function operation
))
626 (values (mapcar (lambda (t1 t2
)
627 (multiple-value-bind (res win
)
628 (funcall operation t1 t2
)
634 (make-list (- (length types1
) (length types2
))
635 :initial-element rest2
)))
638 ;;; If TYPE isn't a values type, then make it into one.
639 (defun-cached (%coerce-to-values
:hash-bits
8 :hash-function
#'type-hash-value
)
641 (cond ((multiple-value-bind (res sure
)
642 (csubtypep (specifier-type 'null
) type
)
643 (and (not res
) sure
))
644 ;; FIXME: What should we do with (NOT SURE)?
645 (make-values-type :required
(list type
) :rest
*universal-type
*))
647 (make-values-type :optional
(list type
) :rest
*universal-type
*))))
649 (defun coerce-to-values (type)
650 (declare (type ctype type
))
651 (cond ((or (eq type
*universal-type
*)
652 (eq type
*wild-type
*))
654 ((values-type-p type
)
656 (t (%coerce-to-values type
))))
658 ;;; Return type, corresponding to ANSI short form of VALUES type
660 (defun make-short-values-type (types)
661 (declare (list types
))
662 (let ((last-required (position-if
664 (not/type
(csubtypep (specifier-type 'null
) type
)))
668 (make-values-type :required
(subseq types
0 (1+ last-required
))
669 :optional
(subseq types
(1+ last-required
))
670 :rest
*universal-type
*)
671 (make-values-type :optional types
:rest
*universal-type
*))))
673 (defun make-single-value-type (type)
674 (make-values-type :required
(list type
)))
676 ;;; Do the specified OPERATION on TYPE1 and TYPE2, which may be any
677 ;;; type, including VALUES types. With VALUES types such as:
680 ;;; we compute the more useful result
681 ;;; (VALUES (<operation> a0 b0) (<operation> a1 b1))
682 ;;; rather than the precise result
683 ;;; (<operation> (values a0 a1) (values b0 b1))
684 ;;; This has the virtue of always keeping the VALUES type specifier
685 ;;; outermost, and retains all of the information that is really
686 ;;; useful for static type analysis. We want to know what is always
687 ;;; true of each value independently. It is worthless to know that if
688 ;;; the first value is B0 then the second will be B1.
690 ;;; If the VALUES count signatures differ, then we produce a result with
691 ;;; the required VALUE count chosen by NREQ when applied to the number
692 ;;; of required values in TYPE1 and TYPE2. Any &KEY values become
693 ;;; &REST T (anyone who uses keyword values deserves to lose.)
695 ;;; The second value is true if the result is definitely empty or if
696 ;;; OPERATION returned true as its second value each time we called
697 ;;; it. Since we approximate the intersection of VALUES types, the
698 ;;; second value being true doesn't mean the result is exact.
699 (defun args-type-op (type1 type2 operation nreq
)
700 (declare (type ctype type1 type2
)
701 (type function operation nreq
))
702 (when (eq type1 type2
)
704 (multiple-value-bind (types1 rest1
)
705 (values-type-types type1
)
706 (multiple-value-bind (types2 rest2
)
707 (values-type-types type2
)
708 (multiple-value-bind (rest rest-exact
)
709 (funcall operation rest1 rest2
)
710 (multiple-value-bind (res res-exact
)
711 (if (< (length types1
) (length types2
))
712 (fixed-values-op types2 types1 rest1 operation
)
713 (fixed-values-op types1 types2 rest2 operation
))
714 (let* ((req (funcall nreq
715 (length (args-type-required type1
))
716 (length (args-type-required type2
))))
717 (required (subseq res
0 req
))
718 (opt (subseq res req
)))
719 (values required opt rest
720 (and rest-exact res-exact
))))))))
722 (defun values-type-op (type1 type2 operation nreq
)
723 (multiple-value-bind (required optional rest exactp
)
724 (args-type-op type1 type2 operation nreq
)
725 (values (make-values-type :required required
730 (defun compare-key-args (type1 type2
)
731 (let ((keys1 (args-type-keywords type1
))
732 (keys2 (args-type-keywords type2
)))
733 (and (= (length keys1
) (length keys2
))
734 (eq (args-type-allowp type1
)
735 (args-type-allowp type2
))
736 (loop for key1 in keys1
737 for match
= (find (key-info-name key1
)
738 keys2
:key
#'key-info-name
)
740 (type= (key-info-type key1
)
741 (key-info-type match
)))))))
743 (defun type=-args
(type1 type2
)
744 (macrolet ((compare (comparator field
)
745 (let ((reader (symbolicate '#:args-type- field
)))
746 `(,comparator
(,reader type1
) (,reader type2
)))))
748 (cond ((null (args-type-rest type1
))
749 (values (null (args-type-rest type2
)) t
))
750 ((null (args-type-rest type2
))
753 (compare type
= rest
)))
754 (and/type
(and/type
(compare type
=-list required
)
755 (compare type
=-list optional
))
756 (if (or (args-type-keyp type1
) (args-type-keyp type2
))
757 (values (compare-key-args type1 type2
) t
)
760 ;;; Do a union or intersection operation on types that might be values
761 ;;; types. The result is optimized for utility rather than exactness,
762 ;;; but it is guaranteed that it will be no smaller (more restrictive)
763 ;;; than the precise result.
765 ;;; The return convention seems to be analogous to
766 ;;; TYPES-EQUAL-OR-INTERSECT. -- WHN 19990910.
767 (defun-cached (values-type-union :hash-function
#'type-cache-hash
769 ((type1 eq
) (type2 eq
))
770 (declare (type ctype type1 type2
))
771 (cond ((or (eq type1
*wild-type
*) (eq type2
*wild-type
*)) *wild-type
*)
772 ((eq type1
*empty-type
*) type2
)
773 ((eq type2
*empty-type
*) type1
)
775 (values (values-type-op type1 type2
#'type-union
#'min
)))))
777 (defun-cached (values-type-intersection :hash-function
#'type-cache-hash
779 ((type1 eq
) (type2 eq
))
780 (declare (type ctype type1 type2
))
781 (cond ((eq type1
*wild-type
*)
782 (coerce-to-values type2
))
783 ((or (eq type2
*wild-type
*) (eq type2
*universal-type
*))
785 ((or (eq type1
*empty-type
*) (eq type2
*empty-type
*))
787 ((and (not (values-type-p type2
))
788 (values-type-required type1
))
789 (let ((req1 (values-type-required type1
)))
790 (make-values-type :required
(cons (type-intersection (first req1
) type2
)
792 :optional
(values-type-optional type1
)
793 :rest
(values-type-rest type1
)
794 :allowp
(values-type-allowp type1
))))
796 (values (values-type-op type1
(coerce-to-values type2
)
800 ;;; This is like TYPES-EQUAL-OR-INTERSECT, except that it sort of
801 ;;; works on VALUES types. Note that due to the semantics of
802 ;;; VALUES-TYPE-INTERSECTION, this might return (VALUES T T) when
803 ;;; there isn't really any intersection.
804 (defun values-types-equal-or-intersect (type1 type2
)
805 (cond ((or (eq type1
*empty-type
*) (eq type2
*empty-type
*))
807 ((or (eq type1
*wild-type
*) (eq type2
*wild-type
*))
810 (let ((res (values-type-intersection type1 type2
)))
811 (values (not (eq res
*empty-type
*))
814 ;;; a SUBTYPEP-like operation that can be used on any types, including
816 (defun-cached (values-subtypep :hash-function
#'type-cache-hash
819 ((type1 eq
) (type2 eq
))
820 (declare (type ctype type1 type2
))
821 (cond ((or (eq type2
*wild-type
*) (eq type2
*universal-type
*)
822 (eq type1
*empty-type
*))
824 ((eq type1
*wild-type
*)
825 (values (eq type2
*wild-type
*) t
))
826 ((or (eq type2
*empty-type
*)
827 (not (values-types-equal-or-intersect type1 type2
)))
829 ((and (not (values-type-p type2
))
830 (values-type-required type1
))
831 (csubtypep (first (values-type-required type1
))
833 (t (setq type2
(coerce-to-values type2
))
834 (multiple-value-bind (types1 rest1
) (values-type-types type1
)
835 (multiple-value-bind (types2 rest2
) (values-type-types type2
)
836 (cond ((< (length (values-type-required type1
))
837 (length (values-type-required type2
)))
839 ((< (length types1
) (length types2
))
842 (do ((t1 types1
(rest t1
))
843 (t2 types2
(rest t2
)))
845 (csubtypep rest1 rest2
))
846 (multiple-value-bind (res win-p
)
847 (csubtypep (first t1
) (first t2
))
849 (return (values nil nil
)))
851 (return (values nil t
))))))))))))
853 ;;;; type method interfaces
855 ;;; like SUBTYPEP, only works on CTYPE structures
856 (defun-cached (csubtypep :hash-function
#'type-cache-hash
860 ((type1 eq
) (type2 eq
))
861 (declare (type ctype type1 type2
))
862 (cond ((or (eq type1 type2
)
863 (eq type1
*empty-type
*)
864 (eq type2
*universal-type
*))
867 ((eq type1
*universal-type
*)
871 (!invoke-type-method
:simple-subtypep
:complex-subtypep-arg2
873 :complex-arg1
:complex-subtypep-arg1
)))))
875 ;;; Just parse the type specifiers and call CSUBTYPE.
876 (defun sb!xc
:subtypep
(type1 type2
&optional environment
)
877 "Return two values indicating the relationship between type1 and type2.
878 If values are T and T, type1 definitely is a subtype of type2.
879 If values are NIL and T, type1 definitely is not a subtype of type2.
880 If values are NIL and NIL, it couldn't be determined."
881 (declare (type lexenv-designator environment
) (ignore environment
))
882 (declare (explicit-check))
883 (csubtypep (specifier-type type1
) (specifier-type type2
)))
885 ;;; If two types are definitely equivalent, return true. The second
886 ;;; value indicates whether the first value is definitely correct.
887 ;;; This should only fail in the presence of HAIRY types.
888 (defun-cached (type= :hash-function
#'type-cache-hash
892 ((type1 eq
) (type2 eq
))
893 (declare (type ctype type1 type2
))
894 (cond ((eq type1 type2
)
896 ;; If args are not EQ, but both allow TYPE= optimization,
897 ;; and at least one is interned, then return no and certainty.
898 ;; Most of the interned CTYPEs admit this optimization,
899 ;; NUMERIC and MEMBER types do as well.
900 ((and (minusp (logior (type-hash-value type1
) (type-hash-value type2
)))
901 (logtest (logand (type-hash-value type1
) (type-hash-value type2
))
902 +type-admits-type
=-optimization
+))
905 (memoize (!invoke-type-method
:simple-
= :complex-
= type1 type2
)))))
907 ;;; Not exactly the negation of TYPE=, since when the relationship is
908 ;;; uncertain, we still return NIL, NIL. This is useful in cases where
909 ;;; the conservative assumption is =.
910 (defun type/= (type1 type2
)
911 (declare (type ctype type1 type2
))
912 (multiple-value-bind (res win
) (type= type1 type2
)
917 ;;; the type method dispatch case of TYPE-UNION2
918 (defun %type-union2
(type1 type2
)
919 ;; As in %TYPE-INTERSECTION2, it seems to be a good idea to give
920 ;; both argument orders a chance at COMPLEX-INTERSECTION2. Unlike
921 ;; %TYPE-INTERSECTION2, though, I don't have a specific case which
922 ;; demonstrates this is actually necessary. Also unlike
923 ;; %TYPE-INTERSECTION2, there seems to be no need to distinguish
924 ;; between not finding a method and having a method return NIL.
926 (!invoke-type-method
:simple-union2
:complex-union2
929 (declare (inline 1way
))
930 (or (1way type1 type2
)
931 (1way type2 type1
))))
933 ;;; Find a type which includes both types. Any inexactness is
934 ;;; represented by the fuzzy element types; we return a single value
935 ;;; that is precise to the best of our knowledge. This result is
936 ;;; simplified into the canonical form, thus is not a UNION-TYPE
937 ;;; unless we find no other way to represent the result.
938 (defun-cached (type-union2 :hash-function
#'type-cache-hash
941 ((type1 eq
) (type2 eq
))
942 ;; KLUDGE: This was generated from TYPE-INTERSECTION2 by Ye Olde Cut And
943 ;; Paste technique of programming. If it stays around (as opposed to
944 ;; e.g. fading away in favor of some CLOS solution) the shared logic
945 ;; should probably become shared code. -- WHN 2001-03-16
946 (declare (type ctype type1 type2
))
952 ;; CSUBTYPEP for array-types answers questions about the
953 ;; specialized type, yet for union we want to take the
954 ;; expressed type in account too.
955 ((and (not (and (array-type-p type1
) (array-type-p type2
)))
956 (or (setf t2
(csubtypep type1 type2
))
957 (csubtypep type2 type1
)))
959 ((or (union-type-p type1
)
960 (union-type-p type2
))
961 ;; Unions of UNION-TYPE should have the UNION-TYPE-TYPES
962 ;; values broken out and united separately. The full TYPE-UNION
963 ;; function knows how to do this, so let it handle it.
964 (type-union type1 type2
))
966 ;; the ordinary case: we dispatch to type methods
967 (%type-union2 type1 type2
)))))))
969 ;;; the type method dispatch case of TYPE-INTERSECTION2
970 (defun %type-intersection2
(type1 type2
)
971 ;; We want to give both argument orders a chance at
972 ;; COMPLEX-INTERSECTION2. Without that, the old CMU CL type
973 ;; methods could give noncommutative results, e.g.
974 ;; (TYPE-INTERSECTION2 *EMPTY-TYPE* SOME-HAIRY-TYPE)
976 ;; (TYPE-INTERSECTION2 SOME-HAIRY-TYPE *EMPTY-TYPE*)
977 ;; => #<NAMED-TYPE NIL>, T
978 ;; We also need to distinguish between the case where we found a
979 ;; type method, and it returned NIL, and the case where we fell
980 ;; through without finding any type method. An example of the first
981 ;; case is the intersection of a HAIRY-TYPE with some ordinary type.
982 ;; An example of the second case is the intersection of two
983 ;; completely-unrelated types, e.g. CONS and NUMBER, or SYMBOL and
986 ;; (Why yes, CLOS probably *would* be nicer..)
988 (!invoke-type-method
:simple-intersection2
:complex-intersection2
990 :default
:call-other-method
)))
991 (declare (inline 1way
))
992 (let ((xy (1way type1 type2
)))
993 (or (and (not (eql xy
:call-other-method
)) xy
)
994 (let ((yx (1way type2 type1
)))
995 (or (and (not (eql yx
:call-other-method
)) yx
)
996 (cond ((and (eql xy
:call-other-method
)
997 (eql yx
:call-other-method
))
1002 (defun-cached (type-intersection2 :hash-function
#'type-cache-hash
1006 ((type1 eq
) (type2 eq
))
1007 (declare (type ctype type1 type2
))
1008 (if (eq type1 type2
)
1009 ;; FIXME: For some reason, this doesn't catch e.g. type1 =
1010 ;; type2 = (SPECIFIER-TYPE
1011 ;; 'SOME-UNKNOWN-TYPE). Investigate. - CSR, 2002-04-10
1015 ((or (intersection-type-p type1
)
1016 (intersection-type-p type2
))
1017 ;; Intersections of INTERSECTION-TYPE should have the
1018 ;; INTERSECTION-TYPE-TYPES values broken out and intersected
1019 ;; separately. The full TYPE-INTERSECTION function knows how
1020 ;; to do that, so let it handle it.
1021 (type-intersection type1 type2
))
1023 ;; the ordinary case: we dispatch to type methods
1024 (%type-intersection2 type1 type2
))))))
1026 ;;; Return as restrictive and simple a type as we can discover that is
1027 ;;; no more restrictive than the intersection of TYPE1 and TYPE2. At
1028 ;;; worst, we arbitrarily return one of the arguments as the first
1029 ;;; value (trying not to return a hairy type).
1030 (defun type-approx-intersection2 (type1 type2
)
1031 (cond ((type-intersection2 type1 type2
))
1032 ((hairy-type-p type1
) type2
)
1035 ;;; a test useful for checking whether a derived type matches a
1038 ;;; The first value is true unless the types don't intersect and
1039 ;;; aren't equal. The second value is true if the first value is
1040 ;;; definitely correct. NIL is considered to intersect with any type.
1041 ;;; If T is a subtype of either type, then we also return T, T. This
1042 ;;; way we recognize that hairy types might intersect with T.
1044 ;;; Well now given the statement above that this is "useful for ..."
1045 ;;; a particular thing, I see how treating *empty-type* magically could
1046 ;;; be useful, however given all the _other_ calls to this function within
1047 ;;; this file, it seems suboptimal, because logically it is wrong.
1048 (defun types-equal-or-intersect (type1 type2
)
1049 (declare (type ctype type1 type2
))
1050 (if (or (eq type1
*empty-type
*) (eq type2
*empty-type
*))
1052 (let ((intersection2 (type-intersection2 type1 type2
)))
1053 (cond ((not intersection2
)
1054 (if (or (csubtypep *universal-type
* type1
)
1055 (csubtypep *universal-type
* type2
))
1058 ((eq intersection2
*empty-type
*) (values nil t
))
1059 (t (values t t
))))))
1061 ;;; Return a Common Lisp type specifier corresponding to the TYPE
1063 (defun type-specifier (type)
1064 (declare (type ctype type
))
1065 (funcall (type-class-unparse (type-class-info type
)) type
))
1067 ;;; Don't try to define a print method until it's actually gonna work!
1068 ;;; (Otherwise this would be near the DEFSTRUCT)
1069 (defmethod print-object ((ctype ctype
) stream
)
1070 (print-unreadable-object (ctype stream
:type t
)
1071 (prin1 (type-specifier ctype
) stream
)))
1074 ;;; Just dump it as a specifier. (We'll convert it back upon loading.)
1075 (defmethod make-load-form ((type ctype
) &optional env
)
1076 (declare (ignore env
))
1077 `(,(if (values-type-p type
)
1078 'values-specifier-type
1080 ',(type-specifier type
)))
1082 (defun-cached (type-negation :hash-function
#'type-hash-value
1086 (declare (type ctype type
))
1087 (funcall (type-class-negate (type-class-info type
)) type
))
1089 (defun-cached (type-singleton-p :hash-function
#'type-hash-value
1093 (declare (type ctype type
))
1094 (let ((function (type-class-singleton-p (type-class-info type
))))
1096 (funcall function type
)
1099 ;;; (VALUES-SPECIFIER-TYPE and SPECIFIER-TYPE moved from here to
1100 ;;; early-type.lisp by WHN ca. 19990201.)
1102 ;;; Take a list of type specifiers, computing the translation of each
1103 ;;; specifier and defining it as a builtin type.
1104 ;;; Seee the comments in 'type-init' for why this is a slightly
1105 ;;; screwy way to go about it.
1106 (declaim (ftype (function (list) (values)) !precompute-types
))
1107 (defun !precompute-types
(specs)
1108 (dolist (spec specs
)
1109 (let ((res (handler-bind
1110 ((parse-unknown-type
1112 (declare (ignore c
))
1113 ;; We can handle conditions at this point,
1114 ;; but win32 can not perform i/o here because
1115 ;; !MAKE-COLD-STDERR-STREAM has no implementation.
1116 ;; FIXME: where is this coming from???
1118 (progn (write-string "//caught: parse-unknown ")
1121 (specifier-type spec
))))
1122 (unless (unknown-type-p res
)
1123 (setf (info :type
:builtin spec
) res
)
1124 (setf (info :type
:kind spec
) :primitive
))))
1127 ;;;; general TYPE-UNION and TYPE-INTERSECTION operations
1129 ;;;; These are fully general operations on CTYPEs: they'll always
1130 ;;;; return a CTYPE representing the result.
1132 ;;; shared logic for unions and intersections: Return a list of
1133 ;;; types representing the same types as INPUT-TYPES, but with
1134 ;;; COMPOUND-TYPEs satisfying %COMPOUND-TYPE-P broken up into their
1135 ;;; component types, and with any SIMPLY2 simplifications applied.
1137 ((def (name compound-type-p simplify2
)
1138 `(defun ,name
(types)
1140 (multiple-value-bind (first rest
)
1141 (if (,compound-type-p
(car types
))
1142 (values (car (compound-type-types (car types
)))
1143 (append (cdr (compound-type-types (car types
)))
1145 (values (car types
) (cdr types
)))
1146 (let ((rest (,name rest
)) u
)
1147 (dolist (r rest
(cons first rest
))
1148 (when (setq u
(,simplify2 first r
))
1149 (return (,name
(nsubstitute u r rest
)))))))))))
1150 (def simplify-intersections intersection-type-p type-intersection2
)
1151 (def simplify-unions union-type-p type-union2
))
1153 (defun maybe-distribute-one-union (union-type types
)
1154 (let* ((intersection (apply #'type-intersection types
))
1155 (union (mapcar (lambda (x) (type-intersection x intersection
))
1156 (union-type-types union-type
))))
1157 (if (notany (lambda (x) (or (hairy-type-p x
)
1158 (intersection-type-p x
)))
1163 (defun type-intersection (&rest input-types
)
1164 (%type-intersection input-types
))
1165 (defun-cached (%type-intersection
:hash-bits
10 :hash-function
#'type-list-cache-hash
)
1166 ((input-types equal
))
1167 (let ((simplified-types (simplify-intersections input-types
)))
1168 (declare (type list simplified-types
))
1169 ;; We want to have a canonical representation of types (or failing
1170 ;; that, punt to HAIRY-TYPE). Canonical representation would have
1171 ;; intersections inside unions but not vice versa, since you can
1172 ;; always achieve that by the distributive rule. But we don't want
1173 ;; to just apply the distributive rule, since it would be too easy
1174 ;; to end up with unreasonably huge type expressions. So instead
1175 ;; we try to generate a simple type by distributing the union; if
1176 ;; the type can't be made simple, we punt to HAIRY-TYPE.
1177 (if (and (cdr simplified-types
) (some #'union-type-p simplified-types
))
1178 (let* ((first-union (find-if #'union-type-p simplified-types
))
1179 (other-types (coerce (remove first-union simplified-types
)
1181 (distributed (maybe-distribute-one-union first-union
1184 (apply #'type-union distributed
)
1185 (%make-hairy-type
`(and ,@(map 'list
#'type-specifier
1186 simplified-types
)))))
1188 ((null simplified-types
) *universal-type
*)
1189 ((null (cdr simplified-types
)) (car simplified-types
))
1190 (t (%make-intersection-type
1191 (some #'type-enumerable simplified-types
)
1192 simplified-types
))))))
1194 (defun type-union (&rest input-types
)
1195 (%type-union input-types
))
1196 (defun-cached (%type-union
:hash-bits
8 :hash-function
#'type-list-cache-hash
)
1197 ((input-types equal
))
1198 (let ((simplified-types (simplify-unions input-types
)))
1200 ((null simplified-types
) *empty-type
*)
1201 ((null (cdr simplified-types
)) (car simplified-types
))
1203 (every #'type-enumerable simplified-types
)
1204 simplified-types
)))))
1208 (!define-type-method
(named :simple-
=) (type1 type2
)
1209 ;;(aver (not (eq type1 *wild-type*))) ; * isn't really a type.
1210 (values (eq type1 type2
) t
))
1212 (defun cons-type-might-be-empty-type (type)
1213 (declare (type cons-type type
))
1214 (let ((car-type (cons-type-car-type type
))
1215 (cdr-type (cons-type-cdr-type type
)))
1217 (if (cons-type-p car-type
)
1218 (cons-type-might-be-empty-type car-type
)
1219 (multiple-value-bind (yes surep
)
1220 (type= car-type
*empty-type
*)
1223 (if (cons-type-p cdr-type
)
1224 (cons-type-might-be-empty-type cdr-type
)
1225 (multiple-value-bind (yes surep
)
1226 (type= cdr-type
*empty-type
*)
1230 (defun cons-type-length-info (type)
1231 (declare (type cons-type type
))
1232 (do ((min 1 (1+ min
))
1233 (cdr (cons-type-cdr-type type
) (cons-type-cdr-type cdr
)))
1234 ((not (cons-type-p cdr
))
1236 ((csubtypep cdr
(specifier-type 'null
))
1238 ((csubtypep *universal-type
* cdr
)
1240 ((type/= (type-intersection (specifier-type 'cons
) cdr
) *empty-type
*)
1242 ((type/= (type-intersection (specifier-type 'null
) cdr
) *empty-type
*)
1244 (t (values min
:maybe
))))
1247 (!define-type-method
(named :complex-
=) (type1 type2
)
1249 ((and (eq type2
*empty-type
*)
1250 (or (and (intersection-type-p type1
)
1251 ;; not allowed to be unsure on these... FIXME: keep
1252 ;; the list of CL types that are intersection types
1253 ;; once and only once.
1254 (not (or (type= type1
(specifier-type 'ratio
))
1255 (type= type1
(specifier-type 'keyword
)))))
1256 (and (cons-type-p type1
)
1257 (cons-type-might-be-empty-type type1
))))
1258 ;; things like (AND (EQL 0) (SATISFIES ODDP)) or (AND FUNCTION
1259 ;; STREAM) can get here. In general, we can't really tell
1260 ;; whether these are equal to NIL or not, so
1262 ((type-might-contain-other-types-p type1
)
1263 (invoke-complex-=-other-method type1 type2
))
1264 (t (values nil t
))))
1266 (!define-type-method
(named :simple-subtypep
) (type1 type2
)
1267 (aver (not (eq type1
*wild-type
*))) ; * isn't really a type.
1268 (aver (not (eq type1 type2
)))
1269 (values (or (eq type1
*empty-type
*)
1270 (eq type2
*wild-type
*)
1271 (eq type2
*universal-type
*)) t
))
1273 (!define-type-method
(named :complex-subtypep-arg1
) (type1 type2
)
1274 ;; This AVER causes problems if we write accurate methods for the
1275 ;; union (and possibly intersection) types which then delegate to
1276 ;; us; while a user shouldn't get here, because of the odd status of
1277 ;; *wild-type* a type-intersection executed by the compiler can. -
1280 ;; (aver (not (eq type1 *wild-type*))) ; * isn't really a type.
1281 (cond ((eq type1
*empty-type
*)
1283 (;; When TYPE2 might be the universal type in disguise
1284 (type-might-contain-other-types-p type2
)
1285 ;; Now that the UNION and HAIRY COMPLEX-SUBTYPEP-ARG2 methods
1286 ;; can delegate to us (more or less as CALL-NEXT-METHOD) when
1287 ;; they're uncertain, we can't just barf on COMPOUND-TYPE and
1288 ;; HAIRY-TYPEs as we used to. Instead we deal with the
1289 ;; problem (where at least part of the problem is cases like
1290 ;; (SUBTYPEP T '(SATISFIES FOO))
1292 ;; (SUBTYPEP T '(AND (SATISFIES FOO) (SATISFIES BAR)))
1293 ;; where the second type is a hairy type like SATISFIES, or
1294 ;; is a compound type which might contain a hairy type) by
1295 ;; returning uncertainty.
1297 ((eq type1
*funcallable-instance-type
*)
1298 (values (eq type2
(specifier-type 'function
)) t
))
1300 ;; This case would have been picked off by the SIMPLE-SUBTYPEP
1301 ;; method, and so shouldn't appear here.
1302 (aver (not (named-type-p type2
)))
1303 ;; Since TYPE2 is not EQ *UNIVERSAL-TYPE* and is not another
1304 ;; named type in disguise, TYPE2 is not a superset of TYPE1.
1307 (!define-type-method
(named :complex-subtypep-arg2
) (type1 type2
)
1308 (aver (not (eq type2
*wild-type
*))) ; * isn't really a type.
1309 (cond ((eq type2
*universal-type
*)
1311 ;; some CONS types can conceal danger
1312 ((and (cons-type-p type1
) (cons-type-might-be-empty-type type1
))
1314 ((type-might-contain-other-types-p type1
)
1315 ;; those types can be other types in disguise. So we'd
1317 (invoke-complex-subtypep-arg1-method type1 type2
))
1318 ((and (or (eq type2
*instance-type
*)
1319 (eq type2
*funcallable-instance-type
*))
1320 (member-type-p type1
))
1321 ;; member types can be subtypep INSTANCE and
1322 ;; FUNCALLABLE-INSTANCE in surprising ways.
1323 (invoke-complex-subtypep-arg1-method type1 type2
))
1324 ((and (eq type2
*extended-sequence-type
*) (classoid-p type1
))
1325 (values (if (classoid-inherits-from type1
'sequence
) t nil
) t
))
1326 ((and (eq type2
*instance-type
*) (classoid-p type1
))
1328 ((classoid-non-instance-p type1
)
1330 ((classoid-inherits-from type1
'function
)
1332 ((eq type1
(find-classoid 'function
))
1334 ((or (structure-classoid-p type1
)
1335 (condition-classoid-p type1
))
1337 (t (values nil nil
))))
1338 ((and (eq type2
*funcallable-instance-type
*) (classoid-p type1
))
1339 (if (and (not (classoid-non-instance-p type1
))
1340 (classoid-inherits-from type1
'function
))
1344 ;; FIXME: This seems to rely on there only being 4 or 5
1345 ;; NAMED-TYPE values, and the exclusion of various
1346 ;; possibilities above. It would be good to explain it and/or
1347 ;; rewrite it so that it's clearer.
1350 (!define-type-method
(named :simple-intersection2
) (type1 type2
)
1352 ((and (eq type1
*extended-sequence-type
*)
1353 (or (eq type2
*instance-type
*)
1354 (eq type2
*funcallable-instance-type
*)))
1356 ((and (or (eq type1
*instance-type
*)
1357 (eq type1
*funcallable-instance-type
*))
1358 (eq type2
*extended-sequence-type
*))
1361 (hierarchical-intersection2 type1 type2
))))
1363 (!define-type-method
(named :complex-intersection2
) (type1 type2
)
1364 ;; FIXME: This assertion failed when I added it in sbcl-0.6.11.13.
1365 ;; Perhaps when bug 85 is fixed it can be reenabled.
1366 ;;(aver (not (eq type2 *wild-type*))) ; * isn't really a type.
1367 (flet ((empty-unless-hairy (type)
1368 (unless (or (type-might-contain-other-types-p type
)
1369 (member-type-p type
))
1372 ((eq type2
*extended-sequence-type
*)
1374 ((or structure-classoid condition-classoid
) *empty-type
*)
1376 ((classoid-non-instance-p type1
) *empty-type
*)
1377 ((classoid-inherits-from type1
'sequence
) type1
)))
1378 (t (empty-unless-hairy type1
))))
1379 ((eq type2
*instance-type
*)
1381 ((or structure-classoid condition-classoid
) type1
)
1382 (classoid (when (or (classoid-non-instance-p type1
)
1383 (eq type1
(find-classoid 'function
))
1384 (classoid-inherits-from type1
'function
))
1386 (t (empty-unless-hairy type1
))))
1387 ((eq type2
*funcallable-instance-type
*)
1389 ((or structure-classoid condition-classoid
) *empty-type
*)
1392 ((classoid-non-instance-p type1
) *empty-type
*)
1393 ((classoid-inherits-from type1
'function
) type1
)
1394 ((type= type1
(find-classoid 'function
)) type2
)))
1396 (t (empty-unless-hairy type1
))))
1397 (t (hierarchical-intersection2 type1 type2
)))))
1399 (!define-type-method
(named :complex-union2
) (type1 type2
)
1400 ;; Perhaps when bug 85 is fixed this can be reenabled.
1401 ;;(aver (not (eq type2 *wild-type*))) ; * isn't really a type.
1403 ((eq type2
*extended-sequence-type
*)
1404 (cond ((not (classoid-p type1
)) nil
)
1405 ((and (not (classoid-non-instance-p type1
))
1406 (classoid-inherits-from type1
'sequence
))
1408 ((eq type2
*instance-type
*)
1409 (cond ((not (classoid-p type1
)) nil
)
1410 ((and (not (classoid-non-instance-p type1
))
1411 (not (classoid-inherits-from type1
'function
)))
1413 ((eq type2
*funcallable-instance-type
*)
1414 (cond ((not (classoid-p type1
)) nil
)
1415 ((classoid-non-instance-p type1
) nil
)
1416 ((not (classoid-inherits-from type1
'function
)) nil
)
1417 ((eq type1
(specifier-type 'function
)) type1
)
1419 (t (hierarchical-union2 type1 type2
))))
1421 (!define-type-method
(named :negate
) (x)
1422 (aver (not (eq x
*wild-type
*)))
1424 ((eq x
*universal-type
*) *empty-type
*)
1425 ((eq x
*empty-type
*) *universal-type
*)
1426 ((or (eq x
*instance-type
*)
1427 (eq x
*funcallable-instance-type
*)
1428 (eq x
*extended-sequence-type
*))
1429 (make-negation-type x
))
1430 (t (bug "NAMED type unexpected: ~S" x
))))
1432 (!define-type-method
(named :unparse
) (x)
1433 (named-type-name x
))
1435 ;;;; hairy and unknown types
1436 ;;;; DEFINE-TYPE-CLASS HAIRY is in 'early-type'
1438 (!define-type-method
(hairy :negate
) (x) (make-negation-type x
))
1440 (!define-type-method
(hairy :unparse
) (x)
1441 (hairy-type-specifier x
))
1443 (!define-type-method
(hairy :simple-subtypep
) (type1 type2
)
1444 (let ((hairy-spec1 (hairy-type-specifier type1
))
1445 (hairy-spec2 (hairy-type-specifier type2
)))
1446 (cond ((equal-but-no-car-recursion hairy-spec1 hairy-spec2
)
1448 ((maybe-reparse-specifier! type1
)
1449 (csubtypep type1 type2
))
1450 ((maybe-reparse-specifier! type2
)
1451 (csubtypep type1 type2
))
1453 (values nil nil
)))))
1455 (!define-type-method
(hairy :complex-subtypep-arg2
) (type1 type2
)
1456 (if (maybe-reparse-specifier! type2
)
1457 (csubtypep type1 type2
)
1458 (let ((specifier (hairy-type-specifier type2
)))
1459 (cond ((and (consp specifier
) (eql (car specifier
) 'satisfies
))
1460 (case (cadr specifier
)
1461 ((keywordp) (if (type= type1
(specifier-type 'symbol
))
1463 (invoke-complex-subtypep-arg1-method type1 type2
)))
1464 (t (invoke-complex-subtypep-arg1-method type1 type2
))))
1466 (invoke-complex-subtypep-arg1-method type1 type2
))))))
1468 (!define-type-method
(hairy :complex-subtypep-arg1
) (type1 type2
)
1469 (if (maybe-reparse-specifier! type1
)
1470 (csubtypep type1 type2
)
1473 (!define-type-method
(hairy :complex-
=) (type1 type2
)
1474 (if (maybe-reparse-specifier! type2
)
1478 (!define-type-method
(hairy :simple-intersection2
:complex-intersection2
)
1480 (acond ((type= type1 type2
)
1482 ((eq type2
(literal-ctype *satisfies-keywordp-type
*))
1483 ;; (AND (MEMBER A) (SATISFIES KEYWORDP)) is possibly non-empty
1484 ;; if A is re-homed as :A. However as a special case that really
1485 ;; does occur, (AND (MEMBER NIL) (SATISFIES KEYWORDP))
1486 ;; is empty because of the illegality of changing NIL's package.
1487 (if (eq type1
(specifier-type 'null
))
1489 (multiple-value-bind (answer certain
)
1490 (types-equal-or-intersect type1
(specifier-type 'symbol
))
1491 (and (not answer
) certain
*empty-type
*))))
1492 ((eq type2
(literal-ctype *fun-name-type
*))
1493 (multiple-value-bind (answer certain
)
1494 (types-equal-or-intersect type1
(specifier-type 'symbol
))
1497 (multiple-value-bind (answer certain
)
1498 (types-equal-or-intersect type1
(specifier-type 'cons
))
1499 (and (not answer
) certain
*empty-type
*)))))
1500 ((and (typep (hairy-type-specifier type2
) '(cons (eql satisfies
)))
1501 (info :function
:predicate-truth-constraint
1502 (cadr (hairy-type-specifier type2
))))
1503 (multiple-value-bind (answer certain
)
1504 (types-equal-or-intersect type1
(specifier-type it
))
1505 (and (not answer
) certain
*empty-type
*)))))
1507 (!define-type-method
(hairy :simple-union2
)
1509 (if (type= type1 type2
)
1513 (!define-type-method
(hairy :simple-
=) (type1 type2
)
1514 (if (equal-but-no-car-recursion (hairy-type-specifier type1
)
1515 (hairy-type-specifier type2
))
1519 (!def-type-translator satisfies
:list
(&whole whole predicate-name
)
1520 (unless (symbolp predicate-name
)
1521 (error 'simple-type-error
1522 :datum predicate-name
1523 :expected-type
'symbol
1524 :format-control
"The SATISFIES predicate name is not a symbol: ~S"
1525 :format-arguments
(list predicate-name
)))
1526 (case predicate-name
1527 (keywordp (literal-ctype *satisfies-keywordp-type
*))
1528 (legal-fun-name-p (literal-ctype *fun-name-type
*))
1529 (t (%make-hairy-type whole
))))
1533 (!define-type-method
(negation :negate
) (x)
1534 (negation-type-type x
))
1536 (!define-type-method
(negation :unparse
) (x)
1537 (if (type= (negation-type-type x
) (specifier-type 'cons
))
1539 `(not ,(type-specifier (negation-type-type x
)))))
1541 (!define-type-method
(negation :simple-subtypep
) (type1 type2
)
1542 (csubtypep (negation-type-type type2
) (negation-type-type type1
)))
1544 (!define-type-method
(negation :complex-subtypep-arg2
) (type1 type2
)
1545 (let* ((complement-type2 (negation-type-type type2
))
1546 (intersection2 (type-intersection2 type1
1549 ;; FIXME: if uncertain, maybe try arg1?
1550 (type= intersection2
*empty-type
*)
1551 (invoke-complex-subtypep-arg1-method type1 type2
))))
1553 (!define-type-method
(negation :complex-subtypep-arg1
) (type1 type2
)
1554 ;; "Incrementally extended heuristic algorithms tend inexorably toward the
1555 ;; incomprehensible." -- http://www.unlambda.com/~james/lambda/lambda.txt
1557 ;; You may not believe this. I couldn't either. But then I sat down
1558 ;; and drew lots of Venn diagrams. Comments involving a and b refer
1559 ;; to the call (subtypep '(not a) 'b) -- CSR, 2002-02-27.
1561 ;; (Several logical truths in this block are true as long as
1562 ;; b/=T. As of sbcl-0.7.1.28, it seems impossible to construct a
1563 ;; case with b=T where we actually reach this type method, but
1564 ;; we'll test for and exclude this case anyway, since future
1565 ;; maintenance might make it possible for it to end up in this
1567 (multiple-value-bind (equal certain
)
1568 (type= type2
*universal-type
*)
1570 (return (values nil nil
)))
1572 (return (values t t
))))
1573 (let ((complement-type1 (negation-type-type type1
)))
1574 ;; Do the special cases first, in order to give us a chance if
1575 ;; subtype/supertype relationships are hairy.
1576 (multiple-value-bind (equal certain
)
1577 (type= complement-type1 type2
)
1578 ;; If a = b, ~a is not a subtype of b (unless b=T, which was
1581 (return (values nil nil
)))
1583 (return (values nil t
))))
1584 ;; KLUDGE: ANSI requires that the SUBTYPEP result between any
1585 ;; two built-in atomic type specifiers never be uncertain. This
1586 ;; is hard to do cleanly for the built-in types whose
1587 ;; definitions include (NOT FOO), i.e. CONS and RATIO. However,
1588 ;; we can do it with this hack, which uses our global knowledge
1589 ;; that our implementation of the type system uses disjoint
1590 ;; implementation types to represent disjoint sets (except when
1591 ;; types are contained in other types). (This is a KLUDGE
1592 ;; because it's fragile. Various changes in internal
1593 ;; representation in the type system could make it start
1594 ;; confidently returning incorrect results.) -- WHN 2002-03-08
1595 (unless (or (type-might-contain-other-types-p complement-type1
)
1596 (type-might-contain-other-types-p type2
))
1597 ;; Because of the way our types which don't contain other
1598 ;; types are disjoint subsets of the space of possible values,
1599 ;; (SUBTYPEP '(NOT AA) 'B)=NIL when AA and B are simple (and B
1600 ;; is not T, as checked above).
1601 (return (values nil t
)))
1602 ;; The old (TYPE= TYPE1 TYPE2) branch would never be taken, as
1603 ;; TYPE1 and TYPE2 will only be equal if they're both NOT types,
1604 ;; and then the :SIMPLE-SUBTYPEP method would be used instead.
1605 ;; But a CSUBTYPEP relationship might still hold:
1606 (multiple-value-bind (equal certain
)
1607 (csubtypep complement-type1 type2
)
1608 ;; If a is a subtype of b, ~a is not a subtype of b (unless
1609 ;; b=T, which was excluded above).
1611 (return (values nil nil
)))
1613 (return (values nil t
))))
1614 (multiple-value-bind (equal certain
)
1615 (csubtypep type2 complement-type1
)
1616 ;; If b is a subtype of a, ~a is not a subtype of b. (FIXME:
1617 ;; That's not true if a=T. Do we know at this point that a is
1620 (return (values nil nil
)))
1622 (return (values nil t
))))
1623 ;; old CSR comment ca. 0.7.2, now obsoleted by the SIMPLE-CTYPE?
1624 ;; KLUDGE case above: Other cases here would rely on being able
1625 ;; to catch all possible cases, which the fragility of this type
1626 ;; system doesn't inspire me; for instance, if a is type= to ~b,
1627 ;; then we want T, T; if this is not the case and the types are
1628 ;; disjoint (have an intersection of *empty-type*) then we want
1629 ;; NIL, T; else if the union of a and b is the *universal-type*
1630 ;; then we want T, T. So currently we still claim to be unsure
1631 ;; about e.g. (subtypep '(not fixnum) 'single-float).
1633 ;; OTOH we might still get here:
1636 (!define-type-method
(negation :complex-
=) (type1 type2
)
1637 ;; (NOT FOO) isn't equivalent to anything that's not a negation
1638 ;; type, except possibly a type that might contain it in disguise.
1639 (declare (ignore type2
))
1640 (if (type-might-contain-other-types-p type1
)
1644 (!define-type-method
(negation :simple-intersection2
) (type1 type2
)
1645 (let ((not1 (negation-type-type type1
))
1646 (not2 (negation-type-type type2
)))
1648 ((csubtypep not1 not2
) type2
)
1649 ((csubtypep not2 not1
) type1
)
1650 ;; Why no analagous clause to the disjoint in the SIMPLE-UNION2
1651 ;; method, below? The clause would read
1653 ;; ((EQ (TYPE-UNION NOT1 NOT2) *UNIVERSAL-TYPE*) *EMPTY-TYPE*)
1655 ;; but with proper canonicalization of negation types, there's
1656 ;; no way of constructing two negation types with union of their
1657 ;; negations being the universal type.
1659 (aver (not (eq (type-union not1 not2
) *universal-type
*)))
1662 (defun maybe-complex-array-refinement (type1 type2
)
1663 (let* ((ntype (negation-type-type type2
))
1664 (ndims (array-type-dimensions ntype
))
1665 (ncomplexp (array-type-complexp ntype
))
1666 (nseltype (array-type-specialized-element-type ntype
))
1667 (neltype (array-type-element-type ntype
)))
1668 (if (and (eql ndims
'*) (null ncomplexp
)
1669 (eq neltype
*wild-type
*) (eq nseltype
*wild-type
*))
1670 (make-array-type (array-type-dimensions type1
)
1672 :element-type
(array-type-element-type type1
)
1673 :specialized-element-type
(array-type-specialized-element-type type1
)))))
1675 (!define-type-method
(negation :complex-intersection2
) (type1 type2
)
1677 ((csubtypep type1
(negation-type-type type2
)) *empty-type
*)
1678 ((eq (type-intersection type1
(negation-type-type type2
)) *empty-type
*)
1680 ((and (array-type-p type1
) (array-type-p (negation-type-type type2
)))
1681 (maybe-complex-array-refinement type1 type2
))
1684 (!define-type-method
(negation :simple-union2
) (type1 type2
)
1685 (let ((not1 (negation-type-type type1
))
1686 (not2 (negation-type-type type2
)))
1688 ((csubtypep not1 not2
) type1
)
1689 ((csubtypep not2 not1
) type2
)
1690 ((eq (type-intersection not1 not2
) *empty-type
*)
1694 (!define-type-method
(negation :complex-union2
) (type1 type2
)
1696 ((csubtypep (negation-type-type type2
) type1
) *universal-type
*)
1697 ((eq (type-intersection type1
(negation-type-type type2
)) *empty-type
*)
1701 (!define-type-method
(negation :simple-
=) (type1 type2
)
1702 (type= (negation-type-type type1
) (negation-type-type type2
)))
1704 (!def-type-translator not
:list
((:context context
) typespec
)
1705 (type-negation (specifier-type-r context typespec
)))
1709 (declaim (inline numeric-type-equal
))
1710 (defun numeric-type-equal (type1 type2
)
1711 (and (eq (numeric-type-class type1
) (numeric-type-class type2
))
1712 (eq (numeric-type-format type1
) (numeric-type-format type2
))
1713 (eq (numeric-type-complexp type1
) (numeric-type-complexp type2
))))
1715 (!define-type-method
(number :simple-
=) (type1 type2
)
1717 (and (numeric-type-equal type1 type2
)
1718 (equalp (numeric-type-low type1
) (numeric-type-low type2
))
1719 (equalp (numeric-type-high type1
) (numeric-type-high type2
)))
1722 (!define-type-method
(number :negate
) (type)
1723 (if (and (null (numeric-type-low type
)) (null (numeric-type-high type
)))
1724 (make-negation-type type
)
1726 (make-negation-type (modified-numeric-type type
:low nil
:high nil
))
1728 ((null (numeric-type-low type
))
1729 (modified-numeric-type
1731 :low
(let ((h (numeric-type-high type
)))
1732 (if (consp h
) (car h
) (list h
)))
1734 ((null (numeric-type-high type
))
1735 (modified-numeric-type
1738 :high
(let ((l (numeric-type-low type
)))
1739 (if (consp l
) (car l
) (list l
)))))
1741 (modified-numeric-type
1744 :high
(let ((l (numeric-type-low type
)))
1745 (if (consp l
) (car l
) (list l
))))
1746 (modified-numeric-type
1748 :low
(let ((h (numeric-type-high type
)))
1749 (if (consp h
) (car h
) (list h
)))
1752 (!define-type-method
(number :unparse
) (type)
1753 (let* ((complexp (numeric-type-complexp type
))
1754 (low (numeric-type-low type
))
1755 (high (numeric-type-high type
))
1756 (base (case (numeric-type-class type
)
1758 (rational 'rational
)
1759 (float (or (numeric-type-format type
) 'float
))
1762 (cond ((and (eq base
'integer
) high low
)
1763 (let ((high-count (logcount high
))
1764 (high-length (integer-length high
)))
1766 (cond ((= high
0) '(integer 0 0))
1768 ((and (= high-count high-length
)
1769 (plusp high-length
))
1770 `(unsigned-byte ,high-length
))
1772 `(mod ,(1+ high
)))))
1773 ((and (= low sb
!xc
:most-negative-fixnum
)
1774 (= high sb
!xc
:most-positive-fixnum
))
1776 ((and (= low
(lognot high
))
1777 (= high-count high-length
)
1779 `(signed-byte ,(1+ high-length
)))
1781 `(integer ,low
,high
)))))
1782 (high `(,base
,(or low
'*) ,high
))
1784 (if (and (eq base
'integer
) (= low
0))
1792 (aver (neq base
+bounds
'real
))
1793 `(complex ,base
+bounds
))
1795 (aver (eq base
+bounds
'real
))
1798 (!define-type-method
(number :singleton-p
) (type)
1799 (let ((low (numeric-type-low type
))
1800 (high (numeric-type-high type
)))
1803 (eql (numeric-type-complexp type
) :real
)
1804 (member (numeric-type-class type
) '(integer rational
1805 #-sb-xc-host float
)))
1806 (values t
(numeric-type-low type
))
1809 ;;; Return true if X is "less than or equal" to Y, taking open bounds
1810 ;;; into consideration. CLOSED is the predicate used to test the bound
1811 ;;; on a closed interval (e.g. <=), and OPEN is the predicate used on
1812 ;;; open bounds (e.g. <). Y is considered to be the outside bound, in
1813 ;;; the sense that if it is infinite (NIL), then the test succeeds,
1814 ;;; whereas if X is infinite, then the test fails (unless Y is also
1817 ;;; This is for comparing bounds of the same kind, e.g. upper and
1818 ;;; upper. Use NUMERIC-BOUND-TEST* for different kinds of bounds.
1819 (defmacro numeric-bound-test
(x y closed open
)
1824 (,closed
(car ,x
) (car ,y
))
1825 (,closed
(car ,x
) ,y
)))
1831 ;;; This is used to compare upper and lower bounds. This is different
1832 ;;; from the same-bound case:
1833 ;;; -- Since X = NIL is -infinity, whereas y = NIL is +infinity, we
1834 ;;; return true if *either* arg is NIL.
1835 ;;; -- an open inner bound is "greater" and also squeezes the interval,
1836 ;;; causing us to use the OPEN test for those cases as well.
1837 (defmacro numeric-bound-test
* (x y closed open
)
1842 (,open
(car ,x
) (car ,y
))
1843 (,open
(car ,x
) ,y
)))
1849 ;;; Return whichever of the numeric bounds X and Y is "maximal"
1850 ;;; according to the predicates CLOSED (e.g. >=) and OPEN (e.g. >).
1851 ;;; This is only meaningful for maximizing like bounds, i.e. upper and
1852 ;;; upper. If MAX-P is true, then we return NIL if X or Y is NIL,
1853 ;;; otherwise we return the other arg.
1854 (defmacro numeric-bound-max
(x y closed open max-p
)
1857 `(cond ((not ,n-x
) ,(if max-p nil n-y
))
1858 ((not ,n-y
) ,(if max-p nil n-x
))
1861 (if (,closed
(car ,n-x
) (car ,n-y
)) ,n-x
,n-y
)
1862 (if (,open
(car ,n-x
) ,n-y
) ,n-x
,n-y
)))
1865 (if (,open
(car ,n-y
) ,n-x
) ,n-y
,n-x
)
1866 (if (,closed
,n-y
,n-x
) ,n-y
,n-x
))))))
1868 (!define-type-method
(number :simple-subtypep
) (type1 type2
)
1869 (let ((class1 (numeric-type-class type1
))
1870 (class2 (numeric-type-class type2
))
1871 (complexp2 (numeric-type-complexp type2
))
1872 (format2 (numeric-type-format type2
))
1873 (low1 (numeric-type-low type1
))
1874 (high1 (numeric-type-high type1
))
1875 (low2 (numeric-type-low type2
))
1876 (high2 (numeric-type-high type2
)))
1877 ;; If one is complex and the other isn't, they are disjoint.
1878 (cond ((not (or (eq (numeric-type-complexp type1
) complexp2
)
1881 ;; If the classes are specified and different, the types are
1882 ;; disjoint unless type2 is RATIONAL and type1 is INTEGER.
1883 ;; [ or type1 is INTEGER and type2 is of the form (RATIONAL
1884 ;; X X) for integral X, but this is dealt with in the
1885 ;; canonicalization inside MAKE-NUMERIC-TYPE ]
1886 ((not (or (eq class1 class2
)
1888 (and (eq class1
'integer
) (eq class2
'rational
))))
1890 ;; If the float formats are specified and different, the types
1892 ((not (or (eq (numeric-type-format type1
) format2
)
1895 ;; Check the bounds.
1896 ((and (numeric-bound-test low1 low2
>= >)
1897 (numeric-bound-test high1 high2
<= <))
1902 (!define-superclasses number
((number)) !cold-init-forms
)
1904 ;;; If the high bound of LOW is adjacent to the low bound of HIGH,
1905 ;;; then return true, otherwise NIL.
1906 (defun numeric-types-adjacent (low high
)
1907 (let ((low-bound (numeric-type-high low
))
1908 (high-bound (numeric-type-low high
)))
1909 (cond ((not (and low-bound high-bound
)) nil
)
1910 ((and (consp low-bound
) (consp high-bound
)) nil
)
1912 (let ((low-value (car low-bound
)))
1913 (or (eql low-value high-bound
)
1915 (load-time-value (make-unportable-float
1916 :single-float-negative-zero
) t
))
1917 (eql high-bound
0f0
))
1918 (and (eql low-value
0f0
)
1920 (load-time-value (make-unportable-float
1921 :single-float-negative-zero
) t
)))
1923 (load-time-value (make-unportable-float
1924 :double-float-negative-zero
) t
))
1925 (eql high-bound
0d0
))
1926 (and (eql low-value
0d0
)
1928 (load-time-value (make-unportable-float
1929 :double-float-negative-zero
) t
))))))
1931 (let ((high-value (car high-bound
)))
1932 (or (eql high-value low-bound
)
1933 (and (eql high-value
1934 (load-time-value (make-unportable-float
1935 :single-float-negative-zero
) t
))
1936 (eql low-bound
0f0
))
1937 (and (eql high-value
0f0
)
1939 (load-time-value (make-unportable-float
1940 :single-float-negative-zero
) t
)))
1941 (and (eql high-value
1942 (load-time-value (make-unportable-float
1943 :double-float-negative-zero
) t
))
1944 (eql low-bound
0d0
))
1945 (and (eql high-value
0d0
)
1947 (load-time-value (make-unportable-float
1948 :double-float-negative-zero
) t
))))))
1949 ((and (eq (numeric-type-class low
) 'integer
)
1950 (eq (numeric-type-class high
) 'integer
))
1951 (eql (1+ low-bound
) high-bound
))
1955 ;;; Return a numeric type that is a supertype for both TYPE1 and TYPE2.
1957 ;;; Binding *APPROXIMATE-NUMERIC-UNIONS* to T allows merging non-adjacent
1958 ;;; numeric types, eg (OR (INTEGER 0 12) (INTEGER 20 128)) => (INTEGER 0 128),
1959 ;;; the compiler does this occasionally during type-derivation to avoid
1960 ;;; creating absurdly complex unions of numeric types.
1961 (defvar *approximate-numeric-unions
* nil
)
1963 (!define-type-method
(number :simple-union2
) (type1 type2
)
1964 (declare (type numeric-type type1 type2
))
1965 (cond ((csubtypep type1 type2
) type2
)
1966 ((csubtypep type2 type1
) type1
)
1968 (let ((class1 (numeric-type-class type1
))
1969 (format1 (numeric-type-format type1
))
1970 (complexp1 (numeric-type-complexp type1
))
1971 (class2 (numeric-type-class type2
))
1972 (format2 (numeric-type-format type2
))
1973 (complexp2 (numeric-type-complexp type2
)))
1975 ((and (eq class1 class2
)
1976 (eq format1 format2
)
1977 (eq complexp1 complexp2
)
1978 (or *approximate-numeric-unions
*
1979 (numeric-types-intersect type1 type2
)
1980 (numeric-types-adjacent type1 type2
)
1981 (numeric-types-adjacent type2 type1
)))
1986 :low
(numeric-bound-max (numeric-type-low type1
)
1987 (numeric-type-low type2
)
1989 :high
(numeric-bound-max (numeric-type-high type1
)
1990 (numeric-type-high type2
)
1992 ;; FIXME: These two clauses are almost identical, and the
1993 ;; consequents are in fact identical in every respect.
1994 ((and (eq class1
'rational
)
1995 (eq class2
'integer
)
1996 (eq format1 format2
)
1997 (eq complexp1 complexp2
)
1998 (integerp (numeric-type-low type2
))
1999 (integerp (numeric-type-high type2
))
2000 (= (numeric-type-low type2
) (numeric-type-high type2
))
2001 (or *approximate-numeric-unions
*
2002 (numeric-types-adjacent type1 type2
)
2003 (numeric-types-adjacent type2 type1
)))
2008 :low
(numeric-bound-max (numeric-type-low type1
)
2009 (numeric-type-low type2
)
2011 :high
(numeric-bound-max (numeric-type-high type1
)
2012 (numeric-type-high type2
)
2014 ((and (eq class1
'integer
)
2015 (eq class2
'rational
)
2016 (eq format1 format2
)
2017 (eq complexp1 complexp2
)
2018 (integerp (numeric-type-low type1
))
2019 (integerp (numeric-type-high type1
))
2020 (= (numeric-type-low type1
) (numeric-type-high type1
))
2021 (or *approximate-numeric-unions
*
2022 (numeric-types-adjacent type1 type2
)
2023 (numeric-types-adjacent type2 type1
)))
2028 :low
(numeric-bound-max (numeric-type-low type1
)
2029 (numeric-type-low type2
)
2031 :high
(numeric-bound-max (numeric-type-high type1
)
2032 (numeric-type-high type2
)
2037 (!cold-init-forms
;; is !PRECOMPUTE-TYPES not doing the right thing?
2038 (setf (info :type
:kind
'number
) :primitive
)
2039 (setf (info :type
:builtin
'number
)
2040 (make-numeric-type :complexp nil
)))
2042 (!def-type-translator complex
((:context context
) &optional
(typespec '*))
2043 (if (eq typespec
'*)
2044 (specifier-type '(complex real
))
2045 (labels ((not-numeric ()
2046 (error "The component type for COMPLEX is not numeric: ~S"
2049 (error "The component type for COMPLEX is not a subtype of REAL: ~S"
2051 (complex1 (component-type)
2052 (unless (numeric-type-p component-type
)
2054 (when (eq (numeric-type-complexp component-type
) :complex
)
2056 (if (csubtypep component-type
(specifier-type '(eql 0)))
2058 (modified-numeric-type component-type
2059 :complexp
:complex
)))
2062 ((eq ctype
*empty-type
*) *empty-type
*)
2063 ((eq ctype
*universal-type
*) (not-real))
2064 ((typep ctype
'numeric-type
) (complex1 ctype
))
2065 ((typep ctype
'union-type
)
2067 (mapcar #'do-complex
(union-type-types ctype
))))
2068 ((typep ctype
'member-type
)
2070 (mapcar-member-type-members
2071 (lambda (x) (do-complex (ctype-of x
)))
2073 ((and (typep ctype
'intersection-type
)
2074 ;; FIXME: This is very much a
2075 ;; not-quite-worst-effort, but we are required to do
2076 ;; something here because of our representation of
2077 ;; RATIO as (AND RATIONAL (NOT INTEGER)): we must
2078 ;; allow users to ask about (COMPLEX RATIO). This
2079 ;; will of course fail to work right on such types
2080 ;; as (AND INTEGER (SATISFIES ZEROP))...
2081 (let ((numbers (remove-if-not
2083 (intersection-type-types ctype
))))
2085 (null (cdr numbers
))
2086 (eq (numeric-type-complexp (car numbers
)) :real
)
2087 (complex1 (car numbers
))))))
2089 (multiple-value-bind (subtypep certainly
)
2090 (csubtypep ctype
(specifier-type 'real
))
2091 (if (and (not subtypep
) certainly
)
2093 ;; ANSI just says that TYPESPEC is any subtype of
2094 ;; type REAL, not necessarily a NUMERIC-TYPE. In
2095 ;; particular, at this point TYPESPEC could legally
2096 ;; be a hairy type like (AND NUMBER (SATISFIES
2097 ;; REALP) (SATISFIES ZEROP)), in which case we fall
2098 ;; through the logic above and end up here,
2100 ;; FIXME: (COMPLEX NUMBER) is not rejected but should
2101 ;; be, as NUMBER is clearly not a subtype of real.
2102 (bug "~@<(known bug #145): The type ~S is too hairy to be ~
2103 used for a COMPLEX component.~:@>"
2105 (let ((ctype (specifier-type-r context typespec
)))
2106 (do-complex ctype
)))))
2108 ;;; If X is *, return NIL, otherwise return the bound, which must be a
2109 ;;; member of TYPE or a one-element list of a member of TYPE.
2110 ;;; This is not necessarily the canonical bound. An integer bound
2111 ;;; should always be an atom, which we'll enforce later if needed.
2112 #!-sb-fluid
(declaim (inline valid-bound
))
2113 (defun valid-bound (bound type
)
2114 (cond ((eq bound
'*) nil
)
2115 ((sb!xc
:typep
(if (singleton-p bound
) (car bound
) bound
) type
) bound
)
2117 (error "Bound is not * or ~A ~S or list of one ~:*~S: ~S"
2118 (if (eq type
'integer
) "an" "a") type bound
))))
2120 (!def-type-translator integer
(&optional
(low '*) (high '*))
2121 (let ((lb (valid-bound low
'integer
))
2122 (hb (valid-bound high
'integer
)))
2123 (make-numeric-type :class
'integer
:complexp
:real
2124 :enumerable
(not (null (and lb hb
)))
2127 (defmacro !def-bounded-type
(type class format
)
2128 `(!def-type-translator
,type
(&optional
(low '*) (high '*))
2129 (let ((lb (valid-bound low
',type
))
2130 (hb (valid-bound high
',type
)))
2131 (make-numeric-type :class
',class
:format
',format
2132 :low lb
:high hb
))))
2134 (!def-bounded-type rational rational nil
)
2136 ;;; Unlike CMU CL, we represent the types FLOAT and REAL as
2137 ;;; UNION-TYPEs of more primitive types, in order to make
2138 ;;; type representation more unique, avoiding problems in the
2139 ;;; simplification of things like
2140 ;;; (subtypep '(or (single-float -1.0 1.0) (single-float 0.1))
2141 ;;; '(or (real -1 7) (single-float 0.1) (single-float -1.0 1.0)))
2142 ;;; When we allowed REAL to remain as a separate NUMERIC-TYPE,
2143 ;;; it was too easy for the first argument to be simplified to
2144 ;;; '(SINGLE-FLOAT -1.0), and for the second argument to be simplified
2145 ;;; to '(OR (REAL -1 7) (SINGLE-FLOAT 0.1)) and then for the
2146 ;;; SUBTYPEP to fail (returning NIL,T instead of T,T) because
2147 ;;; the first argument can't be seen to be a subtype of any of the
2148 ;;; terms in the second argument.
2150 ;;; The old CMU CL way was:
2151 ;;; (!def-bounded-type float float nil)
2152 ;;; (!def-bounded-type real nil nil)
2154 ;;; FIXME: If this new way works for a while with no weird new
2155 ;;; problems, we can go back and rip out support for separate FLOAT
2156 ;;; and REAL flavors of NUMERIC-TYPE. The new way was added in
2157 ;;; sbcl-0.6.11.22, 2001-03-21.
2159 ;;; FIXME: It's probably necessary to do something to fix the
2160 ;;; analogous problem with INTEGER and RATIONAL types. Perhaps
2161 ;;; bounded RATIONAL types should be represented as (OR RATIO INTEGER).
2162 (defun coerce-bound (bound type upperp inner-coerce-bound-fun
)
2163 (declare (type function inner-coerce-bound-fun
))
2166 (funcall inner-coerce-bound-fun bound type upperp
)))
2168 (macrolet ((fp-const (name)
2169 `(load-time-value (locally (declare (notinline symbol-value
))
2170 (symbol-value ',name
)) t
)))
2171 (defun inner-coerce-real-bound (bound type upperp
)
2172 #+sb-xc-host
(declare (ignore upperp
))
2173 (let #+sb-xc-host
()
2174 #-sb-xc-host
((nl (fp-const sb
!xc
:most-negative-long-float
))
2175 (pl (fp-const sb
!xc
:most-positive-long-float
)))
2176 (let ((nbound (if (consp bound
) (car bound
) bound
))
2177 (consp (consp bound
)))
2181 (list (rational nbound
))
2185 ((floatp nbound
) bound
)
2187 ;; Coerce to the widest float format available, to avoid
2188 ;; unnecessary loss of precision, but don't coerce
2189 ;; unrepresentable numbers, except on the host where we
2190 ;; shouldn't be making these types (but KLUDGE: can't even
2191 ;; assert portably that we're not).
2195 (when (< nbound nl
) (return-from inner-coerce-real-bound nl
)))
2197 (when (> nbound pl
) (return-from inner-coerce-real-bound pl
))))
2198 (let ((result (coerce nbound
'long-float
)))
2199 (if consp
(list result
) result
)))))))))
2200 (defun inner-coerce-float-bound (bound type upperp
)
2201 #+sb-xc-host
(declare (ignore upperp
))
2202 (let #+sb-xc-host
()
2203 #-sb-xc-host
((nd (fp-const sb
!xc
:most-negative-double-float
))
2204 (pd (fp-const sb
!xc
:most-positive-double-float
))
2205 (ns (fp-const sb
!xc
:most-negative-single-float
))
2206 (ps (fp-const sb
!xc
:most-positive-single-float
)))
2207 (let ((nbound (if (consp bound
) (car bound
) bound
))
2208 (consp (consp bound
)))
2212 ((typep nbound
'single-float
) bound
)
2217 (when (< nbound ns
) (return-from inner-coerce-float-bound ns
)))
2219 (when (> nbound ps
) (return-from inner-coerce-float-bound ps
))))
2220 (let ((result (coerce nbound
'single-float
)))
2221 (if consp
(list result
) result
)))))
2224 ((typep nbound
'double-float
) bound
)
2229 (when (< nbound nd
) (return-from inner-coerce-float-bound nd
)))
2231 (when (> nbound pd
) (return-from inner-coerce-float-bound pd
))))
2232 (let ((result (coerce nbound
'double-float
)))
2233 (if consp
(list result
) result
)))))))))
2235 (defun coerced-real-bound (bound type upperp
)
2236 (coerce-bound bound type upperp
#'inner-coerce-real-bound
))
2237 (defun coerced-float-bound (bound type upperp
)
2238 (coerce-bound bound type upperp
#'inner-coerce-float-bound
))
2239 (!def-type-translator real
(&optional
(low '*) (high '*))
2240 (specifier-type `(or (float ,(coerced-real-bound low
'float nil
)
2241 ,(coerced-real-bound high
'float t
))
2242 (rational ,(coerced-real-bound low
'rational nil
)
2243 ,(coerced-real-bound high
'rational t
)))))
2244 (!def-type-translator float
(&optional
(low '*) (high '*))
2246 `(or (single-float ,(coerced-float-bound low
'single-float nil
)
2247 ,(coerced-float-bound high
'single-float t
))
2248 (double-float ,(coerced-float-bound low
'double-float nil
)
2249 ,(coerced-float-bound high
'double-float t
))
2250 #!+long-float
,(error "stub: no long float support yet"))))
2252 (macrolet ((define-float-format (f) `(!def-bounded-type
,f float
,f
)))
2253 (define-float-format single-float
)
2254 (define-float-format double-float
))
2256 (defun numeric-types-intersect (type1 type2
)
2257 (declare (type numeric-type type1 type2
))
2258 (let* ((class1 (numeric-type-class type1
))
2259 (class2 (numeric-type-class type2
))
2260 (complexp1 (numeric-type-complexp type1
))
2261 (complexp2 (numeric-type-complexp type2
))
2262 (format1 (numeric-type-format type1
))
2263 (format2 (numeric-type-format type2
))
2264 (low1 (numeric-type-low type1
))
2265 (high1 (numeric-type-high type1
))
2266 (low2 (numeric-type-low type2
))
2267 (high2 (numeric-type-high type2
)))
2268 ;; If one is complex and the other isn't, then they are disjoint.
2269 (cond ((not (or (eq complexp1 complexp2
)
2270 (null complexp1
) (null complexp2
)))
2272 ;; If either type is a float, then the other must either be
2273 ;; specified to be a float or unspecified. Otherwise, they
2275 ((and (eq class1
'float
)
2276 (not (member class2
'(float nil
)))) nil
)
2277 ((and (eq class2
'float
)
2278 (not (member class1
'(float nil
)))) nil
)
2279 ;; If the float formats are specified and different, the
2280 ;; types are disjoint.
2281 ((not (or (eq format1 format2
) (null format1
) (null format2
)))
2284 ;; Check the bounds. This is a bit odd because we must
2285 ;; always have the outer bound of the interval as the
2287 (if (numeric-bound-test high1 high2
<= <)
2288 (or (and (numeric-bound-test low1 low2
>= >)
2289 (numeric-bound-test* low1 high2
<= <))
2290 (and (numeric-bound-test low2 low1
>= >)
2291 (numeric-bound-test* low2 high1
<= <)))
2292 (or (and (numeric-bound-test* low2 high1
<= <)
2293 (numeric-bound-test low2 low1
>= >))
2294 (and (numeric-bound-test high2 high1
<= <)
2295 (numeric-bound-test* high2 low1
>= >))))))))
2297 ;;; Take the numeric bound X and convert it into something that can be
2298 ;;; used as a bound in a numeric type with the specified CLASS and
2299 ;;; FORMAT. If UP-P is true, then we round up as needed, otherwise we
2300 ;;; round down. UP-P true implies that X is a lower bound, i.e. (N) > N.
2302 ;;; This is used by NUMERIC-TYPE-INTERSECTION to mash the bound into
2303 ;;; the appropriate type number. X may only be a float when CLASS is
2306 ;;; ### Note: it is possible for the coercion to a float to overflow
2307 ;;; or underflow. This happens when the bound doesn't fit in the
2308 ;;; specified format. In this case, we should really return the
2309 ;;; appropriate {Most | Least}-{Positive | Negative}-XXX-Float float
2310 ;;; of desired format. But these conditions aren't currently signalled
2311 ;;; in any useful way.
2313 ;;; Also, when converting an open rational bound into a float we
2314 ;;; should probably convert it to a closed bound of the closest float
2315 ;;; in the specified format. KLUDGE: In general, open float bounds are
2316 ;;; screwed up. -- (comment from original CMU CL)
2317 (defun round-numeric-bound (x class format up-p
)
2319 (let ((cx (if (consp x
) (car x
) x
)))
2323 (if (and (consp x
) (integerp cx
))
2324 (if up-p
(1+ cx
) (1- cx
))
2325 (if up-p
(ceiling cx
) (floor cx
))))
2329 ((and format
(subtypep format
'double-float
))
2330 (if (<= most-negative-double-float cx most-positive-double-float
)
2334 (if (<= most-negative-single-float cx most-positive-single-float
)
2336 (coerce cx
(or format
'single-float
))
2338 (if (consp x
) (list res
) res
)))))
2341 ;;; Handle the case of type intersection on two numeric types. We use
2342 ;;; TYPES-EQUAL-OR-INTERSECT to throw out the case of types with no
2343 ;;; intersection. If an attribute in TYPE1 is unspecified, then we use
2344 ;;; TYPE2's attribute, which must be at least as restrictive. If the
2345 ;;; types intersect, then the only attributes that can be specified
2346 ;;; and different are the class and the bounds.
2348 ;;; When the class differs, we use the more restrictive class. The
2349 ;;; only interesting case is RATIONAL/INTEGER, since RATIONAL includes
2352 ;;; We make the result lower (upper) bound the maximum (minimum) of
2353 ;;; the argument lower (upper) bounds. We convert the bounds into the
2354 ;;; appropriate numeric type before maximizing. This avoids possible
2355 ;;; confusion due to mixed-type comparisons (but I think the result is
2357 (!define-type-method
(number :simple-intersection2
) (type1 type2
)
2358 (declare (type numeric-type type1 type2
))
2359 (if (numeric-types-intersect type1 type2
)
2360 (let* ((class1 (numeric-type-class type1
))
2361 (class2 (numeric-type-class type2
))
2362 (class (ecase class1
2364 ((integer float
) class1
)
2365 (rational (if (eq class2
'integer
)
2368 (format (or (numeric-type-format type1
)
2369 (numeric-type-format type2
))))
2373 :complexp
(or (numeric-type-complexp type1
)
2374 (numeric-type-complexp type2
))
2375 :low
(numeric-bound-max
2376 (round-numeric-bound (numeric-type-low type1
)
2378 (round-numeric-bound (numeric-type-low type2
)
2381 :high
(numeric-bound-max
2382 (round-numeric-bound (numeric-type-high type1
)
2384 (round-numeric-bound (numeric-type-high type2
)
2389 ;;; Given two float formats, return the one with more precision. If
2390 ;;; either one is null, return NIL.
2391 (defun float-format-max (f1 f2
)
2393 (dolist (f *float-formats
* (error "bad float format: ~S" f1
))
2394 (when (or (eq f f1
) (eq f f2
))
2397 ;;; Return the result of an operation on TYPE1 and TYPE2 according to
2398 ;;; the rules of numeric contagion. This is always NUMBER, some float
2399 ;;; format (possibly complex) or RATIONAL. Due to rational
2400 ;;; canonicalization, there isn't much we can do here with integers or
2401 ;;; rational complex numbers.
2403 ;;; If either argument is not a NUMERIC-TYPE, then return NUMBER. This
2404 ;;; is useful mainly for allowing types that are technically numbers,
2405 ;;; but not a NUMERIC-TYPE.
2406 (defun numeric-contagion (type1 type2
)
2407 (if (and (numeric-type-p type1
) (numeric-type-p type2
))
2408 (let ((class1 (numeric-type-class type1
))
2409 (class2 (numeric-type-class type2
))
2410 (format1 (numeric-type-format type1
))
2411 (format2 (numeric-type-format type2
))
2412 (complexp1 (numeric-type-complexp type1
))
2413 (complexp2 (numeric-type-complexp type2
)))
2414 (cond ((or (null complexp1
)
2416 (specifier-type 'number
))
2420 :format
(ecase class2
2421 (float (float-format-max format1 format2
))
2422 ((integer rational
) format1
)
2424 ;; A double-float with any real number is a
2427 (if (eq format1
'double-float
)
2430 ;; A long-float with any real number is a
2433 (if (eq format1
'long-float
)
2436 :complexp
(if (or (eq complexp1
:complex
)
2437 (eq complexp2
:complex
))
2440 ((eq class2
'float
) (numeric-contagion type2 type1
))
2441 ((and (eq complexp1
:real
) (eq complexp2
:real
))
2443 :class
(and class1 class2
'rational
)
2446 (specifier-type 'number
))))
2447 (specifier-type 'number
)))
2451 (!define-type-method
(array :simple-
=) (type1 type2
)
2452 (cond ((not (and (equal (array-type-dimensions type1
)
2453 (array-type-dimensions type2
))
2454 (eq (array-type-complexp type1
)
2455 (array-type-complexp type2
))))
2457 ((or (unknown-type-p (array-type-element-type type1
))
2458 (unknown-type-p (array-type-element-type type2
)))
2459 (type= (array-type-element-type type1
)
2460 (array-type-element-type type2
)))
2462 (values (type= (array-type-specialized-element-type type1
)
2463 (array-type-specialized-element-type type2
))
2466 (!define-type-method
(array :negate
) (type)
2467 ;; FIXME (and hint to PFD): we're vulnerable here to attacks of the
2468 ;; form "are (AND ARRAY (NOT (ARRAY T))) and (OR (ARRAY BIT) (ARRAY
2469 ;; NIL) (ARRAY CHAR) ...) equivalent?" -- CSR, 2003-12-10
2470 ;; A symptom of the aforementioned is that the following are not TYPE=
2471 ;; (AND (VECTOR T) (NOT SIMPLE-ARRAY)) ; an ARRAY-TYPE
2472 ;; (AND (VECTOR T) (NOT SIMPLE-VECTOR)) ; an INTERSECTION-TYPE
2473 ;; even though (VECTOR T) makes it so that the (NOT) clause in each can
2474 ;; only provide one additional bit of information: that the vector
2475 ;; is complex as opposed to simple. The rank and element-type are fixed.
2476 (if (and (eq (array-type-dimensions type
) '*)
2477 (eq (array-type-complexp type
) 't
)
2478 (eq (array-type-element-type type
) *wild-type
*))
2479 ;; (NOT <hairy-array>) = either SIMPLE-ARRAY or (NOT ARRAY).
2480 ;; This is deliberately asymmetric - trying to say that NOT simple-array
2481 ;; equals hairy-array leads to infinite recursion.
2482 (type-union (make-array-type '* :complexp nil
2483 :element-type
*wild-type
*)
2485 (make-array-type '* :element-type
*wild-type
*)))
2486 (make-negation-type type
)))
2488 (!define-type-method
(array :unparse
) (type)
2489 (let* ((dims (array-type-dimensions type
))
2490 ;; Compare the specialised element type and the
2491 ;; derived element type. If the derived type
2492 ;; is so small that it jumps to a smaller upgraded
2493 ;; element type, use the specialised element type.
2495 ;; This protects from unparsing
2496 ;; (and (vector (or bit symbol))
2497 ;; (vector (or bit character)))
2498 ;; i.e., the intersection of two T array types,
2500 (stype (array-type-specialized-element-type type
))
2501 (dtype (array-type-element-type type
))
2502 (utype (%upgraded-array-element-type dtype
))
2503 (eltype (type-specifier (if (type= stype utype
)
2506 (complexp (array-type-complexp type
)))
2507 (if (and (eq complexp t
) (not *unparse-allow-negation
*))
2508 (setq complexp
:maybe
))
2512 ((t) '(and array
(not simple-array
)))
2514 ((nil) 'simple-array
))
2516 ((t) `(and (array ,eltype
) (not simple-array
)))
2517 ((:maybe
) `(array ,eltype
))
2518 ((nil) `(simple-array ,eltype
)))))
2519 ((= (length dims
) 1)
2522 (if (eq (car dims
) '*)
2525 ((base-char #!-sb-unicode character
) 'base-string
)
2527 (t `(vector ,eltype
)))
2529 (bit `(bit-vector ,(car dims
)))
2530 ((base-char #!-sb-unicode character
)
2531 `(base-string ,(car dims
)))
2532 (t `(vector ,eltype
,(car dims
)))))))
2533 (if (eql complexp
:maybe
)
2535 `(and ,answer
(not simple-array
))))
2536 (if (eq (car dims
) '*)
2538 (bit 'simple-bit-vector
)
2539 ((base-char #!-sb-unicode character
) 'simple-base-string
)
2540 ((t) 'simple-vector
)
2541 (t `(simple-array ,eltype
(*))))
2543 (bit `(simple-bit-vector ,(car dims
)))
2544 ((base-char #!-sb-unicode character
)
2545 `(simple-base-string ,(car dims
)))
2546 ((t) `(simple-vector ,(car dims
)))
2547 (t `(simple-array ,eltype
,dims
))))))
2550 ((t) `(and (array ,eltype
,dims
) (not simple-array
)))
2551 ((:maybe
) `(array ,eltype
,dims
))
2552 ((nil) `(simple-array ,eltype
,dims
)))))))
2554 (!define-type-method
(array :simple-subtypep
) (type1 type2
)
2555 (let ((dims1 (array-type-dimensions type1
))
2556 (dims2 (array-type-dimensions type2
))
2557 (complexp2 (array-type-complexp type2
)))
2558 (cond (;; not subtypep unless dimensions are compatible
2559 (not (or (eq dims2
'*)
2560 (and (not (eq dims1
'*))
2561 ;; (sbcl-0.6.4 has trouble figuring out that
2562 ;; DIMS1 and DIMS2 must be lists at this
2563 ;; point, and knowing that is important to
2564 ;; compiling EVERY efficiently.)
2565 (= (length (the list dims1
))
2566 (length (the list dims2
)))
2567 (every (lambda (x y
)
2568 (or (eq y
'*) (eql x y
)))
2570 (the list dims2
)))))
2572 ;; not subtypep unless complexness is compatible
2573 ((not (or (eq complexp2
:maybe
)
2574 (eq (array-type-complexp type1
) complexp2
)))
2576 ;; Since we didn't fail any of the tests above, we win
2577 ;; if the TYPE2 element type is wild.
2578 ((eq (array-type-element-type type2
) *wild-type
*)
2580 (;; Since we didn't match any of the special cases above, if
2581 ;; either element type is unknown we can only give a good
2582 ;; answer if they are the same.
2583 (or (unknown-type-p (array-type-element-type type1
))
2584 (unknown-type-p (array-type-element-type type2
)))
2585 (if (type= (array-type-element-type type1
)
2586 (array-type-element-type type2
))
2589 (;; Otherwise, the subtype relationship holds iff the
2590 ;; types are equal, and they're equal iff the specialized
2591 ;; element types are identical.
2593 (values (type= (array-type-specialized-element-type type1
)
2594 (array-type-specialized-element-type type2
))
2597 (!define-superclasses array
((vector vector
) (array)) !cold-init-forms
)
2599 (defun array-types-intersect (type1 type2
)
2600 (declare (type array-type type1 type2
))
2601 (let ((dims1 (array-type-dimensions type1
))
2602 (dims2 (array-type-dimensions type2
))
2603 (complexp1 (array-type-complexp type1
))
2604 (complexp2 (array-type-complexp type2
)))
2605 ;; See whether dimensions are compatible.
2606 (cond ((not (or (eq dims1
'*) (eq dims2
'*)
2607 (and (= (length dims1
) (length dims2
))
2608 (every (lambda (x y
)
2609 (or (eq x
'*) (eq y
'*) (= x y
)))
2612 ;; See whether complexpness is compatible.
2613 ((not (or (eq complexp1
:maybe
)
2614 (eq complexp2
:maybe
)
2615 (eq complexp1 complexp2
)))
2619 ;; If either element type is wild, then they intersect.
2620 ;; Otherwise, the types must be identical.
2622 ;; FIXME: There seems to have been a fair amount of
2623 ;; confusion about the distinction between requested element
2624 ;; type and specialized element type; here is one of
2625 ;; them. If we request an array to hold objects of an
2626 ;; unknown type, we can do no better than represent that
2627 ;; type as an array specialized on wild-type. We keep the
2628 ;; requested element-type in the -ELEMENT-TYPE slot, and
2629 ;; *WILD-TYPE* in the -SPECIALIZED-ELEMENT-TYPE. So, here,
2630 ;; we must test for the SPECIALIZED slot being *WILD-TYPE*,
2631 ;; not just the ELEMENT-TYPE slot. Maybe the return value
2632 ;; in that specific case should be T, NIL? Or maybe this
2633 ;; function should really be called
2634 ;; ARRAY-TYPES-COULD-POSSIBLY-INTERSECT? In any case, this
2635 ;; was responsible for bug #123, and this whole issue could
2636 ;; do with a rethink and/or a rewrite. -- CSR, 2002-08-21
2637 ((or (eq (array-type-specialized-element-type type1
) *wild-type
*)
2638 (eq (array-type-specialized-element-type type2
) *wild-type
*)
2639 (type= (array-type-specialized-element-type type1
)
2640 (array-type-specialized-element-type type2
)))
2646 (defun unite-array-types-complexp (type1 type2
)
2647 (let ((complexp1 (array-type-complexp type1
))
2648 (complexp2 (array-type-complexp type2
)))
2650 ((eq complexp1 complexp2
)
2651 ;; both types are the same complexp-ity
2652 (values complexp1 t
))
2653 ((eq complexp1
:maybe
)
2654 ;; type1 is wild-complexp
2655 (values :maybe type1
))
2656 ((eq complexp2
:maybe
)
2657 ;; type2 is wild-complexp
2658 (values :maybe type2
))
2660 ;; both types partition the complexp-space
2661 (values :maybe nil
)))))
2663 (defun unite-array-types-dimensions (type1 type2
)
2664 (let ((dims1 (array-type-dimensions type1
))
2665 (dims2 (array-type-dimensions type2
)))
2666 (cond ((equal dims1 dims2
)
2667 ;; both types are same dimensionality
2670 ;; type1 is wild-dimensions
2673 ;; type2 is wild-dimensions
2675 ((not (= (length dims1
) (length dims2
)))
2676 ;; types have different number of dimensions
2677 (values :incompatible nil
))
2679 ;; we need to check on a per-dimension basis
2680 (let* ((supertype1 t
)
2683 (result (mapcar (lambda (dim1 dim2
)
2688 (setf supertype2 nil
)
2691 (setf supertype1 nil
)
2694 (setf compatible nil
))))
2697 ((or (not compatible
)
2698 (and (not supertype1
)
2700 (values :incompatible nil
))
2701 ((and supertype1 supertype2
)
2702 (values result supertype1
))
2704 (values result
(if supertype1 type1 type2
)))))))))
2706 (defun unite-array-types-element-types (type1 type2
)
2707 ;; FIXME: We'd love to be able to unite the full set of specialized
2708 ;; array element types up to *wild-type*, but :simple-union2 is
2709 ;; performed pairwise, so we don't have a good hook for it and our
2710 ;; representation doesn't allow us to easily detect the situation
2712 ;; But see SIMPLIFY-ARRAY-UNIONS which is able to do something like that.
2713 (let* ((eltype1 (array-type-element-type type1
))
2714 (eltype2 (array-type-element-type type2
))
2715 (stype1 (array-type-specialized-element-type type1
))
2716 (stype2 (array-type-specialized-element-type type2
))
2717 (wild1 (eq eltype1
*wild-type
*))
2718 (wild2 (eq eltype2
*wild-type
*)))
2720 ((type= eltype1 eltype2
)
2721 (values eltype1 stype1 t
))
2723 (values eltype1 stype1 type1
))
2725 (values eltype2 stype2 type2
))
2726 ((not (type= stype1 stype2
))
2727 ;; non-wild types that don't share UAET don't unite
2728 (values :incompatible nil nil
))
2729 ((csubtypep eltype1 eltype2
)
2730 (values eltype2 stype2 type2
))
2731 ((csubtypep eltype2 eltype1
)
2732 (values eltype1 stype1 type1
))
2734 (values :incompatible nil nil
)))))
2736 (defun unite-array-types-supertypes-compatible-p (&rest supertypes
)
2737 ;; supertypes are compatible if they are all T, if there is a single
2738 ;; NIL and all the rest are T, or if all non-T supertypes are the
2739 ;; same and not NIL.
2740 (let ((interesting-supertypes
2741 (remove t supertypes
)))
2742 (or (not interesting-supertypes
)
2743 (equal interesting-supertypes
'(nil))
2744 ;; supertypes are (OR BOOLEAN ARRAY-TYPE), so...
2745 (typep (remove-duplicates interesting-supertypes
)
2746 '(cons array-type null
)))))
2748 (!define-type-method
(array :simple-union2
) (type1 type2
)
2749 (multiple-value-bind
2750 (result-eltype result-stype eltype-supertype
)
2751 (unite-array-types-element-types type1 type2
)
2752 (multiple-value-bind
2753 (result-complexp complexp-supertype
)
2754 (unite-array-types-complexp type1 type2
)
2755 (multiple-value-bind
2756 (result-dimensions dimensions-supertype
)
2757 (unite-array-types-dimensions type1 type2
)
2758 (when (and (not (eq result-dimensions
:incompatible
))
2759 (not (eq result-eltype
:incompatible
))
2760 (unite-array-types-supertypes-compatible-p
2761 eltype-supertype complexp-supertype dimensions-supertype
))
2762 (make-array-type result-dimensions
2763 :complexp result-complexp
2764 :element-type result-eltype
2765 :specialized-element-type result-stype
))))))
2767 (!define-type-method
(array :simple-intersection2
) (type1 type2
)
2768 (declare (type array-type type1 type2
))
2769 (if (array-types-intersect type1 type2
)
2770 (let ((dims1 (array-type-dimensions type1
))
2771 (dims2 (array-type-dimensions type2
))
2772 (complexp1 (array-type-complexp type1
))
2773 (complexp2 (array-type-complexp type2
))
2774 (eltype1 (array-type-element-type type1
))
2775 (eltype2 (array-type-element-type type2
))
2776 (stype1 (array-type-specialized-element-type type1
))
2777 (stype2 (array-type-specialized-element-type type2
)))
2778 (make-array-type (cond ((eq dims1
'*) dims2
)
2779 ((eq dims2
'*) dims1
)
2781 (mapcar (lambda (x y
) (if (eq x
'*) y x
))
2783 :complexp
(if (eq complexp1
:maybe
) complexp2 complexp1
)
2785 ((eq eltype1
*wild-type
*) eltype2
)
2786 ((eq eltype2
*wild-type
*) eltype1
)
2787 (t (type-intersection eltype1 eltype2
)))
2788 :specialized-element-type
(cond
2789 ((eq stype1
*wild-type
*) stype2
)
2790 ((eq stype2
*wild-type
*) stype1
)
2792 (aver (type= stype1 stype2
))
2796 ;;; Check a supplied dimension list to determine whether it is legal,
2797 ;;; and return it in canonical form (as either '* or a list).
2798 (defun canonical-array-dimensions (dims)
2803 (error "Arrays can't have a negative number of dimensions: ~S" dims
))
2804 (when (>= dims sb
!xc
:array-rank-limit
)
2805 (error "array type with too many dimensions: ~S" dims
))
2806 (make-list dims
:initial-element
'*))
2808 (when (>= (length dims
) sb
!xc
:array-rank-limit
)
2809 (error "array type with too many dimensions: ~S" dims
))
2812 (unless (and (integerp dim
)
2814 (< dim sb
!xc
:array-dimension-limit
))
2815 (error "bad dimension in array type: ~S" dim
))))
2818 (error "Array dimensions is not a list, integer or *:~% ~S" dims
))))
2822 (!define-type-method
(member :negate
) (type)
2823 (let ((xset (member-type-xset type
))
2824 (fp-zeroes (member-type-fp-zeroes type
)))
2826 ;; Hairy case, which needs to do a bit of float type
2827 ;; canonicalization.
2828 (apply #'type-intersection
2829 (if (xset-empty-p xset
)
2831 (make-negation-type (make-member-type xset nil
)))
2834 (let* ((opposite (neg-fp-zero x
))
2835 (type (ctype-of opposite
)))
2838 (modified-numeric-type type
:low nil
:high nil
))
2839 (modified-numeric-type type
:low nil
:high
(list opposite
))
2840 (make-eql-type opposite
)
2841 (modified-numeric-type type
:low
(list opposite
) :high nil
))))
2844 (make-negation-type type
))))
2846 (!define-type-method
(member :unparse
) (type)
2847 (cond ((eq type
(specifier-type 'null
)) 'null
) ; NULL type is EQ-comparable
2848 ((eq type
(specifier-type 'boolean
)) 'boolean
) ; so is BOOLEAN
2849 (t `(member ,@(member-type-members type
)))))
2851 (!define-type-method
(member :singleton-p
) (type)
2852 (if (eql 1 (member-type-size type
))
2853 (values t
(first (member-type-members type
)))
2856 (!define-type-method
(member :simple-subtypep
) (type1 type2
)
2857 (values (and (xset-subset-p (member-type-xset type1
)
2858 (member-type-xset type2
))
2859 (subsetp (member-type-fp-zeroes type1
)
2860 (member-type-fp-zeroes type2
)))
2863 (!define-type-method
(member :complex-subtypep-arg1
) (type1 type2
)
2865 (mapc-member-type-members
2867 (multiple-value-bind (ok surep
) (ctypep elt type2
)
2869 (return-from punt
(values nil nil
)))
2871 (return-from punt
(values nil t
)))))
2875 ;;; We punt if the odd type is enumerable and intersects with the
2876 ;;; MEMBER type. If not enumerable, then it is definitely not a
2877 ;;; subtype of the MEMBER type.
2878 (!define-type-method
(member :complex-subtypep-arg2
) (type1 type2
)
2879 (cond ((not (type-enumerable type1
)) (values nil t
))
2880 ((types-equal-or-intersect type1 type2
)
2881 (invoke-complex-subtypep-arg1-method type1 type2
))
2882 (t (values nil t
))))
2884 (!define-type-method
(member :simple-intersection2
) (type1 type2
)
2885 (make-member-type (xset-intersection (member-type-xset type1
)
2886 (member-type-xset type2
))
2887 (intersection (member-type-fp-zeroes type1
)
2888 (member-type-fp-zeroes type2
))))
2890 (!define-type-method
(member :complex-intersection2
) (type1 type2
)
2892 (let ((xset (alloc-xset))
2894 (mapc-member-type-members
2896 (multiple-value-bind (ok sure
) (ctypep member type1
)
2898 (return-from punt nil
))
2900 (if (fp-zero-p member
)
2901 (pushnew member fp-zeroes
)
2902 (add-to-xset member xset
)))))
2904 (if (and (xset-empty-p xset
) (not fp-zeroes
))
2906 (make-member-type xset fp-zeroes
)))))
2908 ;;; We don't need a :COMPLEX-UNION2, since the only interesting case is
2909 ;;; a union type, and the member/union interaction is handled by the
2910 ;;; union type method.
2911 (!define-type-method
(member :simple-union2
) (type1 type2
)
2912 (make-member-type (xset-union (member-type-xset type1
)
2913 (member-type-xset type2
))
2914 (union (member-type-fp-zeroes type1
)
2915 (member-type-fp-zeroes type2
))))
2917 (!define-type-method
(member :simple-
=) (type1 type2
)
2918 (let ((xset1 (member-type-xset type1
))
2919 (xset2 (member-type-xset type2
))
2920 (l1 (member-type-fp-zeroes type1
))
2921 (l2 (member-type-fp-zeroes type2
)))
2922 (values (and (eql (xset-count xset1
) (xset-count xset2
))
2923 (xset-subset-p xset1 xset2
)
2924 (xset-subset-p xset2 xset1
)
2929 (!define-type-method
(member :complex-
=) (type1 type2
)
2930 (if (type-enumerable type1
)
2931 (multiple-value-bind (val win
) (csubtypep type2 type1
)
2932 (if (or val
(not win
))
2937 (!def-type-translator member
:list
(&rest members
)
2939 (let (ms numbers char-codes
)
2940 (dolist (m (remove-duplicates members
))
2942 (character (push (sb!xc
:char-code m
) char-codes
))
2943 (real (if (and (floatp m
) (zerop m
))
2945 (push (ctype-of m
) numbers
)))
2948 (member-type-from-list ms
)
2949 (make-character-set-type (mapcar (lambda (x) (cons x x
))
2950 (sort char-codes
#'<)))
2951 (nreverse numbers
)))
2954 ;;;; intersection types
2956 ;;;; Until version 0.6.10.6, SBCL followed the original CMU CL approach
2957 ;;;; of punting on all AND types, not just the unreasonably complicated
2958 ;;;; ones. The change was motivated by trying to get the KEYWORD type
2959 ;;;; to behave sensibly:
2960 ;;;; ;; reasonable definition
2961 ;;;; (DEFTYPE KEYWORD () '(AND SYMBOL (SATISFIES KEYWORDP)))
2962 ;;;; ;; reasonable behavior
2963 ;;;; (AVER (SUBTYPEP 'KEYWORD 'SYMBOL))
2964 ;;;; Without understanding a little about the semantics of AND, we'd
2965 ;;;; get (SUBTYPEP 'KEYWORD 'SYMBOL)=>NIL,NIL and, for entirely
2966 ;;;; parallel reasons, (SUBTYPEP 'RATIO 'NUMBER)=>NIL,NIL. That's
2969 ;;;; We still follow the example of CMU CL to some extent, by punting
2970 ;;;; (to the opaque HAIRY-TYPE) on sufficiently complicated types
2973 (!define-type-class intersection
2974 :enumerable
#'compound-type-enumerable
2975 :might-contain-other-types t
)
2977 (!define-type-method
(intersection :negate
) (type)
2979 (mapcar #'type-negation
(intersection-type-types type
))))
2981 ;;; A few intersection types have special names. The others just get
2982 ;;; mechanically unparsed.
2983 (!define-type-method
(intersection :unparse
) (type)
2984 (declare (type ctype type
))
2985 (or (find type
'(ratio keyword compiled-function
) :key
#'specifier-type
:test
#'type
=)
2986 `(and ,@(mapcar #'type-specifier
(intersection-type-types type
)))))
2988 ;;; shared machinery for type equality: true if every type in the set
2989 ;;; TYPES1 matches a type in the set TYPES2 and vice versa
2990 (defun type=-set
(types1 types2
)
2991 (flet ((type<=-set
(x y
)
2992 (declare (type list x y
))
2993 (every/type
(lambda (x y-element
)
2994 (any/type
#'type
= y-element x
))
2996 (and/type
(type<=-set types1 types2
)
2997 (type<=-set types2 types1
))))
2999 ;;; Two intersection types are equal if their subtypes are equal sets.
3001 ;;; FIXME: Might it be better to use
3002 ;;; (AND (SUBTYPEP X Y) (SUBTYPEP Y X))
3003 ;;; instead, since SUBTYPEP is the usual relationship that we care
3004 ;;; most about, so it would be good to leverage any ingenuity there
3005 ;;; in this more obscure method?
3006 (!define-type-method
(intersection :simple-
=) (type1 type2
)
3007 (type=-set
(intersection-type-types type1
)
3008 (intersection-type-types type2
)))
3010 (defun %intersection-complex-subtypep-arg1
(type1 type2
)
3011 (type= type1
(type-intersection type1 type2
)))
3013 (defun %intersection-simple-subtypep
(type1 type2
)
3014 (every/type
#'%intersection-complex-subtypep-arg1
3016 (intersection-type-types type2
)))
3018 (!define-type-method
(intersection :simple-subtypep
) (type1 type2
)
3019 (%intersection-simple-subtypep type1 type2
))
3021 (!define-type-method
(intersection :complex-subtypep-arg1
) (type1 type2
)
3022 (%intersection-complex-subtypep-arg1 type1 type2
))
3024 (defun %intersection-complex-subtypep-arg2
(type1 type2
)
3025 (every/type
#'csubtypep type1
(intersection-type-types type2
)))
3027 (!define-type-method
(intersection :complex-subtypep-arg2
) (type1 type2
)
3028 (%intersection-complex-subtypep-arg2 type1 type2
))
3030 ;;; FIXME: This will look eeriely familiar to readers of the UNION
3031 ;;; :SIMPLE-INTERSECTION2 :COMPLEX-INTERSECTION2 method. That's
3032 ;;; because it was generated by cut'n'paste methods. Given that
3033 ;;; intersections and unions have all sorts of symmetries known to
3034 ;;; mathematics, it shouldn't be beyond the ken of some programmers to
3035 ;;; reflect those symmetries in code in a way that ties them together
3036 ;;; more strongly than having two independent near-copies :-/
3037 (!define-type-method
(intersection :simple-union2
:complex-union2
)
3039 ;; Within this method, type2 is guaranteed to be an intersection
3041 (aver (intersection-type-p type2
))
3042 ;; Make sure to call only the applicable methods...
3043 (cond ((and (intersection-type-p type1
)
3044 (%intersection-simple-subtypep type1 type2
)) type2
)
3045 ((and (intersection-type-p type1
)
3046 (%intersection-simple-subtypep type2 type1
)) type1
)
3047 ((and (not (intersection-type-p type1
))
3048 (%intersection-complex-subtypep-arg2 type1 type2
))
3050 ((and (not (intersection-type-p type1
))
3051 (%intersection-complex-subtypep-arg1 type2 type1
))
3053 ;; KLUDGE: This special (and somewhat hairy) magic is required
3054 ;; to deal with the RATIONAL/INTEGER special case. The UNION
3055 ;; of (INTEGER * -1) and (AND (RATIONAL * -1/2) (NOT INTEGER))
3056 ;; should be (RATIONAL * -1/2) -- CSR, 2003-02-28
3057 ((and (csubtypep type2
(specifier-type 'ratio
))
3058 (numeric-type-p type1
)
3059 (csubtypep type1
(specifier-type 'integer
))
3064 :low
(if (null (numeric-type-low type1
))
3066 (list (1- (numeric-type-low type1
))))
3067 :high
(if (null (numeric-type-high type1
))
3069 (list (1+ (numeric-type-high type1
)))))))
3070 (let* ((intersected (intersection-type-types type2
))
3071 (remaining (remove (specifier-type '(not integer
))
3074 (and (not (equal intersected remaining
))
3075 (type-union type1
(apply #'type-intersection remaining
)))))
3077 (let ((accumulator *universal-type
*))
3078 (do ((t2s (intersection-type-types type2
) (cdr t2s
)))
3079 ((null t2s
) accumulator
)
3080 (let ((union (type-union type1
(car t2s
))))
3081 (when (union-type-p union
)
3082 ;; we have to give up here -- there are all sorts of
3083 ;; ordering worries, but it's better than before.
3084 ;; Doing exactly the same as in the UNION
3085 ;; :SIMPLE/:COMPLEX-INTERSECTION2 method causes stack
3086 ;; overflow with the mutual recursion never bottoming
3088 (if (and (eq accumulator
*universal-type
*)
3090 ;; KLUDGE: if we get here, we have a partially
3091 ;; simplified result. While this isn't by any
3092 ;; means a universal simplification, including
3093 ;; this logic here means that we can get (OR
3094 ;; KEYWORD (NOT KEYWORD)) canonicalized to T.
3098 (type-intersection accumulator union
))))))))
3100 (!def-type-translator and
:list
((:context context
) &rest type-specifiers
)
3101 (apply #'type-intersection
3102 (mapcar (lambda (x) (specifier-type-r context x
))
3107 (!define-type-class union
3108 :enumerable
#'compound-type-enumerable
3109 :might-contain-other-types t
)
3111 (!define-type-method
(union :negate
) (type)
3112 (declare (type ctype type
))
3113 (apply #'type-intersection
3114 (mapcar #'type-negation
(union-type-types type
))))
3116 ;;; Unlike ARRAY-TYPE-DIMENSIONS this handles union types, which
3117 ;;; includes the type STRING.
3118 (defun ctype-array-dimensions (type)
3119 (labels ((process-compound-type (types)
3121 (dolist (type types
)
3122 (unless (or (hairy-type-p type
)
3123 (negation-type-p type
))
3124 (let ((current-dimensions (determine type
)))
3125 (cond ((eq current-dimensions
'*)
3126 (return-from ctype-array-dimensions
'*))
3128 (not (equal current-dimensions dimensions
)))
3129 (if (= (length dimensions
)
3130 (length current-dimensions
))
3132 (loop for dimension in dimensions
3133 for current-dimension in current-dimensions
3134 collect
(if (eql dimension current-dimension
)
3137 (return-from ctype-array-dimensions
'*)))
3140 (setf dimensions current-dimensions
))))))
3145 (array-type-dimensions type
))
3147 (process-compound-type (union-type-types type
)))
3149 (process-compound-type
3150 (mapcar #'ctype-of
(member-type-members type
))))
3152 (process-compound-type (intersection-type-types type
))))))
3155 (defun ctype-array-specialized-element-types (type)
3157 (labels ((process-compound-type (types)
3158 (loop for type in types
3159 unless
(or (hairy-type-p type
)
3160 (negation-type-p type
))
3161 do
(determine type
)))
3165 (when (eq (array-type-specialized-element-type type
) *wild-type
*)
3166 (return-from ctype-array-specialized-element-types
3168 (pushnew (array-type-specialized-element-type type
)
3169 types
:test
#'type
=))
3171 (process-compound-type (union-type-types type
)))
3173 (process-compound-type (intersection-type-types type
)))
3175 (process-compound-type
3176 (mapcar #'ctype-of
(member-type-members type
)))))))
3180 (defun unparse-string-type (ctype string-type
)
3181 (let ((string-ctype (specifier-type string-type
)))
3182 (and (union-type-p ctype
)
3183 (csubtypep ctype string-ctype
)
3184 (let ((types (copy-list (union-type-types string-ctype
))))
3185 (and (loop for type in
(union-type-types ctype
)
3186 for matching
= (and (array-type-p type
)
3190 do
(setf types
(delete matching types
)))
3192 (let ((dimensions (ctype-array-dimensions ctype
)))
3193 (cond ((and (singleton-p dimensions
)
3194 (integerp (car dimensions
)))
3195 `(,string-type
,@dimensions
)))))))
3197 ;;; The LIST, FLOAT and REAL types have special names. Other union
3198 ;;; types just get mechanically unparsed.
3199 (!define-type-method
(union :unparse
) (type)
3200 (declare (type ctype type
))
3202 ((type= type
(specifier-type 'list
)) 'list
)
3203 ((type= type
(specifier-type 'float
)) 'float
)
3204 ((type= type
(specifier-type 'real
)) 'real
)
3205 ((type= type
(specifier-type 'sequence
)) 'sequence
)
3206 ((type= type
(specifier-type 'bignum
)) 'bignum
)
3207 ((type= type
(specifier-type 'simple-string
)) 'simple-string
)
3208 ((type= type
(specifier-type 'string
)) 'string
)
3209 ((unparse-string-type type
'simple-string
))
3210 ((unparse-string-type type
'string
))
3211 ((type= type
(specifier-type 'complex
)) 'complex
)
3212 (t `(or ,@(mapcar #'type-specifier
(union-type-types type
))))))
3214 ;;; Two union types are equal if they are each subtypes of each
3215 ;;; other. We need to be this clever because our complex subtypep
3216 ;;; methods are now more accurate; we don't get infinite recursion
3217 ;;; because the simple-subtypep method delegates to complex-subtypep
3218 ;;; of the individual types of type1. - CSR, 2002-04-09
3220 ;;; Previous comment, now obsolete, but worth keeping around because
3221 ;;; it is true, though too strong a condition:
3223 ;;; Two union types are equal if their subtypes are equal sets.
3224 (!define-type-method
(union :simple-
=) (type1 type2
)
3225 (multiple-value-bind (subtype certain?
)
3226 (csubtypep type1 type2
)
3228 (csubtypep type2 type1
)
3229 ;; we might as well become as certain as possible.
3232 (multiple-value-bind (subtype certain?
)
3233 (csubtypep type2 type1
)
3234 (declare (ignore subtype
))
3235 (values nil certain?
))))))
3237 (!define-type-method
(union :complex-
=) (type1 type2
)
3238 (declare (ignore type1
))
3239 (if (some #'type-might-contain-other-types-p
3240 (union-type-types type2
))
3244 ;;; Similarly, a union type is a subtype of another if and only if
3245 ;;; every element of TYPE1 is a subtype of TYPE2.
3246 (defun union-simple-subtypep (type1 type2
)
3247 (every/type
(swapped-args-fun #'union-complex-subtypep-arg2
)
3249 (union-type-types type1
)))
3251 (!define-type-method
(union :simple-subtypep
) (type1 type2
)
3252 (union-simple-subtypep type1 type2
))
3254 (defun union-complex-subtypep-arg1 (type1 type2
)
3255 (every/type
(swapped-args-fun #'csubtypep
)
3257 (union-type-types type1
)))
3259 (!define-type-method
(union :complex-subtypep-arg1
) (type1 type2
)
3260 (union-complex-subtypep-arg1 type1 type2
))
3262 (defun union-complex-subtypep-arg2 (type1 type2
)
3263 ;; At this stage, we know that type2 is a union type and type1
3264 ;; isn't. We might as well check this, though:
3265 (aver (union-type-p type2
))
3266 (aver (not (union-type-p type1
)))
3267 ;; was: (any/type #'csubtypep type1 (union-type-types type2)), which
3268 ;; turns out to be too restrictive, causing bug 91.
3270 ;; the following reimplementation might look dodgy. It is dodgy. It
3271 ;; depends on the union :complex-= method not doing very much work
3272 ;; -- certainly, not using subtypep. Reasoning:
3274 ;; A is a subset of (B1 u B2)
3275 ;; <=> A n (B1 u B2) = A
3276 ;; <=> (A n B1) u (A n B2) = A
3278 ;; But, we have to be careful not to delegate this type= to
3279 ;; something that could invoke subtypep, which might get us back
3280 ;; here -> stack explosion. We therefore ensure that the second type
3281 ;; (which is the one that's dispatched on) is either a union type
3282 ;; (where we've ensured that the complex-= method will not call
3283 ;; subtypep) or something with no union types involved, in which
3284 ;; case we'll never come back here.
3286 ;; If we don't do this, then e.g.
3287 ;; (SUBTYPEP '(MEMBER 3) '(OR (SATISFIES FOO) (SATISFIES BAR)))
3288 ;; would loop infinitely, as the member :complex-= method is
3289 ;; implemented in terms of subtypep.
3291 ;; Ouch. - CSR, 2002-04-10
3292 (multiple-value-bind (sub-value sub-certain?
)
3295 (mapcar (lambda (x) (type-intersection type1 x
))
3296 (union-type-types type2
))))
3298 (values sub-value sub-certain?
)
3299 ;; The ANY/TYPE expression above is a sufficient condition for
3300 ;; subsetness, but not a necessary one, so we might get a more
3301 ;; certain answer by this CALL-NEXT-METHOD-ish step when the
3302 ;; ANY/TYPE expression is uncertain.
3303 (invoke-complex-subtypep-arg1-method type1 type2
))))
3305 (!define-type-method
(union :complex-subtypep-arg2
) (type1 type2
)
3306 (union-complex-subtypep-arg2 type1 type2
))
3308 (!define-type-method
(union :simple-intersection2
:complex-intersection2
)
3310 ;; The CSUBTYPEP clauses here let us simplify e.g.
3311 ;; (TYPE-INTERSECTION2 (SPECIFIER-TYPE 'LIST)
3312 ;; (SPECIFIER-TYPE '(OR LIST VECTOR)))
3313 ;; (where LIST is (OR CONS NULL)).
3315 ;; The tests are more or less (CSUBTYPEP TYPE1 TYPE2) and vice
3316 ;; versa, but it's important that we pre-expand them into
3317 ;; specialized operations on individual elements of
3318 ;; UNION-TYPE-TYPES, instead of using the ordinary call to
3319 ;; CSUBTYPEP, in order to avoid possibly invoking any methods which
3320 ;; might in turn invoke (TYPE-INTERSECTION2 TYPE1 TYPE2) and thus
3321 ;; cause infinite recursion.
3323 ;; Within this method, type2 is guaranteed to be a union type:
3324 (aver (union-type-p type2
))
3325 ;; Make sure to call only the applicable methods...
3326 (cond ((and (union-type-p type1
)
3327 (union-simple-subtypep type1 type2
)) type1
)
3328 ((and (union-type-p type1
)
3329 (union-simple-subtypep type2 type1
)) type2
)
3330 ((and (not (union-type-p type1
))
3331 (union-complex-subtypep-arg2 type1 type2
))
3333 ((and (not (union-type-p type1
))
3334 (union-complex-subtypep-arg1 type2 type1
))
3337 ;; KLUDGE: This code accumulates a sequence of TYPE-UNION2
3338 ;; operations in a particular order, and gives up if any of
3339 ;; the sub-unions turn out not to be simple. In other cases
3340 ;; ca. sbcl-0.6.11.15, that approach to taking a union was a
3341 ;; bad idea, since it can overlook simplifications which
3342 ;; might occur if the terms were accumulated in a different
3343 ;; order. It's possible that that will be a problem here too.
3344 ;; However, I can't think of a good example to demonstrate
3345 ;; it, and without an example to demonstrate it I can't write
3346 ;; test cases, and without test cases I don't want to
3347 ;; complicate the code to address what's still a hypothetical
3348 ;; problem. So I punted. -- WHN 2001-03-20
3349 (let ((accumulator *empty-type
*))
3350 (dolist (t2 (union-type-types type2
) accumulator
)
3352 (type-union accumulator
3353 (type-intersection type1 t2
))))))))
3355 (!def-type-translator or
:list
((:context context
) &rest type-specifiers
)
3356 (let ((type (apply #'type-union
3357 (mapcar (lambda (x) (specifier-type-r context x
))
3359 (if (union-type-p type
)
3360 (sb!kernel
::simplify-array-unions type
)
3365 (!def-type-translator cons
((:context context
)
3366 &optional
(car-type-spec '*) (cdr-type-spec '*))
3367 (let ((car-type (single-value-specifier-type-r context car-type-spec
))
3368 (cdr-type (single-value-specifier-type-r context cdr-type-spec
)))
3369 (make-cons-type car-type cdr-type
)))
3371 (!define-type-method
(cons :negate
) (type)
3372 (if (and (eq (cons-type-car-type type
) *universal-type
*)
3373 (eq (cons-type-cdr-type type
) *universal-type
*))
3374 (make-negation-type type
)
3376 (make-negation-type (specifier-type 'cons
))
3378 ((and (not (eq (cons-type-car-type type
) *universal-type
*))
3379 (not (eq (cons-type-cdr-type type
) *universal-type
*)))
3382 (type-negation (cons-type-car-type type
))
3386 (type-negation (cons-type-cdr-type type
)))))
3387 ((not (eq (cons-type-car-type type
) *universal-type
*))
3389 (type-negation (cons-type-car-type type
))
3391 ((not (eq (cons-type-cdr-type type
) *universal-type
*))
3394 (type-negation (cons-type-cdr-type type
))))
3395 (t (bug "Weird CONS type ~S" type
))))))
3397 (!define-type-method
(cons :unparse
) (type)
3398 (if (eq type
(specifier-type 'cons
))
3400 `(cons ,(type-specifier (cons-type-car-type type
))
3401 ,(type-specifier (cons-type-cdr-type type
)))))
3403 (!define-type-method
(cons :simple-
=) (type1 type2
)
3404 (declare (type cons-type type1 type2
))
3405 (multiple-value-bind (car-match car-win
)
3406 (type= (cons-type-car-type type1
) (cons-type-car-type type2
))
3407 (multiple-value-bind (cdr-match cdr-win
)
3408 (type= (cons-type-cdr-type type1
) (cons-type-cdr-type type2
))
3409 (cond ((and car-match cdr-match
)
3410 (aver (and car-win cdr-win
))
3414 ;; FIXME: Ideally we would like to detect and handle
3415 ;; (CONS UNKNOWN INTEGER) (CONS UNKNOWN SYMBOL) => NIL, T
3416 ;; but just returning a secondary true on (and car-win cdr-win)
3417 ;; unfortunately breaks other things. --NS 2006-08-16
3418 (and (or (and (not car-match
) car-win
)
3419 (and (not cdr-match
) cdr-win
))
3420 (not (and (cons-type-might-be-empty-type type1
)
3421 (cons-type-might-be-empty-type type2
))))))))))
3423 (!define-type-method
(cons :simple-subtypep
) (type1 type2
)
3424 (declare (type cons-type type1 type2
))
3425 (multiple-value-bind (val-car win-car
)
3426 (csubtypep (cons-type-car-type type1
) (cons-type-car-type type2
))
3427 (multiple-value-bind (val-cdr win-cdr
)
3428 (csubtypep (cons-type-cdr-type type1
) (cons-type-cdr-type type2
))
3429 (if (and val-car val-cdr
)
3430 (values t
(and win-car win-cdr
))
3431 (values nil
(or (and (not val-car
) win-car
)
3432 (and (not val-cdr
) win-cdr
)))))))
3434 ;;; Give up if a precise type is not possible, to avoid returning
3435 ;;; overly general types.
3436 (!define-type-method
(cons :simple-union2
) (type1 type2
)
3437 (declare (type cons-type type1 type2
))
3438 (let ((car-type1 (cons-type-car-type type1
))
3439 (car-type2 (cons-type-car-type type2
))
3440 (cdr-type1 (cons-type-cdr-type type1
))
3441 (cdr-type2 (cons-type-cdr-type type2
))
3444 ;; UGH. -- CSR, 2003-02-24
3445 (macrolet ((frob-car (car1 car2 cdr1 cdr2
3446 &optional
(not1 nil not1p
))
3448 (make-cons-type ,car1
(type-union ,cdr1
,cdr2
))
3450 (type-intersection ,car2
3453 `(type-negation ,car1
)))
3455 (cond ((type= car-type1 car-type2
)
3456 (make-cons-type car-type1
3457 (type-union cdr-type1 cdr-type2
)))
3458 ((type= cdr-type1 cdr-type2
)
3459 (make-cons-type (type-union car-type1 car-type2
)
3461 ((csubtypep car-type1 car-type2
)
3462 (frob-car car-type1 car-type2 cdr-type1 cdr-type2
))
3463 ((csubtypep car-type2 car-type1
)
3464 (frob-car car-type2 car-type1 cdr-type2 cdr-type1
))
3465 ;; more general case of the above, but harder to compute
3467 (setf car-not1
(type-negation car-type1
))
3468 (multiple-value-bind (yes win
)
3469 (csubtypep car-type2 car-not1
)
3470 (and (not yes
) win
)))
3471 (frob-car car-type1 car-type2 cdr-type1 cdr-type2 car-not1
))
3473 (setf car-not2
(type-negation car-type2
))
3474 (multiple-value-bind (yes win
)
3475 (csubtypep car-type1 car-not2
)
3476 (and (not yes
) win
)))
3477 (frob-car car-type2 car-type1 cdr-type2 cdr-type1 car-not2
))
3478 ;; Don't put these in -- consider the effect of taking the
3479 ;; union of (CONS (INTEGER 0 2) (INTEGER 5 7)) and
3480 ;; (CONS (INTEGER 0 3) (INTEGER 5 6)).
3482 ((csubtypep cdr-type1 cdr-type2
)
3483 (frob-cdr car-type1 car-type2 cdr-type1 cdr-type2
))
3485 ((csubtypep cdr-type2 cdr-type1
)
3486 (frob-cdr car-type2 car-type1 cdr-type2 cdr-type1
))))))
3488 (!define-type-method
(cons :simple-intersection2
) (type1 type2
)
3489 (declare (type cons-type type1 type2
))
3490 (let ((car-int2 (type-intersection2 (cons-type-car-type type1
)
3491 (cons-type-car-type type2
)))
3492 (cdr-int2 (type-intersection2 (cons-type-cdr-type type1
)
3493 (cons-type-cdr-type type2
))))
3495 ((and car-int2 cdr-int2
) (make-cons-type car-int2 cdr-int2
))
3496 (car-int2 (make-cons-type car-int2
3498 (cons-type-cdr-type type1
)
3499 (cons-type-cdr-type type2
))))
3500 (cdr-int2 (make-cons-type
3501 (type-intersection (cons-type-car-type type1
)
3502 (cons-type-car-type type2
))
3505 (!define-superclasses cons
((cons)) !cold-init-forms
)
3507 ;;;; CHARACTER-SET types
3509 (!def-type-translator character-set
3510 (&optional
(pairs '((0 .
#.
(1- sb
!xc
:char-code-limit
)))))
3511 (make-character-set-type pairs
))
3513 (!define-type-method
(character-set :negate
) (type)
3514 (let ((pairs (character-set-type-pairs type
)))
3515 (if (and (= (length pairs
) 1)
3517 (= (cdar pairs
) (1- sb
!xc
:char-code-limit
)))
3518 (make-negation-type type
)
3519 (let ((not-character
3521 (make-character-set-type
3522 '((0 .
#.
(1- sb
!xc
:char-code-limit
)))))))
3525 (make-character-set-type
3527 (when (> (caar pairs
) 0)
3528 (push (cons 0 (1- (caar pairs
))) not-pairs
))
3529 (do* ((tail pairs
(cdr tail
))
3530 (high1 (cdar tail
) (cdar tail
))
3531 (low2 (caadr tail
) (caadr tail
)))
3533 (when (< (cdar tail
) (1- sb
!xc
:char-code-limit
))
3534 (push (cons (1+ (cdar tail
))
3535 (1- sb
!xc
:char-code-limit
))
3537 (nreverse not-pairs
))
3538 (push (cons (1+ high1
) (1- low2
)) not-pairs
)))))))))
3540 (!define-type-method
(character-set :unparse
) (type)
3542 ((eq type
(specifier-type 'character
)) 'character
)
3543 ((eq type
(specifier-type 'base-char
)) 'base-char
)
3544 ((eq type
(specifier-type 'extended-char
)) 'extended-char
)
3545 ;; standard-char is not an interned type
3546 ((type= type
(specifier-type 'standard-char
)) 'standard-char
)
3548 ;; Unparse into either MEMBER or CHARACTER-SET. We use MEMBER if there
3549 ;; are at most as many characters as there are character code ranges.
3550 ;; (basically saying to use MEMBER if each range is one character)
3551 (let* ((pairs (character-set-type-pairs type
))
3552 (count (length pairs
))
3553 (chars (loop named outer
3554 for
(low . high
) in pairs
3555 nconc
(loop for code from low upto high
3556 collect
(sb!xc
:code-char code
)
3557 when
(minusp (decf count
))
3558 do
(return-from outer t
)))))
3560 `(character-set ,pairs
)
3561 `(member ,@chars
))))))
3563 (!define-type-method
(character-set :singleton-p
) (type)
3564 (let* ((pairs (character-set-type-pairs type
))
3565 (pair (first pairs
)))
3566 (if (and (typep pairs
'(cons t null
))
3567 (eql (car pair
) (cdr pair
)))
3568 (values t
(code-char (car pair
)))
3571 (!define-type-method
(character-set :simple-
=) (type1 type2
)
3572 (let ((pairs1 (character-set-type-pairs type1
))
3573 (pairs2 (character-set-type-pairs type2
)))
3574 (values (equal pairs1 pairs2
) t
)))
3576 (!define-type-method
(character-set :simple-subtypep
) (type1 type2
)
3578 (dolist (pair (character-set-type-pairs type1
) t
)
3579 (unless (position pair
(character-set-type-pairs type2
)
3580 :test
(lambda (x y
) (and (>= (car x
) (car y
))
3581 (<= (cdr x
) (cdr y
)))))
3585 (!define-type-method
(character-set :simple-union2
) (type1 type2
)
3586 ;; KLUDGE: the canonizing in the MAKE-CHARACTER-SET-TYPE function
3587 ;; actually does the union for us. It might be a little fragile to
3589 (make-character-set-type
3591 (copy-alist (character-set-type-pairs type1
))
3592 (copy-alist (character-set-type-pairs type2
))
3595 (!define-type-method
(character-set :simple-intersection2
) (type1 type2
)
3596 ;; KLUDGE: brute force.
3599 (dolist (pair1 (character-set-type-pairs type1
)
3600 (make-character-set-type
3601 (sort pairs
#'< :key
#'car
)))
3602 (dolist (pair2 (character-set-type-pairs type2
))
3604 ((<= (car pair1
) (car pair2
) (cdr pair1
))
3605 (push (cons (car pair2
) (min (cdr pair1
) (cdr pair2
))) pairs
))
3606 ((<= (car pair2
) (car pair1
) (cdr pair2
))
3607 (push (cons (car pair1
) (min (cdr pair1
) (cdr pair2
))) pairs
))))))
3609 (make-character-set-type
3610 (intersect-type-pairs
3611 (character-set-type-pairs type1
)
3612 (character-set-type-pairs type2
))))
3615 ;;; Intersect two ordered lists of pairs
3616 ;;; Each list is of the form ((start1 . end1) ... (startn . endn)),
3617 ;;; where start1 <= end1 < start2 <= end2 < ... < startn <= endn.
3618 ;;; Each pair represents the integer interval start..end.
3620 (defun intersect-type-pairs (alist1 alist2
)
3621 (if (and alist1 alist2
)
3623 (pair1 (pop alist1
))
3624 (pair2 (pop alist2
)))
3626 (when (> (car pair1
) (car pair2
))
3627 (rotatef pair1 pair2
)
3628 (rotatef alist1 alist2
))
3629 (let ((pair1-cdr (cdr pair1
)))
3631 ((> (car pair2
) pair1-cdr
)
3632 ;; No over lap -- discard pair1
3633 (unless alist1
(return))
3634 (setq pair1
(pop alist1
)))
3635 ((<= (cdr pair2
) pair1-cdr
)
3636 (push (cons (car pair2
) (cdr pair2
)) res
)
3638 ((= (cdr pair2
) pair1-cdr
)
3639 (unless alist1
(return))
3640 (unless alist2
(return))
3641 (setq pair1
(pop alist1
)
3642 pair2
(pop alist2
)))
3643 (t ;; (< (cdr pair2) pair1-cdr)
3644 (unless alist2
(return))
3645 (setq pair1
(cons (1+ (cdr pair2
)) pair1-cdr
))
3646 (setq pair2
(pop alist2
)))))
3647 (t ;; (> (cdr pair2) (cdr pair1))
3648 (push (cons (car pair2
) pair1-cdr
) res
)
3649 (unless alist1
(return))
3650 (setq pair2
(cons (1+ pair1-cdr
) (cdr pair2
)))
3651 (setq pair1
(pop alist1
))))))
3656 ;;; Return the type that describes all objects that are in X but not
3657 ;;; in Y. If we can't determine this type, then return NIL.
3659 ;;; For now, we only are clever dealing with union and member types.
3660 ;;; If either type is not a union type, then we pretend that it is a
3661 ;;; union of just one type. What we do is remove from X all the types
3662 ;;; that are a subtype any type in Y. If any type in X intersects with
3663 ;;; a type in Y but is not a subtype, then we give up.
3665 ;;; We must also special-case any member type that appears in the
3666 ;;; union. We remove from X's members all objects that are TYPEP to Y.
3667 ;;; If Y has any members, we must be careful that none of those
3668 ;;; members are CTYPEP to any of Y's non-member types. We give up in
3669 ;;; this case, since to compute that difference we would have to break
3670 ;;; the type from X into some collection of types that represents the
3671 ;;; type without that particular element. This seems too hairy to be
3672 ;;; worthwhile, given its low utility.
3673 (defun type-difference (x y
)
3674 (if (and (numeric-type-p x
) (numeric-type-p y
))
3675 ;; Numeric types are easy. Are there any others we should handle like this?
3676 (type-intersection x
(type-negation y
))
3677 (let ((x-types (if (union-type-p x
) (union-type-types x
) (list x
)))
3678 (y-types (if (union-type-p y
) (union-type-types y
) (list y
))))
3680 (dolist (x-type x-types
)
3681 (if (member-type-p x-type
)
3682 (let ((xset (alloc-xset))
3684 (mapc-member-type-members
3686 (multiple-value-bind (ok sure
) (ctypep elt y
)
3688 (return-from type-difference nil
))
3691 (pushnew elt fp-zeroes
)
3692 (add-to-xset elt xset
)))))
3694 (unless (and (xset-empty-p xset
) (not fp-zeroes
))
3695 (res (make-member-type xset fp-zeroes
))))
3696 (dolist (y-type y-types
(res x-type
))
3697 (multiple-value-bind (val win
) (csubtypep x-type y-type
)
3698 (unless win
(return-from type-difference nil
))
3700 (when (types-equal-or-intersect x-type y-type
)
3701 (return-from type-difference nil
))))))
3702 (let ((y-mem (find-if #'member-type-p y-types
)))
3704 (dolist (x-type x-types
)
3705 (unless (member-type-p x-type
)
3706 (mapc-member-type-members
3708 (multiple-value-bind (ok sure
) (ctypep member x-type
)
3709 (when (or (not sure
) ok
)
3710 (return-from type-difference nil
))))
3712 (apply #'type-union
(res))))))
3714 (!def-type-translator array
((:context context
)
3715 &optional
(element-type '*)
3717 (let ((eltype (if (eq element-type
'*)
3719 (specifier-type-r context element-type
))))
3720 (make-array-type (canonical-array-dimensions dimensions
)
3722 :element-type eltype
3723 :specialized-element-type
(%upgraded-array-element-type
3726 (!def-type-translator simple-array
((:context context
)
3727 &optional
(element-type '*)
3729 (let ((eltype (if (eq element-type
'*)
3731 (specifier-type-r context element-type
))))
3732 (make-array-type (canonical-array-dimensions dimensions
)
3734 :element-type eltype
3735 :specialized-element-type
(%upgraded-array-element-type
3738 ;;;; SIMD-PACK types
3741 (!define-type-class simd-pack
:enumerable nil
3742 :might-contain-other-types nil
)
3744 ;; Though this involves a recursive call to parser, parsing context need not
3745 ;; be passed down, because an unknown-type condition is an immediate failure.
3746 (!def-type-translator simd-pack
(&optional
(element-type-spec '*))
3747 (if (eql element-type-spec
'*)
3748 (%make-simd-pack-type
*simd-pack-element-types
*)
3749 (make-simd-pack-type (single-value-specifier-type element-type-spec
))))
3751 (!define-type-method
(simd-pack :negate
) (type)
3752 (let ((remaining (set-difference *simd-pack-element-types
*
3753 (simd-pack-type-element-type type
)))
3754 (not-simd-pack (make-negation-type (specifier-type 'simd-pack
))))
3756 (type-union not-simd-pack
(%make-simd-pack-type remaining
))
3759 (!define-type-method
(simd-pack :unparse
) (type)
3760 (let ((eltypes (simd-pack-type-element-type type
)))
3761 (cond ((equal eltypes
*simd-pack-element-types
*)
3763 ((= 1 (length eltypes
))
3764 `(simd-pack ,(first eltypes
)))
3766 `(or ,@(mapcar (lambda (eltype)
3767 `(simd-pack ,eltype
))
3770 (!define-type-method
(simd-pack :simple-
=) (type1 type2
)
3771 (declare (type simd-pack-type type1 type2
))
3772 (null (set-exclusive-or (simd-pack-type-element-type type1
)
3773 (simd-pack-type-element-type type2
))))
3775 (!define-type-method
(simd-pack :simple-subtypep
) (type1 type2
)
3776 (declare (type simd-pack-type type1 type2
))
3777 (subsetp (simd-pack-type-element-type type1
)
3778 (simd-pack-type-element-type type2
)))
3780 (!define-type-method
(simd-pack :simple-union2
) (type1 type2
)
3781 (declare (type simd-pack-type type1 type2
))
3782 (%make-simd-pack-type
(union (simd-pack-type-element-type type1
)
3783 (simd-pack-type-element-type type2
))))
3785 (!define-type-method
(simd-pack :simple-intersection2
) (type1 type2
)
3786 (declare (type simd-pack-type type1 type2
))
3787 (let ((intersection (intersection (simd-pack-type-element-type type1
)
3788 (simd-pack-type-element-type type2
))))
3790 (%make-simd-pack-type intersection
)
3793 (!define-superclasses simd-pack
((simd-pack)) !cold-init-forms
))
3795 ;;;; utilities shared between cross-compiler and target system
3797 ;;; Does the type derived from compilation of an actual function
3798 ;;; definition satisfy declarations of a function's type?
3799 (defun defined-ftype-matches-declared-ftype-p (defined-ftype declared-ftype
)
3800 (declare (type ctype defined-ftype declared-ftype
))
3801 (flet ((is-built-in-class-function-p (ctype)
3802 (and (built-in-classoid-p ctype
)
3803 (eq (built-in-classoid-name ctype
) 'function
))))
3804 (cond (;; DECLARED-FTYPE could certainly be #<BUILT-IN-CLASS FUNCTION>;
3805 ;; that's what happens when we (DECLAIM (FTYPE FUNCTION FOO)).
3806 (is-built-in-class-function-p declared-ftype
)
3807 ;; In that case, any definition satisfies the declaration.
3809 (;; It's not clear whether or how DEFINED-FTYPE might be
3810 ;; #<BUILT-IN-CLASS FUNCTION>, but it's not obviously
3811 ;; invalid, so let's handle that case too, just in case.
3812 (is-built-in-class-function-p defined-ftype
)
3813 ;; No matter what DECLARED-FTYPE might be, we can't prove
3814 ;; that an object of type FUNCTION doesn't satisfy it, so
3815 ;; we return success no matter what.
3817 (;; Otherwise both of them must be FUN-TYPE objects.
3819 ;; FIXME: For now we only check compatibility of the return
3820 ;; type, not argument types, and we don't even check the
3821 ;; return type very precisely (as per bug 94a). It would be
3822 ;; good to do a better job. Perhaps to check the
3823 ;; compatibility of the arguments, we should (1) redo
3824 ;; VALUES-TYPES-EQUAL-OR-INTERSECT as
3825 ;; ARGS-TYPES-EQUAL-OR-INTERSECT, and then (2) apply it to
3826 ;; the ARGS-TYPE slices of the FUN-TYPEs. (ARGS-TYPE
3827 ;; is a base class both of VALUES-TYPE and of FUN-TYPE.)
3828 (values-types-equal-or-intersect
3829 (fun-type-returns defined-ftype
)
3830 (fun-type-returns declared-ftype
))))))
3832 ;;; This messy case of CTYPE for NUMBER is shared between the
3833 ;;; cross-compiler and the target system.
3834 (defun ctype-of-number (x)
3835 (let ((num (if (complexp x
) (realpart x
) x
)))
3836 (multiple-value-bind (complexp low high
)
3838 (let ((imag (imagpart x
)))
3839 (values :complex
(min num imag
) (max num imag
)))
3840 (values :real num num
))
3841 (make-numeric-type :class
(etypecase num
3842 (integer (if (complexp x
)
3843 (if (integerp (imagpart x
))
3847 (rational 'rational
)
3849 :format
(and (floatp num
) (float-format-name num
))
3854 ;;; The following function is a generic driver for approximating
3855 ;;; set-valued functions over types. Putting this here because it'll
3856 ;;; probably be useful for a lot of type analyses.
3858 ;;; Let f be a function from values of type X to Y, e.g., ARRAY-RANK.
3860 ;;; We compute an over or under-approximation of the set
3862 ;;; F(TYPE) = { f(x) : x in TYPE /\ x in X } \subseteq Y
3864 ;;; via set-valued approximations of f, OVER and UNDER.
3866 ;;; These functions must have the property that
3867 ;;; Forall TYPE, OVER(TYPE) \superseteq F(TYPE) and
3868 ;;; Forall TYPE, UNDER(TYPE) \subseteq F(TYPE)
3870 ;;; The driver is also parameterised over the finite set
3873 ;;; Union, intersection and difference are binary functions to compute
3874 ;;; set union, intersection and difference. Top and bottom are the
3875 ;;; concrete representations for the universe and empty sets; we never
3876 ;;; call the set functions on top or bottom, so it's safe to use
3877 ;;; special values there.
3881 ;;; TYPE: the ctype for which we wish to approximate F(TYPE)
3882 ;;; OVERAPPROXIMATE: true if we wish to overapproximate, nil otherwise.
3883 ;;; You usually want T.
3884 ;;; UNION/INTERSECTION/DIFFERENCE: implementations of finite set operations.
3885 ;;; Conform to cl::(union/intersection/set-difference). Passing NIL will
3886 ;;; disable some cleverness and result in quicker computation of coarser
3887 ;;; approximations. However, passing difference without union and intersection
3888 ;;; will probably not end well.
3889 ;;; TOP/BOTTOM: concrete representation of the universe and empty set. Finite
3890 ;;; set operations are never called on TOP/BOTTOM, so it's safe to use special
3892 ;;; OVER/UNDER: the set-valued approximations of F.
3894 ;;; Implementation details.
3896 ;;; It's a straightforward walk down the type.
3897 ;;; Union types -> take the union of children, intersection ->
3898 ;;; intersect. There is some complication for negation types: we must
3899 ;;; not only negate the result, but also flip from overapproximating
3900 ;;; to underapproximating in the children (or vice versa).
3902 ;;; We represent sets as a pair of (negate-p finite-set) in order to
3903 ;;; support negation types.
3905 (declaim (inline generic-abstract-type-function
))
3906 (defun generic-abstract-type-function
3907 (type overapproximate
3908 union intersection difference
3911 (labels ((union* (x y
)
3912 ;; wrappers to avoid calling union/intersection on
3914 (cond ((or (eql x top
)
3920 (funcall union x y
))))
3921 (intersection* (x y
)
3922 (cond ((or (eql x bottom
)
3928 (funcall intersection x y
))))
3929 (unite (not-x-p x not-y-p y
)
3930 ;; if we only have one negated set, it's x.
3932 (rotatef not-x-p not-y-p
)
3934 (cond ((and not-x-p not-y-p
)
3935 ;; -x \/ -y = -(x /\ y)
3936 (normalize t
(intersection* x y
)))
3938 ;; -x \/ y = -(x \ y)
3948 (funcall difference x y
)))))
3950 (values nil
(union* x y
)))))
3951 (intersect (not-x-p x not-y-p y
)
3953 (rotatef not-x-p not-y-p
)
3955 (cond ((and not-x-p not-y-p
)
3956 ;; -x /\ -y = -(x \/ y)
3957 (normalize t
(union* x y
)))
3960 (cond ((or (eql x top
) (eql y bottom
))
3961 (values nil bottom
))
3967 (values nil
(funcall difference y x
)))))
3969 (values nil
(intersection* x y
)))))
3970 (normalize (not-x-p x
)
3971 ;; catch some easy cases of redundant negation.
3972 (cond ((not not-x-p
)
3980 (default (overapproximate)
3982 (if overapproximate top bottom
))
3983 (walk-union (types overapproximate
)
3984 ;; Only do this if union is provided.
3986 (return-from walk-union
(default overapproximate
)))
3987 ;; Reduce/union from bottom.
3988 (let ((not-acc-p nil
)
3990 (dolist (type types
(values not-acc-p acc
))
3991 (multiple-value-bind (not x
)
3992 (walk type overapproximate
)
3993 (setf (values not-acc-p acc
)
3994 (unite not-acc-p acc not x
)))
3995 ;; Early exit on top set.
3996 (when (and (eql acc top
)
3998 (return (values nil top
))))))
3999 (walk-intersection (types overapproximate
)
4000 ;; Skip if we don't know how to intersect sets
4001 (unless intersection
4002 (return-from walk-intersection
(default overapproximate
)))
4003 ;; Reduce/intersection from top
4004 (let ((not-acc-p nil
)
4006 (dolist (type types
(values not-acc-p acc
))
4007 (multiple-value-bind (not x
)
4008 (walk type overapproximate
)
4009 (setf (values not-acc-p acc
)
4010 (intersect not-acc-p acc not x
)))
4011 (when (and (eql acc bottom
)
4013 (return (values nil bottom
))))))
4014 (walk-negate (type overapproximate
)
4015 ;; Don't introduce negated types if we don't know how to
4018 (return-from walk-negate
(default overapproximate
)))
4019 (multiple-value-bind (not x
)
4020 (walk type
(not overapproximate
))
4021 (normalize (not not
) x
)))
4022 (walk (type overapproximate
)
4025 (walk-union (union-type-types type
) overapproximate
))
4026 ((cons (member or union
))
4027 (walk-union (rest type
) overapproximate
))
4029 (walk-intersection (intersection-type-types type
) overapproximate
))
4030 ((cons (member and intersection
))
4031 (walk-intersection (rest type
) overapproximate
))
4033 (walk-negate (negation-type-type type
) overapproximate
))
4035 (walk-negate (second type
) overapproximate
))
4043 (funcall under type
)
4044 (default nil
))))))))
4045 (multiple-value-call #'normalize
(walk type overapproximate
))))
4046 (declaim (notinline generic-abstract-type-function
))
4048 ;;; Standard list representation of sets. Use CL:* for the universe.
4049 (defun list-abstract-type-function (type over
&key under
(overapproximate t
))
4050 (declare (inline generic-abstract-type-function
))
4051 (generic-abstract-type-function
4052 type overapproximate
4053 #'union
#'intersection
#'set-difference
4057 (!defun-from-collected-cold-init-forms
!late-type-cold-init
)
4059 (/show0
"late-type.lisp end of file")
