-- Stability : experimental
-- Portability : non-portable
--
--- $Id: Exception.hs,v 1.5 2001/12/21 15:07:21 simonmar Exp $
+-- $Id: Exception.hs,v 1.6 2002/02/05 17:32:25 simonmar Exp $
--
-- The External API for exceptions. The functions provided in this
-- module allow catching of exceptions in the IO monad.
#ifdef __GLASGOW_HASKELL__
import Prelude hiding (catch)
+import System.IO.Error
import GHC.Base ( assert )
import GHC.Exception hiding (try, catch, bracket, bracket_)
import GHC.Conc ( throwTo, ThreadId )
asyncExceptions (AsyncException e) = Just e
asyncExceptions _ = Nothing
-userErrors (UserError e) = Just e
+userErrors e | isUserError e = Just (ioeGetErrorString e)
userErrors _ = Nothing
-----------------------------------------------------------------------------
-- Stability : experimental
-- Portability : non-portable
--
--- $Id: IO.hs,v 1.3 2002/01/02 14:40:10 simonmar Exp $
+-- $Id: IO.hs,v 1.4 2002/02/05 17:32:25 simonmar Exp $
--
-- Mutable boxed/unboxed arrays in the IO monad.
--
loop off bytes | bytes <= 0 = return (off - init_off)
loop off bytes = do
r' <- throwErrnoIfMinus1RetryMayBlock "readChunk"
- (read_off (fromIntegral fd) is_stream ptr
+ (read_off_ba (fromIntegral fd) is_stream ptr
(fromIntegral off) (fromIntegral bytes))
(threadWaitRead fd)
let r = fromIntegral r'
-- Stability : experimental
-- Portability : portable
--
--- $Id: Bits.hs,v 1.3 2001/12/21 15:07:21 simonmar Exp $
+-- $Id: Bits.hs,v 1.4 2002/02/05 17:32:25 simonmar Exp $
--
-- Bitwise operations.
--
-- Removing all fixities is a fairly safe fix; fixing the "one fixity
-- per symbol per program" limitation in Hugs would take a lot longer.
#ifndef __HUGS__
-infixl 8 `shift`, `rotate`
+infixl 8 `shift`, `rotate`, `shiftL`, `shiftR`, `rotateL`, `rotateR`
infixl 7 .&.
infixl 6 `xor`
infixl 5 .|.
-- Stability : provisional
-- Portability : portable
--
--- $Id: Error.hs,v 1.4 2001/12/21 15:07:22 simonmar Exp $
+-- $Id: Error.hs,v 1.5 2002/02/05 17:32:25 simonmar Exp $
--
-- C-specific Marshalling support: Handling of C "errno" error codes
--
-- This function exists because errno is a variable on some systems, but on
-- Windows it is a macro for a function...
-- [yes, global variables and thread safety don't really go hand-in-hand. -- sof]
-foreign import "ghcErrno" unsafe _errno :: Ptr CInt
+foreign import ccall unsafe "ghcErrno" _errno :: Ptr CInt
-- Haskell representation for "errno" values
--
return (userError (loc ++ ": " ++ str ++ maybe "" (": "++) maybeName))
#endif
-foreign import unsafe strerror :: Errno -> IO (Ptr CChar)
+foreign import ccall unsafe strerror :: Errno -> IO (Ptr CChar)
-- Dreadfully tedious callouts to wrappers which define the
-- actual values for the error codes.
-foreign import ccall "prel_error_E2BIG" unsafe cCONST_E2BIG :: CInt
-foreign import ccall "prel_error_EACCES" unsafe cCONST_EACCES :: CInt
-foreign import ccall "prel_error_EADDRINUSE" unsafe cCONST_EADDRINUSE :: CInt
-foreign import ccall "prel_error_EADDRNOTAVAIL" unsafe cCONST_EADDRNOTAVAIL :: CInt
-foreign import ccall "prel_error_EADV" unsafe cCONST_EADV :: CInt
-foreign import ccall "prel_error_EAFNOSUPPORT" unsafe cCONST_EAFNOSUPPORT :: CInt
-foreign import ccall "prel_error_EAGAIN" unsafe cCONST_EAGAIN :: CInt
-foreign import ccall "prel_error_EALREADY" unsafe cCONST_EALREADY :: CInt
-foreign import ccall "prel_error_EBADF" unsafe cCONST_EBADF :: CInt
-foreign import ccall "prel_error_EBADMSG" unsafe cCONST_EBADMSG :: CInt
-foreign import ccall "prel_error_EBADRPC" unsafe cCONST_EBADRPC :: CInt
-foreign import ccall "prel_error_EBUSY" unsafe cCONST_EBUSY :: CInt
-foreign import ccall "prel_error_ECHILD" unsafe cCONST_ECHILD :: CInt
-foreign import ccall "prel_error_ECOMM" unsafe cCONST_ECOMM :: CInt
-foreign import ccall "prel_error_ECONNABORTED" unsafe cCONST_ECONNABORTED :: CInt
-foreign import ccall "prel_error_ECONNREFUSED" unsafe cCONST_ECONNREFUSED :: CInt
-foreign import ccall "prel_error_ECONNRESET" unsafe cCONST_ECONNRESET :: CInt
-foreign import ccall "prel_error_EDEADLK" unsafe cCONST_EDEADLK :: CInt
-foreign import ccall "prel_error_EDESTADDRREQ" unsafe cCONST_EDESTADDRREQ :: CInt
-foreign import ccall "prel_error_EDIRTY" unsafe cCONST_EDIRTY :: CInt
-foreign import ccall "prel_error_EDOM" unsafe cCONST_EDOM :: CInt
-foreign import ccall "prel_error_EDQUOT" unsafe cCONST_EDQUOT :: CInt
-foreign import ccall "prel_error_EEXIST" unsafe cCONST_EEXIST :: CInt
-foreign import ccall "prel_error_EFAULT" unsafe cCONST_EFAULT :: CInt
-foreign import ccall "prel_error_EFBIG" unsafe cCONST_EFBIG :: CInt
-foreign import ccall "prel_error_EFTYPE" unsafe cCONST_EFTYPE :: CInt
-foreign import ccall "prel_error_EHOSTDOWN" unsafe cCONST_EHOSTDOWN :: CInt
-foreign import ccall "prel_error_EHOSTUNREACH" unsafe cCONST_EHOSTUNREACH :: CInt
-foreign import ccall "prel_error_EIDRM" unsafe cCONST_EIDRM :: CInt
-foreign import ccall "prel_error_EILSEQ" unsafe cCONST_EILSEQ :: CInt
-foreign import ccall "prel_error_EINPROGRESS" unsafe cCONST_EINPROGRESS :: CInt
-foreign import ccall "prel_error_EINTR" unsafe cCONST_EINTR :: CInt
-foreign import ccall "prel_error_EINVAL" unsafe cCONST_EINVAL :: CInt
-foreign import ccall "prel_error_EIO" unsafe cCONST_EIO :: CInt
-foreign import ccall "prel_error_EISCONN" unsafe cCONST_EISCONN :: CInt
-foreign import ccall "prel_error_EISDIR" unsafe cCONST_EISDIR :: CInt
-foreign import ccall "prel_error_ELOOP" unsafe cCONST_ELOOP :: CInt
-foreign import ccall "prel_error_EMFILE" unsafe cCONST_EMFILE :: CInt
-foreign import ccall "prel_error_EMLINK" unsafe cCONST_EMLINK :: CInt
-foreign import ccall "prel_error_EMSGSIZE" unsafe cCONST_EMSGSIZE :: CInt
-foreign import ccall "prel_error_EMULTIHOP" unsafe cCONST_EMULTIHOP :: CInt
-foreign import ccall "prel_error_ENAMETOOLONG" unsafe cCONST_ENAMETOOLONG :: CInt
-foreign import ccall "prel_error_ENETDOWN" unsafe cCONST_ENETDOWN :: CInt
-foreign import ccall "prel_error_ENETRESET" unsafe cCONST_ENETRESET :: CInt
-foreign import ccall "prel_error_ENETUNREACH" unsafe cCONST_ENETUNREACH :: CInt
-foreign import ccall "prel_error_ENFILE" unsafe cCONST_ENFILE :: CInt
-foreign import ccall "prel_error_ENOBUFS" unsafe cCONST_ENOBUFS :: CInt
-foreign import ccall "prel_error_ENODATA" unsafe cCONST_ENODATA :: CInt
-foreign import ccall "prel_error_ENODEV" unsafe cCONST_ENODEV :: CInt
-foreign import ccall "prel_error_ENOENT" unsafe cCONST_ENOENT :: CInt
-foreign import ccall "prel_error_ENOEXEC" unsafe cCONST_ENOEXEC :: CInt
-foreign import ccall "prel_error_ENOLCK" unsafe cCONST_ENOLCK :: CInt
-foreign import ccall "prel_error_ENOLINK" unsafe cCONST_ENOLINK :: CInt
-foreign import ccall "prel_error_ENOMEM" unsafe cCONST_ENOMEM :: CInt
-foreign import ccall "prel_error_ENOMSG" unsafe cCONST_ENOMSG :: CInt
-foreign import ccall "prel_error_ENONET" unsafe cCONST_ENONET :: CInt
-foreign import ccall "prel_error_ENOPROTOOPT" unsafe cCONST_ENOPROTOOPT :: CInt
-foreign import ccall "prel_error_ENOSPC" unsafe cCONST_ENOSPC :: CInt
-foreign import ccall "prel_error_ENOSR" unsafe cCONST_ENOSR :: CInt
-foreign import ccall "prel_error_ENOSTR" unsafe cCONST_ENOSTR :: CInt
-foreign import ccall "prel_error_ENOSYS" unsafe cCONST_ENOSYS :: CInt
-foreign import ccall "prel_error_ENOTBLK" unsafe cCONST_ENOTBLK :: CInt
-foreign import ccall "prel_error_ENOTCONN" unsafe cCONST_ENOTCONN :: CInt
-foreign import ccall "prel_error_ENOTDIR" unsafe cCONST_ENOTDIR :: CInt
-foreign import ccall "prel_error_ENOTEMPTY" unsafe cCONST_ENOTEMPTY :: CInt
-foreign import ccall "prel_error_ENOTSOCK" unsafe cCONST_ENOTSOCK :: CInt
-foreign import ccall "prel_error_ENOTTY" unsafe cCONST_ENOTTY :: CInt
-foreign import ccall "prel_error_ENXIO" unsafe cCONST_ENXIO :: CInt
-foreign import ccall "prel_error_EOPNOTSUPP" unsafe cCONST_EOPNOTSUPP :: CInt
-foreign import ccall "prel_error_EPERM" unsafe cCONST_EPERM :: CInt
-foreign import ccall "prel_error_EPFNOSUPPORT" unsafe cCONST_EPFNOSUPPORT :: CInt
-foreign import ccall "prel_error_EPIPE" unsafe cCONST_EPIPE :: CInt
-foreign import ccall "prel_error_EPROCLIM" unsafe cCONST_EPROCLIM :: CInt
-foreign import ccall "prel_error_EPROCUNAVAIL" unsafe cCONST_EPROCUNAVAIL :: CInt
-foreign import ccall "prel_error_EPROGMISMATCH" unsafe cCONST_EPROGMISMATCH :: CInt
-foreign import ccall "prel_error_EPROGUNAVAIL" unsafe cCONST_EPROGUNAVAIL :: CInt
-foreign import ccall "prel_error_EPROTO" unsafe cCONST_EPROTO :: CInt
-foreign import ccall "prel_error_EPROTONOSUPPORT" unsafe cCONST_EPROTONOSUPPORT :: CInt
-foreign import ccall "prel_error_EPROTOTYPE" unsafe cCONST_EPROTOTYPE :: CInt
-foreign import ccall "prel_error_ERANGE" unsafe cCONST_ERANGE :: CInt
-foreign import ccall "prel_error_EREMCHG" unsafe cCONST_EREMCHG :: CInt
-foreign import ccall "prel_error_EREMOTE" unsafe cCONST_EREMOTE :: CInt
-foreign import ccall "prel_error_EROFS" unsafe cCONST_EROFS :: CInt
-foreign import ccall "prel_error_ERPCMISMATCH" unsafe cCONST_ERPCMISMATCH :: CInt
-foreign import ccall "prel_error_ERREMOTE" unsafe cCONST_ERREMOTE :: CInt
-foreign import ccall "prel_error_ESHUTDOWN" unsafe cCONST_ESHUTDOWN :: CInt
-foreign import ccall "prel_error_ESOCKTNOSUPPORT" unsafe cCONST_ESOCKTNOSUPPORT :: CInt
-foreign import ccall "prel_error_ESPIPE" unsafe cCONST_ESPIPE :: CInt
-foreign import ccall "prel_error_ESRCH" unsafe cCONST_ESRCH :: CInt
-foreign import ccall "prel_error_ESRMNT" unsafe cCONST_ESRMNT :: CInt
-foreign import ccall "prel_error_ESTALE" unsafe cCONST_ESTALE :: CInt
-foreign import ccall "prel_error_ETIME" unsafe cCONST_ETIME :: CInt
-foreign import ccall "prel_error_ETIMEDOUT" unsafe cCONST_ETIMEDOUT :: CInt
-foreign import ccall "prel_error_ETOOMANYREFS" unsafe cCONST_ETOOMANYREFS :: CInt
-foreign import ccall "prel_error_ETXTBSY" unsafe cCONST_ETXTBSY :: CInt
-foreign import ccall "prel_error_EUSERS" unsafe cCONST_EUSERS :: CInt
-foreign import ccall "prel_error_EWOULDBLOCK" unsafe cCONST_EWOULDBLOCK :: CInt
-foreign import ccall "prel_error_EXDEV" unsafe cCONST_EXDEV :: CInt
+foreign import ccall unsafe "prel_error_E2BIG" cCONST_E2BIG :: CInt
+foreign import ccall unsafe "prel_error_EACCES" cCONST_EACCES :: CInt
+foreign import ccall unsafe "prel_error_EADDRINUSE" cCONST_EADDRINUSE :: CInt
+foreign import ccall unsafe "prel_error_EADDRNOTAVAIL" cCONST_EADDRNOTAVAIL :: CInt
+foreign import ccall unsafe "prel_error_EADV" cCONST_EADV :: CInt
+foreign import ccall unsafe "prel_error_EAFNOSUPPORT" cCONST_EAFNOSUPPORT :: CInt
+foreign import ccall unsafe "prel_error_EAGAIN" cCONST_EAGAIN :: CInt
+foreign import ccall unsafe "prel_error_EALREADY" cCONST_EALREADY :: CInt
+foreign import ccall unsafe "prel_error_EBADF" cCONST_EBADF :: CInt
+foreign import ccall unsafe "prel_error_EBADMSG" cCONST_EBADMSG :: CInt
+foreign import ccall unsafe "prel_error_EBADRPC" cCONST_EBADRPC :: CInt
+foreign import ccall unsafe "prel_error_EBUSY" cCONST_EBUSY :: CInt
+foreign import ccall unsafe "prel_error_ECHILD" cCONST_ECHILD :: CInt
+foreign import ccall unsafe "prel_error_ECOMM" cCONST_ECOMM :: CInt
+foreign import ccall unsafe "prel_error_ECONNABORTED" cCONST_ECONNABORTED :: CInt
+foreign import ccall unsafe "prel_error_ECONNREFUSED" cCONST_ECONNREFUSED :: CInt
+foreign import ccall unsafe "prel_error_ECONNRESET" cCONST_ECONNRESET :: CInt
+foreign import ccall unsafe "prel_error_EDEADLK" cCONST_EDEADLK :: CInt
+foreign import ccall unsafe "prel_error_EDESTADDRREQ" cCONST_EDESTADDRREQ :: CInt
+foreign import ccall unsafe "prel_error_EDIRTY" cCONST_EDIRTY :: CInt
+foreign import ccall unsafe "prel_error_EDOM" cCONST_EDOM :: CInt
+foreign import ccall unsafe "prel_error_EDQUOT" cCONST_EDQUOT :: CInt
+foreign import ccall unsafe "prel_error_EEXIST" cCONST_EEXIST :: CInt
+foreign import ccall unsafe "prel_error_EFAULT" cCONST_EFAULT :: CInt
+foreign import ccall unsafe "prel_error_EFBIG" cCONST_EFBIG :: CInt
+foreign import ccall unsafe "prel_error_EFTYPE" cCONST_EFTYPE :: CInt
+foreign import ccall unsafe "prel_error_EHOSTDOWN" cCONST_EHOSTDOWN :: CInt
+foreign import ccall unsafe "prel_error_EHOSTUNREACH" cCONST_EHOSTUNREACH :: CInt
+foreign import ccall unsafe "prel_error_EIDRM" cCONST_EIDRM :: CInt
+foreign import ccall unsafe "prel_error_EILSEQ" cCONST_EILSEQ :: CInt
+foreign import ccall unsafe "prel_error_EINPROGRESS" cCONST_EINPROGRESS :: CInt
+foreign import ccall unsafe "prel_error_EINTR" cCONST_EINTR :: CInt
+foreign import ccall unsafe "prel_error_EINVAL" cCONST_EINVAL :: CInt
+foreign import ccall unsafe "prel_error_EIO" cCONST_EIO :: CInt
+foreign import ccall unsafe "prel_error_EISCONN" cCONST_EISCONN :: CInt
+foreign import ccall unsafe "prel_error_EISDIR" cCONST_EISDIR :: CInt
+foreign import ccall unsafe "prel_error_ELOOP" cCONST_ELOOP :: CInt
+foreign import ccall unsafe "prel_error_EMFILE" cCONST_EMFILE :: CInt
+foreign import ccall unsafe "prel_error_EMLINK" cCONST_EMLINK :: CInt
+foreign import ccall unsafe "prel_error_EMSGSIZE" cCONST_EMSGSIZE :: CInt
+foreign import ccall unsafe "prel_error_EMULTIHOP" cCONST_EMULTIHOP :: CInt
+foreign import ccall unsafe "prel_error_ENAMETOOLONG" cCONST_ENAMETOOLONG :: CInt
+foreign import ccall unsafe "prel_error_ENETDOWN" cCONST_ENETDOWN :: CInt
+foreign import ccall unsafe "prel_error_ENETRESET" cCONST_ENETRESET :: CInt
+foreign import ccall unsafe "prel_error_ENETUNREACH" cCONST_ENETUNREACH :: CInt
+foreign import ccall unsafe "prel_error_ENFILE" cCONST_ENFILE :: CInt
+foreign import ccall unsafe "prel_error_ENOBUFS" cCONST_ENOBUFS :: CInt
+foreign import ccall unsafe "prel_error_ENODATA" cCONST_ENODATA :: CInt
+foreign import ccall unsafe "prel_error_ENODEV" cCONST_ENODEV :: CInt
+foreign import ccall unsafe "prel_error_ENOENT" cCONST_ENOENT :: CInt
+foreign import ccall unsafe "prel_error_ENOEXEC" cCONST_ENOEXEC :: CInt
+foreign import ccall unsafe "prel_error_ENOLCK" cCONST_ENOLCK :: CInt
+foreign import ccall unsafe "prel_error_ENOLINK" cCONST_ENOLINK :: CInt
+foreign import ccall unsafe "prel_error_ENOMEM" cCONST_ENOMEM :: CInt
+foreign import ccall unsafe "prel_error_ENOMSG" cCONST_ENOMSG :: CInt
+foreign import ccall unsafe "prel_error_ENONET" cCONST_ENONET :: CInt
+foreign import ccall unsafe "prel_error_ENOPROTOOPT" cCONST_ENOPROTOOPT :: CInt
+foreign import ccall unsafe "prel_error_ENOSPC" cCONST_ENOSPC :: CInt
+foreign import ccall unsafe "prel_error_ENOSR" cCONST_ENOSR :: CInt
+foreign import ccall unsafe "prel_error_ENOSTR" cCONST_ENOSTR :: CInt
+foreign import ccall unsafe "prel_error_ENOSYS" cCONST_ENOSYS :: CInt
+foreign import ccall unsafe "prel_error_ENOTBLK" cCONST_ENOTBLK :: CInt
+foreign import ccall unsafe "prel_error_ENOTCONN" cCONST_ENOTCONN :: CInt
+foreign import ccall unsafe "prel_error_ENOTDIR" cCONST_ENOTDIR :: CInt
+foreign import ccall unsafe "prel_error_ENOTEMPTY" cCONST_ENOTEMPTY :: CInt
+foreign import ccall unsafe "prel_error_ENOTSOCK" cCONST_ENOTSOCK :: CInt
+foreign import ccall unsafe "prel_error_ENOTTY" cCONST_ENOTTY :: CInt
+foreign import ccall unsafe "prel_error_ENXIO" cCONST_ENXIO :: CInt
+foreign import ccall unsafe "prel_error_EOPNOTSUPP" cCONST_EOPNOTSUPP :: CInt
+foreign import ccall unsafe "prel_error_EPERM" cCONST_EPERM :: CInt
+foreign import ccall unsafe "prel_error_EPFNOSUPPORT" cCONST_EPFNOSUPPORT :: CInt
+foreign import ccall unsafe "prel_error_EPIPE" cCONST_EPIPE :: CInt
+foreign import ccall unsafe "prel_error_EPROCLIM" cCONST_EPROCLIM :: CInt
+foreign import ccall unsafe "prel_error_EPROCUNAVAIL" cCONST_EPROCUNAVAIL :: CInt
+foreign import ccall unsafe "prel_error_EPROGMISMATCH" cCONST_EPROGMISMATCH :: CInt
+foreign import ccall unsafe "prel_error_EPROGUNAVAIL" cCONST_EPROGUNAVAIL :: CInt
+foreign import ccall unsafe "prel_error_EPROTO" cCONST_EPROTO :: CInt
+foreign import ccall unsafe "prel_error_EPROTONOSUPPORT" cCONST_EPROTONOSUPPORT :: CInt
+foreign import ccall unsafe "prel_error_EPROTOTYPE" cCONST_EPROTOTYPE :: CInt
+foreign import ccall unsafe "prel_error_ERANGE" cCONST_ERANGE :: CInt
+foreign import ccall unsafe "prel_error_EREMCHG" cCONST_EREMCHG :: CInt
+foreign import ccall unsafe "prel_error_EREMOTE" cCONST_EREMOTE :: CInt
+foreign import ccall unsafe "prel_error_EROFS" cCONST_EROFS :: CInt
+foreign import ccall unsafe "prel_error_ERPCMISMATCH" cCONST_ERPCMISMATCH :: CInt
+foreign import ccall unsafe "prel_error_ERREMOTE" cCONST_ERREMOTE :: CInt
+foreign import ccall unsafe "prel_error_ESHUTDOWN" cCONST_ESHUTDOWN :: CInt
+foreign import ccall unsafe "prel_error_ESOCKTNOSUPPORT" cCONST_ESOCKTNOSUPPORT :: CInt
+foreign import ccall unsafe "prel_error_ESPIPE" cCONST_ESPIPE :: CInt
+foreign import ccall unsafe "prel_error_ESRCH" cCONST_ESRCH :: CInt
+foreign import ccall unsafe "prel_error_ESRMNT" cCONST_ESRMNT :: CInt
+foreign import ccall unsafe "prel_error_ESTALE" cCONST_ESTALE :: CInt
+foreign import ccall unsafe "prel_error_ETIME" cCONST_ETIME :: CInt
+foreign import ccall unsafe "prel_error_ETIMEDOUT" cCONST_ETIMEDOUT :: CInt
+foreign import ccall unsafe "prel_error_ETOOMANYREFS" cCONST_ETOOMANYREFS :: CInt
+foreign import ccall unsafe "prel_error_ETXTBSY" cCONST_ETXTBSY :: CInt
+foreign import ccall unsafe "prel_error_EUSERS" cCONST_EUSERS :: CInt
+foreign import ccall unsafe "prel_error_EWOULDBLOCK" cCONST_EWOULDBLOCK :: CInt
+foreign import ccall unsafe "prel_error_EXDEV" cCONST_EXDEV :: CInt
-- Stability : provisional
-- Portability : portable
--
--- $Id: Types.hs,v 1.2 2001/07/03 11:37:50 simonmar Exp $
+-- $Id: Types.hs,v 1.3 2002/02/05 17:32:25 simonmar Exp $
--
-- Mapping of C types to corresponding Haskell types. A cool hack...
--
module Foreign.C.Types
( -- Integral types, instances of: Eq, Ord, Num, Read, Show, Enum,
-- Typeable, Storable, Bounded, Real, Integral, Bits
- CChar(..), CSChar(..), CUChar(..)
- , CShort(..), CUShort(..), CInt(..), CUInt(..)
- , CLong(..), CULong(..), CLLong(..), CULLong(..)
+ CChar(..), CSChar(..), CUChar(..)
+ , CShort(..), CUShort(..), CInt(..), CUInt(..)
+ , CLong(..), CULong(..), CLLong(..), CULLong(..)
-- Floating types, instances of: Eq, Ord, Num, Read, Show, Enum,
- -- Typeable, Storable, Real, Fractional, Floating, RealFrac, RealFloat
- , CFloat(..), CDouble(..), CLDouble(..)
+ -- Typeable, Storable, Real, Fractional, Floating, RealFrac,
+ -- RealFloat
+ , CFloat(..), CDouble(..), CLDouble(..)
) where
import Data.Bits ( Bits(..) )
-- Stability : provisional
-- Portability : portable
--
--- $Id: TypesISO.hs,v 1.2 2001/07/03 11:37:50 simonmar Exp $
+-- $Id: TypesISO.hs,v 1.3 2002/02/05 17:32:25 simonmar Exp $
--
-- A mapping of C types defined by the ISO C standard to corresponding Haskell
-- types. Like CTypes, this is a cool hack...
-- Typeable, Storable
, CClock(..), CTime(..),
+ -- Instances of: Eq and Storable
, CFile, CFpos, CJmpBuf
) where
INTEGRAL_TYPE(CClock,tyConCClock,"CClock",HTYPE_CLOCK_T)
INTEGRAL_TYPE(CTime,tyConCTime,"CTime",HTYPE_TIME_T)
--- TODO: Instances. But which...? :-}
-
+-- FIXME: Implement and provide instances for Eq and Storable
data CFile = CFile
-
data CFpos = CFpos
-
data CJmpBuf = CJmpBuf
-- C99 types which are still missing include:
-- Stability : provisional
-- Portability : portable
--
--- $Id: Alloc.hs,v 1.4 2001/12/21 15:07:22 simonmar Exp $
+-- $Id: Alloc.hs,v 1.5 2002/02/05 17:32:25 simonmar Exp $
--
-- Marshalling support: basic routines for memory allocation
--
-- basic C routines needed for memory allocation
--
-foreign import "malloc" unsafe _malloc :: CSize -> IO (Ptr a)
-foreign import "realloc" unsafe _realloc :: Ptr a -> CSize -> IO (Ptr a)
-foreign import "free" unsafe _free :: Ptr a -> IO ()
+foreign import ccall unsafe "malloc" _malloc :: CSize -> IO (Ptr a)
+foreign import ccall unsafe "realloc" _realloc :: Ptr a -> CSize -> IO (Ptr a)
+foreign import ccall unsafe "free" _free :: Ptr a -> IO ()
-- Stability : provisional
-- Portability : portable
--
--- $Id: Array.hs,v 1.3 2001/08/17 12:50:34 simonmar Exp $
+-- $Id: Array.hs,v 1.4 2002/02/05 17:32:25 simonmar Exp $
--
-- Marshalling support: routines allocating, storing, and retrieving Haskell
-- lists that are represented as arrays in the foreign language
withArray, -- :: Storable a => [a] -> (Ptr a -> IO b) -> IO b
withArray0, -- :: Storable a => a -> [a] -> (Ptr a -> IO b) -> IO b
- -- destruction
- --
- destructArray, -- :: Storable a => Int -> Ptr a -> IO ()
- destructArray0, -- :: (Storable a, Eq a) => a -> Ptr a -> IO ()
-
-- copying (argument order: destination, source)
--
copyArray, -- :: Storable a => Ptr a -> Ptr a -> Int -> IO ()
-- indexing
--
- advancePtr -- :: Storable a => Ptr a -> Int -> Ptr a
+ advancePtr, -- :: Storable a => Ptr a -> Int -> Ptr a
) where
import Control.Monad
#ifdef __GLASGOW_HASKELL__
import Foreign.Ptr (Ptr, plusPtr)
-import GHC.Storable (Storable(sizeOf,peekElemOff,pokeElemOff,destruct))
+import GHC.Storable (Storable(sizeOf,peekElemOff,pokeElemOff))
import Foreign.Marshal.Alloc (mallocBytes, allocaBytes, reallocBytes)
import Foreign.Marshal.Utils (copyBytes, moveBytes)
import GHC.IOBase
allocaArray len $ \ptr -> do
pokeArray ptr vals
res <- f ptr
- destructArray len ptr
return res
where
len = length vals
allocaArray0 len $ \ptr -> do
pokeArray0 marker ptr vals
res <- f ptr
- destructArray (len+1) ptr
return res
where
len = length vals
--- destruction
--- -----------
-
--- destruct each element of an array (in reverse order)
---
-destructArray :: Storable a => Int -> Ptr a -> IO ()
-destructArray size ptr =
- sequence_ [destruct (ptr `advancePtr` i)
- | i <- [size-1, size-2 .. 0]]
-
--- like `destructArray', but a terminator indicates where the array ends
---
-destructArray0 :: (Storable a, Eq a) => a -> Ptr a -> IO ()
-destructArray0 marker ptr = do
- size <- lengthArray0 marker ptr
- sequence_ [destruct (ptr `advancePtr` i)
- | i <- [size, size-1 .. 0]]
-
-
-- copying (argument order: destination, source)
-- -------
-- Stability : provisional
-- Portability : portable
--
--- $Id: Utils.hs,v 1.2 2001/07/03 11:37:50 simonmar Exp $
+-- $Id: Utils.hs,v 1.3 2002/02/05 17:32:25 simonmar Exp $
--
-- Utilities for primitive marshaling
--
#ifdef __GLASGOW_HASKELL__
import Foreign.Ptr ( Ptr, nullPtr )
-import GHC.Storable ( Storable(poke,destruct) )
-import Foreign.C.TypesISO ( CSize )
-import Foreign.Marshal.Alloc ( malloc, alloca )
+import GHC.Storable ( Storable(poke) )
+import Foreign.C.TypesISO ( CSize )
+import Foreign.Marshal.Alloc ( malloc, alloca )
import GHC.IOBase
-import GHC.Real ( fromIntegral )
+import GHC.Real ( fromIntegral )
import GHC.Num
import GHC.Base
#endif
alloca $ \ptr -> do
poke ptr val
res <- f ptr
- destruct ptr
return res
-- basic C routines needed for memory copying
--
-foreign import unsafe memcpy :: Ptr a -> Ptr a -> CSize -> IO ()
-foreign import unsafe memmove :: Ptr a -> Ptr a -> CSize -> IO ()
+foreign import ccall unsafe memcpy :: Ptr a -> Ptr a -> CSize -> IO ()
+foreign import ccall unsafe memmove :: Ptr a -> Ptr a -> CSize -> IO ()
-- Stability : provisional
-- Portability : portable
--
--- $Id: Storable.hs,v 1.2 2001/07/03 11:37:50 simonmar Exp $
+-- $Id: Storable.hs,v 1.3 2002/02/05 17:32:25 simonmar Exp $
--
-- A class for primitive marshaling
--
peekByteOff, -- :: Ptr b -> Int -> IO a
pokeByteOff, -- :: Ptr b -> Int -> a -> IO ()
peek, -- :: Ptr a -> IO a
- poke, -- :: Ptr a -> a -> IO ()
- destruct) -- :: Ptr a -> IO ()
+ poke) -- :: Ptr a -> a -> IO ()
) where
#ifdef __GLASGOW_HASKELL__
% -----------------------------------------------------------------------------
-% $Id: Base.lhs,v 1.4 2001/12/21 15:07:22 simonmar Exp $
+% $Id: Base.lhs,v 1.5 2002/02/05 17:32:26 simonmar Exp $
%
% (c) The University of Glasgow, 1992-2000
%
"foldr/augment" forall k z xs (g::forall b. (a->b->b) -> b -> b) .
foldr k z (augment g xs) = g k (foldr k z xs)
-"foldr/id" foldr (:) [] = \x->x
-"foldr/app" forall xs ys. foldr (:) ys xs = append xs ys
+"foldr/id" foldr (:) [] = \x->x
+"foldr/app" [1] forall xs ys. foldr (:) ys xs = xs ++ ys
+ -- Only activate this from phase 1, because that's
+ -- when we disable the rule that expands (++) into foldr
-- The foldr/cons rule looks nice, but it can give disastrously
-- bloated code when commpiling
\begin{code}
map :: (a -> b) -> [a] -> [b]
-{-# NOINLINE [1] map #-}
-map = mapList
+map _ [] = []
+map f (x:xs) = f x : map f xs
-- Note eta expanded
mapFB :: (elt -> lst -> lst) -> (a -> elt) -> a -> lst -> lst
+{-# INLINE [0] mapFB #-}
mapFB c f x ys = c (f x) ys
-mapList :: (a -> b) -> [a] -> [b]
-mapList _ [] = []
-mapList f (x:xs) = f x : mapList f xs
+-- The rules for map work like this.
+--
+-- Up to (but not including) phase 1, we use the "map" rule to
+-- rewrite all saturated applications of map with its build/fold
+-- form, hoping for fusion to happen.
+-- In phase 1 and 0, we switch off that rule, inline build, and
+-- switch on the "mapList" rule, which rewrites the foldr/mapFB
+-- thing back into plain map.
+--
+-- It's important that these two rules aren't both active at once
+-- (along with build's unfolding) else we'd get an infinite loop
+-- in the rules. Hence the activation control below.
+--
+-- The "mapFB" rule optimises compositions of map.
+--
+-- This same pattern is followed by many other functions:
+-- e.g. append, filter, iterate, repeat, etc.
{-# RULES
-"map" forall f xs. map f xs = build (\c n -> foldr (mapFB c f) n xs)
+"map" [~1] forall f xs. map f xs = build (\c n -> foldr (mapFB c f) n xs)
+"mapList" [1] forall f. foldr (mapFB (:) f) [] = map f
"mapFB" forall c f g. mapFB (mapFB c f) g = mapFB c (f.g)
-"mapList" forall f. foldr (mapFB (:) f) [] = mapList f
#-}
\end{code}
----------------------------------------------
\begin{code}
(++) :: [a] -> [a] -> [a]
-{-# NOINLINE [1] (++) #-}
-(++) = append
+(++) [] ys = ys
+(++) (x:xs) ys = x : xs ++ ys
{-# RULES
-"++" forall xs ys. xs ++ ys = augment (\c n -> foldr c n xs) ys
+"++" [~1] forall xs ys. xs ++ ys = augment (\c n -> foldr c n xs) ys
#-}
-append :: [a] -> [a] -> [a]
-append [] ys = ys
-append (x:xs) ys = x : append xs ys
\end{code}
ch -> unpack (C# ch : acc) (i# -# 1#)
{-# RULES
-"unpack" forall a . unpackCString# a = build (unpackFoldrCString# a)
-"unpack-list" forall a . unpackFoldrCString# a (:) [] = unpackCStringList# a
-"unpack-append" forall a n . unpackFoldrCString# a (:) n = unpackAppendCString# a n
+"unpack" [~1] forall a . unpackCString# a = build (unpackFoldrCString# a)
+"unpack-list" [1] forall a . unpackFoldrCString# a (:) [] = unpackCStringList# a
+"unpack-append" forall a n . unpackFoldrCString# a (:) n = unpackAppendCString# a n
-- There's a built-in rule (in GHC.Rules.lhs) for
-- unpackFoldr "foo" c (unpackFoldr "baz" c n) = unpackFoldr "foobaz" c n
% -----------------------------------------------------------------------------
-% $Id: Enum.lhs,v 1.6 2001/12/21 15:07:22 simonmar Exp $
+% $Id: Enum.lhs,v 1.7 2002/02/05 17:32:26 simonmar Exp $
%
% (c) The University of Glasgow, 1992-2000
%
{-# INLINE enumFromThenTo #-}
enumFromThenTo (C# x1) (C# x2) (C# y) = efdtChar (ord# x1) (ord# x2) (ord# y)
-{-# NOINLINE [1] eftChar #-}
-{-# NOINLINE [1] efdChar #-}
-{-# NOINLINE [1] efdtChar #-}
-eftChar = eftCharList
-efdChar = efdCharList
-efdtChar = efdtCharList
-
{-# RULES
-"eftChar" forall x y. eftChar x y = build (\c n -> eftCharFB c n x y)
-"efdChar" forall x1 x2. efdChar x1 x2 = build (\ c n -> efdCharFB c n x1 x2)
-"efdtChar" forall x1 x2 l. efdtChar x1 x2 l = build (\ c n -> efdtCharFB c n x1 x2 l)
-"eftCharList" eftCharFB (:) [] = eftCharList
-"efdCharList" efdCharFB (:) [] = efdCharList
-"efdtCharList" efdtCharFB (:) [] = efdtCharList
+"eftChar" [~1] forall x y. eftChar x y = build (\c n -> eftCharFB c n x y)
+"efdChar" [~1] forall x1 x2. efdChar x1 x2 = build (\ c n -> efdCharFB c n x1 x2)
+"efdtChar" [~1] forall x1 x2 l. efdtChar x1 x2 l = build (\ c n -> efdtCharFB c n x1 x2 l)
+"eftCharList" [1] eftCharFB (:) [] = eftChar
+"efdCharList" [1] efdCharFB (:) [] = efdChar
+"efdtCharList" [1] efdtCharFB (:) [] = efdtChar
#-}
go x | x ># y = n
| otherwise = C# (chr# x) `c` go (x +# 1#)
-eftCharList x y | x ># y = []
- | otherwise = C# (chr# x) : eftCharList (x +# 1#) y
+eftChar x y | x ># y = []
+ | otherwise = C# (chr# x) : eftChar (x +# 1#) y
-- For enumFromThenTo we give up on inlining
where
delta = x2 -# x1
-efdCharList x1 x2
+efdChar x1 x2
| delta >=# 0# = go_up_char_list x1 delta 0x10FFFF#
| otherwise = go_dn_char_list x1 delta 0#
where
where
delta = x2 -# x1
-efdtCharList x1 x2 lim
+efdtChar x1 x2 lim
| delta >=# 0# = go_up_char_list x1 delta lim
| otherwise = go_dn_char_list x1 delta lim
where
{-# INLINE enumFromThenTo #-}
enumFromThenTo (I# x1) (I# x2) (I# y) = efdtInt x1 x2 y
-{-# NOINLINE [1] eftInt #-}
-{-# NOINLINE [1] efdInt #-}
-{-# NOINLINE [1] efdtInt #-}
-eftInt = eftIntList
-efdInt = efdIntList
-efdtInt = efdtIntList
-
{-# RULES
-"eftInt" forall x y. eftInt x y = build (\ c n -> eftIntFB c n x y)
-"efdInt" forall x1 x2. efdInt x1 x2 = build (\ c n -> efdIntFB c n x1 x2)
-"efdtInt" forall x1 x2 l. efdtInt x1 x2 l = build (\ c n -> efdtIntFB c n x1 x2 l)
+"eftInt" [~1] forall x y. eftInt x y = build (\ c n -> eftIntFB c n x y)
+"efdInt" [~1] forall x1 x2. efdInt x1 x2 = build (\ c n -> efdIntFB c n x1 x2)
+"efdtInt" [~1] forall x1 x2 l. efdtInt x1 x2 l = build (\ c n -> efdtIntFB c n x1 x2 l)
-"eftIntList" eftIntFB (:) [] = eftIntList
-"efdIntList" efdIntFB (:) [] = efdIntList
-"efdtIntList" efdtIntFB (:) [] = efdtIntList
+"eftIntList" [1] eftIntFB (:) [] = eftInt
+"efdIntList" [1] efdIntFB (:) [] = efdInt
+"efdtIntList" [1] efdtIntFB (:) [] = efdtInt
#-}
-- so that when eftInfFB is inlined we can inline
-- whatver is bound to "c"
-eftIntList x y | x ># y = []
+eftInt x y | x ># y = []
| otherwise = go x
where
go x = I# x : if x ==# y then [] else go (x +# 1#)
delta = x2 -# x1
lim = y -# delta
-efdtIntList x1 x2 y
+efdtInt x1 x2 y
| delta >=# 0# = if x1 ># y then [] else go_up_int_list x1 delta lim
| otherwise = if x1 <# y then [] else go_dn_int_list x1 delta lim
where
where
delta = x2 -# x1
-efdIntList x1 x2
+efdInt x1 x2
| delta >=# 0# = case maxInt of I# y -> go_up_int_list x1 delta (y -# delta)
| otherwise = case minInt of I# y -> go_dn_int_list x1 delta (y -# delta)
where
% ------------------------------------------------------------------------------
-% $Id: Exception.lhs,v 1.2 2001/07/03 14:13:32 simonmar Exp $
+% $Id: Exception.lhs,v 1.3 2002/02/05 17:32:26 simonmar Exp $
%
% (c) The University of Glasgow, 1998-2000
%
catch :: IO a -> (Exception -> IO a) -> IO a
catch m k = catchException m handler
where handler err@(IOException _) = k err
- handler err@(UserError _) = k err
handler other = throw other
\end{code}
% ------------------------------------------------------------------------------
-% $Id: Float.lhs,v 1.3 2001/12/21 15:07:22 simonmar Exp $
+% $Id: Float.lhs,v 1.4 2002/02/05 17:32:26 simonmar Exp $
%
% (c) The University of Glasgow, 1994-2000
%
\end{code}
\begin{code}
-foreign import ccall "__encodeFloat" unsafe
+foreign import ccall unsafe "__encodeFloat"
encodeFloat# :: Int# -> ByteArray# -> Int -> Float
-foreign import ccall "__int_encodeFloat" unsafe
+foreign import ccall unsafe "__int_encodeFloat"
int_encodeFloat# :: Int# -> Int -> Float
-foreign import ccall "isFloatNaN" unsafe isFloatNaN :: Float -> Int
-foreign import ccall "isFloatInfinite" unsafe isFloatInfinite :: Float -> Int
-foreign import ccall "isFloatDenormalized" unsafe isFloatDenormalized :: Float -> Int
-foreign import ccall "isFloatNegativeZero" unsafe isFloatNegativeZero :: Float -> Int
+foreign import ccall unsafe "isFloatNaN" isFloatNaN :: Float -> Int
+foreign import ccall unsafe "isFloatInfinite" isFloatInfinite :: Float -> Int
+foreign import ccall unsafe "isFloatDenormalized" isFloatDenormalized :: Float -> Int
+foreign import ccall unsafe "isFloatNegativeZero" isFloatNegativeZero :: Float -> Int
-foreign import ccall "__encodeDouble" unsafe
+foreign import ccall unsafe "__encodeDouble"
encodeDouble# :: Int# -> ByteArray# -> Int -> Double
-foreign import ccall "__int_encodeDouble" unsafe
+foreign import ccall unsafe "__int_encodeDouble"
int_encodeDouble# :: Int# -> Int -> Double
-foreign import ccall "isDoubleNaN" unsafe isDoubleNaN :: Double -> Int
-foreign import ccall "isDoubleInfinite" unsafe isDoubleInfinite :: Double -> Int
-foreign import ccall "isDoubleDenormalized" unsafe isDoubleDenormalized :: Double -> Int
-foreign import ccall "isDoubleNegativeZero" unsafe isDoubleNegativeZero :: Double -> Int
+foreign import ccall unsafe "isDoubleNaN" isDoubleNaN :: Double -> Int
+foreign import ccall unsafe "isDoubleInfinite" isDoubleInfinite :: Double -> Int
+foreign import ccall unsafe "isDoubleDenormalized" isDoubleDenormalized :: Double -> Int
+foreign import ccall unsafe "isDoubleNegativeZero" isDoubleNegativeZero :: Double -> Int
\end{code}
%*********************************************************
#undef DEBUG
-- -----------------------------------------------------------------------------
--- $Id: Handle.hs,v 1.2 2002/01/02 14:40:10 simonmar Exp $
+-- $Id: Handle.hs,v 1.3 2002/02/05 17:32:26 simonmar Exp $
--
-- (c) The University of Glasgow, 1994-2001
--
newEmptyBuffer, allocateBuffer, readCharFromBuffer, writeCharIntoBuffer,
flushWriteBufferOnly, flushWriteBuffer, flushReadBuffer, fillReadBuffer,
- read_off,
+ read_off, read_off_ba,
+ write_off, write_off_ba,
ioe_closedHandle, ioe_EOF, ioe_notReadable, ioe_notWritable,
hIsOpen, hIsClosed, hIsReadable, hIsWritable, hGetBuffering, hIsSeekable,
hSetEcho, hGetEcho, hIsTerminalDevice,
- ioeGetFileName, ioeGetErrorString, ioeGetHandle,
#ifdef DEBUG_DUMP
puts,
import Data.Maybe
import Foreign
import Foreign.C
+import System.IO.Error
import GHC.Posix
import GHC.Real
then return (buf{ bufRPtr=0, bufWPtr=0 })
else do
res <- throwErrnoIfMinus1RetryMayBlock "flushWriteBuffer"
- (write_off (fromIntegral fd) is_stream b (fromIntegral r)
- (fromIntegral bytes))
+ (write_off_ba (fromIntegral fd) is_stream b (fromIntegral r)
+ (fromIntegral bytes))
(threadWaitWrite fd)
let res' = fromIntegral res
if res' < bytes
then flushWriteBuffer fd is_stream (buf{ bufRPtr = r + res' })
else return buf{ bufRPtr=0, bufWPtr=0 }
-foreign import "__hscore_PrelHandle_write" unsafe
- write_off :: CInt -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
+foreign import ccall unsafe "__hscore_PrelHandle_write"
+ write_off_ba :: CInt -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
+foreign import ccall unsafe "__hscore_PrelHandle_write"
+ write_off :: CInt -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
fillReadBuffer :: FD -> Bool -> Bool -> Buffer -> IO Buffer
fillReadBuffer fd is_line is_stream
puts ("fillReadBufferLoop: bytes = " ++ show bytes ++ "\n")
#endif
res <- throwErrnoIfMinus1RetryMayBlock "fillReadBuffer"
- (read_off fd is_stream b (fromIntegral w) (fromIntegral bytes))
+ (read_off_ba fd is_stream b (fromIntegral w) (fromIntegral bytes))
(threadWaitRead fd)
let res' = fromIntegral res
#ifdef DEBUG_DUMP
then fillReadBufferLoop fd is_line is_stream buf b (w+res') size
else return buf{ bufRPtr=0, bufWPtr=w+res' }
-foreign import "__hscore_PrelHandle_read" unsafe
- read_off :: FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
+foreign import ccall unsafe "__hscore_PrelHandle_read"
+ read_off_ba :: FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
+
+foreign import ccall unsafe "__hscore_PrelHandle_read"
+ read_off :: FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
-- ---------------------------------------------------------------------------
-- Standard Handles
| otherwise = False
binary_flags
- | binary = GHC.Handle.o_BINARY
+ | binary = o_BINARY
| otherwise = 0
oflags = oflags1 .|. binary_flags
mkFileHandle fd is_stream filepath ha_type binary
-foreign import "lockFile" unsafe
+foreign import ccall unsafe "lockFile"
lockFile :: CInt -> CInt -> CInt -> IO CInt
-foreign import "unlockFile" unsafe
+foreign import ccall unsafe "unlockFile"
unlockFile :: CInt -> IO CInt
mkStdHandle :: FD -> FilePath -> HandleType -> IORef Buffer -> BufferMode
case haType handle_ of
ClosedHandle -> return handle_
_ -> do
- let fd = fromIntegral (haFD handle_)
+ let fd = haFD handle_
+ c_fd = fromIntegral fd
+
flushWriteBufferOnly handle_
- -- close the file descriptor, but not when this is the read side
- -- of a duplex handle.
+ -- close the file descriptor, but not when this is the read
+ -- side of a duplex handle, and not when this is one of the
+ -- std file handles.
case haOtherSide handle_ of
- Nothing -> throwErrnoIfMinus1Retry_ "hClose"
+ Nothing ->
+ when (fd /= fd_stdin && fd /= fd_stdout && fd /= fd_stderr) $
+ throwErrnoIfMinus1Retry_ "hClose"
#ifdef mingw32_TARGET_OS
- (closeFd (haIsStream handle_) fd)
+ (closeFd (haIsStream handle_) c_fd)
#else
- (c_close fd)
+ (c_close c_fd)
#endif
Just _ -> return ()
writeIORef (haBuffers handle_) BufferListNil
-- unlock it
- unlockFile fd
+ unlockFile c_fd
-- we must set the fd to -1, because the finalizer is going
-- to run eventually and try to close/unlock it.
(setmode (fromIntegral (haFD handle_)) bin)
return handle_{haIsBin=bin}
-foreign import "__hscore_setmode" unsafe
+foreign import ccall unsafe "__hscore_setmode"
setmode :: CInt -> Bool -> IO CInt
--- -----------------------------------------------------------------------------
--- 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))
+puts s = withCString s $ \cstr -> do write_off_ba 1 False cstr 0 (fromIntegral (length s))
return ()
#endif
-- -----------------------------------------------------------------------------
-- wrappers to platform-specific constants:
-foreign import ccall "__hscore_supportsTextMode" unsafe
+foreign import ccall unsafe "__hscore_supportsTextMode"
tEXT_MODE_SEEK_ALLOWED :: Bool
-foreign import ccall "__hscore_bufsiz" unsafe dEFAULT_BUFFER_SIZE :: Int
-foreign import ccall "__hscore_seek_cur" unsafe sEEK_CUR :: CInt
-foreign import ccall "__hscore_seek_set" unsafe sEEK_SET :: CInt
-foreign import ccall "__hscore_seek_end" unsafe sEEK_END :: CInt
-foreign import ccall "__hscore_o_binary" unsafe o_BINARY :: CInt
-
-
+foreign import ccall unsafe "__hscore_bufsiz" dEFAULT_BUFFER_SIZE :: Int
+foreign import ccall unsafe "__hscore_seek_cur" sEEK_CUR :: CInt
+foreign import ccall unsafe "__hscore_seek_set" sEEK_SET :: CInt
+foreign import ccall unsafe "__hscore_seek_end" sEEK_END :: CInt
#undef DEBUG_DUMP
-- -----------------------------------------------------------------------------
--- $Id: IO.hs,v 1.2 2002/01/02 14:40:10 simonmar Exp $
+-- $Id: IO.hs,v 1.3 2002/02/05 17:32:26 simonmar Exp $
--
-- (c) The University of Glasgow, 1992-2001
--
import Foreign
import Foreign.C
+import System.IO.Error
import Data.Maybe
import Control.Monad
(inputReady (fromIntegral (haFD handle_)) (fromIntegral msecs) (haIsStream handle_))
return (r /= 0)
-foreign import "inputReady" unsafe
+foreign import ccall unsafe "inputReady"
inputReady :: CInt -> CInt -> Bool -> IO CInt
-- ---------------------------------------------------------------------------
-- make use of the minimal buffer we already have
let raw = bufBuf buf
r <- throwErrnoIfMinus1RetryMayBlock "hGetChar"
- (read_off (fromIntegral fd) (haIsStream handle_) raw 0 1)
+ (read_off_ba (fromIntegral fd) (haIsStream handle_) raw 0 1)
(threadWaitRead fd)
if r == 0
then ioe_EOF
-- make use of the minimal buffer we already have
let raw = bufBuf buf
r <- throwErrnoIfMinus1RetryMayBlock "lazyRead"
- (read_off (fromIntegral fd) (haIsStream handle_) raw 0 1)
+ (read_off_ba (fromIntegral fd) (haIsStream handle_) raw 0 1)
(threadWaitRead fd)
if r == 0
then do handle_ <- hClose_help handle_
NoBuffering ->
withObject (castCharToCChar c) $ \buf ->
throwErrnoIfMinus1RetryMayBlock_ "hPutChar"
- (c_write (fromIntegral fd) buf 1)
+ (write_off (fromIntegral fd) (haIsStream handle_) buf 0 1)
(threadWaitWrite fd)
-- ---------------------------------------------------------------------------
-- memcpy wrappers
-foreign import "__hscore_memcpy_src_off" unsafe
+foreign import ccall unsafe "__hscore_memcpy_src_off"
memcpy_ba_baoff :: RawBuffer -> RawBuffer -> Int -> CSize -> IO (Ptr ())
-foreign import "__hscore_memcpy_src_off" unsafe
+foreign import ccall unsafe "__hscore_memcpy_src_off"
memcpy_ptr_baoff :: Ptr a -> RawBuffer -> Int -> CSize -> IO (Ptr ())
-foreign import "__hscore_memcpy_dst_off" unsafe
+foreign import ccall unsafe "__hscore_memcpy_dst_off"
memcpy_baoff_ba :: RawBuffer -> Int -> RawBuffer -> CSize -> IO (Ptr ())
-foreign import "__hscore_memcpy_dst_off" unsafe
+foreign import ccall unsafe "__hscore_memcpy_dst_off"
memcpy_baoff_ptr :: RawBuffer -> Int -> Ptr a -> CSize -> IO (Ptr ())
-----------------------------------------------------------------------------
% ------------------------------------------------------------------------------
-% $Id: IOBase.lhs,v 1.5 2001/12/21 15:07:25 simonmar Exp $
+% $Id: IOBase.lhs,v 1.6 2002/02/05 17:32:26 simonmar Exp $
%
% (c) The University of Glasgow, 1994-2001
%
| DynException Dynamic -- Dynamic exceptions
| AsyncException AsyncException -- Externally generated errors
| BlockedOnDeadMVar -- Blocking on a dead MVar
+ | Deadlock -- no threads can run (raised in main thread)
| NonTermination
- | UserError String
data ArithException
= Overflow
showsPrec _ (AsyncException e) = shows e
showsPrec _ (BlockedOnDeadMVar) = showString "thread blocked indefinitely"
showsPrec _ (NonTermination) = showString "<<loop>>"
- showsPrec _ (UserError err) = showString err
+ showsPrec _ (Deadlock) = showString "<<deadlock>>"
+
+instance Eq Exception where
+ IOException e1 == IOException e2 = e1 == e2
+ ArithException e1 == ArithException e2 = e1 == e2
+ ArrayException e1 == ArrayException e2 = e1 == e2
+ ErrorCall e1 == ErrorCall e2 = e1 == e2
+ ExitException e1 == ExitException e2 = e1 == e2
+ NoMethodError e1 == NoMethodError e2 = e1 == e2
+ PatternMatchFail e1 == PatternMatchFail e2 = e1 == e2
+ RecSelError e1 == RecSelError e2 = e1 == e2
+ RecConError e1 == RecConError e2 = e1 == e2
+ RecUpdError e1 == RecUpdError e2 = e1 == e2
+ AssertionFailed e1 == AssertionFailed e2 = e1 == e2
+ DynException _ == DynException _ = False -- incomparable
+ AsyncException e1 == AsyncException e2 = e1 == e2
+ BlockedOnDeadMVar == BlockedOnDeadMVar = True
+ NonTermination == NonTermination = True
+ Deadlock == Deadlock = True
-- -----------------------------------------------------------------------------
-- The ExitCode type
type IOError = Exception
data IOException
- = IOError
- (Maybe Handle) -- the handle used by the action flagging the
- -- the error.
- IOErrorType -- what it was.
- String -- location.
- String -- error type specific information.
- (Maybe FilePath) -- filename the error is related to.
+ = IOError {
+ ioe_handle :: Maybe Handle, -- the handle used by the action flagging
+ -- the error.
+ ioe_type :: IOErrorType, -- what it was.
+ ioe_location :: String, -- location.
+ ioe_descr :: String, -- error type specific information.
+ ioe_filename :: Maybe FilePath -- filename the error is related to.
+ }
instance Eq IOException where
(IOError h1 e1 loc1 str1 fn1) == (IOError h2 e2 loc2 str2 fn2) =
data IOErrorType
-- Haskell 98:
= AlreadyExists
- | EOF
- | IllegalOperation
| NoSuchThing
- | PermissionDenied
| ResourceBusy
| ResourceExhausted
+ | EOF
+ | IllegalOperation
+ | PermissionDenied
+ | UserError
-- GHC only:
| UnsatisfiedConstraints
| SystemError
showString $
case e of
AlreadyExists -> "already exists"
- HardwareFault -> "hardware fault"
+ NoSuchThing -> "does not exist"
+ ResourceBusy -> "resource busy"
+ ResourceExhausted -> "resource exhausted"
+ EOF -> "end of file"
IllegalOperation -> "illegal operation"
+ PermissionDenied -> "permission denied"
+ UserError -> "user error"
+ HardwareFault -> "hardware fault"
InappropriateType -> "inappropriate type"
Interrupted -> "interrupted"
InvalidArgument -> "invalid argument"
- NoSuchThing -> "does not exist"
OtherError -> "failed"
- PermissionDenied -> "permission denied"
ProtocolError -> "protocol error"
- ResourceBusy -> "resource busy"
- ResourceExhausted -> "resource exhausted"
ResourceVanished -> "resource vanished"
SystemError -> "system error"
TimeExpired -> "timeout"
UnsatisfiedConstraints -> "unsatisified constraints" -- ultra-precise!
UnsupportedOperation -> "unsupported operation"
- EOF -> "end of file"
DynIOError{} -> "unknown IO error"
userError :: String -> IOError
-userError str = UserError str
-
--- ---------------------------------------------------------------------------
--- Predicates on IOError
-
-isAlreadyExistsError :: IOError -> Bool
-isAlreadyExistsError (IOException (IOError _ AlreadyExists _ _ _)) = True
-isAlreadyExistsError _ = False
-
-isAlreadyInUseError :: IOError -> Bool
-isAlreadyInUseError (IOException (IOError _ ResourceBusy _ _ _)) = True
-isAlreadyInUseError _ = False
-
-isFullError :: IOError -> Bool
-isFullError (IOException (IOError _ ResourceExhausted _ _ _)) = True
-isFullError _ = False
-
-isEOFError :: IOError -> Bool
-isEOFError (IOException (IOError _ EOF _ _ _)) = True
-isEOFError _ = False
-
-isIllegalOperation :: IOError -> Bool
-isIllegalOperation (IOException (IOError _ IllegalOperation _ _ _)) = True
-isIllegalOperation _ = False
-
-isPermissionError :: IOError -> Bool
-isPermissionError (IOException (IOError _ PermissionDenied _ _ _)) = True
-isPermissionError _ = False
-
-isDoesNotExistError :: IOError -> Bool
-isDoesNotExistError (IOException (IOError _ NoSuchThing _ _ _)) = True
-isDoesNotExistError _ = False
-
-isUserError :: IOError -> Bool
-isUserError (UserError _) = True
-isUserError _ = False
+userError str = IOException (IOError Nothing UserError "" str Nothing)
-- ---------------------------------------------------------------------------
-- Showing IOErrors
% ------------------------------------------------------------------------------
-% $Id: List.lhs,v 1.5 2001/12/21 15:07:25 simonmar Exp $
+% $Id: List.lhs,v 1.6 2002/02/05 17:32:26 simonmar Exp $
%
% (c) The University of Glasgow, 1994-2000
%
-- filter, applied to a predicate and a list, returns the list of those
-- elements that satisfy the predicate; i.e.,
-- filter p xs = [ x | x <- xs, p x]
-{-# NOINLINE [1] filter #-}
filter :: (a -> Bool) -> [a] -> [a]
-filter = filterList
+filter _pred [] = []
+filter pred (x:xs)
+ | pred x = x : filter pred xs
+ | otherwise = filter pred xs
-{-# INLINE [0] filter #-}
+{-# NOINLINE [0] filterFB #-}
filterFB c p x r | p x = x `c` r
| otherwise = r
{-# RULES
-"filter" forall p xs. filter p xs = build (\c n -> foldr (filterFB c p) n xs)
-"filterFB" forall c p q. filterFB (filterFB c p) q = filterFB c (\x -> q x && p x)
-"filterList" forall p. foldr (filterFB (:) p) [] = filterList p
+"filter" [~1] forall p xs. filter p xs = build (\c n -> foldr (filterFB c p) n xs)
+"filterList" [1] forall p. foldr (filterFB (:) p) [] = filter p
+"filterFB" forall c p q. filterFB (filterFB c p) q = filterFB c (\x -> q x && p x)
#-}
-- Note the filterFB rule, which has p and q the "wrong way round" in the RHS.
-- I originally wrote (\x -> p x && q x), which is wrong, and actually
-- gave rise to a live bug report. SLPJ.
-filterList :: (a -> Bool) -> [a] -> [a]
-filterList _pred [] = []
-filterList pred (x:xs)
- | pred x = x : filterList pred xs
- | otherwise = filterList pred xs
-- foldl, applied to a binary operator, a starting value (typically the
-- left-identity of the operator), and a list, reduces the list using
-- iterate f x returns an infinite list of repeated applications of f to x:
-- iterate f x == [x, f x, f (f x), ...]
iterate :: (a -> a) -> a -> [a]
-{-# NOINLINE [1] iterate #-}
-iterate = iterateList
+iterate f x = x : iterate f (f x)
iterateFB c f x = x `c` iterateFB c f (f x)
-iterateList f x = x : iterateList f (f x)
{-# RULES
-"iterate" forall f x. iterate f x = build (\c _n -> iterateFB c f x)
-"iterateFB" iterateFB (:) = iterateList
+"iterate" [~1] forall f x. iterate f x = build (\c _n -> iterateFB c f x)
+"iterateFB" [1] iterateFB (:) = iterate
#-}
-- repeat x is an infinite list, with x the value of every element.
repeat :: a -> [a]
-{-# NOINLINE [1] repeat #-}
-repeat = repeatList
+{-# INLINE [0] repeat #-}
+-- The pragma just gives the rules more chance to fire
+repeat x = xs where xs = x : xs
-{-# INLINE [0] repeatFB #-}
+{-# INLINE [0] repeatFB #-} -- ditto
repeatFB c x = xs where xs = x `c` xs
-repeatList x = xs where xs = x : xs
{-# RULES
-"repeat" forall x. repeat x = build (\c _n -> repeatFB c x)
-"repeatFB" repeatFB (:) = repeatList
+"repeat" [~1] forall x. repeat x = build (\c _n -> repeatFB c x)
+"repeatFB" [1] repeatFB (:) = repeat
#-}
-- replicate n x is a list of length n with x the value of every element
{-# RULES
"concat" forall xs. concat xs = build (\c n -> foldr (\x y -> foldr c y x) n xs)
+-- We don't bother to turn non-fusible applications of concat back into concat
#-}
+
\end{code}
\begin{code}
----------------------------------------------
zip :: [a] -> [b] -> [(a,b)]
-{-# NOINLINE [1] zip #-}
-zip = zipList
+zip (a:as) (b:bs) = (a,b) : zip as bs
+zip _ _ = []
{-# INLINE [0] zipFB #-}
zipFB c x y r = (x,y) `c` r
-
-zipList :: [a] -> [b] -> [(a,b)]
-zipList (a:as) (b:bs) = (a,b) : zipList as bs
-zipList _ _ = []
-
{-# RULES
-"zip" forall xs ys. zip xs ys = build (\c n -> foldr2 (zipFB c) n xs ys)
-"zipList" foldr2 (zipFB (:)) [] = zipList
+"zip" [~1] forall xs ys. zip xs ys = build (\c n -> foldr2 (zipFB c) n xs ys)
+"zipList" [1] foldr2 (zipFB (:)) [] = zip
#-}
\end{code}
\begin{code}
----------------------------------------------
zipWith :: (a->b->c) -> [a]->[b]->[c]
-{-# NOINLINE [1] zipWith #-}
-zipWith = zipWithList
+zipWith f (a:as) (b:bs) = f a b : zipWith f as bs
+zipWith _ _ _ = []
{-# INLINE [0] zipWithFB #-}
zipWithFB c f x y r = (x `f` y) `c` r
-zipWithList :: (a->b->c) -> [a] -> [b] -> [c]
-zipWithList f (a:as) (b:bs) = f a b : zipWithList f as bs
-zipWithList _ _ _ = []
-
{-# RULES
-"zipWith" forall f xs ys. zipWith f xs ys = build (\c n -> foldr2 (zipWithFB c f) n xs ys)
-"zipWithList" forall f. foldr2 (zipWithFB (:) f) [] = zipWithList f
+"zipWith" [~1] forall f xs ys. zipWith f xs ys = build (\c n -> foldr2 (zipWithFB c f) n xs ys)
+"zipWithList" [1] forall f. foldr2 (zipWithFB (:) f) [] = zipWith f
#-}
\end{code}
% ------------------------------------------------------------------------------
-% $Id: Num.lhs,v 1.3 2001/12/21 15:07:25 simonmar Exp $
+% $Id: Num.lhs,v 1.4 2002/02/05 17:32:26 simonmar Exp $
%
% (c) The University of Glasgow, 1994-2000
%
{-# INLINE enumFromThen #-}
{-# INLINE enumFromTo #-}
{-# INLINE enumFromThenTo #-}
- enumFrom x = efdInteger x 1
- enumFromThen x y = efdInteger x (y-x)
- enumFromTo x lim = efdtInteger x 1 lim
- enumFromThenTo x y lim = efdtInteger x (y-x) lim
-
-
-efdInteger = enumDeltaIntegerList
-efdtInteger = enumDeltaToIntegerList
+ enumFrom x = enumDeltaInteger x 1
+ enumFromThen x y = enumDeltaInteger x (y-x)
+ enumFromTo x lim = enumDeltaToInteger x 1 lim
+ enumFromThenTo x y lim = enumDeltaToInteger x (y-x) lim
{-# RULES
-"efdInteger" forall x y. efdInteger x y = build (\c _ -> enumDeltaIntegerFB c x y)
-"efdtInteger" forall x y l.efdtInteger x y l = build (\c n -> enumDeltaToIntegerFB c n x y l)
-"enumDeltaInteger" enumDeltaIntegerFB (:) = enumDeltaIntegerList
-"enumDeltaToInteger" enumDeltaToIntegerFB (:) [] = enumDeltaToIntegerList
+"enumDeltaInteger" [~1] forall x y. enumDeltaInteger x y = build (\c _ -> enumDeltaIntegerFB c x y)
+"efdtInteger" [~1] forall x y l.enumDeltaToInteger x y l = build (\c n -> enumDeltaToIntegerFB c n x y l)
+"enumDeltaInteger" [1] enumDeltaIntegerFB (:) = enumDeltaInteger
+"enumDeltaToInteger" [1] enumDeltaToIntegerFB (:) [] = enumDeltaToInteger
#-}
enumDeltaIntegerFB :: (Integer -> b -> b) -> Integer -> Integer -> b
enumDeltaIntegerFB c x d = x `c` enumDeltaIntegerFB c (x+d) d
-enumDeltaIntegerList :: Integer -> Integer -> [Integer]
-enumDeltaIntegerList x d = x : enumDeltaIntegerList (x+d) d
+enumDeltaInteger :: Integer -> Integer -> [Integer]
+enumDeltaInteger x d = x : enumDeltaInteger (x+d) d
enumDeltaToIntegerFB c n x delta lim
| delta >= 0 = up_fb c n x delta lim
| otherwise = dn_fb c n x delta lim
-enumDeltaToIntegerList x delta lim
+enumDeltaToInteger x delta lim
| delta >= 0 = up_list x delta lim
| otherwise = dn_list x delta lim
{-# OPTIONS -fno-implicit-prelude #-}
-- ---------------------------------------------------------------------------
--- $Id: Posix.hsc,v 1.6 2002/01/02 15:01:44 simonmar Exp $
+-- $Id: Posix.hs,v 1.1 2002/02/05 17:32:26 simonmar Exp $
--
-- POSIX support layer for the standard libraries
--
module GHC.Posix where
--- See above comment for non-Posixness reasons.
--- #include "PosixSource.h"
-
-#include "HsCore.h"
+#include "config.h"
import Control.Monad
type CUtimbuf = ()
type CUtsname = ()
-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
+type CDev = HTYPE_DEV_T
+type CIno = HTYPE_INO_T
+type CMode = HTYPE_MODE_T
+type COff = HTYPE_OFF_T
+type CPid = HTYPE_PID_T
#ifdef mingw32_TARGET_OS
-type CSsize = #type size_t
+type CSsize = HTYPE_SIZE_T
#else
-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
+type CGid = HTYPE_GID_T
+type CNlink = HTYPE_NLINK_T
+type CSsize = HTYPE_SSIZE_T
+type CUid = HTYPE_UID_T
+type CCc = HTYPE_CC_T
+type CSpeed = HTYPE_SPEED_T
+type CTcflag = HTYPE_TCFLAG_T
#endif
-- ---------------------------------------------------------------------------
fdFileSize :: Int -> IO Integer
fdFileSize fd =
- allocaBytes (#const sizeof(struct stat)) $ \ p_stat -> do
- throwErrnoIfMinus1Retry "fdFileSize" $
+ 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
fileType :: FilePath -> IO FDType
fileType file =
- allocaBytes (#const sizeof(struct stat)) $ \ p_stat -> do
+ allocaBytes sizeof_stat $ \ p_stat -> do
withCString file $ \p_file -> do
throwErrnoIfMinus1Retry "fileType" $
c_stat p_file p_stat
-- 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
statGetType p_stat
statGetType p_stat = do
- 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
| isStream = c_closesocket fd
| otherwise = c_close fd
-foreign import "closesocket" unsafe
+foreign import ccall unsafe "closesocket"
c_closesocket :: CInt -> IO CInt
#endif
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 const_echo
+ | otherwise = c_lflag .&. complement (fromIntegral const_echo)
+ poke_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
+ 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 const_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 const_icanon)
+ | otherwise = c_lflag .&. complement (fromIntegral const_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 const_vmin)) :: Ptr Word8
+ vtime = (c_cc `plusPtr` (fromIntegral const_vtime)) :: Ptr Word8
poke vmin 1
poke vtime 0
- tcSetAttr fd (#const TCSANOW) p_tios
+ 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
tcSetAttr :: FD -> CInt -> Ptr CTermios -> 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 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
+ c_sigprocmask const_sig_setmask p_old_sigset nullPtr
#else
setNonBlockingFD fd = do
flags <- throwErrnoIfMinus1Retry "setNonBlockingFD"
- (c_fcntl_read (fromIntegral fd) (#const F_GETFL))
+ (c_fcntl_read (fromIntegral fd) const_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.
- c_fcntl_write (fromIntegral fd)
- (#const F_SETFL) (flags .|. #const O_NONBLOCK)
+ c_fcntl_write (fromIntegral fd) const_f_setfl (flags .|. o_NONBLOCK)
#else
-- bogus defns for win32
-- -----------------------------------------------------------------------------
-- foreign imports
--- 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
-
-#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
-#endif
-
-#ifdef HAVE_O_BINARY
-o_BINARY = (#const O_BINARY) :: CInt
-#endif
-
-foreign import ccall "access" unsafe
+foreign import ccall unsafe "access"
c_access :: CString -> CMode -> IO CInt
-foreign import ccall "chmod" unsafe
+foreign import ccall unsafe "chmod"
c_chmod :: CString -> CMode -> IO CInt
-foreign import ccall "chdir" unsafe
+foreign import ccall unsafe "chdir"
c_chdir :: CString -> IO CInt
-foreign import ccall "chown" unsafe
+foreign import ccall unsafe "chown"
c_chown :: CString -> CUid -> CGid -> IO CInt
-foreign import ccall "close" unsafe
+foreign import ccall unsafe "close"
c_close :: CInt -> IO CInt
-foreign import ccall "closedir" unsafe
+foreign import ccall unsafe "closedir"
c_closedir :: Ptr CDir -> IO CInt
-foreign import ccall "creat" unsafe
+foreign import ccall unsafe "creat"
c_creat :: CString -> CMode -> IO CInt
-foreign import ccall "dup" unsafe
+foreign import ccall unsafe "dup"
c_dup :: CInt -> IO CInt
-foreign import ccall "dup2" unsafe
+foreign import ccall unsafe "dup2"
c_dup2 :: CInt -> CInt -> IO CInt
-foreign import ccall "fpathconf" unsafe
+foreign import ccall unsafe "fpathconf"
c_fpathconf :: CInt -> CInt -> IO CLong
-foreign import ccall "fstat" unsafe
+foreign import ccall unsafe "fstat"
c_fstat :: CInt -> Ptr CStat -> IO CInt
-foreign import ccall "getcwd" unsafe
+foreign import ccall unsafe "getcwd"
c_getcwd :: Ptr CChar -> CInt -> IO (Ptr CChar)
-foreign import ccall "isatty" unsafe
+foreign import ccall unsafe "isatty"
c_isatty :: CInt -> IO CInt
-foreign import ccall "link" unsafe
+foreign import ccall unsafe "link"
c_link :: CString -> CString -> IO CInt
-foreign import ccall "lseek" unsafe
+foreign import ccall unsafe "lseek"
c_lseek :: CInt -> COff -> CInt -> IO COff
-#ifdef HAVE_LSTAT
-foreign import ccall "lstat" unsafe
- c_lstat :: CString -> Ptr CStat -> IO CInt
-#endif
+foreign import ccall unsafe "__hscore_lstat"
+ lstat :: CString -> Ptr CStat -> IO CInt
-foreign import ccall "open" unsafe
+foreign import ccall unsafe "open"
c_open :: CString -> CInt -> CMode -> IO CInt
-foreign import ccall "opendir" unsafe
+foreign import ccall unsafe "opendir"
c_opendir :: CString -> IO (Ptr CDir)
-foreign import ccall "mkdir" unsafe
-#if defined(mingw32_TARGET_OS)
- c_mkdir :: CString -> IO CInt
-#else
- c_mkdir :: CString -> CMode -> IO CInt
-#endif
+foreign import ccall unsafe "__hscore_mkdir"
+ mkdir :: CString -> CInt -> IO CInt
-foreign import ccall "mkfifo" unsafe
+foreign import ccall unsafe "mkfifo"
c_mkfifo :: CString -> CMode -> IO CInt
-foreign import ccall "pathconf" unsafe
+foreign import ccall unsafe "pathconf"
c_pathconf :: CString -> CInt -> IO CLong
-foreign import ccall "pipe" unsafe
+foreign import ccall unsafe "pipe"
c_pipe :: Ptr CInt -> IO CInt
-foreign import ccall "read" unsafe
+foreign import ccall unsafe "read"
c_read :: CInt -> Ptr CChar -> CSize -> IO CSsize
-foreign import ccall "readdir" unsafe
+foreign import ccall unsafe "readdir"
c_readdir :: Ptr CDir -> IO (Ptr CDirent)
-foreign import ccall "rename" unsafe
+foreign import ccall unsafe "rename"
c_rename :: CString -> CString -> IO CInt
-foreign import ccall "rewinddir" unsafe
+foreign import ccall unsafe "rewinddir"
c_rewinddir :: Ptr CDir -> IO ()
-foreign import ccall "rmdir" unsafe
+foreign import ccall unsafe "rmdir"
c_rmdir :: CString -> IO CInt
-foreign import ccall "stat" unsafe
+foreign import ccall unsafe "stat"
c_stat :: CString -> Ptr CStat -> IO CInt
-foreign import ccall "umask" unsafe
+foreign import ccall unsafe "umask"
c_umask :: CMode -> IO CMode
-foreign import ccall "utime" unsafe
+foreign import ccall unsafe "utime"
c_utime :: CString -> Ptr CUtimbuf -> IO CMode
-foreign import ccall "write" unsafe
+foreign import ccall unsafe "write"
c_write :: CInt -> Ptr CChar -> CSize -> IO CSsize
#ifndef mingw32_TARGET_OS
-foreign import ccall "fcntl" unsafe
+foreign import ccall unsafe "fcntl"
c_fcntl_read :: CInt -> CInt -> IO CInt
-foreign import ccall "fcntl" unsafe
+foreign import ccall unsafe "fcntl"
c_fcntl_write :: CInt -> CInt -> CInt -> IO CInt
-foreign import ccall "fcntl" unsafe
+foreign import ccall unsafe "fcntl"
c_fcntl_lock :: CInt -> CInt -> Ptr CFLock -> IO CInt
-foreign import ccall "fork" unsafe
+foreign import ccall unsafe "fork"
c_fork :: IO CPid
-foreign import ccall "__hscore_sigemptyset" unsafe
+foreign import ccall unsafe "__hscore_sigemptyset"
c_sigemptyset :: Ptr CSigset -> IO ()
-foreign import ccall "sigaddset" unsafe
+foreign import ccall unsafe "sigaddset"
c_sigaddset :: Ptr CSigset -> CInt -> IO ()
-foreign import ccall "sigprocmask" unsafe
+foreign import ccall unsafe "sigprocmask"
c_sigprocmask :: CInt -> Ptr CSigset -> Ptr CSigset -> IO ()
-foreign import ccall "tcgetattr" unsafe
+foreign import ccall unsafe "tcgetattr"
c_tcgetattr :: CInt -> Ptr CTermios -> IO CInt
-foreign import ccall "tcsetattr" unsafe
+foreign import ccall unsafe "tcsetattr"
c_tcsetattr :: CInt -> CInt -> Ptr CTermios -> IO CInt
-foreign import ccall "uname" unsafe
+foreign import ccall unsafe "uname"
c_uname :: Ptr CUtsname -> IO CInt
-foreign import ccall "unlink" unsafe
+foreign import ccall unsafe "unlink"
c_unlink :: CString -> IO CInt
-foreign import ccall "waitpid" unsafe
+foreign import ccall unsafe "waitpid"
c_waitpid :: CPid -> Ptr CInt -> CInt -> IO CPid
#endif
-foreign import "__hscore_s_isreg" unsafe s_isreg :: CMode -> Bool
-foreign import "__hscore_s_ischr" unsafe s_ischr :: CMode -> Bool
-foreign import "__hscore_s_isblk" unsafe s_isblk :: CMode -> Bool
-foreign import "__hscore_s_isdir" unsafe s_isdir :: CMode -> Bool
-foreign import "__hscore_s_isfifo" unsafe s_isfifo :: CMode -> Bool
+-- POSIX flags only:
+foreign import ccall unsafe "__hscore_o_rdonly" o_RDONLY :: CInt
+foreign import ccall unsafe "__hscore_o_wronly" o_WRONLY :: CInt
+foreign import ccall unsafe "__hscore_o_rdwr" o_RDWR :: CInt
+foreign import ccall unsafe "__hscore_o_append" o_APPEND :: CInt
+foreign import ccall unsafe "__hscore_o_creat" o_CREAT :: CInt
+foreign import ccall unsafe "__hscore_o_excl" o_EXCL :: CInt
+foreign import ccall unsafe "__hscore_o_trunc" o_TRUNC :: CInt
+
+-- non-POSIX flags.
+foreign import ccall unsafe "__hscore_o_noctty" o_NOCTTY :: CInt
+foreign import ccall unsafe "__hscore_o_nonblock" o_NONBLOCK :: CInt
+foreign import ccall unsafe "__hscore_o_binary" o_BINARY :: CInt
+
+foreign import ccall unsafe "__hscore_s_isreg" s_isreg :: CMode -> Bool
+foreign import ccall unsafe "__hscore_s_ischr" s_ischr :: CMode -> Bool
+foreign import ccall unsafe "__hscore_s_isblk" s_isblk :: CMode -> Bool
+foreign import ccall unsafe "__hscore_s_isdir" s_isdir :: CMode -> Bool
+foreign import ccall unsafe "__hscore_s_isfifo" s_isfifo :: CMode -> Bool
+
+foreign import ccall unsafe "__hscore_sizeof_stat" sizeof_stat :: Int
+foreign import ccall unsafe "__hscore_st_mtime" st_mtime :: Ptr CStat -> IO CTime
+foreign import ccall unsafe "__hscore_st_size" st_size :: Ptr CStat -> IO COff
+foreign import ccall unsafe "__hscore_st_mode" st_mode :: Ptr CStat -> IO CMode
+
+foreign import ccall unsafe "__hscore_lflag" c_lflag :: Ptr CTermios -> IO CTcflag
+foreign import ccall unsafe "__hscore_poke_lflag" poke_c_lflag :: Ptr CTermios -> CTcflag -> IO ()
+foreign import ccall unsafe "__hscore_ptr_c_cc" ptr_c_cc :: Ptr CTermios -> IO (Ptr Word8)
+
+foreign import ccall unsafe "__hscore_echo" const_echo :: CInt
+foreign import ccall unsafe "__hscore_tcsanow" const_tcsanow :: CInt
+foreign import ccall unsafe "__hscore_icanon" const_icanon :: CInt
+foreign import ccall unsafe "__hscore_vmin" const_vmin :: CInt
+foreign import ccall unsafe "__hscore_vtime" const_vtime :: CInt
+foreign import ccall unsafe "__hscore_sigttou" const_sigttou :: CInt
+foreign import ccall unsafe "__hscore_sig_block" const_sig_block :: CInt
+foreign import ccall unsafe "__hscore_sig_setmask" const_sig_setmask :: CInt
+foreign import ccall unsafe "__hscore_f_getfl" const_f_getfl :: CInt
+foreign import ccall unsafe "__hscore_f_setfl" const_f_setfl :: CInt
+
+#ifndef mingw32_TARGET_OS
+foreign import ccall unsafe "__hscore_sizeof_termios" sizeof_termios :: Int
+foreign import ccall unsafe "__hscore_sizeof_sigset_t" sizeof_sigset_t :: Int
+#endif
#ifndef mingw32_TARGET_OS
-foreign import "__hscore_s_issock" s_issock :: CMode -> Bool
+foreign import ccall unsafe "__hscore_s_issock" s_issock :: CMode -> Bool
#else
s_issock :: CMode -> Bool
s_issock cmode = False
% -----------------------------------------------------------------------------
-% $Id: Storable.lhs,v 1.3 2001/12/21 15:07:25 simonmar Exp $
+% $Id: Storable.lhs,v 1.4 2002/02/05 17:32:27 simonmar Exp $
%
% (c) The FFI task force, 2000
%
peekByteOff, -- :: Ptr b -> Int -> IO a
pokeByteOff, -- :: Ptr b -> Int -> a -> IO ()
peek, -- :: Ptr a -> IO a
- poke, -- :: Ptr a -> a -> IO ()
- destruct) -- :: Ptr a -> IO ()
+ poke) -- :: Ptr a -> a -> IO ()
) where
\end{code}
peek :: Ptr a -> IO a
poke :: Ptr a -> a -> IO ()
- -- free memory associated with the object
- -- (except the object pointer itself)
- destruct :: Ptr a -> IO ()
-
-- circular default instances
peekElemOff = peekElemOff_ undefined
where peekElemOff_ :: a -> Ptr a -> Int -> IO a
peek ptr = peekElemOff ptr 0
poke ptr = pokeElemOff ptr 0
-
- destruct _ = return ()
\end{code}
System-dependent, but rather obvious instances
-- -----------------------------------------------------------------------------
--- $Id: TopHandler.lhs,v 1.3 2001/08/17 12:50:34 simonmar Exp $
+-- $Id: TopHandler.lhs,v 1.4 2002/02/05 17:32:27 simonmar Exp $
--
-- (c) The University of Glasgow, 2001
--
ExitException ExitSuccess -> shutdownHaskellAndExit 0
ExitException (ExitFailure n) -> shutdownHaskellAndExit n
+ Deadlock -> reportError True
+ "no threads to run: infinite loop or deadlock?"
+
ErrorCall s -> reportError True s
other -> reportError True (showsPrec 0 other "\n")
bitSize _ = 32
isSigned _ = False
-foreign import "stg_eqWord32" unsafe eqWord32# :: Word32# -> Word32# -> Bool
-foreign import "stg_neWord32" unsafe neWord32# :: Word32# -> Word32# -> Bool
-foreign import "stg_ltWord32" unsafe ltWord32# :: Word32# -> Word32# -> Bool
-foreign import "stg_leWord32" unsafe leWord32# :: Word32# -> Word32# -> Bool
-foreign import "stg_gtWord32" unsafe gtWord32# :: Word32# -> Word32# -> Bool
-foreign import "stg_geWord32" unsafe geWord32# :: Word32# -> Word32# -> Bool
-foreign import "stg_int32ToWord32" unsafe int32ToWord32# :: Int32# -> Word32#
-foreign import "stg_word32ToInt32" unsafe word32ToInt32# :: Word32# -> Int32#
-foreign import "stg_intToInt32" unsafe intToInt32# :: Int# -> Int32#
-foreign import "stg_wordToWord32" unsafe wordToWord32# :: Word# -> Word32#
-foreign import "stg_word32ToWord" unsafe word32ToWord# :: Word32# -> Word#
-foreign import "stg_plusInt32" unsafe plusInt32# :: Int32# -> Int32# -> Int32#
-foreign import "stg_minusInt32" unsafe minusInt32# :: Int32# -> Int32# -> Int32#
-foreign import "stg_timesInt32" unsafe timesInt32# :: Int32# -> Int32# -> Int32#
-foreign import "stg_negateInt32" unsafe negateInt32# :: Int32# -> Int32#
-foreign import "stg_quotWord32" unsafe quotWord32# :: Word32# -> Word32# -> Word32#
-foreign import "stg_remWord32" unsafe remWord32# :: Word32# -> Word32# -> Word32#
-foreign import "stg_and32" unsafe and32# :: Word32# -> Word32# -> Word32#
-foreign import "stg_or32" unsafe or32# :: Word32# -> Word32# -> Word32#
-foreign import "stg_xor32" unsafe xor32# :: Word32# -> Word32# -> Word32#
-foreign import "stg_not32" unsafe not32# :: Word32# -> Word32#
-foreign import "stg_shiftL32" unsafe shiftL32# :: Word32# -> Int# -> Word32#
-foreign import "stg_shiftRL32" unsafe shiftRL32# :: Word32# -> Int# -> Word32#
+foreign import unsafe "stg_eqWord32" eqWord32# :: Word32# -> Word32# -> Bool
+foreign import unsafe "stg_neWord32" neWord32# :: Word32# -> Word32# -> Bool
+foreign import unsafe "stg_ltWord32" ltWord32# :: Word32# -> Word32# -> Bool
+foreign import unsafe "stg_leWord32" leWord32# :: Word32# -> Word32# -> Bool
+foreign import unsafe "stg_gtWord32" gtWord32# :: Word32# -> Word32# -> Bool
+foreign import unsafe "stg_geWord32" geWord32# :: Word32# -> Word32# -> Bool
+foreign import unsafe "stg_int32ToWord32" int32ToWord32# :: Int32# -> Word32#
+foreign import unsafe "stg_word32ToInt32" word32ToInt32# :: Word32# -> Int32#
+foreign import unsafe "stg_intToInt32" intToInt32# :: Int# -> Int32#
+foreign import unsafe "stg_wordToWord32" wordToWord32# :: Word# -> Word32#
+foreign import unsafe "stg_word32ToWord" word32ToWord# :: Word32# -> Word#
+foreign import unsafe "stg_plusInt32" plusInt32# :: Int32# -> Int32# -> Int32#
+foreign import unsafe "stg_minusInt32" minusInt32# :: Int32# -> Int32# -> Int32#
+foreign import unsafe "stg_timesInt32" timesInt32# :: Int32# -> Int32# -> Int32#
+foreign import unsafe "stg_negateInt32" negateInt32# :: Int32# -> Int32#
+foreign import unsafe "stg_quotWord32" quotWord32# :: Word32# -> Word32# -> Word32#
+foreign import unsafe "stg_remWord32" remWord32# :: Word32# -> Word32# -> Word32#
+foreign import unsafe "stg_and32" and32# :: Word32# -> Word32# -> Word32#
+foreign import unsafe "stg_or32" or32# :: Word32# -> Word32# -> Word32#
+foreign import unsafe "stg_xor32" xor32# :: Word32# -> Word32# -> Word32#
+foreign import unsafe "stg_not32" not32# :: Word32# -> Word32#
+foreign import unsafe "stg_shiftL32" shiftL32# :: Word32# -> Int# -> Word32#
+foreign import unsafe "stg_shiftRL32" shiftRL32# :: Word32# -> Int# -> Word32#
{-# RULES
"fromIntegral/Int->Word32" fromIntegral = \(I# x#) -> W32# (int32ToWord32# (intToInt32# x#))
bitSize _ = 64
isSigned _ = False
-foreign import "stg_eqWord64" unsafe eqWord64# :: Word64# -> Word64# -> Bool
-foreign import "stg_neWord64" unsafe neWord64# :: Word64# -> Word64# -> Bool
-foreign import "stg_ltWord64" unsafe ltWord64# :: Word64# -> Word64# -> Bool
-foreign import "stg_leWord64" unsafe leWord64# :: Word64# -> Word64# -> Bool
-foreign import "stg_gtWord64" unsafe gtWord64# :: Word64# -> Word64# -> Bool
-foreign import "stg_geWord64" unsafe geWord64# :: Word64# -> Word64# -> Bool
-foreign import "stg_int64ToWord64" unsafe int64ToWord64# :: Int64# -> Word64#
-foreign import "stg_word64ToInt64" unsafe word64ToInt64# :: Word64# -> Int64#
-foreign import "stg_intToInt64" unsafe intToInt64# :: Int# -> Int64#
-foreign import "stg_wordToWord64" unsafe wordToWord64# :: Word# -> Word64#
-foreign import "stg_word64ToWord" unsafe word64ToWord# :: Word64# -> Word#
-foreign import "stg_plusInt64" unsafe plusInt64# :: Int64# -> Int64# -> Int64#
-foreign import "stg_minusInt64" unsafe minusInt64# :: Int64# -> Int64# -> Int64#
-foreign import "stg_timesInt64" unsafe timesInt64# :: Int64# -> Int64# -> Int64#
-foreign import "stg_negateInt64" unsafe negateInt64# :: Int64# -> Int64#
-foreign import "stg_quotWord64" unsafe quotWord64# :: Word64# -> Word64# -> Word64#
-foreign import "stg_remWord64" unsafe remWord64# :: Word64# -> Word64# -> Word64#
-foreign import "stg_and64" unsafe and64# :: Word64# -> Word64# -> Word64#
-foreign import "stg_or64" unsafe or64# :: Word64# -> Word64# -> Word64#
-foreign import "stg_xor64" unsafe xor64# :: Word64# -> Word64# -> Word64#
-foreign import "stg_not64" unsafe not64# :: Word64# -> Word64#
-foreign import "stg_shiftL64" unsafe shiftL64# :: Word64# -> Int# -> Word64#
-foreign import "stg_shiftRL64" unsafe shiftRL64# :: Word64# -> Int# -> Word64#
-
-foreign import "stg_integerToWord64" unsafe integerToWord64# :: Int# -> ByteArray# -> Word64#
+foreign import ccall unsafe "stg_eqWord64" eqWord64# :: Word64# -> Word64# -> Bool
+foreign import ccall unsafe "stg_neWord64" neWord64# :: Word64# -> Word64# -> Bool
+foreign import ccall unsafe "stg_ltWord64" ltWord64# :: Word64# -> Word64# -> Bool
+foreign import ccall unsafe "stg_leWord64" leWord64# :: Word64# -> Word64# -> Bool
+foreign import ccall unsafe "stg_gtWord64" gtWord64# :: Word64# -> Word64# -> Bool
+foreign import ccall unsafe "stg_geWord64" geWord64# :: Word64# -> Word64# -> Bool
+foreign import ccall unsafe "stg_int64ToWord64" int64ToWord64# :: Int64# -> Word64#
+foreign import ccall unsafe "stg_word64ToInt64" word64ToInt64# :: Word64# -> Int64#
+foreign import ccall unsafe "stg_intToInt64" intToInt64# :: Int# -> Int64#
+foreign import ccall unsafe "stg_wordToWord64" wordToWord64# :: Word# -> Word64#
+foreign import ccall unsafe "stg_word64ToWord" word64ToWord# :: Word64# -> Word#
+foreign import ccall unsafe "stg_plusInt64" plusInt64# :: Int64# -> Int64# -> Int64#
+foreign import ccall unsafe "stg_minusInt64" minusInt64# :: Int64# -> Int64# -> Int64#
+foreign import ccall unsafe "stg_timesInt64" timesInt64# :: Int64# -> Int64# -> Int64#
+foreign import ccall unsafe "stg_negateInt64" negateInt64# :: Int64# -> Int64#
+foreign import ccall unsafe "stg_quotWord64" quotWord64# :: Word64# -> Word64# -> Word64#
+foreign import ccall unsafe "stg_remWord64" remWord64# :: Word64# -> Word64# -> Word64#
+foreign import ccall unsafe "stg_and64" and64# :: Word64# -> Word64# -> Word64#
+foreign import ccall unsafe "stg_or64" or64# :: Word64# -> Word64# -> Word64#
+foreign import ccall unsafe "stg_xor64" xor64# :: Word64# -> Word64# -> Word64#
+foreign import ccall unsafe "stg_not64" not64# :: Word64# -> Word64#
+foreign import ccall unsafe "stg_shiftL64" shiftL64# :: Word64# -> Int# -> Word64#
+foreign import ccall unsafe "stg_shiftRL64" shiftRL64# :: Word64# -> Int# -> Word64#
+
+foreign import ccall unsafe "stg_integerToWord64" integerToWord64# :: Int# -> ByteArray# -> Word64#
{-# RULES
# -----------------------------------------------------------------------------
-# $Id: Makefile,v 1.8 2002/01/02 15:13:23 simonmar Exp $
+# $Id: Makefile,v 1.9 2002/02/05 17:32:24 simonmar Exp $
TOP=..
include $(TOP)/mk/boilerplate.mk
System/Mem \
System/IO \
Text \
+ Text/Html \
Text/PrettyPrint \
Text/Regex \
Text/Show
-----------------------------------------------------------------------------
--
-- Module : Numeric
--- Copyright : (c) The University of Glasgow 2001
+-- Copyright : (c) The University of Glasgow 2002
-- License : BSD-style (see the file libraries/core/LICENSE)
--
-- Maintainer : libraries@haskell.org
--- Stability : experimental
+-- Stability : provisional
-- Portability : portable
--
--- $Id: Numeric.hs,v 1.3 2002/01/02 14:40:09 simonmar Exp $
+-- $Id: Numeric.hs,v 1.4 2002/02/05 17:32:24 simonmar Exp $
--
-- Odds and ends, mostly functions for reading and showing
-- RealFloat-like kind of values.
fromRat, -- :: (RealFloat a) => Rational -> a
showSigned, -- :: (Real a) => (a -> ShowS) -> Int -> a -> ShowS
readSigned, -- :: (Real a) => ReadS a -> ReadS a
- showInt, -- :: Integral a => a -> ShowS
+
readInt, -- :: (Integral a) => a -> (Char -> Bool)
-- -> (Char -> Int) -> ReadS a
-
readDec, -- :: (Integral a) => ReadS a
readOct, -- :: (Integral a) => ReadS a
readHex, -- :: (Integral a) => ReadS a
+ showInt, -- :: Integral a => a -> ShowS
+ showIntAtBase, -- :: Integral a => a -> (a -> Char) -> a -> ShowS
showHex, -- :: Integral a => a -> ShowS
showOct, -- :: Integral a => a -> ShowS
showBin, -- :: Integral a => a -> ShowS
-
+
showEFloat, -- :: (RealFloat a) => Maybe Int -> a -> ShowS
showFFloat, -- :: (RealFloat a) => Maybe Int -> a -> ShowS
showGFloat, -- :: (RealFloat a) => Maybe Int -> a -> ShowS
showFloat, -- :: (RealFloat a) => a -> ShowS
readFloat, -- :: (RealFloat a) => ReadS a
-
floatToDigits, -- :: (RealFloat a) => Integer -> a -> ([Int], Int)
lexDigits, -- :: ReadS String
- -- general purpose number->string converter.
- showIntAtBase, -- :: Integral a
- -- => a -- base
- -- -> (a -> Char) -- digit to char
- -- -> a -- number to show.
- -- -> ShowS
) where
import Prelude -- For dependencies
-- Stability : provisional
-- Portability : portable
--
--- $Id: Directory.hsc,v 1.1 2001/08/17 12:45:27 simonmar Exp $
+-- $Id: Directory.hs,v 1.1 2002/02/05 17:32:27 simonmar Exp $
--
-- System-independent interface to directory manipulation.
--
import GHC.IOBase ( IOException(..), IOErrorType(..), ioException )
#endif
--- to get config.h
-#include "HsCore.h"
-
-#include <limits.h>
-
-----------------------------------------------------------------------------
-- Permissions
createDirectory path = do
withCString path $ \s -> do
throwErrnoIfMinus1Retry_ "createDirectory" $
-#if defined(mingw32_TARGET_OS)
- c_mkdir s
-#else
- c_mkdir s 0o777
-#endif
+ mkdir s 0o777
{-
@removeDirectory dir@ removes an existing directory {\em dir}. The
renameFile :: FilePath -> FilePath -> IO ()
renameFile opath npath =
- withFileStatus opath $ \st -> do
+ withFileOrSymlinkStatus opath $ \st -> do
is_dir <- isDirectory st
if is_dir
then ioException (IOError Nothing InappropriateType "renameFile"
getDirectoryContents :: FilePath -> IO [FilePath]
getDirectoryContents path = do
- p <- withCString path $ \s ->
+ alloca $ \ ptr_dEnt -> do
+ p <- withCString path $ \s ->
throwErrnoIfNullRetry "getDirectoryContents" (c_opendir s)
- loop p
+ loop ptr_dEnt p
where
- loop :: Ptr CDir -> IO [String]
- loop dir = do
+ loop :: Ptr (Ptr CDirent) -> Ptr CDir -> IO [String]
+ loop ptr_dEnt dir = do
resetErrno
- p <- c_readdir dir
- if (p /= nullPtr)
+ r <- readdir dir ptr_dEnt
+ if (r == 0)
then do
-#ifdef mingw32_TARGET_OS
- entryp <- (#peek struct dirent,d_name) p
- entry <- peekCString entryp -- on mingwin it's a char *, not a char []
-#else
- entry <- peekCString ((#ptr struct dirent,d_name) p)
-#endif
- entries <- loop dir
- return (entry:entries)
+ dEnt <- peek ptr_dEnt
+ if (dEnt == nullPtr)
+ then return []
+ else do
+ entry <- (d_name dEnt >>= peekCString)
+ freeDirEnt dEnt
+ entries <- loop ptr_dEnt dir
+ return (entry:entries)
else do errno <- getErrno
- if (errno == eINTR) then loop dir else do
+ if (errno == eINTR) then loop ptr_dEnt dir else do
throwErrnoIfMinus1_ "getDirectoryContents" $ c_closedir dir
-#ifdef mingw32_TARGET_OS
- if (errno == eNOENT) -- mingwin (20001111) cunningly sets errno to ENOENT when it runs out of files
-#else
- if (errno == eOK)
-#endif
+ let (Errno eo) = errno
+ if (eo == end_of_dir)
then return []
else throwErrno "getDirectoryContents"
+
+
{-
If the operating system has a notion of current directories,
@getCurrentDirectory@ returns an absolute path to the
getCurrentDirectory :: IO FilePath
getCurrentDirectory = do
- p <- mallocBytes (#const PATH_MAX)
- go p (#const PATH_MAX)
+ p <- mallocBytes path_max
+ go p path_max
where go p bytes = do
p' <- c_getcwd p (fromIntegral bytes)
if p' /= nullPtr
getPermissions :: FilePath -> IO Permissions
getPermissions name = do
withCString name $ \s -> do
- read <- c_access s (#const R_OK)
- write <- c_access s (#const W_OK)
- exec <- c_access s (#const X_OK)
+ read <- c_access s r_OK
+ write <- c_access s w_OK
+ exec <- c_access s x_OK
withFileStatus name $ \st -> do
is_dir <- isDirectory st
is_reg <- isRegularFile st
setPermissions :: FilePath -> Permissions -> IO ()
setPermissions name (Permissions r w e s) = do
let
- read = if r then (#const S_IRUSR) else emptyCMode
- write = if w then (#const S_IWUSR) else emptyCMode
- exec = if e || s then (#const S_IXUSR) else emptyCMode
+ read = if r then s_IRUSR else emptyCMode
+ write = if w then s_IWUSR else emptyCMode
+ exec = if e || s then s_IXUSR else emptyCMode
mode = read `unionCMode` (write `unionCMode` exec)
withFileStatus :: FilePath -> (Ptr CStat -> IO a) -> IO a
withFileStatus name f = do
- allocaBytes (#const sizeof(struct stat)) $ \p ->
+ allocaBytes sizeof_stat $ \p ->
withCString name $ \s -> do
throwErrnoIfMinus1Retry_ "withFileStatus" (c_stat s p)
f p
+withFileOrSymlinkStatus :: FilePath -> (Ptr CStat -> IO a) -> IO a
+withFileOrSymlinkStatus name f = do
+ allocaBytes sizeof_stat $ \p ->
+ withCString name $ \s -> do
+ throwErrnoIfMinus1Retry_ "withFileOrSymlinkStatus" (lstat s p)
+ f p
+
modificationTime :: Ptr CStat -> IO ClockTime
modificationTime stat = do
- mtime <- (#peek struct stat, st_mtime) stat
+ mtime <- st_mtime stat
return (TOD (toInteger (mtime :: CTime)) 0)
-
+
isDirectory :: Ptr CStat -> IO Bool
isDirectory stat = do
- mode <- (#peek struct stat, st_mode) stat
- return (s_ISDIR mode /= 0)
+ mode <- st_mode stat
+ return (s_isdir mode)
isRegularFile :: Ptr CStat -> IO Bool
isRegularFile stat = do
- mode <- (#peek struct stat, st_mode) stat
- return (s_ISREG mode /= 0)
-
-foreign import ccall unsafe s_ISDIR :: CMode -> Int
-#def inline HsInt s_ISDIR(m) {return S_ISDIR(m);}
-
-foreign import ccall unsafe s_ISREG :: CMode -> Int
-#def inline HsInt s_ISREG(m) {return S_ISREG(m);}
+ mode <- st_mode stat
+ return (s_isreg mode)
emptyCMode :: CMode
emptyCMode = 0
unionCMode :: CMode -> CMode -> CMode
unionCMode = (+)
+
+
+foreign import ccall unsafe "__hscore_path_max"
+ path_max :: Int
+
+foreign import ccall unsafe "__hscore_readdir"
+ readdir :: Ptr CDir -> Ptr (Ptr CDirent) -> IO CInt
+
+foreign import ccall unsafe "__hscore_free_dirent"
+ freeDirEnt :: Ptr CDirent -> IO ()
+
+foreign import ccall unsafe "__hscore_end_of_dir"
+ end_of_dir :: CInt
+
+foreign import ccall unsafe "__hscore_d_name"
+ d_name :: Ptr CDirent -> IO CString
+
+foreign import ccall unsafe "__hscore_R_OK" r_OK :: CMode
+foreign import ccall unsafe "__hscore_W_OK" w_OK :: CMode
+foreign import ccall unsafe "__hscore_X_OK" x_OK :: CMode
+
+foreign import ccall unsafe "__hscore_S_IRUSR" s_IRUSR :: CMode
+foreign import ccall unsafe "__hscore_S_IWUSR" s_IWUSR :: CMode
+foreign import ccall unsafe "__hscore_S_IXUSR" s_IXUSR :: CMode
-- Stability : provisional
-- Portability : portable
--
--- $Id: IO.hs,v 1.2 2001/07/03 11:37:50 simonmar Exp $
+-- $Id: IO.hs,v 1.3 2002/02/05 17:32:27 simonmar Exp $
--
-- The standard IO library.
--
import Data.Dynamic
import Control.Monad.Fix
+import System.IO.Error
-- -----------------------------------------------------------------------------
-- MonadFix instance
--- /dev/null
+{-# OPTIONS -fno-implicit-prelude #-}
+
+-----------------------------------------------------------------------------
+--
+-- Module : System.IO.Error
+-- Copyright : (c) The University of Glasgow 2001
+-- License : BSD-style (see the file libraries/core/LICENSE)
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : provisional
+-- Portability : portable
+--
+-- $Id: Error.hs,v 1.1 2002/02/05 17:32:27 simonmar Exp $
+--
+-- Standard IO Errors.
+--
+-----------------------------------------------------------------------------
+
+module System.IO.Error (
+ IOError, -- abstract
+ IOErrorType, -- abstract
+
+ ioError, -- :: IOError -> IO a
+ userError, -- :: String -> IOError
+
+ mkIOError, -- :: IOErrorType -> String -> Maybe Handle
+ -- -> Maybe FilePath -> IOError
+
+ alreadyExistsErrorType, -- :: IOErrorType
+ doesNotExistErrorType,
+ alreadyInUseErrorType,
+ fullErrorType,
+ eofErrorType,
+ illegalOperationErrorType,
+ permissionErrorType,
+ userErrorType,
+
+ isAlreadyExistsErrorType, -- :: IOErrorType -> Bool
+ isDoesNotExistErrorType,
+ isAlreadyInUseErrorType,
+ isFullErrorType,
+ isEOFErrorType,
+ isIllegalOperationErrorType,
+ isPermissionErrorType,
+ isUserErrorType,
+
+ isAlreadyExistsError, -- :: IOError -> Bool
+ isDoesNotExistError,
+ isAlreadyInUseError,
+ isFullError,
+ isEOFError,
+ isIllegalOperation,
+ isPermissionError,
+ isUserError,
+
+ ioeGetErrorType, -- :: IOError -> IOErrorType
+ ioeGetErrorString, -- :: IOError -> String
+ ioeGetHandle, -- :: IOError -> Maybe Handle
+ ioeGetFileName, -- :: IOError -> Maybe FilePath
+
+ ) where
+
+
+#ifdef __GLASGOW_HASKELL__
+import GHC.Base
+import Data.Maybe
+import GHC.IOBase
+import Text.Show
+#endif
+
+-- -----------------------------------------------------------------------------
+-- Constructing an IOError
+
+mkIOError :: IOErrorType -> String -> Maybe Handle -> Maybe FilePath -> IOError
+mkIOError t location maybe_hdl maybe_filename =
+ IOException IOError{ ioe_type = t,
+ ioe_location = location,
+ ioe_descr = "",
+ ioe_handle = maybe_hdl,
+ ioe_filename = maybe_filename
+ }
+
+-- -----------------------------------------------------------------------------
+-- IOErrorType
+
+isAlreadyExistsError, isDoesNotExistError, isAlreadyInUseError,
+ isFullError, isEOFError, isIllegalOperation, isPermissionError,
+ isUserError :: IOError -> Bool
+
+isAlreadyExistsError = isAlreadyExistsErrorType . ioeGetErrorType
+isDoesNotExistError = isDoesNotExistErrorType . ioeGetErrorType
+isAlreadyInUseError = isAlreadyInUseErrorType . ioeGetErrorType
+isFullError = isFullErrorType . ioeGetErrorType
+isEOFError = isEOFErrorType . ioeGetErrorType
+isIllegalOperation = isIllegalOperationErrorType . ioeGetErrorType
+isPermissionError = isPermissionErrorType . ioeGetErrorType
+isUserError = isUserErrorType . ioeGetErrorType
+
+-- -----------------------------------------------------------------------------
+-- IOErrorTypes
+
+#ifdef __GLASGOW_HASKELL__
+alreadyExistsErrorType, doesNotExistErrorType, alreadyInUseErrorType,
+ fullErrorType, eofErrorType, illegalOperationErrorType,
+ permissionErrorType, userErrorType :: IOErrorType
+
+alreadyExistsErrorType = AlreadyExists
+doesNotExistErrorType = NoSuchThing
+alreadyInUseErrorType = ResourceBusy
+fullErrorType = ResourceExhausted
+eofErrorType = EOF
+illegalOperationErrorType = IllegalOperation
+permissionErrorType = PermissionDenied
+userErrorType = UserError
+#endif
+
+-- -----------------------------------------------------------------------------
+-- IOErrorType predicates
+
+#ifdef __GLASGOW_HASKELL__
+isAlreadyExistsErrorType AlreadyExists = True
+isAlreadyExistsErrorType _ = False
+
+isDoesNotExistErrorType NoSuchThing = True
+isDoesNotExistErrorType _ = False
+
+isAlreadyInUseErrorType ResourceBusy = True
+isAlreadyInUseErrorType _ = False
+
+isFullErrorType ResourceExhausted = True
+isFullErrorType _ = False
+
+isEOFErrorType EOF = True
+isEOFErrorType _ = False
+
+isIllegalOperationErrorType IllegalOperation = True
+isIllegalOperationErrorType _ = False
+
+isPermissionErrorType PermissionDenied = True
+isPermissionErrorType _ = False
+
+isUserErrorType UserError = True
+isUserErrorType _ = False
+#endif
+
+-- -----------------------------------------------------------------------------
+-- Miscellaneous
+
+#ifdef __GLASGOW_HASKELL__
+ioeGetErrorType :: IOError -> IOErrorType
+ioeGetFileName :: IOError -> Maybe FilePath
+ioeGetErrorString :: IOError -> String
+ioeGetHandle :: IOError -> Maybe Handle
+
+ioeGetErrorType (IOException ioe) = ioe_type ioe
+ioeGetHandle _ = error "System.IO.Error.ioeGetHandle: not an IO error"
+
+ioeGetHandle (IOException ioe) = ioe_handle ioe
+ioeGetHandle _ = error "System.IO.Error.ioeGetHandle: not an IO error"
+
+ioeGetErrorString (IOException ioe)
+ | isUserErrorType (ioe_type ioe) = show (ioe_descr ioe)
+ | otherwise = show (ioe_type ioe)
+ioeGetErrorString _ = error "System.IO.Error.ioeGetErrorString: not an IO error"
+
+ioeGetFileName (IOException ioe) = ioe_filename ioe
+ioeGetFileName _ = error "System.IO.Error.ioeGetFileName: not an IO error"
+#endif
+
+-- -----------------------------------------------------------------------------
+-- annotating an IOError
+
+#ifdef __GLASGOW_HASKELL__
+annotateIOError :: IOError
+ -> String
+ -> Maybe FilePath
+ -> Maybe Handle
+ -> IOError
+annotateIOError (IOException (IOError hdl errTy _ str path)) loc opath ohdl =
+ IOException (IOError (hdl `mplus` ohdl) errTy loc str (path `mplus` opath))
+ where
+ Nothing `mplus` ys = ys
+ xs `mplus` _ = xs
+annotateIOError exc _ _ _ =
+ exc
+#endif
-- Stability : provisional
-- Portability : portable
--
--- $Id: Time.hsc,v 1.6 2001/12/21 15:07:26 simonmar Exp $
+-- $Id: Time.hsc,v 1.7 2002/02/05 17:32:27 simonmar Exp $
--
-- The standard Time library.
--
# else
foreign import "ghcTimezone" unsafe timezone :: Ptr CLong
foreign import "ghcTzname" unsafe tzname :: Ptr (Ptr CChar)
-# def inline long *ghcTimezone(void) { return &_timezone; }
-# def inline char **ghcTzname(void) { return _tzname; }
# endif
zone x = do
dst <- (#peek struct tm,tm_isdst) x
/*
- * (c) The GRASP/AQUA Project, Glasgow University, 1994-
+ * (c) The University of Glasgow 2002
*
* Directory Runtime Support
*/
-#include "dirUtils.h"
+#include "HsCore.h"
#if defined(mingw32_TARGET_OS)
#include <windows.h>
#endif
-#ifdef HAVE_STDLIB_H
-# include <stdlib.h>
-#endif
-#ifdef HAVE_STDDEF_H
-# include <stddef.h>
-#endif
-#ifdef HAVE_ERRNO_H
-# include <errno.h>
-#endif
-
+/*
+ * read an entry from the directory stream; opt for the
+ * re-entrant friendly way of doing this, if available.
+ */
HsInt
-prel_mkdir(HsAddr pathName, HsInt mode)
+__hscore_readdir( HsAddr dirPtr, HsAddr pDirEnt )
{
-#if defined(mingw32_TARGET_OS)
- return mkdir(pathName);
+ struct dirent **pDirE = (struct dirent**)pDirEnt;
+#if HAVE_READDIR_R
+ struct dirent* p;
+ int res;
+ static unsigned int nm_max = -1;
+
+ if (pDirE == NULL) {
+ return -1;
+ }
+ if (nm_max == -1) {
+#ifdef NAME_MAX
+ nm_max = NAME_MAX + 1;
#else
- return mkdir(pathName,mode);
+ nm_max = pathconf(".", _PC_NAME_MAX);
+ if (nm_max == -1) { nm_max = 255; }
+ nm_max++;
#endif
-}
-
-HsInt
-prel_lstat(HsAddr fname, HsAddr st)
-{
-#ifdef HAVE_LSTAT
- return lstat((const char*)fname, (struct stat*)st);
+ }
+ p = (struct dirent*)malloc(sizeof(struct dirent) + nm_max);
+ if (p == NULL) return -1;
+ res = readdir_r((DIR*)dirPtr, p, pDirE);
+ if (res != 0) {
+ *pDirE = NULL;
+ free(p);
+ }
+ return res;
#else
- return stat((const char*)fname, (struct stat*)st);
-#endif
-}
-
-HsInt prel_s_ISDIR(mode_t m) {return S_ISDIR(m);}
-HsInt prel_s_ISREG(mode_t m) {return S_ISREG(m);}
-
-HsInt prel_sz_stat() { return sizeof(struct stat); }
-HsInt prel_path_max() { return PATH_MAX; }
-mode_t prel_R_OK() { return R_OK; }
-mode_t prel_W_OK() { return W_OK; }
-mode_t prel_X_OK() { return X_OK; }
-mode_t prel_S_IRUSR() { return S_IRUSR; }
-mode_t prel_S_IWUSR() { return S_IWUSR; }
-mode_t prel_S_IXUSR() { return S_IXUSR; }
+ if (pDirE == NULL) {
+ return -1;
+ }
-time_t prel_st_mtime(struct stat* st) { return st->st_mtime; }
-mode_t prel_st_mode(struct stat* st) { return st->st_mode; }
-
-HsAddr prel_d_name(struct dirent* d)
-{
-#ifndef mingw32_TARGET_OS
- return (HsAddr)(&d->d_name);
-#else
- return (HsAddr)(d->d_name);
+ *pDirE = readdir((DIR*)dirPtr);
+ if (*pDirE == NULL) {
+ return -1;
+ } else {
+ return 0;
+ }
#endif
}
-
-HsInt prel_end_of_dir()
-{
-#ifndef mingw32_TARGET_OS
- return 0;
-#else
- return ENOENT;
-#endif
-}
-
library_dirs = [ "$libdir/libraries/core"
, "$libdir/libraries/core/cbits" ],
#endif
- hs_libraries = [ "HScore" ],
+ hs_libraries =
+# ifndef mingw32_TARGET_OS
+ [ "HScore" ],
+# else
+ -- This splitting is the subject of a totally
+ -- horrible hack, which glues HSstd1 and HSstd2
+ -- back into HSstd for the purposes of static linking.
+ -- See DriverState.getPackageLibraries for details.
+ [ "HScore1", "HScore2" ],
+# endif
extra_libraries = [ "HScore_cbits"
#ifdef mingw32_TARGET_OS
- , "wsock32", "msvcrt"
+ , "wsock32", "msvcrt", "kernel32", "user32"
#endif
],
#ifdef INSTALLING
/* -----------------------------------------------------------------------------
- * $Id: HsCore.h,v 1.6 2002/01/02 14:40:11 simonmar Exp $
+ * $Id: HsCore.h,v 1.7 2002/02/05 17:32:27 simonmar Exp $
*
* (c) The University of Glasgow 2001-2002
*
#endif
}
+INLINE int
+__hscore_o_rdonly()
+{
+#ifdef O_RDONLY
+ return O_RDONLY;
+#else
+ return 0;
+#endif
+}
+
+INLINE int
+__hscore_o_wronly( void )
+{
+#ifdef O_WRONLY
+ return O_WRONLY;
+#else
+ return 0;
+#endif
+}
+
+INLINE int
+__hscore_o_rdwr( void )
+{
+#ifdef O_RDWR
+ return O_RDWR;
+#else
+ return 0;
+#endif
+}
+
+INLINE int
+__hscore_o_append( void )
+{
+#ifdef O_APPEND
+ return O_APPEND;
+#else
+ return 0;
+#endif
+}
+
+INLINE int
+__hscore_o_creat( void )
+{
+#ifdef O_CREAT
+ return O_CREAT;
+#else
+ return 0;
+#endif
+}
+
+INLINE int
+__hscore_o_excl( void )
+{
+#ifdef O_EXCL
+ return O_EXCL;
+#else
+ return 0;
+#endif
+}
+
+INLINE int
+__hscore_o_trunc( void )
+{
+#ifdef O_TRUNC
+ return O_TRUNC;
+#else
+ return 0;
+#endif
+}
+
+INLINE int
+__hscore_o_noctty( void )
+{
+#ifdef O_NOCTTY
+ return O_NOCTTY;
+#else
+ return 0;
+#endif
+}
+
+INLINE int
+__hscore_o_nonblock( void )
+{
+#ifdef O_NONBLOCK
+ return O_NONBLOCK;
+#else
+ return 0;
+#endif
+}
+
INLINE HsInt
-__hscore_seek_set()
+__hscore_seek_set( void )
{
return SEEK_SET;
}
INLINE HsInt
-__hscore_seek_end()
+__hscore_seek_end( void )
{
return SEEK_END;
}
}
+#ifdef mingw32_TARGET_OS
+INLINE long *
+__hscore_Time_ghcTimezone( void ) { return &_timezone; }
+
+INLINE char **
+__hscore_Time_ghcTzname( void ) { return _tzname; }
+#endif
+
+INLINE HsInt
+__hscore_mkdir( HsAddr pathName, HsInt mode )
+{
+#if defined(mingw32_TARGET_OS)
+ return mkdir(pathName);
+#else
+ return mkdir(pathName,mode);
+#endif
+}
+
+INLINE HsInt
+__hscore_lstat( HsAddr fname, HsAddr st )
+{
+#ifdef HAVE_LSTAT
+ return lstat((const char*)fname, (struct stat*)st);
+#else
+ return stat((const char*)fname, (struct stat*)st);
+#endif
+}
+
+INLINE HsInt __hscore_path_max() { return PATH_MAX; }
+
+INLINE mode_t __hscore_R_OK() { return R_OK; }
+INLINE mode_t __hscore_W_OK() { return W_OK; }
+INLINE mode_t __hscore_X_OK() { return X_OK; }
+
+INLINE mode_t __hscore_S_IRUSR() { return S_IRUSR; }
+INLINE mode_t __hscore_S_IWUSR() { return S_IWUSR; }
+INLINE mode_t __hscore_S_IXUSR() { return S_IXUSR; }
+
+INLINE HsAddr
+__hscore_d_name( struct dirent* d )
+{
+#ifndef mingw32_TARGET_OS
+ return (HsAddr)(&d->d_name);
+#else
+ return (HsAddr)(d->d_name);
+#endif
+}
+
+INLINE HsInt
+__hscore_end_of_dir( void )
+{
+#ifndef mingw32_TARGET_OS
+ return 0;
+#else
+ return ENOENT;
+#endif
+}
+
+INLINE void
+__hscore_free_dirent(HsAddr dEnt)
+{
+#if HAVE_READDIR_R
+ free(dEnt);
+#endif
+}
+
+INLINE HsInt
+__hscore_sizeof_stat( void )
+{
+ return sizeof(struct stat);
+}
+
+INLINE time_t __hscore_st_mtime ( struct stat* st ) { return st->st_mtime; }
+INLINE off_t __hscore_st_size ( struct stat* st ) { return st->st_size; }
+INLINE mode_t __hscore_st_mode ( struct stat* st ) { return st->st_mode; }
+
+#if HAVE_TERMIOS_H
+INLINE tcflag_t __hscore_lflag( struct termios* ts ) { return ts->c_lflag; }
+
+INLINE void
+__hscore_poke_lflag( struct termios* ts, tcflag_t t ) { ts->c_lflag = t; }
+
+INLINE unsigned char*
+__hscore_ptr_c_cc( struct termios* ts )
+{ return (unsigned char*) &ts->c_cc; }
+#endif
+
+INLINE HsInt
+__hscore_sizeof_termios( void )
+{
+#ifndef mingw32_TARGET_OS
+ return sizeof(struct termios);
+#else
+ return 0;
+#endif
+}
+
+INLINE HsInt
+__hscore_sizeof_sigset_t( void )
+{
+#ifndef mingw32_TARGET_OS
+ return sizeof(sigset_t);
+#else
+ return 0;
+#endif
+}
+
+INLINE int
+__hscore_echo( void )
+{
+#ifdef ECHO
+ return ECHO;
+#else
+ return 0;
+#endif
+
+}
+
+INLINE int
+__hscore_tcsanow( void )
+{
+#ifdef TCSANOW
+ return TCSANOW;
+#else
+ return 0;
+#endif
+
+}
+
+INLINE int
+__hscore_icanon( void )
+{
+#ifdef ICANON
+ return ICANON;
+#else
+ return 0;
+#endif
+}
+
+INLINE int __hscore_vmin( void )
+{
+#ifdef VMIN
+ return VMIN;
+#else
+ return 0;
+#endif
+}
+
+INLINE int __hscore_vtime( void )
+{
+#ifdef VTIME
+ return VTIME;
+#else
+ return 0;
+#endif
+}
+
+INLINE int __hscore_sigttou( void )
+{
+#ifdef SIGTTOU
+ return SIGTTOU;
+#else
+ return 0;
+#endif
+}
+
+INLINE int __hscore_sig_block( void )
+{
+#ifdef SIG_BLOCK
+ return SIG_BLOCK;
+#else
+ return 0;
+#endif
+}
+
+INLINE int __hscore_sig_setmask( void )
+{
+#ifdef SIG_SETMASK
+ return SIG_SETMASK;
+#else
+ return 0;
+#endif
+}
+
+INLINE int
+__hscore_f_getfl( void )
+{
+#ifdef F_GETFL
+ return F_GETFL;
+#else
+ return 0;
+#endif
+}
+
+INLINE int
+__hscore_f_setfl( void )
+{
+#ifdef F_SETFL
+ return F_SETFL;
+#else
+ return 0;
+#endif
+}
+
#endif
/*
- * (c) The GRASP/AQUA Project, Glasgow University, 1994-
+ * (c) The University of Glasgow 2002
*
- * Directory Runtime Support - prototypes.
+ * Directory Runtime Support
*/
#ifndef __DIRUTILS_H__
#define __DIRUTILS_H__
-#include "HsCore.h"
-
-#include <limits.h>
-
-extern HsInt prel_mkdir(HsAddr pathName, HsInt mode);
-extern HsInt prel_lstat(HsAddr fname, HsAddr st);
-
-extern HsInt prel_s_ISDIR(mode_t m);
-extern HsInt prel_s_ISREG(mode_t m);
-
-extern HsInt prel_sz_stat();
-extern HsInt prel_path_max();
-extern mode_t prel_R_OK();
-extern mode_t prel_W_OK();
-extern mode_t prel_X_OK();
-
-extern mode_t prel_S_IRUSR();
-extern mode_t prel_S_IWUSR();
-extern mode_t prel_S_IXUSR();
-
-extern time_t prel_st_mtime(struct stat* st);
-extern mode_t prel_st_mode(struct stat* st);
-
-extern HsAddr prel_d_name(struct dirent* d);
-
-extern HsInt prel_end_of_dir();
+extern HsInt __hscore_readdir(HsAddr dirPtr, HsAddr pDirEnt);
#endif /* __DIRUTILS_H__ */
projects / ghc-base.git / commitdiff