Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv1246
Modified Files: cells.asd defmodel.lisp propagate.lisp Added Files: test-propagation.lisp Log Message: moved propagation test to test-propagation.lisp
--- /project/cells/cvsroot/cells/cells.asd 2007/12/02 18:44:18 1.8 +++ /project/cells/cvsroot/cells/cells.asd 2008/02/01 15:52:49 1.9 @@ -39,7 +39,8 @@ (:file "md-utilities") (:file "family") (:file "fm-utilities") - (:file "family-values"))) + (:file "family-values") + (:file "test-propagation")))
(defmethod perform ((o load-op) (c (eql (find-system :cells)))) (pushnew :cells *features*)) --- /project/cells/cvsroot/cells/defmodel.lisp 2007/11/30 16:51:18 1.13 +++ /project/cells/cvsroot/cells/defmodel.lisp 2008/02/01 15:52:49 1.14 @@ -25,72 +25,72 @@ (setf (get ',class :cell-types) nil) (setf (get ',class 'slots-excluded-from-persistence) ',(loop for slotspec in slotspecs - unless (and (getf (cdr slotspec) :ps t) - (getf (cdr slotspec) :persistable t)) - collect (car slotspec)))) + unless (and (getf (cdr slotspec) :ps t) + (getf (cdr slotspec) :persistable t)) + collect (car slotspec)))) ;; define slot macros before class so they can appear in ;; initforms and default-initargs ,@(delete nil - (loop for slotspec in slotspecs - nconcing (destructuring-bind - (slotname &rest slotargs - &key (cell t) owning (accessor slotname) reader - &allow-other-keys) - slotspec + (loop for slotspec in slotspecs + nconcing (destructuring-bind + (slotname &rest slotargs + &key (cell t) owning (accessor slotname) reader + &allow-other-keys) + slotspec
- (declare (ignorable slotargs owning)) - (list - (when cell - (let* ((reader-fn (or reader accessor)) - (deriver-fn (intern$ "^" (symbol-name reader-fn)))) - `(eval-when (:compile-toplevel :execute :load-toplevel) - (unless (macro-function ',deriver-fn) - (defmacro ,deriver-fn () - `(,',reader-fn self)))))))))) + (declare (ignorable slotargs owning)) + (list + (when cell + (let* ((reader-fn (or reader accessor)) + (deriver-fn (intern$ "^" (symbol-name reader-fn)))) + `(eval-when (:compile-toplevel :execute :load-toplevel) + (unless (macro-function ',deriver-fn) + (defmacro ,deriver-fn () + `(,',reader-fn self))))))))))
- ; - ; ------- defclass --------------- (^slot-value ,model ',',slotname) - ; + ; + ; ------- defclass --------------- (^slot-value ,model ',',slotname) + ;
(progn - (defclass ,class ,(or directsupers '(model-object));; now we can def the class - ,(mapcar (lambda (s) - (list* (car s) - (let ((ias (cdr s))) - (remf ias :persistable) - (remf ias :ps) - ;; We handle accessor below - (when (getf ias :cell t) - (remf ias :reader) - (remf ias :writer) - (remf ias :accessor)) - (remf ias :cell) - (remf ias :owning) - (remf ias :unchanged-if) - ias))) (mapcar #'copy-list slotspecs)) - (:documentation - ,@(or (cdr (find :documentation options :key #'car)) - '("chya"))) - (:default-initargs ;; nil ok and needed: acl oddity in re not clearing d-i's sans this - ,@(cdr (find :default-initargs options :key #'car))) - (:metaclass ,(or (cadr (find :metaclass options :key #'car)) - 'standard-class))) + (defclass ,class ,(or directsupers '(model-object)) ;; now we can def the class + ,(mapcar (lambda (s) + (list* (car s) + (let ((ias (cdr s))) + (remf ias :persistable) + (remf ias :ps) + ;; We handle accessor below + (when (getf ias :cell t) + (remf ias :reader) + (remf ias :writer) + (remf ias :accessor)) + (remf ias :cell) + (remf ias :owning) + (remf ias :unchanged-if) + ias))) (mapcar #'copy-list slotspecs)) + (:documentation + ,@(or (cdr (find :documentation options :key #'car)) + '("chya"))) + (:default-initargs ;; nil ok and needed: acl oddity in re not clearing d-i's sans this + ,@(cdr (find :default-initargs options :key #'car))) + (:metaclass ,(or (cadr (find :metaclass options :key #'car)) + 'standard-class)))
(defmethod shared-initialize :after ((self ,class) slot-names &rest iargs &key) (declare (ignore slot-names iargs)) ,(when (and directsupers (not (member 'model-object directsupers))) - `(unless (typep self 'model-object) - (error "If no superclass of ~a inherits directly + `(unless (typep self 'model-object) + (error "If no superclass of ~a inherits directly or indirectly from model-object, model-object must be included as a direct super-class in the defmodel form for ~a" ',class ',class)))) - ; - ; slot accessors once class is defined... - ; + ; + ; slot accessors once class is defined... + ; ,@(mapcar (lambda (slotspec) (destructuring-bind - (slotname &rest slotargs - &key (cell t) owning unchanged-if (accessor slotname) reader writer type - &allow-other-keys) + (slotname &rest slotargs + &key (cell t) owning unchanged-if (accessor slotname) reader writer type + &allow-other-keys) slotspec
(declare (ignorable slotargs)) @@ -102,24 +102,24 @@ (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))) + `(defmethod ,reader-fn ((self ,class)) + (md-slot-value self ',slotname)))
,(when writer-fn - `(defmethod (setf ,writer-fn) (new-value (self ,class)) - (setf (md-slot-value self ',slotname) - ,(if type - `(coerce new-value ',type) - 'new-value)))) + `(defmethod (setf ,writer-fn) (new-value (self ,class)) + (setf (md-slot-value self ',slotname) + ,(if type + `(coerce new-value ',type) + 'new-value))))
,(when unchanged-if - `(def-c-unchanged-test (,class ,slotname) ,unchanged-if)) + `(def-c-unchanged-test (,class ,slotname) ,unchanged-if)) ) )) )) - slotspecs) + slotspecs) (find-class ',class))))
(defun defmd-canonicalize-slot (slotname --- /project/cells/cvsroot/cells/propagate.lisp 2008/02/01 03:18:36 1.30 +++ /project/cells/cvsroot/cells/propagate.lisp 2008/02/01 15:52:49 1.31 @@ -264,39 +264,7 @@ (funcall f) *the-unpropagated*)))
- -(defmd tcp () - (left (c-in 0)) - (top (c-in 0)) - (right (c-in 0)) - (bottom (c-in 0)) - (area (c? (trc "area running") - (* (- (^right)(^left)) - (- (^top)(^bottom)))))) - -(defobserver area () - (TRC "new area" new-value old-value old-value-boundp :pulse *data-pulse-id*)) - -(defun tcprop () - (untrace) - (test-prep) - (LET ((box (make-instance 'tcp))) - (trc "changing top to 10" *data-pulse-id*) - (setf (top box) 10) - (trc "not changing top" *data-pulse-id*) - (setf (top box) 10) - (trc "changing right to 10" *data-pulse-id*) - (setf (right box) 10) - (trc "not changing right" *data-pulse-id*) - (setf (right box) 10) - (trc "changing bottom to -1" *data-pulse-id*) - (decf (bottom box)) - (with-client-propagation () - (loop repeat 20 do - (trc "changing bottom by -1" *data-pulse-id*) - (decf (bottom box)) - (decf (left box)))))) - +
--- /project/cells/cvsroot/cells/test-propagation.lisp 2008/02/01 15:52:49 NONE +++ /project/cells/cvsroot/cells/test-propagation.lisp 2008/02/01 15:52:49 1.1
(in-package :cells)
(defmd tcp () (left (c-in 0)) (top (c-in 0)) (right (c-in 0)) (bottom (c-in 0)) (area (c? (trc "area running") (* (- (^right)(^left)) (- (^top)(^bottom))))))
(defobserver area () (TRC "new area" new-value old-value old-value-boundp :pulse *data-pulse-id*))
(defun tcprop () (untrace) (test-prep) (LET ((box (make-instance 'tcp))) (trc "changing top to 10" *data-pulse-id*) (setf (top box) 10) (trc "not changing top" *data-pulse-id*) (setf (top box) 10) (trc "changing right to 10" *data-pulse-id*) (setf (right box) 10) (trc "not changing right" *data-pulse-id*) (setf (right box) 10) (trc "changing bottom to -1" *data-pulse-id*) (decf (bottom box)) (with-client-propagation () (loop repeat 20 do (trc "changing bottom by -1" *data-pulse-id*) (decf (bottom box)) (decf (left box))))))