From 879f4fa041cfdefee655eb877f1a91f86a9c62b7 Mon Sep 17 00:00:00 2001
From: Bryan Newbold <bnewbold@robocracy.org>
Date: Fri, 3 Mar 2017 00:56:40 -0800
Subject: New upstream version 5f2

---
 rwb-isam.scm | 78 ++++++++++++++++--------------------------------------------
 1 file changed, 21 insertions(+), 57 deletions(-)
 mode change 100644 => 100755 rwb-isam.scm

(limited to 'rwb-isam.scm')

diff --git a/rwb-isam.scm b/rwb-isam.scm
old mode 100644
new mode 100755
index 962a97b..21c1b85
--- a/rwb-isam.scm
+++ b/rwb-isam.scm
@@ -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 rwb-isam
   ;; foiled indentation so etags will recognize definitions
@@ -80,88 +74,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" "rwb-isam")))
-	 (release-seg seg)
+	     (wb:err? (bt:put! (open-bt seg 0 1) "base-table" "wb-table")))
 	 (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)))))
-- 
cgit v1.2.3