diff options
Diffstat (limited to 'rdms.scm')
| -rw-r--r-- | rdms.scm | 287 |
1 files changed, 162 insertions, 125 deletions
@@ -1,5 +1,5 @@ ;;; "rdms.scm" rewrite 6 - the saga continues -; Copyright 1994, 1995, 1997, 2000 Aubrey Jaffer +; Copyright 1994, 1995, 1997, 2000, 2002, 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 @@ -8,7 +8,7 @@ ;1. Any copy made of this software must include this copyright notice ;in full. ; -;2. I have made no warrantee or representation that the operation of +;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. ; @@ -22,10 +22,10 @@ (define rdms:columns-name '*columns*) (define catalog:init-cols - '((1 #t table-name #f atom) - (2 #f column-limit #f uint) - (3 #f coltab-name #f atom) - (4 #f bastab-id #f base-id) + '((1 #t table-name #f symbol) + (2 #f column-limit #f ordinal) + (3 #f coltab-name #f symbol) + (4 #f bastab-id #f ordinal) (5 #f user-integrity-rule #f expression) (6 #f view-procedure #f expression))) @@ -33,10 +33,10 @@ (define catalog:coltab-name-pos 3) (define catalog:bastab-id-pos 4) (define catalog:integrity-rule-pos 5) -(define catalog:view-proc-pos 6) +;;(define catalog:view-proc-pos 6) (define columns:init-cols - '((1 #t column-number #f uint) + '((1 #t column-number #f ordinal) (2 #f primary-key? #f boolean) (3 #f column-name #f symbol) (4 #f column-integrity-rule #f expression) @@ -48,7 +48,7 @@ (define columns:domain-name-pos 5) (define domains:init-cols - '((1 #t domain-name #f atom) + '((1 #t domain-name #f symbol) (2 #f foreign-table #f atom) (3 #f domain-integrity-rule #f expression) (4 #f type-id #f type) @@ -57,50 +57,44 @@ (define domains:foreign-pos 2) (define domains:integrity-rule-pos 3) (define domains:type-id-pos 4) -(define domains:type-param-pos 5) +;;(define domains:type-param-pos 5) (define domains:init-data - `((atom #f - (lambda (x) (or (not x) (symbol? x) (number? x))) - atom - #f) - (type #f - #f ;type checked when openning - symbol - #f) - (base-id #f - (lambda (x) (or (symbol? x) (number? x))) - base-id - #f) - (uint #f - (lambda (x) - (and (number? x) - (integer? x) - (not (negative? x)))) - number - #f) - (number #f number? number #f) - (expression #f #f expression #f) + `((type #f symbol? symbol #f) + (ordinal #f (lambda (x) (and (integer? x) (positive? x))) number #f) (boolean #f boolean? boolean #f) + (expression #f #f expression #f) (symbol #f symbol? symbol #f) (string #f string? string #f) - (domain ,rdms:domains-name #f atom #f))) - -(define rdms:warn slib:warn) -(define rdms:error slib:error) + (atom #f (lambda (x) (or (not x) (symbol? x))) atom #f) ; (number? x) + (domain ,rdms:domains-name #f atom #f) + ;; Legacy types + (number #f number? number #f) + (base-id #f number? ordinal #f) + (uint #f (lambda (x) (and (integer? x) (not (negative? x)))) number #f) + )) +;@ (define (make-relational-system base) - (define basic - (lambda (name) - (let ((meth (base name))) - (cond ((not meth) (rdms:error 'make-relational-system - "essential method missing for:" name))) - meth))) + + (define (basic name) + (let ((meth (base name))) + (cond ((not meth) (slib:error 'make-relational-system + "essential method missing for:" name))) + meth)) (define (desc-row-type row) (let ((domain (assq (car (cddddr row)) domains:init-data))) (and domain (cadddr domain)))) + (define (itypes rows) + (map (lambda (row) + (let ((domrow (assq (car (cddddr row)) domains:init-data))) + (cond (domrow (cadddr domrow)) + (else (slib:error 'itypes "type not found for:" + (car (cddddr row))))))) + rows)) + (let ((make-base (base 'make-base)) (open-base (basic 'open-base)) (write-base (base 'write-base)) @@ -112,20 +106,14 @@ (base:open-table (basic 'open-table)) (base:kill-table (base 'kill-table)) (present? (basic 'present?)) - (base:ordered-for-each-key (basic 'ordered-for-each-key)) + (base:ordered-for-each-key (base 'ordered-for-each-key)) (base:for-each-primary-key (basic 'for-each-key)) (base:map-primary-key (basic 'map-key)) + (base:make-nexter (base 'make-nexter)) + (base:make-prever (base 'make-prever)) (base:catalog-id (basic 'catalog-id)) (cat:keyify-1 ((basic 'make-keyifier-1) - (desc-row-type (assv 1 catalog:init-cols)))) - (itypes - (lambda (rows) - (map (lambda (row) - (let ((domrow (assq (car (cddddr row)) domains:init-data))) - (cond (domrow (cadddr domrow)) - (else (rdms:error 'itypes "type not found for:" - (car (cddddr row))))))) - rows)))) + (desc-row-type (assv 1 catalog:init-cols))))) (define (init-tab lldb id descriptor rows) (let ((han (base:open-table lldb id 1 (itypes descriptor))) @@ -155,16 +143,15 @@ (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)) (slib: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))))) (cond - ((not lldb) (rdms:error 'make-base "failed.") #f) - ((not cattab) (rdms:error 'make-base "catalog missing.") - (close-base lldb) - #f) + ((not lldb) (slib:error 'make-base "failed.") #f) + ((not cattab) (slib:error 'make-base "catalog missing.") + (close-base lldb) + #f) (else (let ((desdes-id (base:make-table lldb 1 (itypes columns:init-cols))) (domdes-id (base:make-table lldb 1 (itypes columns:init-cols))) @@ -173,7 +160,7 @@ ) (cond ((not (and catdes-id domdes-id domtab-id desdes-id)) - (rdms:error 'create-database "make-table failed.") + (slib:error 'create-database "make-table failed.") (close-base lldb) #f) (else @@ -216,20 +203,35 @@ (define (init-database rdms:filename mutable lldb base:catalog base:domains rdms:catalog) - (define (write-database filename) - (let ((ans (write-base lldb filename))) - (and ans (set! rdms:filename filename)) - ans)) + (define write-database + (and mutable + (lambda (filename) + (let ((ans (write-base lldb filename))) + (and ans (set! rdms:filename filename)) + ans)))) - (define (sync-database) - (sync-base lldb)) + (define sync-database + (and mutable + (lambda () + (sync-base lldb)))) + + (define (solidify-database) + (cond ((sync-base lldb) + (set! mutable #f) + (set! sync-database #f) + (set! write-database #f) + (set! delete-table #f) + (set! create-table #f) + #t) + (else #f))) (define (close-database) - (close-base lldb) - (set! rdms:filename #f) - (set! base:catalog #f) - (set! base:domains #f) - (set! rdms:catalog #f)) + (define ans (close-base lldb)) + (cond (ans (set! rdms:filename #f) + (set! base:catalog #f) + (set! base:domains #f) + (set! rdms:catalog #f))) + ans) (define row-ref (lambda (row pos) (list-ref row (+ -2 pos)))) (define row-eval (lambda (row pos) @@ -239,9 +241,9 @@ (define (open-table table-name writable) (define cat:row (cat:get-row base:catalog table-name)) (cond ((not cat:row) - (rdms:error "can't open-table:" table-name)) + (slib:error "can't open-table:" table-name)) ((and writable (not mutable)) - (rdms:error "can't open-table for writing:" table-name))) + (slib:error "can't open-table for writing:" table-name))) (let ((column-limit (row-ref cat:row catalog:column-limit-pos)) (desc-table (base:open-table @@ -265,8 +267,8 @@ (list->key #f) (key->list #f)) - (if (not desc-table) - (rdms:error "descriptor table doesn't exist for:" table-name)) + (or desc-table + (slib:error "descriptor table doesn't exist for:" table-name)) (do ((ci column-limit (+ -1 ci))) ((zero? ci)) (let* ((des:row (des:get-row desc-table ci)) @@ -301,24 +303,24 @@ (p? (and tab (tab 'get 1)))) (cond ((not tab) - (rdms:error "foreign key table missing for:" + (slib:error "foreign key table missing for:" foreign-name)) ((not (= (tab 'primary-limit) 1)) - (rdms:error "foreign key table wrong type:" + (slib:error "foreign key table wrong type:" foreign-name)) (else p?))))) column-foreign-check-list)))) (else - (rdms:error "missing domain for column:" ci column-name))) + (slib:error "missing domain for column:" ci column-name))) (cond ((row-ref des:row columns:primary?-pos) (set! primary-limit (max primary-limit ci)) (cond ((base:supported-key-type? (car column-type-list))) - (else (rdms:error "key type not supported by base tables:" + (else (slib:error "key type not supported by base tables:" (car column-type-list))))) ((base:supported-type? (car column-type-list))) - (else (rdms:error "type not supported by base tables:" + (else (slib:error "type not supported by base tables:" (car column-type-list)))))) (set! base-table (base:open-table lldb (row-ref cat:row catalog:bastab-id-pos) @@ -332,7 +334,7 @@ (lambda (name proc) (set! export-alist (cons (cons name proc) export-alist)))) - (ckey:retrieve ;ckey gets whole row (assumes exists) + (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))))) @@ -346,7 +348,7 @@ (lambda (mkeys) (define mlim (length mkeys)) (cond ((> mlim primary-limit) - (rdms:error "too many keys:" mkeys)) + (slib:error "too many keys:" mkeys)) ((= mlim primary-limit) mkeys) (else (append mkeys @@ -371,10 +373,20 @@ (let ((r (if (= primary-limit column-limit) key->list ckey:retrieve))) (lambda (proc . mkeys) - (base:ordered-for-each-key + (base:for-each-primary-key base-table (lambda (ckey) (proc (r ckey))) primary-limit column-type-list (norm-mkeys mkeys))))) + (and base:ordered-for-each-key + (export-method + 'for-each-row-in-order + (let ((r (if (= primary-limit column-limit) key->list + ckey:retrieve))) + (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) (letrec @@ -394,36 +406,35 @@ ((3) (lambda (row) (list->key (list (car row) (cadr row) (caddr row))))) - ((4) (lambda (row) - (list->key - (list (car row) (cadr row) - (caddr row) (cadddr row))))) - (else (rdms:error 'combine-primary-keys - "bad number of primary keys" - primary-limit)))))) + (else (lambda (row) + (do ((rw row (cdr rw)) + (nrw '() (cons (car rw) nrw)) + (pl (+ -1 primary-limit) (+ -1 pl))) + ((negative? pl) + (list->key (reverse nrw)))))))))) (uir (row-eval cat:row catalog:integrity-rule-pos)) (check-rules (lambda (row) (if (= column-limit (length row)) #t - (rdms:error "bad row length:" row)) + (slib:error "bad row length:" row)) (for-each (lambda (cir dir value column-name column-domain foreign) (cond ((and dir (not (dir value))) - (rdms:error "violated domain integrity rule:" + (slib:error "violated domain integrity rule:" table-name column-name column-domain value)) ((and cir (not (cir value))) - (rdms:error "violated column integrity rule:" + (slib:error "violated column integrity rule:" table-name column-name value)) ((and foreign (not (foreign value))) - (rdms:error "foreign key missing:" + (slib:error "foreign key missing:" table-name column-name value)))) cirs dirs row column-name-alist column-domain-list column-foreign-check-list) (cond ((and uir (not (uir row))) - (rdms:error "violated user integrity rule:" + (slib:error "violated user integrity rule:" row))))) (putter ((basic 'make-putter) primary-limit column-type-list)) @@ -432,7 +443,7 @@ (check-rules row) (let ((ckey (combine-primary-keys row))) (if (present? base-table ckey) - (rdms:error 'row:insert "row present:" row)) + (slib:error 'row:insert "row present:" row)) (putter base-table ckey (list-tail row primary-limit))))) (row:update @@ -485,21 +496,31 @@ ;;(print 'translate-column column column-name-alist) (let ((colp (assq column column-name-alist))) (cond (colp (cdr colp)) - ((and (number? column) - (integer? column) + ((and (integer? column) (<= 1 column column-limit)) column) - (else (rdms:error "column not in table:" + (else (slib:error "column not in table:" column table-name))))))) (lambda args (cond - ((null? args) - #f) + ((null? args) #f) + ((and base:make-nexter (eq? 'isam-next (car args))) + (base:make-nexter + base-table primary-limit column-type-list + (if (null? (cdr args)) + primary-limit + (translate-column (cadr args))))) + ((and base:make-prever (eq? 'isam-prev (car args))) + (base:make-prever + base-table primary-limit column-type-list + (if (null? (cdr args)) + primary-limit + (translate-column (cadr args))))) ((null? (cdr args)) (let ((pp (assq (car args) export-alist))) (and pp (cdr pp)))) ((not (null? (cddr args))) - (rdms:error "too many arguments to methods:" args)) + (slib:error "too many arguments to methods:" args)) (else (let ((ci (translate-column (cadr args)))) (cond @@ -514,36 +535,51 @@ (lambda mkeys (base:map-primary-key base-table - (lambda (ckey) (key-extractor ckey)) + key-extractor primary-limit column-type-list (norm-mkeys mkeys))))) (else #f))) (else - (let ((index (- ci (+ 1 primary-limit)))) - (case (car args) - ((get) (lambda keys - (let ((row (base:get base-table - (list->key keys)))) - (and row (list-ref row index))))) - ((get*) (lambda mkeys - (base:map-primary-key - base-table - (lambda (ckey) - (list-ref (base:get base-table ckey) - index)) - primary-limit column-type-list - (norm-mkeys mkeys)))) - (else #f))))))))))))) + (let ((index (- ci primary-limit 1)) + (get-1 (base 'make-getter-1))) + (cond + (get-1 + (set! get-1 + (get-1 primary-limit column-type-list ci)) + (case (car args) + ((get) (lambda keys + (get-1 base-table (list->key keys)))) + ((get*) (lambda mkeys + (base:map-primary-key + base-table + (lambda (ckey) (get-1 base-table ckey)) + primary-limit column-type-list + (norm-mkeys mkeys)))))) + (else + (case (car args) + ((get) (lambda keys + (let ((row (base:get base-table + (list->key keys)))) + (and row (list-ref row index))))) + ((get*) (lambda mkeys + (base:map-primary-key + base-table + (lambda (ckey) + (list-ref (base:get base-table ckey) + index)) + primary-limit column-type-list + (norm-mkeys mkeys)))) + (else #f))))))))))))))) (define create-table (and mutable (lambda (table-name . desc) - (if (not rdms:catalog) - (set! rdms:catalog (open-table rdms:catalog-name #t)) #f) + (or rdms:catalog + (set! rdms:catalog (open-table rdms:catalog-name #t))) (cond ((table-exists? table-name) - (rdms:error "table already exists:" table-name) #f) + (slib:error "table already exists:" table-name) #f) ((null? desc) (let ((colt-id (base:make-table lldb 1 (itypes columns:init-cols)))) @@ -576,11 +612,11 @@ ((coltable 'get* 'column-number)) ((coltable 'get* 'primary-key?)) ((coltable 'get* 'domain-name))) - (cond (colerr (rdms:error "some column lacks a number.") #f) + (cond (colerr (slib:error "some column lacks a number.") #f) ((or (< prilimit 1) (and (> prilimit 4) (not (= prilimit colimit)))) - (rdms:error "unreasonable number of primary keys:" + (slib:error "unreasonable number of primary keys:" prilimit)) (else ((rdms:catalog 'row:insert) @@ -588,8 +624,8 @@ (base:make-table lldb prilimit types) #f #f)) (open-table table-name #t))))) (else - (rdms:error "table descriptor not found for:" desc) #f)))) - (else (rdms:error 'create-table "too many args:" + (slib:error "table descriptor not found for:" desc) #f)))) + (else (slib:error 'create-table "too many args:" (cons table-name desc)) #f))))) @@ -599,8 +635,7 @@ (define delete-table (and mutable (lambda (table-name) - ;;(if (not rdms:catalog) - ;;(set! rdms:catalog (open-table rdms:catalog-name #t)) #f) + ;;(or rdms:catalog (set! rdms:catalog (open-table rdms:catalog-name #t))) (let* ((table (open-table table-name #t)) (row ((rdms:catalog 'row:remove) table-name))) (and row (base:kill-table @@ -615,10 +650,12 @@ ((close-database) close-database) ((write-database) write-database) ((sync-database) sync-database) + ((solidify-database) solidify-database) ((open-table) open-table) ((delete-table) delete-table) ((create-table) create-table) ((table-exists?) table-exists?) + ((filename) rdms:filename) (else #f))) ) (lambda (operation-name) |