aboutsummaryrefslogtreecommitdiffstats
path: root/wbtab.scm
diff options
context:
space:
mode:
Diffstat (limited to 'wbtab.scm')
-rwxr-xr-x[-rw-r--r--]wbtab.scm78
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)))))