[cells-cvs] CVS cells
ktilton
ktilton at common-lisp.net
Fri Apr 11 09:19:41 UTC 2008
Update of /project/cells/cvsroot/cells
In directory clnet:/tmp/cvs-serv5826
Modified Files:
cells.lisp family.lisp fm-utilities.lisp integrity.lisp
md-slot-value.lisp
Log Message:
--- /project/cells/cvsroot/cells/cells.lisp 2008/03/15 15:18:34 1.25
+++ /project/cells/cvsroot/cells/cells.lisp 2008/04/11 09:19:29 1.26
@@ -16,14 +16,26 @@
|#
-(eval-when (compile load)
- (proclaim '(optimize (speed 2) (safety 1) (space 1) (debug 3))))
+#| Notes
+I don't like the way with-cc defers twice, first the whole thing and then when the
+body finally runs we are still within the original integrity and each setf gets queued
+to UFB separately before md-slot-value-assume finally runs. I think all that is going on here
+is that we want the programmer to use with-cc to show they know the setf will not be returning
+a useful value. But since they have coded the with-cc we should be able to figure out a way to
+let those SETFs thru as if they were outside integrity, and then we get a little less UFBing
+but even better SETF behaves as it should.
+It would be nice to do referential integrity and notice any time a model object gets stored in
+a cellular slot (or in a list in such) and then mop those up on not-to-be.
+
+|#
-(in-package :cells)
+(eval-when (compile load)
+ (proclaim '(optimize (speed 2) (safety 1) (space 1) (debug 3))))
+(in-package :cells)
(defparameter *c-prop-depth* 0)
(defparameter *causation* nil)
@@ -94,11 +106,8 @@
`t))))
(defmacro without-c-dependency (&body body)
- `(call-without-c-dependency (lambda () , at body)))
-
-(defun call-without-c-dependency (fn)
- (let (*depender*)
- (funcall fn)))
+ ` (let (*depender*)
+ , at body))
(export! .cause)
@@ -117,7 +126,8 @@
(slot-name self new old old-boundp cell)
(declare (ignorable slot-name self new old old-boundp cell)))
-
+#+hunh
+(fmakunbound 'slot-value-observe)
; -------- cell conditions (not much used) ---------------------------------------------
(define-condition xcell () ;; new 2k0227
--- /project/cells/cvsroot/cells/family.lisp 2008/02/16 09:34:29 1.23
+++ /project/cells/cvsroot/cells/family.lisp 2008/04/11 09:19:30 1.24
@@ -91,9 +91,7 @@
(.kids :initform (c-in nil) ;; most useful
:owning t
:accessor kids
- :initarg :kids)
- )
- (:default-initargs :fm-parent (when (boundp '*parent*) *parent*)))
+ :initarg :kids)))
(defmacro the-kids (&rest kids)
`(let ((*parent* self))
--- /project/cells/cvsroot/cells/fm-utilities.lisp 2008/01/29 04:29:52 1.17
+++ /project/cells/cvsroot/cells/fm-utilities.lisp 2008/04/11 09:19:31 1.18
@@ -115,6 +115,17 @@
:with-dependency dependently)
(nreverse collection)))
+(export! fm-collect-some)
+
+(defun fm-collect-some (tree test &optional skip-top dependently)
+ (let (collection)
+ (fm-traverse tree (lambda (node)
+ (unless (and skip-top (eq node tree))
+ (bwhen (s (funcall test node))
+ (push s collection))))
+ :with-dependency dependently)
+ (nreverse collection)))
+
(defun fm-value-dictionary (tree value-fn &optional include-top)
(let (collection)
(fm-traverse tree
--- /project/cells/cvsroot/cells/integrity.lisp 2008/02/01 03:18:36 1.20
+++ /project/cells/cvsroot/cells/integrity.lisp 2008/04/11 09:19:32 1.21
@@ -48,7 +48,15 @@
(return-from call-with-integrity))
(if *within-integrity*
(if opcode
- (ufb-add opcode (cons defer-info action))
+ (progn
+ (ufb-add opcode (cons defer-info action))
+ ;
+ ; SETF is supposed to return the value being installed
+ ; in the place, but if the SETF is deferred we return
+ ; something that will help someone who tries to use
+ ; the setf'ed value figure out what is going on:
+ ;
+ :deferred-to-ufb-1)
(funcall action opcode defer-info))
(let ((*within-integrity* t)
*unfinished-business*
@@ -63,18 +71,15 @@
(finish-business)))))
(defun ufb-queue (opcode)
- (assert (find opcode *ufb-opcodes*))
(cdr (assoc opcode *unfinished-business*)))
(defun ufb-queue-ensure (opcode)
- (assert (find opcode *ufb-opcodes*))
(or (ufb-queue opcode)
(cdr (car (push (cons opcode (make-fifo-queue)) *unfinished-business*)))))
(defparameter *no-tell* nil)
(defun ufb-add (opcode continuation)
- (assert (find opcode *ufb-opcodes*))
#+trythis (when (and *no-tell* (eq opcode :tell-dependents))
(break "truly queueing tell under no-tell"))
(trc nil "ufb-add deferring" opcode (when (eql opcode :client)(car continuation)))
@@ -137,7 +142,7 @@
; dependent reverses the arrow and puts the burden on the prosecution to prove nested tells are a problem.
(bwhen (uqp (fifo-peek (ufb-queue :tell-dependents)))
- (trc "retelling dependenst, one new one being" uqp)
+ #+x42 (trc "retelling dependenst, one new one being" uqp)
(go tell-dependents))
;--- process client queue ------------------------------
@@ -175,7 +180,7 @@
(bwhen (task-info (fifo-pop (ufb-queue :change)))
(trc nil "!!! finbiz --- CHANGE ---- (first of)" (fifo-length (ufb-queue :change)))
(destructuring-bind (defer-info . task-fn) task-info
- (trc nil "finbiz: deferred state change" defer-info)
+ #+xxx (trc "fbz: dfrd chg" defer-info (fifo-length (ufb-queue :change)))
(data-pulse-next (list :finbiz defer-info))
(funcall task-fn :change defer-info)
;
--- /project/cells/cvsroot/cells/md-slot-value.lisp 2008/03/15 15:18:34 1.40
+++ /project/cells/cvsroot/cells/md-slot-value.lisp 2008/04/11 09:19:32 1.41
@@ -131,7 +131,7 @@
(bwhen (v (c-value c))
(if (mdead v)
(progn
- (format t "~&on pulse ~a ensure-value still got and still not returning ~a dead value ~a" *data-pulse-id* c v)
+ #+shhh (format t "~&on pulse ~a ensure-value still got and still not returning ~a dead value ~a" *data-pulse-id* c v)
nil)
v)))
@@ -227,7 +227,8 @@
(defun (setf md-slot-value) (new-value self slot-name
&aux (c (md-slot-cell self slot-name)))
-
+ #+shhh (when *within-integrity*
+ (trc "mdsetf>" self (type-of self) slot-name :new new-value))
(when *c-debug*
(c-setting-debug self slot-name c new-value))
More information about the Cells-cvs
mailing list