From 2c017a9a9808fb0085c5b37834fffeeaf120357e Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Wed, 1 Apr 1998 08:16:28 +0000
Subject: [PATCH] Be more aggressive about dropping pointers to streams when
 traversing them.  Provide more accurate error messages for malformed streams.

---
 v7/src/runtime/make.scm    |   3 +-
 v7/src/runtime/runtime.pkg |   7 +-
 v7/src/runtime/stream.scm  | 361 +++++++++++++++++++++----------------
 v8/src/runtime/make.scm    |   3 +-
 v8/src/runtime/runtime.pkg |  12 +-
 5 files changed, 227 insertions(+), 159 deletions(-)

diff --git a/v7/src/runtime/make.scm b/v7/src/runtime/make.scm
index a32e8e037..3e0399dfc 100644
--- 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 5b9e4d721..79af2341b 100644
--- 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 87e0c2bb4..1d4a4cbe2 100644
--- 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))))
 
-(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)))))))
-
-(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 '() '()))))))))
+
+(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))
 	'())))
 
 (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 7327f30cb..984f01635 100644
--- 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 affa4fcfa..822807a5a 100644
--- 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
-- 
2.25.1