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 ,@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)))