Make Control.Exception buildable by nhc98.

[haskell-directory.git] / GHC / Handle.hs

diff --git a/GHC/Handle.hs b/GHC/Handle.hs
index 3b7a3dc..fd06fc6 100644 (file)
--- a/GHC/Handle.hs
+++ b/GHC/Handle.hs
@@ -157,6 +157,7 @@ withHandle_ :: String -> Handle -> (Handle__ -> IO a) -> IO a
 withHandle_ fun h@(FileHandle _ m)     act = withHandle_' fun h m act
 withHandle_ fun h@(DuplexHandle _ m _) act = withHandle_' fun h m act
 
+withHandle_' :: String -> Handle -> MVar Handle__ -> (Handle__ -> IO a) -> IO a
 withHandle_' fun h m act = 
    block $ do
    h_ <- takeMVar m
@@ -559,10 +560,10 @@ writeRawBufferPtr loc fd is_stream buf off len =
                (threadWaitWrite (fromIntegral fd))
 
 foreign import ccall unsafe "__hscore_PrelHandle_read"
-   read_rawBuffer :: FD -> RawBuffer -> Int -> CInt -> IO CInt
+   read_rawBuffer :: CInt -> RawBuffer -> Int -> CInt -> IO CInt
 
 foreign import ccall unsafe "__hscore_PrelHandle_read"
-   read_off :: FD -> Ptr CChar -> Int -> CInt -> IO CInt
+   read_off :: CInt -> Ptr CChar -> Int -> CInt -> IO CInt
 
 foreign import ccall unsafe "__hscore_PrelHandle_write"
    write_rawBuffer :: CInt -> RawBuffer -> Int -> CInt -> IO CInt
@@ -599,7 +600,7 @@ readRawBufferNoBlock = readRawBuffer
 -- Async versions of the read/write primitives, for the non-threaded RTS
 
 asyncReadRawBuffer loc fd is_stream buf off len = do
-    (l, rc) <- asyncReadBA fd (if is_stream then 1 else 0) 
+    (l, rc) <- asyncReadBA (fromIntegral fd) (if is_stream then 1 else 0) 
                 (fromIntegral len) off buf
     if l == (-1)
       then 
@@ -607,7 +608,7 @@ asyncReadRawBuffer loc fd is_stream buf off len = do
       else return (fromIntegral l)
 
 asyncReadRawBufferPtr loc fd is_stream buf off len = do
-    (l, rc) <- asyncRead fd (if is_stream then 1 else 0) 
+    (l, rc) <- asyncRead (fromIntegral fd) (if is_stream then 1 else 0) 
                        (fromIntegral len) (buf `plusPtr` off)
     if l == (-1)
       then 
@@ -615,7 +616,7 @@ asyncReadRawBufferPtr loc fd is_stream buf off len = do
       else return (fromIntegral l)
 
 asyncWriteRawBuffer loc fd is_stream buf off len = do
-    (l, rc) <- asyncWriteBA fd (if is_stream then 1 else 0) 
+    (l, rc) <- asyncWriteBA (fromIntegral fd) (if is_stream then 1 else 0) 
                        (fromIntegral len) off buf
     if l == (-1)
       then 
@@ -623,7 +624,7 @@ asyncWriteRawBuffer loc fd is_stream buf off len = do
       else return (fromIntegral l)
 
 asyncWriteRawBufferPtr loc fd is_stream buf off len = do
-    (l, rc) <- asyncWrite fd (if is_stream then 1 else 0) 
+    (l, rc) <- asyncWrite (fromIntegral fd) (if is_stream then 1 else 0) 
                  (fromIntegral len) (buf `plusPtr` off)
     if l == (-1)
       then 
@@ -664,10 +665,10 @@ blockingWriteRawBufferPtr loc fd False buf off len =
 -- These calls may block, but that's ok.
 
 foreign import ccall safe "__hscore_PrelHandle_read"
-   read_rawBuffer :: FD -> RawBuffer -> Int -> CInt -> IO CInt
+   read_rawBuffer :: CInt -> RawBuffer -> Int -> CInt -> IO CInt
 
 foreign import ccall safe "__hscore_PrelHandle_read"
-   read_off :: FD -> Ptr CChar -> Int -> CInt -> IO CInt
+   read_off :: CInt -> Ptr CChar -> Int -> CInt -> IO CInt
 
 foreign import ccall safe "__hscore_PrelHandle_write"
    write_rawBuffer :: CInt -> RawBuffer -> Int -> CInt -> IO CInt
@@ -676,10 +677,10 @@ foreign import ccall safe "__hscore_PrelHandle_write"
    write_off :: CInt -> Ptr CChar -> Int -> CInt -> IO CInt
 
 foreign import ccall safe "__hscore_PrelHandle_recv"
-   recv_rawBuffer :: FD -> RawBuffer -> Int -> CInt -> IO CInt
+   recv_rawBuffer :: CInt -> RawBuffer -> Int -> CInt -> IO CInt
 
 foreign import ccall safe "__hscore_PrelHandle_recv"
-   recv_off :: FD -> Ptr CChar -> Int -> CInt -> IO CInt
+   recv_off :: CInt -> Ptr CChar -> Int -> CInt -> IO CInt
 
 foreign import ccall safe "__hscore_PrelHandle_send"
    send_rawBuffer :: CInt -> RawBuffer -> Int -> CInt -> IO CInt
@@ -1064,7 +1065,7 @@ hClose_handle_ handle_ = do
     -- close the file descriptor, but not when this is the read
     -- side of a duplex handle.
     case haOtherSide handle_ of
-      Nothing -> 
+      Nothing ->
                  throwErrnoIfMinus1Retry_ "hClose" 
 #ifdef mingw32_HOST_OS
                                (closeFd (haIsStream handle_) fd)
@@ -1544,21 +1545,24 @@ foreign import ccall unsafe "__hscore_setmode"
 
 hDuplicate :: Handle -> IO Handle
 hDuplicate h@(FileHandle path m) = do
-  new_h_ <- withHandle' "hDuplicate" h m (dupHandle Nothing)
+  new_h_ <- withHandle' "hDuplicate" h m (dupHandle h Nothing)
   newFileHandle path (handleFinalizer path) new_h_
 hDuplicate h@(DuplexHandle path r w) = do
-  new_w_ <- withHandle' "hDuplicate" h w (dupHandle Nothing)
+  new_w_ <- withHandle' "hDuplicate" h w (dupHandle h Nothing)
   new_w <- newMVar new_w_
-  new_r_ <- withHandle' "hDuplicate" h r (dupHandle (Just new_w))
+  new_r_ <- withHandle' "hDuplicate" h r (dupHandle h (Just new_w))
   new_r <- newMVar new_r_
   addMVarFinalizer new_w (handleFinalizer path new_w)
   return (DuplexHandle path new_r new_w)
 
-dupHandle other_side h_ = do
+dupHandle :: Handle -> Maybe (MVar Handle__) -> Handle__
+          -> IO (Handle__, Handle__)
+dupHandle h other_side h_ = do
   -- flush the buffer first, so we don't have to copy its contents
   flushBuffer h_
-  new_fd <- throwErrnoIfMinus1 "dupHandle" $ 
-               c_dup (haFD h_)
+  new_fd <- case other_side of
+                Nothing -> throwErrnoIfMinus1 "dupHandle" $ c_dup (haFD h_)
+                Just r -> withHandle_' "dupHandle" h r (return . haFD)
   dupHandle_ other_side h_ new_fd
 
 dupHandleTo other_side hto_ h_ = do