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