From: Chris Hanson Date: Fri, 1 Mar 1991 22:12:33 +0000 (+0000) Subject: Fix other input-buffer operations to recover gracefully when the X-Git-Tag: 20090517-FFI~10887 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=da6a38c119dd2d066bb41fdfc1d00ea062b743cf;p=mit-scheme.git Fix other input-buffer operations to recover gracefully when the buffer's channel is closed. --- diff --git a/v7/src/runtime/io.scm b/v7/src/runtime/io.scm index 8eacfd0c5..1790c2081 100644 --- a/v7/src/runtime/io.scm +++ b/v7/src/runtime/io.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/io.scm,v 14.19 1991/03/01 21:22:10 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/io.scm,v 14.20 1991/03/01 22:12:33 cph Exp $ Copyright (c) 1988-91 Massachusetts Institute of Technology @@ -217,19 +217,25 @@ MIT in each case. |# ((ucode-primitive channel-nonblocking 1) (channel-descriptor channel))) (define (with-channel-blocking channel blocking? thunk) - (let ((blocking-outside?)) - (dynamic-wind - (lambda () - (set! blocking-outside? (channel-blocking? channel)) - (if blocking? - (channel-blocking channel) - (channel-nonblocking channel))) - thunk - (lambda () - (set! blocking? (channel-blocking? channel)) - (if blocking-outside? - (channel-blocking channel) - (channel-nonblocking channel)))))) + (if (channel-open? channel) + (let ((blocking-outside?)) + (dynamic-wind + (lambda () + (if (channel-open? channel) + (begin + (set! blocking-outside? (channel-blocking? channel)) + (if blocking? + (channel-blocking channel) + (channel-nonblocking channel))))) + thunk + (lambda () + (if (channel-open? channel) + (begin + (set! blocking? (channel-blocking? channel)) + (if blocking-outside? + (channel-blocking channel) + (channel-nonblocking channel))))))) + (thunk))) (define (channel-table) (fluid-let ((traversing? true))