Be more aggressive about dropping pointers to streams when traversing

them.  Provide more accurate error messages for malformed streams.

diff --git a/v7/src/runtime/make.scm b/v7/src/runtime/make.scm
index a32e8e03794a67266e222840ae4a91e5fa7c2f40..3e0399dfcfddbdbcbd7f1060830842d628645639 100644 (file)
--- a/v7/src/runtime/make.scm
+++ b/v7/src/runtime/make.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: make.scm,v 14.61 1998/02/11 05:16:46 cph Exp $
+$Id: make.scm,v 14.62 1998/04/01 08:16:28 cph Exp $
 
 Copyright (c) 1988-98 Massachusetts Institute of Technology
 
@@ -441,6 +441,7 @@ MIT in each case. |#
    ((RUNTIME GENERIC-PROCEDURE) INITIALIZE-CONDITIONS! #t)
    ((RUNTIME GENERIC-PROCEDURE MULTIPLEXER) INITIALIZE-CONDITIONS! #t)
    ((RUNTIME RECORD-SLOT-ACCESS) INITIALIZE-CONDITIONS! #t)
+   ((RUNTIME STREAM) INITIALIZE-CONDITIONS! #t)
    ;; System dependent stuff
    (() INITIALIZE-SYSTEM-PRIMITIVES! #f)
    ;; Threads

diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index 5b9e4d721e73f6e8a376e19d2a20d4ea9ea6692b..79af2341b19ad7701b93aff199d771d10a2a9f20 100644 (file)
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.295 1998/03/09 03:44:11 cph Exp $
+$Id: runtime.pkg,v 14.296 1998/04/01 08:16:15 cph Exp $
 
 Copyright (c) 1988-98 Massachusetts Institute of Technology
 
@@ -784,6 +784,9 @@ MIT in each case. |#
          dynamic-handler-frames)
   (export (runtime debugger)
          continue-from-derived-thread-error)
+  (export (runtime stream)
+         ordinal-number-string
+         write-operator)
   (initialization (initialize-package!)))
 
 (define-package (runtime event-distributor)
@@ -2978,9 +2981,11 @@ MIT in each case. |#
   (files "stream")
   (parent ())
   (export ()
+         condition-type:illegal-stream-element
          empty-stream?
          head
          list->stream
+         make-prime-numbers-stream
          prime-numbers-stream
          stream
          stream->list

diff --git a/v7/src/runtime/stream.scm b/v7/src/runtime/stream.scm
index 87e0c2bb47bf6d22d56acaa2025019aa3cfe06d2..1d4a4cbe2bf6bbd7ef54e4d96f096cc14bd91964 100644 (file)
--- a/v7/src/runtime/stream.scm
+++ b/v7/src/runtime/stream.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: stream.scm,v 14.10 1998/03/31 20:04:18 cph Exp $
+$Id: stream.scm,v 14.11 1998/04/01 08:16:01 cph Exp $
 
 Copyright (c) 1988-98 Massachusetts Institute of Technology
 
@@ -62,14 +62,18 @@ MIT in each case. |#
 (define (stream . list)
   (list->stream list))
 
-(define (stream-length stream)
-  (let loop ((stream stream) (length 0))
-    (if (stream-pair? stream)
-       (loop (force (cdr stream)) (+ length 1))
-       (begin
-         (if (not (null? stream))
-             (error:wrong-type-argument stream "stream" 'STREAM-LENGTH))
-         length))))
+(define stream-length
+  (letrec
+      ((loop
+       (lambda (stream length)
+         (if (stream-pair? stream)
+             (loop (force (cdr stream)) (+ length 1))
+             (begin
+               (if (not (null? stream))
+                   (error:illegal-stream-element stream 'STREAM-LENGTH 0))
+               length)))))
+    (lambda (stream)
+      (loop stream 0))))
 
 (define (stream-ref stream index)
   (let ((tail (stream-tail stream index)))
@@ -77,143 +81,169 @@ MIT in each case. |#
        (error:bad-range-argument index 'STREAM-REF))
     (car tail)))
 
-(define (stream-head stream index)
-  (if (not (exact-nonnegative-integer? index))
-      (error:wrong-type-argument index
-                                "exact nonnegative integer"
-                                'STREAM-HEAD))
-  (let loop ((stream stream) (index index))
-    (if (= 0 index)
-       '()
-       (begin
-         (if (not (stream-pair? stream))
-             (error:bad-range-argument index 'STREAM-HEAD))
-         (cons (car stream)
-               (loop (force (cdr stream)) (- index 1)))))))
+(define stream-head
+  (letrec
+      ((loop
+       (lambda (stream index)
+         (if (= 0 index)
+             '()
+             (begin
+               (if (not (stream-pair? stream))
+                   (error:bad-range-argument index 'STREAM-HEAD))
+               (cons (car stream)
+                     (loop (force (cdr stream)) (- index 1))))))))
+    (lambda (stream index)
+      (if (not (exact-nonnegative-integer? index))
+         (error:wrong-type-argument index
+                                    "exact nonnegative integer"
+                                    'STREAM-HEAD))
+      (loop stream index))))
 
-(define (stream-tail stream index)
-  (if (not (exact-nonnegative-integer? index))
-      (error:wrong-type-argument index
-                                "exact nonnegative integer"
-                                'STREAM-TAIL))
-  (let loop ((stream stream) (index index))
-    (if (= 0 index)
-       stream
-       (begin
-         (if (not (stream-pair? stream))
-             (error:bad-range-argument index 'STREAM-TAIL))
-         (loop (force (cdr stream)) (- index 1))))))
+(define stream-tail
+  (letrec
+      ((loop
+       (lambda (stream index)
+         (if (= 0 index)
+             stream
+             (begin
+               (if (not (stream-pair? stream))
+                   (error:bad-range-argument index 'STREAM-TAIL))
+               (loop (force (cdr stream)) (- index 1)))))))
+    (lambda (stream index)
+      (if (not (exact-nonnegative-integer? index))
+         (error:wrong-type-argument index
+                                    "exact nonnegative integer"
+                                    'STREAM-TAIL))
+      (loop stream index))))
 \f
-(define (stream-map procedure stream . streams)
-  (if (null? streams)
-      (let ((stream-map-1
-            (lambda (procedure stream)
-              (let loop ((stream stream))
-                (if (stream-pair? stream)
-                    (cons-stream (procedure (car stream))
-                                 (loop (force (cdr stream))))
-                    (begin
-                      (if (not (null? stream))
-                          (error:wrong-type-argument stream
-                                                     "stream"
-                                                     'STREAM-MAP))
-                      '()))))))
-       ;; Kludge: accept arguments in old order.
-       (if (or (null? procedure) (stream-pair? procedure))
-           (stream-map-1 stream procedure)
-           (stream-map-1 procedure stream)))
-      (let n-loop ((streams (cons stream streams)))
-       (let parse-cars ((streams streams) (cars '()) (cdrs '()))
-         (cond ((null? streams)
-                (cons (apply procedure (reverse! cars))
-                      (let ((cdrs (reverse! cdrs)))
-                        (delay (n-loop (map force cdrs))))))
-               ((stream-pair? (car streams))
-                (parse-cars (cdr streams)
-                            (cons (car (car streams)) cars)
-                            (cons (cdr (car streams)) cdrs)))
-               (else
-                (if (not (null? (car streams)))
-                    (error:wrong-type-argument (car streams)
-                                               "stream"
-                                               'STREAM-MAP))
-                '()))))))
+(define stream-map
+  (letrec
+      ((do-1
+       (lambda (procedure stream)
+         (if (stream-pair? stream)
+             (cons-stream (procedure (car stream))
+                          (do-1 procedure (force (cdr stream))))
+             (begin
+               (if (not (null? stream))
+                   (error:illegal-stream-element stream 'STREAM-MAP 1))
+               '()))))
+       (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))))))))))
+    (lambda (procedure stream . streams)
+      (if (null? streams)
+         ;; Kludge: accept arguments in old order.
+         (if (or (null? procedure) (stream-pair? procedure))
+             (do-1 stream procedure)
+             (do-1 procedure stream))
+         (do-n procedure (cons stream streams))))))
 
-(define (stream-for-each procedure stream . streams)
-  (if (null? streams)
-      (let loop ((stream stream))
-       (cond ((stream-pair? stream)
-              (procedure (car stream))
-              (loop (force (cdr stream))))
-             ((not (null? stream))
-              (error:wrong-type-argument stream "stream" 'STREAM-FOR-EACH))))
-      (let n-loop ((streams (cons stream streams)))
-       (let parse-cars ((streams streams) (cars '()) (cdrs '()))
-         (cond ((null? streams)
-                (apply procedure (reverse! cars))
-                (n-loop (map force (reverse! cdrs))))
-               ((stream-pair? (car streams))
-                (parse-cars (cdr streams)
-                            (cons (car (car streams)) cars)
-                            (cons (cdr (car streams)) cdrs)))
-               ((not (null? (car streams)))
-                (error:wrong-type-argument (car streams)
-                                           "stream"
-                                           'STREAM-FOR-EACH)))))))
-\f
-(define (stream-append . streams)
-  (if (null? streams)
-      '()
-      (let outer-loop ((streams streams))
-       (if (null? (cdr streams))
-           (car streams)
-           (let inner-loop ((stream (car streams)))
-             (if (stream-pair? stream)
-                 (cons-stream (car stream)
-                              (inner-loop (force (cdr stream))))
+(define stream-for-each
+  (letrec
+      ((do-1
+       (lambda (procedure stream)
+         (cond ((stream-pair? stream)
+                (procedure (car stream))
+                (do-1 procedure (force (cdr stream))))
+               ((not (null? stream))
+                (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
-                   (if (not (null? stream))
-                       (error:wrong-type-argument (car streams)
-                                                  "stream"
-                                                  'STREAM-APPEND))
-                   (outer-loop (cdr streams)))))))))
+                   (apply procedure cars)
+                   (do-n procedure (map force cdrs)))))))))
+    (lambda (procedure stream . streams)
+      (if (null? streams)
+         (do-1 procedure stream)
+         (do-n procedure (cons stream streams))))))
+
+(define (split-streams streams operator)
+  (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))
+         (let ((stream (car streams)))
+           (if (stream-pair? stream)
+               (let ((cars-tail* (list (car stream)))
+                     (cdrs-tail* (list (cdr stream))))
+                 (set-cdr! cars-tail cars-tail*)
+                 (set-cdr! cdrs-tail cdrs-tail*)
+                 (loop (cdr streams) cars-tail* cdrs-tail* (fix:+ n 1)))
+               (begin
+                 (if (not (null? stream))
+                     (error:illegal-stream-element stream operator n))
+                 (values '() '()))))))))
+\f
+(define stream-append
+  (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)
+         (if (stream-pair? stream)
+             (cons-stream (car stream)
+                          (inner-loop (force (cdr stream)) streams n))
+             (begin
+               (if (not (null? stream))
+                   (error:illegal-stream-element stream 'STREAM-APPEND n))
+               (outer-loop streams (fix:+ n 1)))))))
+    (lambda streams
+      (if (null? streams)
+         '()
+         (outer-loop streams 0)))))
 
 (define (stream-accumulate procedure initial stream)
-  (let loop ((stream stream))
-    (if (stream-pair? stream)
-       (procedure (car stream)
-                  (loop (force (cdr stream))))
-       (begin
-         (if (not (null? stream))
-             (error:wrong-type-argument stream "stream" 'STREAM-ACCUMULATE))
-         initial))))
+  (if (stream-pair? stream)
+      (procedure (car stream)
+                (stream-accumulate procedure initial (force (cdr stream))))
+      (begin
+       (if (not (null? stream))
+           (error:illegal-stream-element stream 'STREAM-ACCUMULATE 2))
+       initial)))
 
 (define (stream-filter predicate stream)
-  (let loop ((stream stream))
-    (if (stream-pair? stream)
-       (if (predicate (car stream))
-           (cons-stream (car stream) (loop (force (cdr stream))))
-           (loop (force (cdr stream))))
-       (begin
-         (if (not (null? stream))
-             (error:wrong-type-argument stream "stream" 'STREAM-FILTER))
-         '()))))
+  (if (stream-pair? stream)
+      (if (predicate (car stream))
+         (cons-stream (car stream)
+                      (stream-filter predicate (force (cdr stream))))
+         (stream-filter predicate (force (cdr stream))))
+      (begin
+       (if (not (null? stream))
+           (error:illegal-stream-element stream 'STREAM-FILTER 1))
+       '())))
 
-(define (stream-write stream #!optional port)
-  (let ((port
-        (if (default-object? port)
-            (current-output-port)
-            (guarantee-output-port port))))
-    (let loop ((stream stream) (leader #\{))
-      (if (stream-pair? stream)
-         (begin
-           (write-char leader port)
-           (write (car stream) port)
-           (loop (force (cdr stream)) #\space))
-         (begin
-           (if (not (null? stream))
-               (error:wrong-type-argument stream "stream" 'STREAM-WRITE))
-           (write-char #\} port))))))
+(define stream-write
+  (letrec
+      ((loop
+       (lambda (stream leader port)
+         (if (stream-pair? stream)
+             (begin
+               (write-char leader port)
+               (write (car stream) port)
+               (loop (force (cdr stream)) #\space port))
+             (begin
+               (if (not (null? stream))
+                   (error:illegal-stream-element stream 'STREAM-WRITE 0))
+               (write-char #\} port))))))
+    (lambda (stream #!optional port)
+      (loop stream
+           #\{
+           (if (default-object? port)
+               (current-output-port)
+               (guarantee-output-port port))))))
 
 (define (list->stream list)
   (if (pair? list)
@@ -229,7 +259,7 @@ MIT in each case. |#
            (stream->list (force (cdr stream))))
       (begin
        (if (not (null? stream))
-           (error:wrong-type-argument stream "stream" 'STREAM->LIST))
+           (error:illegal-stream-element stream 'STREAM->LIST 0))
        '())))
 \f
 (define prime-numbers-stream)
@@ -237,19 +267,20 @@ MIT in each case. |#
 (define (make-prime-numbers-stream)
   (cons-stream
    2
-   (letrec ((primes
-            (cons-stream
-             (cons 3 9)
-             (let filter ((integer 5))
-               (let loop ((primes primes))
-                 (let ((prime (car primes)))
-                   (cond ((< integer (cdr prime))
-                          (cons-stream (cons integer (* integer integer))
-                                       (filter (+ integer 2))))
-                         ((= 0 (remainder integer (car prime)))
-                          (filter (+ integer 2)))
-                         (else
-                          (loop (force (cdr primes)))))))))))
+   (letrec
+       ((primes
+        (cons-stream
+         (cons 3 9)
+         (let filter ((integer 5))
+           (let loop ((primes primes))
+             (let ((prime (car primes)))
+               (cond ((< integer (cdr prime))
+                      (cons-stream (cons integer (* integer integer))
+                                   (filter (+ integer 2))))
+                     ((= 0 (remainder integer (car prime)))
+                      (filter (+ integer 2)))
+                     (else
+                      (loop (force (cdr primes)))))))))))
      (let loop ((primes primes))
        (cons-stream (car (car primes))
                    (loop (force (cdr primes))))))))
@@ -260,4 +291,30 @@ MIT in each case. |#
           (set! prime-numbers-stream (make-prime-numbers-stream))
           unspecific)))
     (reset-primes!)
-    (add-secondary-gc-daemon! reset-primes!)))
\ No newline at end of file
+    (add-secondary-gc-daemon! reset-primes!)))
+
+(define (error:illegal-stream-element stream operator operand)
+  (error (make-illegal-stream-element "stream" stream operator operand)))
+
+(define make-illegal-stream-element)
+(define condition-type:illegal-stream-element)
+
+(define (initialize-conditions!)
+  (set! condition-type:illegal-stream-element
+       (make-condition-type 'ILLEGAL-STREAM-ELEMENT
+           condition-type:wrong-type-argument
+           '()
+         (lambda (condition port)
+           (write-string "The object " port)
+           (write (access-condition condition 'DATUM) port)
+           (write-string ", occurring in the " port)
+           (write-string (ordinal-number-string
+                          (+ (access-condition condition 'OPERAND) 1))
+                         port)
+           (write-string " argument to " port)
+           (write-operator (access-condition condition 'OPERATOR) port)
+           (write-string ", is not a stream." port))))
+  (set! make-illegal-stream-element
+       (condition-constructor condition-type:illegal-stream-element
+                              '(TYPE DATUM OPERATOR OPERAND)))
+  unspecific)
\ No newline at end of file

diff --git a/v8/src/runtime/make.scm b/v8/src/runtime/make.scm
index 7327f30cbeaec850a6c1bdecd912fa67ad1daf83..984f0163523c275ebd1dc2c950e79d81c76402d9 100644 (file)
--- a/v8/src/runtime/make.scm
+++ b/v8/src/runtime/make.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: make.scm,v 14.64 1998/02/11 05:16:33 cph Exp $
+$Id: make.scm,v 14.65 1998/04/01 08:16:24 cph Exp $
 
 Copyright (c) 1988-98 Massachusetts Institute of Technology
 
@@ -454,6 +454,7 @@ MIT in each case. |#
    ((RUNTIME GENERIC-PROCEDURE) INITIALIZE-CONDITIONS! #t)
    ((RUNTIME GENERIC-PROCEDURE MULTIPLEXER) INITIALIZE-CONDITIONS! #t)
    ((RUNTIME RECORD-SLOT-ACCESS) INITIALIZE-CONDITIONS! #t)
+   ((RUNTIME STREAM) INITIALIZE-CONDITIONS! #t)
    ;; System dependent stuff
    (() INITIALIZE-SYSTEM-PRIMITIVES! #f)
    ;; Threads

diff --git a/v8/src/runtime/runtime.pkg b/v8/src/runtime/runtime.pkg
index affa4fcfaeb862ad1084fec2c6e10c7cf5306e79..822807a5a31c1e2244b810ee691926079cc099cf 100644 (file)
--- a/v8/src/runtime/runtime.pkg
+++ b/v8/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.301 1998/03/09 03:44:18 cph Exp $
+$Id: runtime.pkg,v 14.302 1998/04/01 08:16:07 cph Exp $
 
 Copyright (c) 1988-98 Massachusetts Institute of Technology
 
@@ -94,8 +94,8 @@ MIT in each case. |#
   (export ()
          char->string
          list->string
-         make-string
          guarantee-string
+         make-string
          set-string-length!
          string
          string->list
@@ -788,6 +788,9 @@ MIT in each case. |#
          dynamic-handler-frames)
   (export (runtime debugger)
          continue-from-derived-thread-error)
+  (export (runtime stream)
+         ordinal-number-string
+         write-operator)
   (initialization (initialize-package!)))
 
 (define-package (runtime event-distributor)
@@ -2982,9 +2985,11 @@ MIT in each case. |#
   (files "stream")
   (parent ())
   (export ()
+         condition-type:illegal-stream-element
          empty-stream?
          head
          list->stream
+         make-prime-numbers-stream
          prime-numbers-stream
          stream
          stream->list
@@ -3471,7 +3476,6 @@ MIT in each case. |#
          eqht/put!
          make-eqht))
 
-
 (define-package (runtime coerce-to-compiled-procedure)
   (files "coerce")
   (parent ())
@@ -3479,4 +3483,4 @@ MIT in each case. |#
          %compiled-code-support:nonrestartable-continuation
          %compiled-code-support:signal-error-in-primitive
          ;;coerce-to-compiled-procedure
-         ))
+         ))
\ No newline at end of file