From 21c2b080d512e218485a3969b773bea62a50b73d Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Fri, 9 May 2003 10:22:48 +0000 Subject: [PATCH] 0.8alpha.0.23: Fix a couple of the CLOS bugs that have been accumulating: ... make :ALLOCATION :CLASS slots behave as they should in slot inheritance and class redefinition. Slightly unKLUDGEify the %SET-SYMBOL-VALUE implementation ... do it the same way whether building with #!+SB-THREAD or not, so at least it's ugly once and only once. --- NEWS | 3 +++ src/compiler/generic/objdef.lisp | 3 +-- src/compiler/generic/vm-ir2tran.lisp | 10 +++++----- src/pcl/std-class.lisp | 19 ++++++++++++++++++- version.lisp-expr | 2 +- 5 files changed, 28 insertions(+), 9 deletions(-) diff --git a/NEWS b/NEWS index acf60de..ba73d33 100644 --- a/NEWS +++ b/NEWS @@ -1724,6 +1724,9 @@ changes in sbcl-0.8.0 relative to sbcl-0.8alpha.0 types. ** &ENVIRONMENT parameter in macro lambda list is bound first. ** SXHASH on condition objects no longer returns NIL. + ** :ALLOCATION :CLASS slots are better treated; their values are + updated on class redefinition, and initforms inherited from + superclasses are applied. planned incompatible changes in 0.8.x: * (not done yet, but planned:) When the profiling interface settles diff --git a/src/compiler/generic/objdef.lisp b/src/compiler/generic/objdef.lisp index ff6ae86..5228849 100644 --- a/src/compiler/generic/objdef.lisp +++ b/src/compiler/generic/objdef.lisp @@ -326,8 +326,7 @@ ;; subtract 3 from (sb-kernel:get-lisp-obj-address 'NIL) you get the ;; first data slot, and if you subtract 7 you get a symbol header. - (value #!-sb-thread :set-trans #!-sb-thread %set-symbol-value - :init :unbound) ;also the CAR of NIL-as-end-of-list + (value :init :unbound) ;also the CAR of NIL-as-end-of-list (hash) ;the CDR of NIL-as-end-of-list (plist :ref-trans symbol-plist diff --git a/src/compiler/generic/vm-ir2tran.lisp b/src/compiler/generic/vm-ir2tran.lisp index 0125c4a..5cbeb85 100644 --- a/src/compiler/generic/vm-ir2tran.lisp +++ b/src/compiler/generic/vm-ir2tran.lisp @@ -82,11 +82,11 @@ (do-inits node block name result lowtag inits args) (move-continuation-result node block locs cont))) -;;; KLUDGE: this is set up automatically in #!-SB-THREAD builds by the -;;; :SET-TRANS thing in objdef.lisp. However, for #!+SB-THREAD builds -;;; we need to use a special VOP, so we have to do this by hand. -;;; -- CSR, 2003-05-08 -#!+sb-thread +;;; :SET-TRANS (in objdef.lisp DEFINE-PRIMITIVE-OBJECT) doesn't quite +;;; cut it for symbols, where under certain compilation options +;;; (e.g. #!+SB-THREAD) we have to do something complicated, rather +;;; than simply set the slot. So we build the IR2 converting function +;;; by hand. -- CSR, 2003-05-08 (let ((fun-info (fun-info-or-lose '%set-symbol-value))) (setf (fun-info-ir2-convert fun-info) (lambda (node block) diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp index d943fb8..a653842 100644 --- a/src/pcl/std-class.lisp +++ b/src/pcl/std-class.lisp @@ -499,6 +499,9 @@ (setq direct-default-initargs (plist-value class 'direct-default-initargs))) (setf (plist-value class 'class-slot-cells) + ;; The below initializes shared slots from direct initforms, + ;; but one might inherit initforms from superclasses + ;; (cf. UPDATE-SHARED-SLOT-VALUES). (let (collect) (dolist (dslotd direct-slots) (when (eq :class (slot-definition-allocation dslotd)) @@ -826,13 +829,27 @@ (update-slots class (compute-slots class)) (update-gfs-of-class class) (update-inits class (compute-default-initargs class)) + (update-shared-slot-values class) (update-ctors 'finalize-inheritance :class class)) (unless finalizep (dolist (sub (class-direct-subclasses class)) (update-class sub nil)))) +(defun update-shared-slot-values (class) + (dolist (slot (class-slots class)) + (when (eq (slot-definition-allocation slot) :class) + (let ((cell (assq (slot-definition-name slot) (class-slot-cells class)))) + (when cell + (let ((initfn (slot-definition-initfunction slot))) + (when initfn + (setf (cdr cell) (funcall initfn))))))))) + (defun update-cpl (class cpl) (if (class-finalized-p class) - (unless (equal (class-precedence-list class) cpl) + (unless (and (equal (class-precedence-list class) cpl) + (dolist (c cpl t) + (when (position :class (class-direct-slots c) + :key #'slot-definition-allocation) + (return nil)))) ;; comment from the old CMU CL sources: ;; Need to have the cpl setup before update-lisp-class-layout ;; is called on CMU CL. diff --git a/version.lisp-expr b/version.lisp-expr index e451eef..cfc4544 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.8alpha.0.22" +"0.8alpha.0.23" -- 1.7.10.4