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 () ,@body))) - -(defun call-without-c-dependency (fn) - (let (*depender*) - (funcall fn))) + ` (let (*depender*) + ,@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))