From 6a8b7f6145fe824a4a0ffd0433221bf0175ecd8b Mon Sep 17 00:00:00 2001
From: mainzelm <mainzelm>
Date: Wed, 8 Jan 2003 09:26:58 +0000
Subject: [PATCH] When closing an output port, capture any errors while
 flushing the port and try to close the port immediately instead.

---
 scheme/rts/port.scm | 18 +++++++++++++++++-
 1 file changed, 17 insertions(+), 1 deletion(-)

diff --git a/scheme/rts/port.scm b/scheme/rts/port.scm
index 1e69825..6498fd0 100644
--- a/scheme/rts/port.scm
+++ b/scheme/rts/port.scm
@@ -181,6 +181,13 @@
 	       ((port-handler-close (port-handler port)) (port-data port))))))
       (call-error "invalid argument" close-input-port port)))
 	
+;; Flushing the port may raise an error. If the port is marked closed
+;; before, subsequent calls will never close the underlying channel.
+;; This installs an error handler before calling REALLY-FORCE-OUTPUT,
+;; the handler will try to close the port and raise the error
+;; afterwards. The inner close has an additional error handler which
+;; will invoke the original handler.
+
 (define (close-output-port port)
   (if (output-port? port)
       (protect-port-op
@@ -189,7 +196,16 @@
 	   (if (open-output-port? port)
 	       (begin
 		 (make-output-port-closed! port)
-		 (really-force-output port)
+		 (with-handler 
+		  (lambda (condition more)
+		    (with-handler 
+		     (lambda (cond2 more2)
+		       (more))
+		     (lambda ()
+		       ((port-handler-close (port-handler port)) (port-data port))
+		       (more))))
+		  (lambda ()
+		    (really-force-output port)))
 		 ((port-handler-close (port-handler port)) (port-data port))))))
       (call-error "invalid argument" close-output-port port)))