From b3aa0ca8345ecadca2f3482bc78074b634557164 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Mon, 23 Jan 2012 09:55:13 +0100 Subject: [multiple changes] 2012-01-23 Ed Schonberg * 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 * 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 * par-ch13.adb: Better error recovery in illegal aspect specification. 2012-01-23 Hristian Kirtchev * 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 --- gcc/ada/ChangeLog | 42 ++++++++ gcc/ada/a-calend.adb | 254 +++++++++++++++++++++++++----------------------- gcc/ada/a-calend.ads | 9 +- gcc/ada/a-catizo.adb | 36 +------ gcc/ada/a-catizo.ads | 7 +- gcc/ada/exp_ch9.adb | 16 +-- gcc/ada/par-ch13.adb | 18 +++- gcc/ada/sem_ch12.adb | 11 ++- gcc/ada/sem_ch3.adb | 31 +++--- gcc/ada/sem_ch6.adb | 11 ++- gcc/ada/sem_prag.adb | 34 ++++++- gcc/ada/snames.ads-tmpl | 1 + 12 files changed, 277 insertions(+), 193 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index f433549..511afc0 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,45 @@ +2012-01-23 Ed Schonberg + + * 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 + + * 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 + + * par-ch13.adb: Better error recovery in illegal aspect + specification. + +2012-01-23 Hristian Kirtchev + + * 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 * sprint.ads, sprint.adb (Sprint_Node_List): Add New_Lines parameter diff --git a/gcc/ada/a-calend.adb b/gcc/ada/a-calend.adb index f5fbbd5..731c4ed 100644 --- a/gcc/ada/a-calend.adb +++ b/gcc/ada/a-calend.adb @@ -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; diff --git a/gcc/ada/a-calend.ads b/gcc/ada/a-calend.ads index 240e62c..6178019 100644 --- a/gcc/ada/a-calend.ads +++ b/gcc/ada/a-calend.ads @@ -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; diff --git a/gcc/ada/a-catizo.adb b/gcc/ada/a-catizo.adb index b8f74b3..a0eb02d 100644 --- a/gcc/ada/a-catizo.adb +++ b/gcc/ada/a-catizo.adb @@ -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 diff --git a/gcc/ada/a-catizo.ads b/gcc/ada/a-catizo.ads index cbd952d..feb0402 100644 --- a/gcc/ada/a-catizo.ads +++ b/gcc/ada/a-catizo.ads @@ -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. diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index 1909d55..a20254b 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -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); diff --git a/gcc/ada/par-ch13.adb b/gcc/ada/par-ch13.adb index 82e96ce..107426f 100644 --- a/gcc/ada/par-ch13.adb +++ b/gcc/ada/par-ch13.adb @@ -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 diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index cbc8b4d..31c9293 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -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. diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 88ef267..9e31930 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -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 diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 4286c0d..cd65caa 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -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); diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index d1e20b6..59640de 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -473,6 +473,9 @@ package body Sem_Prag is 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); -- Check the specified argument Arg to make sure that it is an -- identifier whose name matches either N1 or N2 (or N3, N4, N5 if @@ -1178,6 +1181,24 @@ package body Sem_Prag is 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) is Argx : constant Node_Id := Get_Pragma_Arg (Arg); @@ -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 diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl index 6afd6c3..a091047 100644 --- a/gcc/ada/snames.ads-tmpl +++ b/gcc/ada/snames.ads-tmpl @@ -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 + $; -- cgit v1.1