sem_ch9.adb (Analyze_Requeue): Add a local flag to capture whether a requeue…

sem_ch9.adb (Analyze_Requeue): Add a local flag to capture whether a requeue statement is dispatching.

2007-12-06  Hristian Kirtchev  <kirtchev@adacore.com>
	    Gary Dismukes  <dismukes@adacore.com>

	* sem_ch9.adb (Analyze_Requeue): Add a local flag to capture whether a
	requeue statement is dispatching. Do not emit an error when the name is
	not an entry and the context is a dispatching select. Add code to
	perform subtype conformance between the formals of the current entry
	and those of the target interface primitive.
	(Analyze_Asynchronous_Select, Analyze_Conditional_Entry_Call, Analyze_
	Timed_Entry_Call): Analyze the triggering statement as the first step of
	the processing. If this is a dispatching select, postpone the analysis
	of all select statements until the Expander transforms the select. This
	approach avoids generating duplicate identifiers after the Expander has
	replicated some of the select statements. In case the Expander is
	disabled, perform regular analysis.
	(Check_Triggering_Statement): New routine.
	(Analyze_Requeue): Exclude any interpretations that are not entries when
	checking overloaded names in a requeue. Also test type conformance for
	matching interpretations rather than requiring subtype conformance at
	that point to conform with the RM's resolution rule for requeues.

From-SVN: r130855

gcc/ada/sem_ch9.adb

@@ -73,6 +73,15 @@ package body Sem_Ch9 is
    --  N is an N_Protected_Type_Declaration or N_Task_Type_Declaration node.
    --  Complete decoration of T and check legality of the covered interfaces.
 
+   procedure Check_Triggering_Statement
+     (Trigger        : Node_Id;
+      Error_Node     : Node_Id;
+      Is_Dispatching : out Boolean);
+   --  Examine the triggering statement of a select statement, conditional or
+   --  timed entry call. If Trigger is a dispatching call, return its status
+   --  in Is_Dispatching and check whether the primitive belongs to a limited
+   --  interface. If it does not, emit an error at Error_Node.
+
    function Find_Concurrent_Spec (Body_Id : Entity_Id) return Entity_Id;
    --  Find entity in corresponding task or protected declaration. Use full
    --  view if first declaration was for an incomplete type.
@@ -166,6 +175,10 @@ package body Sem_Ch9 is
       --  a new index type where a discriminant is replaced by the local
       --  variable that renames it in the task body.
 
+      -----------------------
+      -- Actual_Index_Type --
+      -----------------------
+
       function Actual_Index_Type (E : Entity_Id) return Entity_Id is
          Typ   : constant Entity_Id := Entry_Index_Type (E);
          Lo    : constant Node_Id   := Type_Low_Bound  (Typ);
@@ -404,19 +417,20 @@ package body Sem_Ch9 is
 
       --  Set Never_Set_In_Source and clear Is_True_Constant/Current_Value
       --  fields on all entry formals (this loop ignores all other entities).
-      --  Reset Referenced, Referenced_As_LHS and Has_Pragma_Unreferenced as
+      --  Reset Referenced, Referenced_As_xxx and Has_Pragma_Unreferenced as
       --  well, so that we can post accurate warnings on each accept statement
       --  for the same entry.
 
       E := First_Entity (Entry_Nam);
       while Present (E) loop
          if Is_Formal (E) then
-            Set_Never_Set_In_Source     (E, True);
-            Set_Is_True_Constant        (E, False);
-            Set_Current_Value           (E, Empty);
-            Set_Referenced              (E, False);
-            Set_Referenced_As_LHS       (E, False);
-            Set_Has_Pragma_Unreferenced (E, False);
+            Set_Never_Set_In_Source         (E, True);
+            Set_Is_True_Constant            (E, False);
+            Set_Current_Value               (E, Empty);
+            Set_Referenced                  (E, False);
+            Set_Referenced_As_LHS           (E, False);
+            Set_Referenced_As_Out_Parameter (E, False);
+            Set_Has_Pragma_Unreferenced     (E, False);
          end if;
 
          Next_Entity (E);
@@ -447,8 +461,8 @@ package body Sem_Ch9 is
    ---------------------------------
 
    procedure Analyze_Asynchronous_Select (N : Node_Id) is
-      Param   : Node_Id;
-      Trigger : Node_Id;
+      Is_Disp_Select : Boolean := False;
+      Trigger        : Node_Id;
 
    begin
       Tasking_Used := True;
@@ -460,39 +474,30 @@ package body Sem_Ch9 is
 
          Analyze (Trigger);
 
-         --  The trigger is a dispatching procedure. Postpone the analysis of
-         --  the triggering and abortable statements until the expansion of
-         --  this asynchronous select in Expand_N_Asynchronous_Select. This
-         --  action is required since otherwise we would get a gigi abort from
-         --  the code replication in Expand_N_Asynchronous_Select of an already
-         --  analyzed statement list.
+         --  Ada 2005 (AI-345): Check for a potential dispatching select
 
-         if Expander_Active
-           and then Nkind (Trigger) = N_Procedure_Call_Statement
-           and then Present (Parameter_Associations (Trigger))
-         then
-            Param := First (Parameter_Associations (Trigger));
+         Check_Triggering_Statement (Trigger, N, Is_Disp_Select);
+      end if;
 
-            if Is_Controlling_Actual (Param)
-              and then Is_Interface (Etype (Param))
-            then
-               if Is_Limited_Record (Etype (Param)) then
-                  return;
-               else
-                  Error_Msg_N
-                   ("dispatching operation of limited or synchronized " &
-                    "interface required (RM 9.7.2(3))!", N);
-               end if;
-            end if;
+      --  Ada 2005 (AI-345): The expansion of the dispatching asynchronous
+      --  select will have to duplicate the triggering statements. Postpone
+      --  the analysis of the statements till expansion. Analyze only if the
+      --  expander is disabled in order to catch any semantic errors.
+
+      if Is_Disp_Select then
+         if not Expander_Active then
+            Analyze_Statements (Statements (Abortable_Part (N)));
+            Analyze (Triggering_Alternative (N));
          end if;
-      end if;
 
       --  Analyze the statements. We analyze statements in the abortable part,
       --  because this is the section that is executed first, and that way our
       --  remembering of saved values and checks is accurate.
 
-      Analyze_Statements (Statements (Abortable_Part (N)));
-      Analyze (Triggering_Alternative (N));
+      else
+         Analyze_Statements (Statements (Abortable_Part (N)));
+         Analyze (Triggering_Alternative (N));
+      end if;
    end Analyze_Asynchronous_Select;
 
    ------------------------------------
@@ -500,21 +505,45 @@ package body Sem_Ch9 is
    ------------------------------------
 
    procedure Analyze_Conditional_Entry_Call (N : Node_Id) is
+      Trigger        : constant Node_Id :=
+                         Entry_Call_Statement (Entry_Call_Alternative (N));
+      Is_Disp_Select : Boolean := False;
+
    begin
       Check_Restriction (No_Select_Statements, N);
       Tasking_Used := True;
-      Analyze (Entry_Call_Alternative (N));
+
+      --  Ada 2005 (AI-345): The trigger may be a dispatching call
+
+      if Ada_Version >= Ada_05 then
+         Analyze (Trigger);
+         Check_Triggering_Statement (Trigger, N, Is_Disp_Select);
+      end if;
 
       if List_Length (Else_Statements (N)) = 1
         and then Nkind (First (Else_Statements (N))) in N_Delay_Statement
       then
          Error_Msg_N
-           ("suspicious form of conditional entry call?", N);
+           ("suspicious form of conditional entry call?!", N);
          Error_Msg_N
-           ("\`SELECT OR` may be intended rather than `SELECT ELSE`", N);
+           ("\`SELECT OR` may be intended rather than `SELECT ELSE`!", N);
       end if;
 
-      Analyze_Statements (Else_Statements (N));
+      --  Postpone the analysis of the statements till expansion. Analyze only
+      --  if the expander is disabled in order to catch any semantic errors.
+
+      if Is_Disp_Select then
+         if not Expander_Active then
+            Analyze (Entry_Call_Alternative (N));
+            Analyze_Statements (Else_Statements (N));
+         end if;
+
+      --  Regular select analysis
+
+      else
+         Analyze (Entry_Call_Alternative (N));
+         Analyze_Statements (Else_Statements (N));
+      end if;
    end Analyze_Conditional_Entry_Call;
 
    --------------------------------
@@ -533,9 +562,7 @@ package body Sem_Ch9 is
          Analyze_List (Pragmas_Before (N));
       end if;
 
-      if Nkind (Parent (N)) = N_Selective_Accept
-        or else Nkind (Parent (N)) = N_Timed_Entry_Call
-      then
+      if Nkind_In (Parent (N), N_Selective_Accept, N_Timed_Entry_Call) then
          Expr := Expression (Delay_Statement (N));
 
          --  Defer full analysis until the statement is expanded, to insure
@@ -791,8 +818,7 @@ package body Sem_Ch9 is
             end loop;
 
             --  If no matching body entity, then we already had a detected
-            --  error of some kind, so just forget about worrying about these
-            --  warnings.
+            --  error of some kind, so just don't worry about these warnings.
 
             if No (E2) then
                goto Continue;
@@ -994,9 +1020,9 @@ package body Sem_Ch9 is
 
       Ref_Id : Entity_Id;
       --  This is the entity of the protected object or protected type
-      --  involved, and is the entity used for cross-reference purposes
-      --  (it differs from Spec_Id in the case of a single protected
-      --  object, since Spec_Id is set to the protected type in this case).
+      --  involved, and is the entity used for cross-reference purposes (it
+      --  differs from Spec_Id in the case of a single protected object, since
+      --  Spec_Id is set to the protected type in this case).
 
    begin
       Tasking_Used := True;
@@ -1156,9 +1182,8 @@ package body Sem_Ch9 is
 
       Set_Is_Constrained (T, not Has_Discriminants (T));
 
-      --  Perform minimal expansion of the protected type while inside of a
-      --  generic. The corresponding record is needed for various semantic
-      --  checks.
+      --  Perform minimal expansion of protected type while inside a generic.
+      --  The corresponding record is needed for various semantic checks.
 
       if Ada_Version >= Ada_05
         and then Inside_A_Generic
@@ -1231,15 +1256,16 @@ package body Sem_Ch9 is
    ---------------------
 
    procedure Analyze_Requeue (N : Node_Id) is
-      Count      : Natural := 0;
-      Entry_Name : Node_Id := Name (N);
-      Entry_Id   : Entity_Id;
-      I          : Interp_Index;
-      It         : Interp;
-      Enclosing  : Entity_Id;
-      Target_Obj : Node_Id := Empty;
-      Req_Scope  : Entity_Id;
-      Outer_Ent  : Entity_Id;
+      Count       : Natural := 0;
+      Entry_Name  : Node_Id := Name (N);
+      Entry_Id    : Entity_Id;
+      I           : Interp_Index;
+      Is_Disp_Req : Boolean;
+      It          : Interp;
+      Enclosing   : Entity_Id;
+      Target_Obj  : Node_Id := Empty;
+      Req_Scope   : Entity_Id;
+      Outer_Ent   : Entity_Id;
 
    begin
       Check_Restriction (No_Requeue_Statements, N);
@@ -1313,10 +1339,20 @@ package body Sem_Ch9 is
       if Is_Overloaded (Entry_Name) then
          Entry_Id := Empty;
 
+         --  Loop over candidate interpretations and filter out any that are
+         --  not parameterless, are not type conformant, are not entries, or
+         --  do not come from source.
+
          Get_First_Interp (Entry_Name, I, It);
          while Present (It.Nam) loop
-            if No (First_Formal (It.Nam))
-              or else Subtype_Conformant (Enclosing, It.Nam)
+
+            --  Note: we test type conformance here, not subtype conformance.
+            --  Subtype conformance will be tested later on, but it is better
+            --  for error output in some cases not to do that here.
+
+            if (No (First_Formal (It.Nam))
+                 or else (Type_Conformant (Enclosing, It.Nam)))
+              and then Ekind (It.Nam) = E_Entry
             then
                --  Ada 2005 (AI-345): Since protected and task types have
                --  primitive entry wrappers, we only consider source entries.
@@ -1384,11 +1420,28 @@ package body Sem_Ch9 is
          Entry_Id := Entity (Entry_Name);
       end if;
 
+      --  Ada 2005 (AI05-0030): Potential dispatching requeue statement. The
+      --  target type must be a concurrent interface class-wide type and the
+      --  entry name must be a procedure, flagged by pragma Implemented_By_
+      --  Entry.
+
+      Is_Disp_Req :=
+        Ada_Version >= Ada_05
+          and then Present (Target_Obj)
+          and then Is_Class_Wide_Type (Etype (Target_Obj))
+          and then Is_Concurrent_Interface (Etype (Target_Obj))
+          and then Ekind (Entry_Id) = E_Procedure
+          and then Implemented_By_Entry (Entry_Id);
+
       --  Resolve entry, and check that it is subtype conformant with the
       --  enclosing construct if this construct has formals (RM 9.5.4(5)).
+      --  Ada 2005 (AI05-0030): Do not emit an error for this specific case.
 
-      if not Is_Entry (Entry_Id) then
+      if not Is_Entry (Entry_Id)
+        and then not Is_Disp_Req
+      then
          Error_Msg_N ("expect entry name in requeue statement", Name (N));
+
       elsif Ekind (Entry_Id) = E_Entry_Family
         and then Nkind (Entry_Name) /= N_Indexed_Component
       then
@@ -1406,7 +1459,39 @@ package body Sem_Ch9 is
                return;
             end if;
 
-            Check_Subtype_Conformant (Enclosing, Entry_Id, Name (N));
+            --  Ada 2005 (AI05-0030): Perform type conformance after skipping
+            --  the first parameter of Entry_Id since it is the interface
+            --  controlling formal.
+
+            if Is_Disp_Req then
+               declare
+                  Enclosing_Formal : Entity_Id;
+                  Target_Formal    : Entity_Id;
+
+               begin
+                  Enclosing_Formal := First_Formal (Enclosing);
+                  Target_Formal := Next_Formal (First_Formal (Entry_Id));
+                  while Present (Enclosing_Formal)
+                    and then Present (Target_Formal)
+                  loop
+                     if not Conforming_Types
+                              (T1    => Etype (Enclosing_Formal),
+                               T2    => Etype (Target_Formal),
+                               Ctype => Subtype_Conformant)
+                     then
+                        Error_Msg_Node_2 := Target_Formal;
+                        Error_Msg_NE
+                          ("formal & is not subtype conformant with &" &
+                           "in dispatching requeue", N, Enclosing_Formal);
+                     end if;
+
+                     Next_Formal (Enclosing_Formal);
+                     Next_Formal (Target_Formal);
+                  end loop;
+               end;
+            else
+               Check_Subtype_Conformant (Enclosing, Entry_Id, Name (N));
+            end if;
 
             --  Processing for parameters accessed by the requeue
 
@@ -1887,7 +1972,7 @@ package body Sem_Ch9 is
          if Has_Discriminants (T) then
 
             --  Install discriminants. Also, verify conformance of
-            --  discriminants of previous and current view.  ???
+            --  discriminants of previous and current view. ???
 
             Install_Declarations (T);
          else
@@ -1965,11 +2050,36 @@ package body Sem_Ch9 is
    ------------------------------
 
    procedure Analyze_Timed_Entry_Call (N : Node_Id) is
+      Trigger        : constant Node_Id :=
+                         Entry_Call_Statement (Entry_Call_Alternative (N));
+      Is_Disp_Select : Boolean := False;
+
    begin
       Check_Restriction (No_Select_Statements, N);
       Tasking_Used := True;
-      Analyze (Entry_Call_Alternative (N));
-      Analyze (Delay_Alternative (N));
+
+      --  Ada 2005 (AI-345): The trigger may be a dispatching call
+
+      if Ada_Version >= Ada_05 then
+         Analyze (Trigger);
+         Check_Triggering_Statement (Trigger, N, Is_Disp_Select);
+      end if;
+
+      --  Postpone the analysis of the statements till expansion. Analyze only
+      --  if the expander is disabled in order to catch any semantic errors.
+
+      if Is_Disp_Select then
+         if not Expander_Active then
+            Analyze (Entry_Call_Alternative (N));
+            Analyze (Delay_Alternative (N));
+         end if;
+
+      --  Regular select analysis
+
+      else
+         Analyze (Entry_Call_Alternative (N));
+         Analyze (Delay_Alternative (N));
+      end if;
    end Analyze_Timed_Entry_Call;
 
    ------------------------------------
@@ -2113,8 +2223,8 @@ package body Sem_Ch9 is
       Iface_Typ : Entity_Id;
 
    begin
-      pragma Assert (Nkind (N) = N_Protected_Type_Declaration
-        or else Nkind (N) = N_Task_Type_Declaration);
+      pragma Assert
+        (Nkind_In (N, N_Protected_Type_Declaration, N_Task_Type_Declaration));
 
       if Present (Interface_List (N)) then
          Set_Is_Tagged_Type (T);
@@ -2221,14 +2331,14 @@ package body Sem_Ch9 is
             then
                Error_Msg_N
                  ("(Ada 2005) full view must be a synchronized tagged " &
-                  "type ('R'M 7.3 (7.2/2))", Priv_T);
+                  "type (RM 7.3 (7.2/2))", Priv_T);
 
             elsif Is_Synchronized_Tagged_Type (T)
               and then not Is_Synchronized_Tagged_Type (Priv_T)
             then
                Error_Msg_N
                  ("(Ada 2005) partial view must be a synchronized tagged " &
-                  "type ('R'M 7.3 (7.2/2))", T);
+                  "type (RM 7.3 (7.2/2))", T);
             end if;
 
             --  RM 7.3 (7.3/2): The partial view shall be a descendant of an
@@ -2267,6 +2377,43 @@ package body Sem_Ch9 is
       end;
    end Check_Interfaces;
 
+   --------------------------------
+   -- Check_Triggering_Statement --
+   --------------------------------
+
+   procedure Check_Triggering_Statement
+     (Trigger        : Node_Id;
+      Error_Node     : Node_Id;
+      Is_Dispatching : out Boolean)
+   is
+      Param : Node_Id;
+
+   begin
+      Is_Dispatching := False;
+
+      --  It is not possible to have a dispatching trigger if we are not in
+      --  Ada 2005 mode.
+
+      if Ada_Version >= Ada_05
+        and then Nkind (Trigger) = N_Procedure_Call_Statement
+        and then Present (Parameter_Associations (Trigger))
+      then
+         Param := First (Parameter_Associations (Trigger));
+
+         if Is_Controlling_Actual (Param)
+           and then Is_Interface (Etype (Param))
+         then
+            if Is_Limited_Record (Etype (Param)) then
+               Is_Dispatching := True;
+            else
+               Error_Msg_N
+                 ("dispatching operation of limited or synchronized " &
+                  "interface required (RM 9.7.2(3))!", Error_Node);
+            end if;
+         end if;
+      end if;
+   end Check_Triggering_Statement;
+
    --------------------------
    -- Find_Concurrent_Spec --
    --------------------------