[cells-cvs] CVS cells
ktilton
ktilton at common-lisp.net
Tue Jun 13 05:05:14 UTC 2006
Update of /project/cells/cvsroot/cells
In directory clnet:/tmp/cvs-serv7503
Modified Files:
cell-types.lisp family.lisp initialize.lisp md-slot-value.lisp
md-utilities.lisp model-object.lisp propagate.lisp
synapse.lisp
Log Message:
Mostly make ephemerals more transparent by always rerunning rules of dependents. This is actually a bug fix, at some profound level of understanding beyond me.
--- /project/cells/cvsroot/cells/cell-types.lisp 2006/06/10 22:16:35 1.10
+++ /project/cells/cvsroot/cells/cell-types.lisp 2006/06/13 05:05:12 1.11
@@ -64,10 +64,14 @@
; within finish-business we are sure all users have been recalculated
; and all outputs completed.
;
+ ; ;; good q: what does (setf <ephem> 'x) return? historically nil, but...?
+ ;
(with-integrity (:ephemeral-reset c)
(trc nil "!!!!!!!!!!!!!! c-ephemeral-reset resetting:" c)
(md-slot-value-store (c-model c) (c-slot-name c) nil)
- (setf (c-value c) nil)))) ;; good q: what does (setf <ephem> 'x) return? historically nil, but...?
+ (setf (c-value c) nil)
+ (loop for user in (c-users c)
+ do (calculate-and-link user)))))
; -----------------------------------------------------
--- /project/cells/cvsroot/cells/family.lisp 2006/05/20 06:32:19 1.7
+++ /project/cells/cvsroot/cells/family.lisp 2006/06/13 05:05:12 1.8
@@ -135,8 +135,8 @@
(multiple-value-bind (c-or-value suppressp)
(funcall (ks-rule ks-def) self)
(unless suppressp
- (trc nil "c-install " slot-name c-or-value)
- (c-install self slot-name c-or-value)))))))))
+ (trc nil "md-install-cell " slot-name c-or-value)
+ (md-install-cell self slot-name c-or-value)))))))))
(defobserver .kids ((self family) new-kids old-kids)
(declare (ignorable usage))
--- /project/cells/cvsroot/cells/initialize.lisp 2006/05/20 06:32:19 1.5
+++ /project/cells/cvsroot/cells/initialize.lisp 2006/06/13 05:05:12 1.6
@@ -24,11 +24,10 @@
(defstruct (c-envaluer (:conc-name nil))
envalue-rule)
-
-(defmethod c-awaken-cell (c)
+(defmethod awaken-cell (c)
(declare (ignorable c)))
-(defmethod c-awaken-cell ((c cell))
+(defmethod awaken-cell ((c cell))
(assert (c-inputp c))
;
; nothing to calculate, but every cellular slot should be output
@@ -36,17 +35,17 @@
(slot-value-observe (c-slot-name c) (c-model c) (c-value c) nil nil)
(c-ephemeral-reset c))
-(defmethod c-awaken-cell ((c c-ruled))
+(defmethod awaken-cell ((c c-ruled))
(let (*c-calculators*)
- (c-calculate-and-set c)))
+ (calculate-and-set c)))
#+cormanlisp ; satisfy CormanCL bug
-(defmethod c-awaken-cell ((c c-dependent))
+(defmethod awaken-cell ((c c-dependent))
(let (*c-calculators*)
- (trc nil "c-awaken-cell c-dependent clearing *c-calculators*" c)
- (c-calculate-and-set c)))
+ (trc nil "awaken-cell c-dependent clearing *c-calculators*" c)
+ (calculate-and-set c)))
-(defmethod c-awaken-cell ((c c-drifter))
+(defmethod awaken-cell ((c c-drifter))
;
; drifters *begin* valid, so the derived version's test for unbounditude
; would keep (drift) rule ever from being evaluated. correct solution
@@ -55,7 +54,7 @@
; awakening, because awakening's other role is to get an instance up to speed
; at once upon instantiation
;
- (c-calculate-and-set c)
+ (calculate-and-set c)
(cond ((c-validp c) (c-value c))
((c-unboundp c) nil)
(t "illegal state!!!")))
--- /project/cells/cvsroot/cells/md-slot-value.lisp 2006/06/10 22:16:35 1.18
+++ /project/cells/cvsroot/cells/md-slot-value.lisp 2006/06/13 05:05:12 1.19
@@ -42,14 +42,14 @@
(if c
(prog1
(with-integrity ()
- (c-value-ensure-current c))
+ (ensure-value-is-current c))
(when (car *c-calculators*)
(c-link-ex c)))
(values (bd-slot-value self slot-name) nil)))
-(defun c-value-ensure-current (c)
- (count-it :c-value-ensure-current)
- (trc nil "c-value-ensure-current >" c)
+(defun ensure-value-is-current (c)
+ (count-it :ensure-value-is-current)
+ (trc nil "ensure-value-is-current >" 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) (c-ephemeral-reset c))). ie, do not assume inputs are never obsolete
@@ -58,14 +58,14 @@
((or (not (c-validp c))
(some (lambda (used)
- (c-value-ensure-current used)
+ (ensure-value-is-current used)
(trc nil "comparing pulses (user, used): " (c-pulse c)(c-pulse used))
(when (and (c-changed used) (> (c-pulse used)(c-pulse c)))
(trc nil "used changed" c used)
t))
(cd-useds c)))
(trc nil "ensuring current calc-set of" (c-slot-name c) debug-id)
- (c-calculate-and-set c))
+ (calculate-and-set c))
(t (c-pulse-update c :valid-uninfluenced)))
@@ -74,37 +74,36 @@
(c-value c))
-(defun c-calculate-and-set (c)
+(defun calculate-and-set (c)
(flet ((body ()
(when (c-stopped)
(princ #\.)
- (return-from c-calculate-and-set))
-
+ (return-from calculate-and-set))
+
(when (find c *c-calculators*) ;; circularity
- (trc "c-calculate-and-set breaking on circularity" c)
(c-break ;; break is problem when testing cells on some CLs
"cell ~a midst askers: ~a" c *c-calculators*))
- (trc nil "calcing, calcers" (c-slot-name c) (mapcar 'c-slot-name *c-calculators*))
- (count-it :c-calculate-and-set)
- ;;; (count-it :c-calculate-and-set (type-of (c-model c))) ;; (c-slot-name c))
-
- (cd-usage-clear-all c)
-
+
(multiple-value-bind (raw-value propagation-code)
- (let ((*c-calculators* (cons c *c-calculators*))
- (*defer-changes* t))
- (funcall (cr-rule c) c))
+ (calculate-and-link c)
+
(when (and *c-debug* (typep raw-value 'cell))
(c-break "new value for cell ~s is itself a cell: ~s. probably nested (c? ... (c? ))"
c raw-value))
-
- (c-unlink-unused c)
- (trc nil "calc-set calling md-sv-assum" c propagation-code)
+
(md-slot-value-assume c raw-value propagation-code))))
(if nil ;; *dbg*
(ukt::wtrc (0 100 "calcnset" c) (body))
(body))))
+(defun calculate-and-link (c)
+ (let ((*c-calculators* (cons c *c-calculators*))
+ (*defer-changes* t))
+ (cd-usage-clear-all c)
+ (multiple-value-prog1
+ (funcall (cr-rule c) c)
+ (c-unlink-unused c))))
+
;-------------------------------------------------------------
(defun md-slot-makunbound (self slot-name
@@ -183,7 +182,7 @@
(when (and (not (eq propagation-code :propagate))
(eql prior-state :valid)
(c-no-news c absorbed-value prior-value))
- (trc nil "(setf md-slot-value) > early no news" propagation-code prior-state prior-value absorbed-value)
+ (trc "(setf md-slot-value) > early no news" propagation-code prior-state prior-value absorbed-value)
(count-it :nonews)
(return-from md-slot-value-assume absorbed-value))
--- /project/cells/cvsroot/cells/md-utilities.lisp 2006/05/20 06:32:19 1.4
+++ /project/cells/cvsroot/cells/md-utilities.lisp 2006/06/13 05:05:13 1.5
@@ -67,6 +67,6 @@
(defmacro make-kid (class &rest initargs)
`(make-instance ,class
- :fm-parent self
+ :fm-parent (progn (assert self) self)
, at initargs))
--- /project/cells/cvsroot/cells/model-object.lisp 2006/05/20 06:32:19 1.5
+++ /project/cells/cvsroot/cells/model-object.lisp 2006/06/13 05:05:13 1.6
@@ -51,7 +51,7 @@
(slot-value self sn))
when (typep sv 'cell)
do (if (md-slot-cell-type (type-of self) sn)
- (c-install self sn sv)
+ (md-install-cell self sn sv)
(when *c-debug*
(trc "warning: cell ~a offered for non-cellular model/slot ~a/~a" sv self sn))))
;
@@ -60,12 +60,12 @@
(with-integrity (:awaken self)
(md-awaken self)))
-(defun c-install (self sn c &aux (c-isa-cell (typep c 'cell)))
+(defun md-install-cell (self sn c &aux (c-isa-cell (typep c 'cell)))
;
; iff cell, init and move into dictionary
;
(when c-isa-cell
- (count-it :c-install)
+ (count-it :md-install-cell)
(setf
(c-model c) self
(c-slot-name c) sn
@@ -121,7 +121,7 @@
((not c)
;; all slots must hit any change handlers as instances come into existence to get
;; models fully connected to the outside world they are controlling. that
- ;; happens in c-awaken-cell for slots in fact mediated by cells, but as an
+ ;; happens in awaken-cell for slots in fact mediated by cells, but as an
;; optimization we allow raw literal values to be specified for a slot, in
;; which case heroic measures are needed to get the slot to the change handler
;;
@@ -142,7 +142,7 @@
(count-it :c-awaken)
(setf (c-state c) :awake)
- (c-awaken-cell c))))))
+ (awaken-cell c))))))
(setf (md-state self) :awake)
self)
--- /project/cells/cvsroot/cells/propagate.lisp 2006/06/09 17:21:35 1.15
+++ /project/cells/cvsroot/cells/propagate.lisp 2006/06/13 05:05:13 1.16
@@ -46,7 +46,7 @@
(defun c-pulse-update (c key)
(declare (ignorable key))
- (trc nil "c-pulse-update updating" *data-pulse-id* c key)
+ (trc nil "c-pulse-update updating" *data-pulse-id* c key)
(setf (c-changed c) nil
(c-pulse c) *data-pulse-id*))
@@ -159,8 +159,8 @@
; but B is busy eagerly propagating. "This time" is important because it means
; there is no way one can reliably be sure H will not ask for A
;
- (trc nil "c-propagate-to-users > queueing" c)
(when (c-users c)
+ (trc nil "c-propagate-to-users > queueing" c)
(let ((causation (cons c *causation*))) ;; in case deferred
(with-integrity (:tell-dependents c)
(assert (null *c-calculators*))
@@ -169,7 +169,7 @@
(dolist (user (c-users c))
(unless (member (cr-lazy user) '(t :always :once-asked))
(trc nil "propagating to user is (used,user):" c user)
- (c-value-ensure-current user))))))))
+ (ensure-value-is-current user))))))))
--- /project/cells/cvsroot/cells/synapse.lisp 2006/05/20 06:32:19 1.10
+++ /project/cells/cvsroot/cells/synapse.lisp 2006/06/13 05:05:13 1.11
@@ -40,7 +40,7 @@
(prog1
(multiple-value-bind (v p)
(with-integrity ()
- (c-value-ensure-current synapse))
+ (ensure-value-is-current synapse))
(trc nil "with-synapse: synapse, v, prop" synapse v p)
(values v p))
(c-link-ex synapse)))))
More information about the Cells-cvs
mailing list