Implement STREAM-APPEND-MAP. Use RECEIVE rather than

CALL-WITH-VALUES.

diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index 0fca3f7b1cd29a7197c28118582444da49e5998b..2dd9df6200e35ee2e43a6068077f4597a0b0f46a 100644 (file)
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.459 2003/09/24 19:21:55 cph Exp $
+$Id: runtime.pkg,v 14.460 2003/09/30 03:39:10 cph Exp $
 
 Copyright 1988,1989,1990,1991,1992,1993 Massachusetts Institute of Technology
 Copyright 1994,1995,1996,1997,1998,1999 Massachusetts Institute of Technology
@@ -3776,6 +3776,7 @@ USA.
          stream->list
          stream-accumulate
          stream-append
+         stream-append-map
          stream-car
          stream-cdr
          stream-filter

diff --git a/v7/src/runtime/stream.scm b/v7/src/runtime/stream.scm
index 4d46dfa04d2b6c330c401e77a3e769bdeaea8418..12356ce9faa8cf7d24e44d4ee6e7451d17768d7f 100644 (file)
--- a/v7/src/runtime/stream.scm
+++ b/v7/src/runtime/stream.scm
@@ -1,8 +1,9 @@
 #| -*-Scheme-*-
 
-$Id: stream.scm,v 14.15 2003/02/14 18:28:34 cph Exp $
+$Id: stream.scm,v 14.16 2003/09/30 03:39:03 cph Exp $
 
-Copyright (c) 1988-1999, 2002 Massachusetts Institute of Technology
+Copyright 1986,1987,1988,1989,1992,1995 Massachusetts Institute of Technology
+Copyright 1998,2003 Massachusetts Institute of Technology
 
 This file is part of MIT/GNU Scheme.
 
@@ -120,12 +121,11 @@ USA.
                '()))))
        (do-n
        (lambda (procedure streams)
-         (call-with-values (lambda () (split-streams streams 'STREAM-MAP))
-           (lambda (cars cdrs)
-             (if (null? cars)
-                 '()
-                 (cons (apply procedure cars)
-                       (delay (do-n procedure (map force cdrs))))))))))
+         (receive (cars cdrs) (split-streams streams 'STREAM-MAP)
+           (if (pair? cars)
+               (cons-stream (apply procedure cars)
+                            (do-n procedure (map force cdrs)))
+               '())))))
     (lambda (procedure stream . streams)
       (if (null? streams)
          ;; Kludge: accept arguments in old order.
@@ -145,13 +145,11 @@ USA.
                 (error:illegal-stream-element stream 'STREAM-FOR-EACH 1)))))
        (do-n
        (lambda (procedure streams)
-         (call-with-values
-             (lambda () (split-streams streams 'STREAM-FOR-EACH))
-           (lambda (cars cdrs)
-             (if (not (null? cars))
-                 (begin
-                   (apply procedure cars)
-                   (do-n procedure (map force cdrs)))))))))
+         (receive (cars cdrs) (split-streams streams 'STREAM-FOR-EACH)
+           (if (pair? cars)
+               (begin
+                 (apply procedure cars)
+                 (do-n procedure (map force cdrs))))))))
     (lambda (procedure stream . streams)
       (if (null? streams)
          (do-1 procedure stream)
@@ -161,8 +159,7 @@ USA.
   (let ((cars (list 'CARS))
        (cdrs (list 'CDRS)))
     (let loop ((streams streams) (cars-tail cars) (cdrs-tail cdrs) (n 0))
-      (if (null? streams)
-         (values (cdr cars) (cdr cdrs))
+      (if (pair? streams)
          (let ((stream (car streams)))
            (if (stream-pair? stream)
                (let ((cars-tail* (list (car stream)))
@@ -173,29 +170,56 @@ USA.
                (begin
                  (if (not (null? stream))
                      (error:illegal-stream-element stream operator n))
-                 (values '() '()))))))))
+                 (values '() '()))))
+         (values (cdr cars) (cdr cdrs))))))
 \f
-(define stream-append
+(define stream-append-map
   (letrec
-      ((outer-loop
-       (lambda (streams n)
-         (if (null? (cdr streams))
-             (car streams)
-             (inner-loop (car streams) (cdr streams) n))))
-       (inner-loop
-       (lambda (stream streams n)
+      ((do-1
+       (lambda (procedure stream)
          (if (stream-pair? stream)
-             (cons-stream (car stream)
-                          (inner-loop (force (cdr stream)) streams n))
+             (append (procedure (car stream))
+                     (delay (do-1 procedure (force (cdr stream)))))
              (begin
                (if (not (null? stream))
-                   (error:illegal-stream-element stream 'STREAM-APPEND n))
-               (outer-loop streams (fix:+ n 1)))))))
-    (lambda streams
+                   (error:illegal-stream-element stream 'STREAM-APPEND-MAP 1))
+               '()))))
+       (do-n
+       (lambda (procedure streams)
+         (receive (cars cdrs) (split-streams streams 'STREAM-APPEND-MAP)
+           (if (pair? cars)
+               (append (apply procedure cars)
+                       (delay (do-n procedure (map force cdrs))))
+               '()))))
+       (append
+       (lambda (s1 s2)
+         (let loop ((s s1))
+           (if (stream-pair? s)
+               (cons-stream (car s) (loop (force (cdr s))))
+               (begin
+                 (if (not (null? s))
+                     (error:illegal-stream-element s1 'STREAM-APPEND 0))
+                 (force s2)))))))
+    (lambda (procedure stream . streams)
       (if (null? streams)
-         '()
-         (outer-loop streams 0)))))
+         (do-1 procedure stream)
+         (do-n procedure (cons stream streams))))))
 
+(define (stream-append . streams)
+  (if (pair? streams)
+      (let outer-loop ((streams streams) (n 0))
+       (if (pair? (cdr streams))
+           (let inner-loop ((stream (car streams)))
+             (if (stream-pair? stream)
+                 (cons-stream (car stream)
+                              (inner-loop (force (cdr stream))))
+                 (begin
+                   (if (not (null? stream))
+                       (error:illegal-stream-element stream 'STREAM-APPEND n))
+                   (outer-loop (cdr streams) (fix:+ n 1)))))
+           (car streams)))
+      '()))
+\f
 (define (stream-accumulate procedure initial stream)
   (if (stream-pair? stream)
       (procedure (car stream)