Update of /project/cells/cvsroot/cells
In directory clnet:/tmp/cvs-serv31550
Modified Files:
cell-types.lisp cells-manifesto.txt cells.lisp cells.lpr
defmodel.lisp initialize.lisp integrity.lisp link.lisp
md-slot-value.lisp md-utilities.lisp model-object.lisp
optimization.lisp propagate.lisp synapse.lisp test.lisp
Log Message:
New abbreviated defmodel: defmd
Starting to change internals names as the mood hits me.
--- /project/cells/cvsroot/cells/cell-types.lisp 2006/06/20 14:16:44 1.13
+++ /project/cells/cvsroot/cells/cell-types.lisp 2006/06/23 01:04:55 1.14
@@ -26,7 +26,7 @@
inputp ;; t for old c-variable class
synaptic
changed
- (users-store (make-fifo-queue) :type cons) ;; (C3) probably better to notify users FIFO
+ (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}
@@ -34,16 +34,16 @@
debug
md-info)
-(defun c-users (c)
+(defun c-callers (c)
"Make it easier to change implementation"
- (fifo-data (c-users-store c)))
+ (fifo-data (c-caller-store c)))
-(defun user-ensure (used new-user)
- (unless (find new-user (c-users used))
- (fifo-add (c-users-store used) new-user)))
+(defun caller-ensure (used new-caller)
+ (unless (find new-caller (c-callers used))
+ (fifo-add (c-caller-store used) new-caller)))
-(defun user-drop (used user)
- (fifo-delete (c-users-store used) user))
+(defun caller-drop (used caller)
+ (fifo-delete (c-caller-store used) caller))
(defmethod trcp ((c cell))
nil #+(or) (and (typep (c-model c) 'index)
@@ -61,7 +61,7 @@
;
; as of Cells3 we defer resetting ephemerals because everything
; else gets deferred and we cannot /really/ reset it until
- ; within finish-business we are sure all users have been recalculated
+ ; within finish-business we are sure all callers have been recalculated
; and all outputs completed.
;
; ;; good q: what does (setf <ephem> 'x) return? historically nil, but...?
@@ -71,8 +71,8 @@
(md-slot-value-store (c-model c) (c-slot-name c) nil)
(setf (c-value c) nil)
#+notsureaboutthis
- (loop for user in (c-users c)
- do (calculate-and-link user)))))
+ (loop for caller in (c-callers c)
+ do (calculate-and-link caller)))))
; -----------------------------------------------------
--- /project/cells/cvsroot/cells/cells-manifesto.txt 2006/06/20 14:16:44 1.6
+++ /project/cells/cvsroot/cells/cells-manifesto.txt 2006/06/23 01:04:56 1.7
@@ -61,7 +61,8 @@
way around it, and thus his prediction that a software silver bullet was
in principle impossible.
-Which brings us to Cells.
+Which brings us to Cells. See also [axiom] Phillip Eby's developiong axiomatic
+definition he is developing in support of Ryan Forseth's SoC project.
DEFMODEL and Slot types
-----------------------
@@ -392,3 +393,118 @@
was done on having slots of DEFSTRUCTs mediated by Cells, and ports to C++, Java, and
Python have been explored.
+_______
+[axiom] Phillip Eby's axiomatic specification of Cells:
+
+Data Pulse Axioms
+=================
+
+Overview: updates must be synchronous (all changed cells are updated at
+once), consistent (no cell rule sees out of date values), and minimal (only
+necessary rules run).
+
+1. Global Update Counter:
+ There is a global update counter. (Guarantees that there is a
+globally-consistent notion of the "time" at which updates occur.)
+
+2. Per-Cell "As Of" Value:
+ Every cell has a "current-as-of" update count, that is initialized with
+a value that is less than the global update count will ever be.
+
+3. Out-of-dateness:
+ A cell is out of date if its update count is lower than the update
+count of any of the cells it depends on.
+
+4. Out-of-date Before:
+ When a rule-driven cell's value is queried, its rule is only run if the
+cell is out of date; otherwise a cached previous value is
+returned. (Guarantees that a rule is not run unless its dependencies have
+changed since the last time the rule was run.)
+
+5. Up-to-date After:
+ Once a cell's rule is run (or its value is changed, if it is an input
+cell), its update count must be equal to the global update
+count. (Guarantees that a rule cannot run more than once per update.)
+
+6. Inputs Move The System Forward
+ When an input cell changes, it increments the global update count and
+stores the new value in its own update count.
+
+
+Dependency Discovery Axioms
+===========================
+
+Overview: cells automatically notice when other cells depend on them, then
+notify them at most once if there is a change.
+
+
+1. Thread-local "current rule cell":
+ There is a thread-local variable that always contains the cell whose
+rule is currently being evaluated in the corresponding thread. This
+variable can be empty (e.g. None).
+
+2. "Currentness" Maintenance:
+ While a cell rule's is being run, the variable described in #1 must be
+set to point to the cell whose rule is being run. When the rule is
+finished, the variable must be restored to whatever value it had before the
+rule began. (Guarantees that cells will be able to tell who is asking for
+their values.)
+
+3. Dependency Creation:
+ When a cell is read, it adds the "currently-being evaluated" cell as a
+listener that it will notify of changes.
+
+4. Dependency Creation Order:
+ New listeners are added only *after* the cell being read has brought
+itself up-to-date, and notified any *previous* listeners of the
+change. (Ensures that the listening cell does not receive redundant
+notification if the listened-to cell has to be brought up-to-date first.)
+
+5. Dependency Minimalism:
+ A listener should only be added if it does not already present in the
+cell's listener collection. (This isn't strictly mandatory, the system
+behavior will be correct but inefficient if this requirement isn't met.)
+
+6. Dependency Removal:
+ Just before a cell's rule is run, it must cease to be a listener for
+any other cells. (Guarantees that a dependency from a previous update
+cannot trigger an unnecessary repeated calculation.)
+
+7. Dependency Notification
+ Whenever a cell's value changes (due to a rule change or input change),
+it must notify all of its listeners that it has changed, in such a way that
+*none* of the listeners are asked to recalculate their value until *all* of
+the listeners have first been notified of the change. (This guarantees
+that inconsistent views cannot occur.)
+
+7a. Deferred Recalculation
+ The recalculation of listeners (not the notification of the listeners'
+out-of-dateness) must be deferred if a cell's value is currently being
+calculated. As soon as there are no cells being calculated, the deferred
+recalculations must occur. (This guarantees that in the absence of
+circular dependencies, no cell can ask for a value that's in the process of
+being calculated.)
+
+8. One-Time Notification Only
+ A cell's listeners are removed from its listener collection as soon as
+they have been notified. In particular, the cell's collection of listeners
+must be cleared *before* *any* of the listeners are asked to recalculate
+themselves. (This guarantees that listeners reinstated as a side effect of
+recalculation will not get a duplicate notification in the current update,
+or miss a notification in a future update.)
+
+9. Conversion to Constant
+ If a cell's rule is run and no dependencies were created, the cell must
+become a "constant" cell, and do no further listener additions or
+notification, once any necessary notifications to existing listeners are
+completed. (That is, if the rule's run changed the cell's value, it must
+notify its existing listeners, but then the listener collection must be
+cleared -- *again*, in addition to the clearing described in #8.)
+
+10. No Changes During Notification:
+ It is an error to change an input cell's value while change
+notifications are taking place.
+
+11. Weak Notification
+ Automatically created inter-cell links must not inhibit garbage
+collection of either cell. (Technically optional, but very easy to do.)
--- /project/cells/cvsroot/cells/cells.lisp 2006/06/10 22:16:35 1.12
+++ /project/cells/cvsroot/cells/cells.lisp 2006/06/23 01:04:56 1.13
@@ -64,7 +64,7 @@
`(c-break ,fmt$ ,@fmt-args)
`(c-break "failed assertion: ~a" ',assertion)))))
-(defvar *c-calculators* nil)
+(defvar *call-stack* nil)
(defmacro def-c-trace (model-type &optional slot cell-type)
`(defmethod trcp ((self ,(case cell-type
@@ -76,7 +76,7 @@
`t))))
(defmacro without-c-dependency (&body body)
- `(let (*c-calculators*) ,@body))
+ `(let (*call-stack*) ,@body))
(define-symbol-macro .cause
(car *causation*))
--- /project/cells/cvsroot/cells/cells.lpr 2006/05/30 02:47:45 1.14
+++ /project/cells/cvsroot/cells/cells.lpr 2006/06/23 01:04:56 1.15
@@ -1,4 +1,4 @@
-;; -*- lisp-version: "8.0 [Windows] (May 22, 2006 0:51)"; cg: "1.81"; -*-
+;; -*- lisp-version: "8.0 [Windows] (Jun 21, 2006 9:54)"; cg: "1.81"; -*-
(in-package :cg-user)
--- /project/cells/cvsroot/cells/defmodel.lisp 2006/06/20 14:16:44 1.5
+++ /project/cells/cvsroot/cells/defmodel.lisp 2006/06/23 01:04:56 1.6
@@ -124,6 +124,7 @@
(defun defmd-canonicalize-slot (slotname
&key
(cell nil cell-p)
+ (type nil type-p)
(initform nil initform-p)
(initarg (intern (symbol-name slotname) :keyword))
(documentation nil documentation-p)
@@ -135,6 +136,7 @@
(list* slotname :initarg initarg
(append
(when cell-p (list :cell cell))
+ (when type-p (list :type type))
(when initform-p (list :initform initform))
(when unchanged-if-p (list :unchanged-if unchanged-if))
(when reader-p (list :reader reader))
@@ -158,7 +160,7 @@
((keywordp (car spec))
(assert (find (car spec) '(:documentation :metaclass)))
(push spec class-options))
- ((find (cadr spec) '(:initarg :cell :initform :allocation :reader :writer :accessor :documentation))
+ ((find (cadr spec) '(:initarg :type :cell :initform :allocation :reader :writer :accessor :documentation))
(push (apply 'defmd-canonicalize-slot spec) slots))
(t ;; shortform (slotname initform &rest slotdef-key-values)
(push (apply 'defmd-canonicalize-slot
--- /project/cells/cvsroot/cells/initialize.lisp 2006/06/13 16:19:35 1.7
+++ /project/cells/cvsroot/cells/initialize.lisp 2006/06/23 01:04:56 1.8
@@ -36,13 +36,13 @@
(ephemeral-reset c))
(defmethod awaken-cell ((c c-ruled))
- (let (*c-calculators*)
+ (let (*call-stack*)
(calculate-and-set c)))
#+cormanlisp ; satisfy CormanCL bug
(defmethod awaken-cell ((c c-dependent))
- (let (*c-calculators*)
- (trc nil "awaken-cell c-dependent clearing *c-calculators*" c)
+ (let (*call-stack*)
+ (trc nil "awaken-cell c-dependent clearing *call-stack*" c)
(calculate-and-set c)))
(defmethod awaken-cell ((c c-drifter))
--- /project/cells/cvsroot/cells/integrity.lisp 2006/05/20 06:32:19 1.9
+++ /project/cells/cvsroot/cells/integrity.lisp 2006/06/23 01:04:56 1.10
@@ -64,7 +64,7 @@
(let ((*within-integrity* nil)
*unfinished-business*
*defer-changes*
- *c-calculators*
+ *call-stack*
(*data-pulse-id* 0))
(funcall action)))
@@ -138,7 +138,7 @@
; of cells3, I coded an ephemeral cell and initialized it to non-nil, hitting a runtime
; error (now gone) saying I had no idea what a non-nil ephemeral would mean. That had been
; my conclusion when the idea occurred to me the first time, so I stuck in an assertion
- ; to warn off users.
+ ; to warn off callers.
;
; But the new
; datachange progression defined by Cells3 had already forced me to manage ephemeral resets
--- /project/cells/cvsroot/cells/link.lisp 2006/06/20 14:16:44 1.12
+++ /project/cells/cvsroot/cells/link.lisp 2006/06/23 01:04:56 1.13
@@ -22,13 +22,13 @@
(eval-when (compile load)
(proclaim '(optimize (speed 3) (safety 0) (space 0) (debug 0))))
-(defun c-link-ex (used &aux (user (car *c-calculators*)))
+(defun record-caller (used &aux (caller (car *call-stack*)))
(when (c-optimized-away-p used) ;; 2005-05-21 removed slow type check that used is cell
- (return-from c-link-ex nil))
- (trc nil "c-link-ex entry: used=" used :user user)
+ (return-from record-caller nil))
+ (trc nil "record-caller entry: used=" used :caller caller)
(multiple-value-bind (used-pos useds-len)
(loop with u-pos
- for known in (cd-useds user)
+ for known in (cd-useds caller)
counting known into length
when (eq used known)
do
@@ -37,20 +37,20 @@
finally (return (values (when u-pos (- length u-pos)) length)))
(when (null used-pos)
- (trc nil "c-link > new user,used " user used)
+ (trc nil "c-link > new caller,used " caller used)
(count-it :new-used)
(setf used-pos useds-len)
- (push used (cd-useds user))
- (user-ensure used user) ;; 060604 experiment was in unlink
+ (push used (cd-useds caller))
+ (caller-ensure used caller) ;; 060604 experiment was in unlink
)
(handler-case
- (setf (sbit (cd-usage user) used-pos) 1)
+ (setf (sbit (cd-usage caller) used-pos) 1)
(type-error (error)
(declare (ignorable error))
- (setf (cd-usage user)
- (adjust-array (cd-usage user) (+ used-pos 16) :initial-element 0))
- (setf (sbit (cd-usage user) used-pos) 1))))
+ (setf (cd-usage caller)
+ (adjust-array (cd-usage caller) (+ used-pos 16) :initial-element 0))
+ (setf (sbit (cd-usage caller) used-pos) 1))))
used)
@@ -64,10 +64,10 @@
(if (zerop (sbit usage rpos))
(progn
(count-it :unlink-unused)
- (c-unlink-user (car useds) c)
+ (c-unlink-caller (car useds) c)
(rplaca useds nil))
(progn
- ;; moved into c-link-ex 060604 (user-ensure (car useds) c)
+ ;; moved into record-caller 060604 (caller-ensure (car useds) c)
)
)))
(if (cdr useds)
@@ -78,12 +78,12 @@
(nail-unused (cd-useds c))
(setf (cd-useds c) (delete-if #'null (cd-useds c)))))))
-(defun c-user-path-exists-p (from-used to-user)
- (count-it :user-path-exists-p)
- (or (find to-user (c-users from-used))
- (find-if (lambda (from-used-user)
- (c-user-path-exists-p from-used-user to-user))
- (c-users from-used))))
+(defun c-caller-path-exists-p (from-used to-caller)
+ (count-it :caller-path-exists-p)
+ (or (find to-caller (c-callers from-used))
+ (find-if (lambda (from-used-caller)
+ (c-caller-path-exists-p from-used-caller to-caller))
+ (c-callers from-used))))
; ---------------------------------------------
@@ -93,11 +93,11 @@
;--- unlink from used ----------------------
-(defmethod c-unlink-from-used ((user c-dependent))
- (dolist (used (cd-useds user))
- #+dfdbg (trc user "unlinking from used" user used)
- (c-unlink-user used user))
- ;; shouldn't be necessary (setf (cd-useds user) nil)
+(defmethod c-unlink-from-used ((caller c-dependent))
+ (dolist (used (cd-useds caller))
+ #+dfdbg (trc caller "unlinking from used" caller used)
+ (c-unlink-caller used caller))
+ ;; shouldn't be necessary (setf (cd-useds caller) nil)
)
(defmethod c-unlink-from-used (other)
@@ -105,20 +105,20 @@
;----------------------------------------------------------
-(defun c-unlink-user (used user)
- (trc nil "user unlinking from used" user used)
- (user-drop used user)
- (c-unlink-used user used))
+(defun c-unlink-caller (used caller)
+ (trc nil "caller unlinking from used" caller used)
+ (caller-drop used caller)
+ (c-unlink-used caller used))
-(defun c-unlink-used (user used)
- (setf (cd-useds user) (delete used (cd-useds user))))
+(defun c-unlink-used (caller used)
+ (setf (cd-useds caller) (delete used (cd-useds caller))))
;----------------- link debugging ---------------------
-(defun dump-users (c &optional (depth 0))
+(defun dump-callers (c &optional (depth 0))
(format t "~&~v,4t~s" depth c)
- (dolist (user (c-users c))
- (dump-users user (+ 1 depth))))
+ (dolist (caller (c-callers c))
+ (dump-callers caller (+ 1 depth))))
(defun dump-useds (c &optional (depth 0))
;(c.trc "dump-useds> entry " c (+ 1 depth))
@@ -130,3 +130,9 @@
(dolist (used (cd-useds c))
(dump-useds used (+ 1 depth)))))
+
+(defun test-wk ()
+ (let ((h (make-hash-table :test 'eq :weak-keys t)))
+ (loop for n below 10
+ do (setf (gethash (make-cell :value n) h) n))
+ (maphash (lambda (k v) (print (list k v))) h)))
\ No newline at end of file
--- /project/cells/cvsroot/cells/md-slot-value.lisp 2006/06/15 15:55:01 1.21
+++ /project/cells/cvsroot/cells/md-slot-value.lisp 2006/06/23 01:04:56 1.22
@@ -43,8 +43,8 @@
(prog1
(with-integrity ()
(ensure-value-is-current c))
- (when (car *c-calculators*)
- (c-link-ex c)))
+ (when (car *call-stack*)
+ (record-caller c)))
(values (bd-slot-value self slot-name) nil)))
(defun ensure-value-is-current (c)
@@ -59,7 +59,7 @@
((or (not (c-validp c))
(some (lambda (used)
(ensure-value-is-current used)
- (trc nil "comparing pulses (user, used): " (c-pulse c)(c-pulse used))
+ (trc nil "comparing pulses (caller, 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))
@@ -80,9 +80,9 @@
(princ #\.)
(return-from calculate-and-set))
- (when (find c *c-calculators*) ;; circularity
+ (when (find c *call-stack*) ;; circularity
(c-break ;; break is problem when testing cells on some CLs
- "cell ~a midst askers: ~a" c *c-calculators*))
+ "cell ~a midst askers: ~a" c *call-stack*))
(multiple-value-bind (raw-value propagation-code)
(calculate-and-link c)
@@ -97,7 +97,7 @@
(body))))
(defun calculate-and-link (c)
- (let ((*c-calculators* (cons c *c-calculators*))
+ (let ((*call-stack* (cons c *call-stack*))
(*defer-changes* t))
(cd-usage-clear-all c)
(multiple-value-prog1
--- /project/cells/cvsroot/cells/md-utilities.lisp 2006/06/13 05:05:13 1.5
+++ /project/cells/cvsroot/cells/md-utilities.lisp 2006/06/23 01:04:56 1.6
@@ -47,7 +47,7 @@
(trc nil "md-quiesce doing" self (type-of self))
(md-map-cells self nil (lambda (c)
(trc nil "quiescing" c)
- (c-assert (not (find c *c-calculators*)))
+ (c-assert (not (find c *call-stack*)))
(c-quiesce c))))
(defun c-quiesce (c)
@@ -56,8 +56,8 @@
(trc nil "c-quiesce unlinking" c)
(c-unlink-from-used c)
(when (typep c 'cell)
- (dolist (user (c-users c))
- (c-unlink-user c user)))
+ (dolist (caller (c-callers c))
+ (c-unlink-caller c caller)))
(trc nil "cell quiesce nulled cell awake" c))))
(defmethod not-to-be (other)
--- /project/cells/cvsroot/cells/model-object.lisp 2006/06/13 16:19:35 1.7
+++ /project/cells/cvsroot/cells/model-object.lisp 2006/06/23 01:04:56 1.8
@@ -194,7 +194,7 @@
(bif (entry (assoc slot-name (cells self)))
(let ((old (cdr entry))) ;; s/b being supplanted by kid-slotter
(declare (ignorable old))
- (c-assert (null (c-users old)))
+ (c-assert (null (c-callers old)))
(c-assert (null (cd-useds old)))
(trc nil "replacing in model .cells" old new-cell self)
(rplacd entry new-cell))
--- /project/cells/cvsroot/cells/optimization.lisp 2006/06/10 22:16:35 1.7
+++ /project/cells/cvsroot/cells/optimization.lisp 2006/06/23 01:04:56 1.8
@@ -45,9 +45,9 @@
(setf (cells (c-model c)) (delete entry (cells (c-model c))))
(push entry (cells-flushed (c-model c))))
- (dolist (user (c-users c))
- (setf (cd-useds user) (delete c (cd-useds user)))
- (c-optimize-away?! user) ;; rare but it happens when rule says (or .cache ...)
+ (dolist (caller (c-callers c))
+ (setf (cd-useds caller) (delete c (cd-useds caller)))
+ (c-optimize-away?! caller) ;; rare but it happens when rule says (or .cache ...)
)
t)
--- /project/cells/cvsroot/cells/propagate.lisp 2006/06/13 16:19:35 1.17
+++ /project/cells/cvsroot/cells/propagate.lisp 2006/06/23 01:04:56 1.18
@@ -61,17 +61,17 @@
(count-it :c-propagate)
- (let (*c-calculators*
+ (let (*call-stack*
(*c-prop-depth* (1+ *c-prop-depth*))
(*defer-changes* t))
- (trc nil "c-propagate clearing *c-calculators*" c)
+ (trc nil "c-propagate clearing *call-stack*" c)
;------ debug stuff ---------
;
(when *stop*
(princ #\.)(princ #\!)
(return-from c-propagate))
- (trc nil "c-propagate> propping" c (c-value c) :user-ct (length (c-users c)) c)
+ (trc nil "c-propagate> propping" c (c-value c) :caller-ct (length (c-callers c)) c)
(when *c-debug*
(when (> *c-prop-depth* 250)
@@ -81,7 +81,7 @@
; --- manifest new value as needed ---
;
- ; propagation to users jumps back in front of client slot-value-observe handling in cells3
+ ; 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).
;
@@ -89,7 +89,7 @@
; 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-users c)
+ (c-propagate-to-callers c)
(slot-value-observe (c-slot-name c) (c-model c)
(c-value c) prior-value prior-value-supplied)
@@ -98,7 +98,7 @@
; let the fn decide if C really is ephemeral. Note that it might be possible to leave
; this out and use the datapulse to identify obsolete ephemerals and clear them
; when read. That would avoid ever making again bug I had in which I had the reset inside slot-value-observe,
- ; thinking that that always followed propagation to users. It would also make
+ ; thinking that that always followed propagation to callers. It would also make
; debugging easier in that I could find the last ephemeral value in the inspector.
; 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?
@@ -147,29 +147,29 @@
; --- recalculate dependents ----------------------------------------------------
-(defun c-propagate-to-users (c)
+(defun c-propagate-to-callers (c)
;
- ; We must defer propagation to users because of an edge case in which:
+ ; We must defer propagation to callers because of an edge case in which:
; - X tells A to recalculate
; - A asks B for its current value
; - B must recalculate because it too uses X
- ; - if B propagates to its users after recalculating instead of deferring it
+ ; - if B propagates to its callers after recalculating instead of deferring it
; - B might tell H to reclaculate, where H decides this time to use A
; - but A is in the midst of recalculating, and cannot complete until B returns.
; 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
;
- (when (c-users c)
- (trc nil "c-propagate-to-users > queueing" c)
+ (when (c-callers c)
+ (trc nil "c-propagate-to-callers > queueing" c)
(let ((causation (cons c *causation*))) ;; in case deferred
(with-integrity (:tell-dependents c)
- (assert (null *c-calculators*))
+ (assert (null *call-stack*))
(let ((*causation* causation))
- (trc nil "c-propagate-to-users > notifying users of" c (mapcar 'c-slot-name (c-users c)))
- (dolist (user (c-users c))
- (unless (member (cr-lazy user) '(t :always :once-asked))
- (trc nil "propagating to user is (used,user):" c user)
- (ensure-value-is-current user))))))))
+ (trc nil "c-propagate-to-callers > 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))
+ (trc nil "propagating to caller is (used,caller):" c caller)
+ (ensure-value-is-current caller))))))))
--- /project/cells/cvsroot/cells/synapse.lisp 2006/06/13 05:05:13 1.11
+++ /project/cells/cvsroot/cells/synapse.lisp 2006/06/23 01:04:56 1.12
@@ -23,19 +23,19 @@
(defmacro with-synapse (synapse-id (&rest closure-vars) &body body)
(declare (ignorable trcp))
- (let ((syn-id (gensym))(syn-user (gensym)))
+ (let ((syn-id (gensym))(syn-caller (gensym)))
`(let* ((,syn-id ,synapse-id)
- (,syn-user (car *c-calculators*))
- (synapse (or (find ,syn-id (cd-useds ,syn-user) :key 'c-slot-name)
+ (,syn-caller (car *call-stack*))
+ (synapse (or (find ,syn-id (cd-useds ,syn-caller) :key 'c-slot-name)
(let ((new-syn
(let (,@closure-vars)
(make-c-dependent
- :model (c-model ,syn-user)
+ :model (c-model ,syn-caller)
:slot-name ,syn-id
:code ',body
:synaptic t
:rule (c-lambda ,@body)))))
- (c-link-ex new-syn)
+ (record-caller new-syn)
new-syn))))
(prog1
(multiple-value-bind (v p)
@@ -43,7 +43,7 @@
(ensure-value-is-current synapse))
(trc nil "with-synapse: synapse, v, prop" synapse v p)
(values v p))
- (c-link-ex synapse)))))
+ (record-caller synapse)))))
;__________________________________________________________________________________
--- /project/cells/cvsroot/cells/test.lisp 2005/09/26 15:35:58 1.7
+++ /project/cells/cvsroot/cells/test.lisp 2006/06/23 01:04:56 1.8
@@ -34,14 +34,14 @@
- make sure they fire when they should, and do not when they should not
-- make sure they survive an evaluation by the user which does not branch to
+- make sure they survive an evaluation by the caller which does not branch to
them (ie, does not access them)
- make sure they optimize away
- test with forms which access multiple other cells
-- look at direct alteration of a user
+- look at direct alteration of a caller
- does SETF honor not propagating, as well as a c-ruled after re-calcing
