summaryrefslogtreecommitdiffstats
path: root/alistab.scm
diff options
context:
space:
mode:
Diffstat (limited to 'alistab.scm')
-rw-r--r--alistab.scm317
1 files changed, 220 insertions, 97 deletions
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)