[project @ 2002-02-12 11:44:54 by simonmar]

[ghc-hetmet.git] / ghc / lib / std / PrelHandle.hs

diff --git a/ghc/lib/std/PrelHandle.hs b/ghc/lib/std/PrelHandle.hs
index 5be5c59..fe360a7 100644 (file)
--- a/ghc/lib/std/PrelHandle.hs
+++ b/ghc/lib/std/PrelHandle.hs
@@ -4,7 +4,7 @@
 #undef DEBUG
 
 -- -----------------------------------------------------------------------------
--- $Id: PrelHandle.hs,v 1.6 2001/11/27 01:53:23 sof Exp $
+-- $Id: PrelHandle.hs,v 1.9 2002/01/28 13:47:05 simonmar Exp $
 --
 -- (c) The University of Glasgow, 1994-2001
 --
@@ -16,7 +16,8 @@ module PrelHandle (
   
   newEmptyBuffer, allocateBuffer, readCharFromBuffer, writeCharIntoBuffer,
   flushWriteBufferOnly, flushWriteBuffer, flushReadBuffer, fillReadBuffer,
-  read_off,
+  read_off,  read_off_ba,
+  write_off, write_off_ba,
 
   ioe_closedHandle, ioe_EOF, ioe_notReadable, ioe_notWritable,
 
@@ -424,8 +425,8 @@ flushWriteBuffer fd is_stream buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w }  = do
      then return (buf{ bufRPtr=0, bufWPtr=0 })
      else do
   res <- throwErrnoIfMinus1RetryMayBlock "flushWriteBuffer"
-               (write_off (fromIntegral fd) is_stream b (fromIntegral r)
-                       (fromIntegral bytes))
+               (write_off_ba (fromIntegral fd) is_stream b (fromIntegral r)
+                             (fromIntegral bytes))
                (threadWaitWrite fd)
   let res' = fromIntegral res
   if res' < bytes 
@@ -433,8 +434,10 @@ flushWriteBuffer fd is_stream buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w }  = do
      else return buf{ bufRPtr=0, bufWPtr=0 }
 
 foreign import "prel_PrelHandle_write" unsafe
-   write_off :: CInt -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
+   write_off_ba :: CInt -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
 
+foreign import "prel_PrelHandle_write" unsafe
+   write_off :: CInt -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
 
 fillReadBuffer :: FD -> Bool -> Bool -> Buffer -> IO Buffer
 fillReadBuffer fd is_line is_stream
@@ -458,7 +461,7 @@ fillReadBufferLoop fd is_line is_stream buf b w size = do
   puts ("fillReadBufferLoop: bytes = " ++ show bytes ++ "\n")
 #endif
   res <- throwErrnoIfMinus1RetryMayBlock "fillReadBuffer"
-           (read_off fd is_stream b (fromIntegral w) (fromIntegral bytes))
+           (read_off_ba fd is_stream b (fromIntegral w) (fromIntegral bytes))
            (threadWaitRead fd)
   let res' = fromIntegral res
 #ifdef DEBUG_DUMP
@@ -473,7 +476,10 @@ fillReadBufferLoop fd is_line is_stream buf b w size = do
             else return buf{ bufRPtr=0, bufWPtr=w+res' }
  
 foreign import "prel_PrelHandle_read" unsafe
-   read_off :: FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
+   read_off_ba :: FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
+
+foreign import "prel_PrelHandle_read" unsafe
+   read_off :: FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
 
 -- ---------------------------------------------------------------------------
 -- Standard Handles
@@ -588,7 +594,7 @@ openFile' filepath ex_mode =
               | otherwise         = False
 
       binary_flags
-         | binary    = PrelHandle.o_BINARY -- is '0' if not supported.
+         | binary    = o_BINARY -- is '0' if not supported.
          | otherwise = 0
 
       oflags = oflags1 .|. binary_flags
@@ -762,17 +768,22 @@ hClose_help handle_ =
   case haType handle_ of 
       ClosedHandle -> return handle_
       _ -> do
-         let fd = fromIntegral (haFD handle_)
+         let fd = haFD handle_
+             c_fd = fromIntegral fd
+
          flushWriteBufferOnly handle_
 
-         -- close the file descriptor, but not when this is the read side
-         -- of a duplex handle.
+         -- close the file descriptor, but not when this is the read
+         -- side of a duplex handle, and not when this is one of the
+         -- std file handles.
          case haOtherSide handle_ of
-           Nothing -> throwErrnoIfMinus1Retry_ "hClose" 
+           Nothing -> 
+               when (fd /= fd_stdin && fd /= fd_stdout && fd /= fd_stderr) $
+                       throwErrnoIfMinus1Retry_ "hClose" 
 #ifdef mingw32_TARGET_OS
-                                               (closeFd (haIsStream handle_) fd)
+                               (closeFd (haIsStream handle_) c_fd)
 #else
-                                               (c_close fd)
+                               (c_close c_fd)
 #endif
            Just _  -> return ()
 
@@ -780,7 +791,7 @@ hClose_help handle_ =
          writeIORef (haBuffers handle_) BufferListNil
 
          -- unlock it
-         unlockFile fd
+         unlockFile c_fd
 
          -- we must set the fd to -1, because the finalizer is going
          -- to run eventually and try to close/unlock it.
@@ -1202,7 +1213,7 @@ ioeGetFileName _ = error "IO.ioeGetFileName: not an IO error"
 
 #ifdef DEBUG_DUMP
 puts :: String -> IO ()
-puts s = withCString s $ \cstr -> do c_write 1 cstr (fromIntegral (length s))
+puts s = withCString s $ \cstr -> do write_off_ba 1 False cstr 0 (fromIntegral (length s))
                                     return ()
 #endif
 
@@ -1211,6 +1222,5 @@ foreign import ccall "prel_bufsiz"   unsafe dEFAULT_BUFFER_SIZE :: Int
 foreign import ccall "prel_seek_cur" unsafe sEEK_CUR :: CInt
 foreign import ccall "prel_seek_set" unsafe sEEK_SET :: CInt
 foreign import ccall "prel_seek_end" unsafe sEEK_END :: CInt
-foreign import ccall "prel_o_binary" unsafe o_BINARY :: CInt