[cells-cvs] CVS cells

phildebrandt phildebrandt at common-lisp.net
Fri Feb 1 15:52:49 UTC 2008


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



More information about the Cells-cvs mailing list