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 v9 14/18] module: Add SRFI 160. Date: Tue, 12 Dec 2023 23:37:53 -0500 Message-ID: <20231213044217.14093-15-maxim.cournoyer@gmail.com> References: <20231213044217.14093-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="27826"; 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 Dec 13 05:44:05 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 1rDH6K-0006rT-Aq for guile-devel@m.gmane-mx.org; Wed, 13 Dec 2023 05:44:04 +0100 Original-Received: from localhost ([::1] helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1rDH5J-0004XP-3A; Tue, 12 Dec 2023 23:43: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 1rDH5F-0004Wf-E9 for guile-devel@gnu.org; Tue, 12 Dec 2023 23:42:57 -0500 Original-Received: from mail-qt1-x832.google.com ([2607:f8b0:4864:20::832]) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1rDH59-00075z-86 for guile-devel@gnu.org; Tue, 12 Dec 2023 23:42:57 -0500 Original-Received: by mail-qt1-x832.google.com with SMTP id d75a77b69052e-425a84ed4bcso36710421cf.3 for ; Tue, 12 Dec 2023 20:42:49 -0800 (PST) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gmail.com; s=20230601; t=1702442569; x=1703047369; 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=Cuhrk/T7Ia8NJlwLt2oN/e1rpgixKBftzb3b9mqGDNA=; b=QfsfQ979Q8OlUWPW2a5zCGarlxk6wf2WGOm0B7MvY5RUfay5KIAKXu+7PniMLlVARy xIwtTkmHP0dsn+aCknGTUEpzj7eNLT3IqOB/bEEAYErQ4l4g4DNd04RhH8+9fhS5skmP EoQdJ4SEEYRujiurcXoe0z8QItyWSD4qgOMkJHNQ1WUnJ4NZmYxYeyTfbeKZgOKP7YGP ruA4FUqs2zztkMcQA1jHjTCdWeXmjHBgU+3CAkmk2i11ig/INxRY+nZXwLSfQPA994Qw HGsDqGUc90HuExkI7/rYDSJsIGYBjcL4tZetZSgiTH5tVONXNqRiyS+P9AyqqOd5CN+n aEDg== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20230601; t=1702442569; x=1703047369; 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=Cuhrk/T7Ia8NJlwLt2oN/e1rpgixKBftzb3b9mqGDNA=; b=aJVXeD1faLzjN6Tp9DM6SozSIgF+v94ZCX7rMDDpTNcBBkDSmAYHUAUyvf3ZLb88Ch s8Fixb6wkmrSVTe1l61bVl2krTKjTJ4A8dmcUyteO9sjvqmp/qnHtHQm0InE79+KVDdL z5BZmA/Bb9GfUeWmocspNoUNUosd655uzeC93JYWejJ4N7TEonPYf2n+kMvunO7TnSYh 0NAtRHL/brO9obkVsVr2YVgkkFwU7xcbdaN7QoQcYhUvkZsGeLbVQyirFnutcSXFmeMD sV+XFX/b5jCMFC8KWuSaCsZcG53a55CTeyH0zq0B2xFnKveIkQs1fx2BR5AbYwS3NLa4 K/nw== X-Gm-Message-State: AOJu0Yxl4md2pT7XZqLUfQ//pWveJvOpMRveGDSPYEeB6Pf9hhCaVIVg cJQPlYt+h8n/veMdh6wSibG9CiWxMYbllQ== X-Google-Smtp-Source: AGHT+IFBcWnjd3fXCM8zGty7FSZJY8dI62esXp5AaaaXNKHtmudDMWzAM9T7Y3+hmsqT+rEfSGQb8g== X-Received: by 2002:ac8:5c04:0:b0:425:9936:b08e with SMTP id i4-20020ac85c04000000b004259936b08emr11248159qti.136.1702442566055; Tue, 12 Dec 2023 20:42:46 -0800 (PST) Original-Received: from localhost.localdomain (dsl-157-186.b2b2c.ca. [66.158.157.186]) by smtp.gmail.com with ESMTPSA id s7-20020ac87587000000b004181138e0c0sm4621719qtq.31.2023.12.12.20.42.43 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Tue, 12 Dec 2023 20:42:45 -0800 (PST) X-Mailer: git-send-email 2.41.0 In-Reply-To: <20231213044217.14093-1-maxim.cournoyer@gmail.com> Received-SPF: pass client-ip=2607:f8b0:4864:20::832; envelope-from=maxim.cournoyer@gmail.com; helo=mail-qt1-x832.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:22240 Archived-At: * module/srfi/srfi-160/base.sld * module/srfi/srfi-160/base/c128-vector2list.scm * module/srfi/srfi-160/base/c64-vector2list.scm * module/srfi/srfi-160/base/complex.scm * module/srfi/srfi-160/base/f32-vector2list.scm * module/srfi/srfi-160/base/f64-vector2list.scm * module/srfi/srfi-160/base/r7rec.scm * module/srfi/srfi-160/base/s16-vector2list.scm * module/srfi/srfi-160/base/s32-vector2list.scm * module/srfi/srfi-160/base/s64-vector2list.scm * module/srfi/srfi-160/base/s8-vector2list.scm * module/srfi/srfi-160/base/u16-vector2list.scm * module/srfi/srfi-160/base/u32-vector2list.scm * module/srfi/srfi-160/base/u64-vector2list.scm * module/srfi/srfi-160/base/u8-vector2list.scm * module/srfi/srfi-160/base/valid.scm * module/srfi/srfi-160/c128-impl.scm * module/srfi/srfi-160/c128.sld * module/srfi/srfi-160/c64-impl.scm * module/srfi/srfi-160/c64.sld * module/srfi/srfi-160/f32-impl.scm * module/srfi/srfi-160/f32.sld * module/srfi/srfi-160/f64-impl.scm * module/srfi/srfi-160/f64.sld * module/srfi/srfi-160/s16-impl.scm * module/srfi/srfi-160/s16.sld * module/srfi/srfi-160/s32-impl.scm * module/srfi/srfi-160/s32.sld * module/srfi/srfi-160/s64-impl.scm * module/srfi/srfi-160/s64.sld * module/srfi/srfi-160/s8-impl.scm * module/srfi/srfi-160/s8.sld * module/srfi/srfi-160/u16-impl.scm * module/srfi/srfi-160/u16.sld * module/srfi/srfi-160/u32-impl.scm * module/srfi/srfi-160/u32.sld * module/srfi/srfi-160/u64-impl.scm * module/srfi/srfi-160/u64.sld * module/srfi/srfi-160/u8-impl.scm * module/srfi/srfi-160/u8.sld * test-suite/tests/srfi-160-base-test.scm * test-suite/tests/srfi-160-base.test * test-suite/tests/srfi-160-test.scm * test-suite/tests/srfi-160.test: New files. * doc/ref/srfi-modules.texi (SRFI 160 Abstract): New subsection. * test-suite/Makefile.am (SCM_TESTS): Register tests/srfi-160-base.test and tests/srfi-160.test. (EXTRA_DIST): Register tests/srfi-160-base-test.scm and tests/srfi-160-test.scm. * NEWS: Update news. --- (no changes since v8) Changes in v8: - Standardize SPDX/REUSE metadata Changes in v7: - Register prerequisites for srfi/srfi-160/*.go in am/bootstrap.am Changes in v5: - Generate Texinfo menu entries - Update NEWS NEWS | 1 + am/bootstrap.am | 46 ++ doc/ref/guile.texi | 2 +- doc/ref/srfi-modules.texi | 649 +++++++++++++++++- module/srfi/srfi-160/base.sld | 68 ++ .../srfi/srfi-160/base/c128-vector2list.scm | 19 + module/srfi/srfi-160/base/c64-vector2list.scm | 19 + module/srfi/srfi-160/base/complex.scm | 112 +++ module/srfi/srfi-160/base/f32-vector2list.scm | 19 + module/srfi/srfi-160/base/f64-vector2list.scm | 19 + module/srfi/srfi-160/base/r7rec.scm | 12 + module/srfi/srfi-160/base/s16-vector2list.scm | 19 + module/srfi/srfi-160/base/s32-vector2list.scm | 19 + module/srfi/srfi-160/base/s64-vector2list.scm | 19 + module/srfi/srfi-160/base/s8-vector2list.scm | 19 + module/srfi/srfi-160/base/u16-vector2list.scm | 19 + module/srfi/srfi-160/base/u32-vector2list.scm | 19 + module/srfi/srfi-160/base/u64-vector2list.scm | 19 + module/srfi/srfi-160/base/u8-vector2list.scm | 19 + module/srfi/srfi-160/base/valid.scm | 27 + module/srfi/srfi-160/c128-impl.scm | 601 ++++++++++++++++ module/srfi/srfi-160/c128.sld | 49 ++ module/srfi/srfi-160/c64-impl.scm | 601 ++++++++++++++++ module/srfi/srfi-160/c64.sld | 49 ++ module/srfi/srfi-160/f32-impl.scm | 601 ++++++++++++++++ module/srfi/srfi-160/f32.sld | 49 ++ module/srfi/srfi-160/f64-impl.scm | 601 ++++++++++++++++ module/srfi/srfi-160/f64.sld | 49 ++ module/srfi/srfi-160/s16-impl.scm | 601 ++++++++++++++++ module/srfi/srfi-160/s16.sld | 49 ++ module/srfi/srfi-160/s32-impl.scm | 601 ++++++++++++++++ module/srfi/srfi-160/s32.sld | 49 ++ module/srfi/srfi-160/s64-impl.scm | 601 ++++++++++++++++ module/srfi/srfi-160/s64.sld | 49 ++ module/srfi/srfi-160/s8-impl.scm | 601 ++++++++++++++++ module/srfi/srfi-160/s8.sld | 49 ++ module/srfi/srfi-160/u16-impl.scm | 601 ++++++++++++++++ module/srfi/srfi-160/u16.sld | 49 ++ module/srfi/srfi-160/u32-impl.scm | 601 ++++++++++++++++ module/srfi/srfi-160/u32.sld | 49 ++ module/srfi/srfi-160/u64-impl.scm | 601 ++++++++++++++++ module/srfi/srfi-160/u64.sld | 49 ++ module/srfi/srfi-160/u8-impl.scm | 601 ++++++++++++++++ module/srfi/srfi-160/u8.sld | 49 ++ test-suite/Makefile.am | 4 + test-suite/tests/srfi-160-base-test.scm | 168 +++++ test-suite/tests/srfi-160-base.test | 35 + test-suite/tests/srfi-160-test.scm | 263 +++++++ test-suite/tests/srfi-160.test | 36 + 49 files changed, 9449 insertions(+), 2 deletions(-) create mode 100644 module/srfi/srfi-160/base.sld create mode 100644 module/srfi/srfi-160/base/c128-vector2list.scm create mode 100644 module/srfi/srfi-160/base/c64-vector2list.scm create mode 100644 module/srfi/srfi-160/base/complex.scm create mode 100644 module/srfi/srfi-160/base/f32-vector2list.scm create mode 100644 module/srfi/srfi-160/base/f64-vector2list.scm create mode 100644 module/srfi/srfi-160/base/r7rec.scm create mode 100644 module/srfi/srfi-160/base/s16-vector2list.scm create mode 100644 module/srfi/srfi-160/base/s32-vector2list.scm create mode 100644 module/srfi/srfi-160/base/s64-vector2list.scm create mode 100644 module/srfi/srfi-160/base/s8-vector2list.scm create mode 100644 module/srfi/srfi-160/base/u16-vector2list.scm create mode 100644 module/srfi/srfi-160/base/u32-vector2list.scm create mode 100644 module/srfi/srfi-160/base/u64-vector2list.scm create mode 100644 module/srfi/srfi-160/base/u8-vector2list.scm create mode 100644 module/srfi/srfi-160/base/valid.scm create mode 100644 module/srfi/srfi-160/c128-impl.scm create mode 100644 module/srfi/srfi-160/c128.sld create mode 100644 module/srfi/srfi-160/c64-impl.scm create mode 100644 module/srfi/srfi-160/c64.sld create mode 100644 module/srfi/srfi-160/f32-impl.scm create mode 100644 module/srfi/srfi-160/f32.sld create mode 100644 module/srfi/srfi-160/f64-impl.scm create mode 100644 module/srfi/srfi-160/f64.sld create mode 100644 module/srfi/srfi-160/s16-impl.scm create mode 100644 module/srfi/srfi-160/s16.sld create mode 100644 module/srfi/srfi-160/s32-impl.scm create mode 100644 module/srfi/srfi-160/s32.sld create mode 100644 module/srfi/srfi-160/s64-impl.scm create mode 100644 module/srfi/srfi-160/s64.sld create mode 100644 module/srfi/srfi-160/s8-impl.scm create mode 100644 module/srfi/srfi-160/s8.sld create mode 100644 module/srfi/srfi-160/u16-impl.scm create mode 100644 module/srfi/srfi-160/u16.sld create mode 100644 module/srfi/srfi-160/u32-impl.scm create mode 100644 module/srfi/srfi-160/u32.sld create mode 100644 module/srfi/srfi-160/u64-impl.scm create mode 100644 module/srfi/srfi-160/u64.sld create mode 100644 module/srfi/srfi-160/u8-impl.scm create mode 100644 module/srfi/srfi-160/u8.sld create mode 100644 test-suite/tests/srfi-160-base-test.scm create mode 100644 test-suite/tests/srfi-160-base.test create mode 100644 test-suite/tests/srfi-160-test.scm create mode 100644 test-suite/tests/srfi-160.test diff --git a/NEWS b/NEWS index a33e5bbb1..c36b55643 100644 --- a/NEWS +++ b/NEWS @@ -27,6 +27,7 @@ the compiler reports it as "possibly unused". ** Add (scheme sort) ** Add (srfi 125), a mutators library ** Add (srfi 151), a bitwise operations library +** Add (srfi 160), an homogeneous numeric vector library * Bug fixes diff --git a/am/bootstrap.am b/am/bootstrap.am index 04cee1442..d6cdc057a 100644 --- a/am/bootstrap.am +++ b/am/bootstrap.am @@ -67,6 +67,12 @@ srfi/srfi-126.go: srfi/srfi-1.go srfi/srfi-27.go srfi/srfi-128.go: srfi/srfi-69.go srfi/srfi-126.go scheme/comparator.go: srfi/srfi-128.go srfi/srfi-125.go: srfi/srfi-126.go srfi/srfi-128.go +srfi/srfi-160/base.go: srfi/srfi-151.go srfi/srfi-4.go +srfi/srfi-160/c128.go srfi/srfi-160/c64.go srfi/srfi-160/f32.go \ + srfi/srfi-160/f64.go srfi/srfi-160/s16.go srfi/srfi-160/s32.go \ + srfi/srfi-160/s64.go srfi/srfi-160/s8.go srfi/srfi-160/u16.go \ + srfi/srfi-160/u32.go srfi/srfi-160/u64.go \ + srfi/srfi-160/u8.go: srfi/srfi-128.go srfi/srfi-160/base.go # All sources. We can compile these in any order; the order below is # designed to hopefully result in the lowest total compile time. @@ -361,6 +367,19 @@ SOURCES = \ srfi/srfi-126.sld \ srfi/srfi-128.sld \ srfi/srfi-151.sld \ + srfi/srfi-160/base.sld \ + srfi/srfi-160/c64.sld \ + srfi/srfi-160/c128.sld \ + srfi/srfi-160/f32.sld \ + srfi/srfi-160/f64.sld \ + srfi/srfi-160/s8.sld \ + srfi/srfi-160/s16.sld \ + srfi/srfi-160/s32.sld \ + srfi/srfi-160/s64.sld \ + srfi/srfi-160/u8.sld \ + srfi/srfi-160/u16.sld \ + srfi/srfi-160/u32.sld \ + srfi/srfi-160/u64.sld \ srfi/srfi-171.scm \ srfi/srfi-171/gnu.scm \ srfi/srfi-171/meta.scm \ @@ -458,6 +477,33 @@ NOCOMP_SOURCES = \ srfi/srfi-151/bitwise-33.scm \ srfi/srfi-151/bitwise-60.scm \ srfi/srfi-151/bitwise-other.scm \ + srfi/srfi-160/base/c64-vector2list.scm \ + srfi/srfi-160/base/c128-vector2list.scm \ + srfi/srfi-160/base/complex.scm \ + srfi/srfi-160/base/f32-vector2list.scm \ + srfi/srfi-160/base/f64-vector2list.scm \ + srfi/srfi-160/base/r7rec.scm \ + srfi/srfi-160/base/s8-vector2list.scm \ + srfi/srfi-160/base/s16-vector2list.scm \ + srfi/srfi-160/base/s32-vector2list.scm \ + srfi/srfi-160/base/s64-vector2list.scm \ + srfi/srfi-160/base/u8-vector2list.scm \ + srfi/srfi-160/base/u16-vector2list.scm \ + srfi/srfi-160/base/u32-vector2list.scm \ + srfi/srfi-160/base/u64-vector2list.scm \ + srfi/srfi-160/base/valid.scm \ + srfi/srfi-160/c64-impl.scm \ + srfi/srfi-160/c128-impl.scm \ + srfi/srfi-160/f32-impl.scm \ + srfi/srfi-160/f64-impl.scm \ + srfi/srfi-160/s8-impl.scm \ + srfi/srfi-160/s16-impl.scm \ + srfi/srfi-160/s32-impl.scm \ + srfi/srfi-160/s64-impl.scm \ + srfi/srfi-160/u8-impl.scm \ + srfi/srfi-160/u16-impl.scm \ + srfi/srfi-160/u32-impl.scm \ + srfi/srfi-160/u64-impl.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 f94c10209..3226ee53b 100644 --- a/doc/ref/guile.texi +++ b/doc/ref/guile.texi @@ -24,7 +24,7 @@ Invariant Sections, no Front-Cover Texts, and no Back-Cover Texts. A copy of the license is included in the section entitled ``GNU Free Documentation License.'' -Additionally, the documentation of the 125, 126, 128, and 151 SRFI +Additionally, the documentation of the 125, 126, 128, 151 and 160 SRFI modules is adapted from their specification text, which is made available under the following Expat license: diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi index b6782f183..23e030b99 100644 --- a/doc/ref/srfi-modules.texi +++ b/doc/ref/srfi-modules.texi @@ -3,7 +3,7 @@ @c Copyright (C) 1996, 1997, 2000-2004, 2006, 2007-2014, 2017, 2018, 2019, 2020 @c Free Software Foundation, Inc. @c Copyright (C) 2015-2016 Taylan Ulrich Bayırlı/Kammer -@c Copyright (C) 2015-2016 John Cowan +@c Copyright (C) 2015-2016, 2018 John Cowan @c See the file guile.texi for copying conditions. @node SRFI Support @@ -70,6 +70,7 @@ get the relevant SRFI documents from the SRFI home page * SRFI 126:: R6RS-based hash tables. * SRFI 128:: Comparators. * SRFI 151:: Bitwise Operations. +* SRFI 160:: Homogeneous numeric vectors. * SRFI-171:: Transducers. @end menu @@ -8229,6 +8230,652 @@ Return a @url{https://srfi.schemers.org/srfi-121/srfi-121.html, SRFI @end lisp @end deffn +@node SRFI 160 +@subsection SRFI 160: Homogeneous numeric vector libraries +@cindex SRFI 160 + +@menu +* SRFI 160 Abstract:: +* SRFI 160 Rationale:: +* SRFI 160 Datatypes:: +* SRFI 160 Notation:: +* SRFI 160 Packaging:: +* SRFI 160 Procedures:: +* SRFI 160 Optional lexical syntax:: +@end menu + +@node SRFI 160 Abstract +@subsubsection SRFI 160 Abstract + +This SRFI describes a set of operations on SRFI 4 homogeneous vector +types (plus a few additional types) that are closely analogous to the +vector operations library, +@url{https://srfi.schemers.org/srfi-133/srfi-133.html, SRFI 133}. An +external representation is specified which may be supported by the +@code{read} and @code{write} procedures and by the program parser so +that programs can contain references to literal homogeneous vectors. + +@node SRFI 160 Rationale +@subsubsection SRFI 160 Rationale + +Like lists, Scheme vectors are a heterogeneous datatype which impose no +restriction on the type of the elements. This generality is not needed +for applications where all the elements are of the same type. The use +of Scheme vectors is not ideal for such applications because, in the +absence of a compiler with a fancy static analysis, the representation +will typically use some form of boxing of the elements which means low +space efficiency and slower access to the elements. Moreover, +homogeneous vectors are convenient for interfacing with low-level +libraries (e.g. binary block I/O) and to interface with foreign +languages which support homogeneous vectors. Finally, the use of +homogeneous vectors allows certain errors to be caught earlier. + +This SRFI specifies a set of homogeneous vector datatypes which cover +the most practical cases, that is, where the type of the elements is +numeric (exact integer or inexact real or complex) and the precision and +representation is efficiently implemented on the hardware of most +current computer architectures (8, 16, 32 and 64 bit integers, either +signed or unsigned, and 32 and 64 bit floating point numbers). + +This SRFI extends @url{https://srfi.schemers.org/srfi-4/srfi-4.html, +SRFI 4} by providing the additional @code{c64vector} and +@code{c128vector} types, and by providing analogues for almost all of +the heterogeneous vector procedures of +@url{https://srfi.schemers.org/srfi-133/srfi-133.html, SRFI 133}. There +are some additional procedures, most of which are closely analogous to +the string procedures of +@url{https://srfi.schemers.org/srfi-152/srfi-152.html, SRFI 152} + +Note that there are no conversions between homogeneous vectors and +strings in this SRFI. In addition, there is no support for u1vectors +(bitvectors) provided, not because they are not useful, but because they +are different enough in both specification and implementation to be put +into a future SRFI of their own. + +@node SRFI 160 Datatypes +@subsubsection SRFI 160 Datatypes + +There are eight datatypes of exact integer homogeneous vectors (which will +be called integer vectors): + +@deffn {Scheme Datatypes} s8vector + +Signed exact integer in the range -2@sup{7} to 2@sup{7}-1. +@end deffn + +@deffn {Scheme Datatypes} u8vector + +Unsigned exact integer in the range 0 to 2@sup{8}-1. +@end deffn + +@deffn {Scheme Datatypes} s16vector + +Signed exact integer in the range -2@sup{15} to 2@sup{15}-1. +@end deffn + +@deffn {Scheme Datatypes} u16vector + +Unsigned exact integer in the range 0 to 2@sup{16}-1. +@end deffn + +@deffn {Scheme Datatypes} s32vector + +Signed exact integer in the range -2@sup{31} to 2@sup{31}-1. +@end deffn + +@deffn {Scheme Datatypes} u32vector + +Unsigned exact integer in the range 0 to 2@sup{32}-1. +@end deffn + +@deffn {Scheme Datatypes} s64vector + +Signed exact integer in the range -2@sup{63} to 2@sup{63}-1. +@end deffn + +@deffn {Scheme Datatypes} u64vector + +Unsigned exact integer in the range 0 to 2@sup{64}-1. +@end deffn + +All are part of SRFI 4. + +There are two datatypes of inexact real homogeneous vectors (which will +be called float vectors): + +@deffn {Scheme Datatypes} f32vector + +Inexact real, typically 32 bits. +@end deffn + +@deffn {Scheme Datatypes} f64vector + +Inexact real, typically 64 bits. +@end deffn + +These are also part of SRFI 4. + +@code{f64vector}s must preserve at least as +much precision and range as @code{f32vector}s. + +And there are two datatypes of inexact complex homogeneous vectors +(which will be called complex vectors): + +@deffn {Scheme Datatypes} c64vector + +Inexact complex, typically 64 bits. +@end deffn + +@deffn {Scheme Datatypes} c128vector + +Inexact complex, typically 128 bits. +@end deffn + +These are @emph{not} part of SRFI 4. + +@code{c128vector}s must preserve at least as +much precision and range as @code{c64vector}s. + +Each element of a homogeneous vector must be @i{valid}. That is, for an +integer vector, it must be an exact integer within the inclusive range +specified above; for a float vector, it must be an inexact real number; +and for a complex vector, it must be an inexact complex number. It is +an error to try to use a constructor or mutator to set an element to an +invalid value. + +@node SRFI 160 Notation +@subsubsection SRFI 160 Notation + +So as not to multiply the number of procedures described in this SRFI +beyond necessity, a special notational convention is used. The +description of the procedure @code{make-@@vector} is really shorthand +for the descriptions of the twelve procedures @code{make-s8vector}, +@code{make-u8vector}, @dots{}, @code{make-c128vector}, all of which are +exactly the same except that they construct different homogeneous vector +types. Furthermore, except as otherwise noted, the semantics of each +procedure are those of the corresponding SRFI 133 procedure, except that +it is an error to attempt to insert an invalid value into a homogeneous +vector. Consequently, only a brief description of each procedure is +given, and SRFI 133 (or in some cases SRFI 152) should be consulted for +the details. It is worth mentioning, however, that all the procedures +that return one or more vectors (homogeneous or heterogeneous) +invariably return newly allocated vectors specifically. + +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{}) -> @var{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 +@var{something}. If two values are returned, two types are specified. +If @var{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} +Must be a heterogeneous vector, i.e. it must satisfy the predicate +@code{vector?} + +@item @var{@@vec}, @var{@@to}, @var{@@from} +Must be a homogeneous vector, i.e. it must satisfy the predicate +@code{@@vector?} In @code{@@vector-copy!} and +@code{reverse-@@vector-copy!}, @var{@@to} is the destination and +@var{@@from} is the source. + +@item @var{i}, @var{j}, @var{start}, @var{at} +Must be an exact nonnegative integer less than the length of the +@@vector. In @code{@@vector-copy!} and @code{reverse-@@vector-copy!}, +@var{at} refers to the destination and @var{start} to the source. + +@item @var{end} +Must be an exact nonnegative integer not less than @var{start} and not +greater than the length of the vector. 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} +Must be a procedure taking one or more arguments, which returns (except +as noted otherwise) exactly one value. + +@item @var{pred} +Must be a procedure taking one or more arguments that returns one value, +which is treated as a boolean. + +@item @var{=} +Must be an equivalence procedure. + +@item @var{obj}, @var{seed}, @var{nil} +Any Scheme object. + +@item @var{fill}, @var{value} +Any number that is valid with respect to the @var{@@vec}. + +@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 +[start [end]] +@end example + +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{} +At least one @var{something} must be arguments. +@end table + +@node SRFI 160 Packaging +@subsubsection SRFI 160 Packaging + +For each @@vector type, there is a corresponding library named +@code{(srfi@tie{}srfi-160@tie{}@@)}, and if an implementation provides a +given type, it must provide that library as well. In addition, the +library @code{(srfi@tie{}srfi-160@tie{}base)} provides a few basic +procedures for all @@vector types. If a particular type is not provided +by an implementation, then it is an error to call the corresponding +procedures in this library. + +@quotation note +There is no library named @code{(srfi@tie{}srfi-160)}. +@end quotation + +@node SRFI 160 Procedures +@subsubsection SRFI 160 Procedures + +The procedures shared with SRFI 4 are marked with [SRFI@tie{}4]. The +procedures with the same semantics as SRFI 133 are marked with +[SRFI@tie{}133] unless they are already marked with [SRFI@tie{}4]. The +procedures analogous to SRFI 152 string procedures are marked with +[SRFI@tie{}152]. + +@subsubheading Constructors + +@deffn {Scheme Procedure} make-@@vector size [fill] -> @@vector [SRFI@tie{}4] + +Returns a @@vector whose length is @var{size}. If @var{fill} is provided, +all the elements of the @@vector are initialized to it. +@end deffn + +@deffn {Scheme Procedure} @@vector value @dots{} -> @@vector [SRFI@tie{}4] + +Returns a @@vector initialized with @var{values}. +@end deffn + +@deffn {Scheme Procedure} @@vector-unfold f length seed -> @@vector [SRFI@tie{}133] + +Creates a vector whose length is @var{length} and iterates across each +index @var{k} between 0 and @var{length} - 1, applying @var{f} at each +iteration to the current index and current state, in that order, to +receive two values: the element to put in the @var{k}th slot of +the new vector and a new state for the next iteration. On the first +call to @var{f}, the state's value is @var{seed}. +@end deffn + +@deffn {Scheme Procedure} @@vector-unfold-right f length seed -> @@vector [SRFI@tie{}133] + +The same as @code{@@vector-unfold}, but initializes the @@vector from +right to left. +@end deffn + +@deffn {Scheme Procedure} @@vector-copy @@vec [start [end]] -> @@vector [SRFI@tie{}133] + +Makes a copy of the portion of @var{@@vec} from @var{start} to @var{end} +and returns it. +@end deffn + +@deffn {Scheme Procedure} @@vector-reverse-copy @@vec [start [end]] -> @@vector [SRFI@tie{}133] + +The same as @code{@@vector-copy}, but in reverse order. +@end deffn + +@deffn {Scheme Procedure} @@vector-append @@vec @dots{} -> @@vector [SRFI@tie{}133] + +Returns a @@vector containing all the elements of the @var{@@vecs} in +order. +@end deffn + +@deffn {Scheme Procedure} @@vector-concatenate list-of-@@vectors -> @@vector [SRFI@tie{}133] + +The same as @code{@@vector-append}, but takes a list of @@vectors rather +than multiple arguments. +@end deffn + +@deffn {Scheme Procedure} @@vector-append-subvectors [@@vec start end] @dots{} -> @@vector [SRFI@tie{}133] + +Concatenates the result of applying @code{@@vector-copy} to each triplet +of @var{@@vec}, @var{start}, @var{end} arguments, but may be implemented +more efficiently. +@end deffn + +@subsubheading Predicates + +@deffn {Scheme Procedure} @@? obj -> boolean + +Returns @code{#t} if @var{obj} is a valid element of an +@@vector, and @code{#f} otherwise. +@end deffn + +@deffn {Scheme Procedure} @@vector? obj -> boolean [SRFI@tie{}4] + +Returns @code{#t} if @var{obj} is a @@vector, and @code{#f} otherwise. +@end deffn + +@deffn {Scheme Procedure} @@vector-empty? @@vec -> boolean [SRFI@tie{}133] + +Returns @code{#t} if @var{@@vec} has a length of zero, and @code{#f} +otherwise. +@end deffn + +@deffn {Scheme Procedure} @@vector= @@vec @dots{} -> boolean [SRFI@tie{}133] + +Compares the @var{@@vecs} for elementwise equality, using @code{=} to do +the comparisons. Returns @code{#f} unless all @@vectors are the same +length. +@end deffn + +@subsubheading Selectors + +@deffn {Scheme Procedure} @@vector-ref @@vec i -> value [SRFI@tie{}4] + +Returns the @var{i}th element of @var{@@vec}. +@end deffn + +@deffn {Scheme Procedure} @@vector-length @@vec -> exact nonnegative integer [SRFI@tie{}4] + +Returns the length of @i{@@vec}. +@end deffn + +@subsubheading Iteration + +@deffn {Scheme Procedure} @@vector-take @@vec n -> @@vector [SRFI@tie{}152] +@deffnx {Scheme Procedure} @@vector-take-right @@vec n -> @@vector [SRFI@tie{}152] + +Returns a @@vector containing the first/last @var{n} elements of +@var{@@vec}. +@end deffn + +@deffn {Scheme Procedure} @@vector-drop @@vec n -> @@vector [SRFI@tie{}152] +@deffnx {Scheme Procedure} @@vector-drop-right @@vec n -> @@vector [SRFI@tie{}152] + +Returns a @@vector containing all except the first/last @var{n} elements +of @var{@@vec}. +@end deffn + +@deffn {Scheme Procedure} @@vector-segment @@vec n -> list [SRFI@tie{}152] + +Returns a list of @@vectors, each of which contains @var{n} consecutive +elements of @var{@@vec}. The last @@vector may be shorter than @var{n}. +It is an error if @var{n} is not an exact positive integer. +@end deffn + +@deffn {Scheme Procedure} @@vector-fold kons knil @@vec @@vec2 @dots{} -> object [SRFI@tie{}133] +@deffnx {Scheme Procedure} @@vector-fold-right kons knil @@vec @@vec2 @dots{} -> object [SRFI@tie{}133] + +When one @@vector argument @var{@@vec} is given, folds @var{kons} over the +elements of @var{@@vec} in increasing/decreasing order using @var{knil} as +the initial value. The @var{kons} procedure is called with the state +first and the element second, as in SRFIs 43 and 133 (heterogeneous +vectors). This is the opposite order to that used in SRFI 1 (lists) and +the various string SRFIs. + +When multiple @@vector arguments are given, @var{kons} is called with +the current state value and each value from all the vectors; +@code{@@vector-fold} scans elements from left to right, while +@code{@@vector-fold-right} does from right to left. If the lengths of +vectors differ, only the portion of each vector up to the length of the +shortest vector is scanned. +@end deffn + +@deffn {Scheme Procedure} @@vector-map f @@vec @@vec2 @dots{} -> @@vector [SRFI@tie{}133] +@deffnx {Scheme Procedure} @@vector-map! f @@vec @@vec2 @dots{} -> unspecified [SRFI@tie{}133] +@deffnx {Scheme Procedure} @@vector-for-each f @@vec @@vec2 @dots{} -> unspecified [SRFI@tie{}133] + +Iterate over the elements of @var{@@vec} and apply @var{f} to each, +returning respectively a @@vector of the results, an undefined value +with the results placed back in @var{@@vec}, and an undefined value with +no change to @var{@@vec}. + +If more than one vector is passed, @var{f} gets one element from each +vector as arguments. If the lengths of the vectors differ, iteration +stops at the end of the shortest vector. For @code{@@vector-map!}, only +@var{@@vec} is modified even when multiple vectors are passed. + +If @code{@@vector-map} or @code{@@vector-map!} returns more than once +(i.e. because of a continuation captured by @var{f}), the values +returned or stored by earlier returns may be mutated. + +@end deffn + +@deffn {Scheme Procedure} @@vector-count pred? @@vec @@vec2 @dots{} -> exact nonnegative integer [SRFI@tie{}133] + +Call @var{pred?} on each element of @var{@@vec} and return the number of +calls that return true. + +When multiple vectors are given, @var{pred?} must take +the same number of arguments as the number of vectors, and +corresponding elements from each vector are given for each iteration, +which stops at the end of the shortest vector. + +@end deffn + + +@deffn {Scheme Procedure} @@vector-cumulate f knil @@vec -> @@vector [SRFI@tie{}133] + +Like @code{@@vector-fold}, but returns a @@vector of partial results +rather than just the final result. +@end deffn + +@subsubheading Searching + +@deffn {Scheme Procedure} @@vector-take-while pred? @@vec -> @@vector [SRFI@tie{}152] +@deffnx {Scheme Procedure} @@vector-take-while-right pred? @@vec -> @@vector [SRFI@tie{}152] + +Return the shortest prefix/suffix of @var{@@vec} all of whose elements +satisfy @var{pred?}. +@end deffn + +@deffn {Scheme Procedure} @@vector-drop-while pred? @@vec -> @@vector [SRFI@tie{}152] +@deffnx {Scheme Procedure} @@vector-drop-while-right pred? @@vec -> @@vector [SRFI@tie{}152] + +Drops the longest initial prefix/suffix of @var{@@vec} such that all its +elements satisfy @var{pred}. +@end deffn + +@deffn {Scheme Procedure} @@vector-index pred? @@vec @@vec2 @dots{} -> exact nonnegative integer or #f [SRFI@tie{}133] +@deffnx {Scheme Procedure} @@vector-index-right pred? @@vec @@vec2 @dots{} -> exact nonnegative integer or #f [SRFI@tie{}133] + +Return the index of the first/last element of @var{@@vec} that satisfies +@var{pred?}. + +When multiple vectors are passed, @var{pred?} must take the same number of +arguments as the number of vectors, and corresponding elements from each +vector are passed for each iteration. If the lengths of vectors differ, +@code{@@vector-index} stops iteration at the end of the shortest one. +Lengths of vectors must be the same for @code{@@vector-index-right} +@end deffn + +@deffn {Scheme Procedure} @@vector-skip pred? @@vec @@vec2 @dots{} -> exact nonnegative integer or #f [SRFI@tie{}133] +@deffnx {Scheme Procedure} @@vector-skip-right pred? @@vec @@vec2 @dots{} -> exact nonnegative integer or #f [SRFI@tie{}133] + +Returns the index of the first/last element of @var{@@vec} that does not +satisfy @var{pred?}. + +When multiple vectors are passed, @var{pred?} must take the same number +of arguments as the number of vectors, and corresponding elements from +each vector are passed for each iteration. If the lengths of vectors +differ, @code{@@vector-skip} stops iteration at the end of the shortest +one. Lengths of vectors must be the same for @code{@@vector-skip-right} +@end deffn + +@deffn {Scheme Procedure} @@vector-any pred? @@vec @@vec2 @dots{} -> value or boolean [SRFI@tie{}133] + +Returns first non-false result of applying @var{pred?} on a element from +the @var{@@vec}, or @code{#f} if there is no such element. If +@var{@@vec} is empty, returns @code{#t}. + +When multiple vectors are passed, @var{pred?} must take the same number +of arguments as the number of vectors, and corresponding elements from +each vector are passed for each iteration. If the lengths of vectors +differ, it stops at the end of the shortest one. +@end deffn + +@deffn {Scheme Procedure} @@vector-every pred? @@vec @@vec2 @dots{} -> value or boolean [SRFI@tie{}133] + +If all elements from @var{@@vec} satisfy @var{pred?}, return the last +result of @var{pred?}. If not all do, return @code{#f} If @var{@@vec} +is empty, return @code{#t}. + +When multiple vectors are passed, @var{pred?} must take the same number +of arguments as the number of vectors, and corresponding elements from +each vector is passed for each iteration. If the lengths of vectors +differ, it stops at the end of the shortest one. +@end deffn + +@deffn {Scheme Procedure} @@vector-partition pred? @@vec -> @@vector and integer [SRFI@tie{}133] + +Returns a @@vector of the same type as @var{@@vec}, but with all +elements satisfying @var{pred?} in the leftmost part of the vector and +the other elements in the remaining part. The order of elements is +otherwise preserved. Returns two values, the new @@vector and the +number of elements satisfying @var{pred?}. +@end deffn + +@deffn {Scheme Procedure} @@vector-filter pred? @@vec -> @@vector [SRFI@tie{}152] +@deffnx {Scheme Procedure} @@vector-remove pred? @@vec -> @@vector [SRFI@tie{}152] + +Return an @@vector containing the elements of @@vec that satisfy / do +not satisfy @var{pred?}. +@end deffn + +@subsubheading Mutators + +@deffn {Scheme Procedure} @@vector-set! @@vec i value -> unspecified [SRFI@tie{}4] + +Sets the @var{i}th element of @var{@@vec} to @var{value}. +@end deffn + +@deffn {Scheme Procedure} @@vector-swap! @@vec i j -> unspecified [SRFI@tie{}133] + +Interchanges the @var{i}th and @var{j}th elements of @var{@@vec}. +@end deffn + +@deffn {Scheme Procedure} @@vector-fill! @@vec fill [start [end]] -> unspecified [SRFI@tie{}133] + +Fills the portion of @var{@@vec} from @var{start} to @var{end} with the +value @var{fill}. +@end deffn + +@deffn {Scheme Procedure} @@vector-reverse! @@vec [start [end]] -> unspecified [SRFI@tie{}133] + +Reverses the portion of @var{@@vec} from @var{start} to @var{end}. +@end deffn + +@deffn {Scheme Procedure} @@vector-copy! @@to at @@from [start [end]] -> unspecified [SRFI@tie{}133] + +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} @@vector-reverse-copy! @@to at @@from [start [end]] -> unspecified [SRFI@tie{}133] + +The same as @code{@@vector-copy!}, but copies in reverse. +@end deffn + +@deffn {Scheme Procedure} @@vector-unfold! f @@vec start end seed -> @@vector [SRFI@tie{}133] + +Like @code{vector-unfold}, but the elements are copied into the vector +@var{@@vec} starting at element @var{start} rather than into a newly +allocated vector. Terminates when @var{end} - @var{start} elements have +been generated. +@end deffn + +@deffn {Scheme Procedure} @@vector-unfold-right! f @@vec start end seed -> @@vector [SRFI@tie{}133] + +The same as @code{@@vector-unfold!}, but initializes the @@vector from +right to left. +@end deffn + +@subsubheading Conversion + +@deffn {Scheme Procedure} @@vector->list @@vec [start [end]] -> proper-list [SRFI@tie{}4 plus start and end] +@deffnx {Scheme Procedure} reverse-@@vector->list @@vec [start [end]] -> proper-list [SRFI@tie{}133] +@deffnx {Scheme Procedure} list->@@vector proper-list -> @@vector +@deffnx {Scheme Procedure} reverse-list->@@vector proper-list -> @@vector [SRFI@tie{}133] +@deffnx {Scheme Procedure} @@vector->vector @@vec [start [end]] -> vector +@deffnx {Scheme Procedure} vector->@@vector vec [start [end]] -> @@vector + +Returns a list, @@vector, or heterogeneous vector with the same elements +as the argument, in reverse order where specified. +@end deffn + +@subsubheading Generators + +@deffn {Scheme Procedure} make-@@vector-generator @@vector + +Returns a @url{https://srfi.schemers.org/srfi-121/srfi-121.html, SRFI +121} generator that generates all the values of @emph{@@vector} in order. +Note that the generator is finite. +@end deffn + +@subsubheading Comparators + +@deffn {Scheme Variable} @@vector-comparator + +Variable containing a +@url{https://srfi.schemers.org/srfi-128/srfi-128.html, SRFI 128} +comparator whose components provide ordering and hashing of @@vectors. +@end deffn + +@subsubheading Output + +@deffn {Scheme Procedure} write-@@vector @@vec [port] -> unspecified + +Prints to @var{port} (the current output port by default) a representation of +@var{@@vec} in the lexical syntax explained below. +@end deffn + +@node SRFI 160 Optional lexical syntax +@subsubsection SRFI 160 Optional lexical syntax + +Each homogeneous vector datatype has an external representation which +may be supported by the @code{read} and @code{write} procedures and by +the program parser. Conformance to this SRFI does not in itself require +support for these external representations. + +For each value of @code{@@} in @math{{s8, u8, s16, u16, s32, u32, s64, +u64, f32, f64, c64, c128}}, if the datatype @code{@@vector} is +supported, then the external representation of instances of the datatype +@code{@@vector} is @code{#@@(elements @dots{})}. + +@noindent +For example, @code{#u8(0 #e1e2 #xff)} is a @code{u8vector} of length 3 +containing 0, 100 and 255; @code{#f64(-1.5)} is an @code{f64vector} of +length 1 containing -1.5. + +@quotation note +The syntax for float vectors conflicts with R5RS, which parses +@code{#f32()} as 3 objects: @code{#f}, @code{32} and @code{()}. For +this reason, conformance to this SRFI implies this minor non-conformance +to R5RS. +@end quotation + +This external representation is also available in program source code. +For example, @samp{(set! x '#u8(1 2 3))} will set @code{x} to the object +@code{#u8(1 2 3)}. Literal homogeneous vectors, like heterogeneous +vectors, are self-evaluating; they do not need to be quoted. +Homogeneous vectors can appear in quasiquotations but must not contain +@code{unquote} or @code{unquote-splicing} forms (i.e. @samp{`(,x #u8(1 +2))} is legal but @samp{`#u8(1 ,x 2)} is not). This restriction is to +accommodate the many Scheme systems that use the @code{read} procedure +to parse programs. + @node SRFI-171 @subsection Transducers @cindex SRFI-171 diff --git a/module/srfi/srfi-160/base.sld b/module/srfi/srfi-160/base.sld new file mode 100644 index 000000000..3f9d69855 --- /dev/null +++ b/module/srfi/srfi-160/base.sld @@ -0,0 +1,68 @@ +;;; SPDX-FileCopyrightText: 2018 John Cowan +;;; +;;; SPDX-License-Identifier: MIT + +(define-library (srfi srfi-160 base) + (import (scheme base)) + (import (scheme case-lambda)) + (import (scheme complex)) + (import (only (srfi srfi-151) + bitwise-and bitwise-ior + bitwise-not arithmetic-shift)) + ;; SRFI 4 versions of @vector->list don't accept start/end args + (import (except (srfi srfi-4) + u8vector->list s8vector->list u16vector->list s16vector->list + u32vector->list s32vector->list u64vector->list s64vector->list + f32vector->list f64vector->list)) + + (export + make-u8vector make-s8vector make-u16vector make-s16vector + make-u32vector make-s32vector make-u64vector make-s64vector + make-f32vector make-f64vector make-c64vector make-c128vector ) + (export + u8vector s8vector u16vector s16vector + u32vector s32vector u64vector s64vector + f32vector f64vector c64vector c128vector ) + (export + u8vector? s8vector? u16vector? s16vector? + u32vector? s32vector? u64vector? s64vector? + f32vector? f64vector? c64vector? c128vector?) + (export + u8vector-length s8vector-length u16vector-length s16vector-length + u32vector-length s32vector-length u64vector-length s64vector-length + f32vector-length f64vector-length c64vector-length c128vector-length) + (export + u8vector-ref s8vector-ref u16vector-ref s16vector-ref + u32vector-ref s32vector-ref u64vector-ref s64vector-ref + f32vector-ref f64vector-ref c64vector-ref c128vector-ref) + (export + u8vector-set! s8vector-set! u16vector-set! s16vector-set! + u32vector-set! s32vector-set! u64vector-set! s64vector-set! + f32vector-set! f64vector-set! c64vector-set! c128vector-set!) + (export + u8vector->list s8vector->list u16vector->list s16vector->list + u32vector->list s32vector->list u64vector->list s64vector->list + f32vector->list f64vector->list c64vector->list c128vector->list) + (export + list->u8vector list->s8vector list->u16vector list->s16vector + list->u32vector list->s32vector list->u64vector list->s64vector + list->f32vector list->f64vector list->c64vector list->c128vector) + (export + u8? s8? u16? s16? u32? s32? u64? s64? f32? f64? c64? c128?) + + (include "base/r7rec.scm") + (include "base/complex.scm") + (include "base/u8-vector2list.scm") + (include "base/s8-vector2list.scm") + (include "base/u16-vector2list.scm") + (include "base/s16-vector2list.scm") + (include "base/u32-vector2list.scm") + (include "base/s32-vector2list.scm") + (include "base/u64-vector2list.scm") + (include "base/s64-vector2list.scm") + (include "base/f32-vector2list.scm") + (include "base/f64-vector2list.scm") + (include "base/c64-vector2list.scm") + (include "base/c128-vector2list.scm") + (include "base/valid.scm") +) diff --git a/module/srfi/srfi-160/base/c128-vector2list.scm b/module/srfi/srfi-160/base/c128-vector2list.scm new file mode 100644 index 000000000..32bfe8e20 --- /dev/null +++ b/module/srfi/srfi-160/base/c128-vector2list.scm @@ -0,0 +1,19 @@ +;;; SPDX-FileCopyrightText: 2018 John Cowan +;;; +;;; SPDX-License-Identifier: MIT + +;;;; Implementation of SRFI 160 base c128vector->list + +(define c128vector->list + (case-lambda + ((vec) (c128vector->list* vec 0 (c128vector-length vec))) + ((vec start) (c128vector->list* vec start (c128vector-length vec))) + ((vec start end) (c128vector->list* vec start end)))) + +(define (c128vector->list* vec start end) + (let loop ((i (- end 1)) + (list '())) + (if (< i start) + list + (loop (- i 1) (cons (c128vector-ref vec i) list))))) + diff --git a/module/srfi/srfi-160/base/c64-vector2list.scm b/module/srfi/srfi-160/base/c64-vector2list.scm new file mode 100644 index 000000000..44f7a2901 --- /dev/null +++ b/module/srfi/srfi-160/base/c64-vector2list.scm @@ -0,0 +1,19 @@ +;;; SPDX-FileCopyrightText: 2018 John Cowan +;;; +;;; SPDX-License-Identifier: MIT + +;;;; Implementation of SRFI 160 base c64vector->list + +(define c64vector->list + (case-lambda + ((vec) (c64vector->list* vec 0 (c64vector-length vec))) + ((vec start) (c64vector->list* vec start (c64vector-length vec))) + ((vec start end) (c64vector->list* vec start end)))) + +(define (c64vector->list* vec start end) + (let loop ((i (- end 1)) + (list '())) + (if (< i start) + list + (loop (- i 1) (cons (c64vector-ref vec i) list))))) + diff --git a/module/srfi/srfi-160/base/complex.scm b/module/srfi/srfi-160/base/complex.scm new file mode 100644 index 000000000..ec2b40fc6 --- /dev/null +++ b/module/srfi/srfi-160/base/complex.scm @@ -0,0 +1,112 @@ +;;; SPDX-FileCopyrightText: 2018 John Cowan +;;; +;;; SPDX-License-Identifier: MIT + +;;;; Implementation of SRFI 160 base c64vectors and c128vectors + +;;; Main constructor + +(define (make-c64vector len . maybe-fill) + (define vec (raw-make-c64vector (make-f32vector (* len 2)))) + (if (not (null? maybe-fill)) + (c64vector-simple-fill! vec (car maybe-fill))) + vec) + +(define (make-c128vector len . maybe-fill) + (define vec (raw-make-c128vector (make-f64vector (* len 2)))) + (if (not (null? maybe-fill)) + (c128vector-simple-fill! vec (car maybe-fill))) + vec) + +;; Simple fill! (not exported) + +(define (c64vector-simple-fill! vec value) + (define len (c64vector-length vec)) + (let loop ((i 0)) + (if (= i len) + vec + (begin + (c64vector-set! vec i value) + (loop (+ i 1)))))) + +(define (c128vector-simple-fill! vec value) + (define len (c128vector-length vec)) + (let loop ((i 0)) + (if (= i len) + vec + (begin + (c128vector-set! vec i value) + (loop (+ i 1)))))) + +;;; Variable-argument constructor + +(define (c64vector . list) + (list->c64vector list)) + +(define (c128vector . list) + (list->c128vector list)) + +;; Predicate already defined + +;; Length + +(define (c64vector-length vec) + (/ (f32vector-length (bv64 vec)) 2)) + +(define (c128vector-length vec) + (/ (f64vector-length (bv128 vec)) 2)) + +;; Get element + +(define (c64vector-ref vec i) + (let ((fvec (bv64 vec)) + (j (* i 2))) + (make-rectangular + (f32vector-ref fvec j) + (f32vector-ref fvec (+ j 1))))) + +(define (c128vector-ref vec i) + (let ((fvec (bv128 vec)) + (j (* i 2))) + (make-rectangular + (f64vector-ref fvec j) + (f64vector-ref fvec (+ j 1))))) + +;; Set element + +(define (c64vector-set! vec i value) + (let ((fvec (bv64 vec)) + (j (* i 2))) + (f32vector-set! fvec j (real-part value)) + (f32vector-set! fvec (+ j 1) (imag-part value)))) + +(define (c128vector-set! vec i value) + (let ((fvec (bv128 vec)) + (j (* i 2))) + (f64vector-set! fvec j (real-part value)) + (f64vector-set! fvec (+ j 1) (imag-part value)))) + +;; List to vec + +(define (list->c64vector list) + (define len (length list)) + (define vec (make-c64vector len)) + (let loop ((i 0) (list list)) + (if (= i len) + vec + (begin + (c64vector-set! vec i (car list)) + (loop (+ i 1) (cdr list)))))) + +(define (list->c128vector list) + (define len (length list)) + (define vec (make-c128vector len)) + (let loop ((i 0) (list list)) + (if (= i len) + vec + (begin + (c128vector-set! vec i (car list)) + (loop (+ i 1) (cdr list)))))) + +;; Vec to list defined in at-vector2list + diff --git a/module/srfi/srfi-160/base/f32-vector2list.scm b/module/srfi/srfi-160/base/f32-vector2list.scm new file mode 100644 index 000000000..0888175a6 --- /dev/null +++ b/module/srfi/srfi-160/base/f32-vector2list.scm @@ -0,0 +1,19 @@ +;;; SPDX-FileCopyrightText: 2018 John Cowan +;;; +;;; SPDX-License-Identifier: MIT + +;;;; Implementation of SRFI 160 base f32vector->list + +(define f32vector->list + (case-lambda + ((vec) (f32vector->list* vec 0 (f32vector-length vec))) + ((vec start) (f32vector->list* vec start (f32vector-length vec))) + ((vec start end) (f32vector->list* vec start end)))) + +(define (f32vector->list* vec start end) + (let loop ((i (- end 1)) + (list '())) + (if (< i start) + list + (loop (- i 1) (cons (f32vector-ref vec i) list))))) + diff --git a/module/srfi/srfi-160/base/f64-vector2list.scm b/module/srfi/srfi-160/base/f64-vector2list.scm new file mode 100644 index 000000000..676f2bfb8 --- /dev/null +++ b/module/srfi/srfi-160/base/f64-vector2list.scm @@ -0,0 +1,19 @@ +;;; SPDX-FileCopyrightText: 2018 John Cowan +;;; +;;; SPDX-License-Identifier: MIT + +;;;; Implementation of SRFI 160 base f64vector->list + +(define f64vector->list + (case-lambda + ((vec) (f64vector->list* vec 0 (f64vector-length vec))) + ((vec start) (f64vector->list* vec start (f64vector-length vec))) + ((vec start end) (f64vector->list* vec start end)))) + +(define (f64vector->list* vec start end) + (let loop ((i (- end 1)) + (list '())) + (if (< i start) + list + (loop (- i 1) (cons (f64vector-ref vec i) list))))) + diff --git a/module/srfi/srfi-160/base/r7rec.scm b/module/srfi/srfi-160/base/r7rec.scm new file mode 100644 index 000000000..0779113ff --- /dev/null +++ b/module/srfi/srfi-160/base/r7rec.scm @@ -0,0 +1,12 @@ +;;; SPDX-FileCopyrightText: 2018 John Cowan +;;; +;;; SPDX-License-Identifier: MIT + +;; The representation of complex vectors + +(define-record-type (raw-make-c64vector bv) c64vector? + (bv bv64)) + +(define-record-type (raw-make-c128vector bv) c128vector? + (bv bv128)) + diff --git a/module/srfi/srfi-160/base/s16-vector2list.scm b/module/srfi/srfi-160/base/s16-vector2list.scm new file mode 100644 index 000000000..320f32321 --- /dev/null +++ b/module/srfi/srfi-160/base/s16-vector2list.scm @@ -0,0 +1,19 @@ +;;; SPDX-FileCopyrightText: 2018 John Cowan +;;; +;;; SPDX-License-Identifier: MIT + +;;;; Implementation of SRFI 160 base s16vector->list + +(define s16vector->list + (case-lambda + ((vec) (s16vector->list* vec 0 (s16vector-length vec))) + ((vec start) (s16vector->list* vec start (s16vector-length vec))) + ((vec start end) (s16vector->list* vec start end)))) + +(define (s16vector->list* vec start end) + (let loop ((i (- end 1)) + (list '())) + (if (< i start) + list + (loop (- i 1) (cons (s16vector-ref vec i) list))))) + diff --git a/module/srfi/srfi-160/base/s32-vector2list.scm b/module/srfi/srfi-160/base/s32-vector2list.scm new file mode 100644 index 000000000..1b7ef1b6e --- /dev/null +++ b/module/srfi/srfi-160/base/s32-vector2list.scm @@ -0,0 +1,19 @@ +;;; SPDX-FileCopyrightText: 2018 John Cowan +;;; +;;; SPDX-License-Identifier: MIT + +;;;; Implementation of SRFI 160 base s32vector->list + +(define s32vector->list + (case-lambda + ((vec) (s32vector->list* vec 0 (s32vector-length vec))) + ((vec start) (s32vector->list* vec start (s32vector-length vec))) + ((vec start end) (s32vector->list* vec start end)))) + +(define (s32vector->list* vec start end) + (let loop ((i (- end 1)) + (list '())) + (if (< i start) + list + (loop (- i 1) (cons (s32vector-ref vec i) list))))) + diff --git a/module/srfi/srfi-160/base/s64-vector2list.scm b/module/srfi/srfi-160/base/s64-vector2list.scm new file mode 100644 index 000000000..6485241c1 --- /dev/null +++ b/module/srfi/srfi-160/base/s64-vector2list.scm @@ -0,0 +1,19 @@ +;;; SPDX-FileCopyrightText: 2018 John Cowan +;;; +;;; SPDX-License-Identifier: MIT + +;;;; Implementation of SRFI 160 base s64vector->list + +(define s64vector->list + (case-lambda + ((vec) (s64vector->list* vec 0 (s64vector-length vec))) + ((vec start) (s64vector->list* vec start (s64vector-length vec))) + ((vec start end) (s64vector->list* vec start end)))) + +(define (s64vector->list* vec start end) + (let loop ((i (- end 1)) + (list '())) + (if (< i start) + list + (loop (- i 1) (cons (s64vector-ref vec i) list))))) + diff --git a/module/srfi/srfi-160/base/s8-vector2list.scm b/module/srfi/srfi-160/base/s8-vector2list.scm new file mode 100644 index 000000000..7df41eea7 --- /dev/null +++ b/module/srfi/srfi-160/base/s8-vector2list.scm @@ -0,0 +1,19 @@ +;;; SPDX-FileCopyrightText: 2018 John Cowan +;;; +;;; SPDX-License-Identifier: MIT + +;;;; Implementation of SRFI 160 base s8vector->list + +(define s8vector->list + (case-lambda + ((vec) (s8vector->list* vec 0 (s8vector-length vec))) + ((vec start) (s8vector->list* vec start (s8vector-length vec))) + ((vec start end) (s8vector->list* vec start end)))) + +(define (s8vector->list* vec start end) + (let loop ((i (- end 1)) + (list '())) + (if (< i start) + list + (loop (- i 1) (cons (s8vector-ref vec i) list))))) + diff --git a/module/srfi/srfi-160/base/u16-vector2list.scm b/module/srfi/srfi-160/base/u16-vector2list.scm new file mode 100644 index 000000000..2a725f7d4 --- /dev/null +++ b/module/srfi/srfi-160/base/u16-vector2list.scm @@ -0,0 +1,19 @@ +;;; SPDX-FileCopyrightText: 2018 John Cowan +;;; +;;; SPDX-License-Identifier: MIT + +;;;; Implementation of SRFI 160 base u16vector->list + +(define u16vector->list + (case-lambda + ((vec) (u16vector->list* vec 0 (u16vector-length vec))) + ((vec start) (u16vector->list* vec start (u16vector-length vec))) + ((vec start end) (u16vector->list* vec start end)))) + +(define (u16vector->list* vec start end) + (let loop ((i (- end 1)) + (list '())) + (if (< i start) + list + (loop (- i 1) (cons (u16vector-ref vec i) list))))) + diff --git a/module/srfi/srfi-160/base/u32-vector2list.scm b/module/srfi/srfi-160/base/u32-vector2list.scm new file mode 100644 index 000000000..87427eb32 --- /dev/null +++ b/module/srfi/srfi-160/base/u32-vector2list.scm @@ -0,0 +1,19 @@ +;;; SPDX-FileCopyrightText: 2018 John Cowan +;;; +;;; SPDX-License-Identifier: MIT + +;;;; Implementation of SRFI 160 base u32vector->list + +(define u32vector->list + (case-lambda + ((vec) (u32vector->list* vec 0 (u32vector-length vec))) + ((vec start) (u32vector->list* vec start (u32vector-length vec))) + ((vec start end) (u32vector->list* vec start end)))) + +(define (u32vector->list* vec start end) + (let loop ((i (- end 1)) + (list '())) + (if (< i start) + list + (loop (- i 1) (cons (u32vector-ref vec i) list))))) + diff --git a/module/srfi/srfi-160/base/u64-vector2list.scm b/module/srfi/srfi-160/base/u64-vector2list.scm new file mode 100644 index 000000000..59575eb3e --- /dev/null +++ b/module/srfi/srfi-160/base/u64-vector2list.scm @@ -0,0 +1,19 @@ +;;; SPDX-FileCopyrightText: 2018 John Cowan +;;; +;;; SPDX-License-Identifier: MIT + +;;;; Implementation of SRFI 160 base u64vector->list + +(define u64vector->list + (case-lambda + ((vec) (u64vector->list* vec 0 (u64vector-length vec))) + ((vec start) (u64vector->list* vec start (u64vector-length vec))) + ((vec start end) (u64vector->list* vec start end)))) + +(define (u64vector->list* vec start end) + (let loop ((i (- end 1)) + (list '())) + (if (< i start) + list + (loop (- i 1) (cons (u64vector-ref vec i) list))))) + diff --git a/module/srfi/srfi-160/base/u8-vector2list.scm b/module/srfi/srfi-160/base/u8-vector2list.scm new file mode 100644 index 000000000..a1ba5ccbc --- /dev/null +++ b/module/srfi/srfi-160/base/u8-vector2list.scm @@ -0,0 +1,19 @@ +;;; SPDX-FileCopyrightText: 2018 John Cowan +;;; +;;; SPDX-License-Identifier: MIT + +;;;; Implementation of SRFI 160 base u8vector->list + +(define u8vector->list + (case-lambda + ((vec) (u8vector->list* vec 0 (u8vector-length vec))) + ((vec start) (u8vector->list* vec start (u8vector-length vec))) + ((vec start end) (u8vector->list* vec start end)))) + +(define (u8vector->list* vec start end) + (let loop ((i (- end 1)) + (list '())) + (if (< i start) + list + (loop (- i 1) (cons (u8vector-ref vec i) list))))) + diff --git a/module/srfi/srfi-160/base/valid.scm b/module/srfi/srfi-160/base/valid.scm new file mode 100644 index 000000000..2a77973c2 --- /dev/null +++ b/module/srfi/srfi-160/base/valid.scm @@ -0,0 +1,27 @@ +;;; SPDX-FileCopyrightText: 2018 John Cowan +;;; +;;; SPDX-License-Identifier: MIT + +(define (u8? n) (and (exact-integer? n) (<= 0 n 255))) + +(define (s8? n) (and (exact-integer? n) (<= -128 n 127))) + +(define (u16? n) (and (exact-integer? n) (<= 0 n 65535))) + +(define (s16? n) (and (exact-integer? n) (<= -32768 n 32767))) + +(define (u32? n) (and (exact-integer? n) (<= 0 n 4294967295))) + +(define (s32? n) (and (exact-integer? n) (<= -2147483648 n 2147483647))) + +(define (u64? n) (and (exact-integer? n) (<= 0 n 18446744073709551615))) + +(define (s64? n) (and (exact-integer? n) (<= -9223372036854775808 n 9223372036854775807))) + +(define (f32? n) (and (inexact? n) (real? n))) + +(define (f64? n) (f32? n)) + +(define (c64? n) (inexact? n)) + +(define (c128? n) (inexact? n)) diff --git a/module/srfi/srfi-160/c128-impl.scm b/module/srfi/srfi-160/c128-impl.scm new file mode 100644 index 000000000..9db7882e7 --- /dev/null +++ b/module/srfi/srfi-160/c128-impl.scm @@ -0,0 +1,601 @@ +;;; SPDX-FileCopyrightText: 2018 John Cowan +;;; +;;; SPDX-License-Identifier: MIT + +;;; This code is the same for all SRFI 160 vector sizes. +;;; The c128s appearing in the code are expanded to u8, s8, etc. + +;; make-c128vector defined in (srfi 160 base) + +;; c128vector defined in (srfi 160 base) + +(define (c128vector-unfold f len seed) + (let ((v (make-c128vector len))) + (let loop ((i 0) (state seed)) + (unless (= i len) + (let-values (((value newstate) (f i state))) + (c128vector-set! v i value) + (loop (+ i 1) newstate)))) + v)) + +(define (c128vector-unfold-right f len seed) + (let ((v (make-c128vector len))) + (let loop ((i (- len 1)) (state seed)) + (unless (= i -1) + (let-values (((value newstate) (f i state))) + (c128vector-set! v i value) + (loop (- i 1) newstate)))) + v)) + +(define c128vector-copy + (case-lambda + ((vec) (c128vector-copy* vec 0 (c128vector-length vec))) + ((vec start) (c128vector-copy* vec start (c128vector-length vec))) + ((vec start end) (c128vector-copy* vec start end)))) + +(define (c128vector-copy* vec start end) + (let ((v (make-c128vector (- end start)))) + (c128vector-copy! v 0 vec start end) + v)) + +(define c128vector-copy! + (case-lambda + ((to at from) + (c128vector-copy!* to at from 0 (c128vector-length from))) + ((to at from start) + (c128vector-copy!* to at from start (c128vector-length from))) + ((to at from start end) (c128vector-copy!* to at from start end)))) + +(define (c128vector-copy!* to at from start end) + (let loop ((at at) (i start)) + (unless (= i end) + (c128vector-set! to at (c128vector-ref from i)) + (loop (+ at 1) (+ i 1))))) + +(define c128vector-reverse-copy + (case-lambda + ((vec) (c128vector-reverse-copy* vec 0 (c128vector-length vec))) + ((vec start) (c128vector-reverse-copy* vec start (c128vector-length vec))) + ((vec start end) (c128vector-reverse-copy* vec start end)))) + +(define (c128vector-reverse-copy* vec start end) + (let ((v (make-c128vector (- end start)))) + (c128vector-reverse-copy! v 0 vec start end) + v)) + +(define c128vector-reverse-copy! + (case-lambda + ((to at from) + (c128vector-reverse-copy!* to at from 0 (c128vector-length from))) + ((to at from start) + (c128vector-reverse-copy!* to at from start (c128vector-length from))) + ((to at from start end) (c128vector-reverse-copy!* to at from start end)))) + +(define (c128vector-reverse-copy!* to at from start end) + (let loop ((at at) (i (- end 1))) + (unless (< i start) + (c128vector-set! to at (c128vector-ref from i)) + (loop (+ at 1) (- i 1))))) + +(define (c128vector-append . vecs) + (c128vector-concatenate vecs)) + +(define (c128vector-concatenate vecs) + (let ((v (make-c128vector (len-sum vecs)))) + (let loop ((vecs vecs) (at 0)) + (unless (null? vecs) + (let ((vec (car vecs))) + (c128vector-copy! v at vec 0 (c128vector-length vec)) + (loop (cdr vecs) (+ at (c128vector-length vec))))) + v))) + +(define (len-sum vecs) + (if (null? vecs) + 0 + (+ (c128vector-length (car vecs)) + (len-sum (cdr vecs))))) + +(define (c128vector-append-subvectors . args) + (let ((v (make-c128vector (len-subsum args)))) + (let loop ((args args) (at 0)) + (unless (null? args) + (let ((vec (car args)) + (start (cadr args)) + (end (caddr args))) + (c128vector-copy! v at vec start end) + (loop (cdddr args) (+ at (- end start)))))) + v)) + +(define (len-subsum vecs) + (if (null? vecs) + 0 + (+ (- (caddr vecs) (cadr vecs)) + (len-subsum (cdddr vecs))))) + +;; c128? defined in (srfi 160 base) + +;; c128vector? defined in (srfi 160 base) + +(define (c128vector-empty? vec) + (zero? (c128vector-length vec))) + +(define (c128vector= . vecs) + (c128vector=* (car vecs) (cadr vecs) (cddr vecs))) + +(define (c128vector=* vec1 vec2 vecs) + (and (c128dyadic-vecs= vec1 0 (c128vector-length vec1) + vec2 0 (c128vector-length vec2)) + (or (null? vecs) + (c128vector=* vec2 (car vecs) (cdr vecs))))) + +(define (c128dyadic-vecs= vec1 start1 end1 vec2 start2 end2) + (cond + ((not (= end1 end2)) #f) + ((not (< start1 end1)) #t) + ((let ((elt1 (c128vector-ref vec1 start1)) + (elt2 (c128vector-ref vec2 start2))) + (= elt1 elt2)) + (c128dyadic-vecs= vec1 (+ start1 1) end1 + vec2 (+ start2 1) end2)) + (else #f))) + +;; c128vector-ref defined in (srfi 160 base) + +;; c128vector-length defined in (srfi 160 base) + +(define (c128vector-take vec n) + (let ((v (make-c128vector n))) + (c128vector-copy! v 0 vec 0 n) + v)) + +(define (c128vector-take-right vec n) + (let ((v (make-c128vector n)) + (len (c128vector-length vec))) + (c128vector-copy! v 0 vec (- len n) len) + v)) + +(define (c128vector-drop vec n) + (let* ((len (c128vector-length vec)) + (vlen (- len n)) + (v (make-c128vector vlen))) + (c128vector-copy! v 0 vec n len) + v)) + +(define (c128vector-drop-right vec n) + (let* ((len (c128vector-length vec)) + (rlen (- len n)) + (v (make-c128vector rlen))) + (c128vector-copy! v 0 vec 0 rlen) + v)) + +(define (c128vector-segment vec n) + (unless (and (integer? n) (positive? n)) + (error "length must be a positive integer" n)) + (let loop ((r '()) (i 0) (remain (c128vector-length vec))) + (if (<= remain 0) + (reverse r) + (let ((size (min n remain))) + (loop + (cons (c128vector-copy vec i (+ i size)) r) + (+ i size) + (- remain size)))))) + +;; aux. procedure +(define (%c128vectors-ref vecs i) + (map (lambda (v) (c128vector-ref v i)) vecs)) + +(define (c128vector-fold kons knil vec . vecs) + (if (null? vecs) + ;; fast path + (let ((len (c128vector-length vec))) + (let loop ((r knil) (i 0)) + (if (= i len) + r + (loop (kons r (c128vector-ref vec i)) (+ i 1))))) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map c128vector-length vecs)))) + (let loop ((r knil) (i 0)) + (if (= i len) + r + (loop (apply kons r (%c128vectors-ref vecs i)) + (+ i 1))))))) + +(define (c128vector-fold-right kons knil vec . vecs) + (if (null? vecs) + ;; fast path + (let ((len (c128vector-length vec))) + (let loop ((r knil) (i (- (c128vector-length vec) 1))) + (if (negative? i) + r + (loop (kons r (c128vector-ref vec i)) (- i 1))))) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map c128vector-length vecs)))) + (let loop ((r knil) (i (- len 1))) + (if (negative? i) + r + (loop (apply kons r (%c128vectors-ref vecs i)) + (- i 1))))))) + +(define (c128vector-map f vec . vecs) + (if (null? vecs) + ;; fast path + (let* ((len (c128vector-length vec)) + (v (make-c128vector len))) + (let loop ((i 0)) + (unless (= i len) + (c128vector-set! v i (f (c128vector-ref vec i))) + (loop (+ i 1)))) + v) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map c128vector-length vecs))) + (v (make-c128vector len))) + (let loop ((i 0)) + (unless (= i len) + (c128vector-set! v i (apply f (%c128vectors-ref vecs i))) + (loop (+ i 1)))) + v))) + + +(define (c128vector-map! f vec . vecs) + (if (null? vecs) + ;; fast path + (let ((len (c128vector-length vec))) + (let loop ((i 0)) + (unless (= i len) + (c128vector-set! vec i (f (c128vector-ref vec i))) + (loop (+ i 1))))) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map c128vector-length vecs)))) + (let loop ((i 0)) + (unless (= i len) + (c128vector-set! vec i (apply f (%c128vectors-ref vecs i))) + (loop (+ i 1))))))) + +(define (c128vector-for-each f vec . vecs) + (if (null? vecs) + ;; fast path + (let ((len (c128vector-length vec))) + (let loop ((i 0)) + (unless (= i len) + (f (c128vector-ref vec i)) + (loop (+ i 1))))) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map c128vector-length vecs)))) + (let loop ((i 0)) + (unless (= i len) + (apply f (%c128vectors-ref vecs i)) + (loop (+ i 1))))))) + +(define (c128vector-count pred vec . vecs) + (if (null? vecs) + ;; fast path + (let ((len (c128vector-length vec))) + (let loop ((i 0) (r 0)) + (cond + ((= i (c128vector-length vec)) r) + ((pred (c128vector-ref vec i)) (loop (+ i 1) (+ r 1))) + (else (loop (+ i 1) r))))) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map c128vector-length vecs)))) + (let loop ((i 0) (r 0)) + (cond + ((= i len) r) + ((apply pred (%c128vectors-ref vecs i)) (loop (+ i 1) (+ r 1))) + (else (loop (+ i 1) r))))))) + +(define (c128vector-cumulate f knil vec) + (let* ((len (c128vector-length vec)) + (v (make-c128vector len))) + (let loop ((r knil) (i 0)) + (unless (= i len) + (let ((next (f r (c128vector-ref vec i)))) + (c128vector-set! v i next) + (loop next (+ i 1))))) + v)) + +(define (c128vector-foreach f vec) + (let ((len (c128vector-length vec))) + (let loop ((i 0)) + (unless (= i len) + (f (c128vector-ref vec i)) + (loop (+ i 1)))))) + +(define (c128vector-take-while pred vec) + (let* ((len (c128vector-length vec)) + (idx (c128vector-skip pred vec)) + (idx* (if idx idx len))) + (c128vector-copy vec 0 idx*))) + +(define (c128vector-take-while-right pred vec) + (let* ((len (c128vector-length vec)) + (idx (c128vector-skip-right pred vec)) + (idx* (if idx (+ idx 1) 0))) + (c128vector-copy vec idx* len))) + +(define (c128vector-drop-while pred vec) + (let* ((len (c128vector-length vec)) + (idx (c128vector-skip pred vec)) + (idx* (if idx idx len))) + (c128vector-copy vec idx* len))) + +(define (c128vector-drop-while-right pred vec) + (let* ((len (c128vector-length vec)) + (idx (c128vector-skip-right pred vec)) + (idx* (if idx idx -1))) + (c128vector-copy vec 0 (+ 1 idx*)))) + +(define (c128vector-index pred vec . vecs) + (if (null? vecs) + ;; fast path + (let ((len (c128vector-length vec))) + (let loop ((i 0)) + (cond + ((= i len) #f) + ((pred (c128vector-ref vec i)) i) + (else (loop (+ i 1)))))) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map c128vector-length vecs)))) + (let loop ((i 0)) + (cond + ((= i len) #f) + ((apply pred (%c128vectors-ref vecs i)) i) + (else (loop (+ i 1)))))))) + +(define (c128vector-index-right pred vec . vecs) + (if (null? vecs) + ;; fast path + (let ((len (c128vector-length vec))) + (let loop ((i (- len 1))) + (cond + ((negative? i) #f) + ((pred (c128vector-ref vec i)) i) + (else (loop (- i 1)))))) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map c128vector-length vecs)))) + (let loop ((i (- len 1))) + (cond + ((negative? i) #f) + ((apply pred (%c128vectors-ref vecs i)) i) + (else (loop (- i 1)))))))) + +(define (c128vector-skip pred vec . vecs) + (if (null? vecs) + (c128vector-index (lambda (x) (not (pred x))) vec) + (apply c128vector-index (lambda xs (not (apply pred xs))) vec vecs))) + +(define (c128vector-skip-right pred vec . vecs) + (if (null? vecs) + (c128vector-index-right (lambda (x) (not (pred x))) vec) + (apply c128vector-index-right (lambda xs (not (apply pred xs))) vec vecs))) + +(define (c128vector-any pred vec . vecs) + (if (null? vecs) + ;; fast path + (let ((len (c128vector-length vec))) + (let loop ((i 0)) + (cond + ((= i len) #f) + ((pred (c128vector-ref vec i))) ;returns result of pred + (else (loop (+ i 1)))))) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map c128vector-length vecs)))) + (let loop ((i 0)) + (cond + ((= i len) #f) + ((apply pred (%c128vectors-ref vecs i))) ;returns result of pred + (else (loop (+ i 1)))))))) + +(define (c128vector-every pred vec . vecs) + (if (null? vecs) + ;; fast path + (let ((len (c128vector-length vec))) + (let loop ((i 0) (last #t)) + (cond + ((= i len) last) + ((pred (c128vector-ref vec i)) => (lambda (r) (loop (+ i 1) r))) + (else #f)))) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map c128vector-length vecs)))) + (let loop ((i 0) (last #t)) + (cond + ((= i len) last) + ((apply pred (%c128vectors-ref vecs i)) => (lambda (r) (loop (+ i 1) r))) + (else #f)))))) + +(define (c128vector-partition pred vec) + (let* ((len (c128vector-length vec)) + (cnt (c128vector-count pred vec)) + (r (make-c128vector len))) + (let loop ((i 0) (yes 0) (no cnt)) + (cond + ((= i len) (values r cnt)) + ((pred (c128vector-ref vec i)) + (c128vector-set! r yes (c128vector-ref vec i)) + (loop (+ i 1) (+ yes 1) no)) + (else + (c128vector-set! r no (c128vector-ref vec i)) + (loop (+ i 1) yes (+ no 1))))))) + +(define (c128vector-filter pred vec) + (let* ((len (c128vector-length vec)) + (cnt (c128vector-count pred vec)) + (r (make-c128vector cnt))) + (let loop ((i 0) (j 0)) + (cond + ((= i len) r) + ((pred (c128vector-ref vec i)) + (c128vector-set! r j (c128vector-ref vec i)) + (loop (+ i 1) (+ j 1))) + (else + (loop (+ i 1) j)))))) + +(define (c128vector-remove pred vec) + (c128vector-filter (lambda (x) (not (pred x))) vec)) + +;; c128vector-set! defined in (srfi 160 base) + +(define (c128vector-swap! vec i j) + (let ((ival (c128vector-ref vec i)) + (jval (c128vector-ref vec j))) + (c128vector-set! vec i jval) + (c128vector-set! vec j ival))) + +(define c128vector-fill! + (case-lambda + ((vec fill) (c128vector-fill-some! vec fill 0 (c128vector-length vec))) + ((vec fill start) (c128vector-fill-some! vec fill start (c128vector-length vec))) + ((vec fill start end) (c128vector-fill-some! vec fill start end)))) + +(define (c128vector-fill-some! vec fill start end) + (unless (= start end) + (c128vector-set! vec start fill) + (c128vector-fill-some! vec fill (+ start 1) end))) + +(define c128vector-reverse! + (case-lambda + ((vec) (c128vector-reverse-some! vec 0 (c128vector-length vec))) + ((vec start) (c128vector-reverse-some! vec start (c128vector-length vec))) + ((vec start end) (c128vector-reverse-some! vec start end)))) + +(define (c128vector-reverse-some! vec start end) + (let loop ((i start) (j (- end 1))) + (when (< i j) + (c128vector-swap! vec i j) + (loop (+ i 1) (- j 1))))) + +(define (c128vector-unfold! f vec start end seed) + (let loop ((i start) (seed seed)) + (when (< i end) + (let-values (((elt seed) (f i seed))) + (c128vector-set! vec i elt) + (loop (+ i 1) seed))))) + +(define (c128vector-unfold-right! f vec start end seed) + (let loop ((i (- end 1)) (seed seed)) + (when (>= i start) + (let-values (((elt seed) (f i seed))) + (c128vector-set! vec i elt) + (loop (- i 1) seed))))) + +(define reverse-c128vector->list + (case-lambda + ((vec) (reverse-c128vector->list* vec 0 (c128vector-length vec))) + ((vec start) (reverse-c128vector->list* vec start (c128vector-length vec))) + ((vec start end) (reverse-c128vector->list* vec start end)))) + +(define (reverse-c128vector->list* vec start end) + (let loop ((i start) (r '())) + (if (= i end) + r + (loop (+ 1 i) (cons (c128vector-ref vec i) r))))) + +(define (reverse-list->c128vector list) + (let* ((len (length list)) + (r (make-c128vector len))) + (let loop ((i 0) (list list)) + (cond + ((= i len) r) + (else + (c128vector-set! r (- len i 1) (car list)) + (loop (+ i 1) (cdr list))))))) + +(define c128vector->vector + (case-lambda + ((vec) (c128vector->vector* vec 0 (c128vector-length vec))) + ((vec start) (c128vector->vector* vec start (c128vector-length vec))) + ((vec start end) (c128vector->vector* vec start end)))) + +(define (c128vector->vector* vec start end) + (let* ((len (- end start)) + (r (make-vector len))) + (let loop ((i start) (o 0)) + (cond + ((= i end) r) + (else + (vector-set! r o (c128vector-ref vec i)) + (loop (+ i 1) (+ o 1))))))) + +(define vector->c128vector + (case-lambda + ((vec) (vector->c128vector* vec 0 (vector-length vec))) + ((vec start) (vector->c128vector* vec start (vector-length vec))) + ((vec start end) (vector->c128vector* vec start end)))) + +(define (vector->c128vector* vec start end) + (let* ((len (- end start)) + (r (make-c128vector len))) + (let loop ((i start) (o 0)) + (cond + ((= i end) r) + (else + (c128vector-set! r o (vector-ref vec i)) + (loop (+ i 1) (+ o 1))))))) + +(define make-c128vector-generator + (case-lambda ((vec) (make-c128vector-generator vec 0 (c128vector-length vec))) + ((vec start) (make-c128vector-generator vec start (c128vector-length vec))) + ((vec start end) + (lambda () (if (>= start end) + (eof-object) + (let ((next (c128vector-ref vec start))) + (set! start (+ start 1)) + next)))))) + +(define write-c128vector + (case-lambda + ((vec) (write-c128vector* vec (current-output-port))) + ((vec port) (write-c128vector* vec port)))) + + +(define (write-c128vector* vec port) + (display "#c128(" port) ; c128-expansion is blind, so will expand this too + (let ((last (- (c128vector-length vec) 1))) + (let loop ((i 0)) + (cond + ((= i last) + (write (c128vector-ref vec i) port) + (display ")" port)) + (else + (write (c128vector-ref vec i) port) + (display " " port) + (loop (+ i 1))))))) + +(define (c128vector< vec1 vec2) + (let ((len1 (c128vector-length vec1)) + (len2 (c128vector-length vec2))) + (cond + ((< len1 len2) + #t) + ((> len1 len2) + #f) + (else + (let loop ((i 0)) + (cond + ((= i len1) + #f) + ((< (c128vector-ref vec1 i) (c128vector-ref vec2 i)) + #t) + ((> (c128vector-ref vec1 i) (c128vector-ref vec2 i)) + #f) + (else + (loop (+ i 1))))))))) + +(define (c128vector-hash vec) + (let ((len (min 256 (c128vector-length vec)))) + (let loop ((i 0) (r 0)) + (if (= i len) + (abs (floor (real-part (inexact->exact r)))) + (loop (+ i 1) (+ r (c128vector-ref vec i))))))) + +(define c128vector-comparator + (make-comparator c128vector? c128vector= c128vector< c128vector-hash)) diff --git a/module/srfi/srfi-160/c128.sld b/module/srfi/srfi-160/c128.sld new file mode 100644 index 000000000..e7863354e --- /dev/null +++ b/module/srfi/srfi-160/c128.sld @@ -0,0 +1,49 @@ +;;; SPDX-FileCopyrightText: 2018 John Cowan +;;; +;;; SPDX-License-Identifier: MIT + +(define-library (srfi srfi-160 c128) + (import (scheme base)) + (import (scheme case-lambda)) + (import (scheme cxr)) + (import (only (scheme r5rs) inexact->exact)) + (import (scheme complex)) + (import (scheme write)) + (import (srfi srfi-128)) + (import (srfi srfi-160 base)) + ;; Constructors + (export make-c128vector c128vector + c128vector-unfold c128vector-unfold-right + c128vector-copy c128vector-reverse-copy + c128vector-append c128vector-concatenate + c128vector-append-subvectors) + ;; Predicates + (export c128? c128vector? c128vector-empty? c128vector=) + ;; Selectors + (export c128vector-ref c128vector-length) + ;; Iteration + (export c128vector-take c128vector-take-right + c128vector-drop c128vector-drop-right + c128vector-segment + c128vector-fold c128vector-fold-right + c128vector-map c128vector-map! c128vector-for-each + c128vector-count c128vector-cumulate) + ;; Searching + (export c128vector-take-while c128vector-take-while-right + c128vector-drop-while c128vector-drop-while-right + c128vector-index c128vector-index-right c128vector-skip c128vector-skip-right + c128vector-any c128vector-every c128vector-partition + c128vector-filter c128vector-remove) + ;; Mutators + (export c128vector-set! c128vector-swap! c128vector-fill! c128vector-reverse! + c128vector-copy! c128vector-reverse-copy! + c128vector-unfold! c128vector-unfold-right!) + ;; Conversion + (export c128vector->list list->c128vector + reverse-c128vector->list reverse-list->c128vector + c128vector->vector vector->c128vector) + ;; Misc + (export make-c128vector-generator c128vector-comparator write-c128vector) + + (include "c128-impl.scm") +) diff --git a/module/srfi/srfi-160/c64-impl.scm b/module/srfi/srfi-160/c64-impl.scm new file mode 100644 index 000000000..5c60d5019 --- /dev/null +++ b/module/srfi/srfi-160/c64-impl.scm @@ -0,0 +1,601 @@ +;;; SPDX-FileCopyrightText: 2018 John Cowan +;;; +;;; SPDX-License-Identifier: MIT + +;;; This code is the same for all SRFI 160 vector sizes. +;;; The c64s appearing in the code are expanded to u8, s8, etc. + +;; make-c64vector defined in (srfi 160 base) + +;; c64vector defined in (srfi 160 base) + +(define (c64vector-unfold f len seed) + (let ((v (make-c64vector len))) + (let loop ((i 0) (state seed)) + (unless (= i len) + (let-values (((value newstate) (f i state))) + (c64vector-set! v i value) + (loop (+ i 1) newstate)))) + v)) + +(define (c64vector-unfold-right f len seed) + (let ((v (make-c64vector len))) + (let loop ((i (- len 1)) (state seed)) + (unless (= i -1) + (let-values (((value newstate) (f i state))) + (c64vector-set! v i value) + (loop (- i 1) newstate)))) + v)) + +(define c64vector-copy + (case-lambda + ((vec) (c64vector-copy* vec 0 (c64vector-length vec))) + ((vec start) (c64vector-copy* vec start (c64vector-length vec))) + ((vec start end) (c64vector-copy* vec start end)))) + +(define (c64vector-copy* vec start end) + (let ((v (make-c64vector (- end start)))) + (c64vector-copy! v 0 vec start end) + v)) + +(define c64vector-copy! + (case-lambda + ((to at from) + (c64vector-copy!* to at from 0 (c64vector-length from))) + ((to at from start) + (c64vector-copy!* to at from start (c64vector-length from))) + ((to at from start end) (c64vector-copy!* to at from start end)))) + +(define (c64vector-copy!* to at from start end) + (let loop ((at at) (i start)) + (unless (= i end) + (c64vector-set! to at (c64vector-ref from i)) + (loop (+ at 1) (+ i 1))))) + +(define c64vector-reverse-copy + (case-lambda + ((vec) (c64vector-reverse-copy* vec 0 (c64vector-length vec))) + ((vec start) (c64vector-reverse-copy* vec start (c64vector-length vec))) + ((vec start end) (c64vector-reverse-copy* vec start end)))) + +(define (c64vector-reverse-copy* vec start end) + (let ((v (make-c64vector (- end start)))) + (c64vector-reverse-copy! v 0 vec start end) + v)) + +(define c64vector-reverse-copy! + (case-lambda + ((to at from) + (c64vector-reverse-copy!* to at from 0 (c64vector-length from))) + ((to at from start) + (c64vector-reverse-copy!* to at from start (c64vector-length from))) + ((to at from start end) (c64vector-reverse-copy!* to at from start end)))) + +(define (c64vector-reverse-copy!* to at from start end) + (let loop ((at at) (i (- end 1))) + (unless (< i start) + (c64vector-set! to at (c64vector-ref from i)) + (loop (+ at 1) (- i 1))))) + +(define (c64vector-append . vecs) + (c64vector-concatenate vecs)) + +(define (c64vector-concatenate vecs) + (let ((v (make-c64vector (len-sum vecs)))) + (let loop ((vecs vecs) (at 0)) + (unless (null? vecs) + (let ((vec (car vecs))) + (c64vector-copy! v at vec 0 (c64vector-length vec)) + (loop (cdr vecs) (+ at (c64vector-length vec))))) + v))) + +(define (len-sum vecs) + (if (null? vecs) + 0 + (+ (c64vector-length (car vecs)) + (len-sum (cdr vecs))))) + +(define (c64vector-append-subvectors . args) + (let ((v (make-c64vector (len-subsum args)))) + (let loop ((args args) (at 0)) + (unless (null? args) + (let ((vec (car args)) + (start (cadr args)) + (end (caddr args))) + (c64vector-copy! v at vec start end) + (loop (cdddr args) (+ at (- end start)))))) + v)) + +(define (len-subsum vecs) + (if (null? vecs) + 0 + (+ (- (caddr vecs) (cadr vecs)) + (len-subsum (cdddr vecs))))) + +;; c64? defined in (srfi 160 base) + +;; c64vector? defined in (srfi 160 base) + +(define (c64vector-empty? vec) + (zero? (c64vector-length vec))) + +(define (c64vector= . vecs) + (c64vector=* (car vecs) (cadr vecs) (cddr vecs))) + +(define (c64vector=* vec1 vec2 vecs) + (and (c64dyadic-vecs= vec1 0 (c64vector-length vec1) + vec2 0 (c64vector-length vec2)) + (or (null? vecs) + (c64vector=* vec2 (car vecs) (cdr vecs))))) + +(define (c64dyadic-vecs= vec1 start1 end1 vec2 start2 end2) + (cond + ((not (= end1 end2)) #f) + ((not (< start1 end1)) #t) + ((let ((elt1 (c64vector-ref vec1 start1)) + (elt2 (c64vector-ref vec2 start2))) + (= elt1 elt2)) + (c64dyadic-vecs= vec1 (+ start1 1) end1 + vec2 (+ start2 1) end2)) + (else #f))) + +;; c64vector-ref defined in (srfi 160 base) + +;; c64vector-length defined in (srfi 160 base) + +(define (c64vector-take vec n) + (let ((v (make-c64vector n))) + (c64vector-copy! v 0 vec 0 n) + v)) + +(define (c64vector-take-right vec n) + (let ((v (make-c64vector n)) + (len (c64vector-length vec))) + (c64vector-copy! v 0 vec (- len n) len) + v)) + +(define (c64vector-drop vec n) + (let* ((len (c64vector-length vec)) + (vlen (- len n)) + (v (make-c64vector vlen))) + (c64vector-copy! v 0 vec n len) + v)) + +(define (c64vector-drop-right vec n) + (let* ((len (c64vector-length vec)) + (rlen (- len n)) + (v (make-c64vector rlen))) + (c64vector-copy! v 0 vec 0 rlen) + v)) + +(define (c64vector-segment vec n) + (unless (and (integer? n) (positive? n)) + (error "length must be a positive integer" n)) + (let loop ((r '()) (i 0) (remain (c64vector-length vec))) + (if (<= remain 0) + (reverse r) + (let ((size (min n remain))) + (loop + (cons (c64vector-copy vec i (+ i size)) r) + (+ i size) + (- remain size)))))) + +;; aux. procedure +(define (%c64vectors-ref vecs i) + (map (lambda (v) (c64vector-ref v i)) vecs)) + +(define (c64vector-fold kons knil vec . vecs) + (if (null? vecs) + ;; fast path + (let ((len (c64vector-length vec))) + (let loop ((r knil) (i 0)) + (if (= i len) + r + (loop (kons r (c64vector-ref vec i)) (+ i 1))))) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map c64vector-length vecs)))) + (let loop ((r knil) (i 0)) + (if (= i len) + r + (loop (apply kons r (%c64vectors-ref vecs i)) + (+ i 1))))))) + +(define (c64vector-fold-right kons knil vec . vecs) + (if (null? vecs) + ;; fast path + (let ((len (c64vector-length vec))) + (let loop ((r knil) (i (- (c64vector-length vec) 1))) + (if (negative? i) + r + (loop (kons r (c64vector-ref vec i)) (- i 1))))) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map c64vector-length vecs)))) + (let loop ((r knil) (i (- len 1))) + (if (negative? i) + r + (loop (apply kons r (%c64vectors-ref vecs i)) + (- i 1))))))) + +(define (c64vector-map f vec . vecs) + (if (null? vecs) + ;; fast path + (let* ((len (c64vector-length vec)) + (v (make-c64vector len))) + (let loop ((i 0)) + (unless (= i len) + (c64vector-set! v i (f (c64vector-ref vec i))) + (loop (+ i 1)))) + v) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map c64vector-length vecs))) + (v (make-c64vector len))) + (let loop ((i 0)) + (unless (= i len) + (c64vector-set! v i (apply f (%c64vectors-ref vecs i))) + (loop (+ i 1)))) + v))) + + +(define (c64vector-map! f vec . vecs) + (if (null? vecs) + ;; fast path + (let ((len (c64vector-length vec))) + (let loop ((i 0)) + (unless (= i len) + (c64vector-set! vec i (f (c64vector-ref vec i))) + (loop (+ i 1))))) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map c64vector-length vecs)))) + (let loop ((i 0)) + (unless (= i len) + (c64vector-set! vec i (apply f (%c64vectors-ref vecs i))) + (loop (+ i 1))))))) + +(define (c64vector-for-each f vec . vecs) + (if (null? vecs) + ;; fast path + (let ((len (c64vector-length vec))) + (let loop ((i 0)) + (unless (= i len) + (f (c64vector-ref vec i)) + (loop (+ i 1))))) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map c64vector-length vecs)))) + (let loop ((i 0)) + (unless (= i len) + (apply f (%c64vectors-ref vecs i)) + (loop (+ i 1))))))) + +(define (c64vector-count pred vec . vecs) + (if (null? vecs) + ;; fast path + (let ((len (c64vector-length vec))) + (let loop ((i 0) (r 0)) + (cond + ((= i (c64vector-length vec)) r) + ((pred (c64vector-ref vec i)) (loop (+ i 1) (+ r 1))) + (else (loop (+ i 1) r))))) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map c64vector-length vecs)))) + (let loop ((i 0) (r 0)) + (cond + ((= i len) r) + ((apply pred (%c64vectors-ref vecs i)) (loop (+ i 1) (+ r 1))) + (else (loop (+ i 1) r))))))) + +(define (c64vector-cumulate f knil vec) + (let* ((len (c64vector-length vec)) + (v (make-c64vector len))) + (let loop ((r knil) (i 0)) + (unless (= i len) + (let ((next (f r (c64vector-ref vec i)))) + (c64vector-set! v i next) + (loop next (+ i 1))))) + v)) + +(define (c64vector-foreach f vec) + (let ((len (c64vector-length vec))) + (let loop ((i 0)) + (unless (= i len) + (f (c64vector-ref vec i)) + (loop (+ i 1)))))) + +(define (c64vector-take-while pred vec) + (let* ((len (c64vector-length vec)) + (idx (c64vector-skip pred vec)) + (idx* (if idx idx len))) + (c64vector-copy vec 0 idx*))) + +(define (c64vector-take-while-right pred vec) + (let* ((len (c64vector-length vec)) + (idx (c64vector-skip-right pred vec)) + (idx* (if idx (+ idx 1) 0))) + (c64vector-copy vec idx* len))) + +(define (c64vector-drop-while pred vec) + (let* ((len (c64vector-length vec)) + (idx (c64vector-skip pred vec)) + (idx* (if idx idx len))) + (c64vector-copy vec idx* len))) + +(define (c64vector-drop-while-right pred vec) + (let* ((len (c64vector-length vec)) + (idx (c64vector-skip-right pred vec)) + (idx* (if idx idx -1))) + (c64vector-copy vec 0 (+ 1 idx*)))) + +(define (c64vector-index pred vec . vecs) + (if (null? vecs) + ;; fast path + (let ((len (c64vector-length vec))) + (let loop ((i 0)) + (cond + ((= i len) #f) + ((pred (c64vector-ref vec i)) i) + (else (loop (+ i 1)))))) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map c64vector-length vecs)))) + (let loop ((i 0)) + (cond + ((= i len) #f) + ((apply pred (%c64vectors-ref vecs i)) i) + (else (loop (+ i 1)))))))) + +(define (c64vector-index-right pred vec . vecs) + (if (null? vecs) + ;; fast path + (let ((len (c64vector-length vec))) + (let loop ((i (- len 1))) + (cond + ((negative? i) #f) + ((pred (c64vector-ref vec i)) i) + (else (loop (- i 1)))))) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map c64vector-length vecs)))) + (let loop ((i (- len 1))) + (cond + ((negative? i) #f) + ((apply pred (%c64vectors-ref vecs i)) i) + (else (loop (- i 1)))))))) + +(define (c64vector-skip pred vec . vecs) + (if (null? vecs) + (c64vector-index (lambda (x) (not (pred x))) vec) + (apply c64vector-index (lambda xs (not (apply pred xs))) vec vecs))) + +(define (c64vector-skip-right pred vec . vecs) + (if (null? vecs) + (c64vector-index-right (lambda (x) (not (pred x))) vec) + (apply c64vector-index-right (lambda xs (not (apply pred xs))) vec vecs))) + +(define (c64vector-any pred vec . vecs) + (if (null? vecs) + ;; fast path + (let ((len (c64vector-length vec))) + (let loop ((i 0)) + (cond + ((= i len) #f) + ((pred (c64vector-ref vec i))) ;returns result of pred + (else (loop (+ i 1)))))) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map c64vector-length vecs)))) + (let loop ((i 0)) + (cond + ((= i len) #f) + ((apply pred (%c64vectors-ref vecs i))) ;returns result of pred + (else (loop (+ i 1)))))))) + +(define (c64vector-every pred vec . vecs) + (if (null? vecs) + ;; fast path + (let ((len (c64vector-length vec))) + (let loop ((i 0) (last #t)) + (cond + ((= i len) last) + ((pred (c64vector-ref vec i)) => (lambda (r) (loop (+ i 1) r))) + (else #f)))) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map c64vector-length vecs)))) + (let loop ((i 0) (last #t)) + (cond + ((= i len) last) + ((apply pred (%c64vectors-ref vecs i)) => (lambda (r) (loop (+ i 1) r))) + (else #f)))))) + +(define (c64vector-partition pred vec) + (let* ((len (c64vector-length vec)) + (cnt (c64vector-count pred vec)) + (r (make-c64vector len))) + (let loop ((i 0) (yes 0) (no cnt)) + (cond + ((= i len) (values r cnt)) + ((pred (c64vector-ref vec i)) + (c64vector-set! r yes (c64vector-ref vec i)) + (loop (+ i 1) (+ yes 1) no)) + (else + (c64vector-set! r no (c64vector-ref vec i)) + (loop (+ i 1) yes (+ no 1))))))) + +(define (c64vector-filter pred vec) + (let* ((len (c64vector-length vec)) + (cnt (c64vector-count pred vec)) + (r (make-c64vector cnt))) + (let loop ((i 0) (j 0)) + (cond + ((= i len) r) + ((pred (c64vector-ref vec i)) + (c64vector-set! r j (c64vector-ref vec i)) + (loop (+ i 1) (+ j 1))) + (else + (loop (+ i 1) j)))))) + +(define (c64vector-remove pred vec) + (c64vector-filter (lambda (x) (not (pred x))) vec)) + +;; c64vector-set! defined in (srfi 160 base) + +(define (c64vector-swap! vec i j) + (let ((ival (c64vector-ref vec i)) + (jval (c64vector-ref vec j))) + (c64vector-set! vec i jval) + (c64vector-set! vec j ival))) + +(define c64vector-fill! + (case-lambda + ((vec fill) (c64vector-fill-some! vec fill 0 (c64vector-length vec))) + ((vec fill start) (c64vector-fill-some! vec fill start (c64vector-length vec))) + ((vec fill start end) (c64vector-fill-some! vec fill start end)))) + +(define (c64vector-fill-some! vec fill start end) + (unless (= start end) + (c64vector-set! vec start fill) + (c64vector-fill-some! vec fill (+ start 1) end))) + +(define c64vector-reverse! + (case-lambda + ((vec) (c64vector-reverse-some! vec 0 (c64vector-length vec))) + ((vec start) (c64vector-reverse-some! vec start (c64vector-length vec))) + ((vec start end) (c64vector-reverse-some! vec start end)))) + +(define (c64vector-reverse-some! vec start end) + (let loop ((i start) (j (- end 1))) + (when (< i j) + (c64vector-swap! vec i j) + (loop (+ i 1) (- j 1))))) + +(define (c64vector-unfold! f vec start end seed) + (let loop ((i start) (seed seed)) + (when (< i end) + (let-values (((elt seed) (f i seed))) + (c64vector-set! vec i elt) + (loop (+ i 1) seed))))) + +(define (c64vector-unfold-right! f vec start end seed) + (let loop ((i (- end 1)) (seed seed)) + (when (>= i start) + (let-values (((elt seed) (f i seed))) + (c64vector-set! vec i elt) + (loop (- i 1) seed))))) + +(define reverse-c64vector->list + (case-lambda + ((vec) (reverse-c64vector->list* vec 0 (c64vector-length vec))) + ((vec start) (reverse-c64vector->list* vec start (c64vector-length vec))) + ((vec start end) (reverse-c64vector->list* vec start end)))) + +(define (reverse-c64vector->list* vec start end) + (let loop ((i start) (r '())) + (if (= i end) + r + (loop (+ 1 i) (cons (c64vector-ref vec i) r))))) + +(define (reverse-list->c64vector list) + (let* ((len (length list)) + (r (make-c64vector len))) + (let loop ((i 0) (list list)) + (cond + ((= i len) r) + (else + (c64vector-set! r (- len i 1) (car list)) + (loop (+ i 1) (cdr list))))))) + +(define c64vector->vector + (case-lambda + ((vec) (c64vector->vector* vec 0 (c64vector-length vec))) + ((vec start) (c64vector->vector* vec start (c64vector-length vec))) + ((vec start end) (c64vector->vector* vec start end)))) + +(define (c64vector->vector* vec start end) + (let* ((len (- end start)) + (r (make-vector len))) + (let loop ((i start) (o 0)) + (cond + ((= i end) r) + (else + (vector-set! r o (c64vector-ref vec i)) + (loop (+ i 1) (+ o 1))))))) + +(define vector->c64vector + (case-lambda + ((vec) (vector->c64vector* vec 0 (vector-length vec))) + ((vec start) (vector->c64vector* vec start (vector-length vec))) + ((vec start end) (vector->c64vector* vec start end)))) + +(define (vector->c64vector* vec start end) + (let* ((len (- end start)) + (r (make-c64vector len))) + (let loop ((i start) (o 0)) + (cond + ((= i end) r) + (else + (c64vector-set! r o (vector-ref vec i)) + (loop (+ i 1) (+ o 1))))))) + +(define make-c64vector-generator + (case-lambda ((vec) (make-c64vector-generator vec 0 (c64vector-length vec))) + ((vec start) (make-c64vector-generator vec start (c64vector-length vec))) + ((vec start end) + (lambda () (if (>= start end) + (eof-object) + (let ((next (c64vector-ref vec start))) + (set! start (+ start 1)) + next)))))) + +(define write-c64vector + (case-lambda + ((vec) (write-c64vector* vec (current-output-port))) + ((vec port) (write-c64vector* vec port)))) + + +(define (write-c64vector* vec port) + (display "#c64(" port) ; c64-expansion is blind, so will expand this too + (let ((last (- (c64vector-length vec) 1))) + (let loop ((i 0)) + (cond + ((= i last) + (write (c64vector-ref vec i) port) + (display ")" port)) + (else + (write (c64vector-ref vec i) port) + (display " " port) + (loop (+ i 1))))))) + +(define (c64vector< vec1 vec2) + (let ((len1 (c64vector-length vec1)) + (len2 (c64vector-length vec2))) + (cond + ((< len1 len2) + #t) + ((> len1 len2) + #f) + (else + (let loop ((i 0)) + (cond + ((= i len1) + #f) + ((< (c64vector-ref vec1 i) (c64vector-ref vec2 i)) + #t) + ((> (c64vector-ref vec1 i) (c64vector-ref vec2 i)) + #f) + (else + (loop (+ i 1))))))))) + +(define (c64vector-hash vec) + (let ((len (min 256 (c64vector-length vec)))) + (let loop ((i 0) (r 0)) + (if (= i len) + (abs (floor (real-part (inexact->exact r)))) + (loop (+ i 1) (+ r (c64vector-ref vec i))))))) + +(define c64vector-comparator + (make-comparator c64vector? c64vector= c64vector< c64vector-hash)) diff --git a/module/srfi/srfi-160/c64.sld b/module/srfi/srfi-160/c64.sld new file mode 100644 index 000000000..06fa28334 --- /dev/null +++ b/module/srfi/srfi-160/c64.sld @@ -0,0 +1,49 @@ +;;; SPDX-FileCopyrightText: 2018 John Cowan +;;; +;;; SPDX-License-Identifier: MIT + +(define-library (srfi srfi-160 c64) + (import (scheme base)) + (import (scheme case-lambda)) + (import (scheme cxr)) + (import (only (scheme r5rs) inexact->exact)) + (import (scheme complex)) + (import (scheme write)) + (import (srfi srfi-128)) + (import (srfi srfi-160 base)) + ;; Constructors + (export make-c64vector c64vector + c64vector-unfold c64vector-unfold-right + c64vector-copy c64vector-reverse-copy + c64vector-append c64vector-concatenate + c64vector-append-subvectors) + ;; Predicates + (export c64? c64vector? c64vector-empty? c64vector=) + ;; Selectors + (export c64vector-ref c64vector-length) + ;; Iteration + (export c64vector-take c64vector-take-right + c64vector-drop c64vector-drop-right + c64vector-segment + c64vector-fold c64vector-fold-right + c64vector-map c64vector-map! c64vector-for-each + c64vector-count c64vector-cumulate) + ;; Searching + (export c64vector-take-while c64vector-take-while-right + c64vector-drop-while c64vector-drop-while-right + c64vector-index c64vector-index-right c64vector-skip c64vector-skip-right + c64vector-any c64vector-every c64vector-partition + c64vector-filter c64vector-remove) + ;; Mutators + (export c64vector-set! c64vector-swap! c64vector-fill! c64vector-reverse! + c64vector-copy! c64vector-reverse-copy! + c64vector-unfold! c64vector-unfold-right!) + ;; Conversion + (export c64vector->list list->c64vector + reverse-c64vector->list reverse-list->c64vector + c64vector->vector vector->c64vector) + ;; Misc + (export make-c64vector-generator c64vector-comparator write-c64vector) + + (include "c64-impl.scm") +) diff --git a/module/srfi/srfi-160/f32-impl.scm b/module/srfi/srfi-160/f32-impl.scm new file mode 100644 index 000000000..3ed3eda5b --- /dev/null +++ b/module/srfi/srfi-160/f32-impl.scm @@ -0,0 +1,601 @@ +;;; SPDX-FileCopyrightText: 2018 John Cowan +;;; +;;; SPDX-License-Identifier: MIT + +;;; This code is the same for all SRFI 160 vector sizes. +;;; The f32s appearing in the code are expanded to u8, s8, etc. + +;; make-f32vector defined in (srfi 160 base) + +;; f32vector defined in (srfi 160 base) + +(define (f32vector-unfold f len seed) + (let ((v (make-f32vector len))) + (let loop ((i 0) (state seed)) + (unless (= i len) + (let-values (((value newstate) (f i state))) + (f32vector-set! v i value) + (loop (+ i 1) newstate)))) + v)) + +(define (f32vector-unfold-right f len seed) + (let ((v (make-f32vector len))) + (let loop ((i (- len 1)) (state seed)) + (unless (= i -1) + (let-values (((value newstate) (f i state))) + (f32vector-set! v i value) + (loop (- i 1) newstate)))) + v)) + +(define f32vector-copy + (case-lambda + ((vec) (f32vector-copy* vec 0 (f32vector-length vec))) + ((vec start) (f32vector-copy* vec start (f32vector-length vec))) + ((vec start end) (f32vector-copy* vec start end)))) + +(define (f32vector-copy* vec start end) + (let ((v (make-f32vector (- end start)))) + (f32vector-copy! v 0 vec start end) + v)) + +(define f32vector-copy! + (case-lambda + ((to at from) + (f32vector-copy!* to at from 0 (f32vector-length from))) + ((to at from start) + (f32vector-copy!* to at from start (f32vector-length from))) + ((to at from start end) (f32vector-copy!* to at from start end)))) + +(define (f32vector-copy!* to at from start end) + (let loop ((at at) (i start)) + (unless (= i end) + (f32vector-set! to at (f32vector-ref from i)) + (loop (+ at 1) (+ i 1))))) + +(define f32vector-reverse-copy + (case-lambda + ((vec) (f32vector-reverse-copy* vec 0 (f32vector-length vec))) + ((vec start) (f32vector-reverse-copy* vec start (f32vector-length vec))) + ((vec start end) (f32vector-reverse-copy* vec start end)))) + +(define (f32vector-reverse-copy* vec start end) + (let ((v (make-f32vector (- end start)))) + (f32vector-reverse-copy! v 0 vec start end) + v)) + +(define f32vector-reverse-copy! + (case-lambda + ((to at from) + (f32vector-reverse-copy!* to at from 0 (f32vector-length from))) + ((to at from start) + (f32vector-reverse-copy!* to at from start (f32vector-length from))) + ((to at from start end) (f32vector-reverse-copy!* to at from start end)))) + +(define (f32vector-reverse-copy!* to at from start end) + (let loop ((at at) (i (- end 1))) + (unless (< i start) + (f32vector-set! to at (f32vector-ref from i)) + (loop (+ at 1) (- i 1))))) + +(define (f32vector-append . vecs) + (f32vector-concatenate vecs)) + +(define (f32vector-concatenate vecs) + (let ((v (make-f32vector (len-sum vecs)))) + (let loop ((vecs vecs) (at 0)) + (unless (null? vecs) + (let ((vec (car vecs))) + (f32vector-copy! v at vec 0 (f32vector-length vec)) + (loop (cdr vecs) (+ at (f32vector-length vec))))) + v))) + +(define (len-sum vecs) + (if (null? vecs) + 0 + (+ (f32vector-length (car vecs)) + (len-sum (cdr vecs))))) + +(define (f32vector-append-subvectors . args) + (let ((v (make-f32vector (len-subsum args)))) + (let loop ((args args) (at 0)) + (unless (null? args) + (let ((vec (car args)) + (start (cadr args)) + (end (caddr args))) + (f32vector-copy! v at vec start end) + (loop (cdddr args) (+ at (- end start)))))) + v)) + +(define (len-subsum vecs) + (if (null? vecs) + 0 + (+ (- (caddr vecs) (cadr vecs)) + (len-subsum (cdddr vecs))))) + +;; f32? defined in (srfi 160 base) + +;; f32vector? defined in (srfi 160 base) + +(define (f32vector-empty? vec) + (zero? (f32vector-length vec))) + +(define (f32vector= . vecs) + (f32vector=* (car vecs) (cadr vecs) (cddr vecs))) + +(define (f32vector=* vec1 vec2 vecs) + (and (f32dyadic-vecs= vec1 0 (f32vector-length vec1) + vec2 0 (f32vector-length vec2)) + (or (null? vecs) + (f32vector=* vec2 (car vecs) (cdr vecs))))) + +(define (f32dyadic-vecs= vec1 start1 end1 vec2 start2 end2) + (cond + ((not (= end1 end2)) #f) + ((not (< start1 end1)) #t) + ((let ((elt1 (f32vector-ref vec1 start1)) + (elt2 (f32vector-ref vec2 start2))) + (= elt1 elt2)) + (f32dyadic-vecs= vec1 (+ start1 1) end1 + vec2 (+ start2 1) end2)) + (else #f))) + +;; f32vector-ref defined in (srfi 160 base) + +;; f32vector-length defined in (srfi 160 base) + +(define (f32vector-take vec n) + (let ((v (make-f32vector n))) + (f32vector-copy! v 0 vec 0 n) + v)) + +(define (f32vector-take-right vec n) + (let ((v (make-f32vector n)) + (len (f32vector-length vec))) + (f32vector-copy! v 0 vec (- len n) len) + v)) + +(define (f32vector-drop vec n) + (let* ((len (f32vector-length vec)) + (vlen (- len n)) + (v (make-f32vector vlen))) + (f32vector-copy! v 0 vec n len) + v)) + +(define (f32vector-drop-right vec n) + (let* ((len (f32vector-length vec)) + (rlen (- len n)) + (v (make-f32vector rlen))) + (f32vector-copy! v 0 vec 0 rlen) + v)) + +(define (f32vector-segment vec n) + (unless (and (integer? n) (positive? n)) + (error "length must be a positive integer" n)) + (let loop ((r '()) (i 0) (remain (f32vector-length vec))) + (if (<= remain 0) + (reverse r) + (let ((size (min n remain))) + (loop + (cons (f32vector-copy vec i (+ i size)) r) + (+ i size) + (- remain size)))))) + +;; aux. procedure +(define (%f32vectors-ref vecs i) + (map (lambda (v) (f32vector-ref v i)) vecs)) + +(define (f32vector-fold kons knil vec . vecs) + (if (null? vecs) + ;; fast path + (let ((len (f32vector-length vec))) + (let loop ((r knil) (i 0)) + (if (= i len) + r + (loop (kons r (f32vector-ref vec i)) (+ i 1))))) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map f32vector-length vecs)))) + (let loop ((r knil) (i 0)) + (if (= i len) + r + (loop (apply kons r (%f32vectors-ref vecs i)) + (+ i 1))))))) + +(define (f32vector-fold-right kons knil vec . vecs) + (if (null? vecs) + ;; fast path + (let ((len (f32vector-length vec))) + (let loop ((r knil) (i (- (f32vector-length vec) 1))) + (if (negative? i) + r + (loop (kons r (f32vector-ref vec i)) (- i 1))))) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map f32vector-length vecs)))) + (let loop ((r knil) (i (- len 1))) + (if (negative? i) + r + (loop (apply kons r (%f32vectors-ref vecs i)) + (- i 1))))))) + +(define (f32vector-map f vec . vecs) + (if (null? vecs) + ;; fast path + (let* ((len (f32vector-length vec)) + (v (make-f32vector len))) + (let loop ((i 0)) + (unless (= i len) + (f32vector-set! v i (f (f32vector-ref vec i))) + (loop (+ i 1)))) + v) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map f32vector-length vecs))) + (v (make-f32vector len))) + (let loop ((i 0)) + (unless (= i len) + (f32vector-set! v i (apply f (%f32vectors-ref vecs i))) + (loop (+ i 1)))) + v))) + + +(define (f32vector-map! f vec . vecs) + (if (null? vecs) + ;; fast path + (let ((len (f32vector-length vec))) + (let loop ((i 0)) + (unless (= i len) + (f32vector-set! vec i (f (f32vector-ref vec i))) + (loop (+ i 1))))) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map f32vector-length vecs)))) + (let loop ((i 0)) + (unless (= i len) + (f32vector-set! vec i (apply f (%f32vectors-ref vecs i))) + (loop (+ i 1))))))) + +(define (f32vector-for-each f vec . vecs) + (if (null? vecs) + ;; fast path + (let ((len (f32vector-length vec))) + (let loop ((i 0)) + (unless (= i len) + (f (f32vector-ref vec i)) + (loop (+ i 1))))) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map f32vector-length vecs)))) + (let loop ((i 0)) + (unless (= i len) + (apply f (%f32vectors-ref vecs i)) + (loop (+ i 1))))))) + +(define (f32vector-count pred vec . vecs) + (if (null? vecs) + ;; fast path + (let ((len (f32vector-length vec))) + (let loop ((i 0) (r 0)) + (cond + ((= i (f32vector-length vec)) r) + ((pred (f32vector-ref vec i)) (loop (+ i 1) (+ r 1))) + (else (loop (+ i 1) r))))) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map f32vector-length vecs)))) + (let loop ((i 0) (r 0)) + (cond + ((= i len) r) + ((apply pred (%f32vectors-ref vecs i)) (loop (+ i 1) (+ r 1))) + (else (loop (+ i 1) r))))))) + +(define (f32vector-cumulate f knil vec) + (let* ((len (f32vector-length vec)) + (v (make-f32vector len))) + (let loop ((r knil) (i 0)) + (unless (= i len) + (let ((next (f r (f32vector-ref vec i)))) + (f32vector-set! v i next) + (loop next (+ i 1))))) + v)) + +(define (f32vector-foreach f vec) + (let ((len (f32vector-length vec))) + (let loop ((i 0)) + (unless (= i len) + (f (f32vector-ref vec i)) + (loop (+ i 1)))))) + +(define (f32vector-take-while pred vec) + (let* ((len (f32vector-length vec)) + (idx (f32vector-skip pred vec)) + (idx* (if idx idx len))) + (f32vector-copy vec 0 idx*))) + +(define (f32vector-take-while-right pred vec) + (let* ((len (f32vector-length vec)) + (idx (f32vector-skip-right pred vec)) + (idx* (if idx (+ idx 1) 0))) + (f32vector-copy vec idx* len))) + +(define (f32vector-drop-while pred vec) + (let* ((len (f32vector-length vec)) + (idx (f32vector-skip pred vec)) + (idx* (if idx idx len))) + (f32vector-copy vec idx* len))) + +(define (f32vector-drop-while-right pred vec) + (let* ((len (f32vector-length vec)) + (idx (f32vector-skip-right pred vec)) + (idx* (if idx idx -1))) + (f32vector-copy vec 0 (+ 1 idx*)))) + +(define (f32vector-index pred vec . vecs) + (if (null? vecs) + ;; fast path + (let ((len (f32vector-length vec))) + (let loop ((i 0)) + (cond + ((= i len) #f) + ((pred (f32vector-ref vec i)) i) + (else (loop (+ i 1)))))) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map f32vector-length vecs)))) + (let loop ((i 0)) + (cond + ((= i len) #f) + ((apply pred (%f32vectors-ref vecs i)) i) + (else (loop (+ i 1)))))))) + +(define (f32vector-index-right pred vec . vecs) + (if (null? vecs) + ;; fast path + (let ((len (f32vector-length vec))) + (let loop ((i (- len 1))) + (cond + ((negative? i) #f) + ((pred (f32vector-ref vec i)) i) + (else (loop (- i 1)))))) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map f32vector-length vecs)))) + (let loop ((i (- len 1))) + (cond + ((negative? i) #f) + ((apply pred (%f32vectors-ref vecs i)) i) + (else (loop (- i 1)))))))) + +(define (f32vector-skip pred vec . vecs) + (if (null? vecs) + (f32vector-index (lambda (x) (not (pred x))) vec) + (apply f32vector-index (lambda xs (not (apply pred xs))) vec vecs))) + +(define (f32vector-skip-right pred vec . vecs) + (if (null? vecs) + (f32vector-index-right (lambda (x) (not (pred x))) vec) + (apply f32vector-index-right (lambda xs (not (apply pred xs))) vec vecs))) + +(define (f32vector-any pred vec . vecs) + (if (null? vecs) + ;; fast path + (let ((len (f32vector-length vec))) + (let loop ((i 0)) + (cond + ((= i len) #f) + ((pred (f32vector-ref vec i))) ;returns result of pred + (else (loop (+ i 1)))))) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map f32vector-length vecs)))) + (let loop ((i 0)) + (cond + ((= i len) #f) + ((apply pred (%f32vectors-ref vecs i))) ;returns result of pred + (else (loop (+ i 1)))))))) + +(define (f32vector-every pred vec . vecs) + (if (null? vecs) + ;; fast path + (let ((len (f32vector-length vec))) + (let loop ((i 0) (last #t)) + (cond + ((= i len) last) + ((pred (f32vector-ref vec i)) => (lambda (r) (loop (+ i 1) r))) + (else #f)))) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map f32vector-length vecs)))) + (let loop ((i 0) (last #t)) + (cond + ((= i len) last) + ((apply pred (%f32vectors-ref vecs i)) => (lambda (r) (loop (+ i 1) r))) + (else #f)))))) + +(define (f32vector-partition pred vec) + (let* ((len (f32vector-length vec)) + (cnt (f32vector-count pred vec)) + (r (make-f32vector len))) + (let loop ((i 0) (yes 0) (no cnt)) + (cond + ((= i len) (values r cnt)) + ((pred (f32vector-ref vec i)) + (f32vector-set! r yes (f32vector-ref vec i)) + (loop (+ i 1) (+ yes 1) no)) + (else + (f32vector-set! r no (f32vector-ref vec i)) + (loop (+ i 1) yes (+ no 1))))))) + +(define (f32vector-filter pred vec) + (let* ((len (f32vector-length vec)) + (cnt (f32vector-count pred vec)) + (r (make-f32vector cnt))) + (let loop ((i 0) (j 0)) + (cond + ((= i len) r) + ((pred (f32vector-ref vec i)) + (f32vector-set! r j (f32vector-ref vec i)) + (loop (+ i 1) (+ j 1))) + (else + (loop (+ i 1) j)))))) + +(define (f32vector-remove pred vec) + (f32vector-filter (lambda (x) (not (pred x))) vec)) + +;; f32vector-set! defined in (srfi 160 base) + +(define (f32vector-swap! vec i j) + (let ((ival (f32vector-ref vec i)) + (jval (f32vector-ref vec j))) + (f32vector-set! vec i jval) + (f32vector-set! vec j ival))) + +(define f32vector-fill! + (case-lambda + ((vec fill) (f32vector-fill-some! vec fill 0 (f32vector-length vec))) + ((vec fill start) (f32vector-fill-some! vec fill start (f32vector-length vec))) + ((vec fill start end) (f32vector-fill-some! vec fill start end)))) + +(define (f32vector-fill-some! vec fill start end) + (unless (= start end) + (f32vector-set! vec start fill) + (f32vector-fill-some! vec fill (+ start 1) end))) + +(define f32vector-reverse! + (case-lambda + ((vec) (f32vector-reverse-some! vec 0 (f32vector-length vec))) + ((vec start) (f32vector-reverse-some! vec start (f32vector-length vec))) + ((vec start end) (f32vector-reverse-some! vec start end)))) + +(define (f32vector-reverse-some! vec start end) + (let loop ((i start) (j (- end 1))) + (when (< i j) + (f32vector-swap! vec i j) + (loop (+ i 1) (- j 1))))) + +(define (f32vector-unfold! f vec start end seed) + (let loop ((i start) (seed seed)) + (when (< i end) + (let-values (((elt seed) (f i seed))) + (f32vector-set! vec i elt) + (loop (+ i 1) seed))))) + +(define (f32vector-unfold-right! f vec start end seed) + (let loop ((i (- end 1)) (seed seed)) + (when (>= i start) + (let-values (((elt seed) (f i seed))) + (f32vector-set! vec i elt) + (loop (- i 1) seed))))) + +(define reverse-f32vector->list + (case-lambda + ((vec) (reverse-f32vector->list* vec 0 (f32vector-length vec))) + ((vec start) (reverse-f32vector->list* vec start (f32vector-length vec))) + ((vec start end) (reverse-f32vector->list* vec start end)))) + +(define (reverse-f32vector->list* vec start end) + (let loop ((i start) (r '())) + (if (= i end) + r + (loop (+ 1 i) (cons (f32vector-ref vec i) r))))) + +(define (reverse-list->f32vector list) + (let* ((len (length list)) + (r (make-f32vector len))) + (let loop ((i 0) (list list)) + (cond + ((= i len) r) + (else + (f32vector-set! r (- len i 1) (car list)) + (loop (+ i 1) (cdr list))))))) + +(define f32vector->vector + (case-lambda + ((vec) (f32vector->vector* vec 0 (f32vector-length vec))) + ((vec start) (f32vector->vector* vec start (f32vector-length vec))) + ((vec start end) (f32vector->vector* vec start end)))) + +(define (f32vector->vector* vec start end) + (let* ((len (- end start)) + (r (make-vector len))) + (let loop ((i start) (o 0)) + (cond + ((= i end) r) + (else + (vector-set! r o (f32vector-ref vec i)) + (loop (+ i 1) (+ o 1))))))) + +(define vector->f32vector + (case-lambda + ((vec) (vector->f32vector* vec 0 (vector-length vec))) + ((vec start) (vector->f32vector* vec start (vector-length vec))) + ((vec start end) (vector->f32vector* vec start end)))) + +(define (vector->f32vector* vec start end) + (let* ((len (- end start)) + (r (make-f32vector len))) + (let loop ((i start) (o 0)) + (cond + ((= i end) r) + (else + (f32vector-set! r o (vector-ref vec i)) + (loop (+ i 1) (+ o 1))))))) + +(define make-f32vector-generator + (case-lambda ((vec) (make-f32vector-generator vec 0 (f32vector-length vec))) + ((vec start) (make-f32vector-generator vec start (f32vector-length vec))) + ((vec start end) + (lambda () (if (>= start end) + (eof-object) + (let ((next (f32vector-ref vec start))) + (set! start (+ start 1)) + next)))))) + +(define write-f32vector + (case-lambda + ((vec) (write-f32vector* vec (current-output-port))) + ((vec port) (write-f32vector* vec port)))) + + +(define (write-f32vector* vec port) + (display "#f32(" port) ; f32-expansion is blind, so will expand this too + (let ((last (- (f32vector-length vec) 1))) + (let loop ((i 0)) + (cond + ((= i last) + (write (f32vector-ref vec i) port) + (display ")" port)) + (else + (write (f32vector-ref vec i) port) + (display " " port) + (loop (+ i 1))))))) + +(define (f32vector< vec1 vec2) + (let ((len1 (f32vector-length vec1)) + (len2 (f32vector-length vec2))) + (cond + ((< len1 len2) + #t) + ((> len1 len2) + #f) + (else + (let loop ((i 0)) + (cond + ((= i len1) + #f) + ((< (f32vector-ref vec1 i) (f32vector-ref vec2 i)) + #t) + ((> (f32vector-ref vec1 i) (f32vector-ref vec2 i)) + #f) + (else + (loop (+ i 1))))))))) + +(define (f32vector-hash vec) + (let ((len (min 256 (f32vector-length vec)))) + (let loop ((i 0) (r 0)) + (if (= i len) + (abs (floor (real-part (inexact->exact r)))) + (loop (+ i 1) (+ r (f32vector-ref vec i))))))) + +(define f32vector-comparator + (make-comparator f32vector? f32vector= f32vector< f32vector-hash)) diff --git a/module/srfi/srfi-160/f32.sld b/module/srfi/srfi-160/f32.sld new file mode 100644 index 000000000..5c8c8adbe --- /dev/null +++ b/module/srfi/srfi-160/f32.sld @@ -0,0 +1,49 @@ +;;; SPDX-FileCopyrightText: 2018 John Cowan +;;; +;;; SPDX-License-Identifier: MIT + +(define-library (srfi srfi-160 f32) + (import (scheme base)) + (import (scheme case-lambda)) + (import (scheme cxr)) + (import (only (scheme r5rs) inexact->exact)) + (import (scheme complex)) + (import (scheme write)) + (import (srfi srfi-128)) + (import (srfi srfi-160 base)) + ;; Constructors + (export make-f32vector f32vector + f32vector-unfold f32vector-unfold-right + f32vector-copy f32vector-reverse-copy + f32vector-append f32vector-concatenate + f32vector-append-subvectors) + ;; Predicates + (export f32? f32vector? f32vector-empty? f32vector=) + ;; Selectors + (export f32vector-ref f32vector-length) + ;; Iteration + (export f32vector-take f32vector-take-right + f32vector-drop f32vector-drop-right + f32vector-segment + f32vector-fold f32vector-fold-right + f32vector-map f32vector-map! f32vector-for-each + f32vector-count f32vector-cumulate) + ;; Searching + (export f32vector-take-while f32vector-take-while-right + f32vector-drop-while f32vector-drop-while-right + f32vector-index f32vector-index-right f32vector-skip f32vector-skip-right + f32vector-any f32vector-every f32vector-partition + f32vector-filter f32vector-remove) + ;; Mutators + (export f32vector-set! f32vector-swap! f32vector-fill! f32vector-reverse! + f32vector-copy! f32vector-reverse-copy! + f32vector-unfold! f32vector-unfold-right!) + ;; Conversion + (export f32vector->list list->f32vector + reverse-f32vector->list reverse-list->f32vector + f32vector->vector vector->f32vector) + ;; Misc + (export make-f32vector-generator f32vector-comparator write-f32vector) + + (include "f32-impl.scm") +) diff --git a/module/srfi/srfi-160/f64-impl.scm b/module/srfi/srfi-160/f64-impl.scm new file mode 100644 index 000000000..9e1809f7e --- /dev/null +++ b/module/srfi/srfi-160/f64-impl.scm @@ -0,0 +1,601 @@ +;;; SPDX-FileCopyrightText: 2018 John Cowan +;;; +;;; SPDX-License-Identifier: MIT + +;;; This code is the same for all SRFI 160 vector sizes. +;;; The f64s appearing in the code are expanded to u8, s8, etc. + +;; make-f64vector defined in (srfi 160 base) + +;; f64vector defined in (srfi 160 base) + +(define (f64vector-unfold f len seed) + (let ((v (make-f64vector len))) + (let loop ((i 0) (state seed)) + (unless (= i len) + (let-values (((value newstate) (f i state))) + (f64vector-set! v i value) + (loop (+ i 1) newstate)))) + v)) + +(define (f64vector-unfold-right f len seed) + (let ((v (make-f64vector len))) + (let loop ((i (- len 1)) (state seed)) + (unless (= i -1) + (let-values (((value newstate) (f i state))) + (f64vector-set! v i value) + (loop (- i 1) newstate)))) + v)) + +(define f64vector-copy + (case-lambda + ((vec) (f64vector-copy* vec 0 (f64vector-length vec))) + ((vec start) (f64vector-copy* vec start (f64vector-length vec))) + ((vec start end) (f64vector-copy* vec start end)))) + +(define (f64vector-copy* vec start end) + (let ((v (make-f64vector (- end start)))) + (f64vector-copy! v 0 vec start end) + v)) + +(define f64vector-copy! + (case-lambda + ((to at from) + (f64vector-copy!* to at from 0 (f64vector-length from))) + ((to at from start) + (f64vector-copy!* to at from start (f64vector-length from))) + ((to at from start end) (f64vector-copy!* to at from start end)))) + +(define (f64vector-copy!* to at from start end) + (let loop ((at at) (i start)) + (unless (= i end) + (f64vector-set! to at (f64vector-ref from i)) + (loop (+ at 1) (+ i 1))))) + +(define f64vector-reverse-copy + (case-lambda + ((vec) (f64vector-reverse-copy* vec 0 (f64vector-length vec))) + ((vec start) (f64vector-reverse-copy* vec start (f64vector-length vec))) + ((vec start end) (f64vector-reverse-copy* vec start end)))) + +(define (f64vector-reverse-copy* vec start end) + (let ((v (make-f64vector (- end start)))) + (f64vector-reverse-copy! v 0 vec start end) + v)) + +(define f64vector-reverse-copy! + (case-lambda + ((to at from) + (f64vector-reverse-copy!* to at from 0 (f64vector-length from))) + ((to at from start) + (f64vector-reverse-copy!* to at from start (f64vector-length from))) + ((to at from start end) (f64vector-reverse-copy!* to at from start end)))) + +(define (f64vector-reverse-copy!* to at from start end) + (let loop ((at at) (i (- end 1))) + (unless (< i start) + (f64vector-set! to at (f64vector-ref from i)) + (loop (+ at 1) (- i 1))))) + +(define (f64vector-append . vecs) + (f64vector-concatenate vecs)) + +(define (f64vector-concatenate vecs) + (let ((v (make-f64vector (len-sum vecs)))) + (let loop ((vecs vecs) (at 0)) + (unless (null? vecs) + (let ((vec (car vecs))) + (f64vector-copy! v at vec 0 (f64vector-length vec)) + (loop (cdr vecs) (+ at (f64vector-length vec))))) + v))) + +(define (len-sum vecs) + (if (null? vecs) + 0 + (+ (f64vector-length (car vecs)) + (len-sum (cdr vecs))))) + +(define (f64vector-append-subvectors . args) + (let ((v (make-f64vector (len-subsum args)))) + (let loop ((args args) (at 0)) + (unless (null? args) + (let ((vec (car args)) + (start (cadr args)) + (end (caddr args))) + (f64vector-copy! v at vec start end) + (loop (cdddr args) (+ at (- end start)))))) + v)) + +(define (len-subsum vecs) + (if (null? vecs) + 0 + (+ (- (caddr vecs) (cadr vecs)) + (len-subsum (cdddr vecs))))) + +;; f64? defined in (srfi 160 base) + +;; f64vector? defined in (srfi 160 base) + +(define (f64vector-empty? vec) + (zero? (f64vector-length vec))) + +(define (f64vector= . vecs) + (f64vector=* (car vecs) (cadr vecs) (cddr vecs))) + +(define (f64vector=* vec1 vec2 vecs) + (and (f64dyadic-vecs= vec1 0 (f64vector-length vec1) + vec2 0 (f64vector-length vec2)) + (or (null? vecs) + (f64vector=* vec2 (car vecs) (cdr vecs))))) + +(define (f64dyadic-vecs= vec1 start1 end1 vec2 start2 end2) + (cond + ((not (= end1 end2)) #f) + ((not (< start1 end1)) #t) + ((let ((elt1 (f64vector-ref vec1 start1)) + (elt2 (f64vector-ref vec2 start2))) + (= elt1 elt2)) + (f64dyadic-vecs= vec1 (+ start1 1) end1 + vec2 (+ start2 1) end2)) + (else #f))) + +;; f64vector-ref defined in (srfi 160 base) + +;; f64vector-length defined in (srfi 160 base) + +(define (f64vector-take vec n) + (let ((v (make-f64vector n))) + (f64vector-copy! v 0 vec 0 n) + v)) + +(define (f64vector-take-right vec n) + (let ((v (make-f64vector n)) + (len (f64vector-length vec))) + (f64vector-copy! v 0 vec (- len n) len) + v)) + +(define (f64vector-drop vec n) + (let* ((len (f64vector-length vec)) + (vlen (- len n)) + (v (make-f64vector vlen))) + (f64vector-copy! v 0 vec n len) + v)) + +(define (f64vector-drop-right vec n) + (let* ((len (f64vector-length vec)) + (rlen (- len n)) + (v (make-f64vector rlen))) + (f64vector-copy! v 0 vec 0 rlen) + v)) + +(define (f64vector-segment vec n) + (unless (and (integer? n) (positive? n)) + (error "length must be a positive integer" n)) + (let loop ((r '()) (i 0) (remain (f64vector-length vec))) + (if (<= remain 0) + (reverse r) + (let ((size (min n remain))) + (loop + (cons (f64vector-copy vec i (+ i size)) r) + (+ i size) + (- remain size)))))) + +;; aux. procedure +(define (%f64vectors-ref vecs i) + (map (lambda (v) (f64vector-ref v i)) vecs)) + +(define (f64vector-fold kons knil vec . vecs) + (if (null? vecs) + ;; fast path + (let ((len (f64vector-length vec))) + (let loop ((r knil) (i 0)) + (if (= i len) + r + (loop (kons r (f64vector-ref vec i)) (+ i 1))))) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map f64vector-length vecs)))) + (let loop ((r knil) (i 0)) + (if (= i len) + r + (loop (apply kons r (%f64vectors-ref vecs i)) + (+ i 1))))))) + +(define (f64vector-fold-right kons knil vec . vecs) + (if (null? vecs) + ;; fast path + (let ((len (f64vector-length vec))) + (let loop ((r knil) (i (- (f64vector-length vec) 1))) + (if (negative? i) + r + (loop (kons r (f64vector-ref vec i)) (- i 1))))) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map f64vector-length vecs)))) + (let loop ((r knil) (i (- len 1))) + (if (negative? i) + r + (loop (apply kons r (%f64vectors-ref vecs i)) + (- i 1))))))) + +(define (f64vector-map f vec . vecs) + (if (null? vecs) + ;; fast path + (let* ((len (f64vector-length vec)) + (v (make-f64vector len))) + (let loop ((i 0)) + (unless (= i len) + (f64vector-set! v i (f (f64vector-ref vec i))) + (loop (+ i 1)))) + v) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map f64vector-length vecs))) + (v (make-f64vector len))) + (let loop ((i 0)) + (unless (= i len) + (f64vector-set! v i (apply f (%f64vectors-ref vecs i))) + (loop (+ i 1)))) + v))) + + +(define (f64vector-map! f vec . vecs) + (if (null? vecs) + ;; fast path + (let ((len (f64vector-length vec))) + (let loop ((i 0)) + (unless (= i len) + (f64vector-set! vec i (f (f64vector-ref vec i))) + (loop (+ i 1))))) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map f64vector-length vecs)))) + (let loop ((i 0)) + (unless (= i len) + (f64vector-set! vec i (apply f (%f64vectors-ref vecs i))) + (loop (+ i 1))))))) + +(define (f64vector-for-each f vec . vecs) + (if (null? vecs) + ;; fast path + (let ((len (f64vector-length vec))) + (let loop ((i 0)) + (unless (= i len) + (f (f64vector-ref vec i)) + (loop (+ i 1))))) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map f64vector-length vecs)))) + (let loop ((i 0)) + (unless (= i len) + (apply f (%f64vectors-ref vecs i)) + (loop (+ i 1))))))) + +(define (f64vector-count pred vec . vecs) + (if (null? vecs) + ;; fast path + (let ((len (f64vector-length vec))) + (let loop ((i 0) (r 0)) + (cond + ((= i (f64vector-length vec)) r) + ((pred (f64vector-ref vec i)) (loop (+ i 1) (+ r 1))) + (else (loop (+ i 1) r))))) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map f64vector-length vecs)))) + (let loop ((i 0) (r 0)) + (cond + ((= i len) r) + ((apply pred (%f64vectors-ref vecs i)) (loop (+ i 1) (+ r 1))) + (else (loop (+ i 1) r))))))) + +(define (f64vector-cumulate f knil vec) + (let* ((len (f64vector-length vec)) + (v (make-f64vector len))) + (let loop ((r knil) (i 0)) + (unless (= i len) + (let ((next (f r (f64vector-ref vec i)))) + (f64vector-set! v i next) + (loop next (+ i 1))))) + v)) + +(define (f64vector-foreach f vec) + (let ((len (f64vector-length vec))) + (let loop ((i 0)) + (unless (= i len) + (f (f64vector-ref vec i)) + (loop (+ i 1)))))) + +(define (f64vector-take-while pred vec) + (let* ((len (f64vector-length vec)) + (idx (f64vector-skip pred vec)) + (idx* (if idx idx len))) + (f64vector-copy vec 0 idx*))) + +(define (f64vector-take-while-right pred vec) + (let* ((len (f64vector-length vec)) + (idx (f64vector-skip-right pred vec)) + (idx* (if idx (+ idx 1) 0))) + (f64vector-copy vec idx* len))) + +(define (f64vector-drop-while pred vec) + (let* ((len (f64vector-length vec)) + (idx (f64vector-skip pred vec)) + (idx* (if idx idx len))) + (f64vector-copy vec idx* len))) + +(define (f64vector-drop-while-right pred vec) + (let* ((len (f64vector-length vec)) + (idx (f64vector-skip-right pred vec)) + (idx* (if idx idx -1))) + (f64vector-copy vec 0 (+ 1 idx*)))) + +(define (f64vector-index pred vec . vecs) + (if (null? vecs) + ;; fast path + (let ((len (f64vector-length vec))) + (let loop ((i 0)) + (cond + ((= i len) #f) + ((pred (f64vector-ref vec i)) i) + (else (loop (+ i 1)))))) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map f64vector-length vecs)))) + (let loop ((i 0)) + (cond + ((= i len) #f) + ((apply pred (%f64vectors-ref vecs i)) i) + (else (loop (+ i 1)))))))) + +(define (f64vector-index-right pred vec . vecs) + (if (null? vecs) + ;; fast path + (let ((len (f64vector-length vec))) + (let loop ((i (- len 1))) + (cond + ((negative? i) #f) + ((pred (f64vector-ref vec i)) i) + (else (loop (- i 1)))))) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map f64vector-length vecs)))) + (let loop ((i (- len 1))) + (cond + ((negative? i) #f) + ((apply pred (%f64vectors-ref vecs i)) i) + (else (loop (- i 1)))))))) + +(define (f64vector-skip pred vec . vecs) + (if (null? vecs) + (f64vector-index (lambda (x) (not (pred x))) vec) + (apply f64vector-index (lambda xs (not (apply pred xs))) vec vecs))) + +(define (f64vector-skip-right pred vec . vecs) + (if (null? vecs) + (f64vector-index-right (lambda (x) (not (pred x))) vec) + (apply f64vector-index-right (lambda xs (not (apply pred xs))) vec vecs))) + +(define (f64vector-any pred vec . vecs) + (if (null? vecs) + ;; fast path + (let ((len (f64vector-length vec))) + (let loop ((i 0)) + (cond + ((= i len) #f) + ((pred (f64vector-ref vec i))) ;returns result of pred + (else (loop (+ i 1)))))) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map f64vector-length vecs)))) + (let loop ((i 0)) + (cond + ((= i len) #f) + ((apply pred (%f64vectors-ref vecs i))) ;returns result of pred + (else (loop (+ i 1)))))))) + +(define (f64vector-every pred vec . vecs) + (if (null? vecs) + ;; fast path + (let ((len (f64vector-length vec))) + (let loop ((i 0) (last #t)) + (cond + ((= i len) last) + ((pred (f64vector-ref vec i)) => (lambda (r) (loop (+ i 1) r))) + (else #f)))) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map f64vector-length vecs)))) + (let loop ((i 0) (last #t)) + (cond + ((= i len) last) + ((apply pred (%f64vectors-ref vecs i)) => (lambda (r) (loop (+ i 1) r))) + (else #f)))))) + +(define (f64vector-partition pred vec) + (let* ((len (f64vector-length vec)) + (cnt (f64vector-count pred vec)) + (r (make-f64vector len))) + (let loop ((i 0) (yes 0) (no cnt)) + (cond + ((= i len) (values r cnt)) + ((pred (f64vector-ref vec i)) + (f64vector-set! r yes (f64vector-ref vec i)) + (loop (+ i 1) (+ yes 1) no)) + (else + (f64vector-set! r no (f64vector-ref vec i)) + (loop (+ i 1) yes (+ no 1))))))) + +(define (f64vector-filter pred vec) + (let* ((len (f64vector-length vec)) + (cnt (f64vector-count pred vec)) + (r (make-f64vector cnt))) + (let loop ((i 0) (j 0)) + (cond + ((= i len) r) + ((pred (f64vector-ref vec i)) + (f64vector-set! r j (f64vector-ref vec i)) + (loop (+ i 1) (+ j 1))) + (else + (loop (+ i 1) j)))))) + +(define (f64vector-remove pred vec) + (f64vector-filter (lambda (x) (not (pred x))) vec)) + +;; f64vector-set! defined in (srfi 160 base) + +(define (f64vector-swap! vec i j) + (let ((ival (f64vector-ref vec i)) + (jval (f64vector-ref vec j))) + (f64vector-set! vec i jval) + (f64vector-set! vec j ival))) + +(define f64vector-fill! + (case-lambda + ((vec fill) (f64vector-fill-some! vec fill 0 (f64vector-length vec))) + ((vec fill start) (f64vector-fill-some! vec fill start (f64vector-length vec))) + ((vec fill start end) (f64vector-fill-some! vec fill start end)))) + +(define (f64vector-fill-some! vec fill start end) + (unless (= start end) + (f64vector-set! vec start fill) + (f64vector-fill-some! vec fill (+ start 1) end))) + +(define f64vector-reverse! + (case-lambda + ((vec) (f64vector-reverse-some! vec 0 (f64vector-length vec))) + ((vec start) (f64vector-reverse-some! vec start (f64vector-length vec))) + ((vec start end) (f64vector-reverse-some! vec start end)))) + +(define (f64vector-reverse-some! vec start end) + (let loop ((i start) (j (- end 1))) + (when (< i j) + (f64vector-swap! vec i j) + (loop (+ i 1) (- j 1))))) + +(define (f64vector-unfold! f vec start end seed) + (let loop ((i start) (seed seed)) + (when (< i end) + (let-values (((elt seed) (f i seed))) + (f64vector-set! vec i elt) + (loop (+ i 1) seed))))) + +(define (f64vector-unfold-right! f vec start end seed) + (let loop ((i (- end 1)) (seed seed)) + (when (>= i start) + (let-values (((elt seed) (f i seed))) + (f64vector-set! vec i elt) + (loop (- i 1) seed))))) + +(define reverse-f64vector->list + (case-lambda + ((vec) (reverse-f64vector->list* vec 0 (f64vector-length vec))) + ((vec start) (reverse-f64vector->list* vec start (f64vector-length vec))) + ((vec start end) (reverse-f64vector->list* vec start end)))) + +(define (reverse-f64vector->list* vec start end) + (let loop ((i start) (r '())) + (if (= i end) + r + (loop (+ 1 i) (cons (f64vector-ref vec i) r))))) + +(define (reverse-list->f64vector list) + (let* ((len (length list)) + (r (make-f64vector len))) + (let loop ((i 0) (list list)) + (cond + ((= i len) r) + (else + (f64vector-set! r (- len i 1) (car list)) + (loop (+ i 1) (cdr list))))))) + +(define f64vector->vector + (case-lambda + ((vec) (f64vector->vector* vec 0 (f64vector-length vec))) + ((vec start) (f64vector->vector* vec start (f64vector-length vec))) + ((vec start end) (f64vector->vector* vec start end)))) + +(define (f64vector->vector* vec start end) + (let* ((len (- end start)) + (r (make-vector len))) + (let loop ((i start) (o 0)) + (cond + ((= i end) r) + (else + (vector-set! r o (f64vector-ref vec i)) + (loop (+ i 1) (+ o 1))))))) + +(define vector->f64vector + (case-lambda + ((vec) (vector->f64vector* vec 0 (vector-length vec))) + ((vec start) (vector->f64vector* vec start (vector-length vec))) + ((vec start end) (vector->f64vector* vec start end)))) + +(define (vector->f64vector* vec start end) + (let* ((len (- end start)) + (r (make-f64vector len))) + (let loop ((i start) (o 0)) + (cond + ((= i end) r) + (else + (f64vector-set! r o (vector-ref vec i)) + (loop (+ i 1) (+ o 1))))))) + +(define make-f64vector-generator + (case-lambda ((vec) (make-f64vector-generator vec 0 (f64vector-length vec))) + ((vec start) (make-f64vector-generator vec start (f64vector-length vec))) + ((vec start end) + (lambda () (if (>= start end) + (eof-object) + (let ((next (f64vector-ref vec start))) + (set! start (+ start 1)) + next)))))) + +(define write-f64vector + (case-lambda + ((vec) (write-f64vector* vec (current-output-port))) + ((vec port) (write-f64vector* vec port)))) + + +(define (write-f64vector* vec port) + (display "#f64(" port) ; f64-expansion is blind, so will expand this too + (let ((last (- (f64vector-length vec) 1))) + (let loop ((i 0)) + (cond + ((= i last) + (write (f64vector-ref vec i) port) + (display ")" port)) + (else + (write (f64vector-ref vec i) port) + (display " " port) + (loop (+ i 1))))))) + +(define (f64vector< vec1 vec2) + (let ((len1 (f64vector-length vec1)) + (len2 (f64vector-length vec2))) + (cond + ((< len1 len2) + #t) + ((> len1 len2) + #f) + (else + (let loop ((i 0)) + (cond + ((= i len1) + #f) + ((< (f64vector-ref vec1 i) (f64vector-ref vec2 i)) + #t) + ((> (f64vector-ref vec1 i) (f64vector-ref vec2 i)) + #f) + (else + (loop (+ i 1))))))))) + +(define (f64vector-hash vec) + (let ((len (min 256 (f64vector-length vec)))) + (let loop ((i 0) (r 0)) + (if (= i len) + (abs (floor (real-part (inexact->exact r)))) + (loop (+ i 1) (+ r (f64vector-ref vec i))))))) + +(define f64vector-comparator + (make-comparator f64vector? f64vector= f64vector< f64vector-hash)) diff --git a/module/srfi/srfi-160/f64.sld b/module/srfi/srfi-160/f64.sld new file mode 100644 index 000000000..fbaf3a985 --- /dev/null +++ b/module/srfi/srfi-160/f64.sld @@ -0,0 +1,49 @@ +;;; SPDX-FileCopyrightText: 2018 John Cowan +;;; +;;; SPDX-License-Identifier: MIT + +(define-library (srfi srfi-160 f64) + (import (scheme base)) + (import (scheme case-lambda)) + (import (scheme cxr)) + (import (only (scheme r5rs) inexact->exact)) + (import (scheme complex)) + (import (scheme write)) + (import (srfi srfi-128)) + (import (srfi srfi-160 base)) + ;; Constructors + (export make-f64vector f64vector + f64vector-unfold f64vector-unfold-right + f64vector-copy f64vector-reverse-copy + f64vector-append f64vector-concatenate + f64vector-append-subvectors) + ;; Predicates + (export f64? f64vector? f64vector-empty? f64vector=) + ;; Selectors + (export f64vector-ref f64vector-length) + ;; Iteration + (export f64vector-take f64vector-take-right + f64vector-drop f64vector-drop-right + f64vector-segment + f64vector-fold f64vector-fold-right + f64vector-map f64vector-map! f64vector-for-each + f64vector-count f64vector-cumulate) + ;; Searching + (export f64vector-take-while f64vector-take-while-right + f64vector-drop-while f64vector-drop-while-right + f64vector-index f64vector-index-right f64vector-skip f64vector-skip-right + f64vector-any f64vector-every f64vector-partition + f64vector-filter f64vector-remove) + ;; Mutators + (export f64vector-set! f64vector-swap! f64vector-fill! f64vector-reverse! + f64vector-copy! f64vector-reverse-copy! + f64vector-unfold! f64vector-unfold-right!) + ;; Conversion + (export f64vector->list list->f64vector + reverse-f64vector->list reverse-list->f64vector + f64vector->vector vector->f64vector) + ;; Misc + (export make-f64vector-generator f64vector-comparator write-f64vector) + + (include "f64-impl.scm") +) diff --git a/module/srfi/srfi-160/s16-impl.scm b/module/srfi/srfi-160/s16-impl.scm new file mode 100644 index 000000000..8e195c41e --- /dev/null +++ b/module/srfi/srfi-160/s16-impl.scm @@ -0,0 +1,601 @@ +;;; SPDX-FileCopyrightText: 2018 John Cowan +;;; +;;; SPDX-License-Identifier: MIT + +;;; This code is the same for all SRFI 160 vector sizes. +;;; The s16s appearing in the code are expanded to u8, s8, etc. + +;; make-s16vector defined in (srfi 160 base) + +;; s16vector defined in (srfi 160 base) + +(define (s16vector-unfold f len seed) + (let ((v (make-s16vector len))) + (let loop ((i 0) (state seed)) + (unless (= i len) + (let-values (((value newstate) (f i state))) + (s16vector-set! v i value) + (loop (+ i 1) newstate)))) + v)) + +(define (s16vector-unfold-right f len seed) + (let ((v (make-s16vector len))) + (let loop ((i (- len 1)) (state seed)) + (unless (= i -1) + (let-values (((value newstate) (f i state))) + (s16vector-set! v i value) + (loop (- i 1) newstate)))) + v)) + +(define s16vector-copy + (case-lambda + ((vec) (s16vector-copy* vec 0 (s16vector-length vec))) + ((vec start) (s16vector-copy* vec start (s16vector-length vec))) + ((vec start end) (s16vector-copy* vec start end)))) + +(define (s16vector-copy* vec start end) + (let ((v (make-s16vector (- end start)))) + (s16vector-copy! v 0 vec start end) + v)) + +(define s16vector-copy! + (case-lambda + ((to at from) + (s16vector-copy!* to at from 0 (s16vector-length from))) + ((to at from start) + (s16vector-copy!* to at from start (s16vector-length from))) + ((to at from start end) (s16vector-copy!* to at from start end)))) + +(define (s16vector-copy!* to at from start end) + (let loop ((at at) (i start)) + (unless (= i end) + (s16vector-set! to at (s16vector-ref from i)) + (loop (+ at 1) (+ i 1))))) + +(define s16vector-reverse-copy + (case-lambda + ((vec) (s16vector-reverse-copy* vec 0 (s16vector-length vec))) + ((vec start) (s16vector-reverse-copy* vec start (s16vector-length vec))) + ((vec start end) (s16vector-reverse-copy* vec start end)))) + +(define (s16vector-reverse-copy* vec start end) + (let ((v (make-s16vector (- end start)))) + (s16vector-reverse-copy! v 0 vec start end) + v)) + +(define s16vector-reverse-copy! + (case-lambda + ((to at from) + (s16vector-reverse-copy!* to at from 0 (s16vector-length from))) + ((to at from start) + (s16vector-reverse-copy!* to at from start (s16vector-length from))) + ((to at from start end) (s16vector-reverse-copy!* to at from start end)))) + +(define (s16vector-reverse-copy!* to at from start end) + (let loop ((at at) (i (- end 1))) + (unless (< i start) + (s16vector-set! to at (s16vector-ref from i)) + (loop (+ at 1) (- i 1))))) + +(define (s16vector-append . vecs) + (s16vector-concatenate vecs)) + +(define (s16vector-concatenate vecs) + (let ((v (make-s16vector (len-sum vecs)))) + (let loop ((vecs vecs) (at 0)) + (unless (null? vecs) + (let ((vec (car vecs))) + (s16vector-copy! v at vec 0 (s16vector-length vec)) + (loop (cdr vecs) (+ at (s16vector-length vec))))) + v))) + +(define (len-sum vecs) + (if (null? vecs) + 0 + (+ (s16vector-length (car vecs)) + (len-sum (cdr vecs))))) + +(define (s16vector-append-subvectors . args) + (let ((v (make-s16vector (len-subsum args)))) + (let loop ((args args) (at 0)) + (unless (null? args) + (let ((vec (car args)) + (start (cadr args)) + (end (caddr args))) + (s16vector-copy! v at vec start end) + (loop (cdddr args) (+ at (- end start)))))) + v)) + +(define (len-subsum vecs) + (if (null? vecs) + 0 + (+ (- (caddr vecs) (cadr vecs)) + (len-subsum (cdddr vecs))))) + +;; s16? defined in (srfi 160 base) + +;; s16vector? defined in (srfi 160 base) + +(define (s16vector-empty? vec) + (zero? (s16vector-length vec))) + +(define (s16vector= . vecs) + (s16vector=* (car vecs) (cadr vecs) (cddr vecs))) + +(define (s16vector=* vec1 vec2 vecs) + (and (s16dyadic-vecs= vec1 0 (s16vector-length vec1) + vec2 0 (s16vector-length vec2)) + (or (null? vecs) + (s16vector=* vec2 (car vecs) (cdr vecs))))) + +(define (s16dyadic-vecs= vec1 start1 end1 vec2 start2 end2) + (cond + ((not (= end1 end2)) #f) + ((not (< start1 end1)) #t) + ((let ((elt1 (s16vector-ref vec1 start1)) + (elt2 (s16vector-ref vec2 start2))) + (= elt1 elt2)) + (s16dyadic-vecs= vec1 (+ start1 1) end1 + vec2 (+ start2 1) end2)) + (else #f))) + +;; s16vector-ref defined in (srfi 160 base) + +;; s16vector-length defined in (srfi 160 base) + +(define (s16vector-take vec n) + (let ((v (make-s16vector n))) + (s16vector-copy! v 0 vec 0 n) + v)) + +(define (s16vector-take-right vec n) + (let ((v (make-s16vector n)) + (len (s16vector-length vec))) + (s16vector-copy! v 0 vec (- len n) len) + v)) + +(define (s16vector-drop vec n) + (let* ((len (s16vector-length vec)) + (vlen (- len n)) + (v (make-s16vector vlen))) + (s16vector-copy! v 0 vec n len) + v)) + +(define (s16vector-drop-right vec n) + (let* ((len (s16vector-length vec)) + (rlen (- len n)) + (v (make-s16vector rlen))) + (s16vector-copy! v 0 vec 0 rlen) + v)) + +(define (s16vector-segment vec n) + (unless (and (integer? n) (positive? n)) + (error "length must be a positive integer" n)) + (let loop ((r '()) (i 0) (remain (s16vector-length vec))) + (if (<= remain 0) + (reverse r) + (let ((size (min n remain))) + (loop + (cons (s16vector-copy vec i (+ i size)) r) + (+ i size) + (- remain size)))))) + +;; aux. procedure +(define (%s16vectors-ref vecs i) + (map (lambda (v) (s16vector-ref v i)) vecs)) + +(define (s16vector-fold kons knil vec . vecs) + (if (null? vecs) + ;; fast path + (let ((len (s16vector-length vec))) + (let loop ((r knil) (i 0)) + (if (= i len) + r + (loop (kons r (s16vector-ref vec i)) (+ i 1))))) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map s16vector-length vecs)))) + (let loop ((r knil) (i 0)) + (if (= i len) + r + (loop (apply kons r (%s16vectors-ref vecs i)) + (+ i 1))))))) + +(define (s16vector-fold-right kons knil vec . vecs) + (if (null? vecs) + ;; fast path + (let ((len (s16vector-length vec))) + (let loop ((r knil) (i (- (s16vector-length vec) 1))) + (if (negative? i) + r + (loop (kons r (s16vector-ref vec i)) (- i 1))))) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map s16vector-length vecs)))) + (let loop ((r knil) (i (- len 1))) + (if (negative? i) + r + (loop (apply kons r (%s16vectors-ref vecs i)) + (- i 1))))))) + +(define (s16vector-map f vec . vecs) + (if (null? vecs) + ;; fast path + (let* ((len (s16vector-length vec)) + (v (make-s16vector len))) + (let loop ((i 0)) + (unless (= i len) + (s16vector-set! v i (f (s16vector-ref vec i))) + (loop (+ i 1)))) + v) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map s16vector-length vecs))) + (v (make-s16vector len))) + (let loop ((i 0)) + (unless (= i len) + (s16vector-set! v i (apply f (%s16vectors-ref vecs i))) + (loop (+ i 1)))) + v))) + + +(define (s16vector-map! f vec . vecs) + (if (null? vecs) + ;; fast path + (let ((len (s16vector-length vec))) + (let loop ((i 0)) + (unless (= i len) + (s16vector-set! vec i (f (s16vector-ref vec i))) + (loop (+ i 1))))) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map s16vector-length vecs)))) + (let loop ((i 0)) + (unless (= i len) + (s16vector-set! vec i (apply f (%s16vectors-ref vecs i))) + (loop (+ i 1))))))) + +(define (s16vector-for-each f vec . vecs) + (if (null? vecs) + ;; fast path + (let ((len (s16vector-length vec))) + (let loop ((i 0)) + (unless (= i len) + (f (s16vector-ref vec i)) + (loop (+ i 1))))) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map s16vector-length vecs)))) + (let loop ((i 0)) + (unless (= i len) + (apply f (%s16vectors-ref vecs i)) + (loop (+ i 1))))))) + +(define (s16vector-count pred vec . vecs) + (if (null? vecs) + ;; fast path + (let ((len (s16vector-length vec))) + (let loop ((i 0) (r 0)) + (cond + ((= i (s16vector-length vec)) r) + ((pred (s16vector-ref vec i)) (loop (+ i 1) (+ r 1))) + (else (loop (+ i 1) r))))) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map s16vector-length vecs)))) + (let loop ((i 0) (r 0)) + (cond + ((= i len) r) + ((apply pred (%s16vectors-ref vecs i)) (loop (+ i 1) (+ r 1))) + (else (loop (+ i 1) r))))))) + +(define (s16vector-cumulate f knil vec) + (let* ((len (s16vector-length vec)) + (v (make-s16vector len))) + (let loop ((r knil) (i 0)) + (unless (= i len) + (let ((next (f r (s16vector-ref vec i)))) + (s16vector-set! v i next) + (loop next (+ i 1))))) + v)) + +(define (s16vector-foreach f vec) + (let ((len (s16vector-length vec))) + (let loop ((i 0)) + (unless (= i len) + (f (s16vector-ref vec i)) + (loop (+ i 1)))))) + +(define (s16vector-take-while pred vec) + (let* ((len (s16vector-length vec)) + (idx (s16vector-skip pred vec)) + (idx* (if idx idx len))) + (s16vector-copy vec 0 idx*))) + +(define (s16vector-take-while-right pred vec) + (let* ((len (s16vector-length vec)) + (idx (s16vector-skip-right pred vec)) + (idx* (if idx (+ idx 1) 0))) + (s16vector-copy vec idx* len))) + +(define (s16vector-drop-while pred vec) + (let* ((len (s16vector-length vec)) + (idx (s16vector-skip pred vec)) + (idx* (if idx idx len))) + (s16vector-copy vec idx* len))) + +(define (s16vector-drop-while-right pred vec) + (let* ((len (s16vector-length vec)) + (idx (s16vector-skip-right pred vec)) + (idx* (if idx idx -1))) + (s16vector-copy vec 0 (+ 1 idx*)))) + +(define (s16vector-index pred vec . vecs) + (if (null? vecs) + ;; fast path + (let ((len (s16vector-length vec))) + (let loop ((i 0)) + (cond + ((= i len) #f) + ((pred (s16vector-ref vec i)) i) + (else (loop (+ i 1)))))) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map s16vector-length vecs)))) + (let loop ((i 0)) + (cond + ((= i len) #f) + ((apply pred (%s16vectors-ref vecs i)) i) + (else (loop (+ i 1)))))))) + +(define (s16vector-index-right pred vec . vecs) + (if (null? vecs) + ;; fast path + (let ((len (s16vector-length vec))) + (let loop ((i (- len 1))) + (cond + ((negative? i) #f) + ((pred (s16vector-ref vec i)) i) + (else (loop (- i 1)))))) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map s16vector-length vecs)))) + (let loop ((i (- len 1))) + (cond + ((negative? i) #f) + ((apply pred (%s16vectors-ref vecs i)) i) + (else (loop (- i 1)))))))) + +(define (s16vector-skip pred vec . vecs) + (if (null? vecs) + (s16vector-index (lambda (x) (not (pred x))) vec) + (apply s16vector-index (lambda xs (not (apply pred xs))) vec vecs))) + +(define (s16vector-skip-right pred vec . vecs) + (if (null? vecs) + (s16vector-index-right (lambda (x) (not (pred x))) vec) + (apply s16vector-index-right (lambda xs (not (apply pred xs))) vec vecs))) + +(define (s16vector-any pred vec . vecs) + (if (null? vecs) + ;; fast path + (let ((len (s16vector-length vec))) + (let loop ((i 0)) + (cond + ((= i len) #f) + ((pred (s16vector-ref vec i))) ;returns result of pred + (else (loop (+ i 1)))))) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map s16vector-length vecs)))) + (let loop ((i 0)) + (cond + ((= i len) #f) + ((apply pred (%s16vectors-ref vecs i))) ;returns result of pred + (else (loop (+ i 1)))))))) + +(define (s16vector-every pred vec . vecs) + (if (null? vecs) + ;; fast path + (let ((len (s16vector-length vec))) + (let loop ((i 0) (last #t)) + (cond + ((= i len) last) + ((pred (s16vector-ref vec i)) => (lambda (r) (loop (+ i 1) r))) + (else #f)))) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map s16vector-length vecs)))) + (let loop ((i 0) (last #t)) + (cond + ((= i len) last) + ((apply pred (%s16vectors-ref vecs i)) => (lambda (r) (loop (+ i 1) r))) + (else #f)))))) + +(define (s16vector-partition pred vec) + (let* ((len (s16vector-length vec)) + (cnt (s16vector-count pred vec)) + (r (make-s16vector len))) + (let loop ((i 0) (yes 0) (no cnt)) + (cond + ((= i len) (values r cnt)) + ((pred (s16vector-ref vec i)) + (s16vector-set! r yes (s16vector-ref vec i)) + (loop (+ i 1) (+ yes 1) no)) + (else + (s16vector-set! r no (s16vector-ref vec i)) + (loop (+ i 1) yes (+ no 1))))))) + +(define (s16vector-filter pred vec) + (let* ((len (s16vector-length vec)) + (cnt (s16vector-count pred vec)) + (r (make-s16vector cnt))) + (let loop ((i 0) (j 0)) + (cond + ((= i len) r) + ((pred (s16vector-ref vec i)) + (s16vector-set! r j (s16vector-ref vec i)) + (loop (+ i 1) (+ j 1))) + (else + (loop (+ i 1) j)))))) + +(define (s16vector-remove pred vec) + (s16vector-filter (lambda (x) (not (pred x))) vec)) + +;; s16vector-set! defined in (srfi 160 base) + +(define (s16vector-swap! vec i j) + (let ((ival (s16vector-ref vec i)) + (jval (s16vector-ref vec j))) + (s16vector-set! vec i jval) + (s16vector-set! vec j ival))) + +(define s16vector-fill! + (case-lambda + ((vec fill) (s16vector-fill-some! vec fill 0 (s16vector-length vec))) + ((vec fill start) (s16vector-fill-some! vec fill start (s16vector-length vec))) + ((vec fill start end) (s16vector-fill-some! vec fill start end)))) + +(define (s16vector-fill-some! vec fill start end) + (unless (= start end) + (s16vector-set! vec start fill) + (s16vector-fill-some! vec fill (+ start 1) end))) + +(define s16vector-reverse! + (case-lambda + ((vec) (s16vector-reverse-some! vec 0 (s16vector-length vec))) + ((vec start) (s16vector-reverse-some! vec start (s16vector-length vec))) + ((vec start end) (s16vector-reverse-some! vec start end)))) + +(define (s16vector-reverse-some! vec start end) + (let loop ((i start) (j (- end 1))) + (when (< i j) + (s16vector-swap! vec i j) + (loop (+ i 1) (- j 1))))) + +(define (s16vector-unfold! f vec start end seed) + (let loop ((i start) (seed seed)) + (when (< i end) + (let-values (((elt seed) (f i seed))) + (s16vector-set! vec i elt) + (loop (+ i 1) seed))))) + +(define (s16vector-unfold-right! f vec start end seed) + (let loop ((i (- end 1)) (seed seed)) + (when (>= i start) + (let-values (((elt seed) (f i seed))) + (s16vector-set! vec i elt) + (loop (- i 1) seed))))) + +(define reverse-s16vector->list + (case-lambda + ((vec) (reverse-s16vector->list* vec 0 (s16vector-length vec))) + ((vec start) (reverse-s16vector->list* vec start (s16vector-length vec))) + ((vec start end) (reverse-s16vector->list* vec start end)))) + +(define (reverse-s16vector->list* vec start end) + (let loop ((i start) (r '())) + (if (= i end) + r + (loop (+ 1 i) (cons (s16vector-ref vec i) r))))) + +(define (reverse-list->s16vector list) + (let* ((len (length list)) + (r (make-s16vector len))) + (let loop ((i 0) (list list)) + (cond + ((= i len) r) + (else + (s16vector-set! r (- len i 1) (car list)) + (loop (+ i 1) (cdr list))))))) + +(define s16vector->vector + (case-lambda + ((vec) (s16vector->vector* vec 0 (s16vector-length vec))) + ((vec start) (s16vector->vector* vec start (s16vector-length vec))) + ((vec start end) (s16vector->vector* vec start end)))) + +(define (s16vector->vector* vec start end) + (let* ((len (- end start)) + (r (make-vector len))) + (let loop ((i start) (o 0)) + (cond + ((= i end) r) + (else + (vector-set! r o (s16vector-ref vec i)) + (loop (+ i 1) (+ o 1))))))) + +(define vector->s16vector + (case-lambda + ((vec) (vector->s16vector* vec 0 (vector-length vec))) + ((vec start) (vector->s16vector* vec start (vector-length vec))) + ((vec start end) (vector->s16vector* vec start end)))) + +(define (vector->s16vector* vec start end) + (let* ((len (- end start)) + (r (make-s16vector len))) + (let loop ((i start) (o 0)) + (cond + ((= i end) r) + (else + (s16vector-set! r o (vector-ref vec i)) + (loop (+ i 1) (+ o 1))))))) + +(define make-s16vector-generator + (case-lambda ((vec) (make-s16vector-generator vec 0 (s16vector-length vec))) + ((vec start) (make-s16vector-generator vec start (s16vector-length vec))) + ((vec start end) + (lambda () (if (>= start end) + (eof-object) + (let ((next (s16vector-ref vec start))) + (set! start (+ start 1)) + next)))))) + +(define write-s16vector + (case-lambda + ((vec) (write-s16vector* vec (current-output-port))) + ((vec port) (write-s16vector* vec port)))) + + +(define (write-s16vector* vec port) + (display "#s16(" port) ; s16-expansion is blind, so will expand this too + (let ((last (- (s16vector-length vec) 1))) + (let loop ((i 0)) + (cond + ((= i last) + (write (s16vector-ref vec i) port) + (display ")" port)) + (else + (write (s16vector-ref vec i) port) + (display " " port) + (loop (+ i 1))))))) + +(define (s16vector< vec1 vec2) + (let ((len1 (s16vector-length vec1)) + (len2 (s16vector-length vec2))) + (cond + ((< len1 len2) + #t) + ((> len1 len2) + #f) + (else + (let loop ((i 0)) + (cond + ((= i len1) + #f) + ((< (s16vector-ref vec1 i) (s16vector-ref vec2 i)) + #t) + ((> (s16vector-ref vec1 i) (s16vector-ref vec2 i)) + #f) + (else + (loop (+ i 1))))))))) + +(define (s16vector-hash vec) + (let ((len (min 256 (s16vector-length vec)))) + (let loop ((i 0) (r 0)) + (if (= i len) + (abs (floor (real-part (inexact->exact r)))) + (loop (+ i 1) (+ r (s16vector-ref vec i))))))) + +(define s16vector-comparator + (make-comparator s16vector? s16vector= s16vector< s16vector-hash)) diff --git a/module/srfi/srfi-160/s16.sld b/module/srfi/srfi-160/s16.sld new file mode 100644 index 000000000..1d21983f0 --- /dev/null +++ b/module/srfi/srfi-160/s16.sld @@ -0,0 +1,49 @@ +;;; SPDX-FileCopyrightText: 2018 John Cowan +;;; +;;; SPDX-License-Identifier: MIT + +(define-library (srfi srfi-160 s16) + (import (scheme base)) + (import (scheme case-lambda)) + (import (scheme cxr)) + (import (only (scheme r5rs) inexact->exact)) + (import (scheme complex)) + (import (scheme write)) + (import (srfi srfi-128)) + (import (srfi srfi-160 base)) + ;; Constructors + (export make-s16vector s16vector + s16vector-unfold s16vector-unfold-right + s16vector-copy s16vector-reverse-copy + s16vector-append s16vector-concatenate + s16vector-append-subvectors) + ;; Predicates + (export s16? s16vector? s16vector-empty? s16vector=) + ;; Selectors + (export s16vector-ref s16vector-length) + ;; Iteration + (export s16vector-take s16vector-take-right + s16vector-drop s16vector-drop-right + s16vector-segment + s16vector-fold s16vector-fold-right + s16vector-map s16vector-map! s16vector-for-each + s16vector-count s16vector-cumulate) + ;; Searching + (export s16vector-take-while s16vector-take-while-right + s16vector-drop-while s16vector-drop-while-right + s16vector-index s16vector-index-right s16vector-skip s16vector-skip-right + s16vector-any s16vector-every s16vector-partition + s16vector-filter s16vector-remove) + ;; Mutators + (export s16vector-set! s16vector-swap! s16vector-fill! s16vector-reverse! + s16vector-copy! s16vector-reverse-copy! + s16vector-unfold! s16vector-unfold-right!) + ;; Conversion + (export s16vector->list list->s16vector + reverse-s16vector->list reverse-list->s16vector + s16vector->vector vector->s16vector) + ;; Misc + (export make-s16vector-generator s16vector-comparator write-s16vector) + + (include "s16-impl.scm") +) diff --git a/module/srfi/srfi-160/s32-impl.scm b/module/srfi/srfi-160/s32-impl.scm new file mode 100644 index 000000000..1fc7f17bf --- /dev/null +++ b/module/srfi/srfi-160/s32-impl.scm @@ -0,0 +1,601 @@ +;;; SPDX-FileCopyrightText: 2018 John Cowan +;;; +;;; SPDX-License-Identifier: MIT + +;;; This code is the same for all SRFI 160 vector sizes. +;;; The s32s appearing in the code are expanded to u8, s8, etc. + +;; make-s32vector defined in (srfi 160 base) + +;; s32vector defined in (srfi 160 base) + +(define (s32vector-unfold f len seed) + (let ((v (make-s32vector len))) + (let loop ((i 0) (state seed)) + (unless (= i len) + (let-values (((value newstate) (f i state))) + (s32vector-set! v i value) + (loop (+ i 1) newstate)))) + v)) + +(define (s32vector-unfold-right f len seed) + (let ((v (make-s32vector len))) + (let loop ((i (- len 1)) (state seed)) + (unless (= i -1) + (let-values (((value newstate) (f i state))) + (s32vector-set! v i value) + (loop (- i 1) newstate)))) + v)) + +(define s32vector-copy + (case-lambda + ((vec) (s32vector-copy* vec 0 (s32vector-length vec))) + ((vec start) (s32vector-copy* vec start (s32vector-length vec))) + ((vec start end) (s32vector-copy* vec start end)))) + +(define (s32vector-copy* vec start end) + (let ((v (make-s32vector (- end start)))) + (s32vector-copy! v 0 vec start end) + v)) + +(define s32vector-copy! + (case-lambda + ((to at from) + (s32vector-copy!* to at from 0 (s32vector-length from))) + ((to at from start) + (s32vector-copy!* to at from start (s32vector-length from))) + ((to at from start end) (s32vector-copy!* to at from start end)))) + +(define (s32vector-copy!* to at from start end) + (let loop ((at at) (i start)) + (unless (= i end) + (s32vector-set! to at (s32vector-ref from i)) + (loop (+ at 1) (+ i 1))))) + +(define s32vector-reverse-copy + (case-lambda + ((vec) (s32vector-reverse-copy* vec 0 (s32vector-length vec))) + ((vec start) (s32vector-reverse-copy* vec start (s32vector-length vec))) + ((vec start end) (s32vector-reverse-copy* vec start end)))) + +(define (s32vector-reverse-copy* vec start end) + (let ((v (make-s32vector (- end start)))) + (s32vector-reverse-copy! v 0 vec start end) + v)) + +(define s32vector-reverse-copy! + (case-lambda + ((to at from) + (s32vector-reverse-copy!* to at from 0 (s32vector-length from))) + ((to at from start) + (s32vector-reverse-copy!* to at from start (s32vector-length from))) + ((to at from start end) (s32vector-reverse-copy!* to at from start end)))) + +(define (s32vector-reverse-copy!* to at from start end) + (let loop ((at at) (i (- end 1))) + (unless (< i start) + (s32vector-set! to at (s32vector-ref from i)) + (loop (+ at 1) (- i 1))))) + +(define (s32vector-append . vecs) + (s32vector-concatenate vecs)) + +(define (s32vector-concatenate vecs) + (let ((v (make-s32vector (len-sum vecs)))) + (let loop ((vecs vecs) (at 0)) + (unless (null? vecs) + (let ((vec (car vecs))) + (s32vector-copy! v at vec 0 (s32vector-length vec)) + (loop (cdr vecs) (+ at (s32vector-length vec))))) + v))) + +(define (len-sum vecs) + (if (null? vecs) + 0 + (+ (s32vector-length (car vecs)) + (len-sum (cdr vecs))))) + +(define (s32vector-append-subvectors . args) + (let ((v (make-s32vector (len-subsum args)))) + (let loop ((args args) (at 0)) + (unless (null? args) + (let ((vec (car args)) + (start (cadr args)) + (end (caddr args))) + (s32vector-copy! v at vec start end) + (loop (cdddr args) (+ at (- end start)))))) + v)) + +(define (len-subsum vecs) + (if (null? vecs) + 0 + (+ (- (caddr vecs) (cadr vecs)) + (len-subsum (cdddr vecs))))) + +;; s32? defined in (srfi 160 base) + +;; s32vector? defined in (srfi 160 base) + +(define (s32vector-empty? vec) + (zero? (s32vector-length vec))) + +(define (s32vector= . vecs) + (s32vector=* (car vecs) (cadr vecs) (cddr vecs))) + +(define (s32vector=* vec1 vec2 vecs) + (and (s32dyadic-vecs= vec1 0 (s32vector-length vec1) + vec2 0 (s32vector-length vec2)) + (or (null? vecs) + (s32vector=* vec2 (car vecs) (cdr vecs))))) + +(define (s32dyadic-vecs= vec1 start1 end1 vec2 start2 end2) + (cond + ((not (= end1 end2)) #f) + ((not (< start1 end1)) #t) + ((let ((elt1 (s32vector-ref vec1 start1)) + (elt2 (s32vector-ref vec2 start2))) + (= elt1 elt2)) + (s32dyadic-vecs= vec1 (+ start1 1) end1 + vec2 (+ start2 1) end2)) + (else #f))) + +;; s32vector-ref defined in (srfi 160 base) + +;; s32vector-length defined in (srfi 160 base) + +(define (s32vector-take vec n) + (let ((v (make-s32vector n))) + (s32vector-copy! v 0 vec 0 n) + v)) + +(define (s32vector-take-right vec n) + (let ((v (make-s32vector n)) + (len (s32vector-length vec))) + (s32vector-copy! v 0 vec (- len n) len) + v)) + +(define (s32vector-drop vec n) + (let* ((len (s32vector-length vec)) + (vlen (- len n)) + (v (make-s32vector vlen))) + (s32vector-copy! v 0 vec n len) + v)) + +(define (s32vector-drop-right vec n) + (let* ((len (s32vector-length vec)) + (rlen (- len n)) + (v (make-s32vector rlen))) + (s32vector-copy! v 0 vec 0 rlen) + v)) + +(define (s32vector-segment vec n) + (unless (and (integer? n) (positive? n)) + (error "length must be a positive integer" n)) + (let loop ((r '()) (i 0) (remain (s32vector-length vec))) + (if (<= remain 0) + (reverse r) + (let ((size (min n remain))) + (loop + (cons (s32vector-copy vec i (+ i size)) r) + (+ i size) + (- remain size)))))) + +;; aux. procedure +(define (%s32vectors-ref vecs i) + (map (lambda (v) (s32vector-ref v i)) vecs)) + +(define (s32vector-fold kons knil vec . vecs) + (if (null? vecs) + ;; fast path + (let ((len (s32vector-length vec))) + (let loop ((r knil) (i 0)) + (if (= i len) + r + (loop (kons r (s32vector-ref vec i)) (+ i 1))))) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map s32vector-length vecs)))) + (let loop ((r knil) (i 0)) + (if (= i len) + r + (loop (apply kons r (%s32vectors-ref vecs i)) + (+ i 1))))))) + +(define (s32vector-fold-right kons knil vec . vecs) + (if (null? vecs) + ;; fast path + (let ((len (s32vector-length vec))) + (let loop ((r knil) (i (- (s32vector-length vec) 1))) + (if (negative? i) + r + (loop (kons r (s32vector-ref vec i)) (- i 1))))) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map s32vector-length vecs)))) + (let loop ((r knil) (i (- len 1))) + (if (negative? i) + r + (loop (apply kons r (%s32vectors-ref vecs i)) + (- i 1))))))) + +(define (s32vector-map f vec . vecs) + (if (null? vecs) + ;; fast path + (let* ((len (s32vector-length vec)) + (v (make-s32vector len))) + (let loop ((i 0)) + (unless (= i len) + (s32vector-set! v i (f (s32vector-ref vec i))) + (loop (+ i 1)))) + v) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map s32vector-length vecs))) + (v (make-s32vector len))) + (let loop ((i 0)) + (unless (= i len) + (s32vector-set! v i (apply f (%s32vectors-ref vecs i))) + (loop (+ i 1)))) + v))) + + +(define (s32vector-map! f vec . vecs) + (if (null? vecs) + ;; fast path + (let ((len (s32vector-length vec))) + (let loop ((i 0)) + (unless (= i len) + (s32vector-set! vec i (f (s32vector-ref vec i))) + (loop (+ i 1))))) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map s32vector-length vecs)))) + (let loop ((i 0)) + (unless (= i len) + (s32vector-set! vec i (apply f (%s32vectors-ref vecs i))) + (loop (+ i 1))))))) + +(define (s32vector-for-each f vec . vecs) + (if (null? vecs) + ;; fast path + (let ((len (s32vector-length vec))) + (let loop ((i 0)) + (unless (= i len) + (f (s32vector-ref vec i)) + (loop (+ i 1))))) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map s32vector-length vecs)))) + (let loop ((i 0)) + (unless (= i len) + (apply f (%s32vectors-ref vecs i)) + (loop (+ i 1))))))) + +(define (s32vector-count pred vec . vecs) + (if (null? vecs) + ;; fast path + (let ((len (s32vector-length vec))) + (let loop ((i 0) (r 0)) + (cond + ((= i (s32vector-length vec)) r) + ((pred (s32vector-ref vec i)) (loop (+ i 1) (+ r 1))) + (else (loop (+ i 1) r))))) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map s32vector-length vecs)))) + (let loop ((i 0) (r 0)) + (cond + ((= i len) r) + ((apply pred (%s32vectors-ref vecs i)) (loop (+ i 1) (+ r 1))) + (else (loop (+ i 1) r))))))) + +(define (s32vector-cumulate f knil vec) + (let* ((len (s32vector-length vec)) + (v (make-s32vector len))) + (let loop ((r knil) (i 0)) + (unless (= i len) + (let ((next (f r (s32vector-ref vec i)))) + (s32vector-set! v i next) + (loop next (+ i 1))))) + v)) + +(define (s32vector-foreach f vec) + (let ((len (s32vector-length vec))) + (let loop ((i 0)) + (unless (= i len) + (f (s32vector-ref vec i)) + (loop (+ i 1)))))) + +(define (s32vector-take-while pred vec) + (let* ((len (s32vector-length vec)) + (idx (s32vector-skip pred vec)) + (idx* (if idx idx len))) + (s32vector-copy vec 0 idx*))) + +(define (s32vector-take-while-right pred vec) + (let* ((len (s32vector-length vec)) + (idx (s32vector-skip-right pred vec)) + (idx* (if idx (+ idx 1) 0))) + (s32vector-copy vec idx* len))) + +(define (s32vector-drop-while pred vec) + (let* ((len (s32vector-length vec)) + (idx (s32vector-skip pred vec)) + (idx* (if idx idx len))) + (s32vector-copy vec idx* len))) + +(define (s32vector-drop-while-right pred vec) + (let* ((len (s32vector-length vec)) + (idx (s32vector-skip-right pred vec)) + (idx* (if idx idx -1))) + (s32vector-copy vec 0 (+ 1 idx*)))) + +(define (s32vector-index pred vec . vecs) + (if (null? vecs) + ;; fast path + (let ((len (s32vector-length vec))) + (let loop ((i 0)) + (cond + ((= i len) #f) + ((pred (s32vector-ref vec i)) i) + (else (loop (+ i 1)))))) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map s32vector-length vecs)))) + (let loop ((i 0)) + (cond + ((= i len) #f) + ((apply pred (%s32vectors-ref vecs i)) i) + (else (loop (+ i 1)))))))) + +(define (s32vector-index-right pred vec . vecs) + (if (null? vecs) + ;; fast path + (let ((len (s32vector-length vec))) + (let loop ((i (- len 1))) + (cond + ((negative? i) #f) + ((pred (s32vector-ref vec i)) i) + (else (loop (- i 1)))))) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map s32vector-length vecs)))) + (let loop ((i (- len 1))) + (cond + ((negative? i) #f) + ((apply pred (%s32vectors-ref vecs i)) i) + (else (loop (- i 1)))))))) + +(define (s32vector-skip pred vec . vecs) + (if (null? vecs) + (s32vector-index (lambda (x) (not (pred x))) vec) + (apply s32vector-index (lambda xs (not (apply pred xs))) vec vecs))) + +(define (s32vector-skip-right pred vec . vecs) + (if (null? vecs) + (s32vector-index-right (lambda (x) (not (pred x))) vec) + (apply s32vector-index-right (lambda xs (not (apply pred xs))) vec vecs))) + +(define (s32vector-any pred vec . vecs) + (if (null? vecs) + ;; fast path + (let ((len (s32vector-length vec))) + (let loop ((i 0)) + (cond + ((= i len) #f) + ((pred (s32vector-ref vec i))) ;returns result of pred + (else (loop (+ i 1)))))) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map s32vector-length vecs)))) + (let loop ((i 0)) + (cond + ((= i len) #f) + ((apply pred (%s32vectors-ref vecs i))) ;returns result of pred + (else (loop (+ i 1)))))))) + +(define (s32vector-every pred vec . vecs) + (if (null? vecs) + ;; fast path + (let ((len (s32vector-length vec))) + (let loop ((i 0) (last #t)) + (cond + ((= i len) last) + ((pred (s32vector-ref vec i)) => (lambda (r) (loop (+ i 1) r))) + (else #f)))) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map s32vector-length vecs)))) + (let loop ((i 0) (last #t)) + (cond + ((= i len) last) + ((apply pred (%s32vectors-ref vecs i)) => (lambda (r) (loop (+ i 1) r))) + (else #f)))))) + +(define (s32vector-partition pred vec) + (let* ((len (s32vector-length vec)) + (cnt (s32vector-count pred vec)) + (r (make-s32vector len))) + (let loop ((i 0) (yes 0) (no cnt)) + (cond + ((= i len) (values r cnt)) + ((pred (s32vector-ref vec i)) + (s32vector-set! r yes (s32vector-ref vec i)) + (loop (+ i 1) (+ yes 1) no)) + (else + (s32vector-set! r no (s32vector-ref vec i)) + (loop (+ i 1) yes (+ no 1))))))) + +(define (s32vector-filter pred vec) + (let* ((len (s32vector-length vec)) + (cnt (s32vector-count pred vec)) + (r (make-s32vector cnt))) + (let loop ((i 0) (j 0)) + (cond + ((= i len) r) + ((pred (s32vector-ref vec i)) + (s32vector-set! r j (s32vector-ref vec i)) + (loop (+ i 1) (+ j 1))) + (else + (loop (+ i 1) j)))))) + +(define (s32vector-remove pred vec) + (s32vector-filter (lambda (x) (not (pred x))) vec)) + +;; s32vector-set! defined in (srfi 160 base) + +(define (s32vector-swap! vec i j) + (let ((ival (s32vector-ref vec i)) + (jval (s32vector-ref vec j))) + (s32vector-set! vec i jval) + (s32vector-set! vec j ival))) + +(define s32vector-fill! + (case-lambda + ((vec fill) (s32vector-fill-some! vec fill 0 (s32vector-length vec))) + ((vec fill start) (s32vector-fill-some! vec fill start (s32vector-length vec))) + ((vec fill start end) (s32vector-fill-some! vec fill start end)))) + +(define (s32vector-fill-some! vec fill start end) + (unless (= start end) + (s32vector-set! vec start fill) + (s32vector-fill-some! vec fill (+ start 1) end))) + +(define s32vector-reverse! + (case-lambda + ((vec) (s32vector-reverse-some! vec 0 (s32vector-length vec))) + ((vec start) (s32vector-reverse-some! vec start (s32vector-length vec))) + ((vec start end) (s32vector-reverse-some! vec start end)))) + +(define (s32vector-reverse-some! vec start end) + (let loop ((i start) (j (- end 1))) + (when (< i j) + (s32vector-swap! vec i j) + (loop (+ i 1) (- j 1))))) + +(define (s32vector-unfold! f vec start end seed) + (let loop ((i start) (seed seed)) + (when (< i end) + (let-values (((elt seed) (f i seed))) + (s32vector-set! vec i elt) + (loop (+ i 1) seed))))) + +(define (s32vector-unfold-right! f vec start end seed) + (let loop ((i (- end 1)) (seed seed)) + (when (>= i start) + (let-values (((elt seed) (f i seed))) + (s32vector-set! vec i elt) + (loop (- i 1) seed))))) + +(define reverse-s32vector->list + (case-lambda + ((vec) (reverse-s32vector->list* vec 0 (s32vector-length vec))) + ((vec start) (reverse-s32vector->list* vec start (s32vector-length vec))) + ((vec start end) (reverse-s32vector->list* vec start end)))) + +(define (reverse-s32vector->list* vec start end) + (let loop ((i start) (r '())) + (if (= i end) + r + (loop (+ 1 i) (cons (s32vector-ref vec i) r))))) + +(define (reverse-list->s32vector list) + (let* ((len (length list)) + (r (make-s32vector len))) + (let loop ((i 0) (list list)) + (cond + ((= i len) r) + (else + (s32vector-set! r (- len i 1) (car list)) + (loop (+ i 1) (cdr list))))))) + +(define s32vector->vector + (case-lambda + ((vec) (s32vector->vector* vec 0 (s32vector-length vec))) + ((vec start) (s32vector->vector* vec start (s32vector-length vec))) + ((vec start end) (s32vector->vector* vec start end)))) + +(define (s32vector->vector* vec start end) + (let* ((len (- end start)) + (r (make-vector len))) + (let loop ((i start) (o 0)) + (cond + ((= i end) r) + (else + (vector-set! r o (s32vector-ref vec i)) + (loop (+ i 1) (+ o 1))))))) + +(define vector->s32vector + (case-lambda + ((vec) (vector->s32vector* vec 0 (vector-length vec))) + ((vec start) (vector->s32vector* vec start (vector-length vec))) + ((vec start end) (vector->s32vector* vec start end)))) + +(define (vector->s32vector* vec start end) + (let* ((len (- end start)) + (r (make-s32vector len))) + (let loop ((i start) (o 0)) + (cond + ((= i end) r) + (else + (s32vector-set! r o (vector-ref vec i)) + (loop (+ i 1) (+ o 1))))))) + +(define make-s32vector-generator + (case-lambda ((vec) (make-s32vector-generator vec 0 (s32vector-length vec))) + ((vec start) (make-s32vector-generator vec start (s32vector-length vec))) + ((vec start end) + (lambda () (if (>= start end) + (eof-object) + (let ((next (s32vector-ref vec start))) + (set! start (+ start 1)) + next)))))) + +(define write-s32vector + (case-lambda + ((vec) (write-s32vector* vec (current-output-port))) + ((vec port) (write-s32vector* vec port)))) + + +(define (write-s32vector* vec port) + (display "#s32(" port) ; s32-expansion is blind, so will expand this too + (let ((last (- (s32vector-length vec) 1))) + (let loop ((i 0)) + (cond + ((= i last) + (write (s32vector-ref vec i) port) + (display ")" port)) + (else + (write (s32vector-ref vec i) port) + (display " " port) + (loop (+ i 1))))))) + +(define (s32vector< vec1 vec2) + (let ((len1 (s32vector-length vec1)) + (len2 (s32vector-length vec2))) + (cond + ((< len1 len2) + #t) + ((> len1 len2) + #f) + (else + (let loop ((i 0)) + (cond + ((= i len1) + #f) + ((< (s32vector-ref vec1 i) (s32vector-ref vec2 i)) + #t) + ((> (s32vector-ref vec1 i) (s32vector-ref vec2 i)) + #f) + (else + (loop (+ i 1))))))))) + +(define (s32vector-hash vec) + (let ((len (min 256 (s32vector-length vec)))) + (let loop ((i 0) (r 0)) + (if (= i len) + (abs (floor (real-part (inexact->exact r)))) + (loop (+ i 1) (+ r (s32vector-ref vec i))))))) + +(define s32vector-comparator + (make-comparator s32vector? s32vector= s32vector< s32vector-hash)) diff --git a/module/srfi/srfi-160/s32.sld b/module/srfi/srfi-160/s32.sld new file mode 100644 index 000000000..a034b0093 --- /dev/null +++ b/module/srfi/srfi-160/s32.sld @@ -0,0 +1,49 @@ +;;; SPDX-FileCopyrightText: 2018 John Cowan +;;; +;;; SPDX-License-Identifier: MIT + +(define-library (srfi srfi-160 s32) + (import (scheme base)) + (import (scheme case-lambda)) + (import (scheme cxr)) + (import (only (scheme r5rs) inexact->exact)) + (import (scheme complex)) + (import (scheme write)) + (import (srfi srfi-128)) + (import (srfi srfi-160 base)) + ;; Constructors + (export make-s32vector s32vector + s32vector-unfold s32vector-unfold-right + s32vector-copy s32vector-reverse-copy + s32vector-append s32vector-concatenate + s32vector-append-subvectors) + ;; Predicates + (export s32? s32vector? s32vector-empty? s32vector=) + ;; Selectors + (export s32vector-ref s32vector-length) + ;; Iteration + (export s32vector-take s32vector-take-right + s32vector-drop s32vector-drop-right + s32vector-segment + s32vector-fold s32vector-fold-right + s32vector-map s32vector-map! s32vector-for-each + s32vector-count s32vector-cumulate) + ;; Searching + (export s32vector-take-while s32vector-take-while-right + s32vector-drop-while s32vector-drop-while-right + s32vector-index s32vector-index-right s32vector-skip s32vector-skip-right + s32vector-any s32vector-every s32vector-partition + s32vector-filter s32vector-remove) + ;; Mutators + (export s32vector-set! s32vector-swap! s32vector-fill! s32vector-reverse! + s32vector-copy! s32vector-reverse-copy! + s32vector-unfold! s32vector-unfold-right!) + ;; Conversion + (export s32vector->list list->s32vector + reverse-s32vector->list reverse-list->s32vector + s32vector->vector vector->s32vector) + ;; Misc + (export make-s32vector-generator s32vector-comparator write-s32vector) + + (include "s32-impl.scm") +) diff --git a/module/srfi/srfi-160/s64-impl.scm b/module/srfi/srfi-160/s64-impl.scm new file mode 100644 index 000000000..aabe8a8b5 --- /dev/null +++ b/module/srfi/srfi-160/s64-impl.scm @@ -0,0 +1,601 @@ +;;; SPDX-FileCopyrightText: 2018 John Cowan +;;; +;;; SPDX-License-Identifier: MIT + +;;; This code is the same for all SRFI 160 vector sizes. +;;; The s64s appearing in the code are expanded to u8, s8, etc. + +;; make-s64vector defined in (srfi 160 base) + +;; s64vector defined in (srfi 160 base) + +(define (s64vector-unfold f len seed) + (let ((v (make-s64vector len))) + (let loop ((i 0) (state seed)) + (unless (= i len) + (let-values (((value newstate) (f i state))) + (s64vector-set! v i value) + (loop (+ i 1) newstate)))) + v)) + +(define (s64vector-unfold-right f len seed) + (let ((v (make-s64vector len))) + (let loop ((i (- len 1)) (state seed)) + (unless (= i -1) + (let-values (((value newstate) (f i state))) + (s64vector-set! v i value) + (loop (- i 1) newstate)))) + v)) + +(define s64vector-copy + (case-lambda + ((vec) (s64vector-copy* vec 0 (s64vector-length vec))) + ((vec start) (s64vector-copy* vec start (s64vector-length vec))) + ((vec start end) (s64vector-copy* vec start end)))) + +(define (s64vector-copy* vec start end) + (let ((v (make-s64vector (- end start)))) + (s64vector-copy! v 0 vec start end) + v)) + +(define s64vector-copy! + (case-lambda + ((to at from) + (s64vector-copy!* to at from 0 (s64vector-length from))) + ((to at from start) + (s64vector-copy!* to at from start (s64vector-length from))) + ((to at from start end) (s64vector-copy!* to at from start end)))) + +(define (s64vector-copy!* to at from start end) + (let loop ((at at) (i start)) + (unless (= i end) + (s64vector-set! to at (s64vector-ref from i)) + (loop (+ at 1) (+ i 1))))) + +(define s64vector-reverse-copy + (case-lambda + ((vec) (s64vector-reverse-copy* vec 0 (s64vector-length vec))) + ((vec start) (s64vector-reverse-copy* vec start (s64vector-length vec))) + ((vec start end) (s64vector-reverse-copy* vec start end)))) + +(define (s64vector-reverse-copy* vec start end) + (let ((v (make-s64vector (- end start)))) + (s64vector-reverse-copy! v 0 vec start end) + v)) + +(define s64vector-reverse-copy! + (case-lambda + ((to at from) + (s64vector-reverse-copy!* to at from 0 (s64vector-length from))) + ((to at from start) + (s64vector-reverse-copy!* to at from start (s64vector-length from))) + ((to at from start end) (s64vector-reverse-copy!* to at from start end)))) + +(define (s64vector-reverse-copy!* to at from start end) + (let loop ((at at) (i (- end 1))) + (unless (< i start) + (s64vector-set! to at (s64vector-ref from i)) + (loop (+ at 1) (- i 1))))) + +(define (s64vector-append . vecs) + (s64vector-concatenate vecs)) + +(define (s64vector-concatenate vecs) + (let ((v (make-s64vector (len-sum vecs)))) + (let loop ((vecs vecs) (at 0)) + (unless (null? vecs) + (let ((vec (car vecs))) + (s64vector-copy! v at vec 0 (s64vector-length vec)) + (loop (cdr vecs) (+ at (s64vector-length vec))))) + v))) + +(define (len-sum vecs) + (if (null? vecs) + 0 + (+ (s64vector-length (car vecs)) + (len-sum (cdr vecs))))) + +(define (s64vector-append-subvectors . args) + (let ((v (make-s64vector (len-subsum args)))) + (let loop ((args args) (at 0)) + (unless (null? args) + (let ((vec (car args)) + (start (cadr args)) + (end (caddr args))) + (s64vector-copy! v at vec start end) + (loop (cdddr args) (+ at (- end start)))))) + v)) + +(define (len-subsum vecs) + (if (null? vecs) + 0 + (+ (- (caddr vecs) (cadr vecs)) + (len-subsum (cdddr vecs))))) + +;; s64? defined in (srfi 160 base) + +;; s64vector? defined in (srfi 160 base) + +(define (s64vector-empty? vec) + (zero? (s64vector-length vec))) + +(define (s64vector= . vecs) + (s64vector=* (car vecs) (cadr vecs) (cddr vecs))) + +(define (s64vector=* vec1 vec2 vecs) + (and (s64dyadic-vecs= vec1 0 (s64vector-length vec1) + vec2 0 (s64vector-length vec2)) + (or (null? vecs) + (s64vector=* vec2 (car vecs) (cdr vecs))))) + +(define (s64dyadic-vecs= vec1 start1 end1 vec2 start2 end2) + (cond + ((not (= end1 end2)) #f) + ((not (< start1 end1)) #t) + ((let ((elt1 (s64vector-ref vec1 start1)) + (elt2 (s64vector-ref vec2 start2))) + (= elt1 elt2)) + (s64dyadic-vecs= vec1 (+ start1 1) end1 + vec2 (+ start2 1) end2)) + (else #f))) + +;; s64vector-ref defined in (srfi 160 base) + +;; s64vector-length defined in (srfi 160 base) + +(define (s64vector-take vec n) + (let ((v (make-s64vector n))) + (s64vector-copy! v 0 vec 0 n) + v)) + +(define (s64vector-take-right vec n) + (let ((v (make-s64vector n)) + (len (s64vector-length vec))) + (s64vector-copy! v 0 vec (- len n) len) + v)) + +(define (s64vector-drop vec n) + (let* ((len (s64vector-length vec)) + (vlen (- len n)) + (v (make-s64vector vlen))) + (s64vector-copy! v 0 vec n len) + v)) + +(define (s64vector-drop-right vec n) + (let* ((len (s64vector-length vec)) + (rlen (- len n)) + (v (make-s64vector rlen))) + (s64vector-copy! v 0 vec 0 rlen) + v)) + +(define (s64vector-segment vec n) + (unless (and (integer? n) (positive? n)) + (error "length must be a positive integer" n)) + (let loop ((r '()) (i 0) (remain (s64vector-length vec))) + (if (<= remain 0) + (reverse r) + (let ((size (min n remain))) + (loop + (cons (s64vector-copy vec i (+ i size)) r) + (+ i size) + (- remain size)))))) + +;; aux. procedure +(define (%s64vectors-ref vecs i) + (map (lambda (v) (s64vector-ref v i)) vecs)) + +(define (s64vector-fold kons knil vec . vecs) + (if (null? vecs) + ;; fast path + (let ((len (s64vector-length vec))) + (let loop ((r knil) (i 0)) + (if (= i len) + r + (loop (kons r (s64vector-ref vec i)) (+ i 1))))) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map s64vector-length vecs)))) + (let loop ((r knil) (i 0)) + (if (= i len) + r + (loop (apply kons r (%s64vectors-ref vecs i)) + (+ i 1))))))) + +(define (s64vector-fold-right kons knil vec . vecs) + (if (null? vecs) + ;; fast path + (let ((len (s64vector-length vec))) + (let loop ((r knil) (i (- (s64vector-length vec) 1))) + (if (negative? i) + r + (loop (kons r (s64vector-ref vec i)) (- i 1))))) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map s64vector-length vecs)))) + (let loop ((r knil) (i (- len 1))) + (if (negative? i) + r + (loop (apply kons r (%s64vectors-ref vecs i)) + (- i 1))))))) + +(define (s64vector-map f vec . vecs) + (if (null? vecs) + ;; fast path + (let* ((len (s64vector-length vec)) + (v (make-s64vector len))) + (let loop ((i 0)) + (unless (= i len) + (s64vector-set! v i (f (s64vector-ref vec i))) + (loop (+ i 1)))) + v) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map s64vector-length vecs))) + (v (make-s64vector len))) + (let loop ((i 0)) + (unless (= i len) + (s64vector-set! v i (apply f (%s64vectors-ref vecs i))) + (loop (+ i 1)))) + v))) + + +(define (s64vector-map! f vec . vecs) + (if (null? vecs) + ;; fast path + (let ((len (s64vector-length vec))) + (let loop ((i 0)) + (unless (= i len) + (s64vector-set! vec i (f (s64vector-ref vec i))) + (loop (+ i 1))))) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map s64vector-length vecs)))) + (let loop ((i 0)) + (unless (= i len) + (s64vector-set! vec i (apply f (%s64vectors-ref vecs i))) + (loop (+ i 1))))))) + +(define (s64vector-for-each f vec . vecs) + (if (null? vecs) + ;; fast path + (let ((len (s64vector-length vec))) + (let loop ((i 0)) + (unless (= i len) + (f (s64vector-ref vec i)) + (loop (+ i 1))))) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map s64vector-length vecs)))) + (let loop ((i 0)) + (unless (= i len) + (apply f (%s64vectors-ref vecs i)) + (loop (+ i 1))))))) + +(define (s64vector-count pred vec . vecs) + (if (null? vecs) + ;; fast path + (let ((len (s64vector-length vec))) + (let loop ((i 0) (r 0)) + (cond + ((= i (s64vector-length vec)) r) + ((pred (s64vector-ref vec i)) (loop (+ i 1) (+ r 1))) + (else (loop (+ i 1) r))))) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map s64vector-length vecs)))) + (let loop ((i 0) (r 0)) + (cond + ((= i len) r) + ((apply pred (%s64vectors-ref vecs i)) (loop (+ i 1) (+ r 1))) + (else (loop (+ i 1) r))))))) + +(define (s64vector-cumulate f knil vec) + (let* ((len (s64vector-length vec)) + (v (make-s64vector len))) + (let loop ((r knil) (i 0)) + (unless (= i len) + (let ((next (f r (s64vector-ref vec i)))) + (s64vector-set! v i next) + (loop next (+ i 1))))) + v)) + +(define (s64vector-foreach f vec) + (let ((len (s64vector-length vec))) + (let loop ((i 0)) + (unless (= i len) + (f (s64vector-ref vec i)) + (loop (+ i 1)))))) + +(define (s64vector-take-while pred vec) + (let* ((len (s64vector-length vec)) + (idx (s64vector-skip pred vec)) + (idx* (if idx idx len))) + (s64vector-copy vec 0 idx*))) + +(define (s64vector-take-while-right pred vec) + (let* ((len (s64vector-length vec)) + (idx (s64vector-skip-right pred vec)) + (idx* (if idx (+ idx 1) 0))) + (s64vector-copy vec idx* len))) + +(define (s64vector-drop-while pred vec) + (let* ((len (s64vector-length vec)) + (idx (s64vector-skip pred vec)) + (idx* (if idx idx len))) + (s64vector-copy vec idx* len))) + +(define (s64vector-drop-while-right pred vec) + (let* ((len (s64vector-length vec)) + (idx (s64vector-skip-right pred vec)) + (idx* (if idx idx -1))) + (s64vector-copy vec 0 (+ 1 idx*)))) + +(define (s64vector-index pred vec . vecs) + (if (null? vecs) + ;; fast path + (let ((len (s64vector-length vec))) + (let loop ((i 0)) + (cond + ((= i len) #f) + ((pred (s64vector-ref vec i)) i) + (else (loop (+ i 1)))))) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map s64vector-length vecs)))) + (let loop ((i 0)) + (cond + ((= i len) #f) + ((apply pred (%s64vectors-ref vecs i)) i) + (else (loop (+ i 1)))))))) + +(define (s64vector-index-right pred vec . vecs) + (if (null? vecs) + ;; fast path + (let ((len (s64vector-length vec))) + (let loop ((i (- len 1))) + (cond + ((negative? i) #f) + ((pred (s64vector-ref vec i)) i) + (else (loop (- i 1)))))) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map s64vector-length vecs)))) + (let loop ((i (- len 1))) + (cond + ((negative? i) #f) + ((apply pred (%s64vectors-ref vecs i)) i) + (else (loop (- i 1)))))))) + +(define (s64vector-skip pred vec . vecs) + (if (null? vecs) + (s64vector-index (lambda (x) (not (pred x))) vec) + (apply s64vector-index (lambda xs (not (apply pred xs))) vec vecs))) + +(define (s64vector-skip-right pred vec . vecs) + (if (null? vecs) + (s64vector-index-right (lambda (x) (not (pred x))) vec) + (apply s64vector-index-right (lambda xs (not (apply pred xs))) vec vecs))) + +(define (s64vector-any pred vec . vecs) + (if (null? vecs) + ;; fast path + (let ((len (s64vector-length vec))) + (let loop ((i 0)) + (cond + ((= i len) #f) + ((pred (s64vector-ref vec i))) ;returns result of pred + (else (loop (+ i 1)))))) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map s64vector-length vecs)))) + (let loop ((i 0)) + (cond + ((= i len) #f) + ((apply pred (%s64vectors-ref vecs i))) ;returns result of pred + (else (loop (+ i 1)))))))) + +(define (s64vector-every pred vec . vecs) + (if (null? vecs) + ;; fast path + (let ((len (s64vector-length vec))) + (let loop ((i 0) (last #t)) + (cond + ((= i len) last) + ((pred (s64vector-ref vec i)) => (lambda (r) (loop (+ i 1) r))) + (else #f)))) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map s64vector-length vecs)))) + (let loop ((i 0) (last #t)) + (cond + ((= i len) last) + ((apply pred (%s64vectors-ref vecs i)) => (lambda (r) (loop (+ i 1) r))) + (else #f)))))) + +(define (s64vector-partition pred vec) + (let* ((len (s64vector-length vec)) + (cnt (s64vector-count pred vec)) + (r (make-s64vector len))) + (let loop ((i 0) (yes 0) (no cnt)) + (cond + ((= i len) (values r cnt)) + ((pred (s64vector-ref vec i)) + (s64vector-set! r yes (s64vector-ref vec i)) + (loop (+ i 1) (+ yes 1) no)) + (else + (s64vector-set! r no (s64vector-ref vec i)) + (loop (+ i 1) yes (+ no 1))))))) + +(define (s64vector-filter pred vec) + (let* ((len (s64vector-length vec)) + (cnt (s64vector-count pred vec)) + (r (make-s64vector cnt))) + (let loop ((i 0) (j 0)) + (cond + ((= i len) r) + ((pred (s64vector-ref vec i)) + (s64vector-set! r j (s64vector-ref vec i)) + (loop (+ i 1) (+ j 1))) + (else + (loop (+ i 1) j)))))) + +(define (s64vector-remove pred vec) + (s64vector-filter (lambda (x) (not (pred x))) vec)) + +;; s64vector-set! defined in (srfi 160 base) + +(define (s64vector-swap! vec i j) + (let ((ival (s64vector-ref vec i)) + (jval (s64vector-ref vec j))) + (s64vector-set! vec i jval) + (s64vector-set! vec j ival))) + +(define s64vector-fill! + (case-lambda + ((vec fill) (s64vector-fill-some! vec fill 0 (s64vector-length vec))) + ((vec fill start) (s64vector-fill-some! vec fill start (s64vector-length vec))) + ((vec fill start end) (s64vector-fill-some! vec fill start end)))) + +(define (s64vector-fill-some! vec fill start end) + (unless (= start end) + (s64vector-set! vec start fill) + (s64vector-fill-some! vec fill (+ start 1) end))) + +(define s64vector-reverse! + (case-lambda + ((vec) (s64vector-reverse-some! vec 0 (s64vector-length vec))) + ((vec start) (s64vector-reverse-some! vec start (s64vector-length vec))) + ((vec start end) (s64vector-reverse-some! vec start end)))) + +(define (s64vector-reverse-some! vec start end) + (let loop ((i start) (j (- end 1))) + (when (< i j) + (s64vector-swap! vec i j) + (loop (+ i 1) (- j 1))))) + +(define (s64vector-unfold! f vec start end seed) + (let loop ((i start) (seed seed)) + (when (< i end) + (let-values (((elt seed) (f i seed))) + (s64vector-set! vec i elt) + (loop (+ i 1) seed))))) + +(define (s64vector-unfold-right! f vec start end seed) + (let loop ((i (- end 1)) (seed seed)) + (when (>= i start) + (let-values (((elt seed) (f i seed))) + (s64vector-set! vec i elt) + (loop (- i 1) seed))))) + +(define reverse-s64vector->list + (case-lambda + ((vec) (reverse-s64vector->list* vec 0 (s64vector-length vec))) + ((vec start) (reverse-s64vector->list* vec start (s64vector-length vec))) + ((vec start end) (reverse-s64vector->list* vec start end)))) + +(define (reverse-s64vector->list* vec start end) + (let loop ((i start) (r '())) + (if (= i end) + r + (loop (+ 1 i) (cons (s64vector-ref vec i) r))))) + +(define (reverse-list->s64vector list) + (let* ((len (length list)) + (r (make-s64vector len))) + (let loop ((i 0) (list list)) + (cond + ((= i len) r) + (else + (s64vector-set! r (- len i 1) (car list)) + (loop (+ i 1) (cdr list))))))) + +(define s64vector->vector + (case-lambda + ((vec) (s64vector->vector* vec 0 (s64vector-length vec))) + ((vec start) (s64vector->vector* vec start (s64vector-length vec))) + ((vec start end) (s64vector->vector* vec start end)))) + +(define (s64vector->vector* vec start end) + (let* ((len (- end start)) + (r (make-vector len))) + (let loop ((i start) (o 0)) + (cond + ((= i end) r) + (else + (vector-set! r o (s64vector-ref vec i)) + (loop (+ i 1) (+ o 1))))))) + +(define vector->s64vector + (case-lambda + ((vec) (vector->s64vector* vec 0 (vector-length vec))) + ((vec start) (vector->s64vector* vec start (vector-length vec))) + ((vec start end) (vector->s64vector* vec start end)))) + +(define (vector->s64vector* vec start end) + (let* ((len (- end start)) + (r (make-s64vector len))) + (let loop ((i start) (o 0)) + (cond + ((= i end) r) + (else + (s64vector-set! r o (vector-ref vec i)) + (loop (+ i 1) (+ o 1))))))) + +(define make-s64vector-generator + (case-lambda ((vec) (make-s64vector-generator vec 0 (s64vector-length vec))) + ((vec start) (make-s64vector-generator vec start (s64vector-length vec))) + ((vec start end) + (lambda () (if (>= start end) + (eof-object) + (let ((next (s64vector-ref vec start))) + (set! start (+ start 1)) + next)))))) + +(define write-s64vector + (case-lambda + ((vec) (write-s64vector* vec (current-output-port))) + ((vec port) (write-s64vector* vec port)))) + + +(define (write-s64vector* vec port) + (display "#s64(" port) ; s64-expansion is blind, so will expand this too + (let ((last (- (s64vector-length vec) 1))) + (let loop ((i 0)) + (cond + ((= i last) + (write (s64vector-ref vec i) port) + (display ")" port)) + (else + (write (s64vector-ref vec i) port) + (display " " port) + (loop (+ i 1))))))) + +(define (s64vector< vec1 vec2) + (let ((len1 (s64vector-length vec1)) + (len2 (s64vector-length vec2))) + (cond + ((< len1 len2) + #t) + ((> len1 len2) + #f) + (else + (let loop ((i 0)) + (cond + ((= i len1) + #f) + ((< (s64vector-ref vec1 i) (s64vector-ref vec2 i)) + #t) + ((> (s64vector-ref vec1 i) (s64vector-ref vec2 i)) + #f) + (else + (loop (+ i 1))))))))) + +(define (s64vector-hash vec) + (let ((len (min 256 (s64vector-length vec)))) + (let loop ((i 0) (r 0)) + (if (= i len) + (abs (floor (real-part (inexact->exact r)))) + (loop (+ i 1) (+ r (s64vector-ref vec i))))))) + +(define s64vector-comparator + (make-comparator s64vector? s64vector= s64vector< s64vector-hash)) diff --git a/module/srfi/srfi-160/s64.sld b/module/srfi/srfi-160/s64.sld new file mode 100644 index 000000000..623cfe261 --- /dev/null +++ b/module/srfi/srfi-160/s64.sld @@ -0,0 +1,49 @@ +;;; SPDX-FileCopyrightText: 2018 John Cowan +;;; +;;; SPDX-License-Identifier: MIT + +(define-library (srfi srfi-160 s64) + (import (scheme base)) + (import (scheme case-lambda)) + (import (scheme cxr)) + (import (only (scheme r5rs) inexact->exact)) + (import (scheme complex)) + (import (scheme write)) + (import (srfi srfi-128)) + (import (srfi srfi-160 base)) + ;; Constructors + (export make-s64vector s64vector + s64vector-unfold s64vector-unfold-right + s64vector-copy s64vector-reverse-copy + s64vector-append s64vector-concatenate + s64vector-append-subvectors) + ;; Predicates + (export s64? s64vector? s64vector-empty? s64vector=) + ;; Selectors + (export s64vector-ref s64vector-length) + ;; Iteration + (export s64vector-take s64vector-take-right + s64vector-drop s64vector-drop-right + s64vector-segment + s64vector-fold s64vector-fold-right + s64vector-map s64vector-map! s64vector-for-each + s64vector-count s64vector-cumulate) + ;; Searching + (export s64vector-take-while s64vector-take-while-right + s64vector-drop-while s64vector-drop-while-right + s64vector-index s64vector-index-right s64vector-skip s64vector-skip-right + s64vector-any s64vector-every s64vector-partition + s64vector-filter s64vector-remove) + ;; Mutators + (export s64vector-set! s64vector-swap! s64vector-fill! s64vector-reverse! + s64vector-copy! s64vector-reverse-copy! + s64vector-unfold! s64vector-unfold-right!) + ;; Conversion + (export s64vector->list list->s64vector + reverse-s64vector->list reverse-list->s64vector + s64vector->vector vector->s64vector) + ;; Misc + (export make-s64vector-generator s64vector-comparator write-s64vector) + + (include "s64-impl.scm") +) diff --git a/module/srfi/srfi-160/s8-impl.scm b/module/srfi/srfi-160/s8-impl.scm new file mode 100644 index 000000000..9569dbe8c --- /dev/null +++ b/module/srfi/srfi-160/s8-impl.scm @@ -0,0 +1,601 @@ +;;; SPDX-FileCopyrightText: 2018 John Cowan +;;; +;;; SPDX-License-Identifier: MIT + +;;; This code is the same for all SRFI 160 vector sizes. +;;; The s8s appearing in the code are expanded to u8, s8, etc. + +;; make-s8vector defined in (srfi 160 base) + +;; s8vector defined in (srfi 160 base) + +(define (s8vector-unfold f len seed) + (let ((v (make-s8vector len))) + (let loop ((i 0) (state seed)) + (unless (= i len) + (let-values (((value newstate) (f i state))) + (s8vector-set! v i value) + (loop (+ i 1) newstate)))) + v)) + +(define (s8vector-unfold-right f len seed) + (let ((v (make-s8vector len))) + (let loop ((i (- len 1)) (state seed)) + (unless (= i -1) + (let-values (((value newstate) (f i state))) + (s8vector-set! v i value) + (loop (- i 1) newstate)))) + v)) + +(define s8vector-copy + (case-lambda + ((vec) (s8vector-copy* vec 0 (s8vector-length vec))) + ((vec start) (s8vector-copy* vec start (s8vector-length vec))) + ((vec start end) (s8vector-copy* vec start end)))) + +(define (s8vector-copy* vec start end) + (let ((v (make-s8vector (- end start)))) + (s8vector-copy! v 0 vec start end) + v)) + +(define s8vector-copy! + (case-lambda + ((to at from) + (s8vector-copy!* to at from 0 (s8vector-length from))) + ((to at from start) + (s8vector-copy!* to at from start (s8vector-length from))) + ((to at from start end) (s8vector-copy!* to at from start end)))) + +(define (s8vector-copy!* to at from start end) + (let loop ((at at) (i start)) + (unless (= i end) + (s8vector-set! to at (s8vector-ref from i)) + (loop (+ at 1) (+ i 1))))) + +(define s8vector-reverse-copy + (case-lambda + ((vec) (s8vector-reverse-copy* vec 0 (s8vector-length vec))) + ((vec start) (s8vector-reverse-copy* vec start (s8vector-length vec))) + ((vec start end) (s8vector-reverse-copy* vec start end)))) + +(define (s8vector-reverse-copy* vec start end) + (let ((v (make-s8vector (- end start)))) + (s8vector-reverse-copy! v 0 vec start end) + v)) + +(define s8vector-reverse-copy! + (case-lambda + ((to at from) + (s8vector-reverse-copy!* to at from 0 (s8vector-length from))) + ((to at from start) + (s8vector-reverse-copy!* to at from start (s8vector-length from))) + ((to at from start end) (s8vector-reverse-copy!* to at from start end)))) + +(define (s8vector-reverse-copy!* to at from start end) + (let loop ((at at) (i (- end 1))) + (unless (< i start) + (s8vector-set! to at (s8vector-ref from i)) + (loop (+ at 1) (- i 1))))) + +(define (s8vector-append . vecs) + (s8vector-concatenate vecs)) + +(define (s8vector-concatenate vecs) + (let ((v (make-s8vector (len-sum vecs)))) + (let loop ((vecs vecs) (at 0)) + (unless (null? vecs) + (let ((vec (car vecs))) + (s8vector-copy! v at vec 0 (s8vector-length vec)) + (loop (cdr vecs) (+ at (s8vector-length vec))))) + v))) + +(define (len-sum vecs) + (if (null? vecs) + 0 + (+ (s8vector-length (car vecs)) + (len-sum (cdr vecs))))) + +(define (s8vector-append-subvectors . args) + (let ((v (make-s8vector (len-subsum args)))) + (let loop ((args args) (at 0)) + (unless (null? args) + (let ((vec (car args)) + (start (cadr args)) + (end (caddr args))) + (s8vector-copy! v at vec start end) + (loop (cdddr args) (+ at (- end start)))))) + v)) + +(define (len-subsum vecs) + (if (null? vecs) + 0 + (+ (- (caddr vecs) (cadr vecs)) + (len-subsum (cdddr vecs))))) + +;; s8? defined in (srfi 160 base) + +;; s8vector? defined in (srfi 160 base) + +(define (s8vector-empty? vec) + (zero? (s8vector-length vec))) + +(define (s8vector= . vecs) + (s8vector=* (car vecs) (cadr vecs) (cddr vecs))) + +(define (s8vector=* vec1 vec2 vecs) + (and (s8dyadic-vecs= vec1 0 (s8vector-length vec1) + vec2 0 (s8vector-length vec2)) + (or (null? vecs) + (s8vector=* vec2 (car vecs) (cdr vecs))))) + +(define (s8dyadic-vecs= vec1 start1 end1 vec2 start2 end2) + (cond + ((not (= end1 end2)) #f) + ((not (< start1 end1)) #t) + ((let ((elt1 (s8vector-ref vec1 start1)) + (elt2 (s8vector-ref vec2 start2))) + (= elt1 elt2)) + (s8dyadic-vecs= vec1 (+ start1 1) end1 + vec2 (+ start2 1) end2)) + (else #f))) + +;; s8vector-ref defined in (srfi 160 base) + +;; s8vector-length defined in (srfi 160 base) + +(define (s8vector-take vec n) + (let ((v (make-s8vector n))) + (s8vector-copy! v 0 vec 0 n) + v)) + +(define (s8vector-take-right vec n) + (let ((v (make-s8vector n)) + (len (s8vector-length vec))) + (s8vector-copy! v 0 vec (- len n) len) + v)) + +(define (s8vector-drop vec n) + (let* ((len (s8vector-length vec)) + (vlen (- len n)) + (v (make-s8vector vlen))) + (s8vector-copy! v 0 vec n len) + v)) + +(define (s8vector-drop-right vec n) + (let* ((len (s8vector-length vec)) + (rlen (- len n)) + (v (make-s8vector rlen))) + (s8vector-copy! v 0 vec 0 rlen) + v)) + +(define (s8vector-segment vec n) + (unless (and (integer? n) (positive? n)) + (error "length must be a positive integer" n)) + (let loop ((r '()) (i 0) (remain (s8vector-length vec))) + (if (<= remain 0) + (reverse r) + (let ((size (min n remain))) + (loop + (cons (s8vector-copy vec i (+ i size)) r) + (+ i size) + (- remain size)))))) + +;; aux. procedure +(define (%s8vectors-ref vecs i) + (map (lambda (v) (s8vector-ref v i)) vecs)) + +(define (s8vector-fold kons knil vec . vecs) + (if (null? vecs) + ;; fast path + (let ((len (s8vector-length vec))) + (let loop ((r knil) (i 0)) + (if (= i len) + r + (loop (kons r (s8vector-ref vec i)) (+ i 1))))) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map s8vector-length vecs)))) + (let loop ((r knil) (i 0)) + (if (= i len) + r + (loop (apply kons r (%s8vectors-ref vecs i)) + (+ i 1))))))) + +(define (s8vector-fold-right kons knil vec . vecs) + (if (null? vecs) + ;; fast path + (let ((len (s8vector-length vec))) + (let loop ((r knil) (i (- (s8vector-length vec) 1))) + (if (negative? i) + r + (loop (kons r (s8vector-ref vec i)) (- i 1))))) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map s8vector-length vecs)))) + (let loop ((r knil) (i (- len 1))) + (if (negative? i) + r + (loop (apply kons r (%s8vectors-ref vecs i)) + (- i 1))))))) + +(define (s8vector-map f vec . vecs) + (if (null? vecs) + ;; fast path + (let* ((len (s8vector-length vec)) + (v (make-s8vector len))) + (let loop ((i 0)) + (unless (= i len) + (s8vector-set! v i (f (s8vector-ref vec i))) + (loop (+ i 1)))) + v) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map s8vector-length vecs))) + (v (make-s8vector len))) + (let loop ((i 0)) + (unless (= i len) + (s8vector-set! v i (apply f (%s8vectors-ref vecs i))) + (loop (+ i 1)))) + v))) + + +(define (s8vector-map! f vec . vecs) + (if (null? vecs) + ;; fast path + (let ((len (s8vector-length vec))) + (let loop ((i 0)) + (unless (= i len) + (s8vector-set! vec i (f (s8vector-ref vec i))) + (loop (+ i 1))))) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map s8vector-length vecs)))) + (let loop ((i 0)) + (unless (= i len) + (s8vector-set! vec i (apply f (%s8vectors-ref vecs i))) + (loop (+ i 1))))))) + +(define (s8vector-for-each f vec . vecs) + (if (null? vecs) + ;; fast path + (let ((len (s8vector-length vec))) + (let loop ((i 0)) + (unless (= i len) + (f (s8vector-ref vec i)) + (loop (+ i 1))))) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map s8vector-length vecs)))) + (let loop ((i 0)) + (unless (= i len) + (apply f (%s8vectors-ref vecs i)) + (loop (+ i 1))))))) + +(define (s8vector-count pred vec . vecs) + (if (null? vecs) + ;; fast path + (let ((len (s8vector-length vec))) + (let loop ((i 0) (r 0)) + (cond + ((= i (s8vector-length vec)) r) + ((pred (s8vector-ref vec i)) (loop (+ i 1) (+ r 1))) + (else (loop (+ i 1) r))))) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map s8vector-length vecs)))) + (let loop ((i 0) (r 0)) + (cond + ((= i len) r) + ((apply pred (%s8vectors-ref vecs i)) (loop (+ i 1) (+ r 1))) + (else (loop (+ i 1) r))))))) + +(define (s8vector-cumulate f knil vec) + (let* ((len (s8vector-length vec)) + (v (make-s8vector len))) + (let loop ((r knil) (i 0)) + (unless (= i len) + (let ((next (f r (s8vector-ref vec i)))) + (s8vector-set! v i next) + (loop next (+ i 1))))) + v)) + +(define (s8vector-foreach f vec) + (let ((len (s8vector-length vec))) + (let loop ((i 0)) + (unless (= i len) + (f (s8vector-ref vec i)) + (loop (+ i 1)))))) + +(define (s8vector-take-while pred vec) + (let* ((len (s8vector-length vec)) + (idx (s8vector-skip pred vec)) + (idx* (if idx idx len))) + (s8vector-copy vec 0 idx*))) + +(define (s8vector-take-while-right pred vec) + (let* ((len (s8vector-length vec)) + (idx (s8vector-skip-right pred vec)) + (idx* (if idx (+ idx 1) 0))) + (s8vector-copy vec idx* len))) + +(define (s8vector-drop-while pred vec) + (let* ((len (s8vector-length vec)) + (idx (s8vector-skip pred vec)) + (idx* (if idx idx len))) + (s8vector-copy vec idx* len))) + +(define (s8vector-drop-while-right pred vec) + (let* ((len (s8vector-length vec)) + (idx (s8vector-skip-right pred vec)) + (idx* (if idx idx -1))) + (s8vector-copy vec 0 (+ 1 idx*)))) + +(define (s8vector-index pred vec . vecs) + (if (null? vecs) + ;; fast path + (let ((len (s8vector-length vec))) + (let loop ((i 0)) + (cond + ((= i len) #f) + ((pred (s8vector-ref vec i)) i) + (else (loop (+ i 1)))))) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map s8vector-length vecs)))) + (let loop ((i 0)) + (cond + ((= i len) #f) + ((apply pred (%s8vectors-ref vecs i)) i) + (else (loop (+ i 1)))))))) + +(define (s8vector-index-right pred vec . vecs) + (if (null? vecs) + ;; fast path + (let ((len (s8vector-length vec))) + (let loop ((i (- len 1))) + (cond + ((negative? i) #f) + ((pred (s8vector-ref vec i)) i) + (else (loop (- i 1)))))) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map s8vector-length vecs)))) + (let loop ((i (- len 1))) + (cond + ((negative? i) #f) + ((apply pred (%s8vectors-ref vecs i)) i) + (else (loop (- i 1)))))))) + +(define (s8vector-skip pred vec . vecs) + (if (null? vecs) + (s8vector-index (lambda (x) (not (pred x))) vec) + (apply s8vector-index (lambda xs (not (apply pred xs))) vec vecs))) + +(define (s8vector-skip-right pred vec . vecs) + (if (null? vecs) + (s8vector-index-right (lambda (x) (not (pred x))) vec) + (apply s8vector-index-right (lambda xs (not (apply pred xs))) vec vecs))) + +(define (s8vector-any pred vec . vecs) + (if (null? vecs) + ;; fast path + (let ((len (s8vector-length vec))) + (let loop ((i 0)) + (cond + ((= i len) #f) + ((pred (s8vector-ref vec i))) ;returns result of pred + (else (loop (+ i 1)))))) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map s8vector-length vecs)))) + (let loop ((i 0)) + (cond + ((= i len) #f) + ((apply pred (%s8vectors-ref vecs i))) ;returns result of pred + (else (loop (+ i 1)))))))) + +(define (s8vector-every pred vec . vecs) + (if (null? vecs) + ;; fast path + (let ((len (s8vector-length vec))) + (let loop ((i 0) (last #t)) + (cond + ((= i len) last) + ((pred (s8vector-ref vec i)) => (lambda (r) (loop (+ i 1) r))) + (else #f)))) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map s8vector-length vecs)))) + (let loop ((i 0) (last #t)) + (cond + ((= i len) last) + ((apply pred (%s8vectors-ref vecs i)) => (lambda (r) (loop (+ i 1) r))) + (else #f)))))) + +(define (s8vector-partition pred vec) + (let* ((len (s8vector-length vec)) + (cnt (s8vector-count pred vec)) + (r (make-s8vector len))) + (let loop ((i 0) (yes 0) (no cnt)) + (cond + ((= i len) (values r cnt)) + ((pred (s8vector-ref vec i)) + (s8vector-set! r yes (s8vector-ref vec i)) + (loop (+ i 1) (+ yes 1) no)) + (else + (s8vector-set! r no (s8vector-ref vec i)) + (loop (+ i 1) yes (+ no 1))))))) + +(define (s8vector-filter pred vec) + (let* ((len (s8vector-length vec)) + (cnt (s8vector-count pred vec)) + (r (make-s8vector cnt))) + (let loop ((i 0) (j 0)) + (cond + ((= i len) r) + ((pred (s8vector-ref vec i)) + (s8vector-set! r j (s8vector-ref vec i)) + (loop (+ i 1) (+ j 1))) + (else + (loop (+ i 1) j)))))) + +(define (s8vector-remove pred vec) + (s8vector-filter (lambda (x) (not (pred x))) vec)) + +;; s8vector-set! defined in (srfi 160 base) + +(define (s8vector-swap! vec i j) + (let ((ival (s8vector-ref vec i)) + (jval (s8vector-ref vec j))) + (s8vector-set! vec i jval) + (s8vector-set! vec j ival))) + +(define s8vector-fill! + (case-lambda + ((vec fill) (s8vector-fill-some! vec fill 0 (s8vector-length vec))) + ((vec fill start) (s8vector-fill-some! vec fill start (s8vector-length vec))) + ((vec fill start end) (s8vector-fill-some! vec fill start end)))) + +(define (s8vector-fill-some! vec fill start end) + (unless (= start end) + (s8vector-set! vec start fill) + (s8vector-fill-some! vec fill (+ start 1) end))) + +(define s8vector-reverse! + (case-lambda + ((vec) (s8vector-reverse-some! vec 0 (s8vector-length vec))) + ((vec start) (s8vector-reverse-some! vec start (s8vector-length vec))) + ((vec start end) (s8vector-reverse-some! vec start end)))) + +(define (s8vector-reverse-some! vec start end) + (let loop ((i start) (j (- end 1))) + (when (< i j) + (s8vector-swap! vec i j) + (loop (+ i 1) (- j 1))))) + +(define (s8vector-unfold! f vec start end seed) + (let loop ((i start) (seed seed)) + (when (< i end) + (let-values (((elt seed) (f i seed))) + (s8vector-set! vec i elt) + (loop (+ i 1) seed))))) + +(define (s8vector-unfold-right! f vec start end seed) + (let loop ((i (- end 1)) (seed seed)) + (when (>= i start) + (let-values (((elt seed) (f i seed))) + (s8vector-set! vec i elt) + (loop (- i 1) seed))))) + +(define reverse-s8vector->list + (case-lambda + ((vec) (reverse-s8vector->list* vec 0 (s8vector-length vec))) + ((vec start) (reverse-s8vector->list* vec start (s8vector-length vec))) + ((vec start end) (reverse-s8vector->list* vec start end)))) + +(define (reverse-s8vector->list* vec start end) + (let loop ((i start) (r '())) + (if (= i end) + r + (loop (+ 1 i) (cons (s8vector-ref vec i) r))))) + +(define (reverse-list->s8vector list) + (let* ((len (length list)) + (r (make-s8vector len))) + (let loop ((i 0) (list list)) + (cond + ((= i len) r) + (else + (s8vector-set! r (- len i 1) (car list)) + (loop (+ i 1) (cdr list))))))) + +(define s8vector->vector + (case-lambda + ((vec) (s8vector->vector* vec 0 (s8vector-length vec))) + ((vec start) (s8vector->vector* vec start (s8vector-length vec))) + ((vec start end) (s8vector->vector* vec start end)))) + +(define (s8vector->vector* vec start end) + (let* ((len (- end start)) + (r (make-vector len))) + (let loop ((i start) (o 0)) + (cond + ((= i end) r) + (else + (vector-set! r o (s8vector-ref vec i)) + (loop (+ i 1) (+ o 1))))))) + +(define vector->s8vector + (case-lambda + ((vec) (vector->s8vector* vec 0 (vector-length vec))) + ((vec start) (vector->s8vector* vec start (vector-length vec))) + ((vec start end) (vector->s8vector* vec start end)))) + +(define (vector->s8vector* vec start end) + (let* ((len (- end start)) + (r (make-s8vector len))) + (let loop ((i start) (o 0)) + (cond + ((= i end) r) + (else + (s8vector-set! r o (vector-ref vec i)) + (loop (+ i 1) (+ o 1))))))) + +(define make-s8vector-generator + (case-lambda ((vec) (make-s8vector-generator vec 0 (s8vector-length vec))) + ((vec start) (make-s8vector-generator vec start (s8vector-length vec))) + ((vec start end) + (lambda () (if (>= start end) + (eof-object) + (let ((next (s8vector-ref vec start))) + (set! start (+ start 1)) + next)))))) + +(define write-s8vector + (case-lambda + ((vec) (write-s8vector* vec (current-output-port))) + ((vec port) (write-s8vector* vec port)))) + + +(define (write-s8vector* vec port) + (display "#s8(" port) ; s8-expansion is blind, so will expand this too + (let ((last (- (s8vector-length vec) 1))) + (let loop ((i 0)) + (cond + ((= i last) + (write (s8vector-ref vec i) port) + (display ")" port)) + (else + (write (s8vector-ref vec i) port) + (display " " port) + (loop (+ i 1))))))) + +(define (s8vector< vec1 vec2) + (let ((len1 (s8vector-length vec1)) + (len2 (s8vector-length vec2))) + (cond + ((< len1 len2) + #t) + ((> len1 len2) + #f) + (else + (let loop ((i 0)) + (cond + ((= i len1) + #f) + ((< (s8vector-ref vec1 i) (s8vector-ref vec2 i)) + #t) + ((> (s8vector-ref vec1 i) (s8vector-ref vec2 i)) + #f) + (else + (loop (+ i 1))))))))) + +(define (s8vector-hash vec) + (let ((len (min 256 (s8vector-length vec)))) + (let loop ((i 0) (r 0)) + (if (= i len) + (abs (floor (real-part (inexact->exact r)))) + (loop (+ i 1) (+ r (s8vector-ref vec i))))))) + +(define s8vector-comparator + (make-comparator s8vector? s8vector= s8vector< s8vector-hash)) diff --git a/module/srfi/srfi-160/s8.sld b/module/srfi/srfi-160/s8.sld new file mode 100644 index 000000000..26cc23e7a --- /dev/null +++ b/module/srfi/srfi-160/s8.sld @@ -0,0 +1,49 @@ +;;; SPDX-FileCopyrightText: 2018 John Cowan +;;; +;;; SPDX-License-Identifier: MIT + +(define-library (srfi srfi-160 s8) + (import (scheme base)) + (import (scheme case-lambda)) + (import (scheme cxr)) + (import (only (scheme r5rs) inexact->exact)) + (import (scheme complex)) + (import (scheme write)) + (import (srfi srfi-128)) + (import (srfi srfi-160 base)) + ;; Constructors + (export make-s8vector s8vector + s8vector-unfold s8vector-unfold-right + s8vector-copy s8vector-reverse-copy + s8vector-append s8vector-concatenate + s8vector-append-subvectors) + ;; Predicates + (export s8? s8vector? s8vector-empty? s8vector=) + ;; Selectors + (export s8vector-ref s8vector-length) + ;; Iteration + (export s8vector-take s8vector-take-right + s8vector-drop s8vector-drop-right + s8vector-segment + s8vector-fold s8vector-fold-right + s8vector-map s8vector-map! s8vector-for-each + s8vector-count s8vector-cumulate) + ;; Searching + (export s8vector-take-while s8vector-take-while-right + s8vector-drop-while s8vector-drop-while-right + s8vector-index s8vector-index-right s8vector-skip s8vector-skip-right + s8vector-any s8vector-every s8vector-partition + s8vector-filter s8vector-remove) + ;; Mutators + (export s8vector-set! s8vector-swap! s8vector-fill! s8vector-reverse! + s8vector-copy! s8vector-reverse-copy! + s8vector-unfold! s8vector-unfold-right!) + ;; Conversion + (export s8vector->list list->s8vector + reverse-s8vector->list reverse-list->s8vector + s8vector->vector vector->s8vector) + ;; Misc + (export make-s8vector-generator s8vector-comparator write-s8vector) + + (include "s8-impl.scm") +) diff --git a/module/srfi/srfi-160/u16-impl.scm b/module/srfi/srfi-160/u16-impl.scm new file mode 100644 index 000000000..0c017fe9b --- /dev/null +++ b/module/srfi/srfi-160/u16-impl.scm @@ -0,0 +1,601 @@ +;;; SPDX-FileCopyrightText: 2018 John Cowan +;;; +;;; SPDX-License-Identifier: MIT + +;;; This code is the same for all SRFI 160 vector sizes. +;;; The u16s appearing in the code are expanded to u8, s8, etc. + +;; make-u16vector defined in (srfi 160 base) + +;; u16vector defined in (srfi 160 base) + +(define (u16vector-unfold f len seed) + (let ((v (make-u16vector len))) + (let loop ((i 0) (state seed)) + (unless (= i len) + (let-values (((value newstate) (f i state))) + (u16vector-set! v i value) + (loop (+ i 1) newstate)))) + v)) + +(define (u16vector-unfold-right f len seed) + (let ((v (make-u16vector len))) + (let loop ((i (- len 1)) (state seed)) + (unless (= i -1) + (let-values (((value newstate) (f i state))) + (u16vector-set! v i value) + (loop (- i 1) newstate)))) + v)) + +(define u16vector-copy + (case-lambda + ((vec) (u16vector-copy* vec 0 (u16vector-length vec))) + ((vec start) (u16vector-copy* vec start (u16vector-length vec))) + ((vec start end) (u16vector-copy* vec start end)))) + +(define (u16vector-copy* vec start end) + (let ((v (make-u16vector (- end start)))) + (u16vector-copy! v 0 vec start end) + v)) + +(define u16vector-copy! + (case-lambda + ((to at from) + (u16vector-copy!* to at from 0 (u16vector-length from))) + ((to at from start) + (u16vector-copy!* to at from start (u16vector-length from))) + ((to at from start end) (u16vector-copy!* to at from start end)))) + +(define (u16vector-copy!* to at from start end) + (let loop ((at at) (i start)) + (unless (= i end) + (u16vector-set! to at (u16vector-ref from i)) + (loop (+ at 1) (+ i 1))))) + +(define u16vector-reverse-copy + (case-lambda + ((vec) (u16vector-reverse-copy* vec 0 (u16vector-length vec))) + ((vec start) (u16vector-reverse-copy* vec start (u16vector-length vec))) + ((vec start end) (u16vector-reverse-copy* vec start end)))) + +(define (u16vector-reverse-copy* vec start end) + (let ((v (make-u16vector (- end start)))) + (u16vector-reverse-copy! v 0 vec start end) + v)) + +(define u16vector-reverse-copy! + (case-lambda + ((to at from) + (u16vector-reverse-copy!* to at from 0 (u16vector-length from))) + ((to at from start) + (u16vector-reverse-copy!* to at from start (u16vector-length from))) + ((to at from start end) (u16vector-reverse-copy!* to at from start end)))) + +(define (u16vector-reverse-copy!* to at from start end) + (let loop ((at at) (i (- end 1))) + (unless (< i start) + (u16vector-set! to at (u16vector-ref from i)) + (loop (+ at 1) (- i 1))))) + +(define (u16vector-append . vecs) + (u16vector-concatenate vecs)) + +(define (u16vector-concatenate vecs) + (let ((v (make-u16vector (len-sum vecs)))) + (let loop ((vecs vecs) (at 0)) + (unless (null? vecs) + (let ((vec (car vecs))) + (u16vector-copy! v at vec 0 (u16vector-length vec)) + (loop (cdr vecs) (+ at (u16vector-length vec))))) + v))) + +(define (len-sum vecs) + (if (null? vecs) + 0 + (+ (u16vector-length (car vecs)) + (len-sum (cdr vecs))))) + +(define (u16vector-append-subvectors . args) + (let ((v (make-u16vector (len-subsum args)))) + (let loop ((args args) (at 0)) + (unless (null? args) + (let ((vec (car args)) + (start (cadr args)) + (end (caddr args))) + (u16vector-copy! v at vec start end) + (loop (cdddr args) (+ at (- end start)))))) + v)) + +(define (len-subsum vecs) + (if (null? vecs) + 0 + (+ (- (caddr vecs) (cadr vecs)) + (len-subsum (cdddr vecs))))) + +;; u16? defined in (srfi 160 base) + +;; u16vector? defined in (srfi 160 base) + +(define (u16vector-empty? vec) + (zero? (u16vector-length vec))) + +(define (u16vector= . vecs) + (u16vector=* (car vecs) (cadr vecs) (cddr vecs))) + +(define (u16vector=* vec1 vec2 vecs) + (and (u16dyadic-vecs= vec1 0 (u16vector-length vec1) + vec2 0 (u16vector-length vec2)) + (or (null? vecs) + (u16vector=* vec2 (car vecs) (cdr vecs))))) + +(define (u16dyadic-vecs= vec1 start1 end1 vec2 start2 end2) + (cond + ((not (= end1 end2)) #f) + ((not (< start1 end1)) #t) + ((let ((elt1 (u16vector-ref vec1 start1)) + (elt2 (u16vector-ref vec2 start2))) + (= elt1 elt2)) + (u16dyadic-vecs= vec1 (+ start1 1) end1 + vec2 (+ start2 1) end2)) + (else #f))) + +;; u16vector-ref defined in (srfi 160 base) + +;; u16vector-length defined in (srfi 160 base) + +(define (u16vector-take vec n) + (let ((v (make-u16vector n))) + (u16vector-copy! v 0 vec 0 n) + v)) + +(define (u16vector-take-right vec n) + (let ((v (make-u16vector n)) + (len (u16vector-length vec))) + (u16vector-copy! v 0 vec (- len n) len) + v)) + +(define (u16vector-drop vec n) + (let* ((len (u16vector-length vec)) + (vlen (- len n)) + (v (make-u16vector vlen))) + (u16vector-copy! v 0 vec n len) + v)) + +(define (u16vector-drop-right vec n) + (let* ((len (u16vector-length vec)) + (rlen (- len n)) + (v (make-u16vector rlen))) + (u16vector-copy! v 0 vec 0 rlen) + v)) + +(define (u16vector-segment vec n) + (unless (and (integer? n) (positive? n)) + (error "length must be a positive integer" n)) + (let loop ((r '()) (i 0) (remain (u16vector-length vec))) + (if (<= remain 0) + (reverse r) + (let ((size (min n remain))) + (loop + (cons (u16vector-copy vec i (+ i size)) r) + (+ i size) + (- remain size)))))) + +;; aux. procedure +(define (%u16vectors-ref vecs i) + (map (lambda (v) (u16vector-ref v i)) vecs)) + +(define (u16vector-fold kons knil vec . vecs) + (if (null? vecs) + ;; fast path + (let ((len (u16vector-length vec))) + (let loop ((r knil) (i 0)) + (if (= i len) + r + (loop (kons r (u16vector-ref vec i)) (+ i 1))))) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map u16vector-length vecs)))) + (let loop ((r knil) (i 0)) + (if (= i len) + r + (loop (apply kons r (%u16vectors-ref vecs i)) + (+ i 1))))))) + +(define (u16vector-fold-right kons knil vec . vecs) + (if (null? vecs) + ;; fast path + (let ((len (u16vector-length vec))) + (let loop ((r knil) (i (- (u16vector-length vec) 1))) + (if (negative? i) + r + (loop (kons r (u16vector-ref vec i)) (- i 1))))) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map u16vector-length vecs)))) + (let loop ((r knil) (i (- len 1))) + (if (negative? i) + r + (loop (apply kons r (%u16vectors-ref vecs i)) + (- i 1))))))) + +(define (u16vector-map f vec . vecs) + (if (null? vecs) + ;; fast path + (let* ((len (u16vector-length vec)) + (v (make-u16vector len))) + (let loop ((i 0)) + (unless (= i len) + (u16vector-set! v i (f (u16vector-ref vec i))) + (loop (+ i 1)))) + v) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map u16vector-length vecs))) + (v (make-u16vector len))) + (let loop ((i 0)) + (unless (= i len) + (u16vector-set! v i (apply f (%u16vectors-ref vecs i))) + (loop (+ i 1)))) + v))) + + +(define (u16vector-map! f vec . vecs) + (if (null? vecs) + ;; fast path + (let ((len (u16vector-length vec))) + (let loop ((i 0)) + (unless (= i len) + (u16vector-set! vec i (f (u16vector-ref vec i))) + (loop (+ i 1))))) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map u16vector-length vecs)))) + (let loop ((i 0)) + (unless (= i len) + (u16vector-set! vec i (apply f (%u16vectors-ref vecs i))) + (loop (+ i 1))))))) + +(define (u16vector-for-each f vec . vecs) + (if (null? vecs) + ;; fast path + (let ((len (u16vector-length vec))) + (let loop ((i 0)) + (unless (= i len) + (f (u16vector-ref vec i)) + (loop (+ i 1))))) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map u16vector-length vecs)))) + (let loop ((i 0)) + (unless (= i len) + (apply f (%u16vectors-ref vecs i)) + (loop (+ i 1))))))) + +(define (u16vector-count pred vec . vecs) + (if (null? vecs) + ;; fast path + (let ((len (u16vector-length vec))) + (let loop ((i 0) (r 0)) + (cond + ((= i (u16vector-length vec)) r) + ((pred (u16vector-ref vec i)) (loop (+ i 1) (+ r 1))) + (else (loop (+ i 1) r))))) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map u16vector-length vecs)))) + (let loop ((i 0) (r 0)) + (cond + ((= i len) r) + ((apply pred (%u16vectors-ref vecs i)) (loop (+ i 1) (+ r 1))) + (else (loop (+ i 1) r))))))) + +(define (u16vector-cumulate f knil vec) + (let* ((len (u16vector-length vec)) + (v (make-u16vector len))) + (let loop ((r knil) (i 0)) + (unless (= i len) + (let ((next (f r (u16vector-ref vec i)))) + (u16vector-set! v i next) + (loop next (+ i 1))))) + v)) + +(define (u16vector-foreach f vec) + (let ((len (u16vector-length vec))) + (let loop ((i 0)) + (unless (= i len) + (f (u16vector-ref vec i)) + (loop (+ i 1)))))) + +(define (u16vector-take-while pred vec) + (let* ((len (u16vector-length vec)) + (idx (u16vector-skip pred vec)) + (idx* (if idx idx len))) + (u16vector-copy vec 0 idx*))) + +(define (u16vector-take-while-right pred vec) + (let* ((len (u16vector-length vec)) + (idx (u16vector-skip-right pred vec)) + (idx* (if idx (+ idx 1) 0))) + (u16vector-copy vec idx* len))) + +(define (u16vector-drop-while pred vec) + (let* ((len (u16vector-length vec)) + (idx (u16vector-skip pred vec)) + (idx* (if idx idx len))) + (u16vector-copy vec idx* len))) + +(define (u16vector-drop-while-right pred vec) + (let* ((len (u16vector-length vec)) + (idx (u16vector-skip-right pred vec)) + (idx* (if idx idx -1))) + (u16vector-copy vec 0 (+ 1 idx*)))) + +(define (u16vector-index pred vec . vecs) + (if (null? vecs) + ;; fast path + (let ((len (u16vector-length vec))) + (let loop ((i 0)) + (cond + ((= i len) #f) + ((pred (u16vector-ref vec i)) i) + (else (loop (+ i 1)))))) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map u16vector-length vecs)))) + (let loop ((i 0)) + (cond + ((= i len) #f) + ((apply pred (%u16vectors-ref vecs i)) i) + (else (loop (+ i 1)))))))) + +(define (u16vector-index-right pred vec . vecs) + (if (null? vecs) + ;; fast path + (let ((len (u16vector-length vec))) + (let loop ((i (- len 1))) + (cond + ((negative? i) #f) + ((pred (u16vector-ref vec i)) i) + (else (loop (- i 1)))))) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map u16vector-length vecs)))) + (let loop ((i (- len 1))) + (cond + ((negative? i) #f) + ((apply pred (%u16vectors-ref vecs i)) i) + (else (loop (- i 1)))))))) + +(define (u16vector-skip pred vec . vecs) + (if (null? vecs) + (u16vector-index (lambda (x) (not (pred x))) vec) + (apply u16vector-index (lambda xs (not (apply pred xs))) vec vecs))) + +(define (u16vector-skip-right pred vec . vecs) + (if (null? vecs) + (u16vector-index-right (lambda (x) (not (pred x))) vec) + (apply u16vector-index-right (lambda xs (not (apply pred xs))) vec vecs))) + +(define (u16vector-any pred vec . vecs) + (if (null? vecs) + ;; fast path + (let ((len (u16vector-length vec))) + (let loop ((i 0)) + (cond + ((= i len) #f) + ((pred (u16vector-ref vec i))) ;returns result of pred + (else (loop (+ i 1)))))) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map u16vector-length vecs)))) + (let loop ((i 0)) + (cond + ((= i len) #f) + ((apply pred (%u16vectors-ref vecs i))) ;returns result of pred + (else (loop (+ i 1)))))))) + +(define (u16vector-every pred vec . vecs) + (if (null? vecs) + ;; fast path + (let ((len (u16vector-length vec))) + (let loop ((i 0) (last #t)) + (cond + ((= i len) last) + ((pred (u16vector-ref vec i)) => (lambda (r) (loop (+ i 1) r))) + (else #f)))) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map u16vector-length vecs)))) + (let loop ((i 0) (last #t)) + (cond + ((= i len) last) + ((apply pred (%u16vectors-ref vecs i)) => (lambda (r) (loop (+ i 1) r))) + (else #f)))))) + +(define (u16vector-partition pred vec) + (let* ((len (u16vector-length vec)) + (cnt (u16vector-count pred vec)) + (r (make-u16vector len))) + (let loop ((i 0) (yes 0) (no cnt)) + (cond + ((= i len) (values r cnt)) + ((pred (u16vector-ref vec i)) + (u16vector-set! r yes (u16vector-ref vec i)) + (loop (+ i 1) (+ yes 1) no)) + (else + (u16vector-set! r no (u16vector-ref vec i)) + (loop (+ i 1) yes (+ no 1))))))) + +(define (u16vector-filter pred vec) + (let* ((len (u16vector-length vec)) + (cnt (u16vector-count pred vec)) + (r (make-u16vector cnt))) + (let loop ((i 0) (j 0)) + (cond + ((= i len) r) + ((pred (u16vector-ref vec i)) + (u16vector-set! r j (u16vector-ref vec i)) + (loop (+ i 1) (+ j 1))) + (else + (loop (+ i 1) j)))))) + +(define (u16vector-remove pred vec) + (u16vector-filter (lambda (x) (not (pred x))) vec)) + +;; u16vector-set! defined in (srfi 160 base) + +(define (u16vector-swap! vec i j) + (let ((ival (u16vector-ref vec i)) + (jval (u16vector-ref vec j))) + (u16vector-set! vec i jval) + (u16vector-set! vec j ival))) + +(define u16vector-fill! + (case-lambda + ((vec fill) (u16vector-fill-some! vec fill 0 (u16vector-length vec))) + ((vec fill start) (u16vector-fill-some! vec fill start (u16vector-length vec))) + ((vec fill start end) (u16vector-fill-some! vec fill start end)))) + +(define (u16vector-fill-some! vec fill start end) + (unless (= start end) + (u16vector-set! vec start fill) + (u16vector-fill-some! vec fill (+ start 1) end))) + +(define u16vector-reverse! + (case-lambda + ((vec) (u16vector-reverse-some! vec 0 (u16vector-length vec))) + ((vec start) (u16vector-reverse-some! vec start (u16vector-length vec))) + ((vec start end) (u16vector-reverse-some! vec start end)))) + +(define (u16vector-reverse-some! vec start end) + (let loop ((i start) (j (- end 1))) + (when (< i j) + (u16vector-swap! vec i j) + (loop (+ i 1) (- j 1))))) + +(define (u16vector-unfold! f vec start end seed) + (let loop ((i start) (seed seed)) + (when (< i end) + (let-values (((elt seed) (f i seed))) + (u16vector-set! vec i elt) + (loop (+ i 1) seed))))) + +(define (u16vector-unfold-right! f vec start end seed) + (let loop ((i (- end 1)) (seed seed)) + (when (>= i start) + (let-values (((elt seed) (f i seed))) + (u16vector-set! vec i elt) + (loop (- i 1) seed))))) + +(define reverse-u16vector->list + (case-lambda + ((vec) (reverse-u16vector->list* vec 0 (u16vector-length vec))) + ((vec start) (reverse-u16vector->list* vec start (u16vector-length vec))) + ((vec start end) (reverse-u16vector->list* vec start end)))) + +(define (reverse-u16vector->list* vec start end) + (let loop ((i start) (r '())) + (if (= i end) + r + (loop (+ 1 i) (cons (u16vector-ref vec i) r))))) + +(define (reverse-list->u16vector list) + (let* ((len (length list)) + (r (make-u16vector len))) + (let loop ((i 0) (list list)) + (cond + ((= i len) r) + (else + (u16vector-set! r (- len i 1) (car list)) + (loop (+ i 1) (cdr list))))))) + +(define u16vector->vector + (case-lambda + ((vec) (u16vector->vector* vec 0 (u16vector-length vec))) + ((vec start) (u16vector->vector* vec start (u16vector-length vec))) + ((vec start end) (u16vector->vector* vec start end)))) + +(define (u16vector->vector* vec start end) + (let* ((len (- end start)) + (r (make-vector len))) + (let loop ((i start) (o 0)) + (cond + ((= i end) r) + (else + (vector-set! r o (u16vector-ref vec i)) + (loop (+ i 1) (+ o 1))))))) + +(define vector->u16vector + (case-lambda + ((vec) (vector->u16vector* vec 0 (vector-length vec))) + ((vec start) (vector->u16vector* vec start (vector-length vec))) + ((vec start end) (vector->u16vector* vec start end)))) + +(define (vector->u16vector* vec start end) + (let* ((len (- end start)) + (r (make-u16vector len))) + (let loop ((i start) (o 0)) + (cond + ((= i end) r) + (else + (u16vector-set! r o (vector-ref vec i)) + (loop (+ i 1) (+ o 1))))))) + +(define make-u16vector-generator + (case-lambda ((vec) (make-u16vector-generator vec 0 (u16vector-length vec))) + ((vec start) (make-u16vector-generator vec start (u16vector-length vec))) + ((vec start end) + (lambda () (if (>= start end) + (eof-object) + (let ((next (u16vector-ref vec start))) + (set! start (+ start 1)) + next)))))) + +(define write-u16vector + (case-lambda + ((vec) (write-u16vector* vec (current-output-port))) + ((vec port) (write-u16vector* vec port)))) + + +(define (write-u16vector* vec port) + (display "#u16(" port) ; u16-expansion is blind, so will expand this too + (let ((last (- (u16vector-length vec) 1))) + (let loop ((i 0)) + (cond + ((= i last) + (write (u16vector-ref vec i) port) + (display ")" port)) + (else + (write (u16vector-ref vec i) port) + (display " " port) + (loop (+ i 1))))))) + +(define (u16vector< vec1 vec2) + (let ((len1 (u16vector-length vec1)) + (len2 (u16vector-length vec2))) + (cond + ((< len1 len2) + #t) + ((> len1 len2) + #f) + (else + (let loop ((i 0)) + (cond + ((= i len1) + #f) + ((< (u16vector-ref vec1 i) (u16vector-ref vec2 i)) + #t) + ((> (u16vector-ref vec1 i) (u16vector-ref vec2 i)) + #f) + (else + (loop (+ i 1))))))))) + +(define (u16vector-hash vec) + (let ((len (min 256 (u16vector-length vec)))) + (let loop ((i 0) (r 0)) + (if (= i len) + (abs (floor (real-part (inexact->exact r)))) + (loop (+ i 1) (+ r (u16vector-ref vec i))))))) + +(define u16vector-comparator + (make-comparator u16vector? u16vector= u16vector< u16vector-hash)) diff --git a/module/srfi/srfi-160/u16.sld b/module/srfi/srfi-160/u16.sld new file mode 100644 index 000000000..eaaaa19f3 --- /dev/null +++ b/module/srfi/srfi-160/u16.sld @@ -0,0 +1,49 @@ +;;; SPDX-FileCopyrightText: 2018 John Cowan +;;; +;;; SPDX-License-Identifier: MIT + +(define-library (srfi srfi-160 u16) + (import (scheme base)) + (import (scheme case-lambda)) + (import (scheme cxr)) + (import (only (scheme r5rs) inexact->exact)) + (import (scheme complex)) + (import (scheme write)) + (import (srfi srfi-128)) + (import (srfi srfi-160 base)) + ;; Constructors + (export make-u16vector u16vector + u16vector-unfold u16vector-unfold-right + u16vector-copy u16vector-reverse-copy + u16vector-append u16vector-concatenate + u16vector-append-subvectors) + ;; Predicates + (export u16? u16vector? u16vector-empty? u16vector=) + ;; Selectors + (export u16vector-ref u16vector-length) + ;; Iteration + (export u16vector-take u16vector-take-right + u16vector-drop u16vector-drop-right + u16vector-segment + u16vector-fold u16vector-fold-right + u16vector-map u16vector-map! u16vector-for-each + u16vector-count u16vector-cumulate) + ;; Searching + (export u16vector-take-while u16vector-take-while-right + u16vector-drop-while u16vector-drop-while-right + u16vector-index u16vector-index-right u16vector-skip u16vector-skip-right + u16vector-any u16vector-every u16vector-partition + u16vector-filter u16vector-remove) + ;; Mutators + (export u16vector-set! u16vector-swap! u16vector-fill! u16vector-reverse! + u16vector-copy! u16vector-reverse-copy! + u16vector-unfold! u16vector-unfold-right!) + ;; Conversion + (export u16vector->list list->u16vector + reverse-u16vector->list reverse-list->u16vector + u16vector->vector vector->u16vector) + ;; Misc + (export make-u16vector-generator u16vector-comparator write-u16vector) + + (include "u16-impl.scm") +) diff --git a/module/srfi/srfi-160/u32-impl.scm b/module/srfi/srfi-160/u32-impl.scm new file mode 100644 index 000000000..0ad064ae8 --- /dev/null +++ b/module/srfi/srfi-160/u32-impl.scm @@ -0,0 +1,601 @@ +;;; SPDX-FileCopyrightText: 2018 John Cowan +;;; +;;; SPDX-License-Identifier: MIT + +;;; This code is the same for all SRFI 160 vector sizes. +;;; The u32s appearing in the code are expanded to u8, s8, etc. + +;; make-u32vector defined in (srfi 160 base) + +;; u32vector defined in (srfi 160 base) + +(define (u32vector-unfold f len seed) + (let ((v (make-u32vector len))) + (let loop ((i 0) (state seed)) + (unless (= i len) + (let-values (((value newstate) (f i state))) + (u32vector-set! v i value) + (loop (+ i 1) newstate)))) + v)) + +(define (u32vector-unfold-right f len seed) + (let ((v (make-u32vector len))) + (let loop ((i (- len 1)) (state seed)) + (unless (= i -1) + (let-values (((value newstate) (f i state))) + (u32vector-set! v i value) + (loop (- i 1) newstate)))) + v)) + +(define u32vector-copy + (case-lambda + ((vec) (u32vector-copy* vec 0 (u32vector-length vec))) + ((vec start) (u32vector-copy* vec start (u32vector-length vec))) + ((vec start end) (u32vector-copy* vec start end)))) + +(define (u32vector-copy* vec start end) + (let ((v (make-u32vector (- end start)))) + (u32vector-copy! v 0 vec start end) + v)) + +(define u32vector-copy! + (case-lambda + ((to at from) + (u32vector-copy!* to at from 0 (u32vector-length from))) + ((to at from start) + (u32vector-copy!* to at from start (u32vector-length from))) + ((to at from start end) (u32vector-copy!* to at from start end)))) + +(define (u32vector-copy!* to at from start end) + (let loop ((at at) (i start)) + (unless (= i end) + (u32vector-set! to at (u32vector-ref from i)) + (loop (+ at 1) (+ i 1))))) + +(define u32vector-reverse-copy + (case-lambda + ((vec) (u32vector-reverse-copy* vec 0 (u32vector-length vec))) + ((vec start) (u32vector-reverse-copy* vec start (u32vector-length vec))) + ((vec start end) (u32vector-reverse-copy* vec start end)))) + +(define (u32vector-reverse-copy* vec start end) + (let ((v (make-u32vector (- end start)))) + (u32vector-reverse-copy! v 0 vec start end) + v)) + +(define u32vector-reverse-copy! + (case-lambda + ((to at from) + (u32vector-reverse-copy!* to at from 0 (u32vector-length from))) + ((to at from start) + (u32vector-reverse-copy!* to at from start (u32vector-length from))) + ((to at from start end) (u32vector-reverse-copy!* to at from start end)))) + +(define (u32vector-reverse-copy!* to at from start end) + (let loop ((at at) (i (- end 1))) + (unless (< i start) + (u32vector-set! to at (u32vector-ref from i)) + (loop (+ at 1) (- i 1))))) + +(define (u32vector-append . vecs) + (u32vector-concatenate vecs)) + +(define (u32vector-concatenate vecs) + (let ((v (make-u32vector (len-sum vecs)))) + (let loop ((vecs vecs) (at 0)) + (unless (null? vecs) + (let ((vec (car vecs))) + (u32vector-copy! v at vec 0 (u32vector-length vec)) + (loop (cdr vecs) (+ at (u32vector-length vec))))) + v))) + +(define (len-sum vecs) + (if (null? vecs) + 0 + (+ (u32vector-length (car vecs)) + (len-sum (cdr vecs))))) + +(define (u32vector-append-subvectors . args) + (let ((v (make-u32vector (len-subsum args)))) + (let loop ((args args) (at 0)) + (unless (null? args) + (let ((vec (car args)) + (start (cadr args)) + (end (caddr args))) + (u32vector-copy! v at vec start end) + (loop (cdddr args) (+ at (- end start)))))) + v)) + +(define (len-subsum vecs) + (if (null? vecs) + 0 + (+ (- (caddr vecs) (cadr vecs)) + (len-subsum (cdddr vecs))))) + +;; u32? defined in (srfi 160 base) + +;; u32vector? defined in (srfi 160 base) + +(define (u32vector-empty? vec) + (zero? (u32vector-length vec))) + +(define (u32vector= . vecs) + (u32vector=* (car vecs) (cadr vecs) (cddr vecs))) + +(define (u32vector=* vec1 vec2 vecs) + (and (u32dyadic-vecs= vec1 0 (u32vector-length vec1) + vec2 0 (u32vector-length vec2)) + (or (null? vecs) + (u32vector=* vec2 (car vecs) (cdr vecs))))) + +(define (u32dyadic-vecs= vec1 start1 end1 vec2 start2 end2) + (cond + ((not (= end1 end2)) #f) + ((not (< start1 end1)) #t) + ((let ((elt1 (u32vector-ref vec1 start1)) + (elt2 (u32vector-ref vec2 start2))) + (= elt1 elt2)) + (u32dyadic-vecs= vec1 (+ start1 1) end1 + vec2 (+ start2 1) end2)) + (else #f))) + +;; u32vector-ref defined in (srfi 160 base) + +;; u32vector-length defined in (srfi 160 base) + +(define (u32vector-take vec n) + (let ((v (make-u32vector n))) + (u32vector-copy! v 0 vec 0 n) + v)) + +(define (u32vector-take-right vec n) + (let ((v (make-u32vector n)) + (len (u32vector-length vec))) + (u32vector-copy! v 0 vec (- len n) len) + v)) + +(define (u32vector-drop vec n) + (let* ((len (u32vector-length vec)) + (vlen (- len n)) + (v (make-u32vector vlen))) + (u32vector-copy! v 0 vec n len) + v)) + +(define (u32vector-drop-right vec n) + (let* ((len (u32vector-length vec)) + (rlen (- len n)) + (v (make-u32vector rlen))) + (u32vector-copy! v 0 vec 0 rlen) + v)) + +(define (u32vector-segment vec n) + (unless (and (integer? n) (positive? n)) + (error "length must be a positive integer" n)) + (let loop ((r '()) (i 0) (remain (u32vector-length vec))) + (if (<= remain 0) + (reverse r) + (let ((size (min n remain))) + (loop + (cons (u32vector-copy vec i (+ i size)) r) + (+ i size) + (- remain size)))))) + +;; aux. procedure +(define (%u32vectors-ref vecs i) + (map (lambda (v) (u32vector-ref v i)) vecs)) + +(define (u32vector-fold kons knil vec . vecs) + (if (null? vecs) + ;; fast path + (let ((len (u32vector-length vec))) + (let loop ((r knil) (i 0)) + (if (= i len) + r + (loop (kons r (u32vector-ref vec i)) (+ i 1))))) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map u32vector-length vecs)))) + (let loop ((r knil) (i 0)) + (if (= i len) + r + (loop (apply kons r (%u32vectors-ref vecs i)) + (+ i 1))))))) + +(define (u32vector-fold-right kons knil vec . vecs) + (if (null? vecs) + ;; fast path + (let ((len (u32vector-length vec))) + (let loop ((r knil) (i (- (u32vector-length vec) 1))) + (if (negative? i) + r + (loop (kons r (u32vector-ref vec i)) (- i 1))))) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map u32vector-length vecs)))) + (let loop ((r knil) (i (- len 1))) + (if (negative? i) + r + (loop (apply kons r (%u32vectors-ref vecs i)) + (- i 1))))))) + +(define (u32vector-map f vec . vecs) + (if (null? vecs) + ;; fast path + (let* ((len (u32vector-length vec)) + (v (make-u32vector len))) + (let loop ((i 0)) + (unless (= i len) + (u32vector-set! v i (f (u32vector-ref vec i))) + (loop (+ i 1)))) + v) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map u32vector-length vecs))) + (v (make-u32vector len))) + (let loop ((i 0)) + (unless (= i len) + (u32vector-set! v i (apply f (%u32vectors-ref vecs i))) + (loop (+ i 1)))) + v))) + + +(define (u32vector-map! f vec . vecs) + (if (null? vecs) + ;; fast path + (let ((len (u32vector-length vec))) + (let loop ((i 0)) + (unless (= i len) + (u32vector-set! vec i (f (u32vector-ref vec i))) + (loop (+ i 1))))) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map u32vector-length vecs)))) + (let loop ((i 0)) + (unless (= i len) + (u32vector-set! vec i (apply f (%u32vectors-ref vecs i))) + (loop (+ i 1))))))) + +(define (u32vector-for-each f vec . vecs) + (if (null? vecs) + ;; fast path + (let ((len (u32vector-length vec))) + (let loop ((i 0)) + (unless (= i len) + (f (u32vector-ref vec i)) + (loop (+ i 1))))) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map u32vector-length vecs)))) + (let loop ((i 0)) + (unless (= i len) + (apply f (%u32vectors-ref vecs i)) + (loop (+ i 1))))))) + +(define (u32vector-count pred vec . vecs) + (if (null? vecs) + ;; fast path + (let ((len (u32vector-length vec))) + (let loop ((i 0) (r 0)) + (cond + ((= i (u32vector-length vec)) r) + ((pred (u32vector-ref vec i)) (loop (+ i 1) (+ r 1))) + (else (loop (+ i 1) r))))) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map u32vector-length vecs)))) + (let loop ((i 0) (r 0)) + (cond + ((= i len) r) + ((apply pred (%u32vectors-ref vecs i)) (loop (+ i 1) (+ r 1))) + (else (loop (+ i 1) r))))))) + +(define (u32vector-cumulate f knil vec) + (let* ((len (u32vector-length vec)) + (v (make-u32vector len))) + (let loop ((r knil) (i 0)) + (unless (= i len) + (let ((next (f r (u32vector-ref vec i)))) + (u32vector-set! v i next) + (loop next (+ i 1))))) + v)) + +(define (u32vector-foreach f vec) + (let ((len (u32vector-length vec))) + (let loop ((i 0)) + (unless (= i len) + (f (u32vector-ref vec i)) + (loop (+ i 1)))))) + +(define (u32vector-take-while pred vec) + (let* ((len (u32vector-length vec)) + (idx (u32vector-skip pred vec)) + (idx* (if idx idx len))) + (u32vector-copy vec 0 idx*))) + +(define (u32vector-take-while-right pred vec) + (let* ((len (u32vector-length vec)) + (idx (u32vector-skip-right pred vec)) + (idx* (if idx (+ idx 1) 0))) + (u32vector-copy vec idx* len))) + +(define (u32vector-drop-while pred vec) + (let* ((len (u32vector-length vec)) + (idx (u32vector-skip pred vec)) + (idx* (if idx idx len))) + (u32vector-copy vec idx* len))) + +(define (u32vector-drop-while-right pred vec) + (let* ((len (u32vector-length vec)) + (idx (u32vector-skip-right pred vec)) + (idx* (if idx idx -1))) + (u32vector-copy vec 0 (+ 1 idx*)))) + +(define (u32vector-index pred vec . vecs) + (if (null? vecs) + ;; fast path + (let ((len (u32vector-length vec))) + (let loop ((i 0)) + (cond + ((= i len) #f) + ((pred (u32vector-ref vec i)) i) + (else (loop (+ i 1)))))) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map u32vector-length vecs)))) + (let loop ((i 0)) + (cond + ((= i len) #f) + ((apply pred (%u32vectors-ref vecs i)) i) + (else (loop (+ i 1)))))))) + +(define (u32vector-index-right pred vec . vecs) + (if (null? vecs) + ;; fast path + (let ((len (u32vector-length vec))) + (let loop ((i (- len 1))) + (cond + ((negative? i) #f) + ((pred (u32vector-ref vec i)) i) + (else (loop (- i 1)))))) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map u32vector-length vecs)))) + (let loop ((i (- len 1))) + (cond + ((negative? i) #f) + ((apply pred (%u32vectors-ref vecs i)) i) + (else (loop (- i 1)))))))) + +(define (u32vector-skip pred vec . vecs) + (if (null? vecs) + (u32vector-index (lambda (x) (not (pred x))) vec) + (apply u32vector-index (lambda xs (not (apply pred xs))) vec vecs))) + +(define (u32vector-skip-right pred vec . vecs) + (if (null? vecs) + (u32vector-index-right (lambda (x) (not (pred x))) vec) + (apply u32vector-index-right (lambda xs (not (apply pred xs))) vec vecs))) + +(define (u32vector-any pred vec . vecs) + (if (null? vecs) + ;; fast path + (let ((len (u32vector-length vec))) + (let loop ((i 0)) + (cond + ((= i len) #f) + ((pred (u32vector-ref vec i))) ;returns result of pred + (else (loop (+ i 1)))))) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map u32vector-length vecs)))) + (let loop ((i 0)) + (cond + ((= i len) #f) + ((apply pred (%u32vectors-ref vecs i))) ;returns result of pred + (else (loop (+ i 1)))))))) + +(define (u32vector-every pred vec . vecs) + (if (null? vecs) + ;; fast path + (let ((len (u32vector-length vec))) + (let loop ((i 0) (last #t)) + (cond + ((= i len) last) + ((pred (u32vector-ref vec i)) => (lambda (r) (loop (+ i 1) r))) + (else #f)))) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map u32vector-length vecs)))) + (let loop ((i 0) (last #t)) + (cond + ((= i len) last) + ((apply pred (%u32vectors-ref vecs i)) => (lambda (r) (loop (+ i 1) r))) + (else #f)))))) + +(define (u32vector-partition pred vec) + (let* ((len (u32vector-length vec)) + (cnt (u32vector-count pred vec)) + (r (make-u32vector len))) + (let loop ((i 0) (yes 0) (no cnt)) + (cond + ((= i len) (values r cnt)) + ((pred (u32vector-ref vec i)) + (u32vector-set! r yes (u32vector-ref vec i)) + (loop (+ i 1) (+ yes 1) no)) + (else + (u32vector-set! r no (u32vector-ref vec i)) + (loop (+ i 1) yes (+ no 1))))))) + +(define (u32vector-filter pred vec) + (let* ((len (u32vector-length vec)) + (cnt (u32vector-count pred vec)) + (r (make-u32vector cnt))) + (let loop ((i 0) (j 0)) + (cond + ((= i len) r) + ((pred (u32vector-ref vec i)) + (u32vector-set! r j (u32vector-ref vec i)) + (loop (+ i 1) (+ j 1))) + (else + (loop (+ i 1) j)))))) + +(define (u32vector-remove pred vec) + (u32vector-filter (lambda (x) (not (pred x))) vec)) + +;; u32vector-set! defined in (srfi 160 base) + +(define (u32vector-swap! vec i j) + (let ((ival (u32vector-ref vec i)) + (jval (u32vector-ref vec j))) + (u32vector-set! vec i jval) + (u32vector-set! vec j ival))) + +(define u32vector-fill! + (case-lambda + ((vec fill) (u32vector-fill-some! vec fill 0 (u32vector-length vec))) + ((vec fill start) (u32vector-fill-some! vec fill start (u32vector-length vec))) + ((vec fill start end) (u32vector-fill-some! vec fill start end)))) + +(define (u32vector-fill-some! vec fill start end) + (unless (= start end) + (u32vector-set! vec start fill) + (u32vector-fill-some! vec fill (+ start 1) end))) + +(define u32vector-reverse! + (case-lambda + ((vec) (u32vector-reverse-some! vec 0 (u32vector-length vec))) + ((vec start) (u32vector-reverse-some! vec start (u32vector-length vec))) + ((vec start end) (u32vector-reverse-some! vec start end)))) + +(define (u32vector-reverse-some! vec start end) + (let loop ((i start) (j (- end 1))) + (when (< i j) + (u32vector-swap! vec i j) + (loop (+ i 1) (- j 1))))) + +(define (u32vector-unfold! f vec start end seed) + (let loop ((i start) (seed seed)) + (when (< i end) + (let-values (((elt seed) (f i seed))) + (u32vector-set! vec i elt) + (loop (+ i 1) seed))))) + +(define (u32vector-unfold-right! f vec start end seed) + (let loop ((i (- end 1)) (seed seed)) + (when (>= i start) + (let-values (((elt seed) (f i seed))) + (u32vector-set! vec i elt) + (loop (- i 1) seed))))) + +(define reverse-u32vector->list + (case-lambda + ((vec) (reverse-u32vector->list* vec 0 (u32vector-length vec))) + ((vec start) (reverse-u32vector->list* vec start (u32vector-length vec))) + ((vec start end) (reverse-u32vector->list* vec start end)))) + +(define (reverse-u32vector->list* vec start end) + (let loop ((i start) (r '())) + (if (= i end) + r + (loop (+ 1 i) (cons (u32vector-ref vec i) r))))) + +(define (reverse-list->u32vector list) + (let* ((len (length list)) + (r (make-u32vector len))) + (let loop ((i 0) (list list)) + (cond + ((= i len) r) + (else + (u32vector-set! r (- len i 1) (car list)) + (loop (+ i 1) (cdr list))))))) + +(define u32vector->vector + (case-lambda + ((vec) (u32vector->vector* vec 0 (u32vector-length vec))) + ((vec start) (u32vector->vector* vec start (u32vector-length vec))) + ((vec start end) (u32vector->vector* vec start end)))) + +(define (u32vector->vector* vec start end) + (let* ((len (- end start)) + (r (make-vector len))) + (let loop ((i start) (o 0)) + (cond + ((= i end) r) + (else + (vector-set! r o (u32vector-ref vec i)) + (loop (+ i 1) (+ o 1))))))) + +(define vector->u32vector + (case-lambda + ((vec) (vector->u32vector* vec 0 (vector-length vec))) + ((vec start) (vector->u32vector* vec start (vector-length vec))) + ((vec start end) (vector->u32vector* vec start end)))) + +(define (vector->u32vector* vec start end) + (let* ((len (- end start)) + (r (make-u32vector len))) + (let loop ((i start) (o 0)) + (cond + ((= i end) r) + (else + (u32vector-set! r o (vector-ref vec i)) + (loop (+ i 1) (+ o 1))))))) + +(define make-u32vector-generator + (case-lambda ((vec) (make-u32vector-generator vec 0 (u32vector-length vec))) + ((vec start) (make-u32vector-generator vec start (u32vector-length vec))) + ((vec start end) + (lambda () (if (>= start end) + (eof-object) + (let ((next (u32vector-ref vec start))) + (set! start (+ start 1)) + next)))))) + +(define write-u32vector + (case-lambda + ((vec) (write-u32vector* vec (current-output-port))) + ((vec port) (write-u32vector* vec port)))) + + +(define (write-u32vector* vec port) + (display "#u32(" port) ; u32-expansion is blind, so will expand this too + (let ((last (- (u32vector-length vec) 1))) + (let loop ((i 0)) + (cond + ((= i last) + (write (u32vector-ref vec i) port) + (display ")" port)) + (else + (write (u32vector-ref vec i) port) + (display " " port) + (loop (+ i 1))))))) + +(define (u32vector< vec1 vec2) + (let ((len1 (u32vector-length vec1)) + (len2 (u32vector-length vec2))) + (cond + ((< len1 len2) + #t) + ((> len1 len2) + #f) + (else + (let loop ((i 0)) + (cond + ((= i len1) + #f) + ((< (u32vector-ref vec1 i) (u32vector-ref vec2 i)) + #t) + ((> (u32vector-ref vec1 i) (u32vector-ref vec2 i)) + #f) + (else + (loop (+ i 1))))))))) + +(define (u32vector-hash vec) + (let ((len (min 256 (u32vector-length vec)))) + (let loop ((i 0) (r 0)) + (if (= i len) + (abs (floor (real-part (inexact->exact r)))) + (loop (+ i 1) (+ r (u32vector-ref vec i))))))) + +(define u32vector-comparator + (make-comparator u32vector? u32vector= u32vector< u32vector-hash)) diff --git a/module/srfi/srfi-160/u32.sld b/module/srfi/srfi-160/u32.sld new file mode 100644 index 000000000..47d4d5dcf --- /dev/null +++ b/module/srfi/srfi-160/u32.sld @@ -0,0 +1,49 @@ +;;; SPDX-FileCopyrightText: 2018 John Cowan +;;; +;;; SPDX-License-Identifier: MIT + +(define-library (srfi srfi-160 u32) + (import (scheme base)) + (import (scheme case-lambda)) + (import (scheme cxr)) + (import (only (scheme r5rs) inexact->exact)) + (import (scheme complex)) + (import (scheme write)) + (import (srfi srfi-128)) + (import (srfi srfi-160 base)) + ;; Constructors + (export make-u32vector u32vector + u32vector-unfold u32vector-unfold-right + u32vector-copy u32vector-reverse-copy + u32vector-append u32vector-concatenate + u32vector-append-subvectors) + ;; Predicates + (export u32? u32vector? u32vector-empty? u32vector=) + ;; Selectors + (export u32vector-ref u32vector-length) + ;; Iteration + (export u32vector-take u32vector-take-right + u32vector-drop u32vector-drop-right + u32vector-segment + u32vector-fold u32vector-fold-right + u32vector-map u32vector-map! u32vector-for-each + u32vector-count u32vector-cumulate) + ;; Searching + (export u32vector-take-while u32vector-take-while-right + u32vector-drop-while u32vector-drop-while-right + u32vector-index u32vector-index-right u32vector-skip u32vector-skip-right + u32vector-any u32vector-every u32vector-partition + u32vector-filter u32vector-remove) + ;; Mutators + (export u32vector-set! u32vector-swap! u32vector-fill! u32vector-reverse! + u32vector-copy! u32vector-reverse-copy! + u32vector-unfold! u32vector-unfold-right!) + ;; Conversion + (export u32vector->list list->u32vector + reverse-u32vector->list reverse-list->u32vector + u32vector->vector vector->u32vector) + ;; Misc + (export make-u32vector-generator u32vector-comparator write-u32vector) + + (include "u32-impl.scm") +) diff --git a/module/srfi/srfi-160/u64-impl.scm b/module/srfi/srfi-160/u64-impl.scm new file mode 100644 index 000000000..48f1f3d93 --- /dev/null +++ b/module/srfi/srfi-160/u64-impl.scm @@ -0,0 +1,601 @@ +;;; SPDX-FileCopyrightText: 2018 John Cowan +;;; +;;; SPDX-License-Identifier: MIT + +;;; This code is the same for all SRFI 160 vector sizes. +;;; The u64s appearing in the code are expanded to u8, s8, etc. + +;; make-u64vector defined in (srfi 160 base) + +;; u64vector defined in (srfi 160 base) + +(define (u64vector-unfold f len seed) + (let ((v (make-u64vector len))) + (let loop ((i 0) (state seed)) + (unless (= i len) + (let-values (((value newstate) (f i state))) + (u64vector-set! v i value) + (loop (+ i 1) newstate)))) + v)) + +(define (u64vector-unfold-right f len seed) + (let ((v (make-u64vector len))) + (let loop ((i (- len 1)) (state seed)) + (unless (= i -1) + (let-values (((value newstate) (f i state))) + (u64vector-set! v i value) + (loop (- i 1) newstate)))) + v)) + +(define u64vector-copy + (case-lambda + ((vec) (u64vector-copy* vec 0 (u64vector-length vec))) + ((vec start) (u64vector-copy* vec start (u64vector-length vec))) + ((vec start end) (u64vector-copy* vec start end)))) + +(define (u64vector-copy* vec start end) + (let ((v (make-u64vector (- end start)))) + (u64vector-copy! v 0 vec start end) + v)) + +(define u64vector-copy! + (case-lambda + ((to at from) + (u64vector-copy!* to at from 0 (u64vector-length from))) + ((to at from start) + (u64vector-copy!* to at from start (u64vector-length from))) + ((to at from start end) (u64vector-copy!* to at from start end)))) + +(define (u64vector-copy!* to at from start end) + (let loop ((at at) (i start)) + (unless (= i end) + (u64vector-set! to at (u64vector-ref from i)) + (loop (+ at 1) (+ i 1))))) + +(define u64vector-reverse-copy + (case-lambda + ((vec) (u64vector-reverse-copy* vec 0 (u64vector-length vec))) + ((vec start) (u64vector-reverse-copy* vec start (u64vector-length vec))) + ((vec start end) (u64vector-reverse-copy* vec start end)))) + +(define (u64vector-reverse-copy* vec start end) + (let ((v (make-u64vector (- end start)))) + (u64vector-reverse-copy! v 0 vec start end) + v)) + +(define u64vector-reverse-copy! + (case-lambda + ((to at from) + (u64vector-reverse-copy!* to at from 0 (u64vector-length from))) + ((to at from start) + (u64vector-reverse-copy!* to at from start (u64vector-length from))) + ((to at from start end) (u64vector-reverse-copy!* to at from start end)))) + +(define (u64vector-reverse-copy!* to at from start end) + (let loop ((at at) (i (- end 1))) + (unless (< i start) + (u64vector-set! to at (u64vector-ref from i)) + (loop (+ at 1) (- i 1))))) + +(define (u64vector-append . vecs) + (u64vector-concatenate vecs)) + +(define (u64vector-concatenate vecs) + (let ((v (make-u64vector (len-sum vecs)))) + (let loop ((vecs vecs) (at 0)) + (unless (null? vecs) + (let ((vec (car vecs))) + (u64vector-copy! v at vec 0 (u64vector-length vec)) + (loop (cdr vecs) (+ at (u64vector-length vec))))) + v))) + +(define (len-sum vecs) + (if (null? vecs) + 0 + (+ (u64vector-length (car vecs)) + (len-sum (cdr vecs))))) + +(define (u64vector-append-subvectors . args) + (let ((v (make-u64vector (len-subsum args)))) + (let loop ((args args) (at 0)) + (unless (null? args) + (let ((vec (car args)) + (start (cadr args)) + (end (caddr args))) + (u64vector-copy! v at vec start end) + (loop (cdddr args) (+ at (- end start)))))) + v)) + +(define (len-subsum vecs) + (if (null? vecs) + 0 + (+ (- (caddr vecs) (cadr vecs)) + (len-subsum (cdddr vecs))))) + +;; u64? defined in (srfi 160 base) + +;; u64vector? defined in (srfi 160 base) + +(define (u64vector-empty? vec) + (zero? (u64vector-length vec))) + +(define (u64vector= . vecs) + (u64vector=* (car vecs) (cadr vecs) (cddr vecs))) + +(define (u64vector=* vec1 vec2 vecs) + (and (u64dyadic-vecs= vec1 0 (u64vector-length vec1) + vec2 0 (u64vector-length vec2)) + (or (null? vecs) + (u64vector=* vec2 (car vecs) (cdr vecs))))) + +(define (u64dyadic-vecs= vec1 start1 end1 vec2 start2 end2) + (cond + ((not (= end1 end2)) #f) + ((not (< start1 end1)) #t) + ((let ((elt1 (u64vector-ref vec1 start1)) + (elt2 (u64vector-ref vec2 start2))) + (= elt1 elt2)) + (u64dyadic-vecs= vec1 (+ start1 1) end1 + vec2 (+ start2 1) end2)) + (else #f))) + +;; u64vector-ref defined in (srfi 160 base) + +;; u64vector-length defined in (srfi 160 base) + +(define (u64vector-take vec n) + (let ((v (make-u64vector n))) + (u64vector-copy! v 0 vec 0 n) + v)) + +(define (u64vector-take-right vec n) + (let ((v (make-u64vector n)) + (len (u64vector-length vec))) + (u64vector-copy! v 0 vec (- len n) len) + v)) + +(define (u64vector-drop vec n) + (let* ((len (u64vector-length vec)) + (vlen (- len n)) + (v (make-u64vector vlen))) + (u64vector-copy! v 0 vec n len) + v)) + +(define (u64vector-drop-right vec n) + (let* ((len (u64vector-length vec)) + (rlen (- len n)) + (v (make-u64vector rlen))) + (u64vector-copy! v 0 vec 0 rlen) + v)) + +(define (u64vector-segment vec n) + (unless (and (integer? n) (positive? n)) + (error "length must be a positive integer" n)) + (let loop ((r '()) (i 0) (remain (u64vector-length vec))) + (if (<= remain 0) + (reverse r) + (let ((size (min n remain))) + (loop + (cons (u64vector-copy vec i (+ i size)) r) + (+ i size) + (- remain size)))))) + +;; aux. procedure +(define (%u64vectors-ref vecs i) + (map (lambda (v) (u64vector-ref v i)) vecs)) + +(define (u64vector-fold kons knil vec . vecs) + (if (null? vecs) + ;; fast path + (let ((len (u64vector-length vec))) + (let loop ((r knil) (i 0)) + (if (= i len) + r + (loop (kons r (u64vector-ref vec i)) (+ i 1))))) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map u64vector-length vecs)))) + (let loop ((r knil) (i 0)) + (if (= i len) + r + (loop (apply kons r (%u64vectors-ref vecs i)) + (+ i 1))))))) + +(define (u64vector-fold-right kons knil vec . vecs) + (if (null? vecs) + ;; fast path + (let ((len (u64vector-length vec))) + (let loop ((r knil) (i (- (u64vector-length vec) 1))) + (if (negative? i) + r + (loop (kons r (u64vector-ref vec i)) (- i 1))))) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map u64vector-length vecs)))) + (let loop ((r knil) (i (- len 1))) + (if (negative? i) + r + (loop (apply kons r (%u64vectors-ref vecs i)) + (- i 1))))))) + +(define (u64vector-map f vec . vecs) + (if (null? vecs) + ;; fast path + (let* ((len (u64vector-length vec)) + (v (make-u64vector len))) + (let loop ((i 0)) + (unless (= i len) + (u64vector-set! v i (f (u64vector-ref vec i))) + (loop (+ i 1)))) + v) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map u64vector-length vecs))) + (v (make-u64vector len))) + (let loop ((i 0)) + (unless (= i len) + (u64vector-set! v i (apply f (%u64vectors-ref vecs i))) + (loop (+ i 1)))) + v))) + + +(define (u64vector-map! f vec . vecs) + (if (null? vecs) + ;; fast path + (let ((len (u64vector-length vec))) + (let loop ((i 0)) + (unless (= i len) + (u64vector-set! vec i (f (u64vector-ref vec i))) + (loop (+ i 1))))) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map u64vector-length vecs)))) + (let loop ((i 0)) + (unless (= i len) + (u64vector-set! vec i (apply f (%u64vectors-ref vecs i))) + (loop (+ i 1))))))) + +(define (u64vector-for-each f vec . vecs) + (if (null? vecs) + ;; fast path + (let ((len (u64vector-length vec))) + (let loop ((i 0)) + (unless (= i len) + (f (u64vector-ref vec i)) + (loop (+ i 1))))) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map u64vector-length vecs)))) + (let loop ((i 0)) + (unless (= i len) + (apply f (%u64vectors-ref vecs i)) + (loop (+ i 1))))))) + +(define (u64vector-count pred vec . vecs) + (if (null? vecs) + ;; fast path + (let ((len (u64vector-length vec))) + (let loop ((i 0) (r 0)) + (cond + ((= i (u64vector-length vec)) r) + ((pred (u64vector-ref vec i)) (loop (+ i 1) (+ r 1))) + (else (loop (+ i 1) r))))) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map u64vector-length vecs)))) + (let loop ((i 0) (r 0)) + (cond + ((= i len) r) + ((apply pred (%u64vectors-ref vecs i)) (loop (+ i 1) (+ r 1))) + (else (loop (+ i 1) r))))))) + +(define (u64vector-cumulate f knil vec) + (let* ((len (u64vector-length vec)) + (v (make-u64vector len))) + (let loop ((r knil) (i 0)) + (unless (= i len) + (let ((next (f r (u64vector-ref vec i)))) + (u64vector-set! v i next) + (loop next (+ i 1))))) + v)) + +(define (u64vector-foreach f vec) + (let ((len (u64vector-length vec))) + (let loop ((i 0)) + (unless (= i len) + (f (u64vector-ref vec i)) + (loop (+ i 1)))))) + +(define (u64vector-take-while pred vec) + (let* ((len (u64vector-length vec)) + (idx (u64vector-skip pred vec)) + (idx* (if idx idx len))) + (u64vector-copy vec 0 idx*))) + +(define (u64vector-take-while-right pred vec) + (let* ((len (u64vector-length vec)) + (idx (u64vector-skip-right pred vec)) + (idx* (if idx (+ idx 1) 0))) + (u64vector-copy vec idx* len))) + +(define (u64vector-drop-while pred vec) + (let* ((len (u64vector-length vec)) + (idx (u64vector-skip pred vec)) + (idx* (if idx idx len))) + (u64vector-copy vec idx* len))) + +(define (u64vector-drop-while-right pred vec) + (let* ((len (u64vector-length vec)) + (idx (u64vector-skip-right pred vec)) + (idx* (if idx idx -1))) + (u64vector-copy vec 0 (+ 1 idx*)))) + +(define (u64vector-index pred vec . vecs) + (if (null? vecs) + ;; fast path + (let ((len (u64vector-length vec))) + (let loop ((i 0)) + (cond + ((= i len) #f) + ((pred (u64vector-ref vec i)) i) + (else (loop (+ i 1)))))) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map u64vector-length vecs)))) + (let loop ((i 0)) + (cond + ((= i len) #f) + ((apply pred (%u64vectors-ref vecs i)) i) + (else (loop (+ i 1)))))))) + +(define (u64vector-index-right pred vec . vecs) + (if (null? vecs) + ;; fast path + (let ((len (u64vector-length vec))) + (let loop ((i (- len 1))) + (cond + ((negative? i) #f) + ((pred (u64vector-ref vec i)) i) + (else (loop (- i 1)))))) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map u64vector-length vecs)))) + (let loop ((i (- len 1))) + (cond + ((negative? i) #f) + ((apply pred (%u64vectors-ref vecs i)) i) + (else (loop (- i 1)))))))) + +(define (u64vector-skip pred vec . vecs) + (if (null? vecs) + (u64vector-index (lambda (x) (not (pred x))) vec) + (apply u64vector-index (lambda xs (not (apply pred xs))) vec vecs))) + +(define (u64vector-skip-right pred vec . vecs) + (if (null? vecs) + (u64vector-index-right (lambda (x) (not (pred x))) vec) + (apply u64vector-index-right (lambda xs (not (apply pred xs))) vec vecs))) + +(define (u64vector-any pred vec . vecs) + (if (null? vecs) + ;; fast path + (let ((len (u64vector-length vec))) + (let loop ((i 0)) + (cond + ((= i len) #f) + ((pred (u64vector-ref vec i))) ;returns result of pred + (else (loop (+ i 1)))))) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map u64vector-length vecs)))) + (let loop ((i 0)) + (cond + ((= i len) #f) + ((apply pred (%u64vectors-ref vecs i))) ;returns result of pred + (else (loop (+ i 1)))))))) + +(define (u64vector-every pred vec . vecs) + (if (null? vecs) + ;; fast path + (let ((len (u64vector-length vec))) + (let loop ((i 0) (last #t)) + (cond + ((= i len) last) + ((pred (u64vector-ref vec i)) => (lambda (r) (loop (+ i 1) r))) + (else #f)))) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map u64vector-length vecs)))) + (let loop ((i 0) (last #t)) + (cond + ((= i len) last) + ((apply pred (%u64vectors-ref vecs i)) => (lambda (r) (loop (+ i 1) r))) + (else #f)))))) + +(define (u64vector-partition pred vec) + (let* ((len (u64vector-length vec)) + (cnt (u64vector-count pred vec)) + (r (make-u64vector len))) + (let loop ((i 0) (yes 0) (no cnt)) + (cond + ((= i len) (values r cnt)) + ((pred (u64vector-ref vec i)) + (u64vector-set! r yes (u64vector-ref vec i)) + (loop (+ i 1) (+ yes 1) no)) + (else + (u64vector-set! r no (u64vector-ref vec i)) + (loop (+ i 1) yes (+ no 1))))))) + +(define (u64vector-filter pred vec) + (let* ((len (u64vector-length vec)) + (cnt (u64vector-count pred vec)) + (r (make-u64vector cnt))) + (let loop ((i 0) (j 0)) + (cond + ((= i len) r) + ((pred (u64vector-ref vec i)) + (u64vector-set! r j (u64vector-ref vec i)) + (loop (+ i 1) (+ j 1))) + (else + (loop (+ i 1) j)))))) + +(define (u64vector-remove pred vec) + (u64vector-filter (lambda (x) (not (pred x))) vec)) + +;; u64vector-set! defined in (srfi 160 base) + +(define (u64vector-swap! vec i j) + (let ((ival (u64vector-ref vec i)) + (jval (u64vector-ref vec j))) + (u64vector-set! vec i jval) + (u64vector-set! vec j ival))) + +(define u64vector-fill! + (case-lambda + ((vec fill) (u64vector-fill-some! vec fill 0 (u64vector-length vec))) + ((vec fill start) (u64vector-fill-some! vec fill start (u64vector-length vec))) + ((vec fill start end) (u64vector-fill-some! vec fill start end)))) + +(define (u64vector-fill-some! vec fill start end) + (unless (= start end) + (u64vector-set! vec start fill) + (u64vector-fill-some! vec fill (+ start 1) end))) + +(define u64vector-reverse! + (case-lambda + ((vec) (u64vector-reverse-some! vec 0 (u64vector-length vec))) + ((vec start) (u64vector-reverse-some! vec start (u64vector-length vec))) + ((vec start end) (u64vector-reverse-some! vec start end)))) + +(define (u64vector-reverse-some! vec start end) + (let loop ((i start) (j (- end 1))) + (when (< i j) + (u64vector-swap! vec i j) + (loop (+ i 1) (- j 1))))) + +(define (u64vector-unfold! f vec start end seed) + (let loop ((i start) (seed seed)) + (when (< i end) + (let-values (((elt seed) (f i seed))) + (u64vector-set! vec i elt) + (loop (+ i 1) seed))))) + +(define (u64vector-unfold-right! f vec start end seed) + (let loop ((i (- end 1)) (seed seed)) + (when (>= i start) + (let-values (((elt seed) (f i seed))) + (u64vector-set! vec i elt) + (loop (- i 1) seed))))) + +(define reverse-u64vector->list + (case-lambda + ((vec) (reverse-u64vector->list* vec 0 (u64vector-length vec))) + ((vec start) (reverse-u64vector->list* vec start (u64vector-length vec))) + ((vec start end) (reverse-u64vector->list* vec start end)))) + +(define (reverse-u64vector->list* vec start end) + (let loop ((i start) (r '())) + (if (= i end) + r + (loop (+ 1 i) (cons (u64vector-ref vec i) r))))) + +(define (reverse-list->u64vector list) + (let* ((len (length list)) + (r (make-u64vector len))) + (let loop ((i 0) (list list)) + (cond + ((= i len) r) + (else + (u64vector-set! r (- len i 1) (car list)) + (loop (+ i 1) (cdr list))))))) + +(define u64vector->vector + (case-lambda + ((vec) (u64vector->vector* vec 0 (u64vector-length vec))) + ((vec start) (u64vector->vector* vec start (u64vector-length vec))) + ((vec start end) (u64vector->vector* vec start end)))) + +(define (u64vector->vector* vec start end) + (let* ((len (- end start)) + (r (make-vector len))) + (let loop ((i start) (o 0)) + (cond + ((= i end) r) + (else + (vector-set! r o (u64vector-ref vec i)) + (loop (+ i 1) (+ o 1))))))) + +(define vector->u64vector + (case-lambda + ((vec) (vector->u64vector* vec 0 (vector-length vec))) + ((vec start) (vector->u64vector* vec start (vector-length vec))) + ((vec start end) (vector->u64vector* vec start end)))) + +(define (vector->u64vector* vec start end) + (let* ((len (- end start)) + (r (make-u64vector len))) + (let loop ((i start) (o 0)) + (cond + ((= i end) r) + (else + (u64vector-set! r o (vector-ref vec i)) + (loop (+ i 1) (+ o 1))))))) + +(define make-u64vector-generator + (case-lambda ((vec) (make-u64vector-generator vec 0 (u64vector-length vec))) + ((vec start) (make-u64vector-generator vec start (u64vector-length vec))) + ((vec start end) + (lambda () (if (>= start end) + (eof-object) + (let ((next (u64vector-ref vec start))) + (set! start (+ start 1)) + next)))))) + +(define write-u64vector + (case-lambda + ((vec) (write-u64vector* vec (current-output-port))) + ((vec port) (write-u64vector* vec port)))) + + +(define (write-u64vector* vec port) + (display "#u64(" port) ; u64-expansion is blind, so will expand this too + (let ((last (- (u64vector-length vec) 1))) + (let loop ((i 0)) + (cond + ((= i last) + (write (u64vector-ref vec i) port) + (display ")" port)) + (else + (write (u64vector-ref vec i) port) + (display " " port) + (loop (+ i 1))))))) + +(define (u64vector< vec1 vec2) + (let ((len1 (u64vector-length vec1)) + (len2 (u64vector-length vec2))) + (cond + ((< len1 len2) + #t) + ((> len1 len2) + #f) + (else + (let loop ((i 0)) + (cond + ((= i len1) + #f) + ((< (u64vector-ref vec1 i) (u64vector-ref vec2 i)) + #t) + ((> (u64vector-ref vec1 i) (u64vector-ref vec2 i)) + #f) + (else + (loop (+ i 1))))))))) + +(define (u64vector-hash vec) + (let ((len (min 256 (u64vector-length vec)))) + (let loop ((i 0) (r 0)) + (if (= i len) + (abs (floor (real-part (inexact->exact r)))) + (loop (+ i 1) (+ r (u64vector-ref vec i))))))) + +(define u64vector-comparator + (make-comparator u64vector? u64vector= u64vector< u64vector-hash)) diff --git a/module/srfi/srfi-160/u64.sld b/module/srfi/srfi-160/u64.sld new file mode 100644 index 000000000..1c03c3194 --- /dev/null +++ b/module/srfi/srfi-160/u64.sld @@ -0,0 +1,49 @@ +;;; SPDX-FileCopyrightText: 2018 John Cowan +;;; +;;; SPDX-License-Identifier: MIT + +(define-library (srfi srfi-160 u64) + (import (scheme base)) + (import (scheme case-lambda)) + (import (scheme cxr)) + (import (only (scheme r5rs) inexact->exact)) + (import (scheme complex)) + (import (scheme write)) + (import (srfi srfi-128)) + (import (srfi srfi-160 base)) + ;; Constructors + (export make-u64vector u64vector + u64vector-unfold u64vector-unfold-right + u64vector-copy u64vector-reverse-copy + u64vector-append u64vector-concatenate + u64vector-append-subvectors) + ;; Predicates + (export u64? u64vector? u64vector-empty? u64vector=) + ;; Selectors + (export u64vector-ref u64vector-length) + ;; Iteration + (export u64vector-take u64vector-take-right + u64vector-drop u64vector-drop-right + u64vector-segment + u64vector-fold u64vector-fold-right + u64vector-map u64vector-map! u64vector-for-each + u64vector-count u64vector-cumulate) + ;; Searching + (export u64vector-take-while u64vector-take-while-right + u64vector-drop-while u64vector-drop-while-right + u64vector-index u64vector-index-right u64vector-skip u64vector-skip-right + u64vector-any u64vector-every u64vector-partition + u64vector-filter u64vector-remove) + ;; Mutators + (export u64vector-set! u64vector-swap! u64vector-fill! u64vector-reverse! + u64vector-copy! u64vector-reverse-copy! + u64vector-unfold! u64vector-unfold-right!) + ;; Conversion + (export u64vector->list list->u64vector + reverse-u64vector->list reverse-list->u64vector + u64vector->vector vector->u64vector) + ;; Misc + (export make-u64vector-generator u64vector-comparator write-u64vector) + + (include "u64-impl.scm") +) diff --git a/module/srfi/srfi-160/u8-impl.scm b/module/srfi/srfi-160/u8-impl.scm new file mode 100644 index 000000000..00705c98a --- /dev/null +++ b/module/srfi/srfi-160/u8-impl.scm @@ -0,0 +1,601 @@ +;;; SPDX-FileCopyrightText: 2018 John Cowan +;;; +;;; SPDX-License-Identifier: MIT + +;;; This code is the same for all SRFI 160 vector sizes. +;;; The u8s appearing in the code are expanded to u8, s8, etc. + +;; make-u8vector defined in (srfi 160 base) + +;; u8vector defined in (srfi 160 base) + +(define (u8vector-unfold f len seed) + (let ((v (make-u8vector len))) + (let loop ((i 0) (state seed)) + (unless (= i len) + (let-values (((value newstate) (f i state))) + (u8vector-set! v i value) + (loop (+ i 1) newstate)))) + v)) + +(define (u8vector-unfold-right f len seed) + (let ((v (make-u8vector len))) + (let loop ((i (- len 1)) (state seed)) + (unless (= i -1) + (let-values (((value newstate) (f i state))) + (u8vector-set! v i value) + (loop (- i 1) newstate)))) + v)) + +(define u8vector-copy + (case-lambda + ((vec) (u8vector-copy* vec 0 (u8vector-length vec))) + ((vec start) (u8vector-copy* vec start (u8vector-length vec))) + ((vec start end) (u8vector-copy* vec start end)))) + +(define (u8vector-copy* vec start end) + (let ((v (make-u8vector (- end start)))) + (u8vector-copy! v 0 vec start end) + v)) + +(define u8vector-copy! + (case-lambda + ((to at from) + (u8vector-copy!* to at from 0 (u8vector-length from))) + ((to at from start) + (u8vector-copy!* to at from start (u8vector-length from))) + ((to at from start end) (u8vector-copy!* to at from start end)))) + +(define (u8vector-copy!* to at from start end) + (let loop ((at at) (i start)) + (unless (= i end) + (u8vector-set! to at (u8vector-ref from i)) + (loop (+ at 1) (+ i 1))))) + +(define u8vector-reverse-copy + (case-lambda + ((vec) (u8vector-reverse-copy* vec 0 (u8vector-length vec))) + ((vec start) (u8vector-reverse-copy* vec start (u8vector-length vec))) + ((vec start end) (u8vector-reverse-copy* vec start end)))) + +(define (u8vector-reverse-copy* vec start end) + (let ((v (make-u8vector (- end start)))) + (u8vector-reverse-copy! v 0 vec start end) + v)) + +(define u8vector-reverse-copy! + (case-lambda + ((to at from) + (u8vector-reverse-copy!* to at from 0 (u8vector-length from))) + ((to at from start) + (u8vector-reverse-copy!* to at from start (u8vector-length from))) + ((to at from start end) (u8vector-reverse-copy!* to at from start end)))) + +(define (u8vector-reverse-copy!* to at from start end) + (let loop ((at at) (i (- end 1))) + (unless (< i start) + (u8vector-set! to at (u8vector-ref from i)) + (loop (+ at 1) (- i 1))))) + +(define (u8vector-append . vecs) + (u8vector-concatenate vecs)) + +(define (u8vector-concatenate vecs) + (let ((v (make-u8vector (len-sum vecs)))) + (let loop ((vecs vecs) (at 0)) + (unless (null? vecs) + (let ((vec (car vecs))) + (u8vector-copy! v at vec 0 (u8vector-length vec)) + (loop (cdr vecs) (+ at (u8vector-length vec))))) + v))) + +(define (len-sum vecs) + (if (null? vecs) + 0 + (+ (u8vector-length (car vecs)) + (len-sum (cdr vecs))))) + +(define (u8vector-append-subvectors . args) + (let ((v (make-u8vector (len-subsum args)))) + (let loop ((args args) (at 0)) + (unless (null? args) + (let ((vec (car args)) + (start (cadr args)) + (end (caddr args))) + (u8vector-copy! v at vec start end) + (loop (cdddr args) (+ at (- end start)))))) + v)) + +(define (len-subsum vecs) + (if (null? vecs) + 0 + (+ (- (caddr vecs) (cadr vecs)) + (len-subsum (cdddr vecs))))) + +;; u8? defined in (srfi 160 base) + +;; u8vector? defined in (srfi 160 base) + +(define (u8vector-empty? vec) + (zero? (u8vector-length vec))) + +(define (u8vector= . vecs) + (u8vector=* (car vecs) (cadr vecs) (cddr vecs))) + +(define (u8vector=* vec1 vec2 vecs) + (and (u8dyadic-vecs= vec1 0 (u8vector-length vec1) + vec2 0 (u8vector-length vec2)) + (or (null? vecs) + (u8vector=* vec2 (car vecs) (cdr vecs))))) + +(define (u8dyadic-vecs= vec1 start1 end1 vec2 start2 end2) + (cond + ((not (= end1 end2)) #f) + ((not (< start1 end1)) #t) + ((let ((elt1 (u8vector-ref vec1 start1)) + (elt2 (u8vector-ref vec2 start2))) + (= elt1 elt2)) + (u8dyadic-vecs= vec1 (+ start1 1) end1 + vec2 (+ start2 1) end2)) + (else #f))) + +;; u8vector-ref defined in (srfi 160 base) + +;; u8vector-length defined in (srfi 160 base) + +(define (u8vector-take vec n) + (let ((v (make-u8vector n))) + (u8vector-copy! v 0 vec 0 n) + v)) + +(define (u8vector-take-right vec n) + (let ((v (make-u8vector n)) + (len (u8vector-length vec))) + (u8vector-copy! v 0 vec (- len n) len) + v)) + +(define (u8vector-drop vec n) + (let* ((len (u8vector-length vec)) + (vlen (- len n)) + (v (make-u8vector vlen))) + (u8vector-copy! v 0 vec n len) + v)) + +(define (u8vector-drop-right vec n) + (let* ((len (u8vector-length vec)) + (rlen (- len n)) + (v (make-u8vector rlen))) + (u8vector-copy! v 0 vec 0 rlen) + v)) + +(define (u8vector-segment vec n) + (unless (and (integer? n) (positive? n)) + (error "length must be a positive integer" n)) + (let loop ((r '()) (i 0) (remain (u8vector-length vec))) + (if (<= remain 0) + (reverse r) + (let ((size (min n remain))) + (loop + (cons (u8vector-copy vec i (+ i size)) r) + (+ i size) + (- remain size)))))) + +;; aux. procedure +(define (%u8vectors-ref vecs i) + (map (lambda (v) (u8vector-ref v i)) vecs)) + +(define (u8vector-fold kons knil vec . vecs) + (if (null? vecs) + ;; fast path + (let ((len (u8vector-length vec))) + (let loop ((r knil) (i 0)) + (if (= i len) + r + (loop (kons r (u8vector-ref vec i)) (+ i 1))))) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map u8vector-length vecs)))) + (let loop ((r knil) (i 0)) + (if (= i len) + r + (loop (apply kons r (%u8vectors-ref vecs i)) + (+ i 1))))))) + +(define (u8vector-fold-right kons knil vec . vecs) + (if (null? vecs) + ;; fast path + (let ((len (u8vector-length vec))) + (let loop ((r knil) (i (- (u8vector-length vec) 1))) + (if (negative? i) + r + (loop (kons r (u8vector-ref vec i)) (- i 1))))) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map u8vector-length vecs)))) + (let loop ((r knil) (i (- len 1))) + (if (negative? i) + r + (loop (apply kons r (%u8vectors-ref vecs i)) + (- i 1))))))) + +(define (u8vector-map f vec . vecs) + (if (null? vecs) + ;; fast path + (let* ((len (u8vector-length vec)) + (v (make-u8vector len))) + (let loop ((i 0)) + (unless (= i len) + (u8vector-set! v i (f (u8vector-ref vec i))) + (loop (+ i 1)))) + v) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map u8vector-length vecs))) + (v (make-u8vector len))) + (let loop ((i 0)) + (unless (= i len) + (u8vector-set! v i (apply f (%u8vectors-ref vecs i))) + (loop (+ i 1)))) + v))) + + +(define (u8vector-map! f vec . vecs) + (if (null? vecs) + ;; fast path + (let ((len (u8vector-length vec))) + (let loop ((i 0)) + (unless (= i len) + (u8vector-set! vec i (f (u8vector-ref vec i))) + (loop (+ i 1))))) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map u8vector-length vecs)))) + (let loop ((i 0)) + (unless (= i len) + (u8vector-set! vec i (apply f (%u8vectors-ref vecs i))) + (loop (+ i 1))))))) + +(define (u8vector-for-each f vec . vecs) + (if (null? vecs) + ;; fast path + (let ((len (u8vector-length vec))) + (let loop ((i 0)) + (unless (= i len) + (f (u8vector-ref vec i)) + (loop (+ i 1))))) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map u8vector-length vecs)))) + (let loop ((i 0)) + (unless (= i len) + (apply f (%u8vectors-ref vecs i)) + (loop (+ i 1))))))) + +(define (u8vector-count pred vec . vecs) + (if (null? vecs) + ;; fast path + (let ((len (u8vector-length vec))) + (let loop ((i 0) (r 0)) + (cond + ((= i (u8vector-length vec)) r) + ((pred (u8vector-ref vec i)) (loop (+ i 1) (+ r 1))) + (else (loop (+ i 1) r))))) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map u8vector-length vecs)))) + (let loop ((i 0) (r 0)) + (cond + ((= i len) r) + ((apply pred (%u8vectors-ref vecs i)) (loop (+ i 1) (+ r 1))) + (else (loop (+ i 1) r))))))) + +(define (u8vector-cumulate f knil vec) + (let* ((len (u8vector-length vec)) + (v (make-u8vector len))) + (let loop ((r knil) (i 0)) + (unless (= i len) + (let ((next (f r (u8vector-ref vec i)))) + (u8vector-set! v i next) + (loop next (+ i 1))))) + v)) + +(define (u8vector-foreach f vec) + (let ((len (u8vector-length vec))) + (let loop ((i 0)) + (unless (= i len) + (f (u8vector-ref vec i)) + (loop (+ i 1)))))) + +(define (u8vector-take-while pred vec) + (let* ((len (u8vector-length vec)) + (idx (u8vector-skip pred vec)) + (idx* (if idx idx len))) + (u8vector-copy vec 0 idx*))) + +(define (u8vector-take-while-right pred vec) + (let* ((len (u8vector-length vec)) + (idx (u8vector-skip-right pred vec)) + (idx* (if idx (+ idx 1) 0))) + (u8vector-copy vec idx* len))) + +(define (u8vector-drop-while pred vec) + (let* ((len (u8vector-length vec)) + (idx (u8vector-skip pred vec)) + (idx* (if idx idx len))) + (u8vector-copy vec idx* len))) + +(define (u8vector-drop-while-right pred vec) + (let* ((len (u8vector-length vec)) + (idx (u8vector-skip-right pred vec)) + (idx* (if idx idx -1))) + (u8vector-copy vec 0 (+ 1 idx*)))) + +(define (u8vector-index pred vec . vecs) + (if (null? vecs) + ;; fast path + (let ((len (u8vector-length vec))) + (let loop ((i 0)) + (cond + ((= i len) #f) + ((pred (u8vector-ref vec i)) i) + (else (loop (+ i 1)))))) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map u8vector-length vecs)))) + (let loop ((i 0)) + (cond + ((= i len) #f) + ((apply pred (%u8vectors-ref vecs i)) i) + (else (loop (+ i 1)))))))) + +(define (u8vector-index-right pred vec . vecs) + (if (null? vecs) + ;; fast path + (let ((len (u8vector-length vec))) + (let loop ((i (- len 1))) + (cond + ((negative? i) #f) + ((pred (u8vector-ref vec i)) i) + (else (loop (- i 1)))))) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map u8vector-length vecs)))) + (let loop ((i (- len 1))) + (cond + ((negative? i) #f) + ((apply pred (%u8vectors-ref vecs i)) i) + (else (loop (- i 1)))))))) + +(define (u8vector-skip pred vec . vecs) + (if (null? vecs) + (u8vector-index (lambda (x) (not (pred x))) vec) + (apply u8vector-index (lambda xs (not (apply pred xs))) vec vecs))) + +(define (u8vector-skip-right pred vec . vecs) + (if (null? vecs) + (u8vector-index-right (lambda (x) (not (pred x))) vec) + (apply u8vector-index-right (lambda xs (not (apply pred xs))) vec vecs))) + +(define (u8vector-any pred vec . vecs) + (if (null? vecs) + ;; fast path + (let ((len (u8vector-length vec))) + (let loop ((i 0)) + (cond + ((= i len) #f) + ((pred (u8vector-ref vec i))) ;returns result of pred + (else (loop (+ i 1)))))) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map u8vector-length vecs)))) + (let loop ((i 0)) + (cond + ((= i len) #f) + ((apply pred (%u8vectors-ref vecs i))) ;returns result of pred + (else (loop (+ i 1)))))))) + +(define (u8vector-every pred vec . vecs) + (if (null? vecs) + ;; fast path + (let ((len (u8vector-length vec))) + (let loop ((i 0) (last #t)) + (cond + ((= i len) last) + ((pred (u8vector-ref vec i)) => (lambda (r) (loop (+ i 1) r))) + (else #f)))) + ;; generic case + (let* ((vecs (cons vec vecs)) + (len (apply min (map u8vector-length vecs)))) + (let loop ((i 0) (last #t)) + (cond + ((= i len) last) + ((apply pred (%u8vectors-ref vecs i)) => (lambda (r) (loop (+ i 1) r))) + (else #f)))))) + +(define (u8vector-partition pred vec) + (let* ((len (u8vector-length vec)) + (cnt (u8vector-count pred vec)) + (r (make-u8vector len))) + (let loop ((i 0) (yes 0) (no cnt)) + (cond + ((= i len) (values r cnt)) + ((pred (u8vector-ref vec i)) + (u8vector-set! r yes (u8vector-ref vec i)) + (loop (+ i 1) (+ yes 1) no)) + (else + (u8vector-set! r no (u8vector-ref vec i)) + (loop (+ i 1) yes (+ no 1))))))) + +(define (u8vector-filter pred vec) + (let* ((len (u8vector-length vec)) + (cnt (u8vector-count pred vec)) + (r (make-u8vector cnt))) + (let loop ((i 0) (j 0)) + (cond + ((= i len) r) + ((pred (u8vector-ref vec i)) + (u8vector-set! r j (u8vector-ref vec i)) + (loop (+ i 1) (+ j 1))) + (else + (loop (+ i 1) j)))))) + +(define (u8vector-remove pred vec) + (u8vector-filter (lambda (x) (not (pred x))) vec)) + +;; u8vector-set! defined in (srfi 160 base) + +(define (u8vector-swap! vec i j) + (let ((ival (u8vector-ref vec i)) + (jval (u8vector-ref vec j))) + (u8vector-set! vec i jval) + (u8vector-set! vec j ival))) + +(define u8vector-fill! + (case-lambda + ((vec fill) (u8vector-fill-some! vec fill 0 (u8vector-length vec))) + ((vec fill start) (u8vector-fill-some! vec fill start (u8vector-length vec))) + ((vec fill start end) (u8vector-fill-some! vec fill start end)))) + +(define (u8vector-fill-some! vec fill start end) + (unless (= start end) + (u8vector-set! vec start fill) + (u8vector-fill-some! vec fill (+ start 1) end))) + +(define u8vector-reverse! + (case-lambda + ((vec) (u8vector-reverse-some! vec 0 (u8vector-length vec))) + ((vec start) (u8vector-reverse-some! vec start (u8vector-length vec))) + ((vec start end) (u8vector-reverse-some! vec start end)))) + +(define (u8vector-reverse-some! vec start end) + (let loop ((i start) (j (- end 1))) + (when (< i j) + (u8vector-swap! vec i j) + (loop (+ i 1) (- j 1))))) + +(define (u8vector-unfold! f vec start end seed) + (let loop ((i start) (seed seed)) + (when (< i end) + (let-values (((elt seed) (f i seed))) + (u8vector-set! vec i elt) + (loop (+ i 1) seed))))) + +(define (u8vector-unfold-right! f vec start end seed) + (let loop ((i (- end 1)) (seed seed)) + (when (>= i start) + (let-values (((elt seed) (f i seed))) + (u8vector-set! vec i elt) + (loop (- i 1) seed))))) + +(define reverse-u8vector->list + (case-lambda + ((vec) (reverse-u8vector->list* vec 0 (u8vector-length vec))) + ((vec start) (reverse-u8vector->list* vec start (u8vector-length vec))) + ((vec start end) (reverse-u8vector->list* vec start end)))) + +(define (reverse-u8vector->list* vec start end) + (let loop ((i start) (r '())) + (if (= i end) + r + (loop (+ 1 i) (cons (u8vector-ref vec i) r))))) + +(define (reverse-list->u8vector list) + (let* ((len (length list)) + (r (make-u8vector len))) + (let loop ((i 0) (list list)) + (cond + ((= i len) r) + (else + (u8vector-set! r (- len i 1) (car list)) + (loop (+ i 1) (cdr list))))))) + +(define u8vector->vector + (case-lambda + ((vec) (u8vector->vector* vec 0 (u8vector-length vec))) + ((vec start) (u8vector->vector* vec start (u8vector-length vec))) + ((vec start end) (u8vector->vector* vec start end)))) + +(define (u8vector->vector* vec start end) + (let* ((len (- end start)) + (r (make-vector len))) + (let loop ((i start) (o 0)) + (cond + ((= i end) r) + (else + (vector-set! r o (u8vector-ref vec i)) + (loop (+ i 1) (+ o 1))))))) + +(define vector->u8vector + (case-lambda + ((vec) (vector->u8vector* vec 0 (vector-length vec))) + ((vec start) (vector->u8vector* vec start (vector-length vec))) + ((vec start end) (vector->u8vector* vec start end)))) + +(define (vector->u8vector* vec start end) + (let* ((len (- end start)) + (r (make-u8vector len))) + (let loop ((i start) (o 0)) + (cond + ((= i end) r) + (else + (u8vector-set! r o (vector-ref vec i)) + (loop (+ i 1) (+ o 1))))))) + +(define make-u8vector-generator + (case-lambda ((vec) (make-u8vector-generator vec 0 (u8vector-length vec))) + ((vec start) (make-u8vector-generator vec start (u8vector-length vec))) + ((vec start end) + (lambda () (if (>= start end) + (eof-object) + (let ((next (u8vector-ref vec start))) + (set! start (+ start 1)) + next)))))) + +(define write-u8vector + (case-lambda + ((vec) (write-u8vector* vec (current-output-port))) + ((vec port) (write-u8vector* vec port)))) + + +(define (write-u8vector* vec port) + (display "#u8(" port) ; u8-expansion is blind, so will expand this too + (let ((last (- (u8vector-length vec) 1))) + (let loop ((i 0)) + (cond + ((= i last) + (write (u8vector-ref vec i) port) + (display ")" port)) + (else + (write (u8vector-ref vec i) port) + (display " " port) + (loop (+ i 1))))))) + +(define (u8vector< vec1 vec2) + (let ((len1 (u8vector-length vec1)) + (len2 (u8vector-length vec2))) + (cond + ((< len1 len2) + #t) + ((> len1 len2) + #f) + (else + (let loop ((i 0)) + (cond + ((= i len1) + #f) + ((< (u8vector-ref vec1 i) (u8vector-ref vec2 i)) + #t) + ((> (u8vector-ref vec1 i) (u8vector-ref vec2 i)) + #f) + (else + (loop (+ i 1))))))))) + +(define (u8vector-hash vec) + (let ((len (min 256 (u8vector-length vec)))) + (let loop ((i 0) (r 0)) + (if (= i len) + (abs (floor (real-part (inexact->exact r)))) + (loop (+ i 1) (+ r (u8vector-ref vec i))))))) + +(define u8vector-comparator + (make-comparator u8vector? u8vector= u8vector< u8vector-hash)) diff --git a/module/srfi/srfi-160/u8.sld b/module/srfi/srfi-160/u8.sld new file mode 100644 index 000000000..8945cef96 --- /dev/null +++ b/module/srfi/srfi-160/u8.sld @@ -0,0 +1,49 @@ +;;; SPDX-FileCopyrightText: 2018 John Cowan +;;; +;;; SPDX-License-Identifier: MIT + +(define-library (srfi srfi-160 u8) + (import (scheme base)) + (import (scheme case-lambda)) + (import (scheme cxr)) + (import (only (scheme r5rs) inexact->exact)) + (import (scheme complex)) + (import (scheme write)) + (import (srfi srfi-128)) + (import (srfi srfi-160 base)) + ;; Constructors + (export make-u8vector u8vector + u8vector-unfold u8vector-unfold-right + u8vector-copy u8vector-reverse-copy + u8vector-append u8vector-concatenate + u8vector-append-subvectors) + ;; Predicates + (export u8? u8vector? u8vector-empty? u8vector=) + ;; Selectors + (export u8vector-ref u8vector-length) + ;; Iteration + (export u8vector-take u8vector-take-right + u8vector-drop u8vector-drop-right + u8vector-segment + u8vector-fold u8vector-fold-right + u8vector-map u8vector-map! u8vector-for-each + u8vector-count u8vector-cumulate) + ;; Searching + (export u8vector-take-while u8vector-take-while-right + u8vector-drop-while u8vector-drop-while-right + u8vector-index u8vector-index-right u8vector-skip u8vector-skip-right + u8vector-any u8vector-every u8vector-partition + u8vector-filter u8vector-remove) + ;; Mutators + (export u8vector-set! u8vector-swap! u8vector-fill! u8vector-reverse! + u8vector-copy! u8vector-reverse-copy! + u8vector-unfold! u8vector-unfold-right!) + ;; Conversion + (export u8vector->list list->u8vector + reverse-u8vector->list reverse-list->u8vector + u8vector->vector vector->u8vector) + ;; Misc + (export make-u8vector-generator u8vector-comparator write-u8vector) + + (include "u8-impl.scm") +) diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am index f51db8830..1afac2bca 100644 --- a/test-suite/Makefile.am +++ b/test-suite/Makefile.am @@ -166,6 +166,8 @@ SCM_TESTS = tests/00-initial-env.test \ tests/srfi-126.test \ tests/srfi-128.test \ tests/srfi-151.test \ + tests/srfi-160-base.test \ + tests/srfi-160.test \ tests/srfi-171.test \ tests/srfi-4.test \ tests/srfi-9.test \ @@ -216,6 +218,8 @@ EXTRA_DIST = \ tests/srfi-126-test.scm \ tests/srfi-128-test.scm \ tests/srfi-151-test.scm \ + tests/srfi-160-base-test.scm \ + tests/srfi-160-test.scm \ ChangeLog-2008 diff --git a/test-suite/tests/srfi-160-base-test.scm b/test-suite/tests/srfi-160-base-test.scm new file mode 100644 index 000000000..619432e80 --- /dev/null +++ b/test-suite/tests/srfi-160-base-test.scm @@ -0,0 +1,168 @@ +;;; SPDX-FileCopyrightText: 2018 John Cowan +;;; +;;; SPDX-License-Identifier: MIT + +;;;; Shared tests +;;; Hvector = homogeneous vector + +;; Test for sameness + +(define relerr (expt 2 -24)) +(define (inexact-real? x) (and (number? x) (inexact? x) (real? x))) +(define (inexact-complex? x) (and (number? x) (inexact? x) (not (real? x)))) +(define (realify z) (* (real-part z) (imag-part z))) + +(define (same? result expected) + (cond + ((and (inexact-real? result) (inexact-real? expected)) + (let ((abserr (abs (* expected relerr)))) + (<= (- expected abserr) result (+ expected abserr)))) + ((and (inexact-complex? result) (inexact-complex? expected)) + (let ((abserr (abs (* (realify expected) relerr)))) + (<= (- (realify expected) abserr) (realify result) (+ (realify expected) abserr)))) + ((and (number? result) (number? expected)) + (= result expected)) + ((and (pair? result) (pair? expected)) + (list-same? result expected)) + (else + (equal? result expected)))) + + (define (list-same? result expected) + (cond + ((and (null? result) (null? expected)) + #t) + ((and (pair? result) (pair? expected)) + (and (same? (car result) (car expected)) (list-same? (cdr result) (cdr expected)))) + (else + #f))) + +(define-syntax is-same? + (syntax-rules () + ((is-same? result expected) + (begin + (display "Try ") + (display 'result) + (display " is same as ") + (display 'expected) + (display "? ") + (if (same? result expected) + (display "OK") + (begin + (display result) + (display " ") + (display expected) + (display " FAIL"))) + (newline))))) + +(define (create label value) + value) + +(define (test tag make-Hvector Hvector Hvector? Hvector-length + Hvector-ref Hvector-set! Hvector->list list->Hvector) + (display "STARTING ") + (display tag) + (display "vector TESTS:") + (newline) + (let* ((first 32.0) + (second 32.0+47.0i) + (third -47.0i) + (vec0 (make-Hvector 3)) + (vec1 (make-Hvector 3 second)) + (vec2 (Hvector first second third)) + (vec3 (list->Hvector (list third second first)))) + (is-same? (Hvector? vec0) #t) + (is-same? (Hvector? vec1) #t) + (is-same? (Hvector? vec2) #t) + (is-same? (Hvector? vec3) #t) + (is-same? (Hvector-length vec0) 3) + (is-same? (Hvector-length vec1) 3) + (is-same? (Hvector-length vec2) 3) + (is-same? (Hvector-length vec3) 3) + (Hvector-set! vec0 0 second) + (Hvector-set! vec0 1 third) + (Hvector-set! vec0 2 first) + (is-same? (Hvector-ref vec0 0) second) + (is-same? (Hvector-ref vec0 1) third) + (is-same? (Hvector-ref vec0 2) first) + (is-same? (Hvector-ref vec1 0) second) + (is-same? (Hvector-ref vec1 1) second) + (is-same? (Hvector-ref vec1 2) second) + (is-same? (Hvector-ref vec2 0) first) + (is-same? (Hvector-ref vec2 1) second) + (is-same? (Hvector-ref vec2 2) third) + (is-same? (Hvector-ref vec3 0) third) + (is-same? (Hvector-ref vec3 1) second) + (is-same? (Hvector-ref vec3 2) first) + (is-same? (Hvector->list vec0) (list second third first)) + (is-same? (Hvector->list vec1) (list second second second)) + (is-same? (Hvector->list vec2) (list first second third)) + (is-same? (Hvector->list vec3) (list third second first)))) + +(test 'c64 make-c64vector c64vector c64vector? c64vector-length + c64vector-ref c64vector-set! c64vector->list list->c64vector) + +(test 'c128 make-c128vector c128vector c128vector? c128vector-length + c128vector-ref c128vector-set! c128vector->list list->c128vector) + +(define-syntax test-assert + (syntax-rules () + ((test-assert expr) + (begin + (display "Try ") + (display 'expr) + (display " is ") + (display (if expr "true OK" "false FAIL")) + (newline))))) + +(define-syntax test-not + (syntax-rules () + ((test-assert expr) + (begin + (display "Try ") + (display 'expr) + (display " is ") + (display (if expr "true FAIL" "false OK")) + (newline))))) + +(define-syntax integral-tests + (syntax-rules () + ((integral-tests pred lo hi) + (begin + (test-not (pred 1/2)) + (test-not (pred 1.0)) + (test-not (pred 1+2i)) + (test-not (pred 1.0+2.0i)) + (test-assert (pred 0)) + (test-assert (pred hi)) + (test-assert (pred lo)) + (test-not (pred (+ hi 1))) + (test-not (pred (- lo 1))))))) + +(display "STARTING @? TESTS") +(newline) + +(integral-tests u8? 0 255) +(integral-tests s8? -128 127) +(integral-tests u16? 0 65535) +(integral-tests s16? -32768 32767) +(integral-tests u32? 0 4294967295) +(integral-tests s32? -2147483648 2147483647) +(integral-tests u64? 0 18446744073709551615) +(integral-tests s64? -9223372036854775808 9223372036854775807) + +(test-assert (f32? 1.0)) +(test-not (f32? 1)) +(test-not (f32? 1.0+2.0i)) + +(test-assert (f64? 1.0)) +(test-not (f64? 1)) +(test-not (f64? 1.0+2.0i)) + +(test-assert (c64? 1.0)) +(test-not (c64? 1)) +(test-assert (c64? 1.0+2.0i)) + +(test-assert (c128? 1.0)) +(test-not (c128? 1)) +(test-assert (c128? 1.0+2.0i)) + diff --git a/test-suite/tests/srfi-160-base.test b/test-suite/tests/srfi-160-base.test new file mode 100644 index 000000000..9f1d763a9 --- /dev/null +++ b/test-suite/tests/srfi-160-base.test @@ -0,0 +1,35 @@ +;;; srfi-160.test --- Test suite for SRFI-160 base library. -*- scheme -*- +;;; +;;; SPDX-FileCopyrightText: 2023 Free Software Foundation, Inc. +;;; +;;; SPDX-License-Identifier: LGPL-3.0-or-later + +(define-module (test-srfi-160-base) + #:use-module (srfi srfi-160 base) + #: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-160-base-test.scm")) + +;;; Local Variables: +;;; eval: (put 'test-runner-on-test-end! 'scheme-indent-function 1) +;;; End: diff --git a/test-suite/tests/srfi-160-test.scm b/test-suite/tests/srfi-160-test.scm new file mode 100644 index 000000000..130a34b16 --- /dev/null +++ b/test-suite/tests/srfi-160-test.scm @@ -0,0 +1,263 @@ +;;; SPDX-FileCopyrightText: 2018 John Cowan +;;; +;;; SPDX-License-Identifier: MIT + +;;; 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. +(define-syntax-rule (test arg ...) + (test-equal arg ...)) + +(define-syntax-rule (test-exit arg ...) + (test-end)) + +(test-begin "srfi-160 libraries") +;;; END Guile-specific modifications. + +(define (times2 x) (* x 2)) +(define s5 (s16vector 1 2 3 4 5)) +(define s4 (s16vector 1 2 3 4)) +(define s5+ (s16vector 1 2 3 4 6)) + +(define (steady i x) (values x x)) +(define (count-up i x) (values x (+ x 1))) +(define (count-down i x) (values x (- x 1))) +(define (odd+1 x) (if (odd? x) (+ 1 x) #f)) +(define s16vector< (comparator-ordering-predicate s16vector-comparator)) +(define s16vector-hash (comparator-hash-function s16vector-comparator)) + +(define g (make-s16vector-generator s5)) +(define-syntax test-equiv + (syntax-rules () + ((test-equiv expect expr) + (test expect (s16vector->list expr))) + ((test-equiv name expect expr) + (test name expect (s16vector->list expr))))) + +(test-group "s16vector" +(test-group "s16vector/constructors" + (test-equiv "make" '(3 3 3 3 3) (make-s16vector 5 3)) + (test-equiv "s16vector" '(-2 -1 0 1 2) (s16vector -2 -1 0 1 2)) + (test-equiv "unfold up" '(10 11 12 13 14) + (s16vector-unfold count-up 5 10)) + (test-equiv "unfold down" '(10 9 8 7 6) + (s16vector-unfold count-down 5 10)) + (test-equiv "unfold steady" '(10 10 10 10 10) + (s16vector-unfold steady 5 10)) + (test-equiv "unfold-right up" '(14 13 12 11 10) + (s16vector-unfold-right count-up 5 10)) + (test-equiv "unfold-right down" '(6 7 8 9 10) + (s16vector-unfold-right count-down 5 10)) + (test-equiv "unfold-right steady" '(10 10 10 10 10) + (s16vector-unfold-right steady 5 10)) + (test-equiv "copy" '(1 2 3 4 5) (s16vector-copy s5)) + (test-assert "copy2" (not (eqv? s5 (s16vector-copy s5)))) + (test-equiv "copy3" '(2 3) (s16vector-copy s5 1 3)) + (test-equiv "reverse-copy" '(5 4 3 2 1) (s16vector-reverse-copy s5)) + (test-equiv "append" '(1 2 3 4 5 1 2 3 4 5) + (s16vector-append s5 s5)) + (test-equiv "concatenate" '(1 2 3 4 5 1 2 3 4 5) + (s16vector-concatenate (list s5 s5))) + (test-equiv "append-subvectors" '(2 3 2 3) + (s16vector-append-subvectors s5 1 3 s5 1 3)) +) ; end s16vector/constructors + +(test-group "s16vector/predicates" + (test-assert "s16?" (s16? 5)) + (test-assert "not s16?" (not (s16? 65536))) + (test-assert "s16vector?" (s16vector? s5)) + (test-assert "not s16vector?" (not (s16vector? #t))) + (test-assert "empty" (s16vector-empty? (s16vector))) + (test-assert "not empty" (not (s16vector-empty? s5))) + (test-assert "=" (s16vector= (s16vector 1 2 3) (s16vector 1 2 3))) + (test-assert "= multi" (s16vector= (s16vector 1 2 3) + (s16vector 1 2 3) + (s16vector 1 2 3))) + (test-assert "not =" (not (s16vector= (s16vector 1 2 3) (s16vector 3 2 1)))) + (test-assert "not =2" (not (s16vector= (s16vector 1 2 3) (s16vector 1 2)))) + (test-assert "not = multi" (not (s16vector= (s16vector 1 2 3) + (s16vector 1 2 3) + (s16vector 3 2 1)))) +) ; end s16vector/predicates + +(test-group "s16vector/selectors" + (test "ref" 1 (s16vector-ref (s16vector 1 2 3) 0)) + (test "length" 3 (s16vector-length (s16vector 1 2 3))) +) ; end s16vector/selectors + +(test-group "s16vector/iteration" + (test-equiv "take" '(1 2) (s16vector-take s5 2)) + (test-equiv "take-right" '(4 5) (s16vector-take-right s5 2)) + (test-equiv "drop" '(3 4 5) (s16vector-drop s5 2)) + (test-equiv "drop-right" '(1 2 3) (s16vector-drop-right s5 2)) + (test "segment" (list (s16vector 1 2 3) (s16vector 4 5)) + (s16vector-segment s5 3)) + (test "fold" -6 (s16vector-fold - 0 (s16vector 1 2 3))) + (test "fold" '(((0 1 4) 2 5) 3 6) + (s16vector-fold list 0 (s16vector 1 2 3) (s16vector 4 5 6))) + (test "fold-right" -6 (s16vector-fold-right - 0 (s16vector 1 2 3))) + (test "fold-right" '(((0 3 6) 2 5) 1 4) + (s16vector-fold-right list 0 (s16vector 1 2 3) (s16vector 4 5 6))) + (test-equiv "map" '(-1 -2 -3 -4 -5) (s16vector-map - s5)) + (test-equiv "map" '(-2 -4 -6 -8 -10) (s16vector-map - s5 s5 s5 s5)) + (let ((v (s16vector 1 2 3 4 5))) + (s16vector-map! - v) + (test-equiv "map!" '(-1 -2 -3 -4 -5) v)) + (let ((v (s16vector 1 2 3 4 5)) + (v2 (s16vector 6 7 8 9 10))) + (s16vector-map! + v v2) + (test-equiv "map!" '(7 9 11 13 15) v)) + (let ((list '())) + (s16vector-for-each + (lambda (e) (set! list (cons e list))) + s5) + ;; stupid hack to shut up test egg about testing the value of a variable + (test "for-each" '(5 4 3 2 1) (cons (car list) (cdr list)))) + (let ((list '())) + (s16vector-for-each + (lambda (e1 e2) (set! list (cons (cons e1 e2) list))) + s5 + (s16vector 6 7 8 9 10)) + ;; stupid hack to shut up test egg about testing the value of a variable + (test "for-each" '((5 . 10) (4 . 9) (3 . 8) (2 . 7) (1 . 6)) + (cons (car list) (cdr list)))) + (test "count" 3 (s16vector-count odd? s5)) + (test "count" 2 (s16vector-count > s5 (s16vector 9 2 1 5 3))) + (test-equiv "cumulate" '(1 3 6 10 15) + (s16vector-cumulate + 0 s5)) +) ; end s16vector/iteration + +(test-group "s16vector/searching" + (test-equiv "take-while" '(1) (s16vector-take-while odd? s5)) + (test-equiv "take-while-right" '(5) (s16vector-take-while-right odd? s5)) + (test-equiv "drop-while" '(2 3 4 5) (s16vector-drop-while odd? s5)) + (test-equiv "drop-while-right" '(1 2 3 4) (s16vector-drop-while-right odd? s5)) + (test-equiv "degenerate take-while" '() (s16vector-take-while inexact? s5)) + (test-equiv "degenerate take-while-right" '() (s16vector-take-while-right inexact? s5)) + (test-equiv "degenerate drop-while" '(1 2 3 4 5) (s16vector-drop-while inexact? s5)) + (test-equiv "degenerate drop-while-right" '(1 2 3 4 5) (s16vector-drop-while-right inexact? s5)) + (test "index" 1 (s16vector-index even? s5)) + (test "index" 2 (s16vector-index < s5 (s16vector 0 0 10 10 0))) + (test "index-right" 3 (s16vector-index-right even? s5)) + (test "index-right" 3 (s16vector-index-right < s5 (s16vector 0 0 10 10 0))) + (test "skip" 1 (s16vector-skip odd? s5)) + (test "skip" 2 (s16vector-skip > s5 (s16vector 0 0 10 10 0))) + (test "skip-right" 3 (s16vector-skip-right odd? s5)) + (test "skip-right" 3 (s16vector-skip-right > s5 (s16vector 0 0 10 10 0))) + (test "any" 4 (s16vector-any (lambda (x) (and (even? x) (* x 2))) s5)) + (test-assert "not any" (not (s16vector-any inexact? s5))) + (test "any + 1" 2 (s16vector-any odd+1 s5)) + (test-assert "every" (s16vector-every exact? s5)) + (test-assert "not every" (not (s16vector-every odd? s5))) + (test-assert "every + 1" (not (s16vector-every odd+1 s5))) + (test "multi-any" 10 (s16vector-any (lambda (x y) (and (even? x) (even? y) (+ x y))) + s5 (s16vector 0 1 2 6 4))) + (test "multi-any 2" #f (s16vector-any (lambda (x y) (and (even? x) (even? y) (+ x y))) + s5 (s16vector 0 1 2 5 4))) + (test "multi-every" 10 (s16vector-every (lambda (x) (and (exact? x) (* x 2))) s5)) + (test "multi-every-2" 10 (s16vector-every (lambda (x y) (and (exact? x) (exact? y) (+ x y))) + s5 s5)) + (test-assert "multi-not every" (not (s16vector-every < s5 (s16vector 10 10 10 10 0)))) + (test-equiv "partition" '(1 3 5 2 4) + (call-with-values + (lambda () (s16vector-partition odd? s5)) + (lambda (vec cnt) vec))) + (test-equiv "filter" '(1 3 5) (s16vector-filter odd? s5)) + (test-equiv "remove" '(2 4) (s16vector-remove odd? s5)) +) ; end s16vector/searching + +(test-group "s16vector/mutators" + (let ((v (s16vector 1 2 3))) + (display "set!\n") + (s16vector-set! v 0 10) + (test-equiv "set!" '(10 2 3) v)) + (let ((v (s16vector 1 2 3))) + (display "swap!\n") + (s16vector-swap! v 0 1) + (test-equiv "swap!" '(2 1 3) v)) + (let ((v (s16vector 1 2 3))) + (display "fill!\n") + (s16vector-fill! v 2) + (test-equiv "fill!" '(2 2 2) v)) + (let ((v (s16vector 1 2 3))) + (display "fill2!\n") + (s16vector-fill! v 10 0 2) + (test-equiv "fill2!" '(10 10 3) v)) + (let ((v (s16vector 1 2 3))) + (display "reverse!\n") + (s16vector-reverse! v) + (test-equiv "reverse!" '(3 2 1) v)) + (let ((v (s16vector 1 2 3))) + (display "reverse!\n") + (s16vector-reverse! v 1 3) + (test-equiv "reverse2!" '(1 3 2) v)) + (let ((v (s16vector 10 20 30 40 50))) + (display "copy!\n") + (s16vector-copy! v 1 s5 2 4) + (test-equiv "copy!" '(10 3 4 40 50) v)) + (let ((v (s16vector 10 20 30 40 50))) + (display "reverse-copy!\n") + (s16vector-reverse-copy! v 1 s5 2 4) + (test-equiv "reverse-copy!" '(10 4 3 40 50) v)) + (let ((v (s16vector 1 2 3 4 5 6 7 8))) + (display "unfold!") + (s16vector-unfold! (lambda (_ x) (values (* x 2) (* x 2))) + v 1 6 -1) + (test-equiv "vector-unfold!" '(1 -2 -4 -8 -16 -32 7 8) v)) + (let ((v (s16vector 1 2 3 4 5 6 7 8))) + (display "unfold-right!") + (s16vector-unfold-right! (lambda (_ x) (values (* x 2) (* x 2))) + v 1 6 -1) + (test-equiv "vector-unfold!" '(1 -32 -16 -8 -4 -2 7 8) v)) +) ; end s16vector/mutators + +(test-group "s16vector/conversion" + (test "@vector->list 1" '(1 2 3 4 5) + (s16vector->list s5)) + (test "@vector->list 2" '(2 3 4 5) + (s16vector->list s5 1)) + (test "@vector->list 3" '(2 3 4) + (s16vector->list s5 1 4)) + (test "@vector->vector 1" #(1 2 3 4 5) + (s16vector->vector s5)) + (test "@vector->vector 2" #(2 3 4 5) + (s16vector->vector s5 1)) + (test "@vector->vector 3" #(2 3 4) + (s16vector->vector s5 1 4)) + (test-equiv "list->@vector" '(1 2 3 4 5) + (list->s16vector '(1 2 3 4 5))) + (test-equiv "reverse-list->@vector" '(5 4 3 2 1) + (reverse-list->s16vector '(1 2 3 4 5))) + (test-equiv "vector->@vector 1" '(1 2 3 4 5) + (vector->s16vector #(1 2 3 4 5))) + (test-equiv "vector->@vector 2" '(2 3 4 5) + (vector->s16vector #(1 2 3 4 5) 1)) + (test-equiv "vector->@vector 3" '(2 3 4) + (vector->s16vector #(1 2 3 4 5) 1 4)) +) ; end s16vector/conversion + +(test-group "s16vector/misc" + (let ((port (open-output-string))) + (write-s16vector s5 port) + (test "write-@vector" "#s16(1 2 3 4 5)" (get-output-string port)) + (close-output-port port)) + + (test-assert "@vector< short" (s16vector< s4 s5)) + (test-assert "not @vector< short" (not (s16vector< s5 s4))) + (test-assert "@vector< samelen" (s16vector< s5 s5+)) + (test-assert "not @vector< samelen" (not (s16vector< s5+ s5+))) + (test-assert "@vector=" (s16vector= s5+ s5+)) + (test "@vector-hash" 15 (s16vector-hash s5)) + + (test "@vector-gen 0" 1 (g)) + (test "@vector-gen 1" 2 (g)) + (test "@vector-gen 2" 3 (g)) + (test "@vector-gen 3" 4 (g)) + (test "@vector-gen 4" 5 (g)) + (test-assert (eof-object? (g))) +) ; end s16vector/misc + +) ; end s16vector +(test-exit) diff --git a/test-suite/tests/srfi-160.test b/test-suite/tests/srfi-160.test new file mode 100644 index 000000000..317a2f47b --- /dev/null +++ b/test-suite/tests/srfi-160.test @@ -0,0 +1,36 @@ +;;; srfi-160.test --- Test suite for SRFI-160 libraries. -*- scheme -*- +;;; +;;; SPDX-FileCopyrightText: 2023 Free Software Foundation, Inc. +;;; +;;; SPDX-License-Identifier: LGPL-3.0-or-later + +(define-module (test-srfi-160) + #:use-module (srfi srfi-160 s16) + #:use-module (srfi srfi-64) + #:use-module (srfi srfi-128)) + +(define report (@@ (test-suite lib) report)) + +(define (guile-test-runner) + (let ((runner (test-runner-null))) + (test-runner-on-test-end! runner + (lambda (runner) + (let* ((result-alist (test-result-alist runner)) + (result-kind (assq-ref result-alist 'result-kind)) + (test-name (list (assq-ref result-alist 'test-name)))) + (case result-kind + ((pass) (report 'pass test-name)) + ((xpass) (report 'upass test-name)) + ((skip) (report 'untested test-name)) + ((fail xfail) + (apply report result-kind test-name result-alist)) + (else #t))))) + runner)) + +(test-with-runner + (guile-test-runner) + (primitive-load-path "tests/srfi-160-test.scm")) + +;;; Local Variables: +;;; eval: (put 'test-runner-on-test-end! 'scheme-indent-function 1) +;;; End: -- 2.41.0