From 18ce102c270bab3cf5240e7ac93129e107c335de Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9ssica=20Milar=C3=A9?= 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. + + +(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)) + + +;;; 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)) + + +;;; 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)))) + + +;;;; Accessing table items + +(define hash-table-ref gen:hash-table-ref) +(define hash-table-ref/default gen:hash-table-ref/default) + + +;;; 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)) + + +;;; 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)) + + +;; 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) + + +;;; 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))) + + + +;;; 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)) + + +;;; 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=? stringhash-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