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 ;; CONTEXT is the cookie passed down from the outermost surrounding call
128 ;; of VALUES-SPECIFIER-TYPE. INNER-CONTEXT-KIND is an indicator of whether
129 ;; we are currently parsing a FUNCTION or a VALUES compound type specifier.
130 (defun parse-args-types (context lambda-listy-thing inner-context-kind
)
131 (multiple-value-bind (llks required optional rest keys
)
134 :context inner-context-kind
135 :accept
(ecase inner-context-kind
136 (:values-type
(lambda-list-keyword-mask '(&optional
&rest
)))
137 (:function-type
(lambda-list-keyword-mask
138 '(&optional
&rest
&key
&allow-other-keys
))))
140 (flet ((parse-list (list)
141 (mapcar (lambda (x) (single-value-specifier-type-r context x
))
143 (let ((required (parse-list required
))
144 (optional (parse-list optional
))
145 (rest (when rest
(single-value-specifier-type-r context
(car rest
))))
147 (collect ((key-info))
149 (unless (proper-list-of-length-p key
2)
150 (error "Keyword type description is not a two-list: ~S." key
))
151 (let ((kwd (first key
)))
152 (when (find kwd
(key-info) :key
#'key-info-name
)
153 (error "~@<repeated keyword ~S in lambda list: ~2I~_~S~:>"
154 kwd lambda-listy-thing
))
157 ;; MAKE-KEY-INFO will complain if KWD is not a symbol.
158 ;; That's good enough - we don't need an extra check here.
160 :type
(single-value-specifier-type-r context
(second key
))))))
162 (multiple-value-bind (required optional rest
)
163 (canonicalize-args-type-args required optional rest
165 (values llks required optional rest keywords
))))))
167 (defstruct (values-type
169 (class-info (type-class-or-lose 'values
)))
170 (:constructor %make-values-type
)
171 (:predicate %values-type-p
)
174 (declaim (inline values-type-p
))
175 (defun values-type-p (x)
176 (or (eq x
*wild-type
*)
179 (defun-cached (make-values-type-cached
182 (lambda (req opt rest allowp
)
183 (logxor (type-list-cache-hash req
)
184 (type-list-cache-hash opt
)
186 (type-hash-value rest
)
188 ;; Results (logand #xFF (sxhash t/nil))
189 ;; hardcoded to avoid relying on the xc host.
190 ;; [but (logand (sxhash nil) #xff) => 2
191 ;; for me, so the code and comment disagree,
192 ;; but not in a way that matters.]
196 ((required equal-but-no-car-recursion
)
197 (optional equal-but-no-car-recursion
)
200 (%make-values-type
:required required
205 (defun make-values-type (&key required optional rest allowp
)
206 (multiple-value-bind (required optional rest
)
207 (canonicalize-args-type-args required optional rest
)
208 (cond ((and (null required
)
210 (eq rest
*universal-type
*))
212 ((memq *empty-type
* required
)
214 (t (make-values-type-cached required optional
217 (!define-type-class values
:enumerable nil
218 :might-contain-other-types nil
)
220 ;;; (SPECIFIER-TYPE 'FUNCTION) and its subtypes
221 (defstruct (fun-type (:include args-type
222 (class-info (type-class-or-lose 'function
)))
224 %make-fun-type
(required optional rest
225 keyp keywords allowp wild-args returns
)))
226 ;; true if the arguments are unrestrictive, i.e. *
227 (wild-args nil
:type boolean
:read-only t
)
228 ;; type describing the return values. This is a values type
229 ;; when multiple values were specified for the return.
230 (returns (missing-arg) :type ctype
:read-only t
))
232 ;; Without this canonicalization step, I found >350 different
233 ;; (FUNCTION (T) *) representations in a sample build.
234 (declaim (type (simple-vector 4) *interned-fun-type-instances
*))
235 (defglobal *interned-fun-types
* (make-array 4))
236 (defun !intern-important-fun-type-instances
()
237 (setq *interned-fun-types
* (make-array 4))
241 (push *universal-type
* required
))
242 (setf (svref *interned-fun-types
* i
)
244 (%make-fun-type required nil nil nil nil nil nil
*wild-type
*))))))
246 (defun make-fun-type (&key required optional rest
249 (let ((rest (if (eq rest
*empty-type
*) nil rest
))
250 (n (length required
)))
252 (not optional
) (not rest
) (not keyp
)
253 (not keywords
) (not allowp
) (not wild-args
)
254 (eq returns
*wild-type
*)
255 (every (lambda (x) (eq x
*universal-type
*)) required
))
256 (svref *interned-fun-types
* n
)
257 (%make-fun-type required optional rest keyp keywords
258 allowp wild-args returns
))))
260 ;;; The CONSTANT-TYPE structure represents a use of the CONSTANT-ARG
261 ;;; "type specifier", which is only meaningful in function argument
262 ;;; type specifiers used within the compiler. (It represents something
263 ;;; that the compiler knows to be a constant.)
264 (defstruct (constant-type
266 (class-info (type-class-or-lose 'constant
)))
268 ;; The type which the argument must be a constant instance of for this type
270 (type (missing-arg) :type ctype
:read-only t
))
272 ;;; The NAMED-TYPE is used to represent *, T and NIL, the standard
273 ;;; special cases, as well as other special cases needed to
274 ;;; interpolate between regions of the type hierarchy, such as
275 ;;; INSTANCE (which corresponds to all those classes with slots which
276 ;;; are not funcallable), FUNCALLABLE-INSTANCE (those classes with
277 ;;; slots which are funcallable) and EXTENDED-SEQUUENCE (non-LIST
278 ;;; non-VECTOR classes which are also sequences). These special cases
279 ;;; are the ones that aren't really discussed by Baker in his
280 ;;; "Decision Procedure for SUBTYPEP" paper.
281 (defstruct (named-type (:include ctype
282 (class-info (type-class-or-lose 'named
)))
284 (name nil
:type symbol
:read-only t
))
286 ;;; a list of all the float "formats" (i.e. internal representations;
287 ;;; nothing to do with #'FORMAT), in order of decreasing precision
288 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
289 (defparameter *float-formats
*
290 '(long-float double-float single-float short-float
)))
292 ;;; The type of a float format.
293 (deftype float-format
() `(member ,@*float-formats
*))
295 ;;; A NUMERIC-TYPE represents any numeric type, including things
297 (defstruct (numeric-type (:include ctype
298 (class-info (type-class-or-lose 'number
)))
299 (:constructor %make-numeric-type
)
301 ;; Formerly defined in every CTYPE, but now just in the ones
302 ;; for which enumerability is variable.
303 (enumerable nil
:read-only t
)
304 ;; the kind of numeric type we have, or NIL if not specified (just
305 ;; NUMBER or COMPLEX)
307 ;; KLUDGE: A slot named CLASS for a non-CLASS value is bad.
308 ;; Especially when a CLASS value *is* stored in another slot (called
309 ;; CLASS-INFO:-). Perhaps this should be called CLASS-NAME? Also
310 ;; weird that comment above says "Numeric-Type is used to represent
311 ;; all numeric types" but this slot doesn't allow COMPLEX as an
312 ;; option.. how does this fall into "not specified" NIL case above?
313 ;; Perhaps someday we can switch to CLOS and make NUMERIC-TYPE
314 ;; be an abstract base class and INTEGER-TYPE, RATIONAL-TYPE, and
315 ;; whatnot be concrete subclasses..
316 (class nil
:type
(member integer rational float nil
) :read-only t
)
317 ;; "format" for a float type (i.e. type specifier for a CPU
318 ;; representation of floating point, e.g. 'SINGLE-FLOAT -- nothing
319 ;; to do with #'FORMAT), or NIL if not specified or not a float.
320 ;; Formats which don't exist in a given implementation don't appear
322 (format nil
:type
(or float-format null
) :read-only t
)
323 ;; Is this a complex numeric type? Null if unknown (only in NUMBER).
325 ;; FIXME: I'm bewildered by FOO-P names for things not intended to
326 ;; interpreted as truth values. Perhaps rename this COMPLEXNESS?
327 (complexp :real
:type
(member :real
:complex nil
) :read-only t
)
328 ;; The upper and lower bounds on the value, or NIL if there is no
329 ;; bound. If a list of a number, the bound is exclusive. Integer
330 ;; types never have exclusive bounds, i.e. they may have them on
331 ;; input, but they're canonicalized to inclusive bounds before we
333 (low nil
:type
(or number cons null
) :read-only t
)
334 (high nil
:type
(or number cons null
) :read-only t
))
336 ;; For some numeric subtypes, uniqueness of the object representation
337 ;; is enforced. These encompass all array specializations and more.
338 (defglobal *unsigned-byte-type
* -
1)
339 (defglobal *integer-type
* -
1)
340 (defglobal *index-type
* -
1)
341 ;; BIGNUM is not an interned type because union types aren't interned,
342 ;; though some of the important ones probably ought to be.
343 (defglobal *positive-bignum-type
* -
1)
344 (defglobal *negative-bignum-type
* -
1)
345 (defglobal *rational-type
* -
1)
346 (defglobal *unsigned-byte-n-types
* -
1)
347 (defglobal *signed-byte-n-types
* -
1)
348 (defglobal *real-ffloat-type
* -
1)
349 (defglobal *real-dfloat-type
* -
1)
350 (defglobal *complex-ffloat-type
* -
1)
351 (defglobal *complex-dfloat-type
* -
1)
353 (declaim (type (simple-vector #.
(1+ sb
!vm
:n-word-bits
)) *unsigned-byte-n-types
*)
354 (type (simple-vector #.sb
!vm
:n-word-bits
) *signed-byte-n-types
*))
356 ;; Called after NUMBER-TYPE type-class has been made.
357 (defun !intern-important-numeric-type-instances
()
358 (flet ((float-type (format complexp
)
360 (%make-numeric-type
:class
'float
:complexp complexp
361 :format format
:enumerable nil
)))
362 (int-type (enumerable low high
)
364 (%make-numeric-type
:class
'integer
:complexp
:real
365 :enumerable enumerable
366 :low low
:high high
))))
367 (setq *real-ffloat-type
* (float-type 'single-float
:real
)
368 *real-dfloat-type
* (float-type 'double-float
:real
)
369 *complex-ffloat-type
* (float-type 'single-float
:complex
)
370 *complex-dfloat-type
* (float-type 'double-float
:complex
)
371 *rational-type
* (mark-ctype-interned
372 (%make-numeric-type
:class
'rational
))
373 *unsigned-byte-type
* (int-type nil
0 nil
)
374 *integer-type
* (int-type nil nil nil
)
375 *index-type
* (int-type nil
0 (1- sb
!xc
:array-dimension-limit
))
376 *negative-bignum-type
* (int-type nil nil
(1- sb
!xc
:most-negative-fixnum
))
377 *positive-bignum-type
* (int-type nil
(1+ sb
!xc
:most-positive-fixnum
) nil
)
378 *unsigned-byte-n-types
* (make-array (1+ sb
!vm
:n-word-bits
))
379 *signed-byte-n-types
* (make-array sb
!vm
:n-word-bits
))
380 (dotimes (j (1+ sb
!vm
:n-word-bits
))
381 (setf (svref *unsigned-byte-n-types
* j
) (int-type t
0 (1- (ash 1 j
)))))
382 (dotimes (j sb
!vm
:n-word-bits
)
383 (setf (svref *signed-byte-n-types
* j
)
384 (let ((high (1- (ash 1 j
)))) (int-type t
(- (1+ high
)) high
))))))
386 ;;; Impose canonicalization rules for NUMERIC-TYPE. Note that in some
387 ;;; cases, despite the name, we return *EMPTY-TYPE* instead of a
389 ;;; FIXME: The ENUMERABLE flag is unexpectedly NIL for types that
390 ;;; come from parsing MEMBER. But bounded integer ranges,
391 ;;; however large, are enumerable:
392 ;;; (TYPE-ENUMERABLE (SPECIFIER-TYPE '(SIGNED-BYTE 99))) => T
393 ;;; (TYPE-ENUMERABLE (SPECIFIER-TYPE '(COMPLEX (SIGNED-BYTE 99)))) => T
394 ;;; but, in contrast,
395 ;;; (TYPE-ENUMERABLE (SPECIFIER-TYPE '(EQL 5))) => NIL.
396 ;;; I can't figure out whether this is supposed to matter.
397 ;;; Moreover, it seems like this function should be responsible
398 ;;; for figuring out the right value so that callers don't have to.
399 (defun make-numeric-type (&key class format
(complexp :real
) low high
401 ;; if interval is empty
404 (if (or (consp low
) (consp high
)) ; if either bound is exclusive
405 (>= (type-bound-number low
) (type-bound-number high
))
408 (multiple-value-bind (low high
)
411 ;; INTEGER types always have their LOW and HIGH bounds
412 ;; represented as inclusive, not exclusive values.
413 (values (if (consp low
) (1+ (type-bound-number low
)) low
)
414 (if (consp high
) (1- (type-bound-number high
)) high
)))
416 ;; no canonicalization necessary
418 (when (and (eq class
'rational
)
422 (setf class
'integer
))
424 ;; Either lookup the canonical interned object for
425 ;; a point in the type lattice, or construct a new one.
426 (or (cond ((eq class
'float
)
427 (when (and (null low
) (null high
))
431 (:real
*real-ffloat-type
*)
432 (:complex
*complex-ffloat-type
*)))
435 (:real
*real-dfloat-type
*)
436 (:complex
*complex-dfloat-type
*))))))
437 ((and (eq class
'integer
) (eq complexp
:real
))
438 (flet ((n-bits () (integer-length (truly-the word high
))))
439 (declare (inline n-bits
))
441 (cond ((eql low
0) *unsigned-byte-type
*)
442 ((not low
) *integer-type
*)
443 ((eql low
(1+ sb
!xc
:most-positive-fixnum
))
444 *positive-bignum-type
*)))
445 ((or (= high most-positive-word
)
446 (and (typep high
'word
)
447 ;; is (1+ high) a power-of-2 ?
448 (zerop (logand (1+ high
) high
))))
450 (svref *unsigned-byte-n-types
* (n-bits)))
451 ((and (< high most-positive-word
)
452 (eql low
(lognot high
)))
453 (svref *signed-byte-n-types
* (n-bits)))))
455 (eql high
(1- sb
!xc
:array-dimension-limit
)))
458 (eql high
(1- sb
!xc
:most-negative-fixnum
)))
459 *negative-bignum-type
*))))
460 ((and (eq class
'rational
) (eq complexp
:real
)
461 (null low
) (eq high low
))
464 (%make-numeric-type
:class class
469 :enumerable enumerable
)))
470 (setf (type-hash-value result
)
471 (logior (type-hash-value result
)
472 +type-admits-type
=-optimization
+))
475 (defun modified-numeric-type (base
477 (class (numeric-type-class base
))
478 (format (numeric-type-format base
))
479 (complexp (numeric-type-complexp base
))
480 (low (numeric-type-low base
))
481 (high (numeric-type-high base
))
482 (enumerable (type-enumerable base
)))
483 (make-numeric-type :class class
488 :enumerable enumerable
))
490 ;; Interned character-set types.
491 (defglobal *character-type
* -
1)
493 (progn (defglobal *base-char-type
* -
1)
494 (defglobal *extended-char-type
* -
1))
495 #+sb-xc
(declaim (type ctype
*character-type
*
496 #!+sb-unicode
*base-char-type
*
497 #!+sb-unicode
*extended-char-type
*))
499 (defun !intern-important-character-set-type-instances
()
500 (flet ((range (low high
)
502 (%make-character-set-type
(list (cons low high
))))))
503 (setq *character-type
* (range 0 (1- sb
!xc
:char-code-limit
)))
505 (setq *base-char-type
* (range 0 127)
506 *extended-char-type
* (range 128 (1- sb
!xc
:char-code-limit
)))))
508 (defun make-character-set-type (&key pairs
)
509 ; (aver (equal (mapcar #'car pairs)
510 ; (sort (mapcar #'car pairs) #'<)))
511 ;; aver that the cars of the list elements are sorted into increasing order
512 (aver (or (null pairs
)
513 (do ((p pairs
(cdr p
)))
515 (when (> (caar p
) (caadr p
)) (return nil
)))))
516 (let ((pairs (let (result)
517 (do ((pairs pairs
(cdr pairs
)))
518 ((null pairs
) (nreverse result
))
519 (destructuring-bind (low . high
) (car pairs
)
520 (loop for
(low1 . high1
) in
(cdr pairs
)
521 if
(<= low1
(1+ high
))
522 do
(progn (setf high
(max high high1
))
523 (setf pairs
(cdr pairs
)))
524 else do
(return nil
))
526 ((>= low sb
!xc
:char-code-limit
))
528 (t (push (cons (max 0 low
)
529 (min high
(1- sb
!xc
:char-code-limit
)))
533 (or (and (singleton-p pairs
)
534 (let* ((pair (car pairs
))
536 (case (cdr pair
) ; high
537 (#.
(1- sb
!xc
:char-code-limit
)
540 #!+sb-unicode
(128 *extended-char-type
*)))
542 (127 (if (eql low
0) *base-char-type
*)))))
543 (%make-character-set-type pairs
)))))
545 ;; For all ctypes which are the element types of specialized arrays,
546 ;; 3 ctype objects are stored for the rank-1 arrays of that specialization,
547 ;; one for each of simple, maybe-simple, and non-simple (in that order),
548 ;; and 2 ctype objects for unknown-rank arrays, one each for simple
549 ;; and maybe-simple. (Unknown rank, known-non-simple isn't important)
550 (defglobal *canonical-array-ctypes
* -
1)
551 (defun !intern-important-array-type-instances
()
552 ;; Having made the canonical numeric and character ctypes
553 ;; representing the points in the type lattice for which there
554 ;; are array specializations, we can make the canonical array types.
555 (setq *canonical-array-ctypes
* (make-array (* 32 5)))
556 (labels ((make-1 (type-index dims complexp type
)
557 (setf (!ctype-saetp-index type
) type-index
)
558 (mark-ctype-interned (%make-array-type dims complexp type type
)))
559 (make-all (element-type type-index
)
560 (replace *canonical-array-ctypes
*
561 (list (make-1 type-index
'(*) nil element-type
)
562 (make-1 type-index
'(*) :maybe element-type
)
563 (make-1 type-index
'(*) t element-type
)
564 (make-1 type-index
'* nil element-type
)
565 (make-1 type-index
'* :maybe element-type
))
566 :start1
(* type-index
5))))
568 (dolist (x '#.
*specialized-array-element-types
*)
570 (cond ((typep x
'(cons (eql unsigned-byte
)))
571 (aref *unsigned-byte-n-types
* (cadr x
)))
572 ((eq x
'bit
) (aref *unsigned-byte-n-types
* 1))
573 ((typep x
'(cons (eql signed-byte
)))
574 ;; 1- because there is no such thing as (signed-byte 0)
575 (aref *signed-byte-n-types
* (1- (cadr x
))))
576 ;; FIXNUM is its own thing, why? See comment in vm-array
577 ;; saying to "See the comment in PRIMITIVE-TYPE-AUX"
578 ((eq x
'fixnum
) ; One good kludge deserves another.
579 (aref *signed-byte-n-types
* (1- sb
!vm
:n-fixnum-bits
)))
580 ((eq x
'single-float
) *real-ffloat-type
*)
581 ((eq x
'double-float
) *real-dfloat-type
*)
582 ((equal x
'(complex single-float
)) *complex-ffloat-type
*)
583 ((equal x
'(complex double-float
)) *complex-dfloat-type
*)
584 ((eq x
'character
) *character-type
*)
585 #!+sb-unicode
((eq x
'base-char
) *base-char-type
*)
586 ((eq x t
) *universal-type
*)
587 ((null x
) *empty-type
*))
590 ;; Index 31 is available to store *WILD-TYPE*
591 ;; because there are fewer than 32 array widetags.
593 (make-all *wild-type
* 31))))
595 (declaim (ftype (sfunction (t &key
(:complexp t
)
597 (:specialized-element-type t
))
598 ctype
) make-array-type
))
599 (defun make-array-type (dimensions &key
(complexp :maybe
) element-type
600 (specialized-element-type *wild-type
*))
601 (if (and (eq element-type specialized-element-type
)
602 (or (and (eq dimensions
'*) (neq complexp t
))
603 (typep dimensions
'(cons (eql *) null
))))
604 (let ((res (svref *canonical-array-ctypes
*
605 (+ (* (!ctype-saetp-index element-type
) 5)
606 (if (listp dimensions
) 0 3)
607 (ecase complexp
((nil) 0) ((:maybe
) 1) ((t) 2))))))
608 (aver (eq (array-type-element-type res
) element-type
))
610 (%make-array-type dimensions
611 complexp element-type specialized-element-type
)))
613 ;;; A MEMBER-TYPE represent a use of the MEMBER type specifier. We
614 ;;; bother with this at this level because MEMBER types are fairly
615 ;;; important and union and intersection are well defined.
616 (defstruct (member-type (:include ctype
617 (class-info (type-class-or-lose 'member
)))
619 (:constructor %make-member-type
(xset fp-zeroes
))
620 #-sb-xc-host
(:pure nil
))
621 (xset (missing-arg) :type xset
:read-only t
)
622 (fp-zeroes (missing-arg) :type list
:read-only t
))
624 (defglobal *null-type
* -
1) ; = (MEMBER NIL)
625 (defglobal *eql-t-type
* -
1) ; = (MEMBER T)
626 (defglobal *boolean-type
* -
1) ; = (MEMBER T NIL)
627 #+sb-xc
(declaim (type ctype
*null-type
*))
629 (defun !intern-important-member-type-instances
()
630 (flet ((make-it (list)
632 (%make-member-type
(xset-from-list list
) nil
))))
633 (setf *null-type
* (make-it '(nil))
634 *eql-t-type
* (make-it '(t))
635 *boolean-type
* (make-it '(t nil
)))))
637 (declaim (ftype (sfunction (xset list
) ctype
) make-member-type
))
638 (defun member-type-from-list (members)
639 (let ((xset (alloc-xset))
641 (dolist (elt members
(make-member-type xset fp-zeroes
))
643 (pushnew elt fp-zeroes
)
644 (add-to-xset elt xset
)))))
645 (defun make-eql-type (elt) (member-type-from-list (list elt
)))
646 ;; Return possibly a union of a MEMBER type and a NUMERIC type,
647 ;; or just one or the other, or *EMPTY-TYPE* depending on what's in the XSET
648 ;; and the FP-ZEROES. XSET should not contains characters or real numbers.
649 (defun make-member-type (xset fp-zeroes
)
650 ;; if we have a pair of zeros (e.g. 0.0d0 and -0.0d0), then we can
651 ;; canonicalize to (DOUBLE-FLOAT 0.0d0 0.0d0), because numeric
652 ;; ranges are compared by arithmetic operators (while MEMBERship is
653 ;; compared by EQL). -- CSR, 2003-04-23
657 (when fp-zeroes
; avoid doing two passes of nothing
659 (dolist (z fp-zeroes
)
660 (let ((sign (if (minusp (nth-value 2 (integer-decode-float z
))) 1 0))
665 #!+long-float
(long-float 4)))))
667 (setf (ldb (byte 1 (+ pair-idx sign
)) presence
) 1)
668 (if (= (ldb (byte 2 pair-idx
) presence
) #b11
)
670 (push (ctype-of z
) float-types
))
671 (push z unpaired
)))))))
675 (when (singleton-p (xset-data xset
))
676 (case (first (xset-data xset
))
677 ((nil) (return *null-type
*))
678 ((t) (return *eql-t-type
*))))
679 ;; Semantically this is fine - XSETs
680 ;; are not order-preserving except by accident
681 ;; (when not represented as a hash-table).
682 (when (or (equal (xset-data xset
) '(t nil
))
683 (equal (xset-data xset
) '(nil t
)))
684 (return *boolean-type
*)))
685 (when (or unpaired
(not (xset-empty-p xset
)))
686 (let ((result (%make-member-type xset unpaired
)))
687 (setf (type-hash-value result
)
688 (logior (type-hash-value result
)
689 +type-admits-type
=-optimization
+))
691 ;; The actual member-type contains the XSET (with no FP zeroes),
692 ;; and a list of unpaired zeroes.
694 (make-union-type t
(if member-type
695 (cons member-type float-types
)
697 (or member-type
*empty-type
*)))))
699 (defun member-type-size (type)
700 (+ (length (member-type-fp-zeroes type
))
701 (xset-count (member-type-xset type
))))
703 (defun member-type-member-p (x type
)
705 (and (member x
(member-type-fp-zeroes type
)) t
)
706 (xset-member-p x
(member-type-xset type
))))
708 (defun mapcar-member-type-members (function type
)
709 (declare (function function
))
711 (map-xset (lambda (x)
712 (results (funcall function x
)))
713 (member-type-xset type
))
714 (dolist (zero (member-type-fp-zeroes type
))
715 (results (funcall function zero
)))
718 (defun mapc-member-type-members (function type
)
719 (declare (function function
))
720 (map-xset function
(member-type-xset type
))
721 (dolist (zero (member-type-fp-zeroes type
))
722 (funcall function zero
)))
724 (defun member-type-members (type)
725 (append (member-type-fp-zeroes type
)
726 (xset-members (member-type-xset type
))))
728 ;;; Return TYPE converted to canonical form for a situation where the
729 ;;; "type" '* (which SBCL still represents as a type even though ANSI
730 ;;; CL defines it as a related but different kind of placeholder) is
731 ;;; equivalent to type T.
732 (defun type-*-to-t
(type)
733 (if (type= type
*wild-type
*)
737 ;;; A CONS-TYPE is used to represent a CONS type.
738 (defstruct (cons-type (:include ctype
(class-info (type-class-or-lose 'cons
)))
740 %make-cons-type
(car-type
743 ;; the CAR and CDR element types (to support ANSI (CONS FOO BAR) types)
744 (car-type (missing-arg) :type ctype
:read-only t
)
745 (cdr-type (missing-arg) :type ctype
:read-only t
))
747 ;; The function caches work significantly better when there
748 ;; is a unique object that stands for the specifier (CONS T T).
749 (defglobal *cons-t-t-type
* -
1)
750 #+sb-xc
(declaim (type ctype
*cons-t-t-type
*))
752 (defun !intern-important-cons-type-instances
()
753 (setf *cons-t-t-type
*
755 (%make-cons-type
*universal-type
* *universal-type
*))))
758 (declaim (ftype (sfunction (ctype ctype
) (values t t
)) type
=))
759 (defun make-cons-type (car-type cdr-type
)
760 (aver (not (or (eq car-type
*wild-type
*)
761 (eq cdr-type
*wild-type
*))))
762 (cond ((or (eq car-type
*empty-type
*)
763 (eq cdr-type
*empty-type
*))
765 ;; It's not a requirement that (CONS T T) be interned,
766 ;; but it improves the hit rate in the function caches.
767 ((and (type= car-type
*universal-type
*)
768 (type= cdr-type
*universal-type
*))
771 (%make-cons-type car-type cdr-type
))))
773 ;;; A SIMD-PACK-TYPE is used to represent a SIMD-PACK type.
775 (defstruct (simd-pack-type
776 (:include ctype
(class-info (type-class-or-lose 'simd-pack
)))
777 (:constructor %make-simd-pack-type
(element-type))
779 (element-type (missing-arg)
780 :type
(cons #||
(member #.
*simd-pack-element-types
*) ||
#)
784 (defun make-simd-pack-type (element-type)
785 (aver (neq element-type
*wild-type
*))
786 (if (eq element-type
*empty-type
*)
788 (%make-simd-pack-type
789 (dolist (pack-type *simd-pack-element-types
*
790 (error "~S element type must be a subtype of ~
791 ~{~S~#[~;, or ~:;, ~]~}."
792 'simd-pack
*simd-pack-element-types
*))
793 (when (csubtypep element-type
(specifier-type pack-type
))
794 (return (list pack-type
)))))))
799 ;;; Return the type structure corresponding to a type specifier.
801 ;;; Note: VALUES-SPECIFIER-TYPE-CACHE-CLEAR must be called whenever a
802 ;;; type is defined (or redefined).
804 ;;; As I understand things, :FORTHCOMING-DEFCLASS-TYPE behaves contrarily
805 ;;; to the CLHS intent, which is to make the type known to the compiler.
806 ;;; If we compile in one file:
807 ;;; (DEFCLASS FRUITBAT () ())
808 ;;; (DEFUN FRUITBATP (X) (TYPEP X 'FRUITBAT))
809 ;;; we see that it emits a call to %TYPEP with the symbol FRUITBAT as its
810 ;;; argument, whereas it should involve CLASSOID-CELL-TYPEP and LAYOUT-OF,
811 ;;; which (correctly) signals an error if the class were not defined by the
812 ;;; time of the call. Delayed re-parsing of FRUITBAT into any random specifier
813 ;;; at call time is wrong.
815 ;;; FIXME: symbols which are :PRIMITIVE are inconsistently accepted as singleton
816 ;;; lists. e.g. (BIT) and (ATOM) are considered legal, but (FIXNUM) and
817 ;;; (CHARACTER) are not. It has to do with whether the primitive is actually
818 ;;; a DEFTYPE. The CLHS glossary implies that the singleton is *always* legal.
819 ;;; "For every atomic type specifier, x, there is an _equivalent_ [my emphasis]
820 ;;; compound type specifier with no arguments supplied, (x)."
821 ;;; By that same reasonining, is (x) accepted if x names a class?
824 ;;; The xc host uses an ordinary hash table for memoization.
826 (let ((table (make-hash-table :test
'equal
)))
827 (defun !values-specifier-type-memo-wrapper
(thunk specifier
)
828 (multiple-value-bind (type yesp
) (gethash specifier table
)
831 (setf (gethash specifier table
) (funcall thunk
)))))
832 (defun values-specifier-type-cache-clear ()
834 ;;; This cache is sized extremely generously, which has payoff
835 ;;; elsewhere: it improves the TYPE= and CSUBTYPEP functions,
836 ;;; since EQ types are an immediate win.
838 (sb!impl
::!define-hash-cache values-specifier-type
839 ((orig equal-but-no-car-recursion
)) ()
840 :hash-function
#'sxhash
:hash-bits
10)
842 ;;; The recursive ("-R" suffixed) entry point for this function
843 ;;; should be used for each nested parser invocation.
844 (defun values-specifier-type-r (context type-specifier
)
845 (declare (type cons context
))
846 (labels ((fail (spec) ; Q: Shouldn't this signal a TYPE-ERROR ?
847 (error "bad thing to be a type specifier: ~S" spec
))
848 (instance-to-ctype (x)
849 (flet ((translate (classoid)
850 ;; Hmm, perhaps this should signal PARSE-UNKNOWN-TYPE
851 ;; if CLASSOID is an instance of UNDEFINED-CLASSOID ?
853 (or (and (built-in-classoid-p classoid
)
854 (built-in-classoid-translation classoid
))
856 (cond ((classoid-p x
) (translate x
))
857 ;; Avoid TYPEP on SB!MOP:EQL-SPECIALIZER and CLASS because
858 ;; the fake metaobjects do not allow type analysis, and
859 ;; would cause a compiler error as it tries to decide
860 ;; whether any clause of this COND subsumes another.
861 ;; Moreover, we don't require the host to support MOP.
862 ((sb!pcl
::classp x
) (translate (sb!pcl
::class-classoid x
)))
864 ((sb!pcl
::eql-specializer-p type-specifier
)
866 (sb!mop
:eql-specializer-object type-specifier
)))
868 (when (typep type-specifier
'instance
)
869 (return-from values-specifier-type-r
(instance-to-ctype type-specifier
)))
870 (!values-specifier-type-memo-wrapper
874 (prog* ((head (if (listp spec
) (car spec
) spec
))
875 (builtin (if (symbolp head
)
876 (info :type
:builtin head
)
877 (return (fail spec
)))))
878 (when (deprecated-thing-p 'type head
)
879 (setf (cdr context
) nil
)
880 (signal 'parse-deprecated-type
:specifier spec
))
882 ;; If spec is non-atomic, the :BUILTIN value is inapplicable.
883 ;; There used to be compound builtins, but not any more.
884 (when builtin
(return builtin
))
885 (case (info :type
:kind spec
)
886 (:instance
(return (find-classoid spec
)))
887 (:forthcoming-defclass-type
(go unknown
))))
888 (awhen (info :type
:translator head
)
889 (return (or (funcall it context spec
) (fail spec
))))
890 ;; Expansion brings up an interesting question - should the cache
891 ;; contain entries for intermediary types? Say A -> B -> REAL.
892 ;; As it stands, we cache the ctype corresponding to A but not B.
893 (awhen (info :type
:expander head
)
894 (let ((expansion (funcall it
(ensure-list spec
))))
895 (return (if (typep expansion
'instance
)
896 (instance-to-ctype expansion
)
897 (recurse expansion
)))))
898 ;; If the spec is (X ...) and X has neither a translator
899 ;; nor expander, and is a builtin, such as FIXNUM, fail now.
900 ;; But - see FIXME at top - it would be consistent with
901 ;; DEFTYPE to reject spec only if not a singleton.
902 (when builtin
(return (fail spec
)))
903 ;; SPEC has a legal form, so return an unknown type.
904 (signal 'parse-unknown-type
:specifier spec
)
906 (setf (cdr context
) nil
)
907 (return (make-unknown-type :specifier spec
)))))
908 (let ((result (recurse (uncross type-specifier
))))
909 (if (cdr context
) ; cacheable
911 ;; (The RETURN-FROM here inhibits caching; this makes sense
912 ;; not only from a compiler diagnostics point of view,
913 ;; but also for proper workingness of VALID-TYPE-SPECIFIER-P.
914 (return-from values-specifier-type-r result
)))))
916 (defun values-specifier-type (type-specifier)
917 (dx-let ((context (cons type-specifier t
)))
918 (values-specifier-type-r context type-specifier
)))
920 ;;; This is like VALUES-SPECIFIER-TYPE, except that we guarantee to
921 ;;; never return a VALUES type.
922 (defun specifier-type-r (context type-specifier
)
923 (let ((ctype (values-specifier-type-r context type-specifier
)))
924 (when (or (values-type-p ctype
)
925 ;; bootstrap magic :-(
926 (and (named-type-p ctype
)
927 (eq (named-type-name ctype
) '*)))
928 (error "VALUES type illegal in this context:~% ~S" type-specifier
))
930 (defun specifier-type (type-specifier)
931 (dx-let ((context (cons type-specifier t
)))
932 (specifier-type-r context type-specifier
)))
934 (defun single-value-specifier-type-r (context x
)
935 (if (eq x
'*) *universal-type
* (specifier-type-r context x
)))
936 (defun single-value-specifier-type (x)
941 (defun typexpand-1 (type-specifier &optional env
)
943 "Takes and expands a type specifier once like MACROEXPAND-1.
944 Returns two values: the expansion, and a boolean that is true when
946 (declare (type type-specifier type-specifier
))
947 (declare (type lexenv-designator env
) (ignore env
))
948 (let* ((spec type-specifier
)
949 (atom (if (listp spec
) (car spec
) spec
))
950 (expander (and (symbolp atom
) (info :type
:expander atom
))))
951 ;; We do not expand builtins even though it'd be
952 ;; possible to do so sometimes (e.g. STRING) for two
955 ;; a) From a user's point of view, CL types are opaque.
957 ;; b) so (EQUAL (TYPEXPAND 'STRING) (TYPEXPAND-ALL 'STRING))
958 (if (and expander
(not (info :type
:builtin atom
)))
959 (values (funcall expander
(if (symbolp spec
) (list spec
) spec
)) t
)
960 (values type-specifier nil
))))
962 (defun typexpand (type-specifier &optional env
)
964 "Takes and expands a type specifier repeatedly like MACROEXPAND.
965 Returns two values: the expansion, and a boolean that is true when
967 ;; TYPE-SPECIFIER is of type TYPE-SPECIFIER, but it is preferable to
968 ;; defer to TYPEXPAND-1 for the typecheck. Similarly for ENV.
969 (multiple-value-bind (expansion expanded
)
970 (typexpand-1 type-specifier env
)
972 (values (typexpand expansion env
) t
)
973 (values expansion expanded
))))
975 ;;; Note that the type NAME has been (re)defined, updating the
976 ;;; undefined warnings and VALUES-SPECIFIER-TYPE cache.
977 (defun %note-type-defined
(name)
978 (declare (symbol name
))
979 (note-name-defined name
:type
)
980 (values-specifier-type-cache-clear)
984 (!defun-from-collected-cold-init-forms
!early-type-cold-init
)