Import Upstream version 2a6upstream/2a6

1 files changed, 227 insertions, 0 deletions

diff --git a/alistab.scm b/alistab.scm
new file mode 100644
index 0000000..c8149bf
--- /dev/null
+++ b/alistab.scm
@@ -0,0 +1,227 @@
+;;; "alistab.scm" database tables using association lists (assoc)
+; Copyright 1994 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.
+;
+;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
+;this software will be error-free, and I am under no obligation to
+;provide any services, by way of maintenance, update, or otherwise.
+;
+;3.  In conjunction with products arising from the use of this
+;material, there shall be no use of my name in any advertising,
+;promotional, or sales literature without prior written consent in
+;each case.
+
+;;; LLDB	is (filename . alist-table)
+;;; HANDLE	is (table-name . TABLE)
+;;; TABLE	is an alist of (Primary-key . ROW)
+;;; ROW		is a list of non-primary VALUEs
+
+(define alist-table
+(let ((catalog-id 0)
+      (resources '*base-resources*))
+
+(define (make-base filename dim types)
+  (list filename
+	(list catalog-id)
+	(list resources (list 'free-id 1))))
+
+(define (open-base infile writable)
+  (cons (if (input-port? infile) #f infile)
+	((lambda (fun)
+	   (if (input-port? infile)
+	       (fun infile)
+	       (call-with-input-file infile fun)))
+	 read)))
+
+(define (write-base lldb outfile)
+  ((lambda (fun)
+     (cond ((output-port? outfile) (fun outfile))
+	   ((string? outfile) (call-with-output-file outfile fun))
+	   (else #f)))
+   (lambda (port)
+     (display (string-append
+	       ";;; \"" outfile "\" SLIB alist-table database	 -*-scheme-*-")
+	      port)
+     (newline port) (newline port)
+     (display "(" port) (newline port)
+     (for-each
+      (lambda (table)
+	(display " (" port)
+	(write (car table) port) (newline port)
+	(for-each
+	 (lambda (row)
+	   (display "  " port) (write row port) (newline port))
+	 (cdr table))
+	(display " )" port) (newline port))
+      (cdr lldb))
+     (display ")" port) (newline port)
+;     (require 'pretty-print)
+;     (pretty-print (cdr lldb) port)
+     (set-car! lldb (if (string? outfile) outfile #f))
+     #t)))
+
+(define (sync-base lldb)
+  (cond ((car lldb) (write-base lldb (car lldb)) #t)
+	(else
+;;;	 (display "sync-base: database filename not known")
+	 #f)))
+
+(define (close-base lldb)
+  (cond ((car lldb) (write-base lldb (car lldb))
+		    (set-cdr! lldb #f)
+		    (set-car! lldb #f) #t)
+	((cdr lldb) (set-cdr! lldb #f)
+		    (set-car! lldb #f) #t)
+	(else
+;;;	 (display "close-base: database not open")
+	 #f)))
+
+(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))
+	   (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)
+		 (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 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 (make-list-keyifier prinum types)
+  (if (= 1 prinum) car list->vector))
+
+(define (make-keyifier-1 type)
+  identity)
+
+(define (make-key->list prinum types)
+  (cond ((= 1 prinum) list)
+	(else vector->list)))
+
+(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 (for-each-key handle operation)
+  (for-each (lambda (x) (operation (car x))) (handle->alist handle)))
+
+(define (map-key handle operation)
+  (map (lambda (x) (operation (car x))) (handle->alist handle)))
+
+(define (ordered-for-each-key handle operation)
+  (define (key->sortable k)
+    (cond ((number? k) k)
+	  ((string? k) k)
+	  ((symbol? k) (symbol->string k))
+	  ((vector? k) (map key->sortable (vector->list k)))
+	  (else (slib:error "unsortable key" k))))
+  ;; This routine assumes that the car of its operands are either
+  ;; numbers or strings (or lists of those).
+  (define (car-key-< x y)
+    (key-< (car x) (car y)))
+  (define (key-< x y)
+    (cond ((and (number? x) (number? y)) (< x y))
+	  ((number? x) #t)
+	  ((number? y) #f)
+	  ((string? x) (string<? x y))
+	  ((key-< (car x) (car y)) #t)
+	  ((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-<))))
+
+(define (supported-type? type)
+  (case type
+    ((base-id atom integer boolean string symbol expression) #t)
+    (else #f)))
+
+(define (supported-key-type? type)
+  (case type
+    ((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)
+      ))
+  ))