From: "Jéssica Milaré" <jessymilare@gmail.com>
To: 33827@debbugs.gnu.org
Subject: bug#33827: Patches
Date: Sun, 13 Jan 2019 20:53:04 -0200 [thread overview]
Message-ID: <CAGBcF1a70RQVCgRZA8cYm7mdREz0yT0NsrHn_6e9rnuK3QaZdA@mail.gmail.com> (raw)
In-Reply-To: <CAGBcF1aZrZhBjEk=tvsJHLJnMDc1ERt-ZaCiwOzqMksnfZsP_Q@mail.gmail.com>
[-- 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
prev parent reply other threads:[~2019-01-13 22:53 UTC|newest]
Thread overview: 5+ messages / expand[flat|nested] mbox.gz Atom feed top
2018-12-21 11:13 bug#33827: SRFI 69 weak hash-tables is broken Jéssica Milaré
2018-12-22 17:44 ` bug#33827: Attempt to fix Jéssica Milaré
2018-12-23 17:09 ` bug#33827: Patch Jéssica Milaré
2019-01-09 0:21 ` bug#33827: Patches Jéssica Milaré
2019-01-13 22:53 ` Jéssica Milaré [this message]
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
List information: https://www.gnu.org/software/guile/
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=CAGBcF1a70RQVCgRZA8cYm7mdREz0yT0NsrHn_6e9rnuK3QaZdA@mail.gmail.com \
--to=jessymilare@gmail.com \
--cc=33827@debbugs.gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).