From: Nikodemus Siivola Date: Mon, 28 Feb 2011 08:57:19 +0000 (+0000) Subject: 1.0.46.15: fix MAKE-INSTANCE regression from 1.0.45.18 X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=4a1cfe27db52072dfaeddda235e7d830f2c85661;p=sbcl.git 1.0.46.15: fix MAKE-INSTANCE regression from 1.0.45.18 If we use a fake MAKE-INSTANCE emf in the presence of (SETF SLOT-VALUE-USING-CLASS) or SLOT-BOUNDP-USING-CLASS methods, we need to initialize the instance vector using +SLOT-UNBOUND+ before any slots are touched, because accessing any slot can potentially cause another to be accessed -- which in turn requires boundp information to be present. Reported by Slobodan Milnović on sbcl-help. --- diff --git a/NEWS b/NEWS index b077ffa..628eea2 100644 --- a/NEWS +++ b/NEWS @@ -17,6 +17,9 @@ changes relative to sbcl-1.0.46: are detected. (lp#520607) * bug fix: constant keyword argument checking didn't take :ALLOW-OTHER-KEYS into account. + * bug fix: SLOT-BOUNDP information is correct during MAKE-INSTANCE in the + presence of (SETF SLOT-VALUE-USING-CLASS) and SLOT-BOUNDP-USING-CLASS + methods. (regression from 1.0.45.18) changes in sbcl-1.0.46 relative to sbcl-1.0.45: * enhancement: largefile support on Solaris. diff --git a/src/pcl/ctor.lisp b/src/pcl/ctor.lisp index 95de690..e360052 100644 --- a/src/pcl/ctor.lisp +++ b/src/pcl/ctor.lisp @@ -615,7 +615,7 @@ (defun optimizing-generator (ctor ii-methods si-methods setf-svuc-slots sbuc-slots) - (multiple-value-bind (locations names body around-or-before-method-p) + (multiple-value-bind (locations names body early-unbound-markers-p) (fake-initialization-emf ctor ii-methods si-methods setf-svuc-slots sbuc-slots) (let ((wrapper (class-wrapper (ctor-class ctor)))) @@ -626,18 +626,17 @@ (when (layout-invalid ,wrapper) (install-initial-constructor ,ctor) (return (funcall ,ctor ,@(make-ctor-parameter-list ctor)))) - ,(wrap-in-allocate-forms ctor body around-or-before-method-p))) + ,(wrap-in-allocate-forms ctor body early-unbound-markers-p))) locations names t)))) -;;; Return a form wrapped around BODY that allocates an instance -;;; constructed by CTOR. BEFORE-METHOD-P set means we have to run -;;; before-methods, in which case we initialize instance slots to -;;; +SLOT-UNBOUND+. The resulting form binds the local variables -;;; .INSTANCE. to the instance, and .SLOTS. to the instance's slot -;;; vector around BODY. -(defun wrap-in-allocate-forms (ctor body around-or-before-method-p) +;;; Return a form wrapped around BODY that allocates an instance constructed +;;; by CTOR. EARLY-UNBOUND-MARKERS-P means slots may be accessed before we +;;; have explicitly initialized them, requiring all slots to start as +;;; +SLOT-UNBOUND+. The resulting form binds the local variables .INSTANCE. to +;;; the instance, and .SLOTS. to the instance's slot vector around BODY. +(defun wrap-in-allocate-forms (ctor body early-unbound-markers-p) (let* ((class (ctor-class ctor)) (wrapper (class-wrapper class)) (allocation-function (raw-instance-allocator class)) @@ -647,8 +646,8 @@ (get-instance-hash-code))) (.slots. (make-array ,(layout-length wrapper) - ,@(when around-or-before-method-p - '(:initial-element +slot-unbound+))))) + ,@(when early-unbound-markers-p + '(:initial-element +slot-unbound+))))) (setf (std-instance-wrapper .instance.) ,wrapper) (setf (std-instance-slots .instance.) .slots.) ,body @@ -679,11 +678,17 @@ (standard-sort-methods si-methods) (declare (ignore si-primary)) (aver (null si-around)) - (let ((initargs (ctor-initargs ctor))) + (let ((initargs (ctor-initargs ctor)) + ;; :BEFORE and :AROUND initialization methods, and SETF SVUC and + ;; SBUC methods can cause slots to be accessed before the we have + ;; touched them here, which requires the instance-vector to be + ;; initialized with +SLOT-UNBOUND+ to start with. + (early-unbound-markers-p (or ii-before si-before ii-around + setf-svuc-slots sbuc-slots))) (multiple-value-bind (locations names bindings vars defaulting-initargs body) (slot-init-forms ctor - (or ii-before si-before ii-around) + early-unbound-markers-p setf-svuc-slots sbuc-slots) (values locations @@ -724,7 +729,7 @@ (invoke-method ,(car ii-around) .ii-args. .next-methods.)) ;; The simple case. `(initialize-it .ii-args. nil))))) - (or ii-before si-before ii-around))))))) + early-unbound-markers-p)))))) ;;; Return four values from APPLICABLE-METHODS: around methods, before ;;; methods, the applicable primary method, and applicable after @@ -755,15 +760,14 @@ (the ,type (progn ,@body))) `(progn ,@body))) -;;; Return as multiple values bindings for default initialization -;;; arguments, variable names, defaulting initargs and a body for -;;; initializing instance and class slots of an object costructed by -;;; CTOR. The variable .SLOTS. is assumed to bound to the instance's -;;; slot vector. BEFORE-METHOD-P T means before-methods will be -;;; called, which means that 1) other code will initialize instance -;;; slots to +SLOT-UNBOUND+ before the before-methods are run, and -;;; that we have to check if these before-methods have set slots. -(defun slot-init-forms (ctor before-method-p setf-svuc-slots sbuc-slots) +;;; Return as multiple values bindings for default initialization arguments, +;;; variable names, defaulting initargs and a body for initializing instance +;;; and class slots of an object costructed by CTOR. The variable .SLOTS. is +;;; assumed to bound to the instance's slot vector. EARLY-UNBOUND-MARKERS-P +;;; means other code will initialize instance slots to +SLOT-UNBOUND+, and we +;;; have to check if something has already set slots before we initialize +;;; them. +(defun slot-init-forms (ctor early-unbound-markers-p setf-svuc-slots sbuc-slots) (let* ((class (ctor-class ctor)) (initargs (ctor-initargs ctor)) (initkeys (plist-keys initargs)) @@ -870,7 +874,7 @@ +slot-unbound+)))) (ecase kind ((nil) - (unless before-method-p + (unless early-unbound-markers-p `(setf (clos-slots-ref .slots. ,i) +slot-unbound+))) ((param var) @@ -878,12 +882,12 @@ (initfn (setf-form `(funcall ,value))) (initform/initfn - (if before-method-p + (if early-unbound-markers-p `(when ,(not-boundp-form) ,(setf-form `(funcall ,value))) (setf-form `(funcall ,value)))) (initform - (if before-method-p + (if early-unbound-markers-p `(when ,(not-boundp-form) ,(setf-form `',(constant-form-value value))) (setf-form `',(constant-form-value value)))) diff --git a/tests/ctor.impure.lisp b/tests/ctor.impure.lisp index f717d66..fed7e9b 100644 --- a/tests/ctor.impure.lisp +++ b/tests/ctor.impure.lisp @@ -237,5 +237,41 @@ '(:no-applicable-method 'abc zot 1 bar 2) (funcall (compile nil `(lambda (c x y) (make-instance c 'zot x 'bar y))) ''abc 1 2)))) + +(defclass sneaky-class (standard-class) + ()) + +(defmethod sb-mop:validate-superclass ((class sneaky-class) (super standard-class)) + t) + +(defclass sneaky () + ((dirty :initform nil :accessor dirty-slots) + (a :initarg :a :reader sneaky-a) + (b :initform "b" :reader sneaky-b) + (c :accessor sneaky-c)) + (:metaclass sneaky-class)) + +(defvar *supervising* nil) + +(defmethod (setf sb-mop:slot-value-using-class) + :before (value (class sneaky-class) (instance sneaky) slotd) + (unless *supervising* + (let ((name (sb-mop:slot-definition-name slotd)) + (*supervising* t)) + (when (slot-boundp instance 'dirty) + (pushnew name (dirty-slots instance)))))) + +(with-test (:name (make-instance :setf-slot-value-using-class-hits-other-slots)) + (let ((fun (compile nil `(lambda (a c) + (let ((i (make-instance 'sneaky :a a))) + (setf (sneaky-c i) c) + i))))) + (loop repeat 3 + do (let ((i (funcall fun "a" "c"))) + (assert (equal '(c b a) (dirty-slots i))) + (assert (equal "a" (sneaky-a i))) + (assert (equal "b" (sneaky-b i))) + (assert (equal "c" (sneaky-c i))))))) + ;;;; success diff --git a/version.lisp-expr b/version.lisp-expr index ad59cd3..7ae9a31 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -20,4 +20,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".) -"1.0.46.14" +"1.0.46.15"