From: Maxim Cournoyer <maxim.cournoyer@gmail.com>
To: guile-devel@gnu.org
Cc: Maxim Cournoyer <maxim.cournoyer@gmail.com>
Subject: [PATCH v8 16/16] module: Add SRFI 209.
Date: Wed, 6 Dec 2023 18:15:12 -0500 [thread overview]
Message-ID: <20231206231512.6505-17-maxim.cournoyer@gmail.com> (raw)
In-Reply-To: <20231206231512.6505-1-maxim.cournoyer@gmail.com>
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 <delimiter> 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{}
+@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
+(enum<? (enum-ordinal->enum 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
+(<? pizza-comparator pizza-margherita pizza-chicago) @U{21D2} #t
+@end lisp
+@end deffn
+
+@node SRFI 209 Enum set constructors
+@subsubsection SRFI 209 Enum set constructors
+
+@deffn {Scheme Procedure} enum-empty-set enum-type
+
+Returns an empty enum set that can contain enums of the type
+@var{enum-type}.
+@end deffn
+
+@deffn {Scheme Procedure} enum-type->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
+@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} #t
+(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-set<? reddish reddish+blue) @U{21D2} #t
+(enum-set-contains? reddish+blue color-blue) @U{21D2} #t
+@end lisp
+@end deffn
+
+@deffn {Scheme Procedure} enum-set-delete enum-set enum @dots{}
+@deffnx {Scheme Procedure} enum-set-delete! enum-set enum @dots{}
+
+Returns an enum set that contains the members of @var{enum-set}
+excluding the @var{enums}.
+
+@lisp
+(define no-blue
+ (enum-set-delete! (enum-set-copy color-set) color-blue))
+(enum-set<? no-blue color-set) @U{21D2} #t
+(enum-set-contains? no-blue color-blue) @U{21D2} #f
+@end lisp
+@end deffn
+
+@deffn {Scheme Procedure} enum-set-delete-all enum-set list @dots{}
+@deffnx {Scheme Procedure} enum-set-delete-all! enum-set list @dots{}
+
+Returns an enum set that contains the members of @var{enum-set}
+excluding the members of @var{list}.
+
+@lisp
+(define empty-colors
+ (enum-set-delete-all! (enum-set-copy color-set)
+ (enum-set->enum-list color-set)))
+(enum-set<? empty-colors reddish) @U{21D2} #t
+(enum-set-empty? empty-colors) @U{21D2} #t
+@end lisp
+@end deffn
+
+@node SRFI 209 Enum set operations
+@subsubsection SRFI 209 Enum set operations
+
+@deffn {Scheme Procedure} enum-set-size enum-set
+
+Returns the number of elements in @var{enum-set}.
+
+@lisp
+(enum-set-size (enum-set color color-red color-blue)) @U{21D2} 2
+@end lisp
+@end deffn
+
+@deffn {Scheme Procedure} enum-set->enum-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 <name-value> is either a symbol naming an enum or a two-element
+list specifying the name and value of an enum.
+
+<Type-name> is an identifier that is bound to a macro. When <type-name>
+is invoked as @samp{(<type-name> <symbol>)}, it returns the enum named
+<symbol> 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.
+
+<Constructor-syntax> 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<=? 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>=? 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 <enum-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 <enum>
+ (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)
+ (string<? (symbol->string 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))
+
+(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 <enum-set>
+ (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? vec1 vec2)
+ (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")
+ (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
\f
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 #f (enum<? color-tangerine color-red))
+ (test-eqv #t (enum<? color-red color-green color-blue))
+ (test-eqv #f (enum<? color-red color-blue color-blue))
+ (test-eqv #f (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 #f (<? pizza-comparator pizza-chicago pizza-bianca))
+ (test-eqv #f (>? 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 #f (enum-set<? color-set reddish))
+ (test-eqv #f (enum-set<? color-set color-set))
+ (test-eqv #f (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-set<? reddish reddish+green))
+ (test-eqv #t (enum-set-contains? reddish+green color-green)))
+
+ (let ((reddish+green
+ (enum-set-adjoin! (enum-set-copy reddish) color-green)))
+ (test-eqv #t (enum-set<? reddish reddish+green))
+ (test-eqv #t (enum-set-contains? reddish+green color-green)))
+
+ (let ((reddish* (enum-set-delete reddish color-tangerine)))
+ (test-eqv #t (enum-set<? reddish* reddish))
+ (test-eqv #f (enum-set-contains? reddish* color-tangerine)))
+
+ (let ((reddish* (enum-set-delete! (enum-set-copy reddish)
+ color-tangerine)))
+ (test-eqv #t (enum-set<? reddish* reddish))
+ (test-eqv #f (enum-set-contains? reddish* color-tangerine)))
+
+ (let ((reddish* (enum-set-delete-all reddish (list color-tangerine))))
+ (test-eqv #t (enum-set<? reddish* reddish))
+ (test-eqv #f (enum-set-contains? reddish* color-tangerine)))
+
+ (let ((reddish** (enum-set-delete-all! (enum-set-copy reddish)
+ (list color-tangerine))))
+ (test-eqv #t (enum-set<? reddish** reddish))
+ (test-eqv #f (enum-set-contains? reddish** color-tangerine)))
+
+ (test-eqv #t (enum-set-empty?
+ (enum-set-delete-all! (enum-set-copy color-set)
+ (enum-type-enums color))))
+)
+
+(test-group "Derived enum set operations"
+ (test-eqv (length color-names) (enum-set-size color-set))
+ (test-eqv 0 (enum-set-size empty-colors))
+
+ (test-equal (enum-type-enums color) (enum-set->enum-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-set<? (enum-set-filter (lambda (e) (enum=? e color-red))
+ color-set)
+ color-set))
+ (test-equal (filter (lambda (s) (eq? s 'red)) color-names)
+ (enum-set-map->list 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-set<? (enum-set-remove (lambda (e) (enum=? e color-red))
+ color-set)
+ color-set))
+ (test-equal (remove (lambda (s) (eq? s 'red)) color-names)
+ (enum-set-map->list
+ 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
prev parent reply other threads:[~2023-12-06 23:15 UTC|newest]
Thread overview: 17+ messages / expand[flat|nested] mbox.gz Atom feed top
2023-12-06 23:14 [PATCH v8 00/16] Add SRFI 209 and dependencies; improve support for R7RS libraries Maxim Cournoyer
2023-12-06 23:14 ` [PATCH v8 01/16] ice-9: Fix 'include' when used in compilation contexts Maxim Cournoyer
2023-12-06 23:14 ` [PATCH v8 02/16] Use R7RS 'rename' syntax for exports Maxim Cournoyer
2023-12-06 23:14 ` [PATCH v8 03/16] r7rs-libraries: Add support for 'else' clause in cond-expand Maxim Cournoyer
2023-12-06 23:15 ` [PATCH v8 04/16] r7rs-libraries: Better support R7RS SRFI library names Maxim Cournoyer
2023-12-06 23:15 ` [PATCH v8 05/16] (scheme base): Support non-negative SRFI integer names in cond-expand Maxim Cournoyer
2023-12-06 23:15 ` [PATCH v8 06/16] Share features tested by cond-expand library declarations and expressions Maxim Cournoyer
2023-12-06 23:15 ` [PATCH v8 07/16] build: Register '.sld' as an alternative extension to '.scm' Maxim Cournoyer
2023-12-06 23:15 ` [PATCH v8 08/16] module: Add SRFI 126 Maxim Cournoyer
2023-12-06 23:15 ` [PATCH v8 09/16] module: Add SRFI 128 Maxim Cournoyer
2023-12-06 23:15 ` [PATCH v8 10/16] module: Add (scheme comparator) Maxim Cournoyer
2023-12-06 23:15 ` [PATCH v8 11/16] module: Add (scheme sort) Maxim Cournoyer
2023-12-06 23:15 ` [PATCH v8 12/16] module: Add SRFI 125 Maxim Cournoyer
2023-12-06 23:15 ` [PATCH v8 13/16] module: Add SRFI 151 Maxim Cournoyer
2023-12-06 23:15 ` [PATCH v8 14/16] module: Add SRFI 160 Maxim Cournoyer
2023-12-06 23:15 ` [PATCH v8 15/16] module: Add SRFI 178 Maxim Cournoyer
2023-12-06 23:15 ` Maxim Cournoyer [this message]
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
List information: https://www.gnu.org/software/guile/
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=20231206231512.6505-17-maxim.cournoyer@gmail.com \
--to=maxim.cournoyer@gmail.com \
--cc=guile-devel@gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).