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.
150 (clos-hash (random-layout-clos-hash) :type layout-clos-hash
)
151 ;; the class that this is a layout for
152 (classoid (missing-arg) :type classoid
)
153 ;; The value of this slot can be:
154 ;; * :UNINITIALIZED if not initialized yet;
155 ;; * NIL if this is the up-to-date layout for a class; or
156 ;; * T if this layout has been invalidated (by being replaced by
157 ;; a new, more-up-to-date LAYOUT).
158 ;; * something else (probably a list) if the class is a PCL wrapper
159 ;; and PCL has made it invalid and made a note to itself about it
160 (invalid :uninitialized
:type
(or cons
(member nil t
:uninitialized
)))
161 ;; the layouts for all classes we inherit. If hierarchical, i.e. if
162 ;; DEPTHOID >= 0, then these are ordered by ORDER-LAYOUT-INHERITS
163 ;; (least to most specific), so that each inherited layout appears
164 ;; at its expected depth, i.e. at its LAYOUT-DEPTHOID value.
166 ;; Remaining elements are filled by the non-hierarchical layouts or,
167 ;; if they would otherwise be empty, by copies of succeeding layouts.
168 (inherits #() :type simple-vector
)
169 ;; If inheritance is not hierarchical, this is -1. If inheritance is
170 ;; hierarchical, this is the inheritance depth, i.e. (LENGTH INHERITS).
172 ;; (1) This turns out to be a handy encoding for arithmetically
173 ;; comparing deepness; it is generally useful to do a bare numeric
174 ;; comparison of these depthoid values, and we hardly ever need to
175 ;; test whether the values are negative or not.
176 ;; (2) This was called INHERITANCE-DEPTH in classic CMU CL. It was
177 ;; renamed because some of us find it confusing to call something
178 ;; a depth when it isn't quite.
179 (depthoid -
1 :type layout-depthoid
)
180 ;; the number of top level descriptor cells in each instance
181 (length 0 :type index
)
182 ;; If this layout has some kind of compiler meta-info, then this is
183 ;; it. If a structure, then we store the DEFSTRUCT-DESCRIPTION here.
184 (info nil
:type
(or null defstruct-description
))
185 ;; This is true if objects of this class are never modified to
186 ;; contain dynamic pointers in their slots or constant-like
187 ;; substructure (and hence can be copied into read-only space by
190 ;; This slot is known to the C runtime support code.
191 (pure nil
:type
(member t nil
0))
192 ;; Number of raw words at the end.
193 ;; This slot is known to the C runtime support code.
194 ;; It counts the number of untagged cells, not user-visible slots.
195 ;; e.g. on 32-bit machines, each (COMPLEX DOUBLE-FLOAT) counts as 4.
196 #!-interleaved-raw-slots
(n-untagged-slots 0 :type index
)
198 #!+interleaved-raw-slots
(untagged-bitmap 0 :type unsigned-byte
)
199 #!+interleaved-raw-slots
(equalp-tests #() :type simple-vector
)
200 ;; Definition location
201 (source-location nil
)
202 ;; If this layout is for an object of metatype STANDARD-CLASS,
203 ;; these are the EFFECTIVE-SLOT-DEFINITION metaobjects.
204 (slot-list nil
:type list
)
205 ;; Information about slots in the class to PCL: this provides fast
206 ;; access to slot-definitions and locations by name, etc.
207 ;; See MAKE-SLOT-TABLE in pcl/slots-boot.lisp for further details.
208 (slot-table #(1 nil
) :type simple-vector
)
209 ;; True IFF the layout belongs to a standand-instance or a
210 ;; standard-funcallable-instance.
212 ;; FIXME: If we unify wrappers and layouts this can go away, since
213 ;; it is only used in SB-PCL::EMIT-FETCH-WRAPPERS, which can then
214 ;; use INSTANCE-SLOTS-LAYOUT instead (if there is are no slot
215 ;; layouts, there are no slots for it to pull.)
216 ;; But while that's conceivable, it still seems advantageous to have
217 ;; a single bit that decides whether something is STANDARD-OBJECT.
218 (%for-std-class-b
0 :type bit
:read-only t
))
220 (declaim (freeze-type layout
)) ; Good luck hot-patching new subtypes of LAYOUT
222 (declaim (inline layout-for-std-class-p
))
223 (defun layout-for-std-class-p (x) (not (zerop (layout-%for-std-class-b x
))))
225 (def!method print-object
((layout layout
) stream
)
226 (print-unreadable-object (layout stream
:type t
:identity t
)
228 "for ~S~@[, INVALID=~S~]"
229 (layout-proper-name layout
)
230 (layout-invalid layout
))))
232 (eval-when (#-sb-xc
:compile-toplevel
:load-toplevel
:execute
)
233 (defun layout-proper-name (layout)
234 (classoid-proper-name (layout-classoid layout
))))
236 ;;;; support for the hash values used by CLOS when working with LAYOUTs
238 ;;; a generator for random values suitable for the CLOS-HASH slots of
239 ;;; LAYOUTs. We use our own RANDOM-STATE here because we'd like
240 ;;; pseudo-random values to come the same way in the target even when
241 ;;; we make minor changes to the system, in order to reduce the
242 ;;; mysteriousness of possible CLOS bugs.
243 (defvar *layout-clos-hash-random-state
*)
244 (defun random-layout-clos-hash ()
245 ;; FIXME: I'm not sure why this expression is (1+ (RANDOM FOO)),
246 ;; returning a strictly positive value. I copied it verbatim from
247 ;; CMU CL INITIALIZE-LAYOUT-HASH, so presumably it works, but I
248 ;; dunno whether the hash values are really supposed to be 1-based.
249 ;; They're declared as INDEX.. Or is this a hack to try to avoid
250 ;; having to use bignum arithmetic? Or what? An explanation would be
253 ;; an explanation is provided in Kiczales and Rodriguez, "Efficient
254 ;; Method Dispatch in PCL", 1990. -- CSR, 2005-11-30
255 (1+ (random (1- layout-clos-hash-limit
)
256 (if (boundp '*layout-clos-hash-random-state
*)
257 *layout-clos-hash-random-state
*
258 (setf *layout-clos-hash-random-state
*
259 (make-random-state))))))
261 ;;; If we can't find any existing layout, then we create a new one
262 ;;; storing it in *FORWARD-REFERENCED-LAYOUTS*. In classic CMU CL, we
263 ;;; used to immediately check for compatibility, but for
264 ;;; cross-compilability reasons (i.e. convenience of using this
265 ;;; function in a MAKE-LOAD-FORM expression) that functionality has
266 ;;; been split off into INIT-OR-CHECK-LAYOUT.
267 (declaim (ftype (sfunction (symbol) layout
) find-layout
))
268 ;; The comment "This seems ..." is misleading but I don't have a better one.
269 ;; FIND-LAYOUT is used by FIND-AND-INIT-OR-CHECK-LAYOUT which is used
270 ;; by FOP-LAYOUT, so clearly it's used when reading fasl files.
271 (defun find-layout (name)
272 ;; This seems to be currently used only from the compiler, but make
273 ;; it thread-safe all the same. We need to lock *F-R-L* before doing
274 ;; FIND-CLASSOID in case (SETF FIND-CLASSOID) happens in parallel.
275 (let ((table *forward-referenced-layouts
*))
277 (let ((classoid (find-classoid name nil
)))
278 (or (and classoid
(classoid-layout classoid
))
280 (setf (gethash name table
)
281 (make-layout :classoid
(or classoid
(make-undefined-classoid name
)))))))))
283 ;;; If LAYOUT is uninitialized, initialize it with CLASSOID, LENGTH,
284 ;;; INHERITS, DEPTHOID, and RAW-SLOT-METADATA. Otherwise require
285 ;;; that it be consistent with the existing values.
287 ;;; UNDEFINED-CLASS values are interpreted specially as "we don't know
288 ;;; anything about the class", so if LAYOUT is initialized, any
289 ;;; preexisting class slot value is OK, and if it's not initialized,
290 ;;; its class slot value is set to an UNDEFINED-CLASS. -- FIXME: This
291 ;;; is no longer true, :UNINITIALIZED used instead.
292 (declaim (ftype (function (layout classoid index simple-vector layout-depthoid
293 layout-raw-slot-metadata-type
)
295 %init-or-check-layout
))
296 (defun %init-or-check-layout
297 (layout classoid length inherits depthoid raw-slot-metadata
)
298 (cond ((eq (layout-invalid layout
) :uninitialized
)
299 ;; There was no layout before, we just created one which
300 ;; we'll now initialize with our information.
301 (setf (layout-length layout
) length
302 (layout-inherits layout
) inherits
303 (layout-depthoid layout
) depthoid
304 (layout-raw-slot-metadata layout
) raw-slot-metadata
305 (layout-classoid layout
) classoid
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-classoid layout
) classoid
))
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 classoid length inherits depthoid
320 ;;; In code for the target Lisp, we don't dump LAYOUTs using the
321 ;;; standard load form mechanism, we use special fops instead, in
322 ;;; order to make cold load come out right. But when we're building
323 ;;; the cross-compiler, we can't do that because we don't have access
324 ;;; to special non-ANSI low-level things like special fops, and we
325 ;;; don't need to do that anyway because our code isn't going to be
326 ;;; cold loaded, so we use the ordinary load form system.
328 ;;; KLUDGE: A special hack causes this not to be called when we are
329 ;;; building code for the target Lisp. It would be tidier to just not
330 ;;; have it in place when we're building the target Lisp, but it
331 ;;; wasn't clear how to do that without rethinking DEF!STRUCT quite a
332 ;;; bit, so I punted. -- WHN 19990914
334 (defun make-load-form-for-layout (layout &optional env
)
335 (declare (type layout layout
))
336 (declare (ignore env
))
337 (when (layout-invalid layout
)
338 (compiler-error "can't dump reference to obsolete class: ~S"
339 (layout-classoid layout
)))
340 (let ((name (classoid-name (layout-classoid layout
))))
342 (compiler-error "can't dump anonymous LAYOUT: ~S" layout
))
343 ;; Since LAYOUT refers to a class which refers back to the LAYOUT,
344 ;; we have to do this in two stages, like the TREE-WITH-PARENT
345 ;; example in the MAKE-LOAD-FORM entry in the ANSI spec.
347 ;; "creation" form (which actually doesn't create a new LAYOUT if
348 ;; there's a preexisting one with this name)
349 `(find-layout ',name
)
350 ;; "initialization" form (which actually doesn't initialize
351 ;; preexisting LAYOUTs, just checks that they're consistent).
352 `(%init-or-check-layout
',layout
353 ',(layout-classoid layout
)
354 ',(layout-length layout
)
355 ',(layout-inherits layout
)
356 ',(layout-depthoid layout
)
357 ',(layout-raw-slot-metadata layout
)))))
359 ;;; If LAYOUT's slot values differ from the specified slot values in
360 ;;; any interesting way, then give a warning and return T.
361 (declaim (ftype (function (simple-string
367 layout-raw-slot-metadata-type
))
368 redefine-layout-warning
))
369 (defun redefine-layout-warning (old-context old-layout
370 context length inherits depthoid
372 (declare (type layout old-layout
) (type simple-string old-context context
))
373 (let ((name (layout-proper-name old-layout
))
374 (old-inherits (layout-inherits old-layout
)))
375 (or (when (mismatch old-inherits inherits
:key
#'layout-proper-name
)
376 (warn "change in superclasses of class ~S:~% ~
377 ~A superclasses: ~S~% ~
381 (map 'list
#'layout-proper-name old-inherits
)
383 (map 'list
#'layout-proper-name inherits
))
385 (let ((diff (mismatch old-inherits inherits
)))
387 (warn "in class ~S:~% ~
388 ~@(~A~) definition of superclass ~S is incompatible with~% ~
392 (layout-proper-name (svref old-inherits diff
))
395 (let ((old-length (layout-length old-layout
)))
396 (unless (= old-length length
)
397 (warn "change in instance length of class ~S:~% ~
401 old-context old-length
404 (let ((old-metadata (layout-raw-slot-metadata old-layout
)))
405 (unless (= old-metadata raw-slot-metadata
)
406 #!-interleaved-raw-slots
407 (warn "change in instance layout of class ~S:~% ~
408 ~A untagged slots: ~W~% ~
409 ~A untagged slots: ~W"
411 old-context old-metadata
412 context raw-slot-metadata
)
413 #!+interleaved-raw-slots
414 (warn "change in placement of raw slots of class ~S ~
415 between the ~A definition and the ~A definition"
416 name old-context context
)
418 (unless (= (layout-depthoid old-layout
) depthoid
)
419 (warn "change in the inheritance structure of class ~S~% ~
420 between the ~A definition and the ~A definition"
421 name old-context context
)
424 ;;; Require that LAYOUT data be consistent with CLASSOID, LENGTH,
425 ;;; INHERITS, DEPTHOID, and RAW-SLOT-METADATA.
426 (declaim (ftype (function
427 (layout classoid index simple-vector layout-depthoid
428 layout-raw-slot-metadata-type
))
430 (defun check-layout (layout classoid length inherits depthoid raw-slot-metadata
)
431 (aver (eq (layout-classoid layout
) classoid
))
432 (when (redefine-layout-warning "current" layout
433 "compile time" length inherits depthoid
435 ;; Classic CMU CL had more options here. There are several reasons
436 ;; why they might want more options which are less appropriate for
437 ;; us: (1) It's hard to fit the classic CMU CL flexible approach
438 ;; into the ANSI-style MAKE-LOAD-FORM system, and having a
439 ;; non-MAKE-LOAD-FORM-style system is painful when we're trying to
440 ;; make the cross-compiler run under vanilla ANSI Common Lisp. (2)
441 ;; We have CLOS now, and if you want to be able to flexibly
442 ;; redefine classes without restarting the system, it'd make sense
443 ;; to use that, so supporting complexity in order to allow
444 ;; modifying DEFSTRUCTs without restarting the system is a low
445 ;; priority. (3) We now have the ability to rebuild the SBCL
446 ;; system from scratch, so we no longer need this functionality in
447 ;; order to maintain the SBCL system by modifying running images.
448 (error "The loaded code expects an incompatible layout for class ~S."
449 (layout-proper-name layout
)))
452 ;;; a common idiom (the same as CMU CL FIND-LAYOUT) rolled up into a
453 ;;; single function call
455 ;;; Used by the loader to forward-reference layouts for classes whose
456 ;;; definitions may not have been loaded yet. This allows type tests
457 ;;; to be loaded when the type definition hasn't been loaded yet.
458 (declaim (ftype (function (symbol index simple-vector layout-depthoid
459 layout-raw-slot-metadata-type
)
461 find-and-init-or-check-layout
))
462 (defun find-and-init-or-check-layout (name length inherits depthoid metadata
)
464 (let ((layout (find-layout name
)))
465 (%init-or-check-layout layout
466 (or (find-classoid name nil
)
467 (layout-classoid layout
))
473 ;;; Record LAYOUT as the layout for its class, adding it as a subtype
474 ;;; of all superclasses. This is the operation that "installs" a
475 ;;; layout for a class in the type system, clobbering any old layout.
476 ;;; However, this does not modify the class namespace; that is a
477 ;;; separate operation (think anonymous classes.)
478 ;;; -- If INVALIDATE, then all the layouts for any old definition
479 ;;; and subclasses are invalidated, and the SUBCLASSES slot is cleared.
480 ;;; -- If DESTRUCT-LAYOUT, then this is some old layout, and is to be
481 ;;; destructively modified to hold the same type information.
482 (eval-when (#-sb-xc
:compile-toplevel
:load-toplevel
:execute
)
483 (defun register-layout (layout &key
(invalidate t
) destruct-layout
)
484 (declare (type layout layout
) (type (or layout null
) destruct-layout
))
486 (let* ((classoid (layout-classoid layout
))
487 (classoid-layout (classoid-layout classoid
))
488 (subclasses (classoid-subclasses classoid
)))
490 ;; Attempting to register ourselves with a temporary undefined
491 ;; class placeholder is almost certainly a programmer error. (I
492 ;; should know, I did it.) -- WHN 19990927
493 (aver (not (undefined-classoid-p classoid
)))
495 ;; This assertion dates from classic CMU CL. The rationale is
496 ;; probably that calling REGISTER-LAYOUT more than once for the
497 ;; same LAYOUT is almost certainly a programmer error.
498 (aver (not (eq classoid-layout layout
)))
500 ;; Figure out what classes are affected by the change, and issue
501 ;; appropriate warnings and invalidations.
502 (when classoid-layout
503 (%modify-classoid classoid
)
505 (dohash ((subclass subclass-layout
) subclasses
:locked t
)
506 (%modify-classoid subclass
)
508 (%invalidate-layout subclass-layout
))))
510 (%invalidate-layout classoid-layout
)
511 (setf (classoid-subclasses classoid
) nil
)))
514 (setf (layout-invalid destruct-layout
) nil
515 (layout-inherits destruct-layout
) (layout-inherits layout
)
516 (layout-depthoid destruct-layout
) (layout-depthoid layout
)
517 (layout-length destruct-layout
) (layout-length layout
)
518 (layout-raw-slot-metadata destruct-layout
)
519 (layout-raw-slot-metadata layout
)
520 (layout-info destruct-layout
) (layout-info layout
)
521 (classoid-layout classoid
) destruct-layout
)
522 (setf (layout-invalid layout
) nil
523 (classoid-layout classoid
) layout
))
525 (dovector (super-layout (layout-inherits layout
))
526 (let* ((super (layout-classoid super-layout
))
527 (subclasses (or (classoid-subclasses super
)
528 (setf (classoid-subclasses super
)
529 (make-hash-table :test
'eq
530 #-sb-xc-host
#-sb-xc-host
532 (when (and (eq (classoid-state super
) :sealed
)
533 (not (gethash classoid subclasses
)))
534 (warn "unsealing sealed class ~S in order to subclass it"
535 (classoid-name super
))
536 (setf (classoid-state super
) :read-only
))
537 (setf (gethash classoid subclasses
)
538 (or destruct-layout layout
))))))
543 ;;; Arrange the inherited layouts to appear at their expected depth,
544 ;;; ensuring that hierarchical type tests succeed. Layouts with
545 ;;; DEPTHOID >= 0 (i.e. hierarchical classes) are placed first,
546 ;;; at exactly that index in the INHERITS vector. Then, non-hierarchical
547 ;;; layouts are placed in remaining elements. Then, any still-empty
548 ;;; elements are filled with their successors, ensuring that each
549 ;;; element contains a valid layout.
551 ;;; This reordering may destroy CPL ordering, so the inherits should
552 ;;; not be read as being in CPL order.
553 (defun order-layout-inherits (layouts)
554 (declare (simple-vector layouts
))
555 (let ((length (length layouts
))
558 (let ((depth (layout-depthoid (svref layouts i
))))
559 (when (> depth max-depth
)
560 (setf max-depth depth
))))
561 (let* ((new-length (max (1+ max-depth
) length
))
562 ;; KLUDGE: 0 here is the "uninitialized" element. We need
563 ;; to specify it explicitly for portability purposes, as
564 ;; elements can be read before being set [ see below, "(EQL
565 ;; OLD-LAYOUT 0)" ]. -- CSR, 2002-04-20
566 (inherits (make-array new-length
:initial-element
0)))
568 (let* ((layout (svref layouts i
))
569 (depth (layout-depthoid layout
)))
570 (unless (eql depth -
1)
571 (let ((old-layout (svref inherits depth
)))
572 (unless (or (eql old-layout
0) (eq old-layout layout
))
573 (error "layout depth conflict: ~S~%" layouts
)))
574 (setf (svref inherits depth
) layout
))))
578 (declare (type index i j
))
579 (let* ((layout (svref layouts i
))
580 (depth (layout-depthoid layout
)))
582 (loop (when (eql (svref inherits j
) 0)
585 (setf (svref inherits j
) layout
))))
586 (do ((i (1- new-length
) (1- i
)))
588 (declare (type fixnum i
))
589 (when (eql (svref inherits i
) 0)
590 (setf (svref inherits i
) (svref inherits
(1+ i
)))))
593 ;;;; class precedence lists
595 ;;; Topologically sort the list of objects to meet a set of ordering
596 ;;; constraints given by pairs (A . B) constraining A to precede B.
597 ;;; When there are multiple objects to choose, the tie-breaker
598 ;;; function is called with both the list of object to choose from and
599 ;;; the reverse ordering built so far.
600 (defun topological-sort (objects constraints tie-breaker
)
601 (declare (list objects constraints
)
602 (function tie-breaker
))
603 (let ((obj-info (make-hash-table :size
(length objects
)))
606 (dolist (constraint constraints
)
607 (let ((obj1 (car constraint
))
608 (obj2 (cdr constraint
)))
609 (let ((info2 (gethash obj2 obj-info
)))
612 (setf (gethash obj2 obj-info
) (list 1))))
613 (let ((info1 (gethash obj1 obj-info
)))
615 (push obj2
(rest info1
))
616 (setf (gethash obj1 obj-info
) (list 0 obj2
))))))
617 (dolist (obj objects
)
618 (let ((info (gethash obj obj-info
)))
619 (when (or (not info
) (zerop (first info
)))
620 (push obj free-objs
))))
622 (flet ((next-result (obj)
624 (dolist (successor (rest (gethash obj obj-info
)))
625 (let* ((successor-info (gethash successor obj-info
))
626 (count (1- (first successor-info
))))
627 (setf (first successor-info
) count
)
629 (push successor free-objs
))))))
630 (cond ((endp free-objs
)
631 (dohash ((obj info
) obj-info
)
632 (unless (zerop (first info
))
633 (error "Topological sort failed due to constraint on ~S."
635 (return (nreverse result
)))
636 ((endp (rest free-objs
))
637 (next-result (pop free-objs
)))
639 (let ((obj (funcall tie-breaker free-objs result
)))
640 (setf free-objs
(remove obj free-objs
))
641 (next-result obj
))))))))
644 ;;; standard class precedence list computation
645 (defun std-compute-class-precedence-list (class)
648 (labels ((note-class (class)
649 (unless (member class classes
)
651 (let ((superclasses (classoid-direct-superclasses class
)))
653 (rest superclasses
(rest rest
)))
655 (let ((next (first rest
)))
656 (push (cons prev next
) constraints
)
658 (dolist (class superclasses
)
659 (note-class class
)))))
660 (std-cpl-tie-breaker (free-classes rev-cpl
)
661 (dolist (class rev-cpl
(first free-classes
))
662 (let* ((superclasses (classoid-direct-superclasses class
))
663 (intersection (intersection free-classes
666 (return (first intersection
)))))))
668 (topological-sort classes constraints
#'std-cpl-tie-breaker
))))
670 ;;;; object types to represent classes
672 ;;; An UNDEFINED-CLASSOID is a cookie we make up to stick in forward
673 ;;; referenced layouts. Users should never see them.
674 (def!struct
(undefined-classoid
676 (:constructor make-undefined-classoid
(name))))
678 ;;; BUILT-IN-CLASS is used to represent the standard classes that
679 ;;; aren't defined with DEFSTRUCT and other specially implemented
680 ;;; primitive types whose only attribute is their name.
682 ;;; Some BUILT-IN-CLASSes have a TRANSLATION, which means that they
683 ;;; are effectively DEFTYPE'd to some other type (usually a union of
684 ;;; other classes or a "primitive" type such as NUMBER, ARRAY, etc.)
685 ;;; This translation is done when type specifiers are parsed. Type
686 ;;; system operations (union, subtypep, etc.) should never encounter
687 ;;; translated classes, only their translation.
688 (def!struct
(built-in-classoid (:include classoid
)
689 (:constructor make-built-in-classoid
))
690 ;; the type we translate to on parsing. If NIL, then this class
691 ;; stands on its own; or it can be set to :INITIALIZING for a period
693 (translation nil
:type
(or ctype
(member nil
:initializing
))))
695 ;;; STRUCTURE-CLASS represents what we need to know about structure
696 ;;; classes. Non-structure "typed" defstructs are a special case, and
697 ;;; don't have a corresponding class.
698 (def!struct
(structure-classoid (:include classoid
)
699 (:constructor %make-structure-classoid
)))
700 (defun make-structure-classoid (&key name
)
701 (mark-ctype-interned (%make-structure-classoid
:name name
)))
703 ;;;; classoid namespace
705 ;;; We use an indirection to allow forward referencing of class
706 ;;; definitions with load-time resolution.
707 (def!struct
(classoid-cell
708 (:constructor make-classoid-cell
(name &optional classoid
))
709 (:make-load-form-fun
(lambda (c)
711 ',(classoid-cell-name c
)
713 #-no-ansi-print-object
714 (:print-object
(lambda (s stream
)
715 (print-unreadable-object (s stream
:type t
)
716 (prin1 (classoid-cell-name s
) stream
)))))
717 ;; Name of class we expect to find.
718 (name nil
:type symbol
:read-only t
)
719 ;; Classoid or NIL if not yet defined.
720 (classoid nil
:type
(or classoid null
))
723 (declaim (freeze-type classoid-cell
))
725 (defun find-classoid-cell (name &key create
)
726 (let ((real-name (uncross name
)))
727 (cond ((info :type
:classoid-cell real-name
))
729 (get-info-value-initializing :type
:classoid-cell real-name
730 (make-classoid-cell real-name
))))))
732 (eval-when (#-sb-xc
:compile-toplevel
:load-toplevel
:execute
)
734 ;; Return the classoid with the specified NAME. If ERRORP is false,
735 ;; then NIL is returned when no such class exists."
736 (defun find-classoid (name &optional
(errorp t
))
737 (declare (type symbol name
))
738 (let ((cell (find-classoid-cell name
)))
739 (cond ((and cell
(classoid-cell-classoid cell
)))
741 (error 'simple-type-error
743 :expected-type
'class
744 :format-control
"Class not yet defined: ~S"
745 :format-arguments
(list name
))))))
747 (defun (setf find-classoid
) (new-value name
)
748 #-sb-xc
(declare (type (or null classoid
) new-value
))
750 (let ((table *forward-referenced-layouts
*))
752 (let ((cell (find-classoid-cell name
:create t
)))
753 (ecase (info :type
:kind name
)
755 (:forthcoming-defclass-type
756 ;; FIXME: Currently, nothing needs to be done in this case.
757 ;; Later, when PCL is integrated tighter into SBCL, this
758 ;; might need more work.
762 (let ((old-value (classoid-cell-classoid cell
)))
764 ;; KLUDGE: The reason these clauses aren't directly
765 ;; parallel is that we need to use the internal
766 ;; CLASSOID structure ourselves, because we don't
767 ;; have CLASSes to work with until PCL is built. In
768 ;; the host, CLASSes have an approximately
769 ;; one-to-one correspondence with the target
770 ;; CLASSOIDs (as well as with the target CLASSes,
771 ;; modulo potential differences with respect to
774 (let ((old (class-of old-value
))
775 (new (class-of new-value
)))
777 (bug "Trying to change the metaclass of ~S from ~S to ~S in the ~
779 name
(class-name old
) (class-name new
))))
781 (let ((old (classoid-of old-value
))
782 (new (classoid-of new-value
)))
784 (warn "Changing meta-class of ~S from ~S to ~S."
785 name
(classoid-name old
) (classoid-name new
))))))
787 (error "Cannot redefine standard type ~S." name
))
789 (warn "redefining DEFTYPE type to be a class: ~
790 ~/sb-impl::print-symbol-with-prefix/" name
)
791 (clear-info :type
:expander name
)
792 (clear-info :type
:source-location name
)))
795 (%note-type-defined name
)
796 ;; we need to handle things like
797 ;; (setf (find-class 'foo) (find-class 'integer))
799 ;; (setf (find-class 'integer) (find-class 'integer))
800 (cond ((built-in-classoid-p new-value
)
801 (setf (info :type
:kind name
)
802 (or (info :type
:kind name
) :defined
))
803 (let ((translation (built-in-classoid-translation new-value
)))
805 (setf (info :type
:translator name
) translation
))))
807 (setf (info :type
:kind name
) :instance
)))
808 (setf (classoid-cell-classoid cell
) new-value
)
809 (unless (eq (info :type
:compiler-layout name
)
810 (classoid-layout new-value
))
811 (setf (info :type
:compiler-layout name
)
812 (classoid-layout new-value
))))))
815 (defun %clear-classoid
(name cell
)
816 (ecase (info :type
:kind name
)
820 (error "Attempt to remove :PRIMITIVE type: ~S" name
))
821 ((:forthcoming-defclass-type
:instance
)
823 ;; Note: We cannot remove the classoid cell from the table,
824 ;; since compiled code may refer directly to the cell, and
825 ;; getting a different cell for a classoid with the same name
826 ;; just would not do.
828 ;; Remove the proper name of the classoid, if this was it.
829 (let* ((classoid (classoid-cell-classoid cell
))
830 (proper-name (classoid-name classoid
)))
831 (when (eq proper-name name
)
832 (setf (classoid-name classoid
) nil
)))
835 (setf (classoid-cell-classoid cell
) nil
836 (classoid-cell-pcl-class cell
) nil
))
837 (clear-info :type
:kind name
)
838 (clear-info :type
:documentation name
)
839 (clear-info :type
:compiler-layout name
)))))
841 ;;; Called when we are about to define NAME as a class meeting some
842 ;;; predicate (such as a meta-class type test.) The first result is
843 ;;; always of the desired class. The second result is any existing
844 ;;; LAYOUT for this name.
846 ;;; Again, this should be compiler-only, but easier to make this
848 (defun insured-find-classoid (name predicate constructor
)
849 (declare (type function predicate constructor
))
850 (let ((table *forward-referenced-layouts
*))
851 (with-locked-system-table (table)
852 (let* ((old (find-classoid name nil
))
853 (res (if (and old
(funcall predicate old
))
855 (funcall constructor
:name name
)))
856 (found (or (gethash name table
)
857 (when old
(classoid-layout old
)))))
859 (setf (layout-classoid found
) res
))
860 (values res found
)))))
862 ;;; If the classoid has a proper name, return the name, otherwise return
864 (defun classoid-proper-name (classoid)
865 #-sb-xc
(declare (type classoid classoid
))
866 (let ((name (classoid-name classoid
)))
867 (if (and name
(eq (find-classoid name nil
) classoid
))
871 ;;;; CLASS type operations
873 ;; referenced right away by !DEFINE-TYPE-CLASS.
874 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
875 ;; Actually this definition makes very little sense because
876 ;; (TYPE-ENUMERABLE (FIND-CLASSOID 'CHARACTER)) => T
877 ;; but (TYPE-ENUMERABLE (SPECIFIER-TYPE 'CHARACTER)) => NIL.
878 ;; You should never see the CLASSOID used as a type though,
879 ;; at least not from parsing and set operations.
880 ;; On a related note, (TYPE-ENUMERABLE (FIND-CLASSOID 'NULL))
881 ;; should probably be T, but you'll never see that type either.
882 ;; Perhaps a better definition of this function would be
883 ;; (if (classoid-translation x) (bug "enumerable-p classoid?") nil)
884 (defun classoid-enumerable-p (x) (eq (classoid-name x
) 'character
)))
885 (!define-type-class classoid
:enumerable
#'classoid-enumerable-p
886 :might-contain-other-types nil
)
888 ;;; We might be passed classoids with invalid layouts; in any pairwise
889 ;;; class comparison, we must ensure that both are valid before
891 (defun %ensure-classoid-valid
(classoid layout error-context
)
892 (aver (eq classoid
(layout-classoid layout
)))
893 (or (not (layout-invalid layout
))
894 (if (typep classoid
'standard-classoid
)
895 (let ((class (classoid-pcl-class classoid
)))
897 ((sb!pcl
:class-finalized-p class
)
898 (sb!pcl
::%force-cache-flushes class
)
900 ((sb!pcl
::class-has-a-forward-referenced-superclass-p class
)
902 (bug "~@<Invalid class ~S with forward-referenced superclass ~
905 (sb!pcl
::class-has-a-forward-referenced-superclass-p class
)
909 (sb!pcl
:finalize-inheritance class
)
911 (bug "~@<Don't know how to ensure validity of ~S (not a STANDARD-CLASSOID) ~
913 classoid
(or error-context
'subtypep
)))))
915 (defun %ensure-both-classoids-valid
(class1 class2
&optional errorp
)
916 (do ((layout1 (classoid-layout class1
) (classoid-layout class1
))
917 (layout2 (classoid-layout class2
) (classoid-layout class2
))
919 ((and (not (layout-invalid layout1
)) (not (layout-invalid layout2
)))
922 (unless (and (%ensure-classoid-valid class1 layout1 errorp
)
923 (%ensure-classoid-valid class2 layout2 errorp
))
924 (return-from %ensure-both-classoids-valid nil
))))
926 (defun update-object-layout-or-invalid (object layout
)
927 ;; FIXME: explain why this isn't (LAYOUT-FOR-STD-CLASS-P LAYOUT).
928 (if (layout-for-std-class-p (layout-of object
))
929 (sb!pcl
::check-wrapper-validity object
)
930 (sb!c
::%layout-invalid-error object layout
)))
932 ;;; Simple methods for TYPE= and SUBTYPEP should never be called when
933 ;;; the two classes are equal, since there are EQ checks in those
935 (!define-type-method
(classoid :simple-
=) (type1 type2
)
936 (aver (not (eq type1 type2
)))
939 (!define-type-method
(classoid :simple-subtypep
) (class1 class2
)
940 (aver (not (eq class1 class2
)))
942 (if (%ensure-both-classoids-valid class1 class2
)
943 (let ((subclasses2 (classoid-subclasses class2
)))
944 (if (and subclasses2
(gethash class1 subclasses2
))
946 (if (and (typep class1
'standard-classoid
)
947 (typep class2
'standard-classoid
)
948 (or (sb!pcl
::class-has-a-forward-referenced-superclass-p
949 (classoid-pcl-class class1
))
950 (sb!pcl
::class-has-a-forward-referenced-superclass-p
951 (classoid-pcl-class class2
))))
952 ;; If there's a forward-referenced class involved we don't know for sure.
953 ;; (There are cases which we /could/ figure out, but that doesn't seem
954 ;; to be required or important, really.)
959 ;;; When finding the intersection of a sealed class and some other
960 ;;; class (not hierarchically related) the intersection is the union
961 ;;; of the currently shared subclasses.
962 (defun sealed-class-intersection2 (sealed other
)
963 (declare (type classoid sealed other
))
964 (let ((s-sub (classoid-subclasses sealed
))
965 (o-sub (classoid-subclasses other
)))
966 (if (and s-sub o-sub
)
967 (collect ((res *empty-type
* type-union
))
968 (dohash ((subclass layout
) s-sub
:locked t
)
969 (declare (ignore layout
))
970 (when (gethash subclass o-sub
)
971 (res (specifier-type subclass
))))
975 (!define-type-method
(classoid :simple-intersection2
) (class1 class2
)
976 (declare (type classoid class1 class2
))
978 (%ensure-both-classoids-valid class1 class2
"type intersection")
979 (cond ((eq class1 class2
)
981 ;; If one is a subclass of the other, then that is the
983 ((let ((subclasses (classoid-subclasses class2
)))
984 (and subclasses
(gethash class1 subclasses
)))
986 ((let ((subclasses (classoid-subclasses class1
)))
987 (and subclasses
(gethash class2 subclasses
)))
989 ;; Otherwise, we can't in general be sure that the
990 ;; intersection is empty, since a subclass of both might be
991 ;; defined. But we can eliminate it for some special cases.
992 ((or (structure-classoid-p class1
)
993 (structure-classoid-p class2
))
994 ;; No subclass of both can be defined.
996 ((eq (classoid-state class1
) :sealed
)
997 ;; checking whether a subclass of both can be defined:
998 (sealed-class-intersection2 class1 class2
))
999 ((eq (classoid-state class2
) :sealed
)
1000 ;; checking whether a subclass of both can be defined:
1001 (sealed-class-intersection2 class2 class1
))
1003 ;; uncertain, since a subclass of both might be defined
1006 ;;; KLUDGE: we need this to deal with the special-case INSTANCE and
1007 ;;; FUNCALLABLE-INSTANCE types (which used to be CLASSOIDs until CSR
1008 ;;; discovered that this was incompatible with the MOP class
1009 ;;; hierarchy). See NAMED :COMPLEX-SUBTYPEP-ARG2
1010 (defvar *non-instance-classoid-types
*
1011 '(symbol system-area-pointer weak-pointer code-component
1012 lra fdefn random-class
))
1014 ;;; KLUDGE: we need this because of the need to represent
1015 ;;; intersections of two classes, even when empty at a given time, as
1016 ;;; uncanonicalized intersections because of the possibility of later
1017 ;;; defining a subclass of both classes. The necessity for changing
1018 ;;; the default return value from SUBTYPEP to NIL, T if no alternate
1019 ;;; method is present comes about because, unlike the other places we
1020 ;;; use INVOKE-COMPLEX-SUBTYPEP-ARG1-METHOD, in HAIRY methods and the
1021 ;;; like, classes are in their own hierarchy with no possibility of
1022 ;;; mixtures with other type classes.
1023 (!define-type-method
(classoid :complex-subtypep-arg2
) (type1 class2
)
1024 (if (and (intersection-type-p type1
)
1025 (> (count-if #'classoid-p
(intersection-type-types type1
)) 1))
1027 (invoke-complex-subtypep-arg1-method type1 class2 nil t
)))
1029 (!define-type-method
(classoid :negate
) (type)
1030 (make-negation-type :type type
))
1032 (!define-type-method
(classoid :unparse
) (type)
1033 (classoid-proper-name type
))
1037 ;;; the CLASSOID that we use to represent type information for
1038 ;;; STANDARD-CLASS and FUNCALLABLE-STANDARD-CLASS. The type system
1039 ;;; side does not need to distinguish between STANDARD-CLASS and
1040 ;;; FUNCALLABLE-STANDARD-CLASS.
1041 (def!struct
(standard-classoid (:include classoid
)
1042 (:constructor make-standard-classoid
)))
1043 ;;; a metaclass for classes which aren't standardlike but will never
1045 (def!struct
(static-classoid (:include classoid
)
1046 (:constructor make-static-classoid
)))
1048 ;;;; built-in classes
1050 ;;; The BUILT-IN-CLASSES list is a data structure which configures the
1051 ;;; creation of all the built-in classes. It contains all the info
1052 ;;; that we need to maintain the mapping between classes, compile-time
1053 ;;; types and run-time type codes. These options are defined:
1055 ;;; :TRANSLATION (default none)
1056 ;;; When this class is "parsed" as a type specifier, it is
1057 ;;; translated into the specified internal type representation,
1058 ;;; rather than being left as a class. This is used for types
1059 ;;; which we want to canonicalize to some other kind of type
1060 ;;; object because in general we want to be able to include more
1061 ;;; information than just the class (e.g. for numeric types.)
1063 ;;; :STATE (default :SEALED)
1064 ;;; The value of CLASS-STATE which we want on completion,
1065 ;;; indicating whether subclasses can be created at run-time.
1067 ;;; :HIERARCHICAL-P (default T unless any of the inherits are non-hierarchical)
1068 ;;; True if we can assign this class a unique inheritance depth.
1070 ;;; :CODES (default none)
1071 ;;; Run-time type codes which should be translated back to this
1072 ;;; class by CLASS-OF. Unspecified for abstract classes.
1074 ;;; :INHERITS (default this class and T)
1075 ;;; The class-precedence list for this class, with this class and
1078 ;;; :DIRECT-SUPERCLASSES (default to head of CPL)
1079 ;;; List of the direct superclasses of this class.
1081 ;;; NB: not to be confused with SB-PCL::*BUILT-IN-CLASSES*
1082 (!defvar
*!built-in-classes
*
1083 ;; To me these data would look nicer with commas instead of "#."
1084 '((t :state
:read-only
:translation t
)
1085 (character :codes
(#.sb
!vm
:character-widetag
)
1086 :translation
(character-set)
1087 :prototype-form
(code-char 42))
1088 (symbol :codes
(#.sb
!vm
:symbol-header-widetag
)
1089 :prototype-form
'#:mu
)
1091 (system-area-pointer :codes
(#.sb
!vm
:sap-widetag
)
1092 :prototype-form
(int-sap 42))
1093 (weak-pointer :codes
(#.sb
!vm
:weak-pointer-widetag
)
1094 :prototype-form
(make-weak-pointer (find-package "CL")))
1095 (code-component :codes
(#.sb
!vm
:code-header-widetag
))
1096 ;; should this be #!-(or x86 x86-64) ?
1097 (lra :codes
(#.sb
!vm
:return-pc-header-widetag
))
1098 (fdefn :codes
(#.sb
!vm
:fdefn-widetag
)
1099 :prototype-form
(make-fdefn "42"))
1100 (random-class) ; used for unknown type codes
1103 :codes
(#.sb
!vm
:closure-header-widetag
1104 #.sb
!vm
:simple-fun-header-widetag
)
1106 :prototype-form
(function (lambda () 42)))
1108 (number :translation number
)
1110 :translation complex
1112 :codes
(#.sb
!vm
:complex-widetag
)
1113 :prototype-form
(complex 42 42))
1114 (complex-single-float
1115 :translation
(complex single-float
)
1116 :inherits
(complex number
)
1117 :codes
(#.sb
!vm
:complex-single-float-widetag
)
1118 :prototype-form
(complex 42f0
42f0
))
1119 (complex-double-float
1120 :translation
(complex double-float
)
1121 :inherits
(complex number
)
1122 :codes
(#.sb
!vm
:complex-double-float-widetag
)
1123 :prototype-form
(complex 42d0
42d0
))
1126 :translation
(complex long-float
)
1127 :inherits
(complex number
)
1128 :codes
(#.sb
!vm
:complex-long-float-widetag
)
1129 :prototype-form
(complex 42l0 42l0))
1132 :translation simd-pack
1133 :codes
(#.sb
!vm
:simd-pack-widetag
)
1134 :prototype-form
(%make-simd-pack-ub64
42 42))
1135 (real :translation real
:inherits
(number))
1138 :inherits
(real number
))
1140 :translation single-float
1141 :inherits
(float real number
)
1142 :codes
(#.sb
!vm
:single-float-widetag
)
1143 :prototype-form
42f0
)
1145 :translation double-float
1146 :inherits
(float real number
)
1147 :codes
(#.sb
!vm
:double-float-widetag
)
1148 :prototype-form
42d0
)
1151 :translation long-float
1152 :inherits
(float real number
)
1153 :codes
(#.sb
!vm
:long-float-widetag
)
1154 :prototype-form
42l0)
1156 :translation rational
1157 :inherits
(real number
))
1159 :translation
(and rational
(not integer
))
1160 :inherits
(rational real number
)
1161 :codes
(#.sb
!vm
:ratio-widetag
)
1162 :prototype-form
1/42)
1164 :translation integer
1165 :inherits
(rational real number
))
1167 :translation
(integer #.sb
!xc
:most-negative-fixnum
1168 #.sb
!xc
:most-positive-fixnum
)
1169 :inherits
(integer rational real number
)
1170 :codes
#.
(mapcar #'symbol-value sb
!vm
::fixnum-lowtags
)
1173 :translation
(and integer
(not fixnum
))
1174 :inherits
(integer rational real number
)
1175 :codes
(#.sb
!vm
:bignum-widetag
)
1176 :prototype-form
(expt 2 #.
(* sb
!vm
:n-word-bits
(/ 3 2))))
1178 (array :translation array
:codes
(#.sb
!vm
:complex-array-widetag
)
1180 :prototype-form
(make-array nil
:adjustable t
))
1182 :translation simple-array
:codes
(#.sb
!vm
:simple-array-widetag
)
1184 :prototype-form
(make-array nil
))
1186 :translation
(or cons
(member nil
) vector extended-sequence
)
1190 :translation vector
:codes
(#.sb
!vm
:complex-vector-widetag
)
1191 :direct-superclasses
(array sequence
)
1192 :inherits
(array sequence
))
1194 :translation simple-vector
:codes
(#.sb
!vm
:simple-vector-widetag
)
1195 :direct-superclasses
(vector simple-array
)
1196 :inherits
(vector simple-array array sequence
)
1197 :prototype-form
(make-array 0))
1199 :translation bit-vector
:codes
(#.sb
!vm
:complex-bit-vector-widetag
)
1200 :inherits
(vector array sequence
)
1201 :prototype-form
(make-array 0 :element-type
'bit
:fill-pointer t
))
1203 :translation simple-bit-vector
:codes
(#.sb
!vm
:simple-bit-vector-widetag
)
1204 :direct-superclasses
(bit-vector simple-array
)
1205 :inherits
(bit-vector vector simple-array
1207 :prototype-form
(make-array 0 :element-type
'bit
))
1208 (simple-array-unsigned-byte-2
1209 :translation
(simple-array (unsigned-byte 2) (*))
1210 :codes
(#.sb
!vm
:simple-array-unsigned-byte-2-widetag
)
1211 :direct-superclasses
(vector simple-array
)
1212 :inherits
(vector simple-array array sequence
)
1213 :prototype-form
(make-array 0 :element-type
'(unsigned-byte 2)))
1214 (simple-array-unsigned-byte-4
1215 :translation
(simple-array (unsigned-byte 4) (*))
1216 :codes
(#.sb
!vm
:simple-array-unsigned-byte-4-widetag
)
1217 :direct-superclasses
(vector simple-array
)
1218 :inherits
(vector simple-array array sequence
)
1219 :prototype-form
(make-array 0 :element-type
'(unsigned-byte 4)))
1220 (simple-array-unsigned-byte-7
1221 :translation
(simple-array (unsigned-byte 7) (*))
1222 :codes
(#.sb
!vm
:simple-array-unsigned-byte-7-widetag
)
1223 :direct-superclasses
(vector simple-array
)
1224 :inherits
(vector simple-array array sequence
)
1225 :prototype-form
(make-array 0 :element-type
'(unsigned-byte 7)))
1226 (simple-array-unsigned-byte-8
1227 :translation
(simple-array (unsigned-byte 8) (*))
1228 :codes
(#.sb
!vm
:simple-array-unsigned-byte-8-widetag
)
1229 :direct-superclasses
(vector simple-array
)
1230 :inherits
(vector simple-array array sequence
)
1231 :prototype-form
(make-array 0 :element-type
'(unsigned-byte 8)))
1232 (simple-array-unsigned-byte-15
1233 :translation
(simple-array (unsigned-byte 15) (*))
1234 :codes
(#.sb
!vm
:simple-array-unsigned-byte-15-widetag
)
1235 :direct-superclasses
(vector simple-array
)
1236 :inherits
(vector simple-array array sequence
)
1237 :prototype-form
(make-array 0 :element-type
'(unsigned-byte 15)))
1238 (simple-array-unsigned-byte-16
1239 :translation
(simple-array (unsigned-byte 16) (*))
1240 :codes
(#.sb
!vm
:simple-array-unsigned-byte-16-widetag
)
1241 :direct-superclasses
(vector simple-array
)
1242 :inherits
(vector simple-array array sequence
)
1243 :prototype-form
(make-array 0 :element-type
'(unsigned-byte 16)))
1245 (simple-array-unsigned-fixnum
1246 :translation
(simple-array (unsigned-byte #.sb
!vm
:n-positive-fixnum-bits
) (*))
1247 :codes
(#.sb
!vm
:simple-array-unsigned-fixnum-widetag
)
1248 :direct-superclasses
(vector simple-array
)
1249 :inherits
(vector simple-array array sequence
)
1250 :prototype-form
(make-array 0
1251 :element-type
'(unsigned-byte #.sb
!vm
:n-positive-fixnum-bits
)))
1253 (simple-array-unsigned-byte-31
1254 :translation
(simple-array (unsigned-byte 31) (*))
1255 :codes
(#.sb
!vm
:simple-array-unsigned-byte-31-widetag
)
1256 :direct-superclasses
(vector simple-array
)
1257 :inherits
(vector simple-array array sequence
)
1258 :prototype-form
(make-array 0 :element-type
'(unsigned-byte 31)))
1259 (simple-array-unsigned-byte-32
1260 :translation
(simple-array (unsigned-byte 32) (*))
1261 :codes
(#.sb
!vm
:simple-array-unsigned-byte-32-widetag
)
1262 :direct-superclasses
(vector simple-array
)
1263 :inherits
(vector simple-array array sequence
)
1264 :prototype-form
(make-array 0 :element-type
'(unsigned-byte 32)))
1265 #!+#.
(cl:if
(cl:= 64 sb
!vm
:n-word-bits
) '(and) '(or))
1266 (simple-array-unsigned-byte-63
1267 :translation
(simple-array (unsigned-byte 63) (*))
1268 :codes
(#.sb
!vm
:simple-array-unsigned-byte-63-widetag
)
1269 :direct-superclasses
(vector simple-array
)
1270 :inherits
(vector simple-array array sequence
)
1271 :prototype-form
(make-array 0 :element-type
'(unsigned-byte 63)))
1272 #!+#.
(cl:if
(cl:= 64 sb
!vm
:n-word-bits
) '(and) '(or))
1273 (simple-array-unsigned-byte-64
1274 :translation
(simple-array (unsigned-byte 64) (*))
1275 :codes
(#.sb
!vm
:simple-array-unsigned-byte-64-widetag
)
1276 :direct-superclasses
(vector simple-array
)
1277 :inherits
(vector simple-array array sequence
)
1278 :prototype-form
(make-array 0 :element-type
'(unsigned-byte 64)))
1279 (simple-array-signed-byte-8
1280 :translation
(simple-array (signed-byte 8) (*))
1281 :codes
(#.sb
!vm
:simple-array-signed-byte-8-widetag
)
1282 :direct-superclasses
(vector simple-array
)
1283 :inherits
(vector simple-array array sequence
)
1284 :prototype-form
(make-array 0 :element-type
'(signed-byte 8)))
1285 (simple-array-signed-byte-16
1286 :translation
(simple-array (signed-byte 16) (*))
1287 :codes
(#.sb
!vm
:simple-array-signed-byte-16-widetag
)
1288 :direct-superclasses
(vector simple-array
)
1289 :inherits
(vector simple-array array sequence
)
1290 :prototype-form
(make-array 0 :element-type
'(signed-byte 16)))
1292 (simple-array-fixnum
1293 :translation
(simple-array (signed-byte #.sb
!vm
:n-fixnum-bits
)
1295 :codes
(#.sb
!vm
:simple-array-fixnum-widetag
)
1296 :direct-superclasses
(vector simple-array
)
1297 :inherits
(vector simple-array array sequence
)
1298 :prototype-form
(make-array 0
1300 '(signed-byte #.sb
!vm
:n-fixnum-bits
)))
1302 (simple-array-signed-byte-32
1303 :translation
(simple-array (signed-byte 32) (*))
1304 :codes
(#.sb
!vm
:simple-array-signed-byte-32-widetag
)
1305 :direct-superclasses
(vector simple-array
)
1306 :inherits
(vector simple-array array sequence
)
1307 :prototype-form
(make-array 0 :element-type
'(signed-byte 32)))
1308 #!+#.
(cl:if
(cl:= 64 sb
!vm
:n-word-bits
) '(and) '(or))
1309 (simple-array-signed-byte-64
1310 :translation
(simple-array (signed-byte 64) (*))
1311 :codes
(#.sb
!vm
:simple-array-signed-byte-64-widetag
)
1312 :direct-superclasses
(vector simple-array
)
1313 :inherits
(vector simple-array array sequence
)
1314 :prototype-form
(make-array 0 :element-type
'(signed-byte 64)))
1315 (simple-array-single-float
1316 :translation
(simple-array single-float
(*))
1317 :codes
(#.sb
!vm
:simple-array-single-float-widetag
)
1318 :direct-superclasses
(vector simple-array
)
1319 :inherits
(vector simple-array array sequence
)
1320 :prototype-form
(make-array 0 :element-type
'single-float
))
1321 (simple-array-double-float
1322 :translation
(simple-array double-float
(*))
1323 :codes
(#.sb
!vm
:simple-array-double-float-widetag
)
1324 :direct-superclasses
(vector simple-array
)
1325 :inherits
(vector simple-array array sequence
)
1326 :prototype-form
(make-array 0 :element-type
'double-float
))
1328 (simple-array-long-float
1329 :translation
(simple-array long-float
(*))
1330 :codes
(#.sb
!vm
:simple-array-long-float-widetag
)
1331 :direct-superclasses
(vector simple-array
)
1332 :inherits
(vector simple-array array sequence
)
1333 :prototype-form
(make-array 0 :element-type
'long-float
))
1334 (simple-array-complex-single-float
1335 :translation
(simple-array (complex single-float
) (*))
1336 :codes
(#.sb
!vm
:simple-array-complex-single-float-widetag
)
1337 :direct-superclasses
(vector simple-array
)
1338 :inherits
(vector simple-array array sequence
)
1339 :prototype-form
(make-array 0 :element-type
'(complex single-float
)))
1340 (simple-array-complex-double-float
1341 :translation
(simple-array (complex double-float
) (*))
1342 :codes
(#.sb
!vm
:simple-array-complex-double-float-widetag
)
1343 :direct-superclasses
(vector simple-array
)
1344 :inherits
(vector simple-array array sequence
)
1345 :prototype-form
(make-array 0 :element-type
'(complex double-float
)))
1347 (simple-array-complex-long-float
1348 :translation
(simple-array (complex long-float
) (*))
1349 :codes
(#.sb
!vm
:simple-array-complex-long-float-widetag
)
1350 :direct-superclasses
(vector simple-array
)
1351 :inherits
(vector simple-array array sequence
)
1352 :prototype-form
(make-array 0 :element-type
'(complex long-float
)))
1355 :direct-superclasses
(vector)
1356 :inherits
(vector array sequence
))
1358 :translation simple-string
1359 :direct-superclasses
(string simple-array
)
1360 :inherits
(string vector simple-array array sequence
))
1362 :translation
(vector nil
)
1363 :codes
(#.sb
!vm
:complex-vector-nil-widetag
)
1364 :direct-superclasses
(string)
1365 :inherits
(string vector array sequence
)
1366 :prototype-form
(make-array 0 :element-type
'nil
:fill-pointer t
))
1368 :translation
(simple-array nil
(*))
1369 :codes
(#.sb
!vm
:simple-array-nil-widetag
)
1370 :direct-superclasses
(vector-nil simple-string
)
1371 :inherits
(vector-nil simple-string string vector simple-array
1373 :prototype-form
(make-array 0 :element-type
'nil
))
1375 :translation base-string
1376 :codes
(#.sb
!vm
:complex-base-string-widetag
)
1377 :direct-superclasses
(string)
1378 :inherits
(string vector array sequence
)
1379 :prototype-form
(make-array 0 :element-type
'base-char
:fill-pointer t
))
1381 :translation simple-base-string
1382 :codes
(#.sb
!vm
:simple-base-string-widetag
)
1383 :direct-superclasses
(base-string simple-string
)
1384 :inherits
(base-string simple-string string vector simple-array
1386 :prototype-form
(make-array 0 :element-type
'base-char
))
1389 :translation
(vector character
)
1390 :codes
(#.sb
!vm
:complex-character-string-widetag
)
1391 :direct-superclasses
(string)
1392 :inherits
(string vector array sequence
)
1393 :prototype-form
(make-array 0 :element-type
'character
:fill-pointer t
))
1395 (simple-character-string
1396 :translation
(simple-array character
(*))
1397 :codes
(#.sb
!vm
:simple-character-string-widetag
)
1398 :direct-superclasses
(character-string simple-string
)
1399 :inherits
(character-string simple-string string vector simple-array
1401 :prototype-form
(make-array 0 :element-type
'character
))
1403 :translation
(or cons
(member nil
))
1404 :inherits
(sequence))
1406 :codes
(#.sb
!vm
:list-pointer-lowtag
)
1408 :inherits
(list sequence
)
1409 :prototype-form
(cons nil nil
))
1411 :translation
(member nil
)
1412 :inherits
(symbol list sequence
)
1413 :direct-superclasses
(symbol list
)
1414 :prototype-form
'nil
)
1425 :inherits
(stream))))
1427 ;;; See also src/code/class-init.lisp where we finish setting up the
1428 ;;; translations for built-in types.
1430 (dolist (x *!built-in-classes
*)
1431 #-sb-xc-host
(/show0
"at head of loop over *!BUILT-IN-CLASSES*")
1434 (translation nil trans-p
)
1440 (hierarchical-p t
) ; might be modified below
1441 (direct-superclasses (if inherits
1442 (list (car inherits
))
1445 (declare (ignore codes state translation prototype-form
))
1446 (let ((inherits-list (if (eq name t
)
1448 (cons t
(reverse inherits
))))
1449 (classoid (make-built-in-classoid
1451 :translation
(if trans-p
:initializing nil
)
1452 :direct-superclasses
1455 (mapcar #'find-classoid direct-superclasses
)))))
1456 (mark-ctype-interned classoid
)
1457 (setf (info :type
:kind name
) :primitive
1458 (classoid-cell-classoid (find-classoid-cell name
:create t
)) classoid
)
1460 (setf (info :type
:builtin name
) classoid
))
1461 (let* ((inherits-vector
1465 (classoid-layout (find-classoid x
))))
1466 (when (minusp (layout-depthoid super-layout
))
1467 (setf hierarchical-p nil
))
1470 (depthoid (if hierarchical-p
1471 (or depth
(length inherits-vector
))
1474 (find-and-init-or-check-layout name
1479 :invalidate nil
)))))
1480 (/show0
"done with loop over *!BUILT-IN-CLASSES*"))
1482 ;;; Define temporary PCL STANDARD-CLASSes. These will be set up
1483 ;;; correctly and the Lisp layout replaced by a PCL wrapper after PCL
1484 ;;; is loaded and the class defined.
1486 (/show0
"about to define temporary STANDARD-CLASSes")
1487 ;; You'd think with all the pedantic explanation in here it would at least
1488 ;; be right, but it isn't: layout-inherits for FUNDAMENTAL-STREAM
1489 ;; ends up as (T SLOT-OBJECT STREAM STANDARD-OBJECT)
1490 (dolist (x '(;; Why is STREAM duplicated in this list? Because, when
1491 ;; the inherits-vector of FUNDAMENTAL-STREAM is set up,
1492 ;; a vector containing the elements of the list below,
1493 ;; i.e. '(T STREAM STREAM), is created, and
1494 ;; this is what the function ORDER-LAYOUT-INHERITS
1497 ;; So, the purpose is to guarantee a valid layout for
1498 ;; the FUNDAMENTAL-STREAM class, matching what
1499 ;; ORDER-LAYOUT-INHERITS would do.
1500 ;; ORDER-LAYOUT-INHERITS would place STREAM at index 2
1501 ;; in the INHERITS(-VECTOR). Index 1 would not be
1502 ;; filled, so STREAM is duplicated there (as
1503 ;; ORDER-LAYOUTS-INHERITS would do). Maybe the
1504 ;; duplicate definition could be removed (removing a
1505 ;; STREAM element), because FUNDAMENTAL-STREAM is
1506 ;; redefined after PCL is set up, anyway. But to play
1507 ;; it safely, we define the class with a valid INHERITS
1509 (fundamental-stream (t stream stream
))))
1510 (/show0
"defining temporary STANDARD-CLASS")
1511 (let* ((name (first x
))
1512 (inherits-list (second x
))
1513 (classoid (make-standard-classoid :name name
))
1514 (classoid-cell (find-classoid-cell name
:create t
)))
1515 ;; Needed to open-code the MAP, below
1516 (declare (type list inherits-list
))
1517 (setf (classoid-cell-classoid classoid-cell
) classoid
1518 (info :type
:kind name
) :instance
)
1519 (let ((inherits (map 'simple-vector
1521 (classoid-layout (find-classoid x
)))
1523 #-sb-xc-host
(/show0
"INHERITS=..") #-sb-xc-host
(/hexstr inherits
)
1524 (register-layout (find-and-init-or-check-layout name
0 inherits -
1 0)
1526 (/show0
"done defining temporary STANDARD-CLASSes"))
1528 ;;; Now that we have set up the class heterarchy, seal the sealed
1529 ;;; classes. This must be done after the subclasses have been set up.
1531 (dolist (x *!built-in-classes
*)
1532 (destructuring-bind (name &key
(state :sealed
) &allow-other-keys
) x
1533 (setf (classoid-state (find-classoid name
)) state
))))
1535 ;;;; class definition/redefinition
1537 ;;; This is to be called whenever we are altering a class.
1538 (defun %modify-classoid
(classoid)
1540 (when (member (classoid-state classoid
) '(:read-only
:frozen
))
1541 ;; FIXME: This should probably be CERROR.
1542 (warn "making ~(~A~) class ~S writable"
1543 (classoid-state classoid
)
1544 (classoid-name classoid
))
1545 (setf (classoid-state classoid
) nil
)))
1547 ;;; Mark LAYOUT as invalid. Setting DEPTHOID -1 helps cause unsafe
1548 ;;; structure type tests to fail. Remove class from all superclasses
1549 ;;; too (might not be registered, so might not be in subclasses of the
1550 ;;; nominal superclasses.) We set the layout-clos-hash slots to 0 to
1551 ;;; invalidate the wrappers for specialized dispatch functions, which
1552 ;;; use those slots as indexes into tables.
1553 (defun %invalidate-layout
(layout)
1554 (declare (type layout layout
))
1555 (setf (layout-invalid layout
) t
1556 (layout-depthoid layout
) -
1)
1557 (setf (layout-clos-hash layout
) 0)
1558 (let ((inherits (layout-inherits layout
))
1559 (classoid (layout-classoid layout
)))
1560 (%modify-classoid classoid
)
1561 (dovector (super inherits
)
1562 (let ((subs (classoid-subclasses (layout-classoid super
))))
1564 (remhash classoid subs
)))))
1567 ;;;; cold loading initializations
1569 ;;; FIXME: It would be good to arrange for this to be called when the
1570 ;;; cross-compiler is being built, not just when the target Lisp is
1571 ;;; being cold loaded. Perhaps this could be moved to its own file
1572 ;;; late in the build-order.lisp-expr sequence, and be put in
1573 ;;; !COLD-INIT-FORMS there?
1574 (defun !class-finalize
()
1575 (dohash ((name layout
) *forward-referenced-layouts
*)
1576 (let ((class (find-classoid name nil
)))
1578 (setf (layout-classoid layout
) (make-undefined-classoid name
)))
1579 ((eq (classoid-layout class
) layout
)
1580 (remhash name
*forward-referenced-layouts
*))
1582 (error "Something strange with forward layout for ~S:~% ~S"
1586 #-sb-xc-host
(/show0
"about to set *BUILT-IN-CLASS-CODES*")
1587 (setq **built-in-class-codes
**
1588 (let* ((initial-element
1590 ;; KLUDGE: There's a FIND-CLASSOID DEFTRANSFORM for
1591 ;; constant class names which creates fast but
1592 ;; non-cold-loadable, non-compact code. In this
1593 ;; context, we'd rather have compact, cold-loadable
1594 ;; code. -- WHN 19990928
1595 (declare (notinline find-classoid
))
1596 (classoid-layout (find-classoid 'random-class
))))
1597 (res (make-array 256 :initial-element initial-element
)))
1598 (dolist (x *!built-in-classes
* res
)
1599 (destructuring-bind (name &key codes
&allow-other-keys
)
1601 (let ((layout (classoid-layout (find-classoid name
))))
1602 (dolist (code codes
)
1603 (setf (svref res code
) layout
)))))))
1604 #-sb-xc-host
(/show0
"done setting *BUILT-IN-CLASS-CODES*"))
1606 (!defun-from-collected-cold-init-forms
!classes-cold-init
)