diff --git a/functional-tests/block-cache.scm b/functional-tests/block-cache.scm new file mode 100644 index 0000000..6b0dfc8 --- /dev/null +++ b/functional-tests/block-cache.scm @@ -0,0 +1,83 @@ +(library + (block-cache) + (exports) + (imports (chezscheme)) + + (define (cache-open path block-size nr-cache-blocks) + ... + ) + + (define (cache-read-lock cache index) + + ) + + (define (cache-write-lock cache index)) + (define (cache-zero-lock cache index)) + + ;; The super block is the one that should be written last. Unlocking this + ;; block triggers the following events: + ;; + ;; i) synchronous write of all dirty blocks _except_ the superblock. + ;; + ;; ii) synchronous write of superblock + ;; + ;; If any locks are held at the time of the superblock being unlocked then an + ;; error will be raised. + (define (cache-superblock-lock cache index)) + (define (cache-superblock-zero)) + + (define (cache-unlock b) + ) + + (define-syntax with-block + (syntax-rules () + ((_ (var b) body ...) + (let ((var b)) + (dynamic-wind + (lambda () #f) + (lambda () body ...) + (lambda () (block-put var))))))) + + ;;-------------------------------------------- + + (define-record-type ro-spine (fields cache parent child)) + + (define (ro-spine-begin cache) + (make-ro-spine cache #f #f)) + + (define (ro-spine-end spine) + (define (unlock bl) + (if bl (cache-unlock) #f)) + + (unlock (ro-spine-parent spine)) + (unlock (ro-spine-child spine)) + (ro-spine-parent-set! spine #f) + (ro-spind-child-set! spine #f)) + + (define (ro-spine-step spine index) + (define (push b) + (cond + ((ro-spine-child spine) + (let ((grandparent (ro-spine-parent spine))) + (ro-spine-parent-set! spine (ro-spine-child spine)) + (ro-spine-child-set! spine b))) + ((ro-spine-parent spine) + (ro-spine-child-set! spine b)) + (else + (ro-spine-parent-set! spine b)))) + + (push (cache-read-lock (ro-spine-cache spine) index))) + + (define-syntax with-ro-spine + (syntax-rules () + ((_ (n cache) body ...) + + (let ((n (ro-spine-begin cache))) + (dynamic-wind + (lambda () #f) + (lambda () body ...) + (lambda () (ro-spine-end))))))) + + ) + + diff --git a/functional-tests/block-io.scm b/functional-tests/block-io.scm index dc873a2..7cf0625 100644 --- a/functional-tests/block-io.scm +++ b/functional-tests/block-io.scm @@ -22,11 +22,12 @@ (define-syntax with-metadata (syntax-rules () - ((_ (port path) body ...) (let ((port (open-metadata path))) - (dynamic-wind - (lambda () #f) - (lambda () body ...) - (lambda () (close-port port))))))) + ((_ (port path) body ...) + (let ((port (open-metadata path))) + (dynamic-wind + (lambda () #f) + (lambda () body ...) + (lambda () (close-port port))))))) ;; FIXME: return our own condition? (define (io-error msg) diff --git a/functional-tests/btree.scm b/functional-tests/btree.scm index e2c0f26..a947ca4 100644 --- a/functional-tests/btree.scm +++ b/functional-tests/btree.scm @@ -89,20 +89,15 @@ (let ((dev (btree-dev tree)) (vt (btree-value-type tree))) - (define (lookup root fail-k) - (let loop ((root root)) - (let* ((node (read-block dev root)) - (header (node-header-unpack node 0)) - (index (lower-bound node header key))) - (if (internal-node? header) - (loop (value-at header node index le64-type)) - (if (= key (key-at node index)) - (value-at header node index vt) - (fail-k default)))))) - - (call/cc - (lambda (fail-k) - (lookup (btree-root tree) fail-k))))) + (let loop ((root (btree-root tree))) + (let* ((node (read-block dev root)) + (header (node-header-unpack node 0)) + (index (lower-bound node header key))) + (if (internal-node? header) + (loop (value-at header node index le64-type)) + (if (= key (key-at node index)) + (value-at header node index vt) + default)))))) ;;;;---------------------------------------------- ;;;; Walking the btree diff --git a/functional-tests/mapping-tree.scm b/functional-tests/mapping-tree.scm index 1f28e7a..00028a1 100644 --- a/functional-tests/mapping-tree.scm +++ b/functional-tests/mapping-tree.scm @@ -7,7 +7,6 @@ (import (btree) (chezscheme) - (binary-format) (srfi s8 receive)) (define-record-type mapping-tree (fields dev-tree)) @@ -15,6 +14,13 @@ (define (mapping-tree-open dev root) (make-mapping-tree (btree-open le64-type dev root))) + ;; (values