1;;; -*- mode:scheme; coding:utf-8; -*- 2;;; 3;;; SRFI-69 Basic hash tables 4;;; 5;;; Copyright (c) 2010-2015 Takashi Kato <ktakashi@ymail.com> 6;;; 7;;; Redistribution and use in source and binary forms, with or without 8;;; modification, are permitted provided that the following conditions 9;;; are met: 10;;; 11;;; 1. Redistributions of source code must retain the above copyright 12;;; notice, this list of conditions and the following disclaimer. 13;;; 14;;; 2. Redistributions in binary form must reproduce the above copyright 15;;; notice, this list of conditions and the following disclaimer in the 16;;; documentation and/or other materials provided with the distribution. 17;;; 18;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 19;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 20;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 21;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 22;;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 23;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED 24;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 25;;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 26;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 27;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 28;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29;;; 30 31#!nounbound 32(library (srfi :69 basic-hash-tables) 33 (export make-hash-table (rename (hashtable? hash-table?)) 34 alist->hash-table 35 36 (rename 37 (hashtable-equivalence-function hash-table-equivalence-function) 38 (hashtable-hash-function hash-table-hash-function)) 39 40 hash-table-ref hash-table-ref/default 41 (rename (hashtable-set! hash-table-set!) 42 (hashtable-delete! hash-table-delete!) 43 (hashtable-contains? hash-table-exists?)) 44 45 hash-table-update! 46 (rename (hashtable-update! hash-table-update!/default)) 47 48 (rename (hashtable-size hash-table-size) 49 (hashtable-keys-list hash-table-keys) 50 (hashtable-values-list hash-table-values)) 51 hash-table-walk hash-table-fold 52 (rename (hashtable->alist hash-table->alist)) 53 hash-table-copy hash-table-merge! 54 55 (rename (equal-hash hash) 56 (eq-hash hash-by-identity)) 57 string-hash string-ci-hash) 58 (import (rnrs) 59 (prefix (scheme base) r7rs:) 60 ;; make-string-hashtable and make-equal-hashtable 61 (sagittarius) 62 (sagittarius control) 63 (only (util hashtables) hashtable->alist hashtable-for-each 64 hashtable-fold)) 65 66 (define make-hash-table 67 (case-lambda 68 ((eql? hash) (make-hashtable hash eql?)) 69 ((eql?) 70 (cond ((eq? eql? eq?) (make-eq-hashtable)) 71 ((eq? eql? eqv?) (make-eqv-hashtable)) 72 ((eq? eql? equal?) (make-equal-hashtable)) 73 ((eq? eql? r7rs:equal?) (make-equal-hashtable)) 74 ((eq? eql? string=?) (make-string-hashtable)) 75 ((eq? eql? string-ci=?) (make-hashtable string-ci=? string-ci-hash)) 76 (else 77 (assertion-violation 'make-hash-table 78 "unknown equivalent procedure" eql?)))) 79 (() (make-equal-hashtable)))) 80 81 (define no-entry (list 'no-entry)) 82 ;; a bit different from (util hashtables) 83 ;; maybe it's better to adjust that one to this one 84 (define (alist->hash-table alist . opts) 85 (rlet1 ht (apply make-hash-table opts) 86 (for-each (lambda (kv) 87 (hashtable-update! 88 ht 89 (car kv) 90 (lambda (x) (if (eq? no-entry x) (cdr kv) x)) 91 no-entry)) alist))) 92 93 (define (failure-thunk who key) 94 (lambda () (error who "no association for key" key))) 95 96 (define hash-table-ref 97 (case-lambda 98 ((ht key thunk) 99 (let ((val (hashtable-ref ht key no-entry))) 100 (if (eq? val no-entry) 101 (thunk) 102 val))) 103 ((ht key) 104 (hash-table-ref ht key (failure-thunk 'hash-table-ref key))))) 105 106 ;; builtin hashtable-ref allow not to have default 107 (define (hash-table-ref/default ht key default) 108 (hashtable-ref ht key default)) 109 110 (define hash-table-update! 111 (case-lambda 112 ((ht key proc thunk) 113 (hashtable-update! ht key 114 (lambda (v) 115 (if (eq? v no-entry) 116 (thunk) 117 (proc v))) 118 no-entry)) 119 ((ht key proc) 120 (hash-table-update! ht key proc (failure-thunk 'hash-table-update! key))))) 121 122 (define (wrong-type-argument-message expect got . nth) 123 (if (null? nth) 124 (format "expected ~a, but got ~a" expect got) 125 (format "expected ~a, but got ~a, as argument ~a" expect got 126 (car nth)))) 127 (define (hash-table-walk table proc) (hashtable-for-each proc table)) 128 (define (hash-table-fold table kons knil) (hashtable-fold kons table knil)) 129 130 (define (hash-table-copy ht) (hashtable-copy ht #t)) 131 (define (hash-table-merge! ht1 ht2) 132 (hashtable-for-each (lambda (k v) (hashtable-set! ht1 k v)) ht2) 133 ht1) 134 135 ) 136