Import Upstream version 2c3upstream/2c3

1 files changed, 65 insertions, 18 deletions

diff --git a/dbutil.scm b/dbutil.scm
index e99b073..1ed84da 100644
--- a/dbutil.scm
+++ b/dbutil.scm
@@ -56,6 +56,19 @@
 	      path)))
     (dbutil:define-tables
      rdb
+     '(type
+       ((name symbol))
+       ()
+       ((atom)
+	(symbol)
+	(string)
+	(number)
+	(money)
+	(date-time)
+	(boolean)
+	(foreign-key)
+	(expression)
+	(virtual)))
      '(parameter-arity
        ((name symbol))
        ((predicate? expression)
@@ -71,9 +84,10 @@
 	(nary (lambda (a) #t) identity)
 	(nary1 (lambda (a) (not (null? a))) identity))))
     (for-each (((rdb 'open-table) '*domains-data* #t) 'row:insert)
-	      '((parameter-list *catalog-data* #f symbol #f)
-		(parameter-name-translation *catalog-data* #f symbol #f)
-		(parameter-arity parameter-arity #f symbol #f)))
+	      '((parameter-list *catalog-data* #f symbol 1)
+		(parameter-name-translation *catalog-data* #f symbol 1)
+		(parameter-arity parameter-arity #f symbol 1)
+		(table *catalog-data* #f atom 1)))
     (dbutil:define-tables
      rdb
      '(*parameter-columns*
@@ -94,6 +108,36 @@
        ((name string))
        ((parameter-index uint))
        ())
+     '(add-domain-params
+       *parameter-columns*
+       *parameter-columns*
+       ((1 domain-name single atom #f #f "new domain name")
+	(2 foreign-table optional table #f #f
+	   "if present, domain-name must be existing key into this table")
+	(3 domain-integrity-rule optional expression #f #f
+	   "returns #t if single argument is good")
+	(4 type-id single type #f #f "base type of new domain")
+	(5 type-param optional expression #f #f
+	   "which (key) field of the foreign-table")
+	))
+     '(add-domain-pnames
+       ((name string))
+       ((parameter-index uint))		;should be add-domain-params
+       (
+	("n" 1) ("name" 1)
+	("f" 2) ("foreign (key) table" 2)
+	("r" 3) ("domain integrity rule" 3)
+	("t" 4) ("type" 4)
+	("p" 5) ("type param" 5)
+	))
+     '(del-domain-params
+       *parameter-columns*
+       *parameter-columns*
+       ((1 domain-name single domain #f #f "domain name")))
+     '(del-domain-pnames
+       ((name string))
+       ((parameter-index uint))		;should be del-domain-params
+       (("n" 1) ("name" 1)))
      '(*commands*
        ((name symbol))
        ((parameters parameter-list)
@@ -110,26 +154,29 @@
 	     (lambda (domain)
 	       (let ((fkname (ro:for-tab domain))
 		     (dir (slib:eval (ro:get-dir domain))))
-		 (cond (fkname (let* ((fktab ((rdb 'open-table) fkname #f))
-				      (p? (fktab 'get 1)))
-				 (cond (dir (lambda (e) (and (dir e) (p? e))))
-				       (else p?))))
-		       (else dir))))))
+		 (if fkname (let* ((fktab ((rdb 'open-table) fkname #f))
+				   (p? (fktab 'get 1)))
+			      (if dir (lambda (e) (and (dir e) (p? e))) p?))
+		     dir)))))
 	 "return procedure to check given domain name")
 
 	(add-domain
-	 no-parameters
-	 no-parameter-names
+	 add-domain-params
+	 add-domain-pnames
 	 (lambda (rdb)
-	   (((rdb 'open-table) '*domains-data* #t) 'row:insert))
-	 "given the row describing it, add a domain")
+	   (((rdb 'open-table) '*domains-data* #t) 'row:update))
+	 "add a new domain")
 
 	(delete-domain
-	 no-parameters
-	 no-parameter-names
+	 del-domain-params
+	 del-domain-pnames
 	 (lambda (rdb)
 	   (((rdb 'open-table) '*domains-data* #t) 'row:remove))
-	 "given its name, delete a domain"))))
+	 "delete a domain"))))
+    (let* ((tab ((rdb 'open-table) '*domains-data* #t))
+	   (row ((tab 'row:retrieve) 'type)))
+      (set-car! (cdr row) 'type)
+      ((tab 'row:update) row))
     (dbutil:wrap-command-interface rdb)))
 
 (define (make-command-server rdb command-table)
@@ -139,8 +186,8 @@
 	 (comgetrow (comtab 'row:retrieve)))
     (lambda (comname command-callback)
       (let* ((command:row (comgetrow comname))
-	     (parameter-table ((rdb 'open-table)
-			       (row-ref command:row 'parameters) #f))
+	     (parameter-table
+	      ((rdb 'open-table) (row-ref command:row 'parameters) #f))
 	     (parameter-names
 	      ((rdb 'open-table) (row-ref command:row 'parameter-names) #f))
 	     (comval ((slib:eval (row-ref command:row 'procedure)) rdb))
@@ -174,7 +221,7 @@
 			 #f)))
 	     ((((rdb 'open-table) '*domains-data* #t) 'row:insert)
 	      (list dname dname #f
-		    (dom:typ ((ftab 'get 'domain-name) 1)) #f))))))
+		    (dom:typ ((ftab 'get 'domain-name) 1)) 1))))))
   (define (define-table name prikeys slots data)
     (cond
      ((table-exists? name)