;;;; This file contains structures and functions for the maintenance of
;;;; basic information about defined types. Different object systems
-;;;; can be supported simultaneously. Some of the functions here are
-;;;; nominally generic, and are overwritten when CLOS is loaded.
+;;;; can be supported simultaneously.
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
(!begin-collecting-cold-init-forms)
\f
-;;;; the CLASS structure
+;;;; the CLASSOID structure
-;;; The CLASS structure is a supertype of all class types. A CLASS is
-;;; also a CTYPE structure as recognized by the type system.
-(def!struct (;; FIXME: Yes, these #+SB-XC/#-SB-XC conditionals are
- ;; pretty hairy. I'm considering cleaner ways to rewrite
- ;; the whole build system to avoid these (and other hacks
- ;; too, e.g. UNCROSS) but I'm not sure yet that I've got
- ;; it figured out. -- WHN 19990729
- #-sb-xc sb!xc:class
- #+sb-xc cl:class
- (:make-load-form-fun class-make-load-form-fun)
+;;; The CLASSOID structure is a supertype of all classoid types. A
+;;; CLASSOID is also a CTYPE structure as recognized by the type
+;;; system. (FIXME: It's also a type specifier, though this might go
+;;; away as with the merger of SB-PCL:CLASS and CL:CLASS it's no
+;;; longer necessary)
+(def!struct (classoid
+ (:make-load-form-fun classoid-make-load-form-fun)
(:include ctype
- (:class-info (type-class-or-lose #-sb-xc 'sb!xc:class
- #+sb-xc 'cl:class)))
+ (class-info (type-class-or-lose 'classoid)))
(:constructor nil)
#-no-ansi-print-object
(:print-object
(lambda (class stream)
- (let ((name (sb!xc:class-name class)))
+ (let ((name (classoid-name class)))
(print-unreadable-object (class stream
:type t
:identity (not name))
;; reasonably for anonymous classes.
"~:[anonymous~;~:*~S~]~@[ (~(~A~))~]"
name
- (class-state class))))))
+ (classoid-state class))))))
#-sb-xc-host (:pure nil))
- ;; the value to be returned by CLASS-NAME. (CMU CL used the raw slot
- ;; accessor for this slot directly as the definition of
- ;; CL:CLASS-NAME, but that was slightly wrong, because ANSI says
- ;; that CL:CLASS-NAME is a generic function.)
- (%name nil :type symbol)
+ ;; the value to be returned by CLASSOID-NAME.
+ (name nil :type symbol)
;; the current layout for this class, or NIL if none assigned yet
- (layout nil :type (or sb!kernel::layout null))
+ (layout nil :type (or layout null))
;; How sure are we that this class won't be redefined?
;; :READ-ONLY = We are committed to not changing the effective
;; slots or superclasses.
(direct-superclasses () :type list)
;; representation of all of the subclasses (direct or indirect) of
;; this class. This is NIL if no subclasses or not initalized yet;
- ;; otherwise, it's an EQ hash-table mapping CL:CLASS objects to the
+ ;; otherwise, it's an EQ hash-table mapping CLASSOID objects to the
;; subclass layout that was in effect at the time the subclass was
;; created.
(subclasses nil :type (or null hash-table))
- ;; the PCL class object for this class, or NIL if none assigned yet
+ ;; the PCL class (= CL:CLASS, but with a view to future flexibility
+ ;; we don't just call it the CLASS slot) object for this class, or
+ ;; NIL if none assigned yet
(pcl-class nil))
-;;; KLUDGE: ANSI says this is a generic function, but we need it for
-;;; bootstrapping before CLOS exists, so we define it as an ordinary
-;;; function and let CLOS code overwrite it later. -- WHN ca. 19990815
-(defun sb!xc:class-name (class)
- (class-%name class))
-
-(defun class-make-load-form-fun (class)
- (/show "entering CLASS-MAKE-LOAD-FORM-FUN" class)
- (let ((name (sb!xc:class-name class)))
- (unless (and name (eq (sb!xc:find-class name nil) class))
+(defun classoid-make-load-form-fun (class)
+ (/show "entering CLASSOID-MAKE-LOAD-FORM-FUN" class)
+ (let ((name (classoid-name class)))
+ (unless (and name (eq (find-classoid name nil) class))
(/show "anonymous/undefined class case")
(error "can't use anonymous or undefined class as constant:~% ~S"
class))
`(locally
- ;; KLUDGE: There's a FIND-CLASS DEFTRANSFORM for constant class
- ;; names which creates fast but non-cold-loadable, non-compact
- ;; code. In this context, we'd rather have compact,
+ ;; KLUDGE: There's a FIND-CLASSOID DEFTRANSFORM for constant
+ ;; class names which creates fast but non-cold-loadable,
+ ;; non-compact code. In this context, we'd rather have compact,
;; cold-loadable code. -- WHN 19990928
- (declare (notinline sb!xc:find-class))
- (sb!xc:find-class ',name))))
+ (declare (notinline find-classoid))
+ (find-classoid ',name))))
\f
;;;; basic LAYOUT stuff
;;; Note: This bound is set somewhat less than MOST-POSITIVE-FIXNUM
;;; in order to guarantee that several hash values can be added without
;;; overflowing into a bignum.
-(defconstant layout-clos-hash-max (ash most-positive-fixnum -3)
+(def!constant layout-clos-hash-max (ash most-positive-fixnum -3)
#!+sb-doc
"the inclusive upper bound on LAYOUT-CLOS-HASH values")
(clos-hash-6 (random-layout-clos-hash) :type index)
(clos-hash-7 (random-layout-clos-hash) :type index)
;; the class that this is a layout for
- (class (missing-arg)
- ;; FIXME: Do we really know this is a CL:CLASS? Mightn't it
- ;; be a SB-PCL:CLASS under some circumstances? What goes here
- ;; when the LAYOUT is in fact a PCL::WRAPPER?
- :type #-sb-xc sb!xc:class #+sb-xc cl:class)
+ (classoid (missing-arg) :type classoid)
;; The value of this slot can be:
;; * :UNINITIALIZED if not initialized yet;
;; * NIL if this is the up-to-date layout for a class; or
(layout-proper-name layout)
(layout-invalid layout))))
-(eval-when (:compile-toplevel :load-toplevel :execute)
+(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
(defun layout-proper-name (layout)
- (class-proper-name (layout-class layout))))
+ (classoid-proper-name (layout-classoid layout))))
\f
;;;; support for the hash values used by CLOS when working with LAYOUTs
-(defconstant layout-clos-hash-length 8)
+(def!constant layout-clos-hash-length 8)
#!-sb-fluid (declaim (inline layout-clos-hash))
(defun layout-clos-hash (layout i)
;; FIXME: Either this I should be declared to be `(MOD
;;; been split off into INIT-OR-CHECK-LAYOUT.
(declaim (ftype (function (symbol) layout) find-layout))
(defun find-layout (name)
- (let ((class (sb!xc:find-class name nil)))
- (or (and class (class-layout class))
+ (let ((classoid (find-classoid name nil)))
+ (or (and classoid (classoid-layout classoid))
(gethash name *forward-referenced-layouts*)
(setf (gethash name *forward-referenced-layouts*)
- (make-layout :class (or class (make-undefined-class name)))))))
+ (make-layout :classoid (or classoid
+ (make-undefined-classoid name)))))))
-;;; If LAYOUT is uninitialized, initialize it with CLASS, LENGTH,
+;;; If LAYOUT is uninitialized, initialize it with CLASSOID, LENGTH,
;;; INHERITS, and DEPTHOID, otherwise require that it be consistent
-;;; with CLASS, LENGTH, INHERITS, and DEPTHOID.
+;;; with CLASSOID, LENGTH, INHERITS, and DEPTHOID.
;;;
;;; UNDEFINED-CLASS values are interpreted specially as "we don't know
;;; anything about the class", so if LAYOUT is initialized, any
;;; preexisting class slot value is OK, and if it's not initialized,
;;; its class slot value is set to an UNDEFINED-CLASS. -- FIXME: This
;;; is no longer true, :UNINITIALIZED used instead.
-(declaim (ftype (function (layout sb!xc:class index simple-vector layout-depthoid) layout)
+(declaim (ftype (function (layout classoid index simple-vector layout-depthoid)
+ layout)
init-or-check-layout))
-(defun init-or-check-layout (layout class length inherits depthoid)
+(defun init-or-check-layout (layout classoid length inherits depthoid)
(cond ((eq (layout-invalid layout) :uninitialized)
;; There was no layout before, we just created one which
;; we'll now initialize with our information.
(setf (layout-length layout) length
(layout-inherits layout) inherits
(layout-depthoid layout) depthoid
- (layout-class layout) class
+ (layout-classoid layout) classoid
(layout-invalid layout) nil))
;; FIXME: Now that LAYOUTs are born :UNINITIALIZED, maybe this
;; clause is not needed?
((not *type-system-initialized*)
- (setf (layout-class layout) class))
+ (setf (layout-classoid layout) classoid))
(t
;; There was an old layout already initialized with old
;; information, and we'll now check that old information
;; which was known with certainty is consistent with current
;; information which is known with certainty.
- (check-layout layout class length inherits depthoid)))
+ (check-layout layout classoid length inherits depthoid)))
layout)
;;; In code for the target Lisp, we don't use dump LAYOUTs using the
(declare (ignore env))
(when (layout-invalid layout)
(compiler-error "can't dump reference to obsolete class: ~S"
- (layout-class layout)))
- (let ((name (sb!xc:class-name (layout-class layout))))
+ (layout-classoid layout)))
+ (let ((name (classoid-name (layout-classoid layout))))
(unless name
(compiler-error "can't dump anonymous LAYOUT: ~S" layout))
;; Since LAYOUT refers to a class which refers back to the LAYOUT,
;; "initialization" form (which actually doesn't initialize
;; preexisting LAYOUTs, just checks that they're consistent).
`(init-or-check-layout ',layout
- ',(layout-class layout)
+ ',(layout-classoid layout)
',(layout-length layout)
',(layout-inherits layout)
',(layout-depthoid layout)))))
;;; Require that LAYOUT data be consistent with CLASS, LENGTH,
;;; INHERITS, and DEPTHOID.
-(declaim (ftype (function (layout sb!xc:class index simple-vector layout-depthoid))
+(declaim (ftype (function
+ (layout classoid index simple-vector layout-depthoid))
check-layout))
-(defun check-layout (layout class length inherits depthoid)
- (aver (eq (layout-class layout) class))
+(defun check-layout (layout classoid length inherits depthoid)
+ (aver (eq (layout-classoid layout) classoid))
(when (redefine-layout-warning "current" layout
"compile time" length inherits depthoid)
;; Classic CMU CL had more options here. There are several reasons
(defun find-and-init-or-check-layout (name length inherits depthoid)
(let ((layout (find-layout name)))
(init-or-check-layout layout
- (or (sb!xc:find-class name nil)
- (make-undefined-class name))
+ (or (find-classoid name nil)
+ (make-undefined-classoid name))
length
inherits
depthoid)))
(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
(defun register-layout (layout &key (invalidate t) destruct-layout)
(declare (type layout layout) (type (or layout null) destruct-layout))
- (let* ((class (layout-class layout))
- (class-layout (class-layout class))
- (subclasses (class-subclasses class)))
+ (let* ((classoid (layout-classoid layout))
+ (classoid-layout (classoid-layout classoid))
+ (subclasses (classoid-subclasses classoid)))
;; Attempting to register ourselves with a temporary undefined
;; class placeholder is almost certainly a programmer error. (I
;; should know, I did it.) -- WHN 19990927
- (aver (not (undefined-class-p class)))
+ (aver (not (undefined-classoid-p classoid)))
;; This assertion dates from classic CMU CL. The rationale is
;; probably that calling REGISTER-LAYOUT more than once for the
;; same LAYOUT is almost certainly a programmer error.
- (aver (not (eq class-layout layout)))
+ (aver (not (eq classoid-layout layout)))
;; Figure out what classes are affected by the change, and issue
;; appropriate warnings and invalidations.
- (when class-layout
- (modify-class class)
+ (when classoid-layout
+ (modify-classoid classoid)
(when subclasses
(dohash (subclass subclass-layout subclasses)
- (modify-class subclass)
+ (modify-classoid subclass)
(when invalidate
(invalidate-layout subclass-layout))))
(when invalidate
- (invalidate-layout class-layout)
- (setf (class-subclasses class) nil)))
+ (invalidate-layout classoid-layout)
+ (setf (classoid-subclasses classoid) nil)))
(if destruct-layout
(setf (layout-invalid destruct-layout) nil
(layout-depthoid destruct-layout)(layout-depthoid layout)
(layout-length destruct-layout) (layout-length layout)
(layout-info destruct-layout) (layout-info layout)
- (class-layout class) destruct-layout)
+ (classoid-layout classoid) destruct-layout)
(setf (layout-invalid layout) nil
- (class-layout class) layout))
+ (classoid-layout classoid) layout))
(let ((inherits (layout-inherits layout)))
(dotimes (i (length inherits)) ; FIXME: should be DOVECTOR
- (let* ((super (layout-class (svref inherits i)))
- (subclasses (or (class-subclasses super)
- (setf (class-subclasses super)
+ (let* ((super (layout-classoid (svref inherits i)))
+ (subclasses (or (classoid-subclasses super)
+ (setf (classoid-subclasses super)
(make-hash-table :test 'eq)))))
- (when (and (eq (class-state super) :sealed)
- (not (gethash class subclasses)))
+ (when (and (eq (classoid-state super) :sealed)
+ (not (gethash classoid subclasses)))
(warn "unsealing sealed class ~S in order to subclass it"
- (sb!xc:class-name super))
- (setf (class-state super) :read-only))
- (setf (gethash class subclasses)
+ (classoid-name super))
+ (setf (classoid-state super) :read-only))
+ (setf (gethash classoid subclasses)
(or destruct-layout layout))))))
(values))
(when (> depth max-depth)
(setf max-depth depth))))
(let* ((new-length (max (1+ max-depth) length))
- (inherits (make-array new-length)))
+ ;; KLUDGE: 0 here is the "uninitialized" element. We need
+ ;; to specify it explicitly for portability purposes, as
+ ;; elements can be read before being set [ see below, "(EQL
+ ;; OLD-LAYOUT 0)" ]. -- CSR, 2002-04-20
+ (inherits (make-array new-length :initial-element 0)))
(dotimes (i length)
(let* ((layout (svref layouts i))
(depth (layout-depthoid layout)))
(labels ((note-class (class)
(unless (member class classes)
(push class classes)
- (let ((superclasses (class-direct-superclasses class)))
+ (let ((superclasses (classoid-direct-superclasses class)))
(do ((prev class)
(rest superclasses (rest rest)))
((endp rest))
(note-class class)))))
(std-cpl-tie-breaker (free-classes rev-cpl)
(dolist (class rev-cpl (first free-classes))
- (let* ((superclasses (class-direct-superclasses class))
+ (let* ((superclasses (classoid-direct-superclasses class))
(intersection (intersection free-classes
superclasses)))
(when intersection
\f
;;;; object types to represent classes
-;;; An UNDEFINED-CLASS is a cookie we make up to stick in forward
+;;; An UNDEFINED-CLASSOID is a cookie we make up to stick in forward
;;; referenced layouts. Users should never see them.
-(def!struct (undefined-class (:include #-sb-xc sb!xc:class
- #+sb-xc cl:class)
- (:constructor make-undefined-class (%name))))
+(def!struct (undefined-classoid
+ (:include classoid)
+ (:constructor make-undefined-classoid (name))))
;;; BUILT-IN-CLASS is used to represent the standard classes that
;;; aren't defined with DEFSTRUCT and other specially implemented
;;; This translation is done when type specifiers are parsed. Type
;;; system operations (union, subtypep, etc.) should never encounter
;;; translated classes, only their translation.
-(def!struct (sb!xc:built-in-class (:include #-sb-xc sb!xc:class
- #+sb-xc cl:class)
- (:constructor bare-make-built-in-class))
+(def!struct (built-in-classoid (:include classoid)
+ (:constructor make-built-in-classoid))
;; the type we translate to on parsing. If NIL, then this class
;; stands on its own; or it can be set to :INITIALIZING for a period
;; during cold-load.
(translation nil :type (or ctype (member nil :initializing))))
-(defun make-built-in-class (&rest rest)
- (apply #'bare-make-built-in-class
- (rename-key-args '((:name :%name)) rest)))
;;; FIXME: In CMU CL, this was a class with a print function, but not
;;; necessarily a structure class (e.g. CONDITIONs). In SBCL,
;;; we let CLOS handle our print functions, so that is no longer needed.
;;; Is there any need for this class any more?
-(def!struct (slot-class (:include #-sb-xc sb!xc:class #+sb-xc cl:class)
- (:constructor nil)))
+(def!struct (slot-classoid (:include classoid)
+ (:constructor nil)))
;;; STRUCTURE-CLASS represents what we need to know about structure
;;; classes. Non-structure "typed" defstructs are a special case, and
;;; don't have a corresponding class.
-(def!struct (basic-structure-class (:include slot-class)
- (:constructor nil)))
+(def!struct (basic-structure-classoid (:include slot-classoid)
+ (:constructor nil)))
-(def!struct (sb!xc:structure-class (:include basic-structure-class)
- (:constructor bare-make-structure-class))
+(def!struct (structure-classoid (:include basic-structure-classoid)
+ (:constructor make-structure-classoid))
;; If true, a default keyword constructor for this structure.
(constructor nil :type (or function null)))
-(defun make-structure-class (&rest rest)
- (apply #'bare-make-structure-class
- (rename-key-args '((:name :%name)) rest)))
;;; FUNCALLABLE-STRUCTURE-CLASS is used to represent funcallable
;;; structures, which are used to implement generic functions.
-(def!struct (funcallable-structure-class (:include basic-structure-class)
- (:constructor bare-make-funcallable-structure-class)))
-(defun make-funcallable-structure-class (&rest rest)
- (apply #'bare-make-funcallable-structure-class
- (rename-key-args '((:name :%name)) rest)))
+(def!struct (funcallable-structure-classoid
+ (:include basic-structure-classoid)
+ (:constructor make-funcallable-structure-classoid)))
\f
-;;;; class namespace
+;;;; classoid namespace
;;; We use an indirection to allow forward referencing of class
;;; definitions with load-time resolution.
-(def!struct (class-cell
- (:constructor make-class-cell (name &optional class))
+(def!struct (classoid-cell
+ (:constructor make-classoid-cell (name &optional classoid))
(:make-load-form-fun (lambda (c)
- `(find-class-cell ',(class-cell-name c))))
+ `(find-classoid-cell
+ ',(classoid-cell-name c))))
#-no-ansi-print-object
(:print-object (lambda (s stream)
(print-unreadable-object (s stream :type t)
- (prin1 (class-cell-name s) stream)))))
+ (prin1 (classoid-cell-name s) stream)))))
;; Name of class we expect to find.
(name nil :type symbol :read-only t)
;; Class or NIL if not yet defined.
- (class nil :type (or #-sb-xc sb!xc:class #+sb-xc cl:class
- null)))
-(defun find-class-cell (name)
- (or (info :type :class name)
- (setf (info :type :class name)
- (make-class-cell name))))
+ (classoid nil :type (or classoid null)))
+(defun find-classoid-cell (name)
+ (or (info :type :classoid name)
+ (setf (info :type :classoid name)
+ (make-classoid-cell name))))
-;;; FIXME: When the system is stable, this DECLAIM FTYPE should
-;;; probably go away in favor of the DEFKNOWN for FIND-CLASS.
-(declaim (ftype (function (symbol &optional t (or null sb!c::lexenv))) sb!xc:find-class))
(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
-(defun sb!xc:find-class (name &optional (errorp t) environment)
+(defun find-classoid (name &optional (errorp t) environment)
#!+sb-doc
"Return the class with the specified NAME. If ERRORP is false, then NIL is
returned when no such class exists."
(declare (type symbol name) (ignore environment))
- (let ((res (class-cell-class (find-class-cell name))))
+ (let ((res (classoid-cell-classoid (find-classoid-cell name))))
(if (or res (not errorp))
res
(error "class not yet defined:~% ~S" name))))
-(defun (setf sb!xc:find-class) (new-value name)
- #-sb-xc (declare (type sb!xc:class new-value))
- (ecase (info :type :kind name)
- ((nil))
- (:instance
- (let ((old (class-of (sb!xc:find-class name)))
- (new (class-of new-value)))
- (unless (eq old new)
- (warn "changing meta-class of ~S from ~S to ~S"
- name
- (class-name old)
- (class-name new)))))
- (:primitive
- (error "illegal to redefine standard type ~S" name))
- (:defined
- (warn "redefining DEFTYPE type to be a class: ~S" name)
- (setf (info :type :expander name) nil)))
+(defun (setf find-classoid) (new-value name)
+ #-sb-xc (declare (type (or null classoid) new-value))
+ (cond
+ ((null new-value)
+ (ecase (info :type :kind name)
+ ((nil))
+ (:defined)
+ (:primitive
+ (error "attempt to redefine :PRIMITIVE type: ~S" name))
+ ((:forthcoming-defclass-type :instance)
+ (setf (info :type :kind name) nil
+ (info :type :classoid name) nil
+ (info :type :documentation name) nil
+ (info :type :compiler-layout name) nil))))
+ (t
+ (ecase (info :type :kind name)
+ ((nil))
+ (:forthcoming-defclass-type
+ ;; XXX Currently, nothing needs to be done in this
+ ;; case. Later, when PCL is integrated tighter into SBCL, this
+ ;; might need more work.
+ nil)
+ (:instance
+ ;; KLUDGE: The reason these clauses aren't directly parallel
+ ;; is that we need to use the internal CLASSOID structure
+ ;; ourselves, because we don't have CLASSes to work with until
+ ;; PCL is built. In the host, CLASSes have an approximately
+ ;; one-to-one correspondence with the target CLASSOIDs (as
+ ;; well as with the target CLASSes, modulo potential
+ ;; differences with respect to conditions).
+ #+sb-xc-host
+ (let ((old (class-of (find-classoid name)))
+ (new (class-of new-value)))
+ (unless (eq old new)
+ (bug "trying to change the metaclass of ~S from ~S to ~S in the ~
+ cross-compiler."
+ name (class-name old) (class-name new))))
+ #-sb-xc-host
+ (let ((old (classoid-of (find-classoid name)))
+ (new (classoid-of new-value)))
+ (unless (eq old new)
+ (warn "changing meta-class of ~S from ~S to ~S"
+ name (classoid-name old) (classoid-name new)))))
+ (:primitive
+ (error "illegal to redefine standard type ~S" name))
+ (:defined
+ (warn "redefining DEFTYPE type to be a class: ~S" name)
+ (setf (info :type :expander name) nil)))
- (remhash name *forward-referenced-layouts*)
- (%note-type-defined name)
- (setf (info :type :kind name) :instance)
- (setf (class-cell-class (find-class-cell name)) new-value)
- (unless (eq (info :type :compiler-layout name)
- (class-layout new-value))
- (setf (info :type :compiler-layout name) (class-layout new-value)))
+ (remhash name *forward-referenced-layouts*)
+ (%note-type-defined name)
+ (setf (info :type :kind name) :instance)
+ (setf (classoid-cell-classoid (find-classoid-cell name)) new-value)
+ (unless (eq (info :type :compiler-layout name)
+ (classoid-layout new-value))
+ (setf (info :type :compiler-layout name) (classoid-layout new-value)))))
new-value)
) ; EVAL-WHEN
-
+
;;; Called when we are about to define NAME as a class meeting some
;;; predicate (such as a meta-class type test.) The first result is
;;; always of the desired class. The second result is any existing
;;; LAYOUT for this name.
-(defun insured-find-class (name predicate constructor)
+(defun insured-find-classoid (name predicate constructor)
(declare (type function predicate constructor))
- (let* ((old (sb!xc:find-class name nil))
+ (let* ((old (find-classoid name nil))
(res (if (and old (funcall predicate old))
old
(funcall constructor :name name)))
(found (or (gethash name *forward-referenced-layouts*)
- (when old (class-layout old)))))
+ (when old (classoid-layout old)))))
(when found
- (setf (layout-class found) res))
+ (setf (layout-classoid found) res))
(values res found)))
;;; If the class has a proper name, return the name, otherwise return
;;; the class.
-(defun class-proper-name (class)
- #-sb-xc (declare (type sb!xc:class class))
- (let ((name (sb!xc:class-name class)))
- (if (and name (eq (sb!xc:find-class name nil) class))
+(defun classoid-proper-name (class)
+ #-sb-xc (declare (type classoid class))
+ (let ((name (classoid-name class)))
+ (if (and name (eq (find-classoid name nil) class))
name
class)))
\f
;;;; CLASS type operations
-(!define-type-class sb!xc:class)
+(!define-type-class classoid)
;;; Simple methods for TYPE= and SUBTYPEP should never be called when
;;; the two classes are equal, since there are EQ checks in those
;;; operations.
-(!define-type-method (sb!xc:class :simple-=) (type1 type2)
+(!define-type-method (classoid :simple-=) (type1 type2)
(aver (not (eq type1 type2)))
(values nil t))
-(!define-type-method (sb!xc:class :simple-subtypep) (class1 class2)
+(!define-type-method (classoid :simple-subtypep) (class1 class2)
(aver (not (eq class1 class2)))
- (let ((subclasses (class-subclasses class2)))
+ (let ((subclasses (classoid-subclasses class2)))
(if (and subclasses (gethash class1 subclasses))
(values t t)
(values nil t))))
;;; class (not hierarchically related) the intersection is the union
;;; of the currently shared subclasses.
(defun sealed-class-intersection2 (sealed other)
- (declare (type sb!xc:class sealed other))
- (let ((s-sub (class-subclasses sealed))
- (o-sub (class-subclasses other)))
+ (declare (type classoid sealed other))
+ (let ((s-sub (classoid-subclasses sealed))
+ (o-sub (classoid-subclasses other)))
(if (and s-sub o-sub)
(collect ((res *empty-type* type-union))
(dohash (subclass layout s-sub)
(res))
*empty-type*)))
-(!define-type-method (sb!xc:class :simple-intersection2) (class1 class2)
- (declare (type sb!xc:class class1 class2))
+(!define-type-method (classoid :simple-intersection2) (class1 class2)
+ (declare (type classoid class1 class2))
(cond ((eq class1 class2)
class1)
;; If one is a subclass of the other, then that is the
;; intersection.
- ((let ((subclasses (class-subclasses class2)))
+ ((let ((subclasses (classoid-subclasses class2)))
(and subclasses (gethash class1 subclasses)))
class1)
- ((let ((subclasses (class-subclasses class1)))
+ ((let ((subclasses (classoid-subclasses class1)))
(and subclasses (gethash class2 subclasses)))
class2)
;; Otherwise, we can't in general be sure that the
;; intersection is empty, since a subclass of both might be
;; defined. But we can eliminate it for some special cases.
- ((or (basic-structure-class-p class1)
- (basic-structure-class-p class2))
+ ((or (basic-structure-classoid-p class1)
+ (basic-structure-classoid-p class2))
;; No subclass of both can be defined.
*empty-type*)
- ((eq (class-state class1) :sealed)
+ ((eq (classoid-state class1) :sealed)
;; checking whether a subclass of both can be defined:
(sealed-class-intersection2 class1 class2))
- ((eq (class-state class2) :sealed)
+ ((eq (classoid-state class2) :sealed)
;; checking whether a subclass of both can be defined:
(sealed-class-intersection2 class2 class1))
(t
;; uncertain, since a subclass of both might be defined
nil)))
-(!define-type-method (sb!xc:class :unparse) (type)
- (class-proper-name type))
+;;; KLUDGE: we need this because of the need to represent
+;;; intersections of two classes, even when empty at a given time, as
+;;; uncanonicalized intersections because of the possibility of later
+;;; defining a subclass of both classes. The necessity for changing
+;;; the default return value from SUBTYPEP to NIL, T if no alternate
+;;; method is present comes about because, unlike the other places we
+;;; use INVOKE-COMPLEX-SUBTYPEP-ARG1-METHOD, in HAIRY methods and the
+;;; like, classes are in their own hierarchy with no possibility of
+;;; mixtures with other type classes.
+(!define-type-method (classoid :complex-subtypep-arg2) (type1 class2)
+ (if (and (intersection-type-p type1)
+ (> (count-if #'classoid-p (intersection-type-types type1)) 1))
+ (values nil nil)
+ (invoke-complex-subtypep-arg1-method type1 class2 nil t)))
+
+(!define-type-method (classoid :unparse) (type)
+ (classoid-proper-name type))
\f
;;;; PCL stuff
-(def!struct (std-class (:include sb!xc:class)
- (:constructor nil)))
-(def!struct (sb!xc:standard-class (:include std-class)
- (:constructor bare-make-standard-class)))
-(def!struct (random-pcl-class (:include std-class)
- (:constructor bare-make-random-pcl-class)))
-(defun make-standard-class (&rest rest)
- (apply #'bare-make-standard-class
- (rename-key-args '((:name :%name)) rest)))
-(defun make-random-pcl-class (&rest rest)
- (apply #'bare-make-random-pcl-class
- (rename-key-args '((:name :%name)) rest)))
+(def!struct (std-classoid (:include classoid)
+ (:constructor nil)))
+(def!struct (standard-classoid (:include std-classoid)
+ (:constructor make-standard-classoid)))
+(def!struct (random-pcl-classoid (:include std-classoid)
+ (:constructor make-random-pcl-classoid)))
\f
;;;; built-in classes
:inherits (function)
:state :read-only)
- ;; FIXME: Are COLLECTION and MUTABLE-COLLECTION used for anything
- ;; any more? COLLECTION is not defined in ANSI Common Lisp..
- (collection :hierarchical-p nil :state :read-only)
- (mutable-collection :state :read-only
- :inherits (collection))
- (generic-sequence :state :read-only
- :inherits (collection))
- (mutable-sequence :state :read-only
- :direct-superclasses (mutable-collection
- generic-sequence)
- :inherits (mutable-collection
- generic-sequence
- collection))
- (generic-array :state :read-only
- :inherits (mutable-sequence
- mutable-collection
- generic-sequence
- collection))
- (generic-vector :state :read-only
- :inherits (generic-array
- mutable-sequence mutable-collection
- generic-sequence collection))
+ (number :translation number)
+ (complex
+ :translation complex
+ :inherits (number)
+ :codes (#.sb!vm:complex-widetag))
+ (complex-single-float
+ :translation (complex single-float)
+ :inherits (complex number)
+ :codes (#.sb!vm:complex-single-float-widetag))
+ (complex-double-float
+ :translation (complex double-float)
+ :inherits (complex number)
+ :codes (#.sb!vm:complex-double-float-widetag))
+ #!+long-float
+ (complex-long-float
+ :translation (complex long-float)
+ :inherits (complex number)
+ :codes (#.sb!vm:complex-long-float-widetag))
+ (real :translation real :inherits (number))
+ (float
+ :translation float
+ :inherits (real number))
+ (single-float
+ :translation single-float
+ :inherits (float real number)
+ :codes (#.sb!vm:single-float-widetag))
+ (double-float
+ :translation double-float
+ :inherits (float real number)
+ :codes (#.sb!vm:double-float-widetag))
+ #!+long-float
+ (long-float
+ :translation long-float
+ :inherits (float real number)
+ :codes (#.sb!vm:long-float-widetag))
+ (rational
+ :translation rational
+ :inherits (real number))
+ (ratio
+ :translation (and rational (not integer))
+ :inherits (rational real number)
+ :codes (#.sb!vm:ratio-widetag))
+ (integer
+ :translation integer
+ :inherits (rational real number))
+ (fixnum
+ :translation (integer #.sb!xc:most-negative-fixnum
+ #.sb!xc:most-positive-fixnum)
+ :inherits (integer rational real number)
+ :codes (#.sb!vm:even-fixnum-lowtag #.sb!vm:odd-fixnum-lowtag))
+ (bignum
+ :translation (and integer (not fixnum))
+ :inherits (integer rational real number)
+ :codes (#.sb!vm:bignum-widetag))
+
(array :translation array :codes (#.sb!vm:complex-array-widetag)
- :inherits (generic-array mutable-sequence mutable-collection
- generic-sequence collection))
+ :hierarchical-p nil)
(simple-array
:translation simple-array :codes (#.sb!vm:simple-array-widetag)
- :inherits (array generic-array mutable-sequence mutable-collection
- generic-sequence collection))
+ :inherits (array))
(sequence
- :translation (or cons (member nil) vector)
- :inherits (mutable-sequence mutable-collection generic-sequence
- collection))
+ :translation (or cons (member nil) vector))
(vector
:translation vector :codes (#.sb!vm:complex-vector-widetag)
- :direct-superclasses (array sequence generic-vector)
- :inherits (array sequence generic-vector generic-array
- mutable-sequence mutable-collection generic-sequence
- collection))
+ :direct-superclasses (array sequence)
+ :inherits (array sequence))
(simple-vector
:translation simple-vector :codes (#.sb!vm:simple-vector-widetag)
:direct-superclasses (vector simple-array)
- :inherits (vector simple-array array
- sequence generic-vector generic-array
- mutable-sequence mutable-collection
- generic-sequence collection))
+ :inherits (vector simple-array array sequence))
(bit-vector
:translation bit-vector :codes (#.sb!vm:complex-bit-vector-widetag)
- :inherits (vector array sequence
- generic-vector generic-array mutable-sequence
- mutable-collection generic-sequence collection))
+ :inherits (vector array sequence))
(simple-bit-vector
:translation simple-bit-vector :codes (#.sb!vm:simple-bit-vector-widetag)
:direct-superclasses (bit-vector simple-array)
:inherits (bit-vector vector simple-array
- array sequence
- generic-vector generic-array mutable-sequence
- mutable-collection generic-sequence collection))
+ array sequence))
(simple-array-unsigned-byte-2
:translation (simple-array (unsigned-byte 2) (*))
:codes (#.sb!vm:simple-array-unsigned-byte-2-widetag)
:direct-superclasses (vector simple-array)
- :inherits (vector simple-array array sequence
- generic-vector generic-array mutable-sequence
- mutable-collection generic-sequence collection))
+ :inherits (vector simple-array array sequence))
(simple-array-unsigned-byte-4
:translation (simple-array (unsigned-byte 4) (*))
:codes (#.sb!vm:simple-array-unsigned-byte-4-widetag)
:direct-superclasses (vector simple-array)
- :inherits (vector simple-array array sequence
- generic-vector generic-array mutable-sequence
- mutable-collection generic-sequence collection))
+ :inherits (vector simple-array array sequence))
(simple-array-unsigned-byte-8
:translation (simple-array (unsigned-byte 8) (*))
:codes (#.sb!vm:simple-array-unsigned-byte-8-widetag)
:direct-superclasses (vector simple-array)
- :inherits (vector simple-array array sequence
- generic-vector generic-array mutable-sequence
- mutable-collection generic-sequence collection))
+ :inherits (vector simple-array array sequence))
(simple-array-unsigned-byte-16
- :translation (simple-array (unsigned-byte 16) (*))
- :codes (#.sb!vm:simple-array-unsigned-byte-16-widetag)
- :direct-superclasses (vector simple-array)
- :inherits (vector simple-array array sequence
- generic-vector generic-array mutable-sequence
- mutable-collection generic-sequence collection))
+ :translation (simple-array (unsigned-byte 16) (*))
+ :codes (#.sb!vm:simple-array-unsigned-byte-16-widetag)
+ :direct-superclasses (vector simple-array)
+ :inherits (vector simple-array array sequence))
(simple-array-unsigned-byte-32
- :translation (simple-array (unsigned-byte 32) (*))
- :codes (#.sb!vm:simple-array-unsigned-byte-32-widetag)
- :direct-superclasses (vector simple-array)
- :inherits (vector simple-array array sequence
- generic-vector generic-array mutable-sequence
- mutable-collection generic-sequence collection))
+ :translation (simple-array (unsigned-byte 32) (*))
+ :codes (#.sb!vm:simple-array-unsigned-byte-32-widetag)
+ :direct-superclasses (vector simple-array)
+ :inherits (vector simple-array array sequence))
(simple-array-signed-byte-8
- :translation (simple-array (signed-byte 8) (*))
- :codes (#.sb!vm:simple-array-signed-byte-8-widetag)
- :direct-superclasses (vector simple-array)
- :inherits (vector simple-array array sequence
- generic-vector generic-array mutable-sequence
- mutable-collection generic-sequence collection))
+ :translation (simple-array (signed-byte 8) (*))
+ :codes (#.sb!vm:simple-array-signed-byte-8-widetag)
+ :direct-superclasses (vector simple-array)
+ :inherits (vector simple-array array sequence))
(simple-array-signed-byte-16
- :translation (simple-array (signed-byte 16) (*))
- :codes (#.sb!vm:simple-array-signed-byte-16-widetag)
- :direct-superclasses (vector simple-array)
- :inherits (vector simple-array array sequence
- generic-vector generic-array mutable-sequence
- mutable-collection generic-sequence collection))
+ :translation (simple-array (signed-byte 16) (*))
+ :codes (#.sb!vm:simple-array-signed-byte-16-widetag)
+ :direct-superclasses (vector simple-array)
+ :inherits (vector simple-array array sequence))
(simple-array-signed-byte-30
- :translation (simple-array (signed-byte 30) (*))
- :codes (#.sb!vm:simple-array-signed-byte-30-widetag)
- :direct-superclasses (vector simple-array)
- :inherits (vector simple-array array sequence
- generic-vector generic-array mutable-sequence
- mutable-collection generic-sequence collection))
+ :translation (simple-array (signed-byte 30) (*))
+ :codes (#.sb!vm:simple-array-signed-byte-30-widetag)
+ :direct-superclasses (vector simple-array)
+ :inherits (vector simple-array array sequence))
(simple-array-signed-byte-32
- :translation (simple-array (signed-byte 32) (*))
- :codes (#.sb!vm:simple-array-signed-byte-32-widetag)
- :direct-superclasses (vector simple-array)
- :inherits (vector simple-array array sequence
- generic-vector generic-array mutable-sequence
- mutable-collection generic-sequence collection))
+ :translation (simple-array (signed-byte 32) (*))
+ :codes (#.sb!vm:simple-array-signed-byte-32-widetag)
+ :direct-superclasses (vector simple-array)
+ :inherits (vector simple-array array sequence))
(simple-array-single-float
- :translation (simple-array single-float (*))
- :codes (#.sb!vm:simple-array-single-float-widetag)
- :direct-superclasses (vector simple-array)
- :inherits (vector simple-array array sequence
- generic-vector generic-array mutable-sequence
- mutable-collection generic-sequence collection))
+ :translation (simple-array single-float (*))
+ :codes (#.sb!vm:simple-array-single-float-widetag)
+ :direct-superclasses (vector simple-array)
+ :inherits (vector simple-array array sequence))
(simple-array-double-float
- :translation (simple-array double-float (*))
- :codes (#.sb!vm:simple-array-double-float-widetag)
- :direct-superclasses (vector simple-array)
- :inherits (vector simple-array array sequence
- generic-vector generic-array mutable-sequence
- mutable-collection generic-sequence collection))
- #!+long-float
- (simple-array-long-float
- :translation (simple-array long-float (*))
- :codes (#.sb!vm:simple-array-long-float-widetag)
- :direct-superclasses (vector simple-array)
- :inherits (vector simple-array array sequence
- generic-vector generic-array mutable-sequence
- mutable-collection generic-sequence collection))
- (simple-array-complex-single-float
- :translation (simple-array (complex single-float) (*))
- :codes (#.sb!vm:simple-array-complex-single-float-widetag)
- :direct-superclasses (vector simple-array)
- :inherits (vector simple-array array sequence
- generic-vector generic-array mutable-sequence
- mutable-collection generic-sequence collection))
- (simple-array-complex-double-float
- :translation (simple-array (complex double-float) (*))
- :codes (#.sb!vm:simple-array-complex-double-float-widetag)
- :direct-superclasses (vector simple-array)
- :inherits (vector simple-array array sequence
- generic-vector generic-array mutable-sequence
- mutable-collection generic-sequence collection))
- #!+long-float
- (simple-array-complex-long-float
- :translation (simple-array (complex long-float) (*))
- :codes (#.sb!vm:simple-array-complex-long-float-widetag)
- :direct-superclasses (vector simple-array)
- :inherits (vector simple-array array sequence
- generic-vector generic-array mutable-sequence
- mutable-collection generic-sequence collection))
- (generic-string
- :state :read-only
- :inherits (mutable-sequence mutable-collection generic-sequence
- collection))
- (string
- :translation string
- :codes (#.sb!vm:complex-string-widetag)
- :direct-superclasses (vector generic-string)
- :inherits (vector array sequence
- generic-vector generic-array generic-string
- mutable-sequence mutable-collection
- generic-sequence collection))
- (simple-string
- :translation simple-string
- :codes (#.sb!vm:simple-string-widetag)
- :direct-superclasses (string simple-array)
- :inherits (string vector simple-array
- array sequence
- generic-string generic-vector generic-array mutable-sequence
- mutable-collection generic-sequence collection))
- (list
- :translation (or cons (member nil))
- :inherits (sequence mutable-sequence mutable-collection
- generic-sequence collection))
- (cons
- :codes (#.sb!vm:list-pointer-lowtag)
- :translation cons
- :inherits (list sequence
- mutable-sequence mutable-collection
- generic-sequence collection))
- (null
- :translation (member nil)
- :inherits (list sequence
- mutable-sequence mutable-collection
- generic-sequence collection symbol)
- :direct-superclasses (list symbol))
- (generic-number :state :read-only)
- (number :translation number :inherits (generic-number))
- (complex
- :translation complex
- :inherits (number generic-number)
- :codes (#.sb!vm:complex-widetag))
- (complex-single-float
- :translation (complex single-float)
- :inherits (complex number generic-number)
- :codes (#.sb!vm:complex-single-float-widetag))
- (complex-double-float
- :translation (complex double-float)
- :inherits (complex number generic-number)
- :codes (#.sb!vm:complex-double-float-widetag))
- #!+long-float
- (complex-long-float
- :translation (complex long-float)
- :inherits (complex number generic-number)
- :codes (#.sb!vm:complex-long-float-widetag))
- (real :translation real :inherits (number generic-number))
- (float
- :translation float
- :inherits (real number generic-number))
- (single-float
- :translation single-float
- :inherits (float real number generic-number)
- :codes (#.sb!vm:single-float-widetag))
- (double-float
- :translation double-float
- :inherits (float real number generic-number)
- :codes (#.sb!vm:double-float-widetag))
- #!+long-float
- (long-float
- :translation long-float
- :inherits (float real number generic-number)
- :codes (#.sb!vm:long-float-widetag))
- (rational
- :translation rational
- :inherits (real number generic-number))
- (ratio
- :translation (and rational (not integer))
- :inherits (rational real number generic-number)
- :codes (#.sb!vm:ratio-widetag))
- (integer
- :translation integer
- :inherits (rational real number generic-number))
- (fixnum
- :translation (integer #.sb!vm:*target-most-negative-fixnum*
- #.sb!vm:*target-most-positive-fixnum*)
- :inherits (integer rational real number
- generic-number)
- :codes (#.sb!vm:even-fixnum-lowtag #.sb!vm:odd-fixnum-lowtag))
- (bignum
- :translation (and integer (not fixnum))
- :inherits (integer rational real number
- generic-number)
- :codes (#.sb!vm:bignum-widetag))
- (stream
- :state :read-only
- :depth 3
- :inherits (instance)))))
+ :translation (simple-array double-float (*))
+ :codes (#.sb!vm:simple-array-double-float-widetag)
+ :direct-superclasses (vector simple-array)
+ :inherits (vector simple-array array sequence))
+ #!+long-float
+ (simple-array-long-float
+ :translation (simple-array long-float (*))
+ :codes (#.sb!vm:simple-array-long-float-widetag)
+ :direct-superclasses (vector simple-array)
+ :inherits (vector simple-array array sequence))
+ (simple-array-complex-single-float
+ :translation (simple-array (complex single-float) (*))
+ :codes (#.sb!vm:simple-array-complex-single-float-widetag)
+ :direct-superclasses (vector simple-array)
+ :inherits (vector simple-array array sequence))
+ (simple-array-complex-double-float
+ :translation (simple-array (complex double-float) (*))
+ :codes (#.sb!vm:simple-array-complex-double-float-widetag)
+ :direct-superclasses (vector simple-array)
+ :inherits (vector simple-array array sequence))
+ #!+long-float
+ (simple-array-complex-long-float
+ :translation (simple-array (complex long-float) (*))
+ :codes (#.sb!vm:simple-array-complex-long-float-widetag)
+ :direct-superclasses (vector simple-array)
+ :inherits (vector simple-array array sequence))
+ (string
+ :translation string
+ :direct-superclasses (vector)
+ :inherits (vector array sequence))
+ (simple-string
+ :translation simple-string
+ :direct-superclasses (string simple-array)
+ :inherits (string vector simple-array array sequence))
+ (vector-nil
+ ;; FIXME: Should this be (AND (VECTOR NIL) (NOT (SIMPLE-ARRAY NIL (*))))?
+ :translation (vector nil)
+ :codes (#.sb!vm:complex-vector-nil-widetag)
+ :direct-superclasses (string)
+ :inherits (string vector array sequence))
+ (simple-array-nil
+ :translation (simple-array nil (*))
+ :codes (#.sb!vm:simple-array-nil-widetag)
+ :direct-superclasses (vector-nil simple-string)
+ :inherits (vector-nil simple-string string vector simple-array array sequence))
+ (base-string
+ :translation base-string
+ :codes (#.sb!vm:complex-base-string-widetag)
+ :direct-superclasses (string)
+ :inherits (string vector array sequence))
+ (simple-base-string
+ :translation simple-base-string
+ :codes (#.sb!vm:simple-base-string-widetag)
+ :direct-superclasses (base-string simple-string)
+ :inherits (base-string simple-string string vector simple-array
+ array sequence))
+ (list
+ :translation (or cons (member nil))
+ :inherits (sequence))
+ (cons
+ :codes (#.sb!vm:list-pointer-lowtag)
+ :translation cons
+ :inherits (list sequence))
+ (null
+ :translation (member nil)
+ :inherits (symbol list sequence)
+ :direct-superclasses (symbol list))
+
+ (stream
+ :state :read-only
+ :depth 3
+ :inherits (instance)))))
-;;; comment from CMU CL:
-;;; See also type-init.lisp where we finish setting up the
-;;; translations for built-in types.
+;;; See also src/code/class-init.lisp where we finish setting up the
+;;; translations for built-in types.
(!cold-init-forms
(dolist (x *built-in-classes*)
#-sb-xc-host (/show0 "at head of loop over *BUILT-IN-CLASSES*")
(let ((inherits-list (if (eq name t)
()
(cons t (reverse inherits))))
- (class (make-built-in-class
- :enumerable enumerable
- :name name
- :translation (if trans-p :initializing nil)
- :direct-superclasses
- (if (eq name t)
- nil
- (mapcar #'sb!xc:find-class direct-superclasses)))))
- (setf (info :type :kind name) :primitive
- (class-cell-class (find-class-cell name)) class)
+ (classoid (make-built-in-classoid
+ :enumerable enumerable
+ :name name
+ :translation (if trans-p :initializing nil)
+ :direct-superclasses
+ (if (eq name t)
+ nil
+ (mapcar #'find-classoid direct-superclasses)))))
+ (setf (info :type :kind name) #+sb-xc-host :defined #-sb-xc-host :primitive
+ (classoid-cell-classoid (find-classoid-cell name)) classoid)
(unless trans-p
- (setf (info :type :builtin name) class))
+ (setf (info :type :builtin name) classoid))
(let* ((inherits-vector
(map 'simple-vector
(lambda (x)
(let ((super-layout
- (class-layout (sb!xc:find-class x))))
+ (classoid-layout (find-classoid x))))
(when (minusp (layout-depthoid super-layout))
(setf hierarchical-p nil))
super-layout))
(/show0 "defining temporary STANDARD-CLASS")
(let* ((name (first x))
(inherits-list (second x))
- (class (make-standard-class :name name))
- (class-cell (find-class-cell name)))
- (setf (class-cell-class class-cell) class
- (info :type :class name) class-cell
+ (classoid (make-standard-classoid :name name))
+ (classoid-cell (find-classoid-cell name)))
+ ;; Needed to open-code the MAP, below
+ (declare (type list inherits-list))
+ (setf (classoid-cell-classoid classoid-cell) classoid
+ (info :type :classoid name) classoid-cell
(info :type :kind name) :instance)
(let ((inherits (map 'simple-vector
(lambda (x)
- (class-layout (sb!xc:find-class x)))
+ (classoid-layout (find-classoid x)))
inherits-list)))
#-sb-xc-host (/show0 "INHERITS=..") #-sb-xc-host (/hexstr inherits)
(register-layout (find-and-init-or-check-layout name 0 inherits -1)
(!cold-init-forms
(dolist (x *built-in-classes*)
(destructuring-bind (name &key (state :sealed) &allow-other-keys) x
- (setf (class-state (sb!xc:find-class name)) state))))
+ (setf (classoid-state (find-classoid name)) state))))
\f
;;;; class definition/redefinition
;;; This is to be called whenever we are altering a class.
-(defun modify-class (class)
+(defun modify-classoid (classoid)
(clear-type-caches)
- (when (member (class-state class) '(:read-only :frozen))
+ (when (member (classoid-state classoid) '(:read-only :frozen))
;; FIXME: This should probably be CERROR.
(warn "making ~(~A~) class ~S writable"
- (class-state class)
- (sb!xc:class-name class))
- (setf (class-state class) nil)))
+ (classoid-state classoid)
+ (classoid-name classoid))
+ (setf (classoid-state classoid) nil)))
;;; Mark LAYOUT as invalid. Setting DEPTHOID -1 helps cause unsafe
;;; structure type tests to fail. Remove class from all superclasses
(setf (layout-invalid layout) t
(layout-depthoid layout) -1)
(let ((inherits (layout-inherits layout))
- (class (layout-class layout)))
- (modify-class class)
+ (classoid (layout-classoid layout)))
+ (modify-classoid classoid)
(dotimes (i (length inherits)) ; FIXME: DOVECTOR
(let* ((super (svref inherits i))
- (subs (class-subclasses (layout-class super))))
+ (subs (classoid-subclasses (layout-classoid super))))
(when subs
- (remhash class subs)))))
+ (remhash classoid subs)))))
(values))
\f
;;;; cold loading initializations
;;; !COLD-INIT-FORMS there?
(defun !class-finalize ()
(dohash (name layout *forward-referenced-layouts*)
- (let ((class (sb!xc:find-class name nil)))
+ (let ((class (find-classoid name nil)))
(cond ((not class)
- (setf (layout-class layout) (make-undefined-class name)))
- ((eq (class-layout class) layout)
+ (setf (layout-classoid layout) (make-undefined-classoid name)))
+ ((eq (classoid-layout class) layout)
(remhash name *forward-referenced-layouts*))
(t
;; FIXME: ERROR?
(setq *built-in-class-codes*
(let* ((initial-element
(locally
- ;; KLUDGE: There's a FIND-CLASS DEFTRANSFORM for
+ ;; KLUDGE: There's a FIND-CLASSOID DEFTRANSFORM for
;; constant class names which creates fast but
;; non-cold-loadable, non-compact code. In this
;; context, we'd rather have compact, cold-loadable
;; code. -- WHN 19990928
- (declare (notinline sb!xc:find-class))
- (class-layout (sb!xc:find-class 'random-class))))
+ (declare (notinline find-classoid))
+ (classoid-layout (find-classoid 'random-class))))
(res (make-array 256 :initial-element initial-element)))
(dolist (x *built-in-classes* res)
(destructuring-bind (name &key codes &allow-other-keys)
x
- (let ((layout (class-layout (sb!xc:find-class name))))
+ (let ((layout (classoid-layout (find-classoid name))))
(dolist (code codes)
(setf (svref res code) layout)))))))
#-sb-xc-host (/show0 "done setting *BUILT-IN-CLASS-CODES*"))