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