X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fclass.lisp;h=9258e585de711ded40018bd270b7ca427dfef80d;hb=2d3cb6dba6461e98744eca2a1df4f770cea468ca;hp=3475adfbf4e97e60f221383f803c18f24c88e99c;hpb=6fb6e66f531dfb6140ec3e0cc8f84f6ecd1927ca;p=sbcl.git diff --git a/src/code/class.lisp b/src/code/class.lisp index 3475adf..9258e58 100644 --- a/src/code/class.lisp +++ b/src/code/class.lisp @@ -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,15 +37,12 @@ ;; reasonably for anonymous classes. "~:[anonymous~;~:*~S~]~@[ (~(~A~))~]" name - (class-state class)))))) + (classoid-state class)))))) #-sb-xc-host (:pure nil)) - ;; the value to be returned by CLASS-NAME. (CMU CL used the raw slot - ;; accessor for this slot directly as the definition of - ;; CL:CLASS-NAME, but that was slightly wrong, because ANSI says - ;; that CL:CLASS-NAME is a generic function.) - (%name nil :type symbol) + ;; the value to be returned by CLASSOID-NAME. + (name nil :type symbol) ;; the current layout for this class, or NIL if none assigned yet - (layout nil :type (or sb!kernel::layout null)) + (layout nil :type (or layout null)) ;; How sure are we that this class won't be redefined? ;; :READ-ONLY = We are committed to not changing the effective ;; slots or superclasses. @@ -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,15 +72,15 @@ ;; 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 ;;; Note: This bound is set somewhat less than MOST-POSITIVE-FIXNUM ;;; in order to guarantee that several hash values can be added without ;;; overflowing into a bignum. -(defconstant layout-clos-hash-max (ash most-positive-fixnum -3) +(def!constant layout-clos-hash-max (ash most-positive-fixnum -3) #!+sb-doc "the inclusive upper bound on LAYOUT-CLOS-HASH values") @@ -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 (required-argument) - ;; 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 @@ -207,7 +187,7 @@ ;; renamed because some of us find it confusing to call something ;; a depth when it isn't quite. (depthoid -1 :type layout-depthoid) - ;; The number of top-level descriptor cells in each instance. + ;; the number of top level descriptor cells in each instance (length 0 :type index) ;; If this layout has some kind of compiler meta-info, then this is ;; it. If a structure, then we store the DEFSTRUCT-DESCRIPTION here. @@ -229,11 +209,11 @@ (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 -(defconstant layout-clos-hash-length 8) +(def!constant layout-clos-hash-length 8) #!-sb-fluid (declaim (inline layout-clos-hash)) (defun layout-clos-hash (layout i) ;; FIXME: Either this I should be declared to be `(MOD @@ -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))))) @@ -394,8 +376,8 @@ (let ((old-length (layout-length old-layout))) (unless (= old-length length) (warn "change in instance length of class ~S:~% ~ - ~A length: ~D~% ~ - ~A length: ~D" + ~A length: ~W~% ~ + ~A length: ~W" name old-context old-length context length) @@ -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 @@ -441,11 +424,10 @@ (declaim (ftype (function (symbol index simple-vector layout-depthoid) layout) find-and-init-or-check-layout)) (defun find-and-init-or-check-layout (name length inherits depthoid) - (/show0 "entering FIND-AND-INIT-OR-CHECK-LAYOUT") (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))) @@ -462,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 @@ -495,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)) @@ -620,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)) @@ -631,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 @@ -641,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 @@ -657,93 +639,90 @@ ;;; 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 + ;; XXX Currently, nothing needs to be done in this case. Later, when + ;; PCL is integrated tighter into SBCL, this might need more work. + nil) (:instance - (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 @@ -753,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 @@ -764,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)))) @@ -807,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) @@ -819,52 +798,61 @@ (res)) *empty-type*))) -(!define-type-method (sb!xc:class :simple-intersection2) (class1 class2) - (declare (type sb!xc:class class1 class2)) +(!define-type-method (classoid :simple-intersection2) (class1 class2) + (declare (type classoid class1 class2)) (cond ((eq class1 class2) class1) ;; If one is a subclass of the other, then that is the ;; intersection. - ((let ((subclasses (class-subclasses class2))) + ((let ((subclasses (classoid-subclasses class2))) (and subclasses (gethash class1 subclasses))) class1) - ((let ((subclasses (class-subclasses class1))) + ((let ((subclasses (classoid-subclasses class1))) (and subclasses (gethash class2 subclasses))) class2) ;; Otherwise, we can't in general be sure that the ;; intersection is empty, since a subclass of both might be ;; defined. But we can eliminate it for some special cases. - ((or (basic-structure-class-p class1) - (basic-structure-class-p class2)) + ((or (basic-structure-classoid-p class1) + (basic-structure-classoid-p class2)) ;; No subclass of both can be defined. *empty-type*) - ((eq (class-state class1) :sealed) + ((eq (classoid-state class1) :sealed) ;; checking whether a subclass of both can be defined: (sealed-class-intersection2 class1 class2)) - ((eq (class-state class2) :sealed) + ((eq (classoid-state class2) :sealed) ;; checking whether a subclass of both can be defined: (sealed-class-intersection2 class2 class1)) (t ;; uncertain, since a subclass of both might be defined nil))) -(!define-type-method (sb!xc:class :unparse) (type) - (class-proper-name type)) +;;; KLUDGE: we need this because of the need to represent +;;; intersections of two classes, even when empty at a given time, as +;;; uncanonicalized intersections because of the possibility of later +;;; defining a subclass of both classes. The necessity for changing +;;; the default return value from SUBTYPEP to NIL, T if no alternate +;;; method is present comes about because, unlike the other places we +;;; use INVOKE-COMPLEX-SUBTYPEP-ARG1-METHOD, in HAIRY methods and the +;;; like, classes are in their own hierarchy with no possibility of +;;; mixtures with other type classes. +(!define-type-method (classoid :complex-subtypep-arg2) (type1 class2) + (if (and (intersection-type-p type1) + (> (count-if #'classoid-p (intersection-type-types type1)) 1)) + (values nil nil) + (invoke-complex-subtypep-arg1-method type1 class2 nil t))) + +(!define-type-method (classoid :unparse) (type) + (classoid-proper-name type)) ;;;; 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 @@ -914,284 +902,202 @@ (character :enumerable t :translation base-char) (base-char :enumerable t :inherits (character) - :codes (#.sb!vm:base-char-type)) - (symbol :codes (#.sb!vm:symbol-header-type)) + :codes (#.sb!vm:base-char-widetag)) + (symbol :codes (#.sb!vm:symbol-header-widetag)) (instance :state :read-only) - (system-area-pointer :codes (#.sb!vm:sap-type)) - (weak-pointer :codes (#.sb!vm:weak-pointer-type)) - (code-component :codes (#.sb!vm:code-header-type)) - (lra :codes (#.sb!vm:return-pc-header-type)) - (fdefn :codes (#.sb!vm:fdefn-type)) + (system-area-pointer :codes (#.sb!vm:sap-widetag)) + (weak-pointer :codes (#.sb!vm:weak-pointer-widetag)) + (code-component :codes (#.sb!vm:code-header-widetag)) + (lra :codes (#.sb!vm:return-pc-header-widetag)) + (fdefn :codes (#.sb!vm:fdefn-widetag)) (random-class) ; used for unknown type codes (function - :codes (#.sb!vm:closure-header-type - #.sb!vm:simple-fun-header-type) + :codes (#.sb!vm:closure-header-widetag + #.sb!vm:simple-fun-header-widetag) :state :read-only) (funcallable-instance :inherits (function) :state :read-only) - ;; FIXME: Are COLLECTION and MUTABLE-COLLECTION used for anything - ;; any more? COLLECTION is not defined in ANSI Common Lisp.. - (collection :hierarchical-p nil :state :read-only) - (mutable-collection :state :read-only - :inherits (collection)) - (generic-sequence :state :read-only - :inherits (collection)) - (mutable-sequence :state :read-only - :direct-superclasses (mutable-collection - generic-sequence) - :inherits (mutable-collection - generic-sequence - collection)) - (generic-array :state :read-only - :inherits (mutable-sequence - mutable-collection - generic-sequence - collection)) - (generic-vector :state :read-only - :inherits (generic-array - mutable-sequence mutable-collection - generic-sequence collection)) - (array :translation array :codes (#.sb!vm:complex-array-type) - :inherits (generic-array mutable-sequence mutable-collection - generic-sequence collection)) + (array :translation array :codes (#.sb!vm:complex-array-widetag) + :hierarchical-p nil) (simple-array - :translation simple-array :codes (#.sb!vm:simple-array-type) - :inherits (array generic-array mutable-sequence mutable-collection - generic-sequence collection)) + :translation simple-array :codes (#.sb!vm:simple-array-widetag) + :inherits (array)) (sequence - :translation (or cons (member nil) vector) - :inherits (mutable-sequence mutable-collection generic-sequence - collection)) + :translation (or cons (member nil) vector)) (vector - :translation vector :codes (#.sb!vm:complex-vector-type) - :direct-superclasses (array sequence generic-vector) - :inherits (array sequence generic-vector generic-array - mutable-sequence mutable-collection generic-sequence - collection)) + :translation vector :codes (#.sb!vm:complex-vector-widetag) + :direct-superclasses (array sequence) + :inherits (array sequence)) (simple-vector - :translation simple-vector :codes (#.sb!vm:simple-vector-type) + :translation simple-vector :codes (#.sb!vm:simple-vector-widetag) :direct-superclasses (vector simple-array) - :inherits (vector simple-array array - sequence generic-vector generic-array - mutable-sequence mutable-collection - generic-sequence collection)) + :inherits (vector simple-array array sequence)) (bit-vector - :translation bit-vector :codes (#.sb!vm:complex-bit-vector-type) - :inherits (vector array sequence - generic-vector generic-array mutable-sequence - mutable-collection generic-sequence collection)) + :translation bit-vector :codes (#.sb!vm:complex-bit-vector-widetag) + :inherits (vector array sequence)) (simple-bit-vector - :translation simple-bit-vector :codes (#.sb!vm:simple-bit-vector-type) + :translation simple-bit-vector :codes (#.sb!vm:simple-bit-vector-widetag) :direct-superclasses (bit-vector simple-array) :inherits (bit-vector vector simple-array - array sequence - generic-vector generic-array mutable-sequence - mutable-collection generic-sequence collection)) + array sequence)) (simple-array-unsigned-byte-2 :translation (simple-array (unsigned-byte 2) (*)) - :codes (#.sb!vm:simple-array-unsigned-byte-2-type) + :codes (#.sb!vm:simple-array-unsigned-byte-2-widetag) :direct-superclasses (vector simple-array) - :inherits (vector simple-array array sequence - generic-vector generic-array mutable-sequence - mutable-collection generic-sequence collection)) + :inherits (vector simple-array array sequence)) (simple-array-unsigned-byte-4 :translation (simple-array (unsigned-byte 4) (*)) - :codes (#.sb!vm:simple-array-unsigned-byte-4-type) + :codes (#.sb!vm:simple-array-unsigned-byte-4-widetag) :direct-superclasses (vector simple-array) - :inherits (vector simple-array array sequence - generic-vector generic-array mutable-sequence - mutable-collection generic-sequence collection)) + :inherits (vector simple-array array sequence)) (simple-array-unsigned-byte-8 :translation (simple-array (unsigned-byte 8) (*)) - :codes (#.sb!vm:simple-array-unsigned-byte-8-type) + :codes (#.sb!vm:simple-array-unsigned-byte-8-widetag) :direct-superclasses (vector simple-array) - :inherits (vector simple-array array sequence - generic-vector generic-array mutable-sequence - mutable-collection generic-sequence collection)) + :inherits (vector simple-array array sequence)) (simple-array-unsigned-byte-16 :translation (simple-array (unsigned-byte 16) (*)) - :codes (#.sb!vm:simple-array-unsigned-byte-16-type) + :codes (#.sb!vm:simple-array-unsigned-byte-16-widetag) :direct-superclasses (vector simple-array) - :inherits (vector simple-array array sequence - generic-vector generic-array mutable-sequence - mutable-collection generic-sequence collection)) + :inherits (vector simple-array array sequence)) (simple-array-unsigned-byte-32 :translation (simple-array (unsigned-byte 32) (*)) - :codes (#.sb!vm:simple-array-unsigned-byte-32-type) + :codes (#.sb!vm:simple-array-unsigned-byte-32-widetag) :direct-superclasses (vector simple-array) - :inherits (vector simple-array array sequence - generic-vector generic-array mutable-sequence - mutable-collection generic-sequence collection)) + :inherits (vector simple-array array sequence)) (simple-array-signed-byte-8 :translation (simple-array (signed-byte 8) (*)) - :codes (#.sb!vm:simple-array-signed-byte-8-type) + :codes (#.sb!vm:simple-array-signed-byte-8-widetag) :direct-superclasses (vector simple-array) - :inherits (vector simple-array array sequence - generic-vector generic-array mutable-sequence - mutable-collection generic-sequence collection)) + :inherits (vector simple-array array sequence)) (simple-array-signed-byte-16 :translation (simple-array (signed-byte 16) (*)) - :codes (#.sb!vm:simple-array-signed-byte-16-type) + :codes (#.sb!vm:simple-array-signed-byte-16-widetag) :direct-superclasses (vector simple-array) - :inherits (vector simple-array array sequence - generic-vector generic-array mutable-sequence - mutable-collection generic-sequence collection)) + :inherits (vector simple-array array sequence)) (simple-array-signed-byte-30 :translation (simple-array (signed-byte 30) (*)) - :codes (#.sb!vm:simple-array-signed-byte-30-type) + :codes (#.sb!vm:simple-array-signed-byte-30-widetag) :direct-superclasses (vector simple-array) - :inherits (vector simple-array array sequence - generic-vector generic-array mutable-sequence - mutable-collection generic-sequence collection)) + :inherits (vector simple-array array sequence)) (simple-array-signed-byte-32 :translation (simple-array (signed-byte 32) (*)) - :codes (#.sb!vm:simple-array-signed-byte-32-type) + :codes (#.sb!vm:simple-array-signed-byte-32-widetag) :direct-superclasses (vector simple-array) - :inherits (vector simple-array array sequence - generic-vector generic-array mutable-sequence - mutable-collection generic-sequence collection)) + :inherits (vector simple-array array sequence)) (simple-array-single-float :translation (simple-array single-float (*)) - :codes (#.sb!vm:simple-array-single-float-type) + :codes (#.sb!vm:simple-array-single-float-widetag) :direct-superclasses (vector simple-array) - :inherits (vector simple-array array sequence - generic-vector generic-array mutable-sequence - mutable-collection generic-sequence collection)) + :inherits (vector simple-array array sequence)) (simple-array-double-float :translation (simple-array double-float (*)) - :codes (#.sb!vm:simple-array-double-float-type) + :codes (#.sb!vm:simple-array-double-float-widetag) :direct-superclasses (vector simple-array) - :inherits (vector simple-array array sequence - generic-vector generic-array mutable-sequence - mutable-collection generic-sequence collection)) + :inherits (vector simple-array array sequence)) #!+long-float (simple-array-long-float :translation (simple-array long-float (*)) - :codes (#.sb!vm:simple-array-long-float-type) + :codes (#.sb!vm:simple-array-long-float-widetag) :direct-superclasses (vector simple-array) - :inherits (vector simple-array array sequence - generic-vector generic-array mutable-sequence - mutable-collection generic-sequence collection)) + :inherits (vector simple-array array sequence)) (simple-array-complex-single-float :translation (simple-array (complex single-float) (*)) - :codes (#.sb!vm:simple-array-complex-single-float-type) + :codes (#.sb!vm:simple-array-complex-single-float-widetag) :direct-superclasses (vector simple-array) - :inherits (vector simple-array array sequence - generic-vector generic-array mutable-sequence - mutable-collection generic-sequence collection)) + :inherits (vector simple-array array sequence)) (simple-array-complex-double-float :translation (simple-array (complex double-float) (*)) - :codes (#.sb!vm:simple-array-complex-double-float-type) + :codes (#.sb!vm:simple-array-complex-double-float-widetag) :direct-superclasses (vector simple-array) - :inherits (vector simple-array array sequence - generic-vector generic-array mutable-sequence - mutable-collection generic-sequence collection)) + :inherits (vector simple-array array sequence)) #!+long-float (simple-array-complex-long-float :translation (simple-array (complex long-float) (*)) - :codes (#.sb!vm:simple-array-complex-long-float-type) + :codes (#.sb!vm:simple-array-complex-long-float-widetag) :direct-superclasses (vector simple-array) - :inherits (vector simple-array array sequence - generic-vector generic-array mutable-sequence - mutable-collection generic-sequence collection)) - (generic-string - :state :read-only - :inherits (mutable-sequence mutable-collection generic-sequence - collection)) + :inherits (vector simple-array array sequence)) (string :translation string - :codes (#.sb!vm:complex-string-type) - :direct-superclasses (vector generic-string) - :inherits (vector array sequence - generic-vector generic-array generic-string - mutable-sequence mutable-collection - generic-sequence collection)) + :codes (#.sb!vm:complex-string-widetag) + :direct-superclasses (vector) + :inherits (vector array sequence)) (simple-string :translation simple-string - :codes (#.sb!vm:simple-string-type) + :codes (#.sb!vm:simple-string-widetag) :direct-superclasses (string simple-array) :inherits (string vector simple-array - array sequence - generic-string generic-vector generic-array mutable-sequence - mutable-collection generic-sequence collection)) + array sequence)) (list :translation (or cons (member nil)) - :inherits (sequence mutable-sequence mutable-collection - generic-sequence collection)) + :inherits (sequence)) (cons :codes (#.sb!vm:list-pointer-lowtag) :translation cons - :inherits (list sequence - mutable-sequence mutable-collection - generic-sequence collection)) + :inherits (list sequence)) (null :translation (member nil) - :inherits (list sequence - mutable-sequence mutable-collection - generic-sequence collection symbol) - :direct-superclasses (list symbol)) - (generic-number :state :read-only) - (number :translation number :inherits (generic-number)) + :inherits (symbol list sequence) + :direct-superclasses (symbol list)) + (number :translation number) (complex :translation complex - :inherits (number generic-number) - :codes (#.sb!vm:complex-type)) + :inherits (number) + :codes (#.sb!vm:complex-widetag)) (complex-single-float :translation (complex single-float) - :inherits (complex number generic-number) - :codes (#.sb!vm:complex-single-float-type)) + :inherits (complex number) + :codes (#.sb!vm:complex-single-float-widetag)) (complex-double-float :translation (complex double-float) - :inherits (complex number generic-number) - :codes (#.sb!vm:complex-double-float-type)) + :inherits (complex number) + :codes (#.sb!vm:complex-double-float-widetag)) #!+long-float (complex-long-float :translation (complex long-float) - :inherits (complex number generic-number) - :codes (#.sb!vm:complex-long-float-type)) - (real :translation real :inherits (number generic-number)) + :inherits (complex number) + :codes (#.sb!vm:complex-long-float-widetag)) + (real :translation real :inherits (number)) (float :translation float - :inherits (real number generic-number)) + :inherits (real number)) (single-float :translation single-float - :inherits (float real number generic-number) - :codes (#.sb!vm:single-float-type)) + :inherits (float real number) + :codes (#.sb!vm:single-float-widetag)) (double-float :translation double-float - :inherits (float real number generic-number) - :codes (#.sb!vm:double-float-type)) + :inherits (float real number) + :codes (#.sb!vm:double-float-widetag)) #!+long-float (long-float :translation long-float - :inherits (float real number generic-number) - :codes (#.sb!vm:long-float-type)) + :inherits (float real number) + :codes (#.sb!vm:long-float-widetag)) (rational :translation rational - :inherits (real number generic-number)) + :inherits (real number)) (ratio :translation (and rational (not integer)) - :inherits (rational real number generic-number) - :codes (#.sb!vm:ratio-type)) + :inherits (rational real number) + :codes (#.sb!vm:ratio-widetag)) (integer :translation integer - :inherits (rational real number generic-number)) + :inherits (rational real number)) (fixnum - :translation (integer #.sb!vm:*target-most-negative-fixnum* - #.sb!vm:*target-most-positive-fixnum*) - :inherits (integer rational real number - generic-number) + :translation (integer #.sb!xc:most-negative-fixnum + #.sb!xc:most-positive-fixnum) + :inherits (integer rational real number) :codes (#.sb!vm:even-fixnum-lowtag #.sb!vm:odd-fixnum-lowtag)) (bignum :translation (and integer (not fixnum)) - :inherits (integer rational real number - generic-number) - :codes (#.sb!vm:bignum-type)) + :inherits (integer rational real number) + :codes (#.sb!vm:bignum-widetag)) (stream :state :read-only :depth 3 @@ -1220,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))))) - (setf (info :type :kind name) :primitive - (class-cell-class (find-class-cell name)) class) + (classoid (make-built-in-classoid + :enumerable enumerable + :name name + :translation (if trans-p :initializing nil) + :direct-superclasses + (if (eq name t) + nil + (mapcar #'find-classoid direct-superclasses))))) + (setf (info :type :kind name) #+sb-xc-host :defined #-sb-xc-host :primitive + (classoid-cell-classoid (find-classoid-cell name)) classoid) (unless trans-p - (setf (info :type :builtin name) class)) + (setf (info :type :builtin name) classoid)) (let* ((inherits-vector (map 'simple-vector (lambda (x) (let ((super-layout - (class-layout (sb!xc:find-class x)))) + (classoid-layout (find-classoid x)))) (when (minusp (layout-depthoid super-layout)) (setf hierarchical-p nil)) super-layout)) @@ -1280,14 +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))) - (setf (class-cell-class class-cell) class - (info :type :class name) class-cell + (classoid (make-standard-classoid :name name)) + (classoid-cell (find-classoid-cell name))) + ;; Needed to open-code the MAP, below + (declare (type list inherits-list)) + (setf (classoid-cell-classoid classoid-cell) classoid + (info :type :classoid name) classoid-cell (info :type :kind name) :instance) (let ((inherits (map 'simple-vector (lambda (x) - (class-layout (sb!xc:find-class x))) + (classoid-layout (find-classoid x))) inherits-list))) #-sb-xc-host (/show0 "INHERITS=..") #-sb-xc-host (/hexstr inherits) (register-layout (find-and-init-or-check-layout name 0 inherits -1) @@ -1299,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 @@ -1322,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 @@ -1336,14 +1244,14 @@ ;;; FIXME: It would be good to arrange for this to be called when the ;;; cross-compiler is being built, not just when the target Lisp is ;;; being cold loaded. Perhaps this could be moved to its own file -;;; late in the stems-and-flags.lisp-expr sequence, and be put in +;;; late in the build-order.lisp-expr sequence, and be put in ;;; !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? @@ -1361,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*"))