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