From: Javier Miranda Date: Fri, 17 Apr 2020 18:41:58 +0000 (-0400) Subject: [Ada] Ada2020: AI12-0279 more dispatching points with aspect Yield X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=8afbdb8a64c8f269bdda336ee8150d86b42beb04;p=gcc.git [Ada] Ada2020: AI12-0279 more dispatching points with aspect Yield 2020-06-17 Javier Miranda 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. --- diff --git a/gcc/ada/aspects.ads b/gcc/ada/aspects.ads index e6425a80639..2c1245207f7 100644 --- a/gcc/ada/aspects.ads +++ b/gcc/ada/aspects.ads @@ -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, diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index 62f61c42f3a..8280d3bef96 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -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)); diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index ba15d489a0c..8cf9d2e8f78 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -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); diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index daa672f0193..1e0047bfb29 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -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; ----------------------- diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index f4dc5d39046..651ca1f70af 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -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); diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads index f440147f669..d8420d7cbce 100644 --- a/gcc/ada/rtsfind.ads +++ b/gcc/ada/rtsfind.ads @@ -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, diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 0edcb840b60..05a511f5be3 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -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 diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 4c3212d3dee..6e0cfe2b8a8 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -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; ------------------------ diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index b189a52db21..acb5b216733 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -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; diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb index 3b40f4c3be6..6e74098914d 100644 --- a/gcc/ada/sem_disp.adb +++ b/gcc/ada/sem_disp.adb @@ -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 diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 740e3eaa234..32b4572e503 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -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;