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

Modified Files: defmodel.lisp family.lisp md-slot-value.lisp md-utilities.lisp model-object.lisp propagate.lisp Log Message:

--- /project/cells/cvsroot/cells/defmodel.lisp 2008/03/17 20:34:45 1.18 +++ /project/cells/cvsroot/cells/defmodel.lisp 2008/04/22 10:11:50 1.19 @@ -103,7 +103,7 @@ `(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))) --- /project/cells/cvsroot/cells/family.lisp 2008/04/11 14:00:14 1.26 +++ /project/cells/cvsroot/cells/family.lisp 2008/04/22 10:11:50 1.27 @@ -19,7 +19,7 @@ (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 @@ (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 @@

(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 ---------------------------- ; --- /project/cells/cvsroot/cells/md-slot-value.lisp 2008/04/20 13:04:40 1.45 +++ /project/cells/cvsroot/cells/md-slot-value.lisp 2008/04/22 10:11:50 1.46 @@ -69,12 +69,13 @@

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

--- /project/cells/cvsroot/cells/md-utilities.lisp 2008/04/20 13:04:40 1.19 +++ /project/cells/cvsroot/cells/md-utilities.lisp 2008/04/22 10:11:50 1.20 @@ -40,26 +40,52 @@ 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) --- /project/cells/cvsroot/cells/model-object.lisp 2008/02/02 00:09:28 1.19 +++ /project/cells/cvsroot/cells/model-object.lisp 2008/04/22 10:11:50 1.20 @@ -216,7 +216,7 @@ 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 @@ (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 @@ (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) --- /project/cells/cvsroot/cells/propagate.lisp 2008/03/15 15:18:34 1.34 +++ /project/cells/cvsroot/cells/propagate.lisp 2008/04/22 10:11:50 1.35 @@ -105,7 +105,7 @@ ; (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))))