X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=System%2FTime.hsc;h=b4e0d9711d7c3bff3436017f2c55668c061ab1c4;hb=809e77928b69c489681f17599350b4c04323514b;hp=6cb25900639f0ce13bbd3cd2a06d18c673bc2b89;hpb=bf8f7711f2003c09ae4309a7fd2823ebb6352cbc;p=ghc-base.git

diff --git a/System/Time.hsc b/System/Time.hsc
index 6cb2590..b4e0d97 100644
--- a/System/Time.hsc
+++ b/System/Time.hsc
@@ -1,8 +1,5 @@
-{-# OPTIONS -optc-DNON_POSIX_SOURCE #-}
--- JRS 010117: we had to say NON_POSIX_SOURCE to get the resulting .hc
--- to compile on sparc-solaris.  Blargh.
 -----------------------------------------------------------------------------
--- 
+-- |
 -- Module      :  System.Time
 -- Copyright   :  (c) The University of Glasgow 2001
 -- License     :  BSD-style (see the file libraries/core/LICENSE)
@@ -11,8 +8,6 @@
 -- Stability   :  provisional
 -- Portability :  portable
 --
--- $Id: Time.hsc,v 1.2 2001/07/31 13:05:02 simonmar Exp $
---
 -- The standard Time library.
 --
 -----------------------------------------------------------------------------
@@ -101,16 +96,22 @@ module System.Time
 
      ) where
 
-#include "HsCore.h"
+#ifndef __HUGS__
+#include "HsBase.h"
+#endif
 
 import Prelude
 
 import Data.Ix
 import System.Locale
 import System.IO.Unsafe
-	
+
+#ifdef __HUGS__
+import Hugs.Time ( getClockTimePrim, toCalTimePrim, toClockTimePrim )
+#else
 import Foreign
 import Foreign.C
+#endif
 
 -- One way to partition and give name to chunks of a year and a week:
 
@@ -204,13 +205,19 @@ noTimeDiff = TimeDiff 0 0 0 0 0 0 0
 -- -----------------------------------------------------------------------------
 -- getClockTime returns the current time in its internal representation.
 
-#if HAVE_GETTIMEOFDAY
+getClockTime :: IO ClockTime
+#ifdef __HUGS__
+getClockTime = do
+  (sec,usec) <- getClockTimePrim
+  return (TOD (fromIntegral sec) ((fromIntegral usec) * 1000000))
+
+#elif HAVE_GETTIMEOFDAY
 getClockTime = do
   allocaBytes (#const sizeof(struct timeval)) $ \ p_timeval -> do
     throwErrnoIfMinus1_ "getClockTime" $ gettimeofday p_timeval nullPtr
-    sec  <- (#peek struct timeval,tv_sec)  p_timeval :: IO Int32
-    usec <- (#peek struct timeval,tv_usec) p_timeval :: IO Int32
-    return (TOD (fromIntegral sec) ((fromIntegral usec) * 1000))
+    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))
  
 #elif HAVE_FTIME
 getClockTime = do
@@ -218,7 +225,7 @@ getClockTime = 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 * 1000{-ToDo: correct???-}))
+  return (TOD (fromIntegral sec) (fromIntegral msec * 1000000000))
 
 #else /* use POSIX time() */
 getClockTime = do
@@ -301,6 +308,7 @@ normalizeTimeDiff td =
         , tdSec   = diffSecs
         }
 
+#ifndef __HUGS__
 -- -----------------------------------------------------------------------------
 -- How do we deal with timezones on this architecture?
 
@@ -320,12 +328,10 @@ gmtoff x    = (#peek struct tm,tm_gmtoff) x
 #   define tzname _tzname
 #  endif
 #  ifndef mingw32_TARGET_OS
-foreign label tzname :: Ptr (Ptr CChar)
+foreign import ccall unsafe "&tzname" tzname :: Ptr (Ptr CChar)
 #  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; }
+foreign import ccall unsafe "__hscore_timezone" timezone :: Ptr CLong
+foreign import ccall unsafe "__hscore_tzname"   tzname :: Ptr (Ptr CChar)
 #  endif
 zone x = do 
   dst <- (#peek struct tm,tm_isdst) x
@@ -336,26 +342,33 @@ zone x = do
 # endif /* ! HAVE_TZNAME */
 
 -- Get the offset in secs from UTC, if (struct tm) doesn't supply it. */
-#if defined(mingw32_TARGET_OS) || defined(cygwin32_TARGET_OS)
-#define timezone _timezone
-#endif
-
 # if HAVE_ALTZONE
-foreign label altzone  :: Ptr CTime
-foreign label timezone :: Ptr CTime
+foreign import ccall "&altzone"  altzone  :: Ptr CTime
+foreign import ccall "&timezone" timezone :: Ptr CTime
 gmtoff x = do 
   dst <- (#peek struct tm,tm_isdst) x
   tz <- if dst then peek altzone else peek timezone
-  return (fromIntegral tz)
-#  define GMTOFF(x)   	 (((struct tm *)x)->tm_isdst ? altzone : timezone )
+  return (-fromIntegral tz)
 # else /* ! HAVE_ALTZONE */
+
+#if !defined(mingw32_TARGET_OS)
+foreign import ccall unsafe "timezone" timezone :: Ptr CLong
+#endif
+
 -- Assume that DST offset is 1 hour ...
 gmtoff x = do 
   dst <- (#peek struct tm,tm_isdst) x
   tz  <- peek timezone
-  if dst then return (fromIntegral tz - 3600) else return tz
+   -- According to the documentation for tzset(), 
+   --   http://www.opengroup.org/onlinepubs/007908799/xsh/tzset.html
+   -- timezone offsets are > 0 west of the Prime Meridian.
+   --
+   -- This module assumes the interpretation of tm_gmtoff, i.e., offsets
+   -- are > 0 East of the Prime Meridian, so flip the sign.
+  return (- (if dst then (fromIntegral tz - 3600) else tz))
 # endif /* ! HAVE_ALTZONE */
 #endif  /* ! HAVE_TM_ZONE */
+#endif /* ! __HUGS__ */
 
 -- -----------------------------------------------------------------------------
 -- toCalendarTime t converts t to a local time, modified by
@@ -366,18 +379,68 @@ gmtoff x = do
 
 
 toCalendarTime :: ClockTime -> IO CalendarTime
-toCalendarTime =  clockToCalendarTime localtime False
+#ifdef __HUGS__
+toCalendarTime =  toCalTime False
+#elif HAVE_LOCALTIME_R
+toCalendarTime =  clockToCalendarTime_reentrant (throwAwayReturnPointer localtime_r) False
+#else
+toCalendarTime =  clockToCalendarTime_static localtime False
+#endif
 
-toUTCTime      :: ClockTime -> CalendarTime
-toUTCTime      =  unsafePerformIO . clockToCalendarTime gmtime True
+toUTCTime :: ClockTime -> CalendarTime
+#ifdef __HUGS__
+toUTCTime      =  unsafePerformIO . toCalTime True
+#elif HAVE_GMTIME_R
+toUTCTime      =  unsafePerformIO . clockToCalendarTime_reentrant (throwAwayReturnPointer gmtime_r) True
+#else
+toUTCTime      =  unsafePerformIO . clockToCalendarTime_static gmtime True
+#endif
 
--- ToDo: should be made thread safe, because localtime uses static storage,
--- or use the localtime_r version.
-clockToCalendarTime :: (Ptr CTime -> IO (Ptr CTm)) -> Bool -> ClockTime
+#ifdef __HUGS__
+toCalTime :: Bool -> ClockTime -> IO CalendarTime
+toCalTime toUTC (TOD s psecs)
+  | (s > fromIntegral (maxBound :: Int)) || 
+    (s < fromIntegral (minBound :: Int))
+  = error ((if toUTC then "toUTCTime: " else "toCalendarTime: ") ++
+           "clock secs out of range")
+  | otherwise = do
+    (sec,min,hour,mday,mon,year,wday,yday,isdst,zone,off) <- 
+  		toCalTimePrim (if toUTC then 1 else 0) (fromIntegral s)
+    return (CalendarTime{ ctYear=1900+year
+  		        , ctMonth=toEnum mon
+		        , ctDay=mday
+		        , ctHour=hour
+		        , ctMin=min
+		        , ctSec=sec
+		        , ctPicosec=psecs
+		        , ctWDay=toEnum wday
+		        , ctYDay=yday
+		        , ctTZName=(if toUTC then "UTC" else zone)
+		        , ctTZ=(if toUTC then 0 else off)
+		        , ctIsDST=not toUTC && (isdst/=0)
+		        })
+#else /* ! __HUGS__ */
+throwAwayReturnPointer :: (Ptr CTime -> Ptr CTm -> IO (Ptr CTm))
+                       -> (Ptr CTime -> Ptr CTm -> IO (       ))
+throwAwayReturnPointer fun x y = fun x y >> return ()
+
+clockToCalendarTime_static :: (Ptr CTime -> IO (Ptr CTm)) -> Bool -> ClockTime
 	 -> IO CalendarTime
-clockToCalendarTime fun is_utc (TOD secs psec) = do
+clockToCalendarTime_static fun is_utc (TOD secs psec) = do
   withObject (fromIntegral secs :: CTime)  $ \ p_timer -> do
     p_tm <- fun p_timer 	-- can't fail, according to POSIX
+    clockToCalendarTime_aux is_utc p_tm psec
+
+clockToCalendarTime_reentrant :: (Ptr CTime -> Ptr CTm -> IO ()) -> Bool -> ClockTime
+	 -> IO CalendarTime
+clockToCalendarTime_reentrant fun is_utc (TOD secs psec) = do
+  withObject (fromIntegral secs :: CTime)  $ \ p_timer -> do
+    allocaBytes (#const sizeof(struct tm)) $ \ p_tm -> do
+      fun p_timer p_tm
+      clockToCalendarTime_aux is_utc p_tm psec
+
+clockToCalendarTime_aux :: Bool -> Ptr CTm -> Integer -> IO CalendarTime
+clockToCalendarTime_aux is_utc p_tm psec = do
     sec   <-  (#peek struct tm,tm_sec  ) p_tm :: IO CInt
     min   <-  (#peek struct tm,tm_min  ) p_tm :: IO CInt
     hour  <-  (#peek struct tm,tm_hour ) p_tm :: IO CInt
@@ -408,9 +471,18 @@ clockToCalendarTime fun is_utc (TOD secs psec) = do
 		(if is_utc then "UTC" else tzname)
 		(if is_utc then 0     else fromIntegral tz)
 		(if is_utc then False else isdst /= 0))
-
+#endif /* ! __HUGS__ */
 
 toClockTime :: CalendarTime -> ClockTime
+#ifdef __HUGS__
+toClockTime (CalendarTime yr mon mday hour min sec psec
+			  _wday _yday _tzname tz isdst) =
+  unsafePerformIO $ do
+    s <- toClockTimePrim (yr-1900) (fromEnum mon) mday
+  		         hour min sec
+		         tz (if isdst then 1 else 0)
+    return (TOD (fromIntegral s) psec)
+#else /* ! __HUGS__ */
 toClockTime (CalendarTime year mon mday hour min sec psec 
 			  _wday _yday _tzname tz isdst) =
 
@@ -451,7 +523,8 @@ toClockTime (CalendarTime year mon mday hour min sec psec
         -- 
         gmtoff <- gmtoff p_tm
 	let res = fromIntegral t - tz + fromIntegral gmtoff
-	return (TOD (fromIntegral res) 0)
+	return (TOD (fromIntegral res) psec)
+#endif /* ! __HUGS__ */
 
 -- -----------------------------------------------------------------------------
 -- Converting time values to strings.
@@ -593,27 +666,36 @@ formatTimeDiff l fmt td@(TimeDiff year month day hour min sec _)
 
    addS v s = if abs v == 1 then fst s else snd s
 
-
+#ifndef __HUGS__
 -- -----------------------------------------------------------------------------
 -- Foreign time interface (POSIX)
 
 type CTm = () -- struct tm
 
-foreign import unsafe localtime :: Ptr CTime -> IO (Ptr CTm)
-foreign import unsafe gmtime    :: Ptr CTime -> IO (Ptr CTm)
-foreign import unsafe mktime    :: Ptr CTm   -> IO CTime
-foreign import unsafe time      :: Ptr CTime -> IO CTime
+#if HAVE_LOCALTIME_R
+foreign import ccall unsafe localtime_r :: Ptr CTime -> Ptr CTm -> IO (Ptr CTm)
+#else
+foreign import ccall unsafe localtime   :: Ptr CTime -> IO (Ptr CTm)
+#endif
+#if HAVE_GMTIME_R
+foreign import ccall unsafe gmtime_r    :: Ptr CTime -> Ptr CTm -> IO (Ptr CTm)
+#else
+foreign import ccall unsafe gmtime      :: Ptr CTime -> IO (Ptr CTm)
+#endif
+foreign import ccall unsafe mktime      :: Ptr CTm   -> IO CTime
+foreign import ccall unsafe time        :: Ptr CTime -> IO CTime
 
 #if HAVE_GETTIMEOFDAY
 type CTimeVal = ()
-foreign import unsafe gettimeofday :: Ptr CTimeVal -> Ptr () -> IO CInt
+foreign import ccall unsafe gettimeofday :: Ptr CTimeVal -> Ptr () -> IO CInt
 #endif
 
 #if HAVE_FTIME
 type CTimeB = ()
 #ifndef mingw32_TARGET_OS
-foreign import unsafe ftime :: Ptr CTimeB -> IO CInt
+foreign import ccall unsafe ftime :: Ptr CTimeB -> IO CInt
 #else
-foreign import unsafe ftime :: Ptr CTimeB -> IO ()
+foreign import ccall unsafe ftime :: Ptr CTimeB -> IO ()
 #endif
 #endif
+#endif /* ! __HUGS__ */