Commit
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
- Loading branch information
ktilton
committed
Apr 22, 2008
1 parent
6cf104c
commit d0bc812
Showing
3 changed files
with
247 additions
and
4 deletions.
There are no files selected for viewing
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Original file line | Diff line number | Diff line change |
---|---|---|---|
@@ -0,0 +1,243 @@ | |||
;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- | |||
#| | |||
Cells Store -- Dependence on a Hash-Table | |||
Copyright (C) 2008 by Peter Hildebrandt | |||
This library is free software; you can redistribute it and/or | |||
modify it under the terms of the Lisp Lesser GNU Public License | |||
(http://opensource.franz.com/preamble.html), known as the LLGPL. | |||
This library is distributed WITHOUT ANY WARRANTY; without even | |||
the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. | |||
See the Lisp Lesser GNU Public License for more details. | |||
|# | |||
|
|||
(in-package :cells) | |||
|
|||
(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) | |||
,@body))) | |||
|
|||
(defmacro bwhen-c-stored ((var key store &optional if-not) &body body) | |||
(with-gensyms (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 | |||
,@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 | |||
,@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 &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") | |||
,@body | |||
(let ((superfluous-observers (loop for run in *observers* if (not (member run (list ,@asserted-observers))) collect run)) | |||
(failed-observers (loop for asserted in (list ,@asserted-observers) if (not (member asserted *observers*)) collect asserted))) | |||
(trc "called observers on" *observers* :superflous superfluous-observers :failed failed-observers) | |||
(assert (not superfluous-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)))) |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters