1 ;;;; This file contains structures and functions for the maintenance of
2 ;;;; basic information about defined types. Different object systems
3 ;;;; can be supported simultaneously.
5 ;;;; This software is part of the SBCL system. See the README file for
8 ;;;; This software is derived from the CMU CL system, which was
9 ;;;; written at Carnegie Mellon University and released into the
10 ;;;; public domain. The software is in the public domain and is
11 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
12 ;;;; files for more information.
14 (in-package "SB!KERNEL")
16 (!begin-collecting-cold-init-forms)
18 ;;;; the CLASSOID structure
20 ;;; The CLASSOID structure is a supertype of all classoid types. A
21 ;;; CLASSOID is also a CTYPE structure as recognized by the type
22 ;;; system. (FIXME: It's also a type specifier, though this might go
23 ;;; away as with the merger of SB-PCL:CLASS and CL:CLASS it's no
26 (:make-load-form-fun classoid-make-load-form-fun)
28 (class-info (type-class-or-lose 'classoid)))
30 #-no-ansi-print-object
32 (lambda (class stream)
33 (let ((name (classoid-name class)))
34 (print-unreadable-object (class stream
38 ;; FIXME: Make sure that this prints
39 ;; reasonably for anonymous classes.
40 "~:[anonymous~;~:*~S~]~@[ (~(~A~))~]"
42 (classoid-state class))))))
43 #-sb-xc-host (:pure nil))
44 ;; the value to be returned by CLASSOID-NAME.
45 (name nil :type symbol)
46 ;; the current layout for this class, or NIL if none assigned yet
47 (layout nil :type (or layout null))
48 ;; How sure are we that this class won't be redefined?
49 ;; :READ-ONLY = We are committed to not changing the effective
50 ;; slots or superclasses.
51 ;; :SEALED = We can't even add subclasses.
52 ;; NIL = Anything could happen.
53 (state nil :type (member nil :read-only :sealed))
54 ;; direct superclasses of this class
55 (direct-superclasses () :type list)
56 ;; representation of all of the subclasses (direct or indirect) of
57 ;; this class. This is NIL if no subclasses or not initalized yet;
58 ;; otherwise, it's an EQ hash-table mapping CLASSOID objects to the
59 ;; subclass layout that was in effect at the time the subclass was
61 (subclasses nil :type (or null hash-table))
62 ;; the PCL class (= CL:CLASS, but with a view to future flexibility
63 ;; we don't just call it the CLASS slot) object for this class, or
64 ;; NIL if none assigned yet
67 (defun classoid-make-load-form-fun (class)
68 (/show "entering CLASSOID-MAKE-LOAD-FORM-FUN" class)
69 (let ((name (classoid-name class)))
70 (unless (and name (eq (find-classoid name nil) class))
71 (/show "anonymous/undefined class case")
72 (error "can't use anonymous or undefined class as constant:~% ~S"
75 ;; KLUDGE: There's a FIND-CLASSOID DEFTRANSFORM for constant
76 ;; class names which creates fast but non-cold-loadable,
77 ;; non-compact code. In this context, we'd rather have compact,
78 ;; cold-loadable code. -- WHN 19990928
79 (declare (notinline find-classoid))
80 (find-classoid ',name))))
82 ;;;; basic LAYOUT stuff
84 ;;; Note: This bound is set somewhat less than MOST-POSITIVE-FIXNUM
85 ;;; in order to guarantee that several hash values can be added without
86 ;;; overflowing into a bignum.
87 (def!constant layout-clos-hash-limit (1+ (ash sb!xc:most-positive-fixnum -3))
89 "the exclusive upper bound on LAYOUT-CLOS-HASH values")
90 (def!type layout-clos-hash () '(integer 0 #.layout-clos-hash-limit))
92 ;;; a list of conses, initialized by genesis
94 ;;; In each cons, the car is the symbol naming the layout, and the
95 ;;; cdr is the layout itself.
96 (defvar *!initial-layouts*)
98 ;;; a table mapping class names to layouts for classes we have
99 ;;; referenced but not yet loaded. This is initialized from an alist
100 ;;; created by genesis describing the layouts that genesis created at
102 (defvar *forward-referenced-layouts*)
104 (setq *forward-referenced-layouts* (make-hash-table :test 'equal))
106 (/show0 "processing *!INITIAL-LAYOUTS*")
107 (dolist (x *!initial-layouts*)
108 (setf (gethash (car x) *forward-referenced-layouts*)
110 (/show0 "done processing *!INITIAL-LAYOUTS*")))
112 ;;; The LAYOUT structure is pointed to by the first cell of instance
113 ;;; (or structure) objects. It represents what we need to know for
114 ;;; type checking and garbage collection. Whenever a class is
115 ;;; incompatibly redefined, a new layout is allocated. If two object's
116 ;;; layouts are EQ, then they are exactly the same type.
118 ;; KLUDGE: A special hack keeps this from being
119 ;; called when building code for the
120 ;; cross-compiler. See comments at the DEFUN for
121 ;; this. -- WHN 19990914
122 (:make-load-form-fun #-sb-xc-host ignore-it
123 ;; KLUDGE: DEF!STRUCT at #+SB-XC-HOST
124 ;; time controls both the
125 ;; build-the-cross-compiler behavior
126 ;; and the run-the-cross-compiler
127 ;; behavior. The value below only
128 ;; works for build-the-cross-compiler.
129 ;; There's a special hack in
130 ;; EMIT-MAKE-LOAD-FORM which gives
131 ;; effectively IGNORE-IT behavior for
132 ;; LAYOUT at run-the-cross-compiler
133 ;; time. It would be cleaner to
134 ;; actually have an IGNORE-IT value
135 ;; stored, but it's hard to see how to
136 ;; do that concisely with the current
137 ;; DEF!STRUCT setup. -- WHN 19990930
139 make-load-form-for-layout))
140 ;; a pseudo-random hash value for use by CLOS. KLUDGE: The fact
141 ;; that this slot is at offset 1 is known to GENESIS.
142 (clos-hash (random-layout-clos-hash) :type layout-clos-hash)
143 ;; the class that this is a layout for
144 (classoid (missing-arg) :type classoid)
145 ;; The value of this slot can be:
146 ;; * :UNINITIALIZED if not initialized yet;
147 ;; * NIL if this is the up-to-date layout for a class; or
148 ;; * T if this layout has been invalidated (by being replaced by
149 ;; a new, more-up-to-date LAYOUT).
150 ;; * something else (probably a list) if the class is a PCL wrapper
151 ;; and PCL has made it invalid and made a note to itself about it
152 (invalid :uninitialized :type (or cons (member nil t :uninitialized)))
153 ;; the layouts for all classes we inherit. If hierarchical, i.e. if
154 ;; DEPTHOID >= 0, then these are ordered by ORDER-LAYOUT-INHERITS
155 ;; (least to most specific), so that each inherited layout appears
156 ;; at its expected depth, i.e. at its LAYOUT-DEPTHOID value.
158 ;; Remaining elements are filled by the non-hierarchical layouts or,
159 ;; if they would otherwise be empty, by copies of succeeding layouts.
160 (inherits #() :type simple-vector)
161 ;; If inheritance is not hierarchical, this is -1. If inheritance is
162 ;; hierarchical, this is the inheritance depth, i.e. (LENGTH INHERITS).
164 ;; (1) This turns out to be a handy encoding for arithmetically
165 ;; comparing deepness; it is generally useful to do a bare numeric
166 ;; comparison of these depthoid values, and we hardly ever need to
167 ;; test whether the values are negative or not.
168 ;; (2) This was called INHERITANCE-DEPTH in classic CMU CL. It was
169 ;; renamed because some of us find it confusing to call something
170 ;; a depth when it isn't quite.
171 (depthoid -1 :type layout-depthoid)
172 ;; the number of top level descriptor cells in each instance
173 (length 0 :type index)
174 ;; If this layout has some kind of compiler meta-info, then this is
175 ;; it. If a structure, then we store the DEFSTRUCT-DESCRIPTION here.
177 ;; This is true if objects of this class are never modified to
178 ;; contain dynamic pointers in their slots or constant-like
179 ;; substructure (and hence can be copied into read-only space by
182 ;; This slot is known to the C runtime support code.
183 (pure nil :type (member t nil 0))
184 ;; Number of raw words at the end.
185 ;; This slot is known to the C runtime support code.
186 (n-untagged-slots 0 :type index)
187 ;; Definition location
188 (source-location nil))
190 (def!method print-object ((layout layout) stream)
191 (print-unreadable-object (layout stream :type t :identity t)
193 "for ~S~@[, INVALID=~S~]"
194 (layout-proper-name layout)
195 (layout-invalid layout))))
197 (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
198 (defun layout-proper-name (layout)
199 (classoid-proper-name (layout-classoid layout))))
201 ;;;; support for the hash values used by CLOS when working with LAYOUTs
203 ;;; a generator for random values suitable for the CLOS-HASH slots of
204 ;;; LAYOUTs. We use our own RANDOM-STATE here because we'd like
205 ;;; pseudo-random values to come the same way in the target even when
206 ;;; we make minor changes to the system, in order to reduce the
207 ;;; mysteriousness of possible CLOS bugs.
208 (defvar *layout-clos-hash-random-state*)
209 (defun random-layout-clos-hash ()
210 ;; FIXME: I'm not sure why this expression is (1+ (RANDOM FOO)),
211 ;; returning a strictly positive value. I copied it verbatim from
212 ;; CMU CL INITIALIZE-LAYOUT-HASH, so presumably it works, but I
213 ;; dunno whether the hash values are really supposed to be 1-based.
214 ;; They're declared as INDEX.. Or is this a hack to try to avoid
215 ;; having to use bignum arithmetic? Or what? An explanation would be
218 ;; an explanation is provided in Kiczales and Rodriguez, "Efficient
219 ;; Method Dispatch in PCL", 1990. -- CSR, 2005-11-30
220 (1+ (random (1- layout-clos-hash-limit)
221 (if (boundp '*layout-clos-hash-random-state*)
222 *layout-clos-hash-random-state*
223 (setf *layout-clos-hash-random-state*
224 (make-random-state))))))
226 ;;; If we can't find any existing layout, then we create a new one
227 ;;; storing it in *FORWARD-REFERENCED-LAYOUTS*. In classic CMU CL, we
228 ;;; used to immediately check for compatibility, but for
229 ;;; cross-compilability reasons (i.e. convenience of using this
230 ;;; function in a MAKE-LOAD-FORM expression) that functionality has
231 ;;; been split off into INIT-OR-CHECK-LAYOUT.
232 (declaim (ftype (function (symbol) layout) find-layout))
233 (defun find-layout (name)
234 (let ((classoid (find-classoid name nil)))
235 (or (and classoid (classoid-layout classoid))
236 (gethash name *forward-referenced-layouts*)
237 (setf (gethash name *forward-referenced-layouts*)
238 (make-layout :classoid (or classoid
239 (make-undefined-classoid name)))))))
241 ;;; If LAYOUT is uninitialized, initialize it with CLASSOID, LENGTH,
242 ;;; INHERITS, and DEPTHOID, otherwise require that it be consistent
243 ;;; with CLASSOID, LENGTH, INHERITS, and DEPTHOID.
245 ;;; UNDEFINED-CLASS values are interpreted specially as "we don't know
246 ;;; anything about the class", so if LAYOUT is initialized, any
247 ;;; preexisting class slot value is OK, and if it's not initialized,
248 ;;; its class slot value is set to an UNDEFINED-CLASS. -- FIXME: This
249 ;;; is no longer true, :UNINITIALIZED used instead.
250 (declaim (ftype (function (layout classoid index simple-vector layout-depthoid
253 init-or-check-layout))
254 (defun init-or-check-layout
255 (layout classoid length inherits depthoid nuntagged)
256 (cond ((eq (layout-invalid layout) :uninitialized)
257 ;; There was no layout before, we just created one which
258 ;; we'll now initialize with our information.
259 (setf (layout-length layout) length
260 (layout-inherits layout) inherits
261 (layout-depthoid layout) depthoid
262 (layout-n-untagged-slots layout) nuntagged
263 (layout-classoid layout) classoid
264 (layout-invalid layout) nil))
265 ;; FIXME: Now that LAYOUTs are born :UNINITIALIZED, maybe this
266 ;; clause is not needed?
267 ((not *type-system-initialized*)
268 (setf (layout-classoid layout) classoid))
270 ;; There was an old layout already initialized with old
271 ;; information, and we'll now check that old information
272 ;; which was known with certainty is consistent with current
273 ;; information which is known with certainty.
274 (check-layout layout classoid length inherits depthoid nuntagged)))
277 ;;; In code for the target Lisp, we don't use dump LAYOUTs using the
278 ;;; standard load form mechanism, we use special fops instead, in
279 ;;; order to make cold load come out right. But when we're building
280 ;;; the cross-compiler, we can't do that because we don't have access
281 ;;; to special non-ANSI low-level things like special fops, and we
282 ;;; don't need to do that anyway because our code isn't going to be
283 ;;; cold loaded, so we use the ordinary load form system.
285 ;;; KLUDGE: A special hack causes this not to be called when we are
286 ;;; building code for the target Lisp. It would be tidier to just not
287 ;;; have it in place when we're building the target Lisp, but it
288 ;;; wasn't clear how to do that without rethinking DEF!STRUCT quite a
289 ;;; bit, so I punted. -- WHN 19990914
291 (defun make-load-form-for-layout (layout &optional env)
292 (declare (type layout layout))
293 (declare (ignore env))
294 (when (layout-invalid layout)
295 (compiler-error "can't dump reference to obsolete class: ~S"
296 (layout-classoid layout)))
297 (let ((name (classoid-name (layout-classoid layout))))
299 (compiler-error "can't dump anonymous LAYOUT: ~S" layout))
300 ;; Since LAYOUT refers to a class which refers back to the LAYOUT,
301 ;; we have to do this in two stages, like the TREE-WITH-PARENT
302 ;; example in the MAKE-LOAD-FORM entry in the ANSI spec.
304 ;; "creation" form (which actually doesn't create a new LAYOUT if
305 ;; there's a preexisting one with this name)
306 `(find-layout ',name)
307 ;; "initialization" form (which actually doesn't initialize
308 ;; preexisting LAYOUTs, just checks that they're consistent).
309 `(init-or-check-layout ',layout
310 ',(layout-classoid layout)
311 ',(layout-length layout)
312 ',(layout-inherits layout)
313 ',(layout-depthoid layout)
314 ',(layout-n-untagged-slots layout)))))
316 ;;; If LAYOUT's slot values differ from the specified slot values in
317 ;;; any interesting way, then give a warning and return T.
318 (declaim (ftype (function (simple-string
325 redefine-layout-warning))
326 (defun redefine-layout-warning (old-context old-layout
327 context length inherits depthoid nuntagged)
328 (declare (type layout old-layout) (type simple-string old-context context))
329 (let ((name (layout-proper-name old-layout)))
330 (or (let ((old-inherits (layout-inherits old-layout)))
331 (or (when (mismatch old-inherits
333 :key #'layout-proper-name)
334 (warn "change in superclasses of class ~S:~% ~
335 ~A superclasses: ~S~% ~
339 (map 'list #'layout-proper-name old-inherits)
341 (map 'list #'layout-proper-name inherits))
343 (let ((diff (mismatch old-inherits inherits)))
347 ~:(~A~) definition of superclass ~S is incompatible with~% ~
351 (layout-proper-name (svref old-inherits diff))
354 (let ((old-length (layout-length old-layout)))
355 (unless (= old-length length)
356 (warn "change in instance length of class ~S:~% ~
360 old-context old-length
363 (let ((old-nuntagged (layout-n-untagged-slots old-layout)))
364 (unless (= old-nuntagged nuntagged)
365 (warn "change in instance layout of class ~S:~% ~
366 ~A untagged slots: ~W~% ~
367 ~A untagged slots: ~W"
369 old-context old-nuntagged
372 (unless (= (layout-depthoid old-layout) depthoid)
373 (warn "change in the inheritance structure of class ~S~% ~
374 between the ~A definition and the ~A definition"
375 name old-context context)
378 ;;; Require that LAYOUT data be consistent with CLASS, LENGTH,
379 ;;; INHERITS, and DEPTHOID.
380 (declaim (ftype (function
381 (layout classoid index simple-vector layout-depthoid index))
383 (defun check-layout (layout classoid length inherits depthoid nuntagged)
384 (aver (eq (layout-classoid layout) classoid))
385 (when (redefine-layout-warning "current" layout
386 "compile time" length inherits depthoid
388 ;; Classic CMU CL had more options here. There are several reasons
389 ;; why they might want more options which are less appropriate for
390 ;; us: (1) It's hard to fit the classic CMU CL flexible approach
391 ;; into the ANSI-style MAKE-LOAD-FORM system, and having a
392 ;; non-MAKE-LOAD-FORM-style system is painful when we're trying to
393 ;; make the cross-compiler run under vanilla ANSI Common Lisp. (2)
394 ;; We have CLOS now, and if you want to be able to flexibly
395 ;; redefine classes without restarting the system, it'd make sense
396 ;; to use that, so supporting complexity in order to allow
397 ;; modifying DEFSTRUCTs without restarting the system is a low
398 ;; priority. (3) We now have the ability to rebuild the SBCL
399 ;; system from scratch, so we no longer need this functionality in
400 ;; order to maintain the SBCL system by modifying running images.
401 (error "The class ~S was not changed, and there's no guarantee that~@
402 the loaded code (which expected another layout) will work."
403 (layout-proper-name layout)))
406 ;;; a common idiom (the same as CMU CL FIND-LAYOUT) rolled up into a
407 ;;; single function call
409 ;;; Used by the loader to forward-reference layouts for classes whose
410 ;;; definitions may not have been loaded yet. This allows type tests
411 ;;; to be loaded when the type definition hasn't been loaded yet.
412 (declaim (ftype (function (symbol index simple-vector layout-depthoid index)
414 find-and-init-or-check-layout))
415 (defun find-and-init-or-check-layout (name length inherits depthoid nuntagged)
416 (let ((layout (find-layout name)))
417 (init-or-check-layout layout
418 (or (find-classoid name nil)
419 (layout-classoid layout))
425 ;;; Record LAYOUT as the layout for its class, adding it as a subtype
426 ;;; of all superclasses. This is the operation that "installs" a
427 ;;; layout for a class in the type system, clobbering any old layout.
428 ;;; However, this does not modify the class namespace; that is a
429 ;;; separate operation (think anonymous classes.)
430 ;;; -- If INVALIDATE, then all the layouts for any old definition
431 ;;; and subclasses are invalidated, and the SUBCLASSES slot is cleared.
432 ;;; -- If DESTRUCT-LAYOUT, then this is some old layout, and is to be
433 ;;; destructively modified to hold the same type information.
434 (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
435 (defun register-layout (layout &key (invalidate t) destruct-layout)
436 (declare (type layout layout) (type (or layout null) destruct-layout))
437 (let* ((classoid (layout-classoid layout))
438 (classoid-layout (classoid-layout classoid))
439 (subclasses (classoid-subclasses classoid)))
441 ;; Attempting to register ourselves with a temporary undefined
442 ;; class placeholder is almost certainly a programmer error. (I
443 ;; should know, I did it.) -- WHN 19990927
444 (aver (not (undefined-classoid-p classoid)))
446 ;; This assertion dates from classic CMU CL. The rationale is
447 ;; probably that calling REGISTER-LAYOUT more than once for the
448 ;; same LAYOUT is almost certainly a programmer error.
449 (aver (not (eq classoid-layout layout)))
451 ;; Figure out what classes are affected by the change, and issue
452 ;; appropriate warnings and invalidations.
453 (when classoid-layout
454 (modify-classoid classoid)
456 (dohash (subclass subclass-layout subclasses)
457 (modify-classoid subclass)
459 (invalidate-layout subclass-layout))))
461 (invalidate-layout classoid-layout)
462 (setf (classoid-subclasses classoid) nil)))
465 (setf (layout-invalid destruct-layout) nil
466 (layout-inherits destruct-layout) (layout-inherits layout)
467 (layout-depthoid destruct-layout)(layout-depthoid layout)
468 (layout-length destruct-layout) (layout-length layout)
469 (layout-n-untagged-slots destruct-layout) (layout-n-untagged-slots layout)
470 (layout-info destruct-layout) (layout-info layout)
471 (classoid-layout classoid) destruct-layout)
472 (setf (layout-invalid layout) nil
473 (classoid-layout classoid) layout))
475 (dovector (super-layout (layout-inherits layout))
476 (let* ((super (layout-classoid super-layout))
477 (subclasses (or (classoid-subclasses super)
478 (setf (classoid-subclasses super)
479 (make-hash-table :test 'eq)))))
480 (when (and (eq (classoid-state super) :sealed)
481 (not (gethash classoid subclasses)))
482 (warn "unsealing sealed class ~S in order to subclass it"
483 (classoid-name super))
484 (setf (classoid-state super) :read-only))
485 (setf (gethash classoid subclasses)
486 (or destruct-layout layout)))))
491 ;;; Arrange the inherited layouts to appear at their expected depth,
492 ;;; ensuring that hierarchical type tests succeed. Layouts with
493 ;;; DEPTHOID >= 0 (i.e. hierarchical classes) are placed first,
494 ;;; at exactly that index in the INHERITS vector. Then, non-hierarchical
495 ;;; layouts are placed in remaining elements. Then, any still-empty
496 ;;; elements are filled with their successors, ensuring that each
497 ;;; element contains a valid layout.
499 ;;; This reordering may destroy CPL ordering, so the inherits should
500 ;;; not be read as being in CPL order.
501 (defun order-layout-inherits (layouts)
502 (declare (simple-vector layouts))
503 (let ((length (length layouts))
506 (let ((depth (layout-depthoid (svref layouts i))))
507 (when (> depth max-depth)
508 (setf max-depth depth))))
509 (let* ((new-length (max (1+ max-depth) length))
510 ;; KLUDGE: 0 here is the "uninitialized" element. We need
511 ;; to specify it explicitly for portability purposes, as
512 ;; elements can be read before being set [ see below, "(EQL
513 ;; OLD-LAYOUT 0)" ]. -- CSR, 2002-04-20
514 (inherits (make-array new-length :initial-element 0)))
516 (let* ((layout (svref layouts i))
517 (depth (layout-depthoid layout)))
518 (unless (eql depth -1)
519 (let ((old-layout (svref inherits depth)))
520 (unless (or (eql old-layout 0) (eq old-layout layout))
521 (error "layout depth conflict: ~S~%" layouts)))
522 (setf (svref inherits depth) layout))))
526 (declare (type index i j))
527 (let* ((layout (svref layouts i))
528 (depth (layout-depthoid layout)))
530 (loop (when (eql (svref inherits j) 0)
533 (setf (svref inherits j) layout))))
534 (do ((i (1- new-length) (1- i)))
536 (declare (type fixnum i))
537 (when (eql (svref inherits i) 0)
538 (setf (svref inherits i) (svref inherits (1+ i)))))
541 ;;;; class precedence lists
543 ;;; Topologically sort the list of objects to meet a set of ordering
544 ;;; constraints given by pairs (A . B) constraining A to precede B.
545 ;;; When there are multiple objects to choose, the tie-breaker
546 ;;; function is called with both the list of object to choose from and
547 ;;; the reverse ordering built so far.
548 (defun topological-sort (objects constraints tie-breaker)
549 (declare (list objects constraints)
550 (function tie-breaker))
551 (let ((obj-info (make-hash-table :size (length objects)))
554 (dolist (constraint constraints)
555 (let ((obj1 (car constraint))
556 (obj2 (cdr constraint)))
557 (let ((info2 (gethash obj2 obj-info)))
560 (setf (gethash obj2 obj-info) (list 1))))
561 (let ((info1 (gethash obj1 obj-info)))
563 (push obj2 (rest info1))
564 (setf (gethash obj1 obj-info) (list 0 obj2))))))
565 (dolist (obj objects)
566 (let ((info (gethash obj obj-info)))
567 (when (or (not info) (zerop (first info)))
568 (push obj free-objs))))
570 (flet ((next-result (obj)
572 (dolist (successor (rest (gethash obj obj-info)))
573 (let* ((successor-info (gethash successor obj-info))
574 (count (1- (first successor-info))))
575 (setf (first successor-info) count)
577 (push successor free-objs))))))
578 (cond ((endp free-objs)
579 (dohash (obj info obj-info)
580 (unless (zerop (first info))
581 (error "Topological sort failed due to constraint on ~S."
583 (return (nreverse result)))
584 ((endp (rest free-objs))
585 (next-result (pop free-objs)))
587 (let ((obj (funcall tie-breaker free-objs result)))
588 (setf free-objs (remove obj free-objs))
589 (next-result obj))))))))
592 ;;; standard class precedence list computation
593 (defun std-compute-class-precedence-list (class)
596 (labels ((note-class (class)
597 (unless (member class classes)
599 (let ((superclasses (classoid-direct-superclasses class)))
601 (rest superclasses (rest rest)))
603 (let ((next (first rest)))
604 (push (cons prev next) constraints)
606 (dolist (class superclasses)
607 (note-class class)))))
608 (std-cpl-tie-breaker (free-classes rev-cpl)
609 (dolist (class rev-cpl (first free-classes))
610 (let* ((superclasses (classoid-direct-superclasses class))
611 (intersection (intersection free-classes
614 (return (first intersection)))))))
616 (topological-sort classes constraints #'std-cpl-tie-breaker))))
618 ;;;; object types to represent classes
620 ;;; An UNDEFINED-CLASSOID is a cookie we make up to stick in forward
621 ;;; referenced layouts. Users should never see them.
622 (def!struct (undefined-classoid
624 (:constructor make-undefined-classoid (name))))
626 ;;; BUILT-IN-CLASS is used to represent the standard classes that
627 ;;; aren't defined with DEFSTRUCT and other specially implemented
628 ;;; primitive types whose only attribute is their name.
630 ;;; Some BUILT-IN-CLASSes have a TRANSLATION, which means that they
631 ;;; are effectively DEFTYPE'd to some other type (usually a union of
632 ;;; other classes or a "primitive" type such as NUMBER, ARRAY, etc.)
633 ;;; This translation is done when type specifiers are parsed. Type
634 ;;; system operations (union, subtypep, etc.) should never encounter
635 ;;; translated classes, only their translation.
636 (def!struct (built-in-classoid (:include classoid)
637 (:constructor make-built-in-classoid))
638 ;; the type we translate to on parsing. If NIL, then this class
639 ;; stands on its own; or it can be set to :INITIALIZING for a period
641 (translation nil :type (or ctype (member nil :initializing))))
643 ;;; STRUCTURE-CLASS represents what we need to know about structure
644 ;;; classes. Non-structure "typed" defstructs are a special case, and
645 ;;; don't have a corresponding class.
646 (def!struct (structure-classoid (:include classoid)
647 (:constructor make-structure-classoid))
648 ;; If true, a default keyword constructor for this structure.
649 (constructor nil :type (or function null)))
651 ;;;; classoid namespace
653 ;;; We use an indirection to allow forward referencing of class
654 ;;; definitions with load-time resolution.
655 (def!struct (classoid-cell
656 (:constructor make-classoid-cell (name &optional classoid))
657 (:make-load-form-fun (lambda (c)
659 ',(classoid-cell-name c))))
660 #-no-ansi-print-object
661 (:print-object (lambda (s stream)
662 (print-unreadable-object (s stream :type t)
663 (prin1 (classoid-cell-name s) stream)))))
664 ;; Name of class we expect to find.
665 (name nil :type symbol :read-only t)
666 ;; Class or NIL if not yet defined.
667 (classoid nil :type (or classoid null)))
668 (defun find-classoid-cell (name)
669 (or (info :type :classoid name)
670 (setf (info :type :classoid name)
671 (make-classoid-cell name))))
673 (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
674 (defun find-classoid (name &optional (errorp t) environment)
676 "Return the class with the specified NAME. If ERRORP is false, then
677 NIL is returned when no such class exists."
678 (declare (type symbol name) (ignore environment))
679 (let ((res (classoid-cell-classoid (find-classoid-cell name))))
680 (if (or res (not errorp))
682 (error 'simple-type-error
684 :expected-type 'class
685 :format-control "class not yet defined:~% ~S"
686 :format-arguments (list name)))))
687 (defun (setf find-classoid) (new-value name)
688 #-sb-xc (declare (type (or null classoid) new-value))
691 (ecase (info :type :kind name)
695 (error "attempt to redefine :PRIMITIVE type: ~S" name))
696 ((:forthcoming-defclass-type :instance)
697 (setf (info :type :kind name) nil
698 (info :type :classoid name) nil
699 (info :type :documentation name) nil
700 (info :type :compiler-layout name) nil))))
702 (ecase (info :type :kind name)
704 (:forthcoming-defclass-type
705 ;; XXX Currently, nothing needs to be done in this
706 ;; case. Later, when PCL is integrated tighter into SBCL, this
707 ;; might need more work.
710 ;; KLUDGE: The reason these clauses aren't directly parallel
711 ;; is that we need to use the internal CLASSOID structure
712 ;; ourselves, because we don't have CLASSes to work with until
713 ;; PCL is built. In the host, CLASSes have an approximately
714 ;; one-to-one correspondence with the target CLASSOIDs (as
715 ;; well as with the target CLASSes, modulo potential
716 ;; differences with respect to conditions).
718 (let ((old (class-of (find-classoid name)))
719 (new (class-of new-value)))
721 (bug "trying to change the metaclass of ~S from ~S to ~S in the ~
723 name (class-name old) (class-name new))))
725 (let ((old (classoid-of (find-classoid name)))
726 (new (classoid-of new-value)))
728 (warn "changing meta-class of ~S from ~S to ~S"
729 name (classoid-name old) (classoid-name new)))))
731 (error "illegal to redefine standard type ~S" name))
733 (warn "redefining DEFTYPE type to be a class: ~S" name)
734 (setf (info :type :expander name) nil)))
736 (remhash name *forward-referenced-layouts*)
737 (%note-type-defined name)
738 ;; we need to handle things like
739 ;; (setf (find-class 'foo) (find-class 'integer))
741 ;; (setf (find-class 'integer) (find-class 'integer))
743 ((built-in-classoid-p new-value)
744 (setf (info :type :kind name) (or (info :type :kind name) :defined))
745 (let ((translation (built-in-classoid-translation new-value)))
747 (setf (info :type :translator name)
748 (lambda (c) (declare (ignore c)) translation)))))
749 (t (setf (info :type :kind name) :instance)))
750 (setf (classoid-cell-classoid (find-classoid-cell name)) new-value)
751 (unless (eq (info :type :compiler-layout name)
752 (classoid-layout new-value))
753 (setf (info :type :compiler-layout name) (classoid-layout new-value)))))
757 ;;; Called when we are about to define NAME as a class meeting some
758 ;;; predicate (such as a meta-class type test.) The first result is
759 ;;; always of the desired class. The second result is any existing
760 ;;; LAYOUT for this name.
761 (defun insured-find-classoid (name predicate constructor)
762 (declare (type function predicate constructor))
763 (let* ((old (find-classoid name nil))
764 (res (if (and old (funcall predicate old))
766 (funcall constructor :name name)))
767 (found (or (gethash name *forward-referenced-layouts*)
768 (when old (classoid-layout old)))))
770 (setf (layout-classoid found) res))
773 ;;; If the class has a proper name, return the name, otherwise return
775 (defun classoid-proper-name (class)
776 #-sb-xc (declare (type classoid class))
777 (let ((name (classoid-name class)))
778 (if (and name (eq (find-classoid name nil) class))
782 ;;;; CLASS type operations
784 (!define-type-class classoid)
786 ;;; We might be passed classoids with invalid layouts; in any pairwise
787 ;;; class comparison, we must ensure that both are valid before
789 (defun ensure-classoid-valid (classoid layout)
790 (aver (eq classoid (layout-classoid layout)))
791 (when (layout-invalid layout)
792 (if (typep classoid 'standard-classoid)
793 (let ((class (classoid-pcl-class classoid)))
795 ((sb!pcl:class-finalized-p class)
796 (sb!pcl::force-cache-flushes class))
797 ((sb!pcl::class-has-a-forward-referenced-superclass-p class)
798 (error "Invalid, unfinalizeable class ~S (classoid ~S)."
800 (t (sb!pcl:finalize-inheritance class))))
801 (error "Don't know how to ensure validity of ~S (not ~
802 a STANDARD-CLASSOID)." classoid))))
804 (defun ensure-both-classoids-valid (class1 class2)
805 (do ((layout1 (classoid-layout class1) (classoid-layout class1))
806 (layout2 (classoid-layout class2) (classoid-layout class2))
808 ((and (not (layout-invalid layout1)) (not (layout-invalid layout2))))
810 (ensure-classoid-valid class1 layout1)
811 (ensure-classoid-valid class2 layout2)))
813 (defun update-object-layout-or-invalid (object layout)
814 (if (typep (classoid-of object) 'standard-classoid)
815 (sb!pcl::check-wrapper-validity object)
816 (%layout-invalid-error object layout)))
818 ;;; Simple methods for TYPE= and SUBTYPEP should never be called when
819 ;;; the two classes are equal, since there are EQ checks in those
821 (!define-type-method (classoid :simple-=) (type1 type2)
822 (aver (not (eq type1 type2)))
825 (!define-type-method (classoid :simple-subtypep) (class1 class2)
826 (aver (not (eq class1 class2)))
827 (ensure-both-classoids-valid class1 class2)
828 (let ((subclasses (classoid-subclasses class2)))
829 (if (and subclasses (gethash class1 subclasses))
833 ;;; When finding the intersection of a sealed class and some other
834 ;;; class (not hierarchically related) the intersection is the union
835 ;;; of the currently shared subclasses.
836 (defun sealed-class-intersection2 (sealed other)
837 (declare (type classoid sealed other))
838 (let ((s-sub (classoid-subclasses sealed))
839 (o-sub (classoid-subclasses other)))
840 (if (and s-sub o-sub)
841 (collect ((res *empty-type* type-union))
842 (dohash (subclass layout s-sub)
843 (declare (ignore layout))
844 (when (gethash subclass o-sub)
845 (res (specifier-type subclass))))
849 (!define-type-method (classoid :simple-intersection2) (class1 class2)
850 (declare (type classoid class1 class2))
851 (ensure-both-classoids-valid class1 class2)
852 (cond ((eq class1 class2)
854 ;; If one is a subclass of the other, then that is the
856 ((let ((subclasses (classoid-subclasses class2)))
857 (and subclasses (gethash class1 subclasses)))
859 ((let ((subclasses (classoid-subclasses class1)))
860 (and subclasses (gethash class2 subclasses)))
862 ;; Otherwise, we can't in general be sure that the
863 ;; intersection is empty, since a subclass of both might be
864 ;; defined. But we can eliminate it for some special cases.
865 ((or (structure-classoid-p class1)
866 (structure-classoid-p class2))
867 ;; No subclass of both can be defined.
869 ((eq (classoid-state class1) :sealed)
870 ;; checking whether a subclass of both can be defined:
871 (sealed-class-intersection2 class1 class2))
872 ((eq (classoid-state class2) :sealed)
873 ;; checking whether a subclass of both can be defined:
874 (sealed-class-intersection2 class2 class1))
876 ;; uncertain, since a subclass of both might be defined
879 ;;; KLUDGE: we need this to deal with the special-case INSTANCE and
880 ;;; FUNCALLABLE-INSTANCE types (which used to be CLASSOIDs until CSR
881 ;;; discovered that this was incompatible with the MOP class
882 ;;; hierarchy). See NAMED :COMPLEX-SUBTYPEP-ARG2
883 (defvar *non-instance-classoid-types*
884 '(symbol system-area-pointer weak-pointer code-component
885 lra fdefn random-class))
887 ;;; KLUDGE: we need this because of the need to represent
888 ;;; intersections of two classes, even when empty at a given time, as
889 ;;; uncanonicalized intersections because of the possibility of later
890 ;;; defining a subclass of both classes. The necessity for changing
891 ;;; the default return value from SUBTYPEP to NIL, T if no alternate
892 ;;; method is present comes about because, unlike the other places we
893 ;;; use INVOKE-COMPLEX-SUBTYPEP-ARG1-METHOD, in HAIRY methods and the
894 ;;; like, classes are in their own hierarchy with no possibility of
895 ;;; mixtures with other type classes.
896 (!define-type-method (classoid :complex-subtypep-arg2) (type1 class2)
897 (if (and (intersection-type-p type1)
898 (> (count-if #'classoid-p (intersection-type-types type1)) 1))
900 (invoke-complex-subtypep-arg1-method type1 class2 nil t)))
902 (!define-type-method (classoid :negate) (type)
903 (make-negation-type :type type))
905 (!define-type-method (classoid :unparse) (type)
906 (classoid-proper-name type))
910 ;;; the CLASSOID that we use to represent type information for
911 ;;; STANDARD-CLASS and FUNCALLABLE-STANDARD-CLASS. The type system
912 ;;; side does not need to distinguish between STANDARD-CLASS and
913 ;;; FUNCALLABLE-STANDARD-CLASS.
914 (def!struct (standard-classoid (:include classoid)
915 (:constructor make-standard-classoid)))
916 ;;; a metaclass for classes which aren't standardlike but will never
918 (def!struct (static-classoid (:include classoid)
919 (:constructor make-static-classoid)))
921 ;;;; built-in classes
923 ;;; The BUILT-IN-CLASSES list is a data structure which configures the
924 ;;; creation of all the built-in classes. It contains all the info
925 ;;; that we need to maintain the mapping between classes, compile-time
926 ;;; types and run-time type codes. These options are defined:
928 ;;; :TRANSLATION (default none)
929 ;;; When this class is "parsed" as a type specifier, it is
930 ;;; translated into the specified internal type representation,
931 ;;; rather than being left as a class. This is used for types
932 ;;; which we want to canonicalize to some other kind of type
933 ;;; object because in general we want to be able to include more
934 ;;; information than just the class (e.g. for numeric types.)
936 ;;; :ENUMERABLE (default NIL)
937 ;;; The value of the :ENUMERABLE slot in the created class.
938 ;;; Meaningless in translated classes.
940 ;;; :STATE (default :SEALED)
941 ;;; The value of CLASS-STATE which we want on completion,
942 ;;; indicating whether subclasses can be created at run-time.
944 ;;; :HIERARCHICAL-P (default T unless any of the inherits are non-hierarchical)
945 ;;; True if we can assign this class a unique inheritance depth.
947 ;;; :CODES (default none)
948 ;;; Run-time type codes which should be translated back to this
949 ;;; class by CLASS-OF. Unspecified for abstract classes.
951 ;;; :INHERITS (default this class and T)
952 ;;; The class-precedence list for this class, with this class and
955 ;;; :DIRECT-SUPERCLASSES (default to head of CPL)
956 ;;; List of the direct superclasses of this class.
958 ;;; FIXME: This doesn't seem to be needed after cold init (and so can
959 ;;; probably be uninterned at the end of cold init).
960 (defvar *built-in-classes*)
962 (/show0 "setting *BUILT-IN-CLASSES*")
965 '((t :state :read-only :translation t)
966 (character :enumerable t
967 :codes (#.sb!vm:character-widetag)
968 :translation (character-set)
969 :prototype-form (code-char 42))
970 (symbol :codes (#.sb!vm:symbol-header-widetag)
971 :prototype-form '#:mu)
973 (system-area-pointer :codes (#.sb!vm:sap-widetag)
974 :prototype-form (sb!sys:int-sap 42))
975 (weak-pointer :codes (#.sb!vm:weak-pointer-widetag)
976 :prototype-form (sb!ext:make-weak-pointer (find-package "CL")))
977 (code-component :codes (#.sb!vm:code-header-widetag))
978 (lra :codes (#.sb!vm:return-pc-header-widetag))
979 (fdefn :codes (#.sb!vm:fdefn-widetag)
980 :prototype-form (sb!kernel:make-fdefn "42"))
981 (random-class) ; used for unknown type codes
984 :codes (#.sb!vm:closure-header-widetag
985 #.sb!vm:simple-fun-header-widetag)
987 :prototype-form (function (lambda () 42)))
989 (number :translation number)
993 :codes (#.sb!vm:complex-widetag)
994 :prototype-form (complex 42 42))
995 (complex-single-float
996 :translation (complex single-float)
997 :inherits (complex number)
998 :codes (#.sb!vm:complex-single-float-widetag)
999 :prototype-form (complex 42f0 42f0))
1000 (complex-double-float
1001 :translation (complex double-float)
1002 :inherits (complex number)
1003 :codes (#.sb!vm:complex-double-float-widetag)
1004 :prototype-form (complex 42d0 42d0))
1007 :translation (complex long-float)
1008 :inherits (complex number)
1009 :codes (#.sb!vm:complex-long-float-widetag)
1010 :prototype-form (complex 42l0 42l0))
1011 (real :translation real :inherits (number))
1014 :inherits (real number))
1016 :translation single-float
1017 :inherits (float real number)
1018 :codes (#.sb!vm:single-float-widetag)
1019 :prototype-form 42f0)
1021 :translation double-float
1022 :inherits (float real number)
1023 :codes (#.sb!vm:double-float-widetag)
1024 :prototype-form 42d0)
1027 :translation long-float
1028 :inherits (float real number)
1029 :codes (#.sb!vm:long-float-widetag)
1030 :prototype-form 42l0)
1032 :translation rational
1033 :inherits (real number))
1035 :translation (and rational (not integer))
1036 :inherits (rational real number)
1037 :codes (#.sb!vm:ratio-widetag)
1038 :prototype-form 1/42)
1040 :translation integer
1041 :inherits (rational real number))
1043 :translation (integer #.sb!xc:most-negative-fixnum
1044 #.sb!xc:most-positive-fixnum)
1045 :inherits (integer rational real number)
1046 :codes (#.sb!vm:even-fixnum-lowtag #.sb!vm:odd-fixnum-lowtag)
1049 :translation (and integer (not fixnum))
1050 :inherits (integer rational real number)
1051 :codes (#.sb!vm:bignum-widetag)
1052 :prototype-form (expt 2 #.(* sb!vm:n-word-bits (/ 3 2))))
1054 (array :translation array :codes (#.sb!vm:complex-array-widetag)
1056 :prototype-form (make-array nil :adjustable t))
1058 :translation simple-array :codes (#.sb!vm:simple-array-widetag)
1060 :prototype-form (make-array nil))
1062 :translation (or cons (member nil) vector extended-sequence)
1066 :translation vector :codes (#.sb!vm:complex-vector-widetag)
1067 :direct-superclasses (array sequence)
1068 :inherits (array sequence))
1070 :translation simple-vector :codes (#.sb!vm:simple-vector-widetag)
1071 :direct-superclasses (vector simple-array)
1072 :inherits (vector simple-array array sequence)
1073 :prototype-form (make-array 0))
1075 :translation bit-vector :codes (#.sb!vm:complex-bit-vector-widetag)
1076 :inherits (vector array sequence)
1077 :prototype-form (make-array 0 :element-type 'bit :fill-pointer t))
1079 :translation simple-bit-vector :codes (#.sb!vm:simple-bit-vector-widetag)
1080 :direct-superclasses (bit-vector simple-array)
1081 :inherits (bit-vector vector simple-array
1083 :prototype-form (make-array 0 :element-type 'bit))
1084 (simple-array-unsigned-byte-2
1085 :translation (simple-array (unsigned-byte 2) (*))
1086 :codes (#.sb!vm:simple-array-unsigned-byte-2-widetag)
1087 :direct-superclasses (vector simple-array)
1088 :inherits (vector simple-array array sequence)
1089 :prototype-form (make-array 0 :element-type '(unsigned-byte 2)))
1090 (simple-array-unsigned-byte-4
1091 :translation (simple-array (unsigned-byte 4) (*))
1092 :codes (#.sb!vm:simple-array-unsigned-byte-4-widetag)
1093 :direct-superclasses (vector simple-array)
1094 :inherits (vector simple-array array sequence)
1095 :prototype-form (make-array 0 :element-type '(unsigned-byte 4)))
1096 (simple-array-unsigned-byte-7
1097 :translation (simple-array (unsigned-byte 7) (*))
1098 :codes (#.sb!vm:simple-array-unsigned-byte-7-widetag)
1099 :direct-superclasses (vector simple-array)
1100 :inherits (vector simple-array array sequence)
1101 :prototype-form (make-array 0 :element-type '(unsigned-byte 7)))
1102 (simple-array-unsigned-byte-8
1103 :translation (simple-array (unsigned-byte 8) (*))
1104 :codes (#.sb!vm:simple-array-unsigned-byte-8-widetag)
1105 :direct-superclasses (vector simple-array)
1106 :inherits (vector simple-array array sequence)
1107 :prototype-form (make-array 0 :element-type '(unsigned-byte 8)))
1108 (simple-array-unsigned-byte-15
1109 :translation (simple-array (unsigned-byte 15) (*))
1110 :codes (#.sb!vm:simple-array-unsigned-byte-15-widetag)
1111 :direct-superclasses (vector simple-array)
1112 :inherits (vector simple-array array sequence)
1113 :prototype-form (make-array 0 :element-type '(unsigned-byte 15)))
1114 (simple-array-unsigned-byte-16
1115 :translation (simple-array (unsigned-byte 16) (*))
1116 :codes (#.sb!vm:simple-array-unsigned-byte-16-widetag)
1117 :direct-superclasses (vector simple-array)
1118 :inherits (vector simple-array array sequence)
1119 :prototype-form (make-array 0 :element-type '(unsigned-byte 16)))
1120 #!+#.(cl:if (cl:= 32 sb!vm:n-word-bits) '(and) '(or))
1121 (simple-array-unsigned-byte-29
1122 :translation (simple-array (unsigned-byte 29) (*))
1123 :codes (#.sb!vm:simple-array-unsigned-byte-29-widetag)
1124 :direct-superclasses (vector simple-array)
1125 :inherits (vector simple-array array sequence)
1126 :prototype-form (make-array 0 :element-type '(unsigned-byte 29)))
1127 (simple-array-unsigned-byte-31
1128 :translation (simple-array (unsigned-byte 31) (*))
1129 :codes (#.sb!vm:simple-array-unsigned-byte-31-widetag)
1130 :direct-superclasses (vector simple-array)
1131 :inherits (vector simple-array array sequence)
1132 :prototype-form (make-array 0 :element-type '(unsigned-byte 31)))
1133 (simple-array-unsigned-byte-32
1134 :translation (simple-array (unsigned-byte 32) (*))
1135 :codes (#.sb!vm:simple-array-unsigned-byte-32-widetag)
1136 :direct-superclasses (vector simple-array)
1137 :inherits (vector simple-array array sequence)
1138 :prototype-form (make-array 0 :element-type '(unsigned-byte 32)))
1139 #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
1140 (simple-array-unsigned-byte-60
1141 :translation (simple-array (unsigned-byte 60) (*))
1142 :codes (#.sb!vm:simple-array-unsigned-byte-60-widetag)
1143 :direct-superclasses (vector simple-array)
1144 :inherits (vector simple-array array sequence)
1145 :prototype-form (make-array 0 :element-type '(unsigned-byte 60)))
1146 #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
1147 (simple-array-unsigned-byte-63
1148 :translation (simple-array (unsigned-byte 63) (*))
1149 :codes (#.sb!vm:simple-array-unsigned-byte-63-widetag)
1150 :direct-superclasses (vector simple-array)
1151 :inherits (vector simple-array array sequence)
1152 :prototype-form (make-array 0 :element-type '(unsigned-byte 63)))
1153 #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
1154 (simple-array-unsigned-byte-64
1155 :translation (simple-array (unsigned-byte 64) (*))
1156 :codes (#.sb!vm:simple-array-unsigned-byte-64-widetag)
1157 :direct-superclasses (vector simple-array)
1158 :inherits (vector simple-array array sequence)
1159 :prototype-form (make-array 0 :element-type '(unsigned-byte 64)))
1160 (simple-array-signed-byte-8
1161 :translation (simple-array (signed-byte 8) (*))
1162 :codes (#.sb!vm:simple-array-signed-byte-8-widetag)
1163 :direct-superclasses (vector simple-array)
1164 :inherits (vector simple-array array sequence)
1165 :prototype-form (make-array 0 :element-type '(signed-byte 8)))
1166 (simple-array-signed-byte-16
1167 :translation (simple-array (signed-byte 16) (*))
1168 :codes (#.sb!vm:simple-array-signed-byte-16-widetag)
1169 :direct-superclasses (vector simple-array)
1170 :inherits (vector simple-array array sequence)
1171 :prototype-form (make-array 0 :element-type '(signed-byte 16)))
1172 #!+#.(cl:if (cl:= 32 sb!vm:n-word-bits) '(and) '(or))
1173 (simple-array-signed-byte-30
1174 :translation (simple-array (signed-byte 30) (*))
1175 :codes (#.sb!vm:simple-array-signed-byte-30-widetag)
1176 :direct-superclasses (vector simple-array)
1177 :inherits (vector simple-array array sequence)
1178 :prototype-form (make-array 0 :element-type '(signed-byte 30)))
1179 (simple-array-signed-byte-32
1180 :translation (simple-array (signed-byte 32) (*))
1181 :codes (#.sb!vm:simple-array-signed-byte-32-widetag)
1182 :direct-superclasses (vector simple-array)
1183 :inherits (vector simple-array array sequence)
1184 :prototype-form (make-array 0 :element-type '(signed-byte 32)))
1185 #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
1186 (simple-array-signed-byte-61
1187 :translation (simple-array (signed-byte 61) (*))
1188 :codes (#.sb!vm:simple-array-signed-byte-61-widetag)
1189 :direct-superclasses (vector simple-array)
1190 :inherits (vector simple-array array sequence)
1191 :prototype-form (make-array 0 :element-type '(signed-byte 61)))
1192 #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
1193 (simple-array-signed-byte-64
1194 :translation (simple-array (signed-byte 64) (*))
1195 :codes (#.sb!vm:simple-array-signed-byte-64-widetag)
1196 :direct-superclasses (vector simple-array)
1197 :inherits (vector simple-array array sequence)
1198 :prototype-form (make-array 0 :element-type '(signed-byte 64)))
1199 (simple-array-single-float
1200 :translation (simple-array single-float (*))
1201 :codes (#.sb!vm:simple-array-single-float-widetag)
1202 :direct-superclasses (vector simple-array)
1203 :inherits (vector simple-array array sequence)
1204 :prototype-form (make-array 0 :element-type 'single-float))
1205 (simple-array-double-float
1206 :translation (simple-array double-float (*))
1207 :codes (#.sb!vm:simple-array-double-float-widetag)
1208 :direct-superclasses (vector simple-array)
1209 :inherits (vector simple-array array sequence)
1210 :prototype-form (make-array 0 :element-type 'double-float))
1212 (simple-array-long-float
1213 :translation (simple-array long-float (*))
1214 :codes (#.sb!vm:simple-array-long-float-widetag)
1215 :direct-superclasses (vector simple-array)
1216 :inherits (vector simple-array array sequence)
1217 :prototype-form (make-array 0 :element-type 'long-float))
1218 (simple-array-complex-single-float
1219 :translation (simple-array (complex single-float) (*))
1220 :codes (#.sb!vm:simple-array-complex-single-float-widetag)
1221 :direct-superclasses (vector simple-array)
1222 :inherits (vector simple-array array sequence)
1223 :prototype-form (make-array 0 :element-type '(complex single-float)))
1224 (simple-array-complex-double-float
1225 :translation (simple-array (complex double-float) (*))
1226 :codes (#.sb!vm:simple-array-complex-double-float-widetag)
1227 :direct-superclasses (vector simple-array)
1228 :inherits (vector simple-array array sequence)
1229 :prototype-form (make-array 0 :element-type '(complex double-float)))
1231 (simple-array-complex-long-float
1232 :translation (simple-array (complex long-float) (*))
1233 :codes (#.sb!vm:simple-array-complex-long-float-widetag)
1234 :direct-superclasses (vector simple-array)
1235 :inherits (vector simple-array array sequence)
1236 :prototype-form (make-array 0 :element-type '(complex long-float)))
1239 :direct-superclasses (vector)
1240 :inherits (vector array sequence))
1242 :translation simple-string
1243 :direct-superclasses (string simple-array)
1244 :inherits (string vector simple-array array sequence))
1246 :translation (vector nil)
1247 :codes (#.sb!vm:complex-vector-nil-widetag)
1248 :direct-superclasses (string)
1249 :inherits (string vector array sequence)
1250 :prototype-form (make-array 0 :element-type 'nil :fill-pointer t))
1252 :translation (simple-array nil (*))
1253 :codes (#.sb!vm:simple-array-nil-widetag)
1254 :direct-superclasses (vector-nil simple-string)
1255 :inherits (vector-nil simple-string string vector simple-array
1257 :prototype-form (make-array 0 :element-type 'nil))
1259 :translation base-string
1260 :codes (#.sb!vm:complex-base-string-widetag)
1261 :direct-superclasses (string)
1262 :inherits (string vector array sequence)
1263 :prototype-form (make-array 0 :element-type 'base-char :fill-pointer t))
1265 :translation simple-base-string
1266 :codes (#.sb!vm:simple-base-string-widetag)
1267 :direct-superclasses (base-string simple-string)
1268 :inherits (base-string simple-string string vector simple-array
1270 :prototype-form (make-array 0 :element-type 'base-char))
1273 :translation (vector character)
1274 :codes (#.sb!vm:complex-character-string-widetag)
1275 :direct-superclasses (string)
1276 :inherits (string vector array sequence)
1277 :prototype-form (make-array 0 :element-type 'character :fill-pointer t))
1279 (simple-character-string
1280 :translation (simple-array character (*))
1281 :codes (#.sb!vm:simple-character-string-widetag)
1282 :direct-superclasses (character-string simple-string)
1283 :inherits (character-string simple-string string vector simple-array
1285 :prototype-form (make-array 0 :element-type 'character))
1287 :translation (or cons (member nil))
1288 :inherits (sequence))
1290 :codes (#.sb!vm:list-pointer-lowtag)
1292 :inherits (list sequence)
1293 :prototype-form (cons nil nil))
1295 :translation (member nil)
1296 :inherits (symbol list sequence)
1297 :direct-superclasses (symbol list)
1298 :prototype-form 'nil)
1309 :inherits (stream)))))
1311 ;;; See also src/code/class-init.lisp where we finish setting up the
1312 ;;; translations for built-in types.
1314 (dolist (x *built-in-classes*)
1315 #-sb-xc-host (/show0 "at head of loop over *BUILT-IN-CLASSES*")
1318 (translation nil trans-p)
1325 (hierarchical-p t) ; might be modified below
1326 (direct-superclasses (if inherits
1327 (list (car inherits))
1330 (declare (ignore codes state translation prototype-form))
1331 (let ((inherits-list (if (eq name t)
1333 (cons t (reverse inherits))))
1334 (classoid (make-built-in-classoid
1335 :enumerable enumerable
1337 :translation (if trans-p :initializing nil)
1338 :direct-superclasses
1341 (mapcar #'find-classoid direct-superclasses)))))
1342 (setf (info :type :kind name) #+sb-xc-host :defined #-sb-xc-host :primitive
1343 (classoid-cell-classoid (find-classoid-cell name)) classoid)
1345 (setf (info :type :builtin name) classoid))
1346 (let* ((inherits-vector
1350 (classoid-layout (find-classoid x))))
1351 (when (minusp (layout-depthoid super-layout))
1352 (setf hierarchical-p nil))
1355 (depthoid (if hierarchical-p
1356 (or depth (length inherits-vector))
1359 (find-and-init-or-check-layout name
1364 :invalidate nil)))))
1365 (/show0 "done with loop over *BUILT-IN-CLASSES*"))
1367 ;;; Define temporary PCL STANDARD-CLASSes. These will be set up
1368 ;;; correctly and the Lisp layout replaced by a PCL wrapper after PCL
1369 ;;; is loaded and the class defined.
1371 (/show0 "about to define temporary STANDARD-CLASSes")
1372 (dolist (x '(;; Why is STREAM duplicated in this list? Because, when
1373 ;; the inherits-vector of FUNDAMENTAL-STREAM is set up,
1374 ;; a vector containing the elements of the list below,
1375 ;; i.e. '(T STREAM STREAM), is created, and
1376 ;; this is what the function ORDER-LAYOUT-INHERITS
1379 ;; So, the purpose is to guarantee a valid layout for
1380 ;; the FUNDAMENTAL-STREAM class, matching what
1381 ;; ORDER-LAYOUT-INHERITS would do.
1382 ;; ORDER-LAYOUT-INHERITS would place STREAM at index 2
1383 ;; in the INHERITS(-VECTOR). Index 1 would not be
1384 ;; filled, so STREAM is duplicated there (as
1385 ;; ORDER-LAYOUTS-INHERITS would do). Maybe the
1386 ;; duplicate definition could be removed (removing a
1387 ;; STREAM element), because FUNDAMENTAL-STREAM is
1388 ;; redefined after PCL is set up, anyway. But to play
1389 ;; it safely, we define the class with a valid INHERITS
1391 (fundamental-stream (t stream stream))))
1392 (/show0 "defining temporary STANDARD-CLASS")
1393 (let* ((name (first x))
1394 (inherits-list (second x))
1395 (classoid (make-standard-classoid :name name))
1396 (classoid-cell (find-classoid-cell name)))
1397 ;; Needed to open-code the MAP, below
1398 (declare (type list inherits-list))
1399 (setf (classoid-cell-classoid classoid-cell) classoid
1400 (info :type :classoid name) classoid-cell
1401 (info :type :kind name) :instance)
1402 (let ((inherits (map 'simple-vector
1404 (classoid-layout (find-classoid x)))
1406 #-sb-xc-host (/show0 "INHERITS=..") #-sb-xc-host (/hexstr inherits)
1407 (register-layout (find-and-init-or-check-layout name 0 inherits -1 0)
1409 (/show0 "done defining temporary STANDARD-CLASSes"))
1411 ;;; Now that we have set up the class heterarchy, seal the sealed
1412 ;;; classes. This must be done after the subclasses have been set up.
1414 (dolist (x *built-in-classes*)
1415 (destructuring-bind (name &key (state :sealed) &allow-other-keys) x
1416 (setf (classoid-state (find-classoid name)) state))))
1418 ;;;; class definition/redefinition
1420 ;;; This is to be called whenever we are altering a class.
1421 (defun modify-classoid (classoid)
1423 (when (member (classoid-state classoid) '(:read-only :frozen))
1424 ;; FIXME: This should probably be CERROR.
1425 (warn "making ~(~A~) class ~S writable"
1426 (classoid-state classoid)
1427 (classoid-name classoid))
1428 (setf (classoid-state classoid) nil)))
1430 ;;; Mark LAYOUT as invalid. Setting DEPTHOID -1 helps cause unsafe
1431 ;;; structure type tests to fail. Remove class from all superclasses
1432 ;;; too (might not be registered, so might not be in subclasses of the
1433 ;;; nominal superclasses.) We set the layout-clos-hash slots to 0 to
1434 ;;; invalidate the wrappers for specialized dispatch functions, which
1435 ;;; use those slots as indexes into tables.
1436 (defun invalidate-layout (layout)
1437 (declare (type layout layout))
1438 (setf (layout-invalid layout) t
1439 (layout-depthoid layout) -1)
1440 (setf (layout-clos-hash layout) 0)
1441 (let ((inherits (layout-inherits layout))
1442 (classoid (layout-classoid layout)))
1443 (modify-classoid classoid)
1444 (dovector (super inherits)
1445 (let ((subs (classoid-subclasses (layout-classoid super))))
1447 (remhash classoid subs)))))
1450 ;;;; cold loading initializations
1452 ;;; FIXME: It would be good to arrange for this to be called when the
1453 ;;; cross-compiler is being built, not just when the target Lisp is
1454 ;;; being cold loaded. Perhaps this could be moved to its own file
1455 ;;; late in the build-order.lisp-expr sequence, and be put in
1456 ;;; !COLD-INIT-FORMS there?
1457 (defun !class-finalize ()
1458 (dohash (name layout *forward-referenced-layouts*)
1459 (let ((class (find-classoid name nil)))
1461 (setf (layout-classoid layout) (make-undefined-classoid name)))
1462 ((eq (classoid-layout class) layout)
1463 (remhash name *forward-referenced-layouts*))
1466 (warn "something strange with forward layout for ~S:~% ~S"
1471 #-sb-xc-host (/show0 "about to set *BUILT-IN-CLASS-CODES*")
1472 (setq *built-in-class-codes*
1473 (let* ((initial-element
1475 ;; KLUDGE: There's a FIND-CLASSOID DEFTRANSFORM for
1476 ;; constant class names which creates fast but
1477 ;; non-cold-loadable, non-compact code. In this
1478 ;; context, we'd rather have compact, cold-loadable
1479 ;; code. -- WHN 19990928
1480 (declare (notinline find-classoid))
1481 (classoid-layout (find-classoid 'random-class))))
1482 (res (make-array 256 :initial-element initial-element)))
1483 (dolist (x *built-in-classes* res)
1484 (destructuring-bind (name &key codes &allow-other-keys)
1486 (let ((layout (classoid-layout (find-classoid name))))
1487 (dolist (code codes)
1488 (setf (svref res code) layout)))))))
1489 (setq *null-classoid-layout*
1490 ;; KLUDGE: we use (LET () ...) instead of a LOCALLY here to
1491 ;; work around a bug in the LOCALLY handling in the fopcompiler
1492 ;; (present in 0.9.13-0.9.14.18). -- JES, 2006-07-16
1494 (declare (notinline find-classoid))
1495 (classoid-layout (find-classoid 'null))))
1496 #-sb-xc-host (/show0 "done setting *BUILT-IN-CLASS-CODES*"))
1498 (!defun-from-collected-cold-init-forms !classes-cold-init)