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