[cells-cvs] CVS cells
ktilton
ktilton at common-lisp.net
Tue Apr 22 11:03:45 UTC 2008
Update of /project/cells/cvsroot/cells
In directory clnet:/tmp/cvs-serv11478
Modified Files:
md-utilities.lisp
Log Message:
--- /project/cells/cvsroot/cells/md-utilities.lisp 2008/04/22 10:11:50 1.20
+++ /project/cells/cvsroot/cells/md-utilities.lisp 2008/04/22 11:03:44 1.21
@@ -112,235 +112,3 @@
, at initargs
:fm-parent (progn (assert self) self)))
-
-;;;
-;;; cells store stuff
-;;; (w) Peter Hildebrandt
-
-(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-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-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 ((,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))
- (:default-initargs
- :data (make-hash-table)))
-
-;;; infrastructure for manipulating the store and kicking rules
-
-(defmethod entry (key (store cells-store))
- (gethash key (data store)))
-
-(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
- (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 &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)
- (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
-
-(export! test-cells-store)
-
-(defmodel test-store-item (family)
- ())
-
-(defvar *observers*)
-
-(defobserver .value ((self test-store-item))
- (trc " changed value" :self self :to (value self))
- (when (boundp '*observers*)
- (push self *observers*)))
-
-(defmacro with-assert-observers ((desc &rest asserted-observers) &body body)
- `(let ((*observers* nil))
- (trc ,desc " -- checking observers")
- , at body
- (let ((superflous-observers (loop for run in *observers* if (not (member run (list , at asserted-observers))) collect run))
- (failed-observers (loop for asserted in (list , at asserted-observers) if (not (member asserted *observers*)) collect asserted)))
- (trc "called observers on" *observers* :superflous superflous-observers :failed failed-observers)
- (assert (not superflous-observers))
- (assert (not failed-observers)))))
-
-(defmacro assert-values ((desc) &body objects-and-values)
- `(progn
- (trc ,desc)
- ,@(loop for (obj val) in objects-and-values
- collect `(assert (eql (value ,obj) ,val)))))
-
-(defun test-cells-store ()
- (trc "testing cells-store -- making objects")
- (let* ((store (make-instance 'cells-store))
- (foo (make-instance 'test-store-item :value (c?-with-stored (v :foo store 'nothing)
- (bwhen (val (value v)) val))))
- (foo+1 (make-instance 'test-store-item :value (c?-with-stored (v :foo store 'nothing)
- (bwhen (val (value v)) (1+ val)))))
- (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)))))
- (bypass-lookup? (make-instance 'family :value (c-in t)))
- (baz (make-instance 'test-store-item :value (c? (if (value bypass-lookup?)
- 'no-lookup
- (bwhen-c-stored (v :bar store 'nothing)
- (value v)))))))
-
- (assert-values ("assert fresh initialization")
- (foo 'nothing)
- (foo+1 'nothing)
- (bar 'nothing)
- (bar-1 'nothing))
-
- (with-assert-observers ("adding foo" foo foo+1)
- (store-add :foo store (make-instance 'family :value (c-in nil))))
-
- (assert-values ("added foo = nil")
- (foo nil)
- (foo+1 nil)
- (bar 'nothing)
- (bar-1 'nothing))
-
- (with-assert-observers ("changing foo" foo foo+1)
- (setf (value (store-lookup :foo store)) 1))
-
- (assert-values ("changed foo = 1")
- (foo 1)
- (foo+1 2)
- (bar 'nothing)
- (bar-1 'nothing))
-
- (with-assert-observers ("adding bar = 42" bar bar-1)
- (store-add :bar store (make-instance 'family :value (c-in 42))))
-
- (assert-values ("changed foo = 1")
- (foo 1)
- (foo+1 2)
- (bar 42)
- (bar-1 41))
-
- (with-assert-observers ("changing bar to 2" bar bar-1)
- (setf (value (store-lookup :bar store)) 2))
-
- (assert-values ("changed foo = 1")
- (foo 1)
- (foo+1 2)
- (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))
-
- (assert-values ("deleted foo")
- (foo 'nothing)
- (foo+1 'nothing)
- (bar 2)
- (bar-1 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)
- (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
More information about the Cells-cvs
mailing list