From: Andreas Rottmann Subject: 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. --- 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(-) 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 188a71c..109756a 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 @@ -3863,6 +3864,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 +;; . + +;;; 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 @@ +; +; 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..7de316d --- /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-67) + #:use-module (test-suite lib) + #:use-module (srfi srfi-42) + #:use-module (srfi srfi-67)) + +; 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)) ) -- tg: (3300286..) t/srfi-42 (depends on: master)