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 v6 13/16] module: Add SRFI 151. Date: Sat, 2 Dec 2023 20:37:14 -0500 Message-ID: <20231203014115.26985-14-maxim.cournoyer@gmail.com> References: <20231203014115.26985-1-maxim.cournoyer@gmail.com> Mime-Version: 1.0 Content-Type: text/plain; charset=utf-8 Content-Transfer-Encoding: 8bit Injection-Info: ciao.gmane.io; posting-host="blaine.gmane.org:116.202.254.214"; logging-data="31116"; 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 Sun Dec 03 02:42:58 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 1r9bVa-0007tP-2f for guile-devel@m.gmane-mx.org; Sun, 03 Dec 2023 02:42:58 +0100 Original-Received: from localhost ([::1] helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1r9bUe-0001a2-FA; Sat, 02 Dec 2023 20:42:01 -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 1r9bUV-0001R5-3M for guile-devel@gnu.org; Sat, 02 Dec 2023 20:41:51 -0500 Original-Received: from mail-qk1-x72b.google.com ([2607:f8b0:4864:20::72b]) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1r9bUQ-0001ZB-61 for guile-devel@gnu.org; Sat, 02 Dec 2023 20:41:50 -0500 Original-Received: by mail-qk1-x72b.google.com with SMTP id af79cd13be357-77eced97847so101872585a.2 for ; Sat, 02 Dec 2023 17:41:45 -0800 (PST) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gmail.com; s=20230601; t=1701567705; x=1702172505; 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=rY+IzvphLN74RSqYwjqmMV8q3Sfs6hyx3skj80HnVaY=; b=OUmoVrPhT+0z+jfbIW+plpD33lKeizun/M8TOmkUL4I5p4qcN86WDxdKyroUcT38sj mZrILQZlX0GjcIp9zx9ZQ3jhlDkLua+kK+wWJ4wjWS5bDYHQHI5ucNZtKnLXhHsCj5Rh Dl5SHPk4DMNBFPBM4eUTQNqktPRiTtotIttK3cGaJGw+GMYGzg29Kv1Y4wBj2ctk2/Ys Sp9ypWJK4RDCIoVkV90Zxop6ga7dDmJaWLVpGyEayPK+BLUxuJCgzkbaOrBmpkSxm+ba qOUqRfMD9ExISUQaW+cNzoTgSFxv0U5cOVsVaTi0vNRgQDZHskHr3VpqafX+8ZKL+NEd Mv3Q== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20230601; t=1701567705; x=1702172505; 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=rY+IzvphLN74RSqYwjqmMV8q3Sfs6hyx3skj80HnVaY=; b=BiluJHS1tZXJtFSOYo/aQeK6ECRBcmjhTfeYwZMt7v3VbgbC1CFhtSb9xtbqkYvtP2 NmNKvmdgqt/Au6YMn63Efqy+hwVJpiffIAKWbNlz2Ni9voM42Zb/LfXfm8FFazX4UKYZ ZM48C7kewyjM2bvknJsG372a5APu8TaTpY3V+vW5Gibhfs6gkkM17hniEw0qfICR1azb zS89zZ8YR0mhyJro+g4E48yf2VsTjRa35zhIcI/kHC3tqYnxGWN7LwTBpLbWJLbtG8QX Ied5PIwvHMRoVQqd+G+RyWEloopZDNK9Cz4tyeuDB40a8/AdBzsu8Fj9njOCnwYpPDGZ WgaA== X-Gm-Message-State: AOJu0Yyc1YMlPM9fZiheoZScko174BgycWAuGcXxL1NFAsxe2ng02lD0 +WZzYgrPvw00JppyvKNzZbsPKtBU0qA= X-Google-Smtp-Source: AGHT+IE8KhPmwVtVcuisQSQGuopMgI9QxPMGp3HKAjPdQN3hF9QGDs5qHX/D2XP/Dwc9ysvVbK376Q== X-Received: by 2002:a05:620a:271d:b0:77e:fba3:81bb with SMTP id b29-20020a05620a271d00b0077efba381bbmr2524565qkp.81.1701567703578; Sat, 02 Dec 2023 17:41:43 -0800 (PST) Original-Received: from localhost.localdomain (dsl-10-141-196.b2b2c.ca. [72.10.141.196]) by smtp.gmail.com with ESMTPSA id t15-20020a05620a450f00b0077dca8ed9a4sm2869664qkp.133.2023.12.02.17.41.42 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Sat, 02 Dec 2023 17:41:43 -0800 (PST) X-Mailer: git-send-email 2.41.0 In-Reply-To: <20231203014115.26985-1-maxim.cournoyer@gmail.com> Received-SPF: pass client-ip=2607:f8b0:4864:20::72b; envelope-from=maxim.cournoyer@gmail.com; helo=mail-qk1-x72b.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:22171 Archived-At: * module/srfi/srfi-151.scm * module/srfi/srfi-151/bitwise-33.scm * module/srfi/srfi-151/bitwise-60.scm * module/srfi/srfi-151/bitwise-other.scm * test-suite/tests/srfi-151.test * test-suite/tests/srfi-151-test.scm: New files. * am/bootstrap.am (SOURCES): Register srfi-151.scm. (NOCOMP_SOURCES): Register srfi-151/bitwise-33.scm, srfi-151/bitwise-60.scm and srfi-151/bitwise-other.scm. * test-suite/Makefile.am (SCM_TESTS): Register srfi-151.test. (EXTRA_DIST): Register srfi-151-test.scm. * doc/ref/srfi-modules.texi (SRFI 151): Document it. * NEWS: Update news. --- (no changes since v5) Changes in v5: - Update NEWS Changes in v4: - Mention Expat license of SRFI 151 in guile.tex copying section - Update copyright line for John Cowan in srfi-modules.texi - Rename srfi/srfi-151.scm to srfi/srfi-151.sld Changes in v3: - Add SRFI 151 NEWS | 1 + am/bootstrap.am | 4 + doc/ref/guile.texi | 6 +- doc/ref/srfi-modules.texi | 815 ++++++++++++++++++++++++- module/srfi/srfi-151.sld | 56 ++ module/srfi/srfi-151/bitwise-33.scm | 108 ++++ module/srfi/srfi-151/bitwise-60.scm | 70 +++ module/srfi/srfi-151/bitwise-other.scm | 62 ++ test-suite/Makefile.am | 2 + test-suite/tests/srfi-151-test.scm | 381 ++++++++++++ test-suite/tests/srfi-151.test | 46 ++ 11 files changed, 1547 insertions(+), 4 deletions(-) create mode 100644 module/srfi/srfi-151.sld create mode 100644 module/srfi/srfi-151/bitwise-33.scm create mode 100644 module/srfi/srfi-151/bitwise-60.scm create mode 100644 module/srfi/srfi-151/bitwise-other.scm create mode 100644 test-suite/tests/srfi-151-test.scm create mode 100644 test-suite/tests/srfi-151.test diff --git a/NEWS b/NEWS index b7099673d..a33e5bbb1 100644 --- a/NEWS +++ b/NEWS @@ -26,6 +26,7 @@ the compiler reports it as "possibly unused". ** Add (scheme comparator) ** Add (scheme sort) ** Add (srfi 125), a mutators library +** Add (srfi 151), a bitwise operations library * Bug fixes diff --git a/am/bootstrap.am b/am/bootstrap.am index 048379ca9..57c603a0a 100644 --- a/am/bootstrap.am +++ b/am/bootstrap.am @@ -354,6 +354,7 @@ SOURCES = \ srfi/srfi-125.sld \ srfi/srfi-126.scm \ srfi/srfi-128.sld \ + srfi/srfi-151.sld \ srfi/srfi-171.scm \ srfi/srfi-171/gnu.scm \ srfi/srfi-171/meta.scm \ @@ -448,6 +449,9 @@ NOCOMP_SOURCES = \ srfi/srfi-125/125.body.scm \ srfi/srfi-128/128.body1.scm \ srfi/srfi-128/128.body2.scm \ + srfi/srfi-151/bitwise-33.scm \ + srfi/srfi-151/bitwise-60.scm \ + srfi/srfi-151/bitwise-other.scm \ system/base/lalr.upstream.scm \ system/repl/describe.scm \ sxml/sxml-match.ss \ diff --git a/doc/ref/guile.texi b/doc/ref/guile.texi index e10916948..f94c10209 100644 --- a/doc/ref/guile.texi +++ b/doc/ref/guile.texi @@ -24,9 +24,9 @@ Invariant Sections, no Front-Cover Texts, and no Back-Cover Texts. A copy of the license is included in the section entitled ``GNU Free Documentation License.'' -Additionally, the documentation of the 125, 126, and 128 SRFI modules is -adapted from their specification text, which is made available under the -following Expat license: +Additionally, the documentation of the 125, 126, 128, and 151 SRFI +modules is adapted from their specification text, which is made +available under the following Expat license: Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi index 3c276dfb0..b6782f183 100644 --- a/doc/ref/srfi-modules.texi +++ b/doc/ref/srfi-modules.texi @@ -3,7 +3,7 @@ @c Copyright (C) 1996, 1997, 2000-2004, 2006, 2007-2014, 2017, 2018, 2019, 2020 @c Free Software Foundation, Inc. @c Copyright (C) 2015-2016 Taylan Ulrich Bayırlı/Kammer -@c Copyright (C) 2015 John Cowan +@c Copyright (C) 2015-2016 John Cowan @c See the file guile.texi for copying conditions. @node SRFI Support @@ -69,6 +69,7 @@ get the relevant SRFI documents from the SRFI home page * SRFI 125:: Mutators. * SRFI 126:: R6RS-based hash tables. * SRFI 128:: Comparators. +* SRFI 151:: Bitwise Operations. * SRFI-171:: Transducers. @end menu @@ -7416,6 +7417,818 @@ returns true, @var{greater-than} is evaluated and its value returned. If @var{comparator} is omitted, a default comparator is used. @end deffn +@node SRFI 151 +@subsection SRFI 151 Bitwise Operations +@cindex SRFI 151 + +@menu +* SRFI 151 Abstract:: +* SRFI 151 Rationale:: +* SRFI 151 Procedure index:: +* SRFI 151 Basic operations:: +* SRFI 151 Integer operations:: +* SRFI 151 Single-bit operations:: +* SRFI 151 Bit field operations:: +* SRFI 151 Bits conversion:: +* SRFI 151 Fold/unfold and generate:: +@end menu + +@node SRFI 151 Abstract +@subsubsection SRFI 151 Abstract + +This SRFI proposes a coherent and comprehensive set of procedures for +performing bitwise logical operations on integers; it is accompanied by +a reference implementation of the spec in terms of a set of seven core +operators. + +The precise semantics of these operators is almost never an issue. A +consistent, portable set of @emph{names} and @emph{parameter +conventions}, however, is. Hence this SRFI, which is based mainly on +@url{https://srfi.schemers.org/srfi-33/srfi-33.html, SRFI 33}, with some +changes and additions from +@url{http://srfi.schemers.org/srfi-33/mail-archive/msg00023.html, Olin's +late revisions to SRFI 33} (which were never consummated). +@url{https://srfi.schemers.org/srfi-60/srfi-60.html, SRFI 60} (based on +SLIB) is smaller but has a few procedures of its own; some of its +procedures have both native (often Common Lisp) and SRFI 33 names. They +have been incorporated into this SRFI. +@url{http://www.r6rs.org/final/html/r6rs-lib/r6rs-lib-Z-H-12.html#node_sec_11.4, +R6RS} is a subset of SRFI 60, except that all procedure names begin with +a @code{bitwise-} prefix. A few procedures have been added from the +general vector @url{https://srfi.schemers.org/srfi-133/srfi-133.html, +SRFI 133}. + +Among the applications of bitwise operations are: hashing, Galois-field +calculations of error-detecting and error-correcting codes, cryptography +and ciphers, pseudo-random number generation, register-transfer-level +modeling of digital logic designs, Fast-Fourier transforms, packing and +unpacking numbers in persistent data structures, space-filling curves +with applications to dimension reduction and sparse multi-dimensional +database indexes, and generating approximate seed values for +root-finders and transcendental function algorithms. + +@noindent +This SRFI differs from SRFI 142 in only two ways: + +@enumerate +@item +The @code{bitwise-if} function has the argument ordering of +SLIB, SRFI 60, and R6RS rather than the ordering of SRFI 33. + +@item +The order in which bits are processed by the procedures listed in the +``Bits conversion'' section has been clarified and some of the +procedures' names have been changed. See the ``Bit processing order'' +section for details. +@end enumerate + +@node SRFI 151 Rationale +@subsubsection SRFI 151 Rationale + +@subheading General design principles + +@itemize +@item +These operations interpret exact integers using two's-complement +representation. + +@item +The associative bitwise ops are required to be n-ary. Programmers can +reliably write @code{bitwise-and} with 3 arguments, for example. + +@item +The word @code{or} is never used by itself, only with modifiers: +@code{xor}, @code{ior}, @code{nor}, @code{orc1}, or @code{orc2}. This +is the same rule as Common Lisp. + +@item +Extra and redundant functions such as @code{bitwise-count}, +@code{bitwise-nor}and the bit-field ops have been included. Settling on +a standard choice of names makes it easier to read code that uses these +sorts of operations. It also means computations can be clearly +expressed using the more powerful ops rather than synthesized with a +snarled mess of @code{bitwise-and}s, @code{bitwise-or}s, and +@code{bitwise-not}s. What we gain is having an agreed-upon set of names +by which we can refer to these functions. If you believe in "small is +beautiful," then what is your motivation for including anything beyond +@code{bitwise-nand}? + +@item +Programmers don't have to re-implement the redundant functions, and +stumble over the boundary cases and error checking, but can express +themselves using a full palette of building blocks. + +@item +Compilers can directly implement many of these ops for great efficiency +gains without requiring any tricky analysis. + +@item +Logical right or left shift operations are excluded because they are not +well defined on general integers; they are only defined on integers in +some finite range. Remember that, in this library, integers are +interpreted as semi-infinite bit strings that have only a finite number +of ones or a finite number of zeros. Logical shifting operates on bit +strings of some fixed size. If we shift left, then leftmost bits "fall +off" the end (and zeros shift in on the right). If we shift right, then +zeros shift into the string on the left (and rightmost bits fall off the +end). So to define a logical shift operation, we must specify the size +of the window. +@end itemize + +@subheading Common Lisp + +The core of this design mirrors the structure of Common Lisp's pretty +closely. Here are some differences: + +@itemize +@item +"load" and "deposit" are the wrong verbs (e.g., Common Lisp's @code{ldb} +and @code{dpb} ops), since they have nothing to do with the store. + +@item +@code{boole} has been removed; it is not one with the Way of Scheme. +Boolean functions are directly encoded in Scheme as first-class +functions. + +@item +The name choices are more in tune with Scheme conventions (hyphenation, +using @code{?} to mark a predicate, etc.) Common Lisp's name choices +were more historically motivated, for reasons of backward compatibility +with Maclisp and Zetalisp. + +@item +The prefix @code{log} has been changed to @code{bitwise-} (e.g, +@code{lognot} to @code{bitwise-not}), as the prefix @code{bitwise-} more +accurately reflects what they do. + +@item +The six trivial binary boolean ops that return constants, the left or +right arguments, and the @code{bitwise-not} of the left or right +arguments, do not appear in this SRFI. + +@end itemize + +@subheading SRFI 33 + +This SRFI contains all the procedures of SRFI 33, and retains their +original names with these exceptions: + +@itemize +@item +The name @code{bitwise-merge} is replaced by @code{bitwise-if}, the name +used in SRFI 60 and R6RS. + +@item +The name @code{extract-bit-field} (@code{bit-field-extract} in Olin's +revisions) is replaced by @code{bit-field}, the name used in SRFI 60 and +R6RS. + +@item +The names @code{any-bits-set?} and @code{all-bits-set?} are replaced by +@code{any-bit-set?} and @code{every-bit-set?}, in accordance with Olin's +revisions. + +@item +The name @code{test-bit-field?} has been renamed @code{bit-field-any?} +and supplemented with @code{bit-field-every?}, in accordance with Olin's +revisions. + +@item +Because @code{copy-bit-field} means different things in SRFI 33 and SRFI +60, SRFI 33's name @code{copy-bit-field} (@code{bit-field-copy} in +Olin's revisions) has been changed to @code{bit-field-replace-same} +@end itemize + +@subheading SRFI 60 + +SRFI 60 includes six procedures that do not have SRFI 33 equivalents. +They are incorporated into this SRFI as follows: + +@itemize +@item +The names @code{rotate-bit-field} and @code{reverse-bit-field} are +replaced by @code{bit-field-rotate} and @code{bit-field-reverse}, by +analogy with Olin's revisions. + +@item +The procedure @code{copy-bit} is incorporated into this SRFI with the +same name. + +@item +The procedures @code{integer->list} and @code{list->integer}are +incorporated into this SRFI with the slightly different names +@code{integer->bits}and @code{bits->integer} because they are +incompatible with SRFI 60. + +@item +The procedure @code{booleans->integer} is a convenient way to specify a +bitwise integer: it accepts an arbitrary number of boolean arguments and +returns a non-negative integer. So in this SRFI it has the short name +@code{bits}, roughly analogous to @code{list}, @code{string}, and +@code{vector} +@end itemize + +@subheading Other sources + +@itemize +@item +The following procedures are inspired by +@url{https://srfi.schemers.org/srfi-133/srfi-133.html, SRFI 133}: +@code{bit-swap}, @code{bitwise-fold}, @code{bitwise-for-each}, +@code{bitwise-unfold}. + +@item +The procedure @code{bit-field-set} is the counterpart of +@code{bit-field-clear}. + +@item +The procedures @code{bits->vector} and @code{vector->bits} are inspired +by their list counterparts. + +@item +The @code{make-bitwise-generator} procedure is a generator constructor +similar to those provided by +@url{https://srfi.schemers.org/srfi/srfi-127.html, SRFI 127}. +@end itemize + +@subheading Argument ordering and semantics + +In general, these procedures place the bitstring arguments to be +operated on first. Where the operation is not commutative, the +"destination" argument that provides the background bits to be operated +on is placed before the "source" argument that provides the bits to be +transferred to it. + +@itemize +@item +In SRFI 33, @code{bitwise-nand} and @code{bitwise-nor} accepted an +arbitrary number of arguments even though they are not commutative. +Olin's late revisions made them dyadic, and so does this SRFI. + +@item +Common Lisp bit-field operations use a @emph{byte spec} to encapsulate +the position and size of the field. SRFI 33 bit-field operations had +leading @emph{position} and @emph{size}arguments instead. These have +been replaced in this SRFI by trailing @emph{start} (inclusive) and +@emph{end} (exclusive) arguments, the convention used not only in SRFI +60 and R6RS but also in most other subsequence operations in Scheme +standards and SRFIs. + +@item +In SRFI 60, the @code{bitwise-if} function was defined with a different +argument ordering from SRFI 33's @code{bitwise-merge}, but was provided +under both names, using the SLIB ordering. SRFI 142 adopted the SRFI 33 +ordering rather than the SLIB and R6RS ordering. Since SLIB and R6RS +have seen far more usage than SRFI 33, this SRFI adopts the SRFI 60 +ordering instead. +@end itemize + +@subheading Bit processing order + +In SLIB and SRFI 60, the the order in which bits were processed by +@code{integer->list} and @code{list->integer} was not clearly specified. +When SRFI 142 was written, the specification was clarified to process +bits from least significant to most significant, so that +@samp{(integer->list 6) => (#f #t #t)}. However, the SLIB and SRFI 60 +implementation processed them from the most significant bit to the +least-significant bit, so that @samp{(integer->list 6) => (#t #t #f)}. +This SRFI retains the little-endian order, but renames the procedures to +@code{bits->list} and @code{list->bits} to avoid a silent breaking +change from SLIB and SRFI 60. The same is true of the closely analogous +@code{integer->vector}, @code{vector->integer}, and @code{bits} +procedures. + +@node SRFI 151 Procedure index +@subsubsection SRFI 151 Procedure index + +@lisp +bitwise-not +bitwise-and bitwise-ior +bitwise-xor bitwise-eqv +bitwise-nand bitwise-nor +bitwise-andc1 bitwise-andc2 +bitwise-orc1 bitwise-orc2 +arithmetic-shift bit-count +integer-length bitwise-if +bit-set? copy-bit bit-swap +any-bit-set? every-bit-set? +first-set-bit +bit-field bit-field-any? bit-field-every? +bit-field-clear bit-field-set +bit-field-replace bit-field-replace-same +bit-field-rotate bit-field-reverse +bits->list list->bits bits->vector vector->bits +bits +bitwise-fold bitwise-for-each bitwise-unfold +make-bitwise-generator +@end lisp + +In the following procedure specifications all parameters and return +values are exact integers unless otherwise indicated (except that +procedures with names ending in @samp{?} are predicates, as usual). It +is an error to pass values of other types as arguments to these +functions. + +Bitstrings are represented by exact integers, using a two's-complement +encoding of the bitstring. Thus every integer represents a +semi-infinite bitstring, having either a finite number of zeros +(negative integers) or a finite number of ones (non-negative integers). +The bits of a bitstring are numbered from the +rightmost/least-significant bit: bit #0 is the rightmost or 2@sup{0} +bit, bit #1 is the next or 2@sup{1} bit, and so forth. + +@node SRFI 151 Basic operations +@subsubsection SRFI 151 Basic operations + +@deffn {Scheme Procedure} bitwise-not i + +Returns the bitwise complement of @emph{i}; that is, all 1 bits are changed +to 0 bits and all 0 bits to 1 bits. + +@lisp + (bitwise-not 10) => -11 + (bitwise-not -37) => 36 +@end lisp + +@end deffn + +The following ten procedures correspond to the useful set of non-trivial +two-argument boolean functions. For each such function, the +corresponding bitwise operator maps that function across a pair of +bitstrings in a bit-wise fashion. The core idea of this group of +functions is this bitwise ``lifting'' of the set of dyadic boolean +functions to bitstring parameters. + +@deffn {Scheme Procedure} bitwise-and i @dots{} +@deffnx {Scheme Procedure} bitwise-ior i @dots{} +@deffnx {Scheme Procedure} bitwise-xor i @dots{} +@deffnx {Scheme Procedure} bitwise-eqv i @dots{} + +These operations are associative. When passed no arguments, the procedures +return the identity values -1, 0, 0, and -1 respectively. + +The @code{bitwise-eqv} procedure produces the complement of the +@code{bitwise-xor} procedure. When applied to three arguments, it does +@emph{not} produce a 1 bit everywhere that @var{a}, @var{b} and @var{c} +all agree. That is, it does @emph{not} produce: + +@lisp + (bitwise-ior (bitwise-and a b c) + (bitwise-and (bitwise-not a) + (bitwise-not b) + (bitwise-not c))) +@end lisp + +Rather, it produces @samp{(bitwise-eqv @var{a} (bitwise-eqv @var{b} +@var{c}))} or the equivalent @samp{(bitwise-eqv (bitwise-eqv @var{a} +@var{b}) @var{c})}: + +@lisp + (bitwise-ior 3 10) => 11 + (bitwise-and 11 26) => 10 + (bitwise-xor 3 10) => 9 + (bitwise-eqv 37 12) => -42 + (bitwise-and 37 12) => 4 +@end lisp +@end deffn + +@deffn {Scheme Procedure} bitwise-nand i j +@deffnx {Scheme Procedure} bitwise-nor i j +@deffnx {Scheme Procedure} bitwise-andc1 i j +@deffnx {Scheme Procedure} bitwise-andc2 i j +@deffnx {Scheme Procedure} bitwise-orc1 i j +@deffnx {Scheme Procedure} bitwise-orc2 i j + +These operations are not associative. + +@lisp + (bitwise-nand 11 26) => -11 + (bitwise-nor 11 26) => -28 + (bitwise-andc1 11 26) => 16 + (bitwise-andc2 11 26) => 1 + (bitwise-orc1 11 26) => -2 + (bitwise-orc2 11 26) => -17 +@end lisp +@end deffn + +@node SRFI 151 Integer operations +@subsubsection SRFI 151 Integer operations + +@deffn {Scheme Procedure} arithmetic-shift i count + +Return the arithmetic left shift when @var{count}>0; right shift when +@var{count}<0. + +@lisp + (arithmetic-shift 8 2) => 32 + (arithmetic-shift 4 0) => 4 + (arithmetic-shift 8 -1) => 4 + (arithmetic-shift -100000000000000000000000000000000 -100) => -79 +@end lisp +@end deffn + +@deffn {Scheme Procedure} bit-count i + +Return the population count of 1's (@emph{i} >= 0) or 0's (@emph{i} < +0). The result is always non-negative. + +@quotation note +The R6RS analogue @code{bitwise-bit-count} applies @code{bitwise-not} to +the population count before returning it if @emph{i} is negative. +@end quotation + +@lisp + (bit-count 0) => 0 + (bit-count -1) => 0 + (bit-count 7) => 3 + (bit-count 13) => 3 ;Two's-complement binary: ...0001101 + (bit-count -13) => 2 ;Two's-complement binary: ...1110011 + (bit-count 30) => 4 ;Two's-complement binary: ...0011110 + (bit-count -30) => 4 ;Two's-complement binary: ...1100010 + (bit-count (expt 2 100)) => 1 + (bit-count (- (expt 2 100))) => 100 + (bit-count (- (1+ (expt 2 100)))) => 1 +@end lisp +@end deffn + +@deffn {Scheme Procedure} integer-length i + +The number of bits needed to represent @var{i}, i.e. + +@lisp + (ceiling (/ (log (if (negative? integer) + (- integer) + (+ 1 integer))) + (log 2))) +@end lisp + +The result is always non-negative. + +For non-negative @var{i}, this is the number of bits needed to represent +@var{i} in an unsigned binary representation. For all @var{i}, @samp{(+ +1 (integer-length @var{i}))} is the number of bits needed to represent +@var{i} in a signed twos-complement representation. + +@lisp + (integer-length 0) => 0 + (integer-length 1) => 1 + (integer-length -1) => 0 + (integer-length 7) => 3 + (integer-length -7) => 3 + (integer-length 8) => 4 + (integer-length -8) => 3 +@end lisp +@end deffn + +@deffn {Scheme Procedure} bitwise-if mask i j + +Merge the bitstrings @var{i} and @var{j}, with bitstring @var{mask} +determining from which string to take each bit. That is, if the +@var{k}th bit of @var{mask} is 1, then the @var{k}th bit of the result +is the @var{k}th bit of @var{i}, otherwise the @var{k}th bit of @var{j}. + +@lisp + (bitwise-if 3 1 8) => 9 + (bitwise-if 3 8 1) => 0 + (bitwise-if 1 1 2) => 3 + (bitwise-if #b00111100 #b11110000 #b00001111) => #b00110011 +@end lisp +@end deffn + +@node SRFI 151 Single-bit operations +@subsubsection SRFI 151 Single-bit operations + +As always, the rightmost/least-significant bit in @var{i} is bit 0. + +@deffn {Scheme Procedure} bit-set? index i + +Is bit @var{index} set in bitstring @var{i} (where @var{index} is a +non-negative exact integer)? + +@quotation note +The R6RS analogue @code{bitwise-bit-set?} accepts its arguments in the +opposite order. +@end quotation + +@lisp + (bit-set? 1 1) => false + (bit-set? 0 1) => true + (bit-set? 3 10) => true + (bit-set? 1000000 -1) => true + (bit-set? 2 6) => true + (bit-set? 0 6) => false +@end lisp +@end deffn + +@deffn {Scheme Procedure} copy-bit index i boolean + +Return an integer the same as @var{i} except in the @var{index}th bit, +which is 1 if @var{boolean} is @code{#t} and 0 if @var{boolean} is +@code{#f}. + +@quotation note +The R6RS analogue @code{bitwise-copy-bit} as originally documented has a +completely different interface. @samp{(bitwise-copy-bit @var{dest} +@var{ndex} @var{source})} replaces the @var{index}'th bit of @var{dest} +with the @var{index}'th bit of @var{source}. It is equivalent to +@samp{(bit-field-replace-same @var{dest} @var{source} @var{index} (+ +@var{index} 1))}. +@end quotation + +@lisp +(copy-bit 0 0 #t) => #b1 +(copy-bit 2 0 #t) => #b100 +(copy-bit 2 #b1111 #f) => #b1011 +@end lisp +@end deffn + +@deffn {Scheme Procedure} bit-swap index@sub{1} index@sub{2} i + +Return an integer the same as @var{i} except that the +@var{index@sub{1}}th bit and the @var{index@sub{2}}th bit have been +exchanged. + +@lisp +(bit-swap 0 2 4) => #b1 +@end lisp +@end deffn + +@deffn {Scheme Procedure} any-bit-set? test-bits i +@deffnx {Scheme Procedure} every-bit-set? test-bits i + +Determine if any/all of the bits set in bitstring @var{test-bits} are +set in bitstring @var{i}. I.e., return @samp{(not (zero? (bitwise-and +@var{test-bits} @var{i})))} and @samp{(= @var{test-bits} (bitwise-and +@var{test-bits} @var{i}))} respectively. + +@lisp + (any-bit-set? 3 6) => #t + (any-bit-set? 3 12) => #f + (every-bit-set? 4 6) => #t + (every-bit-set? 7 6) => #f +@end lisp +@end deffn + +@deffn {Scheme Procedure} first-set-bit i + +Return the index of the first (smallest index) 1 bit in bitstring +@var{i}. Return -1 if @var{i} contains no 1 bits (i.e., if @var{i} is +zero). + +@lisp + (first-set-bit 1) => 0 + (first-set-bit 2) => 1 + (first-set-bit 0) => -1 + (first-set-bit 40) => 3 + (first-set-bit -28) => 2 + (first-set-bit (expt 2 99)) => 99 + (first-set-bit (expt -2 99)) => 99 +@end lisp +@end deffn + +@node SRFI 151 Bit field operations +@subsubsection SRFI 151 Bit field operations + +These functions operate on a contiguous field of bits (a "byte", in +Common Lisp parlance) in a given bitstring. The @var{start} and +@var{end} arguments, which are not optional, are non-negative exact +integers specifying the field: it is the @var{end-start} bits running +from bit @var{start} to bit @var{end}-1. + +@deffn {Scheme Procedure} bit-field i start end + +Return the field from @var{i}, shifted down to the least-significant +position in the result. + +@lisp + (bit-field #b1101101010 0 4) => #b1010 + (bit-field #b1101101010 3 9) => #b101101 + (bit-field #b1101101010 4 9) => #b10110 + (bit-field #b1101101010 4 10) => #b110110 + (bit-field 6 0 1) => 0 + (bit-field 6 1 3) => 3 + (bit-field 6 2 999) => 1 + (bit-field #x100000000000000000000000000000000 128 129) => 1 +@end lisp +@end deffn + +@deffn {Scheme Procedure} bit-field-any? i start end + +Return true if any of the field's bits are set in bitstring @var{i}, +and false otherwise. + +@lisp + (bit-field-any? #b1001001 1 6) => #t + (bit-field-any? #b1000001 1 6) => #f +@end lisp +@end deffn + +@deffn {Scheme Procedure} bit-field-every? i start end + +Return false if any of the field's bits are not set in bitstring +@var{i}, and true otherwise. + +@lisp + (bit-field-every? #b1011110 1 5) => #t + (bit-field-every? #b1011010 1 5) => #f +@end lisp +@end deffn + +@deffn {Scheme Procedure} bit-field-clear i start end +@deffnx {Scheme Procedure} bit-field-set i start end + +Return @var{i} with the field's bits set to all 0s/1s. + +@lisp + (bit-field-clear #b101010 1 4) => #b100000 + (bit-field-set #b101010 1 4) => #b101110 +@end lisp +@end deffn + +@deffn {Scheme Procedure} bit-field-replace dest source start end + +Return @var{dest} with the field replaced by the least-significant +@var{end-start} bits in @var{source}. + +@lisp + (bit-field-replace #b101010 #b010 1 4) => #b100100 + (bit-field-replace #b110 1 0 1) => #b111 + (bit-field-replace #b110 1 1 2) => #b110 +@end lisp +@end deffn + +@deffn {Scheme Procedure} bit-field-replace-same dest source start end + +Return @var{dest} with its field replaced by the corresponding field in +@var{source}. + +@lisp + (bit-field-replace-same #b1111 #b0000 1 3) => #b1001 +@end lisp +@end deffn + +@deffn {Scheme Procedure} bit-field-rotate i count start end + +Return @var{i} with the field cyclically permuted by @var{count} bits +towards high-order. + +@quotation note +The R6RS analogue @code{bitwise-rotate-bit-field} uses the argument +ordering @var{i} @var{start} @var{end} @var{count}. +@end quotation + +@lisp + (bit-field-rotate #b110 0 0 10) => #b110 + (bit-field-rotate #b110 0 0 256) => #b110 + (bit-field-rotate #x100000000000000000000000000000000 1 0 129) => 1 + (bit-field-rotate #b110 1 1 2) => #b110 + (bit-field-rotate #b110 1 2 4) => #b1010 + (bit-field-rotate #b0111 -1 1 4) => #b1011 +@end lisp +@end deffn + +@deffn {Scheme Procedure} bit-field-reverse i start end + +Return @var{i} with the order of the bits in the field reversed. + +@lisp + (bit-field-reverse 6 1 3) => 6 + (bit-field-reverse 6 1 4) => 12 + (bit-field-reverse 1 0 32) => #x80000000 + (bit-field-reverse 1 0 31) => #x40000000 + (bit-field-reverse 1 0 30) => #x20000000 + (bit-field-reverse #x140000000000000000000000000000000 0 129) => 5 +@end lisp +@end deffn + +@node SRFI 151 Bits conversion +@subsubsection SRFI 151 Bits conversion + +@deffn {Scheme Procedure} bits->list i [len] +@deffnx {Scheme Procedure} bits->vector i [len] + +Return a list/vector of @var{len} booleans corresponding to each bit of +the non-negative integer @var{i}, returning bit #0 as the first element, +bit #1 as the second, and so on. @code{#t} is returned for each 1; +@code{#f} for 0. + +@lisp + (bits->list #b1110101) => (#t #f #t #f #t #t #t) + (bits->list 3 5) => (#t #t #f #f #f) + (bits->list 6 4) => (#f #t #t #f) + (bits->vector #b1110101) => #(#t #f #t #f #t #t #t) +@end lisp +@end deffn + +@deffn {Scheme Procedure} list->bits list +@deffnx {Scheme Procedure} vector->bits vector + +Return an integer formed from the booleans in @var{list}/@var{vector}, +using the first element as bit #0, the second element as bit #1, and so +on. It is an error if @var{list}/@var{vector} contains non-booleans. A +1 bit is coded for each @code{#t}; a 0 bit for @code{#f}. Note that the +result is never a negative integer. + +@lisp + (list->bits '(#t #f #t #f #t #t #t)) => #b1110101 + (list->bits '(#f #f #t #f #t #f #t #t #t)) => #b111010100 + (list->bits '(#f #t #t)) => 6 + (list->bits '(#f #t #t #f)) => 6 + (list->bits '(#f #f #t #t)) => 12 + (vector->bits '#(#t #f #t #f #t #t #t)) => #b1110101 + (vector->bits '#(#f #f #t #f #t #f #t #t #t)) => #b111010100 + (vector->bits '#(#f #t #t)) => 6 + (vector->bits '#(#f #t #t #f)) => 6 + (vector->bits '#(#f #f #t #t)) => 12 +@end lisp + +For positive integers, +@code{bits->list} and @code{list->bits} are inverses in the sense of @code{equal?}, +and so are @code{bits->vector} and @code{vector->bits} +@end deffn + +@deffn {Scheme Procedure} bits bool @dots{} + +Return the integer coded by the @code{bool} arguments. The first +argument is bit #0, the second argument is bit #1, and so on. Note that +the result is never a negative integer. + +@lisp + (bits #t #f #t #f #t #t #t) => #b1110101 + (bits #f #f #t #f #t #f #t #t #t) => #b111010100 +@end lisp +@end deffn + +@node SRFI 151 Fold/unfold and generate +@subsubsection SRFI 151 Fold, unfold, and generate + +It is an error if the arguments named @var{proc}, @var{top}?, +@var{apper} or @var{successor} are not procedures. The arguments named +@var{seed} may be any Scheme object. + +@deffn {Scheme Procedure} bitwise-fold proc seed i + +For each bit @var{b} of @var{i} from bit #0 (inclusive) to bit +@samp{(integer-length @var{i})}(exclusive), @var{proc} is called as +@samp{(@var{proc} @var{b} @var{r})}, where @var{r} is the current +accumulated result. The initial value of @var{r} is @var{seed}, and +the value returned by @var{proc} becomes the next accumulated result. +When the last bit has been processed, the final accumulated result +becomes the result of @code{bitwise-fold}. + +@lisp + (bitwise-fold cons '() #b1010111) => (#t #f #t #f #t #t #t) +@end lisp +@end deffn + +@deffn {Scheme Procedure} bitwise-for-each proc i + +Repeatedly apply @var{proc} to the bits of @var{i} starting with bit +#0 (inclusive) and ending with bit @samp{(integer-length @var{i})} +(exclusive). The values returned by @var{proc} are discarded. Return +an unspecified value. + +@lisp + (let ((count 0)) + (bitwise-for-each (lambda (b) (if b (set! count (+ count 1)))) + #b1010111) + count) +@end lisp +@end deffn + +@deffn {Scheme Procedure} bitwise-unfold stop? mapper successor seed + +Generate a non-negative integer bit by bit, starting with bit 0. If the +result of applying @var{stop?} to the current state (whose initial value +is @var{seed}) is true, return the currently accumulated bits as an +integer. Otherwise, apply @var{mapper} to the current state to obtain +the next bit of the result by interpreting a true value as a 1 bit and a +false value as a 0 bit. Then get a new state by applying +@var{successor} to the current state, and repeat this algorithm. + +@lisp + (bitwise-unfold (lambda (i) (= i 10)) + even? + (lambda (i) (+ i 1)) + 0) => #b101010101 +@end lisp +@end deffn + +@deffn {Scheme Procedure} make-bitwise-generator i + +Return a @url{https://srfi.schemers.org/srfi-121/srfi-121.html, SRFI +121} generator that generates all the bits of @var{i} starting with bit +#0. Note that the generator is infinite. + +@lisp + (let ((g (make-bitwise-generator #b110))) + (test #f (g)) + (test #t (g)) + (test #t (g)) + (test #f (g))) +@end lisp +@end deffn + @node SRFI-171 @subsection Transducers @cindex SRFI-171 diff --git a/module/srfi/srfi-151.sld b/module/srfi/srfi-151.sld new file mode 100644 index 000000000..beb004b87 --- /dev/null +++ b/module/srfi/srfi-151.sld @@ -0,0 +1,56 @@ +;; Copyright (C) John Cowan (2016). All Rights Reserved. + +;; Permission is hereby granted, free of charge, to any person obtaining +;; a copy of this software and associated documentation files (the +;; "Software"), to deal in the Software without restriction, including +;; without limitation the rights to use, copy, modify, merge, publish, +;; distribute, sublicense, and/or sell copies of the Software, and to +;; permit persons to whom the Software is furnished to do so, subject to +;; the following conditions: + +;; The above copyright notice and this permission notice shall be +;; included in all copies or substantial portions of the Software. + +;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +;; SOFTWARE. + +(define-library (srfi srfi-151) + (import (scheme base)) + (import (scheme case-lambda)) + + (export bitwise-not bitwise-and bitwise-ior bitwise-xor bitwise-eqv + bitwise-nand bitwise-nor bitwise-andc1 bitwise-andc2 + bitwise-orc1 bitwise-orc2) + (export arithmetic-shift bit-count integer-length bitwise-if + bit-set? copy-bit bit-swap any-bit-set? every-bit-set? first-set-bit) + (export bit-field bit-field-any? bit-field-every? bit-field-clear bit-field-set + bit-field-replace bit-field-replace-same + bit-field-rotate bit-field-reverse) + (export bits->list list->bits bits->vector vector->bits bits + bitwise-fold bitwise-for-each bitwise-unfold make-bitwise-generator) + + ;; Provide core functions + (import (only (rnrs arithmetic bitwise) + bitwise-not bitwise-and bitwise-ior bitwise-xor + bitwise-bit-count)) + (import (rename (only (rnrs arithmetic bitwise) + bitwise-arithmetic-shift bitwise-length) + (bitwise-arithmetic-shift arithmetic-shift) + (bitwise-length integer-length))) + + (begin + (define (bit-count i) ; Negative case different to R6RS bitwise-bit-count + (if (>= i 0) + (bitwise-bit-count i) + (bitwise-bit-count (bitwise-not i))))) + + ;; Stable part of the implementation + (include "srfi-151/bitwise-33.scm") + (include "srfi-151/bitwise-60.scm") + (include "srfi-151/bitwise-other.scm")) diff --git a/module/srfi/srfi-151/bitwise-33.scm b/module/srfi/srfi-151/bitwise-33.scm new file mode 100644 index 000000000..92f8056d0 --- /dev/null +++ b/module/srfi/srfi-151/bitwise-33.scm @@ -0,0 +1,108 @@ +;;;; bitwise-33 - Olin Shivers's code from SRFI-33 with modified names + +;;; Olin Shivers is the sole author of this code, and he has placed it in +;;; the public domain. +;;; +;;; A good implementation might choose to provide direct compiler/interpreter +;;; support for these derived functions, or might simply define them to be +;;; integrable -- i.e., inline-expanded. +;;; +;;; The seven non-trivial boolean functions in terms +;;; of not, and, or & xor. + +(define (bitwise-nand i j) (bitwise-not (bitwise-and i j))) +(define (bitwise-nor i j) (bitwise-not (bitwise-ior i j))) +(define (bitwise-andc1 i j) (bitwise-and (bitwise-not i) j)) +(define (bitwise-andc2 i j) (bitwise-and i (bitwise-not j))) +(define (bitwise-orc1 i j) (bitwise-ior (bitwise-not i) j)) +(define (bitwise-orc2 i j) (bitwise-ior i (bitwise-not j))) + +;;; This is a general definition, but less than efficient. It should also +;;; receive primitive compiler/interpreter support so that the expensive +;;; n-ary mechanism is not invoked in the standard cases -- that is, +;;; an application of BITWISE-EQV should be rewritten into an equivalent +;;; tree applying some two-argument primitive to the arguments, in the +;;; same manner that statically-known n-ary applications of associative +;;; operations such as + and * are handled efficiently: +;;; (bitwise-eqv) => -1 +;;; (bitwise-eqv i) => i +;;; (bitwise-eqv i j) => (%bitwise-eqv i j) +;;; (bitwise-eqv i j k) => (%bitwise-eqv (%bitwise-eqv i j) k) +;;; (bitwise-eqv i j k l) => (%bitwise-eqv (%bitwise-eqv (%bitwise-eqv i j) k) l) + +(define (bitwise-eqv . args) + (let lp ((args args) (ans -1)) + (if (pair? args) + (lp (cdr args) (bitwise-not (bitwise-xor ans (car args)))) + ans))) + +;;; Helper function -- make a mask of SIZE 1-bits, e.g. (%MASK 3) = #b111. +;;; Suppose your Scheme's fixnums are N bits wide (counting the sign bit, +;;; not counting any tag bits). This version, due to Marc Feeley, will +;;; handle SIZE in the range [0,N-1] without overflowing to bignums. +;;; (For SIZE >= N, the correct bignum value is also produced.) + +(define (mask start end) (bitwise-not (arithmetic-shift -1 (- end start)))) + +;;; This alternate, mathematically-equivalent expression +;;; (- (arithmetic-shift 1 size) 1) +;;; is not as good -- it only handles SIZE in the range [0,N-2] without +;;; overflowing to bignums. +;;; +;;; Finally, note that even Feeley's expression can't build an N-bit mask +;;; without bignum help. This is fundamental, since the interpretation +;;; of fixed-size fixnum bit patterns as semi-infinite-bit-strings is that +;;; you replicate the high bit out to infinity. So you have to have a +;;; zero "stop bit" appearing after that highest one bit to turn off the +;;; replication of the ones. + +(define (bit-set? index n) + (not (zero? (bitwise-and (arithmetic-shift 1 index) n)))) + +(define (any-bit-set? test-bits n) (not (zero? (bitwise-and test-bits n)))) + +(define (every-bit-set? test-bits n) (= test-bits (bitwise-and test-bits n))) + +;;; Bit-field ops + +(define (bit-field n start end) + (bitwise-and (mask start end) (arithmetic-shift n (- start)))) + +(define (bit-field-any? n start end) + (not (zero? (bitwise-and (arithmetic-shift n (- start)) (mask start end))))) + +;; Part of Olin's late revisions; code by John Cowan; public domain. +(define (bit-field-every? n start end) + (let ((m (mask start end))) + (eqv? m (bitwise-and (arithmetic-shift n (- start)) m)))) + +;; Integrating i-b-f reduces nicely. +(define (bit-field-clear n start end) + (bit-field-replace n 0 start end)) + +;; Counterpart to above, not in SRFI 33, written by John Cowan, public domain +(define (bit-field-set n start end) + (bit-field-replace n -1 start end)) + +;;; Oops -- intermediate ARITHMETIC-SHIFT can fixnum-overflow on fixnum args. +;(define (bit-field-replace newfield n start end) +; (bit-field-replace-same (arithmetic-shift newfield start) n start end)) + +;;; This three-line version won't fixnum-overflow on fixnum args. +(define (bit-field-replace n newfield start end) + (let ((m (mask start end))) + (bitwise-ior (bitwise-and n (bitwise-not (arithmetic-shift m start))) + (arithmetic-shift (bitwise-and newfield m) start)))) + +(define (bit-field-replace-same to from start end) + (bitwise-if (arithmetic-shift (mask start end) start) from to)) + +;; Simple definition +;(define (first-set-bit i) +; (and (not (zero? i)) +; (let lp ((j 0) (i start)) +; (if (bit-set? i 0) j +; (lp (+ j 1) (arithmetic-shift i 1)))))) + +;;; Clever definition, assuming you have a fast BIT-COUNT. +(define (first-set-bit i) (- (bit-count (bitwise-xor i (- i 1))) 1)) diff --git a/module/srfi/srfi-151/bitwise-60.scm b/module/srfi/srfi-151/bitwise-60.scm new file mode 100644 index 000000000..3f91cd632 --- /dev/null +++ b/module/srfi/srfi-151/bitwise-60.scm @@ -0,0 +1,70 @@ +;;;; bitwise-60 - SRFI-60 procedures without SRFI-33 analogues, renamed +;;; Copyright (C) 1991, 1993, 2001, 2003, 2005 Aubrey Jaffer +; +;Permission to copy this software, to modify it, to redistribute it, +;to distribute modified versions, and to use it for any purpose is +;granted, subject to the following restrictions and understandings. +; +;1. Any copy made of this software must include this copyright notice +;in full. +; +;2. I have made no warranty or representation that the operation of +;this software will be error-free, and I am under no obligation to +;provide any services, by way of maintenance, update, or otherwise. +; +;3. In conjunction with products arising from the use of this +;material, there shall be no use of my name in any advertising, +;promotional, or sales literature without prior written consent in +;each case. + +(define (bit-field-rotate n count start end) + (define width (- end start)) + (set! count (modulo count width)) + (let ((mask (bitwise-not (arithmetic-shift -1 width)))) + (define zn (bitwise-and mask (arithmetic-shift n (- start)))) + (bitwise-ior (arithmetic-shift + (bitwise-ior (bitwise-and mask (arithmetic-shift zn count)) + (arithmetic-shift zn (- count width))) + start) + (bitwise-and (bitwise-not (arithmetic-shift mask start)) n)))) + +(define (bit-reverse k n) + (do ((m (if (negative? n) (bitwise-not n) n) (arithmetic-shift m -1)) + (k (+ -1 k) (+ -1 k)) + (rvs 0 (bitwise-ior (arithmetic-shift rvs 1) (bitwise-and 1 m)))) + ((negative? k) (if (negative? n) (bitwise-not rvs) rvs)))) + + +(define (bit-field-reverse n start end) + (define width (- end start)) + (let ((mask (bitwise-not (arithmetic-shift -1 width)))) + (define zn (bitwise-and mask (arithmetic-shift n (- start)))) + (bitwise-ior (arithmetic-shift (bit-reverse width zn) start) + (bitwise-and (bitwise-not (arithmetic-shift mask start)) n)))) + +(define (copy-bit index to bool) + (if bool + (bitwise-ior to (arithmetic-shift 1 index)) + (bitwise-and to (bitwise-not (arithmetic-shift 1 index))))) + +(define (bits->list k . len) + (if (null? len) + (do ((k k (arithmetic-shift k -1)) + (lst '() (cons (odd? k) lst))) + ((<= k 0) (reverse lst))) + (do ((idx (+ -1 (car len)) (+ -1 idx)) + (k k (arithmetic-shift k -1)) + (lst '() (cons (odd? k) lst))) + ((negative? idx) (reverse lst))))) + +(define (list->bits bools) + (do ((bs (reverse bools) (cdr bs)) + (acc 0 (+ acc acc (if (car bs) 1 0)))) + ((null? bs) acc))) + +(define (bits . bools) + (list->bits bools)) + +(define (bitwise-if mask n0 n1) + (bitwise-ior (bitwise-and mask n0) + (bitwise-and (bitwise-not mask) n1))) diff --git a/module/srfi/srfi-151/bitwise-other.scm b/module/srfi/srfi-151/bitwise-other.scm new file mode 100644 index 000000000..7f7b9b96e --- /dev/null +++ b/module/srfi/srfi-151/bitwise-other.scm @@ -0,0 +1,62 @@ +;;;; bitwise-other - functions not from SRFI 33 or SRFI 60 +;;; Copyright John Cowan 2017 + +;; Permission is hereby granted, free of charge, to any person obtaining +;; a copy of this software and associated documentation files (the +;; "Software"), to deal in the Software without restriction, including +;; without limitation the rights to use, copy, modify, merge, publish, +;; distribute, sublicense, and/or sell copies of the Software, and to +;; permit persons to whom the Software is furnished to do so, subject to +;; the following conditions: + +;; The above copyright notice and this permission notice shall be +;; included in all copies or substantial portions of the Software. + +;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +;; SOFTWARE. + +(define bits->vector + (case-lambda + ((i) (list->vector (bits->list i))) + ((i len) (list->vector (bits->list i len))))) + +(define (vector->bits vector) (list->bits (vector->list vector))) + +(define (bit-swap n1 n2 i) + (let ((n1-bit (bit-set? n1 i)) + (n2-bit (bit-set? n2 i))) + (copy-bit n2 (copy-bit n1 i n2-bit) n1-bit))) + +(define (bitwise-fold proc seed i) + (let ((len (integer-length i))) + (let loop ((n 0) (r seed)) + (if (= n len) + r + (loop (+ n 1) (proc (bit-set? n i) r)))))) + +(define (bitwise-for-each proc i) + (let ((len (integer-length i))) + (let loop ((n 0)) + (when (< n len) + (proc (bit-set? n i)) + (loop (+ n 1)))))) + +(define (bitwise-unfold stop? mapper successor seed) + (let loop ((n 0) (result 0) (state seed)) + (if (stop? state) + result + (loop (+ n 1) + (copy-bit n result (mapper state)) + (successor state))))) + +(define (make-bitwise-generator i) + (lambda () + (let ((bit (bit-set? 0 i))) + (set! i (arithmetic-shift i -1)) + bit))) diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am index 13eb1f24f..f51db8830 100644 --- a/test-suite/Makefile.am +++ b/test-suite/Makefile.am @@ -165,6 +165,7 @@ SCM_TESTS = tests/00-initial-env.test \ tests/srfi-125.test \ tests/srfi-126.test \ tests/srfi-128.test \ + tests/srfi-151.test \ tests/srfi-171.test \ tests/srfi-4.test \ tests/srfi-9.test \ @@ -214,6 +215,7 @@ EXTRA_DIST = \ tests/srfi-125-test.scm \ tests/srfi-126-test.scm \ tests/srfi-128-test.scm \ + tests/srfi-151-test.scm \ ChangeLog-2008 diff --git a/test-suite/tests/srfi-151-test.scm b/test-suite/tests/srfi-151-test.scm new file mode 100644 index 000000000..b5f6d32cd --- /dev/null +++ b/test-suite/tests/srfi-151-test.scm @@ -0,0 +1,381 @@ +;; Copyright (C) John Cowan (2016). All Rights Reserved. + +;; Permission is hereby granted, free of charge, to any person obtaining +;; a copy of this software and associated documentation files (the +;; "Software"), to deal in the Software without restriction, including +;; without limitation the rights to use, copy, modify, merge, publish, +;; distribute, sublicense, and/or sell copies of the Software, and to +;; permit persons to whom the Software is furnished to do so, subject to +;; the following conditions: + +;; The above copyright notice and this permission notice shall be +;; included in all copies or substantial portions of the Software. + +;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +;; SOFTWARE. + +;;; START Guile-specific modifications. +;;; +;;; The 'imports' are turned into 'use-modules' and srfi-64 is used. +;;; Two macros are added for compatibility with Chicken Scheme's 'test' +;;; library. A 'test-begin' call is added. +(use-modules (srfi srfi-151) + (srfi srfi-64)) + +(define-syntax-rule (test arg ...) + (test-equal arg ...)) + +(define-syntax-rule (test-exit arg ...) + (test-end)) + +(test-begin "srfi-151") +;;; END Guile-specific modifications. + +(test-group "bitwise" + (test-group "bitwise/basic" + (test "test-1" -1 (bitwise-not 0)) + (test "test-122" 0 (bitwise-not -1)) + (test "test-248" -11 (bitwise-not 10)) + (test "test-249" 36 (bitwise-not -37)) + (test "test-2" 0 (bitwise-and #b0 #b1)) + (test "test-10" 1680869008 (bitwise-and -193073517 1689392892)) + (test "test-20" 3769478 (bitwise-and 1694076839 -4290775858)) + (test "test-115" 6 (bitwise-and 14 6)) + (test "test-251" 10 (bitwise-and 11 26)) + (test "test-254" 4 (bitwise-and 37 12)) + (test "test-288" 1 (bitwise-and #b1 #b1)) + (test "test-289" 0 (bitwise-and #b1 #b10)) + (test "test-290" #b10 (bitwise-and #b11 #b10)) + (test "test-291" #b101 (bitwise-and #b101 #b111)) + (test "test-292" #b111 (bitwise-and -1 #b111)) + (test "test-293" #b110 (bitwise-and -2 #b111)) + (test "test-294" 3769478 (bitwise-and -4290775858 1694076839)) + (test "test-11" -4294967295 (bitwise-ior 1 (- -1 #xffffffff))) + (test "test-12" -18446744073709551615 (bitwise-ior 1 (- -1 #xffffffffffffffff))) + (test "test-117" 14 (bitwise-ior 10 12)) + (test "test-250" 11 (bitwise-ior 3 10)) + (test "test-13" -4294967126 (bitwise-xor #b10101010 (- -1 #xffffffff))) + (test "test-15" -18446744073709551446 (bitwise-xor #b10101010 (- -1 #xffffffffffffffff))) + (test "test-16" -2600468497 (bitwise-ior 1694076839 -4290775858)) + (test "test-17" -184549633 (bitwise-ior -193073517 1689392892)) + (test "test-18" -2604237975 (bitwise-xor 1694076839 -4290775858)) + (test "test-19" -1865418641 (bitwise-xor -193073517 1689392892)) + (test "test-119" 6 (bitwise-xor 10 12)) + (test "test-252" 9 (bitwise-xor 3 10)) + (test "test-14" (bitwise-not -4294967126) (bitwise-eqv #b10101010 (- -1 #xffffffff))) + (test "test-253" -42 (bitwise-eqv 37 12)) + (test "test-27" -1 (bitwise-nand 0 0)) + (test "test-28" -1 (bitwise-nand 0 -1)) + (test "test-29" -124 (bitwise-nand -1 123)) + (test "test-326" -11 (bitwise-nand 11 26)) + (test "test-327" -28 (bitwise-nor 11 26)) + (test "test-317" 0 (bitwise-nor -1 123)) + (test "test-328" 16 (bitwise-andc1 11 26)) + (test "test-329" 1 (bitwise-andc2 11 26)) + (test "test-330" -2 (bitwise-orc1 11 26)) + (test "test-30" -1 (bitwise-nor 0 0)) + (test "test-31" 0 (bitwise-nor 0 -1)) + (test "test-22" 0 (bitwise-andc1 0 0)) + (test "test-23" -1 (bitwise-andc1 0 -1)) + (test "test-24" 123 (bitwise-andc1 0 123)) + (test "test-25" 0 (bitwise-andc2 0 0)) + (test "test-26" -1 (bitwise-andc2 -1 0)) + (test "test-318" -1 (bitwise-orc1 0 0)) + (test "test-319" -1 (bitwise-orc1 0 -1)) + (test "test-320" 0 (bitwise-orc1 -1 0)) + (test "test-321" -124 (bitwise-orc1 123 0)) + (test "test-322" -1 (bitwise-orc2 0 0)) + (test "test-323" -1 (bitwise-orc2 -1 0)) + (test "test-324" 0 (bitwise-orc2 0 -1)) + (test "test-325" -124 (bitwise-orc2 0 123)) + ) + (test-group "bitwise/integer" + (test "test-78" #x1000000000000000100000000000000000000000000000000 + (arithmetic-shift #x100000000000000010000000000000000 64)) + (test "test-79" #x8e73b0f7da0e6452c810f32b809079e5 + (arithmetic-shift #x8e73b0f7da0e6452c810f32b809079e562f8ead2522c6b7b -64)) + (test "test-196" 2 (arithmetic-shift 1 1)) + (test "test-197" 0 (arithmetic-shift 1 -1)) + (test "test-331" 1 (arithmetic-shift 1 0)) + (test "test-333" 4 (arithmetic-shift 1 2)) + (test "test-334" 8 (arithmetic-shift 1 3)) + (test "test-335" 16 (arithmetic-shift 1 4)) + (test "test-336" (expt 2 31) (arithmetic-shift 1 31)) + (test "test-337" (expt 2 32) (arithmetic-shift 1 32)) + (test "test-338" (expt 2 33) (arithmetic-shift 1 33)) + (test "test-339" (expt 2 63) (arithmetic-shift 1 63)) + (test "test-340" (expt 2 64) (arithmetic-shift 1 64)) + (test "test-341" (expt 2 65) (arithmetic-shift 1 65)) + (test "test-342" (expt 2 127) (arithmetic-shift 1 127)) + (test "test-343" (expt 2 128) (arithmetic-shift 1 128)) + (test "test-344" (expt 2 129) (arithmetic-shift 1 129)) + (test "test-345" 3028397001194014464 (arithmetic-shift 11829675785914119 8)) + (test "test-346" -1 (arithmetic-shift -1 0)) + (test "test-347" -2 (arithmetic-shift -1 1)) + (test "test-348" -4 (arithmetic-shift -1 2)) + (test "test-349" -8 (arithmetic-shift -1 3)) + (test "test-350" -16 (arithmetic-shift -1 4)) + (test "test-351" (- (expt 2 31)) (arithmetic-shift -1 31)) + (test "test-352" (- (expt 2 32)) (arithmetic-shift -1 32)) + (test "test-353" (- (expt 2 33)) (arithmetic-shift -1 33)) + (test "test-354" (- (expt 2 63)) (arithmetic-shift -1 63)) + (test "test-355" (- (expt 2 64)) (arithmetic-shift -1 64)) + (test "test-356" (- (expt 2 65)) (arithmetic-shift -1 65)) + (test "test-357" (- (expt 2 127)) (arithmetic-shift -1 127)) + (test "test-358" (- (expt 2 128)) (arithmetic-shift -1 128)) + (test "test-359" (- (expt 2 129)) (arithmetic-shift -1 129)) + (test "test-360" 0 (arithmetic-shift 1 -63)) + (test "test-361" 0 (arithmetic-shift 1 -64)) + (test "test-362" 0 (arithmetic-shift 1 -65)) + (test "test-255" 32 (arithmetic-shift 8 2)) + (test "test-256" 4 (arithmetic-shift 4 0)) + (test "test-257" 4 (arithmetic-shift 8 -1)) + (test "test-258" -79 (arithmetic-shift -100000000000000000000000000000000 -100)) + (test "test-135" 2 (bit-count 12)) + (test "test-263" 0 (integer-length 0)) + (test "test-264" 1 (integer-length 1)) + (test "test-265" 0 (integer-length -1)) + (test "test-266" 3 (integer-length 7)) + (test "test-267" 3 (integer-length -7)) + (test "test-268" 4 (integer-length 8)) + (test "test-269" 3 (integer-length -8)) + (test "test-125" 9 (bitwise-if 3 1 8)) + (test "test-126" 0 (bitwise-if 3 8 1)) + (test "test-373" 3 (bitwise-if 1 1 2)) + (test "test-378" #b00110011 (bitwise-if #b00111100 #b11110000 #b00001111)) + ) + (test-group "bitwise/single" + (test "test-160" #t (bit-set? 0 1)) + (test "test-161" #f (bit-set? 1 1)) + (test "test-162" #f (bit-set? 1 8)) + (test "test-163" #t (bit-set? 10000 -1)) + (test "test-167" #t (bit-set? 1000 -1)) + (test "test-541" #t (bit-set? 64 #x10000000000000000)) + (test "test-542" #f (bit-set? 64 1)) + (test "test-272" #t (bit-set? 3 10)) + (test "test-273" #t (bit-set? 2 6)) + (test "test-274" #f (bit-set? 0 6)) + (test "test-168" 0 (copy-bit 0 0 #f)) + (test "test-169" 0 (copy-bit 30 0 #f)) + (test "test-170" 0 (copy-bit 31 0 #f)) + (test "test-171" 0 (copy-bit 62 0 #f)) + (test "test-172" 0 (copy-bit 63 0 #f)) + (test "test-173" 0 (copy-bit 128 0 #f)) + (test "test-174" -1 (copy-bit 0 -1 #t)) + (test "test-175" -1 (copy-bit 30 -1 #t)) + (test "test-176" -1 (copy-bit 31 -1 #t)) + (test "test-177" -1 (copy-bit 62 -1 #t)) + (test "test-178" -1 (copy-bit 63 -1 #t)) + (test "test-179" -1 (copy-bit 128 -1 #t)) + (test "test-180" 1 (copy-bit 0 0 #t)) + (test "test-181" #x106 (copy-bit 8 6 #t)) + (test "test-182" 6 (copy-bit 8 6 #f)) + (test "test-183" -2 (copy-bit 0 -1 #f)) + (test "test-184" 0 (copy-bit 128 #x100000000000000000000000000000000 #f)) + (test "test-185" #x100000000000000000000000000000000 + (copy-bit 128 #x100000000000000000000000000000000 #t)) + (test "test-186" #x100000000000000000000000000000000 + (copy-bit 64 #x100000000000000000000000000000000 #f)) + (test "test-187" #x-100000000000000000000000000000000 + (copy-bit 64 #x-100000000000000000000000000000000 #f)) + (test "test-188" #x-100000000000000000000000000000000 + (copy-bit 256 #x-100000000000000000000000000000000 #t)) + (test "test-276" #b100 (copy-bit 2 0 #t)) + (test "test-277" #b1011 (copy-bit 2 #b1111 #f)) + (test "test-379" #b1 (copy-bit 0 0 #t)) + (test "test-100" #b1011 (bit-swap 1 2 #b1101)) + (test "test-101" #b1011 (bit-swap 2 1 #b1101)) + (test "test-382" #b1110 (bit-swap 0 1 #b1101)) + (test "test-102" #b10000000101 (bit-swap 3 10 #b1101)) + (test "test-278" 1 (bit-swap 0 2 4)) + (test "test-129" #t (any-bit-set? 3 6)) + (test "test-130" #f (any-bit-set? 3 12)) + (test "test-133" #t (every-bit-set? 4 6)) + (test "test-134" #f (every-bit-set? 7 6)) + (test "test-141" -1 (first-set-bit 0)) + (test "test-142" 0 (first-set-bit 1)) + (test "test-143" 0 (first-set-bit 3)) + (test "test-144" 2 (first-set-bit 4)) + (test "test-145" 1 (first-set-bit 6)) + (test "test-146" 0 (first-set-bit -1)) + (test "test-147" 1 (first-set-bit -2)) + (test "test-148" 0 (first-set-bit -3)) + (test "test-149" 2 (first-set-bit -4)) + (test "test-150" 128 (first-set-bit #x100000000000000000000000000000000)) + (test "test-280" 1 (first-set-bit 2)) + (test "test-282" 3 (first-set-bit 40)) + (test "test-283" 2 (first-set-bit -28)) + (test "test-284" 99 (first-set-bit (expt 2 99))) + (test "test-285" 99 (first-set-bit (expt -2 99))) + ) + (test-group "bitwise/field" + (test "test-189" 0 (bit-field 6 0 1)) + (test "test-190" 3 (bit-field 6 1 3)) + (test "test-191" 1 (bit-field 6 2 999)) + (test "test-192" 1 (bit-field #x100000000000000000000000000000000 128 129)) + (test "test-363" #b1010 (bit-field #b1101101010 0 4)) + (test "test-364" #b101101 (bit-field #b1101101010 3 9)) + (test "test-365" #b10110 (bit-field #b1101101010 4 9)) + (test "test-366" #b110110 (bit-field #b1101101010 4 10)) + (test "test-367" #t (bit-field-any? #b101101 0 2)) + (test "test-368" #t (bit-field-any? #b101101 2 4)) + (test "test-369" #f (bit-field-any? #b101101 1 2)) + (test "test-370" #f (bit-field-every? #b101101 0 2)) + (test "test-371" #t (bit-field-every? #b101101 2 4)) + (test "test-372" #t (bit-field-every? #b101101 0 1)) + (test "test-374" #b100000 (bit-field-clear #b101010 1 4)) + (test "test-375" #b101110 (bit-field-set #b101010 1 4)) + (test "test-193" #b111 (bit-field-replace #b110 1 0 1)) + (test "test-194" #b110 (bit-field-replace #b110 1 1 2)) + (test "test-195" #b010 (bit-field-replace #b110 1 1 3)) + (test "test-376" #b100100 (bit-field-replace #b101010 #b010 1 4)) + (test "test-377" #b1001 (bit-field-replace-same #b1111 #b0000 1 3)) + (test "test-200" #b110 (bit-field-rotate #b110 1 1 2)) + (test "test-201" #b1010 (bit-field-rotate #b110 1 2 4)) + (test "test-202" #b1011 (bit-field-rotate #b0111 -1 1 4)) + (test "test-203" #b0 (bit-field-rotate #b0 128 0 256)) + (test "test-204" #b1 (bit-field-rotate #b1 128 1 256)) + (test "test-205" #x100000000000000000000000000000000 + (bit-field-rotate #x100000000000000000000000000000000 128 0 64)) + (test "test-206" #x100000000000000000000000000000008 + (bit-field-rotate #x100000000000000000000000000000001 3 0 64)) + (test "test-207" #x100000000000000002000000000000000 + (bit-field-rotate #x100000000000000000000000000000001 -3 0 64)) + (test "test-208" #b110 (bit-field-rotate #b110 0 0 10)) + (test "test-209" #b110 (bit-field-rotate #b110 0 0 256)) + (test "test-475" 1 (bit-field-rotate #x100000000000000000000000000000000 1 0 129)) + (test "test-211" 6 (bit-field-reverse 6 1 3)) + (test "test-212" 12 (bit-field-reverse 6 1 4)) + (test "test-213" #x80000000 (bit-field-reverse 1 0 32)) + (test "test-214" #x40000000 (bit-field-reverse 1 0 31)) + (test "test-215" #x20000000 (bit-field-reverse 1 0 30)) + (test "test-216" (bitwise-ior (arithmetic-shift -1 32) #xFBFFFFFF) + (bit-field-reverse -2 0 27)) + (test "test-217" (bitwise-ior (arithmetic-shift -1 32) #xF7FFFFFF) + (bit-field-reverse -2 0 28)) + (test "test-218" (bitwise-ior (arithmetic-shift -1 32) #xEFFFFFFF) + (bit-field-reverse -2 0 29)) + (test "test-219" (bitwise-ior (arithmetic-shift -1 32) #xDFFFFFFF) + (bit-field-reverse -2 0 30)) + (test "test-220" (bitwise-ior (arithmetic-shift -1 32) #xBFFFFFFF) + (bit-field-reverse -2 0 31)) + (test "test-221" (bitwise-ior (arithmetic-shift -1 32) #x7FFFFFFF) + (bit-field-reverse -2 0 32)) + (test "test-222" 5 (bit-field-reverse #x140000000000000000000000000000000 0 129)) + ) + (test-group "bitwise/conversion" + (test "test-103" '(#t #f #t #f #t #t #t) (bits->list #b1110101)) + (test "test-104" '(#f #t #f #t) (bits->list #b111010 4)) + (test "test-106" #b1110101 (list->bits '(#t #f #t #f #t #t #t))) + (test "test-107" #b111010100 (list->bits '(#f #f #t #f #t #f #t #t #t))) + (test "test-223" '(#t #t) (bits->list 3)) + (test "test-224" '(#f #t #t #f) (bits->list 6 4)) + (test "test-225" '(#f #t) (bits->list 6 2)) + (test "test-226" '(#t #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f + #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f + #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f + #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f + #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f + #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f + #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f + #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f) + (bits->list 1 128)) + (test "test-228" '(#f + #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f + #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f + #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f + #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f + #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f + #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f + #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f + #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #t) + (bits->list #x100000000000000000000000000000000)) + (test "test-229" 6 (list->bits '(#f #t #t))) + (test "test-230" 12 (list->bits '(#f #f #t #t))) + (test "test-231" 6 (list->bits '(#f #t #t #f))) + (test "test-232" 2 (list->bits '(#f #t))) + (test "test-233" 1 (list->bits + '(#t #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f + #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f + #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f + #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f + #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f + #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f + #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f + #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f))) + (test "test-234" #x100000000000000000000000000000000 + (list->bits + '(#f + #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f + #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f + #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f + #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f + #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f + #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f + #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f + #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #t))) + (test "test-235" #x03FFFFFF (list->bits '(#t #t + #t #t #t #t #t #t #t #t + #t #t #t #t #t #t #t #t + #t #t #t #t #t #t #t #t))) + (test "test-236" #x07FFFFFF (list->bits '(#t #t #t + #t #t #t #t #t #t #t #t + #t #t #t #t #t #t #t #t + #t #t #t #t #t #t #t #t))) + (test "test-237" #x0FFFFFFF (list->bits '(#t #t #t #t + #t #t #t #t #t #t #t #t + #t #t #t #t #t #t #t #t + #t #t #t #t #t #t #t #t))) + (test "test-238" #x1FFFFFFF (list->bits '(#t #t #t #t #t + #t #t #t #t #t #t #t #t + #t #t #t #t #t #t #t #t + #t #t #t #t #t #t #t #t))) + (test "test-239" #x3FFFFFFF (list->bits '(#t #t #t #t #t #t + #t #t #t #t #t #t #t #t + #t #t #t #t #t #t #t #t + #t #t #t #t #t #t #t #t))) + (test "test-240" #x7FFFFFFF (list->bits '(#t #t #t #t #t #t #t + #t #t #t #t #t #t #t #t + #t #t #t #t #t #t #t #t + #t #t #t #t #t #t #t #t))) + (test "test-241" #xFFFFFFFF (list->bits '(#t #t #t #t #t #t #t #t + #t #t #t #t #t #t #t #t + #t #t #t #t #t #t #t #t + #t #t #t #t #t #t #t #t))) + (test "test-242" #x1FFFFFFFF (list->bits '(#t + #t #t #t #t #t #t #t #t + #t #t #t #t #t #t #t #t + #t #t #t #t #t #t #t #t + #t #t #t #t #t #t #t #t))) + (test "test-490" 1 (list->bits '(#t #f))) + (test "test-108" #b1110101 (vector->bits '#(#t #f #t #f #t #t #t))) + (test "test-109" #b00011010100 (vector->bits '#(#f #f #t #f #t #f #t #t))) + (test "test-105" '#(#t #t #t #f #t #f #t #f #f) (bits->vector #b1010111 9)) + (test "test-105" '#(#t #t #t #f #t #f #t #f #f) (bits->vector #b1010111 9)) + (test "test-110" #b1110101 (bits #t #f #t #f #t #t #t)) + (test "test-243" 0 (bits)) + (test "test-111" #b111010100 (bits #f #f #t #f #t #f #t #t #t)) + ) + (test-group "bitwise/fold" + (test "test-112" '(#t #f #t #f #t #t #t) (bitwise-fold cons '() #b1010111)) + (test "test-113" 5 + (let ((count 0)) + (bitwise-for-each (lambda (b) (if b (set! count (+ count 1)))) + #b1010111) + count)) + (test "test-114" #b101010101 + (bitwise-unfold (lambda (i) (= i 10)) even? (lambda (i) (+ i 1)) 0)) + (let ((g (make-bitwise-generator #b110))) + (test "test-244a" #f (g)) + (test "test-244b" #t (g)) + (test "test-244c" #t (g)) + (test "test-244d" #f (g))) + ) +) +(test-exit) diff --git a/test-suite/tests/srfi-151.test b/test-suite/tests/srfi-151.test new file mode 100644 index 000000000..6c535b39e --- /dev/null +++ b/test-suite/tests/srfi-151.test @@ -0,0 +1,46 @@ +;;;; srfi-151.test --- Test suite for SRFI-151. -*- scheme -*- +;;;; +;;;; Copyright (C) 2023 Free Software Foundation, Inc. +;;;; +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +(define-module (test-srfi-151) + #:use-module (srfi srfi-64)) + +(define report (@@ (test-suite lib) report)) + +(define (guile-test-runner) + (let ((runner (test-runner-null))) + (test-runner-on-test-end! runner + (lambda (runner) + (let* ((result-alist (test-result-alist runner)) + (result-kind (assq-ref result-alist 'result-kind)) + (test-name (list (assq-ref result-alist 'test-name)))) + (case result-kind + ((pass) (report 'pass test-name)) + ((xpass) (report 'upass test-name)) + ((skip) (report 'untested test-name)) + ((fail xfail) + (apply report result-kind test-name result-alist)) + (else #t))))) + runner)) + +(test-with-runner + (guile-test-runner) + (primitive-load-path "tests/srfi-151-test.scm")) + +;;; Local Variables: +;;; eval: (put 'test-runner-on-test-end! 'scheme-indent-function 1) +;;; End: -- 2.41.0