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