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.
21 ;;; Its definition occurs in 'early-classoid.lisp'
23 (defmethod make-load-form ((self classoid
) &optional env
)
24 (declare (ignore env
))
25 (let ((name (classoid-name self
)))
26 (if (and name
(eq (find-classoid name nil
) self
))
27 `(find-classoid ',name
)
28 (error "can't use anonymous or undefined class as constant:~% ~S"
32 ;;;; basic LAYOUT stuff
34 ;;; a vector of conses, initialized by genesis
36 ;;; In each cons, the car is the symbol naming the layout, and the
37 ;;; cdr is the layout itself.
38 (defvar *!initial-layouts
*)
40 ;;; a table mapping class names to layouts for classes we have
41 ;;; referenced but not yet loaded. This is initialized from an alist
42 ;;; created by genesis describing the layouts that genesis created at
44 (defvar *forward-referenced-layouts
*)
46 ;; Protected by *WORLD-LOCK*
47 (setq *forward-referenced-layouts
* (make-hash-table :test
'equal
))
49 (/show0
"processing *!INITIAL-LAYOUTS*")
50 (dovector (x *!initial-layouts
*)
51 (setf (layout-clos-hash (cdr x
)) (random-layout-clos-hash))
52 (setf (gethash (car x
) *forward-referenced-layouts
*)
54 (/show0
"done processing *!INITIAL-LAYOUTS*")))
56 ;;; The LAYOUT structure itself is defined in 'early-classoid.lisp'
58 (declaim (inline layout-for-std-class-p
))
59 (defun layout-for-std-class-p (x)
60 (logtest (layout-%flags x
) +pcl-object-layout-flag
+))
62 (defmethod print-object ((layout layout
) stream
)
63 (print-unreadable-object (layout stream
:type t
:identity t
)
65 "for ~S~@[, INVALID=~S~]"
66 (layout-proper-name layout
)
67 (layout-invalid layout
))))
69 (eval-when (#-sb-xc
:compile-toplevel
:load-toplevel
:execute
)
70 (defun layout-proper-name (layout)
71 (classoid-proper-name (layout-classoid layout
))))
73 ;;;; support for the hash values used by CLOS when working with LAYOUTs
75 ;;; a generator for random values suitable for the CLOS-HASH slots of
76 ;;; LAYOUTs. We use our own RANDOM-STATE here because we'd like
77 ;;; pseudo-random values to come the same way in the target even when
78 ;;; we make minor changes to the system, in order to reduce the
79 ;;; mysteriousness of possible CLOS bugs.
80 (defvar *layout-clos-hash-random-state
*)
81 (defun random-layout-clos-hash ()
82 ;; FIXME: I'm not sure why this expression is (1+ (RANDOM FOO)),
83 ;; returning a strictly positive value. I copied it verbatim from
84 ;; CMU CL INITIALIZE-LAYOUT-HASH, so presumably it works, but I
85 ;; dunno whether the hash values are really supposed to be 1-based.
86 ;; They're declared as INDEX.. Or is this a hack to try to avoid
87 ;; having to use bignum arithmetic? Or what? An explanation would be
90 ;; an explanation is provided in Kiczales and Rodriguez, "Efficient
91 ;; Method Dispatch in PCL", 1990. -- CSR, 2005-11-30
92 (1+ (random (1- layout-clos-hash-limit
)
93 (if (boundp '*layout-clos-hash-random-state
*)
94 *layout-clos-hash-random-state
*
95 (setf *layout-clos-hash-random-state
*
96 (make-random-state))))))
98 ;;; If we can't find any existing layout, then we create a new one
99 ;;; storing it in *FORWARD-REFERENCED-LAYOUTS*. In classic CMU CL, we
100 ;;; used to immediately check for compatibility, but for
101 ;;; cross-compilability reasons (i.e. convenience of using this
102 ;;; function in a MAKE-LOAD-FORM expression) that functionality has
103 ;;; been split off into INIT-OR-CHECK-LAYOUT.
104 (declaim (ftype (sfunction (symbol) layout
) find-layout
))
105 ;; The comment "This seems ..." is misleading but I don't have a better one.
106 ;; FIND-LAYOUT is used by FIND-AND-INIT-OR-CHECK-LAYOUT which is used
107 ;; by FOP-LAYOUT, so clearly it's used when reading fasl files.
108 (defun find-layout (name)
109 ;; This seems to be currently used only from the compiler, but make
110 ;; it thread-safe all the same. We need to lock *F-R-L* before doing
111 ;; FIND-CLASSOID in case (SETF FIND-CLASSOID) happens in parallel.
112 (let ((table *forward-referenced-layouts
*))
114 (let ((classoid (find-classoid name nil
)))
115 (or (and classoid
(classoid-layout classoid
))
116 (values (ensure-gethash name table
120 (make-undefined-classoid name
))))))))))
122 ;;; If LAYOUT is uninitialized, initialize it with CLASSOID, LENGTH,
123 ;;; INHERITS, DEPTHOID, and BITMAP.
124 ;;; Otherwise require that it be consistent with the existing values.
126 ;;; UNDEFINED-CLASS values are interpreted specially as "we don't know
127 ;;; anything about the class", so if LAYOUT is initialized, any
128 ;;; preexisting class slot value is OK, and if it's not initialized,
129 ;;; its class slot value is set to an UNDEFINED-CLASS. -- FIXME: This
130 ;;; is no longer true, :UNINITIALIZED used instead.
131 (declaim (ftype (function (layout classoid index fixnum simple-vector
132 layout-depthoid layout-bitmap
)
133 layout
) %init-or-check-layout
))
134 (defun %init-or-check-layout
(layout classoid length flags inherits depthoid bitmap
)
135 (cond ((eq (layout-invalid layout
) :uninitialized
)
136 ;; There was no layout before, we just created one which
137 ;; we'll now initialize with our information.
138 (setf (layout-length layout
) length
139 (layout-%flags layout
) flags
140 (layout-inherits layout
) inherits
141 (layout-depthoid layout
) depthoid
142 (layout-bitmap layout
) bitmap
143 (layout-classoid layout
) classoid
144 (layout-invalid layout
) nil
))
145 ;; FIXME: Now that LAYOUTs are born :UNINITIALIZED, maybe this
146 ;; clause is not needed?
147 ((not *type-system-initialized
*)
148 (setf (layout-classoid layout
) classoid
))
150 ;; There was an old layout already initialized with old
151 ;; information, and we'll now check that old information
152 ;; which was known with certainty is consistent with current
153 ;; information which is known with certainty.
154 (check-layout layout classoid length inherits depthoid bitmap
)))
157 ;;; In code for the target Lisp, we don't dump LAYOUTs using the
158 ;;; standard load form mechanism, we use special fops instead, in
159 ;;; order to make cold load come out right. But when we're building
160 ;;; the cross-compiler, we can't do that because we don't have access
161 ;;; to special non-ANSI low-level things like special fops, and we
162 ;;; don't need to do that anyway because our code isn't going to be
163 ;;; cold loaded, so we use the ordinary load form system.
165 (defmethod make-load-form ((layout layout
) &optional env
)
166 (declare (ignore env
))
167 (when (layout-invalid layout
)
168 (sb!c
::compiler-error
"can't dump reference to obsolete class: ~S"
169 (layout-classoid layout
)))
170 (let* ((classoid (layout-classoid layout
))
171 (name (classoid-name classoid
)))
172 (aver (= (layout-%flags layout
)
174 (structure-classoid +structure-layout-flag
+)
175 (condition-classoid +condition-layout-flag
+)
177 (bug "xc MAKE-LOAD-FORM on undefined layout"))
180 (sb!c
::compiler-error
"can't dump anonymous LAYOUT: ~S" layout
))
181 ;; Since LAYOUT refers to a class which refers back to the LAYOUT,
182 ;; we have to do this in two stages, like the TREE-WITH-PARENT
183 ;; example in the MAKE-LOAD-FORM entry in the ANSI spec.
185 ;; "creation" form (which actually doesn't create a new LAYOUT if
186 ;; there's a preexisting one with this name)
187 `(find-layout ',name
)
188 ;; "initialization" form (which actually doesn't initialize
189 ;; preexisting LAYOUTs, just checks that they're consistent).
190 `(%init-or-check-layout
',layout
191 ',(layout-classoid layout
)
192 ',(layout-length layout
)
193 ',(layout-%flags layout
)
194 ',(layout-inherits layout
)
195 ',(layout-depthoid layout
)
196 ',(layout-bitmap layout
)))))
197 (!set-load-form-method layout
(:xc
:target
) :ignore-it
)
199 ;;; If LAYOUT's slot values differ from the specified slot values in
200 ;;; any interesting way, then give a warning and return T.
201 (declaim (ftype (function (simple-string
208 redefine-layout-warning
))
209 (defun redefine-layout-warning (old-context old-layout
210 context length inherits depthoid bitmap
)
211 (declare (type layout old-layout
) (type simple-string old-context context
))
212 (let ((name (layout-proper-name old-layout
))
213 (old-inherits (layout-inherits old-layout
)))
214 (or (when (mismatch old-inherits inherits
:key
#'layout-proper-name
)
215 (warn "change in superclasses of class ~S:~% ~
216 ~A superclasses: ~S~% ~
220 (map 'list
#'layout-proper-name old-inherits
)
222 (map 'list
#'layout-proper-name inherits
))
224 (let ((diff (mismatch old-inherits inherits
)))
226 (warn "in class ~S:~% ~
227 ~@(~A~) definition of superclass ~S is incompatible with~% ~
231 (layout-proper-name (svref old-inherits diff
))
234 (let ((old-length (layout-length old-layout
)))
235 (unless (= old-length length
)
236 (warn "change in instance length of class ~S:~% ~
240 old-context old-length
243 (let ((old-bitmap (layout-bitmap old-layout
)))
244 (unless (= old-bitmap bitmap
)
245 (warn "change in placement of raw slots of class ~S ~
246 between the ~A definition and the ~A definition"
247 name old-context context
)
249 (unless (= (layout-depthoid old-layout
) depthoid
)
250 (warn "change in the inheritance structure of class ~S~% ~
251 between the ~A definition and the ~A definition"
252 name old-context context
)
255 ;;; Require that LAYOUT data be consistent with CLASSOID, LENGTH,
256 ;;; INHERITS, DEPTHOID, and BITMAP.
257 (declaim (ftype (function (layout classoid index simple-vector layout-depthoid layout-bitmap
))
259 (defun check-layout (layout classoid length inherits depthoid bitmap
)
260 (aver (eq (layout-classoid layout
) classoid
))
261 (when (redefine-layout-warning "current" layout
262 "compile time" length inherits depthoid bitmap
)
263 ;; Classic CMU CL had more options here. There are several reasons
264 ;; why they might want more options which are less appropriate for
265 ;; us: (1) It's hard to fit the classic CMU CL flexible approach
266 ;; into the ANSI-style MAKE-LOAD-FORM system, and having a
267 ;; non-MAKE-LOAD-FORM-style system is painful when we're trying to
268 ;; make the cross-compiler run under vanilla ANSI Common Lisp. (2)
269 ;; We have CLOS now, and if you want to be able to flexibly
270 ;; redefine classes without restarting the system, it'd make sense
271 ;; to use that, so supporting complexity in order to allow
272 ;; modifying DEFSTRUCTs without restarting the system is a low
273 ;; priority. (3) We now have the ability to rebuild the SBCL
274 ;; system from scratch, so we no longer need this functionality in
275 ;; order to maintain the SBCL system by modifying running images.
276 (error "The loaded code expects an incompatible layout for class ~S."
277 (layout-proper-name layout
)))
280 ;;; a common idiom (the same as CMU CL FIND-LAYOUT) rolled up into a
281 ;;; single function call
283 ;;; Used by the loader to forward-reference layouts for classes whose
284 ;;; definitions may not have been loaded yet. This allows type tests
285 ;;; to be loaded when the type definition hasn't been loaded yet.
286 (declaim (ftype (function (symbol index fixnum simple-vector layout-depthoid layout-bitmap
)
288 find-and-init-or-check-layout
))
289 (defun find-and-init-or-check-layout (name length flags inherits depthoid bitmap
)
290 (truly-the ; avoid an "assertion too complex to check" optimizer note
291 (values layout
&optional
)
293 (let ((layout (find-layout name
)))
294 (%init-or-check-layout layout
295 (or (find-classoid name nil
)
296 (layout-classoid layout
))
303 ;;; Record LAYOUT as the layout for its class, adding it as a subtype
304 ;;; of all superclasses. This is the operation that "installs" a
305 ;;; layout for a class in the type system, clobbering any old layout.
306 ;;; However, this does not modify the class namespace; that is a
307 ;;; separate operation (think anonymous classes.)
308 ;;; -- If INVALIDATE, then all the layouts for any old definition
309 ;;; and subclasses are invalidated, and the SUBCLASSES slot is cleared.
310 ;;; -- If DESTRUCT-LAYOUT, then this is some old layout, and is to be
311 ;;; destructively modified to hold the same type information.
312 (eval-when (#-sb-xc
:compile-toplevel
:load-toplevel
:execute
)
313 (defun register-layout (layout &key
(invalidate t
) destruct-layout
)
314 (declare (type layout layout
) (type (or layout null
) destruct-layout
))
316 (let* ((classoid (layout-classoid layout
))
317 (classoid-layout (classoid-layout classoid
))
318 (subclasses (classoid-subclasses classoid
)))
320 ;; Attempting to register ourselves with a temporary undefined
321 ;; class placeholder is almost certainly a programmer error. (I
322 ;; should know, I did it.) -- WHN 19990927
323 (aver (not (undefined-classoid-p classoid
)))
325 ;; This assertion dates from classic CMU CL. The rationale is
326 ;; probably that calling REGISTER-LAYOUT more than once for the
327 ;; same LAYOUT is almost certainly a programmer error.
328 (aver (not (eq classoid-layout layout
)))
330 ;; Figure out what classes are affected by the change, and issue
331 ;; appropriate warnings and invalidations.
332 (when classoid-layout
333 (%modify-classoid classoid
)
335 (dohash ((subclass subclass-layout
) subclasses
:locked t
)
336 (%modify-classoid subclass
)
338 (%invalidate-layout subclass-layout
))))
340 (%invalidate-layout classoid-layout
)
341 (setf (classoid-subclasses classoid
) nil
)))
344 (setf (layout-invalid destruct-layout
) nil
345 (layout-inherits destruct-layout
) (layout-inherits layout
)
346 (layout-depthoid destruct-layout
) (layout-depthoid layout
)
347 (layout-length destruct-layout
) (layout-length layout
)
348 (layout-bitmap destruct-layout
) (layout-bitmap layout
)
349 (layout-info destruct-layout
) (layout-info layout
)
350 (classoid-layout classoid
) destruct-layout
)
351 (setf (layout-invalid layout
) nil
352 (classoid-layout classoid
) layout
))
354 (dovector (super-layout (layout-inherits layout
))
355 (let* ((super (layout-classoid super-layout
))
356 (subclasses (or (classoid-subclasses super
)
357 (setf (classoid-subclasses super
)
358 (make-hash-table :test
'eq
359 #-sb-xc-host
#-sb-xc-host
361 (when (and (eq (classoid-state super
) :sealed
)
362 (not (gethash classoid subclasses
)))
363 (warn "unsealing sealed class ~S in order to subclass it"
364 (classoid-name super
))
365 (setf (classoid-state super
) :read-only
))
366 (setf (gethash classoid subclasses
)
367 (or destruct-layout layout
))))))
372 ;;; Arrange the inherited layouts to appear at their expected depth,
373 ;;; ensuring that hierarchical type tests succeed. Layouts with
374 ;;; DEPTHOID >= 0 (i.e. hierarchical classes) are placed first,
375 ;;; at exactly that index in the INHERITS vector. Then, non-hierarchical
376 ;;; layouts are placed in remaining elements. Then, any still-empty
377 ;;; elements are filled with their successors, ensuring that each
378 ;;; element contains a valid layout.
380 ;;; This reordering may destroy CPL ordering, so the inherits should
381 ;;; not be read as being in CPL order.
382 (defun order-layout-inherits (layouts)
383 (declare (simple-vector layouts
))
384 (let ((length (length layouts
))
387 (let ((depth (layout-depthoid (svref layouts i
))))
388 (when (> depth max-depth
)
389 (setf max-depth depth
))))
390 (let* ((new-length (max (1+ max-depth
) length
))
391 ;; KLUDGE: 0 here is the "uninitialized" element. We need
392 ;; to specify it explicitly for portability purposes, as
393 ;; elements can be read before being set [ see below, "(EQL
394 ;; OLD-LAYOUT 0)" ]. -- CSR, 2002-04-20
395 (inherits (make-array new-length
:initial-element
0)))
397 (let* ((layout (svref layouts i
))
398 (depth (layout-depthoid layout
)))
399 (unless (eql depth -
1)
400 (let ((old-layout (svref inherits depth
)))
401 (unless (or (eql old-layout
0) (eq old-layout layout
))
402 (error "layout depth conflict: ~S~%" layouts
)))
403 (setf (svref inherits depth
) layout
))))
407 (declare (type index i j
))
408 (let* ((layout (svref layouts i
))
409 (depth (layout-depthoid layout
)))
411 (loop (when (eql (svref inherits j
) 0)
414 (setf (svref inherits j
) layout
))))
415 (do ((i (1- new-length
) (1- i
)))
417 (declare (type fixnum i
))
418 (when (eql (svref inherits i
) 0)
419 (setf (svref inherits i
) (svref inherits
(1+ i
)))))
422 ;;;; class precedence lists
424 ;;; Topologically sort the list of objects to meet a set of ordering
425 ;;; constraints given by pairs (A . B) constraining A to precede B.
426 ;;; When there are multiple objects to choose, the tie-breaker
427 ;;; function is called with both the list of object to choose from and
428 ;;; the reverse ordering built so far.
429 (defun topological-sort (objects constraints tie-breaker
)
430 (declare (list objects constraints
)
431 (function tie-breaker
))
432 (let ((obj-info (make-hash-table :size
(length objects
)))
435 (loop for
(obj1 . obj2
) in constraints do
436 (incf (first (ensure-gethash obj2 obj-info
(list 0))))
437 (push obj2
(rest (ensure-gethash obj1 obj-info
(list 0)))))
438 (dolist (obj objects
)
439 (let ((info (gethash obj obj-info
)))
440 (when (or (not info
) (zerop (first info
)))
441 (push obj free-objs
))))
443 (flet ((next-result (obj)
445 (dolist (successor (rest (gethash obj obj-info
)))
446 (let* ((successor-info (gethash successor obj-info
))
447 (count (1- (first successor-info
))))
448 (setf (first successor-info
) count
)
450 (push successor free-objs
))))))
451 (cond ((endp free-objs
)
452 (dohash ((obj info
) obj-info
)
453 (unless (zerop (first info
))
454 (error "Topological sort failed due to constraint on ~S."
456 (return (nreverse result
)))
457 ((endp (rest free-objs
))
458 (next-result (pop free-objs
)))
460 (let ((obj (funcall tie-breaker free-objs result
)))
461 (setf free-objs
(remove obj free-objs
))
462 (next-result obj
))))))))
465 ;;; standard class precedence list computation
466 (defun std-compute-class-precedence-list (class)
469 (labels ((note-class (class)
470 (unless (member class classes
)
472 (let ((superclasses (classoid-direct-superclasses class
)))
474 (rest superclasses
(rest rest
)))
476 (let ((next (first rest
)))
477 (push (cons prev next
) constraints
)
479 (dolist (class superclasses
)
480 (note-class class
)))))
481 (std-cpl-tie-breaker (free-classes rev-cpl
)
482 (dolist (class rev-cpl
(first free-classes
))
483 (let* ((superclasses (classoid-direct-superclasses class
))
484 (intersection (intersection free-classes
487 (return (first intersection
)))))))
489 (topological-sort classes constraints
#'std-cpl-tie-breaker
))))
491 ;;;; object types to represent classes
493 ;;; BUILT-IN-CLASS is used to represent the standard classes that
494 ;;; aren't defined with DEFSTRUCT and other specially implemented
495 ;;; primitive types whose only attribute is their name.
496 ;;; It is defined in 'early-classoid.lisp'
498 ;;; STRUCTURE-CLASS represents what we need to know about structure
499 ;;; classes. Non-structure "typed" defstructs are a special case, and
500 ;;; don't have a corresponding class.
501 (def!struct
(structure-classoid (:include classoid
)
503 (:constructor %make-structure-classoid
)))
504 (defun make-structure-classoid (&key name
)
505 (mark-ctype-interned (%make-structure-classoid
:name name
)))
507 ;;;; classoid namespace
509 (eval-when (#-sb-xc
:compile-toplevel
:load-toplevel
:execute
)
510 (defun (setf find-classoid
) (new-value name
)
511 #-sb-xc
(declare (type (or null classoid
) new-value
))
513 (let ((table *forward-referenced-layouts
*))
515 (let ((cell (find-classoid-cell name
:create t
)))
516 (ecase (info :type
:kind name
)
518 (:forthcoming-defclass-type
519 ;; FIXME: Currently, nothing needs to be done in this case.
520 ;; Later, when PCL is integrated tighter into SBCL, this
521 ;; might need more work.
525 (let ((old-value (classoid-cell-classoid cell
)))
527 ;; KLUDGE: The reason these clauses aren't directly
528 ;; parallel is that we need to use the internal
529 ;; CLASSOID structure ourselves, because we don't
530 ;; have CLASSes to work with until PCL is built. In
531 ;; the host, CLASSes have an approximately
532 ;; one-to-one correspondence with the target
533 ;; CLASSOIDs (as well as with the target CLASSes,
534 ;; modulo potential differences with respect to
537 (let ((old (class-of old-value
))
538 (new (class-of new-value
)))
540 (bug "Trying to change the metaclass of ~S from ~S to ~S in the ~
542 name
(class-name old
) (class-name new
))))
544 (let ((old (classoid-of old-value
))
545 (new (classoid-of new-value
)))
547 (warn "Changing meta-class of ~S from ~S to ~S."
548 name
(classoid-name old
) (classoid-name new
))))))
550 (error "Cannot redefine standard type ~
551 ~/sb!impl:print-type-specifier/." name
))
553 (warn "redefining DEFTYPE type to be a class: ~
554 ~/sb!impl::print-symbol-with-prefix/" name
)
555 (clear-info :type
:expander name
)
556 (clear-info :type
:source-location name
)))
559 (%note-type-defined name
)
560 ;; FIXME: I'm unconvinced of the need to handle either of these.
561 ;; Package locks preclude the latter, and in the former case,
562 ;; once you've made some random thing into a :PRIMITIVE kind of type,
563 ;; you've painted yourself into a corner - those types
564 ;; elicit vociferous complaints if you try to redefine them.
566 ;; we need to handle things like
567 ;; (setf (find-class 'foo) (find-class 'integer))
569 ;; (setf (find-class 'integer) (find-class 'integer))
570 (cond ((built-in-classoid-p new-value
)
571 ;; But I can't figure out how to get assertions to pass
572 ;; without violation what would otherwise be invariants
573 ;; of the internal representation of types. This sucks.
574 (setf (info :type
:kind name
)
575 (or (info :type
:kind name
) :defined
)))
577 (setf (info :type
:kind name
) :instance
)))
578 (setf (classoid-cell-classoid cell
) new-value
)
579 (unless (eq (info :type
:compiler-layout name
)
580 (classoid-layout new-value
))
581 (setf (info :type
:compiler-layout name
)
582 (classoid-layout new-value
))))))
585 (defun %clear-classoid
(name cell
)
586 (ecase (info :type
:kind name
)
590 (error "Attempt to remove :PRIMITIVE type: ~
591 ~/sb!impl:print-type-specifier/" name
))
592 ((:forthcoming-defclass-type
:instance
)
594 ;; Note: We cannot remove the classoid cell from the table,
595 ;; since compiled code may refer directly to the cell, and
596 ;; getting a different cell for a classoid with the same name
597 ;; just would not do.
599 ;; Remove the proper name of the classoid, if this was it.
600 (let* ((classoid (classoid-cell-classoid cell
))
601 (proper-name (classoid-name classoid
)))
602 (when (eq proper-name name
)
603 (setf (classoid-name classoid
) nil
)))
606 (setf (classoid-cell-classoid cell
) nil
607 (classoid-cell-pcl-class cell
) nil
))
608 (clear-info :type
:kind name
)
609 (clear-info :type
:documentation name
)
610 (clear-info :type
:compiler-layout name
)
611 (values-specifier-type-cache-clear)))))
613 ;;; Called when we are about to define NAME as a class meeting some
614 ;;; predicate (such as a meta-class type test.) The first result is
615 ;;; always of the desired class. The second result is any existing
616 ;;; LAYOUT for this name.
618 ;;; Again, this should be compiler-only, but easier to make this
620 (defun insured-find-classoid (name predicate constructor
)
621 (declare (type function predicate constructor
))
622 (let ((table *forward-referenced-layouts
*))
623 (with-locked-system-table (table)
624 (let* ((old (find-classoid name nil
))
625 (res (if (and old
(funcall predicate old
))
627 (funcall constructor
:name name
)))
628 (found (or (gethash name table
)
629 (when old
(classoid-layout old
)))))
631 (setf (layout-classoid found
) res
))
632 (values res found
)))))
634 ;;; If the classoid has a proper name, return the name, otherwise return
636 (defun classoid-proper-name (classoid)
637 #-sb-xc
(declare (type classoid classoid
))
638 (let ((name (classoid-name classoid
)))
639 (if (and name
(eq (find-classoid name nil
) classoid
))
643 ;;;; CLASS type operations
645 ;; CLASSOID-ENUMERABLE-P is referenced during compile by !DEFINE-TYPE-CLASS.
646 ;; But don't redefine it when building the target since we've already
647 ;; got a perfectly good definition loaded for the host.
648 (eval-when (#-sb-xc
:compile-toplevel
:load-toplevel
:execute
)
649 ;; Actually this definition makes very little sense because
650 ;; (TYPE-ENUMERABLE (FIND-CLASSOID 'CHARACTER)) => T
651 ;; but (TYPE-ENUMERABLE (SPECIFIER-TYPE 'CHARACTER)) => NIL.
652 ;; You should never see the CLASSOID used as a type though,
653 ;; at least not from parsing and set operations.
654 ;; On a related note, (TYPE-ENUMERABLE (FIND-CLASSOID 'NULL))
655 ;; should probably be T, but you'll never see that type either.
656 ;; Perhaps a better definition of this function would be
657 ;; (if (classoid-translation x) (bug "enumerable-p classoid?") nil)
658 (defun classoid-enumerable-p (x) (eq (classoid-name x
) 'character
)))
659 (!define-type-class classoid
:enumerable
#'classoid-enumerable-p
660 :might-contain-other-types nil
)
662 (defun classoid-inherits-from (sub super-or-name
)
663 (declare (type classoid sub
)
664 (type (or symbol classoid
) super-or-name
))
665 (let ((super (if (symbolp super-or-name
)
666 (find-classoid super-or-name
)
668 (find (classoid-layout super
)
669 (layout-inherits (classoid-layout sub
)))))
671 ;;; We might be passed classoids with invalid layouts; in any pairwise
672 ;;; class comparison, we must ensure that both are valid before
674 (defun %ensure-classoid-valid
(classoid layout error-context
)
675 (declare (ignorable error-context
)) ; not used on host
676 (aver (eq classoid
(layout-classoid layout
)))
677 (or (not (layout-invalid layout
))
678 ;; Avoid accidentally reaching code that can't work.
679 #+sb-xc-host
(bug "(TYPEP x 'STANDARD-CLASSOID) can't be tested")
681 (if (typep classoid
'standard-classoid
)
682 (let ((class (classoid-pcl-class classoid
)))
684 ((sb!pcl
:class-finalized-p class
)
685 (sb!pcl
::%force-cache-flushes class
)
687 ((sb!pcl
::class-has-a-forward-referenced-superclass-p class
)
689 (bug "~@<Invalid class ~S with forward-referenced superclass ~
692 (sb!pcl
::class-has-a-forward-referenced-superclass-p class
)
696 (sb!pcl
:finalize-inheritance class
)
698 (bug "~@<Don't know how to ensure validity of ~S (not a STANDARD-CLASSOID) ~
700 classoid
(or error-context
'subtypep
)))))
702 (defun %ensure-both-classoids-valid
(class1 class2
&optional errorp
)
703 (do ((layout1 (classoid-layout class1
) (classoid-layout class1
))
704 (layout2 (classoid-layout class2
) (classoid-layout class2
))
706 ((and (not (layout-invalid layout1
)) (not (layout-invalid layout2
)))
709 (unless (and (%ensure-classoid-valid class1 layout1 errorp
)
710 (%ensure-classoid-valid class2 layout2 errorp
))
711 (return-from %ensure-both-classoids-valid nil
))))
713 #-sb-xc-host
; No such thing as LAYOUT-OF, never mind the rest
714 (defun update-object-layout-or-invalid (object layout
)
715 ;; FIXME: explain why this isn't (LAYOUT-FOR-STD-CLASS-P LAYOUT).
716 (if (layout-for-std-class-p (layout-of object
))
717 (sb!pcl
::check-wrapper-validity object
)
718 (sb!c
::%layout-invalid-error object layout
)))
720 ;;; Simple methods for TYPE= and SUBTYPEP should never be called when
721 ;;; the two classes are equal, since there are EQ checks in those
723 (!define-type-method
(classoid :simple-
=) (type1 type2
)
724 (aver (not (eq type1 type2
)))
727 (!define-type-method
(classoid :simple-subtypep
) (class1 class2
)
728 (aver (not (eq class1 class2
)))
730 (if (%ensure-both-classoids-valid class1 class2
)
731 (let ((subclasses2 (classoid-subclasses class2
)))
732 (if (and subclasses2
(gethash class1 subclasses2
))
734 (if (and (typep class1
'standard-classoid
)
735 (typep class2
'standard-classoid
)
736 (or (sb!pcl
::class-has-a-forward-referenced-superclass-p
737 (classoid-pcl-class class1
))
738 (sb!pcl
::class-has-a-forward-referenced-superclass-p
739 (classoid-pcl-class class2
))))
740 ;; If there's a forward-referenced class involved we don't know for sure.
741 ;; (There are cases which we /could/ figure out, but that doesn't seem
742 ;; to be required or important, really.)
747 ;;; When finding the intersection of a sealed class and some other
748 ;;; class (not hierarchically related) the intersection is the union
749 ;;; of the currently shared subclasses.
750 (defun sealed-class-intersection2 (sealed other
)
751 (declare (type classoid sealed other
))
752 (let ((s-sub (classoid-subclasses sealed
))
753 (o-sub (classoid-subclasses other
)))
754 (if (and s-sub o-sub
)
755 (collect ((res *empty-type
* type-union
))
756 (dohash ((subclass layout
) s-sub
:locked t
)
757 (declare (ignore layout
))
758 (when (gethash subclass o-sub
)
759 (res (specifier-type subclass
))))
763 (!define-type-method
(classoid :simple-intersection2
) (class1 class2
)
764 (declare (type classoid class1 class2
))
766 (%ensure-both-classoids-valid class1 class2
"type intersection")
767 (cond ((eq class1 class2
)
769 ;; If one is a subclass of the other, then that is the
771 ((let ((subclasses (classoid-subclasses class2
)))
772 (and subclasses
(gethash class1 subclasses
)))
774 ((let ((subclasses (classoid-subclasses class1
)))
775 (and subclasses
(gethash class2 subclasses
)))
777 ;; Otherwise, we can't in general be sure that the
778 ;; intersection is empty, since a subclass of both might be
779 ;; defined. But we can eliminate it for some special cases.
780 ((or (structure-classoid-p class1
)
781 (structure-classoid-p class2
))
782 ;; No subclass of both can be defined.
784 ((eq (classoid-state class1
) :sealed
)
785 ;; checking whether a subclass of both can be defined:
786 (sealed-class-intersection2 class1 class2
))
787 ((eq (classoid-state class2
) :sealed
)
788 ;; checking whether a subclass of both can be defined:
789 (sealed-class-intersection2 class2 class1
))
790 ;; If exactly one of CLASS{1,2} is a CONDITION-CLASSOID,
791 ;; there can be no intersection: sub-/superclass relations
792 ;; between CONDITION-CLASSOIDs and other CLASSOIDs are not
793 ;; possible and a CONDITION-CLASSOIDs cannot be changed into
794 ;; different CLASSOIDs.
795 ((let ((c1 (condition-classoid-p class1
))
796 (c2 (condition-classoid-p class2
)))
797 (or (and c1
(not c2
)) (and (not c1
) c2
)))
800 ;; uncertain, since a subclass of both might be defined
803 ;;; KLUDGE: we need this to deal with the special-case INSTANCE and
804 ;;; FUNCALLABLE-INSTANCE types (which used to be CLASSOIDs until CSR
805 ;;; discovered that this was incompatible with the MOP class
806 ;;; hierarchy). See NAMED :COMPLEX-SUBTYPEP-ARG2
807 (declaim (type cons
**non-instance-classoid-types
**))
808 (defglobal **non-instance-classoid-types
**
809 '(symbol system-area-pointer weak-pointer code-component
810 #!-
(or x86 x86-64
) lra
813 (defun classoid-non-instance-p (classoid)
814 (declare (type classoid classoid
))
815 (member classoid
**non-instance-classoid-types
**
816 :key
#'find-classoid
))
818 ;;; KLUDGE: we need this because of the need to represent
819 ;;; intersections of two classes, even when empty at a given time, as
820 ;;; uncanonicalized intersections because of the possibility of later
821 ;;; defining a subclass of both classes. The necessity for changing
822 ;;; the default return value from SUBTYPEP to NIL, T if no alternate
823 ;;; method is present comes about because, unlike the other places we
824 ;;; use INVOKE-COMPLEX-SUBTYPEP-ARG1-METHOD, in HAIRY methods and the
825 ;;; like, classes are in their own hierarchy with no possibility of
826 ;;; mixtures with other type classes.
827 (!define-type-method
(classoid :complex-subtypep-arg2
) (type1 class2
)
828 (if (and (intersection-type-p type1
)
829 (> (count-if #'classoid-p
(intersection-type-types type1
)) 1))
831 (invoke-complex-subtypep-arg1-method type1 class2 nil t
)))
833 (!define-type-method
(classoid :negate
) (type) (make-negation-type type
))
835 (!define-type-method
(classoid :unparse
) (type)
836 (classoid-proper-name type
))
838 ;;;; built-in classes
840 ;;; The BUILT-IN-CLASSES list is a data structure which configures the
841 ;;; creation of all the built-in classes. It contains all the info
842 ;;; that we need to maintain the mapping between classes, compile-time
843 ;;; types and run-time type codes. These options are defined:
845 ;;; :TRANSLATION (default none)
846 ;;; When this class is "parsed" as a type specifier, it is
847 ;;; translated into the specified internal type representation,
848 ;;; rather than being left as a class. This is used for types
849 ;;; which we want to canonicalize to some other kind of type
850 ;;; object because in general we want to be able to include more
851 ;;; information than just the class (e.g. for numeric types.)
853 ;;; :STATE (default :SEALED)
854 ;;; The value of CLASS-STATE which we want on completion,
855 ;;; indicating whether subclasses can be created at run-time.
857 ;;; :HIERARCHICAL-P (default T unless any of the inherits are non-hierarchical)
858 ;;; True if we can assign this class a unique inheritance depth.
860 ;;; :CODES (default none)
861 ;;; Run-time type codes which should be translated back to this
862 ;;; class by CLASS-OF. Unspecified for abstract classes.
864 ;;; :INHERITS (default this class and T)
865 ;;; The class-precedence list for this class, with this class and
868 ;;; :DIRECT-SUPERCLASSES (default to head of CPL)
869 ;;; List of the direct superclasses of this class.
871 ;;; NB: not to be confused with SB-PCL::*BUILT-IN-CLASSES*
872 (!defvar
*!built-in-classes
*
873 ;; To me these data would look nicer with commas instead of "#."
874 '((t :state
:read-only
:translation t
)
875 (character :codes
(#.sb
!vm
:character-widetag
)
876 :translation
(character-set)
877 :prototype-form
(code-char 42))
878 (symbol :codes
(#.sb
!vm
:symbol-widetag
)
879 :prototype-form
'#:mu
)
881 (system-area-pointer :codes
(#.sb
!vm
:sap-widetag
)
882 :prototype-form
(int-sap 42))
883 (weak-pointer :codes
(#.sb
!vm
:weak-pointer-widetag
)
884 :prototype-form
(make-weak-pointer (find-package "CL")))
885 (code-component :codes
(#.sb
!vm
:code-header-widetag
))
886 #!-
(or x86 x86-64
) (lra :codes
(#.sb
!vm
:return-pc-widetag
))
887 (fdefn :codes
(#.sb
!vm
:fdefn-widetag
)
888 :prototype-form
(make-fdefn "42"))
889 (random-class) ; used for unknown type codes
892 :codes
(#.sb
!vm
:closure-widetag
893 #.sb
!vm
:simple-fun-widetag
)
895 :prototype-form
(function (lambda () 42)))
897 (number :translation number
)
901 :codes
(#.sb
!vm
:complex-widetag
)
902 :prototype-form
(complex 42 42))
903 (complex-single-float
904 :translation
(complex single-float
)
905 :inherits
(complex number
)
906 :codes
(#.sb
!vm
:complex-single-float-widetag
)
907 :prototype-form
(complex 42f0
42f0
))
908 (complex-double-float
909 :translation
(complex double-float
)
910 :inherits
(complex number
)
911 :codes
(#.sb
!vm
:complex-double-float-widetag
)
912 :prototype-form
(complex 42d0
42d0
))
915 :translation
(complex long-float
)
916 :inherits
(complex number
)
917 :codes
(#.sb
!vm
:complex-long-float-widetag
)
918 :prototype-form
(complex 42l0 42l0))
921 :translation simd-pack
922 :codes
(#.sb
!vm
:simd-pack-widetag
)
923 :prototype-form
(%make-simd-pack-ub64
42 42))
924 (real :translation real
:inherits
(number))
927 :inherits
(real number
))
929 :translation single-float
930 :inherits
(float real number
)
931 :codes
(#.sb
!vm
:single-float-widetag
)
932 :prototype-form
42f0
)
934 :translation double-float
935 :inherits
(float real number
)
936 :codes
(#.sb
!vm
:double-float-widetag
)
937 :prototype-form
42d0
)
940 :translation long-float
941 :inherits
(float real number
)
942 :codes
(#.sb
!vm
:long-float-widetag
)
943 :prototype-form
42l0)
945 :translation rational
946 :inherits
(real number
))
948 :translation
(and rational
(not integer
))
949 :inherits
(rational real number
)
950 :codes
(#.sb
!vm
:ratio-widetag
)
951 :prototype-form
1/42)
954 :inherits
(rational real number
))
956 :translation
(integer #.sb
!xc
:most-negative-fixnum
957 #.sb
!xc
:most-positive-fixnum
)
958 :inherits
(integer rational real number
)
959 :codes
#.
(mapcar #'symbol-value sb
!vm
::fixnum-lowtags
)
962 :translation
(and integer
(not fixnum
))
963 :inherits
(integer rational real number
)
964 :codes
(#.sb
!vm
:bignum-widetag
)
965 :prototype-form
(expt 2 #.
(* sb
!vm
:n-word-bits
(/ 3 2))))
967 (array :translation array
:codes
(#.sb
!vm
:complex-array-widetag
)
969 :prototype-form
(make-array nil
:adjustable t
))
971 :translation simple-array
:codes
(#.sb
!vm
:simple-array-widetag
)
973 :prototype-form
(make-array nil
))
975 :translation
(or cons
(member nil
) vector extended-sequence
)
979 :translation vector
:codes
(#.sb
!vm
:complex-vector-widetag
)
980 :direct-superclasses
(array sequence
)
981 :inherits
(array sequence
))
983 :translation simple-vector
:codes
(#.sb
!vm
:simple-vector-widetag
)
984 :direct-superclasses
(vector simple-array
)
985 :inherits
(vector simple-array array sequence
)
986 :prototype-form
(make-array 0))
988 :translation bit-vector
:codes
(#.sb
!vm
:complex-bit-vector-widetag
)
989 :inherits
(vector array sequence
)
990 :prototype-form
(make-array 0 :element-type
'bit
:fill-pointer t
))
992 :translation simple-bit-vector
:codes
(#.sb
!vm
:simple-bit-vector-widetag
)
993 :direct-superclasses
(bit-vector simple-array
)
994 :inherits
(bit-vector vector simple-array
996 :prototype-form
(make-array 0 :element-type
'bit
))
999 :direct-superclasses
(vector)
1000 :inherits
(vector array sequence
))
1002 :translation simple-string
1003 :direct-superclasses
(string simple-array
)
1004 :inherits
(string vector simple-array array sequence
))
1006 :translation
(vector nil
)
1007 :codes
(#.sb
!vm
:complex-vector-nil-widetag
)
1008 :direct-superclasses
(string)
1009 :inherits
(string vector array sequence
)
1010 :prototype-form
(make-array 0 :element-type
'nil
:fill-pointer t
))
1012 :translation
(simple-array nil
(*))
1013 :codes
(#.sb
!vm
:simple-array-nil-widetag
)
1014 :direct-superclasses
(vector-nil simple-string
)
1015 :inherits
(vector-nil simple-string string vector simple-array
1017 :prototype-form
(make-array 0 :element-type
'nil
))
1019 :translation base-string
1020 :codes
(#.sb
!vm
:complex-base-string-widetag
)
1021 :direct-superclasses
(string)
1022 :inherits
(string vector array sequence
)
1023 :prototype-form
(make-array 0 :element-type
'base-char
:fill-pointer t
))
1025 :translation simple-base-string
1026 :codes
(#.sb
!vm
:simple-base-string-widetag
)
1027 :direct-superclasses
(base-string simple-string
)
1028 :inherits
(base-string simple-string string vector simple-array
1030 :prototype-form
(make-array 0 :element-type
'base-char
))
1033 :translation
(vector character
)
1034 :codes
(#.sb
!vm
:complex-character-string-widetag
)
1035 :direct-superclasses
(string)
1036 :inherits
(string vector array sequence
)
1037 :prototype-form
(make-array 0 :element-type
'character
:fill-pointer t
))
1039 (simple-character-string
1040 :translation
(simple-array character
(*))
1041 :codes
(#.sb
!vm
:simple-character-string-widetag
)
1042 :direct-superclasses
(character-string simple-string
)
1043 :inherits
(character-string simple-string string vector simple-array
1045 :prototype-form
(make-array 0 :element-type
'character
))
1047 :translation
(or cons
(member nil
))
1048 :inherits
(sequence))
1050 :codes
(#.sb
!vm
:list-pointer-lowtag
)
1052 :inherits
(list sequence
)
1053 :prototype-form
(cons nil nil
))
1055 :translation
(member nil
)
1056 :inherits
(symbol list sequence
)
1057 :direct-superclasses
(symbol list
)
1058 :prototype-form
'nil
)
1059 ;; These last few are strange. STREAM has only T as an ancestor,
1060 ;; so you'd think it would be at depth 1. FILE- and STRING-STREAM
1061 ;; each have STREAM and T as ancestors, so you'd think they'd be at depth
1062 ;; 1 greater than STREAM, instead of 2 greater. But changing any of
1063 ;; these to the "obvious" value makes various type checks go wrong.
1076 #.
(loop for x across sb
!vm
:*specialized-array-element-type-properties
*
1077 unless
(member (sb!vm
::saetp-specifier x
) '(t character base-char nil bit
))
1079 ;; I'm not sure if it's an accident that there are distinct SB!KERNEL
1080 ;; versus SB!VM symbols for the specialized arrays. The former are types
1081 ;; in the language, and the latter are primitive object types,
1082 ;; but istm they should be designated by the same symbols.
1083 `(,(intern (string (sb!vm
::saetp-primitive-type-name x
)) *package
*)
1084 :translation
(simple-array ,(sb!vm
::saetp-specifier x
) (*))
1085 :codes
(,(sb!vm
::saetp-typecode x
))
1086 :direct-superclasses
(vector simple-array
)
1087 :inherits
(vector simple-array array sequence
)
1088 :prototype-form
(make-array 0 :element-type
',(sb!vm
::saetp-specifier x
))))))
1090 ;;; See also src/code/class-init.lisp where we finish setting up the
1091 ;;; translations for built-in types.
1093 (dolist (x *!built-in-classes
*)
1094 #-sb-xc-host
(/show0
"at head of loop over *!BUILT-IN-CLASSES*")
1097 (translation nil trans-p
)
1103 (hierarchical-p t
) ; might be modified below
1104 (direct-superclasses (if inherits
1105 (list (car inherits
))
1108 (declare (ignore codes state translation prototype-form
))
1109 (let ((inherits-list (if (eq name t
)
1111 (cons t
(reverse inherits
))))
1113 (acond #+sb-xc
; genesis dumps some classoid literals
1114 ((find-classoid name nil
)
1115 ;; Unseal it so that REGISTER-LAYOUT doesn't warn
1116 (setf (classoid-state it
) nil
)
1119 (setf (classoid-cell-classoid
1120 (find-classoid-cell name
:create t
))
1121 (mark-ctype-interned
1122 (make-built-in-classoid
1124 :translation
(if trans-p
:initializing nil
)
1125 :direct-superclasses
1128 (mapcar #'find-classoid
1129 direct-superclasses
)))))))))
1130 (setf (info :type
:kind name
) :primitive
)
1132 (setf (info :type
:builtin name
) classoid
))
1133 (let* ((inherits-vector
1137 (classoid-layout (find-classoid x
))))
1138 (when (minusp (layout-depthoid super-layout
))
1139 (setf hierarchical-p nil
))
1142 (depthoid (if hierarchical-p
1143 (or depth
(length inherits-vector
))
1146 (find-and-init-or-check-layout name
1151 +layout-all-tagged
+)
1152 :invalidate nil
)))))
1153 (/show0
"done with loop over *!BUILT-IN-CLASSES*"))
1155 ;;; Now that we have set up the class heterarchy, seal the sealed
1156 ;;; classes. This must be done after the subclasses have been set up.
1158 (dolist (x *!built-in-classes
*)
1159 (destructuring-bind (name &key
(state :sealed
) &allow-other-keys
) x
1160 (setf (classoid-state (find-classoid name
)) state
))))
1162 ;;;; class definition/redefinition
1164 ;;; This is to be called whenever we are altering a class.
1166 (defun %modify-classoid
(classoid) (bug "MODIFY-CLASSOID ~S" classoid
))
1168 (defun %modify-classoid
(classoid)
1170 (awhen (classoid-state classoid
)
1171 ;; FIXME: This should probably be CERROR.
1172 (warn "making ~(~A~) class ~S writable" it
(classoid-name classoid
))
1173 (setf (classoid-state classoid
) nil
)))
1175 ;;; Mark LAYOUT as invalid. Setting DEPTHOID -1 helps cause unsafe
1176 ;;; structure type tests to fail. Remove class from all superclasses
1177 ;;; too (might not be registered, so might not be in subclasses of the
1178 ;;; nominal superclasses.) We set the layout-clos-hash slots to 0 to
1179 ;;; invalidate the wrappers for specialized dispatch functions, which
1180 ;;; use those slots as indexes into tables.
1181 (defun %invalidate-layout
(layout)
1182 (declare (type layout layout
))
1183 (setf (layout-invalid layout
) t
1184 (layout-depthoid layout
) -
1)
1185 (setf (layout-clos-hash layout
) 0)
1186 (let ((inherits (layout-inherits layout
))
1187 (classoid (layout-classoid layout
)))
1188 (%modify-classoid classoid
)
1189 (dovector (super inherits
)
1190 (let ((subs (classoid-subclasses (layout-classoid super
))))
1192 (remhash classoid subs
)))))
1195 ;;;; cold loading initializations
1197 ;;; FIXME: It would be good to arrange for this to be called when the
1198 ;;; cross-compiler is being built, not just when the target Lisp is
1199 ;;; being cold loaded. Perhaps this could be moved to its own file
1200 ;;; late in the build-order.lisp-expr sequence, and be put in
1201 ;;; !COLD-INIT-FORMS there?
1202 (defun !class-finalize
()
1203 (dohash ((name layout
) *forward-referenced-layouts
*)
1204 (let ((class (find-classoid name nil
)))
1206 (setf (layout-classoid layout
) (make-undefined-classoid name
)))
1207 ((eq (classoid-layout class
) layout
)
1208 (remhash name
*forward-referenced-layouts
*))
1210 (error "Something strange with forward layout for ~S:~% ~S"
1214 #-sb-xc-host
(/show0
"about to set *BUILT-IN-CLASS-CODES*")
1215 (setq **built-in-class-codes
**
1216 (let* ((initial-element (classoid-layout (find-classoid 'random-class
)))
1217 (res (make-array 256 :initial-element initial-element
)))
1218 (dolist (x *!built-in-classes
* res
)
1219 (destructuring-bind (name &key codes
&allow-other-keys
)
1221 (let ((layout (classoid-layout (find-classoid name
))))
1222 (dolist (code codes
)
1223 (setf (svref res code
) layout
)))))))
1225 (let ((table **built-in-class-codes
**))
1226 (loop with layout
= (aref table sb
!vm
:list-pointer-lowtag
)
1227 for i from sb
!vm
:list-pointer-lowtag by
16 below
256
1228 do
(setf (aref table i
) layout
))
1229 (loop with layout
= (aref table sb
!vm
:even-fixnum-lowtag
)
1230 for i from sb
!vm
:even-fixnum-lowtag by
(ash 1 sb
!vm
:n-fixnum-tag-bits
) below
256
1231 do
(setf (aref table i
) layout
)))
1232 #-sb-xc-host
(/show0
"done setting *BUILT-IN-CLASS-CODES*"))
1234 (!defun-from-collected-cold-init-forms
!classes-cold-init
)