-- Forign objects and weak pointers
foreignObjTyConName = tcQual fOREIGNOBJ_Name SLIT("ForeignObj") foreignObjTyConKey
foreignObjDataConName = dataQual fOREIGNOBJ_Name SLIT("ForeignObj") foreignObjDataConKey
-foreignPtrTyConName = tcQual pREL_IO_BASE_Name SLIT("ForeignPtr") foreignPtrTyConKey
-foreignPtrDataConName = dataQual pREL_IO_BASE_Name SLIT("ForeignPtr") foreignPtrDataConKey
+foreignPtrTyConName = tcQual pREL_FOREIGN_Name SLIT("ForeignPtr") foreignPtrTyConKey
+foreignPtrDataConName = dataQual pREL_FOREIGN_Name SLIT("ForeignPtr") foreignPtrDataConKey
stablePtrTyConName = tcQual pREL_STABLE_Name SLIT("StablePtr") stablePtrTyConKey
stablePtrDataConName = dataQual pREL_STABLE_Name SLIT("StablePtr") stablePtrDataConKey
deRefStablePtrName = varQual pREL_STABLE_Name SLIT("deRefStablePtr") deRefStablePtrIdKey
-- -----------------------------------------------------------------------------
--- $Id: CPUTime.hsc,v 1.2 2001/05/08 17:33:57 qrczak Exp $
+-- $Id: CPUTime.hsc,v 1.3 2001/05/18 16:54:04 simonmar Exp $
--
-- (c) The University of Glasgow, 1995-2001
--
unsafePerformIO, stToIO, ioException )
import Ratio
-#include "config.h"
-
-#ifdef HAVE_SYS_TYPES_H
-#include <sys/types.h>
-#endif
-
-#ifdef HAVE_UNISTD_H
-#include <unistd.h>
-#endif
-
-#ifndef mingw32_TARGET_OS
-# ifdef HAVE_SYS_TIMES_H
-# include <sys/times.h>
-# endif
-#endif
-
-#ifdef HAVE_SYS_TIME_H
-#include <sys/time.h>
-#endif
-
-#if !defined(mingw32_TARGET_OS) && !defined(irix_TARGET_OS)
-# if defined(HAVE_SYS_RESOURCE_H)
-# include <sys/resource.h>
-# endif
-#endif
-
-#ifdef hpux_TARGET_OS
-#include <sys/syscall.h>
-#define getrusage(a, b) syscall(SYS_GETRUSAGE, a, b)
-#define HAVE_GETRUSAGE
-#endif
-
-#ifdef HAVE_WINDOWS_H
-# include <windows.h>
-#endif
+#include "HsStd.h"
-- -----------------------------------------------------------------------------
-- Computation `getCPUTime' returns the number of picoseconds CPU time
-- -----------------------------------------------------------------------------
--- $Id: Directory.hsc,v 1.10 2001/04/02 16:10:32 rrt Exp $
+-- $Id: Directory.hsc,v 1.11 2001/05/18 16:54:04 simonmar Exp $
--
-- (c) The University of Glasgow, 1994-2000
--
import Time ( ClockTime(..) )
+import PrelPosix
import PrelStorable
import PrelCString
import PrelMarshalAlloc
import PrelCTypesISO
import PrelCTypes
-import PrelPosixTypes
import PrelCError
import PrelPtr
import PrelIOBase
foreign import ccall unsafe stat :: UCString -> Ptr CStat -> IO CInt
type CDirent = ()
-type CStat = ()
% -----------------------------------------------------------------------------
-% $Id: IO.lhs,v 1.40 2000/06/30 13:39:35 simonmar Exp $
+% $Id: IO.lhs,v 1.41 2001/05/18 16:54:04 simonmar Exp $
%
% (c) The University of Glasgow, 1994-2000
%
) where
-#ifndef __HUGS__
import PrelIOBase -- Together these four Prelude modules define
+import PrelRead
import PrelHandle -- all the stuff exported by IO for the GHC version
import PrelIO
import PrelException
-
-
--- The entire rest of this module is just Hugs
-
-#else /* ifndef __HUGS__ */
-
-import Ix(Ix)
-import PrelPrim ( IORef
- , unsafePerformIO
- , prelCleanupAfterRunAction
- , copy_String_to_cstring
- , primIntToChar
- , primWriteCharOffAddr
- , nullAddr
- , newIORef
- , writeIORef
- , readIORef
- , nh_close
- , nh_errno
- , nh_stdin
- , nh_stdout
- , nh_stderr
- , nh_flush
- , nh_open
- , nh_free
- , nh_read
- , nh_write
- , nh_filesize
- , nh_iseof
- )
\end{code}
-
-
-%*********************************************************
-%* *
-\subsection{The HUGS version of IO
-%* *
-%*********************************************************
-
-\begin{code}
-import Ix(Ix)
-import Monad(when)
-
-unimp :: String -> a
-unimp s = error ("IO library: function not implemented: " ++ s)
-
-type FILE_STAR = Addr
-type Ptr = Addr
-nULL = nullAddr
-
-data Handle
- = Handle { name :: FilePath,
- file :: FILE_STAR, -- C handle
- mut :: IORef Handle_Mut, -- open/closed/semiclosed
- mode :: IOMode,
- seekable :: Bool
- }
-
-data Handle_Mut
- = Handle_Mut { state :: HState
- }
- deriving Show
-
-set_state :: Handle -> HState -> IO ()
-set_state hdl new_state
- = writeIORef (mut hdl) (Handle_Mut { state = new_state })
-get_state :: Handle -> IO HState
-get_state hdl
- = readIORef (mut hdl) >>= \m -> return (state m)
-
-mkErr :: Handle -> String -> IO a
-mkErr h msg
- = do mut <- readIORef (mut h)
- when (state mut /= HClosed)
- (nh_close (file h) >> set_state h HClosed)
- dummy <- nh_errno
- ioError (IOError msg)
-
-stdin
- = Handle {
- name = "stdin",
- file = unsafePerformIO nh_stdin,
- mut = unsafePerformIO (newIORef (Handle_Mut { state = HOpen })),
- mode = ReadMode
- }
-
-stdout
- = Handle {
- name = "stdout",
- file = unsafePerformIO nh_stdout,
- mut = unsafePerformIO (newIORef (Handle_Mut { state = HOpen })),
- mode = WriteMode
- }
-
-stderr
- = Handle {
- name = "stderr",
- file = unsafePerformIO nh_stderr,
- mut = unsafePerformIO (newIORef (Handle_Mut { state = HOpen })),
- mode = WriteMode
- }
-
-
-instance Eq Handle where
- h1 == h2 = file h1 == file h2
-
-instance Show Handle where
- showsPrec _ h = showString ("`" ++ name h ++ "'")
-
-data HandlePosn
- = HandlePosn
- deriving (Eq, Show)
-
-
-data IOMode = ReadMode | WriteMode | AppendMode | ReadWriteMode
- deriving (Eq, Ord, Ix, Bounded, Enum, Read, Show)
-
-data BufferMode = NoBuffering | LineBuffering
- | BlockBuffering (Maybe Int)
- deriving (Eq, Ord, Read, Show)
-
-data SeekMode = AbsoluteSeek | RelativeSeek | SeekFromEnd
- deriving (Eq, Ord, Ix, Bounded, Enum, Read, Show)
-
-data HState = HOpen | HSemiClosed | HClosed
- deriving (Show, Eq)
-
-
--- A global variable holding a list of all open handles.
--- Each handle is present as many times as it has been opened.
--- Any given file is allowed to have _either_ one writeable handle
--- or many readable handles in this list. The list is used to
--- enforce single-writer multiple reader semantics. It also
--- provides a list of handles for System.exitWith to flush and
--- close. In order not to have to put all this stuff in the
--- Prelude, System.exitWith merely runs prelExitWithAction,
--- which is originally Nothing, but which we set to Just ...
--- once handles appear in the list.
-
-allHandles :: IORef [Handle]
-allHandles = unsafePerformIO (newIORef [])
-
-elemWriterHandles :: FilePath -> IO Bool
-elemAllHandles :: FilePath -> IO Bool
-addHandle :: Handle -> IO ()
-delHandle :: Handle -> IO ()
-cleanupHandles :: IO ()
-
-cleanupHandles
- = do hdls <- readIORef allHandles
- mapM_ cleanupHandle hdls
- where
- cleanupHandle h
- | mode h == ReadMode
- = nh_close (file h)
- >> nh_errno >>= \_ -> return ()
- | otherwise
- = nh_flush (file h) >> nh_close (file h)
- >> nh_errno >>= \_ -> return ()
-
-elemWriterHandles fname
- = do hdls <- readIORef allHandles
- let hdls_w = filter ((/= ReadMode).mode) hdls
- return (fname `elem` (map name hdls_w))
-
-elemAllHandles fname
- = do hdls <- readIORef allHandles
- return (fname `elem` (map name hdls))
-
-addHandle hdl
- = do cleanup_action <- readIORef prelCleanupAfterRunAction
- case cleanup_action of
- Nothing
- -> writeIORef prelCleanupAfterRunAction (Just cleanupHandles)
- Just xx
- -> return ()
- hdls <- readIORef allHandles
- writeIORef allHandles (hdl : hdls)
-
-delHandle hdl
- = do hdls <- readIORef allHandles
- let hdls' = takeWhile (/= hdl) hdls
- ++ drop 1 (dropWhile (/= hdl) hdls)
- writeIORef allHandles hdls'
-
-
-
-openFile :: FilePath -> IOMode -> IO Handle
-openFile f mode
-
- | null f
- = (ioError.IOError) "openFile: empty file name"
-
- | mode == ReadMode
- = do not_ok <- elemWriterHandles f
- if not_ok
- then (ioError.IOError)
- ("openFile: `" ++ f ++ "' in " ++ show mode
- ++ ": is already open for writing")
- else openFile_main f mode
-
- | mode /= ReadMode
- = do not_ok <- elemAllHandles f
- if not_ok
- then (ioError.IOError)
- ("openFile: `" ++ f ++ "' in " ++ show mode
- ++ ": is already open for reading or writing")
- else openFile_main f mode
-
- | otherwise
- = openFile_main f mode
-
-openFile_main f mode
- = copy_String_to_cstring f >>= \nameptr ->
- nh_open nameptr (mode2num mode) >>= \fh ->
- nh_free nameptr >>
- if fh == nULL
- then (ioError.IOError)
- ("openFile: can't open <<" ++ f ++ ">> in " ++ show mode)
- else do r <- newIORef (Handle_Mut { state = HOpen })
- let hdl = Handle { name = f, file = fh,
- mut = r, mode = mode }
- addHandle hdl
- return hdl
- where
- mode2num :: IOMode -> Int
- mode2num ReadMode = 0
- mode2num WriteMode = 1
- mode2num AppendMode = 2
- mode2num ReadWriteMode
- = error
- ("openFile <<" ++ f ++ ">>: ReadWriteMode not supported")
-
-hClose :: Handle -> IO ()
-hClose h
- = do mut <- readIORef (mut h)
- if state mut == HClosed
- then mkErr h
- ("hClose on closed handle " ++ show h)
- else
- do set_state h HClosed
- delHandle h
- nh_close (file h)
- err <- nh_errno
- if err == 0
- then return ()
- else mkErr h
- ("hClose: error closing " ++ name h)
-
-hGetContents :: Handle -> IO String
-hGetContents h
- | mode h /= ReadMode
- = mkErr h ("hGetContents on non-ReadMode handle " ++ show h)
- | otherwise
- = do mut <- readIORef (mut h)
- if state mut /= HOpen
- then mkErr h
- ("hGetContents on closed/semiclosed handle " ++ show h)
- else
- do set_state h HSemiClosed
- read_all (file h)
- where
- read_all f
- = nh_read f >>= \ci ->
- if ci == -1
- then return []
- else read_all f >>= \rest ->
- return ((primIntToChar ci):rest)
-
-hPutStr :: Handle -> String -> IO ()
-hPutStr h s
- | mode h == ReadMode
- = mkErr h ("hPutStr on ReadMode handle " ++ show h)
- | otherwise
- = do mut <- readIORef (mut h)
- if state mut /= HOpen
- then mkErr h
- ("hPutStr on closed/semiclosed handle " ++ show h)
- else write_all (file h) s
- where
- write_all f []
- = return ()
- write_all f (c:cs)
- = nh_write f c >> write_all f cs
-
-hFileSize :: Handle -> IO Integer
-hFileSize h
- = do sz <- nh_filesize (file h)
- er <- nh_errno
- if er == 0
- then return (fromIntegral sz)
- else mkErr h ("hFileSize on " ++ show h)
-
-hIsEOF :: Handle -> IO Bool
-hIsEOF h
- = do iseof <- nh_iseof (file h)
- er <- nh_errno
- if er == 0
- then return (iseof /= 0)
- else mkErr h ("hIsEOF on " ++ show h)
-
-isEOF :: IO Bool
-isEOF = hIsEOF stdin
-
-hSetBuffering :: Handle -> BufferMode -> IO ()
-hSetBuffering = unimp "IO.hSetBuffering"
-hGetBuffering :: Handle -> IO BufferMode
-hGetBuffering = unimp "IO.hGetBuffering"
-
-hFlush :: Handle -> IO ()
-hFlush h
- = do mut <- readIORef (mut h)
- if state mut /= HOpen
- then mkErr h
- ("hFlush on closed/semiclosed file " ++ name h)
- else nh_flush (file h)
-
-hGetPosn :: Handle -> IO HandlePosn
-hGetPosn = unimp "IO.hGetPosn"
-hSetPosn :: HandlePosn -> IO ()
-hSetPosn = unimp "IO.hSetPosn"
-hSeek :: Handle -> SeekMode -> Integer -> IO ()
-hSeek = unimp "IO.hSeek"
-hWaitForInput :: Handle -> Int -> IO Bool
-hWaitForInput = unimp "hWaitForInput"
-hReady :: Handle -> IO Bool
-hReady h = unimp "hReady" -- hWaitForInput h 0
-
-hGetChar :: Handle -> IO Char
-hGetChar h
- = nh_read (file h) >>= \ci ->
- return (primIntToChar ci)
-
-hGetLine :: Handle -> IO String
-hGetLine h = do c <- hGetChar h
- if c=='\n' then return ""
- else do cs <- hGetLine h
- return (c:cs)
-
-hLookAhead :: Handle -> IO Char
-hLookAhead = unimp "IO.hLookAhead"
-
-
-hPutChar :: Handle -> Char -> IO ()
-hPutChar h c = hPutStr h [c]
-
-hPutStrLn :: Handle -> String -> IO ()
-hPutStrLn h s = do { hPutStr h s; hPutChar h '\n' }
-
-hPrint :: Show a => Handle -> a -> IO ()
-hPrint h = hPutStrLn h . show
-
-hIsOpen, hIsClosed, hIsReadable, hIsWritable :: Handle -> IO Bool
-hIsOpen h = do { s <- get_state h; return (s == HOpen) }
-hIsClosed h = do { s <- get_state h; return (s == HClosed) }
-hIsReadable h = return (mode h == ReadMode)
-hIsWritable h = return (mode h `elem` [WriteMode, AppendMode])
-
-hIsSeekable :: Handle -> IO Bool
-hIsSeekable = unimp "IO.hIsSeekable"
-
-isIllegalOperation,
- isAlreadyExistsError,
- isDoesNotExistError,
- isAlreadyInUseError,
- isFullError,
- isEOFError,
- isPermissionError,
- isUserError :: IOError -> Bool
-
-isIllegalOperation = unimp "IO.isIllegalOperation"
-isAlreadyExistsError = unimp "IO.isAlreadyExistsError"
-isDoesNotExistError = unimp "IO.isDoesNotExistError"
-isAlreadyInUseError = unimp "IO.isAlreadyInUseError"
-isFullError = unimp "IO.isFullError"
-isEOFError = unimp "IO.isEOFError"
-isPermissionError = unimp "IO.isPermissionError"
-isUserError = unimp "IO.isUserError"
-
-
-ioeGetErrorString :: IOError -> String
-ioeGetErrorString = unimp "IO.ioeGetErrorString"
-ioeGetHandle :: IOError -> Maybe Handle
-ioeGetHandle = unimp "IO.ioeGetHandle"
-ioeGetFileName :: IOError -> Maybe FilePath
-ioeGetFileName = unimp "IO.ioeGetFileName"
-
-try :: IO a -> IO (Either IOError a)
-try p = catch (p >>= (return . Right)) (return . Left)
-
-bracket :: IO a -> (a -> IO b) -> (a -> IO c) -> IO c
-bracket before after m = do
- x <- before
- rs <- try (m x)
- after x
- case rs of
- Right r -> return r
- Left e -> ioError e
-
--- variant of the above where middle computation doesn't want x
-bracket_ :: IO a -> (a -> IO b) -> IO c -> IO c
-bracket_ before after m = do
- x <- before
- rs <- try m
- after x
- case rs of
- Right r -> return r
- Left e -> ioError e
-
--- TODO: Hugs/slurpFile
-slurpFile = unimp "IO.slurpFile"
-\end{code}
-
-#endif /* #ifndef __HUGS__ */
SRC_HC_OPTS += -cpp -fvia-C -fglasgow-exts $(GhcLibHcOpts) $(PACKAGE)
+SRC_HSC2HS_OPTS += -Icbits
+
ifdef USE_REPORT_PRELUDE
SRC_HC_OPTS += -DUSE_REPORT_PRELUDE=1
endif
+# ESSENTIAL, for getting reasonable performance from the I/O library:
+PrelIOBase_HC_OPTS = -funbox-strict-fields
+
+# debugging...
+PrelIOBase_HC_OPTS += -fno-ignore-asserts
+PrelHandle_HC_OPTS += -fno-ignore-asserts
+PrelIO_HC_OPTS += -fno-ignore-asserts
+
# Special options
PrelStorable_HC_OPTS = -monly-3-regs
PrelCError_HC_OPTS = +RTS -K4m -RTS
% -----------------------------------------------------------------------------
-% $Id: Monad.lhs,v 1.12 2001/04/04 06:51:46 qrczak Exp $
+% $Id: Monad.lhs,v 1.13 2001/05/18 16:54:05 simonmar Exp $
%
% (c) The University of Glasgow, 1994-2000
%
\section[Monad]{Module @Monad@}
\begin{code}
+{-# OPTIONS -fno-implicit-prelude #-}
+
module Monad
( MonadPlus ( -- class context: Monad
mzero -- :: (MonadPlus m) => m a
, (=<<) -- :: (Monad m) => (a -> m b) -> m a -> m b
) where
-import Prelude
+import PrelList
+import PrelMaybe
+import PrelBase
+
+infixr 1 =<<
+\end{code}
+
+%*********************************************************
+%* *
+\subsection{Prelude monad functions}
+%* *
+%*********************************************************
+
+\begin{code}
+{-# SPECIALISE (=<<) :: (a -> [b]) -> [a] -> [b] #-}
+(=<<) :: Monad m => (a -> m b) -> m a -> m b
+f =<< x = x >>= f
+
+sequence :: Monad m => [m a] -> m [a]
+{-# INLINE sequence #-}
+sequence ms = foldr k (return []) ms
+ where
+ k m m' = do { x <- m; xs <- m'; return (x:xs) }
+
+sequence_ :: Monad m => [m a] -> m ()
+{-# INLINE sequence_ #-}
+sequence_ ms = foldr (>>) (return ()) ms
+
+mapM :: Monad m => (a -> m b) -> [a] -> m [b]
+{-# INLINE mapM #-}
+mapM f as = sequence (map f as)
+
+mapM_ :: Monad m => (a -> m b) -> [a] -> m ()
+{-# INLINE mapM_ #-}
+mapM_ f as = sequence_ (map f as)
\end{code}
%*********************************************************
individual operations.
\begin{code}
+{-# OPTIONS -fno-implicit-prelude #-}
#include "MachDeps.h"
module PrelBits where
-import Prelude -- To generate the dependency
#ifdef __GLASGOW_HASKELL__
import PrelGHC
import PrelBase
% -----------------------------------------------------------------------------
-% $Id: PrelByteArr.lhs,v 1.13 2001/02/22 16:48:24 qrczak Exp $
+% $Id: PrelByteArr.lhs,v 1.14 2001/05/18 16:54:05 simonmar Exp $
%
% (c) The University of Glasgow, 1994-2000
%
%* *
%*********************************************************
-Idle ADR question: What's the tradeoff here between flattening these
-datatypes into @MutableArray ix ix (MutableArray# s elt)@ and using
-it as is? As I see it, the former uses slightly less heap and
-provides faster access to the individual parts of the bounds while the
-code used has the benefit of providing a ready-made @(lo, hi)@ pair as
-required by many array-related functions. Which wins? Is the
-difference significant (probably not).
-
-Idle AJG answer: When I looked at the outputted code (though it was 2
-years ago) it seems like you often needed the tuple, and we build
-it frequently. Now we've got the overloading specialiser things
-might be different, though.
-
\begin{code}
newCharArray, newIntArray, newFloatArray, newDoubleArray
:: Ix ix => (ix,ix) -> ST s (MutableByteArray s ix)
% -----------------------------------------------------------------------------
-% $Id: PrelCError.lhs,v 1.7 2001/03/16 21:47:41 qrczak Exp $
+% $Id: PrelCError.lhs,v 1.8 2001/05/18 16:54:05 simonmar Exp $
%
% (c) The FFI task force, 2000
%
C-specific Marshalling support: Handling of C "errno" error codes
\begin{code}
-{-# OPTIONS -fno-implicit-prelude -#include "cbits/ghc_errno.h" #-}
+{-# OPTIONS -fno-implicit-prelude -#include "HsStd.h" #-}
-- this is were we get the CCONST_XXX definitions from that configure
-- calculated for us
throwErrnoIf_, -- :: (a -> Bool) -> String -> IO a -> IO ()
throwErrnoIfRetry, -- :: (a -> Bool) -> String -> IO a -> IO a
throwErrnoIfRetry_, -- :: (a -> Bool) -> String -> IO a -> IO ()
+ throwErrnoIfRetry_, -- :: (a -> Bool) -> String -> IO a -> IO ()
throwErrnoIfMinus1, -- :: Num a
-- => String -> IO a -> IO a
throwErrnoIfMinus1_, -- :: Num a
-- :: Num a
-- => String -> IO a -> IO ()
throwErrnoIfNull, -- :: String -> IO (Ptr a) -> IO (Ptr a)
- throwErrnoIfNullRetry -- :: String -> IO (Ptr a) -> IO (Ptr a)
+ throwErrnoIfNullRetry,-- :: String -> IO (Ptr a) -> IO (Ptr a)
+
+ throwErrnoIfRetryMayBlock,
+ throwErrnoIfRetryMayBlock_,
+ throwErrnoIfMinus1RetryMayBlock,
+ throwErrnoIfMinus1RetryMayBlock_,
+ throwErrnoIfNullRetryMayBlock
) where
-- GHC allows us to get at the guts inside IO errors/exceptions
--
#if __GLASGOW_HASKELL__
-#if __GLASGOW_HASKELL__ < 409
-import PrelIOBase (IOError(..), IOErrorType(..))
-#else
import PrelIOBase (Exception(..), IOException(..), IOErrorType(..))
-#endif
#endif /* __GLASGOW_HASKELL__ */
-- regular imports
-- ---------------
-import Monad (liftM)
-
#if __GLASGOW_HASKELL__
import PrelStorable
import PrelMarshalError
-- yield the current thread's "errno" value
--
getErrno :: IO Errno
-getErrno = liftM Errno (peek _errno)
-
+getErrno = do e <- peek _errno; return (Errno e)
-- set the current thread's "errno" value to 0
--
else throwErrno loc
else return res
+-- as `throwErrnoIfRetry', but checks for operations that would block and
+-- executes an alternative action in that case.
+
+throwErrnoIfRetryMayBlock :: (a -> Bool) -> String -> IO a -> IO b -> IO a
+throwErrnoIfRetryMayBlock pred loc f on_block =
+ do
+ res <- f
+ if pred res
+ then do
+ err <- getErrno
+ if err == eINTR
+ then throwErrnoIfRetryMayBlock pred loc f on_block
+ else if err == eWOULDBLOCK || err == eAGAIN
+ then do on_block; throwErrnoIfRetryMayBlock pred loc f on_block
+ else throwErrno loc
+ else return res
+
-- as `throwErrnoIfRetry', but discards the result
--
throwErrnoIfRetry_ :: (a -> Bool) -> String -> IO a -> IO ()
throwErrnoIfRetry_ pred loc f = void $ throwErrnoIfRetry pred loc f
+-- as `throwErrnoIfRetryMayBlock', but discards the result
+--
+throwErrnoIfRetryMayBlock_ :: (a -> Bool) -> String -> IO a -> IO b -> IO ()
+throwErrnoIfRetryMayBlock_ pred loc f on_block
+ = void $ throwErrnoIfRetryMayBlock pred loc f on_block
+
-- throws "errno" if a result of "-1" is returned
--
throwErrnoIfMinus1 :: Num a => String -> IO a -> IO a
throwErrnoIfMinus1Retry_ :: Num a => String -> IO a -> IO ()
throwErrnoIfMinus1Retry_ = throwErrnoIfRetry_ (== -1)
+-- as throwErrnoIfMinus1Retry, but checks for operations that would block
+--
+throwErrnoIfMinus1RetryMayBlock :: Num a => String -> IO a -> IO b -> IO a
+throwErrnoIfMinus1RetryMayBlock = throwErrnoIfRetryMayBlock (== -1)
+
+-- as `throwErrnoIfMinus1RetryMayBlock', but discards the result
+--
+throwErrnoIfMinus1RetryMayBlock_ :: Num a => String -> IO a -> IO b -> IO ()
+throwErrnoIfMinus1RetryMayBlock_ = throwErrnoIfRetryMayBlock_ (== -1)
+
-- throws "errno" if a result of a NULL pointer is returned
--
throwErrnoIfNull :: String -> IO (Ptr a) -> IO (Ptr a)
throwErrnoIfNullRetry :: String -> IO (Ptr a) -> IO (Ptr a)
throwErrnoIfNullRetry = throwErrnoIfRetry (== nullPtr)
+-- as throwErrnoIfNullRetry, but checks for operations that would block
+--
+throwErrnoIfNullRetryMayBlock :: String -> IO (Ptr a) -> IO b -> IO (Ptr a)
+throwErrnoIfNullRetryMayBlock = throwErrnoIfRetryMayBlock (== nullPtr)
-- conversion of an "errno" value into IO error
-- --------------------------------------------
% -----------------------------------------------------------------------------
-% $Id: PrelCString.lhs,v 1.3 2001/04/14 22:28:46 qrczak Exp $
+% $Id: PrelCString.lhs,v 1.4 2001/05/18 16:54:05 simonmar Exp $
%
% (c) The FFI task force, 2000
%
Utilities for primitive marshaling
\begin{code}
-module PrelCString where
+{-# OPTIONS -fno-implicit-prelude #-}
-import Monad
+module PrelCString where
+#ifdef __GLASGOW_HASKELL__
import PrelMarshalArray
import PrelPtr
import PrelStorable
import PrelWord
import PrelByteArr
import PrelPack
+import PrelList
+import PrelReal
+import PrelNum
+import PrelIOBase
import PrelBase
-
-#ifdef __GLASGOW_HASKELL__
-import PrelIOBase hiding (malloc, _malloc)
#endif
-----------------------------------------------------------------------------
-- marshal a NUL terminated C string into a Haskell string
--
peekCString :: CString -> IO String
-peekCString cp = liftM cCharsToChars $ peekArray0 nUL cp
+peekCString cp = do cs <- peekArray0 nUL cp; return (cCharsToChars cs)
-- marshal a C string with explicit length into a Haskell string
--
peekCStringLen :: CStringLen -> IO String
-peekCStringLen (cp, len) = liftM cCharsToChars $ peekArray len cp
+peekCStringLen (cp, len) = do cs <- peekArray len cp; return (cCharsToChars cs)
-- marshal a Haskell string into a NUL terminated C strings
--
-- * new storage is allocated for the C string and must be explicitly freed
--
newCStringLen :: String -> IO CStringLen
-newCStringLen str = liftM (pairLength str) $ newArray (charsToCChars str)
+newCStringLen str = do a <- newArray (charsToCChars str)
+ return (pairLength str a)
-- marshal a Haskell string into a NUL terminated C strings using temporary
-- storage
% -----------------------------------------------------------------------------
-% $Id: PrelCTypes.lhs,v 1.3 2001/02/22 16:48:24 qrczak Exp $
+% $Id: PrelCTypes.lhs,v 1.4 2001/05/18 16:54:05 simonmar Exp $
%
% (c) The FFI task force, 2000
%
#include "cbits/CTypes.h"
\begin{code}
+{-# OPTIONS -fno-implicit-prelude #-}
+
module PrelCTypes
( -- Integral types, instances of: Eq, Ord, Num, Read, Show, Enum,
-- Typeable, Storable, Bounded, Real, Integral, Bits
\end{code}
\begin{code}
-import PrelBase ( unsafeCoerce# )
+import PrelBase
+import PrelFloat
+import PrelEnum
+import PrelReal
+import PrelShow
+import PrelRead
+import PrelNum
import PrelBits ( Bits(..) )
import PrelInt ( Int8, Int16, Int32, Int64 )
import PrelWord ( Word8, Word16, Word32, Word64 )
% -----------------------------------------------------------------------------
-% $Id: PrelCTypesISO.lhs,v 1.5 2001/02/22 16:48:24 qrczak Exp $
+% $Id: PrelCTypesISO.lhs,v 1.6 2001/05/18 16:54:05 simonmar Exp $
%
% (c) The FFI task force, 2000
%
#include "cbits/CTypes.h"
\begin{code}
+{-# OPTIONS -fno-implicit-prelude #-}
+
module PrelCTypesISO
( -- Integral types, instances of: Eq, Ord, Num, Read, Show, Enum,
-- Typeable, Storable, Bounded, Real, Integral, Bits
\end{code}
\begin{code}
+import PrelBase
+import PrelFloat
+import PrelEnum
+import PrelReal
+import PrelShow
+import PrelRead
+import PrelNum
import PrelBase ( unsafeCoerce# )
import PrelBits ( Bits(..) )
import PrelInt ( Int8, Int16, Int32, Int64 )
% -----------------------------------------------------------------------------
-% $Id: PrelConc.lhs,v 1.23 2001/02/15 10:02:43 simonmar Exp $
+% $Id: PrelConc.lhs,v 1.24 2001/05/18 16:54:05 simonmar Exp $
%
% (c) The University of Glasgow, 1994-2000
%
, tryTakeMVar -- :: MVar a -> IO (Maybe a)
, tryPutMVar -- :: MVar a -> a -> IO Bool
, isEmptyMVar -- :: MVar a -> IO Bool
+ , addMVarFinalizer -- :: MVar a -> IO () -> IO ()
) where
isEmptyMVar (MVar mv#) = IO $ \ s# ->
case isEmptyMVar# mv# s# of
(# s2#, flg #) -> (# s2#, not (flg ==# 0#) #)
+
+-- Like addForeignPtrFinalizer, but for MVars
+addMVarFinalizer :: MVar a -> IO () -> IO ()
+addMVarFinalizer (MVar m) finalizer =
+ IO $ \s -> case mkWeak# m () finalizer s of { (# s1, w #) -> (# s1, () #) }
\end{code}
% -----------------------------------------------------------------------------
-% $Id: PrelErr.lhs,v 1.18 2000/06/30 13:39:35 simonmar Exp $
+% $Id: PrelErr.lhs,v 1.19 2001/05/18 16:54:05 simonmar Exp $
%
% (c) The University of Glasgow, 1994-2000
%
, error -- :: String -> a
, assertError -- :: String -> Bool -> a -> a
+ , undefined -- :: a
) where
import PrelBase
-- error stops execution and displays an error message
error :: String -> a
error s = throw (ErrorCall s)
+
+-- It is expected that compilers will recognize this and insert error
+-- messages which are more appropriate to the context in which undefined
+-- appears.
+
+undefined :: a
+undefined = error "Prelude.undefined"
\end{code}
%*********************************************************
% ------------------------------------------------------------------------------
-% $Id: PrelForeign.lhs,v 1.18 2001/03/22 03:51:09 hwloidl Exp $
+% $Id: PrelForeign.lhs,v 1.19 2001/05/18 16:54:05 simonmar Exp $
%
% (c) The University of Glasgow, 1994-2000
%
module PrelForeign where
import PrelIOBase
+import PrelNum -- for fromInteger
import PrelBase
import PrelPtr
\end{code}
%*********************************************************
\begin{code}
+data ForeignPtr a = ForeignPtr ForeignObj#
+instance CCallable (ForeignPtr a)
+
+eqForeignPtr :: ForeignPtr a -> ForeignPtr a -> Bool
+eqForeignPtr mp1 mp2
+ = unsafePerformIO (primEqForeignPtr mp1 mp2) /= (0::Int)
+
+foreign import "eqForeignObj" unsafe
+ primEqForeignPtr :: ForeignPtr a -> ForeignPtr a -> IO Int
+
+instance Eq (ForeignPtr a) where
+ p == q = eqForeignPtr p q
+ p /= q = not (eqForeignPtr p q)
newForeignPtr :: Ptr a -> IO () -> IO (ForeignPtr a)
newForeignPtr p finalizer
--- /dev/null
+{-# OPTIONS -fno-implicit-prelude #-}
+
+#undef DEBUG_DUMP
+#undef DEBUG
+
+-- -----------------------------------------------------------------------------
+-- $Id: PrelHandle.hsc,v 1.1 2001/05/18 16:54:05 simonmar Exp $
+--
+-- (c) The University of Glasgow, 1994-2001
+--
+-- This module defines the basic operations on I/O "handles".
+
+module PrelHandle (
+ withHandle, withHandle_,
+ wantWritableHandle, wantReadableHandle, wantSeekableHandle,
+
+ newEmptyBuffer, allocateBuffer, readCharFromBuffer, writeCharIntoBuffer,
+ flushWriteBufferOnly, flushWriteBuffer, flushReadBuffer, fillReadBuffer,
+ read_off,
+
+ ioe_closedHandle, ioe_EOF,
+
+ stdin, stdout, stderr,
+ IOMode(..), IOModeEx(..), openFile, openFileEx, openFd,
+ hClose, hFileSize, hIsEOF, isEOF, hLookAhead, hSetBuffering, hSetBinaryMode,
+ hFlush,
+
+ HandlePosn(..), hGetPosn, hSetPosn,
+ SeekMode(..), hSeek,
+
+ hIsOpen, hIsClosed, hIsReadable, hIsWritable, hGetBuffering, hIsSeekable,
+ hSetEcho, hGetEcho, hIsTerminalDevice,
+ ioeGetFileName, ioeGetErrorString, ioeGetHandle,
+
+#ifdef DEBUG_DUMP
+ puts,
+#endif
+
+ ) where
+
+#include "HsStd.h"
+
+import Monad
+
+import PrelBits
+import PrelPosix
+import PrelMarshalUtils
+import PrelCString
+import PrelCTypes
+import PrelCError
+import PrelReal
+
+import PrelArr
+import PrelBase
+import PrelPtr
+import PrelRead ( Read )
+import PrelList
+import PrelIOBase
+import PrelMaybe ( Maybe(..) )
+import PrelException
+import PrelEnum
+import PrelNum ( Integer(..), Num(..) )
+import PrelShow
+import PrelReal ( toInteger )
+
+import PrelConc
+
+-- -----------------------------------------------------------------------------
+-- TODO:
+
+-- hWaitForInput blocks (should use a timeout).
+
+-- unbuffered hGetLine is a bit dodgy
+
+-- hSetBuffering: can't change buffering on a stream,
+-- when the read buffer is non-empty? (no way to flush the buffer)
+
+-- ---------------------------------------------------------------------------
+-- Creating a new handle
+
+newFileHandle :: (MVar Handle__ -> IO ()) -> Handle__ -> IO Handle
+newFileHandle finalizer hc = do
+ m <- newMVar hc
+ addMVarFinalizer m (finalizer m)
+ return (FileHandle m)
+
+-- ---------------------------------------------------------------------------
+-- Working with Handles
+
+{-
+In the concurrent world, handles are locked during use. This is done
+by wrapping an MVar around the handle which acts as a mutex over
+operations on the handle.
+
+To avoid races, we use the following bracketing operations. The idea
+is to obtain the lock, do some operation and replace the lock again,
+whether the operation succeeded or failed. We also want to handle the
+case where the thread receives an exception while processing the IO
+operation: in these cases we also want to relinquish the lock.
+
+There are three versions of @withHandle@: corresponding to the three
+possible combinations of:
+
+ - the operation may side-effect the handle
+ - the operation may return a result
+
+If the operation generates an error or an exception is raised, the
+orignal handle is always replaced [ this is the case at the moment,
+but we might want to revisit this in the future --SDM ].
+-}
+
+{-# INLINE withHandle #-}
+withHandle :: String -> Handle -> (Handle__ -> IO (Handle__,a)) -> IO a
+withHandle fun h@(FileHandle m) act = withHandle' fun h m act
+withHandle fun h@(DuplexHandle r w) act = do
+ withHandle' fun h r act
+ withHandle' fun h w act
+
+withHandle' fun h m act =
+ block $ do
+ h_ <- takeMVar m
+ checkBufferInvariants h_
+ (h',v) <- catchException (act h_)
+ (\ ex -> putMVar m h_ >> throw (augmentIOError ex fun h h_))
+ checkBufferInvariants h'
+ putMVar m h'
+ return v
+
+{-# INLINE withHandle_ #-}
+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_' fun h m act =
+ block $ do
+ h_ <- takeMVar m
+ checkBufferInvariants h_
+ v <- catchException (act h_)
+ (\ ex -> putMVar m h_ >> throw (augmentIOError ex fun h h_))
+ checkBufferInvariants h_
+ putMVar m h_
+ return v
+
+withAllHandles__ :: String -> Handle -> (Handle__ -> IO Handle__) -> IO ()
+withAllHandles__ fun h@(FileHandle m) act = withHandle__' fun h m act
+withAllHandles__ fun h@(DuplexHandle r w) act = do
+ withHandle__' fun h r act
+ withHandle__' fun h w act
+
+withHandle__' fun h m act =
+ block $ do
+ h_ <- takeMVar m
+ checkBufferInvariants h_
+ h' <- catchException (act h_)
+ (\ ex -> putMVar m h_ >> throw (augmentIOError ex fun h h_))
+ checkBufferInvariants h'
+ putMVar m h'
+ return ()
+
+augmentIOError (IOException (IOError _ iot _ str fp)) fun h h_
+ = IOException (IOError (Just h) iot fun str filepath)
+ where filepath | Just _ <- fp = fp
+ | otherwise = Just (haFilePath h_)
+augmentIOError other_exception _ _ _
+ = other_exception
+
+-- ---------------------------------------------------------------------------
+-- Wrapper for write operations.
+
+wantWritableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
+wantWritableHandle fun h@(FileHandle m) act
+ = wantWritableHandle' fun h m act
+wantWritableHandle fun h@(DuplexHandle _ m) act
+ = wantWritableHandle' fun h m act
+ -- ToDo: in the Duplex case, we don't need to checkWritableHandle
+
+wantWritableHandle'
+ :: String -> Handle -> MVar Handle__
+ -> (Handle__ -> IO a) -> IO a
+wantWritableHandle' fun h m act
+ = withHandle_' fun h m (checkWritableHandle act)
+
+checkWritableHandle act handle_
+ = case haType handle_ of
+ ClosedHandle -> ioe_closedHandle
+ SemiClosedHandle -> ioe_closedHandle
+ ReadHandle -> ioException not_writeable_error
+ ReadWriteHandle -> do
+ let ref = haBuffer handle_
+ buf <- readIORef ref
+ new_buf <-
+ if not (bufferIsWritable buf)
+ then do b <- flushReadBuffer (haFD handle_) buf
+ return b{ bufState=WriteBuffer }
+ else return buf
+ writeIORef ref new_buf
+ act handle_
+ _other -> act handle_
+ where
+ not_writeable_error =
+ IOError Nothing IllegalOperation ""
+ "handle is not open for writing" Nothing
+
+-- ---------------------------------------------------------------------------
+-- Wrapper for read operations.
+
+wantReadableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
+wantReadableHandle fun h@(FileHandle m) act
+ = wantReadableHandle' fun h m act
+wantReadableHandle fun h@(DuplexHandle m _) act
+ = wantReadableHandle' fun h m act
+ -- ToDo: in the Duplex case, we don't need to checkReadableHandle
+
+wantReadableHandle'
+ :: String -> Handle -> MVar Handle__
+ -> (Handle__ -> IO a) -> IO a
+wantReadableHandle' fun h m act
+ = withHandle_' fun h m (checkReadableHandle act)
+
+checkReadableHandle act handle_ =
+ case haType handle_ of
+ ClosedHandle -> ioe_closedHandle
+ SemiClosedHandle -> ioe_closedHandle
+ AppendHandle -> ioException not_readable_error
+ WriteHandle -> ioException not_readable_error
+ ReadWriteHandle -> do
+ let ref = haBuffer handle_
+ buf <- readIORef ref
+ when (bufferIsWritable buf) $ do
+ new_buf <- flushWriteBuffer (haFD handle_) buf
+ writeIORef ref new_buf{ bufState=ReadBuffer }
+ act handle_
+ _other -> act handle_
+ where
+ not_readable_error =
+ IOError Nothing IllegalOperation ""
+ "handle is not open for reading" Nothing
+
+-- ---------------------------------------------------------------------------
+-- Wrapper for seek operations.
+
+wantSeekableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
+wantSeekableHandle fun h@(DuplexHandle _ _) _act =
+ ioException (IOError (Just h) IllegalOperation fun
+ "handle is not seekable" Nothing)
+wantSeekableHandle fun h@(FileHandle m) act =
+ withHandle_' fun h m (checkSeekableHandle act)
+
+checkSeekableHandle act handle_ =
+ case haType handle_ of
+ ClosedHandle -> ioe_closedHandle
+ SemiClosedHandle -> ioe_closedHandle
+ AppendHandle -> not_seekable_error
+ _ -> act handle_
+
+not_seekable_error
+ = ioException (IOError Nothing IllegalOperation ""
+ "handle is not seekable" Nothing)
+
+-- -----------------------------------------------------------------------------
+-- Handy IOErrors
+
+ioe_closedHandle :: IO a
+ioe_closedHandle = ioException (IOError Nothing IllegalOperation "" "" Nothing)
+
+ioe_EOF :: IO a
+ioe_EOF = ioException (IOError Nothing EOF "" "" Nothing)
+
+-- -----------------------------------------------------------------------------
+-- Handle Finalizers
+
+-- For a duplex handle, we arrange that the read side points to the write side
+-- (and hence keeps it alive if the read side is alive). This is done by
+-- having the haType field of the read side be ReadSideHandle with a pointer
+-- to the write side. The finalizer is then placed on the write side, and
+-- the handle only gets finalized once, when both sides are no longer
+-- required.
+
+addFinalizer :: Handle -> IO ()
+addFinalizer (FileHandle m) = addMVarFinalizer m (handleFinalizer m)
+addFinalizer (DuplexHandle _ w) = addMVarFinalizer w (handleFinalizer w)
+
+stdHandleFinalizer :: MVar Handle__ -> IO ()
+stdHandleFinalizer m = do
+ h_ <- takeMVar m
+ flushWriteBufferOnly h_
+
+handleFinalizer :: MVar Handle__ -> IO ()
+handleFinalizer m = do
+ h_ <- takeMVar m
+ flushWriteBufferOnly h_
+ let fd = fromIntegral (haFD h_)
+ unlockFile fd
+ -- ToDo: closesocket() for a WINSOCK socket?
+ when (fd /= -1) (c_close fd >> return ())
+ return ()
+
+-- ---------------------------------------------------------------------------
+-- Grimy buffer operations
+
+#ifdef DEBUG
+checkBufferInvariants h_ = do
+ let ref = haBuffer h_
+ Buffer{ bufWPtr=w, bufRPtr=r, bufSize=size, bufState=state } <- readIORef ref
+ if not (
+ size > 0
+ && r <= w
+ && w <= size
+ && ( r /= w || (r == 0 && w == 0) )
+ && ( state /= WriteBuffer || r == 0 )
+ && ( state /= WriteBuffer || w < size ) -- write buffer is never full
+ )
+ then error "buffer invariant violation"
+ else return ()
+#else
+checkBufferInvariants h_ = return ()
+#endif
+
+newEmptyBuffer :: RawBuffer -> BufferState -> Int -> Buffer
+newEmptyBuffer b state size
+ = Buffer{ bufBuf=b, bufRPtr=0, bufWPtr=0, bufSize=size, bufState=state }
+
+allocateBuffer :: Int -> BufferState -> IO Buffer
+allocateBuffer sz@(I## size) state = IO $ \s ->
+ case newByteArray## size s of { (## s, b ##) ->
+ (## s, newEmptyBuffer b state sz ##) }
+
+writeCharIntoBuffer :: RawBuffer -> Int -> Char -> IO Int
+writeCharIntoBuffer slab (I## off) (C## c)
+ = IO $ \s -> case writeCharArray## slab off c s of
+ s -> (## s, I## (off +## 1##) ##)
+
+readCharFromBuffer :: RawBuffer -> Int -> IO (Char, Int)
+readCharFromBuffer slab (I## off)
+ = IO $ \s -> case readCharArray## slab off s of
+ (## s, c ##) -> (## s, (C## c, I## (off +## 1##)) ##)
+
+dEFAULT_BUFFER_SIZE = (#const BUFSIZ) :: Int
+
+getBuffer :: FD -> BufferState -> IO (IORef Buffer, BufferMode)
+getBuffer fd state = do
+ buffer <- allocateBuffer dEFAULT_BUFFER_SIZE state
+ ioref <- newIORef buffer
+ is_tty <- c_isatty (fromIntegral fd)
+
+ let buffer_mode
+ | toBool is_tty = LineBuffering
+ | otherwise = BlockBuffering Nothing
+
+ return (ioref, buffer_mode)
+
+mkUnBuffer :: IO (IORef Buffer)
+mkUnBuffer = do
+ buffer <- allocateBuffer 1 ReadBuffer
+ newIORef buffer
+
+-- flushWriteBufferOnly flushes the buffer iff it contains pending write data.
+flushWriteBufferOnly :: Handle__ -> IO ()
+flushWriteBufferOnly h_ = do
+ let fd = haFD h_
+ ref = haBuffer h_
+ buf <- readIORef ref
+ new_buf <- if bufferIsWritable buf
+ then flushWriteBuffer fd buf
+ else return buf
+ writeIORef ref new_buf
+
+-- flushBuffer syncs the file with the buffer, including moving the
+-- file pointer backwards in the case of a read buffer.
+flushBuffer :: Handle__ -> IO ()
+flushBuffer h_ = do
+ let ref = haBuffer h_
+ buf <- readIORef ref
+
+ flushed_buf <-
+ case bufState buf of
+ ReadBuffer -> flushReadBuffer (haFD h_) buf
+ WriteBuffer -> flushWriteBuffer (haFD h_) buf
+
+ writeIORef ref flushed_buf
+
+-- When flushing a read buffer, we seek backwards by the number of
+-- characters in the buffer. The file descriptor must therefore be
+-- seekable: attempting to flush the read buffer on an unseekable
+-- handle is not allowed.
+flushReadBuffer :: FD -> Buffer -> IO Buffer
+flushReadBuffer fd buf
+ | bufferEmpty buf = return buf
+ | otherwise = do
+ let off = negate (bufWPtr buf - bufRPtr buf)
+ throwErrnoIfMinus1Retry "flushReadBuffer"
+ (c_lseek (fromIntegral fd) (fromIntegral off) (#const SEEK_CUR))
+ return buf{ bufWPtr=0, bufRPtr=0 }
+
+flushWriteBuffer :: FD -> Buffer -> IO Buffer
+flushWriteBuffer fd buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w } = do
+ let bytes = w - r
+#ifdef DEBUG_DUMP
+ puts ("flushWriteBuffer, fd=" ++ show fd ++ ", bytes=" ++ show bytes ++ "\n")
+#endif
+ if bytes == 0
+ then return (buf{ bufRPtr=0, bufWPtr=0 })
+ else do
+ res <- throwErrnoIfMinus1RetryMayBlock "flushWriteBuffer"
+ (write_off (fromIntegral fd) b (fromIntegral r)
+ (fromIntegral bytes))
+ (threadWaitWrite fd)
+ let res' = fromIntegral res
+ if res' < bytes
+ then flushWriteBuffer fd (buf{ bufRPtr = r + res' })
+ else return buf{ bufRPtr=0, bufWPtr=0 }
+
+foreign import "write_wrap" unsafe
+ write_off :: CInt -> RawBuffer -> Int -> CInt -> IO CInt
+#def inline \
+int write_wrap(int fd, void *ptr, HsInt off, int size) \
+{ return write(fd, ptr + off, size); }
+
+
+fillReadBuffer :: FD -> Bool -> Buffer -> IO Buffer
+fillReadBuffer fd is_line
+ buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w, bufSize=size } =
+ -- buffer better be empty:
+ assert (r == 0 && w == 0) $ do
+ fillReadBufferLoop fd is_line buf b w size
+
+-- For a line buffer, we just get the first chunk of data to arrive,
+-- and don't wait for the whole buffer to be full (but we *do* wait
+-- until some data arrives). This isn't really line buffering, but it
+-- appears to be what GHC has done for a long time, and I suspect it
+-- is more useful than line buffering in most cases.
+
+fillReadBufferLoop fd is_line buf b w size = do
+ let bytes = size - w
+ if bytes == 0 -- buffer full?
+ then return buf{ bufRPtr=0, bufWPtr=w }
+ else do
+#ifdef DEBUG_DUMP
+ puts ("fillReadBufferLoop: bytes = " ++ show bytes ++ "\n")
+#endif
+ res <- throwErrnoIfMinus1RetryMayBlock "fillReadBuffer"
+ (read_off fd b (fromIntegral w) (fromIntegral bytes))
+ (threadWaitRead fd)
+ let res' = fromIntegral res
+ if res' == 0
+ then if w == 0
+ then ioe_EOF
+ else return buf{ bufRPtr=0, bufWPtr=w }
+ else if res' < bytes && not is_line
+ then fillReadBufferLoop fd is_line buf b (w+res') size
+ else return buf{ bufRPtr=0, bufWPtr=w+res' }
+
+foreign import "read_wrap" unsafe
+ read_off :: FD -> RawBuffer -> Int -> CInt -> IO CInt
+#def inline \
+int read_wrap(int fd, void *ptr, HsInt off, int size) \
+{ return read(fd, ptr + off, size); }
+
+-- ---------------------------------------------------------------------------
+-- Standard Handles
+
+-- Three handles are allocated during program initialisation. The first
+-- two manage input or output from the Haskell program's standard input
+-- or output channel respectively. The third manages output to the
+-- standard error channel. These handles are initially open.
+
+fd_stdin = 0 :: FD
+fd_stdout = 1 :: FD
+fd_stderr = 2 :: FD
+
+stdin :: Handle
+stdin = unsafePerformIO $ do
+ -- ToDo: acquire lock
+ setNonBlockingFD fd_stdin
+ (buf, bmode) <- getBuffer fd_stdin ReadBuffer
+ spares <- newIORef BufferListNil
+ newFileHandle stdHandleFinalizer
+ (Handle__ { haFD = fd_stdin,
+ haType = ReadHandle,
+ haBufferMode = bmode,
+ haFilePath = "<stdin>",
+ haBuffer = buf,
+ haBuffers = spares
+ })
+
+stdout :: Handle
+stdout = unsafePerformIO $ do
+ -- ToDo: acquire lock
+ -- We don't set non-blocking mode on stdout or sterr, because
+ -- some shells don't recover properly.
+ -- setNonBlockingFD fd_stdout
+ (buf, bmode) <- getBuffer fd_stdout WriteBuffer
+ spares <- newIORef BufferListNil
+ newFileHandle stdHandleFinalizer
+ (Handle__ { haFD = fd_stdout,
+ haType = WriteHandle,
+ haBufferMode = bmode,
+ haFilePath = "<stdout>",
+ haBuffer = buf,
+ haBuffers = spares
+ })
+
+stderr :: Handle
+stderr = unsafePerformIO $ do
+ -- ToDo: acquire lock
+ -- We don't set non-blocking mode on stdout or sterr, because
+ -- some shells don't recover properly.
+ -- setNonBlockingFD fd_stderr
+ buffer <- mkUnBuffer
+ spares <- newIORef BufferListNil
+ newFileHandle stdHandleFinalizer
+ (Handle__ { haFD = fd_stderr,
+ haType = WriteHandle,
+ haBufferMode = NoBuffering,
+ haFilePath = "<stderr>",
+ haBuffer = buffer,
+ haBuffers = spares
+ })
+
+-- ---------------------------------------------------------------------------
+-- Opening and Closing Files
+
+{-
+Computation `openFile file mode' allocates and returns a new, open
+handle to manage the file `file'. It manages input if `mode'
+is `ReadMode', output if `mode' is `WriteMode' or `AppendMode',
+and both input and output if mode is `ReadWriteMode'.
+
+If the file does not exist and it is opened for output, it should be
+created as a new file. If `mode' is `WriteMode' and the file
+already exists, then it should be truncated to zero length. The
+handle is positioned at the end of the file if `mode' is
+`AppendMode', and otherwise at the beginning (in which case its
+internal position is 0).
+
+Implementations should enforce, locally to the Haskell process,
+multiple-reader single-writer locking on files, which is to say that
+there may either be many handles on the same file which manage input,
+or just one handle on the file which manages output. If any open or
+semi-closed handle is managing a file for output, no new handle can be
+allocated for that file. If any open or semi-closed handle is
+managing a file for input, new handles can only be allocated if they
+do not manage output.
+
+Two files are the same if they have the same absolute name. An
+implementation is free to impose stricter conditions.
+-}
+
+data IOMode = ReadMode | WriteMode | AppendMode | ReadWriteMode
+ deriving (Eq, Ord, Ix, Enum, Read, Show)
+
+data IOModeEx
+ = BinaryMode IOMode
+ | TextMode IOMode
+ deriving (Eq, Read, Show)
+
+addFilePathToIOError fun fp (IOException (IOError h iot _ str _))
+ = IOException (IOError h iot fun str (Just fp))
+addFilePathToIOError _ _ other_exception
+ = other_exception
+
+openFile :: FilePath -> IOMode -> IO Handle
+openFile fp im =
+ catch
+ (openFile' fp (TextMode im))
+ (\e -> throw (addFilePathToIOError "openFile" fp e))
+
+openFileEx :: FilePath -> IOModeEx -> IO Handle
+openFileEx fp m =
+ catch
+ (openFile' fp m)
+ (\e -> throw (addFilePathToIOError "openFileEx" fp e))
+
+
+openFile' filepath ex_mode =
+ withCString filepath $ \ f ->
+
+ let
+ (mode, binary) =
+ case ex_mode of
+ BinaryMode bmo -> (bmo, True)
+ TextMode tmo -> (tmo, False)
+
+ oflags1 = case mode of
+ ReadMode -> read_flags
+ WriteMode -> write_flags
+ ReadWriteMode -> rw_flags
+ AppendMode -> append_flags
+
+ binary_flags
+#ifdef HAVE_O_BINARY
+ | binary = o_BINARY
+#endif
+ | otherwise = 0
+
+ oflags = oflags1 .|. binary_flags
+ in do
+
+ -- the old implementation had a complicated series of three opens,
+ -- which is perhaps because we have to be careful not to open
+ -- directories. However, the man pages I've read say that open()
+ -- always returns EISDIR if the file is a directory and was opened
+ -- for writing, so I think we're ok with a single open() here...
+ fd <- fromIntegral `liftM`
+ throwErrnoIfMinus1Retry "openFile"
+ (c_open f (fromIntegral oflags) 0o666)
+
+ openFd fd filepath mode
+
+
+std_flags = o_NONBLOCK .|. o_NOCTTY
+output_flags = std_flags .|. o_CREAT
+read_flags = std_flags .|. o_RDONLY
+write_flags = output_flags .|. o_WRONLY .|. o_TRUNC
+rw_flags = output_flags .|. o_RDWR
+append_flags = output_flags .|. o_WRONLY .|. o_APPEND
+
+-- ---------------------------------------------------------------------------
+-- openFd
+
+openFd :: FD -> FilePath -> IOMode -> IO Handle
+openFd fd filepath mode = do
+ -- turn on non-blocking mode
+ setNonBlockingFD fd
+
+ let (ha_type, write) =
+ case mode of
+ ReadMode -> ( ReadHandle, False )
+ WriteMode -> ( WriteHandle, True )
+ ReadWriteMode -> ( ReadWriteHandle, True )
+ AppendMode -> ( AppendHandle, True )
+
+ -- open() won't tell us if it was a directory if we only opened for
+ -- reading, so check again.
+ fd_type <- fdType fd
+ case fd_type of
+ Directory ->
+ ioException (IOError Nothing InappropriateType "openFile"
+ "is a directory" Nothing)
+
+ Stream
+ | ReadWriteHandle <- ha_type -> mkDuplexHandle fd filepath
+ | otherwise -> mkFileHandle fd filepath ha_type
+
+ -- regular files need to be locked
+ RegularFile -> do
+ r <- lockFile (fromIntegral fd) (fromBool write) 1{-exclusive-}
+ when (r == -1) $
+ ioException (IOError Nothing ResourceBusy "openFile"
+ "file is locked" Nothing)
+ mkFileHandle fd filepath ha_type
+
+
+foreign import "lockFile" unsafe
+ lockFile :: CInt -> CInt -> CInt -> IO CInt
+
+foreign import "unlockFile" unsafe
+ unlockFile :: CInt -> IO CInt
+
+
+mkFileHandle :: FD -> FilePath -> HandleType -> IO Handle
+mkFileHandle fd filepath ha_type = do
+ (buf, bmode) <- getBuffer fd (initBufferState ha_type)
+ spares <- newIORef BufferListNil
+ newFileHandle handleFinalizer
+ (Handle__ { haFD = fd,
+ haType = ha_type,
+ haBufferMode = bmode,
+ haFilePath = filepath,
+ haBuffer = buf,
+ haBuffers = spares
+ })
+
+mkDuplexHandle :: FD -> FilePath -> IO Handle
+mkDuplexHandle fd filepath = do
+ (w_buf, w_bmode) <- getBuffer fd WriteBuffer
+ w_spares <- newIORef BufferListNil
+ let w_handle_ =
+ Handle__ { haFD = fd,
+ haType = WriteHandle,
+ haBufferMode = w_bmode,
+ haFilePath = filepath,
+ haBuffer = w_buf,
+ haBuffers = w_spares
+ }
+ write_side <- newMVar w_handle_
+
+ (r_buf, r_bmode) <- getBuffer fd ReadBuffer
+ r_spares <- newIORef BufferListNil
+ let r_handle_ =
+ Handle__ { haFD = fd,
+ haType = ReadSideHandle write_side,
+ haBufferMode = r_bmode,
+ haFilePath = filepath,
+ haBuffer = r_buf,
+ haBuffers = r_spares
+ }
+ read_side <- newMVar r_handle_
+
+ addMVarFinalizer write_side (handleFinalizer write_side)
+ return (DuplexHandle read_side write_side)
+
+
+initBufferState ReadHandle = ReadBuffer
+initBufferState _ = WriteBuffer
+
+-- ---------------------------------------------------------------------------
+-- Closing a handle
+
+-- Computation `hClose hdl' makes handle `hdl' closed. Before the
+-- computation finishes, any items buffered for output and not already
+-- sent to the operating system are flushed as for `hFlush'.
+
+-- For a duplex handle, we close&flush the write side, and just close
+-- the read side.
+
+hClose :: Handle -> IO ()
+hClose h@(FileHandle m) = hClose' h m
+hClose h@(DuplexHandle r w) = do
+ hClose' h w
+ withHandle__' "hClose" h r $ \ handle_ -> do
+ return handle_{ haFD = -1,
+ haType = ClosedHandle
+ }
+
+hClose' h m =
+ withHandle__' "hClose" h m $ \ handle_ -> do
+ case haType handle_ of
+ ClosedHandle -> return handle_
+ _ -> do
+ let fd = fromIntegral (haFD handle_)
+ flushWriteBufferOnly handle_
+ throwErrnoIfMinus1Retry_ "hClose" (c_close fd)
+
+ -- free the spare buffers
+ writeIORef (haBuffers handle_) BufferListNil
+
+ -- unlock it
+ unlockFile fd
+
+ -- we must set the fd to -1, because the finalizer is going
+ -- to run eventually and try to close/unlock it.
+ return (handle_{ haFD = -1,
+ haType = ClosedHandle
+ })
+
+-----------------------------------------------------------------------------
+-- Detecting the size of a file
+
+-- For a handle `hdl' which attached to a physical file, `hFileSize
+-- hdl' returns the size of `hdl' in terms of the number of items
+-- which can be read from `hdl'.
+
+hFileSize :: Handle -> IO Integer
+hFileSize handle =
+ withHandle_ "hFileSize" handle $ \ handle_ -> do
+ case haType handle_ of
+ ClosedHandle -> ioe_closedHandle
+ SemiClosedHandle -> ioe_closedHandle
+ _ -> do flushWriteBufferOnly handle_
+ r <- fdFileSize (haFD handle_)
+ if r /= -1
+ then return r
+ else ioException (IOError Nothing InappropriateType "hFileSize"
+ "not a regular file" Nothing)
+
+-- ---------------------------------------------------------------------------
+-- Detecting the End of Input
+
+-- For a readable handle `hdl', `hIsEOF hdl' returns
+-- `True' if no further input can be taken from `hdl' or for a
+-- physical file, if the current I/O position is equal to the length of
+-- the file. Otherwise, it returns `False'.
+
+hIsEOF :: Handle -> IO Bool
+hIsEOF handle =
+ catch
+ (do hLookAhead handle; return False)
+ (\e -> if isEOFError e then return True else throw e)
+
+isEOF :: IO Bool
+isEOF = hIsEOF stdin
+
+-- ---------------------------------------------------------------------------
+-- Looking ahead
+
+-- hLookahead returns the next character from the handle without
+-- removing it from the input buffer, blocking until a character is
+-- available.
+
+hLookAhead :: Handle -> IO Char
+hLookAhead handle = do
+ wantReadableHandle "hLookAhead" handle $ \handle_ -> do
+ let ref = haBuffer handle_
+ fd = haFD handle_
+ is_line = haBufferMode handle_ == LineBuffering
+ buf <- readIORef ref
+
+ -- fill up the read buffer if necessary
+ new_buf <- if bufferEmpty buf
+ then fillReadBuffer fd is_line buf
+ else return buf
+
+ writeIORef ref new_buf
+
+ (c,_) <- readCharFromBuffer (bufBuf buf) (bufRPtr buf)
+ return c
+
+-- ---------------------------------------------------------------------------
+-- Buffering Operations
+
+-- Three kinds of buffering are supported: line-buffering,
+-- block-buffering or no-buffering. See PrelIOBase for definition and
+-- further explanation of what the type represent.
+
+-- Computation `hSetBuffering hdl mode' sets the mode of buffering for
+-- handle hdl on subsequent reads and writes.
+--
+-- * If mode is LineBuffering, line-buffering should be enabled if possible.
+--
+-- * If mode is `BlockBuffering size', then block-buffering
+-- should be enabled if possible. The size of the buffer is n items
+-- if size is `Just n' and is otherwise implementation-dependent.
+--
+-- * If mode is NoBuffering, then buffering is disabled if possible.
+
+-- If the buffer mode is changed from BlockBuffering or
+-- LineBuffering to NoBuffering, then any items in the output
+-- buffer are written to the device, and any items in the input buffer
+-- are discarded. The default buffering mode when a handle is opened
+-- is implementation-dependent and may depend on the object which is
+-- attached to that handle.
+
+hSetBuffering :: Handle -> BufferMode -> IO ()
+hSetBuffering handle mode =
+ withAllHandles__ "hSetBuffering" handle $ \ handle_ -> do
+ case haType handle_ of
+ ClosedHandle -> ioe_closedHandle
+ _ -> do
+ {- Note:
+ - we flush the old buffer regardless of whether
+ the new buffer could fit the contents of the old buffer
+ or not.
+ - allow a handle's buffering to change even if IO has
+ occurred (ANSI C spec. does not allow this, nor did
+ the previous implementation of IO.hSetBuffering).
+ - a non-standard extension is to allow the buffering
+ of semi-closed handles to change [sof 6/98]
+ -}
+ flushBuffer handle_
+
+ let state = initBufferState (haType handle_)
+ new_buf <-
+ case mode of
+ -- we always have a 1-character read buffer for
+ -- unbuffered handles: it's needed to
+ -- support hLookAhead.
+ NoBuffering -> allocateBuffer 1 ReadBuffer
+ LineBuffering -> allocateBuffer dEFAULT_BUFFER_SIZE state
+ BlockBuffering Nothing -> allocateBuffer dEFAULT_BUFFER_SIZE state
+ BlockBuffering (Just n) | n <= 0 -> ioe_bufsiz n
+ | otherwise -> allocateBuffer n state
+ writeIORef (haBuffer handle_) new_buf
+
+ -- for input terminals we need to put the terminal into
+ -- cooked or raw mode depending on the type of buffering.
+ is_tty <- fdIsTTY (haFD handle_)
+ when is_tty $
+ case mode of
+ NoBuffering -> setCooked (haFD handle_) False
+ _ -> setCooked (haFD handle_) True
+
+ -- throw away spare buffers, they might be the wrong size
+ writeIORef (haBuffers handle_) BufferListNil
+
+ return (handle_{ haBufferMode = mode })
+
+ioe_bufsiz n
+ = ioException (IOError Nothing InvalidArgument "hSetBuffering"
+ ("illegal buffer size " ++ showsPrec 9 n [])
+ -- 9 => should be parens'ified.
+ Nothing)
+
+-- -----------------------------------------------------------------------------
+-- hFlush
+
+-- The action `hFlush hdl' causes any items buffered for output
+-- in handle `hdl' to be sent immediately to the operating
+-- system.
+
+hFlush :: Handle -> IO ()
+hFlush handle =
+ wantWritableHandle "hFlush" handle $ \ handle_ -> do
+ buf <- readIORef (haBuffer handle_)
+ if bufferIsWritable buf && not (bufferEmpty buf)
+ then do flushed_buf <- flushWriteBuffer (haFD handle_) buf
+ writeIORef (haBuffer handle_) flushed_buf
+ else return ()
+
+
+-- -----------------------------------------------------------------------------
+-- Repositioning Handles
+
+data HandlePosn = HandlePosn Handle HandlePosition
+
+instance Eq HandlePosn where
+ (HandlePosn h1 p1) == (HandlePosn h2 p2) = p1==p2 && h1==h2
+
+ -- HandlePosition is the Haskell equivalent of POSIX' off_t.
+ -- We represent it as an Integer on the Haskell side, but
+ -- cheat slightly in that hGetPosn calls upon a C helper
+ -- that reports the position back via (merely) an Int.
+type HandlePosition = Integer
+
+-- Computation `hGetPosn hdl' returns the current I/O position of
+-- `hdl' as an abstract position. Computation `hSetPosn p' sets the
+-- position of `hdl' to a previously obtained position `p'.
+
+hGetPosn :: Handle -> IO HandlePosn
+hGetPosn handle =
+ wantSeekableHandle "hGetPosn" handle $ \ handle_ -> do
+
+#if defined(_WIN32)
+ -- urgh, on Windows we have to worry about /n -> /r/n translation,
+ -- so we can't easily calculate the file position using the
+ -- current buffer size. Just flush instead.
+ flushBuffer handle_
+#endif
+
+ let fd = fromIntegral (haFD handle_)
+ posn <- fromIntegral `liftM`
+ throwErrnoIfMinus1Retry "hGetPosn"
+ (c_lseek fd 0 (#const SEEK_CUR))
+
+ let ref = haBuffer handle_
+ buf <- readIORef ref
+
+ let real_posn
+ | bufferIsWritable buf = posn + fromIntegral (bufWPtr buf)
+ | otherwise = posn - fromIntegral (bufWPtr buf - bufRPtr buf)
+
+ return (HandlePosn handle real_posn)
+
+
+hSetPosn :: HandlePosn -> IO ()
+hSetPosn (HandlePosn h i) = hSeek h AbsoluteSeek i
+
+-- ---------------------------------------------------------------------------
+-- hSeek
+
+{-
+The action `hSeek hdl mode i' sets the position of handle
+`hdl' depending on `mode'. If `mode' is
+
+ * AbsoluteSeek - The position of `hdl' is set to `i'.
+ * RelativeSeek - The position of `hdl' is set to offset `i' from
+ the current position.
+ * SeekFromEnd - The position of `hdl' is set to offset `i' from
+ the end of the file.
+
+Some handles may not be seekable (see `hIsSeekable'), or only
+support a subset of the possible positioning operations (e.g. it may
+only be possible to seek to the end of a tape, or to a positive
+offset from the beginning or current position).
+
+It is not possible to set a negative I/O position, or for a physical
+file, an I/O position beyond the current end-of-file.
+
+Note:
+ - when seeking using `SeekFromEnd', positive offsets (>=0) means
+ seeking at or past EOF.
+
+ - we possibly deviate from the report on the issue of seeking within
+ the buffer and whether to flush it or not. The report isn't exactly
+ clear here.
+-}
+
+data SeekMode = AbsoluteSeek | RelativeSeek | SeekFromEnd
+ deriving (Eq, Ord, Ix, Enum, Read, Show)
+
+hSeek :: Handle -> SeekMode -> Integer -> IO ()
+hSeek handle mode offset =
+ wantSeekableHandle "hSeek" handle $ \ handle_ -> do
+ let ref = haBuffer handle_
+ buf <- readIORef ref
+ let r = bufRPtr buf
+ w = bufWPtr buf
+ fd = haFD handle_
+
+ let do_seek =
+ throwErrnoIfMinus1Retry_ "hSeek"
+ (c_lseek (fromIntegral (haFD handle_)) (fromIntegral offset) whence)
+
+ whence :: CInt
+ whence = case mode of
+ AbsoluteSeek -> (#const SEEK_SET)
+ RelativeSeek -> (#const SEEK_CUR)
+ SeekFromEnd -> (#const SEEK_END)
+
+ if bufferIsWritable buf
+ then do new_buf <- flushWriteBuffer fd buf
+ writeIORef ref new_buf
+ do_seek
+ else do
+
+ if mode == RelativeSeek && offset >= 0 && offset < fromIntegral (w - r)
+ then writeIORef ref buf{ bufRPtr = r + fromIntegral offset }
+ else do
+
+ new_buf <- flushReadBuffer (haFD handle_) buf
+ writeIORef ref new_buf
+ do_seek
+
+-- -----------------------------------------------------------------------------
+-- Handle Properties
+
+-- A number of operations return information about the properties of a
+-- handle. Each of these operations returns `True' if the handle has
+-- the specified property, and `False' otherwise.
+
+hIsOpen :: Handle -> IO Bool
+hIsOpen handle =
+ withHandle_ "hIsOpen" handle $ \ handle_ -> do
+ case haType handle_ of
+ ClosedHandle -> return False
+ SemiClosedHandle -> return False
+ _ -> return True
+
+hIsClosed :: Handle -> IO Bool
+hIsClosed handle =
+ withHandle_ "hIsClosed" handle $ \ handle_ -> do
+ case haType handle_ of
+ ClosedHandle -> return True
+ _ -> return False
+
+{- not defined, nor exported, but mentioned
+ here for documentation purposes:
+
+ hSemiClosed :: Handle -> IO Bool
+ hSemiClosed h = do
+ ho <- hIsOpen h
+ hc <- hIsClosed h
+ return (not (ho || hc))
+-}
+
+hIsReadable :: Handle -> IO Bool
+hIsReadable (DuplexHandle _ _) = return True
+hIsReadable handle =
+ withHandle_ "hIsReadable" handle $ \ handle_ -> do
+ case haType handle_ of
+ ClosedHandle -> ioe_closedHandle
+ SemiClosedHandle -> ioe_closedHandle
+ htype -> return (isReadable htype)
+ where
+ isReadable ReadHandle = True
+ isReadable (ReadSideHandle _) = True
+ isReadable ReadWriteHandle = True
+ isReadable _ = False
+
+hIsWritable :: Handle -> IO Bool
+hIsWritable (DuplexHandle _ _) = return False
+hIsWritable handle =
+ withHandle_ "hIsWritable" handle $ \ handle_ -> do
+ case haType handle_ of
+ ClosedHandle -> ioe_closedHandle
+ SemiClosedHandle -> ioe_closedHandle
+ htype -> return (isWritable htype)
+ where
+ isWritable AppendHandle = True
+ isWritable WriteHandle = True
+ isWritable ReadWriteHandle = True
+ isWritable _ = False
+
+-- Querying how a handle buffers its data:
+
+hGetBuffering :: Handle -> IO BufferMode
+hGetBuffering handle =
+ withHandle_ "hGetBuffering" handle $ \ handle_ -> do
+ case haType handle_ of
+ ClosedHandle -> ioe_closedHandle
+ _ ->
+ -- We're being non-standard here, and allow the buffering
+ -- of a semi-closed handle to be queried. -- sof 6/98
+ return (haBufferMode handle_) -- could be stricter..
+
+hIsSeekable :: Handle -> IO Bool
+hIsSeekable handle =
+ withHandle_ "hIsSeekable" handle $ \ handle_ -> do
+ case haType handle_ of
+ ClosedHandle -> ioe_closedHandle
+ SemiClosedHandle -> ioe_closedHandle
+ AppendHandle -> return False
+ _ -> do t <- fdType (haFD handle_)
+ return (t == RegularFile)
+
+-- -----------------------------------------------------------------------------
+-- Changing echo status
+
+-- Non-standard GHC extension is to allow the echoing status
+-- of a handles connected to terminals to be reconfigured:
+
+hSetEcho :: Handle -> Bool -> IO ()
+hSetEcho handle on = do
+ isT <- hIsTerminalDevice handle
+ if not isT
+ then return ()
+ else
+ withHandle_ "hSetEcho" handle $ \ handle_ -> do
+ case haType handle_ of
+ ClosedHandle -> ioe_closedHandle
+ _ -> setEcho (haFD handle_) on
+
+hGetEcho :: Handle -> IO Bool
+hGetEcho handle = do
+ isT <- hIsTerminalDevice handle
+ if not isT
+ then return False
+ else
+ withHandle_ "hGetEcho" handle $ \ handle_ -> do
+ case haType handle_ of
+ ClosedHandle -> ioe_closedHandle
+ _ -> getEcho (haFD handle_)
+
+hIsTerminalDevice :: Handle -> IO Bool
+hIsTerminalDevice handle = do
+ withHandle_ "hIsTerminalDevice" handle $ \ handle_ -> do
+ case haType handle_ of
+ ClosedHandle -> ioe_closedHandle
+ _ -> fdIsTTY (haFD handle_)
+
+-- -----------------------------------------------------------------------------
+-- hSetBinaryMode
+
+#ifdef _WIN32
+hSetBinaryMode handle bin =
+ withHandle "hSetBinaryMode" handle $ \ handle_ ->
+ let flg | bin = (#const O_BINARY)
+ | otherwise = (#const O_TEXT)
+ throwErrnoIfMinus1_ "hSetBinaryMode" $
+ setmode (fromIntegral (haFD handle_)) flg
+
+foreign import "setmode" setmode :: CInt -> CInt -> IO CInt
+#else
+hSetBinaryMode _ _ = return ()
+#endif
+
+-- -----------------------------------------------------------------------------
+-- Miscellaneous
+
+-- These three functions are meant to get things out of an IOError.
+
+ioeGetFileName :: IOError -> Maybe FilePath
+ioeGetErrorString :: IOError -> String
+ioeGetHandle :: IOError -> Maybe Handle
+
+ioeGetHandle (IOException (IOError h _ _ _ _)) = h
+ioeGetHandle (UserError _) = Nothing
+ioeGetHandle _ = error "IO.ioeGetHandle: not an IO error"
+
+ioeGetErrorString (IOException (IOError _ iot _ _ _)) = show iot
+ioeGetErrorString (UserError str) = str
+ioeGetErrorString _ = error "IO.ioeGetErrorString: not an IO error"
+
+ioeGetFileName (IOException (IOError _ _ _ _ fn)) = fn
+ioeGetFileName (UserError _) = Nothing
+ioeGetFileName _ = error "IO.ioeGetFileName: not an IO error"
+
+-- ---------------------------------------------------------------------------
+-- debugging
+
+#ifdef DEBUG_DUMP
+puts :: String -> IO ()
+puts s = withCString s $ \cstr -> do c_write 1 cstr (fromIntegral (length s))
+ return ()
+#endif
+++ /dev/null
-% ------------------------------------------------------------------------------
-% $Id: PrelHandle.lhs,v 1.67 2001/02/22 13:17:58 simonpj Exp $
-%
-% (c) The AQUA Project, Glasgow University, 1994-2000
-%
-
-\section[PrelHandle]{Module @PrelHandle@}
-
-This module defines Haskell {\em handles} and the basic operations
-which are supported for them.
-
-\begin{code}
-{-# OPTIONS -fno-implicit-prelude -#include "cbits/stgio.h" #-}
-#include "cbits/stgerror.h"
-
-#ifndef __HUGS__ /* Hugs just includes this in PreludeBuiltin so no header needed */
-module PrelHandle where
-
-import PrelArr
-import PrelBase
-import PrelPtr
-import PrelByteArr ( ByteArray(..) )
-import PrelRead ( Read )
-import PrelList ( break )
-import PrelIOBase
-import PrelMaybe ( Maybe(..) )
-import PrelException
-import PrelEnum
-import PrelNum ( toBig, Integer(..), Num(..), int2Integer )
-import PrelShow
-import PrelReal ( toInteger )
-import PrelPack ( packString )
-
-import PrelConc
-
-#ifndef __PARALLEL_HASKELL__
-import PrelForeign ( newForeignPtr, mkForeignPtr, addForeignPtrFinalizer )
-#endif
-
-#endif /* ndef(__HUGS__) */
-
-#ifdef __HUGS__
-#define __CONCURRENT_HASKELL__
-#define stToIO id
-#endif
-
-#ifndef __PARALLEL_HASKELL__
-#define FILE_OBJECT (ForeignPtr ())
-#else
-#define FILE_OBJECT (Ptr ())
-#endif
-\end{code}
-
-\begin{code}
-mkBuffer__ :: FILE_OBJECT -> Int -> IO ()
-mkBuffer__ fo sz_in_bytes = do
- chunk <-
- case sz_in_bytes of
- 0 -> return nullPtr -- this has the effect of overwriting the pointer to the old buffer.
- _ -> do
- 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}
-
-%*********************************************************
-%* *
-\subsection{Types @Handle@, @Handle__@}
-%* *
-%*********************************************************
-
-The @Handle@ and @Handle__@ types are defined in @IOBase@.
-
-\begin{code}
-{-# INLINE newHandle #-}
-newHandle :: Handle__ -> IO Handle
-
--- Use MVars for concurrent Haskell
-newHandle hc = newMVar hc >>= \ h ->
- return (Handle h)
-\end{code}
-
-%*********************************************************
-%* *
-\subsection{@withHandle@ operations}
-%* *
-%*********************************************************
-
-In the concurrent world, handles are locked during use. This is done
-by wrapping an MVar around the handle which acts as a mutex over
-operations on the handle.
-
-To avoid races, we use the following bracketing operations. The idea
-is to obtain the lock, do some operation and replace the lock again,
-whether the operation succeeded or failed. We also want to handle the
-case where the thread receives an exception while processing the IO
-operation: in these cases we also want to relinquish the lock.
-
-There are three versions of @withHandle@: corresponding to the three
-possible combinations of:
-
- - the operation may side-effect the handle
- - the operation may return a result
-
-If the operation generates an error or an exception is raised, the
-orignal handle is always replaced [ this is the case at the moment,
-but we might want to revisit this in the future --SDM ].
-
-\begin{code}
-withHandle :: Handle -> (Handle__ -> IO (Handle__,a)) -> IO a
-{-# INLINE withHandle #-}
-withHandle (Handle h) act =
- block $ do
- h_ <- takeMVar h
- (h',v) <- catchException (act h_) (\ ex -> putMVar h h_ >> throw ex)
- putMVar h h'
- return v
-
-withHandle_ :: Handle -> (Handle__ -> IO a) -> IO a
-{-# INLINE withHandle_ #-}
-withHandle_ (Handle h) act =
- block $ do
- h_ <- takeMVar h
- v <- catchException (act h_) (\ ex -> putMVar h h_ >> throw ex)
- putMVar h h_
- return v
-
-withHandle__ :: Handle -> (Handle__ -> IO Handle__) -> IO ()
-{-# INLINE withHandle__ #-}
-withHandle__ (Handle h) act =
- block $ do
- h_ <- takeMVar h
- h' <- catchException (act h_) (\ ex -> putMVar h h_ >> throw ex)
- putMVar h h'
- return ()
-\end{code}
-
-nullFile__ is only used for closed handles, plugging it in as a null
-file object reference.
-
-\begin{code}
-nullFile__ :: FILE_OBJECT
-nullFile__ =
-#ifndef __PARALLEL_HASKELL__
- unsafePerformIO (newForeignPtr nullPtr (return ()))
-#else
- nullPtr
-#endif
-
-
-mkClosedHandle__ :: Handle__
-mkClosedHandle__ =
- Handle__ { haFO__ = nullFile__,
- haType__ = ClosedHandle,
- haBufferMode__ = NoBuffering,
- haFilePath__ = "closed file",
- haBuffers__ = []
- }
-\end{code}
-
-%*********************************************************
-%* *
-\subsection{Handle Finalizers}
-%* *
-%*********************************************************
-
-\begin{code}
-stdHandleFinalizer :: Handle -> IO ()
-stdHandleFinalizer (Handle hdl) = do
- handle <- takeMVar hdl
- let fo = haFO__ handle
- freeStdFileObject fo
- freeBuffers (haBuffers__ handle)
-
-handleFinalizer :: Handle -> IO ()
-handleFinalizer (Handle hdl) = do
- handle <- takeMVar hdl
- let fo = haFO__ handle
- freeFileObject fo
- freeBuffers (haBuffers__ handle)
-
-freeBuffers [] = return ()
-freeBuffers (b:bs) = do { free b; freeBuffers bs }
-
-foreign import "libHS_cbits" "freeStdFileObject" unsafe
- freeStdFileObject :: FILE_OBJECT -> IO ()
-foreign import "libHS_cbits" "freeFileObject" unsafe
- freeFileObject :: FILE_OBJECT -> IO ()
-foreign import "free" unsafe
- free :: Ptr a -> IO ()
-\end{code}
-
-%*********************************************************
-%* *
-\subsection[StdHandles]{Standard handles}
-%* *
-%*********************************************************
-
-Three handles are allocated during program initialisation. The first
-two manage input or output from the Haskell program's standard input
-or output channel respectively. The third manages output to the
-standard error channel. These handles are initially open.
-
-
-\begin{code}
-stdin, stdout, stderr :: Handle
-
-stdout = unsafePerformIO (do
- rc <- getLock (1::Int) (1::Int) -- ConcHask: SAFE, won't block
- case (rc::Int) of
- 0 -> newHandle (mkClosedHandle__)
- 1 -> do
- fo <- openStdFile (1::Int)
- (0::Int){-writeable-} -- ConcHask: SAFE, won't block
-
-#ifndef __PARALLEL_HASKELL__
- 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
- -- newForeignPtr. --SDM
-#endif
-
-#ifdef __HUGS__
-/* I dont care what the Haskell report says, in an interactive system,
- * stdout should be unbuffered by default.
- */
- let bm = NoBuffering
-#else
- (bm, bf_size) <- getBMode__ fo
- mkBuffer__ fo bf_size
-#endif
- hdl <- newHandle (Handle__ fo WriteHandle bm "stdout" [])
-
-#ifndef __PARALLEL_HASKELL__
- addForeignPtrFinalizer fo (stdHandleFinalizer hdl)
-#endif
- return hdl
-
- _ -> constructErrorAndFail "stdout"
- )
-
-stdin = unsafePerformIO (do
- rc <- getLock (0::Int) (0::Int) -- ConcHask: SAFE, won't block
- case (rc::Int) of
- 0 -> newHandle (mkClosedHandle__)
- 1 -> do
- fo <- openStdFile (0::Int)
- (1::Int){-readable-} -- ConcHask: SAFE, won't block
-
-#ifndef __PARALLEL_HASKELL__
- fo <- mkForeignPtr fo
-#endif
- (bm, bf_size) <- getBMode__ fo
- mkBuffer__ fo bf_size
- hdl <- newHandle (Handle__ fo ReadHandle bm "stdin" [])
- -- when stdin and stdout are both connected to a terminal, ensure
- -- that anything buffered on stdout is flushed prior to reading from
- -- stdin.
-#ifndef __PARALLEL_HASKELL__
- addForeignPtrFinalizer fo (stdHandleFinalizer hdl)
-#endif
- hConnectTerms stdout hdl
- return hdl
- _ -> constructErrorAndFail "stdin"
- )
-
-
-stderr = unsafePerformIO (do
- rc <- getLock (2::Int) (1::Int){-writeable-} -- ConcHask: SAFE, won't block
- case (rc::Int) of
- 0 -> newHandle (mkClosedHandle__)
- 1 -> do
- fo <- openStdFile (2::Int)
- (0::Int){-writeable-} -- ConcHask: SAFE, won't block
-
-#ifndef __PARALLEL_HASKELL__
- 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__
- addForeignPtrFinalizer fo (stdHandleFinalizer hdl)
-#endif
- hConnectTo stdout hdl
- return hdl
-
- _ -> constructErrorAndFail "stderr"
- )
-\end{code}
-
-%*********************************************************
-%* *
-\subsection[OpeningClosing]{Opening and Closing Files}
-%* *
-%*********************************************************
-
-\begin{code}
-data IOMode = ReadMode | WriteMode | AppendMode | ReadWriteMode
- deriving (Eq, Ord, Ix, Enum, Read, Show)
-
-data IOModeEx
- = BinaryMode IOMode
- | TextMode IOMode
- deriving (Eq, Read, Show)
-
-openFile :: FilePath -> IOMode -> IO Handle
-openFile fp im = openFileEx fp (TextMode im)
-
-openFileEx :: FilePath -> IOModeEx -> IO Handle
-
-openFileEx f m = do
- fo <- primOpenFile (packString f)
- (file_mode::Int)
- (binary::Int) -- ConcHask: SAFE, won't block
- if fo /= nullPtr then do
-#ifndef __PARALLEL_HASKELL__
- fo <- mkForeignPtr fo
-#endif
- (bm, bf_size) <- getBMode__ fo
- mkBuffer__ fo bf_size
- hdl <- newHandle (Handle__ fo htype bm f [])
-#ifndef __PARALLEL_HASKELL__
- addForeignPtrFinalizer fo (handleFinalizer hdl)
-#endif
- return hdl
- else do
- constructErrorAndFailWithInfo "openFile" f
- where
- (imo, binary) =
- case m of
- BinaryMode bmo -> (bmo, 1)
- TextMode tmo -> (tmo, 0)
-
- file_mode =
- case imo of
- AppendMode -> 0
- WriteMode -> 1
- ReadMode -> 2
- ReadWriteMode -> 3
-
- htype = case imo of
- ReadMode -> ReadHandle
- WriteMode -> WriteHandle
- AppendMode -> AppendHandle
- ReadWriteMode -> ReadWriteHandle
-\end{code}
-
-Computation $openFile file mode$ allocates and returns a new, open
-handle to manage the file {\em file}. It manages input if {\em mode}
-is $ReadMode$, output if {\em mode} is $WriteMode$ or $AppendMode$,
-and both input and output if mode is $ReadWriteMode$.
-
-If the file does not exist and it is opened for output, it should be
-created as a new file. If {\em mode} is $WriteMode$ and the file
-already exists, then it should be truncated to zero length. The
-handle is positioned at the end of the file if {\em mode} is
-$AppendMode$, and otherwise at the beginning (in which case its
-internal position is 0).
-
-Implementations should enforce, locally to the Haskell process,
-multiple-reader single-writer locking on files, which is to say that
-there may either be many handles on the same file which manage input,
-or just one handle on the file which manages output. If any open or
-semi-closed handle is managing a file for output, no new handle can be
-allocated for that file. If any open or semi-closed handle is
-managing a file for input, new handles can only be allocated if they
-do not manage output.
-
-Two files are the same if they have the same absolute name. An
-implementation is free to impose stricter conditions.
-
-\begin{code}
-hClose :: Handle -> IO ()
-
-hClose handle =
- withHandle__ handle $ \ handle_ -> do
- case haType__ handle_ of
- 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 ForeignPtr embedded in the Handle
- is still lying around in the heap, so care is taken
- 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())
- -}
-
- if (rc /= 0)
- then constructErrorAndFail "hClose"
-
- -- free the spare buffers (except the handle buffer)
- -- associated with this handle.
- else do freeBuffers (haBuffers__ handle_)
- return (handle_{ haType__ = ClosedHandle,
- haBuffers__ = [] })
-\end{code}
-
-Computation $hClose hdl$ makes handle {\em hdl} closed. Before the
-computation finishes, any items buffered for output and not already
-sent to the operating system are flushed as for $flush$.
-
-%*********************************************************
-%* *
-\subsection[FileSize]{Detecting the size of a file}
-%* *
-%*********************************************************
-
-
-For a handle {\em hdl} which attached to a physical file, $hFileSize
-hdl$ returns the size of {\em hdl} in terms of the number of items
-which can be read from {\em hdl}.
-
-\begin{code}
-hFileSize :: Handle -> IO Integer
-hFileSize handle =
- withHandle_ handle $ \ handle_ -> do
- case haType__ handle_ of
- ClosedHandle -> ioe_closedHandle "hFileSize" handle
- SemiClosedHandle -> ioe_closedHandle "hFileSize" handle
-#ifdef __HUGS__
- _ -> do
- mem <- primNewByteArray 8{-sizeof_int64-}
- rc <- fileSize_int64 (haFO__ handle_) mem -- ConcHask: SAFE, won't block
- if rc == 0 then do
- result <- primReadInt64Array mem 0
- return (primInt64ToInteger result)
- else
- constructErrorAndFail "hFileSize"
-#else
- _ ->
- -- HACK! We build a unique MP_INT of the right shape to hold
- -- a single unsigned word, and we let the C routine
- -- change the data bits
- --
- case int2Integer# 1# of
- (# s, d #) -> do
- rc <- fileSize (haFO__ handle_) d -- ConcHask: SAFE, won't block
- if rc == (0::Int) then
- return (J# s d)
- else
- constructErrorAndFail "hFileSize"
-#endif
-\end{code}
-
-%*********************************************************
-%* *
-\subsection[EOF]{Detecting the End of Input}
-%* *
-%*********************************************************
-
-
-For a readable handle {\em hdl}, @hIsEOF hdl@ returns
-@True@ if no further input can be taken from @hdl@ or for a
-physical file, if the current I/O position is equal to the length of
-the file. Otherwise, it returns @False@.
-
-\begin{code}
-hIsEOF :: Handle -> IO Bool
-hIsEOF handle = do
- rc <- mayBlockRead "hIsEOF" handle fileEOF
- case rc of
- 0 -> return False
- 1 -> return True
- _ -> constructErrorAndFail "hIsEOF"
-
-isEOF :: IO Bool
-isEOF = hIsEOF stdin
-\end{code}
-
-%*********************************************************
-%* *
-\subsection[Buffering]{Buffering Operations}
-%* *
-%*********************************************************
-
-Three kinds of buffering are supported: line-buffering,
-block-buffering or no-buffering. See @IOBase@ for definition
-and further explanation of what the type represent.
-
-Computation @hSetBuffering hdl mode@ sets the mode of buffering for
-handle {\em hdl} on subsequent reads and writes.
-
-\begin{itemize}
-\item
-If {\em mode} is @LineBuffering@, line-buffering should be
-enabled if possible.
-\item
-If {\em mode} is @BlockBuffering@ {\em size}, then block-buffering
-should be enabled if possible. The size of the buffer is {\em n} items
-if {\em size} is @Just@~{\em n} and is otherwise implementation-dependent.
-\item
-If {\em mode} is @NoBuffering@, then buffering is disabled if possible.
-\end{itemize}
-
-If the buffer mode is changed from @BlockBuffering@ or @LineBuffering@
-to @NoBuffering@, then any items in the output buffer are written to
-the device, and any items in the input buffer are discarded. The
-default buffering mode when a handle is opened is
-implementation-dependent and may depend on the object which is
-attached to that handle.
-
-\begin{code}
-hSetBuffering :: Handle -> BufferMode -> IO ()
-
-hSetBuffering handle mode =
- case mode of
- BlockBuffering (Just n)
- | n <= 0 -> ioException
- (IOError (Just handle)
- InvalidArgument
- "hSetBuffering"
- ("illegal buffer size " ++ showsPrec 9 n [])
- -- 9 => should be parens'ified.
- Nothing)
- _ ->
- withHandle__ handle $ \ handle_ -> do
- case haType__ handle_ of
- ClosedHandle -> ioe_closedHandle "hSetBuffering" handle
- _ -> do
- {- Note:
- - we flush the old buffer regardless of whether
- the new buffer could fit the contents of the old buffer
- or not.
- - allow a handle's buffering to change even if IO has
- occurred (ANSI C spec. does not allow this, nor did
- the previous implementation of IO.hSetBuffering).
- - a non-standard extension is to allow the buffering
- of semi-closed handles to change [sof 6/98]
- -}
- let fo = haFO__ handle_
- rc <- mayBlock fo (setBuffering fo bsize) -- ConcHask: UNSAFE, may block
- if rc == 0
- then do
- return (handle_{ haBufferMode__ = mode })
- else do
- -- Note: failure to change the buffer size will cause old buffer to be flushed.
- constructErrorAndFail "hSetBuffering"
- where
- bsize :: Int
- bsize = case mode of
- NoBuffering -> 0
- LineBuffering -> -1
- BlockBuffering Nothing -> -2
- BlockBuffering (Just n) -> n
-\end{code}
-
-The action @hFlush hdl@ causes any items buffered for output
-in handle {\em hdl} to be sent immediately to the operating
-system.
-
-\begin{code}
-hFlush :: Handle -> IO ()
-hFlush handle =
- wantWriteableHandle "hFlush" handle $ \ handle_ -> do
- let fo = haFO__ handle_
- rc <- mayBlock fo (flushFile fo) -- ConcHask: UNSAFE, may block
- if rc == 0 then
- return ()
- else
- constructErrorAndFail "hFlush"
-
-\end{code}
-
-
-%*********************************************************
-%* *
-\subsection[Seeking]{Repositioning Handles}
-%* *
-%*********************************************************
-
-\begin{code}
-data HandlePosn
- = HandlePosn
- Handle -- Q: should this be a weak or strong ref. to the handle?
- -- [what's the winning argument for it not being strong? --sof]
- HandlePosition
-
-instance Eq HandlePosn where
- (HandlePosn h1 p1) == (HandlePosn h2 p2) = p1==p2 && h1==h2
-
- -- HandlePosition is the Haskell equivalent of POSIX' off_t.
- -- We represent it as an Integer on the Haskell side, but
- -- cheat slightly in that hGetPosn calls upon a C helper
- -- that reports the position back via (merely) an Int.
-type HandlePosition = Integer
-
-mkHandlePosn :: Handle -> HandlePosition -> HandlePosn
-mkHandlePosn h p = HandlePosn h p
-
-data SeekMode = AbsoluteSeek | RelativeSeek | SeekFromEnd
- deriving (Eq, Ord, Ix, Enum, Read, Show)
-\end{code}
-
-Computation @hGetPosn hdl@ returns the current I/O
-position of {\em hdl} as an abstract position. Computation
-$hSetPosn p$ sets the position of {\em hdl}
-to a previously obtained position {\em p}.
-
-\begin{code}
-hGetPosn :: Handle -> IO HandlePosn
-hGetPosn handle =
- wantSeekableHandle "hGetPosn" handle $ \ handle_ -> do
- posn <- getFilePosn (haFO__ handle_) -- ConcHask: SAFE, won't block
- if posn /= -1 then do
- return (mkHandlePosn handle (int2Integer posn))
- else
- constructErrorAndFail "hGetPosn"
-
-hSetPosn :: HandlePosn -> IO ()
-hSetPosn (HandlePosn handle i@(S# _)) = hSetPosn (HandlePosn handle (toBig i))
-hSetPosn (HandlePosn handle (J# s# d#)) =
- wantSeekableHandle "hSetPosn" handle $ \ handle_ -> do
- -- not as silly as it looks: the handle may have been closed in the meantime.
- let fo = haFO__ handle_
- rc <- mayBlock fo (setFilePosn fo (I# s#) d#) -- ConcHask: UNSAFE, may block
- if rc == 0 then do
- return ()
- else
- constructErrorAndFail "hSetPosn"
-\end{code}
-
-The action @hSeek hdl mode i@ sets the position of handle
-@hdl@ depending on @mode@. If @mode@ is
-
- * AbsoluteSeek - The position of @hdl@ is set to @i@.
- * RelativeSeek - The position of @hdl@ is set to offset @i@ from
- the current position.
- * SeekFromEnd - The position of @hdl@ is set to offset @i@ from
- the end of the file.
-
-Some handles may not be seekable (see @hIsSeekable@), or only
-support a subset of the possible positioning operations (e.g. it may
-only be possible to seek to the end of a tape, or to a positive
-offset from the beginning or current position).
-
-It is not possible to set a negative I/O position, or for a physical
-file, an I/O position beyond the current end-of-file.
-
-Note:
- - when seeking using @SeekFromEnd@, positive offsets (>=0) means
- seeking at or past EOF.
- - relative seeking on buffered handles can lead to non-obvious results.
-
-\begin{code}
-hSeek :: Handle -> SeekMode -> Integer -> IO ()
-#ifdef __HUGS__
-hSeek handle mode offset =
- wantSeekableHandle "hSeek" handle $ \ handle_ -> do
- let fo = haFO__ handle_
- rc <- mayBlock fo (seekFile fo whence (primIntegerToInt64 offset)) -- ConcHask: UNSAFE, may block
-#else
-hSeek handle mode i@(S# _) = hSeek handle mode (toBig i)
-hSeek handle mode (J# s# d#) =
- wantSeekableHandle "hSeek" handle $ \ handle_ -> do
- let fo = haFO__ handle_
- rc <- mayBlock fo (seekFile fo whence (I# s#) d#) -- ConcHask: UNSAFE, may block
-#endif
- if rc == 0 then do
- return ()
- else
- constructErrorAndFail "hSeek"
- where
- whence :: Int
- whence = case mode of
- AbsoluteSeek -> 0
- RelativeSeek -> 1
- SeekFromEnd -> 2
-\end{code}
-
-%*********************************************************
-%* *
-\subsection[Query]{Handle Properties}
-%* *
-%*********************************************************
-
-A number of operations return information about the properties of a
-handle. Each of these operations returns $True$ if the
-handle has the specified property, and $False$
-otherwise.
-
-Computation $hIsBlockBuffered hdl$ returns $( False, Nothing )$ if
-{\em hdl} is not block-buffered. Otherwise it returns
-$( True, size )$, where {\em size} is $Nothing$ for default buffering, and
-$( Just n )$ for block-buffering of {\em n} bytes.
-
-\begin{code}
-hIsOpen :: Handle -> IO Bool
-hIsOpen handle =
- withHandle_ handle $ \ handle_ -> do
- case haType__ handle_ of
- ClosedHandle -> return False
- SemiClosedHandle -> return False
- _ -> return True
-
-hIsClosed :: Handle -> IO Bool
-hIsClosed handle =
- withHandle_ handle $ \ handle_ -> do
- case haType__ handle_ of
- ClosedHandle -> return True
- _ -> return False
-
-{- not defined, nor exported, but mentioned
- here for documentation purposes:
-
- hSemiClosed :: Handle -> IO Bool
- hSemiClosed h = do
- ho <- hIsOpen h
- hc <- hIsClosed h
- return (not (ho || hc))
--}
-
-hIsReadable :: Handle -> IO Bool
-hIsReadable handle =
- withHandle_ handle $ \ handle_ -> do
- case haType__ handle_ of
- ClosedHandle -> ioe_closedHandle "hIsReadable" handle
- SemiClosedHandle -> ioe_closedHandle "hIsReadable" handle
- htype -> return (isReadable htype)
- where
- isReadable ReadHandle = True
- isReadable ReadWriteHandle = True
- isReadable _ = False
-
-hIsWritable :: Handle -> IO Bool
-hIsWritable handle =
- withHandle_ handle $ \ handle_ -> do
- case haType__ handle_ of
- ClosedHandle -> ioe_closedHandle "hIsWritable" handle
- SemiClosedHandle -> ioe_closedHandle "hIsWritable" handle
- htype -> return (isWritable htype)
- where
- isWritable AppendHandle = True
- isWritable WriteHandle = True
- isWritable ReadWriteHandle = True
- isWritable _ = False
-
-
-getBMode__ :: FILE_OBJECT -> IO (BufferMode, Int)
-getBMode__ fo = do
- rc <- getBufferMode fo -- ConcHask: SAFE, won't block
- case (rc::Int) of
- 0 -> return (NoBuffering, 0)
- -1 -> return (LineBuffering, default_buffer_size)
- -2 -> return (BlockBuffering Nothing, default_buffer_size)
- -3 -> return (NoBuffering, 0) -- only happens on un-stat()able files.
- n -> return (BlockBuffering (Just n), n)
- where
- default_buffer_size :: Int
- default_buffer_size = const_BUFSIZ
-\end{code}
-
-Querying how a handle buffers its data:
-
-\begin{code}
-hGetBuffering :: Handle -> IO BufferMode
-hGetBuffering handle =
- withHandle_ handle $ \ handle_ -> do
- case haType__ handle_ of
- ClosedHandle -> ioe_closedHandle "hGetBuffering" handle
- _ ->
- {-
- We're being non-standard here, and allow the buffering
- of a semi-closed handle to be queried. -- sof 6/98
- -}
- return (haBufferMode__ handle_) -- could be stricter..
-\end{code}
-
-\begin{code}
-hIsSeekable :: Handle -> IO Bool
-hIsSeekable handle =
- withHandle_ handle $ \ handle_ -> do
- case haType__ handle_ of
- ClosedHandle -> ioe_closedHandle "hIsSeekable" handle
- SemiClosedHandle -> ioe_closedHandle "hIsSeekable" handle
- AppendHandle -> return False
- _ -> do
- rc <- seekFileP (haFO__ handle_) -- ConcHask: SAFE, won't block
- case (rc::Int) of
- 0 -> return False
- 1 -> return True
- _ -> constructErrorAndFail "hIsSeekable"
-\end{code}
-
-
-%*********************************************************
-%* *
-\subsection{Changing echo status}
-%* *
-%*********************************************************
-
-Non-standard GHC extension is to allow the echoing status
-of a handles connected to terminals to be reconfigured:
-
-\begin{code}
-hSetEcho :: Handle -> Bool -> IO ()
-hSetEcho handle on = do
- isT <- hIsTerminalDevice handle
- if not isT
- then return ()
- else
- withHandle_ handle $ \ handle_ -> do
- case haType__ handle_ of
- ClosedHandle -> ioe_closedHandle "hSetEcho" handle
- _ -> do
- rc <- setTerminalEcho (haFO__ handle_) (if on then 1 else 0) -- ConcHask: SAFE, won't block
- if rc /= ((-1)::Int)
- then return ()
- else constructErrorAndFail "hSetEcho"
-
-hGetEcho :: Handle -> IO Bool
-hGetEcho handle = do
- isT <- hIsTerminalDevice handle
- if not isT
- then return False
- else
- withHandle_ handle $ \ handle_ -> do
- case haType__ handle_ of
- ClosedHandle -> ioe_closedHandle "hGetEcho" handle
- _ -> do
- rc <- getTerminalEcho (haFO__ handle_) -- ConcHask: SAFE, won't block
- case (rc::Int) of
- 1 -> return True
- 0 -> return False
- _ -> constructErrorAndFail "hSetEcho"
-
-hIsTerminalDevice :: Handle -> IO Bool
-hIsTerminalDevice handle = do
- withHandle_ handle $ \ handle_ -> do
- case haType__ handle_ of
- ClosedHandle -> ioe_closedHandle "hIsTerminalDevice" handle
- _ -> do
- rc <- isTerminalDevice (haFO__ handle_) -- ConcHask: SAFE, won't block
- case (rc::Int) of
- 1 -> return True
- 0 -> return False
- _ -> constructErrorAndFail "hIsTerminalDevice"
-\end{code}
-
-\begin{code}
-hConnectTerms :: Handle -> Handle -> IO ()
-hConnectTerms hW hR = hConnectHdl_ hW hR 1{-check if they're both coming connected to ttys-}
-
-hConnectTo :: Handle -> Handle -> IO ()
-hConnectTo hW hR = hConnectHdl_ hW hR 0{-connect regardless-}
-
-hConnectHdl_ :: Handle -> Handle -> Int -> IO ()
-hConnectHdl_ hW hR is_tty =
- wantRWHandle "hConnectTo" hW $ \ hW_ ->
- wantRWHandle "hConnectTo" hR $ \ hR_ -> do
- setConnectedTo (haFO__ hR_) (haFO__ hW_) is_tty -- ConcHask: SAFE, won't block
-\end{code}
-
-As an extension, we also allow characters to be pushed back.
-Like ANSI C stdio, we guarantee no more than one character of
-pushback. (For unbuffered channels, the (default) push-back limit is
-2 chars tho.)
-
-\begin{code}
-hUngetChar :: Handle -> Char -> IO ()
-hUngetChar handle c =
- wantReadableHandle "hLookAhead" handle $ \ handle_ -> do
- rc <- ungetChar (haFO__ handle_) c -- ConcHask: SAFE, won't block
- if rc == ((-1)::Int)
- then constructErrorAndFail "hUngetChar"
- else return ()
-
-\end{code}
-
-
-Hoisting files in in one go is sometimes useful, so we support
-this as an extension:
-
-\begin{code}
--- in one go, read file into an externally allocated buffer.
-slurpFile :: FilePath -> IO (Ptr (), Int)
-slurpFile fname = do
- handle <- openFile fname ReadMode
- sz <- hFileSize handle
- if sz > toInteger (maxBound::Int) then
- ioError (userError "slurpFile: file too big")
- else do
- let sz_i = fromInteger sz
- chunk <- malloc sz_i
- if chunk == nullPtr
- then do
- hClose handle
- constructErrorAndFail "slurpFile"
- else do
- rc <- withHandle_ handle ( \ handle_ -> do
- let fo = haFO__ handle_
- mayBlock fo (readChunk fo chunk 0 sz_i) -- ConcHask: UNSAFE, may block.
- )
- hClose handle
- if rc < (0::Int)
- then constructErrorAndFail "slurpFile"
- else return (chunk, rc)
-
-\end{code}
-
-Sometimes it's useful to get at the file descriptor that
-the Handle contains..
-
-\begin{code}
-getHandleFd :: Handle -> IO Int
-getHandleFd handle =
- withHandle_ handle $ \ handle_ -> do
- case (haType__ handle_) of
- ClosedHandle -> ioe_closedHandle "getHandleFd" handle
- _ -> do
- fd <- getFileFd (haFO__ handle_)
- return fd
-\end{code}
-
-
-%*********************************************************
-%* *
-\subsection{Miscellaneous}
-%* *
-%*********************************************************
-
-These three functions are meant to get things out of @IOErrors@.
-
-(ToDo: improve!)
-
-\begin{code}
-ioeGetFileName :: IOError -> Maybe FilePath
-ioeGetErrorString :: IOError -> String
-ioeGetHandle :: IOError -> Maybe Handle
-
-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 (UserError str) = str
-ioeGetErrorString _ = error "IO.ioeGetErrorString: 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
-PrelMain.mainIO) and report them - topHandler is the exception
-handler they should use for this:
-
-\begin{code}
--- make sure we handle errors while reporting the error!
--- (e.g. evaluating the string passed to 'error' might generate
--- another error, etc.)
-topHandler :: Bool -> Exception -> IO ()
-topHandler bombOut err = catchException (real_handler bombOut err) (topHandler bombOut)
-
-real_handler :: Bool -> Exception -> IO ()
-real_handler bombOut ex =
- case ex of
- AsyncException StackOverflow -> reportStackOverflow bombOut
- ErrorCall s -> reportError bombOut s
- other -> reportError bombOut (showsPrec 0 other "\n")
-
-reportStackOverflow :: Bool -> IO ()
-reportStackOverflow bombOut = do
- (hFlush stdout) `catchException` (\ _ -> return ())
- callStackOverflowHook
- if bombOut then
- stg_exit 2
- else
- return ()
-
-reportError :: Bool -> String -> IO ()
-reportError bombOut str = do
- (hFlush stdout) `catchException` (\ _ -> return ())
- let bs@(ByteArray _ len _) = packString str
- writeErrString addrOf_ErrorHdrHook bs len
- if bombOut then
- stg_exit 1
- else
- return ()
-
-foreign import ccall "addrOf_ErrorHdrHook" unsafe
- addrOf_ErrorHdrHook :: Ptr ()
-
-foreign import ccall "writeErrString__" unsafe
- 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
- callStackOverflowHook :: IO ()
-
-foreign import ccall "stg_exit" unsafe
- stg_exit :: Int -> IO ()
-\end{code}
-
-
-A number of operations want to get at a readable or writeable handle, and fail
-if it isn't:
-
-\begin{code}
-wantReadableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
-wantReadableHandle fun handle act =
- withHandle_ handle $ \ handle_ -> do
- case haType__ handle_ of
- ClosedHandle -> ioe_closedHandle fun handle
- SemiClosedHandle -> ioe_closedHandle fun handle
- AppendHandle -> ioException not_readable_error
- WriteHandle -> ioException not_readable_error
- _ -> act handle_
- where
- not_readable_error =
- IOError (Just handle) IllegalOperation fun
- "handle is not open for reading" Nothing
-
-wantWriteableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
-wantWriteableHandle fun handle act =
- withHandle_ handle $ \ handle_ ->
- checkWriteableHandle fun handle handle_ (act handle_)
-
-wantWriteableHandle_ :: String -> Handle -> (Handle__ -> IO (Handle__, a)) -> IO a
-wantWriteableHandle_ fun handle act =
- withHandle handle $ \ handle_ ->
- checkWriteableHandle fun handle handle_ (act handle_)
-
-checkWriteableHandle fun handle handle_ act
- = case haType__ handle_ of
- ClosedHandle -> ioe_closedHandle fun handle
- SemiClosedHandle -> ioe_closedHandle fun handle
- ReadHandle -> ioException not_writeable_error
- _ -> act
- where
- not_writeable_error =
- 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
- ClosedHandle -> ioe_closedHandle fun handle
- SemiClosedHandle -> ioe_closedHandle fun handle
- _ -> act handle_
-
-wantSeekableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
-wantSeekableHandle fun handle act =
- withHandle_ handle $ \ handle_ -> do
- case haType__ handle_ of
- ClosedHandle -> ioe_closedHandle fun handle
- SemiClosedHandle -> ioe_closedHandle fun handle
- _ -> act handle_
-\end{code}
-
-Internal function for creating an @IOError@ representing the
-access to a closed file.
-
-\begin{code}
-ioe_closedHandle :: String -> Handle -> IO a
-ioe_closedHandle fun h = ioException (IOError (Just h) IllegalOperation fun
- "handle is closed" Nothing)
-\end{code}
-
-Internal helper functions for Concurrent Haskell implementation
-of IO:
-
-\begin{code}
-mayBlock :: FILE_OBJECT -> IO Int -> IO Int
-mayBlock fo act = do
- rc <- act
- case rc of
- -5 -> do -- (possibly blocking) read
- fd <- getFileFd fo
- threadWaitRead fd
- mayBlock fo act -- input available, re-try
- -6 -> do -- (possibly blocking) write
- fd <- getFileFd fo
- threadWaitWrite fd
- mayBlock fo act -- output possible
- -7 -> do -- (possibly blocking) write on connected handle
- fd <- getConnFileFd fo
- threadWaitWrite fd
- mayBlock fo act -- output possible
- _ -> do
- return rc
-
-data MayBlock a
- = BlockRead Int
- | BlockWrite Int
- | NoBlock a
-
-mayBlockRead :: String -> Handle -> (FILE_OBJECT -> IO Int) -> IO Int
-mayBlockRead fname handle fn = do
- r <- wantReadableHandle fname handle $ \ handle_ -> do
- let fo = haFO__ handle_
- rc <- fn fo
- case rc of
- -5 -> do -- (possibly blocking) read
- fd <- getFileFd fo
- return (BlockRead fd)
- -6 -> do -- (possibly blocking) write
- fd <- getFileFd fo
- return (BlockWrite fd)
- -7 -> do -- (possibly blocking) write on connected handle
- fd <- getConnFileFd fo
- return (BlockWrite fd)
- _ ->
- if rc >= 0
- then return (NoBlock rc)
- else constructErrorAndFail fname
- case r of
- BlockRead fd -> do
- threadWaitRead fd
- mayBlockRead fname handle fn
- BlockWrite fd -> do
- threadWaitWrite fd
- mayBlockRead fname handle fn
- NoBlock c -> return c
-
-mayBlockRead' :: String -> Handle
- -> (FILE_OBJECT -> IO Int)
- -> (FILE_OBJECT -> Int -> IO a)
- -> IO a
-mayBlockRead' fname handle fn io = do
- r <- wantReadableHandle fname handle $ \ handle_ -> do
- let fo = haFO__ handle_
- rc <- fn fo
- case rc of
- -5 -> do -- (possibly blocking) read
- fd <- getFileFd fo
- return (BlockRead fd)
- -6 -> do -- (possibly blocking) write
- fd <- getFileFd fo
- return (BlockWrite fd)
- -7 -> do -- (possibly blocking) write on connected handle
- fd <- getConnFileFd fo
- return (BlockWrite fd)
- _ ->
- if rc >= 0
- then do a <- io fo rc
- return (NoBlock a)
- else constructErrorAndFail fname
- case r of
- BlockRead fd -> do
- threadWaitRead fd
- mayBlockRead' fname handle fn io
- BlockWrite fd -> do
- threadWaitWrite fd
- mayBlockRead' fname handle fn io
- NoBlock c -> return c
-
-mayBlockWrite :: String -> Handle -> (FILE_OBJECT -> IO Int) -> IO Int
-mayBlockWrite fname handle fn = do
- r <- wantWriteableHandle fname handle $ \ handle_ -> do
- let fo = haFO__ handle_
- rc <- fn fo
- case rc of
- -5 -> do -- (possibly blocking) read
- fd <- getFileFd fo
- return (BlockRead fd)
- -6 -> do -- (possibly blocking) write
- fd <- getFileFd fo
- return (BlockWrite fd)
- -7 -> do -- (possibly blocking) write on connected handle
- fd <- getConnFileFd fo
- return (BlockWrite fd)
- _ ->
- if rc >= 0
- then return (NoBlock rc)
- else constructErrorAndFail fname
- case r of
- BlockRead fd -> do
- threadWaitRead fd
- mayBlockWrite fname handle fn
- BlockWrite fd -> do
- threadWaitWrite fd
- mayBlockWrite fname handle fn
- NoBlock c -> return c
-\end{code}
-
-Foreign import declarations of helper functions:
-
-\begin{code}
-
-#ifdef __HUGS__
-type Bytes = PrimByteArray RealWorld
-#else
-type Bytes = ByteArray#
-#endif
-
-foreign import "libHS_cbits" "inputReady" unsafe
- inputReady :: FILE_OBJECT -> Int -> IO Int{-ret code-}
-foreign import "libHS_cbits" "fileGetc" unsafe
- fileGetc :: FILE_OBJECT -> IO Int
-foreign import "libHS_cbits" "fileLookAhead" unsafe
- fileLookAhead :: FILE_OBJECT -> IO Int
-foreign import "libHS_cbits" "readBlock" unsafe
- readBlock :: FILE_OBJECT -> IO Int
-foreign import "libHS_cbits" "readLine" unsafe
- readLine :: FILE_OBJECT -> IO Int
-foreign import "libHS_cbits" "readChar" unsafe
- readChar :: FILE_OBJECT -> IO Int
-foreign import "libHS_cbits" "writeFileObject" unsafe
- writeFileObject :: FILE_OBJECT -> Int -> IO Int{-ret code-}
-foreign import "libHS_cbits" "filePutc" unsafe
- filePutc :: FILE_OBJECT -> Char -> IO Int{-ret code-}
-foreign import "libHS_cbits" "write_" unsafe
- write_ :: FILE_OBJECT -> Ptr () -> Int -> IO Int{-ret code-}
-foreign import "libHS_cbits" "getBufStart" unsafe
- getBufStart :: FILE_OBJECT -> Int -> IO (Ptr ())
-foreign import "libHS_cbits" "getWriteableBuf" unsafe
- getWriteableBuf :: FILE_OBJECT -> IO (Ptr ())
-foreign import "libHS_cbits" "getBuf" unsafe
- getBuf :: FILE_OBJECT -> IO (Ptr ())
-foreign import "libHS_cbits" "getBufWPtr" unsafe
- getBufWPtr :: FILE_OBJECT -> IO Int
-foreign import "libHS_cbits" "setBufWPtr" unsafe
- setBufWPtr :: FILE_OBJECT -> Int -> IO ()
-foreign import "libHS_cbits" "closeFile" unsafe
- closeFile :: FILE_OBJECT -> Int{-Flush-} -> IO Int{-ret code-}
-foreign import "libHS_cbits" "fileEOF" unsafe
- fileEOF :: FILE_OBJECT -> IO Int{-ret code-}
-foreign import "libHS_cbits" "setBuffering" unsafe
- setBuffering :: FILE_OBJECT -> Int -> IO Int{-ret code-}
-foreign import "libHS_cbits" "flushFile" unsafe
- flushFile :: FILE_OBJECT -> IO Int{-ret code-}
-foreign import "libHS_cbits" "flushConnectedBuf" unsafe
- flushConnectedBuf :: FILE_OBJECT -> IO ()
-foreign import "libHS_cbits" "getBufferMode" unsafe
- getBufferMode :: FILE_OBJECT -> IO Int{-ret code-}
-#ifdef __HUGS__
-foreign import "libHS_cbits" "seekFile_int64" unsafe
- seekFile :: FILE_OBJECT -> Int -> Int64 -> IO Int
-#else
-foreign import "libHS_cbits" "seekFile" unsafe
- seekFile :: FILE_OBJECT -> Int -> Int -> Bytes -> IO Int
-#endif
-
-foreign import "libHS_cbits" "seekFileP" unsafe
- seekFileP :: FILE_OBJECT -> IO Int{-ret code-}
-foreign import "libHS_cbits" "setTerminalEcho" unsafe
- setTerminalEcho :: FILE_OBJECT -> Int -> IO Int{-ret code-}
-foreign import "libHS_cbits" "getTerminalEcho" unsafe
- getTerminalEcho :: FILE_OBJECT -> IO Int{-ret code-}
-foreign import "libHS_cbits" "isTerminalDevice" unsafe
- isTerminalDevice :: FILE_OBJECT -> IO Int{-ret code-}
-foreign import "libHS_cbits" "setConnectedTo" unsafe
- setConnectedTo :: FILE_OBJECT -> FILE_OBJECT -> Int -> IO ()
-foreign import "libHS_cbits" "ungetChar" unsafe
- ungetChar :: FILE_OBJECT -> Char -> IO Int{-ret code-}
-foreign import "libHS_cbits" "readChunk" unsafe
- 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" "fileSize_int64" unsafe
- fileSize_int64 :: FILE_OBJECT -> Bytes -> IO Int{-ret code-}
-#else
-foreign import "libHS_cbits" "fileSize" unsafe
- fileSize :: FILE_OBJECT -> Bytes -> IO Int{-ret code-}
-#endif
-
-foreign import "libHS_cbits" "getFilePosn" unsafe
- getFilePosn :: FILE_OBJECT -> IO Int
-foreign import "libHS_cbits" "setFilePosn" unsafe
- setFilePosn :: FILE_OBJECT -> Int -> ByteArray# -> IO Int
-foreign import "libHS_cbits" "getConnFileFd" unsafe
- getConnFileFd :: FILE_OBJECT -> IO Int{-fd-}
-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 (Ptr ()){-file object-}
-foreign import "libHS_cbits" "openFile" unsafe
- primOpenFile :: ByteArray Int{-CString-}
- -> Int{-How-}
- -> Int{-Binary-}
- -> 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}
--- /dev/null
+{-# OPTIONS -fno-implicit-prelude #-}
+
+#undef DEBUG_DUMP
+
+-- -----------------------------------------------------------------------------
+-- $Id: PrelIO.hsc,v 1.1 2001/05/18 16:54:05 simonmar Exp $
+--
+-- (c) The University of Glasgow, 1992-2001
+--
+-- Module PrelIO
+
+-- This module defines all basic IO operations.
+-- These are needed for the IO operations exported by Prelude,
+-- but as it happens they also do everything required by library
+-- module IO.
+
+module PrelIO where
+
+#include "HsStd.h"
+#include "PrelHandle_hsc.h"
+
+import PrelBase
+
+import PrelPosix
+import PrelMarshalAlloc
+import PrelMarshalUtils
+import PrelStorable
+import PrelCError
+import PrelCString
+import PrelCTypes
+import PrelCTypesISO
+
+import PrelIOBase
+import PrelHandle -- much of the real stuff is in here
+
+import PrelMaybe
+import PrelReal
+import PrelNum
+import PrelRead ( Read(..), readIO )
+import PrelShow
+import PrelMaybe ( Maybe(..) )
+import PrelPtr
+import PrelList
+import PrelException ( ioError, catch, throw )
+import PrelConc
+
+-- -----------------------------------------------------------------------------
+-- Standard IO
+
+putChar :: Char -> IO ()
+putChar c = hPutChar stdout c
+
+putStr :: String -> IO ()
+putStr s = hPutStr stdout s
+
+putStrLn :: String -> IO ()
+putStrLn s = do putStr s
+ putChar '\n'
+
+print :: Show a => a -> IO ()
+print x = putStrLn (show x)
+
+getChar :: IO Char
+getChar = hGetChar stdin
+
+getLine :: IO String
+getLine = hGetLine stdin
+
+getContents :: IO String
+getContents = hGetContents stdin
+
+interact :: (String -> String) -> IO ()
+interact f = do s <- getContents
+ putStr (f s)
+
+readFile :: FilePath -> IO String
+readFile name = openFile name ReadMode >>= hGetContents
+
+writeFile :: FilePath -> String -> IO ()
+writeFile name str = do
+ hdl <- openFile name WriteMode
+ hPutStr hdl str
+ hClose hdl
+
+appendFile :: FilePath -> String -> IO ()
+appendFile name str = do
+ hdl <- openFile name AppendMode
+ hPutStr hdl str
+ hClose hdl
+
+readLn :: Read a => IO a
+readLn = do l <- getLine
+ r <- readIO l
+ return r
+
+-- ---------------------------------------------------------------------------
+-- Simple input operations
+
+-- Computation "hReady hdl" indicates whether at least
+-- one item is available for input from handle "hdl".
+
+-- If hWaitForInput finds anything in the Handle's buffer, it
+-- immediately returns. If not, it tries to read from the underlying
+-- OS handle. Notice that for buffered Handles connected to terminals
+-- this means waiting until a complete line is available.
+
+hReady :: Handle -> IO Bool
+hReady h = hWaitForInput h 0
+
+hWaitForInput :: Handle -> Int -> IO Bool
+hWaitForInput h msecs = do
+ wantReadableHandle "hReady" h $ \ handle_ -> do
+ let ref = haBuffer handle_
+ buf <- readIORef ref
+
+ if not (bufferEmpty buf)
+ then return True
+ else do
+
+ r <- throwErrnoIfMinus1Retry "hReady"
+ (inputReady (fromIntegral (haFD handle_)) (fromIntegral msecs))
+ return (r /= 0)
+
+foreign import "inputReady"
+ inputReady :: CInt -> CInt -> IO CInt
+
+-- ---------------------------------------------------------------------------
+-- hGetChar
+
+-- hGetChar reads the next character from a handle,
+-- blocking until a character is available.
+
+hGetChar :: Handle -> IO Char
+hGetChar handle =
+ wantReadableHandle "hGetChar" handle $ \handle_ -> do
+
+ let fd = haFD handle_
+ ref = haBuffer handle_
+
+ buf <- readIORef ref
+ if not (bufferEmpty buf)
+ then hGetcBuffered fd ref buf
+ else do
+
+ -- buffer is empty.
+ case haBufferMode handle_ of
+ LineBuffering -> do
+ new_buf <- fillReadBuffer fd True buf
+ hGetcBuffered fd ref new_buf
+ BlockBuffering _ -> do
+ new_buf <- fillReadBuffer fd False buf
+ hGetcBuffered fd ref new_buf
+ NoBuffering -> do
+ -- make use of the minimal buffer we already have
+ let raw = bufBuf buf
+ r <- throwErrnoIfMinus1RetryMayBlock "hGetChar"
+ (read_off (fromIntegral fd) raw 0 1)
+ (threadWaitRead fd)
+ if r == 0
+ then ioe_EOF
+ else do (c,_) <- readCharFromBuffer raw 0
+ return c
+
+hGetcBuffered fd ref buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w }
+ = do (c,r) <- readCharFromBuffer b r
+ let new_buf | r == w = buf{ bufRPtr=0, bufWPtr=0 }
+ | otherwise = buf{ bufRPtr=r }
+ writeIORef ref new_buf
+ return c
+
+-- ---------------------------------------------------------------------------
+-- hGetLine
+
+-- If EOF is reached before EOL is encountered, ignore the EOF and
+-- return the partial line. Next attempt at calling hGetLine on the
+-- handle will yield an EOF IO exception though.
+
+-- ToDo: the unbuffered case is wrong: it doesn't lock the handle for
+-- the duration.
+hGetLine :: Handle -> IO String
+hGetLine h = do
+ m <- wantReadableHandle "hGetLine" h $ \ handle_ -> do
+ case haBufferMode handle_ of
+ NoBuffering -> return Nothing
+ LineBuffering -> do
+ l <- hGetLineBuffered handle_
+ return (Just l)
+ BlockBuffering _ -> do
+ l <- hGetLineBuffered handle_
+ return (Just l)
+ case m of
+ Nothing -> hGetLineUnBuffered h
+ Just l -> return l
+
+
+hGetLineBuffered handle_ = do
+ let ref = haBuffer handle_
+ buf <- readIORef ref
+ hGetLineBufferedLoop handle_ ref buf []
+
+
+hGetLineBufferedLoop handle_ ref
+ buf@Buffer{ bufRPtr=r, bufWPtr=w, bufBuf=raw } xss =
+ let
+ -- find the end-of-line character, if there is one
+ loop raw r
+ | r == w = return (False, w)
+ | otherwise = do
+ (c,r') <- readCharFromBuffer raw r
+ if c == '\n'
+ then return (True, r) -- NB. not r': don't include the '\n'
+ else loop raw r'
+ in do
+ (eol, off) <- loop raw r
+
+#ifdef DEBUG_DUMP
+ puts ("hGetLineBufferedLoop: r=" ++ show r ++ ", w=" ++ show w ++ ", off=" ++ show off ++ "\n")
+#endif
+
+ xs <- unpack raw r off
+ if eol
+ then do if w == off + 1
+ then writeIORef ref buf{ bufRPtr=0, bufWPtr=0 }
+ else writeIORef ref buf{ bufRPtr = off + 1 }
+ return (concat (reverse (xs:xss)))
+ else do
+ maybe_buf <- maybeFillReadBuffer (haFD handle_) True
+ buf{ bufWPtr=0, bufRPtr=0 }
+ case maybe_buf of
+ -- Nothing indicates we caught an EOF, and we may have a
+ -- partial line to return.
+ Nothing -> let str = concat (reverse (xs:xss)) in
+ if not (null str)
+ then return str
+ else ioe_EOF
+ Just new_buf ->
+ hGetLineBufferedLoop handle_ ref new_buf (xs:xss)
+
+
+unpack :: RawBuffer -> Int -> Int -> IO [Char]
+unpack buf r 0 = return ""
+unpack buf (I## r) (I## len) = IO $ \s -> unpack [] (len -## 1##) s
+ where
+ unpack acc i s
+ | i <## r = (## s, acc ##)
+ | otherwise =
+ case readCharArray## buf i s of
+ (## s, ch ##) -> unpack (C## ch : acc) (i -## 1##) s
+
+
+hGetLineUnBuffered :: Handle -> IO String
+hGetLineUnBuffered h = do
+ c <- hGetChar h
+ if c == '\n' then
+ return ""
+ else do
+ l <- getRest
+ return (c:l)
+ where
+ getRest = do
+ c <-
+ catch
+ (hGetChar h)
+ (\ err -> do
+ if isEOFError err then
+ return '\n'
+ else
+ ioError err)
+ if c == '\n' then
+ return ""
+ else do
+ s <- getRest
+ return (c:s)
+
+-- -----------------------------------------------------------------------------
+-- hGetContents
+
+-- hGetContents returns the list of characters corresponding to the
+-- unread portion of the channel or file managed by the handle, which
+-- is made semi-closed.
+
+hGetContents :: Handle -> IO String
+hGetContents handle =
+ -- can't use wantReadableHandle here, because we want to side effect
+ -- the handle.
+ withHandle "hGetContents" handle $ \ handle_ -> do
+ case haType handle_ of
+ ClosedHandle -> ioe_closedHandle
+ SemiClosedHandle -> ioe_closedHandle
+ AppendHandle -> ioException not_readable_error
+ WriteHandle -> ioException not_readable_error
+ _ -> do xs <- lazyRead handle
+ return (handle_{ haType=SemiClosedHandle}, xs )
+ where
+ not_readable_error =
+ IOError (Just handle) IllegalOperation "hGetContents"
+ "handle is not open for reading" Nothing
+
+-- Note that someone may close the semi-closed handle (or change its
+-- buffering), so each these lazy read functions are pulled on, they
+-- have to check whether the handle has indeed been closed.
+
+lazyRead :: Handle -> IO String
+lazyRead handle =
+ unsafeInterleaveIO $
+ withHandle_ "lazyRead" handle $ \ handle_ -> do
+ case haType handle_ of
+ ClosedHandle -> return ""
+ SemiClosedHandle -> lazyRead' handle handle_
+ _ -> ioException
+ (IOError (Just handle) IllegalOperation "lazyRead"
+ "illegal handle type" Nothing)
+
+lazyRead' h handle_ = do
+ let ref = haBuffer handle_
+ fd = haFD handle_
+
+ -- even a NoBuffering handle can have a char in the buffer...
+ -- (see hLookAhead)
+ buf <- readIORef ref
+ if not (bufferEmpty buf)
+ then lazyReadBuffered h fd ref buf
+ else do
+
+ case haBufferMode handle_ of
+ NoBuffering -> do
+ -- make use of the minimal buffer we already have
+ let raw = bufBuf buf
+ fd = haFD handle_
+ r <- throwErrnoIfMinus1RetryMayBlock "hGetChar"
+ (read_off (fromIntegral fd) raw 0 1)
+ (threadWaitRead fd)
+ if r == 0
+ then return ""
+ else do (c,_) <- readCharFromBuffer raw 0
+ rest <- lazyRead h
+ return (c : rest)
+
+ LineBuffering -> lazyReadBuffered h fd ref buf
+ BlockBuffering _ -> lazyReadBuffered h fd ref buf
+
+-- we never want to block during the read, so we call fillReadBuffer with
+-- is_line==True, which tells it to "just read what there is".
+lazyReadBuffered h fd ref buf = do
+ maybe_new_buf <-
+ if bufferEmpty buf
+ then maybeFillReadBuffer fd True buf
+ else return (Just buf)
+ case maybe_new_buf of
+ Nothing -> return ""
+ Just buf -> do
+ more <- lazyRead h
+ writeIORef ref buf{ bufRPtr=0, bufWPtr=0 }
+ unpackAcc (bufBuf buf) (bufRPtr buf) (bufWPtr buf) more
+
+
+maybeFillReadBuffer fd is_line buf
+ = catch
+ (do buf <- fillReadBuffer fd is_line buf
+ return (Just buf)
+ )
+ (\e -> if isEOFError e
+ then return Nothing
+ else throw e)
+
+
+unpackAcc :: RawBuffer -> Int -> Int -> [Char] -> IO [Char]
+unpackAcc buf r 0 acc = return ""
+unpackAcc buf (I## r) (I## len) acc = IO $ \s -> unpack acc (len -## 1##) s
+ where
+ unpack acc i s
+ | i <## r = (## s, acc ##)
+ | otherwise =
+ case readCharArray## buf i s of
+ (## s, ch ##) -> unpack (C## ch : acc) (i -## 1##) s
+
+-- ---------------------------------------------------------------------------
+-- hPutChar
+
+-- `hPutChar hdl ch' writes the character `ch' to the file or channel
+-- managed by `hdl'. Characters may be buffered if buffering is
+-- enabled for `hdl'.
+
+hPutChar :: Handle -> Char -> IO ()
+hPutChar handle c =
+ c `seq` do -- must evaluate c before grabbing the handle lock
+ wantWritableHandle "hPutChar" handle $ \ handle_ -> do
+ let fd = haFD handle_
+ case haBufferMode handle_ of
+ LineBuffering -> hPutcBuffered handle_ True c
+ BlockBuffering _ -> hPutcBuffered handle_ False c
+ NoBuffering ->
+ withObject (castCharToCChar c) $ \buf ->
+ throwErrnoIfMinus1RetryMayBlock_ "hPutChar"
+ (c_write (fromIntegral fd) buf 1)
+ (threadWaitWrite fd)
+
+
+hPutcBuffered handle_ is_line c = do
+ let ref = haBuffer handle_
+ buf <- readIORef ref
+ let w = bufWPtr buf
+ w' <- writeCharIntoBuffer (bufBuf buf) w c
+ let new_buf = buf{ bufWPtr = w' }
+ if bufferFull new_buf || is_line && c == '\n'
+ then do
+ flushed_buf <- flushWriteBuffer (haFD handle_) new_buf
+ writeIORef ref flushed_buf
+ else do
+ writeIORef ref new_buf
+
+
+hPutChars :: Handle -> [Char] -> IO ()
+hPutChars handle [] = return ()
+hPutChars handle (c:cs) = hPutChar handle c >> hPutChars handle cs
+
+-- ---------------------------------------------------------------------------
+-- hPutStr
+
+-- `hPutStr hdl s' writes the string `s' to the file or
+-- hannel managed by `hdl', buffering the output if needs be.
+
+-- We go to some trouble to avoid keeping the handle locked while we're
+-- evaluating the string argument to hPutStr, in case doing so triggers another
+-- I/O operation on the same handle which would lead to deadlock. The classic
+-- case is
+--
+-- putStr (trace "hello" "world")
+--
+-- so the basic scheme is this:
+--
+-- * copy the string into a fresh buffer,
+-- * "commit" the buffer to the handle.
+--
+-- Committing may involve simply copying the contents of the new
+-- buffer into the handle's buffer, flushing one or both buffers, or
+-- maybe just swapping the buffers over (if the handle's buffer was
+-- empty). See commitBuffer below.
+
+hPutStr :: Handle -> String -> IO ()
+hPutStr handle str = do
+ buffer_mode <- wantWritableHandle "hPutStr" handle
+ (\ handle_ -> do getSpareBuffer handle_)
+ case buffer_mode of
+ (NoBuffering, _) -> do
+ hPutChars handle str -- v. slow, but we don't care
+ (LineBuffering, buf) -> do
+ writeLines handle buf str
+ (BlockBuffering _, buf) -> do
+ writeBlocks handle buf str
+
+
+getSpareBuffer :: Handle__ -> IO (BufferMode, Buffer)
+getSpareBuffer handle_ = do
+ let mode = haBufferMode handle_
+ case mode of
+ NoBuffering -> return (mode, error "no buffer!")
+ _ -> do
+ let spare_ref = haBuffers handle_
+ ref = haBuffer handle_
+ bufs <- readIORef spare_ref
+ buf <- readIORef ref
+ case bufs of
+ BufferListCons b rest -> do
+ writeIORef spare_ref rest
+ return ( mode, newEmptyBuffer b WriteBuffer (bufSize buf))
+ BufferListNil -> do
+ new_buf <- allocateBuffer (bufSize buf) WriteBuffer
+ return (mode, new_buf)
+
+
+writeLines :: Handle -> Buffer -> String -> IO ()
+writeLines hdl Buffer{ bufBuf=raw, bufSize=len } s =
+ let
+ shoveString :: Int -> [Char] -> IO ()
+ -- check n == len first, to ensure that shoveString is strict in n.
+ shoveString n cs | n == len = do
+ new_buf <- commitBuffer hdl raw len n True{-needs flush-} False
+ writeBlocks hdl new_buf cs
+ shoveString n [] = do
+ commitBuffer hdl raw len n False{-no flush-} True{-release-}
+ return ()
+ shoveString n (c:cs) = do
+ n' <- writeCharIntoBuffer raw n c
+ shoveString n' cs
+ in
+ shoveString 0 s
+
+writeBlocks :: Handle -> Buffer -> String -> IO ()
+writeBlocks hdl Buffer{ bufBuf=raw, bufSize=len } s =
+ let
+ shoveString :: Int -> [Char] -> IO ()
+ -- check n == len first, to ensure that shoveString is strict in n.
+ shoveString n cs | n == len = do
+ new_buf <- commitBuffer hdl raw len n True{-needs flush-} False
+ writeBlocks hdl new_buf cs
+ shoveString n [] = do
+ commitBuffer hdl raw len n False{-no flush-} True{-release-}
+ return ()
+ shoveString n (c:cs) = do
+ n' <- writeCharIntoBuffer raw n c
+ shoveString n' cs
+ in
+ shoveString 0 s
+
+-- -----------------------------------------------------------------------------
+-- commitBuffer handle buf sz count flush release
+--
+-- Write the contents of the buffer 'buf' ('sz' bytes long, containing
+-- 'count' bytes of data) to handle (handle must be block or line buffered).
+--
+-- Implementation:
+--
+-- for block/line buffering,
+-- 1. If there isn't room in the handle buffer, flush the handle
+-- buffer.
+--
+-- 2. If the handle buffer is empty,
+-- if flush,
+-- then write buf directly to the device.
+-- else swap the handle buffer with buf.
+--
+-- 3. If the handle buffer is non-empty, copy buf into the
+-- handle buffer. Then, if flush != 0, flush
+-- the buffer.
+
+commitBuffer
+ :: Handle -- handle to commit to
+ -> RawBuffer -> Int -- address and size (in bytes) of buffer
+ -> Int -- number of bytes of data in buffer
+ -> Bool -- flush the handle afterward?
+ -> Bool -- release the buffer?
+ -> IO Buffer
+
+commitBuffer hdl raw sz count flush release = do
+ wantWritableHandle "commitAndReleaseBuffer" hdl $
+ \ handle_@Handle__{ haFD=fd, haBuffer=ref, haBuffers=spare_buf_ref } -> do
+
+#ifdef DEBUG_DUMP
+ puts ("commitBuffer: sz=" ++ show sz ++ ", count=" ++ show count
+ ++ ", flush=" ++ show flush ++ ", release=" ++ show release ++"\n")
+#endif
+
+ old_buf@Buffer{ bufBuf=old_raw, bufRPtr=r, bufWPtr=w, bufSize=size }
+ <- readIORef ref
+
+ buf_ret <-
+ -- enough room in handle buffer?
+ if (not flush && (size - w > count))
+ -- The > is to be sure that we never exactly fill
+ -- up the buffer, which would require a flush. So
+ -- if copying the new data into the buffer would
+ -- make the buffer full, we just flush the existing
+ -- buffer and the new data immediately, rather than
+ -- copying before flushing.
+
+ -- not flushing, and there's enough room in the buffer:
+ -- just copy the data in and update bufWPtr.
+ then do memcpy_off old_raw w raw (fromIntegral count)
+ writeIORef ref old_buf{ bufWPtr = w + count }
+ return (newEmptyBuffer raw WriteBuffer sz)
+
+ -- else, we have to flush
+ else do flushed_buf <- flushWriteBuffer fd old_buf
+
+ let this_buf =
+ Buffer{ bufBuf=raw, bufState=WriteBuffer,
+ bufRPtr=0, bufWPtr=count, bufSize=sz }
+
+ -- if: (a) we don't have to flush, and
+ -- (b) size(new buffer) == size(old buffer), and
+ -- (c) new buffer is not full,
+ -- we can just just swap them over...
+ if (not flush && sz == size && count /= sz)
+ then do
+ writeIORef ref this_buf
+ return flushed_buf
+
+ -- otherwise, we have to flush the new data too,
+ -- and start with a fresh buffer
+ else do
+ flushWriteBuffer fd this_buf
+ writeIORef ref flushed_buf
+ -- if the sizes were different, then allocate
+ -- a new buffer of the correct size.
+ if sz == size
+ then return (newEmptyBuffer raw WriteBuffer sz)
+ else allocateBuffer size WriteBuffer
+
+ -- release the buffer if necessary
+ if release && bufSize buf_ret == size
+ then do
+ spare_bufs <- readIORef spare_buf_ref
+ writeIORef spare_buf_ref
+ (BufferListCons (bufBuf buf_ret) spare_bufs)
+ return buf_ret
+ else
+ return buf_ret
+
+
+foreign import "memcpy_wrap" unsafe
+ memcpy_off :: RawBuffer -> Int -> RawBuffer -> CSize -> IO (Ptr ())
+#def inline \
+void *memcpy_wrap(char *dst, int dst_off, char *src, size_t sz) \
+{ return memcpy(dst+dst_off, src, sz); }
+
+-- ---------------------------------------------------------------------------
+-- hPutStrLn
+
+-- Derived action `hPutStrLn hdl str' writes the string `str' to
+-- the handle `hdl', adding a newline at the end.
+
+hPutStrLn :: Handle -> String -> IO ()
+hPutStrLn hndl str = do
+ hPutStr hndl str
+ hPutChar hndl '\n'
+
+-- ---------------------------------------------------------------------------
+-- hPrint
+
+-- Computation `hPrint hdl t' writes the string representation of `t'
+-- given by the `shows' function to the file or channel managed by `hdl'.
+
+hPrint :: Show a => Handle -> a -> IO ()
+hPrint hdl = hPutStrLn hdl . show
+++ /dev/null
-% ------------------------------------------------------------------------------
-% $Id: PrelIO.lhs,v 1.18 2001/01/11 17:25:57 simonmar Exp $
-%
-% (c) The University of Glasgow, 1992-2000
-%
-
-\section[PrelIO]{Module @PrelIO@}
-
-This module defines all basic IO operations.
-These are needed for the IO operations exported by Prelude,
-but as it happens they also do everything required by library
-module IO.
-
-
-\begin{code}
-{-# OPTIONS -fno-implicit-prelude -#include "cbits/stgio.h" #-}
-
-module PrelIO where
-
-import PrelBase
-
-import PrelIOBase
-import PrelHandle -- much of the real stuff is in here
-
-import PrelNum
-import PrelRead ( Read(..), readIO )
-import PrelShow
-import PrelMaybe ( Maybe(..) )
-import PrelPtr
-import PrelList ( concat, reverse, null )
-import PrelPack ( unpackNBytesST, unpackNBytesAccST )
-import PrelException ( ioError, catch, catchException, throw )
-import PrelConc
-
-#ifndef __PARALLEL_HASKELL__
-#define FILE_OBJECT (ForeignPtr ())
-#else
-#define FILE_OBJECT (Ptr ())
-#endif
-\end{code}
-
-%*********************************************************
-%* *
-\subsection{Standard IO}
-%* *
-%*********************************************************
-
-The Prelude has from Day 1 provided a collection of common
-IO functions. We define these here, but let the Prelude
-export them.
-
-\begin{code}
-putChar :: Char -> IO ()
-putChar c = hPutChar stdout c
-
-putStr :: String -> IO ()
-putStr s = hPutStr stdout s
-
-putStrLn :: String -> IO ()
-putStrLn s = do putStr s
- putChar '\n'
-
-print :: Show a => a -> IO ()
-print x = putStrLn (show x)
-
-getChar :: IO Char
-getChar = hGetChar stdin
-
-getLine :: IO String
-getLine = hGetLine stdin
-
-getContents :: IO String
-getContents = hGetContents stdin
-
-interact :: (String -> String) -> IO ()
-interact f = do s <- getContents
- putStr (f s)
-
-readFile :: FilePath -> IO String
-readFile name = openFile name ReadMode >>= hGetContents
-
-writeFile :: FilePath -> String -> IO ()
-writeFile name str = do
- hdl <- openFile name WriteMode
- hPutStr hdl str
- hClose hdl
-
-appendFile :: FilePath -> String -> IO ()
-appendFile name str = do
- hdl <- openFile name AppendMode
- hPutStr hdl str
- hClose hdl
-
-readLn :: Read a => IO a
-readLn = do l <- getLine
- r <- readIO l
- return r
-\end{code}
-
-
-%*********************************************************
-%* *
-\subsection{Simple input operations}
-%* *
-%*********************************************************
-
-Computation @hReady hdl@ indicates whether at least
-one item is available for input from handle {\em hdl}.
-
-@hWaitForInput@ is the generalisation, wait for \tr{n} milliseconds
-before deciding whether the Handle has run dry or not.
-
-If @hWaitForInput@ finds anything in the Handle's buffer, it immediately returns.
-If not, it tries to read from the underlying OS handle. Notice that
-for buffered Handles connected to terminals this means waiting until a complete
-line is available.
-
-\begin{code}
-hReady :: Handle -> IO Bool
-hReady h = hWaitForInput h 0
-
-hWaitForInput :: Handle -> Int -> IO Bool
-hWaitForInput handle msecs =
- wantReadableHandle "hWaitForInput" handle $ \ handle_ -> do
- rc <- inputReady (haFO__ handle_) (msecs::Int) -- ConcHask: SAFE, won't block
- case (rc::Int) of
- 0 -> return False
- 1 -> return True
- _ -> constructErrorAndFail "hWaitForInput"
-\end{code}
-
-@hGetChar hdl@ reads the next character from handle @hdl@,
-blocking until a character is available.
-
-\begin{code}
-hGetChar :: Handle -> IO Char
-hGetChar handle = do
- c <- mayBlockRead "hGetChar" handle fileGetc
- return (chr c)
-
-{-
- If EOF is reached before EOL is encountered, ignore the
- EOF and return the partial line. Next attempt at calling
- hGetLine on the handle will yield an EOF IO exception though.
--}
-
-hGetLine :: Handle -> IO String
-hGetLine h = do
- buffer_mode <- wantReadableHandle "hGetLine" h
- (\ handle_ -> do return (haBufferMode__ handle_))
- case buffer_mode of
- NoBuffering -> hGetLineUnBuffered h
- LineBuffering -> hGetLineBuf' []
- BlockBuffering _ -> hGetLineBuf' []
-
- where hGetLineBuf' xss = do
- (eol, xss) <- catch
- ( do
- mayBlockRead' "hGetLine" h
- (\fo -> readLine fo)
- (\fo bytes -> do
- buf <- getBufStart fo bytes
- eol <- readCharOffPtr buf (bytes-1)
- xs <- if (eol == '\n')
- then stToIO (unpackNBytesST buf (bytes-1))
- else stToIO (unpackNBytesST buf bytes)
- return (eol, xs:xss)
- )
- )
- (\e -> if isEOFError e && not (null xss)
- then return ('\n', xss)
- else ioError e)
-
- if (eol == '\n')
- then return (concat (reverse xss))
- else hGetLineBuf' xss
-
-
-hGetLineUnBuffered :: Handle -> IO String
-hGetLineUnBuffered h = do
- c <- hGetChar h
- if c == '\n' then
- return ""
- else do
- l <- getRest
- return (c:l)
- where
- getRest = do
- c <-
- catch
- (hGetChar h)
- (\ err -> do
- if isEOFError err then
- return '\n'
- else
- ioError err)
- if c == '\n' then
- return ""
- else do
- s <- getRest
- return (c:s)
-
-
-readCharOffPtr (Ptr a) (I# i)
- = IO $ \s -> case readCharOffAddr# a i s of { (# s,x #) -> (# s, C# x #) }
-\end{code}
-
-@hLookahead hdl@ returns the next character from handle @hdl@
-without removing it from the input buffer, blocking until a
-character is available.
-
-\begin{code}
-hLookAhead :: Handle -> IO Char
-hLookAhead handle = do
- rc <- mayBlockRead "hLookAhead" handle fileLookAhead
- return (chr rc)
-\end{code}
-
-
-%*********************************************************
-%* *
-\subsection{Getting the entire contents of a handle}
-%* *
-%*********************************************************
-
-@hGetContents hdl@ returns the list of characters corresponding
-to the unread portion of the channel or file managed by @hdl@,
-which is made semi-closed.
-
-\begin{code}
-hGetContents :: Handle -> IO String
-hGetContents handle =
- -- can't use wantReadableHandle here, because we want to side effect
- -- the handle.
- withHandle handle $ \ handle_ -> do
- case haType__ handle_ of
- ClosedHandle -> ioe_closedHandle "hGetContents" handle
- SemiClosedHandle -> ioe_closedHandle "hGetContents" handle
- AppendHandle -> ioException not_readable_error
- WriteHandle -> ioException not_readable_error
- _ -> do
- {-
- To avoid introducing an extra layer of buffering here,
- we provide three lazy read methods, based on character,
- line, and block buffering.
- -}
- let handle_' = handle_{ haType__ = SemiClosedHandle }
- case (haBufferMode__ handle_) of
- LineBuffering -> do
- str <- unsafeInterleaveIO (lazyReadLine handle (haFO__ handle_))
- return (handle_', str)
- BlockBuffering _ -> do
- str <- unsafeInterleaveIO (lazyReadBlock handle (haFO__ handle_))
- return (handle_', str)
- NoBuffering -> do
- str <- unsafeInterleaveIO (lazyReadChar handle (haFO__ handle_))
- return (handle_', str)
- where
- not_readable_error =
- IOError (Just handle) IllegalOperation "hGetContents"
- "handle is not open for reading" Nothing
-\end{code}
-
-Note that someone may close the semi-closed handle (or change its buffering),
-so each these lazy read functions are pulled on, they have to check whether
-the handle has indeed been closed.
-
-\begin{code}
-lazyReadBlock :: Handle -> FILE_OBJECT -> IO String
-lazyReadLine :: Handle -> FILE_OBJECT -> IO String
-lazyReadChar :: Handle -> FILE_OBJECT -> IO String
-
-lazyReadBlock handle fo = do
- buf <- getBufStart fo 0
- bytes <- mayBlock fo (readBlock fo) -- ConcHask: UNSAFE, may block.
- case (bytes::Int) of
- -3 -> -- buffering has been turned off, use lazyReadChar instead
- lazyReadChar handle fo
- -2 -> return ""
- -1 -> -- an error occurred, close the handle
- withHandle handle $ \ handle_ -> do
- closeFile (haFO__ handle_) 0{-don't bother flushing-} -- ConcHask: SAFE, won't block.
- return (handle_ { haType__ = ClosedHandle }, "")
- _ -> do
- more <- unsafeInterleaveIO (lazyReadBlock handle fo)
- stToIO (unpackNBytesAccST buf bytes more)
-
-lazyReadLine handle fo = do
- bytes <- mayBlock fo (readLine fo) -- ConcHask: UNSAFE, may block.
- case (bytes::Int) of
- -3 -> -- buffering has been turned off, use lazyReadChar instead
- lazyReadChar handle fo
- -2 -> return "" -- handle closed by someone else, stop reading.
- -1 -> -- an error occurred, close the handle
- withHandle handle $ \ handle_ -> do
- closeFile (haFO__ handle_) 0{- don't bother flushing-} -- ConcHask: SAFE, won't block
- return (handle_ { haType__ = ClosedHandle }, "")
- _ -> do
- more <- unsafeInterleaveIO (lazyReadLine handle fo)
- buf <- getBufStart fo bytes -- ConcHask: won't block
- stToIO (unpackNBytesAccST buf bytes more)
-
-lazyReadChar handle fo = do
- char <- mayBlock fo (readChar fo) -- ConcHask: UNSAFE, may block.
- case (char::Int) of
- -4 -> -- buffering is now block-buffered, use lazyReadBlock instead
- lazyReadBlock handle fo
-
- -3 -> -- buffering is now line-buffered, use lazyReadLine instead
- lazyReadLine handle fo
- -2 -> return ""
- -1 -> -- error, silently close handle.
- withHandle handle $ \ handle_ -> do
- closeFile (haFO__ handle_) 0{-don't bother flusing-} -- ConcHask: SAFE, won't block
- return (handle_{ haType__ = ClosedHandle }, "")
- _ -> do
- more <- unsafeInterleaveIO (lazyReadChar handle fo)
- return (chr char : more)
-
-\end{code}
-
-
-%*********************************************************
-%* *
-\subsection{Simple output functions}
-%* *
-%*********************************************************
-
-@hPutChar hdl ch@ writes the character @ch@ to the file
-or channel managed by @hdl@. Characters may be buffered if
-buffering is enabled for @hdl@
-
-\begin{code}
-hPutChar :: Handle -> Char -> IO ()
-hPutChar handle c =
- c `seq` do -- must evaluate c before grabbing the handle lock
- wantWriteableHandle "hPutChar" handle $ \ handle_ -> do
- let fo = haFO__ handle_
- flushConnectedBuf fo
- rc <- mayBlock fo (filePutc fo c) -- ConcHask: UNSAFE, may block.
- if rc == 0
- then return ()
- else constructErrorAndFail "hPutChar"
-
-hPutChars :: Handle -> [Char] -> IO ()
-hPutChars handle [] = return ()
-hPutChars handle (c:cs) = hPutChar handle c >> hPutChars handle cs
-\end{code}
-
-@hPutStr hdl s@ writes the string @s@ to the file or
-channel managed by @hdl@, buffering the output if needs be.
-
-
-\begin{code}
-hPutStr :: Handle -> String -> IO ()
-hPutStr handle str = do
- buffer_mode <- wantWriteableHandle_ "hPutStr" handle
- (\ handle_ -> do getBuffer handle_)
- case buffer_mode of
- (NoBuffering, _, _) -> do
- hPutChars handle str -- v. slow, but we don't care
- (LineBuffering, buf, bsz) -> do
- writeLines handle buf bsz str
- (BlockBuffering _, buf, bsz) -> do
- writeBlocks handle buf bsz str
- -- ToDo: async exceptions during writeLines & writeBlocks will cause
- -- the buffer to get lost in the void. Using ByteArrays instead of
- -- malloced buffers is one way around this, but we really ought to
- -- be able to handle it with exception handlers/block/unblock etc.
-
-getBuffer :: Handle__ -> IO (Handle__, (BufferMode, Ptr (), Int))
-getBuffer handle_ = do
- let bufs = haBuffers__ handle_
- fo = haFO__ handle_
- mode = haBufferMode__ handle_
- sz <- getBufSize fo
- case mode of
- NoBuffering -> return (handle_, (mode, nullPtr, 0))
- _ -> case bufs of
- [] -> do buf <- malloc sz
- return (handle_, (mode, buf, sz))
- (b:bs) -> return (handle_{ haBuffers__ = bs }, (mode, b, sz))
-
-freeBuffer :: Handle__ -> Ptr () -> Int -> IO Handle__
-freeBuffer handle_ buf sz = do
- fo_sz <- getBufSize (haFO__ handle_)
- if (sz /= fo_sz)
- then do { free buf; return handle_ }
- else do { return handle_{ haBuffers__ = buf : haBuffers__ handle_ } }
-
-swapBuffers :: Handle__ -> Ptr () -> Int -> IO Handle__
-swapBuffers handle_ buf sz = do
- let fo = haFO__ handle_
- fo_buf <- getBuf fo
- setBuf fo buf sz
- return (handle_{ haBuffers__ = fo_buf : haBuffers__ handle_ })
-
--------------------------------------------------------------------------------
--- commitAndReleaseBuffer handle buf sz count flush
---
--- Write the contents of the buffer 'buf' ('sz' bytes long, containing
--- 'count' bytes of data) to handle (handle must be block or line buffered).
---
--- Implementation:
---
--- for block/line buffering,
--- 1. If there isn't room in the handle buffer, flush the handle
--- buffer.
---
--- 2. If the handle buffer is empty,
--- if flush,
--- then write buf directly to the device.
--- else swap the handle buffer with buf.
---
--- 3. If the handle buffer is non-empty, copy buf into the
--- handle buffer. Then, if flush != 0, flush
--- the buffer.
-
-commitAndReleaseBuffer
- :: Handle -- handle to commit to
- -> Ptr () -> Int -- address and size (in bytes) of buffer
- -> Int -- number of bytes of data in buffer
- -> Bool -- flush the handle afterward?
- -> IO ()
-
-commitAndReleaseBuffer hdl@(Handle h) buf sz count flush = do
- h_ <- takeMVar h
-
- -- First deal with any possible exceptions, by freeing the buffer.
- -- Async exceptions are blocked, but there are still some interruptible
- -- ops below.
-
- -- note that commit doesn't *always* free the buffer, it might
- -- swap it for the current handle buffer instead. This makes things
- -- a whole lot more complicated, because we can't just do
- -- "finally (... free buffer ...)" here.
- catchException (commit hdl h_)
- (\e -> do { h_ <- freeBuffer h_ buf sz; putMVar h h_ })
-
- where
- commit hdl@(Handle h) handle_ =
- checkWriteableHandle "commitAndReleaseBuffer" hdl handle_ $ do
- let fo = haFO__ handle_
- flushConnectedBuf fo -- ???? -SDM
- getWriteableBuf fo -- flush read buf if necessary
- fo_buf <- getBuf fo
- fo_wptr <- getBufWPtr fo
- fo_bufSize <- getBufSize fo
-
- let ok h_ = putMVar h h_ >> return ()
-
- -- enough room in handle buffer for the new data?
- if (flush || fo_bufSize - fo_wptr <= count)
-
- -- The <= is to be sure that we never exactly fill up the
- -- buffer, which would require a flush. So if copying the
- -- new data into the buffer would make the buffer full, we
- -- just flush the existing buffer and the new data immediately,
- -- rather than copying before flushing.
-
- then do rc <- mayBlock fo (flushFile fo)
- if (rc < 0)
- then constructErrorAndFail "commitAndReleaseBuffer"
- else
- if (flush || sz /= fo_bufSize || count == sz)
- then do rc <- write_buf fo buf count
- if (rc < 0)
- then constructErrorAndFail "commitAndReleaseBuffer"
- else do handle_ <- freeBuffer handle_ buf sz
- ok handle_
-
- -- if: (a) we don't have to flush, and
- -- (b) size(new buffer) == size(old buffer), and
- -- (c) new buffer is not full,
- -- we can just just swap them over...
- else do handle_ <- swapBuffers handle_ buf sz
- setBufWPtr fo count
- ok handle_
-
- -- not flushing, and there's enough room in the buffer:
- -- just copy the data in and update bufWPtr.
- else do memcpy (plusPtr fo_buf fo_wptr) buf count
- setBufWPtr fo (fo_wptr + count)
- handle_ <- freeBuffer handle_ buf sz
- ok handle_
-
---------------------------------------------------------------------------------
--- commitBuffer handle buf sz count flush
---
--- Flushes 'count' bytes from the buffer 'buf' (size 'sz') to 'handle'.
--- There are several cases to consider altogether:
---
--- If flush,
--- - flush handle buffer,
--- - write out new buffer directly
---
--- else
--- - if there's enough room in the handle buffer,
--- then copy new buf into it
--- else flush handle buffer, then copy new buffer into it
---
--- Make sure that we maintain the invariant that the handle buffer is never
--- left in a full state. Several functions rely on this (eg. filePutc), so
--- if we're about to exactly fill the buffer then we make sure we do a flush
--- here (also see above in commitAndReleaseBuffer).
-
-commitBuffer
- :: Handle -- handle to commit to
- -> Ptr () -> Int -- address and size (in bytes) of buffer
- -> Int -- number of bytes of data in buffer
- -> Bool -- flush the handle afterward?
- -> IO ()
-
-commitBuffer handle buf sz count flush = do
- wantWriteableHandle "commitBuffer" handle $ \handle_ -> do
- let fo = haFO__ handle_
- flushConnectedBuf fo -- ???? -SDM
- getWriteableBuf fo -- flush read buf if necessary
- fo_buf <- getBuf fo
- fo_wptr <- getBufWPtr fo
- fo_bufSize <- getBufSize fo
-
- new_wptr <- -- not enough room in handle buffer?
- (if flush || (fo_bufSize - fo_wptr <= count)
- then do rc <- mayBlock fo (flushFile fo)
- if (rc < 0) then constructErrorAndFail "commitBuffer"
- else return 0
- else return fo_wptr )
-
- if (flush || fo_bufSize <= count) -- committed buffer too large?
-
- then do rc <- write_buf fo buf count
- if (rc < 0) then constructErrorAndFail "commitBuffer"
- else return ()
-
- else do memcpy (plusPtr fo_buf new_wptr) buf count
- setBufWPtr fo (new_wptr + count)
- return ()
-
-write_buf fo buf 0 = return 0
-write_buf fo buf count = do
- rc <- mayBlock fo (write_ fo buf count)
- if (rc > 0)
- then write_buf fo buf (count - rc) -- partial write
- else return rc
-
--- a version of commitBuffer that will free the buffer if an exception is
--- received. DON'T use this if you intend to use the buffer again!
-checkedCommitBuffer handle buf sz count flush
- = catchException (commitBuffer handle buf sz count flush)
- (\e -> do withHandle__ handle (\h_ -> freeBuffer h_ buf sz)
- throw e)
-
-foreign import "memcpy" unsafe memcpy :: Ptr () -> Ptr () -> Int -> IO ()
-\end{code}
-
-Going across the border between Haskell and C is relatively costly,
-so for block writes we pack the character strings on the Haskell-side
-before passing the external write routine a pointer to the buffer.
-
-\begin{code}
-#ifdef __HUGS__
-
-#ifdef __CONCURRENT_HASKELL__
-/* See comment in shoveString below for explanation */
-#warning delayed update of buffer disnae work with killThread
-#endif
-
-writeLines :: Handle -> Ptr () -> Int -> String -> IO ()
-writeLines handle buf bufLen s =
- let
- shoveString :: Int -> [Char] -> IO ()
- shoveString n ls =
- case ls of
- [] -> commitAndReleaseBuffer handle buf buflen n False{-no need to flush-}
-
- (x:xs) -> do
- primWriteCharOffAddr buf n x
- {- Flushing on buffer exhaustion or newlines (even if it isn't the last one) -}
- let next_n = n + 1
- if next_n == bufLen || x == '\n'
- then do
- checkedCommitBuffer hdl buf len next_n True{-needs flush-}
- shoveString 0 xs
- else
- shoveString next_n xs
- in
- shoveString 0 s
-
-#else /* ndef __HUGS__ */
-
-writeLines :: Handle -> Ptr () -> Int -> String -> IO ()
-writeLines hdl buf len@(I# bufLen) s =
- let
- shoveString :: Int# -> [Char] -> IO ()
- shoveString n ls =
- case ls of
- [] -> commitAndReleaseBuffer hdl buf len (I# n) False{-no need to flush-}
-
- ((C# x):xs) -> do
- write_char buf n x
- -- Flushing on buffer exhaustion or newlines
- -- (even if it isn't the last one)
- let next_n = n +# 1#
- if next_n ==# bufLen || x `eqChar#` '\n'#
- then do
- checkedCommitBuffer hdl buf len (I# next_n) True{-needs flush-}
- shoveString 0# xs
- else
- shoveString next_n xs
- in
- shoveString 0# s
-#endif /* ndef __HUGS__ */
-
-#ifdef __HUGS__
-writeBlocks :: Handle -> Ptr () -> Int -> String -> IO ()
-writeBlocks hdl buf bufLen s =
- let
- shoveString :: Int -> [Char] -> IO ()
- shoveString n ls =
- case ls of
- [] -> commitAndReleaseBuffer hdl buf len n False{-no need to flush-}
-
- (x:xs) -> do
- primWriteCharOffAddr buf n x
- let next_n = n + 1
- if next_n == bufLen
- then do
- checkedCommitBuffer hdl buf len next_n True{-needs flush-}
- shoveString 0 xs
- else
- shoveString next_n xs
- in
- shoveString 0 s
-
-#else /* ndef __HUGS__ */
-
-writeBlocks :: Handle -> Ptr () -> Int -> String -> IO ()
-writeBlocks hdl buf len@(I# bufLen) s =
- let
- shoveString :: Int# -> [Char] -> IO ()
- shoveString n ls =
- case ls of
- [] -> commitAndReleaseBuffer hdl buf len (I# n) False{-no need to flush-}
-
- ((C# x):xs) -> do
- write_char buf n x
- let next_n = n +# 1#
- if next_n ==# bufLen
- then do
- checkedCommitBuffer hdl buf len (I# next_n) True{-needs flush-}
- shoveString 0# xs
- else
- shoveString next_n xs
- in
- shoveString 0# s
-
-write_char :: Ptr () -> Int# -> Char# -> IO ()
-write_char (Ptr buf#) n# c# =
- IO $ \ s# ->
- case (writeCharOffAddr# buf# n# c# s#) of s2# -> (# s2#, () #)
-#endif /* ndef __HUGS__ */
-\end{code}
-
-Computation @hPrint hdl t@ writes the string representation of {\em t}
-given by the @shows@ function to the file or channel managed by {\em
-hdl}.
-
-[ Seem to have disappeared from the 1.4 interface - SOF 2/97 ]
-
-\begin{code}
-hPrint :: Show a => Handle -> a -> IO ()
-hPrint hdl = hPutStrLn hdl . show
-\end{code}
-
-Derived action @hPutStrLn hdl str@ writes the string \tr{str} to
-the handle \tr{hdl}, adding a newline at the end.
-
-\begin{code}
-hPutStrLn :: Handle -> String -> IO ()
-hPutStrLn hndl str = do
- hPutStr hndl str
- hPutChar hndl '\n'
-\end{code}
% ------------------------------------------------------------------------------
-% $Id: PrelIOBase.lhs,v 1.37 2001/02/27 13:38:58 simonmar Exp $
+% $Id: PrelIOBase.lhs,v 1.38 2001/05/18 16:54:05 simonmar Exp $
%
-% (c) The University of Glasgow, 1994-2000
+% (c) The University of Glasgow, 1994-2001
%
-\section[PrelIOBase]{Module @PrelIOBase@}
-
-Definitions for the @IO@ monad and its friends. Everything is exported
-concretely; the @IO@ module itself exports abstractly.
+% Definitions for the @IO@ monad and its friends. Everything is exported
+% concretely; the @IO@ module itself exports abstractly.
\begin{code}
-{-# OPTIONS -fno-implicit-prelude -#include "cbits/stgio.h" #-}
+{-# OPTIONS -fno-implicit-prelude #-}
#include "config.h"
-#include "cbits/stgerror.h"
-#ifndef __HUGS__ /* Hugs just includes this in PreludeBuiltin so no header needed */
module PrelIOBase where
-import {-# SOURCE #-} PrelErr ( error )
-
import PrelST
+import PrelArr
import PrelBase
import PrelNum -- To get fromInteger etc, needed because of -fno-implicit-prelude
import PrelMaybe ( Maybe(..) )
import PrelShow
import PrelList
import PrelDynamic
-import PrelPtr
-import PrelPack ( unpackCString )
-
-#if !defined(__CONCURRENT_HASKELL__)
-import PrelArr ( MutableVar, readVar )
-#endif
-#endif
-
-#ifdef __HUGS__
-#define __CONCURRENT_HASKELL__
-#define stToIO id
-#define unpackCString primUnpackString
-#endif
-#ifndef __PARALLEL_HASKELL__
-#define FILE_OBJECT (ForeignPtr ())
-#else
-#define FILE_OBJECT (Ptr ())
-
-#endif
-\end{code}
-
-%*********************************************************
-%* *
-\subsection{The @IO@ monad}
-%* *
-%*********************************************************
+-- ---------------------------------------------------------------------------
+-- The IO Monad
+{-
The IO Monad is just an instance of the ST monad, where the state is
the real world. We use the exception mechanism (in PrelException) to
implement IO exceptions.
Libraries - parts of hslibs/lang.
--SDM
+-}
-\begin{code}
-#ifndef __HUGS__
newtype IO a = IO (State# RealWorld -> (# State# RealWorld, a #))
unIO :: IO a -> (State# RealWorld -> (# State# RealWorld, a #))
returnIO :: a -> IO a
returnIO x = IO (\ s -> (# s, x #))
-#endif
-\end{code}
-%*********************************************************
-%* *
-\subsection{Coercions to @ST@}
-%* *
-%*********************************************************
+-- ---------------------------------------------------------------------------
+-- Coercions between IO and ST
-\begin{code}
-#ifdef __HUGS__
-/* Hugs doesn't distinguish these types so no coercion required) */
-#else
--- stToIO :: (forall s. ST s a) -> IO a
+--stToIO :: (forall s. ST s a) -> IO a
stToIO :: ST RealWorld a -> IO a
stToIO (ST m) = IO m
ioToST :: IO a -> ST RealWorld a
ioToST (IO m) = (ST m)
-#endif
-\end{code}
-%*********************************************************
-%* *
-\subsection{Unsafe @IO@ operations}
-%* *
-%*********************************************************
+-- ---------------------------------------------------------------------------
+-- Unsafe IO operations
-\begin{code}
-#ifndef __HUGS__
{-# NOINLINE unsafePerformIO #-}
unsafePerformIO :: IO a -> a
unsafePerformIO (IO m) = case m realWorld# of (# _, r #) -> r
r = case m s of (# _, res #) -> res
in
(# s, r #))
-#endif
-\end{code}
-%*********************************************************
-%* *
-\subsection{Types @Handle@, @Handle__@}
-%* *
-%*********************************************************
-
-The type for @Handle@ is defined rather than in @IOHandle@
-module, as the @IOError@ type uses it..all operations over
-a handles reside in @IOHandle@.
-
-\begin{code}
+-- ---------------------------------------------------------------------------
+-- Handle type
-#ifndef __HUGS__
-{-
- Sigh, the MVar ops in ConcBase depend on IO, the IO
- representation here depend on MVars for handles (when
- compiling in a concurrent way). Break the cycle by having
- the definition of MVars go here:
-
--}
data MVar a = MVar (MVar# RealWorld a)
-- pull in Eq (Mvar a) too, to avoid PrelConc being an orphan-instance module
instance Eq (MVar a) where
(MVar mvar1#) == (MVar mvar2#) = sameMVar# mvar1# mvar2#
-{-
- Double sigh - ForeignPtr is needed here too to break a cycle.
--}
-data ForeignPtr a = ForeignPtr ForeignObj#
-instance CCallable (ForeignPtr a)
+-- A Handle is represented by (a reference to) a record
+-- containing the state of the I/O port/device. We record
+-- the following pieces of info:
-eqForeignPtr :: ForeignPtr a -> ForeignPtr a -> Bool
-eqForeignPtr mp1 mp2
- = unsafePerformIO (primEqForeignPtr mp1 mp2) /= (0::Int)
+-- * type (read,write,closed etc.)
+-- * the underlying file descriptor
+-- * buffering mode
+-- * buffer, and spare buffers
+-- * user-friendly name (usually the
+-- FilePath used when IO.openFile was called)
-foreign import "eqForeignObj" unsafe
- primEqForeignPtr :: ForeignPtr a -> ForeignPtr a -> IO Int
+-- Note: when a Handle is garbage collected, we want to flush its buffer
+-- and close the OS file handle, so as to free up a (precious) resource.
-instance Eq (ForeignPtr a) where
- p == q = eqForeignPtr p q
- p /= q = not (eqForeignPtr p q)
-#endif /* ndef __HUGS__ */
+data Handle
+ = FileHandle -- A normal handle to a file
+ !(MVar Handle__)
-#if defined(__CONCURRENT_HASKELL__)
-newtype Handle = Handle (MVar Handle__)
-#else
-newtype Handle = Handle (MutableVar RealWorld Handle__)
-#endif
+ | DuplexHandle -- A handle to a read/write stream
+ !(MVar Handle__) -- The read side
+ !(MVar Handle__) -- The write side
+
+-- NOTES:
+-- * A 'FileHandle' is seekable. A 'DuplexHandle' may or may not be
+-- seekable.
instance Eq Handle where
- (Handle h1) == (Handle h2) = h1 == h2
+ (FileHandle h1) == (FileHandle h2) = h1 == h2
+ (DuplexHandle h1 _) == (DuplexHandle h2 _) = h1 == h2
+ _ == _ = False
+
+type FD = Int -- XXX ToDo: should be CInt
-{-
- A Handle is represented by (a reference to) a record
- containing the state of the I/O port/device. We record
- the following pieces of info:
-
- * type (read,write,closed etc.)
- * pointer to the external file object.
- * buffering mode
- * user-friendly name (usually the
- FilePath used when IO.openFile was called)
-
-Note: when a Handle is garbage collected, we want to flush its buffer
-and close the OS file handle, so as to free up a (precious) resource.
--}
data Handle__
= Handle__ {
- haFO__ :: FILE_OBJECT,
- haType__ :: Handle__Type,
- haBufferMode__ :: BufferMode,
- haFilePath__ :: FilePath,
- haBuffers__ :: [Ptr ()]
+ haFD :: !FD,
+ haType :: HandleType,
+ haBufferMode :: BufferMode,
+ haFilePath :: FilePath,
+ haBuffer :: !(IORef Buffer),
+ haBuffers :: !(IORef BufferList)
}
-{-
- Internally, we classify handles as being one
- of the following:
--}
-data Handle__Type
+-- ---------------------------------------------------------------------------
+-- Buffers
+
+-- The buffer is represented by a mutable variable containing a
+-- record, where the record contains the raw buffer and the start/end
+-- points of the filled portion. We use a mutable variable so that
+-- the common operation of writing (or reading) some data from (to)
+-- the buffer doesn't need to modify, and hence copy, the handle
+-- itself, it just updates the buffer.
+
+-- There will be some allocation involved in a simple hPutChar in
+-- order to create the new Buffer structure (below), but this is
+-- relatively small, and this only has to be done once per write
+-- operation.
+
+-- The buffer contains its size - we could also get the size by
+-- calling sizeOfMutableByteArray# on the raw buffer, but that tends
+-- to be rounded up to the nearest Word.
+
+type RawBuffer = MutableByteArray# RealWorld
+
+-- INVARIANTS on a Buffer:
+--
+-- * A handle *always* has a buffer, even if it is only 1 character long
+-- (an unbuffered handle needs a 1 character buffer in order to support
+-- hLookAhead and hIsEOF).
+-- * r <= w
+-- * if r == w, then r == 0 && w == 0
+-- * if state == WriteBuffer, then r == 0
+-- * a write buffer is never full. If an operation
+-- fills up the buffer, it will always flush it before
+-- returning.
+-- * a read buffer may be full as a result of hLookAhead. In normal
+-- operation, a read buffer always has at least one character of space.
+
+data Buffer
+ = Buffer {
+ bufBuf :: RawBuffer,
+ bufRPtr :: !Int,
+ bufWPtr :: !Int,
+ bufSize :: !Int,
+ bufState :: BufferState
+ }
+
+data BufferState = ReadBuffer | WriteBuffer deriving (Eq)
+
+-- we keep a few spare buffers around in a handle to avoid allocating
+-- a new one for each hPutStr. These buffers are *guaranteed* to be the
+-- same size as the main buffer.
+data BufferList
+ = BufferListNil
+ | BufferListCons RawBuffer BufferList
+
+
+bufferIsWritable :: Buffer -> Bool
+bufferIsWritable Buffer{ bufState=WriteBuffer } = True
+bufferIsWritable _other = False
+
+bufferEmpty :: Buffer -> Bool
+bufferEmpty Buffer{ bufRPtr=r, bufWPtr=w } | r == w = True
+bufferEmpty _other = False
+
+-- only makes sense for a write buffer
+bufferFull :: Buffer -> Bool
+bufferFull b@Buffer{ bufWPtr=w } = w >= bufSize b
+
+-- Internally, we classify handles as being one
+-- of the following:
+
+data HandleType
= ClosedHandle
| SemiClosedHandle
| ReadHandle
| WriteHandle
| AppendHandle
| ReadWriteHandle
-
+ | ReadSideHandle !(MVar Handle__) -- read side of a duplex handle
-- File names are specified using @FilePath@, a OS-dependent
-- string that (hopefully, I guess) maps to an accessible file/object.
type FilePath = String
-\end{code}
-%*********************************************************
-%* *
-\subsection[Show-Handle]{Show instance for Handles}
-%* *
-%*********************************************************
+-- ---------------------------------------------------------------------------
+-- Buffering modes
+
+-- Three kinds of buffering are supported: line-buffering,
+-- block-buffering or no-buffering. These modes have the following
+-- effects. For output, items are written out from the internal
+-- buffer according to the buffer mode:
+--
+-- * line-buffering the entire output buffer is written
+-- out whenever a newline is output, the output buffer overflows,
+-- a flush is issued, or the handle is closed.
+--
+-- * block-buffering the entire output buffer is written out whenever
+-- it overflows, a flush is issued, or the handle
+-- is closed.
+--
+-- * no-buffering output is written immediately, and never stored
+-- in the output buffer.
+--
+-- The output buffer is emptied as soon as it has been written out.
+
+-- Similarly, input occurs according to the buffer mode for handle {\em hdl}.
+
+-- * line-buffering when the input buffer for the handle is not empty,
+-- the next item is obtained from the buffer;
+-- otherwise, when the input buffer is empty,
+-- characters up to and including the next newline
+-- character are read into the buffer. No characters
+-- are available until the newline character is
+-- available.
+--
+-- * block-buffering when the input buffer for the handle becomes empty,
+-- the next block of data is read into this buffer.
+--
+-- * no-buffering the next input item is read and returned.
+
+-- For most implementations, physical files will normally be block-buffered
+-- and terminals will normally be line-buffered. (the IO interface provides
+-- operations for changing the default buffering of a handle tho.)
-\begin{code}
--- handle types are 'show'ed when printing error msgs, so
+data BufferMode
+ = NoBuffering | LineBuffering | BlockBuffering (Maybe Int)
+ deriving (Eq, Ord, Show)
+ {- Read instance defined in IO. -}
+
+-- ---------------------------------------------------------------------------
+-- IORefs
+
+newtype IORef a = IORef (STRef RealWorld a) deriving Eq
+
+newIORef :: a -> IO (IORef a)
+newIORef v = stToIO (newSTRef v) >>= \ var -> return (IORef var)
+
+readIORef :: IORef a -> IO a
+readIORef (IORef var) = stToIO (readSTRef var)
+
+writeIORef :: IORef a -> a -> IO ()
+writeIORef (IORef var) v = stToIO (writeSTRef var v)
+
+modifyIORef :: IORef a -> (a -> a) -> IO ()
+modifyIORef ref f = readIORef ref >>= \x -> writeIORef ref (f x)
+
+-- deprecated, use modifyIORef
+updateIORef :: IORef a -> (a -> a) -> IO ()
+updateIORef = modifyIORef
+
+-- ---------------------------------------------------------------------------
+-- Show instance for Handles
+
+-- handle types are 'show'n when printing error msgs, so
-- we provide a more user-friendly Show instance for it
-- than the derived one.
-instance Show Handle__Type where
+
+instance Show HandleType where
showsPrec p t =
case t of
ClosedHandle -> showString "closed"
SemiClosedHandle -> showString "semi-closed"
ReadHandle -> showString "readable"
- WriteHandle -> showString "writeable"
- AppendHandle -> showString "writeable (append)"
- ReadWriteHandle -> showString "read-writeable"
+ WriteHandle -> showString "writable"
+ AppendHandle -> showString "writable (append)"
+ ReadWriteHandle -> showString "read-writable"
+ ReadSideHandle _ -> showString "read-writable (duplex)"
instance Show Handle where
- showsPrec p (Handle h) =
+ showsPrec p (FileHandle h) = showHandle p h
+ showsPrec p (DuplexHandle h _) = showHandle p h
+
+showHandle p h =
let
-#if defined(__CONCURRENT_HASKELL__)
-#ifdef __HUGS__
- hdl_ = unsafePerformIO (primTakeMVar h)
-#else
-- (Big) SIGH: unfolded defn of takeMVar to avoid
-- an (oh-so) unfortunate module loop with PrelConc.
hdl_ = unsafePerformIO (IO $ \ s# ->
case takeMVar# h# s# of { (# s2# , r #) ->
case putMVar# h# r s2# of { s3# ->
(# s3#, r #) }}})
-#endif
-#else
- hdl_ = unsafePerformIO (stToIO (readVar h))
-#endif
in
showChar '{' .
- showHdl (haType__ hdl_)
- (showString "loc=" . showString (haFilePath__ hdl_) . showChar ',' .
- showString "type=" . showsPrec p (haType__ hdl_) . showChar ',' .
- showString "buffering=" . showBufMode (haFO__ hdl_) (haBufferMode__ hdl_) . showString "}\n" )
+ showHdl (haType hdl_)
+ (showString "loc=" . showString (haFilePath hdl_) . showChar ',' .
+ showString "type=" . showsPrec p (haType hdl_) . showChar ',' .
+ showString "buffering=" . showBufMode (unsafePerformIO (readIORef (haBuffer hdl_))) (haBufferMode hdl_) . showString "}" )
where
- showHdl :: Handle__Type -> ShowS -> ShowS
+ showHdl :: HandleType -> ShowS -> ShowS
showHdl ht cont =
case ht of
- ClosedHandle -> showsPrec p ht . showString "}\n"
+ ClosedHandle -> showsPrec p ht . showString "}"
_ -> cont
- showBufMode :: FILE_OBJECT -> BufferMode -> ShowS
- showBufMode fo bmo =
+ showBufMode :: Buffer -> BufferMode -> ShowS
+ showBufMode buf bmo =
case bmo of
NoBuffering -> showString "none"
LineBuffering -> showString "line"
BlockBuffering Nothing -> showString "block " . showParen True (showsPrec p def)
where
def :: Int
- def = unsafePerformIO (getBufSize fo)
-\end{code}
-
-%*********************************************************
-%* *
-\subsection[BufferMode]{Buffering modes}
-%* *
-%*********************************************************
-
-Three kinds of buffering are supported: line-buffering,
-block-buffering or no-buffering. These modes have the following
-effects. For output, items are written out from the internal
-buffer according to the buffer mode:
-
-\begin{itemize}
-\item[line-buffering] the entire output buffer is written
-out whenever a newline is output, the output buffer overflows,
-a flush is issued, or the handle is closed.
-
-\item[block-buffering] the entire output buffer is written out whenever
-it overflows, a flush is issued, or the handle
-is closed.
-
-\item[no-buffering] output is written immediately, and never stored
-in the output buffer.
-\end{itemize}
-
-The output buffer is emptied as soon as it has been written out.
-
-Similarly, input occurs according to the buffer mode for handle {\em hdl}.
-\begin{itemize}
-\item[line-buffering] when the input buffer for {\em hdl} is not empty,
-the next item is obtained from the buffer;
-otherwise, when the input buffer is empty,
-characters up to and including the next newline
-character are read into the buffer. No characters
-are available until the newline character is
-available.
-\item[block-buffering] when the input buffer for {\em hdl} becomes empty,
-the next block of data is read into this buffer.
-\item[no-buffering] the next input item is read and returned.
-\end{itemize}
-
-For most implementations, physical files will normally be block-buffered
-and terminals will normally be line-buffered. (the IO interface provides
-operations for changing the default buffering of a handle tho.)
-
-\begin{code}
-data BufferMode
- = NoBuffering | LineBuffering | BlockBuffering (Maybe Int)
- deriving (Eq, Ord, Show)
- {- Read instance defined in IO. -}
-
-\end{code}
-
-Foreign import declarations to helper routines:
+ def = bufSize buf
-\begin{code}
-foreign import "libHS_cbits" "getErrStr__" unsafe getErrStr__ :: IO (Ptr ())
-foreign import "libHS_cbits" "getErrNo__" unsafe getErrNo__ :: IO Int
-foreign import "libHS_cbits" "getErrType__" unsafe getErrType__ :: IO Int
-
--- ToDo: use mallocBytes from PrelMarshal?
-malloc :: Int -> IO (Ptr ())
-malloc sz = do
- a <- _malloc sz
- if (a == nullPtr)
- then ioException (IOError Nothing ResourceExhausted
- "malloc" "out of memory" Nothing)
- else return a
-
-foreign import "malloc" unsafe _malloc :: Int -> IO (Ptr ())
-
-foreign import "libHS_cbits" "getBufSize" unsafe
- getBufSize :: FILE_OBJECT -> IO Int
-foreign import "libHS_cbits" "setBuf" unsafe
- setBuf :: FILE_OBJECT -> Ptr () -> Int -> IO ()
-
-\end{code}
+-- ------------------------------------------------------------------------
+-- Exception datatype and operations
-%*********************************************************
-%* *
-\subsection{Exception datatype and operations}
-%* *
-%*********************************************************
-
-\begin{code}
data Exception
= IOException IOException -- IO exceptions
| ArithException ArithException -- Arithmetic exceptions
showsPrec _ (BlockedOnDeadMVar) = showString "thread blocked indefinitely"
showsPrec _ (NonTermination) = showString "<<loop>>"
showsPrec _ (UserError err) = showString err
-\end{code}
-%*********************************************************
-%* *
-\subsection{Primitive throw}
-%* *
-%*********************************************************
+-- --------------------------------------------------------------------------
+-- Primitive throw
-\begin{code}
throw :: Exception -> a
throw exception = raise# exception
ioException :: IOException -> IO a
ioException err = IO $ \s -> throw (IOException err) s
-\end{code}
-%*********************************************************
-%* *
-\subsection{Type @IOError@}
-%* *
-%*********************************************************
+-- ---------------------------------------------------------------------------
+-- IOError type
-A value @IOError@ encode errors occurred in the @IO@ monad.
-An @IOError@ records a more specific error type, a descriptive
-string and maybe the handle that was used when the error was
-flagged.
+-- A value @IOError@ encode errors occurred in the @IO@ monad.
+-- An @IOError@ records a more specific error type, a descriptive
+-- string and maybe the handle that was used when the error was
+-- flagged.
-\begin{code}
type IOError = Exception
data IOException
userError :: String -> IOError
userError str = UserError str
-\end{code}
-
-Predicates on IOError; little effort made on these so far...
-\begin{code}
+-- ---------------------------------------------------------------------------
+-- Predicates on IOError
isAlreadyExistsError :: IOError -> Bool
isAlreadyExistsError (IOException (IOError _ AlreadyExists _ _ _)) = True
isUserError :: IOError -> Bool
isUserError (UserError _) = True
isUserError _ = False
-\end{code}
-Showing @IOError@s
+-- ---------------------------------------------------------------------------
+-- Showing IOErrors
-\begin{code}
-#ifdef __HUGS__
--- For now we give a fairly uninformative error message which just happens to
--- be like the ones that Hugs used to give.
-instance Show IOException where
- showsPrec p (IOError _ _ _ s _) = showString s . showChar '\n'
-#else
instance Show IOException where
showsPrec p (IOError hdl iot loc s fn) =
showsPrec p iot .
(case loc of
"" -> id
_ -> showString "\nAction: " . showString loc) .
- showHdl .
+ (case hdl of
+ Nothing -> id
+ Just h -> showString "\nHandle: " . showsPrec p h) .
(case s of
"" -> id
_ -> showString "\nReason: " . showString s) .
(case fn of
Nothing -> id
Just name -> showString "\nFile: " . showString name)
- where
- showHdl =
- case hdl of
- Nothing -> id
- Just h -> showString "\nHandle: " . showsPrec p h
-
-#endif
-\end{code}
-
-The @String@ part of an @IOError@ is platform-dependent. However, to
-provide a uniform mechanism for distinguishing among errors within
-these broad categories, each platform-specific standard shall specify
-the exact strings to be used for particular errors. For errors not
-explicitly mentioned in the standard, any descriptive string may be
-used.
-
-\begin{code}
-constructErrorAndFail :: String -> IO a
-constructErrorAndFail call_site
- = constructError call_site >>= \ io_error ->
- ioError (IOException io_error)
-
-constructErrorAndFailWithInfo :: String -> String -> IO a
-constructErrorAndFailWithInfo call_site fn
- = constructErrorMsg call_site (Just fn) >>= \ io_error ->
- ioError (IOException io_error)
-
-\end{code}
-
-This doesn't seem to be documented/spelled out anywhere,
-so here goes: (SOF)
-
-The implementation of the IO prelude uses various C stubs
-to do the actual interaction with the OS. The bandwidth
-\tr{C<->Haskell} is somewhat limited, so the general strategy
-for flaggging any errors (apart from possibly using the
-return code of the external call), is to set the @ghc_errtype@
-to a value that is one of the \tr{#define}s in @includes/error.h@.
-@ghc_errstr@ holds a character string providing error-specific
-information. Error constructing functions will then reach out
-and grab these values when generating
-
-\begin{code}
-constructError :: String -> IO IOException
-constructError call_site = constructErrorMsg call_site Nothing
-
-constructErrorMsg :: String -> Maybe String -> IO IOException
-constructErrorMsg call_site fn =
- getErrType__ >>= \ errtype ->
- getErrStr__ >>= \ str ->
- let
- iot =
- case (errtype::Int) of
- ERR_ALREADYEXISTS -> AlreadyExists
- ERR_HARDWAREFAULT -> HardwareFault
- ERR_ILLEGALOPERATION -> IllegalOperation
- ERR_INAPPROPRIATETYPE -> InappropriateType
- ERR_INTERRUPTED -> Interrupted
- ERR_INVALIDARGUMENT -> InvalidArgument
- ERR_NOSUCHTHING -> NoSuchThing
- ERR_OTHERERROR -> OtherError
- ERR_PERMISSIONDENIED -> PermissionDenied
- ERR_PROTOCOLERROR -> ProtocolError
- ERR_RESOURCEBUSY -> ResourceBusy
- ERR_RESOURCEEXHAUSTED -> ResourceExhausted
- ERR_RESOURCEVANISHED -> ResourceVanished
- ERR_SYSTEMERROR -> SystemError
- ERR_TIMEEXPIRED -> TimeExpired
- ERR_UNSATISFIEDCONSTRAINTS -> UnsatisfiedConstraints
- ERR_UNSUPPORTEDOPERATION -> UnsupportedOperation
- ERR_EOF -> EOF
- _ -> OtherError
-
- msg =
- unpackCString str ++
- (case iot of
- OtherError -> "(error code: " ++ show errtype ++ ")"
- _ -> "")
- in
- return (IOError Nothing iot call_site msg fn)
\end{code}
\section[PrelInt]{Module @PrelInt@}
\begin{code}
+{-# OPTIONS -fno-implicit-prelude #-}
+
#include "MachDeps.h"
module PrelInt (
import PrelArr
import PrelBits
import PrelWord
+import PrelShow
------------------------------------------------------------------------
-- type Int8
% ------------------------------------------------------------------------------
-% $Id: PrelMain.lhs,v 1.7 2000/06/30 13:39:36 simonmar Exp $
+% $Id: PrelMain.lhs,v 1.8 2001/05/18 16:54:05 simonmar Exp $
%
% (c) The University of Glasgow, 1994-2000
%
\section[PrelMain]{Module @PrelMain@}
\begin{code}
-module PrelMain( mainIO ) where
+module PrelMain( mainIO, reportStackOverflow, reportError ) where
import Prelude
import {-# SOURCE #-} qualified Main -- for type of "Main.main"
+import IO
+import PrelCString
+import PrelPtr
import PrelException
-import PrelHandle ( topHandler )
-
\end{code}
\begin{code}
mainIO :: IO () -- It must be of type (IO t) because that's what
-- the RTS expects. GHC doesn't check this, so
-- make sure this type signature stays!
-mainIO = catchException Main.main (topHandler True)
+mainIO = catchException Main.main topHandler
+
+-- 'Top-level' IO actions want to catch exceptions (e.g., forkIO and
+-- PrelMain.mainIO) and report them - topHandler is the exception
+-- handler they should use for this:
+
+-- make sure we handle errors while reporting the error!
+-- (e.g. evaluating the string passed to 'error' might generate
+-- another error, etc.)
+topHandler :: Exception -> IO ()
+topHandler err = catchException (real_handler err) topHandler
+
+real_handler :: Exception -> IO ()
+real_handler ex =
+ case ex of
+ AsyncException StackOverflow -> reportStackOverflow True
+ ErrorCall s -> reportError True s
+ other -> reportError True (showsPrec 0 other "\n")
+
+reportStackOverflow :: Bool -> IO ()
+reportStackOverflow bombOut = do
+ (hFlush stdout) `catchException` (\ _ -> return ())
+ callStackOverflowHook
+ if bombOut then
+ stg_exit 2
+ else
+ return ()
+
+reportError :: Bool -> String -> IO ()
+reportError bombOut str = do
+ (hFlush stdout) `catchException` (\ _ -> return ())
+ withCStringLen str $ \(cstr,len) -> do
+ writeErrString addrOf_ErrorHdrHook cstr len
+ if bombOut
+ then stg_exit 1
+ else return ()
+
+foreign import ccall "addrOf_ErrorHdrHook" unsafe
+ addrOf_ErrorHdrHook :: Ptr ()
+
+foreign import ccall "writeErrString__" unsafe
+ writeErrString :: Ptr () -> CString -> Int -> IO ()
+
+-- SUP: Are the hooks allowed to re-enter Haskell land? If so, remove
+-- the unsafe below.
+foreign import ccall "stackOverflow" unsafe
+ callStackOverflowHook :: IO ()
+
+foreign import ccall "stg_exit" unsafe
+ stg_exit :: Int -> IO ()
\end{code}
% -----------------------------------------------------------------------------
-% $Id: PrelMarshalAlloc.lhs,v 1.1 2001/01/11 17:25:57 simonmar Exp $
+% $Id: PrelMarshalAlloc.lhs,v 1.2 2001/05/18 16:54:05 simonmar Exp $
%
% (c) The FFI task force, 2000
%
Marshalling support: basic routines for memory allocation
\begin{code}
+{-# OPTIONS -fno-implicit-prelude #-}
+
module PrelMarshalAlloc (
malloc, -- :: Storable a => IO (Ptr a)
mallocBytes, -- :: Int -> IO (Ptr a)
free -- :: Ptr a -> IO ()
) where
+#ifdef __GLASGOW_HASKELL__
import PrelException ( bracket )
import PrelPtr ( Ptr, nullPtr )
import PrelStorable ( Storable(sizeOf) )
import PrelCTypesISO ( CSize )
-
-#ifdef __GLASGOW_HASKELL__
-import PrelIOBase hiding (malloc, _malloc)
+import PrelIOBase
+import PrelMaybe
+import PrelReal
+import PrelNum
+import PrelErr
+import PrelBase
#endif
% -----------------------------------------------------------------------------
-% $Id: PrelMarshalArray.lhs,v 1.2 2001/03/15 20:35:49 qrczak Exp $
+% $Id: PrelMarshalArray.lhs,v 1.3 2001/05/18 16:54:05 simonmar Exp $
%
% (c) The FFI task force, 2000
%
lists that are represented as arrays in the foreign language
\begin{code}
+{-# OPTIONS -fno-implicit-prelude #-}
+
module PrelMarshalArray (
-- allocation
advancePtr -- :: Storable a => Ptr a -> Int -> Ptr a
) where
-import Monad (zipWithM_)
+import Monad
+#ifdef __GLASGOW_HASKELL__
import PrelPtr (Ptr, plusPtr)
import PrelStorable (Storable(sizeOf,peekElemOff,pokeElemOff,destruct))
import PrelMarshalAlloc (mallocBytes, allocaBytes, reallocBytes)
import PrelMarshalUtils (copyBytes, moveBytes)
-
+import PrelIOBase
+import PrelMaybe
+import PrelReal ( fromIntegral )
+import PrelNum
+import PrelList
+import PrelErr
+import PrelBase
+#endif
-- allocation
-- ----------
% -----------------------------------------------------------------------------
-% $Id: PrelMarshalError.lhs,v 1.1 2001/01/11 17:25:57 simonmar Exp $
+% $Id: PrelMarshalError.lhs,v 1.2 2001/05/18 16:54:05 simonmar Exp $
%
% (c) The FFI task force, 2000
%
Marshalling support: Handling of common error conditions
\begin{code}
+{-# OPTIONS -fno-implicit-prelude #-}
module PrelMarshalError (
) where
import PrelPtr
+import PrelIOBase
+import PrelNum
import PrelBase
-- exported functions
% -----------------------------------------------------------------------------
-% $Id: PrelMarshalUtils.lhs,v 1.2 2001/03/15 20:35:49 qrczak Exp $
+% $Id: PrelMarshalUtils.lhs,v 1.3 2001/05/18 16:54:05 simonmar Exp $
%
% (c) The FFI task force, 2000
%
Utilities for primitive marshaling
\begin{code}
+{-# OPTIONS -fno-implicit-prelude #-}
+
module PrelMarshalUtils (
-- combined allocation and marshalling
moveBytes -- :: Ptr a -> Ptr a -> Int -> IO ()
) where
-import Monad ( liftM )
-
+#ifdef __GLASGOW_HASKELL__
import PrelPtr ( Ptr, nullPtr )
import PrelStorable ( Storable(poke,destruct) )
import PrelCTypesISO ( CSize )
import PrelMarshalAlloc ( malloc, alloca )
-
+import PrelIOBase
+import PrelMaybe
+import PrelReal ( fromIntegral )
+import PrelNum
+import PrelBase
+#endif
-- combined allocation and marshalling
-- -----------------------------------
--
maybePeek :: (Ptr a -> IO b) -> Ptr a -> IO (Maybe b)
maybePeek peek ptr | ptr == nullPtr = return Nothing
- | otherwise = liftM Just $ peek ptr
+ | otherwise = do a <- peek ptr; return (Just a)
-- marshalling lists of storable objects
--- /dev/null
+{-# OPTIONS -optc-DNON_POSIX_SOURCE #-}
+
+-- ---------------------------------------------------------------------------
+-- $Id: PrelPosix.hsc,v 1.1 2001/05/18 16:54:05 simonmar Exp $
+--
+-- POSIX support layer for the standard libraries
+--
+
+module PrelPosix where
+
+#include "HsStd.h"
+
+import Monad
+import PrelCString
+import PrelPtr
+import PrelWord
+import PrelInt
+import PrelCTypesISO
+import PrelCTypes
+import PrelCError
+import PrelStorable
+import PrelMarshalAlloc
+import PrelMarshalUtils
+import PrelBits
+import PrelIOBase
+
+
+-- ---------------------------------------------------------------------------
+-- Types
+
+data CDir = CDir
+type CSigset = ()
+
+type CDev = #type dev_t
+type CIno = #type ino_t
+type CMode = #type mode_t
+type COff = #type off_t
+type CPid = #type pid_t
+#ifndef mingw32_TARGET_OS
+type CGid = #type gid_t
+type CNlink = #type nlink_t
+type CSsize = #type ssize_t
+type CUid = #type uid_t
+type CCc = #type cc_t
+type CSpeed = #type speed_t
+type CTcflag = #type tcflag_t
+#endif
+
+-- ---------------------------------------------------------------------------
+-- stat()-related stuff
+
+type CStat = ()
+
+fdFileSize :: Int -> IO Integer
+fdFileSize fd =
+ allocaBytes (#const sizeof(struct stat)) $ \ p_stat -> do
+ throwErrnoIfMinus1Retry "fileSize" $
+ c_fstat (fromIntegral fd) p_stat
+ c_mode <- (#peek struct stat, st_mode) p_stat :: IO CMode
+ if not (s_isreg c_mode)
+ then return (-1)
+ else do
+ c_size <- (#peek struct stat, st_size) p_stat :: IO COff
+ return (fromIntegral c_size)
+
+data FDType = Directory | Stream | RegularFile
+ deriving (Eq)
+
+fdType :: Int -> IO FDType
+fdType fd =
+ allocaBytes (#const sizeof(struct stat)) $ \ p_stat -> do
+ throwErrnoIfMinus1Retry "fileSize" $
+ c_fstat (fromIntegral fd) p_stat
+ c_mode <- (#peek struct stat, st_mode) p_stat :: IO CMode
+ case () of
+ _ | s_isdir c_mode -> return Directory
+ | s_isfifo c_mode || s_issock c_mode -> return Stream
+ | s_isreg c_mode -> return RegularFile
+ | otherwise -> ioException ioe_unknownfiletype
+
+ioe_unknownfiletype = IOError Nothing UnsupportedOperation "fdType"
+ "unknown file type" Nothing
+
+foreign import "s_isreg_wrap" s_isreg :: CMode -> Bool
+#def inline int s_isreg_wrap(m) { return S_ISREG(m); }
+
+foreign import "s_isdir_wrap" s_isdir :: CMode -> Bool
+#def inline int s_isdir_wrap(m) { return S_ISDIR(m); }
+
+foreign import "s_isfifo_wrap" s_isfifo :: CMode -> Bool
+#def inline int s_isfifo_wrap(m) { return S_ISFIFO(m); }
+
+foreign import "s_issock_wrap" s_issock :: CMode -> Bool
+#def inline int s_issock_wrap(m) { return S_ISSOCK(m); }
+
+-- ---------------------------------------------------------------------------
+-- Terminal-related stuff
+
+fdIsTTY :: Int -> IO Bool
+fdIsTTY fd = c_isatty (fromIntegral fd) >>= return.toBool
+
+type Termios = ()
+
+setEcho :: Int -> Bool -> IO ()
+setEcho fd on = do
+ allocaBytes (#const sizeof(struct termios)) $ \p_tios -> do
+ throwErrnoIfMinus1Retry "setEcho"
+ (c_tcgetattr (fromIntegral fd) p_tios)
+ c_lflag <- (#peek struct termios, c_lflag) p_tios :: IO CTcflag
+ let new_c_lflag | on = c_lflag .|. (#const ECHO)
+ | otherwise = c_lflag .&. complement (#const ECHO)
+ (#poke struct termios, c_lflag) p_tios (new_c_lflag :: CTcflag)
+ tcSetAttr fd (#const TCSANOW) p_tios
+
+getEcho :: Int -> IO Bool
+getEcho fd = do
+ allocaBytes (#const sizeof(struct termios)) $ \p_tios -> do
+ throwErrnoIfMinus1Retry "setEcho"
+ (c_tcgetattr (fromIntegral fd) p_tios)
+ c_lflag <- (#peek struct termios, c_lflag) p_tios :: IO CTcflag
+ return ((c_lflag .&. (#const ECHO)) /= 0)
+
+setCooked :: Int -> Bool -> IO ()
+setCooked fd cooked =
+ allocaBytes (#const sizeof(struct termios)) $ \p_tios -> do
+ throwErrnoIfMinus1Retry "setCooked"
+ (c_tcgetattr (fromIntegral fd) p_tios)
+
+ -- turn on/off ICANON
+ c_lflag <- (#peek struct termios, c_lflag) p_tios :: IO CTcflag
+ let new_c_lflag | cooked = c_lflag .|. (#const ICANON)
+ | otherwise = c_lflag .&. complement (#const ICANON)
+ (#poke struct termios, c_lflag) p_tios (new_c_lflag :: CTcflag)
+
+ -- set VMIN & VTIME to 1/0 respectively
+ when cooked $
+ do let c_cc = (#ptr struct termios, c_cc) p_tios
+ vmin = c_cc `plusPtr` (#const VMIN) :: Ptr Word8
+ vtime = c_cc `plusPtr` (#const VTIME) :: Ptr Word8
+ poke vmin 1
+ poke vtime 0
+
+ tcSetAttr fd (#const TCSANOW) p_tios
+
+-- tcsetattr() when invoked by a background process causes the process
+-- to be sent SIGTTOU regardless of whether the process has TOSTOP set
+-- in its terminal flags (try it...). This function provides a
+-- wrapper which temporarily blocks SIGTTOU around the call, making it
+-- transparent.
+
+tcSetAttr :: FD -> CInt -> Ptr Termios -> IO ()
+tcSetAttr fd options p_tios = do
+ allocaBytes (#const sizeof(sigset_t)) $ \ p_sigset -> do
+ allocaBytes (#const sizeof(sigset_t)) $ \ p_old_sigset -> do
+ c_sigemptyset p_sigset
+ c_sigaddset p_sigset (#const SIGTTOU)
+ c_sigprocmask (#const SIG_BLOCK) p_sigset p_old_sigset
+ throwErrnoIfMinus1Retry_ "tcSetAttr" $
+ c_tcsetattr (fromIntegral fd) options p_tios
+ c_sigprocmask (#const SIG_SETMASK) p_old_sigset nullPtr
+
+-- ---------------------------------------------------------------------------
+-- Turning on non-blocking for a file descriptor
+
+setNonBlockingFD fd = do
+ flags <- throwErrnoIfMinus1Retry "setNonBlockingFD"
+ (fcntl_read (fromIntegral fd) (#const F_GETFL))
+ throwErrnoIfMinus1Retry "setNonBlockingFD"
+ (fcntl_write (fromIntegral fd)
+ (#const F_SETFL) (flags .|. #const O_NONBLOCK))
+
+-- -----------------------------------------------------------------------------
+-- foreign imports
+
+foreign import "stat" unsafe
+ c_stat :: CString -> Ptr CStat -> IO CInt
+
+foreign import "fstat" unsafe
+ c_fstat :: CInt -> Ptr CStat -> IO CInt
+
+#ifdef HAVE_LSTAT
+foreign import "lstat" unsafe
+ c_lstat :: CString -> Ptr CStat -> IO CInt
+#endif
+
+foreign import "open" unsafe
+ c_open :: CString -> CInt -> CMode -> IO CInt
+
+-- POSIX flags only:
+o_RDONLY = (#const O_RDONLY) :: CInt
+o_WRONLY = (#const O_WRONLY) :: CInt
+o_RDWR = (#const O_RDWR) :: CInt
+o_APPEND = (#const O_APPEND) :: CInt
+o_CREAT = (#const O_CREAT) :: CInt
+o_EXCL = (#const O_EXCL) :: CInt
+o_NOCTTY = (#const O_NOCTTY) :: CInt
+o_TRUNC = (#const O_TRUNC) :: CInt
+o_NONBLOCK = (#const O_NONBLOCK) :: CInt
+
+foreign import "close" unsafe
+ c_close :: CInt -> IO CInt
+
+foreign import "fcntl" unsafe
+ fcntl_read :: CInt -> CInt -> IO CInt
+
+foreign import "fcntl" unsafe
+ fcntl_write :: CInt -> CInt -> CInt -> IO CInt
+
+foreign import "fork" unsafe
+ fork :: IO CPid
+
+foreign import "isatty" unsafe
+ c_isatty :: CInt -> IO CInt
+
+foreign import "lseek" unsafe
+ c_lseek :: CInt -> COff -> CInt -> IO COff
+
+foreign import "read" unsafe
+ c_read :: CInt -> Ptr CChar -> CSize -> IO CSsize
+
+foreign import "sigemptyset" unsafe
+ c_sigemptyset :: Ptr CSigset -> IO ()
+
+foreign import "sigaddset" unsafe
+ c_sigaddset :: Ptr CSigset -> CInt -> IO ()
+
+foreign import "sigprocmask" unsafe
+ c_sigprocmask :: CInt -> Ptr CSigset -> Ptr CSigset -> IO ()
+
+foreign import "tcgetattr" unsafe
+ c_tcgetattr :: CInt -> Ptr Termios -> IO CInt
+
+foreign import "tcsetattr" unsafe
+ c_tcsetattr :: CInt -> CInt -> Ptr Termios -> IO CInt
+
+foreign import "waitpid" unsafe
+ c_waitpid :: CPid -> Ptr CInt -> CInt -> IO CPid
+
+foreign import "write" unsafe
+ c_write :: CInt -> Ptr CChar -> CSize -> IO CSsize
+
% -----------------------------------------------------------------------------
-% $Id: PrelStorable.lhs,v 1.6 2001/04/14 22:28:22 qrczak Exp $
+% $Id: PrelStorable.lhs,v 1.7 2001/05/18 16:54:05 simonmar Exp $
%
% (c) The FFI task force, 2000
%
A class for primitive marshaling
\begin{code}
+{-# OPTIONS -fno-implicit-prelude #-}
+
#include "MachDeps.h"
module PrelStorable
#ifdef __GLASGOW_HASKELL__
import PrelStable ( StablePtr )
+import PrelNum
import PrelInt
import PrelWord
import PrelCTypes
import PrelStable
import PrelPtr
import PrelFloat
+import PrelErr
import PrelIOBase
import PrelBase
#endif
\section[PrelWord]{Module @PrelWord@}
\begin{code}
+{-# OPTIONS -fno-implicit-prelude #-}
+
#include "MachDeps.h"
module PrelWord (
import PrelRead
import PrelArr
import PrelBits
+import PrelShow
------------------------------------------------------------------------
-- Helper functions
% ------------------------------------------------------------------------------
-% $Id: Prelude.lhs,v 1.25 2001/02/28 00:01:03 qrczak Exp $
+% $Id: Prelude.lhs,v 1.26 2001/05/18 16:54:05 simonmar Exp $
%
% (c) The University of Glasgow, 1992-2000
%
showChar, showString, readParen, showParen,
-- Everything corresponding to the Report's PreludeIO
- FilePath, IOError,
ioError, userError, catch,
- putChar, putStr, putStrLn, print,
- getChar, getLine, getContents, interact,
+ FilePath, IOError,
+ putChar,
+ putStr, putStrLn, print,
+ getChar,
+ getLine, getContents, interact,
readFile, writeFile, appendFile, readIO, readLn,
Bool(..),
) where
+import Monad
+
import PrelBase
import PrelList
#ifndef USE_REPORT_PRELUDE
import PrelMaybe
import PrelShow
import PrelConc
-import PrelErr ( error )
+import PrelErr ( error, undefined )
-infixr 1 =<<
infixr 0 $!
\end{code}
\begin{code}
($!) :: (a -> b) -> a -> b
f $! x = x `seq` f x
-
--- It is expected that compilers will recognize this and insert error
--- messages which are more appropriate to the context in which undefined
--- appears.
-
-undefined :: a
-undefined = error "Prelude.undefined"
\end{code}
#endif
\end{code}
-
-%*********************************************************
-%* *
-\subsection{Prelude monad functions}
-%* *
-%*********************************************************
-
-\begin{code}
-{-# SPECIALISE (=<<) :: (a -> [b]) -> [a] -> [b] #-}
-(=<<) :: Monad m => (a -> m b) -> m a -> m b
-f =<< x = x >>= f
-
-sequence :: Monad m => [m a] -> m [a]
-{-# INLINE sequence #-}
-sequence ms = foldr k (return []) ms
- where
- k m m' = do { x <- m; xs <- m'; return (x:xs) }
-
-sequence_ :: Monad m => [m a] -> m ()
-{-# INLINE sequence_ #-}
-sequence_ ms = foldr (>>) (return ()) ms
-
-mapM :: Monad m => (a -> m b) -> [a] -> m [b]
-{-# INLINE mapM #-}
-mapM f as = sequence (map f as)
-
-mapM_ :: Monad m => (a -> m b) -> [a] -> m ()
-{-# INLINE mapM_ #-}
-mapM_ f as = sequence_ (map f as)
-\end{code}
-% -----------------------------------------------------------------------------
-% $Id: System.lhs,v 1.29 2001/01/11 17:51:02 simonmar Exp $
-%
-% (c) The University of Glasgow, 1994-2000
-%
-
-\section[System]{Module @System@}
+-- -----------------------------------------------------------------------------
+-- $Id: System.lhs,v 1.30 2001/05/18 16:54:05 simonmar Exp $
+--
+-- (c) The University of Glasgow, 1994-2000
+--
\begin{code}
-{-# OPTIONS -#include "cbits/stgio.h" #-}
module System
(
ExitCode(ExitSuccess,ExitFailure)
, exitWith -- :: ExitCode -> IO a
, exitFailure -- :: IO a
) where
-\end{code}
-\begin{code}
import Monad
import Prelude
+import PrelCError
import PrelCString
import PrelCTypes
import PrelMarshalArray
import PrelPtr
import PrelStorable
-import PrelIOBase ( IOException(..), ioException,
- IOErrorType(..), constructErrorAndFailWithInfo )
-\end{code}
+import PrelIOBase ( IOException(..), ioException, IOErrorType(..))
-%*********************************************************
-%* *
-\subsection{The @ExitCode@ type}
-%* *
-%*********************************************************
+-- -----------------------------------------------------------------------------
+-- The ExitCode type
-The $ExitCode$ type defines the exit codes that a program
-can return. $ExitSuccess$ indicates successful termination;
-and $ExitFailure code$ indicates program failure
-with value {\em code}. The exact interpretation of {\em code}
-is operating-system dependent. In particular, some values of
-{\em code} may be prohibited (e.g. 0 on a POSIX-compliant system).
+-- The `ExitCode' type defines the exit codes that a program
+-- can return. `ExitSuccess' indicates successful termination;
+-- and `ExitFailure code' indicates program failure
+-- with value `code'. The exact interpretation of `code'
+-- is operating-system dependent. In particular, some values of
+-- `code' may be prohibited (e.g. 0 on a POSIX-compliant system).
-\begin{code}
data ExitCode = ExitSuccess | ExitFailure Int
deriving (Eq, Ord, Read, Show)
-\end{code}
-Computation $getArgs$ returns a list of the program's command
-line arguments (not including the program name).
+-- Computation `getArgs' returns a list of the program's command
+-- line arguments (not including the program name).
-\begin{code}
getArgs :: IO [String]
getArgs = unpackArgv primArgv primArgc
foreign import ccall "get_prog_argv" unsafe primArgv :: Ptr (Ptr CChar)
foreign import ccall "get_prog_argc" unsafe primArgc :: Int
-\end{code}
-Computation $getProgName$ returns the name of the program
-as it was invoked.
+-- Computation `getProgName' returns the name of the program
+-- as it was invoked.
-\begin{code}
getProgName :: IO String
getProgName = unpackProgName primArgv
-\end{code}
-Computation $getEnv var$ returns the value
-of the environment variable {\em var}.
+-- Computation `getEnv var' returns the value
+-- of the environment variable {\em var}.
-This computation may fail with
-\begin{itemize}
-\item $NoSuchThing$
-The environment variable does not exist.
-\end{itemize}
+-- This computation may fail with
+-- NoSuchThing: The environment variable does not exist.
-\begin{code}
getEnv :: String -> IO String
getEnv name =
withUnsafeCString name $ \s -> do
"no environment variable" (Just name))
foreign import ccall "getenv" unsafe _getenv :: UnsafeCString -> IO (Ptr CChar)
-\end{code}
-Computation $system cmd$ returns the exit code
-produced when the operating system processes the command {\em cmd}.
+-- ---------------------------------------------------------------------------
+-- system
-This computation may fail with
-\begin{itemize}
-\item $PermissionDenied$
-The process has insufficient privileges to perform the operation.
-\item $ResourceExhausted$
-Insufficient resources are available to perform the operation.
-\item $UnsupportedOperation$
-The implementation does not support system calls.
-\end{itemize}
+-- Computation `system cmd' returns the exit code
+-- produced when the operating system processes the command {\em cmd}.
-\begin{code}
-system :: String -> IO ExitCode
+-- This computation may fail with
+-- PermissionDenied
+-- The process has insufficient privileges to perform the operation.
+-- ResourceExhausted
+-- Insufficient resources are available to perform the operation.
+-- UnsupportedOperation
+-- The implementation does not support system calls.
+
+system :: String -> IO ExitCode
system "" = ioException (IOError Nothing InvalidArgument "system" "null command" Nothing)
system cmd =
withUnsafeCString cmd $ \s -> do
- status <- primSystem s
+ status <- throwErrnoIfMinus1 "system" (primSystem s)
case status of
0 -> return ExitSuccess
- -1 -> constructErrorAndFailWithInfo "system" cmd
n -> return (ExitFailure n)
foreign import ccall "systemCmd" unsafe primSystem :: UnsafeCString -> IO Int
-\end{code}
-@exitWith code@ terminates the program, returning {\em code} to the program's caller.
-Before it terminates, any open or semi-closed handles are first closed.
+-- ---------------------------------------------------------------------------
+-- exitWith
-\begin{code}
-exitWith :: ExitCode -> IO a
+-- `exitWith code' terminates the program, returning `code' to the
+-- program's caller. Before it terminates, any open or semi-closed
+-- handles are first closed.
+
+exitWith :: ExitCode -> IO a
exitWith ExitSuccess = do
primExit 0
ioException (IOError Nothing OtherError "exitWith" "exit should not return" Nothing)
exitFailure :: IO a
exitFailure = exitWith (ExitFailure 1)
-\end{code}
-
-%*********************************************************
-%* *
-\subsection{Local utilities}
-%* *
-%*********************************************************
+-- ---------------------------------------------------------------------------
+-- Local utilities
-\begin{code}
unpackArgv :: Ptr (Ptr CChar) -> Int -> IO [String] -- argv[1 .. argc-1]
unpackArgv argv argc
= peekArray (argc-1) (advancePtr argv 1) >>= mapM peekCString
de_slash acc [] = reverse acc
de_slash _acc ('/':xs) = de_slash [] xs
de_slash acc (x:xs) = de_slash (x:acc) xs
+
\end{code}
-- to compile on sparc-solaris. Blargh.
-- -----------------------------------------------------------------------------
--- $Id: Time.hsc,v 1.12 2001/04/25 14:36:48 simonmar Exp $
+-- $Id: Time.hsc,v 1.13 2001/05/18 16:54:05 simonmar Exp $
--
-- (c) The University of Glasgow, 1995-2001
--
) where
-#include "config.h"
-
-#if defined(HAVE_GETTIMEOFDAY)
-# ifdef HAVE_SYS_TIME_H
-# include <sys/time.h>
-# endif
-#elif defined(HAVE_GETCLOCK)
-# ifdef HAVE_SYS_TIMERS_H
-# define POSIX_4D9 1
-# include <sys/timers.h>
-# endif
-#endif
-
-#if defined(HAVE_TIME_H)
-# include <time.h>
-#endif
-
-#ifdef HAVE_SYS_TYPES_H
-#include <sys/types.h>
-#endif
-
-#ifdef HAVE_SYS_TIMEB_H
-#include <sys/timeb.h>
-#endif
-
-#ifdef HAVE_WINDOWS_H
-#include <windows.h>
-#endif
+#include "HsStd.h"
import Ix
import Locale
/* -----------------------------------------------------------------------------
- * $Id: HsStd.h,v 1.1 2000/05/31 12:04:49 panne Exp $
+ * $Id: HsStd.h,v 1.2 2001/05/18 16:54:06 simonmar Exp $
*
* Definitions for package `std' which are visible in Haskell land.
*
#ifndef HSSTD_H
#define HSSTD_H
-#include "stgio.h"
+#include "config.h"
+
+#ifdef HAVE_SYS_TYPES_H
+#include <sys/types.h>
+#endif
+#ifdef HAVE_UNISTD_H
+#include <unistd.h>
+#endif
+#ifdef HAVE_SYS_STAT_H
+#include <sys/stat.h>
+#endif
+#ifdef HAVE_FCNTL_H
+# include <fcntl.h>
+#endif
+#ifdef HAVE_TERMIOS_H
+#include <termios.h>
+#endif
+#ifdef HAVE_SIGNAL_H
+#include <signal.h>
+#endif
+#ifdef HAVE_ERRNO_H
+#include <errno.h>
+#endif
+#if defined(HAVE_GETTIMEOFDAY)
+# ifdef HAVE_SYS_TIME_H
+# include <sys/time.h>
+# endif
+#elif defined(HAVE_GETCLOCK)
+# ifdef HAVE_SYS_TIMERS_H
+# define POSIX_4D9 1
+# include <sys/timers.h>
+# endif
+#endif
+#if defined(HAVE_TIME_H)
+# include <time.h>
+#endif
+#ifdef HAVE_SYS_TIMEB_H
+#include <sys/timeb.h>
+#endif
+#ifdef HAVE_WINDOWS_H
+#include <windows.h>
+#endif
+#ifdef HAVE_SYS_TIMES_H
+#include <sys/times.h>
+#endif
+
+#if !defined(mingw32_TARGET_OS) && !defined(irix_TARGET_OS)
+# if defined(HAVE_SYS_RESOURCE_H)
+# include <sys/resource.h>
+# endif
+#endif
+
+#ifdef hpux_TARGET_OS
+#include <sys/syscall.h>
+#define getrusage(a, b) syscall(SYS_GETRUSAGE, a, b)
+#define HAVE_GETRUSAGE
+#endif
+
+/* For System */
+#ifdef HAVE_SYS_WAIT_H
+#include <sys/wait.h>
+#endif
+#ifdef HAVE_VFORK_H
+#include <vfork.h>
+#endif
+
+#include "lockFile.h"
+
+#include "HsFFI.h"
+
+/* in ghc_errno.c */
+int *ghcErrno(void);
+
+/* in system.c */
+HsInt systemCmd(HsAddr cmd);
+
+/* in progargs.c */
+HsAddr get_prog_argv(void);
+HsInt get_prog_argc();
#endif
+++ /dev/null
-/*
- * (c) The GRASP/AQUA Project, Glasgow University, 1994-1998
- *
- * $Id: closeFile.c,v 1.10 2000/09/25 10:48:50 simonmar Exp $
- *
- * hClose Runtime Support
- */
-
-#include "Rts.h"
-#include "stgio.h"
-#include <errno.h>
-
-#if defined(HAVE_WINSOCK_H) && !defined(__CYGWIN__) && !defined(__CYGWIN32__)
-#define USE_WINSOCK
-#endif
-
-#ifdef USE_WINSOCK
-#include <winsock.h>
-#endif
-
-StgInt __really_close_stdfiles=1;
-
-StgInt
-closeFile(StgForeignPtr ptr, StgInt flush_buf)
-{
- IOFileObject* fo = (IOFileObject*)ptr;
- int rc = 0;
- int unlocked=1;
-
- /* Already closed, shouldn't occur. */
- if ( fo == NULL ) {
- return 0;
- }
-
- /* Flush buffer if we have unwritten data */
- if ( flush_buf != 0 ) {
- flushBuffer(fo);
- }
-
- /* If the flush failed, we ignore this and soldier on.. */
-
- if ( unlockFile(fo->fd) ) {
- /* If the file has already been unlocked (or an entry
- for it in the locking tables couldn't be found), could
- mean two things:
-
- - we're repeating an hClose on an already
- closed file (this is likely to be a bug
- in the implementation of hClose, as this
- condition should have been caught before
- we ended up here.)
-
- - the file wasn't locked in the first place!
- (file descriptors to non regular files.)
-
- We proceed with attempting to close the file,
- but don't flag the error should close() return
- EBADF
- */
- unlocked=0;
-
- }
-
- /* Free the buffer straight away. We can't free the file object
- * itself until the finalizer runs.
- */
- if ( fo->buf != NULL ) {
- free(fo->buf);
- fo->buf = NULL;
- }
-
- /* Closing file descriptors that refer to standard channels
- is problematic, so we back off from doing this by default,
- just closing them at the Handle level. If you insist on
- closing them, setting the (global) variable
- __really_close_stdfiles to 0 turns off this behaviour.
- */
- if ( (fo->flags & FILEOBJ_STD) && __really_close_stdfiles ) {
- ;
-
- } else {
- /* Regardless of success or otherwise, the fd field gets smashed. */
- while ( (rc =
- (
-#ifdef USE_WINSOCK
- fo->flags & FILEOBJ_WINSOCK ?
- closesocket(fo->fd) :
- close(fo->fd))) != 0 ) {
-#else
- close(fo->fd))) != 0 ) {
-#endif
- /* See above unlockFile() comment */
- if ( errno != EINTR && (!unlocked && errno != EBADF ) ) {
- cvtErrno();
- stdErrno();
- fo->fd = -1;
- return rc;
- }
- }
- }
-
- fo->fd = -1;
-
- return 0;
-}
+++ /dev/null
-/*
- * (c) The GRASP/AQUA Project, Glasgow University, 1994-1998
- *
- * $Id: echoAux.c,v 1.5 2001/02/19 16:07:48 rrt Exp $
- *
- * Support functions for changing echoing
- */
-
-#include "Rts.h"
-#include "stgio.h"
-
-#ifdef HAVE_SYS_TYPES_H
-#include <sys/types.h>
-#endif
-
-#ifdef HAVE_SYS_STAT_H
-#include <sys/stat.h>
-#endif
-
-#ifdef HAVE_TERMIOS_H
-#include <termios.h>
-#endif
-
-#ifdef HAVE_FCNTL_H
-#include <fcntl.h>
-#endif
-
-StgInt
-setTerminalEcho(StgForeignPtr ptr, StgInt on)
-{
-#ifndef mingw32_TARGET_OS
- IOFileObject* fo = (IOFileObject*)ptr;
- struct termios tios;
- int fd, rc;
-
- fd = fo->fd;
-
- while ( (rc = tcgetattr(fd,&tios)) == -1) {
- if (errno != EINTR) {
- cvtErrno();
- stdErrno();
- return -1;
- }
- }
-
- if (on) {
- tios.c_lflag |= ECHO;
- } else {
- tios.c_lflag &= ~ECHO;
- }
-
- while ( (rc = tcSetAttr(fd,TCSANOW,&tios)) == -1) {
- if (errno != EINTR) {
- cvtErrno();
- stdErrno();
- return -1;
- }
- }
-#endif
- return 0;
-}
-
-StgInt
-getTerminalEcho(StgForeignPtr ptr)
-{
-#ifndef mingw32_TARGET_OS
- IOFileObject* fo = (IOFileObject*)ptr;
- struct termios tios;
- int fd, rc;
-
- fd = fo->fd;
-
- while ( (rc = tcgetattr(fd,&tios)) == -1) {
- if (errno != EINTR) {
- cvtErrno();
- stdErrno();
- return -1;
- }
- }
- return (tios.c_cflag & ECHO ? 1 : 0);
-#else
- return 0;
-#endif
-}
-
-StgInt
-isTerminalDevice(StgForeignPtr ptr)
-{
-#ifndef mingw32_TARGET_OS
- IOFileObject* fo = (IOFileObject*)ptr;
- struct termios tios;
- int fd, rc;
-
- fd = fo -> fd;
-
- while ( (rc = tcgetattr(fd,&tios)) == -1) {
- if (errno == ENOTTY) return 0;
- if (errno != EINTR) {
- cvtErrno();
- stdErrno();
- return -1;
- }
- }
- return 1;
-#else
- return 0;
-#endif
-}
/*
- * (c) The GRASP/AQUA Project, Glasgow University, 1994-1998
+ * (c) The University of Glasgow, 2000-2001
*
- * $Id: errno.c,v 1.4 2001/01/26 17:51:40 rrt Exp $
+ * $Id: errno.c,v 1.5 2001/05/18 16:54:06 simonmar Exp $
*
* GHC Error Number Conversion
*/
-#include "Rts.h"
-#include "stgio.h"
-
+#include "HsStd.h"
/* Raw errno */
int *ghcErrno(void) {
return &errno;
}
-
-
-/* Fancy errno */
-
-int ghc_errno = 0;
-int ghc_errtype = 0;
-
-char *ghc_errstr = NULL;
-
-StgAddr
-getErrStr__()
-{ return ((StgAddr)ghc_errstr); }
-
-StgInt
-getErrNo__()
-{ return ((StgInt)ghc_errno); }
-
-StgInt
-getErrType__()
-{ return ((StgInt)ghc_errtype); }
-
-
-/* Collect all of the grotty #ifdef's in one place. */
-
-void cvtErrno(void)
-{
- switch(errno) {
-#ifdef E2BIG
- case E2BIG:
- ghc_errno = GHC_E2BIG;
- break;
-#endif
-#ifdef EACCES
- case EACCES:
- ghc_errno = GHC_EACCES;
- break;
-#endif
-#ifdef EADDRINUSE
- case EADDRINUSE:
- ghc_errno = GHC_EADDRINUSE;
- break;
-#endif
-#ifdef EADDRNOTAVAIL
- case EADDRNOTAVAIL:
- ghc_errno = GHC_EADDRNOTAVAIL;
- break;
-#endif
-#ifdef EADV
- case EADV:
- ghc_errno = GHC_EADV;
- break;
-#endif
-#ifdef EAFNOSUPPORT
- case EAFNOSUPPORT:
- ghc_errno = GHC_EAFNOSUPPORT;
- break;
-#endif
-#ifdef EAGAIN
- case EAGAIN:
- ghc_errno = GHC_EAGAIN;
- break;
-#endif
-#ifdef EALREADY
- case EALREADY:
- ghc_errno = GHC_EALREADY;
- break;
-#endif
-#ifdef EBADF
- case EBADF:
- ghc_errno = GHC_EBADF;
- break;
-#endif
-#ifdef EBADMSG
- case EBADMSG:
- ghc_errno = GHC_EBADMSG;
- break;
-#endif
-#ifdef EBADRPC
- case EBADRPC:
- ghc_errno = GHC_EBADRPC;
- break;
-#endif
-#ifdef EBUSY
- case EBUSY:
- ghc_errno = GHC_EBUSY;
- break;
-#endif
-#ifdef ECHILD
- case ECHILD:
- ghc_errno = GHC_ECHILD;
- break;
-#endif
-#ifdef ECOMM
- case ECOMM:
- ghc_errno = GHC_ECOMM;
- break;
-#endif
-#ifdef ECONNABORTED
- case ECONNABORTED:
- ghc_errno = GHC_ECONNABORTED;
- break;
-#endif
-#ifdef ECONNREFUSED
- case ECONNREFUSED:
- ghc_errno = GHC_ECONNREFUSED;
- break;
-#endif
-#ifdef ECONNRESET
- case ECONNRESET:
- ghc_errno = GHC_ECONNRESET;
- break;
-#endif
-#ifdef EDEADLK
- case EDEADLK:
- ghc_errno = GHC_EDEADLK;
- break;
-#endif
-#ifdef EDESTADDRREQ
- case EDESTADDRREQ:
- ghc_errno = GHC_EDESTADDRREQ;
- break;
-#endif
-#ifdef EDIRTY
- case EDIRTY:
- ghc_errno = GHC_EDIRTY;
- break;
-#endif
-#ifdef EDOM
- case EDOM:
- ghc_errno = GHC_EDOM;
- break;
-#endif
-#ifdef EDQUOT
- case EDQUOT:
- ghc_errno = GHC_EDQUOT;
- break;
-#endif
-#ifdef EEXIST
- case EEXIST:
- ghc_errno = GHC_EEXIST;
- break;
-#endif
-#ifdef EFAULT
- case EFAULT:
- ghc_errno = GHC_EFAULT;
- break;
-#endif
-#ifdef EFBIG
- case EFBIG:
- ghc_errno = GHC_EFBIG;
- break;
-#endif
-#ifdef EFTYPE
- case EFTYPE:
- ghc_errno = GHC_EFTYPE;
- break;
-#endif
-#ifdef EHOSTDOWN
- case EHOSTDOWN:
- ghc_errno = GHC_EHOSTDOWN;
- break;
-#endif
-#ifdef EHOSTUNREACH
- case EHOSTUNREACH:
- ghc_errno = GHC_EHOSTUNREACH;
- break;
-#endif
-#ifdef EIDRM
- case EIDRM:
- ghc_errno = GHC_EIDRM;
- break;
-#endif
-#ifdef EILSEQ
- case EILSEQ:
- ghc_errno = GHC_EILSEQ;
- break;
-#endif
-#ifdef EINPROGRESS
- case EINPROGRESS:
- ghc_errno = GHC_EINPROGRESS;
- break;
-#endif
-#ifdef EINTR
- case EINTR:
- ghc_errno = GHC_EINTR;
- break;
-#endif
-#ifdef EINVAL
- case EINVAL:
- ghc_errno = GHC_EINVAL;
- break;
-#endif
-#ifdef EIO
- case EIO:
- ghc_errno = GHC_EIO;
- break;
-#endif
-#ifdef EISCONN
- case EISCONN:
- ghc_errno = GHC_EISCONN;
- break;
-#endif
-#ifdef EISDIR
- case EISDIR:
- ghc_errno = GHC_EISDIR;
- break;
-#endif
-#ifdef ELOOP
- case ELOOP:
- ghc_errno = GHC_ELOOP;
- break;
-#endif
-#ifdef EMFILE
- case EMFILE:
- ghc_errno = GHC_EMFILE;
- break;
-#endif
-#ifdef EMLINK
- case EMLINK:
- ghc_errno = GHC_EMLINK;
- break;
-#endif
-#ifdef EMSGSIZE
- case EMSGSIZE:
- ghc_errno = GHC_EMSGSIZE;
- break;
-#endif
-#ifdef EMULTIHOP
- case EMULTIHOP:
- ghc_errno = GHC_EMULTIHOP;
- break;
-#endif
-#ifdef ENAMETOOLONG
- case ENAMETOOLONG:
- ghc_errno = GHC_ENAMETOOLONG;
- break;
-#endif
-#ifdef ENETDOWN
- case ENETDOWN:
- ghc_errno = GHC_ENETDOWN;
- break;
-#endif
-#ifdef ENETRESET
- case ENETRESET:
- ghc_errno = GHC_ENETRESET;
- break;
-#endif
-#ifdef ENETUNREACH
- case ENETUNREACH:
- ghc_errno = GHC_ENETUNREACH;
- break;
-#endif
-#ifdef ENFILE
- case ENFILE:
- ghc_errno = GHC_ENFILE;
- break;
-#endif
-#ifdef ENOBUFS
- case ENOBUFS:
- ghc_errno = GHC_ENOBUFS;
- break;
-#endif
-#ifdef ENODATA
- case ENODATA:
- ghc_errno = GHC_ENODATA;
- break;
-#endif
-#ifdef ENODEV
- case ENODEV:
- ghc_errno = GHC_ENODEV;
- break;
-#endif
-#ifdef ENOENT
- case ENOENT:
- ghc_errno = GHC_ENOENT;
- break;
-#endif
-#ifdef ENOEXEC
- case ENOEXEC:
- ghc_errno = GHC_ENOEXEC;
- break;
-#endif
-#ifdef ENOLCK
- case ENOLCK:
- ghc_errno = GHC_ENOLCK;
- break;
-#endif
-#ifdef ENOLINK
- case ENOLINK:
- ghc_errno = GHC_ENOLINK;
- break;
-#endif
-#ifdef ENOMEM
- case ENOMEM:
- ghc_errno = GHC_ENOMEM;
- break;
-#endif
-#ifdef ENOMSG
- case ENOMSG:
- ghc_errno = GHC_ENOMSG;
- break;
-#endif
-#ifdef ENONET
- case ENONET:
- ghc_errno = GHC_ENONET;
- break;
-#endif
-#ifdef ENOPROTOOPT
- case ENOPROTOOPT:
- ghc_errno = GHC_ENOPROTOOPT;
- break;
-#endif
-#ifdef ENOSPC
- case ENOSPC:
- ghc_errno = GHC_ENOSPC;
- break;
-#endif
-#ifdef ENOSR
- case ENOSR:
- ghc_errno = GHC_ENOSR;
- break;
-#endif
-#ifdef ENOSTR
- case ENOSTR:
- ghc_errno = GHC_ENOSTR;
- break;
-#endif
-#ifdef ENOSYS
- case ENOSYS:
- ghc_errno = GHC_ENOSYS;
- break;
-#endif
-#ifdef ENOTBLK
- case ENOTBLK:
- ghc_errno = GHC_ENOTBLK;
- break;
-#endif
-#ifdef ENOTCONN
- case ENOTCONN:
- ghc_errno = GHC_ENOTCONN;
- break;
-#endif
-#ifdef ENOTDIR
- case ENOTDIR:
- ghc_errno = GHC_ENOTDIR;
- break;
-#endif
-#ifndef aix_TARGET_OS
-/* AIX returns EEXIST where 4.3BSD used ENOTEMPTY.
- * there is an ENOTEMPTY defined as the same as EEXIST, and
- * therefore it won't work properly on a case statement.
- * another option is to define _ALL_SOURCE for aix, which
- * gives a different number for ENOTEMPTY.
- * I haven't tried that. -- andre.
- */
-#ifdef ENOTEMPTY
- case ENOTEMPTY:
- ghc_errno = GHC_ENOTEMPTY;
- break;
-#endif
-#endif
-#ifdef ENOTSOCK
- case ENOTSOCK:
- ghc_errno = GHC_ENOTSOCK;
- break;
-#endif
-#ifdef ENOTTY
- case ENOTTY:
- ghc_errno = GHC_ENOTTY;
- break;
-#endif
-#ifdef ENXIO
- case ENXIO:
- ghc_errno = GHC_ENXIO;
- break;
-#endif
-#ifdef EOPNOTSUPP
- case EOPNOTSUPP:
- ghc_errno = GHC_EOPNOTSUPP;
- break;
-#endif
-#ifdef EPERM
- case EPERM:
- ghc_errno = GHC_EPERM;
- break;
-#endif
-#ifdef EPFNOSUPPORT
- case EPFNOSUPPORT:
- ghc_errno = GHC_EPFNOSUPPORT;
- break;
-#endif
-#ifdef EPIPE
- case EPIPE:
- ghc_errno = GHC_EPIPE;
- break;
-#endif
-#ifdef EPROCLIM
- case EPROCLIM:
- ghc_errno = GHC_EPROCLIM;
- break;
-#endif
-#ifdef EPROCUNAVAIL
- case EPROCUNAVAIL:
- ghc_errno = GHC_EPROCUNAVAIL;
- break;
-#endif
-#ifdef EPROGMISMATCH
- case EPROGMISMATCH:
- ghc_errno = GHC_EPROGMISMATCH;
- break;
-#endif
-#ifdef EPROGUNAVAIL
- case EPROGUNAVAIL:
- ghc_errno = GHC_EPROGUNAVAIL;
- break;
-#endif
-#ifdef EPROTO
- case EPROTO:
- ghc_errno = GHC_EPROTO;
- break;
-#endif
-#ifdef EPROTONOSUPPORT
- case EPROTONOSUPPORT:
- ghc_errno = GHC_EPROTONOSUPPORT;
- break;
-#endif
-#ifdef EPROTOTYPE
- case EPROTOTYPE:
- ghc_errno = GHC_EPROTOTYPE;
- break;
-#endif
-#ifdef ERANGE
- case ERANGE:
- ghc_errno = GHC_ERANGE;
- break;
-#endif
-#ifdef EREMCHG
- case EREMCHG:
- ghc_errno = GHC_EREMCHG;
- break;
-#endif
-#ifdef EREMOTE
- case EREMOTE:
- ghc_errno = GHC_EREMOTE;
- break;
-#endif
-#ifdef EROFS
- case EROFS:
- ghc_errno = GHC_EROFS;
- break;
-#endif
-#ifdef ERPCMISMATCH
- case ERPCMISMATCH:
- ghc_errno = GHC_ERPCMISMATCH;
- break;
-#endif
-#ifdef ERREMOTE
- case ERREMOTE:
- ghc_errno = GHC_ERREMOTE;
- break;
-#endif
-#ifdef ESHUTDOWN
- case ESHUTDOWN:
- ghc_errno = GHC_ESHUTDOWN;
- break;
-#endif
-#ifdef ESOCKTNOSUPPORT
- case ESOCKTNOSUPPORT:
- ghc_errno = GHC_ESOCKTNOSUPPORT;
- break;
-#endif
-#ifdef ESPIPE
- case ESPIPE:
- ghc_errno = GHC_ESPIPE;
- break;
-#endif
-#ifdef ESRCH
- case ESRCH:
- ghc_errno = GHC_ESRCH;
- break;
-#endif
-#ifdef ESRMNT
- case ESRMNT:
- ghc_errno = GHC_ESRMNT;
- break;
-#endif
-#ifdef ESTALE
- case ESTALE:
- ghc_errno = GHC_ESTALE;
- break;
-#endif
-#ifdef ETIME
- case ETIME:
- ghc_errno = GHC_ETIME;
- break;
-#endif
-#ifdef ETIMEDOUT
- case ETIMEDOUT:
- ghc_errno = GHC_ETIMEDOUT;
- break;
-#endif
-#ifdef ETOOMANYREFS
- case ETOOMANYREFS:
- ghc_errno = GHC_ETOOMANYREFS;
- break;
-#endif
-#ifdef ETXTBSY
- case ETXTBSY:
- ghc_errno = GHC_ETXTBSY;
- break;
-#endif
-#ifdef EUSERS
- case EUSERS:
- ghc_errno = GHC_EUSERS;
- break;
-#endif
-#if 0
-#ifdef EWOULDBLOCK
- case EWOULDBLOCK:
- ghc_errno = GHC_EWOULDBLOCK;
- break;
-#endif
-#endif
-#ifdef EXDEV
- case EXDEV:
- ghc_errno = GHC_EXDEV;
- break;
-#endif
- default:
- ghc_errno = errno;
- break;
- }
-}
-
-void
-stdErrno(void)
-{
- switch(ghc_errno) {
- default:
- ghc_errtype = ERR_OTHERERROR;
- ghc_errstr = "unexpected error";
- break;
- case 0:
- ghc_errtype = ERR_OTHERERROR;
- ghc_errstr = "no error";
- case GHC_E2BIG:
- ghc_errtype = ERR_RESOURCEEXHAUSTED;
- ghc_errstr = "argument list too long";
- break;
- case GHC_EACCES:
- ghc_errtype = ERR_PERMISSIONDENIED;
- ghc_errstr = "inadequate access permission";
- break;
- case GHC_EADDRINUSE:
- ghc_errtype = ERR_RESOURCEBUSY;
- ghc_errstr = "address already in use";
- break;
- case GHC_EADDRNOTAVAIL:
- ghc_errtype = ERR_UNSUPPORTEDOPERATION;
- ghc_errstr = "address not available";
- break;
- case GHC_EADV:
- ghc_errtype = ERR_OTHERERROR;
- ghc_errstr = "RFS advertise error";
- break;
- case GHC_EAFNOSUPPORT:
- ghc_errtype = ERR_UNSUPPORTEDOPERATION;
- ghc_errstr = "address family not supported by protocol family";
- break;
- case GHC_EAGAIN:
- ghc_errtype = ERR_RESOURCEEXHAUSTED;
- ghc_errstr = "insufficient resources";
- break;
- case GHC_EALREADY:
- ghc_errtype = ERR_ALREADYEXISTS;
- ghc_errstr = "operation already in progress";
- break;
- case GHC_EBADF:
- ghc_errtype = ERR_OTHERERROR;
- ghc_errstr = "internal error (EBADF)";
- break;
- case GHC_EBADMSG:
- ghc_errtype = ERR_INAPPROPRIATETYPE;
- ghc_errstr = "next message has wrong type";
- break;
- case GHC_EBADRPC:
- ghc_errtype = ERR_OTHERERROR;
- ghc_errstr = "invalid RPC request or response";
- break;
- case GHC_EBUSY:
- ghc_errtype = ERR_RESOURCEBUSY;
- ghc_errstr = "device busy";
- break;
- case GHC_ECHILD:
- ghc_errtype = ERR_NOSUCHTHING;
- ghc_errstr = "no child processes";
- break;
- case GHC_ECOMM:
- ghc_errtype = ERR_RESOURCEVANISHED;
- ghc_errstr = "no virtual circuit could be found";
- break;
- case GHC_ECONNABORTED:
- ghc_errtype = ERR_OTHERERROR;
- ghc_errstr = "aborted connection";
- break;
- case GHC_ECONNREFUSED:
- ghc_errtype = ERR_NOSUCHTHING;
- ghc_errstr = "no listener on remote host";
- break;
- case GHC_ECONNRESET:
- ghc_errtype = ERR_RESOURCEVANISHED;
- ghc_errstr = "connection reset by peer";
- break;
- case GHC_EDEADLK:
- ghc_errtype = ERR_RESOURCEBUSY;
- ghc_errstr = "resource deadlock avoided";
- break;
- case GHC_EDESTADDRREQ:
- ghc_errtype = ERR_INVALIDARGUMENT;
- ghc_errstr = "destination address required";
- break;
- case GHC_EDIRTY:
- ghc_errtype = ERR_UNSATISFIEDCONSTRAINTS;
- ghc_errstr = "file system dirty";
- break;
- case GHC_EDOM:
- ghc_errtype = ERR_INVALIDARGUMENT;
- ghc_errstr = "argument too large";
- break;
- case GHC_EDQUOT:
- ghc_errtype = ERR_PERMISSIONDENIED;
- ghc_errstr = "quota exceeded";
- break;
- case GHC_EEXIST:
- ghc_errtype = ERR_ALREADYEXISTS;
- ghc_errstr = "file already exists";
- break;
- case GHC_EFAULT:
- ghc_errtype = ERR_OTHERERROR;
- ghc_errstr = "internal error (EFAULT)";
- break;
- case GHC_EFBIG:
- ghc_errtype = ERR_PERMISSIONDENIED;
- ghc_errstr = "file too large";
- break;
- case GHC_EFTYPE:
- ghc_errtype = ERR_INAPPROPRIATETYPE;
- ghc_errstr = "inappropriate NFS file type or format";
- break;
- case GHC_EHOSTDOWN:
- ghc_errtype = ERR_NOSUCHTHING;
- ghc_errstr = "destination host down";
- break;
- case GHC_EHOSTUNREACH:
- ghc_errtype = ERR_NOSUCHTHING;
- ghc_errstr = "remote host is unreachable";
- break;
- case GHC_EIDRM:
- ghc_errtype = ERR_RESOURCEVANISHED;
- ghc_errstr = "IPC identifier removed";
- break;
- case GHC_EILSEQ:
- ghc_errtype = ERR_INVALIDARGUMENT;
- ghc_errstr = "invalid wide character";
- break;
- case GHC_EINPROGRESS:
- ghc_errtype = ERR_ALREADYEXISTS;
- ghc_errstr = "operation now in progress";
- break;
- case GHC_EINTR:
- ghc_errtype = ERR_INTERRUPTED;
- ghc_errstr = "interrupted system call";
- break;
- case GHC_EINVAL:
- ghc_errtype = ERR_INVALIDARGUMENT;
- ghc_errstr = "invalid argument";
- break;
- case GHC_EIO:
- ghc_errtype = ERR_HARDWAREFAULT;
- ghc_errstr = "unknown I/O fault";
- break;
- case GHC_EISCONN:
- ghc_errtype = ERR_ALREADYEXISTS;
- ghc_errstr = "socket is already connected";
- break;
- case GHC_EISDIR:
- ghc_errtype = ERR_INAPPROPRIATETYPE;
- ghc_errstr = "file is a directory";
- break;
- case GHC_ELOOP:
- ghc_errtype = ERR_INVALIDARGUMENT;
- ghc_errstr = "too many symbolic links";
- break;
- case GHC_EMFILE:
- ghc_errtype = ERR_RESOURCEEXHAUSTED;
- ghc_errstr = "process file table full";
- break;
- case GHC_EMLINK:
- ghc_errtype = ERR_RESOURCEEXHAUSTED;
- ghc_errstr = "too many links";
- break;
- case GHC_EMSGSIZE:
- ghc_errtype = ERR_RESOURCEEXHAUSTED;
- ghc_errstr = "message too long";
- break;
- case GHC_EMULTIHOP:
- ghc_errtype = ERR_UNSUPPORTEDOPERATION;
- ghc_errstr = "multi-hop RFS request";
- break;
- case GHC_ENAMETOOLONG:
- ghc_errtype = ERR_INVALIDARGUMENT;
- ghc_errstr = "filename too long";
- break;
- case GHC_ENETDOWN:
- ghc_errtype = ERR_RESOURCEVANISHED;
- ghc_errstr = "network is down";
- break;
- case GHC_ENETRESET:
- ghc_errtype = ERR_RESOURCEVANISHED;
- ghc_errstr = "remote host rebooted; connection lost";
- break;
- case GHC_ENETUNREACH:
- ghc_errtype = ERR_NOSUCHTHING;
- ghc_errstr = "remote network is unreachable";
- break;
- case GHC_ENFILE:
- ghc_errtype = ERR_RESOURCEEXHAUSTED;
- ghc_errstr = "system file table full";
- break;
- case GHC_ENOBUFS:
- ghc_errtype = ERR_RESOURCEEXHAUSTED;
- ghc_errstr = "no buffer space available";
- break;
- case GHC_ENODATA:
- ghc_errtype = ERR_NOSUCHTHING;
- ghc_errstr = "no message on the stream head read queue";
- break;
- case GHC_ENODEV:
- ghc_errtype = ERR_NOSUCHTHING;
- ghc_errstr = "no such device";
- break;
- case GHC_ENOENT:
- ghc_errtype = ERR_NOSUCHTHING;
- ghc_errstr = "no such file or directory";
- break;
- case GHC_ENOEXEC:
- ghc_errtype = ERR_INVALIDARGUMENT;
- ghc_errstr = "not an executable file";
- break;
- case GHC_ENOLCK:
- ghc_errtype = ERR_RESOURCEEXHAUSTED;
- ghc_errstr = "no file locks available";
- break;
- case GHC_ENOLINK:
- ghc_errtype = ERR_RESOURCEVANISHED;
- ghc_errstr = "RFS link has been severed";
- break;
- case GHC_ENOMEM:
- ghc_errtype = ERR_RESOURCEEXHAUSTED;
- ghc_errstr = "not enough virtual memory";
- break;
- case GHC_ENOMSG:
- ghc_errtype = ERR_NOSUCHTHING;
- ghc_errstr = "no message of desired type";
- break;
- case GHC_ENONET:
- ghc_errtype = ERR_NOSUCHTHING;
- ghc_errstr = "host is not on a network";
- break;
- case GHC_ENOPROTOOPT:
- ghc_errtype = ERR_UNSUPPORTEDOPERATION;
- ghc_errstr = "operation not supported by protocol";
- break;
- case GHC_ENOSPC:
- ghc_errtype = ERR_RESOURCEEXHAUSTED;
- ghc_errstr = "no space left on device";
- break;
- case GHC_ENOSR:
- ghc_errtype = ERR_RESOURCEEXHAUSTED;
- ghc_errstr = "out of stream resources";
- break;
- case GHC_ENOSTR:
- ghc_errtype = ERR_INVALIDARGUMENT;
- ghc_errstr = "not a stream device";
- break;
- case GHC_ENOSYS:
- ghc_errtype = ERR_UNSUPPORTEDOPERATION;
- ghc_errstr = "function not implemented";
- break;
- case GHC_ENOTBLK:
- ghc_errtype = ERR_INVALIDARGUMENT;
- ghc_errstr = "not a block device";
- break;
- case GHC_ENOTCONN:
- ghc_errtype = ERR_INVALIDARGUMENT;
- ghc_errstr = "socket is not connected";
- break;
- case GHC_ENOTDIR:
- ghc_errtype = ERR_INAPPROPRIATETYPE;
- ghc_errstr = "not a directory";
- break;
- case GHC_ENOTEMPTY:
- ghc_errtype = ERR_UNSATISFIEDCONSTRAINTS;
- ghc_errstr = "directory not empty";
- break;
- case GHC_ENOTSOCK:
- ghc_errtype = ERR_INVALIDARGUMENT;
- ghc_errstr = "not a socket";
- break;
- case GHC_ENOTTY:
- ghc_errtype = ERR_ILLEGALOPERATION;
- ghc_errstr = "inappropriate ioctl for device";
- break;
- case GHC_ENXIO:
- ghc_errtype = ERR_NOSUCHTHING;
- ghc_errstr = "no such device or address";
- break;
- case GHC_EOPNOTSUPP:
- ghc_errtype = ERR_UNSUPPORTEDOPERATION;
- ghc_errstr = "operation not supported on socket";
- break;
- case GHC_EPERM:
- ghc_errtype = ERR_PERMISSIONDENIED;
- ghc_errstr = "privileged operation";
- break;
- case GHC_EPFNOSUPPORT:
- ghc_errtype = ERR_UNSUPPORTEDOPERATION;
- ghc_errstr = "protocol family not supported";
- break;
- case GHC_EPIPE:
- ghc_errtype = ERR_RESOURCEVANISHED;
- ghc_errstr = "broken pipe";
- break;
- case GHC_EPROCLIM:
- ghc_errtype = ERR_PERMISSIONDENIED;
- ghc_errstr = "too many processes";
- break;
- case GHC_EPROCUNAVAIL:
- ghc_errtype = ERR_UNSUPPORTEDOPERATION;
- ghc_errstr = "unimplemented RPC procedure";
- break;
- case GHC_EPROGMISMATCH:
- ghc_errtype = ERR_PROTOCOLERROR;
- ghc_errstr = "unsupported RPC program version";
- break;
- case GHC_EPROGUNAVAIL:
- ghc_errtype = ERR_UNSUPPORTEDOPERATION;
- ghc_errstr = "RPC program unavailable";
- break;
- case GHC_EPROTO:
- ghc_errtype = ERR_PROTOCOLERROR;
- ghc_errstr = "error in streams protocol";
- break;
- case GHC_EPROTONOSUPPORT:
- ghc_errtype = ERR_PROTOCOLERROR;
- ghc_errstr = "protocol not supported";
- break;
- case GHC_EPROTOTYPE:
- ghc_errtype = ERR_PROTOCOLERROR;
- ghc_errstr = "wrong protocol for socket";
- break;
- case GHC_ERANGE:
- ghc_errtype = ERR_UNSUPPORTEDOPERATION;
- ghc_errstr = "result too large";
- break;
- case GHC_EREMCHG:
- ghc_errtype = ERR_RESOURCEVANISHED;
- ghc_errstr = "remote address changed";
- break;
- case GHC_EREMOTE:
- ghc_errtype = ERR_ILLEGALOPERATION;
- ghc_errstr = "too many levels of remote in path";
- break;
- case GHC_EROFS:
- ghc_errtype = ERR_PERMISSIONDENIED;
- ghc_errstr = "read-only file system";
- break;
- case GHC_ERPCMISMATCH:
- ghc_errtype = ERR_PROTOCOLERROR;
- ghc_errstr = "RPC version is wrong";
- break;
- case GHC_ERREMOTE:
- ghc_errtype = ERR_ILLEGALOPERATION;
- ghc_errstr = "object is remote";
- break;
- case GHC_ESHUTDOWN:
- ghc_errtype = ERR_ILLEGALOPERATION;
- ghc_errstr = "can't send after socket shutdown";
- break;
- case GHC_ESOCKTNOSUPPORT:
- ghc_errtype = ERR_UNSUPPORTEDOPERATION;
- ghc_errstr = "socket type not supported";
- break;
- case GHC_ESPIPE:
- ghc_errtype = ERR_UNSUPPORTEDOPERATION;
- ghc_errstr = "can't seek on a pipe";
- break;
- case GHC_ESRCH:
- ghc_errtype = ERR_NOSUCHTHING;
- ghc_errstr = "no such process";
- break;
- case GHC_ESRMNT:
- ghc_errtype = ERR_UNSATISFIEDCONSTRAINTS;
- ghc_errstr = "RFS resources still mounted by remote host(s)";
- break;
- case GHC_ESTALE:
- ghc_errtype = ERR_RESOURCEVANISHED;
- ghc_errstr = "stale NFS file handle";
- break;
- case GHC_ETIME:
- ghc_errtype = ERR_TIMEEXPIRED;
- ghc_errstr = "timer expired";
- break;
- case GHC_ETIMEDOUT:
- ghc_errtype = ERR_TIMEEXPIRED;
- ghc_errstr = "connection timed out";
- break;
- case GHC_ETOOMANYREFS:
- ghc_errtype = ERR_RESOURCEEXHAUSTED;
- ghc_errstr = "too many references; can't splice";
- break;
- case GHC_ETXTBSY:
- ghc_errtype = ERR_RESOURCEBUSY;
- ghc_errstr = "text file in-use";
- break;
- case GHC_EUSERS:
- ghc_errtype = ERR_RESOURCEEXHAUSTED;
- ghc_errstr = "quota table full";
- break;
- case GHC_EWOULDBLOCK:
- ghc_errtype = ERR_OTHERERROR;
- ghc_errstr = "operation would block";
- break;
- case GHC_EXDEV:
- ghc_errtype = ERR_UNSUPPORTEDOPERATION;
- ghc_errstr = "can't make a cross-device link";
- break;
- }
-}
-
-void
-convertErrno(void)
-{
- cvtErrno();
- stdErrno();
-}
+++ /dev/null
-/*
- * (c) The GRASP/AQUA Project, Glasgow University, 1994-1998
- *
- * $Id: fileEOF.c,v 1.4 1999/11/25 16:54:14 simonmar Exp $
- *
- * hIsEOF Runtime Support
- */
-
-#include "Rts.h"
-#include "stgio.h"
-
-StgInt
-fileEOF(StgForeignPtr ptr)
-{
- IOFileObject* fo = (IOFileObject*)ptr;
-
- if ( FILEOBJ_IS_EOF(fo) )
- return 1;
-
- if (fileLookAhead(ptr) != EOF)
- return 0;
- else if (ghc_errtype == ERR_EOF)
- return 1;
- else
- return -1;
-}
+++ /dev/null
-/*
- * (c) The GRASP/AQUA Project, Glasgow University, 1994-1998
- *
- * $Id: fileGetc.c,v 1.6 2000/01/18 12:41:03 simonmar Exp $
- *
- * hGetChar Runtime Support
- */
-
-#include "Rts.h"
-#include "stgio.h"
-
-#define EOT 4
-
-/* Pre-condition: only ever called on a readable fileObject */
-StgInt
-fileGetc(StgForeignPtr ptr)
-{
- IOFileObject* fo = (IOFileObject*)ptr;
- int rc=0;
- unsigned char c;
-
-#if 0
- fprintf(stderr, "fgc: %d %d %d\n", fo->bufRPtr, fo->bufWPtr, fo->flags);
-#endif
- /*
- fileGetc does the following:
- - if the input is buffered, try fetch the char from buffer.
- - failing that,
-
- - if the input stream is 'connected' to an output stream,
- flush it before requesting any input.
- - if unbuffered, read in one character.
- - if line-buffered, read in one line, returning the first.
- - if block-buffered, fill up block, returning the first.
- */
-
- if ( FILEOBJ_WRITEABLE(fo) && FILEOBJ_JUST_WRITTEN(fo) && FILEOBJ_NEEDS_FLUSHING(fo) ) {
- rc = flushBuffer(ptr);
- if (rc < 0) return rc;
- }
-
- fo->flags = (fo->flags & ~FILEOBJ_RW_WRITE) | FILEOBJ_RW_READ;
-
- if ( FILEOBJ_IS_EOF(fo) ) {
- ghc_errtype = ERR_EOF;
- ghc_errstr = "";
- return -1;
- }
-
- if ( FILEOBJ_BUFFER_EMPTY(fo) ) {
- ;
- } else if ( FILEOBJ_UNBUFFERED(fo) && !FILEOBJ_HAS_PUSHBACKS(fo) ) {
- ;
- } else if ( FILEOBJ_UNBUFFERED(fo) ) { /* Unbuffered stream has pushbacks, retrieve them */
- c=((unsigned char*)(fo->buf))[fo->bufRPtr++];
- return (int)c;
- } else {
- c=((unsigned char*)(fo->buf))[fo->bufRPtr];
- fo->bufRPtr++;
- return (int)c;
- }
-
- /* Nothing in the buffer, go out and fetch a byte for our customer,
- filling up the buffer if needs be.
- */
- if ( FILEOBJ_UNBUFFERED(fo) ) {
- return (readChar(ptr));
- } else if ( FILEOBJ_LINEBUFFERED(fo) ) {
-
- /* if input stream is connect to an output stream, flush it first */
- if ( fo->connectedTo != NULL &&
- fo->connectedTo->fd != -1 &&
- (fo->connectedTo->flags & FILEOBJ_WRITE) ) {
- rc = flushFile((StgForeignPtr)fo->connectedTo);
- }
- if (rc < 0) return rc;
-
- rc = fill_up_line_buffer(fo);
- if (rc < 0) return rc;
-
- c=((unsigned char*)(fo->buf))[fo->bufRPtr];
- fo->bufRPtr++;
- return (int)c;
-
- } else { /* Fully-buffered */
- rc = readBlock(ptr);
- if (rc < 0) return rc;
-
- c=((unsigned char*)(fo->buf))[fo->bufRPtr];
- fo->bufRPtr++;
- return (int)c;
- }
-}
+++ /dev/null
-/*
- * (c) The GRASP/AQUA Project, Glasgow University, 1994-1998
- *
- * $Id: fileLookAhead.c,v 1.5 1999/12/08 15:47:07 simonmar Exp $
- *
- * hLookAhead Runtime Support
- */
-
-#include "Rts.h"
-#include "stgio.h"
-
-StgInt
-fileLookAhead(StgForeignPtr ptr)
-{
- IOFileObject* fo = (IOFileObject*)ptr;
- int c, rc;
-
-#if 0
- fprintf(stderr, "flh: %d %d %d\n",fo->bufRPtr, fo->bufWPtr, fo->flags);
-#endif
-
- /*
- * fileLookahead reads the next character (hopefully from the buffer),
- * before putting it back and returning the char.
- *
- */
-
- if ( FILEOBJ_IS_EOF(fo) ) {
- ghc_errtype = ERR_EOF;
- ghc_errstr = "";
- return -1;
- }
-
- if ( (c = fileGetc(ptr)) < 0 ) {
- return c;
- }
-
- rc = ungetChar(ptr,(char)c);
- if ( rc < 0 ) {
- return rc;
- } else {
- return c;
- }
-}
-
-StgInt
-ungetChar(StgForeignPtr ptr, StgChar c)
-{
- IOFileObject* fo = (IOFileObject*)ptr;
- int sz = 0;
-
-#if 0
- fprintf(stderr, "ug: %d %d %c\n",fo->bufRPtr, fo->bufWPtr,(char)c, fo->flags);
-#endif
-
- /* Sanity check */
- if ( !FILEOBJ_READABLE(fo) ) {
- ghc_errno = GHC_EINVAL;
- ghc_errstr = "object not readable";
- return -1;
- }
-
- /* For an unbuffered file object, we lazily
- allocate a pushback buffer. The sizeof the pushback
- buffer is (globally) configurable.
- */
- sz = getPushbackBufSize();
- if ( FILEOBJ_UNBUFFERED(fo) && fo->buf==NULL && sz > 0 ) {
- if ((fo->buf = malloc(sz*sizeof(char))) == NULL ) {
- return -1;
- }
- fo->bufSize = sz;
- ((unsigned char*)fo->buf)[sz-1]=(unsigned char)c;
- fo->bufWPtr = sz; /* Points one past the end of pushback buffer */
- fo->bufRPtr = sz-1; /* points to current char. */
- return 0;
- }
-
- if ( fo->bufWPtr > 0 && fo->bufRPtr > 0 ) {
- fo->bufRPtr -= 1;
- ((unsigned char*)fo->buf)[fo->bufRPtr]=(unsigned char)c;
- return 0;
- } else if ( fo->buf != NULL &&
- fo->bufSize > 0 &&
- fo->bufWPtr == 0 &&
- fo->bufRPtr==0 ) { /* empty buffer waiting to be filled up */
- fo->bufRPtr=fo->bufSize-1;
- ((unsigned char*)fo->buf)[fo->bufRPtr]=(unsigned char)c;
- fo->bufWPtr=fo->bufSize;
- return 0;
- } else {
- return -1;
- }
-}
+++ /dev/null
-/*
- * (c) The GRASP/AQUA Project, Glasgow University, 1994-1998
- *
- * $Id: fileObject.c,v 1.11 2000/10/10 09:28:50 simonmar Exp $
- *
- * hPutStr Runtime Support
- */
-
-#include "Rts.h"
-#include "stgio.h"
-
-#include <stdio.h>
-
-#if defined(HAVE_WINSOCK_H) && !defined(__CYGWIN__) && !defined(__CYGWIN32__)
-#define USE_WINSOCK
-#endif
-
-#ifdef USE_WINSOCK
-#include <winsock.h>
-#endif
-
-void
-setBufFlags(StgForeignPtr fo, StgInt flg)
-{
- ((IOFileObject*)fo)->flags = flg;
- return;
-}
-
-void
-setBufWPtr(StgForeignPtr fo, StgInt len)
-{
- ((IOFileObject*)fo)->bufWPtr = len;
- return;
-}
-
-StgInt
-getBufWPtr(StgForeignPtr fo)
-{
- return (((IOFileObject*)fo)->bufWPtr);
-}
-
-StgInt
-getBufSize(StgForeignPtr fo)
-{
- return (((IOFileObject*)fo)->bufSize);
-}
-
-void
-setBuf(StgForeignPtr fo, StgAddr buf,StgInt sz)
-{
- ((IOFileObject*)fo)->buf = buf;
- ((IOFileObject*)fo)->bufSize = sz;
- return;
-}
-
-StgAddr
-getBuf(StgForeignPtr fo)
-{ return (((IOFileObject*)fo)->buf); }
-
-StgAddr
-getWriteableBuf(StgForeignPtr ptr)
-{
- /* getWriteableBuf() is called prior to starting to pack
- a Haskell string into the IOFileObject buffer. It takes
- care of flushing the (input) buffer in the case we're
- dealing with a RW handle.
- */
- IOFileObject* fo = (IOFileObject*)ptr;
-
- if ( FILEOBJ_READABLE(fo) && FILEOBJ_JUST_READ(fo) ) {
- flushReadBuffer(ptr); /* ignoring return code */
- /* Ahead of time really, but indicate that we're (just about to) write */
- }
- fo->flags = (fo->flags & ~FILEOBJ_RW_READ) | FILEOBJ_RW_WRITE;
- return (fo->buf);
-}
-
-StgAddr
-getBufStart(StgForeignPtr fo, StgInt count)
-{ return ((char*)((IOFileObject*)fo)->buf + (((IOFileObject*)fo)->bufRPtr) - count); }
-
-StgInt
-getFileFd(StgForeignPtr fo)
-{ return (((IOFileObject*)fo)->fd); }
-
-StgInt
-getConnFileFd(StgForeignPtr fo)
-{ return (((IOFileObject*)fo)->connectedTo->fd); }
-
-
-void
-setFd(StgForeignPtr fo,StgInt fp)
-{ ((IOFileObject*)fo)->fd = fp;
- return;
-}
-
-void
-setConnectedTo(StgForeignPtr fo, StgForeignPtr fw, StgInt flg)
-{
- if( flg && (! isatty(((IOFileObject*)fo)->fd) || !isatty(((IOFileObject*)fw)->fd)) ) {
- return;
- }
- ((IOFileObject*)fo)->connectedTo = (IOFileObject*)fw;
- return;
-}
-
-static int __pushback_buf_size__ = 2;
-
-void
-setPushbackBufSize(StgInt i)
-{ __pushback_buf_size__ = (i > 0 ? i : 0); }
-
-StgInt
-getPushbackBufSize(void)
-{ return (__pushback_buf_size__); }
-
-/* Only ever called on line-buffered file objects */
-StgInt
-fill_up_line_buffer(IOFileObject* fo)
-{
- int count,len, ipos;
- unsigned char* p;
-
- /* ToDo: deal with buffer overflow (i.e., realloc buffer if this happens) */
-
- if ( fo->bufRPtr == fo->bufWPtr ) { /* There's nothing in the buffer, reset */
- fo->bufRPtr=0;
- fo->bufWPtr=0;
- }
- ipos = fo->bufWPtr;
- len = fo->bufSize - fo->bufWPtr;
- p = (unsigned char*)fo->buf + fo->bufWPtr;
-
- while ((count =
- (
-#ifdef USE_WINSOCK
- fo->flags & FILEOBJ_WINSOCK ?
- recv(fo->fd, p, len, 0) :
- read(fo->fd, p, len))) <= 0 ) {
-#else
- read(fo->fd, p, len))) <= 0 ) {
-#endif
- if (count == 0) {
- ghc_errtype = ERR_EOF;
- ghc_errstr = "";
- FILEOBJ_SET_EOF(fo);
- return -1;
- } else if ( count == -1 && errno == EAGAIN) {
- errno = 0;
- return FILEOBJ_BLOCKED_READ;
- } else if ( count == -1 && errno != EINTR ) {
- cvtErrno();
- stdErrno();
- return -1;
- }
- }
- fo->bufWPtr += count;
-/* TODO: ipos doesn't change???? what's it for??? --SDM */
- return (fo->bufWPtr - ipos);
-}
+++ /dev/null
-#ifndef FILEOBJECT_H
-#define FILEOBJECT_H
-
-/*
- IOFileObjects are used as part of the IO.Handle
- implementation, ensuring that when handles are
- finalised, buffers are flushed and FILE* objects
- are closed (we really should be using file descriptors
- here..)
-
- */
-
-typedef struct _IOFileObject {
- int fd;
- void* buf;
-
- int bufWPtr; /* points to next position to write,
- bufRPtr >= bufWPtr <= bufSize.
-
- For read-only files, bufWPtr = bufSize
-
- bufWPtr = 0 => buffer is empty.
-
- */
- int bufRPtr; /* points to the next char to read
- -1 >= bufRPtr <= bufWPtr
-
- For write-only files, bufRPtr = 0
-
- bufRPtr == -1 => buffer is empty.
- */
- int bufSize; /* the size of the buffer, i.e. the number of bytes
- malloced */
- int flags;
- struct _IOFileObject* connectedTo;
-
-} IOFileObject;
-
-#define FILEOBJ_LB 2
-#define FILEOBJ_BB 4
-#define FILEOBJ_EOF 8
-#define FILEOBJ_READ 16
-#define FILEOBJ_WRITE 32
-#define FILEOBJ_STD 64
-/* The next two flags are used for RW file objects only.
- They indicate whether the last operation was a read or a write.
- (Need this info to determine whether a RW file object's
- buffer should be flushed before doing a subsequent
- read or write).
-*/
-#define FILEOBJ_RW_READ 256
-#define FILEOBJ_RW_WRITE 512
-/*
- * Under Win32, a file fd is not the same as a socket fd, so
- * we need to use separate r/w calls.
- */
-#define FILEOBJ_WINSOCK 1024
-#define FILEOBJ_BINARY 2048
-
-#define FILEOBJ_IS_EOF(x) ((x)->flags & FILEOBJ_EOF)
-#define FILEOBJ_SET_EOF(x) ((x)->flags |= FILEOBJ_EOF)
-#define FILEOBJ_CLEAR_EOF(x) ((x)->flags &= ~FILEOBJ_EOF)
-#define FILEOBJ_CLEAR_ERR(x) FILEOBJ_CLEAR_EOF(x)
-
-#define FILEOBJ_BLOCKED_READ -5
-#define FILEOBJ_BLOCKED_WRITE -6
-#define FILEOBJ_BLOCKED_CONN_WRITE -7
-
-#define FILEOBJ_UNBUFFERED(x) (!((x)->flags & FILEOBJ_LB) && !((x)->flags & FILEOBJ_BB))
-#define FILEOBJ_LINEBUFFERED(x) ((x)->flags & FILEOBJ_LB)
-#define FILEOBJ_BLOCKBUFFERED(x) ((x)->flags & FILEOBJ_BB)
-#define FILEOBJ_BUFFER_FULL(x) ((x)->bufWPtr >= (x)->bufSize)
-#define FILEOBJ_BUFFER_EMPTY(x) ((x)->bufRPtr == (x)->bufWPtr)
-#define FILEOBJ_HAS_PUSHBACKS(x) ((x)->buf != NULL && (x)->bufRPtr >= 0 && (x)->bufRPtr < (x)->bufWPtr)
-#define FILEOBJ_READABLE(x) ((x)->flags & FILEOBJ_READ)
-#define FILEOBJ_WRITEABLE(x) ((x)->flags & FILEOBJ_WRITE)
-#define FILEOBJ_JUST_READ(x) ((x)->flags & FILEOBJ_RW_READ)
-#define FILEOBJ_JUST_WRITTEN(x) ((x)->flags & FILEOBJ_RW_WRITE)
-#define FILEOBJ_NEEDS_FLUSHING(x) (!FILEOBJ_BUFFER_EMPTY(x))
-#define FILEOBJ_RW(x) (FILEOBJ_READABLE(x) && FILEOBJ_WRITEABLE(x))
-
-#endif /* FILEOBJECT_H */
+++ /dev/null
-/*
- * (c) The GRASP/AQUA Project, Glasgow University, 1994-1998
- *
- * $Id: filePosn.c,v 1.7 2000/04/14 16:25:08 rrt Exp $
- *
- * hGetPosn and hSetPosn Runtime Support
- */
-
-#include "Rts.h"
-#include "stgio.h"
-
-#ifdef HAVE_SYS_TYPES_H
-#include <sys/types.h>
-#endif
-
-StgInt
-getFilePosn(ptr)
-StgForeignPtr ptr;
-{
- IOFileObject* fo = (IOFileObject*)ptr;
- off_t posn;
- while ( (posn = lseek(fo->fd, 0, SEEK_CUR)) == -1) {
- if (errno != EINTR) {
- cvtErrno();
- stdErrno();
- return -1;
- }
- }
- if (fo->flags & FILEOBJ_WRITE) {
- posn += fo->bufWPtr;
- } else if (fo->flags & FILEOBJ_READ) {
- posn -= (fo->bufWPtr - fo->bufRPtr);
-#if defined(_WIN32)
- if (fo->buf && !(fo->flags & FILEOBJ_BINARY)) {
- /* Sigh, to get at the Real file position for files opened
- in text mode, we need to scan the read buffer looking for
- '\n's, making them count as \r\n (i.e., undoing the work of
- read()), since lseek() returns the raw position.
- */
- int i, j;
-
- i = fo->bufRPtr;
- j = fo->bufWPtr;
- while (i <= j) {
- if (((char*)fo->buf)[i] == '\n') {
- posn--;
- }
- i++;
- }
- }
-#endif
- }
- return (StgInt)posn;
-}
-
-/* The following is only called with a position that we've already visited
- (this is ensured by making the Haskell file posn. type abstract.)
-*/
-StgInt
-setFilePosn(StgForeignPtr ptr, StgInt size, StgByteArray d)
-{
- IOFileObject* fo = (IOFileObject*)ptr;
- int rc;
- off_t offset;
-
- /*
- * We need to snatch the offset out of an MP_INT. The bits are there sans sign,
- * which we pick up from our size parameter. If abs(size) is greater than 1,
- * this integer is just too big.
- */
- switch (size) {
- case -1:
- offset = -*(StgInt *) d;
- break;
- case 0:
- offset = 0;
- break;
- case 1:
- offset = *(StgInt *) d;
- break;
- default:
- ghc_errtype = ERR_INVALIDARGUMENT;
- ghc_errstr = "offset out of range";
- return -1;
- }
-
- rc = flushBuffer(ptr);
- if (rc < 0) return rc;
-
- while (lseek(fo->fd, offset, SEEK_SET) == -1) {
- if (errno != EINTR) {
- cvtErrno();
- stdErrno();
- return -1;
- }
- }
- FILEOBJ_CLEAR_EOF(fo);
- return 0;
-}
+++ /dev/null
-/*
- * (c) The GRASP/AQUA Project, Glasgow University, 1994-1998
- *
- * $Id: filePutc.c,v 1.12 2000/08/07 23:37:23 qrczak Exp $
- *
- * hPutChar Runtime Support
- */
-
-#include "Rts.h"
-#include "stgio.h"
-
-#if defined(HAVE_WINSOCK_H) && !defined(__CYGWIN__) && !defined(__CYGWIN32__)
-#define USE_WINSOCK
-#endif
-
-#ifdef USE_WINSOCK
-#include <winsock.h>
-#endif
-
-#define TERMINATE_LINE(x) ((x) == '\n')
-
-StgInt
-filePutc(StgForeignPtr ptr, StgChar c)
-{
- IOFileObject* fo = (IOFileObject*)ptr;
- int rc = 0;
- unsigned char byte = (unsigned char) c;
-
- /* What filePutc needs to do:
-
- - if there's no buffering => write it out.
- - if the buffer is line-buffered
- write out buffer (+char), iff buffer would be full afterwards ||
- new char is the newline character
- add to buffer , otherwise
- - if the buffer is fully-buffered
- write out buffer (+char), iff adding char fills up buffer.
- add char to buffer, otherwise.
-
- In the cases where a file is buffered, the invariant is that operations
- that fill up a buffer also flushes them. A consequence of this here, is
- that we're guaranteed to be passed a buffer with space for (at least)
- the one char we're adding.
-
- Supporting RW objects adds yet another twist, since we have to make
- sure that if such objects have been read from just previously, we
- flush(i.e., empty) the buffer first. (We could be smarter about this,
- but aren't!)
-
- Only the lower 8 bits of a character are written. The data are supposed
- to be already converted to the stream's 8-bit encoding.
-
- */
-
- if ( FILEOBJ_READABLE(fo) && FILEOBJ_JUST_READ(fo) ) {
- rc = flushReadBuffer(ptr);
- if (rc<0) return rc;
- }
-
- fo->flags = (fo->flags & ~FILEOBJ_RW_READ) | FILEOBJ_RW_WRITE;
-
- /* check whether we can just add it to the buffer.. */
- if ( FILEOBJ_UNBUFFERED(fo) ) {
- ;
- } else {
- /* We're buffered, add it to the pack */
- ((unsigned char*)fo->buf)[fo->bufWPtr] = byte;
- fo->bufWPtr++;
- /* If the buffer filled up as a result, *or*
- the added character terminated a line
- => flush.
- */
- if ( FILEOBJ_BUFFER_FULL(fo) ||
- (FILEOBJ_LINEBUFFERED(fo) && TERMINATE_LINE(c)) ) {
- rc = writeBuffer(ptr, fo->bufWPtr);
- /* Undo the write if we're blocking..*/
- if (rc == FILEOBJ_BLOCKED_WRITE ) fo->bufWPtr--;
- }
- return rc;
- }
-
- /* Unbuffered, write the character directly. */
- while ((rc = (
-#ifdef USE_WINSOCK
- fo->flags & FILEOBJ_WINSOCK ?
- send(fo->fd, &byte, 1, 0) :
- write(fo->fd, &byte, 1))) <= 0) {
-#else
- write(fo->fd, &byte, 1))) <= 0) {
-#endif
-
- if ( rc == -1 && errno == EAGAIN) {
- errno = 0;
- return FILEOBJ_BLOCKED_WRITE;
- } else if (rc == 0 || (rc == -1 && errno != EINTR)) {
- cvtErrno();
- stdErrno();
- return -1;
- }
- }
-
- return 0;
-}
+++ /dev/null
-/*
- * (c) The GRASP/AQUA Project, Glasgow University, 1994-1998
- *
- * $Id: fileSize.c,v 1.7 2001/04/02 16:10:32 rrt Exp $
- *
- * hClose Runtime Support
- */
-
-#include "Rts.h"
-#include "stgio.h"
-
-#ifdef HAVE_SYS_TYPES_H
-#include <sys/types.h>
-#endif
-
-#ifdef HAVE_SYS_STAT_H
-#include <sys/stat.h>
-#endif
-
-StgInt
-fileSize(StgForeignPtr ptr, StgByteArray result)
-{
- IOFileObject* fo = (IOFileObject*)ptr;
- struct stat sb;
- int rc = 0;
-
- /* Flush buffer in order to get as an accurate size as poss. */
- rc = flushFile(ptr);
- if (rc < 0) return rc;
-
- while (fstat(fo->fd, &sb) < 0) {
- /* highly unlikely */
- if (errno != EINTR) {
- cvtErrno();
- stdErrno();
- return -1;
- }
- }
- if (S_ISREG(sb.st_mode)) {
- /* result will be word aligned */
-#if defined( macosx_TARGET_OS )
- *(W_ *) result = (W_)sb.st_size;
-#else
- *(off_t *) result = sb.st_size;
-#endif
- return 0;
- } else {
- ghc_errtype = ERR_INAPPROPRIATETYPE;
- ghc_errstr = "not a regular file";
- return -1;
- }
-}
-
-StgInt
-fileSize_int64(StgForeignPtr ptr, StgByteArray result)
-{
- IOFileObject* fo = (IOFileObject*)ptr;
- struct stat sb;
- int rc = 0;
-
- /* Flush buffer in order to get as an accurate size as poss. */
- rc = flushFile(ptr);
- if (rc < 0) return rc;
-
- while (fstat(fo->fd, &sb) < 0) {
- /* highly unlikely */
- if (errno != EINTR) {
- cvtErrno();
- stdErrno();
- return -1;
- }
- }
- if (S_ISREG(sb.st_mode)) {
- /* result will be word aligned */
- *(StgInt64*) result = (StgInt64)sb.st_size;
- return 0;
- } else {
- ghc_errtype = ERR_INAPPROPRIATETYPE;
- ghc_errstr = "not a regular file";
- return -1;
- }
-}
-
+++ /dev/null
-/*
- * (c) The GRASP/AQUA Project, Glasgow University, 1994-1998
- *
- * $Id: flushFile.c,v 1.8 2000/09/25 10:51:04 simonmar Exp $
- *
- * hFlush Runtime Support
- */
-
-#include "Rts.h"
-#include "stgio.h"
-
-StgInt
-flushFile(StgForeignPtr ptr)
-{
- IOFileObject* fo = (IOFileObject*)ptr;
- int rc = 0;
-
- if ( FILEOBJ_WRITEABLE(fo) && FILEOBJ_JUST_WRITTEN(fo) &&
- FILEOBJ_NEEDS_FLUSHING(fo) ) {
- rc = writeBuffer(ptr, fo->bufWPtr - fo->bufRPtr);
- }
-
- return rc;
-}
-
-StgInt
-flushBuffer(StgForeignPtr ptr)
-{
- IOFileObject* fo = (IOFileObject*)ptr;
- int rc = 0;
-
- if ( FILEOBJ_WRITEABLE(fo) && FILEOBJ_JUST_WRITTEN(fo) &&
- FILEOBJ_NEEDS_FLUSHING(fo) ) {
- rc = writeBuffer(ptr, fo->bufWPtr - fo->bufRPtr);
- if (rc<0) return rc;
- }
-
- /* TODO: shouldn't we do the lseek stuff from flushReadBuffer
- * here???? --SDM
- */
-
- /* Reset read & write pointer for input buffers */
- if ( (fo->flags & FILEOBJ_READ) ) {
- fo->bufRPtr=0;
- fo->bufWPtr=0;
- }
- return 0;
-}
-
-/*
- For RW file objects, flushing input buffers doesn't just involve
- resetting the read & write pointers, we also have to change the
- underlying file position to point to the effective read position.
-
- (Sigh, I now understand the real reason for why stdio opted for
- the solution of leaving this to the programmer!)
-*/
-StgInt
-flushReadBuffer(StgForeignPtr ptr)
-{
- IOFileObject* fo = (IOFileObject*)ptr;
- int delta;
-
- delta = fo->bufWPtr - fo->bufRPtr;
-
- if ( delta > 0 ) {
- while ( lseek(fo->fd, -delta, SEEK_CUR) == -1) {
- if (errno != EINTR) {
- cvtErrno();
- stdErrno();
- return -1;
- }
- }
- }
-
- fo->bufRPtr=0;
- fo->bufWPtr=0;
- return 0;
-}
-
-void
-flushConnectedBuf(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;
-}
-
-
+++ /dev/null
-/*
- * (c) The GRASP/AQUA Project, Glasgow University, 1994-1998
- *
- * $Id: freeFile.c,v 1.11 2000/04/14 16:21:32 rrt Exp $
- *
- * Giving up files
- */
-
-#include "Rts.h"
-#include "stgio.h"
-
-#if defined(HAVE_WINSOCK_H) && !defined(__CYGWIN__) && !defined(__CYGWIN32__)
-#define USE_WINSOCK
-#endif
-
-#ifdef USE_WINSOCK
-#include <winsock.h>
-#endif
-
-
-/* sigh, the FILEs attached to the standard descriptors are
- handled differently. We don't want them freed via the
- ForeignObj finaliser, as we probably want to use these
- before we *really* shut down (dumping stats etc.)
-*/
-void
-freeStdFile(StgAddr fp)
-{ return; }
-
-void
-freeStdFileObject(StgAddr ptr)
-{
- IOFileObject* fo = (IOFileObject*)ptr;
- int rc;
-
- /* Don't close the file, just flush the buffer */
- if (fo != NULL && fo->fd != -1) {
- if (fo->buf != NULL && (fo->flags & FILEOBJ_WRITE) && fo->bufWPtr > 0) {
- /* Flush buffer contents */
- do {
- rc = writeBuffer((StgForeignPtr)fo, fo->bufWPtr);
- } while (rc == FILEOBJ_BLOCKED_WRITE) ;
- }
- }
-}
-
-void
-freeFileObject(StgAddr ptr)
-{
- /*
- * The finaliser for the file objects embedded in Handles. The RTS
- * assumes that the finaliser runs without problems, so all
- * we can do here is flush buffers + close(), and hope nothing went wrong.
- *
- */
-
- int rc;
- IOFileObject* fo = (IOFileObject*)ptr;
-
- if ( fo == NULL )
- return;
-
- if ( fo->fd == -1 || (rc = unlockFile(fo->fd)) ) {
- /* If the file handle has been explicitly closed
- * (via closeFile()), we will have given
- * up our process lock, so we break off and just return.
- */
- if ( fo->buf != NULL ) {
- free(fo->buf);
- }
- free(fo);
- return;
- }
-
- if (fo->buf != NULL && fo->bufWPtr > 0) {
- /* Flush buffer contents before closing underlying file */
- fo->flags &= ~FILEOBJ_RW_WRITE | ~FILEOBJ_RW_READ;
- flushFile(ptr);
- }
-
-#ifdef USE_WINSOCK
- if ( fo->flags & FILEOBJ_WINSOCK )
- /* Sigh - the cleanup call at the end will do this for us */
- return;
- rc = ( fo->flags & FILEOBJ_WINSOCK ? closesocket(fo->fd) : close(fo->fd) );
-#else
- rc = close(fo->fd);
-#endif
- /* Error or no error, we don't care.. */
-
- if ( fo->buf != NULL ) {
- free(fo->buf);
- }
- free(fo);
-
- return;
-}
-
-StgAddr
-ref_freeStdFileObject(void)
-{
- return (StgAddr)&freeStdFileObject;
-}
-
-StgAddr
-ref_freeFileObject(void)
-{
- return (StgAddr)&freeFileObject;
-}
-
+++ /dev/null
-/*
- * (c) The GRASP/AQUA Project, Glasgow University, 1994-1998
- *
- * $Id: getBufferMode.c,v 1.5 2001/04/02 16:10:32 rrt Exp $
- *
- * hIs...Buffered Runtime Support
- */
-
-#include "Rts.h"
-#include "stgio.h"
-
-#ifdef HAVE_SYS_TYPES_H
-#include <sys/types.h>
-#endif
-
-#ifdef HAVE_SYS_STAT_H
-#include <sys/stat.h>
-#endif
-
-/*
- * We try to guess what the default buffer mode is going to be based
- * on the type of file we're attached to.
- */
-
-#define GBM_NB (0)
-#define GBM_LB (-1)
-#define GBM_BB (-2)
-#define GBM_ERR (-3)
-
-StgInt
-getBufferMode(ptr)
-StgForeignPtr ptr;
-{
- IOFileObject* fo = (IOFileObject*)ptr;
- struct stat sb;
- int fd = fo->fd;
-
- /* Try to find out the file type */
- while (fstat(fd, &sb) < 0) {
- /* highly unlikely */
- if (errno != EINTR) {
- cvtErrno();
- stdErrno();
- return GBM_ERR;
- }
- }
- /* Terminals are line-buffered by default */
- if (S_ISCHR(sb.st_mode) && isatty(fd) == 1) {
- fo ->flags |= FILEOBJ_LB;
- return GBM_LB;
- /* Default size block buffering for the others */
- } else {
- fo ->flags |= FILEOBJ_BB;
- return GBM_BB;
- }
-}
/*
* (c) The GRASP/AQUA Project, Glasgow University, 1994-1998
*
- * $Id: inputReady.c,v 1.6 1999/12/08 15:47:08 simonmar Exp $
+ * $Id: inputReady.c,v 1.7 2001/05/18 16:54:06 simonmar Exp $
*
* hReady Runtime Support
*/
#define NON_POSIX_SOURCE
#endif
-#include "Rts.h"
-#include "stgio.h"
-
-#ifdef HAVE_SYS_TYPES_H
-#include <sys/types.h>
-#endif
-
-#ifdef _AIX
-/* this is included from sys/types.h only if _BSD is defined. */
-/* Since it is not, I include it here. - andre */
-#include <sys/select.h>
-#endif
-
-#ifdef HAVE_UNISTD_H
-#include <unistd.h>
-#endif
-
-#ifdef HAVE_FCNTL_H
-#include <fcntl.h>
-#endif
-
-#ifdef HAVE_SYS_TIME_H
-#include <sys/time.h>
-#endif
+#include "HsStd.h"
/*
- * inputReady(ptr, msecs) checks to see whether input is available
- * on the file object 'ptr', timing out after (approx.) 'msec' milliseconds.
- * Input meaning 'can I safely read at least a *character* from this file
- * object without blocking?'
- *
- * If the file object has a non-empty buffer, the test is trivial. If not,
- * we select() on the (readable) file descriptor.
- *
- * Notice that for file descriptors connected to ttys in non-canonical mode
- * (i.e., it's buffered), inputReady will not return true until a *complete
- * line* can be read.
+ * inputReady(fd) checks to see whether input is available on the file
+ * descriptor 'fd'. Input meaning 'can I safely read at least a
+ * *character* from this file object without blocking?'
*/
-
-StgInt
-inputReady(ptr, msecs)
-StgForeignPtr ptr;
-StgInt msecs;
+int
+inputReady(int fd, int msecs)
{
- IOFileObject* fo = (IOFileObject*)ptr;
- int fd, maxfd, ready;
+ int maxfd, ready;
#ifndef mingw32_TARGET_OS
fd_set rfd;
struct timeval tv;
#endif
- if ( FILEOBJ_IS_EOF(fo) )
- return 0;
-
- if ( !FILEOBJ_BUFFER_EMPTY(fo) ) {
- /* Don't look any further, there's stuff in the buffer */
- return 1;
- }
-
#ifdef mingw32_TARGET_OS
return 1;
#else
- fd = fo->fd;
-
- /* Now try to get a character */
FD_ZERO(&rfd);
FD_SET(fd, &rfd);
- /* select() will consider the descriptor set in the range of 0 to (maxfd-1) */
+
+ /* select() will consider the descriptor set in the range of 0 to
+ * (maxfd-1)
+ */
maxfd = fd + 1;
tv.tv_sec = msecs / 1000;
tv.tv_usec = msecs % 1000;
+
while ((ready = select(maxfd, &rfd, NULL, NULL, &tv)) < 0 ) {
if (errno != EINTR ) {
- cvtErrno();
- stdErrno();
- ready = -1;
- break;
+ return -1;
}
}
- /* 1 => Input ready, 0 => time expired (-1 error) */
+ /* 1 => Input ready, 0 => not ready, -1 => error */
return (ready);
+
#endif
}
/*
* (c) The GRASP/AQUA Project, Glasgow University, 1994-1998
*
- * $Id: getLock.c,v 1.9 2001/04/02 16:10:32 rrt Exp $
+ * $Id: lockFile.c,v 1.1 2001/05/18 16:54:06 simonmar Exp $
*
* stdin/stout/stderr Runtime Support
*/
-#include "Rts.h"
-#include "stgio.h"
-
-#ifdef HAVE_SYS_TYPES_H
-#include <sys/types.h>
-#endif
-
-#ifdef HAVE_SYS_STAT_H
-#include <sys/stat.h>
-#endif
-
-#ifdef HAVE_UNISTD_H
-#include <unistd.h>
-#endif
-
-#ifdef HAVE_FCNTL_H
-#include <fcntl.h>
-#endif
+#include "HsStd.h"
#ifndef FD_SETSIZE
#define FD_SETSIZE 256
static int writeLocks = 0;
int
-lockFile(fd, for_writing, exclusive)
-int fd;
-int for_writing;
-int exclusive;
+lockFile(int fd, int for_writing, int exclusive)
{
int i;
struct stat sb;
- while (fstat(fd, &sb) < 0) {
- if (errno != EINTR) {
-#ifndef _WIN32
- return -1;
-#else
- /* fstat()ing socket fd's seems to fail with CRT's fstat(),
- so let's just silently return and hope for the best..
- */
- return 0;
-#endif
- }
- }
-
- /* Only lock regular files */
- if (!S_ISREG(sb.st_mode))
- return 0;
-
if (for_writing) {
/* opening a file for writing, check to see whether
we don't have any read locks on it already.. */
for (i = 0; i < readLocks; i++) {
if (readLock[i].inode == sb.st_ino && readLock[i].device == sb.st_dev) {
#ifndef __MINGW32__
- errno = EAGAIN;
return -1;
#else
break;
for (i = 0; i < writeLocks; i++) {
if (writeLock[i].inode == sb.st_ino && writeLock[i].device == sb.st_dev) {
#ifndef __MINGW32__
- errno = EAGAIN;
return -1;
#else
break;
for (i = 0; i < writeLocks; i++) {
if (writeLock[i].inode == sb.st_ino && writeLock[i].device == sb.st_dev) {
#ifndef __MINGW32__
- errno = EAGAIN;
return -1;
#else
break;
}
int
-unlockFile(fd)
-int fd;
+unlockFile(int fd)
{
int i;
/* Signal that we did not find an entry */
return 1;
}
-
-/* getLock() is used when opening the standard file descriptors */
-StgInt
-getLock(fd, for_writing)
-StgInt fd;
-StgInt for_writing;
-{
- if (lockFile(fd, for_writing, 0) < 0) {
- if (errno == EBADF)
- return 0;
- else {
- cvtErrno();
- switch (ghc_errno) {
- default:
- stdErrno();
- break;
- case GHC_EACCES:
- case GHC_EAGAIN:
- ghc_errtype = ERR_RESOURCEBUSY;
- ghc_errstr = "file is locked";
- break;
- }
- /* Not so sure we want to do this, since getLock()
- is only called on the standard file descriptors.. */
- /*(void) close(fd); */
- return -1;
- }
- }
- return 1;
-}
--- /dev/null
+/*
+ * (c) The University of Glasgow 2001
+ *
+ * $Id: lockFile.h,v 1.1 2001/05/18 16:54:06 simonmar Exp $
+ *
+ * lockFile header
+ */
+
+int lockFile(int fd, int for_writing, int exclusive);
+int unlockFile(int fd);
+++ /dev/null
-/*
- * (c) The GRASP/AQUA Project, Glasgow University, 1994-1998
- *
- * $Id: openFile.c,v 1.20 2001/04/02 16:10:33 rrt Exp $
- *
- * openFile Runtime Support
- */
-
-/* We use lstat, which is sadly not POSIX */
-#define NON_POSIX_SOURCE
-
-#include "Rts.h"
-#include "stgio.h"
-
-#ifdef HAVE_SYS_TYPES_H
-#include <sys/types.h>
-#endif
-
-#ifdef HAVE_SYS_STAT_H
-#include <sys/stat.h>
-#endif
-
-#ifdef HAVE_UNISTD_H
-#include <unistd.h>
-#endif
-
-#ifdef HAVE_FCNTL_H
-#include <fcntl.h>
-#endif
-
-#if defined(mingw32_TARGET_OS) && !defined(O_NOCTTY)
-#define O_NOCTTY 0
-#endif
-
-IOFileObject*
-openStdFile(StgInt fd, StgInt rd)
-{
- IOFileObject* fo;
- long fd_flags;
-
- if ((fo = malloc(sizeof(IOFileObject))) == NULL)
- return NULL;
- fo->fd = fd;
- fo->buf = NULL;
- fo->bufWPtr = 0;
- fo->bufRPtr = 0;
- fo->flags = FILEOBJ_STD | ( rd ? FILEOBJ_READ : FILEOBJ_WRITE);
- fo->connectedTo = NULL;
-
-#if !defined(_WIN32) || defined(__CYGWIN__) || defined(__CYGWIN32__)
- /* Set the non-blocking flag on this file descriptor.
- *
- * Don't do it for stdout and stderr: some shells (actually most)
- * don't reset the nonblocking flag after running a program, and
- * this causes all sorts of problems. --SDM (12/99)
- *
- * MS Win32 CRT doesn't support fcntl() -- the workaround is to
- * start using 'completion ports', but I'm punting on implementing
- * support for using those.
- */
- if (fd != 1 && fd != 2) {
- fd_flags = fcntl(fd, F_GETFL);
- fcntl(fd, F_SETFL, fd_flags | O_NONBLOCK);
- }
-#endif
-
- return fo;
-}
-
-#define OPENFILE_APPEND 0
-#define OPENFILE_WRITE 1
-#define OPENFILE_READ_ONLY 2
-#define OPENFILE_READ_WRITE 3
-
-IOFileObject*
-openFile(StgByteArray file, StgInt how, StgInt binary)
-{
- int fd;
- int oflags;
- int for_writing;
- int created = 0;
- struct stat sb;
- IOFileObject* fo;
- int flags = 0;
-
-#if defined(_WIN32) && !(defined(__CYGWIN__) || defined(__CYGWIN32__))
-#define O_NONBLOCK 0
-#endif
-
- /*
- * Since we aren't supposed to succeed when we're opening for writing and
- * there's another writer, we can't just do an open() with O_WRONLY.
- */
-
- switch (how) {
- case OPENFILE_APPEND:
- oflags = O_NONBLOCK | O_WRONLY | O_NOCTTY | O_APPEND;
- for_writing = 1;
- flags |= FILEOBJ_WRITE;
- break;
- case OPENFILE_WRITE:
- oflags = O_NONBLOCK | O_WRONLY | O_NOCTTY;
- flags |= FILEOBJ_WRITE;
- for_writing = 1;
- break;
- case OPENFILE_READ_ONLY:
- oflags = O_NONBLOCK | O_RDONLY | O_NOCTTY;
- flags |= FILEOBJ_READ;
- for_writing = 0;
- break;
- case OPENFILE_READ_WRITE:
- oflags = O_NONBLOCK | O_RDWR | O_NOCTTY;
- flags |= FILEOBJ_READ | FILEOBJ_WRITE;
- for_writing = 1;
- break;
- default:
- fprintf(stderr, "openFile: unknown mode `%d'\n", how);
- exit(EXIT_FAILURE);
- }
-
-#if HAVE_O_BINARY
- if (binary) {
- oflags |= O_BINARY;
- flags |= FILEOBJ_BINARY;
- }
-#endif
-
- /* First try to open without creating */
- while ((fd = open(file, oflags, 0666)) < 0) {
- if (errno == ENOENT) {
- if ( how == OPENFILE_READ_ONLY ) {
- /* For ReadMode, just bail out now */
- ghc_errtype = ERR_NOSUCHTHING;
- ghc_errstr = "file does not exist";
- return NULL;
- } else {
- /* If it is a dangling symlink, break off now, too. */
-#ifndef mingw32_TARGET_OS
- struct stat st;
- if ( lstat(file,&st) == 0) {
- ghc_errtype = ERR_NOSUCHTHING;
- ghc_errstr = "dangling symlink";
- return NULL;
- }
-#endif
- }
- /* Now try to create it */
- while ((fd = open(file, oflags | O_CREAT | O_EXCL, 0666)) < 0) {
- if (errno == EEXIST) {
- /* Race detected; go back and open without creating it */
- break;
- } else if (errno != EINTR) {
- cvtErrno();
- switch (ghc_errno) {
- default:
- stdErrno();
- break;
- case GHC_ENOENT:
- case GHC_ENOTDIR:
- ghc_errtype = ERR_NOSUCHTHING;
- ghc_errstr = "no path to file";
- break;
- case GHC_EINVAL:
- ghc_errtype = ERR_PERMISSIONDENIED;
- ghc_errstr = "unsupported owner or group";
- break;
- }
- return NULL;
- }
- }
- if (fd >= 0) {
- created = 1;
- break;
- }
- } else if (errno != EINTR) {
- cvtErrno();
- switch (ghc_errno) {
- default:
- stdErrno();
- break;
- case GHC_ENOTDIR:
- ghc_errtype = ERR_NOSUCHTHING;
- ghc_errstr = "no path to file";
- break;
- case GHC_EINVAL:
- ghc_errtype = ERR_PERMISSIONDENIED;
- ghc_errstr = "unsupported owner or group";
- break;
- }
- return NULL;
- }
- }
-
- /* Make sure that we aren't looking at a directory */
-
- while (fstat(fd, &sb) < 0) {
- /* highly unlikely */
- if (errno != EINTR) {
- cvtErrno();
- if (created)
- (void) unlink(file);
- (void) close(fd);
- return NULL;
- }
- }
- if (S_ISDIR(sb.st_mode)) {
- ghc_errtype = ERR_INAPPROPRIATETYPE;
- ghc_errstr = "file is a directory";
- /* We can't have created it in this case. */
- (void) close(fd);
-
- return NULL;
- }
- /* Use our own personal locking */
-
- if (lockFile(fd, for_writing, 1/*enforce single-writer, if needs be.*/) < 0) {
- cvtErrno();
- switch (ghc_errno) {
- default:
- stdErrno();
- break;
- case GHC_EACCES:
- case GHC_EAGAIN:
- ghc_errtype = ERR_RESOURCEBUSY;
- ghc_errstr = "file is locked";
- break;
- }
- if (created)
- (void) unlink(file);
- (void) close(fd);
- return NULL;
- }
-
- /*
- * Write mode is supposed to truncate the file. Unfortunately, our pal
- * ftruncate() is non-POSIX, so we truncate with a second open, which may fail.
- */
-
- if ( how == OPENFILE_WRITE ) {
- int fd2, oflags2;
-
- oflags2 = oflags | O_TRUNC;
- while ((fd2 = open(file, oflags2, 0666)) < 0) {
- if (errno != EINTR) {
- cvtErrno();
- if (created)
- (void) unlink(file);
- (void) close(fd);
- switch (ghc_errno) {
- default:
- stdErrno();
- break;
- case GHC_EAGAIN:
- ghc_errtype = ERR_RESOURCEBUSY;
- ghc_errstr = "enforced lock prevents truncation";
- break;
- case GHC_ENOTDIR:
- ghc_errtype = ERR_NOSUCHTHING;
- ghc_errstr = "no path to file";
- break;
- case GHC_EINVAL:
- ghc_errtype = ERR_PERMISSIONDENIED;
- ghc_errstr = "unsupported owner or group";
- break;
- }
- return NULL;
- }
- }
- close(fd2);
- }
-
- /* Allocate a IOFileObject to hold the information
- we need to record per-handle for the various C stubs.
- This chunk of memory is wrapped up inside a foreign object,
- so it will be finalised and freed properly when we're
- through with the handle.
- */
- if ((fo = malloc(sizeof(IOFileObject))) == NULL)
- return NULL;
-
- fo->fd = fd;
- fo->buf = NULL;
- fo->bufWPtr = 0;
- fo->bufRPtr = 0;
- fo->flags = flags;
- fo->connectedTo = NULL;
- return fo;
-}
-
-/* `Lock' file descriptor and return file object. */
-IOFileObject*
-openFd(StgInt fd, StgInt oflags, StgInt flags)
-{
- int for_writing;
- IOFileObject* fo;
-
- for_writing = ( ((oflags & O_WRONLY) || (oflags & O_RDWR)) ? 1 : 0);
-
- if (lockFile(fd, for_writing, 1/* enforce single-writer */ ) < 0) {
- cvtErrno();
- switch (ghc_errno) {
- default:
- stdErrno();
- break;
- case GHC_EACCES:
- case GHC_EAGAIN:
- ghc_errtype = ERR_RESOURCEBUSY;
- ghc_errstr = "file is locked";
- break;
- }
- return NULL;
- }
-
- /* See openFileObject() comment */
- if ((fo = malloc(sizeof(IOFileObject))) == NULL)
- return NULL;
- fo->fd = fd;
- fo->buf = NULL;
- fo->bufWPtr = 0;
- fo->bufRPtr = 0;
- fo->flags = flags | ( oflags & O_RDONLY ? FILEOBJ_READ
- : oflags & O_RDWR ? FILEOBJ_READ
- : 0)
- | ( oflags & O_WRONLY ? FILEOBJ_WRITE
- : oflags & O_RDWR ? FILEOBJ_WRITE
- : 0);
- fo->connectedTo = NULL;
- return fo;
-}
/*
* (c) The GRASP/AQUA Project, Glasgow University, 1994-1998
*
- * $Id: progargs.c,v 1.4 2001/01/11 17:25:58 simonmar Exp $
+ * $Id: progargs.c,v 1.5 2001/05/18 16:54:06 simonmar Exp $
*
* System.getArgs Runtime Support
*/
#include "Rts.h"
-#include "stgio.h"
HsAddr
get_prog_argv(void)
+++ /dev/null
-/*
- * (c) The GRASP/AQUA Project, Glasgow University, 1994-1998
- *
- * $Id: readFile.c,v 1.15 2000/04/12 17:33:16 simonmar Exp $
- *
- * hGetContents Runtime Support
- */
-
-#include "Rts.h"
-#include "stgio.h"
-
-#if defined(HAVE_WINSOCK_H) && !defined(__CYGWIN__) && !defined(__CYGWIN32__)
-#define USE_WINSOCK
-#endif
-
-#ifdef USE_WINSOCK
-#include <winsock.h>
-#endif
-
-#define EOT 4
-
-/* Filling up a (block-buffered) buffer, that
- is completely empty. */
-StgInt
-readBlock(StgForeignPtr ptr)
-{
- IOFileObject* fo = (IOFileObject*)ptr;
- int count,rc=0;
- int fd;
-
- /* Check if someone hasn't zapped us */
- if ( fo == NULL || fo->fd == -1 )
- return -2;
-
- fd = fo->fd;
-
- if ( FILEOBJ_IS_EOF(fo) ) {
- ghc_errtype = ERR_EOF;
- ghc_errstr = "";
- return -1;
- }
-
- /* Weird case: buffering has suddenly been turned off.
- Return non-std value and deal with this case on the Haskell side.
- */
- if ( FILEOBJ_UNBUFFERED(fo) ) {
- return -3;
- }
-
- /* if input stream is connect to an output stream, flush this one first. */
- if ( fo->connectedTo != NULL &&
- fo->connectedTo->fd != -1 &&
- (fo->connectedTo->flags & FILEOBJ_WRITE)
- ) {
- rc = flushFile((StgForeignPtr)fo->connectedTo);
- }
- if (rc < 0) return (rc == FILEOBJ_BLOCKED_WRITE ? FILEOBJ_BLOCKED_CONN_WRITE : rc);
-
- /* RW object: flush the (output) buffer first. */
- if ( FILEOBJ_WRITEABLE(fo) && FILEOBJ_JUST_WRITTEN(fo) && FILEOBJ_NEEDS_FLUSHING(fo) ) {
- rc = flushBuffer(ptr);
- if (rc < 0) return rc;
- }
- fo->flags = (fo->flags & ~FILEOBJ_RW_WRITE) | FILEOBJ_RW_READ;
-
- /* return the unread parts of the file buffer..*/
- if ( fo->flags & FILEOBJ_READ &&
- fo->bufRPtr > 0 &&
- fo->bufWPtr > fo->bufRPtr ) {
- count = fo->bufWPtr - fo->bufRPtr;
- fo->bufRPtr=0;
- return count;
- }
-
-#if 0
- fprintf(stderr, "rb: %d %d %d\n", fo->bufRPtr, fo->bufWPtr, fo->bufSize);
-#endif
-
- while ((count =
- (
-#ifdef USE_WINSOCK
- fo->flags & FILEOBJ_WINSOCK ?
- recv(fd, fo->buf, fo->bufSize, 0) :
- read(fd, fo->buf, fo->bufSize))) <= 0 ) {
-#else
- read(fd, fo->buf, fo->bufSize))) <= 0 ) {
-#endif
- if ( count == 0 ) {
- FILEOBJ_SET_EOF(fo);
- ghc_errtype = ERR_EOF;
- ghc_errstr = "";
- return -1;
- } else if ( count == -1 && errno == EAGAIN) {
- errno = 0;
- return FILEOBJ_BLOCKED_READ;
- } else if ( count == -1 && errno != EINTR) {
- cvtErrno();
- stdErrno();
- return -1;
- }
- }
- fo->bufWPtr = count;
- fo->bufRPtr = 0;
- return count;
-}
-
-/* Filling up a (block-buffered) buffer of length len */
-
-/* readChunk(FileObjet *, void *, int)
- * returns:
- * -1 error
- * -2 object closed
- * FILEOBJ_BLOCKED_CONN_WRITE blocking while flushing
- * buffer of connected handle.
- * FILEOBJ_BLOCKED_READ didn't read anything; would block
- * n, where n > 0 read n bytes into buffer.
- * 0 EOF has been reached
- */
-
-StgInt
-readChunk(StgForeignPtr ptr, StgAddr buf, StgInt off, StgInt len)
-{
- IOFileObject* fo = (IOFileObject*)ptr;
- int count, rc=0, total_count=0;
- int fd;
- char* p;
-
- /* Check if someone hasn't zapped us */
- if ( fo == NULL )
- return -2;
-
- fd = fo->fd;
-
- if ( fd == -1 ) /* File has been closed for us */
- return -2;
-
- if ( FILEOBJ_IS_EOF(fo) ) {
- return 0;
- }
-
- /* if input stream is connect to an output stream, flush it first */
- if ( fo->connectedTo != NULL &&
- fo->connectedTo->fd != -1 &&
- (fo->connectedTo->flags & FILEOBJ_WRITE)
- ) {
- rc = flushFile((StgForeignPtr)fo->connectedTo);
- }
- if (rc < 0) return (rc == FILEOBJ_BLOCKED_WRITE ? FILEOBJ_BLOCKED_CONN_WRITE : rc);
-
- /* RW object: flush the (output) buffer first. */
- if ( FILEOBJ_WRITEABLE(fo) && FILEOBJ_JUST_WRITTEN(fo) && FILEOBJ_NEEDS_FLUSHING(fo) ) {
- rc = flushBuffer(ptr);
- if (rc < 0) return rc;
- }
- fo->flags = (fo->flags & ~FILEOBJ_RW_WRITE) | FILEOBJ_RW_READ;
-
- p = buf+off;
-
- /* copy the unread parts of the file buffer..*/
- if ( FILEOBJ_READABLE(fo) &&
- fo->bufRPtr > 0 &&
- fo->bufWPtr >= fo->bufRPtr ) {
-
- if (fo->bufWPtr - fo->bufRPtr >= len) {
- /* buffer has enough data to fulfill the request */
- memcpy(buf, fo->buf + fo->bufRPtr, len);
- fo->bufRPtr += len;
- return len;
- } else {
- /* can only partially fulfill the request from the buffer */
- count = fo->bufWPtr - fo->bufRPtr;
- memcpy(buf, fo->buf + fo->bufRPtr, count);
- fo->bufWPtr=0;
- fo->bufRPtr=0;
- len -= count;
- p += count;
- total_count = count;
- }
- }
-
- while ((count =
- (
-#ifdef USE_WINSOCK
- fo->flags & FILEOBJ_WINSOCK ?
- recv(fd, p, len, 0) :
- read(fd, p, len))) <= 0 ) {
-#else
- read(fd, p, len))) <= 0 ) {
-#endif
- /* EOF */
- if ( count == 0 ) {
- FILEOBJ_SET_EOF(fo);
- return total_count;
- }
-
- /* Blocking */
- else if ( count == -1 && errno == EAGAIN) {
- errno = 0;
- if (total_count > 0)
- return total_count; /* partial read */
- else
- return FILEOBJ_BLOCKED_READ;
- }
-
- /* Error */
- else if ( count == -1 && errno != EINTR) {
- cvtErrno();
- stdErrno();
- return -1;
- }
- }
-
- total_count += count;
- return total_count;
-}
-
-/*
- readLine() tries to fill the buffer up with a line of chars, returning
- the length of the resulting line.
-
- Users of readLine() should immediately afterwards copy out the line
- from the buffer.
-
-*/
-
-StgInt
-readLine(StgForeignPtr ptr)
-{
- IOFileObject* fo = (IOFileObject*)ptr;
- int rc=0, count;
-
- /* Check if someone hasn't zapped us */
- if ( fo == NULL || fo->fd == -1 )
- return -2;
-
- if ( FILEOBJ_IS_EOF(fo) ) {
- ghc_errtype = ERR_EOF;
- ghc_errstr = "";
- return -1;
- }
-
- /* Weird case: buffering has been turned off.
- Return non-std value and deal with this case on the Haskell side.
- */
- if ( FILEOBJ_UNBUFFERED(fo) ) {
- return -3;
- }
-
- /* if input stream is connect to an output stream, flush it first */
- if ( fo->connectedTo != NULL &&
- fo->connectedTo->fd != -1 &&
- (fo->connectedTo->flags & FILEOBJ_WRITE)
- ) {
- rc = flushFile((StgForeignPtr)fo->connectedTo);
- }
- if (rc < 0) return (rc == FILEOBJ_BLOCKED_WRITE ? FILEOBJ_BLOCKED_CONN_WRITE : rc);
-
- /* RW object: flush the (output) buffer first. */
- if ( FILEOBJ_WRITEABLE(fo) && FILEOBJ_JUST_WRITTEN(fo) ) {
- rc = flushBuffer(ptr);
- if (rc < 0) return rc;
- }
- fo->flags = (fo->flags & ~FILEOBJ_RW_WRITE) | FILEOBJ_RW_READ;
-
- if ( fo->bufRPtr < 0 || fo->bufRPtr >= fo->bufWPtr ) { /* Buffer is empty */
- fo->bufRPtr=0;
- fo->bufWPtr=0;
- rc = fill_up_line_buffer(fo);
- if (rc < 0) return rc;
- }
-
- while (1) {
- unsigned char* s1 = memchr((unsigned char *)fo->buf+fo->bufRPtr, '\n', fo->bufWPtr - fo->bufRPtr);
- if (s1 != NULL ) { /* Found one */
- /* Note: we *don't* zero terminate the line */
- count = s1 - ((unsigned char*)fo->buf + fo->bufRPtr) + 1;
- fo->bufRPtr += count;
- return count;
- } else {
- /* Just return partial line */
- count = fo->bufWPtr - fo->bufRPtr;
- fo->bufRPtr += count;
- return count;
- }
- }
-
-}
-
-StgInt
-readChar(StgForeignPtr ptr)
-{
- IOFileObject* fo= (IOFileObject*)ptr;
- int count,rc=0;
- unsigned char c;
-
- /* Check if someone hasn't zapped us */
- if ( fo == NULL || fo->fd == -1)
- return -2;
-
- if ( FILEOBJ_IS_EOF(fo) ) {
- ghc_errtype = ERR_EOF;
- ghc_errstr = "";
- return -1;
- }
-
- /* Buffering has been changed, report back */
- if ( FILEOBJ_LINEBUFFERED(fo) ) {
- return -3;
- } else if ( FILEOBJ_BLOCKBUFFERED(fo) ) {
- return -4;
- }
-
- /* if input stream is connect to an output stream, flush it first */
- if ( fo->connectedTo != NULL &&
- fo->connectedTo->fd != -1 &&
- (fo->connectedTo->flags & FILEOBJ_WRITE)
- ) {
- rc = flushFile((StgForeignPtr)fo->connectedTo);
- }
- if (rc < 0) return (rc == FILEOBJ_BLOCKED_WRITE ? FILEOBJ_BLOCKED_CONN_WRITE : rc);
-
- /* RW object: flush the (output) buffer first. */
- if ( FILEOBJ_WRITEABLE(fo) && FILEOBJ_JUST_WRITTEN(fo) && FILEOBJ_NEEDS_FLUSHING(fo) ) {
- rc = flushBuffer(ptr);
- if (rc < 0) return rc;
- }
- fo->flags = (fo->flags & ~FILEOBJ_RW_WRITE) | FILEOBJ_RW_READ;
-
- while ( (count =
- (
-#ifdef USE_WINSOCK
- fo->flags & FILEOBJ_WINSOCK ?
- recv(fo->fd, &c, 1, 0) :
- read(fo->fd, &c, 1))) <= 0 ) {
-#else
- read(fo->fd, &c, 1))) <= 0 ) {
-#endif
- if ( count == 0 ) {
- ghc_errtype = ERR_EOF;
- ghc_errstr = "";
- return -1;
- } else if ( count == -1 && errno == EAGAIN) {
- errno = 0;
- return FILEOBJ_BLOCKED_READ;
- } else if ( count == -1 && errno != EINTR) {
- cvtErrno();
- stdErrno();
- return -1;
- }
- }
-
- if ( isatty(fo->fd) && c == EOT ) {
- return EOF;
- } else {
- return (int)c;
- }
-}
+++ /dev/null
-/*
- * (c) The GRASP/AQUA Project, Glasgow University, 1994-1998
- *
- * $Id: seekFile.c,v 1.7 2001/04/02 16:10:33 rrt Exp $
- *
- * hSeek and hIsSeekable Runtime Support
- */
-
-#include "Rts.h"
-#include "stgio.h"
-
-#ifdef HAVE_SYS_TYPES_H
-#include <sys/types.h>
-#endif
-
-#ifdef HAVE_SYS_STAT_H
-#include <sys/stat.h>
-#endif
-
-/* Invoked by IO.hSeek only */
-StgInt
-seekFile(StgForeignPtr ptr, StgInt whence, StgInt size, StgByteArray d)
-{
- IOFileObject* fo = (IOFileObject*)ptr;
- struct stat sb;
- off_t offset;
- int posn_delta =0;
- int rc = 0;
-
- switch (whence) {
- case 0: whence=SEEK_SET; break;
- case 1: whence=SEEK_CUR; break;
- case 2: whence=SEEK_END; break;
- default: whence=SEEK_SET; /* Should never happen, really */
- }
-
- /*
- * We need to snatch the offset out of an MP_INT. The bits are there sans sign,
- * which we pick up from our size parameter. If abs(size) is greater than 1,
- * this integer is just too big.
- */
-
- switch (size) {
- case -1:
- offset = -*(StgInt *) d;
- break;
- case 0:
- offset = 0;
- break;
- case 1:
- offset = *(StgInt *) d;
- break;
- default:
- ghc_errtype = ERR_INVALIDARGUMENT;
- ghc_errstr = "offset out of range";
- return -1;
- }
-
- /* If we're doing a relative seek, see if we cannot deal
- * with the request without flushing the buffer..
- *
- * Note: the wording in the report is vague here, but
- * we only avoid flushing on *input* buffers and *not* output ones.
- */
- if ( whence == SEEK_CUR &&
- (FILEOBJ_READABLE(fo) && !FILEOBJ_WRITEABLE(fo) &&
- (fo->bufRPtr + (int)offset) < fo->bufWPtr &&
- (fo->bufRPtr + (int)offset) >= 0) ) { /* The input buffer case */
- fo->bufRPtr += (int)offset;
- return 0;
- } else if ( whence == SEEK_CUR && (FILEOBJ_READABLE(fo) && !FILEOBJ_WRITEABLE(fo)) ) {
- /* We're seeking outside the input buffer,
- record delta so that we can adjust the file position
- reported from the underlying fd to get
- at the real position we're at when we take into account
- buffering.
- */
- posn_delta = fo->bufWPtr - fo->bufRPtr; /* number of chars left in the buffer */
- if (posn_delta < 0) posn_delta=0;
- }
-
- /* If we cannot seek within our current buffer, flush it. */
- rc = flushBuffer(ptr);
- if (rc < 0) return rc;
-
- /* Try to find out the file type */
- while (fstat(fo->fd, &sb) < 0) {
- /* highly unlikely */
- if (errno != EINTR) {
- cvtErrno();
- stdErrno();
- return -1;
- }
- }
- if (S_ISFIFO(sb.st_mode)) {
- ghc_errtype = ERR_UNSUPPORTEDOPERATION;
- ghc_errstr = "can't seek on a pipe";
- return -1;
- }
- while ( lseek(fo->fd, offset-posn_delta, whence) == -1) {
- if (errno != EINTR) {
- cvtErrno();
- stdErrno();
- return -1;
- }
- }
- /* Clear EOF */
- FILEOBJ_CLEAR_EOF(fo);
- return 0;
-}
-
-/* Invoked by IO.hSeek only */
-StgInt
-seekFile_int64(StgForeignPtr ptr, StgInt whence, StgInt64 d)
-{
- IOFileObject* fo = (IOFileObject*)ptr;
- struct stat sb;
- off_t offset = d;
- int posn_delta =0;
- int rc = 0;
-
- switch (whence) {
- case 0: whence=SEEK_SET; break;
- case 1: whence=SEEK_CUR; break;
- case 2: whence=SEEK_END; break;
- default: whence=SEEK_SET; break; /* Should never happen, really */
- }
-
- /* If we're doing a relative seek, see if we cannot deal
- * with the request without flushing the buffer..
- *
- * Note: the wording in the report is vague here, but
- * we only avoid flushing on *input* buffers and *not* output ones.
- */
- if ( whence == SEEK_CUR &&
- (FILEOBJ_READABLE(fo) && !FILEOBJ_WRITEABLE(fo) &&
- (fo->bufRPtr + (int)offset) < fo->bufWPtr &&
- (fo->bufRPtr + (int)offset) >= 0) ) { /* The input buffer case */
- fo->bufRPtr += (int)offset;
- return 0;
- } else if ( whence == SEEK_CUR && (FILEOBJ_READABLE(fo) && !FILEOBJ_WRITEABLE(fo)) ) {
- /* We're seeking outside the input buffer,
- record delta so that we can adjust the file position
- reported from the underlying fd to get
- at the real position we're at when we take into account
- buffering.
- */
- posn_delta = fo->bufWPtr - fo->bufRPtr; /* number of chars left in the buffer */
- if (posn_delta < 0) posn_delta=0;
- }
-
- /* If we cannot seek within our current buffer, flush it. */
- rc = flushBuffer(ptr);
- if (rc < 0) return rc;
-
- /* Try to find out the file type & size for a physical file */
- while (fstat(fo->fd, &sb) < 0) {
- /* highly unlikely */
- if (errno != EINTR) {
- cvtErrno();
- stdErrno();
- return -1;
- }
- }
- if (S_ISFIFO(sb.st_mode)) {
- ghc_errtype = ERR_UNSUPPORTEDOPERATION;
- ghc_errstr = "can't seek on a pipe";
- return -1;
- }
- while ( lseek(fo->fd, offset-posn_delta, whence) == -1) {
- if (errno != EINTR) {
- cvtErrno();
- stdErrno();
- return -1;
- }
- }
- /* Clear EOF */
- FILEOBJ_CLEAR_EOF(fo);
- return 0;
-}
-
-StgInt
-seekFileP(StgForeignPtr ptr)
-{
- IOFileObject* fo = (IOFileObject*)ptr;
- struct stat sb;
-
- /* Try to find out the file type */
- while (fstat(fo->fd, &sb) < 0) {
- /* highly unlikely */
- if (errno != EINTR) {
- cvtErrno();
- stdErrno();
- return -1;
- }
- }
- /* Pipes are not okay.. */
- if (S_ISFIFO(sb.st_mode)) {
- return 0;
- }
- /* ..for now, everything else is */
- else {
- return 1;
- }
-}
+++ /dev/null
-/*
- * (c) The GRASP/AQUA Project, Glasgow University, 1999
- *
- * $Id: setBinaryMode.c,v 1.1 1999/09/19 19:27:10 sof Exp $
- *
- * hSetBinaryMode runtime support
- */
-
-#include "Rts.h"
-#include "stgio.h"
-
-#ifdef HAVE_FCNTL_H
-#include <fcntl.h>
-#endif
-
-#ifdef _WIN32
-#include <io.h>
-#endif
-
-StgInt
-setBinaryMode__(ptr,flg)
-StgForeignPtr ptr;
-StgInt flg;
-{
- IOFileObject* fo = (IOFileObject*)ptr;
- int rc;
-
- rc = flushBuffer(ptr);
- if (rc < 0) return rc;
-
-#ifdef _WIN32
- setmode ( fo->fd, flg ? O_BINARY : O_TEXT );
-#endif
- rc = (fo->flags & FILEOBJ_BINARY ? 1 : 0);
- fo->flags = fo->flags & (flg ? FILEOBJ_BINARY : ~FILEOBJ_BINARY);
-
- return rc;
-}
+++ /dev/null
-/*
- * (c) The GRASP/AQUA Project, Glasgow University, 1994-1998
- *
- * $Id: setBuffering.c,v 1.12 2001/04/02 16:10:33 rrt Exp $
- *
- * hSetBuffering Runtime Support
- */
-
-#include "Rts.h"
-#include "stgio.h"
-
-#ifdef HAVE_SYS_TYPES_H
-#include <sys/types.h>
-#endif
-
-#ifdef HAVE_SYS_STAT_H
-#include <sys/stat.h>
-#endif
-
-#ifdef HAVE_TERMIOS_H
-#include <termios.h>
-#endif
-
-#ifdef HAVE_FCNTL_H
-#include <fcntl.h>
-#endif
-
-#define SB_NB (0)
-#define SB_LB (-1)
-#define SB_BB (-2)
-
-StgInt
-setBuffering(StgForeignPtr ptr, StgInt size)
-{
- IOFileObject* fo = (IOFileObject*)ptr;
- int flags, rc=0;
- int input, isaterm;
-#ifndef mingw32_TARGET_OS
- struct termios tio;
-#endif
- struct stat sb;
-
- /* First off, flush old buffer.. */
- if ( (fo->flags & FILEOBJ_WRITE) ) {
- rc = flushBuffer(ptr);
- }
- if (rc<0) return rc;
-
- /* Let go of old buffer, and reset buffer pointers. */
- if ( fo->buf != NULL ) {
- free(fo->buf);
- fo->bufWPtr = 0;
- fo->bufRPtr = 0;
- fo->bufSize = 0;
- fo->buf = NULL;
- }
-
-#ifndef mingw32_TARGET_OS
- while ((flags = fcntl(fo->fd, F_GETFL)) < 0) {
- if (errno != EINTR) {
- cvtErrno();
- stdErrno();
- return -1;
- }
- }
- flags &= O_ACCMODE;
- input = flags == O_RDONLY || flags == O_RDWR;
-
- isaterm = input && isatty(fo->fd);
-#endif
-
- switch (size) {
- case SB_NB:
- fo->flags &= ~FILEOBJ_LB & ~FILEOBJ_BB;
-
-#ifndef mingw32_TARGET_OS
- if (isaterm) {
- /* Switch over to canonical mode. */
- if (tcgetattr(fo->fd, &tio) < 0) {
- cvtErrno();
- stdErrno();
- return -1;
- }
- tio.c_lflag &= ~ICANON;
- tio.c_cc[VMIN] = 1;
- tio.c_cc[VTIME] = 0;
- if (tcSetAttr(fo->fd, TCSANOW, &tio) < 0) {
- cvtErrno();
- stdErrno();
- return -1;
- }
- }
-#endif
- return 0;
- case SB_LB:
- fo->flags &= ~FILEOBJ_BB;
- fo->flags |= FILEOBJ_LB;
- size = BUFSIZ;
- break;
- case SB_BB:
-
-#ifdef HAVE_ST_BLKSIZE
- while (fstat(fo->fd, &sb) < 0) {
- /* not very likely.. */
- if ( errno != EINTR ) {
- cvtErrno();
- stdErrno();
- return -1;
- }
- }
- size = sb.st_blksize;
-#else
- size = BUFSIZ;
-#endif
- fo->flags &= ~FILEOBJ_LB;
- fo->flags |= FILEOBJ_BB;
- /* fall through */
- default:
- break;
- }
-
- if ( size > 0) {
- fo->buf = malloc(size*sizeof(char));
- if (fo->buf == NULL) {
- return -1;
- }
- }
- fo->bufSize = size;
-#ifndef mingw32_TARGET_OS
- if (isaterm) {
-
- /*
- * Try to switch back to cooked mode.
- */
-
- if (tcgetattr(fo->fd, &tio) < 0) {
- cvtErrno();
- stdErrno();
- return -1;
- }
- tio.c_lflag |= ICANON;
- if (tcSetAttr(fo->fd, TCSANOW, &tio) < 0) {
- cvtErrno();
- stdErrno();
- return -1;
- }
- }
-#endif
- return 0;
-}
-
-StgInt const_BUFSIZ() { return BUFSIZ; }
-
/*
* (c) The GRASP/AQUA Project, Glasgow University, 1994-1998
*
- * $Id: system.c,v 1.11 2001/02/20 03:41:31 qrczak Exp $
+ * $Id: system.c,v 1.12 2001/05/18 16:54:06 simonmar Exp $
*
* system Runtime Support
*/
/* The itimer stuff in this module is non-posix */
#define NON_POSIX_SOURCE
-#include "Rts.h"
-#include "stgio.h"
+#include "HsStd.h"
-#ifdef HAVE_UNISTD_H
-#include <unistd.h>
-#endif
-
-#if TIME_WITH_SYS_TIME
-# include <sys/time.h>
-# include <time.h>
-#else
-# if HAVE_SYS_TIME_H
-# include <sys/time.h>
-# else
-# include <time.h>
-# endif
-#endif
-
-#ifndef mingw32_TARGET_OS
-# ifdef HAVE_SYS_WAIT_H
-# include <sys/wait.h>
-# endif
-#else
-# include <windows.h> /* for Sleep */
-#endif
-
-#ifdef HAVE_VFORK_H
-#include <vfork.h>
-#endif
-
-#ifdef HAVE_VFORK
-#define fork vfork
-#endif
-
-StgInt
-systemCmd(StgByteArray cmd)
+HsInt
+systemCmd(HsAddr cmd)
{
#if defined(mingw32_TARGET_OS)
/* There's no fork() under Windows, so we fall back on using libc's
switch(pid = fork()) {
case -1:
if (errno != EINTR) {
- cvtErrno();
- stdErrno();
return -1;
}
case 0:
while (waitpid(pid, &wstat, 0) < 0) {
if (errno != EINTR) {
- cvtErrno();
- stdErrno();
return -1;
}
}
if (WIFEXITED(wstat))
return WEXITSTATUS(wstat);
else if (WIFSIGNALED(wstat)) {
- ghc_errtype = ERR_INTERRUPTED;
- ghc_errstr = "system command interrupted";
+ errno = EINTR;
}
else {
/* This should never happen */
- ghc_errtype = ERR_OTHERERROR;
- ghc_errstr = "internal error (process neither exited nor signalled)";
}
return -1;
#endif
+++ /dev/null
-/*
- * (c) The GHC Team 2001
- *
- * $Id: tcSetAttr.c,v 1.2 2001/01/26 17:51:40 rrt Exp $
- *
- * A wrapper around tcsetattr() which works for a background process.
- */
-
-#include "Rts.h"
-#include "stgio.h"
-
-#ifdef HAVE_SIGNAL_H
-#include <signal.h>
-#endif
-
-#ifdef HAVE_TERMIOS_H
-#include <termios.h>
-#endif
-
-#ifdef HAVE_UNISTD_H
-#include <unistd.h>
-#endif
-
-#ifndef mingw32_TARGET_OS
-/* tcsetattr() when invoked by a background process causes the process
- * to be sent SIGTTOU regardless of whether the process has TOSTOP set
- * in its terminal flags (try it...). This function provides a
- * wrapper which temporarily blocks SIGTTOU around the call, making it
- * transparent. */
-int
-tcSetAttr( int fd, int options, const struct termios *tp )
-{
- int res;
- sigset_t block_ttou, old_sigset;
-
- sigemptyset (&block_ttou);
- sigaddset (&block_ttou, SIGTTOU);
- sigprocmask(SIG_BLOCK, &block_ttou, &old_sigset);
- res = tcsetattr(fd, options, tp);
- sigprocmask(SIG_SETMASK, &old_sigset, NULL);
-
- return res;
-}
-#else
-#define tcSetAttr(f,o,t) tcsetattr((f),(o),(t))
-#endif
/*
* (c) The GRASP/AQUA Project, Glasgow University, 1998
*
- * $Id: writeError.c,v 1.5 2000/05/01 14:44:25 panne Exp $
+ * $Id: writeError.c,v 1.6 2001/05/18 16:54:07 simonmar Exp $
*
* hPutStr Runtime Support
*/
#include "Rts.h"
#include "RtsUtils.h"
-#include "stgio.h"
+#include "HsStd.h"
-#ifdef HAVE_FCNTL_H
-#include <fcntl.h>
-#endif
-
-StgAddr
+HsAddr
addrOf_ErrorHdrHook(void)
{
return &ErrorHdrHook;
}
void
-writeErrString__ (msg_hdr, msg, len)
-StgAddr msg_hdr;
-StgByteArray msg;
-StgInt len;
+writeErrString__ (HsAddr msg_hdr, HsAddr msg, HsInt len)
{
int count = 0;
char* p = (char*)msg;
+++ /dev/null
-/*
- * (c) The GRASP/AQUA Project, Glasgow University, 1994-1998
- *
- * $Id: writeFile.c,v 1.14 2000/04/12 17:33:16 simonmar Exp $
- *
- * hPutStr Runtime Support
- */
-
-#include "Rts.h"
-#include "stgio.h"
-
-#if defined(HAVE_WINSOCK_H) && !defined(__CYGWIN__) && !defined(__CYGWIN32__)
-#define USE_WINSOCK
-#endif
-
-#ifdef USE_WINSOCK
-#include <winsock.h>
-#endif
-
-StgInt
-writeFileObject(StgForeignPtr ptr, StgInt bytes)
-{
- int rc=0;
- IOFileObject* fo = (IOFileObject*)ptr;
-
- /* If we've got a r/w file object in our hand, flush the
- (input) buffer contents first.
- */
- if ( FILEOBJ_READABLE(fo) && FILEOBJ_JUST_READ(fo) ) {
- fo->flags = (fo->flags & ~FILEOBJ_RW_READ) | FILEOBJ_RW_WRITE;
- rc = flushReadBuffer(ptr);
- if (rc < 0) return rc;
- }
-
- return (writeBuffer(ptr, bytes));
-}
-
-StgInt
-writeBuffer(StgForeignPtr ptr, StgInt bytes)
-{
- int count;
- IOFileObject* fo = (IOFileObject*)ptr;
-
- char *pBuf = (char *) fo->buf + fo->bufRPtr;
-
- bytes -= fo->bufRPtr;
-
- /* Disallow short writes */
- if (bytes == 0 || fo->buf == NULL) {
- fo->bufRPtr = 0;
- return 0;
- }
-
- while ((count =
- (
-#ifdef USE_WINSOCK
- fo->flags & FILEOBJ_WINSOCK ?
- send(fo->fd, pBuf, bytes, 0) :
- write(fo->fd, pBuf, bytes))) < bytes) {
-#else
- write(fo->fd, pBuf, bytes))) < bytes) {
-#endif
- if ( count == -1 && errno == EAGAIN) {
- errno = 0;
- return FILEOBJ_BLOCKED_WRITE;
- }
- else if ( count == -1 && errno != EINTR ) {
- cvtErrno();
- stdErrno();
- return -1;
- }
- else {
- bytes -= count;
- pBuf += count;
- fo->bufRPtr += count;
- }
- }
- /* Signal that we've emptied the buffer */
- fo->bufRPtr = 0;
- fo->bufWPtr = 0;
- return 0;
-}
-
-
-/* ToDo: there's currently no way for writeBuf to return both a
- * partial write and an indication that the write blocked. It needs
- * two calls: one to get the partial result, and the next one to block.
- * This matches Unix write/2, but is rather a waste.
- */
-
-StgInt
-writeBuf(StgForeignPtr ptr, StgAddr buf, StgInt off, StgInt len)
-{
- IOFileObject* fo = (IOFileObject*)ptr;
- int count, total_count;
- int rc = 0;
- char *pBuf = (char *) buf+off;
-
- if (len == 0)
- return 0;
-
- /* First of all, check if we do need to flush the buffer .. */
- /* Note - in the case of line buffering, we do not currently check
- whether we need to flush buffer due to line terminators in the
- buffer we're outputting */
- if ( fo->buf != NULL && /* buffered and */
- (fo->bufWPtr + len < (fo->bufSize)) /* there's room */
- ) {
- /* Block copying is likely to be cheaper than flush, followed by write */
- memcpy(((char*)fo->buf + fo->bufWPtr), pBuf, len);
- fo->bufWPtr += len;
- return len;
- }
- /* If we do overflow, flush current contents of the buffer and
- directly output the chunk.
- (no attempt at splitting up the chunk is currently made)
- */
- if ( fo->buf != NULL && /* buffered and */
- (fo->bufWPtr + len >= (fo->bufSize)) /* there's not room */
- ) {
- /* Flush buffer */
- rc = writeFileObject(ptr, fo->bufWPtr);
- /* ToDo: undo buffer fill if we're blocking.. */
- if (rc != 0) {
- return rc;
- }
- }
-
- total_count = 0;
-
- while ((count =
- (
-#ifdef USE_WINSOCK
- fo->flags & FILEOBJ_WINSOCK ?
- send(fo->fd, pBuf, (int)len, 0) :
- write(fo->fd, pBuf, (int)len))) < len ) {
-#else
- write(fo->fd, pBuf, (int)len))) < len ) {
-#endif
- if ( count >= 0 ) {
- len -= count;
- pBuf += count;
- total_count += count;
- continue;
- } else if ( errno == EAGAIN ) {
- errno = 0;
- if (total_count > 0)
- return total_count; /* partial write */
- else
- return FILEOBJ_BLOCKED_WRITE;
- } else if ( errno != EINTR ) {
- cvtErrno();
- stdErrno();
- return -1;
- }
- }
-
- total_count += count;
- return total_count;
-}
-
-StgInt
-writeBufBA(StgForeignPtr ptr, StgByteArray buf, StgInt off, StgInt len)
-{
- return (writeBuf(ptr,(StgAddr)buf, off, len));
-}
-
-/* -----------------------------------------------------------------------------
- * write_ is just a simple wrapper around write/2 that restarts
- * on EINTR and returns FILEOBJ_BLOCKED_WRITE on EAGAIN.
- * -------------------------------------------------------------------------- */
-
-StgInt
-write_(StgForeignPtr ptr, StgAddr buf, StgInt len)
-{
- IOFileObject* fo = (IOFileObject*)ptr;
- int rc;
-
- while ((rc =
- (
-#ifdef USE_WINSOCK
- fo->flags & FILEOBJ_WINSOCK ?
- send(fo->fd, buf, (int)len, 0) :
- write(fo->fd, buf, (int)len))) < 0 ) {
-#else
- write(fo->fd, buf, (int)len))) < 0 ) {
-#endif
- if ( errno == EAGAIN ) {
- errno = 0;
- return FILEOBJ_BLOCKED_WRITE;
- } else if ( errno != EINTR ) {
- cvtErrno();
- stdErrno();
- return -1;
- }
- }
- return rc;
-}
t (T i) = i + 1
-- test 2: mutual recursion (should back off from unboxing either field)
-data R = R !R
-data S = S !S
+data R = R !S
+data S = S !R
r (R s) = s
l F{x = a} = a
m (F a b c) = a
n F{z = (a,b)} = a
+
+-- test 7: newtypes
+newtype G a b = G (F a b)
+data H a b = H !Int !(G a b) !Int
+o (H y (G (F{ x=x })) z) = x + z
+++ /dev/null
-main = putStr "Hello, world\n"
+++ /dev/null
-import IO
-
-main =
- openFile "io007.hs" ReadMode >>= \ hIn ->
- hPutStr hIn "test" `catch`
- \ err ->
- if isIllegalOperation err then
- hGetContents hIn >>= \ stuff ->
- hPutStr stdout stuff
- else
- error "Oh dear\n"
+++ /dev/null
-import IO
-
-main =
- openFile "io007.hs" ReadMode >>= \ hIn ->
- hPutStr hIn "test" `catch`
- \ err ->
- if isIllegalOperation err then
- hGetContents hIn >>= \ stuff ->
- hPutStr stdout stuff
- else
- error "Oh dear\n"
+++ /dev/null
--- !!! Test seeking
-
-import IO
-
-main = do
- h <- openFile "io013.in" ReadMode
- sz <- hFileSize h
- print sz
- hSeek h SeekFromEnd (-3)
- x <- hGetChar h
- putStr (x:"\n")
- hSeek h RelativeSeek (-2)
- w <- hGetChar h
- putStr (w:"\n")
- True <- hIsSeekable h
- hClose h
-
+++ /dev/null
-import IO
-
-main =
- isEOF >>= \ eof ->
- if eof then
- return ()
- else
- getChar >>= \ c ->
- putChar c >>
- main
+++ /dev/null
-import IO
-
-import System (getArgs)
-import Char (toUpper)
-import Directory (removeFile, doesFileExist)
-
-main = getArgs >>= \ [f1,f2] ->
- openFile f1 ReadMode >>= \ h1 ->
- doesFileExist f2 >>= \ f ->
- if f then removeFile f2 else return () >>
- openFile f2 WriteMode >>= \ h2 ->
- copyFile h1 h2 >>
- hClose h1 >>
- hClose h2
-
-copyFile h1 h2 =
- hIsEOF h1 >>= \ eof ->
- if eof then
- return ()
- else
- hGetChar h1 >>= \ c ->
- hPutChar h2 (toUpper c) >>
- copyFile h1 h2
-
+++ /dev/null
-import IO
-
-main =
- hSetBuffering stdout NoBuffering >>
- putStr "Enter an integer: " >>
- readLine >>= \ x1 ->
- putStr "Enter another integer: " >>
- readLine >>= \ x2 ->
- putStr ("Their sum is " ++ show (read x1 + read x2 :: Int) ++ "\n")
-
- where readLine = isEOF >>= \ eof ->
- if eof then return []
- else getChar >>= \ c ->
- if c `elem` ['\n','\r'] then
- return []
- else
- readLine >>= \ cs ->
- return (c:cs)
-
+++ /dev/null
-Smoewnst pa ihyu
-Caught EOF
-S-m-o e!w!n
-Caught EOF
-S-m-o e!w!n!s tT epsat iinhgy uR!s tT epsat iinhgy uRW handles
-module Main(main) where
-
-import IO
-import IOExts
-import Directory (removeFile, doesFileExist)
-import Monad
-
--- This test is weird, full marks to whoever dreamt it up!
-
-main :: IO ()
-main = do
- let username = "io018.inout"
- f <- doesFileExist username
- when f (removeFile username)
- cd <- openFile username ReadWriteMode
- hSetBinaryMode cd True
- hSetBuffering stdin NoBuffering
- hSetBuffering stdout NoBuffering
- hSetBuffering cd NoBuffering
- hPutStr cd speakString
- hSeek cd AbsoluteSeek 0
- speak cd `catch` \ err -> if isEOFError err then putStrLn "\nCaught EOF" else ioError err
- hSeek cd AbsoluteSeek 0
- hSetBuffering cd LineBuffering
- speak cd `catch` \ err -> if isEOFError err then putStrLn "\nCaught EOF" else ioError err
- hSeek cd AbsoluteSeek 0
- hSetBuffering cd (BlockBuffering Nothing)
- speak cd `catch` \ err -> if isEOFError err then putStrLn "\nCaught EOF" else ioError err
-
-speakString = "Someone wants to speak with you\n"
-
-speak cd = do
- (do
- ready <- hReady cd
- if ready then
- hGetChar cd >>= putChar
- else
- return ()
- ready <- hReady stdin
- if ready then (do { ch <- ge
-Caught EOF
+++ /dev/null
-Hello
\ No newline at end of file
+++ /dev/null
--- !!! isEOF
-module Main(main) where
-
-import IO ( isEOF )
-
-main = do
- flg <- isEOF
- print flg
-
-
+++ /dev/null
-illegal operation
-Action: hGetChar
-Handle: {loc=stdin,type=semi-closed,buffering=block (8192)}
-
-Reason: handle is closed
-illegal operation
-Action: hGetChar
-Handle: {loc=stdin,type=semi-closed,buffering=block (8192)}
-
-Reason: handle is closed
--- /dev/null
+illegal operation
+Action: hGetChar
+Handle: {loc=<stdin>,type=semi-closed,buffering=block (8192)}
+File: <stdin>
+illegal operation
+Action: hGetChar
+Handle: {loc=<stdin>,type=semi-closed,buffering=block (8192)}
+File: <stdin>
--- /dev/null
+# -----------------------------------------------------------------------------
+# $Id: Makefile,v 1.1 2001/05/18 16:54:08 simonmar Exp $
+
+TOP = ../..
+
+include $(TOP)/mk/boilerplate.mk
+
+ifeq "$(TARGETPLATFORM)" "i386-unknown-mingw32"
+# io018 should run
+OMITTED_RUNTESTS = io005.run io018.run io033.run
+endif
+
+include $(TOP)/mk/should_run.mk
+
+SRC_HC_OPTS += -dcore-lint
+
+hSetBuffering002_RUNTEST_OPTS += -i hSetBuffering002.hs
+hSetBuffering003_RUNTEST_OPTS += -i hSetBuffering003.hs
+misc001_RUNTEST_OPTS += misc001.hs misc001.out
+hGetChar001_RUNTEST_OPTS += -i hGetChar001.stdin
+openFile002_RUNTEST_OPTS += -x 1
+IOError001_RUNTEST_OPTS += -o1 IOError001.stdout-mingw
+readwrite002_RUNTEST_OPTS += -i readwrite002.hs
+hGetLine001_RUNTEST_OPTS += -i hGetLine001.hs
+
+.PRECIOUS: %.o %.bin
+
+CLEAN_FILES += *.out* *.inout
+
+include $(TOP)/mk/target.mk
doTest :: IO ()
doTest = do
- sd <- openFile "io033.hs" ReadWriteMode
+ sd <- openFile "finalization001.hs" ReadWriteMode
result <- hGetContents sd
slurp result
hClose sd
--- /dev/null
+import IO
+
+-- !!! test hFileSize
+
+main = do
+ h <- openFile "hFileSize001.hs" ReadMode
+ sz <- hFileSize h
+ print sz
main = do
sz <- hFileSize stdin `catch` (\ _ -> return (-1))
print sz
- let fn = "io025.out"
+ let fn = "hFileSize002.out"
f <- doesFileExist fn
when f (removeFile fn)
hdl <- openFile fn WriteMode
hFlush stdout
putStr "Hello - "
hFlush stderr
- hdl <- openFile "io029.hs" ReadMode
+ hdl <- openFile "hFlush001.hs" ReadMode
hFlush hdl `catch` \ _ -> putStrLn "No can do - flushing read-only handles isn't legal"
hClose hdl
remove
- hdl <- openFile "io029.out" WriteMode
+ hdl <- openFile "hFlush001.out" WriteMode
hFlush hdl
hClose hdl
remove
- hdl <- openFile "io029.out" AppendMode
+ hdl <- openFile "hFlush001.out" AppendMode
hFlush hdl
hClose hdl
remove
- hdl <- openFile "io029.out" ReadWriteMode
+ hdl <- openFile "hFlush001.out" ReadWriteMode
hFlush hdl
hClose hdl
where remove = do
- f <- doesFileExist "io029.out"
- when f (removeFile "io029.out")
+ f <- doesFileExist "hFlush001.out"
+ when f (removeFile "hFlush001.out")
--- /dev/null
+import IO
+
+main = do
+ hSetBuffering stdout NoBuffering
+ putStr "Enter an integer: "
+ x1 <- readLine
+ putStr "Enter another integer: "
+ x2 <- readLine
+ putStr ("Their sum is " ++ show (read x1 + read x2 :: Int) ++ "\n")
+
+ where readLine = do
+ eof <- isEOF
+ if eof then return [] else do
+ c <- getChar
+ if c `elem` ['\n','\r']
+ then return []
+ else do cs <- readLine
+ return (c:cs)
--- /dev/null
+-- !!! testing hGetLine
+
+import IO
+
+-- one version of 'cat'
+main = do
+ let loop h = do b <- hIsEOF h
+ if b then return ()
+ else do l <- hGetLine h; putStrLn l; loop h
+ loop stdin
+
+ h <- openFile "hGetLine001.hs" ReadMode
+ hSetBuffering h NoBuffering
+ loop h
+
+ hSeek h AbsoluteSeek 0
+ hSetBuffering h LineBuffering
+ loop h
+
+ hSeek h AbsoluteSeek 0
+ hSetBuffering h (BlockBuffering (Just 83))
+ loop h
--- /dev/null
+-- !!! testing hGetLine
+
+import IO
+
+-- one version of 'cat'
+main = do
+ let loop h = do b <- hIsEOF h
+ if b then return ()
+ else do l <- hGetLine h; putStrLn l; loop h
+ loop stdin
+
+ h <- openFile "hGetLine001.hs" ReadMode
+ hSetBuffering h NoBuffering
+ loop h
+
+ hSeek h AbsoluteSeek 0
+ hSetBuffering h LineBuffering
+ loop h
+
+ hSeek h AbsoluteSeek 0
+ hSetBuffering h (BlockBuffering (Just 83))
+ loop h
+-- !!! testing hGetLine
+
+import IO
+
+-- one version of 'cat'
+main = do
+ let loop h = do b <- hIsEOF h
+ if b then return ()
+ else do l <- hGetLine h; putStrLn l; loop h
+ loop stdin
+
+ h <- openFile "hGetLine001.hs" ReadMode
+ hSetBuffering h NoBuffering
+ loop h
+
+ hSeek h AbsoluteSeek 0
+ hSetBuffering h LineBuffering
+ loop h
+
+ hSeek h AbsoluteSeek 0
+ hSetBuffering h (BlockBuffering (Just 83))
+ loop h
+-- !!! testing hGetLine
+
+import IO
+
+-- one version of 'cat'
+main = do
+ let loop h = do b <- hIsEOF h
+ if b then return ()
+ else do l <- hGetLine h; putStrLn l; loop h
+ loop stdin
+
+ h <- openFile "hGetLine001.hs" ReadMode
+ hSetBuffering h NoBuffering
+ loop h
+
+ hSeek h AbsoluteSeek 0
+ hSetBuffering h LineBuffering
+ loop h
+
+ hSeek h AbsoluteSeek 0
+ hSetBuffering h (BlockBuffering (Just 83))
+ loop h
+-- !!! testing hGetLine
+
+import IO
+
+-- one version of 'cat'
+main = do
+ let loop h = do b <- hIsEOF h
+ if b then return ()
+ else do l <- hGetLine h; putStrLn l; loop h
+ loop stdin
+
+ h <- openFile "hGetLine001.hs" ReadMode
+ hSetBuffering h NoBuffering
+ loop h
+
+ hSeek h AbsoluteSeek 0
+ hSetBuffering h LineBuffering
+ loop h
+
+ hSeek h AbsoluteSeek 0
+ hSetBuffering h (BlockBuffering (Just 83))
+ loop h
import Directory (removeFile, doesFileExist)
main = do
- hIn <- openFile "io008.in" ReadMode
- f <- doesFileExist "io008.out"
- when f (removeFile "io008.out")
- hOut <- openFile "io008.out" ReadWriteMode
+ hIn <- openFile "hGetPosn001.in" ReadMode
+ f <- doesFileExist "hGetPosn001.out"
+ when f (removeFile "hGetPosn001.out")
+ hOut <- openFile "hGetPosn001.out" ReadWriteMode
bof <- hGetPosn hIn
copy hIn hOut
hSetPosn bof
-- !!! hIsEOF (on stdout)
-module Main(main) where
import IO ( hIsEOF, stdout )
--- /dev/null
+-- !!! test hIsEOF in various buffering situations
+
+import IO
+
+main = do
+ h <- openFile "hIsEOF002.hs" ReadMode
+ hSetBuffering h NoBuffering
+ hSeek h SeekFromEnd 0
+ hIsEOF h >>= print
+ hSeek h SeekFromEnd (-1)
+ hIsEOF h >>= print
+ hGetChar h >>= print
+
+ hSetBuffering h LineBuffering
+ hSeek h SeekFromEnd 0
+ hIsEOF h >>= print
+ hSeek h SeekFromEnd (-1)
+ hIsEOF h >>= print
+ hGetChar h >>= print
+
+ hSetBuffering h (BlockBuffering (Just 1))
+ hSeek h SeekFromEnd 0
+ hIsEOF h >>= print
+ hSeek h SeekFromEnd (-1)
+ hIsEOF h >>= print
+ hGetChar h >>= print
+
+ hSetBuffering h (BlockBuffering Nothing)
+ hSeek h SeekFromEnd 0
+ hIsEOF h >>= print
+ hSeek h SeekFromEnd (-1)
+ hIsEOF h >>= print
+ hGetChar h >>= print
+ hClose h
+
+ h <- openFile "hIsEOF002.out" WriteMode
+ hPutStrLn h "hello, world"
+ hClose h
+
+ h <- openFile "hIsEOF002.out" ReadWriteMode
+ hSetBuffering h NoBuffering
+ hSeek h SeekFromEnd 0
+ hIsEOF h >>= print
+ hPutChar h 'x'
+ hIsEOF h >>= print
+ hSeek h SeekFromEnd (-1)
+ hIsEOF h >>= print
+ hGetChar h >>= print
--- /dev/null
+True
+False
+'\n'
+True
+False
+'\n'
+True
+False
+'\n'
+True
+False
+'\n'
+True
+True
+False
+'x'
--- /dev/null
+-- !!! hReady test
+
+ -- hReady should probably return False at the end of a file,
+ -- but in GHC it returns True (known bug).
+
+import IO
+
+main = do
+ h <- openFile "hReady001.hs" ReadMode
+ hSeek h SeekFromEnd 0
+ hReady h >>= print
--- /dev/null
+-- !!! Test seeking
+
+import IO
+
+main = do
+ h <- openFile "hSeek001.in" ReadMode
+ True <- hIsSeekable h
+ hSeek h SeekFromEnd (-1)
+ z <- hGetChar h
+ putStr (z:"\n")
+ hSeek h SeekFromEnd (-3)
+ x <- hGetChar h
+ putStr (x:"\n")
+ hSeek h RelativeSeek (-2)
+ w <- hGetChar h
+ putStr (w:"\n")
+ hSeek h RelativeSeek 2
+ z <- hGetChar h
+ putStr (z:"\n")
+ hSeek h AbsoluteSeek (0)
+ a <- hGetChar h
+ putStr (a:"\n")
+ hSeek h AbsoluteSeek (10)
+ k <- hGetChar h
+ putStr (k:"\n")
+ hSeek h AbsoluteSeek (25)
+ z <- hGetChar h
+ putStr (z:"\n")
+ hClose h
--- /dev/null
+z
+x
+w
+z
+a
+k
+z
main :: IO ()
main = do
- hdl <- openFile "io025.hs" ReadMode
+ hdl <- openFile "hSeek002.hs" ReadMode
flg <- hIsEOF hdl
print flg
hSeek hdl SeekFromEnd 0
BlockBuffering (Just 511),BlockBuffering (Just 3), BlockBuffering (Just 11)]
main = do
- hdl <- openFile "io030.hs" ReadMode
+ hdl <- openFile "hSeek003.hs" ReadMode
sequence (zipWith testPosns (repeat hdl) bmo_ls)
hClose hdl
--- /dev/null
+-- !!! can't seek an AppendMode handle
+
+import IO
+
+main = do
+ h <- openFile "hSeek004.out" AppendMode
+ try (hSeek h AbsoluteSeek 0) >>= print
--- /dev/null
+Left illegal operation
+Action: hSeek
+Handle: {loc=hSeek004.out,type=writable (append),buffering=block (8192)}
+Reason: handle is not seekable
+File: hSeek004.out
--- /dev/null
+-- !!! test ioeGetErrorString
+
+import IO
+import Maybe
+
+main = do
+ h <- openFile "ioeGetErrorString001.hs" ReadMode
+ hSeek h SeekFromEnd 0
+ (hGetChar h >> return ()) `catch`
+ \e -> if isEOFError e
+ then print (ioeGetErrorString e)
+ else putStrLn "failed."
--- /dev/null
+"end of file"
--- /dev/null
+-- !!! test ioeGetFileName
+
+import IO
+
+main = do
+ h <- openFile "ioeGetFileName001.hs" ReadMode
+ hSeek h SeekFromEnd 0
+ (hGetChar h >> return ()) `catch`
+ \e -> if isEOFError e
+ then print (ioeGetFileName e)
+ else putStrLn "failed."
--- /dev/null
+Just "ioeGetFileName001.hs"
--- /dev/null
+-- !!! test ioeGetHandle
+
+import IO
+import Maybe
+
+main = do
+ h <- openFile "ioeGetHandle001.hs" ReadMode
+ hSeek h SeekFromEnd 0
+ (hGetChar h >> return ()) `catch`
+ \e -> if isEOFError e && fromJust (ioeGetHandle e) == h
+ then putStrLn "ok."
+ else putStrLn "failed."
--- /dev/null
+import IO
+
+main = isEOF >>= print
--- /dev/null
+import IO
+
+import System (getArgs)
+import Char (toUpper)
+import Directory (removeFile, doesFileExist)
+
+main = do
+ [f1,f2] <- getArgs
+ h1 <- openFile f1 ReadMode
+ f <- doesFileExist f2
+ if f then removeFile f2 else return ()
+ h2 <- openFile f2 WriteMode
+ copyFile h1 h2
+ hClose h1
+ hClose h2
+
+copyFile h1 h2 = do
+ eof <- hIsEOF h1
+ if eof
+ then return ()
+ else do
+ c <- hGetChar h1
+ c <- hPutChar h2 (toUpper c)
+ copyFile h1 h2
--- /dev/null
+-- !!! test that a file opened in ReadMode can't be written to
+
+import IO
+
+main = do
+ hIn <- openFile "openFile001.hs" ReadMode
+ hPutStr hIn "test" `catch` \ err ->
+ if isIllegalOperation err
+ then putStrLn "ok."
+ else error "Oh dear\n"
--- /dev/null
+import Char
+import IO
+
+-- !!! Open a non-existent file for reading (should fail)
+
+main = openFile "<nonexistent>" ReadMode
--- /dev/null
+
+Fail: does not exist
+Action: openFile
+Reason: No such file or directory
+File: <nonexistent>
+
--- /dev/null
+import IO
+
+-- !!! Open a directory (should fail)
+
+main = do
+ r <- try (openFile "." ReadMode)
+ print r
+ r <- try (openFile "." WriteMode)
+ print r
+ r <- try (openFile "." AppendMode)
+ print r
+ r <- try (openFile "." ReadWriteMode)
+ print r
--- /dev/null
+Left inappropriate type
+Action: openFile
+Reason: is a directory
+File: .
+Left inappropriate type
+Action: openFile
+Reason: Is a directory
+File: .
+Left inappropriate type
+Action: openFile
+Reason: Is a directory
+File: .
+Left inappropriate type
+Action: openFile
+Reason: Is a directory
+File: .
--- /dev/null
+-- !!! Open a non-existent file for writing
+
+import Char
+import IO
+import Directory
+import Monad
+
+file = "openFile004.out"
+
+main = do
+ b <- doesFileExist file
+ when b (removeFile file)
+
+ h <- openFile file WriteMode
+ hPutStr h "hello world\n"
+ hClose h
+
+ h <- openFile file ReadMode
+ let loop = do
+ b <- hIsEOF h
+ if b then return ()
+ else do c <- hGetChar h; putChar c; loop
+ loop
--- /dev/null
+hello world
--- /dev/null
+-- !!! test multiple-reader single-writer locking semantics
+
+import IO
+
+file1 = "openFile005.out1"
+file2 = "openFile005.out2"
+
+main = do
+ -- two writes (should fail)
+ h <- openFile file1 WriteMode
+ try (openFile file1 WriteMode) >>= print
+ hClose h
+
+ -- write and an append (should fail)
+ h <- openFile file1 WriteMode
+ try (openFile file1 AppendMode) >>= print
+ hClose h
+
+ -- read/write and a write (should fail)
+ h <- openFile file1 ReadWriteMode
+ try (openFile file1 WriteMode) >>= print
+ hClose h
+
+ -- read and a read/write (should fail)
+ h <- openFile file1 ReadMode
+ try (openFile file1 ReadWriteMode) >>= print
+ hClose h
+
+ -- write and a read (should fail)
+ h <- openFile file1 WriteMode
+ try (openFile file1 ReadMode) >>= print
+ hClose h
+
+ -- two writes, different files (silly, but should succeed)
+ h1 <- openFile file1 WriteMode
+ h2 <- openFile file2 WriteMode
+ hClose h1
+ hClose h2
+
+ -- two reads, should succeed
+ h1 <- openFile file1 ReadMode
+ h2 <- openFile file1 ReadMode
+ hClose h1
+ hClose h2
--- /dev/null
+Left resource busy
+Action: openFile
+Reason: file is locked
+File: openFile005.out1
+Left resource busy
+Action: openFile
+Reason: file is locked
+File: openFile005.out1
+Left resource busy
+Action: openFile
+Reason: file is locked
+File: openFile005.out1
+Left resource busy
+Action: openFile
+Reason: file is locked
+File: openFile005.out1
+Left resource busy
+Action: openFile
+Reason: file is locked
+File: openFile005.out1
--- /dev/null
+-- !!! opening a file in WriteMode better truncate it
+
+import IO
+
+main = do
+ h <- openFile "openFile006.out" AppendMode
+ hPutStrLn h "hello, world"
+ size <- hFileSize h
+ print size
+ hClose h
+
+ h <- openFile "openFile006.out" WriteMode
+ size <- hFileSize h
+ print size
-- !!! Testing output on stdout
-module Main(main) where
-- stdout is buffered, so test if its buffer
-- is flushed upon program termination.
-main :: IO ()
-main = putStr "Hello"
+
+main = putStr "Hello, world\n"
import Monad
main = do
- f <- doesFileExist "io031.inout"
- when f (removeFile "io031.inout")
- hdl <- openFile "io031.inout" ReadWriteMode
+ f <- doesFileExist "readwrite001.inout"
+ when f (removeFile "readwrite001.inout")
+ hdl <- openFile "readwrite001.inout" ReadWriteMode
hSetBuffering hdl LineBuffering
hPutStr hdl "as"
hSeek hdl AbsoluteSeek 0
-- !!! Testing RW handles
-module Main(main) where
-
import IO
-import IOExts
import Directory (removeFile, doesFileExist)
import Monad
main :: IO ()
main = do
- let username = "io018.inout"
+ let username = "readwrite002.inout"
f <- doesFileExist username
when f (removeFile username)
cd <- openFile username ReadWriteMode
- hSetBinaryMode cd True
+-- hSetBinaryMode cd True
hSetBuffering stdin NoBuffering
hSetBuffering stdout NoBuffering
hSetBuffering cd NoBuffering
hSetBuffering cd (BlockBuffering Nothing)
speak cd `catch` \ err -> if isEOFError err then putStrLn "\nCaught EOF" else ioError err
-speakString = "Someone wants to speak with you\n"
+speakString = "##############################\n"
speak cd = do
(do
--- /dev/null
+###############
+
+Caught EOF
+###############
+
+Caught EOF
+###############
+
+Caught EOF
projects / ghc-hetmet.git / commitdiff