ada/xmlada
0
0
Fork 0
mirror of https://github.com/AdaCore/xmlada.git synced 2026-02-12 12:30:28 -08:00
Code Issues Packages Projects Releases Wiki Activity
Files
master
xmlada/schema/schema-date_time.adb
Emmanuel Briot 53dc51bf5c Update copyright notices 
Change-Id: Iae1283292b460ead48dedc565d6f24259e497e69
2017-01-03 10:02:38 +01:00

1578 lines
45 KiB
Ada
Raw Permalink Blame History

------------------------------------------------------------------------------
-- XML/Ada - An XML suite for Ada95 --
-- --
-- Copyright (C) 2005-2017, AdaCore --
-- --
-- This library is free software; you can redistribute it and/or modify it --
-- under terms of the GNU General Public License as published by the Free --
-- Software Foundation; either version 3, or (at your option) any later --
-- version. This library is distributed in the hope that it will be useful, --
-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
------------------------------------------------------------------------------
with Ada.Characters.Handling; use Ada.Characters.Handling;
package body Schema.Date_Time is
procedure Parse
(Symbols : Symbol_Table;
Ch : String;
Date : out Date_NZ_T;
Eos : out Natural;
Error : out Symbol);
procedure Parse
(Symbols : Symbol_Table;
Ch : String; Time : out Time_NZ_T; Eos : out Natural;
Error : out Symbol);
procedure Parse
(Symbols : Symbol_Table;
Ch : String; TZ : out Timezone_T; Error : out Symbol);
procedure Parse_Year
(Symbols : Symbol_Table;
Ch : String; Year : out Integer; Eos : out Natural; Error : out Symbol);
-- Parse the various components of dates.
-- On exit, Eos is set to the first unused character in Ch, except for the
-- timezone which must finish on the last character in Ch.
-- The No_* parameter indicate that the corresponding part should not be
-- found in Ch.
function Image (Date : Date_NZ_T) return String;
function Image (TZ : Timezone_T) return String;
function Image (Time : Time_NZ_T) return String;
-- Return the string representation of the parameter.
type Compare_Result is (Less_Than, Equal, Greater_Than, Uncomparable);
function Compare (Time1, Time2 : Date_Time_T) return Compare_Result;
function Compare (Date1, Date2 : Date_NZ_T) return Compare_Result;
function Compare (Time1, Time2 : Time_NZ_T) return Compare_Result;
function Compare (Duration1, Duration2 : Duration_T) return Compare_Result;
-- Compare the two parameters. The parameters must have been normalized
-- prior to the call. Timezones are taken into account if present
function To_Date_Time (Time : Time_T) return Date_Time_T;
function To_Date_Time (Date : Date_T) return Date_Time_T;
function To_Date_Time (Day : GDay_T) return Date_Time_T;
function To_Date_Time (Day : GMonth_Day_T) return Date_Time_T;
function To_Date_Time (Month : GMonth_T) return Date_Time_T;
function To_Date_Time (Year : GYear_T) return Date_Time_T;
function To_Date_Time (Month : GYear_Month_T) return Date_Time_T;
-- Convert the parameter to a Date_Time
function Normalize (Date : Date_Time_T) return Date_Time_T;
function Normalize (Duration : Duration_T) return Duration_T;
-- Return a normalized version of Date, ie with a time zone of 0. There
-- will be no time zone set for the result if Date has no timezone
procedure Normalize (Date : in out Date_NZ_T);
-- Make sure that the day is valid in the date. Otherwise, change the month
-- and year until we end up on a valid day
function Image (Value : Integer; Num_Digits : Natural := 2) return String;
-- Return the image of Value, in a string of Num_Digits characters long
function MS_Image (Sub_Second : Day_Range) return String;
-- Return the image to use for milliseconds (nothing if 0, or the minimal
-- number of digits)
generic
Field : Integer;
Char : Character;
function Component_Image return String;
-- Return each component of the duration, in the format expected for
-- durations. Nothing is returned if the matching component is
-- null;
function Max_Days_In_Month (Year, Month : Integer) return Integer;
-- Return the maximum number of days in the given month. Month is
-- allowed to be outside the range 1 .. 12
generic
type T is private;
with function Normalize (T1 : T) return T is <>;
with function Compare (T1, T2 : T) return Compare_Result is <>;
package Comparators is
function "<" (T1, T2 : T) return Boolean;
function "<=" (T1, T2 : T) return Boolean;
function "=" (T1, T2 : T) return Boolean;
function ">" (T1, T2 : T) return Boolean;
function ">=" (T1, T2 : T) return Boolean;
end Comparators;
-- Generate the comparison functions for various types
generic
type T is private;
with function To_Date_Time (T1 : T) return Date_Time_T is <>;
package DT_Comparators is
function "<" (T1, T2 : T) return Boolean;
function "<=" (T1, T2 : T) return Boolean;
function "=" (T1, T2 : T) return Boolean;
function ">" (T1, T2 : T) return Boolean;
function ">=" (T1, T2 : T) return Boolean;
end DT_Comparators;
------------------
-- To_Date_Time --
------------------
function To_Date_Time (Time : Time_T) return Date_Time_T is
begin
return Date_Time_T'(No_Date_NZ, Time.Time, Time.TZ);
end To_Date_Time;
function To_Date_Time (Day : GDay_T) return Date_Time_T is
begin
return Date_Time_T'((2001, 01, Day.Day), No_Time_NZ, Day.TZ);
end To_Date_Time;
function To_Date_Time (Day : GMonth_Day_T) return Date_Time_T is
begin
return Date_Time_T'((2001, Day.Month, Day.Day), No_Time_NZ, Day.TZ);
end To_Date_Time;
function To_Date_Time (Month : GMonth_T) return Date_Time_T is
begin
return Date_Time_T'((2001, Month.Month, 1), No_Time_NZ, Month.TZ);
end To_Date_Time;
function To_Date_Time (Year : GYear_T) return Date_Time_T is
begin
return Date_Time_T'((Year.Year, 01, 15), No_Time_NZ, Year.TZ);
end To_Date_Time;
function To_Date_Time (Month : GYear_Month_T) return Date_Time_T is
begin
return Date_Time_T'((Month.Year, Month.Month, 01), No_Time_NZ, Month.TZ);
end To_Date_Time;
function To_Date_Time (Date : Date_T) return Date_Time_T is
begin
return Date_Time_T'(Date.Date, No_Time_NZ, Date.TZ);
end To_Date_Time;
-----------
-- Image --
-----------
function Image (Value : Integer; Num_Digits : Natural := 2) return String is
Str : constant String := Integer'Image (Value);
Padding : constant String (1 .. Num_Digits) := (others => '0');
begin
if Value < 0 then
if Str'Length - 1 > Num_Digits then
-- No padding, return the whole string
return Str;
else
return '-' & Padding (1 .. Num_Digits - Str'Last + Str'First)
& Str (Str'First + 1 .. Str'Last);
end if;
else
if Str'Length - 1 > Num_Digits then
return Str (Str'First + 1 .. Str'Last);
else
return Padding (1 .. Num_Digits - Str'Last + Str'First)
& Str (Str'First + 1 .. Str'Last);
end if;
end if;
end Image;
---------------------
-- Component_Image --
---------------------
function Component_Image return String is
begin
if Field = 0 then
return "";
else
return Image (abs (Field), 1) & Char;
end if;
end Component_Image;
-----------
-- Image --
-----------
function Image (Date : Date_NZ_T) return String is
begin
return Image (Date.Year, 4)
& '-' & Image (abs (Date.Month), 2) & '-'
& Image (abs (Date.Day), 2);
end Image;
function Image (Day : GDay_T) return String is
begin
return "---" & Image (Day.Day, 2) & Image (Day.TZ);
end Image;
function Image (Day : GMonth_Day_T) return String is
begin
return "--" & Image (Day.Month, 2) & '-' & Image (Day.Day, 2)
& Image (Day.TZ);
end Image;
function Image (Month : GMonth_T) return String is
begin
return "--" & Image (Month.Month, 2) & Image (Month.TZ);
end Image;
function Image (Year : GYear_T) return String is
begin
return Image (Year.Year, 4) & Image (Year.TZ);
end Image;
function Image (Month : GYear_Month_T) return String is
begin
return Image (Month.Year, 4) & '-' & Image (Month.Month, 2)
& Image (Month.TZ);
end Image;
function Image (Date : Date_T) return String is
begin
return Image (Date.Date) & Image (Date.TZ);
end Image;
function Image (Date : Date_Time_T) return String is
begin
return Image (Date.Date) & 'T' & Image (Date.Time) & Image (Date.TZ);
end Image;
function Image (Time : Time_T) return String is
begin
return Image (Time.Time) & Image (Time.TZ);
end Image;
--------------
-- MS_Image --
--------------
function MS_Image (Sub_Second : Day_Range) return String is
Sub : constant String := Day_Range'Image (Sub_Second);
Last : Natural := Sub'Last;
begin
if Sub_Second = 0.0 then
return "";
else
while Last >= Sub'First and Sub (Last) = '0' loop
Last := Last - 1;
end loop;
-- Skip '0.' in the subseconds image
return Sub (Sub'First + 2 .. Last);
end if;
end MS_Image;
-----------
-- Image --
-----------
function Image (Time : Time_NZ_T) return String is
Hour, Min, Secs : Natural;
Sub_Second : Time_NZ_T;
begin
if Time = 0.0 then
Secs := 0;
else
Secs := Natural (abs (Time) - 0.5);
end if;
Sub_Second := abs (Time) - Time_NZ_T (Secs);
Hour := Integer (Secs / 3600);
Secs := Secs mod 3600;
Min := Integer (Secs / 60);
Secs := Secs mod 60;
return Image (Hour, 2) & ':' & Image (Min, 2)
& ':' & Image (Secs, 2) & MS_Image (Sub_Second);
end Image;
-----------
-- Image --
-----------
function Image (Duration : Duration_T) return String is
Hour, Min, Secs : Natural;
Sub_Second : Time_NZ_T;
function Year_Image is new Component_Image (Duration.Year, 'Y');
function Month_Image is new Component_Image (Duration.Month, 'M');
function Day_Image is new Component_Image (Duration.Day, 'D');
function Secs_Image return String;
function Secs_Image return String is
Im : constant String := Image (Secs, 1) & MS_Image (Sub_Second) & 'S';
begin
if Im /= "0S" then
return Im;
else
return "";
end if;
end Secs_Image;
begin
if Duration.Seconds = 0.0 then
Secs := 0;
else
Secs := Natural (abs (Duration.Seconds) - 0.5);
end if;
Sub_Second := abs (Duration.Seconds) - Time_NZ_T (Secs);
Hour := Integer (Secs / 3600);
Secs := Secs mod 3600;
Min := Integer (Secs / 60);
Secs := Secs mod 60;
declare
function Hour_Image is new Component_Image (Hour, 'H');
function Min_Image is new Component_Image (Min, 'M');
Date_Img : constant String := Year_Image & Month_Image & Day_Image;
Time_Img : constant String := Hour_Image & Min_Image & Secs_Image;
begin
if Duration.Sign < 0 then
if Time_Img'Length /= 0 then
return "-P" & Date_Img & 'T' & Time_Img;
else
return "-P" & Date_Img;
end if;
else
if Time_Img'Length /= 0 then
return 'P' & Date_Img & 'T' & Time_Img;
else
return 'P' & Date_Img;
end if;
end if;
end;
end Image;
-----------
-- Image --
-----------
function Image (TZ : Timezone_T) return String is
begin
if TZ = No_Timezone then
return "";
elsif TZ = 0 then
return "Z";
elsif TZ < 0 then
return '-' & Image (abs (Integer (TZ)) / 60, 2) & ':'
& Image (abs (Integer (TZ)) mod 60, 2);
else
return '+' & Image (abs (Integer (TZ)) / 60, 2) & ':'
& Image (abs (Integer (TZ)) mod 60, 2);
end if;
end Image;
----------------
-- Parse_Year --
----------------
procedure Parse_Year
(Symbols : Symbol_Table;
Ch : String;
Year : out Integer;
Eos : out Natural;
Error : out Symbol)
is
Pos : Integer := Ch'First;
begin
if Ch (Pos) = '-' then
Pos := Pos + 1;
end if;
while Pos <= Ch'Last
and then Ch (Pos) /= '-'
and then Ch (Pos) /= 'Z'
loop
Pos := Pos + 1;
end loop;
Year := Integer'Value (Ch (Ch'First .. Pos - 1));
if Year = 0 then
Error := Find
(Symbols, "Year cannot be null in: """ & Ch & """");
Eos := Ch'Last;
return;
elsif Pos - Ch'First < 4 then
Error := Find (Symbols, "Year must include at least four digits");
return;
end if;
Eos := Pos;
Error := No_Symbol;
exception
when Constraint_Error =>
Error := Find (Symbols, "Invalid year in """ & Ch & """");
Year := 0;
Eos := Ch'Last + 1;
end Parse_Year;
-----------
-- Parse --
-----------
procedure Parse
(Symbols : Symbol_Table;
Ch : String;
Date : out Date_NZ_T;
Eos : out Natural;
Error : out Symbol)
is
Max_Days : constant array (1 .. 12) of Natural :=
(31, 29, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31);
Pos : Integer;
Leap_Year : Boolean;
begin
Parse_Year (Symbols, Ch, Date.Year, Pos, Error);
if Error /= No_Symbol then
Eos := Ch'First;
return;
end if;
if Pos > Ch'Last then
Error := Find
(Symbols, "Invalid date (no month) """ & Ch & """");
Date := No_Date_NZ;
Eos := Ch'First;
return;
end if;
if Ch (Pos) /= '-'
or else Ch (Pos + 3) /= '-'
or else (Pos + 6 <= Ch'Last
and then Ch (Pos + 6) /= 'T'
and then Ch (Pos + 6) /= '-'
and then Ch (Pos + 6) /= '+'
and then Ch (Pos + 6) /= 'Z')
then
Error := Find
(Symbols, "Invalid separator in date value """ & Ch & """");
Date := No_Date_NZ;
Eos := Ch'First;
return;
end if;
Date.Month := Integer'Value (Ch (Pos + 1 .. Pos + 2));
if Date.Month < 1 or else Date.Month > 12 then
Error := Find (Symbols, "Invalid month in """ & Ch & '"');
return;
end if;
Date.Day := Integer'Value (Ch (Pos + 4 .. Pos + 5));
Eos := Pos + 6;
-- Check that the date is correct.
-- We cannot use Ada.Calendar, since its range of dates is much more
-- limited than the one in XML.
Leap_Year :=
Date.Year mod 4 = 0
and then (Date.Year mod 100 /= 0 or else Date.Year mod 400 = 0);
if Date.Day > Max_Days (Date.Month)
or else (Date.Month = 2
and then (Date.Day > 29
or else (Date.Day = 29 and then not Leap_Year)))
then
Error := Find (Symbols, "Invalid date """ & Ch & """");
-- & Date.Year'Image & Date.Month'Img & Date.Day'Img);
Date := No_Date_NZ;
Eos := Ch'Last + 1;
return;
end if;
Error := No_Symbol;
exception
when Constraint_Error =>
Error := Find (Symbols, "Invalid date """ & Ch & """");
Date := No_Date_NZ;
Eos := Ch'Last + 1;
end Parse;
-----------
-- Parse --
-----------
procedure Parse
(Symbols : Symbol_Table;
Ch : String;
Time : out Time_NZ_T;
Eos : out Natural;
Error : out Symbol)
is
-- Format is "hh:mm:ss.sss[+-]hh:mm"
Pos : Integer;
Hour, Min : Integer;
Msec : Day_Range := 0.0;
begin
Hour := Integer'Value (Ch (Ch'First .. Ch'First + 1));
if Ch (Ch'First + 2) /= ':'
or else Ch (Ch'First + 5) /= ':'
then
Error := Find
(Symbols, "Invalid separator in time: """ & Ch & """");
Time := No_Time_NZ;
Eos := Ch'First;
return;
end if;
Min := Integer'Value (Ch (Ch'First + 3 .. Ch'First + 4));
if Min > 59 then
Error := Find
(Symbols, "Invalid minutes in time: """ & Ch & """");
Time := No_Time_NZ;
return;
end if;
Pos := Ch'First + 8;
if Pos = Ch'Last and then Ch (Pos) = '.' then
Error := Find
(Symbols, "'.' must be followed by digits in """ & Ch & """");
return;
end if;
if Pos < Ch'Last and then Ch (Pos) = '.' then
Pos := Pos + 1;
while Pos <= Ch'Last and then Is_Decimal_Digit (Ch (Pos)) loop
Pos := Pos + 1;
end loop;
Msec := Day_Range'Value (Ch (Ch'First + 6 .. Pos - 1));
Eos := Pos;
else
Msec := Day_Range'Value (Ch (Ch'First + 6 .. Ch'First + 7));
Eos := Ch'First + 8;
end if;
if Msec >= 60.0 then
Error := Find (Symbols, "Invalid seconds in time: """ & Ch & """");
Time := No_Time_NZ;
return;
end if;
if Hour > 24
or else (Hour = 24 and then (Min /= 0 or else Msec /= 0.0))
then
Error := Find (Symbols, "Invalid hour in time: """ & Ch & """");
Time := No_Time_NZ;
return;
end if;
Error := No_Symbol;
Time := Day_Range (Hour) * 3600.0 + Day_Range (Min) * 60.0 + Msec;
exception
when Constraint_Error =>
Error := Find (Symbols, "Invalid time: """ & Ch & """");
Time := No_Time_NZ;
Eos := Ch'Last + 1;
end Parse;
-----------
-- Parse --
-----------
procedure Parse
(Symbols : Symbol_Table;
Ch : String;
TZ : out Timezone_T;
Error : out Symbol) is
begin
if Ch'Length /= 0 then
if Ch (Ch'First) = 'Z' then
if Ch'Length /= 1 then
Error := Find (Symbols, "Invalid time zone in """ & Ch & """");
TZ := No_Timezone;
return;
else
TZ := 0;
end if;
elsif Ch'Length /= 6 then
Error := Find (Symbols, "Invalid time zone in """ & Ch & """");
TZ := No_Timezone;
return;
else
if (Ch (Ch'First) /= '-' and then Ch (Ch'First) /= '+')
or else Ch (Ch'First + 3) /= ':'
then
Error := Find
(Symbols,
"Invalid time zone specification in """ & Ch & """");
TZ := No_Timezone;
return;
end if;
TZ :=
Timezone_T'Value (Ch (Ch'First + 1 .. Ch'First + 2)) * 60
+ Timezone_T'Value (Ch (Ch'First + 4 .. Ch'First + 5));
if abs (TZ) > 14 * 60 then
Error := Find
(Symbols, "Invalid time zone range in """ & Ch & """");
TZ := No_Timezone;
return;
end if;
if Ch (Ch'First) = '-' then
TZ := -TZ;
end if;
end if;
else
TZ := No_Timezone;
end if;
Error := No_Symbol;
exception
when Constraint_Error =>
Error := Find
(Symbols, "Invalid time zone specification in """ & Ch & """");
TZ := No_Timezone;
end Parse;
-----------
-- Value --
-----------
procedure Value
(Symbols : Symbol_Table;
Ch : String;
Val : out Duration_T;
Error : out Symbol)
is
Pos : Integer := Ch'First;
Tmp : Integer;
Processing_Time : Boolean := False;
Hour : Natural;
begin
Val := No_Duration;
if Ch = "" then
Error := Find
(Symbols, "Empty string is not a valid value for duration");
return;
end if;
if Ch (Pos) = '-' then
Val.Sign := -1;
Pos := Pos + 1;
else
Val.Sign := 1;
end if;
if Ch (Pos) /= 'P' then
Error := Find
(Symbols, "Invalid prefix for duration in """ & Ch & """");
return;
end if;
Pos := Pos + 1;
while Pos <= Ch'Last loop
Tmp := Pos;
while Tmp <= Ch'Last
and then (Is_Decimal_Digit (Ch (Tmp)) or else Ch (Tmp) = '.')
loop
Tmp := Tmp + 1;
end loop;
if Tmp > Ch'Last then
Error := Find
(Symbols,
"Missing qualifier after last digit in duration """
& Ch & """");
return;
end if;
if Ch (Tmp) = 'T' then
Processing_Time := True;
if Tmp = Ch'Last then
Error := Find
(Symbols, "Expecting time after T in """ & Ch & """");
return;
end if;
elsif Ch (Tmp) = 'Y' then
if Processing_Time then
Error := Find
(Symbols, "Expecting time component in """ & Ch & """");
return;
end if;
begin
Val.Year := Integer'Value (Ch (Pos .. Tmp - 1));
exception
when Constraint_Error =>
Error := Find
(Symbols, "Expecting an integer for the year, found """
& Ch (Pos .. Tmp - 1) & """");
return;
end;
elsif Ch (Tmp) = 'M' then
if Processing_Time then
Val.Seconds := Val.Seconds + Day_Range
(Integer'Value (Ch (Pos .. Tmp - 1))) * 60.0;
else
Val.Month := Integer'Value (Ch (Pos .. Tmp - 1));
end if;
elsif Ch (Tmp) = 'D' then
if Processing_Time then
Error := Find
(Symbols, "Expecting time component in """ & Ch & """");
return;
end if;
Val.Day := Integer'Value (Ch (Pos .. Tmp - 1));
elsif Ch (Tmp) = 'S' then
if not Processing_Time then
Error := Find
(Symbols, "Expecting date component in """ & Ch & """");
return;
end if;
Val.Seconds := Val.Seconds + Day_Range'Value (Ch (Pos .. Tmp - 1));
elsif Ch (Tmp) = 'H' then
if not Processing_Time then
Error := Find
(Symbols, "Expecting date component in """ & Ch & """");
return;
end if;
Hour := Integer'Value (Ch (Pos .. Tmp - 1));
Val.Seconds := Val.Seconds + Duration (Hour) * 3600.0;
else
Error := Find
(Symbols, "Invalid character '" & Ch (Tmp)
& "' in duration: """ & Ch & """");
return;
end if;
Pos := Tmp + 1;
end loop;
Error := No_Symbol;
end Value;
-----------
-- Value --
-----------
procedure Value
(Symbols : Symbol_Table;
Ch : String;
Val : out Date_Time_T;
Error : out Symbol)
is
Eos : Integer;
begin
Parse (Symbols, Ch, Val.Date, Eos, Error);
if Error /= No_Symbol then
return;
end if;
if Ch (Eos) /= 'T' then
Error := Find
(Symbols, "Invalid date/time separator in """ & Ch & """");
return;
end if;
Parse (Symbols, Ch (Eos + 1 .. Ch'Last), Val.Time, Eos, Error);
if Error /= No_Symbol then
return;
end if;
Parse (Symbols, Ch (Eos .. Ch'Last), Val.TZ, Error);
end Value;
-----------
-- Value --
-----------
procedure Value
(Symbols : Symbol_Table;
Ch : String;
Val : out Date_T;
Error : out Symbol)
is
Eos : Integer;
begin
Parse (Symbols, Ch, Val.Date, Eos, Error);
if Error /= No_Symbol then
return;
end if;
Parse (Symbols, Ch (Eos .. Ch'Last), Val.TZ, Error);
end Value;
-----------
-- Value --
-----------
procedure Value
(Symbols : Symbol_Table;
Ch : String;
Val : out GDay_T;
Error : out Symbol) is
begin
if Ch (Ch'First) /= '-'
or else Ch (Ch'First + 1) /= '-'
or else Ch (Ch'First + 2) /= '-'
then
Error := Find (Symbols, "Invalid date """ & Ch & """");
return;
end if;
Val.Day := Integer'Value (Ch (Ch'First + 3 .. Ch'First + 4));
Parse (Symbols, Ch (Ch'First + 5 .. Ch'Last), Val.TZ, Error);
exception
when Constraint_Error =>
Error := Find (Symbols, "Invalid date """ & Ch & """");
end Value;
-----------
-- Value --
-----------
procedure Value
(Symbols : Symbol_Table;
Ch : String;
Val : out GMonth_Day_T;
Error : out Symbol) is
begin
if Ch (Ch'First .. Ch'First + 1) /= "--"
or else Ch (Ch'First + 4) /= '-'
then
Error := Find (Symbols, "Invalid gMonthDay: """ & Ch & """");
return;
end if;
Val.Month := Integer'Value (Ch (Ch'First + 2 .. Ch'First + 3));
Val.Day := Integer'Value (Ch (Ch'First + 5 .. Ch'First + 6));
Parse (Symbols, Ch (Ch'First + 7 .. Ch'Last), Val.TZ, Error);
exception
when Constraint_Error =>
Error := Find (Symbols, "Invalid gMonthDay: """ & Ch & """");
end Value;
-----------
-- Value --
-----------
procedure Value
(Symbols : Symbol_Table;
Ch : String;
Val : out GMonth_T;
Error : out Symbol)
is
Index : Natural;
begin
if Ch (Ch'First .. Ch'First + 1) /= "--" then
Error := Find (Symbols, "Invalid gMonth: """ & Ch & """");
return;
end if;
Val.Month := Integer'Value (Ch (Ch'First + 2 .. Ch'First + 3));
if Val.Month > 12 then
Error := Find (Symbols, "Invalid month:" & Val.Month'Img);
return;
end if;
Val.TZ := No_Timezone;
if Ch'Last > Ch'First + 3 then
if Ch'Last >= Ch'First + 5
and then Ch (Ch'First + 4 .. Ch'First + 5) = "--"
then
Index := Ch'First + 6;
else
Index := Ch'First + 4;
end if;
if Index < Ch'Last then
Parse (Symbols, Ch (Index .. Ch'Last), Val.TZ, Error);
end if;
else
Error := No_Symbol;
end if;
exception
when Constraint_Error =>
Error := Find (Symbols, "Invalid gMonth: """ & Ch & """");
end Value;
-----------
-- Value --
-----------
procedure Value
(Symbols : Symbol_Table;
Ch : String;
Val : out GYear_T;
Error : out Symbol)
is
Eos : Integer;
begin
Parse_Year (Symbols, Ch, Val.Year, Eos, Error);
if Error /= No_Symbol then
return;
end if;
Parse (Symbols, Ch (Eos .. Ch'Last), Val.TZ, Error);
end Value;
-----------
-- Value --
-----------
procedure Value
(Symbols : Symbol_Table;
Ch : String;
Val : out GYear_Month_T;
Error : out Symbol)
is
Eos : Integer;
begin
Parse_Year (Symbols, Ch, Val.Year, Eos, Error);
if Error /= No_Symbol then
return;
end if;
if Ch (Eos) /= '-' then
Error := Find (Symbols, "Invalid gYearMonth: """ & Ch & """");
return;
end if;
Val.Month := Integer'Value (Ch (Eos + 1 .. Eos + 2));
if Val.Month > 12 then
Error := Find (Symbols, "Invalid month:" & Val.Month'Img);
return;
end if;
Parse (Symbols, Ch (Eos + 3 .. Ch'Last), Val.TZ, Error);
exception
when Constraint_Error =>
Error := Find (Symbols, "Invalid gYearMonth: """ & Ch & """");
end Value;
-----------
-- Value --
-----------
procedure Value
(Symbols : Symbol_Table;
Ch : String;
Val : out Time_T;
Error : out Symbol)
is
Eos : Integer;
begin
Parse (Symbols, Ch, Val.Time, Eos, Error);
if Error /= No_Symbol then
return;
end if;
Parse (Symbols, Ch (Eos .. Ch'Last), Val.TZ, Error);
end Value;
-----------------------
-- Max_Days_In_Month --
-----------------------
function Max_Days_In_Month (Year, Month : Integer) return Integer is
Days : constant array (1 .. 12) of Integer :=
(1 => 31, 2 => 28, 3 => 31, 4 => 30, 5 => 31, 6 => 30, 7 => 31,
8 => 31, 9 => 30, 10 => 31, 11 => 30, 12 => 31);
Y : constant Integer := Year
+ Integer (Float'Floor (Float (Month - 1) / 12.0));
M : constant Integer := 1 + (Month - 1) mod 12;
begin
if M = 2 then
if Y mod 400 = 0
or else (Y mod 100 /= 0 and then Y mod 4 = 0)
then
return 29;
else
return 28;
end if;
else
return Days (M);
end if;
end Max_Days_In_Month;
---------
-- "+" --
---------
function "+"
(Date : Date_Time_T; Duration : Duration_T) return Date_Time_T
is
Result : Date_Time_T := Date;
Tmp : Float;
Tmp2 : Integer;
begin
Result.Date.Month :=
Date.Date.Month + Duration.Sign * Duration.Month;
Result.Date.Year :=
Date.Date.Year + Duration.Sign * Duration.Year;
Result.Date.Day :=
Date.Date.Day + Duration.Sign * Duration.Day;
Result.TZ := Date.TZ;
Tmp := Float (Date.Time)
+ Float (Duration.Sign) * Float (Duration.Seconds);
if Tmp < 0.0 or else Tmp > 86_400.0 then
Tmp2 := Integer (Float'Floor (Tmp / 86_400.0));
Result.Time := Day_Range (Tmp - Float (Tmp2 * 86_400));
Result.Date.Day := Result.Date.Day + Tmp2;
else
-- Redo the computation based on the Duration type, to avoid
-- rounding error. We know for sur the result will be in the range
Result.Time := Date.Time
+ Day_Range (Duration.Sign) * Day_Range (Duration.Seconds);
end if;
Normalize (Result.Date);
return Result;
end "+";
---------------
-- Normalize --
---------------
procedure Normalize (Date : in out Date_NZ_T) is
Carry : Integer;
Max_Days : Integer;
begin
if Date.Month < 1 or else Date.Month > 12 then
Date.Year := Date.Year + (Date.Month - 1) / 12;
Date.Month := (Date.Month - 1) mod 12 + 1;
end if;
loop
if Date.Day < 1 then
Date.Day := Date.Day
+ Max_Days_In_Month (Date.Year, Date.Month - 1);
Carry := -1;
else
Max_Days := Max_Days_In_Month (Date.Year, Date.Month);
if Date.Day > Max_Days then
Date.Day := Date.Day - Max_Days;
Carry := 1;
else
exit;
end if;
end if;
Date.Year := Date.Year
+ Integer (Float'Floor (Float (Date.Month + Carry - 1) / 12.0));
Date.Month := 1 + (Date.Month + Carry - 1) mod 12;
end loop;
end Normalize;
---------------
-- Normalize --
---------------
function Normalize (Date : Date_Time_T) return Date_Time_T is
Result : Date_Time_T;
begin
if Date.TZ /= No_Timezone and then Date.TZ /= 0 then
if Date.TZ > 0 then
Result := Date + (-1, 0, 0, 0, Day_Range (Date.TZ * 60));
else
Result := Date + (1, 0, 0, 0, Day_Range ((-Date.TZ) * 60));
end if;
Result.TZ := 0;
return Result;
else
return Date;
end if;
end Normalize;
---------------
-- Normalize --
---------------
function Normalize (Duration : Duration_T) return Duration_T is
begin
return Duration;
end Normalize;
----------
-- Sign --
----------
function Sign (Duration : Duration_T) return Integer is
begin
return Duration.Sign;
end Sign;
----------
-- Year --
----------
function Year (Duration : Duration_T) return Natural is
begin
return Duration.Year;
end Year;
-----------
-- Month --
-----------
function Month (Duration : Duration_T) return Natural is
begin
return Duration.Month;
end Month;
---------
-- Day --
---------
function Day (Duration : Duration_T) return Natural is
begin
return Duration.Day;
end Day;
-------------
-- Seconds --
-------------
function Seconds (Duration : Duration_T) return Day_Duration is
begin
return Duration.Seconds;
end Seconds;
-----------
-- Value --
-----------
function Year (Date : Date_Time_T) return Integer is
D : Date_Time_T := Date;
begin
if D.TZ /= No_Timezone then
D.Time := D.Time - Time_NZ_T (D.TZ) * 60.0;
D := Normalize (D);
end if;
return D.Date.Year;
end Year;
function Month (Date : Date_Time_T) return Natural is
D : Date_Time_T := Date;
begin
if D.TZ /= No_Timezone then
D.Time := D.Time - Time_NZ_T (D.TZ) * 60.0;
D := Normalize (D);
end if;
return D.Date.Month;
end Month;
function Day (Date : Date_Time_T) return Natural is
D : Date_Time_T := Date;
begin
if D.TZ /= No_Timezone then
D.Time := D.Time - Time_NZ_T (D.TZ) * 60.0;
D := Normalize (D);
end if;
return D.Date.Day;
end Day;
-------------
-- Compare --
-------------
function Compare (Date1, Date2 : Date_NZ_T) return Compare_Result is
begin
if Date1.Year < Date2.Year then
return Less_Than;
elsif Date1.Year > Date2.Year then
return Greater_Than;
elsif Date1.Month < Date2.Month then
return Less_Than;
elsif Date1.Month > Date2.Month then
return Greater_Than;
elsif Date1.Day < Date2.Day then
return Less_Than;
elsif Date1.Day > Date2.Day then
return Greater_Than;
end if;
return Equal;
end Compare;
-------------
-- Compare --
-------------
function Compare (Time1, Time2 : Time_NZ_T) return Compare_Result is
begin
if Time1 < Time2 then
return Less_Than;
elsif Time1 > Time2 then
return Greater_Than;
else
return Equal;
end if;
end Compare;
-------------
-- Compare --
-------------
function Compare
(Duration1, Duration2 : Duration_T) return Compare_Result
is
-- See 3.2.6.2 for more information on how to compare Durations
Date1 : constant Date_Time_T := ((1696, 09, 01), 0.0, 0);
Date2 : constant Date_Time_T := ((1697, 02, 01), 0.0, 0);
Date3 : constant Date_Time_T := ((1903, 03, 01), 0.0, 0);
Date4 : constant Date_Time_T := ((1903, 07, 01), 0.0, 0);
T1 : constant Compare_Result :=
Compare (Normalize (Date1 + Duration1), Normalize (Date1 + Duration2));
T2 : constant Compare_Result :=
Compare (Normalize (Date2 + Duration1), Normalize (Date2 + Duration2));
T3 : constant Compare_Result :=
Compare (Normalize (Date3 + Duration1), Normalize (Date3 + Duration2));
T4 : constant Compare_Result :=
Compare (Normalize (Date4 + Duration1), Normalize (Date4 + Duration2));
begin
if T1 = Less_Than
and then T2 = Less_Than
and then T3 = Less_Than
and then T4 = Less_Than
then
return Less_Than;
elsif T1 = Greater_Than
and then T2 = Greater_Than
and then T3 = Greater_Than
and then T4 = Greater_Than
then
return Greater_Than;
elsif T1 = Equal
and then T2 = Equal
and then T3 = Equal
and then T4 = Equal
then
return Equal;
else
return Uncomparable;
end if;
end Compare;
-------------
-- Compare --
-------------
function Compare (Time1, Time2 : Date_Time_T) return Compare_Result is
T : Date_Time_T;
Tmp : Compare_Result;
begin
if (Time1.TZ = No_Timezone and Time2.TZ = No_Timezone)
or else (Time1.TZ /= No_Timezone and Time2.TZ /= No_Timezone)
then
Tmp := Compare (Time1.Date, Time2.Date);
if Tmp /= Equal then
return Tmp;
else
return Compare (Time1.Time, Time2.Time);
end if;
elsif Time1.TZ /= No_Timezone then
T := Time2;
T.TZ := 14 * 60;
if Compare (Time1, Normalize (T)) = Less_Than then
return Less_Than;
end if;
T.TZ := -14 * 60;
if Compare (Time1, Normalize (T)) = Greater_Than then
return Greater_Than;
end if;
return Uncomparable;
else
T := Time1;
T.TZ := -14 * 60;
if Compare (Normalize (T), Time2) = Less_Than then
return Less_Than;
end if;
T.TZ := 14 * 60;
if Compare (Normalize (T), Time2) = Greater_Than then
return Greater_Than;
end if;
return Uncomparable;
end if;
end Compare;
-----------------
-- Comparators --
-----------------
package body Comparators is
---------
-- "<" --
---------
function "<" (T1, T2 : T) return Boolean is
Result : constant Compare_Result :=
Compare (Normalize (T1), Normalize (T2));
begin
if Result = Uncomparable then
raise Not_Comparable;
else
return Result = Less_Than;
end if;
end "<";
----------
-- "<=" --
----------
function "<=" (T1, T2 : T) return Boolean is
Result : constant Compare_Result :=
Compare (Normalize (T1), Normalize (T2));
begin
if Result = Uncomparable then
raise Not_Comparable;
else
return Result = Less_Than or Result = Equal;
end if;
end "<=";
---------
-- "=" --
---------
function "=" (T1, T2 : T) return Boolean is
Result : constant Compare_Result :=
Compare (Normalize (T1), Normalize (T2));
begin
if Result = Uncomparable then
return False;
else
return Result = Equal;
end if;
end "=";
---------
-- ">" --
---------
function ">" (T1, T2 : T) return Boolean is
Result : constant Compare_Result :=
Compare (Normalize (T1), Normalize (T2));
begin
if Result = Uncomparable then
raise Not_Comparable;
else
return Result = Greater_Than;
end if;
end ">";
----------
-- ">=" --
----------
function ">=" (T1, T2 : T) return Boolean is
Result : constant Compare_Result :=
Compare (Normalize (T1), Normalize (T2));
begin
if Result = Uncomparable then
raise Not_Comparable;
else
return Result = Greater_Than or Result = Equal;
end if;
end ">=";
end Comparators;
--------------------
-- DT_Comparators --
--------------------
package body DT_Comparators is
---------
-- "<" --
---------
function "<" (T1, T2 : T) return Boolean is
begin
return To_Date_Time (T1) < To_Date_Time (T2);
end "<";
----------
-- "<=" --
----------
function "<=" (T1, T2 : T) return Boolean is
begin
return To_Date_Time (T1) <= To_Date_Time (T2);
end "<=";
---------
-- "=" --
---------
function "=" (T1, T2 : T) return Boolean is
begin
return To_Date_Time (T1) = To_Date_Time (T2);
end "=";
---------
-- ">" --
---------
function ">" (T1, T2 : T) return Boolean is
begin
return To_Date_Time (T1) > To_Date_Time (T2);
end ">";
----------
-- ">=" --
----------
function ">=" (T1, T2 : T) return Boolean is
begin
return To_Date_Time (T1) >= To_Date_Time (T2);
end ">=";
end DT_Comparators;
package Date_Comp is new DT_Comparators (Date_T);
function "<" (Date1, Date2 : Date_T) return Boolean renames Date_Comp."<";
function "<=" (Date1, Date2 : Date_T) return Boolean renames Date_Comp."<=";
function "=" (Date1, Date2 : Date_T) return Boolean renames Date_Comp."=";
function ">" (Date1, Date2 : Date_T) return Boolean renames Date_Comp.">";
function ">=" (Date1, Date2 : Date_T) return Boolean renames Date_Comp.">=";
package Time_Comp is new DT_Comparators (Time_T);
function "<" (Time1, Time2 : Time_T) return Boolean renames Time_Comp."<";
function "<=" (Time1, Time2 : Time_T) return Boolean renames Time_Comp."<=";
function "=" (Time1, Time2 : Time_T) return Boolean renames Time_Comp."=";
function ">" (Time1, Time2 : Time_T) return Boolean renames Time_Comp.">";
function ">=" (Time1, Time2 : Time_T) return Boolean renames Time_Comp.">=";
package Day_T_Comp is new DT_Comparators (GDay_T);
function "<" (Day1, Day2 : GDay_T) return Boolean renames Day_T_Comp."<";
function "<=" (Day1, Day2 : GDay_T) return Boolean renames Day_T_Comp."<=";
function "=" (Day1, Day2 : GDay_T) return Boolean renames Day_T_Comp."=";
function ">" (Day1, Day2 : GDay_T) return Boolean renames Day_T_Comp.">";
function ">=" (Day1, Day2 : GDay_T) return Boolean renames Day_T_Comp.">=";
package Month_Day_T_Comp is new DT_Comparators (GMonth_Day_T);
function "<" (Day1, Day2 : GMonth_Day_T) return Boolean
renames Month_Day_T_Comp."<";
function "<=" (Day1, Day2 : GMonth_Day_T) return Boolean
renames Month_Day_T_Comp."<=";
function "=" (Day1, Day2 : GMonth_Day_T) return Boolean
renames Month_Day_T_Comp."=";
function ">" (Day1, Day2 : GMonth_Day_T) return Boolean
renames Month_Day_T_Comp.">";
function ">=" (Day1, Day2 : GMonth_Day_T) return Boolean
renames Month_Day_T_Comp.">=";
package Month_T_Comp is new DT_Comparators (GMonth_T);
function "<" (Month1, Month2 : GMonth_T) return Boolean
renames Month_T_Comp."<";
function "<=" (Month1, Month2 : GMonth_T) return Boolean
renames Month_T_Comp."<=";
function "=" (Month1, Month2 : GMonth_T) return Boolean
renames Month_T_Comp."=";
function ">" (Month1, Month2 : GMonth_T) return Boolean
renames Month_T_Comp.">";
function ">=" (Month1, Month2 : GMonth_T) return Boolean
renames Month_T_Comp.">=";
package Year_Month_T_Comp is new DT_Comparators (GYear_Month_T);
function "<" (Month1, Month2 : GYear_Month_T) return Boolean
renames Year_Month_T_Comp."<";
function "<=" (Month1, Month2 : GYear_Month_T) return Boolean
renames Year_Month_T_Comp."<=";
function "=" (Month1, Month2 : GYear_Month_T) return Boolean
renames Year_Month_T_Comp."=";
function ">" (Month1, Month2 : GYear_Month_T) return Boolean
renames Year_Month_T_Comp.">";
function ">=" (Month1, Month2 : GYear_Month_T) return Boolean
renames Year_Month_T_Comp.">=";
package Year_T_Comp is new DT_Comparators (GYear_T);
function "<" (Year1, Year2 : GYear_T) return Boolean
renames Year_T_Comp."<";
function "<=" (Year1, Year2 : GYear_T) return Boolean
renames Year_T_Comp."<=";
function "=" (Year1, Year2 : GYear_T) return Boolean
renames Year_T_Comp."=";
function ">" (Year1, Year2 : GYear_T) return Boolean
renames Year_T_Comp.">";
function ">=" (Year1, Year2 : GYear_T) return Boolean
renames Year_T_Comp.">=";
package Date_Time_T_Comp is new Comparators (Date_Time_T);
function "<" (Time1, Time2 : Date_Time_T) return Boolean
renames Date_Time_T_Comp."<";
function "<=" (Time1, Time2 : Date_Time_T) return Boolean
renames Date_Time_T_Comp."<=";
function "=" (Time1, Time2 : Date_Time_T) return Boolean
renames Date_Time_T_Comp."=";
function ">" (Time1, Time2 : Date_Time_T) return Boolean
renames Date_Time_T_Comp.">";
function ">=" (Time1, Time2 : Date_Time_T) return Boolean
renames Date_Time_T_Comp.">=";
package Duration_T_Comp is new Comparators (Duration_T);
function "<" (Duration1, Duration2 : Duration_T) return Boolean
renames Duration_T_Comp."<";
function "<=" (Duration1, Duration2 : Duration_T) return Boolean
renames Duration_T_Comp."<=";
function "=" (Duration1, Duration2 : Duration_T) return Boolean
renames Duration_T_Comp."=";
function ">" (Duration1, Duration2 : Duration_T) return Boolean
renames Duration_T_Comp.">";
function ">=" (Duration1, Duration2 : Duration_T) return Boolean
renames Duration_T_Comp.">=";
end Schema.Date_Time;
Reference in New Issue View Git Blame Copy Permalink