From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.io!.POSTED.blaine.gmane.org!not-for-mail From: Maxim Cournoyer Newsgroups: gmane.lisp.guile.devel Subject: [PATCH v9 12/18] module: Add SRFI 125. Date: Tue, 12 Dec 2023 23:37:51 -0500 Message-ID: <20231213044217.14093-13-maxim.cournoyer@gmail.com> References: <20231213044217.14093-1-maxim.cournoyer@gmail.com> Mime-Version: 1.0 Content-Type: text/plain; charset=utf-8 Content-Transfer-Encoding: 8bit Injection-Info: ciao.gmane.io; posting-host="blaine.gmane.org:116.202.254.214"; logging-data="25221"; mail-complaints-to="usenet@ciao.gmane.io" Cc: Maxim Cournoyer To: guile-devel@gnu.org Original-X-From: guile-devel-bounces+guile-devel=m.gmane-mx.org@gnu.org Wed Dec 13 05:43:41 2023 Return-path: Envelope-to: guile-devel@m.gmane-mx.org Original-Received: from lists.gnu.org ([209.51.188.17]) by ciao.gmane.io with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.92) (envelope-from ) id 1rDH5v-0006Kh-Bd for guile-devel@m.gmane-mx.org; Wed, 13 Dec 2023 05:43:39 +0100 Original-Received: from localhost ([::1] helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1rDH5A-0004P1-7p; Tue, 12 Dec 2023 23:42:52 -0500 Original-Received: from eggs.gnu.org ([2001:470:142:3::10]) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1rDH58-0004MV-H6 for guile-devel@gnu.org; Tue, 12 Dec 2023 23:42:50 -0500 Original-Received: from mail-qt1-x829.google.com ([2607:f8b0:4864:20::829]) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1rDH52-00074b-Ux for guile-devel@gnu.org; Tue, 12 Dec 2023 23:42:50 -0500 Original-Received: by mail-qt1-x829.google.com with SMTP id d75a77b69052e-4259a275fa9so43587691cf.2 for ; Tue, 12 Dec 2023 20:42:44 -0800 (PST) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gmail.com; s=20230601; t=1702442564; x=1703047364; darn=gnu.org; h=content-transfer-encoding:mime-version:references:in-reply-to :message-id:date:subject:cc:to:from:from:to:cc:subject:date :message-id:reply-to; bh=dtX4CP1U3GUXTqpOCJrqXBUnFpie/Ff9/MoPBL5aCZ0=; b=lzGZOpk/whTDqoc1DWfyR27rLwnZ/TBAo+0zmbUuSgKyDFRfZCLzLas25O3wGewifg SHZQToJKf7tuEY1DB3OWWy6OI4IOCxmTPHYlGomYGMG/DCZMfWd+T2dNUsjXg09CFOjc d3CWUS21n5ndgH38r3Gs6DjVvkYC+8tx3VHu0qEYLo/En5rxSlbPGShvH2o4I+LfGgGF D3OTKgr+O8niY8IZiNqLEkaVNLexoFMMq+mYHqOor3ExpPRwVgELLeZr6Z7w6zk8V9sA TT1R/4WO9aLKfarihpDPmDlLVQOzj4PdTGjAFy+HnYizL4eAQpL0DKd+hp60kVfDJ1iU uL1w== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20230601; t=1702442564; x=1703047364; h=content-transfer-encoding:mime-version:references:in-reply-to :message-id:date:subject:cc:to:from:x-gm-message-state:from:to:cc :subject:date:message-id:reply-to; bh=dtX4CP1U3GUXTqpOCJrqXBUnFpie/Ff9/MoPBL5aCZ0=; b=aCkwLgraqQynjBLZzODzabWvLs1HFpS/5B4NhlrNHTe7OSII++8Gmn5xWljxKJlnOh Zs0xaQ+5A7pqRSCCRWidUWPMuPflgFI7sSQzV9NbbPe1/0yeW4fPG1EX+x8A14qO49ZP CPoJ9nMLrRgVGzjdlfC74Ww4IJwh3YkScXU1DDrMjAxm9InxLH3AQRLwVWUWwcg5h4wR PPchgZfncp48F00pTJzod7/kLIunddBXGWp/i+rTme7wNLRatXzX/KJRouOuSOeCu9Yc to72w5isQJi5Q284butJCowveq2kjMRuxrXzZcgj373d+5TWBN+yep8Bsq/5pD3KrpcV 9m/g== X-Gm-Message-State: AOJu0YwlSnPIqZiCb+xF4rszE9e9Wv1x3KsjSp0zKD/JAwDccPZUCAvd XiT0X5QxJsF0wppI7p2l+QUqL9G29ZVSgg== X-Google-Smtp-Source: AGHT+IGt5adxyXjqB3nSm+1uEH91iv2YDlFfC6CfX9wJ62XrQED6dU7WJMubkGn8j0RU3RjNbiQSuQ== X-Received: by 2002:a05:622a:4ce:b0:425:4043:41a0 with SMTP id q14-20020a05622a04ce00b00425404341a0mr8344571qtx.76.1702442561407; Tue, 12 Dec 2023 20:42:41 -0800 (PST) Original-Received: from localhost.localdomain (dsl-157-186.b2b2c.ca. [66.158.157.186]) by smtp.gmail.com with ESMTPSA id s7-20020ac87587000000b004181138e0c0sm4621719qtq.31.2023.12.12.20.42.40 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Tue, 12 Dec 2023 20:42:40 -0800 (PST) X-Mailer: git-send-email 2.41.0 In-Reply-To: <20231213044217.14093-1-maxim.cournoyer@gmail.com> Received-SPF: pass client-ip=2607:f8b0:4864:20::829; envelope-from=maxim.cournoyer@gmail.com; helo=mail-qt1-x829.google.com X-Spam_score_int: -20 X-Spam_score: -2.1 X-Spam_bar: -- X-Spam_report: (-2.1 / 5.0 requ) BAYES_00=-1.9, DKIM_SIGNED=0.1, DKIM_VALID=-0.1, DKIM_VALID_AU=-0.1, DKIM_VALID_EF=-0.1, FREEMAIL_FROM=0.001, RCVD_IN_DNSWL_NONE=-0.0001, SPF_HELO_NONE=0.001, SPF_PASS=-0.001, T_SCC_BODY_TEXT_LINE=-0.01 autolearn=ham autolearn_force=no X-Spam_action: no action X-BeenThere: guile-devel@gnu.org X-Mailman-Version: 2.1.29 Precedence: list List-Id: "Developers list for Guile, the GNU extensibility library" List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guile-devel-bounces+guile-devel=m.gmane-mx.org@gnu.org Original-Sender: guile-devel-bounces+guile-devel=m.gmane-mx.org@gnu.org Xref: news.gmane.io gmane.lisp.guile.devel:22235 Archived-At: * module/srfi/srfi-125.scm * module/srfi/srfi-125/hash-table.scm * test-suite/tests/srfi-125-test.scm * test-suite/tests/srfi-125.test: New files. * am/bootstrap.am (SOURCES): Register srfi-125.scm. (NOCOMP_SOURCES): Register hash-table.scm. * test-suite/Makefile.am (SCM_TESTS): Register srfi-128.test. (EXTRA_DIST): Register srfi-128-test.scm. * doc/ref/srfi-modules.texi (SRFI-125): Document it. * NEWS: Update news. --- (no changes since v7) Changes in v7: - Register prerequisites for srfi/srfi-125.go in am/bootstrap.am Changes in v5: - Update NEWS Changes in v4: - Mention Expat license of SRFI 125 in guile.tex copying section - Rename srfi-125.scm to srfi-125.sld and use upstream copy - Streamline import of (srfi srfi-125) - Use R7RS 'import' for srfi-125-test.scm Changes in v3: - Add menu entries. - Rename SRFI-125 to SRFI 125 in text - Rename included file to upstream name (125.body.scm) - Add copyright/license header 125.body.scm LICENSES/LicenseRef-Clinger.txt | 10 + NEWS | 1 + am/bootstrap.am | 3 + doc/ref/guile.texi | 2 +- doc/ref/srfi-modules.texi | 603 +++++++++++++++++++ module/srfi/srfi-125.sld | 87 +++ module/srfi/srfi-125/125.body.scm | 590 +++++++++++++++++++ test-suite/Makefile.am | 2 + test-suite/tests/srfi-125-test.scm | 891 +++++++++++++++++++++++++++++ test-suite/tests/srfi-125.test | 33 ++ 10 files changed, 2221 insertions(+), 1 deletion(-) create mode 100644 LICENSES/LicenseRef-Clinger.txt create mode 100644 module/srfi/srfi-125.sld create mode 100644 module/srfi/srfi-125/125.body.scm create mode 100644 test-suite/tests/srfi-125-test.scm create mode 100644 test-suite/tests/srfi-125.test diff --git a/LICENSES/LicenseRef-Clinger.txt b/LICENSES/LicenseRef-Clinger.txt new file mode 100644 index 000000000..758728f35 --- /dev/null +++ b/LICENSES/LicenseRef-Clinger.txt @@ -0,0 +1,10 @@ +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. diff --git a/NEWS b/NEWS index 614a2bc7f..b7099673d 100644 --- a/NEWS +++ b/NEWS @@ -25,6 +25,7 @@ the compiler reports it as "possibly unused". ** Add (srfi 128), a comparators library ** Add (scheme comparator) ** Add (scheme sort) +** Add (srfi 125), a mutators library * Bug fixes diff --git a/am/bootstrap.am b/am/bootstrap.am index 3dd8ec65b..13e0b711d 100644 --- a/am/bootstrap.am +++ b/am/bootstrap.am @@ -66,6 +66,7 @@ ice-9/psyntax-pp.go: ice-9/psyntax.scm ice-9/psyntax-pp.scm srfi/srfi-126.go: srfi/srfi-1.go srfi/srfi-27.go srfi/srfi-128.go: srfi/srfi-69.go srfi/srfi-126.go scheme/comparator.go: srfi/srfi-128.go +srfi/srfi-125.go: srfi/srfi-126.go srfi/srfi-128.go # All sources. We can compile these in any order; the order below is # designed to hopefully result in the lowest total compile time. @@ -356,6 +357,7 @@ SOURCES = \ srfi/srfi-88.scm \ srfi/srfi-98.scm \ srfi/srfi-111.scm \ + srfi/srfi-125.sld \ srfi/srfi-126.sld \ srfi/srfi-128.sld \ srfi/srfi-171.scm \ @@ -449,6 +451,7 @@ NOCOMP_SOURCES = \ srfi/srfi-42/ec.scm \ srfi/srfi-64/testing.scm \ srfi/srfi-67/compare.scm \ + srfi/srfi-125/125.body.scm \ srfi/srfi-128/128.body1.scm \ srfi/srfi-128/128.body2.scm \ system/base/lalr.upstream.scm \ diff --git a/doc/ref/guile.texi b/doc/ref/guile.texi index f71d9a22c..e10916948 100644 --- a/doc/ref/guile.texi +++ b/doc/ref/guile.texi @@ -24,7 +24,7 @@ Invariant Sections, no Front-Cover Texts, and no Back-Cover Texts. A copy of the license is included in the section entitled ``GNU Free Documentation License.'' -Additionally, the documentation of the 126 and 128 SRFI modules is +Additionally, the documentation of the 125, 126, and 128 SRFI modules is adapted from their specification text, which is made available under the following Expat license: diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi index 40ca7a2e7..3c276dfb0 100644 --- a/doc/ref/srfi-modules.texi +++ b/doc/ref/srfi-modules.texi @@ -66,6 +66,7 @@ get the relevant SRFI documents from the SRFI home page * SRFI-98:: Accessing environment variables. * SRFI-105:: Curly-infix expressions. * SRFI-111:: Boxes. +* SRFI 125:: Mutators. * SRFI 126:: R6RS-based hash tables. * SRFI 128:: Comparators. * SRFI-171:: Transducers. @@ -5666,6 +5667,608 @@ Return the current contents of @var{box}. Set the contents of @var{box} to @var{value}. @end deffn +@node SRFI 125 +@subsection SRFI 125 Intermediate hash tables +@cindex SRFI 125 +@cindex hash tables + +This SRFI defines an interface to hash tables, which are widely +recognized as a fundamental data structure for a wide variety of +applications. A hash table is a data structure that: + +@itemize +@item +Is disjoint from all other types. + +@item +Provides a mapping from objects known as keys to corresponding objects +known as values. +@itemize +@item +Keys may be any Scheme objects in some kinds of hash tables, but are +restricted in other kinds. +@item +Values may be any Scheme objects. +@end itemize + +@item +Has no intrinsic order for the key-value associations it contains. + +@item +Provides an equality predicate which defines when a proposed key is the +same as an existing key. No table may contain more than one value for a +given key. + +@item +Provides a hash function which maps a candidate key into a non-negative +exact integer. + +@item +Supports mutation as the primary means of setting the contents of a +table. + +@item +Provides key lookup and destructive update in (expected) amortized +constant time, provided a satisfactory hash function is available. + +@item +Does not guarantee that whole-table operations work in the presence of +concurrent mutation of the whole hash table (values may be safely +mutated). +@end itemize + +@menu +* SRFI 125 Rationale:: +* SRFI 125 Constructors:: +* SRFI 125 Predicates:: +* SRFI 125 Accessors:: +* SRFI 125 Mutators:: +* SRFI 125 The whole hash table:: +* SRFI 125 Mapping and folding:: +* SRFI 125 Copying and conversion:: +* SRFI 125 Hash tables as sets:: +* SRFI 125 Hash functions and reflectivity:: +@end menu + +@node SRFI 125 Rationale +@subsubsection SRFI 125 Rationale + +Hash tables themselves don't really need defending: almost all +dynamically typed languages, from awk to JavaScript to Lua to Perl to +Python to Common Lisp, and including many Scheme implementations, +provide them in some form as a fundamental data structure. Therefore, +what needs to be defended is not the data structure but the procedures. +This SRFI is at an intermediate level. It supports a great many +convenience procedures on top of the basic hash table interfaces +provided by SRFI 69 and R6RS. Nothing in it adds power to what those +interfaces provide, but it does add convenience in the form of +pre-debugged routines to do various common things, and even some things +not so commonly done but useful. + +There is no mandated support for thread safety, immutability, or +weakness, though there are portable hooks for specifying these features. + +While the specification of this SRFI accepts separate equality +predicates and hash functions for backward compatibility, it strongly +encourages the use of SRFI 128 comparators, which package a type test, +an equality predicate, and a hash function into a single bundle. + +@subheading SRFI 69 compatibility + +This SRFI is downward compatible with SRFI 69. Some procedures have +been given new preferred names for compatibility with other SRFIs, but +in all cases the SRFI 69 names have been retained as deprecated +synonyms; in Guile, these deprecated procedures have their name prefixed +with @code{deprecated:}. + +There is one absolute incompatibility with SRFI 69: the reflective +procedure @code{hash-table-hash-function} may return @code{#f}, which is +not permitted by SRFI 69. + +@subheading R6RS compatibility + +The relatively few hash table procedures in R6RS are all available in +this SRFI under somewhat different names. The only substantive +difference is that R6RS @code{hashtable-values} and +@code{hashtable-entries} return vectors, whereas in this SRFI +@code{hash-table-value} and @code{hash-table-entries} return lists. +This SRFI adopts SRFI 69's term hash-table rather than R6RS's hashtable, +because of the universal use of ``hash table'' rather than ``hashtable'' +in other computer languages and in technical prose generally. Besides, +the English word hashtable obviously means something that can be@dots{} +hashted. + +In addition, the @code{hashtable-ref} and @code{hashtable-update!} of +R6RS correspond to the @code{hash-table-ref/default} and +@code{hash-table-update!/default} of both SRFI 69 and this SRFI. + +@subheading Common Lisp compatibility + +As usual, the Common Lisp names are completely different from the Scheme +names. Common Lisp provides the following capabilities that are +@emph{not} in this SRFI: + +@itemize +@item +The constructor allows specifying the rehash size and rehash threshold +of the new hash table. There are also accessors and mutators for these +and for the current capacity (as opposed to size). + +@item +There are hash tables based on @code{equalp} (which does not exist in +Scheme). + +@item +@code{with-hash-table-iterator} is a hash table external iterator +implemented as a local macro. + +@item +@code{sxhash} is an implementation-specific hash function for the equal +predicate. It has the property that objects in different instantiations +of the same Lisp implementation that are similar, a concept analogous to +e@code{qual} but defined across all instantiations, always return the +same value from @code{sxhash}; for example, the symbol @code{xyz} will +have the same @code{sxhash} result in all instantiations. +@end itemize + +@subheading Sources + +The procedures in this SRFI are drawn primarily from SRFI 69 and +R6RS. In addition, the following sources are acknowledged: + +@itemize +@item +The @code{hash-table-mutable?} procedure and the second argument of +@code{hash-table-copy} (which allows the creation of immutable hash +tables) are from R6RS, renamed in the style of this SRFI. + +@item +The @code{hash-table-intern!} procedure is from +@url{https://docs.racket-lang.org/reference/hashtables.html, Racket}, +renamed in the style of this SRFI. + +@item +The @code{hash-table-find} procedure is a modified version of +@code{table-search} in Gambit. + +@item +The procedures @code{hash-table-unfold} and @code{hash-table-count} were +suggested by SRFI-1. + +@item +The procedures @code{hash-table=?} and @code{hash-table-map} were +suggested by Haskell's @code{Data.Map.Strict} module. + +@item +The procedure @code{hash-table-map->list} is from Guile. +@end itemize + +The procedures @code{hash-table-empty?,} @code{hash-table-empty-copy, +hash-table-pop!,} @code{hash-table-map!,} +@code{hash-table-intersection!, hash-table-difference!,} and +@code{hash-table-xor!} were added for convenience and completeness. + +The native hash tables of MIT, SISC, Bigloo, Scheme48, SLIB, RScheme, +Scheme 7, Scheme 9, Rep, and FemtoLisp were also investigated, but no +additional procedures were incorporated. + +@subheading Pronunciation + +The slash in the names of some procedures can be pronounced ``with''. + +@node SRFI 125 Constructors +@subsubsection SRFI 125 Constructors + +@deffn {Scheme Procedure} make-hash-table comparator [ arg @dots{} ] +@deffnx {Scheme Procedure} make-hash-table equality-predicate [ hash-function ] [ arg @dots{} ]) + +Return a newly allocated hash table whose equality predicate and hash +function are extracted from comparator. Alternatively, for backward +compatibility with SRFI 69 the equality predicate and hash function can +be passed as separate arguments; this usage is deprecated. + +These procedures relate to R6RS @code{make-eq-hashtable}, +@code{make-eqv-hashtable} and @code{make-hashtable} ones, and +@code{make-hash-table} from Common Lisp. +@end deffn + +@deffn {Scheme Procedure} hash-table comparator [ key value ] @dots{} + +Return a newly allocated hash table, created as if by +@code{make-hash-table} using @var{comparator}. For each pair of +arguments, an association is added to the new hash table with @var{key} +as its key and @var{value} as its value. This procedure returns an +immutable hash table. If the same key (in the sense of the equality +predicate) is specified more than once, it is an error. +@end deffn + +@deffn {Scheme Procedure} hash-table-unfold stop? mapper successor seed comparator arg @dots{} + +Create a new hash table as if by @var{make-hash-table} using +@var{comparator} and the @var{args}. If the result of applying the +predicate @code{stop?} to @var{seed} is true, return the hash table. +Otherwise, apply the procedure @var{mapper} to @var{seed}. @var{mapper} +returns two values, which are inserted into the hash table as the key +and the value respectively. Then get a new seed by applying the +procedure @var{successor} to @var{seed}, and repeat this algorithm. +@end deffn + +@deffn {Scheme Procedure} alist->hash-table alist comparator arg @dots{} +@deffnx {Scheme Procedure} alist->hash-table alist equality-predicate [ hash-function ] arg @dots{} + +Return a newly allocated hash table as if by @code{make-hash-table} +using @var{comparator} and the @var{args}. It is then initialized from +the associations of @var{alist}. Associations earlier in the list take +precedence over those that come later. The second form is for +compatibility with SRFI 69, and is deprecated. +@end deffn + +@node SRFI 125 Predicates +@subsubsection SRFI 125 Predicates + +@deffn {Scheme Procedure} hash-table? obj + +Return @code{#t} if @var{obj} is a hash table, and @code{#f} otherwise. +(R6RS @code{hashtable?}; Common Lisp @code{hash-table-p}) +@end deffn + +@deffn {Scheme Procedure} hash-table-contains? hash-table key +@deffnx {Scheme Procedure} hash-table-exists? hash-table key + +Return @code{#t} if there is any association to key in @var{hash-table}, +and @code{#f} otherwise. Execute in amortized constant time. The +@code{hash-table-exists?} procedure is the same as +@code{hash-table-contains?}; it is provided for backward compatibility +with SRFI 69, and is deprecated. (R6RS @code{hashtable-contains?}) +@end deffn + +@deffn {Scheme Procedure} hash-table-empty? hash-table + +Return @code{#t} if @var{hash-table} contains no associations, and +@code{#f} otherwise. +@end deffn + +@deffn {Scheme Procedure} hash-table=? value-comparator hash-table@sub{1} hash-table@sub{2} + +Return @code{#t} if @var{hash-table@sub{1}} and @var{hash-table@sub{2}} +have the same keys (in the sense of their common equality predicate) and +each key has the same value (in the sense of @var{value-comparator)}, +and @code{#f} otherwise. +@end deffn + +@deffn {Scheme Procedure} hash-table-mutable? hash-table + +Return @code{#t} if @var{hash-table} is mutable. (R6RS +@code{hashtable-mutable?}) +@end deffn + +@node SRFI 125 Accessors +@subsubsection SRFI 125 Accessors + +The following procedures, given a key, return the corresponding value. + +@deffn {Scheme Procedure} hash-table-ref hash-table key [ failure [ success ] ] + +Extract the value associated to key in @var{hash-table}, invoke the +procedure success on it, and return its result; if @var{success} is not +provided, then the value itself is returned. If @var{key} is not +contained in @var{hash-table} and @var{failure} is supplied, then +@var{failure} is called with no arguments and its result is returned. +Otherwise, it is an error. Execute in expected amortized constant time, +not counting the time to call the procedures. SRFI 69 does not support +the @var{success} procedure. +@end deffn + +@deffn {Scheme Procedure} hash-table-ref/default hash-table key default + +Semantically equivalent to, but may be more efficient than, the +following code: + +@lisp +(hash-table-ref @var{hash-table} @var{key} (lambda () @var{default})) +@end lisp + +(R6RS @code{hashtable-ref}; Common Lisp @code{gethash}) +@end deffn + +@node SRFI 125 Mutators +@subsubsection SRFI 125 Mutators + +The following procedures alter the associations in a hash table either +unconditionally, or conditionally on the presence or absence of a +specified key. It is an error to add an association to a hash table +whose key does not satisfy the type test predicate of the comparator +used to create the hash table. + +@deffn {Scheme Procedure} hash-table-set! hash-table arg @dots{} + +Repeatedly mutates @code{hash-table}, creating new associations in it by +processing the arguments from left to right. The @var{args} alternate +between keys and values. Whenever there is a previous association for a +key, it is deleted. It is an error if the type check procedure of the +comparator of @var{hash-table}, when invoked on a key, does not return +@code{#t}. Likewise, it is an error if a key is not a valid argument to +the equality predicate of @var{hash-table}. Return an unspecified +value. Execute in expected amortized constant time per key. +SRFI 69, R6RS @code{hashtable-set!} and Common Lisp (@samp{setf +gethash}) do not handle multiple associations. +@end deffn + +@deffn {Scheme Procedure} hash-table-delete! hash-table key @dots{} + +Delete any association to each key in @var{hash-table} and returns the +number of keys that had associations. Execute in expected amortized +constant time per key. SRFI 69, R6RS @code{hashtable-delete!}, and +Common Lisp @var{remhash} do not handle multiple associations. +@end deffn + +@deffn {Scheme Procedure} hash-table-intern! hash-table key failure + +Effectively invoke @code{hash-table-ref} with the given arguments and +return what it returns. If @var{key} was not found in @var{hash-table}, +its value is set to the result of calling @var{failure}. Execute in +expected amortized constant time. +@end deffn + +@deffn {Scheme Procedure} hash-table-update! hash-table key updater [ failure [ success ] ] + +Semantically equivalent to, but may be more efficient than, the +following code: + +@lisp +(hash-table-set! @var{hash-table} @var{key} + (@var{updater} (hash-table-ref @var{hash-table} @var{key} @var{failure} @var{success}))) +@end lisp + +Execute in expected amortized constant time. Return an unspecified +value. (SRFI 69 and R6RS @code{hashtable-update!} do not support +the @var{success} procedure) +@end deffn + +@deffn {Scheme Procedure} hash-table-update!/default hash-table key updater default + +Semantically equivalent to, but may be more efficient than, the +following code: + +@lisp +(hash-table-set! @var{hash-table} @var{key} + (@var{updater} (hash-table-ref/default @var{hash-table} @var{key} @var{default}))) +@end lisp + +Execute in expected amortized constant time. Return an unspecified value. +@end deffn + +@deffn {Scheme Procedure} hash-table-pop! hash-table + +Choose an arbitrary association from @var{hash-table} and removes it, +returning the key and value as two values. It is an error if +@var{hash-table} is empty. +@end deffn + +@deffn {Scheme Procedure} hash-table-clear! hash-table +Delete all the associations from @var{hash-table}. (R6RS +@code{hashtable-clear!}; Common Lisp @code{clrhash}.) +@end deffn + +@node SRFI 125 The whole hash table +@subsubsection SRFI 125 The whole hash table + +These procedures process the associations of the hash table in an +unspecified order. + +@deffn {Scheme Procedure} hash-table-size hash-table + +Return the number of associations in @var{hash-table} as an exact +integer. Execute in constant time. (R6RS @code{hashtable-size}; Common +Lisp @code{hash-table-count}.) +@end deffn + +@deffn {Scheme Procedure} hash-table-keys hash-table + +Return a newly allocated list of all the keys in @var{hash-table}. R6RS +@code{hashtable-keys} returns a vector. +@end deffn + +@deffn {Scheme Procedure} hash-table-values hash-table + +Return a newly allocated list of all the keys in @var{hash-table}. +@end deffn + +@deffn {Scheme Procedure} hash-table-entries hash-table + +Return two values, a newly allocated list of all the keys in +@var{hash-table} and a newly allocated list of all the values in +@var{hash-table} in the corresponding order. R6RS +@code{hash-table-entries} returns vectors. +@end deffn + +@deffn {Scheme Procedure} hash-table-find proc hash-table failure + +For each association of @var{hash-table}, invoke @var{proc} on its key +and value. If @var{proc} returns true, then @code{hash-table-find} +returns what @var{proc} returns. If all the calls to @var{proc} return +@code{#f}, return the result of invoking the thunk @var{failure}. +@end deffn + +@deffn {Scheme Procedure} hash-table-count pred hash-table +For each association of @var{hash-table}, invoke @var{pred} on its key +and value. Return the number of calls to @var{pred} which returned +true. +@end deffn + +@node SRFI 125 Mapping and folding +@subsubsection SRFI 125 Mapping and folding + +These procedures process the associations of the hash table in an +unspecified order. + +@deffn {Scheme Procedure} hash-table-map proc comparator hash-table + +Return a newly allocated hash table as if by @samp{(make-hash-table +comparator)}. Calls @var{proc} for every association in +@var{hash-table} with the value of the association. The key of the +association and the result of invoking @var{proc} are entered into the +new hash table. Note that this is not the result of lifting mapping +over the domain of hash tables, but it is considered more useful. + +If @var{comparator} recognizes multiple keys in the @var{hash-table} as +equivalent, any one of such associations is taken. +@end deffn + +@deffn {Scheme Procedure} hash-table-for-each proc hash-table +@deffnx {Scheme Procedure} hash-table-walk hash-table proc + +Call @var{proc} for every association in @var{hash-table} with two +arguments: the key of the association and the value of the association. +The value returned by @var{proc} is discarded. Return an unspecified +value. The @code{hash-table-walk} procedure is equivalent to +@code{hash-table-for-each} with the arguments reversed, is provided for +backward compatibility with SRFI 69, and is deprecated. (Common +Lisp @code{maphash}) +@end deffn + +@deffn {Scheme Procedure} hash-table-map! proc hash-table + +Call @var{proc} for every association in @var{hash-table} with two +arguments: the key of the association and the value of the association. +The value returned by @var{proc} is used to update the value of the +association. Return an unspecified value. +@end deffn + +@deffn {Scheme Procedure} hash-table-map->list proc hash-table + +Call @var{proc} for every association in @var{hash-table} with two +arguments: the key of the association and the value of the association. +The values returned by the invocations of @var{proc} are accumulated +into a list, which is returned. +@end deffn + +@deffn {Scheme Procedure} hash-table-fold proc seed hash-table +@deffnx {Scheme Procedure} hash-table-fold hash-table proc seed + +Call @var{proc} for every association in @var{hash-table} with three +arguments: the key of the association, the value of the association, and +an accumulated value @var{val}. @var{val} is the seed for the first +invocation of @var{proc}, and for subsequent invocations of @var{proc}, +the returned value of the previous invocation. The value returned by +@code{hash-table-fold} is the return value of the last invocation of +@var{proc}. The order of arguments with @var{hash-table} as the first +argument is provided for SRFI 69 compatibility, and is deprecated. +@end deffn + +@deffn {Scheme Procedure} hash-table-prune! proc hash-table + +Call @var{proc} for every association in @var{hash-table} with two +arguments, the key and the value of the association, and removes all +associations from @var{hash-table} for which @var{proc} returns true. +Return an unspecified value. +@end deffn + +@node SRFI 125 Copying and conversion +@subsubsection SRFI 125 Copying and conversion + +@deffn {Scheme Procedure} hash-table-copy hash-table [ mutable? ] + +Return a newly allocated hash table with the same properties and +associations as @var{hash-table}. If the second argument is present and +is true, the new hash table is mutable. Otherwise it is immutable. +SRFI 69 @code{hash-table-copy} does not support a second argument. +(R6RS @code{hashtable-copy}) +@end deffn + +@deffn {Scheme Procedure} hash-table-empty-copy hash-table + +Return a newly allocated mutable hash table with the same properties as +@var{hash-table}, but with no associations. +@end deffn + +@deffn {Scheme Procedure} hash-table->alist hash-table + +Return an alist with the same associations as @var{hash-table} in an +unspecified order. +@end deffn + +@node SRFI 125 Hash tables as sets +@subsubsection SRFI 125 Hash tables as sets + +@deffn {Scheme Procedure} hash-table-union! hash-table@sub{1} hash-table@sub{2} +@deffnx {Scheme Procedure} hash-table-merge! hash-table@sub{1} hash-table@sub{2} + +Add the associations of @var{hash-table@sub{2}} to +@var{hash-table@sub{1}} and return @var{hash-table@sub{1}}. If a key +appears in both hash tables, its value is set to the value appearing in +@var{hash-table@sub{1}}. Return @var{hash-table@sub{1}}. The +@code{hash-table-merge!} procedure is the same as +@code{hash-table-union!}, is provided for compatibility with SRFI 69, +and is deprecated. +@end deffn + +@deffn {Scheme Procedure} hash-table-intersection! hash-table@sub{1} hash-table@sub{2} + +Delete the associations from @var{hash-table@sub{1}} whose keys don't +also appear in @var{hash-table@sub{2}} and return +@var{hash-table@sub{1}}. +@end deffn + +@deffn {Scheme Procedure} hash-table-difference! hash-table@sub{1} hash-table@sub{2} + +Delete the associations of @var{hash-table@sub{1}} whose keys are also +present in @var{hash-table@sub{2}} and return @var{hash-table@sub{1}}. +@end deffn + +@deffn {Scheme Procedure} hash-table-xor! hash-table@sub{1} hash-table@sub{2} + +Delete the associations of @var{hash-table@sub{1}} whose keys are also +present in @var{hash-table@sub{2}}, and then adds the associations of +@var{hash-table@sub{2}} whose keys are not present in +@var{hash-table@sub{1}} to @var{hash-table@sub{1}}. Return +@var{hash-table@sub{1}}. +@end deffn + +@node SRFI 125 Hash functions and reflectivity +@subsubsection SRFI 125 Hash functions and reflectivity + +These functions are made part of this SRFI solely for compatibility with +SRFI 69, and are deprecated. + +@quotation note +While the SRFI 125 specifies that these deprecated procedures should be +exported using their original names, which forces its users to rename +these procedures to something else to avoid clashing with the SRFI 126 +and SRFI 128 variants that should be preferred instead, Guile exports +them with the @code{deprecated:} prefix. +@end quotation + +@deffn {Scheme Procedure} deprecated:hash obj [ arg ] + +The same as SRFI 128's @code{default-hash} procedure, except that it +must accept (and should ignore) an optional second argument. +@end deffn + +@deffn {Scheme Procedure} deprecated:string-hash obj [ arg ] + +Similar to SRFI 128's @code{string-hash} procedure, except that it must +accept (and should ignore) an optional second argument. It is +incompatible with the procedure of the same name exported by SRFI 128 +and SRFI 126. +@end deffn + +@deffn {Scheme Procedure} deprecated:hash-by-identity obj [ arg ] + +The same as SRFI 128's @code{default-hash} procedure, except that it +must accept (and should ignore) an optional second argument. +@end deffn + +@deffn {Scheme Procedure} deprecated:hash-table-equivalence-function hash-table + +Return the equivalence procedure used to create @var{hash-table}. +@end deffn + +@deffn {Scheme Procedure} deprecated:hash-table-hash-function hash-table + +Return the hash function used to create @var{hash-table}. +@end deffn + @node SRFI 126 @subsection SRFI 126 R6RS-based hash tables @cindex SRFI 126 diff --git a/module/srfi/srfi-125.sld b/module/srfi/srfi-125.sld new file mode 100644 index 000000000..72b3c9da7 --- /dev/null +++ b/module/srfi/srfi-125.sld @@ -0,0 +1,87 @@ +;;; SPDX-FileCopyrightText: 2015 William D Clinger +;;; +;;; SPDX-License-Identifier: LicenseRef-Clinger + +(define-library (srfi 125) + + (export + + make-hash-table + hash-table + hash-table-unfold + alist->hash-table + + hash-table? + hash-table-contains? + hash-table-empty? + hash-table=? + hash-table-mutable? + + hash-table-ref + hash-table-ref/default + + hash-table-set! + hash-table-delete! + hash-table-intern! + hash-table-update! + hash-table-update!/default + hash-table-pop! + hash-table-clear! + + hash-table-size + hash-table-keys + hash-table-values + hash-table-entries + hash-table-find + hash-table-count + + hash-table-map + hash-table-for-each + hash-table-map! + hash-table-map->list + hash-table-fold + hash-table-prune! + + hash-table-copy + hash-table-empty-copy + hash-table->alist + + hash-table-union! + hash-table-intersection! + hash-table-difference! + hash-table-xor! + + ;; The following procedures are deprecated by SRFI 125: + + (rename deprecated:hash hash) + (rename deprecated:string-hash string-hash) + (rename deprecated:string-ci-hash string-ci-hash) + (rename deprecated:hash-by-identity hash-by-identity) + + (rename deprecated:hash-table-equivalence-function + hash-table-equivalence-function) + (rename deprecated:hash-table-hash-function hash-table-hash-function) + (rename deprecated:hash-table-exists? hash-table-exists?) + (rename deprecated:hash-table-walk hash-table-walk) + (rename deprecated:hash-table-merge! hash-table-merge!) + + ) + + (import (scheme base) + (scheme write) ; for warnings about deprecated features + (srfi 126) + (except (srfi 128) + hash-salt ; exported by (srfi 126) + string-hash ; exported by (srfi 126) + string-ci-hash ; exported by (srfi 126) + )) + + (cond-expand + ((library (scheme char)) + (import (scheme char))) + (else + (begin (define string-ci=? string=?)))) + + (include "srfi-125/125.body.scm") + + ) ; eof diff --git a/module/srfi/srfi-125/125.body.scm b/module/srfi/srfi-125/125.body.scm new file mode 100644 index 000000000..1fc30be44 --- /dev/null +++ b/module/srfi/srfi-125/125.body.scm @@ -0,0 +1,590 @@ +;;; SPDX-License-Identifier: LicenseRef-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. +;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; 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 '()) + +;;; 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) + +;;; 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 (comparator-hash-function comparator))) + (if %enforce-comparator-type-tests + (lambda (x . rest) + (cond ((not (okay? x)) + (error "key rejected by hash-table comparator" + x + comparator)) + ((null? rest) + (hash-function x)) + (else + (apply hash-function x rest)))) + hash-function))) + +;;; A unique (in the sense of eq?) value that will never be found +;;; within a hash-table. + +(define %not-found (list '%not-found)) + +;;; A unique (in the sense of eq?) value that escapes only as an irritant +;;; when a hash-table key is not found. + +(define %not-found-irritant (list 'not-found)) + +;;; The error message used when a hash-table key is not found. + +(define %not-found-message "hash-table key not found") + +;;; FIXME: thread-safe, weak-keys, ephemeral-keys, weak-values, +;;; and ephemeral-values are not supported by this portable +;;; reference implementation. + +(define (%check-optional-arguments procname args) + (if (or (memq 'thread-safe args) + (memq 'weak-keys args) + (memq 'weak-values args) + (memq 'ephemeral-keys args) + (memq 'ephemeral-values args)) + (error (string-append (symbol->string procname) + ": unsupported optional argument(s)") + args))) + +;;; This was exported by an earlier draft of SRFI 125, +;;; and is still used by hash-table=? + +(define (hash-table-every proc ht) + (call-with-values + (lambda () (hash-table-entries ht)) + (lambda (keys vals) + (let loop ((keys keys) + (vals vals)) + (if (null? keys) + #t + (let* ((key (car keys)) + (val (car vals)) + (x (proc key val))) + (and x + (loop (cdr keys) + (cdr vals))))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Exported procedures +;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; Constructors. + +;;; 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 hash-function rest)))) + +(define (%make-hash-table equiv hash-function opts) + (%check-optional-arguments 'make-hash-table opts) + (cond ((equal? equiv eq?) + (make-eq-hashtable)) + ((equal? equiv eqv?) + (make-eqv-hashtable)) + (hash-function + (make-hashtable hash-function equiv)) + ((equal? equiv equal?) + (make-hashtable equal-hash equiv)) + ((equal? equiv string=?) + (make-hashtable string-hash equiv)) + ((equal? equiv string-ci=?) + (make-hashtable string-ci-hash equiv)) + ((equal? equiv symbol=?) + (make-hashtable symbol-hash equiv)) + (else + (error "make-hash-table: unable to infer hash function" + equiv)))) + +(define (hash-table comparator . rest) + (let ((ht (apply make-hash-table comparator rest))) + (let loop ((kvs rest)) + (cond + ((null? kvs) #f) + ((null? (cdr kvs)) (error "hash-table: wrong number of arguments")) + ((hashtable-contains? ht (car kvs)) + (error "hash-table: two equivalent keys were provided" + (car kvs))) + (else (hashtable-set! ht (car kvs) (cadr kvs)) + (loop (cddr kvs))))) + (hashtable-copy ht #f))) + +(define (hash-table-unfold stop? mapper successor seed comparator . rest) + (let ((ht (apply make-hash-table comparator rest))) + (let loop ((seed seed)) + (if (stop? seed) + ht + (call-with-values + (lambda () (mapper seed)) + (lambda (key val) + (hash-table-set! ht key val) + (loop (successor seed)))))))) + +(define (alist->hash-table alist comparator/equiv . rest) + (if (and (not (null? rest)) + (procedure? (car rest))) + (issue-warning-deprecated 'srfi-69-style:alist->hash-table)) + (let ((ht (apply make-hash-table comparator/equiv rest)) + (entries (reverse alist))) + (for-each (lambda (entry) + (hash-table-set! ht (car entry) (cdr entry))) + entries) + ht)) + +;;; Predicates. + +(define (hash-table? obj) + (hashtable? obj)) + +(define (hash-table-contains? ht key) + (hashtable-contains? ht key)) + +(define (hash-table-empty? ht) + (= 0 (hashtable-size ht))) + +;;; FIXME: walks both hash tables because their key comparators +;;; might be different + +(define (hash-table=? value-comparator ht1 ht2) + (let ((val=? (comparator-equality-predicate value-comparator)) + (n1 (hash-table-size ht1)) + (n2 (hash-table-size ht2))) + (and (= n1 n2) + (hash-table-every (lambda (key val1) + (and (hashtable-contains? ht2 key) + (val=? val1 + (hashtable-ref ht2 key 'ignored)))) + ht1) + (hash-table-every (lambda (key val2) + (and (hashtable-contains? ht1 key) + (val=? val2 + (hashtable-ref ht1 key 'ignored)))) + ht2)))) + +(define (hash-table-mutable? ht) + (hashtable-mutable? ht)) + +;;; Accessors. + +(define (hash-table-ref ht key . rest) + (let ((failure (if (null? rest) #f (car rest))) + (success (if (or (null? rest) (null? (cdr rest))) #f (cadr rest))) + (val (hashtable-ref ht key %not-found))) + (cond ((eq? val %not-found) + (if (and failure (procedure? failure)) + (failure) + (error %not-found-message ht key %not-found-irritant))) + (success + (success val)) + (else + val)))) + +(define (hash-table-ref/default ht key default) + (hashtable-ref ht key default)) + +;;; Mutators. + +(define (hash-table-set! ht . rest) + (if (= 2 (length rest)) + (hashtable-set! ht (car rest) (cadr rest)) + (let loop ((kvs rest)) + (cond ((and (not (null? kvs)) + (not (null? (cdr kvs)))) + (hashtable-set! ht (car kvs) (cadr kvs)) + (loop (cddr kvs))) + ((not (null? kvs)) + (error "hash-table-set!: wrong number of arguments" + (cons ht rest))))))) + +(define (hash-table-delete! ht . keys) + (let loop ((keys keys) (cnt 0)) + (cond ((null? keys) cnt) + ((hash-table-contains? ht (car keys)) + (hashtable-delete! ht (car keys)) + (loop (cdr keys) (+ cnt 1))) + (else + (loop (cdr keys) cnt))))) + +(define (hash-table-intern! ht key failure) + (if (hashtable-contains? ht key) + (hash-table-ref ht key) + (let ((val (failure))) + (hash-table-set! ht key val) + val))) + +(define (hash-table-update! ht key updater . rest) + (hash-table-set! ht + key + (updater (apply hash-table-ref ht key rest)))) + +(define (hash-table-update!/default ht key updater default) + (hash-table-set! ht key (updater (hashtable-ref ht key default)))) + +(define (hash-table-pop! ht) + (call/cc + (lambda (return) + (hash-table-for-each + (lambda (key value) + (hash-table-delete! ht key) + (return key value)) + ht) + (error "hash-table-pop!: hash table is empty" ht)))) + +(define (hash-table-clear! ht) + (hashtable-clear! ht)) + +;;; The whole hash table. + +(define (hash-table-size ht) + (hashtable-size ht)) + +(define (hash-table-keys ht) + (vector->list (hashtable-keys ht))) + +(define (hash-table-values ht) + (call-with-values + (lambda () (hashtable-entries ht)) + (lambda (keys vals) + (vector->list vals)))) + +(define (hash-table-entries ht) + (call-with-values + (lambda () (hashtable-entries ht)) + (lambda (keys vals) + (values (vector->list keys) + (vector->list vals))))) + +(define (hash-table-find proc ht failure) + (call-with-values + (lambda () (hash-table-entries ht)) + (lambda (keys vals) + (let loop ((keys keys) + (vals vals)) + (if (null? keys) + (failure) + (let* ((key (car keys)) + (val (car vals)) + (x (proc key val))) + (or x + (loop (cdr keys) + (cdr vals))))))))) + +(define (hash-table-count pred ht) + (call-with-values + (lambda () (hash-table-entries ht)) + (lambda (keys vals) + (let loop ((keys keys) + (vals vals) + (n 0)) + (if (null? keys) + n + (let* ((key (car keys)) + (val (car vals)) + (x (pred key val))) + (loop (cdr keys) + (cdr vals) + (if x (+ n 1) n)))))))) + +;;; Mapping and folding. + +(define (hash-table-map proc comparator ht) + (let ((result (make-hash-table comparator))) + (hash-table-for-each + (lambda (key val) + (hash-table-set! result key (proc val))) + ht) + result)) + +(define (hash-table-map->list proc ht) + (call-with-values + (lambda () (hash-table-entries ht)) + (lambda (keys vals) + (map proc keys vals)))) + +;;; With this particular implementation, the proc can safely mutate ht. +;;; That property is not guaranteed by the specification, but can be +;;; relied upon by procedures defined in this file. + +(define (hash-table-for-each proc ht) + (call-with-values + (lambda () (hashtable-entries ht)) + (lambda (keys vals) + (vector-for-each proc keys vals)))) + +(define (hash-table-map! proc ht) + (hash-table-for-each (lambda (key val) + (hashtable-set! ht key (proc key val))) + ht)) + +(define (hash-table-fold proc init ht) + (if (hashtable? proc) + (deprecated:hash-table-fold proc init ht) + (call-with-values + (lambda () (hash-table-entries ht)) + (lambda (keys vals) + (let loop ((keys keys) + (vals vals) + (x init)) + (if (null? keys) + x + (loop (cdr keys) + (cdr vals) + (proc (car keys) (car vals) x)))))))) + +(define (hash-table-prune! proc ht) + (hash-table-for-each (lambda (key val) + (if (proc key val) + (hashtable-delete! ht key))) + ht)) + +;;; Copying and conversion. + +(define (hash-table-copy ht . rest) + (apply hashtable-copy ht rest)) + +(define (hash-table-empty-copy ht) + (let* ((ht2 (hashtable-copy ht #t)) + (ignored (hashtable-clear! ht2))) + ht2)) + +(define (hash-table->alist ht) + (call-with-values + (lambda () (hash-table-entries ht)) + (lambda (keys vals) + (map cons keys vals)))) + +;;; Hash tables as sets. + +(define (hash-table-union! ht1 ht2) + (hash-table-for-each + (lambda (key2 val2) + (if (not (hashtable-contains? ht1 key2)) + (hashtable-set! ht1 key2 val2))) + ht2) + ht1) + +(define (hash-table-intersection! ht1 ht2) + (hash-table-for-each + (lambda (key1 val1) + (if (not (hashtable-contains? ht2 key1)) + (hashtable-delete! ht1 key1))) + ht1) + ht1) + +(define (hash-table-difference! ht1 ht2) + (hash-table-for-each + (lambda (key1 val1) + (if (hashtable-contains? ht2 key1) + (hashtable-delete! ht1 key1))) + ht1) + ht1) + +(define (hash-table-xor! ht1 ht2) + (hash-table-for-each + (lambda (key2 val2) + (if (hashtable-contains? ht1 key2) + (hashtable-delete! ht1 key2) + (hashtable-set! ht1 key2 val2))) + ht2) + ht1) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; 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) + (default-hash obj)) + +(define (deprecated:string-hash obj . rest) + (issue-warning-deprecated 'srfi-125:string-hash) + (string-hash obj)) + +(define (deprecated:string-ci-hash obj . rest) + (issue-warning-deprecated 'srfi-125:string-ci-hash) + (string-ci-hash obj)) + +(define (deprecated:hash-by-identity obj . rest) + (issue-warning-deprecated 'hash-by-identity) + (deprecated:hash obj)) + +(define (deprecated:hash-table-equivalence-function ht) + (issue-warning-deprecated 'hash-table-equivalence-function) + (hashtable-equivalence-function ht)) + +(define (deprecated:hash-table-hash-function ht) + (issue-warning-deprecated 'hash-table-hash-function) + (hashtable-hash-function ht)) + +(define (deprecated:hash-table-exists? ht key) + (issue-warning-deprecated 'hash-table-exists?) + (hash-table-contains? ht key)) + +(define (deprecated:hash-table-walk ht proc) + (issue-warning-deprecated 'hash-table-walk) + (hash-table-for-each proc ht)) + +(define (deprecated:hash-table-fold ht proc seed) + (issue-warning-deprecated 'srfi-69-style:hash-table-fold) + (hash-table-fold proc seed ht)) + +(define (deprecated:hash-table-merge! ht1 ht2) + (issue-warning-deprecated 'hash-table-merge!) + (hash-table-union! ht1 ht2)) + +; eof diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am index 0fb5827cc..13eb1f24f 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-171.test \ @@ -210,6 +211,7 @@ EXTRA_DIST = \ $(SCM_TESTS) \ tests/rnrs-test-a.scm \ tests/srfi-64-test.scm \ + tests/srfi-125-test.scm \ tests/srfi-126-test.scm \ tests/srfi-128-test.scm \ ChangeLog-2008 diff --git a/test-suite/tests/srfi-125-test.scm b/test-suite/tests/srfi-125-test.scm new file mode 100644 index 000000000..8774d3694 --- /dev/null +++ b/test-suite/tests/srfi-125-test.scm @@ -0,0 +1,891 @@ +;;; SPDX-License-Identifier: MIT +;;; 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. + +;;; 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. + +(import (scheme base) + (scheme char) + (scheme write) + (only (scheme process-context) exit) + (scheme comparator) ; was (srfi 128) + (only (scheme sort) list-sort) ; was (r6rs sorting) + (only (srfi 126) hashtable-copy) + (rename (srfi 125) + (string-hash deprecated:string-hash) + (string-ci-hash deprecated:string-ci-hash))) + +;;; Commentary: + +;;; The test suite was slightly adjusted to use SRFI 64, for better +;;; integration with the Guile test suite. + +;;; Code: + +(test-begin "srfi-125") + +;;; FIXME: when debugging catastrophic failures, printing every expression +;;; before it's executed may help. + +(define-syntax test + (syntax-rules () + ((_ expr expected) + (test-equal expr expected)))) + +(define-syntax test-deny + (syntax-rules () + ((_ expr) + (test-assert (not expr))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Transition from SRFI 114 to SRFI 128. +;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define default-comparator (make-default-comparator)) + +;;; SRFI 128 says the following definition will work, but that's +;;; an error in SRFI 128; the hash function produce non-integers. + +#; +(define number-comparator + (make-comparator real? = < (lambda (x) (exact (abs x))))) + +(define number-comparator + (make-comparator real? = < (lambda (x) (exact (abs (round x)))))) + +(define string-comparator + (make-comparator string? string=? stringhash-table '(("" . 0) ("Mary" . 4) ("Paul" . 4) ("Peter" . 5)) + string-ci-comparator + "ignored1" 'ignored2)) + +(define ht-symbol2 + (alist->hash-table '((mary . travers) (noel . stookey) (peter .yarrow)) + eq?)) + +(define ht-equal2 + (alist->hash-table '(((edward) . abbey) + ((dashiell) . hammett) + ((edward) . teach) + ((mark) . twain)) + equal? + (comparator-hash-function default-comparator))) + +(define test-tables + (list ht-default ht-default2 ; initial keys: foo, 101.3, (x y z) + ht-eq ht-eq2 ; initially empty + ht-eqv ht-eqv2 ; initially empty + ht-equal ht-equal2 ; initial keys: (edward), (dashiell), (mark) + ht-string ht-string2 ; initial keys: "p, "pr", ..., "prefixes" + ht-string-ci ht-string-ci2 ; initial keys: "", "Mary", "Paul", "Peter" + ht-symbol ht-symbol2 ; initial keys: mary, noel, peter + ht-fixnum ht-fixnum2)) ; initial keys: 0, 1, 4, 9, ..., 81 + +;;; Predicates + +(test (map hash-table? + (cons '#() + (cons default-comparator + test-tables))) + (append '(#f #f) (map (lambda (x) #t) test-tables))) + +(test (map hash-table-contains? + test-tables + '(foo 101.3 + x "y" + (14 15) #\newline + (edward) (mark) + "p" "pref" + "mike" "PAUL" + jane noel + 0 4)) + '(#f #t #f #f #f #f #f #t #f #t #f #t #f #t #f #t)) + +(test (map hash-table-contains? + test-tables + '(#u8() 47.9 + '#() '() + foo bar + 19 (henry) + "p" "perp" + "mike" "Noel" + jane paul + 0 5)) + (map (lambda (x) #f) test-tables)) + +(test (map hash-table-empty? test-tables) + '(#t #f #t #t #t #t #t #f #t #f #t #f #t #f #t #f)) + +(test (map (lambda (ht1 ht2) (hash-table=? default-comparator ht1 ht2)) + test-tables + test-tables) + (map (lambda (x) #t) test-tables)) + +(test (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))) + '(#f #f #t #t #t #t #f #f #f #f #f #f #f #f #f #f)) + +(test (map hash-table-mutable? test-tables) + '(#t #f #t #t #t #t #t #t #t #t #t #t #t #t #t #f)) + +;;; FIXME: glass-box + +(test (map hash-table-mutable? (map hash-table-copy test-tables)) + (map (lambda (x) #f) test-tables)) + +(test (hash-table-mutable? (hash-table-copy ht-fixnum2 #t)) + #t) + +;;; Accessors. + +;;; FIXME: glass-box (implementations not required to raise an exception here) + +(test (map (lambda (ht) + (guard (exn + (else 'err)) + (hash-table-ref ht 'not-a-key))) + test-tables) + (map (lambda (ht) 'err) test-tables)) + +;;; FIXME: glass-box (implementations not required to raise an exception here) + +(test (map (lambda (ht) + (guard (exn + (else 'err)) + (hash-table-ref ht 'not-a-key (lambda () 'err)))) + test-tables) + (map (lambda (ht) 'err) test-tables)) + +;;; FIXME: glass-box (implementations not required to raise an exception here) + +(test (map (lambda (ht) + (guard (exn + (else 'err)) + (hash-table-ref ht 'not-a-key (lambda () 'err) values))) + test-tables) + (map (lambda (ht) 'err) test-tables)) + +(test (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)) + '(err "fever" err err err err err twain err 4 err 4 err stookey err 2)) + +(test (map (lambda (ht key) + (guard (exn + (else 'err)) + (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)) + '(eh "fever" eh eh eh eh eh twain eh 4 eh 4 eh stookey eh 2)) + +(test (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)) + '(eh ("fever") eh eh eh eh eh (twain) eh (4) eh (4) eh (stookey) eh (2))) + +;;; FIXME: glass-box (implementations not required to raise an exception here) + +(test (map (lambda (ht) + (guard (exn + (else 'eh)) + (hash-table-ref/default ht 'not-a-key 'eh))) + test-tables) + (map (lambda (ht) 'eh) test-tables)) + +(test (map (lambda (ht key) + (guard (exn + (else 'err)) + (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)) + '(eh "fever" eh eh eh eh eh twain eh 4 eh 4 eh stookey eh 2)) + +(test (begin (hash-table-set! ht-fixnum) + (list-sort < (hash-table-keys ht-fixnum))) + '()) + +(test (begin (hash-table-set! ht-fixnum 121 11 144 12 169 13) + (list-sort < (hash-table-keys ht-fixnum))) + '(121 144 169)) + +(test (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))) + '(0 1 4 9 16 25 36 49 64 81 121 144 169)) + +(test (map (lambda (i) (hash-table-ref/default ht-fixnum i 'error)) + '(169 144 121 0 1 4 9 16 25 36 49 64 81)) + '(13 12 11 0 1 2 3 4 5 6 7 8 9)) + +(test (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))) + '(13 12 11 0 1 2 3 4 5 6 7 8 9)) + +(test (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))) + '(-1 12 -1 0 -1 2 -1 4 -1 6 -1 8 -1)) + +(test (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))) + '(-1 12 -1 -1 -1 2 -1 4 -1 -1 -1 8 -1)) + +(test (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))) + '(13 12 11 0 1 2 -1 4 -1 -1 -1 8 -1)) + +(test (list-sort (lambda (v1 v2) (< (vector-ref v1 0) (vector-ref v2 0))) + (hash-table-map->list vector ht-fixnum)) + '(#(0 0) #(1 1) #(4 2) #(16 4) #(64 8) #(121 11) #(144 12) #(169 13))) + +(test (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))) + '((0 0) (1 1) (4 2) (16 4) (64 8) #;(121 11) (144 12) #;(169 13))) + +(test (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))) + '((0 0) (1 1) (4 2) (16 4) (64 8) (121 11) (144 12) (169 13))) + +(test (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))) + '(13 12 11 0 1 2 3 4 -1 -1 -1 8 -1)) + +(test (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))) + '(13 12 11 0 1 2 3 -4 -1 -1 -1 8 -1)) + +(test (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))) + '(13 12 11 0 1 2 3 4 -1 -1 -1 8 -1)) + +(test (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))) + '(13 12 11 0 1 2 3 4 -5 -1 -1 8 -1)) + +(test (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))) + '(13 12 11 0 1 2 3 4 5 -1 -1 8 -1)) + +(test (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) + (list (= key (* val val)) + (= (- n0 1) (hash-table-size ht)))))) + '(#t #t)) + +(test (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))) + '(13 12 11 0 1 2 3 4 5 -1 -1 8 -1 -1)) + +(let ((ht-eg (hashtable-copy (hash-table number-comparator + 1 1 4 2 9 3 16 4 25 5 64 8) + #t))) + (test (hash-table-delete! ht-eg) + 0) + (test (hash-table-delete! ht-eg 2 7 2000) + 0) + (test (hash-table-delete! ht-eg 1 2 4 7 64 2000) + 3) + (test-assert (= 3 (length (hash-table-keys ht-eg))))) + +(test (map (lambda (i) (hash-table-ref/default ht-fixnum i -1)) + '(169 144 121 0 1 4 9 16 25 36 49 64 81)) + '(13 12 11 0 1 2 3 4 5 -1 -1 8 -1)) + +(test (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))) + '(13 12 11 0 1 2 3 4 5 6 -1 8 9)) + +(test (begin (hash-table-clear! ht-eq) + (hash-table-size ht-eq)) + 0) + +;;; The whole hash table. + +(test (begin (hash-table-set! ht-eq 'foo 13 'bar 14 'baz 18) + (hash-table-size ht-eq)) + 3) + +(test (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))) + '(0 3 #t)) + +(test (begin (hash-table-clear! ht-eq) + (hash-table-size ht-eq)) + 0) + +(test (hash-table-find (lambda (key val) + (if (= 144 key (* val val)) + (list key val) + #f)) + ht-fixnum + (lambda () 99)) + '(144 12)) + +(test (hash-table-find (lambda (key val) + (if (= 144 key val) + (list key val) + #f)) + ht-fixnum + (lambda () 99)) + 99) + +(test (hash-table-count <= ht-fixnum) + 2) + +;;; Mapping and folding. + +(test (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)) + '(0 1 2 3 4 5 6 -1 8 9 -1 11 12 13 -1)) + +(test (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))) + '(0 1 4 9 16 25 36 -1 64 81 -1 121 144 169 -1)) + +(test (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)) + '(#(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))) + +(test (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))) + '(0 1 2 3 -4 -5 -6 -1 -8 -9 -1 -11 -12 -13 -1)) + +(test (hash-table-fold (lambda (key val acc) + (+ val acc)) + 0 + ht-string-ci2) + 13) + +(test (list-sort < (hash-table-fold (lambda (key val acc) + (cons key acc)) + '() + ht-fixnum)) + '(0 1 4 9 16 25 36 64 81 121 144 169)) + +;;; Copying and conversion. + +(test (hash-table=? number-comparator ht-fixnum (hash-table-copy ht-fixnum)) + #t) + +(test (hash-table=? number-comparator ht-fixnum (hash-table-copy ht-fixnum #f)) + #t) + +(test (hash-table=? number-comparator ht-fixnum (hash-table-copy ht-fixnum #t)) + #t) + +(test (hash-table-mutable? (hash-table-copy ht-fixnum)) + #f) + +(test (hash-table-mutable? (hash-table-copy ht-fixnum #f)) + #f) + +(test (hash-table-mutable? (hash-table-copy ht-fixnum #t)) + #t) + +(test (hash-table->alist ht-eq) + '()) + +(test (list-sort (lambda (x y) (< (car x) (car y))) + (hash-table->alist ht-fixnum)) + '((0 . 0) + (1 . 1) + (4 . 2) + (9 . 3) + (16 . -4) + (25 . -5) + (36 . -6) + (64 . -8) + (81 . -9) + (121 . -11) + (144 . -12) + (169 . -13))) + +;;; Hash tables as sets. + +(test (begin (hash-table-union! ht-fixnum ht-fixnum2) + (list-sort (lambda (x y) (< (car x) (car y))) + (hash-table->alist ht-fixnum))) + '((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))) + +(test (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))) + '((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))) + +(test (begin (hash-table-union! ht-eqv2 ht-fixnum) + (hash-table=? default-comparator ht-eqv2 ht-fixnum)) + #t) + +(test (begin (hash-table-intersection! ht-eqv2 ht-fixnum) + (hash-table=? default-comparator ht-eqv2 ht-fixnum)) + #t) + +(test (begin (hash-table-intersection! ht-eqv2 ht-eqv) + (hash-table-empty? ht-eqv2)) + #t) + +(test (begin (hash-table-intersection! ht-fixnum ht-fixnum2) + (list-sort (lambda (x y) (< (car x) (car y))) + (hash-table->alist ht-fixnum))) + '((0 . 0) + (1 . 1) + (4 . 2) + (9 . 3) + (16 . -4) + (25 . -5) + (36 . -6) + (49 . 7) + (64 . -8) + (81 . -9))) + +(test (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))) + '((4 . 2) + (25 . -5))) + +(test (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))) + '((0 . 0) + (1 . 1) + (9 . 3) + (16 . 4) + (36 . 6) + (49 . 7) + (64 . 8) + (81 . 9))) + +(test (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))) + '((-1 . -1) + (0 . 0) + (1 . 1) + (9 . 3) + (16 . 4) + (36 . 6) + (49 . 7) + (64 . 8) + (81 . 9) + (100 . 10))) + +(test (guard (exn + (else 'key-not-found)) + (hash-table-ref ht-default "this key won't be present")) + 'key-not-found) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Desultory tests of deprecated procedures and usages. +;;; Deprecated usage of make-hash-table and alist->hash-table +;;; has already been tested above. +;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(test (let* ((x (list 1 2 3)) + (y (cons 1 (cdr x))) + (h1 (hash x)) + (h2 (hash y))) + (list (exact-integer? h1) + (exact-integer? h2) + (= h1 h2))) + '(#t #t #t)) + +(test (let* ((x "abcd") + (y (string-append "ab" "cd")) + (h1 (deprecated:string-hash x)) + (h2 (deprecated:string-hash y))) + (list (exact-integer? h1) + (exact-integer? h2) + (= h1 h2))) + '(#t #t #t)) + +(test (let* ((x "Hello There!") + (y "hello THERE!") + (h1 (deprecated:string-ci-hash x)) + (h2 (deprecated:string-ci-hash y))) + (list (exact-integer? h1) + (exact-integer? h2) + (= h1 h2))) + '(#t #t #t)) + +(test (let* ((x '#(a "bcD" #\c (d 2.718) -42 #u8() #() #u8(19 20))) + (y x) + (h1 (hash-by-identity x)) + (h2 (hash-by-identity y))) + (list (exact-integer? h1) + (exact-integer? h2) + (= h1 h2))) + '(#t #t #t)) + +(test (let* ((x (list 1 2 3)) + (y (cons 1 (cdr x))) + (h1 (hash x 60)) + (h2 (hash y 60))) + (list (exact-integer? h1) + (exact-integer? h2) + (= h1 h2))) + '(#t #t #t)) + +(test (let* ((x "abcd") + (y (string-append "ab" "cd")) + (h1 (deprecated:string-hash x 97)) + (h2 (deprecated:string-hash y 97))) + (list (exact-integer? h1) + (exact-integer? h2) + (= h1 h2))) + '(#t #t #t)) + +(test (let* ((x "Hello There!") + (y "hello THERE!") + (h1 (deprecated:string-ci-hash x 101)) + (h2 (deprecated:string-ci-hash y 101))) + (list (exact-integer? h1) + (exact-integer? h2) + (= h1 h2))) + '(#t #t #t)) + +(test (let* ((x '#(a "bcD" #\c (d 2.718) -42 #u8() #() #u8(19 20))) + (y x) + (h1 (hash-by-identity x 102)) + (h2 (hash-by-identity y 102))) + (list (exact-integer? h1) + (exact-integer? h2) + (= h1 h2))) + '(#t #t #t)) + +(test (let ((f (hash-table-equivalence-function ht-fixnum))) + (if (procedure? f) + (f 34 34) + #t)) + #t) + +(test (let ((f (hash-table-hash-function ht-fixnum))) + (if (procedure? f) + (= (f 34) (f 34)) + #t)) + #t) + +(test (map (lambda (key) (hash-table-exists? ht-fixnum2 key)) + '(0 1 2 3 4 5 6 7 8 9 10)) + '(#t #t #f #f #t #f #f #f #f #t #f)) + +(test (let ((n 0)) + (hash-table-walk ht-fixnum2 + (lambda (key val) (set! n (+ n key)))) + n) + (apply + + (map (lambda (x) (* x x)) + '(0 1 2 3 4 5 6 7 8 9)))) + +(test (list-sort < (hash-table-fold ht-fixnum2 + (lambda (key val acc) + (cons key acc)) + '())) + '(0 1 4 9 16 25 36 49 64 81)) + +(test (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))) + '((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))) + +;;; Bugs reported on 5 January 2019 by Jéssica Milaré +;;; ( https://srfi-email.schemers.org/srfi-125/msg/10177551 ) + +;;; Spec says hash-table returns an immutable hash table (if that +;;; is supported) and signal an error if there are duplicate keys, +;;; but standard implementation returns a mutable hash table and +;;; signals no error with duplicate keys. +;;; +;;; Comment by Will Clinger: the spec says specifying a duplicate +;;; key "is an error", so hash-table is not required to signal an +;;; error when there are duplicate keys. That part of the spec +;;; was added on 8 May 2016, which is why it was not implemented +;;; by the sample implementation of 2 May 2016. Because a duplicate +;;; key "is an error" rather than "signals an error", testing for +;;; that situation is glass-box, as is testing for immutability. + +;;; FIXME: glass-box + +(test (hash-table-mutable? + (hash-table number-comparator + .25 .5 64 9999 81 9998 121 -11 144 -12)) + #f) + +;;; FIXME: glass-box (implementations not required to raise an exception here) + +(test (guard (exn + (else 'eh)) + (hash-table number-comparator .25 .5 .25 -.5)) + 'eh) + +;;; Spec says hash-table-set! must go left to right, but in +;;; standard implementation it goes right to left. +;;; +;;; Comment by Will Clinger: the left-to-right requirement was +;;; added to the spec on 8 May 2016, which is why it was not +;;; implemented by the sample implementation of 2 May 2016. + +(test (let* ((ht (hash-table-empty-copy ht-eq)) + (ignored (hash-table-set! ht 'foo 13 'bar 14 'foo 18))) + (hash-table-ref ht 'foo)) + 18) + +;;; Spec says hash-table-empty-copy returns a mutable hash table, +;;; but in standard implementation it returns an immutable hash +;;; table if the given hash table is immutable. + +;;; FIXME: glass-box (immutable tables need not be supported) + +(test (hash-table-mutable? + (hash-table number-comparator)) + #f) + +(test (hash-table-mutable? + (hash-table-empty-copy + (hash-table-copy (hash-table number-comparator) #f))) + #t) + +;;; hash-table-delete! seems to loop infinitely once it finds a key. +;;; +;;; Comment by Will Clinger: that bug was added by +;;; commit e17c15203a934ab741300e59619f880f363c2b2f +;;; on 26 September 2018. I do not understand the purpose of that +;;; commit, as its one change appears to have had no substantive +;;; effect apart from inserting this bug. + +(test (let* ((ht + (hash-table default-comparator 'foo 1 'bar 2 'baz 3)) + (ht (hash-table-copy ht #t))) + (hash-table-delete! ht 'foo) + (hash-table-size ht)) + 2) + +(test-end "srfi-125") + +; eof diff --git a/test-suite/tests/srfi-125.test b/test-suite/tests/srfi-125.test new file mode 100644 index 000000000..69f283460 --- /dev/null +++ b/test-suite/tests/srfi-125.test @@ -0,0 +1,33 @@ +;;; srfi-125.test --- Test suite for SRFI-125. -*- scheme -*- +;;; +;;; SPDX-FileCopyrightText: 2023 Free Software Foundation, Inc. +;;; +;;; SPDX-License-Identifier: LGPL-3.0-or-later + +(import (srfi 64)) + +(define report (@@ (test-suite lib) report)) + +(define (guile-test-runner) + (let ((runner (test-runner-null))) + (test-runner-on-test-end! runner + (lambda (runner) + (let* ((result-alist (test-result-alist runner)) + (result-kind (assq-ref result-alist 'result-kind)) + (test-name (list (assq-ref result-alist 'test-name)))) + (case result-kind + ((pass) (report 'pass test-name)) + ((xpass) (report 'upass test-name)) + ((skip) (report 'untested test-name)) + ((fail xfail) + (apply report result-kind test-name result-alist)) + (else #t))))) + runner)) + +(test-with-runner + (guile-test-runner) + (primitive-load-path "tests/srfi-125-test.scm")) + +;;; Local Variables: +;;; eval: (put 'test-runner-on-test-end! 'scheme-indent-function 1) +;;; End: -- 2.41.0