OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[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:
Arnaud Charlet 2012-01-23 09:55:13 +01:00
parent 3ffd18f16c
commit b3aa0ca834
12 changed files with 277 additions and 193 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

42
gcc/ada/ChangeLog
View File

@ -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>
* sprint.ads, sprint.adb (Sprint_Node_List): Add New_Lines parameter

254
gcc/ada/a-calend.adb
View File

@ -30,7 +30,7 @@
------------------------------------------------------------------------------
with Ada.Unchecked_Conversion;
with Interfaces.C;
with System.OS_Primitives;
package body Ada.Calendar is
@ -109,6 +109,21 @@ package body Ada.Calendar is
new Ada.Unchecked_Conversion (Time_Rep, Duration);
-- 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 --
-----------------
@ -176,6 +191,13 @@ package body Ada.Calendar is
Unix_Min : constant Time_Rep :=
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;
-- The difference between 2150-1-1 UTC and 1970-1-1 UTC expressed in
-- nanoseconds. Note that year 2100 is non-leap.
@ -626,6 +648,110 @@ package body Ada.Calendar is
Time_Zone => 0);
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 --
----------
@ -1024,11 +1150,7 @@ package body Ada.Calendar is
function Day_Of_Week (Date : Time) return Integer is
Date_N : constant Time_Rep := Time_Rep (Date);
Time_Zone : constant Long_Integer :=
Time_Zones_Operations.UTC_Time_Offset
(Date => Date,
Is_Historic => False);
Time_Zone : constant Long_Integer := UTC_Time_Offset (Date, True);
Ada_Low_N : Time_Rep;
Day_Count : Long_Integer;
Day_Dur : Time_Dur;
@ -1141,9 +1263,8 @@ package body Ada.Calendar is
else
declare
Off : constant Long_Integer :=
Time_Zones_Operations.UTC_Time_Offset
(Date => Time (Date_N),
Is_Historic => False);
UTC_Time_Offset (Time (Date_N), False);
begin
Date_N := Date_N + Time_Rep (Off) * Nano;
end;
@ -1364,15 +1485,12 @@ package body Ada.Calendar is
else
declare
Current_Off : constant Long_Integer :=
Time_Zones_Operations.UTC_Time_Offset
(Date => Time (Res_N),
Is_Historic => False);
UTC_Time_Offset (Time (Res_N), False);
Current_Res_N : constant Time_Rep :=
Res_N - Time_Rep (Current_Off) * Nano;
Off : constant Long_Integer :=
Time_Zones_Operations.UTC_Time_Offset
(Date => Time (Current_Res_N),
Is_Historic => False);
UTC_Time_Offset (Time (Current_Res_N), False);
begin
Res_N := Res_N - Time_Rep (Off) * Nano;
end;
@ -1416,115 +1534,13 @@ package body Ada.Calendar 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 --
---------------------
function UTC_Time_Offset
(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;
function UTC_Time_Offset (Date : Time) return Long_Integer is
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 Offset;
return UTC_Time_Offset (Date, True);
end UTC_Time_Offset;
end Time_Zones_Operations;

9
gcc/ada/a-calend.ads
View File

@ -350,12 +350,9 @@ private
package Time_Zones_Operations is
function UTC_Time_Offset
(Date : Time;
Is_Historic : Boolean := True) return Long_Integer;
-- 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.
function UTC_Time_Offset (Date : Time) return Long_Integer;
-- Return (in seconds), the difference between the local time zone and
-- UTC time at a specific historic date.
end Time_Zones_Operations;

36
gcc/ada/a-catizo.adb
View File

@ -42,41 +42,9 @@ package body Ada.Calendar.Time_Zones is
-- 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 :=
Time_Zones_Operations.UTC_Time_Offset
(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);
Time_Zones_Operations.UTC_Time_Offset (Date);
Offset : Time_Offset;
begin

7
gcc/ada/a-catizo.ads
View File

@ -26,12 +26,7 @@ package Ada.Calendar.Time_Zones is
Unknown_Zone_Error : exception;
function UTC_Time_Offset 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;
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, at the time Date. If the time zone
-- of the Calendar implementation is unknown, raises Unknown_Zone_Error.

16
gcc/ada/exp_ch9.adb
View File

@ -8878,7 +8878,8 @@ package body Exp_Ch9 is
-- Target.Primitive (Param1, ..., ParamN);
-- 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
-- S : constant Offset_Index :=
@ -8923,9 +8924,9 @@ package body Exp_Ch9 is
function Build_Dispatching_Requeue_To_Any return Node_Id;
-- Ada 2012 (AI05-0030): N denotes a dispatching requeue statement of
-- the form Concval.Ename. Ename is either marked by pragma Implemented
-- (XXX, By_Any) or not marked at all. Create a block which determines
-- at runtime whether Ename denotes an entry or a procedure and perform
-- the appropriate kind of dispatching select.
-- (XXX, By_Any | Optional) or not marked at all. Create a block which
-- determines at runtime whether Ename denotes an entry or a procedure
-- and perform the appropriate kind of dispatching select.
function Build_Normal_Requeue return Node_Id;
-- N denotes a non-dispatching requeue statement to either a task or a
@ -9445,9 +9446,10 @@ package body Exp_Ch9 is
Analyze (N);
-- The procedure_or_entry_NAME's implementation kind is either
-- By_Any or pragma Implemented was not applied at all. In this
-- case a runtime test determines whether Ename denotes an entry
-- or a protected procedure and performs the appropriate call.
-- By_Any, Optional, or pragma Implemented was not applied at all.
-- In this case a runtime test determines whether Ename denotes an
-- entry or a protected procedure and performs the appropriate
-- call.
else
Rewrite (N, Build_Dispatching_Requeue_To_Any);

18
gcc/ada/par-ch13.adb
View File

@ -6,7 +6,7 @@
-- --
-- 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 --
-- 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
or else Token = Tok_Semicolon
or else (not Semicolon and then Token /= Tok_Arrow)
then
-- or else (not Semicolon and then Token /= Tok_Arrow)
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");
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;
-- Here we have an aspect definition

11
gcc/ada/sem_ch12.adb
View File

@ -6,7 +6,7 @@
-- --
-- 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 --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -5104,6 +5104,15 @@ package body Sem_Ch12 is
then
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
-- instantiation of the formal must match, up to renamings.

31
gcc/ada/sem_ch3.adb
View File

@ -6,7 +6,7 @@
-- --
-- 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 --
-- 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
Iface_Alias : constant Entity_Id := Interface_Alias (Subp);
Impl_Kind : constant Name_Id := Implementation_Kind (Iface_Alias);
Subp_Alias : constant Entity_Id := Alias (Subp);
Contr_Typ : Entity_Id;
Impl_Subp : Entity_Id;
begin
-- Subp must have an alias since it is a hidden entity used to link
-- 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
Contr_Typ := Etype (First_Formal (Alias (Subp)));
Contr_Typ := Etype (First_Formal (Subp_Alias));
if Is_Concurrent_Record_Type (Contr_Typ) then
Contr_Typ := Corresponding_Concurrent_Type (Contr_Typ);
@ -8917,12 +8927,12 @@ package body Sem_Ch3 is
-- be implemented by an entry.
if Impl_Kind = Name_By_Entry
and then Ekind (Wrapped_Entity (Alias (Subp))) /= E_Entry
and then Ekind (Impl_Subp) /= E_Entry
then
Error_Msg_Node_2 := Iface_Alias;
Error_Msg_NE
("type & must implement abstract subprogram & with an entry",
Alias (Subp), Contr_Typ);
Subp_Alias, Contr_Typ);
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_NE
("interface subprogram & cannot be implemented by a " &
"primitive procedure of task type &", Alias (Subp),
"primitive procedure of task type &", Subp_Alias,
Iface_Alias);
-- An interface subprogram whose implementation kind is By_
-- Protected_Procedure must be implemented by a procedure.
elsif Is_Primitive_Wrapper (Alias (Subp))
and then Ekind (Wrapped_Entity (Alias (Subp))) /= E_Procedure
then
elsif Ekind (Impl_Subp) /= E_Procedure then
Error_Msg_Node_2 := Iface_Alias;
Error_Msg_NE
("type & must implement abstract subprogram & with a " &
"procedure", Alias (Subp), Contr_Typ);
"procedure", Subp_Alias, Contr_Typ);
end if;
end if;
end Check_Pragma_Implemented;
@ -8966,10 +8974,11 @@ package body Sem_Ch3 is
-- Ada 2012 (AI05-0030): The implementation kinds of an overridden
-- and overriding subprogram are different. In general this is an
-- error except when the implementation kind of the overridden
-- subprograms is By_Any.
-- subprograms is By_Any or Optional.
if Iface_Kind /= Subp_Kind
and then Iface_Kind /= Name_By_Any
and then Iface_Kind /= Name_Optional
then
if Iface_Kind = Name_By_Entry then
Error_Msg_N

11
gcc/ada/sem_ch6.adb
View File

@ -6,7 +6,7 @@
-- --
-- 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 --
-- 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),
Make_Defining_Identifier (Loc, Chars (Defining_Entity (N))));
Set_Corresponding_Body (N, Defining_Entity (Null_Body));
Form := First (Parameter_Specifications (Specification (Null_Body)));
while Present (Form) loop
@ -3192,7 +3191,13 @@ package body Sem_Ch6 is
then
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_Body_To_Inline (N, Null_Body);
Set_Is_Inlined (Designator);

34
gcc/ada/sem_prag.adb
View File

@ -471,6 +471,9 @@ package body Sem_Prag is
procedure Check_Arg_Is_One_Of
(Arg : Node_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
(Arg : Node_Id;
N1, N2, N3, N4, N5 : Name_Id);
@ -1176,6 +1179,24 @@ package body Sem_Prag is
end if;
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
(Arg : Node_Id;
N1, N2, N3, N4, N5 : Name_Id)
@ -9325,7 +9346,11 @@ package body Sem_Prag is
-----------------
-- 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
Proc_Id : Entity_Id;
@ -9337,8 +9362,11 @@ package body Sem_Prag is
Check_No_Identifiers;
Check_Arg_Is_Identifier (Arg1);
Check_Arg_Is_Local_Name (Arg1);
Check_Arg_Is_One_Of
(Arg2, Name_By_Any, Name_By_Entry, Name_By_Protected_Procedure);
Check_Arg_Is_One_Of (Arg2,
Name_By_Any,
Name_By_Entry,
Name_By_Protected_Procedure,
Name_Optional);
-- Extract the name of the local procedure

1
gcc/ada/snames.ads-tmpl
View File

@ -678,6 +678,7 @@ package Snames is
Name_No_Task_Attributes_Package : constant Name_Id := N + $;
Name_Nominal : constant Name_Id := N + $;
Name_On : constant Name_Id := N + $;
Name_Optional : constant Name_Id := N + $;
Name_Policy : constant Name_Id := N + $;
Name_Parameter_Types : constant Name_Id := N + $;
Name_Reference : constant Name_Id := N + $;