From 8fce7f8c44ed51b8bab2b6a588290c65b5535c4a Mon Sep 17 00:00:00 2001
From: Jim Ursetto <zbigniewsz@gmail.com>
Date: Mon, 19 Dec 2011 15:53:13 -0600
Subject: [PATCH] Ensure current-{input,output}-port are properly restored on
 exception.

Modify with-input-from-{file,pipe} and with-output-to-{file,pipe} to use
fluid-let on ##sys#standard-{input,output} to ensure they are restored
after an exception.  The ports were restored only if the exception bubbled
up to the REPL; if intercepted prior to that, the REPL would then read
further commands from (or write output to) that file or pipe.

Signed-off-by: felix <felix@call-with-current-continuation.org>
(cherry picked from commit 5ae71ecd963948d0d1c9eeea5c47c32ecaac963a)
---
 library.scm   | 28 ++++++++++++----------------
 posixunix.scm | 28 ++++++++++++----------------
 posixwin.scm  | 32 ++++++++++++++------------------
 3 files changed, 38 insertions(+), 50 deletions(-)

diff --git a/library.scm b/library.scm
index 2aae051..c9849f4 100644
--- a/library.scm
+++ b/library.scm
@@ -1930,27 +1930,23 @@ EOF
   (let ((open-input-file open-input-file)
 	(close-input-port close-input-port) )
     (lambda (str thunk . mode)
-      (let ((old ##sys#standard-input)
-	    (file (apply open-input-file str mode)) )
-	(set! ##sys#standard-input file)
-	(##sys#call-with-values thunk
-	  (lambda results
-	    (close-input-port file)
-	    (set! ##sys#standard-input old)
-	    (apply ##sys#values results) ) ) ) ) ) )
+      (let ((file (apply open-input-file str mode)))
+	(fluid-let ((##sys#standard-input file))
+	  (##sys#call-with-values thunk
+	    (lambda results
+	      (close-input-port file)
+	      (apply ##sys#values results) ) ) ) ) ) ) )
 
 (define with-output-to-file 
   (let ((open-output-file open-output-file)
 	(close-output-port close-output-port) ) 
     (lambda (str thunk . mode)
-      (let ((old ##sys#standard-output)
-	    (file (apply open-output-file str mode)) )
-	(set! ##sys#standard-output file)
-	(##sys#call-with-values thunk
-	  (lambda results
-	    (close-output-port file)
-	    (set! ##sys#standard-output old)
-	    (apply ##sys#values results) ) ) ) ) ) )
+      (let ((file (apply open-output-file str mode)))
+	(fluid-let ((##sys#standard-output file))
+	  (##sys#call-with-values thunk
+	    (lambda results
+	      (close-output-port file)
+	      (apply ##sys#values results) ) ) ) ) ) ) )
 
 (define (file-exists? name)
   (##sys#check-string name 'file-exists?)
diff --git a/posixunix.scm b/posixunix.scm
index f49a15e..4ba16a9 100644
--- a/posixunix.scm
+++ b/posixunix.scm
@@ -830,24 +830,20 @@ EOF
 
 (define with-input-from-pipe
   (lambda (cmd thunk . mode)
-    (let ([old ##sys#standard-input]
-	  [p (apply open-input-pipe cmd mode)] )
-      (set! ##sys#standard-input p)
-      (##sys#call-with-values thunk
-			      (lambda results
-				(close-input-pipe p)
-				(set! ##sys#standard-input old)
-				(apply values results) ) ) ) ) )
+    (let ([p (apply open-input-pipe cmd mode)])
+      (fluid-let ((##sys#standard-input p))
+	(##sys#call-with-values thunk
+				(lambda results
+				  (close-input-pipe p)
+				  (apply values results) ) ) ) ) ) )
 (define with-output-to-pipe
   (lambda (cmd thunk . mode)
-    (let ([old ##sys#standard-output]
-	  [p (apply open-output-pipe cmd mode)] )
-      (set! ##sys#standard-output p)
-      (##sys#call-with-values thunk
-			      (lambda results
-				(close-output-pipe p)
-				(set! ##sys#standard-output old)
-				(apply values results) ) ) ) ) )
+    (let ([p (apply open-output-pipe cmd mode)])
+      (fluid-let ((##sys#standard-output p))
+	(##sys#call-with-values thunk
+				(lambda results
+				  (close-output-pipe p)
+				  (apply values results) ) ) ) ) ) )
 
 (define-foreign-variable _pipefd0 int "C_pipefds[ 0 ]")
 (define-foreign-variable _pipefd1 int "C_pipefds[ 1 ]")
diff --git a/posixwin.scm b/posixwin.scm
index 28f8c5f..3e5f4f7 100644
--- a/posixwin.scm
+++ b/posixwin.scm
@@ -1190,27 +1190,23 @@ EOF
 
 (define with-input-from-pipe
   (lambda (cmd thunk . mode)
-    (let ([old ##sys#standard-input]
-	  [p (apply open-input-pipe cmd mode)] )
-      (set! ##sys#standard-input p)
-      (##sys#call-with-values
-       thunk
-       (lambda results
-	 (close-input-pipe p)
-	 (set! ##sys#standard-input old)
-	 (apply values results) ) ) ) ) )
+    (let ([p (apply open-input-pipe cmd mode)])
+      (fluid-let ((##sys#standard-input p))
+	(##sys#call-with-values
+	 thunk
+	 (lambda results
+	   (close-input-pipe p)
+	   (apply values results) ) ) ) ) ) )
 
 (define with-output-to-pipe
   (lambda (cmd thunk . mode)
-    (let ([old ##sys#standard-output]
-	  [p (apply open-output-pipe cmd mode)] )
-      (set! ##sys#standard-output p)
-      (##sys#call-with-values
-       thunk
-       (lambda results
-	 (close-output-pipe p)
-	 (set! ##sys#standard-output old)
-	 (apply values results) ) ) ) ) )
+    (let ([p (apply open-output-pipe cmd mode)])
+      (fluid-let ((##sys#standard-output p))
+	(##sys#call-with-values
+	 thunk
+	 (lambda results
+	   (close-output-pipe p)
+	   (apply values results) ) ) ) ) ) )
 
 
 ;;; Pipe primitive: