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