[cells-cvs] CVS cells

ktilton ktilton at common-lisp.net
Mon Oct 2 02:38:32 UTC 2006


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

Modified Files:
	cell-types.lisp cells-manifesto.txt cells.lisp 
	constructors.lisp defmodel.lisp fm-utilities.lisp 
	integrity.lisp md-slot-value.lisp model-object.lisp 
	propagate.lisp 
Log Message:
Hope I have not broken things, but consider this a warning: I may have.

--- /project/cells/cvsroot/cells/cell-types.lisp	2006/07/25 10:51:48	1.17
+++ /project/cells/cvsroot/cells/cell-types.lisp	2006/10/02 02:38:31	1.18
@@ -25,12 +25,13 @@
   
   inputp ;; t for old c-variable class
   synaptic
-  changed
   (caller-store (make-fifo-queue) :type cons) ;; (C3) probably better to notify callers FIFO
   
   (state :nascent :type symbol) ;; :nascent, :awake, :optimized-away
   (value-state :unbound :type symbol) ;; {:unbound | :unevaluated | :valid}
   (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
+  lazy
   debug
   md-info)
 
@@ -46,9 +47,8 @@
   (fifo-delete (c-caller-store used) caller))
 
 (defmethod trcp ((c cell))
-  #+not (and ;; (typep (c-model c) 'index)
-   (find (c-slot-name c) '(celtk::state mathx::problem))))
-
+   (and  #+not(typep (c-model c) 'index)
+     (find (c-slot-name c) '(mathx::line-breaks mathx::phrases))))
 
 ; --- ephemerality --------------------------------------------------
 ; 
@@ -86,16 +86,12 @@
 (defstruct (c-ruled
             (:include cell)
             (:conc-name cr-))
-  lazy
   (code nil :type list) ;; /// feature this out on production build
   rule)
 
 (defun c-optimized-away-p (c)
   (eql :optimized-away (c-state c)))
 
-(defmethod c-lazy ((c c-ruled)) (cr-lazy c))
-(defmethod c-lazy (c) (declare (ignore c)) nil)
-
 ;----------------------------
 
 (defmethod trcp-slot (self slot-name)
--- /project/cells/cvsroot/cells/cells-manifesto.txt	2006/06/29 09:54:06	1.8
+++ /project/cells/cvsroot/cells/cells-manifesto.txt	2006/10/02 02:38:31	1.9
@@ -13,7 +13,7 @@
 he had to propagate that change to other cells by first remembering 
 which other ones included the changed cell in their computation. 
 Then he had to do the calculations for those, erase, enter...
-and then repeating that process to propagate those changes in a 
+and then repeat that process to propagate those changes in a 
 cascade across the paper.
 
 VisiCalc let my father take the formula he had in mind and 
@@ -61,7 +61,7 @@
 way around it, and thus his prediction that a software silver bullet was
 in principle impossible.
 
-Which brings us to Cells. See also [axiom] Phillip Eby's developiong axiomatic 
+Which brings us to Cells. See also [axiom] Phillip Eby's developing axiomatic 
 definition he is developing in support of Ryan Forseth's SoC project.
 
 DEFMODEL and Slot types
@@ -236,8 +236,8 @@
 Let's return for a moment to VisiCalc and its descendants. In even the most complex financial spreadsheet  
 model, no one cell rule accesses more than a relatively few other spreadsheet cells (counting a row or 
 column range as one reference). Yet the complex model emerges. All the work of tracking dependencies
-is handled by the spreadsheet software, which require no special declaration by the modeller. They simply 
-writes the Cell rule. In writing the rule, they are concerned only with the derivation of one datapoint from
+is handled by the spreadsheet software, which requires no special declaration by the modeller. They simply 
+write the Cell rule. In writing the rule, they are concerned only with the derivation of one datapoint from
 a population of other datapoints. No effort goes into arranging for the rule to get run at the right time,
 and certainly no energy is spent worrying about what other cells might be using the authored cell. That
 cell has certain semantics -- "account balance", perhaps -- and the modeller need only worry about writing
@@ -251,8 +251,8 @@
 
 Model Building
 --------------
-Everything above could describe one instance of one class defined by DEFMODEL. Of course, we want multiples
-of both. In brief:
+Everything above could describe one instance of one class defined by DEFMODEL. A real application has 
+multiple instances of multiple classes. So...
 
 -- cells can depend on other cells from any other instance. Since a rule gets passed only "self", Cell users
 need something like the Family class included with the Cells package effectively to turn a collection of
@@ -312,6 +312,7 @@
  The dataflow paradigm: http://en.wikipedia.org/wiki/Dataflow
  Reactive programming: http://www.haskell.org/yampa/AFPLectureNotes.pdf
  Frame-based programming
+ Definitive-programming
 
 Commentary
 ----------
--- /project/cells/cvsroot/cells/cells.lisp	2006/08/21 04:29:30	1.16
+++ /project/cells/cvsroot/cells/cells.lisp	2006/10/02 02:38:31	1.17
@@ -25,7 +25,6 @@
 (defparameter *causation* nil)
 
 (defparameter *data-pulse-id* 0)
-(defparameter *data-pulses* nil)
 
 (defparameter *c-debug* nil)
 (defparameter *defer-changes* nil)
@@ -33,12 +32,12 @@
 (defparameter *client-queue-handler* nil)
 (defparameter *unfinished-business* nil)
 
-(defun cells-reset (&optional client-queue-handler)
+(defun cells-reset (&optional client-queue-handler &key debug)
   (utils-kt-reset)
   (setf 
+   *c-debug* debug
    *c-prop-depth* 0
    *data-pulse-id* 0
-   *data-pulses* nil
    *defer-changes* nil ;; should not be necessary, but cannot be wrong
    *client-queue-handler* client-queue-handler
    *within-integrity* nil
--- /project/cells/cvsroot/cells/constructors.lisp	2006/07/06 22:10:01	1.8
+++ /project/cells/cvsroot/cells/constructors.lisp	2006/10/02 02:38:31	1.9
@@ -48,11 +48,19 @@
 
 (defmacro c?n (&body body)
   `(make-c-dependent
-    :code nil ;; `(without-c-dependency ,@,body)
+    :code '(without-c-dependency , at body)
     :inputp t
     :value-state :unevaluated
     :rule (c-lambda (without-c-dependency , at body))))
 
+(export! c?once)
+(defmacro c?once (&body body)
+  `(make-c-dependent
+    :code '(without-c-dependency , at body)
+    :inputp nil
+    :value-state :unevaluated
+    :rule (c-lambda (without-c-dependency , at body))))
+
 (defmacro c?dbg (&body body)
   `(make-c-dependent
     :code ',body
--- /project/cells/cvsroot/cells/defmodel.lisp	2006/09/05 18:40:47	1.9
+++ /project/cells/cvsroot/cells/defmodel.lisp	2006/10/02 02:38:31	1.10
@@ -20,6 +20,7 @@
 
 (defmacro defmodel (class directsupers slotspecs &rest options)
   ;;(print `(defmodel sees directsupers ,directsupers using ,(or directsupers :model-object)))
+  (assert (not (find class directsupers))() "~a cannot be its own superclass" class)
   `(progn
      (eval-when (:compile-toplevel :execute :load-toplevel)
        (setf (get ',class :cell-types) nil))
@@ -34,94 +35,87 @@
                             &allow-other-keys)
                           slotspec
                         
-                        (declare (ignorable slotargs))
+                        (declare (ignorable slotargs owning))
                         (list
                          (when cell
                            (let* ((reader-fn (or reader accessor))
-                                  (deriver-fn (intern$ "^" (symbol-name reader-fn)))
-                                  )
-                             ;
-                             ; may as well do this here...
-                             ;
-                             ;;(trc nil "slot, deriverfn would be" slotname deriverfn)
+                                  (deriver-fn (intern$ "^" (symbol-name reader-fn))))
                              `(eval-when (:compile-toplevel :execute :load-toplevel)
-                                (setf (md-slot-cell-type ',class ',slotname) ,cell)
                                 (unless (macro-function ',deriver-fn)
                                   (defmacro ,deriver-fn ()
-                                    `(,',reader-fn self))))))
-                         (when owning
-                           `(eval-when (:compile-toplevel :execute :load-toplevel)
-                              (setf (md-slot-owning ',class ',slotname) ,owning)))))))
-  
-  ;
-  ; -------  defclass ---------------  (^slot-value ,model ',',slotname)
-  ;
-  
-  (progn
-    (defclass ,class ,(or directsupers '(model-object));; now we can def the class
-      ,(mapcar (lambda (s)
-                 (list* (car s)
-                   (let ((ias (cdr s)))
-                     ;; We handle accessor below
-                     (when (getf ias :cell t)
-                       (remf ias :reader)
-                       (remf ias :writer)
-                       (remf ias :accessor))
-                     (remf ias :cell)
-                     (remf ias :owning)
-                     (remf ias :unchanged-if)
-                     ias))) (mapcar #'copy-list slotspecs))
-      (:documentation
-       ,@(or (cdr (find :documentation options :key #'car))
-           '("chya")))
-      (:default-initargs ;; nil ok and needed: acl oddity in re not clearing d-i's sans this
-          ,@(cdr (find :default-initargs options :key #'car)))
-      (:metaclass ,(or (cadr (find :metaclass options :key #'car))
-                     'standard-class)))
-    
-    (defmethod shared-initialize :after ((self ,class) slot-names &rest iargs &key)
-      (declare (ignore slot-names iargs))
-      ,(when (and directsupers (not (member 'model-object directsupers)))
-         `(unless (typep self 'model-object)
-            (error "If no superclass of ~a inherits directly
+                                    `(,',reader-fn self))))))))))
+     
+     ;
+     ; -------  defclass ---------------  (^slot-value ,model ',',slotname)
+     ;
+     
+     (progn
+       (defclass ,class ,(or directsupers '(model-object));; now we can def the class
+         ,(mapcar (lambda (s)
+                    (list* (car s)
+                      (let ((ias (cdr s)))
+                        ;; We handle accessor below
+                        (when (getf ias :cell t)
+                          (remf ias :reader)
+                          (remf ias :writer)
+                          (remf ias :accessor))
+                        (remf ias :cell)
+                        (remf ias :owning)
+                        (remf ias :unchanged-if)
+                        ias))) (mapcar #'copy-list slotspecs))
+         (:documentation
+          ,@(or (cdr (find :documentation options :key #'car))
+              '("chya")))
+         (:default-initargs ;; nil ok and needed: acl oddity in re not clearing d-i's sans this
+             ,@(cdr (find :default-initargs options :key #'car)))
+         (:metaclass ,(or (cadr (find :metaclass options :key #'car))
+                        'standard-class)))
+       
+       (defmethod shared-initialize :after ((self ,class) slot-names &rest iargs &key)
+         (declare (ignore slot-names iargs))
+         ,(when (and directsupers (not (member 'model-object directsupers)))
+            `(unless (typep self 'model-object)
+               (error "If no superclass of ~a inherits directly
 or indirectly from model-object, model-object must be included as a direct super-class in
 the defmodel form for ~a" ',class ',class))))
-    ;
-    ; slot accessors once class is defined...
-    ;
-    ,@(mapcar (lambda (slotspec)
-                (destructuring-bind
-                    (slotname &rest slotargs
-                      &key (cell t) unchanged-if (accessor slotname) reader writer type
-                      &allow-other-keys)
-                    slotspec
-                  
-                  (declare (ignorable slotargs))
-                  (when cell
-                    (let* ((reader-fn (or reader accessor))
-                           (writer-fn (or writer accessor))
-                           )
-                      (setf (md-slot-cell-type class slotname) cell)
-                      
-                      `(progn
-                         ,(when reader-fn
-                            `(defmethod ,reader-fn ((self ,class))
-                               (md-slot-value self ',slotname)))
-                         
-                         ,(when writer-fn
-                            `(defmethod (setf ,writer-fn) (new-value (self ,class))
-                               (setf (md-slot-value self ',slotname)
-                                 ,(if type
-                                      `(coerce new-value ',type)
-                                    'new-value))))
+       ;
+       ; slot accessors once class is defined...
+       ;
+       ,@(mapcar (lambda (slotspec)
+                   (destructuring-bind
+                       (slotname &rest slotargs
+                         &key (cell t) owning unchanged-if (accessor slotname) reader writer type
+                         &allow-other-keys)
+                       slotspec
+                     
+                     (declare (ignorable slotargs))
+                     (when cell
+                       (let* ((reader-fn (or reader accessor))
+                              (writer-fn (or writer accessor))
+                              )
+                         `(progn
+                            (setf (md-slot-cell-type ',class ',slotname) ,cell)
                          
-                         ,(when unchanged-if
-                            `(def-c-unchanged-test (,class ,slotname) ,unchanged-if))
-                         )
-                      ))
-                  ))
-        slotspecs)
-    (find-class ',class))))
+                            ,(when owning
+                               `(setf (md-slot-owning ',class ',slotname) ,owning))
+                            ,(when reader-fn
+                               `(defmethod ,reader-fn ((self ,class))
+                                  (md-slot-value self ',slotname)))
+                            
+                            ,(when writer-fn
+                               `(defmethod (setf ,writer-fn) (new-value (self ,class))
+                                  (setf (md-slot-value self ',slotname)
+                                    ,(if type
+                                         `(coerce new-value ',type)
+                                       'new-value))))
+                            
+                            ,(when unchanged-if
+                               `(def-c-unchanged-test (,class ,slotname) ,unchanged-if))
+                            )
+                         ))
+                     ))
+           slotspecs)
+       (find-class ',class))))
 
 (defun defmd-canonicalize-slot (slotname
                                  &key
--- /project/cells/cvsroot/cells/fm-utilities.lisp	2006/08/31 17:35:28	1.9
+++ /project/cells/cvsroot/cells/fm-utilities.lisp	2006/10/02 02:38:31	1.10
@@ -118,9 +118,9 @@
     max))
 
 
-(defun fm-traverse (family applied-fn &key skip-node skip-tree global-search opaque)
+(defun fm-traverse (family applied-fn &key skip-node skip-tree global-search opaque with-dependency)
    ;;(when *fmdbg* (trc "fm-traverse" family skipTree skipNode global-search))
-  (without-c-dependency
+
    (when family
      (labels ((tv-family (fm)
                 (etypecase fm
@@ -134,13 +134,18 @@
                            (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))
+       (flet ((tv ()
+                (tv-family family)
+                (when global-search
+                  (fm-traverse (fm-parent family) applied-fn 
+                    :global-search t
+                    :skip-tree family
+                    :skip-node skip-node
+                    :with-dependency t)))) ;; t actually just defaults to outermost call
+         (if with-dependency
+             (tv)
+             (without-c-dependency (tv))))))
+  (values))
 
 (defun fm-ordered-p (n1 n2 &aux (top (fm-ascendant-common n1 n2)))
   (assert top)
--- /project/cells/cvsroot/cells/integrity.lisp	2006/07/24 05:03:08	1.12
+++ /project/cells/cvsroot/cells/integrity.lisp	2006/10/02 02:38:31	1.13
@@ -30,6 +30,12 @@
             "Invalid second value to with-integrity: ~a" opcode))
   `(call-with-integrity ,opcode ,defer-info (lambda () , at body)))
 
+(export! with-c-change)
+
+(defmacro with-c-change (id &body body)
+  `(with-integrity (:change ,id)
+     , at body))
+
 (defun integrity-managed-p ()
   *within-integrity*)
 
@@ -53,23 +59,6 @@
           (funcall action)
         (finish-business)))))
 
-(export! with-integrity-bubble)
-
-(defmacro with-integrity-bubble ((&optional dbg-info) &rest body)
-  "Whimsical name for launching a self-contained, dynamic integrity chunk, as with
-string-to-mx in the math-paper project, where everything is fully isolated from the
-outside computation."
-  `(call-with-integrity-bubble ,dbg-info (lambda () , at body)))
-
-(defun call-with-integrity-bubble (dbg-info action)
-  (declare (ignorable dbg-info))
-  (let ((*within-integrity* nil)
-          *unfinished-business*
-          *defer-changes*
-        *call-stack*
-        (*data-pulse-id* 0))
-    (funcall action)))
-
 (defun ufb-queue (opcode)
   (assert (find opcode *ufb-opcodes*))
   (cdr (assoc opcode *unfinished-business*)))
@@ -115,9 +104,13 @@
     ; we do not go back to check for a need to :tell-dependents because (a) the original propagation
     ; and processing of the :tell-dependents queue is a full propagation; no rule can ask for a cell that
     ; then decides it needs to recompute and possibly propagate; and (b) the only rules forced awake during
-    ; awakening need that precisely because no one asked for their values, so their can be no dependents
+    ; awakening need that precisely because no one asked for their values, so there can be no dependents
     ; to "tell". I think. :) So...
     ;
+    (when (fifo-peek (ufb-queue :tell-dependents))
+      (DOlist (b (fifo-data (ufb-queue :tell-dependents)))
+        (trc "unhandled :tell-dependents" (car b) (c-callers (car b))))
+      (break "ufb"))
     (assert (null (fifo-peek (ufb-queue :tell-dependents))))
 
     ;--- process client queue ------------------------------
--- /project/cells/cvsroot/cells/md-slot-value.lisp	2006/08/21 04:29:30	1.27
+++ /project/cells/cvsroot/cells/md-slot-value.lisp	2006/10/02 02:38:31	1.28
@@ -55,8 +55,10 @@
   (declare (ignorable debug-id caller))
   (count-it :ensure-value-is-current)
   (trc nil "ensure-value-is-current > entry" c :now-pulse *data-pulse-id* debug-id caller)
+
   (when (eq :eternal-rest (md-state (c-model c)))
     (break "model ~a of cell ~a is dead" (c-model c) c))
+
   (cond
    ((c-currentp c)(trc nil "c-currentp" c)) ;; used to follow c-inputp, but I am toying with letting ephemerals (inputs) fall obsolete
    ;; and then get reset here (ie, ((c-input-p c) (ephemeral-reset c))). ie, do not assume inputs are never obsolete
@@ -64,17 +66,27 @@
    ((c-inputp c)(trc nil "c-inputp" c)) ;; always current (for now; see above)
 
    ((or (not (c-validp c))
-      (some (lambda (used)
-              (ensure-value-is-current used :nested c)
-              (trc nil "comparing pulses (caller, used, used-changed): "  c used (c-changed used))
-              (when (and (c-changed used) (> (c-pulse used)(c-pulse c)))
-                 (trc nil "used changed and newer !!!!!!" c used)
-                t))
-        (cd-useds c)))
-    (trc nil "ensuring current calc-set of" (c-slot-name c))
+      ;;
+      ;; new for 2006-09-21: a cell ended up checking slots of a dead instance, which would have been
+      ;; refreshed when checked, but was going to be checked last because it was the first used, useds
+      ;; being simply pushed onto a list as they come up. We may need fancier handling of dead instance/cells
+      ;; still being encountered by consulting the prior useds list, but checking now in same order as
+      ;; accessed seems Deeply Correct (and fixed the immediate problem nicely, always a Good Sign).
+      ;;
+      (labels ((check-reversed (useds)
+                 (when useds
+                   (or (check-reversed (cdr useds))
+                     (let ((used (car useds)))
+                       (ensure-value-is-current used :nested c)
+                       (trc nil "comparing pulses (caller, used, used-changed): "  c debug-id used (c-pulse-last-changed used))
+                       (when (> (c-pulse-last-changed used)(c-pulse c))
+                         (trc nil "used changed and newer !!!!!!" c debug-id used)
+                         t))))))
+        (check-reversed (cd-useds c))))
+    (trc nil "kicking off calc-set of" (c-slot-name c) :pulse *data-pulse-id*)
     (calculate-and-set c))
 
-   (t (trc nil "ensuring current decided current, updating pulse" (c-slot-name c) )
+   (t (trc nil "ensuring current decided current, updating pulse" (c-slot-name c) debug-id)
      (c-pulse-update c :valid-uninfluenced)))
 
   (when (c-unboundp c)
@@ -157,7 +169,7 @@
           ; --- data flow propagation -----------
           ;
           
-          (setf (c-changed c) t)
+          (setf (c-pulse-last-changed c) *data-pulse-id*)
           (without-c-dependency
               (c-propagate c prior-value t)))))))
 
@@ -178,11 +190,16 @@
 In brief, initialize ~0@*~a to (c-in ~2@*~s) instead of plain ~:*~s"
       slot-name self (slot-value self slot-name)))
 
-  (when *defer-changes*
+  (cond
+   ((find (c-lazy c) '(:once-asked :always t))
+    (md-slot-value-assume c new-value nil))
+
+   (*defer-changes*
     (c-break "SETF of ~a must be deferred by wrapping code in WITH-INTEGRITY" c))
 
-  (with-integrity (:change)
-    (md-slot-value-assume c new-value nil))
+   (t
+    (with-integrity (:change slot-name)
+      (md-slot-value-assume c new-value nil))))
 
   ;; new-value 
   ;; above line commented out 2006-05-01. It seems to me we want the value assumed by the slot
@@ -222,7 +239,7 @@
         ; --- data flow propagation -----------
         (unless (eq propagation-code :no-propagate)
           (trc nil "md-slot-value-assume flagging as changed" c)
-          (setf (c-changed c) t)
+          (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))
         
         absorbed-value)))
--- /project/cells/cvsroot/cells/model-object.lisp	2006/09/05 18:40:47	1.11
+++ /project/cells/cvsroot/cells/model-object.lisp	2006/10/02 02:38:31	1.12
@@ -25,6 +25,7 @@
 
 (defclass model-object ()
   ((.md-state :initform :nascent :accessor md-state) ; [nil | :nascent | :alive | :doomed]
+   (.awaken-on-init-p :initform nil :initarg :awaken-on-init-p :accessor awaken-on-init-p) ; [nil | :nascent | :alive | :doomed]
    (.cells :initform nil :accessor cells)
    (.cells-flushed :initform nil :accessor cells-flushed
                    :documentation "cells supplied but un-whenned or optimized-away")
@@ -51,17 +52,22 @@
         for sn = (slot-definition-name esd)
         for sv = (when (slot-boundp self sn)
                    (slot-value self sn))
-        ;; do (print (list self sn sv (typep sv 'cell)))
+        ;; do (print (list (type-of self) sn sv (typep sv 'cell)))
         when (typep sv 'cell)
         do (if (md-slot-cell-type (type-of self) sn)
                (md-install-cell self sn sv)
              (when *c-debug*
-               (trc "warning: cell ~a offered for non-cellular model/slot ~a/~a" sv self sn))))
+               (break "warning: cell ~a offered for non-cellular model/slot ~a/~a" sv sn (type-of self)))))
     ;
     ; queue up for awakening
     ;
-    (with-integrity (:awaken self)
-      (md-awaken self))))
+    (if (awaken-on-init-p self)
+        (md-awaken self)
+      (with-integrity (:awaken self)
+        (md-awaken self)))
+    ))
+
+
 
 (defun md-install-cell (self sn c &aux (c-isa-cell (typep c 'cell)))
   ;
@@ -162,14 +168,18 @@
 (defun md-slot-cell-type (class-name slot-name)
   (bif (entry (assoc slot-name (get class-name :cell-types)))
     (cdr entry)
-    (dolist (super (class-precedence-list (find-class class-name)))
+    (dolist (super (class-precedence-list (find-class class-name))
+              (setf (md-slot-cell-type class-name slot-name) nil))
       (bwhen (entry (assoc slot-name (get (c-class-name super) :cell-types)))
-        (return (setf (md-slot-cell-type class-name slot-name) (cdr entry)))))))       
+        (return-from md-slot-cell-type (setf (md-slot-cell-type class-name slot-name) (cdr entry)))))))       
 
 (defun (setf md-slot-cell-type) (new-type class-name slot-name)
   (let ((entry (assoc slot-name (get class-name :cell-types))))
     (if entry
-        (setf (cdr entry) new-type)
+        (progn
+          (setf (cdr entry) new-type)
+          (loop for c in (mop:class-direct-subclasses (find-class class-name))
+                do (setf (md-slot-cell-type (class-name c) slot-name) new-type)))
       (push (cons slot-name new-type) (get class-name :cell-types)))))
 
 (defun md-slot-owning (class-name slot-name)
@@ -182,11 +192,12 @@
 (defun (setf md-slot-owning) (value class-name slot-name)
   (let ((entry (assoc slot-name (get class-name :ownings))))
     (if entry
-        (setf (cdr entry) value)
+        (progn
+          (setf (cdr entry) value)
+          (loop for c in (mop:class-direct-subclasses (find-class class-name))
+                do (setf (md-slot-owning (class-name c) slot-name) value)))
       (push (cons slot-name value) (get class-name :ownings)))))
 
-
-
 (defmethod md-slot-value-store ((self model-object) slot-name new-value)
   (trc nil "md-slot-value-store" slot-name new-value)
   (setf (slot-value self slot-name) new-value))
--- /project/cells/cvsroot/cells/propagate.lisp	2006/09/05 18:40:47	1.21
+++ /project/cells/cvsroot/cells/propagate.lisp	2006/10/02 02:38:31	1.22
@@ -46,10 +46,10 @@
 
 (defun c-pulse-update (c key)
   (declare (ignorable key))
-  (trc nil "c-pulse-update updating" *data-pulse-id* c key)
-  (assert (>= *data-pulse-id* (c-pulse c)))
-  (setf (c-changed c) nil
-      (c-pulse c) *data-pulse-id*))
+  (trc nil "c-pulse-update updating" *data-pulse-id* c key :prior-pulse (c-pulse c))
+  (assert (>= *data-pulse-id* (c-pulse c)) ()
+    "Current DP ~a not GE pulse ~a of cell ~a" *data-pulse-id* (c-pulse c) c)
+  (setf (c-pulse c) *data-pulse-id*))
 
 ;--------------- propagate  ----------------------------
 
@@ -90,19 +90,19 @@
     ; expected to have side-effects, so we want to propagate fully and be sure no rule
     ; wants a rollback before starting with the side effects.
     ; 
-    (c-propagate-to-callers c)
+    (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)
+
     (when (and prior-value-supplied
             prior-value
             (md-slot-owning (type-of (c-model c)) (c-slot-name c)))
-      (bwhen (lost (set-difference prior-value (c-value c)))
-        (trc "bingo!!!!! lost nailing" lost)
-        (break "go")
-        (typecase lost
-          (atom (not-to-be lost))
-          (cons (mapcar 'not-to-be lost)))))
+      (flet ((listify (x) (if (listp x) x (list x))))
+        (bwhen (lost (set-difference (listify prior-value) (listify (c-value c))))
+          (trc "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
@@ -113,8 +113,7 @@
     ; would this be bad for persistent CLOS, in which a DB would think there was still a link
     ; between two records until the value actually got cleared?
     ;
-    (ephemeral-reset c)
-    ))
+    (ephemeral-reset c)))
 
 ; --- slot change -----------------------------------------------------------
 
@@ -177,7 +176,7 @@
         (let ((*causation* causation))
           (trc nil "c-propagate-to-callers > actually notifying callers of" c (mapcar 'c-slot-name (c-callers c)))
           (dolist (caller (c-callers c))
-            (unless (member (cr-lazy caller) '(t :always :once-asked))
+            (unless (member (c-lazy caller) '(t :always :once-asked))
               (trc nil "propagating to caller is caller:" caller)
               (ensure-value-is-current caller :prop-from c))))))))
 




More information about the Cells-cvs mailing list