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))))) - ,@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))))) + ,@output-body + ;;broke cells-gtk #+(or clisp cormanlisp) (call-next-method) + )))))

(defmacro bump-output-count (slotname) ;; pure test func `(if (get ',slotname :outputs)