summaryrefslogtreecommitdiffstats
path: root/rdms.scm
diff options
context:
space:
mode:
authorBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:28 -0800
committerBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:28 -0800
commit87b82b5822ca54228cfa6df29be3ad9d4bc47d16 (patch)
tree1eb4f87abd38bea56e08335d939e8171d5e7bfc7 /rdms.scm
parentbd9733926076885e3417b74de76e4c9c7bc56254 (diff)
downloadslib-87b82b5822ca54228cfa6df29be3ad9d4bc47d16.tar.gz
slib-87b82b5822ca54228cfa6df29be3ad9d4bc47d16.zip
Import Upstream version 2d2upstream/2d2
Diffstat (limited to 'rdms.scm')
-rw-r--r--rdms.scm41
1 files changed, 27 insertions, 14 deletions
diff --git a/rdms.scm b/rdms.scm
index e0dbd3c..8c8388f 100644
--- a/rdms.scm
+++ b/rdms.scm
@@ -1,9 +1,9 @@
;;; "rdms.scm" rewrite 6 - the saga continues
-; Copyright 1994, 1995, 1997 Aubrey Jaffer
+; Copyright 1994, 1995, 1997, 2000 Aubrey Jaffer
;
-;Permission to copy this software, to redistribute it, and to use it
-;for any purpose is granted, subject to the following restrictions and
-;understandings.
+;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.
@@ -77,7 +77,7 @@
(and (number? x)
(integer? x)
(not (negative? x))))
- integer
+ number
#f)
(number #f number? number #f)
(expression #f #f expression #f)
@@ -155,8 +155,8 @@
(des:getter bastab (des:keyify-1 key)))))
(define (create-database filename)
- (cond ((and filename (file-exists? filename))
- (rdms:warn 'create-database "file exists:" filename)))
+ ;;(cond ((and filename (file-exists? filename))
+ ;;(rdms:warn 'create-database "file exists:" filename)))
(let* ((lldb (make-base filename 1 (itypes catalog:init-cols)))
(cattab (and lldb (base:open-table lldb base:catalog-id 1
(itypes catalog:init-cols)))))
@@ -221,6 +221,9 @@
(and ans (set! rdms:filename filename))
ans))
+ (define (sync-database)
+ (sync-base lldb))
+
(define (close-database)
(close-base lldb)
(set! rdms:filename #f)
@@ -336,7 +339,9 @@
(accumulate-over-table
(lambda (operation)
(lambda mkeys (base:map-primary-key
- base-table operation (norm-mkeys mkeys)))))
+ base-table operation
+ primary-limit column-type-list
+ (norm-mkeys mkeys)))))
(norm-mkeys
(lambda (mkeys)
(define mlim (length mkeys))
@@ -345,7 +350,9 @@
((= mlim primary-limit) mkeys)
(else
(append mkeys
- (make-list (- primary-limit mlim) #f)))))))
+ (do ((k (- primary-limit mlim) (+ -1 k))
+ (result '() (cons #f result)))
+ ((<= k 0) result))))))))
(export-method
'row:retrieve
(if (= primary-limit column-limit)
@@ -366,6 +373,7 @@
(lambda (proc . mkeys)
(base:ordered-for-each-key
base-table (lambda (ckey) (proc (r ckey)))
+ primary-limit column-type-list
(norm-mkeys mkeys)))))
(cond
((and mutable writable)
@@ -458,7 +466,9 @@
(accumulate-over-table ckey:remove))
(export-method 'row:delete*
(lambda mkeys
- (base:delete* base-table (norm-mkeys mkeys))))
+ (base:delete* base-table
+ primary-limit column-type-list
+ (norm-mkeys mkeys))))
(export-method 'close-table
(lambda () (set! base-table #f)
(set! desc-table #f)
@@ -505,6 +515,7 @@
(base:map-primary-key
base-table
(lambda (ckey) (key-extractor ckey))
+ primary-limit column-type-list
(norm-mkeys mkeys)))))
(else #f)))
(else
@@ -520,6 +531,7 @@
(lambda (ckey)
(list-ref (base:get base-table ckey)
index))
+ primary-limit column-type-list
(norm-mkeys mkeys))))
(else #f)))))))))))))
@@ -587,10 +599,10 @@
(define delete-table
(and mutable
(lambda (table-name)
- (if (not rdms:catalog)
- (set! rdms:catalog (open-table rdms:catalog-name #t)) #f)
- (let ((table (open-table table-name #t))
- (row ((rdms:catalog 'row:remove) table-name)))
+ ;;(if (not rdms:catalog)
+ ;;(set! rdms:catalog (open-table rdms:catalog-name #t)) #f)
+ (let* ((table (open-table table-name #t))
+ (row ((rdms:catalog 'row:remove) table-name)))
(and row (base:kill-table
lldb
(list-ref row (+ -1 catalog:bastab-id-pos))
@@ -602,6 +614,7 @@
(case operation-name
((close-database) close-database)
((write-database) write-database)
+ ((sync-database) sync-database)
((open-table) open-table)
((delete-table) delete-table)
((create-table) create-table)