;;; "alistab.scm" database tables using association lists (assoc) ; Copyright 1994, 1997 Aubrey Jaffer ; ;Permission to copy this software, to modify it, to redistribute it, ;to distribute modified versions, 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 warranty 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 key-dim) . TABLE) ;;; TABLE is an alist of (Primary-key . ROW) ;;; ROW is a list of non-primary VALUEs (require 'common-list-functions) (require 'relational-database) ;for make-relational-system (require-if 'compiling 'sort) ;@ (define alist-table (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 (list catalog-id) (list resources (list 'free-id 1)))) (define (open-base infile writable) (define (reader port) (cond ((eof-object? port) #f) ((not (eqv? #\; (read-char port))) #f) ((not (eqv? #\; (read-char port))) #f) (else (cons (and (not (input-port? infile)) infile) (read port))))) (cond ((input-port? infile) (reader infile)) ((file-exists? infile) (call-with-input-file infile reader)) (else #f))) (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 " *slib-version* " 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 (assoc* (keyify-1 'free-id) (handle->alist free-hand))) (table-id #f)) (cond (row (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 (kill-table lldb base-id dim types) (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->alist cdr) (define set-handle-alist! set-cdr!) (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-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 (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 (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 (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 (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 (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 (alist-sort! alist) (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) (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 primary-limit column-type-list match-keys) (assoc*-for-each operation '() match-keys (handle->alist handle))) (define (map-key handle operation primary-limit column-type-list match-keys) (assoc*-map operation '() match-keys (handle->alist handle))) (define (ordered-for-each-key handle operation primary-limit column-type-list match-keys) (sorted-assoc*-for-each operation '() match-keys (handle->alist handle))) (define (supported-type? type) (case type ((atom ordinal integer boolean string symbol expression number) #t) (else #f))) (define (supported-key-type? type) (case type ((atom ordinal integer number symbol string) #t) (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 primary-limit column-type-list match-keys) (set-handle-alist! handle (delete-assoc* match-keys (handle->alist handle))))) ((for-each-key) for-each-key) ((map-key) map-key) ((ordered-for-each-key) ordered-for-each-key) (else #f))) )) (set! *base-table-implementations* (cons (list 'alist-table (make-relational-system alist-table)) *base-table-implementations*)) ;; #f (trace-all "/home/jaffer/slib/alistab.scm") (untrace alist-table) (set! *qp-width* 333)