X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Flib%2Fstd%2FPrelPosix.hsc;h=e36f69c1934d8549be14424a61793e05f56458da;hb=210d594cb084c373daee4812ae8f2e25ca788501;hp=35dacc68cee2f3d241a4b2d0525b8868e709d608;hpb=254849fcd88bbb7b553141556400194c1bd9f24f;p=ghc-hetmet.git diff --git a/ghc/lib/std/PrelPosix.hsc b/ghc/lib/std/PrelPosix.hsc index 35dacc6..e36f69c 100644 --- a/ghc/lib/std/PrelPosix.hsc +++ b/ghc/lib/std/PrelPosix.hsc @@ -1,4 +1,4 @@ -{-# OPTIONS -fno-implicit-prelude #-} +{-# OPTIONS -fno-implicit-prelude -#include "PrelIOUtils.h" #-} -- --------------------------------------------------------------------------- -- @@ -64,14 +64,14 @@ type CStat = () fdFileSize :: Int -> IO Integer fdFileSize fd = - allocaBytes (#const sizeof(struct stat)) $ \ p_stat -> do + allocaBytes sizeof_stat $ \ p_stat -> do throwErrnoIfMinus1Retry "fileSize" $ c_fstat (fromIntegral fd) p_stat - c_mode <- (#peek struct stat, st_mode) p_stat :: IO CMode + c_mode <- 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 + c_size <- st_size p_stat :: IO COff return (fromIntegral c_size) data FDType = Directory | Stream | RegularFile @@ -81,31 +81,34 @@ data FDType = Directory | Stream | RegularFile -- referring to file handles. i.e., it'll fail for socket FDs. fdType :: Int -> IO FDType fdType fd = - allocaBytes (#const sizeof(struct stat)) $ \ p_stat -> do + allocaBytes sizeof_stat $ \ p_stat -> do throwErrnoIfMinus1Retry "fdType" $ c_fstat (fromIntegral fd) p_stat - c_mode <- (#peek struct stat, st_mode) p_stat :: IO CMode + c_mode <- 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 + _ | s_isdir c_mode -> return Directory + | s_isfifo c_mode -> return Stream + | s_issock c_mode -> return Stream + | s_ischr c_mode -> return Stream + | s_isreg c_mode -> return RegularFile + | s_isblk c_mode -> return RegularFile + | otherwise -> ioException ioe_unknownfiletype + -- we consider character devices to be streams (eg. ttys), + -- whereas block devices are more like regular files because they + -- are seekable. ioe_unknownfiletype = IOError Nothing UnsupportedOperation "fdType" "unknown file type" Nothing foreign import "s_isreg_PrelPosix_wrap" unsafe s_isreg :: CMode -> Bool -#def inline int s_isreg_PrelPosix_wrap(m) { return S_ISREG(m); } - foreign import "s_isdir_PrelPosix_wrap" unsafe s_isdir :: CMode -> Bool -#def inline int s_isdir_PrelPosix_wrap(m) { return S_ISDIR(m); } - foreign import "s_isfifo_PrelPosix_wrap" unsafe s_isfifo :: CMode -> Bool -#def inline int s_isfifo_PrelPosix_wrap(m) { return S_ISFIFO(m); } +foreign import "s_ischr_PrelPosix_wrap" unsafe s_ischr :: CMode -> Bool +foreign import "s_isblk_PrelPosix_wrap" unsafe s_isblk :: CMode -> Bool #ifndef mingw32_TARGET_OS foreign import "s_issock_PrelPosix_wrap" unsafe s_issock :: CMode -> Bool -#def inline int s_issock_PrelPosix_wrap(m) { return S_ISSOCK(m); } + #else s_issock :: CMode -> Bool s_issock cmode = False @@ -135,44 +138,44 @@ type Termios = () setEcho :: Int -> Bool -> IO () setEcho fd on = do - allocaBytes (#const sizeof(struct termios)) $ \p_tios -> do + allocaBytes sizeof_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 + c_lflag <- c_lflag p_tios :: IO CTcflag + let new_c_lflag | on = c_lflag .|. fromIntegral prel_echo + | otherwise = c_lflag .&. complement (fromIntegral prel_echo) + poke_c_lflag p_tios (new_c_lflag :: CTcflag) + tcSetAttr fd prel_tcsanow p_tios getEcho :: Int -> IO Bool getEcho fd = do - allocaBytes (#const sizeof(struct termios)) $ \p_tios -> do + allocaBytes sizeof_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) + c_lflag <- c_lflag p_tios :: IO CTcflag + return ((c_lflag .&. fromIntegral prel_echo) /= 0) setCooked :: Int -> Bool -> IO () setCooked fd cooked = - allocaBytes (#const sizeof(struct termios)) $ \p_tios -> do + allocaBytes sizeof_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) + c_lflag <- c_lflag p_tios :: IO CTcflag + let new_c_lflag | cooked = c_lflag .|. (fromIntegral prel_icanon) + | otherwise = c_lflag .&. complement (fromIntegral prel_icanon) + poke_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 + c_cc <- ptr_c_cc p_tios + let vmin = (c_cc `plusPtr` (fromIntegral prel_vmin)) :: Ptr Word8 + vtime = (c_cc `plusPtr` (fromIntegral prel_vtime)) :: Ptr Word8 poke vmin 1 poke vtime 0 - tcSetAttr fd (#const TCSANOW) p_tios + tcSetAttr fd prel_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 @@ -182,15 +185,29 @@ setCooked fd cooked = 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 + allocaBytes sizeof_sigset_t $ \ p_sigset -> do + allocaBytes 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 + c_sigaddset p_sigset prel_sigttou + c_sigprocmask prel_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 - + c_sigprocmask prel_sig_setmask p_old_sigset nullPtr + +foreign import ccall "prel_lflag" c_lflag :: Ptr Termios -> IO CTcflag +foreign import ccall "prel_poke_lflag" poke_c_lflag :: Ptr Termios -> CTcflag -> IO () +foreign import ccall "prel_ptr_c_cc" ptr_c_cc :: Ptr Termios -> IO (Ptr Word8) + +foreign import ccall "prel_echo" unsafe prel_echo :: CInt +foreign import ccall "prel_tcsanow" unsafe prel_tcsanow :: CInt +foreign import ccall "prel_icanon" unsafe prel_icanon :: CInt +foreign import ccall "prel_vmin" unsafe prel_vmin :: CInt +foreign import ccall "prel_vtime" unsafe prel_vtime :: CInt +foreign import ccall "prel_sigttou" unsafe prel_sigttou :: CInt +foreign import ccall "prel_sig_block" unsafe prel_sig_block :: CInt +foreign import ccall "prel_sig_setmask" unsafe prel_sig_setmask :: CInt +foreign import ccall "prel_f_getfl" unsafe prel_f_getfl :: CInt +foreign import ccall "prel_f_setfl" unsafe prel_f_setfl :: CInt #else -- bogus defns for win32 @@ -212,12 +229,11 @@ getEcho fd = return False setNonBlockingFD fd = do flags <- throwErrnoIfMinus1Retry "setNonBlockingFD" - (fcntl_read (fromIntegral fd) (#const F_GETFL)) + (fcntl_read (fromIntegral fd) prel_f_getfl) -- An error when setting O_NONBLOCK isn't fatal: on some systems -- there are certain file handles on which this will fail (eg. /dev/null -- on FreeBSD) so we throw away the return code from fcntl_write. - fcntl_write (fromIntegral fd) - (#const F_SETFL) (flags .|. #const O_NONBLOCK) + fcntl_write (fromIntegral fd) prel_f_setfl (flags .|. o_NONBLOCK) #else -- bogus defns for win32 @@ -234,34 +250,34 @@ foreign import "stat" unsafe 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_TRUNC = (#const O_TRUNC) :: CInt +foreign import ccall "prel_sizeof_stat" unsafe sizeof_stat :: Int +foreign import ccall "prel_st_mtime" unsafe st_mtime :: Ptr CStat -> IO CTime +foreign import ccall "prel_st_size" unsafe st_size :: Ptr CStat -> IO COff +foreign import ccall "prel_st_mode" unsafe st_mode :: Ptr CStat -> IO CMode -#ifdef mingw32_TARGET_OS -o_NOCTTY = 0 :: CInt -o_NONBLOCK = 0 :: CInt -#else -o_NOCTTY = (#const O_NOCTTY) :: CInt -o_NONBLOCK = (#const O_NONBLOCK) :: CInt +#ifndef mingw32_TARGET_OS +foreign import ccall "prel_sizeof_termios" unsafe sizeof_termios :: Int +foreign import ccall "prel_sizeof_sigset_t" unsafe sizeof_sigset_t :: Int #endif -#ifdef HAVE_O_BINARY -o_BINARY = (#const O_BINARY) :: CInt -#endif +-- POSIX flags only: +foreign import ccall "prel_o_rdonly" unsafe o_RDONLY :: CInt +foreign import ccall "prel_o_wronly" unsafe o_WRONLY :: CInt +foreign import ccall "prel_o_rdwr" unsafe o_RDWR :: CInt +foreign import ccall "prel_o_append" unsafe o_APPEND :: CInt +foreign import ccall "prel_o_creat" unsafe o_CREAT :: CInt +foreign import ccall "prel_o_excl" unsafe o_EXCL :: CInt +foreign import ccall "prel_o_trunc" unsafe o_TRUNC :: CInt + + +-- non-POSIX flags. +foreign import ccall "prel_o_noctty" unsafe o_NOCTTY :: CInt +foreign import ccall "prel_o_nonblock" unsafe o_NONBLOCK :: CInt +foreign import ccall "prel_o_binary" unsafe o_BINARY :: CInt + foreign import "isatty" unsafe c_isatty :: CInt -> IO CInt @@ -282,12 +298,6 @@ foreign import "closesocket" unsafe foreign import "lseek" unsafe c_lseek :: CInt -> COff -> CInt -> IO COff -foreign import "write" unsafe - c_write :: CInt -> Ptr CChar -> CSize -> IO CSsize - -foreign import "read" unsafe - c_read :: CInt -> Ptr CChar -> CSize -> IO CSsize - #ifndef mingw32_TARGET_OS foreign import "fcntl" unsafe fcntl_read :: CInt -> CInt -> IO CInt @@ -300,7 +310,6 @@ foreign import "fork" unsafe foreign import "sigemptyset_PrelPosix_wrap" unsafe c_sigemptyset :: Ptr CSigset -> IO () -#def inline void sigemptyset_PrelPosix_wrap(sigset_t *set) { sigemptyset(set); } foreign import "sigaddset" unsafe c_sigaddset :: Ptr CSigset -> CInt -> IO ()