1 ;;;; This file contains structures and functions for the maintenance of
2 ;;;; basic information about defined types. Different object systems
3 ;;;; can be supported simultaneously.
5 ;;;; This software is part of the SBCL system. See the README file for
8 ;;;; This software is derived from the CMU CL system, which was
9 ;;;; written at Carnegie Mellon University and released into the
10 ;;;; public domain. The software is in the public domain and is
11 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
12 ;;;; files for more information.
14 (in-package "SB!KERNEL")
16 (!begin-collecting-cold-init-forms
)
18 ;;;; the CLASSOID structure
20 ;;; The CLASSOID structure is a supertype of all classoid types. A
21 ;;; CLASSOID is also a CTYPE structure as recognized by the type
22 ;;; system. (FIXME: It's also a type specifier, though this might go
23 ;;; away as with the merger of SB-PCL:CLASS and CL:CLASS it's no
26 (:make-load-form-fun classoid-make-load-form-fun
)
28 (class-info (type-class-or-lose 'classoid
)))
30 #-no-ansi-print-object
32 (lambda (class stream
)
33 (let ((name (classoid-name class
)))
34 (print-unreadable-object (class stream
38 ;; FIXME: Make sure that this prints
39 ;; reasonably for anonymous classes.
40 "~:[anonymous~;~:*~S~]~@[ (~(~A~))~]"
42 (classoid-state class
))))))
43 #-sb-xc-host
(:pure nil
))
44 ;; the value to be returned by CLASSOID-NAME.
45 (name nil
:type symbol
)
46 ;; the current layout for this class, or NIL if none assigned yet
47 (layout nil
:type
(or layout null
))
48 ;; How sure are we that this class won't be redefined?
49 ;; :READ-ONLY = We are committed to not changing the effective
50 ;; slots or superclasses.
51 ;; :SEALED = We can't even add subclasses.
52 ;; NIL = Anything could happen.
53 (state nil
:type
(member nil
:read-only
:sealed
))
54 ;; direct superclasses of this class. Always NIL for CLOS classes.
55 (direct-superclasses () :type list
)
56 ;; representation of all of the subclasses (direct or indirect) of
57 ;; this class. This is NIL if no subclasses or not initalized yet;
58 ;; otherwise, it's an EQ hash-table mapping CLASSOID objects to the
59 ;; subclass layout that was in effect at the time the subclass was
61 (subclasses nil
:type
(or null hash-table
))
62 ;; the PCL class (= CL:CLASS, but with a view to future flexibility
63 ;; we don't just call it the CLASS slot) object for this class, or
64 ;; NIL if none assigned yet
67 (defun classoid-make-load-form-fun (class)
68 (/show
"entering CLASSOID-MAKE-LOAD-FORM-FUN" class
)
69 (let ((name (classoid-name class
)))
70 (unless (and name
(eq (find-classoid name nil
) class
))
71 (/show
"anonymous/undefined class case")
72 (error "can't use anonymous or undefined class as constant:~% ~S"
75 ;; KLUDGE: There's a FIND-CLASSOID DEFTRANSFORM for constant
76 ;; class names which creates fast but non-cold-loadable,
77 ;; non-compact code. In this context, we'd rather have compact,
78 ;; cold-loadable code. -- WHN 19990928
79 (declare (notinline find-classoid
))
80 (find-classoid ',name
))))
82 ;;;; basic LAYOUT stuff
84 ;;; Note: This bound is set somewhat less than MOST-POSITIVE-FIXNUM
85 ;;; in order to guarantee that several hash values can be added without
86 ;;; overflowing into a bignum.
87 (def!constant layout-clos-hash-limit
(1+ (ash sb
!xc
:most-positive-fixnum -
3))
89 "the exclusive upper bound on LAYOUT-CLOS-HASH values")
90 (def!type layout-clos-hash
() '(integer 0 #.layout-clos-hash-limit
))
92 ;;; a list of conses, initialized by genesis
94 ;;; In each cons, the car is the symbol naming the layout, and the
95 ;;; cdr is the layout itself.
96 (defvar *!initial-layouts
*)
98 ;;; a table mapping class names to layouts for classes we have
99 ;;; referenced but not yet loaded. This is initialized from an alist
100 ;;; created by genesis describing the layouts that genesis created at
102 (defvar *forward-referenced-layouts
*)
104 ;; Protected by *WORLD-LOCK*
105 (setq *forward-referenced-layouts
* (make-hash-table :test
'equal
))
107 (/show0
"processing *!INITIAL-LAYOUTS*")
108 (dolist (x *!initial-layouts
*)
109 (setf (layout-clos-hash (cdr x
)) (random-layout-clos-hash))
110 (setf (gethash (car x
) *forward-referenced-layouts
*)
112 (/show0
"done processing *!INITIAL-LAYOUTS*")))
114 ;;; The LAYOUT structure is pointed to by the first cell of instance
115 ;;; (or structure) objects. It represents what we need to know for
116 ;;; type checking and garbage collection. Whenever a class is
117 ;;; incompatibly redefined, a new layout is allocated. If two object's
118 ;;; layouts are EQ, then they are exactly the same type.
120 ;;; *** IMPORTANT ***
122 ;;; If you change the slots of LAYOUT, you need to alter genesis as
123 ;;; well, since the initialization of layout slots is hardcoded there.
125 ;;; FIXME: ...it would be better to automate this, of course...
127 ;; KLUDGE: A special hack keeps this from being
128 ;; called when building code for the
129 ;; cross-compiler. See comments at the DEFUN for
130 ;; this. -- WHN 19990914
131 (:make-load-form-fun
#-sb-xc-host ignore-it
132 ;; KLUDGE: DEF!STRUCT at #+SB-XC-HOST
133 ;; time controls both the
134 ;; build-the-cross-compiler behavior
135 ;; and the run-the-cross-compiler
136 ;; behavior. The value below only
137 ;; works for build-the-cross-compiler.
138 ;; There's a special hack in
139 ;; EMIT-MAKE-LOAD-FORM which gives
140 ;; effectively IGNORE-IT behavior for
141 ;; LAYOUT at run-the-cross-compiler
142 ;; time. It would be cleaner to
143 ;; actually have an IGNORE-IT value
144 ;; stored, but it's hard to see how to
145 ;; do that concisely with the current
146 ;; DEF!STRUCT setup. -- WHN 19990930
148 make-load-form-for-layout
))
149 ;; a pseudo-random hash value for use by CLOS. KLUDGE: The fact
150 ;; that this slot is at offset 1 is known to GENESIS.
151 (clos-hash (random-layout-clos-hash) :type layout-clos-hash
)
152 ;; the class that this is a layout for
153 (classoid (missing-arg) :type classoid
)
154 ;; The value of this slot can be:
155 ;; * :UNINITIALIZED if not initialized yet;
156 ;; * NIL if this is the up-to-date layout for a class; or
157 ;; * T if this layout has been invalidated (by being replaced by
158 ;; a new, more-up-to-date LAYOUT).
159 ;; * something else (probably a list) if the class is a PCL wrapper
160 ;; and PCL has made it invalid and made a note to itself about it
161 (invalid :uninitialized
:type
(or cons
(member nil t
:uninitialized
)))
162 ;; the layouts for all classes we inherit. If hierarchical, i.e. if
163 ;; DEPTHOID >= 0, then these are ordered by ORDER-LAYOUT-INHERITS
164 ;; (least to most specific), so that each inherited layout appears
165 ;; at its expected depth, i.e. at its LAYOUT-DEPTHOID value.
167 ;; Remaining elements are filled by the non-hierarchical layouts or,
168 ;; if they would otherwise be empty, by copies of succeeding layouts.
169 (inherits #() :type simple-vector
)
170 ;; If inheritance is not hierarchical, this is -1. If inheritance is
171 ;; hierarchical, this is the inheritance depth, i.e. (LENGTH INHERITS).
173 ;; (1) This turns out to be a handy encoding for arithmetically
174 ;; comparing deepness; it is generally useful to do a bare numeric
175 ;; comparison of these depthoid values, and we hardly ever need to
176 ;; test whether the values are negative or not.
177 ;; (2) This was called INHERITANCE-DEPTH in classic CMU CL. It was
178 ;; renamed because some of us find it confusing to call something
179 ;; a depth when it isn't quite.
180 (depthoid -
1 :type layout-depthoid
)
181 ;; the number of top level descriptor cells in each instance
182 (length 0 :type index
)
183 ;; If this layout has some kind of compiler meta-info, then this is
184 ;; it. If a structure, then we store the DEFSTRUCT-DESCRIPTION here.
186 ;; This is true if objects of this class are never modified to
187 ;; contain dynamic pointers in their slots or constant-like
188 ;; substructure (and hence can be copied into read-only space by
191 ;; This slot is known to the C runtime support code.
192 (pure nil
:type
(member t nil
0))
193 ;; Number of raw words at the end.
194 ;; This slot is known to the C runtime support code.
195 ;; It counts the number of untagged cells, not user-visible slots.
196 ;; e.g. on 32-bit machines, each (COMPLEX DOUBLE-FLOAT) counts as 4.
197 (n-untagged-slots 0 :type index
)
198 ;; Definition location
199 (source-location nil
)
200 ;; If this layout is for an object of metatype STANDARD-CLASS,
201 ;; these are the EFFECTIVE-SLOT-DEFINITION metaobjects.
202 (slot-list nil
:type list
)
203 ;; Information about slots in the class to PCL: this provides fast
204 ;; access to slot-definitions and locations by name, etc.
205 (slot-table #(nil) :type simple-vector
)
206 ;; True IFF the layout belongs to a standand-instance or a
207 ;; standard-funcallable-instance.
209 ;; FIXME: If we unify wrappers and layouts this can go away, since
210 ;; it is only used in SB-PCL::EMIT-FETCH-WRAPPERS, which can then
211 ;; use INSTANCE-SLOTS-LAYOUT instead (if there is are no slot
212 ;; layouts, there are no slots for it to pull.)
213 ;; But while that's conceivable, it still seems advantageous to have
214 ;; a single bit that decides whether something is STANDARD-OBJECT.
215 (%for-std-class-b
0 :type bit
:read-only t
))
217 (declaim (freeze-type layout
)) ; Good luck hot-patching new subtypes of LAYOUT
219 (declaim (inline layout-for-std-class-p
))
220 (defun layout-for-std-class-p (x) (not (zerop (layout-%for-std-class-b x
))))
222 (def!method print-object
((layout layout
) stream
)
223 (print-unreadable-object (layout stream
:type t
:identity t
)
225 "for ~S~@[, INVALID=~S~]"
226 (layout-proper-name layout
)
227 (layout-invalid layout
))))
229 (eval-when (#-sb-xc
:compile-toplevel
:load-toplevel
:execute
)
230 (defun layout-proper-name (layout)
231 (classoid-proper-name (layout-classoid layout
))))
233 ;;;; support for the hash values used by CLOS when working with LAYOUTs
235 ;;; a generator for random values suitable for the CLOS-HASH slots of
236 ;;; LAYOUTs. We use our own RANDOM-STATE here because we'd like
237 ;;; pseudo-random values to come the same way in the target even when
238 ;;; we make minor changes to the system, in order to reduce the
239 ;;; mysteriousness of possible CLOS bugs.
240 (defvar *layout-clos-hash-random-state
*)
241 (defun random-layout-clos-hash ()
242 ;; FIXME: I'm not sure why this expression is (1+ (RANDOM FOO)),
243 ;; returning a strictly positive value. I copied it verbatim from
244 ;; CMU CL INITIALIZE-LAYOUT-HASH, so presumably it works, but I
245 ;; dunno whether the hash values are really supposed to be 1-based.
246 ;; They're declared as INDEX.. Or is this a hack to try to avoid
247 ;; having to use bignum arithmetic? Or what? An explanation would be
250 ;; an explanation is provided in Kiczales and Rodriguez, "Efficient
251 ;; Method Dispatch in PCL", 1990. -- CSR, 2005-11-30
252 (1+ (random (1- layout-clos-hash-limit
)
253 (if (boundp '*layout-clos-hash-random-state
*)
254 *layout-clos-hash-random-state
*
255 (setf *layout-clos-hash-random-state
*
256 (make-random-state))))))
258 ;;; If we can't find any existing layout, then we create a new one
259 ;;; storing it in *FORWARD-REFERENCED-LAYOUTS*. In classic CMU CL, we
260 ;;; used to immediately check for compatibility, but for
261 ;;; cross-compilability reasons (i.e. convenience of using this
262 ;;; function in a MAKE-LOAD-FORM expression) that functionality has
263 ;;; been split off into INIT-OR-CHECK-LAYOUT.
264 (declaim (ftype (sfunction (symbol) layout
) find-layout
))
265 ;; The comment "This seems ..." is misleading but I don't have a better one.
266 ;; FIND-LAYOUT is used by FIND-AND-INIT-OR-CHECK-LAYOUT which is used
267 ;; by FOP-LAYOUT, so clearly it's used when reading fasl files.
268 (defun find-layout (name)
269 ;; This seems to be currently used only from the compiler, but make
270 ;; it thread-safe all the same. We need to lock *F-R-L* before doing
271 ;; FIND-CLASSOID in case (SETF FIND-CLASSOID) happens in parallel.
272 (let ((table *forward-referenced-layouts
*))
274 (let ((classoid (find-classoid name nil
)))
275 (or (and classoid
(classoid-layout classoid
))
277 (setf (gethash name table
)
278 (make-layout :classoid
(or classoid
(make-undefined-classoid name
)))))))))
280 ;;; If LAYOUT is uninitialized, initialize it with CLASSOID, LENGTH,
281 ;;; INHERITS, and DEPTHOID, otherwise require that it be consistent
282 ;;; with CLASSOID, LENGTH, INHERITS, and DEPTHOID.
284 ;;; UNDEFINED-CLASS values are interpreted specially as "we don't know
285 ;;; anything about the class", so if LAYOUT is initialized, any
286 ;;; preexisting class slot value is OK, and if it's not initialized,
287 ;;; its class slot value is set to an UNDEFINED-CLASS. -- FIXME: This
288 ;;; is no longer true, :UNINITIALIZED used instead.
289 (declaim (ftype (function (layout classoid index simple-vector layout-depthoid
292 %init-or-check-layout
))
293 (defun %init-or-check-layout
294 (layout classoid length inherits depthoid nuntagged
)
295 (cond ((eq (layout-invalid layout
) :uninitialized
)
296 ;; There was no layout before, we just created one which
297 ;; we'll now initialize with our information.
298 (setf (layout-length layout
) length
299 (layout-inherits layout
) inherits
300 (layout-depthoid layout
) depthoid
301 (layout-n-untagged-slots layout
) nuntagged
302 (layout-classoid layout
) classoid
303 (layout-invalid layout
) nil
))
304 ;; FIXME: Now that LAYOUTs are born :UNINITIALIZED, maybe this
305 ;; clause is not needed?
306 ((not *type-system-initialized
*)
307 (setf (layout-classoid layout
) classoid
))
309 ;; There was an old layout already initialized with old
310 ;; information, and we'll now check that old information
311 ;; which was known with certainty is consistent with current
312 ;; information which is known with certainty.
313 (check-layout layout classoid length inherits depthoid nuntagged
)))
316 ;;; In code for the target Lisp, we don't use dump LAYOUTs using the
317 ;;; standard load form mechanism, we use special fops instead, in
318 ;;; order to make cold load come out right. But when we're building
319 ;;; the cross-compiler, we can't do that because we don't have access
320 ;;; to special non-ANSI low-level things like special fops, and we
321 ;;; don't need to do that anyway because our code isn't going to be
322 ;;; cold loaded, so we use the ordinary load form system.
324 ;;; KLUDGE: A special hack causes this not to be called when we are
325 ;;; building code for the target Lisp. It would be tidier to just not
326 ;;; have it in place when we're building the target Lisp, but it
327 ;;; wasn't clear how to do that without rethinking DEF!STRUCT quite a
328 ;;; bit, so I punted. -- WHN 19990914
330 (defun make-load-form-for-layout (layout &optional env
)
331 (declare (type layout layout
))
332 (declare (ignore env
))
333 (when (layout-invalid layout
)
334 (compiler-error "can't dump reference to obsolete class: ~S"
335 (layout-classoid layout
)))
336 (let ((name (classoid-name (layout-classoid layout
))))
338 (compiler-error "can't dump anonymous LAYOUT: ~S" layout
))
339 ;; Since LAYOUT refers to a class which refers back to the LAYOUT,
340 ;; we have to do this in two stages, like the TREE-WITH-PARENT
341 ;; example in the MAKE-LOAD-FORM entry in the ANSI spec.
343 ;; "creation" form (which actually doesn't create a new LAYOUT if
344 ;; there's a preexisting one with this name)
345 `(find-layout ',name
)
346 ;; "initialization" form (which actually doesn't initialize
347 ;; preexisting LAYOUTs, just checks that they're consistent).
348 `(%init-or-check-layout
',layout
349 ',(layout-classoid layout
)
350 ',(layout-length layout
)
351 ',(layout-inherits layout
)
352 ',(layout-depthoid layout
)
353 ',(layout-n-untagged-slots layout
)))))
355 ;;; If LAYOUT's slot values differ from the specified slot values in
356 ;;; any interesting way, then give a warning and return T.
357 (declaim (ftype (function (simple-string
364 redefine-layout-warning
))
365 (defun redefine-layout-warning (old-context old-layout
366 context length inherits depthoid nuntagged
)
367 (declare (type layout old-layout
) (type simple-string old-context context
))
368 (let ((name (layout-proper-name old-layout
)))
369 (or (let ((old-inherits (layout-inherits old-layout
)))
370 (or (when (mismatch old-inherits
372 :key
#'layout-proper-name
)
373 (warn "change in superclasses of class ~S:~% ~
374 ~A superclasses: ~S~% ~
378 (map 'list
#'layout-proper-name old-inherits
)
380 (map 'list
#'layout-proper-name inherits
))
382 (let ((diff (mismatch old-inherits inherits
)))
386 ~@(~A~) definition of superclass ~S is incompatible with~% ~
390 (layout-proper-name (svref old-inherits diff
))
393 (let ((old-length (layout-length old-layout
)))
394 (unless (= old-length length
)
395 (warn "change in instance length of class ~S:~% ~
399 old-context old-length
402 (let ((old-nuntagged (layout-n-untagged-slots old-layout
)))
403 (unless (= old-nuntagged nuntagged
)
404 (warn "change in instance layout of class ~S:~% ~
405 ~A untagged slots: ~W~% ~
406 ~A untagged slots: ~W"
408 old-context old-nuntagged
411 (unless (= (layout-depthoid old-layout
) depthoid
)
412 (warn "change in the inheritance structure of class ~S~% ~
413 between the ~A definition and the ~A definition"
414 name old-context context
)
417 ;;; Require that LAYOUT data be consistent with CLASS, LENGTH,
418 ;;; INHERITS, and DEPTHOID.
419 (declaim (ftype (function
420 (layout classoid index simple-vector layout-depthoid index
))
422 (defun check-layout (layout classoid length inherits depthoid nuntagged
)
423 (aver (eq (layout-classoid layout
) classoid
))
424 (when (redefine-layout-warning "current" layout
425 "compile time" length inherits depthoid
427 ;; Classic CMU CL had more options here. There are several reasons
428 ;; why they might want more options which are less appropriate for
429 ;; us: (1) It's hard to fit the classic CMU CL flexible approach
430 ;; into the ANSI-style MAKE-LOAD-FORM system, and having a
431 ;; non-MAKE-LOAD-FORM-style system is painful when we're trying to
432 ;; make the cross-compiler run under vanilla ANSI Common Lisp. (2)
433 ;; We have CLOS now, and if you want to be able to flexibly
434 ;; redefine classes without restarting the system, it'd make sense
435 ;; to use that, so supporting complexity in order to allow
436 ;; modifying DEFSTRUCTs without restarting the system is a low
437 ;; priority. (3) We now have the ability to rebuild the SBCL
438 ;; system from scratch, so we no longer need this functionality in
439 ;; order to maintain the SBCL system by modifying running images.
440 (error "The loaded code expects an incompatible layout for class ~S."
441 (layout-proper-name layout
)))
444 ;;; a common idiom (the same as CMU CL FIND-LAYOUT) rolled up into a
445 ;;; single function call
447 ;;; Used by the loader to forward-reference layouts for classes whose
448 ;;; definitions may not have been loaded yet. This allows type tests
449 ;;; to be loaded when the type definition hasn't been loaded yet.
450 (declaim (ftype (function (symbol index simple-vector layout-depthoid index
)
452 find-and-init-or-check-layout
))
453 (defun find-and-init-or-check-layout (name length inherits depthoid nuntagged
)
455 (let ((layout (find-layout name
)))
456 (%init-or-check-layout layout
457 (or (find-classoid name nil
)
458 (layout-classoid layout
))
464 ;;; Record LAYOUT as the layout for its class, adding it as a subtype
465 ;;; of all superclasses. This is the operation that "installs" a
466 ;;; layout for a class in the type system, clobbering any old layout.
467 ;;; However, this does not modify the class namespace; that is a
468 ;;; separate operation (think anonymous classes.)
469 ;;; -- If INVALIDATE, then all the layouts for any old definition
470 ;;; and subclasses are invalidated, and the SUBCLASSES slot is cleared.
471 ;;; -- If DESTRUCT-LAYOUT, then this is some old layout, and is to be
472 ;;; destructively modified to hold the same type information.
473 (eval-when (#-sb-xc
:compile-toplevel
:load-toplevel
:execute
)
474 (defun register-layout (layout &key
(invalidate t
) destruct-layout
)
475 (declare (type layout layout
) (type (or layout null
) destruct-layout
))
477 (let* ((classoid (layout-classoid layout
))
478 (classoid-layout (classoid-layout classoid
))
479 (subclasses (classoid-subclasses classoid
)))
481 ;; Attempting to register ourselves with a temporary undefined
482 ;; class placeholder is almost certainly a programmer error. (I
483 ;; should know, I did it.) -- WHN 19990927
484 (aver (not (undefined-classoid-p classoid
)))
486 ;; This assertion dates from classic CMU CL. The rationale is
487 ;; probably that calling REGISTER-LAYOUT more than once for the
488 ;; same LAYOUT is almost certainly a programmer error.
489 (aver (not (eq classoid-layout layout
)))
491 ;; Figure out what classes are affected by the change, and issue
492 ;; appropriate warnings and invalidations.
493 (when classoid-layout
494 (%modify-classoid classoid
)
496 (dohash ((subclass subclass-layout
) subclasses
:locked t
)
497 (%modify-classoid subclass
)
499 (%invalidate-layout subclass-layout
))))
501 (%invalidate-layout classoid-layout
)
502 (setf (classoid-subclasses classoid
) nil
)))
505 (setf (layout-invalid destruct-layout
) nil
506 (layout-inherits destruct-layout
) (layout-inherits layout
)
507 (layout-depthoid destruct-layout
)(layout-depthoid layout
)
508 (layout-length destruct-layout
) (layout-length layout
)
509 (layout-n-untagged-slots destruct-layout
) (layout-n-untagged-slots layout
)
510 (layout-info destruct-layout
) (layout-info layout
)
511 (classoid-layout classoid
) destruct-layout
)
512 (setf (layout-invalid layout
) nil
513 (classoid-layout classoid
) layout
))
515 (dovector (super-layout (layout-inherits layout
))
516 (let* ((super (layout-classoid super-layout
))
517 (subclasses (or (classoid-subclasses super
)
518 (setf (classoid-subclasses super
)
519 (make-hash-table :test
'eq
520 #-sb-xc-host
#-sb-xc-host
522 (when (and (eq (classoid-state super
) :sealed
)
523 (not (gethash classoid subclasses
)))
524 (warn "unsealing sealed class ~S in order to subclass it"
525 (classoid-name super
))
526 (setf (classoid-state super
) :read-only
))
527 (setf (gethash classoid subclasses
)
528 (or destruct-layout layout
))))))
533 ;;; Arrange the inherited layouts to appear at their expected depth,
534 ;;; ensuring that hierarchical type tests succeed. Layouts with
535 ;;; DEPTHOID >= 0 (i.e. hierarchical classes) are placed first,
536 ;;; at exactly that index in the INHERITS vector. Then, non-hierarchical
537 ;;; layouts are placed in remaining elements. Then, any still-empty
538 ;;; elements are filled with their successors, ensuring that each
539 ;;; element contains a valid layout.
541 ;;; This reordering may destroy CPL ordering, so the inherits should
542 ;;; not be read as being in CPL order.
543 (defun order-layout-inherits (layouts)
544 (declare (simple-vector layouts
))
545 (let ((length (length layouts
))
548 (let ((depth (layout-depthoid (svref layouts i
))))
549 (when (> depth max-depth
)
550 (setf max-depth depth
))))
551 (let* ((new-length (max (1+ max-depth
) length
))
552 ;; KLUDGE: 0 here is the "uninitialized" element. We need
553 ;; to specify it explicitly for portability purposes, as
554 ;; elements can be read before being set [ see below, "(EQL
555 ;; OLD-LAYOUT 0)" ]. -- CSR, 2002-04-20
556 (inherits (make-array new-length
:initial-element
0)))
558 (let* ((layout (svref layouts i
))
559 (depth (layout-depthoid layout
)))
560 (unless (eql depth -
1)
561 (let ((old-layout (svref inherits depth
)))
562 (unless (or (eql old-layout
0) (eq old-layout layout
))
563 (error "layout depth conflict: ~S~%" layouts
)))
564 (setf (svref inherits depth
) layout
))))
568 (declare (type index i j
))
569 (let* ((layout (svref layouts i
))
570 (depth (layout-depthoid layout
)))
572 (loop (when (eql (svref inherits j
) 0)
575 (setf (svref inherits j
) layout
))))
576 (do ((i (1- new-length
) (1- i
)))
578 (declare (type fixnum i
))
579 (when (eql (svref inherits i
) 0)
580 (setf (svref inherits i
) (svref inherits
(1+ i
)))))
583 ;;;; class precedence lists
585 ;;; Topologically sort the list of objects to meet a set of ordering
586 ;;; constraints given by pairs (A . B) constraining A to precede B.
587 ;;; When there are multiple objects to choose, the tie-breaker
588 ;;; function is called with both the list of object to choose from and
589 ;;; the reverse ordering built so far.
590 (defun topological-sort (objects constraints tie-breaker
)
591 (declare (list objects constraints
)
592 (function tie-breaker
))
593 (let ((obj-info (make-hash-table :size
(length objects
)))
596 (dolist (constraint constraints
)
597 (let ((obj1 (car constraint
))
598 (obj2 (cdr constraint
)))
599 (let ((info2 (gethash obj2 obj-info
)))
602 (setf (gethash obj2 obj-info
) (list 1))))
603 (let ((info1 (gethash obj1 obj-info
)))
605 (push obj2
(rest info1
))
606 (setf (gethash obj1 obj-info
) (list 0 obj2
))))))
607 (dolist (obj objects
)
608 (let ((info (gethash obj obj-info
)))
609 (when (or (not info
) (zerop (first info
)))
610 (push obj free-objs
))))
612 (flet ((next-result (obj)
614 (dolist (successor (rest (gethash obj obj-info
)))
615 (let* ((successor-info (gethash successor obj-info
))
616 (count (1- (first successor-info
))))
617 (setf (first successor-info
) count
)
619 (push successor free-objs
))))))
620 (cond ((endp free-objs
)
621 (dohash ((obj info
) obj-info
)
622 (unless (zerop (first info
))
623 (error "Topological sort failed due to constraint on ~S."
625 (return (nreverse result
)))
626 ((endp (rest free-objs
))
627 (next-result (pop free-objs
)))
629 (let ((obj (funcall tie-breaker free-objs result
)))
630 (setf free-objs
(remove obj free-objs
))
631 (next-result obj
))))))))
634 ;;; standard class precedence list computation
635 (defun std-compute-class-precedence-list (class)
638 (labels ((note-class (class)
639 (unless (member class classes
)
641 (let ((superclasses (classoid-direct-superclasses class
)))
643 (rest superclasses
(rest rest
)))
645 (let ((next (first rest
)))
646 (push (cons prev next
) constraints
)
648 (dolist (class superclasses
)
649 (note-class class
)))))
650 (std-cpl-tie-breaker (free-classes rev-cpl
)
651 (dolist (class rev-cpl
(first free-classes
))
652 (let* ((superclasses (classoid-direct-superclasses class
))
653 (intersection (intersection free-classes
656 (return (first intersection
)))))))
658 (topological-sort classes constraints
#'std-cpl-tie-breaker
))))
660 ;;;; object types to represent classes
662 ;;; An UNDEFINED-CLASSOID is a cookie we make up to stick in forward
663 ;;; referenced layouts. Users should never see them.
664 (def!struct
(undefined-classoid
666 (:constructor make-undefined-classoid
(name))))
668 ;;; BUILT-IN-CLASS is used to represent the standard classes that
669 ;;; aren't defined with DEFSTRUCT and other specially implemented
670 ;;; primitive types whose only attribute is their name.
672 ;;; Some BUILT-IN-CLASSes have a TRANSLATION, which means that they
673 ;;; are effectively DEFTYPE'd to some other type (usually a union of
674 ;;; other classes or a "primitive" type such as NUMBER, ARRAY, etc.)
675 ;;; This translation is done when type specifiers are parsed. Type
676 ;;; system operations (union, subtypep, etc.) should never encounter
677 ;;; translated classes, only their translation.
678 (def!struct
(built-in-classoid (:include classoid
)
679 (:constructor make-built-in-classoid
))
680 ;; the type we translate to on parsing. If NIL, then this class
681 ;; stands on its own; or it can be set to :INITIALIZING for a period
683 (translation nil
:type
(or ctype
(member nil
:initializing
))))
685 ;;; STRUCTURE-CLASS represents what we need to know about structure
686 ;;; classes. Non-structure "typed" defstructs are a special case, and
687 ;;; don't have a corresponding class.
688 (def!struct
(structure-classoid (:include classoid
)
689 (:constructor make-structure-classoid
)))
691 ;;;; classoid namespace
693 ;;; We use an indirection to allow forward referencing of class
694 ;;; definitions with load-time resolution.
695 (def!struct
(classoid-cell
696 (:constructor make-classoid-cell
(name &optional classoid
))
697 (:make-load-form-fun
(lambda (c)
699 ',(classoid-cell-name c
)
701 #-no-ansi-print-object
702 (:print-object
(lambda (s stream
)
703 (print-unreadable-object (s stream
:type t
)
704 (prin1 (classoid-cell-name s
) stream
)))))
705 ;; Name of class we expect to find.
706 (name nil
:type symbol
:read-only t
)
707 ;; Classoid or NIL if not yet defined.
708 (classoid nil
:type
(or classoid null
))
711 (declaim (freeze-type classoid-cell
))
713 (defun find-classoid-cell (name &key create
)
714 (let ((real-name (uncross name
)))
715 (cond ((info :type
:classoid-cell real-name
))
717 (get-info-value-initializing :type
:classoid-cell real-name
718 (make-classoid-cell real-name
))))))
720 (eval-when (#-sb-xc
:compile-toplevel
:load-toplevel
:execute
)
722 ;; Return the classoid with the specified NAME. If ERRORP is false,
723 ;; then NIL is returned when no such class exists."
724 (defun find-classoid (name &optional
(errorp t
))
725 (declare (type symbol name
))
726 (let ((cell (find-classoid-cell name
)))
727 (cond ((and cell
(classoid-cell-classoid cell
)))
729 (error 'simple-type-error
731 :expected-type
'class
732 :format-control
"Class not yet defined: ~S"
733 :format-arguments
(list name
))))))
735 (defun (setf find-classoid
) (new-value name
)
736 #-sb-xc
(declare (type (or null classoid
) new-value
))
738 (let ((table *forward-referenced-layouts
*))
740 (let ((cell (find-classoid-cell name
:create t
)))
741 (ecase (info :type
:kind name
)
743 (:forthcoming-defclass-type
744 ;; FIXME: Currently, nothing needs to be done in this case.
745 ;; Later, when PCL is integrated tighter into SBCL, this
746 ;; might need more work.
750 (let ((old-value (classoid-cell-classoid cell
)))
752 ;; KLUDGE: The reason these clauses aren't directly
753 ;; parallel is that we need to use the internal
754 ;; CLASSOID structure ourselves, because we don't
755 ;; have CLASSes to work with until PCL is built. In
756 ;; the host, CLASSes have an approximately
757 ;; one-to-one correspondence with the target
758 ;; CLASSOIDs (as well as with the target CLASSes,
759 ;; modulo potential differences with respect to
762 (let ((old (class-of old-value
))
763 (new (class-of new-value
)))
765 (bug "Trying to change the metaclass of ~S from ~S to ~S in the ~
767 name
(class-name old
) (class-name new
))))
769 (let ((old (classoid-of old-value
))
770 (new (classoid-of new-value
)))
772 (warn "Changing meta-class of ~S from ~S to ~S."
773 name
(classoid-name old
) (classoid-name new
))))))
775 (error "Cannot redefine standard type ~S." name
))
777 (warn "redefining DEFTYPE type to be a class: ~
778 ~/sb-impl::print-symbol-with-prefix/" name
)
779 (clear-info :type
:expander name
)
780 (clear-info :type
:lambda-list name
)
781 (clear-info :type
:source-location name
)))
784 (%note-type-defined name
)
785 ;; we need to handle things like
786 ;; (setf (find-class 'foo) (find-class 'integer))
788 ;; (setf (find-class 'integer) (find-class 'integer))
789 (cond ((built-in-classoid-p new-value
)
790 (setf (info :type
:kind name
)
791 (or (info :type
:kind name
) :defined
))
792 (let ((translation (built-in-classoid-translation new-value
)))
794 (setf (info :type
:translator name
)
795 (lambda (c) (declare (ignore c
)) translation
)))))
797 (setf (info :type
:kind name
) :instance
)))
798 (setf (classoid-cell-classoid cell
) new-value
)
799 (unless (eq (info :type
:compiler-layout name
)
800 (classoid-layout new-value
))
801 (setf (info :type
:compiler-layout name
)
802 (classoid-layout new-value
))))))
805 (defun %clear-classoid
(name cell
)
806 (ecase (info :type
:kind name
)
810 (error "Attempt to remove :PRIMITIVE type: ~S" name
))
811 ((:forthcoming-defclass-type
:instance
)
813 ;; Note: We cannot remove the classoid cell from the table,
814 ;; since compiled code may refer directly to the cell, and
815 ;; getting a different cell for a classoid with the same name
816 ;; just would not do.
818 ;; Remove the proper name of the classoid, if this was it.
819 (let* ((classoid (classoid-cell-classoid cell
))
820 (proper-name (classoid-name classoid
)))
821 (when (eq proper-name name
)
822 (setf (classoid-name classoid
) nil
)))
825 (setf (classoid-cell-classoid cell
) nil
826 (classoid-cell-pcl-class cell
) nil
))
827 (clear-info :type
:kind name
)
828 (clear-info :type
:documentation name
)
829 (clear-info :type
:compiler-layout name
)))))
831 ;;; Called when we are about to define NAME as a class meeting some
832 ;;; predicate (such as a meta-class type test.) The first result is
833 ;;; always of the desired class. The second result is any existing
834 ;;; LAYOUT for this name.
836 ;;; Again, this should be compiler-only, but easier to make this
838 (defun insured-find-classoid (name predicate constructor
)
839 (declare (type function predicate constructor
))
840 (let ((table *forward-referenced-layouts
*))
841 (with-locked-system-table (table)
842 (let* ((old (find-classoid name nil
))
843 (res (if (and old
(funcall predicate old
))
845 (funcall constructor
:name name
)))
846 (found (or (gethash name table
)
847 (when old
(classoid-layout old
)))))
849 (setf (layout-classoid found
) res
))
850 (values res found
)))))
852 ;;; If the classoid has a proper name, return the name, otherwise return
854 (defun classoid-proper-name (classoid)
855 #-sb-xc
(declare (type classoid classoid
))
856 (let ((name (classoid-name classoid
)))
857 (if (and name
(eq (find-classoid name nil
) classoid
))
861 ;;;; CLASS type operations
863 (!define-type-class classoid
)
865 ;;; We might be passed classoids with invalid layouts; in any pairwise
866 ;;; class comparison, we must ensure that both are valid before
868 (defun %ensure-classoid-valid
(classoid layout error-context
)
869 (aver (eq classoid
(layout-classoid layout
)))
870 (or (not (layout-invalid layout
))
871 (if (typep classoid
'standard-classoid
)
872 (let ((class (classoid-pcl-class classoid
)))
874 ((sb!pcl
:class-finalized-p class
)
875 (sb!pcl
::%force-cache-flushes class
)
877 ((sb!pcl
::class-has-a-forward-referenced-superclass-p class
)
879 (bug "~@<Invalid class ~S with forward-referenced superclass ~
882 (sb!pcl
::class-has-a-forward-referenced-superclass-p class
)
886 (sb!pcl
:finalize-inheritance class
)
888 (bug "~@<Don't know how to ensure validity of ~S (not a STANDARD-CLASSOID) ~
890 classoid
(or error-context
'subtypep
)))))
892 (defun %ensure-both-classoids-valid
(class1 class2
&optional errorp
)
893 (do ((layout1 (classoid-layout class1
) (classoid-layout class1
))
894 (layout2 (classoid-layout class2
) (classoid-layout class2
))
896 ((and (not (layout-invalid layout1
)) (not (layout-invalid layout2
)))
899 (unless (and (%ensure-classoid-valid class1 layout1 errorp
)
900 (%ensure-classoid-valid class2 layout2 errorp
))
901 (return-from %ensure-both-classoids-valid nil
))))
903 (defun update-object-layout-or-invalid (object layout
)
904 ;; FIXME: explain why this isn't (LAYOUT-FOR-STD-CLASS-P LAYOUT).
905 (if (layout-for-std-class-p (layout-of object
))
906 (sb!pcl
::check-wrapper-validity object
)
907 (sb!c
::%layout-invalid-error object layout
)))
909 ;;; Simple methods for TYPE= and SUBTYPEP should never be called when
910 ;;; the two classes are equal, since there are EQ checks in those
912 (!define-type-method
(classoid :simple-
=) (type1 type2
)
913 (aver (not (eq type1 type2
)))
916 (!define-type-method
(classoid :simple-subtypep
) (class1 class2
)
917 (aver (not (eq class1 class2
)))
919 (if (%ensure-both-classoids-valid class1 class2
)
920 (let ((subclasses2 (classoid-subclasses class2
)))
921 (if (and subclasses2
(gethash class1 subclasses2
))
923 (if (and (typep class1
'standard-classoid
)
924 (typep class2
'standard-classoid
)
925 (or (sb!pcl
::class-has-a-forward-referenced-superclass-p
926 (classoid-pcl-class class1
))
927 (sb!pcl
::class-has-a-forward-referenced-superclass-p
928 (classoid-pcl-class class2
))))
929 ;; If there's a forward-referenced class involved we don't know for sure.
930 ;; (There are cases which we /could/ figure out, but that doesn't seem
931 ;; to be required or important, really.)
936 ;;; When finding the intersection of a sealed class and some other
937 ;;; class (not hierarchically related) the intersection is the union
938 ;;; of the currently shared subclasses.
939 (defun sealed-class-intersection2 (sealed other
)
940 (declare (type classoid sealed other
))
941 (let ((s-sub (classoid-subclasses sealed
))
942 (o-sub (classoid-subclasses other
)))
943 (if (and s-sub o-sub
)
944 (collect ((res *empty-type
* type-union
))
945 (dohash ((subclass layout
) s-sub
:locked t
)
946 (declare (ignore layout
))
947 (when (gethash subclass o-sub
)
948 (res (specifier-type subclass
))))
952 (!define-type-method
(classoid :simple-intersection2
) (class1 class2
)
953 (declare (type classoid class1 class2
))
955 (%ensure-both-classoids-valid class1 class2
"type intersection")
956 (cond ((eq class1 class2
)
958 ;; If one is a subclass of the other, then that is the
960 ((let ((subclasses (classoid-subclasses class2
)))
961 (and subclasses
(gethash class1 subclasses
)))
963 ((let ((subclasses (classoid-subclasses class1
)))
964 (and subclasses
(gethash class2 subclasses
)))
966 ;; Otherwise, we can't in general be sure that the
967 ;; intersection is empty, since a subclass of both might be
968 ;; defined. But we can eliminate it for some special cases.
969 ((or (structure-classoid-p class1
)
970 (structure-classoid-p class2
))
971 ;; No subclass of both can be defined.
973 ((eq (classoid-state class1
) :sealed
)
974 ;; checking whether a subclass of both can be defined:
975 (sealed-class-intersection2 class1 class2
))
976 ((eq (classoid-state class2
) :sealed
)
977 ;; checking whether a subclass of both can be defined:
978 (sealed-class-intersection2 class2 class1
))
980 ;; uncertain, since a subclass of both might be defined
983 ;;; KLUDGE: we need this to deal with the special-case INSTANCE and
984 ;;; FUNCALLABLE-INSTANCE types (which used to be CLASSOIDs until CSR
985 ;;; discovered that this was incompatible with the MOP class
986 ;;; hierarchy). See NAMED :COMPLEX-SUBTYPEP-ARG2
987 (defvar *non-instance-classoid-types
*
988 '(symbol system-area-pointer weak-pointer code-component
989 lra fdefn random-class
))
991 ;;; KLUDGE: we need this because of the need to represent
992 ;;; intersections of two classes, even when empty at a given time, as
993 ;;; uncanonicalized intersections because of the possibility of later
994 ;;; defining a subclass of both classes. The necessity for changing
995 ;;; the default return value from SUBTYPEP to NIL, T if no alternate
996 ;;; method is present comes about because, unlike the other places we
997 ;;; use INVOKE-COMPLEX-SUBTYPEP-ARG1-METHOD, in HAIRY methods and the
998 ;;; like, classes are in their own hierarchy with no possibility of
999 ;;; mixtures with other type classes.
1000 (!define-type-method
(classoid :complex-subtypep-arg2
) (type1 class2
)
1001 (if (and (intersection-type-p type1
)
1002 (> (count-if #'classoid-p
(intersection-type-types type1
)) 1))
1004 (invoke-complex-subtypep-arg1-method type1 class2 nil t
)))
1006 (!define-type-method
(classoid :negate
) (type)
1007 (make-negation-type :type type
))
1009 (!define-type-method
(classoid :unparse
) (type)
1010 (classoid-proper-name type
))
1014 ;;; the CLASSOID that we use to represent type information for
1015 ;;; STANDARD-CLASS and FUNCALLABLE-STANDARD-CLASS. The type system
1016 ;;; side does not need to distinguish between STANDARD-CLASS and
1017 ;;; FUNCALLABLE-STANDARD-CLASS.
1018 (def!struct
(standard-classoid (:include classoid
)
1019 (:constructor make-standard-classoid
)))
1020 ;;; a metaclass for classes which aren't standardlike but will never
1022 (def!struct
(static-classoid (:include classoid
)
1023 (:constructor make-static-classoid
)))
1025 ;;;; built-in classes
1027 ;;; The BUILT-IN-CLASSES list is a data structure which configures the
1028 ;;; creation of all the built-in classes. It contains all the info
1029 ;;; that we need to maintain the mapping between classes, compile-time
1030 ;;; types and run-time type codes. These options are defined:
1032 ;;; :TRANSLATION (default none)
1033 ;;; When this class is "parsed" as a type specifier, it is
1034 ;;; translated into the specified internal type representation,
1035 ;;; rather than being left as a class. This is used for types
1036 ;;; which we want to canonicalize to some other kind of type
1037 ;;; object because in general we want to be able to include more
1038 ;;; information than just the class (e.g. for numeric types.)
1040 ;;; :ENUMERABLE (default NIL)
1041 ;;; The value of the :ENUMERABLE slot in the created class.
1042 ;;; Meaningless in translated classes.
1044 ;;; :STATE (default :SEALED)
1045 ;;; The value of CLASS-STATE which we want on completion,
1046 ;;; indicating whether subclasses can be created at run-time.
1048 ;;; :HIERARCHICAL-P (default T unless any of the inherits are non-hierarchical)
1049 ;;; True if we can assign this class a unique inheritance depth.
1051 ;;; :CODES (default none)
1052 ;;; Run-time type codes which should be translated back to this
1053 ;;; class by CLASS-OF. Unspecified for abstract classes.
1055 ;;; :INHERITS (default this class and T)
1056 ;;; The class-precedence list for this class, with this class and
1059 ;;; :DIRECT-SUPERCLASSES (default to head of CPL)
1060 ;;; List of the direct superclasses of this class.
1062 ;;; FIXME: This doesn't seem to be needed after cold init (and so can
1063 ;;; probably be uninterned at the end of cold init).
1064 (defvar *built-in-classes
*)
1066 (/show0
"setting *BUILT-IN-CLASSES*")
1069 '((t :state
:read-only
:translation t
)
1070 (character :enumerable t
1071 :codes
(#.sb
!vm
:character-widetag
)
1072 :translation
(character-set)
1073 :prototype-form
(code-char 42))
1074 (symbol :codes
(#.sb
!vm
:symbol-header-widetag
)
1075 :prototype-form
'#:mu
)
1077 (system-area-pointer :codes
(#.sb
!vm
:sap-widetag
)
1078 :prototype-form
(int-sap 42))
1079 (weak-pointer :codes
(#.sb
!vm
:weak-pointer-widetag
)
1080 :prototype-form
(make-weak-pointer (find-package "CL")))
1081 (code-component :codes
(#.sb
!vm
:code-header-widetag
))
1082 (lra :codes
(#.sb
!vm
:return-pc-header-widetag
))
1083 (fdefn :codes
(#.sb
!vm
:fdefn-widetag
)
1084 :prototype-form
(make-fdefn "42"))
1085 (random-class) ; used for unknown type codes
1088 :codes
(#.sb
!vm
:closure-header-widetag
1089 #.sb
!vm
:simple-fun-header-widetag
)
1091 :prototype-form
(function (lambda () 42)))
1093 (number :translation number
)
1095 :translation complex
1097 :codes
(#.sb
!vm
:complex-widetag
)
1098 :prototype-form
(complex 42 42))
1099 (complex-single-float
1100 :translation
(complex single-float
)
1101 :inherits
(complex number
)
1102 :codes
(#.sb
!vm
:complex-single-float-widetag
)
1103 :prototype-form
(complex 42f0
42f0
))
1104 (complex-double-float
1105 :translation
(complex double-float
)
1106 :inherits
(complex number
)
1107 :codes
(#.sb
!vm
:complex-double-float-widetag
)
1108 :prototype-form
(complex 42d0
42d0
))
1111 :translation
(complex long-float
)
1112 :inherits
(complex number
)
1113 :codes
(#.sb
!vm
:complex-long-float-widetag
)
1114 :prototype-form
(complex 42l0 42l0))
1117 :translation simd-pack
1118 :codes
(#.sb
!vm
:simd-pack-widetag
)
1119 :prototype-form
(%make-simd-pack-ub64
42 42))
1120 (real :translation real
:inherits
(number))
1123 :inherits
(real number
))
1125 :translation single-float
1126 :inherits
(float real number
)
1127 :codes
(#.sb
!vm
:single-float-widetag
)
1128 :prototype-form
42f0
)
1130 :translation double-float
1131 :inherits
(float real number
)
1132 :codes
(#.sb
!vm
:double-float-widetag
)
1133 :prototype-form
42d0
)
1136 :translation long-float
1137 :inherits
(float real number
)
1138 :codes
(#.sb
!vm
:long-float-widetag
)
1139 :prototype-form
42l0)
1141 :translation rational
1142 :inherits
(real number
))
1144 :translation
(and rational
(not integer
))
1145 :inherits
(rational real number
)
1146 :codes
(#.sb
!vm
:ratio-widetag
)
1147 :prototype-form
1/42)
1149 :translation integer
1150 :inherits
(rational real number
))
1152 :translation
(integer #.sb
!xc
:most-negative-fixnum
1153 #.sb
!xc
:most-positive-fixnum
)
1154 :inherits
(integer rational real number
)
1155 :codes
#.
(mapcar #'symbol-value sb
!vm
::fixnum-lowtags
)
1158 :translation
(and integer
(not fixnum
))
1159 :inherits
(integer rational real number
)
1160 :codes
(#.sb
!vm
:bignum-widetag
)
1161 :prototype-form
(expt 2 #.
(* sb
!vm
:n-word-bits
(/ 3 2))))
1163 (array :translation array
:codes
(#.sb
!vm
:complex-array-widetag
)
1165 :prototype-form
(make-array nil
:adjustable t
))
1167 :translation simple-array
:codes
(#.sb
!vm
:simple-array-widetag
)
1169 :prototype-form
(make-array nil
))
1171 :translation
(or cons
(member nil
) vector extended-sequence
)
1175 :translation vector
:codes
(#.sb
!vm
:complex-vector-widetag
)
1176 :direct-superclasses
(array sequence
)
1177 :inherits
(array sequence
))
1179 :translation simple-vector
:codes
(#.sb
!vm
:simple-vector-widetag
)
1180 :direct-superclasses
(vector simple-array
)
1181 :inherits
(vector simple-array array sequence
)
1182 :prototype-form
(make-array 0))
1184 :translation bit-vector
:codes
(#.sb
!vm
:complex-bit-vector-widetag
)
1185 :inherits
(vector array sequence
)
1186 :prototype-form
(make-array 0 :element-type
'bit
:fill-pointer t
))
1188 :translation simple-bit-vector
:codes
(#.sb
!vm
:simple-bit-vector-widetag
)
1189 :direct-superclasses
(bit-vector simple-array
)
1190 :inherits
(bit-vector vector simple-array
1192 :prototype-form
(make-array 0 :element-type
'bit
))
1193 (simple-array-unsigned-byte-2
1194 :translation
(simple-array (unsigned-byte 2) (*))
1195 :codes
(#.sb
!vm
:simple-array-unsigned-byte-2-widetag
)
1196 :direct-superclasses
(vector simple-array
)
1197 :inherits
(vector simple-array array sequence
)
1198 :prototype-form
(make-array 0 :element-type
'(unsigned-byte 2)))
1199 (simple-array-unsigned-byte-4
1200 :translation
(simple-array (unsigned-byte 4) (*))
1201 :codes
(#.sb
!vm
:simple-array-unsigned-byte-4-widetag
)
1202 :direct-superclasses
(vector simple-array
)
1203 :inherits
(vector simple-array array sequence
)
1204 :prototype-form
(make-array 0 :element-type
'(unsigned-byte 4)))
1205 (simple-array-unsigned-byte-7
1206 :translation
(simple-array (unsigned-byte 7) (*))
1207 :codes
(#.sb
!vm
:simple-array-unsigned-byte-7-widetag
)
1208 :direct-superclasses
(vector simple-array
)
1209 :inherits
(vector simple-array array sequence
)
1210 :prototype-form
(make-array 0 :element-type
'(unsigned-byte 7)))
1211 (simple-array-unsigned-byte-8
1212 :translation
(simple-array (unsigned-byte 8) (*))
1213 :codes
(#.sb
!vm
:simple-array-unsigned-byte-8-widetag
)
1214 :direct-superclasses
(vector simple-array
)
1215 :inherits
(vector simple-array array sequence
)
1216 :prototype-form
(make-array 0 :element-type
'(unsigned-byte 8)))
1217 (simple-array-unsigned-byte-15
1218 :translation
(simple-array (unsigned-byte 15) (*))
1219 :codes
(#.sb
!vm
:simple-array-unsigned-byte-15-widetag
)
1220 :direct-superclasses
(vector simple-array
)
1221 :inherits
(vector simple-array array sequence
)
1222 :prototype-form
(make-array 0 :element-type
'(unsigned-byte 15)))
1223 (simple-array-unsigned-byte-16
1224 :translation
(simple-array (unsigned-byte 16) (*))
1225 :codes
(#.sb
!vm
:simple-array-unsigned-byte-16-widetag
)
1226 :direct-superclasses
(vector simple-array
)
1227 :inherits
(vector simple-array array sequence
)
1228 :prototype-form
(make-array 0 :element-type
'(unsigned-byte 16)))
1230 (simple-array-unsigned-fixnum
1231 :translation
(simple-array (unsigned-byte #.sb
!vm
:n-positive-fixnum-bits
) (*))
1232 :codes
(#.sb
!vm
:simple-array-unsigned-fixnum-widetag
)
1233 :direct-superclasses
(vector simple-array
)
1234 :inherits
(vector simple-array array sequence
)
1235 :prototype-form
(make-array 0
1236 :element-type
'(unsigned-byte #.sb
!vm
:n-positive-fixnum-bits
)))
1238 (simple-array-unsigned-byte-31
1239 :translation
(simple-array (unsigned-byte 31) (*))
1240 :codes
(#.sb
!vm
:simple-array-unsigned-byte-31-widetag
)
1241 :direct-superclasses
(vector simple-array
)
1242 :inherits
(vector simple-array array sequence
)
1243 :prototype-form
(make-array 0 :element-type
'(unsigned-byte 31)))
1244 (simple-array-unsigned-byte-32
1245 :translation
(simple-array (unsigned-byte 32) (*))
1246 :codes
(#.sb
!vm
:simple-array-unsigned-byte-32-widetag
)
1247 :direct-superclasses
(vector simple-array
)
1248 :inherits
(vector simple-array array sequence
)
1249 :prototype-form
(make-array 0 :element-type
'(unsigned-byte 32)))
1250 #!+#.
(cl:if
(cl:= 64 sb
!vm
:n-word-bits
) '(and) '(or))
1251 (simple-array-unsigned-byte-63
1252 :translation
(simple-array (unsigned-byte 63) (*))
1253 :codes
(#.sb
!vm
:simple-array-unsigned-byte-63-widetag
)
1254 :direct-superclasses
(vector simple-array
)
1255 :inherits
(vector simple-array array sequence
)
1256 :prototype-form
(make-array 0 :element-type
'(unsigned-byte 63)))
1257 #!+#.
(cl:if
(cl:= 64 sb
!vm
:n-word-bits
) '(and) '(or))
1258 (simple-array-unsigned-byte-64
1259 :translation
(simple-array (unsigned-byte 64) (*))
1260 :codes
(#.sb
!vm
:simple-array-unsigned-byte-64-widetag
)
1261 :direct-superclasses
(vector simple-array
)
1262 :inherits
(vector simple-array array sequence
)
1263 :prototype-form
(make-array 0 :element-type
'(unsigned-byte 64)))
1264 (simple-array-signed-byte-8
1265 :translation
(simple-array (signed-byte 8) (*))
1266 :codes
(#.sb
!vm
:simple-array-signed-byte-8-widetag
)
1267 :direct-superclasses
(vector simple-array
)
1268 :inherits
(vector simple-array array sequence
)
1269 :prototype-form
(make-array 0 :element-type
'(signed-byte 8)))
1270 (simple-array-signed-byte-16
1271 :translation
(simple-array (signed-byte 16) (*))
1272 :codes
(#.sb
!vm
:simple-array-signed-byte-16-widetag
)
1273 :direct-superclasses
(vector simple-array
)
1274 :inherits
(vector simple-array array sequence
)
1275 :prototype-form
(make-array 0 :element-type
'(signed-byte 16)))
1277 (simple-array-fixnum
1278 :translation
(simple-array (signed-byte #.sb
!vm
:n-fixnum-bits
)
1280 :codes
(#.sb
!vm
:simple-array-fixnum-widetag
)
1281 :direct-superclasses
(vector simple-array
)
1282 :inherits
(vector simple-array array sequence
)
1283 :prototype-form
(make-array 0
1285 '(signed-byte #.sb
!vm
:n-fixnum-bits
)))
1287 (simple-array-signed-byte-32
1288 :translation
(simple-array (signed-byte 32) (*))
1289 :codes
(#.sb
!vm
:simple-array-signed-byte-32-widetag
)
1290 :direct-superclasses
(vector simple-array
)
1291 :inherits
(vector simple-array array sequence
)
1292 :prototype-form
(make-array 0 :element-type
'(signed-byte 32)))
1293 #!+#.
(cl:if
(cl:= 64 sb
!vm
:n-word-bits
) '(and) '(or))
1294 (simple-array-signed-byte-64
1295 :translation
(simple-array (signed-byte 64) (*))
1296 :codes
(#.sb
!vm
:simple-array-signed-byte-64-widetag
)
1297 :direct-superclasses
(vector simple-array
)
1298 :inherits
(vector simple-array array sequence
)
1299 :prototype-form
(make-array 0 :element-type
'(signed-byte 64)))
1300 (simple-array-single-float
1301 :translation
(simple-array single-float
(*))
1302 :codes
(#.sb
!vm
:simple-array-single-float-widetag
)
1303 :direct-superclasses
(vector simple-array
)
1304 :inherits
(vector simple-array array sequence
)
1305 :prototype-form
(make-array 0 :element-type
'single-float
))
1306 (simple-array-double-float
1307 :translation
(simple-array double-float
(*))
1308 :codes
(#.sb
!vm
:simple-array-double-float-widetag
)
1309 :direct-superclasses
(vector simple-array
)
1310 :inherits
(vector simple-array array sequence
)
1311 :prototype-form
(make-array 0 :element-type
'double-float
))
1313 (simple-array-long-float
1314 :translation
(simple-array long-float
(*))
1315 :codes
(#.sb
!vm
:simple-array-long-float-widetag
)
1316 :direct-superclasses
(vector simple-array
)
1317 :inherits
(vector simple-array array sequence
)
1318 :prototype-form
(make-array 0 :element-type
'long-float
))
1319 (simple-array-complex-single-float
1320 :translation
(simple-array (complex single-float
) (*))
1321 :codes
(#.sb
!vm
:simple-array-complex-single-float-widetag
)
1322 :direct-superclasses
(vector simple-array
)
1323 :inherits
(vector simple-array array sequence
)
1324 :prototype-form
(make-array 0 :element-type
'(complex single-float
)))
1325 (simple-array-complex-double-float
1326 :translation
(simple-array (complex double-float
) (*))
1327 :codes
(#.sb
!vm
:simple-array-complex-double-float-widetag
)
1328 :direct-superclasses
(vector simple-array
)
1329 :inherits
(vector simple-array array sequence
)
1330 :prototype-form
(make-array 0 :element-type
'(complex double-float
)))
1332 (simple-array-complex-long-float
1333 :translation
(simple-array (complex long-float
) (*))
1334 :codes
(#.sb
!vm
:simple-array-complex-long-float-widetag
)
1335 :direct-superclasses
(vector simple-array
)
1336 :inherits
(vector simple-array array sequence
)
1337 :prototype-form
(make-array 0 :element-type
'(complex long-float
)))
1340 :direct-superclasses
(vector)
1341 :inherits
(vector array sequence
))
1343 :translation simple-string
1344 :direct-superclasses
(string simple-array
)
1345 :inherits
(string vector simple-array array sequence
))
1347 :translation
(vector nil
)
1348 :codes
(#.sb
!vm
:complex-vector-nil-widetag
)
1349 :direct-superclasses
(string)
1350 :inherits
(string vector array sequence
)
1351 :prototype-form
(make-array 0 :element-type
'nil
:fill-pointer t
))
1353 :translation
(simple-array nil
(*))
1354 :codes
(#.sb
!vm
:simple-array-nil-widetag
)
1355 :direct-superclasses
(vector-nil simple-string
)
1356 :inherits
(vector-nil simple-string string vector simple-array
1358 :prototype-form
(make-array 0 :element-type
'nil
))
1360 :translation base-string
1361 :codes
(#.sb
!vm
:complex-base-string-widetag
)
1362 :direct-superclasses
(string)
1363 :inherits
(string vector array sequence
)
1364 :prototype-form
(make-array 0 :element-type
'base-char
:fill-pointer t
))
1366 :translation simple-base-string
1367 :codes
(#.sb
!vm
:simple-base-string-widetag
)
1368 :direct-superclasses
(base-string simple-string
)
1369 :inherits
(base-string simple-string string vector simple-array
1371 :prototype-form
(make-array 0 :element-type
'base-char
))
1374 :translation
(vector character
)
1375 :codes
(#.sb
!vm
:complex-character-string-widetag
)
1376 :direct-superclasses
(string)
1377 :inherits
(string vector array sequence
)
1378 :prototype-form
(make-array 0 :element-type
'character
:fill-pointer t
))
1380 (simple-character-string
1381 :translation
(simple-array character
(*))
1382 :codes
(#.sb
!vm
:simple-character-string-widetag
)
1383 :direct-superclasses
(character-string simple-string
)
1384 :inherits
(character-string simple-string string vector simple-array
1386 :prototype-form
(make-array 0 :element-type
'character
))
1388 :translation
(or cons
(member nil
))
1389 :inherits
(sequence))
1391 :codes
(#.sb
!vm
:list-pointer-lowtag
)
1393 :inherits
(list sequence
)
1394 :prototype-form
(cons nil nil
))
1396 :translation
(member nil
)
1397 :inherits
(symbol list sequence
)
1398 :direct-superclasses
(symbol list
)
1399 :prototype-form
'nil
)
1410 :inherits
(stream)))))
1412 ;;; See also src/code/class-init.lisp where we finish setting up the
1413 ;;; translations for built-in types.
1415 (dolist (x *built-in-classes
*)
1416 #-sb-xc-host
(/show0
"at head of loop over *BUILT-IN-CLASSES*")
1419 (translation nil trans-p
)
1426 (hierarchical-p t
) ; might be modified below
1427 (direct-superclasses (if inherits
1428 (list (car inherits
))
1431 (declare (ignore codes state translation prototype-form
))
1432 (let ((inherits-list (if (eq name t
)
1434 (cons t
(reverse inherits
))))
1435 (classoid (make-built-in-classoid
1436 :enumerable enumerable
1438 :translation
(if trans-p
:initializing nil
)
1439 :direct-superclasses
1442 (mapcar #'find-classoid direct-superclasses
)))))
1443 (setf (info :type
:kind name
) #+sb-xc-host
:defined
#-sb-xc-host
:primitive
1444 (classoid-cell-classoid (find-classoid-cell name
:create t
)) classoid
)
1446 (setf (info :type
:builtin name
) classoid
))
1447 (let* ((inherits-vector
1451 (classoid-layout (find-classoid x
))))
1452 (when (minusp (layout-depthoid super-layout
))
1453 (setf hierarchical-p nil
))
1456 (depthoid (if hierarchical-p
1457 (or depth
(length inherits-vector
))
1460 (find-and-init-or-check-layout name
1465 :invalidate nil
)))))
1466 (/show0
"done with loop over *BUILT-IN-CLASSES*"))
1468 ;;; Define temporary PCL STANDARD-CLASSes. These will be set up
1469 ;;; correctly and the Lisp layout replaced by a PCL wrapper after PCL
1470 ;;; is loaded and the class defined.
1472 (/show0
"about to define temporary STANDARD-CLASSes")
1473 (dolist (x '(;; Why is STREAM duplicated in this list? Because, when
1474 ;; the inherits-vector of FUNDAMENTAL-STREAM is set up,
1475 ;; a vector containing the elements of the list below,
1476 ;; i.e. '(T STREAM STREAM), is created, and
1477 ;; this is what the function ORDER-LAYOUT-INHERITS
1480 ;; So, the purpose is to guarantee a valid layout for
1481 ;; the FUNDAMENTAL-STREAM class, matching what
1482 ;; ORDER-LAYOUT-INHERITS would do.
1483 ;; ORDER-LAYOUT-INHERITS would place STREAM at index 2
1484 ;; in the INHERITS(-VECTOR). Index 1 would not be
1485 ;; filled, so STREAM is duplicated there (as
1486 ;; ORDER-LAYOUTS-INHERITS would do). Maybe the
1487 ;; duplicate definition could be removed (removing a
1488 ;; STREAM element), because FUNDAMENTAL-STREAM is
1489 ;; redefined after PCL is set up, anyway. But to play
1490 ;; it safely, we define the class with a valid INHERITS
1492 (fundamental-stream (t stream stream
))))
1493 (/show0
"defining temporary STANDARD-CLASS")
1494 (let* ((name (first x
))
1495 (inherits-list (second x
))
1496 (classoid (make-standard-classoid :name name
))
1497 (classoid-cell (find-classoid-cell name
:create t
)))
1498 ;; Needed to open-code the MAP, below
1499 (declare (type list inherits-list
))
1500 (setf (classoid-cell-classoid classoid-cell
) classoid
1501 (info :type
:kind name
) :instance
)
1502 (let ((inherits (map 'simple-vector
1504 (classoid-layout (find-classoid x
)))
1506 #-sb-xc-host
(/show0
"INHERITS=..") #-sb-xc-host
(/hexstr inherits
)
1507 (register-layout (find-and-init-or-check-layout name
0 inherits -
1 0)
1509 (/show0
"done defining temporary STANDARD-CLASSes"))
1511 ;;; Now that we have set up the class heterarchy, seal the sealed
1512 ;;; classes. This must be done after the subclasses have been set up.
1514 (dolist (x *built-in-classes
*)
1515 (destructuring-bind (name &key
(state :sealed
) &allow-other-keys
) x
1516 (setf (classoid-state (find-classoid name
)) state
))))
1518 ;;;; class definition/redefinition
1520 ;;; This is to be called whenever we are altering a class.
1521 (defun %modify-classoid
(classoid)
1523 (when (member (classoid-state classoid
) '(:read-only
:frozen
))
1524 ;; FIXME: This should probably be CERROR.
1525 (warn "making ~(~A~) class ~S writable"
1526 (classoid-state classoid
)
1527 (classoid-name classoid
))
1528 (setf (classoid-state classoid
) nil
)))
1530 ;;; Mark LAYOUT as invalid. Setting DEPTHOID -1 helps cause unsafe
1531 ;;; structure type tests to fail. Remove class from all superclasses
1532 ;;; too (might not be registered, so might not be in subclasses of the
1533 ;;; nominal superclasses.) We set the layout-clos-hash slots to 0 to
1534 ;;; invalidate the wrappers for specialized dispatch functions, which
1535 ;;; use those slots as indexes into tables.
1536 (defun %invalidate-layout
(layout)
1537 (declare (type layout layout
))
1538 (setf (layout-invalid layout
) t
1539 (layout-depthoid layout
) -
1)
1540 (setf (layout-clos-hash layout
) 0)
1541 (let ((inherits (layout-inherits layout
))
1542 (classoid (layout-classoid layout
)))
1543 (%modify-classoid classoid
)
1544 (dovector (super inherits
)
1545 (let ((subs (classoid-subclasses (layout-classoid super
))))
1547 (remhash classoid subs
)))))
1550 ;;;; cold loading initializations
1552 ;;; FIXME: It would be good to arrange for this to be called when the
1553 ;;; cross-compiler is being built, not just when the target Lisp is
1554 ;;; being cold loaded. Perhaps this could be moved to its own file
1555 ;;; late in the build-order.lisp-expr sequence, and be put in
1556 ;;; !COLD-INIT-FORMS there?
1557 (defun !class-finalize
()
1558 (dohash ((name layout
) *forward-referenced-layouts
*)
1559 (let ((class (find-classoid name nil
)))
1561 (setf (layout-classoid layout
) (make-undefined-classoid name
)))
1562 ((eq (classoid-layout class
) layout
)
1563 (remhash name
*forward-referenced-layouts
*))
1565 (error "Something strange with forward layout for ~S:~% ~S"
1569 #-sb-xc-host
(/show0
"about to set *BUILT-IN-CLASS-CODES*")
1570 (setq **built-in-class-codes
**
1571 (let* ((initial-element
1573 ;; KLUDGE: There's a FIND-CLASSOID DEFTRANSFORM for
1574 ;; constant class names which creates fast but
1575 ;; non-cold-loadable, non-compact code. In this
1576 ;; context, we'd rather have compact, cold-loadable
1577 ;; code. -- WHN 19990928
1578 (declare (notinline find-classoid
))
1579 (classoid-layout (find-classoid 'random-class
))))
1580 (res (make-array 256 :initial-element initial-element
)))
1581 (dolist (x *built-in-classes
* res
)
1582 (destructuring-bind (name &key codes
&allow-other-keys
)
1584 (let ((layout (classoid-layout (find-classoid name
))))
1585 (dolist (code codes
)
1586 (setf (svref res code
) layout
)))))))
1587 #-sb-xc-host
(/show0
"done setting *BUILT-IN-CLASS-CODES*"))
1589 (!defun-from-collected-cold-init-forms
!classes-cold-init
)