[cells-cvs] CVS cells

[ktilton]

Update of /project/cells/cvsroot/cells
In directory clnet:/tmp/cvs-serv19981

Modified Files:
	cells.lisp md-slot-value.lisp md-utilities.lisp 
Log Message:
Allow access to dead instances during *not-to-be* processing.

--- /project/cells/cvsroot/cells/cells.lisp	2008/04/11 09:19:29	1.26
+++ /project/cells/cvsroot/cells/cells.lisp	2008/04/12 22:53:26	1.27
@@ -47,6 +47,7 @@
 (defparameter *within-integrity* nil)
 (defparameter *client-queue-handler* nil)
 (defparameter *unfinished-business* nil)
+(defparameter *not-to-be* nil)
 
 #+test
 (cells-reset)
--- /project/cells/cvsroot/cells/md-slot-value.lisp	2008/04/11 09:19:32	1.41
+++ /project/cells/cvsroot/cells/md-slot-value.lisp	2008/04/12 22:53:26	1.42
@@ -21,8 +21,9 @@
 (defparameter *ide-app-hard-to-kill* t)
 
 (defun md-slot-value (self slot-name &aux (c (md-slot-cell self slot-name)))
-  (when (mdead self)
-    (trc "md-slot-value passed dead self, returning NIL" self)
+  (when (and (not *not-to-be*)
+          (mdead self))
+    (trc "md-slot-value passed dead self, returning NIL" self slot-name c)
     (inspect self)
     (break "see inspector for dead ~a" self)
     (return-from md-slot-value nil))
@@ -57,7 +58,7 @@
       (record-caller c))))
   
 (defun chk (s &optional (key 'anon))
-  (when (eq :eternal-rest (md-state s))
+  (when (mdead s)
     (break "model ~a is dead at ~a" s key)))
 
 ;;;(defmethod trcp ((c cell))
@@ -77,6 +78,9 @@
   (count-it :ensure-value-is-current)
   ;; (trc c "ensure-value-is-current > entry" c (c-state c) :now-pulse *data-pulse-id* debug-id ensurer)
 
+  (when *not-to-be*
+    (return-from ensure-value-is-current t))
+
   (when (and (not (symbolp (c-model c)))(eq :eternal-rest (md-state (c-model c))))
     (break "model ~a of cell ~a is dead" (c-model c) c))
 
--- /project/cells/cvsroot/cells/md-utilities.lisp	2008/01/29 04:29:52	1.14
+++ /project/cells/cvsroot/cells/md-utilities.lisp	2008/04/12 22:53:26	1.15
@@ -31,9 +31,9 @@
 ;___________________ birth / death__________________________________
   
 (defgeneric mdead (self)
-
   (:method ((self model-object))
-    (eq :eternal-rest (md-state self)))
+    (unless *not-to-be*
+      (eq :eternal-rest (md-state self))))
 
   (:method (self)
     (declare (ignore self))
@@ -45,20 +45,20 @@
 
   (:method :around ((self model-object))
     (declare (ignorable self))
-    (trc nil #+not (typep self '(or mathx::problem mathx::prb-solvers mathx::prb-solver))
-      "not.to-be nailing" self)
-    ;;showpanic (c-assert (not (eq (md-state self) :eternal-rest)))
-    (unless (eq (md-state self) :eternal-rest)
-      (call-next-method)
-
-      (setf (fm-parent self) nil
-        (md-state self) :eternal-rest)
-
-      (md-map-cells self nil
-        (lambda (c)
-          (c-assert (eq :quiesced (c-state c))))) ;; fails if user obstructs not.to-be with primary method (use :before etc)
+    (let ((*not-to-be* t))
+      (trc nil #+not (typep self '(or mathx::problem mathx::prb-solvers mathx::prb-solver))
+        "not.to-be nailing" self)
+      (unless (eq (md-state self) :eternal-rest)
+        (call-next-method)
+        
+        (setf (fm-parent self) nil
+          (md-state self) :eternal-rest)
+
+        (md-map-cells self nil
+          (lambda (c)
+            (c-assert (eq :quiesced (c-state c))))) ;; fails if user obstructs not.to-be with primary method (use :before etc)
 
-      (trc nil "not.to-be cleared 2 fm-parent, eternal-rest" self))))
+        (trc nil "not.to-be cleared 2 fm-parent, eternal-rest" self)))))
 
 (defun md-quiesce (self)
   (trc nil "md-quiesce nailing cells" self (type-of self))