1;;;
2;;; srfi-125 - intermediate hash tables
3;;;
4;;;   Copyright (c) 2017-2020  Shiro Kawai  <shiro@acm.org>
5;;;
6;;;   Redistribution and use in source and binary forms, with or without
7;;;   modification, are permitted provided that the following conditions
8;;;   are met:
9;;;
10;;;   1. Redistributions of source code must retain the above copyright
11;;;      notice, this list of conditions and the following disclaimer.
12;;;
13;;;   2. Redistributions in binary form must reproduce the above copyright
14;;;      notice, this list of conditions and the following disclaimer in the
15;;;      documentation and/or other materials provided with the distribution.
16;;;
17;;;   3. Neither the name of the authors nor the names of its contributors
18;;;      may be used to endorse or promote products derived from this
19;;;      software without specific prior written permission.
20;;;
21;;;   THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
22;;;   "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
23;;;   LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
24;;;   A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
25;;;   OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
26;;;   SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
27;;;   TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
28;;;   PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
29;;;   LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
30;;;   NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
31;;;   SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
32;;;
33
34;; Most of procedures are built-in, though some of them have different names
35;; to avoid conflict with traditional Gauche procedures.
36
37(define-module srfi-125
38  (use gauche.hashutil)
39  (export make-hash-table                   ; extended for compatibility
40          hash-table                        ; extended for compatibility
41          hash-table-unfold                 ; extended for compatibility
42          alist->hash-table                 ; extended for compatibility
43
44          hash-table?                   ; builtin
45          hash-table-contains?          ; builtin
46          hash-table-exists?            ; builtin
47          hash-table-empty?             ; builtin
48          hash-table=?                  ; builtin
49          hash-table-mutable?           ; builtin
50
51          hash-table-ref                ; builtin
52          hash-table-ref/default        ; builtin
53
54          hash-table-set!               ; builtin
55          (rename hash-table-delete!-r7 hash-table-delete!) ; builtin
56          (rename hash-table-intern!-r7 hash-table-intern!) ; builtin
57          (rename hash-table-update!-r7 hash-table-update!) ; builtin
58          hash-table-update!/default                        ; builtin
59          (rename hash-table-pop!-r7 hash-table-pop!)       ; builtin
60          hash-table-clear!                                 ; builtin
61
62          hash-table-size               ; builtin
63          hash-table-keys               ; builtin
64          hash-table-values             ; builtin
65          hash-table-entries            ; builtin
66          (rename hash-table-find-r7 hash-table-find) ; builtin
67          (rename hash-table-count-r7 hash-table-count) ; builtin
68
69          (rename hash-table-map-r7 hash-table-map) ; builtin
70          (rename hash-table-for-each-r7 hash-table-for-each) ; builtin
71          hash-table-walk               ; compatibility
72          (rename hash-table-map!-r7 hash-table-map!) ; builtin
73          (rename hash-table-map->list-r7 hash-table-map->list) ; builtin
74          hash-table-fold               ; extended for compatibility
75          (rename hash-table-prune!-r7 hash-table-prune!) ; builtin
76
77          hash-table-copy               ; builtin
78          hash-table-empty-copy         ; builtin
79          hash-table->alist             ; builtin
80
81          hash-table-union!             ; builtin
82          hash-table-merge!             ; compatibility
83          hash-table-intersection!      ; builtin
84          hash-table-difference!        ; builtin
85          hash-table-xor!               ; builtin
86
87          hash                          ; compatibility
88          string-hash                   ; compatibility
89          string-ci-hash                ; compatibility
90          hash-by-identity              ; compatibility
91          hash-table-equivalence-function ; compatibility
92          hash-table-hash-function      ; compatibility
93          ))
94(select-module srfi-125)
95
96;; srfi-69 compatibility layer
97
98(define %make-hash-table (with-module gauche make-hash-table))
99(define %alist->hash-table (with-module gauche alist->hash-table))
100
101(define (%eq-fn->comparator eq-fn)
102  (cond [(eq? eq-fn eq?) eq-comparator]
103        [(eq? eq-fn eqv?) eqv-comparator]
104        [(eq? eq-fn equal?) equal-comparator]
105        [(eq? eq-fn string=?) string-comparator]
106        [(eq? eq-fn string-ci=?) string-ci-comparator]
107        [else (make-comparator #t eq-fn #f default-hash)]))
108
109(define (make-hash-table cmpr . args)
110  (if (procedure? cmpr)                 ; srfi-69
111    (if (and (pair? args) (procedure? (car args)))
112      (%make-hash-table (make-comparator #t cmpr #f (car args)))
113      (%make-hash-table (%eq-fn->comparator cmpr)))
114    (%make-hash-table cmpr)))
115
116(define (hash-table cmpr . kvs)
117  (cond [(comparator? cmpr) (apply hash-table-r7 cmpr kvs)]
118        [(procedure? cmpr)
119         (if (pair? kvs)
120           (apply hash-table-r7 (make-comparator #t cmpr #f (cadr kvs))
121                  (cdr kvs))
122           (error "missing hash function in hash-table (srfi-69 compatibility):"
123                  (list 'hash-table cmpr)))]
124        [else (error "comparator or procedure expected, but got:" cmpr)]))
125
126(define (alist->hash-table alist cmpr . args)
127  ;; ignore args
128  (cond [(comparator? cmpr) (%alist->hash-table alist cmpr)]
129        [(procedure? cmpr)
130         ;; srfi-69 compatibility
131         (if (null? args)
132           (%alist->hash-table alist (%eq-fn->comparator cmpr))
133           (let* ([eq-proc cmpr]
134                  [hash-proc (car args)])
135             (%alist->hash-table alist
136                                 (make-comparator #t eq-proc #f hash-proc))))]
137        [else (error "comparator or procedure expected, but got:" cmpr)]))
138
139(define (hash-table-unfold p f g seed cmpr . args)
140  ;; ignore args
141  ((with-module gauche hash-table-unfold) p f g seed cmpr))
142
143(define (hash-table-walk ht proc) (hash-table-for-each ht proc))
144
145(define (hash-table-fold proc seed ht)
146  (if (hash-table? proc)
147    ((with-module gauche hash-table-fold) proc seed ht)
148    (hash-table-fold-r7 proc seed ht)))
149
150(define (hash-table-merge! ht1 ht2) (hash-table-union! ht1 ht2))
151
152(define (hash obj :optional ignore)
153  (warn "srfi-69 `hash' is deprecated.  Use `default-hash' instead.")
154  (default-hash obj))
155(define (string-hash obj :optional ignore)
156  ((with-module gauche string-hash) obj))
157(define (string-ci-hash obj :optional ignore)
158  ((with-module gauche string-ci-hash) obj))
159(define (hash-by-identity obj :optional ignore)
160  (warn "srfi-69 `hash-by-identity' is deprecated and does not work compatible way with Gauche's eq-hash.")
161  (default-hash obj))
162
163(define (hash-table-equivalence-function ht)
164  (assume-type ht <hash-table>)
165  (comparator-equality-predicate (hash-table-comparator ht)))
166(define (hash-table-hash-function ht)
167  (assume-type ht <hash-table>)
168  (comparator-hash-function (hash-table-comparator ht)))
169
170
171