From 8ffbc2df0fde83082610149d24e594c1cd879f4a Mon Sep 17 00:00:00 2001 From: Bryan Newbold Date: Mon, 20 Feb 2017 00:05:25 -0800 Subject: Import Upstream version 2a6 --- alistab.scm | 227 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 227 insertions(+) create mode 100644 alistab.scm (limited to 'alistab.scm') 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) (stringsortable (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) + )) + )) -- cgit v1.2.3