diff options
Diffstat (limited to 'gcc/ada/sem_ch9.adb')
| -rw-r--r-- | gcc/ada/sem_ch9.adb | 1705 |
1 files changed, 1705 insertions, 0 deletions
diff --git a/gcc/ada/sem_ch9.adb b/gcc/ada/sem_ch9.adb new file mode 100644 index 00000000000..2075e5e5342 --- /dev/null +++ b/gcc/ada/sem_ch9.adb @@ -0,0 +1,1705 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S E M _ C H 9 -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.235 $ +-- -- +-- Copyright (C) 1992-2001, 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. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +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 (Ityp, 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'); + 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'); + 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'); + 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'); + 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 (Id, 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 (Id, 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); + Spec_Id : Entity_Id; + Last_E : Entity_Id; + + 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; + + Generate_Reference (Spec_Id, Body_Id, 'b'); + 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'); + 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)) 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'); + 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); + 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); + Spec_Id : Entity_Id; + Last_E : Entity_Id; + + 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; + + Generate_Reference (Spec_Id, Body_Id, 'b'); + 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'); + 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'); + 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); + T := Find_Type_Name (N); + Generate_Definition (T); + + if Ekind (T) = E_Incomplete_Type then + T := Full_View (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; |