[cells-cvs] CVS cells

[ktilton]

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

Modified Files:
	cell-types.lisp initialize.lisp md-slot-value.lisp 
	model-object.lisp propagate.lisp 
Log Message:
Fixed a whole in initialization such that a slot could be observed twice, unhealthy when observers have side effects.

--- /project/cells/cvsroot/cells/cell-types.lisp	2008/01/29 04:29:52	1.28
+++ /project/cells/cvsroot/cells/cell-types.lisp	2008/01/31 03:30:17	1.29
@@ -37,6 +37,7 @@
                                                        ; a dependency on the existence of instance owning X
   (pulse 0 :type fixnum)
   (pulse-last-changed 0 :type fixnum) ;; lazys can miss changes by missing change of X followed by unchange of X in subsequent DP
+  (pulse-observed 0 :type fixnum)
   lazy
   (optimize t)
   debug
--- /project/cells/cvsroot/cells/initialize.lisp	2006/06/23 01:04:56	1.8
+++ /project/cells/cvsroot/cells/initialize.lisp	2008/01/31 03:30:17	1.9
@@ -32,8 +32,11 @@
   ;
   ; nothing to calculate, but every cellular slot should be output
   ;
-  (slot-value-observe (c-slot-name c) (c-model c) (c-value c) nil nil)
-  (ephemeral-reset c))
+  (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)
+    (ephemeral-reset c)))
 
 (defmethod awaken-cell ((c c-ruled))
   (let (*call-stack*)
--- /project/cells/cvsroot/cells/md-slot-value.lisp	2008/01/29 04:29:52	1.37
+++ /project/cells/cvsroot/cells/md-slot-value.lisp	2008/01/31 03:30:17	1.38
@@ -328,7 +328,7 @@
           )
     ;; (when (trcp c) (break "go optimizing ~a" c))
     
-    #+shh (when (trcp c)
+    (when (trcp c)
       (trc "optimizing away" c (c-state c) (rassoc c (cells (c-model c)))(rassoc c (cells-flushed (c-model c))))
       )
 
--- /project/cells/cvsroot/cells/model-object.lisp	2008/01/29 04:29:52	1.17
+++ /project/cells/cvsroot/cells/model-object.lisp	2008/01/31 03:30:17	1.18
@@ -104,7 +104,8 @@
 
 (defmethod md-awaken :around ((self model-object))
   (when (eql :nascent (md-state self))
-    (call-next-method)))
+    (call-next-method))
+  self)
 
 #+test
 (md-slot-cell-type 'cgtk::label 'cgtk::container)
@@ -150,7 +151,12 @@
           ;; but first I worried about it being slow keeping the flushed list /and/ searching, then
           ;; I wondered why a flushed cell should not be observed, constant cells are. So Just Observe It
           
-          (slot-value-observe slot-name self (bd-slot-value self slot-name) nil nil))
+          (let ((flushed (md-slot-cell-flushed self slot-name)))
+            (when (or (null flushed) ;; constant, ie, never any cell provided for this slot
+                    (> *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))))
 
 
          ((find (c-lazy c) '(:until-asked :always t))
@@ -179,6 +185,11 @@
       (cdr (assoc slot-name (cells self)))
     (get slot-name 'cell)))
 
+(defmethod md-slot-cell-flushed (self slot-name)
+  (if self
+      (cdr (assoc slot-name (cells-flushed self)))
+    (get slot-name 'cell)))
+
 #+test
 (get 'cgtk::label :cell-types)
 
--- /project/cells/cvsroot/cells/propagate.lisp	2007/11/30 16:51:18	1.28
+++ /project/cells/cvsroot/cells/propagate.lisp	2008/01/31 03:30:17	1.29
@@ -113,8 +113,14 @@
     (unless nil #+not (member (c-lazy c) '(t :always :once-asked)) ;; 2006-09-26 still fuzzy on this 
       (c-propagate-to-callers c))
     
-    (slot-value-observe (c-slot-name c) (c-model c)
-      (c-value c) prior-value prior-value-supplied)
+    (trc nil "c-propagate observing" c)
+
+    ; this next assertion is just to see if we can ever come this way twice. If so, just
+    ; make it a condition on whether to observe
+    (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))
     
     
     ;