; FILE "general-table.scm" ; IMLEMENTS simple parameterized hash tables ; AUTHOR Ken Dickey ; DATE 1994 April 21 ; LAST UPDATE 1994 April 22 ; NOTES OO style (requires YASOS) ; lightly tested. Bugs & fixes to KenD@Newton.Apple.com ;(require 'yasos) ;; INTERFACE: ; (make-table) -> keyed on objects ; (make-string-table) ->

keyed on strings ; (make-symbol-table) ->

keyed on symbols ; (table? obj) -> #t or #f ; (associate! table key value) -> ; (lookup table key failure-marker) -> or failure-marker ; Failure-marker allows for #f values. ; Eg: (let* ( (fail (cons #f #f)) ; not eq? to anything else ; (probe (lookup foo-table my-key fail)) ) ; (if (eq? probe fail) ) ; ; (remove! table key) -> ; removes key,value pair ; An error is signalled if key is not present ; (size table) ->

; Eg: (define (make-symbol-table) ; (make-general-table-maker eq? hash-symbol)) ; These can be put somewhere else: ; (hash-symbol sym n) -> 0..n-1 ; (hash-string str n) -> 0..n-1 ; (hash-number int n) -> 0..n-1 ; (hash-char char n) -> 0..n-1 ; (hash-vector vec n) -> 0..n-1 ; (hash-object obj n) -> 0..n-1 ;------------------------- ;; HASH TABLE DESIGN NOTES ; A table is a record, one of whose slots is a vector of alists. Each ; slot in the vector is a hash bucket. Initially there is only one ; bucket, so the table is just a fancy alist. As the table grows, the ; number of buckets is increased and the table rehashed. The growth ; criteria and hashing functions are fairly simple minded. ;; you may need the following: when unless while add1 sub1 ;(define-syntax WHEN ; (syntax-rules () ; ((when ...) ; ;; => ; (if (begin ...) #f)) ;) ) ;(define-syntax UNLESS ; (syntax-rules () ; ((unless ...) ; ;; => ; (if #f (begin ...))) ;) ) ;(define-syntax WHILE ; (syntax-rules () ; ((while ...) ; ;; => ; (let ( (test (lambda () )) ) ; (let recur ( (c (test)) ) ; (when c ; ... ; (recur (test))) ; ) ) ;) ) ) ;(define (ADD1 n) (+ n 1)) ;(define (SUB1 n) (- n 1)) ;; TABLE FUNCTIONS (def'ed in collect.oo -- uncomment if not loaded) ;(define-predicate TABLE?) ;(define-operation (LOOKUP table key failure-object)) ;(define-operation (ASSOCIATE! table key value)) ;; returns key ;(define-operation (REMOVE! table key)) ;; returns value (define-operation (WALK table proc)) ; not in collect.oo (define (MAKE-GENERAL-TABLE-MAKER compare?-proc hash-proc) ;; TABLE RECORDS {locally scoped generic operations} (define-predicate table-record?) (define-operation (increment-size! self)) (define-operation (decrement-size! self)) (define-access-operation grow-size) (define-operation (compare-fun self)) (define-operation (assoc-fun self)) (define-operation (hash-fun self)) (define-access-operation data) (define-operation (num-buckets self)) (define-access-operation data-bucket) (define-operation (zero! self)) (define (MAKE-TABLE-RECORD compare? assoc-fn hash-fn) (let ( (num-pairs 0) (grow-when 20) (my-data (vector '())) ) (object ((table-record? self) #t) ((size self) num-pairs) ((zero! self) (set! num-pairs 0)) ((increment-size! self) (set! num-pairs (add1 num-pairs))) ((decrement-size! self) (set! num-pairs (sub1 num-pairs))) ((grow-size self) grow-when) (((setter grow-size) self new-size) (set! grow-when new-size)) ((compare-fun self) compare?) ((assoc-fun self) assoc-fn) ((hash-fun self) hash-fn) ((num-buckets self) (vector-length my-data)) ((data self) my-data) (((setter data) self new-data) (set! my-data new-data)) ((data-bucket self index) (vector-ref my-data index)) (((setter data-bucket) self index new-data) (vector-set! my-data index new-data) self) ) ) ) (define (MAKE-ASSOC compare-fn) ; memoize assoc-funs to save space (letrec ( (assoc-alist (list (cons eq? assq) (cons eqv? assv) (cons equal? assoc))) (really-make-assoc (lambda (match?) (lambda (key alist) (let loop ( (alist alist) ) (cond ((null? alist) #f) ((match? key (caar alist)) (car alist)) (else (loop (cdr alist)))))))) ) (cond ((assq compare-fn assoc-alist) => cdr) (else (set! assoc-alist (cons (cons compare-fn (really-make-assoc compare-fn)) assoc-alist)))) ) ) ; end make-assoc (define (MAKE-TABLE-HASH hash-fun) ; internalize hash-fun (lambda (table-record obj) (let ( (number-of-buckets (num-buckets table-record)) ) (if (= 1 number-of-buckets) 0 (hash-fun obj number-of-buckets)) ) ) ) (define MAX-TABLE-BUCKETS 10000) ; your milage may vary (define (GROW-TABLE! table-obj table-record) (let* ( (old-num-buckets (num-buckets table-record)) (new-num-buckets (if (= old-num-buckets 1) 23 (+ 1 (* 3 old-num-buckets)))) ; should be relative prime ) (set (grow-size table-record) (* new-num-buckets 10)) ;; N.B.: untuned (when (< new-num-buckets max-table-buckets) ; rehash (let ( (old-data (data table-record)) ) (set (data table-record) (make-vector new-num-buckets '())) (zero! table-record) ; associate! adds to size ; walk old data (let loop ( (index (sub1 (vector-length old-data))) ) (for-each (lambda (bucket) (associate! table-obj (car bucket) (cdr bucket))) (vector-ref old-data index)) (if (> index 0) (loop (sub1 index)) table-obj) ) ) ) ) ) (lambda () ; make-general-table-maker (let ( (table (make-table-record compare?-proc (make-assoc compare?-proc) (make-table-hash hash-proc))) ) (object ;; table behaviors ((TABLE? self) #t) ((SIZE self) (size table)) ((PRINT self port) (format port "#

")) ((LOOKUP self key failure-marker) (cond (((assoc-fun table) key (data-bucket table ((hash-fun table) table key))) => cdr) (else failure-marker)) ) ((ASSOCIATE! self key value) (let* ( (index ((hash-fun table) table key)) (alist (data-bucket table index)) ) (cond (((assoc-fun table) key alist) => (lambda (bucket) (set-cdr! bucket value) key)) (else (set (data-bucket table index) (cons (cons key value) alist)) (increment-size! table) (if (> (size table) (grow-size table)) (grow-table! self table)) key)) ) ) ((REMOVE! self key) ;; returns old value (let* ( (index ((hash-fun table) table key)) (alist (data-bucket table index)) (match? (compare-fun table)) ) (cond ; empty alist? ((null? alist) (error "TABLE:REMOVE! Key not found: " key)) ; 1st bucket in alist? ((match? key (caar alist)) (let ( (value (cdar alist)) ) (set (data-bucket table index) (cdr alist)) (decrement-size! table) value) ) ; general case (else (let loop ( (last alist) (this (cdr alist)) ) (cond ((null? this) (error "TABLE:REMOVE! Key not found: " key)) ((match? key (caar this)) (let ( (value (cdar this)) ) (set-cdr! last (cdr this)) (decrement-size! table) value) ) (else (loop (cdr last) (cdr this))) ) ) ) )) ) ((WALK self proc) (let loop ( (index (sub1 (num-buckets table))) ) (for-each proc (data-bucket table index)) (if (> index 0) (loop (sub1 index)) 'done)) ) ;; collection behaviors ((COLLECTION? self) #t) ((GEN-KEYS self) ; lazy (let* ( (bucket-index (sub1 (num-buckets table))) (alist (data-bucket table bucket-index)) ) (lambda () (while (null? alist) (when (zero? bucket-index) (error "gen-keys: more keys asked for than available!")) (set! bucket-index (sub1 bucket-index)) (set! alist (data-bucket table bucket-index))) (let ( (key (caar alist)) ) (set! alist (cdr alist)) key))) ) ((GEN-ELTS self) ; lazy (let* ( (bucket-index (sub1 (num-buckets table))) (alist (data-bucket table bucket-index)) ) (lambda () (while (null? alist) (when (zero? bucket-index) (error "gen-keys: more keys asked for than available!")) (set! bucket-index (sub1 bucket-index)) (set! alist (data-bucket table bucket-index))) (let ( (elt (cdar alist)) ) (set! alist (cdr alist)) elt))) ) ((FOR-EACH-KEY self proc) (walk table (lambda (bucket) (proc (car bucket)))) ) ((FOR-EACH-ELT self proc) (walk table (lambda (bucket) (proc (cdr bucket)))) ) ) ) ) ) ;-----------------------------------------------------------------v ; simple hash functions from "proplist.scm" (c) 1991, Marc Feeley (define (HASH-SYMBOL sym n) (hash-string (symbol->string sym) n)) (define (HASH-STRING str n) (let ((len (string-length str))) (let loop ((h 0) (i (sub1 len))) (if (>= i 0) (let ((x (+ (* h 256) (char->integer (string-ref str i))))) (loop (modulo x n) (sub1 i))) h)))) (define (HASH-NUMBER num n) (modulo (inexact->exact (floor (cond ((integer? num) num) ((rational? num) (+ (numerator num) (denominator num))) ((real? num) num) (else (+ (real-part num) (imag-part num)))))) n)) (define (HASH-CHAR chr n) (modulo (char->integer chr) n)) (define (HASH-VECTOR vec n) (modulo (vector-length vec) n)) (define (HASH-OBJECT obj n) (cond ((symbol? obj) (hash-symbol obj n)) ((string? obj) (hash-string obj n)) ((number? obj) (hash-number obj n)) ((char? obj) (hash-char obj n)) ((vector? obj) (hash-vector obj n)) ((pair? obj) 0) (else (modulo 1 n)))) ;-----------------------------------------------------------------^ (define MAKE-TABLE (make-general-table-maker eq? hash-object)) (define MAKE-STRING-TABLE (make-general-table-maker string=? hash-string)) (define MAKE-SYMBOL-TABLE (make-general-table-maker eq? hash-symbol)) ;; --- E O F ---