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

---
 rdms.scm | 69 ++++++++++++++++++++++++++++++++++++++--------------------------
 1 file changed, 41 insertions(+), 28 deletions(-)

(limited to 'rdms.scm')

diff --git a/rdms.scm b/rdms.scm
index 0fd4a2c..8c20362 100644
--- a/rdms.scm
+++ b/rdms.scm
@@ -1,5 +1,5 @@
 ;;; "rdms.scm" rewrite 6 - the saga continues
-; Copyright 1994 Aubrey Jaffer
+; Copyright 1994, 1995, 1997 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
@@ -85,8 +85,7 @@
     (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:warn slib:warn)
 (define rdms:error slib:error)
 
 (define (make-relational-system base)
@@ -234,7 +233,9 @@
 
       (define (open-table table-name writable)
 	(define cat:row (cat:get-row base:catalog table-name))
-	(cond ((and writable (not mutable))
+	(cond ((not cat:row)
+	       (rdms:error "can't open-table:" table-name))
+	      ((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
@@ -319,21 +320,27 @@
 		((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))))))
+	  (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 (norm-mkeys mkeys)))))
+		   (norm-mkeys
+		    (lambda (mkeys)
+		      (define mlim (length mkeys))
+		      (cond ((> mlim primary-limit)
+			     (rdms:error "too many keys:" mkeys))
+			    ((= mlim primary-limit) mkeys)
+			    (else
+			     (append mkeys
+				     (make-list (- primary-limit mlim) #f)))))))
 	    (export-method
 	     'row:retrieve
 	     (if (= primary-limit column-limit)
@@ -351,8 +358,10 @@
 	     '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)))))))
+	       (lambda (proc . mkeys)
+		 (base:ordered-for-each-key
+		  base-table (lambda (ckey) (proc (r ckey)))
+		  (norm-mkeys mkeys)))))
 	    (cond
 	     ((and mutable writable)
 	      (letrec
@@ -427,6 +436,7 @@
 			       (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))
@@ -442,8 +452,8 @@
 		(export-method 'row:remove*
 			       (accumulate-over-table ckey:remove))
 		(export-method 'row:delete*
-			       (generalize-to-table
-				(lambda (ckey) (base:delete base-table ckey))))
+			       (lambda mkeys
+				 (base:delete* base-table (norm-mkeys mkeys))))
 		(export-method 'close-table
 			       (lambda () (set! base-table #f)
 				       (set! desc-table #f)
@@ -468,7 +478,8 @@
 					       column table-name)))))))
 	      (lambda args
 		(cond
-		 ((null? args) #f)
+		 ((null? args)
+		  #f)
 		 ((null? (cdr args))
 		  (let ((pp (assq (car args) export-alist)))
 		    (and pp (cdr pp))))
@@ -485,10 +496,11 @@
 			  ((get) (lambda keys
 				   (and (present? base-table (list->key keys))
 					(list-ref keys (+ -1 ci)))))
-			  ((get*) (lambda ()
+			  ((get*) (lambda mkeys
 				    (base:map-primary-key
 				     base-table
-				     (lambda (ckey) (key-extractor ckey)))))
+				     (lambda (ckey) (key-extractor ckey))
+				     (norm-mkeys mkeys))))
 			  (else #f))))
 		     (else
 		      (let ((index (- ci (+ 1 primary-limit))))
@@ -497,12 +509,13 @@
 				   (let ((row (base:get base-table
 							(list->key keys))))
 				     (and row (list-ref row index)))))
-			  ((get*) (lambda ()
+			  ((get*) (lambda mkeys
 				    (base:map-primary-key
 				     base-table
 				     (lambda (ckey)
 				       (list-ref (base:get base-table ckey)
-						 index)))))
+						 index))
+				     (norm-mkeys mkeys))))
 			  (else #f)))))))))))))
 
       (define create-table
-- 
cgit v1.2.3