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 v8 16/16] module: Add SRFI 209. Date: Wed, 6 Dec 2023 18:15:12 -0500 Message-ID: <20231206231512.6505-17-maxim.cournoyer@gmail.com> References: <20231206231512.6505-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="40059"; 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 Thu Dec 07 00:17:22 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 1rB18q-000A7k-Fk for guile-devel@m.gmane-mx.org; Thu, 07 Dec 2023 00:17:20 +0100 Original-Received: from localhost ([::1] helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1rB17a-0001zP-Dq; Wed, 06 Dec 2023 18:16:02 -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 1rB17V-0001wM-8i for guile-devel@gnu.org; Wed, 06 Dec 2023 18:15:57 -0500 Original-Received: from mail-oi1-x234.google.com ([2607:f8b0:4864:20::234]) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1rB17M-0001Az-40 for guile-devel@gnu.org; Wed, 06 Dec 2023 18:15:57 -0500 Original-Received: by mail-oi1-x234.google.com with SMTP id 5614622812f47-3b8b5faa15bso250427b6e.1 for ; Wed, 06 Dec 2023 15:15:47 -0800 (PST) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gmail.com; s=20230601; t=1701904545; x=1702509345; 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=t9ZlTAXQIItJLv9pJq35GmoWXs2oFxctiGNJqhOmDkM=; b=UdJ4EkucYHF2qpo2/I2P8gcHLsBUx6UAsMHXE5BtSiQjVVw8+tDOTfIVWSCD2ibXN8 Qq8q7nCq1sSaX6uX+OxqkVHxpcja/N4uQzZD8fltXHomBQZnyrhIL6j78a9LhRgS+KuO Bke4pCn/2pCXBk90be9+wK4XM05C4Mq3bS9ueACf1kyPbK2OPvLqrw9irEWnS8RUo0+y pknI1adT2X6OSbjn8wabeVX3FSy6QkFRCpAwHVRvzsbDQmd4zVfT4byw6aZasi+/Qusv 98fcTnCHtwVCispLOQacROYChExvnp72D5P3VP/n64js1kPS76Yqb9vCuNfUDJDIWbSp vb2A== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20230601; t=1701904545; x=1702509345; 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=t9ZlTAXQIItJLv9pJq35GmoWXs2oFxctiGNJqhOmDkM=; b=PvlGvtlQLEkF2ZPy2qYDsBV5pt9fgrj5Rbd4PjALn0+P4SXNCAUjru133EjBk9ya6a pcQ2FH2BoymNbwvvMPe1h2TZTBLi2R9gkhk/ZQmJ2mz4JheQ3fkWGev/dSs7KfliXf2F jlnXPy2bye1pXTVXpQmL33hGl1lZoBmXEwlthCtMNA8xRjmF4eUxTlsSX2vce3SAL0hj 1bCkWFDXQnE0A0YskhubSYDusftyaBicYf++XBkr4NfuO1jQMNInZQ2UrjO/wdznmfVP Cb58zAG0YQDQXnOp7uoER41wWMRhGaZZ55d11gPqAgohipibpdoChqUKvkOySvbmOrdd jWLQ== X-Gm-Message-State: AOJu0YxI2dQ5V3+qx0FkvMejiD8cu4MOndGkHcBKLIjNpI+9JxBj3qh/ EjQl0qfw7hhCRdCet0jl57WdFQMB9h8= X-Google-Smtp-Source: AGHT+IEnt4H2SCbOqfRAQgyQcO5+ef4B8oxFUBhJz+I8nNOl3FhBh/jXFxiU9SYztnOynU/aZuxMgw== X-Received: by 2002:a05:6808:130f:b0:3b8:b063:8935 with SMTP id y15-20020a056808130f00b003b8b0638935mr1969681oiv.67.1701904543088; Wed, 06 Dec 2023 15:15:43 -0800 (PST) Original-Received: from localhost.localdomain (dsl-10-130-68.b2b2c.ca. [72.10.130.68]) by smtp.gmail.com with ESMTPSA id re18-20020a05620a8e1200b0077d8ad77069sm3400qkn.26.2023.12.06.15.15.42 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Wed, 06 Dec 2023 15:15:42 -0800 (PST) X-Mailer: git-send-email 2.41.0 In-Reply-To: <20231206231512.6505-1-maxim.cournoyer@gmail.com> Received-SPF: pass client-ip=2607:f8b0:4864:20::234; envelope-from=maxim.cournoyer@gmail.com; helo=mail-oi1-x234.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:22216 Archived-At: Sources retrieved from commit 9d40aaff0b788f3fd611e04a5b6aef4dfd017e8d from https://github.com/scheme-requests-for-implementation/srfi-209/. * module/srfi/srfi-209.sld: New file. * module/srfi/srfi-209/209.scm: Likewise. * module/Makefile.am (SOURCES): Register srfi-209.sld. (NOCOMP_SOURCES): Register 209.scm. * test-suite/tests/srfi-209-test.scm: New file. * test-suite/tests/srfi-209.test: Likewise. * test-suite/Makefile.am (SCM_TESTS): Register test. (EXTRA_DIST): Register test definition. * doc/ref/srfi-modules.texi (SRFI 209): Document it. --- Changes in v8: - Incorporate recent fix from Wolfgang (commit 6092dfb) Changes in v7: - Register prerequisites for srfi/srfi-209.go in am/bootstrap.am Changes in v6: - Add SRFI 209 NEWS | 1 + am/bootstrap.am | 4 + doc/ref/guile.texi | 4 +- doc/ref/srfi-modules.texi | 893 ++++++++++++++++++++++++++++- module/srfi/srfi-209.sld | 60 ++ module/srfi/srfi-209/209.scm | 691 ++++++++++++++++++++++ test-suite/Makefile.am | 2 + test-suite/tests/srfi-209-test.scm | 465 +++++++++++++++ test-suite/tests/srfi-209.test | 50 ++ 9 files changed, 2162 insertions(+), 8 deletions(-) create mode 100644 module/srfi/srfi-209.sld create mode 100644 module/srfi/srfi-209/209.scm create mode 100644 test-suite/tests/srfi-209-test.scm create mode 100644 test-suite/tests/srfi-209.test diff --git a/NEWS b/NEWS index b1a21c59b..a269e0776 100644 --- a/NEWS +++ b/NEWS @@ -29,6 +29,7 @@ the compiler reports it as "possibly unused". ** Add (srfi 151), a bitwise operations library ** Add (srfi 160), an homogeneous numeric vector library ** Add (srfi 178), a bitvector library +** Add (srfi 209), an enums library * Bug fixes diff --git a/am/bootstrap.am b/am/bootstrap.am index acbf17f0b..425919a72 100644 --- a/am/bootstrap.am +++ b/am/bootstrap.am @@ -75,6 +75,8 @@ srfi/srfi-160/c128.go srfi/srfi-160/c64.go srfi/srfi-160/f32.go \ srfi/srfi-160/u32.go srfi/srfi-160/u64.go \ srfi/srfi-160/u8.go: srfi/srfi-128.go srfi/srfi-160/base.go srfi/srfi-178.go: srfi/srfi-151.go srfi/srfi-160/u8.go +srfi/srfi-209.go: srfi/srfi-1.go srfi/srfi-125.go srfi/srfi-128.go \ + srfi/srfi-178.go # All sources. We can compile these in any order; the order below is # designed to hopefully result in the lowest total compile time. @@ -386,6 +388,7 @@ SOURCES = \ srfi/srfi-171/gnu.scm \ srfi/srfi-171/meta.scm \ srfi/srfi-178.sld \ + srfi/srfi-209.sld \ \ statprof.scm \ \ @@ -517,6 +520,7 @@ NOCOMP_SOURCES = \ srfi/srfi-178/quasi-strs.scm \ srfi/srfi-178/unfolds.scm \ srfi/srfi-178/wrappers.scm \ + srfi/srfi-209/209.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 22d234b1b..f2a2d08f4 100644 --- a/doc/ref/guile.texi +++ b/doc/ref/guile.texi @@ -24,8 +24,8 @@ 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 125, 126, 128, 151, 160 and 178 -SRFI modules is adapted from their specification text, which is made +Additionally, the documentation of the 125, 126, 128, 151, 160, 178 and +209 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 diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi index 216a4e045..3ca18979f 100644 --- a/doc/ref/srfi-modules.texi +++ b/doc/ref/srfi-modules.texi @@ -3,7 +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-2016, 2018 John Cowan +@c Copyright (C) 2015-2016, 2018, 2020 John Cowan @c See the file guile.texi for copying conditions. @node SRFI Support @@ -73,9 +73,9 @@ get the relevant SRFI documents from the SRFI home page * SRFI 160:: Homogeneous numeric vectors. * SRFI-171:: Transducers. * SRFI 178:: Bitvectors. +* SRFI 209:: Enums and Enum Sets. @end menu - @node About SRFI Usage @subsection About SRFI Usage @@ -9444,13 +9444,14 @@ returns, and in order to write portable code, the return value should be ignored. @item @var{vec} -An heterogeneous vector; that is, it must satisfy the predicate +A heterogeneous vector; that is, it must satisfy the predicate @code{vector?}. @item @var{bvec}, @var{to}, @var{from} -A bitvector, i.e., it must satisfy the predicate @code{bitvector?}. In -@code{bitvector-copy!} and @code{reverse-bitvector-copy!}, @var{to} is the -destination and @var{from} is the source. +A bitvector, @abbr{i.e.} it must satisfy the predicate +@code{bitvector?}. In @code{bitvector-copy!} and +@code{reverse-bitvector-copy!}, @var{to} is the destination and +@var{from} is the source. @item @var{i}, @var{j}, @var{start}, @var{at} An exact nonnegative integer less than the length of the bitvector. In @@ -9966,6 +9967,886 @@ and @code{write} procedures and by the program parser, so that programs can contain references to literal bitvectors. On input, it is an error if such a literal is not followed by a or the end of input. +@node SRFI 209 +@subsection SRFI 209: Enums and Enum Sets +@cindex SRFI 209 + +Enums are objects that serve to form sets of distinct classes that +specify different modes of operation for a procedure. Their use fosters +portable and readable code. + +@menu +* SRFI 209 Rationale:: +* SRFI 209 R6RS compatibility:: +* SRFI 209 Predicates:: +* SRFI 209 Enum type constructor:: +* SRFI 209 Enum accessors:: +* SRFI 209 Enum finders:: +* SRFI 209 Enum types:: +* SRFI 209 Enum objects:: +* SRFI 209 Comparators:: +* SRFI 209 Enum set constructors:: +* SRFI 209 Enum set predicates:: +* SRFI 209 Enum set accessors:: +* SRFI 209 Enum set mutators:: +* SRFI 209 Enum set operations:: +* SRFI 209 Enum set logical operations:: +* SRFI 209 Syntax:: +@end menu + +@node SRFI 209 Rationale +@subsubsection SRFI 209 Rationale + +Many procedures in many libraries accept arguments from a finite set +(usually a fairly small one), or subsets of a finite set to describe one +or more modes of operation. Offering a mechanism for dealing with such +values fosters portable and readable code, much as records do for +compound values, or multiple values for procedures computing several +results. + +This SRFI provides something related to the @emph{enums} of Java version +5 and later. These are objects of a type disjoint from all others that +are grouped into @emph{enum types} (called @emph{enum classes} in Java). +In Java, each enum type declares the names and types of values +associated with each object, but in this SRFI an enum object has exactly +one value; this is useful when translating from C to record the numeric +value, but has other uses as well. + +In this SRFI, each enum has four properties: the enum type to which it +belongs, its name (a symbol), its ordinal (an exact integer), and its +value (any object). An enum type provides access to all the enums that +belong to it by name or ordinal. + +@subsubheading Alternatives + +In Lisp-family languages, it is traditional to use symbols and lists of +symbols for this purpose. Symbols have at least two disadvantages: they +are not ``type-safe'', in the sense that a single symbol may be used in +more than one logically independent universe of flags; and in Scheme +symbols do not have associated values (although in Common Lisp they do). + +R6RS enums ameliorate these disadvantages by providing ``type-safe'' +sets, which can be stored more efficiently than general lists, possibly +as integers. However, neither enum types nor enum objects are exposed, +only enum names and enum sets. This means that R6RS cannot have a +procedure that takes an enum-type and returns the enum of the type whose +ordinal number is @emph{n}, nor a procedure that takes an existing +enum-type and creates an enum-set containing specified enums from it. +Instead, it must use procedures that return a quasi-curried procedure +for performing these operations on a specified enum-type. The nearest +equivalent to an enum object in the sense of this SRFI is a singleton +enum set. To perform an efficient test of enum set membership, it is +necessary to use such a singleton, and comparing two such sets for +equality involves @code{=} rather than @code{eqv?}. + +In C, enums have names and numeric values, by default consecutive +values, but often powers of two or something externally dictated. +However, the name is not accessible at runtime, and enum types are not +really disjoint from integer types. (In C++, they are statically +distinct.) + +@subsubheading Enum collections + +@emph{Enum sets} are used to represent multiple enums that belong to the +same type. They provide a subset of the operations provided by +@url{https://srfi.schemers.org/srfi-113/srfi-113.html, SRFI 113} general +sets. + +Specialized mappings from enums to arbitrary values will be described in +a future SRFI. Meanwhile either general-purpose hash tables from +@url{https://srfi.schemers.org/srfi-125/srfi-125.html, SRFI 125} or +elsewhere, or @url{https://srfi.schemers.org/srfi-146/srfi-146.html, +SRFI 146} mappings, can be used instead. + +@node SRFI 209 R6RS compatibility +@subsubsection SRFI 209 R6RS compatibility + +This SRFI provides the same procedures as the @code{(rnrs enums)} +library. In that library, neither enum types nor enum objects are +exposed ---only enum-sets and the names of enums. (There are no enum +values or ordinals.) Some of the R6RS-specific procedures given below +operate in those terms and are redundant with other procedures. These +are deprecated, and have been marked with @samp{[from R6RS, +deprecated]}. + +@node SRFI 209 Predicates +@subsubsection SRFI 209 Predicates + +@deffn {Scheme Procedure} enum-type? obj + +Returns @code{#t} if @var{obj} is an enum type, and @code{#f} otherwise. +@end deffn + +@deffn {Scheme Procedure} enum? obj + +Returns @code{#t} if @var{obj} is an enum, and @code{#f} otherwise. +@end deffn + +@deffn {Scheme Procedure} enum-type-contains? enum-type enum + +Returns @code{#t} if @var{enum} belongs to @var{enum-type}, and +@code{#f} otherwise. + +@lisp +(enum-type-contains? color (enum-name->enum color 'red)) @U{21D2} #t +(enum-type-contains? pizza (enum-name->enum color 'red)) @U{21D2} #f +@end lisp +@end deffn + +@deffn {Scheme Procedure} enum=? enum@sub{0} enum@sub{1} enum @dots{} + +Returns @code{#t} if all the arguments are the same enum in the sense of +@code{eq?} (which is equivalent to having the same name and ordinal) and +@code{#f} otherwise. It is an error to apply @code{enum=?} to enums +belonging to different enum types. + +@lisp +(enum=? color-red color-blue) @U{21D2} #f +(enum=? pizza-funghi (enum-name->enum pizza 'funghi)) @U{21D2} #t +(enum=? color-red (enum-name->enum color 'red) color-blue) @U{21D2} #f +@end lisp +@end deffn + +@deffn {Scheme Procedure} enum? enum@sub{0} enum@sub{1} enum @dots{} +@deffnx {Scheme Procedure} enum<=? enum@sub{0} enum@sub{1} enum @dots{} +@deffnx {Scheme Procedure} enum>=? enum@sub{0} enum@sub{1} enum @dots{} + +These predicates return @code{#t} if their arguments are enums whose +ordinals are in increasing, decreasing, non-decreasing, and +non-increasing order respectively, and @code{#f} otherwise. It is an +error unless all of the arguments belong to the same enum type. + +@lisp +(enumenum color 0) (enum-ordinal->enum color 1)) +@U{21D2} #t +(enum>? (enum-ordinal->enum color 2) (enum-ordinal->enum color 1)) @U{21D2} #t +(enum>=? (enum-ordinal->enum color 2) + (enum-ordinal->enum color 1) + (enum-ordinal->enum color 1)) +@U{21D2} #t +@end lisp +@end deffn + +@node SRFI 209 Enum type constructor +@subsubsection SRFI 209 Enum type constructor + +@deffn {Scheme Procedure} make-enum-type list + +Returns a newly allocated enum type containing a fixed set of newly +allocated enums. Both enums and enum types are immutable, and it is not +possible to create an enum except as part of creating an enum type. + +The elements of @var{list} are either symbols or two-element lists, +where each list has a symbol as the first element and any value as the +second element. Each list element causes a single enum to be generated, +and the enum's name is specified by the symbol. It is an error unless +all the symbols are distinct within an enum type. The position of the +element in @var{list} is the ordinal of the corresponding enum, so +ordinals within an enum type are also distinct. If a value is given, it +becomes the value of the enum; otherwise the enum’s value is the same as +the ordinal. + +The following example enum types will be used in examples throughout +this SRFI, with the identifier @emph{type-name} referring to the enum of +type @emph{type} with name @emph{name}. + +@lisp +(define color + (make-enum-type '(red orange yellow green cyan blue violet))) +(define us-traffic-light + (make-enum-type '(red yellow green))) +(define pizza + (make-enum-type '((margherita "tomato and mozzarella") + (funghi "mushrooms") + (chicago "deep-dish") + (hawaiian "pineapple and ham")))) +@end lisp +@end deffn + +@node SRFI 209 Enum accessors +@subsubsection SRFI 209 Enum accessors + +@deffn {Scheme Procedure} enum-type enum + +Returns the enum type to which @var{enum} belongs. +@end deffn + +@deffn {Scheme Procedure} enum-name enum + +Returns the name (symbol) associated with @var{enum}. +@end deffn + +@deffn {Scheme Procedure} enum-ordinal enum + +Returns the ordinal (exact integer) associated with @var{enum}. +@end deffn + +@deffn {Scheme Procedure} enum-value enum + +Returns the value associated with @var{enum}. +@end deffn + +@node SRFI 209 Enum finders +@subsubsection SRFI 209 Enum finders + +These procedures use an enum type and one of the properties of an enum +to find the enum object. + +@deffn {Scheme Procedure} enum-name->enum enum-type symbol + +If there exists an enum belonging to @var{enum-type} named +@var{symbol}, returns it; otherwise return @code{#f}. + +@lisp +(enum-name (enum-name->enum color 'green)) @U{21D2} green +(enum-name->enum color 'mushroom) @U{21D2} #f +@end lisp +@end deffn + +@deffn {Scheme Procedure} enum-ordinal->enum enum-type exact-integer + +If there exists an enum belonging to @var{enum-type} whose ordinal is +@var{exact-integer}, returns it; otherwise return @code{#f}. + +@lisp +(enum-name (enum-ordinal->enum color 3)) @U{21D2} green +(enum-ordinal->enum color 10) @U{21D2} #f +@end lisp + +Note: There is no way to find an enum by its value, since values need +not be unique. + +The following convenience procedures provide enum-finding followed by access +to a property. +@end deffn + +@deffn {Scheme Procedure} enum-name->ordinal enum-type symbol + +Returns the ordinal of the enum belonging to @var{enum-type} whose name +is @var{symbol}. It is an error if there is no such enum. + +@lisp +(enum-name->ordinal color 'blue) @U{21D2} 5 +@end lisp +@end deffn + +@deffn {Scheme Procedure} enum-name->value enum-type symbol + +Returns the value of the enum belonging to @var{enum-type} whose name is +@var{symbol}. It is an error if there is no such enum. + +@lisp +(enum-name->value pizza 'funghi) @U{21D2} "mushrooms" +(enum-name->value color 'blue) @U{21D2} 5 +@end lisp +@end deffn + +@deffn {Scheme Procedure} enum-ordinal->name enum-type exact-integer + +Returns the name of the enum belonging to @var{enum-type} whose ordinal +is @var{exact-integer}. It is an error if there is no such enum. + +@lisp +(enum-ordinal->name color 0) @U{21D2} red +(enum-ordinal->name pizza 3) @U{21D2} hawaiian +@end lisp +@end deffn + +@deffn {Scheme Procedure} enum-ordinal->value enum-type exact-integer + +Returns the value of the enum belonging to @var{enum-type} whose ordinal +is @var{exact-integer}. It is an error if there is no such enum. + +@lisp +(enum-ordinal->value pizza 1) @U{21D2} "mushrooms" +@end lisp +@end deffn + +@node SRFI 209 Enum types +@subsubsection SRFI 209 Enum types + +@deffn {Scheme Procedure} enum-type-size enum-type + +Returns an exact integer equal to the number of enums in +@var{enum-type}. +@end deffn + +@deffn {Scheme Procedure} enum-min enum-type + +Returns the enum belonging to @var{enum-type} whose ordinal is 0. + +@lisp +(enum-name (enum-min color)) @U{21D2} red +(enum-name (enum-min pizza)) @U{21D2} margherita +@end lisp +@end deffn + +@deffn {Scheme Procedure} enum-max enum-type + +Returns the enum belonging to @var{enum-type} whose ordinal is equal to +the number of enums in the enum type minus 1. + +@lisp +(enum-name (enum-max color)) @U{21D2} violet +(enum-name (enum-max pizza)) @U{21D2} hawaiian +@end lisp +@end deffn + +@deffn {Scheme Procedure} enum-type-enums enum-type + +Returns a list of the enums belonging to @var{enum-type} ordered by +increasing ordinal. + +@lisp +(map enum-name (enum-type-enums pizza)) @U{21D2} (margherita funghi chicago hawaiian) +@end lisp +@end deffn + +@deffn {Scheme Procedure} enum-type-names enum-type + +Returns a list of the names of the enums belonging to @var{enum-type} +ordered by increasing ordinal. + +@lisp +(enum-type-names color) +@U{21D2} (red orange yellow green cyan blue violet) +@end lisp +@end deffn + +@deffn {Scheme Procedure} enum-type-values enum-type + +Returns a list of the values of the enums belonging to @var{enum-type} +ordered by increasing ordinal. + +@lisp +(enum-type-values pizza) +@U{21D2} ("tomato and mozzarella" "mushrooms" "deep-dish" "pineapple and ham") +@end lisp +@end deffn + +@node SRFI 209 Enum objects +@subsubsection SRFI 209 Enum objects + +@deffn {Scheme Procedure} enum-next enum + +Returns the enum that belongs to the same enum type as @var{enum} and +has an ordinal one greater than @var{enum}. Returns @code{#f} if there +is no such enum. + +@lisp +(enum-name (enum-next color-red)) @U{21D2} orange +(enum-next (enum-max color)) @U{21D2} #f +@end lisp +@end deffn + +@deffn {Scheme Procedure} enum-prev enum + +Returns the enum that belongs to the same enum type as @var{enum} and +has an ordinal one less than @var{enum}. Returns @code{#f} if there is +no such enum. + +@lisp +(enum-name (enum-prev color-orange)) @U{21D2} red +(enum-prev (enum-min color)) @U{21D2} #f +@end lisp +@end deffn + +@node SRFI 209 Comparators +@subsubsection SRFI 209 Comparators + +@deffn {Scheme Procedure} make-enum-comparator enum-type + +Returns a @url{https://srfi.schemers.org/srfi-128/srfi-128.html, SRFI +128} comparator suitable for comparing enums that belong to +@var{enum-type}. The comparator contains both an ordering predicate and +a hash function, and orders enums based on their ordinal values. + +@lisp +(define pizza-comparator (make-enum-comparator pizza)) +(comparator-hashable? pizza-comparator) @U{21D2} #t +(comparator-test-type pizza-comparator pizza-funghi) @U{21D2} #t +(enum-set enum-type + +Returns an enum set containing all the enums that belong to +@var{enum-type}. + +@lisp +(define color-set (enum-type->enum-set color)) +(define pizza-set (enum-type->enum-set pizza)) +(every (lambda (enum) + (enum-set-contains? pizza-set enum)) + (enum-type-enums pizza)) +@U{21D2} #t +(enum-set-map->list enum-name color-set) +@U{21D2} (red orange yellow green cyan blue violet) +@end lisp +@end deffn + +@deffn {Scheme Procedure} enum-set enum-type enum @dots{} + +Returns an enum set that can contain enums of the type @var{enum-type} +and containing the @var{enums}. It is an error unless all the +@var{enums} belong to @var{enum-type}. + +@lisp +(enum-set-contains? (enum-set color color-red color-blue) color-red) +@U{21D2} #t +(enum-set-contains? (enum-set color color-red color-blue) color-orange) +@U{21D2} #f +@end lisp +@end deffn + +@deffn {Scheme Procedure} list->enum-set enum-type list + +Returns an enum set with the specified @var{enum-type} that +contains the members of @var{list}. It is an error +unless all the members are enums belonging to @var{enum-type}. + +@lisp +(list->enum-set (enum-type-enums pizza)) + = (enum-type->enum-set pizza) +(enum-set-contains? (list->enum-set pizza (list pizza-funghi pizza-chicago)) + pizza-funghi) +@U{21D2} #t +@end lisp +@end deffn + +@deffn {Scheme Procedure} enum-set-projection enum-type-or-setenum-set + +If @var{enum-type-or-set} is an enum set, its enum type is extracted and +used; otherwise, the enum type is used directly. Returns an enum set +containing the enums belonging to the enum type that have the same names +as the members of @var{enum-set}, whose enum type need not be not the +same as the enum-type. It is an error if @var{enum-set} contains an +enum that does not correspond by name to an enum in the enum type of +@var{enum-type-or-set}. + +@lisp +(enum-set-projection us-traffic-light + (enum-set color color-red color-green color-blue)) + = (enum-set us-traffic-light + us-traffic-light-red us-traffic-light-green) +@end lisp +@end deffn + +@deffn {Scheme Procedure} enum-set-copy enum-set + +Returns a copy of @var{enum-set}. +@end deffn + +@deffn {Scheme Procedure} make-enumeration symbol-list [from R6RS, deprecated] + +Creates a newly allocated enum type. The names are the members of +@var{symbol-list}, and they appear in the enum set in the order given by +the list. The values are the same as the names. Then an enum set +containing all the enums of this enum type is newly allocated and +returned. The enum type can be retrieved with @code{enum-set-type}. +@end deffn + +@deffn {Scheme Procedure} enum-set-universe enum-set [from R6RS, deprecated] + +Retrieves the enum type of @var{enum-set}, and returns a newly allocated +enum set containing all the enums of the enum type. +@end deffn + +@deffn {Scheme Procedure} enum-set-constructor enum-set [from R6RS, deprecated] + +Returns a procedure that accepts one argument, a list of symbols. This +procedure returns a newly allocated enum set containing the enums whose +names are members of the list of symbols. It is an error if any of the +symbols is not the name of an enum in the enum type associated with +@var{enum-set}. +@end deffn + +@node SRFI 209 Enum set predicates +@subsubsection SRFI 209 Enum set predicates + +@deffn {Scheme Procedure} enum-set? obj + +Returns @code{#t} if @var{obj} is an enum-set and @code{#f} otherwise. +@end deffn + +@deffn {Scheme Procedure} enum-set-contains? enum-set enum + +Returns @code{#t} if @var{enum} is a member of @var{enum-set}. It is an +error if @var{enum} does not belong to the same enum type as the members +of @var{enum-set}. + +@lisp +(enum-set-contains? color-set color-blue) @U{21D2} #t +(enum-set-contains? (enum-set-delete! color-set color-blue) color-blue) @U{21D2} #f +@end lisp +@end deffn + +@deffn enum-set-member? symbol enum-set [from R6RS, deprecated] + +Returns @code{#t} if @var{symbol} is the name of a member of +@var{enum-set}. It is an error if @var{symbol} is not the name of an +enum belonging to the enum type of @var{enum-set}. +@end deffn + +@deffn {Scheme Procedure} enum-set-empty? enum-set + +Returns @code{#t} if @var{enum-set} is empty, and @code{#f} otherwise. + +@lisp +(enum-set-empty? color-set) @U{21D2} #f +(enum-set-empty? (enum-set-delete-all! color-set (enum-set->enum-list color-set))) +@U{21D2} #t +@end lisp +@end deffn + +@deffn {Scheme Procedure} enum-set-disjoint? enum-set@sub{1} enum-set@sub{2} + +Returns @code{#t} if @var{enum-set@sub{1}} and @var{enum-set@sub{2}} do +not have any enum objects in common, and @code{#f} otherwise. It is an +error if the members of the enum sets do not belong to the same type. + +@lisp +(define reddish + (list->enum-set (map (lambda (name) + (enum-name->enum color name)) + '(red orange)))) +(define ~reddish + (list->enum-set (map (lambda (name) + (enum-name->enum color name)) + '(yellow green cyan blue violet)))) +(enum-set-disjoint? color-set reddish) @U{21D2} #f +(enum-set-disjoint? reddish ~reddish) @U{21D2} #t +@end lisp +@end deffn + +Note that the following three procedures do not obey the trichotomy law, +and cannot be used to define a comparator. + +@deffn {Scheme Procedure} enum-set=? enum-set-1 enum-set-2 +@deffnx {Scheme Procedure} enum-set? enum-set-1 enum-set-2 +@deffnx {Scheme Procedure} enum-set<=? enum-set-1 enum-set-2 +@deffnx {Scheme Procedure} enum-set>=? enum-set-1 enum-set-2 + +Returns @code{#t} if the members of @var{enum-set-1} are the same as / a +proper subset of / a proper superset of / a subset of / a superset of +@var{enum-set-2}. It is an error if the members of the enum sets do not +belong to the same type. + +@lisp +(enum-set=? color-set (enum-set-copy color-set)) @U{21D2} #t +(enum-set=? color-set reddish) @U{21D2} #f +(enum-set? reddish color-set) @U{21D2} #f +(enum-set<=? reddish color-set) @U{21D2} #t +(enum-set>=? reddish color-set) @U{21D2} #f +@end lisp +@end deffn + +@deffn {Scheme Procedure} enum-set-subset? enum-set-1 enum-set-2 + +Returns @code{#t} if the set of the names of the elements of +@var{enum-set-1} is a subset of the set of the names of the elements of +@var{enum-set-2}. Otherwise returns @code{#f}. Note that +@var{enum-set-1} and @var{enum-set-2} can be of different enum types. + +@lisp +(enum-set-subset? (enum-set color red blue) + (enum-set color red green blue)) @U{21D2} #t +(enum-set-subset? (enum-set us-traffic-light red green) + (enum-set color red green blue)) @U{21D2} #t +@end lisp +@end deffn + +@deffn {Scheme Procedure} enum-set-any? pred enum-set +@deffnx {Scheme Procedure} enum-set-every? pred enum-set + +Returns @code{#t} if any/every application of @var{proc} to the elements +of @var{enum-set} returns true, and @code{#f} otherwise. + +@lisp +(enum-set-any? (lambda (e) (eqv? 'green (enum-name e))) + color-set) +@U{21D2} #t +(enum-set-any? (lambda (e) (eqv? 'green (enum-name e))) + reddish) +@U{21D2} #f +(enum-set-every? (lambda (e) (eq? 'green (enum-name e))) + color-set) +@U{21D2} #f +(enum-set-every? (lambda (e) (string? (enum-value e))) + pizza-set) +@U{21D2} #t +@end lisp +@end deffn + +@node SRFI 209 Enum set accessors +@subsubsection SRFI 209 Enum set accessors + +@deffn {Scheme Procedure} enum-set-type enum-set + +Returns the enum type associated with @var{enum-set}. +@end deffn + +@deffn enum-set-indexer enum-set [from R6RS, deprecated] + +Returns a procedure that accepts one argument, a symbol. When this +procedure is called, if the symbol is the name of an enum in the enum +type associated with @var{enum-set}, then the ordinal of that enum is +returned. Otherwise, @code{#f} is returned. +@end deffn + +@node SRFI 209 Enum set mutators +@subsubsection SRFI 209 Enum set mutators + +These procedures come in pairs. Procedures whose names end in @samp{!} +are linear-update: that is, they may or may not modify their +@var{enum-set} argument, and any existing references to it are +invalidated. Other procedures are functional and return a newly +allocated modified copy of their @var{enum-set} argument. + +@deffn {Scheme Procedure} enum-set-adjoin enum-set enum @dots{} +@deffnx {Scheme Procedure} enum-set-adjoin! enum-set enum @dots{} + +Returns an enum set that contains the members of @var{enum-set} and the +@var{enums}. It is an error if the members of the result do not all +belong to the same enum type. + +@lisp +(define reddish+blue + (enum-set-adjoin! (enum-set-copy reddish) color-blue)) +(enum-setenum-list color-set))) +(enum-setenum-list enum-set +@deffnx {Scheme Procedure} enum-set->list enum-set [from R6RS, deprecated] + +Returns a list containing the members of @var{enum-set}, whereas the +@code{set->enum-list} procedure returns a list containing the names of +the members of @var{enum-set}. In either case, the list will be in +increasing order of the enums. + +@lisp +(map enum-name (enum-set->enum-list reddish)) @U{21D2} (red orange) +(list->enum-set (enum-set->enum-list color-set)) @U{21D2} color-set +@end lisp +@end deffn + +@deffn {Scheme Procedure} enum-set-count pred enum-set + +Returns an exact integer, the number of elements of @var{enum-set} that +satisfy @var{pred}. + +@lisp +(enum-set-count (lambda (e) (> (enum-ordinal e) 3)) + color-set) +@U{21D2} 3 +@end lisp +@end deffn + +@deffn {Scheme Procedure} enum-set-filter pred enum-set +@deffnx {Scheme Procedure} enum-set-remove pred enum-set + +Returns an enum set containing the enums in @var{enum-set} that satisfy +/ do not satisfy @var{pred}. +@end deffn + +@deffn {Scheme Procedure} enum-set-map->list proc enum-set + +Invokes @var{proc} on each member of @var{enum-set} in increasing +ordinal order. The results are made into a list and returned. + +@lisp +(enum-set-map->list enum-name + (enum-set-filter (lambda (e) (> (enum-ordinal e) 3)) + color-set)) +@U{21D2} '(cyan blue violet) +@end lisp +@end deffn + +@deffn {Scheme Procedure} enum-set-for-each proc enum-set + +Invokes @var{proc} on each member of @var{enum-set} in increasing +ordinal order and discards the rest. The result is an unspecified +value. + +@lisp +(let ((s "")) + (begin + (enum-set-for-each (lambda (e) + (set! s (string-append s (enum-value e) " "))) + (enum-set pizza pizza-margherita pizza-chicago)) + s)) +@U{21D2} "tomato and mozzarella deep-dish " +@end lisp +@end deffn + +@deffn {Scheme Procedure} enum-set-fold proc nil enum-set + +The current state is initialized to @var{nil}, and @var{proc} is invoked +on each element of @var{enum-set} in increasing ordinal order and the +current state, setting the current state to the result. The algorithm +is repeated until all the elements of @var{enum-set} have been +processed. Then the current state is returned. + +@lisp +(enum-set-fold cons '() color-set) + = (reverse (enum-set->enum-list color-set)) +@end lisp +@end deffn + +@node SRFI 209 Enum set logical operations +@subsubsection SRFI 209 Enum set logical operations + +These procedures come in pairs. Procedures whose names end in @code{!} +are linear-update: that is, they may or may not modify their +@var{enum-set} argument(s), and any existing references to them are +invalidated. Other procedures are functional and return a newly +allocated modified copy of their @var{enum-set} argument. + +@deffn {Scheme Procedure} enum-set-complement enum-set +@deffnx {Scheme Procedure} enum-set-complement! enum-set + +Returns an enum set that contains the elements of the enum type of +@var{enum-set} that are not members of @var{enum-set}. +@end deffn + +@deffn {Scheme Procedure} enum-set-union enum-set-1 enum-set-2 +@deffnx {Scheme Procedure} enum-set-union! enum-set-1 enum-set-2 + +Returns an enum set containing all the elements of either +@var{enum-set-1} or @var{enum-set-2}. It is an error if all the +elements of the result do not belong to the same enum type. + +@lisp +(enum-set-map->list enum-name + (enum-set-union! (enum-set color color-orange) + (enum-set color color-blue))) +@U{21D2} (orange blue) +(enum-set=? color-set (enum-set-union! reddish ~reddish)) @U{21D2} #t +@end lisp +@end deffn + +@deffn {Scheme Procedure} enum-set-intersection enum-set-1 enum-set-2 +@deffnx {Scheme Procedure} enum-set-intersection! enum-set-1 enum-set-2 + +Returns an enum set containing all the elements that appear in both +@var{enum-set-1} and @var{enum-set-2}. It is an error if all the +elements of the result do not belong to the same enum type. + +@lisp +(enum-set-empty? (enum-set-intersection! reddish ~reddish)) +@U{21D2} #t +@end lisp +@end deffn + +@deffn {Scheme Procedure} enum-set-difference enum-set-1enum-set-2 +@deffnx {Scheme Procedure} enum-set-difference! enum-set-1enum-set-2 + +Returns an enum set containing the elements of @var{enum-set-1} but not +@var{enum-set-2}. It is an error if all the elements of the result do +not belong to the same enum type. + +@lisp +(enum-set=? ~reddish (enum-set-difference! color-set reddish)) +@U{21D2} #t +@end lisp +@end deffn + +@deffn {Scheme Procedure} enum-set-xor enum-set-1 enum-set-2 +@deffnx {Scheme Procedure} enum-set-xor! enum-set-1enum-set-2 + +Returns an enum set containing all the elements that appear in either +@var{enum-set-1} or @var{enum-set-2} but not both. It is an error if all +the elements of the result do not belong to the same enum type. + +@lisp +(enum-set=? color-set (enum-set-xor! reddish ~reddish)) +@U{21D2} #t +(enum-set-empty? (enum-set-xor! reddish reddish)) @U{21D2} #t +@end lisp +@end deffn + +@node SRFI 209 Syntax +@subsubsection SRFI 209 Syntax + +@deffn {Scheme Syntax} define-enum type-name name-value dots{} constructor-syntax +@deffnx {Scheme Syntax} define-enumeration type-name name-value @dots{} constructor-syntax [from R6RS, deprecated] + +These macros allocate a newly created enum type and provide two macros +for constructing its members and sets of its members. They are +definitions and can appear anywhere any other definition can appear. +Each is either a symbol naming an enum or a two-element +list specifying the name and value of an enum. + + is an identifier that is bound to a macro. When +is invoked as @samp{( )}, it returns the enum named + in the case of @code{define-enum} or the symbol itself in the +case of @code{define-enumeration}. If the symbol does not name any enum +of the enum-type, an error is signaled. + + is an identifier that is bound to a macro that, +given any finite sequence of the names of enums, possibly with +duplicates, expands into an expression that evaluates to an enum set of +those enums. If any of the symbols does not name any enum of the +enum-type, an error is signaled. + +@end deffn + @c srfi-modules.texi ends here @c Local Variables: diff --git a/module/srfi/srfi-209.sld b/module/srfi/srfi-209.sld new file mode 100644 index 000000000..725ebb3fa --- /dev/null +++ b/module/srfi/srfi-209.sld @@ -0,0 +1,60 @@ +(define-library (srfi 209) + (import (rnrs syntax-case (6)) + (scheme base) + (scheme case-lambda) + (srfi 1) + (srfi 125) + (srfi 128) + (srfi 178)) + + (cond-expand + ((library (srfi 162)) + (import (srfi 162))) + (else + (begin + (define real-comparator + (make-comparator real? = < number-hash))))) + + (export enum-type? enum? enum-type-contains? enum=? enum? + enum<=? enum>=? + + make-enum-type + + enum-type enum-name enum-ordinal enum-value + + enum-name->enum enum-ordinal->enum enum-name->ordinal + enum-name->value enum-ordinal->name enum-ordinal->value + + enum-type-size enum-min enum-max enum-type-enums + enum-type-names enum-type-values + + enum-next enum-prev + + enum-type->enum-set enum-set list->enum-set enum-set-projection + enum-set-copy enum-empty-set make-enumeration enum-set-universe + enum-set-constructor enum-set-type enum-set-indexer + + enum-set? enum-set-contains? enum-set=? enum-set-member? + enum-set-empty? enum-set-disjoint? enum-set? + enum-set<=? enum-set>=? enum-set-any? enum-set-every? + enum-set-subset? + + enum-set-adjoin! enum-set-delete! enum-set-delete-all! + enum-set-adjoin enum-set-delete enum-set-delete-all + + enum-set-size enum-set->list enum-set-map->list enum-set-for-each + enum-set-filter enum-set-remove enum-set-count enum-set-fold + enum-set->enum-list + enum-set-filter! enum-set-remove! + + enum-set-union enum-set-intersection enum-set-difference + enum-set-xor enum-set-complement enum-set-union! + enum-set-intersection! enum-set-difference! enum-set-xor! + enum-set-complement! + + make-enum-comparator + + define-enum define-enumeration + ) + + (include "srfi-209/209.scm")) diff --git a/module/srfi/srfi-209/209.scm b/module/srfi/srfi-209/209.scm new file mode 100644 index 000000000..5525b6624 --- /dev/null +++ b/module/srfi/srfi-209/209.scm @@ -0,0 +1,691 @@ +;;; Copyright (C) 2020 Wolfgang Corcoran-Mathe +;;; +;;; 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. +;;; + +;;;; Utility + +(define-syntax assert + (syntax-rules () + ((assert expr) + (unless expr + (error "assertion failed" 'expr))) + ((assert expr msg) + (unless expr + (error msg 'expr))))) + +(define (exact-natural? obj) + (and (exact-integer? obj) (not (negative? obj)))) + +(define (bitvector-subset? vec1 vec2) + (let loop ((i (- (bitvector-length vec1) 1))) + (cond ((< i 0) #t) + ((and (bitvector-ref/bool vec1 i) + (zero? (bitvector-ref/int vec2 i))) + #f) + (else (loop (- i 1)))))) + +;;;; Types + +(define-record-type + (make-raw-enum-type enum-vector name-table comparator) + enum-type? + (enum-vector enum-type-enum-vector set-enum-type-enum-vector!) + (name-table enum-type-name-table set-enum-type-name-table!) + (comparator enum-type-comparator set-enum-type-comparator!)) + +(define-record-type + (make-enum type name ordinal value) + enum? + (type enum-type) + (name enum-name) + (ordinal enum-ordinal) + (value enum-value)) + +(define (make-enum-type names+vals) + (assert (or (pair? names+vals) (null? names+vals)) + "argument must be a proper list") + (let* ((type (make-raw-enum-type #f #f #f)) + (enums (generate-enums type names+vals))) + (set-enum-type-enum-vector! type (list->vector enums)) + (set-enum-type-name-table! type (make-name-table enums)) + (set-enum-type-comparator! type (make-enum-comparator type)) + type)) + +(define (generate-enums type names+vals) + (map (lambda (elt ord) + (cond ((and (pair? elt) (= 2 (length elt)) (symbol? (car elt))) + (make-enum type (car elt) ord (cadr elt))) + ((symbol? elt) (make-enum type elt ord ord)) + (else (error "make-enum-type: invalid argument" elt)))) + names+vals + (iota (length names+vals)))) + +(define symbol-comparator + (make-comparator symbol? + eqv? + (lambda (sym1 sym2) + (stringstring sym1) + (symbol->string sym2))) + symbol-hash)) + +(define (make-name-table enums) + (hash-table-unfold null? + (lambda (enums) + (values (enum-name (car enums)) (car enums))) + cdr + enums + symbol-comparator)) + +(define (%enum-type=? etype1 etype2) + (eqv? etype1 etype2)) + +(define (make-enum-comparator type) + (make-comparator + (lambda (obj) + (and (enum? obj) (eq? (enum-type obj) type))) + eq? + (lambda (enum1 enum2) + (< (enum-ordinal enum1) (enum-ordinal enum2))) + (lambda (enum) + (symbol-hash (enum-name enum))))) + +;;;; Predicates + +(define (enum-type-contains? type enum) + (assert (enum-type? type)) + (assert (enum? enum)) + ((comparator-type-test-predicate (enum-type-comparator type)) enum)) + +(define (%enum-type-contains?/no-assert type enum) + ((comparator-type-test-predicate (enum-type-comparator type)) enum)) + +(define (%well-typed-enum? type obj) + (and (enum? obj) (%enum-type-contains?/no-assert type obj))) + +(define (%compare-enums compare enums) + (assert (and (pair? enums) (pair? (cdr enums))) + "invalid number of arguments") + (assert (enum? (car enums))) + (let ((type (enum-type (car enums)))) + (assert (every (lambda (e) (%well-typed-enum? type e)) (cdr enums)) + "enums must all belong to the same type") + (apply compare (enum-type-comparator type) enums))) + +(define (enum=? enum1 enum2 . enums) + (assert (enum? enum1)) + (let* ((type (enum-type enum1)) + (comp (enum-type-comparator type))) + (cond ((null? enums) ; fast path + (assert (%well-typed-enum? type enum2) + "enums must all belong to the same type") + ((comparator-equality-predicate comp) enum1 enum2)) + (else ; variadic path + (assert (every (lambda (e) (%well-typed-enum? type e)) enums) + "enums must all belong to the same type") + (apply =? comp enum1 enum2 enums))))) + +(define (enum? . enums) (%compare-enums >? enums)) + +(define (enum<=? . enums) (%compare-enums <=? enums)) + +(define (enum>=? . enums) (%compare-enums >=? enums)) + +;;;; Enum finders + +;;; Core procedures + +(define (enum-name->enum type name) + (assert (enum-type? type)) + (assert (symbol? name)) + (hash-table-ref/default (enum-type-name-table type) name #f)) + +(define (enum-ordinal->enum enum-type ordinal) + (assert (enum-type? enum-type)) + (assert (exact-natural? ordinal)) + (and (< ordinal (enum-type-size enum-type)) + (vector-ref (enum-type-enum-vector enum-type) ordinal))) + +;; Fast version for internal use. +(define (%enum-ordinal->enum-no-assert enum-type ordinal) + (vector-ref (enum-type-enum-vector enum-type) ordinal)) + +;;; Derived procedures + +(define (%enum-project type finder key proc) + (assert (enum-type? type)) + (cond ((finder type key) => proc) + (else (error "no enum found" type key)))) + +(define (enum-name->ordinal type name) + (assert (symbol? name)) + (%enum-project type enum-name->enum name enum-ordinal)) + +(define (enum-name->value type name) + (assert (symbol? name)) + (%enum-project type enum-name->enum name enum-value)) + +(define (enum-ordinal->name type ordinal) + (assert (exact-natural? ordinal)) + (%enum-project type %enum-ordinal->enum-no-assert ordinal enum-name)) + +(define (enum-ordinal->value type ordinal) + (assert (exact-natural? ordinal)) + (%enum-project type %enum-ordinal->enum-no-assert ordinal enum-value)) + +;;;; Enum type accessors + +(define (enum-type-size type) + (assert (enum-type? type)) + (vector-length (enum-type-enum-vector type))) + +(define (enum-min type) + (assert (enum-type? type)) + (vector-ref (enum-type-enum-vector type) 0)) + +(define (enum-max type) + (assert (enum-type? type)) + (let ((vec (enum-type-enum-vector type))) + (vector-ref vec (- (vector-length vec) 1)))) + +(define (enum-type-enums type) + (assert (enum-type? type)) + (vector->list (enum-type-enum-vector type))) + +(define (enum-type-names type) + (assert (enum-type? type)) + (let ((vec (enum-type-enum-vector type))) + (list-tabulate (vector-length vec) + (lambda (n) (enum-name (vector-ref vec n)))))) + +(define (enum-type-values type) + (assert (enum-type? type)) + (let ((vec (enum-type-enum-vector type))) + (list-tabulate (vector-length vec) + (lambda (n) (enum-value (vector-ref vec n)))))) + +;;;; Enum object procedures + +(define (enum-next enum) + (assert (enum? enum)) + (enum-ordinal->enum (enum-type enum) (+ (enum-ordinal enum) 1))) + +(define (enum-prev enum) + (assert (enum? enum)) + (let ((ord (enum-ordinal enum))) + (and (> ord 0) + (enum-ordinal->enum (enum-type enum) (- ord 1))))) + +;;;; Enum set constructors + +(define-record-type + (make-enum-set type bitvector) + enum-set? + (type enum-set-type) + (bitvector enum-set-bitvector set-enum-set-bitvector!)) + +(define (enum-empty-set type) + (assert (enum-type? type)) + (make-enum-set type (make-bitvector (enum-type-size type) #f))) + +(define (enum-type->enum-set type) + (assert (enum-type? type)) + (make-enum-set type (make-bitvector (enum-type-size type) #t))) + +(define (enum-set type . enums) (list->enum-set type enums)) + +(define (list->enum-set type enums) + (assert (or (pair? enums) (null? enums)) + "argument must be a proper list") + (let ((vec (make-bitvector (enum-type-size type) #f))) + (for-each (lambda (e) + (assert (%well-typed-enum? type e) "ill-typed enum") + (bitvector-set! vec (enum-ordinal e) #t)) + enums) + (make-enum-set type vec))) + +;; Returns a set of enums drawn from the enum-type/-set src with +;; the same names as the enums of eset. +(define (enum-set-projection src eset) + (assert (or (enum-type? src) (enum-set? src)) + "argument must be an enum type or enum set") + (assert (enum-set? eset)) + (let ((type (if (enum-type? src) src (enum-set-type src)))) + (list->enum-set + type + (enum-set-map->list + (lambda (enum) + (let ((name (enum-name enum))) + (or (enum-name->enum type name) + (error "enum name not found in type" name type)))) + eset)))) + +(define (enum-set-copy eset) + (make-enum-set (enum-set-type eset) + (bitvector-copy (enum-set-bitvector eset)))) + +;; [Deprecated] +(define (make-enumeration names) + (enum-type->enum-set (make-enum-type (zip names names)))) + +;; [Deprecated] +(define (enum-set-universe eset) + (assert (enum-set? eset)) + (enum-type->enum-set (enum-set-type eset))) + +;; [Deprecated] Returns a procedure which takes a list of symbols +;; and returns an enum set containing the corresponding enums. This +;; extracts the type of eset, but otherwise ignores this argument. +(define (enum-set-constructor eset) + (assert (enum-set? eset)) + (let ((type (enum-set-type eset))) + (lambda (names) + (list->enum-set type + (map (lambda (sym) + (or (enum-name->enum type sym) + (error "invalid enum name" sym))) + names))))) + +;; [Deprecated] Returns a procedure which takes a symbol and returns +;; the corresponding enum ordinal or #f. This doesn't make any use +;; of eset, beyond pulling out its enum type. +(define (enum-set-indexer eset) + (assert (enum-set? eset)) + (let ((type (enum-set-type eset))) + (lambda (name) + (cond ((enum-name->enum type name) => enum-ordinal) + (else #f))))) + +;;;; Enum set predicates + +(define (enum-set-contains? eset enum) + (assert (enum-set? eset)) + (assert (%well-typed-enum? (enum-set-type eset) enum) + "enum types of arguments must match") + (bitvector-ref/bool (enum-set-bitvector eset) (enum-ordinal enum))) + +;; FIXME: Avoid double (type, then set) lookup. +(define (enum-set-member? name eset) + (assert (symbol? name)) + (assert (enum-set? eset)) + (bitvector-ref/bool (enum-set-bitvector eset) + (enum-name->ordinal (enum-set-type eset) name))) + +(define (%enum-set-type=? eset1 eset2) + (%enum-type=? (enum-set-type eset1) (enum-set-type eset2))) + +(define (enum-set-empty? eset) + (assert (enum-set? eset)) + (zero? (bitvector-count #t (enum-set-bitvector eset)))) + +(define (bit-nand a b) + (not (and (= 1 a) (= 1 b)))) + +(define (enum-set-disjoint? eset1 eset2) + (assert (enum-set? eset1)) + (assert (enum-set? eset2)) + (assert (%enum-type=? (enum-set-type eset1) (enum-set-type eset2)) + "arguments must have the same enum type") + (let ((vec1 (enum-set-bitvector eset1)) + (vec2 (enum-set-bitvector eset2))) + (let ((len (bitvector-length vec1))) + (let loop ((i 0)) + (or (= i len) + (and (bit-nand (bitvector-ref/int vec1 i) + (bitvector-ref/int vec2 i)) + (loop (+ i 1)))))))) + +(define (enum-set=? eset1 eset2) + (assert (%enum-type=? (enum-set-type eset1) (enum-set-type eset2)) + "arguments must have the same enum type") + (bitvector=? (enum-set-bitvector eset1) (enum-set-bitvector eset2))) + +(define (enum-set? eset1 eset2) + (assert (enum-set? eset1)) + (assert (enum-set? eset2)) + (assert (%enum-type=? (enum-set-type eset1) (enum-set-type eset2)) + "arguments must have the same enum type") + (let ((vec1 (enum-set-bitvector eset1)) + (vec2 (enum-set-bitvector eset2))) + (and (bitvector-subset? vec2 vec1) + (not (bitvector=? vec1 vec2))))) + +(define (enum-set<=? eset1 eset2) + (assert (enum-set? eset1)) + (assert (enum-set? eset2)) + (assert (%enum-type=? (enum-set-type eset1) (enum-set-type eset2)) + "arguments must have the same enum type") + (bitvector-subset? (enum-set-bitvector eset1) + (enum-set-bitvector eset2))) + +(define (enum-set>=? eset1 eset2) + (assert (enum-set? eset1)) + (assert (enum-set? eset2)) + (assert (%enum-type=? (enum-set-type eset1) (enum-set-type eset2)) + "arguments must have the same enum type") + (bitvector-subset? (enum-set-bitvector eset2) + (enum-set-bitvector eset1))) + +;; This uses lists as sets and is thus not very efficient. +;; An implementation with SRFI 113 or some other set library +;; might want to optimize this. +(define (enum-set-subset? eset1 eset2) + (assert (enum-set? eset1)) + (assert (enum-set? eset2)) + (lset<= eqv? + (enum-set-map->list enum-name eset1) + (enum-set-map->list enum-name eset2))) + +(define (enum-set-any? pred eset) + (assert (procedure? pred)) + (call-with-current-continuation + (lambda (return) + (enum-set-fold (lambda (e _) (and (pred e) (return #t))) + #f + eset)))) + +(define (enum-set-every? pred eset) + (assert (procedure? pred)) + (call-with-current-continuation + (lambda (return) + (enum-set-fold (lambda (e _) (or (pred e) (return #f))) + #t + eset)))) + +;;;; Enum set mutators + +(define (enum-set-adjoin eset . enums) + (apply enum-set-adjoin! (enum-set-copy eset) enums)) + +(define enum-set-adjoin! + (case-lambda + ((eset enum) ; fast path + (assert (enum-set? eset)) + (assert (%well-typed-enum? (enum-set-type eset) enum) + "arguments must have the same enum type") + (bitvector-set! (enum-set-bitvector eset) (enum-ordinal enum) #t) + eset) + ((eset . enums) ; variadic path + (assert (enum-set? eset)) + (let ((type (enum-set-type eset)) + (vec (enum-set-bitvector eset))) + (for-each (lambda (e) + (assert (%well-typed-enum? type e) + "arguments must have the same enum type") + (bitvector-set! vec (enum-ordinal e) #t)) + enums) + eset)))) + +(define (enum-set-delete eset . enums) + (apply enum-set-delete! (enum-set-copy eset) enums)) + +(define enum-set-delete! + (case-lambda + ((eset enum) ; fast path + (assert (enum-set? eset)) + (assert (%well-typed-enum? (enum-set-type eset) enum) + "arguments must have the same enum type") + (bitvector-set! (enum-set-bitvector eset) (enum-ordinal enum) #f) + eset) + ((eset . enums) ; variadic path + (enum-set-delete-all! eset enums)))) + +(define (enum-set-delete-all eset enums) + (enum-set-delete-all! (enum-set-copy eset) enums)) + +(define (enum-set-delete-all! eset enums) + (assert (enum-set? eset)) + (assert (or (pair? enums) (null? enums)) + "argument must be a proper list") + (unless (null? enums) + (let ((type (enum-set-type eset)) + (vec (enum-set-bitvector eset))) + (for-each (lambda (e) + (assert (%well-typed-enum? type e) + "arguments must have the same enum type") + (bitvector-set! vec (enum-ordinal e) #f)) + enums))) + eset) + +;;;; Enum set operations + +(define (enum-set-size eset) + (assert (enum-set? eset)) + (bitvector-count #t (enum-set-bitvector eset))) + +(define (enum-set->enum-list eset) + (assert (enum-set? eset)) + (enum-set-map->list values eset)) + +(define (enum-set->list eset) + (enum-set-map->list enum-name eset)) + +;; Slightly complicated by the order in which proc is applied. +(define (enum-set-map->list proc eset) + (assert (procedure? proc)) + (assert (enum-set? eset)) + (let* ((vec (enum-set-bitvector eset)) + (len (bitvector-length vec)) + (type (enum-set-type eset))) + (letrec + ((build + (lambda (i) + (cond ((= i len) '()) + ((bitvector-ref/bool vec i) + (cons (proc (%enum-ordinal->enum-no-assert type i)) + (build (+ i 1)))) + (else (build (+ i 1))))))) + (build 0)))) + +(define (enum-set-count pred eset) + (assert (procedure? pred)) + (enum-set-fold (lambda (e n) (if (pred e) (+ n 1) n)) 0 eset)) + +(define (enum-set-filter pred eset) + (enum-set-filter! pred (enum-set-copy eset))) + +(define (enum-set-filter! pred eset) + (assert (procedure? pred)) + (assert (enum-set? eset)) + (let* ((type (enum-set-type eset)) + (vec (enum-set-bitvector eset))) + (let loop ((i (- (bitvector-length vec) 1))) + (cond ((< i 0) eset) + ((and (bitvector-ref/bool vec i) + (not (pred (%enum-ordinal->enum-no-assert type i)))) + (bitvector-set! vec i #f) + (loop (- i 1))) + (else (loop (- i 1))))))) + +(define (enum-set-remove pred eset) + (enum-set-remove! pred (enum-set-copy eset))) + +(define (enum-set-remove! pred eset) + (assert (procedure? pred)) + (assert (enum-set? eset)) + (let* ((type (enum-set-type eset)) + (vec (enum-set-bitvector eset))) + (let loop ((i (- (bitvector-length vec) 1))) + (cond ((< i 0) eset) + ((and (bitvector-ref/bool vec i) + (pred (%enum-ordinal->enum-no-assert type i))) + (bitvector-set! vec i #f) + (loop (- i 1))) + (else (loop (- i 1))))))) + +(define (enum-set-for-each proc eset) + (assert (procedure? proc)) + (enum-set-fold (lambda (e _) (proc e)) '() eset)) + +(define (enum-set-fold proc nil eset) + (assert (procedure? proc)) + (assert (enum-set? eset)) + (let ((type (enum-set-type eset))) + (let* ((vec (enum-set-bitvector eset)) + (len (bitvector-length vec))) + (let loop ((i 0) (state nil)) + (cond ((= i len) state) + ((bitvector-ref/bool vec i) + (loop (+ i 1) + (proc (%enum-ordinal->enum-no-assert type i) state))) + (else (loop (+ i 1) state))))))) + +;;;; Enum set logical operations + +(define (%enum-set-logical-op! bv-proc eset1 eset2) + (assert (enum-set? eset1)) + (assert (enum-set? eset2)) + (assert (%enum-set-type=? eset1 eset2) + "arguments must have the same enum type") + (bv-proc (enum-set-bitvector eset1) (enum-set-bitvector eset2)) + eset1) + +(define (enum-set-union eset1 eset2) + (%enum-set-logical-op! bitvector-ior! (enum-set-copy eset1) eset2)) + +(define (enum-set-intersection eset1 eset2) + (%enum-set-logical-op! bitvector-and! (enum-set-copy eset1) eset2)) + +(define (enum-set-difference eset1 eset2) + (%enum-set-logical-op! bitvector-andc2! (enum-set-copy eset1) eset2)) + +(define (enum-set-xor eset1 eset2) + (%enum-set-logical-op! bitvector-xor! (enum-set-copy eset1) eset2)) + +(define (enum-set-union! eset1 eset2) + (%enum-set-logical-op! bitvector-ior! eset1 eset2)) + +(define (enum-set-intersection! eset1 eset2) + (%enum-set-logical-op! bitvector-and! eset1 eset2)) + +(define (enum-set-difference! eset1 eset2) + (%enum-set-logical-op! bitvector-andc2! eset1 eset2)) + +(define (enum-set-xor! eset1 eset2) + (%enum-set-logical-op! bitvector-xor! eset1 eset2)) + +(define (enum-set-complement eset) + (enum-set-complement! (enum-set-copy eset))) + +(define (enum-set-complement! eset) + (assert (enum-set? eset)) + (bitvector-not! (enum-set-bitvector eset)) + eset) + +;;;; Syntax + +;; Defines a new enum-type T, binds type-name to a macro which takes a +;; symbol to an enum in T, and binds constructor to a macro taking +;; symbols to an enum set of type T. This is the newer syntax-case +;; based version found in 'contrib/zipheir/define-enum-sc.scm' that +;; does a lot of the work at expansion time. +(define-syntax define-enum + (lambda (stx) + (define (parse-name-val nv-syn) + (syntax-case nv-syn () + (id (identifier? #'id) #'id) + ((id _) (identifier? #'id) #'id) + (_ (syntax-violation 'define-enum + "invalid enum syntax" stx nv-syn)))) + + (define (unique-ids? ids) + (let unique ((ids ids)) + (or (null? ids) + (let ((id (car ids)) (rest (cdr ids))) + (and (not (find (lambda (x) (free-identifier=? x id)) + rest)) + (unique rest)))))) + + (syntax-case stx () + ((_ type-name (name-val ...) constructor) + (and (identifier? #'type-name) + (identifier? #'constructor)) + (with-syntax (((name ...) (map parse-name-val #'(name-val ...))) + ((idx ...) (iota (length #'(name-val ...))))) + (unless (unique-ids? #'(name ...)) + (syntax-violation 'define-enum + "duplicated enum names" stx #'(quote (name ...)))) + (syntax + (begin + (define new-type (make-enum-type '(name-val ...))) + + ;; Helper + (define-syntax enum-name-to-ordinal-syn + (syntax-rules (name ...) + ((_ loc name) idx) ... + ((_ loc x) + (syntax-violation 'loc "invalid enum name" 'x)))) + + (define-syntax type-name + (syntax-rules () + ((_ (x . _)) + (syntax-violation 'type-name "invalid syntax" 'x)) + ((_ id) + (%enum-ordinal->enum-no-assert + new-type + (enum-name-to-ordinal-syn type-name id))))) + + (... ; escape ellipsis for the following + (define-syntax constructor + (lambda (stx) + (syntax-case stx () + ((_ arg ...) + (every identifier? #'(arg ...)) + (syntax + (let ((vec (make-bitvector (enum-type-size new-type) + #f))) + ;; Unroll for-each loop + (bitvector-set! + vec + (enum-name-to-ordinal-syn constructor arg) + #t) ... + (make-enum-set new-type vec))))))))))))))) + +;; [Deprecated] As define-enum, except that type-name is bound to +;; a macro that returns its symbol argument if the corresponding +;; enum is in the new type. +(define-syntax define-enumeration + (syntax-rules () + ((_ type-name (name-val ...) constructor) + (begin + (define etype (make-enum-type '(name-val ...))) + (define-syntax type-name + (syntax-rules () + ((_ name) + (and (enum-name->enum etype 'name) 'name)))) + (define-syntax constructor + (syntax-rules () + ((_ . names) + (list->enum-set etype + (map (lambda (s) + (enum-name->enum etype s)) + 'names))))))))) diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am index 6ee26e869..2b5156923 100644 --- a/test-suite/Makefile.am +++ b/test-suite/Makefile.am @@ -170,6 +170,7 @@ SCM_TESTS = tests/00-initial-env.test \ tests/srfi-160.test \ tests/srfi-171.test \ tests/srfi-178.test \ + tests/srfi-209.test \ tests/srfi-4.test \ tests/srfi-9.test \ tests/statprof.test \ @@ -231,6 +232,7 @@ EXTRA_DIST = \ tests/srfi-178-test/quasi-ints.scm \ tests/srfi-178-test/quasi-string.scm \ tests/srfi-178-test/selectors.scm \ + tests/srfi-209-test.scm \ ChangeLog-2008 diff --git a/test-suite/tests/srfi-209-test.scm b/test-suite/tests/srfi-209-test.scm new file mode 100644 index 000000000..1c0c9f8ca --- /dev/null +++ b/test-suite/tests/srfi-209-test.scm @@ -0,0 +1,465 @@ +;;; Copyright (C) 2020 Wolfgang Corcoran-Mathe +;;; +;;; 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. + +;;; SRFI 64-flavored test suite for SRFI 209. + +;;;; Utility + +(define-syntax constantly + (syntax-rules () + ((_ obj) (lambda _ obj)))) + +(define always (constantly #t)) +(define never (constantly #f)) + +;; Run a procedure on fresh copies of two enum sets. +(define (fresh-sets proc eset1 eset2) + (proc (enum-set-copy eset1) (enum-set-copy eset2))) + +;;;; Test types + +(define color-names + '(red tangerine orange yellow green cyan blue violet)) + +(define color (make-enum-type color-names)) + +(define color-red (enum-name->enum color 'red)) + +(define color-tangerine (enum-name->enum color 'tangerine)) + +(define color-blue (enum-name->enum color 'blue)) + +(define color-green (enum-name->enum color 'green)) + +(define color-set (enum-type->enum-set color)) + +(define reddish (list->enum-set + color + (map (lambda (name) + (enum-name->enum color name)) + (take color-names 3)))) + +(define ~reddish (list->enum-set + color + (map (lambda (ord) + (enum-name->enum color ord)) + (drop color-names 3)))) + +(define empty-colors (enum-empty-set color)) + +(define pizza-descriptions + '((margherita "tomato and mozzarella") + (funghi "mushrooms") + (bianca "ricotta and mozzarella") + (chicago "deep-dish") + (hawaiian "pineapple and ham"))) + +(define pizza-names (map car pizza-descriptions)) + +(define pizza (make-enum-type pizza-descriptions)) + +(define pizza-chicago (enum-name->enum pizza 'chicago)) +(define pizza-bianca (enum-name->enum pizza 'bianca)) + +;;;; Finders and enum accessors + +;;; Later tests make heavy use of these, so test these first. + +(test-group "Finders and accessors" + (test-eqv 'red (enum-name (enum-name->enum color 'red))) + (test-eqv 0 (enum-ordinal (enum-name->enum color 'red))) + (test-eqv #t (eqv? color (enum-type (enum-name->enum color 'red)))) + (test-eqv 'red (enum-name (enum-ordinal->enum color 0))) + (test-eqv 0 (enum-ordinal (enum-ordinal->enum color 0))) + (test-eqv #t (eqv? color (enum-type (enum-ordinal->enum color 0)))) + (test-eqv #t (eqv? (enum-name->enum color 'red) (enum-ordinal->enum color 0))) + (test-equal "deep-dish" (enum-value (enum-name->enum pizza 'chicago))) + + (test-eqv 0 (enum-name->ordinal color 'red)) + (test-eqv 6 (enum-name->ordinal color 'blue)) + (test-equal "mushrooms" (enum-name->value pizza 'funghi)) + (test-eqv (enum-name->ordinal color 'blue) (enum-name->value color 'blue)) + (test-eqv 'red (enum-ordinal->name color 0)) + (test-eqv 'chicago (enum-ordinal->name pizza 3)) + (test-equal "mushrooms" (enum-ordinal->value pizza 1)) + (test-eqv 6 (enum-ordinal->value color 6)) +) + +(test-group "Enum type constructors" + ;; Mixing name and name+value args. + (test-eqv #t (enum-type? + (make-enum-type + '(vanilla (chocolate 2) strawberry (pistachio 4)))))) + +;;;; Predicates + +(test-group "Predicates" + (test-eqv #t (enum? color-red)) + (test-eqv #f (enum? 'z)) ; Ensure enums aren't just symbols. + + (test-eqv #t (every (lambda (e) (enum-type-contains? color e)) + (map (lambda (s) + (enum-name->enum color s)) + color-names))) + (test-eqv #f (any (lambda (e) (enum-type-contains? color e)) + (map (lambda (s) (enum-name->enum pizza s)) pizza-names))) + + (test-eqv #t (enum=? color-red (enum-ordinal->enum color 0))) + (test-eqv #f (enum=? color-red color-tangerine)) + (test-eqv #t (enum=? color-red color-red color-red)) + (test-eqv #f (enum=? color-red color-red color-tangerine)) + + (test-eqv #t (enum? color-red color-tangerine)) + (test-eqv #f (enum>? color-tangerine color-tangerine)) + (test-eqv #t (enum>? color-tangerine color-red)) + (test-eqv #t (enum>? color-blue color-green color-red)) + (test-eqv #f (enum>? color-blue color-red color-red)) + (test-eqv #t (enum<=? color-red color-tangerine)) + (test-eqv #t (enum<=? color-tangerine color-tangerine)) + (test-eqv #f (enum<=? color-tangerine color-red)) + (test-eqv #t (enum<=? color-red color-blue color-blue)) + (test-eqv #f (enum<=? color-blue color-blue color-red)) + (test-eqv #f (enum>=? color-red color-tangerine)) + (test-eqv #t (enum>=? color-tangerine color-tangerine)) + (test-eqv #t (enum>=? color-tangerine color-red)) + (test-eqv #t (enum>=? color-blue color-red color-red)) + (test-eqv #f (enum>=? color-blue color-red color-blue)) +) + +;;;; Enum type accessors + +(test-group "Enum type accessors" + (test-eqv (length color-names) (enum-type-size color)) + (test-eqv (length pizza-names) (enum-type-size pizza)) + (test-eqv 'red (enum-name (enum-min color))) + (test-eqv 'margherita (enum-name (enum-min pizza))) + (test-eqv 'violet (enum-name (enum-max color))) + (test-eqv 'hawaiian (enum-name (enum-max pizza))) + + (test-eqv (enum-type-size color) (length (enum-type-enums color))) + (test-equal color-names (map enum-name (enum-type-enums color))) + (test-equal (iota (enum-type-size color)) + (map enum-ordinal (enum-type-enums color))) + (test-equal (map cadr pizza-descriptions) + (map enum-value (enum-type-enums pizza))) + + (test-equal color-names (enum-type-names color)) + (test-equal pizza-names (enum-type-names pizza)) + (test-equal (map cadr pizza-descriptions) (enum-type-values pizza)) + (test-equal (iota (enum-type-size color)) (enum-type-values color)) +) + +(test-group "Enum operations" + (test-eqv #t (enum=? (enum-next color-red) color-tangerine)) + (test-eqv #t (enum=? (enum-prev color-tangerine) color-red)) + (test-eqv #t (enum=? (enum-next pizza-bianca) pizza-chicago)) + (test-eqv #t (enum=? (enum-prev pizza-chicago) pizza-bianca)) + (test-eqv #f (enum-next (enum-max color)) ) + (test-eqv #f (enum-prev (enum-min color)) ) +) + +;;;; Enum comparators + +(test-group "Enum comparators" + (let ((pizza-comparator (make-enum-comparator pizza))) + (test-eqv #t (comparator? pizza-comparator)) + (test-eqv #t (comparator-ordered? pizza-comparator)) + (test-eqv #t (comparator-hashable? pizza-comparator)) + + (test-eqv #t (every (lambda (e) (comparator-test-type pizza-comparator e)) + (enum-type-enums pizza))) + (test-eqv #f (any (lambda (e) (comparator-test-type pizza-comparator e)) + (enum-type-enums color))) + + (test-eqv #t (=? pizza-comparator + pizza-chicago + (enum-name->enum pizza 'chicago))) + + (test-eqv #f (=? pizza-comparator pizza-bianca pizza-chicago)) + (test-eqv #t (? pizza-comparator pizza-bianca pizza-chicago)) + (test-eqv #f (>? pizza-comparator pizza-bianca pizza-bianca)) + (test-eqv #t (>? pizza-comparator pizza-chicago pizza-bianca)) + (test-eqv #t (<=? pizza-comparator pizza-bianca pizza-chicago)) + (test-eqv #t (<=? pizza-comparator pizza-bianca pizza-bianca)) + (test-eqv #f (<=? pizza-comparator pizza-chicago pizza-bianca)) + (test-eqv #f (>=? pizza-comparator pizza-bianca pizza-chicago)) + (test-eqv #t (>=? pizza-comparator pizza-bianca pizza-bianca)) + (test-eqv #t (>=? pizza-comparator pizza-chicago pizza-bianca))) +) + +(test-group "Basic enum set operations" + ;; Ensure that an enum set created from an enum type with + ;; enum-type->enum-set contains every enum of the original type. + (test-eqv #t (let ((pizza-set (enum-type->enum-set pizza))) + (every (lambda (enum) + (enum-set-contains? pizza-set enum)) + (enum-type-enums pizza)))) + + (test-eqv #t (let ((pizza-set (list->enum-set pizza (enum-type-enums pizza)))) + (every (lambda (enum) + (enum-set-contains? pizza-set enum)) + (enum-type-enums pizza)))) + + (test-eqv #t (let ((pizza-set (apply enum-set pizza (enum-type-enums pizza)))) + (every (lambda (enum) (enum-set-contains? pizza-set enum)) + (enum-type-enums pizza)))) + + (test-eqv #t (enum-set-contains? (enum-set color color-red color-blue) + color-red)) + (test-eqv #f (enum-set-contains? (enum-set color color-red color-blue) + color-tangerine)) + + (test-eqv #t (eqv? (enum-set-type color-set) color)) + (test-eqv #t (eqv? (enum-set-type (enum-type->enum-set pizza)) pizza)) + + (test-eqv #t (enum-set-empty? (enum-empty-set pizza))) + + (test-eqv #t (enum-set-empty? empty-colors)) + (test-eqv #f (enum-set-empty? color-set)) + + (test-eqv #t (enum-set=? (enum-set-projection color reddish) reddish)) + (let* ((color* (make-enum-type color-names)) + (reddish* (list->enum-set color* + (map (lambda (name) + (enum-name->enum color* name)) + (take color-names 3))))) + (test-eqv #t (enum-set=? (enum-set-projection color* reddish) reddish*))) + + (test-eqv #f (eqv? color-set (enum-set-copy color-set))) +) + +;;;; Enum set predicates + +(test-group "Enum set predicates" + (test-eqv #t (enum-set-disjoint? color-set empty-colors)) + (test-eqv #f (enum-set-disjoint? color-set reddish)) + (test-eqv #t (enum-set-disjoint? reddish ~reddish)) + + ;;; comparisons + + (test-eqv #t (enum-set=? color-set (enum-set-copy color-set))) + + (test-eqv #f (enum-set=? color-set empty-colors)) + (test-eqv #t (enum-set? reddish color-set)) + (test-eqv #t (enum-set>? color-set reddish)) + (test-eqv #f (enum-set>? color-set color-set)) + (test-eqv #t (enum-set<=? reddish color-set)) + (test-eqv #f (enum-set<=? color-set reddish)) + (test-eqv #t (enum-set<=? color-set color-set)) + (test-eqv #f (enum-set>=? reddish color-set)) + (test-eqv #t (enum-set>=? color-set reddish)) + (test-eqv #t (enum-set>=? color-set color-set)) + + ;;; enum-set-subset? + (test-eqv #t (enum-set-subset? reddish color-set)) + (test-eqv #f (enum-set-subset? color-set reddish)) + (test-eqv #t (enum-set-subset? reddish reddish)) + (let ((color-set* (make-enumeration '(red green blue)))) + (test-eqv #t (enum-set-subset? color-set* color-set)) + (test-eqv #f (enum-set-subset? color-set color-set*))) + + ;;; any & every + + (test-eqv #t (enum-set-any? (lambda (e) (eq? 'green (enum-name e))) + color-set)) + (test-eqv #f (enum-set-any? (lambda (e) (eq? 'mauve (enum-name e))) + color-set)) + (test-eqv #f (enum-set-any? never empty-colors)) + (test-eqv #f (enum-set-every? (lambda (e) (eq? 'green (enum-name e))) + color-set)) + (test-eqv #t (enum-set-every? (lambda (e) (< (enum-ordinal e) 10)) + color-set)) + (test-eqv #t (enum-set-every? never empty-colors)) +) + +;;;; Enum set mutators + +(test-group "Enum set mutators" + (let ((reddish+green (enum-set-adjoin reddish color-green))) + (test-eqv #t (enum-setenum-list color-set)) + (test-eqv #t (null? (enum-set->enum-list empty-colors))) + (test-eqv #t (= (enum-set-size color-set) + (length (enum-set->enum-list color-set)))) + + (test-equal color-names (enum-set->list color-set)) + (test-equal (map car pizza-descriptions) + (enum-set->list (enum-type->enum-set pizza))) + (test-eqv (enum-set-size color-set) + (length (enum-set->enum-list color-set))) + + (test-equal color-names (enum-set-map->list enum-name color-set)) + (test-eqv #t (null? (enum-set-map->list enum-name empty-colors))) + (test-equal (enum-set-map->list enum-name color-set) + (enum-set->list color-set)) + + (test-eqv 1 (enum-set-count (lambda (e) (enum=? e color-blue)) color-set)) + (test-eqv 0 (enum-set-count (lambda (e) (enum=? e color-blue)) reddish)) + (test-eqv (length pizza-descriptions) + (enum-set-count (lambda (e) (string? (enum-value e))) + (enum-type->enum-set pizza))) + + ;;; filter & remove + + (test-eqv #t (enum-setlist enum-name + (enum-set-filter + (lambda (e) (enum=? e color-red)) + color-set))) + (test-eqv #t (enum-set=? (enum-set-filter always color-set) color-set)) + (test-eqv #t (enum-set-empty? (enum-set-filter never color-set))) + (test-eqv #t (enum-setlist + enum-name + (enum-set-remove (lambda (e) (enum=? e color-red)) + color-set))) + (test-eqv #t (enum-set=? (enum-set-remove never color-set) color-set)) + (test-eqv #t (enum-set-empty? (enum-set-remove always color-set))) + + (test-eqv (length color-names) + (let ((n 0)) + (enum-set-for-each (lambda (_) (set! n (+ n 1))) + color-set) + n)) + + (test-equal (reverse color-names) + (enum-set-fold (lambda (enum lis) + (cons (enum-name enum) lis)) + '() + color-set)) + + (test-eqv #t (enum-set=? color-set (enum-set-universe reddish))) + + (let* ((ds '(red yellow green)) + (us-traffic-light (make-enumeration ds)) + (light-type (enum-set-type us-traffic-light))) + (test-eqv #t (every (lambda (e) (enum-set-contains? us-traffic-light e)) + (map (lambda (sym) (enum-name->enum light-type sym)) + ds))) + (test-eqv #t (every (lambda (e) (eqv? (enum-name e) (enum-value e))) + (enum-set->enum-list us-traffic-light)))) + + (let ((color-con (enum-set-constructor reddish))) + (test-eqv #t (eqv? (enum-set-type (color-con '(green))) color)) + (test-eqv #t (enum-set=? (color-con color-names) color-set))) + + (test-eqv #t (enum-set-member? 'red reddish)) + (test-eqv #f (enum-set-member? 'blue reddish)) + + (let ((idx (enum-set-indexer reddish))) + (test-eqv 0 (idx 'red)) + (test-eqv 4 (idx 'green)) + (test-eqv #f (idx 'margherita))) +) + +(test-group "Enum set logical operations" + (test-eqv #t (enum-set=? color-set (enum-set-union reddish ~reddish))) + (test-eqv #t (enum-set-empty? (enum-set-intersection reddish ~reddish))) + (test-eqv #t (enum-set=? ~reddish (enum-set-difference color-set reddish))) + (test-eqv #t (enum-set=? color-set (enum-set-xor reddish ~reddish))) + (test-eqv #t (enum-set-empty? (enum-set-xor reddish reddish))) + + (test-eqv #t (enum-set=? color-set + (fresh-sets enum-set-union! reddish ~reddish))) + (test-eqv #t (enum-set-empty? + (fresh-sets enum-set-intersection! reddish ~reddish))) + (test-eqv #t + (enum-set=? ~reddish + (fresh-sets enum-set-difference! color-set reddish))) + (test-eqv #t + (enum-set=? color-set + (fresh-sets enum-set-xor! reddish ~reddish))) + (test-eqv #t (enum-set-empty? + (fresh-sets enum-set-xor! reddish reddish))) + + (test-eqv #t (enum-set-empty? (enum-set-complement color-set))) + (test-eqv #t (enum-set=? (enum-set-complement reddish) ~reddish)) + (test-eqv #t (enum-set-empty? + (enum-set-complement! (enum-set-copy color-set)))) + (test-eqv #t (enum-set=? + (enum-set-complement! (enum-set-copy reddish)) ~reddish)) +) + +(test-group "Syntax" + (define-enum hobbit (frodo sam merry pippin) hobbit-set) + (define-enumeration wizard (gandalf saruman radagast) wizard-set) + + (test-eqv 'merry (enum-name (hobbit merry))) + (test-eqv #t (enum-set? (hobbit-set))) + (test-eqv #t (enum-set-empty? (hobbit-set))) + (test-eqv #t (enum-set-contains? (hobbit-set merry pippin) (hobbit pippin))) + + (test-eqv 'radagast (wizard radagast)) + (test-eqv #t (enum-set? (wizard-set))) + (test-eqv #t (enum-set-empty? (wizard-set))) + (test-eqv #t (enum-set-member? (wizard gandalf) (wizard-set saruman gandalf))) +) diff --git a/test-suite/tests/srfi-209.test b/test-suite/tests/srfi-209.test new file mode 100644 index 000000000..9e8c4e798 --- /dev/null +++ b/test-suite/tests/srfi-209.test @@ -0,0 +1,50 @@ +;;;; srfi-209.test --- Test suite for SRFI-209. -*- 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-209) + #:use-module (srfi srfi-209) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-64) + #:use-module (srfi srfi-128)) + +;;; Test runner copied from srfi-64.test. +(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-209-test.scm")) + +;;; Local Variables: +;;; eval: (put 'test-runner-on-test-end! 'scheme-indent-function 1) +;;; End: -- 2.41.0