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) ,@body)))

(defmacro with-uniqs ((&rest symbols) &body body) `(let ,(mapcar #'(lambda (sym) `(,sym (gensym ,(string sym)))) symbols) ,@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 ,@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 ,@body) - (kick-listener ,key ,store))) + (symbol-macrolet ((,item '(item key store))) + (progn + ,@body)) + (kick-c-link ,key ,store))) + + +(defmacro with-store-entry ((key store &key quiet) &body body) + `(prog1 + (progn + ,@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")