Update of /project/rjain-utils/cvsroot/prototypes In directory cl-net:/tmp/cvs-serv9460
Modified Files: prototypes.lisp Log Message: documentation robustness initiarg processing during instance creation
--- /project/rjain-utils/cvsroot/prototypes/prototypes.lisp 2009/11/24 10:40:13 1.4 +++ /project/rjain-utils/cvsroot/prototypes/prototypes.lisp 2009/11/24 10:43:30 1.5 @@ -8,29 +8,65 @@
(in-package :prototypes)
+;;;; +;;;; PROTOTYPE-OBJECT +;;;;
(defclass prototype-object () ((%delegates :initarg :delegates :reader prototype-delegates :writer %set-prototype-delegates - :initform nil))) + :initform nil)) + (:documentation "The root of the prototype hierarchy. Instantiate this + class to create a new prototype, possibly initializing it with + a :DELEGATES argument to provide a list of other prototype instances + that slots will be inherited from.")) + +(defgeneric prototype-add-delegate (object delegate) + ;; TODO: test case + ;; Maybe indicate whether delegate was already there? + (:documentation "Adds a DELEGATE to the end of OBJECT's delegates, if + it is not already there. Returns no values.") + (:method ((object prototype-object) (delegate prototype-object)) + (if (prototype-delegates object) + (loop for tail on (prototype-delegates object) + until (eql delegate (car tail)) + finally (setf (cdr tail) (list delegate))) + (%set-prototype-delegates (list delegate) object)) + (values))) + +(defgeneric prototype-remove-delegate (object delegate) + ;; TODO: test case + ;; Maybe indicate whether delegate was actually found? + (:documentation "Removes DELEGATE from OBJECT's delegates, if it is + there. Returns no values.") + (:method ((object prototype-object) (delegate prototype-object)) + (%set-prototype-delegates (delete delegate (prototype-delegates object)) + object) + (values))) + +;;;; +;;;; Utility for memoization of searches +;;;;
-(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 symbolicate (x) + (make-symbol (write-to-string x :escape nil)))
(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)))) + (restart-case + (add-method generic-function + (make-instance 'standard-method + :lambda-list (mapcar #'symbolicate + specializers) + :specializers specializers + :function (constantly result))) + (disable-memoization () + :report "Disable memoization and continue." + (setf (symbol-function 'memoize-method-result) (constantly nil))))) + +;;;; +;;;; Prototype backend class search and generation +;;;;
(defgeneric prototype-find-subclass (prototype slot-name))
@@ -55,6 +91,13 @@ (or (prototype-find-subclass class slot-name) (prototype-subclass class slot-name)))
+;;;; +;;;; Additional functionality needed for prototype object manipulation +;;;; beyond what CLOS gives us for free +;;;; + +;;; TODO: Delegate down a linearized precedence list. Maybe offer both +;;; CLOS and C3 linearization algorithms. (macrolet ((reader-delegation (operation) `(defmethod slot-missing (class (object prototype-object) slot-name (operation (eql ',operation)) @@ -63,6 +106,12 @@ (dolist (delegate (prototype-delegates object) (call-next-method)) (ignore-errors + ;; if OPERATION succeeds on the delegate, RETURN + ;; that result from our loop, otherwise it will + ;; error and continue on to the next delegate, via + ;; IGNORE-ERRORS. If no delegates are left, it will + ;; call the default method which signals a + ;; slot-missing error. (return (,operation delegate slot-name))))))) (reader-delegation slot-value) (reader-delegation slot-boundp)) @@ -76,8 +125,21 @@ (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))) +;;;; +;;;; Shortcut for single-inheritance +;;;; + +(defmethod make-instance ((prototype prototype-object) &rest initargs + &key &allow-other-keys) + "Create a PROTOTYPE-OBJECT that delegates to the given PROTOTYPE." + (let ((object (make-instance 'prototype-object :delegates (list prototype)))) + (loop for (slot-name value) on initargs by #'cddr + do (setf (slot-value object slot-name) value)) + object)) + +;;;; +;;;; Subclassing of CLOS classes as prototype objects +;;;;
(defgeneric find-std-class-prototype (class))
@@ -101,16 +163,22 @@ (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)) +(defgeneric make-prototype (class &rest initargs + &key delegates &allow-other-keys) + (:documentation "Create a prototype instance that is an instance of + CLASS, initializing it with the given INITARGS, which may + include :DELEGATES to specify the instance's delegates.")) + +(defmethod make-prototype ((class-name symbol) &rest initargs) + (apply #'make-prototype (find-class class-name) initargs)) + +(defmethod make-prototype ((class standard-class) &rest initargs) + (apply #'make-instance (ensure-std-class-prototype class) + initargs))
+;;;; ;;;; TESTS +;;;;
(defparameter *1* (make-instance 'prototype-object)) (setf (slot-value *1* 'x) 1) @@ -174,4 +242,4 @@
(assert (eql (slot-value *t* 'x) :t)) (assert (eql (slot-value *3.t* 'x) 3)) -(assert (eql (slot-value *t.3* 'x) :t)) +(assert (eql (slot-value *t.3* 'x) :t)) ; The slot is class-allocated, remember!