summaryrefslogtreecommitdiffstats
path: root/wbtab.scm
diff options
context:
space:
mode:
authorBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:31 -0800
committerBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:31 -0800
commitae2b295c7deaf2d7c18ad1ed9b6050970e56bae7 (patch)
treeeee15e02ae016333546d3841712be591b2bcb06f /wbtab.scm
parent302e3218b7d487539ec305bf23881a6ee7d5be99 (diff)
downloadscm-ae2b295c7deaf2d7c18ad1ed9b6050970e56bae7.tar.gz
scm-ae2b295c7deaf2d7c18ad1ed9b6050970e56bae7.zip
Import Upstream version 5e2upstream/5e2
Diffstat (limited to 'wbtab.scm')
-rw-r--r--wbtab.scm525
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*))