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

---
 alistab.scm | 317 +++++++++++++++++++++++++++++++++++++++++-------------------
 1 file changed, 220 insertions(+), 97 deletions(-)

(limited to 'alistab.scm')

diff --git a/alistab.scm b/alistab.scm
index c8149bf..f0e8d59 100644
--- a/alistab.scm
+++ b/alistab.scm
@@ -1,5 +1,5 @@
 ;;; "alistab.scm" database tables using association lists (assoc)
-; Copyright 1994 Aubrey Jaffer
+; Copyright 1994, 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
@@ -18,13 +18,23 @@
 ;each case.
 
 ;;; LLDB	is (filename . alist-table)
-;;; HANDLE	is (table-name . TABLE)
+;;; HANDLE	is (#(table-name key-dim) . TABLE)
 ;;; TABLE	is an alist of (Primary-key . ROW)
 ;;; ROW		is a list of non-primary VALUEs
 
+(require 'common-list-functions)
+
 (define alist-table
-(let ((catalog-id 0)
-      (resources '*base-resources*))
+  (let ((catalog-id 0)
+	(resources '*base-resources*)
+	(make-list-keyifier (lambda (prinum types) identity))
+	(make-keyifier-1 (lambda (type) list))
+	(make-key->list (lambda (prinum types) identity))
+	(make-key-extractor (lambda (primary-limit column-type-list index)
+			      (let ((i (+ -1 index)))
+				(lambda (lst) (list-ref lst i))))))
+
+(define keyify-1 (make-keyifier-1 'atom))
 
 (define (make-base filename dim types)
   (list filename
@@ -85,84 +95,155 @@
 (define (make-table lldb dim types)
   (let ((free-hand (open-table lldb resources 1 '(atom integer))))
     (and free-hand
-	 (let* ((row (remover free-hand 'free-id))
-		(id #f))
+	 (let* ((row (assoc* (keyify-1 'free-id) (handle->alist free-hand)))
+		(table-id #f))
 	   (cond (row
-		  (set! id (car row))
-		  ((make-putter 1 '(atom integer)) free-hand 'free-id
-						   (list (+ 1 id)))
-		  (set-cdr! lldb (cons (list id) (cdr lldb)))
-		  id)
+		  (set! table-id (cadr row))
+		  (set-car! (cdr row) (+ 1 table-id))
+		  (set-cdr! lldb (cons (list table-id) (cdr lldb)))
+		  table-id)
 		 (else #f))))))
 
 (define (open-table lldb base-id dim types)
   (assoc base-id (cdr lldb)))
 
-(define (remover nalist key)
-  (let ((alist (cdr nalist)))
-    (cond ((null? alist) #f)
-	  ((equal? key (caar alist))
-	   (set-cdr! nalist (cdr alist))
-	   (cdar alist))
-	  ((null? (cdr alist)) #f)
-	  ((equal? key (caadr alist))
-	   (set! nalist (cdadr alist))
-	   (set-cdr! alist (cddr alist))
-	   nalist)
-	  (else
-	   (let l ((al (cdr alist)))
-	     (cond ((null? (cdr al)) #f)
-		   ((equal? key (caadr al))
-		    (set! nalist (caadr al))
-		    (set-cdr! al (cddr al))
-		    nalist)
-		   (else (l (cdr al)))))))))
-
 (define (kill-table lldb base-id dim types)
-  (and (remover lldb base-id) #t))
+  (define ckey (list base-id))
+  (let ((pair (assoc* ckey (cdr lldb))))
+    (and pair (set-cdr! lldb (delete-assoc ckey (cdr lldb))))
+    (and pair (not (assoc* ckey (cdr lldb))))))
 
-(define handle->base-id car)
 (define handle->alist cdr)
 (define set-handle-alist! set-cdr!)
 
-(define (present? handle key)
-  (assoc key (handle->alist handle)))
-
-(define (make-putter prinum types)
-  (lambda (handle ckey restcols)
-    (let ((row (assoc ckey (handle->alist handle))))
-      (cond (row (set-cdr! row restcols))
-	    (else (set-handle-alist!
-		   handle (cons (cons ckey restcols)
-				(handle->alist handle))))))))
-
-(define (make-getter prinum types)
-  (lambda (handle ckey)
-    (let ((row (assoc ckey (handle->alist handle))))
-      (and row (cdr row)))))
+(define (assoc* keys alist)
+  (let ((pair (assoc (car keys) alist)))
+    (cond ((not pair) #f)
+	  ((null? (cdr keys)) pair)
+	  (else (assoc* (cdr keys) (cdr pair))))))
 
-(define (make-list-keyifier prinum types)
-  (if (= 1 prinum) car list->vector))
+(define (make-assoc* keys alist vals)
+  (let ((pair (assoc (car keys) alist)))
+    (cond ((not pair) (cons (cons (car keys)
+				  (if (null? (cdr keys))
+				      vals
+				      (make-assoc* (cdr keys) '() vals)))
+			    alist))
+	  (else (set-cdr! pair (if (null? (cdr keys))
+				   vals
+				   (make-assoc* (cdr keys) (cdr pair) vals)))
+		alist))))
 
-(define (make-keyifier-1 type)
-  identity)
+(define (delete-assoc ckey alist)
+  (cond
+   ((null? ckey) '())
+   ((assoc (car ckey) alist)
+    => (lambda (match)
+	 (let ((adl (delete-assoc (cdr ckey) (cdr match))))
+	   (cond ((null? adl) (delete match alist))
+		 (else (set-cdr! match adl) alist)))))
+   (else alist)))
 
-(define (make-key->list prinum types)
-  (cond ((= 1 prinum) list)
-	(else vector->list)))
+(define (delete-assoc* ckey alist)
+  (cond
+   ((every not ckey) '())		;includes the null case.
+   ((not (car ckey))
+    (delete '()
+	    (map (lambda (fodder)
+		   (let ((adl (delete-assoc* (cdr ckey) (cdr fodder))))
+		     (if (null? adl) '() (cons (car fodder) adl))))
+		 alist)))
+   ((procedure? (car ckey))
+    (delete '()
+	    (map (lambda (fodder)
+		   (if ((car ckey) (car fodder))
+		       (let ((adl (delete-assoc* (cdr ckey) (cdr fodder))))
+			 (if (null? adl) '() (cons (car fodder) adl)))
+		       fodder))
+		 alist)))
+   ((assoc (car ckey) alist)
+    => (lambda (match)
+	 (let ((adl (delete-assoc* (cdr ckey) (cdr match))))
+	   (cond ((null? adl) (delete match alist))
+		 (else (set-cdr! match adl) alist)))))
+   (else alist)))
 
-(define (make-key-extractor primary-limit column-type-list index)
-  (if (= 1 primary-limit) identity
-      (let ((i (+ -1 index)))
-	(lambda (v) (vector-ref v i)))))
+(define (assoc*-for-each proc bkey ckey alist)
+  (cond ((null? ckey) (proc (reverse bkey)))
+	((not (car ckey))
+	 (for-each (lambda (alist)
+		     (assoc*-for-each proc
+				      (cons (car alist) bkey)
+				      (cdr ckey)
+				      (cdr alist)))
+		   alist))
+	((procedure? (car ckey))
+	 (for-each (lambda (alist)
+		     (if ((car ckey) (car alist))
+			 (assoc*-for-each proc
+					  (cons (car alist) bkey)
+					  (cdr ckey)
+					  (cdr alist))))
+		   alist))
+	((assoc (car ckey) alist)
+	 => (lambda (match)
+	      (assoc*-for-each proc
+			       (cons (car match) bkey)
+			       (cdr ckey)
+			       (cdr match))))))
 
-(define (for-each-key handle operation)
-  (for-each (lambda (x) (operation (car x))) (handle->alist handle)))
+(define (assoc*-map proc bkey ckey alist)
+  (cond ((null? ckey) (list (proc (reverse bkey))))
+	((not (car ckey))
+	 (apply append
+		(map (lambda (alist)
+		       (assoc*-map proc
+				   (cons (car alist) bkey)
+				   (cdr ckey)
+				   (cdr alist)))
+		     alist)))
+	((procedure? (car ckey))
+	 (apply append
+		(map (lambda (alist)
+		       (if ((car ckey) (car alist))
+			   (assoc*-map proc
+				       (cons (car alist) bkey)
+				       (cdr ckey)
+				       (cdr alist))
+			   '()))
+		     alist)))
+	((assoc (car ckey) alist)
+	 => (lambda (match)
+	      (assoc*-map proc
+			  (cons (car match) bkey)
+			  (cdr ckey)
+			  (cdr match))))
+	(else '())))
 
-(define (map-key handle operation)
-  (map (lambda (x) (operation (car x))) (handle->alist handle)))
+(define (sorted-assoc*-for-each proc bkey ckey alist)
+  (cond ((null? ckey) (proc (reverse bkey)))
+	((not (car ckey))
+	 (for-each (lambda (alist)
+		     (sorted-assoc*-for-each proc
+					     (cons (car alist) bkey)
+					     (cdr ckey)
+					     (cdr alist)))
+		   (alist-sort! alist)))
+	((procedure? (car ckey))
+	 (sorted-assoc*-for-each proc
+				 bkey
+				 (cons #f (cdr ckey))
+				 (remove-if-not (lambda (pair)
+						  ((car ckey) (car pair)))
+						alist)))
+	((assoc (car ckey) alist)
+	 => (lambda (match)
+	      (sorted-assoc*-for-each proc
+				      (cons (car match) bkey)
+				      (cdr ckey)
+				      (cdr match))))))
 
-(define (ordered-for-each-key handle operation)
+(define (alist-sort! alist)
   (define (key->sortable k)
     (cond ((number? k) k)
 	  ((string? k) k)
@@ -182,15 +263,45 @@
 	  ((key-< (car y) (car x)) #f)
 	  (else (key-< (cdr x) (cdr y)))))
   (require 'sort)
-  (for-each operation
-	    (map cdr (sort! (map (lambda (p) (cons (key->sortable (car p))
-						   (car p)))
-				 (handle->alist handle))
-			    car-key-<))))
+  (map cdr (sort! (map (lambda (p)
+			 (cons (key->sortable (car p)) p))
+		       alist)
+		  car-key-<)))
+
+(define (present? handle ckey)
+  (assoc* ckey (handle->alist handle)))
+
+(define (make-putter prinum types)
+  (lambda (handle ckey restcols)
+    (set-handle-alist! handle
+		       (make-assoc* ckey (handle->alist handle) restcols))))
+
+(define (make-getter prinum types)
+  (lambda (handle ckey)
+    (let ((row (assoc* ckey (handle->alist handle))))
+      (and row (cdr row)))))
+
+(define (for-each-key handle operation match-key)
+  (assoc*-for-each operation
+		   '()
+		   match-key
+		   (handle->alist handle)))
+
+(define (map-key handle operation match-key)
+  (assoc*-map operation
+	      '()
+	      match-key
+	      (handle->alist handle)))
+
+(define (ordered-for-each-key handle operation match-key)
+  (sorted-assoc*-for-each operation
+			  '()
+			  match-key
+			  (handle->alist handle)))
 
 (define (supported-type? type)
   (case type
-    ((base-id atom integer boolean string symbol expression) #t)
+    ((base-id atom integer boolean string symbol expression number) #t)
     (else #f)))
 
 (define (supported-key-type? type)
@@ -198,30 +309,42 @@
     ((atom integer symbol string) #t)
     (else #f)))
 
-  (lambda (operation-name)
-    (case operation-name
-      ((make-base) make-base)
-      ((open-base) open-base)
-      ((write-base) write-base)
-      ((sync-base) sync-base)
-      ((close-base) close-base)
-      ((make-table) make-table)
-      ((open-table) open-table)
-      ((kill-table) kill-table)
-      ((make-keyifier-1) make-keyifier-1)
-      ((make-list-keyifier) make-list-keyifier)
-      ((make-key->list) make-key->list)
-      ((make-key-extractor) make-key-extractor)
-      ((supported-type?) supported-type?)
-      ((supported-key-type?) supported-key-type?)
-      ((present?) present?)
-      ((make-putter) make-putter)
-      ((make-getter) make-getter)
-      ((delete) remover)
-      ((for-each-key) for-each-key)
-      ((map-key) map-key)
-      ((ordered-for-each-key) ordered-for-each-key)
-      ((catalog-id) catalog-id)
-      (else #f)
-      ))
-  ))
+;;make-table open-table remover assoc* make-assoc*
+;;(trace assoc*-for-each assoc*-map sorted-assoc*-for-each)
+
+    (lambda (operation-name)
+      (case operation-name
+	((make-base) make-base)
+	((open-base) open-base)
+	((write-base) write-base)
+	((sync-base) sync-base)
+	((close-base) close-base)
+	((catalog-id) catalog-id)
+	((make-table) make-table)
+	((open-table) open-table)
+	((kill-table) kill-table)
+	((make-keyifier-1) make-keyifier-1)
+	((make-list-keyifier) make-list-keyifier)
+	((make-key->list) make-key->list)
+	((make-key-extractor) make-key-extractor)
+	((supported-type?) supported-type?)
+	((supported-key-type?) supported-key-type?)
+	((present?) present?)
+	((make-putter) make-putter)
+	((make-getter) make-getter)
+	((delete)
+	 (lambda (handle ckey)
+	   (set-handle-alist! handle
+			      (delete-assoc ckey (handle->alist handle)))))
+	((delete*)
+	 (lambda (handle match-key)
+	   (set-handle-alist! handle
+			      (delete-assoc* match-key
+					     (handle->alist handle)))))
+	((for-each-key) for-each-key)
+	((map-key) map-key)
+	((ordered-for-each-key) ordered-for-each-key)
+	(else #f)))
+    ))
+
+;; #f (trace-all "/home/jaffer/slib/alistab.scm") (untrace alist-table) (set! *qp-width* 333)
-- 
cgit v1.2.3