diff options
Diffstat (limited to 'rdms.scm')
| -rw-r--r-- | rdms.scm | 69 |
1 files changed, 41 insertions, 28 deletions
@@ -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 |