~ chicken-core (chicken-5) 2a996096f5b8101a6b568a42f9795cf5123ca5f1
commit 2a996096f5b8101a6b568a42f9795cf5123ca5f1
Author: unknown <felix@.(none)>
AuthorDate: Wed Oct 21 09:30:43 2009 +0200
Commit: unknown <felix@.(none)>
CommitDate: Wed Oct 21 09:30:43 2009 +0200
line-terminators
diff --git a/chicken-setup.scm b/chicken-setup.scm
index 85087d0b..04bcfc4b 100644
--- a/chicken-setup.scm
+++ b/chicken-setup.scm
@@ -1,28 +1,28 @@
-;;;; chicken-setup.scm - stub application to overwrite old versions of this program on installation
-;
-; Copyright (c) 2009, The Chicken Team
-; All rights reserved.
-;
-; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
-; conditions are met:
-;
-; Redistributions of source code must retain the above copyright notice, this list of conditions and the following
-; disclaimer.
-; Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
-; disclaimer in the documentation and/or other materials provided with the distribution.
-; Neither the name of the author nor the names of its contributors may be used to endorse or promote
-; products derived from this software without specific prior written permission.
-;
-; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
-; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
-; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
-; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
-; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
-; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
-; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
-; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
-; POSSIBILITY OF SUCH DAMAGE.
-
-
-(print "This program is obsolete. Please use `chicken-install' instead.")
-(exit 1)
+;;;; chicken-setup.scm - stub application to overwrite old versions of this program on installation
+;
+; Copyright (c) 2009, The Chicken Team
+; All rights reserved.
+;
+; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
+; conditions are met:
+;
+; Redistributions of source code must retain the above copyright notice, this list of conditions and the following
+; disclaimer.
+; Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
+; disclaimer in the documentation and/or other materials provided with the distribution.
+; Neither the name of the author nor the names of its contributors may be used to endorse or promote
+; products derived from this software without specific prior written permission.
+;
+; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
+; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
+; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
+; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+; POSSIBILITY OF SUCH DAMAGE.
+
+
+(print "This program is obsolete. Please use `chicken-install' instead.")
+(exit 1)
diff --git a/misc/inline.scm b/misc/inline.scm
index 6be85cf9..524fe624 100644
--- a/misc/inline.scm
+++ b/misc/inline.scm
@@ -1,418 +1,418 @@
-;;; this assumes that :
-;;; a) nothing has been evaluated yet
-;;; b) basic syntactical correctness has been assured (so a list l starting
-;;; with 'define-inline will have the procedure-name as (caadr l) and
-;;; arity for all procedure calls is correct)
-;;; c) alpha substitution has occurred so all named symbols are guaranteed
-;;; unique across all procedures
-;;; d) optional, keyword, and rest arguments are not allowed for inline
-;;; procedures (although it should be possible to add them)
-
-;; beginning of the pass
-;; takes the ordered quoted list of all top-level statements
-;; ends by calling either
-;; inline-pass:final with the input list (if no inline procedures exist) and
-;; null, or
-;; inline-pass:graph-inline with two lists, the inline procedures (with some
-;; metadata) and all non-inline-procedure statements.
-(define (inline-pass:start qlst)
- (let find-inline ((q qlst) ; quoted top-level statements
- (i 0) ; index of inline procedure for later steps
- (l '()) ; inline procedures
- (r '())) ; non-inline statements
- (cond ((null? q)
- (if (= 0 i)
- (inline-pass:final (reverse r) '())
- (inline-pass:graph-inline i (reverse l) (reverse r))))
- ((and (list? (car q)) (eq? 'define-inline (caar q)))
- (find-inline
- (cdr q)
- (+ 1 i)
- (cons (cons (caadar q)
- (vector i 0 (cddar q) (cdadar q)))
- l)
- r))
- (else
- (find-inline (cdr q) i l (cons (car q) r))))))
-
-
-;; walks through a list
-;; takes a list, an index vector, and the metadata inline list from above
-;; ends by returning the (possibly modified) vector
-(define (inline-pass:walk l v ilst)
- (let walk ((l l)
- (t 0))
- (cond ((null? l)
- v)
- ((list? (car l))
- (cond ((null? (car l))
- (walk (cdr l) t))
- ((eq? 'quote (caar l))
- (or (= 0 t)
- (walk (cdar l) 3))
- (walk (cdr l) t))
- ((eq? 'quasiquote (caar l))
- (walk (cdar l) 2)
- (walk (cdr l) t))
- ((or (eq? 'unquote (caar l))
- (eq? 'unquote-splicing (caar l)))
- (walk (cdar l) 1)
- (walk (cdr l) t))
- (else
- (walk (car l) t)
- (walk (cdr l) t))))
- ((pair? (car l))
- (walk (unfold not-pair? car cdr (car l) list) t)
- (walk (cdr l) t))
- ((vector? (car l))
- (walk (vector->list (car l)) t)
- (walk (cdr l) t))
- ((not (symbol? (car l)))
- (walk (cdr l) t))
- ((> t 1)
- (walk (cdr l) t))
- ((alist-ref (car l) ilst) =>
- (lambda (d)
- (vector-set! v (vector-ref d 0) #t)
- (walk (cdr l) t)))
- (else
- (walk (cdr l) t)))))
-
-
-;; builds a graph of calls to inline procedures from inline procedures
-;; takes the inline-list-length, inline metadata list, and other statements
-;; ends by calling inline-pass:simplify1 with the graph and input args
-(define (inline-pass:graph-inline i ilst rlst)
- (inline-pass:simplify1
- (map
- (lambda (iv)
- (cons (car iv)
- (inline-pass:walk
- (vector-ref (cdr iv) 3)
- (make-vector i #f)
- ilst)))
- ilst)
- i ilst rlst))
-
-
-;; simplifies direct self-call, no further inline, and only-self cases
-;; takes the graph, inline list length, inline metadata list, and statements
-;; ends by calling either:
-;; inline-pass:simplify2 with the further inline, no-further-but-self inline,
-;; graph, inline length, all inline, and other statements, or
-;; inline-pass:final with the statements and inlines
-(define (inline-pass:simplify1 g i ilst rlst)
- (for-each
- (lambda (x)
- (and (vector-ref (cdr x) (car x))
- (vector-set! (cdr (list-ref ilst (car x))) 1 1)))
- g)
- (let simple ((h g) ; graph
- (l ilst) ; inline metadata
- (r '()) ; no further inlines (except possibly self)
- (s '())) ; further inlining
- (cond ((null? h)
- (if (null? s)
- (inline-pass:final rlst r)
- (inline-pass:simplify2 s r g i ilst rlst)))
- ((every (lambda (x i) (or (= i (caar h)) (not x)))
- (vector->list (cdar h)) (iota i))
- (simple (cdr h) (cdr l) (cons (car l) r) s))
- (else
- (simple (cdr h) (cdr l) r (cons (car l) s))))))
-
-;; substitutes in inlined procedures
-;; takes the procedure in which to do the substitution (as a list) and the
-;; list of inlined procedures with metadata
-;; ends with the new procedure-as-list
-;; note: there are four distinct cases -
-;; 1) inline procedure in application position, no self call :
-;; becomes a (begin ...) with the arguments set locally
-;; 2) inline procedure in application position, with self call :
-;; becomes a (let <name> (vars ...) ...)
-;; 3) inline procedure not in application position, no self call :
-;; becomes a (lambda (arglist) ...)
-;; 4) inline procedure not in application position, with self call :
-;; becomes a (lambda (arglist) (let <name> (vars ...) ...) with new
-;; symbols generated for arglist
-(define (inline-pass:subst1 l ilst)
- (let walk ((l l)
- (t 0))
- (cond ((null? l)
- l)
- ((vector? l)
- (list->vector (walk (vector->list l) t)))
- ((symbol? l)
- (cond ((> t 1)
- l)
- ((alist-ref l ilst) =>
- (lambda (d)
- (if (= 1 (vector-ref d 1))
- (let* ((a (map
- (lambda (x) (gensym 'ia))
- (vector-ref d 2)))
- (m (map
- (lambda (a x) (list a x))
- (vector-ref d 2) a)))
- `(lambda ,a (let ,l ,m
- ,@(vector-ref d 3))))
- `(lambda ,(vector-ref d 2)
- ,@(vector-ref d 3)))))
- (else
- l)))
- ((not (pair? l))
- l)
- ((list? (car l))
- (cond ((null? (car l))
- (cons (car l) (walk (cdr l) t)))
- ((not (symbol? (caar l)))
- (cons (walk (car l) t) (walk (cdr l) t)))
- ((eq? 'quote (caar l))
- (if (= t 0)
- (cons (car l) (walk (cdr l) t))
- (cons `(quote ,(walk (cadr l) 3))
- (walk (cdr l) t))))
- ((eq? 'quasiquote (caar l))
- (cons `(quasiquote ,(walk (cadr l) 2))
- (walk (cdr l) t)))
- ((or (eq? 'unquote (caar l))
- (eq? 'unquote-splicing (caar l)))
- (cons `(,(caar l) ,(walk (cadr l) 1))
- (walk (cdr l) t)))
- ((> t 1)
- (cons (walk (car l) t) (walk (cdr l) t)))
- ((alist-ref (caar l) ilst) =>
- (lambda (d)
- (cons
- (if (= 1 (vector-ref d 1))
- (let ((m (map
- (lambda (a x) (list a x))
- (vector-ref d 2)
- (walk (cdar l) t))))
- `(let ,(caar l) ,m
- ,@(vector-ref d 3)))
- `(begin
- ,@(map
- (lambda (a x)
- `(set-local! ,a ,x))
- (vector-ref d 2)
- (walk (cdar l) t))
- ,@(vector-ref d 3)))
- (walk (cdr l) t))))
- (else
- (cons (walk (car l) t) (walk (cdr l) t)))))
- ((pair? (car l))
- (cons (cons (walk (caar l) t) (walk (cdar l) t))
- (walk (cdr l) t)))
- ((vector? (car l))
- (cons (list->vector (walk (vector->list (car l)) t))
- (walk (cdr l) t)))
- ((not (symbol? (car l)))
- (cons (car l) (walk (cdr l) t)))
- ((> t 1)
- (cons (car l) (walk (cdr l) t)))
- ((alist-ref (car l) ilst) =>
- (lambda (d)
- (cons
- (if (= 1 (vector-ref d 1))
- (let* ((a (map
- (lambda (x) (gensym 'ia))
- (vector-ref d 2)))
- (m (map
- (lambda (a x) (list a x))
- (vector-ref d 2) a)))
- `(lambda ,a (let ,(car l) ,m
- ,@(vector-ref d 3))))
- `(lambda ,(vector-ref d 2) ,@(vector-ref d 3)))
- (walk (cdr l) t))))
- (else
- (cons (car l) (walk (cdr l) t))))))
-
-
-;; substitutes in inlined procedures with further processing
-;; takes the procedure in which to do the substitution (as a list), the
-;; list of inlined procedures with metadata, and a list of procedures to
-;; not treat as inline
-;; ends with the new procedure-as-list
-;; note: there are four distinct cases -
-;; 1) inline procedure in application position, no self call :
-;; becomes a (begin ...) with the arguments set locally
-;; 2) inline procedure in application position, with self call :
-;; becomes a (let <name> (vars ...) ...)
-;; 3) inline procedure not in application position, no self call :
-;; becomes a (lambda (arglist) ...)
-;; 4) inline procedure not in application position, with self call :
-;; becomes a (lambda (arglist) (let <name> (vars ...) ...) with new
-;; symbols generated for arglist
-(define (inline-pass:subst2 l ilst nof)
- (let walk ((l l)
- (n nof)
- (t 0))
- (cond ((null? l)
- l)
- ((vector? l)
- (list->vector (walk (vector->list l) t n)))
- ((symbol? l)
- (cond ((> t 1)
- l)
- ((memq l n) =>
- (lambda (m)
- (let ((d (alist-ref l ilst)))
- (if (= 1 (vector-ref d 1))
- l
- (begin
- (vector-set! d 1 1)
- (if (= 1 (length m))
- l
- (walk l t (cdr m))))))))
- ((alist-ref l ilst) =>
- (lambda (d)
- (if (= 1 (vector-ref d 1))
- (let* ((a (map
- (lambda (x) (gensym 'ia))
- (vector-ref d 2)))
- (m (map
- (lambda (a x) (list a x))
- (vector-ref d 2) a)))
- `(lambda ,a (let ,l ,m
- ,@(walk (vector-ref d 3) t
- (cons l n)))))
- `(lambda ,(vector-ref d 2)
- ,@(walk (vector-ref d 3) t
- (cons l n))))))
- (else
- l)))
- ((not (pair? l))
- l)
- ((list? (car l))
- (cond ((null? (car l))
- (cons (car l) (walk (cdr l) t n)))
- ((not (symbol? (caar l)))
- (cons (walk (car l) t n) (walk (cdr l) t n)))
- ((eq? 'quote (caar l))
- (if (= t 0)
- (cons (car l) (walk (cdr l) t n))
- (cons `(quote ,(walk (cadr l) 3 n))
- (walk (cdr l) t n))))
- ((eq? 'quasiquote (caar l))
- (cons `(quasiquote ,(walk (cadr l) 2 n))
- (walk (cdr l) t n)))
- ((or (eq? 'unquote (caar l))
- (eq? 'unquote-splicing (caar l)))
- (cons `(,(caar l) ,(walk (cadr l) 1 n))
- (walk (cdr l) t n)))
- ((> t 1)
- (cons (walk (car l) t n) (walk (cdr l) t n)))
- ((memq (caar l) n) =>
- (lambda (m)
- (let ((d (alist-ref (caar l) ilst)))
- (if (= 1 (vector-ref d 1))
- (cons (cons (caar l)
- (walk (cdar l) t n))
- (walk (cdr l) t n))
- (begin
- (vector-set! d 1 1)
- (if (= 1 (length m))
- (cons (cons (caar l)
- (walk (cdar l) t n))
- (walk (cdr l) t n))
- (walk l t
- (cdr m))))))))
- ((alist-ref (caar l) ilst) =>
- (lambda (d)
- (cons
- (if (= 1 (vector-ref d 1))
- (let ((m (map
- (lambda (a x) (list a x))
- (vector-ref d 2)
- (walk (cdar l) t
- (cons (caar l) n)))))
- `(let ,(caar l) ,m
- ,@(walk (vector-ref d 3) t
- (cons (caar l) n))))
- `(begin
- ,@(map
- (lambda (a x)
- `(set-local! ,a ,x))
- (vector-ref d 2)
- (walk (cdar l) t
- (cons (caar l) n)))
- ,@(walk (vector-ref d 3) t
- (cons (caar l) n))))
- (walk (cdr l) t n))))
- (else
- (cons (walk (car l) t n) (walk (cdr l) t n)))))
- ((pair? (car l))
- (cons (cons (walk (caar l) t n) (walk (cdar l) t n))
- (walk (cdr l) t n)))
- ((vector? (car l))
- (cons (list->vector (walk (vector->list (car l)) t n))
- (walk (cdr l) t n)))
- ((not (symbol? (car l)))
- (cons (car l) (walk (cdr l) t n)))
- ((> t 1)
- (cons (car l) (walk (cdr l) t)))
- ((memq (car l) n) =>
- (lambda (m)
- (let ((d (alist-ref (car l) ilst)))
- (if (= 1 (vector-ref d 1))
- (cons (car l) (walk (cdr l) t n))
- (begin
- (vector-set! d 1 1)
- (if (= 1 (length m))
- (cons (car l) (walk (cdr l) t n))
- (walk l t (cdr m))))))))
- ((alist-ref (car l) ilst) =>
- (lambda (d)
- (cons
- (if (= 1 (vector-ref d 1))
- (let* ((a (map
- (lambda (x) (gensym 'ia))
- (vector-ref d 2)))
- (m (map
- (lambda (a x) (list a x))
- (vector-ref d 2) a)))
- `(lambda ,a (let ,l ,m
- ,@(walk (vector-ref d 3) t
- (cons (car l) n)))))
- `(lambda ,(vector-ref d 2)
- ,@(walk (vector-ref d 3) t (cons (car l) n))))
- (walk (cdr l) t n))))
- (else
- (cons (car l) (walk (cdr l) t n))))))
-
-;; finds which inlined procedures are called from non-inlined procedures
-;; performs substitutions for all inline procedures
-;; takes the further inline procedures, no further inline procedures, graph,
-;; inlined procedures list, and statements list
-;; ends by calling inline-pass:final with the statements and inline procedures
-;; ready for substitution
-(define (inline-pass:simplify2 fur nof g ilst rlst)
- (for-each
- (lambda (x)
- (vector-set! (cdr x) 3
- (inline-pass:subst1 (vector-ref (cdr x) 3) nof)))
- fur)
- (let ((v (inline-pass:walk rlst (make-vector i #f) fur)))
- (for-each
- (lambda (x)
- (vector-set! (cdr x) 3
- (inline-pass:subst2 (vector-ref (cdr x) 3) ilst
- (list (car x)))))
- (vector-fold
- (lambda (i r x)
- (if x
- (cons (list-ref ilst i) r)
- r))
- '() v))
- (inline-pass:final rlst ilst)))
-
-
-;; inlines all procedures
-;; takes the list of statements and the list of inline procedures with metadata
-;; returns the list of statements with all procedures inlined
-(define (inline-pass:final rlst ilst)
- (if (null? ilst)
- rlst
- (inline-pass:subst1 rlst ilst)))
-
+;;; this assumes that :
+;;; a) nothing has been evaluated yet
+;;; b) basic syntactical correctness has been assured (so a list l starting
+;;; with 'define-inline will have the procedure-name as (caadr l) and
+;;; arity for all procedure calls is correct)
+;;; c) alpha substitution has occurred so all named symbols are guaranteed
+;;; unique across all procedures
+;;; d) optional, keyword, and rest arguments are not allowed for inline
+;;; procedures (although it should be possible to add them)
+
+;; beginning of the pass
+;; takes the ordered quoted list of all top-level statements
+;; ends by calling either
+;; inline-pass:final with the input list (if no inline procedures exist) and
+;; null, or
+;; inline-pass:graph-inline with two lists, the inline procedures (with some
+;; metadata) and all non-inline-procedure statements.
+(define (inline-pass:start qlst)
+ (let find-inline ((q qlst) ; quoted top-level statements
+ (i 0) ; index of inline procedure for later steps
+ (l '()) ; inline procedures
+ (r '())) ; non-inline statements
+ (cond ((null? q)
+ (if (= 0 i)
+ (inline-pass:final (reverse r) '())
+ (inline-pass:graph-inline i (reverse l) (reverse r))))
+ ((and (list? (car q)) (eq? 'define-inline (caar q)))
+ (find-inline
+ (cdr q)
+ (+ 1 i)
+ (cons (cons (caadar q)
+ (vector i 0 (cddar q) (cdadar q)))
+ l)
+ r))
+ (else
+ (find-inline (cdr q) i l (cons (car q) r))))))
+
+
+;; walks through a list
+;; takes a list, an index vector, and the metadata inline list from above
+;; ends by returning the (possibly modified) vector
+(define (inline-pass:walk l v ilst)
+ (let walk ((l l)
+ (t 0))
+ (cond ((null? l)
+ v)
+ ((list? (car l))
+ (cond ((null? (car l))
+ (walk (cdr l) t))
+ ((eq? 'quote (caar l))
+ (or (= 0 t)
+ (walk (cdar l) 3))
+ (walk (cdr l) t))
+ ((eq? 'quasiquote (caar l))
+ (walk (cdar l) 2)
+ (walk (cdr l) t))
+ ((or (eq? 'unquote (caar l))
+ (eq? 'unquote-splicing (caar l)))
+ (walk (cdar l) 1)
+ (walk (cdr l) t))
+ (else
+ (walk (car l) t)
+ (walk (cdr l) t))))
+ ((pair? (car l))
+ (walk (unfold not-pair? car cdr (car l) list) t)
+ (walk (cdr l) t))
+ ((vector? (car l))
+ (walk (vector->list (car l)) t)
+ (walk (cdr l) t))
+ ((not (symbol? (car l)))
+ (walk (cdr l) t))
+ ((> t 1)
+ (walk (cdr l) t))
+ ((alist-ref (car l) ilst) =>
+ (lambda (d)
+ (vector-set! v (vector-ref d 0) #t)
+ (walk (cdr l) t)))
+ (else
+ (walk (cdr l) t)))))
+
+
+;; builds a graph of calls to inline procedures from inline procedures
+;; takes the inline-list-length, inline metadata list, and other statements
+;; ends by calling inline-pass:simplify1 with the graph and input args
+(define (inline-pass:graph-inline i ilst rlst)
+ (inline-pass:simplify1
+ (map
+ (lambda (iv)
+ (cons (car iv)
+ (inline-pass:walk
+ (vector-ref (cdr iv) 3)
+ (make-vector i #f)
+ ilst)))
+ ilst)
+ i ilst rlst))
+
+
+;; simplifies direct self-call, no further inline, and only-self cases
+;; takes the graph, inline list length, inline metadata list, and statements
+;; ends by calling either:
+;; inline-pass:simplify2 with the further inline, no-further-but-self inline,
+;; graph, inline length, all inline, and other statements, or
+;; inline-pass:final with the statements and inlines
+(define (inline-pass:simplify1 g i ilst rlst)
+ (for-each
+ (lambda (x)
+ (and (vector-ref (cdr x) (car x))
+ (vector-set! (cdr (list-ref ilst (car x))) 1 1)))
+ g)
+ (let simple ((h g) ; graph
+ (l ilst) ; inline metadata
+ (r '()) ; no further inlines (except possibly self)
+ (s '())) ; further inlining
+ (cond ((null? h)
+ (if (null? s)
+ (inline-pass:final rlst r)
+ (inline-pass:simplify2 s r g i ilst rlst)))
+ ((every (lambda (x i) (or (= i (caar h)) (not x)))
+ (vector->list (cdar h)) (iota i))
+ (simple (cdr h) (cdr l) (cons (car l) r) s))
+ (else
+ (simple (cdr h) (cdr l) r (cons (car l) s))))))
+
+;; substitutes in inlined procedures
+;; takes the procedure in which to do the substitution (as a list) and the
+;; list of inlined procedures with metadata
+;; ends with the new procedure-as-list
+;; note: there are four distinct cases -
+;; 1) inline procedure in application position, no self call :
+;; becomes a (begin ...) with the arguments set locally
+;; 2) inline procedure in application position, with self call :
+;; becomes a (let <name> (vars ...) ...)
+;; 3) inline procedure not in application position, no self call :
+;; becomes a (lambda (arglist) ...)
+;; 4) inline procedure not in application position, with self call :
+;; becomes a (lambda (arglist) (let <name> (vars ...) ...) with new
+;; symbols generated for arglist
+(define (inline-pass:subst1 l ilst)
+ (let walk ((l l)
+ (t 0))
+ (cond ((null? l)
+ l)
+ ((vector? l)
+ (list->vector (walk (vector->list l) t)))
+ ((symbol? l)
+ (cond ((> t 1)
+ l)
+ ((alist-ref l ilst) =>
+ (lambda (d)
+ (if (= 1 (vector-ref d 1))
+ (let* ((a (map
+ (lambda (x) (gensym 'ia))
+ (vector-ref d 2)))
+ (m (map
+ (lambda (a x) (list a x))
+ (vector-ref d 2) a)))
+ `(lambda ,a (let ,l ,m
+ ,@(vector-ref d 3))))
+ `(lambda ,(vector-ref d 2)
+ ,@(vector-ref d 3)))))
+ (else
+ l)))
+ ((not (pair? l))
+ l)
+ ((list? (car l))
+ (cond ((null? (car l))
+ (cons (car l) (walk (cdr l) t)))
+ ((not (symbol? (caar l)))
+ (cons (walk (car l) t) (walk (cdr l) t)))
+ ((eq? 'quote (caar l))
+ (if (= t 0)
+ (cons (car l) (walk (cdr l) t))
+ (cons `(quote ,(walk (cadr l) 3))
+ (walk (cdr l) t))))
+ ((eq? 'quasiquote (caar l))
+ (cons `(quasiquote ,(walk (cadr l) 2))
+ (walk (cdr l) t)))
+ ((or (eq? 'unquote (caar l))
+ (eq? 'unquote-splicing (caar l)))
+ (cons `(,(caar l) ,(walk (cadr l) 1))
+ (walk (cdr l) t)))
+ ((> t 1)
+ (cons (walk (car l) t) (walk (cdr l) t)))
+ ((alist-ref (caar l) ilst) =>
+ (lambda (d)
+ (cons
+ (if (= 1 (vector-ref d 1))
+ (let ((m (map
+ (lambda (a x) (list a x))
+ (vector-ref d 2)
+ (walk (cdar l) t))))
+ `(let ,(caar l) ,m
+ ,@(vector-ref d 3)))
+ `(begin
+ ,@(map
+ (lambda (a x)
+ `(set-local! ,a ,x))
+ (vector-ref d 2)
+ (walk (cdar l) t))
+ ,@(vector-ref d 3)))
+ (walk (cdr l) t))))
+ (else
+ (cons (walk (car l) t) (walk (cdr l) t)))))
+ ((pair? (car l))
+ (cons (cons (walk (caar l) t) (walk (cdar l) t))
+ (walk (cdr l) t)))
+ ((vector? (car l))
+ (cons (list->vector (walk (vector->list (car l)) t))
+ (walk (cdr l) t)))
+ ((not (symbol? (car l)))
+ (cons (car l) (walk (cdr l) t)))
+ ((> t 1)
+ (cons (car l) (walk (cdr l) t)))
+ ((alist-ref (car l) ilst) =>
+ (lambda (d)
+ (cons
+ (if (= 1 (vector-ref d 1))
+ (let* ((a (map
+ (lambda (x) (gensym 'ia))
+ (vector-ref d 2)))
+ (m (map
+ (lambda (a x) (list a x))
+ (vector-ref d 2) a)))
+ `(lambda ,a (let ,(car l) ,m
+ ,@(vector-ref d 3))))
+ `(lambda ,(vector-ref d 2) ,@(vector-ref d 3)))
+ (walk (cdr l) t))))
+ (else
+ (cons (car l) (walk (cdr l) t))))))
+
+
+;; substitutes in inlined procedures with further processing
+;; takes the procedure in which to do the substitution (as a list), the
+;; list of inlined procedures with metadata, and a list of procedures to
+;; not treat as inline
+;; ends with the new procedure-as-list
+;; note: there are four distinct cases -
+;; 1) inline procedure in application position, no self call :
+;; becomes a (begin ...) with the arguments set locally
+;; 2) inline procedure in application position, with self call :
+;; becomes a (let <name> (vars ...) ...)
+;; 3) inline procedure not in application position, no self call :
+;; becomes a (lambda (arglist) ...)
+;; 4) inline procedure not in application position, with self call :
+;; becomes a (lambda (arglist) (let <name> (vars ...) ...) with new
+;; symbols generated for arglist
+(define (inline-pass:subst2 l ilst nof)
+ (let walk ((l l)
+ (n nof)
+ (t 0))
+ (cond ((null? l)
+ l)
+ ((vector? l)
+ (list->vector (walk (vector->list l) t n)))
+ ((symbol? l)
+ (cond ((> t 1)
+ l)
+ ((memq l n) =>
+ (lambda (m)
+ (let ((d (alist-ref l ilst)))
+ (if (= 1 (vector-ref d 1))
+ l
+ (begin
+ (vector-set! d 1 1)
+ (if (= 1 (length m))
+ l
+ (walk l t (cdr m))))))))
+ ((alist-ref l ilst) =>
+ (lambda (d)
+ (if (= 1 (vector-ref d 1))
+ (let* ((a (map
+ (lambda (x) (gensym 'ia))
+ (vector-ref d 2)))
+ (m (map
+ (lambda (a x) (list a x))
+ (vector-ref d 2) a)))
+ `(lambda ,a (let ,l ,m
+ ,@(walk (vector-ref d 3) t
+ (cons l n)))))
+ `(lambda ,(vector-ref d 2)
+ ,@(walk (vector-ref d 3) t
+ (cons l n))))))
+ (else
+ l)))
+ ((not (pair? l))
+ l)
+ ((list? (car l))
+ (cond ((null? (car l))
+ (cons (car l) (walk (cdr l) t n)))
+ ((not (symbol? (caar l)))
+ (cons (walk (car l) t n) (walk (cdr l) t n)))
+ ((eq? 'quote (caar l))
+ (if (= t 0)
+ (cons (car l) (walk (cdr l) t n))
+ (cons `(quote ,(walk (cadr l) 3 n))
+ (walk (cdr l) t n))))
+ ((eq? 'quasiquote (caar l))
+ (cons `(quasiquote ,(walk (cadr l) 2 n))
+ (walk (cdr l) t n)))
+ ((or (eq? 'unquote (caar l))
+ (eq? 'unquote-splicing (caar l)))
+ (cons `(,(caar l) ,(walk (cadr l) 1 n))
+ (walk (cdr l) t n)))
+ ((> t 1)
+ (cons (walk (car l) t n) (walk (cdr l) t n)))
+ ((memq (caar l) n) =>
+ (lambda (m)
+ (let ((d (alist-ref (caar l) ilst)))
+ (if (= 1 (vector-ref d 1))
+ (cons (cons (caar l)
+ (walk (cdar l) t n))
+ (walk (cdr l) t n))
+ (begin
+ (vector-set! d 1 1)
+ (if (= 1 (length m))
+ (cons (cons (caar l)
+ (walk (cdar l) t n))
+ (walk (cdr l) t n))
+ (walk l t
+ (cdr m))))))))
+ ((alist-ref (caar l) ilst) =>
+ (lambda (d)
+ (cons
+ (if (= 1 (vector-ref d 1))
+ (let ((m (map
+ (lambda (a x) (list a x))
+ (vector-ref d 2)
+ (walk (cdar l) t
+ (cons (caar l) n)))))
+ `(let ,(caar l) ,m
+ ,@(walk (vector-ref d 3) t
+ (cons (caar l) n))))
+ `(begin
+ ,@(map
+ (lambda (a x)
+ `(set-local! ,a ,x))
+ (vector-ref d 2)
+ (walk (cdar l) t
+ (cons (caar l) n)))
+ ,@(walk (vector-ref d 3) t
+ (cons (caar l) n))))
+ (walk (cdr l) t n))))
+ (else
+ (cons (walk (car l) t n) (walk (cdr l) t n)))))
+ ((pair? (car l))
+ (cons (cons (walk (caar l) t n) (walk (cdar l) t n))
+ (walk (cdr l) t n)))
+ ((vector? (car l))
+ (cons (list->vector (walk (vector->list (car l)) t n))
+ (walk (cdr l) t n)))
+ ((not (symbol? (car l)))
+ (cons (car l) (walk (cdr l) t n)))
+ ((> t 1)
+ (cons (car l) (walk (cdr l) t)))
+ ((memq (car l) n) =>
+ (lambda (m)
+ (let ((d (alist-ref (car l) ilst)))
+ (if (= 1 (vector-ref d 1))
+ (cons (car l) (walk (cdr l) t n))
+ (begin
+ (vector-set! d 1 1)
+ (if (= 1 (length m))
+ (cons (car l) (walk (cdr l) t n))
+ (walk l t (cdr m))))))))
+ ((alist-ref (car l) ilst) =>
+ (lambda (d)
+ (cons
+ (if (= 1 (vector-ref d 1))
+ (let* ((a (map
+ (lambda (x) (gensym 'ia))
+ (vector-ref d 2)))
+ (m (map
+ (lambda (a x) (list a x))
+ (vector-ref d 2) a)))
+ `(lambda ,a (let ,l ,m
+ ,@(walk (vector-ref d 3) t
+ (cons (car l) n)))))
+ `(lambda ,(vector-ref d 2)
+ ,@(walk (vector-ref d 3) t (cons (car l) n))))
+ (walk (cdr l) t n))))
+ (else
+ (cons (car l) (walk (cdr l) t n))))))
+
+;; finds which inlined procedures are called from non-inlined procedures
+;; performs substitutions for all inline procedures
+;; takes the further inline procedures, no further inline procedures, graph,
+;; inlined procedures list, and statements list
+;; ends by calling inline-pass:final with the statements and inline procedures
+;; ready for substitution
+(define (inline-pass:simplify2 fur nof g ilst rlst)
+ (for-each
+ (lambda (x)
+ (vector-set! (cdr x) 3
+ (inline-pass:subst1 (vector-ref (cdr x) 3) nof)))
+ fur)
+ (let ((v (inline-pass:walk rlst (make-vector i #f) fur)))
+ (for-each
+ (lambda (x)
+ (vector-set! (cdr x) 3
+ (inline-pass:subst2 (vector-ref (cdr x) 3) ilst
+ (list (car x)))))
+ (vector-fold
+ (lambda (i r x)
+ (if x
+ (cons (list-ref ilst i) r)
+ r))
+ '() v))
+ (inline-pass:final rlst ilst)))
+
+
+;; inlines all procedures
+;; takes the list of statements and the list of inline procedures with metadata
+;; returns the list of statements with all procedures inlined
+(define (inline-pass:final rlst ilst)
+ (if (null? ilst)
+ rlst
+ (inline-pass:subst1 rlst ilst)))
+
diff --git a/misc/manual.css b/misc/manual.css
index 786b36e1..238d3455 100644
--- a/misc/manual.css
+++ b/misc/manual.css
@@ -1,33 +1,33 @@
-/* manual.css - Stylesheet for HTML manual */
-
-
-CODE {
- color: #666666;
-}
-
-a:link {
- color: #336;
-}
-
-a:visited { color: #666; }
-
-a:active { color: #966; }
-
-a:hover { color: #669; }
-
-body {
- background: #fff;
- color: #000;
- font: 9pt "Lucida Grande", "Verdana", sans-serif;
- margin: 8em;
-}
-
-TABLE {
- font: 9pt "Lucida Grande", "Verdana", sans-serif;
-}
-
-H3 {
- color: #113;
-}
-
-PRE { font-family: "Andale Mono", monospace; }
+/* manual.css - Stylesheet for HTML manual */
+
+
+CODE {
+ color: #666666;
+}
+
+a:link {
+ color: #336;
+}
+
+a:visited { color: #666; }
+
+a:active { color: #966; }
+
+a:hover { color: #669; }
+
+body {
+ background: #fff;
+ color: #000;
+ font: 9pt "Lucida Grande", "Verdana", sans-serif;
+ margin: 8em;
+}
+
+TABLE {
+ font: 9pt "Lucida Grande", "Verdana", sans-serif;
+}
+
+H3 {
+ color: #113;
+}
+
+PRE { font-family: "Andale Mono", monospace; }
diff --git a/patches/finalizer-closures.diff b/patches/finalizer-closures.diff
index f209c0a5..963d3bd1 100644
--- a/patches/finalizer-closures.diff
+++ b/patches/finalizer-closures.diff
@@ -1,8 +1,8 @@
-Index: runtime.c
-===================================================================
---- runtime.c (Revision 12825)
-+++ runtime.c (Revision 12869)
-@@ -2701,10 +2701,15 @@
+Index: runtime.c
+===================================================================
+--- runtime.c (Revision 12825)
++++ runtime.c (Revision 12869)
+@@ -2701,10 +2701,15 @@
/* Mark collectibles: */
for(msp = collectibles; msp < collectibles_top; ++msp)
if(*msp != NULL) mark(*msp);
@@ -19,7 +19,7 @@ Index: runtime.c
mark_system_globals();
}
else {
-@@ -2769,7 +2774,6 @@
+@@ -2769,7 +2774,6 @@
for(flist = finalizer_list; flist != NULL; flist = flist->next) {
mark(&flist->item);
@@ -27,7 +27,7 @@ Index: runtime.c
++fcount;
}
-@@ -2786,7 +2790,6 @@
+@@ -2786,7 +2790,6 @@
}
mark(&flist->item);
@@ -35,7 +35,7 @@ Index: runtime.c
}
}
-@@ -2794,7 +2797,7 @@
+@@ -2794,7 +2797,7 @@
finalizers_checked = 1;
if(pending_finalizer_count > 0 && gc_report_flag)
@@ -44,7 +44,7 @@ Index: runtime.c
pending_finalizer_count, live_finalizer_count);
goto rescan;
-@@ -2803,7 +2806,7 @@
+@@ -2803,7 +2806,7 @@
/* Copy finalized items with remembered indices into `##sys#pending-finalizers'
(and release finalizer node): */
if(pending_finalizer_count > 0) {
diff --git a/scripts/README b/scripts/README
index 09c6e87e..0905509c 100644
--- a/scripts/README
+++ b/scripts/README
@@ -1,44 +1,44 @@
-README for scripts/
-===================
-
-
-This directory contains a couple of things that might be useful:
-
- scheme
-
- A wrapper sh(1) script that allows automatic compilation of Scheme
- scripts. If you precede a Scheme file with a header line like this
-
- #!/usr/bin/env scheme
-
- then a compiled version of the code will be stored in $HOME/.cache
- and executed, instead of the original source file.
-
- tools.scm
-
- Helper functions for some of the scripts here.
-
- test-dist.sh
-
- Takes a platform-designator and the path to a tarball and unpacks,
- builds and tests the chicken distribution contained therein.
-
- wiki2html.scm
-
- A simple svnwiki -> HTML translator used for the manual. Needs
- `htmlprag' and `matchable' eggs installed.
-
- make-egg-index.scm
-
- Creates an egg index HTML page from a local working copy of a
- `release/<number>' egg tree.
-
- makedist.scm
-
- Creates a distribution tarball from a chicken svn checkout.
-
- henrietta.scm
- henrietta.cgi
-
- A CGI script and sub-program that serves eggs from a local tree
- or via svn over HTTP.
+README for scripts/
+===================
+
+
+This directory contains a couple of things that might be useful:
+
+ scheme
+
+ A wrapper sh(1) script that allows automatic compilation of Scheme
+ scripts. If you precede a Scheme file with a header line like this
+
+ #!/usr/bin/env scheme
+
+ then a compiled version of the code will be stored in $HOME/.cache
+ and executed, instead of the original source file.
+
+ tools.scm
+
+ Helper functions for some of the scripts here.
+
+ test-dist.sh
+
+ Takes a platform-designator and the path to a tarball and unpacks,
+ builds and tests the chicken distribution contained therein.
+
+ wiki2html.scm
+
+ A simple svnwiki -> HTML translator used for the manual. Needs
+ `htmlprag' and `matchable' eggs installed.
+
+ make-egg-index.scm
+
+ Creates an egg index HTML page from a local working copy of a
+ `release/<number>' egg tree.
+
+ makedist.scm
+
+ Creates a distribution tarball from a chicken svn checkout.
+
+ henrietta.scm
+ henrietta.cgi
+
+ A CGI script and sub-program that serves eggs from a local tree
+ or via svn over HTTP.
diff --git a/tests/ec-tests.scm b/tests/ec-tests.scm
index 1ab7f68d..87704379 100644
--- a/tests/ec-tests.scm
+++ b/tests/ec-tests.scm
@@ -1,652 +1,652 @@
-; <PLAINTEXT>
-; Examples for Eager Comprehensions in [outer..inner|expr]-Convention
-; ===================================================================
-;
-; sebastian.egner@philips.com, Eindhoven, The Netherlands, 26-Dec-2007.
-; Scheme R5RS (incl. macros), SRFI-23 (error).
-;
-; Running the examples in Scheme48 (version 1.1):
-; ,open srfi-23
-; ,load ec.scm
-; (define my-open-output-file open-output-file)
-; (define my-call-with-input-file call-with-input-file)
-; ,load examples.scm
-;
-; Running the examples in PLT/DrScheme (version 317):
-; (load "ec.scm")
-; (define (my-open-output-file filename)
-; (open-output-file filename 'replace 'text) )
-; (define (my-call-with-input-file filename thunk)
-; (call-with-input-file filename thunk 'text) )
-; (load "examples.scm")
-;
-; Running the examples in SCM (version 5d7):
-; (require 'macro) (require 'record)
-; (load "ec.scm")
-; (define my-open-output-file open-output-file)
-; (define my-call-with-input-file call-with-input-file)
-; (load "examples.scm")
-
-(import ec)
-
-
-(define my-open-output-file open-output-file)
-(define my-call-with-input-file call-with-input-file)
-
-
-; 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 my-check-correct 0)
-(define my-check-wrong 0)
-
-(define-syntax my-check
- (syntax-rules (=>)
- ((my-check ec => desired-result)
- (begin
- (newline)
- (write (quote ec))
- (newline)
- (let ((actual-result ec))
- (display " => ")
- (write actual-result)
- (if (my-equal? actual-result desired-result)
- (begin
- (display " ; correct")
- (set! my-check-correct (+ my-check-correct 1)) )
- (begin
- (display " ; *** wrong ***, desired result:")
- (newline)
- (display " => ")
- (write desired-result)
- (set! my-check-wrong (+ my-check-wrong 1)) ))
- (newline) )))))
-
-
-; ==========================================================================
-; 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 sunnan@handgranat.org 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)) )
-
-
-; ==========================================================================
-; Summary
-; ==========================================================================
-
-(begin
- (newline)
- (newline)
- (display "correct examples : ")
- (display my-check-correct)
- (newline)
- (display "wrong examples : ")
- (display my-check-wrong)
- (newline)
- (newline) )
+; <PLAINTEXT>
+; Examples for Eager Comprehensions in [outer..inner|expr]-Convention
+; ===================================================================
+;
+; sebastian.egner@philips.com, Eindhoven, The Netherlands, 26-Dec-2007.
+; Scheme R5RS (incl. macros), SRFI-23 (error).
+;
+; Running the examples in Scheme48 (version 1.1):
+; ,open srfi-23
+; ,load ec.scm
+; (define my-open-output-file open-output-file)
+; (define my-call-with-input-file call-with-input-file)
+; ,load examples.scm
+;
+; Running the examples in PLT/DrScheme (version 317):
+; (load "ec.scm")
+; (define (my-open-output-file filename)
+; (open-output-file filename 'replace 'text) )
+; (define (my-call-with-input-file filename thunk)
+; (call-with-input-file filename thunk 'text) )
+; (load "examples.scm")
+;
+; Running the examples in SCM (version 5d7):
+; (require 'macro) (require 'record)
+; (load "ec.scm")
+; (define my-open-output-file open-output-file)
+; (define my-call-with-input-file call-with-input-file)
+; (load "examples.scm")
+
+(import ec)
+
+
+(define my-open-output-file open-output-file)
+(define my-call-with-input-file call-with-input-file)
+
+
+; 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 my-check-correct 0)
+(define my-check-wrong 0)
+
+(define-syntax my-check
+ (syntax-rules (=>)
+ ((my-check ec => desired-result)
+ (begin
+ (newline)
+ (write (quote ec))
+ (newline)
+ (let ((actual-result ec))
+ (display " => ")
+ (write actual-result)
+ (if (my-equal? actual-result desired-result)
+ (begin
+ (display " ; correct")
+ (set! my-check-correct (+ my-check-correct 1)) )
+ (begin
+ (display " ; *** wrong ***, desired result:")
+ (newline)
+ (display " => ")
+ (write desired-result)
+ (set! my-check-wrong (+ my-check-wrong 1)) ))
+ (newline) )))))
+
+
+; ==========================================================================
+; 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 sunnan@handgranat.org 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)) )
+
+
+; ==========================================================================
+; Summary
+; ==========================================================================
+
+(begin
+ (newline)
+ (newline)
+ (display "correct examples : ")
+ (display my-check-correct)
+ (newline)
+ (display "wrong examples : ")
+ (display my-check-wrong)
+ (newline)
+ (newline) )
diff --git a/tests/reexport-tests.scm b/tests/reexport-tests.scm
index ef19a63a..ff0fb14f 100644
--- a/tests/reexport-tests.scm
+++ b/tests/reexport-tests.scm
@@ -1,38 +1,38 @@
-;;;; reexport-tests.scm
-
-
-(module r4rs ()
- (import scheme chicken)
- (reexport
- (except scheme
- dynamic-wind values call-with-values eval scheme-report-environment
- null-environment interaction-environment)))
-
-(module m1 ()
- (import r4rs)
- (display (+ 3 4))
- (newline))
-
-(assert
- (not
- (handle-exceptions ex #f
- (eval '(module m2 ()
- (import r4rs)
- (values 123))))))
-
-(define-syntax compound-module
- (syntax-rules ()
- ((_ name imp ...)
- (module name ()
- (import scheme)
- (reexport imp ...)))))
-
-(compound-module
- big-chicken
- chicken ports files extras data-structures)
-
-(require-library extras data-structures)
-
-(module m3 ()
- (import scheme big-chicken)
- (pp (string-intersperse '("abc" "def" "ghi") "-")))
+;;;; reexport-tests.scm
+
+
+(module r4rs ()
+ (import scheme chicken)
+ (reexport
+ (except scheme
+ dynamic-wind values call-with-values eval scheme-report-environment
+ null-environment interaction-environment)))
+
+(module m1 ()
+ (import r4rs)
+ (display (+ 3 4))
+ (newline))
+
+(assert
+ (not
+ (handle-exceptions ex #f
+ (eval '(module m2 ()
+ (import r4rs)
+ (values 123))))))
+
+(define-syntax compound-module
+ (syntax-rules ()
+ ((_ name imp ...)
+ (module name ()
+ (import scheme)
+ (reexport imp ...)))))
+
+(compound-module
+ big-chicken
+ chicken ports files extras data-structures)
+
+(require-library extras data-structures)
+
+(module m3 ()
+ (import scheme big-chicken)
+ (pp (string-intersperse '("abc" "def" "ghi") "-")))
Trap