X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fstd-class.lisp;h=d40e7cfbef23971265aea2f003cc344141791f69;hb=96a67b487909638cc0cb91114b6babf94b4bc1a7;hp=cf2eb6e1424a6186d33b7e00f3f8bb65ebe41b1e;hpb=310aee0b439b715a5ec242862ab0a4d254e123b5;p=sbcl.git diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp index cf2eb6e..d40e7cf 100644 --- a/src/pcl/std-class.lisp +++ b/src/pcl/std-class.lisp @@ -72,19 +72,14 @@ (defmethod initialize-internal-slot-functions ((slotd effective-slot-definition)) (let* ((name (slot-value slotd 'name)) - (class (slot-value slotd 'class))) - (let ((table (or (gethash name *name->class->slotd-table*) - (setf (gethash name *name->class->slotd-table*) - (make-hash-table :test 'eq :size 5))))) - (setf (gethash class table) slotd)) + (class (slot-value slotd '%class))) (dolist (type '(reader writer boundp)) (let* ((gf-name (ecase type (reader 'slot-value-using-class) (writer '(setf slot-value-using-class)) (boundp 'slot-boundp-using-class))) (gf (gdefinition gf-name))) - (compute-slot-accessor-info slotd type gf))) - (initialize-internal-slot-gfs name))) + (compute-slot-accessor-info slotd type gf))))) ;;; CMUCL (Gerd PCL 2003-04-25) comment: ;;; @@ -103,7 +98,7 @@ (defmethod compute-slot-accessor-info ((slotd effective-slot-definition) type gf) (let* ((name (slot-value slotd 'name)) - (class (slot-value slotd 'class)) + (class (slot-value slotd '%class)) (old-slotd (find-slot-definition class name)) (old-std-p (and old-slotd (slot-accessor-std-p old-slotd 'all)))) (multiple-value-bind (function std-p) @@ -281,11 +276,11 @@ slot-names &key) (declare (ignore slot-names)) - (setf (slot-value specl 'type) `(class-eq ,(specializer-class specl)))) + (setf (slot-value specl '%type) `(class-eq ,(specializer-class specl)))) (defmethod shared-initialize :after ((specl eql-specializer) slot-names &key) (declare (ignore slot-names)) - (setf (slot-value specl 'type) + (setf (slot-value specl '%type) `(eql ,(specializer-object specl))) (setf (info :type :translator specl) (constantly (make-member-type :members (list (specializer-object specl)))))) @@ -364,7 +359,7 @@ (defmethod shared-initialize :after - ((class std-class) slot-names &key + ((class std-class) slot-names &key (direct-superclasses nil direct-superclasses-p) (direct-slots nil direct-slots-p) (direct-default-initargs nil direct-default-initargs-p)) @@ -485,7 +480,7 @@ (declare (ignore slot-names name)) ;; FIXME: Could this just be CLASS instead of `(CLASS ,CLASS)? If not, ;; why not? (See also similar expression in !BOOTSTRAP-INITIALIZE-CLASS.) - (setf (slot-value class 'type) `(class ,class)) + (setf (slot-value class '%type) `(class ,class)) (setf (slot-value class 'class-eq-specializer) (make-instance 'class-eq-specializer :class class))) @@ -520,7 +515,7 @@ &key direct-slots direct-superclasses) (declare (ignore slot-names)) (let ((classoid (find-classoid (class-name class)))) - (with-slots (wrapper class-precedence-list cpl-available-p + (with-slots (wrapper %class-precedence-list cpl-available-p prototype (direct-supers direct-superclasses)) class (setf (slot-value class 'direct-slots) @@ -530,7 +525,7 @@ (setf (classoid-pcl-class classoid) class) (setq direct-supers direct-superclasses) (setq wrapper (classoid-layout classoid)) - (setq class-precedence-list (compute-class-precedence-list class)) + (setq %class-precedence-list (compute-class-precedence-list class)) (setq cpl-available-p t) (add-direct-subclasses class direct-superclasses) (setf (slot-value class 'slots) (compute-slots class)))) @@ -590,7 +585,7 @@ (compute-effective-slot-definition class (slot-definition-name dslotd) (list dslotd))) (class-direct-slots superclass))) - (reverse (slot-value class 'class-precedence-list)))) + (reverse (slot-value class '%class-precedence-list)))) (defmethod compute-slots :around ((class condition-class)) (let ((eslotds (call-next-method))) @@ -660,7 +655,7 @@ (sb-kernel::compiler-layout-or-lose (dd-name dd)))))) (defmethod shared-initialize :after - ((class structure-class) slot-names &key + ((class structure-class) slot-names &key (direct-superclasses nil direct-superclasses-p) (direct-slots nil direct-slots-p) direct-default-initargs) @@ -709,7 +704,7 @@ (setf (slot-value class 'defstruct-constructor) (make-defstruct-allocation-function class))) (add-direct-subclasses class direct-superclasses) - (setf (slot-value class 'class-precedence-list) + (setf (slot-value class '%class-precedence-list) (compute-class-precedence-list class)) (setf (slot-value class 'cpl-available-p) t) (setf (slot-value class 'slots) (compute-slots class)) @@ -813,9 +808,8 @@ (update-gfs-of-class class) (update-initargs class (compute-default-initargs class)) (update-ctors 'finalize-inheritance :class class)) - (unless finalizep - (dolist (sub (class-direct-subclasses class)) - (update-class sub nil))))) + (dolist (sub (class-direct-subclasses class)) + (update-class sub nil)))) (define-condition cpl-protocol-violation (reference-condition error) ((class :initarg :class :reader cpl-protocol-violation-class) @@ -849,11 +843,11 @@ ;; comment from the old CMU CL sources: ;; Need to have the cpl setup before update-lisp-class-layout ;; is called on CMU CL. - (setf (slot-value class 'class-precedence-list) cpl) + (setf (slot-value class '%class-precedence-list) cpl) (setf (slot-value class 'cpl-available-p) t) (force-cache-flushes class)) (progn - (setf (slot-value class 'class-precedence-list) cpl) + (setf (slot-value class '%class-precedence-list) cpl) (setf (slot-value class 'cpl-available-p) t))) (update-class-can-precede-p cpl)) @@ -1045,7 +1039,7 @@ (slot-definition-name dslotd) (list dslotd))) (class-direct-slots superclass))) - (reverse (slot-value class 'class-precedence-list)))) + (reverse (slot-value class '%class-precedence-list)))) (defmethod compute-slots :around ((class structure-class)) (let ((eslotds (call-next-method)))