(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))))
(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))
(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
(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
(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
(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))
+slot-unbound+))))
(ecase kind
((nil)
- (unless before-method-p
+ (unless early-unbound-markers-p
`(setf (clos-slots-ref .slots. ,i)
+slot-unbound+)))
((param var)
(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))))
'(: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)))))))
+
\f
;;;; success
projects / sbcl.git / commitdiff