Update of /project/rjain-utils/cvsroot/prototypes In directory cl-net:/tmp/cvs-serv7378
Modified Files: prototypes.lisp Log Message: removed metaclass added stdandard-object subclassing added subclass caching
--- /project/rjain-utils/cvsroot/prototypes/prototypes.lisp 2009/11/24 10:38:19 1.3 +++ /project/rjain-utils/cvsroot/prototypes/prototypes.lisp 2009/11/24 10:40:13 1.4 @@ -1,32 +1,54 @@ (defpackage :prototypes + (:export #:prototype-object + #:prototype-delegates + #:prototype-add-delegate + #:prototype-remove-delegate + #:make-prototype) (:use :cl #+sbcl :sb-mop #-sbcl :mop))
(in-package :prototypes)
-(defclass prototype-class (standard-class) - ()) - -(defmethod validate-superclass ((proto prototype-class) (super standard-class)) - t)
(defclass prototype-object () - ((delegates :initarg :delegates :reader prototype-delegates :initform nil)) - (:metaclass prototype-class)) + ((%delegates :initarg :delegates + :reader prototype-delegates + :writer %set-prototype-delegates + :initform nil))) + +(defmethod prototype-add-delegate ((object prototype-object) (delegate prototype-object)) + (loop for tail on (prototype-delegates object) + until (eql object (car tail)) + finally (setf (cdr tail) (list delegate)))) + +(defmethod prototype-remove-delegate ((object prototype-object) (delegate prototype-object)) + (%set-prototype-delegates object (delete delegate (prototype-delegates object)))) + +(defun memoize-method-result (generic-function specializers result) + (add-method generic-function + (make-instance 'standard-method + :lambda-list (mapcar (lambda (x) + (make-symbol (write-to-string x :escape nil))) + specializers) + :specializers specializers + :function (constantly result))))
(defgeneric prototype-find-subclass (prototype slot-name))
-(defmethod prototype-find-subclass ((class prototype-class) slot-name) - (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)) - -(defun prototype-subclass (class slot-name) - (make-instance 'prototype-class - :direct-superclasses (list class) +(defmethod prototype-find-subclass ((object prototype-object) (slot-name symbol)) + (let ((subclass (find slot-name + (class-direct-subclasses (class-of object)) + :key (lambda (subclass) + (slot-definition-name (first (class-direct-slots subclass))))))) + (when subclass + (memoize-method-result #'prototype-find-subclass + (list (class-of object) + (intern-eql-specializer slot-name)) + subclass)) + subclass)) + +(defun prototype-subclass (object slot-name) + (make-instance 'standard-class + :direct-superclasses (list (class-of object)) :direct-slots (list (list :name slot-name :initargs (list slot-name)))))
(defun ensure-subclass (class slot-name) @@ -34,8 +56,8 @@ (prototype-subclass class slot-name)))
(macrolet ((reader-delegation (operation) - `(defmethod slot-missing (class (object prototype-object) slot-name - (operation (eql ',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) @@ -46,21 +68,51 @@ (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))))) + `(defmethod slot-missing (class (object prototype-object) + slot-name (operation (eql ',operation)) + &optional new-value) + (let ((new-class (ensure-subclass object 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 :delegates (list prototype)))
+(defgeneric find-std-class-prototype (class)) + +(defmethod find-std-class-prototype ((class standard-class)) + (let ((subclass (find-if (lambda (subclass) (subtypep subclass class)) + (class-direct-subclasses (find-class 'prototype-object)) + :key (lambda (subclass) + (first (class-direct-superclasses subclass)))))) + (when subclass + (memoize-method-result #'find-std-class-prototype + (list (intern-eql-specializer class)) + subclass)) + subclass)) + +(defun make-std-class-prototype (class) + (make-instance 'standard-class + :direct-superclasses (list class + (find-class 'prototype-object)))) + +(defun ensure-std-class-prototype (class) + (or (find-std-class-prototype class) + (make-std-class-prototype class))) + +(defgeneric make-prototype (class &key delegates)) + +(defmethod make-prototype ((class-name symbol) &key delegates) + (make-prototype (find-class class-name) :delegates delegates)) + +(defmethod make-prototype ((class standard-class) &key delegates) + (make-instance (ensure-std-class-prototype class) + :delegates delegates)) + ;;;; TESTS
(defparameter *1* (make-instance 'prototype-object)) - (setf (slot-value *1* 'x) 1)
(defparameter *2* (make-instance *1*)) @@ -75,26 +127,51 @@
(assert (eql (slot-value *3.1* 'x) 1))
+(defparameter *3.3.1* (make-instance 'prototype-object :delegates (list *3.1* *3*))) + (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)) +(assert (eql (slot-value *3.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)) +(assert (eql (slot-value *3.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))) +(assert (not (slot-boundp *3.3.1* 'x))) + +(defclass test () + ((x :allocation :class))) + +;; need to always reset the slot value because we change it below +(finalize-inheritance (find-class 'test)) +(setf (slot-value (class-prototype (find-class 'test)) 'x) :test) + +(defparameter *t* (make-prototype 'test)) + +(assert (eql (slot-value *t* 'x) :test)) + +(defparameter *3.t* (make-instance 'prototype-object + :delegates (list *3* (make-prototype 'test)))) + +(assert (eql (slot-value *3.t* 'x) 3)) + +(defparameter *t.3* (make-prototype 'test :delegates (list *3*))) + +(assert (eql (slot-value *t.3* 'x) :test)) + +(setf (slot-value *t* 'x) :t) + +(assert (eql (slot-value *t* 'x) :t)) +(assert (eql (slot-value *3.t* 'x) 3)) +(assert (eql (slot-value *t.3* 'x) :t))