From bccd35aa801c910b7db3f94ac16f2b18bdf9f108 Mon Sep 17 00:00:00 2001 From: panne Date: Sun, 13 Jun 2004 21:03:47 +0000 Subject: [PATCH] [project @ 2004-06-13 21:03:46 by panne] Changes related to arithmetic types: * Renamed macros NUMERIC_FOO to ARITHMETIC_FOO to match C99-speak * ARITHMETIC_TYPEs now have a Real instance, otherwise they are quite useless. Note that this differs from the FFI spec, but the spec should very probably changed in this respect. * Some changes to fix the wrong assumption that CTime/CClock are integral types, C99 in fact guarantees only that they are arithmetic types. This has been accomplished by using realToInteger = round . realToFrac :: Real a => a -> Integer instead of fromIntegral for CTime/CClock. I'm not sure if we could do better, going via Double seems to be overkill, but I couldn't think of a better way. GHC could e.g. use RULES here. Improvements welcome. --- Foreign/C/Types.hs | 4 ++-- System/CPUTime.hsc | 9 +++++---- System/Directory.hs | 3 ++- System/Posix/Types.hs | 6 +++--- System/Time.hsc | 11 +++++++---- include/CTypes.h | 25 ++++++++++++------------- 6 files changed, 31 insertions(+), 27 deletions(-) diff --git a/Foreign/C/Types.hs b/Foreign/C/Types.hs index 8a09e44..ae62af2 100644 --- a/Foreign/C/Types.hs +++ b/Foreign/C/Types.hs @@ -154,8 +154,8 @@ INTEGRAL_TYPE(CSigAtomic,tyConCSigAtomic,"CSigAtomic",HTYPE_SIG_ATOMIC_T) "fromIntegral/CSigAtomic->a" fromIntegral = \(CSigAtomic x) -> fromIntegral x #-} -NUMERIC_TYPE(CClock,tyConCClock,"CClock",HTYPE_CLOCK_T) -NUMERIC_TYPE(CTime,tyConCTime,"CTime",HTYPE_TIME_T) +ARITHMETIC_TYPE(CClock,tyConCClock,"CClock",HTYPE_CLOCK_T) +ARITHMETIC_TYPE(CTime,tyConCTime,"CTime",HTYPE_TIME_T) -- FIXME: Implement and provide instances for Eq and Storable data CFile = CFile diff --git a/System/CPUTime.hsc b/System/CPUTime.hsc index 6624870..6c58d8e 100644 --- a/System/CPUTime.hsc +++ b/System/CPUTime.hsc @@ -64,9 +64,9 @@ getCPUTime = do u_usec <- (#peek struct timeval,tv_usec) ru_utime :: IO CTime s_sec <- (#peek struct timeval,tv_sec) ru_stime :: IO CTime s_usec <- (#peek struct timeval,tv_usec) ru_stime :: IO CTime - - return ((fromIntegral u_sec * 1000000 + fromIntegral u_usec + - fromIntegral s_sec * 1000000 + fromIntegral s_usec) + let realToInteger = round . realToFrac :: Real a => a -> Integer + return ((realToInteger u_sec * 1000000 + realToInteger u_usec + + realToInteger s_sec * 1000000 + realToInteger s_usec) * 1000000) type CRUsage = () @@ -77,7 +77,8 @@ foreign import ccall unsafe getrusage :: CInt -> Ptr CRUsage -> IO CInt times p_tms u_ticks <- (#peek struct tms,tms_utime) p_tms :: IO CClock s_ticks <- (#peek struct tms,tms_stime) p_tms :: IO CClock - return (( (fromIntegral u_ticks + fromIntegral s_ticks) * 1000000000000) + let realToInteger = round . realToFrac :: Real a => a -> Integer + return (( (realToInteger u_ticks + realToInteger s_ticks) * 1000000000000) `div` fromIntegral clockTicks) type CTms = () diff --git a/System/Directory.hs b/System/Directory.hs index 616ce4c..baa55ec 100644 --- a/System/Directory.hs +++ b/System/Directory.hs @@ -632,7 +632,8 @@ withFileOrSymlinkStatus loc name f = do modificationTime :: Ptr CStat -> IO ClockTime modificationTime stat = do mtime <- st_mtime stat - return (TOD (toInteger (mtime :: CTime)) 0) + let realToInteger = round . realToFrac :: Real a => a -> Integer + return (TOD (realToInteger (mtime :: CTime)) 0) isDirectory :: Ptr CStat -> IO Bool isDirectory stat = do diff --git a/System/Posix/Types.hs b/System/Posix/Types.hs index 77ec354..7acb364 100644 --- a/System/Posix/Types.hs +++ b/System/Posix/Types.hs @@ -105,7 +105,7 @@ import Control.Monad #include "CTypes.h" #if defined(HTYPE_DEV_T) -NUMERIC_TYPE(CDev,tyConCDev,"CDev",HTYPE_DEV_T) +ARITHMETIC_TYPE(CDev,tyConCDev,"CDev",HTYPE_DEV_T) #endif #if defined(HTYPE_INO_T) INTEGRAL_TYPE(CIno,tyConCIno,"CIno",HTYPE_INO_T) @@ -139,10 +139,10 @@ INTEGRAL_TYPE(CNlink,tyConCNlink,"CNlink",HTYPE_NLINK_T) INTEGRAL_TYPE(CUid,tyConCUid,"CUid",HTYPE_UID_T) #endif #if defined(HTYPE_CC_T) -NUMERIC_TYPE(CCc,tyConCCc,"CCc",HTYPE_CC_T) +ARITHMETIC_TYPE(CCc,tyConCCc,"CCc",HTYPE_CC_T) #endif #if defined(HTYPE_SPEED_T) -NUMERIC_TYPE(CSpeed,tyConCSpeed,"CSpeed",HTYPE_SPEED_T) +ARITHMETIC_TYPE(CSpeed,tyConCSpeed,"CSpeed",HTYPE_SPEED_T) #endif #if defined(HTYPE_TCFLAG_T) INTEGRAL_TYPE(CTcflag,tyConCTcflag,"CTcflag",HTYPE_TCFLAG_T) diff --git a/System/Time.hsc b/System/Time.hsc index 4da0867..a47e14d 100644 --- a/System/Time.hsc +++ b/System/Time.hsc @@ -219,19 +219,21 @@ getClockTime = do #elif HAVE_GETTIMEOFDAY getClockTime = do + let realToInteger = round . realToFrac :: Real a => a -> Integer allocaBytes (#const sizeof(struct timeval)) $ \ p_timeval -> do throwErrnoIfMinus1_ "getClockTime" $ gettimeofday p_timeval nullPtr sec <- (#peek struct timeval,tv_sec) p_timeval :: IO CTime usec <- (#peek struct timeval,tv_usec) p_timeval :: IO CTime - return (TOD (fromIntegral sec) ((fromIntegral usec) * 1000000)) + return (TOD (realToInteger sec) ((realToInteger usec) * 1000000)) #elif HAVE_FTIME getClockTime = do + let realToInteger = round . realToFrac :: Real a => a -> Integer allocaBytes (#const sizeof(struct timeb)) $ \ p_timeb -> do ftime p_timeb sec <- (#peek struct timeb,time) p_timeb :: IO CTime msec <- (#peek struct timeb,millitm) p_timeb :: IO CUShort - return (TOD (fromIntegral sec) (fromIntegral msec * 1000000000)) + return (TOD (realToInteger sec) (fromIntegral msec * 1000000000)) #else /* use POSIX time() */ getClockTime = do @@ -528,8 +530,9 @@ toClockTime (CalendarTime year mon mday hour min sec psec -- result. -- gmtoff <- gmtoff p_tm - let res = fromIntegral t - tz + fromIntegral gmtoff - return (TOD (fromIntegral res) psec) + let realToInteger = round . realToFrac :: Real a => a -> Integer + res = realToInteger t - fromIntegral tz + fromIntegral gmtoff + return (TOD res psec) #endif /* ! __HUGS__ */ -- ----------------------------------------------------------------------------- diff --git a/include/CTypes.h b/include/CTypes.h index f74d9f0..d867936 100644 --- a/include/CTypes.h +++ b/include/CTypes.h @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $Id: CTypes.h,v 1.7 2003/07/24 12:05:42 panne Exp $ + * $Id: CTypes.h,v 1.8 2004/06/13 21:03:47 panne Exp $ * * Dirty CPP hackery for CTypes/CTypesISO * @@ -15,9 +15,10 @@ /* A hacked version for GHC follows the Haskell 98 version... */ #ifndef __GLASGOW_HASKELL__ -#define NUMERIC_TYPE(T,C,S,B) \ +#define ARITHMETIC_TYPE(T,C,S,B) \ newtype T = T B deriving (Eq, Ord) ; \ INSTANCE_NUM(T) ; \ +INSTANCE_REAL(T) ; \ INSTANCE_READ(T,B) ; \ INSTANCE_SHOW(T,B) ; \ INSTANCE_ENUM(T) ; \ @@ -25,15 +26,13 @@ INSTANCE_STORABLE(T) ; \ INSTANCE_TYPEABLE0(T,C,S) ; #define INTEGRAL_TYPE(T,C,S,B) \ -NUMERIC_TYPE(T,C,S,B) ; \ +ARITHMETIC_TYPE(T,C,S,B) ; \ INSTANCE_BOUNDED(T) ; \ -INSTANCE_REAL(T) ; \ INSTANCE_INTEGRAL(T) ; \ INSTANCE_BITS(T) #define FLOATING_TYPE(T,C,S,B) \ -NUMERIC_TYPE(T,C,S,B) ; \ -INSTANCE_REAL(T) ; \ +ARITHMETIC_TYPE(T,C,S,B) ; \ INSTANCE_FRACTIONAL(T) ; \ INSTANCE_FLOATING(T) ; \ INSTANCE_REALFRAC(T) ; \ @@ -172,24 +171,24 @@ instance Storable T where { \ * here... */ -#define NUMERIC_CLASSES Eq,Ord,Num,Enum,Storable -#define INTEGRAL_CLASSES Bounded,Real,Integral,Bits -#define FLOATING_CLASSES Real,Fractional,Floating,RealFrac,RealFloat +#define ARITHMETIC_CLASSES Eq,Ord,Num,Enum,Storable,Real +#define INTEGRAL_CLASSES Bounded,Integral,Bits +#define FLOATING_CLASSES Fractional,Floating,RealFrac,RealFloat -#define NUMERIC_TYPE(T,C,S,B) \ -newtype T = T B deriving (NUMERIC_CLASSES); \ +#define ARITHMETIC_TYPE(T,C,S,B) \ +newtype T = T B deriving (ARITHMETIC_CLASSES); \ INSTANCE_READ(T,B); \ INSTANCE_SHOW(T,B); \ INSTANCE_TYPEABLE0(T,C,S) ; #define INTEGRAL_TYPE(T,C,S,B) \ -newtype T = T B deriving (NUMERIC_CLASSES, INTEGRAL_CLASSES); \ +newtype T = T B deriving (ARITHMETIC_CLASSES, INTEGRAL_CLASSES); \ INSTANCE_READ(T,B); \ INSTANCE_SHOW(T,B); \ INSTANCE_TYPEABLE0(T,C,S) ; #define FLOATING_TYPE(T,C,S,B) \ -newtype T = T B deriving (NUMERIC_CLASSES, FLOATING_CLASSES); \ +newtype T = T B deriving (ARITHMETIC_CLASSES, FLOATING_CLASSES); \ INSTANCE_READ(T,B); \ INSTANCE_SHOW(T,B); \ INSTANCE_TYPEABLE0(T,C,S) ; -- 1.7.10.4