(export (equal-hash string=-hash string=-ci-hash char=-hash char=-ci-hash =-hash make-table table? table-ref table-set! table-remove! table-size table-walk)
;;; Exported interface
(define (make-table . args)
"([initial-size {comparison-fn hash-fn}]) Make a new hash table with room initially for INITIAL-SIZE entries, using the given COMPARISON-FN and HASH-FN. INITIAL-SIZE defaults to something reasonably small. COMPARISON-FN and HASH-FN default to EQV? and EQV-HASH."
(let* ((len (length args))
(initial-size
(comparison-fn
(if (>= len 2)
(cadr args)
eqv?))
(hash-fn
(if (>= len 3)
(caddr args)
eqv-hash)))
(when (= len 2)
(error 'make-table args "a COMPARISON-FN was specified but not a HASH-FN"))
(when (> len 4)
(error 'make-table args "Too many arguments"))
(make-table-rep initial-size comparison-fn hash-fn)))
(define (table? object)
"Is OBJECT a table?"
(table-rep? object))
(define (table-ref table key)
"Fetch the value stored under KEY in TABLE, returning #F if KEY has no entry in TABLE."
(let ((index (find-table-rep-index table key))
(vec (table-rep-vector table))
(compare? (table-rep-comparison-fn table)))
(let loop ((entries (vector-ref vec index)))
(cond
((null? entries) ; Not found
#f)
((compare? (caar entries) key) ; This is it
(cdar entries))
(else
(loop (cdr entries)))))))
(define (table-set! table key value)
"Either change the current entry for KEY in TABLE to VALUE, if such an entry exists, or add an entry mapping KEY to VALUE."
(let* ((index (find-table-rep-index table key))
(vec (table-rep-vector table))
(compare? (table-rep-comparison-fn table))
(entries (vector-ref vec index)))
(let loop ((ls entries))
(cond
((null? ls) ; Not found
(let ((new-entry (cons key value)))
(vector-set! vec index (cons new-entry entries))
(set-table-rep-size! table (+ (table-rep-size table) 1))
(if (>= (table-rep-size table)
(table-rep-max-size table))
(rehash-table! table))))
((compare? (caar ls) key) ; This is it
(set-cdr! (car ls) value))
(else
(loop (cdr ls)))))))
(define (table-remove! table key)
"Remove the entry for KEY from TABLE, if such an entry exists. Return a boolean indicating whether or not the entry existed."
(let ((index (find-table-rep-index table key))
(vec (table-rep-vector table))
(compare? (table-rep-comparison-fn table)))
(let loop ((entries (vector-ref vec index))
(lag #f))
(cond
((null? entries) ; Not found
#f)
((compare? (caar entries) key) ; This is it
(if (not lag)
(vector-set! vec index (cdr entries))
(set-cdr! lag (cdr entries)))
(set-table-rep-size! table (- (table-rep-size table) 1))
#t)
(else
(loop (cdr entries) entries))))))
(define (table-size table)
"How many entries are there in TABLE?"
(table-rep-size table))
(define (table-walk fn table)
"Apply FN to the key and value for each entry in TABLE. No changes should be made to the TABLE during the walk."
(let ((vec (table-rep-vector table))
(max-size (table-rep-max-size table)))
(let loop ((index 0))
(when (< index max-size)
(for-each (lambda (entry)
(fn (car entry) (cdr entry)))
(vector-ref vec index))
(loop (+ index 1))))))
;;; Predefined hashing-functions
; (define eq-hash ...) ; primitive
; (define eqv-hash ...) ; primitive
(define (equal-hash object)
(cond
((string? object)
(string=-hash object))
((vector? object)
(let ((len (vector-length object)))
(let loop ((index 0)
(hash 0))
(if (< index len)
(loop (+ index 1)
(logxor hash (equal-hash (vector-ref object index))))
hash))))
((pair? object)
(let loop ((tail (cdr object))
(hash (logxor -1 (equal-hash (car object)))))
(if (pair? tail)
(loop (cdr tail)
(logxor hash (equal-hash (car tail))))
(logxor hash (equal-hash tail)))))
(else
(eqv-hash object))))
(define (string=-hash s)
(let ((len (string-length s)))
(let loop ((index 0)
(hash -2))
(if (< index len)
(loop (+ index 1)
(logxor hash (char=-hash (string-ref s index))))
hash))))
(define (string=-ci-hash s)
(let ((len (string-length s)))
(let loop ((index 0)
(hash -2))
(if (< index len)
(loop (+ index 1)
(logxor hash (char=-ci-hash (string-ref s index))))
hash))))
(define char=-hash eqv-hash)
(define (char=-ci-hash c)
(eqv-hash (char-downcase c)))
(define =-hash eqv-hash)
;;; Implementation
(define (find-table-rep-index table key)
;; NB: Be sure to change rehash-table! to match
;; any changes in this definition!!
(let ((hash-fn (table-rep-hash-fn table))
(mod (table-rep-max-size table)))
(modulo (hash-fn key) mod)))
(define (rehash-table! table)
(let* ((old-vec (table-rep-vector table))
(old-max-size (table-rep-max-size table))
(new-max-size (* old-max-size 2))
(new-vec (make-vector new-max-size))
(hash-fn (table-rep-hash-fn table)))
(let loop ((index 0))
(when (< index old-max-size)
(for-each (lambda (entry)
(let ((i (modulo (hash-fn (car entry))
new-max-size)))
(vector-set! new-vec i
(cons entry
(vector-ref new-vec i)))))
(vector-ref old-vec index))
(loop (+ index 1))))
(set-table-rep-vector! table new-vec)
(set-table-rep-max-size! table new-max-size)))
(define tr-descriptor #f)
(define (print-table port table display?)
(format port "#<Table @ ~S>" (eq-hash table)))
(define make-full-table-rep #f)
(define (make-table-rep max-size comparison-fn hash-fn)
(make-full-table-rep max-size comparison-fn hash-fn
(make-vector max-size '())
0))
(define table-rep? #f)
(define table-rep-max-size #f)
(define table-rep-comparison-fn #f)
(define table-rep-hash-fn #f)
(define table-rep-vector #f)
(define table-rep-size #f)
(define set-table-rep-max-size! #f)
(define set-table-rep-vector! #f)
(define set-table-rep-size! #f)
(set! tr-descriptor
(make-record-type 'table-rep
'(max-size comparison-fn hash-fn vector size)
#f
print-table))
(set! make-full-table-rep (record-constructor tr-descriptor))
(set! table-rep? (record-predicate tr-descriptor))
(set! table-rep-max-size (record-accessor tr-descriptor 'max-size))
(set! table-rep-comparison-fn
(record-accessor tr-descriptor 'comparison-fn))
(set! table-rep-hash-fn (record-accessor tr-descriptor 'hash-fn))
(set! table-rep-vector (record-accessor tr-descriptor 'vector))
(set! table-rep-size (record-accessor tr-descriptor 'size))
(set! set-table-rep-max-size! (record-updater tr-descriptor 'max-size))
(set! set-table-rep-vector! (record-updater tr-descriptor 'vector))
(set! set-table-rep-size! (record-updater tr-descriptor 'size))