214 lines
6.7 KiB
Scheme
214 lines
6.7 KiB
Scheme
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
|
|
|
|
|
|
; Hash table package that allows for different hash and comparison functions.
|
|
|
|
(define-record-type table :table
|
|
(really-make-table size data ref set)
|
|
table?
|
|
(size table-size set-table-size!)
|
|
(data table-data set-table-data!)
|
|
(ref table-ref-procedure set-table-ref-procedure!)
|
|
(set table-set!-procedure set-table-set!-procedure!))
|
|
|
|
(define (table-ref table key)
|
|
((table-ref-procedure table) table key))
|
|
|
|
(define (table-set! table key value)
|
|
((table-set!-procedure table) table key value))
|
|
|
|
; These numbers are guesses
|
|
(define linear-table-size-limit 15)
|
|
(define table-size-limit 100000)
|
|
|
|
(define (next-table-size count) ; Figure out next good size for table.
|
|
(let ((new-size (+ (* count 3) 1)))
|
|
(if (>= new-size table-size-limit)
|
|
(error "requested table size is too large" new-size))
|
|
new-size))
|
|
|
|
(define (make-table-maker comparison-function hash-function)
|
|
(let* ((assoc (make-assoc comparison-function))
|
|
(ref-proc (make-linear-table-ref assoc))
|
|
(x->hash-table! (make->hash-table assoc hash-function))
|
|
(set!-proc (make-linear-table-set! assoc x->hash-table!)))
|
|
(lambda ()
|
|
(really-make-table 0 #f ref-proc set!-proc))))
|
|
|
|
; Speed & size hack?! See how well it works out, then revert to
|
|
; a-lists if it doesn't.
|
|
|
|
(define null-entry #f)
|
|
|
|
(define (new-entry key val others) ;(cons (cons key val) others)
|
|
(let ((v (make-vector 3 #f)))
|
|
(vector-set! v 0 key)
|
|
(vector-set! v 1 val)
|
|
(vector-set! v 2 others)
|
|
v))
|
|
|
|
(define (make-assoc pred)
|
|
(if (eq? pred eq?)
|
|
eq?-assoc ;+++
|
|
(lambda (thing alist)
|
|
(let loop ((alist alist))
|
|
(cond ((not alist)
|
|
#f)
|
|
((pred thing (vector-ref alist 0))
|
|
alist)
|
|
(else
|
|
(loop (vector-ref alist 2))))))))
|
|
|
|
(define eq?-assoc
|
|
(lambda (thing alist)
|
|
(let loop ((alist alist))
|
|
(cond ((not alist)
|
|
#f)
|
|
((eq? thing (vector-ref alist 0))
|
|
alist)
|
|
(else
|
|
(loop (vector-ref alist 2)))))))
|
|
|
|
; Turn some version of ASSOC into a table reference procedure for a-list
|
|
; tables.
|
|
(define (make-linear-table-ref assoc)
|
|
(lambda (table key)
|
|
(let ((probe (assoc key (table-data table))))
|
|
(if probe (vector-ref probe 1) #f))))
|
|
|
|
; Turn some version of ASSOC and a hash function into a table set! procedure
|
|
; for a-list tables. If the table gets too big it is turned into a hash table.
|
|
(define (make-linear-table-set! assoc x->hash-table!)
|
|
(lambda (table key value)
|
|
(let* ((data (table-data table))
|
|
(probe (assoc key data)))
|
|
(cond (probe
|
|
(vector-set! probe 1 value))
|
|
(else
|
|
(set-table-data! table (new-entry key value data))
|
|
(let ((size (table-size table)))
|
|
(if (< size linear-table-size-limit)
|
|
(set-table-size! table (+ size 1))
|
|
(x->hash-table! table size))))))))
|
|
|
|
; Return a function to transform linear tables into hash tables.
|
|
(define (make->hash-table assoc hash-function)
|
|
(let ((hash-table-ref (make-hash-table-ref assoc hash-function))
|
|
(hash-table-set! (make-hash-table-set! assoc hash-function)))
|
|
(lambda (table size)
|
|
(let ((data (table-data table)))
|
|
(set-table-ref-procedure! table hash-table-ref)
|
|
(set-table-set!-procedure! table hash-table-set!)
|
|
(table-expand-table! table (next-table-size size))
|
|
(table-enter-alist! table data)))))
|
|
|
|
(define (make-hash-table-ref assoc hash-function)
|
|
(lambda (table key)
|
|
(let* ((data (table-data table))
|
|
(h (remainder (hash-function key)
|
|
(vector-length data)))
|
|
(alist (vector-ref data h))
|
|
(probe (assoc key alist)))
|
|
(if probe (vector-ref probe 1) #f))))
|
|
|
|
(define (make-hash-table-set! assoc hash-function)
|
|
(lambda (table key value)
|
|
(let* ((data (table-data table))
|
|
(h (remainder (hash-function key)
|
|
(vector-length data)))
|
|
(alist (vector-ref data h))
|
|
(probe (assoc key alist)))
|
|
(cond (probe
|
|
(vector-set! probe 1 value))
|
|
(else
|
|
(vector-set! data h (new-entry key value alist))
|
|
(let ((size (+ (table-size table) 1)))
|
|
(if (< size (vector-length data))
|
|
(set-table-size! table size)
|
|
(expand-hash-table! table size))))))))
|
|
|
|
(define (expand-hash-table! table size)
|
|
(let ((data (table-data table)))
|
|
(table-expand-table! table (next-table-size size))
|
|
(do ((i 0 (+ i 1)))
|
|
((>= i (vector-length data)))
|
|
(table-enter-alist! table (vector-ref data i)))))
|
|
|
|
(define (table-enter-alist! table alist)
|
|
(let ((set!-proc (table-set!-procedure table)))
|
|
(do ((alist alist (vector-ref alist 2)))
|
|
((not alist))
|
|
(let ((value (vector-ref alist 1)))
|
|
(if value (set!-proc table (vector-ref alist 0) value))))))
|
|
|
|
(define (table-expand-table! table size)
|
|
(set-table-size! table 0)
|
|
(if (< size table-size-limit)
|
|
(set-table-data! table (make-vector size #f))
|
|
(error "requested table size is too large" size)))
|
|
|
|
(define (table-walk proc table)
|
|
(really-table-walk (lambda (v)
|
|
(let ((value (vector-ref v 1)))
|
|
(if value (proc (vector-ref v 0) value))))
|
|
table))
|
|
|
|
(define (really-table-walk proc table)
|
|
(let ((data (table-data table)))
|
|
(cond ((not data))
|
|
((= 3 (vector-length data))
|
|
(alist-walk proc data))
|
|
(else
|
|
(do ((i 0 (+ i 1)))
|
|
((>= i (vector-length data)))
|
|
(alist-walk proc (vector-ref data i)))))))
|
|
|
|
(define (alist-walk proc alist)
|
|
(do ((alist alist (vector-ref alist 2)))
|
|
((not alist))
|
|
(proc alist)))
|
|
|
|
(define (make-table-immutable! table)
|
|
(really-table-walk make-immutable! table)
|
|
(make-immutable! (table-data table))
|
|
(make-immutable! table))
|
|
|
|
(define (table->entry-list table)
|
|
(let ((list '()))
|
|
(table-walk (lambda (k v)
|
|
(set! list (cons v list)))
|
|
table)
|
|
list))
|
|
|
|
; Actual tables
|
|
|
|
; The default hash function only on works on things that would work in
|
|
; a CASE expression. Even then, numbers don't really "work," since
|
|
; they are compared using eq?.
|
|
|
|
(define (default-table-hash-function obj)
|
|
(cond ((symbol? obj) (string-hash (symbol->string obj)))
|
|
((integer? obj)
|
|
(if (< obj 0) (- -1 obj) obj))
|
|
((char? obj) (+ 333 (char->integer obj)))
|
|
((eq? obj #f) 3001)
|
|
((eq? obj #t) 3003)
|
|
((null? obj) 3005)
|
|
(else (error "value cannot be used as a table key" obj))))
|
|
|
|
; (define string-hash (structure-ref features string-hash))
|
|
|
|
(define (symbol-hash symbol)
|
|
(string-hash (symbol->string symbol)))
|
|
|
|
(define make-table
|
|
(let ((make-usual-table (make-table-maker eq? default-table-hash-function)))
|
|
(lambda hash-function-option
|
|
(if (null? hash-function-option)
|
|
(make-usual-table)
|
|
((make-table-maker eq? (car hash-function-option)))))))
|
|
|
|
(define make-string-table (make-table-maker string=? string-hash))
|
|
(define make-symbol-table (make-table-maker eq? symbol-hash))
|
|
(define make-integer-table (make-table-maker = (lambda (x) x)))
|