From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.io!.POSTED.blaine.gmane.org!not-for-mail From: Maxim Cournoyer Newsgroups: gmane.lisp.guile.devel Subject: [PATCH v5 15/15] module: Add SRFI 178. Date: Wed, 29 Nov 2023 16:59:43 -0500 Message-ID: <20231129220225.6819-16-maxim.cournoyer@gmail.com> References: <20231129220225.6819-1-maxim.cournoyer@gmail.com> Mime-Version: 1.0 Content-Transfer-Encoding: 8bit Injection-Info: ciao.gmane.io; posting-host="blaine.gmane.org:116.202.254.214"; logging-data="16001"; mail-complaints-to="usenet@ciao.gmane.io" Cc: Maxim Cournoyer To: guile-devel@gnu.org Original-X-From: guile-devel-bounces+guile-devel=m.gmane-mx.org@gnu.org Wed Nov 29 23:04:34 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 1r8SfZ-0003rs-Ss for guile-devel@m.gmane-mx.org; Wed, 29 Nov 2023 23:04:34 +0100 Original-Received: from localhost ([::1] helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1r8SeT-0001UE-G9; Wed, 29 Nov 2023 17:03:25 -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 1r8SeM-0001Gf-0b for guile-devel@gnu.org; Wed, 29 Nov 2023 17:03:18 -0500 Original-Received: from mail-ot1-x32b.google.com ([2607:f8b0:4864:20::32b]) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1r8SeC-0004H8-Uf for guile-devel@gnu.org; Wed, 29 Nov 2023 17:03:16 -0500 Original-Received: by mail-ot1-x32b.google.com with SMTP id 46e09a7af769-6d7eca548ccso188488a34.3 for ; Wed, 29 Nov 2023 14:03:08 -0800 (PST) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gmail.com; s=20230601; t=1701295387; x=1701900187; 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=OT8rIzDWCg/7SD0Q8yOz+sPk3vWDNLGfX5jsnc0thyI=; b=DiWwxE+N4vM2T2RdocFou8gfV+Bt2spDi9n5FNqQkyytOJ9ugfThFYhGrXc6DO0jei mARQWtTT0w0eKxnHMB7BCEyUBhB1N1bMGvgd1t5N+mf1FB19kgKOstpMZyG2m/39QfL1 s2PoIzee17xRSWbLrl1AM3juGrGsSuitPqvwlZ0H5TM4nZ4P7vfAcO7cntEteMe1WLnP U+mqLwVDE+Q6jQfOQELeqK0TQA8V7ssWOrRZoOs595RmsSd/SF61GErGmhQBsVCXFZ2F lFfnwQcMMO7eH9Pfjd2147G9kbE++kEri6LZPNIgasDz+HmrNBK0OrK2Ix/viyZwv+Ui qvdQ== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20230601; t=1701295387; x=1701900187; 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=OT8rIzDWCg/7SD0Q8yOz+sPk3vWDNLGfX5jsnc0thyI=; b=IOVgQruU1NUnM7Ujwcy17xcZt3dDJDGEaIw8o4xQFqXwUJCX4ANcQB5h3B29SKtxMF g7iVeOxjepB5Nxt9gCu2Me9F7LGFSqrzDnLnxWxtuTyuQi6VVEqsAa9ENpcXRphYCkKF q/fyx67o0m9qh4a5cMI/+HFjCiyevjyOJU4Sn8YAXHw6qOM5MKYiRFTuQIFUE8JPw/nS xvrms24MMxMJl0KTiPIJmZ01j/uI9h8dPrYsWdlwA8RhkjBPmDGxJuuc8w34claELH5q Djq2W457GHPdn2NaaNOtqDOg5GEXjTe1NUUqvBqg1nIFh448fmh1kC6oDz6oCc3YgQgx eCsw== X-Gm-Message-State: AOJu0YxAB8pVOJUifbCNZhgf7Iaf+J++YS4YmqLVDftFT0gLy0GVDShf Vj+esgbIaeElaEE54ph4vxwtlkiJTqM= X-Google-Smtp-Source: AGHT+IGi1xxowEnxasnjE+U81yi/vehKV0jcMuH+P9OEgWbFsiIFkIntPRyH+Zx1T9Ui+ctpv55+sw== X-Received: by 2002:a05:6830:12da:b0:6d8:187b:f2e with SMTP id a26-20020a05683012da00b006d8187b0f2emr15884525otq.24.1701295385724; Wed, 29 Nov 2023 14:03:05 -0800 (PST) Original-Received: from localhost.localdomain (dsl-158-174.b2b2c.ca. [66.158.158.174]) by smtp.gmail.com with ESMTPSA id g15-20020ad4510f000000b0067a2a0b44ddsm4644444qvp.44.2023.11.29.14.03.04 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Wed, 29 Nov 2023 14:03:05 -0800 (PST) X-Mailer: git-send-email 2.41.0 In-Reply-To: <20231129220225.6819-1-maxim.cournoyer@gmail.com> Received-SPF: pass client-ip=2607:f8b0:4864:20::32b; envelope-from=maxim.cournoyer@gmail.com; helo=mail-ot1-x32b.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:22155 Archived-At: * module/srfi/srfi-178.sld: New file. * am/bootstrap.am (SOURCES): Register it. * module/srfi/srfi-178/convert.scm * module/srfi/srfi-178/fields.scm * module/srfi/srfi-178/gen-acc.scm * module/srfi/srfi-178/logic-ops.scm * module/srfi/srfi-178/macros.scm * module/srfi/srfi-178/map2list.scm * module/srfi/srfi-178/quasi-ints.scm * module/srfi/srfi-178/quasi-strs.scm * module/srfi/srfi-178/unfolds.scm * module/srfi/srfi-178/wrappers.scm: New module implementation files. * am/bootstrap.am (NOCOMP_SOURCES): Register them. * test-suite/tests/srfi-178.test: New test. * test-suite/Makefile.am (SCM_TESTS): Register it. * test-suite/tests/srfi-178-test/constructors.scm * test-suite/tests/srfi-178-test/conversions.scm * test-suite/tests/srfi-178-test/fields.scm * test-suite/tests/srfi-178-test/gen-accum.scm * test-suite/tests/srfi-178-test/iterators.scm * test-suite/tests/srfi-178-test/logic-ops.scm * test-suite/tests/srfi-178-test/mutators.scm * test-suite/tests/srfi-178-test/quasi-ints.scm * test-suite/tests/srfi-178-test/quasi-string.scm * test-suite/tests/srfi-178-test/selectors.scm: New test implementation files. * test-suite/Makefile.am (EXTRA_DIST): Register them. * doc/ref/srfi-modules.texi (SRFI 178): New subsection. * NEWS: Update news. --- (no changes since v1) NEWS | 1 + am/bootstrap.am | 11 + doc/ref/srfi-modules.texi | 604 ++++++++++++++++++ module/srfi/srfi-178.sld | 105 +++ module/srfi/srfi-178/convert.scm | 83 +++ module/srfi/srfi-178/fields.scm | 88 +++ module/srfi/srfi-178/gen-acc.scm | 25 + module/srfi/srfi-178/logic-ops.scm | 105 +++ module/srfi/srfi-178/macros.scm | 26 + module/srfi/srfi-178/map2list.scm | 27 + module/srfi/srfi-178/quasi-ints.scm | 54 ++ module/srfi/srfi-178/quasi-strs.scm | 88 +++ module/srfi/srfi-178/unfolds.scm | 44 ++ module/srfi/srfi-178/wrappers.scm | 285 +++++++++ test-suite/Makefile.am | 11 + .../tests/srfi-178-test/constructors.scm | 88 +++ .../tests/srfi-178-test/conversions.scm | 108 ++++ test-suite/tests/srfi-178-test/fields.scm | 98 +++ test-suite/tests/srfi-178-test/gen-accum.scm | 72 +++ test-suite/tests/srfi-178-test/iterators.scm | 150 +++++ test-suite/tests/srfi-178-test/logic-ops.scm | 125 ++++ test-suite/tests/srfi-178-test/mutators.scm | 79 +++ test-suite/tests/srfi-178-test/quasi-ints.scm | 41 ++ .../tests/srfi-178-test/quasi-string.scm | 62 ++ test-suite/tests/srfi-178-test/selectors.scm | 13 + test-suite/tests/srfi-178.test | 147 +++++ 26 files changed, 2540 insertions(+) create mode 100644 module/srfi/srfi-178.sld create mode 100644 module/srfi/srfi-178/convert.scm create mode 100644 module/srfi/srfi-178/fields.scm create mode 100644 module/srfi/srfi-178/gen-acc.scm create mode 100644 module/srfi/srfi-178/logic-ops.scm create mode 100644 module/srfi/srfi-178/macros.scm create mode 100644 module/srfi/srfi-178/map2list.scm create mode 100644 module/srfi/srfi-178/quasi-ints.scm create mode 100644 module/srfi/srfi-178/quasi-strs.scm create mode 100644 module/srfi/srfi-178/unfolds.scm create mode 100644 module/srfi/srfi-178/wrappers.scm create mode 100644 test-suite/tests/srfi-178-test/constructors.scm create mode 100644 test-suite/tests/srfi-178-test/conversions.scm create mode 100644 test-suite/tests/srfi-178-test/fields.scm create mode 100644 test-suite/tests/srfi-178-test/gen-accum.scm create mode 100644 test-suite/tests/srfi-178-test/iterators.scm create mode 100644 test-suite/tests/srfi-178-test/logic-ops.scm create mode 100644 test-suite/tests/srfi-178-test/mutators.scm create mode 100644 test-suite/tests/srfi-178-test/quasi-ints.scm create mode 100644 test-suite/tests/srfi-178-test/quasi-string.scm create mode 100644 test-suite/tests/srfi-178-test/selectors.scm create mode 100644 test-suite/tests/srfi-178.test diff --git a/NEWS b/NEWS index c36b55643..b1a21c59b 100644 --- a/NEWS +++ b/NEWS @@ -28,6 +28,7 @@ the compiler reports it as "possibly unused". ** Add (srfi 125), a mutators library ** Add (srfi 151), a bitwise operations library ** Add (srfi 160), an homogeneous numeric vector library +** Add (srfi 178), a bitvector library * Bug fixes diff --git a/am/bootstrap.am b/am/bootstrap.am index f7fa9e145..7ebf4ca67 100644 --- a/am/bootstrap.am +++ b/am/bootstrap.am @@ -371,6 +371,7 @@ SOURCES = \ srfi/srfi-171.scm \ srfi/srfi-171/gnu.scm \ srfi/srfi-171/meta.scm \ + srfi/srfi-178.sld \ \ statprof.scm \ \ @@ -492,6 +493,16 @@ NOCOMP_SOURCES = \ srfi/srfi-160/u16-impl.scm \ srfi/srfi-160/u32-impl.scm \ srfi/srfi-160/u64-impl.scm \ + srfi/srfi-178/macros.scm \ + srfi/srfi-178/convert.scm \ + srfi/srfi-178/fields.scm \ + srfi/srfi-178/gen-acc.scm \ + srfi/srfi-178/logic-ops.scm \ + srfi/srfi-178/map2list.scm \ + srfi/srfi-178/quasi-ints.scm \ + srfi/srfi-178/quasi-strs.scm \ + srfi/srfi-178/unfolds.scm \ + srfi/srfi-178/wrappers.scm \ system/base/lalr.upstream.scm \ system/repl/describe.scm \ sxml/sxml-match.ss \ diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi index 23e030b99..216a4e045 100644 --- a/doc/ref/srfi-modules.texi +++ b/doc/ref/srfi-modules.texi @@ -72,6 +72,7 @@ get the relevant SRFI documents from the SRFI home page * SRFI 151:: Bitwise Operations. * SRFI 160:: Homogeneous numeric vectors. * SRFI-171:: Transducers. +* SRFI 178:: Bitvectors. @end menu @@ -9362,6 +9363,609 @@ The generator version of list-reduce. It reduces over @code{gen} until it returns the EOF object @end deffn +@node SRFI 178 +@subsection SRFI 178: Bitvector library +@cindex SRFI 178 + +@menu +* SRFI 178 Abstract:: +* SRFI 178 Rationale:: +* SRFI 178 Notation:: +* SRFI 178 Bit conversion:: +* SRFI 178 Constructors:: +* SRFI 178 Predicates:: +* SRFI 178 Selectors:: +* SRFI 178 Iteration:: +* SRFI 178 Prefixes suffixes trimming padding:: +* SRFI 178 Mutators:: +* SRFI 178 Conversion:: +* SRFI 178 Generators:: +* SRFI 178 Basic operations:: +* SRFI 178 Quasi-integer operations:: +* SRFI 178 Bit field operations:: +* SRFI 178 Bitvector literals:: +@end menu + +@node SRFI 178 Abstract +@subsubsection SRFI 178 Abstract + +This SRFI describes a set of operations on homogeneous bitvectors. +Operations analogous to those provided on the other homogeneous vector +types described in +@url{https://srfi.schemers.org/srfi-160/srfi-160.html, SRFI 160} are +provided, along with operations analogous to the bitwise operations of +@url{https://srfi.schemers.org/srfi-151/srfi-151.html, SRFI 151}. + +@node SRFI 178 Rationale +@subsubsection SRFI 178 Rationale + +Bitvectors were excluded from the final draft of SRFI 160 because they +are the only type of homogeneous numeric vectors for which bitwise +operations make sense. In addition, there are two ways to view them: as +vectors of exact integers limited to the values 0 and 1, and as vectors +of booleans. This SRFI is designed to allow bitvectors to be viewed in +either way. + +@node SRFI 178 Notation +@subsubsection SRFI 178 Notation + +Bitvectors are disjoint from all other Scheme types with the possible +exception of u1vectors, if the Scheme implementation supports them. + +The procedures of this SRFI that accept single bits or lists of bits can +be passed any of the values 0, 1, #f, #t. Procedures that return a bit +or a list of bits come in two flavors: one ending in @samp{/int} that +returns an exact integer, and one ending in @samp{/bool} that returns a +boolean. + +Mapping and folding procedures also come in two flavors: those ending in +@samp{/int} pass exact integers to their procedure arguments, whereas +those ending in @samp{/bool} pass booleans to theirs. + +Procedures whose names end in @samp{!} are the same as the corresponding +procedures without @samp{!}, except that the first bitvector argument is +mutated and an unspecified result is returned. Consequently, only the +non-@samp{!} version is documented below. + +It is an error unless all bitvector arguments passed to procedures that +accept more than one are of the same length (except as otherwise noted). + +In the section containing specifications of procedures, the following +notation is used to specify parameters and return values: + +@table @asis +@item (@var{f} @var{arg@sub{1}} @var{arg@sub{2}} @dots{}) -> something +A procedure @var{f} that takes the parameters @var{arg@sub{1}} +@var{arg@sub{2}} @dots{} and returns a value of the type +@code{something}. If two values are returned, two types are specified. +If @code{something} is @code{unspecified}, then @var{f} returns a single +implementation-dependent value; this SRFI does not specify what it +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 +@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. + +@item @var{i}, @var{j}, @var{start}, @var{at} +An exact nonnegative integer less than the length of the bitvector. In +@code{bitvector-copy!} and @code{reverse-bitvector-copy!}, @var{at} refers +to the destination and @var{start} to the source. + +@item @var{end} +An exact nonnegative integer not less than @var{start}. This indicates +the index directly before which traversal will stop --- processing will +occur until the index of the vector is one less than @var{end}. It is +the open right side of a range. + +@item @var{f} +A procedure taking one or more arguments, which returns (except as noted +otherwise) exactly one value. + +@item @var{=} +An equivalence procedure. + +@item @var{obj}, @var{seed}, @var{knil} +Any Scheme object. + +@item @var{[something]} +An optional argument; it needn't necessarily be applied. +@var{something} needn't necessarily be one thing; for example, this +usage of it is perfectly valid: + +@example +[@var{start} [@var{end}]] +@end example + +@noindent +and is indeed used quite often. + +@item @var{something} @dots{} +Zero or more @var{something}s are allowed to be arguments. + +@item @var{something@sub{1}} @var{something@sub{2}} @dots{} +One or more @var{something}s must be arguments. +@end table + +All procedures that return bitvectors, vectors, or lists newly allocate +their results, except those that end in @samp{!}. However, a +zero-length value need not be separately allocated. + +Except as otherwise noted, the semantics of each procedure are those of +the corresponding SRFI 133 or SRFI 151 procedure. + +@node SRFI 178 Bit conversion +@subsubsection SRFI 178 Bit conversion + +@deffn {Scheme Procedure} bit->integer bit -> exact integer + +Returns 0 if @var{bit} is 0 or @code{#f} and 1 if @var{bit} is 1 or +@code{#t}. +@end deffn + +@deffn {Scheme Procedure} bit->boolean bit -> boolean + +Returns @code{#f} if @var{bit} is 0 or @code{#f} and @code{#t} if +@var{bit} is 1 or @code{#t}. +@end deffn + +@node SRFI 178 Constructors +@subsubsection SRFI 178 Constructors + +@deffn {Scheme Procedure} make-bitvector size [bit] -> bitvector + +Returns a bitvector whose length is @var{size}. If @var{bit} is provided, +all the elements of the bitvector are initialized to it. +@end deffn + +@deffn {Scheme Procedure} bitvector value @dots{} -> bitvector + +Returns a bitvector initialized with @var{values}. +@end deffn + +@deffn {Scheme Procedure} bitvector-unfold f length seed @dots{} -> bitvector + +Creates a vector whose length is @var{length} and iterates across each +index @var{k} between 0 and @var{length}, applying @var{f} at each +iteration to the current index and current states, in that order, to +receive @var{n} + 1 values: the bit to put in the @var{k}th slot of the +new vector and new states for the next iteration. On the first call to +@var{f}, the states' values are the @var{seeds}. +@end deffn + +@deffn {Scheme Procedure} bitvector-unfold-right f length seed -> bitvector + +The same as @code{bitvector-unfold}, but initializes the bitvector from +right to left. +@end deffn + +@deffn {Scheme Procedure} bitvector-copy bvec [start [end]] -> bitvector + +Makes a copy of the portion of @var{bvec} from @var{start} to @var{end} and +returns it. +@end deffn + +@deffn {Scheme Procedure} bitvector-reverse-copy bvec [start [end]] -> bitvector + +The same as @code{bitvector-copy}, but in reverse order. +@end deffn + +@deffn {Scheme Procedure} bitvector-append bvec @dots{} -> bitvector + +Returns a bitvector containing all the elements of the @var{bvecs} in +order. +@end deffn + +@deffn {Scheme Procedure} bitvector-concatenate list-of-bitvectors -> bitvector + +The same as @code{bitvector-append}, but takes a list of bitvectors +rather than multiple arguments. +@end deffn + +@deffn {Scheme Procedure} bitvector-append-subbitvectors [bvec start end] @dots{} -> bitvector + +Concatenates the result of applying @code{bitvector-copy} to each +triplet of @var{bvec}, @var{start}, @var{end} arguments. +@end deffn + +@node SRFI 178 Predicates +@subsubsection SRFI 178 Predicates + +@deffn {Scheme Procedure} bitvector? obj -> boolean + +Returns @code{#t} if @var{obj} is a bitvector, and @code{#f} otherwise. +@end deffn + +@deffn {Scheme Procedure} bitvector-empty? bvec -> boolean + +Returns @code{#t} if @var{bvec} has a length of zero, and @code{#f} +otherwise. +@end deffn + +@deffn {Scheme Procedure} bitvector=? bvec @dots{} -> boolean + +Compares the @var{bvecs} for element-wise equality, using @code{eqv?} to +do the comparisons, and returns @code{#t} or @code{#f} accordingly. +@end deffn + +@node SRFI 178 Selectors +@subsubsection SRFI 178 Selectors + +@deffn {Scheme Procedure} bitvector-ref/int bvec i -> integer +@deffnx {Scheme Procedure} bitvector-ref/bool bvec i -> boolean + +Returns the @var{i}th element of @var{bvec} as an exact integer or +boolean, respectively. +@end deffn + +@deffn {Scheme Procedure} bitvector-length bvec -> exact nonnegative integer + +Returns the length of @var{bvec}. +@end deffn + +@node SRFI 178 Iteration +@subsubsection SRFI 178 Iteration + +@deffn {Scheme Procedure} bitvector-take bvec n -> bitvector +@deffnx {Scheme Procedure} bitvector-take-right bvec n -> bitvector + +Returns a bitvector containing the first/last @var{n} elements of +@var{bvec}. +@end deffn + +@deffn {Scheme Procedure} bitvector-drop bvec n -> bitvector +@deffnx {Scheme Procedure} bitvector-drop-right bvec n -> bitvector + +Returns a bitvector containing all except the first/last @var{n} +elements of @var{bvec}. +@end deffn + +@deffn {Scheme Procedure} bitvector-segment bvec n -> list + +Returns a list of bitvectors, each of which contains @var{n} consecutive +elements of @var{bvec}. The last bitvector may be shorter than @var{n}. +It is an error if @var{n} is not an exact positive integer. +@end deffn + +@deffn {Scheme Procedure} bitvector-fold/int kons knil bvec@sub{1} bvec@sub{2} @dots{} -> object +@deffnx {Scheme Procedure} bitvector-fold/bool kons knil bvec@sub{1} bvec@sub{2} @dots{} -> object +@deffnx {Scheme Procedure} bitvector-fold-right/int kons knil bvec@sub{1} bvec@sub{2} @dots{} -> object +@deffnx {Scheme Procedure} bitvector-fold-right/bool kons knil bvec@sub{1} bvec@sub{2} @dots{} -> object + +Folds @var{kons} over the elements of @var{bvec} in +increasing/decreasing order using @var{knil} as the initial value. The +kons procedure is called with the states first and the new element last, +as in SRFIs 43, 133, and 160. +@end deffn + +@deffn {Scheme Procedure} bitvector-map/int f bvec@sub{1} bvec@sub{2} @dots{} -> bitvector +@deffnx {Scheme Procedure} bitvector-map/bool f bvec@sub{1} bvec@sub{2} @dots{} -> bitvector +@deffnx {Scheme Procedure} bitvector-map!/int f bvec@sub{1} bvec@sub{2} @dots{} -> unspecified +@deffnx {Scheme Procedure} bitvector-map!/bool f bvec@sub{1} bvec@sub{2} @dots{} -> unspecified +@deffnx {Scheme Procedure} bitvector-map- > list/int f bvec@sub{1} bvec@sub{2} @dots{} -> list +@deffnx {Scheme Procedure} bitvector-map- > list/bool f bvec@sub{1} bvec@sub{2} @dots{} -> list +@deffnx {Scheme Procedure} bitvector-for-each/int f bvec@sub{1} bvec@sub{2} @dots{} -> unspecified +@deffnx {Scheme Procedure} bitvector-for-each/bool f bvec@sub{1} bvec@sub{2} @dots{} -> unspecified + +Iterate over the corresponding elements of the @var{bvecs} and apply +@var{f} to each, returning respectively: a bitvector of the results, an +undefined value with the results placed back in @var{bvec1}, a list of +the results, and an undefined value with no change to @var{bvec1}. +@end deffn + +@node SRFI 178 Prefixes suffixes trimming padding +@subsubsection SRFI 178 Prefixes, suffixes, trimming, padding + +@deffn {Scheme Procedure} bitvector-prefix-length bvec1 bvec2 -> index +@deffnx {Scheme Procedure} bitvector-suffix-length bvec1 bvec2 -> index + +Return the number of elements that are equal in the prefix/suffix +of the two @i{bvecs}, which are allowed to be of different lengths. +@end deffn + +@deffn {Scheme Procedure} bitvector-prefix? bvec1 bvec2 -> boolean +@deffnx {Scheme Procedure} bitvector-suffix? bvec1 bvec2 -> boolean + +Returns @code{#t} if @var{bvec1} is a prefix/suffix of @var{bvec2}, and +@code{#f} otherwise. The arguments are allowed to be of different +lengths. +@end deffn + +@deffn {Scheme Procedure} bitvector-pad bit bvec length -> bvec +@deffnx {Scheme Procedure} bitvector-pad-right bit bvec length -> bvec + +Returns a copy of @var{bvec} with leading/trailing elements equal to +@var{bit} added (if necessary) so that the length of the result is +@var{length}. +@end deffn + +@deffn {Scheme Procedure} bitvector-trim bit bvec -> bvec +@deffnx {Scheme Procedure} bitvector-trim-right bit bvec -> bvec +@deffnx {Scheme Procedure} bitvector-trim-both bit bvec -> bvec + +Returns a copy of @var{bvec} with leading/trailing/both elements equal to +@var{bit} removed. +@end deffn + +@node SRFI 178 Mutators +@subsubsection SRFI 178 Mutators + +@deffn {Scheme Procedure} bitvector-set! bvec i bit -> unspecified + +Sets the @var{i}th element of @var{bvec} to @var{bit}. +@end deffn + +@deffn {Scheme Procedure} bitvector-swap! bvec i j -> unspecified + +Interchanges the @var{i}th and @var{j}th elements of @var{bvec}. +@end deffn + +@deffn {Scheme Procedure} bitvector-reverse! bvec [start [end]] -> unspecified + +Reverses the portion of @var{bvec} from @var{start} to @var{end}. +@end deffn + +@deffn {Scheme Procedure} bitvector-copy! to at from [start [end]] -> unspecified + +Copies the portion of @var{from} from @var{start} to @var{end} onto +@var{to}, starting at index @var{at}. +@end deffn + + +@deffn {Scheme Procedure} bitvector-reverse-copy! to at from [start [end]] -> unspecified + +The same as @code{bitvector-copy!}, but copies in reverse. +@end deffn + +@node SRFI 178 Conversion +@subsubsection SRFI 178 Conversion + +@deffn {Scheme Procedure} bitvector->list/int bvec [start [end]] -> list of integers +@deffnx {Scheme Procedure} bitvector->list/bool bvec [start [end]] -> list of booleans +@deffnx {Scheme Procedure} reverse-bitvector->list/int bvec [start [end]] -> list of integers +@deffnx {Scheme Procedure} reverse-bitvector->list/bool bvec [start [end]] -> list of booleans +@deffnx {Scheme Procedure} list->bitvector list -> bitvector +@deffnx {Scheme Procedure} reverse-list->bitvector list -> bitvector +@deffnx {Scheme Procedure} bitvector->vector/int bvec [start [end]] -> vector of integers +@deffnx {Scheme Procedure} bitvector->vector/bool bvec [start [end]] -> vector of booleans +@deffnx {Scheme Procedure} reverse-bitvector->vector/int bvec [start [end]] -> vector of integers +@deffnx {Scheme Procedure} reverse-bitvector->vector/bool bvec [start [end]] -> vector of booleans +@deffnx {Scheme Procedure} vector->bitvector vec [start [end]] -> bitvector +@deffnx {Scheme Procedure} reverse-vector->bitvector vec [start [end]] -> bitvector + +Returns a list, bitvector, or heterogeneous vector with the same +elements as the argument, in reverse order where specified. +@end deffn + +@deffn {Scheme Procedure} bitvector->string bvec -> string + +Returns a string beginning with @samp{"#*"} and followed by the values +of @var{bvec} represented as 0 and 1 characters. This is the Common +Lisp representation of a bitvector. +@end deffn + +@deffn {Scheme Procedure} string->bitvector string -> bitvector + +Parses a string in the format generated by @code{bitvector->string} and +returns the corresponding bitvector, or @code{#f} if the string is not +in this format. +@end deffn + +@deffn {Scheme Procedure} bitvector->integer bitvector + +Returns a non-negative exact integer whose bits, starting with the least +significant bit as bit 0, correspond to the values in @var{bitvector}. +This ensures compatibility with the integers-as-bits operations of +@url{https://srfi.schemers.org/srfi-151/srfi-151.html, SRFI 151}. +@end deffn + +@deffn {Scheme Procedure} integer->bitvector integer [len] + +Returns a bitvector whose length is @var{len} whose values correspond to +the bits of @var{integer}, a non-negative exact integer, starting with +the least significant bit as bit 0. This ensures compatibility with the +integers-as-bits operations of +@url{https://srfi.schemers.org/srfi-151/srfi-151.html, SRFI 151} + +The default value of @var{len} is @samp{(integer-length @var{integer})}. +If the value of @var{len} is less than the default, the resulting +bitvector cannot be converted back by @code{bitvector->integer} +correctly. +@end deffn + +@node SRFI 178 Generators +@subsubsection SRFI 178 Generators + +@deffn {Scheme Procedure} make-bitvector/int-generator bitvector +@deffnx {Scheme Procedure} make-bitvector/bool-generator bitvector + +Returns a @url{https://srfi.schemers.org/srfi-158/srfi-158.html, SRFI +158} generator that generates all the values of @var{bitvector} in +order. Note that the generator is finite. +@end deffn + +@deffn {Scheme Procedure} make-bitvector-accumulator + +Returns a @url{https://srfi.schemers.org/srfi-158/srfi-158.html, SRFI +158} accumulator that collects all the bits it is invoked on. When +invoked on an end-of-file object, returns a bitvector containing all the +bits in order. +@end deffn + +@node SRFI 178 Basic operations +@subsubsection SRFI 178 Basic operations + +@deffn {Scheme Procedure} bitvector-not bvec +@deffnx {Scheme Procedure} bitvector-not! bvec + +Returns the element-wise complement of @var{bvec}; that is, each value +is changed to the opposite value. +@end deffn + +The following ten procedures correspond to the useful set of non-trivial +two-argument boolean functions. For each such function, the +corresponding bitvector operator maps that function across two or more +bitvectors in an element-wise fashion. The core idea of this group of +functions is this element-wise "lifting" of the set of dyadic boolean +functions to bitvector parameters. + +@deffn {Scheme Procedure} bitvector-and bvec1 bvec2 bvec @dots{} +@deffnx {Scheme Procedure} bitvector-and! bvec1 bvec2 bvec @dots{} +@deffnx {Scheme Procedure} bitvector-ior bvec1 bvec2 bvec @dots{} +@deffnx {Scheme Procedure} bitvector-ior! bvec1 bvec2 bvec @dots{} +@deffnx {Scheme Procedure} bitvector-xor bvec1 bvec2 bvec @dots{} +@deffnx {Scheme Procedure} bitvector-xor! bvec1 bvec2 bvec @dots{} +@deffnx {Scheme Procedure} bitvector-eqv bvec1 bvec2 bvec @dots{} +@deffnx {Scheme Procedure} bitvector-eqv! bvec1 bvec2 bvec @dots{} + +These operations are associative. + +The @code{bitvector-eqv} procedure produces the complement of the +@code{bitvector-xor} procedure. When applied to three arguments, it +does @emph{not} produce a @code{#t} value everywhere that @var{a}, +@var{b} and @var{c} all agree. That is, it does @emph{not} produce: + +@lisp + (bitvector-ior (bitvector-and a b c) + (bitvector-and (bitvector-not a) + (bitvector-not b) + (bitvector-not c))) +@end lisp + +Rather, it produces @samp{(bitvector-eqv @var{a} (bitvector-eqv @var{b} +@var{c}))} or the equivalent @samp{(bitvector-eqv (bitvector-eqv @var{a} +@var{b}) @var{c})}. +@end deffn + +@deffn {Scheme Procedure} bitvector-nand bvec1 bvec2 +@deffnx {Scheme Procedure} bitvector-nand! bvec1 bvec2 +@deffnx {Scheme Procedure} bitvector-nor bvec1 bvec2 +@deffnx {Scheme Procedure} bitvector-nor! bvec1 bvec2 +@deffnx {Scheme Procedure} bitvector-andc1 bvec1 bvec2 +@deffnx {Scheme Procedure} bitvector-andc1! bvec1 bvec2 +@deffnx {Scheme Procedure} bitvector-andc2 bvec1 bvec2 +@deffnx {Scheme Procedure} bitvector-andc2! bvec1 bvec2 +@deffnx {Scheme Procedure} bitvector-orc1 bvec1 bvec2 +@deffnx {Scheme Procedure} bitvector-orc1! bvec1 bvec2 +@deffnx {Scheme Procedure} bitvector-orc2 bvec1 bvec2 +@deffnx {Scheme Procedure} bitvector-orc2! bvec1 bvec2 + +These operations are not associative. +@end deffn + +@node SRFI 178 Quasi-integer operations +@subsubsection SRFI 178 Quasi-integer operations + +@deffn {Scheme Procedure} bitvector-logical-shift bvec count bit + +Returns a bitvector equal in length to @var{bvec} containing the logical +left shift (toward lower indices) when @var{count}>=0 or the right shift +(toward upper indices) when @var{count}<0. Newly vacated elements are +filled with @var{bit}. +@end deffn + +@deffn {Scheme Procedure} bitvector-count bit bvec + +Returns the number of @var{bit} values in @var{bvec}. +@end deffn + +@deffn {Scheme Procedure} bitvector-count-run bit bvec i + +Returns the number of consecutive @var{bit} values in @var{bvec}, +starting at index @var{i}. +@end deffn + +@deffn {Scheme Procedure} bitvector-if if-bitvector then-bitvector else-bitvector + +Returns a bitvector that merges the bitvectors @var{then-bitvector} and +@var{else-bitvector}, with the bitvector @var{if-bitvector} determining +from which bitvector to take each value. That is, if the @var{k}th +value of @var{if-bitvector} is @code{#t} (or 1, depending in how you +look at it), then the @var{k}th bit of the result is the @var{k}th bit +of @var{then-bitvector}, otherwise the @var{k}th bit of +@var{else-bitvector}. +@end deffn + +@deffn {Scheme Procedure} bitvector-first-bit bit bvec + +Return the index of the first (smallest index) @var{bit} value in +@var{bvec}. Return @code{-1} if @var{bvec} contains no values equal to +@var{bit}. +@end deffn + +@node SRFI 178 Bit field operations +@subsubsection SRFI 178 Bit field operations + +These procedures operate on a contiguous field of bits (a "byte" in +Common Lisp parlance) in a given bitvector. The @var{start} and +@var{end} arguments, which are not optional, are non-negative exact +integers specifying the field: it is the @var{end} --- @var{start} bits +running from bit @var{start} to bit @samp{@var{end} - 1}. + +@deffn {Scheme Procedure} bitvector-field-any? bvec start end + +Returns @code{#t} if any of the field's bits are set in @var{bvec}, and +@code{#f} otherwise. +@end deffn + +@deffn {Scheme Procedure} bitvector-field-every? bvec start end + +Returns @code{#f} if any of the field's bits are not set in @var{bvec}, +and @code{#t} otherwise. +@end deffn + +@deffn {Scheme Procedure} bitvector-field-clear bvec start end +@deffnx {Scheme Procedure} bitvector-field-clear! bvec start end +@deffnx {Scheme Procedure} bitvector-field-set bvec start end +@deffnx {Scheme Procedure} bitvector-field-set! bvec start end + +Returns a bitvector containing @var{bvec} with the field's bits set +appropriately. +@end deffn + +@deffn {Scheme Procedure} bitvector-field-replace dest source start end +@deffnx {Scheme Procedure} bitvector-field-replace! dest source start end + +Returns a bitvector containing @var{dest} with the field replaced by the +first @var{end-start} bits in @var{source}. +@end deffn + +@deffn {Scheme Procedure} bitvector-field-replace-same dest source start end +@deffnx {Scheme Procedure} bitvector-field-replace-same! dest source start end + +Returns a bitvector containing @var{dest} with its field replaced by +the corresponding field in @var{source}. +@end deffn + +@deffn {Scheme Procedure} bitvector-field-rotate bvec count start end + +Returns @var{bvec} with the field cyclically permuted by @var{count} +bits towards higher indices when @var{count} is negative, and toward +lower indices otherwise. +@end deffn + +@deffn {Scheme Procedure} bitvector-field-flip bvec start end +@deffnx {Scheme Procedure} bitvector-field-flip! bvec start end + +Returns @var{bvec} with the bits in the field flipped: that is, each +value is replaced by the opposite value. There is no SRFI 151 +equivalent. +@end deffn + +@node SRFI 178 Bitvector literals +@subsubsection SRFI 178 Bitvector literals + +The compact string representation used by @code{bitvector->string} and +@code{string->bitvector} may be supported by the standard @code{read} +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. + @c srfi-modules.texi ends here @c Local Variables: diff --git a/module/srfi/srfi-178.sld b/module/srfi/srfi-178.sld new file mode 100644 index 000000000..e0d991ee7 --- /dev/null +++ b/module/srfi/srfi-178.sld @@ -0,0 +1,105 @@ +;;; SPDX-License-Identifier: MIT +;;; SPDX-FileCopyrightText: 2020 Wolfgang Corcoran-Mathe + +(define-library (srfi 178) + (import (scheme base)) + (import (scheme case-lambda)) + (import (srfi 151)) + (import (srfi 160 u8)) + + (cond-expand + ((library (srfi 133)) + (import (only (srfi 133) vector-unfold))) + (else + (begin + ;; The "seedless" case is all we need. + (define (vector-unfold f len) + (let ((res (make-vector len))) + (let lp ((i 0)) + (cond ((= i len) res) + (else (vector-set! res i (f i)) + (lp (+ i 1)))))))))) + + (export bit->integer bit->boolean ; Bit conversion + + ;; Constructors + make-bitvector bitvector bitvector-unfold + bitvector-unfold-right bitvector-copy + bitvector-reverse-copy bitvector-append bitvector-concatenate + bitvector-append-subbitvectors + + ;; Predicates + bitvector? bitvector-empty? bitvector=? + + ;; Selectors + bitvector-ref/int bitvector-ref/bool bitvector-length + + ;; Iteration + bitvector-take bitvector-take-right + bitvector-drop bitvector-drop-right bitvector-segment + bitvector-fold/int bitvector-fold/bool bitvector-fold-right/int + bitvector-fold-right/bool bitvector-map/int bitvector-map/bool + bitvector-map!/int bitvector-map!/bool bitvector-map->list/int + bitvector-map->list/bool bitvector-for-each/int + bitvector-for-each/bool + + ;; Prefixes, suffixes, trimming, padding + bitvector-prefix-length + bitvector-suffix-length bitvector-prefix? bitvector-suffix? + bitvector-pad bitvector-pad-right bitvector-trim + bitvector-trim-right bitvector-trim-both + + ;; Mutators + bitvector-set! + bitvector-swap! bitvector-reverse! + bitvector-copy! bitvector-reverse-copy! + + ;; Conversion + bitvector->list/int + bitvector->list/bool reverse-bitvector->list/int + reverse-bitvector->list/bool list->bitvector + reverse-list->bitvector bitvector->vector/int + bitvector->vector/bool vector->bitvector bitvector->string + string->bitvector bitvector->integer integer->bitvector + reverse-vector->bitvector reverse-bitvector->vector/int + reverse-bitvector->vector/bool + + ;; Generators and accumulators + make-bitvector/int-generator make-bitvector/bool-generator + make-bitvector-accumulator + + ;; Basic operations + bitvector-not bitvector-not! + bitvector-and bitvector-and! bitvector-ior bitvector-ior! + bitvector-xor bitvector-xor! bitvector-eqv bitvector-eqv! + bitvector-nand bitvector-nand! bitvector-nor bitvector-nor! + bitvector-andc1 bitvector-andc1! bitvector-andc2 + bitvector-andc2! bitvector-orc1 bitvector-orc1! + bitvector-orc2 bitvector-orc2! + + ;; Quasi-integer operations + bitvector-logical-shift + bitvector-count bitvector-if + bitvector-first-bit bitvector-count-run + + ;; Bit field operations + bitvector-field-any? bitvector-field-every? + bitvector-field-clear bitvector-field-clear! + bitvector-field-set bitvector-field-set! + bitvector-field-replace-same bitvector-field-replace-same! + bitvector-field-rotate bitvector-field-flip + bitvector-field-flip! + bitvector-field-replace bitvector-field-replace! + ) + + (include "srfi-178/macros.scm") + (include "srfi-178/convert.scm") + (include "srfi-178/fields.scm") + (include "srfi-178/gen-acc.scm") + (include "srfi-178/logic-ops.scm") + (include "srfi-178/map2list.scm") + (include "srfi-178/quasi-ints.scm") + (include "srfi-178/quasi-strs.scm") + (include "srfi-178/unfolds.scm") + (include "srfi-178/wrappers.scm") +) diff --git a/module/srfi/srfi-178/convert.scm b/module/srfi/srfi-178/convert.scm new file mode 100644 index 000000000..86f61b950 --- /dev/null +++ b/module/srfi/srfi-178/convert.scm @@ -0,0 +1,83 @@ +;;; SPDX-License-Identifier: MIT +;;; SPDX-FileCopyrightText: 2020 Wolfgang Corcoran-Mathe + +;;;; Bit conversions + +(define (bit->integer bit) (I bit)) + +(define (bit->boolean bit) (B bit)) + +(define (bitvector->string bvec) + (let loop ((i (- (bitvector-length bvec) 1)) + (r '())) + (if (< i 0) + (list->string (cons #\# (cons #\* r))) + (loop (- i 1) + (cons (if (bitvector-ref/bool bvec i) #\1 #\0) r))))) + +(define (string->bitvector str) + (call/cc + (lambda (return) + (and + (> (string-length str) 1) + (char=? (string-ref str 0) #\#) + (char=? (string-ref str 1) #\*) + (bitvector-unfold + (lambda (ri si) + (case (string-ref str si) + ((#\0) (values 0 (+ si 1))) + ((#\1) (values 1 (+ si 1))) + (else (return #f)))) + (- (string-length str) 2) + 2))))) + +;;;; Bitvector/integer conversions + +(define (bitvector->integer bvec) + (bitvector-fold-right/int (lambda (r b) (+ (* r 2) b)) 0 bvec)) + +(define integer->bitvector + (case-lambda + ((int) (integer->bitvector int (integer-length int))) + ((int len) + (bitvector-unfold + (lambda (_ int) + (values (bit-set? 0 int) (arithmetic-shift int -1))) + len + int)))) + +;;; Additional vector conversions + +(define reverse-vector->bitvector + (case-lambda + ((vec) (reverse-vector->bitvector vec 0 (vector-length vec))) + ((vec start) (reverse-vector->bitvector vec start (vector-length vec))) + ((vec start end) + (bitvector-unfold + (lambda (i) + (vector-ref vec (- end 1 i))) + (- end start))))) + +(define reverse-bitvector->vector/int + (case-lambda + ((bvec) + (reverse-bitvector->vector/int bvec 0 (bitvector-length bvec))) + ((bvec start) + (reverse-bitvector->vector/int bvec start (bitvector-length bvec))) + ((bvec start end) + (let ((u8vec (U bvec))) + (vector-unfold (lambda (i) + (u8vector-ref u8vec (- end 1 i))) + (- end start)))))) + +(define reverse-bitvector->vector/bool + (case-lambda + ((bvec) + (reverse-bitvector->vector/bool bvec 0 (bitvector-length bvec))) + ((bvec start) + (reverse-bitvector->vector/bool bvec start (bitvector-length bvec))) + ((bvec start end) + (let ((u8vec (U bvec))) + (vector-unfold (lambda (i) + (B (u8vector-ref u8vec (- end 1 i)))) + (- end start)))))) diff --git a/module/srfi/srfi-178/fields.scm b/module/srfi/srfi-178/fields.scm new file mode 100644 index 000000000..e2c172e0e --- /dev/null +++ b/module/srfi/srfi-178/fields.scm @@ -0,0 +1,88 @@ +;;; SPDX-License-Identifier: MIT +;;; SPDX-FileCopyrightText: 2020 Wolfgang Corcoran-Mathe + +(define (bitvector-field-any? bvec start end) + (let lp ((i start)) + (and (< i end) + (or (bitvector-ref/bool bvec i) + (lp (+ i 1)))))) + +(define (bitvector-field-every? bvec start end) + (let lp ((i start)) + (or (>= i end) + (and (bitvector-ref/bool bvec i) + (lp (+ i 1)))))) + +(define (%bitvector-field-modify bvec bit start end) + (bitvector-unfold + (lambda (i) + (if (and (>= i start) (< i end)) + bit + (bitvector-ref/int bvec i))) + (bitvector-length bvec))) + +(define (bitvector-field-clear bvec start end) + (%bitvector-field-modify bvec 0 start end)) + +(define (%bitvector-fill!/int bvec int start end) + (u8vector-fill! (U bvec) int start end)) + +(define (bitvector-field-clear! bvec start end) + (%bitvector-fill!/int bvec 0 start end)) + +(define (bitvector-field-set bvec start end) + (%bitvector-field-modify bvec 1 start end)) + +(define (bitvector-field-set! bvec start end) + (%bitvector-fill!/int bvec 1 start end)) + +(define (bitvector-field-replace dest source start end) + (bitvector-unfold + (lambda (i) + (if (and (>= i start) (< i end)) + (bitvector-ref/int source (- i start)) + (bitvector-ref/int dest i))) + (bitvector-length dest))) + +(define (bitvector-field-replace! dest source start end) + (bitvector-copy! dest start source 0 (- end start))) + +(define (bitvector-field-replace-same dest source start end) + (bitvector-unfold + (lambda (i) + (bitvector-ref/int (if (and (>= i start) (< i end)) + source + dest) + i)) + (bitvector-length dest))) + +(define (bitvector-field-replace-same! dest source start end) + (bitvector-copy! dest start source start end)) + +(define (bitvector-field-rotate bvec count start end) + (if (zero? count) + bvec + (let ((field-len (- end start))) + (bitvector-unfold + (lambda (i) + (if (and (>= i start) (< i end)) + (bitvector-ref/int + bvec + (+ start (floor-remainder (+ (- i start) count) field-len))) + (bitvector-ref/int bvec i))) + (bitvector-length bvec))))) + +(define (bitvector-field-flip bvec start end) + (bitvector-unfold + (lambda (i) + (I (if (and (>= i start) (< i end)) + (not (bitvector-ref/bool bvec i)) + (bitvector-ref/bool bvec i)))) + (bitvector-length bvec))) + +(define (bitvector-field-flip! bvec start end) + (let lp ((i start)) + (unless (>= i end) + (bitvector-set! bvec i (not (bitvector-ref/bool bvec i))) + (lp (+ i 1))))) + diff --git a/module/srfi/srfi-178/gen-acc.scm b/module/srfi/srfi-178/gen-acc.scm new file mode 100644 index 000000000..863f5358c --- /dev/null +++ b/module/srfi/srfi-178/gen-acc.scm @@ -0,0 +1,25 @@ +;;; SPDX-License-Identifier: MIT +;;; SPDX-FileCopyrightText: 2020 Wolfgang Corcoran-Mathe + +(define (%make-bitvector-generator bvec ref-proc) + (let ((len (bitvector-length bvec)) + (i 0)) + (lambda () + (if (= i len) + (eof-object) + (let ((r (ref-proc bvec i))) + (set! i (+ i 1)) + r))))) + +(define (make-bitvector/int-generator bvec) + (%make-bitvector-generator bvec bitvector-ref/int)) + +(define (make-bitvector/bool-generator bvec) + (%make-bitvector-generator bvec bitvector-ref/bool)) + +(define (make-bitvector-accumulator) + (let ((r '())) + (lambda (x) + (if (eof-object? x) + (reverse-list->bitvector r) + (set! r (cons x r)))))) diff --git a/module/srfi/srfi-178/logic-ops.scm b/module/srfi/srfi-178/logic-ops.scm new file mode 100644 index 000000000..b14b357da --- /dev/null +++ b/module/srfi/srfi-178/logic-ops.scm @@ -0,0 +1,105 @@ +;;; SPDX-License-Identifier: MIT +;;; SPDX-FileCopyrightText: 2020 Wolfgang Corcoran-Mathe + +(define (u1-not a) + (- 1 a)) + +(define (bitvector-not avec) + (bitvector-map/int u1-not avec)) + +(define (bitvector-not! avec) + (bitvector-map!/int u1-not avec)) + +(define (u1-and . args) + (I (apply * args))) + +(define (bitvector-and . vecs) + (apply bitvector-map/int u1-and vecs)) + +(define (bitvector-and! . vecs) + (apply bitvector-map!/int u1-and vecs)) + +(define (u1-ior . args) + (I (apply + args))) + +(define (bitvector-ior . vecs) + (apply bitvector-map/int u1-ior vecs)) + +(define (bitvector-ior! . vecs) + (apply bitvector-map!/int u1-ior vecs)) + +(define (u1-xor . args) + (I (odd? (apply + args)))) + +(define (bitvector-xor . vecs) + (apply bitvector-map/int u1-xor vecs)) + +(define (bitvector-xor! . vecs) + (apply bitvector-map!/int u1-xor vecs)) + +(define (u1-eqv . args) + (let ((xor-value (apply u1-xor args))) + (if (odd? (length args)) + xor-value + (u1-not xor-value)))) + +(define (bitvector-eqv . vecs) + (apply bitvector-map/int u1-eqv vecs)) + +(define (bitvector-eqv! . vecs) + (apply bitvector-map!/int u1-eqv vecs)) + +(define (u1-nand a b) + (u1-not (u1-and a b))) + +(define (bitvector-nand a b) + (bitvector-map/int u1-nand a b)) + +(define (bitvector-nand! a b) + (bitvector-map!/int u1-nand a b)) + +(define (u1-nor a b) + (u1-not (u1-ior a b))) + +(define (bitvector-nor a b) + (bitvector-map/int u1-nor a b)) + +(define (bitvector-nor! a b) + (bitvector-map!/int u1-nor a b)) + +(define (u1-andc1 a b) + (u1-and (u1-not a) b)) + +(define (bitvector-andc1 a b) + (bitvector-map/int u1-andc1 a b)) + +(define (bitvector-andc1! a b) + (bitvector-map!/int u1-andc1 a b)) + +(define (u1-andc2 a b) + (u1-and a (u1-not b))) + +(define (bitvector-andc2 a b) + (bitvector-map/int u1-andc2 a b)) + +(define (bitvector-andc2! a b) + (bitvector-map!/int u1-andc2 a b)) + +(define (u1-orc1 a b) + (u1-ior (u1-not a) b)) + +(define (bitvector-orc1 a b) + (bitvector-map/int u1-orc1 a b)) + +(define (bitvector-orc1! a b) + (bitvector-map!/int u1-orc1 a b)) + +(define (u1-orc2 a b) + (u1-ior a (u1-not b))) + +(define (bitvector-orc2 a b) + (bitvector-map/int u1-orc2 a b)) + +(define (bitvector-orc2! a b) + (bitvector-map!/int u1-orc2 a b)) + diff --git a/module/srfi/srfi-178/macros.scm b/module/srfi/srfi-178/macros.scm new file mode 100644 index 000000000..9e5900512 --- /dev/null +++ b/module/srfi/srfi-178/macros.scm @@ -0,0 +1,26 @@ +;;; SPDX-License-Identifier: MIT +;;; SPDX-FileCopyrightText: 2020 Wolfgang Corcoran-Mathe + +;;;;; SRFI 178 macros for internal use + +;;; Bitvector type definition +;;; W wraps a u8vector as a bitvector, U unwraps it again + +(define-record-type + (W u8vec) + bitvector? + (u8vec U)) + +;; Convert a bit to an integer +(define-syntax I + (syntax-rules () + ((I bit) + (cond + ((eqv? bit 0) 0) + ((not bit) 0) + (else 1))))) + +;; Convert a bit to a bool +(define-syntax B + (syntax-rules () + ((B bit) (not (or (eqv? bit 0) (not bit)))))) diff --git a/module/srfi/srfi-178/map2list.scm b/module/srfi/srfi-178/map2list.scm new file mode 100644 index 000000000..7118f59cc --- /dev/null +++ b/module/srfi/srfi-178/map2list.scm @@ -0,0 +1,27 @@ +;;; SPDX-License-Identifier: MIT +;;; SPDX-FileCopyrightText: 2020 Wolfgang Corcoran-Mathe + +(define bitvector-map->list/int + (case-lambda + ((f bvec) ; fast path + (bitvector-fold-right/int (lambda (xs b) (cons (f b) xs)) + '() + bvec)) + ((f . bvecs) + (apply bitvector-fold-right/int + (lambda (xs . bs) (cons (apply f bs) xs)) + '() + bvecs)))) + +(define bitvector-map->list/bool + (case-lambda + ((f bvec) ; fast path + (bitvector-fold-right/bool (lambda (xs b) (cons (f b) xs)) + '() + bvec)) + ((f . bvecs) + (apply bitvector-fold-right/bool + (lambda (xs . bs) (cons (apply f bs) xs)) + '() + bvecs)))) + diff --git a/module/srfi/srfi-178/quasi-ints.scm b/module/srfi/srfi-178/quasi-ints.scm new file mode 100644 index 000000000..f66e4ee27 --- /dev/null +++ b/module/srfi/srfi-178/quasi-ints.scm @@ -0,0 +1,54 @@ +;;; SPDX-License-Identifier: MIT +;;; SPDX-FileCopyrightText: 2020 Wolfgang Corcoran-Mathe + +(define (bitvector-logical-shift bvec count bit) + (cond ((positive? count) + (%bitvector-left-shift bvec count (I bit))) + ((negative? count) + (%bitvector-right-shift bvec (- count) (I bit))) + (else bvec))) + +(define (%bitvector-left-shift bvec count bit) + (let ((len (bitvector-length bvec))) + (bitvector-unfold + (lambda (i) + (let ((i* (+ i count))) + (if (< i* len) (bitvector-ref/int bvec i*) bit))) + len))) + +(define (%bitvector-right-shift bvec count bit) + (bitvector-unfold + (lambda (i) + (if (< i count) + bit + (bitvector-ref/int bvec (- i count)))) + (bitvector-length bvec))) + +(define (bitvector-count bit bvec) + (let ((int (I bit))) + (bitvector-fold/int (lambda (n b) (if (= b int) (+ n 1) n)) + 0 + bvec))) + +(define (bitvector-count-run bit bvec index) + (let ((int (I bit)) + (len (bitvector-length bvec))) + (let lp ((i index) (c 0)) + (if (or (>= i len) (not (= int (bitvector-ref/int bvec i)))) + c + (lp (+ i 1) (+ c 1)))))) + +(define (bitvector-if if-bvec then-bvec else-bvec) + (bitvector-map/bool (lambda (bit then-bit else-bit) + (if bit then-bit else-bit)) + if-bvec + then-bvec + else-bvec)) + +(define (bitvector-first-bit bit bvec) + (let ((int (I bit)) (len (bitvector-length bvec))) + (let lp ((i 0)) + (cond ((>= i len) -1) + ((= int (bitvector-ref/int bvec i)) i) + (else (lp (+ i 1))))))) + diff --git a/module/srfi/srfi-178/quasi-strs.scm b/module/srfi/srfi-178/quasi-strs.scm new file mode 100644 index 000000000..2d63b43ad --- /dev/null +++ b/module/srfi/srfi-178/quasi-strs.scm @@ -0,0 +1,88 @@ +;;; SPDX-License-Identifier: MIT +;;; SPDX-FileCopyrightText: 2020 Wolfgang Corcoran-Mathe + +(define (bitvector-prefix-length bvec1 bvec2) + (let ((end (min (bitvector-length bvec1) (bitvector-length bvec2)))) + (if (eqv? bvec1 bvec2) + end + (let lp ((i 0)) + (if (or (>= i end) + (not (= (bitvector-ref/int bvec1 i) + (bitvector-ref/int bvec2 i)))) + i + (lp (+ i 1))))))) + +(define (bitvector-suffix-length bvec1 bvec2) + (let ((end1 (bitvector-length bvec1)) + (end2 (bitvector-length bvec2))) + (let* ((delta (min end1 end2)) + (start (- end1 delta))) + (if (eqv? bvec1 bvec2) + delta + (let lp ((i (- end1 1)) (j (- end2 1))) + (if (or (< i start) + (not (= (bitvector-ref/int bvec1 i) + (bitvector-ref/int bvec2 j)))) + (- (- end1 i) 1) + (lp (- i 1) (- j 1)))))))) + +(define (bitvector-prefix? bvec1 bvec2) + (let ((len1 (bitvector-length bvec1))) + (and (<= len1 (bitvector-length bvec2)) + (= (bitvector-prefix-length bvec1 bvec2) len1)))) + +(define (bitvector-suffix? bvec1 bvec2) + (let ((len1 (bitvector-length bvec1))) + (and (<= len1 (bitvector-length bvec2)) + (= (bitvector-suffix-length bvec1 bvec2) len1)))) + +(define (bitvector-pad bit bvec len) + (let ((old-len (bitvector-length bvec))) + (if (<= len old-len) + bvec + (let ((result (make-bitvector len bit))) + (bitvector-copy! result (- len old-len) bvec) + result)))) + +(define (bitvector-pad-right bit bvec len) + (if (<= len (bitvector-length bvec)) + bvec + (let ((result (make-bitvector len bit))) + (bitvector-copy! result 0 bvec) + result))) + +(define (%bitvector-skip bvec bit) + (let ((len (bitvector-length bvec)) + (int (bit->integer bit))) + (let lp ((i 0)) + (and (< i len) + (if (= int (bitvector-ref/int bvec i)) + (lp (+ i 1)) + i))))) + +(define (%bitvector-skip-right bvec bit) + (let ((len (bitvector-length bvec)) + (int (bit->integer bit))) + (let lp ((i (- len 1))) + (and (>= i 0) + (if (= int (bitvector-ref/int bvec i)) + (lp (- i 1)) + i))))) + +(define (bitvector-trim bit bvec) + (cond ((%bitvector-skip bvec bit) => + (lambda (skip) + (bitvector-copy bvec skip (bitvector-length bvec)))) + (else (bitvector)))) + +(define (bitvector-trim-right bit bvec) + (cond ((%bitvector-skip-right bvec bit) => + (lambda (skip) + (bitvector-copy bvec 0 (+ skip 1)))) + (else (bitvector)))) + +(define (bitvector-trim-both bit bvec) + (cond ((%bitvector-skip bvec bit) => + (lambda (skip) + (bitvector-copy bvec skip (+ 1 (%bitvector-skip-right bvec bit))))) + (else (bitvector)))) diff --git a/module/srfi/srfi-178/unfolds.scm b/module/srfi/srfi-178/unfolds.scm new file mode 100644 index 000000000..fa5956926 --- /dev/null +++ b/module/srfi/srfi-178/unfolds.scm @@ -0,0 +1,44 @@ +;;; SPDX-License-Identifier: MIT +;;; SPDX-FileCopyrightText: 2020 Wolfgang Corcoran-Mathe + +;;;; unfold + +;;; These procedures work by building temporary lists, then converting +;;; them to vectors. This uses more space than pre-allocating a bitvector +;;; and filling it, but it's referentially transparent: there's no way +;;; to capture a partially-filled bitvector through continuation tricks. + +;; Unfold a list. f is passed the current index and list of seeds +;; on each step, and must return a bit and new seeds on each step. +(define (%unfold/index f len seeds) + (letrec + ((build + (lambda (i seeds) + (if (= i len) + '() + (let-values (((b . seeds*) (apply f i seeds))) + (cons b (build (+ i 1) seeds*))))))) + + (build 0 seeds))) + +(define (bitvector-unfold f len . seeds) + (list->bitvector (%unfold/index f len seeds))) + +;;;; unfold-right + +;; Unfold a list from the right. f is passed the current index and +;; list of seeds on each step, and must return a bit and new seeds +;; on each step. +(define (%unfold-right/index f len seeds) + (letrec + ((build + (lambda (i seeds res) + (if (< i 0) + res + (let-values (((b . seeds*) (apply f i seeds))) + (build (- i 1) seeds* (cons b res))))))) + + (build (- len 1) seeds '()))) + +(define (bitvector-unfold-right f len . seeds) + (list->bitvector (%unfold-right/index f len seeds))) diff --git a/module/srfi/srfi-178/wrappers.scm b/module/srfi/srfi-178/wrappers.scm new file mode 100644 index 000000000..bb439dd12 --- /dev/null +++ b/module/srfi/srfi-178/wrappers.scm @@ -0,0 +1,285 @@ +;;; SPDX-License-Identifier: MIT +;;; SPDX-FileCopyrightText: 2020 Wolfgang Corcoran-Mathe + +;;;; SRFI 178 procedures that are just wrappers + +(define make-bitvector + (case-lambda + ((size) (W (make-u8vector size))) + ((size bit) (W (make-u8vector size (I bit)))))) + +(define bitvector-copy + (case-lambda + ((bvec) (W (u8vector-copy (U bvec)))) + ((bvec start) (W (u8vector-copy (U bvec) start))) + ((bvec start end) (W (u8vector-copy (U bvec) start end))))) + +(define bitvector-reverse-copy + (case-lambda + ((bvec) (W (u8vector-reverse-copy (U bvec)))) + ((bvec start) (W (u8vector-reverse-copy (U bvec) start))) + ((bvec start end) (W (u8vector-reverse-copy (U bvec) start end))))) + +(define (bitvector-append . bvecs) + (bitvector-concatenate bvecs)) + +(define (bitvector-concatenate bvecs) + (W (u8vector-concatenate (map U bvecs)))) + +(define (bitvector-append-subbitvectors . args) + (W (apply u8vector-append-subvectors + (map (lambda (x) (if (bitvector? x) (U x) x)) args)))) + +(define (bitvector-empty? bvec) + (eqv? 0 (u8vector-length (U bvec)))) + +(define (bitvector=? . bvecs) + (apply u8vector= (map U bvecs))) + +(define (bitvector-ref/int bvec i) + (u8vector-ref (U bvec) i)) + +(define (bitvector-ref/bool bvec i) + (B (u8vector-ref (U bvec) i))) + +(define (bitvector-length bvec) + (u8vector-length (U bvec))) + +(define (bitvector-take bvec n) + (W (u8vector-take (U bvec) n))) + +(define (bitvector-take-right bvec n) + (W (u8vector-take-right (U bvec) n))) + +(define (bitvector-drop bvec n) + (W (u8vector-drop (U bvec) n))) + +(define (bitvector-drop-right bvec n) + (W (u8vector-drop-right (U bvec) n))) + +(define (bitvector-segment bvec n) + (unless (and (integer? n) (positive? n)) + (error "bitvector-segment: not a positive integer" n)) + (map W (u8vector-segment (U bvec) n))) + +(define bitvector-fold/int + (case-lambda + ((kons knil bvec) + (u8vector-fold kons knil (U bvec))) ; fast path + ((kons knil . bvecs) + (apply u8vector-fold kons knil (map U bvecs))))) + +(define bitvector-fold/bool + (case-lambda + ((kons knil bvec) + (u8vector-fold (lambda (x b) (kons x (B b))) ; fast path + knil + (U bvec))) + ((kons knil . bvecs) + (apply u8vector-fold + (lambda (x . bits) + (apply kons x (map bit->boolean bits))) + knil + (map U bvecs))))) + +(define bitvector-fold-right/int + (case-lambda + ((kons knil bvec) + (u8vector-fold-right kons knil (U bvec))) ; fast path + ((kons knil . bvecs) + (apply u8vector-fold-right kons knil (map U bvecs))))) + +(define bitvector-fold-right/bool + (case-lambda + ((kons knil bvec) + (u8vector-fold-right (lambda (x bit) (kons x (B bit))) ; fast path + knil + (U bvec))) + ((kons knil . bvecs) + (apply u8vector-fold-right + (lambda (x . bits) + (apply kons x (map bit->boolean bits))) + knil + (map U bvecs))))) + +(define bitvector-map/int + (case-lambda + ((f bvec) + (W (u8vector-map f (U bvec)))) ; one-bitvector fast path + ((f bvec1 bvec2) + (%bitvector-map2/int f bvec1 bvec2)) ; two-bitvector fast path + ((f . bvecs) + (W (apply u8vector-map f (map U bvecs)))))) ; normal path + +;; Tuned two-bitvector version, mainly for binary logical ops. +(define (%bitvector-map2/int f bvec1 bvec2) + (let ((u8vec1 (U bvec1)) + (u8vec2 (U bvec2))) + (bitvector-unfold + (lambda (i) + (f (u8vector-ref u8vec1 i) (u8vector-ref u8vec2 i))) + (bitvector-length bvec1)))) + +(define bitvector-map/bool + (case-lambda + ((f bvec) ; one-bitvector fast path + (W (u8vector-map (lambda (n) (I (f (B n)))) (U bvec)))) + ((f bvec1 bvec2) ; two-bitvector fast path + (%bitvector-map2/int (lambda (n m) (I (f (B n) (B m)))) bvec1 bvec2)) + ((f . bvecs) ; normal path (ugh) + (W (apply u8vector-map + (lambda ns (I (apply f (map bit->boolean ns)))) + (map U bvecs)))))) + +(define bitvector-map!/int + (case-lambda + ((f bvec) + (u8vector-map! f (U bvec))) ; one-bitvector fast path + ((f bvec1 bvec2) + (%bitvector-map2!/int f bvec1 bvec2)) ; two-bitvector fast path + ((f . bvecs) + (apply u8vector-map! f (map U bvecs))))) ; normal path + +;; Tuned two-bitvector version, mainly for binary logical ops. +(define (%bitvector-map2!/int f bvec1 bvec2) + (let ((len (bitvector-length bvec1)) + (u8vec1 (U bvec1)) + (u8vec2 (U bvec2))) + (let lp ((i 0)) + (unless (>= i len) + (u8vector-set! u8vec1 i (f (u8vector-ref u8vec1 i) + (u8vector-ref u8vec2 i))) + (lp (+ i 1)))) + bvec1)) + +(define bitvector-map!/bool + (case-lambda + ((f bvec) ; one-bitvector fast path + (u8vector-map! (lambda (n) (I (f (B n)))) (U bvec))) + ((f bvec1 bvec2) ; two-bitvector fast path + (%bitvector-map2!/int (lambda (n m) (I (f (B n) (B m)))) bvec1 bvec2)) + ((f . bvecs) ; normal path (ugh) + (apply u8vector-map! + (lambda ns (I (apply f (map bit->boolean ns)))) + (map U bvecs))))) + +(define bitvector-for-each/int + (case-lambda + ((f bvec) + (u8vector-for-each f (U bvec))) ; fast path + ((f . bvecs) + (apply u8vector-for-each f (map U bvecs))))) + +(define bitvector-for-each/bool + (case-lambda + ((f bvec) + (u8vector-for-each (lambda (n) (f (B n))) (U bvec))) ; fast path + ((f . bvecs) + (apply u8vector-for-each + (lambda ns (apply f (map bit->boolean ns))) + (map U bvecs))))) + +(define (bitvector-set! bvec i bit) + (u8vector-set! (U bvec) i (I bit))) + +(define (bitvector-swap! bvec i j) + (u8vector-swap! (U bvec) i j)) + + +(define bitvector-reverse! + (case-lambda + ((bvec) + (u8vector-reverse! (U bvec))) + ((bvec start) + (u8vector-reverse! (U bvec) start)) + ((bvec start end) + (u8vector-reverse! (U bvec) start end)))) + +(define bitvector-copy! + (case-lambda + ((to at from) + (u8vector-copy! (U to) at (U from))) + ((to at from start) + (u8vector-copy! (U to) at (U from) start)) + ((to at from start end) + (u8vector-copy! (U to) at (U from) start end)))) + +(define bitvector-reverse-copy! + (case-lambda + ((to at from) + (u8vector-reverse-copy! (U to) at (U from))) + ((to at from start) + (u8vector-reverse-copy! (U to) at (U from) start)) + ((to at from start end) + (u8vector-reverse-copy! (U to) at (U from) start end)))) + +(define bitvector->list/int + (case-lambda + ((bvec) + (u8vector->list (U bvec))) + ((bvec start) + (u8vector->list (U bvec) start)) + ((bvec start end) + (u8vector->list (U bvec) start end)))) + +(define bitvector->list/bool + (case-lambda + ((bvec) + (map bit->boolean (u8vector->list (U bvec)))) + ((bvec start) + (map bit->boolean (u8vector->list (U bvec) start))) + ((bvec start end) + (map bit->boolean (u8vector->list (U bvec) start end))))) + +(define reverse-bitvector->list/int + (case-lambda + ((bvec) + (reverse-u8vector->list (U bvec))) + ((bvec start) + (reverse-u8vector->list (U bvec) start)) + ((bvec start end) + (reverse-u8vector->list (U bvec) start end)))) + +(define reverse-bitvector->list/bool + (case-lambda + ((bvec) + (map bit->boolean (reverse-u8vector->list (U bvec)))) + ((bvec start) + (map bit->boolean (reverse-u8vector->list (U bvec) start))) + ((bvec start end) + (map bit->boolean (reverse-u8vector->list (U bvec) start end))))) + +(define bitvector->vector/int + (case-lambda + ((bvec) + (u8vector->vector (U bvec))) + ((bvec start) + (u8vector->vector (U bvec) start)) + ((bvec start end) + (u8vector->vector (U bvec) start end)))) + +(define bitvector->vector/bool + (case-lambda + ((bvec) + (vector-map bit->boolean (u8vector->vector (U bvec)))) + ((bvec start) + (vector-map bit->boolean (u8vector->vector (U bvec) start))) + ((bvec start end) + (vector-map bit->boolean (u8vector->vector (U bvec) start end))))) + +(define (list->bitvector list) + (W (list->u8vector (map bit->integer list)))) + +(define (reverse-list->bitvector list) + (W (reverse-list->u8vector (map bit->integer list)))) + +(define (bitvector . bits) (list->bitvector bits)) + +(define vector->bitvector + (case-lambda + ((vec) + (W (vector->u8vector (vector-map bit->integer vec)))) + ((vec start) + (W (vector->u8vector (vector-map bit->integer vec) start))) + ((vec start end) + (W (vector->u8vector (vector-map bit->integer vec) start end))))) diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am index 1afac2bca..6ee26e869 100644 --- a/test-suite/Makefile.am +++ b/test-suite/Makefile.am @@ -169,6 +169,7 @@ SCM_TESTS = tests/00-initial-env.test \ tests/srfi-160-base.test \ tests/srfi-160.test \ tests/srfi-171.test \ + tests/srfi-178.test \ tests/srfi-4.test \ tests/srfi-9.test \ tests/statprof.test \ @@ -220,6 +221,16 @@ EXTRA_DIST = \ tests/srfi-151-test.scm \ tests/srfi-160-base-test.scm \ tests/srfi-160-test.scm \ + tests/srfi-178-test/constructors.scm \ + tests/srfi-178-test/conversions.scm \ + tests/srfi-178-test/fields.scm \ + tests/srfi-178-test/gen-accum.scm \ + tests/srfi-178-test/iterators.scm \ + tests/srfi-178-test/logic-ops.scm \ + tests/srfi-178-test/mutators.scm \ + tests/srfi-178-test/quasi-ints.scm \ + tests/srfi-178-test/quasi-string.scm \ + tests/srfi-178-test/selectors.scm \ ChangeLog-2008 diff --git a/test-suite/tests/srfi-178-test/constructors.scm b/test-suite/tests/srfi-178-test/constructors.scm new file mode 100644 index 000000000..3e133703a --- /dev/null +++ b/test-suite/tests/srfi-178-test/constructors.scm @@ -0,0 +1,88 @@ +;;; SPDX-License-Identifier: MIT +;;; SPDX-FileCopyrightText: 2020 Wolfgang Corcoran-Mathe + +(define (check-constructors) + (print-header "Checking constructors...") + + (check (bitvector-length (make-bitvector 8)) => 8) + (check (bitvector= (make-bitvector 4 0) (bitvector 0 0 0 0)) => #t) + (check (bitvector= (make-bitvector 4 #t) (bitvector 1 1 1 1)) => #t) + + ;;; unfolds + + (check (bitvector= + (bitvector-unfold (lambda (_) 0) 4) + (bitvector 0 0 0 0)) + => #t) + (check (bitvector= + (bitvector-unfold (lambda (_ b) (values b (not b))) 4 #f) + (bitvector 0 1 0 1)) + => #t) + (check (bitvector= + (bitvector-unfold (lambda (_ b c) + (values (and b c) (not b) c)) + 4 + #t + #t) + (bitvector 1 0 1 0)) + => #t) + (check (bitvector= + (bitvector-unfold-right (lambda (_) 0) 4) + (bitvector 0 0 0 0)) + => #t) + (check (bitvector= + (bitvector-unfold-right (lambda (_ b) (values b (not b))) 4 #f) + (bitvector 1 0 1 0)) + => #t) + (check (bitvector= + (bitvector-unfold-right (lambda (_ b c) + (values (and b c) (not b) c)) + 4 + #t + #t) + (bitvector 0 1 0 1)) + => #t) + + ;;; copy + + (let ((bvec (bitvector 1 0 1 0))) + (check (bitvector= bvec (bitvector-copy bvec)) => #t) + (check (eqv? bvec (bitvector-copy bvec)) => #f)) ; fresh copy? + (check (bitvector= (bitvector-copy (bitvector 1 0 1 0) 1) (bitvector 0 1 0)) + => #t) + (check (bitvector= (bitvector-copy (bitvector 1 0 1 0) 2 4) (bitvector 1 0)) + => #t) + + (let ((bvec (bitvector 1 0 1 0))) + (check (equal? (bitvector->list/int (bitvector-reverse-copy bvec)) + (reverse (bitvector->list/int bvec))) + => #t) + (check (eqv? bvec (bitvector-reverse-copy bvec)) => #f)) ; fresh copy? + (check (bitvector= (bitvector-reverse-copy (bitvector 1 0 1 0) 1) + (bitvector 0 1 0)) + => #t) + (check (bitvector= (bitvector-reverse-copy (bitvector 1 0 1 0) 2 4) + (bitvector 0 1)) + => #t) + + ;;; append & concatenate + + (check (bitvector= + (bitvector-append (bitvector 1 0) (bitvector 0 1)) + (bitvector 1 0 0 1)) + => #t) + (check (bitvector= + (bitvector-append (bitvector 1 0) (bitvector 0 1) (bitvector)) + (bitvector 1 0 0 1)) + => #t) + (check (bitvector= + (bitvector-concatenate + (list (bitvector 1 0) (bitvector 0 1) (bitvector))) + (bitvector 1 0 0 1)) + => #t) + (check (bitvector= + (bitvector-append-subbitvectors (bitvector 1 0 0 1) 0 2 + (bitvector 1 1 1 1) 2 4) + (bitvector 1 0 1 1)) + => #t) +) diff --git a/test-suite/tests/srfi-178-test/conversions.scm b/test-suite/tests/srfi-178-test/conversions.scm new file mode 100644 index 000000000..7d3b3f232 --- /dev/null +++ b/test-suite/tests/srfi-178-test/conversions.scm @@ -0,0 +1,108 @@ +;;; SPDX-License-Identifier: MIT +;;; SPDX-FileCopyrightText: 2020 Wolfgang Corcoran-Mathe + +(define (check-bitvector-conversions) + (print-header "Checking bitvector conversions...") + + ;;; lists + + (check (bitvector->list/int (bitvector)) => '()) + (check (bitvector->list/int (bitvector 1 0 1 0)) => '(1 0 1 0)) + (check (bitvector->list/int (bitvector 1 0 1 0) 2) => '(1 0)) + (check (bitvector->list/int (bitvector 1 0 1 0) 1 3) => '(0 1)) + (check (bitvector->list/bool (bitvector)) => '()) + (check (bitvector->list/bool (bitvector 1 0 1 0)) => '(#t #f #t #f)) + (check (bitvector->list/bool (bitvector 1 0 1 0) 2) => '(#t #f)) + (check (bitvector->list/bool (bitvector 1 0 1 0) 1 3) => '(#f #t)) + + (check (reverse-bitvector->list/int (bitvector)) => '()) + (check (reverse-bitvector->list/int (bitvector 1 0 1 0) 2) => '(0 1)) + (check (reverse-bitvector->list/int (bitvector 1 0 1 0) 1 3) => '(1 0)) + (let ((bvec (bitvector 1 0 1 0))) + (check (equal? (reverse-bitvector->list/int bvec) + (reverse (bitvector->list/int bvec))) + => #t) + (check (equal? (reverse-bitvector->list/bool bvec) + (reverse (bitvector->list/bool bvec))) + => #t)) + (check (reverse-bitvector->list/bool (bitvector)) => '()) + (check (reverse-bitvector->list/bool (bitvector 1 0 1 0) 2) => '(#f #t)) + (check (reverse-bitvector->list/bool (bitvector 1 0 1 0) 1 3) => '(#t #f)) + + (check (bitvector= (list->bitvector '(1 0 #t #f)) (bitvector 1 0 1 0)) => #t) + (let ((bs '(1 0 1 0))) + (check (equal? bs (bitvector->list/int (list->bitvector bs))) => #t) + (check (equal? bs + (reverse-bitvector->list/int + (reverse-list->bitvector bs))) + => #t)) + (check (bitvector= (reverse-list->bitvector '(1 0 #t #f)) (bitvector 0 1 0 1)) + => #t) + + ;;; vectors + + (check (bitvector->vector/int (bitvector)) => #()) + (check (bitvector->vector/int (bitvector 1 0 1 0)) => #(1 0 1 0)) + (check (bitvector->vector/int (bitvector 1 0 1 0) 1) => #(0 1 0)) + (check (bitvector->vector/int (bitvector 1 0 1 0) 1 3) => #(0 1)) + (check (bitvector->vector/bool (bitvector)) => #()) + (check (bitvector->vector/bool (bitvector 1 0 1 0)) => #(#t #f #t #f)) + (check (bitvector->vector/bool (bitvector 1 0 1 0) 1) => #(#f #t #f)) + (check (bitvector->vector/bool (bitvector 1 0 1 0) 1 3) => #(#f #t)) + + (check (reverse-bitvector->vector/int (bitvector)) => #()) + (check (reverse-bitvector->vector/int (bitvector 1 0 1 0)) => #(0 1 0 1)) + (check (reverse-bitvector->vector/int (bitvector 1 0 1 0) 2) => #(0 1)) + (check (reverse-bitvector->vector/int (bitvector 1 0 1 0) 1 3) => #(1 0)) + (check (reverse-bitvector->vector/bool (bitvector)) => #()) + (check (reverse-bitvector->vector/bool (bitvector 1 0 1 0)) + => #(#f #t #f #t)) + (check (reverse-bitvector->vector/bool (bitvector 1 0 1 0) 2) => #(#f #t)) + (check (reverse-bitvector->vector/bool (bitvector 1 0 1 0) 1 3) => #(#t #f)) + + (check (bitvector-empty? (vector->bitvector #())) => #t) + (check (bitvector= (vector->bitvector #(1 0 #t #f)) + (bitvector 1 0 1 0)) + => #t) + (check (bitvector= (vector->bitvector #(1 0 1 0) 1) + (bitvector 0 1 0)) + => #t) + (check (bitvector= (vector->bitvector #(1 0 1 0) 1 3) + (bitvector 0 1)) + => #t) + (check (bitvector-empty? (reverse-vector->bitvector #())) => #t) + (check (bitvector= (reverse-vector->bitvector #(1 0 #t #f)) + (bitvector 0 1 0 1)) + => #t) + (check (bitvector= (reverse-vector->bitvector #(1 0 1 0) 2) + (bitvector 0 1)) + => #t) + (check (bitvector= (reverse-vector->bitvector #(1 0 1 0) 1 3) + (bitvector 1 0)) + => #t) + + ;;; strings + + (check (bitvector->string (bitvector 1 0 1 0)) => "#*1010") + (check (bitvector->string (bitvector)) => "#*") + (check (bitvector= (string->bitvector "#*1010") (bitvector 1 0 1 0)) + => #t) + (check (bitvector-empty? (string->bitvector "#*")) => #t) + (check (string->bitvector "") => #f) + (check (string->bitvector "1010") => #f) + (check (string->bitvector "#") => #f) + (let ((bvec (bitvector 1 0 1 0))) + (check (bitvector= (string->bitvector (bitvector->string bvec)) + bvec) + => #t)) + + ;;; integers + + ;; Remember, these are little-endian! + (check (bitvector->integer (bitvector 0 1 0 1)) => #xa) + (check (bitvector->integer (bitvector 1 0 1 0 1 1 0 1)) => #xb5) + (check (bitvector= (integer->bitvector #xa) (bitvector 0 1 0 1)) => #t) + (check (bitvector= (integer->bitvector #xb5) (bitvector 1 0 1 0 1 1 0 1)) + => #t) + (check (bitvector= (integer->bitvector #xb5 4) (bitvector 1 0 1 0)) => #t) +) diff --git a/test-suite/tests/srfi-178-test/fields.scm b/test-suite/tests/srfi-178-test/fields.scm new file mode 100644 index 000000000..bde5f4aaf --- /dev/null +++ b/test-suite/tests/srfi-178-test/fields.scm @@ -0,0 +1,98 @@ +;;; SPDX-License-Identifier: MIT +;;; SPDX-FileCopyrightText: 2020 Wolfgang Corcoran-Mathe + +(define (check-bit-field-operations) + (print-header "Checking bit field operations...") + + (check (bitvector-field-any? (bitvector 0 1 0 0) 0 4) => #t) + (check (bitvector-field-any? (bitvector 0 0 0 0) 0 4) => #f) + (check (bitvector-field-any? (bitvector 0 1 0 0) 1 3) => #t) + (check (bitvector-field-any? (bitvector 0 1 0 0) 2 4) => #f) + + (check (bitvector-field-every? (make-bitvector 4 1) 0 4) => #t) + (check (bitvector-field-every? (bitvector 1 1 1 0) 0 4) => #f) + (check (bitvector-field-every? (bitvector 1 1 0 0) 0 2) => #t) + (check (bitvector-field-every? (bitvector 1 1 0 0) 2 4) => #f) + + (check (bitvector= (bitvector-field-clear (make-bitvector 4 1) 0 2) + (bitvector 0 0 1 1)) + => #t) + (let ((bvec (make-bitvector 4 1))) + (check (bitvector= (begin (bitvector-field-clear! bvec 0 2) bvec) + (bitvector 0 0 1 1)) + => #t)) + (check (bitvector= (bitvector-field-set (make-bitvector 4 0) 0 2) + (bitvector 1 1 0 0)) + => #t) + (let ((bvec (make-bitvector 4 0))) + (check (bitvector= (begin (bitvector-field-set! bvec 0 2) bvec) + (bitvector 1 1 0 0)) + => #t)) + + ;;; replace-same and replace + + (check + (bitvector= + (bitvector-field-replace-same (make-bitvector 4 0) + (make-bitvector 4 1) + 1 + 3) + (bitvector 0 1 1 0)) + => #t) + (let ((bvec (make-bitvector 4 0))) + (check + (bitvector= (begin + (bitvector-field-replace-same! bvec + (make-bitvector 4 1) + 1 + 3) + bvec) + (bitvector 0 1 1 0)) + => #t)) + (check + (bitvector= + (bitvector-field-replace (make-bitvector 4 0) (bitvector 1 0 0 0) 1 3) + (bitvector 0 1 0 0)) + => #t) + (let ((bvec (make-bitvector 4 0))) + (check + (bitvector= (begin + (bitvector-field-replace! bvec (make-bitvector 4 1) 1 3) + bvec) + (bitvector 0 1 1 0)) + => #t)) + + ;;; rotate + + (check (bitvector= (bitvector-field-rotate (bitvector 1 0 0 1) 1 0 4) + (bitvector 0 0 1 1)) + => #t) + (check (bitvector= (bitvector-field-rotate (bitvector 1 0 0 1) -1 0 4) + (bitvector 1 1 0 0)) + => #t) + (check (bitvector= + (bitvector-field-rotate (bitvector 1 0 0 1 1 0 1 0) 2 2 6) + (bitvector 1 0 1 0 0 1 1 0)) + => #t) + (check (bitvector= + (bitvector-field-rotate (bitvector 1 0 0 1 1 0 1 0) -3 2 6) + (bitvector 1 0 1 1 0 0 1 0)) + => #t) + + ;;; flip + + (check (bitvector= (bitvector-field-flip (bitvector 0 1 0 1) 0 4) + (bitvector 1 0 1 0)) + => #t) + (check (bitvector= (bitvector-field-flip (bitvector 0 1 0 1) 2 4) + (bitvector 0 1 1 0)) + => #t) + (let ((bvec (bitvector 0 1 0 1))) + (check (bitvector= (begin (bitvector-field-flip! bvec 0 4) bvec) + (bitvector 1 0 1 0)) + => #t)) + (let ((bvec (bitvector 0 1 0 1))) + (check (bitvector= (begin (bitvector-field-flip! bvec 2 4) bvec) + (bitvector 0 1 1 0)) + => #t)) +) diff --git a/test-suite/tests/srfi-178-test/gen-accum.scm b/test-suite/tests/srfi-178-test/gen-accum.scm new file mode 100644 index 000000000..ab14912f3 --- /dev/null +++ b/test-suite/tests/srfi-178-test/gen-accum.scm @@ -0,0 +1,72 @@ +;;; SPDX-License-Identifier: MIT +;;; SPDX-FileCopyrightText: 2020 Wolfgang Corcoran-Mathe + +(define (check-generators-and-accumulators) + (define test-bvec (bitvector 1 0 1 1 0 1 0 1)) + (print-header "Checking generators and accumulators...") + + ;;; Generators + + (check (eof-object? ((make-bitvector/int-generator (bitvector)))) => #t) + (check (eof-object? ((make-bitvector/bool-generator (bitvector)))) => #t) + (check (bitvector= + (bitvector-unfold (lambda (_ g) (values (g) g)) + (bitvector-length test-bvec) + (make-bitvector/int-generator test-bvec)) + test-bvec) + => #t) + (check (bitvector= + (bitvector-unfold (lambda (_ g) (values (g) g)) + (bitvector-length test-bvec) + (make-bitvector/bool-generator test-bvec)) + test-bvec) + => #t) + + ;;; Accumulator + + (check (bitvector-empty? ((make-bitvector-accumulator) (eof-object))) + => #t) + ;; Accumulate integers. + (check (bitvector= test-bvec + (let ((acc (make-bitvector-accumulator))) + (bitvector-for-each/int acc test-bvec) + (acc (eof-object)))) + => #t) + ;; Accumulate booleans. + (check (bitvector= test-bvec + (let ((acc (make-bitvector-accumulator))) + (bitvector-for-each/bool acc test-bvec) + (acc (eof-object)))) + => #t) + + ;;; Generator/accumulator identities + + ;; Accumulating generated values yields the original structure. + (check (bitvector= + (let ((gen (make-bitvector/int-generator test-bvec)) + (acc (make-bitvector-accumulator))) + (generator-for-each acc gen) + (acc (eof-object))) + test-bvec) + => #t) + + ;; Generating accumulated values yields the original values. + ;; Integer generator. + (let ((lis (bitvector->list/int test-bvec))) + (check (equal? + (let ((acc (make-bitvector-accumulator))) + (for-each acc lis) + (generator->list + (make-bitvector/int-generator (acc (eof-object))))) + lis) + => #t)) + ;; Boolean generator. + (let ((lis (bitvector->list/bool test-bvec))) + (check (equal? + (let ((acc (make-bitvector-accumulator))) + (for-each acc lis) + (generator->list + (make-bitvector/bool-generator (acc (eof-object))))) + lis) + => #t)) +) diff --git a/test-suite/tests/srfi-178-test/iterators.scm b/test-suite/tests/srfi-178-test/iterators.scm new file mode 100644 index 000000000..239572b6a --- /dev/null +++ b/test-suite/tests/srfi-178-test/iterators.scm @@ -0,0 +1,150 @@ +;;; SPDX-License-Identifier: MIT +;;; SPDX-FileCopyrightText: 2020 Wolfgang Corcoran-Mathe + +(define (check-iterators) + (print-header "Checking iteration...") + + ;;; take & take-right + + (check (bitvector= (bitvector-take (bitvector 1 0 1 0) 2) + (bitvector 1 0)) + => #t) + (check (bitvector-empty? (bitvector-take (bitvector 1 0) 0)) => #t) + (let ((bvec (bitvector 1 0 1 0))) + (check (bitvector= (bitvector-take bvec (bitvector-length bvec)) + bvec) + => #t) + (check (bitvector= (bitvector-take-right bvec (bitvector-length bvec)) + bvec) + => #t)) + (check (bitvector= (bitvector-take-right (bitvector 1 0 1 0) 3) + (bitvector 0 1 0)) + => #t) + (check (bitvector-empty? (bitvector-take-right (bitvector 1 0) 0)) => #t) + + ;;; drop & drop-right + + (check (bitvector= (bitvector-drop (bitvector 1 0 1 0) 1) + (bitvector 0 1 0)) + => #t) + (let ((bvec (bitvector 1 0 1 0))) + (check (bitvector-empty? (bitvector-drop bvec (bitvector-length bvec))) + => #t) + (check (bitvector= (bitvector-drop bvec 0) bvec) => #t) + (check (bitvector= (bitvector-drop-right bvec 0) bvec) => #t) + (check (bitvector-empty? + (bitvector-drop-right bvec (bitvector-length bvec))) + => #t)) + (check (bitvector= (bitvector-drop-right (bitvector 1 0 1 0) 1) + (bitvector 1 0 1)) + => #t) + + ;;; segment + + (check (bitvector= (car (bitvector-segment (bitvector 1 0 1 0) 2)) + (bitvector 1 0)) + => #t) + (let ((bvec (bitvector 1 0 1 0))) + (check (bitvector= (bitvector-concatenate (bitvector-segment bvec 1)) + bvec) + => #t)) + + ;;; fold + + (check (bitvector-fold/int + 0 (bitvector)) => 0) + (check (bitvector-fold/int + 0 (bitvector 1)) => 1) + (check (bitvector-fold/bool proc-or #f (bitvector)) => #f) + (check (bitvector-fold/bool proc-or #f (bitvector #t)) => #t) + (check (bitvector-fold-right/int + 0 (bitvector)) => 0) + (check (bitvector-fold-right/int + 0 (bitvector 1)) => 1) + (check (bitvector-fold-right/bool proc-or #f (bitvector)) => #f) + (check (bitvector-fold-right/bool proc-or #f (bitvector #t)) => #t) + + ;;; map + + (check (bitvector-empty? (bitvector-map/int values (bitvector))) => #t) + (check (bitvector= (bitvector-map/int (constantly 1) (bitvector 0 0 1)) + (bitvector 1 1 1)) + => #t) + (check (bitvector= (bitvector-map/int (lambda (a b c) b) + (bitvector 1 0 0) + (bitvector 0 1 0) + (bitvector 0 0 1)) + (bitvector 0 1 0)) + => #t) + (check (bitvector-empty? (bitvector-map/bool values (bitvector))) => #t) + (check (bitvector= (bitvector-map/bool (constantly #t) + (bitvector #f #f #t)) + (bitvector #t #t #t)) + => #t) + (check (bitvector= (bitvector-map/bool (lambda (a b c) b) + (bitvector #t #f #f) + (bitvector #f #t #f) + (bitvector #f #f #t)) + (bitvector #f #t #f)) + => #t) + + ;;; map! + + (check (let ((bvec (bitvector))) + (bitvector-map!/int values bvec) + (bitvector-empty? bvec)) + => #t) + (check (let ((bvec (bitvector 1 0 1 0))) + (bitvector-map!/int (constantly 1) bvec) + (bitvector= bvec (bitvector 1 1 1 1))) + => #t) + (check (let ((bvec1 (bitvector 1 0 0)) + (bvec2 (bitvector 0 1 0)) + (bvec3 (bitvector 0 0 1))) + (bitvector-map!/int (lambda (a b c) b) bvec1 bvec2 bvec3) + (bitvector= bvec1 bvec2)) + => #t) + (check (let ((bvec (bitvector))) + (bitvector-map!/bool values bvec) + (bitvector-empty? bvec)) + => #t) + (check (let ((bvec (bitvector #t #f #t #f))) + (bitvector-map!/bool (constantly #t) bvec) + (bitvector= bvec (bitvector #t #t #t #t))) + => #t) + (check (let ((bvec1 (bitvector #t #f #f)) + (bvec2 (bitvector #f #t #f)) + (bvec3 (bitvector #f #f #t))) + (bitvector-map!/bool (lambda (a b c) b) bvec1 bvec2 bvec3) + (bitvector= bvec1 bvec2)) + => #t) + + + ;;; map->list + + (check (bitvector-map->list/bool values (bitvector)) => '()) + (check (bitvector-map->list/int (constantly 1) (bitvector 1 0 0)) => '(1 1 1)) + (check (bitvector-map->list/int list (bitvector 1 0) (bitvector 0 1)) + => '((1 0) (0 1))) + (check (bitvector-map->list/bool values (bitvector)) => '()) + (check (bitvector-map->list/bool (constantly #t) (bitvector 1 0 0)) + => '(#t #t #t)) + (check (bitvector-map->list/bool list (bitvector 1 0) (bitvector 0 1)) + => '((#t #f) (#f #t))) + + ;;; for-each + + (let ((bvec (bitvector 1 0 1 0))) + (check (let ((c 0)) + (bitvector-for-each/int (lambda (_) (set! c (+ c 1))) bvec) + c) + => (bitvector-length bvec)) + (check (let ((lis '())) + (bitvector-for-each/int (lambda (b) (set! lis (cons b lis))) bvec) + lis) + => (reverse-bitvector->list/int bvec)) + (check (let ((c 0)) + (bitvector-for-each/bool (lambda (_) (set! c (+ c 1))) bvec) + c) + => (bitvector-length bvec)) + (check (let ((lis '())) + (bitvector-for-each/bool (lambda (b) (set! lis (cons b lis))) bvec) + lis) + => (reverse-bitvector->list/bool bvec))) +) diff --git a/test-suite/tests/srfi-178-test/logic-ops.scm b/test-suite/tests/srfi-178-test/logic-ops.scm new file mode 100644 index 000000000..e68fdebda --- /dev/null +++ b/test-suite/tests/srfi-178-test/logic-ops.scm @@ -0,0 +1,125 @@ +;;; SPDX-License-Identifier: MIT +;;; SPDX-FileCopyrightText: 2020 Wolfgang Corcoran-Mathe + +(define (check-bitwise-operations) + (define test-bvec1 (bitvector 1 0 1 0)) + (define test-bvec2 (bitvector 1 1 0 0)) + (define test-bvec3 (bitvector 0 0 1 1)) + (print-header "Checking bitwise operations...") + + ;;; not + + (check (bitvector= (bitvector-not test-bvec1) (bitvector 0 1 0 1)) + => #t) + (check (bitvector= (bitvector-not (bitvector-not test-bvec1)) + test-bvec1) + => #t) + + ;;; Associative operations + + (check (bitvector= (bitvector-and test-bvec1 test-bvec2 test-bvec3) + (bitvector 0 0 0 0)) + => #t) + (check (bitvector= (bitvector-ior test-bvec1 test-bvec2 test-bvec3) + (bitvector 1 1 1 1)) + => #t) + (check (bitvector= (bitvector-xor test-bvec1 test-bvec2 test-bvec3) + (bitvector 0 1 0 1)) + => #t) + (check (bitvector= (bitvector-eqv test-bvec1 test-bvec2 test-bvec3) + (bitvector 0 1 0 1)) + => #t) + + (let ((test-bvec1* (bitvector-copy test-bvec1))) + (check + (bitvector= (begin + (bitvector-and! test-bvec1* test-bvec2 test-bvec3) + test-bvec1*) + (bitvector 0 0 0 0)) + => #t)) + (let ((test-bvec1* (bitvector-copy test-bvec1))) + (check + (bitvector= (begin + (bitvector-ior! test-bvec1* test-bvec2 test-bvec3) + test-bvec1*) + (bitvector 1 1 1 1)) + => #t)) + (let ((test-bvec1* (bitvector-copy test-bvec1))) + (check + (bitvector= (begin + (bitvector-xor! test-bvec1* test-bvec2 test-bvec3) + test-bvec1*) + (bitvector 0 1 0 1)) + => #t)) + (let ((test-bvec1* (bitvector-copy test-bvec1))) + (check + (bitvector= (begin + (bitvector-eqv! test-bvec1* test-bvec2 test-bvec3) + test-bvec1*) + (bitvector 0 1 0 1)) + => #t)) + + ;;; Non-associative binary operations + + (check (bitvector= (bitvector-nand test-bvec1 test-bvec2) + (bitvector 0 1 1 1)) + => #t) + (check (bitvector= (bitvector-nor test-bvec1 test-bvec2) + (bitvector 0 0 0 1)) + => #t) + (check (bitvector= (bitvector-andc1 test-bvec1 test-bvec2) + (bitvector 0 1 0 0)) + => #t) + (check (bitvector= (bitvector-andc2 test-bvec1 test-bvec2) + (bitvector 0 0 1 0)) + => #t) + (check (bitvector= (bitvector-orc1 test-bvec1 test-bvec2) + (bitvector 1 1 0 1)) + => #t) + (check (bitvector= (bitvector-orc2 test-bvec1 test-bvec2) + (bitvector 1 0 1 1)) + => #t) + + (let ((test-bvec1* (bitvector-copy test-bvec1))) + (check + (bitvector= (begin + (bitvector-nand! test-bvec1* test-bvec2) + test-bvec1*) + (bitvector 0 1 1 1)) + => #t)) + (let ((test-bvec1* (bitvector-copy test-bvec1))) + (check + (bitvector= (begin + (bitvector-nor! test-bvec1* test-bvec2) + test-bvec1*) + (bitvector 0 0 0 1)) + => #t)) + (let ((test-bvec1* (bitvector-copy test-bvec1))) + (check + (bitvector= (begin + (bitvector-andc1! test-bvec1* test-bvec2) + test-bvec1*) + (bitvector 0 1 0 0)) + => #t)) + (let ((test-bvec1* (bitvector-copy test-bvec1))) + (check + (bitvector= (begin + (bitvector-andc2! test-bvec1* test-bvec2) + test-bvec1*) + (bitvector 0 0 1 0)) + => #t)) + (let ((test-bvec1* (bitvector-copy test-bvec1))) + (check + (bitvector= (begin + (bitvector-orc1! test-bvec1* test-bvec2) + test-bvec1*) + (bitvector 1 1 0 1)) + => #t)) + (let ((test-bvec1* (bitvector-copy test-bvec1))) + (check + (bitvector= (begin + (bitvector-orc2! test-bvec1* test-bvec2) + test-bvec1*) + (bitvector 1 0 1 1)) + => #t)) +) diff --git a/test-suite/tests/srfi-178-test/mutators.scm b/test-suite/tests/srfi-178-test/mutators.scm new file mode 100644 index 000000000..281a67cdd --- /dev/null +++ b/test-suite/tests/srfi-178-test/mutators.scm @@ -0,0 +1,79 @@ +;;; SPDX-License-Identifier: MIT +;;; SPDX-FileCopyrightText: 2020 Wolfgang Corcoran-Mathe + +(define (check-mutators) + (print-header "Checking mutators...") + + (let ((bvec (bitvector 1 0 1 0))) + (check + (bitvector= (begin (bitvector-set! bvec 1 1) bvec) + (bitvector 1 1 1 0)) + => #t)) + (let ((bvec (bitvector 1 0 1 0))) + (check + (bitvector= (begin (bitvector-set! bvec 0 #f) bvec) + (bitvector 0 0 1 0)) + => #t)) + (let ((bvec (bitvector 1 0 1 0))) + (check + (bitvector= (begin (bitvector-swap! bvec 0 1) bvec) + (bitvector 0 1 1 0)) + => #t)) + + ;;; reverse! + + (let ((bvec (bitvector 1 0 1 0))) + (check + (bitvector= (begin (bitvector-reverse! bvec) bvec) + (bitvector 0 1 0 1)) + => #t)) + (let ((bvec (bitvector 1 0 1 0))) + (check + (bitvector= (begin (bitvector-reverse! bvec 2) bvec) + (bitvector 1 0 0 1)) + => #t)) + (let ((bvec (bitvector 1 0 1 0))) + (check + (bitvector= (begin (bitvector-reverse! bvec 1 3) bvec) + (bitvector 1 1 0 0)) + => #t)) + + ;;; copy! + + (let ((bvec (bitvector 0 0 0 0))) + (check + (bitvector= (begin (bitvector-copy! bvec 0 (bitvector 1 0)) bvec) + (bitvector 1 0 0 0)) + => #t)) + (let ((bvec (bitvector 0 0 0 0))) + (check + (bitvector= (begin (bitvector-copy! bvec 1 (bitvector 1 1 0) 1) bvec) + (bitvector 0 1 0 0)) + => #t)) + (let ((bvec (bitvector 0 0 0 0))) + (check + (bitvector= (begin (bitvector-copy! bvec 1 (bitvector 1 0 1) 0 2) bvec) + (bitvector 0 1 0 0)) + => #t)) + + ;;; reverse-copy! + + (let ((bvec (bitvector 0 0 0 0))) + (check + (bitvector= (begin (bitvector-reverse-copy! bvec 0 (bitvector 1 0)) + bvec) + (bitvector 0 1 0 0)) + => #t)) + (let ((bvec (bitvector 0 0 0 0))) + (check + (bitvector= (begin (bitvector-reverse-copy! bvec 1 (bitvector 0 0 1) 1) + bvec) + (bitvector 0 1 0 0)) + => #t)) + (let ((bvec (bitvector 0 0 0 0))) + (check + (bitvector= (begin (bitvector-reverse-copy! bvec 1 (bitvector 0 1 1) 0 2) + bvec) + (bitvector 0 1 0 0)) + => #t)) +) diff --git a/test-suite/tests/srfi-178-test/quasi-ints.scm b/test-suite/tests/srfi-178-test/quasi-ints.scm new file mode 100644 index 000000000..8f59ff1cc --- /dev/null +++ b/test-suite/tests/srfi-178-test/quasi-ints.scm @@ -0,0 +1,41 @@ +;;; SPDX-License-Identifier: MIT +;;; SPDX-FileCopyrightText: 2020 Wolfgang Corcoran-Mathe + +(define (check-quasi-integer-operations) + (print-header "Checking quasi-integer operations...") + + (check (bitvector= (bitvector-logical-shift (bitvector 1 0 1 1) 2 0) + (bitvector 1 1 0 0)) + => #t) + (check (bitvector= (bitvector-logical-shift (bitvector 1 0 1 1) -2 #t) + (bitvector 1 1 1 0)) + => #t) + + (check (bitvector-count 1 (make-bitvector 8 1)) => 8) + (check (bitvector-count #t (make-bitvector 8 0)) => 0) + (check (bitvector-count 1 (bitvector 1 1 0 1 1 0 0 0)) => 4) + + (check (bitvector-count-run 1 (make-bitvector 8 1) 0) => 8) + (check (bitvector-count-run #t (make-bitvector 8 0) 4) => 0) + (check (bitvector-count-run 1 (bitvector 0 1 1 1) 1) => 3) + + (let ((then-bvec (bitvector 1 0 1 0)) + (else-bvec (bitvector 0 0 0 1))) + (check + (bitvector= (bitvector-if (make-bitvector 4 1) then-bvec else-bvec) + then-bvec) + => #t) + (check + (bitvector= (bitvector-if (make-bitvector 4 0) then-bvec else-bvec) + else-bvec) + => #t)) + (check (bitvector= (bitvector-if (bitvector 1 1 0 0) + (bitvector 0 1 1 1) + (bitvector 0 0 1 0)) + (bitvector 0 1 1 0)) + => #t) + + (check (bitvector-first-bit 0 (make-bitvector 4 0)) => 0) + (check (bitvector-first-bit #t (bitvector 0 0 1 0)) => 2) + (check (bitvector-first-bit #f (make-bitvector 4 1)) => -1) +) diff --git a/test-suite/tests/srfi-178-test/quasi-string.scm b/test-suite/tests/srfi-178-test/quasi-string.scm new file mode 100644 index 000000000..2da77466a --- /dev/null +++ b/test-suite/tests/srfi-178-test/quasi-string.scm @@ -0,0 +1,62 @@ +;;; SPDX-License-Identifier: MIT +;;; SPDX-FileCopyrightText: 2020 Wolfgang Corcoran-Mathe + +(define (check-quasi-string-ops) + (print-header "Checking quasi-string operations...") + + ;;; prefix & suffix + + (check (bitvector-prefix-length (bitvector 1 0 0) (bitvector 1 0 1)) => 2) + (check (bitvector-prefix-length (bitvector) (bitvector 1 0 1)) => 0) + (let ((bvec (bitvector 1 0 1))) + (check (= (bitvector-prefix-length bvec bvec) (bitvector-length bvec)) + => #t) + (check (= (bitvector-suffix-length bvec bvec) (bitvector-length bvec)) + => #t)) + (check (bitvector-suffix-length (bitvector 1 0 0) (bitvector 0 0 0)) => 2) + (check (bitvector-suffix-length (bitvector) (bitvector 1 0 1)) => 0) + + (check (bitvector-prefix? (bitvector 1) (bitvector 1 0)) => #t) + (check (bitvector-prefix? (bitvector 0) (bitvector 1 0)) => #f) + (check (bitvector-suffix? (bitvector 0) (bitvector 1 0)) => #t) + (check (bitvector-suffix? (bitvector 1) (bitvector 1 0)) => #f) + (let ((bvec (bitvector 1 0 1 0))) + (check (bitvector-prefix? bvec bvec) => #t) + (check (bitvector-suffix? bvec bvec) => #t)) + + ;;; pad & trim + + (check (bitvector= + (bitvector-pad 0 (bitvector 1) 4) + (bitvector 0 0 0 1)) + => #t) + (let ((bvec (bitvector 1 0 1 0))) + (check (bitvector= (bitvector-pad 0 bvec (bitvector-length bvec)) + bvec) + => #t) + (check (bitvector= (bitvector-pad-right 0 bvec (bitvector-length bvec)) + bvec) + => #t)) + (check (bitvector= + (bitvector-pad-right 0 (bitvector 1) 4) + (bitvector 1 0 0 0)) + => #t) + (check (bitvector= (bitvector-trim 0 (bitvector 0 0 0 1)) + (bitvector 1)) + => #t) + (check (bitvector= (bitvector-trim 0 (bitvector 1 0 1)) + (bitvector 1 0 1)) + => #t) + (check (bitvector= (bitvector-trim-right 0 (bitvector 1 0 1)) + (bitvector 1 0 1)) + => #t) + (check (bitvector= (bitvector-trim-right 0 (bitvector 1 0 0 0)) + (bitvector 1)) + => #t) + (check (bitvector= (bitvector-trim-both 1 (bitvector 1 0 1)) + (bitvector 0)) + => #t) + (check (bitvector= (bitvector-trim-both 0 (bitvector 1 0 1)) + (bitvector 1 0 1)) + => #t) +) diff --git a/test-suite/tests/srfi-178-test/selectors.scm b/test-suite/tests/srfi-178-test/selectors.scm new file mode 100644 index 000000000..f37894702 --- /dev/null +++ b/test-suite/tests/srfi-178-test/selectors.scm @@ -0,0 +1,13 @@ +;;; SPDX-License-Identifier: MIT +;;; SPDX-FileCopyrightText: 2020 Wolfgang Corcoran-Mathe + +(define (check-selectors) + (print-header "Checking selectors...") + + (check (bitvector-length (bitvector)) => 0) + (check (bitvector-length (bitvector 1 0 1 0)) => 4) + (check (bitvector-ref/int (bitvector 1 0 1 0) 0) => 1) + (check (bitvector-ref/int (bitvector 1 0 1 0) 3) => 0) + (check (bitvector-ref/bool (bitvector 1 0 1 0) 0) => #t) + (check (bitvector-ref/bool (bitvector 1 0 1 0) 3) => #f)) + diff --git a/test-suite/tests/srfi-178.test b/test-suite/tests/srfi-178.test new file mode 100644 index 000000000..4ab6c6708 --- /dev/null +++ b/test-suite/tests/srfi-178.test @@ -0,0 +1,147 @@ +;;; 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. + +(import (scheme base)) +(import (scheme write)) +(import (srfi 178)) + +;;; START Guile-specific customizations to use Guile's own test runner. +(import (srfi 64)) + +(define report (@@ (test-suite lib) report)) + +(define-syntax check + (syntax-rules (=>) + ((check expr => expected) + (test-equal expected expr)))) + +(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)) +;;; END Guile-specific customizations to use Guile's own test runner. + +(cond-expand + ((library (srfi 158)) + (import (only (srfi 158) generator-for-each generator->list))) + (else + (begin + (define (generator-for-each proc g) + (let ((v (g))) + (unless (eof-object? v) + (proc v) + (generator-for-each proc g)))) + + (define (generator->list g) + (let ((v (g))) + (if (eof-object? v) + '() + (cons v (generator->list g)))))))) + +(define (print-header message) + (newline) + (display ";;; ") + (display message) + (newline)) + +;;;; Utility + +(define (proc-or a b) (or a b)) + +(define (constantly x) (lambda (_) x)) + +(define bitvector= bitvector=?) + +(define (check-bit-conversions) + (print-header "Checking bit conversions...") + + (check (bit->integer 0) => 0) + (check (bit->integer 1) => 1) + (check (bit->integer #f) => 0) + (check (bit->integer #t) => 1) + (check (bit->boolean 0) => #f) + (check (bit->boolean 1) => #t) + (check (bit->boolean #f) => #f) + (check (bit->boolean #t) => #t)) + +(define (check-predicates) + (print-header "Checking predicates...") + + (check (bitvector? (bitvector)) => #t) + (check (bitvector? (make-bitvector 1)) => #t) + + (check (bitvector-empty? (bitvector)) => #t) + (check (bitvector-empty? (bitvector 1)) => #f) + + (check (bitvector= (bitvector) (bitvector)) => #t) + (check (bitvector= (bitvector 1 0 0) (bitvector 1 0 0)) => #t) + (check (bitvector= (bitvector 1 0 0) (bitvector 1 0 1)) => #f) + (check (bitvector= (bitvector 1 0 0) (bitvector 1 0)) => #f) + (check (bitvector= (bitvector 1 0 0) + (bitvector 1 0 0) + (bitvector 1 0 0)) + => #t) + (check (bitvector= (bitvector 1 0 0) + (bitvector 1 0 1) + (bitvector 1 0 0)) + => #f)) + +(include "srfi-178-test/constructors.scm") +(include "srfi-178-test/iterators.scm") +(include "srfi-178-test/selectors.scm") +(include "srfi-178-test/conversions.scm") +(include "srfi-178-test/mutators.scm") +(include "srfi-178-test/quasi-string.scm") +(include "srfi-178-test/gen-accum.scm") +(include "srfi-178-test/logic-ops.scm") +(include "srfi-178-test/quasi-ints.scm") +(include "srfi-178-test/fields.scm") + +(define (check-all) + ;; Check predicates, bitvector conversions, and selectors first, + ;; since they're used extensively in later tests. + (check-predicates) + (check-bitvector-conversions) + (check-selectors) + (check-bit-conversions) + (check-constructors) + (check-iterators) + (check-quasi-string-ops) + (check-mutators) + (check-bitwise-operations) + (check-quasi-integer-operations) + (check-bit-field-operations)) + +(test-with-runner (guile-test-runner) + (test-begin "SRFI 178") + (check-all) + (test-end "SRFI 178")) -- 2.41.0