[cells-cvs] CVS cells

[phildebrandt]

Update of /project/cells/cvsroot/cells
In directory clnet:/tmp/cvs-serv32577

Modified Files:
	md-utilities.lisp 
Log Message:
added bwhen-gethash


--- /project/cells/cvsroot/cells/md-utilities.lisp	2008/04/17 13:52:57	1.17
+++ /project/cells/cvsroot/cells/md-utilities.lisp	2008/04/17 15:50:37	1.18
@@ -91,16 +91,28 @@
 ;;; cells store stuff
 ;;;    (w) Peter Hildebrandt
 
-(export! cells-store c?-with-stored with-store-item store-add store-lookup store-remove)
+(export! cells-store bwhen-gethash c?-with-stored with-store-item store-add store-lookup store-remove)
 
 (defmacro c?-with-stored ((var key store &optional default) &body body)
-  `(c? (let ((something (value (get-listener ,key ,store))))
-	 (declare (ignorable something))
-	 (trc nil "executing c?-bwhen" self :something something :lookup (store-lookup ,key ,store))
-	 (bif (,var (store-lookup ,key ,store))
-	      (progn
-		, at body)
-	      ,default))))
+  `(c? (bwhen-gethash (,var ,key ,store ,default)
+	 , at body)))
+
+(defmacro with-uniqs ((&rest symbols) &body body)
+  `(let ,(mapcar #'(lambda (sym) `(,sym (gensym ,(string sym)))) symbols)
+     , at body))
+
+(defmacro bwhen-gethash ((var key store &optional if-not) &body body)
+  (with-uniqs (gkey gstore gupdate gifnot)
+    `(let ((,gkey ,key)
+	   (,gstore ,store)
+	   (,gifnot ,if-not))
+	(let ((,gupdate (value (get-listener ,gkey ,gstore))))
+	  (declare (ignorable ,gupdate))
+	  (trc nil "executing bwhen-gethash" self :update-tick ,gupdate :lookup (store-lookup ,gkey ,gstore))
+	  (bif (,var (store-lookup ,gkey ,gstore))
+	       (progn
+		 , at body)
+	       ,gifnot)))))
 
 (defmodel cells-store (family)
   ((data :accessor data :initarg :data :cell nil)
@@ -183,7 +195,12 @@
 	 (bar (make-instance 'test-store-item :value (c?-with-stored (v :bar store 'nothing)
 						       (bwhen (val (value v)) val))))
 	 (bar-1 (make-instance 'test-store-item :value (c?-with-stored (v :bar store 'nothing)
-							 (bwhen (val (value v)) (1- val))))))
+							 (bwhen (val (value v)) (1- val)))))
+	 (bypass-lookup? (make-instance 'family :value (c-in t)))
+	 (baz (make-instance 'test-store-item :value (c? (if (value bypass-lookup?)
+							     'no-lookup
+							     (bwhen-gethash (v :bar store 'nothing)
+							       (value v)))))))
 
     (assert-values ("assert fresh initialization")
       (foo 'nothing)
@@ -227,6 +244,15 @@
       (bar 2)
       (bar-1 1))
 
+    (assert-values ("baz w/o lookup")
+      (baz 'no-lookup))
+
+    (with-assert-observers ("activating lookup" baz)
+      (setf (value bypass-lookup?) nil))
+
+    (assert-values ("baz w/lookup")
+      (baz 2))
+
     (with-assert-observers ("deleting foo" foo foo+1)
       (store-remove :foo store))
 
@@ -236,11 +262,18 @@
       (bar 2)
       (bar-1 1))
 
-    (with-assert-observers ("deleting bar" bar bar-1)
+    (with-assert-observers ("deleting bar" bar bar-1 baz)
       (store-remove :bar store))
 
     (assert-values ("deleted bar")
       (foo 'nothing)
       (foo+1 'nothing)
       (bar 'nothing)
-      (bar-1 'nothing))))
\ No newline at end of file
+      (bar-1 'nothing)
+      (baz 'nothing))
+
+    (with-assert-observers ("de-activating lookup" baz)
+      (setf (value bypass-lookup?) t))
+
+    (assert-values ("baz w/o lookup")
+      (baz 'no-lookup))))
\ No newline at end of file