% ------------------------------------------------------------------------------
-% $Id: PrelHandle.lhs,v 1.62 2000/09/14 14:24:02 simonmar Exp $
+% $Id: PrelHandle.lhs,v 1.67 2001/02/22 13:17:58 simonpj Exp $
%
% (c) The AQUA Project, Glasgow University, 1994-2000
%
import PrelArr
import PrelBase
-import PrelAddr ( Addr, nullAddr )
+import PrelPtr
import PrelByteArr ( ByteArray(..) )
import PrelRead ( Read )
-import PrelList ( span )
+import PrelList ( break )
import PrelIOBase
import PrelMaybe ( Maybe(..) )
import PrelException
import PrelEnum
-import PrelNum ( toBig, Integer(..), Num(..) )
+import PrelNum ( toBig, Integer(..), Num(..), int2Integer )
import PrelShow
-import PrelAddr ( Addr, nullAddr )
import PrelReal ( toInteger )
import PrelPack ( packString )
-#ifndef __PARALLEL_HASKELL__
-import PrelWeak ( addForeignFinalizer )
-#endif
import PrelConc
#ifndef __PARALLEL_HASKELL__
-import PrelForeign ( makeForeignObj, mkForeignObj )
+import PrelForeign ( newForeignPtr, mkForeignPtr, addForeignPtrFinalizer )
#endif
#endif /* ndef(__HUGS__) */
#endif
#ifndef __PARALLEL_HASKELL__
-#define FILE_OBJECT ForeignObj
+#define FILE_OBJECT (ForeignPtr ())
#else
-#define FILE_OBJECT Addr
+#define FILE_OBJECT (Ptr ())
#endif
\end{code}
mkBuffer__ fo sz_in_bytes = do
chunk <-
case sz_in_bytes of
- 0 -> return nullAddr -- this has the effect of overwriting the pointer to the old buffer.
+ 0 -> return nullPtr -- this has the effect of overwriting the pointer to the old buffer.
_ -> do
- chunk <- allocMemory__ sz_in_bytes
- if chunk == nullAddr
- then ioException (IOError Nothing ResourceExhausted "mkBuffer__" "not enough virtual memory")
+ chunk <- malloc sz_in_bytes
+ if chunk == nullPtr
+ then ioException (IOError Nothing ResourceExhausted
+ "mkBuffer__" "not enough virtual memory" Nothing)
else return chunk
setBuf fo chunk sz_in_bytes
\end{code}
nullFile__ :: FILE_OBJECT
nullFile__ =
#ifndef __PARALLEL_HASKELL__
- unsafePerformIO (makeForeignObj nullAddr (return ()))
+ unsafePerformIO (newForeignPtr nullPtr (return ()))
#else
- nullAddr
+ nullPtr
#endif
haFilePath__ = "closed file",
haBuffers__ = []
}
-
-mkErrorHandle__ :: IOException -> Handle__
-mkErrorHandle__ ioe =
- Handle__ { haFO__ = nullFile__,
- haType__ = (ErrorHandle ioe),
- haBufferMode__ = NoBuffering,
- haFilePath__ = "error handle",
- haBuffers__ = []
- }
\end{code}
%*********************************************************
foreign import "libHS_cbits" "freeFileObject" unsafe
freeFileObject :: FILE_OBJECT -> IO ()
foreign import "free" unsafe
- free :: Addr -> IO ()
+ free :: Ptr a -> IO ()
\end{code}
%*********************************************************
(0::Int){-writeable-} -- ConcHask: SAFE, won't block
#ifndef __PARALLEL_HASKELL__
- fo <- mkForeignObj fo
+ fo <- mkForeignPtr fo
-- I know this is deprecated, but I couldn't bring myself
- -- to move fixIO into the prelude just so I could use makeForeignObj.
- -- --SDM
+ -- to move fixIO into the prelude just so I could use
+ -- newForeignPtr. --SDM
#endif
#ifdef __HUGS__
hdl <- newHandle (Handle__ fo WriteHandle bm "stdout" [])
#ifndef __PARALLEL_HASKELL__
- addForeignFinalizer fo (stdHandleFinalizer hdl)
+ addForeignPtrFinalizer fo (stdHandleFinalizer hdl)
#endif
return hdl
- _ -> do ioError <- constructError "stdout"
- newHandle (mkErrorHandle__ ioError)
+ _ -> constructErrorAndFail "stdout"
)
stdin = unsafePerformIO (do
(1::Int){-readable-} -- ConcHask: SAFE, won't block
#ifndef __PARALLEL_HASKELL__
- fo <- mkForeignObj fo
+ fo <- mkForeignPtr fo
#endif
(bm, bf_size) <- getBMode__ fo
mkBuffer__ fo bf_size
-- that anything buffered on stdout is flushed prior to reading from
-- stdin.
#ifndef __PARALLEL_HASKELL__
- addForeignFinalizer fo (stdHandleFinalizer hdl)
+ addForeignPtrFinalizer fo (stdHandleFinalizer hdl)
#endif
hConnectTerms stdout hdl
return hdl
- _ -> do ioError <- constructError "stdin"
- newHandle (mkErrorHandle__ ioError)
+ _ -> constructErrorAndFail "stdin"
)
(0::Int){-writeable-} -- ConcHask: SAFE, won't block
#ifndef __PARALLEL_HASKELL__
- fo <- mkForeignObj fo
+ fo <- mkForeignPtr fo
#endif
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.
#ifndef __PARALLEL_HASKELL__
- addForeignFinalizer fo (stdHandleFinalizer hdl)
+ addForeignPtrFinalizer fo (stdHandleFinalizer hdl)
#endif
hConnectTo stdout hdl
return hdl
- _ -> do ioError <- constructError "stderr"
- newHandle (mkErrorHandle__ ioError)
+ _ -> constructErrorAndFail "stderr"
)
\end{code}
fo <- primOpenFile (packString f)
(file_mode::Int)
(binary::Int) -- ConcHask: SAFE, won't block
- if fo /= nullAddr then do
+ if fo /= nullPtr then do
#ifndef __PARALLEL_HASKELL__
- fo <- mkForeignObj fo
+ fo <- mkForeignPtr fo
#endif
(bm, bf_size) <- getBMode__ fo
mkBuffer__ fo bf_size
hdl <- newHandle (Handle__ fo htype bm f [])
#ifndef __PARALLEL_HASKELL__
- addForeignFinalizer fo (handleFinalizer hdl)
+ addForeignPtrFinalizer fo (handleFinalizer hdl)
#endif
return hdl
else do
hClose handle =
withHandle__ handle $ \ handle_ -> do
case haType__ handle_ of
- ErrorHandle theError -> ioException theError
ClosedHandle -> return handle_
_ -> do
rc <- closeFile (haFO__ handle_)
(1::Int){-flush if you can-} -- ConcHask: SAFE, won't block
{- We explicitly close a file object so that we can be told
if there were any errors. Note that after @hClose@
- has been performed, the ForeignObj embedded in the Handle
+ has been performed, the ForeignPtr embedded in the Handle
is still lying around in the heap, so care is taken
- to avoid closing the file object when the ForeignObj
+ to avoid closing the file object when the ForeignPtr
is finalized. (we overwrite the file ptr in the underlying
FileObject with a NULL as part of closeFile())
-}
hFileSize handle =
withHandle_ handle $ \ handle_ -> do
case haType__ handle_ of
- ErrorHandle theError -> ioException theError
ClosedHandle -> ioe_closedHandle "hFileSize" handle
SemiClosedHandle -> ioe_closedHandle "hFileSize" handle
#ifdef __HUGS__
(IOError (Just handle)
InvalidArgument
"hSetBuffering"
- ("illegal buffer size " ++ showsPrec 9 n []))
+ ("illegal buffer size " ++ showsPrec 9 n [])
-- 9 => should be parens'ified.
+ Nothing)
_ ->
withHandle__ handle $ \ handle_ -> do
case haType__ handle_ of
- ErrorHandle theError -> ioException theError
ClosedHandle -> ioe_closedHandle "hSetBuffering" handle
_ -> do
{- Note:
wantSeekableHandle "hGetPosn" handle $ \ handle_ -> do
posn <- getFilePosn (haFO__ handle_) -- ConcHask: SAFE, won't block
if posn /= -1 then do
- return (mkHandlePosn handle (fromInt posn))
+ return (mkHandlePosn handle (int2Integer posn))
else
constructErrorAndFail "hGetPosn"
hIsOpen handle =
withHandle_ handle $ \ handle_ -> do
case haType__ handle_ of
- ErrorHandle theError -> ioException theError
ClosedHandle -> return False
SemiClosedHandle -> return False
_ -> return True
hIsClosed handle =
withHandle_ handle $ \ handle_ -> do
case haType__ handle_ of
- ErrorHandle theError -> ioException theError
ClosedHandle -> return True
_ -> return False
hIsReadable handle =
withHandle_ handle $ \ handle_ -> do
case haType__ handle_ of
- ErrorHandle theError -> ioException theError
ClosedHandle -> ioe_closedHandle "hIsReadable" handle
SemiClosedHandle -> ioe_closedHandle "hIsReadable" handle
htype -> return (isReadable htype)
hIsWritable handle =
withHandle_ handle $ \ handle_ -> do
case haType__ handle_ of
- ErrorHandle theError -> ioException theError
ClosedHandle -> ioe_closedHandle "hIsWritable" handle
SemiClosedHandle -> ioe_closedHandle "hIsWritable" handle
htype -> return (isWritable htype)
hGetBuffering handle =
withHandle_ handle $ \ handle_ -> do
case haType__ handle_ of
- ErrorHandle theError -> ioException theError
ClosedHandle -> ioe_closedHandle "hGetBuffering" handle
_ ->
{-
hIsSeekable handle =
withHandle_ handle $ \ handle_ -> do
case haType__ handle_ of
- ErrorHandle theError -> ioException theError
ClosedHandle -> ioe_closedHandle "hIsSeekable" handle
SemiClosedHandle -> ioe_closedHandle "hIsSeekable" handle
AppendHandle -> return False
else
withHandle_ handle $ \ handle_ -> do
case haType__ handle_ of
- ErrorHandle theError -> ioException theError
ClosedHandle -> ioe_closedHandle "hSetEcho" handle
_ -> do
rc <- setTerminalEcho (haFO__ handle_) (if on then 1 else 0) -- ConcHask: SAFE, won't block
else
withHandle_ handle $ \ handle_ -> do
case haType__ handle_ of
- ErrorHandle theError -> ioException theError
ClosedHandle -> ioe_closedHandle "hGetEcho" handle
_ -> do
rc <- getTerminalEcho (haFO__ handle_) -- ConcHask: SAFE, won't block
hIsTerminalDevice handle = do
withHandle_ handle $ \ handle_ -> do
case haType__ handle_ of
- ErrorHandle theError -> ioException theError
ClosedHandle -> ioe_closedHandle "hIsTerminalDevice" handle
_ -> do
rc <- isTerminalDevice (haFO__ handle_) -- ConcHask: SAFE, won't block
\begin{code}
-- in one go, read file into an externally allocated buffer.
-slurpFile :: FilePath -> IO (Addr, Int)
+slurpFile :: FilePath -> IO (Ptr (), Int)
slurpFile fname = do
handle <- openFile fname ReadMode
sz <- hFileSize handle
ioError (userError "slurpFile: file too big")
else do
let sz_i = fromInteger sz
- chunk <- allocMemory__ sz_i
- if chunk == nullAddr
+ chunk <- malloc sz_i
+ if chunk == nullPtr
then do
hClose handle
constructErrorAndFail "slurpFile"
getHandleFd handle =
withHandle_ handle $ \ handle_ -> do
case (haType__ handle_) of
- ErrorHandle theError -> ioException theError
ClosedHandle -> ioe_closedHandle "getHandleFd" handle
_ -> do
fd <- getFileFd (haFO__ handle_)
ioeGetErrorString :: IOError -> String
ioeGetHandle :: IOError -> Maybe Handle
-ioeGetHandle (IOException (IOError h _ _ _)) = h
-ioeGetHandle _ = error "IO.ioeGetHandle: not an IO error"
+ioeGetHandle (IOException (IOError h _ _ _ _)) = h
+ioeGetHandle (UserError _) = Nothing
+ioeGetHandle _ = error "IO.ioeGetHandle: not an IO error"
-ioeGetErrorString (IOException (IOError _ iot _ str)) =
- case iot of
- EOF -> "end of file"
- _ -> str
-ioeGetErrorString _ = error "IO.ioeGetErrorString: not an IO error"
+ioeGetErrorString (IOException (IOError _ iot _ str _)) =
+ case iot of
+ EOF -> "end of file"
+ _ -> str
+ioeGetErrorString (UserError str) = str
+ioeGetErrorString _ = error "IO.ioeGetErrorString: not an IO error"
-ioeGetFileName (IOException (IOError _ _ _ str)) =
- case span (/=':') str of
- (_,[]) -> Nothing
- (fs,_) -> Just fs
-ioeGetFileName _ = error "IO.ioeGetFileName: not an IO error"
+ioeGetFileName (IOException (IOError _ _ _ _ fn)) = fn
+ioeGetFileName (UserError _) = Nothing
+ioeGetFileName _ = error "IO.ioeGetFileName: not an IO error"
\end{code}
'Top-level' IO actions want to catch exceptions (e.g., forkIO and
return ()
foreign import ccall "addrOf_ErrorHdrHook" unsafe
- addrOf_ErrorHdrHook :: Addr
+ addrOf_ErrorHdrHook :: Ptr ()
foreign import ccall "writeErrString__" unsafe
- writeErrString :: Addr -> ByteArray Int -> Int -> IO ()
+ writeErrString :: Ptr () -> ByteArray Int -> Int -> IO ()
-- SUP: Are the hooks allowed to re-enter Haskell land? If yes, remove the unsafe below.
foreign import ccall "stackOverflow" unsafe
wantReadableHandle fun handle act =
withHandle_ handle $ \ handle_ -> do
case haType__ handle_ of
- ErrorHandle theError -> ioException theError
ClosedHandle -> ioe_closedHandle fun handle
SemiClosedHandle -> ioe_closedHandle fun handle
AppendHandle -> ioException not_readable_error
_ -> act handle_
where
not_readable_error =
- IOError (Just handle) IllegalOperation fun
- ("handle is not open for reading")
+ IOError (Just handle) IllegalOperation fun
+ "handle is not open for reading" Nothing
wantWriteableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
wantWriteableHandle fun handle act =
checkWriteableHandle fun handle handle_ act
= case haType__ handle_ of
- ErrorHandle theError -> ioError (IOException theError)
ClosedHandle -> ioe_closedHandle fun handle
SemiClosedHandle -> ioe_closedHandle fun handle
- ReadHandle -> ioError not_writeable_error
+ ReadHandle -> ioException not_writeable_error
_ -> act
where
not_writeable_error =
- IOException (IOError (Just handle) IllegalOperation fun
- ("handle is not open for writing"))
+ IOError (Just handle) IllegalOperation fun
+ "handle is not open for writing" Nothing
wantRWHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
wantRWHandle fun handle act =
withHandle_ handle $ \ handle_ -> do
case haType__ handle_ of
- ErrorHandle theError -> ioException theError
ClosedHandle -> ioe_closedHandle fun handle
SemiClosedHandle -> ioe_closedHandle fun handle
_ -> act handle_
wantSeekableHandle fun handle act =
withHandle_ handle $ \ handle_ -> do
case haType__ handle_ of
- ErrorHandle theError -> ioException theError
ClosedHandle -> ioe_closedHandle fun handle
SemiClosedHandle -> ioe_closedHandle fun handle
_ -> act handle_
\begin{code}
ioe_closedHandle :: String -> Handle -> IO a
-ioe_closedHandle fun h = ioError (IOException (IOError (Just h) IllegalOperation fun
- "handle is closed"))
+ioe_closedHandle fun h = ioException (IOError (Just h) IllegalOperation fun
+ "handle is closed" Nothing)
\end{code}
Internal helper functions for Concurrent Haskell implementation
foreign import "libHS_cbits" "filePutc" unsafe
filePutc :: FILE_OBJECT -> Char -> IO Int{-ret code-}
foreign import "libHS_cbits" "write_" unsafe
- write_ :: FILE_OBJECT -> Addr -> Int -> IO Int{-ret code-}
+ write_ :: FILE_OBJECT -> Ptr () -> Int -> IO Int{-ret code-}
foreign import "libHS_cbits" "getBufStart" unsafe
- getBufStart :: FILE_OBJECT -> Int -> IO Addr
+ getBufStart :: FILE_OBJECT -> Int -> IO (Ptr ())
foreign import "libHS_cbits" "getWriteableBuf" unsafe
- getWriteableBuf :: FILE_OBJECT -> IO Addr
+ getWriteableBuf :: FILE_OBJECT -> IO (Ptr ())
foreign import "libHS_cbits" "getBuf" unsafe
- getBuf :: FILE_OBJECT -> IO Addr
+ getBuf :: FILE_OBJECT -> IO (Ptr ())
foreign import "libHS_cbits" "getBufWPtr" unsafe
getBufWPtr :: FILE_OBJECT -> IO Int
foreign import "libHS_cbits" "setBufWPtr" unsafe
foreign import "libHS_cbits" "ungetChar" unsafe
ungetChar :: FILE_OBJECT -> Char -> IO Int{-ret code-}
foreign import "libHS_cbits" "readChunk" unsafe
- readChunk :: FILE_OBJECT -> Addr -> Int -> Int -> IO Int{-ret code-}
+ readChunk :: FILE_OBJECT -> Ptr a -> Int -> Int -> IO Int{-ret code-}
foreign import "libHS_cbits" "getFileFd" unsafe
getFileFd :: FILE_OBJECT -> IO Int{-fd-}
#ifdef __HUGS__
foreign import "libHS_cbits" "getLock" unsafe
getLock :: Int{-Fd-} -> Int{-exclusive-} -> IO Int{-return code-}
foreign import "libHS_cbits" "openStdFile" unsafe
- openStdFile :: Int{-fd-} -> Int{-Readable?-} -> IO Addr{-file obj-}
+ openStdFile :: Int{-fd-}
+ -> Int{-Readable?-}
+ -> IO (Ptr ()){-file object-}
foreign import "libHS_cbits" "openFile" unsafe
primOpenFile :: ByteArray Int{-CString-}
-> Int{-How-}
-> Int{-Binary-}
- -> IO Addr {-file obj-}
+ -> IO (Ptr ()){-file object-}
foreign import "libHS_cbits" "const_BUFSIZ" unsafe
const_BUFSIZ :: Int
foreign import "libHS_cbits" "setBinaryMode__" unsafe
setBinaryMode :: FILE_OBJECT -> Int -> IO Int
\end{code}
-
-
projects / ghc-hetmet.git / blobdiff