Commit a0020dc0 authored by Kenny Tilton's avatar Kenny Tilton
Browse files

*** empty log message ***

parent d250b9da
......@@ -103,7 +103,7 @@ the defmodel form for ~a" ',class ',class))))
`(eval-when (#-sbcl :compile-toplevel :load-toplevel :execute) ; ph -- prevent sbcl warning
(setf (md-slot-cell-type ',class ',slotname) ,cell)
,(when owning
`(setf (md-slot-owning ',class ',slotname) ,owning))
`(setf (md-slot-owning? ',class ',slotname) ,owning))
,(when reader-fn
`(defmethod ,reader-fn ((self ,class))
(md-slot-value self ',slotname)))
......
......@@ -19,7 +19,7 @@ See the Lisp Lesser GNU Public License for more details.
(in-package :cells)
(eval-when (:compile-toplevel :execute :load-toplevel)
(export '(model value family dbg
(export '(model value family dbg .pa
kids kid1 ^k1 kid2 ^k2 last-kid ^k-last perishable)))
(defmodel model ()
......@@ -47,6 +47,7 @@ See the Lisp Lesser GNU Public License for more details.
(or (md-name self) (type-of self))))
(define-symbol-macro .parent (fm-parent self))
(define-symbol-macro .pa (fm-parent self))
(defmethod md-name (other)
(trc "yep other md-name" other (type-of other))
......@@ -180,11 +181,7 @@ See the Lisp Lesser GNU Public License for more details.
(defmethod kids ((other model-object)) nil)
(defmethod not-to-be :before ((fm family))
(let ((sv-kids (slot-value fm '.kids)))
(when (listp sv-kids)
(dolist ( kid sv-kids)
(not-to-be kid)))))
;------------------ kid slotting ----------------------------
;
......
......@@ -46,6 +46,7 @@ See the Lisp Lesser GNU Public License for more details.
(mk-kid-slot (py :if-missing t)
(c? (py-maintain-pt 0))))))
(export! geo-kid-sized)
(defmodel geo-kid-sized (family)
()
(:default-initargs
......
......@@ -69,12 +69,13 @@ See the Lisp Lesser GNU Public License for more details.
(defvar *trc-ensure* nil)
(defun ensure-value-is-current (c debug-id ensurer)
(defmethod ensure-value-is-current (c debug-id ensurer)
;
; ensurer can be used cell propagating to callers, or an existing caller who wants to make sure
; dependencies are up-to-date before deciding if it itself is up-to-date
;
(declare (ignorable debug-id ensurer))
(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)
......
......@@ -40,26 +40,52 @@ See the Lisp Lesser GNU Public License for more details.
nil))
(defgeneric not-to-be (self)
(:method ((self list))
(dolist (s self)
(not-to-be s)))
(:method ((self array))
(loop for s across self
do (not-to-be s)))
(:method ((self hash-table))
(maphash (lambda (k v)
(declare (ignorable k))
(not-to-be v)) self))
(:method ((self model-object))
(md-quiesce self))
(:method :before ((self model-object))
(loop for (slot-name . owning?) in (get (type-of self) :ownings)
when owning?
do (not-to-be (slot-value self slot-name))))
(:method :around ((self model-object))
(declare (ignorable 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)))))
(let ((*not-to-be* t)
(dbg nil #+not (or (eq (md-name self) :eclm-owner)
(typep self '(or mathx::eclm-2008 clo:ix-form mathx::a1-panel mathx::edit-caret ctk:window)))))
(flet ((gok ()
(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)) ()
"Cell ~a of dead model ~a not quiesced. Was not-to-be shadowed by
a primary method? Use :before instead."))) ;; fails if user obstructs not.to-be with primary method (use :before etc)
)))
(if (not dbg)
(gok)
(wtrc (0 100 "not.to-be nailing" self (when (typep self 'family)
(mapcar 'type-of (slot-value self '.kids))))
(gok)
(when dbg (trc "finished nailing" self))))))))
(defun md-quiesce (self)
(trc nil "md-quiesce nailing cells" self (type-of self))
(md-map-cells self nil (lambda (c)
......
......@@ -216,7 +216,7 @@ See the Lisp Lesser GNU Public License for more details.
do (setf (md-slot-cell-type (class-name c) slot-name) new-type)))
(cdar (push (cons slot-name new-type) (get class-name :cell-types)))))))
(defun md-slot-owning (class-name slot-name)
(defun md-slot-owning? (class-name slot-name)
(assert class-name)
(if (eq class-name 'null)
(get slot-name :owning)
......@@ -224,9 +224,9 @@ See the Lisp Lesser GNU Public License for more details.
(cdr entry)
(dolist (super (class-precedence-list (find-class class-name)))
(bwhen (entry (assoc slot-name (get (c-class-name super) :ownings)))
(return (setf (md-slot-owning class-name slot-name) (cdr entry))))))))
(return (setf (md-slot-owning? class-name slot-name) (cdr entry))))))))
(defun (setf md-slot-owning) (value class-name slot-name)
(defun (setf md-slot-owning?) (value class-name slot-name)
(assert class-name)
(if (eq class-name 'null)
(setf (get slot-name :owning) value)
......@@ -236,7 +236,7 @@ See the Lisp Lesser GNU Public License for more details.
(progn
(setf (cdr entry) value)
(loop for c in (class-direct-subclasses (find-class class-name))
do (setf (md-slot-owning (class-name c) slot-name) value)))
do (setf (md-slot-owning? (class-name c) slot-name) value)))
(push (cons slot-name value) (get class-name :ownings))))))
(defun md-slot-value-store (self slot-name new-value)
......
......@@ -105,7 +105,7 @@ See the Lisp Lesser GNU Public License for more details.
;
(when (and prior-value-supplied
prior-value
(md-slot-owning (type-of (c-model c)) (c-slot-name c)))
(md-slot-owning? (type-of (c-model c)) (c-slot-name c)))
(trc nil "c.propagate> contemplating lost")
(flet ((listify (x) (if (listp x) x (list x))))
(bif (lost (set-difference (listify prior-value) (listify (c-value c))))
......
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