Update of /project/cells/cvsroot/cells
In directory clnet:/tmp/cvs-serv31675
Modified Files:
cell-types.lisp constructors.lisp family.lisp
fm-utilities.lisp link.lisp md-slot-value.lisp
md-utilities.lisp propagate.lisp
Log Message:
a couple of serious bug fixes, actually.
--- /project/cells/cvsroot/cells/cell-types.lisp 2006/10/28 18:20:48 1.21
+++ /project/cells/cvsroot/cells/cell-types.lisp 2006/11/03 13:37:10 1.22
@@ -42,6 +42,28 @@
debug
md-info)
+;_____________________ print __________________________________
+
+(defmethod print-object :before ((c cell) stream)
+ (unless (or *stop* *print-readably*)
+ (format stream "[~a~a:" (if (c-inputp c) "i" "?")
+ (cond
+ ((null (c-model c)) #\0)
+ ((eq :eternal-rest (md-state (c-model c))) #\_)
+ ((not (c-currentp c)) #\#)
+ (t #\space)))))
+
+
+(defmethod print-object ((c cell) stream)
+ (if (or *stop* *print-readably*)
+ (call-next-method)
+ (progn
+ (c-print-value c stream)
+ (format stream "=~d/~a/~a]"
+ (c-pulse c)
+ (symbol-name (or (c-slot-name c) :anoncell))
+ (or (and (c-model c)(md-name (c-model c))) :anonmd)))))
+
(defmethod trcp :around ((c cell))
(or (c-debug c)
(call-next-method)))
@@ -136,28 +158,6 @@
(defun c-unboundp (c)
(eql :unbound (c-value-state c)))
-;_____________________ print __________________________________
-
-(defmethod print-object :before ((c cell) stream)
- (unless (or *stop* *print-readably*)
- (format stream "[~a~a:" (if (c-inputp c) "i" "?")
- (cond
- ((null (c-model c)) #\0)
- ((eq :eternal-rest (md-state (c-model c))) #\_)
- ((not (c-currentp c)) #\#)
- (t #\space)))))
-
-
-(defmethod print-object ((c cell) stream)
- (if (or *stop* *print-readably*)
- (call-next-method)
- (progn
- (c-print-value c stream)
- (format stream "=~d/~a/~a]"
- (c-pulse c)
- (symbol-name (or (c-slot-name c) :anoncell))
- (or (c-model c) :anonmd)))))
-
;__________________
--- /project/cells/cvsroot/cells/constructors.lisp 2006/10/28 18:20:48 1.11
+++ /project/cells/cvsroot/cells/constructors.lisp 2006/11/03 13:37:10 1.12
@@ -53,13 +53,14 @@
:value-state :unevaluated
:rule (c-lambda (without-c-dependency ,@body))))
-(defmacro c?n-until (&body body)
+(defmacro c?n-until (args &body body)
`(make-c-dependent
:optimize :when-value-t
:code ',body
:inputp t
:value-state :unevaluated
- :rule (c-lambda ,@body)))
+ :rule (c-lambda ,@body)
+ ,@args))
(export! c?once c?n-until)
(defmacro c?once (&body body)
--- /project/cells/cvsroot/cells/family.lisp 2006/09/05 18:40:47 1.14
+++ /project/cells/cvsroot/cells/family.lisp 2006/11/03 13:37:10 1.15
@@ -36,8 +36,8 @@
new-value)
(defmethod print-object ((self model) s)
- (format s "~a" (type-of self))
- #+shhh (format s "~a" (or (md-name self) (type-of self))))
+ #+shhh (format s "~a" (type-of self))
+ (format s "~a" (or (md-name self) (type-of self))))
(define-symbol-macro .parent (fm-parent self))
--- /project/cells/cvsroot/cells/fm-utilities.lisp 2006/10/13 05:56:38 1.12
+++ /project/cells/cvsroot/cells/fm-utilities.lisp 2006/11/03 13:37:10 1.13
@@ -295,12 +295,11 @@
(car (cdr (member ,s (kids (fm-parent ,s))))))))
(defun find-prior (self sibs &key (test #'true-that))
- (c-assert (member self sibs)) ;; got this by accidentally having toolbar kids dependent..on second calc,
- ;; all newkids got over, and when old kids tried to recalculate...not in sibs!!
+ (c-assert (member self sibs) () "find-prior of ~a does not find it in sibs arg ~a" self sibs)
(unless (eql self (car sibs))
(labels
((fpsib (rsibs &aux (psib (car rsibs)))
- (c-assert rsibs () "~&find-prior > fpsib > self ~s not found to prior off" self)
+ (c-assert rsibs () "find-prior > fpsib > self ~s not found to prior off" self)
(if (eql self (cadr rsibs))
(when (funcall test psib) psib)
(or (fpsib (cdr rsibs))
--- /project/cells/cvsroot/cells/link.lisp 2006/10/28 18:20:48 1.20
+++ /project/cells/cvsroot/cells/link.lisp 2006/11/03 13:37:10 1.21
@@ -39,7 +39,7 @@
finally (return (values (when u-pos (- length u-pos)) length)))
(when (null used-pos)
- (trc caller "c-link > new caller,used " caller used)
+ (trc nil "c-link > new caller,used " caller used)
(count-it :new-used)
(setf used-pos useds-len)
(push used (cd-useds caller))
@@ -62,7 +62,7 @@
(usage-size (array-dimension (cd-usage c) 0))
(dbg nil)) ;; #+not (and (typep (c-model c) 'mathx::mx-solver-stack)
;;(eq (c-slot-name c) '.kids))))
- (declare (ignorable usage-size))
+ (declare (ignorable dbg usage-size))
(when (cd-useds c)
(let (rev-pos)
(labels ((nail-unused (useds)
@@ -71,7 +71,7 @@
(zerop (sbit usage rpos)))
(progn
(count-it :unlink-unused)
- (trc c "c-unlink-unused" c :dropping-used (car useds))
+ (trc nil "c-unlink-unused" c :dropping-used (car useds))
(c-unlink-caller (car useds) c)
(rplaca useds nil))
(progn
@@ -83,7 +83,7 @@
(nail-unused (cdr useds))
(handle-used (incf rev-pos)))
(handle-used (setf rev-pos 0))))))
- (trc dbg "cd-useds length" (length (cd-useds c)) c)
+ (trc nil "cd-useds length" (length (cd-useds c)) c)
(nail-unused (cd-useds c))
(setf (cd-useds c) (delete nil (cd-useds c)))))))
@@ -104,7 +104,7 @@
(defmethod c-unlink-from-used ((caller c-dependent))
(dolist (used (cd-useds caller))
- #+dfdbg (trc nil "unlinking from used" caller used)
+ (trc nil "unlinking from used" caller used)
(c-unlink-caller used caller))
;; shouldn't be necessary (setf (cd-useds caller) nil)
)
@@ -115,7 +115,7 @@
;----------------------------------------------------------
(defun c-unlink-caller (used caller)
- (trc nil "caller unlinking from used" caller used)
+ (trc caller "(1) caller unlinking from (2) used" caller used)
(caller-drop used caller)
(c-unlink-used caller used))
--- /project/cells/cvsroot/cells/md-slot-value.lisp 2006/10/28 18:20:48 1.30
+++ /project/cells/cvsroot/cells/md-slot-value.lisp 2006/11/03 13:37:10 1.31
@@ -66,7 +66,8 @@
;;
((and (c-inputp c)
(c-validp c) ;; a c?n (ruled-then-input) cell will not be valid at first
- (not (and (eq (cd-optimize c) :when-value-t)
+ (not (and (typep c 'c-dependent)
+ (eq (cd-optimize c) :when-value-t)
(null (c-value c))))))
((or (not (c-validp c))
@@ -86,6 +87,7 @@
(when (> (c-pulse-last-changed used)(c-pulse c))
(trc nil "used changed and newer !!!!!!" c debug-id used)
t))))))
+ (assert (typep c 'c-dependent))
(check-reversed (cd-useds c))))
(trc nil "kicking off calc-set of" (c-slot-name c) :pulse *data-pulse-id*)
(calculate-and-set c))
@@ -135,6 +137,7 @@
(defun calculate-and-link (c)
(let ((*call-stack* (cons c *call-stack*))
(*defer-changes* t))
+ (assert (typep c 'c-ruled))
(cd-usage-clear-all c)
(multiple-value-prog1
(funcall (cr-rule c) c)
@@ -246,9 +249,10 @@
; --- data flow propagation -----------
(unless (eq propagation-code :no-propagate)
- (trc nil "md-slot-value-assume flagging as changed" c)
+ (trc nil "md-slot-value-assume flagging as changed: prior state, value:" prior-state prior-value )
(setf (c-pulse-last-changed c) *data-pulse-id*)
- (c-propagate c prior-value (eq prior-state :valid))) ;; until 06-02-13 was (not (eq prior-state :unbound))
+ (c-propagate c prior-value (or (eq prior-state :valid)
+ (eq prior-state :uncurrent)))) ;; until 06-02-13 was (not (eq prior-state :unbound))
absorbed-value)))
@@ -260,7 +264,7 @@
(null (cd-useds c))
(cd-optimize c)
(not (c-optimized-away-p c)) ;; c-streams (FNYI) may come this way repeatedly even if optimized away
- (c-validp c) ;; /// when would this not be the case?
+ (c-validp c) ;; /// when would this not be the case? and who cares?
(not (c-synaptic c)) ;; no slot to cache invariant result, so they have to stay around)
(not (c-inputp c)) ;; yes, dependent cells can be inputp
)
--- /project/cells/cvsroot/cells/md-utilities.lisp 2006/10/28 18:20:48 1.10
+++ /project/cells/cvsroot/cells/md-utilities.lisp 2006/11/03 13:37:10 1.11
@@ -65,6 +65,7 @@
(c-unlink-from-used c)
(dolist (caller (c-callers c))
(setf (c-value-state caller) :uncurrent)
+ (trc nil "c-quiesce unlinking caller" c)
(c-unlink-caller c caller))
(setf (c-state c) :quiesced) ;; 20061024 for debugging for now, might break some code tho
)))
--- /project/cells/cvsroot/cells/propagate.lisp 2006/10/17 21:28:39 1.24
+++ /project/cells/cvsroot/cells/propagate.lisp 2006/11/03 13:37:10 1.25
@@ -61,7 +61,8 @@
(defun c-propagate (c prior-value prior-value-supplied)
(count-it :c-propagate)
-
+ (when prior-value
+ (assert prior-value-supplied () "How can prior-value-supplied be nil if prior-value is not?!! ~a" c))
(let (*call-stack*
(*c-prop-depth* (1+ *c-prop-depth*))
(*defer-changes* t))
@@ -72,8 +73,8 @@
(when *stop*
(princ #\.)(princ #\!)
(return-from c-propagate))
- (trc c "c-propagate> !!!!!!!!!!!!!! propping" c (c-value c) :caller-ct (length (c-callers c)) c)
-
+ (trc nil "c-propagate> !!!!!!! propping" c (c-value c) :caller-ct (length (c-callers c)) c)
+ (trc nil "c-propagate> !!!! new value" (c-value c) :prior-value prior-value :caller-ct (length (c-callers c)) c)
(when *c-debug*
(when (> *c-prop-depth* 250)
(trc nil "c-propagate deep" *c-prop-depth* (c-model c) (c-slot-name c) #+nah c))
@@ -82,6 +83,24 @@
; --- manifest new value as needed ---
;
+ ; 20061030 Trying not-to-be first because doomed instances may be interested in callers
+ ; who will decide to propagate. If a family instance kids slot is changing, a doomed kid
+ ; will be out of the kids but not yet quiesced. If the propagation to this rule asks the kid
+ ; to look at its siblings (say a view instance being deleted from a stack who looks to the psib
+ ; pb to decide its own pt), the doomed kid will still have a parent but not be in its kids slot
+ ; when it goes looking for a sibling relative to its position.
+ ;
+ (when (and prior-value-supplied
+ prior-value
+ (md-slot-owning (type-of (c-model c)) (c-slot-name c)))
+ (trc nil "c-propagate> contemplating lost")
+ (flet ((listify (x) (if (listp x) x (list x))))
+ (bIf (lost (set-difference (listify prior-value) (listify (c-value c))))
+ (progn
+ (trc nil "prop nailing owned" c :lost lost :leaving (c-value c))
+ (mapcar 'not-to-be lost))
+ (trc nil "no owned lost!!!!!"))))
+
; propagation to callers jumps back in front of client slot-value-observe handling in cells3
; because model adopting (once done by the kids change handler) can now be done in
; shared-initialize (since one is now forced to supply the parent to make-instance).
@@ -96,13 +115,7 @@
(slot-value-observe (c-slot-name c) (c-model c)
(c-value c) prior-value prior-value-supplied)
- (when (and prior-value-supplied
- prior-value
- (md-slot-owning (type-of (c-model c)) (c-slot-name c)))
- (flet ((listify (x) (if (listp x) x (list x))))
- (bwhen (lost (set-difference (listify prior-value) (listify (c-value c))))
- (trc nil "prop nailing owned" c (c-value c) prior-value lost)
- (mapcar 'not-to-be lost))))
+
;
; with propagation done, ephemerals can be reset. we also do this in c-awaken, so
; let the fn decide if C really is ephemeral. Note that it might be possible to leave
@@ -174,13 +187,19 @@
(c-callers c))
(let ((causation (cons c *causation*)) ;; in case deferred
)
+ (TRC c "c-propagate-to-callers > queueing notifying callers" (mapcar 'c-slot-name (c-callers c)))
(with-integrity (:tell-dependents c)
(assert (null *call-stack*))
(let ((*causation* causation))
- (trc nil "c-propagate-to-callers > actually notifying callers of" c (mapcar 'c-slot-name (c-callers c)))
+ (trc c "c-propagate-to-callers > actually notifying callers of" c (mapcar 'c-slot-name (c-callers c)))
(dolist (caller (c-callers c))
- (unless (member (c-lazy caller) '(t :always :once-asked))
- (trc nil "propagating to caller is caller:" caller)
+ (assert (find c (cd-useds caller)) () "test 1 failed ~a ~a" c caller))
+
+ (dolist (caller (c-callers c)) ;; following code may modify c-callers list...
+ (unless (or (eq (c-state caller) :quiesced) ;; ..so watch for quiesced
+ (member (c-lazy caller) '(t :always :once-asked)))
+ (assert (find c (cd-useds caller)))
+ (trc caller "propagating to caller is caller:" caller)
(ensure-value-is-current caller :prop-from c))))))))
