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))