[cells-cvs] CVS update: cells/cell-types.lisp cells/fm-utilities.lisp cells/md-slot-value.lisp cells/propagate.lisp

[Kenny Tilton]

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