summaryrefslogtreecommitdiffstats
path: root/rdms.scm
diff options
context:
space:
mode:
authorBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:26 -0800
committerBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:26 -0800
commitf24b9140d6f74804d5599ec225717d38ca443813 (patch)
tree0da952f1a5a7c0eacfc05c296766523e32c05fe2 /rdms.scm
parent8ffbc2df0fde83082610149d24e594c1cd879f4a (diff)
downloadslib-f24b9140d6f74804d5599ec225717d38ca443813.tar.gz
slib-f24b9140d6f74804d5599ec225717d38ca443813.zip
Import Upstream version 2c0upstream/2c0
Diffstat (limited to 'rdms.scm')
-rw-r--r--rdms.scm69
1 files changed, 41 insertions, 28 deletions
diff --git a/rdms.scm b/rdms.scm
index 0fd4a2c..8c20362 100644
--- a/rdms.scm
+++ b/rdms.scm
@@ -1,5 +1,5 @@
;;; "rdms.scm" rewrite 6 - the saga continues
-; Copyright 1994 Aubrey Jaffer
+; Copyright 1994, 1995, 1997 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
@@ -85,8 +85,7 @@
(string #f string? string #f)
(domain ,rdms:domains-name #f atom #f)))
-(define (rdms:warn identifier msg obj)
- (display identifier) (display #\ ) (display msg) (write obj) (newline))
+(define rdms:warn slib:warn)
(define rdms:error slib:error)
(define (make-relational-system base)
@@ -234,7 +233,9 @@
(define (open-table table-name writable)
(define cat:row (cat:get-row base:catalog table-name))
- (cond ((and writable (not mutable))
+ (cond ((not cat:row)
+ (rdms:error "can't open-table:" table-name))
+ ((and writable (not mutable))
(rdms:error "can't open-table for writing:" table-name)))
(let ((column-limit (row-ref cat:row catalog:column-limit-pos))
(desc-table
@@ -319,21 +320,27 @@
((basic 'make-list-keyifier) primary-limit column-type-list))
(set! key->list
((basic 'make-key->list) primary-limit column-type-list))
- (let ((export-method
- (lambda (name proc)
- (set! export-alist
- (cons (cons name proc) export-alist))))
- (generalize-to-table
- (lambda (operation)
- (lambda ()
- (base:for-each-primary-key base-table operation))))
- (accumulate-over-table
- (lambda (operation)
- (lambda () (base:map-primary-key base-table operation))))
- (ckey:retrieve ;ckey gets whole row (assumes exists)
- (if (= primary-limit column-limit) key->list
- (lambda (ckey) (append (key->list ckey)
- (base:get base-table ckey))))))
+ (letrec ((export-method
+ (lambda (name proc)
+ (set! export-alist
+ (cons (cons name proc) export-alist))))
+ (ckey:retrieve ;ckey gets whole row (assumes exists)
+ (if (= primary-limit column-limit) key->list
+ (lambda (ckey) (append (key->list ckey)
+ (base:get base-table ckey)))))
+ (accumulate-over-table
+ (lambda (operation)
+ (lambda mkeys (base:map-primary-key
+ base-table operation (norm-mkeys mkeys)))))
+ (norm-mkeys
+ (lambda (mkeys)
+ (define mlim (length mkeys))
+ (cond ((> mlim primary-limit)
+ (rdms:error "too many keys:" mkeys))
+ ((= mlim primary-limit) mkeys)
+ (else
+ (append mkeys
+ (make-list (- primary-limit mlim) #f)))))))
(export-method
'row:retrieve
(if (= primary-limit column-limit)
@@ -351,8 +358,10 @@
'for-each-row
(let ((r (if (= primary-limit column-limit) key->list
ckey:retrieve)))
- (lambda (proc) (base:ordered-for-each-key
- base-table (lambda (ckey) (proc (r ckey)))))))
+ (lambda (proc . mkeys)
+ (base:ordered-for-each-key
+ base-table (lambda (ckey) (proc (r ckey)))
+ (norm-mkeys mkeys)))))
(cond
((and mutable writable)
(letrec
@@ -427,6 +436,7 @@
(lambda (rows) (for-each row:update rows))))
(letrec ((base:delete (basic 'delete))
+ (base:delete* (basic 'delete*))
(ckey:remove (lambda (ckey)
(let ((r (ckey:retrieve ckey)))
(and r (base:delete base-table ckey))
@@ -442,8 +452,8 @@
(export-method 'row:remove*
(accumulate-over-table ckey:remove))
(export-method 'row:delete*
- (generalize-to-table
- (lambda (ckey) (base:delete base-table ckey))))
+ (lambda mkeys
+ (base:delete* base-table (norm-mkeys mkeys))))
(export-method 'close-table
(lambda () (set! base-table #f)
(set! desc-table #f)
@@ -468,7 +478,8 @@
column table-name)))))))
(lambda args
(cond
- ((null? args) #f)
+ ((null? args)
+ #f)
((null? (cdr args))
(let ((pp (assq (car args) export-alist)))
(and pp (cdr pp))))
@@ -485,10 +496,11 @@
((get) (lambda keys
(and (present? base-table (list->key keys))
(list-ref keys (+ -1 ci)))))
- ((get*) (lambda ()
+ ((get*) (lambda mkeys
(base:map-primary-key
base-table
- (lambda (ckey) (key-extractor ckey)))))
+ (lambda (ckey) (key-extractor ckey))
+ (norm-mkeys mkeys))))
(else #f))))
(else
(let ((index (- ci (+ 1 primary-limit))))
@@ -497,12 +509,13 @@
(let ((row (base:get base-table
(list->key keys))))
(and row (list-ref row index)))))
- ((get*) (lambda ()
+ ((get*) (lambda mkeys
(base:map-primary-key
base-table
(lambda (ckey)
(list-ref (base:get base-table ckey)
- index)))))
+ index))
+ (norm-mkeys mkeys))))
(else #f)))))))))))))
(define create-table