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