1 ;;;; This file contains the definition of the CTYPE (Compiler TYPE)
2 ;;;; structure, as well as the TYPE-CLASS structure which is a metaobject
3 ;;;; that factors out commonality amongst the subtypes of CTYPE.
4 ;;;; Together they form a sort of mini object system with slightly
5 ;;;; odd dispatching rules. The TYPE-CLASS is a vtable, essentially.
6 ;;;; Various macros related to manipulating those things are here too.
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 (!begin-collecting-cold-init-forms
)
21 ;; We can't make an instance of any CTYPE descendant until its type-class
22 ;; exists in *TYPE-CLASSES* and the quasi-random state has been made.
23 ;; By initializing the state and type-class storage vector at once,
24 ;; it is obvious that either both have been made or neither one has been.
26 (progn (defvar *ctype-lcg-state
* 1)
27 (defvar *ctype-hash-state
* (make-random-state))
28 (defvar *type-classes
* (make-array 20 :fill-pointer
0)))
31 (let* ((state-type `(unsigned-byte ,sb
!vm
:n-positive-fixnum-bits
))
32 (initform `(make-array 1 :element-type
',state-type
))
33 (n (length *type-classes
*)))
35 (declaim (type (simple-array ,state-type
(1))
37 (type (simple-vector ,n
) *type-classes
*))
38 ;; The value forms are for type-correctness only.
39 ;; COLD-INIT-FORMS will already have been run.
40 (defglobal *ctype-hash-state
* ,initform
)
41 (defglobal *type-classes
* (make-array ,n
))
42 (!cold-init-forms
(setq *ctype-hash-state
* ,initform
))))))
45 (defun type-class-or-lose (name)
46 (or (find name
*type-classes
* :key
#'type-class-name
)
47 (error "~S is not a defined type class." name
)))
50 (define-compiler-macro type-class-or-lose
(&whole form name
)
51 ;; If NAME is a quoted constant, the resultant form should be
52 ;; a fixed index into *TYPE-CLASSES* except that during the building
53 ;; of the cross-compiler the array hasn't been populated yet.
54 ;; One solution to that, which I favored, is that DEFINE-TYPE-CLASS
55 ;; appear before the structure definition that uses the corresponding
56 ;; type-class in its slot initializer. That posed a problem for
57 ;; the :INHERITS option, because the constructor of a descendant
58 ;; grabs all the methods [sic] from its ancestor at the time the
59 ;; descendant is defined, which means the methods of the ancestor
60 ;; should have been filled in, which means at least one DEFINE-TYPE-CLASS
61 ;; wants to appear _after_ a structure definition that uses it.
63 (let ((name (constant-form-value name
)))
65 ,(or (position name
*type-classes
* :key
#'type-class-name
)
66 (error "~S is not a defined type class." name
))))
69 (defun must-supply-this (&rest foo
)
70 (/show0
"failing in MUST-SUPPLY-THIS")
71 (error "missing type method for ~S" foo
))
73 ;;; A TYPE-CLASS object represents the "kind" of a type. It mainly
74 ;;; contains functions which are methods on that kind of type, but is
75 ;;; also used in EQ comparisons to determined if two types have the
77 (def!struct
(type-class
79 #-no-ansi-print-object
80 (:print-object
(lambda (x stream
)
81 (print-unreadable-object (x stream
:type t
)
82 (prin1 (type-class-name x
) stream
)))))
83 ;; the name of this type class (used to resolve references at load time)
84 (name (missing-arg) :type symbol
:read-only t
)
85 ;; Dyadic type methods. If the classes of the two types are EQ, then
86 ;; we call the SIMPLE-xxx method. If the classes are not EQ, and
87 ;; either type's class has a COMPLEX-xxx method, then we call it.
89 ;; Although it is undefined which method will get precedence when
90 ;; both types have a complex method, the complex method can assume
91 ;; that the second arg always is in its class, and the first always
92 ;; is not. The arguments to commutative operations will be swapped
93 ;; if the first argument has a complex method.
95 ;; Since SUBTYPEP is not commutative, we have two complex methods.
96 ;; The ARG1 method is only called when the first argument is in its
97 ;; class, and the ARG2 method is only called when called when the
98 ;; second type is. If either is specified, both must be.
99 ;; FIXME: "both must be" is false of CLASSOID type-class.
100 ;; Figure out if this is a comment bug or a logic bug.
101 ;; * (type-class-complex-subtypep-arg1 (type-class-or-lose 'classoid)) => NIL
102 ;; * (type-class-complex-subtypep-arg2 (type-class-or-lose 'classoid))
103 ;; => #<FUNCTION CLASSOID-COMPLEX-SUBTYPEP-ARG2-TYPE-METHOD>
104 (simple-subtypep #'must-supply-this
:type function
)
105 (complex-subtypep-arg1 nil
:type
(or function null
))
106 (complex-subtypep-arg2 nil
:type
(or function null
))
107 ;; SIMPLE-UNION2, COMPLEX-UNION2, SIMPLE-INTERSECTION2, and
108 ;; COMPLEX-INTERSECTION2 methods take pairs of types and try to find
109 ;; a new type which expresses the result nicely, better than could
110 ;; be done by just stuffing the two component types into an
111 ;; UNION-TYPE or INTERSECTION-TYPE object. They return NIL on
112 ;; failure, or a CTYPE for success.
114 ;; Note: These methods are similar to CMU CL's SIMPLE-UNION,
115 ;; COMPLEX-UNION, SIMPLE-INTERSECTION, and COMPLEX-UNION methods.
116 ;; They were reworked in SBCL because SBCL has INTERSECTION-TYPE
117 ;; objects (where CMU CL just punted to HAIRY-TYPE) and because SBCL
118 ;; wants to simplify unions and intersections by considering all
119 ;; possible pairwise simplifications (where the CMU CL code only
120 ;; considered simplifications between types which happened to appear
121 ;; next to each other the argument sequence).
123 ;; Differences in detail from old CMU CL methods:
124 ;; * SBCL's methods are more parallel between union and
125 ;; intersection forms. Each returns one values, (OR NULL CTYPE).
126 ;; * SBCL doesn't use type methods to deal with unions or
127 ;; intersections of the COMPOUND-TYPE of the corresponding form.
128 ;; Instead the wrapper functions TYPE-UNION2, TYPE-INTERSECTION2,
129 ;; TYPE-UNION, and TYPE-INTERSECTION handle those cases specially
130 ;; (and deal with canonicalization/simplification issues at the
132 (simple-union2 #'hierarchical-union2
:type function
)
133 (complex-union2 nil
:type
(or function null
))
134 (simple-intersection2 #'hierarchical-intersection2
:type function
)
135 (complex-intersection2 nil
:type
(or function null
))
136 (simple-= #'must-supply-this
:type function
)
137 (complex-= nil
:type
(or function null
))
139 (negate #'must-supply-this
:type function
)
140 ;; a function which returns a Common Lisp type specifier
141 ;; representing this type
142 (unparse #'must-supply-this
:type function
)
144 ;; Can types of this type-class contain other types?
145 ;; A global property of our
146 ;; implementation (which unfortunately seems impossible to enforce
147 ;; with assertions or other in-the-code checks and constraints) is
148 ;; that subclasses which don't contain other types correspond to
149 ;; disjoint subsets (except of course for the NAMED-TYPE T, which
150 ;; covers everything). So NUMBER-TYPE is disjoint from CONS-TYPE is
151 ;; is disjoint from MEMBER-TYPE and so forth. But types which can
152 ;; contain other types, like HAIRY-TYPE and INTERSECTION-TYPE, can
153 ;; violate this rule.
154 (might-contain-other-types-p nil
:type boolean
:read-only t
)
155 ;; a function which returns T if the CTYPE could possibly be
156 ;; equivalent to a MEMBER type. If not a function, then it's
157 ;; a constant T or NIL for all instances of this type class.
158 ;; Note that the old comment for this slot was
159 ;; "True if this type has a fixed number of members, and as such
160 ;; could possibly be completely specified in a MEMBER type."
161 ;; The second half of that is right because of the "possibly,"
162 ;; but "has a fixed number" is too strong a claim, because we
163 ;; set enumerable=T for NEGATION and HAIRY and some other things.
164 ;; Conceptually the choices are really {yes, no, unknown}, but
165 ;; whereas "no" means "definitely not", T means "yes or maybe".
166 (enumerable-p nil
:type
(or function boolean
) :read-only t
)
167 ;; a function which returns T if the CTYPE is inhabited by a single
168 ;; object and, as a value, the object. Otherwise, returns NIL, NIL.
169 ;; The default case (NIL) is interpreted as a function that always
171 (singleton-p nil
:type
(or function null
))
174 Not used
, and not really right. Probably we want a TYPE
= alist for the
175 unary operations
, since there are lots of interesting unary predicates that
176 aren
't equivalent to an entire class
177 ;; Names of functions used for testing the type of objects in this type
178 ;; class. UNARY-PREDICATE takes just the object, whereas PREDICATE gets
179 ;; passed both the object and the CTYPE. Normally one or the other will be
180 ;; supplied for any type that can be passed to TYPEP; there is no point in
182 (unary-typep nil
:type
(or symbol null
))
183 (typep nil
:type
(or symbol null
))
184 ;; These are like TYPEP and UNARY-TYPEP except they coerce objects to
186 (unary-coerce nil
:type
(or symbol null
))
187 (coerce :type
(or symbol null
))
190 #!-sb-fluid
(declaim (freeze-type type-class
))
193 (defun ctype-random (mask)
194 (logand (setq *ctype-lcg-state
*
195 (logand #x8fffff
(+ (* 1103515245 *ctype-lcg-state
*) 12345)))
198 ;;; the base class for the internal representation of types
200 ;; Each CTYPE instance (incl. subtypes thereof) has a random opaque hash value.
201 ;; Hashes are mixed together to form a lookup key in the memoization wrappers
202 ;; for most operations in CTYPES. This works because CTYPEs are immutable.
203 ;; But some bits are "stolen" from the hash as flag bits.
204 ;; The sign bit indicates that the object is the *only* object representing
205 ;; its type-specifier - it is an "interned" object.
206 ;; The next highest bit indicates that the object, if compared for TYPE=
207 ;; against an interned object can quickly return false when not EQ.
208 ;; Complicated types don't admit the quick failure check.
209 ;; At any rate, the totally opaque pseudo-random bits are under this mask.
210 (defconstant +ctype-hash-mask
+
211 (ldb (byte (1- sb
!vm
:n-positive-fixnum-bits
) 0) -
1))
213 ;;; When comparing two ctypes, if this bit is 1 in each and they are not EQ,
214 ;;; and at least one is interned, then they are not TYPE=.
215 (defconstant +type-admits-type
=-optimization
+
216 (ash 1 (- sb
!vm
:n-positive-fixnum-bits
1)))
218 ;;; Represent an index into *SPECIALIZED-ARRAY-ELEMENT-TYPE-PROPERTIES*
219 ;;; if applicable. For types which are not array specializations,
220 ;;; the bits are arbitrary.
221 (defmacro !ctype-saetp-index
(x)
222 `(ldb (byte 5 ,(- sb
!vm
:n-positive-fixnum-bits
6)) (type-hash-value ,x
)))
224 (def!struct
(ctype (:conc-name type-
)
227 #-sb-xc-host
(:pure t
))
228 ;; the class of this type
230 ;; FIXME: It's unnecessarily confusing to have a structure accessor
231 ;; named TYPE-CLASS-INFO which is an accessor for the CTYPE structure
232 ;; even though the TYPE-CLASS structure also exists in the system.
233 ;; Rename this slot: TYPE-CLASS or ASSOCIATED-TYPE-CLASS or something.
234 ;; [or TYPE-VTABLE or TYPE-METHODS either of which basically equates
235 ;; a type-class with the set of things it can do, while avoiding
236 ;; ambiguity to whether it is a 'CLASS-INFO' slot in a 'TYPE'
237 ;; or an 'INFO' slot in a 'TYPE-CLASS']
238 (class-info (missing-arg) :type type-class
)
239 ;; an arbitrary hash code used in EQ-style hashing of identity
240 ;; (since EQ hashing can't be done portably)
241 ;; - in the host lisp, generate a hash value using a known, simple
242 ;; random number generator (rather than the host lisp's
243 ;; implementation of RANDOM)
244 ;; - in the target, use scrambled bits from the allocation pointer
247 #+sb-xc-host
(ctype-random +ctype-hash-mask
+)
248 #-sb-xc-host
(sb!impl
::quasi-random-address-based-hash
249 *ctype-hash-state
* +ctype-hash-mask
+)
250 :type
(signed-byte #.sb
!vm
:n-fixnum-bits
)
251 ;; FIXME: is there a better way to initialize the hash value
252 ;; and its flag bit simultaneously rather than have it
253 ;; be a read/write slot?
256 ;;; The "interned" bit indicates uniqueness of the internal representation of
257 ;;; any specifier that parses to this object.
258 ;;; Not all interned types admit TYPE= optimization. As one example:
259 ;;; (type= (specifier-type '(array (unsigned-byte 6) (*)))
260 ;;; (specifier-type '(array (unsigned-byte 7) (*)))) => T and T
261 ;;; because we preserve the difference in spelling of the two types.
262 (defun mark-ctype-interned (obj)
263 (setf (type-hash-value obj
)
264 (logior sb
!xc
:most-negative-fixnum
265 (if (eq (type-class-name (type-class-info obj
)) 'array
)
267 +type-admits-type
=-optimization
+)
268 (type-hash-value obj
)))
271 ;; For cold-init: improve the randomness of the hash.
272 ;; (The host uses at most 21 bits of randomness. See CTYPE-RANDOM)
274 (defun !fix-ctype-hash
(obj)
275 (let ((saetp-index (!ctype-saetp-index obj
)))
276 ;; Preserve the interned-p and type=-optimization bits
277 ;; by flipping only the bits under the hash-mask.
278 (setf (type-hash-value obj
)
279 (logxor (logand (sb!impl
::quasi-random-address-based-hash
280 *ctype-hash-state
* +ctype-hash-mask
+))
281 (type-hash-value obj
)))
282 ;; Except that some of those "non-intelligent" bits contain
283 ;; critical information, if this type is an array specialization.
284 (setf (!ctype-saetp-index obj
) saetp-index
))
287 (declaim (inline type-might-contain-other-types-p
))
288 (defun type-might-contain-other-types-p (ctype)
289 (type-class-might-contain-other-types-p (type-class-info ctype
)))
291 (declaim (inline type-enumerable
))
292 (defun type-enumerable (ctype)
293 (let ((answer (type-class-enumerable-p (type-class-info ctype
))))
294 (if (functionp answer
)
295 (funcall answer ctype
)
299 (eval-when (:compile-toplevel
)
300 (assert (= (length (dd-slots (find-defstruct-description 'type-class
)))
301 ;; there exist two boolean slots, plus NAME
302 (+ (length !type-class-fun-slots
) 3))))
304 ;; Unfortunately redundant with the slots in the DEF!STRUCT,
305 ;; but allows asserting about correctness of the constructor
306 ;; without relying on introspection in host Lisp.
307 (defconstant-eqx !type-class-fun-slots
309 complex-subtypep-arg1
310 complex-subtypep-arg2
314 complex-intersection2
322 (eval-when (#-sb-xc
:compile-toplevel
:load-toplevel
:execute
)
323 (defun !type-class-fun-slot
(name)
324 (unless (member name
!type-class-fun-slots
325 :key
(if (keywordp name
) 'keywordicate
'identity
))
326 (warn "Undefined type-class method ~S" name
))
327 (symbolicate "TYPE-CLASS-" name
)))
329 (defmacro !define-type-method
((class method
&rest more-methods
)
330 lambda-list
&body body
)
331 (let ((name (symbolicate class
"-" method
"-TYPE-METHOD")))
333 (defun ,name
,lambda-list
336 ,@(mapcar (lambda (method)
337 `(setf (,(!type-class-fun-slot method
)
338 (type-class-or-lose ',class
))
340 (cons method more-methods
)))
343 (defmacro !define-type-class
(name &key inherits
344 (enumerable (unless inherits
(must-supply-this))
345 enumerable-supplied-p
)
346 (might-contain-other-types
347 (unless inherits
(must-supply-this))
348 might-contain-other-types-supplied-p
))
350 `(let ,(if inherits
`((parent (type-class-or-lose ',inherits
))))
353 :enumerable-p
,(if enumerable-supplied-p
355 `(type-class-enumerable-p parent
))
356 :might-contain-other-types-p
357 ,(if might-contain-other-types-supplied-p
358 might-contain-other-types
359 `(type-class-might-contain-other-types-p parent
))
361 (loop for name in
!type-class-fun-slots
362 append
`(,(keywordicate name
)
363 (,(!type-class-fun-slot name
) parent
))))))))
365 `(if (find ',name
*type-classes
* :key
#'type-class-name
)
366 ;; Careful: type-classes are very complicated things to redefine.
367 ;; For the sake of parallelized make-host-1 we have to allow it
368 ;; not to be an error to get here, but we can't overwrite anything.
369 (style-warn "Not redefining type-class ~S" ',name
)
370 (vector-push-extend ,make-it
*type-classes
*))
371 ;; The Nth entry in the array of classes contain a list of instances
372 ;; of the type-class created by genesis that need patching.
373 ;; Types are dumped into the cold core without pointing to their class
374 ;; which avoids a bootstrap problem: it's tricky to dump a type-class.
376 (let ((type-class-index
377 (position name
*type-classes
* :key
#'type-class-name
))
379 ;; KLUDGE: silence bogus warning that FIND "certainly" returns NIL
380 (locally (declare (notinline find
))
381 (dsd-index (find 'class-info
382 (dd-slots (find-defstruct-description 'ctype
))
385 (let* ((backpatch-list (svref *type-classes
* ,type-class-index
))
386 (type-class ,make-it
))
387 (setf (svref *type-classes
* ,type-class-index
) type-class
)
390 (princ ,(format nil
"Patching type-class ~A into instances: " name
))
391 (princ (length backpatch-list
))
393 (dolist (instance backpatch-list
)
394 ;; Fixup the class first, in case fixing the hash needs the class.
395 ;; (It doesn't currently, but just in case it does)
396 (setf (%instance-ref instance
,slot-index
) type-class
)
397 (!fix-ctype-hash instance
)))))))
399 ;;; Define the translation from a type-specifier to a type structure for
400 ;;; some particular type. Syntax is identical to DEFTYPE.
401 ;;; Semantics are slightly different though: DEFTYPE causes the default
402 ;;; for missing &OPTIONAL arguments to be '* but a translator requires
403 ;;; an explicit default of '*, or else it assumes a default of NIL.
404 (defmacro !def-type-translator
(name &rest stuff
)
405 (declare (type symbol name
))
406 (let* ((allow-atom (if (eq (car stuff
) :list
) (progn (pop stuff
) nil
) t
))
407 (lambda-list (pop stuff
))
408 (context-var-p (typep (car lambda-list
) '(cons (eql :context
))))
410 (if context-var-p
(cadr (pop lambda-list
)) (make-symbol "CONTEXT")))
411 ;; If atoms are allowed, then the internal destructuring-bind receives
412 ;; NIL when the spec is an atom; it should not take CDR of its input.
413 ;; (Note that a &WHOLE argument gets NIL, not the atom in that case)
414 ;; If atoms are disallowed, it's basically like a regular macro.
415 (lexpr (make-macro-lambda nil lambda-list stuff nil nil
416 :accessor
(if allow-atom
'identity
'cdr
)
418 (ll-decl (third lexpr
))
419 (defun-name (symbolicate "PARSE-<" name
">")))
420 (aver (and (eq (car ll-decl
) 'declare
) (caadr ll-decl
) 'sb
!c
::lambda-list
))
422 (defun ,defun-name
(,context spec
)
424 ,@(unless context-var-p
`((declare (ignore ,context
))))
426 `(,lexpr
(and (listp spec
) (cdr spec
)))
427 `(if (listp spec
) (,lexpr spec
))))
429 (setf (info :type
:expander
',name
) (list #',defun-name
))))))
431 ;;; Invoke a type method on TYPE1 and TYPE2. If the two types have the
432 ;;; same class, invoke the simple method. Otherwise, invoke any
433 ;;; complex method. If there isn't a distinct COMPLEX-ARG1 method,
434 ;;; then swap the arguments when calling TYPE1's method. If no
435 ;;; applicable method, return DEFAULT.
437 ;;; KLUDGE: It might be a lot easier to understand this and the rest
438 ;;; of the type system code if we used CLOS to express it instead of
439 ;;; trying to maintain this squirrely hand-crufted object system.
440 ;;; Unfortunately that'd require reworking PCL bootstrapping so that
441 ;;; all the compilation can get done by the cross-compiler, which I
442 ;;; suspect is hard, so we'll bear with the old system for the time
443 ;;; being. -- WHN 2001-03-11
444 (defmacro !invoke-type-method
(simple complex-arg2 type1 type2
&key
445 (default '(values nil t
))
446 ; assume complex fn is symmetric
447 ; unless told otherwise.
448 (complex-arg1 complex-arg2 complex-arg1-p
))
449 (declare (type keyword simple complex-arg1 complex-arg2
))
450 (once-only ((left type1
)
452 (once-only ((class1 `(type-class-info ,left
))
453 (class2 `(type-class-info ,right
)))
454 `(if (eq ,class1
,class2
)
455 (funcall (,(!type-class-fun-slot simple
) ,class1
) ,left
,right
)
456 (acond ((,(!type-class-fun-slot complex-arg2
) ,class2
)
457 (funcall it
,left
,right
))
458 ((,(!type-class-fun-slot complex-arg1
) ,class1
)
459 ;; if COMPLEX-ARG1 method was provided, the method accepts
460 ;; the arguments exactly as given. Otherwise, flip them.
461 (funcall it
,@(if complex-arg1-p
462 `(,left
,right
) `(,right
,left
))))
465 ;;; This is a very specialized implementation of CLOS-style
466 ;;; CALL-NEXT-METHOD within our twisty little type class object
467 ;;; system, which works given that it's called from within a
468 ;;; COMPLEX-SUBTYPEP-ARG2 method. (We're particularly motivated to
469 ;;; implement CALL-NEXT-METHOD in that case, because ANSI imposes some
470 ;;; strict limits on when SUBTYPEP is allowed to return (VALUES NIL NIL),
471 ;;; so instead of just complacently returning (VALUES NIL NIL) from a
472 ;;; COMPLEX-SUBTYPEP-ARG2 method we usually need to CALL-NEXT-METHOD.)
474 ;;; KLUDGE: In CLOS, this could just be CALL-NEXT-METHOD and
475 ;;; everything would Just Work without us having to think about it. In
476 ;;; our goofy type dispatch system, it's messier to express. It's also
477 ;;; more fragile, since (0) there's no check that it's called from
478 ;;; within a COMPLEX-SUBTYPEP-ARG2 method as it should be, and (1) we
479 ;;; rely on our global knowledge that the next (and only) relevant
480 ;;; method is COMPLEX-SUBTYPEP-ARG1, and (2) we rely on our global
481 ;;; knowledge of the appropriate default for the CSUBTYPEP function
482 ;;; when no next method exists. -- WHN 2002-04-07
484 ;;; (We miss CLOS! -- CSR and WHN)
485 (defun invoke-complex-subtypep-arg1-method (type1 type2
&optional subtypep win
)
486 (let* ((type-class (type-class-info type1
))
487 (method-fun (type-class-complex-subtypep-arg1 type-class
)))
489 (funcall (the function method-fun
) type1 type2
)
490 (values subtypep win
))))
492 ;;; KLUDGE: This function is dangerous, as its overuse could easily
493 ;;; cause stack exhaustion through unbounded recursion. We only use
494 ;;; it in one place; maybe it ought not to be a function at all?
495 (defun invoke-complex-=-other-method
(type1 type2
)
496 (let* ((type-class (type-class-info type1
))
497 (method-fun (type-class-complex-= type-class
)))
499 (funcall (the function method-fun
) type2 type1
)
504 ;;; Hash two things (types) down to a target fixnum. In CMU CL this was an EQ
505 ;;; hash, but since it now needs to run in vanilla ANSI Common Lisp at
506 ;;; cross-compile time, it's now based on the CTYPE-HASH-VALUE field
509 ;;; FIXME: This was a macro in CMU CL, and is now an INLINE function. Is
510 ;;; it important for it to be INLINE, or could be become an ordinary
511 ;;; function without significant loss? -- WHN 19990413
512 #!-sb-fluid
(declaim (inline type-cache-hash
))
513 (declaim (ftype (function (ctype ctype
) (signed-byte #.sb
!vm
:n-fixnum-bits
))
515 (defun type-cache-hash (type1 type2
)
516 (logxor (ash (type-hash-value type1
) -
3) (type-hash-value type2
)))
518 #!-sb-fluid
(declaim (inline type-list-cache-hash
))
519 (declaim (ftype (function (list) (signed-byte #.sb
!vm
:n-fixnum-bits
))
520 type-list-cache-hash
))
521 (defun type-list-cache-hash (types)
522 (loop with res of-type
(signed-byte #.sb
!vm
:n-fixnum-bits
) = 0
524 do
(setq res
(logxor (ash res -
1) (type-hash-value type
)))
525 finally
(return res
)))
527 ;;; A few type representations need to be defined slightly earlier than
528 ;;; 'early-type' is compiled, so they're defined here.
530 ;;; The NAMED-TYPE is used to represent *, T and NIL, the standard
531 ;;; special cases, as well as other special cases needed to
532 ;;; interpolate between regions of the type hierarchy, such as
533 ;;; INSTANCE (which corresponds to all those classes with slots which
534 ;;; are not funcallable), FUNCALLABLE-INSTANCE (those classes with
535 ;;; slots which are funcallable) and EXTENDED-SEQUUENCE (non-LIST
536 ;;; non-VECTOR classes which are also sequences). These special cases
537 ;;; are the ones that aren't really discussed by Baker in his
538 ;;; "Decision Procedure for SUBTYPEP" paper.
539 (defstruct (named-type (:include ctype
540 (class-info (type-class-or-lose 'named
)))
542 (name nil
:type symbol
:read-only t
))
544 ;;; A MEMBER-TYPE represent a use of the MEMBER type specifier. We
545 ;;; bother with this at this level because MEMBER types are fairly
546 ;;; important and union and intersection are well defined.
547 (defstruct (member-type (:include ctype
548 (class-info (type-class-or-lose 'member
)))
550 (:constructor %make-member-type
(xset fp-zeroes
))
551 #-sb-xc-host
(:pure nil
))
552 (xset nil
:type xset
:read-only t
)
553 (fp-zeroes nil
:type list
:read-only t
))
555 ;;; An ARRAY-TYPE is used to represent any array type, including
556 ;;; things such as SIMPLE-BASE-STRING.
557 (defstruct (array-type (:include ctype
558 (class-info (type-class-or-lose 'array
)))
559 (:constructor %make-array-type
560 (dimensions complexp element-type
561 specialized-element-type
))
563 ;; the dimensions of the array, or * if unspecified. If a dimension
564 ;; is unspecified, it is *.
565 (dimensions '* :type
(or list
(member *)) :read-only t
)
566 ;; Is this not a simple array type? (:MAYBE means that we don't know.)
567 (complexp :maybe
:type
(member t nil
:maybe
) :read-only t
)
568 ;; the element type as originally specified
569 (element-type nil
:type ctype
:read-only t
)
570 ;; the element type as it is specialized in this implementation
571 (specialized-element-type nil
:type ctype
:read-only t
))
573 (defstruct (character-set-type
575 (class-info (type-class-or-lose 'character-set
)))
576 (:constructor %make-character-set-type
(pairs))
578 (pairs (missing-arg) :type list
:read-only t
))
580 ;;; A COMPOUND-TYPE is a type defined out of a set of types, the
581 ;;; common parent of UNION-TYPE and INTERSECTION-TYPE.
582 (defstruct (compound-type (:include ctype
)
585 ;; Formerly defined in every CTYPE, but now just in the ones
586 ;; for which enumerability is variable.
587 (enumerable nil
:read-only t
)
588 (types nil
:type list
:read-only t
))
590 ;;; A UNION-TYPE represents a use of the OR type specifier which we
591 ;;; couldn't canonicalize to something simpler. Canonical form:
592 ;;; 1. All possible pairwise simplifications (using the UNION2 type
593 ;;; methods) have been performed. Thus e.g. there is never more
594 ;;; than one MEMBER-TYPE component. FIXME: As of sbcl-0.6.11.13,
595 ;;; this hadn't been fully implemented yet.
596 ;;; 2. There are never any UNION-TYPE components.
598 ;;; TODO: As STRING is an especially important union type,
599 ;;; it could be interned by canonicalizing its subparts into
600 ;;; ARRAY of {CHARACTER,BASE-CHAR,NIL} in that exact order always.
601 ;;; It will therefore admit quick TYPE=, but not quick failure, since
602 ;;; (type= (specifier-type '(or (simple-array (member #\a) (*))
603 ;;; (simple-array character (*))
604 ;;; (simple-array nil (*))))
605 ;;; (specifier-type 'simple-string)) => T and T
606 ;;; even though (MEMBER #\A) is not TYPE= to BASE-CHAR.
608 (defstruct (union-type (:include compound-type
609 (class-info (type-class-or-lose 'union
)))
610 (:constructor make-union-type
(enumerable types
))
613 ;;; An INTERSECTION-TYPE represents a use of the AND type specifier
614 ;;; which we couldn't canonicalize to something simpler. Canonical form:
615 ;;; 1. All possible pairwise simplifications (using the INTERSECTION2
616 ;;; type methods) have been performed. Thus e.g. there is never more
617 ;;; than one MEMBER-TYPE component.
618 ;;; 2. There are never any INTERSECTION-TYPE components: we've
619 ;;; flattened everything into a single INTERSECTION-TYPE object.
620 ;;; 3. There are never any UNION-TYPE components. Either we should
621 ;;; use the distributive rule to rearrange things so that
622 ;;; unions contain intersections and not vice versa, or we
623 ;;; should just punt to using a HAIRY-TYPE.
624 (defstruct (intersection-type (:include compound-type
625 (class-info (type-class-or-lose
627 (:constructor %make-intersection-type
631 ;;; a list of all the float "formats" (i.e. internal representations;
632 ;;; nothing to do with #'FORMAT), in order of decreasing precision
633 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
634 (defparameter *float-formats
*
635 '(long-float double-float single-float short-float
)))
637 ;;; The type of a float format.
638 (deftype float-format
() `(member ,@*float-formats
*))
640 ;;; A NUMERIC-TYPE represents any numeric type, including things
642 (defstruct (numeric-type (:include ctype
643 (class-info (type-class-or-lose 'number
)))
644 (:constructor %make-numeric-type
)
646 ;; Formerly defined in every CTYPE, but now just in the ones
647 ;; for which enumerability is variable.
648 (enumerable nil
:type boolean
:read-only t
)
649 ;; the kind of numeric type we have, or NIL if not specified (just
650 ;; NUMBER or COMPLEX)
652 ;; KLUDGE: A slot named CLASS for a non-CLASS value is bad.
653 ;; Especially when a CLASS value *is* stored in another slot (called
654 ;; CLASS-INFO:-). Perhaps this should be called CLASS-NAME? Also
655 ;; weird that comment above says "Numeric-Type is used to represent
656 ;; all numeric types" but this slot doesn't allow COMPLEX as an
657 ;; option.. how does this fall into "not specified" NIL case above?
658 ;; Perhaps someday we can switch to CLOS and make NUMERIC-TYPE
659 ;; be an abstract base class and INTEGER-TYPE, RATIONAL-TYPE, and
660 ;; whatnot be concrete subclasses..
661 (class nil
:type
(member integer rational float nil
) :read-only t
)
662 ;; "format" for a float type (i.e. type specifier for a CPU
663 ;; representation of floating point, e.g. 'SINGLE-FLOAT -- nothing
664 ;; to do with #'FORMAT), or NIL if not specified or not a float.
665 ;; Formats which don't exist in a given implementation don't appear
667 (format nil
:type
(or float-format null
) :read-only t
)
668 ;; Is this a complex numeric type? Null if unknown (only in NUMBER).
670 ;; FIXME: I'm bewildered by FOO-P names for things not intended to
671 ;; interpreted as truth values. Perhaps rename this COMPLEXNESS?
672 (complexp :real
:type
(member :real
:complex nil
) :read-only t
)
673 ;; The upper and lower bounds on the value, or NIL if there is no
674 ;; bound. If a list of a number, the bound is exclusive. Integer
675 ;; types never have exclusive bounds, i.e. they may have them on
676 ;; input, but they're canonicalized to inclusive bounds before we
678 (low nil
:type
(or number cons null
) :read-only t
)
679 (high nil
:type
(or number cons null
) :read-only t
))
681 ;;; A CONS-TYPE is used to represent a CONS type.
682 (defstruct (cons-type (:include ctype
(class-info (type-class-or-lose 'cons
)))
684 %make-cons-type
(car-type
687 ;; the CAR and CDR element types (to support ANSI (CONS FOO BAR) types)
688 (car-type (missing-arg) :type ctype
:read-only t
)
689 (cdr-type (missing-arg) :type ctype
:read-only t
))
691 (in-package "SB!ALIEN")
692 (def!struct
(alien-type
694 (:constructor make-alien-type
695 (&key class bits alignment
697 (or alignment
(guess-alignment bits
))))))
698 (class 'root
:type symbol
:read-only t
)
699 (bits nil
:type
(or null unsigned-byte
))
700 (alignment nil
:type
(or null unsigned-byte
)))
701 (!set-load-form-method alien-type
(:xc
:target
))
703 (in-package "SB!KERNEL")
704 (defstruct (alien-type-type
706 (class-info (type-class-or-lose 'alien
)))
707 (:constructor %make-alien-type-type
(alien-type))
709 (alien-type nil
:type alien-type
:read-only t
))
711 ;;; the description of a &KEY argument
712 (defstruct (key-info #-sb-xc-host
(:pure t
)
714 ;; the key (not necessarily a keyword in ANSI Common Lisp)
715 (name (missing-arg) :type symbol
:read-only t
)
716 ;; the type of the argument value
717 (type (missing-arg) :type ctype
:read-only t
))
719 ;;; ARGS-TYPE objects are used both to represent VALUES types and
720 ;;; to represent FUNCTION types.
721 (defstruct (args-type (:include ctype
)
724 ;; Lists of the type for each required and optional argument.
725 (required nil
:type list
:read-only t
)
726 (optional nil
:type list
:read-only t
)
727 ;; The type for the rest arg. NIL if there is no &REST arg.
728 (rest nil
:type
(or ctype null
) :read-only t
)
729 ;; true if &KEY arguments are specified
730 (keyp nil
:type boolean
:read-only t
)
731 ;; list of KEY-INFO structures describing the &KEY arguments
732 (keywords nil
:type list
:read-only t
)
733 ;; true if other &KEY arguments are allowed
734 (allowp nil
:type boolean
:read-only t
))
736 ;;; (SPECIFIER-TYPE 'FUNCTION) and its subtypes
737 (defstruct (fun-type (:include args-type
738 (class-info (type-class-or-lose 'function
)))
741 %make-fun-type
(required optional rest
742 keyp keywords allowp wild-args returns
)))
743 ;; true if the arguments are unrestrictive, i.e. *
744 (wild-args nil
:type boolean
:read-only t
)
745 ;; type describing the return values. This is a values type
746 ;; when multiple values were specified for the return.
747 (returns (missing-arg) :type ctype
:read-only t
))
749 (declaim (ftype (sfunction (ctype ctype
) (values t t
)) csubtypep
))
750 ;;; Look for nice relationships for types that have nice relationships
751 ;;; only when one is a hierarchical subtype of the other.
752 (defun hierarchical-intersection2 (type1 type2
)
753 ;; *EMPTY-TYPE* is involved in a dependency cycle: It wants to be a constant
754 ;; instance of NAMED-TYPE. To construct an instance of a type, you need a
755 ;; type-class. A type-class needs to refer to this function, which refers
756 ;; to *EMPTY-TYPE*, which .... etc.
757 ;; In the cross-compiler, it is actually a constant.
758 #+sb-xc-host
(declare (special *empty-type
*))
759 (multiple-value-bind (subtypep1 win1
) (csubtypep type1 type2
)
760 (multiple-value-bind (subtypep2 win2
) (csubtypep type2 type1
)
761 (cond (subtypep1 type1
)
763 ((and win1 win2
) *empty-type
*)
766 (defun hierarchical-union2 (type1 type2
)
767 (cond ((csubtypep type1 type2
) type2
)
768 ((csubtypep type2 type1
) type1
)
771 ;; KLUDGE: putting this here satisfies CMUCL for an inexplicable reason.
772 ;; It should suffice to put it anywhere before %MAKE-CHARACTER-SET-TYPE
773 ;; is actually called.
775 ;; all character-set types are enumerable, but it's not possible
776 ;; for one to be TYPE= to a MEMBER type because (MEMBER #\x)
777 ;; is not internally represented as a MEMBER type.
778 ;; So in case it wasn't clear already ENUMERABLE-P does not mean
779 ;; "possibly a MEMBER type in the Lisp-theoretic sense",
780 ;; but means "could be implemented in SBCL as a MEMBER type".
781 (!define-type-class character-set
:enumerable nil
782 :might-contain-other-types nil
)
783 (!defun-from-collected-cold-init-forms
!type-class-cold-init
)