--- /dev/null
+** CONDITION-CLASS
+
+(find-class 'warning) gives an object of type STRUCTURE-CLASS.
+However, a WARNING is not a STRUCTURE-OBJECT, but a CONDITION-OBJECT,
+which contradicts the requirement that instances of STRUCTURE-CLASS be
+STRUCTURE-OBJECTs. Fix this, probably by teaching PCL about
+CONDITION-CLASS analogously to STRUCTURE-CLASS.
+
+** CLASS-PROTOTYPE
+
+(sb-pcl:class-prototype (find-class 'null)) yields something decidedly
+weird -- it has allocated a NULL thingy. This is easy to solve
+[&optional (proto nil protop)]; probably harder are the issues for
+e.g. BIGNUM, some strange array classes, and so on, particularly in
+their interaction with the cross-compiler dumper, should PCL ever be
+moved to the main build.
+
+** SB-KERNEL
+
+Now that CL:CLASS has turned into SB-KERNEL:CLASSOID, SB-PCL can
+use-package SB-KERNEL. This should have the pleasant effect of
+ridding us of a fair amount of package prefix noise.
+
+** SB-MOP
+
+Now that a CL:CLASS is a real CLOS class, it might be worth giving
+SB-PCL the SB-MOP nickname, since it now is in the region of
+conforming to AMOP.
+
"LAYOUT-PURE" "DSD-RAW-TYPE"
"DEFSTRUCT-DESCRIPTION" "UNDEFINE-STRUCTURE"
"DD-COPIER" "UNDEFINE-FUN-NAME" "DD-TYPE"
- "CLASS-STATE" "INSTANCE"
+ "CLASSOID-STATE" "INSTANCE"
"*TYPE-SYSTEM-INITIALIZED*" "FIND-LAYOUT"
"DSD-NAME" "%TYPEP" "DD-RAW-INDEX"
- "DD-NAME" "CLASS-SUBCLASSES"
- "CLASS-LAYOUT" "CLASS-%NAME"
+ "DD-NAME" "CLASSOID-SUBCLASSES"
+ "CLASSOID-LAYOUT" "CLASSOID-NAME"
"DD-RAW-LENGTH" "NOTE-NAME-DEFINED"
"%CODE-CODE-SIZE" "DD-SLOTS"
"%IMAGPART" "DSD-ACCESSOR-NAME"
"%CODE-DEBUG-INFO" "DSD-%NAME"
- "LAYOUT-CLASS" "LAYOUT-INVALID"
+ "LAYOUT-CLASSOID" "LAYOUT-INVALID"
"%SIMPLE-FUN-NAME" "DSD-TYPE" "%INSTANCEP"
"DEFSTRUCT-SLOT-DESCRIPTION" "%SIMPLE-FUN-ARGLIST"
"%SIMPLE-FUN-NEXT" "LAYOUT-CLOS-HASH-LENGTH" "DD-PREDICATE-NAME"
- "CLASS-PROPER-NAME" "%NOTE-TYPE-DEFINED" "LAYOUT-INFO"
+ "CLASSOID-PROPER-NAME" "%NOTE-TYPE-DEFINED" "LAYOUT-INFO"
"%SET-INSTANCE-LAYOUT" "DD-DEFAULT-CONSTRUCTOR"
"LAYOUT-OF" "%SIMPLE-FUN-SELF" "%REALPART"
- "STRUCTURE-CLASS-P" "DSD-INDEX"
+ "STRUCTURE-CLASSOID-P" "DSD-INDEX"
"%INSTANCE-LAYOUT" "LAYOUT-CLOS-HASH"
"%SIMPLE-FUN-TYPE" "PROCLAIM-AS-FUN-NAME"
"BECOME-DEFINED-FUN-NAME"
- "%NUMERATOR" "CLASS-TYPEP"
+ "%NUMERATOR" "CLASSOID-TYPEP"
"DSD-READ-ONLY"
"LAYOUT-INHERITS" "DD-LENGTH" "%CODE-ENTRY-POINTS"
"%DENOMINATOR"
- "MAKE-STANDARD-CLASS"
- "CLASS-CELL-TYPEP"
- "FIND-CLASS-CELL" "EXTRACT-FUN-TYPE"
- "FUNCALLABLE-STRUCTURE-CLASS"
+
+ "STANDARD-CLASSOID"
+ "CLASSOID-OF"
+ "MAKE-STANDARD-CLASSOID"
+ "CLASSOID-CELL-TYPEP"
+ "FIND-CLASSOID-CELL" "EXTRACT-FUN-TYPE"
+ "FUNCALLABLE-STRUCTURE-CLASSOID"
"%RANDOM-DOUBLE-FLOAT"
#!+long-float "%RANDOM-LONG-FLOAT"
"%RANDOM-SINGLE-FLOAT"
- "RANDOM-PCL-CLASS"
+ "RANDOM-PCL-CLASSOID"
"%FUNCALLABLE-INSTANCE-INFO" "RANDOM-CHUNK"
- "MAKE-FUNCALLABLE-STRUCTURE-CLASS" "LAYOUT-CLOS-HASH-MAX"
- "CLASS-CELL-NAME" "BUILT-IN-CLASS-DIRECT-SUPERCLASSES"
+ "MAKE-FUNCALLABLE-STRUCTURE-CLASSOID" "LAYOUT-CLOS-HASH-MAX"
+ "CLASSOID-CELL-NAME" "BUILT-IN-CLASSOID-DIRECT-SUPERCLASSES"
"RANDOM-LAYOUT-CLOS-HASH"
- "CLASS-PCL-CLASS" "FUNCALLABLE-STRUCTURE"
+ "CLASSOID-PCL-CLASS" "FUNCALLABLE-STRUCTURE"
"FUNCALLABLE-INSTANCE-FUN"
"%FUNCALLABLE-INSTANCE-LAYOUT"
- "BASIC-STRUCTURE-CLASS"
- "CLASS-CELL-CLASS"
- "FUNCALLABLE-STRUCTURE-CLASS-P" "REGISTER-LAYOUT"
+ "BASIC-STRUCTURE-CLASSOID"
+ "CLASSOID-CELL-CLASSOID"
+ "FUNCALLABLE-STRUCTURE-CLASSOID-P" "REGISTER-LAYOUT"
"FUNCALLABLE-INSTANCE" "RANDOM-FIXNUM-MAX"
- "MAKE-RANDOM-PCL-CLASS" "INSTANCE-LAMBDA"
+ "MAKE-RANDOM-PCL-CLASSOID" "INSTANCE-LAMBDA"
"%FUNCALLABLE-INSTANCE-LEXENV" "%MAKE-SYMBOL"
"%FUNCALLABLE-INSTANCE-FUN" "SYMBOL-HASH"
- "MAKE-UNDEFINED-CLASS" "CLASS-DIRECT-SUPERCLASSES" "MAKE-LAYOUT"
- "REDEFINE-LAYOUT-WARNING" "SLOT-CLASS"
- "INSURED-FIND-CLASS" "ORDER-LAYOUT-INHERITS"
+ "BUILT-IN-CLASSOID"
+ "MAKE-UNDEFINED-CLASSOID" "FIND-CLASSOID" "CLASSOID"
+ "CLASSOID-DIRECT-SUPERCLASSES" "MAKE-LAYOUT"
+ "REDEFINE-LAYOUT-WARNING" "SLOT-CLASSOID"
+ "INSURED-FIND-CLASSOID" "ORDER-LAYOUT-INHERITS"
"STD-COMPUTE-CLASS-PRECEDENCE-LIST"
;; symbols from former SB!CONDITIONS
;;; 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)
+(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 layout null))
;; How sure are we that this class won't be redefined?
;; the PCL class 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))
;; 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
(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
(eval-when (: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
;;; 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,
;;; INHERITS, and DEPTHOID, otherwise require that it be consistent
;;; 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))
(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))
+(declaim (ftype (function (symbol &optional t (or null sb!c::lexenv)))
+ find-classoid))
(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))
+(defun (setf find-classoid) (new-value name)
+ #-sb-xc (declare (type classoid new-value))
(ecase (info :type :kind name)
((nil))
(:forthcoming-defclass-type
;; PCL is integrated tighter into SBCL, this might need more work.
nil)
(:instance
- (let ((old (class-of (sb!xc:find-class name)))
- (new (class-of new-value)))
+ #-sb-xc-host ; FIXME
+ (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
- (class-name old)
- (class-name new)))))
+ (classoid-name old)
+ (classoid-name new)))))
(:primitive
(error "illegal to redefine standard type ~S" name))
(:defined
(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)
+ (setf (classoid-cell-classoid (find-classoid-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)))
+ (classoid-layout new-value))
+ (setf (info :type :compiler-layout name) (classoid-layout new-value)))
new-value)
) ; EVAL-WHEN
;;; 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
;;; 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 (sb!xc:class :complex-subtypep-arg2) (type1 class2)
+(!define-type-method (classoid :complex-subtypep-arg2) (type1 class2)
(if (and (intersection-type-p type1)
- (> (count-if #'class-p (intersection-type-types type1)) 1))
+ (> (count-if #'classoid-p (intersection-type-types type1)) 1))
(values nil nil)
(invoke-complex-subtypep-arg1-method type1 class2 nil t)))
-(!define-type-method (sb!xc:class :unparse) (type)
- (class-proper-name type))
+(!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
(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)))))
+ (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
- (class-cell-class (find-class-cell name)) class)
+ (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)))
+ (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 (class-cell-class class-cell) class
- (info :type :class name) class-cell
+ (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*"))
(/show0 "condition.lisp 24")
-(def!struct (condition-class (:include slot-class)
- (:constructor bare-make-condition-class))
+(def!struct (condition-classoid (:include slot-classoid)
+ (:constructor make-condition-classoid))
;; list of CONDITION-SLOT structures for the direct slots of this
;; class
(slots nil :type list)
(/show0 "condition.lisp 49")
-(defun make-condition-class (&rest rest)
- (apply #'bare-make-condition-class
- (rename-key-args '((:name :%name)) rest)))
-
-(/show0 "condition.lisp 53")
-
) ; EVAL-WHEN
(!defstruct-with-alternate-metaclass condition
:slot-names (actual-initargs assigned-slots)
:boa-constructor %make-condition-object
:superclass-name instance
- :metaclass-name condition-class
- :metaclass-constructor make-condition-class
+ :metaclass-name condition-classoid
+ :metaclass-constructor make-condition-classoid
:dd-type structure)
(defun make-condition-object (actual-initargs)
(eval-when (:compile-toplevel :load-toplevel :execute)
(/show0 "condition.lisp 103")
(let ((condition-class (locally
- ;; KLUDGE: There's a DEFTRANSFORM FIND-CLASS 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 'condition))))
- (setf (condition-class-cpl condition-class)
+ ;; KLUDGE: There's a DEFTRANSFORM
+ ;; FIND-CLASSOID 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 find-classoid))
+ (find-classoid 'condition))))
+ (setf (condition-classoid-cpl condition-class)
(list condition-class)))
(/show0 "condition.lisp 103"))
-(setf (condition-class-report (locally
- ;; KLUDGE: There's a DEFTRANSFORM FIND-CLASS
- ;; 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))
- (find-class 'condition)))
+(setf (condition-classoid-report (locally
+ ;; KLUDGE: There's a DEFTRANSFORM
+ ;; FIND-CLASSOID 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 find-classoid))
+ (find-classoid 'condition)))
(lambda (cond stream)
(format stream "Condition ~S was signalled." (type-of cond))))
(reverse
(reduce #'append
(mapcar (lambda (x)
- (condition-class-cpl
- (sb!xc:find-class x)))
+ (condition-classoid-cpl
+ (find-classoid x)))
parent-types)))))
(cond-layout (info :type :compiler-layout 'condition))
(olayout (info :type :compiler-layout name))
(new-inherits
(order-layout-inherits (concatenate 'simple-vector
(layout-inherits cond-layout)
- (mapcar #'class-layout cpl)))))
+ (mapcar #'classoid-layout cpl)))))
(if (and olayout
(not (mismatch (layout-inherits olayout) new-inherits)))
olayout
- (make-layout :class (make-undefined-class name)
+ (make-layout :classoid (make-undefined-classoid name)
:inherits new-inherits
:depthoid -1
:length (layout-length cond-layout)))))
;; KLUDGE: A comment from CMU CL here said
;; 7/13/98 BUG? CPL is not sorted and results here depend on order of
;; superclasses in define-condition call!
- (dolist (class (condition-class-cpl (sb!xc:class-of x))
+ (dolist (class (condition-classoid-cpl (classoid-of x))
(error "no REPORT? shouldn't happen!"))
- (let ((report (condition-class-report class)))
+ (let ((report (condition-classoid-report class)))
(when report
(return (funcall report x stream)))))))
\f
(defun find-slot-default (class slot)
(let ((initargs (condition-slot-initargs slot))
- (cpl (condition-class-cpl class)))
+ (cpl (condition-classoid-cpl class)))
(dolist (class cpl)
- (let ((default-initargs (condition-class-default-initargs class)))
+ (let ((default-initargs (condition-classoid-default-initargs class)))
(dolist (initarg initargs)
(let ((val (getf default-initargs initarg *empty-condition-slot*)))
(unless (eq val *empty-condition-slot*)
(defun find-condition-class-slot (condition-class slot-name)
(dolist (sclass
- (condition-class-cpl condition-class)
+ (condition-classoid-cpl condition-class)
(error "There is no slot named ~S in ~S."
slot-name condition-class))
- (dolist (slot (condition-class-slots sclass))
+ (dolist (slot (condition-classoid-slots sclass))
(when (eq (condition-slot-name slot) slot-name)
(return-from find-condition-class-slot slot)))))
(defun condition-writer-function (condition new-value name)
- (dolist (cslot (condition-class-class-slots
- (layout-class (%instance-layout condition)))
+ (dolist (cslot (condition-classoid-class-slots
+ (layout-classoid (%instance-layout condition)))
(setf (getf (condition-assigned-slots condition) name)
new-value))
(when (eq (condition-slot-name cslot) name)
(return (setf (car (condition-slot-cell cslot)) new-value)))))
(defun condition-reader-function (condition name)
- (let ((class (layout-class (%instance-layout condition))))
- (dolist (cslot (condition-class-class-slots class))
+ (let ((class (layout-classoid (%instance-layout condition))))
+ (dolist (cslot (condition-classoid-class-slots class))
(when (eq (condition-slot-name cslot) name)
(return-from condition-reader-function
(car (condition-slot-cell cslot)))))
;; Note: ANSI specifies no exceptional situations in this function.
;; signalling simple-type-error would not be wrong.
(let* ((thing (if (symbolp thing)
- (sb!xc:find-class thing)
+ (find-classoid thing)
thing))
(class (typecase thing
- (condition-class thing)
- (class
+ (condition-classoid thing)
+ (classoid
(error 'simple-type-error
:datum thing
:expected-type 'condition-class
:format-control "bad thing for class argument:~% ~S"
:format-arguments (list thing)))))
(res (make-condition-object args)))
- (setf (%instance-layout res) (class-layout class))
+ (setf (%instance-layout res) (classoid-layout class))
;; Set any class slots with initargs present in this call.
- (dolist (cslot (condition-class-class-slots class))
+ (dolist (cslot (condition-classoid-class-slots class))
(dolist (initarg (condition-slot-initargs cslot))
(let ((val (getf args initarg *empty-condition-slot*)))
(unless (eq val *empty-condition-slot*)
(setf (car (condition-slot-cell cslot)) val)))))
;; Default any slots with non-constant defaults now.
- (dolist (hslot (condition-class-hairy-slots class))
+ (dolist (hslot (condition-classoid-hairy-slots class))
(when (dolist (initarg (condition-slot-initargs hslot) t)
(unless (eq (getf args initarg *empty-condition-slot*)
*empty-condition-slot*)
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun %compiler-define-condition (name direct-supers layout)
(multiple-value-bind (class old-layout)
- (insured-find-class name #'condition-class-p #'make-condition-class)
- (setf (layout-class layout) class)
- (setf (class-direct-superclasses class)
- (mapcar #'sb!xc:find-class direct-supers))
+ (insured-find-classoid name
+ #'condition-classoid-p
+ #'make-condition-classoid)
+ (setf (layout-classoid layout) class)
+ (setf (classoid-direct-superclasses class)
+ (mapcar #'find-classoid direct-supers))
(cond ((not old-layout)
(register-layout layout))
((not *type-system-initialized*)
- (setf (layout-class old-layout) class)
+ (setf (layout-classoid old-layout) class)
(setq layout old-layout)
- (unless (eq (class-layout class) layout)
+ (unless (eq (classoid-layout class) layout)
(register-layout layout)))
((redefine-layout-warning "current"
old-layout
(layout-inherits layout)
(layout-depthoid layout))
(register-layout layout :invalidate t))
- ((not (class-layout class))
+ ((not (classoid-layout class))
(register-layout layout)))
(setf (layout-info layout)
;; 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))
- (layout-info (class-layout (sb!xc:find-class 'condition)))))
+ (declare (notinline find-classoid))
+ (layout-info (classoid-layout (find-classoid 'condition)))))
- (setf (sb!xc:find-class name) class)
+ (setf (find-classoid name) class)
;; Initialize CPL slot.
- (setf (condition-class-cpl class)
- (remove-if-not #'condition-class-p
+ (setf (condition-classoid-cpl class)
+ (remove-if-not #'condition-classoid-p
(std-compute-class-precedence-list class))))
(values))
;;; and documenting it here would be good. (Or, if this is not in fact
;;; ANSI-compliant, fixing it would also be good.:-)
(defun compute-effective-slots (class)
- (collect ((res (copy-list (condition-class-slots class))))
- (dolist (sclass (condition-class-cpl class))
- (dolist (sslot (condition-class-slots sclass))
+ (collect ((res (copy-list (condition-classoid-slots class))))
+ (dolist (sclass (condition-classoid-cpl class))
+ (dolist (sslot (condition-classoid-slots sclass))
(let ((found (find (condition-slot-name sslot) (res))))
(cond (found
(setf (condition-slot-initargs found)
(res)))
(defun %define-condition (name slots documentation report default-initargs)
- (let ((class (sb!xc:find-class name)))
- (setf (condition-class-slots class) slots)
- (setf (condition-class-report class) report)
- (setf (condition-class-default-initargs class) default-initargs)
+ (let ((class (find-classoid name)))
+ (setf (condition-classoid-slots class) slots)
+ (setf (condition-classoid-report class) report)
+ (setf (condition-classoid-default-initargs class) default-initargs)
(setf (fdocumentation name 'type) documentation)
(dolist (slot slots)
(let ((eslots (compute-effective-slots class))
(e-def-initargs
(reduce #'append
- (mapcar #'condition-class-default-initargs
- (condition-class-cpl class)))))
+ (mapcar #'condition-classoid-default-initargs
+ (condition-classoid-cpl class)))))
(dolist (slot eslots)
(ecase (condition-slot-allocation slot)
(:class
(funcall initform)
initform))
*empty-condition-slot*))))
- (push slot (condition-class-class-slots class)))
+ (push slot (condition-classoid-class-slots class)))
((:instance nil)
(setf (condition-slot-allocation slot) :instance)
(when (or (functionp (condition-slot-initform slot))
(dolist (initarg (condition-slot-initargs slot) nil)
(when (functionp (getf e-def-initargs initarg))
(return t))))
- (push slot (condition-class-hairy-slots class))))))))
+ (push slot (condition-classoid-hairy-slots class))))))))
name)
(defmacro define-condition (name (&rest parent-types) (&rest slot-specs)
sb!alien-internals:alien-value)))
(values nil t))
(;; special case when TARGET-TYPE isn't a type spec, but
- ;; instead a CLASS object
- (typep target-type 'sb!xc::structure-class)
- ;; SBCL-specific types which have an analogue specially
- ;; created on the host system
- (if (sb!xc:subtypep (sb!xc:class-name target-type)
- 'sb!kernel::structure!object)
- (values (typep host-object (sb!xc:class-name target-type)) t)
- (values nil t)))
+ ;; instead a CLASS object.
+ (typep target-type 'class)
+ (bug "We don't support CROSS-TYPEP of CLASS type specifiers"))
((and (symbolp target-type)
(find-class target-type nil)
(subtypep target-type 'sb!kernel::structure!object))
(values (typep host-object target-type) t))
((and (symbolp target-type)
- (sb!xc:find-class target-type nil)
+ (find-classoid target-type nil)
(sb!xc:subtypep target-type 'cl:structure-object)
(typep host-object '(or symbol number list character)))
(values nil t))
(values nil t))) ; but "obviously not a complex" being easy
;; Some types require translation between the cross-compilation
;; host Common Lisp and the target SBCL.
- ((target-type-is-in '(sb!xc:class))
- (values (typep host-object 'sb!xc:class) t))
+ ((target-type-is-in '(classoid))
+ (values (typep host-object 'classoid) t))
((target-type-is-in '(fixnum))
(values (fixnump host-object) t))
;; Some types are too hard to handle in the positive
(cond ((typep x 'standard-char)
;; (Note that SBCL doesn't distinguish between BASE-CHAR and
;; CHARACTER.)
- (sb!xc:find-class 'base-char))
+ (find-classoid 'base-char))
((not (characterp x))
nil)
(t
;; Beyond this, there seems to be no portable correspondence.
(error "can't map host Lisp CHARACTER ~S to target Lisp" x))))
(structure!object
- (sb!xc:find-class (uncross (class-name (class-of x)))))
+ (find-classoid (uncross (class-name (class-of x)))))
(t
;; There might be more cases which we could handle with
;; sufficient effort; since all we *need* to handle are enough
(progn
(defun %instance-length (instance)
(aver (typep instance 'structure!object))
- (layout-length (class-layout (sb!xc:find-class (type-of instance)))))
+ (layout-length (classoid-layout (find-classoid (type-of instance)))))
(defun %instance-ref (instance index)
(aver (typep instance 'structure!object))
- (let* ((class (sb!xc:find-class (type-of instance)))
- (layout (class-layout class)))
+ (let* ((class (find-classoid (type-of instance)))
+ (layout (classoid-layout class)))
(if (zerop index)
layout
(let* ((dd (layout-info layout))
(funcall accessor-name instance)))))
(defun %instance-set (instance index new-value)
(aver (typep instance 'structure!object))
- (let* ((class (sb!xc:find-class (type-of instance)))
- (layout (class-layout class)))
+ (let* ((class (find-classoid (type-of instance)))
+ (layout (classoid-layout class)))
(if (zerop index)
(error "can't set %INSTANCE-REF FOO 0 in cross-compilation host")
(let* ((dd (layout-info layout))
;; 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))
+ (declare (notinline find-classoid))
,@(let ((pf (dd-print-function defstruct))
(po (dd-print-object defstruct))
(x (gensym))
(t nil))))
,@(let ((pure (dd-pure defstruct)))
(cond ((eq pure t)
- `((setf (layout-pure (class-layout
- (sb!xc:find-class ',name)))
+ `((setf (layout-pure (classoid-layout
+ (find-classoid ',name)))
t)))
((eq pure :substructure)
- `((setf (layout-pure (class-layout
- (sb!xc:find-class ',name)))
+ `((setf (layout-pure (classoid-layout
+ (find-classoid ',name)))
0)))))
,@(let ((def-con (dd-default-constructor defstruct)))
(when (and def-con (not (dd-alternate-metaclass defstruct)))
- `((setf (structure-class-constructor (sb!xc:find-class ',name))
+ `((setf (structure-classoid-constructor (find-classoid ',name))
#',def-con))))))))
;;; shared logic for CL:DEFSTRUCT and SB!XC:DEFSTRUCT
(specifier-type (dd-element-type dd))))
(error ":TYPE option mismatch between structures ~S and ~S"
(dd-name dd) included-name))
- (let ((included-class (sb!xc:find-class included-name nil)))
- (when included-class
+ (let ((included-classoid (find-classoid included-name nil)))
+ (when included-classoid
;; It's not particularly well-defined to :INCLUDE any of the
;; CMU CL INSTANCE weirdosities like CONDITION or
;; GENERIC-FUNCTION, and it's certainly not ANSI-compliant.
- (let* ((included-layout (class-layout included-class))
+ (let* ((included-layout (classoid-layout included-classoid))
(included-dd (layout-info included-layout)))
(when (and (dd-alternate-metaclass included-dd)
;; As of sbcl-0.pre7.73, anyway, STRUCTURE-OBJECT
(super
(if include
(compiler-layout-or-lose (first include))
- (class-layout (sb!xc:find-class
- (or (first superclass-opt)
- 'structure-object))))))
+ (classoid-layout (find-classoid
+ (or (first superclass-opt)
+ 'structure-object))))))
(if (eq (dd-name info) 'ansi-stream)
;; a hack to add the CL:STREAM class as a mixin for ANSI-STREAMs
(concatenate 'simple-vector
(layout-inherits super)
(vector super
- (class-layout (sb!xc:find-class 'stream))))
+ (classoid-layout (find-classoid 'stream))))
(concatenate 'simple-vector
(layout-inherits super)
(vector super)))))
(declare (type defstruct-description dd))
;; We set up LAYOUTs even in the cross-compilation host.
- (multiple-value-bind (class layout old-layout)
+ (multiple-value-bind (classoid layout old-layout)
(ensure-structure-class dd inherits "current" "new")
(cond ((not old-layout)
- (unless (eq (class-layout class) layout)
+ (unless (eq (classoid-layout classoid) layout)
(register-layout layout)))
(t
(let ((old-dd (layout-info old-layout)))
(fmakunbound (dsd-accessor-name slot))
(unless (dsd-read-only slot)
(fmakunbound `(setf ,(dsd-accessor-name slot)))))))
- (%redefine-defstruct class old-layout layout)
- (setq layout (class-layout class))))
- (setf (sb!xc:find-class (dd-name dd)) class)
+ (%redefine-defstruct classoid old-layout layout)
+ (setq layout (classoid-layout classoid))))
+ (setf (find-classoid (dd-name dd)) classoid)
;; Various other operations only make sense on the target SBCL.
#-sb-xc-host
(inherits (vector (find-layout t)
(find-layout 'instance))))
- (multiple-value-bind (class layout old-layout)
+ (multiple-value-bind (classoid layout old-layout)
(multiple-value-bind (clayout clayout-p)
(info :type :compiler-layout (dd-name dd))
(ensure-structure-class dd
"compiled"
:compiler-layout clayout))
(cond (old-layout
- (undefine-structure (layout-class old-layout))
- (when (and (class-subclasses class)
+ (undefine-structure (layout-classoid old-layout))
+ (when (and (classoid-subclasses classoid)
(not (eq layout old-layout)))
(collect ((subs))
- (dohash (class layout (class-subclasses class))
+ (dohash (classoid layout (classoid-subclasses classoid))
(declare (ignore layout))
- (undefine-structure class)
- (subs (class-proper-name class)))
+ (undefine-structure classoid)
+ (subs (classoid-proper-name classoid)))
(when (subs)
(warn "removing old subclasses of ~S:~% ~S"
- (sb!xc:class-name class)
+ (classoid-name classoid)
(subs))))))
(t
- (unless (eq (class-layout class) layout)
+ (unless (eq (classoid-layout classoid) layout)
(register-layout layout :invalidate nil))
- (setf (sb!xc:find-class (dd-name dd)) class)))
+ (setf (find-classoid (dd-name dd)) classoid)))
;; At this point the class should be set up in the INFO database.
;; But the logic that enforces this is a little tangled and
;; scattered, so it's not obvious, so let's check.
- (aver (sb!xc:find-class (dd-name dd) nil))
+ (aver (find-classoid (dd-name dd) nil))
(setf (info :type :compiler-layout (dd-name dd)) layout))
;;; If we are redefining a structure with different slots than in the
;;; currently loaded version, give a warning and return true.
-(defun redefine-structure-warning (class old new)
+(defun redefine-structure-warning (classoid old new)
(declare (type defstruct-description old new)
- (type sb!xc:class class)
- (ignore class))
+ (type classoid classoid)
+ (ignore classoid))
(let ((name (dd-name new)))
(multiple-value-bind (moved retyped deleted) (compare-slots old new)
(when (or moved retyped deleted)
;;; structure CLASS to have the specified NEW-LAYOUT. We signal an
;;; error with some proceed options and return the layout that should
;;; be used.
-(defun %redefine-defstruct (class old-layout new-layout)
- (declare (type sb!xc:class class) (type layout old-layout new-layout))
- (let ((name (class-proper-name class)))
+(defun %redefine-defstruct (classoid old-layout new-layout)
+ (declare (type classoid classoid)
+ (type layout old-layout new-layout))
+ (let ((name (classoid-proper-name classoid)))
(restart-case
(error "~@<attempt to redefine the ~S class ~S incompatibly with the current definition~:@>"
'structure-object
(destructuring-bind
(&optional
name
- (class 'sb!xc:structure-class)
- (constructor 'make-structure-class))
+ (class 'structure-classoid)
+ (constructor 'make-structure-classoid))
(dd-alternate-metaclass info)
(declare (ignore name))
- (insured-find-class (dd-name info)
- (if (eq class 'sb!xc:structure-class)
- (lambda (x)
- (typep x 'sb!xc:structure-class))
- (lambda (x)
- (sb!xc:typep x (sb!xc:find-class class))))
- (fdefinition constructor)))
- (setf (class-direct-superclasses class)
+ (insured-find-classoid (dd-name info)
+ (if (eq class 'structure-classoid)
+ (lambda (x)
+ (sb!xc:typep x 'structure-classoid))
+ (lambda (x)
+ (sb!xc:typep x (find-classoid class))))
+ (fdefinition constructor)))
+ (setf (classoid-direct-superclasses class)
(if (eq (dd-name info) 'ansi-stream)
;; a hack to add CL:STREAM as a superclass mixin to ANSI-STREAMs
- (list (layout-class (svref inherits (1- (length inherits))))
- (layout-class (svref inherits (- (length inherits) 2))))
- (list (layout-class (svref inherits (1- (length inherits)))))))
- (let ((new-layout (make-layout :class class
+ (list (layout-classoid (svref inherits (1- (length inherits))))
+ (layout-classoid (svref inherits (- (length inherits) 2))))
+ (list (layout-classoid
+ (svref inherits (1- (length inherits)))))))
+ (let ((new-layout (make-layout :classoid class
:inherits inherits
:depthoid (length inherits)
:length (dd-length info)
(;; This clause corresponds to an assertion in REDEFINE-LAYOUT-WARNING
;; of classic CMU CL. I moved it out to here because it was only
;; exercised in this code path anyway. -- WHN 19990510
- (not (eq (layout-class new-layout) (layout-class old-layout)))
+ (not (eq (layout-classoid new-layout) (layout-classoid old-layout)))
(error "shouldn't happen: weird state of OLD-LAYOUT?"))
((not *type-system-initialized*)
(setf (layout-info old-layout) info)
;;; over this type, clearing the compiler structure type info, and
;;; undefining all the associated functions.
(defun undefine-structure (class)
- (let ((info (layout-info (class-layout class))))
+ (let ((info (layout-info (classoid-layout class))))
(when (defstruct-description-p info)
(let ((type (dd-name info)))
(remhash type *typecheckfuns*)
;;;; or implementing declarations in standard compiler transforms
;;; a type specifier
-(sb!xc:deftype type-specifier () '(or list symbol sb!xc:class))
+;;;
+;;; FIXME: The SB!KERNEL:INSTANCE here really means CL:CLASS.
+;;; However, the CL:CLASS type is only defined once PCL is loaded,
+;;; which is before this is evaluated. Once PCL is moved into cold
+;;; init, this might be fixable.
+(sb!xc:deftype type-specifier () '(or list symbol sb!kernel:instance))
;;; array rank, total size...
(sb!xc:deftype array-rank () `(integer 0 (,sb!xc:array-rank-limit)))
;; * NIL, in which case there's nothing to see here, move along.
(when (eq (info :type :kind x) :defined)
(format s "~@:_It names a type specifier."))
- (let ((symbol-named-class (cl:find-class x nil)))
+ (let ((symbol-named-class (find-classoid x nil)))
(when symbol-named-class
(format s "~@:_It names a class ~A." symbol-named-class)
(describe symbol-named-class s))))
((and (not (eq spec u))
(info :type :builtin spec)))
((eq (info :type :kind spec) :instance)
- (sb!xc:find-class spec))
- ((typep spec 'class)
+ (find-classoid spec))
+ ((typep spec 'classoid)
;; There doesn't seem to be any way to translate
;; (TYPEP SPEC 'BUILT-IN-CLASS) into something which can be
;; executed on the host Common Lisp at cross-compilation time.
#+sb-xc-host (error
"stub: (TYPEP SPEC 'BUILT-IN-CLASS) on xc host")
- (if (typep spec 'built-in-class)
- (or (built-in-class-translation spec) spec)
+ (if (typep spec 'built-in-classoid)
+ (or (built-in-classoid-translation spec) spec)
spec))
+ ;; FIXME: CL:CLASS objects are type specifiers.
(t
(let* (;; FIXME: This automatic promotion of FOO-style
;; specs to (FOO)-style specs violates the ANSI
:format-control format-control
:format-arguments format-arguments))
-(define-condition sb!kernel:layout-invalid (type-error)
+(define-condition layout-invalid (type-error)
()
(:report
(lambda (condition stream)
"~@<invalid structure layout: ~
~2I~_A test for class ~4I~_~S ~
~2I~_was passed the obsolete instance ~4I~_~S~:>"
- (sb!kernel:class-proper-name (type-error-expected-type condition))
+ (classoid-proper-name (type-error-expected-type condition))
(type-error-datum condition)))))
(define-condition case-failure (type-error)
(deferr layout-invalid-error (object layout)
(error 'layout-invalid
:datum object
- :expected-type (layout-class layout)))
+ :expected-type (layout-classoid layout)))
(deferr odd-key-args-error ()
(error 'simple-program-error
(values
;; FIXME: This old CMU CL code probably deserves a comment
;; explaining to us mere mortals how it works...
- (and (sb!xc:typep type2 'sb!xc:class)
+ (and (sb!xc:typep type2 'classoid)
(dolist (x info nil)
(when (or (not (cdr x))
(csubtypep type1 (specifier-type (cdr x))))
(return
(or (eq type2 (car x))
- (let ((inherits (layout-inherits (class-layout (car x)))))
+ (let ((inherits (layout-inherits
+ (classoid-layout (car x)))))
(dotimes (i (length inherits) nil)
- (when (eq type2 (layout-class (svref inherits i)))
+ (when (eq type2 (layout-classoid (svref inherits i)))
(return t)))))))))
t)))
(destructuring-bind
(super &optional guard)
spec
- (cons (sb!xc:find-class super) guard)))
+ (cons (find-classoid super) guard)))
',specs)))
(setf (type-class-complex-subtypep-arg1 ,type-class)
(lambda (type1 type2)
(defun defined-ftype-matches-declared-ftype-p (defined-ftype declared-ftype)
(declare (type ctype defined-ftype declared-ftype))
(flet ((is-built-in-class-function-p (ctype)
- (and (built-in-class-p ctype)
- (eq (built-in-class-%name ctype) 'function))))
+ (and (built-in-classoid-p ctype)
+ (eq (built-in-classoid-name ctype) 'function))))
(cond (;; DECLARED-FTYPE could certainly be #<BUILT-IN-CLASS FUNCTION>;
;; that's what happens when we (DECLAIM (FTYPE FUNCTION FOO)).
(is-built-in-class-function-p declared-ftype)
"Return the type of OBJECT."
(if (typep object '(or function array complex))
(type-specifier (ctype-of object))
- (let* ((class (layout-class (layout-of object)))
- (name (class-name class)))
+ (let* ((classoid (layout-classoid (layout-of object)))
+ (name (classoid-name classoid)))
(if (typep object 'instance)
(case name
(sb!alien-internals:alien-value
,(sb!alien-internals:unparse-alien-type
(sb!alien-internals:alien-value-type object))))
(t
- (class-proper-name class)))
+ (classoid-proper-name classoid)))
name))))
\f
;;;; equality predicates
(len (layout-length layout-x)))
(and (typep y 'instance)
(eq layout-x (%instance-layout y))
- (structure-class-p (layout-class layout-x))
+ (structure-classoid-p (layout-classoid layout-x))
(do ((i 1 (1+ i)))
((= i len) t)
(declare (fixnum i))
(when (eql type instance-header-widetag)
(incf total-objects)
(incf total-bytes size)
- (let* ((class (layout-class (%instance-ref obj 0)))
- (found (gethash class totals)))
+ (let* ((classoid (layout-classoid (%instance-ref obj 0)))
+ (found (gethash classoid totals)))
(cond (found
(incf (the fixnum (car found)))
(incf (the fixnum (cdr found)) size))
(t
- (setf (gethash class totals) (cons 1 size)))))))
+ (setf (gethash classoid totals) (cons 1 size)))))))
space)
(collect ((totals-list))
- (maphash (lambda (class what)
+ (maphash (lambda (classoid what)
(totals-list (cons (prin1-to-string
- (class-proper-name class))
+ (classoid-proper-name classoid))
what)))
totals)
(let ((sorted (sort (totals-list) #'> :key #'cddr))
(%reader-error stream "non-list following #S: ~S" body))
(unless (symbolp (car body))
(%reader-error stream "Structure type is not a symbol: ~S" (car body)))
- (let ((class (sb!xc:find-class (car body) nil)))
- (unless (typep class 'sb!xc:structure-class)
+ (let ((classoid (find-classoid (car body) nil)))
+ (unless (typep classoid 'structure-classoid)
(%reader-error stream "~S is not a defined structure type."
(car body)))
(let ((def-con (dd-default-constructor
(layout-info
- (class-layout class)))))
+ (classoid-layout classoid)))))
(unless def-con
(%reader-error
stream "The ~S structure does not have a default constructor."
(defun %default-structure-pretty-print (structure stream)
(let* ((layout (%instance-layout structure))
- (name (class-name (layout-class layout)))
+ (name (classoid-name (layout-classoid layout)))
(dd (layout-info layout)))
(pprint-logical-block (stream nil :prefix "#S(" :suffix ")")
(prin1 name stream)
(pprint-newline :linear stream))))))))
(defun %default-structure-ugly-print (structure stream)
(let* ((layout (%instance-layout structure))
- (name (class-name (layout-class layout)))
+ (name (classoid-name (layout-classoid layout)))
(dd (layout-info layout)))
(descend-into (stream)
(write-string "#S(" stream)
((layout-invalid obj-layout)
(/noshow0 "LAYOUT-INVALID case")
(error 'layout-invalid
- :expected-type (layout-class obj-layout)
+ :expected-type (layout-classoid obj-layout)
:datum obj))
(t
(let ((depthoid (layout-depthoid layout)))
(unless (typep-to-layout x layout)
(error 'type-error
:datum x
- :expected-type (class-name (layout-class layout))))
+ :expected-type (classoid-name (layout-classoid layout))))
(values))
\f
(/show0 "target-defstruct.lisp end of file")
(if (typep x 'structure-object)
(logxor 422371266
(sxhash ; through DEFTRANSFORM
- (class-name (layout-class (%instance-layout x)))))
+ (classoid-name
+ (layout-classoid (%instance-layout x)))))
(sxhash-instance x)))
(symbol (sxhash x)) ; through DEFTRANSFORM
(array
(declare (type (integer 0 #.+max-hash-depthoid+) depthoid))
(let* ((layout (%instance-layout key)) ; i.e. slot #0
(length (layout-length layout))
- (class (layout-class layout))
- (name (class-name class))
+ (classoid (layout-classoid layout))
+ (name (classoid-name classoid))
(result (mix (sxhash name) (the fixnum 79867))))
(declare (type fixnum result))
(dotimes (i (min depthoid (1- length)))
named-type
member-type
array-type
- sb!xc:built-in-class
+ built-in-classoid
cons-type)
(values (%typep obj type) t))
- (sb!xc:class
+ (classoid
(if (if (csubtypep type (specifier-type 'funcallable-instance))
(funcallable-instance-p obj)
(typep obj 'instance))
- (if (eq (class-layout type)
- (info :type :compiler-layout (sb!xc:class-name type)))
+ (if (eq (classoid-layout type)
+ (info :type :compiler-layout (classoid-name type)))
(values (sb!xc:typep obj type) t)
(values nil nil))
(values nil t)))
;; KLUDGE: In order to really make this run at run time
;; (instead of doing some weird broken thing at cold load
;; time), we need to suppress a DEFTRANSFORM.. -- WHN 19991004
- (declare (notinline sb!xc:find-class))
- (class-layout (sb!xc:find-class 'null))))
+ (declare (notinline find-classoid))
+ (classoid-layout (find-classoid 'null))))
(t (svref *built-in-class-codes* (widetag-of x)))))
-#!-sb-fluid (declaim (inline sb!xc:class-of))
-(defun sb!xc:class-of (object)
+#!-sb-fluid (declaim (inline classoid-of))
+(defun classoid-of (object)
#!+sb-doc
"Return the class of the supplied object, which may be any Lisp object, not
just a CLOS STANDARD-OBJECT."
- (layout-class (layout-of object)))
+ (layout-classoid (layout-of object)))
;;; Pull the type specifier out of a function object.
(defun extract-fun-type (fun)
(typecase x
(function
(if (funcallable-instance-p x)
- (sb!xc:class-of x)
+ (classoid-of x)
(extract-fun-type x)))
(symbol
(make-member-type :members (list x)))
(cons
(make-cons-type *universal-type* *universal-type*))
(t
- (sb!xc:class-of x))))
+ (classoid-of x))))
;;; Clear this cache on GC so that we don't hold onto too much garbage.
(pushnew 'ctype-of-cache-clear *before-gc-hooks*)
(/primitive-print (symbol-name name))
(when trans-p
(/show0 "in TRANS-P case")
- (let ((class (class-cell-class (find-class-cell name)))
+ (let ((classoid (classoid-cell-classoid (find-classoid-cell name)))
(type (specifier-type translation)))
- (setf (built-in-class-translation class) type)
+ (setf (built-in-classoid-translation classoid) type)
(setf (info :type :builtin name) type)))))
;;; numeric types
(let* ((typespec (second typespec-form))
(ctype (specifier-type typespec)))
(aver (= 2 (length typespec-form)))
- (cond ((structure-class-p ctype)
+ (cond ((structure-classoid-p ctype)
`(structure-object-typecheckfun ,typespec-form))
((ctype-needs-to-be-interpreted-p ctype)
whole) ; i.e. give up compiler macro
object)))))))
(member-type
(if (member object (member-type-members type)) t))
- (sb!xc:class
+ (classoid
#+sb-xc-host (ctypep object type)
- #-sb-xc-host (class-typep (layout-of object) type object))
+ #-sb-xc-host (classoid-typep (layout-of object) type object))
(union-type
(some (lambda (union-type-type) (%%typep object union-type-type))
(union-type-types type)))
;;; Do a type test from a class cell, allowing forward reference and
;;; redefinition.
-(defun class-cell-typep (obj-layout cell object)
- (let ((class (class-cell-class cell)))
- (unless class
- (error "The class ~S has not yet been defined." (class-cell-name cell)))
- (class-typep obj-layout class object)))
+(defun classoid-cell-typep (obj-layout cell object)
+ (let ((classoid (classoid-cell-classoid cell)))
+ (unless classoid
+ (error "The class ~S has not yet been defined."
+ (classoid-cell-name cell)))
+ (classoid-typep obj-layout classoid object)))
-;;; Test whether OBJ-LAYOUT is from an instance of CLASS.
-(defun class-typep (obj-layout class object)
+;;; Test whether OBJ-LAYOUT is from an instance of CLASSOID.
+(defun classoid-typep (obj-layout classoid object)
(declare (optimize speed))
(when (layout-invalid obj-layout)
- (if (and (typep (sb!xc:class-of object) 'sb!xc:standard-class) object)
+ (if (and (typep (classoid-of object) 'standard-classoid) object)
(setq obj-layout (sb!pcl::check-wrapper-validity object))
(error "TYPEP was called on an obsolete object (was class ~S)."
- (class-proper-name (layout-class obj-layout)))))
- (let ((layout (class-layout class))
+ (classoid-proper-name (layout-classoid obj-layout)))))
+ (let ((layout (classoid-layout classoid))
(obj-inherits (layout-inherits obj-layout)))
(when (layout-invalid layout)
- (error "The class ~S is currently invalid." class))
+ (error "The class ~S is currently invalid." classoid))
(or (eq obj-layout layout)
(dotimes (i (length obj-inherits) nil)
(when (eq (svref obj-inherits i) layout)
\f
;;;; compiling and loading more of the system
-;;; KLUDGE: In SBCL, almost all in-the-flow-of-control package hacking has
-;;; gone away in favor of package setup controlled by tables. However, that
-;;; mechanism isn't smart enough to handle shadowing, and since this shadowing
-;;; is inherently a non-ANSI KLUDGE anyway (i.e. there ought to be no
-;;; difference between e.g. CL:CLASS and SB-PCL:CLASS) there's not much
-;;; point in trying to polish it by implementing a non-KLUDGEy way of
-;;; setting it up. -- WHN 19991203
-(let ((*package* (the package (find-package "SB-PCL"))))
- (shadow '(;; CLASS itself and operations thereon
- "CLASS" "CLASS-NAME" "CLASS-OF" "FIND-CLASS"
- ;; some system classes
- "BUILT-IN-CLASS" "STANDARD-CLASS" "STRUCTURE-CLASS"))
- ;; Of the shadowing symbols above, these are external symbols in CMU CL ca.
- ;; 19991203. I'm not sure what's the basis of the decision to export some and
- ;; not others; we'll just follow along..
- (export (mapcar #'intern '("CLASS-NAME" "CLASS-OF" "FIND-CLASS"))))
-
;;; FIXME: CMU CL's pclcom.lisp had extra optional stuff wrapped around
;;; COMPILE-PCL, at least some of which we should probably have too:
;;;
(error "illegal to redefine standard type: ~S" name)))
(:instance
(warn "The class ~S is being redefined to be a DEFTYPE." name)
- (undefine-structure (layout-info (class-layout (sb!xc:find-class name))))
- (setf (class-cell-class (find-class-cell name)) nil)
+ (undefine-structure (layout-info (classoid-layout (find-classoid name))))
+ (setf (classoid-cell-classoid (find-classoid-cell name)) nil)
(setf (info :type :compiler-layout name) nil)
(setf (info :type :kind name) :defined))
(:defined
(when (layout-invalid obj)
(compiler-error "attempt to dump reference to obsolete class: ~S"
(layout-class obj)))
- (let ((name (sb!xc:class-name (layout-class obj))))
+ (let ((name (classoid-name (layout-classoid obj))))
(unless name
(compiler-error "dumping anonymous layout: ~S" obj))
(dump-fop 'fop-normal-load file)
;;;; classes
(sb!xc:deftype name-for-class () t)
-(defknown class-name (sb!xc:class) name-for-class (flushable))
-(defknown find-class (name-for-class &optional t lexenv-designator)
- (or sb!xc:class null) ())
-(defknown class-of (t) sb!xc:class (flushable))
+(defknown classoid-name (classoid) name-for-class (flushable))
+(defknown find-classoid (name-for-class &optional t lexenv-designator)
+ (or classoid null) ())
+(defknown classoid-of (t) classoid (flushable))
(defknown layout-of (t) layout (flushable))
(defknown copy-structure (structure-object) structure-object
(flushable unsafe))
(ecase (named-type-name type)
((t *) (values *backend-t-primitive-type* t))
((nil) (any))))
- (sb!xc:built-in-class
- (case (sb!xc:class-name type)
+ (built-in-classoid
+ (case (classoid-name type)
((complex function instance
system-area-pointer weak-pointer)
- (values (primitive-type-or-lose (sb!xc:class-name type)) t))
+ (values (primitive-type-or-lose (classoid-name type)) t))
(funcallable-instance
(part-of function))
(base-char
(any))))
(fun-type
(exactly function))
- (sb!xc:class
+ (classoid
(if (csubtypep type (specifier-type 'function))
(part-of function)
(part-of instance)))
(if (type= type (specifier-type 'cons))
'sb!c:check-cons
nil))
- (built-in-class
+ (built-in-classoid
(if (type= type (specifier-type 'symbol))
'sb!c:check-symbol
nil))
;;; meaningful error if we only have the cons.
(define-info-type
:class :type
- :type :class
- :type-spec (or sb!kernel::class-cell null)
+ :type :classoid
+ :type-spec (or sb!kernel::classoid-cell null)
:default nil)
;;; layout for this type being used by the compiler
:class :type
:type :compiler-layout
:type-spec (or layout null)
- :default (let ((class (sb!xc:find-class name nil)))
- (when class (class-layout class))))
+ :default (let ((class (find-classoid name nil)))
+ (when class (classoid-layout class))))
(define-info-class :typed-structure)
(define-info-type
(freeze-type
(dolist (type args)
(let ((class (specifier-type type)))
- (when (typep class 'sb!xc:class)
- (setf (class-state class) :sealed)
- (let ((subclasses (class-subclasses class)))
+ (when (typep class 'classoid)
+ (setf (classoid-state class) :sealed)
+ (let ((subclasses (classoid-subclasses class)))
(when subclasses
(dohash (subclass layout subclasses)
(declare (ignore layout))
- (setf (class-state subclass) :sealed))))))))
+ (setf (classoid-state subclass) :sealed))))))))
(optimize
(setq *policy* (process-optimize-decl form *policy*)))
((inline notinline maybe-inline)
;;; If FIND-CLASS is called on a constant class, locate the CLASS-CELL
;;; at load time.
-(deftransform find-class ((name) ((constant-arg symbol)) *)
+(deftransform find-classoid ((name) ((constant-arg symbol)) *)
(let* ((name (continuation-value name))
- (cell (find-class-cell name)))
- `(or (class-cell-class ',cell)
+ (cell (find-classoid-cell name)))
+ `(or (classoid-cell-classoid ',cell)
(error "class not yet defined: ~S" name))))
\f
;;;; standard type predicates, i.e. those defined in package COMMON-LISP,
(aver (constant-continuation-p spec))
(let* ((spec (continuation-value spec))
(class (specifier-type spec))
- (name (sb!xc:class-name class))
+ (name (classoid-name class))
(otype (continuation-type object))
(layout (let ((res (info :type :compiler-layout name)))
(if (and res (not (layout-invalid res)))
((csubtypep otype class)
t)
;; If not properly named, error.
- ((not (and name (eq (sb!xc:find-class name) class)))
+ ((not (and name (eq (find-classoid name) class)))
(compiler-error "can't compile TYPEP of anonymous or undefined ~
class:~% ~S"
class))
(t
(values '(lambda (x) (declare (ignore x)) t) 'layout-of)))
(cond
- ((and (eq (class-state class) :sealed) layout
- (not (class-subclasses class)))
+ ((and (eq (classoid-state class) :sealed) layout
+ (not (classoid-subclasses class)))
;; Sealed and has no subclasses.
(let ((n-layout (gensym)))
`(and (,pred object)
`((when (layout-invalid ,n-layout)
(%layout-invalid-error object ',layout))))
(eq ,n-layout ',layout)))))
- ((and (typep class 'basic-structure-class) layout)
+ ((and (typep class 'basic-structure-classoid) layout)
;; structure type tests; hierarchical layout depths
(let ((depthoid (layout-depthoid layout))
(n-layout (gensym)))
(t
(/noshow "default case -- ,PRED and CLASS-CELL-TYPEP")
`(and (,pred object)
- (class-cell-typep (,get-layout object)
- ',(find-class-cell name)
- object)))))))))
+ (classoid-cell-typep (,get-layout object)
+ ',(find-classoid-cell name)
+ object)))))))))
;;; If the specifier argument is a quoted constant, then we consider
;;; converting into a simple predicate or other stuff. If the type is
(typecase type
(numeric-type
(source-transform-numeric-typep object type))
- (sb!xc:class
+ (classoid
`(%instance-typep ,object ,spec))
(array-type
(source-transform-array-typep object type))
(built-in-class built-in-class-wrapper)
(structure-class structure-class-wrapper)))
(class (or (find-class name nil)
- (allocate-standard-instance wrapper))))
+ (allocate-standard-instance wrapper))))
(setf (find-class name) class)))
(dolist (definition *early-class-definitions*)
(let ((name (ecd-class-name definition))
(dolist (e *built-in-classes*)
(destructuring-bind (name supers subs cpl prototype) e
(let* ((class (find-class name))
- (lclass (cl:find-class name))
- (wrapper (sb-kernel:class-layout lclass)))
+ (lclass (sb-kernel:find-classoid name))
+ (wrapper (sb-kernel:classoid-layout lclass)))
(set (get-built-in-class-symbol name) class)
(set (get-built-in-wrapper-symbol name) wrapper)
- (setf (sb-kernel:class-pcl-class lclass) class)
+ (setf (sb-kernel:classoid-pcl-class lclass) class)
(!bootstrap-initialize-class 'built-in-class class
name class-eq-wrapper nil
:metaclass 'structure-class
:name symbol
:direct-superclasses
- (mapcar #'cl:class-name
- (sb-kernel:class-direct-superclasses
- (cl:find-class symbol)))
+ (mapcar #'sb-kernel:classoid-name
+ (sb-kernel:classoid-direct-superclasses
+ (sb-kernel:find-classoid symbol)))
:direct-slots
(mapcar #'slot-initargs-from-structure-slotd
(structure-type-slot-description-list
;;; Set the inherits from CPL, and register the layout. This actually
;;; installs the class in the Lisp type system.
(defun update-lisp-class-layout (class layout)
- (let ((lclass (sb-kernel:layout-class layout)))
- (unless (eq (sb-kernel:class-layout lclass) layout)
+ (let ((lclass (sb-kernel:layout-classoid layout)))
+ (unless (eq (sb-kernel:classoid-layout lclass) layout)
(setf (sb-kernel:layout-inherits layout)
(sb-kernel:order-layout-inherits
(map 'simple-vector #'class-wrapper
;; unknown to CL:FIND-CLASS and also anonymous. This
;; functionality moved here from (SETF FIND-CLASS).
(let ((name (class-name class)))
- (setf (cl:find-class name) lclass
- ;; FIXME: It's nasty to use double colons. Perhaps the
- ;; best way to fix this is not to export CLASS-%NAME
- ;; from SB-KERNEL, but instead to move the whole
- ;; UPDATE-LISP-CLASS-LAYOUT function to SB-KERNEL, and
- ;; export it. (since it's also nasty for us to be
- ;; reaching into %KERNEL implementation details my
- ;; messing with raw CLASS-%NAME)
- (sb-kernel::class-%name lclass) name)))))
+ (setf (sb-kernel:find-classoid name) lclass
+ (sb-kernel:classoid-name lclass) name)))))
+
+(defun set-class-type-translation (class name)
+ (let ((classoid (sb-kernel:find-classoid name nil)))
+ (etypecase classoid
+ (null)
+ (sb-kernel:built-in-classoid
+ (let ((translation (sb-kernel::built-in-classoid-translation classoid)))
+ (cond
+ (translation
+ (aver (sb-kernel:ctype-p translation))
+ (setf (info :type :translator class)
+ (lambda (spec) (declare (ignore spec)) translation)))
+ (t
+ (setf (info :type :translator class)
+ (lambda (spec) (declare (ignore spec)) classoid))))))
+ (sb-kernel:classoid
+ (setf (info :type :translator class)
+ (lambda (spec) (declare (ignore spec)) classoid))))))
(clrhash *find-class*)
(!bootstrap-meta-braid)
(dohash (name x *find-class*)
(let* ((class (find-class-from-cell name x))
(layout (class-wrapper class))
- (lclass (sb-kernel:layout-class layout))
- (lclass-pcl-class (sb-kernel:class-pcl-class lclass))
- (olclass (cl:find-class name nil)))
+ (lclass (sb-kernel:layout-classoid layout))
+ (lclass-pcl-class (sb-kernel:classoid-pcl-class lclass))
+ (olclass (sb-kernel:find-classoid name nil)))
(if lclass-pcl-class
(aver (eq class lclass-pcl-class))
- (setf (sb-kernel:class-pcl-class lclass) class))
+ (setf (sb-kernel:classoid-pcl-class lclass) class))
(update-lisp-class-layout class layout)
(cond (olclass
(aver (eq lclass olclass)))
(t
- (setf (cl:find-class name) lclass)))))
+ (setf (sb-kernel:find-classoid name) lclass)))
+
+ (set-class-type-translation class name)))
(setq *boot-state* 'braid)
(setq *the-class-t* nil))
(defmacro wrapper-class (wrapper)
- `(sb-kernel:class-pcl-class (sb-kernel:layout-class ,wrapper)))
+ `(sb-kernel:classoid-pcl-class (sb-kernel:layout-classoid ,wrapper)))
(defmacro wrapper-no-of-instance-slots (wrapper)
`(sb-kernel:layout-length ,wrapper))
;;; whose slots are not initialized yet, and which may be built-in
;;; classes. We pass in the class name in addition to the class.
(defun boot-make-wrapper (length name &optional class)
- (let ((found (cl:find-class name nil)))
+ (let ((found (sb-kernel:find-classoid name nil)))
(cond
(found
- (unless (sb-kernel:class-pcl-class found)
- (setf (sb-kernel:class-pcl-class found) class))
- (aver (eq (sb-kernel:class-pcl-class found) class))
- (let ((layout (sb-kernel:class-layout found)))
+ (unless (sb-kernel:classoid-pcl-class found)
+ (setf (sb-kernel:classoid-pcl-class found) class))
+ (aver (eq (sb-kernel:classoid-pcl-class found) class))
+ (let ((layout (sb-kernel:classoid-layout found)))
(aver layout)
layout))
(t
(make-wrapper-internal
:length length
- :class (sb-kernel:make-standard-class :name name :pcl-class class))))))
+ :classoid (sb-kernel:make-standard-classoid
+ :name name :pcl-class class))))))
;;; The following variable may be set to a STANDARD-CLASS that has
;;; already been created by the lisp code and which is to be redefined
;;; In SBCL, as in CMU CL, the layouts (a.k.a wrappers) for built-in
;;; and structure classes already exist when PCL is initialized, so we
;;; don't necessarily always make a wrapper. Also, we help maintain
-;;; the mapping between CL:CLASS and PCL::CLASS objects.
+;;; the mapping between CL:CLASS and SB-KERNEL:CLASSOID objects.
(defun make-wrapper (length class)
(cond
((typep class 'std-class)
(make-wrapper-internal
:length length
- :class
+ :classoid
(let ((owrap (class-wrapper class)))
(cond (owrap
- (sb-kernel:layout-class owrap))
+ (sb-kernel:layout-classoid owrap))
((*subtypep (class-of class)
*the-class-standard-class*)
(cond ((and *pcl-class-boot*
(eq (slot-value class 'name) *pcl-class-boot*))
- (let ((found (cl:find-class (slot-value class 'name))))
- (unless (sb-kernel:class-pcl-class found)
- (setf (sb-kernel:class-pcl-class found) class))
- (aver (eq (sb-kernel:class-pcl-class found) class))
+ (let ((found (sb-kernel:find-classoid
+ (slot-value class 'name))))
+ (unless (sb-kernel:classoid-pcl-class found)
+ (setf (sb-kernel:classoid-pcl-class found) class))
+ (aver (eq (sb-kernel:classoid-pcl-class found) class))
found))
(t
- (sb-kernel:make-standard-class :pcl-class class))))
+ (sb-kernel:make-standard-classoid :pcl-class class))))
(t
- (sb-kernel:make-random-pcl-class :pcl-class class))))))
+ (sb-kernel:make-random-pcl-classoid :pcl-class class))))))
(t
- (let* ((found (cl:find-class (slot-value class 'name)))
- (layout (sb-kernel:class-layout found)))
- (unless (sb-kernel:class-pcl-class found)
- (setf (sb-kernel:class-pcl-class found) class))
- (aver (eq (sb-kernel:class-pcl-class found) class))
+ (let* ((found (sb-kernel:find-classoid (slot-value class 'name)))
+ (layout (sb-kernel:classoid-layout found)))
+ (unless (sb-kernel:classoid-pcl-class found)
+ (setf (sb-kernel:classoid-pcl-class found) class))
+ (aver (eq (sb-kernel:classoid-pcl-class found) class))
(aver layout)
layout))))
(defun wrapper-class* (wrapper)
(or (wrapper-class wrapper)
(find-structure-class
- (cl:class-name (sb-kernel:layout-class wrapper)))))
+ (sb-kernel:classoid-name (sb-kernel:layout-classoid wrapper)))))
;;; The wrapper cache machinery provides general mechanism for
;;; trapping on the next access to any instance of a given class. This
:slot-names (function-name class-name class initargs)
:boa-constructor %make-ctor
:superclass-name pcl-funcallable-instance
- :metaclass-name sb-kernel:random-pcl-class
- :metaclass-constructor sb-kernel:make-random-pcl-class
+ :metaclass-name sb-kernel:random-pcl-classoid
+ :metaclass-constructor sb-kernel:make-random-pcl-classoid
:dd-type sb-kernel:funcallable-structure
:runtime-type-checks-p nil)
(error "The value of the :metaclass option (~S) is not a~%~
legal class name."
(cadr option)))
- (setq metaclass
- (case (cadr option)
- (cl:standard-class 'standard-class)
- (cl:structure-class 'structure-class)
- (t (cadr option))))
+ (setq metaclass (cadr option))
(setf options (remove option options))
(return t))))
:object (coerce-to-class (car args))))
(class-eq (class-eq-specializer (coerce-to-class (car args))))
(eql (intern-eql-specializer (car args))))))
- ((and (null args) (typep type 'cl:class))
- (or (sb-kernel:class-pcl-class type)
- (find-structure-class (cl:class-name type))))
+ ;; FIXME: do we still need this?
+ ((and (null args) (typep type 'sb-kernel:classoid))
+ (or (sb-kernel:classoid-pcl-class type)
+ (find-structure-class (sb-kernel:classoid-name type))))
((specializerp type) type)))
;;; interface
((not and or) `(,(car type) ,@(mapcar #'convert-to-system-type
(cdr type))))
((class class-eq) ; class-eq is impossible to do right
- (sb-kernel:layout-class (class-wrapper (cadr type))))
+ (sb-kernel:layout-classoid (class-wrapper (cadr type))))
(eql type)
(t (if (null (cdr type))
(car type)
(defvar *built-in-classes*
(labels ((direct-supers (class)
(/noshow "entering DIRECT-SUPERS" (sb-kernel::class-name class))
- (if (typep class 'cl:built-in-class)
- (sb-kernel:built-in-class-direct-superclasses class)
+ (if (typep class 'sb-kernel:built-in-classoid)
+ (sb-kernel:built-in-classoid-direct-superclasses class)
(let ((inherits (sb-kernel:layout-inherits
- (sb-kernel:class-layout class))))
+ (sb-kernel:classoid-layout class))))
(/noshow inherits)
(list (svref inherits (1- (length inherits)))))))
(direct-subs (class)
(/noshow "entering DIRECT-SUBS" (sb-kernel::class-name class))
(collect ((res))
- (let ((subs (sb-kernel:class-subclasses class)))
+ (let ((subs (sb-kernel:classoid-subclasses class)))
(/noshow subs)
(when subs
(dohash (sub v subs)
(mapcar (lambda (kernel-bic-entry)
(/noshow "setting up" kernel-bic-entry)
(let* ((name (car kernel-bic-entry))
- (class (cl:find-class name)))
+ (class (sb-kernel:find-classoid name)))
(/noshow name class)
`(,name
- ,(mapcar #'cl:class-name (direct-supers class))
- ,(mapcar #'cl:class-name (direct-subs class))
+ ,(mapcar #'sb-kernel:classoid-name (direct-supers class))
+ ,(mapcar #'sb-kernel:classoid-name (direct-subs class))
,(map 'list
(lambda (x)
- (cl:class-name (sb-kernel:layout-class x)))
+ (sb-kernel:classoid-name
+ (sb-kernel:layout-classoid x)))
(reverse
(sb-kernel:layout-inherits
- (sb-kernel:class-layout class))))
+ (sb-kernel:classoid-layout class))))
,(prototype name))))
(remove-if (lambda (kernel-bic-entry)
(member (first kernel-bic-entry)
;;; other code which does low-level hacking of packages.. -- WHN 19991203
;;; types, classes, and structure names
-(defmethod documentation ((x cl:structure-class) (doc-type (eql 't)))
- (values (info :type :documentation (cl:class-name x))))
-
(defmethod documentation ((x structure-class) (doc-type (eql 't)))
(values (info :type :documentation (class-name x))))
-(defmethod documentation ((x cl:standard-class) (doc-type (eql 't)))
- (or (values (info :type :documentation (cl:class-name x)))
- (let ((pcl-class (sb-kernel:class-pcl-class x)))
- (and pcl-class (plist-value pcl-class 'documentation)))))
-
-(defmethod documentation ((x cl:structure-class) (doc-type (eql 'type)))
- (values (info :type :documentation (cl:class-name x))))
-
(defmethod documentation ((x structure-class) (doc-type (eql 'type)))
(values (info :type :documentation (class-name x))))
-(defmethod documentation ((x cl:standard-class) (doc-type (eql 'type)))
- (or (values (info :type :documentation (cl:class-name x)))
- (let ((pcl-class (sb-kernel:class-pcl-class x)))
- (and pcl-class (plist-value pcl-class 'documentation)))))
-
(defmethod documentation ((x symbol) (doc-type (eql 'type)))
(or (values (info :type :documentation x))
(let ((class (find-class x nil)))
(values (info :type :documentation x))))
(defmethod (setf documentation) (new-value
- (x cl:structure-class)
- (doc-type (eql 't)))
- (setf (info :type :documentation (cl:class-name x)) new-value))
-
-(defmethod (setf documentation) (new-value
(x structure-class)
(doc-type (eql 't)))
(setf (info :type :documentation (class-name x)) new-value))
(defmethod (setf documentation) (new-value
- (x cl:structure-class)
- (doc-type (eql 'type)))
- (setf (info :type :documentation (cl:class-name x)) new-value))
-
-(defmethod (setf documentation) (new-value
(x structure-class)
(doc-type (eql 'type)))
(setf (info :type :documentation (class-name x)) new-value))
;;; it needs a more mnemonic name. -- WHN 19991204
(defun structure-type-p (type)
(and (symbolp type)
- (let ((class (cl:find-class type nil)))
- (and class
- (typep (sb-kernel:layout-info (sb-kernel:class-layout class))
+ (let ((classoid (sb-kernel:find-classoid type nil)))
+ (and classoid
+ (typep (sb-kernel:layout-info
+ (sb-kernel:classoid-layout classoid))
'sb-kernel:defstruct-description)))))
\f
(/show "finished with early-low.lisp")
(defmethod make-load-form ((object wrapper) &optional env)
(declare (ignore env))
- (let ((pname (sb-kernel:class-proper-name (sb-kernel:layout-class object))))
+ (let ((pname (sb-kernel:classoid-proper-name
+ (sb-kernel:layout-classoid object))))
(unless pname
(error "can't dump wrapper for anonymous class:~% ~S"
- (sb-kernel:layout-class object)))
- `(sb-kernel:class-layout (cl:find-class ',pname))))
-\f
-;;;; The following are hacks to deal with CMU CL having two different CLASS
-;;;; classes.
-
-(defun coerce-to-pcl-class (class)
- (if (typep class 'cl:class)
- (or (sb-kernel:class-pcl-class class)
- (find-structure-class (cl:class-name class)))
- class))
-
-(defmethod make-instance ((class cl:class) &rest stuff)
- (apply #'make-instance (coerce-to-pcl-class class) stuff))
-(defmethod change-class (instance (class cl:class) &rest initargs)
- (apply #'change-class instance (coerce-to-pcl-class class) initargs))
-
-(macrolet ((frob (&rest names)
- `(progn
- ,@(mapcar (lambda (name)
- `(defmethod ,name ((class cl:class))
- (funcall #',name
- (coerce-to-pcl-class class))))
- names))))
- (frob
- class-direct-slots
- class-prototype
- class-precedence-list
- class-direct-default-initargs
- class-direct-superclasses
- compute-class-precedence-list
- class-default-initargs class-finalized-p
- class-direct-subclasses class-slots
- make-instances-obsolete))
+ (sb-kernel:layout-classoid object)))
+ `(sb-kernel:classoid-layout (sb-kernel:find-classoid ',pname))))
+
:slot-names (clos-slots name hash-code)
:boa-constructor %make-pcl-funcallable-instance
:superclass-name sb-kernel:funcallable-instance
- :metaclass-name sb-kernel:random-pcl-class
- :metaclass-constructor sb-kernel:make-random-pcl-class
+ :metaclass-name sb-kernel:random-pcl-classoid
+ :metaclass-constructor sb-kernel:make-random-pcl-classoid
:dd-type sb-kernel:funcallable-structure
;; Only internal implementation code will access these, and these
;; accesses (slot readers in particular) could easily be a
:slot-names (slots hash-code)
:boa-constructor %make-standard-instance
:superclass-name sb-kernel:instance
- :metaclass-name cl:standard-class
- :metaclass-constructor sb-kernel:make-standard-class
+ :metaclass-name sb-kernel:standard-classoid
+ :metaclass-constructor sb-kernel:make-standard-classoid
:dd-type structure
:runtime-type-checks-p nil)
;;; The definition of STRUCTURE-TYPE-P was moved to early-low.lisp.
(defun get-structure-dd (type)
- (sb-kernel:layout-info (sb-kernel:class-layout (cl:find-class type))))
+ (sb-kernel:layout-info (sb-kernel:classoid-layout
+ (sb-kernel:find-classoid type))))
(defun structure-type-included-type-name (type)
(let ((include (sb-kernel::dd-include (get-structure-dd type))))
\f
;;;; FIND-CLASS
;;;;
-;;;; This is documented in the CLOS specification. FIXME: Except that
-;;;; SBCL deviates from the spec by having CL:FIND-CLASS distinct from
-;;;; PCL:FIND-CLASS, alas.
+;;;; This is documented in the CLOS specification.
(/show "pcl/macros.lisp 119")
(find-class-cell-predicate cell))
(defun legal-class-name-p (x)
- (and (symbolp x)
- (not (keywordp x))))
+ (symbolp x))
(defun find-class (symbol &optional (errorp t) environment)
(declare (ignore environment))
(/show "pcl/macros.lisp 187")
-;;; Note that in SBCL as in CMU CL,
-;;; COMMON-LISP:FIND-CLASS /= SB-PCL:FIND-CLASS.
-;;; (Yes, this is a KLUDGE!)
(define-compiler-macro find-class (&whole form
symbol &optional (errorp t) environment)
(declare (ignore environment))
(or (find-class-cell-class ,class-cell)
,(if errorp
`(find-class-from-cell ',symbol ,class-cell t)
- `(and (sb-kernel:class-cell-class
- ',(sb-kernel:find-class-cell symbol))
+ `(and (sb-kernel:classoid-cell-classoid
+ ',(sb-kernel:find-classoid-cell symbol))
(find-class-from-cell ',symbol ,class-cell nil))))))
form))
(cond ((eq class *the-class-t*)
t)
((eq class *the-class-slot-object*)
- `(not (cl:typep (cl:class-of ,arg) 'cl:built-in-class)))
+ `(not (typep (sb-kernel:classoid-of ,arg)
+ 'sb-kernel:built-in-classoid)))
((eq class *the-class-std-object*)
`(or (std-instance-p ,arg) (fsc-instance-p ,arg)))
((eq class *the-class-standard-object*)
(defun named-object-print-function (instance stream
&optional (extra nil extra-p))
- (print-unreadable-object (instance stream :type t)
+ (print-unreadable-object (instance stream :type t :identity t)
(if extra-p
(format stream
"~S ~:S"
:definition-source `((defclass ,name)
,*load-pathname*)
other)))
- ;; Defclass of a class with a forward-referenced superclass does not
- ;; have a wrapper. RES is the incomplete PCL class. The Lisp class
- ;; does not yet exist. Maybe should return NIL in that case as RES
- ;; is not useful to the user?
- (and (class-wrapper res) (sb-kernel:layout-class (class-wrapper res)))))
+ res))
(setf (gdefinition 'load-defclass) #'real-load-defclass)
(defmethod ensure-class-using-class (name (class null) &rest args &key)
(multiple-value-bind (meta initargs)
(ensure-class-values class args)
+ (set-class-type-translation (class-prototype meta) name)
(setf class (apply #'make-instance meta :name name initargs)
(find-class name) class)
+ (set-class-type-translation class name)
class))
(defmethod ensure-class-using-class (name (class pcl-class) &rest args &key)
(unless (eq (class-of class) meta) (change-class class meta))
(apply #'reinitialize-instance class initargs)
(setf (find-class name) class)
+ (set-class-type-translation class name)
class))
(defmethod class-predicate-name ((class t))
(setf (slot-value class 'class-precedence-list)
(compute-class-precedence-list class))
(setf (slot-value class 'slots) (compute-slots class))
- (let ((lclass (cl:find-class (class-name class))))
- (setf (sb-kernel:class-pcl-class lclass) class)
- (setf (slot-value class 'wrapper) (sb-kernel:class-layout lclass)))
+ (let ((lclass (sb-kernel:find-classoid (class-name class))))
+ (setf (sb-kernel:classoid-pcl-class lclass) class)
+ (setf (slot-value class 'wrapper) (sb-kernel:classoid-layout lclass)))
(update-pv-table-cache-info class)
(setq predicate-name (if predicate-name-p
(setf (slot-value class 'predicate-name)
;;; Readers for Class Metaobjects (pp. 212--214 of AMOP)
(defclass red-herring (forward-ref) ())
-(assert (null (sb-pcl:class-direct-slots (sb-pcl:find-class 'forward-ref))))
+(assert (null (sb-pcl:class-direct-slots (find-class 'forward-ref))))
(assert (null (sb-pcl:class-direct-default-initargs
- (sb-pcl:find-class 'forward-ref))))
+ (find-class 'forward-ref))))
\f
;;; Readers for Generic Function Metaobjects (pp. 216--218 of AMOP)
(defgeneric fn-with-odd-arg-precedence (a b c)
\f
;;; Class Finalization Protocol (see section 5.5.2 of AMOP)
(let ((finalized-count 0))
- (defmethod sb-pcl:finalize-inheritance :after ((x sb-pcl::standard-class))
+ (defmethod sb-pcl:finalize-inheritance :after ((x standard-class))
(incf finalized-count))
(defun get-count () finalized-count))
(defclass finalization-test-1 () ())
;;; relationships. These aren't necessarily true, but are probably
;;; not going to change often.
(dolist (x '(number array sequence character symbol))
- (assert (eq (car (sb-pcl:class-direct-superclasses (sb-pcl:find-class x)))
- (sb-pcl:find-class t)))
- (assert (member (sb-pcl:find-class x)
- (sb-pcl:class-direct-subclasses (sb-pcl:find-class t)))))
+ (assert (eq (car (sb-pcl:class-direct-superclasses (find-class x)))
+ (find-class t)))
+ (assert (member (find-class x)
+ (sb-pcl:class-direct-subclasses (find-class t)))))
\f
;;;; success
(sb-ext:quit :unix-status 104)
(assert (subtypep 'simple-error 'error))
(assert (not (subtypep 'condition 'simple-condition)))
(assert (not (subtypep 'error 'simple-error)))
- (assert (eq (car (sb-kernel:class-direct-superclasses
+ (assert (eq (car (sb-pcl:class-direct-superclasses
(find-class 'simple-condition)))
(find-class 'condition)))
- (assert (eq (car (sb-pcl:class-direct-superclasses (sb-pcl:find-class
- 'simple-condition)))
- (sb-pcl:find-class 'condition)))
-
- (let ((subclasses (mapcar #'sb-pcl:find-class
+ (let ((subclasses (mapcar #'find-class
'(simple-type-error
simple-error
simple-warning
sb-int:simple-file-error
sb-int:simple-style-warning))))
(assert (null (set-difference
- (sb-pcl:class-direct-subclasses (sb-pcl:find-class
+ (sb-pcl:class-direct-subclasses (find-class
'simple-condition))
subclasses))))
;; precedence lists
(assert (equal (sb-pcl:class-precedence-list
- (sb-pcl:find-class 'simple-condition))
- (mapcar #'sb-pcl:find-class '(simple-condition
- condition
- sb-kernel:instance
- t))))
+ (find-class 'simple-condition))
+ (mapcar #'find-class '(simple-condition
+ condition
+ sb-kernel:instance
+ t))))
;; stream classes
- (assert (null (sb-kernel:class-direct-superclasses
- (find-class 'fundamental-stream))))
- (assert (equal (sb-pcl:class-direct-superclasses (sb-pcl:find-class
+ (assert (equal (sb-pcl:class-direct-superclasses (find-class
'fundamental-stream))
- (mapcar #'sb-pcl:find-class '(standard-object stream))))
+ (mapcar #'find-class '(standard-object stream))))
(assert (null (set-difference
- (sb-pcl:class-direct-subclasses (sb-pcl:find-class
+ (sb-pcl:class-direct-subclasses (find-class
'fundamental-stream))
- (mapcar #'sb-pcl:find-class '(fundamental-binary-stream
- fundamental-character-stream
- fundamental-output-stream
- fundamental-input-stream)))))
- (assert (equal (sb-pcl:class-precedence-list (sb-pcl:find-class
+ (mapcar #'find-class '(fundamental-binary-stream
+ fundamental-character-stream
+ fundamental-output-stream
+ fundamental-input-stream)))))
+ (assert (equal (sb-pcl:class-precedence-list (find-class
'fundamental-stream))
- (mapcar #'sb-pcl:find-class '(fundamental-stream
- standard-object
- sb-pcl::std-object
- sb-pcl::slot-object
- stream
- sb-kernel:instance
- t))))
- (assert (equal (sb-pcl:class-precedence-list (sb-pcl:find-class
+ (mapcar #'find-class '(fundamental-stream
+ standard-object
+ sb-pcl::std-object
+ sb-pcl::slot-object
+ stream
+ sb-kernel:instance
+ t))))
+ (assert (equal (sb-pcl:class-precedence-list (find-class
'fundamental-stream))
- (mapcar #'sb-pcl:find-class '(fundamental-stream
- standard-object
- sb-pcl::std-object
- sb-pcl::slot-object stream
- sb-kernel:instance t))))
+ (mapcar #'find-class '(fundamental-stream
+ standard-object
+ sb-pcl::std-object
+ sb-pcl::slot-object stream
+ sb-kernel:instance t))))
(assert (subtypep (find-class 'stream) (find-class t)))
(assert (subtypep (find-class 'fundamental-stream) 'stream))
(assert (not (subtypep 'stream 'fundamental-stream)))))
;;; versions, especially for internal versions off the main CVS
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.7.13.32"
+"0.7.13.pcl-class.1"
projects / sbcl.git / commitdiff