[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. release_1-9-12-129-gf
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. release_1-9-12-129-gfdc8fd4 |
|
Date: |
Sun, 03 Oct 2010 10:08:44 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=fdc8fd46fd02d072b6b5f183178862650fe36305
The branch, master has been updated
via fdc8fd46fd02d072b6b5f183178862650fe36305 (commit)
from 6e3d49a0731bca22d8c3b4151a5a7121802a97c1 (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit fdc8fd46fd02d072b6b5f183178862650fe36305
Author: Andreas Rottmann <address@hidden>
Date: Sun Oct 3 12:06:38 2010 +0200
Add implementation of SRFI 42
* module/srfi/srfi-42/ec.scm: New file; reference implementation of
SRFI 42.
* module/srfi/srfi-42.scm: New file; module for SRFI 42.
* module/Makefile.am (SRFI_SOURCES): Add srfi/srfi-42.scm.
(NOCOMP_SOURCES): Add srfi/srfi-42/ec.scm.
* test-suite/tests/srfi-42.test: New file; test suite for SRFI 42.
* test-suite/Makefile.am: SCM_TESTS: Add tests/srfi-42.test.
-----------------------------------------------------------------------
Summary of changes:
NEWS | 7 +-
doc/ref/srfi-modules.texi | 7 +
module/Makefile.am | 2 +
module/srfi/srfi-42.scm | 64 +++
module/srfi/srfi-42/ec.scm | 1053 +++++++++++++++++++++++++++++++++++++++++
test-suite/Makefile.am | 1 +
test-suite/tests/srfi-42.test | 618 ++++++++++++++++++++++++
7 files changed, 1750 insertions(+), 2 deletions(-)
create mode 100644 module/srfi/srfi-42.scm
create mode 100644 module/srfi/srfi-42/ec.scm
create mode 100644 test-suite/tests/srfi-42.test
diff --git a/NEWS b/NEWS
index 0449b1d..5e9fd03 100644
--- a/NEWS
+++ b/NEWS
@@ -11,9 +11,12 @@ latest prerelease, and a full NEWS corresponding to 1.8 ->
2.0.
Changes in 1.9.12 (since the 1.9.11 prerelease):
-** Support for SRFI-27
+** SRFI support
-SRFI-27 "Sources of Random Bits" is now available.
+The following SRFIs have been added:
+
+- SRFI-27 "Sources of Random Bits"
+- SRFI-42 "Eager Comprehensions"
** Many R6RS bugfixes
diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi
index 8a0b014..780f10d 100644
--- a/doc/ref/srfi-modules.texi
+++ b/doc/ref/srfi-modules.texi
@@ -43,6 +43,7 @@ get the relevant SRFI documents from the SRFI home page
* SRFI-35:: Conditions.
* SRFI-37:: args-fold program argument processor
* SRFI-39:: Parameter objects
+* SRFI-42:: Eager comprehensions
* SRFI-55:: Requiring Features.
* SRFI-60:: Integers as bits.
* SRFI-61:: A more general `cond' clause
@@ -3866,6 +3867,12 @@ SRFI-39 doesn't specify the interaction between
parameter objects and
threads, so the threading behaviour described here should be regarded
as Guile-specific.
address@hidden SRFI-42
address@hidden SRFI-42 - Eager Comprehensions
address@hidden SRFI-42
+
+See @uref{http://srfi.schemers.org/srfi-42/srfi-42.html, the
+specification of SRFI-42}.
@node SRFI-55
@subsection SRFI-55 - Requiring Features
diff --git a/module/Makefile.am b/module/Makefile.am
index 4ab649b..6197a43 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -253,6 +253,7 @@ SRFI_SOURCES = \
srfi/srfi-34.scm \
srfi/srfi-35.scm \
srfi/srfi-37.scm \
+ srfi/srfi-42.scm \
srfi/srfi-39.scm \
srfi/srfi-60.scm \
srfi/srfi-69.scm \
@@ -349,6 +350,7 @@ NOCOMP_SOURCES = \
ice-9/psyntax.scm \
ice-9/r6rs-libraries.scm \
ice-9/quasisyntax.scm \
+ srfi/srfi-42/ec.scm \
system/base/lalr.upstream.scm \
system/repl/describe.scm \
sxml/sxml-match.ss \
diff --git a/module/srfi/srfi-42.scm b/module/srfi/srfi-42.scm
new file mode 100644
index 0000000..0aaaf8f
--- /dev/null
+++ b/module/srfi/srfi-42.scm
@@ -0,0 +1,64 @@
+;;; srfi-42.scm --- Eager comprehensions
+
+;; Copyright (C) 2010 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, see
+;; <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This module is not yet documented in the Guile Reference Manual.
+
+;;; Code:
+
+(define-module (srfi srfi-42)
+ #:export (:
+ :-dispatch-ref
+ :-dispatch-set!
+ :char-range
+ :dispatched
+ :do
+ :generator-proc
+ :integers
+ :let
+ :list
+ :parallel
+ :port
+ :range
+ :real-range
+ :string
+ :until
+ :vector
+ :while
+ any?-ec
+ append-ec
+ dispatch-union
+ do-ec
+ every?-ec
+ first-ec
+ fold-ec
+ fold3-ec
+ last-ec
+ list-ec
+ make-initial-:-dispatch
+ max-ec
+ min-ec
+ product-ec
+ string-append-ec
+ string-ec
+ sum-ec
+ vector-ec
+ vector-of-length-ec))
+
+(include-from-path "srfi/srfi-42/ec.scm")
diff --git a/module/srfi/srfi-42/ec.scm b/module/srfi/srfi-42/ec.scm
new file mode 100644
index 0000000..bc0616e
--- /dev/null
+++ b/module/srfi/srfi-42/ec.scm
@@ -0,0 +1,1053 @@
+; <PLAINTEXT>
+; Eager Comprehensions in [outer..inner|expr]-Convention
+; ======================================================
+;
+; address@hidden, Eindhoven, The Netherlands, 26-Dec-2007
+; Scheme R5RS (incl. macros), SRFI-23 (error).
+;
+; Loading the implementation into Scheme48 0.57:
+; ,open srfi-23
+; ,load ec.scm
+;
+; Loading the implementation into PLT/DrScheme 317:
+; ; File > Open ... "ec.scm", click Execute
+;
+; Loading the implementation into SCM 5d7:
+; (require 'macro) (require 'record)
+; (load "ec.scm")
+;
+; Implementation comments:
+; * All local (not exported) identifiers are named ec-<something>.
+; * This implementation focuses on portability, performance,
+; readability, and simplicity roughly in this order. Design
+; decisions related to performance are taken for Scheme48.
+; * Alternative implementations, Comments and Warnings are
+; mentioned after the definition with a heading.
+
+
+; ==========================================================================
+; The fundamental comprehension do-ec
+; ==========================================================================
+;
+; All eager comprehensions are reduced into do-ec and
+; all generators are reduced to :do.
+;
+; We use the following short names for syntactic variables
+; q - qualifier
+; cc - current continuation, thing to call at the end;
+; the CPS is (m (cc ...) arg ...) -> (cc ... expr ...)
+; cmd - an expression being evaluated for its side-effects
+; expr - an expression
+; gen - a generator of an eager comprehension
+; ob - outer binding
+; oc - outer command
+; lb - loop binding
+; ne1? - not-end1? (before the payload)
+; ib - inner binding
+; ic - inner command
+; ne2? - not-end2? (after the payload)
+; ls - loop step
+; etc - more arguments of mixed type
+
+
+; (do-ec q ... cmd)
+; handles nested, if/not/and/or, begin, :let, and calls generator
+; macros in CPS to transform them into fully decorated :do.
+; The code generation for a :do is delegated to do-ec:do.
+
+(define-syntax do-ec
+ (syntax-rules (nested if not and or begin :do let)
+
+ ; explicit nesting -> implicit nesting
+ ((do-ec (nested q ...) etc ...)
+ (do-ec q ... etc ...) )
+
+ ; implicit nesting -> fold do-ec
+ ((do-ec q1 q2 etc1 etc ...)
+ (do-ec q1 (do-ec q2 etc1 etc ...)) )
+
+ ; no qualifiers at all -> evaluate cmd once
+ ((do-ec cmd)
+ (begin cmd (if #f #f)) )
+
+; now (do-ec q cmd) remains
+
+ ; filter -> make conditional
+ ((do-ec (if test) cmd)
+ (if test (do-ec cmd)) )
+ ((do-ec (not test) cmd)
+ (if (not test) (do-ec cmd)) )
+ ((do-ec (and test ...) cmd)
+ (if (and test ...) (do-ec cmd)) )
+ ((do-ec (or test ...) cmd)
+ (if (or test ...) (do-ec cmd)) )
+
+ ; begin -> make a sequence
+ ((do-ec (begin etc ...) cmd)
+ (begin etc ... (do-ec cmd)) )
+
+ ; fully decorated :do-generator -> delegate to do-ec:do
+ ((do-ec (:do olet lbs ne1? ilet ne2? lss) cmd)
+ (do-ec:do cmd (:do olet lbs ne1? ilet ne2? lss)) )
+
+; anything else -> call generator-macro in CPS; reentry at (*)
+
+ ((do-ec (g arg1 arg ...) cmd)
+ (g (do-ec:do cmd) arg1 arg ...) )))
+
+
+; (do-ec:do cmd (:do olet lbs ne1? ilet ne2? lss))
+; generates code for a single fully decorated :do-generator
+; with cmd as payload, taking care of special cases.
+
+(define-syntax do-ec:do
+ (syntax-rules (:do let)
+
+ ; reentry point (*) -> generate code
+ ((do-ec:do cmd
+ (:do (let obs oc ...)
+ lbs
+ ne1?
+ (let ibs ic ...)
+ ne2?
+ (ls ...) ))
+ (ec-simplify
+ (let obs
+ oc ...
+ (let loop lbs
+ (ec-simplify
+ (if ne1?
+ (ec-simplify
+ (let ibs
+ ic ...
+ cmd
+ (ec-simplify
+ (if ne2?
+ (loop ls ...) )))))))))) ))
+
+
+; (ec-simplify <expression>)
+; generates potentially more efficient code for <expression>.
+; The macro handles if, (begin <command>*), and (let () <command>*)
+; and takes care of special cases.
+
+(define-syntax ec-simplify
+ (syntax-rules (if not let begin)
+
+; one- and two-sided if
+
+ ; literal <test>
+ ((ec-simplify (if #t consequent))
+ consequent )
+ ((ec-simplify (if #f consequent))
+ (if #f #f) )
+ ((ec-simplify (if #t consequent alternate))
+ consequent )
+ ((ec-simplify (if #f consequent alternate))
+ alternate )
+
+ ; (not (not <test>))
+ ((ec-simplify (if (not (not test)) consequent))
+ (ec-simplify (if test consequent)) )
+ ((ec-simplify (if (not (not test)) consequent alternate))
+ (ec-simplify (if test consequent alternate)) )
+
+; (let () <command>*)
+
+ ; empty <binding spec>*
+ ((ec-simplify (let () command ...))
+ (ec-simplify (begin command ...)) )
+
+; begin
+
+ ; flatten use helper (ec-simplify 1 done to-do)
+ ((ec-simplify (begin command ...))
+ (ec-simplify 1 () (command ...)) )
+ ((ec-simplify 1 done ((begin to-do1 ...) to-do2 ...))
+ (ec-simplify 1 done (to-do1 ... to-do2 ...)) )
+ ((ec-simplify 1 (done ...) (to-do1 to-do ...))
+ (ec-simplify 1 (done ... to-do1) (to-do ...)) )
+
+ ; exit helper
+ ((ec-simplify 1 () ())
+ (if #f #f) )
+ ((ec-simplify 1 (command) ())
+ command )
+ ((ec-simplify 1 (command1 command ...) ())
+ (begin command1 command ...) )
+
+; anything else
+
+ ((ec-simplify expression)
+ expression )))
+
+
+; ==========================================================================
+; The special generators :do, :let, :parallel, :while, and :until
+; ==========================================================================
+
+(define-syntax :do
+ (syntax-rules ()
+
+ ; full decorated -> continue with cc, reentry at (*)
+ ((:do (cc ...) olet lbs ne1? ilet ne2? lss)
+ (cc ... (:do olet lbs ne1? ilet ne2? lss)) )
+
+ ; short form -> fill in default values
+ ((:do cc lbs ne1? lss)
+ (:do cc (let ()) lbs ne1? (let ()) #t lss) )))
+
+
+(define-syntax :let
+ (syntax-rules (index)
+ ((:let cc var (index i) expression)
+ (:do cc (let ((var expression) (i 0))) () #t (let ()) #f ()) )
+ ((:let cc var expression)
+ (:do cc (let ((var expression))) () #t (let ()) #f ()) )))
+
+
+(define-syntax :parallel
+ (syntax-rules (:do)
+ ((:parallel cc)
+ cc )
+ ((:parallel cc (g arg1 arg ...) gen ...)
+ (g (:parallel-1 cc (gen ...)) arg1 arg ...) )))
+
+; (:parallel-1 cc (to-do ...) result [ next ] )
+; iterates over to-do by converting the first generator into
+; the :do-generator next and merging next into result.
+
+(define-syntax :parallel-1 ; used as
+ (syntax-rules (:do let)
+
+ ; process next element of to-do, reentry at (**)
+ ((:parallel-1 cc ((g arg1 arg ...) gen ...) result)
+ (g (:parallel-1 cc (gen ...) result) arg1 arg ...) )
+
+ ; reentry point (**) -> merge next into result
+ ((:parallel-1
+ cc
+ gens
+ (:do (let (ob1 ...) oc1 ...)
+ (lb1 ...)
+ ne1?1
+ (let (ib1 ...) ic1 ...)
+ ne2?1
+ (ls1 ...) )
+ (:do (let (ob2 ...) oc2 ...)
+ (lb2 ...)
+ ne1?2
+ (let (ib2 ...) ic2 ...)
+ ne2?2
+ (ls2 ...) ))
+ (:parallel-1
+ cc
+ gens
+ (:do (let (ob1 ... ob2 ...) oc1 ... oc2 ...)
+ (lb1 ... lb2 ...)
+ (and ne1?1 ne1?2)
+ (let (ib1 ... ib2 ...) ic1 ... ic2 ...)
+ (and ne2?1 ne2?2)
+ (ls1 ... ls2 ...) )))
+
+ ; no more gens -> continue with cc, reentry at (*)
+ ((:parallel-1 (cc ...) () result)
+ (cc ... result) )))
+
+(define-syntax :while
+ (syntax-rules ()
+ ((:while cc (g arg1 arg ...) test)
+ (g (:while-1 cc test) arg1 arg ...) )))
+
+; (:while-1 cc test (:do ...))
+; modifies the fully decorated :do-generator such that it
+; runs while test is a true value.
+; The original implementation just replaced ne1? by
+; (and ne1? test) as follows:
+;
+; (define-syntax :while-1
+; (syntax-rules (:do)
+; ((:while-1 cc test (:do olet lbs ne1? ilet ne2? lss))
+; (:do cc olet lbs (and ne1? test) ilet ne2? lss) )))
+;
+; Bug #1:
+; Unfortunately, this code is wrong because ne1? may depend
+; in the inner bindings introduced in ilet, but ne1? is evaluated
+; outside of the inner bindings. (Refer to the specification of
+; :do to see the structure.)
+; The problem manifests itself (as address@hidden
+; observed, 25-Apr-2005) when the :list-generator is modified:
+;
+; (do-ec (:while (:list x '(1 2)) (= x 1)) (display x)).
+;
+; In order to generate proper code, we introduce temporary
+; variables saving the values of the inner bindings. The inner
+; bindings are executed in a new ne1?, which also evaluates ne1?
+; outside the scope of the inner bindings, then the inner commands
+; are executed (possibly changing the variables), and then the
+; values of the inner bindings are saved and (and ne1? test) is
+; returned. In the new ilet, the inner variables are bound and
+; initialized and their values are restored. So we construct:
+;
+; (let (ob .. (ib-tmp #f) ...)
+; oc ...
+; (let loop (lb ...)
+; (if (let (ne1?-value ne1?)
+; (let ((ib-var ib-rhs) ...)
+; ic ...
+; (set! ib-tmp ib-var) ...)
+; (and ne1?-value test))
+; (let ((ib-var ib-tmp) ...)
+; /payload/
+; (if ne2?
+; (loop ls ...) )))))
+;
+; Bug #2:
+; Unfortunately, the above expansion is still incorrect (as Jens-Axel
+; Soegaard pointed out, 4-Jun-2007) because ib-rhs are evaluated even
+; if ne1?-value is #f, indicating that the loop has ended.
+; The problem manifests itself in the following example:
+;
+; (do-ec (:while (:list x '(1)) #t) (display x))
+;
+; Which iterates :list beyond exhausting the list '(1).
+;
+; For the fix, we follow Jens-Axel's approach of guarding the evaluation
+; of ib-rhs with a check on ne1?-value.
+
+(define-syntax :while-1
+ (syntax-rules (:do let)
+ ((:while-1 cc test (:do olet lbs ne1? ilet ne2? lss))
+ (:while-2 cc test () () () (:do olet lbs ne1? ilet ne2? lss)))))
+
+(define-syntax :while-2
+ (syntax-rules (:do let)
+ ((:while-2 cc
+ test
+ (ib-let ...)
+ (ib-save ...)
+ (ib-restore ...)
+ (:do olet
+ lbs
+ ne1?
+ (let ((ib-var ib-rhs) ib ...) ic ...)
+ ne2?
+ lss))
+ (:while-2 cc
+ test
+ (ib-let ... (ib-tmp #f))
+ (ib-save ... (ib-var ib-rhs))
+ (ib-restore ... (ib-var ib-tmp))
+ (:do olet
+ lbs
+ ne1?
+ (let (ib ...) ic ... (set! ib-tmp ib-var))
+ ne2?
+ lss)))
+ ((:while-2 cc
+ test
+ (ib-let ...)
+ (ib-save ...)
+ (ib-restore ...)
+ (:do (let (ob ...) oc ...) lbs ne1? (let () ic ...) ne2? lss))
+ (:do cc
+ (let (ob ... ib-let ...) oc ...)
+ lbs
+ (let ((ne1?-value ne1?))
+ (and ne1?-value
+ (let (ib-save ...)
+ ic ...
+ test)))
+ (let (ib-restore ...))
+ ne2?
+ lss))))
+
+
+(define-syntax :until
+ (syntax-rules ()
+ ((:until cc (g arg1 arg ...) test)
+ (g (:until-1 cc test) arg1 arg ...) )))
+
+(define-syntax :until-1
+ (syntax-rules (:do)
+ ((:until-1 cc test (:do olet lbs ne1? ilet ne2? lss))
+ (:do cc olet lbs ne1? ilet (and ne2? (not test)) lss) )))
+
+
+; ==========================================================================
+; The typed generators :list :string :vector etc.
+; ==========================================================================
+
+(define-syntax :list
+ (syntax-rules (index)
+ ((:list cc var (index i) arg ...)
+ (:parallel cc (:list var arg ...) (:integers i)) )
+ ((:list cc var arg1 arg2 arg ...)
+ (:list cc var (append arg1 arg2 arg ...)) )
+ ((:list cc var arg)
+ (:do cc
+ (let ())
+ ((t arg))
+ (not (null? t))
+ (let ((var (car t))))
+ #t
+ ((cdr t)) ))))
+
+
+(define-syntax :string
+ (syntax-rules (index)
+ ((:string cc var (index i) arg)
+ (:do cc
+ (let ((str arg) (len 0))
+ (set! len (string-length str)))
+ ((i 0))
+ (< i len)
+ (let ((var (string-ref str i))))
+ #t
+ ((+ i 1)) ))
+ ((:string cc var (index i) arg1 arg2 arg ...)
+ (:string cc var (index i) (string-append arg1 arg2 arg ...)) )
+ ((:string cc var arg1 arg ...)
+ (:string cc var (index i) arg1 arg ...) )))
+
+; Alternative: An implementation in the style of :vector can also
+; be used for :string. However, it is less interesting as the
+; overhead of string-append is much less than for 'vector-append'.
+
+
+(define-syntax :vector
+ (syntax-rules (index)
+ ((:vector cc var arg)
+ (:vector cc var (index i) arg) )
+ ((:vector cc var (index i) arg)
+ (:do cc
+ (let ((vec arg) (len 0))
+ (set! len (vector-length vec)))
+ ((i 0))
+ (< i len)
+ (let ((var (vector-ref vec i))))
+ #t
+ ((+ i 1)) ))
+
+ ((:vector cc var (index i) arg1 arg2 arg ...)
+ (:parallel cc (:vector cc var arg1 arg2 arg ...) (:integers i)) )
+ ((:vector cc var arg1 arg2 arg ...)
+ (:do cc
+ (let ((vec #f)
+ (len 0)
+ (vecs (ec-:vector-filter (list arg1 arg2 arg ...))) ))
+ ((k 0))
+ (if (< k len)
+ #t
+ (if (null? vecs)
+ #f
+ (begin (set! vec (car vecs))
+ (set! vecs (cdr vecs))
+ (set! len (vector-length vec))
+ (set! k 0)
+ #t )))
+ (let ((var (vector-ref vec k))))
+ #t
+ ((+ k 1)) ))))
+
+(define (ec-:vector-filter vecs)
+ (if (null? vecs)
+ '()
+ (if (zero? (vector-length (car vecs)))
+ (ec-:vector-filter (cdr vecs))
+ (cons (car vecs) (ec-:vector-filter (cdr vecs))) )))
+
+; Alternative: A simpler implementation for :vector uses vector->list
+; append and :list in the multi-argument case. Please refer to the
+; 'design.scm' for more details.
+
+
+(define-syntax :integers
+ (syntax-rules (index)
+ ((:integers cc var (index i))
+ (:do cc ((var 0) (i 0)) #t ((+ var 1) (+ i 1))) )
+ ((:integers cc var)
+ (:do cc ((var 0)) #t ((+ var 1))) )))
+
+
+(define-syntax :range
+ (syntax-rules (index)
+
+ ; handle index variable and add optional args
+ ((:range cc var (index i) arg1 arg ...)
+ (:parallel cc (:range var arg1 arg ...) (:integers i)) )
+ ((:range cc var arg1)
+ (:range cc var 0 arg1 1) )
+ ((:range cc var arg1 arg2)
+ (:range cc var arg1 arg2 1) )
+
+; special cases (partially evaluated by hand from general case)
+
+ ((:range cc var 0 arg2 1)
+ (:do cc
+ (let ((b arg2))
+ (if (not (and (integer? b) (exact? b)))
+ (error
+ "arguments of :range are not exact integer "
+ "(use :real-range?)" 0 b 1 )))
+ ((var 0))
+ (< var b)
+ (let ())
+ #t
+ ((+ var 1)) ))
+
+ ((:range cc var 0 arg2 -1)
+ (:do cc
+ (let ((b arg2))
+ (if (not (and (integer? b) (exact? b)))
+ (error
+ "arguments of :range are not exact integer "
+ "(use :real-range?)" 0 b 1 )))
+ ((var 0))
+ (> var b)
+ (let ())
+ #t
+ ((- var 1)) ))
+
+ ((:range cc var arg1 arg2 1)
+ (:do cc
+ (let ((a arg1) (b arg2))
+ (if (not (and (integer? a) (exact? a)
+ (integer? b) (exact? b) ))
+ (error
+ "arguments of :range are not exact integer "
+ "(use :real-range?)" a b 1 )) )
+ ((var a))
+ (< var b)
+ (let ())
+ #t
+ ((+ var 1)) ))
+
+ ((:range cc var arg1 arg2 -1)
+ (:do cc
+ (let ((a arg1) (b arg2) (s -1) (stop 0))
+ (if (not (and (integer? a) (exact? a)
+ (integer? b) (exact? b) ))
+ (error
+ "arguments of :range are not exact integer "
+ "(use :real-range?)" a b -1 )) )
+ ((var a))
+ (> var b)
+ (let ())
+ #t
+ ((- var 1)) ))
+
+; the general case
+
+ ((:range cc var arg1 arg2 arg3)
+ (:do cc
+ (let ((a arg1) (b arg2) (s arg3) (stop 0))
+ (if (not (and (integer? a) (exact? a)
+ (integer? b) (exact? b)
+ (integer? s) (exact? s) ))
+ (error
+ "arguments of :range are not exact integer "
+ "(use :real-range?)" a b s ))
+ (if (zero? s)
+ (error "step size must not be zero in :range") )
+ (set! stop (+ a (* (max 0 (ceiling (/ (- b a) s))) s))) )
+ ((var a))
+ (not (= var stop))
+ (let ())
+ #t
+ ((+ var s)) ))))
+
+; Comment: The macro :range inserts some code to make sure the values
+; are exact integers. This overhead has proven very helpful for
+; saving users from themselves.
+
+
+(define-syntax :real-range
+ (syntax-rules (index)
+
+ ; add optional args and index variable
+ ((:real-range cc var arg1)
+ (:real-range cc var (index i) 0 arg1 1) )
+ ((:real-range cc var (index i) arg1)
+ (:real-range cc var (index i) 0 arg1 1) )
+ ((:real-range cc var arg1 arg2)
+ (:real-range cc var (index i) arg1 arg2 1) )
+ ((:real-range cc var (index i) arg1 arg2)
+ (:real-range cc var (index i) arg1 arg2 1) )
+ ((:real-range cc var arg1 arg2 arg3)
+ (:real-range cc var (index i) arg1 arg2 arg3) )
+
+ ; the fully qualified case
+ ((:real-range cc var (index i) arg1 arg2 arg3)
+ (:do cc
+ (let ((a arg1) (b arg2) (s arg3) (istop 0))
+ (if (not (and (real? a) (real? b) (real? s)))
+ (error "arguments of :real-range are not real" a b s) )
+ (if (and (exact? a) (or (not (exact? b)) (not (exact? s))))
+ (set! a (exact->inexact a)) )
+ (set! istop (/ (- b a) s)) )
+ ((i 0))
+ (< i istop)
+ (let ((var (+ a (* s i)))))
+ #t
+ ((+ i 1)) ))))
+
+; Comment: The macro :real-range adapts the exactness of the start
+; value in case any of the other values is inexact. This is a
+; precaution to avoid (list-ec (: x 0 3.0) x) => '(0 1.0 2.0).
+
+
+(define-syntax :char-range
+ (syntax-rules (index)
+ ((:char-range cc var (index i) arg1 arg2)
+ (:parallel cc (:char-range var arg1 arg2) (:integers i)) )
+ ((:char-range cc var arg1 arg2)
+ (:do cc
+ (let ((imax (char->integer arg2))))
+ ((i (char->integer arg1)))
+ (<= i imax)
+ (let ((var (integer->char i))))
+ #t
+ ((+ i 1)) ))))
+
+; Warning: There is no R5RS-way to implement the :char-range generator
+; because the integers obtained by char->integer are not necessarily
+; consecutive. We simply assume this anyhow for illustration.
+
+
+(define-syntax :port
+ (syntax-rules (index)
+ ((:port cc var (index i) arg1 arg ...)
+ (:parallel cc (:port var arg1 arg ...) (:integers i)) )
+ ((:port cc var arg)
+ (:port cc var arg read) )
+ ((:port cc var arg1 arg2)
+ (:do cc
+ (let ((port arg1) (read-proc arg2)))
+ ((var (read-proc port)))
+ (not (eof-object? var))
+ (let ())
+ #t
+ ((read-proc port)) ))))
+
+
+; ==========================================================================
+; The typed generator :dispatched and utilities for constructing dispatchers
+; ==========================================================================
+
+(define-syntax :dispatched
+ (syntax-rules (index)
+ ((:dispatched cc var (index i) dispatch arg1 arg ...)
+ (:parallel cc
+ (:integers i)
+ (:dispatched var dispatch arg1 arg ...) ))
+ ((:dispatched cc var dispatch arg1 arg ...)
+ (:do cc
+ (let ((d dispatch)
+ (args (list arg1 arg ...))
+ (g #f)
+ (empty (list #f)) )
+ (set! g (d args))
+ (if (not (procedure? g))
+ (error "unrecognized arguments in dispatching"
+ args
+ (d '()) )))
+ ((var (g empty)))
+ (not (eq? var empty))
+ (let ())
+ #t
+ ((g empty)) ))))
+
+; Comment: The unique object empty is created as a newly allocated
+; non-empty list. It is compared using eq? which distinguishes
+; the object from any other object, according to R5RS 6.1.
+
+
+(define-syntax :generator-proc
+ (syntax-rules (:do let)
+
+ ; call g with a variable, reentry at (**)
+ ((:generator-proc (g arg ...))
+ (g (:generator-proc var) var arg ...) )
+
+ ; reentry point (**) -> make the code from a single :do
+ ((:generator-proc
+ var
+ (:do (let obs oc ...)
+ ((lv li) ...)
+ ne1?
+ (let ((i v) ...) ic ...)
+ ne2?
+ (ls ...)) )
+ (ec-simplify
+ (let obs
+ oc ...
+ (let ((lv li) ... (ne2 #t))
+ (ec-simplify
+ (let ((i #f) ...) ; v not yet valid
+ (lambda (empty)
+ (if (and ne1? ne2)
+ (ec-simplify
+ (begin
+ (set! i v) ...
+ ic ...
+ (let ((value var))
+ (ec-simplify
+ (if ne2?
+ (ec-simplify
+ (begin (set! lv ls) ...) )
+ (set! ne2 #f) ))
+ value )))
+ empty ))))))))
+
+ ; silence warnings of some macro expanders
+ ((:generator-proc var)
+ (error "illegal macro call") )))
+
+
+(define (dispatch-union d1 d2)
+ (lambda (args)
+ (let ((g1 (d1 args)) (g2 (d2 args)))
+ (if g1
+ (if g2
+ (if (null? args)
+ (append (if (list? g1) g1 (list g1))
+ (if (list? g2) g2 (list g2)) )
+ (error "dispatching conflict" args (d1 '()) (d2 '())) )
+ g1 )
+ (if g2 g2 #f) ))))
+
+
+; ==========================================================================
+; The dispatching generator :
+; ==========================================================================
+
+(define (make-initial-:-dispatch)
+ (lambda (args)
+ (case (length args)
+ ((0) 'SRFI42)
+ ((1) (let ((a1 (car args)))
+ (cond
+ ((list? a1)
+ (:generator-proc (:list a1)) )
+ ((string? a1)
+ (:generator-proc (:string a1)) )
+ ((vector? a1)
+ (:generator-proc (:vector a1)) )
+ ((and (integer? a1) (exact? a1))
+ (:generator-proc (:range a1)) )
+ ((real? a1)
+ (:generator-proc (:real-range a1)) )
+ ((input-port? a1)
+ (:generator-proc (:port a1)) )
+ (else
+ #f ))))
+ ((2) (let ((a1 (car args)) (a2 (cadr args)))
+ (cond
+ ((and (list? a1) (list? a2))
+ (:generator-proc (:list a1 a2)) )
+ ((and (string? a1) (string? a1))
+ (:generator-proc (:string a1 a2)) )
+ ((and (vector? a1) (vector? a2))
+ (:generator-proc (:vector a1 a2)) )
+ ((and (integer? a1) (exact? a1) (integer? a2) (exact? a2))
+ (:generator-proc (:range a1 a2)) )
+ ((and (real? a1) (real? a2))
+ (:generator-proc (:real-range a1 a2)) )
+ ((and (char? a1) (char? a2))
+ (:generator-proc (:char-range a1 a2)) )
+ ((and (input-port? a1) (procedure? a2))
+ (:generator-proc (:port a1 a2)) )
+ (else
+ #f ))))
+ ((3) (let ((a1 (car args)) (a2 (cadr args)) (a3 (caddr args)))
+ (cond
+ ((and (list? a1) (list? a2) (list? a3))
+ (:generator-proc (:list a1 a2 a3)) )
+ ((and (string? a1) (string? a1) (string? a3))
+ (:generator-proc (:string a1 a2 a3)) )
+ ((and (vector? a1) (vector? a2) (vector? a3))
+ (:generator-proc (:vector a1 a2 a3)) )
+ ((and (integer? a1) (exact? a1)
+ (integer? a2) (exact? a2)
+ (integer? a3) (exact? a3))
+ (:generator-proc (:range a1 a2 a3)) )
+ ((and (real? a1) (real? a2) (real? a3))
+ (:generator-proc (:real-range a1 a2 a3)) )
+ (else
+ #f ))))
+ (else
+ (letrec ((every?
+ (lambda (pred args)
+ (if (null? args)
+ #t
+ (and (pred (car args))
+ (every? pred (cdr args)) )))))
+ (cond
+ ((every? list? args)
+ (:generator-proc (:list (apply append args))) )
+ ((every? string? args)
+ (:generator-proc (:string (apply string-append args))) )
+ ((every? vector? args)
+ (:generator-proc (:list (apply append (map vector->list args)))) )
+ (else
+ #f )))))))
+
+(define :-dispatch
+ (make-initial-:-dispatch) )
+
+(define (:-dispatch-ref)
+ :-dispatch )
+
+(define (:-dispatch-set! dispatch)
+ (if (not (procedure? dispatch))
+ (error "not a procedure" dispatch) )
+ (set! :-dispatch dispatch) )
+
+(define-syntax :
+ (syntax-rules (index)
+ ((: cc var (index i) arg1 arg ...)
+ (:dispatched cc var (index i) :-dispatch arg1 arg ...) )
+ ((: cc var arg1 arg ...)
+ (:dispatched cc var :-dispatch arg1 arg ...) )))
+
+
+; ==========================================================================
+; The utility comprehensions fold-ec, fold3-ec
+; ==========================================================================
+
+(define-syntax fold3-ec
+ (syntax-rules (nested)
+ ((fold3-ec x0 (nested q1 ...) q etc1 etc2 etc3 etc ...)
+ (fold3-ec x0 (nested q1 ... q) etc1 etc2 etc3 etc ...) )
+ ((fold3-ec x0 q1 q2 etc1 etc2 etc3 etc ...)
+ (fold3-ec x0 (nested q1 q2) etc1 etc2 etc3 etc ...) )
+ ((fold3-ec x0 expression f1 f2)
+ (fold3-ec x0 (nested) expression f1 f2) )
+
+ ((fold3-ec x0 qualifier expression f1 f2)
+ (let ((result #f) (empty #t))
+ (do-ec qualifier
+ (let ((value expression)) ; don't duplicate
+ (if empty
+ (begin (set! result (f1 value))
+ (set! empty #f) )
+ (set! result (f2 value result)) )))
+ (if empty x0 result) ))))
+
+
+(define-syntax fold-ec
+ (syntax-rules (nested)
+ ((fold-ec x0 (nested q1 ...) q etc1 etc2 etc ...)
+ (fold-ec x0 (nested q1 ... q) etc1 etc2 etc ...) )
+ ((fold-ec x0 q1 q2 etc1 etc2 etc ...)
+ (fold-ec x0 (nested q1 q2) etc1 etc2 etc ...) )
+ ((fold-ec x0 expression f2)
+ (fold-ec x0 (nested) expression f2) )
+
+ ((fold-ec x0 qualifier expression f2)
+ (let ((result x0))
+ (do-ec qualifier (set! result (f2 expression result)))
+ result ))))
+
+
+; ==========================================================================
+; The comprehensions list-ec string-ec vector-ec etc.
+; ==========================================================================
+
+(define-syntax list-ec
+ (syntax-rules ()
+ ((list-ec etc1 etc ...)
+ (reverse (fold-ec '() etc1 etc ... cons)) )))
+
+; Alternative: Reverse can safely be replaced by reverse! if you have it.
+;
+; Alternative: It is possible to construct the result in the correct order
+; using set-cdr! to add at the tail. This removes the overhead of copying
+; at the end, at the cost of more book-keeping.
+
+
+(define-syntax append-ec
+ (syntax-rules ()
+ ((append-ec etc1 etc ...)
+ (apply append (list-ec etc1 etc ...)) )))
+
+(define-syntax string-ec
+ (syntax-rules ()
+ ((string-ec etc1 etc ...)
+ (list->string (list-ec etc1 etc ...)) )))
+
+; Alternative: For very long strings, the intermediate list may be a
+; problem. A more space-aware implementation collect the characters
+; in an intermediate list and when this list becomes too large it is
+; converted into an intermediate string. At the end, the intermediate
+; strings are concatenated with string-append.
+
+
+(define-syntax string-append-ec
+ (syntax-rules ()
+ ((string-append-ec etc1 etc ...)
+ (apply string-append (list-ec etc1 etc ...)) )))
+
+(define-syntax vector-ec
+ (syntax-rules ()
+ ((vector-ec etc1 etc ...)
+ (list->vector (list-ec etc1 etc ...)) )))
+
+; Comment: A similar approach as for string-ec can be used for vector-ec.
+; However, the space overhead for the intermediate list is much lower
+; than for string-ec and as there is no vector-append, the intermediate
+; vectors must be copied explicitly.
+
+(define-syntax vector-of-length-ec
+ (syntax-rules (nested)
+ ((vector-of-length-ec k (nested q1 ...) q etc1 etc ...)
+ (vector-of-length-ec k (nested q1 ... q) etc1 etc ...) )
+ ((vector-of-length-ec k q1 q2 etc1 etc ...)
+ (vector-of-length-ec k (nested q1 q2) etc1 etc ...) )
+ ((vector-of-length-ec k expression)
+ (vector-of-length-ec k (nested) expression) )
+
+ ((vector-of-length-ec k qualifier expression)
+ (let ((len k))
+ (let ((vec (make-vector len))
+ (i 0) )
+ (do-ec qualifier
+ (if (< i len)
+ (begin (vector-set! vec i expression)
+ (set! i (+ i 1)) )
+ (error "vector is too short for the comprehension") ))
+ (if (= i len)
+ vec
+ (error "vector is too long for the comprehension") ))))))
+
+
+(define-syntax sum-ec
+ (syntax-rules ()
+ ((sum-ec etc1 etc ...)
+ (fold-ec (+) etc1 etc ... +) )))
+
+(define-syntax product-ec
+ (syntax-rules ()
+ ((product-ec etc1 etc ...)
+ (fold-ec (*) etc1 etc ... *) )))
+
+(define-syntax min-ec
+ (syntax-rules ()
+ ((min-ec etc1 etc ...)
+ (fold3-ec (min) etc1 etc ... min min) )))
+
+(define-syntax max-ec
+ (syntax-rules ()
+ ((max-ec etc1 etc ...)
+ (fold3-ec (max) etc1 etc ... max max) )))
+
+(define-syntax last-ec
+ (syntax-rules (nested)
+ ((last-ec default (nested q1 ...) q etc1 etc ...)
+ (last-ec default (nested q1 ... q) etc1 etc ...) )
+ ((last-ec default q1 q2 etc1 etc ...)
+ (last-ec default (nested q1 q2) etc1 etc ...) )
+ ((last-ec default expression)
+ (last-ec default (nested) expression) )
+
+ ((last-ec default qualifier expression)
+ (let ((result default))
+ (do-ec qualifier (set! result expression))
+ result ))))
+
+
+; ==========================================================================
+; The fundamental early-stopping comprehension first-ec
+; ==========================================================================
+
+(define-syntax first-ec
+ (syntax-rules (nested)
+ ((first-ec default (nested q1 ...) q etc1 etc ...)
+ (first-ec default (nested q1 ... q) etc1 etc ...) )
+ ((first-ec default q1 q2 etc1 etc ...)
+ (first-ec default (nested q1 q2) etc1 etc ...) )
+ ((first-ec default expression)
+ (first-ec default (nested) expression) )
+
+ ((first-ec default qualifier expression)
+ (let ((result default) (stop #f))
+ (ec-guarded-do-ec
+ stop
+ (nested qualifier)
+ (begin (set! result expression)
+ (set! stop #t) ))
+ result ))))
+
+; (ec-guarded-do-ec stop (nested q ...) cmd)
+; constructs (do-ec q ... cmd) where the generators gen in q ... are
+; replaced by (:until gen stop).
+
+(define-syntax ec-guarded-do-ec
+ (syntax-rules (nested if not and or begin)
+
+ ((ec-guarded-do-ec stop (nested (nested q1 ...) q2 ...) cmd)
+ (ec-guarded-do-ec stop (nested q1 ... q2 ...) cmd) )
+
+ ((ec-guarded-do-ec stop (nested (if test) q ...) cmd)
+ (if test (ec-guarded-do-ec stop (nested q ...) cmd)) )
+ ((ec-guarded-do-ec stop (nested (not test) q ...) cmd)
+ (if (not test) (ec-guarded-do-ec stop (nested q ...) cmd)) )
+ ((ec-guarded-do-ec stop (nested (and test ...) q ...) cmd)
+ (if (and test ...) (ec-guarded-do-ec stop (nested q ...) cmd)) )
+ ((ec-guarded-do-ec stop (nested (or test ...) q ...) cmd)
+ (if (or test ...) (ec-guarded-do-ec stop (nested q ...) cmd)) )
+
+ ((ec-guarded-do-ec stop (nested (begin etc ...) q ...) cmd)
+ (begin etc ... (ec-guarded-do-ec stop (nested q ...) cmd)) )
+
+ ((ec-guarded-do-ec stop (nested gen q ...) cmd)
+ (do-ec
+ (:until gen stop)
+ (ec-guarded-do-ec stop (nested q ...) cmd) ))
+
+ ((ec-guarded-do-ec stop (nested) cmd)
+ (do-ec cmd) )))
+
+; Alternative: Instead of modifying the generator with :until, it is
+; possible to use call-with-current-continuation:
+;
+; (define-synatx first-ec
+; ...same as above...
+; ((first-ec default qualifier expression)
+; (call-with-current-continuation
+; (lambda (cc)
+; (do-ec qualifier (cc expression))
+; default ))) ))
+;
+; This is much simpler but not necessarily as efficient.
+
+
+; ==========================================================================
+; The early-stopping comprehensions any?-ec every?-ec
+; ==========================================================================
+
+(define-syntax any?-ec
+ (syntax-rules (nested)
+ ((any?-ec (nested q1 ...) q etc1 etc ...)
+ (any?-ec (nested q1 ... q) etc1 etc ...) )
+ ((any?-ec q1 q2 etc1 etc ...)
+ (any?-ec (nested q1 q2) etc1 etc ...) )
+ ((any?-ec expression)
+ (any?-ec (nested) expression) )
+
+ ((any?-ec qualifier expression)
+ (first-ec #f qualifier (if expression) #t) )))
+
+(define-syntax every?-ec
+ (syntax-rules (nested)
+ ((every?-ec (nested q1 ...) q etc1 etc ...)
+ (every?-ec (nested q1 ... q) etc1 etc ...) )
+ ((every?-ec q1 q2 etc1 etc ...)
+ (every?-ec (nested q1 q2) etc1 etc ...) )
+ ((every?-ec expression)
+ (every?-ec (nested) expression) )
+
+ ((every?-ec qualifier expression)
+ (first-ec #t qualifier (if (not expression)) #f) )))
+
diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am
index 22f31d9..a481260 100644
--- a/test-suite/Makefile.am
+++ b/test-suite/Makefile.am
@@ -119,6 +119,7 @@ SCM_TESTS = tests/00-initial-env.test \
tests/srfi-35.test \
tests/srfi-37.test \
tests/srfi-39.test \
+ tests/srfi-42.test \
tests/srfi-60.test \
tests/srfi-69.test \
tests/srfi-88.test \
diff --git a/test-suite/tests/srfi-42.test b/test-suite/tests/srfi-42.test
new file mode 100644
index 0000000..5417de0
--- /dev/null
+++ b/test-suite/tests/srfi-42.test
@@ -0,0 +1,618 @@
+;;; -*- mode: scheme; coding: utf-8; -*-
+
+;;; Examples for Eager Comprehensions in [outer..inner|expr]-Convention
+;;; ===================================================================
+;;;
+;;; Copyright (C) 2010 Free Software Foundation, Inc.
+;;; Copyright (c) 2007 Sebastian Egner
+;;;
+;;; This code is based on the file examples.scm in the reference
+;;; implementation of SRFI-42, provided under the following license:
+;;;
+;;; Permission is hereby granted, free of charge, to any person obtaining
+;;; a copy of this software and associated documentation files (the
+;;; ``Software''), to deal in the Software without restriction, including
+;;; without limitation the rights to use, copy, modify, merge, publish,
+;;; distribute, sublicense, and/or sell copies of the Software, and to
+;;; permit persons to whom the Software is furnished to do so, subject to
+;;; the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED ``AS IS'', WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+;;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+;;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+;;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+;;;
+
+(define-module (test-srfi-42)
+ #:use-module (test-suite lib)
+ #:use-module (srfi srfi-42))
+
+
+; Tools for checking results
+; ==========================
+
+(define (my-equal? x y)
+ (cond
+ ((or (boolean? x)
+ (null? x)
+ (symbol? x)
+ (char? x)
+ (input-port? x)
+ (output-port? x) )
+ (eqv? x y) )
+ ((string? x)
+ (and (string? y) (string=? x y)) )
+ ((vector? x)
+ (and (vector? y)
+ (my-equal? (vector->list x) (vector->list y)) ))
+ ((pair? x)
+ (and (pair? y)
+ (my-equal? (car x) (car y))
+ (my-equal? (cdr x) (cdr y)) ))
+ ((real? x)
+ (and (real? y)
+ (eqv? (exact? x) (exact? y))
+ (if (exact? x)
+ (= x y)
+ (< (abs (- x y)) (/ 1 (expt 10 6))) ))) ; will do here
+ (else
+ (error "unrecognized type" x) )))
+
+(define-syntax my-check
+ (syntax-rules (=>)
+ ((my-check ec => desired-result)
+ (pass-if (my-equal? ec desired-result)))))
+
+(define my-call-with-input-file call-with-input-file)
+(define my-open-output-file open-output-file)
+
+; ==========================================================================
+; do-ec
+; ==========================================================================
+
+(my-check
+ (let ((x 0)) (do-ec (set! x (+ x 1))) x)
+ => 1)
+
+(my-check
+ (let ((x 0)) (do-ec (:range i 10) (set! x (+ x 1))) x)
+ => 10)
+
+(my-check
+ (let ((x 0)) (do-ec (:range n 10) (:range k n) (set! x (+ x 1))) x)
+ => 45)
+
+
+; ==========================================================================
+; list-ec and basic qualifiers
+; ==========================================================================
+
+(my-check (list-ec 1) => '(1))
+
+(my-check (list-ec (:range i 4) i) => '(0 1 2 3))
+
+(my-check (list-ec (:range n 3) (:range k (+ n 1)) (list n k))
+ => '((0 0) (1 0) (1 1) (2 0) (2 1) (2 2)) )
+
+(my-check
+ (list-ec (:range n 5) (if (even? n)) (:range k (+ n 1)) (list n k))
+ => '((0 0) (2 0) (2 1) (2 2) (4 0) (4 1) (4 2) (4 3) (4 4)) )
+
+(my-check
+ (list-ec (:range n 5) (not (even? n)) (:range k (+ n 1)) (list n k))
+ => '((1 0) (1 1) (3 0) (3 1) (3 2) (3 3)) )
+
+(my-check
+ (list-ec (:range n 5)
+ (and (even? n) (> n 2))
+ (:range k (+ n 1))
+ (list n k) )
+ => '((4 0) (4 1) (4 2) (4 3) (4 4)) )
+
+(my-check
+ (list-ec (:range n 5)
+ (or (even? n) (> n 3))
+ (:range k (+ n 1))
+ (list n k) )
+ => '((0 0) (2 0) (2 1) (2 2) (4 0) (4 1) (4 2) (4 3) (4 4)) )
+
+(my-check
+ (let ((x 0)) (list-ec (:range n 10) (begin (set! x (+ x 1))) n) x)
+ => 10 )
+
+(my-check
+ (list-ec (nested (:range n 3) (:range k n)) k)
+ => '(0 0 1) )
+
+
+; ==========================================================================
+; Other comprehensions
+; ==========================================================================
+
+(my-check (append-ec '(a b)) => '(a b))
+(my-check (append-ec (:range i 0) '(a b)) => '())
+(my-check (append-ec (:range i 1) '(a b)) => '(a b))
+(my-check (append-ec (:range i 2) '(a b)) => '(a b a b))
+
+(my-check (string-ec #\a) => (string #\a))
+(my-check (string-ec (:range i 0) #\a) => "")
+(my-check (string-ec (:range i 1) #\a) => "a")
+(my-check (string-ec (:range i 2) #\a) => "aa")
+
+(my-check (string-append-ec "ab") => "ab")
+(my-check (string-append-ec (:range i 0) "ab") => "")
+(my-check (string-append-ec (:range i 1) "ab") => "ab")
+(my-check (string-append-ec (:range i 2) "ab") => "abab")
+
+(my-check (vector-ec 1) => (vector 1))
+(my-check (vector-ec (:range i 0) i) => (vector))
+(my-check (vector-ec (:range i 1) i) => (vector 0))
+(my-check (vector-ec (:range i 2) i) => (vector 0 1))
+
+(my-check (vector-of-length-ec 1 1) => (vector 1))
+(my-check (vector-of-length-ec 0 (:range i 0) i) => (vector))
+(my-check (vector-of-length-ec 1 (:range i 1) i) => (vector 0))
+(my-check (vector-of-length-ec 2 (:range i 2) i) => (vector 0 1))
+
+(my-check (sum-ec 1) => 1)
+(my-check (sum-ec (:range i 0) i) => 0)
+(my-check (sum-ec (:range i 1) i) => 0)
+(my-check (sum-ec (:range i 2) i) => 1)
+(my-check (sum-ec (:range i 3) i) => 3)
+
+(my-check (product-ec 1) => 1)
+(my-check (product-ec (:range i 1 0) i) => 1)
+(my-check (product-ec (:range i 1 1) i) => 1)
+(my-check (product-ec (:range i 1 2) i) => 1)
+(my-check (product-ec (:range i 1 3) i) => 2)
+(my-check (product-ec (:range i 1 4) i) => 6)
+
+(my-check (min-ec 1) => 1)
+(my-check (min-ec (:range i 1) i) => 0)
+(my-check (min-ec (:range i 2) i) => 0)
+
+(my-check (max-ec 1) => 1)
+(my-check (max-ec (:range i 1) i) => 0)
+(my-check (max-ec (:range i 2) i) => 1)
+
+(my-check (first-ec #f 1) => 1)
+(my-check (first-ec #f (:range i 0) i) => #f)
+(my-check (first-ec #f (:range i 1) i) => 0)
+(my-check (first-ec #f (:range i 2) i) => 0)
+
+(my-check
+ (let ((last-i -1))
+ (first-ec #f (:range i 10) (begin (set! last-i i)) i)
+ last-i )
+ => 0 )
+
+(my-check (last-ec #f 1) => 1)
+(my-check (last-ec #f (:range i 0) i) => #f)
+(my-check (last-ec #f (:range i 1) i) => 0)
+(my-check (last-ec #f (:range i 2) i) => 1)
+
+(my-check (any?-ec #f) => #f)
+(my-check (any?-ec #t) => #t)
+(my-check (any?-ec (:range i 2 2) (even? i)) => #f)
+(my-check (any?-ec (:range i 2 3) (even? i)) => #t)
+
+(my-check (every?-ec #f) => #f)
+(my-check (every?-ec #t) => #t)
+(my-check (every?-ec (:range i 2 2) (even? i)) => #t)
+(my-check (every?-ec (:range i 2 3) (even? i)) => #t)
+(my-check (every?-ec (:range i 2 4) (even? i)) => #f)
+
+(my-check
+ (let ((sum-sqr (lambda (x result) (+ result (* x x)))))
+ (fold-ec 0 (:range i 10) i sum-sqr) )
+ => 285 )
+
+(my-check
+ (let ((minus-1 (lambda (x) (- x 1)))
+ (sum-sqr (lambda (x result) (+ result (* x x)))))
+ (fold3-ec (error "wrong") (:range i 10) i minus-1 sum-sqr) )
+ => 284 )
+
+(my-check
+ (fold3-ec 'infinity (:range i 0) i min min)
+ => 'infinity )
+
+
+; ==========================================================================
+; Typed generators
+; ==========================================================================
+
+(my-check (list-ec (:list x '()) x) => '())
+(my-check (list-ec (:list x '(1)) x) => '(1))
+(my-check (list-ec (:list x '(1 2 3)) x) => '(1 2 3))
+(my-check (list-ec (:list x '(1) '(2)) x) => '(1 2))
+(my-check (list-ec (:list x '(1) '(2) '(3)) x) => '(1 2 3))
+
+(my-check (list-ec (:string c "") c) => '())
+(my-check (list-ec (:string c "1") c) => '(#\1))
+(my-check (list-ec (:string c "123") c) => '(#\1 #\2 #\3))
+(my-check (list-ec (:string c "1" "2") c) => '(#\1 #\2))
+(my-check (list-ec (:string c "1" "2" "3") c) => '(#\1 #\2 #\3))
+
+(my-check (list-ec (:vector x (vector)) x) => '())
+(my-check (list-ec (:vector x (vector 1)) x) => '(1))
+(my-check (list-ec (:vector x (vector 1 2 3)) x) => '(1 2 3))
+(my-check (list-ec (:vector x (vector 1) (vector 2)) x) => '(1 2))
+(my-check
+ (list-ec (:vector x (vector 1) (vector 2) (vector 3)) x)
+ => '(1 2 3))
+
+(my-check (list-ec (:range x -2) x) => '())
+(my-check (list-ec (:range x -1) x) => '())
+(my-check (list-ec (:range x 0) x) => '())
+(my-check (list-ec (:range x 1) x) => '(0))
+(my-check (list-ec (:range x 2) x) => '(0 1))
+
+(my-check (list-ec (:range x 0 3) x) => '(0 1 2))
+(my-check (list-ec (:range x 1 3) x) => '(1 2))
+(my-check (list-ec (:range x -2 -1) x) => '(-2))
+(my-check (list-ec (:range x -2 -2) x) => '())
+
+(my-check (list-ec (:range x 1 5 2) x) => '(1 3))
+(my-check (list-ec (:range x 1 6 2) x) => '(1 3 5))
+(my-check (list-ec (:range x 5 1 -2) x) => '(5 3))
+(my-check (list-ec (:range x 6 1 -2) x) => '(6 4 2))
+
+(my-check (list-ec (:real-range x 0.0 3.0) x) => '(0. 1. 2.))
+(my-check (list-ec (:real-range x 0 3.0) x) => '(0. 1. 2.))
+(my-check (list-ec (:real-range x 0 3 1.0) x) => '(0. 1. 2.))
+
+(my-check
+ (string-ec (:char-range c #\a #\z) c)
+ => "abcdefghijklmnopqrstuvwxyz" )
+
+(my-check
+ (begin
+ (let ((f (my-open-output-file "tmp1")))
+ (do-ec (:range n 10) (begin (write n f) (newline f)))
+ (close-output-port f))
+ (my-call-with-input-file "tmp1"
+ (lambda (port) (list-ec (:port x port read) x)) ))
+ => (list-ec (:range n 10) n) )
+
+(my-check
+ (begin
+ (let ((f (my-open-output-file "tmp1")))
+ (do-ec (:range n 10) (begin (write n f) (newline f)))
+ (close-output-port f))
+ (my-call-with-input-file "tmp1"
+ (lambda (port) (list-ec (:port x port) x)) ))
+ => (list-ec (:range n 10) n) )
+
+
+; ==========================================================================
+; The special generators :do :let :parallel :while :until
+; ==========================================================================
+
+(my-check (list-ec (:do ((i 0)) (< i 4) ((+ i 1))) i) => '(0 1 2 3))
+
+(my-check
+ (list-ec
+ (:do (let ((x 'x)))
+ ((i 0))
+ (< i 4)
+ (let ((j (- 10 i))))
+ #t
+ ((+ i 1)) )
+ j )
+ => '(10 9 8 7) )
+
+(my-check (list-ec (:let x 1) x) => '(1))
+(my-check (list-ec (:let x 1) (:let y (+ x 1)) y) => '(2))
+(my-check (list-ec (:let x 1) (:let x (+ x 1)) x) => '(2))
+
+(my-check
+ (list-ec (:parallel (:range i 1 10) (:list x '(a b c))) (list i x))
+ => '((1 a) (2 b) (3 c)) )
+
+(my-check
+ (list-ec (:while (:range i 1 10) (< i 5)) i)
+ => '(1 2 3 4) )
+
+(my-check
+ (list-ec (:until (:range i 1 10) (>= i 5)) i)
+ => '(1 2 3 4 5) )
+
+; with generator that might use inner bindings
+
+(my-check
+ (list-ec (:while (:list i '(1 2 3 4 5 6 7 8 9)) (< i 5)) i)
+ => '(1 2 3 4) )
+; Was broken in original reference implementation as pointed
+; out by address@hidden on 24-Apr-2005 comp.lang.scheme.
+; Refer to http://groups-beta.google.com/group/comp.lang.scheme/
+; browse_thread/thread/f5333220eaeeed66/75926634cf31c038#75926634cf31c038
+
+(my-check
+ (list-ec (:until (:list i '(1 2 3 4 5 6 7 8 9)) (>= i 5)) i)
+ => '(1 2 3 4 5) )
+
+(my-check
+ (list-ec (:while (:vector x (index i) '#(1 2 3 4 5))
+ (< x 10))
+ x)
+ => '(1 2 3 4 5))
+; Was broken in reference implementation, even after fix for the
+; bug reported by Sunnan, as reported by Jens-Axel Soegaard on
+; 4-Jun-2007.
+
+; combine :while/:until and :parallel
+
+(my-check
+ (list-ec (:while (:parallel (:range i 1 10)
+ (:list j '(1 2 3 4 5 6 7 8 9)))
+ (< i 5))
+ (list i j))
+ => '((1 1) (2 2) (3 3) (4 4)))
+
+(my-check
+ (list-ec (:until (:parallel (:range i 1 10)
+ (:list j '(1 2 3 4 5 6 7 8 9)))
+ (>= i 5))
+ (list i j))
+ => '((1 1) (2 2) (3 3) (4 4) (5 5)))
+
+; check that :while/:until really stop the generator
+
+(my-check
+ (let ((n 0))
+ (do-ec (:while (:range i 1 10) (begin (set! n (+ n 1)) (< i 5)))
+ (if #f #f))
+ n)
+ => 5)
+
+(my-check
+ (let ((n 0))
+ (do-ec (:until (:range i 1 10) (begin (set! n (+ n 1)) (>= i 5)))
+ (if #f #f))
+ n)
+ => 5)
+
+(my-check
+ (let ((n 0))
+ (do-ec (:while (:parallel (:range i 1 10)
+ (:do () (begin (set! n (+ n 1)) #t) ()))
+ (< i 5))
+ (if #f #f))
+ n)
+ => 5)
+
+(my-check
+ (let ((n 0))
+ (do-ec (:until (:parallel (:range i 1 10)
+ (:do () (begin (set! n (+ n 1)) #t) ()))
+ (>= i 5))
+ (if #f #f))
+ n)
+ => 5)
+
+; ==========================================================================
+; The dispatching generator
+; ==========================================================================
+
+(my-check (list-ec (: c '(a b)) c) => '(a b))
+(my-check (list-ec (: c '(a b) '(c d)) c) => '(a b c d))
+
+(my-check (list-ec (: c "ab") c) => '(#\a #\b))
+(my-check (list-ec (: c "ab" "cd") c) => '(#\a #\b #\c #\d))
+
+(my-check (list-ec (: c (vector 'a 'b)) c) => '(a b))
+(my-check (list-ec (: c (vector 'a 'b) (vector 'c)) c) => '(a b c))
+
+(my-check (list-ec (: i 0) i) => '())
+(my-check (list-ec (: i 1) i) => '(0))
+(my-check (list-ec (: i 10) i) => '(0 1 2 3 4 5 6 7 8 9))
+(my-check (list-ec (: i 1 2) i) => '(1))
+(my-check (list-ec (: i 1 2 3) i) => '(1))
+(my-check (list-ec (: i 1 9 3) i) => '(1 4 7))
+
+(my-check (list-ec (: i 0.0 1.0 0.2) i) => '(0. 0.2 0.4 0.6 0.8))
+
+(my-check (list-ec (: c #\a #\c) c) => '(#\a #\b #\c))
+
+(my-check
+ (begin
+ (let ((f (my-open-output-file "tmp1")))
+ (do-ec (:range n 10) (begin (write n f) (newline f)))
+ (close-output-port f))
+ (my-call-with-input-file "tmp1"
+ (lambda (port) (list-ec (: x port read) x)) ))
+ => (list-ec (:range n 10) n) )
+
+(my-check
+ (begin
+ (let ((f (my-open-output-file "tmp1")))
+ (do-ec (:range n 10) (begin (write n f) (newline f)))
+ (close-output-port f))
+ (my-call-with-input-file "tmp1"
+ (lambda (port) (list-ec (: x port) x)) ))
+ => (list-ec (:range n 10) n) )
+
+
+; ==========================================================================
+; With index variable
+; ==========================================================================
+
+(my-check (list-ec (:list c (index i) '(a b)) (list c i)) => '((a 0) (b 1)))
+(my-check (list-ec (:string c (index i) "a") (list c i)) => '((#\a 0)))
+(my-check (list-ec (:vector c (index i) (vector 'a)) (list c i)) => '((a 0)))
+
+(my-check
+ (list-ec (:range i (index j) 0 -3 -1) (list i j))
+ => '((0 0) (-1 1) (-2 2)) )
+
+(my-check
+ (list-ec (:real-range i (index j) 0 1 0.2) (list i j))
+ => '((0. 0) (0.2 1) (0.4 2) (0.6 3) (0.8 4)) )
+
+(my-check
+ (list-ec (:char-range c (index i) #\a #\c) (list c i))
+ => '((#\a 0) (#\b 1) (#\c 2)) )
+
+(my-check
+ (list-ec (: x (index i) '(a b c d)) (list x i))
+ => '((a 0) (b 1) (c 2) (d 3)) )
+
+(my-check
+ (begin
+ (let ((f (my-open-output-file "tmp1")))
+ (do-ec (:range n 10) (begin (write n f) (newline f)))
+ (close-output-port f))
+ (my-call-with-input-file "tmp1"
+ (lambda (port) (list-ec (: x (index i) port) (list x i))) ))
+ => '((0 0) (1 1) (2 2) (3 3) (4 4) (5 5) (6 6) (7 7) (8 8) (9 9)) )
+
+
+; ==========================================================================
+; The examples from the SRFI document
+; ==========================================================================
+
+; from Abstract
+
+(my-check (list-ec (: i 5) (* i i)) => '(0 1 4 9 16))
+
+(my-check
+ (list-ec (: n 1 4) (: i n) (list n i))
+ => '((1 0) (2 0) (2 1) (3 0) (3 1) (3 2)) )
+
+; from Generators
+
+(my-check
+ (list-ec (: x (index i) "abc") (list x i))
+ => '((#\a 0) (#\b 1) (#\c 2)) )
+
+(my-check
+ (list-ec (:string c (index i) "a" "b") (cons c i))
+ => '((#\a . 0) (#\b . 1)) )
+
+
+; ==========================================================================
+; Little Shop of Horrors
+; ==========================================================================
+
+(my-check (list-ec (:range x 5) (:range x x) x) => '(0 0 1 0 1 2 0 1 2 3))
+
+(my-check (list-ec (:list x '(2 "23" (4))) (: y x) y) => '(0 1 #\2 #\3 4))
+
+(my-check
+ (list-ec (:parallel (:integers x)
+ (:do ((i 10)) (< x i) ((- i 1))))
+ (list x i))
+ => '((0 10) (1 9) (2 8) (3 7) (4 6)) )
+
+
+; ==========================================================================
+; Less artificial examples
+; ==========================================================================
+
+(define (factorial n) ; n * (n-1) * .. * 1 for n >= 0
+ (product-ec (:range k 2 (+ n 1)) k) )
+
+(my-check (factorial 0) => 1)
+(my-check (factorial 1) => 1)
+(my-check (factorial 3) => 6)
+(my-check (factorial 5) => 120)
+
+
+(define (eratosthenes n) ; primes in {2..n-1} for n >= 1
+ (let ((p? (make-string n #\1)))
+ (do-ec (:range k 2 n)
+ (if (char=? (string-ref p? k) #\1))
+ (:range i (* 2 k) n k)
+ (string-set! p? i #\0) )
+ (list-ec (:range k 2 n) (if (char=? (string-ref p? k) #\1)) k) ))
+
+(my-check
+ (eratosthenes 50)
+ => '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47) )
+
+(my-check
+ (length (eratosthenes 100000))
+ => 9592 ) ; we expect 10^5/ln(10^5)
+
+
+(define (pythagoras n) ; a, b, c s.t. 1 <= a <= b <= c <= n, a^2 + b^2 = c^2
+ (list-ec
+ (:let sqr-n (* n n))
+ (:range a 1 (+ n 1))
+; (begin (display a) (display " "))
+ (:let sqr-a (* a a))
+ (:range b a (+ n 1))
+ (:let sqr-c (+ sqr-a (* b b)))
+ (if (<= sqr-c sqr-n))
+ (:range c b (+ n 1))
+ (if (= (* c c) sqr-c))
+ (list a b c) ))
+
+(my-check
+ (pythagoras 15)
+ => '((3 4 5) (5 12 13) (6 8 10) (9 12 15)) )
+
+(my-check
+ (length (pythagoras 200))
+ => 127 )
+
+
+(define (qsort xs) ; stable
+ (if (null? xs)
+ '()
+ (let ((pivot (car xs)) (xrest (cdr xs)))
+ (append
+ (qsort (list-ec (:list x xrest) (if (< x pivot)) x))
+ (list pivot)
+ (qsort (list-ec (:list x xrest) (if (>= x pivot)) x)) ))))
+
+(my-check
+ (qsort '(1 5 4 2 4 5 3 2 1 3))
+ => '(1 1 2 2 3 3 4 4 5 5) )
+
+
+(define (pi-BBP m) ; approx. of pi within 16^-m (Bailey-Borwein-Plouffe)
+ (sum-ec
+ (:range n 0 (+ m 1))
+ (:let n8 (* 8 n))
+ (* (- (/ 4 (+ n8 1))
+ (+ (/ 2 (+ n8 4))
+ (/ 1 (+ n8 5))
+ (/ 1 (+ n8 6))))
+ (/ 1 (expt 16 n)) )))
+
+(my-check
+ (pi-BBP 5)
+ => (/ 40413742330349316707 12864093722915635200) )
+
+
+(define (read-line port) ; next line (incl. #\newline) of port
+ (let ((line
+ (string-ec
+ (:until (:port c port read-char)
+ (char=? c #\newline) )
+ c )))
+ (if (string=? line "")
+ (read-char port) ; eof-object
+ line )))
+
+(define (read-lines filename) ; list of all lines
+ (my-call-with-input-file
+ filename
+ (lambda (port)
+ (list-ec (:port line port read-line) line) )))
+
+(my-check
+ (begin
+ (let ((f (my-open-output-file "tmp1")))
+ (do-ec (:range n 10) (begin (write n f) (newline f)))
+ (close-output-port f))
+ (read-lines "tmp1") )
+ => (list-ec (:char-range c #\0 #\9) (string c #\newline)) )
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. release_1-9-12-129-gfdc8fd4,
Andy Wingo <=