mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-19 18:20:22 +02:00
Add SRFI-171 to guile
This adds SRFI-171 (transducers) to guile. The two guile-specific additions are powerful transducers which can be used to generalize transducers like tsegment. They are hard to get right, but powerful and useful enough to warrant inclusion. * doc/ref/srfi-modules.texi: added srfi-171 section * module/Makefile.am (SOURCES): * module/srfi/srfi-171.scm: * module/srfi/srfi-171/meta.scm: Add SRFI-171 * module/srfi/srfi-171/gnu.scm: Add 2 guile-specific extensions. * test-suite/Makefile.am (SCM_TESTS): * test-suite/tests/srfi-171.test: Add tests. Signed-off-by: Ludovic Courtès <ludo@gnu.org>
This commit is contained in:
parent
f8f8986e4a
commit
5f60eb6bb5
7 changed files with 1393 additions and 0 deletions
65
module/srfi/srfi-171/gnu.scm
Normal file
65
module/srfi/srfi-171/gnu.scm
Normal file
|
@ -0,0 +1,65 @@
|
|||
;; Copyright (C) 2020 Free Software Foundation, Inc.
|
||||
;;
|
||||
;; This library is free software; you can redistribute it and/or
|
||||
;; modify it under the terms of the GNU Lesser General Public
|
||||
;; License as published by the Free Software Foundation; either
|
||||
;; version 3 of the License, or (at your option) any later version.
|
||||
;;
|
||||
;; This library is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||||
;; Lesser General Public License for more details.
|
||||
;;
|
||||
;; You should have received a copy of the GNU Lesser General Public
|
||||
;; License along with this library; if not, write to the Free Software
|
||||
;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
|
||||
|
||||
(define-module (srfi srfi-171 gnu)
|
||||
#:use-module (srfi srfi-171)
|
||||
#:use-module (srfi srfi-171 meta)
|
||||
#:export (tbatch tfold))
|
||||
|
||||
|
||||
(define tbatch
|
||||
(case-lambda
|
||||
((reducer)
|
||||
(tbatch identity reducer))
|
||||
((t r)
|
||||
(lambda (reducer)
|
||||
(let ((cur-reducer (t r))
|
||||
(cur-state (r)))
|
||||
(case-lambda
|
||||
(() (reducer))
|
||||
((result)
|
||||
(if (equal? cur-state (cur-reducer))
|
||||
(reducer result)
|
||||
(let ((new-res (reducer result (cur-reducer cur-state))))
|
||||
(if (reduced? new-res)
|
||||
(reducer (unreduce new-res))
|
||||
(reducer new-res)))))
|
||||
((result value)
|
||||
(let ((val (cur-reducer cur-state value)))
|
||||
(cond
|
||||
;; cur-reducer is done. Push value downstream
|
||||
;; re-instantiate the state and the cur-reducer
|
||||
((reduced? val)
|
||||
(let ((unreduced-val (unreduce val)))
|
||||
(set! cur-reducer (t r))
|
||||
(set! cur-state (cur-reducer))
|
||||
(reducer result (cur-reducer unreduced-val))))
|
||||
(else
|
||||
(set! cur-state val)
|
||||
result))))))))))
|
||||
|
||||
|
||||
(define* (tfold reducer #:optional (seed (reducer)))
|
||||
(lambda (r)
|
||||
(let ((state seed))
|
||||
(case-lambda
|
||||
(() (r))
|
||||
((result) (r result))
|
||||
((result value)
|
||||
(set! state (reducer state value))
|
||||
(if (reduced? state)
|
||||
(reduced (reducer (unreduce state)))
|
||||
(r result state)))))))
|
Loading…
Add table
Add a link
Reference in a new issue