[rjain-utils-cvs] CVS prototypes

[rjain]

Update of /project/rjain-utils/cvsroot/prototypes
In directory cl-net:/tmp/cvs-serv6830

Modified Files:
	prototypes.lisp 
Log Message:
add multiple delegation
macrolet for slot operation definition


--- /project/rjain-utils/cvsroot/prototypes/prototypes.lisp	2009/11/24 10:36:43	1.2
+++ /project/rjain-utils/cvsroot/prototypes/prototypes.lisp	2009/11/24 10:38:19	1.3
@@ -10,53 +10,52 @@
   t)
 
 (defclass prototype-object ()
-  ((delegate :initarg :delegate :reader prototype-delegate :initform nil))
+  ((delegates :initarg :delegates :reader prototype-delegates :initform nil))
   (:metaclass prototype-class))
 
 (defgeneric prototype-find-subclass (prototype slot-name))
 
 (defmethod prototype-find-subclass ((class prototype-class) slot-name)
-  (find-if (lambda (subclass) (eql slot-name (slot-definition-name (first (class-direct-slots subclass))))) 
-           (class-direct-subclasses class)))
+  (find slot-name
+        (class-direct-subclasses class)
+        :key (lambda (subclass) 
+               (slot-definition-name (first (class-direct-slots subclass))))))
 
 (defmethod prototype-find-subclass ((object prototype-object) slot-name)
   (prototype-find-subclass (class-of object) slot-name))
 
-(defmethod slot-missing (class (object prototype-object) slot-name
-                         (operation (eql 'slot-value))
-                         &optional new-value)
-  (if (null (prototype-delegate object))
-      (call-next-method)
-      (slot-value (prototype-delegate object) slot-name)))
-
-(defmethod slot-missing (class (object prototype-object) slot-name
-                         (operation (eql 'slot-boundp))
-                         &optional new-value)
-  (if (null (prototype-delegate object))
-      (call-next-method)
-      (slot-boundp (prototype-delegate object) slot-name)))
-
 (defun prototype-subclass (class slot-name)
   (make-instance 'prototype-class
                  :direct-superclasses (list class)
                  :direct-slots (list (list :name slot-name :initargs (list slot-name)))))
 
-(defmethod slot-missing (class (object prototype-object) slot-name
-                         (operation (eql 'setf)) &optional new-value)
-  (let ((new-class (or (prototype-find-subclass class slot-name)
-                       (prototype-subclass class slot-name))))
-    (change-class object new-class slot-name new-value)))
-
-(defmethod slot-missing (class (object prototype-object) slot-name
-                         (operation (eql 'slot-makunbound))
-                         &optional new-value)
-  (let ((new-class (or (prototype-find-subclass class slot-name)
-                       (prototype-subclass class slot-name))))
-    (change-class object new-class)))
+(defun ensure-subclass (class slot-name)
+  (or (prototype-find-subclass class slot-name)
+      (prototype-subclass class slot-name)))
+
+(macrolet ((reader-delegation (operation)
+             `(defmethod slot-missing (class (object prototype-object) slot-name
+                                       (operation (eql ',operation))
+                                       &optional new-value)
+                (declare (ignore new-value))
+                (dolist (delegate (prototype-delegates object)
+                         (call-next-method))
+                  (ignore-errors
+                    (return (,operation delegate slot-name)))))))
+  (reader-delegation slot-value)
+  (reader-delegation slot-boundp))
+
+(macrolet ((writer-subclassing (operation &rest initargs)
+           `(defmethod slot-missing (class (object prototype-object) slot-name
+                                     (operation (eql ',operation))
+                                     &optional new-value)
+              (let ((new-class (ensure-subclass class slot-name)))
+                (change-class object new-class , at initargs)))))
+  (writer-subclassing setf slot-name new-value)
+  (writer-subclassing slot-makunbound))
 
 (defmethod make-instance ((prototype prototype-object) &key)
-  (make-instance 'prototype-object :delegate prototype))
-
+  (make-instance 'prototype-object :delegates (list prototype)))
 
 ;;;; TESTS
 
@@ -91,3 +90,11 @@
 (assert (eql (slot-value *3* 'x) 3))
 
 (assert (eql (slot-value *3.1* 'x) 2))
+
+(slot-makunbound *3.1* 'x)
+
+(assert (eql (slot-value *2* 'x) 2))
+
+(assert (eql (slot-value *3* 'x) 3))
+
+(assert (not (slot-boundp *3.1* 'x)))