Update of /project/cells/cvsroot/cell-cultures/cells In directory common-lisp.net:/tmp/cvs-serv14181/cells
Modified Files: integrity.lisp model-object.lisp Log Message:
Date: Thu Jul 8 20:53:04 2004 Author: ktilton
Index: cell-cultures/cells/integrity.lisp diff -u cell-cultures/cells/integrity.lisp:1.3 cell-cultures/cells/integrity.lisp:1.4 --- cell-cultures/cells/integrity.lisp:1.3 Tue Jul 6 18:25:40 2004 +++ cell-cultures/cells/integrity.lisp Thu Jul 8 20:53:04 2004 @@ -51,8 +51,8 @@ `(let ((*deference-acknowledged* t)) ,@body))
-(defmacro with-integrity ((key &rest defer-info) &rest body) - `(call-with-integrity ,key (list ,@defer-info) +(defmacro with-integrity ((debug-key &rest defer-info) &rest body) + `(call-with-integrity ,debug-key (list ,@defer-info) (lambda () ,@body)))
(defun ufb-queue (opcode) @@ -61,7 +61,7 @@ (defun ufb-add (opcode continuation) (fifo-add (ufb-queue opcode) continuation))
-(defconstant-once *ufb-opcodes* '(:user-notify :output :setf :makunbound)) +(defconstant-once *ufb-opcodes* '(:user-notify :output :setf :makunbound :finalize))
(define-condition c-opcode-deferred (c-enabling) ((defer-info :initarg :defer-info :reader defer-info)) @@ -72,8 +72,8 @@
(defparameter *ufb-needed* nil)
-(defun call-with-integrity (key defer-info action &aux (opcode (car defer-info))) - (declare (ignorable key)) +(defun call-with-integrity (debug-key defer-info action &aux (opcode (car defer-info))) + (declare (ignorable debug-key)) (assert (or (null opcode) (member opcode *ufb-opcodes*))) (trc nil "call-with-integrity entry *unfinished-business*" *unfinished-business*) (if *unfinished-business* @@ -91,7 +91,7 @@ (mapcar (lambda (opcode) (cons opcode (make-fifo-queue))) *ufb-opcodes*))) - (trc nil "!!!!!!!!!! started new *unfinished-business*" key defer-info) + (trc nil "!!!!!!!!!! started new *unfinished-business*" debug-key defer-info) (when (or (zerop *data-pulse-id*) (member opcode '(:setf :makunbound))) (data-pulse-next (cons opcode defer-info)) @@ -145,4 +145,12 @@ (push c setfs) (data-pulse-next (list :finbiz c new-value)) (funcall task-fn)))) + (go notify-users)) + + ; --- do finalizations ------------------------ + (setf task (fifo-pop (ufb-queue :finalize))) + (when task + (destructuring-bind ((self) . task-fn) task + (trc "finbiz: deferred finalize!!!!" self) + (funcall task-fn)) (go notify-users))))
Index: cell-cultures/cells/model-object.lisp diff -u cell-cultures/cells/model-object.lisp:1.2 cell-cultures/cells/model-object.lisp:1.3 --- cell-cultures/cells/model-object.lisp:1.2 Sun Jul 4 11:59:41 2004 +++ cell-cultures/cells/model-object.lisp Thu Jul 8 20:53:04 2004 @@ -154,7 +154,7 @@ (progn ;; next bit revised to avoid double-output of optimized cells (when (eql '.kids slot-name) (bwhen (sv (slot-value self '.kids)) - (trc nil "soon will output initial kids of" self) + (trc "soon will output initial kids of" self) (md-kids-change self sv nil :md-awaken-slot))) (c-output-initially self slot-name)))))))