From 10b760eabdabefed9a8437b04f74ed5b07d58db7 Mon Sep 17 00:00:00 2001
From: emarsden <emarsden>
Date: Fri, 26 Mar 2004 18:22:54 +0000
Subject: [PATCH]  - add a SIMPLE-STREAM-ERROR class, and use it when signaling
 errors from    fd-streams DO-OUTPUT (noted by Matthew Danish)

 - fix bug in fd-stream error handling (patch from Ole Rohne)
---
 code/error.lisp       |  3 ++-
 code/fd-stream.lisp   |  8 +++++---
 code/serve-event.lisp | 13 ++++++-------
 code/stream.lisp      | 10 +++++-----
 4 files changed, 18 insertions(+), 16 deletions(-)

diff --git a/code/error.lisp b/code/error.lisp
index 351a563fb..fcb790b80 100644
--- a/code/error.lisp
+++ b/code/error.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/error.lisp,v 1.78 2003/10/26 12:48:23 gerd Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/error.lisp,v 1.79 2004/03/26 18:22:54 emarsden Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -1010,6 +1010,7 @@
 (define-condition simple-program-error (simple-condition program-error)())
 (define-condition simple-parse-error (simple-condition parse-error)())
 (define-condition simple-control-error (simple-condition control-error)())
+(define-condition simple-stream-error (simple-condition stream-error) ())
 
 (define-condition simple-file-error (simple-condition file-error) ()
   (:report
diff --git a/code/fd-stream.lisp b/code/fd-stream.lisp
index 1b861c8e4..d49ca57ed 100644
--- a/code/fd-stream.lisp
+++ b/code/fd-stream.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/fd-stream.lisp,v 1.74 2003/11/05 16:47:18 gerd Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/fd-stream.lisp,v 1.75 2004/03/26 18:22:54 emarsden Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -217,8 +217,10 @@
 	  (cond ((not count)
 		 (if (= errno unix:ewouldblock)
 		     (output-later stream base start end reuse-sap)
-		     (error "While writing ~S: ~A"
-			    stream (unix:get-unix-error-msg errno))))
+		     (error 'simple-stream-error
+                            :stream stream
+                            :format-control "while writing: ~A"
+			    :format-arguments (list (unix:get-unix-error-msg errno)))))
 		((not (eql count length))
 		 (output-later stream base (the index (+ start count))
 			       end reuse-sap)))))))
diff --git a/code/serve-event.lisp b/code/serve-event.lisp
index ab7d5e1a3..e892100b7 100644
--- a/code/serve-event.lisp
+++ b/code/serve-event.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/serve-event.lisp,v 1.25 2000/07/06 05:41:28 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/serve-event.lisp,v 1.26 2004/03/26 18:22:54 emarsden Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -200,8 +200,8 @@
 ;;;   Search *descriptor-handlers* for any reference to fd, and nuke 'em.
 ;;; 
 (defun invalidate-descriptor (fd)
-  "Remove any handers refering to fd. This should only be used when attempting
-  to recover from a detected inconsistancy."
+  "Remove any handers refering to FD. This should only be used when attempting
+  to recover from a detected inconsistency."
   (setf *descriptor-handlers*
 	(delete fd *descriptor-handlers*
 		:key #'handler-descriptor)))
@@ -427,15 +427,14 @@
 		 (:output (unix:fd-isset desc write-fds)))
 	   (unwind-protect
 	       (progn
-		 ;; Doesn't work -- ACK
-		 ;(setf (handler-active handler) t)
+		 (setf (handler-active handler) t)
 		 (funcall (handler-function handler) desc))
 	     (setf (handler-active handler) nil))
 	   (ecase (handler-direction handler)
 	     (:input (unix:fd-clr desc read-fds))
 	     (:output (unix:fd-clr desc write-fds)))
-	   (setf result t)))
-       result)))
+	   (setf result t))))
+    result))
 
 ); eval-when (compile eval)
 
diff --git a/code/stream.lisp b/code/stream.lisp
index 8a80947b3..2fa36ddff 100644
--- a/code/stream.lisp
+++ b/code/stream.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/stream.lisp,v 1.67 2004/01/20 17:32:20 toy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/stream.lisp,v 1.68 2004/03/26 18:22:54 emarsden Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -2014,11 +2014,11 @@ POSITION: an INTEGER greater than or equal to zero, and less than or
 
       ;; Just catch some errors earlier than it would be necessary.
       (cond ((not (open-stream-p stream))
-	     (error 'stream-error
+	     (error 'simple-stream-error
 		    :stream stream
 		    :format-control "The stream is not open."))
 	    ((not (input-stream-p stream))
-	     (error 'stream-error
+	     (error 'simple-stream-error
 		    :stream stream
 		    :format-control "The stream is not open for input."))
 	    ((and seq (>= start end) 0))
@@ -2334,11 +2334,11 @@ SEQ:	a proper SEQUENCE
 
       ;; Just catch some errors earlier than it would be necessary.
       (cond ((not (open-stream-p stream))
-	     (error 'stream-error
+	     (error 'simple-stream-error
 		    :stream stream
 		    :format-control "The stream is not open."))
 	    ((not (output-stream-p stream))
-	     (error 'stream-error
+	     (error 'simple-stream-error
 		    :stream stream
 		    :format-control "The stream is not open for output."))
 	    ((and seq (>= start end)) seq)
-- 
GitLab