** GETF and GET-PROPERTIES throw a TYPE-ERROR, not a SIMPLE-ERROR,
on malformed property lists;
+changes in sbcl-0.8.0 relative to sbcl-0.7.14
+ * the old distinction between CL:CLASS objects and SB-PCL:CLASS
+ objects has been removed. The return value from CL:FIND-CLASS is
+ now a CLOS class, and likewise that of CL:CLASS-OF;
+ CL:BUILT-IN-CLASS, CL:STRUCTURE-CLASS and CL:STANDARD-CLASS name
+ CLOS classes.
+ * an interface to the MetaObject Protocol, as described in Kiczales,
+ des Rivieres and Bobrow's "The Art of the Metaobject Protocol",
+ MIT Press, 1991, is available from the SB-MOP package.
+ * incompatible change: the SB-PCL package should now be considered a
+ private implementation detail, and no longer a semi-private MOP
+ interface.
+
planned incompatible changes in 0.7.x:
* (not done yet, but planned:) When the profiling interface settles
down, maybe in 0.7.x, maybe later, it might impact TRACE. They both
"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"
+ "DD-INCLUDE"
"%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"
+ "DSD-DEFAULT"
"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"
+ "BUILT-IN-CLASSOID-TRANSLATION"
"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"
+ "CONDITION-CLASSOID-P"
+ "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
:export ())
#s(sb-cold:package-data
+ :name "SB!MOP"
+ :doc
+ "public: the MetaObject Protocol interface, as defined by
+The Art of the Metaobject Protocol, by Kiczales, des Rivieres and Bobrow:
+ISBN 0-262-61074-4."
+ :use ("SB!PCL")
+ :reexport ("ADD-DEPENDENT"
+ "ADD-DIRECT-METHOD"
+ "ADD-DIRECT-SUBCLASS"
+ "ADD-METHOD"
+ "ALLOCATE-INSTANCE"
+ "CLASS-DEFAULT-INITARGS"
+ "CLASS-DIRECT-DEFAULT-INITARGS"
+ "CLASS-DIRECT-SLOTS"
+ "CLASS-DIRECT-SUBCLASSES"
+ "CLASS-DIRECT-SUPERCLASSES"
+ "CLASS-FINALIZED-P"
+ "CLASS-NAME"
+ "CLASS-PRECEDENCE-LIST"
+ "CLASS-PROTOTYPE"
+ "CLASS-SLOTS"
+ "COMPUTE-APPLICABLE-METHODS"
+ "COMPUTE-APPLICABLE-METHODS-USING-CLASSES"
+ "COMPUTE-CLASS-PRECEDENCE-LIST"
+ "COMPUTE-DEFAULT-INITARGS"
+ "COMPUTE-DISCRIMINATING-FUNCTION"
+ "COMPUTE-EFFECTIVE-METHOD"
+ "COMPUTE-EFFECTIVE-SLOT-DEFINITION"
+ "COMPUTE-SLOTS"
+ "DIRECT-SLOT-DEFINITION-CLASS"
+ "EFFECTIVE-SLOT-DEFINITION-CLASS"
+ "ENSURE-CLASS"
+ "ENSURE-CLASS-USING-CLASS"
+ "ENSURE-GENERIC-FUNCTION"
+ "ENSURE-GENERIC-FUNCTION-USING-CLASS"
+ "EQL-SPECIALIZER-OBJECT"
+ "EXTRACT-LAMBDA-LIST"
+ "EXTRACT-SPECIALIZER-NAMES"
+ "FINALIZE-INHERITANCE"
+ "FIND-METHOD-COMBINATION"
+ "FUNCALLABLE-STANDARD-INSTANCE-ACCESS"
+ "GENERIC-FUNCTION-ARGUMENT-PRECEDENCE-ORDER"
+ "GENERIC-FUNCTION-DECLARATIONS"
+ "GENERIC-FUNCTION-LAMBDA-LIST"
+ "GENERIC-FUNCTION-METHOD-CLASS"
+ "GENERIC-FUNCTION-METHOD-COMBINATION"
+ "GENERIC-FUNCTION-METHODS"
+ "GENERIC-FUNCTION-NAME"
+ "INTERN-EQL-SPECIALIZER"
+ "MAKE-METHOD-LAMBDA"
+ "MAKE-INSTANCE"
+ "MAP-DEPENDENTS"
+ "METHOD-FUNCTION"
+ "METHOD-GENERIC-FUNCTION"
+ "METHOD-LAMBDA-LIST"
+ "METHOD-QUALIFIERS"
+ "METHOD-SPECIALIZERS"
+ "ACCESSOR-METHOD-SLOT-DEFINITION"
+ "READER-METHOD-CLASS"
+ "REMOVE-DEPENDENT"
+ "REMOVE-DIRECT-METHOD"
+ "REMOVE-DIRECT-SUBCLASS"
+ "REMOVE-METHOD"
+ "SET-FUNCALLABLE-INSTANCE-FUNCTION"
+ "SLOT-BOUNDP-USING-CLASS"
+ "SLOT-DEFINITION-ALLOCATION"
+ "SLOT-DEFINITION-INITARGS"
+ "SLOT-DEFINITION-INITFORM"
+ "SLOT-DEFINITION-INITFUNCTION"
+ "SLOT-DEFINITION-LOCATION"
+ "SLOT-DEFINITION-NAME"
+ "SLOT-DEFINITION-READERS"
+ "SLOT-DEFINITION-WRITERS"
+ "SLOT-DEFINITION-TYPE"
+ "SLOT-MAKUNBOUND-USING-CLASS"
+ "SLOT-VALUE-USING-CLASS"
+ "SPECIALIZER-DIRECT-GENERIC-FUNCTIONS"
+ "SPECIALIZER-DIRECT-METHODS"
+ "STANDARD-INSTANCE-ACCESS"
+ "UPDATE-DEPENDENT"
+ "VALIDATE-SUPERCLASS"
+ "WRITER-METHOD-CLASS"))
+
+ #s(sb-cold:package-data
:name "SB!PCL"
:doc
"semi-public: This package includes useful meta-object protocol
extensions, but even they are not guaranteed to be present in
later versions of SBCL, and the other stuff in here is
definitely not guaranteed to be present in later versions of SBCL."
- ;; FIXME: SB-PCL should probably USE-PACKAGE SB-KERNEL, since SB-PCL
- ;; is built on SB-KERNEL, and in the absence of USE-PACKAGE, it ends
- ;; up using a thundering herd of explicit prefixes to get to
- ;; SB-KERNEL symbols. However, it'll probably be too messy to do
- ;; this until the duplicate SB-PCL:CLASS/CL:CLASS hierarchy kludge
- ;; is unscrewed, since until it is there are too many things which
- ;; conflict between the two packages.
- :use ("CL" "SB!INT" "SB!EXT" "SB!WALKER")
- :import-from (("SB!KERNEL" "FUNCALLABLE-INSTANCE-P" "%FUN-DOC"
- "PACKAGE-DOC-STRING"
- "PACKAGE-HASHTABLE-SIZE" "PACKAGE-HASHTABLE-FREE"
- "PACKAGE-INTERNAL-SYMBOLS" "PACKAGE-EXTERNAL-SYMBOLS"))
+ :use ("CL" "SB!INT" "SB!EXT" "SB!WALKER" "SB!KERNEL")
:reexport ("ADD-METHOD" "ALLOCATE-INSTANCE"
- "COMPUTE-APPLICABLE-METHODS"
- "ENSURE-GENERIC-FUNCTION"
- "MAKE-INSTANCE" "METHOD-QUALIFIERS"
- "REMOVE-METHOD")
+ "CLASS-NAME" "COMPUTE-APPLICABLE-METHODS"
+ "ENSURE-GENERIC-FUNCTION" "MAKE-INSTANCE"
+ "METHOD-QUALIFIERS" "REMOVE-METHOD")
:export ("ADD-DEPENDENT"
"ADD-DIRECT-METHOD"
"ADD-DIRECT-SUBCLASS"
"CLASS-SLOTS"
"COMPUTE-APPLICABLE-METHODS-USING-CLASSES"
"COMPUTE-CLASS-PRECEDENCE-LIST"
+ "COMPUTE-DEFAULT-INITARGS"
"COMPUTE-DISCRIMINATING-FUNCTION"
"COMPUTE-EFFECTIVE-METHOD"
"COMPUTE-EFFECTIVE-SLOT-DEFINITION"
"ENSURE-CLASS"
"ENSURE-CLASS-USING-CLASS"
"ENSURE-GENERIC-FUNCTION-USING-CLASS"
- "EQL-SPECIALIZER-INSTANCE"
+ "EQL-SPECIALIZER-OBJECT"
"EXTRACT-LAMBDA-LIST"
"EXTRACT-SPECIALIZER-NAMES"
"FINALIZE-INHERITANCE"
"REMOVE-DEPENDENT"
"REMOVE-DIRECT-METHOD"
"REMOVE-DIRECT-SUBCLASS"
- "SET-FUNCALLABLE-INSTANCE-FUN"
+ "SET-FUNCALLABLE-INSTANCE-FUNCTION"
"SLOT-BOUNDP-USING-CLASS"
"SLOT-DEFINITION-ALLOCATION"
"SLOT-DEFINITION-INITARGS"
"SLOT-DEFINITION-TYPE"
"SLOT-MAKUNBOUND-USING-CLASS"
"SLOT-VALUE-USING-CLASS"
- "SPECIALIZER-DIRECT-GENERIC-FUNCTION"
+ "SPECIALIZER-DIRECT-GENERIC-FUNCTIONS"
"SPECIALIZER-DIRECT-METHODS"
"STANDARD-INSTANCE-ACCESS"
"UPDATE-DEPENDENT"
;;;; This file contains structures and functions for the maintenance of
;;;; basic information about defined types. Different object systems
-;;;; can be supported simultaneously. Some of the functions here are
-;;;; nominally generic, and are overwritten when CLOS is loaded.
+;;;; can be supported simultaneously.
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
(!begin-collecting-cold-init-forms)
\f
-;;;; the CLASS structure
+;;;; the CLASSOID structure
-;;; The CLASS structure is a supertype of all class types. A CLASS is
-;;; also a CTYPE structure as recognized by the type system.
-(def!struct (;; FIXME: Yes, these #+SB-XC/#-SB-XC conditionals are
- ;; pretty hairy. I'm considering cleaner ways to rewrite
- ;; the whole build system to avoid these (and other hacks
- ;; too, e.g. UNCROSS) but I'm not sure yet that I've got
- ;; it figured out. -- WHN 19990729
- #-sb-xc sb!xc:class
- #+sb-xc cl:class
- (:make-load-form-fun class-make-load-form-fun)
+;;; The CLASSOID structure is a supertype of all classoid types. A
+;;; CLASSOID is also a CTYPE structure as recognized by the type
+;;; system. (FIXME: It's also a type specifier, though this might go
+;;; away as with the merger of SB-PCL:CLASS and CL:CLASS it's no
+;;; longer necessary)
+(def!struct (classoid
+ (:make-load-form-fun classoid-make-load-form-fun)
(:include ctype
- (class-info (type-class-or-lose #-sb-xc 'sb!xc:class
- #+sb-xc 'cl:class)))
+ (class-info (type-class-or-lose 'classoid)))
(:constructor nil)
#-no-ansi-print-object
(:print-object
(lambda (class stream)
- (let ((name (sb!xc:class-name class)))
+ (let ((name (classoid-name class)))
(print-unreadable-object (class stream
:type t
:identity (not name))
;; reasonably for anonymous classes.
"~:[anonymous~;~:*~S~]~@[ (~(~A~))~]"
name
- (class-state class))))))
+ (classoid-state class))))))
#-sb-xc-host (:pure nil))
- ;; the value to be returned by CLASS-NAME. (CMU CL used the raw slot
- ;; accessor for this slot directly as the definition of
- ;; CL:CLASS-NAME, but that was slightly wrong, because ANSI says
- ;; that CL:CLASS-NAME is a generic function.)
- (%name nil :type symbol)
+ ;; the value to be returned by CLASSOID-NAME.
+ (name nil :type symbol)
;; the current layout for this class, or NIL if none assigned yet
(layout nil :type (or layout null))
;; How sure are we that this class won't be redefined?
(direct-superclasses () :type list)
;; representation of all of the subclasses (direct or indirect) of
;; this class. This is NIL if no subclasses or not initalized yet;
- ;; otherwise, it's an EQ hash-table mapping CL:CLASS objects to the
+ ;; otherwise, it's an EQ hash-table mapping CLASSOID objects to the
;; subclass layout that was in effect at the time the subclass was
;; created.
(subclasses nil :type (or null hash-table))
- ;; the PCL class object for this class, or NIL if none assigned yet
+ ;; the PCL class (= CL:CLASS, but with a view to future flexibility
+ ;; we don't just call it the CLASS slot) object for this class, or
+ ;; NIL if none assigned yet
(pcl-class nil))
-;;; KLUDGE: ANSI says this is a generic function, but we need it for
-;;; bootstrapping before CLOS exists, so we define it as an ordinary
-;;; function and let CLOS code overwrite it later. -- WHN ca. 19990815
-(defun sb!xc:class-name (class)
- (class-%name class))
-
-(defun class-make-load-form-fun (class)
- (/show "entering CLASS-MAKE-LOAD-FORM-FUN" class)
- (let ((name (sb!xc:class-name class)))
- (unless (and name (eq (sb!xc:find-class name nil) class))
+(defun classoid-make-load-form-fun (class)
+ (/show "entering CLASSOID-MAKE-LOAD-FORM-FUN" class)
+ (let ((name (classoid-name class)))
+ (unless (and name (eq (find-classoid name nil) class))
(/show "anonymous/undefined class case")
(error "can't use anonymous or undefined class as constant:~% ~S"
class))
`(locally
- ;; KLUDGE: There's a FIND-CLASS DEFTRANSFORM for constant class
- ;; names which creates fast but non-cold-loadable, non-compact
- ;; code. In this context, we'd rather have compact,
+ ;; KLUDGE: There's a FIND-CLASSOID DEFTRANSFORM for constant
+ ;; class names which creates fast but non-cold-loadable,
+ ;; non-compact code. In this context, we'd rather have compact,
;; cold-loadable code. -- WHN 19990928
- (declare (notinline sb!xc:find-class))
- (sb!xc:find-class ',name))))
+ (declare (notinline find-classoid))
+ (find-classoid ',name))))
\f
;;;; basic LAYOUT stuff
(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,
+;;; If LAYOUT is uninitialized, initialize it with CLASSOID, LENGTH,
;;; INHERITS, and DEPTHOID, otherwise require that it be consistent
-;;; with CLASS, LENGTH, INHERITS, and DEPTHOID.
+;;; with CLASSOID, LENGTH, INHERITS, and DEPTHOID.
;;;
;;; UNDEFINED-CLASS values are interpreted specially as "we don't know
;;; anything about the class", so if LAYOUT is initialized, any
;;; preexisting class slot value is OK, and if it's not initialized,
;;; its class slot value is set to an UNDEFINED-CLASS. -- FIXME: This
;;; is no longer true, :UNINITIALIZED used instead.
-(declaim (ftype (function (layout sb!xc:class index simple-vector layout-depthoid) layout)
+(declaim (ftype (function (layout classoid index simple-vector layout-depthoid)
+ layout)
init-or-check-layout))
-(defun init-or-check-layout (layout class length inherits depthoid)
+(defun init-or-check-layout (layout classoid length inherits depthoid)
(cond ((eq (layout-invalid layout) :uninitialized)
;; There was no layout before, we just created one which
;; we'll now initialize with our information.
(setf (layout-length layout) length
(layout-inherits layout) inherits
(layout-depthoid layout) depthoid
- (layout-class layout) class
+ (layout-classoid layout) classoid
(layout-invalid layout) nil))
;; FIXME: Now that LAYOUTs are born :UNINITIALIZED, maybe this
;; clause is not needed?
((not *type-system-initialized*)
- (setf (layout-class layout) class))
+ (setf (layout-classoid layout) classoid))
(t
;; There was an old layout already initialized with old
;; information, and we'll now check that old information
;; which was known with certainty is consistent with current
;; information which is known with certainty.
- (check-layout layout class length inherits depthoid)))
+ (check-layout layout classoid length inherits depthoid)))
layout)
;;; In code for the target Lisp, we don't use dump LAYOUTs using the
(declare (ignore env))
(when (layout-invalid layout)
(compiler-error "can't dump reference to obsolete class: ~S"
- (layout-class layout)))
- (let ((name (sb!xc:class-name (layout-class layout))))
+ (layout-classoid layout)))
+ (let ((name (classoid-name (layout-classoid layout))))
(unless name
(compiler-error "can't dump anonymous LAYOUT: ~S" layout))
;; Since LAYOUT refers to a class which refers back to the LAYOUT,
;; "initialization" form (which actually doesn't initialize
;; preexisting LAYOUTs, just checks that they're consistent).
`(init-or-check-layout ',layout
- ',(layout-class layout)
+ ',(layout-classoid layout)
',(layout-length layout)
',(layout-inherits layout)
',(layout-depthoid layout)))))
;;; Require that LAYOUT data be consistent with CLASS, LENGTH,
;;; INHERITS, and DEPTHOID.
-(declaim (ftype (function (layout sb!xc:class index simple-vector layout-depthoid))
+(declaim (ftype (function
+ (layout classoid index simple-vector layout-depthoid))
check-layout))
-(defun check-layout (layout class length inherits depthoid)
- (aver (eq (layout-class layout) class))
+(defun check-layout (layout classoid length inherits depthoid)
+ (aver (eq (layout-classoid layout) classoid))
(when (redefine-layout-warning "current" layout
"compile time" length inherits depthoid)
;; Classic CMU CL had more options here. There are several reasons
(defun find-and-init-or-check-layout (name length inherits depthoid)
(let ((layout (find-layout name)))
(init-or-check-layout layout
- (or (sb!xc:find-class name nil)
- (make-undefined-class name))
+ (or (find-classoid name nil)
+ (make-undefined-classoid name))
length
inherits
depthoid)))
(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
(defun register-layout (layout &key (invalidate t) destruct-layout)
(declare (type layout layout) (type (or layout null) destruct-layout))
- (let* ((class (layout-class layout))
- (class-layout (class-layout class))
- (subclasses (class-subclasses class)))
+ (let* ((classoid (layout-classoid layout))
+ (classoid-layout (classoid-layout classoid))
+ (subclasses (classoid-subclasses classoid)))
;; Attempting to register ourselves with a temporary undefined
;; class placeholder is almost certainly a programmer error. (I
;; should know, I did it.) -- WHN 19990927
- (aver (not (undefined-class-p class)))
+ (aver (not (undefined-classoid-p classoid)))
;; This assertion dates from classic CMU CL. The rationale is
;; probably that calling REGISTER-LAYOUT more than once for the
;; same LAYOUT is almost certainly a programmer error.
- (aver (not (eq class-layout layout)))
+ (aver (not (eq classoid-layout layout)))
;; Figure out what classes are affected by the change, and issue
;; appropriate warnings and invalidations.
- (when class-layout
- (modify-class class)
+ (when classoid-layout
+ (modify-classoid classoid)
(when subclasses
(dohash (subclass subclass-layout subclasses)
- (modify-class subclass)
+ (modify-classoid subclass)
(when invalidate
(invalidate-layout subclass-layout))))
(when invalidate
- (invalidate-layout class-layout)
- (setf (class-subclasses class) nil)))
+ (invalidate-layout classoid-layout)
+ (setf (classoid-subclasses classoid) nil)))
(if destruct-layout
(setf (layout-invalid destruct-layout) nil
(layout-depthoid destruct-layout)(layout-depthoid layout)
(layout-length destruct-layout) (layout-length layout)
(layout-info destruct-layout) (layout-info layout)
- (class-layout class) destruct-layout)
+ (classoid-layout classoid) destruct-layout)
(setf (layout-invalid layout) nil
- (class-layout class) layout))
+ (classoid-layout classoid) layout))
(let ((inherits (layout-inherits layout)))
(dotimes (i (length inherits)) ; FIXME: should be DOVECTOR
- (let* ((super (layout-class (svref inherits i)))
- (subclasses (or (class-subclasses super)
- (setf (class-subclasses super)
+ (let* ((super (layout-classoid (svref inherits i)))
+ (subclasses (or (classoid-subclasses super)
+ (setf (classoid-subclasses super)
(make-hash-table :test 'eq)))))
- (when (and (eq (class-state super) :sealed)
- (not (gethash class subclasses)))
+ (when (and (eq (classoid-state super) :sealed)
+ (not (gethash classoid subclasses)))
(warn "unsealing sealed class ~S in order to subclass it"
- (sb!xc:class-name super))
- (setf (class-state super) :read-only))
- (setf (gethash class subclasses)
+ (classoid-name super))
+ (setf (classoid-state super) :read-only))
+ (setf (gethash classoid subclasses)
(or destruct-layout layout))))))
(values))
(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)))
+ ;; KLUDGE: The reason these clauses aren't directly parallel is
+ ;; that we need to use the internal CLASSOID structure ourselves,
+ ;; because we don't have CLASSes to work with until PCL is built.
+ ;; In the host, CLASSes have an approximately one-to-one
+ ;; correspondence with the target CLASSOIDs (as well as with the
+ ;; target CLASSes, modulo potential differences with respect to
+ ;; conditions).
+ #+sb-xc-host
+ (let ((old (class-of (find-classoid name)))
(new (class-of new-value)))
(unless (eq old new)
+ (bug "trying to change the metaclass of ~S from ~S to ~S in the ~
+ cross-compiler."
+ name (class-name old) (class-name new))))
+ #-sb-xc-host
+ (let ((old (classoid-of (find-classoid name)))
+ (new (classoid-of new-value)))
+ (unless (eq old new)
(warn "changing meta-class of ~S from ~S to ~S"
- name
- (class-name old)
- (class-name new)))))
+ name (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))
(t
(let* (;; FIXME: This automatic promotion of FOO-style
: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)
;; Now that all package-package references exist, we can handle
;; REEXPORT operations. (We have to wait until now because they
- ;; interact with USE operations.) KLUDGE: This code doesn't detect
- ;; dependencies and do exports in proper order to work around them, so
- ;; it could break randomly (with build-time errors, not with silent
- ;; errors or runtime errors) if multiple levels of re-exportation are
- ;; used, e.g. package A exports X, package B uses A and reexports X,
- ;; and package C uses B and reexports X. That doesn't seem to be an
- ;; issue in the current code, and it's hard to see why anyone would
- ;; want to do it, and it should be straightforward (though tedious) to
- ;; extend the code here to deal with that if it ever becomes necessary.
- (dolist (package-data package-data-list)
- (let ((package (find-package (package-data-name package-data))))
- (dolist (symbol-name (package-data-reexport package-data))
- (multiple-value-bind (symbol status)
- (find-symbol symbol-name package)
- (unless status
- (error "No symbol named ~S is accessible in ~S."
- symbol-name
- package))
- (when (eq (symbol-package symbol) package)
- (error "~S is not inherited/imported, but native to ~S."
- symbol-name
- package))
- (export symbol package))))))
+ ;; interact with USE operations.) This code handles dependencies
+ ;; properly, but is somewhat ugly.
+ (let (done)
+ (labels
+ ((reexport (package-data)
+ (let ((package (find-package (package-data-name package-data))))
+ (cond
+ ((member package done))
+ ((null (package-data-reexport package-data))
+ (push package done))
+ (t
+ (mapcar #'reexport
+ (remove-if-not
+ (lambda (x)
+ (member x (package-data-use package-data)
+ :test #'string=))
+ package-data-list
+ :key #'package-data-name))
+ (dolist (symbol-name (package-data-reexport package-data))
+ (multiple-value-bind (symbol status)
+ (find-symbol symbol-name package)
+ (unless status
+ (error "No symbol named ~S is accessible in ~S."
+ symbol-name package))
+ (when (eq (symbol-package symbol) package)
+ (error
+ "~S is not inherited/imported, but native to ~S."
+ symbol-name package))
+ (export symbol package)))
+ (push package done))))))
+ (dolist (x package-data-list)
+ (reexport x))
+ (assert (= (length done) (length package-data-list))))))
\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))
#',fun-name))))
(defun compile-or-load-defgeneric (fun-name)
- (sb-kernel:proclaim-as-fun-name fun-name)
- (sb-kernel:note-name-defined fun-name :function)
+ (proclaim-as-fun-name fun-name)
+ (note-name-defined fun-name :function)
(unless (eq (info :function :where-from fun-name) :declared)
(setf (info :function :where-from fun-name) :defined)
(setf (info :function :type fun-name)
- (sb-kernel:specifier-type 'function))))
+ (specifier-type 'function))))
(defun load-defgeneric (fun-name lambda-list &rest initargs)
(when (fboundp fun-name)
- (sb-kernel::style-warn "redefining ~S in DEFGENERIC" fun-name)
+ (style-warn "redefining ~S in DEFGENERIC" fun-name)
(let ((fun (fdefinition fun-name)))
(when (generic-function-p fun)
(loop for method in (generic-function-initial-methods fun)
(parse-specializers specializers)
nil))))
(when method
- (sb-kernel::style-warn "redefining ~S~{ ~S~} ~S in DEFMETHOD"
- gf-spec qualifiers specializers))))
+ (style-warn "redefining ~S~{ ~S~} ~S in DEFMETHOD"
+ gf-spec qualifiers specializers))))
(let ((method (apply #'add-named-method
gf-spec qualifiers specializers lambda-list
:definition-source `((defmethod ,gf-spec
(analyze-lambda-list lambda-list)
(declare (ignore keyword-parameters))
(let* ((old (info :function :type name)) ;FIXME:FDOCUMENTATION instead?
- (old-ftype (if (sb-kernel:fun-type-p old) old nil))
- (old-restp (and old-ftype (sb-kernel:fun-type-rest old-ftype)))
+ (old-ftype (if (fun-type-p old) old nil))
+ (old-restp (and old-ftype (fun-type-rest old-ftype)))
(old-keys (and old-ftype
- (mapcar #'sb-kernel:key-info-name
- (sb-kernel:fun-type-keywords
+ (mapcar #'key-info-name
+ (fun-type-keywords
old-ftype))))
- (old-keysp (and old-ftype (sb-kernel:fun-type-keyp old-ftype)))
+ (old-keysp (and old-ftype (fun-type-keyp old-ftype)))
(old-allowp (and old-ftype
- (sb-kernel:fun-type-allowp old-ftype)))
+ (fun-type-allowp old-ftype)))
(keywords (union old-keys (mapcar #'keyword-spec-name keywords))))
`(function ,(append (make-list nrequired :initial-element t)
(when (plusp noptional)
(defun make-early-gf (spec &optional lambda-list lambda-list-p
function argument-precedence-order)
(let ((fin (allocate-funcallable-instance *sgf-wrapper* *sgf-slots-init*)))
- (set-funcallable-instance-fun
+ (set-funcallable-instance-function
fin
(or function
(if (eq spec 'print-object)
- #'(sb-kernel:instance-lambda (instance stream)
+ #'(instance-lambda (instance stream)
(print-unreadable-object (instance stream :identity t)
(format stream "std-instance")))
- #'(sb-kernel:instance-lambda (&rest args)
+ #'(instance-lambda (&rest args)
(declare (ignore args))
(error "The function of the funcallable-instance ~S~
has not been set." fin)))))
(slots-init nil slots-init-p))
(let ((fin (%make-pcl-funcallable-instance nil nil
(get-instance-hash-code))))
- (set-funcallable-instance-fun
+ (set-funcallable-instance-function
fin
- #'(sb-kernel:instance-lambda (&rest args)
+ #'(instance-lambda (&rest args)
(declare (ignore args))
(error "The function of the funcallable-instance ~S has not been set."
fin)))
(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))
(metaclass-name class name
class-eq-wrapper source direct-supers direct-subclasses cpl wrapper
&optional
- proto direct-slots slots direct-default-initargs default-initargs)
+ (proto nil proto-p)
+ direct-slots slots direct-default-initargs default-initargs)
(flet ((classes (names) (mapcar #'find-class names))
(set-slot (slot-name value)
(!bootstrap-set-slot metaclass-name class slot-name value)))
(set-slot 'from-defclass-p t)
(set-slot 'plist nil)
(set-slot 'prototype (funcall constructor-sym)))
- (set-slot 'prototype (or proto (allocate-standard-instance wrapper))))
+ (set-slot 'prototype
+ (if proto-p proto (allocate-standard-instance wrapper))))
class))
(defun !bootstrap-make-slot-definitions (name class slots wrapper effective-p)
(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 (find-classoid name))
+ (wrapper (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 (classoid-pcl-class lclass) class)
(!bootstrap-initialize-class 'built-in-class class
name class-eq-wrapper nil
(make-class-predicate class (class-predicate-name class))))))
\f
(defmacro wrapper-of-macro (x)
- `(sb-kernel:layout-of ,x))
+ `(layout-of ,x))
(defun class-of (x)
(wrapper-class* (wrapper-of-macro x)))
(defun wrapper-of (x)
(wrapper-of-macro x))
-(defvar *find-structure-class* nil)
-
(defun eval-form (form)
(lambda () (eval form)))
:initform ,(structure-slotd-init-form slotd)
:initfunction ,(eval-form (structure-slotd-init-form slotd))))
-(defun find-structure-class (symbol)
- (if (structure-type-p symbol)
- (unless (eq *find-structure-class* symbol)
- (let ((*find-structure-class* symbol))
- (ensure-class symbol
- :metaclass 'structure-class
- :name symbol
- :direct-superclasses
- (mapcar #'cl:class-name
- (sb-kernel:class-direct-superclasses
- (cl:find-class symbol)))
- :direct-slots
- (mapcar #'slot-initargs-from-structure-slotd
- (structure-type-slot-description-list
- symbol)))))
- (error "~S is not a legal structure class name." symbol)))
+(defun ensure-non-standard-class (name)
+ (flet
+ ((ensure (metaclass &optional (slots nil slotsp))
+ (let ((supers
+ (mapcar #'classoid-name (classoid-direct-superclasses
+ (find-classoid name)))))
+ (if slotsp
+ (ensure-class-using-class name nil
+ :metaclass metaclass :name name
+ :direct-superclasses supers
+ :direct-slots slots)
+ (ensure-class-using-class name nil
+ :metaclass metaclass :name name
+ :direct-superclasses supers)))))
+ (cond ((structure-type-p name)
+ (ensure 'structure-class
+ (mapcar #'slot-initargs-from-structure-slotd
+ (structure-type-slot-description-list name))))
+ ((condition-type-p name)
+ (ensure 'condition-class))
+ (t
+ (error "~@<~S is not the name of a class.~@:>" name)))))
\f
(defun make-class-predicate (class name)
(let* ((gf (ensure-generic-function name))
;;; 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)
- (setf (sb-kernel:layout-inherits layout)
- (sb-kernel:order-layout-inherits
+ (let ((lclass (layout-classoid layout)))
+ (unless (eq (classoid-layout lclass) layout)
+ (setf (layout-inherits layout)
+ (order-layout-inherits
(map 'simple-vector #'class-wrapper
(reverse (rest (class-precedence-list class))))))
- (sb-kernel:register-layout layout :invalidate t)
+ (register-layout layout :invalidate t)
;; Subclasses of formerly forward-referenced-class may be
;; 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 (find-classoid name) lclass
+ (classoid-name lclass) name)))))
+
+(defun set-class-type-translation (class name)
+ (let ((classoid (find-classoid name nil)))
+ (etypecase classoid
+ (null)
+ (built-in-classoid
+ (let ((translation (built-in-classoid-translation classoid)))
+ (cond
+ (translation
+ (aver (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))))))
+ (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 (layout-classoid layout))
+ (lclass-pcl-class (classoid-pcl-class lclass))
+ (olclass (find-classoid name nil)))
(if lclass-pcl-class
(aver (eq class lclass-pcl-class))
- (setf (sb-kernel:class-pcl-class lclass) class))
+ (setf (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 (find-classoid name) lclass)))
+
+ (set-class-type-translation class name)))
(setq *boot-state* 'braid)
1 (the fixnum (1+ old-count))))))))
(deftype field-type ()
- '(mod #.sb-kernel:layout-clos-hash-length))
+ '(mod #.layout-clos-hash-length))
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun power-of-two-ceiling (x)
;;; are the forms of this constant which it is more convenient for the
;;; runtime code to use.
(defconstant wrapper-cache-number-length
- (integer-length sb-kernel:layout-clos-hash-max))
-(defconstant wrapper-cache-number-mask sb-kernel:layout-clos-hash-max)
+ (integer-length layout-clos-hash-max))
+(defconstant wrapper-cache-number-mask layout-clos-hash-max)
(defconstant wrapper-cache-number-adds-ok
- (truncate most-positive-fixnum sb-kernel:layout-clos-hash-max))
+ (truncate most-positive-fixnum layout-clos-hash-max))
\f
;;;; wrappers themselves
;;; have a fixed number of cache hash values, and that number must
;;; correspond to the number of cache lines we use.
(defconstant wrapper-cache-number-vector-length
- sb-kernel:layout-clos-hash-length)
+ layout-clos-hash-length)
(unless (boundp '*the-class-t*)
(setq *the-class-t* nil))
(defmacro wrapper-class (wrapper)
- `(sb-kernel:class-pcl-class (sb-kernel:layout-class ,wrapper)))
+ `(classoid-pcl-class (layout-classoid ,wrapper)))
(defmacro wrapper-no-of-instance-slots (wrapper)
- `(sb-kernel:layout-length ,wrapper))
+ `(layout-length ,wrapper))
(defmacro wrapper-instance-slots-layout (wrapper)
`(%wrapper-instance-slots-layout ,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 (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 (classoid-pcl-class found)
+ (setf (classoid-pcl-class found) class))
+ (aver (eq (classoid-pcl-class found) class))
+ (let ((layout (classoid-layout found)))
(aver layout)
layout))
(t
(make-wrapper-internal
:length length
- :class (sb-kernel:make-standard-class :name name :pcl-class class))))))
+ :classoid (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))
+ (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 (find-classoid
+ (slot-value class 'name))))
+ (unless (classoid-pcl-class found)
+ (setf (classoid-pcl-class found) class))
+ (aver (eq (classoid-pcl-class found) class))
found))
(t
- (sb-kernel:make-standard-class :pcl-class class))))
+ (make-standard-classoid :pcl-class class))))
(t
- (sb-kernel:make-random-pcl-class :pcl-class class))))))
+ (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 (find-classoid (slot-value class 'name)))
+ (layout (classoid-layout found)))
+ (unless (classoid-pcl-class found)
+ (setf (classoid-pcl-class found) class))
+ (aver (eq (classoid-pcl-class found) class))
(aver layout)
layout))))
(defmacro cache-number-vector-ref (cnv n)
`(wrapper-cache-number-vector-ref ,cnv ,n))
(defmacro wrapper-cache-number-vector-ref (wrapper n)
- `(sb-kernel:layout-clos-hash ,wrapper ,n))
+ `(layout-clos-hash ,wrapper ,n))
(declaim (inline wrapper-class*))
(defun wrapper-class* (wrapper)
(or (wrapper-class wrapper)
- (find-structure-class
- (cl:class-name (sb-kernel:layout-class wrapper)))))
+ (ensure-non-standard-class
+ (classoid-name (layout-classoid wrapper)))))
;;; The wrapper cache machinery provides general mechanism for
;;; trapping on the next access to any instance of a given class. This
(declaim (inline invalid-wrapper-p))
(defun invalid-wrapper-p (wrapper)
- (not (null (sb-kernel:layout-invalid wrapper))))
+ (not (null (layout-invalid wrapper))))
(defvar *previous-nwrappers* (make-hash-table))
(push previous new-previous))
(let ((ocnv (wrapper-cache-number-vector owrapper)))
- (dotimes (i sb-kernel:layout-clos-hash-length)
+ (dotimes (i layout-clos-hash-length)
(setf (cache-number-vector-ref ocnv i) 0)))
- (push (setf (sb-kernel:layout-invalid owrapper) (list state nwrapper))
+ (push (setf (layout-invalid owrapper) (list state nwrapper))
new-previous)
(setf (gethash owrapper *previous-nwrappers*) ()
(defun check-wrapper-validity (instance)
(let* ((owrapper (wrapper-of instance))
- (state (sb-kernel:layout-invalid owrapper)))
+ (state (layout-invalid owrapper)))
(if (null state)
owrapper
(ecase (car state)
(declaim (inline check-obsolete-instance))
(defun check-obsolete-instance (instance)
- (when (invalid-wrapper-p (sb-kernel:layout-of instance))
+ (when (invalid-wrapper-p (layout-of instance))
(check-wrapper-validity instance)))
\f
(defvar *free-caches* nil)
(std (find-class 'std-class))
(standard (find-class 'standard-class))
(fsc (find-class 'funcallable-standard-class))
+ (condition (find-class 'condition-class))
(structure (find-class 'structure-class))
(built-in (find-class 'built-in-class)))
(flet ((specializer->metatype (x)
(if (eq *boot-state* 'complete)
(class-of (specializer-class x))
(class-of x))))
- (cond ((eq x *the-class-t*) t)
- ((*subtypep meta-specializer std)
- 'standard-instance)
- ((*subtypep meta-specializer standard)
- 'standard-instance)
- ((*subtypep meta-specializer fsc)
- 'standard-instance)
- ((*subtypep meta-specializer structure)
- 'structure-instance)
- ((*subtypep meta-specializer built-in)
- 'built-in-instance)
- ((*subtypep meta-specializer slot)
- 'slot-instance)
- (t (error "PCL cannot handle the specializer ~S (meta-specializer ~S)."
- new-specializer
- meta-specializer))))))
+ (cond
+ ((eq x *the-class-t*) t)
+ ((*subtypep meta-specializer std) 'standard-instance)
+ ((*subtypep meta-specializer standard) 'standard-instance)
+ ((*subtypep meta-specializer fsc) 'standard-instance)
+ ((*subtypep meta-specializer condition) 'condition-instance)
+ ((*subtypep meta-specializer structure) 'structure-instance)
+ ((*subtypep meta-specializer built-in) 'built-in-instance)
+ ((*subtypep meta-specializer slot) 'slot-instance)
+ (t (error "~@<PCL cannot handle the specializer ~S ~
+ (meta-specializer ~S).~@:>"
+ new-specializer
+ meta-specializer))))))
;; We implement the following table. The notation is
;; that X and Y are distinct meta specializer names.
;;
((csubtypep otype std-obj) t)
((not (types-equal-or-intersect otype std-obj)) nil)
(t
- `(typep (sb-kernel:layout-of object) 'sb-pcl::wrapper)))))
+ `(typep (layout-of object) 'sb-pcl::wrapper)))))
(define-source-context defmethod (name &rest stuff)
(let ((arg-pos (position-if #'listp stuff)))
;;; When the optimized function is computed, the function of the
;;; funcallable instance is set to it.
;;;
-(sb-kernel:!defstruct-with-alternate-metaclass ctor
+(!defstruct-with-alternate-metaclass ctor
: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
- :dd-type sb-kernel:funcallable-structure
+ :metaclass-name random-pcl-classoid
+ :metaclass-constructor make-random-pcl-classoid
+ :dd-type funcallable-structure
:runtime-type-checks-p nil)
;;; List of all defined ctors.
(defun install-initial-constructor (ctor &key force-p)
(when (or force-p (ctor-class ctor))
(setf (ctor-class ctor) nil)
- (setf (sb-kernel:funcallable-instance-fun ctor)
- #'(sb-kernel:instance-lambda (&rest args)
+ (setf (funcallable-instance-fun ctor)
+ #'(instance-lambda (&rest args)
(install-optimized-constructor ctor)
(apply ctor args)))
- (setf (sb-kernel:%funcallable-instance-info ctor 1)
+ (setf (%funcallable-instance-info ctor 1)
(ctor-function-name ctor))))
;;;
(function-name (make-ctor-function-name class-name initargs)))
;;
;; Prevent compiler warnings for calling the ctor.
- (sb-kernel:proclaim-as-fun-name function-name)
- (sb-kernel:note-name-defined function-name :function)
+ (proclaim-as-fun-name function-name)
+ (note-name-defined function-name :function)
(when (eq (info :function :where-from function-name) :assumed)
(setf (info :function :where-from function-name) :defined)
(when (info :function :assumed-type function-name)
(finalize-inheritance class))
(setf (ctor-class ctor) class)
(pushnew ctor (plist-value class 'ctors))
- (setf (sb-kernel:funcallable-instance-fun ctor)
+ (setf (funcallable-instance-fun ctor)
;; KLUDGE: Gerd here has the equivalent of (COMPILE NIL
;; (CONSTRUCTOR-FUNCTION-FORM)), but SBCL's COMPILE doesn't
;; deal with INSTANCE-LAMBDA expressions, only with LAMBDA
(defun fallback-generator (ctor ii-methods si-methods)
(declare (ignore ii-methods si-methods))
- `(sb-kernel:instance-lambda ,(make-ctor-parameter-list ctor)
+ `(instance-lambda ,(make-ctor-parameter-list ctor)
(make-instance ,(ctor-class ctor) ,@(ctor-initargs ctor))))
(defun optimizing-generator (ctor ii-methods si-methods)
(multiple-value-bind (body before-method-p)
(fake-initialization-emf ctor ii-methods si-methods)
- `(sb-kernel:instance-lambda ,(make-ctor-parameter-list ctor)
+ `(instance-lambda ,(make-ctor-parameter-list ctor)
(declare #.*optimize-speed*)
,(wrap-in-allocate-forms ctor body before-method-p))))
`(let ((.instance. (%make-standard-instance nil
(get-instance-hash-code)))
(.slots. (make-array
- ,(sb-kernel:layout-length wrapper)
+ ,(layout-length wrapper)
,@(when before-method-p
'(:initial-element +slot-unbound+)))))
(setf (std-instance-wrapper .instance.) ,wrapper)
(initargs (ctor-initargs ctor))
(initkeys (plist-keys initargs))
(slot-vector
- (make-array (sb-kernel:layout-length (class-wrapper class))
+ (make-array (layout-length (class-wrapper class))
:initial-element nil))
(class-inits ())
(default-initargs (class-default-initargs class))
(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 'classoid))
+ (or (classoid-pcl-class type)
+ (ensure-non-standard-class (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))))
+ (layout-classoid (class-wrapper (cadr type))))
(eql type)
(t (if (null (cdr type))
(car type)
(/show "about to set up SB-PCL::*BUILT-IN-CLASSES*")
(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)
- (let ((inherits (sb-kernel:layout-inherits
- (sb-kernel:class-layout class))))
+ (/noshow "entering DIRECT-SUPERS" (classoid-name class))
+ (if (typep class 'built-in-classoid)
+ (built-in-classoid-direct-superclasses class)
+ (let ((inherits (layout-inherits
+ (classoid-layout class))))
(/noshow inherits)
(list (svref inherits (1- (length inherits)))))))
(direct-subs (class)
- (/noshow "entering DIRECT-SUBS" (sb-kernel::class-name class))
+ (/noshow "entering DIRECT-SUBS" (classoid-name class))
(collect ((res))
- (let ((subs (sb-kernel:class-subclasses class)))
+ (let ((subs (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 (find-classoid name)))
(/noshow name class)
`(,name
- ,(mapcar #'cl:class-name (direct-supers class))
- ,(mapcar #'cl:class-name (direct-subs class))
+ ,(mapcar #'classoid-name (direct-supers class))
+ ,(mapcar #'classoid-name (direct-subs class))
,(map 'list
(lambda (x)
- (cl:class-name (sb-kernel:layout-class x)))
+ (classoid-name
+ (layout-classoid x)))
(reverse
- (sb-kernel:layout-inherits
- (sb-kernel:class-layout class))))
+ (layout-inherits
+ (classoid-layout class))))
,(prototype name))))
(remove-if (lambda (kernel-bic-entry)
(member (first kernel-bic-entry)
;; I'm not sure why these are removed from
;; the list, but that's what the original
;; CMU CL code did. -- WHN 20000715
- '(t sb-kernel:instance
- sb-kernel:funcallable-instance
+ '(t instance
+ funcallable-instance
function stream)))
sb-kernel::*built-in-classes*))))
(/noshow "done setting up SB-PCL::*BUILT-IN-CLASSES*")
(defclass t () ()
(:metaclass built-in-class))
-(defclass sb-kernel:instance (t) ()
+(defclass instance (t) ()
(:metaclass built-in-class))
(defclass function (t) ()
(:metaclass built-in-class))
-(defclass sb-kernel:funcallable-instance (function) ()
+(defclass funcallable-instance (function) ()
(:metaclass built-in-class))
-(defclass stream (sb-kernel:instance) ()
+(defclass stream (instance) ()
(:metaclass built-in-class))
(defclass slot-object (t) ()
(:metaclass slot-class))
-(defclass structure-object (slot-object sb-kernel:instance) ()
+(defclass structure-object (slot-object instance) ()
(:metaclass structure-class))
(defstruct (dead-beef-structure-object
(defclass std-object (slot-object) ()
(:metaclass std-class))
-(defclass standard-object (std-object sb-kernel:instance) ())
+(defclass standard-object (std-object instance) ())
-(defclass funcallable-standard-object (std-object
- sb-kernel:funcallable-instance)
+(defclass funcallable-standard-object (std-object funcallable-instance)
()
(:metaclass funcallable-standard-class))
:initform nil
:reader class-predicate-name)))
+(def!method make-load-form ((class class) &optional env)
+ ;; FIXME: should we not instead pass ENV to FIND-CLASS? Probably
+ ;; doesn't matter while all our environments are the same...
+ (declare (ignore env))
+ (let ((name (class-name class)))
+ (unless (and name (eq (find-class name nil) class))
+ (error "~@<Can't use anonymous or undefined class as constant: ~S~:@>"
+ class))
+ `(find-class ',name)))
+
;;; The class PCL-CLASS is an implementation-specific common
;;; superclass of all specified subclasses of the class CLASS.
(defclass pcl-class (class)
(defclass built-in-class (pcl-class) ())
+(defclass condition-class (pcl-class) ())
+
(defclass structure-class (slot-class)
((defstruct-form
:initform ()
(defun make-initial-dfun (gf)
(let ((initial-dfun
- #'(sb-kernel:instance-lambda (&rest args)
+ #'(instance-lambda (&rest args)
(initial-dfun gf args))))
(multiple-value-bind (dfun cache info)
(if (and (eq *boot-state* 'complete)
(let* ((methods (early-gf-methods gf))
(slot-name (early-method-standard-accessor-slot-name (car methods))))
(ecase type
- (reader #'(sb-kernel:instance-lambda (instance)
+ (reader #'(instance-lambda (instance)
(let* ((class (class-of instance))
(class-name (!bootstrap-get-slot 'class class 'name)))
(!bootstrap-get-slot class-name instance slot-name))))
- (boundp #'(sb-kernel:instance-lambda (instance)
+ (boundp #'(instance-lambda (instance)
(let* ((class (class-of instance))
(class-name (!bootstrap-get-slot 'class class 'name)))
(not (eq +slot-unbound+
(!bootstrap-get-slot class-name
instance slot-name))))))
- (writer #'(sb-kernel:instance-lambda (new-value instance)
+ (writer #'(instance-lambda (new-value instance)
(let* ((class (class-of instance))
(class-name (!bootstrap-get-slot 'class class 'name)))
(!bootstrap-set-slot class-name instance slot-name new-value)))))))
specls all-same-p)
(cond ((null methods)
(values
- #'(sb-kernel:instance-lambda (&rest args)
+ #'(instance-lambda (&rest args)
(apply #'no-applicable-method gf args))
nil
(no-methods-dfun-info)))
(if function-p
(lambda (method-alist wrappers)
(declare (ignore method-alist wrappers))
- #'(sb-kernel:instance-lambda (&rest args)
+ #'(instance-lambda (&rest args)
(apply #'no-applicable-method gf args)))
(lambda (method-alist wrappers)
(declare (ignore method-alist wrappers))
(let ((dfun (if early-p
(or dfun (make-initial-dfun generic-function))
(compute-discriminating-function generic-function))))
- (set-funcallable-instance-fun generic-function dfun)
+ (set-funcallable-instance-function generic-function dfun)
(set-fun-name generic-function gf-name)
(when (and ocache (not (eq ocache cache))) (free-cache ocache))
dfun)))
(lambda `(lambda ,closure-variables
,@(when (member 'miss-fn closure-variables)
`((declare (type function miss-fn))))
- #'(sb-kernel:instance-lambda ,args
+ #'(instance-lambda ,args
(let ()
(declare #.*optimize-speed*)
,form)))))
(if cached-emf-p
(lambda (cache miss-fn)
(declare (type function miss-fn))
- #'(sb-kernel:instance-lambda (&rest args)
+ #'(instance-lambda (&rest args)
(declare #.*optimize-speed*)
(with-dfun-wrappers (args metatypes)
(dfun-wrappers invalid-wrapper-p)
(invoke-emf emf args))))))))
(lambda (cache emf miss-fn)
(declare (type function miss-fn))
- #'(sb-kernel:instance-lambda (&rest args)
+ #'(instance-lambda (&rest args)
(declare #.*optimize-speed*)
(with-dfun-wrappers (args metatypes)
(dfun-wrappers invalid-wrapper-p)
;;; 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))
(defmethod (setf documentation) (new-value (x symbol) (doc-type (eql 'type)))
- (if (structure-type-p x) ; Catch structures first.
+ (if (or (structure-type-p x) (condition-type-p x))
(setf (info :type :documentation x) new-value)
(let ((class (find-class x nil)))
(if class
;;; 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))
- 'sb-kernel:defstruct-description)))))
+ (not (condition-type-p type))
+ (let ((classoid (find-classoid type nil)))
+ (and classoid
+ (typep (layout-info
+ (classoid-layout classoid))
+ 'defstruct-description)))))
+
+(defun condition-type-p (type)
+ (and (symbolp type)
+ (condition-classoid-p (find-classoid type nil))))
\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 (classoid-proper-name
+ (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))
+ (layout-classoid object)))
+ `(classoid-layout (find-classoid ',pname))))
+
;; even if it hasn't been defined yet, the user doesn't get
;; obscure warnings about undefined internal implementation
;; functions like HAIRY-MAKE-instance-name.
- (sb-kernel:become-defined-fun-name sym)
+ (become-defined-fun-name sym)
`(,sym ',class (list ,@initargs)))))))
(defmacro expanding-make-instance-toplevel (&rest forms &environment env)
;;; this shouldn't matter, since the only two slots that WRAPPER adds
;;; are meaningless in those cases.
(defstruct (wrapper
- (:include sb-kernel:layout
+ (:include layout
;; KLUDGE: In CMU CL, the initialization default
;; for LAYOUT-INVALID was NIL. In SBCL, that has
;; changed to :UNINITIALIZED, but PCL code might
\f
;;;; PCL's view of funcallable instances
-(sb-kernel:!defstruct-with-alternate-metaclass pcl-funcallable-instance
+(!defstruct-with-alternate-metaclass pcl-funcallable-instance
;; KLUDGE: Note that neither of these slots is ever accessed by its
;; accessor name as of sbcl-0.pre7.63. Presumably everything works
;; by puns based on absolute locations. Fun fun fun.. -- WHN 2001-10-30
: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
- :dd-type sb-kernel:funcallable-structure
+ :superclass-name funcallable-instance
+ :metaclass-name random-pcl-classoid
+ :metaclass-constructor make-random-pcl-classoid
+ :dd-type funcallable-structure
;; Only internal implementation code will access these, and these
;; accesses (slot readers in particular) could easily be a
;; bottleneck, so it seems reasonable to suppress runtime type
(import 'sb-kernel:funcallable-instance-p)
-(defun set-funcallable-instance-fun (fin new-value)
+(defun set-funcallable-instance-function (fin new-value)
(declare (type function new-value))
(aver (funcallable-instance-p fin))
- (setf (sb-kernel:funcallable-instance-fun fin) new-value))
+ (setf (funcallable-instance-fun fin) new-value))
(defmacro fsc-instance-p (fin)
`(funcallable-instance-p ,fin))
(defmacro fsc-instance-wrapper (fin)
- `(sb-kernel:%funcallable-instance-layout ,fin))
+ `(%funcallable-instance-layout ,fin))
;;; FIXME: This seems to bear no relation at all to the CLOS-SLOTS
;;; slot in the FUNCALLABLE-INSTANCE structure, above, which
;;; (bizarrely) seems to be set to the NAME of the
;;; FUNCALLABLE-INSTANCE. At least, the index 1 seems to return the
;;; NAME, and the index 2 NIL. Weird. -- CSR, 2002-11-07
(defmacro fsc-instance-slots (fin)
- `(sb-kernel:%funcallable-instance-info ,fin 0))
+ `(%funcallable-instance-info ,fin 0))
(defmacro fsc-instance-hash (fin)
- `(sb-kernel:%funcallable-instance-info ,fin 3))
+ `(%funcallable-instance-info ,fin 3))
\f
(declaim (inline clos-slots-ref (setf clos-slots-ref)))
(declaim (ftype (function (simple-vector index) t) clos-slots-ref))
;;; few uses of (OR STD-INSTANCE-P FSC-INSTANCE-P) are changed to
;;; PCL-INSTANCE-P.
(defmacro std-instance-p (x)
- `(sb-kernel:%instancep ,x))
+ `(%instancep ,x))
;; a temporary definition used for debugging the bootstrap
#+sb-show
(if (if (eq *boot-state* 'complete)
(typep fcn 'generic-function)
(eq (class-of fcn) *the-class-standard-generic-function*))
- (setf (sb-kernel:%funcallable-instance-info fcn 1) new-name)
+ (setf (%funcallable-instance-info fcn 1) new-name)
(bug "unanticipated function type"))
fcn)
(t
;; it loses some info of potential hacking value. So,
;; lets not do this...
#+nil
- (let ((header (sb-kernel:%closure-fun fcn)))
- (setf (sb-kernel:%simple-fun-name header) new-name))
+ (let ((header (%closure-fun fcn)))
+ (setf (%simple-fun-name header) new-name))
;; XXX Maybe add better scheme here someday.
fcn)))
\f
;;; This definition is for interpreted code.
(defun pcl-instance-p (x)
- (typep (sb-kernel:layout-of x) 'wrapper))
+ (typep (layout-of x) 'wrapper))
;;; CMU CL comment:
;;; We define this as STANDARD-INSTANCE, since we're going to
(:predicate nil)
(:constructor %%allocate-instance--class ())
(:copier nil)
- (:alternate-metaclass sb-kernel:instance
+ (:alternate-metaclass instance
cl:standard-class
- sb-kernel:make-standard-class))
+ make-standard-class))
(slots nil))
|#
-(sb-kernel:!defstruct-with-alternate-metaclass standard-instance
+(!defstruct-with-alternate-metaclass standard-instance
: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
+ :superclass-name instance
+ :metaclass-name standard-classoid
+ :metaclass-constructor make-standard-classoid
:dd-type structure
:runtime-type-checks-p nil)
;;; Both of these operations "work" on structures, which allows the above
;;; weakening of STD-INSTANCE-P.
-(defmacro std-instance-slots (x) `(sb-kernel:%instance-ref ,x 1))
-(defmacro std-instance-wrapper (x) `(sb-kernel:%instance-layout ,x))
+(defmacro std-instance-slots (x) `(%instance-ref ,x 1))
+(defmacro std-instance-wrapper (x) `(%instance-layout ,x))
;;; KLUDGE: This one doesn't "work" on structures. However, we
;;; ensure, in SXHASH and friends, never to call it on structures.
-(defmacro std-instance-hash (x) `(sb-kernel:%instance-ref ,x 2))
+(defmacro std-instance-hash (x) `(%instance-ref ,x 2))
;;; FIXME: These functions are called every place we do a
;;; CALL-NEXT-METHOD, and probably other places too. It's likely worth
(when (pcl-instance-p instance)
(get-slots instance)))
-(defmacro built-in-or-structure-wrapper (x) `(sb-kernel:layout-of ,x))
+(defmacro built-in-or-structure-wrapper (x) `(layout-of ,x))
(defmacro get-wrapper (inst)
(once-only ((wrapper `(wrapper-of ,inst)))
;;; 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))))
+ (layout-info (classoid-layout (find-classoid type))))
(defun structure-type-included-type-name (type)
- (let ((include (sb-kernel::dd-include (get-structure-dd type))))
+ (let ((include (dd-include (get-structure-dd type))))
(if (consp include)
(car include)
include)))
(defun structure-type-slot-description-list (type)
(nthcdr (length (let ((include (structure-type-included-type-name type)))
(and include
- (sb-kernel:dd-slots (get-structure-dd include)))))
- (sb-kernel:dd-slots (get-structure-dd type))))
+ (dd-slots (get-structure-dd include)))))
+ (dd-slots (get-structure-dd type))))
(defun structure-slotd-name (slotd)
- (sb-kernel:dsd-name slotd))
+ (dsd-name slotd))
(defun structure-slotd-accessor-symbol (slotd)
- (sb-kernel:dsd-accessor-name slotd))
+ (dsd-accessor-name slotd))
(defun structure-slotd-reader-function (slotd)
- (fdefinition (sb-kernel:dsd-accessor-name slotd)))
+ (fdefinition (dsd-accessor-name slotd)))
(defun structure-slotd-writer-function (slotd)
- (unless (sb-kernel:dsd-read-only slotd)
- (fdefinition `(setf ,(sb-kernel:dsd-accessor-name slotd)))))
+ (unless (dsd-read-only slotd)
+ (fdefinition `(setf ,(dsd-accessor-name slotd)))))
(defun structure-slotd-type (slotd)
- (sb-kernel:dsd-type slotd))
+ (dsd-type slotd))
(defun structure-slotd-init-form (slotd)
- (sb-kernel::dsd-default slotd))
+ (dsd-default slotd))
\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")
(defun find-class-from-cell (symbol cell &optional (errorp t))
(or (find-class-cell-class cell)
(and *create-classes-from-internal-structure-definitions-p*
- (structure-type-p symbol)
- (find-structure-class symbol))
+ (or (structure-type-p symbol) (condition-type-p symbol))
+ (ensure-non-standard-class symbol))
(cond ((null errorp) nil)
((legal-class-name-p symbol)
(error "There is no class named ~S." symbol))
(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 (classoid-cell-classoid
+ ',(find-classoid-cell symbol))
(find-class-from-cell ',symbol ,class-cell nil))))))
form))
&rest other-initargs)
(unless (and (fboundp generic-function-name)
(typep (fdefinition generic-function-name) 'generic-function))
- (sb-kernel::style-warn "implicitly creating new generic function ~S"
- generic-function-name))
+ (style-warn "implicitly creating new generic function ~S"
+ generic-function-name))
;; XXX What about changing the class of the generic function if
;; there is one? Whose job is that, anyway? Do we need something
;; kind of like CLASS-FOR-REDEFINITION?
(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 (classoid-of ,arg)
+ 'built-in-classoid)))
((eq class *the-class-std-object*)
`(or (std-instance-p ,arg) (fsc-instance-p ,arg)))
((eq class *the-class-standard-object*)
(make-fast-method-call-lambda-list metatypes applyp))))
(multiple-value-bind (cfunction constants)
(get-fun1 `(,(if function-p
- 'sb-kernel:instance-lambda
+ 'instance-lambda
'lambda)
,arglist
,@(unless function-p
;;; the funcallable instance function of the generic function for which
;;; it was computed.
;;;
-;;; More precisely, if compute-discriminating-function is called with an
-;;; argument <gf1>, and returns a result <df1>, that result must not be
-;;; passed to apply or funcall directly. Rather, <df1> must be stored as
-;;; the funcallable instance function of the same generic function <gf1>
-;;; (using set-funcallable-instance-fun). Then the generic function
-;;; can be passed to funcall or apply.
+;;; More precisely, if compute-discriminating-function is called with
+;;; an argument <gf1>, and returns a result <df1>, that result must
+;;; not be passed to apply or funcall directly. Rather, <df1> must be
+;;; stored as the funcallable instance function of the same generic
+;;; function <gf1> (using SET-FUNCALLABLE-INSTANCE-FUNCTION). Then the
+;;; generic function can be passed to funcall or apply.
;;;
;;; An important exception is that methods on this generic function are
;;; permitted to return a function which itself ends up calling the value
;;; (lambda (arg)
;;; (cond (<some condition>
;;; <store some info in the generic function>
-;;; (set-funcallable-instance-fun
+;;; (set-funcallable-instance-function
;;; gf
;;; (compute-discriminating-function gf))
;;; (funcall gf arg))
;;; (defmethod compute-discriminating-function ((gf my-generic-function))
;;; (lambda (arg)
;;; (cond (<some condition>
-;;; (set-funcallable-instance-fun
+;;; (set-funcallable-instance-function
;;; gf
;;; (lambda (a) ..))
;;; (funcall gf arg))
: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))
(remf initargs :metaclass)
(loop (unless (remf initargs :direct-superclasses) (return)))
(loop (unless (remf initargs :direct-slots) (return)))
- (values meta
- (list* :direct-superclasses
- (and (neq supplied-supers unsupplied)
- (mapcar #'fix-super supplied-supers))
- :direct-slots
- (and (neq supplied-slots unsupplied) supplied-slots)
- initargs))))
+ (values
+ meta
+ (nconc
+ (when (neq supplied-supers unsupplied)
+ (list :direct-superclasses (mapcar #'fix-super supplied-supers)))
+ (when (neq supplied-slots unsupplied)
+ (list :direct-slots supplied-slots))
+ initargs))))
\f
-
(defmethod shared-initialize :after
((class std-class)
slot-names
(lambda (dependent)
(apply #'update-dependent class dependent initargs))))
+(defmethod shared-initialize :after ((class condition-class) slot-names
+ &key direct-superclasses)
+ (declare (ignore slot-names))
+ (let ((classoid (find-classoid (class-name class))))
+ (with-slots (wrapper class-precedence-list prototype predicate-name
+ (direct-supers direct-superclasses))
+ class
+ (setf (classoid-pcl-class classoid) class)
+ (setq direct-supers direct-superclasses)
+ (setq wrapper (classoid-layout classoid))
+ (setq class-precedence-list (compute-class-precedence-list class))
+ (setq prototype (make-condition (class-name class)))
+ (add-direct-subclasses class direct-superclasses)
+ (setq predicate-name (make-class-predicate-name (class-name class)))
+ (make-class-predicate class predicate-name))))
+
(defmethod shared-initialize :after
((slotd structure-slot-definition) slot-names &key
(allocation :instance) allocation-class)
(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 (find-classoid (class-name class))))
+ (setf (classoid-pcl-class lclass) class)
+ (setf (slot-value class 'wrapper) (classoid-layout lclass)))
(update-pv-table-cache-info class)
(setq predicate-name (if predicate-name-p
(setf (slot-value class 'predicate-name)
(class-name class))))))
(make-class-predicate class predicate-name)
(add-slot-accessors class direct-slots)))
-
+
(defmethod direct-slot-definition-class ((class structure-class) initargs)
(declare (ignore initargs))
(find-class 'structure-direct-slot-definition))
;;; obsolete the wrapper.
;;;
;;; FIXME: either here or in INVALID-WRAPPER-P looks like a good place
-;;; for (AVER (NOT (EQ (SB-KERNEL:LAYOUT-INVALID OWRAPPER)
+;;; for (AVER (NOT (EQ (LAYOUT-INVALID OWRAPPER)
;;; :UNINITIALIZED)))
;;;
;;; Thanks to Gerd Moellmann for the explanation. -- CSR, 2002-10-29
;; a violation of locality or what might be considered
;; good style. There has to be a better way! -- CSR,
;; 2002-10-29
- (eq (sb-kernel:layout-invalid owrapper) t))
+ (eq (layout-invalid owrapper) t))
(let ((nwrapper (make-wrapper (wrapper-no-of-instance-slots owrapper)
class)))
(setf (wrapper-instance-slots-layout nwrapper)
;;;; absolutely no warranty. See the COPYING and CREDITS files for
;;;; more information.
-;;;; Note that the MOP is not in a supported state. Package issues
-;;;; (both MOP/SB-PCL and CL/SB-PCL) have yet to be resolved, and
-;;;; there is likely to be missing functionality. However, this seems
-;;;; a good a way as any of ensuring that we have no regressions.
+;;;; Note that the MOP is not in an entirely supported state.
+;;;; However, this seems a good a way as any of ensuring that we have
+;;;; no regressions.
(defpackage "MOP-TEST"
- ;; eventually, we might want "MOP" as well here.
- (:use "CL"))
+ (:use "CL" "SB-MOP"))
(in-package "MOP-TEST")
\f
;;; 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-default-initargs
- (sb-pcl:find-class 'forward-ref))))
+(assert (null (class-direct-slots (find-class 'forward-ref))))
+(assert (null (class-direct-default-initargs
+ (find-class 'forward-ref))))
\f
;;; Readers for Generic Function Metaobjects (pp. 216--218 of AMOP)
(defgeneric fn-with-odd-arg-precedence (a b c)
(:argument-precedence-order b c a))
(assert (equal
- (sb-pcl:generic-function-lambda-list #'fn-with-odd-arg-precedence)
+ (generic-function-lambda-list #'fn-with-odd-arg-precedence)
'(a b c)))
(assert (equal
- (sb-pcl:generic-function-argument-precedence-order #'fn-with-odd-arg-precedence)
+ (generic-function-argument-precedence-order #'fn-with-odd-arg-precedence)
'(b c a)))
;;; Test for DOCUMENTATION's order, which was wrong until sbcl-0.7.8.39
(assert (equal
- (sb-pcl:generic-function-argument-precedence-order #'documentation)
- (let ((ll (sb-pcl:generic-function-lambda-list #'documentation)))
+ (generic-function-argument-precedence-order #'documentation)
+ (let ((ll (generic-function-lambda-list #'documentation)))
(list (nth 1 ll) (nth 0 ll)))))
(assert (null
- (sb-pcl:generic-function-declarations #'fn-with-odd-arg-precedence)))
+ (generic-function-declarations #'fn-with-odd-arg-precedence)))
(defgeneric gf-with-declarations (x)
(declare (optimize (speed 3)))
(declare (optimize (safety 0))))
-(let ((decls (sb-pcl:generic-function-declarations #'gf-with-declarations)))
+(let ((decls (generic-function-declarations #'gf-with-declarations)))
(assert (= (length decls) 2))
(assert (member '(optimize (speed 3)) decls :test #'equal))
(assert (member '(optimize (safety 0)) decls :test #'equal)))
(a-class-slot :allocation :class :accessor a-class-slot)))
(dolist (m (list (list #'an-instance-slot :instance)
(list #'a-class-slot :class)))
- (let ((methods (sb-pcl:generic-function-methods (car m))))
+ (let ((methods (generic-function-methods (car m))))
(assert (= (length methods) 1))
- (assert (eq (sb-pcl:slot-definition-allocation
- (sb-pcl:accessor-method-slot-definition
+ (assert (eq (slot-definition-allocation
+ (accessor-method-slot-definition
(car methods)))
(cadr m)))))
\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 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 (class-direct-superclasses (find-class x)))
+ (find-class t)))
+ (assert (member (find-class x)
+ (class-direct-subclasses (find-class t)))))
+\f
+;;; the class-prototype of the NULL class used to be some weird
+;;; standard-instance-like thing. Make sure it's actually NIL.
+;;;
+;;; (and FIXME: eventually turn this into asserting that the prototype
+;;; of all built-in-classes is of the relevant type)
+(assert (null (class-prototype (find-class 'null))))
+\f
+;;; simple consistency checks for the SB-PCL (perhaps AKA SB-MOP)
+;;; package: all of the functionality specified in AMOP is in
+;;; functions:
+(assert (null (loop for x being each external-symbol in "SB-PCL"
+ unless (fboundp x) collect x)))
+;;; and all generic functions in SB-PCL have at least one specified
+;;; method, except for UPDATE-DEPENDENT
+(assert (null (loop for x being each external-symbol in "SB-PCL"
+ unless (or (eq x 'update-dependent)
+ (not (typep (fdefinition x) 'generic-function))
+ (> (length (generic-function-methods
+ (fdefinition x)))
+ 0))
+ collect x)))
\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.14"
+"0.pre8.1"
projects / sbcl.git / commitdiff