diff options
Diffstat (limited to 'rdms.scm')
| -rw-r--r-- | rdms.scm | 650 |
1 files changed, 327 insertions, 323 deletions
@@ -242,335 +242,339 @@ (define (open-table table-name writable) (define cat:row (cat:get-row base:catalog table-name)) - (cond ((not cat:row) - (slib:error "can't open-table:" table-name)) - ((and writable (not mutable)) - (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 - lldb - (row-ref (cat:get-row - base:catalog - (row-ref cat:row catalog:coltab-name-pos)) - catalog:bastab-id-pos) - 1 (itypes columns:init-cols))) - (base-table #f) - (base:get #f) - (primary-limit 1) - (column-name-alist '()) - (column-foreign-list '()) - (column-foreign-check-list '()) - (column-domain-list '()) - (column-type-list '()) - (export-alist '()) - (cirs '()) - (dirs '()) - (list->key #f) - (key->list #f)) - - (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)) - (column-name (row-ref des:row columns:name-pos)) - (column-domain (row-ref des:row columns:domain-name-pos))) - (set! cirs - (cons (row-eval des:row columns:integrity-rule-pos) cirs)) - (set! column-name-alist - (cons (cons column-name ci) column-name-alist)) - (cond - (column-domain - (let ((dom:row (dom:get-row base:domains column-domain))) - (set! dirs - (cons (row-eval dom:row domains:integrity-rule-pos) - dirs)) - (set! column-type-list - (cons (row-ref dom:row domains:type-id-pos) - column-type-list)) - (set! column-domain-list - (cons column-domain column-domain-list)) - (set! column-foreign-list - (cons (let ((foreign-name - (row-ref dom:row domains:foreign-pos))) - (and (not (eq? foreign-name table-name)) - foreign-name)) - column-foreign-list)) - (set! column-foreign-check-list - (cons - (let ((foreign-name (car column-foreign-list))) - (and foreign-name - (let* ((tab (open-table foreign-name #f)) - (p? (and tab (tab 'get 1)))) - (cond - ((not tab) - (slib:error "foreign key table missing for:" - foreign-name)) - ((not (= (tab 'primary-limit) 1)) - (slib:error "foreign key table wrong type:" - foreign-name)) - (else p?))))) - column-foreign-check-list)))) - (else - (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 (slib:error "key type not supported by base tables:" - (car column-type-list))))) - ((base:supported-type? (car column-type-list))) - (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) - primary-limit column-type-list)) - (set! base:get ((basic 'make-getter) primary-limit column-type-list)) - (set! list->key - ((basic 'make-list-keyifier) primary-limit column-type-list)) - (set! key->list - ((basic 'make-key->list) primary-limit column-type-list)) - (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 - primary-limit column-type-list - (norm-mkeys mkeys))))) - (norm-mkeys - (lambda (mkeys) - (define mlim (length mkeys)) - (cond ((> mlim primary-limit) - (slib:error "too many keys:" mkeys)) - ((= mlim primary-limit) mkeys) - (else - (append mkeys - (do ((k (- primary-limit mlim) (+ -1 k)) - (result '() (cons #f result))) - ((<= k 0) result)))))))) - (export-method - 'row:retrieve - (if (= primary-limit column-limit) - (lambda keys - (let ((ckey (list->key keys))) - (and (present? base-table ckey) keys))) - (lambda keys - (let ((vals (base:get base-table (list->key keys)))) - (and vals (append keys vals)))))) - (export-method 'row:retrieve* - (accumulate-over-table - (if (= primary-limit column-limit) key->list - ckey:retrieve))) - (export-method - 'for-each-row - (let ((r (if (= primary-limit column-limit) key->list - ckey:retrieve))) - (lambda (proc . mkeys) - (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 - ((combine-primary-keys - (cond - ((and (= primary-limit column-limit) - (> primary-limit 0)) - list->key) - ((eq? list->key car) list->key) - (else - (case primary-limit - ((1) (let ((keyify-1 ((base 'make-keyifier-1) - (car column-type-list)))) - (lambda (row) (keyify-1 (car row))))) - ((2) (lambda (row) - (list->key (list (car row) (cadr row))))) - ((3) (lambda (row) - (list->key (list (car row) (cadr row) - (caddr row))))) - (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 - (slib:error "bad row length:" row)) - (for-each - (lambda (cir dir value column-name column-domain - foreign) - (cond - ((and dir (not (dir value))) - (slib:error "violated domain integrity rule:" - table-name column-name - column-domain value)) - ((and cir (not (cir value))) - (slib:error "violated column integrity rule:" - table-name column-name value)) - ((and foreign (not (foreign value))) - (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))) - (slib:error "violated user integrity rule:" - row))))) - (putter - ((basic 'make-putter) primary-limit column-type-list)) - (row:insert - (lambda (row) - (check-rules row) - (let ((ckey (combine-primary-keys row))) - (if (present? base-table ckey) - (slib:error 'row:insert "row present:" row)) - (putter base-table ckey - (list-tail row primary-limit))))) - (row:update - (lambda (row) - (check-rules row) - (putter base-table (combine-primary-keys row) - (list-tail row primary-limit))))) - - (export-method 'row:insert row:insert) - (export-method 'row:insert* - (lambda (rows) (for-each row:insert rows))) - (export-method 'row:update row:update) - (export-method 'row:update* - (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)) - r)))) - (export-method 'row:remove - (lambda keys - (let ((ckey (list->key keys))) - (and (present? base-table ckey) - (ckey:remove ckey))))) - (export-method 'row:delete - (lambda keys - (base:delete base-table (list->key keys)))) - (export-method 'row:remove* - (accumulate-over-table ckey:remove)) - (export-method 'row:delete* - (lambda 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) - (set! export-alist #f)))))) - - (export-method 'column-names (map car column-name-alist)) - (export-method 'column-foreigns column-foreign-list) - (export-method 'column-domains column-domain-list) - (export-method 'column-types column-type-list) - (export-method 'primary-limit primary-limit) - - (let ((translate-column - (lambda (column) - (let ((colp (assq column column-name-alist))) - (cond (colp (cdr colp)) - ((and (integer? column) - (<= 1 column column-limit)) - column) - (else (slib:error "column not in table:" - column table-name))))))) - (lambda args + (cond + ((not cat:row) + (slib:warn "can't open-table:" table-name) + #f) + ((and writable (not mutable)) + (slib:warn "can't open-table for writing:" table-name) + #f) + (else + (let ((column-limit (row-ref cat:row catalog:column-limit-pos)) + (desc-table + (base:open-table + lldb + (row-ref (cat:get-row + base:catalog + (row-ref cat:row catalog:coltab-name-pos)) + catalog:bastab-id-pos) + 1 (itypes columns:init-cols))) + (base-table #f) + (base:get #f) + (primary-limit 1) + (column-name-alist '()) + (column-foreign-list '()) + (column-foreign-check-list '()) + (column-domain-list '()) + (column-type-list '()) + (export-alist '()) + (cirs '()) + (dirs '()) + (list->key #f) + (key->list #f)) + + (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)) + (column-name (row-ref des:row columns:name-pos)) + (column-domain (row-ref des:row columns:domain-name-pos))) + (set! cirs + (cons (row-eval des:row columns:integrity-rule-pos) cirs)) + (set! column-name-alist + (cons (cons column-name ci) column-name-alist)) (cond - ((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))) - (slib:error "too many arguments to methods:" args)) + (column-domain + (let ((dom:row (dom:get-row base:domains column-domain))) + (set! dirs + (cons (row-eval dom:row domains:integrity-rule-pos) + dirs)) + (set! column-type-list + (cons (row-ref dom:row domains:type-id-pos) + column-type-list)) + (set! column-domain-list + (cons column-domain column-domain-list)) + (set! column-foreign-list + (cons (let ((foreign-name + (row-ref dom:row domains:foreign-pos))) + (and (not (eq? foreign-name table-name)) + foreign-name)) + column-foreign-list)) + (set! column-foreign-check-list + (cons + (let ((foreign-name (car column-foreign-list))) + (and foreign-name + (let* ((tab (open-table foreign-name #f)) + (p? (and tab (tab 'get 1)))) + (cond + ((not tab) + (slib:error "foreign key table missing for:" + foreign-name)) + ((not (= (tab 'primary-limit) 1)) + (slib:error "foreign key table wrong type:" + foreign-name)) + (else p?))))) + column-foreign-check-list)))) (else - (let ((ci (translate-column (cadr args)))) - (cond - ((<= ci primary-limit) ;primary-key? - (case (car args) - ((get) (lambda gkeys - (and (present? base-table (list->key gkeys)) - (list-ref gkeys (+ -1 ci))))) - ((get*) (let ((key-extractor - ((base 'make-key-extractor) - primary-limit column-type-list ci))) - (lambda mkeys - (base:map-primary-key - base-table - key-extractor - primary-limit column-type-list - (norm-mkeys mkeys))))) - (else #f))) - (else - (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)) + (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 (slib:error "key type not supported by base tables:" + (car column-type-list))))) + ((base:supported-type? (car column-type-list))) + (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) + primary-limit column-type-list)) + (set! base:get ((basic 'make-getter) primary-limit column-type-list)) + (set! list->key + ((basic 'make-list-keyifier) primary-limit column-type-list)) + (set! key->list + ((basic 'make-key->list) primary-limit column-type-list)) + (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 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 + (norm-mkeys mkeys))))) + (norm-mkeys + (lambda (mkeys) + (define mlim (length mkeys)) + (cond ((> mlim primary-limit) + (slib:error "too many keys:" mkeys)) + ((= mlim primary-limit) mkeys) + (else + (append mkeys + (do ((k (- primary-limit mlim) (+ -1 k)) + (result '() (cons #f result))) + ((<= k 0) result)))))))) + (export-method + 'row:retrieve + (if (= primary-limit column-limit) + (lambda keys + (let ((ckey (list->key keys))) + (and (present? base-table ckey) keys))) + (lambda keys + (let ((vals (base:get base-table (list->key keys)))) + (and vals (append keys vals)))))) + (export-method 'row:retrieve* + (accumulate-over-table + (if (= primary-limit column-limit) key->list + ckey:retrieve))) + (export-method + 'for-each-row + (let ((r (if (= primary-limit column-limit) key->list + ckey:retrieve))) + (lambda (proc . mkeys) + (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 + ((combine-primary-keys + (cond + ((and (= primary-limit column-limit) + (> primary-limit 0)) + list->key) + ((eq? list->key car) list->key) + (else + (case primary-limit + ((1) (let ((keyify-1 ((base 'make-keyifier-1) + (car column-type-list)))) + (lambda (row) (keyify-1 (car row))))) + ((2) (lambda (row) + (list->key (list (car row) (cadr row))))) + ((3) (lambda (row) + (list->key (list (car row) (cadr row) + (caddr row))))) + (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 + (slib:error "bad row length:" row)) + (for-each + (lambda (cir dir value column-name column-domain + foreign) + (cond + ((and dir (not (dir value))) + (slib:error "violated domain integrity rule:" + table-name column-name + column-domain value)) + ((and cir (not (cir value))) + (slib:error "violated column integrity rule:" + table-name column-name value)) + ((and foreign (not (foreign value))) + (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))) + (slib:error "violated user integrity rule:" + row))))) + (putter + ((basic 'make-putter) primary-limit column-type-list)) + (row:insert + (lambda (row) + (check-rules row) + (let ((ckey (combine-primary-keys row))) + (if (present? base-table ckey) + (slib:error 'row:insert "row present:" row)) + (putter base-table ckey + (list-tail row primary-limit))))) + (row:update + (lambda (row) + (check-rules row) + (putter base-table (combine-primary-keys row) + (list-tail row primary-limit))))) + + (export-method 'row:insert row:insert) + (export-method 'row:insert* + (lambda (rows) (for-each row:insert rows))) + (export-method 'row:update row:update) + (export-method 'row:update* + (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)) + r)))) + (export-method 'row:remove + (lambda keys + (let ((ckey (list->key keys))) + (and (present? base-table ckey) + (ckey:remove ckey))))) + (export-method 'row:delete + (lambda keys + (base:delete base-table (list->key keys)))) + (export-method 'row:remove* + (accumulate-over-table ckey:remove)) + (export-method 'row:delete* + (lambda 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) + (set! export-alist #f)))))) + + (export-method 'column-names (map car column-name-alist)) + (export-method 'column-foreigns column-foreign-list) + (export-method 'column-domains column-domain-list) + (export-method 'column-types column-type-list) + (export-method 'primary-limit primary-limit) + + (let ((translate-column + (lambda (column) + (let ((colp (assq column column-name-alist))) + (cond (colp (cdr colp)) + ((and (integer? column) + (<= 1 column column-limit)) + column) + (else (slib:error "column not in table:" + column table-name))))))) + (lambda args + (cond + ((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))) + (slib:error "too many arguments to methods:" args)) + (else + (let ((ci (translate-column (cadr args)))) + (cond + ((<= ci primary-limit) ;primary-key? + (case (car args) + ((get) (lambda gkeys + (and (present? base-table (list->key gkeys)) + (list-ref gkeys (+ -1 ci))))) + ((get*) (let ((key-extractor + ((base 'make-key-extractor) + primary-limit column-type-list ci))) + (lambda mkeys (base:map-primary-key base-table - (lambda (ckey) - (list-ref (base:get base-table ckey) - index)) + key-extractor primary-limit column-type-list - (norm-mkeys mkeys)))) - (else #f))))))))))))))) + (norm-mkeys mkeys))))) + (else #f))) + (else + (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 |