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