From: Guillermo J. Rozas <edu/mit/csail/zurich/gjr>
Date: Sat, 25 Apr 1987 09:45:17 +0000 (+0000)
Subject: Fix IO redirection bug.
X-Git-Tag: 20090517-FFI~13586
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=9a43067efbaad158e4880652476717b521a715a8;p=mit-scheme.git

Fix IO redirection bug.
---

diff --git a/v7/src/runtime/output.scm b/v7/src/runtime/output.scm
index 7f2764d4b..d9e27dc67 100644
--- 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 @@
 
 ;;;; 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 30d4f03e0..e2678ab4f 100644
--- 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))
 
 ;;; 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