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. Some of the functions here are
4 ;;;; nominally generic, and are overwritten when CLOS is loaded.
6 ;;;; This software is part of the SBCL system. See the README file for
9 ;;;; This software is derived from the CMU CL system, which was
10 ;;;; written at Carnegie Mellon University and released into the
11 ;;;; public domain. The software is in the public domain and is
12 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
13 ;;;; files for more information.
15 (in-package "SB!KERNEL")
17 (!begin-collecting-cold-init-forms)
19 ;;;; the CLASS structure
21 ;;; The CLASS structure is a supertype of all class types. A CLASS is
22 ;;; also a CTYPE structure as recognized by the type system.
23 (def!struct (;; FIXME: Yes, these #+SB-XC/#-SB-XC conditionals are
24 ;; pretty hairy. I'm considering cleaner ways to rewrite
25 ;; the whole build system to avoid these (and other hacks
26 ;; too, e.g. UNCROSS) but I'm not sure yet that I've got
27 ;; it figured out. -- WHN 19990729
30 (:make-load-form-fun class-make-load-form-fun)
32 (:class-info (type-class-or-lose #-sb-xc 'sb!xc:class
35 #-no-ansi-print-object
37 (lambda (class stream)
38 (let ((name (sb!xc:class-name class)))
39 (print-unreadable-object (class stream
43 ;; FIXME: Make sure that this prints
44 ;; reasonably for anonymous classes.
45 "~:[anonymous~;~:*~S~]~@[ (~(~A~))~]"
47 (class-state class))))))
48 #-sb-xc-host (:pure nil))
49 ;; the value to be returned by CLASS-NAME. (CMU CL used the raw slot
50 ;; accessor for this slot directly as the definition of
51 ;; CL:CLASS-NAME, but that was slightly wrong, because ANSI says
52 ;; that CL:CLASS-NAME is a generic function.)
53 (%name nil :type symbol)
54 ;; the current layout for this class, or NIL if none assigned yet
55 (layout nil :type (or sb!kernel::layout null))
56 ;; How sure are we that this class won't be redefined?
57 ;; :READ-ONLY = We are committed to not changing the effective
58 ;; slots or superclasses.
59 ;; :SEALED = We can't even add subclasses.
60 ;; NIL = Anything could happen.
61 (state nil :type (member nil :read-only :sealed))
62 ;; direct superclasses of this class
63 (direct-superclasses () :type list)
64 ;; representation of all of the subclasses (direct or indirect) of
65 ;; this class. This is NIL if no subclasses or not initalized yet;
66 ;; otherwise, it's an EQ hash-table mapping CL:CLASS objects to the
67 ;; subclass layout that was in effect at the time the subclass was
69 (subclasses nil :type (or null hash-table))
70 ;; the PCL class object for this class, or NIL if none assigned yet
73 ;;; KLUDGE: ANSI says this is a generic function, but we need it for
74 ;;; bootstrapping before CLOS exists, so we define it as an ordinary
75 ;;; function and let CLOS code overwrite it later. -- WHN ca. 19990815
76 (defun sb!xc:class-name (class)
79 (defun class-make-load-form-fun (class)
80 (/show "entering CLASS-MAKE-LOAD-FORM-FUN" class)
81 (let ((name (sb!xc:class-name class)))
82 (unless (and name (eq (sb!xc:find-class name nil) class))
83 (/show "anonymous/undefined class case")
84 (error "can't use anonymous or undefined class as constant:~% ~S"
87 ;; KLUDGE: There's a FIND-CLASS DEFTRANSFORM for constant class
88 ;; names which creates fast but non-cold-loadable, non-compact
89 ;; code. In this context, we'd rather have compact,
90 ;; cold-loadable code. -- WHN 19990928
91 (declare (notinline sb!xc:find-class))
92 (sb!xc:find-class ',name))))
94 ;;;; basic LAYOUT stuff
96 ;;; Note: This bound is set somewhat less than MOST-POSITIVE-FIXNUM
97 ;;; in order to guarantee that several hash values can be added without
98 ;;; overflowing into a bignum.
99 (defconstant layout-clos-hash-max (ash most-positive-fixnum -3)
101 "the inclusive upper bound on LAYOUT-CLOS-HASH values")
103 ;;; a list of conses, initialized by genesis
105 ;;; In each cons, the car is the symbol naming the layout, and the
106 ;;; cdr is the layout itself.
107 (defvar *!initial-layouts*)
109 ;;; a table mapping class names to layouts for classes we have
110 ;;; referenced but not yet loaded. This is initialized from an alist
111 ;;; created by genesis describing the layouts that genesis created at
113 (defvar *forward-referenced-layouts*)
115 (setq *forward-referenced-layouts* (make-hash-table :test 'equal))
117 (/show0 "processing *!INITIAL-LAYOUTS*")
118 (dolist (x *!initial-layouts*)
119 (setf (gethash (car x) *forward-referenced-layouts*)
121 (/show0 "done processing *!INITIAL-LAYOUTS*")))
123 ;;; The LAYOUT structure is pointed to by the first cell of instance
124 ;;; (or structure) objects. It represents what we need to know for
125 ;;; type checking and garbage collection. Whenever a class is
126 ;;; incompatibly redefined, a new layout is allocated. If two object's
127 ;;; layouts are EQ, then they are exactly the same type.
129 ;;; KLUDGE: The genesis code has raw offsets of slots in this
130 ;;; structure hardwired into it. It would be good to rewrite that code
131 ;;; so that it looks up those offsets in the compiler's tables, but
132 ;;; for now if you change this structure, lucky you, you get to grovel
133 ;;; over the genesis code by hand.:-( -- WHN 19990820
135 ;; KLUDGE: A special hack keeps this from being
136 ;; called when building code for the
137 ;; cross-compiler. See comments at the DEFUN for
138 ;; this. -- WHN 19990914
139 (:make-load-form-fun #-sb-xc-host ignore-it
140 ;; KLUDGE: DEF!STRUCT at #+SB-XC-HOST
141 ;; time controls both the
142 ;; build-the-cross-compiler behavior
143 ;; and the run-the-cross-compiler
144 ;; behavior. The value below only
145 ;; works for build-the-cross-compiler.
146 ;; There's a special hack in
147 ;; EMIT-MAKE-LOAD-FORM which gives
148 ;; effectively IGNORE-IT behavior for
149 ;; LAYOUT at run-the-cross-compiler
150 ;; time. It would be cleaner to
151 ;; actually have an IGNORE-IT value
152 ;; stored, but it's hard to see how to
153 ;; do that concisely with the current
154 ;; DEF!STRUCT setup. -- WHN 19990930
156 make-load-form-for-layout))
157 ;; hash bits which should be set to constant pseudo-random values
158 ;; for use by CLOS. Sleazily accessed via %INSTANCE-REF, see
161 ;; FIXME: We should get our story straight on what the type of these
162 ;; values is. (declared INDEX here, described as <=
163 ;; LAYOUT-CLOS-HASH-MAX by the doc string of that constant,
164 ;; generated as strictly positive in RANDOM-LAYOUT-CLOS-HASH..)
166 ;; KLUDGE: The fact that the slots here start at offset 1 is known
167 ;; to the LAYOUT-CLOS-HASH function and to the LAYOUT-dumping code
169 (clos-hash-0 (random-layout-clos-hash) :type index)
170 (clos-hash-1 (random-layout-clos-hash) :type index)
171 (clos-hash-2 (random-layout-clos-hash) :type index)
172 (clos-hash-3 (random-layout-clos-hash) :type index)
173 (clos-hash-4 (random-layout-clos-hash) :type index)
174 (clos-hash-5 (random-layout-clos-hash) :type index)
175 (clos-hash-6 (random-layout-clos-hash) :type index)
176 (clos-hash-7 (random-layout-clos-hash) :type index)
177 ;; the class that this is a layout for
179 ;; FIXME: Do we really know this is a CL:CLASS? Mightn't it
180 ;; be a SB-PCL:CLASS under some circumstances? What goes here
181 ;; when the LAYOUT is in fact a PCL::WRAPPER?
182 :type #-sb-xc sb!xc:class #+sb-xc cl:class)
183 ;; The value of this slot can be:
184 ;; * :UNINITIALIZED if not initialized yet;
185 ;; * NIL if this is the up-to-date layout for a class; or
186 ;; * T if this layout has been invalidated (by being replaced by
187 ;; a new, more-up-to-date LAYOUT).
188 ;; * something else (probably a list) if the class is a PCL wrapper
189 ;; and PCL has made it invalid and made a note to itself about it
190 (invalid :uninitialized :type (or cons (member nil t :uninitialized)))
191 ;; the layouts for all classes we inherit. If hierarchical, i.e. if
192 ;; DEPTHOID >= 0, then these are ordered by ORDER-LAYOUT-INHERITS,
193 ;; so that each inherited layout appears at its expected depth,
194 ;; i.e. at its LAYOUT-DEPTHOID value.
196 ;; Remaining elements are filled by the non-hierarchical layouts or,
197 ;; if they would otherwise be empty, by copies of succeeding layouts.
198 (inherits #() :type simple-vector)
199 ;; If inheritance is not hierarchical, this is -1. If inheritance is
200 ;; hierarchical, this is the inheritance depth, i.e. (LENGTH INHERITS).
202 ;; (1) This turns out to be a handy encoding for arithmetically
203 ;; comparing deepness; it is generally useful to do a bare numeric
204 ;; comparison of these depthoid values, and we hardly ever need to
205 ;; test whether the values are negative or not.
206 ;; (2) This was called INHERITANCE-DEPTH in classic CMU CL. It was
207 ;; renamed because some of us find it confusing to call something
208 ;; a depth when it isn't quite.
209 (depthoid -1 :type layout-depthoid)
210 ;; the number of top level descriptor cells in each instance
211 (length 0 :type index)
212 ;; If this layout has some kind of compiler meta-info, then this is
213 ;; it. If a structure, then we store the DEFSTRUCT-DESCRIPTION here.
215 ;; This is true if objects of this class are never modified to
216 ;; contain dynamic pointers in their slots or constant-like
217 ;; substructure (and hence can be copied into read-only space by
220 ;; KLUDGE: This slot is known to the C runtime support code.
221 (pure nil :type (member t nil 0)))
223 (def!method print-object ((layout layout) stream)
224 (print-unreadable-object (layout stream :type t :identity t)
226 "for ~S~@[, INVALID=~S~]"
227 (layout-proper-name layout)
228 (layout-invalid layout))))
230 (eval-when (:compile-toplevel :load-toplevel :execute)
231 (defun layout-proper-name (layout)
232 (class-proper-name (layout-class layout))))
234 ;;;; support for the hash values used by CLOS when working with LAYOUTs
236 (defconstant layout-clos-hash-length 8)
237 #!-sb-fluid (declaim (inline layout-clos-hash))
238 (defun layout-clos-hash (layout i)
239 ;; FIXME: Either this I should be declared to be `(MOD
240 ;; ,LAYOUT-CLOS-HASH-LENGTH), or this is used in some inner loop
241 ;; where we can't afford to check that kind of thing and therefore
242 ;; should have some insane level of optimization. (This is true both
243 ;; of this function and of the SETF function below.)
244 (declare (type layout layout) (type index i))
245 ;; FIXME: LAYOUT slots should have type `(MOD ,LAYOUT-CLOS-HASH-MAX),
247 (truly-the index (%instance-ref layout (1+ i))))
248 #!-sb-fluid (declaim (inline (setf layout-clos-hash)))
249 (defun (setf layout-clos-hash) (new-value layout i)
250 (declare (type layout layout) (type index new-value i))
251 (setf (%instance-ref layout (1+ i)) new-value))
253 ;;; a generator for random values suitable for the CLOS-HASH slots of
254 ;;; LAYOUTs. We use our own RANDOM-STATE here because we'd like
255 ;;; pseudo-random values to come the same way in the target even when
256 ;;; we make minor changes to the system, in order to reduce the
257 ;;; mysteriousness of possible CLOS bugs.
258 (defvar *layout-clos-hash-random-state*)
259 (defun random-layout-clos-hash ()
260 ;; FIXME: I'm not sure why this expression is (1+ (RANDOM FOO)),
261 ;; returning a strictly positive value. I copied it verbatim from
262 ;; CMU CL INITIALIZE-LAYOUT-HASH, so presumably it works, but I
263 ;; dunno whether the hash values are really supposed to be 1-based.
264 ;; They're declared as INDEX.. Or is this a hack to try to avoid
265 ;; having to use bignum arithmetic? Or what? An explanation would be
267 (1+ (random layout-clos-hash-max
268 (if (boundp '*layout-clos-hash-random-state*)
269 *layout-clos-hash-random-state*
270 (setf *layout-clos-hash-random-state*
271 (make-random-state))))))
273 ;;; If we can't find any existing layout, then we create a new one
274 ;;; storing it in *FORWARD-REFERENCED-LAYOUTS*. In classic CMU CL, we
275 ;;; used to immediately check for compatibility, but for
276 ;;; cross-compilability reasons (i.e. convenience of using this
277 ;;; function in a MAKE-LOAD-FORM expression) that functionality has
278 ;;; been split off into INIT-OR-CHECK-LAYOUT.
279 (declaim (ftype (function (symbol) layout) find-layout))
280 (defun find-layout (name)
281 (let ((class (sb!xc:find-class name nil)))
282 (or (and class (class-layout class))
283 (gethash name *forward-referenced-layouts*)
284 (setf (gethash name *forward-referenced-layouts*)
285 (make-layout :class (or class (make-undefined-class name)))))))
287 ;;; If LAYOUT is uninitialized, initialize it with CLASS, LENGTH,
288 ;;; INHERITS, and DEPTHOID, otherwise require that it be consistent
289 ;;; with CLASS, LENGTH, INHERITS, and DEPTHOID.
291 ;;; UNDEFINED-CLASS values are interpreted specially as "we don't know
292 ;;; anything about the class", so if LAYOUT is initialized, any
293 ;;; preexisting class slot value is OK, and if it's not initialized,
294 ;;; its class slot value is set to an UNDEFINED-CLASS. -- FIXME: This
295 ;;; is no longer true, :UNINITIALIZED used instead.
296 (declaim (ftype (function (layout sb!xc:class index simple-vector layout-depthoid) layout)
297 init-or-check-layout))
298 (defun init-or-check-layout (layout class length inherits depthoid)
299 (cond ((eq (layout-invalid layout) :uninitialized)
300 ;; There was no layout before, we just created one which
301 ;; we'll now initialize with our information.
302 (setf (layout-length layout) length
303 (layout-inherits layout) inherits
304 (layout-depthoid layout) depthoid
305 (layout-class layout) class
306 (layout-invalid layout) nil))
307 ;; FIXME: Now that LAYOUTs are born :UNINITIALIZED, maybe this
308 ;; clause is not needed?
309 ((not *type-system-initialized*)
310 (setf (layout-class layout) class))
312 ;; There was an old layout already initialized with old
313 ;; information, and we'll now check that old information
314 ;; which was known with certainty is consistent with current
315 ;; information which is known with certainty.
316 (check-layout layout class length inherits depthoid)))
319 ;;; In code for the target Lisp, we don't use dump LAYOUTs using the
320 ;;; standard load form mechanism, we use special fops instead, in
321 ;;; order to make cold load come out right. But when we're building
322 ;;; the cross-compiler, we can't do that because we don't have access
323 ;;; to special non-ANSI low-level things like special fops, and we
324 ;;; don't need to do that anyway because our code isn't going to be
325 ;;; cold loaded, so we use the ordinary load form system.
327 ;;; KLUDGE: A special hack causes this not to be called when we are
328 ;;; building code for the target Lisp. It would be tidier to just not
329 ;;; have it in place when we're building the target Lisp, but it
330 ;;; wasn't clear how to do that without rethinking DEF!STRUCT quite a
331 ;;; bit, so I punted. -- WHN 19990914
333 (defun make-load-form-for-layout (layout &optional env)
334 (declare (type layout layout))
335 (declare (ignore env))
336 (when (layout-invalid layout)
337 (compiler-error "can't dump reference to obsolete class: ~S"
338 (layout-class layout)))
339 (let ((name (sb!xc:class-name (layout-class layout))))
341 (compiler-error "can't dump anonymous LAYOUT: ~S" layout))
342 ;; Since LAYOUT refers to a class which refers back to the LAYOUT,
343 ;; we have to do this in two stages, like the TREE-WITH-PARENT
344 ;; example in the MAKE-LOAD-FORM entry in the ANSI spec.
346 ;; "creation" form (which actually doesn't create a new LAYOUT if
347 ;; there's a preexisting one with this name)
348 `(find-layout ',name)
349 ;; "initialization" form (which actually doesn't initialize
350 ;; preexisting LAYOUTs, just checks that they're consistent).
351 `(init-or-check-layout ',layout
352 ',(layout-class layout)
353 ',(layout-length layout)
354 ',(layout-inherits layout)
355 ',(layout-depthoid layout)))))
357 ;;; If LAYOUT's slot values differ from the specified slot values in
358 ;;; any interesting way, then give a warning and return T.
359 (declaim (ftype (function (simple-string
365 redefine-layout-warning))
366 (defun redefine-layout-warning (old-context old-layout
367 context length inherits depthoid)
368 (declare (type layout old-layout) (type simple-string old-context context))
369 (let ((name (layout-proper-name old-layout)))
370 (or (let ((old-inherits (layout-inherits old-layout)))
371 (or (when (mismatch old-inherits
373 :key #'layout-proper-name)
374 (warn "change in superclasses of class ~S:~% ~
375 ~A superclasses: ~S~% ~
379 (map 'list #'layout-proper-name old-inherits)
381 (map 'list #'layout-proper-name inherits))
383 (let ((diff (mismatch old-inherits inherits)))
387 ~:(~A~) definition of superclass ~S is incompatible with~% ~
391 (layout-proper-name (svref old-inherits diff))
394 (let ((old-length (layout-length old-layout)))
395 (unless (= old-length length)
396 (warn "change in instance length of class ~S:~% ~
400 old-context old-length
403 (unless (= (layout-depthoid old-layout) depthoid)
404 (warn "change in the inheritance structure of class ~S~% ~
405 between the ~A definition and the ~A definition"
406 name old-context context)
409 ;;; Require that LAYOUT data be consistent with CLASS, LENGTH,
410 ;;; INHERITS, and DEPTHOID.
411 (declaim (ftype (function (layout sb!xc:class index simple-vector layout-depthoid))
413 (defun check-layout (layout class length inherits depthoid)
414 (aver (eq (layout-class layout) class))
415 (when (redefine-layout-warning "current" layout
416 "compile time" length inherits depthoid)
417 ;; Classic CMU CL had more options here. There are several reasons
418 ;; why they might want more options which are less appropriate for
419 ;; us: (1) It's hard to fit the classic CMU CL flexible approach
420 ;; into the ANSI-style MAKE-LOAD-FORM system, and having a
421 ;; non-MAKE-LOAD-FORM-style system is painful when we're trying to
422 ;; make the cross-compiler run under vanilla ANSI Common Lisp. (2)
423 ;; We have CLOS now, and if you want to be able to flexibly
424 ;; redefine classes without restarting the system, it'd make sense
425 ;; to use that, so supporting complexity in order to allow
426 ;; modifying DEFSTRUCTs without restarting the system is a low
427 ;; priority. (3) We now have the ability to rebuild the SBCL
428 ;; system from scratch, so we no longer need this functionality in
429 ;; order to maintain the SBCL system by modifying running images.
430 (error "The class ~S was not changed, and there's no guarantee that~@
431 the loaded code (which expected another layout) will work."
432 (layout-proper-name layout)))
435 ;;; a common idiom (the same as CMU CL FIND-LAYOUT) rolled up into a
436 ;;; single function call
438 ;;; Used by the loader to forward-reference layouts for classes whose
439 ;;; definitions may not have been loaded yet. This allows type tests
440 ;;; to be loaded when the type definition hasn't been loaded yet.
441 (declaim (ftype (function (symbol index simple-vector layout-depthoid) layout)
442 find-and-init-or-check-layout))
443 (defun find-and-init-or-check-layout (name length inherits depthoid)
444 (let ((layout (find-layout name)))
445 (init-or-check-layout layout
446 (or (sb!xc:find-class name nil)
447 (make-undefined-class name))
452 ;;; Record LAYOUT as the layout for its class, adding it as a subtype
453 ;;; of all superclasses. This is the operation that "installs" a
454 ;;; layout for a class in the type system, clobbering any old layout.
455 ;;; However, this does not modify the class namespace; that is a
456 ;;; separate operation (think anonymous classes.)
457 ;;; -- If INVALIDATE, then all the layouts for any old definition
458 ;;; and subclasses are invalidated, and the SUBCLASSES slot is cleared.
459 ;;; -- If DESTRUCT-LAYOUT, then this is some old layout, and is to be
460 ;;; destructively modified to hold the same type information.
461 (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
462 (defun register-layout (layout &key (invalidate t) destruct-layout)
463 (declare (type layout layout) (type (or layout null) destruct-layout))
464 (let* ((class (layout-class layout))
465 (class-layout (class-layout class))
466 (subclasses (class-subclasses class)))
468 ;; Attempting to register ourselves with a temporary undefined
469 ;; class placeholder is almost certainly a programmer error. (I
470 ;; should know, I did it.) -- WHN 19990927
471 (aver (not (undefined-class-p class)))
473 ;; This assertion dates from classic CMU CL. The rationale is
474 ;; probably that calling REGISTER-LAYOUT more than once for the
475 ;; same LAYOUT is almost certainly a programmer error.
476 (aver (not (eq class-layout layout)))
478 ;; Figure out what classes are affected by the change, and issue
479 ;; appropriate warnings and invalidations.
483 (dohash (subclass subclass-layout subclasses)
484 (modify-class subclass)
486 (invalidate-layout subclass-layout))))
488 (invalidate-layout class-layout)
489 (setf (class-subclasses class) nil)))
492 (setf (layout-invalid destruct-layout) nil
493 (layout-inherits destruct-layout) (layout-inherits layout)
494 (layout-depthoid destruct-layout)(layout-depthoid layout)
495 (layout-length destruct-layout) (layout-length layout)
496 (layout-info destruct-layout) (layout-info layout)
497 (class-layout class) destruct-layout)
498 (setf (layout-invalid layout) nil
499 (class-layout class) layout))
501 (let ((inherits (layout-inherits layout)))
502 (dotimes (i (length inherits)) ; FIXME: should be DOVECTOR
503 (let* ((super (layout-class (svref inherits i)))
504 (subclasses (or (class-subclasses super)
505 (setf (class-subclasses super)
506 (make-hash-table :test 'eq)))))
507 (when (and (eq (class-state super) :sealed)
508 (not (gethash class subclasses)))
509 (warn "unsealing sealed class ~S in order to subclass it"
510 (sb!xc:class-name super))
511 (setf (class-state super) :read-only))
512 (setf (gethash class subclasses)
513 (or destruct-layout layout))))))
518 ;;; Arrange the inherited layouts to appear at their expected depth,
519 ;;; ensuring that hierarchical type tests succeed. Layouts with
520 ;;; DEPTHOID >= 0 (i.e. hierarchical classes) are placed first,
521 ;;; at exactly that index in the INHERITS vector. Then, non-hierarchical
522 ;;; layouts are placed in remaining elements. Then, any still-empty
523 ;;; elements are filled with their successors, ensuring that each
524 ;;; element contains a valid layout.
526 ;;; This reordering may destroy CPL ordering, so the inherits should
527 ;;; not be read as being in CPL order.
528 (defun order-layout-inherits (layouts)
529 (declare (simple-vector layouts))
530 (let ((length (length layouts))
533 (let ((depth (layout-depthoid (svref layouts i))))
534 (when (> depth max-depth)
535 (setf max-depth depth))))
536 (let* ((new-length (max (1+ max-depth) length))
537 (inherits (make-array new-length)))
539 (let* ((layout (svref layouts i))
540 (depth (layout-depthoid layout)))
541 (unless (eql depth -1)
542 (let ((old-layout (svref inherits depth)))
543 (unless (or (eql old-layout 0) (eq old-layout layout))
544 (error "layout depth conflict: ~S~%" layouts)))
545 (setf (svref inherits depth) layout))))
549 (declare (type index i j))
550 (let* ((layout (svref layouts i))
551 (depth (layout-depthoid layout)))
553 (loop (when (eql (svref inherits j) 0)
556 (setf (svref inherits j) layout))))
557 (do ((i (1- new-length) (1- i)))
559 (declare (type fixnum i))
560 (when (eql (svref inherits i) 0)
561 (setf (svref inherits i) (svref inherits (1+ i)))))
564 ;;;; class precedence lists
566 ;;; Topologically sort the list of objects to meet a set of ordering
567 ;;; constraints given by pairs (A . B) constraining A to precede B.
568 ;;; When there are multiple objects to choose, the tie-breaker
569 ;;; function is called with both the list of object to choose from and
570 ;;; the reverse ordering built so far.
571 (defun topological-sort (objects constraints tie-breaker)
572 (declare (list objects constraints)
573 (function tie-breaker))
574 (let ((obj-info (make-hash-table :size (length objects)))
577 (dolist (constraint constraints)
578 (let ((obj1 (car constraint))
579 (obj2 (cdr constraint)))
580 (let ((info2 (gethash obj2 obj-info)))
583 (setf (gethash obj2 obj-info) (list 1))))
584 (let ((info1 (gethash obj1 obj-info)))
586 (push obj2 (rest info1))
587 (setf (gethash obj1 obj-info) (list 0 obj2))))))
588 (dolist (obj objects)
589 (let ((info (gethash obj obj-info)))
590 (when (or (not info) (zerop (first info)))
591 (push obj free-objs))))
593 (flet ((next-result (obj)
595 (dolist (successor (rest (gethash obj obj-info)))
596 (let* ((successor-info (gethash successor obj-info))
597 (count (1- (first successor-info))))
598 (setf (first successor-info) count)
600 (push successor free-objs))))))
601 (cond ((endp free-objs)
602 (dohash (obj info obj-info)
603 (unless (zerop (first info))
604 (error "Topological sort failed due to constraint on ~S."
606 (return (nreverse result)))
607 ((endp (rest free-objs))
608 (next-result (pop free-objs)))
610 (let ((obj (funcall tie-breaker free-objs result)))
611 (setf free-objs (remove obj free-objs))
612 (next-result obj))))))))
615 ;;; standard class precedence list computation
616 (defun std-compute-class-precedence-list (class)
619 (labels ((note-class (class)
620 (unless (member class classes)
622 (let ((superclasses (class-direct-superclasses class)))
624 (rest superclasses (rest rest)))
626 (let ((next (first rest)))
627 (push (cons prev next) constraints)
629 (dolist (class superclasses)
630 (note-class class)))))
631 (std-cpl-tie-breaker (free-classes rev-cpl)
632 (dolist (class rev-cpl (first free-classes))
633 (let* ((superclasses (class-direct-superclasses class))
634 (intersection (intersection free-classes
637 (return (first intersection)))))))
639 (topological-sort classes constraints #'std-cpl-tie-breaker))))
641 ;;;; object types to represent classes
643 ;;; An UNDEFINED-CLASS is a cookie we make up to stick in forward
644 ;;; referenced layouts. Users should never see them.
645 (def!struct (undefined-class (:include #-sb-xc sb!xc:class
647 (:constructor make-undefined-class (%name))))
649 ;;; BUILT-IN-CLASS is used to represent the standard classes that
650 ;;; aren't defined with DEFSTRUCT and other specially implemented
651 ;;; primitive types whose only attribute is their name.
653 ;;; Some BUILT-IN-CLASSes have a TRANSLATION, which means that they
654 ;;; are effectively DEFTYPE'd to some other type (usually a union of
655 ;;; other classes or a "primitive" type such as NUMBER, ARRAY, etc.)
656 ;;; This translation is done when type specifiers are parsed. Type
657 ;;; system operations (union, subtypep, etc.) should never encounter
658 ;;; translated classes, only their translation.
659 (def!struct (sb!xc:built-in-class (:include #-sb-xc sb!xc:class
661 (:constructor bare-make-built-in-class))
662 ;; the type we translate to on parsing. If NIL, then this class
663 ;; stands on its own; or it can be set to :INITIALIZING for a period
665 (translation nil :type (or ctype (member nil :initializing))))
666 (defun make-built-in-class (&rest rest)
667 (apply #'bare-make-built-in-class
668 (rename-key-args '((:name :%name)) rest)))
670 ;;; FIXME: In CMU CL, this was a class with a print function, but not
671 ;;; necessarily a structure class (e.g. CONDITIONs). In SBCL,
672 ;;; we let CLOS handle our print functions, so that is no longer needed.
673 ;;; Is there any need for this class any more?
674 (def!struct (slot-class (:include #-sb-xc sb!xc:class #+sb-xc cl:class)
677 ;;; STRUCTURE-CLASS represents what we need to know about structure
678 ;;; classes. Non-structure "typed" defstructs are a special case, and
679 ;;; don't have a corresponding class.
680 (def!struct (basic-structure-class (:include slot-class)
683 (def!struct (sb!xc:structure-class (:include basic-structure-class)
684 (:constructor bare-make-structure-class))
685 ;; If true, a default keyword constructor for this structure.
686 (constructor nil :type (or function null)))
687 (defun make-structure-class (&rest rest)
688 (apply #'bare-make-structure-class
689 (rename-key-args '((:name :%name)) rest)))
691 ;;; FUNCALLABLE-STRUCTURE-CLASS is used to represent funcallable
692 ;;; structures, which are used to implement generic functions.
693 (def!struct (funcallable-structure-class (:include basic-structure-class)
694 (:constructor bare-make-funcallable-structure-class)))
695 (defun make-funcallable-structure-class (&rest rest)
696 (apply #'bare-make-funcallable-structure-class
697 (rename-key-args '((:name :%name)) rest)))
701 ;;; We use an indirection to allow forward referencing of class
702 ;;; definitions with load-time resolution.
703 (def!struct (class-cell
704 (:constructor make-class-cell (name &optional class))
705 (:make-load-form-fun (lambda (c)
706 `(find-class-cell ',(class-cell-name c))))
707 #-no-ansi-print-object
708 (:print-object (lambda (s stream)
709 (print-unreadable-object (s stream :type t)
710 (prin1 (class-cell-name s) stream)))))
711 ;; Name of class we expect to find.
712 (name nil :type symbol :read-only t)
713 ;; Class or NIL if not yet defined.
714 (class nil :type (or #-sb-xc sb!xc:class #+sb-xc cl:class
716 (defun find-class-cell (name)
717 (or (info :type :class name)
718 (setf (info :type :class name)
719 (make-class-cell name))))
721 ;;; FIXME: When the system is stable, this DECLAIM FTYPE should
722 ;;; probably go away in favor of the DEFKNOWN for FIND-CLASS.
723 (declaim (ftype (function (symbol &optional t (or null sb!c::lexenv))) sb!xc:find-class))
724 (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
725 (defun sb!xc:find-class (name &optional (errorp t) environment)
727 "Return the class with the specified NAME. If ERRORP is false, then NIL is
728 returned when no such class exists."
729 (declare (type symbol name) (ignore environment))
730 (let ((res (class-cell-class (find-class-cell name))))
731 (if (or res (not errorp))
733 (error "class not yet defined:~% ~S" name))))
734 (defun (setf sb!xc:find-class) (new-value name)
735 #-sb-xc (declare (type sb!xc:class new-value))
736 (ecase (info :type :kind name)
739 (let ((old (class-of (sb!xc:find-class name)))
740 (new (class-of new-value)))
742 (warn "changing meta-class of ~S from ~S to ~S"
747 (error "illegal to redefine standard type ~S" name))
749 (warn "redefining DEFTYPE type to be a class: ~S" name)
750 (setf (info :type :expander name) nil)))
752 (remhash name *forward-referenced-layouts*)
753 (%note-type-defined name)
754 (setf (info :type :kind name) :instance)
755 (setf (class-cell-class (find-class-cell name)) new-value)
756 (unless (eq (info :type :compiler-layout name)
757 (class-layout new-value))
758 (setf (info :type :compiler-layout name) (class-layout new-value)))
762 ;;; Called when we are about to define NAME as a class meeting some
763 ;;; predicate (such as a meta-class type test.) The first result is
764 ;;; always of the desired class. The second result is any existing
765 ;;; LAYOUT for this name.
766 (defun insured-find-class (name predicate constructor)
767 (declare (type function predicate constructor))
768 (let* ((old (sb!xc:find-class name nil))
769 (res (if (and old (funcall predicate old))
771 (funcall constructor :name name)))
772 (found (or (gethash name *forward-referenced-layouts*)
773 (when old (class-layout old)))))
775 (setf (layout-class found) res))
778 ;;; If the class has a proper name, return the name, otherwise return
780 (defun class-proper-name (class)
781 #-sb-xc (declare (type sb!xc:class class))
782 (let ((name (sb!xc:class-name class)))
783 (if (and name (eq (sb!xc:find-class name nil) class))
787 ;;;; CLASS type operations
789 (!define-type-class sb!xc:class)
791 ;;; Simple methods for TYPE= and SUBTYPEP should never be called when
792 ;;; the two classes are equal, since there are EQ checks in those
794 (!define-type-method (sb!xc:class :simple-=) (type1 type2)
795 (aver (not (eq type1 type2)))
798 (!define-type-method (sb!xc:class :simple-subtypep) (class1 class2)
799 (aver (not (eq class1 class2)))
800 (let ((subclasses (class-subclasses class2)))
801 (if (and subclasses (gethash class1 subclasses))
805 ;;; When finding the intersection of a sealed class and some other
806 ;;; class (not hierarchically related) the intersection is the union
807 ;;; of the currently shared subclasses.
808 (defun sealed-class-intersection2 (sealed other)
809 (declare (type sb!xc:class sealed other))
810 (let ((s-sub (class-subclasses sealed))
811 (o-sub (class-subclasses other)))
812 (if (and s-sub o-sub)
813 (collect ((res *empty-type* type-union))
814 (dohash (subclass layout s-sub)
815 (declare (ignore layout))
816 (when (gethash subclass o-sub)
817 (res (specifier-type subclass))))
821 (!define-type-method (sb!xc:class :simple-intersection2) (class1 class2)
822 (declare (type sb!xc:class class1 class2))
823 (cond ((eq class1 class2)
825 ;; If one is a subclass of the other, then that is the
827 ((let ((subclasses (class-subclasses class2)))
828 (and subclasses (gethash class1 subclasses)))
830 ((let ((subclasses (class-subclasses class1)))
831 (and subclasses (gethash class2 subclasses)))
833 ;; Otherwise, we can't in general be sure that the
834 ;; intersection is empty, since a subclass of both might be
835 ;; defined. But we can eliminate it for some special cases.
836 ((or (basic-structure-class-p class1)
837 (basic-structure-class-p class2))
838 ;; No subclass of both can be defined.
840 ((eq (class-state class1) :sealed)
841 ;; checking whether a subclass of both can be defined:
842 (sealed-class-intersection2 class1 class2))
843 ((eq (class-state class2) :sealed)
844 ;; checking whether a subclass of both can be defined:
845 (sealed-class-intersection2 class2 class1))
847 ;; uncertain, since a subclass of both might be defined
850 (!define-type-method (sb!xc:class :unparse) (type)
851 (class-proper-name type))
855 (def!struct (std-class (:include sb!xc:class)
857 (def!struct (sb!xc:standard-class (:include std-class)
858 (:constructor bare-make-standard-class)))
859 (def!struct (random-pcl-class (:include std-class)
860 (:constructor bare-make-random-pcl-class)))
861 (defun make-standard-class (&rest rest)
862 (apply #'bare-make-standard-class
863 (rename-key-args '((:name :%name)) rest)))
864 (defun make-random-pcl-class (&rest rest)
865 (apply #'bare-make-random-pcl-class
866 (rename-key-args '((:name :%name)) rest)))
868 ;;;; built-in classes
870 ;;; The BUILT-IN-CLASSES list is a data structure which configures the
871 ;;; creation of all the built-in classes. It contains all the info
872 ;;; that we need to maintain the mapping between classes, compile-time
873 ;;; types and run-time type codes. These options are defined:
875 ;;; :TRANSLATION (default none)
876 ;;; When this class is "parsed" as a type specifier, it is
877 ;;; translated into the specified internal type representation,
878 ;;; rather than being left as a class. This is used for types
879 ;;; which we want to canonicalize to some other kind of type
880 ;;; object because in general we want to be able to include more
881 ;;; information than just the class (e.g. for numeric types.)
883 ;;; :ENUMERABLE (default NIL)
884 ;;; The value of the :ENUMERABLE slot in the created class.
885 ;;; Meaningless in translated classes.
887 ;;; :STATE (default :SEALED)
888 ;;; The value of CLASS-STATE which we want on completion,
889 ;;; indicating whether subclasses can be created at run-time.
891 ;;; :HIERARCHICAL-P (default T unless any of the inherits are non-hierarchical)
892 ;;; True if we can assign this class a unique inheritance depth.
894 ;;; :CODES (default none)
895 ;;; Run-time type codes which should be translated back to this
896 ;;; class by CLASS-OF. Unspecified for abstract classes.
898 ;;; :INHERITS (default this class and T)
899 ;;; The class-precedence list for this class, with this class and
902 ;;; :DIRECT-SUPERCLASSES (default to head of CPL)
903 ;;; List of the direct superclasses of this class.
905 ;;; FIXME: This doesn't seem to be needed after cold init (and so can
906 ;;; probably be uninterned at the end of cold init).
907 (defvar *built-in-classes*)
909 (/show0 "setting *BUILT-IN-CLASSES*")
912 '((t :state :read-only :translation t)
913 (character :enumerable t :translation base-char)
914 (base-char :enumerable t
915 :inherits (character)
916 :codes (#.sb!vm:base-char-widetag))
917 (symbol :codes (#.sb!vm:symbol-header-widetag))
919 (instance :state :read-only)
921 (system-area-pointer :codes (#.sb!vm:sap-widetag))
922 (weak-pointer :codes (#.sb!vm:weak-pointer-widetag))
923 (code-component :codes (#.sb!vm:code-header-widetag))
924 (lra :codes (#.sb!vm:return-pc-header-widetag))
925 (fdefn :codes (#.sb!vm:fdefn-widetag))
926 (random-class) ; used for unknown type codes
929 :codes (#.sb!vm:closure-header-widetag
930 #.sb!vm:simple-fun-header-widetag)
932 (funcallable-instance
936 ;; FIXME: Are COLLECTION and MUTABLE-COLLECTION used for anything
937 ;; any more? COLLECTION is not defined in ANSI Common Lisp..
938 (collection :hierarchical-p nil :state :read-only)
939 (mutable-collection :state :read-only
940 :inherits (collection))
941 (generic-sequence :state :read-only
942 :inherits (collection))
943 (mutable-sequence :state :read-only
944 :direct-superclasses (mutable-collection
946 :inherits (mutable-collection
949 (generic-array :state :read-only
950 :inherits (mutable-sequence
954 (generic-vector :state :read-only
955 :inherits (generic-array
956 mutable-sequence mutable-collection
957 generic-sequence collection))
958 (array :translation array :codes (#.sb!vm:complex-array-widetag)
959 :inherits (generic-array mutable-sequence mutable-collection
960 generic-sequence collection))
962 :translation simple-array :codes (#.sb!vm:simple-array-widetag)
963 :inherits (array generic-array mutable-sequence mutable-collection
964 generic-sequence collection))
966 :translation (or cons (member nil) vector)
967 :inherits (mutable-sequence mutable-collection generic-sequence
970 :translation vector :codes (#.sb!vm:complex-vector-widetag)
971 :direct-superclasses (array sequence generic-vector)
972 :inherits (array sequence generic-vector generic-array
973 mutable-sequence mutable-collection generic-sequence
976 :translation simple-vector :codes (#.sb!vm:simple-vector-widetag)
977 :direct-superclasses (vector simple-array)
978 :inherits (vector simple-array array
979 sequence generic-vector generic-array
980 mutable-sequence mutable-collection
981 generic-sequence collection))
983 :translation bit-vector :codes (#.sb!vm:complex-bit-vector-widetag)
984 :inherits (vector array sequence
985 generic-vector generic-array mutable-sequence
986 mutable-collection generic-sequence collection))
988 :translation simple-bit-vector :codes (#.sb!vm:simple-bit-vector-widetag)
989 :direct-superclasses (bit-vector simple-array)
990 :inherits (bit-vector vector simple-array
992 generic-vector generic-array mutable-sequence
993 mutable-collection generic-sequence collection))
994 (simple-array-unsigned-byte-2
995 :translation (simple-array (unsigned-byte 2) (*))
996 :codes (#.sb!vm:simple-array-unsigned-byte-2-widetag)
997 :direct-superclasses (vector simple-array)
998 :inherits (vector simple-array array sequence
999 generic-vector generic-array mutable-sequence
1000 mutable-collection generic-sequence collection))
1001 (simple-array-unsigned-byte-4
1002 :translation (simple-array (unsigned-byte 4) (*))
1003 :codes (#.sb!vm:simple-array-unsigned-byte-4-widetag)
1004 :direct-superclasses (vector simple-array)
1005 :inherits (vector simple-array array sequence
1006 generic-vector generic-array mutable-sequence
1007 mutable-collection generic-sequence collection))
1008 (simple-array-unsigned-byte-8
1009 :translation (simple-array (unsigned-byte 8) (*))
1010 :codes (#.sb!vm:simple-array-unsigned-byte-8-widetag)
1011 :direct-superclasses (vector simple-array)
1012 :inherits (vector simple-array array sequence
1013 generic-vector generic-array mutable-sequence
1014 mutable-collection generic-sequence collection))
1015 (simple-array-unsigned-byte-16
1016 :translation (simple-array (unsigned-byte 16) (*))
1017 :codes (#.sb!vm:simple-array-unsigned-byte-16-widetag)
1018 :direct-superclasses (vector simple-array)
1019 :inherits (vector simple-array array sequence
1020 generic-vector generic-array mutable-sequence
1021 mutable-collection generic-sequence collection))
1022 (simple-array-unsigned-byte-32
1023 :translation (simple-array (unsigned-byte 32) (*))
1024 :codes (#.sb!vm:simple-array-unsigned-byte-32-widetag)
1025 :direct-superclasses (vector simple-array)
1026 :inherits (vector simple-array array sequence
1027 generic-vector generic-array mutable-sequence
1028 mutable-collection generic-sequence collection))
1029 (simple-array-signed-byte-8
1030 :translation (simple-array (signed-byte 8) (*))
1031 :codes (#.sb!vm:simple-array-signed-byte-8-widetag)
1032 :direct-superclasses (vector simple-array)
1033 :inherits (vector simple-array array sequence
1034 generic-vector generic-array mutable-sequence
1035 mutable-collection generic-sequence collection))
1036 (simple-array-signed-byte-16
1037 :translation (simple-array (signed-byte 16) (*))
1038 :codes (#.sb!vm:simple-array-signed-byte-16-widetag)
1039 :direct-superclasses (vector simple-array)
1040 :inherits (vector simple-array array sequence
1041 generic-vector generic-array mutable-sequence
1042 mutable-collection generic-sequence collection))
1043 (simple-array-signed-byte-30
1044 :translation (simple-array (signed-byte 30) (*))
1045 :codes (#.sb!vm:simple-array-signed-byte-30-widetag)
1046 :direct-superclasses (vector simple-array)
1047 :inherits (vector simple-array array sequence
1048 generic-vector generic-array mutable-sequence
1049 mutable-collection generic-sequence collection))
1050 (simple-array-signed-byte-32
1051 :translation (simple-array (signed-byte 32) (*))
1052 :codes (#.sb!vm:simple-array-signed-byte-32-widetag)
1053 :direct-superclasses (vector simple-array)
1054 :inherits (vector simple-array array sequence
1055 generic-vector generic-array mutable-sequence
1056 mutable-collection generic-sequence collection))
1057 (simple-array-single-float
1058 :translation (simple-array single-float (*))
1059 :codes (#.sb!vm:simple-array-single-float-widetag)
1060 :direct-superclasses (vector simple-array)
1061 :inherits (vector simple-array array sequence
1062 generic-vector generic-array mutable-sequence
1063 mutable-collection generic-sequence collection))
1064 (simple-array-double-float
1065 :translation (simple-array double-float (*))
1066 :codes (#.sb!vm:simple-array-double-float-widetag)
1067 :direct-superclasses (vector simple-array)
1068 :inherits (vector simple-array array sequence
1069 generic-vector generic-array mutable-sequence
1070 mutable-collection generic-sequence collection))
1072 (simple-array-long-float
1073 :translation (simple-array long-float (*))
1074 :codes (#.sb!vm:simple-array-long-float-widetag)
1075 :direct-superclasses (vector simple-array)
1076 :inherits (vector simple-array array sequence
1077 generic-vector generic-array mutable-sequence
1078 mutable-collection generic-sequence collection))
1079 (simple-array-complex-single-float
1080 :translation (simple-array (complex single-float) (*))
1081 :codes (#.sb!vm:simple-array-complex-single-float-widetag)
1082 :direct-superclasses (vector simple-array)
1083 :inherits (vector simple-array array sequence
1084 generic-vector generic-array mutable-sequence
1085 mutable-collection generic-sequence collection))
1086 (simple-array-complex-double-float
1087 :translation (simple-array (complex double-float) (*))
1088 :codes (#.sb!vm:simple-array-complex-double-float-widetag)
1089 :direct-superclasses (vector simple-array)
1090 :inherits (vector simple-array array sequence
1091 generic-vector generic-array mutable-sequence
1092 mutable-collection generic-sequence collection))
1094 (simple-array-complex-long-float
1095 :translation (simple-array (complex long-float) (*))
1096 :codes (#.sb!vm:simple-array-complex-long-float-widetag)
1097 :direct-superclasses (vector simple-array)
1098 :inherits (vector simple-array array sequence
1099 generic-vector generic-array mutable-sequence
1100 mutable-collection generic-sequence collection))
1103 :inherits (mutable-sequence mutable-collection generic-sequence
1107 :codes (#.sb!vm:complex-string-widetag)
1108 :direct-superclasses (vector generic-string)
1109 :inherits (vector array sequence
1110 generic-vector generic-array generic-string
1111 mutable-sequence mutable-collection
1112 generic-sequence collection))
1114 :translation simple-string
1115 :codes (#.sb!vm:simple-string-widetag)
1116 :direct-superclasses (string simple-array)
1117 :inherits (string vector simple-array
1119 generic-string generic-vector generic-array mutable-sequence
1120 mutable-collection generic-sequence collection))
1122 :translation (or cons (member nil))
1123 :inherits (sequence mutable-sequence mutable-collection
1124 generic-sequence collection))
1126 :codes (#.sb!vm:list-pointer-lowtag)
1128 :inherits (list sequence
1129 mutable-sequence mutable-collection
1130 generic-sequence collection))
1132 :translation (member nil)
1133 :inherits (list sequence
1134 mutable-sequence mutable-collection
1135 generic-sequence collection symbol)
1136 :direct-superclasses (list symbol))
1137 (generic-number :state :read-only)
1138 (number :translation number :inherits (generic-number))
1140 :translation complex
1141 :inherits (number generic-number)
1142 :codes (#.sb!vm:complex-widetag))
1143 (complex-single-float
1144 :translation (complex single-float)
1145 :inherits (complex number generic-number)
1146 :codes (#.sb!vm:complex-single-float-widetag))
1147 (complex-double-float
1148 :translation (complex double-float)
1149 :inherits (complex number generic-number)
1150 :codes (#.sb!vm:complex-double-float-widetag))
1153 :translation (complex long-float)
1154 :inherits (complex number generic-number)
1155 :codes (#.sb!vm:complex-long-float-widetag))
1156 (real :translation real :inherits (number generic-number))
1159 :inherits (real number generic-number))
1161 :translation single-float
1162 :inherits (float real number generic-number)
1163 :codes (#.sb!vm:single-float-widetag))
1165 :translation double-float
1166 :inherits (float real number generic-number)
1167 :codes (#.sb!vm:double-float-widetag))
1170 :translation long-float
1171 :inherits (float real number generic-number)
1172 :codes (#.sb!vm:long-float-widetag))
1174 :translation rational
1175 :inherits (real number generic-number))
1177 :translation (and rational (not integer))
1178 :inherits (rational real number generic-number)
1179 :codes (#.sb!vm:ratio-widetag))
1181 :translation integer
1182 :inherits (rational real number generic-number))
1184 :translation (integer #.sb!vm:*target-most-negative-fixnum*
1185 #.sb!vm:*target-most-positive-fixnum*)
1186 :inherits (integer rational real number
1188 :codes (#.sb!vm:even-fixnum-lowtag #.sb!vm:odd-fixnum-lowtag))
1190 :translation (and integer (not fixnum))
1191 :inherits (integer rational real number
1193 :codes (#.sb!vm:bignum-widetag))
1197 :inherits (instance)))))
1199 ;;; comment from CMU CL:
1200 ;;; See also type-init.lisp where we finish setting up the
1201 ;;; translations for built-in types.
1203 (dolist (x *built-in-classes*)
1204 #-sb-xc-host (/show0 "at head of loop over *BUILT-IN-CLASSES*")
1207 (translation nil trans-p)
1213 (hierarchical-p t) ; might be modified below
1214 (direct-superclasses (if inherits
1215 (list (car inherits))
1218 (declare (ignore codes state translation))
1219 (let ((inherits-list (if (eq name t)
1221 (cons t (reverse inherits))))
1222 (class (make-built-in-class
1223 :enumerable enumerable
1225 :translation (if trans-p :initializing nil)
1226 :direct-superclasses
1229 (mapcar #'sb!xc:find-class direct-superclasses)))))
1230 (setf (info :type :kind name) :primitive
1231 (class-cell-class (find-class-cell name)) class)
1233 (setf (info :type :builtin name) class))
1234 (let* ((inherits-vector
1238 (class-layout (sb!xc:find-class x))))
1239 (when (minusp (layout-depthoid super-layout))
1240 (setf hierarchical-p nil))
1243 (depthoid (if hierarchical-p
1244 (or depth (length inherits-vector))
1247 (find-and-init-or-check-layout name
1251 :invalidate nil)))))
1252 (/show0 "done with loop over *BUILT-IN-CLASSES*"))
1254 ;;; Define temporary PCL STANDARD-CLASSes. These will be set up
1255 ;;; correctly and the Lisp layout replaced by a PCL wrapper after PCL
1256 ;;; is loaded and the class defined.
1258 (/show0 "about to define temporary STANDARD-CLASSes")
1259 (dolist (x '(;; Why is STREAM duplicated in this list? Because, when
1260 ;; the inherits-vector of FUNDAMENTAL-STREAM is set up,
1261 ;; a vector containing the elements of the list below,
1262 ;; i.e. '(T INSTANCE STREAM STREAM), is created, and
1263 ;; this is what the function ORDER-LAYOUT-INHERITS
1266 ;; So, the purpose is to guarantee a valid layout for
1267 ;; the FUNDAMENTAL-STREAM class, matching what
1268 ;; ORDER-LAYOUT-INHERITS would do.
1269 ;; ORDER-LAYOUT-INHERITS would place STREAM at index 3
1270 ;; in the INHERITS(-VECTOR). Index 2 would not be
1271 ;; filled, so STREAM is duplicated there (as
1272 ;; ORDER-LAYOUTS-INHERITS would do). Maybe the
1273 ;; duplicate definition could be removed (removing a
1274 ;; STREAM element), because FUNDAMENTAL-STREAM is
1275 ;; redefined after PCL is set up, anyway. But to play
1276 ;; it safely, we define the class with a valid INHERITS
1278 (fundamental-stream (t instance stream stream))))
1279 (/show0 "defining temporary STANDARD-CLASS")
1280 (let* ((name (first x))
1281 (inherits-list (second x))
1282 (class (make-standard-class :name name))
1283 (class-cell (find-class-cell name)))
1284 (setf (class-cell-class class-cell) class
1285 (info :type :class name) class-cell
1286 (info :type :kind name) :instance)
1287 (let ((inherits (map 'simple-vector
1289 (class-layout (sb!xc:find-class x)))
1291 #-sb-xc-host (/show0 "INHERITS=..") #-sb-xc-host (/hexstr inherits)
1292 (register-layout (find-and-init-or-check-layout name 0 inherits -1)
1294 (/show0 "done defining temporary STANDARD-CLASSes"))
1296 ;;; Now that we have set up the class heterarchy, seal the sealed
1297 ;;; classes. This must be done after the subclasses have been set up.
1299 (dolist (x *built-in-classes*)
1300 (destructuring-bind (name &key (state :sealed) &allow-other-keys) x
1301 (setf (class-state (sb!xc:find-class name)) state))))
1303 ;;;; class definition/redefinition
1305 ;;; This is to be called whenever we are altering a class.
1306 (defun modify-class (class)
1308 (when (member (class-state class) '(:read-only :frozen))
1309 ;; FIXME: This should probably be CERROR.
1310 (warn "making ~(~A~) class ~S writable"
1312 (sb!xc:class-name class))
1313 (setf (class-state class) nil)))
1315 ;;; Mark LAYOUT as invalid. Setting DEPTHOID -1 helps cause unsafe
1316 ;;; structure type tests to fail. Remove class from all superclasses
1317 ;;; too (might not be registered, so might not be in subclasses of the
1318 ;;; nominal superclasses.)
1319 (defun invalidate-layout (layout)
1320 (declare (type layout layout))
1321 (setf (layout-invalid layout) t
1322 (layout-depthoid layout) -1)
1323 (let ((inherits (layout-inherits layout))
1324 (class (layout-class layout)))
1325 (modify-class class)
1326 (dotimes (i (length inherits)) ; FIXME: DOVECTOR
1327 (let* ((super (svref inherits i))
1328 (subs (class-subclasses (layout-class super))))
1330 (remhash class subs)))))
1333 ;;;; cold loading initializations
1335 ;;; FIXME: It would be good to arrange for this to be called when the
1336 ;;; cross-compiler is being built, not just when the target Lisp is
1337 ;;; being cold loaded. Perhaps this could be moved to its own file
1338 ;;; late in the build-order.lisp-expr sequence, and be put in
1339 ;;; !COLD-INIT-FORMS there?
1340 (defun !class-finalize ()
1341 (dohash (name layout *forward-referenced-layouts*)
1342 (let ((class (sb!xc:find-class name nil)))
1344 (setf (layout-class layout) (make-undefined-class name)))
1345 ((eq (class-layout class) layout)
1346 (remhash name *forward-referenced-layouts*))
1349 (warn "something strange with forward layout for ~S:~% ~S"
1353 ;;; a vector that maps type codes to layouts, used for quickly finding
1354 ;;; the layouts of built-in classes
1355 (defvar *built-in-class-codes*) ; initialized in cold load
1356 (declaim (type simple-vector *built-in-class-codes*))
1359 #-sb-xc-host (/show0 "about to set *BUILT-IN-CLASS-CODES*")
1360 (setq *built-in-class-codes*
1361 (let* ((initial-element
1363 ;; KLUDGE: There's a FIND-CLASS DEFTRANSFORM for
1364 ;; constant class names which creates fast but
1365 ;; non-cold-loadable, non-compact code. In this
1366 ;; context, we'd rather have compact, cold-loadable
1367 ;; code. -- WHN 19990928
1368 (declare (notinline sb!xc:find-class))
1369 (class-layout (sb!xc:find-class 'random-class))))
1370 (res (make-array 256 :initial-element initial-element)))
1371 (dolist (x *built-in-classes* res)
1372 (destructuring-bind (name &key codes &allow-other-keys)
1374 (let ((layout (class-layout (sb!xc:find-class name))))
1375 (dolist (code codes)
1376 (setf (svref res code) layout)))))))
1377 #-sb-xc-host (/show0 "done setting *BUILT-IN-CLASS-CODES*"))
1379 (!defun-from-collected-cold-init-forms !classes-cold-init)