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 (defvar *type-classes*)
18 (unless (boundp '*type-classes*) ; FIXME: How could this be bound?
19 (setq *type-classes* (make-hash-table :test 'eq))))
21 (defun type-class-or-lose (name)
22 (or (gethash name *type-classes*)
23 (error "~S is not a defined type class." name)))
25 (defun must-supply-this (&rest foo)
26 (/show0 "failing in MUST-SUPPLY-THIS")
27 (error "missing type method for ~S" foo))
29 ;;; A TYPE-CLASS object represents the "kind" of a type. It mainly
30 ;;; contains functions which are methods on that kind of type, but is
31 ;;; also used in EQ comparisons to determined if two types have the
33 (def!struct (type-class
34 #-no-ansi-print-object
35 (:print-object (lambda (x stream)
36 (print-unreadable-object (x stream :type t)
37 (prin1 (type-class-name x) stream)))))
38 ;; the name of this type class (used to resolve references at load time)
39 (name nil :type symbol) ; FIXME: should perhaps be (MISSING-ARG) default?
40 ;; Dyadic type methods. If the classes of the two types are EQ, then
41 ;; we call the SIMPLE-xxx method. If the classes are not EQ, and
42 ;; either type's class has a COMPLEX-xxx method, then we call it.
44 ;; Although it is undefined which method will get precedence when
45 ;; both types have a complex method, the complex method can assume
46 ;; that the second arg always is in its class, and the first always
47 ;; is not. The arguments to commutative operations will be swapped
48 ;; if the first argument has a complex method.
50 ;; Since SUBTYPEP is not commutative, we have two complex methods.
51 ;; The ARG1 method is only called when the first argument is in its
52 ;; class, and the ARG2 method is only called when called when the
53 ;; second type is. If either is specified, both must be.
54 (simple-subtypep #'must-supply-this :type function)
55 (complex-subtypep-arg1 nil :type (or function null))
56 (complex-subtypep-arg2 nil :type (or function null))
57 ;; SIMPLE-UNION2, COMPLEX-UNION2, SIMPLE-INTERSECTION2, and
58 ;; COMPLEX-INTERSECTION2 methods take pairs of types and try to find
59 ;; a new type which expresses the result nicely, better than could
60 ;; be done by just stuffing the two component types into an
61 ;; UNION-TYPE or INTERSECTION-TYPE object. They return NIL on
62 ;; failure, or a CTYPE for success.
64 ;; Note: These methods are similar to CMU CL's SIMPLE-UNION,
65 ;; COMPLEX-UNION, SIMPLE-INTERSECTION, and COMPLEX-UNION methods.
66 ;; They were reworked in SBCL because SBCL has INTERSECTION-TYPE
67 ;; objects (where CMU CL just punted to HAIRY-TYPE) and because SBCL
68 ;; wants to simplify unions and intersections by considering all
69 ;; possible pairwise simplifications (where the CMU CL code only
70 ;; considered simplifications between types which happened to appear
71 ;; next to each other the argument sequence).
73 ;; Differences in detail from old CMU CL methods:
74 ;; * SBCL's methods are more parallel between union and
75 ;; intersection forms. Each returns one values, (OR NULL CTYPE).
76 ;; * SBCL doesn't use type methods to deal with unions or
77 ;; intersections of the COMPOUND-TYPE of the corresponding form.
78 ;; Instead the wrapper functions TYPE-UNION2, TYPE-INTERSECTION2,
79 ;; TYPE-UNION, and TYPE-INTERSECTION handle those cases specially
80 ;; (and deal with canonicalization/simplification issues at the
82 (simple-union2 #'hierarchical-union2 :type function)
83 (complex-union2 nil :type (or function null))
84 (simple-intersection2 #'hierarchical-intersection2 :type function)
85 (complex-intersection2 nil :type (or function null))
86 (simple-= #'must-supply-this :type function)
87 (complex-= nil :type (or function null))
89 (negate #'must-supply-this :type function)
90 ;; a function which returns a Common Lisp type specifier
91 ;; representing this type
92 (unparse #'must-supply-this :type function)
93 ;; a function which returns T if the CTYPE is inhabited by a single
94 ;; object and, as a value, the object. Otherwise, returns NIL, NIL.
95 ;; The default case (NIL) is interpreted as a function that always
97 (singleton-p nil :type (or function null))
100 Not used, and not really right. Probably we want a TYPE= alist for the
101 unary operations, since there are lots of interesting unary predicates that
102 aren't equivalent to an entire class
103 ;; Names of functions used for testing the type of objects in this type
104 ;; class. UNARY-PREDICATE takes just the object, whereas PREDICATE gets
105 ;; passed both the object and the CTYPE. Normally one or the other will be
106 ;; supplied for any type that can be passed to TYPEP; there is no point in
108 (unary-typep nil :type (or symbol null))
109 (typep nil :type (or symbol null))
110 ;; These are like TYPEP and UNARY-TYPEP except they coerce objects to
112 (unary-coerce nil :type (or symbol null))
113 (coerce :type (or symbol null))
117 (eval-when (:compile-toplevel :load-toplevel :execute)
118 ;; KLUDGE: If the slots of TYPE-CLASS ever change, the slots here
119 ;; will have to be tweaked to match. -- WHN 19991021
120 (defparameter *type-class-fun-slots*
121 '((:simple-subtypep . type-class-simple-subtypep)
122 (:complex-subtypep-arg1 . type-class-complex-subtypep-arg1)
123 (:complex-subtypep-arg2 . type-class-complex-subtypep-arg2)
124 (:simple-union2 . type-class-simple-union2)
125 (:complex-union2 . type-class-complex-union2)
126 (:simple-intersection2 . type-class-simple-intersection2)
127 (:complex-intersection2 . type-class-complex-intersection2)
128 (:simple-= . type-class-simple-=)
129 (:complex-= . type-class-complex-=)
130 (:negate . type-class-negate)
131 (:unparse . type-class-unparse)
132 (:singleton-p . type-class-singleton-p))))
134 (declaim (ftype (function (type-class) type-class) copy-type-class-coldly))
135 (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
136 ;;; Copy TYPE-CLASS object X, using only operations which will work
137 ;;; early in cold load. (COPY-STRUCTURE won't work early in cold load,
138 ;;; because it needs RAW-INDEX and RAW-LENGTH information from
139 ;;; LAYOUT-INFO, and LAYOUT-INFO isn't initialized early in cold
142 ;;; FIXME: It's nasty having to maintain this hand-written copy
143 ;;; function. And it seems intrinsically dain-bramaged to have
144 ;;; RAW-INDEX and RAW-LENGTH in LAYOUT-INFO instead of directly in
145 ;;; LAYOUT. We should fix this:
146 ;;; * Move RAW-INDEX and RAW-LENGTH slots into LAYOUT itself.
147 ;;; * Rewrite the various CHECK-LAYOUT-related functions so that
148 ;;; they check RAW-INDEX and RAW-LENGTH too.
149 ;;; * Remove this special hacked copy function, just use
150 ;;; COPY-STRUCTURE instead.
151 ;;; (For even more improvement, it might be good to move the raw slots
152 ;;; into the same object as the ordinary slots, instead of having the
153 ;;; unfortunate extra level of indirection. But that'd probably
154 ;;; require a lot of work, including updating the garbage collector to
155 ;;; understand it. And it might even hurt overall performance, because
156 ;;; the positive effect of removing indirection could be cancelled by
157 ;;; the negative effect of imposing an unnecessary GC write barrier on
158 ;;; raw data which doesn't actually affect GC.)
159 (defun copy-type-class-coldly (x)
160 ;; KLUDGE: If the slots of TYPE-CLASS ever change in a way not
161 ;; reflected in *TYPE-CLASS-FUN-SLOTS*, the slots here will
162 ;; have to be hand-tweaked to match. -- WHN 2001-03-19
163 (make-type-class :name (type-class-name x)
164 . #.(mapcan (lambda (type-class-fun-slot)
165 (destructuring-bind (keyword . slot-accessor)
167 `(,keyword (,slot-accessor x))))
168 *type-class-fun-slots*)))
170 (defun class-fun-slot-or-lose (name)
171 (or (cdr (assoc name *type-class-fun-slots*))
172 (error "~S is not a defined type class method." name)))
173 ;;; FIXME: This seems to be called at runtime by cold init code.
174 ;;; Make sure that it's not being called at runtime anywhere but
175 ;;; one-time toplevel initialization code.
179 (defmacro !define-type-method ((class method &rest more-methods)
180 lambda-list &body body)
181 (let ((name (symbolicate class "-" method "-TYPE-METHOD")))
183 (defun ,name ,lambda-list
186 ,@(mapcar (lambda (method)
187 `(setf (,(class-fun-slot-or-lose method)
188 (type-class-or-lose ',class))
190 (cons method more-methods)))
193 (defmacro !define-type-class (name &key inherits)
195 ,(once-only ((n-class (if inherits
196 `(copy-type-class-coldly (type-class-or-lose
198 '(make-type-class))))
200 (setf (type-class-name ,n-class) ',name)
201 (setf (gethash ',name *type-classes*) ,n-class)
204 ;;; Invoke a type method on TYPE1 and TYPE2. If the two types have the
205 ;;; same class, invoke the simple method. Otherwise, invoke any
206 ;;; complex method. If there isn't a distinct COMPLEX-ARG1 method,
207 ;;; then swap the arguments when calling TYPE1's method. If no
208 ;;; applicable method, return DEFAULT.
210 ;;; KLUDGE: It might be a lot easier to understand this and the rest
211 ;;; of the type system code if we used CLOS to express it instead of
212 ;;; trying to maintain this squirrely hand-crufted object system.
213 ;;; Unfortunately that'd require reworking PCL bootstrapping so that
214 ;;; all the compilation can get done by the cross-compiler, which I
215 ;;; suspect is hard, so we'll bear with the old system for the time
216 ;;; being. -- WHN 2001-03-11
217 (defmacro !invoke-type-method (simple complex-arg2 type1 type2 &key
218 (default '(values nil t))
219 (complex-arg1 :foo complex-arg1-p))
220 (declare (type keyword simple complex-arg1 complex-arg2))
221 (let ((simple (class-fun-slot-or-lose simple))
222 (cslot1 (class-fun-slot-or-lose
223 (if complex-arg1-p complex-arg1 complex-arg2)))
224 (cslot2 (class-fun-slot-or-lose complex-arg2)))
225 (once-only ((ntype1 type1)
227 (once-only ((class1 `(type-class-info ,ntype1))
228 (class2 `(type-class-info ,ntype2)))
229 `(if (eq ,class1 ,class2)
230 (funcall (,simple ,class1) ,ntype1 ,ntype2)
231 ,(once-only ((complex2 `(,cslot2 ,class2)))
233 (funcall ,complex2 ,ntype1 ,ntype2)
234 ,(once-only ((complex1 `(,cslot1 ,class1)))
237 (funcall ,complex1 ,ntype1 ,ntype2)
238 (funcall ,complex1 ,ntype2 ,ntype1))
241 ;;; This is a very specialized implementation of CLOS-style
242 ;;; CALL-NEXT-METHOD within our twisty little type class object
243 ;;; system, which works given that it's called from within a
244 ;;; COMPLEX-SUBTYPEP-ARG2 method. (We're particularly motivated to
245 ;;; implement CALL-NEXT-METHOD in that case, because ANSI imposes some
246 ;;; strict limits on when SUBTYPEP is allowed to return (VALUES NIL NIL),
247 ;;; so instead of just complacently returning (VALUES NIL NIL) from a
248 ;;; COMPLEX-SUBTYPEP-ARG2 method we usually need to CALL-NEXT-METHOD.)
250 ;;; KLUDGE: In CLOS, this could just be CALL-NEXT-METHOD and
251 ;;; everything would Just Work without us having to think about it. In
252 ;;; our goofy type dispatch system, it's messier to express. It's also
253 ;;; more fragile, since (0) there's no check that it's called from
254 ;;; within a COMPLEX-SUBTYPEP-ARG2 method as it should be, and (1) we
255 ;;; rely on our global knowledge that the next (and only) relevant
256 ;;; method is COMPLEX-SUBTYPEP-ARG1, and (2) we rely on our global
257 ;;; knowledge of the appropriate default for the CSUBTYPEP function
258 ;;; when no next method exists. -- WHN 2002-04-07
260 ;;; (We miss CLOS! -- CSR and WHN)
261 (defun invoke-complex-subtypep-arg1-method (type1 type2 &optional subtypep win)
262 (let* ((type-class (type-class-info type1))
263 (method-fun (type-class-complex-subtypep-arg1 type-class)))
265 (funcall (the function method-fun) type1 type2)
266 (values subtypep win))))
268 ;;; KLUDGE: This function is dangerous, as its overuse could easily
269 ;;; cause stack exhaustion through unbounded recursion. We only use
270 ;;; it in one place; maybe it ought not to be a function at all?
271 (defun invoke-complex-=-other-method (type1 type2)
272 (let* ((type-class (type-class-info type1))
273 (method-fun (type-class-complex-= type-class)))
275 (funcall (the function method-fun) type2 type1)
278 (!defun-from-collected-cold-init-forms !type-class-cold-init)