procyberian/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

[Ada] Ada2020: AI12-0279 more dispatching points with aspect Yield

Browse source 
2020-06-17  Javier Miranda  <miranda@adacore.com>

gcc/ada/

	* aspects.ads (type Aspect_Id): Add Aspect_Yield as a Boolean
	aspect, and update the Is_Representation_Aspect, Aspect_Names,
	and Aspect_Delay arrays.
	* einfo.ads, einfo.adb (Has_Yield_Aspect, Yield_Aspect): New
	subprograms.
	* exp_ch6.adb (Add_Return, Expand_Non_Function_Return,
	Expand_Simple_Function_Return): Add calls to Yield.
	* exp_ch9.adb (Build_Accept_Body, Expand_N_Accept_Statement):
	Add calls to Yield.
	* rtsfind.ads (RE_Yield): Adding support to generate calls to
	the runtime service Ada.Dispatching.Yield
	* sem_ch13.adb (Analyze_Aspect_Yield): New subprogram.
	* sem_ch3.adb (Derive_Subprogram): Inherit attribute
	Has_Yield_Aspect.
	* sem_ch8.adb (Analyze_Subprogram_Renaming): Check consistency
	of Has_Yield in the actual subprogram of a generic
	instantiation.
	* sem_disp.adb (Check_Dispatching_Operation): Check that if the
	Yield aspect is specified for a dispatching subprogram that
	inherits the aspect, the specified value shall be confirming.
	* sem_prag.adb (Analyze_Pragma [Pragma_Implemented]): Check that
	the implementation kind By_Protected_Procedure cannot be applied
	to a procedure that has aspect Yield.
This commit is contained in:
Javier Miranda 2020-04-17 14:41:58 -04:00 • committed by Pierre-Marie de Rodat
parent 67b2ed8e56
commit 8afbdb8a64
11 changed files with 320 additions and 25 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

10
gcc/ada/aspects.ads
View file

@ -218,7 +218,8 @@ package Aspects is
Aspect_Unreferenced_Objects, -- GNAT
Aspect_Volatile,
Aspect_Volatile_Components,
Aspect_Volatile_Full_Access); -- GNAT
Aspect_Volatile_Full_Access, -- GNAT
Aspect_Yield);
subtype Aspect_Id_Exclude_No_Aspect is
Aspect_Id range Aspect_Id'Succ (No_Aspect) .. Aspect_Id'Last;
@ -566,7 +567,8 @@ package Aspects is
Aspect_Unreferenced_Objects => False,
Aspect_Volatile => True,
Aspect_Volatile_Components => True,
Aspect_Volatile_Full_Access => True);
Aspect_Volatile_Full_Access => True,
Aspect_Yield => False);
-----------------------------------------
-- Table Linking Names and Aspect_Id's --
@ -709,7 +711,8 @@ package Aspects is
Aspect_Volatile_Full_Access => Name_Volatile_Full_Access,
Aspect_Volatile_Function => Name_Volatile_Function,
Aspect_Warnings => Name_Warnings,
Aspect_Write => Name_Write);
Aspect_Write => Name_Write,
Aspect_Yield => Name_Yield);
function Get_Aspect_Id (Name : Name_Id) return Aspect_Id;
pragma Inline (Get_Aspect_Id);
@ -943,6 +946,7 @@ package Aspects is
Aspect_Unimplemented => Never_Delay,
Aspect_Volatile_Function => Never_Delay,
Aspect_Warnings => Never_Delay,
Aspect_Yield => Never_Delay,
Aspect_Alignment => Rep_Aspect,
Aspect_Atomic => Rep_Aspect,

35
gcc/ada/einfo.adb
View file

@ -522,8 +522,8 @@ package body Einfo is
-- Known_To_Have_Preelab_Init Flag207
-- Must_Have_Preelab_Init Flag208
-- Is_Return_Object Flag209
-- Elaborate_Body_Desirable Flag210
-- Elaborate_Body_Desirable Flag210
-- Has_Static_Discriminants Flag211
-- Has_Pragma_Unreferenced_Objects Flag212
-- Requires_Overriding Flag213
@ -533,8 +533,8 @@ package body Einfo is
-- Suppress_Value_Tracking_On_Call Flag217
-- Is_Primitive Flag218
-- Has_Initial_Value Flag219
-- Has_Dispatch_Table Flag220
-- Has_Dispatch_Table Flag220
-- Has_Pragma_Preelab_Init Flag221
-- Used_As_Generic_Actual Flag222
-- Is_Descendant_Of_Address Flag223
@ -544,8 +544,8 @@ package body Einfo is
-- Referenced_As_Out_Parameter Flag227
-- Has_Thunks Flag228
-- Can_Use_Internal_Rep Flag229
-- Has_Pragma_Inline_Always Flag230
-- Has_Pragma_Inline_Always Flag230
-- Renamed_In_Spec Flag231
-- Has_Own_Invariants Flag232
-- Has_Pragma_Unmodified Flag233
@ -555,8 +555,8 @@ package body Einfo is
-- Warnings_Off_Used_Unmodified Flag237
-- Warnings_Off_Used_Unreferenced Flag238
-- No_Reordering Flag239
-- Has_Expanded_Contract Flag240
-- Has_Expanded_Contract Flag240
-- Optimize_Alignment_Space Flag241
-- Optimize_Alignment_Time Flag242
-- Overlays_Constant Flag243
@ -566,8 +566,8 @@ package body Einfo is
-- OK_To_Rename Flag247
-- Has_Inheritable_Invariants Flag248
-- Is_Safe_To_Reevaluate Flag249
-- Has_Predicates Flag250
-- Has_Predicates Flag250
-- Has_Implicit_Dereference Flag251
-- Is_Finalized_Transient Flag252
-- Disable_Controlled Flag253
@ -577,8 +577,8 @@ package body Einfo is
-- Is_Invariant_Procedure Flag257
-- Has_Dynamic_Predicate_Aspect Flag258
-- Has_Static_Predicate_Aspect Flag259
-- Has_Loop_Entry_Attributes Flag260
-- Has_Loop_Entry_Attributes Flag260
-- Has_Delayed_Rep_Aspects Flag261
-- May_Inherit_Delayed_Rep_Aspects Flag262
-- Has_Visible_Refinement Flag263
@ -588,8 +588,8 @@ package body Einfo is
-- Has_Shift_Operator Flag267
-- Is_Independent Flag268
-- Has_Static_Predicate Flag269
-- Stores_Attribute_Old_Prefix Flag270
-- Stores_Attribute_Old_Prefix Flag270
-- Has_Protected Flag271
-- SSO_Set_Low_By_Default Flag272
-- SSO_Set_High_By_Default Flag273
@ -599,8 +599,8 @@ package body Einfo is
-- Is_Checked_Ghost_Entity Flag277
-- Is_Ignored_Ghost_Entity Flag278
-- Contains_Ignored_Ghost_Code Flag279
-- Partial_View_Has_Unknown_Discr Flag280
-- Partial_View_Has_Unknown_Discr Flag280
-- Is_Static_Type Flag281
-- Has_Nested_Subprogram Flag282
-- Is_Uplevel_Referenced_Entity Flag283
@ -610,8 +610,8 @@ package body Einfo is
-- Rewritten_For_C Flag287
-- Predicates_Ignored Flag288
-- Has_Timing_Event Flag289
-- Is_Class_Wide_Clone Flag290
-- Is_Class_Wide_Clone Flag290
-- Has_Inherited_Invariants Flag291
-- Is_Partial_Invariant_Procedure Flag292
-- Is_Actual_Subtype Flag293
@ -621,8 +621,8 @@ package body Einfo is
-- Is_Entry_Wrapper Flag297
-- Is_Underlying_Full_View Flag298
-- Body_Needed_For_Inlining Flag299
-- Has_Private_Extension Flag300
-- Has_Private_Extension Flag300
-- Ignore_SPARK_Mode_Pragmas Flag301
-- Is_Initial_Condition_Procedure Flag302
-- Suppress_Elaboration_Warnings Flag303
@ -630,8 +630,8 @@ package body Einfo is
-- Is_Activation_Record Flag305
-- Needs_Activation_Record Flag306
-- Is_Loop_Parameter Flag307
-- Has_Yield_Aspect Flag308
-- (unused) Flag308
-- (unused) Flag309
-- Note: Flag310-317 are defined in atree.ads/adb, but not yet in atree.h
@ -1989,6 +1989,11 @@ package body Einfo is
return Flag182 (Id);
end Has_Xref_Entry;
function Has_Yield_Aspect (Id : E) return B is
begin
return Flag308 (Id);
end Has_Yield_Aspect;
function Hiding_Loop_Variable (Id : E) return E is
begin
pragma Assert (Ekind (Id) = E_Variable);
@ -5192,6 +5197,13 @@ package body Einfo is
Set_Flag182 (Id, V);
end Set_Has_Xref_Entry;
procedure Set_Has_Yield_Aspect (Id : E; V : B := True) is
begin
pragma Assert
(Is_Entry (Id) or else Is_Subprogram_Or_Generic_Subprogram (Id));
Set_Flag308 (Id, V);
end Set_Has_Yield_Aspect;
procedure Set_Hiding_Loop_Variable (Id : E; V : E) is
begin
pragma Assert (Ekind (Id) = E_Variable);
@ -9812,6 +9824,7 @@ package body Einfo is
W ("Has_Visible_Refinement", Flag263 (Id));
W ("Has_Volatile_Components", Flag87 (Id));
W ("Has_Xref_Entry", Flag182 (Id));
W ("Has_Yield_Aspect", Flag308 (Id));
W ("Ignore_SPARK_Mode_Pragmas", Flag301 (Id));
W ("In_Package_Body", Flag48 (Id));
W ("In_Private_Part", Flag45 (Id));

11
gcc/ada/einfo.ads
View file

@ -2189,6 +2189,10 @@ package Einfo is
-- references an entity with a type reference. See package Lib.Xref for
-- further details).
-- Has_Yield_Aspect (Flag308)
-- Defined in subprograms, generic subprograms, entries, entry families.
-- Set if the entity has aspect Yield.
-- Hiding_Loop_Variable (Node8)
-- Defined in variables. Set only if a variable of a discrete type is
-- hidden by a loop variable in the same local scope, in which case
@ -6092,6 +6096,7 @@ package Einfo is
-- SPARK_Pragma (Node40) (protected kind)
-- Default_Expressions_Processed (Flag108)
-- Entry_Accepted (Flag152)
-- Has_Yield_Aspect (Flag308)
-- Has_Expanded_Contract (Flag240)
-- Ignore_SPARK_Mode_Pragmas (Flag301)
-- Is_Elaboration_Checks_OK_Id (Flag148)
@ -6229,6 +6234,7 @@ package Einfo is
-- Has_Nested_Subprogram (Flag282)
-- Has_Out_Or_In_Out_Parameter (Flag110)
-- Has_Recursive_Call (Flag143)
-- Has_Yield_Aspect (Flag308)
-- Ignore_SPARK_Mode_Pragmas (Flag301)
-- Is_Abstract_Subprogram (Flag19) (non-generic case only)
-- Is_Called (Flag102) (non-generic case only)
@ -6554,6 +6560,7 @@ package Einfo is
-- Has_Master_Entity (Flag21)
-- Has_Nested_Block_With_Handler (Flag101)
-- Has_Nested_Subprogram (Flag282)
-- Has_Yield_Aspect (Flag308)
-- Ignore_SPARK_Mode_Pragmas (Flag301)
-- Is_Abstract_Subprogram (Flag19) (non-generic case only)
-- Is_Asynchronous (Flag81)
@ -7297,6 +7304,7 @@ package Einfo is
function Has_Visible_Refinement (Id : E) return B;
function Has_Volatile_Components (Id : E) return B;
function Has_Xref_Entry (Id : E) return B;
function Has_Yield_Aspect (Id : E) return B;
function Hiding_Loop_Variable (Id : E) return E;
function Hidden_In_Formal_Instance (Id : E) return L;
function Homonym (Id : E) return E;
@ -8008,6 +8016,7 @@ package Einfo is
procedure Set_Has_Visible_Refinement (Id : E; V : B := True);
procedure Set_Has_Volatile_Components (Id : E; V : B := True);
procedure Set_Has_Xref_Entry (Id : E; V : B := True);
procedure Set_Has_Yield_Aspect (Id : E; V : B := True);
procedure Set_Hiding_Loop_Variable (Id : E; V : E);
procedure Set_Hidden_In_Formal_Instance (Id : E; V : L);
procedure Set_Homonym (Id : E; V : E);
@ -8839,6 +8848,7 @@ package Einfo is
pragma Inline (Has_Visible_Refinement);
pragma Inline (Has_Volatile_Components);
pragma Inline (Has_Xref_Entry);
pragma Inline (Has_Yield_Aspect);
pragma Inline (Hiding_Loop_Variable);
pragma Inline (Hidden_In_Formal_Instance);
pragma Inline (Homonym);
@ -9452,6 +9462,7 @@ package Einfo is
pragma Inline (Set_Has_Visible_Refinement);
pragma Inline (Set_Has_Volatile_Components);
pragma Inline (Set_Has_Xref_Entry);
pragma Inline (Set_Has_Yield_Aspect);
pragma Inline (Set_Hiding_Loop_Variable);
pragma Inline (Set_Hidden_In_Formal_Instance);
pragma Inline (Set_Homonym);

33
gcc/ada/exp_ch6.adb
View file

@ -6463,6 +6463,19 @@ package body Exp_Ch6 is
Name =>
New_Occurrence_Of (Postconditions_Proc (Spec_Id), Loc)));
end if;
-- Ada 2020 (AI12-0279): append the call to 'Yield unless this is
-- a generic subprogram (since in such case it will be added to
-- the instantiations).
if Has_Yield_Aspect (Spec_Id)
and then Ekind (Spec_Id) /= E_Generic_Procedure
and then RTE_Available (RE_Yield)
then
Insert_Action (Stmt,
Make_Procedure_Call_Statement (Loc,
New_Occurrence_Of (RTE (RE_Yield), Loc)));
end if;
end if;
end Add_Return;
@ -6896,6 +6909,16 @@ package body Exp_Ch6 is
Name => New_Occurrence_Of (Postconditions_Proc (Scope_Id), Loc)));
end if;
-- Ada 2020 (AI12-0279)
if Has_Yield_Aspect (Scope_Id)
and then RTE_Available (RE_Yield)
then
Insert_Action (N,
Make_Procedure_Call_Statement (Loc,
New_Occurrence_Of (RTE (RE_Yield), Loc)));
end if;
-- If it is a return from a procedure do no extra steps
if Kind = E_Procedure or else Kind = E_Generic_Procedure then
@ -8045,6 +8068,16 @@ package body Exp_Ch6 is
Set_Original_Node (Exp, New_Copy_Of_Exp);
end if;
end if;
-- Ada 2020 (AI12-0279)
if Has_Yield_Aspect (Scope_Id)
and then RTE_Available (RE_Yield)
then
Insert_Action (N,
Make_Procedure_Call_Statement (Loc,
New_Occurrence_Of (RTE (RE_Yield), Loc)));
end if;
end Expand_Simple_Function_Return;
-----------------------

79
gcc/ada/exp_ch9.adb
View file

@ -826,6 +826,16 @@ package body Exp_Ch9 is
Insert_Before (Last (Statements (Stats)), Call);
Analyze (Call);
-- Ada 2020 (AI12-0279)
if Has_Yield_Aspect (Entity (Entry_Direct_Name (Astat)))
and then RTE_Available (RE_Yield)
then
Insert_Action_After (Call,
Make_Procedure_Call_Statement (Loc,
New_Occurrence_Of (RTE (RE_Yield), Loc)));
end if;
-- If exception handlers are present, then append Complete_Rendezvous
-- calls to the handlers, and construct the required outer block. As
-- above, the Sloc is copied from the last statement in the sequence.
@ -838,6 +848,17 @@ package body Exp_Ch9 is
(Sloc (Last (Statements (Hand))), RE_Complete_Rendezvous);
Append (Call, Statements (Hand));
Analyze (Call);
-- Ada 2020 (AI12-0279)
if Has_Yield_Aspect (Entity (Entry_Direct_Name (Astat)))
and then RTE_Available (RE_Yield)
then
Insert_Action_After (Call,
Make_Procedure_Call_Statement (Loc,
New_Occurrence_Of (RTE (RE_Yield), Loc)));
end if;
Next (Hand);
end loop;
@ -861,6 +882,16 @@ package body Exp_Ch9 is
-- We handle Abort_Signal to make sure that we properly catch the abort
-- case and wake up the caller.
Call :=
Make_Procedure_Call_Statement (Sloc (Stats),
Name => New_Occurrence_Of (
RTE (RE_Exceptional_Complete_Rendezvous), Sloc (Stats)),
Parameter_Associations => New_List (
Make_Function_Call (Sloc (Stats),
Name =>
New_Occurrence_Of
(RTE (RE_Get_GNAT_Exception), Sloc (Stats)))));
Ohandle := Make_Others_Choice (Loc);
Set_All_Others (Ohandle);
@ -869,15 +900,17 @@ package body Exp_Ch9 is
Make_Implicit_Exception_Handler (Loc,
Exception_Choices => New_List (Ohandle),
Statements => New_List (
Make_Procedure_Call_Statement (Sloc (Stats),
Name => New_Occurrence_Of (
RTE (RE_Exceptional_Complete_Rendezvous), Sloc (Stats)),
Parameter_Associations => New_List (
Make_Function_Call (Sloc (Stats),
Name =>
New_Occurrence_Of
(RTE (RE_Get_GNAT_Exception), Sloc (Stats)))))))));
Statements => New_List (Call))));
-- Ada 2020 (AI12-0279)
if Has_Yield_Aspect (Entity (Entry_Direct_Name (Astat)))
and then RTE_Available (RE_Yield)
then
Insert_Action_After (Call,
Make_Procedure_Call_Statement (Loc,
New_Occurrence_Of (RTE (RE_Yield), Loc)));
end if;
Set_Parent (New_S, Astat); -- temp parent for Analyze call
Analyze_Exception_Handlers (Exception_Handlers (New_S));
@ -6548,6 +6581,16 @@ package body Exp_Ch9 is
Analyze (N);
-- Ada 2020 (AI12-0279)
if Has_Yield_Aspect (Eent)
and then RTE_Available (RE_Yield)
then
Insert_Action_After (N,
Make_Procedure_Call_Statement (Loc,
New_Occurrence_Of (RTE (RE_Yield), Loc)));
end if;
-- Discard Entry_Address that was created for it, so it will not be
-- emitted if this accept statement is in the statement part of a
-- delay alternative.
@ -10842,7 +10885,23 @@ package body Exp_Ch9 is
-- Accept with no body (followed by trailing statements)
else
Alt_Stats := Empty_List;
declare
Entry_Id : constant Entity_Id :=
Entity (Entry_Direct_Name (Accept_Statement (Alt)));
begin
-- Ada 2020 (AI12-0279)
if Has_Yield_Aspect (Entry_Id)
and then RTE_Available (RE_Yield)
then
Alt_Stats :=
New_List (
Make_Procedure_Call_Statement (Sloc (Proc),
New_Occurrence_Of (RTE (RE_Yield), Sloc (Proc))));
else
Alt_Stats := Empty_List;
end if;
end;
end if;
Ensure_Statement_Present (Sloc (Astmt), Alt);

4
gcc/ada/rtsfind.ads
View file

@ -428,6 +428,8 @@ package Rtsfind is
RO_CA_Delay_Until, -- Ada.Calendar.Delays
RO_CA_To_Duration, -- Ada.Calendar.Delays
RE_Yield, -- Ada_Dispatching
RE_Set_Deadline, -- Ada.Dispatching.EDF
RE_Code_Loc, -- Ada.Exceptions
@ -1712,6 +1714,8 @@ package Rtsfind is
RO_CA_Delay_Until => Ada_Calendar_Delays,
RO_CA_To_Duration => Ada_Calendar_Delays,
RE_Yield => Ada_Dispatching,
RE_Set_Deadline => Ada_Dispatching_EDF,
RE_Code_Loc => Ada_Exceptions,

100
gcc/ada/sem_ch13.adb
View file

@ -1792,6 +1792,9 @@ package body Sem_Ch13 is
procedure Analyze_Aspect_Relaxed_Initialization;
-- Perform analysis of aspect Relaxed_Initialization
procedure Analyze_Aspect_Yield;
-- Perform analysis of aspect Yield
procedure Analyze_Aspect_Static;
-- Ada 202x (AI12-0075): Perform analysis of aspect Static
@ -2466,6 +2469,97 @@ package body Sem_Ch13 is
end if;
end Analyze_Aspect_Static;
--------------------------
-- Analyze_Aspect_Yield --
--------------------------
procedure Analyze_Aspect_Yield is
Expr_Value : Boolean := False;
begin
-- Check valid declarations for 'Yield
if (Nkind_In (N, N_Abstract_Subprogram_Declaration,
N_Entry_Declaration,
N_Generic_Subprogram_Declaration,
N_Subprogram_Declaration)
or else Nkind (N) in N_Formal_Subprogram_Declaration)
and then not Within_Protected_Type (E)
then
null;
elsif Within_Protected_Type (E) then
Error_Msg_N
("aspect% not applicable to protected operations", Id);
return;
else
Error_Msg_N
("aspect% only applicable to subprogram and entry "
& "declarations", Id);
return;
end if;
-- Evaluate its static expression (if available); otherwise it
-- defaults to True.
if No (Expr) then
Expr_Value := True;
-- Otherwise it must have a static boolean expression
else
if Inside_A_Generic then
Preanalyze_And_Resolve (Expr, Any_Boolean);
else
Analyze_And_Resolve (Expr, Any_Boolean);
end if;
if Is_OK_Static_Expression (Expr) then
if Is_True (Static_Boolean (Expr)) then
Expr_Value := True;
end if;
else
Error_Msg_N
("expression of aspect % must be static", Aspect);
end if;
end if;
if Expr_Value then
-- Adding minimum decoration to generic subprograms to set
-- the Yield attribute (since at this stage it may not be
-- set; see Analyze_Generic_Subprogram_Declaration).
if Nkind (N) in N_Generic_Subprogram_Declaration
and then Ekind (E) = E_Void
then
if Nkind (Specification (N)) = N_Function_Specification
then
Set_Ekind (E, E_Function);
else
Set_Ekind (E, E_Procedure);
end if;
end if;
Set_Has_Yield_Aspect (E);
end if;
-- If the Yield aspect is specified for a dispatching
-- subprogram that inherits the aspect, the specified
-- value shall be confirming.
if Present (Expr)
and then Is_Dispatching_Operation (E)
and then Present (Overridden_Operation (E))
and then Has_Yield_Aspect (Overridden_Operation (E))
/= Is_True (Static_Boolean (Expr))
then
Error_Msg_N ("specification of inherited aspect% can only " &
"confirm parent value", Id);
end if;
end Analyze_Aspect_Yield;
-----------------------
-- Make_Aitem_Pragma --
-----------------------
@ -4220,6 +4314,12 @@ package body Sem_Ch13 is
elsif A_Id = Aspect_Static then
Analyze_Aspect_Static;
goto Continue;
-- Ada 2020 (AI12-0279)
elsif A_Id = Aspect_Yield then
Analyze_Aspect_Yield;
goto Continue;
end if;
-- Library unit aspects require special handling in the case

11
gcc/ada/sem_ch3.adb
View file

@ -15803,6 +15803,17 @@ package body Sem_Ch3 is
if Ekind (New_Subp) = E_Function then
Set_Mechanism (New_Subp, Mechanism (Parent_Subp));
end if;
-- Ada 2020 (AI12-0279): If a Yield aspect is specified True for a
-- primitive subprogram S of a type T, then the aspect is inherited
-- by the corresponding primitive subprogram of each descendant of T.
if Is_Tagged_Type (Derived_Type)
and then Is_Dispatching_Operation (New_Subp)
and then Has_Yield_Aspect (Alias (New_Subp))
then
Set_Has_Yield_Aspect (New_Subp, Has_Yield_Aspect (Alias (New_Subp)));
end if;
end Derive_Subprogram;
------------------------

11
gcc/ada/sem_ch8.adb
View file

@ -3772,6 +3772,17 @@ package body Sem_Ch8 is
Analyze_Aspect_Specifications (N, New_S);
end if;
-- AI12-0279
if Is_Actual
and then Has_Yield_Aspect (Formal_Spec)
and then not Has_Yield_Aspect (Old_S)
then
Error_Msg_Name_1 := Name_Yield;
Error_Msg_N
("actual subprogram& must have aspect% to match formal", Name (N));
end if;
Ada_Version := Save_AV;
Ada_Version_Pragma := Save_AVP;
Ada_Version_Explicit := Save_AV_Exp;

37
gcc/ada/sem_disp.adb
View file

@ -23,6 +23,7 @@
-- --
------------------------------------------------------------------------------
with Aspects; use Aspects;
with Atree; use Atree;
with Debug; use Debug;
with Elists; use Elists;
@ -1636,6 +1637,42 @@ package body Sem_Disp is
end;
end if;
-- AI12-0279: If the Yield aspect is specified for a dispatching
-- subprogram that inherits the aspect, the specified value shall
-- be confirming.
if Is_Dispatching_Operation (Subp)
and then Is_Primitive_Wrapper (Subp)
and then Present (Wrapped_Entity (Subp))
and then Comes_From_Source (Wrapped_Entity (Subp))
and then Present (Overridden_Operation (Subp))
and then Has_Yield_Aspect (Overridden_Operation (Subp))
/= Has_Yield_Aspect (Wrapped_Entity (Subp))
then
declare
W_Ent : constant Entity_Id := Wrapped_Entity (Subp);
W_Decl : constant Node_Id := Parent (W_Ent);
Asp : Node_Id;
begin
if Present (Aspect_Specifications (W_Decl)) then
Asp := First (Aspect_Specifications (W_Decl));
while Present (Asp) loop
if Chars (Identifier (Asp)) = Name_Yield then
Error_Msg_Name_1 := Name_Yield;
Error_Msg_N
("specification of inherited aspect% can only confirm "
& "parent value", Asp);
end if;
Next (Asp);
end loop;
end if;
Set_Has_Yield_Aspect (Wrapped_Entity (Subp));
end;
end if;
-- For similarity with record extensions, in Ada 9X the language should
-- have disallowed adding visible operations to a tagged type after
-- deriving a private extension from it. Report a warning if this

14
gcc/ada/sem_prag.adb
View file

@ -17195,7 +17195,7 @@ package body Sem_Prag is
-- By_Protected_Procedure to the primitive procedure of a task
-- interface.
if Chars (Arg2) = Name_By_Protected_Procedure
if Chars (Get_Pragma_Arg (Arg2)) = Name_By_Protected_Procedure
and then Is_Interface (Typ)
and then Is_Task_Interface (Typ)
then
@ -17220,6 +17220,18 @@ package body Sem_Prag is
return;
end if;
-- Ada 2012 (AI12-0279): Cannot apply the implementation_kind
-- By_Protected_Procedure to a procedure that has aspect Yield
if Chars (Get_Pragma_Arg (Arg2)) = Name_By_Protected_Procedure
and then Has_Yield_Aspect (Proc_Id)
then
Error_Pragma_Arg
("implementation kind By_Protected_Procedure cannot be "
& "applied to entities with aspect 'Yield", Arg2);
return;
end if;
Record_Rep_Item (Proc_Id, N);
end Implemented;