Import Upstream version 3a1upstream/3a1

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)