* bug#33827: SRFI 69 weak hash-tables is broken
@ 2018-12-21 11:13 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é
0 siblings, 2 replies; 5+ messages in thread
From: Jéssica Milaré @ 2018-12-21 11:13 UTC (permalink / raw)
To: 33827
[-- Attachment #1: Type: text/plain, Size: 671 bytes --]
The srfi-69 implementation that comes with Guile doesn't function properly
when some non-false #:weak argument is provided. The problems seems to be
that it tries to use handles, which are only available for non-weak
hash-tables.
scheme@(guile-user)> (import (srfi :69))
scheme@(guile-user)> (define ht (make-hash-table eq? hashq #:weak 'key))
scheme@(guile-user)> (hash-table-set! ht 10 10)
ERROR: In procedure hashx-create-handle!:
In procedure scm_hash_fn_create_handle_x: Wrong type argument in position 1
(expecting hash-table): #<weak-table 0/31>
Entering a new prompt. Type `,bt' for a backtrace or `,q' to continue.
scheme@(guile-user) [1]>
Regards,
Jessica
[-- Attachment #2: Type: text/html, Size: 1740 bytes --]
^ permalink raw reply [flat|nested] 5+ messages in thread
* bug#33827: Attempt to fix
2018-12-21 11:13 bug#33827: SRFI 69 weak hash-tables is broken Jéssica Milaré
@ 2018-12-22 17:44 ` Jéssica Milaré
2018-12-23 17:09 ` bug#33827: Patch Jéssica Milaré
1 sibling, 0 replies; 5+ messages in thread
From: Jéssica Milaré @ 2018-12-22 17:44 UTC (permalink / raw)
To: 33827
[-- Attachment #1: Type: text/plain, Size: 110 bytes --]
I'll try to fix this bug and create some tests, then I send a format-patch
here. I'll need to do that anyway.
[-- Attachment #2: Type: text/html, Size: 139 bytes --]
^ permalink raw reply [flat|nested] 5+ messages in thread
* bug#33827: Patch
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 ` Jéssica Milaré
2019-01-09 0:21 ` bug#33827: Patches Jéssica Milaré
1 sibling, 1 reply; 5+ messages in thread
From: Jéssica Milaré @ 2018-12-23 17:09 UTC (permalink / raw)
To: 33827
[-- Attachment #1.1: Type: text/plain, Size: 1 bytes --]
[-- Attachment #1.2: Type: text/html, Size: 26 bytes --]
[-- Attachment #2: 0001-Fix-SRFI-69-don-t-use-handles-with-weak-tables-anymo.patch --]
[-- Type: text/x-patch, Size: 21521 bytes --]
From 87ff519b9288dedcc62a2fd1b2c03eccbf631e56 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?J=C3=A9ssica=20Milar=C3=A9?= <jessymilare@gmail.com>
Date: Sun, 23 Dec 2018 15:07:32 -0200
Subject: [PATCH] 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. Otherwise, check whether default-thunk is given
and, if so, use hashx-create-handle! to avoid double lookup.
(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 | 149 +++++++++++++++++-----------
test-suite/tests/srfi-69.test | 177 +++++++++++++++++++++-------------
3 files changed, 205 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..a05ec61ea 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,79 @@ 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
+ (if (eq? ht-unspecified default-thunk)
+ (hashx-get-handle hash-proc associator real-table key)
+ (hashx-create-handle! hash-proc associator real-table key
+ ht-unspecified))))
+ (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
+ (error "Key not in table" key ht))))))
*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 +327,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 +342,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 +352,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 +368,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..105ae3759 100644
--- a/test-suite/tests/srfi-69.test
+++ b/test-suite/tests/srfi-69.test
@@ -28,80 +28,123 @@ 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?))
+ (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)
+ (let loop ((weakness-list (list #f 'key 'value 'key-or-value)))
+ (or (null? weakness-list)
+ (let ((weakness (car weakness-list)))
+ (and (null? (hash-table->alist (make-hash-table eq? #:weak weakness)))
+ (loop (cdr weakness-list))))))))
+
+ (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
^ permalink raw reply related [flat|nested] 5+ messages in thread
* bug#33827: Patches
2018-12-23 17:09 ` bug#33827: Patch Jéssica Milaré
@ 2019-01-09 0:21 ` Jéssica Milaré
2019-01-13 22:53 ` Jéssica Milaré
0 siblings, 1 reply; 5+ messages in thread
From: Jéssica Milaré @ 2019-01-09 0:21 UTC (permalink / raw)
To: 33827
[-- 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
^ permalink raw reply related [flat|nested] 5+ messages in thread
* bug#33827: Patches
2019-01-09 0:21 ` bug#33827: Patches Jéssica Milaré
@ 2019-01-13 22:53 ` Jéssica Milaré
0 siblings, 0 replies; 5+ messages in thread
From: Jéssica Milaré @ 2019-01-13 22:53 UTC (permalink / raw)
To: 33827
[-- Attachment #1.1: Type: text/plain, Size: 675 bytes --]
The rest of the patches are here, implementing SRFI 128 and SRFI 125.
Em ter, 8 de jan de 2019 às 22:21, Jéssica Milaré <jessymilare@gmail.com>
escreveu:
> 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: 1108 bytes --]
[-- Attachment #2: 0006-Fix-wrong-year-in-copyright-notices.patch --]
[-- Type: text/x-patch, Size: 3877 bytes --]
From a02fd09117013154c011074b5a7583a1bed5eca4 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?J=C3=A9ssica=20Milar=C3=A9?= <jessymilare@gmail.com>
Date: Fri, 11 Jan 2019 17:40:38 -0200
Subject: [PATCH 06/10] Fix wrong year in copyright notices.
---
module/ice-9/generic-hash-tables.scm | 2 +-
module/srfi/srfi-126.scm | 4 ++--
module/srfi/srfi-69.scm | 2 +-
test-suite/tests/generic-hash-tables.test | 4 ++--
test-suite/tests/srfi-126.test | 4 ++--
test-suite/tests/srfi-69.test | 2 +-
6 files changed, 9 insertions(+), 9 deletions(-)
diff --git a/module/ice-9/generic-hash-tables.scm b/module/ice-9/generic-hash-tables.scm
index 033c3ecda..31dead97a 100644
--- a/module/ice-9/generic-hash-tables.scm
+++ b/module/ice-9/generic-hash-tables.scm
@@ -1,6 +1,6 @@
;;; generic-hash-tables.scm --- Intermediate hash tables
-;; Copyright (C) 2007 Free Software Foundation, Inc.
+;; Copyright (C) 2007,2018 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
diff --git a/module/srfi/srfi-126.scm b/module/srfi/srfi-126.scm
index 7a6594434..e7fee35d3 100644
--- a/module/srfi/srfi-126.scm
+++ b/module/srfi/srfi-126.scm
@@ -1,6 +1,6 @@
-;;; srfi-69.scm --- Basic hash tables
+;;; srfi-126.scm --- R6RS hash tables
-;; Copyright (C) 2007 Free Software Foundation, Inc.
+;; Copyright (C) 2019 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
diff --git a/module/srfi/srfi-69.scm b/module/srfi/srfi-69.scm
index ae5bc7f06..134bcd694 100644
--- a/module/srfi/srfi-69.scm
+++ b/module/srfi/srfi-69.scm
@@ -1,6 +1,6 @@
;;; srfi-69.scm --- Basic hash tables
-;; Copyright (C) 2007 Free Software Foundation, Inc.
+;; Copyright (C) 2007,2018 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
diff --git a/test-suite/tests/generic-hash-tables.test b/test-suite/tests/generic-hash-tables.test
index 494cbf70a..d1eb2ac2d 100644
--- a/test-suite/tests/generic-hash-tables.test
+++ b/test-suite/tests/generic-hash-tables.test
@@ -1,6 +1,6 @@
-;;;; srfi-69.test --- Test suite for SRFI 69 -*- scheme -*-
+;;;; generic-hash-tables.test --- Test suite for GENERIC-HASH-TABLES -*- scheme -*-
;;;;
-;;;; Copyright (C) 2007 Free Software Foundation, Inc.
+;;;; Copyright (C) 2007,2018 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
diff --git a/test-suite/tests/srfi-126.test b/test-suite/tests/srfi-126.test
index e6a4e66a9..970770a6e 100644
--- a/test-suite/tests/srfi-126.test
+++ b/test-suite/tests/srfi-126.test
@@ -1,6 +1,6 @@
-;;;; srfi-69.test --- Test suite for SRFI 69 -*- scheme -*-
+;;;; srfi-126.test --- Test suite for SRFI 126 -*- scheme -*-
;;;;
-;;;; Copyright (C) 2007 Free Software Foundation, Inc.
+;;;; Copyright (C) 2019 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
diff --git a/test-suite/tests/srfi-69.test b/test-suite/tests/srfi-69.test
index e1579f73a..97491ba83 100644
--- a/test-suite/tests/srfi-69.test
+++ b/test-suite/tests/srfi-69.test
@@ -1,6 +1,6 @@
;;;; srfi-69.test --- Test suite for SRFI 69 -*- scheme -*-
;;;;
-;;;; Copyright (C) 2007 Free Software Foundation, Inc.
+;;;; Copyright (C) 2007,2018 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
--
2.19.1
[-- Attachment #3: 0009-Implemented-SRFI-125.patch --]
[-- Type: text/x-patch, Size: 54607 bytes --]
From 18ce102c270bab3cf5240e7ac93129e107c335de Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?J=C3=A9ssica=20Milar=C3=A9?= <jessymilare@gmail.com>
Date: Sun, 13 Jan 2019 12:01:08 -0200
Subject: [PATCH 09/10] Implemented SRFI-125
---
module/Makefile.am | 1 +
module/srfi/srfi-125.scm | 479 ++++++++++++++++++
test-suite/Makefile.am | 1 +
test-suite/tests/srfi-125.test | 860 +++++++++++++++++++++++++++++++++
4 files changed, 1341 insertions(+)
create mode 100644 module/srfi/srfi-125.scm
create mode 100644 test-suite/tests/srfi-125.test
diff --git a/module/Makefile.am b/module/Makefile.am
index 5fc3010c1..41c1c2826 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-125.scm \
srfi/srfi-126.scm \
srfi/srfi-128/gnu.scm \
srfi/srfi-128.scm \
diff --git a/module/srfi/srfi-125.scm b/module/srfi/srfi-125.scm
new file mode 100644
index 000000000..f0a1dfb02
--- /dev/null
+++ b/module/srfi/srfi-125.scm
@@ -0,0 +1,479 @@
+;;; srfi-125.scm --- Intermediate hash tables
+
+;; Copyright (C) 2019 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
+
+;; This file contains code from SRFI 128 reference implementation, by
+;; William D Clinger
+
+;;; Copyright 2015 William D Clinger.
+;;;
+;;; Permission to copy this software, in whole or in part, to use this
+;;; software for any lawful purpose, and to redistribute this software
+;;; is granted subject to the restriction that all copies made of this
+;;; software must include this copyright and permission notice in full.
+;;;
+;;; I also request that you send me a copy of any improvements that you
+;;; make to this software so that they may be incorporated within it to
+;;; the benefit of the Scheme community.
+\f
+
+(define-module (srfi srfi-125)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-128)
+ #:use-module ((rnrs base) #:select (symbol=?))
+ #:use-module ((ice-9 generic-hash-tables) #:prefix gen:)
+ #:export (;; Type constructors and predicate
+ make-hash-table
+ hash-table hash-table-unfold alist->hash-table
+ ;; Predicates
+ hash-table? hash-table-contains? hash-table-empty? hash-table=?
+ hash-table-mutable?
+ ;; Accessors
+ hash-table-ref hash-table-ref/default
+ ;; Mutators
+ hash-table-set! hash-table-delete! hash-table-intern! hash-table-update!
+ hash-table-update!/default hash-table-pop! hash-table-clear!
+ ;; The whole hash table
+ hash-table-size hash-table-keys hash-table-values hash-table-entries
+ hash-table-find hash-table-count
+ ;; 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!
+ ;; The following procedures are deprecated by SRFI 125:
+ (deprecated:hash-table-exists? . hash-table-exists?)
+ (deprecated:hash-table-walk . hash-table-walk)
+ (deprecated:hash-table-merge! . hash-table-merge!)
+ ;; Fixme: should we really deprecate these in Guile?
+ (deprecated:hash . hash)
+ (deprecated:string-hash . string-hash)
+ (deprecated:string-ci-hash . string-ci-hash)
+ (deprecated:hash-by-identity . hash-by-identity)
+ (deprecated:hash-table-equivalence-function . hash-table-equivalence-function)
+ (deprecated:hash-table-hash-function . hash-table-hash-function))
+ #:replace (make-hash-table hash-table?))
+
+(cond-expand-provide (current-module) '(srfi-125))
+
+\f
+;;; Private stuff, not exported.
+
+;; Ten of the SRFI 125 procedures are deprecated, and another
+;; two allow alternative arguments that are deprecated.
+
+(define (issue-deprecated-warnings?) #t)
+
+(define (issue-warning-deprecated name-of-deprecated-misfeature)
+ (if (not (memq name-of-deprecated-misfeature already-warned))
+ (begin
+ (set! already-warned
+ (cons name-of-deprecated-misfeature already-warned))
+ (if (issue-deprecated-warnings?)
+ (let ((out (current-error-port)))
+ (display "WARNING: " out)
+ (display name-of-deprecated-misfeature out)
+ (newline out)
+ (display " is deprecated by SRFI 125. See" out)
+ (newline out)
+ (display " " out)
+ (display url:deprecated out)
+ (newline out))))))
+
+(define url:deprecated
+ "http://srfi.schemers.org/srfi-125/srfi-125.html")
+
+;; List of deprecated features for which a warning has already
+;; been issued.
+
+(define already-warned '())
+
+;;; Comentary from SRFI 125 standard implementation
+;;;
+;;; Comparators contain a type test predicate, which implementations
+;;; of the hash-table-set! procedure can use to reject invalid keys.
+;;; That's hard to do without sacrificing interoperability with R6RS
+;;; and/or SRFI 69 and/or SRFI 126 hash tables.
+;;;
+;;; Full interoperability means the hash tables implemented here are
+;;; interchangeable with the SRFI 126 hashtables used to implement them.
+;;; SRFI 69 and R6RS and SRFI 126 hashtables don't contain comparators,
+;;; so any association between a hash table and its comparator would have
+;;; to be maintained outside the representation of hash tables themselves,
+;;; which is problematic unless weak pointers are available.
+;;;
+;;; Not all of the hash tables implemented here will have comparators
+;;; associated with them anyway, because an equivalence procedure
+;;; and hash function can be used to create a hash table instead of
+;;; a comparator (although that usage is deprecated by SRFI 125).
+;;;
+;;; One way to preserve interoperability while enforcing a comparator's
+;;; type test is to incorporate that test into a hash table's hash
+;;; function. The advantage of doing that should be weighed against
+;;; these disadvantages:
+;;;
+;;; If the type test is slow, then hashing would also be slower.
+;;;
+;;; The R6RS, SRFI 69, and SRFI 126 APIs allow extraction of
+;;; a hash function from some hash tables.
+;;; Some programmers might expect that hash function to be the
+;;; hash function encapsulated by the comparator (in the sense
+;;; of eq?, perhaps) even though this API makes no such guarantee
+;;; (and extraction of that hash function from an existing hash
+;;; table can only be done by calling a deprecated procedure).
+
+;; If %enforce-comparator-type-tests is true, then make-hash-table,
+;; when passed a comparator, will use a hash function that enforces
+;; the comparator's type test.
+
+(define %enforce-comparator-type-tests #t)
+
+;;; Don't use HASH-FUNCTION if EQUIV is a (known) refinement of EQUAL?
+(define (%get-hash-table-hash-function equiv hash-function)
+ (if (or (eq? eq? equiv)
+ (eq? eqv? equiv)
+ (eq? equal? equiv)
+ (eq? string=? equiv))
+ ;; Let GENERIC-HASH-TABLES decide a better HASH-FUNCTION
+ #f
+ ;; Not required by specification, but implemented by standard
+ ;; implementation
+ (if (eq? symbol=? equiv)
+ symbol-hash
+ hash-function)))
+
+;;; Given a comparator, return its hash function, possibly augmented
+;;; by the comparator's type test.
+(define (%comparator-hash-function comparator)
+ (let ((okay? (comparator-type-test-predicate comparator))
+ (hash-function (%get-hash-table-hash-function
+ (comparator-equality-predicate comparator)
+ (comparator-hash-function comparator))))
+ (and hash-function
+ (if (and %enforce-comparator-type-tests
+ ;; These procedures already test type
+ (not (or (eq? hash-function symbol-hash)
+ (eq? hash-function string-ci-hash))))
+ (lambda (x)
+ (cond ((not (okay? x))
+ (error "Key rejected by hash-table comparator"
+ x
+ comparator))
+ (else
+ (hash-function x))))
+ hash-function))))
+
+;;; We let GENERIC-HASH-TABLES decide which weaknesses are supported
+(define (%check-optional-arguments procname args)
+ (if (memq 'thread-safe args)
+ (error (string-append (symbol->string procname)
+ ": unsupported optional argument(s)")
+ args)))
+
+(define (%get-hash-table-weakness args)
+ (cond
+ ((memq 'ephemeral-values args)
+ (if (or (memq 'ephemeral-keys args)
+ (memq 'weak-keys args))
+ 'ephemeral-key-and-value
+ 'ephemeral-value))
+ ((memq 'ephemeral-keys args)
+ (if (memq 'weak-values args)
+ 'ephemeral-key-and-value
+ 'ephemeral-key))
+ ((memq 'weak-keys args)
+ (if (memq 'weak-values args)
+ 'weak-key-and-value
+ 'weak-key))
+ ((memq 'weak-values args)
+ 'weak-value)
+ (else #f)))
+
+(define (%get-hash-table-capacity args)
+ (or (find integer? args) 1))
+
+\f
+;;; Constructors.
+
+;;; Comentary from SRFI 125 standard implementation
+;;;
+;;; The first argument can be a comparator or an equality predicate.
+;;;
+;;; If the first argument is a comparator, any remaining arguments
+;;; are implementation-dependent, but a non-negative exact integer
+;;; should be interpreted as an initial capacity and the symbols
+;;; thread-safe, weak-keys, ephemeral-keys, weak-values, and
+;;; emphemeral-values should be interpreted specially. (These
+;;; special symbols are distinct from the analogous special symbols
+;;; in SRFI 126.)
+;;;
+;;; If the first argument is not a comparator, then it had better
+;;; be an equality predicate (which is deprecated by SRFI 125).
+;;; If a second argument is present and is a procedure, then it's
+;;; a hash function (which is allowed only for the deprecated case
+;;; in which the first argument is an equality predicate). If a
+;;; second argument is not a procedure, then it's some kind of
+;;; implementation-dependent optional argument, as are all arguments
+;;; beyond the second.
+;;;
+;;; SRFI 128 defines make-eq-comparator, make-eqv-comparator, and
+;;; make-equal-comparator procedures whose hash function is the
+;;; default-hash procedure of SRFI 128, which is inappropriate
+;;; for use with eq? and eqv? unless the object being hashed is
+;;; never mutated. Neither SRFI 125 nor 128 provide any way to
+;;; define a comparator whose hash function is truly compatible
+;;; with the use of eq? or eqv? as an equality predicate.
+;;;
+;;; That would make SRFI 125 almost as bad as SRFI 69 if not for
+;;; the following paragraph of SRFI 125:
+;;;
+;;; Implementations are permitted to ignore user-specified
+;;; hash functions in certain circumstances. Specifically,
+;;; if the equality predicate, whether passed as part of a
+;;; comparator or explicitly, is more fine-grained (in the
+;;; sense of R7RS-small section 6.1) than equal?, the
+;;; implementation is free — indeed, is encouraged — to
+;;; ignore the user-specified hash function and use something
+;;; implementation-dependent. This allows the use of addresses
+;;; as hashes, in which case the keys must be rehashed if
+;;; they are moved by the garbage collector. Such a hash
+;;; function is unsafe to use outside the context of
+;;; implementation-provided hash tables. It can of course be
+;;; exposed by an implementation as an extension, with
+;;; suitable warnings against inappropriate uses.
+;;;
+;;; That gives implementations permission to do something more
+;;; useful, but when should implementations take advantage of
+;;; that permission? This implementation uses the superior
+;;; solution provided by SRFI 126 whenever:
+;;;
+;;; A comparator is passed as first argument and its equality
+;;; predicate is eq? or eqv?.
+;;;
+;;; The eq? or eqv? procedure is passed as first argument
+;;; (which is a deprecated usage).
+
+(define (make-hash-table comparator/equiv . rest)
+ (if (comparator? comparator/equiv)
+ (let ((equiv (comparator-equality-predicate comparator/equiv))
+ (hash-function (%comparator-hash-function comparator/equiv)))
+ (%make-hash-table equiv hash-function rest))
+ (let* ((equiv comparator/equiv)
+ (hash-function (if (and (not (null? rest))
+ (procedure? (car rest)))
+ (car rest)
+ #f))
+ (rest (if hash-function (cdr rest) rest)))
+ (issue-warning-deprecated 'srfi-69-style:make-hash-table)
+ (%make-hash-table equiv (%get-hash-table-hash-function equiv hash-function)
+ rest))))
+
+(define (%make-hash-table equiv hash-function opts)
+ (%check-optional-arguments 'make-hash-table opts)
+ (let ((weakness (%get-hash-table-weakness opts))
+ (capacity (%get-hash-table-capacity opts)))
+ (gen:make-hash-table equiv hash-function
+ #:capacity capacity #:weakness weakness)))
+
+(define (hash-table comparator . args)
+ (let ((equiv (comparator-equality-predicate comparator))
+ (hash-function (%comparator-hash-function comparator)))
+ (apply gen:hash-table (if hash-function
+ (list equiv hash-function)
+ equiv)
+ args)))
+
+(define (hash-table-unfold stop? mapper successor seed comparator . rest)
+ (let ((equiv (comparator-equality-predicate comparator))
+ (hash-function (%comparator-hash-function comparator))
+ (weakness (%get-hash-table-weakness rest))
+ (capacity (%get-hash-table-capacity rest)))
+ (gen:hash-table-unfold stop? mapper successor seed
+ equiv hash-function #:weakness weakness
+ #:capacity capacity)))
+
+(define (alist->hash-table alist comparator/equiv . rest)
+ (if (procedure? comparator/equiv)
+ (let* ((equiv comparator/equiv)
+ (hash-function (and (pair? rest) (procedure? (car rest))
+ (car rest)))
+ (rest (if hash-function (cdr rest) rest))
+ (hash-function (%get-hash-table-hash-function equiv hash-function))
+ (weakness (%get-hash-table-weakness rest))
+ (capacity (%get-hash-table-capacity rest)))
+ (issue-warning-deprecated 'srfi-69-style:alist->hash-table)
+ (gen:alist->hash-table alist equiv hash-function
+ #:capacity capacity #:weakness weakness))
+ (let* ((equiv (comparator-equality-predicate comparator/equiv))
+ (hash-function (%comparator-hash-function comparator/equiv))
+ (weakness (%get-hash-table-weakness rest))
+ (capacity (%get-hash-table-capacity rest)))
+ (gen:alist->hash-table alist equiv hash-function
+ #:capacity capacity #:weakness weakness))))
+
+\f
+;;;; Accessing table items
+
+(define hash-table-ref gen:hash-table-ref)
+(define hash-table-ref/default gen:hash-table-ref/default)
+
+\f
+;;; Predicates.
+
+(define hash-table? gen:hash-table?)
+(define hash-table-empty? gen:hash-table-empty?)
+(define hash-table-contains? gen:hash-table-contains?)
+(define hash-table-mutable? gen:hash-table-mutable?)
+
+(define (hash-table=? value-comparator ht1 ht2)
+ (gen:hash-table=? (comparator-equality-predicate value-comparator)
+ ht1 ht2))
+
+\f
+;;; Mutators.
+
+(define hash-table-set! gen:hash-table-set!)
+(define hash-table-delete! gen:hash-table-delete!)
+(define hash-table-intern! gen:hash-table-intern!)
+(define hash-table-update! gen:hash-table-update!)
+(define hash-table-update!/default gen:hash-table-update!/default)
+(define hash-table-pop! gen:hash-table-pop!)
+(define (hash-table-clear! ht) (gen:hash-table-clear! ht))
+
+\f
+;; The whole hash table.
+
+(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-entries gen:hash-table-entries)
+(define hash-table-find gen:hash-table-find)
+(define hash-table-count gen:hash-table-count)
+
+\f
+;;; Mapping and folding.
+
+(define hash-table-map->list gen:hash-table-map->list)
+(define hash-table-for-each gen:hash-table-for-each)
+(define hash-table-prune! gen:hash-table-prune!)
+(define hash-table-map! gen:hash-table-map!)
+
+(define (hash-table-map proc comparator ht)
+ (let ((equiv (comparator-equality-predicate comparator))
+ (hash-function (%comparator-hash-function comparator)))
+ (gen:hash-table-map proc ht equiv hash-function)))
+
+(define (hash-table-fold proc init ht)
+ (if (hash-table? proc)
+ (begin (issue-warning-deprecated 'srfi-69-style:hash-table-fold)
+ (hash-table-fold init ht proc))
+ (gen:hash-table-fold proc init ht)))
+
+
+\f
+;;; Copying and conversion.
+
+(define hash-table->alist gen:hash-table->alist)
+
+(define* (hash-table-copy ht #:optional mutable)
+ (gen:hash-table-copy ht #:mutable mutable))
+
+(define (hash-table-empty-copy ht)
+ (gen:hash-table-empty-copy ht))
+
+\f
+;;; Hash tables as sets.
+
+(define (hash-table-union! ht1 ht2)
+ (unless (eq? (gen:hash-table-equivalence-function ht1)
+ (gen:hash-table-equivalence-function ht2))
+ (error "Hash tables have different equivalence functions" ht1 ht2))
+ (gen:hash-table-union! ht1 ht2))
+
+(define (hash-table-intersection! ht1 ht2)
+ (unless (eq? (gen:hash-table-equivalence-function ht1)
+ (gen:hash-table-equivalence-function ht2))
+ (error "Hash tables have different equivalence functions" ht1 ht2))
+ (gen:hash-table-intersection! ht1 ht2))
+
+(define (hash-table-difference! ht1 ht2)
+ (unless (eq? (gen:hash-table-equivalence-function ht1)
+ (gen:hash-table-equivalence-function ht2))
+ (error "Hash tables have different equivalence functions" ht1 ht2))
+ (gen:hash-table-difference! ht1 ht2))
+
+(define (hash-table-xor! ht1 ht2)
+ (unless (eq? (gen:hash-table-equivalence-function ht1)
+ (gen:hash-table-equivalence-function ht2))
+ (error "Hash tables have different equivalence functions" ht1 ht2))
+ (gen:hash-table-xor! ht1 ht2))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; The following procedures are deprecated by SRFI 125, but must
+;;; be exported nonetheless.
+;;;
+;;; Programs that import the (srfi 125) library must rename the
+;;; deprecated string-hash and string-ci-hash procedures to avoid
+;;; conflict with the string-hash and string-ci-hash procedures
+;;; exported by SRFI 126 and SRFI 128.
+;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (deprecated:hash obj . rest)
+ (issue-warning-deprecated 'hash)
+ (apply gen:hash obj rest))
+
+(define (deprecated:string-hash obj . rest)
+ (issue-warning-deprecated 'srfi-125:string-hash)
+ (apply string-hash obj rest))
+
+(define (deprecated:string-ci-hash obj . rest)
+ (issue-warning-deprecated 'srfi-125:string-ci-hash)
+ (apply string-ci-hash obj rest))
+
+(define (deprecated:hash-by-identity obj . rest)
+ (issue-warning-deprecated 'hash-by-identity)
+ (apply gen:hash-by-identity obj rest))
+
+(define (deprecated:hash-table-equivalence-function ht)
+ (issue-warning-deprecated 'hash-table-equivalence-function)
+ (gen:hash-table-equivalence-function ht))
+
+(define (deprecated:hash-table-hash-function ht)
+ (issue-warning-deprecated 'hash-table-hash-function)
+ (gen:hash-table-hash-function ht))
+
+(define (deprecated:hash-table-exists? ht key)
+ (issue-warning-deprecated 'hash-table-exists?)
+ (gen:hash-table-contains? ht key))
+
+(define (deprecated:hash-table-walk ht proc)
+ (issue-warning-deprecated 'hash-table-walk)
+ (gen:hash-table-for-each proc ht))
+
+(define (deprecated:hash-table-merge! ht1 ht2)
+ (issue-warning-deprecated 'hash-table-merge!)
+ (gen:hash-table-union! ht1 ht2))
+
+;; eof
diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am
index a2f73b329..38537aaac 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-125.test \
tests/srfi-126.test \
tests/srfi-128.test \
tests/srfi-4.test \
diff --git a/test-suite/tests/srfi-125.test b/test-suite/tests/srfi-125.test
new file mode 100644
index 000000000..e5ba95ed3
--- /dev/null
+++ b/test-suite/tests/srfi-125.test
@@ -0,0 +1,860 @@
+;;;; srfi-125.test --- Test suite for SRFI 125 -*- scheme -*-
+;;;;
+;;;; Copyright (C) 2019 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-125 reference
+;;; implementation ported to Guile test suite.
+
+;;; Copyright (C) William D Clinger 2015. All Rights Reserved.
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without restriction,
+;;; including without limitation the rights to use, copy, modify, merge,
+;;; publish, distribute, sublicense, and/or sell copies of the Software,
+;;; and to permit persons to whom the Software is furnished to do so,
+;;; subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
+;;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
+;;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
+;;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
+;;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+
+;;; Comentary from standard SRFI 125 tests:
+;;;
+;;; This is a very shallow sanity test for hash tables.
+;;;
+;;; Tests marked by a "FIXME: glass-box" comment test behavior of the
+;;; reference implementation that is not required by the specification.
+
+(define-module (test-srfi-125)
+ #:duplicates (last)
+ #:use-module (test-suite lib)
+ #:use-module (srfi srfi-128)
+ #:use-module (srfi srfi-125)
+ #:use-module (srfi srfi-1)
+ #:use-module (rnrs bytevectors)
+ #:use-module ((rnrs base) #:select (symbol=?))
+ #:use-module ((rnrs) #:select (list-sort guard)))
+
+(define (bytevector . args)
+ (u8-list->bytevector args))
+
+(define default-comparator (make-default-comparator))
+
+(define number-comparator
+ (make-comparator real? = < (lambda (x) (inexact->exact (abs (round x))))))
+
+(define string-comparator
+ (make-comparator string? string=? string<? string-hash))
+
+(define string-ci-comparator
+ (make-comparator string? string-ci=? string-ci<? string-ci-hash))
+
+(define eq-comparator (make-eq-comparator))
+
+(define eqv-comparator (make-eqv-comparator))
+
+;;; Returns an immutable hash table.
+
+(define (hash-table-tabulate comparator n proc)
+ (let ((ht (make-hash-table comparator)))
+ (do ((i 0 (+ i 1)))
+ ((= i n)
+ (hash-table-copy ht))
+ (call-with-values
+ (lambda ()
+ (proc i))
+ (lambda (key val)
+ (hash-table-set! ht key val))))))
+
+;;; Constructors.
+
+(define ht-default (make-hash-table default-comparator))
+
+(define ht-eq (make-hash-table eq-comparator 'random-argument "another"))
+
+(define ht-eqv (make-hash-table eqv-comparator))
+
+(define ht-eq2 (make-hash-table eq?))
+
+(define ht-eqv2 (make-hash-table eqv?))
+
+(define ht-equal (make-hash-table equal?))
+
+(define ht-string (make-hash-table string=?))
+
+(define ht-string-ci (make-hash-table string-ci=?))
+
+(define ht-symbol (make-hash-table symbol=?)) ; FIXME: glass-box
+
+(define ht-fixnum (make-hash-table = abs))
+
+;; Spec says HASH-TABLE returns an immutable hash table, so we put a
+;; HASH-TABLE-COPY here
+(define ht-default2
+ (hash-table-copy
+ (hash-table default-comparator 'foo 'bar 101.3 "fever" '(x y z) '#())
+ #t))
+
+(define ht-fixnum2
+ (hash-table-tabulate number-comparator
+ 10
+ (lambda (i) (values (* i i) i))))
+
+(define ht-string2
+ (hash-table-unfold (lambda (s) (= 0 (string-length s)))
+ (lambda (s) (values s (string-length s)))
+ (lambda (s) (substring s 0 (- (string-length s) 1)))
+ "prefixes"
+ string-comparator
+ 'ignored1 'ignored2 "ignored3" '#(ignored 4 5)))
+
+(define ht-string-ci2
+ (alist->hash-table '(("" . 0) ("Mary" . 4) ("Paul" . 4) ("Peter" . 5))
+ string-ci-comparator
+ "ignored1" 'ignored2))
+
+(define ht-symbol2
+ (alist->hash-table '((mary . travers) (noel . stookey) (peter . yarrow))
+ eq?))
+
+(define ht-equal2
+ (alist->hash-table '(((edward) . abbey)
+ ((dashiell) . hammett)
+ ((edward) . teach)
+ ((mark) . twain))
+ equal?
+ (comparator-hash-function default-comparator)))
+
+(define test-tables
+ (list ht-default ht-default2 ; initial keys: foo, 101.3, (x y z)
+ ht-eq ht-eq2 ; initially empty
+ ht-eqv ht-eqv2 ; initially empty
+ ht-equal ht-equal2 ; initial keys: (edward), (dashiell), (mark)
+ ht-string ht-string2 ; initial keys: "p, "pr", ..., "prefixes"
+ ht-string-ci ht-string-ci2 ; initial keys: "", "Mary", "Paul", "Peter"
+ ht-symbol ht-symbol2 ; initial keys: mary, noel, peter
+ ht-fixnum ht-fixnum2)) ; initial keys: 0, 1, 4, 9, ..., 81
+
+
+(with-test-prefix "SRFI-125"
+
+ (with-test-prefix "predicates"
+
+ (pass-if-equal "hash-table? functions properly"
+ (append '(#f #f) (map (lambda (x) #t) test-tables))
+ (map hash-table?
+ (cons '#()
+ (cons default-comparator
+ test-tables))))
+
+ (pass-if-equal "hash-table-contains? functions properly"
+ '(#f #t #f #f #f #f #f #t #f #t #f #t #f #t #f #t)
+ (map hash-table-contains?
+ test-tables
+ '(foo 101.3
+ x "y"
+ (14 15) #\newline
+ (edward) (mark)
+ "p" "pref"
+ "mike" "PAUL"
+ jane noel
+ 0 4)))
+
+ (pass-if-equal "hash-table-contains? functions properly"
+ (map (lambda (x) #f) test-tables)
+ (map hash-table-contains?
+ test-tables
+ `(,(bytevector) 47.9
+ '#() '()
+ foo bar
+ 19 (henry)
+ "p" "perp"
+ "mike" "Noel"
+ jane paul
+ 0 5)))
+
+ (pass-if-equal "hash-table-empty? functions properly"
+ '(#t #f #t #t #t #t #t #f #t #f #t #f #t #f #t #f)
+ (map hash-table-empty? test-tables))
+
+ (pass-if-equal "hash-table=? is reflective"
+ (map (lambda (x) #t) test-tables)
+ (map (lambda (ht1 ht2) (hash-table=? default-comparator ht1 ht2))
+ test-tables
+ test-tables))
+
+ (pass-if-equal "hash-table=? functions properly"
+ '(#f #f #t #t #t #t #f #f #f #f #f #f #f #f #f #f)
+ (map (lambda (ht1 ht2) (hash-table=? default-comparator ht1 ht2))
+ test-tables
+ (do ((tables (reverse test-tables) (cddr tables))
+ (rev '() (cons (car tables) (cons (cadr tables) rev))))
+ ((null? tables)
+ rev))))
+
+ (pass-if-equal "hash-table-mutable? functions properly on mutable hash tables 1"
+ '(#t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #f)
+ (map hash-table-mutable? test-tables))
+
+ (pass-if-equal "hash-table-mutable? functions properly on immutable hash tables"
+ (map (lambda (x) #f) test-tables)
+ (map hash-table-mutable? (map hash-table-copy test-tables)))
+
+ (pass-if "hash-table-mutable? functions properly on mutable hash tables 2"
+ (hash-table-mutable? (hash-table-copy ht-fixnum2 #t))))
+
+ (with-test-prefix "accessors"
+
+ (pass-if-equal "hash-table-ref when key is not in table 1"
+ (map (lambda (ht) 'err) test-tables)
+ (map (lambda (ht)
+ (guard (exn
+ (else 'err))
+ (hash-table-ref ht 'not-a-key)))
+ test-tables))
+
+ (pass-if-equal "hash-table-ref when key is not in table 2"
+ (map (lambda (ht) 'err) test-tables)
+ (map (lambda (ht)
+ (guard (exn
+ (else 'err))
+ (hash-table-ref ht 'not-a-key (lambda () 'err))))
+ test-tables))
+
+ (pass-if-equal "hash-table-ref when key is not in table 3"
+ (map (lambda (ht) 'err) test-tables)
+ (map (lambda (ht)
+ (guard (exn
+ (else 'err))
+ (hash-table-ref ht 'not-a-key (lambda () 'err) values)))
+ test-tables))
+
+ (pass-if-equal "hash-table-ref functions properly"
+ '(err "fever" err err err err err twain err 4 err 4 err stookey err 2)
+ (map (lambda (ht key)
+ (guard (exn
+ (else 'err))
+ (hash-table-ref ht key)))
+ test-tables
+ '(foo 101.3
+ x "y"
+ (14 15) #\newline
+ (edward) (mark)
+ "p" "pref"
+ "mike" "PAUL"
+ jane noel
+ 0 4)))
+
+ (pass-if-equal "hash-table-ref accepts FAILURE and functions properly"
+ '(eh "fever" eh eh eh eh eh twain eh 4 eh 4 eh stookey eh 2)
+ (map (lambda (ht key)
+ (hash-table-ref ht key (lambda () 'eh)))
+ test-tables
+ '(foo 101.3
+ x "y"
+ (14 15) #\newline
+ (edward) (mark)
+ "p" "pref"
+ "mike" "PAUL"
+ jane noel
+ 0 4)))
+
+ (pass-if-equal "hash-table-ref accepts FAILURE and SUCCESS and functions properly"
+ '(eh ("fever") eh eh eh eh eh (twain) eh (4) eh (4) eh (stookey) eh (2))
+ (map (lambda (ht key)
+ (guard (exn
+ (else 'err))
+ (hash-table-ref ht key (lambda () 'eh) list)))
+ test-tables
+ '(foo 101.3
+ x "y"
+ (14 15) #\newline
+ (edward) (mark)
+ "p" "pref"
+ "mike" "PAUL"
+ jane noel
+ 0 4)))
+
+ (pass-if-equal "hash-table-ref/default uses DEFAULT"
+ (map (lambda (ht) 'eh) test-tables)
+ (map (lambda (ht)
+ (guard (exn
+ (else 'eh))
+ (hash-table-ref/default ht 'not-a-key 'eh)))
+ test-tables))
+
+ (pass-if-equal "hash-table-ref/default functions properly"
+ '(eh "fever" eh eh eh eh eh twain eh 4 eh 4 eh stookey eh 2)
+ (map (lambda (ht key)
+ (hash-table-ref/default ht key 'eh))
+ test-tables
+ '(foo 101.3
+ x "y"
+ (14 15) #\newline
+ (edward) (mark)
+ "p" "pref"
+ "mike" "PAUL"
+ jane noel
+ 0 4))))
+
+ (with-test-prefix "mutators"
+
+ (pass-if-equal "hash-table-set! with no key-value pairs does nothing"
+ '()
+ (begin (hash-table-set! ht-fixnum)
+ (list-sort < (hash-table-keys ht-fixnum))))
+
+ (pass-if-equal "hash-table-set! functions properly 1"
+ '(121 144 169)
+ (begin (hash-table-set! ht-fixnum 121 11 144 12 169 13)
+ (list-sort < (hash-table-keys ht-fixnum))))
+
+ (pass-if-equal "hash-table-set! functions properly 2"
+ '(0 1 4 9 16 25 36 49 64 81 121 144 169)
+ (begin (hash-table-set! ht-fixnum
+ 0 0 1 1 4 2 9 3 16 4 25 5 36 6 49 7 64 8 81 9)
+ (list-sort < (hash-table-keys ht-fixnum))))
+
+ (pass-if-equal "hash-table-set! functions properly 3"
+ '(13 12 11 0 1 2 3 4 5 6 7 8 9)
+ (map (lambda (i) (hash-table-ref/default ht-fixnum i 'error))
+ '(169 144 121 0 1 4 9 16 25 36 49 64 81)))
+
+ (pass-if-equal "hash-table-delete! with no keys does nothing"
+ '(13 12 11 0 1 2 3 4 5 6 7 8 9)
+ (begin (hash-table-delete! ht-fixnum)
+ (map (lambda (i) (hash-table-ref/default ht-fixnum i 'error))
+ '(169 144 121 0 1 4 9 16 25 36 49 64 81))))
+
+ (pass-if-equal "hash-table-delete! functions properly 1"
+ '(-1 12 -1 0 -1 2 -1 4 -1 6 -1 8 -1)
+ (begin (hash-table-delete! ht-fixnum 1 9 25 49 81 200 121 169 81 1)
+ (map (lambda (i) (hash-table-ref/default ht-fixnum i -1))
+ '(169 144 121 0 1 4 9 16 25 36 49 64 81))))
+
+ (pass-if-equal "hash-table-delete! functions properly 2"
+ '(-1 12 -1 -1 -1 2 -1 4 -1 -1 -1 8 -1)
+ (begin (hash-table-delete! ht-fixnum 200 100 0 81 36)
+ (map (lambda (i) (hash-table-ref/default ht-fixnum i -1))
+ '(169 144 121 0 1 4 9 16 25 36 49 64 81))))
+
+ (pass-if-equal "hash-table-intern! functions properly 1"
+ '(13 12 11 0 1 2 -1 4 -1 -1 -1 8 -1)
+ (begin (hash-table-intern! ht-fixnum 169 (lambda () 13))
+ (hash-table-intern! ht-fixnum 121 (lambda () 11))
+ (hash-table-intern! ht-fixnum 0 (lambda () 0))
+ (hash-table-intern! ht-fixnum 1 (lambda () 1))
+ (hash-table-intern! ht-fixnum 1 (lambda () 99))
+ (hash-table-intern! ht-fixnum 121 (lambda () 66))
+ (map (lambda (i) (hash-table-ref/default ht-fixnum i -1))
+ '(169 144 121 0 1 4 9 16 25 36 49 64 81))))
+
+ (pass-if-equal "hash-table-map->list functions properly 1"
+ '(#(0 0) #(1 1) #(4 2) #(16 4) #(64 8) #(121 11) #(144 12) #(169 13))
+ (list-sort (lambda (v1 v2) (< (vector-ref v1 0) (vector-ref v2 0)))
+ (hash-table-map->list vector ht-fixnum)))
+
+ (pass-if-equal "hash-table-prune! functions properly"
+ '((0 0) (1 1) (4 2) (16 4) (64 8) #;(121 11) (144 12) #;(169 13))
+ (begin (hash-table-prune! (lambda (key val)
+ (and (odd? key) (> val 10)))
+ ht-fixnum)
+ (list-sort (lambda (l1 l2)
+ (< (car l1) (car l2)))
+ (hash-table-map->list list ht-fixnum))))
+
+ (pass-if-equal "hash-table-intern! functions properly 2"
+ '((0 0) (1 1) (4 2) (16 4) (64 8) (121 11) (144 12) (169 13))
+ (begin (hash-table-intern! ht-fixnum 169 (lambda () 13))
+ (hash-table-intern! ht-fixnum 144 (lambda () 9999))
+ (hash-table-intern! ht-fixnum 121 (lambda () 11))
+ (list-sort (lambda (l1 l2)
+ (< (car l1) (car l2)))
+ (hash-table-map->list list ht-fixnum))))
+
+ (pass-if-equal "hash-table-update! with FAILURE functions properly 1"
+ '(13 12 11 0 1 2 3 4 -1 -1 -1 8 -1)
+ (begin (hash-table-update! ht-fixnum 9 length (lambda () '(a b c)))
+ (map (lambda (i) (hash-table-ref/default ht-fixnum i -1))
+ '(169 144 121 0 1 4 9 16 25 36 49 64 81))))
+
+ (pass-if-equal "hash-table-update! functions properly"
+ '(13 12 11 0 1 2 3 -4 -1 -1 -1 8 -1)
+ (begin (hash-table-update! ht-fixnum 16 -)
+ (map (lambda (i) (hash-table-ref/default ht-fixnum i -1))
+ '(169 144 121 0 1 4 9 16 25 36 49 64 81))))
+
+ (pass-if-equal "hash-table-update! with FAILURE functions properly 2"
+ '(13 12 11 0 1 2 3 4 -1 -1 -1 8 -1)
+ (begin (hash-table-update! ht-fixnum 16 - abs)
+ (map (lambda (i) (hash-table-ref/default ht-fixnum i -1))
+ '(169 144 121 0 1 4 9 16 25 36 49 64 81))))
+
+ (pass-if-equal "hash-table-update!/default functions properly 1"
+ '(13 12 11 0 1 2 3 4 -5 -1 -1 8 -1)
+ (begin (hash-table-update!/default ht-fixnum 25 - 5)
+ (map (lambda (i) (hash-table-ref/default ht-fixnum i -1))
+ '(169 144 121 0 1 4 9 16 25 36 49 64 81))))
+
+ (pass-if-equal "hash-table-update!/default functions properly 2"
+ '(13 12 11 0 1 2 3 4 5 -1 -1 8 -1)
+ (begin (hash-table-update!/default ht-fixnum 25 - 999)
+ (map (lambda (i) (hash-table-ref/default ht-fixnum i -1))
+ '(169 144 121 0 1 4 9 16 25 36 49 64 81))))
+
+ (pass-if "hash-table-pop! functions properly"
+ (let* ((n0 (hash-table-size ht-fixnum))
+ (ht (hash-table-copy ht-fixnum #t)))
+ (call-with-values
+ (lambda () (hash-table-pop! ht))
+ (lambda (key val)
+ (and (= key (* val val))
+ (= (- n0 1) (hash-table-size ht)))))))
+
+ (pass-if-equal "hash-table-delete! functions properly 2"
+ '(13 12 11 0 1 2 3 4 5 -1 -1 8 -1 -1)
+ (begin (hash-table-delete! ht-fixnum 75)
+ (map (lambda (i) (hash-table-ref/default ht-fixnum i -1))
+ '(169 144 121 0 1 4 9 16 25 36 49 64 75 81))))
+
+ ;; Spec says HASH-TABLE returns an immutable hash table, so we put a
+ ;; HASH-TABLE-COPY here
+ (let ((ht-eg (hash-table-copy
+ (hash-table number-comparator 1 1 4 2 9 3 16 4 25 5 64 8)
+ #t)))
+ (pass-if-equal "hash-table-delete! functions properly 3"
+ 0
+ (hash-table-delete! ht-eg))
+ (pass-if-equal "hash-table-delete! functions properly 4"
+ 0
+ (hash-table-delete! ht-eg 2 7 2000))
+ (pass-if-equal "hash-table-delete! functions properly 5"
+ 3
+ (hash-table-delete! ht-eg 1 2 4 7 64 2000))
+ (pass-if "hash-table-delete! functions properly 6"
+ (= 3 (length (hash-table-keys ht-eg)))))
+
+ (pass-if-equal "hash-table-ref/default functions properly 2"
+ '(13 12 11 0 1 2 3 4 5 -1 -1 8 -1)
+ (map (lambda (i) (hash-table-ref/default ht-fixnum i -1))
+ '(169 144 121 0 1 4 9 16 25 36 49 64 81)))
+
+ (pass-if-equal "hash-table-set! functions properly 4"
+ '(13 12 11 0 1 2 3 4 5 6 -1 8 9)
+ (begin (hash-table-set! ht-fixnum 36 6)
+ (hash-table-set! ht-fixnum 81 9)
+ (map (lambda (i) (hash-table-ref/default ht-fixnum i -1))
+ '(169 144 121 0 1 4 9 16 25 36 49 64 81))))
+
+ (pass-if-equal "hash-table-clear! clears hash table"
+ 0
+ (begin (hash-table-clear! ht-eq)
+ (hash-table-size ht-eq))))
+
+ (with-test-prefix "the whole hash table"
+
+ (pass-if-equal "hash-table-size returns correct table size"
+ 3
+ (begin (hash-table-set! ht-eq 'foo 13 'bar 14 'baz 18)
+ (hash-table-size ht-eq)))
+
+ (pass-if-equal "hash-table-size returns correct table size 2"
+ '(0 3 #t)
+ (let* ((ht (hash-table-empty-copy ht-eq))
+ (n0 (hash-table-size ht))
+ (ignored (hash-table-set! ht 'foo 13 'bar 14 'baz 18))
+ (n1 (hash-table-size ht)))
+ (list n0 n1 (hash-table=? default-comparator ht ht-eq))))
+
+ (pass-if-equal "hash-table-size returns 0 with empty hash table"
+ 0
+ (begin (hash-table-clear! ht-eq)
+ (hash-table-size ht-eq)))
+
+ (pass-if-equal "hash-table-find functions properly 1"
+ '(144 12)
+ (hash-table-find (lambda (key val)
+ (if (= 144 key (* val val))
+ (list key val)
+ #f))
+ ht-fixnum
+ (lambda () 99)))
+
+ (pass-if-equal "hash-table-find functions properly 2"
+ 99
+ (hash-table-find (lambda (key val)
+ (if (= 144 key val)
+ (list key val)
+ #f))
+ ht-fixnum
+ (lambda () 99)))
+
+ (pass-if-equal "hash-table-count functions properly"
+ 2
+ (hash-table-count <= ht-fixnum)))
+
+ (with-test-prefix "mapping and folding"
+
+ (pass-if-equal "hash-table-ref/default functions properly 3"
+ '(0 1 2 3 4 5 6 -1 8 9 -1 11 12 13 -1)
+ (map (lambda (i) (hash-table-ref/default ht-fixnum i -1))
+ '(0 1 4 9 16 25 36 49 64 81 100 121 144 169 196)))
+
+ (pass-if-equal "hash-table-map functions properly"
+ '(0 1 4 9 16 25 36 -1 64 81 -1 121 144 169 -1)
+ (let ((ht (hash-table-map (lambda (val) (* val val))
+ eqv-comparator
+ ht-fixnum)))
+ (map (lambda (i) (hash-table-ref/default ht i -1))
+ '(0 1 4 9 16 25 36 49 64 81 100 121 144 169 196))))
+
+ (pass-if-equal "hash-table-for-each functions properly"
+ '(#(0 1 4 9 16 25 36 -1 64 81 -1 121 144 169 -1)
+ #(0 1 2 3 4 5 6 -1 8 9 -1 11 12 13 -1))
+ (let ((keys (make-vector 15 -1))
+ (vals (make-vector 15 -1)))
+ (hash-table-for-each (lambda (key val)
+ (vector-set! keys val key)
+ (vector-set! vals val val))
+ ht-fixnum)
+ (list keys vals)))
+
+ (pass-if-equal "hash-table-map! functions properly"
+ '(0 1 2 3 -4 -5 -6 -1 -8 -9 -1 -11 -12 -13 -1)
+ (begin (hash-table-map! (lambda (key val)
+ (if (<= 10 key)
+ (- val)
+ val))
+ ht-fixnum)
+ (map (lambda (i) (hash-table-ref/default ht-fixnum i -1))
+ '(0 1 4 9 16 25 36 49 64 81 100 121 144 169 196))))
+
+ (pass-if-equal "hash-table-fold functions properly 1"
+ 13
+ (hash-table-fold (lambda (key val acc)
+ (+ val acc))
+ 0
+ ht-string-ci2))
+
+ (pass-if-equal "hash-table-fold functions properly 2"
+ '(0 1 4 9 16 25 36 64 81 121 144 169)
+ (list-sort < (hash-table-fold (lambda (key val acc)
+ (cons key acc))
+ '()
+ ht-fixnum))))
+
+ (with-test-prefix "copying and conversion"
+
+ (pass-if "hash-table-copy functions properly 1"
+ (hash-table=? number-comparator ht-fixnum (hash-table-copy ht-fixnum)))
+
+ (pass-if "hash-table-copy functions properly 2"
+ (hash-table=? number-comparator ht-fixnum (hash-table-copy ht-fixnum #f)))
+
+ (pass-if "hash-table-copy functions properly 3"
+ (hash-table=? number-comparator ht-fixnum (hash-table-copy ht-fixnum #t)))
+
+ (pass-if "hash-table-copy functions properly 4"
+ (not (hash-table-mutable? (hash-table-copy ht-fixnum))))
+
+ (pass-if "hash-table-copy functions properly 5"
+ (not (hash-table-mutable? (hash-table-copy ht-fixnum #f))))
+
+ (pass-if "hash-table-copy functions properly 6"
+ (hash-table-mutable? (hash-table-copy ht-fixnum #t)))
+
+ (pass-if-equal "hash-table->alist functions properly 1"
+ '()
+ (hash-table->alist ht-eq))
+
+ (pass-if-equal "hash-table->alist functions properly 2"
+ '((0 . 0)
+ (1 . 1)
+ (4 . 2)
+ (9 . 3)
+ (16 . -4)
+ (25 . -5)
+ (36 . -6)
+ (64 . -8)
+ (81 . -9)
+ (121 . -11)
+ (144 . -12)
+ (169 . -13))
+ (list-sort (lambda (x y) (< (car x) (car y)))
+ (hash-table->alist ht-fixnum))))
+
+ (with-test-prefix "hash tables as sets"
+
+ (pass-if-equal "hash-table-union! functions properly 1"
+ '((0 . 0)
+ (1 . 1)
+ (4 . 2)
+ (9 . 3)
+ (16 . -4)
+ (25 . -5)
+ (36 . -6)
+ (49 . 7)
+ (64 . -8)
+ (81 . -9)
+ (121 . -11)
+ (144 . -12)
+ (169 . -13))
+ (begin (hash-table-union! ht-fixnum ht-fixnum2)
+ (list-sort (lambda (x y) (< (car x) (car y)))
+ (hash-table->alist ht-fixnum))))
+
+ (pass-if-equal "hash-table-union! functions properly 2"
+ '((0 . 0)
+ (1 . 1)
+ (4 . 2)
+ (9 . 3)
+ (16 . 4)
+ (25 . 5)
+ (36 . 6)
+ (49 . 7)
+ (64 . 8)
+ (81 . 9)
+ (121 . -11)
+ (144 . -12)
+ (169 . -13))
+ (let ((ht (hash-table-copy ht-fixnum2 #t)))
+ (hash-table-union! ht ht-fixnum)
+ (list-sort (lambda (x y) (< (car x) (car y)))
+ (hash-table->alist ht))))
+
+ ;; Spec in Specification section says "It is an error to pass two
+ ;; hash tables that have different comparators or equality
+ ;; predicates to any of the procedures of this SRFI."
+ ;;
+ ;; So we create a new hash table with number-comparator with the
+ ;; contents of ht-eqv2
+
+ (let ((ht-fixnum3 (hash-table-map identity number-comparator ht-eqv2)))
+ (pass-if "hash-table-union! functions properly 3"
+ (begin (hash-table-union! ht-fixnum3 ht-fixnum)
+ (hash-table=? number-comparator ht-fixnum ht-fixnum3)))
+
+ (pass-if "hash-table-intersection! functions properly 1"
+ (begin (hash-table-intersection! ht-fixnum3 ht-fixnum)
+ (hash-table=? number-comparator ht-fixnum ht-fixnum3))))
+
+ (pass-if "hash-table-intersection! functions properly 2"
+ (begin (hash-table-intersection! ht-eqv2 ht-eqv)
+ (hash-table-empty? ht-eqv2)))
+
+ (pass-if-equal "hash-table-intersection! functions properly 3"
+ '((0 . 0)
+ (1 . 1)
+ (4 . 2)
+ (9 . 3)
+ (16 . -4)
+ (25 . -5)
+ (36 . -6)
+ (49 . 7)
+ (64 . -8)
+ (81 . -9))
+ (begin (hash-table-intersection! ht-fixnum ht-fixnum2)
+ (list-sort (lambda (x y) (< (car x) (car y)))
+ (hash-table->alist ht-fixnum))))
+
+ (pass-if-equal "hash-table-intersection! functions properly 4"
+ '((4 . 2)
+ (25 . -5))
+ (begin (hash-table-intersection!
+ ht-fixnum
+ (alist->hash-table '((-1 . -1) (4 . 202) (25 . 205) (100 . 10))
+ number-comparator))
+ (list-sort (lambda (x y) (< (car x) (car y)))
+ (hash-table->alist ht-fixnum))))
+
+ (pass-if-equal "hash-table-difference! functions properly"
+ '((0 . 0)
+ (1 . 1)
+ (9 . 3)
+ (16 . 4)
+ (36 . 6)
+ (49 . 7)
+ (64 . 8)
+ (81 . 9))
+ (let ((ht (hash-table-copy ht-fixnum2 #t)))
+ (hash-table-difference!
+ ht
+ (alist->hash-table '((-1 . -1) (4 . 202) (25 . 205) (100 . 10))
+ number-comparator))
+ (list-sort (lambda (x y) (< (car x) (car y)))
+ (hash-table->alist ht))))
+
+ (pass-if-equal "hash-table-xor! functions properly"
+ '((-1 . -1)
+ (0 . 0)
+ (1 . 1)
+ (9 . 3)
+ (16 . 4)
+ (36 . 6)
+ (49 . 7)
+ (64 . 8)
+ (81 . 9)
+ (100 . 10))
+ (let ((ht (hash-table-copy ht-fixnum2 #t)))
+ (hash-table-xor!
+ ht
+ (alist->hash-table '((-1 . -1) (4 . 202) (25 . 205) (100 . 10))
+ number-comparator))
+ (list-sort (lambda (x y) (< (car x) (car y)))
+ (hash-table->alist ht))))
+
+ (pass-if-exception "hash-table-ref signals 'key not found' error (again)"
+ '(misc-error . "^Key not in table")
+ (hash-table-ref ht-default "this key won't be present")))
+
+ (with-test-prefix "deprecated"
+
+ (pass-if "hash returns exact integers"
+ (let* ((x (list 1 2 3))
+ (y (cons 1 (cdr x)))
+ (h1 (hash x))
+ (h2 (hash y)))
+ (and (exact-integer? h1)
+ (exact-integer? h2)
+ (= h1 h2))))
+
+ (pass-if "string-hash returns exact integers"
+ (let* ((x "abcd")
+ (y (string-append "ab" "cd"))
+ (h1 (string-hash x))
+ (h2 (string-hash y)))
+ (and (exact-integer? h1)
+ (exact-integer? h2)
+ (= h1 h2))))
+
+ (pass-if "string-ci-hash returns exact integers"
+ (let* ((x "Hello There!")
+ (y "hello THERE!")
+ (h1 (string-ci-hash x))
+ (h2 (string-ci-hash y)))
+ (and (exact-integer? h1)
+ (exact-integer? h2)
+ (= h1 h2))))
+
+ (pass-if "hash-by-identity returns exact integers"
+ (let* ((x (vector 'a "bcD" #\c '(d 2.718) -42 (bytevector) '#() (bytevector 9 20)))
+ (y x)
+ (h1 (hash-by-identity x))
+ (h2 (hash-by-identity y)))
+ (and (exact-integer? h1)
+ (exact-integer? h2)
+ (= h1 h2))))
+
+ (pass-if "hash returns exact integers 2"
+ (let* ((x (list 1 2 3))
+ (y (cons 1 (cdr x)))
+ (h1 (hash x 60))
+ (h2 (hash y 60)))
+ (and (exact-integer? h1)
+ (exact-integer? h2)
+ (= h1 h2))))
+
+ (pass-if "string-hash returns exact integers 2"
+ (let* ((x "abcd")
+ (y (string-append "ab" "cd"))
+ (h1 (string-hash x 97))
+ (h2 (string-hash y 97)))
+ (and (exact-integer? h1)
+ (exact-integer? h2)
+ (= h1 h2))))
+
+ (pass-if "string-ci-hash returns exact integers 2"
+ (let* ((x "Hello There!")
+ (y "hello THERE!")
+ (h1 (string-ci-hash x 101))
+ (h2 (string-ci-hash y 101)))
+ (and (exact-integer? h1)
+ (exact-integer? h2)
+ (= h1 h2))))
+
+ (pass-if "hash-by-identity returns exact integers 2"
+ (let* ((x (vector 'a "bcD" #\c '(d 2.718) -42 (bytevector) '#() (bytevector 19 20)))
+ (y x)
+ (h1 (hash-by-identity x 102))
+ (h2 (hash-by-identity y 102)))
+ (and (exact-integer? h1)
+ (exact-integer? h2)
+ (= h1 h2))))
+
+ (pass-if "hash-table-equivalence-function functions properly"
+ (let ((f (hash-table-equivalence-function ht-fixnum)))
+ (if (procedure? f)
+ (f 34 34)
+ #t)))
+
+ (pass-if "hash-table-hash-function functions properly"
+ (let ((f (hash-table-hash-function ht-fixnum)))
+ (if (procedure? f)
+ (= (f 34) (f 34))
+ #t)))
+
+ (pass-if-equal "hash-table-exists? functions properly"
+ '(#t #t #f #f #t #f #f #f #f #t #f)
+ (map (lambda (key) (hash-table-exists? ht-fixnum2 key))
+ '(0 1 2 3 4 5 6 7 8 9 10)))
+
+ (pass-if-equal "hash-table-walk functions properly"
+ (apply +
+ (map (lambda (x) (* x x))
+ '(0 1 2 3 4 5 6 7 8 9)))
+ (let ((n 0))
+ (hash-table-walk ht-fixnum2
+ (lambda (key val) (set! n (+ n key))))
+ n))
+
+ (pass-if-equal "hash-table-fold with reversed arguments functions properly"
+ '(0 1 4 9 16 25 36 49 64 81)
+ (list-sort < (hash-table-fold ht-fixnum2
+ (lambda (key val acc)
+ (cons key acc))
+ '())))
+
+ (pass-if-equal "hash-table-merge! functions properly"
+ '((0 . 0)
+ (.25 . .5)
+ (1 . 1)
+ (4 . 2)
+ (9 . 3)
+ (16 . 4)
+ (25 . 5)
+ (36 . 6)
+ (49 . 7)
+ (64 . 8)
+ (81 . 9)
+ (121 . -11)
+ (144 . -12))
+ (let ((ht (hash-table-copy ht-fixnum2 #t))
+ (ht2 (hash-table number-comparator
+ .25 .5 64 9999 81 9998 121 -11 144 -12)))
+ (hash-table-merge! ht ht2)
+ (list-sort (lambda (x y) (< (car x) (car y)))
+ (hash-table->alist ht))))))
+
+;; eof
--
2.19.1
[-- Attachment #4: 0008-Fix-bugs-in-GENERIC-HASH-TABLES.patch --]
[-- Type: text/x-patch, Size: 2926 bytes --]
From 554b440c488a90c8f6bd2d9bf0aee2425dab67ff Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?J=C3=A9ssica=20Milar=C3=A9?= <jessymilare@gmail.com>
Date: Sat, 12 Jan 2019 18:15:44 -0200
Subject: [PATCH 08/10] Fix bugs in GENERIC-HASH-TABLES
HASH-TABLE-PRUNE! didn't update size after removing keys.
HASH-TABLE-DELETE! accessed hash function and associator
once per key, instead of accessing only once per
procedure call.
* module/ice-9/generic-hash-tables.scm (hash-table-prune!):
Now updates size after removing keys (bug).
* (hash-table-delete!): use WITH-HASHX-VALUES outside of loop,
so that hash function and associator are accessed only once.
---
module/ice-9/generic-hash-tables.scm | 25 ++++++++++++++-----------
1 file changed, 14 insertions(+), 11 deletions(-)
diff --git a/module/ice-9/generic-hash-tables.scm b/module/ice-9/generic-hash-tables.scm
index 31dead97a..62fd5bb13 100644
--- a/module/ice-9/generic-hash-tables.scm
+++ b/module/ice-9/generic-hash-tables.scm
@@ -517,19 +517,20 @@ number of keys that had associations."
(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
+ (with-hashx-values (h a real-table) ht
+ (let* ((count 0)
+ (size (ht-size ht))
+ (delete-one! (lambda (key)
(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))))
+ (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 (- size count)))
+ count)))))
(define (hash-table-intern! ht key failure)
"Effectively invokes HASH-TABLE-REF with the given arguments and
@@ -820,8 +821,10 @@ 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)))
+ (when (proc key val)
+ (unless (ht-weakness ht)
+ (ht-size! ht (- (ht-size ht) 1)))
+ (hashx-remove! h a real-table key)))
real-table)))
\f
--
2.19.1
[-- Attachment #5: 0010-Created-a-procedure-that-returns-the-size-of-a-hash-.patch --]
[-- Type: text/x-patch, Size: 23779 bytes --]
From e2745275e8eeeab5d7b91746e92c1c0e78ffc93b Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?J=C3=A9ssica=20Milar=C3=A9?= <jessymilare@gmail.com>
Date: Sun, 13 Jan 2019 20:44:18 -0200
Subject: [PATCH 10/10] Created a procedure that returns the size of a hash
table
The module (ICE-9 GENERIC-HASH-TABLES) used to keep track of hash table
size by itself. Now, a procedure HASH-N-ITEMS was implemented in
'libguile/hashtab.c' to access the n_items field of Guile hash table
structure.
* libguile/hashtab.c (scm_hash_n_items): created, it returns the number
of items that the given hash table has. It works for normal and weak
hash tables.
* module/ice-9/generic-hash-tables.scm: removed 'size' field of
<generic-hash-table> record type. No procedures need to update it
anymore.
(hash-table-size): now accesses the size using HASH-N-ITEMS. That
guarantees O(1) procedure time.
---
libguile/hashtab.c | 19 ++-
libguile/hashtab.h | 1 +
libguile/weak-table.c | 14 ++
libguile/weak-table.h | 3 +-
module/ice-9/generic-hash-tables.scm | 230 ++++++++++-----------------
5 files changed, 117 insertions(+), 150 deletions(-)
diff --git a/libguile/hashtab.c b/libguile/hashtab.c
index b4f004c1d..dd0659f7c 100644
--- a/libguile/hashtab.c
+++ b/libguile/hashtab.c
@@ -210,6 +210,22 @@ SCM_DEFINE (scm_hash_table_p, "hash-table?", 1, 0, 0,
}
#undef FUNC_NAME
+SCM_DEFINE (scm_hash_n_items, "hash-n-items", 1, 0, 0,
+ (SCM table),
+ "Return the number of elements in the given hash TABLE.")
+#define FUNC_NAME s_scm_hash_n_items
+{
+ if (SCM_WEAK_TABLE_P (table))
+ {
+ return scm_weak_table_n_items (table);
+ }
+
+ SCM_VALIDATE_HASHTABLE (1, table);
+
+ return scm_from_ulong (SCM_HASHTABLE_N_ITEMS (table));
+}
+#undef FUNC_NAME
+
\f
/* Accessing hash table entries. */
@@ -986,8 +1002,7 @@ count_proc (void *pred, SCM key, SCM data, SCM value)
SCM_DEFINE (scm_hash_count, "hash-count", 2, 0, 0,
(SCM pred, SCM table),
"Return the number of elements in the given hash TABLE that\n"
- "cause `(PRED KEY VALUE)' to return true. To quickly determine\n"
- "the total number of elements, use `(const #t)' for PRED.")
+ "cause `(PRED KEY VALUE)' to return true.")
#define FUNC_NAME s_scm_hash_count
{
SCM init;
diff --git a/libguile/hashtab.h b/libguile/hashtab.h
index 61e81b341..70e9daabb 100644
--- a/libguile/hashtab.h
+++ b/libguile/hashtab.h
@@ -78,6 +78,7 @@ SCM_API SCM scm_c_make_hash_table (unsigned long k);
SCM_API SCM scm_make_hash_table (SCM n);
SCM_API SCM scm_hash_table_p (SCM h);
+SCM_API SCM scm_hash_n_items (SCM hash);
SCM_INTERNAL void scm_i_rehash (SCM table, scm_t_hash_fn hash_fn,
void *closure, const char *func_name);
diff --git a/libguile/weak-table.c b/libguile/weak-table.c
index 1e4d8d302..3f94b4fd9 100644
--- a/libguile/weak-table.c
+++ b/libguile/weak-table.c
@@ -515,6 +515,20 @@ scm_weak_table_p (SCM obj)
return scm_from_bool (SCM_WEAK_TABLE_P (obj));
}
+SCM
+scm_weak_table_n_items (SCM table)
+#define FUNC_NAME "weak-table-n-items"
+{
+ scm_t_weak_table *t;
+
+ SCM_VALIDATE_WEAK_TABLE (1, table);
+
+ t = SCM_WEAK_TABLE (table);
+
+ return scm_from_ulong (t->n_items);
+}
+#undef FUNC_NAME
+
SCM
scm_c_weak_table_ref (SCM table, unsigned long raw_hash,
scm_t_table_predicate_fn pred,
diff --git a/libguile/weak-table.h b/libguile/weak-table.h
index bcbc94e3f..b309b11f9 100644
--- a/libguile/weak-table.h
+++ b/libguile/weak-table.h
@@ -45,6 +45,7 @@ typedef SCM (*scm_t_table_fold_fn) (void *closure, SCM k, SCM v, SCM result);
SCM_INTERNAL SCM scm_c_make_weak_table (unsigned long k,
scm_t_weak_table_kind kind);
SCM_INTERNAL SCM scm_weak_table_p (SCM h);
+SCM_INTERNAL SCM scm_weak_table_n_items (SCM table);
SCM_INTERNAL SCM scm_c_weak_table_ref (SCM table, unsigned long raw_hash,
scm_t_table_predicate_fn pred,
@@ -63,7 +64,7 @@ SCM_INTERNAL void scm_weak_table_remq_x (SCM table, SCM key);
SCM_INTERNAL void scm_weak_table_clear_x (SCM table);
SCM_INTERNAL SCM scm_c_weak_table_fold (scm_t_table_fold_fn proc, void *closure,
- SCM init, SCM table);
+ SCM init, SCM table);
SCM_INTERNAL SCM scm_weak_table_fold (SCM proc, SCM init, SCM table);
SCM_INTERNAL void scm_weak_table_for_each (SCM proc, SCM table);
SCM_INTERNAL SCM scm_weak_table_map_to_list (SCM proc, SCM table);
diff --git a/module/ice-9/generic-hash-tables.scm b/module/ice-9/generic-hash-tables.scm
index 62fd5bb13..45cd1364a 100644
--- a/module/ice-9/generic-hash-tables.scm
+++ b/module/ice-9/generic-hash-tables.scm
@@ -187,19 +187,16 @@ alist keys with 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)
+ mutable? 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.
+ ;; Weak hash tables don't use handles.
(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))
@@ -239,10 +236,10 @@ alist keys with EQUIV-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
+ ;; weakness mutable? equivalence-function orig-hash-function
(make-generic-hash-table real-table internal-hash-function
(equivalence-proc->associator equiv-function)
- weakness (and mutable #t) 0
+ weakness (and mutable #t)
equiv-function hash-function))))
;; If the list of arguments is updated, HASH-TABLE, ALIST->HASH-TABLE,
@@ -325,8 +322,7 @@ is signaled."
(error "Two equivalent keys were provided"
(car handle) (car kvs)))
(set-cdr! handle (cadr kvs)))
- (loop (cddr kvs))))
- (ht-size! ht capacity))))
+ (loop (cddr kvs)))))))
ht)))
(define* (hash-table-unfold stop? mapper successor seed
@@ -341,25 +337,12 @@ 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))))
+ (let loop ((seed seed))
+ (if (stop? seed)
+ result
+ (receive (key val) (mapper seed)
+ (hashx-set! h a real-table key val)
+ (loop (successor seed))))))
result))
(define* (alist->hash-table alist equiv-function hash-function
@@ -372,19 +355,9 @@ 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))))
+ (for-each (lambda (pair)
+ (hashx-set! h a real-table (car pair) (cdr pair)))
+ (reverse alist)))
result))
\f
@@ -415,12 +388,7 @@ KEY isn't present."
(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))))
+ (zero? (hash-n-items (ht-real-table ht))))
(define (hash-table-contains? ht key)
"Return whether KEY is a key in HT."
@@ -450,14 +418,8 @@ 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)))))
+ (hashx-set! h a real-table key val))
+ *unspecified*)
(define* (hash-table-set! ht #:optional (key1 ht-unspecified) (val1 ht-unspecified)
#:rest args)
@@ -477,25 +439,15 @@ deleted."
(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))))))))))
+ (hashx-set! h a real-table 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 (hashx-set! h a real-table (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
@@ -505,7 +457,6 @@ had an association and #f otherwise."
(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)
@@ -519,7 +470,6 @@ number of keys that had associations."
(assert-mutable ht)
(with-hashx-values (h a real-table) ht
(let* ((count 0)
- (size (ht-size ht))
(delete-one! (lambda (key)
(when (not (eq? ht-unspecified
(hashx-ref h a real-table key
@@ -528,8 +478,6 @@ number of keys that had associations."
(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 (- size count)))
count)))))
(define (hash-table-intern! ht key failure)
@@ -546,11 +494,9 @@ is set to the result of calling FAILURE and the new value is returned."
(hashx-set! h a real-table key value)
value))
(else value)))
- (let ((handle
- (hashx-create-handle! h a real-table key ht-unspecified)))
+ (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))))
+ (set-cdr! handle (failure)))
(cdr handle)))))
(define (hash-table-intern!/default ht key default)
@@ -566,11 +512,7 @@ is set to DEFAULT and DEFAULT is returned."
(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)))
+ (let ((handle (hashx-create-handle! h a real-table key default)))
(cdr handle)))))
(define* (hash-table-update! ht key updater #:optional
@@ -601,7 +543,6 @@ provided, or signals an error otherwise."
(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*)
@@ -619,12 +560,8 @@ UPDATER, and setting it to the result thereof."
;; 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)))))))
+ (let ((handle (hashx-create-handle! h a real-table key default)))
+ (set-cdr! handle (updater (cdr handle))))))
*unspecified*)
(define (hash-table-pop! ht)
@@ -637,8 +574,6 @@ and value as two values."
(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))))
@@ -649,7 +584,6 @@ and value as two values."
(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
@@ -658,10 +592,7 @@ and value as two values."
(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)))
+ (hash-n-items (ht-real-table ht)))
(define (hash-table-keys ht)
"Returns a list of the keys in HT."
@@ -683,48 +614,60 @@ values in the corresponding order."
(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))
+ (let* ((len (hash-table-size ht))
+ (keys (make-vector len))
+ ;; In a weak hash table, some values might get gargabe
+ ;; collected while the procedure is running, so we double-check
+ ;; if we collected the expected number of keys.
+ (new-len (hash-fold (lambda (key val i)
+ (vector-set! keys i key)
+ (+ i 1))
+ 0 (ht-real-table ht))))
+ (if (< new-len len)
+ (let ((new-keys (make-vector new-len)))
+ (vector-move-left! keys 0 new-len new-keys 0)
+ new-keys)
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))
+ (let* ((len (hash-table-size ht))
+ (vals (make-vector len))
+ ;; In a weak hash table, some values might get gargabe
+ ;; collected while the procedure is running, so we double-check
+ ;; if we collected the expected number of keys.
+ (new-len (hash-fold (lambda (key val i)
+ (vector-set! vals i val)
+ (+ i 1))
+ 0 (ht-real-table ht))))
+ (if (< new-len len)
+ (let ((new-vals (make-vector new-len)))
+ (vector-move-left! vals 0 new-len new-vals 0)
+ new-vals)
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))
+ (let* ((len (hash-table-size ht))
+ (keys (make-vector len))
+ (vals (make-vector len))
+ ;; In a weak hash table, some values might get gargabe
+ ;; collected while the procedure is running, so we double-check
+ ;; if we collected the expected number of keys.
+ (new-len (hash-fold (lambda (key val i)
+ (vector-set! keys i key)
+ (vector-set! vals i val)
+ (+ i 1))
+ 0 (ht-real-table ht))))
+ (if (< new-len len)
+ (let ((new-keys (make-vector new-len))
+ (new-vals (make-vector new-len)))
+ (vector-move-left! keys 0 new-len new-keys 0)
+ (vector-move-left! vals 0 new-len new-vals 0)
+ (values new-keys new-vals))
(values keys vals))))
(define (hash-table-find proc ht failure)
@@ -759,15 +702,12 @@ 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))
+ mutable capacity weakness)))
(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)))
+ (hashx-set! h a real-table key (proc val)))
(ht-real-table ht)))
- (ht-size! result size)
result))
(define (hash-table-map->list proc ht)
@@ -822,8 +762,6 @@ PROC returns true. Returns an unspecified value."
(with-hashx-values (h a real-table) ht
(hash-for-each (lambda (key val)
(when (proc key val)
- (unless (ht-weakness ht)
- (ht-size! ht (- (ht-size ht) 1)))
(hashx-remove! h a real-table key)))
real-table)))
@@ -838,15 +776,13 @@ 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))
+ (let ((new-real-table ((guile-ht-ctor weakness) capacity)))
(hash-for-each (lambda (key val)
- (hashx-set! h a new-real-table key val)
- (set! size (+ 1 size)))
+ (hashx-set! h a new-real-table key val))
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
+ ;; weakness mutable? equivalence-function orig-hash-function
+ (make-generic-hash-table new-real-table h a weakness (and mutable #t)
(hash-table-equivalence-function ht)
(hash-table-hash-function ht)))))
@@ -858,8 +794,8 @@ 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
+ ;; weakness mutable? equivalence-function orig-hash-function
+ (make-generic-hash-table new-real-table h a weakness (and mutable #t)
(hash-table-equivalence-function ht)
(hash-table-hash-function ht)))))
--
2.19.1
[-- Attachment #6: 0007-Implemented-SRFI-128.patch --]
[-- Type: text/x-patch, Size: 40659 bytes --]
From 050b7050e38dec3b8301356053582505f6677afc Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?J=C3=A9ssica=20Milar=C3=A9?= <jessymilare@gmail.com>
Date: Fri, 11 Jan 2019 19:41:20 -0200
Subject: [PATCH 07/10] Implemented SRFI-128
---
module/Makefile.am | 2 +
module/srfi/srfi-128.scm | 577 +++++++++++++++++++++++++++++++++
module/srfi/srfi-128/gnu.scm | 38 +++
test-suite/Makefile.am | 1 +
test-suite/tests/srfi-128.test | 348 ++++++++++++++++++++
5 files changed, 966 insertions(+)
create mode 100644 module/srfi/srfi-128.scm
create mode 100644 module/srfi/srfi-128/gnu.scm
create mode 100644 test-suite/tests/srfi-128.test
diff --git a/module/Makefile.am b/module/Makefile.am
index 6e739fed0..5fc3010c1 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -295,6 +295,8 @@ SOURCES = \
srfi/srfi-98.scm \
srfi/srfi-111.scm \
srfi/srfi-126.scm \
+ srfi/srfi-128/gnu.scm \
+ srfi/srfi-128.scm \
\
statprof.scm \
\
diff --git a/module/srfi/srfi-128.scm b/module/srfi/srfi-128.scm
new file mode 100644
index 000000000..bdacfb3c0
--- /dev/null
+++ b/module/srfi/srfi-128.scm
@@ -0,0 +1,577 @@
+;;; srfi-128.scm --- Comparators
+
+;; Copyright (C) 2019 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
+
+;; This file contains code from SRFI 128 reference implementation, by
+;; John Cowan
+
+;;; Copyright (C) John Cowan (2015). All Rights Reserved.
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use,
+;;; copy, modify, merge, publish, distribute, sublicense, and/or
+;;; sell copies of the Software, and to permit persons to whom the
+;;; Software is furnished to do so, subject to the following
+;;; conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
+;;; OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
+;;; OTHER DEALINGS IN THE SOFTWARE.
+\f
+
+(define-module (srfi srfi-128)
+ #:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-43)
+ ;; HASH-BOUND, HASH-SALT and WITH-HASH-SALT are defined here because
+ ;; the latter is not standard
+ #:use-module ((srfi srfi-128 gnu) #:select (hash-bound hash-salt))
+ #:use-module ((rnrs unicode) #:select (char-foldcase))
+ #:use-module (rnrs bytevectors)
+ #:use-module ((ice-9 generic-hash-tables)
+ #:select ((hash . equal-hash)
+ string-ci-hash hash-by-identity hash-by-value))
+ #:export (comparator?
+ make-comparator
+ comparator-type-test-predicate comparator-equality-predicate
+ comparator-ordering-predicate comparator-hash-function
+ comparator-ordered? comparator-hashable?
+ comparator-test-type comparator-check-type
+ comparator-hash
+ make-pair-comparator make-list-comparator make-vector-comparator
+ make-eq-comparator make-eqv-comparator make-equal-comparator
+ boolean-hash char-hash char-ci-hash number-hash
+ make-default-comparator default-hash
+ comparator-register-default!
+ =? <? >? <=? >=?
+ comparator-if<=>)
+ #:re-export (string-hash string-ci-hash symbol-hash hash-bound hash-salt))
+
+(cond-expand-provide (current-module) '(srfi-128))
+
+\f
+;; Arithmetic if
+(define-syntax comparator-if<=>
+ (syntax-rules ()
+ ((if<=> a b less equal greater)
+ (comparator-if<=> default-comparator a b less equal greater))
+ ((comparator-if<=> comparator a b less equal greater)
+ (cond
+ ((<? comparator a b) less)
+ ((=? comparator a b) equal)
+ (else greater)))))
+
+\f
+;;; Definition of comparator records with accessors and basic comparator
+
+(define-record-type comparator
+ (make-raw-comparator type-test equality ordering hash ordering? hash?)
+ comparator?
+ (type-test comparator-type-test-predicate)
+ (equality comparator-equality-predicate)
+ (ordering comparator-ordering-predicate)
+ (hash comparator-hash-function)
+ (ordering? comparator-ordered?)
+ (hash? comparator-hashable?))
+
+(define (always-true obj) #t)
+
+;; Public constructor
+(define (make-comparator type-test equality ordering hash)
+ (make-raw-comparator
+ (if (eq? type-test #t) always-true type-test)
+ (if (eq? equality #t) (lambda (x y) (eqv? (ordering x y) 0)) equality)
+ (if ordering ordering (lambda (x y) (error "ordering not supported")))
+ (if hash hash (lambda (x y) (error "hashing not supported")))
+ (if ordering #t #f)
+ (if hash #t #f)))
+
+\f
+;;; Invokers
+
+;; Invoke the test type
+(define (comparator-test-type comparator obj)
+ ((comparator-type-test-predicate comparator) obj))
+
+;; Invoke the test type and throw an error if it fails
+(define (comparator-check-type comparator obj)
+ (if (comparator-test-type comparator obj)
+ #t
+ (error "Comparator type check failed" comparator obj)))
+
+;; Invoke the hash function
+(define (comparator-hash comparator obj)
+ ((comparator-hash-function comparator) obj))
+
+\f
+;;; Comparison predicates
+
+;; Binary versions for internal use
+
+(define (binary=? comparator a b)
+ ((comparator-equality-predicate comparator) a b))
+
+(define (binary<? comparator a b)
+ ((comparator-ordering-predicate comparator) a b))
+
+(define (binary>? comparator a b)
+ (binary<? comparator b a))
+
+(define (binary<=? comparator a b)
+ (not (binary>? comparator a b)))
+
+(define (binary>=? comparator a b)
+ (not (binary<? comparator a b)))
+
+;; General versions for export
+
+(define (=? comparator a b . objs)
+ (let loop ((a a) (b b) (objs objs))
+ (and (binary=? comparator a b)
+ (if (null? objs) #t (loop b (car objs) (cdr objs))))))
+
+(define (<? comparator a b . objs)
+ (let loop ((a a) (b b) (objs objs))
+ (and (binary<? comparator a b)
+ (if (null? objs) #t (loop b (car objs) (cdr objs))))))
+
+(define (>? comparator a b . objs)
+ (let loop ((a a) (b b) (objs objs))
+ (and (binary>? comparator a b)
+ (if (null? objs) #t (loop b (car objs) (cdr objs))))))
+
+(define (<=? comparator a b . objs)
+ (let loop ((a a) (b b) (objs objs))
+ (and (binary<=? comparator a b)
+ (if (null? objs) #t (loop b (car objs) (cdr objs))))))
+
+(define (>=? comparator a b . objs)
+ (let loop ((a a) (b b) (objs objs))
+ (and (binary>=? comparator a b)
+ (if (null? objs) #t (loop b (car objs) (cdr objs))))))
+
+\f
+;;; Simple ordering and hash functions
+
+(define boolean-hash hash-by-identity)
+(define char-hash hash-by-identity)
+(define number-hash hash-by-value)
+
+(define* (char-ci-hash c #:optional (size most-positive-fixnum))
+ (hashq (char-foldcase c) size))
+
+;; Lexicographic ordering of complex numbers
+(define (complex<? a b)
+ (or (< (real-part a) (real-part b))
+ (and (= (real-part a) (real-part b))
+ (< (imag-part a) (imag-part b)))))
+
+(define (symbol<? a b)
+ ;; Valid according to spec.
+ ;; It's faster to hash than to compare strings.
+ (let ((ha (hashq a (hash-bound)))
+ (hb (hashq b (hash-bound))))
+ (or (< ha hb)
+ (and (= ha hb)
+ (not (eq? a b))
+ (string<? (symbol->string a) (symbol->string b))))))
+
+;; Stick to fixnums
+(define lower-mask (ash (hash-bound) -5)) ; (/ (hash-bound) 32)
+
+;; Hash helper
+(define (mix h1 h2)
+ (logxor (* (logand h1 lower-mask) 31) h2))
+
+
+\f
+;;; Pair comparator
+(define (make-pair-comparator car-comparator cdr-comparator)
+ (make-comparator
+ (make-pair-type-test car-comparator cdr-comparator)
+ (make-pair=? car-comparator cdr-comparator)
+ (make-pair<? car-comparator cdr-comparator)
+ (make-pair-hash car-comparator cdr-comparator)))
+
+(define (make-pair-type-test car-comparator cdr-comparator)
+ (let ((car-test (comparator-type-test-predicate car-comparator))
+ (cdr-test (comparator-type-test-predicate cdr-comparator)))
+ (if (eq? always-true car-test cdr-test)
+ pair?
+ (lambda (obj)
+ (and (pair? obj)
+ (car-test (car obj))
+ (cdr-test (cdr obj)))))))
+
+(define (make-pair=? car-comparator cdr-comparator)
+ (let ((car-equiv (comparator-equality-predicate car-comparator))
+ (cdr-equiv (comparator-equality-predicate cdr-comparator)))
+ (if (eq? equal? car-equiv cdr-equiv)
+ equal?
+ (lambda (a b)
+ (and (car-equiv (car a) (car b))
+ (cdr-equiv (cdr a) (cdr b)))))))
+
+(define (make-pair<? car-comparator cdr-comparator)
+ (let ((car-equiv (comparator-equality-predicate car-comparator))
+ (car<? (comparator-ordering-predicate car-comparator))
+ (cdr<? (comparator-ordering-predicate cdr-comparator)))
+ (lambda (a b)
+ (or (car<? (car a) (car b))
+ (and (car-equiv (car a) (car b))
+ (cdr<? (cdr a) (cdr b)))))))
+
+(define pair-hash-salt (mix (symbol-hash 'pair) (hash-salt)))
+
+(define (make-pair-hash car-comparator cdr-comparator)
+ (let ((car-hash (comparator-hash-function car-comparator))
+ (cdr-hash (comparator-hash-function cdr-comparator)))
+ (if (eq? equal-hash car-hash cdr-hash)
+ equal-hash
+ (lambda (obj)
+ (mix (mix pair-hash-salt (car-hash (car obj)))
+ (cdr-hash (cdr obj)))))))
+
+\f
+;;; List comparator
+
+(define (make-list-comparator element-comparator type-test empty? head tail)
+ (make-comparator
+ (make-list-type-test element-comparator type-test empty? head tail)
+ (make-list=? element-comparator type-test empty? head tail)
+ (make-list<? element-comparator type-test empty? head tail)
+ (make-list-hash element-comparator type-test empty? head tail)))
+
+(define (make-list-type-test element-comparator type-test empty? head tail)
+ (let ((elem-type-test (comparator-type-test-predicate element-comparator)))
+ (lambda (obj)
+ (and
+ (type-test obj)
+ (let loop ((obj obj))
+ (cond
+ ((empty? obj) #t)
+ ((not (elem-type-test (head obj))) #f)
+ (else (loop (tail obj)))))))))
+
+(define (make-list=? element-comparator type-test empty? head tail)
+ (let ((elem=? (comparator-equality-predicate element-comparator)))
+ (lambda (a b)
+ (let loop ((a a) (b b))
+ (cond
+ ((empty? a) (empty? b))
+ ((empty? b) #f)
+ ((elem=? (head a) (head b)) (loop (tail a) (tail b)))
+ (else #f))))))
+
+(define (make-list<? element-comparator type-test empty? head tail)
+ (let ((elem=? (comparator-equality-predicate element-comparator))
+ (elem<? (comparator-ordering-predicate element-comparator)))
+ (lambda (a b)
+ (let loop ((a a) (b b))
+ (cond
+ ((empty? a) (not (empty? b)))
+ ((empty? b) #f)
+ ((elem<? (head a) (head b)) #t)
+ ((elem=? (head a) (head b)) (loop (tail a) (tail b)))
+ (else #f))))))
+
+(define list-hash-salt (mix (symbol-hash 'list) (hash-salt)))
+
+(define (make-list-hash element-comparator type-test empty? head tail)
+ (let ((elem-hash (comparator-hash-function element-comparator)))
+ (lambda (obj)
+ (let loop ((obj obj)
+ (result list-hash-salt))
+ (cond
+ ((empty? obj) result)
+ (else (loop (tail obj) (mix result (elem-hash (head obj))))))))))
+
+\f
+;;; Vector comparator
+
+(define (make-vector-comparator element-comparator type-test length ref)
+ (make-comparator
+ (make-vector-type-test element-comparator type-test length ref)
+ (make-vector=? element-comparator type-test length ref)
+ (make-vector<? element-comparator type-test length ref)
+ (make-vector-hash element-comparator type-test length ref)))
+
+(define (make-vector-type-test element-comparator type-test length ref)
+ (let ((elem-type-test (comparator-type-test-predicate element-comparator)))
+ (lambda (obj)
+ (and
+ (type-test obj)
+ (let ((len (length obj)))
+ (let loop ((n 0))
+ (cond
+ ((= n len) #t)
+ ((not (elem-type-test (ref obj n))) #f)
+ (else (loop (+ n 1))))))))))
+
+(define (make-vector=? element-comparator type-test length ref)
+ (let ((elem=? (comparator-equality-predicate element-comparator)))
+ (lambda (a b)
+ (let ((len (length b)))
+ (and
+ (= (length a) len)
+ (let loop ((n 0))
+ (cond
+ ((= n len) #t)
+ ((elem=? (ref a n) (ref b n)) (loop (+ n 1)))
+ (else #f))))))))
+
+(define (make-vector<? element-comparator type-test length ref)
+ (let ((elem=? (comparator-equality-predicate element-comparator))
+ (elem<? (comparator-ordering-predicate element-comparator)))
+ (lambda (a b)
+ (let ((lena (length a))
+ (lenb (length b)))
+ (cond
+ ((< lena lenb) #t)
+ ((> lena lenb) #f)
+ (else
+ (let loop ((n 0))
+ (cond
+ ((= n lena) #f)
+ ((elem<? (ref a n) (ref b n)) #t)
+ ((elem=? (ref a n) (ref b n)) (loop (+ n 1)))
+ (else #f)))))))))
+
+(define vector-hash-salt (mix (symbol-hash 'vector) (hash-salt)))
+
+(define (make-vector-hash element-comparator type-test length ref)
+ (let ((elem-hash (comparator-hash-function element-comparator)))
+ (lambda (obj)
+ (let ((len (length obj)))
+ (let loop ((n 0) (result vector-hash-salt))
+ (cond
+ ((= n len) result)
+ (else (loop (+ n 1) (mix result (elem-hash (ref obj n)))))))))))
+
+\f
+;;; The default comparator
+
+;;; Standard comparators and their functions
+
+;; The unknown-object comparator, used as a fallback to everything else
+;; Everything compares exactly the same and hashes to 0
+(define unknown-object-comparator
+ (make-comparator
+ always-true
+ (lambda (a b) #t)
+ (lambda (a b) #f)
+ (lambda (obj) 0)))
+
+;; Next index for added comparator
+
+(define *next-comparator-index* 0)
+(define *registered-comparators* (make-vector 8 unknown-object-comparator))
+
+;; Register a new comparator for use by the default comparator.
+(define (comparator-register-default! comparator)
+ (let ((len (vector-length *registered-comparators*)))
+ (if (= *next-comparator-index* (- len 1))
+ (set! *registered-comparators*
+ (vector-copy *registered-comparators* 0 (* 2 len) unknown-object-comparator))))
+ (vector-set! *registered-comparators* *next-comparator-index* comparator)
+ (set! *next-comparator-index* (+ 1 *next-comparator-index*)))
+
+;; Return ordinal for object types: null sorts before booleans, which sort
+;; before numbers, etc. Implementations can extend this.
+;; People who call comparator-register-default! effectively do extend it.
+(define (internal-object-type obj)
+ (cond
+ ((null? obj) 0)
+ ((boolean? obj) 1)
+ ((number? obj) 2)
+ ((char? obj) 3)
+ ((string? obj) 4)
+ ((symbol? obj) 5)
+ ((bytevector? obj) 6)
+ ((vector? obj) 7)
+ ((pair? obj) 8)
+ ((unspecified? obj) 9)
+ ((eof-object? obj) 10)
+ ;; Add more here if you want
+ (else #f)))
+
+(define (external-object-type obj)
+ (registered-index obj))
+
+;; Return the index for the registered type of obj.
+(define (registered-index obj)
+ (vector-index (lambda (comparator)
+ (comparator-test-type comparator obj))
+ *registered-comparators*))
+
+(define (external-object-comparator obj)
+ (vector-any (lambda (comparator)
+ (and (comparator-test-type comparator obj)
+ comparator))
+ *registered-comparators*))
+
+;; Given an index, retrieve a registered conductor.
+(define (registered-comparator i)
+ (vector-ref *registered-comparators* i))
+
+(define (internal-dispatch-equality type a b)
+ ;; EQUAL? already returns #t for many internal types
+ (case type
+ ;; ((0) #t) ; All empty lists are equal
+ ;; ((1) (if a (and b #t) (not b)))
+ ;; ((2) (= a b))
+ ;; ((3) (char=? a b))
+ ;; ((4) (string=? a b))
+ ;; ((5) (eq? a b))
+ ;; ((6) (default-bytevector=? a b))
+ ((7) (default-vector=? a b))
+ ((8) (default-pair=? a b))
+ ;; ((9 10) #t)
+ ;; Add more here
+ (else #f)))
+
+(define (external-dispatch-equality type a b)
+ (binary=? (registered-comparator type) a b))
+
+(define (internal-dispatch-ordering type a b)
+ ;; EQUAL? already eliminates some internal types
+ (case type
+ ;; ((0) #f) ; All empty lists are equal
+ ((1) (and (not a) b)) ; #f < #t but not otherwise
+ ((2) (complex<? a b))
+ ((3) (char<? a b))
+ ((4) (string<? a b))
+ ((5) (symbol<? a b))
+ ((6) (default-bytevector<? a b))
+ ((7) (default-vector<? a b))
+ ((8) (default-pair<? a b))
+ ;; ((9 10) #f)
+ ;; Add more here
+ ))
+
+(define (external-dispatch-ordering type a b)
+ (binary<? (registered-comparator type) a b))
+
+;; EQUAL-HASH returns the same as HASH-BY-VALUE on numbers and
+;; HASH-BY-IDENTITY on booleans, chars and symbols.
+
+(define (default-hash obj)
+ (let ((type (internal-object-type obj)))
+ (if type
+ (if (or (<= type 6) (>= type 9))
+ (equal-hash obj)
+ (case type
+ ((7) (default-vector-hash obj))
+ ((8) (default-pair-hash obj))
+ ;; Add more here
+ ))
+ (let ((comparator (external-object-comparator obj)))
+ (comparator-hash comparator obj)))))
+
+(define (default-ordering a b)
+ (and (not (equal? a b)) ; should be much faster than this procedure
+ (let ((a-itype (internal-object-type a))
+ (b-itype (internal-object-type b)))
+ (cond
+ ((not b-itype)
+ (or a-itype
+ ;; Neither a nor b are of internal type:
+ ;; dispatch ordering on external type
+ (let ((a-etype (external-object-type a))
+ (b-etype (external-object-type b)))
+ (cond
+ ((< a-etype b-etype) #t)
+ ((> a-etype b-etype) #f)
+ (else (external-dispatch-ordering a-etype a b))))))
+ ((not a-itype) #f)
+ ;; Both a and b are of internal type
+ ((< a-itype b-itype) #t)
+ ((> a-itype b-itype) #f)
+ (else (internal-dispatch-ordering a-itype a b))))))
+
+(define (default-equality a b)
+ (or (equal? a b) ; should be much faster than this procedure
+ (let ((a-itype (internal-object-type a))
+ (b-itype (internal-object-type b)))
+ (and (eqv? a-itype b-itype)
+ (if a-itype
+ (internal-dispatch-equality a-itype a b)
+ (let ((a-comp (external-object-comparator a))
+ (b-comp (external-object-comparator b)))
+ (and (eq? a-comp b-comp) (binary=? a-comp a b))))))))
+
+;; Note: comparators are immutable, no reason to allocate a new one
+(define default-comparator (make-comparator always-true default-equality
+ default-ordering default-hash))
+
+(define (make-default-comparator) default-comparator)
+
+(define default-pair-comparator
+ (make-pair-comparator default-comparator default-comparator))
+
+(define default-pair=?
+ (comparator-equality-predicate default-pair-comparator))
+(define default-pair<?
+ (comparator-ordering-predicate default-pair-comparator))
+(define default-pair-hash
+ (comparator-hash-function default-pair-comparator))
+
+(define default-vector-comparator
+ (make-vector-comparator default-comparator vector?
+ vector-length vector-ref))
+
+(define default-vector=?
+ (comparator-equality-predicate default-vector-comparator))
+(define default-vector<?
+ (comparator-ordering-predicate default-vector-comparator))
+(define default-vector-hash
+ (comparator-hash-function default-vector-comparator))
+
+(define default-bytevector-comparator
+ (make-vector-comparator default-comparator bytevector?
+ bytevector-length bytevector-u8-ref))
+
+(define default-bytevector=?
+ (comparator-equality-predicate default-bytevector-comparator))
+(define default-bytevector<?
+ (comparator-ordering-predicate default-bytevector-comparator))
+(define default-bytevector-hash
+ (comparator-hash-function default-bytevector-comparator))
+
+;;; Wrapped equality predicates
+;;; These comparators don't have ordering functions.
+
+;; Note: comparators are immutable, no reason to allocate a new one
+(define eq-comparator (make-comparator #t eq? #f default-hash))
+(define (make-eq-comparator) eq-comparator)
+
+(define eqv-comparator (make-comparator #t eqv? #f default-hash))
+(define (make-eqv-comparator) eqv-comparator)
+
+(define equal-comparator (make-comparator #t equal? #f default-hash))
+(define (make-equal-comparator) equal-comparator)
+
+;; eof
diff --git a/module/srfi/srfi-128/gnu.scm b/module/srfi/srfi-128/gnu.scm
new file mode 100644
index 000000000..89fd434aa
--- /dev/null
+++ b/module/srfi/srfi-128/gnu.scm
@@ -0,0 +1,38 @@
+;;; Extensions to SRFI-128
+
+;; Copyright (C) 2019 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 (srfi srfi-128 gnu)
+ #:export (hash-bound hash-salt with-hash-salt))
+
+(define-syntax hash-bound
+ (syntax-rules ()
+ ((hash-bound) most-positive-fixnum)))
+
+(define %salt% (make-parameter (random (hash-bound)
+ (seed->random-state (current-time)))))
+
+(define-syntax hash-salt
+ (syntax-rules ()
+ ((hash-salt) (%salt%))))
+
+(define-syntax with-hash-salt
+ (syntax-rules ()
+ ((with-hash-salt new-salt hash-func obj)
+ (parameterize ((%salt% new-salt)) (hash-func obj)))))
+
+;; eof
diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am
index f0ad8bb91..a2f73b329 100644
--- a/test-suite/Makefile.am
+++ b/test-suite/Makefile.am
@@ -163,6 +163,7 @@ SCM_TESTS = tests/00-initial-env.test \
tests/srfi-105.test \
tests/srfi-111.test \
tests/srfi-126.test \
+ tests/srfi-128.test \
tests/srfi-4.test \
tests/srfi-9.test \
tests/statprof.test \
diff --git a/test-suite/tests/srfi-128.test b/test-suite/tests/srfi-128.test
new file mode 100644
index 000000000..02a538e22
--- /dev/null
+++ b/test-suite/tests/srfi-128.test
@@ -0,0 +1,348 @@
+;;;; srfi-128.test --- Test suite for SRFI 128 -*- scheme -*-
+;;;;
+;;;; Copyright (C) 2019 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.
+
+;; This file contains code from SRFI 128 reference implementation, by
+;; John Cowan
+
+;;; Copyright (C) John Cowan (2015). All Rights Reserved.
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use,
+;;; copy, modify, merge, publish, distribute, sublicense, and/or
+;;; sell copies of the Software, and to permit persons to whom the
+;;; Software is furnished to do so, subject to the following
+;;; conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
+;;; OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
+;;; OTHER DEALINGS IN THE SOFTWARE.
+
+(define-module (test-srfi-128)
+ #:use-module (test-suite lib)
+ #:use-module (srfi srfi-128)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-2)
+ #:use-module (srfi srfi-8)
+ #:use-module (rnrs bytevectors))
+
+(define (vector-cdr vec)
+ (let* ((len (vector-length vec))
+ (result (make-vector (- len 1))))
+ (let loop ((n 1))
+ (cond
+ ((= n len) result)
+ (else (vector-set! result (- n 1) (vector-ref vec n))
+ (loop (+ n 1)))))))
+
+(define default-comparator (make-default-comparator))
+
+(define real-comparator (make-comparator real? = < number-hash))
+
+(define degenerate-comparator (make-comparator (lambda (x) #t) equal? #f #f))
+
+(define boolean-comparator
+ (make-comparator boolean? eq? (lambda (x y) (and (not x) y)) boolean-hash))
+
+(define bool-pair-comparator
+ (make-pair-comparator boolean-comparator boolean-comparator))
+
+(define num-list-comparator
+ (make-list-comparator real-comparator list? null? car cdr))
+
+(define num-vector-comparator
+ (make-vector-comparator real-comparator vector? vector-length vector-ref))
+
+(define vector-qua-list-comparator
+ (make-list-comparator
+ real-comparator
+ vector?
+ (lambda (vec) (= 0 (vector-length vec)))
+ (lambda (vec) (vector-ref vec 0))
+ vector-cdr))
+
+(define list-qua-vector-comparator
+ (make-vector-comparator default-comparator list? length list-ref))
+
+(define eq-comparator (make-eq-comparator))
+
+(define eqv-comparator (make-eqv-comparator))
+
+(define equal-comparator (make-equal-comparator))
+
+(define symbol-comparator
+ (make-comparator
+ symbol?
+ eq?
+ (lambda (a b) (string<? (symbol->string a) (symbol->string b)))
+ symbol-hash))
+
+
+(with-test-prefix "SRFI-128"
+
+ (pass-if-equal '#(2 3 4) (vector-cdr '#(1 2 3 4)))
+ (pass-if-equal '#() (vector-cdr '#(1)))
+
+ (with-test-prefix "comparators/predicates"
+ (pass-if (comparator? real-comparator))
+ (pass-if (not (comparator? =)))
+ (pass-if (comparator-ordered? real-comparator))
+ (pass-if (comparator-hashable? real-comparator))
+ (pass-if (not (comparator-ordered? degenerate-comparator)))
+ (pass-if (not (comparator-hashable? degenerate-comparator)))
+ ) ; end comparators/predicates
+
+ (with-test-prefix "comparators/constructors"
+ (pass-if (=? boolean-comparator #t #t))
+ (pass-if (not (=? boolean-comparator #t #f)))
+ (pass-if (<? boolean-comparator #f #t))
+ (pass-if (not (<? boolean-comparator #t #t)))
+ (pass-if (not (<? boolean-comparator #t #f)))
+
+ (pass-if (comparator-test-type bool-pair-comparator '(#t . #f)))
+ (pass-if (not (comparator-test-type bool-pair-comparator 32)))
+ (pass-if (not (comparator-test-type bool-pair-comparator '(32 . #f))))
+ (pass-if (not (comparator-test-type bool-pair-comparator '(#t . 32))))
+ (pass-if (not (comparator-test-type bool-pair-comparator '(32 . 34))))
+ (pass-if (=? bool-pair-comparator '(#t . #t) '(#t . #t)))
+ (pass-if (not (=? bool-pair-comparator '(#t . #t) '(#f . #t))))
+ (pass-if (not (=? bool-pair-comparator '(#t . #t) '(#t . #f))))
+ (pass-if (<? bool-pair-comparator '(#f . #t) '(#t . #t)))
+ (pass-if (<? bool-pair-comparator '(#t . #f) '(#t . #t)))
+ (pass-if (not (<? bool-pair-comparator '(#t . #t) '(#t . #t))))
+ (pass-if (not (<? bool-pair-comparator '(#t . #t) '(#f . #t))))
+ (pass-if (not (<? bool-pair-comparator '(#f . #t) '(#f . #f))))
+
+ (pass-if (comparator-test-type num-vector-comparator '#(1 2 3)))
+ (pass-if (comparator-test-type num-vector-comparator '#()))
+ (pass-if (not (comparator-test-type num-vector-comparator 1)))
+ (pass-if (not (comparator-test-type num-vector-comparator '#(a 2 3))))
+ (pass-if (not (comparator-test-type num-vector-comparator '#(1 b 3))))
+ (pass-if (not (comparator-test-type num-vector-comparator '#(1 2 c))))
+ (pass-if (=? num-vector-comparator '#(1 2 3) '#(1 2 3)))
+ (pass-if (not (=? num-vector-comparator '#(1 2 3) '#(4 5 6))))
+ (pass-if (not (=? num-vector-comparator '#(1 2 3) '#(1 5 6))))
+ (pass-if (not (=? num-vector-comparator '#(1 2 3) '#(1 2 6))))
+ (pass-if (<? num-vector-comparator '#(1 2) '#(1 2 3)))
+ (pass-if (<? num-vector-comparator '#(1 2 3) '#(2 3 4)))
+ (pass-if (<? num-vector-comparator '#(1 2 3) '#(1 3 4)))
+ (pass-if (<? num-vector-comparator '#(1 2 3) '#(1 2 4)))
+ (pass-if (<? num-vector-comparator '#(3 4) '#(1 2 3)))
+ (pass-if (not (<? num-vector-comparator '#(1 2 3) '#(1 2 3))))
+ (pass-if (not (<? num-vector-comparator '#(1 2 3) '#(1 2))))
+ (pass-if (not (<? num-vector-comparator '#(1 2 3) '#(0 2 3))))
+ (pass-if (not (<? num-vector-comparator '#(1 2 3) '#(1 1 3))))
+
+ (pass-if (not (<? vector-qua-list-comparator '#(3 4) '#(1 2 3))))
+ (pass-if (<? list-qua-vector-comparator '(3 4) '(1 2 3)))
+
+ (let ((bool-pair (cons #t #f))
+ (bool-pair-2 (cons #t #f))
+ (reverse-bool-pair (cons #f #t)))
+ (pass-if (=? eq-comparator #t #t))
+ (pass-if (not (=? eq-comparator #f #t)))
+ (pass-if (=? eqv-comparator bool-pair bool-pair))
+ (pass-if (not (=? eqv-comparator bool-pair bool-pair-2)))
+ (pass-if (=? equal-comparator bool-pair bool-pair-2))
+ (pass-if (not (=? equal-comparator bool-pair reverse-bool-pair))))
+ ) ; end comparators/constructors
+
+ (with-test-prefix "comparators/hash"
+ (pass-if (exact-integer? (boolean-hash #f)))
+ (pass-if (not (negative? (boolean-hash #t))))
+ (pass-if (exact-integer? (char-hash #\a)))
+ (pass-if (not (negative? (char-hash #\b))))
+ (pass-if (exact-integer? (char-ci-hash #\a)))
+ (pass-if (not (negative? (char-ci-hash #\b))))
+ (pass-if (= (char-ci-hash #\a) (char-ci-hash #\A)))
+ (pass-if (exact-integer? (string-hash "f")))
+ (pass-if (not (negative? (string-hash "g"))))
+ (pass-if (exact-integer? (string-ci-hash "f")))
+ (pass-if (not (negative? (string-ci-hash "g"))))
+ (pass-if (= (string-ci-hash "f") (string-ci-hash "F")))
+ (pass-if (exact-integer? (symbol-hash 'f)))
+ (pass-if (not (negative? (symbol-hash 't))))
+ (pass-if (exact-integer? (number-hash 3)))
+ (pass-if (not (negative? (number-hash 3))))
+ (pass-if (exact-integer? (number-hash -3)))
+ (pass-if (not (negative? (number-hash -3))))
+ (pass-if (exact-integer? (number-hash 3.0)))
+ (pass-if (not (negative? (number-hash 3.0))))
+ (pass-if (exact-integer? (number-hash 3.47)))
+ (pass-if (not (negative? (number-hash 3.47))))
+ (pass-if (exact-integer? (default-hash '())))
+ (pass-if (not (negative? (default-hash '()))))
+ (pass-if (exact-integer? (default-hash '(a "b" #\c #(dee) 2.718))))
+ (pass-if (not (negative? (default-hash '(a "b" #\c #(dee) 2.718)))))
+ (pass-if (exact-integer? (default-hash '#u8())))
+ (pass-if (not (negative? (default-hash '#u8()))))
+ (pass-if (exact-integer? (default-hash '#u8(8 6 3))))
+ (pass-if (not (negative? (default-hash '#u8(8 6 3)))))
+ (pass-if (exact-integer? (default-hash '#())))
+ (pass-if (not (negative? (default-hash '#()))))
+ (pass-if (exact-integer? (default-hash '#(a "b" #\c #(dee) 2.718))))
+ (pass-if (not (negative? (default-hash '#(a "b" #\c #(dee) 2.718)))))
+
+ ) ; end comparators/hash
+
+ (with-test-prefix "comparators/default"
+ (pass-if (<? default-comparator '() '(a)))
+ (pass-if (not (=? default-comparator '() '(a))))
+ (pass-if (=? default-comparator #t #t))
+ (pass-if (not (=? default-comparator #t #f)))
+ (pass-if (<? default-comparator #f #t))
+ (pass-if (not (<? default-comparator #t #t)))
+ (pass-if (=? default-comparator #\a #\a))
+ (pass-if (<? default-comparator #\a #\b))
+
+ (pass-if (comparator-test-type default-comparator '()))
+ (pass-if (comparator-test-type default-comparator #t))
+ (pass-if (comparator-test-type default-comparator #\t))
+ (pass-if (comparator-test-type default-comparator '(a)))
+ (pass-if (comparator-test-type default-comparator 'a))
+ (pass-if (comparator-test-type default-comparator (make-bytevector 10)))
+ (pass-if (comparator-test-type default-comparator 10))
+ (pass-if (comparator-test-type default-comparator 10.0))
+ (pass-if (comparator-test-type default-comparator "10.0"))
+ (pass-if (comparator-test-type default-comparator '#(10)))
+
+ (pass-if (=? default-comparator '(#t . #t) '(#t . #t)))
+ (pass-if (not (=? default-comparator '(#t . #t) '(#f . #t))))
+ (pass-if (not (=? default-comparator '(#t . #t) '(#t . #f))))
+ (pass-if (<? default-comparator '(#f . #t) '(#t . #t)))
+ (pass-if (<? default-comparator '(#t . #f) '(#t . #t)))
+ (pass-if (not (<? default-comparator '(#t . #t) '(#t . #t))))
+ (pass-if (not (<? default-comparator '(#t . #t) '(#f . #t))))
+ (pass-if (not (<? default-comparator '#(#f #t) '#(#f #f))))
+
+ (pass-if (=? default-comparator '#(#t #t) '#(#t #t)))
+ (pass-if (not (=? default-comparator '#(#t #t) '#(#f #t))))
+ (pass-if (not (=? default-comparator '#(#t #t) '#(#t #f))))
+ (pass-if (<? default-comparator '#(#f #t) '#(#t #t)))
+ (pass-if (<? default-comparator '#(#t #f) '#(#t #t)))
+ (pass-if (not (<? default-comparator '#(#t #t) '#(#t #t))))
+ (pass-if (not (<? default-comparator '#(#t #t) '#(#f #t))))
+ (pass-if (not (<? default-comparator '#(#f #t) '#(#f #f))))
+
+ (pass-if (= (comparator-hash default-comparator #t) (boolean-hash #t)))
+ (pass-if (= (comparator-hash default-comparator #\t) (char-hash #\t)))
+ (pass-if (= (comparator-hash default-comparator "t") (string-hash "t")))
+ (pass-if (= (comparator-hash default-comparator 't) (symbol-hash 't)))
+ (pass-if (= (comparator-hash default-comparator 10) (number-hash 10)))
+ (pass-if (= (comparator-hash default-comparator 10.0) (number-hash 10.0)))
+
+ (comparator-register-default!
+ (make-comparator procedure? (lambda (a b) #t) (lambda (a b) #f) (lambda (obj) 200)))
+ (pass-if (=? default-comparator (lambda () #t) (lambda () #f)))
+ (pass-if (not (<? default-comparator (lambda () #t) (lambda () #f))))
+ (pass-if-equal 200 (comparator-hash default-comparator (lambda () #t)))
+
+ ) ; end comparators/default
+
+ ;; SRFI 128 does not actually require a comparator's four procedures
+ ;; to be eq? to the procedures originally passed to make-comparator.
+ ;; For interoperability/interchangeability between the comparators
+ ;; of SRFI 114 and SRFI 128, some of the procedures passed to
+ ;; make-comparator may need to be wrapped inside another lambda
+ ;; expression before they're returned by the corresponding accessor.
+ ;;
+ ;; So this next group of tests is incorrect, hence commented out
+ ;; and replaced by a slightly less naive group of tests.
+
+ #;
+ (with-test-prefix "comparators/accessors"
+ (define ttp (lambda (x) #t))
+ (define eqp (lambda (x y) #t))
+ (define orp (lambda (x y) #t))
+ (define hf (lambda (x) 0))
+ (define comp (make-comparator ttp eqp orp hf))
+ (pass-if-equal ttp (comparator-type-test-predicate comp))
+ (pass-if-equal eqp (comparator-equality-predicate comp))
+ (pass-if-equal orp (comparator-ordering-predicate comp))
+ (pass-if-equal hf (comparator-hash-function comp))
+ ) ; end comparators/accessors
+
+ (with-test-prefix "comparators/accessors"
+ (let* ((x1 0)
+ (x2 0)
+ (x3 0)
+ (x4 0)
+ (ttp (lambda (x) (set! x1 111) #t))
+ (eqp (lambda (x y) (set! x2 222) #t))
+ (orp (lambda (x y) (set! x3 333) #t))
+ (hf (lambda (x) (set! x4 444) 0))
+ (comp (make-comparator ttp eqp orp hf)))
+ (pass-if-equal #t (and ((comparator-type-test-predicate comp) x1) (= x1 111)))
+ (pass-if-equal #t (and ((comparator-equality-predicate comp) x1 x2) (= x2 222)))
+ (pass-if-equal #t (and ((comparator-ordering-predicate comp) x1 x3) (= x3 333)))
+ (pass-if-equal #t (and (zero? ((comparator-hash-function comp) x1)) (= x4 444))))
+ ) ; end comparators/accessors
+
+ (with-test-prefix "comparators/invokers"
+ (pass-if (comparator-test-type real-comparator 3))
+ (pass-if (comparator-test-type real-comparator 3.0))
+ (pass-if (not (comparator-test-type real-comparator "3.0")))
+ (pass-if (comparator-check-type boolean-comparator #t))
+ (pass-if-exception "check-type"
+ '(misc-error . "^Comparator type check failed")
+ (comparator-check-type boolean-comparator 't))
+ ) ; end comparators/invokers
+
+ (with-test-prefix "comparators/comparison"
+ (pass-if (=? real-comparator 2 2.0 2))
+ (pass-if (<? real-comparator 2 3.0 4))
+ (pass-if (>? real-comparator 4.0 3.0 2))
+ (pass-if (<=? real-comparator 2.0 2 3.0))
+ (pass-if (>=? real-comparator 3 3.0 2))
+ (pass-if (not (=? real-comparator 1 2 3)))
+ (pass-if (not (<? real-comparator 3 1 2)))
+ (pass-if (not (>? real-comparator 1 2 3)))
+ (pass-if (not (<=? real-comparator 4 3 3)))
+ (pass-if (not (>=? real-comparator 3 4 4.0)))
+
+ ) ; end comparators/comparison
+
+ (with-test-prefix "comparators/syntax"
+ (pass-if-equal 'less (comparator-if<=> real-comparator 1 2 'less 'equal 'greater))
+ (pass-if-equal 'equal (comparator-if<=> real-comparator 1 1 'less 'equal 'greater))
+ (pass-if-equal 'greater (comparator-if<=> real-comparator 2 1 'less 'equal 'greater))
+ (pass-if-equal 'less (comparator-if<=> "1" "2" 'less 'equal 'greater))
+ (pass-if-equal 'equal (comparator-if<=> "1" "1" 'less 'equal 'greater))
+ (pass-if-equal 'greater (comparator-if<=> "2" "1" 'less 'equal 'greater))
+
+ ) ; end comparators/syntax
+
+ (with-test-prefix "comparators/bound-salt"
+ (pass-if (exact-integer? (hash-bound)))
+ (pass-if (exact-integer? (hash-salt)))
+ (pass-if (< (hash-salt) (hash-bound)))
+ #; (pass-if-equal (hash-salt) (fake-salt-hash #t)) ; no such thing as fake-salt-hash
+ ) ; end comparators/bound-salt
+ )
--
2.19.1
^ permalink raw reply related [flat|nested] 5+ messages in thread
end of thread, other threads:[~2019-01-13 22:53 UTC | newest]
Thread overview: 5+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
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 ` bug#33827: Patches Jéssica Milaré
2019-01-13 22:53 ` Jéssica Milaré
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).