diff --git a/ghc/lib/std/IO.lhs b/ghc/lib/std/IO.lhs
index 1b458cbefec4ea4302dea7f2969ab756e9c557f8..6670ff3172218b7912c669052ce21f0b23553dac 100644
--- a/ghc/lib/std/IO.lhs
+++ b/ghc/lib/std/IO.lhs
@@ -358,6 +358,7 @@ hPutChar :: Handle -> Char -> IO ()
hPutChar handle c =
wantWriteableHandle "hPutChar" handle $ \ handle_ -> do
let fo = haFO__ handle_
+ flushConnectedBuf fo
rc <- mayBlock fo (CCALL(filePutc) fo c) -- ConcHask: UNSAFE, may block.
writeHandle handle handle_
if rc == 0
@@ -374,6 +375,7 @@ hPutStr :: Handle -> String -> IO ()
hPutStr handle str =
wantWriteableHandle "hPutStr" handle $ \ handle_ -> do
let fo = haFO__ handle_
+ flushConnectedBuf 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 ec3c896017690cbe8cbb6049a71faf37d3ea869b..139594d2313abd253e572310f9923992719129e3 100644
--- a/ghc/lib/std/PrelHandle.lhs
+++ b/ghc/lib/std/PrelHandle.lhs
@@ -258,7 +258,13 @@ stderr = unsafePerformIO (do
fo <- makeForeignObj fo
addForeignFinaliser fo (freeStdFileObject fo)
#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 to
+ -- stderr.
+ hConnectTo stdout hdl
+ return hdl
+
_ -> do ioError <- constructError "stderr"
newHandle (mkErrorHandle__ ioError)
)
@@ -905,12 +911,20 @@ hConnectTo hW hR = hConnectHdl_ hW hR 0{-connect regardless-}
hConnectHdl_ :: Handle -> Handle -> Int -> IO ()
hConnectHdl_ hW hR is_tty =
- wantWriteableHandle "hConnectTo" hW $ \ hW_ -> do
- wantReadableHandle "hConnectTo" hR $ \ hR_ -> do
+ wantRWHandle "hConnectTo" hW $ \ hW_ -> do
+ wantRWHandle "hConnectTo" hR $ \ hR_ -> do
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
+
+flushConnectedBuf :: FILE_OBJECT -> IO ()
+flushConnectedBuf fo = CCALL(flushConnectedBuf) fo
\end{code}
As an extension, we also allow characters to be pushed back.
@@ -1124,6 +1138,25 @@ wantWriteableHandle fun handle act =
IOError (Just handle) IllegalOperation fun
("handle is not open for writing")
+wantRWHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
+wantRWHandle fun handle act =
+ withHandle handle $ \ handle_ -> do
+ case haType__ handle_ of
+ ErrorHandle theError -> do
+ writeHandle handle handle_
+ ioError theError
+ ClosedHandle -> do
+ writeHandle handle handle_
+ ioe_closedHandle fun handle
+ SemiClosedHandle -> do
+ writeHandle handle handle_
+ ioe_closedHandle fun handle
+ _ -> act handle_
+ where
+ not_rw_error =
+ IOError (Just handle) IllegalOperation fun
+ ("handle is not open for reading or writing")
+
wantSeekableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
wantSeekableHandle fun handle act =
withHandle handle $ \ handle_ -> do
@@ -1246,11 +1279,12 @@ foreign import ccall "libHS_cbits.so" "getWriteableBuf" unsafe prim_getWri
foreign import ccall "libHS_cbits.so" "getBufWPtr" unsafe prim_getBufWPtr :: FILE_OBJ -> IO Int
foreign import ccall "libHS_cbits.so" "setBufWPtr" unsafe prim_setBufWPtr :: FILE_OBJ -> Int -> IO ()
foreign import ccall "libHS_cbits.so" "closeFile" unsafe prim_closeFile :: FILE_OBJ -> Flush -> IO RC
-foreign import ccall "libHS_cbits.so" "fileEOF" unsafe prim_fileEOF :: FILE_OBJ -> IO RC
-foreign import ccall "libHS_cbits.so" "setBuffering" unsafe prim_setBuffering :: FILE_OBJ -> Int -> IO RC
-foreign import ccall "libHS_cbits.so" "flushFile" unsafe prim_flushFile :: FILE_OBJ -> IO RC
-foreign import ccall "libHS_cbits.so" "getBufferMode" unsafe prim_getBufferMode :: FILE_OBJ -> IO RC
-foreign import ccall "libHS_cbits.so" "seekFile_int64" unsafe prim_seekFile_int64 :: FILE_OBJ -> Int -> Int64 -> IO RC
+foreign import ccall "libHS_cbits.so" "fileEOF" unsafe prim_fileEOF :: FILE_OBJ -> IO RC
+foreign import ccall "libHS_cbits.so" "setBuffering" unsafe prim_setBuffering :: FILE_OBJ -> Int -> IO RC
+foreign import ccall "libHS_cbits.so" "flushFile" unsafe prim_flushFile :: FILE_OBJ -> IO RC
+foreign import ccall "libHS_cbits.so" "flushConnectedBuf" unsafe prim_flushConnectedBuf :: FILE_OBJ -> IO RC
+foreign import ccall "libHS_cbits.so" "getBufferMode" unsafe prim_getBufferMode :: FILE_OBJ -> IO RC
+foreign import ccall "libHS_cbits.so" "seekFile_int64" unsafe prim_seekFile_int64 :: FILE_OBJ -> Int -> Int64 -> IO RC
foreign import ccall "libHS_cbits.so" "seekFileP" unsafe prim_seekFileP :: FILE_OBJ -> IO RC
foreign import ccall "libHS_cbits.so" "setTerminalEcho" unsafe prim_setTerminalEcho :: FILE_OBJ -> Int -> IO RC
foreign import ccall "libHS_cbits.so" "getTerminalEcho" unsafe prim_getTerminalEcho :: FILE_OBJ -> IO RC
diff --git a/ghc/lib/std/cbits/flushFile.c b/ghc/lib/std/cbits/flushFile.c
index 7390b27ec2ecd21481ef7ce7acf388a2a2b4d256..d556d5ae1b5400afccd005552813cfa618206a1f 100644
--- a/ghc/lib/std/cbits/flushFile.c
+++ b/ghc/lib/std/cbits/flushFile.c
@@ -1,7 +1,7 @@
/*
* (c) The GRASP/AQUA Project, Glasgow University, 1994-1998
*
- * $Id: flushFile.c,v 1.3 1998/12/02 13:27:32 simonm Exp $
+ * $Id: flushFile.c,v 1.4 1999/01/15 17:54:23 sof Exp $
*
* hFlush Runtime Support
*/
@@ -78,3 +78,21 @@ StgForeignPtr ptr;
fo->bufWPtr=0;
return 0;
}
+
+void
+flushConnectedBuf(ptr)
+StgForeignPtr ptr;
+{
+ StgInt rc;
+ IOFileObject* fo = (IOFileObject*)ptr;
+
+ /* if the stream is connected to an output stream, flush it. */
+ if ( fo->connectedTo != NULL && fo->connectedTo->fd != -1 &&
+ (fo->connectedTo->flags & FILEOBJ_WRITE) ) {
+ rc = flushBuffer((StgForeignPtr)fo->connectedTo);
+ }
+ /* Willfully ignore the return code for now. */
+ return;
+}
+
+
diff --git a/ghc/lib/std/cbits/stgio.h b/ghc/lib/std/cbits/stgio.h
index 8115b5ec6400ad188d479336a4823a9ec0ea7f57..68a097974feee0f753acd153c289ff871815f63e 100644
--- a/ghc/lib/std/cbits/stgio.h
+++ b/ghc/lib/std/cbits/stgio.h
@@ -1,7 +1,7 @@
/*
* (c) The GRASP/AQUA Project, Glasgow University, 1994-1998
*
- * $Id: stgio.h,v 1.8 1998/12/02 13:27:58 simonm Exp $
+ * $Id: stgio.h,v 1.9 1999/01/15 17:54:23 sof Exp $
*
* Helper code for GHC's IO subsystem.
*/
@@ -117,6 +117,7 @@ StgInt fileSize_int64 (StgForeignPtr, StgByteArray);
StgInt flushFile (StgForeignPtr);
StgInt flushBuffer (StgForeignPtr);
StgInt flushReadBuffer (StgForeignPtr);
+void flushConnectedBuf (StgForeignPtr);
/* freeFile.c */
void freeStdFile (StgForeignPtr);