1;;; 2;;; srfi-69 Basic Hash Tables 3;;; 4 5;; This is a thin wrapper to the Gauche's native hashtable support. 6 7(define-module srfi-69 8 (use srfi-13 :prefix srfi-13:) ; string-hash 9 (export make-hash-table hash-table? alist->hash-table 10 hash-table-equivalence-function hash-table-hash-function 11 hash-table-ref hash-table-ref/default 12 hash-table-set! hash-table-delete! 13 hash-table-exists? hash-table-update! 14 hash-table-update!/default 15 hash-table-size hash-table-keys hash-table-values 16 hash-table-walk hash-table-fold hash-table->alist 17 hash-table-copy hash-table-merge! 18 hash string-hash string-ci-hash hash-by-identity)) 19(select-module srfi-69) 20 21;; These procedures are the same as Gauche's built-in: 22;; hash-table? hash-table-delete! hash-table-exists? 23;; hash-table-keys hash-table-values hash-table-fold 24;;hash-table->alist hash-table-copy 25 26(define-constant *hasher-range* (+ (greatest-fixnum) 1)) 27 28(define (%choose-comparator equal hasher) ; equal never be #f. 29 (if hasher 30 (make-comparator #t equal #f (^[obj] (hasher obj *hasher-range*))) 31 (cond [(eq? equal equal?) equal-comparator] 32 [(eq? equal eqv?) eqv-comparator] 33 [(eq? equal eq?) eq-comparator] 34 [(eq? equal string=?) string-comparator] 35 [(eq? equal string-ci=?) string-ci-comparator] 36 [else (make-comparator #t equal #f (with-module gauche hash))]))) 37 38(define (make-hash-table :optional (equal equal?) (hasher #f) :rest opts) 39 ((with-module gauche make-hash-table) 40 (%choose-comparator equal hasher))) 41 42(define (alist->hash-table alist :optional (equal equal?) (hasher #f) :rest opts) 43 ((with-module gauche alist->hash-table) 44 alist (%choose-comparator equal hasher))) 45 46(define (hash-table-equivalence-function ht) 47 (comparator-equality-predicate (hash-table-comparator ht))) 48 49;; NB: srfi-69's hash function must take second argument. 50(define (hash-table-hash-function ht) 51 (let1 h (comparator-hash-function (hash-table-comparator ht)) 52 (^[obj bound] (modulo (h obj) bound)))) 53 54(define *unique* (list #f)) 55 56(define (no-key-thunk) 57 (error "Hashtable has no key")) ; maybe custom condition? 58 59(define (hash-table-ref ht key :optional (thunk no-key-thunk)) 60 (let1 r (hash-table-get ht key *unique*) 61 (if (eq? r *unique*) 62 (thunk) 63 r))) 64 65(define (hash-table-ref/default ht key default) 66 (hash-table-get ht key default)) 67 68(define (hash-table-set! ht key val) 69 (hash-table-put! ht key val)) 70 71(define (hash-table-update! ht key proc :optional (thunk no-key-thunk)) 72 ((with-module gauche hash-table-update!) 73 ht key 74 (^[v] (if (eq? v *unique*) 75 (thunk) 76 (proc v))) 77 *unique*)) 78 79(define (hash-table-update!/default ht key proc default) 80 ((with-module gauche hash-table-update!) ht key proc default)) 81 82(define hash-table-size hash-table-num-entries) 83 84(define (hash-table-walk ht proc) (hash-table-for-each ht proc)) 85 86(define (hash-table-merge! ht1 ht2) 87 (hash-table-for-each ht2 (^[k v] (hash-table-put! ht1 k v))) 88 ht1) 89 90(define (%maybe-bounded proc obj bound) 91 (let1 h (proc obj) 92 (if bound (modulo h bound) h))) 93 94(define (hash obj :optional (bound #f)) 95 (%maybe-bounded (with-module gauche hash) obj bound)) 96 97(define (string-hash obj :optional (bound #f)) 98 (if bound (srfi-13:string-hash obj bound) (srfi-13:string-hash obj))) 99 100(define (string-ci-hash obj :optional (bound #f)) 101 (if bound (srfi-13:string-hash-ci obj bound) (srfi-13:string-hash-ci obj))) 102 103(define (hash-by-identity obj :optional (bound #f)) 104 (%maybe-bounded eq-hash obj bound)) 105