Update of /project/cells/cvsroot/cells In directory common-lisp.net:/tmp/cvs-serv26948
Modified Files: cell-types.lisp fm-utilities.lisp md-slot-value.lisp propagate.lisp Log Message: Dow-Jones use case: Use new :no-propagate rule option to suppress processing of trades at unchanged price. Date: Sat May 21 03:40:54 2005 Author: ktilton
Index: cells/cell-types.lisp diff -u cells/cell-types.lisp:1.4 cells/cell-types.lisp:1.5 --- cells/cell-types.lisp:1.4 Thu May 19 22:17:47 2005 +++ cells/cell-types.lisp Sat May 21 03:40:53 2005 @@ -38,6 +38,10 @@ debug md-info)
+(defmethod trcp ((c cell)) + nil #+not (and (typep (c-model c) 'index) + (eql 'state (c-slot-name c)))) + (defun c-unboundp (c) (eql :unbound (c-value-state c)))
Index: cells/fm-utilities.lisp diff -u cells/fm-utilities.lisp:1.1 cells/fm-utilities.lisp:1.2 --- cells/fm-utilities.lisp:1.1 Fri May 6 23:05:45 2005 +++ cells/fm-utilities.lisp Sat May 21 03:40:53 2005 @@ -123,26 +123,25 @@
(defun fm-traverse (family applied-fn &key skip-node skip-tree global-search (opaque nil)) ;;(when *fmdbg* (trc "fm-traverse" family skipTree skipNode global-search)) + (without-c-dependency (when family - (labels ((tv-family (fm) - (when (and (typep fm 'model-object) - (not (eql fm skip-tree))) - (let ((outcome (and (not (eql skip-node fm)) ;; skipnode new 990310 kt - (funcall applied-fn fm)))) - (unless (and outcome opaque) - (dolist (kid (kids fm)) - (tv-family kid)) - ;(tv-family (mdValue fm)) - ))))) - (tv-family family) - (when global-search - (fm-traverse (fm-parent family) applied-fn - :global-search t - :skip-tree family - :skip-node skip-node) - ) - ) - nil)) + (labels ((tv-family (fm) + (when (and (typep fm 'model-object) + (not (eql fm skip-tree))) + (let ((outcome (and (not (eql skip-node fm)) ;; skipnode new 990310 kt + (funcall applied-fn fm)))) + (unless (and outcome opaque) + (dolist (kid (kids fm)) + (tv-family kid)) + ;(tv-family (mdValue fm)) + ))))) + (tv-family family) + (when global-search + (fm-traverse (fm-parent family) applied-fn + :global-search t + :skip-tree family + :skip-node skip-node)))) + nil))
(defmethod sub-nodes (other) (declare (ignore other))) @@ -423,10 +422,11 @@ :global-search global-search))
(defmacro fm^ (md-name &key (skip-tree 'self)) - `(fm-find-one (fm-parent self) ,md-name - :skip-tree ,skip-tree - :must-find t - :global-search t)) + `(without-c-dependency + (fm-find-one (fm-parent self) ,md-name + :skip-tree ,skip-tree + :must-find t + :global-search t)))
(defmacro fm? (md-name &optional (starting 'self) (global-search t)) `(fm-find-one ,starting ,(if (consp md-name)
Index: cells/md-slot-value.lisp diff -u cells/md-slot-value.lisp:1.6 cells/md-slot-value.lisp:1.7 --- cells/md-slot-value.lisp:1.6 Thu May 19 22:17:47 2005 +++ cells/md-slot-value.lisp Sat May 21 03:40:53 2005 @@ -184,7 +184,7 @@
; --- data flow propagation ----------- ; - (trc nil "md-sv comparing" c prior-state absorbed-value prior-value) + (trc nil "md-sv comparing no-prop" c prior-state absorbed-value prior-value) (if (or (eq propagation-code :no-propagate) (and (null propagation-code) (eql prior-state :valid) @@ -194,7 +194,7 @@ (count-it :nonews)) (progn (setf (c-changed c) t) - (trc nil "sv-assume: flagging as changed" c absorbed-value prior-value prior-state) + (trc nil "sv-assume: propagating changed as changed" c) ;; absorbed-value prior-value prior-state) (when (eql '.kids (c-slot-name c)) (md-kids-change (c-model c) absorbed-value prior-value :mdslotvalueassume))
Index: cells/propagate.lisp diff -u cells/propagate.lisp:1.5 cells/propagate.lisp:1.6 --- cells/propagate.lisp:1.5 Thu May 19 22:17:47 2005 +++ cells/propagate.lisp Sat May 21 03:40:53 2005 @@ -65,7 +65,7 @@ (bwhen (dead (catch :mdead (trc nil "c-propagate-to-users> *data-pulse-id*, user, c:" *data-pulse-id* user c) (when (c-user-cares user) - (trc nil "c=prop updating" user :used c) + (trc user "propagating to user is (used,user):" c user) (c-value-ensure-current user)) nil)) (when (eq dead (c-model c))