1 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; This software is derived from the CMU CL system, which was
5 ;;;; written at Carnegie Mellon University and released into the
6 ;;;; public domain. The software is in the public domain and is
7 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
8 ;;;; files for more information.
10 (in-package "SB!KERNEL")
12 (!begin-collecting-cold-init-forms
)
14 ;;; the description of a &KEY argument
15 (defstruct (key-info #-sb-xc-host
(:pure t
)
17 ;; the key (not necessarily a keyword in ANSI Common Lisp)
18 (name (missing-arg) :type symbol
:read-only t
)
19 ;; the type of the argument value
20 (type (missing-arg) :type ctype
:read-only t
))
22 ;;;; representations of types
24 ;;; A HAIRY-TYPE represents anything too weird to be described
25 ;;; reasonably or to be useful, such as NOT, SATISFIES, unknown types,
26 ;;; and unreasonably complicated types involving AND. We just remember
27 ;;; the original type spec.
28 ;;; A possible improvement would be for HAIRY-TYPE to have a subtype
29 ;;; named SATISFIES-TYPE for the hairy types which are specifically
30 ;;; of the form (SATISFIES pred) so that we don't have to examine
31 ;;; the sexpr repeatedly to decide whether it takes that form.
32 ;;; And as a further improvement, we might want a table that maps
33 ;;; predicates to their exactly recognized type when possible.
34 ;;; We have such a table in fact - *BACKEND-PREDICATE-TYPES*
35 ;;; as a starting point. But something like PLUSP isn't in there.
36 ;;; On the other hand, either of these points may not be sources of
37 ;;; inefficiency, and the latter if implemented might have undesirable
38 ;;; user-visible ramifications, though it seems unlikely.
39 (defstruct (hairy-type (:include ctype
40 (class-info (type-class-or-lose 'hairy
)))
41 (:constructor %make-hairy-type
(specifier))
44 ;; the Common Lisp type-specifier of the type we represent
45 (specifier nil
:type t
:read-only t
))
47 ;; ENUMERABLE-P is T because a hairy type could be equivalent to a MEMBER type.
48 ;; e.g. any SATISFIES with a predicate returning T over a finite domain.
49 ;; But in practice there's nothing that can be done with this information,
50 ;; because we don't call random predicates when performing operations on types
51 ;; as objects, only when checking for inclusion of something in the type.
52 (!define-type-class hairy
:enumerable t
:might-contain-other-types t
)
54 ;;; An UNKNOWN-TYPE is a type not known to the type system (not yet
55 ;;; defined). We make this distinction since we don't want to complain
56 ;;; about types that are hairy but defined.
57 (defstruct (unknown-type (:include hairy-type
)
60 (defun maybe-reparse-specifier (type)
61 (when (unknown-type-p type
)
62 (let* ((spec (unknown-type-specifier type
))
63 (name (if (consp spec
)
66 (when (info :type
:kind name
)
67 (let ((new-type (specifier-type spec
)))
68 (unless (unknown-type-p new-type
)
72 (defmacro maybe-reparse-specifier
! (type)
73 (assert (symbolp type
))
74 (with-unique-names (new-type)
75 `(let ((,new-type
(maybe-reparse-specifier ,type
)))
77 (setf ,type
,new-type
)
80 (defstruct (negation-type (:include ctype
81 (class-info (type-class-or-lose 'negation
)))
84 (type (missing-arg) :type ctype
:read-only t
))
86 ;; Former comment was:
87 ;; FIXME: is this right? It's what they had before, anyway
88 ;; But I think the reason it's right is that "enumerable :t" is equivalent
89 ;; to "maybe" which is actually the conservative assumption, same as HAIRY.
90 (!define-type-class negation
:enumerable t
:might-contain-other-types t
)
92 ;;; ARGS-TYPE objects are used both to represent VALUES types and
93 ;;; to represent FUNCTION types.
94 (defstruct (args-type (:include ctype
)
97 ;; Lists of the type for each required and optional argument.
98 (required nil
:type list
:read-only t
)
99 (optional nil
:type list
:read-only t
)
100 ;; The type for the rest arg. NIL if there is no &REST arg.
101 (rest nil
:type
(or ctype null
) :read-only t
)
102 ;; true if &KEY arguments are specified
103 (keyp nil
:type boolean
:read-only t
)
104 ;; list of KEY-INFO structures describing the &KEY arguments
105 (keywords nil
:type list
:read-only t
)
106 ;; true if other &KEY arguments are allowed
107 (allowp nil
:type boolean
:read-only t
))
109 (defun canonicalize-args-type-args (required optional rest
&optional keyp
)
110 (when (eq rest
*empty-type
*)
113 (loop with last-not-rest
= nil
116 do
(cond ((eq opt
*empty-type
*)
117 (return (values required
(subseq optional i
) rest
)))
118 ((and (not keyp
) (neq opt rest
))
119 (setq last-not-rest i
)))
120 finally
(return (values required
124 (subseq optional
0 (1+ last-not-rest
))))
127 (defun parse-args-types (lambda-listy-thing context
)
128 (multiple-value-bind (llks required optional rest keys
)
132 :accept
(ecase context
133 (:values-type
(lambda-list-keyword-mask '(&optional
&rest
)))
134 (:function-type
(lambda-list-keyword-mask
135 '(&optional
&rest
&key
&allow-other-keys
))))
137 (let ((required (mapcar #'single-value-specifier-type required
))
138 (optional (mapcar #'single-value-specifier-type optional
))
139 (rest (when rest
(single-value-specifier-type (car rest
))))
141 (collect ((key-info))
143 (unless (proper-list-of-length-p key
2)
144 (error "Keyword type description is not a two-list: ~S." key
))
145 (let ((kwd (first key
)))
146 (when (find kwd
(key-info) :key
#'key-info-name
)
147 (error "~@<repeated keyword ~S in lambda list: ~2I~_~S~:>"
148 kwd lambda-listy-thing
))
152 :type
(single-value-specifier-type (second key
))))))
154 (multiple-value-bind (required optional rest
)
155 (canonicalize-args-type-args required optional rest
157 (values llks required optional rest keywords
)))))
159 (defstruct (values-type
161 (class-info (type-class-or-lose 'values
)))
162 (:constructor %make-values-type
)
163 (:predicate %values-type-p
)
166 (declaim (inline values-type-p
))
167 (defun values-type-p (x)
168 (or (eq x
*wild-type
*)
171 (defun-cached (make-values-type-cached
174 (lambda (req opt rest allowp
)
175 (logxor (type-list-cache-hash req
)
176 (type-list-cache-hash opt
)
178 (type-hash-value rest
)
180 ;; Results (logand #xFF (sxhash t/nil))
181 ;; hardcoded to avoid relying on the xc host.
182 ;; [but (logand (sxhash nil) #xff) => 2
183 ;; for me, so the code and comment disagree,
184 ;; but not in a way that matters.]
188 ((required equal-but-no-car-recursion
)
189 (optional equal-but-no-car-recursion
)
192 (%make-values-type
:required required
197 (defun make-values-type (&key required optional rest allowp
)
198 (multiple-value-bind (required optional rest
)
199 (canonicalize-args-type-args required optional rest
)
200 (cond ((and (null required
)
202 (eq rest
*universal-type
*))
204 ((memq *empty-type
* required
)
206 (t (make-values-type-cached required optional
209 (!define-type-class values
:enumerable nil
210 :might-contain-other-types nil
)
212 ;;; (SPECIFIER-TYPE 'FUNCTION) and its subtypes
213 (defstruct (fun-type (:include args-type
214 (class-info (type-class-or-lose 'function
)))
216 %make-fun-type
(required optional rest
217 keyp keywords allowp wild-args returns
)))
218 ;; true if the arguments are unrestrictive, i.e. *
219 (wild-args nil
:type boolean
:read-only t
)
220 ;; type describing the return values. This is a values type
221 ;; when multiple values were specified for the return.
222 (returns (missing-arg) :type ctype
:read-only t
))
224 ;; Without this canonicalization step, I found >350 different
225 ;; (FUNCTION (T) *) representations in a sample build.
226 (declaim (type (simple-vector 4) *interned-fun-type-instances
*))
227 (defglobal *interned-fun-types
* (make-array 4))
228 (defun !intern-important-fun-type-instances
()
229 (setq *interned-fun-types
* (make-array 4))
233 (push *universal-type
* required
))
234 (setf (svref *interned-fun-types
* i
)
236 (%make-fun-type required nil nil nil nil nil nil
*wild-type
*))))))
238 (defun make-fun-type (&key required optional rest
241 (let ((rest (if (eq rest
*empty-type
*) nil rest
))
242 (n (length required
)))
244 (not optional
) (not rest
) (not keyp
)
245 (not keywords
) (not allowp
) (not wild-args
)
246 (eq returns
*wild-type
*)
247 (every (lambda (x) (eq x
*universal-type
*)) required
))
248 (svref *interned-fun-types
* n
)
249 (%make-fun-type required optional rest keyp keywords
250 allowp wild-args returns
))))
252 ;;; The CONSTANT-TYPE structure represents a use of the CONSTANT-ARG
253 ;;; "type specifier", which is only meaningful in function argument
254 ;;; type specifiers used within the compiler. (It represents something
255 ;;; that the compiler knows to be a constant.)
256 (defstruct (constant-type
258 (class-info (type-class-or-lose 'constant
)))
260 ;; The type which the argument must be a constant instance of for this type
262 (type (missing-arg) :type ctype
:read-only t
))
264 ;;; The NAMED-TYPE is used to represent *, T and NIL, the standard
265 ;;; special cases, as well as other special cases needed to
266 ;;; interpolate between regions of the type hierarchy, such as
267 ;;; INSTANCE (which corresponds to all those classes with slots which
268 ;;; are not funcallable), FUNCALLABLE-INSTANCE (those classes with
269 ;;; slots which are funcallable) and EXTENDED-SEQUUENCE (non-LIST
270 ;;; non-VECTOR classes which are also sequences). These special cases
271 ;;; are the ones that aren't really discussed by Baker in his
272 ;;; "Decision Procedure for SUBTYPEP" paper.
273 (defstruct (named-type (:include ctype
274 (class-info (type-class-or-lose 'named
)))
276 (name nil
:type symbol
:read-only t
))
278 ;;; a list of all the float "formats" (i.e. internal representations;
279 ;;; nothing to do with #'FORMAT), in order of decreasing precision
280 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
281 (defparameter *float-formats
*
282 '(long-float double-float single-float short-float
)))
284 ;;; The type of a float format.
285 (deftype float-format
() `(member ,@*float-formats
*))
287 ;;; A NUMERIC-TYPE represents any numeric type, including things
289 (defstruct (numeric-type (:include ctype
290 (class-info (type-class-or-lose 'number
)))
291 (:constructor %make-numeric-type
)
293 ;; Formerly defined in every CTYPE, but now just in the ones
294 ;; for which enumerability is variable.
295 (enumerable nil
:read-only t
)
296 ;; the kind of numeric type we have, or NIL if not specified (just
297 ;; NUMBER or COMPLEX)
299 ;; KLUDGE: A slot named CLASS for a non-CLASS value is bad.
300 ;; Especially when a CLASS value *is* stored in another slot (called
301 ;; CLASS-INFO:-). Perhaps this should be called CLASS-NAME? Also
302 ;; weird that comment above says "Numeric-Type is used to represent
303 ;; all numeric types" but this slot doesn't allow COMPLEX as an
304 ;; option.. how does this fall into "not specified" NIL case above?
305 ;; Perhaps someday we can switch to CLOS and make NUMERIC-TYPE
306 ;; be an abstract base class and INTEGER-TYPE, RATIONAL-TYPE, and
307 ;; whatnot be concrete subclasses..
308 (class nil
:type
(member integer rational float nil
) :read-only t
)
309 ;; "format" for a float type (i.e. type specifier for a CPU
310 ;; representation of floating point, e.g. 'SINGLE-FLOAT -- nothing
311 ;; to do with #'FORMAT), or NIL if not specified or not a float.
312 ;; Formats which don't exist in a given implementation don't appear
314 (format nil
:type
(or float-format null
) :read-only t
)
315 ;; Is this a complex numeric type? Null if unknown (only in NUMBER).
317 ;; FIXME: I'm bewildered by FOO-P names for things not intended to
318 ;; interpreted as truth values. Perhaps rename this COMPLEXNESS?
319 (complexp :real
:type
(member :real
:complex nil
) :read-only t
)
320 ;; The upper and lower bounds on the value, or NIL if there is no
321 ;; bound. If a list of a number, the bound is exclusive. Integer
322 ;; types never have exclusive bounds, i.e. they may have them on
323 ;; input, but they're canonicalized to inclusive bounds before we
325 (low nil
:type
(or number cons null
) :read-only t
)
326 (high nil
:type
(or number cons null
) :read-only t
))
328 ;; For some numeric subtypes, uniqueness of the object representation
329 ;; is enforced. These encompass all array specializations and more.
330 (defglobal *unsigned-byte-type
* -
1)
331 (defglobal *integer-type
* -
1)
332 (defglobal *unsigned-byte-n-types
* -
1)
333 (defglobal *signed-byte-n-types
* -
1)
334 (defglobal *real-ffloat-type
* -
1)
335 (defglobal *real-dfloat-type
* -
1)
336 (defglobal *complex-ffloat-type
* -
1)
337 (defglobal *complex-dfloat-type
* -
1)
339 (declaim (type (simple-vector #.
(1+ sb
!vm
:n-word-bits
)) *unsigned-byte-n-types
*)
340 (type (simple-vector #.sb
!vm
:n-word-bits
) *signed-byte-n-types
*))
342 ;; Called after NUMBER-TYPE type-class has been made.
343 (defun !intern-important-numeric-type-instances
()
344 (flet ((float-type (format complexp
)
346 (%make-numeric-type
:class
'float
:complexp complexp
347 :format format
:enumerable nil
)))
348 (int-type (enumerable low high
)
350 (%make-numeric-type
:class
'integer
:complexp
:real
351 :enumerable enumerable
352 :low low
:high high
))))
353 (setq *real-ffloat-type
* (float-type 'single-float
:real
)
354 *real-dfloat-type
* (float-type 'double-float
:real
)
355 *complex-ffloat-type
* (float-type 'single-float
:complex
)
356 *complex-dfloat-type
* (float-type 'double-float
:complex
)
357 *unsigned-byte-type
* (int-type nil
0 nil
)
358 *integer-type
* (int-type nil nil nil
)
359 *unsigned-byte-n-types
* (make-array (1+ sb
!vm
:n-word-bits
))
360 *signed-byte-n-types
* (make-array sb
!vm
:n-word-bits
))
361 (dotimes (j (1+ sb
!vm
:n-word-bits
))
362 (setf (svref *unsigned-byte-n-types
* j
) (int-type t
0 (1- (ash 1 j
)))))
363 (dotimes (j sb
!vm
:n-word-bits
)
364 (setf (svref *signed-byte-n-types
* j
)
365 (let ((high (1- (ash 1 j
)))) (int-type t
(- (1+ high
)) high
))))))
367 ;;; Impose canonicalization rules for NUMERIC-TYPE. Note that in some
368 ;;; cases, despite the name, we return *EMPTY-TYPE* instead of a
370 ;;; FIXME: The ENUMERABLE flag is unexpectedly NIL for types that
371 ;;; come from parsing MEMBER. But bounded integer ranges,
372 ;;; however large, are enumerable:
373 ;;; (TYPE-ENUMERABLE (SPECIFIER-TYPE '(SIGNED-BYTE 99))) => T
374 ;;; (TYPE-ENUMERABLE (SPECIFIER-TYPE '(COMPLEX (SIGNED-BYTE 99)))) => T
375 ;;; but, in contrast,
376 ;;; (TYPE-ENUMERABLE (SPECIFIER-TYPE '(EQL 5))) => NIL.
377 ;;; I can't figure out whether this is supposed to matter.
378 ;;; Moreover, it seems like this function should be responsible
379 ;;; for figuring out the right value so that callers don't have to.
380 (defun make-numeric-type (&key class format
(complexp :real
) low high
382 ;; if interval is empty
385 (if (or (consp low
) (consp high
)) ; if either bound is exclusive
386 (>= (type-bound-number low
) (type-bound-number high
))
389 (multiple-value-bind (low high
)
392 ;; INTEGER types always have their LOW and HIGH bounds
393 ;; represented as inclusive, not exclusive values.
394 (values (if (consp low
) (1+ (type-bound-number low
)) low
)
395 (if (consp high
) (1- (type-bound-number high
)) high
)))
397 ;; no canonicalization necessary
399 (when (and (eq class
'rational
)
403 (setf class
'integer
))
405 ;; Either lookup the canonical interned object for
406 ;; a point in the type lattice, or construct a new one.
407 (or (cond ((eq class
'float
)
408 (when (and (null low
) (null high
))
412 (:real
*real-ffloat-type
*)
413 (:complex
*complex-ffloat-type
*)))
416 (:real
*real-dfloat-type
*)
417 (:complex
*complex-dfloat-type
*))))))
418 ((and (eq class
'integer
) (eq complexp
:real
))
419 (flet ((n-bits () (integer-length (truly-the word high
))))
420 (declare (inline n-bits
))
422 (cond ((eql low
0) *unsigned-byte-type
*)
423 ((not low
) *integer-type
*)))
424 ((or (= high most-positive-word
)
425 (and (typep high
'word
)
426 ;; is (1+ high) a power-of-2 ?
427 (zerop (logand (1+ high
) high
))))
429 (svref *unsigned-byte-n-types
* (n-bits)))
430 ((and (< high most-positive-word
)
431 (eql low
(lognot high
)))
432 (svref *signed-byte-n-types
* (n-bits)))))))))
434 (%make-numeric-type
:class class
439 :enumerable enumerable
)))
440 (setf (type-hash-value result
)
441 (logior (type-hash-value result
)
442 +type-admits-type
=-optimization
+))
445 (defun modified-numeric-type (base
447 (class (numeric-type-class base
))
448 (format (numeric-type-format base
))
449 (complexp (numeric-type-complexp base
))
450 (low (numeric-type-low base
))
451 (high (numeric-type-high base
))
452 (enumerable (type-enumerable base
)))
453 (make-numeric-type :class class
458 :enumerable enumerable
))
460 (defstruct (character-set-type
462 (class-info (type-class-or-lose 'character-set
)))
463 (:constructor %make-character-set-type
(pairs))
465 (pairs (missing-arg) :type list
:read-only t
))
467 ;; Interned character-set types.
468 (defglobal *character-type
* -
1)
470 (progn (defglobal *base-char-type
* -
1)
471 (defglobal *extended-char-type
* -
1))
472 #+sb-xc
(declaim (type ctype
*character-type
*
473 #!+sb-unicode
*base-char-type
*
474 #!+sb-unicode
*extended-char-type
*))
476 (defun !intern-important-character-set-type-instances
()
477 (flet ((range (low high
)
479 (%make-character-set-type
(list (cons low high
))))))
480 (setq *character-type
* (range 0 (1- sb
!xc
:char-code-limit
)))
482 (setq *base-char-type
* (range 0 127)
483 *extended-char-type
* (range 128 (1- sb
!xc
:char-code-limit
)))))
485 (defun make-character-set-type (&key pairs
)
486 ; (aver (equal (mapcar #'car pairs)
487 ; (sort (mapcar #'car pairs) #'<)))
488 ;; aver that the cars of the list elements are sorted into increasing order
489 (aver (or (null pairs
)
490 (do ((p pairs
(cdr p
)))
492 (when (> (caar p
) (caadr p
)) (return nil
)))))
493 (let ((pairs (let (result)
494 (do ((pairs pairs
(cdr pairs
)))
495 ((null pairs
) (nreverse result
))
496 (destructuring-bind (low . high
) (car pairs
)
497 (loop for
(low1 . high1
) in
(cdr pairs
)
498 if
(<= low1
(1+ high
))
499 do
(progn (setf high
(max high high1
))
500 (setf pairs
(cdr pairs
)))
501 else do
(return nil
))
503 ((>= low sb
!xc
:char-code-limit
))
505 (t (push (cons (max 0 low
)
506 (min high
(1- sb
!xc
:char-code-limit
)))
510 (or (and (singleton-p pairs
)
511 (let* ((pair (car pairs
))
513 (case (cdr pair
) ; high
514 (#.
(1- sb
!xc
:char-code-limit
)
517 #!+sb-unicode
(128 *extended-char-type
*)))
519 (127 (if (eql low
0) *base-char-type
*)))))
520 (%make-character-set-type pairs
)))))
522 ;;; An ARRAY-TYPE is used to represent any array type, including
523 ;;; things such as SIMPLE-BASE-STRING.
524 (defstruct (array-type (:include ctype
525 (class-info (type-class-or-lose 'array
)))
526 (:constructor %make-array-type
527 (dimensions complexp element-type
528 specialized-element-type
))
530 ;; the dimensions of the array, or * if unspecified. If a dimension
531 ;; is unspecified, it is *.
532 (dimensions '* :type
(or list
(member *)) :read-only t
)
533 ;; Is this not a simple array type? (:MAYBE means that we don't know.)
534 (complexp :maybe
:type
(member t nil
:maybe
) :read-only t
)
535 ;; the element type as originally specified
536 (element-type (missing-arg) :type ctype
:read-only t
)
537 ;; the element type as it is specialized in this implementation
538 (specialized-element-type *wild-type
* :type ctype
:read-only t
))
540 ;; For all ctypes which are the element types of specialized arrays,
541 ;; 3 ctype objects are stored for the rank-1 arrays of that specialization,
542 ;; one for each of simple, maybe simple, and not simple.
543 ;; It would also be reasonable to intern (ARRAY <type> *).
544 (defglobal *rank-1-array-ctypes
* -
1)
545 (defconstant +canon-array-ctype-hash-divisor
+ 37) ; arbitrary-ish
546 (defun !intern-important-array-type-instances
()
547 ;; Having made the canonical numeric and character ctypes
548 ;; representing the points in the type lattice for which there
549 ;; are array specializations, we can make the canonical array types.
550 (let* ((element-types
552 *universal-type
* *wild-type
* *empty-type
*
554 #!+sb-unicode
*base-char-type
* #!+sb-unicode
*extended-char-type
*
555 *real-ffloat-type
* *complex-ffloat-type
*
556 *real-dfloat-type
* *complex-dfloat-type
*
559 ;; Possibly could use the SAETP-IMPORTANCE as sort criterion
560 ;; so that collisions in a bucket place the more important
564 (cond ((typep x
'(cons (eql unsigned-byte
)))
565 (aref *unsigned-byte-n-types
* (cadr x
)))
567 (aref *unsigned-byte-n-types
* 1))
568 ((typep x
'(cons (eql signed-byte
)))
569 ;; 1- because there is no such thing as (signed-byte 0)
570 (aref *signed-byte-n-types
* (1- (cadr x
))))
571 ;; FIXNUM is its own thing, why? See comment in vm-array
572 ;; saying to "See the comment in PRIMITIVE-TYPE-AUX"
573 ((eq x
'fixnum
) ; One good kludge deserves another.
574 (aref *signed-byte-n-types
* (1- sb
!vm
:n-fixnum-bits
)))))
575 '#.
*specialized-array-element-types
*))))
576 (n (length element-types
))
577 (data-vector (make-array (* 3 n
)))
579 (hashtable (make-array +canon-array-ctype-hash-divisor
+
580 :initial-element nil
)))
581 ;; This is a compact binned table. A full-blown hashtable is unneeded.
582 #-sb-xc
(aver (< (/ n
(length hashtable
)) 80/100)) ; assert reasonable load
583 (flet ((make-it (complexp type
)
584 (mark-ctype-interned (%make-array-type
'(*) complexp type type
))))
585 (dolist (element-type element-types
)
586 (let ((bin (mod (type-hash-value element-type
)
587 +canon-array-ctype-hash-divisor
+)))
588 (setf (aref hashtable bin
)
589 (nconc (aref hashtable bin
) (list (cons element-type index
))))
590 (setf (aref data-vector
(+ index
0)) (make-it nil element-type
)
591 (aref data-vector
(+ index
1)) (make-it :maybe element-type
)
592 (aref data-vector
(+ index
2)) (make-it t element-type
))
594 (setq *rank-1-array-ctypes
* (cons data-vector hashtable
))))
596 (declaim (ftype (sfunction (t &key
(:complexp t
)
598 (:specialized-element-type t
))
599 ctype
) make-array-type
))
600 (defun make-array-type (dimensions &key
(complexp :maybe
) element-type
601 (specialized-element-type *wild-type
*))
602 (or (and (eq element-type specialized-element-type
)
603 (singleton-p dimensions
)
604 (eq (first dimensions
) '*)
605 (let ((table *rank-1-array-ctypes
*))
606 (dolist (cell (svref (cdr table
)
607 (mod (type-hash-value element-type
)
608 +canon-array-ctype-hash-divisor
+)))
609 (when (eq (car cell
) element-type
)
610 (return (truly-the ctype
614 ((nil) 0) ((:maybe
) 1) ((t) 2))))))))))
615 (%make-array-type dimensions
616 complexp element-type specialized-element-type
)))
618 ;;; A MEMBER-TYPE represent a use of the MEMBER type specifier. We
619 ;;; bother with this at this level because MEMBER types are fairly
620 ;;; important and union and intersection are well defined.
621 (defstruct (member-type (:include ctype
622 (class-info (type-class-or-lose 'member
)))
624 (:constructor %make-member-type
(xset fp-zeroes
))
625 #-sb-xc-host
(:pure nil
))
626 (xset (missing-arg) :type xset
:read-only t
)
627 (fp-zeroes (missing-arg) :type list
:read-only t
))
629 (defglobal *null-type
* -
1) ; = (MEMBER NIL)
630 (defglobal *eql-t-type
* -
1) ; = (MEMBER T)
631 (defglobal *boolean-type
* -
1) ; = (MEMBER T NIL)
632 #+sb-xc
(declaim (type ctype
*null-type
*))
634 (defun !intern-important-member-type-instances
()
635 (flet ((make-it (list)
637 (%make-member-type
(xset-from-list list
) nil
))))
638 (setf *null-type
* (make-it '(nil))
639 *eql-t-type
* (make-it '(t))
640 *boolean-type
* (make-it '(t nil
)))))
642 (declaim (ftype (sfunction (&key
(:xset t
) (:fp-zeroes t
) (:members t
)) ctype
)
644 (defun make-member-type (&key xset fp-zeroes members
)
646 (aver (not fp-zeroes
))
647 (setf xset
(alloc-xset))
648 (dolist (elt members
)
650 (pushnew elt fp-zeroes
)
651 (add-to-xset elt xset
))))
652 ;; if we have a pair of zeros (e.g. 0.0d0 and -0.0d0), then we can
653 ;; canonicalize to (DOUBLE-FLOAT 0.0d0 0.0d0), because numeric
654 ;; ranges are compared by arithmetic operators (while MEMBERship is
655 ;; compared by EQL). -- CSR, 2003-04-23
659 (when fp-zeroes
; avoid doing two passes of nothing
661 (dolist (z fp-zeroes
)
662 (let ((sign (if (minusp (nth-value 2 (integer-decode-float z
))) 1 0))
667 #!+long-float
(long-float 4)))))
669 (setf (ldb (byte 1 (+ pair-idx sign
)) presence
) 1)
670 (if (= (ldb (byte 2 pair-idx
) presence
) #b11
)
672 (push (ctype-of z
) float-types
))
673 (push z unpaired
)))))))
677 (when (singleton-p (xset-data xset
))
678 (case (first (xset-data xset
))
679 ((nil) (return *null-type
*))
680 ((t) (return *eql-t-type
*))))
681 ;; Semantically this is fine - XSETs
682 ;; are not order-preserving except by accident
683 ;; (when not represented as a hash-table).
684 (when (or (equal (xset-data xset
) '(t nil
))
685 (equal (xset-data xset
) '(nil t
)))
686 (return *boolean-type
*)))
687 (when (or unpaired
(not (xset-empty-p xset
)))
688 (let ((result (%make-member-type xset unpaired
)))
689 (setf (type-hash-value result
)
690 (logior (type-hash-value result
)
691 +type-admits-type
=-optimization
+))
693 ;; The actual member-type contains the XSET (with no FP zeroes),
694 ;; and a list of unpaired zeroes.
696 (make-union-type t
(if member-type
697 (cons member-type float-types
)
699 (or member-type
*empty-type
*)))))
701 (defun member-type-size (type)
702 (+ (length (member-type-fp-zeroes type
))
703 (xset-count (member-type-xset type
))))
705 (defun member-type-member-p (x type
)
707 (and (member x
(member-type-fp-zeroes type
)) t
)
708 (xset-member-p x
(member-type-xset type
))))
710 (defun mapcar-member-type-members (function type
)
711 (declare (function function
))
713 (map-xset (lambda (x)
714 (results (funcall function x
)))
715 (member-type-xset type
))
716 (dolist (zero (member-type-fp-zeroes type
))
717 (results (funcall function zero
)))
720 (defun mapc-member-type-members (function type
)
721 (declare (function function
))
722 (map-xset function
(member-type-xset type
))
723 (dolist (zero (member-type-fp-zeroes type
))
724 (funcall function zero
)))
726 (defun member-type-members (type)
727 (append (member-type-fp-zeroes type
)
728 (xset-members (member-type-xset type
))))
730 ;;; A COMPOUND-TYPE is a type defined out of a set of types, the
731 ;;; common parent of UNION-TYPE and INTERSECTION-TYPE.
732 (defstruct (compound-type (:include ctype
)
735 ;; Formerly defined in every CTYPE, but now just in the ones
736 ;; for which enumerability is variable.
737 (enumerable nil
:read-only t
)
738 (types nil
:type list
:read-only t
))
740 ;;; A UNION-TYPE represents a use of the OR type specifier which we
741 ;;; couldn't canonicalize to something simpler. Canonical form:
742 ;;; 1. All possible pairwise simplifications (using the UNION2 type
743 ;;; methods) have been performed. Thus e.g. there is never more
744 ;;; than one MEMBER-TYPE component. FIXME: As of sbcl-0.6.11.13,
745 ;;; this hadn't been fully implemented yet.
746 ;;; 2. There are never any UNION-TYPE components.
748 ;;; TODO: As STRING is an especially important union type,
749 ;;; it could be interned by canonicalizing its subparts into
750 ;;; ARRAY of {CHARACTER,BASE-CHAR,NIL} in that exact order always.
751 ;;; It will therefore admit quick TYPE=, but not quick failure, since
752 ;;; (type= (specifier-type '(or (simple-array (member #\a) (*))
753 ;;; (simple-array character (*))
754 ;;; (simple-array nil (*))))
755 ;;; (specifier-type 'simple-string)) => T and T
756 ;;; even though (MEMBER #\A) is not TYPE= to BASE-CHAR.
758 (defstruct (union-type (:include compound-type
759 (class-info (type-class-or-lose 'union
)))
760 (:constructor make-union-type
(enumerable types
))
763 ;;; An INTERSECTION-TYPE represents a use of the AND type specifier
764 ;;; which we couldn't canonicalize to something simpler. Canonical form:
765 ;;; 1. All possible pairwise simplifications (using the INTERSECTION2
766 ;;; type methods) have been performed. Thus e.g. there is never more
767 ;;; than one MEMBER-TYPE component.
768 ;;; 2. There are never any INTERSECTION-TYPE components: we've
769 ;;; flattened everything into a single INTERSECTION-TYPE object.
770 ;;; 3. There are never any UNION-TYPE components. Either we should
771 ;;; use the distributive rule to rearrange things so that
772 ;;; unions contain intersections and not vice versa, or we
773 ;;; should just punt to using a HAIRY-TYPE.
774 (defstruct (intersection-type (:include compound-type
775 (class-info (type-class-or-lose
777 (:constructor %make-intersection-type
781 ;;; Return TYPE converted to canonical form for a situation where the
782 ;;; "type" '* (which SBCL still represents as a type even though ANSI
783 ;;; CL defines it as a related but different kind of placeholder) is
784 ;;; equivalent to type T.
785 (defun type-*-to-t
(type)
786 (if (type= type
*wild-type
*)
790 ;;; A CONS-TYPE is used to represent a CONS type.
791 (defstruct (cons-type (:include ctype
(class-info (type-class-or-lose 'cons
)))
793 %make-cons-type
(car-type
796 ;; the CAR and CDR element types (to support ANSI (CONS FOO BAR) types)
797 (car-type (missing-arg) :type ctype
:read-only t
)
798 (cdr-type (missing-arg) :type ctype
:read-only t
))
800 ;; The function caches work significantly better when there
801 ;; is a unique object that stands for the specifier (CONS T T).
802 (defglobal *cons-t-t-type
* -
1)
803 #+sb-xc
(declaim (type ctype
*cons-t-t-type
*))
805 (defun !intern-important-cons-type-instances
()
806 (setf *cons-t-t-type
*
808 (%make-cons-type
*universal-type
* *universal-type
*))))
811 (declaim (ftype (sfunction (ctype ctype
) (values t t
)) type
=))
812 (defun make-cons-type (car-type cdr-type
)
813 (aver (not (or (eq car-type
*wild-type
*)
814 (eq cdr-type
*wild-type
*))))
815 (cond ((or (eq car-type
*empty-type
*)
816 (eq cdr-type
*empty-type
*))
818 ;; It's not a requirement that (CONS T T) be interned,
819 ;; but it improves the hit rate in the function caches.
820 ((and (type= car-type
*universal-type
*)
821 (type= cdr-type
*universal-type
*))
824 (%make-cons-type car-type cdr-type
))))
826 ;;; A SIMD-PACK-TYPE is used to represent a SIMD-PACK type.
828 (defstruct (simd-pack-type
829 (:include ctype
(class-info (type-class-or-lose 'simd-pack
)))
830 (:constructor %make-simd-pack-type
(element-type))
832 (element-type (missing-arg)
833 :type
(cons #||
(member #.
*simd-pack-element-types
*) ||
#)
837 (defun make-simd-pack-type (element-type)
838 (aver (neq element-type
*wild-type
*))
839 (if (eq element-type
*empty-type
*)
841 (%make-simd-pack-type
842 (dolist (pack-type *simd-pack-element-types
*
843 (error "~S element type must be a subtype of ~
844 ~{~S~#[~;, or ~:;, ~]~}."
845 'simd-pack
*simd-pack-element-types
*))
846 (when (csubtypep element-type
(specifier-type pack-type
))
847 (return (list pack-type
)))))))
852 ;;; Return the type structure corresponding to a type specifier. We
853 ;;; pick off structure types as a special case.
855 ;;; Note: VALUES-SPECIFIER-TYPE-CACHE-CLEAR must be called whenever a
856 ;;; type is defined (or redefined).
857 ;;; This cache is sized extremely generously, which has payoff
858 ;;; elsewhere: it improves the TYPE= and CSUBTYPEP functions,
859 ;;; since EQ types are an immediate win.
861 ;;; KLUDGE: why isn't this a MACROLET? "lexical environment too
863 (defmacro !values-specifier-type-body
(arg)
864 `(let* ((u (uncross ,arg
))
866 (result (or (info :type
:builtin u
)
867 (let ((spec (typexpand u
)))
868 (when (and (symbolp u
) (deprecated-thing-p 'type u
))
870 (signal 'parse-deprecated-type
:specifier u
))
872 ((and (not (eq spec u
))
873 (info :type
:builtin spec
)))
874 ((and (consp spec
) (symbolp (car spec
))
875 (info :type
:builtin
(car spec
))
876 (let ((expander (info :type
:expander
(car spec
))))
877 (and expander
(values-specifier-type (funcall expander spec
))))))
878 ((eq (info :type
:kind spec
) :instance
)
879 (find-classoid spec
))
880 ((typep spec
'classoid
)
881 (if (typep spec
'built-in-classoid
)
882 (or (built-in-classoid-translation spec
) spec
)
885 (when (and (atom spec
)
886 (member spec
'(and or not member eql satisfies values
)))
887 (error "The symbol ~S is not valid as a type specifier." spec
))
889 (info :type
:translator
(if (consp spec
) (car spec
) spec
))))
890 (cond ((functionp fun-or-ctype
)
891 (funcall fun-or-ctype
(ensure-list spec
)))
893 ((or (and (consp spec
) (symbolp (car spec
))
894 (not (info :type
:builtin
(car spec
))))
895 (and (symbolp spec
) (not (info :type
:builtin spec
))))
896 (when (and *type-system-initialized
*
897 (not (eq (info :type
:kind spec
)
898 :forthcoming-defclass-type
)))
899 (signal 'parse-unknown-type
:specifier spec
))
901 (make-unknown-type :specifier spec
))
903 (error "bad thing to be a type specifier: ~S"
907 ;; (The RETURN-FROM here inhibits caching; this does not only
908 ;; make sense from a compiler diagnostics point of view but
909 ;; is also indispensable for proper workingness of
910 ;; VALID-TYPE-SPECIFIER-P.)
911 (return-from values-specifier-type
914 (let ((table (make-hash-table :test
'equal
)))
915 (defun values-specifier-type (specifier)
916 (multiple-value-bind (type yesp
) (gethash specifier table
)
919 (setf (gethash specifier table
)
920 (!values-specifier-type-body specifier
)))))
921 (defun values-specifier-type-cache-clear ()
924 (defun-cached (values-specifier-type
925 :hash-function
#'sxhash
:hash-bits
10)
926 ((orig equal-but-no-car-recursion
))
927 (!values-specifier-type-body orig
))
929 ;;; This is like VALUES-SPECIFIER-TYPE, except that we guarantee to
930 ;;; never return a VALUES type.
931 (defun specifier-type (type-specifier)
932 (let ((ctype (values-specifier-type type-specifier
)))
933 (when (or (values-type-p ctype
)
934 ;; bootstrap magic :-(
935 (and (named-type-p ctype
)
936 (eq (named-type-name ctype
) '*)))
937 (error "VALUES type illegal in this context:~% ~S" type-specifier
))
940 (defun single-value-specifier-type (x)
945 (defun typexpand-1 (type-specifier &optional env
)
947 "Takes and expands a type specifier once like MACROEXPAND-1.
948 Returns two values: the expansion, and a boolean that is true when
950 (declare (type type-specifier type-specifier
))
951 (declare (ignore env
))
952 (let* ((spec type-specifier
)
953 (atom (if (listp spec
) (car spec
) spec
))
954 (expander (and (symbolp atom
) (info :type
:expander atom
))))
955 ;; We do not expand builtins even though it'd be
956 ;; possible to do so sometimes (e.g. STRING) for two
959 ;; a) From a user's point of view, CL types are opaque.
961 ;; b) so (EQUAL (TYPEXPAND 'STRING) (TYPEXPAND-ALL 'STRING))
962 (if (and expander
(not (info :type
:builtin atom
)))
963 (values (funcall expander
(if (symbolp spec
) (list spec
) spec
)) t
)
964 (values type-specifier nil
))))
966 (defun typexpand (type-specifier &optional env
)
968 "Takes and expands a type specifier repeatedly like MACROEXPAND.
969 Returns two values: the expansion, and a boolean that is true when
971 (declare (type type-specifier type-specifier
))
972 (multiple-value-bind (expansion flag
)
973 (typexpand-1 type-specifier env
)
975 (values (typexpand expansion env
) t
)
976 (values expansion flag
))))
978 ;;; Note that the type NAME has been (re)defined, updating the
979 ;;; undefined warnings and VALUES-SPECIFIER-TYPE cache.
980 (defun %note-type-defined
(name)
981 (declare (symbol name
))
982 (note-name-defined name
:type
)
983 (values-specifier-type-cache-clear)
987 (!defun-from-collected-cold-init-forms
!early-type-cold-init
)