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