From 87b82b5822ca54228cfa6df29be3ad9d4bc47d16 Mon Sep 17 00:00:00 2001
From: Bryan Newbold <bnewbold@robocracy.org>
Date: Mon, 20 Feb 2017 00:05:28 -0800
Subject: Import Upstream version 2d2

---
 rdms.scm | 41 +++++++++++++++++++++++++++--------------
 1 file changed, 27 insertions(+), 14 deletions(-)

(limited to 'rdms.scm')

diff --git a/rdms.scm b/rdms.scm
index e0dbd3c..8c8388f 100644
--- a/rdms.scm
+++ b/rdms.scm
@@ -1,9 +1,9 @@
 ;;; "rdms.scm" rewrite 6 - the saga continues
-; Copyright 1994, 1995, 1997 Aubrey Jaffer
+; Copyright 1994, 1995, 1997, 2000 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.
+;Permission to copy this software, to modify it, to redistribute it,
+;to distribute modified versions, 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.
@@ -77,7 +77,7 @@
             (and (number? x)
                  (integer? x)
                  (not (negative? x))))
-          integer
+          number
           #f)
     (number #f number? number #f)
     (expression #f #f expression #f)
@@ -155,8 +155,8 @@
 	  (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))
+	     ;;(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)))))
@@ -221,6 +221,9 @@
 	  (and ans (set! rdms:filename filename))
 	  ans))
 
+      (define (sync-database)
+	(sync-base lldb))
+
       (define (close-database)
 	(close-base lldb)
 	(set! rdms:filename #f)
@@ -336,7 +339,9 @@
 		   (accumulate-over-table
 		    (lambda (operation)
 		      (lambda mkeys (base:map-primary-key
-				     base-table operation (norm-mkeys mkeys)))))
+				     base-table operation
+				     primary-limit column-type-list
+				     (norm-mkeys mkeys)))))
 		   (norm-mkeys
 		    (lambda (mkeys)
 		      (define mlim (length mkeys))
@@ -345,7 +350,9 @@
 			    ((= mlim primary-limit) mkeys)
 			    (else
 			     (append mkeys
-				     (make-list (- primary-limit mlim) #f)))))))
+				     (do ((k (- primary-limit mlim) (+ -1 k))
+					  (result '() (cons #f result)))
+					 ((<= k 0) result))))))))
 	    (export-method
 	     'row:retrieve
 	     (if (= primary-limit column-limit)
@@ -366,6 +373,7 @@
 	       (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)
@@ -458,7 +466,9 @@
 			       (accumulate-over-table ckey:remove))
 		(export-method 'row:delete*
 			       (lambda mkeys
-				 (base:delete* base-table (norm-mkeys 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)
@@ -505,6 +515,7 @@
 				    (base:map-primary-key
 				     base-table
 				     (lambda (ckey) (key-extractor ckey))
+				     primary-limit column-type-list
 				     (norm-mkeys mkeys)))))
 			(else #f)))
 		     (else
@@ -520,6 +531,7 @@
 				     (lambda (ckey)
 				       (list-ref (base:get base-table ckey)
 						 index))
+				     primary-limit column-type-list
 				     (norm-mkeys mkeys))))
 			  (else #f)))))))))))))
 
@@ -587,10 +599,10 @@
       (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)))
+	       ;;(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))
@@ -602,6 +614,7 @@
 	(case operation-name
 	  ((close-database) close-database)
 	  ((write-database) write-database)
+	  ((sync-database) sync-database)
 	  ((open-table) open-table)
 	  ((delete-table) delete-table)
 	  ((create-table) create-table)
-- 
cgit v1.2.3