diff options
Diffstat (limited to 'gcc/ada/sem_ch9.adb')
| -rw-r--r-- | gcc/ada/sem_ch9.adb | 285 |
1 files changed, 216 insertions, 69 deletions
diff --git a/gcc/ada/sem_ch9.adb b/gcc/ada/sem_ch9.adb index b61e58af574..ec4ce80bff1 100644 --- a/gcc/ada/sem_ch9.adb +++ b/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 -- -------------------------- |