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