[Top][All Lists]

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

[patch] SRFI-69 support

From: Stephen Compall
Subject: [patch] SRFI-69 support
Date: Sat, 01 Dec 2007 20:30:25 +0000

Here is SRFI-69, Basic hash tables, implemented by me from scratch in
Scheme, including a manual section and a few tests.  Patch does not
include log entries, listed immediately below instead:


2007-12-01  Stephen Compall  <address@hidden>

        * srfi-modules.texi: Describe SRFI-69 in a new subsection.


2007-12-01  Stephen Compall  <address@hidden>

        * tests/srfi-69.test: New file.
        * Add it.


2007-12-01  Stephen Compall  <address@hidden>

        * srfi-69.scm: New file.
        * Add it.

Index: doc/ref/srfi-modules.texi
RCS file: /sources/guile/guile/guile-core/doc/ref/srfi-modules.texi,v
retrieving revision 1.74
diff -u -d -u -r1.74 srfi-modules.texi
--- doc/ref/srfi-modules.texi   11 Aug 2007 10:08:10 -0000      1.74
+++ doc/ref/srfi-modules.texi   1 Dec 2007 20:19:15 -0000
@@ -44,6 +44,7 @@
 * SRFI-55::                     Requiring Features.
 * SRFI-60::                     Integers as bits.
 * SRFI-61::                     A more general `cond' clause
+* SRFI-69::                     Basic hash tables.
 @end menu
@@ -3027,6 +3028,195 @@
 @ref{if cond case,, Simple Conditional Evaluation}.
address@hidden SRFI-69
address@hidden SRFI-69 - Basic hash tables
address@hidden SRFI-69
+This is a portable wrapper around Guile's built-in hash table and weak
+table support.  @xref{Hash Tables}, for information on that built-in
+support.  Above that, this hash-table interface provides association
+of equality and hash functions with tables at creation time, so
+variants of each function are not required, as well as a procedure
+that takes care of most uses for Guile hash table handles, which this
+SRFI does not provide as such.
+Access it with:
+(use-modules (srfi srfi-37))
address@hidden lisp
+* SRFI-69 Creating hash tables::  
+* SRFI-69 Accessing table items::  
+* SRFI-69 Table properties::    
+* SRFI-69 Hash table algorithms::  
address@hidden menu
address@hidden SRFI-69 Creating hash tables
address@hidden Creating hash tables
address@hidden {Scheme Procedure} make-hash-table [equal-proc hash-proc #:weak 
weakness start-size]
+Create and answer a new hash table with @var{equal-proc} as the
+equality function and @var{hash-proc} as the hashing function.
+By default, @var{equal-proc} is @code{equal?}.  It can be any
+two-argument procedure, and should answer whether two keys are the
+same for this table's purposes.
+My default @var{hash-proc} assumes that @code{equal-proc} is no
+coarser than @code{equal?}  unless it is literally @code{string-ci=?}.
+If provided, @var{hash-proc} should be a two-argument procedure that
+takes a key and the current table size, and answers a reasonably good
+hash integer between 0 (inclusive) and the size (exclusive).
address@hidden should be @code{#f} or a symbol indicating how ``weak''
+the hash table is:
address@hidden @code
address@hidden #f
+An ordinary non-weak hash table.  This is the default.
address@hidden key
+When the key has no more non-weak references at GC, remove that entry.
address@hidden value
+When the value has no more non-weak references at GC, remove that
address@hidden key-or-value
+When either has no more non-weak references at GC, remove the
address@hidden table
+As a legacy of the time when Guile couldn't grow hash tables,
address@hidden is an optional integer argument that specifies the
+approximate starting size for the hash table.  I will usually round
+this to an algorithmically-sounder number.
address@hidden deffn
+By @dfn{coarser} than @code{equal?}, I mean that for all @var{x} and
address@hidden values where @code{(@var{equal-proc} @var{x} @var{y})},
address@hidden(equal? @var{x} @var{y})} as well.  If that does not hold for
+your @var{equal-proc}, you must provide a @var{hash-proc}.
+In the case of weak tables, remember that @dfn{references} above
+always refers to @code{eq?}-wise references.  Just because you have a
+reference to some string @code{"foo"} doesn't mean that an association
+with key @code{"foo"} in a weak-key table @emph{won't} be collected;
+it only counts as a reference if the two @code{"foo"}s are @code{eq?},
+regardless of @var{equal-proc}.  As such, it is usually only sensible
+to use @code{eq?} and @code{hashq} as the equivalence and hash
+functions for a weak table.  @xref{Weak References}, for more
+information on Guile's built-in weak table support.
address@hidden {Scheme Procedure} alist->hash-table alist [equal-proc hash-proc 
#:weak weakness start-size]
+As with @code{make-hash-table}, but initialize it with the
+associations in @var{alist}.  Where keys are repeated in @var{alist},
+the leftmost association takes precedence.
address@hidden deffn
address@hidden SRFI-69 Accessing table items
address@hidden Accessing table items
address@hidden {Scheme Procedure} hash-table-ref table key [default-thunk]
address@hidden {Scheme Procedure} hash-table-ref/default table key default
+Answer the value associated with @var{key} in @var{table}.  If
address@hidden is not present, answer the result of invoking the thunk
address@hidden, which signals an error instead by default.
address@hidden/default} is a variant that requires a third
+argument, @var{default}, and answers @var{default} itself instead of
+invoking it.
address@hidden deffn
address@hidden {Scheme Procedure} hash-table-set! table key new-value
+Set @var{key} to @var{new-value} in @var{table}.
address@hidden deffn
address@hidden {Scheme Procedure} hash-table-delete! table key
+Remove the association of @var{key} in @var{table}, if present.  If
+absent, do nothing.
address@hidden deffn
address@hidden {Scheme Procedure} hash-table-exists? table key
+Answer whether @var{key} has an association in @var{table}.
address@hidden deffn
address@hidden {Scheme Procedure} hash-table-update! table key modifier 
address@hidden {Scheme Procedure} hash-table-update!/default table key modifier 
+Replace @var{key}'s associated value in @var{table} by invoking
address@hidden with one argument, the old value.
+If @var{key} is not present, and @var{default-thunk} is provided,
+invoke it with no arguments to get the ``old value'' to be passed to
address@hidden as above.  If @var{default-thunk} is not provided in
+such a case, signal an error.
address@hidden/default} is a variant that requires the
+fourth argument, which is used directly as the ``old value'' rather
+than as a thunk to be invoked to retrieve the ``old value''.
address@hidden deffn
address@hidden SRFI-69 Table properties
address@hidden Table properties
address@hidden {Scheme Procedure} hash-table-size table
+Answer the number of associations in @var{table}.  This is guaranteed
+to run in constant time for non-weak tables.
address@hidden deffn
address@hidden {Scheme Procedure} hash-table-keys table
+Answer an unordered list of the keys in @var{table}.
address@hidden deffn
address@hidden {Scheme Procedure} hash-table-values table
+Answer an unordered list of the values in @var{table}.
address@hidden deffn
address@hidden {Scheme Procedure} hash-table-walk table proc
+Invoke @var{proc} once for each association in @var{table}, passing
+the key and value as arguments.
address@hidden deffn
address@hidden {Scheme Procedure} hash-table-fold table proc init
+Invoke @code{(@var{proc} @var{key} @var{value} @var{previous})} for
+each @var{key} and @var{value} in @var{table}, where @var{previous} is
+the result of the previous invocation, using @var{init} as the first
address@hidden value.  Answer the final @var{proc} result.
address@hidden deffn
address@hidden {Scheme Procedure} hash-table->alist table
+Answer an alist where each association in @var{table} is an
+association in the result.
address@hidden deffn
address@hidden SRFI-69 Hash table algorithms
address@hidden Hash table algorithms
+Each hash table carries an @dfn{equivalence function} and a @dfn{hash
+function}, used to implement key lookups.  Beginning users should
+follow the rules for consistency of the default @var{hash-proc}
+specified above.  Advanced users can use these to implement their own
+equivalence and hash functions for specialized lookup semantics.
address@hidden {Scheme Procedure} hash-table-equivalence-function hash-table
address@hidden {Scheme Procedure} hash-table-hash-function hash-table
+Answer the equivalence and hash function of @var{hash-table}, respectively.
address@hidden deffn
address@hidden {Scheme Procedure} hash obj [size]
address@hidden {Scheme Procedure} string-hash obj [size]
address@hidden {Scheme Procedure} string-ci-hash obj [size]
address@hidden {Scheme Procedure} hash-by-identity obj [size]
+Answer a hash value appropriate for equality predicate @code{equal?},
address@hidden, @code{string-ci=?}, and @code{eq?}, respectively.
address@hidden deffn
address@hidden is a backwards-compatible replacement for Guile's built-in
 @c srfi-modules.texi ends here
 @c Local Variables:
Index: srfi/
RCS file: /sources/guile/guile/guile-core/srfi/,v
retrieving revision 1.36
diff -u -d -u -r1.36
--- srfi/    11 Aug 2007 10:08:10 -0000      1.36
+++ srfi/    1 Dec 2007 20:19:15 -0000
@@ -82,7 +82,8 @@
            srfi-35.scm \
             srfi-37.scm \
             srfi-39.scm \
-            srfi-60.scm
+            srfi-60.scm \
+           srfi-69.scm
 EXTRA_DIST = $(srfi_DATA) 
 TAGS_FILES = $(srfi_DATA)
Index: test-suite/
RCS file: /sources/guile/guile/guile-core/test-suite/,v
retrieving revision 1.42
diff -u -d -u -r1.42
--- test-suite/      11 Aug 2007 10:08:10 -0000      1.42
+++ test-suite/      1 Dec 2007 20:19:16 -0000
@@ -80,6 +80,7 @@
            tests/srfi-37.test                  \
            tests/srfi-39.test                  \
            tests/srfi-60.test                  \
+           tests/srfi-69.test                  \
            tests/srfi-4.test                   \
            tests/srfi-9.test                   \
            tests/strings.test                  \
--- /dev/null   2007-09-18 10:49:13.528459000 -0500
+++ test-suite/tests/srfi-69.test       2007-12-01 13:57:52.000000000 -0600
@@ -0,0 +1,105 @@
+;;;; srfi-69.test --- Test suite for SRFI 69 -*- scheme -*-
+;;;;   Copyright (C) 2007 Free Software Foundation, Inc.
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 2, or (at your option)
+;;;; any later version.
+;;;; This program is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; GNU General Public License for more details.
+;;;; You should have received a copy of the GNU General Public License
+;;;; along with this software; see the file COPYING.  If not, write to
+;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;;;; Boston, MA 02110-1301 USA
+(define-module (test-srfi-69)
+  #:use-module (test-suite lib)
+  #:use-module (srfi srfi-69)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-26))
+(define (string-ci-assoc-equal? left right)
+  "Answer whether LEFT and RIGHT are equal, being associations of
+case-insensitive strings to `equal?'-tested values."
+  (and (string-ci=? (car left) (car right))
+       (equal? (cdr left) (cdr right))))
+(with-test-prefix "SRFI-69"
+  (pass-if "small alist<->hash tables round-trip"
+    (let* ((start-alist '((a . 1) (b . 2) (c . 3) (a . 42)))
+          (ht (alist->hash-table start-alist eq?))
+          (end-alist (hash-table->alist ht)))
+      (and (= 3 (hash-table-size ht))
+          (lset= equal? end-alist (take start-alist 3))
+          (= 1 (hash-table-ref ht 'a))
+          (= 2 (hash-table-ref ht 'b))
+          (= 3 (hash-table-ref ht 'c)))))
+  (pass-if "string-ci=? tables work by default"
+    (let ((ht (alist->hash-table '(("xY" . 2) ("abc" . 54)) string-ci=?)))
+      (hash-table-set! ht "XY" 42)
+      (hash-table-set! ht "qqq" 100)
+      (and (= 54 (hash-table-ref ht "ABc"))
+          (= 42 (hash-table-ref ht "xy"))
+          (= 3 (hash-table-size ht))
+          (lset= string-ci-assoc-equal?
+                 '(("xy" . 42) ("abc" . 54) ("qqq" . 100))
+                 (hash-table->alist ht)))))
+  (pass-if-exception "Bad weakness arg to mht signals an error"
+                    '(misc-error . "^Invalid weak hash table type")
+    (make-hash-table equal? hash #:weak 'key-and-value))
+  (pass-if "empty hash tables are empty"
+    (null? (hash-table->alist (make-hash-table eq?))))
+  (pass-if "hash-table-ref uses default"
+    (equal? '(4)
+           (hash-table-ref (alist->hash-table '((a . 1)) eq?)
+                           'b (cut list (+ 2 2)))))
+  (pass-if "hash-table-delete! deletes present assocs, ignores others"
+    (let ((ht (alist->hash-table '((a . 1) (b . 2)) eq?)))
+      (hash-table-delete! ht 'c)
+      (and (= 2 (hash-table-size ht))
+          (begin
+            (hash-table-delete! ht 'a)
+            (= 1 (hash-table-size ht)))
+          (lset= equal? '((b . 2)) (hash-table->alist ht)))))
+  (pass-if "alist->hash-table does not require linear stack space"
+    (eqv? 99999
+         (hash-table-ref (alist->hash-table
+                          (unfold-right (cut >= <> 100000)
+                                        (lambda (s) `(x . ,s)) 1+ 0)
+                          eq?)
+                         'x)))
+  (pass-if "hash-table-walk ignores return values"
+    (let ((ht (alist->hash-table '((a . 1) (b . 2) (c . 3)) eq?)))
+      (for-each (cut hash-table-walk ht <>)
+               (list (lambda (k v) (values))
+                     (lambda (k v) (values 1 2 3))))
+      #t))
+  (pass-if "hash-table-update! modifies existing binding"
+    (let ((ht (alist->hash-table '((a . 1)) eq?)))
+      (hash-table-update! ht 'a 1+)
+      (hash-table-update! ht 'a (cut + 4 <>) (lambda () 42))
+      (and (= 1 (hash-table-size ht))
+          (lset= equal? '((a . 6)) (hash-table->alist ht)))))
+  (pass-if "hash-table-update! creates new binding when appropriate"
+    (let ((ht (make-hash-table eq?)))
+      (hash-table-update! ht 'b 1+ (lambda () 42))
+      (hash-table-update! ht 'b (cut + 10 <>))
+      (and (= 1 (hash-table-size ht))
+          (lset= equal? '((b . 53)) (hash-table->alist ht)))))
--- /dev/null   2007-09-18 10:49:13.528459000 -0500
+++ srfi/srfi-69.scm    2007-12-01 13:50:24.000000000 -0600
@@ -0,0 +1,329 @@
+;;; srfi-69.scm --- Basic hash tables
+;;     Copyright (C) 2007 Free Software Foundation, Inc.
+;; This library is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public
+;; License as published by the Free Software Foundation; either
+;; version 2.1 of the License, or (at your option) any later version.
+;; This library is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; Lesser General Public License for more details.
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this library; if not, write to the Free Software
+;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+;;;; Commentary:
+;; My `hash' is compatible with core `hash', so I replace it.
+;; However, my `hash-table?' and `make-hash-table' are different, so
+;; importing this module will warn about them.  If you don't rename my
+;; imports, you shouldn't use both my hash tables and Guile's hash
+;; tables in the same module.
+;; SRFI-13 `string-hash' and `string-hash-ci' have more arguments, but
+;; are compatible with my `string-hash' and `string-ci-hash', and are
+;; furthermore primitive in Guile, so I use them as my own.
+;; I also have the extension of allowing hash functions that require a
+;; second argument to be used as the `hash-table-hash-function', and use
+;; these in defaults to avoid an indirection in the hashx functions.  The
+;; only deviation this causes is:
+;;  ((hash-table-hash-function (make-hash-table)) obj)
+;;  error> Wrong number of arguments to #<primitive-procedure hash>
+;; I don't think that SRFI 69 actually specifies that I *can't* do this,
+;; because it only implies the signature of a hash function by way of the
+;; named, exported hash functions.  However, if this matters enough I can
+;; add a private derivation of hash-function to the srfi-69:hash-table
+;; record type, like associator is to equivalence-function.
+;; Also, outside of the issue of how weak keys and values are referenced
+;; outside the table, I always interpret key equivalence to be that of
+;; the `hash-table-equivalence-function'.  For example, given the
+;; requirement that `alist->hash-table' give earlier associations
+;; priority, what should these answer?
+;;  (hash-table-keys
+;;   (alist->hash-table '(("xY" . 1) ("Xy" . 2)) string-ci=?))
+;;  (let ((ht (make-hash-table string-ci=?)))
+;;    (hash-table-set! ht "xY" 2)
+;;    (hash-table-set! ht "Xy" 1)
+;;    (hash-table-keys ht))
+;; My interpretation is that they can answer either ("Xy") or ("xY"),
+;; where `hash-table-values' will of course always answer (1), because
+;; the keys are the same according to the equivalence function.  In this
+;; implementation, both answer ("xY").  However, I don't guarantee that
+;; this won't change in the future.
+;;; Code:
+;;;; Module definition & exports
+(define-module (srfi srfi-69)
+  #:use-module (srfi srfi-1)   ;alist-cons,second&c,assoc
+  #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-13)  ;string-hash,string-hash-ci
+  #:use-module (ice-9 optargs)
+  #:export (;; Type constructors & predicate
+           make-hash-table hash-table? alist->hash-table
+           ;; Reflective queries
+           hash-table-equivalence-function hash-table-hash-function
+           ;; Dealing with single elements
+           hash-table-ref hash-table-ref/default hash-table-set!
+           hash-table-delete! hash-table-exists? hash-table-update!
+           hash-table-update!/default
+           ;; Dealing with the whole contents
+           hash-table-size hash-table-keys hash-table-values
+           hash-table-walk hash-table-fold hash-table->alist
+           hash-table-copy hash-table-merge!
+           ;; Hashing
+           string-ci-hash hash-by-identity)
+  #:re-export (string-hash)
+  #:replace (hash))
+(cond-expand-provide (current-module) '(srfi-37))
+;;;; Hashing
+;;; The largest fixnum is in `most-positive-fixnum' in module (guile),
+;;; though not documented anywhere but libguile/numbers.c.
+(define (caller-with-default-size hash-fn)
+  "Answer a function that makes `most-positive-fixnum' the default
+second argument to HASH-FN, a 2-arg procedure."
+  (lambda* (obj #:optional (size most-positive-fixnum))
+    (hash-fn obj size)))
+(define hash (caller-with-default-size (@ (guile) hash)))
+(define string-ci-hash string-hash-ci)
+(define hash-by-identity (caller-with-default-size hashq))
+;;;; Reflective queries, construction, predicate
+(define-record-type srfi-69:hash-table
+  (make-srfi-69-hash-table real-table associator size weakness
+                          equivalence-function hash-function)
+  hash-table?
+  (real-table ht-real-table)
+  (associator ht-associator)
+  ;; required for O(1) by SRFI-69.  It really makes a mess of things,
+  ;; and I'd like to compute it in O(n) and memoize it because it
+  ;; doesn't seem terribly useful, but SRFI-69 is final.
+  (size ht-size ht-size!)
+  ;; required for `hash-table-copy'
+  (weakness ht-weakness)
+  ;; used only to implement hash-table-equivalence-function; I don't
+  ;; use it internally other than for `ht-associator'.
+  (equivalence-function hash-table-equivalence-function)
+  (hash-function hash-table-hash-function))
+(define (guess-hash-function equal-proc)
+  "Guess a hash function for EQUAL-PROC, falling back on `hash', as
+specified in SRFI-69 for `make-hash-table'."
+  (cond ((eq? equal? equal-proc) (@ (guile) hash)) ;shortcut most common case
+       ((eq? eq? equal-proc) hashq)
+       ((eq? eqv? equal-proc) hashv)
+       ((eq? string=? equal-proc) string-hash)
+       ((eq? string-ci=? equal-proc) string-ci-hash)
+       (else (@ (guile) hash))))
+(define (without-keyword-args rest-list)
+  "Answer REST-LIST with all keywords removed along with items that
+follow them."
+  (let lp ((acc '()) (rest-list rest-list))
+    (cond ((null? rest-list) (reverse! acc))
+         ((keyword? (first rest-list))
+          (lp acc (cddr rest-list)))
+         (else (lp (cons (first rest-list) acc) (rest rest-list))))))
+(define (guile-ht-ctor weakness)
+  "Answer the Guile HT constructor for the given WEAKNESS."
+  (case weakness
+    ((#f) (@ (guile) make-hash-table))
+    ((key) make-weak-key-hash-table)
+    ((value) make-weak-value-hash-table)
+    ((key-or-value) make-doubly-weak-hash-table)
+    (else (error "Invalid weak hash table type" weakness))))
+(define (equivalence-proc->associator equal-proc)
+  "Answer an `assoc'-like procedure that compares the argument key to
+alist keys with EQUAL-PROC."
+  (cond ((or (eq? equal? equal-proc)
+            (eq? string=? equal-proc)) (@ (guile) assoc))
+       ((eq? eq? equal-proc) assq)
+       ((eq? eqv? equal-proc) assv)
+       (else (lambda (item alist)
+               (assoc item alist equal-proc)))))
+(define* (make-hash-table
+         #:optional (equal-proc equal?)
+         (hash-proc (guess-hash-function equal-proc))
+         #:key (weak #f) #:rest guile-opts)
+  "Answer a new hash table using EQUAL-PROC as the comparison
+function, and HASH-PROC as the hash function.  See the reference
+manual for specifics, of which there are many."
+  (make-srfi-69-hash-table
+   (apply (guile-ht-ctor weak) (without-keyword-args guile-opts))
+   (equivalence-proc->associator equal-proc)
+   0 weak equal-proc hash-proc))
+(define (alist->hash-table alist . mht-args)
+  "Convert ALIST to a hash table created with MHT-ARGS."
+  (let* ((result (apply make-hash-table mht-args))
+        (size (ht-size result)))
+    (with-hashx-values (hash-proc associator real-table) result
+      (for-each (lambda (pair)
+                 (let ((handle (hashx-get-handle hash-proc associator
+                                                 real-table (car pair))))
+                   (cond ((not handle)
+                          (set! size (1+ size))
+                          (hashx-set! hash-proc associator real-table
+                                      (car pair) (cdr pair))))))
+               alist))
+    (ht-size! result size)
+    result))
+;;;; Accessing table items
+;; We use this to denote missing or unspecified values to avoid
+;; possible collision with *unspecified*.
+(define ht-unspecified (cons *unspecified* "ht-value"))
+;; I am a macro only for efficiency, to avoid varargs/apply.
+(define-macro (hashx-invoke hashx-proc ht-var . args)
+  "Invoke HASHX-PROC, a `hashx-*' procedure taking a hash-function,
+assoc-function, and the hash-table as first args."
+  `(,hashx-proc (hash-table-hash-function ,ht-var)
+               (ht-associator ,ht-var)
+               (ht-real-table ,ht-var)
+               . ,args))
+(define-macro (with-hashx-values bindings ht-var . body-forms)
+  "Bind BINDINGS to the hash-function, associator, and real-table of
+HT-VAR, while evaluating BODY-FORMS."
+  `(let ((,(first bindings) (hash-table-hash-function ,ht-var))
+        (,(second bindings) (ht-associator ,ht-var))
+        (,(third bindings) (ht-real-table ,ht-var)))
+     . ,body-forms))
+(define (hash-table-ref ht key . default-thunk-lst)
+  "Lookup KEY in HT and answer the value, invoke DEFAULT-THUNK if KEY
+isn't present, or signal an error if DEFAULT-THUNK isn't provided."
+  (let ((result (hashx-invoke hashx-ref ht key ht-unspecified)))
+    (if (eq? ht-unspecified result)
+       (if (pair? default-thunk-lst)
+           ((first default-thunk-lst))
+           (error "Key not in table" key ht))
+       result)))
+(define (hash-table-ref/default ht key default)
+  "Lookup KEY in HT and answer the value.  Answer DEFAULT if KEY isn't
+  (hashx-invoke hashx-ref ht key default))
+(define (hash-table-set! ht key new-value)
+  "Set KEY to NEW-VALUE in HT."
+  (let ((handle (hashx-invoke hashx-create-handle! ht key ht-unspecified)))
+    (if (eq? ht-unspecified (cdr handle))
+       (ht-size! ht (1+ (ht-size ht))))
+    (set-cdr! handle new-value))
+  *unspecified*)
+(define (hash-table-delete! ht key)
+  "Remove KEY's association in HT."
+  (with-hashx-values (h a real-ht) ht
+    (if (hashx-get-handle h a real-ht key)
+       (begin
+         (ht-size! ht (1- (ht-size ht)))
+         (hashx-remove! h a real-ht key))))
+  *unspecified*)
+(define (hash-table-exists? ht key)
+  "Return whether KEY is a key in HT."
+  (and (hashx-invoke hashx-get-handle ht key) #t))
+;;; `hashx-set!' duplicates the hash lookup, but we use it anyway to
+;;; avoid creating a handle in case DEFAULT-THUNK exits
+;;; `hash-table-update!' non-locally.
+(define (hash-table-update! ht key modifier . default-thunk-lst)
+  "Modify HT's value at KEY by passing its value to MODIFIER and
+setting it to the result thereof.  Invoke DEFAULT-THUNK for the old
+value if KEY isn't in HT, or signal an error if DEFAULT-THUNK is not
+  (with-hashx-values (hash-proc associator real-table) ht
+    (let ((handle (hashx-get-handle hash-proc associator real-table key)))
+      (cond (handle
+            (set-cdr! handle (modifier (cdr handle))))
+           (else
+            (hashx-set! hash-proc associator real-table key
+                        (if (pair? default-thunk-lst)
+                            (modifier ((car default-thunk-lst)))
+                            (error "Key not in table" key ht)))
+            (ht-size! ht (1+ (ht-size ht)))))))
+  *unspecified*)
+(define (hash-table-update!/default ht key modifier default)
+  "Modify HT's value at KEY by passing its old value, or DEFAULT if it
+doesn't have one, to MODIFIER, and setting it to the result thereof."
+  (hash-table-update! ht key modifier (lambda () default)))
+;;;; Accessing whole tables
+(define (hash-table-size ht)
+  "Return the number of associations in HT.  This is guaranteed O(1)
+for tables where #:weak was #f or not specified at creation time."
+  (if (ht-weakness ht)
+      (hash-table-fold ht (lambda (k v ans) (1+ ans)) 0)
+      (ht-size ht)))
+(define (hash-table-keys ht)
+  "Return a list of the keys in HT."
+  (hash-table-fold ht (lambda (k v lst) (cons k lst)) '()))
+(define (hash-table-values ht)
+  "Return a list of the values in HT."
+  (hash-table-fold ht (lambda (k v lst) (cons v lst)) '()))
+(define (hash-table-walk ht proc)
+  "Call PROC with each key and value as two arguments."
+  (hash-table-fold ht (lambda (k v unspec) (proc k v) unspec)
+                  *unspecified*))
+(define (hash-table-fold ht f knil)
+  "Invoke (F KEY VAL PREV) for each KEY and VAL in HT, where PREV is
+the result of the previous invocation, using KNIL as the first PREV.
+Answer the final F result."
+  (hash-fold f knil (ht-real-table ht)))
+(define (hash-table->alist ht)
+  "Return an alist for HT."
+  (hash-table-fold ht alist-cons '()))
+(define (hash-table-copy ht)
+  "Answer a copy of HT."
+  (with-hashx-values (h a real-ht) ht
+    (let* ((size (hash-table-size ht)) (weak (ht-weakness ht))
+          (new-real-ht ((guile-ht-ctor weak) size)))
+      (hash-fold (lambda (k v ign) (hashx-set! h a new-real-ht k v))
+                #f real-ht)
+      (make-srfi-69-hash-table         ;real,assoc,size,weak,equiv,h
+       new-real-ht a size weak
+       (hash-table-equivalence-function ht) h))))
+(define (hash-table-merge! ht other-ht)
+  "Add all key/value pairs from OTHER-HT to HT, overriding HT's
+mappings where present.  Return HT."
+  (hash-table-fold
+   ht (lambda (k v ign) (hash-table-set! ht k v)) #f)
+  ht)
+;;; srfi-69.scm ends here

Our last-ditch plan is to change the forums into a podcast, then send
RSS feeds into the blogosphere so our users can further debate the
legality of mashups amongst this month's 20 'sexiest' gadgets.
        --Richard "Lowtax" Kyanka

Attachment: signature.asc
Description: This is a digitally signed message part

reply via email to

[Prev in Thread] Current Thread [Next in Thread]