1 ;;;; stuff related to the TYPE-CLASS structure
3 ;;;; This software is part of the SBCL system. See the README file for
6 ;;;; This software is derived from the CMU CL system, which was
7 ;;;; written at Carnegie Mellon University and released into the
8 ;;;; public domain. The software is in the public domain and is
9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
10 ;;;; files for more information.
12 (in-package "SB!KERNEL")
14 (!begin-collecting-cold-init-forms
)
16 ;; We can't make an instance of any CTYPE descendant until its type-class
17 ;; exists in *TYPE-CLASSES* and the quasi-random state has been made.
18 ;; By initializing the state and type-class storage vector at once,
19 ;; it is obvious that either both have been made or neither one has been.
21 (progn (defvar *ctype-lcg-state
* 1)
22 (defvar *ctype-hash-state
* (make-random-state))
23 (defvar *type-classes
* (make-array 20 :fill-pointer
0)))
26 (let* ((state-type `(unsigned-byte ,sb
!vm
:n-positive-fixnum-bits
))
27 (initform `(make-array 1 :element-type
',state-type
))
28 (n (length *type-classes
*)))
30 (declaim (type (simple-array ,state-type
(1))
32 (type (simple-vector ,n
) *type-classes
*))
33 ;; The value forms are for type-correctness only.
34 ;; COLD-INIT-FORMS will already have been run.
35 (defglobal *ctype-hash-state
* ,initform
)
36 (defglobal *type-classes
* (make-array ,n
))
38 (setq *ctype-hash-state
* ,initform
39 *type-classes
* (make-array ,n
)))))))
42 (defun type-class-or-lose (name)
43 (or (find name
*type-classes
* :key
#'type-class-name
)
44 (error "~S is not a defined type class." name
)))
47 (define-compiler-macro type-class-or-lose
(&whole form name
)
48 ;; If NAME is a quoted constant, the resultant form should be
49 ;; a fixed index into *TYPE-CLASSES* except that during the building
50 ;; of the cross-compiler the array hasn't been populated yet.
51 ;; One solution to that, which I favored, is that DEFINE-TYPE-CLASS
52 ;; appear before the structure definition that uses the corresponding
53 ;; type-class in its slot initializer. That posed a problem for
54 ;; the :INHERITS option, because the constructor of a descendant
55 ;; grabs all the methods [sic] from its ancestor at the time the
56 ;; descendant is defined, which means the methods of the ancestor
57 ;; should have been filled in, which means at least one DEFINE-TYPE-CLASS
58 ;; wants to appear _after_ a structure definition that uses it.
60 (let ((name (constant-form-value name
)))
62 ,(or (position name
*type-classes
* :key
#'type-class-name
)
63 (error "~S is not a defined type class." name
))))
66 (defun must-supply-this (&rest foo
)
67 (/show0
"failing in MUST-SUPPLY-THIS")
68 (error "missing type method for ~S" foo
))
70 ;;; A TYPE-CLASS object represents the "kind" of a type. It mainly
71 ;;; contains functions which are methods on that kind of type, but is
72 ;;; also used in EQ comparisons to determined if two types have the
74 (def!struct
(type-class
75 #-no-ansi-print-object
76 (:print-object
(lambda (x stream
)
77 (print-unreadable-object (x stream
:type t
)
78 (prin1 (type-class-name x
) stream
)))))
79 ;; the name of this type class (used to resolve references at load time)
80 (name (missing-arg) :type symbol
:read-only t
)
81 ;; Dyadic type methods. If the classes of the two types are EQ, then
82 ;; we call the SIMPLE-xxx method. If the classes are not EQ, and
83 ;; either type's class has a COMPLEX-xxx method, then we call it.
85 ;; Although it is undefined which method will get precedence when
86 ;; both types have a complex method, the complex method can assume
87 ;; that the second arg always is in its class, and the first always
88 ;; is not. The arguments to commutative operations will be swapped
89 ;; if the first argument has a complex method.
91 ;; Since SUBTYPEP is not commutative, we have two complex methods.
92 ;; The ARG1 method is only called when the first argument is in its
93 ;; class, and the ARG2 method is only called when called when the
94 ;; second type is. If either is specified, both must be.
95 ;; FIXME: "both must be" is false of CLASSOID type-class.
96 ;; Figure out if this is a comment bug or a logic bug.
97 ;; * (type-class-complex-subtypep-arg1 (type-class-or-lose 'classoid)) => NIL
98 ;; * (type-class-complex-subtypep-arg2 (type-class-or-lose 'classoid))
99 ;; => #<FUNCTION CLASSOID-COMPLEX-SUBTYPEP-ARG2-TYPE-METHOD>
100 (simple-subtypep #'must-supply-this
:type function
)
101 (complex-subtypep-arg1 nil
:type
(or function null
))
102 (complex-subtypep-arg2 nil
:type
(or function null
))
103 ;; SIMPLE-UNION2, COMPLEX-UNION2, SIMPLE-INTERSECTION2, and
104 ;; COMPLEX-INTERSECTION2 methods take pairs of types and try to find
105 ;; a new type which expresses the result nicely, better than could
106 ;; be done by just stuffing the two component types into an
107 ;; UNION-TYPE or INTERSECTION-TYPE object. They return NIL on
108 ;; failure, or a CTYPE for success.
110 ;; Note: These methods are similar to CMU CL's SIMPLE-UNION,
111 ;; COMPLEX-UNION, SIMPLE-INTERSECTION, and COMPLEX-UNION methods.
112 ;; They were reworked in SBCL because SBCL has INTERSECTION-TYPE
113 ;; objects (where CMU CL just punted to HAIRY-TYPE) and because SBCL
114 ;; wants to simplify unions and intersections by considering all
115 ;; possible pairwise simplifications (where the CMU CL code only
116 ;; considered simplifications between types which happened to appear
117 ;; next to each other the argument sequence).
119 ;; Differences in detail from old CMU CL methods:
120 ;; * SBCL's methods are more parallel between union and
121 ;; intersection forms. Each returns one values, (OR NULL CTYPE).
122 ;; * SBCL doesn't use type methods to deal with unions or
123 ;; intersections of the COMPOUND-TYPE of the corresponding form.
124 ;; Instead the wrapper functions TYPE-UNION2, TYPE-INTERSECTION2,
125 ;; TYPE-UNION, and TYPE-INTERSECTION handle those cases specially
126 ;; (and deal with canonicalization/simplification issues at the
128 (simple-union2 #'hierarchical-union2
:type function
)
129 (complex-union2 nil
:type
(or function null
))
130 (simple-intersection2 #'hierarchical-intersection2
:type function
)
131 (complex-intersection2 nil
:type
(or function null
))
132 (simple-= #'must-supply-this
:type function
)
133 (complex-= nil
:type
(or function null
))
135 (negate #'must-supply-this
:type function
)
136 ;; a function which returns a Common Lisp type specifier
137 ;; representing this type
138 (unparse #'must-supply-this
:type function
)
140 ;; Can types of this type-class contain other types?
141 ;; A global property of our
142 ;; implementation (which unfortunately seems impossible to enforce
143 ;; with assertions or other in-the-code checks and constraints) is
144 ;; that subclasses which don't contain other types correspond to
145 ;; disjoint subsets (except of course for the NAMED-TYPE T, which
146 ;; covers everything). So NUMBER-TYPE is disjoint from CONS-TYPE is
147 ;; is disjoint from MEMBER-TYPE and so forth. But types which can
148 ;; contain other types, like HAIRY-TYPE and INTERSECTION-TYPE, can
149 ;; violate this rule.
150 (might-contain-other-types-p nil
)
151 ;; a function which returns T if the CTYPE could possibly be
152 ;; equivalent to a MEMBER type. If not a function, then it's
153 ;; a constant T or NIL for all instances of this type class.
154 ;; Note that the old comment for this slot was
155 ;; "True if this type has a fixed number of members, and as such
156 ;; could possibly be completely specified in a MEMBER type."
157 ;; The second half of that is right because of the "possibly,"
158 ;; but "has a fixed number" is too strong a claim, because we
159 ;; set enumerable=T for NEGATION and HAIRY and some other things.
160 ;; Conceptually the choices are really {yes, no, unknown}, but
161 ;; whereas "no" means "definitely not", T means "yes or maybe".
162 (enumerable-p nil
:type
(or function null t
))
163 ;; a function which returns T if the CTYPE is inhabited by a single
164 ;; object and, as a value, the object. Otherwise, returns NIL, NIL.
165 ;; The default case (NIL) is interpreted as a function that always
167 (singleton-p nil
:type
(or function null
))
170 Not used
, and not really right. Probably we want a TYPE
= alist for the
171 unary operations
, since there are lots of interesting unary predicates that
172 aren
't equivalent to an entire class
173 ;; Names of functions used for testing the type of objects in this type
174 ;; class. UNARY-PREDICATE takes just the object, whereas PREDICATE gets
175 ;; passed both the object and the CTYPE. Normally one or the other will be
176 ;; supplied for any type that can be passed to TYPEP; there is no point in
178 (unary-typep nil
:type
(or symbol null
))
179 (typep nil
:type
(or symbol null
))
180 ;; These are like TYPEP and UNARY-TYPEP except they coerce objects to
182 (unary-coerce nil
:type
(or symbol null
))
183 (coerce :type
(or symbol null
))
186 #!-sb-fluid
(declaim (freeze-type type-class
))
189 (eval-when (:compile-toplevel
)
190 (assert (= (length (dd-slots (find-defstruct-description 'type-class
)))
191 ;; there exist two boolean slots, plus NAME
192 (+ (length !type-class-fun-slots
) 3))))
194 ;; Unfortunately redundant with the slots in the DEF!STRUCT,
195 ;; but allows asserting about correctness of the constructor
196 ;; without relying on introspection in host Lisp.
197 (defconstant-eqx !type-class-fun-slots
199 complex-subtypep-arg1
200 complex-subtypep-arg2
204 complex-intersection2
212 (eval-when (#-sb-xc
:compile-toplevel
:load-toplevel
:execute
)
213 (defun !type-class-fun-slot
(name)
214 (unless (member name
!type-class-fun-slots
215 :key
(if (keywordp name
) 'keywordicate
'identity
))
216 (warn "Undefined type-class method ~S" name
))
217 (symbolicate "TYPE-CLASS-" name
)))
219 (defmacro !define-type-method
((class method
&rest more-methods
)
220 lambda-list
&body body
)
221 (let ((name (symbolicate class
"-" method
"-TYPE-METHOD")))
223 (defun ,name
,lambda-list
226 ,@(mapcar (lambda (method)
227 `(setf (,(!type-class-fun-slot method
)
228 (type-class-or-lose ',class
))
230 (cons method more-methods
)))
233 (defmacro !define-type-class
(name &key inherits
234 (enumerable (unless inherits
(must-supply-this))
235 enumerable-supplied-p
)
236 (might-contain-other-types
237 (unless inherits
(must-supply-this))
238 might-contain-other-types-supplied-p
))
240 `(let ,(if inherits
`((parent (type-class-or-lose ',inherits
))))
243 :enumerable-p
,(if enumerable-supplied-p
245 `(type-class-enumerable-p parent
))
246 :might-contain-other-types-p
247 ,(if might-contain-other-types-supplied-p
248 might-contain-other-types
249 `(type-class-might-contain-other-types-p parent
))
251 (loop for name in
!type-class-fun-slots
252 append
`(,(keywordicate name
)
253 (,(!type-class-fun-slot name
) parent
))))))))
256 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
257 (unless (find ',name
*type-classes
* :key
#'type-class-name
)
258 (vector-push-extend ,make-it
*type-classes
*))))
261 (setf (svref *type-classes
*
262 ,(position name
*type-classes
* :key
#'type-class-name
))
265 ;;; Invoke a type method on TYPE1 and TYPE2. If the two types have the
266 ;;; same class, invoke the simple method. Otherwise, invoke any
267 ;;; complex method. If there isn't a distinct COMPLEX-ARG1 method,
268 ;;; then swap the arguments when calling TYPE1's method. If no
269 ;;; applicable method, return DEFAULT.
271 ;;; KLUDGE: It might be a lot easier to understand this and the rest
272 ;;; of the type system code if we used CLOS to express it instead of
273 ;;; trying to maintain this squirrely hand-crufted object system.
274 ;;; Unfortunately that'd require reworking PCL bootstrapping so that
275 ;;; all the compilation can get done by the cross-compiler, which I
276 ;;; suspect is hard, so we'll bear with the old system for the time
277 ;;; being. -- WHN 2001-03-11
278 (defmacro !invoke-type-method
(simple complex-arg2 type1 type2
&key
279 (default '(values nil t
))
280 ; assume complex fn is symmetric
281 ; unless told otherwise.
282 (complex-arg1 complex-arg2 complex-arg1-p
))
283 (declare (type keyword simple complex-arg1 complex-arg2
))
284 (once-only ((left type1
)
286 (once-only ((class1 `(type-class-info ,left
))
287 (class2 `(type-class-info ,right
)))
288 `(if (eq ,class1
,class2
)
289 (funcall (,(!type-class-fun-slot simple
) ,class1
) ,left
,right
)
290 (acond ((,(!type-class-fun-slot complex-arg2
) ,class2
)
291 (funcall it
,left
,right
))
292 ((,(!type-class-fun-slot complex-arg1
) ,class1
)
293 ;; if COMPLEX-ARG1 method was provided, the method accepts
294 ;; the arguments exactly as given. Otherwise, flip them.
295 (funcall it
,@(if complex-arg1-p
296 `(,left
,right
) `(,right
,left
))))
299 ;;; This is a very specialized implementation of CLOS-style
300 ;;; CALL-NEXT-METHOD within our twisty little type class object
301 ;;; system, which works given that it's called from within a
302 ;;; COMPLEX-SUBTYPEP-ARG2 method. (We're particularly motivated to
303 ;;; implement CALL-NEXT-METHOD in that case, because ANSI imposes some
304 ;;; strict limits on when SUBTYPEP is allowed to return (VALUES NIL NIL),
305 ;;; so instead of just complacently returning (VALUES NIL NIL) from a
306 ;;; COMPLEX-SUBTYPEP-ARG2 method we usually need to CALL-NEXT-METHOD.)
308 ;;; KLUDGE: In CLOS, this could just be CALL-NEXT-METHOD and
309 ;;; everything would Just Work without us having to think about it. In
310 ;;; our goofy type dispatch system, it's messier to express. It's also
311 ;;; more fragile, since (0) there's no check that it's called from
312 ;;; within a COMPLEX-SUBTYPEP-ARG2 method as it should be, and (1) we
313 ;;; rely on our global knowledge that the next (and only) relevant
314 ;;; method is COMPLEX-SUBTYPEP-ARG1, and (2) we rely on our global
315 ;;; knowledge of the appropriate default for the CSUBTYPEP function
316 ;;; when no next method exists. -- WHN 2002-04-07
318 ;;; (We miss CLOS! -- CSR and WHN)
319 (defun invoke-complex-subtypep-arg1-method (type1 type2
&optional subtypep win
)
320 (let* ((type-class (type-class-info type1
))
321 (method-fun (type-class-complex-subtypep-arg1 type-class
)))
323 (funcall (the function method-fun
) type1 type2
)
324 (values subtypep win
))))
326 ;;; KLUDGE: This function is dangerous, as its overuse could easily
327 ;;; cause stack exhaustion through unbounded recursion. We only use
328 ;;; it in one place; maybe it ought not to be a function at all?
329 (defun invoke-complex-=-other-method
(type1 type2
)
330 (let* ((type-class (type-class-info type1
))
331 (method-fun (type-class-complex-= type-class
)))
333 (funcall (the function method-fun
) type2 type1
)
336 (!defun-from-collected-cold-init-forms
!type-class-cold-init
)