X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fslots.lisp;h=e7c1d866174e759039995b821eff6c2dc3c1f2e6;hb=50f728671defadb8f7b1e8691c984cb0e6aba17c;hp=e726ba4a8723eee37f9f64b64d9f81c437d7a406;hpb=50462f68bf70faf0bd96de7517643afb740543e6;p=sbcl.git diff --git a/src/pcl/slots.lisp b/src/pcl/slots.lisp index e726ba4..e7c1d86 100644 --- a/src/pcl/slots.lisp +++ b/src/pcl/slots.lisp @@ -58,7 +58,7 @@ (error "unrecognized instance type")))) (defun swap-wrappers-and-slots (i1 i2) - (sb-sys:without-interrupts + (with-pcl-lock ;FIXME is this sufficient? (cond ((std-instance-p i1) (let ((w1 (std-instance-wrapper i1)) (s1 (std-instance-slots i1))) @@ -116,14 +116,11 @@ (slot-missing class object slot-name 'slot-value) (slot-value-using-class class object slot-definition)))) -(setf (gdefinition 'slot-value-normal) #'slot-value) - -(define-compiler-macro slot-value (object-form slot-name-form) - (if (and (constantp slot-name-form) - (let ((slot-name (eval slot-name-form))) - (and (symbolp slot-name) (symbol-package slot-name)))) - `(accessor-slot-value ,object-form ,slot-name-form) - `(slot-value-normal ,object-form ,slot-name-form))) +(define-compiler-macro slot-value (&whole form object slot-name) + (if (and (constantp slot-name) + (interned-symbol-p (eval slot-name))) + `(accessor-slot-value ,object ,slot-name) + form)) (defun set-slot-value (object slot-name new-value) (let* ((class (class-of object)) @@ -133,16 +130,11 @@ (setf (slot-value-using-class class object slot-definition) new-value)))) -(setf (gdefinition 'set-slot-value-normal) #'set-slot-value) - -(define-compiler-macro set-slot-value (object-form - slot-name-form - new-value-form) - (if (and (constantp slot-name-form) - (let ((slot-name (eval slot-name-form))) - (and (symbolp slot-name) (symbol-package slot-name)))) - `(accessor-set-slot-value ,object-form ,slot-name-form ,new-value-form) - `(set-slot-value-normal ,object-form ,slot-name-form ,new-value-form))) +(define-compiler-macro set-slot-value (&whole form object slot-name new-value) + (if (and (constantp slot-name) + (interned-symbol-p (eval slot-name))) + `(accessor-set-slot-value ,object ,slot-name ,new-value) + form)) (defun slot-boundp (object slot-name) (let* ((class (class-of object)) @@ -153,12 +145,11 @@ (setf (gdefinition 'slot-boundp-normal) #'slot-boundp) -(define-compiler-macro slot-boundp (object-form slot-name-form) - (if (and (constantp slot-name-form) - (let ((slot-name (eval slot-name-form))) - (and (symbolp slot-name) (symbol-package slot-name)))) - `(accessor-slot-boundp ,object-form ,slot-name-form) - `(slot-boundp-normal ,object-form ,slot-name-form))) +(define-compiler-macro slot-boundp (&whole form object slot-name) + (if (and (constantp slot-name) + (interned-symbol-p (eval slot-name))) + `(accessor-slot-boundp ,object ,slot-name) + form)) (defun slot-makunbound (object slot-name) (let* ((class (class-of object)) @@ -187,19 +178,14 @@ (defmethod slot-value-using-class ((class std-class) (object std-object) (slotd standard-effective-slot-definition)) + (check-obsolete-instance object) (let* ((location (slot-definition-location slotd)) (value (typecase location (fixnum (cond ((std-instance-p object) - (when (invalid-wrapper-p (std-instance-wrapper - object)) - (check-wrapper-validity object)) (clos-slots-ref (std-instance-slots object) location)) ((fsc-instance-p object) - (when (invalid-wrapper-p (fsc-instance-wrapper - object)) - (check-wrapper-validity object)) (clos-slots-ref (fsc-instance-slots object) location)) (t (error "unrecognized instance type")))) @@ -218,19 +204,16 @@ (new-value (class std-class) (object std-object) (slotd standard-effective-slot-definition)) + (check-obsolete-instance object) (let ((location (slot-definition-location slotd))) (typecase location (fixnum (cond ((std-instance-p object) - (when (invalid-wrapper-p (std-instance-wrapper object)) - (check-wrapper-validity object)) - (setf (clos-slots-ref (std-instance-slots object) location) - new-value)) + (setf (clos-slots-ref (std-instance-slots object) location) + new-value)) ((fsc-instance-p object) - (when (invalid-wrapper-p (fsc-instance-wrapper object)) - (check-wrapper-validity object)) - (setf (clos-slots-ref (fsc-instance-slots object) location) - new-value)) + (setf (clos-slots-ref (fsc-instance-slots object) location) + new-value)) (t (error "unrecognized instance type")))) (cons (setf (cdr location) new-value)) @@ -243,19 +226,14 @@ ((class std-class) (object std-object) (slotd standard-effective-slot-definition)) + (check-obsolete-instance object) (let* ((location (slot-definition-location slotd)) (value (typecase location (fixnum (cond ((std-instance-p object) - (when (invalid-wrapper-p (std-instance-wrapper - object)) - (check-wrapper-validity object)) (clos-slots-ref (std-instance-slots object) location)) ((fsc-instance-p object) - (when (invalid-wrapper-p (fsc-instance-wrapper - object)) - (check-wrapper-validity object)) (clos-slots-ref (fsc-instance-slots object) location)) (t (error "unrecognized instance type")))) @@ -272,19 +250,16 @@ ((class std-class) (object std-object) (slotd standard-effective-slot-definition)) + (check-obsolete-instance object) (let ((location (slot-definition-location slotd))) (typecase location (fixnum (cond ((std-instance-p object) - (when (invalid-wrapper-p (std-instance-wrapper object)) - (check-wrapper-validity object)) - (setf (clos-slots-ref (std-instance-slots object) location) - +slot-unbound+)) + (setf (clos-slots-ref (std-instance-slots object) location) + +slot-unbound+)) ((fsc-instance-p object) - (when (invalid-wrapper-p (fsc-instance-wrapper object)) - (check-wrapper-validity object)) - (setf (clos-slots-ref (fsc-instance-slots object) location) - +slot-unbound+)) + (setf (clos-slots-ref (fsc-instance-slots object) location) + +slot-unbound+)) (t (error "unrecognized instance type")))) (cons (setf (cdr location) +slot-unbound+))