[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.

diff --git a/Foreign/C/Types.hs b/Foreign/C/Types.hs
index 8a09e44..ae62af2 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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) ;