------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- S E M _ C H 9 -- -- -- -- B o d y -- -- -- -- Copyright (C) 1992-2018, 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 Contracts; use Contracts; 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; use Lib; 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_Elab; use Sem_Elab; with Sem_Eval; use Sem_Eval; with Sem_Prag; use Sem_Prag; with Sem_Res; use Sem_Res; with Sem_Type; use Sem_Type; with Sem_Util; use Sem_Util; with Sem_Warn; use Sem_Warn; with Snames; use Snames; with Stand; use Stand; with Sinfo; use Sinfo; with Style; with Tbuild; use Tbuild; with Uintp; use Uintp; package body Sem_Ch9 is ----------------------- -- Local Subprograms -- ----------------------- 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 := 0; -- 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 := 0; -- 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_Max | Name_Min | 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_OK_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_OK_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_OK_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_05_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 := Empty; -- initialize to prevent warning begin Tasking_Used := True; Check_SPARK_05_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_Compilation_Unit | N_Task_Body => 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_05_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_05_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_05_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); -- In SPARK mode the relative delay statement introduces an implicit -- dependency on the Ada.Real_Time.Clock_Time abstract state, so we must -- force the loading of the Ada.Real_Time package. if GNATprove_Mode then SPARK_Implicit_Load (RO_RT_Time); end if; 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_05_Restriction ("delay statement is not allowed", N); Check_Restriction (No_Delay, N); Check_Potentially_Blocking_Operation (N); Analyze_And_Resolve (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 -- An entry body freezes the contract of the nearest enclosing package -- body and all other contracts encountered in the same declarative part -- up to and excluding the entry body. This ensures that any annotations -- referenced by the contract of an entry or subprogram body declared -- within the current protected body are available. Freeze_Previous_Contracts (N); 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_Etype (Id, Standard_Void_Type); Set_Scope (Id, Current_Scope); Set_Accept_Address (Id, New_Elmt_List); -- Set the SPARK_Mode from the current context (may be overwritten later -- with an explicit pragma). Set_SPARK_Pragma (Id, SPARK_Mode_Pragma); Set_SPARK_Pragma_Inherited (Id); -- Analyze any aspect specifications that appear on the entry body if Has_Aspects (N) then Analyze_Aspects_On_Subprogram_Body_Or_Stub (N); end if; 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 (E), 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 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; -- Process the contract of the subprogram body after all declarations -- have been analyzed. This ensures that any contract-related pragmas -- are available through the N_Contract node of the body. Analyze_Entry_Or_Subprogram_Body_Contract (Id); 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)); <> 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); Update_Use_Clause_Chain; 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_05_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); 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_OK_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; <> 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_OK_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; <> 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); -- Set the SPARK_Mode from the current context (may be overwritten later -- with an explicit pragma). Task entries are excluded because they are -- not completed by entry bodies. if Ekind (Current_Scope) = E_Protected_Type then Set_SPARK_Pragma (Def_Id, SPARK_Mode_Pragma); Set_SPARK_Pragma_Inherited (Def_Id); end if; -- Preserve relevant elaboration-related attributes of the context which -- are no longer available or very expensive to recompute once analysis, -- resolution, and expansion are over. Mark_Elaboration_Attributes (N_Id => Def_Id, Checks => True, Warnings => True); -- 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 its 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 -- A protected body freezes the contract of the nearest enclosing -- package body and all other contracts encountered in the same -- declarative part up to and excluding the protected body. This -- ensures that any annotations referenced by the contract of an -- entry or subprogram body declared within the current protected -- body are available. Freeze_Previous_Contracts (N); Tasking_Used := True; Set_Ekind (Body_Id, E_Protected_Body); Set_Etype (Body_Id, Standard_Void_Type); 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; if Has_Aspects (N) then Analyze_Aspect_Specifications (N, Body_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); Update_Use_Clause_Chain; 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. In the case of itypes that are access -- types we need to complete their representation by calling layout, -- which would otherwise be invoked when freezing a type. -- -- 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_Access_Type (Comp) then Layout_Type (Comp); end if; 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_05_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); else Propagate_Concurrent_Flags (Current_Scope, Etype (E)); 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); Init_Size_Align (T); Set_Etype (T, T); Set_Has_Delayed_Freeze (T); Set_Stored_Constraint (T, No_Elist); -- Mark this type as a protected type for the sake of restrictions, -- unless the protected type is declared in a private part of a package -- of the runtime. With this exception, the Suspension_Object from -- Ada.Synchronous_Task_Control can be implemented using a protected -- object without triggering violations of No_Local_Protected_Objects -- when the user locally declares such an object. This may look like a -- trick, but the user doesn't have to know how Suspension_Object is -- implemented. if In_Private_Part (Current_Scope) and then Is_Internal_Unit (Current_Sem_Unit) then Set_Has_Protected (T, False); else Set_Has_Protected (T); end if; -- Set the SPARK_Mode from the current context (may be overwritten later -- with an explicit pragma). Set_SPARK_Pragma (T, SPARK_Mode_Pragma); Set_SPARK_Aux_Pragma (T, SPARK_Mode_Pragma); Set_SPARK_Pragma_Inherited (T); Set_SPARK_Aux_Pragma_Inherited (T); 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 -- The protected type is the full view of a private type. Analyze the -- aspects with the entity of the private type to ensure that after -- both views are exchanged, the aspect are actually associated with -- the full view. if T /= Def_Id and then Is_Private_Type (Def_Id) then Analyze_Aspect_Specifications (N, T); else Analyze_Aspect_Specifications (N, Def_Id); end if; 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 not Restricted_Profile 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, Lock_Free_Given => 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; -- Propagate Default_Initial_Condition-related attributes from the -- private type to the protected type. Propagate_DIC_Attributes (T, From_Typ => Def_Id); -- Propagate invariant-related attributes from the private type to -- the protected type. Propagate_Invariant_Attributes (T, From_Typ => Def_Id); -- 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 Expander_Active then Expand_N_Protected_Type_Declaration (N); Process_Full_View (N, T, Def_Id); end if; end if; -- In GNATprove mode, force the loading of a Interrupt_Priority, which -- is required for the ceiling priority protocol checks triggered by -- calls originating from protected subprograms and entries. if GNATprove_Mode then SPARK_Implicit_Load (RE_Interrupt_Priority); 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 := Empty; begin -- Preserve relevant elaboration-related attributes of the context which -- are no longer available or very expensive to recompute once analysis, -- resolution, and expansion are over. Mark_Elaboration_Attributes (N_Id => N, Checks => True, Modes => True, Warnings => True); Tasking_Used := True; Check_SPARK_05_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 -- 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. Note that the subprogram does not have -- to be a protected operation: it can be an primitive implemented -- by entry with a formal that is a protected interface. if Present (Target_Obj) and then not Is_Variable (Target_Obj) then Error_Msg_N ("target protected object of requeue must be a variable", N); end if; -- A requeue statement is treated as a call for purposes of ABE checks -- and diagnostics. Annotate the tree by creating a call marker in case -- the requeue statement is transformed by expansion. Build_Call_Marker (N); 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_05_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); Obj_Id : constant Node_Id := Defining_Identifier (N); Obj_Decl : Node_Id; Typ : Entity_Id; begin Generate_Definition (Obj_Id); Tasking_Used := True; -- A single protected declaration is transformed into a pair of an -- anonymous protected type and an object of that type. Generate: -- protected type Typ is ...; Typ := Make_Defining_Identifier (Sloc (Obj_Id), Chars => New_External_Name (Chars (Obj_Id), 'T')); Rewrite (N, Make_Protected_Type_Declaration (Loc, Defining_Identifier => Typ, Protected_Definition => Relocate_Node (Protected_Definition (N)), Interface_List => Interface_List (N))); -- Use the original defining identifier of the single protected -- declaration in the generated object declaration to allow for debug -- information to be attached to it when compiling with -gnatD. The -- parent of the entity is the new object declaration. The single -- protected declaration is not used in semantics or code generation, -- but is scanned when generating debug information, and therefore needs -- the updated Sloc information from the entity (see Sprint). Generate: -- Obj : Typ; Obj_Decl := Make_Object_Declaration (Loc, Defining_Identifier => Obj_Id, Object_Definition => New_Occurrence_Of (Typ, Loc)); Insert_After (N, Obj_Decl); Mark_Rewrite_Insertion (Obj_Decl); -- Relocate aspect Part_Of from the the original single protected -- declaration to the anonymous object declaration. This emulates the -- placement of an equivalent source pragma. Move_Or_Merge_Aspects (N, To => Obj_Decl); -- Relocate pragma Part_Of from the visible declarations of the original -- single protected declaration to the anonymous object declaration. The -- new placement better reflects the role of the pragma. Relocate_Pragmas_To_Anonymous_Object (N, Obj_Decl); -- Enter the names of the anonymous protected type and the object before -- analysis takes places, because the name of the object may be used in -- its own body. Enter_Name (Typ); Set_Ekind (Typ, E_Protected_Type); Set_Etype (Typ, Typ); Set_Anonymous_Object (Typ, Obj_Id); Enter_Name (Obj_Id); Set_Ekind (Obj_Id, E_Variable); Set_Etype (Obj_Id, Typ); Set_SPARK_Pragma (Obj_Id, SPARK_Mode_Pragma); Set_SPARK_Pragma_Inherited (Obj_Id); -- 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); if Has_Aspects (N) then Analyze_Aspect_Specifications (N, Obj_Id); end if; end Analyze_Single_Protected_Declaration; ------------------------------------- -- Analyze_Single_Task_Declaration -- ------------------------------------- procedure Analyze_Single_Task_Declaration (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); Obj_Id : constant Node_Id := Defining_Identifier (N); Obj_Decl : Node_Id; Typ : Entity_Id; begin Generate_Definition (Obj_Id); Tasking_Used := True; -- A single task declaration is transformed into a pair of an anonymous -- task type and an object of that type. Generate: -- task type Typ is ...; Typ := Make_Defining_Identifier (Sloc (Obj_Id), Chars => New_External_Name (Chars (Obj_Id), Suffix => "TK")); Rewrite (N, Make_Task_Type_Declaration (Loc, Defining_Identifier => Typ, Task_Definition => Relocate_Node (Task_Definition (N)), Interface_List => Interface_List (N))); -- Use the original defining identifier of the single task declaration -- in the generated object declaration to allow for debug information -- to 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 in semantics or code generation, but is scanned when -- generating debug information, and therefore needs the updated Sloc -- information from the entity (see Sprint). Generate: -- Obj : Typ; Obj_Decl := Make_Object_Declaration (Loc, Defining_Identifier => Obj_Id, Object_Definition => New_Occurrence_Of (Typ, Loc)); Insert_After (N, Obj_Decl); Mark_Rewrite_Insertion (Obj_Decl); -- Relocate aspects Depends, Global and Part_Of from the original single -- task declaration to the anonymous object declaration. This emulates -- the placement of an equivalent source pragma. Move_Or_Merge_Aspects (N, To => Obj_Decl); -- Relocate pragmas Depends, Global and Part_Of from the visible -- declarations of the original single protected declaration to the -- anonymous object declaration. The new placement better reflects the -- role of the pragmas. Relocate_Pragmas_To_Anonymous_Object (N, Obj_Decl); -- Enter the names of the anonymous task type and the object before -- analysis takes places, because the name of the object may be used -- in its own body. Enter_Name (Typ); Set_Ekind (Typ, E_Task_Type); Set_Etype (Typ, Typ); Set_Anonymous_Object (Typ, Obj_Id); Enter_Name (Obj_Id); Set_Ekind (Obj_Id, E_Variable); Set_Etype (Obj_Id, Typ); Set_SPARK_Pragma (Obj_Id, SPARK_Mode_Pragma); Set_SPARK_Pragma_Inherited (Obj_Id); -- Preserve relevant elaboration-related attributes of the context which -- are no longer available or very expensive to recompute once analysis, -- resolution, and expansion are over. Mark_Elaboration_Attributes (N_Id => Obj_Id, Checks => True, Warnings => True); -- 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, Obj_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 -- A task body freezes the contract of the nearest enclosing package -- body and all other contracts encountered in the same declarative part -- up to and excluding the task body. This ensures that annotations -- referenced by the contract of an entry or subprogram body declared -- within the current protected body are available. Freeze_Previous_Contracts (N); Tasking_Used := True; Set_Scope (Body_Id, Current_Scope); Set_Ekind (Body_Id, E_Task_Body); Set_Etype (Body_Id, Standard_Void_Type); 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; -- Set the SPARK_Mode from the current context (may be overwritten later -- with an explicit pragma). Set_SPARK_Pragma (Body_Id, SPARK_Mode_Pragma); Set_SPARK_Pragma_Inherited (Body_Id); if Has_Aspects (N) then Analyze_Aspect_Specifications (N, Body_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); Update_Use_Clause_Chain; 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_05_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 -- Attempt to use tasking in no run time mode is not allowe. Issue hard -- error message to disable expansion which leads to crashes. if Opt.No_Run_Time_Mode then Error_Msg_N ("tasking not allowed in No_Run_Time mode", N); -- Otherwise soft check for no tasking restriction else Check_Restriction (No_Tasking, N); end if; -- Proceed ahead with analysis of task type declaration Tasking_Used := True; -- The sequential partition elaboration policy is supported only in the -- restricted profile. if Partition_Elaboration_Policy = 'S' and then not Restricted_Profile then Error_Msg_N ("sequential elaboration supported only in restricted profile", N); end if; 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); -- Set the SPARK_Mode from the current context (may be overwritten later -- with an explicit pragma). Set_SPARK_Pragma (T, SPARK_Mode_Pragma); Set_SPARK_Aux_Pragma (T, SPARK_Mode_Pragma); Set_SPARK_Pragma_Inherited (T); Set_SPARK_Aux_Pragma_Inherited (T); -- Preserve relevant elaboration-related attributes of the context which -- are no longer available or very expensive to recompute once analysis, -- resolution, and expansion are over. Mark_Elaboration_Attributes (N_Id => T, Checks => True, Warnings => True); 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 -- The task type is the full view of a private type. Analyze the -- aspects with the entity of the private type to ensure that after -- both views are exchanged, the aspect are actually associated with -- the full view. if T /= Def_Id and then Is_Private_Type (Def_Id) then Analyze_Aspect_Specifications (N, T); else Analyze_Aspect_Specifications (N, Def_Id); end if; 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) and then not CodePeer_Mode 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; -- Propagate Default_Initial_Condition-related attributes from the -- private type to the task type. Propagate_DIC_Attributes (T, From_Typ => Def_Id); -- Propagate invariant-related attributes from the private type to -- task type. Propagate_Invariant_Attributes (T, From_Typ => Def_Id); -- 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 Expander_Active then Expand_N_Task_Type_Declaration (N); Process_Full_View (N, T, Def_Id); end if; end if; -- In GNATprove mode, force the loading of a Interrupt_Priority, which -- is required for the ceiling priority protocol checks triggered by -- calls originating from tasks. if GNATprove_Mode then SPARK_Implicit_Load (RE_Interrupt_Priority); 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_05_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 procedure or entry call " & "or delay statement", 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); -- The primitive operations of a tagged synchronized type are placed -- on the Corresponding_Record for proper dispatching, but are -- attached to the synchronized type itself when expansion is -- disabled, for ASIS use. Set_Direct_Primitive_Operations (T, New_Elmt_List); 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 := No_Elist; Iface : Node_Id; Priv_T : Entity_Id; Priv_T_Ifaces : Elist_Id := No_Elist; 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 in partial view& not implemented by full " & "type (RM-2005 7.3 (7.3/2))", 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; end Sem_Ch9;