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
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 (gethash (car x) *forward-referenced-layouts*)
111 (/show0 "done processing *!INITIAL-LAYOUTS*")))
113 ;;; The LAYOUT structure is pointed to by the first cell of instance
114 ;;; (or structure) objects. It represents what we need to know for
115 ;;; type checking and garbage collection. Whenever a class is
116 ;;; incompatibly redefined, a new layout is allocated. If two object's
117 ;;; layouts are EQ, then they are exactly the same type.
119 ;;; *** IMPORTANT ***
121 ;;; If you change the slots of LAYOUT, you need to alter genesis as
122 ;;; well, since the initialization of layout slots is hardcoded there.
124 ;;; FIXME: ...it would be better to automate this, of course...
126 ;; KLUDGE: A special hack keeps this from being
127 ;; called when building code for the
128 ;; cross-compiler. See comments at the DEFUN for
129 ;; this. -- WHN 19990914
130 (:make-load-form-fun #-sb-xc-host ignore-it
131 ;; KLUDGE: DEF!STRUCT at #+SB-XC-HOST
132 ;; time controls both the
133 ;; build-the-cross-compiler behavior
134 ;; and the run-the-cross-compiler
135 ;; behavior. The value below only
136 ;; works for build-the-cross-compiler.
137 ;; There's a special hack in
138 ;; EMIT-MAKE-LOAD-FORM which gives
139 ;; effectively IGNORE-IT behavior for
140 ;; LAYOUT at run-the-cross-compiler
141 ;; time. It would be cleaner to
142 ;; actually have an IGNORE-IT value
143 ;; stored, but it's hard to see how to
144 ;; do that concisely with the current
145 ;; DEF!STRUCT setup. -- WHN 19990930
147 make-load-form-for-layout))
148 ;; a pseudo-random hash value for use by CLOS. KLUDGE: The fact
149 ;; that this slot is at offset 1 is known to GENESIS.
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.
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 (n-untagged-slots 0 :type index)
195 ;; Definition location
196 (source-location nil)
197 ;; Information about slots in the class to PCL: this provides fast
198 ;; access to slot-definitions and locations by name, etc.
199 (slot-table #(nil) :type simple-vector)
200 ;; True IFF the layout belongs to a standand-instance or a
201 ;; standard-funcallable-instance -- that is, true only if the layout
202 ;; is really a wrapper.
204 ;; FIXME: If we unify wrappers and layouts this can go away, since
205 ;; it is only used in SB-PCL::EMIT-FETCH-WRAPPERS, which can then
206 ;; use INSTANCE-SLOTS-LAYOUT instead (if there is are no slot
207 ;; layouts, there are no slots for it to pull.)
208 (for-std-class-p nil :type boolean :read-only t))
210 (def!method print-object ((layout layout) stream)
211 (print-unreadable-object (layout stream :type t :identity t)
213 "for ~S~@[, INVALID=~S~]"
214 (layout-proper-name layout)
215 (layout-invalid layout))))
217 (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
218 (defun layout-proper-name (layout)
219 (classoid-proper-name (layout-classoid layout))))
221 ;;;; support for the hash values used by CLOS when working with LAYOUTs
223 ;;; a generator for random values suitable for the CLOS-HASH slots of
224 ;;; LAYOUTs. We use our own RANDOM-STATE here because we'd like
225 ;;; pseudo-random values to come the same way in the target even when
226 ;;; we make minor changes to the system, in order to reduce the
227 ;;; mysteriousness of possible CLOS bugs.
228 (defvar *layout-clos-hash-random-state*)
229 (defun random-layout-clos-hash ()
230 ;; FIXME: I'm not sure why this expression is (1+ (RANDOM FOO)),
231 ;; returning a strictly positive value. I copied it verbatim from
232 ;; CMU CL INITIALIZE-LAYOUT-HASH, so presumably it works, but I
233 ;; dunno whether the hash values are really supposed to be 1-based.
234 ;; They're declared as INDEX.. Or is this a hack to try to avoid
235 ;; having to use bignum arithmetic? Or what? An explanation would be
238 ;; an explanation is provided in Kiczales and Rodriguez, "Efficient
239 ;; Method Dispatch in PCL", 1990. -- CSR, 2005-11-30
240 (1+ (random (1- layout-clos-hash-limit)
241 (if (boundp '*layout-clos-hash-random-state*)
242 *layout-clos-hash-random-state*
243 (setf *layout-clos-hash-random-state*
244 (make-random-state))))))
246 ;;; If we can't find any existing layout, then we create a new one
247 ;;; storing it in *FORWARD-REFERENCED-LAYOUTS*. In classic CMU CL, we
248 ;;; used to immediately check for compatibility, but for
249 ;;; cross-compilability reasons (i.e. convenience of using this
250 ;;; function in a MAKE-LOAD-FORM expression) that functionality has
251 ;;; been split off into INIT-OR-CHECK-LAYOUT.
252 (declaim (ftype (sfunction (symbol) layout) find-layout))
253 (defun find-layout (name)
254 ;; This seems to be currently used only from the compiler, but make
255 ;; it thread-safe all the same. We need to lock *F-R-L* before doing
256 ;; FIND-CLASSOID in case (SETF FIND-CLASSOID) happens in parallel.
257 (let ((table *forward-referenced-layouts*))
259 (let ((classoid (find-classoid name nil)))
260 (or (and classoid (classoid-layout classoid))
262 (setf (gethash name table)
263 (make-layout :classoid (or classoid (make-undefined-classoid name)))))))))
265 ;;; If LAYOUT is uninitialized, initialize it with CLASSOID, LENGTH,
266 ;;; INHERITS, and DEPTHOID, otherwise require that it be consistent
267 ;;; with CLASSOID, LENGTH, INHERITS, and DEPTHOID.
269 ;;; UNDEFINED-CLASS values are interpreted specially as "we don't know
270 ;;; anything about the class", so if LAYOUT is initialized, any
271 ;;; preexisting class slot value is OK, and if it's not initialized,
272 ;;; its class slot value is set to an UNDEFINED-CLASS. -- FIXME: This
273 ;;; is no longer true, :UNINITIALIZED used instead.
274 (declaim (ftype (function (layout classoid index simple-vector layout-depthoid
277 %init-or-check-layout))
278 (defun %init-or-check-layout
279 (layout classoid length inherits depthoid nuntagged)
280 (cond ((eq (layout-invalid layout) :uninitialized)
281 ;; There was no layout before, we just created one which
282 ;; we'll now initialize with our information.
283 (setf (layout-length layout) length
284 (layout-inherits layout) inherits
285 (layout-depthoid layout) depthoid
286 (layout-n-untagged-slots layout) nuntagged
287 (layout-classoid layout) classoid
288 (layout-invalid layout) nil))
289 ;; FIXME: Now that LAYOUTs are born :UNINITIALIZED, maybe this
290 ;; clause is not needed?
291 ((not *type-system-initialized*)
292 (setf (layout-classoid layout) classoid))
294 ;; There was an old layout already initialized with old
295 ;; information, and we'll now check that old information
296 ;; which was known with certainty is consistent with current
297 ;; information which is known with certainty.
298 (check-layout layout classoid length inherits depthoid nuntagged)))
301 ;;; In code for the target Lisp, we don't use dump LAYOUTs using the
302 ;;; standard load form mechanism, we use special fops instead, in
303 ;;; order to make cold load come out right. But when we're building
304 ;;; the cross-compiler, we can't do that because we don't have access
305 ;;; to special non-ANSI low-level things like special fops, and we
306 ;;; don't need to do that anyway because our code isn't going to be
307 ;;; cold loaded, so we use the ordinary load form system.
309 ;;; KLUDGE: A special hack causes this not to be called when we are
310 ;;; building code for the target Lisp. It would be tidier to just not
311 ;;; have it in place when we're building the target Lisp, but it
312 ;;; wasn't clear how to do that without rethinking DEF!STRUCT quite a
313 ;;; bit, so I punted. -- WHN 19990914
315 (defun make-load-form-for-layout (layout &optional env)
316 (declare (type layout layout))
317 (declare (ignore env))
318 (when (layout-invalid layout)
319 (compiler-error "can't dump reference to obsolete class: ~S"
320 (layout-classoid layout)))
321 (let ((name (classoid-name (layout-classoid layout))))
323 (compiler-error "can't dump anonymous LAYOUT: ~S" layout))
324 ;; Since LAYOUT refers to a class which refers back to the LAYOUT,
325 ;; we have to do this in two stages, like the TREE-WITH-PARENT
326 ;; example in the MAKE-LOAD-FORM entry in the ANSI spec.
328 ;; "creation" form (which actually doesn't create a new LAYOUT if
329 ;; there's a preexisting one with this name)
330 `(find-layout ',name)
331 ;; "initialization" form (which actually doesn't initialize
332 ;; preexisting LAYOUTs, just checks that they're consistent).
333 `(%init-or-check-layout ',layout
334 ',(layout-classoid layout)
335 ',(layout-length layout)
336 ',(layout-inherits layout)
337 ',(layout-depthoid layout)
338 ',(layout-n-untagged-slots layout)))))
340 ;;; If LAYOUT's slot values differ from the specified slot values in
341 ;;; any interesting way, then give a warning and return T.
342 (declaim (ftype (function (simple-string
349 redefine-layout-warning))
350 (defun redefine-layout-warning (old-context old-layout
351 context length inherits depthoid nuntagged)
352 (declare (type layout old-layout) (type simple-string old-context context))
353 (let ((name (layout-proper-name old-layout)))
354 (or (let ((old-inherits (layout-inherits old-layout)))
355 (or (when (mismatch old-inherits
357 :key #'layout-proper-name)
358 (warn "change in superclasses of class ~S:~% ~
359 ~A superclasses: ~S~% ~
363 (map 'list #'layout-proper-name old-inherits)
365 (map 'list #'layout-proper-name inherits))
367 (let ((diff (mismatch old-inherits inherits)))
371 ~@(~A~) definition of superclass ~S is incompatible with~% ~
375 (layout-proper-name (svref old-inherits diff))
378 (let ((old-length (layout-length old-layout)))
379 (unless (= old-length length)
380 (warn "change in instance length of class ~S:~% ~
384 old-context old-length
387 (let ((old-nuntagged (layout-n-untagged-slots old-layout)))
388 (unless (= old-nuntagged nuntagged)
389 (warn "change in instance layout of class ~S:~% ~
390 ~A untagged slots: ~W~% ~
391 ~A untagged slots: ~W"
393 old-context old-nuntagged
396 (unless (= (layout-depthoid old-layout) depthoid)
397 (warn "change in the inheritance structure of class ~S~% ~
398 between the ~A definition and the ~A definition"
399 name old-context context)
402 ;;; Require that LAYOUT data be consistent with CLASS, LENGTH,
403 ;;; INHERITS, and DEPTHOID.
404 (declaim (ftype (function
405 (layout classoid index simple-vector layout-depthoid index))
407 (defun check-layout (layout classoid length inherits depthoid nuntagged)
408 (aver (eq (layout-classoid layout) classoid))
409 (when (redefine-layout-warning "current" layout
410 "compile time" length inherits depthoid
412 ;; Classic CMU CL had more options here. There are several reasons
413 ;; why they might want more options which are less appropriate for
414 ;; us: (1) It's hard to fit the classic CMU CL flexible approach
415 ;; into the ANSI-style MAKE-LOAD-FORM system, and having a
416 ;; non-MAKE-LOAD-FORM-style system is painful when we're trying to
417 ;; make the cross-compiler run under vanilla ANSI Common Lisp. (2)
418 ;; We have CLOS now, and if you want to be able to flexibly
419 ;; redefine classes without restarting the system, it'd make sense
420 ;; to use that, so supporting complexity in order to allow
421 ;; modifying DEFSTRUCTs without restarting the system is a low
422 ;; priority. (3) We now have the ability to rebuild the SBCL
423 ;; system from scratch, so we no longer need this functionality in
424 ;; order to maintain the SBCL system by modifying running images.
425 (error "The loaded code expects an incompatible layout for class ~S."
426 (layout-proper-name layout)))
429 ;;; a common idiom (the same as CMU CL FIND-LAYOUT) rolled up into a
430 ;;; single function call
432 ;;; Used by the loader to forward-reference layouts for classes whose
433 ;;; definitions may not have been loaded yet. This allows type tests
434 ;;; to be loaded when the type definition hasn't been loaded yet.
435 (declaim (ftype (function (symbol index simple-vector layout-depthoid index)
437 find-and-init-or-check-layout))
438 (defun find-and-init-or-check-layout (name length inherits depthoid nuntagged)
440 (let ((layout (find-layout name)))
441 (%init-or-check-layout layout
442 (or (find-classoid name nil)
443 (layout-classoid layout))
449 ;;; Record LAYOUT as the layout for its class, adding it as a subtype
450 ;;; of all superclasses. This is the operation that "installs" a
451 ;;; layout for a class in the type system, clobbering any old layout.
452 ;;; However, this does not modify the class namespace; that is a
453 ;;; separate operation (think anonymous classes.)
454 ;;; -- If INVALIDATE, then all the layouts for any old definition
455 ;;; and subclasses are invalidated, and the SUBCLASSES slot is cleared.
456 ;;; -- If DESTRUCT-LAYOUT, then this is some old layout, and is to be
457 ;;; destructively modified to hold the same type information.
458 (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
459 (defun register-layout (layout &key (invalidate t) destruct-layout)
460 (declare (type layout layout) (type (or layout null) destruct-layout))
462 (let* ((classoid (layout-classoid layout))
463 (classoid-layout (classoid-layout classoid))
464 (subclasses (classoid-subclasses classoid)))
466 ;; Attempting to register ourselves with a temporary undefined
467 ;; class placeholder is almost certainly a programmer error. (I
468 ;; should know, I did it.) -- WHN 19990927
469 (aver (not (undefined-classoid-p classoid)))
471 ;; This assertion dates from classic CMU CL. The rationale is
472 ;; probably that calling REGISTER-LAYOUT more than once for the
473 ;; same LAYOUT is almost certainly a programmer error.
474 (aver (not (eq classoid-layout layout)))
476 ;; Figure out what classes are affected by the change, and issue
477 ;; appropriate warnings and invalidations.
478 (when classoid-layout
479 (%modify-classoid classoid)
481 (dohash ((subclass subclass-layout) subclasses :locked t)
482 (%modify-classoid subclass)
484 (%invalidate-layout subclass-layout))))
486 (%invalidate-layout classoid-layout)
487 (setf (classoid-subclasses classoid) nil)))
490 (setf (layout-invalid destruct-layout) nil
491 (layout-inherits destruct-layout) (layout-inherits layout)
492 (layout-depthoid destruct-layout)(layout-depthoid layout)
493 (layout-length destruct-layout) (layout-length layout)
494 (layout-n-untagged-slots destruct-layout) (layout-n-untagged-slots layout)
495 (layout-info destruct-layout) (layout-info layout)
496 (classoid-layout classoid) destruct-layout)
497 (setf (layout-invalid layout) nil
498 (classoid-layout classoid) layout))
500 (dovector (super-layout (layout-inherits layout))
501 (let* ((super (layout-classoid super-layout))
502 (subclasses (or (classoid-subclasses super)
503 (setf (classoid-subclasses super)
504 (make-hash-table :test 'eq
505 #-sb-xc-host #-sb-xc-host
507 (when (and (eq (classoid-state super) :sealed)
508 (not (gethash classoid subclasses)))
509 (warn "unsealing sealed class ~S in order to subclass it"
510 (classoid-name super))
511 (setf (classoid-state super) :read-only))
512 (setf (gethash classoid subclasses)
513 (or destruct-layout layout))))))
518 ;;; Arrange the inherited layouts to appear at their expected depth,
519 ;;; ensuring that hierarchical type tests succeed. Layouts with
520 ;;; DEPTHOID >= 0 (i.e. hierarchical classes) are placed first,
521 ;;; at exactly that index in the INHERITS vector. Then, non-hierarchical
522 ;;; layouts are placed in remaining elements. Then, any still-empty
523 ;;; elements are filled with their successors, ensuring that each
524 ;;; element contains a valid layout.
526 ;;; This reordering may destroy CPL ordering, so the inherits should
527 ;;; not be read as being in CPL order.
528 (defun order-layout-inherits (layouts)
529 (declare (simple-vector layouts))
530 (let ((length (length layouts))
533 (let ((depth (layout-depthoid (svref layouts i))))
534 (when (> depth max-depth)
535 (setf max-depth depth))))
536 (let* ((new-length (max (1+ max-depth) length))
537 ;; KLUDGE: 0 here is the "uninitialized" element. We need
538 ;; to specify it explicitly for portability purposes, as
539 ;; elements can be read before being set [ see below, "(EQL
540 ;; OLD-LAYOUT 0)" ]. -- CSR, 2002-04-20
541 (inherits (make-array new-length :initial-element 0)))
543 (let* ((layout (svref layouts i))
544 (depth (layout-depthoid layout)))
545 (unless (eql depth -1)
546 (let ((old-layout (svref inherits depth)))
547 (unless (or (eql old-layout 0) (eq old-layout layout))
548 (error "layout depth conflict: ~S~%" layouts)))
549 (setf (svref inherits depth) layout))))
553 (declare (type index i j))
554 (let* ((layout (svref layouts i))
555 (depth (layout-depthoid layout)))
557 (loop (when (eql (svref inherits j) 0)
560 (setf (svref inherits j) layout))))
561 (do ((i (1- new-length) (1- i)))
563 (declare (type fixnum i))
564 (when (eql (svref inherits i) 0)
565 (setf (svref inherits i) (svref inherits (1+ i)))))
568 ;;;; class precedence lists
570 ;;; Topologically sort the list of objects to meet a set of ordering
571 ;;; constraints given by pairs (A . B) constraining A to precede B.
572 ;;; When there are multiple objects to choose, the tie-breaker
573 ;;; function is called with both the list of object to choose from and
574 ;;; the reverse ordering built so far.
575 (defun topological-sort (objects constraints tie-breaker)
576 (declare (list objects constraints)
577 (function tie-breaker))
578 (let ((obj-info (make-hash-table :size (length objects)))
581 (dolist (constraint constraints)
582 (let ((obj1 (car constraint))
583 (obj2 (cdr constraint)))
584 (let ((info2 (gethash obj2 obj-info)))
587 (setf (gethash obj2 obj-info) (list 1))))
588 (let ((info1 (gethash obj1 obj-info)))
590 (push obj2 (rest info1))
591 (setf (gethash obj1 obj-info) (list 0 obj2))))))
592 (dolist (obj objects)
593 (let ((info (gethash obj obj-info)))
594 (when (or (not info) (zerop (first info)))
595 (push obj free-objs))))
597 (flet ((next-result (obj)
599 (dolist (successor (rest (gethash obj obj-info)))
600 (let* ((successor-info (gethash successor obj-info))
601 (count (1- (first successor-info))))
602 (setf (first successor-info) count)
604 (push successor free-objs))))))
605 (cond ((endp free-objs)
606 (dohash ((obj info) obj-info)
607 (unless (zerop (first info))
608 (error "Topological sort failed due to constraint on ~S."
610 (return (nreverse result)))
611 ((endp (rest free-objs))
612 (next-result (pop free-objs)))
614 (let ((obj (funcall tie-breaker free-objs result)))
615 (setf free-objs (remove obj free-objs))
616 (next-result obj))))))))
619 ;;; standard class precedence list computation
620 (defun std-compute-class-precedence-list (class)
623 (labels ((note-class (class)
624 (unless (member class classes)
626 (let ((superclasses (classoid-direct-superclasses class)))
628 (rest superclasses (rest rest)))
630 (let ((next (first rest)))
631 (push (cons prev next) constraints)
633 (dolist (class superclasses)
634 (note-class class)))))
635 (std-cpl-tie-breaker (free-classes rev-cpl)
636 (dolist (class rev-cpl (first free-classes))
637 (let* ((superclasses (classoid-direct-superclasses class))
638 (intersection (intersection free-classes
641 (return (first intersection)))))))
643 (topological-sort classes constraints #'std-cpl-tie-breaker))))
645 ;;;; object types to represent classes
647 ;;; An UNDEFINED-CLASSOID is a cookie we make up to stick in forward
648 ;;; referenced layouts. Users should never see them.
649 (def!struct (undefined-classoid
651 (:constructor make-undefined-classoid (name))))
653 ;;; BUILT-IN-CLASS is used to represent the standard classes that
654 ;;; aren't defined with DEFSTRUCT and other specially implemented
655 ;;; primitive types whose only attribute is their name.
657 ;;; Some BUILT-IN-CLASSes have a TRANSLATION, which means that they
658 ;;; are effectively DEFTYPE'd to some other type (usually a union of
659 ;;; other classes or a "primitive" type such as NUMBER, ARRAY, etc.)
660 ;;; This translation is done when type specifiers are parsed. Type
661 ;;; system operations (union, subtypep, etc.) should never encounter
662 ;;; translated classes, only their translation.
663 (def!struct (built-in-classoid (:include classoid)
664 (:constructor make-built-in-classoid))
665 ;; the type we translate to on parsing. If NIL, then this class
666 ;; stands on its own; or it can be set to :INITIALIZING for a period
668 (translation nil :type (or ctype (member nil :initializing))))
670 ;;; STRUCTURE-CLASS represents what we need to know about structure
671 ;;; classes. Non-structure "typed" defstructs are a special case, and
672 ;;; don't have a corresponding class.
673 (def!struct (structure-classoid (:include classoid)
674 (:constructor make-structure-classoid))
675 ;; If true, a default keyword constructor for this structure.
676 (constructor nil :type (or function null)))
678 ;;;; classoid namespace
680 ;;; We use an indirection to allow forward referencing of class
681 ;;; definitions with load-time resolution.
682 (def!struct (classoid-cell
683 (:constructor make-classoid-cell (name &optional classoid))
684 (:make-load-form-fun (lambda (c)
686 ',(classoid-cell-name c)
688 #-no-ansi-print-object
689 (:print-object (lambda (s stream)
690 (print-unreadable-object (s stream :type t)
691 (prin1 (classoid-cell-name s) stream)))))
692 ;; Name of class we expect to find.
693 (name nil :type symbol :read-only t)
694 ;; Classoid or NIL if not yet defined.
695 (classoid nil :type (or classoid null))
699 ;;; Protected by the hash-table lock, used only in FIND-CLASSOID-CELL.
700 (defvar *classoid-cells*)
702 (setq *classoid-cells* (make-hash-table :test 'eq)))
704 (defun find-classoid-cell (name &key create errorp)
705 (let ((table *classoid-cells*)
706 (real-name (uncross name)))
707 (or (with-locked-hash-table (table)
708 (or (gethash real-name table)
710 (setf (gethash real-name table) (make-classoid-cell real-name)))))
712 (error 'simple-type-error
714 :expected-type 'class
715 :format-control "Class not yet defined: ~S"
716 :format-arguments (list name))))))
718 (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
720 ;; Return the classoid with the specified NAME. If ERRORP is false,
721 ;; then NIL is returned when no such class exists."
722 (defun find-classoid (name &optional (errorp t))
723 (declare (type symbol name))
724 (let ((cell (find-classoid-cell name :errorp errorp)))
725 (when cell (classoid-cell-classoid cell))))
727 (defun (setf find-classoid) (new-value name)
728 #-sb-xc (declare (type (or null classoid) new-value))
730 (let ((table *forward-referenced-layouts*))
732 (let ((cell (find-classoid-cell name :create t)))
733 (ecase (info :type :kind name)
735 (:forthcoming-defclass-type
736 ;; FIXME: Currently, nothing needs to be done in this case.
737 ;; Later, when PCL is integrated tighter into SBCL, this
738 ;; might need more work.
742 (let ((old-value (classoid-cell-classoid cell)))
744 ;; KLUDGE: The reason these clauses aren't directly
745 ;; parallel is that we need to use the internal
746 ;; CLASSOID structure ourselves, because we don't
747 ;; have CLASSes to work with until PCL is built. In
748 ;; the host, CLASSes have an approximately
749 ;; one-to-one correspondence with the target
750 ;; CLASSOIDs (as well as with the target CLASSes,
751 ;; modulo potential differences with respect to
754 (let ((old (class-of old-value))
755 (new (class-of new-value)))
757 (bug "Trying to change the metaclass of ~S from ~S to ~S in the ~
759 name (class-name old) (class-name new))))
761 (let ((old (classoid-of old-value))
762 (new (classoid-of new-value)))
764 (warn "Changing meta-class of ~S from ~S to ~S."
765 name (classoid-name old) (classoid-name new))))))
767 (error "Cannot redefine standard type ~S." name))
769 (warn "Redefining DEFTYPE type to be a class: ~S" name)
770 (setf (info :type :expander name) nil
771 (info :type :lambda-list name) nil
772 (info :type :source-location name) nil)))
775 (%note-type-defined name)
776 ;; we need to handle things like
777 ;; (setf (find-class 'foo) (find-class 'integer))
779 ;; (setf (find-class 'integer) (find-class 'integer))
780 (cond ((built-in-classoid-p new-value)
781 (setf (info :type :kind name)
782 (or (info :type :kind name) :defined))
783 (let ((translation (built-in-classoid-translation new-value)))
785 (setf (info :type :translator name)
786 (lambda (c) (declare (ignore c)) translation)))))
788 (setf (info :type :kind name) :instance)))
789 (setf (classoid-cell-classoid cell) new-value)
790 (unless (eq (info :type :compiler-layout name)
791 (classoid-layout new-value))
792 (setf (info :type :compiler-layout name)
793 (classoid-layout new-value))))))
796 (defun %clear-classoid (name cell)
797 (ecase (info :type :kind name)
801 (error "Attempt to remove :PRIMITIVE type: ~S" name))
802 ((:forthcoming-defclass-type :instance)
804 ;; Note: We cannot remove the classoid cell from the table,
805 ;; since compiled code may refer directly to the cell, and
806 ;; getting a different cell for a classoid with the same name
807 ;; just would not do.
809 ;; Remove the proper name of the classoid.
810 (setf (classoid-name (classoid-cell-classoid cell)) nil)
812 (setf (classoid-cell-classoid cell) nil
813 (classoid-cell-pcl-class cell) nil))
814 (setf (info :type :kind name) nil
815 (info :type :documentation name) nil
816 (info :type :compiler-layout name) nil)))))
818 ;;; Called when we are about to define NAME as a class meeting some
819 ;;; predicate (such as a meta-class type test.) The first result is
820 ;;; always of the desired class. The second result is any existing
821 ;;; LAYOUT for this name.
823 ;;; Again, this should be compiler-only, but easier to make this
825 (defun insured-find-classoid (name predicate constructor)
826 (declare (type function predicate constructor))
827 (let ((table *forward-referenced-layouts*))
828 (with-locked-hash-table (table)
829 (let* ((old (find-classoid name nil))
830 (res (if (and old (funcall predicate old))
832 (funcall constructor :name name)))
833 (found (or (gethash name table)
834 (when old (classoid-layout old)))))
836 (setf (layout-classoid found) res))
837 (values res found)))))
839 ;;; If the classoid has a proper name, return the name, otherwise return
841 (defun classoid-proper-name (classoid)
842 #-sb-xc (declare (type classoid classoid))
843 (let ((name (classoid-name classoid)))
844 (if (and name (eq (find-classoid name nil) classoid))
848 ;;;; CLASS type operations
850 (!define-type-class classoid)
852 ;;; We might be passed classoids with invalid layouts; in any pairwise
853 ;;; class comparison, we must ensure that both are valid before
855 (defun %ensure-classoid-valid (classoid layout)
856 (aver (eq classoid (layout-classoid layout)))
857 (when (layout-invalid layout)
858 (if (typep classoid 'standard-classoid)
859 (let ((class (classoid-pcl-class classoid)))
861 ((sb!pcl:class-finalized-p class)
862 (sb!pcl::%force-cache-flushes class))
863 ((sb!pcl::class-has-a-forward-referenced-superclass-p class)
864 (error "Invalid, unfinalizeable class ~S (classoid ~S)."
867 (sb!pcl:finalize-inheritance class))))
868 (error "Don't know how to ensure validity of ~S (not ~
869 a STANDARD-CLASSOID)." classoid))))
871 (defun %ensure-both-classoids-valid (class1 class2)
872 (do ((layout1 (classoid-layout class1) (classoid-layout class1))
873 (layout2 (classoid-layout class2) (classoid-layout class2))
875 ((and (not (layout-invalid layout1)) (not (layout-invalid layout2))))
877 (%ensure-classoid-valid class1 layout1)
878 (%ensure-classoid-valid class2 layout2)))
880 (defun update-object-layout-or-invalid (object layout)
881 (if (typep (classoid-of object) 'standard-classoid)
882 (sb!pcl::check-wrapper-validity object)
883 (sb!c::%layout-invalid-error object layout)))
885 ;;; Simple methods for TYPE= and SUBTYPEP should never be called when
886 ;;; the two classes are equal, since there are EQ checks in those
888 (!define-type-method (classoid :simple-=) (type1 type2)
889 (aver (not (eq type1 type2)))
892 (!define-type-method (classoid :simple-subtypep) (class1 class2)
893 (aver (not (eq class1 class2)))
895 (%ensure-both-classoids-valid class1 class2)
896 (let ((subclasses (classoid-subclasses class2)))
897 (if (and subclasses (gethash class1 subclasses))
901 ;;; When finding the intersection of a sealed class and some other
902 ;;; class (not hierarchically related) the intersection is the union
903 ;;; of the currently shared subclasses.
904 (defun sealed-class-intersection2 (sealed other)
905 (declare (type classoid sealed other))
906 (let ((s-sub (classoid-subclasses sealed))
907 (o-sub (classoid-subclasses other)))
908 (if (and s-sub o-sub)
909 (collect ((res *empty-type* type-union))
910 (dohash ((subclass layout) s-sub :locked t)
911 (declare (ignore layout))
912 (when (gethash subclass o-sub)
913 (res (specifier-type subclass))))
917 (!define-type-method (classoid :simple-intersection2) (class1 class2)
918 (declare (type classoid class1 class2))
920 (%ensure-both-classoids-valid class1 class2)
921 (cond ((eq class1 class2)
923 ;; If one is a subclass of the other, then that is the
925 ((let ((subclasses (classoid-subclasses class2)))
926 (and subclasses (gethash class1 subclasses)))
928 ((let ((subclasses (classoid-subclasses class1)))
929 (and subclasses (gethash class2 subclasses)))
931 ;; Otherwise, we can't in general be sure that the
932 ;; intersection is empty, since a subclass of both might be
933 ;; defined. But we can eliminate it for some special cases.
934 ((or (structure-classoid-p class1)
935 (structure-classoid-p class2))
936 ;; No subclass of both can be defined.
938 ((eq (classoid-state class1) :sealed)
939 ;; checking whether a subclass of both can be defined:
940 (sealed-class-intersection2 class1 class2))
941 ((eq (classoid-state class2) :sealed)
942 ;; checking whether a subclass of both can be defined:
943 (sealed-class-intersection2 class2 class1))
945 ;; uncertain, since a subclass of both might be defined
948 ;;; KLUDGE: we need this to deal with the special-case INSTANCE and
949 ;;; FUNCALLABLE-INSTANCE types (which used to be CLASSOIDs until CSR
950 ;;; discovered that this was incompatible with the MOP class
951 ;;; hierarchy). See NAMED :COMPLEX-SUBTYPEP-ARG2
952 (defvar *non-instance-classoid-types*
953 '(symbol system-area-pointer weak-pointer code-component
954 lra fdefn random-class))
956 ;;; KLUDGE: we need this because of the need to represent
957 ;;; intersections of two classes, even when empty at a given time, as
958 ;;; uncanonicalized intersections because of the possibility of later
959 ;;; defining a subclass of both classes. The necessity for changing
960 ;;; the default return value from SUBTYPEP to NIL, T if no alternate
961 ;;; method is present comes about because, unlike the other places we
962 ;;; use INVOKE-COMPLEX-SUBTYPEP-ARG1-METHOD, in HAIRY methods and the
963 ;;; like, classes are in their own hierarchy with no possibility of
964 ;;; mixtures with other type classes.
965 (!define-type-method (classoid :complex-subtypep-arg2) (type1 class2)
966 (if (and (intersection-type-p type1)
967 (> (count-if #'classoid-p (intersection-type-types type1)) 1))
969 (invoke-complex-subtypep-arg1-method type1 class2 nil t)))
971 (!define-type-method (classoid :negate) (type)
972 (make-negation-type :type type))
974 (!define-type-method (classoid :unparse) (type)
975 (classoid-proper-name type))
979 ;;; the CLASSOID that we use to represent type information for
980 ;;; STANDARD-CLASS and FUNCALLABLE-STANDARD-CLASS. The type system
981 ;;; side does not need to distinguish between STANDARD-CLASS and
982 ;;; FUNCALLABLE-STANDARD-CLASS.
983 (def!struct (standard-classoid (:include classoid)
984 (:constructor make-standard-classoid)))
985 ;;; a metaclass for classes which aren't standardlike but will never
987 (def!struct (static-classoid (:include classoid)
988 (:constructor make-static-classoid)))
990 ;;;; built-in classes
992 ;;; The BUILT-IN-CLASSES list is a data structure which configures the
993 ;;; creation of all the built-in classes. It contains all the info
994 ;;; that we need to maintain the mapping between classes, compile-time
995 ;;; types and run-time type codes. These options are defined:
997 ;;; :TRANSLATION (default none)
998 ;;; When this class is "parsed" as a type specifier, it is
999 ;;; translated into the specified internal type representation,
1000 ;;; rather than being left as a class. This is used for types
1001 ;;; which we want to canonicalize to some other kind of type
1002 ;;; object because in general we want to be able to include more
1003 ;;; information than just the class (e.g. for numeric types.)
1005 ;;; :ENUMERABLE (default NIL)
1006 ;;; The value of the :ENUMERABLE slot in the created class.
1007 ;;; Meaningless in translated classes.
1009 ;;; :STATE (default :SEALED)
1010 ;;; The value of CLASS-STATE which we want on completion,
1011 ;;; indicating whether subclasses can be created at run-time.
1013 ;;; :HIERARCHICAL-P (default T unless any of the inherits are non-hierarchical)
1014 ;;; True if we can assign this class a unique inheritance depth.
1016 ;;; :CODES (default none)
1017 ;;; Run-time type codes which should be translated back to this
1018 ;;; class by CLASS-OF. Unspecified for abstract classes.
1020 ;;; :INHERITS (default this class and T)
1021 ;;; The class-precedence list for this class, with this class and
1024 ;;; :DIRECT-SUPERCLASSES (default to head of CPL)
1025 ;;; List of the direct superclasses of this class.
1027 ;;; FIXME: This doesn't seem to be needed after cold init (and so can
1028 ;;; probably be uninterned at the end of cold init).
1029 (defvar *built-in-classes*)
1031 (/show0 "setting *BUILT-IN-CLASSES*")
1034 '((t :state :read-only :translation t)
1035 (character :enumerable t
1036 :codes (#.sb!vm:character-widetag)
1037 :translation (character-set)
1038 :prototype-form (code-char 42))
1039 (symbol :codes (#.sb!vm:symbol-header-widetag)
1040 :prototype-form '#:mu)
1042 (system-area-pointer :codes (#.sb!vm:sap-widetag)
1043 :prototype-form (sb!sys:int-sap 42))
1044 (weak-pointer :codes (#.sb!vm:weak-pointer-widetag)
1045 :prototype-form (sb!ext:make-weak-pointer (find-package "CL")))
1046 (code-component :codes (#.sb!vm:code-header-widetag))
1047 (lra :codes (#.sb!vm:return-pc-header-widetag))
1048 (fdefn :codes (#.sb!vm:fdefn-widetag)
1049 :prototype-form (sb!kernel:make-fdefn "42"))
1050 (random-class) ; used for unknown type codes
1053 :codes (#.sb!vm:closure-header-widetag
1054 #.sb!vm:simple-fun-header-widetag)
1056 :prototype-form (function (lambda () 42)))
1058 (number :translation number)
1060 :translation complex
1062 :codes (#.sb!vm:complex-widetag)
1063 :prototype-form (complex 42 42))
1064 (complex-single-float
1065 :translation (complex single-float)
1066 :inherits (complex number)
1067 :codes (#.sb!vm:complex-single-float-widetag)
1068 :prototype-form (complex 42f0 42f0))
1069 (complex-double-float
1070 :translation (complex double-float)
1071 :inherits (complex number)
1072 :codes (#.sb!vm:complex-double-float-widetag)
1073 :prototype-form (complex 42d0 42d0))
1076 :translation (complex long-float)
1077 :inherits (complex number)
1078 :codes (#.sb!vm:complex-long-float-widetag)
1079 :prototype-form (complex 42l0 42l0))
1080 (real :translation real :inherits (number))
1083 :inherits (real number))
1085 :translation single-float
1086 :inherits (float real number)
1087 :codes (#.sb!vm:single-float-widetag)
1088 :prototype-form 42f0)
1090 :translation double-float
1091 :inherits (float real number)
1092 :codes (#.sb!vm:double-float-widetag)
1093 :prototype-form 42d0)
1096 :translation long-float
1097 :inherits (float real number)
1098 :codes (#.sb!vm:long-float-widetag)
1099 :prototype-form 42l0)
1101 :translation rational
1102 :inherits (real number))
1104 :translation (and rational (not integer))
1105 :inherits (rational real number)
1106 :codes (#.sb!vm:ratio-widetag)
1107 :prototype-form 1/42)
1109 :translation integer
1110 :inherits (rational real number))
1112 :translation (integer #.sb!xc:most-negative-fixnum
1113 #.sb!xc:most-positive-fixnum)
1114 :inherits (integer rational real number)
1115 :codes (#.sb!vm:even-fixnum-lowtag #.sb!vm:odd-fixnum-lowtag)
1118 :translation (and integer (not fixnum))
1119 :inherits (integer rational real number)
1120 :codes (#.sb!vm:bignum-widetag)
1121 :prototype-form (expt 2 #.(* sb!vm:n-word-bits (/ 3 2))))
1123 (array :translation array :codes (#.sb!vm:complex-array-widetag)
1125 :prototype-form (make-array nil :adjustable t))
1127 :translation simple-array :codes (#.sb!vm:simple-array-widetag)
1129 :prototype-form (make-array nil))
1131 :translation (or cons (member nil) vector extended-sequence)
1135 :translation vector :codes (#.sb!vm:complex-vector-widetag)
1136 :direct-superclasses (array sequence)
1137 :inherits (array sequence))
1139 :translation simple-vector :codes (#.sb!vm:simple-vector-widetag)
1140 :direct-superclasses (vector simple-array)
1141 :inherits (vector simple-array array sequence)
1142 :prototype-form (make-array 0))
1144 :translation bit-vector :codes (#.sb!vm:complex-bit-vector-widetag)
1145 :inherits (vector array sequence)
1146 :prototype-form (make-array 0 :element-type 'bit :fill-pointer t))
1148 :translation simple-bit-vector :codes (#.sb!vm:simple-bit-vector-widetag)
1149 :direct-superclasses (bit-vector simple-array)
1150 :inherits (bit-vector vector simple-array
1152 :prototype-form (make-array 0 :element-type 'bit))
1153 (simple-array-unsigned-byte-2
1154 :translation (simple-array (unsigned-byte 2) (*))
1155 :codes (#.sb!vm:simple-array-unsigned-byte-2-widetag)
1156 :direct-superclasses (vector simple-array)
1157 :inherits (vector simple-array array sequence)
1158 :prototype-form (make-array 0 :element-type '(unsigned-byte 2)))
1159 (simple-array-unsigned-byte-4
1160 :translation (simple-array (unsigned-byte 4) (*))
1161 :codes (#.sb!vm:simple-array-unsigned-byte-4-widetag)
1162 :direct-superclasses (vector simple-array)
1163 :inherits (vector simple-array array sequence)
1164 :prototype-form (make-array 0 :element-type '(unsigned-byte 4)))
1165 (simple-array-unsigned-byte-7
1166 :translation (simple-array (unsigned-byte 7) (*))
1167 :codes (#.sb!vm:simple-array-unsigned-byte-7-widetag)
1168 :direct-superclasses (vector simple-array)
1169 :inherits (vector simple-array array sequence)
1170 :prototype-form (make-array 0 :element-type '(unsigned-byte 7)))
1171 (simple-array-unsigned-byte-8
1172 :translation (simple-array (unsigned-byte 8) (*))
1173 :codes (#.sb!vm:simple-array-unsigned-byte-8-widetag)
1174 :direct-superclasses (vector simple-array)
1175 :inherits (vector simple-array array sequence)
1176 :prototype-form (make-array 0 :element-type '(unsigned-byte 8)))
1177 (simple-array-unsigned-byte-15
1178 :translation (simple-array (unsigned-byte 15) (*))
1179 :codes (#.sb!vm:simple-array-unsigned-byte-15-widetag)
1180 :direct-superclasses (vector simple-array)
1181 :inherits (vector simple-array array sequence)
1182 :prototype-form (make-array 0 :element-type '(unsigned-byte 15)))
1183 (simple-array-unsigned-byte-16
1184 :translation (simple-array (unsigned-byte 16) (*))
1185 :codes (#.sb!vm:simple-array-unsigned-byte-16-widetag)
1186 :direct-superclasses (vector simple-array)
1187 :inherits (vector simple-array array sequence)
1188 :prototype-form (make-array 0 :element-type '(unsigned-byte 16)))
1189 #!+#.(cl:if (cl:= 32 sb!vm:n-word-bits) '(and) '(or))
1190 (simple-array-unsigned-byte-29
1191 :translation (simple-array (unsigned-byte 29) (*))
1192 :codes (#.sb!vm:simple-array-unsigned-byte-29-widetag)
1193 :direct-superclasses (vector simple-array)
1194 :inherits (vector simple-array array sequence)
1195 :prototype-form (make-array 0 :element-type '(unsigned-byte 29)))
1196 (simple-array-unsigned-byte-31
1197 :translation (simple-array (unsigned-byte 31) (*))
1198 :codes (#.sb!vm:simple-array-unsigned-byte-31-widetag)
1199 :direct-superclasses (vector simple-array)
1200 :inherits (vector simple-array array sequence)
1201 :prototype-form (make-array 0 :element-type '(unsigned-byte 31)))
1202 (simple-array-unsigned-byte-32
1203 :translation (simple-array (unsigned-byte 32) (*))
1204 :codes (#.sb!vm:simple-array-unsigned-byte-32-widetag)
1205 :direct-superclasses (vector simple-array)
1206 :inherits (vector simple-array array sequence)
1207 :prototype-form (make-array 0 :element-type '(unsigned-byte 32)))
1208 #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
1209 (simple-array-unsigned-byte-60
1210 :translation (simple-array (unsigned-byte 60) (*))
1211 :codes (#.sb!vm:simple-array-unsigned-byte-60-widetag)
1212 :direct-superclasses (vector simple-array)
1213 :inherits (vector simple-array array sequence)
1214 :prototype-form (make-array 0 :element-type '(unsigned-byte 60)))
1215 #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
1216 (simple-array-unsigned-byte-63
1217 :translation (simple-array (unsigned-byte 63) (*))
1218 :codes (#.sb!vm:simple-array-unsigned-byte-63-widetag)
1219 :direct-superclasses (vector simple-array)
1220 :inherits (vector simple-array array sequence)
1221 :prototype-form (make-array 0 :element-type '(unsigned-byte 63)))
1222 #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
1223 (simple-array-unsigned-byte-64
1224 :translation (simple-array (unsigned-byte 64) (*))
1225 :codes (#.sb!vm:simple-array-unsigned-byte-64-widetag)
1226 :direct-superclasses (vector simple-array)
1227 :inherits (vector simple-array array sequence)
1228 :prototype-form (make-array 0 :element-type '(unsigned-byte 64)))
1229 (simple-array-signed-byte-8
1230 :translation (simple-array (signed-byte 8) (*))
1231 :codes (#.sb!vm:simple-array-signed-byte-8-widetag)
1232 :direct-superclasses (vector simple-array)
1233 :inherits (vector simple-array array sequence)
1234 :prototype-form (make-array 0 :element-type '(signed-byte 8)))
1235 (simple-array-signed-byte-16
1236 :translation (simple-array (signed-byte 16) (*))
1237 :codes (#.sb!vm:simple-array-signed-byte-16-widetag)
1238 :direct-superclasses (vector simple-array)
1239 :inherits (vector simple-array array sequence)
1240 :prototype-form (make-array 0 :element-type '(signed-byte 16)))
1241 #!+#.(cl:if (cl:= 32 sb!vm:n-word-bits) '(and) '(or))
1242 (simple-array-signed-byte-30
1243 :translation (simple-array (signed-byte 30) (*))
1244 :codes (#.sb!vm:simple-array-signed-byte-30-widetag)
1245 :direct-superclasses (vector simple-array)
1246 :inherits (vector simple-array array sequence)
1247 :prototype-form (make-array 0 :element-type '(signed-byte 30)))
1248 (simple-array-signed-byte-32
1249 :translation (simple-array (signed-byte 32) (*))
1250 :codes (#.sb!vm:simple-array-signed-byte-32-widetag)
1251 :direct-superclasses (vector simple-array)
1252 :inherits (vector simple-array array sequence)
1253 :prototype-form (make-array 0 :element-type '(signed-byte 32)))
1254 #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
1255 (simple-array-signed-byte-61
1256 :translation (simple-array (signed-byte 61) (*))
1257 :codes (#.sb!vm:simple-array-signed-byte-61-widetag)
1258 :direct-superclasses (vector simple-array)
1259 :inherits (vector simple-array array sequence)
1260 :prototype-form (make-array 0 :element-type '(signed-byte 61)))
1261 #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
1262 (simple-array-signed-byte-64
1263 :translation (simple-array (signed-byte 64) (*))
1264 :codes (#.sb!vm:simple-array-signed-byte-64-widetag)
1265 :direct-superclasses (vector simple-array)
1266 :inherits (vector simple-array array sequence)
1267 :prototype-form (make-array 0 :element-type '(signed-byte 64)))
1268 (simple-array-single-float
1269 :translation (simple-array single-float (*))
1270 :codes (#.sb!vm:simple-array-single-float-widetag)
1271 :direct-superclasses (vector simple-array)
1272 :inherits (vector simple-array array sequence)
1273 :prototype-form (make-array 0 :element-type 'single-float))
1274 (simple-array-double-float
1275 :translation (simple-array double-float (*))
1276 :codes (#.sb!vm:simple-array-double-float-widetag)
1277 :direct-superclasses (vector simple-array)
1278 :inherits (vector simple-array array sequence)
1279 :prototype-form (make-array 0 :element-type 'double-float))
1281 (simple-array-long-float
1282 :translation (simple-array long-float (*))
1283 :codes (#.sb!vm:simple-array-long-float-widetag)
1284 :direct-superclasses (vector simple-array)
1285 :inherits (vector simple-array array sequence)
1286 :prototype-form (make-array 0 :element-type 'long-float))
1287 (simple-array-complex-single-float
1288 :translation (simple-array (complex single-float) (*))
1289 :codes (#.sb!vm:simple-array-complex-single-float-widetag)
1290 :direct-superclasses (vector simple-array)
1291 :inherits (vector simple-array array sequence)
1292 :prototype-form (make-array 0 :element-type '(complex single-float)))
1293 (simple-array-complex-double-float
1294 :translation (simple-array (complex double-float) (*))
1295 :codes (#.sb!vm:simple-array-complex-double-float-widetag)
1296 :direct-superclasses (vector simple-array)
1297 :inherits (vector simple-array array sequence)
1298 :prototype-form (make-array 0 :element-type '(complex double-float)))
1300 (simple-array-complex-long-float
1301 :translation (simple-array (complex long-float) (*))
1302 :codes (#.sb!vm:simple-array-complex-long-float-widetag)
1303 :direct-superclasses (vector simple-array)
1304 :inherits (vector simple-array array sequence)
1305 :prototype-form (make-array 0 :element-type '(complex long-float)))
1308 :direct-superclasses (vector)
1309 :inherits (vector array sequence))
1311 :translation simple-string
1312 :direct-superclasses (string simple-array)
1313 :inherits (string vector simple-array array sequence))
1315 :translation (vector nil)
1316 :codes (#.sb!vm:complex-vector-nil-widetag)
1317 :direct-superclasses (string)
1318 :inherits (string vector array sequence)
1319 :prototype-form (make-array 0 :element-type 'nil :fill-pointer t))
1321 :translation (simple-array nil (*))
1322 :codes (#.sb!vm:simple-array-nil-widetag)
1323 :direct-superclasses (vector-nil simple-string)
1324 :inherits (vector-nil simple-string string vector simple-array
1326 :prototype-form (make-array 0 :element-type 'nil))
1328 :translation base-string
1329 :codes (#.sb!vm:complex-base-string-widetag)
1330 :direct-superclasses (string)
1331 :inherits (string vector array sequence)
1332 :prototype-form (make-array 0 :element-type 'base-char :fill-pointer t))
1334 :translation simple-base-string
1335 :codes (#.sb!vm:simple-base-string-widetag)
1336 :direct-superclasses (base-string simple-string)
1337 :inherits (base-string simple-string string vector simple-array
1339 :prototype-form (make-array 0 :element-type 'base-char))
1342 :translation (vector character)
1343 :codes (#.sb!vm:complex-character-string-widetag)
1344 :direct-superclasses (string)
1345 :inherits (string vector array sequence)
1346 :prototype-form (make-array 0 :element-type 'character :fill-pointer t))
1348 (simple-character-string
1349 :translation (simple-array character (*))
1350 :codes (#.sb!vm:simple-character-string-widetag)
1351 :direct-superclasses (character-string simple-string)
1352 :inherits (character-string simple-string string vector simple-array
1354 :prototype-form (make-array 0 :element-type 'character))
1356 :translation (or cons (member nil))
1357 :inherits (sequence))
1359 :codes (#.sb!vm:list-pointer-lowtag)
1361 :inherits (list sequence)
1362 :prototype-form (cons nil nil))
1364 :translation (member nil)
1365 :inherits (symbol list sequence)
1366 :direct-superclasses (symbol list)
1367 :prototype-form 'nil)
1378 :inherits (stream)))))
1380 ;;; See also src/code/class-init.lisp where we finish setting up the
1381 ;;; translations for built-in types.
1383 (dolist (x *built-in-classes*)
1384 #-sb-xc-host (/show0 "at head of loop over *BUILT-IN-CLASSES*")
1387 (translation nil trans-p)
1394 (hierarchical-p t) ; might be modified below
1395 (direct-superclasses (if inherits
1396 (list (car inherits))
1399 (declare (ignore codes state translation prototype-form))
1400 (let ((inherits-list (if (eq name t)
1402 (cons t (reverse inherits))))
1403 (classoid (make-built-in-classoid
1404 :enumerable enumerable
1406 :translation (if trans-p :initializing nil)
1407 :direct-superclasses
1410 (mapcar #'find-classoid direct-superclasses)))))
1411 (setf (info :type :kind name) #+sb-xc-host :defined #-sb-xc-host :primitive
1412 (classoid-cell-classoid (find-classoid-cell name :create t)) classoid)
1414 (setf (info :type :builtin name) classoid))
1415 (let* ((inherits-vector
1419 (classoid-layout (find-classoid x))))
1420 (when (minusp (layout-depthoid super-layout))
1421 (setf hierarchical-p nil))
1424 (depthoid (if hierarchical-p
1425 (or depth (length inherits-vector))
1428 (find-and-init-or-check-layout name
1433 :invalidate nil)))))
1434 (/show0 "done with loop over *BUILT-IN-CLASSES*"))
1436 ;;; Define temporary PCL STANDARD-CLASSes. These will be set up
1437 ;;; correctly and the Lisp layout replaced by a PCL wrapper after PCL
1438 ;;; is loaded and the class defined.
1440 (/show0 "about to define temporary STANDARD-CLASSes")
1441 (dolist (x '(;; Why is STREAM duplicated in this list? Because, when
1442 ;; the inherits-vector of FUNDAMENTAL-STREAM is set up,
1443 ;; a vector containing the elements of the list below,
1444 ;; i.e. '(T STREAM STREAM), is created, and
1445 ;; this is what the function ORDER-LAYOUT-INHERITS
1448 ;; So, the purpose is to guarantee a valid layout for
1449 ;; the FUNDAMENTAL-STREAM class, matching what
1450 ;; ORDER-LAYOUT-INHERITS would do.
1451 ;; ORDER-LAYOUT-INHERITS would place STREAM at index 2
1452 ;; in the INHERITS(-VECTOR). Index 1 would not be
1453 ;; filled, so STREAM is duplicated there (as
1454 ;; ORDER-LAYOUTS-INHERITS would do). Maybe the
1455 ;; duplicate definition could be removed (removing a
1456 ;; STREAM element), because FUNDAMENTAL-STREAM is
1457 ;; redefined after PCL is set up, anyway. But to play
1458 ;; it safely, we define the class with a valid INHERITS
1460 (fundamental-stream (t stream stream))))
1461 (/show0 "defining temporary STANDARD-CLASS")
1462 (let* ((name (first x))
1463 (inherits-list (second x))
1464 (classoid (make-standard-classoid :name name))
1465 (classoid-cell (find-classoid-cell name :create t)))
1466 ;; Needed to open-code the MAP, below
1467 (declare (type list inherits-list))
1468 (setf (classoid-cell-classoid classoid-cell) classoid
1469 (info :type :kind name) :instance)
1470 (let ((inherits (map 'simple-vector
1472 (classoid-layout (find-classoid x)))
1474 #-sb-xc-host (/show0 "INHERITS=..") #-sb-xc-host (/hexstr inherits)
1475 (register-layout (find-and-init-or-check-layout name 0 inherits -1 0)
1477 (/show0 "done defining temporary STANDARD-CLASSes"))
1479 ;;; Now that we have set up the class heterarchy, seal the sealed
1480 ;;; classes. This must be done after the subclasses have been set up.
1482 (dolist (x *built-in-classes*)
1483 (destructuring-bind (name &key (state :sealed) &allow-other-keys) x
1484 (setf (classoid-state (find-classoid name)) state))))
1486 ;;;; class definition/redefinition
1488 ;;; This is to be called whenever we are altering a class.
1489 (defun %modify-classoid (classoid)
1491 (when (member (classoid-state classoid) '(:read-only :frozen))
1492 ;; FIXME: This should probably be CERROR.
1493 (warn "making ~(~A~) class ~S writable"
1494 (classoid-state classoid)
1495 (classoid-name classoid))
1496 (setf (classoid-state classoid) nil)))
1498 ;;; Mark LAYOUT as invalid. Setting DEPTHOID -1 helps cause unsafe
1499 ;;; structure type tests to fail. Remove class from all superclasses
1500 ;;; too (might not be registered, so might not be in subclasses of the
1501 ;;; nominal superclasses.) We set the layout-clos-hash slots to 0 to
1502 ;;; invalidate the wrappers for specialized dispatch functions, which
1503 ;;; use those slots as indexes into tables.
1504 (defun %invalidate-layout (layout)
1505 (declare (type layout layout))
1506 (setf (layout-invalid layout) t
1507 (layout-depthoid layout) -1)
1508 (setf (layout-clos-hash layout) 0)
1509 (let ((inherits (layout-inherits layout))
1510 (classoid (layout-classoid layout)))
1511 (%modify-classoid classoid)
1512 (dovector (super inherits)
1513 (let ((subs (classoid-subclasses (layout-classoid super))))
1515 (remhash classoid subs)))))
1518 ;;;; cold loading initializations
1520 ;;; FIXME: It would be good to arrange for this to be called when the
1521 ;;; cross-compiler is being built, not just when the target Lisp is
1522 ;;; being cold loaded. Perhaps this could be moved to its own file
1523 ;;; late in the build-order.lisp-expr sequence, and be put in
1524 ;;; !COLD-INIT-FORMS there?
1525 (defun !class-finalize ()
1526 (dohash ((name layout) *forward-referenced-layouts*)
1527 (let ((class (find-classoid name nil)))
1529 (setf (layout-classoid layout) (make-undefined-classoid name)))
1530 ((eq (classoid-layout class) layout)
1531 (remhash name *forward-referenced-layouts*))
1533 (error "Something strange with forward layout for ~S:~% ~S"
1537 #-sb-xc-host (/show0 "about to set *BUILT-IN-CLASS-CODES*")
1538 (setq *built-in-class-codes*
1539 (let* ((initial-element
1541 ;; KLUDGE: There's a FIND-CLASSOID DEFTRANSFORM for
1542 ;; constant class names which creates fast but
1543 ;; non-cold-loadable, non-compact code. In this
1544 ;; context, we'd rather have compact, cold-loadable
1545 ;; code. -- WHN 19990928
1546 (declare (notinline find-classoid))
1547 (classoid-layout (find-classoid 'random-class))))
1548 (res (make-array 256 :initial-element initial-element)))
1549 (dolist (x *built-in-classes* res)
1550 (destructuring-bind (name &key codes &allow-other-keys)
1552 (let ((layout (classoid-layout (find-classoid name))))
1553 (dolist (code codes)
1554 (setf (svref res code) layout)))))))
1555 (setq *null-classoid-layout*
1556 ;; KLUDGE: we use (LET () ...) instead of a LOCALLY here to
1557 ;; work around a bug in the LOCALLY handling in the fopcompiler
1558 ;; (present in 0.9.13-0.9.14.18). -- JES, 2006-07-16
1560 (declare (notinline find-classoid))
1561 (classoid-layout (find-classoid 'null))))
1562 #-sb-xc-host (/show0 "done setting *BUILT-IN-CLASS-CODES*"))
1564 (!defun-from-collected-cold-init-forms !classes-cold-init)