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