[rjain-utils-cvs] CVS prototypes

[rjain]

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

Modified Files:
	prototypes.lisp 
Log Message:
add delegation and all slot operations
add tests


--- /project/rjain-utils/cvsroot/prototypes/prototypes.lisp	2009/11/24 10:30:48	1.1.1.1
+++ /project/rjain-utils/cvsroot/prototypes/prototypes.lisp	2009/11/24 10:36:43	1.2
@@ -1,5 +1,5 @@
 (defpackage :prototypes
-  (:use :cl :sb-mop))
+  (:use :cl #+sbcl :sb-mop #-sbcl :mop))
 
 (in-package :prototypes)
 
@@ -9,24 +9,85 @@
 (defmethod validate-superclass ((proto prototype-class) (super standard-class))
   t)
 
-(defclass prototype-instance (standard-object)
-  ()
+(defclass prototype-object ()
+  ((delegate :initarg :delegate :reader prototype-delegate :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)))
 
-(defmethod slot-missing (class (object prototype-instance) slot-name (operation (eql 'setf)) &optional new-value)
+(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)
-                       (make-instance 'prototype-class
-                                      :direct-superclasses (list class)
-                                      :direct-slots (list (make-instance 'standard-direct-slot-definition :name slot-name :initarg slot-name))))))
-    (change-class object slot-name new-class new-value)))
-
-(defmethod make-instance ((prototype prototype-instance) &key)
-  (apply #'make-instance (class-of prototype)
-         (mapcan (lambda (slot) (let ((name (slot-definition-name slot)))
-                                  (when (slot-boundp prototype name) 
-                                    (list name (slot-value prototype name)))))
-                 (class-slots (class-of prototype)))))
+                       (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)))
+
+(defmethod make-instance ((prototype prototype-object) &key)
+  (make-instance 'prototype-object :delegate prototype))
+
+
+;;;; TESTS
+
+(defparameter *1* (make-instance 'prototype-object))
+
+(setf (slot-value *1* 'x) 1)
+
+(defparameter *2* (make-instance *1*))
+
+(assert (eql (slot-value *2* 'x) 1))
+
+(defparameter *3* (make-instance *2*))
+
+(assert (eql (slot-value *3* 'x) 1))
+
+(defparameter *3.1* (make-instance *2*))
+
+(assert (eql (slot-value *3.1* 'x) 1))
+
+(setf (slot-value *2* 'x) 2)
+
+(assert (eql (slot-value *2* 'x) 2))
+
+(assert (eql (slot-value *3* 'x) 2))
+
+(assert (eql (slot-value *3.1* 'x) 2))
+
+(setf (slot-value *3* 'x) 3)
+
+(assert (eql (slot-value *2* 'x) 2))
+
+(assert (eql (slot-value *3* 'x) 3))
+
+(assert (eql (slot-value *3.1* 'x) 2))