[rjain-utils-cvs] CVS prototypes

[rjain]

Update of /project/rjain-utils/cvsroot/prototypes
In directory cl-net:/tmp/cvs-serv4504

Modified Files:
	prototypes.lisp 
Log Message:
use CLOSER-MOP
allow slot-unbound errors to propagate out of slot-value accessors
add test case for above change


--- /project/rjain-utils/cvsroot/prototypes/prototypes.lisp	2009/11/24 10:43:30	1.5
+++ /project/rjain-utils/cvsroot/prototypes/prototypes.lisp	2009/11/25 10:46:36	1.6
@@ -4,7 +4,7 @@
            #:prototype-add-delegate
            #:prototype-remove-delegate
            #:make-prototype)
-  (:use :cl #+sbcl :sb-mop #-sbcl :mop))
+  (:use :cl :closer-mop))
 
 (in-package :prototypes)
 
@@ -104,14 +104,20 @@
                                        &optional new-value)
                 (declare (ignore new-value))
                 (dolist (delegate (prototype-delegates object)
+                         ;; if no slot is found in all the delegates, we
+                         ;; call the default method to signal a
+                         ;; slot-missing error
                          (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.
+                  (handler-bind ((unbound-slot #'error)
+                                 ;; there is no specific class for
+                                 ;; slot-missing errors. the spec just
+                                 ;; says signals an error of type error.
+                                 ;; ugh.
+                                 (error 
+                                  ;; can't find the slot here, so we
+                                  ;; continue to the next delegate
+                                  #'identity))
+                    ;; if this finds the slot, we return it
                     (return (,operation delegate slot-name)))))))
   (reader-delegation slot-value)
   (reader-delegation slot-boundp))
@@ -217,6 +223,11 @@
 (assert (eql (slot-value *3* 'x) 3))
 (assert (not (slot-boundp *3.1* 'x)))
 (assert (not (slot-boundp *3.3.1* 'x)))
+(handler-case
+    (progn
+      (slot-value *3.3.1* 'x)
+      (assert nil))
+  (unbound-slot (error)))
 
 (defclass test ()
   ((x :allocation :class)))