-- 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.
-- 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);
-- 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);
---------------------------------
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;
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;
------------------------------------
------------------------------------
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;
--------------------------------
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
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;
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;
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
---------------------
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);
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.
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
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
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
------------------------------
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;
------------------------------------
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);
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
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 --
--------------------------
projects / platform / upstream / linaro-gcc.git / commitdiff