| ------------------------------------------------------------------------------ |
| -- -- |
| -- GNAT RUN-TIME COMPONENTS -- |
| -- -- |
| -- A D A . C A L E N D A R -- |
| -- -- |
| -- B o d y -- |
| -- -- |
| -- Copyright (C) 1997-2002 Free Software Foundation, Inc. -- |
| -- -- |
| -- GNAT is free software; you can redistribute it and/or modify it under -- |
| -- terms of the GNU General Public License as published by the Free Soft- -- |
| -- ware Foundation; either version 2, or (at your option) any later ver- -- |
| -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- |
| -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- |
| -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- |
| -- for more details. You should have received a copy of the GNU General -- |
| -- Public License distributed with GNAT; see file COPYING. If not, write -- |
| -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- |
| -- MA 02111-1307, USA. -- |
| -- -- |
| -- As a special exception, if other files instantiate generics from this -- |
| -- unit, or you link this unit with other files to produce an executable, -- |
| -- this unit does not by itself cause the resulting executable to be -- |
| -- covered by the GNU General Public License. This exception does not -- |
| -- however invalidate any other reasons why the executable file might be -- |
| -- covered by the GNU Public License. -- |
| -- -- |
| -- GNAT was originally developed by the GNAT team at New York University. -- |
| -- Extensive contributions were provided by Ada Core Technologies Inc. -- |
| -- -- |
| ------------------------------------------------------------------------------ |
| |
| -- This is the Windows NT/95 version. |
| |
| with System.OS_Primitives; |
| -- used for Clock |
| |
| with System.OS_Interface; |
| |
| package body Ada.Calendar is |
| |
| use System.OS_Interface; |
| |
| ------------------------------ |
| -- Use of Pragma Unsuppress -- |
| ------------------------------ |
| |
| -- This implementation of Calendar takes advantage of the permission in |
| -- Ada 95 of using arithmetic overflow checks to check for out of bounds |
| -- time values. This means that we must catch the constraint error that |
| -- results from arithmetic overflow, so we use pragma Unsuppress to make |
| -- sure that overflow is enabled, using software overflow checking if |
| -- necessary. That way, compiling Calendar with options to suppress this |
| -- checking will not affect its correctness. |
| |
| ------------------------ |
| -- Local Declarations -- |
| ------------------------ |
| |
| Ada_Year_Min : constant := 1901; |
| Ada_Year_Max : constant := 2099; |
| |
| -- Win32 time constants |
| |
| epoch_1970 : constant := 16#19D_B1DE_D53E_8000#; -- win32 UTC epoch |
| system_time_ns : constant := 100; -- 100 ns per tick |
| Sec_Unit : constant := 10#1#E9; |
| |
| --------- |
| -- "+" -- |
| --------- |
| |
| function "+" (Left : Time; Right : Duration) return Time is |
| pragma Unsuppress (Overflow_Check); |
| begin |
| return (Left + Time (Right)); |
| |
| exception |
| when Constraint_Error => |
| raise Time_Error; |
| end "+"; |
| |
| function "+" (Left : Duration; Right : Time) return Time is |
| pragma Unsuppress (Overflow_Check); |
| begin |
| return (Time (Left) + Right); |
| |
| exception |
| when Constraint_Error => |
| raise Time_Error; |
| end "+"; |
| |
| --------- |
| -- "-" -- |
| --------- |
| |
| function "-" (Left : Time; Right : Duration) return Time is |
| pragma Unsuppress (Overflow_Check); |
| begin |
| return Left - Time (Right); |
| |
| exception |
| when Constraint_Error => |
| raise Time_Error; |
| end "-"; |
| |
| function "-" (Left : Time; Right : Time) return Duration is |
| pragma Unsuppress (Overflow_Check); |
| begin |
| return Duration (Left) - Duration (Right); |
| |
| exception |
| when Constraint_Error => |
| raise Time_Error; |
| end "-"; |
| |
| --------- |
| -- "<" -- |
| --------- |
| |
| function "<" (Left, Right : Time) return Boolean is |
| begin |
| return Duration (Left) < Duration (Right); |
| end "<"; |
| |
| ---------- |
| -- "<=" -- |
| ---------- |
| |
| function "<=" (Left, Right : Time) return Boolean is |
| begin |
| return Duration (Left) <= Duration (Right); |
| end "<="; |
| |
| --------- |
| -- ">" -- |
| --------- |
| |
| function ">" (Left, Right : Time) return Boolean is |
| begin |
| return Duration (Left) > Duration (Right); |
| end ">"; |
| |
| ---------- |
| -- ">=" -- |
| ---------- |
| |
| function ">=" (Left, Right : Time) return Boolean is |
| begin |
| return Duration (Left) >= Duration (Right); |
| end ">="; |
| |
| ----------- |
| -- Clock -- |
| ----------- |
| |
| -- The Ada.Calendar.Clock function gets the time from the soft links |
| -- interface which will call the appropriate function depending wether |
| -- tasking is involved or not. |
| |
| function Clock return Time is |
| begin |
| return Time (System.OS_Primitives.Clock); |
| end Clock; |
| |
| --------- |
| -- Day -- |
| --------- |
| |
| function Day (Date : Time) return Day_Number is |
| DY : Year_Number; |
| DM : Month_Number; |
| DD : Day_Number; |
| DS : Day_Duration; |
| |
| begin |
| Split (Date, DY, DM, DD, DS); |
| return DD; |
| end Day; |
| |
| ----------- |
| -- Month -- |
| ----------- |
| |
| function Month (Date : Time) return Month_Number is |
| DY : Year_Number; |
| DM : Month_Number; |
| DD : Day_Number; |
| DS : Day_Duration; |
| |
| begin |
| Split (Date, DY, DM, DD, DS); |
| return DM; |
| end Month; |
| |
| ------------- |
| -- Seconds -- |
| ------------- |
| |
| function Seconds (Date : Time) return Day_Duration is |
| DY : Year_Number; |
| DM : Month_Number; |
| DD : Day_Number; |
| DS : Day_Duration; |
| |
| begin |
| Split (Date, DY, DM, DD, DS); |
| return DS; |
| end Seconds; |
| |
| ----------- |
| -- Split -- |
| ----------- |
| |
| procedure Split |
| (Date : Time; |
| Year : out Year_Number; |
| Month : out Month_Number; |
| Day : out Day_Number; |
| Seconds : out Day_Duration) |
| is |
| |
| Date_Int : aliased Long_Long_Integer; |
| Date_Loc : aliased Long_Long_Integer; |
| Timbuf : aliased SYSTEMTIME; |
| Int_Date : Long_Long_Integer; |
| Sub_Seconds : Duration; |
| |
| begin |
| -- We take the sub-seconds (decimal part) of Date and this is added |
| -- to compute the Seconds. This way we keep the precision of the |
| -- high-precision clock that was lost with the Win32 API calls |
| -- below. |
| |
| if Date < 0.0 then |
| |
| -- this is a Date before Epoch (January 1st, 1970) |
| |
| Sub_Seconds := Duration (Date) - |
| Duration (Long_Long_Integer (Date + Duration'(0.5))); |
| |
| Int_Date := Long_Long_Integer (Date - Sub_Seconds); |
| |
| -- For Date = -86400.1 we are 2 days before Epoch at 0.1 seconds |
| -- from day 1 before Epoch. It means that it is 23h 59m 59.9s. |
| -- here we adjust for that. |
| |
| if Sub_Seconds < 0.0 then |
| Int_Date := Int_Date - 1; |
| Sub_Seconds := 1.0 + Sub_Seconds; |
| end if; |
| |
| else |
| |
| -- this is a Date after Epoch (January 1st, 1970) |
| |
| Sub_Seconds := Duration (Date) - |
| Duration (Long_Long_Integer (Date - Duration'(0.5))); |
| |
| Int_Date := Long_Long_Integer (Date - Sub_Seconds); |
| |
| end if; |
| |
| -- Date_Int is the number of seconds from Epoch. |
| |
| Date_Int := Long_Long_Integer |
| (Int_Date * Sec_Unit / system_time_ns) + epoch_1970; |
| |
| if not FileTimeToLocalFileTime (Date_Int'Access, Date_Loc'Access) then |
| raise Time_Error; |
| end if; |
| |
| if not FileTimeToSystemTime (Date_Loc'Access, Timbuf'Access) then |
| raise Time_Error; |
| end if; |
| |
| if Timbuf.wYear not in Ada_Year_Min .. Ada_Year_Max then |
| raise Time_Error; |
| end if; |
| |
| Seconds := |
| Duration (Timbuf.wHour) * 3_600.0 + |
| Duration (Timbuf.wMinute) * 60.0 + |
| Duration (Timbuf.wSecond) + |
| Sub_Seconds; |
| |
| Day := Integer (Timbuf.wDay); |
| Month := Integer (Timbuf.wMonth); |
| Year := Integer (Timbuf.wYear); |
| end Split; |
| |
| ------------- |
| -- Time_Of -- |
| ------------- |
| |
| function Time_Of |
| (Year : Year_Number; |
| Month : Month_Number; |
| Day : Day_Number; |
| Seconds : Day_Duration := 0.0) |
| return Time |
| is |
| |
| Timbuf : aliased SYSTEMTIME; |
| Now : aliased Long_Long_Integer; |
| Loc : aliased Long_Long_Integer; |
| Int_Secs : Integer; |
| Secs : Integer; |
| Add_One_Day : Boolean := False; |
| Date : Time; |
| |
| begin |
| -- The following checks are redundant with respect to the constraint |
| -- error checks that should normally be made on parameters, but we |
| -- decide to raise Constraint_Error in any case if bad values come |
| -- in (as a result of checks being off in the caller, or for other |
| -- erroneous or bounded error cases). |
| |
| if not Year 'Valid |
| or else not Month 'Valid |
| or else not Day 'Valid |
| or else not Seconds'Valid |
| then |
| raise Constraint_Error; |
| end if; |
| |
| if Seconds = 0.0 then |
| Int_Secs := 0; |
| else |
| Int_Secs := Integer (Seconds - 0.5); |
| end if; |
| |
| -- Timbuf.wMillisec is to keep the msec. We can't use that because the |
| -- high-resolution clock has a precision of 1 Microsecond. |
| -- Anyway the sub-seconds part is not needed to compute the number |
| -- of seconds in UTC. |
| |
| if Int_Secs = 86_400 then |
| Secs := 0; |
| Add_One_Day := True; |
| else |
| Secs := Int_Secs; |
| end if; |
| |
| Timbuf.wMilliseconds := 0; |
| Timbuf.wSecond := WORD (Secs mod 60); |
| Timbuf.wMinute := WORD ((Secs / 60) mod 60); |
| Timbuf.wHour := WORD (Secs / 3600); |
| Timbuf.wDay := WORD (Day); |
| Timbuf.wMonth := WORD (Month); |
| Timbuf.wYear := WORD (Year); |
| |
| if not SystemTimeToFileTime (Timbuf'Access, Loc'Access) then |
| raise Time_Error; |
| end if; |
| |
| if not LocalFileTimeToFileTime (Loc'Access, Now'Access) then |
| raise Time_Error; |
| end if; |
| |
| -- Here we have the UTC now translate UTC to Epoch time (UNIX style |
| -- time based on 1 january 1970) and add there the sub-seconds part. |
| |
| declare |
| Sub_Sec : constant Duration := Seconds - Duration (Int_Secs); |
| begin |
| Date := Time ((Now - epoch_1970) * system_time_ns / Sec_Unit) + |
| Sub_Sec; |
| end; |
| |
| if Add_One_Day then |
| Date := Date + Duration (86400.0); |
| end if; |
| |
| return Date; |
| end Time_Of; |
| |
| ---------- |
| -- Year -- |
| ---------- |
| |
| function Year (Date : Time) return Year_Number is |
| DY : Year_Number; |
| DM : Month_Number; |
| DD : Day_Number; |
| DS : Day_Duration; |
| |
| begin |
| Split (Date, DY, DM, DD, DS); |
| return DY; |
| end Year; |
| |
| end Ada.Calendar; |