[cells-cvs] CVS cells
ktilton
ktilton at common-lisp.net
Tue Apr 22 14:50:56 UTC 2008
Update of /project/cells/cvsroot/cells
In directory clnet:/tmp/cvs-serv28246
Modified Files:
cells.lpr
Added Files:
cells-store.lisp
Log Message:
--- /project/cells/cvsroot/cells/cells.lpr 2008/02/02 00:09:28 1.30
+++ /project/cells/cvsroot/cells/cells.lpr 2008/04/22 14:50:56 1.31
@@ -1,4 +1,4 @@
-;; -*- lisp-version: "8.1 [Windows] (Feb 1, 2008 18:35)"; cg: "1.103.2.10"; -*-
+;; -*- lisp-version: "8.1 [Windows] (Apr 3, 2008 23:47)"; cg: "1.103.2.10"; -*-
(in-package :cg-user)
@@ -24,7 +24,8 @@
(make-instance 'module :name "family.lisp")
(make-instance 'module :name "fm-utilities.lisp")
(make-instance 'module :name "family-values.lisp")
- (make-instance 'module :name "test-propagation.lisp"))
+ (make-instance 'module :name "test-propagation.lisp")
+ (make-instance 'module :name "cells-store.lisp"))
:projects (list (make-instance 'project-module :name
"utils-kt\\utils-kt"))
:libraries nil
--- /project/cells/cvsroot/cells/cells-store.lisp 2008/04/22 14:50:56 NONE
+++ /project/cells/cvsroot/cells/cells-store.lisp 2008/04/22 14:50:56 1.1
;; -*- 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)
, at 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
, 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 ((superfluous-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 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))))
More information about the Cells-cvs
mailing list