From: "Jéssica Milaré" <jessymilare@gmail.com>
To: 33827@debbugs.gnu.org
Subject: bug#33827: Patches
Date: Tue, 8 Jan 2019 22:21:04 -0200 [thread overview]
Message-ID: <CAGBcF1aZrZhBjEk=tvsJHLJnMDc1ERt-ZaCiwOzqMksnfZsP_Q@mail.gmail.com> (raw)
In-Reply-To: <CAGBcF1Z5WmXij2vX+EhxQHvWkmmOkeL-hV+Y-SUSpByH0tZQHw@mail.gmail.com>
[-- Attachment #1.1: Type: text/plain, Size: 483 bytes --]
Patch 0001 fixes SRFI-69 bugs as specified. Patches 0002 to 0005 implement
the module (ice-9 generic-hash-tables) and then reimplement SRFI-69 and
(rnrs hashtables) and add an implementation of SRFI 126, all of them using
generic-hash-tables (and therefore compatible to each other).
I've called `make check' after each commit and all tests PASS: or XFAIL:,
except the four tests in linker.test, as reported in Bug 33991[1].
[1] https://debbugs.gnu.org/cgi/bugreport.cgi?bug=33991
[-- Attachment #1.2: Type: text/html, Size: 671 bytes --]
[-- Attachment #2: 0003-Reimplemented-SRFI-69-using-GENERIC-HASH-TABLES.patch --]
[-- Type: text/x-patch, Size: 19960 bytes --]
From a83946f0cd8abb64b9b890668938675955815918 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?J=C3=A9ssica=20Milar=C3=A9?= <jessymilare@gmail.com>
Date: Tue, 8 Jan 2019 22:02:25 -0200
Subject: [PATCH 3/5] Reimplemented SRFI-69 using GENERIC-HASH-TABLES
---
module/rnrs/hashtables.scm | 29 ++--
module/srfi/srfi-69.scm | 318 ++++++++--------------------------
test-suite/tests/srfi-69.test | 3 +-
3 files changed, 93 insertions(+), 257 deletions(-)
diff --git a/module/rnrs/hashtables.scm b/module/rnrs/hashtables.scm
index 22bae7f09..486452a2a 100644
--- a/module/rnrs/hashtables.scm
+++ b/module/rnrs/hashtables.scm
@@ -67,6 +67,7 @@
hash-table-fold)
(hash equal-hash)
(hash-by-identity symbol-hash))
+ (only (ice-9 generic-hash-tables) hash-by-value)
(rnrs base (6))
(rnrs records procedural (6)))
@@ -90,9 +91,9 @@
(define hashtable-mutable? r6rs:hashtable-mutable?)
- (define hash-by-value ((@@ (srfi srfi-69) caller-with-default-size) hashv))
- (define (wrap-hash-function proc)
- (lambda (key capacity) (modulo (proc key) capacity)))
+ ;; (define hash-by-value ((@@ (srfi srfi-69) caller-with-default-size) hashv))
+ ;; (define (wrap-hash-function proc)
+ ;; (lambda (key capacity) (modulo (proc key) capacity)))
(define* (make-eq-hashtable #:optional k)
(make-r6rs-hashtable
@@ -109,14 +110,13 @@
'eqv))
(define* (make-hashtable hash-function equiv #:optional k)
- (let ((wrapped-hash-function (wrap-hash-function hash-function)))
- (make-r6rs-hashtable
- (if k
- (make-hash-table equiv wrapped-hash-function k)
- (make-hash-table equiv wrapped-hash-function))
- hash-function
- #t
- 'custom)))
+ (make-r6rs-hashtable
+ (if k
+ (make-hash-table equiv hash-function k)
+ (make-hash-table equiv hash-function))
+ hash-function
+ #t
+ 'custom))
(define (hashtable-size hashtable)
(hash-table-size (r6rs:hashtable-wrapped-table hashtable)))
@@ -156,13 +156,12 @@
(if (r6rs:hashtable-mutable? hashtable)
(let* ((ht (r6rs:hashtable-wrapped-table hashtable))
(equiv (hash-table-equivalence-function ht))
- (hash-function (r6rs:hashtable-orig-hash-function hashtable))
- (wrapped-hash-function (wrap-hash-function hash-function)))
+ (hash-function (r6rs:hashtable-orig-hash-function hashtable)))
(r6rs:hashtable-set-wrapped-table!
hashtable
(if k
- (make-hash-table equiv wrapped-hash-function k)
- (make-hash-table equiv wrapped-hash-function)))))
+ (make-hash-table equiv hash-function k)
+ (make-hash-table equiv hash-function)))))
*unspecified*)
(define (hashtable-keys hashtable)
diff --git a/module/srfi/srfi-69.scm b/module/srfi/srfi-69.scm
index 2b7fb9a7f..ae5bc7f06 100644
--- a/module/srfi/srfi-69.scm
+++ b/module/srfi/srfi-69.scm
@@ -16,7 +16,8 @@
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
\f
-;;;; Commentary:
+
+;;;; Original (stale) SRFI-69 commentary:
;; My `hash' is compatible with core `hash', so I replace it.
;; However, my `hash-table?' and `make-hash-table' are different, so
@@ -65,8 +66,7 @@
;;;; Commentary by Jessica Milare 2018
-;; Make bug fixes for weak hash-tables, since handles don't work anymore,
-;; and also some optimizations.
+;; Now implemented using module (ice-9 generic-hash-tables)
;;
;; My personal comments are marked by J.M.
@@ -75,300 +75,136 @@
;;;; 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
+ #:use-module (srfi srfi-1)
+ #:use-module ((ice-9 generic-hash-tables) #:prefix gen:)
+ #:replace (make-hash-table hash-table? hash)
+ #:export (;; Type constructors
+ 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-delete! hash-table-update!
hash-table-update!/default
+ hash-table-exists?
;; 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!
+ hash-table->alist hash-table-fold
+ hash-table-walk hash-table-merge!
+ hash-table-copy
;; Hashing
- string-ci-hash hash-by-identity)
- #:re-export (string-hash)
- #:replace (hash make-hash-table hash-table?))
+ string-ci-hash hash-by-identity hash)
+ #:re-export (string-hash))
(cond-expand-provide (current-module) '(srfi-69))
-\f
-;;;; Internal helper macros
-
-;; Define these first, so the compiler will pick them up.
-
-;; 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))
-
-\f
;;;; 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 gen:hash)
+(define hash-by-identity gen:hash-by-identity)
-(define hash-by-identity (caller-with-default-size hashq))
\f
;;;; 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 hash-table? gen:hash-table?)
(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) (cdr 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)
+ (cond ((eq? equal? equal-proc) gen:hash) ;shortcut most common case
+ ((eq? eq? equal-proc) gen:hash-by-identity)
+ ((eq? eqv? equal-proc) gen:hash-by-value)
+ ((eq? string=? equal-proc) gen:string-hash)
+ ((eq? string-ci=? equal-proc) gen:string-ci-hash)
+ (else gen:hash)))
+
+(define (normalize-weakness weak)
+ "Normalizes SRFI-69 standard #:weak to SRFI-126 weakness argument."
+ (case weak
+ ((#f) #f)
+ ((key) 'weak-key)
+ ((value) 'weak-value)
+ ((key-or-value) 'weak-key-and-value)
+ (else (error "Invalid weak hash table type" weak))))
+
+(define* (make-hash-table #:optional (equal-proc equal?)
+ (hash-proc (guess-hash-function equal-proc))
+ #:key (weak #f) #:rest args)
"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))
+ (let ((capacity (find integer? args)))
+ (gen:make-hash-table equal-proc hash-proc
+ #:weakness (normalize-weakness weak)
+ #:capacity (or capacity 1))))
+
+(define hash-table-equivalence-function gen:hash-table-equivalence-function)
+(define hash-table-hash-function gen:hash-table-hash-function)
+(define* (alist->hash-table alist #:optional (equal-proc equal?)
+ (hash-proc (guess-hash-function equal-proc))
+ #:key (weak #f) #:rest args)
+ (let ((capacity (find integer? args)))
+ (gen:alist->hash-table alist equal-proc hash-proc
+ #:weakness (normalize-weakness weak)
+ #:capacity (or capacity 1))))
-(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 ((value (hashx-ref hash-proc associator
- real-table (car pair)
- ht-unspecified)))
- (cond ((eq? ht-unspecified value)
- (set! size (1+ size))
- (hashx-set! hash-proc associator real-table
- (car pair) (cdr pair))))))
- alist))
- (ht-size! result size)
- result))
\f
-;;;; 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"))
+;; Dealing with single elements
-(define* (hash-table-ref ht key #:optional (default-thunk ht-unspecified))
+(define* (hash-table-ref ht key #:optional failure)
"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 (eq? ht-unspecified default-thunk)
- (error "Key not in table" key ht)
- (default-thunk))
- result)))
-
-(define (hash-table-ref/default ht key default)
- "Lookup KEY in HT and answer the value. Answer DEFAULT if KEY isn't
-present."
- (hashx-invoke hashx-ref ht key default))
-
-(define (hash-table-set! ht key new-value)
- "Set KEY to NEW-VALUE in HT."
- (if (ht-weakness ht)
- ;; J.M. separate the case where ht is weak - don't use handle
- ;; J.M. don't need to update size for weak hash-tables
- (hashx-invoke hashx-set! ht key new-value)
- (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*)
+ (if failure
+ (gen:hash-table-ref ht key failure)
+ (gen:hash-table-ref ht key)))
+(define hash-table-ref/default gen:hash-table-ref/default)
+(define hash-table-exists? gen:hash-table-contains?)
+(define hash-table-set! gen:hash-table-set-single!)
(define (hash-table-delete! ht key)
- "Remove KEY's association in HT."
- (with-hashx-values (h a real-ht) ht
- (if (not (eq? ht-unspecified (hashx-ref h a real-ht key ht-unspecified)))
- (begin
- (ht-size! ht (1- (ht-size ht)))
- (hashx-remove! h a real-ht key))))
+ (gen:hash-table-delete-single! ht key)
*unspecified*)
-(define (hash-table-exists? ht key)
- "Return whether KEY is a key in HT."
- (not (eq? ht-unspecified (hashx-invoke hashx-ref ht key ht-unspecified))))
-
-;;; `hash-table-update!' non-locally.
-(define* (hash-table-update! ht key modifier
- #:optional (default-thunk ht-unspecified))
+(define* (hash-table-update! ht key modifier #:optional default-thunk)
"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
provided."
- (with-hashx-values (hash-proc associator real-table) ht
- (if (ht-weakness ht)
- ;; J.M. separate the case where ht is weak - don't use handle
- (let* ((old (hashx-ref hash-proc associator real-table key
- ht-unspecified)))
- (cond ((eq? ht-unspecified old)
- (if (eq? ht-unspecified default-thunk)
- (error "Key not in table" key ht)
- (hashx-set! hash-proc associator real-table key
- (modifier (default-thunk)))))
- (else
- (hashx-set! hash-proc associator real-table key
- (modifier old)))))
- (let ((handle (hashx-get-handle hash-proc associator real-table key)))
- (cond (handle (if (eq? ht-unspecified (cdr handle))
- (begin (ht-size! ht (1+ (ht-size ht)))
- (set-cdr! handle (modifier (default-thunk))))
- (set-cdr! handle (modifier (cdr handle)))))
- (else (if (eq? ht-unspecified default-thunk)
- (error "Key not in table" key ht)
- (let ((default (default-thunk)))
- (ht-size! ht (1+ (ht-size ht)))
- (hashx-set! hash-proc associator real-table key
- (modifier default)))))))))
- *unspecified*)
+ (if default-thunk
+ (gen:hash-table-update! ht key modifier default-thunk)
+ (gen:hash-table-update! ht key modifier)))
+
+(define hash-table-update!/default gen:hash-table-update!/default)
-;;; J.M. Custom implementation instead of using hash-table-update!
-(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."
- (with-hashx-values (hash-proc associator real-table) ht
- (if (ht-weakness ht)
- ;; J.M. separate the case where ht is weak - don't use handle
- (let* ((old (hashx-ref hash-proc associator real-table key default)))
- (hashx-set! hash-proc associator real-table key (modifier old)))
- (let ((handle (hashx-create-handle! hash-proc associator real-table key
- ht-unspecified)))
- (if (eq? ht-unspecified (cdr handle))
- (begin (ht-size! ht (1+ (ht-size ht)))
- (set-cdr! handle (modifier default)))
- (set-cdr! handle (modifier (cdr handle))))))))
\f
;;;; 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)
- (let ((size (hash-table-fold ht (lambda (k v ans) (1+ ans)) 0)))
- (ht-size! ht size)
- size)
- (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-size gen:hash-table-size)
+(define hash-table-keys gen:hash-table-keys)
+(define hash-table-values gen:hash-table-values)
+(define hash-table->alist gen:hash-table->alist)
(define (hash-table-walk ht proc)
"Call PROC with each key and value as two arguments."
- (hash-for-each proc (ht-real-table ht)))
+ (gen:hash-table-for-each proc ht))
(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-map->list cons (ht-real-table ht)))
+ (gen:hash-table-fold f knil ht))
(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-for-each (lambda (k v) (hashx-set! h a new-real-ht k v))
- 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))))
+ (gen:hash-table-copy ht))
(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-for-each (lambda (k v) (hash-table-set! ht k v))
- (ht-real-table other-ht))
+ ;; HASH-TABLE-SET! tests if HT is mutable.
+ (gen:hash-table-for-each (lambda (k v) (hash-table-set! ht k v))
+ other-ht)
ht)
;;; srfi-69.scm ends here
diff --git a/test-suite/tests/srfi-69.test b/test-suite/tests/srfi-69.test
index c2a554db3..e1579f73a 100644
--- a/test-suite/tests/srfi-69.test
+++ b/test-suite/tests/srfi-69.test
@@ -141,6 +141,7 @@ case-insensitive strings to `equal?'-tested values."
(lset= equal? '((b . 3) (c . 4)) (hash-table->alist ht2))))))
(pass-if "can use all arguments, including size"
- (hash-table? (make-hash-table equal? hash #:weak 'key 31)))
+ (let ((ht (make-hash-table equal? hash #:weak 'key 31)))
+ (hash-table? ht)))
)
--
2.19.1
[-- Attachment #3: 0001-Fix-SRFI-69-don-t-use-handles-with-weak-tables.patch --]
[-- Type: text/x-patch, Size: 21295 bytes --]
From ce10994fd7cd7546b7707a40712ec9603e740107 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?J=C3=A9ssica=20Milar=C3=A9?= <jessymilare@gmail.com>
Date: Tue, 8 Jan 2019 21:55:40 -0200
Subject: [PATCH 1/5] Fix: SRFI-69 don't use handles with weak tables anymore.
Many procedures used hashx-get-handle and hashx-create-handle! without
checking whether real-hash-table was weak. Now that isn't the case
anymore (Bug 33827). A bug was fixed in hash-table-merge! and a test case
was added. A few other optimizations were made.
* module/srfi/srfi-69.scm (alist->hash-table):
(hash-table-delete!):
(hash-table-exists?):
(hash-table-ref): Don't use hashx-get-handle.
(hash-table-set!): If weakness is set, don't use hashx-create-handle!
and don't update size.
(hash-table-update!): If weakness is set, don't use hashx-get-handle
and don't update size.
(hash-table-update!/default): Added an implementation that doesn't call
hash-table-update!, avoiding allocating a procedure.
(hash-table-size): Set ht-size for weak hash-tables.
(hash-table-walk):
(hash-table-copy): Use native hash-for-each instead of hash-table-fold.
(hash-table->alist): Use native hash-map->list instead of hash-table-fold.
(hash-table-merge!): Use native hash-for-each instead of hash-table-fold.
Walks over other-ht rather than walking ht (and doing nothing).
* test-suite/tests/srfi-69.test: all appropriate test are replicated for
all possible #:weak arguments. Added a test for hash-table-merge!.
---
THANKS | 1 +
module/srfi/srfi-69.scm | 148 ++++++++++++++++++-----------
test-suite/tests/srfi-69.test | 173 +++++++++++++++++++++-------------
3 files changed, 200 insertions(+), 122 deletions(-)
diff --git a/THANKS b/THANKS
index 616d3b04b..9056a795c 100644
--- a/THANKS
+++ b/THANKS
@@ -20,6 +20,7 @@ Contributors since the last release:
Noah Lavine
Daniel Llorens
Gregory Marton
+ Jéssica Milaré
Thien-Thi Nguyen
Han-Wen Nienhuys
Jan Nieuwenhuizen
diff --git a/module/srfi/srfi-69.scm b/module/srfi/srfi-69.scm
index b9486c465..2b7fb9a7f 100644
--- a/module/srfi/srfi-69.scm
+++ b/module/srfi/srfi-69.scm
@@ -62,6 +62,14 @@
;; implementation, both answer ("xY"). However, I don't guarantee that
;; this won't change in the future.
+
+;;;; Commentary by Jessica Milare 2018
+
+;; Make bug fixes for weak hash-tables, since handles don't work anymore,
+;; and also some optimizations.
+;;
+;; My personal comments are marked by J.M.
+
;;; Code:
\f
;;;; Module definition & exports
@@ -73,18 +81,18 @@
#: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)
+ ;; 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 make-hash-table hash-table?))
@@ -204,30 +212,32 @@ manual for specifics, of which there are many."
(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))
+ (let ((value (hashx-ref hash-proc associator
+ real-table (car pair)
+ ht-unspecified)))
+ (cond ((eq? ht-unspecified value)
+ (set! size (1+ size))
+ (hashx-set! hash-proc associator real-table
+ (car pair) (cdr pair))))))
+ alist))
(ht-size! result size)
result))
\f
;;;; 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"))
-(define (hash-table-ref ht key . default-thunk-lst)
+(define* (hash-table-ref ht key #:optional (default-thunk ht-unspecified))
"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))
+ (if (eq? ht-unspecified default-thunk)
+ (error "Key not in table" key ht)
+ (default-thunk))
result)))
(define (hash-table-ref/default ht key default)
@@ -237,49 +247,78 @@ present."
(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))
+ (if (ht-weakness ht)
+ ;; J.M. separate the case where ht is weak - don't use handle
+ ;; J.M. don't need to update size for weak hash-tables
+ (hashx-invoke hashx-set! ht key new-value)
+ (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))))
+ (if (not (eq? ht-unspecified (hashx-ref h a real-ht key ht-unspecified)))
+ (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))
+ (not (eq? ht-unspecified (hashx-invoke hashx-ref ht key ht-unspecified))))
-;;; `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)
+(define* (hash-table-update! ht key modifier
+ #:optional (default-thunk ht-unspecified))
"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
provided."
(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)))))))
+ (if (ht-weakness ht)
+ ;; J.M. separate the case where ht is weak - don't use handle
+ (let* ((old (hashx-ref hash-proc associator real-table key
+ ht-unspecified)))
+ (cond ((eq? ht-unspecified old)
+ (if (eq? ht-unspecified default-thunk)
+ (error "Key not in table" key ht)
+ (hashx-set! hash-proc associator real-table key
+ (modifier (default-thunk)))))
+ (else
+ (hashx-set! hash-proc associator real-table key
+ (modifier old)))))
+ (let ((handle (hashx-get-handle hash-proc associator real-table key)))
+ (cond (handle (if (eq? ht-unspecified (cdr handle))
+ (begin (ht-size! ht (1+ (ht-size ht)))
+ (set-cdr! handle (modifier (default-thunk))))
+ (set-cdr! handle (modifier (cdr handle)))))
+ (else (if (eq? ht-unspecified default-thunk)
+ (error "Key not in table" key ht)
+ (let ((default (default-thunk)))
+ (ht-size! ht (1+ (ht-size ht)))
+ (hashx-set! hash-proc associator real-table key
+ (modifier default)))))))))
*unspecified*)
+;;; J.M. Custom implementation instead of using hash-table-update!
(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)))
+ (with-hashx-values (hash-proc associator real-table) ht
+ (if (ht-weakness ht)
+ ;; J.M. separate the case where ht is weak - don't use handle
+ (let* ((old (hashx-ref hash-proc associator real-table key default)))
+ (hashx-set! hash-proc associator real-table key (modifier old)))
+ (let ((handle (hashx-create-handle! hash-proc associator real-table key
+ ht-unspecified)))
+ (if (eq? ht-unspecified (cdr handle))
+ (begin (ht-size! ht (1+ (ht-size ht)))
+ (set-cdr! handle (modifier default)))
+ (set-cdr! handle (modifier (cdr handle))))))))
\f
;;;; Accessing whole tables
@@ -287,7 +326,9 @@ doesn't have one, to MODIFIER, and setting it to the result thereof."
"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)
+ (let ((size (hash-table-fold ht (lambda (k v ans) (1+ ans)) 0)))
+ (ht-size! ht size)
+ size)
(ht-size ht)))
(define (hash-table-keys ht)
@@ -300,10 +341,7 @@ for tables where #:weak was #f or not specified at creation time."
(define (hash-table-walk ht proc)
"Call PROC with each key and value as two arguments."
- (hash-table-fold ht (lambda (k v unspec)
- (call-with-values (lambda () (proc k v))
- (lambda vals unspec)))
- *unspecified*))
+ (hash-for-each proc (ht-real-table ht)))
(define (hash-table-fold ht f knil)
"Invoke (F KEY VAL PREV) for each KEY and VAL in HT, where PREV is
@@ -313,15 +351,15 @@ Answer the final F result."
(define (hash-table->alist ht)
"Return an alist for HT."
- (hash-table-fold ht alist-cons '()))
+ (hash-map->list cons (ht-real-table ht)))
(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)
+ (hash-for-each (lambda (k v) (hashx-set! h a new-real-ht k v))
+ 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))))
@@ -329,8 +367,8 @@ Answer the final F result."
(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)
+ (hash-for-each (lambda (k v) (hash-table-set! ht k v))
+ (ht-real-table other-ht))
ht)
;;; srfi-69.scm ends here
diff --git a/test-suite/tests/srfi-69.test b/test-suite/tests/srfi-69.test
index e99b76c6d..c2a554db3 100644
--- a/test-suite/tests/srfi-69.test
+++ b/test-suite/tests/srfi-69.test
@@ -28,80 +28,119 @@ case-insensitive strings to `equal?'-tested values."
(and (string-ci=? (car left) (car right))
(equal? (cdr left) (cdr right))))
+(define-syntax with-weakness-list
+ (syntax-rules ()
+ ((with-weakness-list weakness weakness-list expr ...)
+ (let loop ((weakness-list* weakness-list))
+ (or (null? weakness-list*)
+ (and (let ((weakness (car weakness-list*)))
+ expr ...)
+ (loop (cdr weakness-list*))))))))
+
+(define (test-str-weakness str weakness)
+ (if (not weakness) str (format #f "~a (weak: ~a)" str weakness)))
+
(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)))))
+ (with-weakness-list weakness (list #f 'key 'value 'key-or-value)
+ (pass-if (test-str-weakness "small alist<->hash tables round-trip" weakness)
+ (let* ((start-alist '((a . 1) (b . 2) (c . 3) (a . 42)))
+ (ht (alist->hash-table start-alist eq? #:weak weakness))
+ (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))))))
+
+ (with-weakness-list weakness (list #f 'key 'value 'key-or-value)
+ (pass-if (test-str-weakness "string-ci=? tables work by default" weakness)
+ (let ((ht (alist->hash-table '(("xY" . 2) ("abc" . 54)) string-ci=?
+ #:weak weakness)))
+ (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")
+ '(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)))))
+ (with-weakness-list weakness (list #f 'key 'value 'key-or-value)
+ (pass-if (test-str-weakness "empty hash tables are empty" weakness)
+ (null? (hash-table->alist (make-hash-table eq? #:weak weakness)))))
+
+ (with-weakness-list weakness (list #f 'key 'value 'key-or-value)
+ (pass-if (test-str-weakness "hash-table-ref uses default" weakness)
+ (equal? '(4)
+ (hash-table-ref (alist->hash-table '((a . 1)) eq? #:weak weakness)
+ 'b (cut list (+ 2 2))))))
+
+ (with-weakness-list weakness (list #f 'key 'value 'key-or-value)
+ (pass-if (test-str-weakness "hash-table-delete! deletes present assocs, ignores others"
+ weakness)
+ (let ((ht (alist->hash-table '((a . 1) (b . 2)) eq? #:weak weakness)))
+ (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))))))
+
+ (with-weakness-list weakness (list #f 'key 'value 'key-or-value)
+ (pass-if (test-str-weakness "alist->hash-table does not require linear stack space"
+ weakness)
+ (eqv? 99999
+ (hash-table-ref (alist->hash-table
+ (unfold-right (cut >= <> 100000)
+ (lambda (s) `(x . ,s)) 1+ 0)
+ eq?
+ #:weak weakness)
+ 'x))))
+
+ (with-weakness-list weakness (list #f 'key 'value 'key-or-value)
+ (pass-if (test-str-weakness "hash-table-walk ignores return values"
+ weakness)
+ (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)))
+
+ (with-weakness-list weakness (list #f 'key 'value 'key-or-value)
+ (pass-if (test-str-weakness "hash-table-update! modifies existing binding"
+ weakness)
+ (let ((ht (alist->hash-table '((a . 1)) eq? #:weak weakness)))
+ (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))))))
+
+ (with-weakness-list weakness (list #f 'key 'value 'key-or-value)
+ (pass-if (test-str-weakness "hash-table-update! creates new binding when appropriate"
+ weakness)
+ (let ((ht (make-hash-table eq? #:weak weakness)))
+ (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))))))
+
+ (with-weakness-list weakness (list #f 'key 'value 'key-or-value)
+ (pass-if (test-str-weakness "hash-table-merge! functions properly"
+ weakness)
+ (let* ((ht1 (alist->hash-table '((a . 1) (b . 2)) eq? #:weak weakness))
+ (ht2 (alist->hash-table '((b . 3) (c . 4)) eq? #:weak weakness)))
+ (set! ht1 (hash-table-merge! ht1 ht2))
+ (and (= 3 (hash-table-size ht1))
+ (= 2 (hash-table-size ht2))
+ (lset= equal? '((a . 1) (b . 3) (c . 4)) (hash-table->alist ht1))
+ (lset= equal? '((b . 3) (c . 4)) (hash-table->alist ht2))))))
(pass-if "can use all arguments, including size"
(hash-table? (make-hash-table equal? hash #:weak 'key 31)))
-)
+ )
--
2.19.1
[-- Attachment #4: 0004-Reimplemented-RNRS-HASHTABLES-using-GENERIC-HASH-TAB.patch --]
[-- Type: text/x-patch, Size: 8579 bytes --]
From b9e4ebfeeb8d9b16a11effbe49f4a7e826844db8 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?J=C3=A9ssica=20Milar=C3=A9?= <jessymilare@gmail.com>
Date: Tue, 8 Jan 2019 22:06:10 -0200
Subject: [PATCH 4/5] Reimplemented (RNRS HASHTABLES) using GENERIC-HASH-TABLES
---
module/rnrs/hashtables.scm | 212 +++++++++++++------------------------
1 file changed, 75 insertions(+), 137 deletions(-)
diff --git a/module/rnrs/hashtables.scm b/module/rnrs/hashtables.scm
index 486452a2a..fd27c54c6 100644
--- a/module/rnrs/hashtables.scm
+++ b/module/rnrs/hashtables.scm
@@ -43,147 +43,85 @@
string-ci-hash
symbol-hash)
(import (rename (only (guile) string-hash-ci
- string-hash
- hashq
- hashv
- modulo
- *unspecified*
- @@)
+ string-hash
+ hashq
+ hashv
+ modulo
+ *unspecified*)
(string-hash-ci string-ci-hash))
(only (ice-9 optargs) define*)
- (rename (only (srfi :69) make-hash-table
- hash
- hash-by-identity
- hash-table-size
- hash-table-ref/default
- hash-table-set!
- hash-table-delete!
- hash-table-exists?
- hash-table-update!/default
- hash-table-copy
- hash-table-equivalence-function
- hash-table-hash-function
- hash-table-keys
- hash-table-fold)
- (hash equal-hash)
- (hash-by-identity symbol-hash))
- (only (ice-9 generic-hash-tables) hash-by-value)
+ (rename (only (ice-9 generic-hash-tables)
+ make-hash-table
+ hash-table?
+ hash-table-mutable?
+ hash
+ hash-by-identity
+ hash-by-value
+ hash-table-size
+ hash-table-ref/default
+ hash-table-set-single!
+ hash-table-delete-single!
+ hash-table-contains?
+ hash-table-update!/default
+ hash-table-clear!
+ hash-table-copy
+ hash-table-entry-vectors
+ hash-table-equivalence-function
+ hash-table-hash-function
+ hash-table-key-vector)
+ (make-hash-table gen:make-hash-table)
+ (hash equal-hash))
+ (only (srfi srfi-69) hash-table-set! hash-table-delete!)
(rnrs base (6))
(rnrs records procedural (6)))
+
+ (define hashtable? hash-table?)
+
+ (define hashtable-mutable? hash-table-mutable?)
+
+ (define symbol-hash hash-by-identity)
+
+ (define* (make-eq-hashtable #:optional capacity)
+ (if capacity
+ (gen:make-hash-table eq? #f #:capacity capacity)
+ (gen:make-hash-table eq? #f)))
+
+ (define* (make-eqv-hashtable #:optional capacity)
+ (if capacity
+ (gen:make-hash-table eqv? #f #:capacity capacity)
+ (gen:make-hash-table eqv? #f)))
+
+ (define* (make-hashtable hash-function equiv #:optional capacity)
+ (if capacity
+ (gen:make-hash-table equiv hash-function #:capacity capacity)
+ (gen:make-hash-table equiv hash-function)))
- (define r6rs:hashtable
- (make-record-type-descriptor
- 'r6rs:hashtable #f #f #t #t
- '#((mutable wrapped-table)
- (immutable orig-hash-function)
- (immutable mutable)
- (immutable type))))
-
- (define hashtable? (record-predicate r6rs:hashtable))
- (define make-r6rs-hashtable
- (record-constructor (make-record-constructor-descriptor
- r6rs:hashtable #f #f)))
- (define r6rs:hashtable-wrapped-table (record-accessor r6rs:hashtable 0))
- (define r6rs:hashtable-set-wrapped-table! (record-mutator r6rs:hashtable 0))
- (define r6rs:hashtable-orig-hash-function (record-accessor r6rs:hashtable 1))
- (define r6rs:hashtable-mutable? (record-accessor r6rs:hashtable 2))
- (define r6rs:hashtable-type (record-accessor r6rs:hashtable 3))
-
- (define hashtable-mutable? r6rs:hashtable-mutable?)
-
- ;; (define hash-by-value ((@@ (srfi srfi-69) caller-with-default-size) hashv))
- ;; (define (wrap-hash-function proc)
- ;; (lambda (key capacity) (modulo (proc key) capacity)))
-
- (define* (make-eq-hashtable #:optional k)
- (make-r6rs-hashtable
- (if k (make-hash-table eq? hashq k) (make-hash-table eq? symbol-hash))
- symbol-hash
- #t
- 'eq))
-
- (define* (make-eqv-hashtable #:optional k)
- (make-r6rs-hashtable
- (if k (make-hash-table eqv? hashv k) (make-hash-table eqv? hash-by-value))
- hash-by-value
- #t
- 'eqv))
-
- (define* (make-hashtable hash-function equiv #:optional k)
- (make-r6rs-hashtable
- (if k
- (make-hash-table equiv hash-function k)
- (make-hash-table equiv hash-function))
- hash-function
- #t
- 'custom))
-
- (define (hashtable-size hashtable)
- (hash-table-size (r6rs:hashtable-wrapped-table hashtable)))
-
- (define (hashtable-ref hashtable key default)
- (hash-table-ref/default
- (r6rs:hashtable-wrapped-table hashtable) key default))
-
- (define (hashtable-set! hashtable key obj)
- (if (r6rs:hashtable-mutable? hashtable)
- (hash-table-set! (r6rs:hashtable-wrapped-table hashtable) key obj)
- (assertion-violation
- 'hashtable-set! "Hashtable is immutable." hashtable)))
-
- (define (hashtable-delete! hashtable key)
- (if (r6rs:hashtable-mutable? hashtable)
- (hash-table-delete! (r6rs:hashtable-wrapped-table hashtable) key))
- *unspecified*)
-
- (define (hashtable-contains? hashtable key)
- (hash-table-exists? (r6rs:hashtable-wrapped-table hashtable) key))
-
- (define (hashtable-update! hashtable key proc default)
- (if (r6rs:hashtable-mutable? hashtable)
- (hash-table-update!/default
- (r6rs:hashtable-wrapped-table hashtable) key proc default))
- *unspecified*)
-
- (define* (hashtable-copy hashtable #:optional mutable)
- (make-r6rs-hashtable
- (hash-table-copy (r6rs:hashtable-wrapped-table hashtable))
- (r6rs:hashtable-orig-hash-function hashtable)
- (and mutable #t)
- (r6rs:hashtable-type hashtable)))
-
- (define* (hashtable-clear! hashtable #:optional k)
- (if (r6rs:hashtable-mutable? hashtable)
- (let* ((ht (r6rs:hashtable-wrapped-table hashtable))
- (equiv (hash-table-equivalence-function ht))
- (hash-function (r6rs:hashtable-orig-hash-function hashtable)))
- (r6rs:hashtable-set-wrapped-table!
- hashtable
- (if k
- (make-hash-table equiv hash-function k)
- (make-hash-table equiv hash-function)))))
- *unspecified*)
-
- (define (hashtable-keys hashtable)
- (list->vector (hash-table-keys (r6rs:hashtable-wrapped-table hashtable))))
-
- (define (hashtable-entries hashtable)
- (let* ((ht (r6rs:hashtable-wrapped-table hashtable))
- (size (hash-table-size ht))
- (keys (make-vector size))
- (vals (make-vector size)))
- (hash-table-fold (r6rs:hashtable-wrapped-table hashtable)
- (lambda (k v i)
- (vector-set! keys i k)
- (vector-set! vals i v)
- (+ i 1))
- 0)
- (values keys vals)))
-
- (define (hashtable-equivalence-function hashtable)
- (hash-table-equivalence-function (r6rs:hashtable-wrapped-table hashtable)))
+ (define hashtable-size hash-table-size)
+
+ (define hashtable-ref hash-table-ref/default)
+
+ (define hashtable-set! hash-table-set!)
+
+ (define hashtable-delete! hash-table-delete!)
+
+ (define hashtable-contains? hash-table-contains?)
+
+ (define hashtable-update! hash-table-update!/default)
+
+ (define* (hashtable-copy ht #:optional mutable)
+ (hash-table-copy ht #:mutable mutable))
+
+ (define hashtable-clear! hash-table-clear!)
+
+ (define hashtable-keys hash-table-key-vector)
+
+ (define hashtable-entries hash-table-entry-vectors)
+
+ (define hashtable-equivalence-function hash-table-equivalence-function)
(define (hashtable-hash-function hashtable)
- (case (r6rs:hashtable-type hashtable)
- ((eq eqv) #f)
- (else (r6rs:hashtable-orig-hash-function hashtable)))))
+ (let ((hash-function (hash-table-hash-function hashtable)))
+ (cond ((or (eq? hash-by-identity hash-function)
+ (eq? hash-by-value hash-function))
+ #f)
+ (else hash-function)))))
--
2.19.1
[-- Attachment #5: 0005-Implemented-SRFI-126-using-GENERIC-HASH-TABLES.patch --]
[-- Type: text/x-patch, Size: 27211 bytes --]
From 575a3316916fdddbc30a404f190277e1b5c0e71a Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?J=C3=A9ssica=20Milar=C3=A9?= <jessymilare@gmail.com>
Date: Tue, 8 Jan 2019 22:07:02 -0200
Subject: [PATCH 5/5] Implemented SRFI-126 using GENERIC-HASH-TABLES
---
module/Makefile.am | 1 +
module/srfi/srfi-126.scm | 215 +++++++++++++++++++++
test-suite/Makefile.am | 1 +
test-suite/tests/srfi-126.test | 344 +++++++++++++++++++++++++++++++++
4 files changed, 561 insertions(+)
create mode 100644 module/srfi/srfi-126.scm
create mode 100644 test-suite/tests/srfi-126.test
diff --git a/module/Makefile.am b/module/Makefile.am
index 6dba87ce8..6e739fed0 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -294,6 +294,7 @@ SOURCES = \
srfi/srfi-88.scm \
srfi/srfi-98.scm \
srfi/srfi-111.scm \
+ srfi/srfi-126.scm \
\
statprof.scm \
\
diff --git a/module/srfi/srfi-126.scm b/module/srfi/srfi-126.scm
new file mode 100644
index 000000000..7a6594434
--- /dev/null
+++ b/module/srfi/srfi-126.scm
@@ -0,0 +1,215 @@
+;;; 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 3 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
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; 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
+\f
+
+(define-module (srfi srfi-126)
+ #:use-module (srfi srfi-1)
+ #:use-module ((ice-9 generic-hash-tables) #:prefix gen:)
+ #:use-module ((rnrs hashtables)
+ #:select (hashtable?
+ hashtable-contains? hashtable-mutable?
+ hashtable-set! hashtable-delete! hashtable-clear!
+ hashtable-size
+ hashtable-keys hashtable-entries
+ hashtable-equivalence-function
+ hashtable-hash-function
+ equal-hash symbol-hash
+ string-hash string-ci-hash))
+ #:re-export (hashtable?
+ hashtable-contains? hashtable-mutable?
+ hashtable-set! hashtable-delete! hashtable-clear!
+ hashtable-size
+ hashtable-keys hashtable-entries
+ hashtable-equivalence-function
+ hashtable-hash-function
+ equal-hash symbol-hash
+ string-hash string-ci-hash)
+ #:export (make-eq-hashtable
+ make-eqv-hashtable make-hashtable
+ alist->eq-hashtable alist->eqv-hashtable alist->hashtable
+ hashtable-weakness
+ hashtable-ref hashtable-lookup
+ hashtable-update! hashtable-intern!
+ hashtable-copy hashtable-empty-copy
+ hashtable-values
+ hashtable-key-list hashtable-value-list hashtable-entry-lists
+ hashtable-walk hashtable-update-all!
+ hashtable-prune! hashtable-merge! hashtable-sum
+ hashtable-map->lset
+ hashtable-find hashtable-empty?
+ hashtable-pop!
+ hashtable-inc! hashtable-dec!
+ hash-salt))
+
+(cond-expand-provide (current-module) '(srfi-126))
+
+(define hashtable? gen:hash-table?)
+
+(define* (make-hashtable hash-function equiv-function
+ #:optional capacity weakness)
+ "Creates a new hash table. EQUIV-FUNCTION is used as the comparison
+function and HASH-FUNCTION, if provided and not false, is used as the
+hash function, otherwise a suitable hash-function for the hash table is
+guessed or, if one can't be guessed, an error is signaled. WEAKNESS
+should be either #f, WEAK-KEY, WEAK-VALUE or WEAK-KEY-AND-VALUE.
+CAPACITY is the minimal number of buckets of the hash table."
+ (gen:make-hash-table equiv-function (if (pair? hash-function)
+ (car hash-function)
+ hash-function)
+ #:capacity (or capacity 1)
+ #:weakness weakness))
+
+(define* (make-eq-hashtable #:optional capacity weakness)
+ (gen:make-hash-table eq? gen:hash-by-identity
+ #:capacity (or capacity 1)
+ #:weakness weakness))
+
+(define* (make-eqv-hashtable #:optional capacity weakness)
+ (gen:make-hash-table eqv? gen:hash-by-value
+ #:capacity (or capacity 1)
+ #:weakness weakness))
+
+(define alist->hashtable
+ (case-lambda
+ ((hash-function equiv-function alist)
+ (gen:alist->hash-table alist equiv-function
+ (if (pair? hash-function)
+ (car hash-function)
+ hash-function)))
+ ((hash-function equiv-function capacity alist)
+ (gen:alist->hash-table alist equiv-function
+ (if (pair? hash-function)
+ (car hash-function)
+ hash-function)
+ #:capacity (or capacity 1)))
+ ((hash-function equiv-function capacity weakness alist)
+ (gen:alist->hash-table alist equiv-function
+ (if (pair? hash-function)
+ (car hash-function)
+ hash-function)
+ #:capacity (or capacity 1)
+ #:weakness weakness))))
+
+(define (alist->eq-hashtable . args)
+ (apply alist->hashtable #f eq? args))
+
+(define (alist->eqv-hashtable . args)
+ (apply alist->hashtable #f eqv? args))
+
+(define* (hashtable-ref ht key #:optional default)
+ (if default
+ (gen:hash-table-ref/default ht key default)
+ (gen:hash-table-ref ht key)))
+
+;; (define hashtable-contains? rnrs:hashtable-contains?)
+;; (define hashtable-set! rnrs:hashtable-set!)
+;; (define hashtable-delete! rnrs:hashtable-delete!)
+
+(define (hashtable-lookup hashtable key)
+ (let* ((found? #t)
+ (value (gen:hash-table-ref hashtable key
+ (lambda () (set! found? #f) #f))))
+ (values value found?)))
+
+(define* (hashtable-update! ht key modifier #:optional default)
+ (if default
+ (gen:hash-table-update!/default ht key modifier default)
+ (gen:hash-table-update! ht key modifier)))
+
+(define hashtable-intern! gen:hash-table-intern!)
+
+(define* (hashtable-copy hashtable #:optional mutable
+ (weakness (hashtable-weakness hashtable)))
+ (gen:hash-table-copy hashtable #:mutable mutable #:weakness weakness))
+
+;; (define hashtable-clear! rnrs:hashtable-clear!)
+
+(define* (hashtable-empty-copy hashtable #:optional capacity
+ (weakness (hashtable-weakness hashtable)))
+ (let ((capacity (case capacity
+ ((#f) 1)
+ ((#t) (hashtable-size hashtable))
+ (else capacity))))
+ (gen:hash-table-empty-copy hashtable #:capacity capacity #:weakness weakness)))
+
+\f
+;;;; Accessing whole tables
+
+;; (define hashtable-size rnrs:hashtable-size)
+;; (define hashtable-keys gen:hash-table-key-vector)
+(define hashtable-values gen:hash-table-value-vector)
+;; (define hashtable-entries rnrs:hashtable-entries)
+(define hashtable-key-list gen:hash-table-keys)
+(define hashtable-value-list gen:hash-table-values)
+(define hashtable-entry-lists gen:hash-table-entries)
+(define hashtable->alist gen:hash-table->alist)
+
+(define (hashtable-walk hashtable proc)
+ (gen:hash-table-for-each proc hashtable))
+
+(define (hashtable-update-all! hashtable proc)
+ (gen:hash-table-map! proc hashtable))
+
+(define (hashtable-prune! hashtable proc)
+ (gen:hash-table-prune! proc hashtable))
+
+(define (hashtable-sum hashtable init proc)
+ (gen:hash-table-fold proc init hashtable))
+
+(define (hashtable-merge! ht other-ht)
+ (gen:hash-table-for-each (lambda (k v) (hashtable-set! ht k v))
+ other-ht)
+ ht)
+
+(define (hashtable-map->lset hashtable proc)
+ (gen:hash-table-map->list proc hashtable))
+
+(define (hashtable-find hashtable proc)
+ (call/cc (lambda (return)
+ (gen:hash-table-for-each (lambda (k v)
+ (when (proc k v) (return k v #t)))
+ hashtable)
+ (values *unspecified* *unspecified* #f))))
+
+(define hashtable-empty? gen:hash-table-empty?)
+(define hashtable-pop! gen:hash-table-pop!)
+
+(define* (hashtable-inc! hashtable key #:optional (number 1))
+ (hashtable-update! hashtable key (lambda (v) (+ v number)) 0))
+
+(define* (hashtable-dec! hashtable key #:optional (number 1))
+ (hashtable-update! hashtable key (lambda (v) (- v number)) 0))
+
+(define hashtable-weakness gen:hash-table-weakness)
+;; (define hashtable-mutable? rnrs:hashtable-mutable?)
+;; (define hashtable-equivalence-function rnrs:hashtable-equivalence-function)
+;; (define hashtable-hash-function rnrs:hashtable-hash-function)
+;; (define equal-hash rnrs:equal-hash)
+;; (define string-hash rnrs:string-hash)
+;; (define string-ci-hash rnrs:string-ci-hash)
+;; (define symbol-hash rnrs:symbol-hash)
+
+(define *hash-salt*
+ (let ((seed (getenv "SRFI_126_HASH_SEED")))
+ (if (or (not seed) (string=? seed ""))
+ (random most-positive-fixnum)
+ (modulo (string-hash seed) most-positive-fixnum))))
+
+(define (hash-salt) *hash-salt*)
+
+;; eof
diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am
index e154602a7..f0ad8bb91 100644
--- a/test-suite/Makefile.am
+++ b/test-suite/Makefile.am
@@ -162,6 +162,7 @@ SCM_TESTS = tests/00-initial-env.test \
tests/srfi-98.test \
tests/srfi-105.test \
tests/srfi-111.test \
+ tests/srfi-126.test \
tests/srfi-4.test \
tests/srfi-9.test \
tests/statprof.test \
diff --git a/test-suite/tests/srfi-126.test b/test-suite/tests/srfi-126.test
new file mode 100644
index 000000000..e6a4e66a9
--- /dev/null
+++ b/test-suite/tests/srfi-126.test
@@ -0,0 +1,344 @@
+;;;; srfi-69.test --- Test suite for SRFI 69 -*- scheme -*-
+;;;;
+;;;; 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 3 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
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; 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
+
+;;; The following tests are the tests from SRFI-126 reference
+;;; implementation ported to Guile test suite.
+
+(define-module (test-srfi-126)
+ #:use-module (test-suite lib)
+ #:use-module (srfi srfi-126)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-2)
+ #:use-module (srfi srfi-8))
+
+(define-syntax with-elt-in-list
+ (syntax-rules ()
+ ((with-elt-in-list arg arg-list expr ...)
+ (let loop ((arg-list* arg-list))
+ (or (null? arg-list*)
+ (and (let ((arg (car arg-list*)))
+ expr ...)
+ (loop (cdr arg-list*))))))))
+
+(define (exact-integer? obj)
+ (and (integer? obj) (exact? obj)))
+
+(define (test-str-weakness str weakness)
+ (if (not weakness) str (format #f "~a (weakness: ~a)" str weakness)))
+
+
+
+(with-test-prefix "SRFI-126"
+
+ ;; The following tests are done once with each kind of weakness
+ (with-elt-in-list weakness (list #f 'weak-key 'weak-value 'weak-key-and-value)
+
+ (with-test-prefix "eq"
+ (let ((tables (list (and (not weakness)
+ (make-eq-hashtable))
+ (make-eq-hashtable 10 weakness)
+ (make-eq-hashtable #f weakness)
+ (make-hashtable #f eq? #f weakness)
+ (and (not weakness)
+ (alist->eq-hashtable '((a . b) (c . d))))
+ (alist->eq-hashtable 10 weakness '((a . b) (c . d)))
+ (alist->eq-hashtable #f weakness '((a . b) (c . d))))))
+ (do ((tables tables (cdr tables))
+ (i 0 (+ i 1)))
+ ((null? tables))
+ (and-let* ((table (car tables)))
+ (with-test-prefix (test-str-weakness (format #f "table ~a" i) weakness)
+ (pass-if (hashtable? table))
+ (pass-if-equal #f (hashtable-hash-function table))
+ (pass-if-equal eq? (hashtable-equivalence-function table))
+ (pass-if-equal weakness (hashtable-weakness table))
+ (pass-if (hashtable-mutable? table)))))))
+
+ (with-test-prefix "eqv"
+ (let ((tables (list (and (not weakness)
+ (make-eqv-hashtable))
+ (make-eqv-hashtable 10 weakness)
+ (make-eqv-hashtable #f weakness)
+ (make-hashtable #f eqv? #f weakness)
+ (and (not weakness)
+ (alist->eqv-hashtable '((a . b) (c . d))))
+ (alist->eqv-hashtable 10 weakness '((a . b) (c . d)))
+ (alist->eqv-hashtable #f weakness '((a . b) (c . d))))))
+ (do ((tables tables (cdr tables))
+ (i 0 (+ i 1)))
+ ((null? tables))
+ (and-let* ((table (car tables)))
+ (with-test-prefix (test-str-weakness (format #f "table ~a" i) weakness)
+ (pass-if (hashtable? table))
+ (pass-if-equal #f (hashtable-hash-function table))
+ (pass-if-equal eqv? (hashtable-equivalence-function table))
+ (pass-if-equal weakness (hashtable-weakness table))
+ (pass-if (hashtable-mutable? table)))))))
+
+ (with-test-prefix "equal"
+ (let ((tables (list (and (not weakness)
+ (make-hashtable equal-hash equal?))
+ (make-hashtable equal-hash equal? 10 weakness)
+ (make-hashtable equal-hash equal? #f weakness)
+ (and (not weakness)
+ (alist->hashtable equal-hash equal? '((a . b) (c . d))))
+ (alist->hashtable equal-hash equal? 10 weakness
+ '((a . b) (c . d)))
+ (alist->hashtable equal-hash equal? #f weakness
+ '((a . b) (c . d)))
+ (and (not weakness)
+ (make-hashtable (cons equal-hash equal-hash) equal?)))))
+ (do ((tables tables (cdr tables))
+ (i 0 (+ i 1)))
+ ((null? tables))
+ (and-let* ((table (car tables)))
+ (with-test-prefix (test-str-weakness (format #f "table ~a" i) weakness)
+ (pass-if (hashtable? table))
+ (pass-if-equal equal-hash (hashtable-hash-function table))
+ (pass-if-equal equal? (hashtable-equivalence-function table))
+ (pass-if-equal weakness (hashtable-weakness table))
+ (pass-if (hashtable-mutable? table)))))))
+
+ (with-test-prefix "alist"
+ (let ((tables (list (and (not weakness)
+ (alist->eq-hashtable '((a . b) (a . c))))
+ (and (not weakness)
+ (alist->eqv-hashtable '((a . b) (a . c))))
+ (and (not weakness)
+ (alist->hashtable equal-hash equal?
+ '((a . b) (a . c))))
+ (alist->eq-hashtable #f weakness '((a . b) (a . c)))
+ (alist->eqv-hashtable #f weakness '((a . b) (a . c)))
+ (alist->hashtable equal-hash equal? #f weakness
+ '((a . b) (a . c))))))
+ (do ((tables tables (cdr tables))
+ (i 0 (+ i 1)))
+ ((null? tables))
+ (and-let* ((table (car tables)))
+ (with-test-prefix (test-str-weakness (format #f "table ~a" i) weakness)
+ (pass-if-equal 'b (hashtable-ref table 'a)))))))
+
+ (with-test-prefix "procedures"
+ (with-test-prefix "basics"
+ (let ((table (make-eq-hashtable #f weakness)))
+ (with-test-prefix "ref"
+ (pass-if-exception "key not found"
+ '(misc-error . "^Key not in table")
+ (hashtable-ref table 'a))
+ (pass-if-equal 'b (hashtable-ref table 'a 'b))
+ (pass-if (not (hashtable-contains? table 'a)))
+ (pass-if-equal 0 (hashtable-size table)))
+ (with-test-prefix "set"
+ (hashtable-set! table 'a 'c)
+ (pass-if-equal 'c (hashtable-ref table 'a))
+ (pass-if-equal 'c (hashtable-ref table 'a 'b))
+ (pass-if (hashtable-contains? table 'a))
+ (pass-if-equal 1 (hashtable-size table)))
+ (with-test-prefix "delete"
+ (hashtable-delete! table 'a)
+ (pass-if-exception "key not found"
+ '(misc-error . "^Key not in table")
+ (hashtable-ref table 'a))
+ (pass-if-equal 'b (hashtable-ref table 'a 'b))
+ (pass-if (not (hashtable-contains? table 'a)))
+ (pass-if-equal 0 (hashtable-size table))))))
+
+ (with-test-prefix "advanced"
+ (let ((table (make-eq-hashtable)))
+ (with-test-prefix "lookup"
+ (receive (x found?) (hashtable-lookup table 'a)
+ (pass-if (not found?))))
+ (with-test-prefix "update"
+ (pass-if-exception "key not found"
+ '(misc-error . "^Key not in table")
+ (hashtable-update! table 'a (lambda (x) (+ x 1))))
+ (hashtable-update! table 'a (lambda (x) (+ x 1)) 0)
+ (receive (x found?) (hashtable-lookup table 'a)
+ (pass-if-equal 1 x)
+ (pass-if found?))
+ (hashtable-update! table 'a (lambda (x) (+ x 1)))
+ (receive (x found?) (hashtable-lookup table 'a)
+ (pass-if-equal x 2)
+ (pass-if found?))
+ (hashtable-update! table 'a (lambda (x) (+ x 1)) 0)
+ (receive (x found?) (hashtable-lookup table 'a)
+ (pass-if-equal x 3)
+ (pass-if found?)))
+ (with-test-prefix "intern"
+ (pass-if-equal 0 (hashtable-intern! table 'b (lambda () 0)))
+ (pass-if-equal 0 (hashtable-intern! table 'b (lambda () 1))))))
+
+ (with-test-prefix "copy/clear"
+ (let ((table (alist->hashtable equal-hash equal? #f weakness '((a . b)))))
+ (with-test-prefix "copy"
+ (let ((table2 (hashtable-copy table)))
+ (pass-if-equal equal-hash (hashtable-hash-function table2))
+ (pass-if-equal equal? (hashtable-equivalence-function table2))
+ (pass-if-equal 'b (hashtable-ref table2 'a))
+ (pass-if-equal weakness (hashtable-weakness table2))
+ (pass-if-exception "set! immutable table"
+ '(misc-error . "^Hash table is not mutable")
+ (hashtable-set! table2 'a 'c)))
+ (let ((table2 (hashtable-copy table #f)))
+ (pass-if-equal equal-hash (hashtable-hash-function table2))
+ (pass-if-equal equal? (hashtable-equivalence-function table2))
+ (pass-if-equal 'b (hashtable-ref table2 'a))
+ (pass-if-equal weakness (hashtable-weakness table2))
+ (pass-if-exception "set! immutable table"
+ '(misc-error . "^Hash table is not mutable")
+ (hashtable-set! table2 'a 'c)))
+ (let ((table2 (hashtable-copy table #t)))
+ (pass-if-equal equal-hash (hashtable-hash-function table2))
+ (pass-if-equal equal? (hashtable-equivalence-function table2))
+ (pass-if-equal 'b (hashtable-ref table2 'a))
+ (pass-if-equal weakness (hashtable-weakness table2))
+ (hashtable-set! table2 'a 'c)
+ (pass-if-equal 'c (hashtable-ref table2 'a)))
+ (let ((table2 (hashtable-copy table #f #f)))
+ (pass-if-equal equal-hash (hashtable-hash-function table2))
+ (pass-if-equal equal? (hashtable-equivalence-function table2))
+ (pass-if-equal #f (hashtable-weakness table2))))
+
+ (with-test-prefix "clear"
+ (let ((table2 (hashtable-copy table #t)))
+ (hashtable-clear! table2)
+ (pass-if-equal 0 (hashtable-size table2)))
+ (let ((table2 (hashtable-copy table #t)))
+ (hashtable-clear! table2 10)
+ (pass-if-equal 0 (hashtable-size table2))))
+
+ (with-test-prefix "empty-copy"
+ (let ((table2 (hashtable-empty-copy table)))
+ (pass-if-equal equal-hash (hashtable-hash-function table2))
+ (pass-if-equal equal? (hashtable-equivalence-function table2))
+ (pass-if-equal 0 (hashtable-size table2)))
+ (let ((table2 (hashtable-empty-copy table 10)))
+ (pass-if-equal equal-hash (hashtable-hash-function table2))
+ (pass-if-equal equal? (hashtable-equivalence-function table2))
+ (pass-if-equal 0 (hashtable-size table2))))))
+
+ (with-test-prefix "keys/values"
+ (let ((table (alist->eq-hashtable '((a . b) (c . d)))))
+ (pass-if (lset= eq? '(a c) (vector->list (hashtable-keys table))))
+ (pass-if (lset= eq? '(b d) (vector->list (hashtable-values table))))
+ (receive (keys values) (hashtable-entries table)
+ (pass-if (lset= eq? '(a c) (vector->list keys)))
+ (pass-if (lset= eq? '(b d) (vector->list values))))
+ (pass-if (lset= eq? '(a c) (hashtable-key-list table)))
+ (pass-if (lset= eq? '(b d) (hashtable-value-list table)))
+ (receive (keys values) (hashtable-entry-lists table)
+ (pass-if (lset= eq? '(a c) keys))
+ (pass-if (lset= eq? '(b d) values)))))
+
+ (with-test-prefix "iteration"
+ (with-test-prefix "walk"
+ (let ((keys '())
+ (values '()))
+ (hashtable-walk (alist->eq-hashtable '((a . b) (c . d)))
+ (lambda (k v)
+ (set! keys (cons k keys))
+ (set! values (cons v values))))
+ (pass-if (lset= eq? '(a c) keys))
+ (pass-if (lset= eq? '(b d) values))))
+
+ (with-test-prefix "update-all"
+ (let ((table (alist->eq-hashtable '((a . b) (c . d)))))
+ (hashtable-update-all! table
+ (lambda (k v)
+ (string->symbol (string-append (symbol->string v) "x"))))
+ (pass-if (lset= eq? '(a c) (hashtable-key-list table)))
+ (pass-if (lset= eq? '(bx dx) (hashtable-value-list table)))))
+
+ (with-test-prefix "prune"
+ (let ((table (alist->eq-hashtable '((a . b) (c . d)))))
+ (hashtable-prune! table (lambda (k v) (eq? k 'a)))
+ (pass-if (not (hashtable-contains? table 'a)))
+ (pass-if (hashtable-contains? table 'c))))
+
+ (with-test-prefix "merge"
+ (let ((table (alist->eq-hashtable '((a . b) (c . d))))
+ (table2 (alist->eq-hashtable '((a . x) (e . f)))))
+ (hashtable-merge! table table2)
+ (pass-if (lset= eq? '(a c e) (hashtable-key-list table)))
+ (pass-if (lset= eq? '(x d f) (hashtable-value-list table)))))
+
+ (with-test-prefix "sum"
+ (let ((table (alist->eq-hashtable '((a . b) (c . d)))))
+ (pass-if (lset= eq? '(a b c d)
+ (hashtable-sum table '()
+ (lambda (k v acc)
+ (lset-adjoin eq? acc k v)))))))
+
+ (with-test-prefix "map->lset"
+ (let ((table (alist->eq-hashtable '((a . b) (c . d)))))
+ (pass-if (lset= equal? '((a . b) (c . d))
+ (hashtable-map->lset table cons)))))
+
+ (with-test-prefix "find"
+ (let ((table (alist->eq-hashtable '((a . b) (c . d)))))
+ (receive (k v f?) (hashtable-find table
+ (lambda (k v)
+ (eq? k 'a)))
+ (pass-if (and f? (eq? k 'a) (eq? v 'b))))
+ (receive (k v f?) (hashtable-find table (lambda (k v) #f))
+ (pass-if (not f?)))))
+
+ (with-test-prefix "misc"
+
+ (with-test-prefix "empty?"
+ (pass-if (hashtable-empty? (alist->eq-hashtable '())))
+ (pass-if (not (hashtable-empty? (alist->eq-hashtable '((a . b)))))))
+
+ (with-test-prefix "pop!"
+ (pass-if-exception ""
+ '(misc-error . "^Hash table is empty")
+ (hashtable-pop! (make-eq-hashtable)))
+ (let ((table (alist->eq-hashtable '((a . b)))))
+ (receive (k v) (hashtable-pop! table)
+ (pass-if-equal 'a k)
+ (pass-if-equal 'b v)
+ (pass-if (hashtable-empty? table)))))
+
+ (with-test-prefix "inc!"
+ (let ((table (alist->eq-hashtable '((a . 0)))))
+ (hashtable-inc! table 'a)
+ (pass-if-equal 1 (hashtable-ref table 'a))
+ (hashtable-inc! table 'a 2)
+ (pass-if-equal 3 (hashtable-ref table 'a))))
+
+ (with-test-prefix "dec!"
+ (let ((table (alist->eq-hashtable '((a . 0)))))
+ (hashtable-dec! table 'a)
+ (pass-if-equal -1 (hashtable-ref table 'a))
+ (hashtable-dec! table 'a 2)
+ (pass-if-equal -3 (hashtable-ref table 'a))))))
+
+ (with-test-prefix "hashing"
+ (pass-if (exact-integer? (hash-salt)))
+ (pass-if (not (negative? (hash-salt))))
+ (pass-if (= (hash-salt) (hash-salt)))
+ (pass-if (= (equal-hash (list "foo" 'bar 42))
+ (equal-hash (list "foo" 'bar 42))))
+ (pass-if (= (string-hash (string-copy "foo"))
+ (string-hash (string-copy "foo"))))
+ (pass-if (= (string-ci-hash (string-copy "foo"))
+ (string-ci-hash (string-copy "FOO"))))
+ (pass-if (= (symbol-hash (string->symbol "foo"))
+ (symbol-hash (string->symbol "foo")))))
+ )
+ )
--
2.19.1
[-- Attachment #6: 0002-Implemented-GENERIC-HASH-TABLES-module.patch --]
[-- Type: text/x-patch, Size: 64604 bytes --]
From 47256c0cbff9b1ca6e268d5d4407671807edc202 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?J=C3=A9ssica=20Milar=C3=A9?= <jessymilare@gmail.com>
Date: Tue, 8 Jan 2019 21:58:37 -0200
Subject: [PATCH 2/5] Implemented GENERIC-HASH-TABLES module.
This module implements an interface to intermediate hash tables and can
be used to implement SRFI-69, SRFI-125, SRFI-126 and R6RS hash table
libraries. That way, we avoid duplication of code, missing features and
incompatibilities. It reuses current SRFI-69 code and its procedures are
mostly based on SRFI-125 specifications with some changes. It does not
depend on SRFI-128: instead of using comparators, the procedures accept
the same arguments that are accepted by MAKE-HASH-TABLE. The weakness
argument is as specified by SRFI 126.
---
module/Makefile.am | 1 +
module/ice-9/generic-hash-tables.scm | 915 ++++++++++++++++++++++
test-suite/Makefile.am | 1 +
test-suite/tests/generic-hash-tables.test | 415 ++++++++++
4 files changed, 1332 insertions(+)
create mode 100644 module/ice-9/generic-hash-tables.scm
create mode 100644 test-suite/tests/generic-hash-tables.test
diff --git a/module/Makefile.am b/module/Makefile.am
index c72fb9228..6dba87ce8 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -66,6 +66,7 @@ SOURCES = \
ice-9/futures.scm \
ice-9/gap-buffer.scm \
ice-9/getopt-long.scm \
+ ice-9/generic-hash-tables.scm \
ice-9/hash-table.scm \
ice-9/hcons.scm \
ice-9/history.scm \
diff --git a/module/ice-9/generic-hash-tables.scm b/module/ice-9/generic-hash-tables.scm
new file mode 100644
index 000000000..033c3ecda
--- /dev/null
+++ b/module/ice-9/generic-hash-tables.scm
@@ -0,0 +1,915 @@
+;;; generic-hash-tables.scm --- Intermediate 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 3 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
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; 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
+\f
+
+;;;; Commentary by Jessica Milare 2018
+
+;; This implementation was created on top of SRFI-69 (old) Guile code,
+;; extending it to support SRFI-125 specifications and intended to be
+;; used by SRFI-69, SRFI-125, SRFI-126 and R6RS. One single hash tables
+;; implementation could be exported to all of these libraries, avoiding
+;; duplication of code, missing features and incompatibilities.
+;;
+;; Hash tables here have 2 hash functions, one internal (that is used by
+;; Guile) and one external (that is returned by hash-table-hash-function).
+;; Internal hash functions accepts two arguments, while external functions
+;; accept one argument (and possibly more optional arguments).
+
+;;; Code:
+\f
+;;;; Module definition & exports
+
+(define-module (ice-9 generic-hash-tables)
+ #:use-module (srfi srfi-1) ;alist-cons,second&c,assoc
+ #:use-module (srfi srfi-8) ;receive
+ #:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-9 gnu)
+ #:use-module (ice-9 format)
+ #:export (;; Type constructors & predicate
+ make-hash-table
+ hash-table? hash-table hash-table-unfold alist->hash-table
+ ;; Reflective queries
+ hash-table-equivalence-function hash-table-hash-function
+ hash-table-weakness hash-table-key-weakness hash-table-value-weakness
+ ;; Predicates
+ hash-table-mutable? hash-table-contains?
+ hash-table-empty? hash-table=?
+ ;; Accessors
+ hash-table-ref hash-table-ref/default
+ ;; Mutators
+ hash-table-set! hash-table-set-single!
+ hash-table-delete! hash-table-delete-single!
+ hash-table-intern! hash-table-intern!/default
+ hash-table-update! hash-table-update!/default
+ hash-table-pop! hash-table-clear!
+ ;; The whole hash table
+ hash-table-size hash-table-find hash-table-count
+ hash-table-keys hash-table-values hash-table-entries
+ hash-table-key-vector hash-table-value-vector hash-table-entry-vectors
+ ;; Mapping and folding
+ hash-table-map hash-table-for-each hash-table-map! hash-table-map->list
+ hash-table-fold hash-table-prune!
+ ;; Copying
+ hash-table-copy hash-table-empty-copy
+ ;; Conversion
+ hash-table->alist
+ ;; Hash tables as sets
+ hash-table-union! hash-table-intersection! hash-table-difference!
+ hash-table-xor!
+ ;; Hashing
+ string-ci-hash hash-by-identity hash-by-value hash)
+ #:re-export (string-hash)
+ #:replace (hash make-hash-table hash-table?))
+
+\f
+;;;; Internal helper macros
+
+;; Define these first, so the compiler will pick them up.
+
+;; 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 (ht-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 ((,(third bindings) (ht-real-table ,ht-var))
+ (,(first bindings) (ht-hash-function ,ht-var))
+ (,(second bindings) (ht-associator ,ht-var)))
+ . ,body-forms))
+
+(define-syntax assert-mutable
+ (syntax-rules ()
+ ((assert-mutable ht)
+ (or (hash-table-mutable? ht)
+ (error "Hash table is not mutable" ht)))))
+
+\f
+;;;; Hashing
+
+;;; SRFI-125 and R6RS hash functions are supposed to accept only one
+;;; argument, but Guile standard hash tables needs two args.
+;;; Therefore, the hash functions inside the hash table always accepts
+;;; one (required) argument and at least one possible argument, which
+;;; must be a fixnum.
+
+;;; 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))
+(define hash-by-value (caller-with-default-size hashv))
+
+(define (wrap-hash-function hash-function)
+ (lambda* (obj size)
+ (modulo (hash-function obj) size)))
+
+\f
+;;;; Reflective queries, construction, predicate
+
+(define (get-hash-functions equiv-function hash-function)
+ "Returns an internal and an external hash function."
+ (cond
+ (hash-function (cond
+ ;; SRFI-69 should give HASH as default hash-function.
+ ((or (eq? (@ (guile) hash) hash-function)
+ (eq? hash hash-function))
+ (values (@ (guile) hash) hash-function))
+ ;; These procedures don't need to be wrapped.
+ ((or (eq? string-hash hash-function)
+ (eq? string-ci-hash hash-function))
+ (values hash-function hash-function))
+ ((or (eq? hashq hash-function)
+ (eq? hash-by-identity hash-function))
+ (values hashq hash-function))
+ ((or (eq? hashv hash-function)
+ (eq? hash-by-value hash-function))
+ (values hashv hash-function))
+ ;; Otherwise, wrap the given function.
+ (else (values (wrap-hash-function hash-function) hash-function))))
+ ((eq? equal? equiv-function) (values (@ (guile) hash) hash))
+ ((eq? eq? equiv-function) (values hashq hash-by-identity))
+ ((eq? eqv? equiv-function) (values hashv hash-by-value))
+ ((eq? string=? equiv-function) (values string-hash string-hash))
+ ((eq? string-ci=? equiv-function) (values string-ci-hash string-ci-hash))
+ (else (error "A suitable hash function could not be determined" equiv-function))))
+
+(define (guile-ht-ctor weakness)
+ "Answer the Guile HT constructor for the given WEAKNESS, where
+WEAKNESS is as specified by SRFI-126."
+ (case weakness
+ ((#f) (@ (guile) make-hash-table))
+ ((weak-key) make-weak-key-hash-table)
+ ((weak-value) make-weak-value-hash-table)
+ ((weak-key-and-value) make-doubly-weak-hash-table)
+ ((ephemeral-key ephemeral-value ephemeral-key-and-value)
+ (error "Unsupported hash table weakness" weakness))
+ (else (error "Invalid hash table weakness" weakness))))
+
+(define (equivalence-proc->associator equiv-function)
+ "Answer an `assoc'-like procedure that compares the argument key to
+alist keys with EQUIV-FUNCTION."
+ (cond ((or (eq? equal? equiv-function)
+ (eq? string=? equiv-function)) (@ (guile) assoc))
+ ((eq? eq? equiv-function) assq)
+ ((eq? eqv? equiv-function) assv)
+ (else (lambda (item alist)
+ (assoc item alist equiv-function)))))
+
+(define-record-type generic-hash-table
+ (make-generic-hash-table real-table hash-function associator weakness
+ mutable? size equivalence-function original-hash-function)
+ hash-table?
+ ;; These three are the most accessed fields.
+ (real-table ht-real-table ht-real-table!)
+ (hash-function ht-hash-function)
+ (associator ht-associator)
+ ;; Weak hash tables don't use handles and don't update ht-size.
+ (weakness ht-weakness)
+ ;; Supports immutability.
+ (mutable? hash-table-mutable?)
+ ;; Size of hash-table, allowing O(1) hash-table-size for
+ ;; non-weak hash tables.
+ (size ht-size ht-size!)
+ ;; These are mostly needed for reflective queries
+ (equivalence-function hash-table-equivalence-function)
+ (original-hash-function hash-table-hash-function))
+
+;; Show some informations.
+(define (print-hash-table ht port)
+ (let ((equiv-name (procedure-name (hash-table-equivalence-function ht))))
+ (format port "#<generic-hash-table ~@[~a ~]~@[~a ~]size: ~a mutable? ~a>"
+ equiv-name (ht-weakness ht)
+ (hash-table-size ht) (hash-table-mutable? ht))))
+
+(set-record-type-printer! generic-hash-table print-hash-table)
+
+(define (hash-table-key-weakness ht)
+ "Returns WEAK-KEYS if HT has weak keys, or #f otherwise."
+ ;; If Guile ever supports ephemeral keys, this procedure should
+ ;; return EPHEMERAL-KEYS if the HT keys are ephemeral.
+ (case (ht-weakness ht)
+ ((#f weak-value) #f)
+ ((weak-key weak-key-and-value) 'weak-keys)))
+
+(define (hash-table-value-weakness ht)
+ "Returns WEAK-VALUES if HT has weak values, or #f otherwise."
+ ;; If Guile ever supports ephemeral values, this procedure should
+ ;; return EPHEMERAL-VALUES if the HT values are ephemeral.
+ (case (ht-weakness ht)
+ ((#f weak-key) #f)
+ ((weak-value weak-key-and-value) 'weak-values)))
+
+(define (hash-table-weakness ht)
+ "Return the weakness of HT according to SRFI-126 spec."
+ (ht-weakness ht))
+
+;; This internal function allows us to create immutable hash tables
+(define (%make-hash-table equiv-function hash-function mutable capacity weakness)
+ (receive (internal-hash-function hash-function)
+ (get-hash-functions equiv-function hash-function)
+ (let ((real-table ((guile-ht-ctor weakness) capacity)))
+ ;; Arguments: real-table hash-function associator
+ ;; weakness mutable? size equivalence-function orig-hash-function
+ (make-generic-hash-table real-table internal-hash-function
+ (equivalence-proc->associator equiv-function)
+ weakness (and mutable #t) 0
+ equiv-function hash-function))))
+
+;; If the list of arguments is updated, HASH-TABLE, ALIST->HASH-TABLE,
+;; HASH-TABLE-UNFOLD and HASH-TABLE-MAP should be updated as well.
+(define* (make-hash-table equiv-function hash-function
+ #:key (capacity 1) (weakness #f) #:rest args)
+ "Creates a new hash table. EQUIV-FUNCTION is used as the comparison
+function and HASH-FUNCTION, if not false, is used as the hash function,
+otherwise a suitable hash-function for the hash table is guessed or, if
+one can't be guessed, an error is signaled. #:WEAKNESS should be either
+#f, WEAK-KEY, WEAK-VALUE or WEAK-KEY-AND-VALUE, as specified by
+SRFI-126. #:CAPACITY is the minimal number of buckets of the hash table.
+
+ARGS is ignored and reserved for future extensions."
+ (%make-hash-table equiv-function hash-function #t capacity weakness))
+
+;; We use this to denote missing or unspecified values to avoid
+;; possible collision with *unspecified*.
+
+(define ht-unspecified (cons *unspecified* "ht-value"))
+
+(define* (hash-table equiv-function-or-mht-args . args)
+ "Creates a new immutable hash table with the associations given by
+ARGS. If EQUIV-FUNCTION-OR-MHT-ARGS is a list, the new hash table is
+created by (APPLY MAKE-HASH-TABLE EQUIV-FUNCTION-OR-MHT-ARGS), otherwise
+it is created by (MAKE-HASH-TABLE EQUIV-FUNCTION-OR-MHT-ARGS) with the
+initial capacity set to the number of associations in args.
+
+The ARGS alternate between keys and values. If the same key (in the
+sense of the equality procedure) is specified more then once, an error
+is signaled."
+ (let ((len (length args)))
+ (unless (even? len)
+ (error "Odd number of key-value pairs" args))
+ (let* ((capacity (quotient len 2))
+ (ht (if (pair? equiv-function-or-mht-args)
+ (cond ((null? equiv-function-or-mht-args)
+ ;; SRFI-125 Spec says this should return an immutable hash table
+ (%make-hash-table equal? #f #f capacity #f))
+ ((null? (cdr equiv-function-or-mht-args))
+ (%make-hash-table (car equiv-function-or-mht-args) #f
+ #f capacity #f))
+ ((null? (cddr equiv-function-or-mht-args))
+ (%make-hash-table (car equiv-function-or-mht-args)
+ (cadr equiv-function-or-mht-args)
+ #f capacity #f))
+ (else
+ (apply (lambda* (equiv-function
+ hash-function
+ #:key (mutable #f)
+ (capacity capacity)
+ (weakness #f)
+ #:rest args)
+ (%make-hash-table equiv-function hash-function
+ mutable capacity weakness))
+ (car equiv-function-or-mht-args)
+ (cadr equiv-function-or-mht-args)
+ #:capacity capacity
+ (cddr equiv-function-or-mht-args))))
+ (%make-hash-table equiv-function-or-mht-args #f #f capacity #f))))
+ (with-hashx-values (h a real-table) ht
+ (if (ht-weakness ht)
+ (let loop ((kvs args))
+ (cond
+ ((null? kvs) #f)
+ ((not (eq? ht-unspecified
+ (hashx-ref h a real-table (car kvs) ht-unspecified)))
+ (error "Two equivalent keys were provided"
+ (car (member (car kvs) (hash-table-keys ht)
+ (hash-table-equivalence-function ht)))
+ (car kvs)))
+ (else (hashx-set! h a real-table (car kvs) (cadr kvs))
+ (loop (cddr kvs)))))
+ (let loop ((kvs args))
+ (cond
+ ((null? kvs) #f)
+ (else (let ((handle (hashx-create-handle! h a real-table
+ (car kvs) ht-unspecified)))
+ (unless (eq? ht-unspecified (cdr handle))
+ (error "Two equivalent keys were provided"
+ (car handle) (car kvs)))
+ (set-cdr! handle (cadr kvs)))
+ (loop (cddr kvs))))
+ (ht-size! ht capacity))))
+ ht)))
+
+(define* (hash-table-unfold stop? mapper successor seed
+ equiv-function hash-function
+ #:key (mutable #t) (weakness #f) (capacity 1) #:rest args)
+ "Returns a new hash table created by MAKE-HASH-TABLE with the given
+arguments. If the result of applying the predicate STOP? to SEED is
+true, returns the hash table. Otherwise, apply the procedure MAPPER to
+SEED. MAPPER returns two values, which are inserted into the hash table
+as the key and the value respectively. Then get a new seed by applying
+the procedure SUCCESSOR to SEED, and repeat this algorithm."
+ (let ((result (%make-hash-table equiv-function hash-function
+ mutable capacity weakness)))
+ (with-hashx-values (h a real-table) result
+ (if (ht-weakness result)
+ (let loop ((seed seed))
+ (if (stop? seed)
+ result
+ (receive (key val) (mapper seed)
+ (hashx-set! h a real-table key val)
+ (loop (successor seed)))))
+ (let ((size (ht-size result)))
+ (let loop ((seed seed))
+ (if (stop? seed)
+ result
+ (receive (key val) (mapper seed)
+ (let ((handle (hashx-create-handle! h a real-table key
+ ht-unspecified)))
+ (if (eq? ht-unspecified (cdr handle))
+ (set! size (+ 1 size)))
+ (set-cdr! handle val))
+ (loop (successor seed)))))
+ (ht-size! result size))))
+ result))
+
+(define* (alist->hash-table alist equiv-function hash-function
+ #:key (mutable #t) (capacity (length alist)) (weakness #f)
+ #:rest args)
+ "Returns a new hash-table created by MAKE-HASH-TABLE with the given
+arguments. It is initialized from the associations of alist.
+Associations earlier in the list take precedence over those that
+come later."
+ (let ((result (%make-hash-table equiv-function hash-function
+ mutable capacity weakness)))
+ (with-hashx-values (h a real-table) result
+ (if (ht-weakness result)
+ (for-each (lambda (pair)
+ (hashx-set! h a real-table (car pair) (cdr pair)))
+ (reverse alist))
+ (let ((size (ht-size result)))
+ (for-each (lambda (pair)
+ (let ((handle (hashx-create-handle!
+ h a real-table (car pair) ht-unspecified)))
+ (when (eq? ht-unspecified (cdr handle))
+ (set! size (+ 1 size))
+ (set-cdr! handle (cdr pair)))))
+ alist)
+ (ht-size! result size))))
+ result))
+
+\f
+;;;; Accessing table items
+
+(define* (hash-table-ref ht key #:optional
+ (failure (lambda () (error "Key not in table" key ht)))
+ success)
+ "Extracts the value associated to KEY in HT, invokes the procedure
+SUCCESS on it, and returns its result; if SUCCESS is not provided, then
+the value itself is returned. If key is not contained in hash-table and
+FAILURE is supplied, then FAILURE is invoked on no arguments and its
+result is returned. Otherwise, an error is signaled."
+ (let ((result (hashx-invoke hashx-ref ht key ht-unspecified)))
+ (if (eq? ht-unspecified result)
+ (failure)
+ (if success (success result) result))))
+
+(define (hash-table-ref/default ht key default)
+ "Lookups KEY in HT and returns the associated value. Returns DEFAULT if
+KEY isn't present."
+ (hashx-invoke hashx-ref ht key default))
+
+\f
+;;; Predicates.
+
+;; (define (hash-table? obj))
+
+(define (hash-table-empty? ht)
+ "Returns whether KEY is empty."
+ (if (ht-weakness ht)
+ (call/cc (lambda (exit)
+ (hash-for-each (lambda (key val) (exit #f))
+ (ht-real-table ht))
+ #t))
+ (zero? (ht-size ht))))
+
+(define (hash-table-contains? ht key)
+ "Return whether KEY is a key in HT."
+ (not (eq? ht-unspecified (hashx-invoke hashx-ref ht key ht-unspecified))))
+
+(define (hash-table=? val=? ht1 ht2)
+ "Returns #t if the hash tables HT1 and HT2 have the same keys (in the
+sense of their common equality predicate) and each key has the same
+value (in the sense of VAL=?), and #f otherwise."
+ (let ((n1 (hash-table-size ht1))
+ (n2 (hash-table-size ht2)))
+ (and (= n1 n2)
+ (eq? (hash-table-equivalence-function ht1)
+ (hash-table-equivalence-function ht2))
+ (receive (keys vals) (hash-table-entries ht1)
+ (every (lambda (key val1)
+ (and (hash-table-contains? ht2 key)
+ (val=? val1 (hash-table-ref ht2 key))))
+ keys vals)))))
+
+\f
+;;; Mutators.
+
+(define (hash-table-set-single! ht key val)
+ "If HT is immutable, an error is signaled. Otherwise, a new
+association is created between KEY and VAL. If there is a previous
+association for KEY, it is deleted."
+ (assert-mutable ht)
+ (with-hashx-values (h a real-table) ht
+ (if (ht-weakness ht)
+ (hashx-set! h a real-table key val)
+ (let ((handle (hashx-create-handle!
+ h a real-table key
+ ht-unspecified)))
+ (if (eq? ht-unspecified (cdr handle))
+ (ht-size! ht (+ 1 (ht-size ht))))
+ (set-cdr! handle val)))))
+
+(define* (hash-table-set! ht #:optional (key1 ht-unspecified) (val1 ht-unspecified)
+ #:rest args)
+ "If HT is immutable, an error is signaled. Otherwise, repeatedly
+mutates the hash table HT, creating new associations in it by processing
+the arguments from left to right. The ARGS alternate between keys and
+values. Whenever there is a previous association for a key, it is
+deleted."
+ (if (null? args)
+ (if (eq? val1 ht-unspecified)
+ (if (eq? key1 ht-unspecified)
+ ;; If one calls (hash-table-set! ht) with an
+ ;; immutable hash table, something is really wrong.
+ (assert-mutable ht)
+ (error "No value provided for key" key1))
+ (hash-table-set-single! ht key1 val1))
+ (begin
+ (assert-mutable ht)
+ (with-hashx-values (h a real-table) ht
+ (let ((set-one! (if (ht-weakness ht)
+ (lambda (key val)
+ (hashx-set! h a real-table key val))
+ (lambda (key val)
+ (let ((handle (hashx-create-handle!
+ h a real-table key
+ ht-unspecified)))
+ (if (eq? ht-unspecified (cdr handle))
+ (ht-size! ht (+ 1 (ht-size ht))))
+ (set-cdr! handle val))))))
+ (set-one! key1 val1)
+ (let loop ((kvs args))
+ (cond
+ ((null? kvs) *unspecified*)
+ ((null? (cdr kvs))
+ (error "Odd number of key-value pairs"
+ (cons* key1 val1 args)))
+ (else (set-one! (car kvs) (cadr kvs))
+ (loop (cddr kvs))))))))))
+
+(define (hash-table-delete-single! ht key)
+ "Deletes KEY and associated value in hash table HT. Returns #t if KEY
+had an association and #f otherwise."
+ (assert-mutable ht)
+ (with-hashx-values (h a real-table) ht
+ (if (eq? ht-unspecified (hashx-ref h a real-table key ht-unspecified))
+ #f
+ (begin (hashx-remove! h a real-table key)
+ (ht-size! ht (- (ht-size ht) 1))
+ #t))))
+
+(define* (hash-table-delete! ht #:optional (key1 ht-unspecified) #:rest keys)
+ "Deletes any association to each key in hash table HT and returns the
+number of keys that had associations."
+ (if (null? keys)
+ (if (eq? ht-unspecified key1)
+ (begin (assert-mutable ht) 0)
+ (if (hash-table-delete-single! ht key1) 1 0))
+ (begin
+ (assert-mutable ht)
+ (let* ((count 0)
+ (delete-one! (lambda (key)
+ (with-hashx-values (h a real-table) ht
+ (when (not (eq? ht-unspecified
+ (hashx-ref h a real-table key
+ ht-unspecified)))
+ (set! count (+ 1 count))
+ (hashx-remove! h a real-table key))))))
+ (delete-one! key1)
+ (for-each delete-one! keys)
+ (unless (or (ht-weakness ht) (zero? count))
+ (ht-size! ht (- (ht-size ht) count)))
+ count))))
+
+(define (hash-table-intern! ht key failure)
+ "Effectively invokes HASH-TABLE-REF with the given arguments and
+returns what it returns. If KEY was not found in hash-table, its value
+is set to the result of calling FAILURE and the new value is returned."
+ (assert-mutable ht)
+ (with-hashx-values (h a real-table) ht
+ (if (ht-weakness ht)
+ ;; Separate the case where ht is weak - don't use handle
+ (let* ((value (hashx-ref h a real-table key ht-unspecified)))
+ (cond ((eq? ht-unspecified value)
+ (let ((value (failure)))
+ (hashx-set! h a real-table key value)
+ value))
+ (else value)))
+ (let ((handle
+ (hashx-create-handle! h a real-table key ht-unspecified)))
+ (if (eq? ht-unspecified (cdr handle))
+ (begin (ht-size! ht (+ 1 (ht-size ht)))
+ (set-cdr! handle (failure))))
+ (cdr handle)))))
+
+(define (hash-table-intern!/default ht key default)
+ "Effectively invokes HASH-TABLE-REF with the given arguments and
+returns what it returns. If KEY was not found in hash-table, its value
+is set to DEFAULT and DEFAULT is returned."
+ (assert-mutable ht)
+ (with-hashx-values (h a real-table) ht
+ (if (ht-weakness ht)
+ ;; Separate the case where ht is weak - don't use handle
+ (let* ((value (hashx-ref h a real-table key ht-unspecified)))
+ (cond ((eq? ht-unspecified value)
+ (hashx-set! h a real-table key default)
+ default)
+ (else value)))
+ (let ((handle
+ (hashx-create-handle! h a real-table key ht-unspecified)))
+ (if (eq? ht-unspecified (cdr handle))
+ (begin (ht-size! ht (+ 1 (ht-size ht)))
+ (set-cdr! handle default)))
+ (cdr handle)))))
+
+(define* (hash-table-update! ht key updater #:optional
+ (failure (lambda () (error "Key not in table" key ht)))
+ success)
+ "Semantically equivalent to, but may be more efficient than, the
+ following code:
+ (HASH-TABLE-SET! HT KEY (UPDATER (HASH-TABLE-REF HT KEY [FAILURE [SUCCESS]])))
+
+Signals an error if HT is immutable. Otherwise, if KEY is found in hash
+table HT, its associated VALUE is set to (UPDATER (SUCCESS VALUE)),
+or (UPDATER VALUE) if SUCCESS isn't provided. If KEY is not found, sets
+the new value to the result of (UPDATER (FAILURE)) if FAILURE is
+provided, or signals an error otherwise."
+ (assert-mutable ht)
+ (with-hashx-values (h a real-table) ht
+ (if (ht-weakness ht)
+ ;; Separate the case where ht is weak - don't use handle
+ (let* ((old (hashx-ref h a real-table key ht-unspecified))
+ (new (updater (if (eq? old ht-unspecified)
+ (failure)
+ (if success (success old) old)))))
+ (hashx-set! h a real-table key new))
+ (let ((handle (hashx-get-handle h a real-table key)))
+ (cond (handle
+ (let* ((old (cdr handle))
+ (new (updater (if success (success old) old))))
+ (set-cdr! handle new)))
+ (else
+ (let ((new (updater (failure))))
+ (ht-size! ht (+ 1 (ht-size ht)))
+ (hashx-set! h a real-table key new)))))))
+ *unspecified*)
+
+(define (hash-table-update!/default ht key updater default)
+ "Semantically equivalent to, but may be more efficient than, the
+following code:
+ (HASH-TABLE-SET! HT KEY (UPDATER (HASH-TABLE-REF/DEFAULT HT KEY DEFAULT)))
+
+Signals an error if HT is immutable. Otherwise, modifies HT's value at
+KEY by passing its old value, or DEFAULT if it doesn't have one, to
+UPDATER, and setting it to the result thereof."
+ (assert-mutable ht)
+ (with-hashx-values (h a real-table) ht
+ (if (ht-weakness ht)
+ ;; J.M. separate the case where ht is weak - don't use handle
+ (let* ((old (hashx-ref h a real-table key default)))
+ (hashx-set! h a real-table key (updater old)))
+ (let ((handle (hashx-create-handle! h a real-table key
+ ht-unspecified)))
+ (if (eq? ht-unspecified (cdr handle))
+ (begin (ht-size! ht (+ 1 (ht-size ht)))
+ (set-cdr! handle (updater default)))
+ (set-cdr! handle (updater (cdr handle)))))))
+ *unspecified*)
+
+(define (hash-table-pop! ht)
+ "Signals an error if HT is immutable or empty. Otherwise, chooses an
+arbitrary association from hash-table and removes it, returning the key
+and value as two values."
+ (assert-mutable ht)
+ (call/cc
+ (lambda (return)
+ (with-hashx-values (h a real-table) ht
+ (hash-for-each (lambda (key value)
+ (hashx-remove! h a real-table key)
+ (unless (ht-weakness ht)
+ (ht-size! ht (- (ht-size ht) 1)))
+ (return key value))
+ real-table))
+ (error "Hash table is empty" ht))))
+
+(define* (hash-table-clear! ht #:optional capacity)
+ "Deletes all associations from HT."
+ (assert-mutable ht)
+ (if capacity
+ (ht-real-table! ht ((guile-ht-ctor (ht-weakness ht)) capacity))
+ (hash-clear! (ht-real-table ht)))
+ (ht-size! ht 0)
+ *unspecified*)
+
+\f
+;; The whole hash table.
+
+(define (hash-table-size ht)
+ "Returns the number of associations in HT. This is guaranteed O(1) for
+tables where #:WEAKNESS is #f."
+ (if (ht-weakness ht)
+ (hash-fold (lambda (key val ans) (+ 1 ans))
+ 0 (ht-real-table ht))
+ (ht-size ht)))
+
+(define (hash-table-keys ht)
+ "Returns a list of the keys in HT."
+ (hash-fold (lambda (key val lst) (cons key lst))
+ '() (ht-real-table ht)))
+
+(define (hash-table-values ht)
+ "Returns a list of the values in HT."
+ (hash-fold (lambda (key val lst) (cons val lst))
+ '() (ht-real-table ht)))
+
+(define (hash-table-entries ht)
+ "Returns two values: a list of the keys and a list of the associated
+values in the corresponding order."
+ (let ((keys '()) (vals '()))
+ (hash-for-each (lambda (key val)
+ (set! keys (cons key keys))
+ (set! vals (cons val vals)))
+ (ht-real-table ht))
+ (values keys vals)))
+
+;;; In a non-weak hash table, we know the size that the key/value vector
+;;; will have. In a weak hash table, we have to iterate throw
+;;; associations of the hash table to compute its size, so it is easier
+;;; to simply call HASH-TABLE-KEYS/HASH-TABLE-VALUES.
+(define (hash-table-key-vector ht)
+ "Returns a vector of the keys in HT."
+ (if (ht-weakness ht)
+ (list->vector (hash-table-keys ht))
+ (let* ((len (ht-size ht))
+ (keys (make-vector len)))
+ (hash-fold (lambda (key val i)
+ (vector-set! keys i key)
+ (+ i 1))
+ 0 (ht-real-table ht))
+ keys)))
+
+(define (hash-table-value-vector ht)
+ "Returns a vector of the values in HT."
+ (if (ht-weakness ht)
+ (list->vector (hash-table-values ht))
+ (let* ((len (ht-size ht))
+ (vals (make-vector len)))
+ (hash-fold (lambda (key val i)
+ (vector-set! vals i val)
+ (+ i 1))
+ 0 (ht-real-table ht))
+ vals)))
+
+(define (hash-table-entry-vectors ht)
+ "Returns two values: a vector of the keys and a vector of the
+associated values in the corresponding order."
+ (if (ht-weakness ht)
+ (receive (keys vals) (hash-table-entries ht)
+ (values (list->vector keys) (list->vector vals)))
+ (let* ((len (ht-size ht))
+ (keys (make-vector len))
+ (vals (make-vector len)))
+ (hash-fold (lambda (key val i)
+ (vector-set! keys i key)
+ (vector-set! vals i val)
+ (+ i 1))
+ 0 (ht-real-table ht))
+ (values keys vals))))
+
+(define (hash-table-find proc ht failure)
+ "For each association of the hash table HT, invoke PROC on its key and
+value. If PROC returns true, then HASH-TABLE-FIND returns what PROC
+returns. If all the calls to PROC return #f, returns the result of
+invoking the thunk FAILURE."
+ (call/cc (lambda (return)
+ (hash-for-each (lambda (key val)
+ (let ((x (proc key val)))
+ (if x (return x))))
+ (ht-real-table ht))
+ (failure))))
+
+(define (hash-table-count pred ht)
+ "For each association of HT, invoke PRED on its key and value. Return
+the number of calls to PRED which returned true."
+ (hash-fold (lambda (key val n)
+ (if (pred key val) (+ 1 n) n))
+ 0 (ht-real-table ht)))
+
+\f
+;;; Mapping and folding.
+
+(define* (hash-table-map proc ht equiv-function hash-function
+ #:key (mutable #t) (capacity (hash-table-size ht))
+ (weakness #f)
+ #:rest args)
+ "Creates a new hash table by calling MAKE-HASH-TABLE with the given
+arguments. After creation, HASH-TABLE-MAP calls PROC for every
+association in hash-table with the value of the association. The key of
+the association and the result of invoking PROC are entered into the new
+hash table, which is then returned."
+ (let ((result (%make-hash-table equiv-function hash-function
+ mutable capacity weakness))
+ (size 0))
+ (with-hashx-values (h a real-table) result
+ (hash-for-each
+ (lambda (key val)
+ (hashx-set! h a real-table key (proc val))
+ (set! size (+ 1 size)))
+ (ht-real-table ht)))
+ (ht-size! result size)
+ result))
+
+(define (hash-table-map->list proc ht)
+ "Calls PROC for every association in HT with two arguments:
+the key of the association and the value of the association. The values
+returned by the invocations of PROC are accumulated into a list, which
+is returned."
+ (hash-map->list proc (ht-real-table ht)))
+
+;;; With this particular implementation, the proc can safely mutate ht.
+;;; That property is not guaranteed by the specification, but can be
+;;; relied upon by procedures defined in this file.
+
+(define (hash-table-for-each proc ht)
+ "Calls PROC with each key and value as two arguments. Returns an
+unspecified value."
+ (hash-for-each proc (ht-real-table ht)))
+
+(define (hash-table-map! proc ht)
+ "Signals an error if HT is immutable. Otherwise, calls PROC for every
+association in HT with two arguments: the key of the association and the
+value of the association. The value returned by PROC is used to update
+the value of the association. Return an unspecified value."
+ (assert-mutable ht)
+ (if (ht-weakness ht)
+ (with-hashx-values (h a real-table) ht
+ (hash-for-each (lambda (key val)
+ (hashx-set! h a real-table key (proc key val)))
+ real-table))
+ (let ((real-table (ht-real-table ht)))
+ (hash-for-each-handle (lambda (handle)
+ (let ((key (car handle))
+ (val (cdr handle)))
+ (set-cdr! handle (proc key val))))
+ real-table))))
+
+(define (hash-table-fold proc init ht)
+ "Calls PROC for every association in HT with three arguments: the key
+of the association, the value of the association, and an accumulated
+value VAL. VAL is SEED for the first invocation of procedure, and for
+subsequent invocations of PROC, the returned value of the previous
+invocation. The value returned by HASH-TABLE-FOLD is the return value of
+the last invocation of PROC."
+ (hash-fold proc init (ht-real-table ht)))
+
+(define (hash-table-prune! proc ht)
+ "If HT is immutable, signals an error. Otherwise, calls PROC for every
+association in hash-table with two arguments, the key and the value of
+the association, and removes all associations from hash-table for which
+PROC returns true. Returns an unspecified value."
+ (assert-mutable ht)
+ (with-hashx-values (h a real-table) ht
+ (hash-for-each (lambda (key val)
+ (if (proc key val)
+ (hashx-remove! h a real-table key)))
+ real-table)))
+
+\f
+;;; Copying and conversion.
+
+(define* (hash-table-copy ht #:key (mutable (hash-table-mutable? ht))
+ (capacity (hash-table-size ht))
+ (weakness (hash-table-weakness ht)))
+ "Returns a newly allocated hash table with the associations as HT and
+properties as given by keyword arguments, which default to HT
+properties. If MUTABLE is true, the new hash table is mutable,
+otherwise, it is immutable."
+ (with-hashx-values (h a real-table) ht
+ (let ((new-real-table ((guile-ht-ctor weakness) capacity))
+ (size 0))
+ (hash-for-each (lambda (key val)
+ (hashx-set! h a new-real-table key val)
+ (set! size (+ 1 size)))
+ real-table)
+ ;; Arguments: real-table hash-function associator
+ ;; weakness mutable? size equivalence-function orig-hash-function
+ (make-generic-hash-table new-real-table h a weakness (and mutable #t) size
+ (hash-table-equivalence-function ht)
+ (hash-table-hash-function ht)))))
+
+(define* (hash-table-empty-copy ht #:key (mutable #t)
+ (capacity 1)
+ (weakness (hash-table-weakness ht)))
+ "Returns a newly allocated mutable hash table with the same properties
+as HT, but with no associations."
+ (with-hashx-values (h a real-table) ht
+ (let ((new-real-table ((guile-ht-ctor weakness) capacity)))
+ ;; Arguments: real-table hash-function associator
+ ;; weakness mutable? size equivalence-function orig-hash-function
+ (make-generic-hash-table new-real-table h a weakness (and mutable #t) 0
+ (hash-table-equivalence-function ht)
+ (hash-table-hash-function ht)))))
+
+(define (hash-table->alist ht)
+ "Returns an alist with the same associations as hash-table in an
+unspecified order."
+ (hash-map->list cons (ht-real-table ht)))
+
+\f
+;;; Hash tables as sets.
+
+(define (hash-table-union! ht1 ht2)
+ "If HT1 is immutable, signals an error. Otherwise, adds the associations
+of HT2 to HT1 and return HT1. If a key appears in both hash tables, its
+value is set to the value appearing in HT1."
+ (assert-mutable ht1)
+ (hash-for-each (lambda (key2 val2)
+ (hash-table-intern!/default ht1 key2 val2))
+ (ht-real-table ht2))
+ ht1)
+
+(define (hash-table-intersection! ht1 ht2)
+ "If HT1 is immutable, signals an error. Otherwise, deletes the
+associations from HT whose keys don't also appear in HT2 and returns
+HT1."
+ (assert-mutable ht1)
+ (hash-for-each (lambda (key1 val1)
+ (if (not (hash-table-contains? ht2 key1))
+ (hash-table-delete! ht1 key1)))
+ (ht-real-table ht1))
+ ht1)
+
+(define (hash-table-difference! ht1 ht2)
+ "If HT1 is immutable, signals an error. Otherwise, deletes the
+associations of HT1 whose keys are also present in HT2 and returns HT1."
+ (assert-mutable ht1)
+ (hash-for-each (lambda (key1 val1)
+ (if (hash-table-contains? ht2 key1)
+ (hash-table-delete! ht1 key1)))
+ (ht-real-table ht1))
+ ht1)
+
+(define (hash-table-xor! ht1 ht2)
+ "If HT1 is immutable, signals an error. Otherwise, deletes the
+associations of HT1 whose keys are also present in HT2, and then adds
+the associations of HT2 whose keys are not present in HT1 to
+HT1. Returns HT1."
+ (assert-mutable ht1)
+ (hash-for-each (lambda (key2 val2)
+ (if (hash-table-contains? ht1 key2)
+ (hash-table-delete! ht1 key2)
+ (hash-table-set! ht1 key2 val2)))
+ (ht-real-table ht2))
+ ht1)
+
+;; eof
diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am
index 0934dbb34..e154602a7 100644
--- a/test-suite/Makefile.am
+++ b/test-suite/Makefile.am
@@ -63,6 +63,7 @@ SCM_TESTS = tests/00-initial-env.test \
tests/ftw.test \
tests/future.test \
tests/gc.test \
+ tests/generic-hash-tables.test \
tests/getopt-long.test \
tests/goops.test \
tests/guardians.test \
diff --git a/test-suite/tests/generic-hash-tables.test b/test-suite/tests/generic-hash-tables.test
new file mode 100644
index 000000000..494cbf70a
--- /dev/null
+++ b/test-suite/tests/generic-hash-tables.test
@@ -0,0 +1,415 @@
+;;;; srfi-69.test --- Test suite for SRFI 69 -*- scheme -*-
+;;;;
+;;;; 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 3 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
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; 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
+
+(define-module (test-generic-hash-tables)
+ #:use-module (test-suite lib)
+ #:use-module (ice-9 generic-hash-tables)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-8)
+ #: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))))
+
+(define-syntax with-elt-in-list
+ (syntax-rules ()
+ ((with-elt-in-list arg arg-list expr ...)
+ (let loop ((arg-list* arg-list))
+ (or (null? arg-list*)
+ (and (let ((arg (car arg-list*)))
+ expr ...)
+ (loop (cdr arg-list*))))))))
+
+(define (test-str-weakness str weakness)
+ (if (not weakness) str (format #f "~a (weakness: ~a)" str weakness)))
+
+(with-test-prefix "generic-hash-tables"
+
+ (pass-if-exception "bad weakness arg to mht signals an error"
+ '(misc-error . "^Invalid hash table weakness")
+ (make-hash-table equal? hash #:weakness 'weak-key-or-value))
+
+ (pass-if-exception "unsupported weakness arg to mht signals an error"
+ '(misc-error . "^Unsupported hash table weakness")
+ (make-hash-table equal? hash #:weakness 'ephemeral-key))
+
+ (pass-if "can use all arguments, including size"
+ (hash-table? (make-hash-table equal? hash #:weakness 'weak-key 31)))
+
+ ;; The following tests are done once with each kind of weakness
+ (with-elt-in-list weakness (list #f 'weak-key 'weak-value 'weak-key-and-value)
+ (pass-if (test-str-weakness "reflective queries function properly" weakness)
+ (let ((ht (make-hash-table eqv? #f #:weakness weakness)))
+ (and (hash-table-mutable? ht)
+ (eq? eqv? (hash-table-equivalence-function ht))
+ (eq? hash-by-value (hash-table-hash-function ht))
+ (eq? weakness (hash-table-weakness ht))
+ (equal? (list (hash-table-key-weakness ht)
+ (hash-table-value-weakness ht))
+ (case weakness
+ ((#f) '(#f #f))
+ ((weak-key) '(weak-keys #f))
+ ((weak-value) '(#f weak-values))
+ ((weak-key-and-value) '(weak-keys weak-values)))))))
+
+ (pass-if (test-str-weakness "hash-table-contains? functions properly" weakness)
+ (let ((ht (make-hash-table eq? #f #:weakness weakness)))
+ (hash-table-set-single! ht 'a 1)
+ (and (hash-table-contains? ht 'a)
+ (not (hash-table-contains? ht 'b))
+ (begin (hash-table-set-single! ht 'b 1)
+ (hash-table-contains? ht 'b))
+ (begin (hash-table-delete-single! ht 'a)
+ (not (hash-table-contains? ht 'a))))))
+
+ (pass-if (test-str-weakness "small alist<->hash tables round-trip" weakness)
+ (let* ((start-alist '((a . 1) (b . 2) (c . 3) (a . 42)))
+ (ht (alist->hash-table start-alist eq? #f #:weakness weakness))
+ (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 (test-str-weakness "string-ci=? tables work by default" weakness)
+ (let ((ht (alist->hash-table '(("xY" . 2) ("abc" . 54)) string-ci=? #f
+ #:weakness weakness)))
+ (hash-table-set! ht "XY" 42 "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 (test-str-weakness "empty hash tables are empty" weakness)
+ (let ((ht (make-hash-table eq? #f #:weakness weakness)))
+ (and (= 0 (hash-table-size ht))
+ (hash-table-empty? ht)
+ (null? (hash-table->alist ht)))))
+
+ (pass-if (test-str-weakness "hash-table functions properly" weakness)
+ (let ((ht (hash-table (list eq? #f #:weakness weakness)
+ 'a 1 'b 2 'c 3)))
+ (and (= 3 (hash-table-size ht))
+ (lset= equal? '((a . 1) (b . 2) (c . 3)) (hash-table->alist ht))
+ (eq? weakness (hash-table-weakness ht))
+ (not (hash-table-mutable? ht)))))
+
+ (pass-if-exception
+ (test-str-weakness "hash-table with equivalent keys signals an error" weakness)
+ '(misc-error . "^Two equivalent keys were provided")
+ (hash-table (list string=? #f #:weakness weakness)
+ "a" 1 "b" 2 "c" 3 "a" 4))
+
+ (pass-if (test-str-weakness "hash-table-unfold functions properly" weakness)
+ (let ((ht (hash-table-unfold (lambda (i) (>= i 5))
+ (lambda (i) (values i (* i 10)))
+ 1+ 0
+ eqv? #f #:weakness weakness)))
+ (and (= 5 (hash-table-size ht))
+ (eq? weakness (hash-table-weakness ht))
+ (lset= equal? '((0 . 0) (1 . 10) (2 . 20) (3 . 30) (4 . 40))
+ (hash-table->alist ht)))))
+
+ (pass-if (test-str-weakness "hash-table=? functions properly" weakness)
+ (let ((ht1 (hash-table-unfold (lambda (i) (>= i 5))
+ (lambda (i) (values i (* i 10)))
+ 1+ 0
+ eqv? #f #:weakness weakness))
+ (ht2 (alist->hash-table '((0 . 0) (1 . 10) (2 . 20) (3 . 30) (4 . 40))
+ eqv? #f #:weakness weakness))
+ (ht3 (alist->hash-table '((0 . 0) (1 . 10) (2 . 20) (3 . 30) (4 . 40))
+ equal? #f #:weakness weakness))
+ (ht4 (alist->hash-table '((0 . 10) (1 . 10) (2 . 20) (3 . 30) (4 . 40))
+ eqv? #f #:weakness weakness)))
+ (and (hash-table=? eqv? ht1 ht2)
+ (not (hash-table=? eqv? ht1 ht3))
+ (not (hash-table=? eqv? ht1 ht4))
+ (lset= equal? '((0 . 0) (1 . 10) (2 . 20) (3 . 30) (4 . 40))
+ (hash-table->alist ht3)))))
+
+ (pass-if (test-str-weakness "hash-table-ref uses default" weakness)
+ (equal? '(4)
+ (hash-table-ref (alist->hash-table '((a . 1)) eq? #f
+ #:weakness weakness)
+ 'b (cut list (+ 2 2)))))
+
+ (pass-if (test-str-weakness "hash-table-ref/default uses default" weakness)
+ (equal? 'foo
+ (hash-table-ref/default (alist->hash-table '((a . 1)) eq? #f
+ #:weakness weakness)
+ 'b 'foo)))
+
+ (pass-if (test-str-weakness "hash-table-delete! deletes present assocs, ignores others"
+ weakness)
+ (let ((ht (alist->hash-table '((a . 1) (b . 2)) eq? #f #:weakness weakness)))
+ (and (= 0 (hash-table-delete! ht 'c))
+ (= 2 (hash-table-size ht))
+ (= 1 (hash-table-delete! ht 'a))
+ (= 1 (hash-table-size ht))
+ (lset= equal? '((b . 2)) (hash-table->alist ht)))))
+
+ (pass-if (test-str-weakness "hash-table-delete! deletes several keys"
+ weakness)
+ (let ((ht (alist->hash-table '((a . 1) (b . 2) (d . 4) (e . 5)) eq? #f
+ #:weakness weakness)))
+ (and (= 4 (hash-table-size ht))
+ (= 3 (hash-table-delete! ht 'a 'b 'c 'e))
+ (= 1 (hash-table-size ht))
+ (lset= equal? '((d . 4)) (hash-table->alist ht)))))
+
+ (pass-if (test-str-weakness "alist->hash-table does not require linear stack space"
+ weakness)
+ (eqv? 99999
+ (hash-table-ref
+ (alist->hash-table (unfold-right (cut >= <> 100000)
+ (lambda (s) `(x . ,s)) 1+ 0)
+ eq? #f
+ #:weakness weakness)
+ 'x)))
+
+ (pass-if (test-str-weakness "hash-table-update! modifies existing binding"
+ weakness)
+ (let ((ht (alist->hash-table '((a . 1)) eq? #f #:weakness weakness)))
+ (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 (test-str-weakness "hash-table-update! creates new binding when appropriate"
+ weakness)
+ (let ((ht (make-hash-table eq? #f #:weakness weakness)))
+ (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)))))
+
+ (pass-if (test-str-weakness "hash-table-intern! creates new binding"
+ weakness)
+ (let ((ht (make-hash-table eq? #f #:weakness weakness)))
+ (and (= 1 (hash-table-intern! ht 'b (const 1)))
+ (= 1 (hash-table-size ht))
+ (lset= equal? '((b . 1)) (hash-table->alist ht)))))
+
+ (pass-if (test-str-weakness "hash-table-intern! doesn't modify existing binding"
+ weakness)
+ (let ((ht (alist->hash-table '((a . 1)) eq? #f #:weakness weakness)))
+ (and (= 1 (hash-table-intern! ht 'a (const 2)))
+ (= 1 (hash-table-size ht))
+ (lset= equal? '((a . 1)) (hash-table->alist ht)))))
+
+ (pass-if (test-str-weakness "hash-table-pop! functions properly"
+ weakness)
+ (let* ((ht (alist->hash-table '((a . 1) (b . 2)) eq? #f #:weakness weakness))
+ (popped (receive (key val) (hash-table-pop! ht) (list key val))))
+ (or (and (equal? '(a 1) popped)
+ (equal? '((b . 2)) (hash-table->alist ht)))
+ (and (equal? '(b 2) popped)
+ (equal? '((a . 1)) (hash-table->alist ht))))))
+
+ (pass-if-exception
+ (test-str-weakness "hash-table-pop! with empty hash table signals an error"
+ weakness)
+ '(misc-error . "^Hash table is empty")
+ (hash-table-pop! (make-hash-table eq? #f #:weakness weakness)))
+
+ (pass-if (test-str-weakness "hash-table-clear! functions properly"
+ weakness)
+ (let ((ht (alist->hash-table '((a . 1) (b . 2)) eq? #f #:weakness weakness)))
+ (hash-table-clear! ht)
+ (and (= 0 (hash-table-size ht))
+ (hash-table-empty? ht)
+ (null? (hash-table->alist ht)))))
+
+ (pass-if (test-str-weakness "hash-table-find functions properly" weakness)
+ (let ((ht (alist->hash-table '((a . 1) (b . 2) (c . 3)) eq? #f
+ #:weakness weakness)))
+ (and (eq? 'b (hash-table-find (lambda (key val) (and (even? val) key)) ht
+ (lambda () #f)))
+ (not (hash-table-find (lambda (key val) (= val 4)) ht
+ (lambda () #f))))))
+
+ (pass-if (test-str-weakness "hash-table-count functions properly" weakness)
+ (let ((ht (alist->hash-table '((a . 1) (b . 2) (c . 3) (d . 4)) eq? #f
+ #:weakness weakness)))
+ (and (= 2 (hash-table-count (lambda (key val) (even? val)) ht))
+ (= 1 (hash-table-count (lambda (key val) (= val 4)) ht))
+ (= 0 (hash-table-count (lambda (key val) (= val 5)) ht)))))
+
+ (pass-if (test-str-weakness "hash table keys and values are correct" weakness)
+ (let ((ht (alist->hash-table '((a . 1) (b . 2) (c . 3) (d . 4)) eq? #f
+ #:weakness weakness)))
+ (and (lset= eq? '(a b c d) (hash-table-keys ht))
+ (lset= = '(1 2 3 4) (hash-table-values ht))
+ (receive (keys vals) (hash-table-entries ht)
+ (and (lset= eq? '(a b c d) keys)
+ (lset= = '(1 2 3 4) vals))))))
+
+ (pass-if (test-str-weakness "hash table key and value vectors are correct" weakness)
+ (let ((ht (alist->hash-table '((a . 1) (b . 2) (c . 3) (d . 4)) eq? #f
+ #:weakness weakness)))
+ (and (lset= eq? '(a b c d) (vector->list (hash-table-key-vector ht)))
+ (lset= = '(1 2 3 4) (vector->list (hash-table-value-vector ht)))
+ (receive (keys vals) (hash-table-entry-vectors ht)
+ (and (lset= eq? '(a b c d) (vector->list keys))
+ (lset= = '(1 2 3 4) (vector->list vals)))))))
+
+ (pass-if (test-str-weakness "hash-table-map functions properly" weakness)
+ (let* ((ht1 (alist->hash-table '((a . 1) (b . 2)) eq? #f
+ #:weakness weakness))
+ (ht2 (hash-table-map 1+ ht1 eq? #f)))
+ (and (= 2 (hash-table-size ht2))
+ (lset= equal? '((a . 2) (b . 3)) (hash-table->alist ht2)))))
+
+ (pass-if (test-str-weakness "hash-table-map! functions properly" weakness)
+ (let ((ht (alist->hash-table '((a . 1) (b . 2)) eq? #f
+ #:weakness weakness)))
+ (hash-table-map! (lambda (key val) (+ val 1)) ht)
+ (and (= 2 (hash-table-size ht))
+ (lset= equal? '((a . 2) (b . 3)) (hash-table->alist ht)))))
+
+ (pass-if (test-str-weakness "hash-table-for-each ignores return values"
+ weakness)
+ (let ((ht (alist->hash-table '((a . 1) (b . 2) (c . 3)) eq? #f
+ #:weakness weakness)))
+ (for-each (cut hash-table-for-each <> ht)
+ (list (lambda (k v) (values))
+ (lambda (k v) (values 1 2 3))))
+ #t))
+
+ (pass-if (test-str-weakness "hash-table-map->list functions properly" weakness)
+ (let ((ht (alist->hash-table '((a . 1) (b . 2)) eq? #f
+ #:weakness weakness)))
+ (and (lset= eq? '(a b) (hash-table-map->list (lambda (key val) key) ht))
+ (lset= = '(1 2) (hash-table-map->list (lambda (key val) val) ht)))))
+
+ (pass-if (test-str-weakness "hash-table-fold functions properly" weakness)
+ (let ((ht (alist->hash-table '((a . 1) (b . 2)) eq? #f
+ #:weakness weakness)))
+ (= 3 (hash-table-fold (lambda (key val acc) (+ val acc))
+ 0 ht))))
+
+ (pass-if (test-str-weakness "hash-table-prune! functions properly" weakness)
+ (let ((ht (alist->hash-table '((a . 1) (b . 2) (c . 3) (d . 4)) eq? #f
+ #:weakness weakness)))
+ (hash-table-prune! (lambda (key val) (even? val)) ht)
+ (lset= equal? '((a . 1) (c . 3)) (hash-table->alist ht))))
+
+ (pass-if (test-str-weakness "hash-table-copy functions properly" weakness)
+ (let ((ht (hash-table-copy (alist->hash-table '((a . 1) (b . 2)) eq? #f
+ #:weakness weakness)
+ #:mutable #t)))
+ (and (= 2 (hash-table-size ht))
+ (lset= equal? '((a . 1) (b . 2)) (hash-table->alist ht))
+ (hash-table-mutable? ht))))
+
+ (pass-if (test-str-weakness "hash-table-union! functions properly"
+ weakness)
+ (let* ((ht1 (alist->hash-table '((a . 1) (b . 2)) eq? #f #:weakness weakness))
+ (ht2 (alist->hash-table '((b . 3) (c . 4)) eq? #f #:weakness weakness)))
+ (set! ht1 (hash-table-union! ht1 ht2))
+ (and (= 3 (hash-table-size ht1))
+ (= 2 (hash-table-size ht2))
+ (lset= equal? '((a . 1) (b . 2) (c . 4)) (hash-table->alist ht1))
+ (lset= equal? '((b . 3) (c . 4)) (hash-table->alist ht2)))))
+
+ (pass-if (test-str-weakness "hash-table-intersection! functions properly"
+ weakness)
+ (let* ((ht1 (alist->hash-table '((a . 1) (b . 2)) eq? #f #:weakness weakness))
+ (ht2 (alist->hash-table '((b . 3) (c . 4)) eq? #f #:weakness weakness)))
+ (set! ht1 (hash-table-intersection! ht1 ht2))
+ (and (= 1 (hash-table-size ht1))
+ (= 2 (hash-table-size ht2))
+ (lset= equal? '((b . 2)) (hash-table->alist ht1))
+ (lset= equal? '((b . 3) (c . 4)) (hash-table->alist ht2)))))
+
+ (pass-if (test-str-weakness "hash-table-difference! functions properly"
+ weakness)
+ (let* ((ht1 (alist->hash-table '((a . 1) (b . 2)) eq? #f #:weakness weakness))
+ (ht2 (alist->hash-table '((b . 3) (c . 4)) eq? #f #:weakness weakness)))
+ (set! ht1 (hash-table-difference! ht1 ht2))
+ (and (= 1 (hash-table-size ht1))
+ (= 2 (hash-table-size ht2))
+ (lset= equal? '((a . 1)) (hash-table->alist ht1))
+ (lset= equal? '((b . 3) (c . 4)) (hash-table->alist ht2)))))
+
+ (pass-if (test-str-weakness "hash-table-xor! functions properly"
+ weakness)
+ (let* ((ht1 (alist->hash-table '((a . 1) (b . 2)) eq? #f #:weakness weakness))
+ (ht2 (alist->hash-table '((b . 3) (c . 4)) eq? #f #:weakness weakness)))
+ (set! ht1 (hash-table-xor! ht1 ht2))
+ (and (= 2 (hash-table-size ht1))
+ (= 2 (hash-table-size ht2))
+ (lset= equal? '((a . 1) (c . 4)) (hash-table->alist ht1))
+ (lset= equal? '((b . 3) (c . 4)) (hash-table->alist ht2)))))
+
+ (pass-if (test-str-weakness "immutable hash tables are immutable" weakness)
+ (let ((ht (hash-table-copy (alist->hash-table '((a . 1) (b . 2)) eq? #f
+ #:weakness weakness)
+ #:mutable #f)))
+ (and (= 2 (hash-table-size ht))
+ (not (hash-table-mutable? ht)))))
+
+ ;; Tests whether each of the following procedure signals an error on
+ ;; immutable hash tables
+ (with-elt-in-list sym+proc
+ (list
+ (cons 'hash-table-set!
+ (lambda (ht) (hash-table-set! ht 'a 2 'b 3)))
+ (cons 'hash-table-set-single!
+ (lambda (ht) (hash-table-set-single! ht 'a 2)))
+ (cons 'hash-table-delete!
+ (lambda (ht) (hash-table-delete! ht 'a 'b)))
+ (cons 'hash-table-delete-single!
+ (lambda (ht) (hash-table-delete-single! ht 'a)))
+ (cons 'hash-table-intern!
+ (lambda (ht) (hash-table-intern! ht 'a (const 2))))
+ (cons 'hash-table-update!
+ (lambda (ht) (hash-table-update! ht 'a 1+)))
+ (cons 'hash-table-update!/default
+ (lambda (ht) (hash-table-update!/default ht 'a 1+ 0)))
+ (cons 'hash-table-pop!
+ (lambda (ht) (hash-table-pop! ht)))
+ (cons 'hash-table-clear!
+ (lambda (ht) (hash-table-clear! ht)))
+ (cons 'hash-table-prune!
+ (lambda (ht) (hash-table-prune! (lambda (key val) #t) ht)))
+ (cons 'hash-table-union!
+ (lambda (ht) (hash-table-union! ht ht)))
+ (cons 'hash-table-intersection!
+ (lambda (ht) (hash-table-intersection! ht ht)))
+ (cons 'hash-table-difference!
+ (lambda (ht) (hash-table-difference! ht ht)))
+ (cons 'hash-table-xor!
+ (lambda (ht) (hash-table-xor! ht ht))))
+ (pass-if-exception
+ (test-str-weakness
+ (format #f "~a with immutable hash table signals an error" (car sym+proc))
+ weakness)
+ '(misc-error . "^Hash table is not mutable")
+ (let ((ht (hash-table-copy (alist->hash-table '((a . 1) (b . 2)) eq? #f
+ #:weakness weakness)
+ #:mutable #f)))
+ ((cdr sym+proc) ht))))
+ )
+ )
--
2.19.1
next prev parent reply other threads:[~2019-01-09 0:21 UTC|newest]
Thread overview: 5+ messages / expand[flat|nested] mbox.gz Atom feed top
2018-12-21 11:13 bug#33827: SRFI 69 weak hash-tables is broken Jéssica Milaré
2018-12-22 17:44 ` bug#33827: Attempt to fix Jéssica Milaré
2018-12-23 17:09 ` bug#33827: Patch Jéssica Milaré
2019-01-09 0:21 ` Jéssica Milaré [this message]
2019-01-13 22:53 ` bug#33827: Patches Jéssica Milaré
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
List information: https://www.gnu.org/software/guile/
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to='CAGBcF1aZrZhBjEk=tvsJHLJnMDc1ERt-ZaCiwOzqMksnfZsP_Q@mail.gmail.com' \
--to=jessymilare@gmail.com \
--cc=33827@debbugs.gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).