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