[cells-cvs] CVS cells
ktilton
ktilton at common-lisp.net
Tue Apr 22 10:11:50 UTC 2008
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))))
More information about the Cells-cvs
mailing list