X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=System%2FIO.hs;h=f94dca660ddb7ece8dc4e895aab61a9e141f9475;hb=bca0cbb5e0ee7cf63a79721f7087abf02c866a5a;hp=f33a167bde470fc98dde647bff36f6cde4152d4d;hpb=b8ac498face4c8b16c06d30fbc86666b7dc28173;p=ghc-base.git

diff --git a/System/IO.hs b/System/IO.hs
index f33a167..f94dca6 100644
--- a/System/IO.hs
+++ b/System/IO.hs
@@ -93,7 +93,7 @@ module System.IO (
 
     -- ** Terminal operations
 
-#if !defined(__HUGS__) && !defined(__NHC__)
+#if !defined(__NHC__)
     hIsTerminalDevice,	 	-- :: Handle -> IO Bool
 
     hSetEcho,			-- :: Handle -> Bool -> IO ()
@@ -141,14 +141,13 @@ module System.IO (
 
     -- * Binary input and output
 
-#if !defined(__NHC__)
     openBinaryFile,	       -- :: FilePath -> IOMode -> IO Handle
-#endif
-
-#if !defined(__HUGS__) && !defined(__NHC__)
     hSetBinaryMode,	       -- :: Handle -> Bool -> IO ()
+#if !defined(__NHC__)
     hPutBuf,		       -- :: Handle -> Ptr a -> Int -> IO ()
     hGetBuf,		       -- :: Handle -> Ptr a -> Int -> IO Int
+#endif
+#if !defined(__NHC__) && !defined(__HUGS__)
     hPutBufNonBlocking,	       -- :: Handle -> Ptr a -> Int -> IO Int
     hGetBufNonBlocking,	       -- :: Handle -> Ptr a -> Int -> IO Int
 #endif
@@ -171,6 +170,9 @@ import GHC.Show
 #ifdef __HUGS__
 import Hugs.IO
 import Hugs.IOExts
+import Hugs.IORef
+import Hugs.Prelude	( throw, Exception(NonTermination) )
+import System.IO.Unsafe	( unsafeInterleaveIO )
 #endif
 
 #ifdef __NHC__
@@ -199,6 +201,9 @@ import IO
   , hGetContents              -- :: Handle -> IO [Char]
   , hPutChar                  -- :: Handle -> Char -> IO ()
   , hPutStr                   -- :: Handle -> [Char] -> IO ()
+  , hPutStrLn                 -- :: Handle -> [Char] -> IO ()
+  , hPrint                    -- :: Handle -> [Char] -> IO ()
+  , hReady                    -- :: Handle -> [Char] -> IO ()
   , hIsOpen, hIsClosed        -- :: Handle -> IO Bool
   , hIsReadable, hIsWritable  -- :: Handle -> IO Bool
   , hIsSeekable               -- :: Handle -> IO Bool
@@ -231,7 +236,7 @@ import System.IO.Error (
 -- -----------------------------------------------------------------------------
 -- Standard IO
 
-#ifndef __HUGS__
+#ifdef __GLASGOW_HASKELL__
 -- | Write a character to the standard output device
 -- (same as 'hPutChar' 'stdout').
 
@@ -244,7 +249,7 @@ putChar c       =  hPutChar stdout c
 putStr          :: String -> IO ()
 putStr s        =  hPutStr stdout s
 
--- | The same as 'putStrLn', but adds a newline character.
+-- | The same as 'putStr', but adds a newline character.
 
 putStrLn        :: String -> IO ()
 putStrLn s      =  do putStr s
@@ -340,8 +345,9 @@ readIO s        =  case (do { (x,t) <- reads s ;
 			[x]    -> return x
 			[]     -> ioError (userError "Prelude.readIO: no parse")
 			_      -> ioError (userError "Prelude.readIO: ambiguous parse")
-#endif  /* __HUGS__ */
+#endif  /* __GLASGOW_HASKELL__ */
 
+#ifndef __NHC__
 -- | Computation 'hReady' @hdl@ indicates whether at least one item is
 -- available for input from handle @hdl@.
 -- 
@@ -371,13 +377,29 @@ hPutStrLn hndl str = do
 
 hPrint		:: Show a => Handle -> a -> IO ()
 hPrint hdl 	=  hPutStrLn hdl . show
+#endif /* !__NHC__ */
 
 -- ---------------------------------------------------------------------------
 -- fixIO
 
-#ifdef __GLASGOW_HASKELL__
-fixIO 		:: (a -> IO a) -> IO a
-fixIO m         = stToIO (fixST (ioToST . m))
+#if defined(__GLASGOW_HASKELL__) || defined(__HUGS__)
+fixIO :: (a -> IO a) -> IO a
+fixIO k = do
+    ref <- newIORef (throw NonTermination)
+    ans <- unsafeInterleaveIO (readIORef ref)
+    result <- k ans
+    writeIORef ref result
+    return result
+
+-- NOTE: we do our own explicit black holing here, because GHC's lazy
+-- blackholing isn't enough.  In an infinite loop, GHC may run the IO
+-- computation a few times before it notices the loop, which is wrong.
+#endif
+
+#if defined(__NHC__)
+-- Assume a unix platform, where text and binary I/O are identical.
+openBinaryFile = openFile
+hSetBinaryMode _ _ = return ()
 #endif
 
 -- $locking