diff options
Diffstat (limited to 'gcc-4.2.1/gcc/ada/sem_ch9.adb')
| -rw-r--r-- | gcc-4.2.1/gcc/ada/sem_ch9.adb | 2446 |
1 files changed, 2446 insertions, 0 deletions
diff --git a/gcc-4.2.1/gcc/ada/sem_ch9.adb b/gcc-4.2.1/gcc/ada/sem_ch9.adb new file mode 100644 index 000000000..1ce2efdbf --- /dev/null +++ b/gcc-4.2.1/gcc/ada/sem_ch9.adb @@ -0,0 +1,2446 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S E M _ C H 9 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Atree; use Atree; +with Checks; use Checks; +with Einfo; use Einfo; +with Errout; use Errout; +with Exp_Ch9; use Exp_Ch9; +with Elists; use Elists; +with Freeze; use Freeze; +with Itypes; use Itypes; +with Lib.Xref; use Lib.Xref; +with Nlists; use Nlists; +with Nmake; use Nmake; +with Opt; use Opt; +with Restrict; use Restrict; +with Rident; use Rident; +with Rtsfind; use Rtsfind; +with Sem; use Sem; +with Sem_Ch3; use Sem_Ch3; +with Sem_Ch5; use Sem_Ch5; +with Sem_Ch6; use Sem_Ch6; +with Sem_Ch8; use Sem_Ch8; +with Sem_Eval; use Sem_Eval; +with Sem_Res; use Sem_Res; +with Sem_Type; use Sem_Type; +with Sem_Util; use Sem_Util; +with Sem_Warn; use Sem_Warn; +with Snames; use Snames; +with Stand; use Stand; +with Sinfo; use Sinfo; +with Style; +with Tbuild; use Tbuild; +with Uintp; use Uintp; + +package body Sem_Ch9 is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Check_Max_Entries (D : Node_Id; R : All_Parameter_Restrictions); + -- Given either a protected definition or a task definition in D, check + -- the corresponding restriction parameter identifier R, and if it is set, + -- count the entries (checking the static requirement), and compare with + -- the given maximum. + + procedure Check_Overriding_Indicator (Def : Node_Id); + -- Ada 2005 (AI-397): Check the overriding indicator of entries and + -- subprograms of protected or task types. Def is the definition of the + -- protected or task type. + + 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. + + procedure Install_Declarations (Spec : Entity_Id); + -- Utility to make visible in corresponding body the entities defined in + -- task, protected type declaration, or entry declaration. + + ----------------------------- + -- Analyze_Abort_Statement -- + ----------------------------- + + procedure Analyze_Abort_Statement (N : Node_Id) is + T_Name : Node_Id; + + begin + Tasking_Used := True; + T_Name := First (Names (N)); + while Present (T_Name) loop + Analyze (T_Name); + + if Is_Task_Type (Etype (T_Name)) + or else (Ada_Version >= Ada_05 + and then Ekind (Etype (T_Name)) = E_Class_Wide_Type + and then Is_Interface (Etype (T_Name)) + and then Is_Task_Interface (Etype (T_Name))) + then + Resolve (T_Name); + else + if Ada_Version >= Ada_05 then + Error_Msg_N ("expect task name or task interface class-wide " + & "object for ABORT", T_Name); + else + Error_Msg_N ("expect task name for ABORT", T_Name); + end if; + + return; + end if; + + Next (T_Name); + end loop; + + Check_Restriction (No_Abort_Statements, N); + Check_Potentially_Blocking_Operation (N); + end Analyze_Abort_Statement; + + -------------------------------- + -- Analyze_Accept_Alternative -- + -------------------------------- + + procedure Analyze_Accept_Alternative (N : Node_Id) is + begin + Tasking_Used := True; + + if Present (Pragmas_Before (N)) then + Analyze_List (Pragmas_Before (N)); + end if; + + if Present (Condition (N)) then + Analyze_And_Resolve (Condition (N), Any_Boolean); + end if; + + Analyze (Accept_Statement (N)); + + if Is_Non_Empty_List (Statements (N)) then + Analyze_Statements (Statements (N)); + end if; + end Analyze_Accept_Alternative; + + ------------------------------ + -- Analyze_Accept_Statement -- + ------------------------------ + + procedure Analyze_Accept_Statement (N : Node_Id) is + Nam : constant Entity_Id := Entry_Direct_Name (N); + Formals : constant List_Id := Parameter_Specifications (N); + Index : constant Node_Id := Entry_Index (N); + Stats : constant Node_Id := Handled_Statement_Sequence (N); + Accept_Id : Entity_Id; + Entry_Nam : Entity_Id; + E : Entity_Id; + Kind : Entity_Kind; + Task_Nam : Entity_Id; + + ----------------------- + -- Actual_Index_Type -- + ----------------------- + + function Actual_Index_Type (E : Entity_Id) return Entity_Id; + -- If the bounds of an entry family depend on task discriminants, create + -- a new index type where a discriminant is replaced by the local + -- variable that renames it in the task body. + + 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); + Hi : constant Node_Id := Type_High_Bound (Typ); + New_T : Entity_Id; + + function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id; + -- If bound is discriminant reference, replace with corresponding + -- local variable of the same name. + + ----------------------------- + -- Actual_Discriminant_Ref -- + ----------------------------- + + function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id is + Typ : constant Entity_Id := Etype (Bound); + Ref : Node_Id; + begin + if not Is_Entity_Name (Bound) + or else Ekind (Entity (Bound)) /= E_Discriminant + then + return Bound; + else + Ref := Make_Identifier (Sloc (N), Chars (Entity (Bound))); + Analyze (Ref); + Resolve (Ref, Typ); + return Ref; + end if; + end Actual_Discriminant_Ref; + + -- Start of processing for Actual_Index_Type + + begin + if not Has_Discriminants (Task_Nam) + or else (not Is_Entity_Name (Lo) + and then not Is_Entity_Name (Hi)) + then + return Entry_Index_Type (E); + else + New_T := Create_Itype (Ekind (Typ), N); + Set_Etype (New_T, Base_Type (Typ)); + Set_Size_Info (New_T, Typ); + Set_RM_Size (New_T, RM_Size (Typ)); + Set_Scalar_Range (New_T, + Make_Range (Sloc (N), + Low_Bound => Actual_Discriminant_Ref (Lo), + High_Bound => Actual_Discriminant_Ref (Hi))); + + return New_T; + end if; + end Actual_Index_Type; + + -- Start of processing for Analyze_Accept_Statement + + begin + Tasking_Used := True; + + -- Entry name is initialized to Any_Id. It should get reset to the + -- matching entry entity. An error is signalled if it is not reset. + + Entry_Nam := Any_Id; + + for J in reverse 0 .. Scope_Stack.Last loop + Task_Nam := Scope_Stack.Table (J).Entity; + exit when Ekind (Etype (Task_Nam)) = E_Task_Type; + Kind := Ekind (Task_Nam); + + if Kind /= E_Block and then Kind /= E_Loop + and then not Is_Entry (Task_Nam) + then + Error_Msg_N ("enclosing body of accept must be a task", N); + return; + end if; + end loop; + + if Ekind (Etype (Task_Nam)) /= E_Task_Type then + Error_Msg_N ("invalid context for accept statement", N); + return; + end if; + + -- In order to process the parameters, we create a defining + -- identifier that can be used as the name of the scope. The + -- name of the accept statement itself is not a defining identifier, + -- and we cannot use its name directly because the task may have + -- any number of accept statements for the same entry. + + if Present (Index) then + Accept_Id := New_Internal_Entity + (E_Entry_Family, Current_Scope, Sloc (N), 'E'); + else + Accept_Id := New_Internal_Entity + (E_Entry, Current_Scope, Sloc (N), 'E'); + end if; + + Set_Etype (Accept_Id, Standard_Void_Type); + Set_Accept_Address (Accept_Id, New_Elmt_List); + + if Present (Formals) then + New_Scope (Accept_Id); + Process_Formals (Formals, N); + Create_Extra_Formals (Accept_Id); + End_Scope; + end if; + + -- We set the default expressions processed flag because we don't need + -- default expression functions. This is really more like body entity + -- than a spec entity anyway. + + Set_Default_Expressions_Processed (Accept_Id); + + E := First_Entity (Etype (Task_Nam)); + while Present (E) loop + if Chars (E) = Chars (Nam) + and then (Ekind (E) = Ekind (Accept_Id)) + and then Type_Conformant (Accept_Id, E) + then + Entry_Nam := E; + exit; + end if; + + Next_Entity (E); + end loop; + + if Entry_Nam = Any_Id then + Error_Msg_N ("no entry declaration matches accept statement", N); + return; + else + Set_Entity (Nam, Entry_Nam); + Generate_Reference (Entry_Nam, Nam, 'b', Set_Ref => False); + Style.Check_Identifier (Nam, Entry_Nam); + end if; + + -- Verify that the entry is not hidden by a procedure declared in the + -- current block (pathological but possible). + + if Current_Scope /= Task_Nam then + declare + E1 : Entity_Id; + + begin + E1 := First_Entity (Current_Scope); + while Present (E1) loop + if Ekind (E1) = E_Procedure + and then Chars (E1) = Chars (Entry_Nam) + and then Type_Conformant (E1, Entry_Nam) + then + Error_Msg_N ("entry name is not visible", N); + end if; + + Next_Entity (E1); + end loop; + end; + end if; + + Set_Convention (Accept_Id, Convention (Entry_Nam)); + Check_Fully_Conformant (Accept_Id, Entry_Nam, N); + + for J in reverse 0 .. Scope_Stack.Last loop + exit when Task_Nam = Scope_Stack.Table (J).Entity; + + if Entry_Nam = Scope_Stack.Table (J).Entity then + Error_Msg_N ("duplicate accept statement for same entry", N); + end if; + + end loop; + + declare + P : Node_Id := N; + begin + loop + P := Parent (P); + case Nkind (P) is + when N_Task_Body | N_Compilation_Unit => + exit; + when N_Asynchronous_Select => + Error_Msg_N ("accept statements are not allowed within" & + " an asynchronous select inner" & + " to the enclosing task body", N); + exit; + when others => + null; + end case; + end loop; + end; + + if Ekind (E) = E_Entry_Family then + if No (Index) then + Error_Msg_N ("missing entry index in accept for entry family", N); + else + Analyze_And_Resolve (Index, Entry_Index_Type (E)); + Apply_Range_Check (Index, Actual_Index_Type (E)); + end if; + + elsif Present (Index) then + Error_Msg_N ("invalid entry index in accept for simple entry", N); + end if; + + -- If label declarations present, analyze them. They are declared in the + -- enclosing task, but their enclosing scope is the entry itself, so + -- that goto's to the label are recognized as local to the accept. + + if Present (Declarations (N)) then + declare + Decl : Node_Id; + Id : Entity_Id; + + begin + Decl := First (Declarations (N)); + while Present (Decl) loop + Analyze (Decl); + + pragma Assert + (Nkind (Decl) = N_Implicit_Label_Declaration); + + Id := Defining_Identifier (Decl); + Set_Enclosing_Scope (Id, Entry_Nam); + Next (Decl); + end loop; + end; + end if; + + -- If statements are present, they must be analyzed in the context of + -- the entry, so that references to formals are correctly resolved. We + -- also have to add the declarations that are required by the expansion + -- of the accept statement in this case if expansion active. + + -- In the case of a select alternative of a selective accept, the + -- expander references the address declaration even if there is no + -- statement list. + + -- We also need to create the renaming declarations for the local + -- variables that will replace references to the formals within the + -- accept statement. + + Exp_Ch9.Expand_Accept_Declarations (N, Entry_Nam); + + -- Set Never_Set_In_Source and clear Is_True_Constant/Current_Value + -- fields on all entry formals (this loop ignores all other entities). + -- Reset Set_Referenced 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_Has_Pragma_Unreferenced (E, False); + end if; + + Next_Entity (E); + end loop; + + -- Analyze statements if present + + if Present (Stats) then + New_Scope (Entry_Nam); + Install_Declarations (Entry_Nam); + + Set_Actual_Subtypes (N, Current_Scope); + + Analyze (Stats); + Process_End_Label (Handled_Statement_Sequence (N), 't', Entry_Nam); + End_Scope; + end if; + + -- Some warning checks + + Check_Potentially_Blocking_Operation (N); + Check_References (Entry_Nam, N); + Set_Entry_Accepted (Entry_Nam); + end Analyze_Accept_Statement; + + --------------------------------- + -- Analyze_Asynchronous_Select -- + --------------------------------- + + procedure Analyze_Asynchronous_Select (N : Node_Id) is + Param : Node_Id; + Trigger : Node_Id; + + begin + Tasking_Used := True; + Check_Restriction (Max_Asynchronous_Select_Nesting, N); + Check_Restriction (No_Select_Statements, N); + + if Ada_Version >= Ada_05 then + Trigger := Triggering_Statement (Triggering_Alternative (N)); + + 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. + + if Expander_Active + 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 + return; + else + Error_Msg_N + ("dispatching operation of limited or synchronized " & + "interface required ('R'M 9.7.2(3))!", N); + end if; + end if; + 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)); + end Analyze_Asynchronous_Select; + + ------------------------------------ + -- Analyze_Conditional_Entry_Call -- + ------------------------------------ + + procedure Analyze_Conditional_Entry_Call (N : Node_Id) is + begin + Check_Restriction (No_Select_Statements, N); + Tasking_Used := True; + Analyze (Entry_Call_Alternative (N)); + + 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); + Error_Msg_N + ("\`SELECT OR` may be intended rather than `SELECT ELSE`", N); + end if; + + Analyze_Statements (Else_Statements (N)); + end Analyze_Conditional_Entry_Call; + + -------------------------------- + -- Analyze_Delay_Alternative -- + -------------------------------- + + procedure Analyze_Delay_Alternative (N : Node_Id) is + Expr : Node_Id; + Typ : Entity_Id; + + begin + Tasking_Used := True; + Check_Restriction (No_Delay, N); + + if Present (Pragmas_Before (N)) then + Analyze_List (Pragmas_Before (N)); + end if; + + if Nkind (Parent (N)) = N_Selective_Accept + or else Nkind (Parent (N)) = N_Timed_Entry_Call + then + Expr := Expression (Delay_Statement (N)); + + -- Defer full analysis until the statement is expanded, to insure + -- that generated code does not move past the guard. The delay + -- expression is only evaluated if the guard is open. + + if Nkind (Delay_Statement (N)) = N_Delay_Relative_Statement then + Pre_Analyze_And_Resolve (Expr, Standard_Duration); + else + Pre_Analyze_And_Resolve (Expr); + end if; + + Typ := First_Subtype (Etype (Expr)); + + if Nkind (Delay_Statement (N)) = N_Delay_Until_Statement + and then not Is_RTE (Typ, RO_CA_Time) + and then not Is_RTE (Typ, RO_RT_Time) + then + Error_Msg_N ("expect Time types for `DELAY UNTIL`", Expr); + end if; + + Check_Restriction (No_Fixed_Point, Expr); + + else + Analyze (Delay_Statement (N)); + end if; + + if Present (Condition (N)) then + Analyze_And_Resolve (Condition (N), Any_Boolean); + end if; + + if Is_Non_Empty_List (Statements (N)) then + Analyze_Statements (Statements (N)); + end if; + end Analyze_Delay_Alternative; + + ---------------------------- + -- Analyze_Delay_Relative -- + ---------------------------- + + procedure Analyze_Delay_Relative (N : Node_Id) is + E : constant Node_Id := Expression (N); + + begin + Check_Restriction (No_Relative_Delay, N); + Tasking_Used := True; + Check_Restriction (No_Delay, N); + Check_Potentially_Blocking_Operation (N); + Analyze_And_Resolve (E, Standard_Duration); + Check_Restriction (No_Fixed_Point, E); + end Analyze_Delay_Relative; + + ------------------------- + -- Analyze_Delay_Until -- + ------------------------- + + procedure Analyze_Delay_Until (N : Node_Id) is + E : constant Node_Id := Expression (N); + Typ : Entity_Id; + + begin + Tasking_Used := True; + Check_Restriction (No_Delay, N); + Check_Potentially_Blocking_Operation (N); + Analyze (E); + Typ := First_Subtype (Etype (E)); + + if not Is_RTE (Typ, RO_CA_Time) and then + not Is_RTE (Typ, RO_RT_Time) + then + Error_Msg_N ("expect Time types for `DELAY UNTIL`", E); + end if; + end Analyze_Delay_Until; + + ------------------------ + -- Analyze_Entry_Body -- + ------------------------ + + procedure Analyze_Entry_Body (N : Node_Id) is + Id : constant Entity_Id := Defining_Identifier (N); + Decls : constant List_Id := Declarations (N); + Stats : constant Node_Id := Handled_Statement_Sequence (N); + Formals : constant Node_Id := Entry_Body_Formal_Part (N); + P_Type : constant Entity_Id := Current_Scope; + Entry_Name : Entity_Id; + E : Entity_Id; + + begin + Tasking_Used := True; + + -- Entry_Name is initialized to Any_Id. It should get reset to the + -- matching entry entity. An error is signalled if it is not reset + + Entry_Name := Any_Id; + + Analyze (Formals); + + if Present (Entry_Index_Specification (Formals)) then + Set_Ekind (Id, E_Entry_Family); + else + Set_Ekind (Id, E_Entry); + end if; + + Set_Scope (Id, Current_Scope); + Set_Etype (Id, Standard_Void_Type); + Set_Accept_Address (Id, New_Elmt_List); + + E := First_Entity (P_Type); + while Present (E) loop + if Chars (E) = Chars (Id) + and then (Ekind (E) = Ekind (Id)) + and then Type_Conformant (Id, E) + then + Entry_Name := E; + Set_Convention (Id, Convention (E)); + Set_Corresponding_Body (Parent (Entry_Name), Id); + Check_Fully_Conformant (Id, E, N); + + if Ekind (Id) = E_Entry_Family then + if not Fully_Conformant_Discrete_Subtypes ( + Discrete_Subtype_Definition (Parent (E)), + Discrete_Subtype_Definition + (Entry_Index_Specification (Formals))) + then + Error_Msg_N + ("index not fully conformant with previous declaration", + Discrete_Subtype_Definition + (Entry_Index_Specification (Formals))); + + else + -- The elaboration of the entry body does not recompute the + -- bounds of the index, which may have side effects. Inherit + -- the bounds from the entry declaration. This is critical + -- if the entry has a per-object constraint. If a bound is + -- given by a discriminant, it must be reanalyzed in order + -- to capture the discriminal of the current entry, rather + -- than that of the protected type. + + declare + Index_Spec : constant Node_Id := + Entry_Index_Specification (Formals); + + Def : constant Node_Id := + New_Copy_Tree + (Discrete_Subtype_Definition (Parent (E))); + + begin + if Nkind + (Original_Node + (Discrete_Subtype_Definition (Index_Spec))) = N_Range + then + Set_Etype (Def, Empty); + Set_Analyzed (Def, False); + + -- Keep the original subtree to ensure a properly + -- formed tree (e.g. for ASIS use). + + Rewrite + (Discrete_Subtype_Definition (Index_Spec), Def); + + Set_Analyzed (Low_Bound (Def), False); + Set_Analyzed (High_Bound (Def), False); + + if Denotes_Discriminant (Low_Bound (Def)) then + Set_Entity (Low_Bound (Def), Empty); + end if; + + if Denotes_Discriminant (High_Bound (Def)) then + Set_Entity (High_Bound (Def), Empty); + end if; + + Analyze (Def); + Make_Index (Def, Index_Spec); + Set_Etype + (Defining_Identifier (Index_Spec), Etype (Def)); + end if; + end; + end if; + end if; + + exit; + end if; + + Next_Entity (E); + end loop; + + if Entry_Name = Any_Id then + Error_Msg_N ("no entry declaration matches entry body", N); + return; + + elsif Has_Completion (Entry_Name) then + Error_Msg_N ("duplicate entry body", N); + return; + + else + Set_Has_Completion (Entry_Name); + Generate_Reference (Entry_Name, Id, 'b', Set_Ref => False); + Style.Check_Identifier (Id, Entry_Name); + end if; + + Exp_Ch9.Expand_Entry_Barrier (N, Entry_Name); + New_Scope (Entry_Name); + + Exp_Ch9.Expand_Entry_Body_Declarations (N); + Install_Declarations (Entry_Name); + Set_Actual_Subtypes (N, Current_Scope); + + -- The entity for the protected subprogram corresponding to the entry + -- has been created. We retain the name of this entity in the entry + -- body, for use when the corresponding subprogram body is created. + -- Note that entry bodies have no corresponding_spec, and there is no + -- easy link back in the tree between the entry body and the entity for + -- the entry itself, which is why we must propagate some attributes + -- explicitly from spec to body. + + Set_Protected_Body_Subprogram + (Id, Protected_Body_Subprogram (Entry_Name)); + + Set_Entry_Parameters_Type + (Id, Entry_Parameters_Type (Entry_Name)); + + if Present (Decls) then + Analyze_Declarations (Decls); + end if; + + if Present (Stats) then + Analyze (Stats); + end if; + + -- Check for unreferenced variables etc. Before the Check_References + -- call, we transfer Never_Set_In_Source and Referenced flags from + -- parameters in the spec to the corresponding entities in the body, + -- since we want the warnings on the body entities. Note that we do + -- not have to transfer Referenced_As_LHS, since that flag can only + -- be set for simple variables. + + -- At the same time, we set the flags on the spec entities to suppress + -- any warnings on the spec formals, since we also scan the spec. + -- Finally, we propagate the Entry_Component attribute to the body + -- formals, for use in the renaming declarations created later for the + -- formals (see exp_ch9.Add_Formal_Renamings). + + declare + E1 : Entity_Id; + E2 : Entity_Id; + + begin + E1 := First_Entity (Entry_Name); + while Present (E1) loop + E2 := First_Entity (Id); + while Present (E2) loop + exit when Chars (E1) = Chars (E2); + Next_Entity (E2); + 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. + + if No (E2) then + goto Continue; + end if; + + if Ekind (E1) = E_Out_Parameter then + Set_Never_Set_In_Source (E2, Never_Set_In_Source (E1)); + Set_Never_Set_In_Source (E1, False); + end if; + + Set_Referenced (E2, Referenced (E1)); + Set_Referenced (E1); + Set_Entry_Component (E2, Entry_Component (E1)); + + <<Continue>> + Next_Entity (E1); + end loop; + + Check_References (Id); + end; + + -- We still need to check references for the spec, since objects + -- declared in the body are chained (in the First_Entity sense) to + -- the spec rather than the body in the case of entries. + + Check_References (Entry_Name); + + -- Process the end label, and terminate the scope + + Process_End_Label (Handled_Statement_Sequence (N), 't', Entry_Name); + End_Scope; + + -- If this is an entry family, remove the loop created to provide + -- a scope for the entry index. + + if Ekind (Id) = E_Entry_Family + and then Present (Entry_Index_Specification (Formals)) + then + End_Scope; + end if; + end Analyze_Entry_Body; + + ------------------------------------ + -- Analyze_Entry_Body_Formal_Part -- + ------------------------------------ + + procedure Analyze_Entry_Body_Formal_Part (N : Node_Id) is + Id : constant Entity_Id := Defining_Identifier (Parent (N)); + Index : constant Node_Id := Entry_Index_Specification (N); + Formals : constant List_Id := Parameter_Specifications (N); + + begin + Tasking_Used := True; + + if Present (Index) then + Analyze (Index); + end if; + + if Present (Formals) then + Set_Scope (Id, Current_Scope); + New_Scope (Id); + Process_Formals (Formals, Parent (N)); + End_Scope; + end if; + end Analyze_Entry_Body_Formal_Part; + + ------------------------------------ + -- Analyze_Entry_Call_Alternative -- + ------------------------------------ + + procedure Analyze_Entry_Call_Alternative (N : Node_Id) is + Call : constant Node_Id := Entry_Call_Statement (N); + + begin + Tasking_Used := True; + + if Present (Pragmas_Before (N)) then + Analyze_List (Pragmas_Before (N)); + end if; + + if Nkind (Call) = N_Attribute_Reference then + + -- Possibly a stream attribute, but definitely illegal. Other + -- illegalitles, such as procedure calls, are diagnosed after + -- resolution. + + Error_Msg_N ("entry call alternative requires an entry call", Call); + return; + end if; + + Analyze (Call); + + if Is_Non_Empty_List (Statements (N)) then + Analyze_Statements (Statements (N)); + end if; + end Analyze_Entry_Call_Alternative; + + ------------------------------- + -- Analyze_Entry_Declaration -- + ------------------------------- + + procedure Analyze_Entry_Declaration (N : Node_Id) is + Formals : constant List_Id := Parameter_Specifications (N); + Id : constant Entity_Id := Defining_Identifier (N); + D_Sdef : constant Node_Id := Discrete_Subtype_Definition (N); + + begin + Generate_Definition (Id); + Tasking_Used := True; + + if No (D_Sdef) then + Set_Ekind (Id, E_Entry); + else + Enter_Name (Id); + Set_Ekind (Id, E_Entry_Family); + Analyze (D_Sdef); + Make_Index (D_Sdef, N, Id); + end if; + + Set_Etype (Id, Standard_Void_Type); + Set_Convention (Id, Convention_Entry); + Set_Accept_Address (Id, New_Elmt_List); + + if Present (Formals) then + Set_Scope (Id, Current_Scope); + New_Scope (Id); + Process_Formals (Formals, N); + Create_Extra_Formals (Id); + End_Scope; + end if; + + if Ekind (Id) = E_Entry then + New_Overloaded_Entity (Id); + end if; + end Analyze_Entry_Declaration; + + --------------------------------------- + -- Analyze_Entry_Index_Specification -- + --------------------------------------- + + -- The Defining_Identifier of the entry index specification is local to the + -- entry body, but it must be available in the entry barrier which is + -- evaluated outside of the entry body. The index is eventually renamed as + -- a run-time object, so is visibility is strictly a front-end concern. In + -- order to make it available to the barrier, we create an additional + -- scope, as for a loop, whose only declaration is the index name. This + -- loop is not attached to the tree and does not appear as an entity local + -- to the protected type, so its existence need only be knwown to routines + -- that process entry families. + + procedure Analyze_Entry_Index_Specification (N : Node_Id) is + Iden : constant Node_Id := Defining_Identifier (N); + Def : constant Node_Id := Discrete_Subtype_Definition (N); + Loop_Id : constant Entity_Id := + Make_Defining_Identifier (Sloc (N), + Chars => New_Internal_Name ('L')); + + begin + Tasking_Used := True; + Analyze (Def); + + -- There is no elaboration of the entry index specification. Therefore, + -- if the index is a range, it is not resolved and expanded, but the + -- bounds are inherited from the entry declaration, and reanalyzed. + -- See Analyze_Entry_Body. + + if Nkind (Def) /= N_Range then + Make_Index (Def, N); + end if; + + Set_Ekind (Loop_Id, E_Loop); + Set_Scope (Loop_Id, Current_Scope); + New_Scope (Loop_Id); + Enter_Name (Iden); + Set_Ekind (Iden, E_Entry_Index_Parameter); + Set_Etype (Iden, Etype (Def)); + end Analyze_Entry_Index_Specification; + + ---------------------------- + -- Analyze_Protected_Body -- + ---------------------------- + + procedure Analyze_Protected_Body (N : Node_Id) is + Body_Id : constant Entity_Id := Defining_Identifier (N); + Last_E : Entity_Id; + + Spec_Id : Entity_Id; + -- This is initially the entity of the protected object or protected + -- type involved, but is replaced by the protected type always in the + -- case of a single protected declaration, since this is the proper + -- scope to be used. + + 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). + + begin + Tasking_Used := True; + Set_Ekind (Body_Id, E_Protected_Body); + Spec_Id := Find_Concurrent_Spec (Body_Id); + + if Present (Spec_Id) + and then Ekind (Spec_Id) = E_Protected_Type + then + null; + + elsif Present (Spec_Id) + and then Ekind (Etype (Spec_Id)) = E_Protected_Type + and then not Comes_From_Source (Etype (Spec_Id)) + then + null; + + else + Error_Msg_N ("missing specification for protected body", Body_Id); + return; + end if; + + Ref_Id := Spec_Id; + Generate_Reference (Ref_Id, Body_Id, 'b', Set_Ref => False); + Style.Check_Identifier (Body_Id, Spec_Id); + + -- The declarations are always attached to the type + + if Ekind (Spec_Id) /= E_Protected_Type then + Spec_Id := Etype (Spec_Id); + end if; + + New_Scope (Spec_Id); + Set_Corresponding_Spec (N, Spec_Id); + Set_Corresponding_Body (Parent (Spec_Id), Body_Id); + Set_Has_Completion (Spec_Id); + Install_Declarations (Spec_Id); + + Exp_Ch9.Expand_Protected_Body_Declarations (N, Spec_Id); + + Last_E := Last_Entity (Spec_Id); + + Analyze_Declarations (Declarations (N)); + + -- For visibility purposes, all entities in the body are private. Set + -- First_Private_Entity accordingly, if there was no private part in the + -- protected declaration. + + if No (First_Private_Entity (Spec_Id)) then + if Present (Last_E) then + Set_First_Private_Entity (Spec_Id, Next_Entity (Last_E)); + else + Set_First_Private_Entity (Spec_Id, First_Entity (Spec_Id)); + end if; + end if; + + Check_Completion (Body_Id); + Check_References (Spec_Id); + Process_End_Label (N, 't', Ref_Id); + End_Scope; + end Analyze_Protected_Body; + + ---------------------------------- + -- Analyze_Protected_Definition -- + ---------------------------------- + + procedure Analyze_Protected_Definition (N : Node_Id) is + E : Entity_Id; + L : Entity_Id; + + begin + Tasking_Used := True; + Analyze_Declarations (Visible_Declarations (N)); + + if Present (Private_Declarations (N)) + and then not Is_Empty_List (Private_Declarations (N)) + then + L := Last_Entity (Current_Scope); + Analyze_Declarations (Private_Declarations (N)); + + if Present (L) then + Set_First_Private_Entity (Current_Scope, Next_Entity (L)); + else + Set_First_Private_Entity (Current_Scope, + First_Entity (Current_Scope)); + end if; + end if; + + E := First_Entity (Current_Scope); + while Present (E) loop + if Ekind (E) = E_Function + or else Ekind (E) = E_Procedure + then + Set_Convention (E, Convention_Protected); + + elsif Is_Task_Type (Etype (E)) + or else Has_Task (Etype (E)) + then + Set_Has_Task (Current_Scope); + end if; + + Next_Entity (E); + end loop; + + Check_Max_Entries (N, Max_Protected_Entries); + Process_End_Label (N, 'e', Current_Scope); + Check_Overriding_Indicator (N); + end Analyze_Protected_Definition; + + ---------------------------- + -- Analyze_Protected_Type -- + ---------------------------- + + procedure Analyze_Protected_Type (N : Node_Id) is + E : Entity_Id; + T : Entity_Id; + Def_Id : constant Entity_Id := Defining_Identifier (N); + Iface : Node_Id; + Iface_Def : Node_Id; + Iface_Typ : Entity_Id; + + begin + if No_Run_Time_Mode then + Error_Msg_CRT ("protected type", N); + return; + end if; + + Tasking_Used := True; + Check_Restriction (No_Protected_Types, N); + + T := Find_Type_Name (N); + + if Ekind (T) = E_Incomplete_Type then + T := Full_View (T); + Set_Completion_Referenced (T); + end if; + + Set_Ekind (T, E_Protected_Type); + Set_Is_First_Subtype (T, True); + Init_Size_Align (T); + Set_Etype (T, T); + Set_Has_Delayed_Freeze (T, True); + Set_Stored_Constraint (T, No_Elist); + New_Scope (T); + + -- Ada 2005 (AI-345) + + if Present (Interface_List (N)) then + Set_Is_Tagged_Type (T); + + Iface := First (Interface_List (N)); + while Present (Iface) loop + Iface_Typ := Find_Type_Of_Subtype_Indic (Iface); + Iface_Def := Type_Definition (Parent (Iface_Typ)); + + if not Is_Interface (Iface_Typ) then + Error_Msg_NE ("(Ada 2005) & must be an interface", + Iface, Iface_Typ); + + else + -- Ada 2005 (AI-251): "The declaration of a specific descendant + -- of an interface type freezes the interface type" RM 13.14. + + Freeze_Before (N, Etype (Iface)); + + -- Ada 2005 (AI-345): Protected types can only implement + -- limited, synchronized or protected interfaces. + + if Limited_Present (Iface_Def) + or else Synchronized_Present (Iface_Def) + or else Protected_Present (Iface_Def) + then + null; + + elsif Task_Present (Iface_Def) then + Error_Msg_N ("(Ada 2005) protected type cannot implement a " + & "task interface", Iface); + + else + Error_Msg_N ("(Ada 2005) protected type cannot implement a " + & "non-limited interface", Iface); + end if; + end if; + + Next (Iface); + end loop; + + -- If this is the full-declaration associated with a private + -- declaration that implement interfaces, then the private type + -- declaration must be limited. + + if Has_Private_Declaration (T) then + declare + E : Entity_Id; + + begin + E := First_Entity (Scope (T)); + loop + pragma Assert (Present (E)); + + if Is_Type (E) and then Present (Full_View (E)) then + exit when Full_View (E) = T; + end if; + + Next_Entity (E); + end loop; + + if not Is_Limited_Record (E) then + Error_Msg_Sloc := Sloc (E); + Error_Msg_N + ("(Ada 2005) private type declaration # must be limited", + T); + end if; + end; + end if; + end if; + + if Present (Discriminant_Specifications (N)) then + if Has_Discriminants (T) then + + -- Install discriminants. Also, verify conformance of + -- discriminants of previous and current view. ??? + + Install_Declarations (T); + else + Process_Discriminants (N); + end if; + end if; + + Set_Is_Constrained (T, not Has_Discriminants (T)); + + Analyze (Protected_Definition (N)); + + -- Protected types with entries are controlled (because of the + -- Protection component if nothing else), same for any protected type + -- with interrupt handlers. Note that we need to analyze the protected + -- definition to set Has_Entries and such. + + if (Abort_Allowed or else Restriction_Active (No_Entry_Queue) = False + or else Number_Entries (T) > 1) + and then + (Has_Entries (T) + or else Has_Interrupt_Handler (T) + or else Has_Attach_Handler (T)) + then + Set_Has_Controlled_Component (T, True); + end if; + + -- The Ekind of components is E_Void during analysis to detect illegal + -- uses. Now it can be set correctly. + + E := First_Entity (Current_Scope); + while Present (E) loop + if Ekind (E) = E_Void then + Set_Ekind (E, E_Component); + Init_Component_Location (E); + end if; + + Next_Entity (E); + end loop; + + End_Scope; + + if T /= Def_Id + and then Is_Private_Type (Def_Id) + and then Has_Discriminants (Def_Id) + and then Expander_Active + then + Exp_Ch9.Expand_N_Protected_Type_Declaration (N); + Process_Full_View (N, T, Def_Id); + end if; + end Analyze_Protected_Type; + + --------------------- + -- Analyze_Requeue -- + --------------------- + + 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; + + begin + Check_Restriction (No_Requeue_Statements, N); + Check_Unreachable_Code (N); + Tasking_Used := True; + + Enclosing := Empty; + for J in reverse 0 .. Scope_Stack.Last loop + Enclosing := Scope_Stack.Table (J).Entity; + exit when Is_Entry (Enclosing); + + if Ekind (Enclosing) /= E_Block + and then Ekind (Enclosing) /= E_Loop + then + Error_Msg_N ("requeue must appear within accept or entry body", N); + return; + end if; + end loop; + + Analyze (Entry_Name); + + if Etype (Entry_Name) = Any_Type then + return; + end if; + + if Nkind (Entry_Name) = N_Selected_Component then + Target_Obj := Prefix (Entry_Name); + Entry_Name := Selector_Name (Entry_Name); + end if; + + -- If an explicit target object is given then we have to check the + -- restrictions of 9.5.4(6). + + if Present (Target_Obj) then + + -- Locate containing concurrent unit and determine enclosing entry + -- body or outermost enclosing accept statement within the unit. + + Outer_Ent := Empty; + for S in reverse 0 .. Scope_Stack.Last loop + Req_Scope := Scope_Stack.Table (S).Entity; + + exit when Ekind (Req_Scope) in Task_Kind + or else Ekind (Req_Scope) in Protected_Kind; + + if Is_Entry (Req_Scope) then + Outer_Ent := Req_Scope; + end if; + end loop; + + pragma Assert (Present (Outer_Ent)); + + -- Check that the accessibility level of the target object is not + -- greater or equal to the outermost enclosing accept statement (or + -- entry body) unless it is a parameter of the innermost enclosing + -- accept statement (or entry body). + + if Object_Access_Level (Target_Obj) >= Scope_Depth (Outer_Ent) + and then + (not Is_Entity_Name (Target_Obj) + or else Ekind (Entity (Target_Obj)) not in Formal_Kind + or else Enclosing /= Scope (Entity (Target_Obj))) + then + Error_Msg_N + ("target object has invalid level for requeue", Target_Obj); + end if; + end if; + + -- Overloaded case, find right interpretation + + if Is_Overloaded (Entry_Name) then + Entry_Id := Empty; + + 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) + then + -- Ada 2005 (AI-345): Since protected and task types have + -- primitive entry wrappers, we only consider source entries. + + if Comes_From_Source (It.Nam) then + Count := Count + 1; + Entry_Id := It.Nam; + else + Remove_Interp (I); + end if; + end if; + + Get_Next_Interp (I, It); + end loop; + + if Count = 0 then + Error_Msg_N ("no entry matches context", N); + return; + + elsif Count > 1 then + Error_Msg_N ("ambiguous entry name in requeue", N); + return; + + else + Set_Is_Overloaded (Entry_Name, False); + Set_Entity (Entry_Name, Entry_Id); + end if; + + -- Non-overloaded cases + + -- For the case of a reference to an element of an entry family, the + -- Entry_Name is an indexed component. + + elsif Nkind (Entry_Name) = N_Indexed_Component then + + -- Requeue to an entry out of the body + + if Nkind (Prefix (Entry_Name)) = N_Selected_Component then + Entry_Id := Entity (Selector_Name (Prefix (Entry_Name))); + + -- Requeue from within the body itself + + elsif Nkind (Prefix (Entry_Name)) = N_Identifier then + Entry_Id := Entity (Prefix (Entry_Name)); + + else + Error_Msg_N ("invalid entry_name specified", N); + return; + end if; + + -- If we had a requeue of the form REQUEUE A (B), then the parser + -- accepted it (because it could have been a requeue on an entry index. + -- If A turns out not to be an entry family, then the analysis of A (B) + -- turned it into a function call. + + elsif Nkind (Entry_Name) = N_Function_Call then + Error_Msg_N + ("arguments not allowed in requeue statement", + First (Parameter_Associations (Entry_Name))); + return; + + -- Normal case of no entry family, no argument + + else + Entry_Id := Entity (Entry_Name); + end if; + + -- Resolve entry, and check that it is subtype conformant with the + -- enclosing construct if this construct has formals (RM 9.5.4(5)). + + if not Is_Entry (Entry_Id) 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 + Error_Msg_N ("missing index for entry family component", Name (N)); + + else + Resolve_Entry (Name (N)); + Generate_Reference (Entry_Id, Entry_Name); + + if Present (First_Formal (Entry_Id)) then + Check_Subtype_Conformant (Enclosing, Entry_Id, Name (N)); + + -- Processing for parameters accessed by the requeue + + declare + Ent : Entity_Id; + + begin + Ent := First_Formal (Enclosing); + while Present (Ent) loop + + -- For OUT or IN OUT parameter, the effect of the requeue is + -- to assign the parameter a value on exit from the requeued + -- body, so we can set it as source assigned. We also clear + -- the Is_True_Constant indication. We do not need to clear + -- Current_Value, since the effect of the requeue is to + -- perform an unconditional goto so that any further + -- references will not occur anyway. + + if Ekind (Ent) = E_Out_Parameter + or else + Ekind (Ent) = E_In_Out_Parameter + then + Set_Never_Set_In_Source (Ent, False); + Set_Is_True_Constant (Ent, False); + end if; + + -- For all parameters, the requeue acts as a reference, + -- since the value of the parameter is passed to the new + -- entry, so we want to suppress unreferenced warnings. + + Set_Referenced (Ent); + Next_Formal (Ent); + end loop; + end; + end if; + end if; + end Analyze_Requeue; + + ------------------------------ + -- Analyze_Selective_Accept -- + ------------------------------ + + procedure Analyze_Selective_Accept (N : Node_Id) is + Alts : constant List_Id := Select_Alternatives (N); + Alt : Node_Id; + + Accept_Present : Boolean := False; + Terminate_Present : Boolean := False; + Delay_Present : Boolean := False; + Relative_Present : Boolean := False; + Alt_Count : Uint := Uint_0; + + begin + Check_Restriction (No_Select_Statements, N); + Tasking_Used := True; + + -- Loop to analyze alternatives + + Alt := First (Alts); + while Present (Alt) loop + Alt_Count := Alt_Count + 1; + Analyze (Alt); + + if Nkind (Alt) = N_Delay_Alternative then + if Delay_Present then + + if Relative_Present /= + (Nkind (Delay_Statement (Alt)) = N_Delay_Relative_Statement) + then + Error_Msg_N + ("delay_until and delay_relative alternatives ", Alt); + Error_Msg_N + ("\cannot appear in the same selective_wait", Alt); + end if; + + else + Delay_Present := True; + Relative_Present := + Nkind (Delay_Statement (Alt)) = N_Delay_Relative_Statement; + end if; + + elsif Nkind (Alt) = N_Terminate_Alternative then + if Terminate_Present then + Error_Msg_N ("only one terminate alternative allowed", N); + else + Terminate_Present := True; + Check_Restriction (No_Terminate_Alternatives, N); + end if; + + elsif Nkind (Alt) = N_Accept_Alternative then + Accept_Present := True; + + -- Check for duplicate accept + + declare + Alt1 : Node_Id; + Stm : constant Node_Id := Accept_Statement (Alt); + EDN : constant Node_Id := Entry_Direct_Name (Stm); + Ent : Entity_Id; + + begin + if Nkind (EDN) = N_Identifier + and then No (Condition (Alt)) + and then Present (Entity (EDN)) -- defend against junk + and then Ekind (Entity (EDN)) = E_Entry + then + Ent := Entity (EDN); + + Alt1 := First (Alts); + while Alt1 /= Alt loop + if Nkind (Alt1) = N_Accept_Alternative + and then No (Condition (Alt1)) + then + declare + Stm1 : constant Node_Id := Accept_Statement (Alt1); + EDN1 : constant Node_Id := Entry_Direct_Name (Stm1); + + begin + if Nkind (EDN1) = N_Identifier then + if Entity (EDN1) = Ent then + Error_Msg_Sloc := Sloc (Stm1); + Error_Msg_N + ("?accept duplicates one on line#", Stm); + exit; + end if; + end if; + end; + end if; + + Next (Alt1); + end loop; + end if; + end; + end if; + + Next (Alt); + end loop; + + Check_Restriction (Max_Select_Alternatives, N, Alt_Count); + Check_Potentially_Blocking_Operation (N); + + if Terminate_Present and Delay_Present then + Error_Msg_N ("at most one of terminate or delay alternative", N); + + elsif not Accept_Present then + Error_Msg_N + ("select must contain at least one accept alternative", N); + end if; + + if Present (Else_Statements (N)) then + if Terminate_Present or Delay_Present then + Error_Msg_N ("else part not allowed with other alternatives", N); + end if; + + Analyze_Statements (Else_Statements (N)); + end if; + end Analyze_Selective_Accept; + + ------------------------------ + -- Analyze_Single_Protected -- + ------------------------------ + + procedure Analyze_Single_Protected (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Id : constant Node_Id := Defining_Identifier (N); + T : Entity_Id; + T_Decl : Node_Id; + O_Decl : Node_Id; + O_Name : constant Entity_Id := New_Copy (Id); + + begin + Generate_Definition (Id); + Tasking_Used := True; + + -- The node is rewritten as a protected type declaration, in exact + -- analogy with what is done with single tasks. + + T := + Make_Defining_Identifier (Sloc (Id), + New_External_Name (Chars (Id), 'T')); + + T_Decl := + Make_Protected_Type_Declaration (Loc, + Defining_Identifier => T, + Protected_Definition => Relocate_Node (Protected_Definition (N)), + Interface_List => Interface_List (N)); + + O_Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => O_Name, + Object_Definition => Make_Identifier (Loc, Chars (T))); + + Rewrite (N, T_Decl); + Insert_After (N, O_Decl); + Mark_Rewrite_Insertion (O_Decl); + + -- Enter names of type and object before analysis, because the name of + -- the object may be used in its own body. + + Enter_Name (T); + Set_Ekind (T, E_Protected_Type); + Set_Etype (T, T); + + Enter_Name (O_Name); + Set_Ekind (O_Name, E_Variable); + Set_Etype (O_Name, T); + + -- Instead of calling Analyze on the new node, call the proper analysis + -- procedure directly. Otherwise the node would be expanded twice, with + -- disastrous result. + + Analyze_Protected_Type (N); + end Analyze_Single_Protected; + + ------------------------- + -- Analyze_Single_Task -- + ------------------------- + + procedure Analyze_Single_Task (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Id : constant Node_Id := Defining_Identifier (N); + T : Entity_Id; + T_Decl : Node_Id; + O_Decl : Node_Id; + O_Name : constant Entity_Id := New_Copy (Id); + + begin + Generate_Definition (Id); + Tasking_Used := True; + + -- The node is rewritten as a task type declaration, followed by an + -- object declaration of that anonymous task type. + + T := + Make_Defining_Identifier (Sloc (Id), + New_External_Name (Chars (Id), Suffix => "TK")); + + T_Decl := + Make_Task_Type_Declaration (Loc, + Defining_Identifier => T, + Task_Definition => Relocate_Node (Task_Definition (N)), + Interface_List => Interface_List (N)); + + O_Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => O_Name, + Object_Definition => Make_Identifier (Loc, Chars (T))); + + Rewrite (N, T_Decl); + Insert_After (N, O_Decl); + Mark_Rewrite_Insertion (O_Decl); + + -- Enter names of type and object before analysis, because the name of + -- the object may be used in its own body. + + Enter_Name (T); + Set_Ekind (T, E_Task_Type); + Set_Etype (T, T); + + Enter_Name (O_Name); + Set_Ekind (O_Name, E_Variable); + Set_Etype (O_Name, T); + + -- Instead of calling Analyze on the new node, call the proper analysis + -- procedure directly. Otherwise the node would be expanded twice, with + -- disastrous result. + + Analyze_Task_Type (N); + end Analyze_Single_Task; + + ----------------------- + -- Analyze_Task_Body -- + ----------------------- + + procedure Analyze_Task_Body (N : Node_Id) is + Body_Id : constant Entity_Id := Defining_Identifier (N); + Last_E : Entity_Id; + + Spec_Id : Entity_Id; + -- This is initially the entity of the task or task type involved, but + -- is replaced by the task type always in the case of a single task + -- declaration, since this is the proper scope to be used. + + Ref_Id : Entity_Id; + -- This is the entity of the task or task type, and is the entity used + -- for cross-reference purposes (it differs from Spec_Id in the case of + -- a single task, since Spec_Id is set to the task type) + + begin + Tasking_Used := True; + Set_Ekind (Body_Id, E_Task_Body); + Set_Scope (Body_Id, Current_Scope); + Spec_Id := Find_Concurrent_Spec (Body_Id); + + -- The spec is either a task type declaration, or a single task + -- declaration for which we have created an anonymous type. + + if Present (Spec_Id) + and then Ekind (Spec_Id) = E_Task_Type + then + null; + + elsif Present (Spec_Id) + and then Ekind (Etype (Spec_Id)) = E_Task_Type + and then not Comes_From_Source (Etype (Spec_Id)) + then + null; + + else + Error_Msg_N ("missing specification for task body", Body_Id); + return; + end if; + + if Has_Completion (Spec_Id) + and then Present (Corresponding_Body (Parent (Spec_Id))) + then + if Nkind (Parent (Spec_Id)) = N_Task_Type_Declaration then + Error_Msg_NE ("duplicate body for task type&", N, Spec_Id); + + else + Error_Msg_NE ("duplicate body for task&", N, Spec_Id); + end if; + end if; + + Ref_Id := Spec_Id; + Generate_Reference (Ref_Id, Body_Id, 'b', Set_Ref => False); + Style.Check_Identifier (Body_Id, Spec_Id); + + -- Deal with case of body of single task (anonymous type was created) + + if Ekind (Spec_Id) = E_Variable then + Spec_Id := Etype (Spec_Id); + end if; + + New_Scope (Spec_Id); + Set_Corresponding_Spec (N, Spec_Id); + Set_Corresponding_Body (Parent (Spec_Id), Body_Id); + Set_Has_Completion (Spec_Id); + Install_Declarations (Spec_Id); + Last_E := Last_Entity (Spec_Id); + + Analyze_Declarations (Declarations (N)); + + -- For visibility purposes, all entities in the body are private. Set + -- First_Private_Entity accordingly, if there was no private part in the + -- protected declaration. + + if No (First_Private_Entity (Spec_Id)) then + if Present (Last_E) then + Set_First_Private_Entity (Spec_Id, Next_Entity (Last_E)); + else + Set_First_Private_Entity (Spec_Id, First_Entity (Spec_Id)); + end if; + end if; + + Analyze (Handled_Statement_Sequence (N)); + Check_Completion (Body_Id); + Check_References (Body_Id); + Check_References (Spec_Id); + + -- Check for entries with no corresponding accept + + declare + Ent : Entity_Id; + + begin + Ent := First_Entity (Spec_Id); + while Present (Ent) loop + if Is_Entry (Ent) + and then not Entry_Accepted (Ent) + and then Comes_From_Source (Ent) + then + Error_Msg_NE ("no accept for entry &?", N, Ent); + end if; + + Next_Entity (Ent); + end loop; + end; + + Process_End_Label (Handled_Statement_Sequence (N), 't', Ref_Id); + End_Scope; + end Analyze_Task_Body; + + ----------------------------- + -- Analyze_Task_Definition -- + ----------------------------- + + procedure Analyze_Task_Definition (N : Node_Id) is + L : Entity_Id; + + begin + Tasking_Used := True; + + if Present (Visible_Declarations (N)) then + Analyze_Declarations (Visible_Declarations (N)); + end if; + + if Present (Private_Declarations (N)) then + L := Last_Entity (Current_Scope); + Analyze_Declarations (Private_Declarations (N)); + + if Present (L) then + Set_First_Private_Entity + (Current_Scope, Next_Entity (L)); + else + Set_First_Private_Entity + (Current_Scope, First_Entity (Current_Scope)); + end if; + end if; + + Check_Max_Entries (N, Max_Task_Entries); + Process_End_Label (N, 'e', Current_Scope); + Check_Overriding_Indicator (N); + end Analyze_Task_Definition; + + ----------------------- + -- Analyze_Task_Type -- + ----------------------- + + procedure Analyze_Task_Type (N : Node_Id) is + T : Entity_Id; + Def_Id : constant Entity_Id := Defining_Identifier (N); + Iface : Node_Id; + Iface_Def : Node_Id; + Iface_Typ : Entity_Id; + + begin + Check_Restriction (No_Tasking, N); + Tasking_Used := True; + T := Find_Type_Name (N); + Generate_Definition (T); + + if Ekind (T) = E_Incomplete_Type then + T := Full_View (T); + Set_Completion_Referenced (T); + end if; + + Set_Ekind (T, E_Task_Type); + Set_Is_First_Subtype (T, True); + Set_Has_Task (T, True); + Init_Size_Align (T); + Set_Etype (T, T); + Set_Has_Delayed_Freeze (T, True); + Set_Stored_Constraint (T, No_Elist); + New_Scope (T); + + -- Ada 2005 (AI-345) + + if Present (Interface_List (N)) then + Set_Is_Tagged_Type (T); + + Iface := First (Interface_List (N)); + while Present (Iface) loop + Iface_Typ := Find_Type_Of_Subtype_Indic (Iface); + Iface_Def := Type_Definition (Parent (Iface_Typ)); + + if not Is_Interface (Iface_Typ) then + Error_Msg_NE ("(Ada 2005) & must be an interface", + Iface, Iface_Typ); + + else + -- Ada 2005 (AI-251): The declaration of a specific descendant + -- of an interface type freezes the interface type (RM 13.14). + + Freeze_Before (N, Etype (Iface)); + + -- Ada 2005 (AI-345): Task types can only implement limited, + -- synchronized or task interfaces. + + if Limited_Present (Iface_Def) + or else Synchronized_Present (Iface_Def) + or else Task_Present (Iface_Def) + then + null; + + elsif Protected_Present (Iface_Def) then + Error_Msg_N ("(Ada 2005) task type cannot implement a " & + "protected interface", Iface); + + else + Error_Msg_N ("(Ada 2005) task type cannot implement a " & + "non-limited interface", Iface); + end if; + end if; + + Next (Iface); + end loop; + + -- If this is the full-declaration associated with a private + -- declaration that implement interfaces, then the private + -- type declaration must be limited. + + if Has_Private_Declaration (T) then + declare + E : Entity_Id; + + begin + E := First_Entity (Scope (T)); + loop + pragma Assert (Present (E)); + + if Is_Type (E) and then Present (Full_View (E)) then + exit when Full_View (E) = T; + end if; + + Next_Entity (E); + end loop; + + if not Is_Limited_Record (E) then + Error_Msg_Sloc := Sloc (E); + Error_Msg_N + ("(Ada 2005) private type declaration # must be limited", + T); + end if; + end; + end if; + end if; + + if Present (Discriminant_Specifications (N)) then + if Ada_Version = Ada_83 and then Comes_From_Source (N) then + Error_Msg_N ("(Ada 83) task discriminant not allowed!", N); + end if; + + if Has_Discriminants (T) then + + -- Install discriminants. Also, verify conformance of + -- discriminants of previous and current view. ??? + + Install_Declarations (T); + else + Process_Discriminants (N); + end if; + end if; + + Set_Is_Constrained (T, not Has_Discriminants (T)); + + if Present (Task_Definition (N)) then + Analyze_Task_Definition (Task_Definition (N)); + end if; + + if not Is_Library_Level_Entity (T) then + Check_Restriction (No_Task_Hierarchy, N); + end if; + + End_Scope; + + if T /= Def_Id + and then Is_Private_Type (Def_Id) + and then Has_Discriminants (Def_Id) + and then Expander_Active + then + Exp_Ch9.Expand_N_Task_Type_Declaration (N); + Process_Full_View (N, T, Def_Id); + end if; + end Analyze_Task_Type; + + ----------------------------------- + -- Analyze_Terminate_Alternative -- + ----------------------------------- + + procedure Analyze_Terminate_Alternative (N : Node_Id) is + begin + Tasking_Used := True; + + if Present (Pragmas_Before (N)) then + Analyze_List (Pragmas_Before (N)); + end if; + + if Present (Condition (N)) then + Analyze_And_Resolve (Condition (N), Any_Boolean); + end if; + end Analyze_Terminate_Alternative; + + ------------------------------ + -- Analyze_Timed_Entry_Call -- + ------------------------------ + + procedure Analyze_Timed_Entry_Call (N : Node_Id) is + begin + Check_Restriction (No_Select_Statements, N); + Tasking_Used := True; + Analyze (Entry_Call_Alternative (N)); + Analyze (Delay_Alternative (N)); + end Analyze_Timed_Entry_Call; + + ------------------------------------ + -- Analyze_Triggering_Alternative -- + ------------------------------------ + + procedure Analyze_Triggering_Alternative (N : Node_Id) is + Trigger : constant Node_Id := Triggering_Statement (N); + + begin + Tasking_Used := True; + + if Present (Pragmas_Before (N)) then + Analyze_List (Pragmas_Before (N)); + end if; + + Analyze (Trigger); + + if Comes_From_Source (Trigger) + and then Nkind (Trigger) not in N_Delay_Statement + and then Nkind (Trigger) /= N_Entry_Call_Statement + then + if Ada_Version < Ada_05 then + Error_Msg_N + ("triggering statement must be delay or entry call", Trigger); + + -- Ada 2005 (AI-345): If a procedure_call_statement is used for a + -- procedure_or_entry_call, the procedure_name or pro- cedure_prefix + -- of the procedure_call_statement shall denote an entry renamed by a + -- procedure, or (a view of) a primitive subprogram of a limited + -- interface whose first parameter is a controlling parameter. + + elsif Nkind (Trigger) = N_Procedure_Call_Statement + and then not Is_Renamed_Entry (Entity (Name (Trigger))) + and then not Is_Controlling_Limited_Procedure + (Entity (Name (Trigger))) + then + Error_Msg_N ("triggering statement must be delay, procedure " & + "or entry call", Trigger); + end if; + end if; + + if Is_Non_Empty_List (Statements (N)) then + Analyze_Statements (Statements (N)); + end if; + end Analyze_Triggering_Alternative; + + ----------------------- + -- Check_Max_Entries -- + ----------------------- + + procedure Check_Max_Entries (D : Node_Id; R : All_Parameter_Restrictions) is + Ecount : Uint; + + procedure Count (L : List_Id); + -- Count entries in given declaration list + + ----------- + -- Count -- + ----------- + + procedure Count (L : List_Id) is + D : Node_Id; + + begin + if No (L) then + return; + end if; + + D := First (L); + while Present (D) loop + if Nkind (D) = N_Entry_Declaration then + declare + DSD : constant Node_Id := + Discrete_Subtype_Definition (D); + + begin + -- If not an entry family, then just one entry + + if No (DSD) then + Ecount := Ecount + 1; + + -- If entry family with static bounds, count entries + + elsif Is_OK_Static_Subtype (Etype (DSD)) then + declare + Lo : constant Uint := + Expr_Value + (Type_Low_Bound (Etype (DSD))); + Hi : constant Uint := + Expr_Value + (Type_High_Bound (Etype (DSD))); + + begin + if Hi >= Lo then + Ecount := Ecount + Hi - Lo + 1; + end if; + end; + + -- Entry family with non-static bounds + + else + -- If restriction is set, then this is an error + + if Restrictions.Set (R) then + Error_Msg_N + ("static subtype required by Restriction pragma", + DSD); + + -- Otherwise we record an unknown count restriction + + else + Check_Restriction (R, D); + end if; + end if; + end; + end if; + + Next (D); + end loop; + end Count; + + -- Start of processing for Check_Max_Entries + + begin + Ecount := Uint_0; + Count (Visible_Declarations (D)); + Count (Private_Declarations (D)); + + if Ecount > 0 then + Check_Restriction (R, D, Ecount); + end if; + end Check_Max_Entries; + + -------------------------------- + -- Check_Overriding_Indicator -- + -------------------------------- + + procedure Check_Overriding_Indicator (Def : Node_Id) is + Aliased_Hom : Entity_Id; + Decl : Node_Id; + Def_Id : Entity_Id; + Hom : Entity_Id; + Ifaces : constant List_Id := Interface_List (Parent (Def)); + Overrides : Boolean; + Spec : Node_Id; + Vis_Decls : constant List_Id := Visible_Declarations (Def); + + function Matches_Prefixed_View_Profile + (Ifaces : List_Id; + Entry_Params : List_Id; + Proc_Params : List_Id) return Boolean; + -- Ada 2005 (AI-397): Determine if an entry parameter profile matches + -- the prefixed view profile of an abstract procedure. Also determine + -- whether the abstract procedure belongs to an implemented interface. + + ----------------------------------- + -- Matches_Prefixed_View_Profile -- + ----------------------------------- + + function Matches_Prefixed_View_Profile + (Ifaces : List_Id; + Entry_Params : List_Id; + Proc_Params : List_Id) return Boolean + is + Entry_Param : Node_Id; + Proc_Param : Node_Id; + Proc_Param_Typ : Entity_Id; + + function Includes_Interface + (Iface : Entity_Id; + Ifaces : List_Id) return Boolean; + -- Determine if an interface is contained in a list of interfaces + + ------------------------ + -- Includes_Interface -- + ------------------------ + + function Includes_Interface + (Iface : Entity_Id; + Ifaces : List_Id) return Boolean + is + Ent : Entity_Id; + + begin + Ent := First (Ifaces); + while Present (Ent) loop + if Etype (Ent) = Iface then + return True; + end if; + + Next (Ent); + end loop; + + return False; + end Includes_Interface; + + -- Start of processing for Matches_Prefixed_View_Profile + + begin + Proc_Param := First (Proc_Params); + Proc_Param_Typ := Etype (Parameter_Type (Proc_Param)); + + -- The first parameter of the abstract procedure must be of an + -- interface type. The task or protected type must also implement + -- that interface. + + if not Is_Interface (Proc_Param_Typ) + or else not Includes_Interface (Proc_Param_Typ, Ifaces) + then + return False; + end if; + + Entry_Param := First (Entry_Params); + Proc_Param := Next (Proc_Param); + while Present (Entry_Param) and then Present (Proc_Param) loop + + -- The two parameters must be mode conformant and have the exact + -- same types. + + if Ekind (Defining_Identifier (Entry_Param)) /= + Ekind (Defining_Identifier (Proc_Param)) + or else Etype (Parameter_Type (Entry_Param)) /= + Etype (Parameter_Type (Proc_Param)) + then + return False; + end if; + + Next (Entry_Param); + Next (Proc_Param); + end loop; + + -- One of the lists is longer than the other + + if Present (Entry_Param) or else Present (Proc_Param) then + return False; + end if; + + return True; + end Matches_Prefixed_View_Profile; + + -- Start of processing for Check_Overriding_Indicator + + begin + if Present (Ifaces) then + Decl := First (Vis_Decls); + while Present (Decl) loop + + -- Consider entries with either "overriding" or "not overriding" + -- indicator present. + + if Nkind (Decl) = N_Entry_Declaration + and then (Must_Override (Decl) + or else + Must_Not_Override (Decl)) + then + Def_Id := Defining_Identifier (Decl); + + Overrides := False; + + Hom := Homonym (Def_Id); + while Present (Hom) loop + + -- The current entry may override a procedure from an + -- implemented interface. + + if Ekind (Hom) = E_Procedure + and then (Is_Abstract (Hom) + or else + Null_Present (Parent (Hom))) + then + Aliased_Hom := Hom; + while Present (Alias (Aliased_Hom)) loop + Aliased_Hom := Alias (Aliased_Hom); + end loop; + + if Matches_Prefixed_View_Profile (Ifaces, + Parameter_Specifications (Decl), + Parameter_Specifications (Parent (Aliased_Hom))) + then + Overrides := True; + exit; + end if; + end if; + + Hom := Homonym (Hom); + end loop; + + if Overrides then + if Must_Not_Override (Decl) then + Error_Msg_NE ("entry& is overriding", Def_Id, Def_Id); + end if; + else + if Must_Override (Decl) then + Error_Msg_NE ("entry& is not overriding", Def_Id, Def_Id); + end if; + end if; + + -- Consider subprograms with either "overriding" or "not + -- overriding" indicator present. + + elsif Nkind (Decl) = N_Subprogram_Declaration + and then (Must_Override (Specification (Decl)) + or else + Must_Not_Override (Specification (Decl))) + then + Spec := Specification (Decl); + Def_Id := Defining_Unit_Name (Spec); + + Overrides := False; + + Hom := Homonym (Def_Id); + while Present (Hom) loop + + -- Function + + if Ekind (Def_Id) = E_Function + and then Ekind (Hom) = E_Function + and then Is_Abstract (Hom) + and then Matches_Prefixed_View_Profile (Ifaces, + Parameter_Specifications (Spec), + Parameter_Specifications (Parent (Hom))) + and then Etype (Result_Definition (Spec)) = + Etype (Result_Definition (Parent (Hom))) + then + Overrides := True; + exit; + + -- Procedure + + elsif Ekind (Def_Id) = E_Procedure + and then Ekind (Hom) = E_Procedure + and then (Is_Abstract (Hom) + or else + Null_Present (Parent (Hom))) + and then Matches_Prefixed_View_Profile (Ifaces, + Parameter_Specifications (Spec), + Parameter_Specifications (Parent (Hom))) + then + Overrides := True; + exit; + end if; + + Hom := Homonym (Hom); + end loop; + + if Overrides then + if Must_Not_Override (Spec) then + Error_Msg_NE + ("subprogram& is overriding", Def_Id, Def_Id); + end if; + else + if Must_Override (Spec) then + Error_Msg_NE + ("subprogram& is not overriding", Def_Id, Def_Id); + end if; + end if; + end if; + + Next (Decl); + end loop; + + -- The protected or task type is not implementing an interface, we need + -- to check for the presence of "overriding" entries or subprograms and + -- flag them as erroneous. + + else + Decl := First (Vis_Decls); + while Present (Decl) loop + if Nkind (Decl) = N_Entry_Declaration + and then Must_Override (Decl) + then + Def_Id := Defining_Identifier (Decl); + Error_Msg_NE ("entry& is not overriding", Def_Id, Def_Id); + + elsif Nkind (Decl) = N_Subprogram_Declaration + and then Must_Override (Specification (Decl)) + then + Def_Id := Defining_Identifier (Specification (Decl)); + Error_Msg_NE ("subprogram& is not overriding", Def_Id, Def_Id); + end if; + + Next (Decl); + end loop; + end if; + end Check_Overriding_Indicator; + + -------------------------- + -- Find_Concurrent_Spec -- + -------------------------- + + function Find_Concurrent_Spec (Body_Id : Entity_Id) return Entity_Id is + Spec_Id : Entity_Id := Current_Entity_In_Scope (Body_Id); + + begin + -- The type may have been given by an incomplete type declaration. + -- Find full view now. + + if Present (Spec_Id) and then Ekind (Spec_Id) = E_Incomplete_Type then + Spec_Id := Full_View (Spec_Id); + end if; + + return Spec_Id; + end Find_Concurrent_Spec; + + -------------------------- + -- Install_Declarations -- + -------------------------- + + procedure Install_Declarations (Spec : Entity_Id) is + E : Entity_Id; + Prev : Entity_Id; + begin + E := First_Entity (Spec); + while Present (E) loop + Prev := Current_Entity (E); + Set_Current_Entity (E); + Set_Is_Immediately_Visible (E); + Set_Homonym (E, Prev); + Next_Entity (E); + end loop; + end Install_Declarations; + +end Sem_Ch9; |