[rjain-utils-cvs] CVS prototypes

[rjain]

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!