Import Upstream version 2a6upstream/2a6

1 files changed, 598 insertions, 0 deletions

diff --git a/rdms.scm b/rdms.scm
new file mode 100644
index 0000000..0fd4a2c
--- /dev/null
+++ b/rdms.scm
@@ -0,0 +1,598 @@
+;;; "rdms.scm" rewrite 6 - the saga continues
+; Copyright 1994 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.
+;
+;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
+;this software will be error-free, and I am under no obligation to
+;provide any services, by way of maintenance, update, or otherwise.
+;
+;3.  In conjunction with products arising from the use of this
+;material, there shall be no use of my name in any advertising,
+;promotional, or sales literature without prior written consent in
+;each case.
+
+(define rdms:catalog-name '*catalog-data*)
+(define rdms:domains-name '*domains-data*)
+(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)
+    (5 #f user-integrity-rule	#f expression)
+    (6 #f view-procedure	#f expression)))
+
+(define catalog:column-limit-pos 2)
+(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 columns:init-cols
+  '((1 #t column-number		#f uint)
+    (2 #f primary-key?		#f boolean)
+    (3 #f column-name		#f symbol)
+    (4 #f column-integrity-rule	#f expression)
+    (5 #f domain-name		#f domain)))
+
+(define columns:primary?-pos 2)
+(define columns:name-pos 3)
+(define columns:integrity-rule-pos 4)
+(define columns:domain-name-pos 5)
+
+(define domains:init-cols
+  '((1 #t domain-name		#f atom)
+    (2 #f foreign-table		#f atom)
+    (3 #f domain-integrity-rule	#f expression)
+    (4 #f type-id		#f type)
+    (5 #f type-param		#f expression)))
+
+(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: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))))
+          integer
+          #f)
+    (expression #f #f expression #f)
+    (boolean #f boolean? boolean #f)
+    (symbol #f symbol? symbol #f)
+    (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:error slib:error)
+
+(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 (desc-row-type row)
+    (let ((domain (assq (car (cddddr row)) domains:init-data)))
+      (and domain (cadddr domain))))
+
+  (let ((make-base (base 'make-base))
+	(open-base (basic 'open-base))
+	(write-base (base 'write-base))
+	(sync-base (base 'sync-base))
+	(close-base (basic 'close-base))
+	(base:supported-type? (basic 'supported-type?))
+	(base:supported-key-type? (basic 'supported-key-type?))
+	(base:make-table (base 'make-table))
+	(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:for-each-primary-key (basic 'for-each-key))
+	(base:map-primary-key (basic 'map-key))
+	(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))))
+
+    (define (init-tab lldb id descriptor rows)
+      (let ((han (base:open-table lldb id 1 (itypes descriptor)))
+	    (keyify-1
+	     ((base 'make-keyifier-1) (desc-row-type (assv 1 descriptor))))
+	    (putter ((basic 'make-putter) 1 (itypes descriptor))))
+	(for-each (lambda (row) (putter han (keyify-1 (car row)) (cdr row)))
+		  rows)))
+
+    (define cat:get-row
+      (let ((cat:getter ((basic 'make-getter) 1 (itypes catalog:init-cols))))
+	(lambda (bastab key)
+	  (cat:getter bastab (cat:keyify-1 key)))))
+
+    (define dom:get-row
+      (let ((dom:getter ((basic 'make-getter) 1 (itypes domains:init-cols)))
+	    (dom:keyify-1 ((basic 'make-keyifier-1)
+			   (desc-row-type (assv 1 domains:init-cols)))))
+	(lambda (bastab key)
+	  (dom:getter bastab (dom:keyify-1 key)))))
+
+    (define des:get-row
+      (let ((des:getter ((basic 'make-getter) 1 (itypes columns:init-cols)))
+	    (des:keyify-1 ((basic 'make-keyifier-1)
+			   (desc-row-type (assv 1 columns:init-cols)))))
+	(lambda (bastab key)
+	  (des:getter bastab (des:keyify-1 key)))))
+
+    (define (create-database 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)))))
+	(cond
+	 ((not lldb) (rdms:error 'make-base "failed.") #f)
+	 ((not cattab) (rdms: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)))
+		(catdes-id (base:make-table lldb 1 (itypes columns:init-cols)))
+		(domtab-id (base:make-table lldb 1 (itypes domains:init-cols)))
+		)
+	    (cond
+	     ((not (and catdes-id domdes-id domtab-id desdes-id))
+	      (rdms:error 'create-database "make-table failed.")
+	      (close-base lldb)
+	      #f)
+	     (else
+	      (init-tab lldb desdes-id columns:init-cols columns:init-cols)
+	      (init-tab lldb domdes-id columns:init-cols domains:init-cols)
+	      (init-tab lldb catdes-id columns:init-cols catalog:init-cols)
+	      (init-tab lldb domtab-id domains:init-cols domains:init-data)
+	      (init-tab
+	       lldb base:catalog-id catalog:init-cols
+	       `((*catalog-desc* 5 ,rdms:columns-name ,catdes-id #f #f)
+		 (*domains-desc* 5 ,rdms:columns-name ,domdes-id #f #f)
+		 (,rdms:catalog-name 6 *catalog-desc* ,base:catalog-id #f #f)
+		 (,rdms:domains-name 5 *domains-desc* ,domtab-id #f #f)
+		 (,rdms:columns-name 5 ,rdms:columns-name ,desdes-id #f #f)))
+	      (init-database
+	       filename #t lldb cattab
+	       (base:open-table lldb domtab-id 1 (itypes domains:init-cols))
+	       #f))))))))
+
+    (define (base:catalog->domains lldb base:catalog)
+      (let ((cat:row (cat:get-row base:catalog rdms:domains-name)))
+	(and cat:row
+	     (base:open-table lldb
+			      (list-ref cat:row (+ -2 catalog:bastab-id-pos))
+			      1 (itypes domains:init-cols)))))
+
+    (define (open-database filename mutable)
+      (let* ((lldb (open-base filename mutable))
+	     (base:catalog
+	      (and lldb (base:open-table lldb base:catalog-id
+					 1 (itypes catalog:init-cols))))
+	     (base:domains
+	      (and base:catalog (base:catalog->domains lldb base:catalog))))
+	(cond
+	 ((not lldb) #f)
+	 ((not base:domains) (close-base lldb) #f)
+	 (else (init-database
+		filename mutable lldb base:catalog base:domains #f)))))
+
+    (define (init-database rdms:filename mutable lldb
+			   base:catalog base:domains rdms:catalog)
+
+      (define (write-database filename)
+	(write-base lldb filename)
+	(set! rdms:filename filename))
+
+      (define (close-database)
+	(close-base lldb)
+	(set! rdms:filename #f)
+	(set! base:catalog #f)
+	(set! base:domains #f)
+	(set! rdms:catalog #f))
+
+      (define row-ref (lambda (row pos) (list-ref row (+ -2 pos))))
+      (define row-eval (lambda (row pos)
+			 (let ((ans (list-ref row (+ -2 pos))))
+			   (and ans (slib:eval ans)))))
+
+      (define (open-table table-name writable)
+	(define cat:row (cat:get-row base:catalog table-name))
+	(cond ((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
+	       (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-domain-list '())
+	      (column-type-list '())
+	      (export-alist '())
+	      (cirs '())
+	      (dirs '())
+	      (list->key #f)
+	      (key->list #f))
+
+	  (if (not desc-table)
+	      (rdms: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)))
+			   (cond
+			    ((or (not foreign-name)
+				 (eq? foreign-name table-name)) #f)
+			    (else
+			     (let* ((tab (open-table foreign-name #f))
+				    (p? (and tab (tab 'get 1))))
+			       (cond
+				((not tab)
+				 (rdms:error "foreign key table missing for:"
+					     foreign-name))
+				((not (= (tab 'primary-limit) 1))
+				 (rdms:error "foreign key table wrong type:"
+					     foreign-name))
+				(else p?))))))
+			 column-foreign-list))))
+	       (else
+		(rdms: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:"
+				   (car column-type-list)))))
+	       ((base:supported-type? (car column-type-list)))
+	       (else (rdms: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))
+	  (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))))))
+	    (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) (base:ordered-for-each-key
+			       base-table (lambda (ckey) (proc (r ckey)))))))
+	    (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)))))
+			((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))))))
+		   (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))
+		      (for-each
+		       (lambda (cir dir value column-name column-domain
+				    foreign)
+			 (cond
+			  ((and dir (not (dir value)))
+			   (rdms:error "violated domain integrity rule:"
+				       table-name column-name
+				       column-domain value))
+			  ((and cir (not (cir value)))
+			   (rdms:error "violated column integrity rule:"
+				       table-name column-name value))
+			  ((and foreign (not (foreign value)))
+			   (rdms:error "foreign key missing:"
+				       table-name column-name value))))
+		       cirs dirs row column-name-alist column-domain-list
+		       column-foreign-list)
+		      (cond ((and uir (not (uir row)))
+			     (rdms: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)
+			    (rdms: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))
+		       (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*
+			       (generalize-to-table
+				(lambda (ckey) (base:delete base-table ckey))))
+		(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)
+		     ;;(print 'translate-column column column-name-alist)
+		     (let ((colp (assq column column-name-alist)))
+		       (cond (colp (cdr colp))
+			     ((and (number? column)
+				   (integer? column)
+				   (<= 1 column column-limit))
+			      column)
+			     (else (rdms:error "column not in table:"
+					       column table-name)))))))
+	      (lambda args
+		(cond
+		 ((null? args) #f)
+		 ((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))
+		 (else
+		  (let ((ci (translate-column (cadr args))))
+		    (cond
+		     ((<= ci primary-limit) ;primary-key?
+		      (let ((key-extractor
+			     ((base 'make-key-extractor)
+			      primary-limit column-type-list ci)))
+			(case (car args)
+			  ((get) (lambda keys
+				   (and (present? base-table (list->key keys))
+					(list-ref keys (+ -1 ci)))))
+			  ((get*) (lambda ()
+				    (base:map-primary-key
+				     base-table
+				     (lambda (ckey) (key-extractor ckey)))))
+			  (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 ()
+				    (base:map-primary-key
+				     base-table
+				     (lambda (ckey)
+				       (list-ref (base:get base-table ckey)
+						 index)))))
+			  (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)
+	   (cond
+	    ((table-exists? table-name)
+	     (rdms:error "table already exists:" table-name) #f)
+	    ((null? desc)
+	     (let ((colt-id
+		    (base:make-table lldb 1 (itypes columns:init-cols))))
+	       ((rdms:catalog 'row:insert)
+		(list table-name
+		      (length columns:init-cols)
+		      ((rdms:catalog 'get 'coltab-name)
+		       rdms:columns-name)
+		      colt-id
+		      #f
+		      #f)))
+	     (open-table table-name #t))
+	    ((null? (cdr desc))
+	     (set! desc (car desc))
+	     (let ((colt-id ((rdms:catalog 'get 'bastab-id) desc)))
+	       (cond
+		(colt-id
+		 (let ((coltable (open-table desc #f))
+		       (types '())
+		       (prilimit 0)
+		       (colimit 0)
+		       (colerr #f))
+		   (for-each (lambda (n p d)
+			       (if (number? n) (set! colimit (max colimit n))
+				   (set! colerr #t))
+			       (if p (set! prilimit (+ 1 prilimit)) #f)
+			       (set! types
+				     (cons (dom:get-row base:domains d)
+					   types)))
+			     ((coltable 'get* 'column-number))
+			     ((coltable 'get* 'primary-key?))
+			     ((coltable 'get* 'domain-name)))
+		   (cond (colerr (rdms:error "some column lacks a number.") #f)
+			 ((or (< prilimit 1)
+			      (and (> prilimit 4)
+				   (not (= prilimit colimit))))
+			  (rdms:error "unreasonable number of primary keys:"
+				      prilimit))
+			 (else
+			  ((rdms:catalog 'row:insert)
+			   (list table-name colimit desc
+				 (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:"
+			      (cons table-name desc))
+		  #f)))))
+
+      (define (table-exists? table-name)
+	(present? base:catalog (cat:keyify-1 table-name)))
+
+      (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)))
+		 (and row (base:kill-table
+			   lldb
+			   (list-ref row (+ -1 catalog:bastab-id-pos))
+			   (table 'primary-limit)
+			   (table 'column-type-list))
+		      row)))))
+
+      (lambda (operation-name)
+	(case operation-name
+	  ((close-database) close-database)
+	  ((write-database) write-database)
+	  ((open-table) open-table)
+	  ((delete-table) delete-table)
+	  ((create-table) create-table)
+	  ((table-exists?) table-exists?)
+	  (else #f)))
+      )
+    (lambda (operation-name)
+      (case operation-name
+	((create-database) create-database)
+	((open-database) open-database)
+	(else #f)))
+    ))