[multiple changes]
2012-01-23 Ed Schonberg <schonberg@adacore.com> * sem_ch6.adb (Analyze_Subprogram_Declaration): Do not set the Corresponding_Body on a defaulted null formal subprogram. * sem_ch12.adb (Check_Formal_Package_Instance): No check needed on a defaulted formal subprogram that is a null procedure. 2012-01-23 Hristian Kirtchev <kirtchev@adacore.com> * exp_ch9.adb: Update the comments involving pragma Implemented. * sem_ch3.adb (Check_Pragma_Implemented (Entity_Id)): Add local constant Subp_Alias and local variable Impl_Subp. Properly handle aliases of synchronized wrappers. Code cleanup. (Check_Pragma_Implemented (Entity_Id; Entity_Id)): Add Name_Optional as part of the condition. * sem_prag.adb (Analyze_Pragma): Add "Optional" as one of the valid choices of implementation kind. (Check_Arg_Is_One_Of): New routine. * snames.ads-tmlp: Add Name_Optional. 2012-01-23 Ed Schonberg <schonberg@adacore.com> * par-ch13.adb: Better error recovery in illegal aspect specification. 2012-01-23 Hristian Kirtchev <kirtchev@adacore.com> * a-calend.adb: Add with clause for Interfaces.C. Add constant Unix_Max. (Day_Of_Week): Call the internal UTC_Time_Offset. (Split): Call the internal UTC_Time_Offset. (Time_Of): Call the internal UTC_Time_Offset. (Time_Zone_Operations.UTC_Time_Offset): Call internal UTC_Time_Offset. (UTC_Time_Offset): New library-level routine. * a-calend.ads (UTC_Time_Offset): Remove parameter Is_Historic. Update related comment on usage. * a-catizo.adb (UTC_Time_Offset): Removed. (UTC_Time_Offset (Time)): Call Time_Zone_Operations.UTC_Time_Offset. * a-caltizo.ads (UTC_Time_Offset): Removed. (UTC_Time_Offset (Time)): Add back the default expression of parameter Date. From-SVN: r183414
This commit is contained in:
parent
3ffd18f16c
commit
b3aa0ca834
|
@ -1,3 +1,45 @@
|
||||||
|
2012-01-23 Ed Schonberg <schonberg@adacore.com>
|
||||||
|
|
||||||
|
* sem_ch6.adb (Analyze_Subprogram_Declaration): Do not set the
|
||||||
|
Corresponding_Body on a defaulted null formal subprogram.
|
||||||
|
* sem_ch12.adb (Check_Formal_Package_Instance): No check needed
|
||||||
|
on a defaulted formal subprogram that is a null procedure.
|
||||||
|
|
||||||
|
2012-01-23 Hristian Kirtchev <kirtchev@adacore.com>
|
||||||
|
|
||||||
|
* exp_ch9.adb: Update the comments involving pragma Implemented.
|
||||||
|
* sem_ch3.adb (Check_Pragma_Implemented (Entity_Id)): Add local
|
||||||
|
constant Subp_Alias and local variable Impl_Subp. Properly
|
||||||
|
handle aliases of synchronized wrappers. Code cleanup.
|
||||||
|
(Check_Pragma_Implemented (Entity_Id; Entity_Id)): Add
|
||||||
|
Name_Optional as part of the condition.
|
||||||
|
* sem_prag.adb (Analyze_Pragma): Add "Optional" as one of the
|
||||||
|
valid choices of implementation kind.
|
||||||
|
(Check_Arg_Is_One_Of): New routine.
|
||||||
|
* snames.ads-tmlp: Add Name_Optional.
|
||||||
|
|
||||||
|
2012-01-23 Ed Schonberg <schonberg@adacore.com>
|
||||||
|
|
||||||
|
* par-ch13.adb: Better error recovery in illegal aspect
|
||||||
|
specification.
|
||||||
|
|
||||||
|
2012-01-23 Hristian Kirtchev <kirtchev@adacore.com>
|
||||||
|
|
||||||
|
* a-calend.adb: Add with clause for Interfaces.C. Add constant
|
||||||
|
Unix_Max.
|
||||||
|
(Day_Of_Week): Call the internal UTC_Time_Offset.
|
||||||
|
(Split): Call the internal UTC_Time_Offset.
|
||||||
|
(Time_Of): Call the internal UTC_Time_Offset.
|
||||||
|
(Time_Zone_Operations.UTC_Time_Offset): Call internal UTC_Time_Offset.
|
||||||
|
(UTC_Time_Offset): New library-level routine.
|
||||||
|
* a-calend.ads (UTC_Time_Offset): Remove parameter
|
||||||
|
Is_Historic. Update related comment on usage.
|
||||||
|
* a-catizo.adb (UTC_Time_Offset): Removed.
|
||||||
|
(UTC_Time_Offset (Time)): Call Time_Zone_Operations.UTC_Time_Offset.
|
||||||
|
* a-caltizo.ads (UTC_Time_Offset): Removed.
|
||||||
|
(UTC_Time_Offset (Time)): Add back the default expression of parameter
|
||||||
|
Date.
|
||||||
|
|
||||||
2012-01-23 Robert Dewar <dewar@adacore.com>
|
2012-01-23 Robert Dewar <dewar@adacore.com>
|
||||||
|
|
||||||
* sprint.ads, sprint.adb (Sprint_Node_List): Add New_Lines parameter
|
* sprint.ads, sprint.adb (Sprint_Node_List): Add New_Lines parameter
|
||||||
|
|
|
@ -30,7 +30,7 @@
|
||||||
------------------------------------------------------------------------------
|
------------------------------------------------------------------------------
|
||||||
|
|
||||||
with Ada.Unchecked_Conversion;
|
with Ada.Unchecked_Conversion;
|
||||||
|
with Interfaces.C;
|
||||||
with System.OS_Primitives;
|
with System.OS_Primitives;
|
||||||
|
|
||||||
package body Ada.Calendar is
|
package body Ada.Calendar is
|
||||||
|
@ -109,6 +109,21 @@ package body Ada.Calendar is
|
||||||
new Ada.Unchecked_Conversion (Time_Rep, Duration);
|
new Ada.Unchecked_Conversion (Time_Rep, Duration);
|
||||||
-- Convert a time representation value into a duration value
|
-- Convert a time representation value into a duration value
|
||||||
|
|
||||||
|
function UTC_Time_Offset
|
||||||
|
(Date : Time;
|
||||||
|
Is_Historic : Boolean) return Long_Integer;
|
||||||
|
-- This routine acts as an Ada wrapper around __gnat_localtime_tzoff which
|
||||||
|
-- in turn utilizes various OS-dependent mechanisms to calculate the time
|
||||||
|
-- zone offset of a date. Formal parameter Date represents an arbitrary
|
||||||
|
-- time stamp, either in the past, now, or in the future. If flag
|
||||||
|
-- Is_Historic is set, this routine would try to calculate to the best of
|
||||||
|
-- the OS's abilities the time zone offset that was or will be in effect
|
||||||
|
-- on Date. If the flag is set to False, the routine returns the current
|
||||||
|
-- time zone with Date effectively set to Clock.
|
||||||
|
-- NOTE: Targets which support localtime_r will aways return a historic
|
||||||
|
-- time zone even if flag Is_Historic is set to False because this is how
|
||||||
|
-- localtime_r operates.
|
||||||
|
|
||||||
-----------------
|
-----------------
|
||||||
-- Local Types --
|
-- Local Types --
|
||||||
-----------------
|
-----------------
|
||||||
|
@ -176,6 +191,13 @@ package body Ada.Calendar is
|
||||||
Unix_Min : constant Time_Rep :=
|
Unix_Min : constant Time_Rep :=
|
||||||
Ada_Low + Time_Rep (17 * 366 + 52 * 365) * Nanos_In_Day;
|
Ada_Low + Time_Rep (17 * 366 + 52 * 365) * Nanos_In_Day;
|
||||||
|
|
||||||
|
-- The Unix upper time bound expressed as nonoseconds since the start of
|
||||||
|
-- Ada time in UTC.
|
||||||
|
|
||||||
|
Unix_Max : constant Time_Rep :=
|
||||||
|
Ada_Low + Time_Rep (34 * 366 + 102 * 365) * Nanos_In_Day +
|
||||||
|
Time_Rep (Leap_Seconds_Count) * Nano;
|
||||||
|
|
||||||
Epoch_Offset : constant Time_Rep := (136 * 365 + 44 * 366) * Nanos_In_Day;
|
Epoch_Offset : constant Time_Rep := (136 * 365 + 44 * 366) * Nanos_In_Day;
|
||||||
-- The difference between 2150-1-1 UTC and 1970-1-1 UTC expressed in
|
-- The difference between 2150-1-1 UTC and 1970-1-1 UTC expressed in
|
||||||
-- nanoseconds. Note that year 2100 is non-leap.
|
-- nanoseconds. Note that year 2100 is non-leap.
|
||||||
|
@ -626,6 +648,110 @@ package body Ada.Calendar is
|
||||||
Time_Zone => 0);
|
Time_Zone => 0);
|
||||||
end Time_Of;
|
end Time_Of;
|
||||||
|
|
||||||
|
---------------------
|
||||||
|
-- UTC_Time_Offset --
|
||||||
|
---------------------
|
||||||
|
|
||||||
|
function UTC_Time_Offset
|
||||||
|
(Date : Time;
|
||||||
|
Is_Historic : Boolean) return Long_Integer
|
||||||
|
is
|
||||||
|
-- The following constants denote February 28 during non-leap centennial
|
||||||
|
-- years, the units are nanoseconds.
|
||||||
|
|
||||||
|
T_2100_2_28 : constant Time_Rep := Ada_Low +
|
||||||
|
(Time_Rep (49 * 366 + 150 * 365 + 59) * Secs_In_Day +
|
||||||
|
Time_Rep (Leap_Seconds_Count)) * Nano;
|
||||||
|
|
||||||
|
T_2200_2_28 : constant Time_Rep := Ada_Low +
|
||||||
|
(Time_Rep (73 * 366 + 226 * 365 + 59) * Secs_In_Day +
|
||||||
|
Time_Rep (Leap_Seconds_Count)) * Nano;
|
||||||
|
|
||||||
|
T_2300_2_28 : constant Time_Rep := Ada_Low +
|
||||||
|
(Time_Rep (97 * 366 + 302 * 365 + 59) * Secs_In_Day +
|
||||||
|
Time_Rep (Leap_Seconds_Count)) * Nano;
|
||||||
|
|
||||||
|
-- 56 years (14 leap years + 42 non-leap years) in nanoseconds:
|
||||||
|
|
||||||
|
Nanos_In_56_Years : constant := (14 * 366 + 42 * 365) * Nanos_In_Day;
|
||||||
|
|
||||||
|
type int_Pointer is access all Interfaces.C.int;
|
||||||
|
type long_Pointer is access all Interfaces.C.long;
|
||||||
|
|
||||||
|
type time_t is
|
||||||
|
range -(2 ** (Standard'Address_Size - Integer'(1))) ..
|
||||||
|
+(2 ** (Standard'Address_Size - Integer'(1)) - 1);
|
||||||
|
type time_t_Pointer is access all time_t;
|
||||||
|
|
||||||
|
procedure localtime_tzoff
|
||||||
|
(timer : time_t_Pointer;
|
||||||
|
is_historic : int_Pointer;
|
||||||
|
off : long_Pointer);
|
||||||
|
pragma Import (C, localtime_tzoff, "__gnat_localtime_tzoff");
|
||||||
|
-- This routine is a interfacing wrapper around the library function
|
||||||
|
-- __gnat_localtime_tzoff. Parameter 'timer' represents a Unix-based
|
||||||
|
-- time equivalent of the input date. If flag 'is_historic' is set, this
|
||||||
|
-- routine would try to calculate to the best of the OS's abilities the
|
||||||
|
-- time zone offset that was or will be in effect on 'timer'. If the
|
||||||
|
-- flag is set to False, the routine returns the current time zone
|
||||||
|
-- regardless of what 'timer' designates. Parameter 'off' captures the
|
||||||
|
-- UTC offset of 'timer'.
|
||||||
|
|
||||||
|
Adj_Cent : Integer;
|
||||||
|
Date_N : Time_Rep;
|
||||||
|
Flag : aliased Interfaces.C.int;
|
||||||
|
Offset : aliased Interfaces.C.long;
|
||||||
|
Secs_T : aliased time_t;
|
||||||
|
|
||||||
|
-- Start of processing for UTC_Time_Offset
|
||||||
|
|
||||||
|
begin
|
||||||
|
Date_N := Time_Rep (Date);
|
||||||
|
|
||||||
|
-- Dates which are 56 years apart fall on the same day, day light saving
|
||||||
|
-- and so on. Non-leap centennial years violate this rule by one day and
|
||||||
|
-- as a consequence, special adjustment is needed.
|
||||||
|
|
||||||
|
Adj_Cent :=
|
||||||
|
(if Date_N <= T_2100_2_28 then 0
|
||||||
|
elsif Date_N <= T_2200_2_28 then 1
|
||||||
|
elsif Date_N <= T_2300_2_28 then 2
|
||||||
|
else 3);
|
||||||
|
|
||||||
|
if Adj_Cent > 0 then
|
||||||
|
Date_N := Date_N - Time_Rep (Adj_Cent) * Nanos_In_Day;
|
||||||
|
end if;
|
||||||
|
|
||||||
|
-- Shift the date within bounds of Unix time
|
||||||
|
|
||||||
|
while Date_N < Unix_Min loop
|
||||||
|
Date_N := Date_N + Nanos_In_56_Years;
|
||||||
|
end loop;
|
||||||
|
|
||||||
|
while Date_N >= Unix_Max loop
|
||||||
|
Date_N := Date_N - Nanos_In_56_Years;
|
||||||
|
end loop;
|
||||||
|
|
||||||
|
-- Perform a shift in origins from Ada to Unix
|
||||||
|
|
||||||
|
Date_N := Date_N - Unix_Min;
|
||||||
|
|
||||||
|
-- Convert the date into seconds
|
||||||
|
|
||||||
|
Secs_T := time_t (Date_N / Nano);
|
||||||
|
|
||||||
|
-- Determine whether to treat the input date as historical or not
|
||||||
|
|
||||||
|
Flag := (if Is_Historic then 1 else 0);
|
||||||
|
|
||||||
|
localtime_tzoff
|
||||||
|
(Secs_T'Unchecked_Access,
|
||||||
|
Flag'Unchecked_Access,
|
||||||
|
Offset'Unchecked_Access);
|
||||||
|
|
||||||
|
return Long_Integer (Offset);
|
||||||
|
end UTC_Time_Offset;
|
||||||
|
|
||||||
----------
|
----------
|
||||||
-- Year --
|
-- Year --
|
||||||
----------
|
----------
|
||||||
|
@ -1024,11 +1150,7 @@ package body Ada.Calendar is
|
||||||
|
|
||||||
function Day_Of_Week (Date : Time) return Integer is
|
function Day_Of_Week (Date : Time) return Integer is
|
||||||
Date_N : constant Time_Rep := Time_Rep (Date);
|
Date_N : constant Time_Rep := Time_Rep (Date);
|
||||||
Time_Zone : constant Long_Integer :=
|
Time_Zone : constant Long_Integer := UTC_Time_Offset (Date, True);
|
||||||
Time_Zones_Operations.UTC_Time_Offset
|
|
||||||
(Date => Date,
|
|
||||||
Is_Historic => False);
|
|
||||||
|
|
||||||
Ada_Low_N : Time_Rep;
|
Ada_Low_N : Time_Rep;
|
||||||
Day_Count : Long_Integer;
|
Day_Count : Long_Integer;
|
||||||
Day_Dur : Time_Dur;
|
Day_Dur : Time_Dur;
|
||||||
|
@ -1141,9 +1263,8 @@ package body Ada.Calendar is
|
||||||
else
|
else
|
||||||
declare
|
declare
|
||||||
Off : constant Long_Integer :=
|
Off : constant Long_Integer :=
|
||||||
Time_Zones_Operations.UTC_Time_Offset
|
UTC_Time_Offset (Time (Date_N), False);
|
||||||
(Date => Time (Date_N),
|
|
||||||
Is_Historic => False);
|
|
||||||
begin
|
begin
|
||||||
Date_N := Date_N + Time_Rep (Off) * Nano;
|
Date_N := Date_N + Time_Rep (Off) * Nano;
|
||||||
end;
|
end;
|
||||||
|
@ -1364,15 +1485,12 @@ package body Ada.Calendar is
|
||||||
else
|
else
|
||||||
declare
|
declare
|
||||||
Current_Off : constant Long_Integer :=
|
Current_Off : constant Long_Integer :=
|
||||||
Time_Zones_Operations.UTC_Time_Offset
|
UTC_Time_Offset (Time (Res_N), False);
|
||||||
(Date => Time (Res_N),
|
|
||||||
Is_Historic => False);
|
|
||||||
Current_Res_N : constant Time_Rep :=
|
Current_Res_N : constant Time_Rep :=
|
||||||
Res_N - Time_Rep (Current_Off) * Nano;
|
Res_N - Time_Rep (Current_Off) * Nano;
|
||||||
Off : constant Long_Integer :=
|
Off : constant Long_Integer :=
|
||||||
Time_Zones_Operations.UTC_Time_Offset
|
UTC_Time_Offset (Time (Current_Res_N), False);
|
||||||
(Date => Time (Current_Res_N),
|
|
||||||
Is_Historic => False);
|
|
||||||
begin
|
begin
|
||||||
Res_N := Res_N - Time_Rep (Off) * Nano;
|
Res_N := Res_N - Time_Rep (Off) * Nano;
|
||||||
end;
|
end;
|
||||||
|
@ -1416,115 +1534,13 @@ package body Ada.Calendar is
|
||||||
|
|
||||||
package body Time_Zones_Operations is
|
package body Time_Zones_Operations is
|
||||||
|
|
||||||
-- The Unix time bounds in nanoseconds: 1970/1/1 .. 2037/1/1
|
|
||||||
|
|
||||||
Unix_Min : constant Time_Rep := Ada_Low +
|
|
||||||
Time_Rep (17 * 366 + 52 * 365) * Nanos_In_Day;
|
|
||||||
|
|
||||||
Unix_Max : constant Time_Rep := Ada_Low +
|
|
||||||
Time_Rep (34 * 366 + 102 * 365) * Nanos_In_Day +
|
|
||||||
Time_Rep (Leap_Seconds_Count) * Nano;
|
|
||||||
|
|
||||||
-- The following constants denote February 28 during non-leap
|
|
||||||
-- centennial years, the units are nanoseconds.
|
|
||||||
|
|
||||||
T_2100_2_28 : constant Time_Rep := Ada_Low +
|
|
||||||
(Time_Rep (49 * 366 + 150 * 365 + 59) * Secs_In_Day +
|
|
||||||
Time_Rep (Leap_Seconds_Count)) * Nano;
|
|
||||||
|
|
||||||
T_2200_2_28 : constant Time_Rep := Ada_Low +
|
|
||||||
(Time_Rep (73 * 366 + 226 * 365 + 59) * Secs_In_Day +
|
|
||||||
Time_Rep (Leap_Seconds_Count)) * Nano;
|
|
||||||
|
|
||||||
T_2300_2_28 : constant Time_Rep := Ada_Low +
|
|
||||||
(Time_Rep (97 * 366 + 302 * 365 + 59) * Secs_In_Day +
|
|
||||||
Time_Rep (Leap_Seconds_Count)) * Nano;
|
|
||||||
|
|
||||||
-- 56 years (14 leap years + 42 non leap years) in nanoseconds:
|
|
||||||
|
|
||||||
Nanos_In_56_Years : constant := (14 * 366 + 42 * 365) * Nanos_In_Day;
|
|
||||||
|
|
||||||
subtype long is Long_Integer;
|
|
||||||
subtype int is Integer;
|
|
||||||
type long_Pointer is access all long;
|
|
||||||
type int_Pointer is access all int;
|
|
||||||
|
|
||||||
type time_t is
|
|
||||||
range -(2 ** (Standard'Address_Size - Integer'(1))) ..
|
|
||||||
+(2 ** (Standard'Address_Size - Integer'(1)) - 1);
|
|
||||||
type time_t_Pointer is access all time_t;
|
|
||||||
|
|
||||||
procedure localtime_tzoff
|
|
||||||
(timer : time_t_Pointer;
|
|
||||||
is_historic : int_Pointer;
|
|
||||||
off : long_Pointer);
|
|
||||||
pragma Import (C, localtime_tzoff, "__gnat_localtime_tzoff");
|
|
||||||
-- This is a lightweight wrapper around the system library function
|
|
||||||
-- localtime_r. Parameter 'off' captures the UTC offset which is either
|
|
||||||
-- retrieved from the tm struct or calculated from the 'timezone' extern
|
|
||||||
-- and the tm_isdst flag in the tm struct. Flag 'is_historic' denotes
|
|
||||||
-- whether 'timer' is a historical time stamp. If this is not the case,
|
|
||||||
-- the routine returns the offset of the local time zone.
|
|
||||||
|
|
||||||
---------------------
|
---------------------
|
||||||
-- UTC_Time_Offset --
|
-- UTC_Time_Offset --
|
||||||
---------------------
|
---------------------
|
||||||
|
|
||||||
function UTC_Time_Offset
|
function UTC_Time_Offset (Date : Time) return Long_Integer is
|
||||||
(Date : Time;
|
|
||||||
Is_Historic : Boolean := True) return Long_Integer
|
|
||||||
is
|
|
||||||
Adj_Cent : Integer;
|
|
||||||
Date_N : Time_Rep;
|
|
||||||
Flag : aliased int;
|
|
||||||
Offset : aliased long;
|
|
||||||
Secs_T : aliased time_t;
|
|
||||||
|
|
||||||
begin
|
begin
|
||||||
Date_N := Time_Rep (Date);
|
return UTC_Time_Offset (Date, True);
|
||||||
|
|
||||||
-- Dates which are 56 years apart fall on the same day, day light
|
|
||||||
-- saving and so on. Non-leap centennial years violate this rule by
|
|
||||||
-- one day and as a consequence, special adjustment is needed.
|
|
||||||
|
|
||||||
Adj_Cent :=
|
|
||||||
(if Date_N <= T_2100_2_28 then 0
|
|
||||||
elsif Date_N <= T_2200_2_28 then 1
|
|
||||||
elsif Date_N <= T_2300_2_28 then 2
|
|
||||||
else 3);
|
|
||||||
|
|
||||||
if Adj_Cent > 0 then
|
|
||||||
Date_N := Date_N - Time_Rep (Adj_Cent) * Nanos_In_Day;
|
|
||||||
end if;
|
|
||||||
|
|
||||||
-- Shift the date within bounds of Unix time
|
|
||||||
|
|
||||||
while Date_N < Unix_Min loop
|
|
||||||
Date_N := Date_N + Nanos_In_56_Years;
|
|
||||||
end loop;
|
|
||||||
|
|
||||||
while Date_N >= Unix_Max loop
|
|
||||||
Date_N := Date_N - Nanos_In_56_Years;
|
|
||||||
end loop;
|
|
||||||
|
|
||||||
-- Perform a shift in origins from Ada to Unix
|
|
||||||
|
|
||||||
Date_N := Date_N - Unix_Min;
|
|
||||||
|
|
||||||
-- Convert the date into seconds
|
|
||||||
|
|
||||||
Secs_T := time_t (Date_N / Nano);
|
|
||||||
|
|
||||||
-- Determine whether to treat the input date as historical or not
|
|
||||||
|
|
||||||
Flag := (if Is_Historic then 1 else 0);
|
|
||||||
|
|
||||||
localtime_tzoff
|
|
||||||
(Secs_T'Unchecked_Access,
|
|
||||||
Flag'Unchecked_Access,
|
|
||||||
Offset'Unchecked_Access);
|
|
||||||
|
|
||||||
return Offset;
|
|
||||||
end UTC_Time_Offset;
|
end UTC_Time_Offset;
|
||||||
|
|
||||||
end Time_Zones_Operations;
|
end Time_Zones_Operations;
|
||||||
|
|
|
@ -350,12 +350,9 @@ private
|
||||||
|
|
||||||
package Time_Zones_Operations is
|
package Time_Zones_Operations is
|
||||||
|
|
||||||
function UTC_Time_Offset
|
function UTC_Time_Offset (Date : Time) return Long_Integer;
|
||||||
(Date : Time;
|
-- Return (in seconds), the difference between the local time zone and
|
||||||
Is_Historic : Boolean := True) return Long_Integer;
|
-- UTC time at a specific historic date.
|
||||||
-- Return the offset in seconds from UTC of an arbitrary date. If flag
|
|
||||||
-- Is_Historic is set to False, then return the local time zone offset
|
|
||||||
-- regardless of what Date designates.
|
|
||||||
|
|
||||||
end Time_Zones_Operations;
|
end Time_Zones_Operations;
|
||||||
|
|
||||||
|
|
|
@ -42,41 +42,9 @@ package body Ada.Calendar.Time_Zones is
|
||||||
-- UTC_Time_Offset --
|
-- UTC_Time_Offset --
|
||||||
---------------------
|
---------------------
|
||||||
|
|
||||||
function UTC_Time_Offset return Time_Offset is
|
function UTC_Time_Offset (Date : Time := Clock) return Time_Offset is
|
||||||
Offset_L : constant Long_Integer :=
|
Offset_L : constant Long_Integer :=
|
||||||
Time_Zones_Operations.UTC_Time_Offset
|
Time_Zones_Operations.UTC_Time_Offset (Date);
|
||||||
(Date => Clock,
|
|
||||||
Is_Historic => False);
|
|
||||||
Offset : Time_Offset;
|
|
||||||
|
|
||||||
begin
|
|
||||||
if Offset_L = Invalid_Time_Zone_Offset then
|
|
||||||
raise Unknown_Zone_Error;
|
|
||||||
end if;
|
|
||||||
|
|
||||||
-- The offset returned by Time_Zones_Operations.UTC_Time_Offset is in
|
|
||||||
-- seconds, the returned value needs to be in minutes.
|
|
||||||
|
|
||||||
Offset := Time_Offset (Offset_L / 60);
|
|
||||||
|
|
||||||
-- Validity checks
|
|
||||||
|
|
||||||
if not Offset'Valid then
|
|
||||||
raise Unknown_Zone_Error;
|
|
||||||
end if;
|
|
||||||
|
|
||||||
return Offset;
|
|
||||||
end UTC_Time_Offset;
|
|
||||||
|
|
||||||
---------------------
|
|
||||||
-- UTC_Time_Offset --
|
|
||||||
---------------------
|
|
||||||
|
|
||||||
function UTC_Time_Offset (Date : Time) return Time_Offset is
|
|
||||||
Offset_L : constant Long_Integer :=
|
|
||||||
Time_Zones_Operations.UTC_Time_Offset
|
|
||||||
(Date => Date,
|
|
||||||
Is_Historic => True);
|
|
||||||
Offset : Time_Offset;
|
Offset : Time_Offset;
|
||||||
|
|
||||||
begin
|
begin
|
||||||
|
|
|
@ -26,12 +26,7 @@ package Ada.Calendar.Time_Zones is
|
||||||
|
|
||||||
Unknown_Zone_Error : exception;
|
Unknown_Zone_Error : exception;
|
||||||
|
|
||||||
function UTC_Time_Offset return Time_Offset;
|
function UTC_Time_Offset (Date : Time := Clock) return Time_Offset;
|
||||||
-- Returns (in minutes), the difference between the implementation-defined
|
|
||||||
-- time zone of Calendar, and UTC time. If the time zone of the Calendar
|
|
||||||
-- implementation is unknown, raises Unknown_Zone_Error.
|
|
||||||
|
|
||||||
function UTC_Time_Offset (Date : Time) return Time_Offset;
|
|
||||||
-- Returns (in minutes), the difference between the implementation-defined
|
-- Returns (in minutes), the difference between the implementation-defined
|
||||||
-- time zone of Calendar, and UTC time, at the time Date. If the time zone
|
-- time zone of Calendar, and UTC time, at the time Date. If the time zone
|
||||||
-- of the Calendar implementation is unknown, raises Unknown_Zone_Error.
|
-- of the Calendar implementation is unknown, raises Unknown_Zone_Error.
|
||||||
|
|
|
@ -8878,7 +8878,8 @@ package body Exp_Ch9 is
|
||||||
-- Target.Primitive (Param1, ..., ParamN);
|
-- Target.Primitive (Param1, ..., ParamN);
|
||||||
|
|
||||||
-- Ada 2012 (AI05-0030): Dispatching requeue to an interface primitive
|
-- Ada 2012 (AI05-0030): Dispatching requeue to an interface primitive
|
||||||
-- marked by pragma Implemented (XXX, By_Any) or not marked at all.
|
-- marked by pragma Implemented (XXX, By_Any | Optional) or not marked
|
||||||
|
-- at all.
|
||||||
|
|
||||||
-- declare
|
-- declare
|
||||||
-- S : constant Offset_Index :=
|
-- S : constant Offset_Index :=
|
||||||
|
@ -8923,9 +8924,9 @@ package body Exp_Ch9 is
|
||||||
function Build_Dispatching_Requeue_To_Any return Node_Id;
|
function Build_Dispatching_Requeue_To_Any return Node_Id;
|
||||||
-- Ada 2012 (AI05-0030): N denotes a dispatching requeue statement of
|
-- Ada 2012 (AI05-0030): N denotes a dispatching requeue statement of
|
||||||
-- the form Concval.Ename. Ename is either marked by pragma Implemented
|
-- the form Concval.Ename. Ename is either marked by pragma Implemented
|
||||||
-- (XXX, By_Any) or not marked at all. Create a block which determines
|
-- (XXX, By_Any | Optional) or not marked at all. Create a block which
|
||||||
-- at runtime whether Ename denotes an entry or a procedure and perform
|
-- determines at runtime whether Ename denotes an entry or a procedure
|
||||||
-- the appropriate kind of dispatching select.
|
-- and perform the appropriate kind of dispatching select.
|
||||||
|
|
||||||
function Build_Normal_Requeue return Node_Id;
|
function Build_Normal_Requeue return Node_Id;
|
||||||
-- N denotes a non-dispatching requeue statement to either a task or a
|
-- N denotes a non-dispatching requeue statement to either a task or a
|
||||||
|
@ -9445,9 +9446,10 @@ package body Exp_Ch9 is
|
||||||
Analyze (N);
|
Analyze (N);
|
||||||
|
|
||||||
-- The procedure_or_entry_NAME's implementation kind is either
|
-- The procedure_or_entry_NAME's implementation kind is either
|
||||||
-- By_Any or pragma Implemented was not applied at all. In this
|
-- By_Any, Optional, or pragma Implemented was not applied at all.
|
||||||
-- case a runtime test determines whether Ename denotes an entry
|
-- In this case a runtime test determines whether Ename denotes an
|
||||||
-- or a protected procedure and performs the appropriate call.
|
-- entry or a protected procedure and performs the appropriate
|
||||||
|
-- call.
|
||||||
|
|
||||||
else
|
else
|
||||||
Rewrite (N, Build_Dispatching_Requeue_To_Any);
|
Rewrite (N, Build_Dispatching_Requeue_To_Any);
|
||||||
|
|
|
@ -6,7 +6,7 @@
|
||||||
-- --
|
-- --
|
||||||
-- B o d y --
|
-- B o d y --
|
||||||
-- --
|
-- --
|
||||||
-- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
|
-- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
|
||||||
-- --
|
-- --
|
||||||
-- GNAT is free software; you can redistribute it and/or modify it under --
|
-- 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- --
|
-- terms of the GNU General Public License as published by the Free Soft- --
|
||||||
|
@ -514,12 +514,24 @@ package body Ch13 is
|
||||||
|
|
||||||
if Token = Tok_Comma
|
if Token = Tok_Comma
|
||||||
or else Token = Tok_Semicolon
|
or else Token = Tok_Semicolon
|
||||||
or else (not Semicolon and then Token /= Tok_Arrow)
|
|
||||||
then
|
then
|
||||||
|
-- or else (not Semicolon and then Token /= Tok_Arrow)
|
||||||
if Aspect_Argument (A_Id) /= Optional then
|
if Aspect_Argument (A_Id) /= Optional then
|
||||||
Error_Msg_Node_1 := Aspect;
|
Error_Msg_Node_1 := Identifier (Aspect);
|
||||||
Error_Msg_AP ("aspect& requires an aspect definition");
|
Error_Msg_AP ("aspect& requires an aspect definition");
|
||||||
OK := False;
|
OK := False;
|
||||||
|
|
||||||
|
end if;
|
||||||
|
|
||||||
|
elsif not Semicolon and then Token /= Tok_Arrow then
|
||||||
|
if Aspect_Argument (A_Id) /= Optional then
|
||||||
|
|
||||||
|
-- The name or expression may be there, but the arrow is
|
||||||
|
-- missing. Skip to the end of the declaration.
|
||||||
|
|
||||||
|
T_Arrow;
|
||||||
|
Resync_To_Semicolon;
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
-- Here we have an aspect definition
|
-- Here we have an aspect definition
|
||||||
|
|
|
@ -6,7 +6,7 @@
|
||||||
-- --
|
-- --
|
||||||
-- B o d y --
|
-- B o d y --
|
||||||
-- --
|
-- --
|
||||||
-- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
|
-- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
|
||||||
-- --
|
-- --
|
||||||
-- GNAT is free software; you can redistribute it and/or modify it under --
|
-- 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- --
|
-- terms of the GNU General Public License as published by the Free Soft- --
|
||||||
|
@ -5104,6 +5104,15 @@ package body Sem_Ch12 is
|
||||||
then
|
then
|
||||||
null;
|
null;
|
||||||
|
|
||||||
|
-- No check needed if subprogram is a defaulted null procedure
|
||||||
|
|
||||||
|
elsif No (Alias (E2))
|
||||||
|
and then Ekind (E2) = E_Procedure
|
||||||
|
and then
|
||||||
|
Null_Present (Specification (Unit_Declaration_Node (E2)))
|
||||||
|
then
|
||||||
|
null;
|
||||||
|
|
||||||
-- Otherwise the actual in the formal and the actual in the
|
-- Otherwise the actual in the formal and the actual in the
|
||||||
-- instantiation of the formal must match, up to renamings.
|
-- instantiation of the formal must match, up to renamings.
|
||||||
|
|
||||||
|
|
|
@ -6,7 +6,7 @@
|
||||||
-- --
|
-- --
|
||||||
-- B o d y --
|
-- B o d y --
|
||||||
-- --
|
-- --
|
||||||
-- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
|
-- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
|
||||||
-- --
|
-- --
|
||||||
-- GNAT is free software; you can redistribute it and/or modify it under --
|
-- 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- --
|
-- terms of the GNU General Public License as published by the Free Soft- --
|
||||||
|
@ -8897,17 +8897,27 @@ package body Sem_Ch3 is
|
||||||
procedure Check_Pragma_Implemented (Subp : Entity_Id) is
|
procedure Check_Pragma_Implemented (Subp : Entity_Id) is
|
||||||
Iface_Alias : constant Entity_Id := Interface_Alias (Subp);
|
Iface_Alias : constant Entity_Id := Interface_Alias (Subp);
|
||||||
Impl_Kind : constant Name_Id := Implementation_Kind (Iface_Alias);
|
Impl_Kind : constant Name_Id := Implementation_Kind (Iface_Alias);
|
||||||
|
Subp_Alias : constant Entity_Id := Alias (Subp);
|
||||||
Contr_Typ : Entity_Id;
|
Contr_Typ : Entity_Id;
|
||||||
|
Impl_Subp : Entity_Id;
|
||||||
|
|
||||||
begin
|
begin
|
||||||
-- Subp must have an alias since it is a hidden entity used to link
|
-- Subp must have an alias since it is a hidden entity used to link
|
||||||
-- an interface subprogram to its overriding counterpart.
|
-- an interface subprogram to its overriding counterpart.
|
||||||
|
|
||||||
pragma Assert (Present (Alias (Subp)));
|
pragma Assert (Present (Subp_Alias));
|
||||||
|
|
||||||
|
-- Handle aliases to synchronized wrappers
|
||||||
|
|
||||||
|
Impl_Subp := Subp_Alias;
|
||||||
|
|
||||||
|
if Is_Primitive_Wrapper (Impl_Subp) then
|
||||||
|
Impl_Subp := Wrapped_Entity (Impl_Subp);
|
||||||
|
end if;
|
||||||
|
|
||||||
-- Extract the type of the controlling formal
|
-- Extract the type of the controlling formal
|
||||||
|
|
||||||
Contr_Typ := Etype (First_Formal (Alias (Subp)));
|
Contr_Typ := Etype (First_Formal (Subp_Alias));
|
||||||
|
|
||||||
if Is_Concurrent_Record_Type (Contr_Typ) then
|
if Is_Concurrent_Record_Type (Contr_Typ) then
|
||||||
Contr_Typ := Corresponding_Concurrent_Type (Contr_Typ);
|
Contr_Typ := Corresponding_Concurrent_Type (Contr_Typ);
|
||||||
|
@ -8917,12 +8927,12 @@ package body Sem_Ch3 is
|
||||||
-- be implemented by an entry.
|
-- be implemented by an entry.
|
||||||
|
|
||||||
if Impl_Kind = Name_By_Entry
|
if Impl_Kind = Name_By_Entry
|
||||||
and then Ekind (Wrapped_Entity (Alias (Subp))) /= E_Entry
|
and then Ekind (Impl_Subp) /= E_Entry
|
||||||
then
|
then
|
||||||
Error_Msg_Node_2 := Iface_Alias;
|
Error_Msg_Node_2 := Iface_Alias;
|
||||||
Error_Msg_NE
|
Error_Msg_NE
|
||||||
("type & must implement abstract subprogram & with an entry",
|
("type & must implement abstract subprogram & with an entry",
|
||||||
Alias (Subp), Contr_Typ);
|
Subp_Alias, Contr_Typ);
|
||||||
|
|
||||||
elsif Impl_Kind = Name_By_Protected_Procedure then
|
elsif Impl_Kind = Name_By_Protected_Procedure then
|
||||||
|
|
||||||
|
@ -8934,19 +8944,17 @@ package body Sem_Ch3 is
|
||||||
Error_Msg_Node_2 := Contr_Typ;
|
Error_Msg_Node_2 := Contr_Typ;
|
||||||
Error_Msg_NE
|
Error_Msg_NE
|
||||||
("interface subprogram & cannot be implemented by a " &
|
("interface subprogram & cannot be implemented by a " &
|
||||||
"primitive procedure of task type &", Alias (Subp),
|
"primitive procedure of task type &", Subp_Alias,
|
||||||
Iface_Alias);
|
Iface_Alias);
|
||||||
|
|
||||||
-- An interface subprogram whose implementation kind is By_
|
-- An interface subprogram whose implementation kind is By_
|
||||||
-- Protected_Procedure must be implemented by a procedure.
|
-- Protected_Procedure must be implemented by a procedure.
|
||||||
|
|
||||||
elsif Is_Primitive_Wrapper (Alias (Subp))
|
elsif Ekind (Impl_Subp) /= E_Procedure then
|
||||||
and then Ekind (Wrapped_Entity (Alias (Subp))) /= E_Procedure
|
|
||||||
then
|
|
||||||
Error_Msg_Node_2 := Iface_Alias;
|
Error_Msg_Node_2 := Iface_Alias;
|
||||||
Error_Msg_NE
|
Error_Msg_NE
|
||||||
("type & must implement abstract subprogram & with a " &
|
("type & must implement abstract subprogram & with a " &
|
||||||
"procedure", Alias (Subp), Contr_Typ);
|
"procedure", Subp_Alias, Contr_Typ);
|
||||||
end if;
|
end if;
|
||||||
end if;
|
end if;
|
||||||
end Check_Pragma_Implemented;
|
end Check_Pragma_Implemented;
|
||||||
|
@ -8966,10 +8974,11 @@ package body Sem_Ch3 is
|
||||||
-- Ada 2012 (AI05-0030): The implementation kinds of an overridden
|
-- Ada 2012 (AI05-0030): The implementation kinds of an overridden
|
||||||
-- and overriding subprogram are different. In general this is an
|
-- and overriding subprogram are different. In general this is an
|
||||||
-- error except when the implementation kind of the overridden
|
-- error except when the implementation kind of the overridden
|
||||||
-- subprograms is By_Any.
|
-- subprograms is By_Any or Optional.
|
||||||
|
|
||||||
if Iface_Kind /= Subp_Kind
|
if Iface_Kind /= Subp_Kind
|
||||||
and then Iface_Kind /= Name_By_Any
|
and then Iface_Kind /= Name_By_Any
|
||||||
|
and then Iface_Kind /= Name_Optional
|
||||||
then
|
then
|
||||||
if Iface_Kind = Name_By_Entry then
|
if Iface_Kind = Name_By_Entry then
|
||||||
Error_Msg_N
|
Error_Msg_N
|
||||||
|
|
|
@ -6,7 +6,7 @@
|
||||||
-- --
|
-- --
|
||||||
-- B o d y --
|
-- B o d y --
|
||||||
-- --
|
-- --
|
||||||
-- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
|
-- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
|
||||||
-- --
|
-- --
|
||||||
-- GNAT is free software; you can redistribute it and/or modify it under --
|
-- 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- --
|
-- terms of the GNU General Public License as published by the Free Soft- --
|
||||||
|
@ -3138,7 +3138,6 @@ package body Sem_Ch6 is
|
||||||
|
|
||||||
Set_Defining_Unit_Name (Specification (Null_Body),
|
Set_Defining_Unit_Name (Specification (Null_Body),
|
||||||
Make_Defining_Identifier (Loc, Chars (Defining_Entity (N))));
|
Make_Defining_Identifier (Loc, Chars (Defining_Entity (N))));
|
||||||
Set_Corresponding_Body (N, Defining_Entity (Null_Body));
|
|
||||||
|
|
||||||
Form := First (Parameter_Specifications (Specification (Null_Body)));
|
Form := First (Parameter_Specifications (Specification (Null_Body)));
|
||||||
while Present (Form) loop
|
while Present (Form) loop
|
||||||
|
@ -3192,7 +3191,13 @@ package body Sem_Ch6 is
|
||||||
then
|
then
|
||||||
Set_Has_Completion (Designator);
|
Set_Has_Completion (Designator);
|
||||||
|
|
||||||
if Present (Null_Body) then
|
-- Null procedures are always inlined, but generic formal subprograms
|
||||||
|
-- which appear as such in the internal instance of formal packages,
|
||||||
|
-- need no completion and are not marked Inline.
|
||||||
|
|
||||||
|
if Present (Null_Body)
|
||||||
|
and then Nkind (N) /= N_Formal_Concrete_Subprogram_Declaration
|
||||||
|
then
|
||||||
Set_Corresponding_Body (N, Defining_Entity (Null_Body));
|
Set_Corresponding_Body (N, Defining_Entity (Null_Body));
|
||||||
Set_Body_To_Inline (N, Null_Body);
|
Set_Body_To_Inline (N, Null_Body);
|
||||||
Set_Is_Inlined (Designator);
|
Set_Is_Inlined (Designator);
|
||||||
|
|
|
@ -471,6 +471,9 @@ package body Sem_Prag is
|
||||||
procedure Check_Arg_Is_One_Of
|
procedure Check_Arg_Is_One_Of
|
||||||
(Arg : Node_Id;
|
(Arg : Node_Id;
|
||||||
N1, N2, N3 : Name_Id);
|
N1, N2, N3 : Name_Id);
|
||||||
|
procedure Check_Arg_Is_One_Of
|
||||||
|
(Arg : Node_Id;
|
||||||
|
N1, N2, N3, N4 : Name_Id);
|
||||||
procedure Check_Arg_Is_One_Of
|
procedure Check_Arg_Is_One_Of
|
||||||
(Arg : Node_Id;
|
(Arg : Node_Id;
|
||||||
N1, N2, N3, N4, N5 : Name_Id);
|
N1, N2, N3, N4, N5 : Name_Id);
|
||||||
|
@ -1176,6 +1179,24 @@ package body Sem_Prag is
|
||||||
end if;
|
end if;
|
||||||
end Check_Arg_Is_One_Of;
|
end Check_Arg_Is_One_Of;
|
||||||
|
|
||||||
|
procedure Check_Arg_Is_One_Of
|
||||||
|
(Arg : Node_Id;
|
||||||
|
N1, N2, N3, N4 : Name_Id)
|
||||||
|
is
|
||||||
|
Argx : constant Node_Id := Get_Pragma_Arg (Arg);
|
||||||
|
|
||||||
|
begin
|
||||||
|
Check_Arg_Is_Identifier (Argx);
|
||||||
|
|
||||||
|
if Chars (Argx) /= N1
|
||||||
|
and then Chars (Argx) /= N2
|
||||||
|
and then Chars (Argx) /= N3
|
||||||
|
and then Chars (Argx) /= N4
|
||||||
|
then
|
||||||
|
Error_Pragma_Arg ("invalid argument for pragma%", Argx);
|
||||||
|
end if;
|
||||||
|
end Check_Arg_Is_One_Of;
|
||||||
|
|
||||||
procedure Check_Arg_Is_One_Of
|
procedure Check_Arg_Is_One_Of
|
||||||
(Arg : Node_Id;
|
(Arg : Node_Id;
|
||||||
N1, N2, N3, N4, N5 : Name_Id)
|
N1, N2, N3, N4, N5 : Name_Id)
|
||||||
|
@ -9325,7 +9346,11 @@ package body Sem_Prag is
|
||||||
-----------------
|
-----------------
|
||||||
|
|
||||||
-- pragma Implemented (procedure_LOCAL_NAME, implementation_kind);
|
-- pragma Implemented (procedure_LOCAL_NAME, implementation_kind);
|
||||||
-- implementation_kind ::= By_Entry | By_Protected_Procedure | By_Any
|
-- implementation_kind ::=
|
||||||
|
-- By_Entry | By_Protected_Procedure | By_Any | Optional
|
||||||
|
|
||||||
|
-- "By_Any" and "Optional" are treated as synonyms in order to
|
||||||
|
-- support Ada 2012 aspect Synchronization.
|
||||||
|
|
||||||
when Pragma_Implemented => Implemented : declare
|
when Pragma_Implemented => Implemented : declare
|
||||||
Proc_Id : Entity_Id;
|
Proc_Id : Entity_Id;
|
||||||
|
@ -9337,8 +9362,11 @@ package body Sem_Prag is
|
||||||
Check_No_Identifiers;
|
Check_No_Identifiers;
|
||||||
Check_Arg_Is_Identifier (Arg1);
|
Check_Arg_Is_Identifier (Arg1);
|
||||||
Check_Arg_Is_Local_Name (Arg1);
|
Check_Arg_Is_Local_Name (Arg1);
|
||||||
Check_Arg_Is_One_Of
|
Check_Arg_Is_One_Of (Arg2,
|
||||||
(Arg2, Name_By_Any, Name_By_Entry, Name_By_Protected_Procedure);
|
Name_By_Any,
|
||||||
|
Name_By_Entry,
|
||||||
|
Name_By_Protected_Procedure,
|
||||||
|
Name_Optional);
|
||||||
|
|
||||||
-- Extract the name of the local procedure
|
-- Extract the name of the local procedure
|
||||||
|
|
||||||
|
|
|
@ -678,6 +678,7 @@ package Snames is
|
||||||
Name_No_Task_Attributes_Package : constant Name_Id := N + $;
|
Name_No_Task_Attributes_Package : constant Name_Id := N + $;
|
||||||
Name_Nominal : constant Name_Id := N + $;
|
Name_Nominal : constant Name_Id := N + $;
|
||||||
Name_On : constant Name_Id := N + $;
|
Name_On : constant Name_Id := N + $;
|
||||||
|
Name_Optional : constant Name_Id := N + $;
|
||||||
Name_Policy : constant Name_Id := N + $;
|
Name_Policy : constant Name_Id := N + $;
|
||||||
Name_Parameter_Types : constant Name_Id := N + $;
|
Name_Parameter_Types : constant Name_Id := N + $;
|
||||||
Name_Reference : constant Name_Id := N + $;
|
Name_Reference : constant Name_Id := N + $;
|
||||||
|
|
Loading…
Reference in New Issue