diff options
Diffstat (limited to 'gcc-4.8.3/gcc/ada/sem_ch9.adb')
| -rw-r--r-- | gcc-4.8.3/gcc/ada/sem_ch9.adb | 3475 |
1 files changed, 3475 insertions, 0 deletions
diff --git a/gcc-4.8.3/gcc/ada/sem_ch9.adb b/gcc-4.8.3/gcc/ada/sem_ch9.adb new file mode 100644 index 000000000..16c011c5a --- /dev/null +++ b/gcc-4.8.3/gcc/ada/sem_ch9.adb @@ -0,0 +1,3475 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S E M _ C H 9 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2012, 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 3, 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 COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Aspects; use Aspects; +with Atree; use Atree; +with Checks; use Checks; +with Debug; use Debug; +with Einfo; use Einfo; +with Errout; use Errout; +with Exp_Ch9; use Exp_Ch9; +with Elists; use Elists; +with Freeze; use Freeze; +with Layout; use Layout; +with Lib.Xref; use Lib.Xref; +with Namet; use Namet; +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_Aux; use Sem_Aux; +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_Ch13; use Sem_Ch13; +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 Targparm; use Targparm; +with Tbuild; use Tbuild; +with Uintp; use Uintp; + +package body Sem_Ch9 is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Allows_Lock_Free_Implementation + (N : Node_Id; + Lock_Free_Given : Boolean := False) return Boolean; + -- This routine returns True iff N satisfies the following list of lock- + -- free restrictions for protected type declaration and protected body: + -- + -- 1) Protected type declaration + -- May not contain entries + -- Protected subprogram declarations may not have non-elementary + -- parameters. + -- + -- 2) Protected Body + -- Each protected subprogram body within N must satisfy: + -- May reference only one protected component + -- May not reference non-constant entities outside the protected + -- subprogram scope. + -- May not contain address representation items, allocators and + -- quantified expressions. + -- May not contain delay, goto, loop and procedure call + -- statements. + -- May not contain exported and imported entities + -- May not dereference access values + -- Function calls and attribute references must be static + -- + -- If Lock_Free_Given is True, an error message is issued when False is + -- returned. + + 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_Interfaces (N : Node_Id; T : Entity_Id); + -- 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. + + ------------------------------------- + -- Allows_Lock_Free_Implementation -- + ------------------------------------- + + function Allows_Lock_Free_Implementation + (N : Node_Id; + Lock_Free_Given : Boolean := False) return Boolean + is + Errors_Count : Nat; + -- Errors_Count is a count of errors detected by the compiler so far + -- when Lock_Free_Given is True. + + begin + pragma Assert (Nkind_In (N, N_Protected_Type_Declaration, + N_Protected_Body)); + + -- The lock-free implementation is currently enabled through a debug + -- flag. When Lock_Free_Given is True, an aspect Lock_Free forces the + -- lock-free implementation. In that case, the debug flag is not needed. + + if not Lock_Free_Given and then not Debug_Flag_9 then + return False; + end if; + + -- Get the number of errors detected by the compiler so far + + if Lock_Free_Given then + Errors_Count := Serious_Errors_Detected; + end if; + + -- Protected type declaration case + + if Nkind (N) = N_Protected_Type_Declaration then + declare + Pdef : constant Node_Id := Protected_Definition (N); + Priv_Decls : constant List_Id := Private_Declarations (Pdef); + Vis_Decls : constant List_Id := Visible_Declarations (Pdef); + Decl : Node_Id; + + begin + -- Examine the visible and the private declarations + + Decl := First (Vis_Decls); + while Present (Decl) loop + + -- Entries and entry families are not allowed by the lock-free + -- restrictions. + + if Nkind (Decl) = N_Entry_Declaration then + if Lock_Free_Given then + Error_Msg_N + ("entry not allowed when Lock_Free given", Decl); + else + return False; + end if; + + -- Non-elementary parameters in protected procedure are not + -- allowed by the lock-free restrictions. + + elsif Nkind (Decl) = N_Subprogram_Declaration + and then + Nkind (Specification (Decl)) = N_Procedure_Specification + and then + Present (Parameter_Specifications (Specification (Decl))) + then + declare + Par_Specs : constant List_Id := + Parameter_Specifications + (Specification (Decl)); + + Par : Node_Id; + + begin + Par := First (Par_Specs); + while Present (Par) loop + if not Is_Elementary_Type + (Etype (Defining_Identifier (Par))) + then + if Lock_Free_Given then + Error_Msg_NE + ("non-elementary parameter& not allowed " + & "when Lock_Free given", + Par, Defining_Identifier (Par)); + else + return False; + end if; + end if; + + Next (Par); + end loop; + end; + end if; + + -- Examine private declarations after visible declarations + + if No (Next (Decl)) + and then List_Containing (Decl) = Vis_Decls + then + Decl := First (Priv_Decls); + else + Next (Decl); + end if; + end loop; + end; + + -- Protected body case + + else + Protected_Body_Case : declare + Decls : constant List_Id := Declarations (N); + Pid : constant Entity_Id := Corresponding_Spec (N); + Prot_Typ_Decl : constant Node_Id := Parent (Pid); + Prot_Def : constant Node_Id := + Protected_Definition (Prot_Typ_Decl); + Priv_Decls : constant List_Id := + Private_Declarations (Prot_Def); + Decl : Node_Id; + + function Satisfies_Lock_Free_Requirements + (Sub_Body : Node_Id) return Boolean; + -- Return True if protected subprogram body Sub_Body satisfies all + -- requirements of a lock-free implementation. + + -------------------------------------- + -- Satisfies_Lock_Free_Requirements -- + -------------------------------------- + + function Satisfies_Lock_Free_Requirements + (Sub_Body : Node_Id) return Boolean + is + Is_Procedure : constant Boolean := + Ekind (Corresponding_Spec (Sub_Body)) = + E_Procedure; + -- Indicates if Sub_Body is a procedure body + + Comp : Entity_Id := Empty; + -- Track the current component which the body references + + Errors_Count : Nat; + -- Errors_Count is a count of errors detected by the compiler + -- so far when Lock_Free_Given is True. + + function Check_Node (N : Node_Id) return Traverse_Result; + -- Check that node N meets the lock free restrictions + + ---------------- + -- Check_Node -- + ---------------- + + function Check_Node (N : Node_Id) return Traverse_Result is + Kind : constant Node_Kind := Nkind (N); + + -- The following function belongs in sem_eval ??? + + function Is_Static_Function (Attr : Node_Id) return Boolean; + -- Given an attribute reference node Attr, return True if + -- Attr denotes a static function according to the rules in + -- (RM 4.9 (22)). + + ------------------------ + -- Is_Static_Function -- + ------------------------ + + function Is_Static_Function + (Attr : Node_Id) return Boolean + is + Para : Node_Id; + + begin + pragma Assert (Nkind (Attr) = N_Attribute_Reference); + + case Attribute_Name (Attr) is + when Name_Min | + Name_Max | + Name_Pred | + Name_Succ | + Name_Value | + Name_Wide_Value | + Name_Wide_Wide_Value => + + -- A language-defined attribute denotes a static + -- function if the prefix denotes a static scalar + -- subtype, and if the parameter and result types + -- are scalar (RM 4.9 (22)). + + if Is_Scalar_Type (Etype (Attr)) + and then Is_Scalar_Type (Etype (Prefix (Attr))) + and then Is_Static_Subtype (Etype (Prefix (Attr))) + then + Para := First (Expressions (Attr)); + + while Present (Para) loop + if not Is_Scalar_Type (Etype (Para)) then + return False; + end if; + + Next (Para); + end loop; + + return True; + + else + return False; + end if; + + when others => return False; + end case; + end Is_Static_Function; + + -- Start of processing for Check_Node + + begin + if Is_Procedure then + -- Allocators restricted + + if Kind = N_Allocator then + if Lock_Free_Given then + Error_Msg_N ("allocator not allowed", N); + return Skip; + end if; + + return Abandon; + + -- Aspects Address, Export and Import restricted + + elsif Kind = N_Aspect_Specification then + declare + Asp_Name : constant Name_Id := + Chars (Identifier (N)); + Asp_Id : constant Aspect_Id := + Get_Aspect_Id (Asp_Name); + + begin + if Asp_Id = Aspect_Address or else + Asp_Id = Aspect_Export or else + Asp_Id = Aspect_Import + then + Error_Msg_Name_1 := Asp_Name; + + if Lock_Free_Given then + Error_Msg_N ("aspect% not allowed", N); + return Skip; + end if; + + return Abandon; + end if; + end; + + -- Address attribute definition clause restricted + + elsif Kind = N_Attribute_Definition_Clause + and then Get_Attribute_Id (Chars (N)) = + Attribute_Address + then + Error_Msg_Name_1 := Chars (N); + + if Lock_Free_Given then + if From_Aspect_Specification (N) then + Error_Msg_N ("aspect% not allowed", N); + else + Error_Msg_N ("% clause not allowed", N); + end if; + + return Skip; + end if; + + return Abandon; + + -- Non-static Attribute references that don't denote a + -- static function restricted. + + elsif Kind = N_Attribute_Reference + and then not Is_Static_Expression (N) + and then not Is_Static_Function (N) + then + if Lock_Free_Given then + Error_Msg_N + ("non-static attribute reference not allowed", N); + return Skip; + end if; + + return Abandon; + + -- Delay statements restricted + + elsif Kind in N_Delay_Statement then + if Lock_Free_Given then + Error_Msg_N ("delay not allowed", N); + return Skip; + end if; + + return Abandon; + + -- Dereferences of access values restricted + + elsif Kind = N_Explicit_Dereference + or else (Kind = N_Selected_Component + and then Is_Access_Type (Etype (Prefix (N)))) + then + if Lock_Free_Given then + Error_Msg_N + ("dereference of access value not allowed", N); + return Skip; + end if; + + return Abandon; + + -- Non-static function calls restricted + + elsif Kind = N_Function_Call + and then not Is_Static_Expression (N) + then + if Lock_Free_Given then + Error_Msg_N + ("non-static function call not allowed", N); + return Skip; + end if; + + return Abandon; + + -- Goto statements restricted + + elsif Kind = N_Goto_Statement then + if Lock_Free_Given then + Error_Msg_N ("goto statement not allowed", N); + return Skip; + end if; + + return Abandon; + + -- References + + elsif Kind = N_Identifier + and then Present (Entity (N)) + then + declare + Id : constant Entity_Id := Entity (N); + Sub_Id : constant Entity_Id := + Corresponding_Spec (Sub_Body); + + begin + -- Prohibit references to non-constant entities + -- outside the protected subprogram scope. + + if Ekind (Id) in Assignable_Kind + and then not + Scope_Within_Or_Same (Scope (Id), Sub_Id) + and then not + Scope_Within_Or_Same + (Scope (Id), + Protected_Body_Subprogram (Sub_Id)) + then + if Lock_Free_Given then + Error_Msg_NE + ("reference to global variable& not " & + "allowed", N, Id); + return Skip; + end if; + + return Abandon; + end if; + end; + + -- Loop statements restricted + + elsif Kind = N_Loop_Statement then + if Lock_Free_Given then + Error_Msg_N ("loop not allowed", N); + return Skip; + end if; + + return Abandon; + + -- Pragmas Export and Import restricted + + elsif Kind = N_Pragma then + declare + Prag_Name : constant Name_Id := Pragma_Name (N); + Prag_Id : constant Pragma_Id := + Get_Pragma_Id (Prag_Name); + + begin + if Prag_Id = Pragma_Export + or else Prag_Id = Pragma_Import + then + Error_Msg_Name_1 := Prag_Name; + + if Lock_Free_Given then + if From_Aspect_Specification (N) then + Error_Msg_N ("aspect% not allowed", N); + else + Error_Msg_N ("pragma% not allowed", N); + end if; + + return Skip; + end if; + + return Abandon; + end if; + end; + + -- Procedure call statements restricted + + elsif Kind = N_Procedure_Call_Statement then + if Lock_Free_Given then + Error_Msg_N ("procedure call not allowed", N); + return Skip; + end if; + + return Abandon; + + -- Quantified expression restricted. Note that we have + -- to check the original node as well, since at this + -- stage, it may have been rewritten. + + elsif Kind = N_Quantified_Expression + or else + Nkind (Original_Node (N)) = N_Quantified_Expression + then + if Lock_Free_Given then + Error_Msg_N + ("quantified expression not allowed", N); + return Skip; + end if; + + return Abandon; + end if; + end if; + + -- A protected subprogram (function or procedure) may + -- reference only one component of the protected type, plus + -- the type of the component must support atomic operation. + + if Kind = N_Identifier + and then Present (Entity (N)) + then + declare + Id : constant Entity_Id := Entity (N); + Comp_Decl : Node_Id; + Comp_Id : Entity_Id := Empty; + Comp_Type : Entity_Id; + + begin + if Ekind (Id) = E_Component then + Comp_Id := Id; + + elsif Ekind_In (Id, E_Constant, E_Variable) + and then Present (Prival_Link (Id)) + then + Comp_Id := Prival_Link (Id); + end if; + + if Present (Comp_Id) then + Comp_Decl := Parent (Comp_Id); + Comp_Type := Etype (Comp_Id); + + if Nkind (Comp_Decl) = N_Component_Declaration + and then Is_List_Member (Comp_Decl) + and then List_Containing (Comp_Decl) = Priv_Decls + then + -- Skip generic types since, in that case, we + -- will not build a body anyway (in the generic + -- template), and the size in the template may + -- have a fake value. + + if not Is_Generic_Type (Comp_Type) then + + -- Make sure the protected component type has + -- size and alignment fields set at this + -- point whenever this is possible. + + Layout_Type (Comp_Type); + + if not + Support_Atomic_Primitives (Comp_Type) + then + if Lock_Free_Given then + Error_Msg_NE + ("type of& must support atomic " & + "operations", + N, Comp_Id); + return Skip; + end if; + + return Abandon; + end if; + end if; + + -- Check if another protected component has + -- already been accessed by the subprogram body. + + if No (Comp) then + Comp := Comp_Id; + + elsif Comp /= Comp_Id then + if Lock_Free_Given then + Error_Msg_N + ("only one protected component allowed", + N); + return Skip; + end if; + + return Abandon; + end if; + end if; + end if; + end; + end if; + + return OK; + end Check_Node; + + function Check_All_Nodes is new Traverse_Func (Check_Node); + + -- Start of processing for Satisfies_Lock_Free_Requirements + + begin + -- Get the number of errors detected by the compiler so far + + if Lock_Free_Given then + Errors_Count := Serious_Errors_Detected; + end if; + + if Check_All_Nodes (Sub_Body) = OK + and then (not Lock_Free_Given + or else Errors_Count = Serious_Errors_Detected) + then + -- Establish a relation between the subprogram body and the + -- unique protected component it references. + + if Present (Comp) then + Lock_Free_Subprogram_Table.Append + (Lock_Free_Subprogram'(Sub_Body, Comp)); + end if; + + return True; + else + return False; + end if; + end Satisfies_Lock_Free_Requirements; + + -- Start of processing for Protected_Body_Case + + begin + Decl := First (Decls); + while Present (Decl) loop + if Nkind (Decl) = N_Subprogram_Body + and then not Satisfies_Lock_Free_Requirements (Decl) + then + if Lock_Free_Given then + Error_Msg_N + ("illegal body when Lock_Free given", Decl); + else + return False; + end if; + end if; + + Next (Decl); + end loop; + end Protected_Body_Case; + end if; + + -- When Lock_Free is given, check if no error has been detected during + -- the process. + + if Lock_Free_Given + and then Errors_Count /= Serious_Errors_Detected + then + return False; + end if; + + return True; + end Allows_Lock_Free_Implementation; + + ----------------------------- + -- Analyze_Abort_Statement -- + ----------------------------- + + procedure Analyze_Abort_Statement (N : Node_Id) is + T_Name : Node_Id; + + begin + Tasking_Used := True; + Check_SPARK_Restriction ("abort statement is not allowed", N); + + 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_2005 + 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_2005 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; + + begin + Tasking_Used := True; + Check_SPARK_Restriction ("accept statement is not allowed", N); + + -- 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 + Push_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, Entry_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 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_Referenced_As_Out_Parameter (E, False); + Set_Has_Pragma_Unreferenced (E, False); + end if; + + Next_Entity (E); + end loop; + + -- Analyze statements if present + + if Present (Stats) then + Push_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 + Is_Disp_Select : Boolean := False; + Trigger : Node_Id; + + begin + Tasking_Used := True; + Check_SPARK_Restriction ("select statement is not allowed", N); + Check_Restriction (Max_Asynchronous_Select_Nesting, N); + Check_Restriction (No_Select_Statements, N); + + if Ada_Version >= Ada_2005 then + Trigger := Triggering_Statement (Triggering_Alternative (N)); + + Analyze (Trigger); + + -- Ada 2005 (AI-345): Check for a potential dispatching select + + Check_Triggering_Statement (Trigger, N, Is_Disp_Select); + 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; + + -- 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. + + else + Analyze_Statements (Statements (Abortable_Part (N))); + Analyze (Triggering_Alternative (N)); + end if; + end Analyze_Asynchronous_Select; + + ------------------------------------ + -- Analyze_Conditional_Entry_Call -- + ------------------------------------ + + 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 + Tasking_Used := True; + Check_SPARK_Restriction ("select statement is not allowed", N); + Check_Restriction (No_Select_Statements, N); + + -- Ada 2005 (AI-345): The trigger may be a dispatching call + + if Ada_Version >= Ada_2005 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); + Error_Msg_N + ("\`SELECT OR` may be intended rather than `SELECT ELSE`??!", N); + 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_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_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_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 + -- 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 + Preanalyze_And_Resolve (Expr, Standard_Duration); + else + Preanalyze_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 + Tasking_Used := True; + Check_SPARK_Restriction ("delay statement is not allowed", N); + Check_Restriction (No_Relative_Delay, N); + 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_SPARK_Restriction ("delay statement is not allowed", N); + 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; + E : Entity_Id; + Entry_Name : 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); + Push_Scope (Entry_Name); + + 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)); + + -- Add a declaration for the Protection object, renaming declarations + -- for the discriminals and privals and finally a declaration for the + -- entry family index (if applicable). + + if Full_Expander_Active + and then Is_Protected_Type (P_Type) + then + Install_Private_Data_Declarations + (Sloc (N), Entry_Name, P_Type, N, Decls); + end if; + + if Present (Decls) then + Analyze_Declarations (Decls); + Inspect_Deferred_Constant_Completion (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, but we include Has_Pragma_Unreferenced, + -- which may have been specified for a formal in the body. + + -- 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 don't worry 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_Has_Pragma_Unreferenced (E2, Has_Pragma_Unreferenced (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); + + -- The entry index functions like a loop variable, thus it is known + -- to have a valid value. + + Set_Is_Known_Valid (Defining_Identifier (Index)); + end if; + + if Present (Formals) then + Set_Scope (Id, Current_Scope); + Push_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; + Check_SPARK_Restriction ("entry call is not allowed", N); + + 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 + -- illegalities, such as procedure calls, are diagnosed after + -- resolution. + + Error_Msg_N ("entry call alternative requires an entry call", Call); + return; + end if; + + Analyze (Call); + + -- An indirect call in this context is illegal. A procedure call that + -- does not involve a renaming of an entry is illegal as well, but this + -- and other semantic errors are caught during resolution. + + if Nkind (Call) = N_Explicit_Dereference then + Error_Msg_N + ("entry call or dispatching primitive of interface required ", N); + end if; + + 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 + D_Sdef : constant Node_Id := Discrete_Subtype_Definition (N); + Def_Id : constant Entity_Id := Defining_Identifier (N); + Formals : constant List_Id := Parameter_Specifications (N); + + begin + Generate_Definition (Def_Id); + Set_Contract (Def_Id, Make_Contract (Sloc (Def_Id))); + Tasking_Used := True; + + -- Case of no discrete subtype definition + + if No (D_Sdef) then + Set_Ekind (Def_Id, E_Entry); + + -- Processing for discrete subtype definition present + + else + Enter_Name (Def_Id); + Set_Ekind (Def_Id, E_Entry_Family); + Analyze (D_Sdef); + Make_Index (D_Sdef, N, Def_Id); + + -- Check subtype with predicate in entry family + + Bad_Predicated_Subtype_Use + ("subtype& has predicate, not allowed in entry family", + D_Sdef, Etype (D_Sdef)); + + -- Check entry family static bounds outside allowed limits + + -- Note: originally this check was not performed here, but in that + -- case the check happens deep in the expander, and the message is + -- posted at the wrong location, and omitted in -gnatc mode. + -- If the type of the entry index is a generic formal, no check + -- is possible. In an instance, the check is not static and a run- + -- time exception will be raised if the bounds are unreasonable. + + declare + PEI : constant Entity_Id := RTE (RE_Protected_Entry_Index); + LB : constant Uint := Expr_Value (Type_Low_Bound (PEI)); + UB : constant Uint := Expr_Value (Type_High_Bound (PEI)); + + LBR : Node_Id; + UBR : Node_Id; + + begin + + -- No bounds checking if the type is generic or if previous error. + -- In an instance the check is dynamic. + + if Is_Generic_Type (Etype (D_Sdef)) + or else In_Instance + or else Error_Posted (D_Sdef) + then + goto Skip_LB; + + elsif Nkind (D_Sdef) = N_Range then + LBR := Low_Bound (D_Sdef); + + elsif Is_Entity_Name (D_Sdef) + and then Is_Type (Entity (D_Sdef)) + then + LBR := Type_Low_Bound (Entity (D_Sdef)); + + else + goto Skip_LB; + end if; + + if Is_Static_Expression (LBR) + and then Expr_Value (LBR) < LB + then + Error_Msg_Uint_1 := LB; + Error_Msg_N ("entry family low bound must be '>'= ^!", D_Sdef); + end if; + + <<Skip_LB>> + if Is_Generic_Type (Etype (D_Sdef)) + or else In_Instance + or else Error_Posted (D_Sdef) + then + goto Skip_UB; + + elsif Nkind (D_Sdef) = N_Range then + UBR := High_Bound (D_Sdef); + + elsif Is_Entity_Name (D_Sdef) + and then Is_Type (Entity (D_Sdef)) + then + UBR := Type_High_Bound (Entity (D_Sdef)); + + else + goto Skip_UB; + end if; + + if Is_Static_Expression (UBR) + and then Expr_Value (UBR) > UB + then + Error_Msg_Uint_1 := UB; + Error_Msg_N ("entry family high bound must be '<'= ^!", D_Sdef); + end if; + + <<Skip_UB>> + null; + end; + end if; + + -- Decorate Def_Id + + Set_Etype (Def_Id, Standard_Void_Type); + Set_Convention (Def_Id, Convention_Entry); + Set_Accept_Address (Def_Id, New_Elmt_List); + + -- Process formals + + if Present (Formals) then + Set_Scope (Def_Id, Current_Scope); + Push_Scope (Def_Id); + Process_Formals (Formals, N); + Create_Extra_Formals (Def_Id); + End_Scope; + end if; + + if Ekind (Def_Id) = E_Entry then + New_Overloaded_Entity (Def_Id); + end if; + + Generate_Reference_To_Formals (Def_Id); + + if Has_Aspects (N) then + Analyze_Aspect_Specifications (N, Def_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 known 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_Temporary (Sloc (N), '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); + Push_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). + + function Lock_Free_Disabled return Boolean; + -- This routine returns False if the protected object has a Lock_Free + -- aspect specification or a Lock_Free pragma that turns off the + -- lock-free implementation (e.g. whose expression is False). + + ------------------------ + -- Lock_Free_Disabled -- + ------------------------ + + function Lock_Free_Disabled return Boolean is + Ritem : constant Node_Id := + Get_Rep_Item + (Spec_Id, Name_Lock_Free, Check_Parents => False); + + begin + if Present (Ritem) then + + -- Pragma with one argument + + if Nkind (Ritem) = N_Pragma + and then Present (Pragma_Argument_Associations (Ritem)) + then + return + Is_False + (Static_Boolean + (Expression + (First (Pragma_Argument_Associations (Ritem))))); + + -- Aspect Specification with expression present + + elsif Nkind (Ritem) = N_Aspect_Specification + and then Present (Expression (Ritem)) + then + return Is_False (Static_Boolean (Expression (Ritem))); + + -- Otherwise, return False + + else + return False; + end if; + end if; + + return False; + end Lock_Free_Disabled; + + -- Start of processing for Analyze_Protected_Body + + 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; + + Push_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); + + 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; + + -- When a Lock_Free aspect specification/pragma forces the lock-free + -- implementation, verify the protected body meets all the restrictions, + -- otherwise Allows_Lock_Free_Implementation issues an error message. + + if Uses_Lock_Free (Spec_Id) then + if not Allows_Lock_Free_Implementation (N, True) then + return; + end if; + + -- In other cases, if there is no aspect specification/pragma that + -- disables the lock-free implementation, check both the protected + -- declaration and body satisfy the lock-free restrictions. + + elsif not Lock_Free_Disabled + and then Allows_Lock_Free_Implementation (Parent (Spec_Id)) + and then Allows_Lock_Free_Implementation (N) + then + Set_Uses_Lock_Free (Spec_Id); + end if; + end Analyze_Protected_Body; + + ---------------------------------- + -- Analyze_Protected_Definition -- + ---------------------------------- + + procedure Analyze_Protected_Definition (N : Node_Id) is + E : Entity_Id; + L : Entity_Id; + + procedure Undelay_Itypes (T : Entity_Id); + -- Itypes created for the private components of a protected type + -- do not receive freeze nodes, because there is no scope in which + -- they can be elaborated, and they can depend on discriminants of + -- the enclosed protected type. Given that the components can be + -- composite types with inner components, we traverse recursively + -- the private components of the protected type, and indicate that + -- all itypes within are frozen. This ensures that no freeze nodes + -- will be generated for them. + -- + -- On the other hand, components of the corresponding record are + -- frozen (or receive itype references) as for other records. + + -------------------- + -- Undelay_Itypes -- + -------------------- + + procedure Undelay_Itypes (T : Entity_Id) is + Comp : Entity_Id; + + begin + if Is_Protected_Type (T) then + Comp := First_Private_Entity (T); + elsif Is_Record_Type (T) then + Comp := First_Entity (T); + else + return; + end if; + + while Present (Comp) loop + if Is_Type (Comp) + and then Is_Itype (Comp) + then + Set_Has_Delayed_Freeze (Comp, False); + Set_Is_Frozen (Comp); + + if Is_Record_Type (Comp) + or else Is_Protected_Type (Comp) + then + Undelay_Itypes (Comp); + end if; + end if; + + Next_Entity (Comp); + end loop; + end Undelay_Itypes; + + -- Start of processing for Analyze_Protected_Definition + + begin + Tasking_Used := True; + Check_SPARK_Restriction ("protected definition is not allowed", N); + 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_In (E, E_Function, 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; + + Undelay_Itypes (Current_Scope); + + Check_Max_Entries (N, Max_Protected_Entries); + Process_End_Label (N, 'e', Current_Scope); + end Analyze_Protected_Definition; + + ---------------------------------------- + -- Analyze_Protected_Type_Declaration -- + ---------------------------------------- + + procedure Analyze_Protected_Type_Declaration (N : Node_Id) is + Def_Id : constant Entity_Id := Defining_Identifier (N); + E : Entity_Id; + T : Entity_Id; + + begin + if No_Run_Time_Mode then + Error_Msg_CRT ("protected type", N); + + if Has_Aspects (N) then + Analyze_Aspect_Specifications (N, Def_Id); + end if; + + return; + end if; + + Tasking_Used := True; + Check_Restriction (No_Protected_Types, N); + + T := Find_Type_Name (N); + + -- In the case of an incomplete type, use the full view, unless it's not + -- present (as can occur for an incomplete view from a limited with). + + if Ekind (T) = E_Incomplete_Type and then Present (Full_View (T)) 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); + Push_Scope (T); + + if Ada_Version >= Ada_2005 then + Check_Interfaces (N, T); + 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)); + + -- If aspects are present, analyze them now. They can make references + -- to the discriminants of the type, but not to any components. + + if Has_Aspects (N) then + Analyze_Aspect_Specifications (N, Def_Id); + end if; + + Analyze (Protected_Definition (N)); + + -- In the case where the protected type is declared at a nested level + -- and the No_Local_Protected_Objects restriction applies, issue a + -- warning that objects of the type will violate the restriction. + + if Restriction_Check_Required (No_Local_Protected_Objects) + and then not Is_Library_Level_Entity (T) + and then Comes_From_Source (T) + then + Error_Msg_Sloc := Restrictions_Loc (No_Local_Protected_Objects); + + if Error_Msg_Sloc = No_Location then + Error_Msg_N + ("objects of this type will violate " & + "`No_Local_Protected_Objects`??", N); + else + Error_Msg_N + ("objects of this type will violate " & + "`No_Local_Protected_Objects`#??", N); + end if; + end if; + + -- 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; + + -- When a Lock_Free aspect forces the lock-free implementation, check N + -- meets all the lock-free restrictions. Otherwise, an error message is + -- issued by Allows_Lock_Free_Implementation. + + if Uses_Lock_Free (Defining_Identifier (N)) then + + -- Complain when there is an explicit aspect/pragma Priority (or + -- Interrupt_Priority) while the lock-free implementation is forced + -- by an aspect/pragma. + + declare + Id : constant Entity_Id := Defining_Identifier (Original_Node (N)); + -- The warning must be issued on the original identifier in order + -- to deal properly with the case of a single protected object. + + Prio_Item : constant Node_Id := + Get_Rep_Item (Def_Id, Name_Priority, False); + + begin + if Present (Prio_Item) then + + -- Aspect case + + if Nkind (Prio_Item) = N_Aspect_Specification + or else From_Aspect_Specification (Prio_Item) + then + Error_Msg_Name_1 := Chars (Identifier (Prio_Item)); + Error_Msg_NE ("aspect% for & has no effect when Lock_Free" & + " given??", Prio_Item, Id); + + -- Pragma case + + else + Error_Msg_Name_1 := Pragma_Name (Prio_Item); + Error_Msg_NE ("pragma% for & has no effect when Lock_Free" & + " given??", Prio_Item, Id); + end if; + end if; + end; + + if not Allows_Lock_Free_Implementation (N, True) then + return; + end if; + end if; + + -- If the Attach_Handler aspect is specified or the Interrupt_Handler + -- aspect is True, then the initial ceiling priority must be in the + -- range of System.Interrupt_Priority. It is therefore recommanded + -- to use the Interrupt_Priority aspect instead of the Priority aspect. + + if Has_Interrupt_Handler (T) or else Has_Attach_Handler (T) then + declare + Prio_Item : constant Node_Id := + Get_Rep_Item (Def_Id, Name_Priority, False); + + begin + if Present (Prio_Item) then + + -- Aspect case + + if (Nkind (Prio_Item) = N_Aspect_Specification + or else From_Aspect_Specification (Prio_Item)) + and then Chars (Identifier (Prio_Item)) = Name_Priority + then + Error_Msg_N ("aspect Interrupt_Priority is preferred " + & "in presence of handlers??", Prio_Item); + + -- Pragma case + + elsif Nkind (Prio_Item) = N_Pragma + and then Pragma_Name (Prio_Item) = Name_Priority + then + Error_Msg_N ("pragma Interrupt_Priority is preferred " + & "in presence of handlers??", Prio_Item); + end if; + end if; + end; + end if; + + -- Case of a completion of a private declaration + + if T /= Def_Id and then Is_Private_Type (Def_Id) then + + -- Deal with preelaborable initialization. Note that this processing + -- is done by Process_Full_View, but as can be seen below, in this + -- case the call to Process_Full_View is skipped if any serious + -- errors have occurred, and we don't want to lose this check. + + if Known_To_Have_Preelab_Init (Def_Id) then + Set_Must_Have_Preelab_Init (T); + end if; + + -- Create corresponding record now, because some private dependents + -- may be subtypes of the partial view. + + -- Skip if errors are present, to prevent cascaded messages + + if Serious_Errors_Detected = 0 + + -- Also skip if expander is not active + + and then Full_Expander_Active + then + Expand_N_Protected_Type_Declaration (N); + Process_Full_View (N, T, Def_Id); + end if; + end if; + end Analyze_Protected_Type_Declaration; + + --------------------- + -- 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; + Is_Disp_Req : Boolean; + It : Interp; + Enclosing : Entity_Id; + Target_Obj : Node_Id := Empty; + Req_Scope : Entity_Id; + Outer_Ent : Entity_Id; + Synch_Type : Entity_Id; + + begin + Tasking_Used := True; + Check_SPARK_Restriction ("requeue statement is not allowed", N); + Check_Restriction (No_Requeue_Statements, N); + Check_Unreachable_Code (N); + + Enclosing := Empty; + for J in reverse 0 .. Scope_Stack.Last loop + Enclosing := Scope_Stack.Table (J).Entity; + exit when Is_Entry (Enclosing); + + if not Ekind_In (Enclosing, E_Block, 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; + + -- 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 + + -- 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. + + 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; + + -- Ada 2012 (AI05-0030): Potential dispatching requeue statement. The + -- target type must be a concurrent interface class-wide type and the + -- target must be a procedure, flagged by pragma Implemented. The + -- target may be an access to class-wide type, in which case it must + -- be dereferenced. + + if Present (Target_Obj) then + Synch_Type := Etype (Target_Obj); + + if Is_Access_Type (Synch_Type) then + Synch_Type := Designated_Type (Synch_Type); + end if; + end if; + + Is_Disp_Req := + Ada_Version >= Ada_2012 + and then Present (Target_Obj) + and then Is_Class_Wide_Type (Synch_Type) + and then Is_Concurrent_Interface (Synch_Type) + and then Ekind (Entry_Id) = E_Procedure + and then Has_Rep_Pragma (Entry_Id, Name_Implemented); + + -- 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) + 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 + 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 + if VM_Target = JVM_Target then + Error_Msg_N + ("arguments unsupported in requeue statement", + First_Formal (Entry_Id)); + return; + end if; + + -- Ada 2012 (AI05-0030): Perform type conformance after skipping + -- the first parameter of Entry_Id since it is the interface + -- controlling formal. + + if Ada_Version >= Ada_2012 and then 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 + + 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_In (Ent, E_Out_Parameter, 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; + + -- AI05-0225: the target protected object of a requeue must be a + -- variable. This is a binding interpretation that applies to all + -- versions of the language. + + if Present (Target_Obj) + and then Ekind (Scope (Entry_Id)) in Protected_Kind + and then not Is_Variable (Target_Obj) + then + Error_Msg_N + ("target protected object of requeue must be a variable", N); + 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 + Tasking_Used := True; + Check_SPARK_Restriction ("select statement is not allowed", N); + Check_Restriction (No_Select_Statements, N); + + -- 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_Declaration -- + ------------------------------------------ + + procedure Analyze_Single_Protected_Declaration (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 := 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_Declaration (N); + end Analyze_Single_Protected_Declaration; + + ------------------------------------- + -- Analyze_Single_Task_Declaration -- + ------------------------------------- + + procedure Analyze_Single_Task_Declaration (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 := 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)); + + -- We use the original defining identifier of the single task in the + -- generated object declaration, so that debugging information can + -- be attached to it when compiling with -gnatD. The parent of the + -- entity is the new object declaration. The single_task_declaration + -- is not used further in semantics or code generation, but is scanned + -- when generating debug information, and therefore needs the updated + -- Sloc information for the entity (see Sprint). Aspect specifications + -- are moved from the single task node to the object declaration node. + + 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_Declaration (N); + + if Has_Aspects (N) then + Analyze_Aspect_Specifications (N, Id); + end if; + end Analyze_Single_Task_Declaration; + + ----------------------- + -- Analyze_Task_Body -- + ----------------------- + + procedure Analyze_Task_Body (N : Node_Id) is + Body_Id : constant Entity_Id := Defining_Identifier (N); + Decls : constant List_Id := Declarations (N); + HSS : constant Node_Id := Handled_Statement_Sequence (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; + + Push_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 (Decls); + Inspect_Deferred_Constant_Completion (Decls); + + -- 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; + + -- Mark all handlers as not suitable for local raise optimization, + -- since this optimization causes difficulties in a task context. + + if Present (Exception_Handlers (HSS)) then + declare + Handlr : Node_Id; + begin + Handlr := First (Exception_Handlers (HSS)); + while Present (Handlr) loop + Set_Local_Raise_Not_OK (Handlr); + Next (Handlr); + end loop; + end; + end if; + + -- Now go ahead and complete analysis of the task body + + Analyze (HSS); + 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 (HSS, '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; + Check_SPARK_Restriction ("task definition is not allowed", N); + + 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); + end Analyze_Task_Definition; + + ----------------------------------- + -- Analyze_Task_Type_Declaration -- + ----------------------------------- + + procedure Analyze_Task_Type_Declaration (N : Node_Id) is + Def_Id : constant Entity_Id := Defining_Identifier (N); + T : Entity_Id; + + begin + Check_Restriction (No_Tasking, N); + Tasking_Used := True; + T := Find_Type_Name (N); + Generate_Definition (T); + + -- In the case of an incomplete type, use the full view, unless it's not + -- present (as can occur for an incomplete view from a limited with). + -- Initialize the Corresponding_Record_Type (which overlays the Private + -- Dependents field of the incomplete view). + + if Ekind (T) = E_Incomplete_Type then + if Present (Full_View (T)) then + T := Full_View (T); + Set_Completion_Referenced (T); + + else + Set_Ekind (T, E_Task_Type); + Set_Corresponding_Record_Type (T, Empty); + end if; + 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); + Push_Scope (T); + + if Ada_Version >= Ada_2005 then + Check_Interfaces (N, T); + 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 Has_Aspects (N) then + Analyze_Aspect_Specifications (N, Def_Id); + end if; + + if Present (Task_Definition (N)) then + Analyze_Task_Definition (Task_Definition (N)); + end if; + + -- In the case where the task type is declared at a nested level and the + -- No_Task_Hierarchy restriction applies, issue a warning that objects + -- of the type will violate the restriction. + + if Restriction_Check_Required (No_Task_Hierarchy) + and then not Is_Library_Level_Entity (T) + and then Comes_From_Source (T) + then + Error_Msg_Sloc := Restrictions_Loc (No_Task_Hierarchy); + + if Error_Msg_Sloc = No_Location then + Error_Msg_N + ("objects of this type will violate `No_Task_Hierarchy`??", N); + else + Error_Msg_N + ("objects of this type will violate `No_Task_Hierarchy`#??", N); + end if; + end if; + + End_Scope; + + -- Case of a completion of a private declaration + + if T /= Def_Id + and then Is_Private_Type (Def_Id) + then + -- Deal with preelaborable initialization. Note that this processing + -- is done by Process_Full_View, but as can be seen below, in this + -- case the call to Process_Full_View is skipped if any serious + -- errors have occurred, and we don't want to lose this check. + + if Known_To_Have_Preelab_Init (Def_Id) then + Set_Must_Have_Preelab_Init (T); + end if; + + -- Create corresponding record now, because some private dependents + -- may be subtypes of the partial view. + + -- Skip if errors are present, to prevent cascaded messages + + if Serious_Errors_Detected = 0 + + -- Also skip if expander is not active + + and then Full_Expander_Active + then + Expand_N_Task_Type_Declaration (N); + Process_Full_View (N, T, Def_Id); + end if; + end if; + end Analyze_Task_Type_Declaration; + + ----------------------------------- + -- 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 + Trigger : constant Node_Id := + Entry_Call_Statement (Entry_Call_Alternative (N)); + Is_Disp_Select : Boolean := False; + + begin + Tasking_Used := True; + Check_SPARK_Restriction ("select statement is not allowed", N); + Check_Restriction (No_Select_Statements, N); + + -- Ada 2005 (AI-345): The trigger may be a dispatching call + + if Ada_Version >= Ada_2005 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; + + ------------------------------------ + -- 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_2005 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 procedure_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 + -- Record an unknown count restriction, and if the + -- restriction is active, post a message or warning. + + Check_Restriction (R, D); + 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_Interfaces -- + ---------------------- + + procedure Check_Interfaces (N : Node_Id; T : Entity_Id) is + Iface : Node_Id; + Iface_Typ : Entity_Id; + + begin + pragma Assert + (Nkind_In (N, N_Protected_Type_Declaration, N_Task_Type_Declaration)); + + 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); + + 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)); + + if Nkind (N) = N_Protected_Type_Declaration then + + -- Ada 2005 (AI-345): Protected types can only implement + -- limited, synchronized, or protected interfaces (note that + -- the predicate Is_Limited_Interface includes synchronized + -- and protected interfaces). + + if Is_Task_Interface (Iface_Typ) then + Error_Msg_N ("(Ada 2005) protected type cannot implement " + & "a task interface", Iface); + + elsif not Is_Limited_Interface (Iface_Typ) then + Error_Msg_N ("(Ada 2005) protected type cannot implement " + & "a non-limited interface", Iface); + end if; + + else pragma Assert (Nkind (N) = N_Task_Type_Declaration); + + -- Ada 2005 (AI-345): Task types can only implement limited, + -- synchronized, or task interfaces (note that the predicate + -- Is_Limited_Interface includes synchronized and task + -- interfaces). + + if Is_Protected_Interface (Iface_Typ) then + Error_Msg_N ("(Ada 2005) task type cannot implement a " & + "protected interface", Iface); + + elsif not Is_Limited_Interface (Iface_Typ) then + Error_Msg_N ("(Ada 2005) task type cannot implement a " & + "non-limited interface", Iface); + end if; + end if; + end if; + + Next (Iface); + end loop; + end if; + + if not Has_Private_Declaration (T) then + return; + end if; + + -- Additional checks on full-types associated with private type + -- declarations. Search for the private type declaration. + + declare + Full_T_Ifaces : Elist_Id; + Iface : Node_Id; + Priv_T : Entity_Id; + Priv_T_Ifaces : Elist_Id; + + begin + Priv_T := First_Entity (Scope (T)); + loop + pragma Assert (Present (Priv_T)); + + if Is_Type (Priv_T) and then Present (Full_View (Priv_T)) then + exit when Full_View (Priv_T) = T; + end if; + + Next_Entity (Priv_T); + end loop; + + -- In case of synchronized types covering interfaces the private type + -- declaration must be limited. + + if Present (Interface_List (N)) + and then not Is_Limited_Type (Priv_T) + then + Error_Msg_Sloc := Sloc (Priv_T); + Error_Msg_N ("(Ada 2005) limited type declaration expected for " & + "private type#", T); + end if; + + -- RM 7.3 (7.1/2): If the full view has a partial view that is + -- tagged then check RM 7.3 subsidiary rules. + + if Is_Tagged_Type (Priv_T) + and then not Error_Posted (N) + then + -- RM 7.3 (7.2/2): The partial view shall be a synchronized tagged + -- type if and only if the full type is a synchronized tagged type + + if Is_Synchronized_Tagged_Type (Priv_T) + and then not Is_Synchronized_Tagged_Type (T) + then + Error_Msg_N + ("(Ada 2005) full view must be a synchronized tagged " & + "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 (RM 7.3 (7.2/2))", T); + end if; + + -- RM 7.3 (7.3/2): The partial view shall be a descendant of an + -- interface type if and only if the full type is descendant of + -- the interface type. + + if Present (Interface_List (N)) + or else (Is_Tagged_Type (Priv_T) + and then Has_Interfaces + (Priv_T, Use_Full_View => False)) + then + if Is_Tagged_Type (Priv_T) then + Collect_Interfaces + (Priv_T, Priv_T_Ifaces, Use_Full_View => False); + end if; + + if Is_Tagged_Type (T) then + Collect_Interfaces (T, Full_T_Ifaces); + end if; + + Iface := Find_Hidden_Interface (Priv_T_Ifaces, Full_T_Ifaces); + + if Present (Iface) then + Error_Msg_NE + ("interface & not implemented by full type " & + "(RM-2005 7.3 (7.3/2))", Priv_T, Iface); + end if; + + Iface := Find_Hidden_Interface (Full_T_Ifaces, Priv_T_Ifaces); + + if Present (Iface) then + Error_Msg_NE + ("interface & not implemented by partial " & + "view (RM-2005 7.3 (7.3/2))", T, Iface); + end if; + end if; + end if; + 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_2005 + 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; + + elsif Nkind (Trigger) = N_Explicit_Dereference then + Error_Msg_N + ("entry call or dispatching primitive of interface required ", + Trigger); + end if; + end if; + end Check_Triggering_Statement; + + -------------------------- + -- 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; + + --------------------------- + -- Install_Discriminants -- + --------------------------- + + procedure Install_Discriminants (E : Entity_Id) is + Disc : Entity_Id; + Prev : Entity_Id; + begin + Disc := First_Discriminant (E); + while Present (Disc) loop + Prev := Current_Entity (Disc); + Set_Current_Entity (Disc); + Set_Is_Immediately_Visible (Disc); + Set_Homonym (Disc, Prev); + Next_Discriminant (Disc); + end loop; + end Install_Discriminants; + + ------------------------------------------ + -- Push_Scope_And_Install_Discriminants -- + ------------------------------------------ + + procedure Push_Scope_And_Install_Discriminants (E : Entity_Id) is + begin + if Has_Discriminants (E) then + Push_Scope (E); + Install_Discriminants (E); + end if; + end Push_Scope_And_Install_Discriminants; + + ----------------------------- + -- Uninstall_Discriminants -- + ----------------------------- + + procedure Uninstall_Discriminants (E : Entity_Id) is + Disc : Entity_Id; + Prev : Entity_Id; + Outer : Entity_Id; + + begin + Disc := First_Discriminant (E); + while Present (Disc) loop + if Disc /= Current_Entity (Disc) then + Prev := Current_Entity (Disc); + while Present (Prev) + and then Present (Homonym (Prev)) + and then Homonym (Prev) /= Disc + loop + Prev := Homonym (Prev); + end loop; + else + Prev := Empty; + end if; + + Set_Is_Immediately_Visible (Disc, False); + + Outer := Homonym (Disc); + while Present (Outer) and then Scope (Outer) = E loop + Outer := Homonym (Outer); + end loop; + + -- Reset homonym link of other entities, but do not modify link + -- between entities in current scope, so that the back-end can have + -- a proper count of local overloadings. + + if No (Prev) then + Set_Name_Entity_Id (Chars (Disc), Outer); + + elsif Scope (Prev) /= Scope (Disc) then + Set_Homonym (Prev, Outer); + end if; + + Next_Discriminant (Disc); + end loop; + end Uninstall_Discriminants; + + ------------------------------------------- + -- Uninstall_Discriminants_And_Pop_Scope -- + ------------------------------------------- + + procedure Uninstall_Discriminants_And_Pop_Scope (E : Entity_Id) is + begin + if Has_Discriminants (E) then + Uninstall_Discriminants (E); + Pop_Scope; + end if; + end Uninstall_Discriminants_And_Pop_Scope; +end Sem_Ch9; |