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))))))
+
+
+
+
+
