diff options
Diffstat (limited to 'wbtab.scm')
| -rw-r--r-- | wbtab.scm | 525 |
1 files changed, 525 insertions, 0 deletions
diff --git a/wbtab.scm b/wbtab.scm new file mode 100644 index 0000000..cf15647 --- /dev/null +++ b/wbtab.scm @@ -0,0 +1,525 @@ +;;; "wbtab.scm" database tables using WB b-trees. +; Copyright 1996, 2000, 2001, 2003 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 +;granted, subject to the following restrictions and understandings. +; +;1. Any copy made of this software must include this copyright notice +;in full. +; +;2. I have made no warranty or representation that the operation of +;this software will be error-free, and I am under no obligation to +;provide any services, by way of maintenance, update, or otherwise. +; +;3. In conjunction with products arising from the use of this +;material, there shall be no use of my name in any advertising, +;promotional, or sales literature without prior written consent in +;each case. + +;;;; *catalog* is informed of 'wb-table binding by "scm/mkimpcat.scm". +(require 'wb) +(require 'byte) +(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)) +;@ +(define wb-table + ;; foiled indentation so etags will recognize definitions + (let ((make-handle list) + (handle->base-id car) + (handle->bt cadr) + (catalog-id 0) + (free-id "") + (root-name "rwb") + +;;;k30 is a key-coding system where adjacent key fields are separated +;;;by a byte with value in the range 0 (^@=#\nul) to 31 (^_=#\us). +;;;Strings are prefixed with 30 and extend to the the next byte +;;;smaller than 32, or end of the key. Numbers are prefixed by the +;;;string-length of the string representation of the number up to 30. +;;;Unsigned integers with less than 31 digits will thus sort in +;;;numerical order. Larger numbers and strings will sort +;;;lexicographically. +;;; +;;;Use of bytes with values less than 32 in key fields will wedge k30. + + (k30:true (bytes 1 (char->integer #\T))) + (k30:false (bytes 1 (char->integer #\F))) + (k30:s31 (bytes 31)) + (k30:s30 (bytes 30)) + (k30:s1 (bytes 1 (char->integer #\1))) + (k30:s0 (bytes 0))) + +;;;A suffix encoding the field number (with number length prepended) +;;;is appended to composite keys. COL-FIELD computes this field. +;;;k30:s0 and k30:s1 are constants for cases 0 and 1 respectively. +;;;Note that ks30:s0 has no digits! + +(define (k30:incr-key prefix) + (string-append prefix k30:s31)) + +(define (col-field i) + (let ((str (number->string i))) + (string-append (bytes (string-length str)) str))) + +(define (k30:number-keyifier n) + (define str (number->string n)) + (string-append (bytes (min 30 (string-length str))) str)) + +;;; These two NTHCDR procedures replicate those in "comlist.scm". +(define (nthcdr k list) + (do ((i k (+ -1 i)) + (lst list (cdr lst))) + ((<= i 0) lst))) + +(define (butnthcdr k lst) + (cond ((or (zero? k) (null? lst)) '()) + (else (let ((ans (list (car lst)))) + (do ((lst (cdr lst) (cdr lst)) + (tail ans (cdr tail)) + (k (+ -2 k) (+ -1 k))) + ((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) + ((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)))) + +(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?)))) + +(define (write-base seg filename) + (cond ((and filename + (equal? filename (vector-ref wb-seg:files seg))) + (let ((status (close-seg seg #f))) + (cond ((wb:err? status) #f) + ((wb:err? (open-seg seg filename 2)) #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)))) + +(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))) + +;;;; 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)) + (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) + (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)))) + (slib:error 'make-table "free-id lock broken") + #f) + (else base-id))))) + +;;; OPEN-TABLE allocates a new handle (in call to open-db) so each +;;; table handle will have its own last-block-used + +(define (open-table seg base-id dim types) + (define (base-id->prefix base-id) + (define nstr (number->string base-id)) + (string-append (string #\T (integer->char (string-length nstr))) + nstr + (string (integer->char 1) #\D))) + (make-handle (base-id->prefix base-id) + (open-db seg root-name))) + +(define (kill-table seg base-id dim types) + (let* ((handle (open-table seg base-id dim types)) + (prefix (handle->base-id handle))) + (not (wb:err? (bt:rem* (handle->bt handle) + prefix + (k30:incr-key prefix)))))) + +;;;; Conversions from Scheme objects into and from strings. + +(define (object->wb-string type) + (case type + ((string) identity) + ((symbol) symbol->string) + ((integer number ordinal) number->string) + ((boolean) (lambda (b) (if b "Y" "N"))) + ((c64) (lambda (x) (string-append (ieee-double->bytes (real-part x)) + (ieee-double->bytes (imag-part x))))) + ((c32) (lambda (x) (string-append (ieee-float->bytes (real-part x)) + (ieee-float->bytes (imag-part x))))) + ((r64) (lambda (x) (ieee-double->bytes x))) + ((r32) (lambda (x) (ieee-single->bytes x))) + ((s64) (lambda (n) (integer->bytes n -8))) + ((s32) (lambda (n) (integer->bytes n -4))) + ((s16) (lambda (n) (integer->bytes n -2))) + (( s8) (lambda (n) (integer->bytes n -1))) + ((u64) (lambda (n) (integer->bytes n 8))) + ((u32) (lambda (n) (integer->bytes n 4))) + ((u16) (lambda (n) (integer->bytes n 2))) + (( u8) (lambda (n) (integer->bytes n 1))) + ((atom) (lambda (obj) + (cond ((number? obj) (number->string obj)) + ((not obj) "#f") + (else (symbol->string obj))))) + ((expression) (lambda (obj) (call-with-output-string + (lambda (port) (write obj port))))) + (else #f))) + +(define (wb-string->object type) + (case type + ((string) identity) + ((symbol) string->symbol) + ((integer number ordinal) string->number) + ((boolean) (lambda (str) (not (equal? str "N")))) + ((c64) (lambda (str) (make-rectangular + (bytes->ieee-double (substring str 0 8)) + (bytes->ieee-double (substring str 8 16))))) + ((c32) (lambda (str) (make-rectangular + (bytes->ieee-float (substring str 0 4)) + (bytes->ieee-float (substring str 4 8))))) + ((r64) (lambda (str) (bytes->ieee-double str))) + ((r32) (lambda (str) (bytes->ieee-single str))) + ((s64) (lambda (str) (integer->bytes str -8))) + ((s32) (lambda (str) (integer->bytes str -4))) + ((s16) (lambda (str) (integer->bytes str -2))) + (( s8) (lambda (str) (bytes->integer str -1))) + ((u64) (lambda (str) (integer->bytes str 8))) + ((u32) (lambda (str) (integer->bytes str 4))) + ((u16) (lambda (str) (integer->bytes str 2))) + (( u8) (lambda (str) (bytes->integer str 1))) + ((atom) (lambda (str) + (cond ((string->number str)) + ((string-ci=? "#f" str) #f) + (else (string->symbol str))))) + ((expression) (lambda (str) (call-with-input-string str read))) + (else #f))) + +(define (supported-type? type) + (case type + ((ordinal atom integer number boolean string symbol expression + c64 c32 r64 r32 s64 s32 s16 s8 u64 u32 u16 u8) #t) + (else #f))) + +(define (supported-key-type? type) + (case type + ((atom integer number symbol string boolean) #t) + (else #f))) + +;;;; Keys + +;;; unitary composite-key maker +(define (make-keyifier-1 type) + (case type + ((string) (lambda (s) (string-append k30:s30 s))) + ((symbol) (lambda (s) (string-append k30:s30 (symbol->string s)))) + ((integer number ordinal) k30:number-keyifier) + ((boolean) (lambda (b) (if b k30:true k30:false))) + ((atom) (lambda (obj) + (cond ((not obj) k30:false) + ((number? obj) (k30:number-keyifier obj)) + (else (string-append k30:s30 (symbol->string obj)))))) + (else (slib:error 'make-keyifier-1 'unsupported-type type)))) + +;;; composite-key maker +(define (make-list-keyifier prinum types) + (set! types (butnthcdr prinum types)) + ;; Special case when there is just one primary key. + (if (= 1 prinum) + (let ((proc (make-keyifier-1 (car types)))) + (lambda (lst) (proc (car lst)))) + (let ((procs (map make-keyifier-1 types))) + (lambda (lst) + (apply string-append (map (lambda (p v) (p v)) procs lst)))))) + +(define (k30:width type key pos kend) + (define flen (byte-ref key pos)) + (set! pos (+ 1 pos)) + (cond ((= flen 30) + (do ((i pos (+ 1 i))) + ((or (>= i kend) + (<= 0 (byte-ref key i) 30)) + (set! flen (- i pos)))))) + flen) + +;;; extracts one key-field from composite-key +(define (make-key-extractor primary-limit types index) + (define (wbstr->obj type) + (or (wb-string->object type) + (slib:error 'make-key-extractor 'unsupported-type type))) + (let ((proc (wbstr->obj (list-ref types (+ -1 index))))) + (lambda (key) + (define kend (string-length key)) + (let loop ((pos 0) (argind (+ -1 index)) (types types)) + (if (positive? argind) + (loop (+ 1 pos (k30:width (car types) key pos kend)) + (+ -1 argind) + (cdr types)) + (proc (substring key + (+ 1 pos) + (+ 1 pos (k30:width (car types) key pos kend)) + ))))))) + +;;; composite-key to list +(define (make-key->list prinum types) + (define (wbstr->obj type) + (or (wb-string->object type) + (slib:error 'make-key->list 'unsupported-type type))) + (let ((procs (map wbstr->obj (butnthcdr prinum types)))) + (lambda (key) + (define kend (string-length key)) + (let loop ((pos 0) (argind (+ -1 prinum)) (types types) (procs procs)) + (define flen (k30:width (car types) key pos kend)) + (cons ((car procs) (substring key (+ 1 pos) (+ 1 flen pos))) + (if (zero? argind) + '() + (loop (+ 1 flen pos) (+ -1 argind) (cdr types) (cdr procs)))))))) + +;;;; for-each-key, ordered-for-each-key, and map-key + +(define (list-of-false? lst) + (cond ((null? lst) #t) + ((car lst) #f) + (else (list-of-false? (cdr lst))))) + +(define (make-key-match? key-dimension column-types match-keys) + (if (list-of-false? match-keys) + (lambda (ckey) #t) + (let ((keyploder (make-key->list key-dimension column-types))) + (lambda (ckey) + (define (key-match? match-keys keys) + (cond ((null? match-keys) #t) + ((not (car match-keys)) + (key-match? (cdr match-keys) (cdr keys))) + ((equal? (car match-keys) (car keys)) + (key-match? (cdr match-keys) (cdr keys))) + ((not (procedure? (car match-keys))) + #f) + (((car match-keys) (car keys)) + (key-match? (cdr match-keys) (cdr keys))) + (else #f))) + (key-match? match-keys (keyploder ckey)))))) + +(define (ordered-for-each-key + handle operation key-dimension column-types match-keys) + (let* ((bt (handle->bt handle)) + (prefix (handle->base-id handle)) + (pl (string-length prefix)) + (prefix+ (k30:incr-key prefix)) + (key-match? (make-key-match? key-dimension column-types match-keys)) + (maproc + (lambda (k v) + (let ((i (+ -1 (string-length k)))) + (cond ((and (char=? #\1 (string-ref k i)) + (= 1 (byte-ref k (+ -1 i)))) + (and (key-match? (substring k pl (+ -1 i))) + (operation (substring k pl (+ -1 i))))) + ((= 0 (byte-ref k i)) + (and (key-match? (substring k pl i)) + (operation (substring k pl i)))))) + #f))) + (do ((res (bt:scan bt 0 prefix prefix+ maproc 1) + (bt:scan bt 0 (caddr res) prefix+ maproc 1))) + ((not (= -1 (car res))))))) + +(define (map-key handle operation key-dimension column-types match-keys) + (define lst (list 'dummy)) + (let ((tail lst)) + (ordered-for-each-key handle + (lambda (k) + (set-cdr! tail (list (operation k))) + (set! tail (cdr tail))) + key-dimension column-types match-keys) + (cdr lst))) + +;;;; getters and putters + +(define (make-getter prinum types) + (define (wbstr->obj type) + (or (wb-string->object type) + (slib:error 'make-getter 'unsupported-type type))) + (case (- (length types) prinum) + ((0) (lambda (handle key) + (and (bt:get (handle->bt handle) + (string-append (handle->base-id handle) key k30:s0)) + '()))) + ((1) (let ((proc (wbstr->obj (list-ref types prinum)))) + (lambda (handle key) + (define val + (bt:get + (handle->bt handle) + (string-append (handle->base-id handle) key k30:s1))) + (and val (list (proc val)))))) + (else (let ((procs (reverse (map wbstr->obj (nthcdr prinum types))))) + (lambda (handle key) + (let* ((bt (handle->bt handle)) + (prefix (string-append (handle->base-id handle) key)) + (prefix+ (k30:incr-key prefix)) + (lst '()) + (maproc (lambda (k v) (set! lst (cons v lst)) #t))) + (do ((res (bt:scan bt 0 prefix prefix+ maproc 1) + (bt:scan bt 0 (caddr res) prefix+ maproc 1))) + ((not (= -1 (car res))) + (and (not (zero? (cadr res))) + (do ((ps procs (cdr ps)) + (ls lst (cdr ls)) + (rl '() (cons ((car ps) (car ls)) rl))) + ((null? (cdr ls)) + (cons ((car ps) (car ls)) rl)))))))))))) + +(define (make-putter prinum types) + (define (obj->wbstr type) + (or (object->wb-string type) + (slib:error 'make-putter 'unsupported-type type))) + (case (- (length types) prinum) + ((0) (lambda (handle ckey restcols) + (bt:put! (handle->bt handle) + (string-append (handle->base-id handle) ckey k30:s0) + ""))) + ((1) (let ((proc (obj->wbstr (list-ref types prinum)))) + (lambda (handle ckey restcols) + (bt:put! (handle->bt handle) + (string-append (handle->base-id handle) ckey k30:s1) + (proc (car restcols)))))) + (else (let ((procs (map obj->wbstr (nthcdr prinum types)))) + (lambda (handle ckey restcols) + (define i 0) + (for-each + (lambda (proc val) + (set! i (+ 1 i)) + (cond ((wb:err? + (bt:put! (handle->bt handle) + (string-append (handle->base-id handle) + ckey + (col-field i)) + (proc val))) + (slib:error 'putter "couldn't put" + (string-append (handle->base-id handle) + ckey + (col-field i)) + (proc val))))) + procs restcols)))))) + +;;;; other table methods. + +(define (present? handle key) + (let* ((kc (string-append (handle->base-id handle) key)) + (kcl (string-length kc)) + (n (bt:next (handle->bt handle) kc))) + (and n + (<= (+ 1 kcl) (string-length n) (+ 2 kcl)) + (string=? kc (substring n 0 kcl))))) + +(define (delete handle key) + (let ((prefix (string-append (handle->base-id handle) key))) + (not (wb:err? (bt:rem* (handle->bt handle) + prefix + (k30:incr-key prefix)))))) + +(define (delete* handle key-dimension column-types match-keys) + (let ((prefix (string-append (handle->base-id handle) match-keys))) + (not (wb:err? (bt:rem* (handle->bt handle) + prefix + (k30:incr-key prefix)))))) + + (lambda (operation-name) + #+foo ; To trace methods use this wrapper: + ((lambda (proc) + (if (procedure? proc) + (lambda args + (let ((ans (apply proc args))) + (if (procedure? ans) + (tracef ans operation-name) + ans))) + proc)) + ) +;;(trace bt:scan bt:get map-key ordered-for-each-key make-key-extractor make-key->list) (set! *qp-width* 333) ;;(trace-all "rwb-isam.scm") + + (case operation-name + ((make-base) make-base) + ((open-base) open-base) + ((write-base) write-base) + ((sync-base) sync-base) + ((close-base) close-base) + ((make-table) make-table) + ((open-table) open-table) + ((kill-table) kill-table) + ((make-keyifier-1) make-keyifier-1) + ((make-list-keyifier) make-list-keyifier) + ((make-key->list) make-key->list) + ((make-key-extractor) make-key-extractor) + ((supported-type?) supported-type?) + ((supported-key-type?) supported-key-type?) + ((present?) present?) + ((make-putter) make-putter) + ((make-getter) make-getter) + ((delete) delete) + ((delete*) delete*) + ((for-each-key) ordered-for-each-key) + ((map-key) map-key) + ((ordered-for-each-key) ordered-for-each-key) + ((catalog-id) catalog-id) + (else #f))))) + +(set! *base-table-implementations* + (cons (list 'wb-table (make-relational-system wb-table)) + *base-table-implementations*)) |