[project @ 1998-11-23 15:44:21 by sof]

Extend hConnectTo to also allow output handles to be connected, i.e.,

    h1 <- openFile "foo" WriteMode
    h2 <- openFile "bar" WriteMode
    hConnectTo h1 h2

  will cause h1's buffer to be flushed when h2's buffer overflows
  (and it is just about to be flushed.) The implementation is currently
  not as lazy as that, it flushes h1's buffer regardless of whether h2's
  buffer overflows or not.

  This is used to connect 'stderr' and 'stdout', i.e., output on
  'stderr' will now cause 'stdout' output to (first) be flushed.

6 files changed, 56 insertions, 6 deletions

diff --git a/ghc/lib/std/IO.lhs b/ghc/lib/std/IO.lhs
index 5c8c9fb0b1..4c40d943d1 100644
--- a/ghc/lib/std/IO.lhs
+++ b/ghc/lib/std/IO.lhs
@@ -329,6 +329,7 @@ hPutChar :: Handle -> Char -> IO ()
 hPutChar handle c = do
     handle_  <- wantWriteableHandle "hPutChar" handle
     let fo = haFO__ handle_
+    flushConnectedHandle fo    
     rc       <- mayBlock fo (_ccall_ filePutc fo c)   -- ConcHask: UNSAFE, may block.
     writeHandle handle handle_
     if rc == 0
@@ -345,6 +346,7 @@ hPutStr :: Handle -> String -> IO ()
 hPutStr handle str = do
     handle_ <- wantWriteableHandle "hPutStr" handle
     let fo = haFO__ handle_
+    flushConnectedHandle fo
     case haBufferMode__ handle_ of
        LineBuffering -> do
 	    buf <- _ccall_ getWriteableBuf fo
diff --git a/ghc/lib/std/PrelHandle.lhs b/ghc/lib/std/PrelHandle.lhs
index 91ae3df5d7..c1ca8b2c21 100644
--- a/ghc/lib/std/PrelHandle.lhs
+++ b/ghc/lib/std/PrelHandle.lhs
@@ -150,7 +150,12 @@ stderr = unsafePerformIO (do
 #ifndef __PARALLEL_HASKELL__
             fo <- makeForeignObj fo (``&freeStdFileObject''::Addr)
 #endif
-            newHandle (Handle__ fo WriteHandle NoBuffering "stderr")
+            hdl <- newHandle (Handle__ fo WriteHandle NoBuffering "stderr")
+	     -- when stderr and stdout are both connected to a terminal, ensure
+	     -- that anything buffered on stdout is flushed prior to writing on stderr.
+	     -- 
+	    hConnectTo stdout hdl
+	    return hdl
        _ -> do ioError <- constructError "stderr"
                newHandle (mkErrorHandle__ ioError)
   )
@@ -774,12 +779,20 @@ hConnectTo hW hR = hConnectHdl_ hW hR 0{-connect regardless-}
 
 hConnectHdl_ :: Handle -> Handle -> Int -> IO ()
 hConnectHdl_ hW hR is_tty = do
-  hW_ <- wantWriteableHandle "hConnectTo" hW
-  hR_ <- wantReadableHandle  "hConnectTo" hR
+  hW_ <- wantRWHandle "hConnectTo" hW
+  hR_ <- wantRWHandle "hConnectTo" hR
   _ccall_ setConnectedTo (haFO__ hR_) (haFO__ hW_) is_tty  -- ConcHask: SAFE, won't block
   writeHandle hR hR_
   writeHandle hW hW_
 
+#ifndef __PARALLEL_HASKELL__
+#define FILE_OBJECT	    ForeignObj
+#else
+#define FILE_OBJECT	    Addr
+#endif
+
+flushConnectedHandle :: FILE_OBJECT -> IO ()
+flushConnectedHandle fo = _ccall_ flushConnectedHandle fo
 \end{code}
 
 As an extension, we also allow characters to be pushed back.
@@ -985,6 +998,26 @@ wantWriteableHandle fun handle = do
 	   IOError (Just handle) IllegalOperation fun
 		   ("handle is not open for writing")
 
+-- either R or W.
+wantRWHandle :: String -> Handle -> IO Handle__
+wantRWHandle fun handle = do
+    handle_ <- readHandle handle
+    case haType__ handle_ of 
+      ErrorHandle ioError -> do
+	  writeHandle handle handle_
+          fail ioError
+      ClosedHandle -> do
+	  writeHandle handle handle_
+	  ioe_closedHandle fun handle
+      SemiClosedHandle -> do
+	  writeHandle handle handle_
+	  ioe_closedHandle fun handle
+      other -> return handle_
+  where
+   not_readable_error = 
+	   IOError (Just handle) IllegalOperation fun	
+		   ("handle is not open for reading or writing")
+
 wantSeekableHandle :: String -> Handle -> IO Handle__
 wantSeekableHandle fun handle = do
     handle_ <- readHandle handle
diff --git a/ghc/lib/std/cbits/filePutc.lc b/ghc/lib/std/cbits/filePutc.lc
index a6ebf3d155..cf9ffe1213 100644
--- a/ghc/lib/std/cbits/filePutc.lc
+++ b/ghc/lib/std/cbits/filePutc.lc
@@ -49,7 +49,7 @@ StgChar c;
 
     fo->flags = (fo->flags & ~FILEOBJ_RW_READ) | FILEOBJ_RW_WRITE;
 	      
-    /* check whether we can just add it to the buffer.. */
+   /* check whether we can just add it to the buffer.. */
     if ( FILEOBJ_UNBUFFERED(fo) ) {
         ; 
     } else {
diff --git a/ghc/lib/std/cbits/flushFile.lc b/ghc/lib/std/cbits/flushFile.lc
index 595dfc01ac..6fa7888ff5 100644
--- a/ghc/lib/std/cbits/flushFile.lc
+++ b/ghc/lib/std/cbits/flushFile.lc
@@ -80,8 +80,21 @@ StgForeignObj ptr;
     return 0;
 }
 
-
-\end{code}
+void
+flushConnectedHandle(ptr)
+StgForeignObj ptr;
+{
+    StgInt rc;
+    IOFileObject* fo = (IOFileObject*)ptr;
 
 
+    /* if the stream is connected to an output stream, flush it first */
+    if ( fo->connectedTo != NULL   && fo->connectedTo->fd != -1 &&
+         (fo->connectedTo->flags & FILEOBJ_WRITE)  ) {
+        rc = flushBuffer((StgForeignObj)fo->connectedTo);
+    }
+    /* Willfully ignore return code for now */
+    return;  
+}
 
+\end{code}
diff --git a/ghc/lib/std/cbits/stgio.h b/ghc/lib/std/cbits/stgio.h
index 2bce94b326..2769e808cb 100644
--- a/ghc/lib/std/cbits/stgio.h
+++ b/ghc/lib/std/cbits/stgio.h
@@ -90,6 +90,7 @@ StgInt	fileSize    PROTO((StgForeignObj, StgByteArray));
 StgInt	flushFile   PROTO((StgForeignObj));
 StgInt	flushBuffer PROTO((StgForeignObj));
 StgInt	flushReadBuffer PROTO((StgForeignObj));
+void	flushConnectedHandle PROTO((StgForeignObj));
 
 /* freeFile.lc */
 void freeStdFile PROTO((StgForeignObj));
diff --git a/ghc/lib/std/cbits/writeFile.lc b/ghc/lib/std/cbits/writeFile.lc
index ca7bac63d4..1cd336e71d 100644
--- a/ghc/lib/std/cbits/writeFile.lc
+++ b/ghc/lib/std/cbits/writeFile.lc
@@ -76,6 +76,7 @@ StgInt  len;
     if (len == 0 )
 	return 0;
 
+
     /* First of all, check if we do need to flush the buffer .. */
     /* Note - in the case of line buffering, we do not currently check
        whether we need to flush buffer due to line terminators in the