From: Chris Hanson <org/chris-hanson/cph>
Date: Mon, 19 Jun 2000 02:01:54 +0000 (+0000)
Subject: Simplify implementation of broken-pipe handler so that parts can be
X-Git-Tag: 20090517-FFI~3495
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=4791d80dd2e4ca431173cbb7960c44a2fbdcd9e7;p=mit-scheme.git

Simplify implementation of broken-pipe handler so that parts can be
reused.
---

diff --git a/v7/src/imail/imail-util.scm b/v7/src/imail/imail-util.scm
index 5d8eaace9..40dd3ed4d 100644
--- a/v7/src/imail/imail-util.scm
+++ b/v7/src/imail/imail-util.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: imail-util.scm,v 1.27 2000/05/30 20:53:19 cph Exp $
+;;; $Id: imail-util.scm,v 1.28 2000/06/19 02:01:54 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
 ;;;
@@ -279,15 +279,17 @@
   (bind-condition-handler (list condition-type:system-call-error
 				condition-type:derived-port-error)
       (lambda (condition)
-	(if (or (broken-pipe? condition)
-		(derived-broken-pipe? condition))
+	(if (broken-pipe? condition)
 	    (handler condition)))
     thunk))
 
 (define (broken-pipe? condition)
-  (and (eq? (condition/type condition) condition-type:system-call-error)
-       (eq? (system-call-name condition) 'WRITE)
-       (eq? (system-call-error condition) 'BROKEN-PIPE)))
+  (cond ((eq? (condition/type condition) condition-type:system-call-error)
+	 (and (eq? (system-call-name condition) 'WRITE)
+	      (eq? (system-call-error condition) 'BROKEN-PIPE)))
+	((eq? (condition/type condition) condition-type:derived-port-error)
+	 (broken-pipe? (derived-port-condition condition)))
+	(else #f)))
 
 (define system-call-name
   (condition-accessor condition-type:system-call-error 'SYSTEM-CALL))
@@ -295,10 +297,6 @@
 (define system-call-error
   (condition-accessor condition-type:system-call-error 'ERROR-TYPE))
 
-(define (derived-broken-pipe? condition)
-  (and (eq? (condition/type condition) condition-type:derived-port-error)
-       (broken-pipe? (derived-port-condition condition))))
-
 (define derived-port-condition
   (condition-accessor condition-type:derived-port-error 'CONDITION))