Update of /cvsroot/sbcl/sbcl/src/code In directory sc8-pr-cvs1:/tmp/cvs-serv16556/src/code Modified Files: Tag: pcl_class_defrobulation_branch class.lisp condition.lisp cross-type.lisp defbangstruct.lisp defstruct.lisp deftypes-for-target.lisp describe.lisp early-type.lisp error.lisp interr.lisp late-type.lisp pred.lisp room.lisp sharpm.lisp target-defstruct.lisp target-sxhash.lisp target-type.lisp type-init.lisp typecheckfuns.lisp typep.lisp Log Message: 0.7.13.pcl-class.1 Turn SB-PCL::CLASS into CL:CLASS ... and to do that, turn CL:CLASS into SB-KERNEL:CLASSOID Well, there's a little more to it than that. This commit causes no regressions against our own test suite (once the necessary s/SB-PCL:FIND-CLASS/FIND-CLASS/ changes have been made) but, along with several new passes in the gcl suite, causes one new failure to do with condition classes. There have been some code deletions, too, as some methods that were necessary to paper over the cracks between the two different CLASSes are now no longer necessary, as the CLASSOID structure is now viewed as internal. The major code addition is probably SB-PCL::SET-CLASS-TYPE-TRANSLATOR, which communicates the necessary information to the type engine (with extra hair to get BUILT-IN-CLASSES right). This branch is expected to last during the freeze period, and land shortly after 0.7.14 is released. Index: class.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/code/class.lisp,v retrieving revision 1.38 retrieving revision 1.38.2.1 diff -u -d -r1.38 -r1.38.2.1 --- class.lisp 3 Mar 2003 11:16:07 -0000 1.38 +++ class.lisp 20 Mar 2003 16:03:42 -0000 1.38.2.1 @@ -20,22 +20,15 @@ ;;; The CLASS structure is a supertype of all class types. A CLASS is ;;; also a CTYPE structure as recognized by the type system. -(def!struct (;; FIXME: Yes, these #+SB-XC/#-SB-XC conditionals are - ;; pretty hairy. I'm considering cleaner ways to rewrite - ;; the whole build system to avoid these (and other hacks - ;; too, e.g. UNCROSS) but I'm not sure yet that I've got - ;; it figured out. -- WHN 19990729 - #-sb-xc sb!xc:class - #+sb-xc cl:class - (:make-load-form-fun class-make-load-form-fun) +(def!struct (classoid + (:make-load-form-fun classoid-make-load-form-fun) (:include ctype - (class-info (type-class-or-lose #-sb-xc 'sb!xc:class - #+sb-xc 'cl:class))) + (class-info (type-class-or-lose 'classoid))) (:constructor nil) #-no-ansi-print-object (:print-object (lambda (class stream) - (let ((name (sb!xc:class-name class))) + (let ((name (classoid-name class))) (print-unreadable-object (class stream :type t :identity (not name)) @@ -44,13 +37,10 @@ ;; 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? @@ -70,16 +60,10 @@ ;; the PCL class object for this class, or NIL if none assigned yet (pcl-class nil)) -;;; KLUDGE: ANSI says this is a generic function, but we need it for -;;; bootstrapping before CLOS exists, so we define it as an ordinary -;;; function and let CLOS code overwrite it later. -- WHN ca. 19990815 -(defun sb!xc:class-name (class) - (class-%name class)) - -(defun class-make-load-form-fun (class) - (/show "entering CLASS-MAKE-LOAD-FORM-FUN" class) - (let ((name (sb!xc:class-name class))) - (unless (and name (eq (sb!xc:find-class name nil) class)) +(defun classoid-make-load-form-fun (class) + (/show "entering %CLASSOID-MAKE-LOAD-FORM-FUN" class) + (let ((name (classoid-name class))) + (unless (and name (eq (find-classoid name nil) class)) (/show "anonymous/undefined class case") (error "can't use anonymous or undefined class as constant:~% ~S" class)) @@ -88,8 +72,8 @@ ;; 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)))) ;;;; basic LAYOUT stuff @@ -175,11 +159,7 @@ (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 @@ -229,7 +209,7 @@ (eval-when (:compile-toplevel :load-toplevel :execute) (defun layout-proper-name (layout) - (class-proper-name (layout-class layout)))) + (classoid-proper-name (layout-classoid layout)))) ;;;; support for the hash values used by CLOS when working with LAYOUTs @@ -278,11 +258,12 @@ ;;; been split off into INIT-OR-CHECK-LAYOUT. (declaim (ftype (function (symbol) layout) find-layout)) (defun find-layout (name) - (let ((class (sb!xc:find-class name nil))) - (or (and class (class-layout class)) + (let ((classoid (find-classoid name nil))) + (or (and classoid (classoid-layout classoid)) (gethash name *forward-referenced-layouts*) (setf (gethash name *forward-referenced-layouts*) - (make-layout :class (or class (make-undefined-class name))))))) + (make-layout :classoid (or classoid + (make-undefined-classoid name))))))) ;;; If LAYOUT is uninitialized, initialize it with CLASS, LENGTH, ;;; INHERITS, and DEPTHOID, otherwise require that it be consistent @@ -293,27 +274,28 @@ ;;; 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 @@ -335,8 +317,8 @@ (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, @@ -349,7 +331,7 @@ ;; "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))))) @@ -408,10 +390,11 @@ ;;; 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 @@ -443,8 +426,8 @@ (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))) @@ -461,32 +444,32 @@ (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 @@ -494,22 +477,22 @@ (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)) @@ -619,7 +602,7 @@ (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)) @@ -630,7 +613,7 @@ (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 @@ -640,11 +623,11 @@ ;;;; 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 @@ -656,83 +639,75 @@ ;;; 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))) -;;;; 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 @@ -740,13 +715,14 @@ ;; PCL is integrated tighter into SBCL, this might need more work. nil) (:instance - (let ((old (class-of (sb!xc:find-class name))) - (new (class-of new-value))) + #-sb-xc-host ; FIXME + (let ((old (classoid-of (find-classoid name))) + (new (classoid-of new-value))) (unless (eq old new) (warn "changing meta-class of ~S from ~S to ~S" name - (class-name old) - (class-name new))))) + (classoid-name old) + (classoid-name new))))) (:primitive (error "illegal to redefine standard type ~S" name)) (:defined @@ -756,10 +732,10 @@ (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 @@ -767,41 +743,41 @@ ;;; 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))) ;;;; 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)))) @@ -810,9 +786,9 @@ ;;; 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) @@ -822,29 +798,29 @@ (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 @@ -860,29 +836,23 @@ ;;; 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)) ;;;; 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))) ;;;; built-in classes @@ -1156,23 +1126,23 @@ (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)) @@ -1216,16 +1186,16 @@ (/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) @@ -1237,19 +1207,19 @@ (!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)))) ;;;; 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 @@ -1260,13 +1230,13 @@ (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)) ;;;; cold loading initializations @@ -1278,10 +1248,10 @@ ;;; !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? @@ -1299,18 +1269,18 @@ (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*")) Index: condition.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/code/condition.lisp,v retrieving revision 1.21 retrieving revision 1.21.2.1 diff -u -d -r1.21 -r1.21.2.1 --- condition.lisp 10 Mar 2003 14:54:23 -0000 1.21 +++ condition.lisp 20 Mar 2003 16:03:42 -0000 1.21.2.1 @@ -21,8 +21,8 @@ (/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) @@ -44,20 +44,14 @@ (/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) @@ -88,25 +82,29 @@ (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)))) @@ -117,8 +115,8 @@ (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)) @@ -130,11 +128,11 @@ (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))))) @@ -155,9 +153,9 @@ ;; 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))))))) @@ -167,9 +165,9 @@ (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*) @@ -187,24 +185,24 @@ (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))))) @@ -237,11 +235,11 @@ ;; 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 @@ -254,15 +252,15 @@ :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*) @@ -277,16 +275,18 @@ (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 @@ -295,7 +295,7 @@ (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) @@ -304,14 +304,14 @@ ;; 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)) @@ -326,9 +326,9 @@ ;;; 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) @@ -347,10 +347,10 @@ (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) @@ -371,8 +371,8 @@ (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 @@ -384,14 +384,14 @@ (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) Index: cross-type.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/code/cross-type.lisp,v retrieving revision 1.18 retrieving revision 1.18.12.1 diff -u -d -r1.18 -r1.18.12.1 --- cross-type.lisp 12 Oct 2002 15:51:35 -0000 1.18 +++ cross-type.lisp 20 Mar 2003 16:03:42 -0000 1.18.12.1 @@ -144,20 +144,15 @@ 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)) @@ -217,8 +212,8 @@ (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 @@ -376,14 +371,14 @@ (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 Index: defbangstruct.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/code/defbangstruct.lisp,v retrieving revision 1.12 retrieving revision 1.12.10.1 diff -u -d -r1.12 -r1.12.10.1 --- defbangstruct.lisp 14 Dec 2002 22:10:07 -0000 1.12 +++ defbangstruct.lisp 20 Mar 2003 16:03:43 -0000 1.12.10.1 @@ -145,11 +145,11 @@ (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)) @@ -159,8 +159,8 @@ (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)) Index: defstruct.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/code/defstruct.lisp,v retrieving revision 1.55 retrieving revision 1.55.6.1 diff -u -d -r1.55 -r1.55.6.1 --- defstruct.lisp 28 Jan 2003 17:21:14 -0000 1.55 +++ defstruct.lisp 20 Mar 2003 16:03:43 -0000 1.55.6.1 @@ -289,7 +289,7 @@ ;; 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)) @@ -318,16 +318,16 @@ (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 @@ -764,12 +764,12 @@ (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 @@ -827,15 +827,15 @@ (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))))) @@ -849,10 +849,10 @@ (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))) @@ -861,9 +861,9 @@ (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 @@ -928,7 +928,7 @@ (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 @@ -937,27 +937,27 @@ "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)) @@ -1062,10 +1062,10 @@ ;;; 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) @@ -1082,9 +1082,10 @@ ;;; 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 @@ -1131,24 +1132,25 @@ (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) @@ -1160,7 +1162,7 @@ (;; 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) @@ -1193,7 +1195,7 @@ ;;; 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*) Index: deftypes-for-target.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/code/deftypes-for-target.lisp,v retrieving revision 1.13 retrieving revision 1.13.6.1 diff -u -d -r1.13 -r1.13.6.1 --- deftypes-for-target.lisp 27 Jan 2003 17:27:52 -0000 1.13 +++ deftypes-for-target.lisp 20 Mar 2003 16:03:43 -0000 1.13.6.1 @@ -102,7 +102,12 @@ ;;;; 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))) Index: describe.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/code/describe.lisp,v retrieving revision 1.35 retrieving revision 1.35.4.1 diff -u -d -r1.35 -r1.35.4.1 --- describe.lisp 19 Feb 2003 17:11:37 -0000 1.35 +++ describe.lisp 20 Mar 2003 16:03:43 -0000 1.35.4.1 @@ -301,7 +301,7 @@ ;; * 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)))) Index: early-type.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/code/early-type.lisp,v retrieving revision 1.30 retrieving revision 1.30.4.1 diff -u -d -r1.30 -r1.30.4.1 --- early-type.lisp 18 Feb 2003 11:44:43 -0000 1.30 +++ early-type.lisp 20 Mar 2003 16:03:44 -0000 1.30.4.1 @@ -344,16 +344,17 @@ ((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 'bu... [truncated message content] |