[cells-cvs] CVS cells

[ktilton]

Update of /project/cells/cvsroot/cells
In directory clnet:/tmp/cvs-serv11734

Modified Files:
	propagate.lisp 
Log Message:
defobserver now supports an :around option specified in usual place:

  (defobserver accelerator :around () etc......)

Long overdue.

--- /project/cells/cvsroot/cells/propagate.lisp	2006/03/18 00:15:40	1.10
+++ /project/cells/cvsroot/cells/propagate.lisp	2006/03/22 18:48:13	1.11
@@ -112,37 +112,39 @@
 
 ; --- slot change -----------------------------------------------------------
 
-(defmacro defobserver (slotname
-                      (&optional (self-arg 'self) (new-varg 'new-value)
-                                 (oldvarg 'old-value) (oldvargboundp 'old-value-boundp))
-                      &body output-body)
-  `(progn
-     (eval-when (:compile-toplevel :load-toplevel :execute)
-       (setf (get ',slotname :output-defined) t))
-     ,(if (eql (last1 output-body) :test)
-          (let ((temp1 (gensym))
-                (loc-self (gensym)))
-            `(defmethod slot-value-observe #-(or clisp cormanlisp) progn ((slotname (eql ',slotname)) ,self-arg ,new-varg ,oldvarg ,oldvargboundp)
-               (let ((,temp1 (bump-output-count ,slotname))
-                     (,loc-self ,(if (listp self-arg)
-                                     (car self-arg)
-                                   self-arg)))
-                 (when (and ,oldvargboundp ,oldvarg)
-                   (format t "~&output ~d (~a ~a) old: ~a" ,temp1 ',slotname ,loc-self ,oldvarg))
-                 (format t "~&output ~d (~a ~a) new: ~a" ,temp1 ',slotname ,loc-self ,new-varg))))
-        `(defmethod slot-value-observe
-             #-(or clisp cormanlisp) progn ;;broke cells-gtk #+(or clisp cormanlisp) :around
-           ((slotname (eql ',slotname)) ,self-arg ,new-varg ,oldvarg ,oldvargboundp)
-           (declare (ignorable
-                     ,@(flet ((arg-name (arg-spec)
-                                (etypecase arg-spec
-                                  (list (car arg-spec))
-                                  (atom arg-spec))))
-                         (list (arg-name self-arg)(arg-name new-varg)
-                           (arg-name oldvarg)(arg-name oldvargboundp)))))
-           , at output-body
-           ;;broke cells-gtk #+(or clisp cormanlisp) (call-next-method)
-           ))))
+(defmacro defobserver (slotname &rest args &aux (aroundp (eq :around (first args))))
+  (when aroundp (setf args (cdr args)))
+  (destructuring-bind ((&optional (self-arg 'self) (new-varg 'new-value)
+                         (oldvarg 'old-value) (oldvargboundp 'old-value-boundp))
+                       &body output-body) args
+    `(progn
+       (eval-when (:compile-toplevel :load-toplevel :execute)
+         (setf (get ',slotname :output-defined) t))
+       ,(if (eql (last1 output-body) :test)
+            (let ((temp1 (gensym))
+                  (loc-self (gensym)))
+              `(defmethod slot-value-observe #-(or clisp cormanlisp) ,(if aroundp :around 'progn)
+                 ((slotname (eql ',slotname)) ,self-arg ,new-varg ,oldvarg ,oldvargboundp)
+                 (let ((,temp1 (bump-output-count ,slotname))
+                       (,loc-self ,(if (listp self-arg)
+                                       (car self-arg)
+                                     self-arg)))
+                   (when (and ,oldvargboundp ,oldvarg)
+                     (format t "~&output ~d (~a ~a) old: ~a" ,temp1 ',slotname ,loc-self ,oldvarg))
+                   (format t "~&output ~d (~a ~a) new: ~a" ,temp1 ',slotname ,loc-self ,new-varg))))
+          `(defmethod slot-value-observe
+               #-(or clisp cormanlisp) ,(if aroundp :around 'progn)
+             ((slotname (eql ',slotname)) ,self-arg ,new-varg ,oldvarg ,oldvargboundp)
+             (declare (ignorable
+                       ,@(flet ((arg-name (arg-spec)
+                                  (etypecase arg-spec
+                                    (list (car arg-spec))
+                                    (atom arg-spec))))
+                           (list (arg-name self-arg)(arg-name new-varg)
+                             (arg-name oldvarg)(arg-name oldvargboundp)))))
+             , at output-body
+             ;;broke cells-gtk #+(or clisp cormanlisp) (call-next-method)
+             )))))
 
 (defmacro bump-output-count (slotname) ;; pure test func
   `(if (get ',slotname :outputs)