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 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 (def!constant 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 (def!constant 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
)
738 (:forthcoming-defclass-type
739 ;; XXX Currently, nothing needs to be done in this case. Later, when
740 ;; PCL is integrated tighter into SBCL, this might need more work.
743 (let ((old (class-of (sb!xc
:find-class name
)))
744 (new (class-of new-value
)))
746 (warn "changing meta-class of ~S from ~S to ~S"
751 (error "illegal to redefine standard type ~S" name
))
753 (warn "redefining DEFTYPE type to be a class: ~S" name
)
754 (setf (info :type
:expander name
) nil
)))
756 (remhash name
*forward-referenced-layouts
*)
757 (%note-type-defined name
)
758 (setf (info :type
:kind name
) :instance
)
759 (setf (class-cell-class (find-class-cell name
)) new-value
)
760 (unless (eq (info :type
:compiler-layout name
)
761 (class-layout new-value
))
762 (setf (info :type
:compiler-layout name
) (class-layout new-value
)))
766 ;;; Called when we are about to define NAME as a class meeting some
767 ;;; predicate (such as a meta-class type test.) The first result is
768 ;;; always of the desired class. The second result is any existing
769 ;;; LAYOUT for this name.
770 (defun insured-find-class (name predicate constructor
)
771 (declare (type function predicate constructor
))
772 (let* ((old (sb!xc
:find-class name nil
))
773 (res (if (and old
(funcall predicate old
))
775 (funcall constructor
:name name
)))
776 (found (or (gethash name
*forward-referenced-layouts
*)
777 (when old
(class-layout old
)))))
779 (setf (layout-class found
) res
))
782 ;;; If the class has a proper name, return the name, otherwise return
784 (defun class-proper-name (class)
785 #-sb-xc
(declare (type sb
!xc
:class class
))
786 (let ((name (sb!xc
:class-name class
)))
787 (if (and name
(eq (sb!xc
:find-class name nil
) class
))
791 ;;;; CLASS type operations
793 (!define-type-class sb
!xc
:class
)
795 ;;; Simple methods for TYPE= and SUBTYPEP should never be called when
796 ;;; the two classes are equal, since there are EQ checks in those
798 (!define-type-method
(sb!xc
:class
:simple-
=) (type1 type2
)
799 (aver (not (eq type1 type2
)))
802 (!define-type-method
(sb!xc
:class
:simple-subtypep
) (class1 class2
)
803 (aver (not (eq class1 class2
)))
804 (let ((subclasses (class-subclasses class2
)))
805 (if (and subclasses
(gethash class1 subclasses
))
809 ;;; When finding the intersection of a sealed class and some other
810 ;;; class (not hierarchically related) the intersection is the union
811 ;;; of the currently shared subclasses.
812 (defun sealed-class-intersection2 (sealed other
)
813 (declare (type sb
!xc
:class sealed other
))
814 (let ((s-sub (class-subclasses sealed
))
815 (o-sub (class-subclasses other
)))
816 (if (and s-sub o-sub
)
817 (collect ((res *empty-type
* type-union
))
818 (dohash (subclass layout s-sub
)
819 (declare (ignore layout
))
820 (when (gethash subclass o-sub
)
821 (res (specifier-type subclass
))))
825 (!define-type-method
(sb!xc
:class
:simple-intersection2
) (class1 class2
)
826 (declare (type sb
!xc
:class class1 class2
))
827 (cond ((eq class1 class2
)
829 ;; If one is a subclass of the other, then that is the
831 ((let ((subclasses (class-subclasses class2
)))
832 (and subclasses
(gethash class1 subclasses
)))
834 ((let ((subclasses (class-subclasses class1
)))
835 (and subclasses
(gethash class2 subclasses
)))
837 ;; Otherwise, we can't in general be sure that the
838 ;; intersection is empty, since a subclass of both might be
839 ;; defined. But we can eliminate it for some special cases.
840 ((or (basic-structure-class-p class1
)
841 (basic-structure-class-p class2
))
842 ;; No subclass of both can be defined.
844 ((eq (class-state class1
) :sealed
)
845 ;; checking whether a subclass of both can be defined:
846 (sealed-class-intersection2 class1 class2
))
847 ((eq (class-state class2
) :sealed
)
848 ;; checking whether a subclass of both can be defined:
849 (sealed-class-intersection2 class2 class1
))
851 ;; uncertain, since a subclass of both might be defined
854 (!define-type-method
(sb!xc
:class
:unparse
) (type)
855 (class-proper-name type
))
859 (def!struct
(std-class (:include sb
!xc
:class
)
861 (def!struct
(sb!xc
:standard-class
(:include std-class
)
862 (:constructor bare-make-standard-class
)))
863 (def!struct
(random-pcl-class (:include std-class
)
864 (:constructor bare-make-random-pcl-class
)))
865 (defun make-standard-class (&rest rest
)
866 (apply #'bare-make-standard-class
867 (rename-key-args '((:name
:%name
)) rest
)))
868 (defun make-random-pcl-class (&rest rest
)
869 (apply #'bare-make-random-pcl-class
870 (rename-key-args '((:name
:%name
)) rest
)))
872 ;;;; built-in classes
874 ;;; The BUILT-IN-CLASSES list is a data structure which configures the
875 ;;; creation of all the built-in classes. It contains all the info
876 ;;; that we need to maintain the mapping between classes, compile-time
877 ;;; types and run-time type codes. These options are defined:
879 ;;; :TRANSLATION (default none)
880 ;;; When this class is "parsed" as a type specifier, it is
881 ;;; translated into the specified internal type representation,
882 ;;; rather than being left as a class. This is used for types
883 ;;; which we want to canonicalize to some other kind of type
884 ;;; object because in general we want to be able to include more
885 ;;; information than just the class (e.g. for numeric types.)
887 ;;; :ENUMERABLE (default NIL)
888 ;;; The value of the :ENUMERABLE slot in the created class.
889 ;;; Meaningless in translated classes.
891 ;;; :STATE (default :SEALED)
892 ;;; The value of CLASS-STATE which we want on completion,
893 ;;; indicating whether subclasses can be created at run-time.
895 ;;; :HIERARCHICAL-P (default T unless any of the inherits are non-hierarchical)
896 ;;; True if we can assign this class a unique inheritance depth.
898 ;;; :CODES (default none)
899 ;;; Run-time type codes which should be translated back to this
900 ;;; class by CLASS-OF. Unspecified for abstract classes.
902 ;;; :INHERITS (default this class and T)
903 ;;; The class-precedence list for this class, with this class and
906 ;;; :DIRECT-SUPERCLASSES (default to head of CPL)
907 ;;; List of the direct superclasses of this class.
909 ;;; FIXME: This doesn't seem to be needed after cold init (and so can
910 ;;; probably be uninterned at the end of cold init).
911 (defvar *built-in-classes
*)
913 (/show0
"setting *BUILT-IN-CLASSES*")
916 '((t :state
:read-only
:translation t
)
917 (character :enumerable t
:translation base-char
)
918 (base-char :enumerable t
919 :inherits
(character)
920 :codes
(#.sb
!vm
:base-char-widetag
))
921 (symbol :codes
(#.sb
!vm
:symbol-header-widetag
))
923 (instance :state
:read-only
)
925 (system-area-pointer :codes
(#.sb
!vm
:sap-widetag
))
926 (weak-pointer :codes
(#.sb
!vm
:weak-pointer-widetag
))
927 (code-component :codes
(#.sb
!vm
:code-header-widetag
))
928 (lra :codes
(#.sb
!vm
:return-pc-header-widetag
))
929 (fdefn :codes
(#.sb
!vm
:fdefn-widetag
))
930 (random-class) ; used for unknown type codes
933 :codes
(#.sb
!vm
:closure-header-widetag
934 #.sb
!vm
:simple-fun-header-widetag
)
936 (funcallable-instance
940 (array :translation array
:codes
(#.sb
!vm
:complex-array-widetag
)
943 :translation simple-array
:codes
(#.sb
!vm
:simple-array-widetag
)
946 :translation
(or cons
(member nil
) vector
))
948 :translation vector
:codes
(#.sb
!vm
:complex-vector-widetag
)
949 :direct-superclasses
(array sequence
)
950 :inherits
(array sequence
))
952 :translation simple-vector
:codes
(#.sb
!vm
:simple-vector-widetag
)
953 :direct-superclasses
(vector simple-array
)
954 :inherits
(vector simple-array array sequence
))
956 :translation bit-vector
:codes
(#.sb
!vm
:complex-bit-vector-widetag
)
957 :inherits
(vector array sequence
))
959 :translation simple-bit-vector
:codes
(#.sb
!vm
:simple-bit-vector-widetag
)
960 :direct-superclasses
(bit-vector simple-array
)
961 :inherits
(bit-vector vector simple-array
963 (simple-array-unsigned-byte-2
964 :translation
(simple-array (unsigned-byte 2) (*))
965 :codes
(#.sb
!vm
:simple-array-unsigned-byte-2-widetag
)
966 :direct-superclasses
(vector simple-array
)
967 :inherits
(vector simple-array array sequence
))
968 (simple-array-unsigned-byte-4
969 :translation
(simple-array (unsigned-byte 4) (*))
970 :codes
(#.sb
!vm
:simple-array-unsigned-byte-4-widetag
)
971 :direct-superclasses
(vector simple-array
)
972 :inherits
(vector simple-array array sequence
))
973 (simple-array-unsigned-byte-8
974 :translation
(simple-array (unsigned-byte 8) (*))
975 :codes
(#.sb
!vm
:simple-array-unsigned-byte-8-widetag
)
976 :direct-superclasses
(vector simple-array
)
977 :inherits
(vector simple-array array sequence
))
978 (simple-array-unsigned-byte-16
979 :translation
(simple-array (unsigned-byte 16) (*))
980 :codes
(#.sb
!vm
:simple-array-unsigned-byte-16-widetag
)
981 :direct-superclasses
(vector simple-array
)
982 :inherits
(vector simple-array array sequence
))
983 (simple-array-unsigned-byte-32
984 :translation
(simple-array (unsigned-byte 32) (*))
985 :codes
(#.sb
!vm
:simple-array-unsigned-byte-32-widetag
)
986 :direct-superclasses
(vector simple-array
)
987 :inherits
(vector simple-array array sequence
))
988 (simple-array-signed-byte-8
989 :translation
(simple-array (signed-byte 8) (*))
990 :codes
(#.sb
!vm
:simple-array-signed-byte-8-widetag
)
991 :direct-superclasses
(vector simple-array
)
992 :inherits
(vector simple-array array sequence
))
993 (simple-array-signed-byte-16
994 :translation
(simple-array (signed-byte 16) (*))
995 :codes
(#.sb
!vm
:simple-array-signed-byte-16-widetag
)
996 :direct-superclasses
(vector simple-array
)
997 :inherits
(vector simple-array array sequence
))
998 (simple-array-signed-byte-30
999 :translation
(simple-array (signed-byte 30) (*))
1000 :codes
(#.sb
!vm
:simple-array-signed-byte-30-widetag
)
1001 :direct-superclasses
(vector simple-array
)
1002 :inherits
(vector simple-array array sequence
))
1003 (simple-array-signed-byte-32
1004 :translation
(simple-array (signed-byte 32) (*))
1005 :codes
(#.sb
!vm
:simple-array-signed-byte-32-widetag
)
1006 :direct-superclasses
(vector simple-array
)
1007 :inherits
(vector simple-array array sequence
))
1008 (simple-array-single-float
1009 :translation
(simple-array single-float
(*))
1010 :codes
(#.sb
!vm
:simple-array-single-float-widetag
)
1011 :direct-superclasses
(vector simple-array
)
1012 :inherits
(vector simple-array array sequence
))
1013 (simple-array-double-float
1014 :translation
(simple-array double-float
(*))
1015 :codes
(#.sb
!vm
:simple-array-double-float-widetag
)
1016 :direct-superclasses
(vector simple-array
)
1017 :inherits
(vector simple-array array sequence
))
1019 (simple-array-long-float
1020 :translation
(simple-array long-float
(*))
1021 :codes
(#.sb
!vm
:simple-array-long-float-widetag
)
1022 :direct-superclasses
(vector simple-array
)
1023 :inherits
(vector simple-array array sequence
))
1024 (simple-array-complex-single-float
1025 :translation
(simple-array (complex single-float
) (*))
1026 :codes
(#.sb
!vm
:simple-array-complex-single-float-widetag
)
1027 :direct-superclasses
(vector simple-array
)
1028 :inherits
(vector simple-array array sequence
))
1029 (simple-array-complex-double-float
1030 :translation
(simple-array (complex double-float
) (*))
1031 :codes
(#.sb
!vm
:simple-array-complex-double-float-widetag
)
1032 :direct-superclasses
(vector simple-array
)
1033 :inherits
(vector simple-array array sequence
))
1035 (simple-array-complex-long-float
1036 :translation
(simple-array (complex long-float
) (*))
1037 :codes
(#.sb
!vm
:simple-array-complex-long-float-widetag
)
1038 :direct-superclasses
(vector simple-array
)
1039 :inherits
(vector simple-array array sequence
))
1042 :codes
(#.sb
!vm
:complex-string-widetag
)
1043 :direct-superclasses
(vector)
1044 :inherits
(vector array sequence
))
1046 :translation simple-string
1047 :codes
(#.sb
!vm
:simple-string-widetag
)
1048 :direct-superclasses
(string simple-array
)
1049 :inherits
(string vector simple-array
1052 :translation
(or cons
(member nil
))
1053 :inherits
(sequence))
1055 :codes
(#.sb
!vm
:list-pointer-lowtag
)
1057 :inherits
(list sequence
))
1059 :translation
(member nil
)
1060 :inherits
(symbol list sequence
)
1061 :direct-superclasses
(symbol list
))
1062 (number :translation number
)
1064 :translation complex
1066 :codes
(#.sb
!vm
:complex-widetag
))
1067 (complex-single-float
1068 :translation
(complex single-float
)
1069 :inherits
(complex number
)
1070 :codes
(#.sb
!vm
:complex-single-float-widetag
))
1071 (complex-double-float
1072 :translation
(complex double-float
)
1073 :inherits
(complex number
)
1074 :codes
(#.sb
!vm
:complex-double-float-widetag
))
1077 :translation
(complex long-float
)
1078 :inherits
(complex number
)
1079 :codes
(#.sb
!vm
:complex-long-float-widetag
))
1080 (real :translation real
:inherits
(number))
1083 :inherits
(real number
))
1085 :translation single-float
1086 :inherits
(float real number
)
1087 :codes
(#.sb
!vm
:single-float-widetag
))
1089 :translation double-float
1090 :inherits
(float real number
)
1091 :codes
(#.sb
!vm
:double-float-widetag
))
1094 :translation long-float
1095 :inherits
(float real number
)
1096 :codes
(#.sb
!vm
:long-float-widetag
))
1098 :translation rational
1099 :inherits
(real number
))
1101 :translation
(and rational
(not integer
))
1102 :inherits
(rational real number
)
1103 :codes
(#.sb
!vm
:ratio-widetag
))
1105 :translation integer
1106 :inherits
(rational real number
))
1108 :translation
(integer #.sb
!xc
:most-negative-fixnum
1109 #.sb
!xc
:most-positive-fixnum
)
1110 :inherits
(integer rational real number
)
1111 :codes
(#.sb
!vm
:even-fixnum-lowtag
#.sb
!vm
:odd-fixnum-lowtag
))
1113 :translation
(and integer
(not fixnum
))
1114 :inherits
(integer rational real number
)
1115 :codes
(#.sb
!vm
:bignum-widetag
))
1119 :inherits
(instance)))))
1121 ;;; comment from CMU CL:
1122 ;;; See also type-init.lisp where we finish setting up the
1123 ;;; translations for built-in types.
1125 (dolist (x *built-in-classes
*)
1126 #-sb-xc-host
(/show0
"at head of loop over *BUILT-IN-CLASSES*")
1129 (translation nil trans-p
)
1135 (hierarchical-p t
) ; might be modified below
1136 (direct-superclasses (if inherits
1137 (list (car inherits
))
1140 (declare (ignore codes state translation
))
1141 (let ((inherits-list (if (eq name t
)
1143 (cons t
(reverse inherits
))))
1144 (class (make-built-in-class
1145 :enumerable enumerable
1147 :translation
(if trans-p
:initializing nil
)
1148 :direct-superclasses
1151 (mapcar #'sb
!xc
:find-class direct-superclasses
)))))
1152 (setf (info :type
:kind name
) #+sb-xc-host
:defined
#-sb-xc-host
:primitive
1153 (class-cell-class (find-class-cell name
)) class
)
1155 (setf (info :type
:builtin name
) class
))
1156 (let* ((inherits-vector
1160 (class-layout (sb!xc
:find-class x
))))
1161 (when (minusp (layout-depthoid super-layout
))
1162 (setf hierarchical-p nil
))
1165 (depthoid (if hierarchical-p
1166 (or depth
(length inherits-vector
))
1169 (find-and-init-or-check-layout name
1173 :invalidate nil
)))))
1174 (/show0
"done with loop over *BUILT-IN-CLASSES*"))
1176 ;;; Define temporary PCL STANDARD-CLASSes. These will be set up
1177 ;;; correctly and the Lisp layout replaced by a PCL wrapper after PCL
1178 ;;; is loaded and the class defined.
1180 (/show0
"about to define temporary STANDARD-CLASSes")
1181 (dolist (x '(;; Why is STREAM duplicated in this list? Because, when
1182 ;; the inherits-vector of FUNDAMENTAL-STREAM is set up,
1183 ;; a vector containing the elements of the list below,
1184 ;; i.e. '(T INSTANCE STREAM STREAM), is created, and
1185 ;; this is what the function ORDER-LAYOUT-INHERITS
1188 ;; So, the purpose is to guarantee a valid layout for
1189 ;; the FUNDAMENTAL-STREAM class, matching what
1190 ;; ORDER-LAYOUT-INHERITS would do.
1191 ;; ORDER-LAYOUT-INHERITS would place STREAM at index 3
1192 ;; in the INHERITS(-VECTOR). Index 2 would not be
1193 ;; filled, so STREAM is duplicated there (as
1194 ;; ORDER-LAYOUTS-INHERITS would do). Maybe the
1195 ;; duplicate definition could be removed (removing a
1196 ;; STREAM element), because FUNDAMENTAL-STREAM is
1197 ;; redefined after PCL is set up, anyway. But to play
1198 ;; it safely, we define the class with a valid INHERITS
1200 (fundamental-stream (t instance stream stream
))))
1201 (/show0
"defining temporary STANDARD-CLASS")
1202 (let* ((name (first x
))
1203 (inherits-list (second x
))
1204 (class (make-standard-class :name name
))
1205 (class-cell (find-class-cell name
)))
1206 ;; Needed to open-code the MAP, below
1207 (declare (type list inherits-list
))
1208 (setf (class-cell-class class-cell
) class
1209 (info :type
:class name
) class-cell
1210 (info :type
:kind name
) :instance
)
1211 (let ((inherits (map 'simple-vector
1213 (class-layout (sb!xc
:find-class x
)))
1215 #-sb-xc-host
(/show0
"INHERITS=..") #-sb-xc-host
(/hexstr inherits
)
1216 (register-layout (find-and-init-or-check-layout name
0 inherits -
1)
1218 (/show0
"done defining temporary STANDARD-CLASSes"))
1220 ;;; Now that we have set up the class heterarchy, seal the sealed
1221 ;;; classes. This must be done after the subclasses have been set up.
1223 (dolist (x *built-in-classes
*)
1224 (destructuring-bind (name &key
(state :sealed
) &allow-other-keys
) x
1225 (setf (class-state (sb!xc
:find-class name
)) state
))))
1227 ;;;; class definition/redefinition
1229 ;;; This is to be called whenever we are altering a class.
1230 (defun modify-class (class)
1232 (when (member (class-state class
) '(:read-only
:frozen
))
1233 ;; FIXME: This should probably be CERROR.
1234 (warn "making ~(~A~) class ~S writable"
1236 (sb!xc
:class-name class
))
1237 (setf (class-state class
) nil
)))
1239 ;;; Mark LAYOUT as invalid. Setting DEPTHOID -1 helps cause unsafe
1240 ;;; structure type tests to fail. Remove class from all superclasses
1241 ;;; too (might not be registered, so might not be in subclasses of the
1242 ;;; nominal superclasses.)
1243 (defun invalidate-layout (layout)
1244 (declare (type layout layout
))
1245 (setf (layout-invalid layout
) t
1246 (layout-depthoid layout
) -
1)
1247 (let ((inherits (layout-inherits layout
))
1248 (class (layout-class layout
)))
1249 (modify-class class
)
1250 (dotimes (i (length inherits
)) ; FIXME: DOVECTOR
1251 (let* ((super (svref inherits i
))
1252 (subs (class-subclasses (layout-class super
))))
1254 (remhash class subs
)))))
1257 ;;;; cold loading initializations
1259 ;;; FIXME: It would be good to arrange for this to be called when the
1260 ;;; cross-compiler is being built, not just when the target Lisp is
1261 ;;; being cold loaded. Perhaps this could be moved to its own file
1262 ;;; late in the build-order.lisp-expr sequence, and be put in
1263 ;;; !COLD-INIT-FORMS there?
1264 (defun !class-finalize
()
1265 (dohash (name layout
*forward-referenced-layouts
*)
1266 (let ((class (sb!xc
:find-class name nil
)))
1268 (setf (layout-class layout
) (make-undefined-class name
)))
1269 ((eq (class-layout class
) layout
)
1270 (remhash name
*forward-referenced-layouts
*))
1273 (warn "something strange with forward layout for ~S:~% ~S"
1277 ;;; a vector that maps type codes to layouts, used for quickly finding
1278 ;;; the layouts of built-in classes
1279 (defvar *built-in-class-codes
*) ; initialized in cold load
1280 (declaim (type simple-vector
*built-in-class-codes
*))
1283 #-sb-xc-host
(/show0
"about to set *BUILT-IN-CLASS-CODES*")
1284 (setq *built-in-class-codes
*
1285 (let* ((initial-element
1287 ;; KLUDGE: There's a FIND-CLASS DEFTRANSFORM for
1288 ;; constant class names which creates fast but
1289 ;; non-cold-loadable, non-compact code. In this
1290 ;; context, we'd rather have compact, cold-loadable
1291 ;; code. -- WHN 19990928
1292 (declare (notinline sb
!xc
:find-class
))
1293 (class-layout (sb!xc
:find-class
'random-class
))))
1294 (res (make-array 256 :initial-element initial-element
)))
1295 (dolist (x *built-in-classes
* res
)
1296 (destructuring-bind (name &key codes
&allow-other-keys
)
1298 (let ((layout (class-layout (sb!xc
:find-class name
))))
1299 (dolist (code codes
)
1300 (setf (svref res code
) layout
)))))))
1301 #-sb-xc-host
(/show0
"done setting *BUILT-IN-CLASS-CODES*"))
1303 (!defun-from-collected-cold-init-forms
!classes-cold-init
)