Subject: [PATCH] Add SRFI 158: Generators and Accumulators This patch adds support for SRFI 158 (Generators and Accumulators), a widely-implemented and fundamental SRFI that has been final since 2017.
WHAT IS SRFI 158? ----------------- SRFI 158 provides two complementary abstractions: 1. Generators: procedures that produce a sequence of values when called repeatedly. They are lightweight, stateful, and destructive (unlike SRFI 41 streams which are persistent). 2. Accumulators: the inverse of generators - procedures that consume a sequence of values. Generators are a fundamental building block used throughout the Scheme ecosystem, similar to Python's itertools or Clojure's lazy sequences. They are particularly useful for: - Processing large or infinite sequences efficiently - Composing data transformations - Building lazy pipelines - Working with external data sources (files, network, etc.) - Separation of concerns: abstracting boundaries and processing from data WHY ADD IT TO GUILE? -------------------- 1. Widespread adoption: Implemented in Gauche, Chicken, Chibi, Sagittarius, and other major Scheme implementations. 2. Referenced by newer SRFIs: SRFI 171 (Transducers), already in Guile, can work with generators. SRFI 158 makes that integration natural. 3. Fills a gap: While Guile has SRFI 41 (streams) for persistent lazy sequences, it lacks a lightweight mutable sequence abstraction. 4. Mature and stable: Finalized in 2017, with nearly a decade of real-world use. 5. Easy maintenance: Uses the well-tested reference implementation with minimal Guile-specific glue code. IMPLEMENTATION NOTES -------------------- - Based on the official reference implementation from https://srfi.schemers.org/srfi-158/ - Requires only SRFI 11 (let-values) and basic R6RS modules already in Guile - All exports follow the SRFI 158 specification exactly - Comprehensive test suite covering all major functionality - No conflicts with existing Guile procedures TESTING ------- The included test suite covers: - Generator constructors (make-range-generator, list->generator, etc.) - Generator operations (gfilter, gmap, gtake, gdrop, etc.) - Generator consumers (generator->list, generator-fold, etc.) - Accumulators (list-accumulator, sum-accumulator, etc.) The tests are based on the existing tests in the reference implementation, adapted for Guile's test framework. All tests pass with the current Guile 3.0.11. DOCUMENTATION ------------- The patch includes documentation for the Guile Reference Manual (doc/ref/srfi-modules.texi) following the style of existing SRFIs like SRFI-171. The documentation covers: - Introduction to generators and accumulators - Constructor procedures with examples - Generator operations (filtering, mapping, etc.) - Consumer procedures - Accumulator procedures The documentation references the full SRFI-158 specification for additional details and rationale. FUTURE WORK ----------- If accepted, this opens the door for: - Better SRFI 171 (transducers) integration - Potential future SRFIs that build on generators - Examples showing generator usage in Guile DISCLAIMER ---------- I was aided by Claude Sonnet 5 while developing this patch, under my close supervision and review. The work is mine. Please let me know if you have any questions or if any changes are needed. Thanks for considering this contribution! Yitz Gale [email protected]
From df3a7705ed88d4b94f53e29dcdeeb5cf8411d509 Mon Sep 17 00:00:00 2001 From: Yitz Gale <[email protected]> Date: Mon, 27 Jul 2026 01:07:25 +0300 Subject: [PATCH] Add SRFI 158: Generators and Accumulators SRFI 158 provides generators (procedures that produce sequences of values) and accumulators (procedures that consume sequences). This is a fundamental lazy sequence abstraction used by many modern Scheme programs. The implementation uses the reference implementation from https://srfi.schemers.org/srfi-158/ with minimal Guile-specific wrapper code. * module/srfi/srfi-158.scm: New file. Main module wrapper. * module/srfi/srfi-158/impl.scm: New file. Reference implementation. * test-suite/tests/srfi-158.test: New file. Test suite based on the SRFI 158 reference tests, adapted to Guile's test framework. * doc/ref/srfi-modules.texi: Add SRFI-158 documentation. --- doc/ref/srfi-modules.texi | 320 ++++++++++++++++++ module/srfi/srfi-158.scm | 121 +++++++ module/srfi/srfi-158/impl.scm | 580 +++++++++++++++++++++++++++++++++ test-suite/tests/srfi-158.test | 245 ++++++++++++++ 4 files changed, 1266 insertions(+) create mode 100644 module/srfi/srfi-158.scm create mode 100644 module/srfi/srfi-158/impl.scm create mode 100644 test-suite/tests/srfi-158.test diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi index 1cbb0c030..90c3f9092 100644 --- a/doc/ref/srfi-modules.texi +++ b/doc/ref/srfi-modules.texi @@ -68,6 +68,7 @@ get the relevant SRFI documents from the SRFI home page * SRFI-105:: Curly-infix expressions. * SRFI-111:: Boxes. * SRFI-119:: Wisp: simpler indentation-sensitive Scheme. +* SRFI-158:: Generators and Accumulators * SRFI-171:: Transducers * SRFI-197:: Pipeline operators * SRFI-207:: String-notated bytevectors @@ -6596,6 +6597,325 @@ extension @code{.w} vie @code{guile --language=wisp -x .w}. In files using Wisp, @xref{SRFI-105} (Curly Infix) is always activated. +@node SRFI-158 +@subsection Generators and Accumulators +@cindex SRFI-158 +@cindex generators +@cindex accumulators + +This subsection is based on the +@uref{https://srfi.schemers.org/srfi-158/srfi-158.html, specification of +SRFI-158} by Shiro Kawai, John Cowan, and Thomas Gilray. + +Generators are procedures with no arguments that produce a sequence of values. +Every time a generator is called, it yields the next value in the sequence. +When a finite generator is exhausted, it returns an end-of-file object. +Generators provide lightweight laziness without the overhead of creating thunks +for each element, making them well-suited for processing large or infinite +sequences efficiently. + +Accumulators are the inverse of generators: they are procedures of one argument +that consume a sequence of values. When called with an end-of-file object, an +accumulator returns its accumulated result. + +SRFI-158 can be made available with: + +@example +(use-modules (srfi srfi-158)) +@end example + +@menu +* SRFI-158 Constructors:: Creating generators +* SRFI-158 Operations:: Transforming generators +* SRFI-158 Consumers:: Consuming generators +* SRFI-158 Accumulators:: Accumulating values +@end menu + +@node SRFI-158 Constructors +@subsubsection SRFI-158 Constructors + +Generators can be constructed from various data sources or created with +specific patterns. + +@deffn {Scheme Procedure} generator arg @dots{} +Returns a generator that yields the given arguments in sequence, then +returns an end-of-file object. + +@example +(define g (generator 1 2 3)) +(g) @result{} 1 +(g) @result{} 2 +(g) @result{} 3 +(g) @result{} #<eof> +@end example +@end deffn + +@deffn {Scheme Procedure} circular-generator arg @dots{} +Returns a generator that yields the given arguments in sequence, then +repeats the sequence infinitely. + +@example +(define g (circular-generator 1 2 3)) +(generator->list g 7) @result{} (1 2 3 1 2 3 1) +@end example +@end deffn + +@deffn {Scheme Procedure} make-iota-generator [count [start [step]]] +Returns a generator that yields @var{count} numbers starting from @var{start} +(default 0) with an increment of @var{step} (default 1). If @var{count} is +omitted, the generator is infinite. + +@example +(generator->list (make-iota-generator 5 10 2)) +@result{} (10 12 14 16 18) +@end example +@end deffn + +@deffn {Scheme Procedure} make-range-generator start [end [step]] +Returns a generator that yields numbers from @var{start} (inclusive) to +@var{end} (exclusive) with an increment of @var{step} (default 1). If +@var{end} is omitted, the generator is infinite. + +@example +(generator->list (make-range-generator 3 8)) +@result{} (3 4 5 6 7) +(generator->list (make-range-generator 3 8 2)) +@result{} (3 5 7) +(generator->list (make-range-generator 10) 5) +@result{} (10 11 12 13 14) +@end example +@end deffn + +@deffn {Scheme Procedure} make-coroutine-generator proc +Creates a generator from a coroutine. @var{proc} is a procedure that takes +one argument, @code{yield}. When @code{yield} is called with a value, that +value becomes the result of calling the generator. + +@example +(define g + (make-coroutine-generator + (lambda (yield) + (let loop ((i 0)) + (when (< i 3) + (yield i) + (loop (+ i 1))))))) +(generator->list g) @result{} (0 1 2) +@end example +@end deffn + +@deffn {Scheme Procedure} list->generator lst +@deffnx {Scheme Procedure} vector->generator vec +@deffnx {Scheme Procedure} reverse-vector->generator vec +@deffnx {Scheme Procedure} string->generator str +@deffnx {Scheme Procedure} bytevector->generator bv +Returns a generator that yields the elements of the given data structure +in sequence. @code{reverse-vector->generator} yields vector elements in +reverse order. +@end deffn + +@node SRFI-158 Operations +@subsubsection SRFI-158 Operations + +These procedures transform generators into new generators. + +@deffn {Scheme Procedure} gcons* item @dots{} gen +Returns a generator that yields the given @var{item}s, then yields values +from @var{gen}. + +@example +(generator->list (gcons* 'a 'b (generator 1 2 3))) +@result{} (a b 1 2 3) +@end example +@end deffn + +@deffn {Scheme Procedure} gappend gen @dots{} +Returns a generator that yields values from the first @var{gen}, then the +second, and so on. + +@example +(generator->list (gappend (generator 1 2) (generator 3 4))) +@result{} (1 2 3 4) +@end example +@end deffn + +@deffn {Scheme Procedure} gfilter pred gen +Returns a generator that yields only the values from @var{gen} for which +@var{pred} returns true. + +@example +(generator->list (gfilter odd? (make-range-generator 1 10))) +@result{} (1 3 5 7 9) +@end example +@end deffn + +@deffn {Scheme Procedure} gremove pred gen +Returns a generator that yields only the values from @var{gen} for which +@var{pred} returns false. +@end deffn + +@deffn {Scheme Procedure} gmap proc gen @dots{} +Returns a generator that applies @var{proc} to the values from the given +generators and yields the results. + +@example +(generator->list (gmap (lambda (x) (* x 2)) (generator 1 2 3))) +@result{} (2 4 6) +@end example +@end deffn + +@deffn {Scheme Procedure} gtake gen k [padding] +Returns a generator that yields the first @var{k} values from @var{gen}. +If @var{gen} is exhausted before @var{k} values are produced, and +@var{padding} is provided, the remaining values are @var{padding}. + +@example +(generator->list (gtake (generator 1 2 3 4 5) 3)) +@result{} (1 2 3) +(generator->list (gtake (generator 1 2) 4 0)) +@result{} (1 2 0 0) +@end example +@end deffn + +@deffn {Scheme Procedure} gdrop gen k +Returns a generator that skips the first @var{k} values from @var{gen}, +then yields the remaining values. +@end deffn + +@deffn {Scheme Procedure} gtake-while pred gen +@deffnx {Scheme Procedure} gdrop-while pred gen +@code{gtake-while} returns a generator that yields values from @var{gen} +as long as @var{pred} returns true. @code{gdrop-while} returns a generator +that skips values from @var{gen} as long as @var{pred} returns true, then +yields the remaining values. +@end deffn + +@deffn {Scheme Procedure} gflatten gen +Returns a generator that yields the elements of the lists produced by +@var{gen}. + +@example +(generator->list (gflatten (generator '(1 2) '(3 4)))) +@result{} (1 2 3 4) +@end example +@end deffn + +@deffn {Scheme Procedure} gmerge less-than gen @dots{} +Returns a generator that merges values from the given generators, which +must yield values in non-decreasing order according to @var{less-than}. +The output is also in non-decreasing order. + +@example +(generator->list (gmerge < (generator 1 3 5) (generator 2 4 6))) +@result{} (1 2 3 4 5 6) +@end example +@end deffn + +@node SRFI-158 Consumers +@subsubsection SRFI-158 Consumers + +These procedures consume values from generators. + +@deffn {Scheme Procedure} generator->list generator [k] +Reads items from @var{generator} and returns a list of them. If @var{k} +is given, reads at most @var{k} items. + +@example +(generator->list (generator 1 2 3)) +@result{} (1 2 3) +(generator->list (make-range-generator 1) 5) +@result{} (1 2 3 4 5) +@end example +@end deffn + +@deffn {Scheme Procedure} generator->reverse-list generator [k] +Like @code{generator->list}, but returns the items in reverse order. +@end deffn + +@deffn {Scheme Procedure} generator->vector generator [k] +@deffnx {Scheme Procedure} generator->string generator [k] +Reads items from @var{generator} and returns a vector or string of them. +@end deffn + +@deffn {Scheme Procedure} generator-fold proc seed gen @dots{} +Applies @var{proc} to the values from the generators and an accumulator, +starting with @var{seed}. Returns the final accumulator value. + +@example +(generator-fold + 0 (generator 1 2 3 4 5)) +@result{} 15 +@end example +@end deffn + +@deffn {Scheme Procedure} generator-for-each proc gen @dots{} +Applies @var{proc} to the values from the generators for side effects. +Returns an unspecified value. +@end deffn + +@deffn {Scheme Procedure} generator-find pred gen +Returns the first value from @var{gen} for which @var{pred} returns true, +or @code{#f} if no such value is found. +@end deffn + +@deffn {Scheme Procedure} generator-count pred gen +Returns the number of values from @var{gen} for which @var{pred} returns +true. +@end deffn + +@deffn {Scheme Procedure} generator-any pred gen +@deffnx {Scheme Procedure} generator-every pred gen +@code{generator-any} returns true if @var{pred} returns true for any value +from @var{gen}. @code{generator-every} returns true if @var{pred} returns +true for all values from @var{gen}. +@end deffn + +@node SRFI-158 Accumulators +@subsubsection SRFI-158 Accumulators + +Accumulators consume values and return a result when passed an end-of-file +object. + +@deffn {Scheme Procedure} list-accumulator +Returns an accumulator that collects values into a list. + +@example +(define acc (list-accumulator)) +(acc 1) +(acc 2) +(acc 3) +(acc (eof-object)) @result{} (1 2 3) +@end example +@end deffn + +@deffn {Scheme Procedure} reverse-list-accumulator +Returns an accumulator that collects values into a list in reverse order. +@end deffn + +@deffn {Scheme Procedure} vector-accumulator +@deffnx {Scheme Procedure} string-accumulator +@deffnx {Scheme Procedure} bytevector-accumulator +Returns an accumulator that collects values into a vector, string, or +bytevector. +@end deffn + +@deffn {Scheme Procedure} count-accumulator +Returns an accumulator that counts the number of values it receives. +@end deffn + +@deffn {Scheme Procedure} sum-accumulator +@deffnx {Scheme Procedure} product-accumulator +Returns an accumulator that computes the sum or product of the values it +receives. + +@example +(define acc (sum-accumulator)) +(acc 1) +(acc 2) +(acc 3) +(acc (eof-object)) @result{} 6 +@end example +@end deffn + + @node SRFI-171 @subsection Transducers @cindex SRFI-171 diff --git a/module/srfi/srfi-158.scm b/module/srfi/srfi-158.scm new file mode 100644 index 000000000..6be17a05c --- /dev/null +++ b/module/srfi/srfi-158.scm @@ -0,0 +1,121 @@ +;; srfi-158.scm --- Generators and Accumulators + +;; Copyright (C) 2026 Free Software Foundation, Inc. +;; +;; This library is free software; you can redistribute it and/or +;; modify it under the terms of the GNU Lesser General Public +;; License as published by the Free Software Foundation; either +;; version 3 of the License, or (at your option) any later version. +;; +;; This library is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; Lesser General Public License for more details. +;; +;; You should have received a copy of the GNU Lesser General Public +;; License along with this library; if not, write to the Free Software +;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Reference implementation from SRFI 158 +;;; Copyright (c) 2015, 2017 Shiro Kawai, John Cowan, Thomas Gilray +;;; Permission is hereby granted, free of charge, to any person obtaining a copy +;;; of this software and associated documentation files (the "Software"), to deal +;;; in the Software without restriction, including without limitation the rights +;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +;;; copies of the Software, and to permit persons to whom the Software is +;;; furnished to do so, subject to the following conditions: +;;; +;;; The above copyright notice and this permission notice shall be included in +;;; all copies or substantial portions of the Software. + +;;; Commentary: + +;; This is an implementation of SRFI-158 (Generators and Accumulators). +;; +;; Generators are procedures that can be called repeatedly to produce a +;; sequence of values. Accumulators are the inverse: procedures that can +;; be called repeatedly to consume a sequence of values. +;; +;; See the SRFI 158 specification at https://srfi.schemers.org/srfi-158/ +;; for detailed documentation. + +;;; Code: + +(define-module (srfi srfi-158) + #:use-module (rnrs io ports) + #:use-module (rnrs bytevectors) + #:use-module (srfi srfi-11) + #:export ( +;;; Generators + generator + circular-generator + make-iota-generator + make-range-generator + make-coroutine-generator + list->generator + vector->generator + reverse-vector->generator + string->generator + bytevector->generator + make-for-each-generator + make-unfold-generator + +;;; Generator operations + gcons* + gappend + gcombine + gfilter + gremove + gtake + gdrop + gtake-while + gdrop-while + gflatten + ggroup + gmerge + gmap + gstate-filter + gdelete + gdelete-neighbor-dups + gindex + gselect + +;;; Consuming generators + generator->list + generator->reverse-list + generator->vector + generator->vector! + generator->string + generator-fold + generator-map->list + generator-for-each + generator-find + generator-count + generator-any + generator-every + generator-unfold + +;;; Accumulators + make-accumulator + count-accumulator + list-accumulator + reverse-list-accumulator + vector-accumulator + reverse-vector-accumulator + vector-accumulator! + string-accumulator + bytevector-accumulator + bytevector-accumulator! + sum-accumulator + product-accumulator + )) + +(cond-expand-provide (current-module) '(srfi-158)) + +;; Guile compatibility shims for R7RS functions + +(define (truncate/ n1 n2) + (values (quotient n1 n2) (remainder n1 n2))) + +;; Load the reference implementation +(include-from-path "srfi/srfi-158/impl.scm") diff --git a/module/srfi/srfi-158/impl.scm b/module/srfi/srfi-158/impl.scm new file mode 100644 index 000000000..21854e36d --- /dev/null +++ b/module/srfi/srfi-158/impl.scm @@ -0,0 +1,580 @@ +;; Chibi Scheme version of any + +(define (any pred ls) + (if (null? (cdr ls)) + (pred (car ls)) + ((lambda (x) (if x x (any pred (cdr ls)))) (pred (car ls))))) + +;; list->bytevector +(define (list->bytevector list) + (let ((vec (make-bytevector (length list) 0))) + (let loop ((i 0) (list list)) + (if (null? list) + vec + (begin + (bytevector-u8-set! vec i (car list)) + (loop (+ i 1) (cdr list))))))) + + +;; generator +(define (generator . args) + (lambda () (if (null? args) + (eof-object) + (let ((next (car args))) + (set! args (cdr args)) + next)))) + +;; circular-generator +(define (circular-generator . args) + (let ((base-args args)) + (lambda () + (when (null? args) + (set! args base-args)) + (let ((next (car args))) + (set! args (cdr args)) + next)))) + + +;; make-iota-generator +(define make-iota-generator + (case-lambda ((count) (make-iota-generator count 0 1)) + ((count start) (make-iota-generator count start 1)) + ((count start step) (make-iota count start step)))) + +;; make-iota +(define (make-iota count start step) + (lambda () + (cond + ((<= count 0) + (eof-object)) + (else + (let ((result start)) + (set! count (- count 1)) + (set! start (+ start step)) + result))))) + + +;; make-range-generator +(define make-range-generator + (case-lambda ((start end) (make-range-generator start end 1)) + ((start) (make-infinite-range-generator start)) + ((start end step) + (set! start (- (+ start step) step)) + (lambda () (if (< start end) + (let ((v start)) + (set! start (+ start step)) + v) + (eof-object)))))) + +(define (make-infinite-range-generator start) + (lambda () + (let ((result start)) + (set! start (+ start 1)) + result))) + + + +;; make-coroutine-generator +(define (make-coroutine-generator proc) + (define return #f) + (define resume #f) + (define yield (lambda (v) (call/cc (lambda (r) (set! resume r) (return v))))) + (lambda () (call/cc (lambda (cc) (set! return cc) + (if resume + (resume (if #f #f)) ; void? or yield again? + (begin (proc yield) + (set! resume (lambda (v) (return (eof-object)))) + (return (eof-object)))))))) + + +;; list->generator +(define (list->generator lst) + (lambda () (if (null? lst) + (eof-object) + (let ((next (car lst))) + (set! lst (cdr lst)) + next)))) + + +;; vector->generator +(define vector->generator + (case-lambda ((vec) (vector->generator vec 0 (vector-length vec))) + ((vec start) (vector->generator vec start (vector-length vec))) + ((vec start end) + (lambda () (if (>= start end) + (eof-object) + (let ((next (vector-ref vec start))) + (set! start (+ start 1)) + next)))))) + + +;; reverse-vector->generator +(define reverse-vector->generator + (case-lambda ((vec) (reverse-vector->generator vec 0 (vector-length vec))) + ((vec start) (reverse-vector->generator vec start (vector-length vec))) + ((vec start end) + (lambda () (if (>= start end) + (eof-object) + (let ((next (vector-ref vec (- end 1)))) + (set! end (- end 1)) + next)))))) + + +;; string->generator +(define string->generator + (case-lambda ((str) (string->generator str 0 (string-length str))) + ((str start) (string->generator str start (string-length str))) + ((str start end) + (lambda () (if (>= start end) + (eof-object) + (let ((next (string-ref str start))) + (set! start (+ start 1)) + next)))))) + + +;; bytevector->generator +(define bytevector->generator + (case-lambda ((str) (bytevector->generator str 0 (bytevector-length str))) + ((str start) (bytevector->generator str start (bytevector-length str))) + ((str start end) + (lambda () (if (>= start end) + (eof-object) + (let ((next (bytevector-u8-ref str start))) + (set! start (+ start 1)) + next)))))) + + +;; make-for-each-generator +;FIXME: seems to fail test +(define (make-for-each-generator for-each obj) + (make-coroutine-generator (lambda (yield) (for-each yield obj)))) + + +;; make-unfold-generator +(define (make-unfold-generator stop? mapper successor seed) + (make-coroutine-generator (lambda (yield) + (let loop ((s seed)) + (if (stop? s) + (if #f #f) + (begin (yield (mapper s)) + (loop (successor s)))))))) + + +;; gcons* +(define (gcons* . args) + (lambda () (if (null? args) + (eof-object) + (if (= (length args) 1) + ((car args)) + (let ((v (car args))) + (set! args (cdr args)) + v))))) + + +;; gappend +(define (gappend . args) + (lambda () (if (null? args) + (eof-object) + (let loop ((v ((car args)))) + (if (eof-object? v) + (begin (set! args (cdr args)) + (if (null? args) + (eof-object) + (loop ((car args))))) + v))))) + +;; gflatten +(define (gflatten gen) + (let ((state '())) + (lambda () + (if (null? state) (set! state (gen))) + (if (eof-object? state) + state + (let ((obj (car state))) + (set! state (cdr state)) + obj))))) + +;; ggroup +(define ggroup + (case-lambda + ((gen k) + (simple-ggroup gen k)) + ((gen k padding) + (padded-ggroup (simple-ggroup gen k) k padding)))) + +(define (simple-ggroup gen k) + (lambda () + (let loop ((item (gen)) (result '()) (count (- k 1))) + (if (eof-object? item) + (if (null? result) item (reverse result)) + (if (= count 0) + (reverse (cons item result)) + (loop (gen) (cons item result) (- count 1))))))) + +(define (padded-ggroup gen k padding) + (lambda () + (let ((item (gen))) + (if (eof-object? item) + item + (let ((len (length item))) + (if (= len k) + item + (append item (make-list (- k len) padding)))))))) + +;; gmerge +(define gmerge + (case-lambda + ((<) (error "wrong number of arguments for gmerge")) + ((< gen) gen) + ((< genleft genright) + (let ((left (genleft)) + (right (genright))) + (lambda () + (cond + ((and (eof-object? left) (eof-object? right)) + left) + ((eof-object? left) + (let ((obj right)) (set! right (genright)) obj)) + ((eof-object? right) + (let ((obj left)) (set! left (genleft)) obj)) + ((< right left) + (let ((obj right)) (set! right (genright)) obj)) + (else + (let ((obj left)) (set! left (genleft)) obj)))))) + ((< . gens) + (apply gmerge < + (let loop ((gens gens) (gs '())) + (cond ((null? gens) (reverse gs)) + ((null? (cdr gens)) (reverse (cons (car gens) gs))) + (else (loop (cddr gens) + (cons (gmerge < (car gens) (cadr gens)) gs))))))))) + +;; gmap +(define gmap + (case-lambda + ((proc) (error "wrong number of arguments for gmap")) + ((proc gen) + (lambda () + (let ((item (gen))) + (if (eof-object? item) item (proc item))))) + ((proc . gens) + (lambda () + (let ((items (map (lambda (x) (x)) gens))) + (if (any eof-object? items) (eof-object) (apply proc items))))))) + +;; gcombine +(define (gcombine proc seed . gens) + (lambda () + (define items (map (lambda (x) (x)) gens)) + (if (any eof-object? items) + (eof-object) + (let () + (define-values (value newseed) (apply proc (append items (list seed)))) + (set! seed newseed) + value)))) + +;; gfilter +(define (gfilter pred gen) + (lambda () (let loop () + (let ((next (gen))) + (if (or (eof-object? next) + (pred next)) + next + (loop)))))) + +;; gstate-filter +(define (gstate-filter proc seed gen) + (let ((state seed)) + (lambda () + (let loop ((item (gen))) + (if (eof-object? item) + item + (let-values (((yes newstate) (proc item state))) + (set! state newstate) + (if yes + item + (loop (gen))))))))) + + + +;; gremove +(define (gremove pred gen) + (gfilter (lambda (v) (not (pred v))) gen)) + + + +;; gtake +(define gtake + (case-lambda ((gen k) (gtake gen k (eof-object))) + ((gen k padding) + (make-coroutine-generator (lambda (yield) + (if (> k 0) + (let loop ((i 0) (v (gen))) + (begin (if (eof-object? v) (yield padding) (yield v)) + (if (< (+ 1 i) k) + (loop (+ 1 i) (gen)) + (eof-object)))) + (eof-object))))))) + + + +;; gdrop +(define (gdrop gen k) + (lambda () (do () ((<= k 0)) (set! k (- k 1)) (gen)) + (gen))) + + + +;; gdrop-while +(define (gdrop-while pred gen) + (define found #f) + (lambda () + (let loop () + (let ((val (gen))) + (cond (found val) + ((and (not (eof-object? val)) (pred val)) (loop)) + (else (set! found #t) val)))))) + + +;; gtake-while +(define (gtake-while pred gen) + (lambda () (let ((next (gen))) + (if (eof-object? next) + next + (if (pred next) + next + (begin (set! gen (generator)) + (gen))))))) + + + +;; gdelete +(define gdelete + (case-lambda ((item gen) (gdelete item gen equal?)) + ((item gen ==) + (lambda () (let loop ((v (gen))) + (cond + ((eof-object? v) (eof-object)) + ((== item v) (loop (gen))) + (else v))))))) + + + +;; gdelete-neighbor-dups +(define gdelete-neighbor-dups + (case-lambda ((gen) + (gdelete-neighbor-dups gen equal?)) + ((gen ==) + (define firsttime #t) + (define prev #f) + (lambda () (if firsttime + (begin (set! firsttime #f) + (set! prev (gen)) + prev) + (let loop ((v (gen))) + (cond + ((eof-object? v) + v) + ((== prev v) + (loop (gen))) + (else + (set! prev v) + v)))))))) + + +;; gindex +(define (gindex value-gen index-gen) + (let ((done? #f) (count 0)) + (lambda () + (if done? + (eof-object) + (let loop ((value (value-gen)) (index (index-gen))) + (cond + ((or (eof-object? value) (eof-object? index)) + (set! done? #t) + (eof-object)) + ((= index count) + (set! count (+ count 1)) + value) + (else + (set! count (+ count 1)) + (loop (value-gen) index)))))))) + + +;; gselect +(define (gselect value-gen truth-gen) + (let ((done? #f)) + (lambda () + (if done? + (eof-object) + (let loop ((value (value-gen)) (truth (truth-gen))) + (cond + ((or (eof-object? value) (eof-object? truth)) + (set! done? #t) + (eof-object)) + (truth value) + (else (loop (value-gen) (truth-gen))))))))) + +;; generator->list +(define generator->list + (case-lambda ((gen n) + (generator->list (gtake gen n))) + ((gen) + (reverse (generator->reverse-list gen))))) + +;; generator->reverse-list +(define generator->reverse-list + (case-lambda ((gen n) + (generator->reverse-list (gtake gen n))) + ((gen) + (generator-fold cons '() gen)))) + +;; generator->vector +(define generator->vector + (case-lambda ((gen) (list->vector (generator->list gen))) + ((gen n) (list->vector (generator->list gen n))))) + + +;; generator->vector! +(define (generator->vector! vector at gen) + (let loop ((value (gen)) (count 0) (at at)) + (cond + ((eof-object? value) count) + ((>= at (vector-length vector)) count) + (else (begin + (vector-set! vector at value) + (loop (gen) (+ count 1) (+ at 1))))))) + + +;; generator->string +(define generator->string + (case-lambda ((gen) (list->string (generator->list gen))) + ((gen n) (list->string (generator->list gen n))))) + + + + +;; generator-fold +(define (generator-fold f seed . gs) + (define (inner-fold seed) + (let ((vs (map (lambda (g) (g)) gs))) + (if (any eof-object? vs) + seed + (inner-fold (apply f (append vs (list seed))))))) + (inner-fold seed)) + + + +;; generator-for-each +(define (generator-for-each f . gs) + (let loop () + (let ((vs (map (lambda (g) (g)) gs))) + (if (any eof-object? vs) + (if #f #f) + (begin (apply f vs) + (loop)))))) + + +(define (generator-map->list f . gs) + (let loop ((result '())) + (let ((vs (map (lambda (g) (g)) gs))) + (if (any eof-object? vs) + (reverse result) + (loop (cons (apply f vs) result)))))) + + +;; generator-find +(define (generator-find pred g) + (let loop ((v (g))) + (cond ((eof-object? v) #f) + ((pred v) v) + (else (loop (g)))))) + +;; generator-count +(define (generator-count pred g) + (generator-fold (lambda (v n) (if (pred v) (+ 1 n) n)) 0 g)) + + +;; generator-any +(define (generator-any pred gen) + (let loop ((item (gen))) + (cond ((eof-object? item) #f) + ((pred item)) + (else (loop (gen)))))) + + +;; generator-every +(define (generator-every pred gen) + (let loop ((item (gen)) (last #t)) + (if (eof-object? item) + last + (let ((r (pred item))) + (if r + (loop (gen) r) + #f))))) + + +;; generator-unfold +(define (generator-unfold g unfold . args) + (apply unfold eof-object? (lambda (x) x) (lambda (x) (g)) (g) args)) + + +;; make-accumulator +(define (make-accumulator kons knil finalize) + (let ((state knil)) + (lambda (obj) + (if (eof-object? obj) + (finalize state) + (set! state (kons obj state)))))) + + +;; count-accumulator +(define (count-accumulator) (make-accumulator + (lambda (obj state) (+ 1 state)) 0 (lambda (x) x))) + +;; list-accumulator +(define (list-accumulator) (make-accumulator cons '() reverse)) + +;; reverse-list-accumulator +(define (reverse-list-accumulator) (make-accumulator cons '() (lambda (x) x))) + +;; vector-accumulator +(define (vector-accumulator) + (make-accumulator cons '() (lambda (x) (list->vector (reverse x))))) + +;; reverse-vector-accumulator +(define (reverse-vector-accumulator) + (make-accumulator cons '() list->vector)) + +;; vector-accumulator! +(define (vector-accumulator! vec at) + (lambda (obj) + (if (eof-object? obj) + vec + (begin + (vector-set! vec at obj) + (set! at (+ at 1)))))) + +;; bytevector-accumulator +(define (bytevector-accumulator) + (make-accumulator cons '() (lambda (x) (list->bytevector (reverse x))))) + +(define (bytevector-accumulator! bytevec at) + (lambda (obj) + (if (eof-object? obj) + bytevec + (begin + (bytevector-u8-set! bytevec at obj) + (set! at (+ at 1)))))) + +;; string-accumulator +(define (string-accumulator) + (make-accumulator cons '() + (lambda (lst) (list->string (reverse lst))))) + +;; sum-accumulator +(define (sum-accumulator) (make-accumulator + 0 (lambda (x) x))) + +;; product-accumulator +(define (product-accumulator) (make-accumulator * 1 (lambda (x) x))) + diff --git a/test-suite/tests/srfi-158.test b/test-suite/tests/srfi-158.test new file mode 100644 index 000000000..628472716 --- /dev/null +++ b/test-suite/tests/srfi-158.test @@ -0,0 +1,245 @@ +;; Copyright (C) 2026 Free Software Foundation, Inc. +;; +;; This library is free software; you can redistribute it and/or +;; modify it under the terms of the GNU Lesser General Public +;; License as published by the Free Software Foundation; either +;; version 3 of the License, or (at your option) any later version. +;; +;; This library is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; Lesser General Public License for more details. +;; +;; You should have received a copy of the GNU Lesser General Public +;; License along with this library; if not, write to the Free Software +;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Test cases are based on the reference test suite from SRFI 158, +;;; available at https://github.com/scheme-requests-for-implementation/srfi-158 +;;; The tests have been adapted to use Guile's test-suite framework. + +(define-module (test-srfi-158) + #:use-module (test-suite lib) + #:use-module (srfi srfi-158) + #:use-module (rnrs bytevectors)) + +(with-test-prefix "generators/constructors" + + (pass-if "generator with no arguments" + (equal? '() (generator->list (generator)))) + + (pass-if "generator with arguments" + (equal? '(1 2 3) (generator->list (generator 1 2 3)))) + + (pass-if "circular-generator" + (equal? '(1 2 3 1 2) (generator->list (circular-generator 1 2 3) 5))) + + (pass-if "make-iota-generator" + (equal? '(8 9 10) (generator->list (make-iota-generator 3 8)))) + + (pass-if "make-iota-generator with step" + (equal? '(8 10 12) (generator->list (make-iota-generator 3 8 2)))) + + (pass-if "make-range-generator unbounded" + (equal? '(3 4 5 6) (generator->list (make-range-generator 3) 4))) + + (pass-if "make-range-generator bounded" + (equal? '(3 4 5 6 7) (generator->list (make-range-generator 3 8)))) + + (pass-if "make-range-generator with step" + (equal? '(3 5 7) (generator->list (make-range-generator 3 8 2)))) + + (pass-if "make-coroutine-generator" + (let ((g (make-coroutine-generator + (lambda (yield) + (let loop ((i 0)) + (when (< i 3) + (yield i) + (loop (+ i 1)))))))) + (equal? '(0 1 2) (generator->list g)))) + + (pass-if "list->generator" + (equal? '(1 2 3 4 5) (generator->list (list->generator '(1 2 3 4 5))))) + + (pass-if "vector->generator" + (equal? '(1 2 3 4 5) (generator->list (vector->generator '#(1 2 3 4 5))))) + + (pass-if "reverse-vector->generator" + (equal? '(5 4 3 2 1) (generator->list (reverse-vector->generator '#(1 2 3 4 5))))) + + (pass-if "string->generator" + (equal? '(#\a #\b #\c #\d #\e) (generator->list (string->generator "abcde")))) + + (pass-if "bytevector->generator" + (equal? '(10 20 30) (generator->list (bytevector->generator (bytevector-u8 10 20 30))))) + + (pass-if "make-for-each-generator" + (let ((for-each-digit (lambda (proc n) + (when (> n 0) + (let-values (((div rem) (truncate/ n 10))) + (proc rem) + (for-each-digit proc div)))))) + (equal? '(5 4 3 2 1) (generator->list + (make-for-each-generator for-each-digit 12345))))) + + (pass-if "make-unfold-generator" + (equal? '(0 2 4 6 8 10) (generator->list + (make-unfold-generator + (lambda (s) (> s 5)) + (lambda (s) (* s 2)) + (lambda (s) (+ s 1)) + 0))))) + +(with-test-prefix "generators/operators" + + (pass-if "gcons*" + (equal? '(a b 0 1) (generator->list (gcons* 'a 'b (make-range-generator 0 2))))) + + (pass-if "gappend" + (equal? '(0 1 2 0 1) (generator->list (gappend (make-range-generator 0 3) + (make-range-generator 0 2))))) + + (pass-if "gappend with no arguments" + (equal? '() (generator->list (gappend)))) + + (pass-if "gcombine" + (let* ((g1 (generator 1 2 3)) + (g2 (generator 4 5 6 7)) + (proc (lambda args (values (apply + args) (apply + args))))) + (equal? '(15 22 31) (generator->list (gcombine proc 10 g1 g2))))) + + (pass-if "gfilter" + (equal? '(1 3 5 7 9) (generator->list (gfilter odd? (make-range-generator 1 11))))) + + (pass-if "gremove" + (equal? '(2 4 6 8 10) (generator->list (gremove odd? (make-range-generator 1 11))))) + + (pass-if "gtake" + (let ((g (make-range-generator 1 5))) + (and (equal? '(1 2 3) (generator->list (gtake g 3))) + (equal? '(4) (generator->list g))))) + + (pass-if "gtake more than available" + (equal? '(1 2) (generator->list (gtake (make-range-generator 1 3) 3)))) + + (pass-if "gtake with padding" + (equal? '(1 2 0) (generator->list (gtake (make-range-generator 1 3) 3 0)))) + + (pass-if "gdrop" + (equal? '(3 4) (generator->list (gdrop (make-range-generator 1 5) 2)))) + + (pass-if "gtake-while" + (let ((g (make-range-generator 1 5))) + (equal? '(1 2) (generator->list (gtake-while (lambda (x) (< x 3)) g))))) + + (pass-if "gdrop-while" + (let ((g (make-range-generator 1 5))) + (equal? '(3 4) (generator->list (gdrop-while (lambda (x) (< x 3)) g))))) + + (pass-if "gdelete" + (equal? '(0.0 1.0 0 2) (generator->list (gdelete 1 (generator 0.0 1.0 0 1 2))))) + + (pass-if "gdelete with equality predicate" + (equal? '(0.0 0 2) (generator->list (gdelete 1 (generator 0.0 1.0 0 1 2) =)))) + + (pass-if "gdelete-neighbor-dups" + (equal? '(1 2 3) (generator->list (gdelete-neighbor-dups (generator 1 1 2 3 3 3) =)))) + + (pass-if "gindex" + (equal? '(a c e) (generator->list (gindex (list->generator '(a b c d e f)) + (list->generator '(0 2 4)))))) + + (pass-if "gselect" + (equal? '(a d e) (generator->list (gselect (list->generator '(a b c d e f)) + (list->generator '(#t #f #f #t #t #f)))))) + + (pass-if "gflatten" + (equal? '(1 2 3 a b c) (generator->list (gflatten (generator '(1 2 3) '(a b c)))))) + + (pass-if "ggroup" + (equal? '((1 2 3) (4 5 6) (7 8)) (generator->list (ggroup (generator 1 2 3 4 5 6 7 8) 3)))) + + (pass-if "ggroup with padding" + (equal? '((1 2 3) (4 5 6) (7 8 0)) (generator->list (ggroup (generator 1 2 3 4 5 6 7 8) 3 0)))) + + (pass-if "gmerge" + (equal? '(1 2 3 4 5 6) (generator->list (gmerge < (generator 1 3 5) (generator 2 4 6))))) + + (pass-if "gmap" + (equal? '(2 4 6 8) (generator->list (gmap (lambda (x) (* x 2)) (generator 1 2 3 4)))))) + +(with-test-prefix "generators/consumers" + + (pass-if "generator->list with length" + (equal? '(1 2 3) (generator->list (make-range-generator 1) 3))) + + (pass-if "generator->reverse-list" + (equal? '(5 4 3 2 1) (generator->reverse-list (generator 1 2 3 4 5)))) + + (pass-if "generator->vector" + (equal? '#(1 2 3 4 5) (generator->vector (generator 1 2 3 4 5)))) + + (pass-if "generator->vector!" + (let ((v (make-vector 5 0))) + (generator->vector! v 2 (generator 1 2 4)) + (equal? '#(0 0 1 2 4) v))) + + (pass-if "generator->string" + (equal? "abcde" (generator->string (generator #\a #\b #\c #\d #\e)))) + + (pass-if "generator-fold" + (equal? 15 (generator-fold + 0 (generator 1 2 3 4 5)))) + + (pass-if "generator-for-each" + (let ((sum 0)) + (generator-for-each (lambda (x) (set! sum (+ sum x))) (generator 1 2 3 4 5)) + (equal? 15 sum))) + + (pass-if "generator-find" + (equal? 4 (generator-find even? (generator 1 3 4 5 6)))) + + (pass-if "generator-count" + (equal? 3 (generator-count odd? (generator 1 2 3 4 5)))) + + (pass-if "generator-any" + (generator-any even? (generator 1 3 4 5))) + + (pass-if "generator-every" + (not (generator-every odd? (generator 1 3 4 5))))) + +(with-test-prefix "accumulators" + + (pass-if "count-accumulator" + (let ((acc (count-accumulator))) + (acc 1) (acc 2) (acc 3) + (equal? 3 (acc (eof-object))))) + + (pass-if "list-accumulator" + (let ((acc (list-accumulator))) + (acc 1) (acc 2) (acc 3) + (equal? '(1 2 3) (acc (eof-object))))) + + (pass-if "reverse-list-accumulator" + (let ((acc (reverse-list-accumulator))) + (acc 1) (acc 2) (acc 3) + (equal? '(3 2 1) (acc (eof-object))))) + + (pass-if "vector-accumulator" + (let ((acc (vector-accumulator))) + (acc 1) (acc 2) (acc 3) + (equal? '#(1 2 3) (acc (eof-object))))) + + (pass-if "string-accumulator" + (let ((acc (string-accumulator))) + (acc #\a) (acc #\b) (acc #\c) + (equal? "abc" (acc (eof-object))))) + + (pass-if "sum-accumulator" + (let ((acc (sum-accumulator))) + (acc 1) (acc 2) (acc 3) + (equal? 6 (acc (eof-object))))) + + (pass-if "product-accumulator" + (let ((acc (product-accumulator))) + (acc 2) (acc 3) (acc 4) + (equal? 24 (acc (eof-object)))))) -- 2.55.0
