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 v5 08/15] module: Add SRFI 126. Date: Wed, 29 Nov 2023 16:59:36 -0500 Message-ID: <20231129220225.6819-9-maxim.cournoyer@gmail.com> References: <20231129220225.6819-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="16329"; 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 Nov 29 23:04:39 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 1r8Sff-00042r-BL for guile-devel@m.gmane-mx.org; Wed, 29 Nov 2023 23:04:39 +0100 Original-Received: from localhost ([::1] helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1r8Se7-0001D9-7X; Wed, 29 Nov 2023 17:03:03 -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 1r8Se3-0001Br-DB for guile-devel@gnu.org; Wed, 29 Nov 2023 17:02:59 -0500 Original-Received: from mail-qv1-xf36.google.com ([2607:f8b0:4864:20::f36]) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1r8Sdy-0004EK-Je for guile-devel@gnu.org; Wed, 29 Nov 2023 17:02:59 -0500 Original-Received: by mail-qv1-xf36.google.com with SMTP id 6a1803df08f44-67a2661560dso1461906d6.0 for ; Wed, 29 Nov 2023 14:02:54 -0800 (PST) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gmail.com; s=20230601; t=1701295373; x=1701900173; 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=+tdM9MKD8NYYMFW+qfm2yNZDfFplNWqqamV8Ri5Fnlc=; b=M2fLi8RBGV+kAbkx+yNWRnjt06o7viYkwwMFtv08smEWW9NV3ceoFklArrDi5oFbfX Sm9OQbTt8AJcxVWl6QjsyQRIGAOnoJPedeljhw21i2mANTt5MvbSykXR/mvhL3D/QEpf WLvTlrlsjGiI823yyWu63VYOIruAjAwqRQxZtHP0R1Rm03sjHuaoZVR5rKfLBfunWq8Y gFOrFY/QF6ZMaQSnZ82JRqfi5bgV1bZ9vhHPomwZWKUtU7jb8nBlUKphaqN2WbFJc2kb 2xloKbBmaaLcQxNwNEx8xVSaVgNmam+E7uLlLwZxjoMHlNCmyc2lMaypSi2zPvA+Gxbz PHvA== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20230601; t=1701295373; x=1701900173; 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=+tdM9MKD8NYYMFW+qfm2yNZDfFplNWqqamV8Ri5Fnlc=; b=rJ25uJZD/uFNiqOhr9MFcjUOvvC/2IvFrS1D5Dh01Z5r/ci2xQISNDsTy4hmEGGgVG GZZSsZ2hDCPp2UE3rbrIwDVsAdc2J13/w2m3xB8GNOn73H5Sdz0acTX3pf1jqgG7naHQ ynet9DEWvH3OlxmFOx7SD3zp4DwoSHrE+WTjkE7IQfaSrpqanBZ/nsHdc6eYoxLqLSPi PiWva8us/rqOXRlwRu853zXnrTTcmPoO86QRHs98vZoduLDz3/UScu5WWuQrSg7b26Ga V3s9Lh8AA+xUePZkPufjbjFwo1DgvS9TkUTG9d7RFJEuciHIfj8TOeajH5KfeP3XbmAw HrsQ== X-Gm-Message-State: AOJu0Yyrjs15oTNistf7XfMK3C0cBp5azAOE5f332aMUSwYsFC4t4Rtp mak/jTE3W2GPVg9Zyn5KOx5avKuacrI= X-Google-Smtp-Source: AGHT+IGKTGD0R89HHIJ/QUnBFx7xXFHqH4Zcj6DVFX7MNmGndu+wC0Osvut1fxflkZoJAQaKFEmswQ== X-Received: by 2002:ad4:5f8d:0:b0:67a:2e8f:90cd with SMTP id jp13-20020ad45f8d000000b0067a2e8f90cdmr18901751qvb.37.1701295371657; Wed, 29 Nov 2023 14:02:51 -0800 (PST) Original-Received: from localhost.localdomain (dsl-158-174.b2b2c.ca. [66.158.158.174]) by smtp.gmail.com with ESMTPSA id g15-20020ad4510f000000b0067a2a0b44ddsm4644444qvp.44.2023.11.29.14.02.50 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Wed, 29 Nov 2023 14:02:51 -0800 (PST) X-Mailer: git-send-email 2.41.0 In-Reply-To: <20231129220225.6819-1-maxim.cournoyer@gmail.com> Received-SPF: pass client-ip=2607:f8b0:4864:20::f36; envelope-from=maxim.cournoyer@gmail.com; helo=mail-qv1-xf36.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:22157 Archived-At: This is not original work: it merely integrates and formats the work of Taylan Ulrich Bayırlı/Kammer into Guile, with a few adjustments to avoid warnings/fix missing imports. Thank you! * module/srfi/srfi-126.scm: New file. * test-suite/tests/srfi-126.test: New file. * test-suite/tests/srfi-126-test.scm: Likewise. * am/bootstrap.am (SOURCES): Register srfi-126 module. * test-suite/Makefile.am (SCM_TESTS): Register test. (EXTRA_DIST): Register test suite implementation. * doc/ref/srfi-modules.texi (SRFI Support): Document new module. * NEWS: Mention new interface. --- Changes in v5: - Update NEWS Changes in v4: - Mention Expat license of SRFI 126 in guile.tex copying section Changes in v3: - Rename SRFI-126 to SRFI 126 in text Changes in v2: - Remove extraneous (ice-9 hash-table) import - Rename SRFI-69 to SRFI 69, SRFI-125 to SRFI 125 in text NEWS | 3 + am/bootstrap.am | 1 + doc/ref/guile.texi | 25 +- doc/ref/srfi-modules.texi | 600 +++++++++++++++++++++++++++++ module/srfi/srfi-126.scm | 396 +++++++++++++++++++ test-suite/Makefile.am | 2 + test-suite/tests/srfi-126-test.scm | 289 ++++++++++++++ test-suite/tests/srfi-126.test | 49 +++ 8 files changed, 1364 insertions(+), 1 deletion(-) create mode 100644 module/srfi/srfi-126.scm create mode 100644 test-suite/tests/srfi-126-test.scm create mode 100644 test-suite/tests/srfi-126.test diff --git a/NEWS b/NEWS index e5cc3c7aa..31107a76d 100644 --- a/NEWS +++ b/NEWS @@ -21,6 +21,9 @@ definitely unused---this is notably the case for modules that are only used at macro-expansion time, such as (srfi srfi-26). In those cases, the compiler reports it as "possibly unused". +** Add (srfi 126), a hash tables library +** Add (srfi 128), a comparators library + * Bug fixes ** (ice-9 suspendable-ports) incorrect UTF-8 decoding diff --git a/am/bootstrap.am b/am/bootstrap.am index 68d4b3334..3586f0873 100644 --- a/am/bootstrap.am +++ b/am/bootstrap.am @@ -349,6 +349,7 @@ SOURCES = \ srfi/srfi-88.scm \ srfi/srfi-98.scm \ srfi/srfi-111.scm \ + srfi/srfi-126.scm \ srfi/srfi-171.scm \ srfi/srfi-171/gnu.scm \ srfi/srfi-171/meta.scm \ diff --git a/doc/ref/guile.texi b/doc/ref/guile.texi index 8414c3e2d..0540d2aab 100644 --- a/doc/ref/guile.texi +++ b/doc/ref/guile.texi @@ -23,8 +23,31 @@ any later version published by the Free Software Foundation; with no 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.'' -@end copying +Additionally, the documentation of the SRFI 126 module is adapted from +its specification text, which is made available under the following +Expat license: + +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. + +@end copying @c Notes @c diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi index 0cdf56923..8b3315180 100644 --- a/doc/ref/srfi-modules.texi +++ b/doc/ref/srfi-modules.texi @@ -2,6 +2,7 @@ @c This is part of the GNU Guile Reference Manual. @c Copyright (C) 1996, 1997, 2000-2004, 2006, 2007-2014, 2017, 2018, 2019, 2020 @c Free Software Foundation, Inc. +@c Copyright (C) 2015-2016 Taylan Ulrich Bayırlı/Kammer @c See the file guile.texi for copying conditions. @node SRFI Support @@ -64,6 +65,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 126:: R6RS-based hash tables. * SRFI-171:: Transducers @end menu @@ -5662,6 +5664,604 @@ Return the current contents of @var{box}. Set the contents of @var{box} to @var{value}. @end deffn +@node SRFI 126 +@subsection SRFI 126 R6RS-based hash tables +@cindex SRFI 126 +@cindex hash tables, r6rs-based + +@uref{http://srfi.schemers.org/srfi-126/srfi-126.html, SRFI 126} +provides hash tables API that takes the R6RS hash tables API as a basis +and makes backwards compatible additions such as support for weak hash +tables, external representation, API support for double hashing +implementations, and utility procedures. As an alternative to SRFI 125, +it builds on the R6RS hash tables API instead of SRFI 69, with only +fully backwards compatible additions such as weak and ephemeral hash +tables, an external representation, and API support for hashing +strategies that require a pair of hash functions. This SRFI does not +attempt to specify thread-safety because typical multi-threaded +use-cases will most likely involve locking more than just accesses and +mutations of hash tables. + +@noindent +The R6RS hash tables API is favored over SRFI 69 because the latter +contains a crucial flaw: exposing the hash functions for the @code{eq?} +and @code{eqv?} procedures is a hindrance for Scheme implementations +with a moving garbage collector. SRFI 125 works around this by allowing +the user-provided hash function passed to @code{make-hash-table} to be +ignored by the implementation, and allowing the +@code{hash-table-hash-function} procedure to return @code{#f} instead of +the hash function passed to @code{make-hash-table}. R6RS avoids the +issue by providing dedicated constructors for @code{eq?} and @code{eqv?} +based hash tables, and returning @code{#f} when their hash function is +queried. + +While the SRFI is based on the R6RS hash tables API instead of SRFI 69, +the provided utility procedures nevertheless make it relatively +straightforward to change code written for SRFI 69 to use the API +specified herein. The utility procedures provided by this SRFI in +addition to the R6RS API may be categorized as follows: + +@table @asis +@item Constructors +alist->eq-hashtable, alist->eqv-hashtable, alist->hashtable + +@item Access and mutation +hashtable-lookup, hashtable-intern! + +@item Copying +hashtable-empty-copy + +@item Key/value collections +hashtable-values, hashtable-key-list, hashtable-value-list, +hashtable-entry-lists + +@item Iteration +hashtable-walk, hashtable-update-all!, hashtable-prune!, +hashtable-merge!, hashtable-sum, hashtable-map->lset, hashtable-find + +@item Miscellaneous +hashtable-empty?, hashtable-pop!, hashtable-inc!, hashtable-dec! +@end table + +Additionally, this specification adheres to the R7RS rule of specifying +a single return value for procedures which don't have meaningful return +values. + +@menu +* SRFI 126 API:: +* SRFI 126 Constructors:: +* SRFI 126 Procedures:: +* SRFI 126 Inspection:: +* SRFI 126 Hash functions:: +@end menu + +@node SRFI 126 API +@subsubsection SRFI 126 API + +The @code{(srfi srfi-126)} library provides a set of operations on hash +tables. A hash table is of a disjoint type that associates keys with +values. Any object can be used as a key, provided a hash function or a +pair of hash functions, and a suitable equivalence function, are +available. A hash function is a procedure that maps keys to +non-negative exact integer objects. It is the programmer's +responsibility to ensure that the hash functions are compatible with the +equivalence function, which is a procedure that accepts two keys and +returns true if they are equivalent and @code{#f} otherwise. Standard +hash tables for arbitrary objects based on the @code{eq?} and +@code{eqv?} predicates (see R7RS section on “Equivalence predicates”) +are provided. Also, hash functions for arbitrary objects, strings, and +symbols are provided. + +Hash tables can store their key, value, or key and value weakly. +Storing an object weakly means that the storage location of the object +does not count towards the total storage locations in the program which +refer to the object, meaning the object can be reclaimed as soon as no +non-weak storage locations referring to the object remain. Weakly +stored objects referring to each other in a cycle will be reclaimed as +well if none of them are referred to from outside the cycle. When a +weakly stored object is reclaimed, associations in the hash table which +have the object as their key or value are deleted. + +Hash tables can also store their key and value in ephemeral storage +pairs. The objects in an ephemeral storage pair are stored weakly, but +both protected from reclamation as long as there remain non-weak +references to the first object from outside the ephemeral storage pair. +In particular, an @code{ephemeral-key} hash table (where the keys are +the first objects in the ephemeral storage pairs), with an association +mapping an element of a vector to the vector itself, may delete said +association when no non-weak references remain to the vector nor its +element in the rest of the program. If it were a @code{weak-key} hash +table, the reference to the key from within the vector would cyclically +protect the key and value from reclamation, even when no non-weak +references to the key and value remained from outside the hash table. +At the absence of such references between the key and value, +@code{ephemeral-key} and @code{ephemeral-value} hash tables behave +effectively equivalent to @code{weak-key} and @code{weak-value} hash +tables. + +@code{ephemeral-key-and-value} hash tables use a pair of ephemeral +storage pairs for each association: one where the key is the first +object and one where the value is. This means that the key and value +are protected from reclamation until no references remain to neither the +key nor value from outside the hash table. In contrast, a +@code{weak-key-and-value} hash table will delete an association as soon +as either the key or value is reclaimed. + +This document uses the @var{hashtable} parameter name for arguments that +must be hash tables, and the @var{key} parameter name for arguments that +must be hash table keys. + +@node SRFI 126 Constructors +@subsubsection SRFI 126 Constructors + +@deffn {Scheme Procedure} make-eq-hashtable +@deffnx {Scheme Procedure} make-eq-hashtable capacity +@deffnx {Scheme Procedure} make-eq-hashtable capacity weakness + +Return a newly allocated mutable hash table that accepts arbitrary +objects as keys, and compares those keys with @code{eq?}. If the +@var{capacity} argument is provided and not @code{#f}, it must be an +exact non-negative integer and the initial capacity of the hash table is +set to approximately @var{capacity} elements. The @var{weakness} +argument, if provided, must be one of: @code{#f}, @code{weak-key}, +@code{weak-value}, @code{weak-key-and-value}, @code{ephemeral-key}, +@code{ephemeral-value}, and @code{ephemeral-key-and-value}, and +determines the weakness or ephemeral status for the keys and values in +the hash table. +@end deffn + +@deffn {Scheme Procedure} make-eqv-hashtable +@deffnx {Scheme Procedure} make-eqv-hashtable capacity +@deffnx {Scheme Procedure} make-eqv-hashtable capacity weakness + +Return a newly allocated mutable hash table that accepts arbitrary +objects as keys, and compares those keys with @code{eqv?}. The +semantics of the optional arguments are as in @code{make-eq-hashtable}. +@end deffn + +@deffn {Scheme Procedure} make-hashtable hash equiv +@deffnx {Scheme Procedure} make-hashtable hash equiv capacity +@deffnx {Scheme Procedure} make-hashtable hash equiv capacity weakness + +If @var{hash} is @code{#f} and @var{equiv} is the @code{eq?} procedure, +the semantics of @code{make-eq-hashtable} apply to the rest of the +arguments. If @var{hash} is @code{#f} and @var{equiv} is the +@code{eqv?} procedure, the semantics of @code{make-eqv-hashtable} apply +to the rest of the arguments. + +Otherwise, @var{hash} must be a pair of hash functions or a hash +function, and @var{equiv} must be a procedure. @var{equiv} should +accept two keys as arguments and return a single value. None of the +procedures should mutate the hash table returned by +@code{make-hashtable}. The @code{make-hashtable} procedure returns a +newly allocated mutable hash table using the function(s) specified by +@var{hash} as its hash function(s), and @var{equiv} as the equivalence +function used to compare keys. The semantics of the remaining arguments +are as in @code{make-eq-hashtable} and @code{make-eqv-hashtable}. + +The @var{hash} functions and @var{equiv} should behave like pure +functions on the domain of keys. For example, the @code{string-hash} +and @code{string=?} procedures are permissible only if all keys are +strings and the contents of those strings are never changed so long as +any of them continues to serve as a key in the hash table. Furthermore, +any pair of keys for which @var{equiv} returns true should be hashed to +the same exact integer objects by the given @var{hash} function(s). + +@quotation Note +Hash tables are allowed to cache the results of calling a hash function +and equivalence function, so programs cannot rely on a hash function +being called for every lookup or update. Furthermore any hash table +operation may call a hash function more than once. +@end quotation +@end deffn + +@deffn {Scheme Procedure} alist->eq-hashtable alist +@deffnx {Scheme Procedure} alist->eq-hashtable capacity alist +@deffnx {Scheme Procedure} alist->eq-hashtable capacity weakness alist + +The semantics of this procedure can be described as: + +@lisp +(let ((ht (make-eq-hashtable @var{capacity} @var{weakness}))) + (for-each (lambda (entry) + (hashtable-set! ht (car entry) (cdr entry))) + (reverse alist)) + ht) +@end lisp + +where omission of the @var{capacity} and/or @var{weakness} arguments +corresponds to their omission in the call to @code{make-eq-hashtable}. +@end deffn + +@deffn {Scheme Procedure} alist->eqv-hashtable alist +@deffnx {Scheme Procedure} alist->eqv-hashtable capacity alist +@deffnx {Scheme Procedure} alist->eqv-hashtable capacity weakness alist + +This procedure is equivalent to @code{alist->eq-hashtable} except that +@code{make-eqv-hashtable} is used to construct the hash table. +@end deffn + +@deffn {Scheme Procedure} alist->hashtable hash equiv alist +@deffnx {Scheme Procedure} alist->hashtable hash equiv capacity alist +@deffnx {Scheme Procedure} alist->hashtable hash equiv capacity weakness alist + +This procedure is equivalent to @code{alist->eq-hashtable} except that +@code{make-hashtable} is used to construct the hash table, with the +given @var{hash} and @var{equiv} arguments. +@end deffn + +@deffn {Scheme Syntax} weakness weakness-symbol + +The @var{weakness-symbol} must correspond to one of the non-#f values +accepted for the @var{weakness} argument of the constructor procedures, +that is, @code{'weak-key}, @code{'weak-value}, +@code{'weak-key-and-value}, @code{'ephemeral-key}, +@code{'ephemeral-value}, or @code{'ephemeral-key-and-value}. Given such +a symbol, it is returned as a datum. Passing any other argument is an +error. +@end deffn + +@node SRFI 126 Procedures +@subsubsection SRFI 126 Procedures + +@deffn {Scheme Procedure} hashtable? obj + +Return @code{#t} if @var{obj} is a hash table, @code{#f} otherwise. +@end deffn + +@deffn {Scheme Procedure} hashtable-size hashtable + +Return the number of keys contained in @var{hashtable} as an exact +integer object. +@end deffn + +@deffn {Scheme Procedure} hashtable-ref hashtable key +@deffnx {Scheme Procedure} hashtable-ref hashtable key default + +Return the value in @var{hashtable} associated with @var{key}. If +@var{hashtable} does not contain an association for key, @var{default} +is returned. If @var{hashtable} does not contain an association for key +and the @var{default} argument is not provided, an error is signaled. +@end deffn + +@deffn {Scheme Procedure} hashtable-set! hashtable key obj + +Change @var{hashtable} to associate @var{key} with @var{obj}, adding a +new association or replacing any existing association for @var{key}, and +return an unspecified value. +@end deffn + +@deffn {Scheme Procedure} hashtable-delete! hashtable key + +Remove any association for @var{key} within @var{hashtable} and return +an unspecified value. +@end deffn + +@deffn {Scheme Procedure} hashtable-contains? hashtable key + +Return @code{#t} if @var{hashtable} contains an association for +@var{key}, @code{#f} otherwise. +@end deffn + +@deffn {Scheme Procedure} hashtable-lookup hashtable key + +Return two values: the value in @var{hashtable} associated with +@var{key} or an unspecified value if there is none, and a boolean +indicating whether an association was found. +@end deffn + +@deffn {Scheme Procedure} hashtable-update! hashtable key proc +@deffnx {Scheme Procedure} hashtable-update! hashtable key proc default + +@var{proc} should accept one argument, should return a single value, and +should not mutate hashtable. The @code{hashtable-update!} procedure +applies @var{proc} to the value in @var{hashtable} associated with +@var{key}, or to @var{default} if @var{hashtable} does not contain an +association for @var{key}. The @var{hashtable} is then changed to +associate @var{key} with the value returned by @var{proc}. If +@var{hashtable} does not contain an association for @var{key} and the +@var{default} argument is not provided, an error should be signaled. +@var{hashtable-update!} returns the value of the new association for +@var{key} in @var{hashtable}. +@end deffn + +@deffn {Scheme Procedure} hashtable-intern! hashtable key default-proc + +@var{default-proc} should accept zero arguments, should return a single +value, and should not mutate @var{hashtable}. The +@code{hashtable-intern!} procedure returns the association for key in +@var{hashtable} if there is one, otherwise it calls @var{default-proc} +with zero arguments, associates its return value with @var{key} in +@var{hashtable}, and returns that value. +@end deffn + +@deffn {Scheme Procedure} hashtable-copy hashtable +@deffnx {Scheme Procedure} hashtable-copy hashtable mutable +@deffnx {Scheme Procedure} hashtable-copy hashtable mutable weakness + +Return a copy of @var{hashtable}. If the @var{mutable} argument is +provided and is true, the returned @var{hashtable} is mutable; otherwise +it is immutable. If the optional @var{weakness} argument is provided, +it determines the weakness of the copy, otherwise the weakness attribute +of @var{hashtable} is used. +@end deffn + +@deffn {Scheme Procedure} hashtable-clear! hashtable +@deffnx {Scheme Procedure} hashtable-clear! hashtable capacity + +Remove all associations from @var{hashtable} and return an unspecified +value. If @var{capacity} is provided and not @code{#f}, it must be an +exact non-negative integer and the current capacity of the +@var{hashtable} is reset to approximately @var{capacity} elements. +@end deffn + +@deffn {Scheme Procedure} hashtable-empty-copy hashtable +@deffnx {Scheme Procedure} hashtable-empty-copy hashtable capacity + +Return a newly allocated mutable @var{hashtable} that has the same hash +and equivalence functions and weakness attribute as @var{hashtable}. +The @var{capacity} argument may be @code{#t} to set the initial capacity +of the copy to approximately @samp{(hashtable-size @var{hashtable})} +elements; otherwise the semantics of @code{make-eq-hashtable} apply to +the @var{capacity} argument. +@end deffn + +@deffn {Scheme Procedure} hashtable-keys hashtable + +Return a vector of all keys in @var{hashtable}. The order of the vector +is unspecified. +@end deffn + +@deffn {Scheme Procedure} hashtable-values hashtable + +Return a vector of all values in @var{hashtable}. The order of the +vector is unspecified, and is not guaranteed to match the order of keys +in the result of @code{hashtable-keys}. +@end deffn + +@deffn {Scheme Procedure} hashtable-entries hashtable + +Return two values, a vector of the keys in @var{hashtable}, and a vector +of the corresponding values. +@end deffn + +@deffn {Scheme Procedure} hashtable-key-list hashtable + +Return a list of all keys in @var{hashtable}. The order of the list is +unspecified. +@end deffn + +@deffn {Scheme Procedure} hashtable-value-list hashtable + +Return a list of all values in @var{hashtable}. The order of the list +is unspecified, and is not guaranteed to match the order of keys in the +result of @code{hashtable-key-list}. +@end deffn + +@deffn {Scheme Procedure} hashtable-entry-lists hashtable + +Return two values, a list of the keys in @var{hashtable}, and a list of +the corresponding values. +@end deffn + +@deffn {Scheme Procedure} hashtable-walk hashtable proc + +@var{proc} should accept two arguments, and should not mutate +@var{hashtable}. The @code{hashtable-walk} procedure applies @var{proc} +once for every association in @var{hashtable}, passing it the key and +value as arguments. The order in which @var{proc} is applied to the +associations is unspecified. Return values of @var{proc} are ignored. +@code{hashtable-walk} returns an unspecified value. +@end deffn + +@deffn {Scheme Procedure} hashtable-update-all! hashtable proc + +@var{proc} should accept two arguments, should return a single value, +and should not mutate @var{hashtable}. The @code{hashtable-update-all!} +procedure applies @var{proc} once for every association in +@var{hashtable}, passing it the key and value as arguments, and changes +the value of the association to the return value of @var{proc}. The +order in which @var{proc} is applied to the associations is unspecified. +@code{hashtable-update-all!} returns an unspecified value. +@end deffn + +@deffn {Scheme Procedure} hashtable-prune! hashtable proc + +@var{proc} should accept two arguments, should return a single value, +and should not mutate @var{hashtable}. The @code{hashtable-prune!} +procedure applies @var{proc} once for every association in +@var{hashtable}, passing it the key and value as arguments, and deletes +the association if @var{proc} returns a true value. The order in which +@var{proc} is applied to the associations is unspecified. +@code{hashtable-prune!} returns an unspecified value. +@end deffn + +@deffn {Scheme Procedure} hashtable-merge! hashtable-dest hashtable-source + +Effectively equivalent to: + +@lisp +(begin + (hashtable-walk @var{hashtable-source} + (lambda (key value) + (hashtable-set! @var{hashtable-dest} key value))) + hashtable-dest) +@end lisp +@end deffn + +@deffn {Scheme Procedure} hashtable-sum hashtable init proc + +@var{proc} should accept three arguments, should return a single value, +and should not mutate @var{hashtable}. The @code{hashtable-sum} +procedure accumulates a result by applying @var{proc} once for every +association in @var{hashtable}, passing it as arguments: the key, the +value, and the result of the previous application or @var{init} at the +first application. The order in which @var{proc} is applied to the +associations is unspecified. +@end deffn + +@deffn {Scheme Procedure} hashtable-map->lset hashtable proc + +@var{proc} should accept two arguments, should return a single value, +and should not mutate @var{hashtable}. The @code{hashtable-map->lset} +procedure applies @var{proc} once for every association in +@var{hashtable}, passing it the key and value as arguments, and +accumulates the returned values into a list. The order in which +@var{proc} is applied to the associations, and the order of the results +in the returned list, are unspecified. + +@quotation note +This procedure can trivially imitate @code{hashtable->alist}: +@samp{(hashtable-map->lset @var{hashtable} cons)}. +@end quotation + +@quotation warning +Since the order of the results is unspecified, the returned list should +be treated as a set or multi-set. Relying on the order of results will +produce unpredictable programs. +@end quotation +@end deffn + +@deffn {Scheme Procedure} hashtable-find hashtable proc + +@var{proc} should accept two arguments, should return a single value, +and should not mutate @var{hashtable}. The @code{hashtable-find} +procedure applies @var{proc} to associations in @var{hashtable} in an +unspecified order until one of the applications returns a true value or +the associations are exhausted. Three values are returned: the key and +value of the matching association or two unspecified values if none +matched, and a boolean indicating whether any association matched. +@end deffn + +@deffn {Scheme Procedure} hashtable-empty? hashtable + +Effectively equivalent to @samp{(zero? (hashtable-size @var{hashtable}))}. +@end deffn + +@deffn {Scheme Procedure} hashtable-pop! hashtable + +Effectively equivalent to: + +@lisp +(let-values (((key value found?) + (hashtable-find @var{hashtable} (lambda (k v) #t)))) + (when (not found?) + (error)) + (hashtable-delete! @var{hashtable} key) + (values key value)) +@end lisp +@end deffn + +@deffn {Scheme Procedure} hashtable-inc! hashtable key +@deffnx {Scheme Procedure} hashtable-inc! hashtable key number + +Effectively equivalent to: + +@lisp +(hashtable-update! @var{hashtable} @var{key} (lambda (v) (+ v @var{number})) 0) +@end lisp + +where @var{number} is 1 when not provided. +@end deffn + +@deffn {Scheme Procedure} hashtable-dec! hashtable key +@deffnx {Scheme Procedure} hashtable-dec! hashtable key number + +Effectively equivalent to: + +@lisp +(hashtable-update! @var{hashtable} @var{key} (lambda (v) (- v @var{number})) 0) +@end lisp + +where @var{number} is 1 when not provided. +@end deffn + +@node SRFI 126 Inspection +@subsubsection SRFI 126 Inspection + +@deffn {Scheme Procedure} hashtable-equivalence-function hashtable + +Return the equivalence function used by @var{hashtable} to compare +keys. For hash tables created with @code{make-eq-hashtable} and +@code{make-eqv-hashtable}, returns @code{eq?} and @code{eqv?} +respectively. +@end deffn + +@deffn {Scheme Procedure} hashtable-hash-function hashtable + +Return the hash function(s) used by @var{hashtable}, that is, either a +procedure, or a pair of procedures. For hash tables created by +@code{make-eq-hashtable} or @code{make-eqv-hashtable}, @code{#f} is +returned. +@end deffn + +@deffn {Scheme Procedure} hashtable-weakness hashtable + +Return the weakness attribute of @var{hashtable}. The same values that +are accepted as the weakness argument in the constructor procedures are +returned. This procedure may expose the fact that @code{weak-key} and +@code{weak-value} hash tables are implemented as @var{ephemeral-key} and +@var{ephemeral-value} hash tables, returning symbols indicating the +latter even when the former were used to construct the hash table. +@end deffn + +@deffn {Scheme Procedure} hashtable-mutable? hashtable + +Return @code{#t} if @var{hashtable} is mutable, otherwise @code{#f}. +@end deffn + +@node SRFI 126 Hash functions +@subsubsection SRFI 126 Hash functions + +The @code{equal-hash}, @code{string-hash}, and @code{string-ci-hash} +procedures of this section are acceptable as the hash functions of a +hash table only if the keys on which they are called are not mutated +while they remain in use as keys in the hash table. + +An implementation may initialize its hash functions with a random salt +value at program startup, meaning they are not guaranteed to return the +same values for the same inputs across multiple runs of a program. If +however the environment variable @env{SRFI_126_HASH_SEED} is set to a +non-empty string before program startup, then the salt value is derived +from that string in a deterministic manner. + +@deffn {Scheme Syntax} hash-salt + +Expand to a form evaluating to an exact non-negative integer that lies +within the fixnum range of the implementation. The value the expanded +form evaluates to remains constant throughout the execution of the +program. It is random for every run of the program, except when the +environment variable @env{SRFI_126_HASH_SEED} is set to a non-empty +string before program startup, in which case it is derived from the +value of that environment variable in a deterministic manner. +@end deffn + +@deffn {Scheme Procedure} equal-hash obj + +Return an integer hash value for @var{obj}, based on its structure and +current contents. This hash function is suitable for use with +@code{equal?} as an equivalence function. +@end deffn + +@deffn {Scheme Procedure} string-hash string + +Return an integer hash value for @var{string}, based on its current +contents. This hash function is suitable for use with @code{string=?} +as an equivalence function. +@end deffn + +@deffn {Scheme Procedure} string-ci-hash string + +Return an integer hash value for @var{string} based on its current +contents, ignoring case. This hash function is suitable for use with +@code{string-ci=?} as an equivalence function. +@end deffn + +@deffn {Scheme Procedure} symbol-hash symbol + +Return an integer hash value for @var{symbol}. +@end deffn + @node SRFI-171 @subsection Transducers @cindex SRFI-171 diff --git a/module/srfi/srfi-126.scm b/module/srfi/srfi-126.scm new file mode 100644 index 000000000..ce91fd158 --- /dev/null +++ b/module/srfi/srfi-126.scm @@ -0,0 +1,396 @@ +;;; srfi-126.scm -- SRFI 126 - R6RS-based hashtables. + +;; Copyright (C) Taylan Ulrich Bayırlı/Kammer (2015, 2016). 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 (srfi srfi-126) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-9 gnu) + #:use-module (srfi srfi-11) + #:use-module (ice-9 control) + #:use-module ((rnrs hashtables) #:select (equal-hash + string-hash + string-ci-hash)) + #:export (make-eq-hashtable + make-eqv-hashtable make-hashtable + alist->eq-hashtable alist->eqv-hashtable alist->hashtable + weakness + hashtable? hashtable-size + hashtable-ref hashtable-set! hashtable-delete! hashtable-contains? + hashtable-lookup hashtable-update! hashtable-intern! + hashtable-copy hashtable-clear! hashtable-empty-copy + hashtable-keys hashtable-values hashtable-entries + hashtable-key-list hashtable-value-list hashtable-entry-lists + hashtable-walk hashtable-update-all! hashtable-prune! + hashtable-merge! + hashtable-sum hashtable-map->lset hashtable-find + hashtable-empty? hashtable-pop! hashtable-inc! hashtable-dec! + hashtable-equivalence-function hashtable-hash-function + hashtable-weakness hashtable-mutable? + hash-salt) + #:re-export (equal-hash string-hash string-ci-hash)) + +(define-record-type + (%make-hashtable %table %hash %assoc hash equiv weakness mutable) + hashtable? + (%table %hashtable-table) + (%hash %hashtable-hash) + (%assoc %hashtable-assoc) + (hash hashtable-hash-function) + (equiv hashtable-equivalence-function) + (weakness hashtable-weakness) + (mutable hashtable-mutable? %hashtable-set-mutable!)) + +(define nil (cons #f #f)) +(define (nil? obj) (eq? obj nil)) + +(define (make-table capacity weakness) + (let ((capacity (or capacity 32))) + (case weakness + ((#f) (make-hash-table capacity)) + ((weak-key) (make-weak-key-hash-table capacity)) + ((weak-value) (make-weak-value-hash-table capacity)) + ((weak-key-and-value) (make-doubly-weak-hash-table capacity)) + (else (error "Hashtable weakness not supported." weakness))))) + +(define* (make-eq-hashtable #:optional capacity weakness) + (let ((table (make-table capacity weakness))) + (%make-hashtable table hashq assq #f eq? weakness #t))) + +(define* (make-eqv-hashtable #:optional capacity weakness) + (let ((table (make-table capacity weakness))) + (%make-hashtable table hashv assv #f eqv? weakness #t))) + +(define* (make-hashtable hash equiv #:optional capacity weakness) + (cond + ((and (not hash) (eq? equiv eq?)) + (make-eq-hashtable capacity weakness)) + ((and (not hash) (eq? equiv eqv?)) + (make-eqv-hashtable capacity weakness)) + (else + (let* ((table (make-table capacity weakness)) + (hash (if (pair? hash) + (car hash) + hash)) + (%hash (lambda (obj bound) + (modulo (hash obj) bound))) + (assoc (lambda (key alist) + (find (lambda (entry) + (equiv (car entry) key)) + alist)))) + (%make-hashtable table %hash assoc hash equiv weakness #t))))) + +(define (alist->eq-hashtable . args) + (apply alist->hashtable #f eq? args)) + +(define (alist->eqv-hashtable . args) + (apply alist->hashtable #f eqv? args)) + +(define alist->hashtable + (case-lambda + ((hash equiv alist) + (alist->hashtable hash equiv #f #f alist)) + ((hash equiv capacity alist) + (alist->hashtable hash equiv capacity #f alist)) + ((hash equiv capacity weakness alist) + (let ((ht (make-hashtable hash equiv capacity weakness))) + (for-each (lambda (entry) + (hashtable-set! ht (car entry) (cdr entry))) + (reverse alist)) + ht)))) + +(define-syntax weakness + (lambda (stx) + (syntax-case stx () + ((_ ) + (let ((sym (syntax->datum #'))) + (case sym + ((weak-key weak-value weak-key-and-value ephemeral-key + ephemeral-value ephemeral-key-and-value) + #''sym) + (else + (error "Bad weakness symbol." sym)))))))) + +(define (hashtable-size ht) + (hash-count (const #t) (%hashtable-table ht))) + +(define* (%hashtable-ref ht key default) + (hashx-ref (%hashtable-hash ht) (%hashtable-assoc ht) + (%hashtable-table ht) key default)) + +(define* (hashtable-ref ht key #:optional (default nil)) + (let ((val (%hashtable-ref ht key default))) + (if (nil? val) + (error "No association for key in hashtable." key ht) + val))) + +(define (assert-mutable ht) + (when (not (hashtable-mutable? ht)) + (error "Hashtable is immutable." ht))) + +(define (hashtable-set! ht key value) + (assert-mutable ht) + (hashx-set! (%hashtable-hash ht) (%hashtable-assoc ht) + (%hashtable-table ht) key value) + *unspecified*) + +(define (hashtable-delete! ht key) + (assert-mutable ht) + (hashx-remove! (%hashtable-hash ht) (%hashtable-assoc ht) + (%hashtable-table ht) key) + *unspecified*) + +(define (hashtable-contains? ht key) + (not (nil? (%hashtable-ref ht key nil)))) + +(define (hashtable-lookup ht key) + (let ((val (%hashtable-ref ht key nil))) + (if (nil? val) + (values #f #f) + (values val #t)))) + +(define* (hashtable-update! ht key updater #:optional (default nil)) + (assert-mutable ht) + (let ((handle (hashx-create-handle! + (%hashtable-hash ht) (%hashtable-assoc ht) + (%hashtable-table ht) key nil))) + (if (eq? nil (cdr handle)) + (if (nil? default) + (error "No association for key in hashtable." key ht) + (set-cdr! handle (updater default))) + (set-cdr! handle (updater (cdr handle)))) + (cdr handle))) + +(define (hashtable-intern! ht key default-proc) + (assert-mutable ht) + (let ((handle (hashx-create-handle! + (%hashtable-hash ht) (%hashtable-assoc ht) + (%hashtable-table ht) key nil))) + (when (nil? (cdr handle)) + (set-cdr! handle (default-proc))) + (cdr handle))) + +(define* (hashtable-copy ht #:optional mutable weakness) + (let ((copy (hashtable-empty-copy ht (hashtable-size ht) weakness))) + (hashtable-walk ht + (lambda (k v) + (hashtable-set! copy k v))) + (%hashtable-set-mutable! copy mutable) + copy)) + +(define* (hashtable-clear! ht #:optional _capacity) + (assert-mutable ht) + (hash-clear! (%hashtable-table ht)) + *unspecified*) + +(define* (hashtable-empty-copy ht #:optional capacity weakness) + (make-hashtable (hashtable-hash-function ht) + (hashtable-equivalence-function ht) + (case capacity + ((#f) #f) + ((#t) (hashtable-size ht)) + (else capacity)) + (or weakness (hashtable-weakness ht)))) + +(define (hashtable-keys ht) + (let ((keys (make-vector (hashtable-size ht)))) + (hashtable-sum ht 0 + (lambda (k v i) + (vector-set! keys i k) + (+ i 1))) + keys)) + +(define (hashtable-values ht) + (let ((vals (make-vector (hashtable-size ht)))) + (hashtable-sum ht 0 + (lambda (k v i) + (vector-set! vals i v) + (+ i 1))) + vals)) + +(define (hashtable-entries ht) + (let ((keys (make-vector (hashtable-size ht))) + (vals (make-vector (hashtable-size ht)))) + (hashtable-sum ht 0 + (lambda (k v i) + (vector-set! keys i k) + (vector-set! vals i v) + (+ i 1))) + (values keys vals))) + +(define (hashtable-key-list ht) + (hashtable-map->lset ht (lambda (k v) k))) + +(define (hashtable-value-list ht) + (hashtable-map->lset ht (lambda (k v) v))) + +(define (hashtable-entry-lists ht) + (let ((keys&vals (cons '() '()))) + (hashtable-walk ht + (lambda (k v) + (set-car! keys&vals (cons k (car keys&vals))) + (set-cdr! keys&vals (cons v (cdr keys&vals))))) + (car+cdr keys&vals))) + +(define (hashtable-walk ht proc) + (hash-for-each proc (%hashtable-table ht))) + +(define (hashtable-update-all! ht proc) + (assert-mutable ht) + (hash-for-each-handle + (lambda (handle) + (set-cdr! handle (proc (car handle) (cdr handle)))) + (%hashtable-table ht))) + +(define (hashtable-prune! ht pred) + (assert-mutable ht) + (let ((keys (hashtable-sum ht '() + (lambda (k v keys-to-delete) + (if (pred k v) + (cons k keys-to-delete) + keys-to-delete))))) + (for-each (lambda (k) + (hashtable-delete! ht k)) + keys))) + +(define (hashtable-merge! ht-dest ht-src) + (assert-mutable ht-dest) + (hashtable-walk ht-src + (lambda (k v) + (hashtable-set! ht-dest k v))) + ht-dest) + +(define (hashtable-sum ht init proc) + (hash-fold proc init (%hashtable-table ht))) + +(define (hashtable-map->lset ht proc) + (hash-map->list proc (%hashtable-table ht))) + +(define (hashtable-find ht pred) + (let/ec return + (hashtable-walk ht + (lambda (k v) + (when (pred k v) + (return k v #t)))) + (return #f #f #f))) + +(define (hashtable-empty? ht) + (zero? (hashtable-size ht))) + +(define (hashtable-pop! ht) + (assert-mutable ht) + (when (hashtable-empty? ht) + (error "Cannot pop from empty hashtable." ht)) + (let-values (((k v found?) (hashtable-find ht (const #t)))) + (hashtable-delete! ht k) + (values k v))) + +(define* (hashtable-inc! ht k #:optional (x 1)) + (assert-mutable ht) + (hashtable-update! ht k (lambda (v) (+ v x)) 0)) + +(define* (hashtable-dec! ht k #:optional (x 1)) + (assert-mutable ht) + (hashtable-update! ht k (lambda (v) (- v x)) 0)) + +(define (hash-salt) 0) + +(set-record-type-printer! + + (lambda (ht port) + (with-output-to-port port + (lambda () + (let ((equal-hash (@ (rnrs hashtables) equal-hash)) + (string-hash (@ (rnrs hashtables) string-hash)) + (string-ci-hash (@ (rnrs hashtables) string-ci-hash)) + (symbol-hash (@ (rnrs hashtables) symbol-hash)) + (hash (hashtable-hash-function ht)) + (equiv (hashtable-equivalence-function ht)) + (alist (hashtable-map->lset ht cons))) + (cond + ((and (not hash) (eq? equiv eq?)) + (display "#hasheq") + (display alist)) + ((and (not hash) (eq? equiv eqv?)) + (display "#hasheqv") + (display alist)) + (else + (display "#hash") + (cond + ((and (eq? hash (@ (rnrs hashtables) equal-hash)) (eq? equiv equal?)) + (display alist)) + ((and (eq? hash (@ (rnrs hashtables) string-hash)) (eq? equiv string=?)) + (display (cons 'string alist))) + ((and (eq? hash string-ci-hash) (eq? equiv string-ci=?)) + (display (cons 'string-ci alist))) + ((and (eq? hash symbol-hash) (eq? equiv eq?)) + (display (cons 'symbol alist))) + (else + (display (cons 'custom alist))))))))))) + +(read-hash-extend + #\h + (lambda (char port) + (with-input-from-port port + (lambda () + (let ((equal-hash (@ (rnrs hashtables) equal-hash)) + (string-hash (@ (rnrs hashtables) string-hash)) + (string-ci-hash (@ (rnrs hashtables) string-ci-hash)) + (symbol-hash (@ (rnrs hashtables) symbol-hash)) + (type (string-append "h" (symbol->string (read)))) + (alist (read))) + (cond + ((string=? type "hasheq") + (alist->eq-hashtable alist)) + ((string=? type "hasheqv") + (alist->eqv-hashtable alist)) + (else + (when (not (string=? type "hash")) + (error "Unrecognized hash type." type)) + (let* ((has-tag? (symbol? (car alist))) + (subtype (if has-tag? + (car alist) + "equal")) + (alist (if has-tag? + (cdr alist) + alist))) + (cond + ((string=? subtype "equal") + (alist->hashtable equal-hash equal? alist)) + ((string=? subtype "string") + (alist->hashtable string-hash string=? alist)) + ((string=? subtype "string-ci") + (alist->hashtable string-ci-hash string-ci=? alist)) + ((string=? subtype "symbol") + (alist->hashtable symbol-hash eq? alist)) + (else + (error "Unrecognized hash subtype." subtype))))))))))) + +;; Local Variables: +;; eval: (put 'hashtable-walk 'scheme-indent-function 1) +;; eval: (put 'hashtable-update-all! 'scheme-indent-function 1) +;; eval: (put 'hashtable-prune! 'scheme-indent-function 1) +;; eval: (put 'hashtable-sum 'scheme-indent-function 2) +;; eval: (put 'hashtable-map->lset 'scheme-indent-function 1) +;; eval: (put 'hashtable-find 'scheme-indent-function 1) +;; End: diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am index 81e63bce2..eaa5e1fdb 100644 --- a/test-suite/Makefile.am +++ b/test-suite/Makefile.am @@ -162,6 +162,7 @@ SCM_TESTS = tests/00-initial-env.test \ tests/srfi-98.test \ tests/srfi-105.test \ tests/srfi-111.test \ + tests/srfi-126.test \ tests/srfi-171.test \ tests/srfi-4.test \ tests/srfi-9.test \ @@ -208,6 +209,7 @@ EXTRA_DIST = \ $(SCM_TESTS) \ tests/rnrs-test-a.scm \ tests/srfi-64-test.scm \ + tests/srfi-126-test.scm \ ChangeLog-2008 diff --git a/test-suite/tests/srfi-126-test.scm b/test-suite/tests/srfi-126-test.scm new file mode 100644 index 000000000..25ba5ae91 --- /dev/null +++ b/test-suite/tests/srfi-126-test.scm @@ -0,0 +1,289 @@ +;; Copyright (C) Taylan Ulrich Bayırlı/Kammer (2015, 2016). 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 doesn't test weakness, external representation, and quasiquote. + +(test-begin "SRFI-126") + +(test-group "constructors & inspection" + (test-group "eq" + (let ((tables (list (make-eq-hashtable) + (make-eq-hashtable 10) + (make-eq-hashtable #f #f) + (make-hashtable #f eq?) + (alist->eq-hashtable '((a . b) (c . d))) + (alist->eq-hashtable 10 '((a . b) (c . d))) + (alist->eq-hashtable #f #f '((a . b) (c . d)))))) + (do ((tables tables (cdr tables)) + (i 0 (+ i 1))) + ((null? tables)) + (let ((table (car tables)) + (label (number->string i))) + (test-assert label (hashtable? table)) + (test-eq label #f (hashtable-hash-function table)) + (test-eq label eq? (hashtable-equivalence-function table)) + (test-eq label #f (hashtable-weakness table)) + (test-assert label (hashtable-mutable? table)))))) + (test-group "eqv" + (let ((tables (list (make-eqv-hashtable) + (make-eqv-hashtable 10) + (make-eqv-hashtable #f #f) + (make-hashtable #f eqv?) + (alist->eqv-hashtable '((a . b) (c . d))) + (alist->eqv-hashtable 10 '((a . b) (c . d))) + (alist->eqv-hashtable #f #f '((a . b) (c . d)))))) + (do ((tables tables (cdr tables)) + (i 0 (+ i 1))) + ((null? tables)) + (let ((table (car tables)) + (label (number->string i))) + (test-assert label (hashtable? table)) + (test-eq label #f (hashtable-hash-function table)) + (test-eq label eqv? (hashtable-equivalence-function table)) + (test-eq label #f (hashtable-weakness table)) + (test-assert label (hashtable-mutable? table)))))) + (test-group "equal" + (let ((tables (list (make-hashtable equal-hash equal?) + (make-hashtable equal-hash equal? 10) + (make-hashtable equal-hash equal? #f #f) + (alist->hashtable equal-hash equal? + '((a . b) (c . d))) + (alist->hashtable equal-hash equal? 10 + '((a . b) (c . d))) + (alist->hashtable equal-hash equal? #f #f + '((a . b) (c . d)))))) + (do ((tables tables (cdr tables)) + (i 0 (+ i 1))) + ((null? tables)) + (let ((table (car tables)) + (label (number->string i))) + (test-assert label (hashtable? table)) + (test-eq label equal-hash (hashtable-hash-function table)) + (test-eq label equal? (hashtable-equivalence-function table)) + (test-eq label #f (hashtable-weakness table)) + (test-assert label (hashtable-mutable? table)))) + (let ((table (make-hashtable (cons equal-hash equal-hash) equal?))) + (let ((hash (hashtable-hash-function table))) + (test-assert (or (eq? equal-hash hash) + (and (eq? equal-hash (car hash)) + (eq? equal-hash (cdr hash))))))))) + (test-group "alist" + (let ((tables (list (alist->eq-hashtable '((a . b) (a . c))) + (alist->eqv-hashtable '((a . b) (a . c))) + (alist->hashtable equal-hash equal? + '((a . b) (a . c)))))) + (do ((tables tables (cdr tables)) + (i 0 (+ i 1))) + ((null? tables)) + (let ((table (car tables)) + (label (number->string i))) + (test-eq label 'b (hashtable-ref table 'a))))))) + +(test-group "procedures" + (test-group "basics" + (let ((table (make-eq-hashtable))) + (test-group "ref" + (test-error (hashtable-ref table 'a)) + (test-eq 'b (hashtable-ref table 'a 'b)) + (test-assert (not (hashtable-contains? table 'a))) + (test-eqv 0 (hashtable-size table))) + (test-group "set" + (hashtable-set! table 'a 'c) + (test-eq 'c (hashtable-ref table 'a)) + (test-eq 'c (hashtable-ref table 'a 'b)) + (test-assert (hashtable-contains? table 'a)) + (test-eqv 1 (hashtable-size table))) + (test-group "delete" + (hashtable-delete! table 'a) + (test-error (hashtable-ref table 'a)) + (test-eq 'b (hashtable-ref table 'a 'b)) + (test-assert (not (hashtable-contains? table 'a))) + (test-eqv 0 (hashtable-size table))))) + (test-group "advanced" + (let ((table (make-eq-hashtable))) + (test-group "lookup" + (let-values (((x found?) (hashtable-lookup table 'a))) + (test-assert (not found?)))) + (test-group "update" + (test-error (hashtable-update! table 'a (lambda (x) (+ x 1)))) + (hashtable-update! table 'a (lambda (x) (+ x 1)) 0) + (let-values (((x found?) (hashtable-lookup table 'a))) + (test-eqv 1 x) + (test-assert found?)) + (hashtable-update! table 'a (lambda (x) (+ x 1))) + (let-values (((x found?) (hashtable-lookup table 'a))) + (test-eqv x 2) + (test-assert found?)) + (hashtable-update! table 'a (lambda (x) (+ x 1)) 0) + (let-values (((x found?) (hashtable-lookup table 'a))) + (test-eqv x 3) + (test-assert found?))) + (test-group "intern" + (test-eqv 0 (hashtable-intern! table 'b (lambda () 0))) + (test-eqv 0 (hashtable-intern! table 'b (lambda () 1)))))) + (test-group "copy/clear" + (let ((table (alist->hashtable equal-hash equal? '((a . b))))) + (test-group "copy" + (let ((table2 (hashtable-copy table))) + (test-eq equal-hash (hashtable-hash-function table2)) + (test-eq equal? (hashtable-equivalence-function table2)) + (test-eq 'b (hashtable-ref table2 'a)) + (test-error (hashtable-set! table2 'a 'c))) + (let ((table2 (hashtable-copy table #f))) + (test-eq equal-hash (hashtable-hash-function table2)) + (test-eq equal? (hashtable-equivalence-function table2)) + (test-eq 'b (hashtable-ref table2 'a)) + (test-error (hashtable-set! table2 'a 'c))) + (let ((table2 (hashtable-copy table #t))) + (test-eq equal-hash (hashtable-hash-function table2)) + (test-eq equal? (hashtable-equivalence-function table2)) + (test-eq 'b (hashtable-ref table2 'a)) + (hashtable-set! table2 'a 'c) + (test-eq 'c (hashtable-ref table2 'a))) + (let ((table2 (hashtable-copy table #f #f))) + (test-eq equal-hash (hashtable-hash-function table2)) + (test-eq equal? (hashtable-equivalence-function table2)) + (test-eq #f (hashtable-weakness table2)))) + (test-group "clear" + (let ((table2 (hashtable-copy table #t))) + (hashtable-clear! table2) + (test-eqv 0 (hashtable-size table2))) + (let ((table2 (hashtable-copy table #t))) + (hashtable-clear! table2 10) + (test-eqv 0 (hashtable-size table2)))) + (test-group "empty-copy" + (let ((table2 (hashtable-empty-copy table))) + (test-eq equal-hash (hashtable-hash-function table2)) + (test-eq equal? (hashtable-equivalence-function table2)) + (test-eqv 0 (hashtable-size table2))) + (let ((table2 (hashtable-empty-copy table 10))) + (test-eq equal-hash (hashtable-hash-function table2)) + (test-eq equal? (hashtable-equivalence-function table2)) + (test-eqv 0 (hashtable-size table2)))))) + (test-group "keys/values" + (let ((table (alist->eq-hashtable '((a . b) (c . d))))) + (test-assert (lset= eq? '(a c) (vector->list (hashtable-keys table)))) + (test-assert (lset= eq? '(b d) (vector->list (hashtable-values table)))) + (let-values (((keys values) (hashtable-entries table))) + (test-assert (lset= eq? '(a c) (vector->list keys))) + (test-assert (lset= eq? '(b d) (vector->list values)))) + (test-assert (lset= eq? '(a c) (hashtable-key-list table))) + (test-assert (lset= eq? '(b d) (hashtable-value-list table))) + (let-values (((keys values) (hashtable-entry-lists table))) + (test-assert (lset= eq? '(a c) keys)) + (test-assert (lset= eq? '(b d) values))))) + (test-group "iteration" + (test-group "walk" + (let ((keys '()) + (values '())) + (hashtable-walk (alist->eq-hashtable '((a . b) (c . d))) + (lambda (k v) + (set! keys (cons k keys)) + (set! values (cons v values)))) + (test-assert (lset= eq? '(a c) keys)) + (test-assert (lset= eq? '(b d) values)))) + (test-group "update-all" + (let ((table (alist->eq-hashtable '((a . b) (c . d))))) + (hashtable-update-all! table + (lambda (k v) + (string->symbol (string-append (symbol->string v) "x")))) + (test-assert (lset= eq? '(a c) (hashtable-key-list table))) + (test-assert (lset= eq? '(bx dx) (hashtable-value-list table))))) + (test-group "prune" + (let ((table (alist->eq-hashtable '((a . b) (c . d))))) + (hashtable-prune! table (lambda (k v) (eq? k 'a))) + (test-assert (not (hashtable-contains? table 'a))) + (test-assert (hashtable-contains? table 'c)))) + (test-group "merge" + (let ((table (alist->eq-hashtable '((a . b) (c . d)))) + (table2 (alist->eq-hashtable '((a . x) (e . f))))) + (hashtable-merge! table table2) + (test-assert (lset= eq? '(a c e) (hashtable-key-list table))) + (test-assert (lset= eq? '(x d f) (hashtable-value-list table))))) + (test-group "sum" + (let ((table (alist->eq-hashtable '((a . b) (c . d))))) + (test-assert (lset= eq? '(a b c d) + (hashtable-sum table '() + (lambda (k v acc) + (lset-adjoin eq? acc k v))))))) + (test-group "map->lset" + (let ((table (alist->eq-hashtable '((a . b) (c . d))))) + (test-assert (lset= equal? '((a . b) (c . d)) + (hashtable-map->lset table cons))))) + (test-group "find" + (let ((table (alist->eq-hashtable '((a . b) (c . d))))) + (let-values (((k v f?) (hashtable-find table + (lambda (k v) + (eq? k 'a))))) + (test-assert (and f? (eq? k 'a) (eq? v 'b)))) + (let-values (((k v f?) (hashtable-find table (lambda (k v) #f)))) + (test-assert (not f?))))) + (test-group "misc" + (test-group "empty?" + (test-assert (hashtable-empty? (alist->eq-hashtable '()))) + (test-assert (not (hashtable-empty? (alist->eq-hashtable '((a . b))))))) + (test-group "pop!" + (test-error (hashtable-pop! (make-eq-hashtable))) + (let ((table (alist->eq-hashtable '((a . b))))) + (let-values (((k v) (hashtable-pop! table))) + (test-eq 'a k) + (test-eq 'b v) + (test-assert (hashtable-empty? table))))) + (test-group "inc!" + (let ((table (alist->eq-hashtable '((a . 0))))) + (hashtable-inc! table 'a) + (test-eqv 1 (hashtable-ref table 'a)) + (hashtable-inc! table 'a 2) + (test-eqv 3 (hashtable-ref table 'a)))) + (test-group "dec!" + (let ((table (alist->eq-hashtable '((a . 0))))) + (hashtable-dec! table 'a) + (test-eqv -1 (hashtable-ref table 'a)) + (hashtable-dec! table 'a 2) + (test-eqv -3 (hashtable-ref table 'a))))))) + +(test-group "hashing" + (test-assert (and (exact-integer? (hash-salt)))) + (test-assert (not (negative? (hash-salt)))) + (test-assert (= (equal-hash (list "foo" 'bar 42)) + (equal-hash (list "foo" 'bar 42)))) + (test-assert (= (string-hash (string-copy "foo")) + (string-hash (string-copy "foo")))) + (test-assert (= (string-ci-hash (string-copy "foo")) + (string-ci-hash (string-copy "FOO")))) + (test-assert (= (symbol-hash (string->symbol "foo")) + (symbol-hash (string->symbol "foo"))))) + +(test-end "SRFI-126") + +(display + (string-append + "\n" + "NOTE: On implementations using the (r6rs hashtables) library from Larceny,\n" + " 14 tests are expected to fail in relation to make-eq-hashtable and\n" + " make-eqv-hashtable returning hashtables whose hash functions are\n" + " exposed instead of being #f. We have no obvious way to detect this\n" + " within this portable test suite, hence no XFAIL results.\n")) + +;; Local Variables: +;; eval: (put (quote test-group) (quote scheme-indent-function) 1) +;; End: diff --git a/test-suite/tests/srfi-126.test b/test-suite/tests/srfi-126.test new file mode 100644 index 000000000..8d8a1cd3f --- /dev/null +++ b/test-suite/tests/srfi-126.test @@ -0,0 +1,49 @@ +;;;; srfi-126.test --- Test suite for SRFI-126. -*- scheme -*- +;;;; +;;;; Copyright (C) 2023 Free Software Foundation, Inc. +;;;; +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +(define-module (test-srfi-126) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-64) + #:use-module (srfi srfi-126)) + +(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-126-test.scm")) + +;;; Local Variables: +;;; eval: (put 'test-runner-on-test-end! 'scheme-indent-function 1) +;;; End: -- 2.41.0