~ chicken-core (chicken-5) 5ae71ecd963948d0d1c9eeea5c47c32ecaac963a

commit 5ae71ecd963948d0d1c9eeea5c47c32ecaac963a
Author:     Jim Ursetto <zbigniewsz@gmail.com>
AuthorDate: Mon Dec 19 15:53:13 2011 -0600
Commit:     felix <felix@call-with-current-continuation.org>
CommitDate: Tue Dec 20 07:21:38 2011 +0100

    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>

diff --git a/library.scm b/library.scm
index 9b65ad29..aed45dc4 100644
--- a/library.scm
+++ b/library.scm
@@ -1996,27 +1996,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 (##sys#file-exists? name file? dir? loc)
   (case (##core#inline "C_i_file_exists_p" (##sys#make-c-string name loc) file? dir?)
diff --git a/posixunix.scm b/posixunix.scm
index f1af0926..9b238465 100644
--- a/posixunix.scm
+++ b/posixunix.scm
@@ -858,24 +858,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 bc61b7e7..c12c2c54 100644
--- a/posixwin.scm
+++ b/posixwin.scm
@@ -1184,27 +1184,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: