Commit 21ebc573 authored by Kenny Tilton's avatar Kenny Tilton
Browse files

Allow access to dead instances during *not-to-be* processing.

parent 93857ae8
......@@ -26,8 +26,8 @@
(defmd image (family) left top width height)
(defun right (x) (+ (left x) (width x)))
(defun bottom (x) (+ (top x) (height x)))
(defun i-right (x) (+ (left x) (width x)))
(defun i-bottom (x) (+ (top x) (height x)))
(defmd stack (image)
justify
......@@ -42,7 +42,7 @@
(:right (- (width .parent) (^width)))))))
(mk-kid-slot (top)
(c? (bif (psib (psib))
(bottom psib)
(i-bottom psib)
(top .parent))))))
:accessor kid-slots
:initarg :kid-slots))
......@@ -53,7 +53,7 @@
;; because they will be endowed with rules as necessary to achieve that end by the parent stack.
;;
;; note the ifmissing option, which defaults to nil. the stack's goal is mainly to manage the
;; top attribute of each kid to match any predecessor's bottom attribute. the stack will as a
;; top attribute of each kid to match any predecessor's i-bottom attribute. the stack will as a
;; a convenience arrange for horizontal justification, but if some kid chose to define its
;; left attribute that would be honored.
;;
......@@ -74,11 +74,11 @@
(every (lambda (k) (eql 10 (left k)))
(kids stack))))
(ct-assert (every (lambda (k)
(eql (top k) (bottom (fm-prior-sib k))))
(eql (top k) (i-bottom (fm-prior-sib k))))
(cdr (kids stack))))
(setf (justify stack) :right)
(ct-assert (and (eql 510 (right stack))
(every (lambda (k) (eql 510 (right k)))
(ct-assert (and (eql 510 (i-right stack))
(every (lambda (k) (eql 510 (i-right k)))
(kids stack))))
))
......@@ -47,6 +47,7 @@ a cellular slot (or in a list in such) and then mop those up on not-to-be.
(defparameter *within-integrity* nil)
(defparameter *client-queue-handler* nil)
(defparameter *unfinished-business* nil)
(defparameter *not-to-be* nil)
#+test
(cells-reset)
......
......@@ -21,8 +21,9 @@ See the Lisp Lesser GNU Public License for more details.
(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 @@ See the Lisp Lesser GNU Public License for more details.
(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 @@ See the Lisp Lesser GNU Public License for more details.
(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))
......
......@@ -31,9 +31,9 @@ See the Lisp Lesser GNU Public License for more details.
;___________________ 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 @@ See the Lisp Lesser GNU Public License for more details.
(: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)
(trc nil "not.to-be cleared 2 fm-parent, eternal-rest" self))))
(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)))))
(defun md-quiesce (self)
(trc nil "md-quiesce nailing cells" self (type-of self))
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment