srfi/srfi-69.scm

   1 ;;; srfi-69.scm --- Basic hash tables
   2
   3 ;;      Copyright (C) 2007 Free Software Foundation, Inc.
   4 ;;
   5 ;; This library is free software; you can redistribute it and/or
   6 ;; modify it under the terms of the GNU Lesser General Public
   7 ;; License as published by the Free Software Foundation; either
   8 ;; version 2.1 of the License, or (at your option) any later version.
   9 ;;
  10 ;; This library is distributed in the hope that it will be useful,
  11 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13 ;; Lesser General Public License for more details.
  14 ;;
  15 ;; You should have received a copy of the GNU Lesser General Public
  16 ;; License along with this library; if not, write to the Free Software
  17 ;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  18 \f
  19 ;;;; Commentary:
  20
  21 ;; My `hash' is compatible with core `hash', so I replace it.
  22 ;; However, my `hash-table?' and `make-hash-table' are different, so
  23 ;; importing this module will warn about them.  If you don't rename my
  24 ;; imports, you shouldn't use both my hash tables and Guile's hash
  25 ;; tables in the same module.
  26 ;;
  27 ;; SRFI-13 `string-hash' and `string-hash-ci' have more arguments, but
  28 ;; are compatible with my `string-hash' and `string-ci-hash', and are
  29 ;; furthermore primitive in Guile, so I use them as my own.
  30 ;;
  31 ;; I also have the extension of allowing hash functions that require a
  32 ;; second argument to be used as the `hash-table-hash-function', and use
  33 ;; these in defaults to avoid an indirection in the hashx functions.  The
  34 ;; only deviation this causes is:
  35 ;;
  36 ;;  ((hash-table-hash-function (make-hash-table)) obj)
  37 ;;  error> Wrong number of arguments to #<primitive-procedure hash>
  38 ;;
  39 ;; I don't think that SRFI 69 actually specifies that I *can't* do this,
  40 ;; because it only implies the signature of a hash function by way of the
  41 ;; named, exported hash functions.  However, if this matters enough I can
  42 ;; add a private derivation of hash-function to the srfi-69:hash-table
  43 ;; record type, like associator is to equivalence-function.
  44 ;;
  45 ;; Also, outside of the issue of how weak keys and values are referenced
  46 ;; outside the table, I always interpret key equivalence to be that of
  47 ;; the `hash-table-equivalence-function'.  For example, given the
  48 ;; requirement that `alist->hash-table' give earlier associations
  49 ;; priority, what should these answer?
  50 ;;
  51 ;;  (hash-table-keys
  52 ;;   (alist->hash-table '(("xY" . 1) ("Xy" . 2)) string-ci=?))
  53 ;;
  54 ;;  (let ((ht (make-hash-table string-ci=?)))
  55 ;;    (hash-table-set! ht "xY" 2)
  56 ;;    (hash-table-set! ht "Xy" 1)
  57 ;;    (hash-table-keys ht))
  58 ;;
  59 ;; My interpretation is that they can answer either ("Xy") or ("xY"),
  60 ;; where `hash-table-values' will of course always answer (1), because
  61 ;; the keys are the same according to the equivalence function.  In this
  62 ;; implementation, both answer ("xY").  However, I don't guarantee that
  63 ;; this won't change in the future.
  64
  65 ;;; Code:
  66 \f
  67 ;;;; Module definition & exports
  68
  69 (define-module (srfi srfi-69)
  70   #:use-module (srfi srfi-1)    ;alist-cons,second&c,assoc
  71   #:use-module (srfi srfi-9)
  72   #:use-module (srfi srfi-13)   ;string-hash,string-hash-ci
  73   #:use-module (ice-9 optargs)
  74   #:export (;; Type constructors & predicate
  75             make-hash-table hash-table? alist->hash-table
  76             ;; Reflective queries
  77             hash-table-equivalence-function hash-table-hash-function
  78             ;; Dealing with single elements
  79             hash-table-ref hash-table-ref/default hash-table-set!
  80             hash-table-delete! hash-table-exists? hash-table-update!
  81             hash-table-update!/default
  82             ;; Dealing with the whole contents
  83             hash-table-size hash-table-keys hash-table-values
  84             hash-table-walk hash-table-fold hash-table->alist
  85             hash-table-copy hash-table-merge!
  86             ;; Hashing
  87             string-ci-hash hash-by-identity)
  88   #:re-export (string-hash)
  89   #:replace (hash))
  90
  91 (cond-expand-provide (current-module) '(srfi-37))
  92 \f
  93 ;;;; Hashing
  94
  95 ;;; The largest fixnum is in `most-positive-fixnum' in module (guile),
  96 ;;; though not documented anywhere but libguile/numbers.c.
  97
  98 (define (caller-with-default-size hash-fn)
  99   "Answer a function that makes `most-positive-fixnum' the default
 100 second argument to HASH-FN, a 2-arg procedure."
 101   (lambda* (obj #:optional (size most-positive-fixnum))
 102     (hash-fn obj size)))
 103
 104 (define hash (caller-with-default-size (@ (guile) hash)))
 105
 106 (define string-ci-hash string-hash-ci)
 107
 108 (define hash-by-identity (caller-with-default-size hashq))
 109 \f
 110 ;;;; Reflective queries, construction, predicate
 111
 112 (define-record-type srfi-69:hash-table
 113   (make-srfi-69-hash-table real-table associator size weakness
 114                            equivalence-function hash-function)
 115   hash-table?
 116   (real-table ht-real-table)
 117   (associator ht-associator)
 118   ;; required for O(1) by SRFI-69.  It really makes a mess of things,
 119   ;; and I'd like to compute it in O(n) and memoize it because it
 120   ;; doesn't seem terribly useful, but SRFI-69 is final.
 121   (size ht-size ht-size!)
 122   ;; required for `hash-table-copy'
 123   (weakness ht-weakness)
 124   ;; used only to implement hash-table-equivalence-function; I don't
 125   ;; use it internally other than for `ht-associator'.
 126   (equivalence-function hash-table-equivalence-function)
 127   (hash-function hash-table-hash-function))
 128
 129 (define (guess-hash-function equal-proc)
 130   "Guess a hash function for EQUAL-PROC, falling back on `hash', as
 131 specified in SRFI-69 for `make-hash-table'."
 132   (cond ((eq? equal? equal-proc) (@ (guile) hash)) ;shortcut most common case
 133         ((eq? eq? equal-proc) hashq)
 134         ((eq? eqv? equal-proc) hashv)
 135         ((eq? string=? equal-proc) string-hash)
 136         ((eq? string-ci=? equal-proc) string-ci-hash)
 137         (else (@ (guile) hash))))
 138
 139 (define (without-keyword-args rest-list)
 140   "Answer REST-LIST with all keywords removed along with items that
 141 follow them."
 142   (let lp ((acc '()) (rest-list rest-list))
 143     (cond ((null? rest-list) (reverse! acc))
 144           ((keyword? (first rest-list))
 145            (lp acc (cddr rest-list)))
 146           (else (lp (cons (first rest-list) acc) (cdr rest-list))))))
 147
 148 (define (guile-ht-ctor weakness)
 149   "Answer the Guile HT constructor for the given WEAKNESS."
 150   (case weakness
 151     ((#f) (@ (guile) make-hash-table))
 152     ((key) make-weak-key-hash-table)
 153     ((value) make-weak-value-hash-table)
 154     ((key-or-value) make-doubly-weak-hash-table)
 155     (else (error "Invalid weak hash table type" weakness))))
 156
 157 (define (equivalence-proc->associator equal-proc)
 158   "Answer an `assoc'-like procedure that compares the argument key to
 159 alist keys with EQUAL-PROC."
 160   (cond ((or (eq? equal? equal-proc)
 161              (eq? string=? equal-proc)) (@ (guile) assoc))
 162         ((eq? eq? equal-proc) assq)
 163         ((eq? eqv? equal-proc) assv)
 164         (else (lambda (item alist)
 165                 (assoc item alist equal-proc)))))
 166
 167 (define* (make-hash-table
 168           #:optional (equal-proc equal?)
 169           (hash-proc (guess-hash-function equal-proc))
 170           #:key (weak #f) #:rest guile-opts)
 171   "Answer a new hash table using EQUAL-PROC as the comparison
 172 function, and HASH-PROC as the hash function.  See the reference
 173 manual for specifics, of which there are many."
 174   (make-srfi-69-hash-table
 175    (apply (guile-ht-ctor weak) (without-keyword-args guile-opts))
 176    (equivalence-proc->associator equal-proc)
 177    0 weak equal-proc hash-proc))
 178
 179 (define (alist->hash-table alist . mht-args)
 180   "Convert ALIST to a hash table created with MHT-ARGS."
 181   (let* ((result (apply make-hash-table mht-args))
 182          (size (ht-size result)))
 183     (with-hashx-values (hash-proc associator real-table) result
 184       (for-each (lambda (pair)
 185                   (let ((handle (hashx-get-handle hash-proc associator
 186                                                   real-table (car pair))))
 187                     (cond ((not handle)
 188                            (set! size (1+ size))
 189                            (hashx-set! hash-proc associator real-table
 190                                        (car pair) (cdr pair))))))
 191                 alist))
 192     (ht-size! result size)
 193     result))
 194 \f
 195 ;;;; Accessing table items
 196
 197 ;; We use this to denote missing or unspecified values to avoid
 198 ;; possible collision with *unspecified*.
 199 (define ht-unspecified (cons *unspecified* "ht-value"))
 200
 201 ;; I am a macro only for efficiency, to avoid varargs/apply.
 202 (define-macro (hashx-invoke hashx-proc ht-var . args)
 203   "Invoke HASHX-PROC, a `hashx-*' procedure taking a hash-function,
 204 assoc-function, and the hash-table as first args."
 205   `(,hashx-proc (hash-table-hash-function ,ht-var)
 206                 (ht-associator ,ht-var)
 207                 (ht-real-table ,ht-var)
 208                 . ,args))
 209
 210 (define-macro (with-hashx-values bindings ht-var . body-forms)
 211   "Bind BINDINGS to the hash-function, associator, and real-table of
 212 HT-VAR, while evaluating BODY-FORMS."
 213   `(let ((,(first bindings) (hash-table-hash-function ,ht-var))
 214          (,(second bindings) (ht-associator ,ht-var))
 215          (,(third bindings) (ht-real-table ,ht-var)))
 216      . ,body-forms))
 217
 218 (define (hash-table-ref ht key . default-thunk-lst)
 219   "Lookup KEY in HT and answer the value, invoke DEFAULT-THUNK if KEY
 220 isn't present, or signal an error if DEFAULT-THUNK isn't provided."
 221   (let ((result (hashx-invoke hashx-ref ht key ht-unspecified)))
 222     (if (eq? ht-unspecified result)
 223         (if (pair? default-thunk-lst)
 224             ((first default-thunk-lst))
 225             (error "Key not in table" key ht))
 226         result)))
 227
 228 (define (hash-table-ref/default ht key default)
 229   "Lookup KEY in HT and answer the value.  Answer DEFAULT if KEY isn't
 230 present."
 231   (hashx-invoke hashx-ref ht key default))
 232
 233 (define (hash-table-set! ht key new-value)
 234   "Set KEY to NEW-VALUE in HT."
 235   (let ((handle (hashx-invoke hashx-create-handle! ht key ht-unspecified)))
 236     (if (eq? ht-unspecified (cdr handle))
 237         (ht-size! ht (1+ (ht-size ht))))
 238     (set-cdr! handle new-value))
 239   *unspecified*)
 240
 241 (define (hash-table-delete! ht key)
 242   "Remove KEY's association in HT."
 243   (with-hashx-values (h a real-ht) ht
 244     (if (hashx-get-handle h a real-ht key)
 245         (begin
 246           (ht-size! ht (1- (ht-size ht)))
 247           (hashx-remove! h a real-ht key))))
 248   *unspecified*)
 249
 250 (define (hash-table-exists? ht key)
 251   "Return whether KEY is a key in HT."
 252   (and (hashx-invoke hashx-get-handle ht key) #t))
 253
 254 ;;; `hashx-set!' duplicates the hash lookup, but we use it anyway to
 255 ;;; avoid creating a handle in case DEFAULT-THUNK exits
 256 ;;; `hash-table-update!' non-locally.
 257 (define (hash-table-update! ht key modifier . default-thunk-lst)
 258   "Modify HT's value at KEY by passing its value to MODIFIER and
 259 setting it to the result thereof.  Invoke DEFAULT-THUNK for the old
 260 value if KEY isn't in HT, or signal an error if DEFAULT-THUNK is not
 261 provided."
 262   (with-hashx-values (hash-proc associator real-table) ht
 263     (let ((handle (hashx-get-handle hash-proc associator real-table key)))
 264       (cond (handle
 265              (set-cdr! handle (modifier (cdr handle))))
 266             (else
 267              (hashx-set! hash-proc associator real-table key
 268                          (if (pair? default-thunk-lst)
 269                              (modifier ((car default-thunk-lst)))
 270                              (error "Key not in table" key ht)))
 271              (ht-size! ht (1+ (ht-size ht)))))))
 272   *unspecified*)
 273
 274 (define (hash-table-update!/default ht key modifier default)
 275   "Modify HT's value at KEY by passing its old value, or DEFAULT if it
 276 doesn't have one, to MODIFIER, and setting it to the result thereof."
 277   (hash-table-update! ht key modifier (lambda () default)))
 278 \f
 279 ;;;; Accessing whole tables
 280
 281 (define (hash-table-size ht)
 282   "Return the number of associations in HT.  This is guaranteed O(1)
 283 for tables where #:weak was #f or not specified at creation time."
 284   (if (ht-weakness ht)
 285       (hash-table-fold ht (lambda (k v ans) (1+ ans)) 0)
 286       (ht-size ht)))
 287
 288 (define (hash-table-keys ht)
 289   "Return a list of the keys in HT."
 290   (hash-table-fold ht (lambda (k v lst) (cons k lst)) '()))
 291
 292 (define (hash-table-values ht)
 293   "Return a list of the values in HT."
 294   (hash-table-fold ht (lambda (k v lst) (cons v lst)) '()))
 295
 296 (define (hash-table-walk ht proc)
 297   "Call PROC with each key and value as two arguments."
 298   (hash-table-fold ht (lambda (k v unspec) (proc k v) unspec)
 299                    *unspecified*))
 300
 301 (define (hash-table-fold ht f knil)
 302   "Invoke (F KEY VAL PREV) for each KEY and VAL in HT, where PREV is
 303 the result of the previous invocation, using KNIL as the first PREV.
 304 Answer the final F result."
 305   (hash-fold f knil (ht-real-table ht)))
 306
 307 (define (hash-table->alist ht)
 308   "Return an alist for HT."
 309   (hash-table-fold ht alist-cons '()))
 310
 311 (define (hash-table-copy ht)
 312   "Answer a copy of HT."
 313   (with-hashx-values (h a real-ht) ht
 314     (let* ((size (hash-table-size ht)) (weak (ht-weakness ht))
 315            (new-real-ht ((guile-ht-ctor weak) size)))
 316       (hash-fold (lambda (k v ign) (hashx-set! h a new-real-ht k v))
 317                  #f real-ht)
 318       (make-srfi-69-hash-table          ;real,assoc,size,weak,equiv,h
 319        new-real-ht a size weak
 320        (hash-table-equivalence-function ht) h))))
 321
 322 (define (hash-table-merge! ht other-ht)
 323   "Add all key/value pairs from OTHER-HT to HT, overriding HT's
 324 mappings where present.  Return HT."
 325   (hash-table-fold
 326    ht (lambda (k v ign) (hash-table-set! ht k v)) #f)
 327   ht)
 328
 329 ;;; srfi-69.scm ends here