------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- S E M _ C H 9 -- -- -- -- B o d y -- -- -- -- -- -- Copyright (C) 1992-2002, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- -- for more details. You should have received a copy of the GNU General -- -- Public License distributed with GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- -- MA 02111-1307, USA. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ with Atree; use Atree; with Checks; use Checks; with Einfo; use Einfo; with Errout; use Errout; with Exp_Ch9; with Elists; use Elists; with Itypes; use Itypes; with Lib.Xref; use Lib.Xref; with Nlists; use Nlists; with Nmake; use Nmake; with Opt; use Opt; with Restrict; use Restrict; with Rtsfind; use Rtsfind; with Sem; use Sem; with Sem_Ch3; use Sem_Ch3; with Sem_Ch5; use Sem_Ch5; with Sem_Ch6; use Sem_Ch6; with Sem_Ch8; use Sem_Ch8; with Sem_Eval; use Sem_Eval; with Sem_Res; use Sem_Res; with Sem_Type; use Sem_Type; with Sem_Util; use Sem_Util; with Sem_Warn; use Sem_Warn; with Snames; use Snames; with Stand; use Stand; with Sinfo; use Sinfo; with Style; with Tbuild; use Tbuild; with Uintp; use Uintp; package body Sem_Ch9 is ----------------------- -- Local Subprograms -- ----------------------- procedure Check_Max_Entries (Def : Node_Id; R : Restriction_Parameter_Id); -- Given either a protected definition or a task definition in Def, 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. function Find_Concurrent_Spec (Body_Id : Entity_Id) return Entity_Id; -- Find entity in corresponding task or protected declaration. Use full -- view if first declaration was for an incomplete type. procedure Install_Declarations (Spec : Entity_Id); -- Utility to make visible in corresponding body the entities defined -- in task, protected type declaration, or entry declaration. ----------------------------- -- Analyze_Abort_Statement -- ----------------------------- procedure Analyze_Abort_Statement (N : Node_Id) is T_Name : Node_Id; begin Tasking_Used := True; T_Name := First (Names (N)); while Present (T_Name) loop Analyze (T_Name); if not Is_Task_Type (Etype (T_Name)) then Error_Msg_N ("expect task name for ABORT", T_Name); return; else Resolve (T_Name, Etype (T_Name)); 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; Analyze (Accept_Statement (N)); 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_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); Ityp : Entity_Id; Entry_Nam : Entity_Id; E : Entity_Id; Kind : Entity_Kind; Task_Nam : Entity_Id; ----------------------- -- Actual_Index_Type -- ----------------------- function Actual_Index_Type (E : Entity_Id) return Entity_Id; -- If the bounds of an entry family depend on task discriminants, -- create a new index type where a discriminant is replaced by the -- local variable that renames it in the task body. function Actual_Index_Type (E : Entity_Id) return Entity_Id is Typ : Entity_Id := Entry_Index_Type (E); Lo : Node_Id := Type_Low_Bound (Typ); Hi : Node_Id := Type_High_Bound (Typ); New_T : Entity_Id; function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id; -- If bound is discriminant reference, replace with corresponding -- local variable of the same name. function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id is Typ : Entity_Id := Etype (Bound); Ref : Node_Id; begin if not Is_Entity_Name (Bound) or else Ekind (Entity (Bound)) /= E_Discriminant then return Bound; else Ref := Make_Identifier (Sloc (N), Chars (Entity (Bound))); Analyze (Ref); Resolve (Ref, Typ); return Ref; end if; end Actual_Discriminant_Ref; -- Start of processing for Actual_Index_Type begin if not Has_Discriminants (Task_Nam) or else (not Is_Entity_Name (Lo) and then not Is_Entity_Name (Hi)) then return Entry_Index_Type (E); else New_T := Create_Itype (Ekind (Typ), N); Set_Etype (New_T, Base_Type (Typ)); Set_Size_Info (New_T, Typ); Set_RM_Size (New_T, RM_Size (Typ)); Set_Scalar_Range (New_T, Make_Range (Sloc (N), Low_Bound => Actual_Discriminant_Ref (Lo), High_Bound => Actual_Discriminant_Ref (Hi))); return New_T; end if; end Actual_Index_Type; -- Start of processing for Analyze_Accept_Statement begin Tasking_Used := True; -- Entry name is initialized to Any_Id. It should get reset to the -- matching entry entity. An error is signalled if it is not reset. Entry_Nam := Any_Id; for J in reverse 0 .. Scope_Stack.Last loop Task_Nam := Scope_Stack.Table (J).Entity; exit when Ekind (Etype (Task_Nam)) = E_Task_Type; Kind := Ekind (Task_Nam); if Kind /= E_Block and then Kind /= E_Loop and then not Is_Entry (Task_Nam) then Error_Msg_N ("enclosing body of accept must be a task", N); return; end if; end loop; if Ekind (Etype (Task_Nam)) /= E_Task_Type then Error_Msg_N ("invalid context for accept statement", N); return; end if; -- In order to process the parameters, we create a defining -- identifier that can be used as the name of the scope. The -- name of the accept statement itself is not a defining identifier. if Present (Index) then Ityp := New_Internal_Entity (E_Entry_Family, Current_Scope, Sloc (N), 'E'); else Ityp := New_Internal_Entity (E_Entry, Current_Scope, Sloc (N), 'E'); end if; Set_Etype (Ityp, Standard_Void_Type); Set_Accept_Address (Ityp, New_Elmt_List); if Present (Formals) then New_Scope (Ityp); Process_Formals (Formals, N); Create_Extra_Formals (Ityp); End_Scope; end if; -- We set the default expressions processed flag because we don't -- need default expression functions. This is really more like a -- body entity than a spec entity anyway. Set_Default_Expressions_Processed (Ityp); E := First_Entity (Etype (Task_Nam)); while Present (E) loop if Chars (E) = Chars (Nam) and then (Ekind (E) = Ekind (Ityp)) and then Type_Conformant (Ityp, 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 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 (Ityp, Convention (Entry_Nam)); Check_Fully_Conformant (Ityp, Entry_Nam, N); for J in reverse 0 .. Scope_Stack.Last loop exit when Task_Nam = Scope_Stack.Table (J).Entity; if Entry_Nam = Scope_Stack.Table (J).Entity then Error_Msg_N ("duplicate accept statement for same entry", N); end if; end loop; declare P : Node_Id := N; begin loop P := Parent (P); case Nkind (P) is when N_Task_Body | N_Compilation_Unit => exit; when N_Asynchronous_Select => Error_Msg_N ("accept statements are not allowed within" & " an asynchronous select inner" & " to the enclosing task body", N); exit; when others => null; end case; end loop; end; if Ekind (E) = E_Entry_Family then if No (Index) then Error_Msg_N ("missing entry index in accept for entry family", N); else Analyze_And_Resolve (Index, Entry_Index_Type (E)); Apply_Range_Check (Index, Actual_Index_Type (E)); end if; elsif Present (Index) then Error_Msg_N ("invalid entry index in accept for simple entry", N); end if; -- If 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. Exp_Ch9.Expand_Accept_Declarations (N, Entry_Nam); -- 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; -- Set Not_Source_Assigned flag on all entry formals E := First_Entity (Entry_Nam); while Present (E) loop Set_Not_Source_Assigned (E, True); Next_Entity (E); end loop; -- Analyze statements if present if Present (Stats) then New_Scope (Entry_Nam); Install_Declarations (Entry_Nam); Set_Actual_Subtypes (N, Current_Scope); Analyze (Stats); Process_End_Label (Handled_Statement_Sequence (N), 't', Entry_Nam); End_Scope; end if; -- Some warning checks Check_Potentially_Blocking_Operation (N); Check_References (Entry_Nam, N); Set_Entry_Accepted (Entry_Nam); end Analyze_Accept_Statement; --------------------------------- -- Analyze_Asynchronous_Select -- --------------------------------- procedure Analyze_Asynchronous_Select (N : Node_Id) is begin Tasking_Used := True; Check_Restriction (Max_Asynchronous_Select_Nesting, N); Check_Restriction (No_Select_Statements, N); Analyze (Triggering_Alternative (N)); Analyze_Statements (Statements (Abortable_Part (N))); end Analyze_Asynchronous_Select; ------------------------------------ -- Analyze_Conditional_Entry_Call -- ------------------------------------ procedure Analyze_Conditional_Entry_Call (N : Node_Id) is begin Check_Restriction (No_Select_Statements, N); Tasking_Used := True; Analyze (Entry_Call_Alternative (N)); Analyze_Statements (Else_Statements (N)); end Analyze_Conditional_Entry_Call; -------------------------------- -- Analyze_Delay_Alternative -- -------------------------------- procedure Analyze_Delay_Alternative (N : Node_Id) is Expr : Node_Id; begin Tasking_Used := True; Check_Restriction (No_Delay, N); if Present (Pragmas_Before (N)) then Analyze_List (Pragmas_Before (N)); end if; if Nkind (Parent (N)) = N_Selective_Accept or else Nkind (Parent (N)) = N_Timed_Entry_Call then Expr := Expression (Delay_Statement (N)); -- defer full analysis until the statement is expanded, to insure -- that generated code does not move past the guard. The delay -- expression is only evaluated if the guard is open. if Nkind (Delay_Statement (N)) = N_Delay_Relative_Statement then Pre_Analyze_And_Resolve (Expr, Standard_Duration); else Pre_Analyze_And_Resolve (Expr); end if; Check_Restriction (No_Fixed_Point, Expr); else Analyze (Delay_Statement (N)); end if; if Present (Condition (N)) then Analyze_And_Resolve (Condition (N), Any_Boolean); end if; if Is_Non_Empty_List (Statements (N)) then Analyze_Statements (Statements (N)); end if; end Analyze_Delay_Alternative; ---------------------------- -- Analyze_Delay_Relative -- ---------------------------- procedure Analyze_Delay_Relative (N : Node_Id) is E : constant Node_Id := Expression (N); begin Check_Restriction (No_Relative_Delay, N); Tasking_Used := True; Check_Restriction (No_Delay, N); Check_Potentially_Blocking_Operation (N); Analyze_And_Resolve (E, Standard_Duration); Check_Restriction (No_Fixed_Point, E); end Analyze_Delay_Relative; ------------------------- -- Analyze_Delay_Until -- ------------------------- procedure Analyze_Delay_Until (N : Node_Id) is E : constant Node_Id := Expression (N); begin Tasking_Used := True; Check_Restriction (No_Delay, N); Check_Potentially_Blocking_Operation (N); Analyze (E); if not Is_RTE (Base_Type (Etype (E)), RO_CA_Time) and then not Is_RTE (Base_Type (Etype (E)), RO_RT_Time) then Error_Msg_N ("expect Time types for `DELAY UNTIL`", E); end if; end Analyze_Delay_Until; ------------------------ -- Analyze_Entry_Body -- ------------------------ procedure Analyze_Entry_Body (N : Node_Id) is Id : constant Entity_Id := Defining_Identifier (N); Decls : constant List_Id := Declarations (N); Stats : constant Node_Id := Handled_Statement_Sequence (N); Formals : constant Node_Id := Entry_Body_Formal_Part (N); P_Type : constant Entity_Id := Current_Scope; Entry_Name : Entity_Id; E : Entity_Id; begin Tasking_Used := True; -- Entry_Name is initialized to Any_Id. It should get reset to the -- matching entry entity. An error is signalled if it is not reset Entry_Name := Any_Id; Analyze (Formals); if Present (Entry_Index_Specification (Formals)) then Set_Ekind (Id, E_Entry_Family); else Set_Ekind (Id, E_Entry); end if; Set_Scope (Id, Current_Scope); Set_Etype (Id, Standard_Void_Type); Set_Accept_Address (Id, New_Elmt_List); E := First_Entity (P_Type); while Present (E) loop if Chars (E) = Chars (Id) and then (Ekind (E) = Ekind (Id)) and then Type_Conformant (Id, E) then Entry_Name := E; Set_Convention (Id, Convention (E)); Check_Fully_Conformant (Id, E, N); exit; end if; Next_Entity (E); end loop; if Entry_Name = Any_Id then Error_Msg_N ("no entry declaration matches entry body", N); return; elsif Has_Completion (Entry_Name) then Error_Msg_N ("duplicate entry body", N); return; else Set_Has_Completion (Entry_Name); Generate_Reference (Entry_Name, Id, 'b', Set_Ref => False); Style.Check_Identifier (Id, Entry_Name); end if; Exp_Ch9.Expand_Entry_Barrier (N, Entry_Name); New_Scope (Entry_Name); Exp_Ch9.Expand_Entry_Body_Declarations (N); Install_Declarations (Entry_Name); Set_Actual_Subtypes (N, Current_Scope); -- The entity for the protected subprogram corresponding to the entry -- has been created. We retain the name of this entity in the entry -- body, for use when the corresponding subprogram body is created. -- Note that entry bodies have to corresponding_spec, and there is no -- easy link back in the tree between the entry body and the entity for -- the entry itself. Set_Protected_Body_Subprogram (Id, Protected_Body_Subprogram (Entry_Name)); if Present (Decls) then Analyze_Declarations (Decls); end if; if Present (Stats) then Analyze (Stats); end if; Check_References (Entry_Name); Process_End_Label (Handled_Statement_Sequence (N), 't', Entry_Name); End_Scope; -- If this is an entry family, remove the loop created to provide -- a scope for the entry index. if Ekind (Id) = E_Entry_Family and then Present (Entry_Index_Specification (Formals)) then End_Scope; end if; end Analyze_Entry_Body; ------------------------------------ -- Analyze_Entry_Body_Formal_Part -- ------------------------------------ procedure Analyze_Entry_Body_Formal_Part (N : Node_Id) is Id : constant Entity_Id := Defining_Identifier (Parent (N)); Index : constant Node_Id := Entry_Index_Specification (N); Formals : constant List_Id := Parameter_Specifications (N); begin Tasking_Used := True; if Present (Index) then Analyze (Index); end if; if Present (Formals) then Set_Scope (Id, Current_Scope); New_Scope (Id); Process_Formals (Formals, Parent (N)); End_Scope; end if; end Analyze_Entry_Body_Formal_Part; ------------------------------------ -- Analyze_Entry_Call_Alternative -- ------------------------------------ procedure Analyze_Entry_Call_Alternative (N : Node_Id) is begin Tasking_Used := True; if Present (Pragmas_Before (N)) then Analyze_List (Pragmas_Before (N)); end if; Analyze (Entry_Call_Statement (N)); 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 Id : Entity_Id := Defining_Identifier (N); D_Sdef : Node_Id := Discrete_Subtype_Definition (N); Formals : List_Id := Parameter_Specifications (N); begin Generate_Definition (Id); Tasking_Used := True; if No (D_Sdef) then Set_Ekind (Id, E_Entry); else Enter_Name (Id); Set_Ekind (Id, E_Entry_Family); Analyze (D_Sdef); Make_Index (D_Sdef, N, Id); end if; Set_Etype (Id, Standard_Void_Type); Set_Convention (Id, Convention_Entry); Set_Accept_Address (Id, New_Elmt_List); if Present (Formals) then Set_Scope (Id, Current_Scope); New_Scope (Id); Process_Formals (Formals, N); Create_Extra_Formals (Id); End_Scope; end if; if Ekind (Id) = E_Entry then New_Overloaded_Entity (Id); end if; end Analyze_Entry_Declaration; --------------------------------------- -- Analyze_Entry_Index_Specification -- --------------------------------------- -- The defining_Identifier of the entry index specification is local -- to the entry body, but must be available in the entry barrier, -- which is evaluated outside of the entry body. The index is eventually -- renamed as a run-time object, so is visibility is strictly a front-end -- concern. In order to make it available to the barrier, we create -- an additional scope, as for a loop, whose only declaration is the -- index name. This loop is not attached to the tree and does not appear -- as an entity local to the protected type, so its existence need only -- be knwown to routines that process entry families. procedure Analyze_Entry_Index_Specification (N : Node_Id) is Iden : constant Node_Id := Defining_Identifier (N); Def : constant Node_Id := Discrete_Subtype_Definition (N); Loop_Id : Entity_Id := Make_Defining_Identifier (Sloc (N), Chars => New_Internal_Name ('L')); begin Tasking_Used := True; Analyze (Def); Make_Index (Def, N); Set_Ekind (Loop_Id, E_Loop); Set_Scope (Loop_Id, Current_Scope); New_Scope (Loop_Id); Enter_Name (Iden); Set_Ekind (Iden, E_Entry_Index_Parameter); Set_Etype (Iden, Etype (Def)); end Analyze_Entry_Index_Specification; ---------------------------- -- Analyze_Protected_Body -- ---------------------------- procedure Analyze_Protected_Body (N : Node_Id) is Body_Id : constant Entity_Id := Defining_Identifier (N); Last_E : Entity_Id; Spec_Id : Entity_Id; -- This is initially the entity of the protected object or protected -- type involved, but is replaced by the protected type always in the -- case of a single protected declaration, since this is the proper -- scope to be used. Ref_Id : Entity_Id; -- This is the entity of the protected object or protected type -- involved, and is the entity used for cross-reference purposes -- (it differs from Spec_Id in the case of a single protected -- object, since Spec_Id is set to the protected type in this case). begin Tasking_Used := True; Set_Ekind (Body_Id, E_Protected_Body); Spec_Id := Find_Concurrent_Spec (Body_Id); if Present (Spec_Id) and then Ekind (Spec_Id) = E_Protected_Type then null; elsif Present (Spec_Id) and then Ekind (Etype (Spec_Id)) = E_Protected_Type and then not Comes_From_Source (Etype (Spec_Id)) then null; else Error_Msg_N ("missing specification for protected body", Body_Id); return; end if; Ref_Id := Spec_Id; Generate_Reference (Ref_Id, Body_Id, 'b', Set_Ref => False); Style.Check_Identifier (Body_Id, Spec_Id); -- The declarations are always attached to the type if Ekind (Spec_Id) /= E_Protected_Type then Spec_Id := Etype (Spec_Id); end if; New_Scope (Spec_Id); Set_Corresponding_Spec (N, Spec_Id); Set_Corresponding_Body (Parent (Spec_Id), Body_Id); Set_Has_Completion (Spec_Id); Install_Declarations (Spec_Id); Exp_Ch9.Expand_Protected_Body_Declarations (N, Spec_Id); Last_E := Last_Entity (Spec_Id); Analyze_Declarations (Declarations (N)); -- For visibility purposes, all entities in the body are private. -- Set First_Private_Entity accordingly, if there was no private -- part in the protected declaration. if No (First_Private_Entity (Spec_Id)) then if Present (Last_E) then Set_First_Private_Entity (Spec_Id, Next_Entity (Last_E)); else Set_First_Private_Entity (Spec_Id, First_Entity (Spec_Id)); end if; end if; Check_Completion (Body_Id); Check_References (Spec_Id); Process_End_Label (N, 't', Ref_Id); End_Scope; end Analyze_Protected_Body; ---------------------------------- -- Analyze_Protected_Definition -- ---------------------------------- procedure Analyze_Protected_Definition (N : Node_Id) is E : Entity_Id; L : Entity_Id; begin Tasking_Used := True; Analyze_Declarations (Visible_Declarations (N)); if Present (Private_Declarations (N)) and then not Is_Empty_List (Private_Declarations (N)) then L := Last_Entity (Current_Scope); Analyze_Declarations (Private_Declarations (N)); if Present (L) then Set_First_Private_Entity (Current_Scope, Next_Entity (L)); else Set_First_Private_Entity (Current_Scope, First_Entity (Current_Scope)); end if; end if; E := First_Entity (Current_Scope); while Present (E) loop if Ekind (E) = E_Function or else Ekind (E) = E_Procedure then Set_Convention (E, Convention_Protected); elsif Is_Task_Type (Etype (E)) or else Has_Task (Etype (E)) then Set_Has_Task (Current_Scope); end if; Next_Entity (E); end loop; Check_Max_Entries (N, Max_Protected_Entries); Process_End_Label (N, 'e', Current_Scope); end Analyze_Protected_Definition; ---------------------------- -- Analyze_Protected_Type -- ---------------------------- procedure Analyze_Protected_Type (N : Node_Id) is E : Entity_Id; T : Entity_Id; Def_Id : constant Entity_Id := Defining_Identifier (N); begin Tasking_Used := True; Check_Restriction (No_Protected_Types, N); T := Find_Type_Name (N); if Ekind (T) = E_Incomplete_Type then T := Full_View (T); Set_Completion_Referenced (T); end if; Set_Ekind (T, E_Protected_Type); Init_Size_Align (T); Set_Etype (T, T); Set_Is_First_Subtype (T, True); Set_Has_Delayed_Freeze (T, True); Set_Girder_Constraint (T, No_Elist); New_Scope (T); 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; Analyze (Protected_Definition (N)); -- Protected types with entries are controlled (because of the -- Protection component if nothing else), same for any protected type -- with interrupt handlers. Note that we need to analyze the protected -- definition to set Has_Entries and such. if (Abort_Allowed or else Restrictions (No_Entry_Queue) = False or else Number_Entries (T) > 1) and then (Has_Entries (T) or else Has_Interrupt_Handler (T) or else Has_Attach_Handler (T)) then Set_Has_Controlled_Component (T, True); end if; -- The Ekind of components is E_Void during analysis to detect -- illegal uses. Now it can be set correctly. E := First_Entity (Current_Scope); while Present (E) loop if Ekind (E) = E_Void then Set_Ekind (E, E_Component); Init_Component_Location (E); end if; Next_Entity (E); end loop; End_Scope; if T /= Def_Id and then Is_Private_Type (Def_Id) and then Has_Discriminants (Def_Id) and then Expander_Active then Exp_Ch9.Expand_N_Protected_Type_Declaration (N); Process_Full_View (N, T, Def_Id); end if; end Analyze_Protected_Type; --------------------- -- Analyze_Requeue -- --------------------- procedure Analyze_Requeue (N : Node_Id) is Entry_Name : Node_Id := Name (N); Entry_Id : Entity_Id; Found : Boolean; I : Interp_Index; It : Interp; Enclosing : Entity_Id; Target_Obj : Node_Id := Empty; Req_Scope : Entity_Id; Outer_Ent : Entity_Id; begin Check_Restriction (No_Requeue, N); Check_Unreachable_Code (N); Tasking_Used := True; Enclosing := Empty; for J in reverse 0 .. Scope_Stack.Last loop Enclosing := Scope_Stack.Table (J).Entity; exit when Is_Entry (Enclosing); if Ekind (Enclosing) /= E_Block and then Ekind (Enclosing) /= E_Loop then Error_Msg_N ("requeue must appear within accept or entry body", N); return; end if; end loop; Analyze (Entry_Name); if Etype (Entry_Name) = Any_Type then return; end if; if Nkind (Entry_Name) = N_Selected_Component then Target_Obj := Prefix (Entry_Name); Entry_Name := Selector_Name (Entry_Name); end if; -- If an explicit target object is given then we have to check -- the restrictions of 9.5.4(6). if Present (Target_Obj) then -- Locate containing concurrent unit and determine -- enclosing entry body or outermost enclosing accept -- statement within the unit. Outer_Ent := Empty; for S in reverse 0 .. Scope_Stack.Last loop Req_Scope := Scope_Stack.Table (S).Entity; exit when Ekind (Req_Scope) in Task_Kind or else Ekind (Req_Scope) in Protected_Kind; if Is_Entry (Req_Scope) then Outer_Ent := Req_Scope; end if; end loop; pragma Assert (Present (Outer_Ent)); -- Check that the accessibility level of the target object -- is not greater or equal to the outermost enclosing accept -- statement (or entry body) unless it is a parameter of the -- innermost enclosing accept statement (or entry body). if Object_Access_Level (Target_Obj) >= Scope_Depth (Outer_Ent) and then (not Is_Entity_Name (Target_Obj) or else Ekind (Entity (Target_Obj)) not in Formal_Kind or else Enclosing /= Scope (Entity (Target_Obj))) then Error_Msg_N ("target object has invalid level for requeue", Target_Obj); end if; end if; -- Overloaded case, find right interpretation if Is_Overloaded (Entry_Name) then Get_First_Interp (Entry_Name, I, It); Found := False; Entry_Id := Empty; while Present (It.Nam) loop if No (First_Formal (It.Nam)) or else Subtype_Conformant (Enclosing, It.Nam) then if not Found then Found := True; Entry_Id := It.Nam; else Error_Msg_N ("ambiguous entry name in requeue", N); return; end if; end if; Get_Next_Interp (I, It); end loop; if not Found then Error_Msg_N ("no entry matches context", N); return; else Set_Entity (Entry_Name, Entry_Id); end if; -- Non-overloaded cases -- For the case of a reference to an element of an entry family, -- the Entry_Name is an indexed component. elsif Nkind (Entry_Name) = N_Indexed_Component then -- Requeue to an entry out of the body if Nkind (Prefix (Entry_Name)) = N_Selected_Component then Entry_Id := Entity (Selector_Name (Prefix (Entry_Name))); -- Requeue from within the body itself elsif Nkind (Prefix (Entry_Name)) = N_Identifier then Entry_Id := Entity (Prefix (Entry_Name)); else Error_Msg_N ("invalid entry_name specified", N); return; end if; -- If we had a requeue of the form REQUEUE A (B), then the parser -- accepted it (because it could have been a requeue on an entry -- index. If A turns out not to be an entry family, then the analysis -- of A (B) turned it into a function call. elsif Nkind (Entry_Name) = N_Function_Call then Error_Msg_N ("arguments not allowed in requeue statement", First (Parameter_Associations (Entry_Name))); return; -- Normal case of no entry family, no argument else Entry_Id := Entity (Entry_Name); end if; -- Resolve entry, and check that it is subtype conformant with the -- enclosing construct if this construct has formals (RM 9.5.4(5)). if not Is_Entry (Entry_Id) then Error_Msg_N ("expect entry name in requeue statement", Name (N)); elsif Ekind (Entry_Id) = E_Entry_Family and then Nkind (Entry_Name) /= N_Indexed_Component then Error_Msg_N ("missing index for entry family component", Name (N)); else Resolve_Entry (Name (N)); if Present (First_Formal (Entry_Id)) then Check_Subtype_Conformant (Enclosing, Entry_Id, Name (N)); -- Mark any output parameters as assigned declare Ent : Entity_Id := First_Formal (Enclosing); begin while Present (Ent) loop if Ekind (Ent) = E_Out_Parameter then Set_Not_Source_Assigned (Ent, False); end if; Next_Formal (Ent); end loop; end; end if; end if; end Analyze_Requeue; ------------------------------ -- Analyze_Selective_Accept -- ------------------------------ procedure Analyze_Selective_Accept (N : Node_Id) is Alts : constant List_Id := Select_Alternatives (N); Alt : Node_Id; Accept_Present : Boolean := False; Terminate_Present : Boolean := False; Delay_Present : Boolean := False; Relative_Present : Boolean := False; Alt_Count : Uint := Uint_0; begin Check_Restriction (No_Select_Statements, N); Tasking_Used := True; 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, Alt_Count, N); Check_Potentially_Blocking_Operation (N); if Terminate_Present and Delay_Present then Error_Msg_N ("at most one of terminate or delay alternative", N); elsif not Accept_Present then Error_Msg_N ("select must contain at least one accept alternative", N); end if; if Present (Else_Statements (N)) then if Terminate_Present or Delay_Present then Error_Msg_N ("else part not allowed with other alternatives", N); end if; Analyze_Statements (Else_Statements (N)); end if; end Analyze_Selective_Accept; ------------------------------ -- Analyze_Single_Protected -- ------------------------------ procedure Analyze_Single_Protected (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); Id : constant Node_Id := Defining_Identifier (N); T : Entity_Id; T_Decl : Node_Id; O_Decl : Node_Id; O_Name : constant Entity_Id := New_Copy (Id); begin Generate_Definition (Id); Tasking_Used := True; -- The node is rewritten as a protected type declaration, -- in exact analogy with what is done with single tasks. T := Make_Defining_Identifier (Sloc (Id), New_External_Name (Chars (Id), 'T')); T_Decl := Make_Protected_Type_Declaration (Loc, Defining_Identifier => T, Protected_Definition => Relocate_Node (Protected_Definition (N))); O_Decl := Make_Object_Declaration (Loc, Defining_Identifier => O_Name, Object_Definition => Make_Identifier (Loc, Chars (T))); Rewrite (N, T_Decl); Insert_After (N, O_Decl); Mark_Rewrite_Insertion (O_Decl); -- Enter names of type and object before analysis, because the name -- of the object may be used in its own body. Enter_Name (T); Set_Ekind (T, E_Protected_Type); Set_Etype (T, T); Enter_Name (O_Name); Set_Ekind (O_Name, E_Variable); Set_Etype (O_Name, T); -- Instead of calling Analyze on the new node, call directly -- the proper analysis procedure. Otherwise the node would be -- expanded twice, with disastrous result. Analyze_Protected_Type (N); end Analyze_Single_Protected; ------------------------- -- Analyze_Single_Task -- ------------------------- procedure Analyze_Single_Task (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); Id : constant Node_Id := Defining_Identifier (N); T : Entity_Id; T_Decl : Node_Id; O_Decl : Node_Id; O_Name : constant Entity_Id := New_Copy (Id); begin Generate_Definition (Id); Tasking_Used := True; -- The node is rewritten as a task type declaration, followed -- by an object declaration of that anonymous task type. T := Make_Defining_Identifier (Sloc (Id), New_External_Name (Chars (Id), Suffix => "TK")); T_Decl := Make_Task_Type_Declaration (Loc, Defining_Identifier => T, Task_Definition => Relocate_Node (Task_Definition (N))); O_Decl := Make_Object_Declaration (Loc, Defining_Identifier => O_Name, Object_Definition => Make_Identifier (Loc, Chars (T))); Rewrite (N, T_Decl); Insert_After (N, O_Decl); Mark_Rewrite_Insertion (O_Decl); -- Enter names of type and object before analysis, because the name -- of the object may be used in its own body. Enter_Name (T); Set_Ekind (T, E_Task_Type); Set_Etype (T, T); Enter_Name (O_Name); Set_Ekind (O_Name, E_Variable); Set_Etype (O_Name, T); -- Instead of calling Analyze on the new node, call directly -- the proper analysis procedure. Otherwise the node would be -- expanded twice, with disastrous result. Analyze_Task_Type (N); end Analyze_Single_Task; ----------------------- -- Analyze_Task_Body -- ----------------------- procedure Analyze_Task_Body (N : Node_Id) is Body_Id : constant Entity_Id := Defining_Identifier (N); Last_E : Entity_Id; Spec_Id : Entity_Id; -- This is initially the entity of the task or task type involved, -- but is replaced by the task type always in the case of a single -- task declaration, since this is the proper scope to be used. Ref_Id : Entity_Id; -- This is the entity of the task or task type, and is the entity -- used for cross-reference purposes (it differs from Spec_Id in -- the case of a single task, since Spec_Id is set to the task type) begin Tasking_Used := True; Set_Ekind (Body_Id, E_Task_Body); Set_Scope (Body_Id, Current_Scope); Spec_Id := Find_Concurrent_Spec (Body_Id); -- The spec is either a task type declaration, or a single task -- declaration for which we have created an anonymous type. if Present (Spec_Id) and then Ekind (Spec_Id) = E_Task_Type then null; elsif Present (Spec_Id) and then Ekind (Etype (Spec_Id)) = E_Task_Type and then not Comes_From_Source (Etype (Spec_Id)) then null; else Error_Msg_N ("missing specification for task body", Body_Id); return; end if; Ref_Id := Spec_Id; Generate_Reference (Ref_Id, Body_Id, 'b', Set_Ref => False); Style.Check_Identifier (Body_Id, Spec_Id); -- Deal with case of body of single task (anonymous type was created) if Ekind (Spec_Id) = E_Variable then Spec_Id := Etype (Spec_Id); end if; New_Scope (Spec_Id); Set_Corresponding_Spec (N, Spec_Id); Set_Corresponding_Body (Parent (Spec_Id), Body_Id); Set_Has_Completion (Spec_Id); Install_Declarations (Spec_Id); Last_E := Last_Entity (Spec_Id); Analyze_Declarations (Declarations (N)); -- For visibility purposes, all entities in the body are private. -- Set First_Private_Entity accordingly, if there was no private -- part in the protected declaration. if No (First_Private_Entity (Spec_Id)) then if Present (Last_E) then Set_First_Private_Entity (Spec_Id, Next_Entity (Last_E)); else Set_First_Private_Entity (Spec_Id, First_Entity (Spec_Id)); end if; end if; Analyze (Handled_Statement_Sequence (N)); Check_Completion (Body_Id); Check_References (Body_Id); -- Check for entries with no corresponding accept declare Ent : Entity_Id; begin Ent := First_Entity (Spec_Id); while Present (Ent) loop if Is_Entry (Ent) and then not Entry_Accepted (Ent) and then Comes_From_Source (Ent) then Error_Msg_NE ("no accept for entry &?", N, Ent); end if; Next_Entity (Ent); end loop; end; Process_End_Label (Handled_Statement_Sequence (N), 't', Ref_Id); End_Scope; end Analyze_Task_Body; ----------------------------- -- Analyze_Task_Definition -- ----------------------------- procedure Analyze_Task_Definition (N : Node_Id) is L : Entity_Id; begin Tasking_Used := True; if Present (Visible_Declarations (N)) then Analyze_Declarations (Visible_Declarations (N)); end if; if Present (Private_Declarations (N)) then L := Last_Entity (Current_Scope); Analyze_Declarations (Private_Declarations (N)); if Present (L) then Set_First_Private_Entity (Current_Scope, Next_Entity (L)); else Set_First_Private_Entity (Current_Scope, First_Entity (Current_Scope)); end if; end if; Check_Max_Entries (N, Max_Task_Entries); Process_End_Label (N, 'e', Current_Scope); end Analyze_Task_Definition; ----------------------- -- Analyze_Task_Type -- ----------------------- procedure Analyze_Task_Type (N : Node_Id) is T : Entity_Id; Def_Id : constant Entity_Id := Defining_Identifier (N); begin Tasking_Used := True; Check_Restriction (Max_Tasks, N); Check_Restriction (No_Tasking, N); T := Find_Type_Name (N); Generate_Definition (T); if Ekind (T) = E_Incomplete_Type then T := Full_View (T); Set_Completion_Referenced (T); end if; Set_Ekind (T, E_Task_Type); Set_Is_First_Subtype (T, True); Set_Has_Task (T, True); Init_Size_Align (T); Set_Etype (T, T); Set_Has_Delayed_Freeze (T, True); Set_Girder_Constraint (T, No_Elist); New_Scope (T); if Present (Discriminant_Specifications (N)) then if 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; if Present (Task_Definition (N)) then Analyze_Task_Definition (Task_Definition (N)); end if; if not Is_Library_Level_Entity (T) then Check_Restriction (No_Task_Hierarchy, N); end if; End_Scope; if T /= Def_Id and then Is_Private_Type (Def_Id) and then Has_Discriminants (Def_Id) and then Expander_Active then Exp_Ch9.Expand_N_Task_Type_Declaration (N); Process_Full_View (N, T, Def_Id); end if; end Analyze_Task_Type; ----------------------------------- -- Analyze_Terminate_Alternative -- ----------------------------------- procedure Analyze_Terminate_Alternative (N : Node_Id) is begin Tasking_Used := True; if Present (Pragmas_Before (N)) then Analyze_List (Pragmas_Before (N)); end if; if Present (Condition (N)) then Analyze_And_Resolve (Condition (N), Any_Boolean); end if; end Analyze_Terminate_Alternative; ------------------------------ -- Analyze_Timed_Entry_Call -- ------------------------------ procedure Analyze_Timed_Entry_Call (N : Node_Id) is begin Check_Restriction (No_Select_Statements, N); Tasking_Used := True; Analyze (Entry_Call_Alternative (N)); Analyze (Delay_Alternative (N)); end Analyze_Timed_Entry_Call; ------------------------------------ -- Analyze_Triggering_Alternative -- ------------------------------------ procedure Analyze_Triggering_Alternative (N : Node_Id) is Trigger : 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) /= N_Delay_Until_Statement and then Nkind (Trigger) /= N_Delay_Relative_Statement and then Nkind (Trigger) /= N_Entry_Call_Statement then Error_Msg_N ("triggering statement must be delay or entry call", Trigger); 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 (Def : Node_Id; R : Restriction_Parameter_Id) is Ecount : Uint; procedure Count (L : List_Id); -- Count entries in given declaration list 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 No (DSD) then Ecount := Ecount + 1; 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; else Error_Msg_N ("static subtype required by Restriction pragma", DSD); end if; end; end if; Next (D); end loop; end Count; -- Start of processing for Check_Max_Entries begin if Restriction_Parameters (R) >= 0 then Ecount := Uint_0; Count (Visible_Declarations (Def)); Count (Private_Declarations (Def)); Check_Restriction (R, Ecount, Def); end if; end Check_Max_Entries; -------------------------- -- 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;