diff options
Diffstat (limited to 'alistab.scm')
| -rw-r--r-- | alistab.scm | 33 |
1 files changed, 21 insertions, 12 deletions
diff --git a/alistab.scm b/alistab.scm index e51bd26..e8999bf 100644 --- a/alistab.scm +++ b/alistab.scm @@ -8,7 +8,7 @@ ;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 +;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. ; @@ -23,7 +23,9 @@ ;;; 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*) @@ -42,13 +44,15 @@ (list resources (list 'free-id 1)))) (define (open-base infile writable) - (and (or (input-port? infile) (file-exists? infile)) - (cons (if (input-port? infile) #f infile) - ((lambda (fun) - (if (input-port? infile) - (fun infile) - (call-with-input-file infile fun))) - read)))) + (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) @@ -57,7 +61,8 @@ (else #f))) (lambda (port) (display (string-append - ";;; \"" outfile "\" SLIB alist-table database -*-scheme-*-") + ";;; \"" outfile "\" SLIB " *SLIB-VERSION* + " alist-table database -*-scheme-*-") port) (newline port) (newline port) (display "(" port) (newline port) @@ -303,12 +308,12 @@ (define (supported-type? type) (case type - ((base-id atom integer boolean string symbol expression number) #t) + ((atom ordinal integer boolean string symbol expression number) #t) (else #f))) (define (supported-key-type? type) (case type - ((atom integer number symbol string) #t) + ((atom ordinal integer number symbol string) #t) (else #f))) ;;make-table open-table remover assoc* make-assoc* @@ -349,4 +354,8 @@ (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) |