6cbcc54138
* xeinfo.adb: Don't look for revision numbers. * xnmake.adb: Likewise. * xsinfo.adb: Likewise. * xsnames.adb: Likewise. * xtreeprs.adb: Likewise. From-SVN: r50768
396 lines
12 KiB
Ada
396 lines
12 KiB
Ada
------------------------------------------------------------------------------
|
|
-- --
|
|
-- GNAT RUN-TIME COMPONENTS --
|
|
-- --
|
|
-- A D A . C A L E N D A R --
|
|
-- --
|
|
-- B o d y --
|
|
-- --
|
|
-- --
|
|
-- Copyright (C) 1997-2001 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. --
|
|
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
|
-- --
|
|
------------------------------------------------------------------------------
|
|
|
|
-- 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 : 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;
|