summaryrefslogtreecommitdiffstats
path: root/rwb-isam.scm
diff options
context:
space:
mode:
authorThomas Bushnell <tb@debian.org>2006-04-26 23:01:39 -0700
committerBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:32 -0800
commit20402610bf881f67b22eb1600340d8284556ae56 (patch)
tree6a19e5a1b2cc22dccd1003787a70b751f7da4763 /rwb-isam.scm
parent5846f77421a975897a31d6fbf3f520aab385cea3 (diff)
parentae2b295c7deaf2d7c18ad1ed9b6050970e56bae7 (diff)
downloadscm-20402610bf881f67b22eb1600340d8284556ae56.tar.gz
scm-20402610bf881f67b22eb1600340d8284556ae56.zip
Import Debian changes 5e2-1debian/5e2-1
scm (5e2-1) unstable; urgency=low * New upstream release. * Change to continue.h from version 5e1-2 repeated here.
Diffstat (limited to 'rwb-isam.scm')
-rw-r--r--rwb-isam.scm616
1 files changed, 616 insertions, 0 deletions
diff --git a/rwb-isam.scm b/rwb-isam.scm
new file mode 100644
index 0000000..962a97b
--- /dev/null
+++ b/rwb-isam.scm
@@ -0,0 +1,616 @@
+;;; "rwb-isam.scm" Relational WB database with sequential indexes.
+; 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 'rwb-isam 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 rwb-isam
+ ;; 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")
+ (key:s255 (bytes 255))
+ (key:col1 (bytes 1))
+ (key:col0 (bytes 0))
+ (key:null (bytes 0))
+
+ (key:col-field bytes))
+
+;;;The least-upper-bound of a composite key.
+(define (key:incr key)
+ (string-append key key:s255))
+
+;;;Return key sans prefix and column suffix if first column.
+(define (key:match-prefix? prefix ckey)
+ (define sdx (+ -1 (string-length ckey)))
+ (define prelen (string-length prefix))
+ (and (<= prelen sdx)
+ (string=? prefix (substring ckey 0 prelen))
+ (substring ckey prelen sdx)))
+
+;;;Detects when all match-keys given are false.
+(define (list-all-false? lst)
+ (cond ((null? lst) #t)
+ ((car lst) #f)
+ (else (list-all-false? (cdr lst)))))
+
+;;; 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" "rwb-isam")))
+ (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
+ (key:incr 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 "T" "F")))
+ ((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-float->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) (if (not obj) "#f" (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 "F"))))
+ ((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-float str)))
+ ((s64) (lambda (str) (bytes->integer str -8)))
+ ((s32) (lambda (str) (bytes->integer str -4)))
+ ((s16) (lambda (str) (bytes->integer str -2)))
+ (( s8) (lambda (str) (bytes->integer str -1)))
+ ((u64) (lambda (str) (bytes->integer str 8)))
+ ((u32) (lambda (str) (bytes->integer str 4)))
+ ((u16) (lambda (str) (bytes->integer str 2)))
+ (( u8) (lambda (str) (bytes->integer str 1)))
+ ((atom) (lambda (str) (if (string-ci=? "#f" str) #f (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 ordinal integer number symbol string boolean
+ r64 r32 s64 s32 s16 s8 u64 u32 u16 u8) #t)
+ (else #f)))
+
+;;;; Keys
+
+;;;Keys are composed of one to many fields.
+;;;
+;;;* The binary number formats r64, r32, s64, s32, s16, s8, u64, u32,
+;;; u16, and u8 have fixed widths and are encoded so that the key
+;;; sort order is the same as numerical order.
+;;;
+;;;* Booleans occupy one byte: 'T' or 'F'.
+;;;
+;;;* Strings, symbols, and atoms (symbol or #f) are variable width
+;;; fields terminated by a null byte. They sort in lexicographic
+;;; (dictionary) order. A #f atom is represented by the null string.
+;;;
+;;;* The integer, number, and ordinal formats are strings of decimal
+;;; digits preceeded by a length byte. Nonnegative integers sort
+;;; correctly.
+;;;
+;;;Use of null bytes in string, symbol, or atom key-fields will break
+;;;this encoding.
+
+(define (string-number-keyifier n)
+ (define str (number->string n))
+ (string-append (bytes (string-length str)) str))
+
+(define (string-keyifier str)
+ (string-append str key:null))
+
+(define (key:shorten-1 str)
+ (substring str 0 (+ -1 (string-length str))))
+
+;;; unitary composite-key maker
+(define (make-keyifier-1 type)
+ (case type
+ ((string) string-keyifier)
+ ((symbol) (lambda (s) (string-keyifier (symbol->string s))))
+ ((atom) (lambda (obj) (string-keyifier (if obj (symbol->string obj) ""))))
+ ((boolean) (lambda (b) (if b "T" "F")))
+ ((integer number ordinal) string-number-keyifier)
+ ;; binary number formats
+ ((r64) (lambda (x) (ieee-byte-collate! (ieee-double->bytes x))))
+ ((r32) (lambda (x) (ieee-byte-collate! (ieee-float->bytes x))))
+ ((s64) (lambda (n) (integer-byte-collate! (integer->bytes n -8))))
+ ((s32) (lambda (n) (integer-byte-collate! (integer->bytes n -4))))
+ ((s16) (lambda (n) (integer-byte-collate! (integer->bytes n -2))))
+ (( s8) (lambda (n) (integer->bytes n -1)))
+ ((u64) (lambda (n) (integer-byte-collate! (integer->bytes n 8))))
+ ((u32) (lambda (n) (integer-byte-collate! (integer->bytes n 4))))
+ ((u16) (lambda (n) (integer-byte-collate! (integer->bytes n 2))))
+ (( u8) (lambda (n) (integer->bytes n 1)))
+ (else (slib:error 'make-keyifier-1 'unsupported-type type))))
+
+;;; composite-key maker
+(define (key-polymerase 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 (key:width type)
+ (case type
+ ((r64 s64 u64) 8)
+ ((r32 s32 u32) 4)
+ ((s16 u16) 2)
+ ((s8 u8 boolean) 1)
+ ((integer number ordinal)
+ (lambda (key pos) (+ 1 (byte-ref key pos))))
+ ((string symbol atom) ;null terminated
+ (lambda (key pos)
+ (do ((i pos (+ 1 i)))
+ ((zero? (byte-ref key i)) (- i pos -1)))))
+ (else #f)))
+
+(define (exokeyase type)
+ (case type
+ ((string) key:shorten-1)
+ ((symbol) (lambda (str) (string->symbol (key:shorten-1 str))))
+ ((atom) (lambda (str) (if (string=? "" str) #f
+ (string->symbol (key:shorten-1 str)))))
+ ((boolean) (lambda (str) (not (string=? "F" str))))
+ ((integer number ordinal)
+ (lambda (str) (string->number (substring str 1 (string-length str)))))
+ ;; binary number formats
+ ((r64) (lambda (str) (bytes->ieee-double (ieee-byte-decollate! str))))
+ ((r32) (lambda (str) (bytes->ieee-float (ieee-byte-decollate! str))))
+ ((s64) (lambda (str) (bytes->integer (integer-byte-collate! str) -8)))
+ ((s32) (lambda (str) (bytes->integer (integer-byte-collate! str) -4)))
+ ((s16) (lambda (str) (bytes->integer (integer-byte-collate! str) -2)))
+ (( s8) (lambda (str) (bytes->integer str -1)))
+ ((u64) (lambda (str) (bytes->integer (integer-byte-collate! str) 8)))
+ ((u32) (lambda (str) (bytes->integer (integer-byte-collate! str) 4)))
+ ((u16) (lambda (str) (bytes->integer (integer-byte-collate! str) 2)))
+ (( u8) (lambda (str) (bytes->integer str 1)))
+ (else #f)))
+
+;;; extracts one key-field from composite-key
+(define (make-key-extractor primary-limit types index)
+ (define (wither type)
+ (or (key:width type)
+ (slib:error 'make-key-extractor 'unsupported-type type)))
+ (let ((proc (exokeyase (list-ref types (+ -1 index))))
+ (skips (map wither (butnthcdr index types))))
+ (lambda (key)
+ (let loop ((pos 0) (skips skips))
+ (define flen (car skips))
+ (if (procedure? flen) (set! flen (flen key pos)))
+ (if (null? (cdr skips))
+ (proc (substring key pos (+ pos flen)))
+ (loop (+ pos flen) (cdr skips)))))))
+
+;;; composite-key to list
+(define (make-key->list primary-limit types)
+ (define (wither type)
+ (or (key:width type)
+ (slib:error 'make-key->list 'unsupported-type type)))
+ (define typs (butnthcdr primary-limit types))
+ (let ((procs (map exokeyase typs))
+ (skips (map wither typs)))
+ (lambda (key)
+ (let loop ((pos 0) (skips skips) (procs procs))
+ (define flen (car skips))
+ (if (procedure? flen) (set! flen (flen key pos)))
+ ;;(print 'key->list pos flen typs key)
+ (cons ((car procs) (substring key pos (+ pos flen)))
+ (if (null? (cdr skips))
+ '()
+ (loop (+ pos flen) (cdr skips) (cdr procs))))))))
+
+;;;; for-each-key, ordered-for-each-key, and map-key
+
+(define (make-key-match? key-dimension column-types match-keys)
+ (if (list-all-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 (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)))
+
+;;;; Indexed Sequential Access Methods
+
+(define (ordered-for-each-key handle operation key-dimension column-types match-keys)
+ (let ((bt (handle->bt handle))
+ (prefix (handle->base-id handle))
+ (key-match? (make-key-match? key-dimension column-types match-keys)))
+ (case (- (length column-types) key-dimension)
+ ((0) (let ((prefix+ (key:incr prefix))
+ (maproc (lambda (ckey val)
+ (define fkey (key:match-prefix? prefix ckey))
+ ;;(print 'ordered-for-each-key ckey fkey)
+ (and fkey (key-match? fkey) (operation fkey))
+ #f)))
+ (do ((res (bt:scan bt 0 prefix prefix+ maproc 1)
+ (bt:scan bt 0 (caddr res) prefix+ maproc 1)))
+ ((not (= -1 (car res)))))))
+ (else (let ((prelen (string-length prefix)))
+ (do ((nkey (bt:next bt prefix)
+ (bt:next bt (key:incr (key:shorten-1 nkey)))))
+ ((or (not nkey)
+ (not (string=? prefix (substring nkey 0 prelen))))
+ #f)
+ ;;(print 'ordered-for-each-key nkey (key:match-prefix? prefix nkey))
+ (let ((fkey (key:match-prefix? prefix nkey)))
+ (and fkey (key-match? fkey) (operation fkey)))))))))
+
+(define (make-nexter handle key-dimension column-types index)
+ (define bt (handle->bt handle))
+ (define prefix (handle->base-id handle))
+ (define key->list (make-key->list key-dimension column-types))
+ (define list->key (key-polymerase key-dimension column-types))
+ (lambda keys
+ (define nkey
+ (bt:next bt (string-append prefix
+ (list->key (butnthcdr index keys))
+ key:s255)))
+ (and nkey (let ((ckey (key:match-prefix? prefix nkey)))
+ (and ckey (key->list ckey))))))
+
+(define (make-prever handle key-dimension column-types index)
+ (define bt (handle->bt handle))
+ (define ldx (- (length column-types) key-dimension))
+ (define prefix (handle->base-id handle))
+ (define key->list (make-key->list key-dimension column-types))
+ (define list->key (key-polymerase key-dimension column-types))
+ (lambda keys
+ (define pkey
+ (bt:prev bt (string-append prefix
+ (list->key (butnthcdr index keys)))))
+ (and pkey (let ((ckey (key:match-prefix? prefix pkey)))
+ (and ckey (key->list ckey))))))
+
+;;;; getters and putters
+
+;;;Records are stored as multiple copies of the key to which a
+;;;one-byte code is appended, identifying the field. If all fields
+;;;are primary keys, then KEY:COL0 (a 0 byte) is appended.
+
+(define (make-getter-1 prinum types index)
+ (define type (list-ref types (- index prinum)))
+ (let ((proc (or (wb-string->object type)
+ (slib:error 'make-getter-1 'unsupported-type type)))
+ (ci (key:col-field (- index prinum))))
+ (lambda (handle key)
+ (define val
+ (db:get
+ (handle->bt handle)
+ (string-append (handle->base-id handle) key ci))) ; (print 'ckey )
+ (and val (proc val)))))
+
+;;;If more than one non-primary value is stored, then use SCAN to
+;;;extract the values.
+
+(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 (db:get (handle->bt handle)
+ (string-append (handle->base-id handle) key key:col0))
+ '())))
+ ((1) (let ((proc (wbstr->obj (list-ref types prinum))))
+ (lambda (handle key)
+ (define val
+ (db:get
+ (handle->bt handle)
+ (string-append (handle->base-id handle) key key:col1)))
+ (and val (list (proc val))))))
+ (else (let ((procs (map wbstr->obj (nthcdr prinum types))))
+ (lambda (handle key)
+ (define lst (list 'dummy))
+ (define idx 1)
+ (let ((bt (handle->bt handle))
+ (prefix (string-append (handle->base-id handle) key))
+ (tail lst))
+ (define (loop procs)
+ (define val (db:get bt (string-append prefix (bytes idx))))
+ (cond (val (set-cdr! tail (list ((car procs) val)))
+ (set! tail (cdr tail))
+ (set! idx (+ 1 idx))
+ (if (null? (cdr procs))
+ (cdr lst)
+ (loop (cdr procs))))
+ (else #f)))
+ (loop procs)))))))
+
+(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 key:col0)
+ "")))
+ ((1) (let ((proc (obj->wbstr (list-ref types prinum))))
+ (lambda (handle ckey restcols)
+ (db:put! (handle->bt handle)
+ (string-append (handle->base-id handle) ckey key:col1)
+ (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))
+ (db:put! (handle->bt handle)
+ (string-append (handle->base-id handle)
+ ckey
+ (key: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
+ (key:incr 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
+ (key:incr prefix))))))
+
+ (lambda (operation-name)
+ ;;(require 'trace)
+ #+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))
+ )
+ (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) key-polymerase)
+ ((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)
+ ((make-getter-1) make-getter-1)
+ ((delete) delete)
+ ((delete*) delete*)
+ ((for-each-key) ordered-for-each-key)
+ ((map-key) map-key)
+ ((ordered-for-each-key) ordered-for-each-key)
+ ((make-nexter) make-nexter)
+ ((make-prever) make-prever)
+ ((catalog-id) catalog-id)
+ (else #f))
+ )))
+
+(set! *base-table-implementations*
+ (cons (list 'rwb-isam (make-relational-system rwb-isam))
+ *base-table-implementations*))
+;;(trace bt:scan bt:get make-getter map-key ordered-for-each-key make-key-extractor make-key->list) (set! *qp-width* 333) ;;(trace-all "rwb-isam.scm")