Permalink
Browse files

ensure that if we have an accessor named for a slot that we call it

instead of slot-value

 * When we find a slot, but its name is in a different package than
   expected, try calling again, but with the slot-name we found
  • Loading branch information...
bobbysmith007 committed Dec 28, 2012
1 parent 8b86edf commit 68e6252068ce273823f37572c57c87007484baab
Showing with 48 additions and 6 deletions.
  1. +19 −5 access.lisp
  2. +29 −1 test/access.lisp
View
@@ -312,9 +312,16 @@
(gethash it o)))))
(:object
(let ((actual-slot-name (has-slot? o k)))
- (when (and actual-slot-name
- (slot-boundp o actual-slot-name))
- (slot-value o actual-slot-name)))))))))
+ (cond
+ ;; same package as requested, must be no accessor so handle slots
+ ((eql actual-slot-name k)
+ (when (slot-boundp o k)
+ (slot-value o k)))
+
+ ;; lets recheck for an accessor in the correct package
+ (actual-slot-name
+ (access o actual-slot-name :type type :test test :key key))
+ ))))))))
(defun set-access (new o k &key type (test #'equalper) (key #'identity))
"set places in plists, alists, hashtables and clos objects all through the same interface"
@@ -353,8 +360,15 @@
))
o)
(:object
- (when (has-slot? o k)
- (setf (slot-value o k) new))
+ (let ((actual-slot-name (has-slot? o k)))
+ (cond
+ ;; same package so there must be no accessor
+ ((eql actual-slot-name k)
+ (setf (slot-value o k) new))
+ ;; different package, but we have a slot, so lets look for its accessor
+ (actual-slot-name
+ (set-access new o actual-slot-name :type type :test test :key key))
+ ))
o)))))))
(define-setf-expander access (place key
View
@@ -34,7 +34,6 @@
(null-slot :initarg :null-slot :initform ())
(pl :initarg :pl :initform (copy-list +pl+) :accessor pl)))
-
(defun make-obj () (make-instance 'access-test))
(define-test access-basic
@@ -192,3 +191,32 @@
(assert-true warned? "We got a warning for multi-slot-matches"))
(assert-eql 'access-test-other::my-slot (has-slot? o 'access-test-other::my-slot))))
+(defclass accessed-object ()
+ ((my-slot :initarg :my-slot :initform nil)
+ (no-access :initarg :no-access :initform nil)
+ (call-number :accessor call-number :initarg :call-number :initform 0)))
+
+(defmethod my-slot ((o accessed-object))
+ (incf (call-number o))
+ (slot-value o 'my-slot))
+
+(defmethod (setf my-slot) (new (o accessed-object))
+ (incf (call-number o))
+ (setf (slot-value o 'my-slot) new ))
+
+(define-test ensure-called-when-you-can
+ (let ((o (make-instance 'accessed-object)))
+ (setf (access o :my-slot) :test)
+ (assert-eql 1 (call-number o))
+ (assert-eql :test (access o :my-slot))
+ (assert-eql 2 (call-number o))
+
+ ;; check that accessorless slots still work correctly
+ (setf (access o :no-access) :test2)
+ (assert-eql :test2 (access o :no-access) :slot-access-by-name-failed)
+
+ ;; check that accessorless slots still work correctly
+ (setf (access o 'no-access) :test3)
+ (assert-eql :test3 (access o 'no-access) :slot-access-failed)
+ ))
+

0 comments on commit 68e6252

Please sign in to comment.