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