[cells-cvs] CVS cells
ktilton
ktilton at common-lisp.net
Tue Sep 5 18:40:48 UTC 2006
Update of /project/cells/cvsroot/cells
In directory clnet:/tmp/cvs-serv30469
Modified Files:
defmodel.lisp family.lisp model-object.lisp propagate.lisp
Log Message:
New :owning slot parameter automates NOT-TO-BE of slot contents as value/values disappear.
--- /project/cells/cvsroot/cells/defmodel.lisp 2006/08/21 04:29:30 1.8
+++ /project/cells/cvsroot/cells/defmodel.lisp 2006/09/05 18:40:47 1.9
@@ -26,30 +26,32 @@
;
; define slot macros before class so they can appear in initforms and default-initargs
;
- ,@(loop for slotspec in slotspecs
- collecting (destructuring-bind
+ ,@(delete nil
+ (loop for slotspec in slotspecs
+ nconcing (destructuring-bind
(slotname &rest slotargs
- &key (cell t) (accessor slotname) reader
+ &key (cell t) owning (accessor slotname) reader
&allow-other-keys)
slotspec
(declare (ignorable slotargs))
- (when cell
- (let* ((reader-fn (or reader accessor))
- (deriver-fn (intern$ "^" (symbol-name reader-fn)))
- )
- ;
- ; may as well do this here...
- ;
- ;;(trc nil "slot, deriverfn would be" slotname deriverfn)
- `(eval-when (:compile-toplevel :execute :load-toplevel)
- (setf (md-slot-cell-type ',class ',slotname) ,cell)
- (unless (macro-function ',deriver-fn)
- (defmacro ,deriver-fn ()
- `(,',reader-fn self)))
- )
- ))
- ))
+ (list
+ (when cell
+ (let* ((reader-fn (or reader accessor))
+ (deriver-fn (intern$ "^" (symbol-name reader-fn)))
+ )
+ ;
+ ; may as well do this here...
+ ;
+ ;;(trc nil "slot, deriverfn would be" slotname deriverfn)
+ `(eval-when (:compile-toplevel :execute :load-toplevel)
+ (setf (md-slot-cell-type ',class ',slotname) ,cell)
+ (unless (macro-function ',deriver-fn)
+ (defmacro ,deriver-fn ()
+ `(,',reader-fn self))))))
+ (when owning
+ `(eval-when (:compile-toplevel :execute :load-toplevel)
+ (setf (md-slot-owning ',class ',slotname) ,owning)))))))
;
; ------- defclass --------------- (^slot-value ,model ',',slotname)
@@ -66,6 +68,7 @@
(remf ias :writer)
(remf ias :accessor))
(remf ias :cell)
+ (remf ias :owning)
(remf ias :unchanged-if)
ias))) (mapcar #'copy-list slotspecs))
(:documentation
@@ -123,6 +126,7 @@
(defun defmd-canonicalize-slot (slotname
&key
(cell nil cell-p)
+ (owning nil owning-p)
(type nil type-p)
(initform nil initform-p)
(initarg (intern (symbol-name slotname) :keyword))
@@ -135,6 +139,7 @@
(list* slotname :initarg initarg
(append
(when cell-p (list :cell cell))
+ (when owning-p (list :owning owning))
(when type-p (list :type type))
(when initform-p (list :initform initform))
(when unchanged-if-p (list :unchanged-if unchanged-if))
--- /project/cells/cvsroot/cells/family.lisp 2006/09/03 13:41:09 1.13
+++ /project/cells/cvsroot/cells/family.lisp 2006/09/05 18:40:47 1.14
@@ -64,12 +64,13 @@
(defmodel family (model)
((.kid-slots :cell nil
- :initform nil
- :accessor kid-slots
- :initarg :kid-slots)
+ :initform nil
+ :accessor kid-slots
+ :initarg :kid-slots)
(.kids :initform (c-in nil) ;; most useful
- :accessor kids
- :initarg :kids)
+ :owning t
+ :accessor kids
+ :initarg :kids)
))
(defvar *parent*)
@@ -152,11 +153,7 @@
(bwhen (sample (find-if-not 'fm-parent new-kids))
(c-break "New as of Cells3: parent must be supplied to make-instance of ~a kid ~a"
(type-of sample) sample))
- (trc nil ".kids output > entry" new-kids (mapcar 'fm-parent new-kids))
-
- (dolist (k (set-difference old-kids new-kids))
- (trc nil "kids change nailing lost kid" k)
- (not-to-be k)))
+ (trc nil ".kids output > entry" new-kids (mapcar 'fm-parent new-kids)))
(defmethod kids ((other model-object)) nil)
--- /project/cells/cvsroot/cells/model-object.lisp 2006/09/03 13:41:09 1.10
+++ /project/cells/cvsroot/cells/model-object.lisp 2006/09/05 18:40:47 1.11
@@ -45,12 +45,13 @@
; here we shuttle cells out of the slots and into a per-instance dictionary of cells,
; as well as tell the cells what slot and instance they are mediating.
;
+
(when (slot-boundp self '.md-state)
(loop for esd in (class-slots (class-of self))
for sn = (slot-definition-name esd)
for sv = (when (slot-boundp self sn)
(slot-value self sn))
- ;;do (print (list self sn sv (typep sv 'cell)))
+ ;; do (print (list self sn sv (typep sv 'cell)))
when (typep sv 'cell)
do (if (md-slot-cell-type (type-of self) sn)
(md-install-cell self sn sv)
@@ -171,6 +172,21 @@
(setf (cdr entry) new-type)
(push (cons slot-name new-type) (get class-name :cell-types)))))
+(defun md-slot-owning (class-name slot-name)
+ (bif (entry (assoc slot-name (get class-name :ownings)))
+ (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)))))))
+
+(defun (setf md-slot-owning) (value class-name slot-name)
+ (let ((entry (assoc slot-name (get class-name :ownings))))
+ (if entry
+ (setf (cdr entry) value)
+ (push (cons slot-name value) (get class-name :ownings)))))
+
+
+
(defmethod md-slot-value-store ((self model-object) slot-name new-value)
(trc nil "md-slot-value-store" slot-name new-value)
(setf (slot-value self slot-name) new-value))
--- /project/cells/cvsroot/cells/propagate.lisp 2006/09/03 13:41:09 1.20
+++ /project/cells/cvsroot/cells/propagate.lisp 2006/09/05 18:40:47 1.21
@@ -94,6 +94,15 @@
(slot-value-observe (c-slot-name c) (c-model c)
(c-value c) prior-value prior-value-supplied)
+ (when (and prior-value-supplied
+ prior-value
+ (md-slot-owning (type-of (c-model c)) (c-slot-name c)))
+ (bwhen (lost (set-difference prior-value (c-value c)))
+ (trc "bingo!!!!! lost nailing" lost)
+ (break "go")
+ (typecase lost
+ (atom (not-to-be lost))
+ (cons (mapcar 'not-to-be lost)))))
;
; with propagation done, ephemerals can be reset. we also do this in c-awaken, so
; let the fn decide if C really is ephemeral. Note that it might be possible to leave
More information about the Cells-cvs
mailing list