From ae2b295c7deaf2d7c18ad1ed9b6050970e56bae7 Mon Sep 17 00:00:00 2001
From: Bryan Newbold <bnewbold@robocracy.org>
Date: Mon, 20 Feb 2017 00:05:31 -0800
Subject: Import Upstream version 5e2

---
 rwb-isam.scm | 616 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 616 insertions(+)
 create mode 100644 rwb-isam.scm

(limited to 'rwb-isam.scm')

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")
-- 
cgit v1.2.3