summaryrefslogtreecommitdiffstats
path: root/rdms.scm
diff options
context:
space:
mode:
authorBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:29 -0800
committerBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:29 -0800
commit8466d8cfa486fb30d1755c4261b781135083787b (patch)
treec8c12c67246f543c3cc4f64d1c07e003cb1d45ae /rdms.scm
parent87b82b5822ca54228cfa6df29be3ad9d4bc47d16 (diff)
downloadslib-8466d8cfa486fb30d1755c4261b781135083787b.tar.gz
slib-8466d8cfa486fb30d1755c4261b781135083787b.zip
Import Upstream version 3a1upstream/3a1
Diffstat (limited to 'rdms.scm')
-rw-r--r--rdms.scm287
1 files changed, 162 insertions, 125 deletions
diff --git a/rdms.scm b/rdms.scm
index 8c8388f..eb74494 100644
--- a/rdms.scm
+++ b/rdms.scm
@@ -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)