Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv19896
Modified Files: cells.lisp cells.lpr initialize.lisp model-object.lisp propagate.lisp test-propagation.lisp Log Message: make cell (if any) sixth param to slot-value-observe
--- /project/cells/cvsroot/cells/cells.lisp 2008/01/29 04:29:52 1.23 +++ /project/cells/cvsroot/cells/cells.lisp 2008/02/02 00:09:28 1.24 @@ -103,14 +103,14 @@ (define-condition unbound-cell (unbound-slot) ((cell :initarg :cell :reader cell :initform nil)))
-(defgeneric slot-value-observe (slotname self new old old-boundp) +(defgeneric slot-value-observe (slotname self new old old-boundp cell) #-(or cormanlisp) (:method-combination progn))
#-cells-testing (defmethod slot-value-observe #-(or cormanlisp) progn - (slot-name self new old old-boundp) - (declare (ignorable slot-name self new old old-boundp))) + (slot-name self new old old-boundp cell) + (declare (ignorable slot-name self new old old-boundp cell)))
; -------- cell conditions (not much used) --------------------------------------------- --- /project/cells/cvsroot/cells/cells.lpr 2008/02/01 03:18:35 1.29 +++ /project/cells/cvsroot/cells/cells.lpr 2008/02/02 00:09:28 1.30 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.1 [Windows] (Jan 2, 2008 9:44)"; cg: "1.103.2.10"; -*- +;; -*- lisp-version: "8.1 [Windows] (Feb 1, 2008 18:35)"; cg: "1.103.2.10"; -*-
(in-package :cg-user)
@@ -23,7 +23,8 @@ (make-instance 'module :name "md-utilities.lisp") (make-instance 'module :name "family.lisp") (make-instance 'module :name "fm-utilities.lisp") - (make-instance 'module :name "family-values.lisp")) + (make-instance 'module :name "family-values.lisp") + (make-instance 'module :name "test-propagation.lisp")) :projects (list (make-instance 'project-module :name "utils-kt\utils-kt")) :libraries nil --- /project/cells/cvsroot/cells/initialize.lisp 2008/01/31 03:30:17 1.9 +++ /project/cells/cvsroot/cells/initialize.lisp 2008/02/02 00:09:28 1.10 @@ -35,7 +35,7 @@ (trc nil "awaken cell observing" c) (when (> *data-pulse-id* (c-pulse-observed c)) (setf (c-pulse-observed c) *data-pulse-id*) - (slot-value-observe (c-slot-name c) (c-model c) (c-value c) nil nil) + (slot-value-observe (c-slot-name c) (c-model c) (c-value c) nil nil c) (ephemeral-reset c)))
(defmethod awaken-cell ((c c-ruled)) --- /project/cells/cvsroot/cells/model-object.lisp 2008/01/31 03:30:17 1.18 +++ /project/cells/cvsroot/cells/model-object.lisp 2008/02/02 00:09:28 1.19 @@ -156,7 +156,7 @@ (> *data-pulse-id* (c-pulse-observed flushed))) ;; unfrickinlikely (when flushed (setf (c-pulse-observed flushed) *data-pulse-id*)) ;; probably unnecessary - (slot-value-observe slot-name self (bd-slot-value self slot-name) nil nil)))) + (slot-value-observe slot-name self (bd-slot-value self slot-name) nil nil flushed))))
((find (c-lazy c) '(:until-asked :always t)) --- /project/cells/cvsroot/cells/propagate.lisp 2008/02/01 20:41:54 1.32 +++ /project/cells/cvsroot/cells/propagate.lisp 2008/02/02 00:09:28 1.33 @@ -36,11 +36,11 @@
; --- data pulse (change ID) management -------------------------------------
-(defparameter *client-is-propagating* nil) +(defparameter *one-pulse?* nil)
(defun data-pulse-next (pulse-info) (declare (ignorable pulse-info)) - (unless *client-is-propagating* + (unless *one-pulse?* (trc nil "data-pulse-next > " (1+ *data-pulse-id*) pulse-info) (incf *data-pulse-id*)))
@@ -66,7 +66,7 @@ (defparameter *per-cell-handler* nil)
(defun c-propagate (c prior-value prior-value-supplied) - (when *client-is-propagating* + (when *one-pulse?* (when *per-cell-handler* (funcall *per-cell-handler* c prior-value prior-value-supplied) (return-from c-propagate))) @@ -132,7 +132,7 @@ (when t ; breaks algebra (> *data-pulse-id* (c-pulse-observed c)) (setf (c-pulse-observed c) *data-pulse-id*) (slot-value-observe (c-slot-name c) (c-model c) - (c-value c) prior-value prior-value-supplied)) + (c-value c) prior-value prior-value-supplied c))
; @@ -152,7 +152,7 @@ (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)) + (oldvarg 'old-value) (oldvargboundp 'old-value-boundp) (cell-arg 'c)) &body output-body) args `(progn (eval-when (:compile-toplevel :load-toplevel :execute) @@ -161,24 +161,24 @@ (let ((temp1 (gensym)) (loc-self (gensym))) `(defmethod slot-value-observe #-(or cormanlisp) ,(if aroundp :around 'progn) - ((slotname (eql ',slotname)) ,self-arg ,new-varg ,oldvarg ,oldvargboundp) + ((slotname (eql ',slotname)) ,self-arg ,new-varg ,oldvarg ,oldvargboundp ,cell-arg) (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)))) + (format t "~&output ~d (~a ~a) old: ~a" ,temp1 ',slotname ,loc-self ,oldvarg ,cell-arg)) + (format t "~&output ~d (~a ~a) new: ~a" ,temp1 ',slotname ,loc-self ,new-varg ,cell-arg)))) `(defmethod slot-value-observe #-(or cormanlisp) ,(if aroundp :around 'progn) - ((slotname (eql ',slotname)) ,self-arg ,new-varg ,oldvarg ,oldvargboundp) + ((slotname (eql ',slotname)) ,self-arg ,new-varg ,oldvarg ,oldvargboundp ,cell-arg) (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))))) + (arg-name oldvarg)(arg-name oldvargboundp) (arg-name cell-arg))))) ,@output-body)))))
(defmacro bump-output-count (slotname) ;; pure test func @@ -256,56 +256,13 @@ ;(trace c-propagate ensure-value-is-current) (loop for (c prior-value prior-value?) in (nreverse cs) do (c-propagate c prior-value prior-value?))))) - (assert (not *client-is-propagating*)) + (assert (not *one-pulse?*)) (data-pulse-next :client-prop) (trc "call-with-one-datapulse bumps pulse" *data-pulse-id*) (funcall finally - (let ((*client-is-propagating* t) + (let ((*one-pulse?* t) (*per-cell-handler* per-cell) (*the-unpropagated* nil)) (funcall f) *the-unpropagated*)))
-(defmd tcp () - (left (c-in 0)) - (top (c-in 0)) - (right (c-in 0)) - (bottom (c-in 0)) - (area (c? (trc "area running") - (* (- (^right)(^left)) - (- (^top)(^bottom)))))) - -(defobserver area () - (TRC "new area" new-value old-value old-value-boundp :pulse *data-pulse-id*)) - -(defobserver bottom () - (TRC "new bottom" new-value old-value old-value-boundp :pulse *data-pulse-id*) - (with-integrity (:change 'bottom-tells-left) - (setf (^left) new-value))) - -(defobserver left () - (TRC "new left" new-value old-value old-value-boundp :pulse *data-pulse-id*)) - -(defun tcprop () - (untrace) - (test-prep) - (LET ((box (make-instance 'tcp))) - (trc "changing top to 10" *data-pulse-id*) - (setf (top box) 10) - (trc "not changing top" *data-pulse-id*) - (setf (top box) 10) - (trc "changing right to 10" *data-pulse-id*) - (setf (right box) 10) - (trc "not changing right" *data-pulse-id*) - (setf (right box) 10) - (trc "changing bottom to -1" *data-pulse-id*) - (decf (bottom box)) - (with-one-datapulse () - (loop repeat 20 do - (trc "changing bottom by -1" *data-pulse-id*) - (decf (bottom box)))))) - - - - - --- /project/cells/cvsroot/cells/test-propagation.lisp 2008/02/01 15:52:49 1.1 +++ /project/cells/cvsroot/cells/test-propagation.lisp 2008/02/02 00:09:28 1.2 @@ -1,4 +1,3 @@ - (in-package :cells)
(defmd tcp () @@ -13,6 +12,14 @@ (defobserver area () (TRC "new area" new-value old-value old-value-boundp :pulse *data-pulse-id*))
+(defobserver bottom () + (TRC "new bottom" new-value old-value old-value-boundp :pulse *data-pulse-id*) + (with-integrity (:change 'bottom-tells-left) + (setf (^left) new-value))) + +(defobserver left () + (TRC "new left" new-value old-value old-value-boundp :pulse *data-pulse-id*)) + (defun tcprop () (untrace) (test-prep) @@ -27,8 +34,12 @@ (setf (right box) 10) (trc "changing bottom to -1" *data-pulse-id*) (decf (bottom box)) - (with-client-propagation () - (loop repeat 20 do + (with-one-datapulse () + (loop repeat 5 do (trc "changing bottom by -1" *data-pulse-id*) - (decf (bottom box)) - (decf (left box)))))) + (decf (bottom box)))))) + + + + +