Fix IO redirection bug.

diff --git a/v7/src/runtime/output.scm b/v7/src/runtime/output.scm
index 7f2764d4bb9c0f42842e86ce85a30c6e4f337eb7..d9e27dc670f134a708167ce15b6a9b701047ba1b 100644 (file)
--- a/v7/src/runtime/output.scm
+++ b/v7/src/runtime/output.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;    $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/output.scm,v 13.42 1987/02/15 15:45:07 cph Exp $
+;;;    $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/output.scm,v 13.43 1987/04/25 09:44:31 jinx Exp $
 ;;;
 ;;;    Copyright (c) 1987 Massachusetts Institute of Technology
 ;;;
@@ -273,19 +273,12 @@
 \f
 ;;;; Output Procedures
 
-(define (write-char char #!optional port)
-  (cond ((unassigned? port) (set! port *current-output-port*))
-       ((not (output-port? port)) (error "Bad output port" port)))
-  ((access :write-char port) char)
-  ((access :flush-output port))
-  *the-non-printing-object*)
+(define (non-printing-object? object)
+  (and (not (future? object))
+       (eq? object *the-non-printing-object*)))
 
-(define (write-string string #!optional port)
-  (cond ((unassigned? port) (set! port *current-output-port*))
-       ((not (output-port? port)) (error "Bad output port" port)))
-  ((access :write-string port) string)
-  ((access :flush-output port))
-  *the-non-printing-object*)
+(define (unparse-with-brackets thunk)
+  ((access unparse-with-brackets unparser-package) thunk))
 
 (define (newline #!optional port)
   (cond ((unassigned? port) (set! port *current-output-port*))
@@ -294,33 +287,46 @@
   ((access :flush-output port))
   *the-non-printing-object*)
 
-(define (display object #!optional port)
-  (cond ((unassigned? port) (set! port *current-output-port*))
-       ((not (output-port? port)) (error "Bad output port" port)))
-  (if (not (non-printing-object? object))
-      (begin (if (and (not (future? object)) (string? object))
-                ((access :write-string port) object)
-                ((access unparse-object unparser-package) object port false))
-            ((access :flush-output port))))
-  *the-non-printing-object*)
-
-(define (write object #!optional port)
+(define (write-char char #!optional port)
   (cond ((unassigned? port) (set! port *current-output-port*))
        ((not (output-port? port)) (error "Bad output port" port)))
-  (if (not (non-printing-object? object))
-      (begin ((access unparse-object unparser-package) object port)
-            ((access :flush-output port))))
+  ((access :write-char port) char)
+  ((access :flush-output port))
   *the-non-printing-object*)
 
-(define (write-line object #!optional port)
+(define (write-string string #!optional port)
   (cond ((unassigned? port) (set! port *current-output-port*))
        ((not (output-port? port)) (error "Bad output port" port)))
-  (if (not (non-printing-object? object))
-      (begin ((access :write-char port) char:newline)
-            ((access unparse-object unparser-package) object port)
-            ((access :flush-output port))))
+  ((access :write-string port) string)
+  ((access :flush-output port))
   *the-non-printing-object*)
 
-(define (non-printing-object? object)
-  (and (not (future? object))
+(define (make-unparser handler)
+  (lambda (object #!optional port)
+    (if (not (non-printing-object? object))
+       (if (unassigned? port)
+           (handler object *current-output-port*)
+           (with-output-to-port port (lambda () (handler object port)))))
+    *the-non-printing-object*))
+          
+(define display
+  (make-unparser
+   (lambda (object port)
+     (if (and (not (future? object)) (string? object))
+        ((access :write-string port) object)
+        ((access unparse-object unparser-package) object port false))
+     ((access :flush-output port)))))
+
+(define write
+  (make-unparser
+   (lambda (object port)
+     ((access unparse-object unparser-package) object port)
+     ((access :flush-output port)))))
+
+(define write-line
+  (make-unparser
+   (lambda (object port)
+      ((access :write-char port) char:newline)
+      ((access unparse-object unparser-package) object port)
+      ((access :flush-output port)))))
        ((access :flush-output port))))))
\ No newline at end of file

diff --git a/v7/src/runtime/unpars.scm b/v7/src/runtime/unpars.scm
index 30d4f03e074d85f7516923161f1fd6d05ab1e44b..e2678ab4f56f297f9ab28f94648e970bc52af316 100644 (file)
--- a/v7/src/runtime/unpars.scm
+++ b/v7/src/runtime/unpars.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;    $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/unpars.scm,v 13.43 1987/04/24 13:37:27 cph Exp $
+;;;    $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/unpars.scm,v 13.44 1987/04/25 09:45:17 jinx Exp $
 ;;;
 ;;;    Copyright (c) 1987 Massachusetts Institute of Technology
 ;;;
@@ -42,15 +42,11 @@
 (declare (usual-integrations))
 \f
 ;;; Control Variables
+
 (define *unparser-radix* #d10)
 (define *unparser-list-breadth-limit* false)
 (define *unparser-list-depth-limit* false)
 
-(define (unparse-with-brackets thunk)
-  (write-string "#[")
-  (thunk)
-  (write-char #\]))
-
 (define unparser-package
   (make-environment
 
@@ -59,6 +55,11 @@
 (define *unparser-list-depth*)
 (define *slashify*)
 
+(define (unparse-with-brackets thunk)
+  (*unparse-string "#[")
+  (thunk)
+  (*unparse-char #\]))
+
 (define (unparse-object object port #!optional slashify)
   (if (unassigned? slashify) (set! slashify true))
   (fluid-let ((*unparse-char (access :write-char port))
@@ -311,4 +312,5 @@
 (define-type 'COMPLEX unparse-number)
 
 ;;; end UNPARSER-PACKAGE.
+))
 ))
\ No newline at end of file