X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fstd-class.lisp;h=c3216bae354ca52e557003eeec967c3c5801b673;hb=ebc0f0ebf9efd39519ab86ba28c33abdb25443e0;hp=a7533d3f7d536672d2ea0490ad633ad371f5a806;hpb=a4640afb239d4de3e348430fd9903fc3a88b9139;p=sbcl.git diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp index a7533d3..c3216ba 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)))))) @@ -333,9 +328,6 @@ (set-class-type-translation class name) class)) -(defmethod class-predicate-name ((class t)) - 'constantly-nil) - (defun fix-super (s) (cond ((classp s) s) ((not (legal-class-name-p s)) @@ -367,12 +359,10 @@ (defmethod shared-initialize :after - ((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) - (predicate-name nil predicate-name-p)) + ((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)) (cond (direct-superclasses-p (setq direct-superclasses (or direct-superclasses @@ -419,15 +409,7 @@ (push (cons name value) collect)) (push old collect))))) (nreverse collect))) - (setq predicate-name (if predicate-name-p - (setf (slot-value class 'predicate-name) - (car predicate-name)) - (or (slot-value class 'predicate-name) - (setf (slot-value class 'predicate-name) - (make-class-predicate-name (class-name - class)))))) (add-direct-subclasses class direct-superclasses) - (make-class-predicate class predicate-name) (update-class class nil) (do* ((slots (slot-value class 'slots) (cdr slots)) (dupes nil)) @@ -498,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))) @@ -533,9 +515,8 @@ &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 - prototype predicate-name - (direct-supers direct-superclasses)) + (with-slots (wrapper %class-precedence-list cpl-available-p + prototype (direct-supers direct-superclasses)) class (setf (slot-value class 'direct-slots) (mapcar (lambda (pl) (make-direct-slotd class pl)) @@ -544,11 +525,9 @@ (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) - (setq predicate-name (make-class-predicate-name (class-name class))) - (make-class-predicate class predicate-name) (setf (slot-value class 'slots) (compute-slots class)))) ;; Comment from Gerd's PCL, 2003-05-15: ;; @@ -606,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))) @@ -676,12 +655,10 @@ (sb-kernel::compiler-layout-or-lose (dd-name dd)))))) (defmethod shared-initialize :after - ((class structure-class) - slot-names - &key (direct-superclasses nil direct-superclasses-p) + ((class structure-class) slot-names &key + (direct-superclasses nil direct-superclasses-p) (direct-slots nil direct-slots-p) - direct-default-initargs - (predicate-name nil predicate-name-p)) + direct-default-initargs) (declare (ignore slot-names direct-default-initargs)) (if direct-superclasses-p (setf (slot-value class 'direct-superclasses) @@ -727,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)) @@ -736,14 +713,6 @@ (setf (slot-value class 'wrapper) (classoid-layout lclass))) (setf (slot-value class 'finalized-p) t) (update-pv-table-cache-info class) - (setq predicate-name (if predicate-name-p - (setf (slot-value class 'predicate-name) - (car predicate-name)) - (or (slot-value class 'predicate-name) - (setf (slot-value class 'predicate-name) - (make-class-predicate-name - (class-name class)))))) - (make-class-predicate class predicate-name) (add-slot-accessors class direct-slots))) (defmethod direct-slot-definition-class ((class structure-class) &rest initargs) @@ -825,6 +794,8 @@ (not (class-finalized-p class)) (not (class-has-a-forward-referenced-superclass-p class))) (finalize-inheritance class) + (dolist (sub (class-direct-subclasses class)) + (update-class sub nil)) (return-from update-class)) (when (or finalizep (class-finalized-p class) (not (class-has-a-forward-referenced-superclass-p class))) @@ -875,11 +846,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)) @@ -1041,9 +1012,9 @@ ;; do if we find that said user has added a slot ;; with the same name as another slot... (cell (or (assq name (class-slot-cells from-class)) - (setf (class-slot-cells from-class) - (cons (cons name +slot-unbound+) - (class-slot-cells from-class)))))) + (let ((c (cons name +slot-unbound+))) + (push c (class-slot-cells from-class)) + c)))) (aver (consp cell)) (if (eq +slot-unbound+ (cdr cell)) ;; We may have inherited an initfunction @@ -1071,7 +1042,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)))