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 09/15] module: Add SRFI 128. Date: Wed, 29 Nov 2023 16:59:37 -0500 Message-ID: <20231129220225.6819-10-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="16199"; 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:37 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 1r8Sfd-0003yS-4B for guile-devel@m.gmane-mx.org; Wed, 29 Nov 2023 23:04:37 +0100 Original-Received: from localhost ([::1] helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1r8Se7-0001DJ-TI; 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 1r8Se4-0001C9-RY for guile-devel@gnu.org; Wed, 29 Nov 2023 17:03:00 -0500 Original-Received: from mail-yb1-xb2f.google.com ([2607:f8b0:4864:20::b2f]) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1r8Sdz-0004EV-S6 for guile-devel@gnu.org; Wed, 29 Nov 2023 17:03:00 -0500 Original-Received: by mail-yb1-xb2f.google.com with SMTP id 3f1490d57ef6-d9caf5cc948so222848276.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=1701295374; x=1701900174; 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=No17sB9pYURMiKBR/O7K0vme4LdpNjmxZevJHNCLcTQ=; b=IV16Amc6cS/UTm8/icIJoHaflATayNA8eyScpUa5frW//rlotimIKqaZGZR/ObFgmA FRTbn8JB36TS4LWj+/xrsdMLfeLmtt5WUgJ3jvlJaHKRZTzfjop29eyJIPjZvhJrODbl TFL5PN6SjgN1mpT/UgzHyUxWjGLq9uG3HNxkEIiPTdE4H4AQr0yzyQOhAbydJYSjAqWL fsQeTMStUbAoIL58JWoWuULhac/4RCYycvnFb/JzlsjvWzV15fPBSZ3ECfd4kxGMI/dW 7ZYvKd9poAJUTBV42uMkTo5KmW1ud6BmpkQ8g+oI/8v5yB+vx+9dGgQp2yzZjkrkKFLn 6mQQ== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20230601; t=1701295374; x=1701900174; 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=No17sB9pYURMiKBR/O7K0vme4LdpNjmxZevJHNCLcTQ=; b=LcGPtYnlbpQ90rKosqULID+mH3c3OwuNuh8yzF04xGAXQ3Tv0PuJTRhob7clBkfuSM vbZG16HeJuAx8/GwfN6cAIJ5I/sVk0JTksfQ3AyKcj2+Oc4aMGomPI0KFqp/NaXN4ULb zPug/SHQjgF0PcLiNInB/uHgAcBlpVV56przQS8hzNYhomR0bCVAkvRSEIewFkJKOhyJ UlHYzuS3BWDWbRRfOsm1i1mRmFr45pbHBuKvOcu5S/X5BhRNoQJUTAuP6okogN6KhiGd lOjdMe4jUUA+NgVBawciXEIrXOeAewvPtLZE5Dm/m8HnWXxEyw50C5r3+5AOXas6K6X0 28yw== X-Gm-Message-State: AOJu0YzlhMCbnmObMCNbJsQmhABLmz3ie/LBXkOvn+IEKcgPzI88T1EF oUIHOVrzmu2Gs4wi1pUO5FsJkF9LJso= X-Google-Smtp-Source: AGHT+IGPYx0NOUObdHoxKo6uYoo7ybLtiSDdOZdVHYKXSTsYjQcBehoFxSs37cTKWtu2t/teNvTyIA== X-Received: by 2002:a25:ac5:0:b0:dae:4b98:16f9 with SMTP id 188-20020a250ac5000000b00dae4b9816f9mr20476506ybk.0.1701295373281; Wed, 29 Nov 2023 14:02:53 -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.52 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Wed, 29 Nov 2023 14:02:52 -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::b2f; envelope-from=maxim.cournoyer@gmail.com; helo=mail-yb1-xb2f.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:22156 Archived-At: >From upstream commit 62504e3b5b01615297cf65c33ca76a474bd61dd3. * module/srfi/srfi-128.scm * module/srfi/srfi-128/128.body1.scm * module/srfi/srfi-128/128.body2.scm * test-suite/tests/srfi-128-test.scm * test-suite/tests/srfi-128.test: New files. * am/bootstrap.am (SOURCES): Register srfi-128.scm. (NOCOMP_SOURCES): Register 128.body1.scm and 128.body2.scm. * test-suite/Makefile.am (SCM_TESTS): Register srfi-128.test. (EXTRA_DIST): Register srfi-128-test.scm. * doc/ref/srfi-modules.texi (SRFI Support): Document it. * NEWS: Update news. --- Changes in v5: - Update NEWS Changes in v4: - Fix invalid module references (e.g. (srfi 69) -> (srfi srfi-69)) - Use .sld for srfi-128 library file extension - Mention Expat license of SRFI 128 in guile.tex copying section - Add copyright line in srfi-modules.texi Changes in v3: - Rename SRFI-128 to SRFI 128 in text - Replace srfi-128.scm with upstream srfi/128.sld Changes in v2: - Remove string-hash and symbol-hash from exports (they are already listed in #:rename) am/bootstrap.am | 3 + doc/ref/guile.texi | 6 +- doc/ref/srfi-modules.texi | 553 ++++++++++++++++++++++++++++- module/srfi/srfi-128.sld | 61 ++++ module/srfi/srfi-128/128.body1.scm | 361 +++++++++++++++++++ module/srfi/srfi-128/128.body2.scm | 146 ++++++++ test-suite/Makefile.am | 2 + test-suite/tests/srfi-128-test.scm | 321 +++++++++++++++++ test-suite/tests/srfi-128.test | 47 +++ 9 files changed, 1496 insertions(+), 4 deletions(-) create mode 100644 module/srfi/srfi-128.sld create mode 100644 module/srfi/srfi-128/128.body1.scm create mode 100644 module/srfi/srfi-128/128.body2.scm create mode 100644 test-suite/tests/srfi-128-test.scm create mode 100644 test-suite/tests/srfi-128.test diff --git a/am/bootstrap.am b/am/bootstrap.am index 3586f0873..4404113ab 100644 --- a/am/bootstrap.am +++ b/am/bootstrap.am @@ -350,6 +350,7 @@ SOURCES = \ srfi/srfi-98.scm \ srfi/srfi-111.scm \ srfi/srfi-126.scm \ + srfi/srfi-128.sld \ srfi/srfi-171.scm \ srfi/srfi-171/gnu.scm \ srfi/srfi-171/meta.scm \ @@ -441,6 +442,8 @@ NOCOMP_SOURCES = \ srfi/srfi-42/ec.scm \ srfi/srfi-64/testing.scm \ srfi/srfi-67/compare.scm \ + srfi/srfi-128/128.body1.scm \ + srfi/srfi-128/128.body2.scm \ system/base/lalr.upstream.scm \ system/repl/describe.scm \ sxml/sxml-match.ss \ diff --git a/doc/ref/guile.texi b/doc/ref/guile.texi index 0540d2aab..f71d9a22c 100644 --- a/doc/ref/guile.texi +++ b/doc/ref/guile.texi @@ -24,9 +24,9 @@ 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 SRFI 126 module is adapted from -its specification text, which is made available under the following -Expat license: +Additionally, the documentation of the 126 and 128 SRFI modules is +adapted from their 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 diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi index 8b3315180..40ca7a2e7 100644 --- a/doc/ref/srfi-modules.texi +++ b/doc/ref/srfi-modules.texi @@ -3,6 +3,7 @@ @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 Copyright (C) 2015 John Cowan @c See the file guile.texi for copying conditions. @node SRFI Support @@ -66,7 +67,8 @@ get the relevant SRFI documents from the SRFI home page * SRFI-105:: Curly-infix expressions. * SRFI-111:: Boxes. * SRFI 126:: R6RS-based hash tables. -* SRFI-171:: Transducers +* SRFI 128:: Comparators. +* SRFI-171:: Transducers. @end menu @@ -6262,6 +6264,555 @@ contents, ignoring case. This hash function is suitable for use with Return an integer hash value for @var{symbol}. @end deffn +@node SRFI 128 +@subsection Comparators +@cindex SRFI 128 +@cindex comparators + +@uref{https://srfi.schemers.org/srfi-128/srfi-128.html, SRFI 128} +provides comparators, which bundle a @emph{type test predicate}, an +@emph{equality predicate}, an @emph{ordering predicate}, and a @emph{hash +function} into a single Scheme object. By packaging these procedures +together, they can be treated as a single item for use in the +implementation of data structures. + +@noindent +The four procedures above have complex dependencies on one another, and +it is inconvenient to have to pass them individually to other procedures +that might or might not make use of all of them. For example, a set +implementation by its nature requires only an equality predicate, but if +it is implemented using a hash table, an appropriate hash function is +also required if the implementation does not provide one; alternatively, +if it is implemented using a tree, procedures specifying a total order +are required. By passing a comparator rather than a bare equality +predicate, the set implementation can make use of whatever procedures +are available and useful to it. + +@subheading Definitions + +A comparator is an object of a disjoint type. It is a bundle of +procedures that are useful for comparing two objects in a total order. +It is an error if any of the procedures have side effects. There are +four procedures in the bundle: + +@enumerate +@item +The @emph{type test predicate} returns @code{#t} if its argument has the +correct type to be passed as an argument to the other three procedures, +and @code{#f} otherwise. + +@item +The @emph{equality predicate} returns @code{#t} if the two objects are the +same in the sense of the comparator, and @code{#f} otherwise. It is the +programmer's responsibility to ensure that it is reflexive, symmetric, +transitive, and can handle any arguments that satisfy the type test +predicate. + +@item +The @emph{ordering predicate} returns @code{#t} if the first object +precedes the second in a total order, and @code{#f} otherwise. Note +that if it is true, the equality predicate must be false. It is the +programmer's responsibility to ensure that it is irreflexive, +anti-symmetric, transitive, and can handle any arguments that satisfy +the type test predicate. + +@item +The @emph{hash function} takes an object and returns an exact non-negative +integer. It is the programmer's responsibility to ensure that it can +handle any argument that satisfies the type test predicate, and that it +returns the same value on two objects if the equality predicate says +they are the same (but not necessarily the converse). +@end enumerate + +It is also the programmer's responsibility to ensure that all four +procedures provide the same result whenever they are applied to the same +object(s) (in the sense of @code{eqv?}), unless the object(s) have been +mutated since the last invocation. + +@subheading Limitations + +The comparator objects defined in SRFI 128 are not applicable to +circular structures or to NaNs, or to objects containing any of these. +Attempts to pass any such objects to any procedure defined here, or to +any procedure that is part of a comparator defined here, is an error +except as otherwise noted. + +@menu +* SRFI 128 Predicates:: +* SRFI 128 Constructors:: +* SRFI 128 Standard hash functions:: +* SRFI 128 Bounds and salt:: +* SRFI 128 Default comparators:: +* SRFI 128 Accessors and Invokers:: +* SRFI 128 Comparison predicates:: +* SRFI 128 Syntax:: +@end menu + +@node SRFI 128 Predicates +@subsubsection SRFI 128 Predicates + +@deffn {Scheme Procedure} comparator? obj + +Return @code{#t} if @var{obj} is a comparator, and @code{#f} otherwise. +@end deffn + +@deffn {Scheme Procedure} comparator-ordered? comparator + +Return @code{#t} if @var{comparator} has a supplied ordering predicate, +and @code{#f} otherwise. +@end deffn + +@deffn {Scheme Procedure} comparator-hashable? comparator +Return @code{#t} if @var{comparator} has a supplied hash function, and +@code{#f} otherwise. +@end deffn + +@node SRFI 128 Constructors +@subsubsection SRFI 128 Constructors + +The following comparator constructors all supply appropriate type test +predicates, equality predicates, ordering predicates, and hash functions +based on the supplied arguments. They are allowed to cache their +results: they need not return a newly allocated object, since +comparators are pure and functional. In addition, the procedures in a +comparator are likewise pure and functional. + +@deffn {Scheme Procedure} make-comparator type-test equality ordering hash + +Return a comparator which bundles the @var{type-test}, @var{equality}, +@var{ordering}, and @var{hash} procedures provided. However, if +@var{ordering} or @var{hash} is @code{#f}, a procedure is provided that +signals an error on application. The predicates +@code{comparator-ordered?} and/or @code{comparator-hashable?}, +respectively, will return @code{#f} in these cases. + +Here are calls on @code{make-comparator} that will return useful +comparators for standard Scheme types: + +@itemize +@item +@samp{(make-comparator boolean? boolean=? (lambda (x y) (and (not x) y)) +boolean-hash)} will return a comparator for booleans, expressing the +ordering @samp{#f < #t} and the standard hash function for booleans. + +@item +@samp{(make-comparator real? = < (lambda (x) (exact (abs x))))} will +return a comparator expressing the natural ordering of real numbers and +a plausible (but not optimal) hash function. + +@item +@samp{(make-comparator string? string=? stringstring} and then +@code{string-hash} to the symbol, this is not a requirement. + +@node SRFI 128 Bounds and salt +@subsubsection SRFI 128 Bounds and salt + +The following macros allow the callers of hash functions to affect their +behavior without interfering with the calling signature of a hash +function, which accepts a single argument (the object to be hashed) and +returns its hash value. + +@deffn {Scheme Syntax} hash-bound + +Hash functions should be written so as to return a number between +@code{0} and the largest reasonable number of elements (such as hash +buckets) a data structure in the implementation might have. This value +is defined as @math{2^25-1} or @code{33554432} in the reference +implementation used by Guile. This value provides the current bound as +a positive exact integer, typically for use by user-written hash +functions. However, they are not required to bound their results in +this way. +@end deffn + +@deffn {Scheme Syntax} hash-salt + +A salt is random data in the form of a non-negative exact integer used +as an additional input to a hash function in order to defend against +dictionary attacks, or (when used in hash tables) against +denial-of-service attacks that overcrowd certain hash buckets, +increasing the amortized O(1) lookup time to O(n). Salt can also be +used to specify which of a family of hash functions should be used for +purposes such as cuckoo hashing. This macro provides the current value +of the salt, typically for use by user-written hash functions. However, +they are not required to make use of the current salt. + +The initial value is implementation-dependent, but must be less than the +value of @samp{(hash-bound)}, and should be distinct for distinct runs +of a program unless otherwise specified by the implementation. In the +reference implementation used by Guile, the initial salt value is +@code{16064047}. +@end deffn + +@node SRFI 128 Default comparators +@subsubsection SRFI 128 Default comparators + +@deffn {Scheme Procedure} make-default-comparator + +Return a comparator known as a @emph{default comparator} that accepts +Scheme values and orders them in a way that respects the following +conditions: + +@itemize +@item +Given disjoint types @code{a} and @code{b}, one of three conditions must +hold: +@itemize +@item +All objects of type @code{a} compare less than all objects of type +@code{b}. +@item +All objects of type @code{a} compare greater than all objects of type +@code{b}. +@item +All objects of both type @code{a} and type @code{b} compare equal to +each other. This is not permitted for any of the Scheme types mentioned +below. +@end itemize + +@item +The empty list must be ordered before all pairs. + +@item +When comparing booleans, it must use the total order @samp{#f < #t}. + +@item +When comparing characters, @code{char=?} and @code{char}, so are +the numbers; otherwise, the numbers are ordered by their imaginary +parts. This can still produce somewhat surprising results if one real +part is exact and the other is inexact. + +@item +When comparing real numbers, it must use @code{=} and @code{<}. + +@item +When comparing strings, it must use @code{string=?} and @code{string? comparator object@sub{1} object@sub{2} object@sub{3} @dots{} +@deffnx {Scheme Procedure} <=? comparator object@sub{1} object@sub{2} object@sub{3} @dots{} +@deffnx {Scheme Procedure} >=? comparator object@sub{1} object@sub{2} object@sub{3} @dots{} +@end deffn + +@noindent +These procedures are analogous to the number, character, and string +comparison predicates of Scheme. They allow the convenient use of +comparators to handle variable data types. + +@noindent +These procedures apply the equality and ordering predicates of +@var{comparator} to the objects as follows. If the specified relation +returns @code{#t} for all @var{object@sub{i}} and @var{object@sub{j}} +where @var{n} is the number of objects and @math{1 <= @var{i} < @var{j} +<= @var{n}}, then the procedures return @code{#t}, but otherwise +@code{#f}. Because the relations are transitive, it suffices to compare +each object with its successor. The order in which the values are +compared is unspecified. + +@node SRFI 128 Syntax +@subsubsection SRFI 128 Syntax + +@deffn {Scheme Procedure} comparator-if<=> [comparator] object@sub{1} object@sub{2} less-than equal-to greater-than + +It is an error unless @var{comparator} evaluates to a comparator and +@var{object@sub{1}} and @var{object@sub{2}} evaluate to objects that the +comparator can handle. If the ordering predicate returns true when +applied to the values of @var{object@sub{1}} and @var{object@sub{2}} in +that order, then @var{less-than} is evaluated and its value returned. +If the equality predicate returns true when applied in the same way, +then @var{equal-to} is evaluated and its value returned. If neither +returns true, @var{greater-than} is evaluated and its value returned. + +If @var{comparator} is omitted, a default comparator is used. +@end deffn + @node SRFI-171 @subsection Transducers @cindex SRFI-171 diff --git a/module/srfi/srfi-128.sld b/module/srfi/srfi-128.sld new file mode 100644 index 000000000..3931abea7 --- /dev/null +++ b/module/srfi/srfi-128.sld @@ -0,0 +1,61 @@ +;;; Copyright (C) John Cowan (2015). All Rights Reserved. +;;; +;;; Permission is hereby granted, free of charge, to any person +;;; obtaining a copy of this software and associated documentation +;;; files (the "Software"), to deal in the Software without +;;; restriction, including without limitation the rights to use, +;;; copy, modify, merge, publish, distribute, sublicense, and/or +;;; sell copies of the Software, and to permit persons to whom the +;;; Software is furnished to do so, subject to the following +;;; conditions: +;;; +;;; The above copyright notice and this permission notice shall be +;;; included in all copies or substantial portions of the Software. +;;; +;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES +;;; OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT +;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, +;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR +;;; OTHER DEALINGS IN THE SOFTWARE. + +(define-library (srfi srfi-128) + (export comparator? comparator-ordered? comparator-hashable? + make-comparator + make-pair-comparator make-list-comparator make-vector-comparator + make-eq-comparator make-eqv-comparator make-equal-comparator + boolean-hash char-hash char-ci-hash + string-hash string-ci-hash symbol-hash number-hash + make-default-comparator default-hash comparator-register-default! + comparator-type-test-predicate comparator-equality-predicate + comparator-ordering-predicate comparator-hash-function + comparator-test-type comparator-check-type comparator-hash + hash-bound hash-salt + =? ? <=? >=? + comparator-if<=> + ) + (import (scheme base) + (scheme case-lambda) + (scheme char) + (scheme inexact) + (scheme complex)) + + (cond-expand ((library (srfi srfi-126)) + (import (only (srfi srfi-126) equal-hash))) + ((library (rnrs hashtables)) + (import (only (rnrs hashtables) equal-hash))) + ((library (r6rs hashtables)) + (import (only (r6rs hashtables) equal-hash))) + ((library (srfi srfi-69)) + (import (rename (only (srfi srfi-69) hash-by-identity) + (hash-by-identity equal-hash)))) + (else + ;; FIXME: This works well enough for the test program, + ;; but you wouldn't want to use it in a real program. + (begin (define (equal-hash x) 0)))) + + (include "srfi-128/128.body1.scm") + (include "srfi-128/128.body2.scm") +) diff --git a/module/srfi/srfi-128/128.body1.scm b/module/srfi/srfi-128/128.body1.scm new file mode 100644 index 000000000..8cb41a2bf --- /dev/null +++ b/module/srfi/srfi-128/128.body1.scm @@ -0,0 +1,361 @@ +;;; Copyright (C) John Cowan (2015). All Rights Reserved. +;;; +;;; Permission is hereby granted, free of charge, to any person +;;; obtaining a copy of this software and associated documentation +;;; files (the "Software"), to deal in the Software without +;;; restriction, including without limitation the rights to use, +;;; copy, modify, merge, publish, distribute, sublicense, and/or +;;; sell copies of the Software, and to permit persons to whom the +;;; Software is furnished to do so, subject to the following +;;; conditions: +;;; +;;; The above copyright notice and this permission notice shall be +;;; included in all copies or substantial portions of the Software. +;;; +;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES +;;; OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT +;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, +;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR +;;; OTHER DEALINGS IN THE SOFTWARE. + +;;;; Main part of the SRFI 114 reference implementation + +;;; "There are two ways of constructing a software design: One way is to +;;; make it so simple that there are obviously no deficiencies, and the +;;; other way is to make it so complicated that there are no *obvious* +;;; deficiencies." --Tony Hoare + +;;; Syntax (because syntax must be defined before it is used, contra Dr. Hardcase) + +;; Arithmetic if +(define-syntax comparator-if<=> + (syntax-rules () + ((if<=> a b less equal greater) + (comparator-if<=> (make-default-comparator) a b less equal greater)) + ((comparator-if<=> comparator a b less equal greater) + (cond + ((=? comparator a b) equal) + ((? comparator a b) + (binary? comparator a b))) + +(define (binary>=? comparator a b) + (not (binary? comparator a b . objs) + (let loop ((a a) (b b) (objs objs)) + (and (binary>? comparator a b) + (if (null? objs) #t (loop b (car objs) (cdr objs)))))) + +(define (<=? comparator a b . objs) + (let loop ((a a) (b b) (objs objs)) + (and (binary<=? comparator a b) + (if (null? objs) #t (loop b (car objs) (cdr objs)))))) + +(define (>=? comparator a b . objs) + (let loop ((a a) (b b) (objs objs)) + (and (binary>=? comparator a b) + (if (null? objs) #t (loop b (car objs) (cdr objs)))))) + + +;;; Simple ordering and hash functions + +(define (booleaninteger obj)) (hash-bound))) + +(define (char-ci-hash obj) + (modulo (* (%salt%) (char->integer (char-foldcase obj))) (hash-bound))) + +(define (number-hash obj) + (cond + ((nan? obj) (%salt%)) + ((and (infinite? obj) (positive? obj)) (* 2 (%salt%))) + ((infinite? obj) (* (%salt%) 3)) + ((real? obj) (abs (exact (round obj)))) + (else (+ (number-hash (real-part obj)) (number-hash (imag-part obj)))))) + +;; Lexicographic ordering of complex numbers +(define (complexstring a) (symbol->string b))) + +(define (symbol-hash obj) + (string-hash (symbol->string obj))) + +;;; Wrapped equality predicates +;;; These comparators don't have ordering functions. + +(define (make-eq-comparator) + (make-comparator #t eq? #f default-hash)) + +(define (make-eqv-comparator) + (make-comparator #t eqv? #f default-hash)) + +(define (make-equal-comparator) + (make-comparator #t equal? #f default-hash)) + +;;; Sequence ordering and hash functions +;; The hash functions are based on djb2, but +;; modulo 2^25 instead of 2^32 in hopes of sticking to fixnums. + +(define (make-hasher) + (let ((result (%salt%))) + (case-lambda + (() result) + ((n) (set! result (+ (modulo (* result 33) (hash-bound)) n)) + result)))) + +;;; Pair comparator +(define (make-pair-comparator car-comparator cdr-comparator) + (make-comparator + (make-pair-type-test car-comparator cdr-comparator) + (make-pair=? car-comparator cdr-comparator) + (make-pair (length a) (length b)) #f) + (else + (let ((elem=? (comparator-equality-predicate element-comparator)) + (eleminteger (string-ref obj n))) (loop (+ n 1))))))) diff --git a/module/srfi/srfi-128/128.body2.scm b/module/srfi/srfi-128/128.body2.scm new file mode 100644 index 000000000..b424d41b5 --- /dev/null +++ b/module/srfi/srfi-128/128.body2.scm @@ -0,0 +1,146 @@ +;;; Copyright (C) John Cowan (2015). All Rights Reserved. +;;; +;;; Permission is hereby granted, free of charge, to any person +;;; obtaining a copy of this software and associated documentation +;;; files (the "Software"), to deal in the Software without +;;; restriction, including without limitation the rights to use, +;;; copy, modify, merge, publish, distribute, sublicense, and/or +;;; sell copies of the Software, and to permit persons to whom the +;;; Software is furnished to do so, subject to the following +;;; conditions: +;;; +;;; The above copyright notice and this permission notice shall be +;;; included in all copies or substantial portions of the Software. +;;; +;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES +;;; OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT +;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, +;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR +;;; OTHER DEALINGS IN THE SOFTWARE. + +;;; The default comparator + +;;; Standard comparators and their functions + +;; The unknown-object comparator, used as a fallback to everything else +;; Everything compares exactly the same and hashes to 0 +(define unknown-object-comparator + (make-comparator + (lambda (obj) #t) + (lambda (a b) #t) + (lambda (a b) #f) + (lambda (obj) 0))) + +;; Next index for added comparator + +(define first-comparator-index 9) +(define *next-comparator-index* 9) +(define *registered-comparators* (list unknown-object-comparator)) + +;; Register a new comparator for use by the default comparator. +(define (comparator-register-default! comparator) + (set! *registered-comparators* (cons comparator *registered-comparators*)) + (set! *next-comparator-index* (+ *next-comparator-index* 1))) + +;; Return ordinal for object types: null sorts before pairs, which sort +;; before booleans, etc. Implementations can extend this. +;; People who call comparator-register-default! effectively do extend it. +(define (object-type obj) + (cond + ((null? obj) 0) + ((pair? obj) 1) + ((boolean? obj) 2) + ((char? obj) 3) + ((string? obj) 4) + ((symbol? obj) 5) + ((number? obj) 6) + ((vector? obj) 7) + ((bytevector? obj) 8) + ; Add more here if you want: be sure to update comparator-index variables + (else (registered-index obj)))) + +;; Return the index for the registered type of obj. +(define (registered-index obj) + (let loop ((i 0) (registry *registered-comparators*)) + (cond + ((null? registry) (+ first-comparator-index i)) + ((comparator-test-type (car registry) obj) (+ first-comparator-index i)) + (else (loop (+ i 1) (cdr registry)))))) + +;; Given an index, retrieve a registered conductor. +;; Index must be >= first-comparator-index. +(define (registered-comparator i) + (list-ref *registered-comparators* (- i first-comparator-index))) + +(define (dispatch-equality type a b) + (case type + ((0) #t) ; All empty lists are equal + ((1) ((make-pair=? (make-default-comparator) (make-default-comparator)) a b)) + ((2) (boolean=? a b)) + ((3) (char=? a b)) + ((4) (string=? a b)) + ((5) (symbol=? a b)) + ((6) (= a b)) + ((7) ((make-vector=? (make-default-comparator) + vector? vector-length vector-ref) a b)) + ((8) ((make-vector=? (make-comparator exact-integer? = < default-hash) + bytevector? bytevector-length bytevector-u8-ref) a b)) + ; Add more here + (else (binary=? (registered-comparator type) a b)))) + +(define (dispatch-ordering type a b) + (case type + ((0) 0) ; All empty lists are equal + ((1) ((make-pair a-type b-type) #f) + (else (dispatch-ordering a-type a b))))) + +(define (default-equality a b) + (let ((a-type (object-type a)) + (b-type (object-type b))) + (if (= a-type b-type) (dispatch-equality a-type a b) #f))) + +(define (make-default-comparator) + (make-comparator + (lambda (obj) #t) + default-equality + default-ordering + default-hash)) diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am index eaa5e1fdb..0fb5827cc 100644 --- a/test-suite/Makefile.am +++ b/test-suite/Makefile.am @@ -163,6 +163,7 @@ SCM_TESTS = tests/00-initial-env.test \ tests/srfi-105.test \ tests/srfi-111.test \ tests/srfi-126.test \ + tests/srfi-128.test \ tests/srfi-171.test \ tests/srfi-4.test \ tests/srfi-9.test \ @@ -210,6 +211,7 @@ EXTRA_DIST = \ tests/rnrs-test-a.scm \ tests/srfi-64-test.scm \ tests/srfi-126-test.scm \ + tests/srfi-128-test.scm \ ChangeLog-2008 diff --git a/test-suite/tests/srfi-128-test.scm b/test-suite/tests/srfi-128-test.scm new file mode 100644 index 000000000..2cad04377 --- /dev/null +++ b/test-suite/tests/srfi-128-test.scm @@ -0,0 +1,321 @@ +;;; Copyright (C) John Cowan (2015). All Rights Reserved. +;;; +;;; Permission is hereby granted, free of charge, to any person +;;; obtaining a copy of this software and associated documentation +;;; files (the "Software"), to deal in the Software without +;;; restriction, including without limitation the rights to use, +;;; copy, modify, merge, publish, distribute, sublicense, and/or +;;; sell copies of the Software, and to permit persons to whom the +;;; Software is furnished to do so, subject to the following +;;; conditions: +;;; +;;; The above copyright notice and this permission notice shall be +;;; included in all copies or substantial portions of the Software. +;;; +;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES +;;; OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT +;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, +;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR +;;; OTHER DEALINGS IN THE SOFTWARE. + +;;; START Guile-specific modifications. +;;; +;;; The 'imports' are turned into 'use-modules' and srfi-64 is used. +;;; Two macros are added for compatibility with Chicken Scheme's 'test' +;;; library. A 'test-begin' call is added. +(use-modules (rnrs bytevectors) + (srfi srfi-64) + (srfi srfi-128)) + +(define-syntax-rule (test arg ...) + (test-equal arg ...)) + +(define-syntax-rule (test-exit arg ...) + (test-end)) + +(test-begin "comparators") +;;; END Guile-specific modifications. + +(define (print x) (display x) (newline)) + +(test-group "comparators" + + (define (vector-cdr vec) + (let* ((len (vector-length vec)) + (result (make-vector (- len 1)))) + (let loop ((n 1)) + (cond + ((= n len) result) + (else (vector-set! result (- n 1) (vector-ref vec n)) + (loop (+ n 1))))))) + + (test '#(2 3 4) (vector-cdr '#(1 2 3 4))) + (test '#() (vector-cdr '#(1))) + + (print "default-comparator") + (define default-comparator (make-default-comparator)) + (print "real-comparator") + (define real-comparator (make-comparator real? = < number-hash)) + (print "degenerate comparator") + (define degenerate-comparator (make-comparator (lambda (x) #t) equal? #f #f)) + (print "boolean comparator") + (define boolean-comparator + (make-comparator boolean? eq? (lambda (x y) (and (not x) y)) boolean-hash)) + (print "bool-pair-comparator") + (define bool-pair-comparator (make-pair-comparator boolean-comparator boolean-comparator)) + (print "num-list-comparator") + (define num-list-comparator + (make-list-comparator real-comparator list? null? car cdr)) + (print "num-vector-comparator") + (define num-vector-comparator + (make-vector-comparator real-comparator vector? vector-length vector-ref)) + (print "vector-qua-list comparator") + (define vector-qua-list-comparator + (make-list-comparator + real-comparator + vector? + (lambda (vec) (= 0 (vector-length vec))) + (lambda (vec) (vector-ref vec 0)) + vector-cdr)) + (print "list-qua-vector-comparator") + (define list-qua-vector-comparator + (make-vector-comparator default-comparator list? length list-ref)) + (print "eq-comparator") + (define eq-comparator (make-eq-comparator)) + (print "eqv-comparator") + (define eqv-comparator (make-eqv-comparator)) + (print "equal-comparator") + (define equal-comparator (make-equal-comparator)) + (print "symbol-comparator") + (define symbol-comparator + (make-comparator + symbol? + eq? + (lambda (a b) (stringstring a) (symbol->string b))) + symbol-hash)) + + (test-group "comparators/predicates" + (test-assert (comparator? real-comparator)) + (test-assert (not (comparator? =))) + (test-assert (comparator-ordered? real-comparator)) + (test-assert (comparator-hashable? real-comparator)) + (test-assert (not (comparator-ordered? degenerate-comparator))) + (test-assert (not (comparator-hashable? degenerate-comparator))) + ) ; end comparators/predicates + + (test-group "comparators/constructors" + (test-assert (=? boolean-comparator #t #t)) + (test-assert (not (=? boolean-comparator #t #f))) + (test-assert (? real-comparator 4.0 3.0 2)) + (test-assert (<=? real-comparator 2.0 2 3.0)) + (test-assert (>=? real-comparator 3 3.0 2)) + (test-assert (not (=? real-comparator 1 2 3))) + (test-assert (not (? real-comparator 1 2 3))) + (test-assert (not (<=? real-comparator 4 3 3))) + (test-assert (not (>=? real-comparator 3 4 4.0))) + + ) ; end comparators/comparison + + (test-group "comparators/syntax" + (test 'less (comparator-if<=> real-comparator 1 2 'less 'equal 'greater)) + (test 'equal (comparator-if<=> real-comparator 1 1 'less 'equal 'greater)) + (test 'greater (comparator-if<=> real-comparator 2 1 'less 'equal 'greater)) + (test 'less (comparator-if<=> "1" "2" 'less 'equal 'greater)) + (test 'equal (comparator-if<=> "1" "1" 'less 'equal 'greater)) + (test 'greater (comparator-if<=> "2" "1" 'less 'equal 'greater)) + + ) ; end comparators/syntax + + (test-group "comparators/bound-salt" + (test-assert (exact-integer? (hash-bound))) + (test-assert (exact-integer? (hash-salt))) + (test-assert (< (hash-salt) (hash-bound))) + ) ; end comparators/bound-salt + +) ; end comparators + +(test-exit) diff --git a/test-suite/tests/srfi-128.test b/test-suite/tests/srfi-128.test new file mode 100644 index 000000000..a6a447767 --- /dev/null +++ b/test-suite/tests/srfi-128.test @@ -0,0 +1,47 @@ +;;;; srfi-128.test --- Test suite for SRFI-128. -*- 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-128) + #:use-module (srfi srfi-64) + #:use-module (srfi srfi-128)) + +(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-128-test.scm")) + +;;; Local Variables: +;;; eval: (put 'test-runner-on-test-end! 'scheme-indent-function 1) +;;; End: -- 2.41.0