diff options
Diffstat (limited to 'wbtab.scm')
| -rwxr-xr-x[-rw-r--r--] | wbtab.scm | 78 |
1 files changed, 21 insertions, 57 deletions
diff --git a/wbtab.scm b/wbtab.scm index cf15647..102828d 100644..100755 --- a/wbtab.scm +++ b/wbtab.scm @@ -1,5 +1,5 @@ ;;; "wbtab.scm" database tables using WB b-trees. -; Copyright 1996, 2000, 2001, 2003 Aubrey Jaffer +; Copyright 1996, 2000, 2001, 2003, 2008 Aubrey Jaffer ; ;Permission to copy this software, to modify it, to redistribute it, ;to distribute modified versions, and to use it for any purpose is @@ -23,14 +23,8 @@ (require 'byte-number) (require 'relational-database) ;for make-relational-system -;;; WB-SEG:LOCKS has one extra location at end for loop end test -(defvar wb-seg:locks (let ((locks (make-vector (+ 1 wb:num-segs) #f))) - (do ((i (+ -2 (vector-length locks)) (+ -1 i))) - ((negative? i) locks) - (vector-set! locks i (make-arbiter i))))) -(defvar wb-seg:files (make-vector (+ 1 wb:num-segs) #f)) -(defvar wb-seg:roots (make-vector (+ 1 wb:num-segs) #f)) -(defvar wb-seg:mut?s (make-vector (+ 1 wb:num-segs) #f)) +(init-wb 75 150 2048) + ;@ (define wb-table ;; foiled indentation so etags will recognize definitions @@ -90,88 +84,58 @@ ((or (negative? k) (null? lst)) ans) (set-cdr! tail (list (car lst)))))))) -;;;; Segments - -(define (find-free-seg) - (do ((i 0 (+ 1 i)) - (arb (vector-ref wb-seg:locks 0) - (vector-ref wb-seg:locks (+ 1 i)))) - ((or (not arb) (try-arbiter arb)) - (and arb i)))) -(define (release-seg seg) - (and seg - (release-arbiter (vector-ref wb-seg:locks seg)) - #f)) - ;;;; Create, open, write, sync, or close database. -(define (seg-open-base seg filename writable?) - (vector-set! wb-seg:files seg filename) - (vector-set! wb-seg:mut?s seg writable?) - (vector-set! wb-seg:roots seg (open-db seg root-name)) - (cond ((wb:err? (vector-ref wb-seg:roots seg)) - (close-base seg) - #f) - (else seg))) - ;;; Because B-trees grow in depth only very slowly, we might as well ;;; put everything into one B-tree named "rwb". (define (make-base filename dim types) - (define seg (find-free-seg)) - (cond ((not seg) #f) - ((wb:err? (make-seg seg filename 2048)) (release-seg seg) #f) - ((wb:err? (open-seg seg filename 2)) (release-seg seg) #f) + (define seg (make-seg filename 2048)) + (cond ((not seg) + (slib:error 'make-base "couldn't make new base" filename) + #f) ((or (wb:err? (bt:put! (create-db seg #\T root-name) free-id "1")) (wb:err? (bt:put! (open-bt seg 0 1) "base-table" "wb-table"))) - (release-seg seg) (slib:error 'make-base "couldn't modify new base" filename) #f) - (else (seg-open-base seg filename #t)))) + (else seg))) (define (open-base filename writable?) - (define seg (find-free-seg)) - (cond ((wb:err? (open-seg seg filename (if writable? 2 0))) - (release-seg seg) #f) - (else (seg-open-base seg filename writable?)))) + (open-seg filename writable?)) (define (write-base seg filename) - (cond ((and filename - (equal? filename (vector-ref wb-seg:files seg))) + (cond ((and filename (equal? filename (SEG:STR seg))) (let ((status (close-seg seg #f))) (cond ((wb:err? status) #f) - ((wb:err? (open-seg seg filename 2)) #f) - (else #t)))) + (else + (set! seg (open-seg filename #t)) + (cond ((not seg) #f) + (else #t)))))) (else ;;(slib:error 'write-base "WB can't change database filename" filename) #f))) (define (sync-base seg) - (and seg (write-base seg (vector-ref wb-seg:files seg)))) + (and seg (write-base seg (SEG:STR seg)))) (define (close-base seg) - (cond ((wb:err? (close-seg seg #f)) - (let ((status (close-seg seg #t))) - (release-seg seg) - (not (wb:err? status)))) - (else (release-seg seg) #t))) + (not (wb:err? (close-seg seg #f)))) ;;;; Make, open, and destroy tables. (define (make-table seg dim types) - (and (vector-ref wb-seg:mut?s seg) - (let* ((tns (bt:rem (vector-ref wb-seg:roots seg) free-id)) + (and (SEG:MUTABLE? seg) + (let* ((root (open-db seg root-name)) + (tns (bt:rem root free-id)) (base-id (and (string? tns) (string->number tns)))) (cond ((not tns) (slib:error 'make-table 'free-id "in use?") #f) ((not base-id) - (bt:put (vector-ref wb-seg:roots seg) free-id tns) + (bt:put root free-id tns) (slib:error 'make-table "free-id corrupted" base-id) #f) - ((not (bt:put (vector-ref wb-seg:roots seg) - free-id - (number->string (+ 1 base-id)))) + ((not (bt:put root free-id (number->string (+ 1 base-id)))) (slib:error 'make-table "free-id lock broken") #f) (else base-id))))) |