[rjain-utils-cvs] CVS prototypes
rjain
rjain at common-lisp.net
Tue Nov 24 10:40:13 UTC 2009
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 , at 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 , at 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))
More information about the Rjain-utils-cvs
mailing list