[cells-cvs] CVS cells

[ktilton]

Update of /project/cells/cvsroot/cells
In directory cl-net:/tmp/cvs-serv13916

Added Files:
	test-cc.lisp 
Log Message:



--- /project/cells/cvsroot/cells/test-cc.lisp	2008/10/12 21:22:16	NONE
+++ /project/cells/cvsroot/cells/test-cc.lisp	2008/10/12 21:22:16	1.1
(in-package :cells)

(defmd tcc ()
  (tccversion 1)
  (tcc-a (c-in nil))
  (tcc-2a (c-in nil)))

(defobserver tcc-a ()
  (case (^tccversion)
    (1 (when new-value
         (with-cc :tcc-a-obs
           (setf (tcc-2a self) (* 2 new-value))
           (with-cc :aha!2
             (assert (eql (tcc-2a self) (* 2 new-value))
               () "one")
             (trc "one happy")))
         (with-cc :aha!
           (assert (eql (tcc-2a self) (* 2 new-value))
             () "two"))))
    (2 (when new-value
         (with-cc :tcc-a-obs
           (setf (tcc-2a self) (* 2 new-value))
           (with-cc :aha!2
             (assert (eql (tcc-2a self) (* 2 new-value))
               () "one")
             (trc "one happy")))))))


(defun test-with-cc ()
  (let ((self (make-instance 'tcc 
                 :tccversion 2 ;:tcc-2a
                )))
    (trcx cool 42)
    (setf (tcc-a self) 42)
    (assert (and (numberp (tcc-2a self))
              (= (tcc-2a self) 84)))))

#+test
(test-with-cc)