[cells-cvs] CVS cells

[phildebrandt]

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

Modified Files:
	md-slot-value.lisp md-utilities.lisp 
Log Message:
Newer version of the cells-store


--- /project/cells/cvsroot/cells/md-slot-value.lisp	2008/04/13 15:25:00	1.44
+++ /project/cells/cvsroot/cells/md-slot-value.lisp	2008/04/20 13:04:40	1.45
@@ -24,7 +24,7 @@
   (when (and (not *not-to-be*)
           (mdead self))
     (trc "md-slot-value passed dead self, returning NIL" self slot-name c)
-    (inspect self)
+    #-sbcl (inspect self)
     (break "see inspector for dead ~a" self)
     (return-from md-slot-value nil))
   (tagbody
--- /project/cells/cvsroot/cells/md-utilities.lisp	2008/04/17 15:50:37	1.18
+++ /project/cells/cvsroot/cells/md-utilities.lisp	2008/04/20 13:04:40	1.19
@@ -91,68 +91,109 @@
 ;;; cells store stuff
 ;;;    (w) Peter Hildebrandt
 
-(export! cells-store bwhen-gethash c?-with-stored with-store-item store-add store-lookup store-remove)
+(export! cells-store bwhen-c-stored c?-with-stored with-store-item store-add store-lookup store-remove)
 
 (defmacro c?-with-stored ((var key store &optional default) &body body)
-  `(c? (bwhen-gethash (,var ,key ,store ,default)
+  `(c? (bwhen-c-stored (,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)
+(defmacro bwhen-c-stored ((var key store &optional if-not) &body body)
+  (with-uniqs (gkey gstore glink 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))
+	(let ((,glink (query-c-link ,gkey ,gstore)))
+	  (declare (ignorable ,glink))
+	  (trc nil "executing bwhen-c-stored" self :update-tick ,glink :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)
-   (listeners :accessor listeners :initarg :listeners :cell nil))
+  ((data :accessor data :initarg :data :cell nil))
   (:default-initargs
-      :data (make-hash-table)
-    :listeners (make-hash-table)
-    :kids (c-in nil)))
+      :data (make-hash-table)))
 
 ;;; infrastructure for manipulating the store and kicking rules
 
-(defmethod get-listener (key (store cells-store))
-  (or (gethash key (listeners store))
-      (let ((new-listener (make-instance 'family :fm-parent store :value (c-in 0))))
-	(with-integrity (:change)
-	  (push new-listener (kids store))
-	  (setf (gethash key (listeners store)) new-listener))
-	new-listener)))
-
-(defmethod kick-listener (key (store cells-store))
-  (bwhen (listener (gethash key (listeners store)))
-    (incf (value listener))))
+(defmethod entry (key (store cells-store))
+  (gethash key (data store)))
 
-(defmacro with-store-item ((key store) &body body)
+(defmethod (setf entry) (new-data key (store cells-store))
+  (setf (gethash key (data store)) new-data))
+
+(defmethod c-link (key (store cells-store))
+  (car (entry key store)))
+
+(defmethod (setf c-link) (new-c-link key (store cells-store))
+  (if (consp (entry key store))
+      (setf (car (entry key store)) new-c-link)
+      (setf (entry key store) (cons new-c-link nil)))
+  new-c-link)
+
+(defmethod item (key (store cells-store))
+  (cdr (entry key store)))
+
+(defmethod (setf item) (new-item key (store cells-store))
+  (if (consp (entry key store))
+      (setf (cdr (entry key store)) new-item)
+      (setf (entry key store) (cons nil new-item)))
+  new-item)
+
+;;; c-links
+
+(defmodel c-link ()
+  ((value :accessor value :initform (c-in 0) :initarg :value)))
+
+(defmethod query-c-link (key (store cells-store))
+  (trc "c-link> query link" key store (c-link key store))
+  (value (or (c-link key store)
+	     (setf (c-link key store) (make-instance 'c-link)))))
+
+(defmethod kick-c-link (key (store cells-store))
+  (bwhen (link (c-link key store))
+    (trc "c-link> kick link" key store link)
+    (with-integrity (:change :kick-c-link)
+     (incf (value link)))))
+
+(defmacro with-store-item ((item key store) &body body)
   `(prog1
-       (progn , at body)
-     (kick-listener ,key ,store)))
+       (symbol-macrolet ((,item '(item key store)))
+	(progn
+	  , at body))
+     (kick-c-link ,key ,store)))
+
+
+(defmacro with-store-entry ((key store &key quiet) &body body)
+  `(prog1
+       (progn
+	 , at body)
+     (unless ,quiet
+       (kick-c-link ,key ,store))))
 
 ;;; item management
 
-(defmethod store-add (key (store cells-store) object)
-  (with-store-item (key store)    
-    (setf (gethash key (data store)) object)))
+(defmethod store-add (key (store cells-store) object &key quiet)
+  (with-store-entry (key store :quiet quiet)
+    (when (item key store)
+      (trc "overwriting item" key (item key store)))
+    (setf (item key store) object)))
 
 (defmethod store-lookup (key (store cells-store) &optional default)
-  (gethash key (data store) default))
-
-(defmethod store-remove (key (store cells-store))
-  (with-store-item (key store)
-    (remhash key (data store))))
+  (when (mdead (item key store))
+    (with-store-entry (key store)
+      (trc "looked up dead item -- resetting to nil" key store)
+      (setf (item key store) nil)))
+  (or (item key store) default))
+
+(defmethod store-remove (key (store cells-store) &key quiet)
+  (with-store-entry (key store :quiet quiet)
+    (setf (item key store) nil)))
 
 
 ;;;  unit test
@@ -199,7 +240,7 @@
 	 (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)
+							     (bwhen-c-stored (v :bar store 'nothing)
 							       (value v)))))))
 
     (assert-values ("assert fresh initialization")