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;
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 --
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);
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,
-- 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
-- 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
-- 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
-- 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
-- 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
-- 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
-- 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
-- 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
-- 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
-- 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
-- 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
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);
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);
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));
-- 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
-- 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)
-- 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)
-- 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)
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;
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);
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);
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);
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;
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
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;
-----------------------
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.
(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;
-- 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);
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));
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.
-- 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);
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
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,
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
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 --
-----------------------
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
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;
------------------------
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;
-- --
------------------------------------------------------------------------------
+with Aspects; use Aspects;
with Atree; use Atree;
with Debug; use Debug;
with Elists; use Elists;
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
-- 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
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;
projects / gcc.git / commitdiff