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)))