aboutsummaryrefslogtreecommitdiffstats
path: root/wbtab.scm
blob: cf156477ab31459987c30af9af88b328dd05dfc3 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
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*))