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

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.

1 files changed, 37 insertions, 0 deletions

diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb
index 3b40f4c..6e74098 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