X-Git-Url: http://git.sourceforge.jp/view?a=blobdiff_plain;f=gcc%2Fada%2Fsem_ch9.adb;h=f9aab6a235db6a926e0c877ed205d84205552aca;hb=43537c9651f05e0ad6ba2c752dcfdfb762ef8376;hp=190706c4e11537976ffcc5fa0237d648889341bd;hpb=d62940bfa0c906f830712fc4334d3a5d5d45c728;p=pf3gnuchains%2Fgcc-fork.git diff --git a/gcc/ada/sem_ch9.adb b/gcc/ada/sem_ch9.adb index 190706c4e11..f9aab6a235d 100644 --- a/gcc/ada/sem_ch9.adb +++ b/gcc/ada/sem_ch9.adb @@ -6,18 +6,17 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2005 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2011, 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- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- -- for more details. You should have received a copy of the GNU General -- --- Public License distributed with GNAT; see file COPYING. If not, write -- --- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- --- Boston, MA 02110-1301, USA. -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- @@ -28,11 +27,11 @@ with Atree; use Atree; with Checks; use Checks; with Einfo; use Einfo; with Errout; use Errout; -with Exp_Ch9; +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 Namet; use Namet; with Nlists; use Nlists; with Nmake; use Nmake; with Opt; use Opt; @@ -40,10 +39,12 @@ with Restrict; use Restrict; with Rident; use Rident; with Rtsfind; use Rtsfind; with Sem; use Sem; +with Sem_Aux; use Sem_Aux; with Sem_Ch3; use Sem_Ch3; with Sem_Ch5; use Sem_Ch5; with Sem_Ch6; use Sem_Ch6; with Sem_Ch8; use Sem_Ch8; +with Sem_Ch13; use Sem_Ch13; with Sem_Eval; use Sem_Eval; with Sem_Res; use Sem_Res; with Sem_Type; use Sem_Type; @@ -53,6 +54,7 @@ with Snames; use Snames; with Stand; use Stand; with Sinfo; use Sinfo; with Style; +with Targparm; use Targparm; with Tbuild; use Tbuild; with Uintp; use Uintp; @@ -68,18 +70,26 @@ package body Sem_Ch9 is -- 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. + procedure Check_Interfaces (N : Node_Id; T : Entity_Id); + -- N is an N_Protected_Type_Declaration or N_Task_Type_Declaration node. + -- Complete decoration of T and check legality of the covered interfaces. + + procedure Check_Triggering_Statement + (Trigger : Node_Id; + Error_Node : Node_Id; + Is_Dispatching : out Boolean); + -- Examine the triggering statement of a select statement, conditional or + -- timed entry call. If Trigger is a dispatching call, return its status + -- in Is_Dispatching and check whether the primitive belongs to a limited + -- interface. If it does not, emit an error at Error_Node. function Find_Concurrent_Spec (Body_Id : Entity_Id) return Entity_Id; -- Find entity in corresponding task or protected declaration. Use full -- view if first declaration was for an incomplete type. procedure Install_Declarations (Spec : Entity_Id); - -- Utility to make visible in corresponding body the entities defined - -- in task, protected type declaration, or entry declaration. + -- Utility to make visible in corresponding body the entities defined in + -- task, protected type declaration, or entry declaration. ----------------------------- -- Analyze_Abort_Statement -- @@ -90,15 +100,28 @@ package body Sem_Ch9 is begin Tasking_Used := True; + Check_SPARK_Restriction ("abort statement is not allowed", N); + T_Name := First (Names (N)); while Present (T_Name) loop Analyze (T_Name); - if not Is_Task_Type (Etype (T_Name)) then - Error_Msg_N ("expect task name for ABORT", T_Name); - return; - else + if Is_Task_Type (Etype (T_Name)) + or else (Ada_Version >= Ada_2005 + and then Ekind (Etype (T_Name)) = E_Class_Wide_Type + and then Is_Interface (Etype (T_Name)) + and then Is_Task_Interface (Etype (T_Name))) + then Resolve (T_Name); + else + if Ada_Version >= Ada_2005 then + Error_Msg_N ("expect task name or task interface class-wide " + & "object for ABORT", T_Name); + else + Error_Msg_N ("expect task name for ABORT", T_Name); + end if; + + return; end if; Next (T_Name); @@ -146,73 +169,9 @@ package body Sem_Ch9 is 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; + Check_SPARK_Restriction ("accept statement is not allowed", N); -- Entry name is initialized to Any_Id. It should get reset to the -- matching entry entity. An error is signalled if it is not reset. @@ -237,11 +196,11 @@ package body Sem_Ch9 is 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. + -- 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 @@ -255,15 +214,15 @@ package body Sem_Ch9 is Set_Accept_Address (Accept_Id, New_Elmt_List); if Present (Formals) then - New_Scope (Accept_Id); + Push_Scope (Accept_Id); Process_Formals (Formals, N); Create_Extra_Formals (Accept_Id); End_Scope; end if; - -- We set the default expressions processed flag because we don't - -- need default expression functions. This is really more like a - -- body entity than a spec entity anyway. + -- 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); @@ -289,8 +248,8 @@ package body Sem_Ch9 is 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). + -- 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 @@ -298,9 +257,7 @@ package body Sem_Ch9 is 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) @@ -322,7 +279,6 @@ package body Sem_Ch9 is if Entry_Nam = Scope_Stack.Table (J).Entity then Error_Msg_N ("duplicate accept statement for same entry", N); end if; - end loop; declare @@ -349,26 +305,24 @@ package body Sem_Ch9 is 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)); + Apply_Range_Check (Index, Entry_Index_Type (E)); end if; elsif Present (Index) then Error_Msg_N ("invalid entry index in accept for simple entry", N); end if; - -- If label declarations present, analyze them. They are declared - -- in the enclosing task, but their enclosing scope is the entry itself, - -- so that goto's to the label are recognized as local to the accept. + -- If 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); @@ -382,34 +336,37 @@ package body Sem_Ch9 is 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. + -- 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. - -- 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. + -- 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. + -- Reset Referenced, Referenced_As_xxx and Has_Pragma_Unreferenced as + -- well, so that we can post accurate warnings on each accept statement + -- for the same entry. E := First_Entity (Entry_Nam); while Present (E) loop if Is_Formal (E) then - Set_Never_Set_In_Source (E, True); - Set_Is_True_Constant (E, False); - Set_Current_Value (E, Empty); - Set_Referenced (E, False); - Set_Has_Pragma_Unreferenced (E, False); + Set_Never_Set_In_Source (E, True); + Set_Is_True_Constant (E, False); + Set_Current_Value (E, Empty); + Set_Referenced (E, False); + Set_Referenced_As_LHS (E, False); + Set_Referenced_As_Out_Parameter (E, False); + Set_Has_Pragma_Unreferenced (E, False); end if; Next_Entity (E); @@ -418,7 +375,7 @@ package body Sem_Ch9 is -- Analyze statements if present if Present (Stats) then - New_Scope (Entry_Nam); + Push_Scope (Entry_Nam); Install_Declarations (Entry_Nam); Set_Actual_Subtypes (N, Current_Scope); @@ -440,17 +397,44 @@ package body Sem_Ch9 is --------------------------------- procedure Analyze_Asynchronous_Select (N : Node_Id) is + Is_Disp_Select : Boolean := False; + Trigger : Node_Id; + begin Tasking_Used := True; + Check_SPARK_Restriction ("select statement is not allowed", N); Check_Restriction (Max_Asynchronous_Select_Nesting, N); Check_Restriction (No_Select_Statements, N); - -- Analyze the statements. We analyze statements in the abortable part - -- first, because this is the section that is executed first, and that - -- way our remembering of saved values and checks is accurate. + if Ada_Version >= Ada_2005 then + Trigger := Triggering_Statement (Triggering_Alternative (N)); + + Analyze (Trigger); + + -- Ada 2005 (AI-345): Check for a potential dispatching select + + Check_Triggering_Statement (Trigger, N, Is_Disp_Select); + end if; + + -- Ada 2005 (AI-345): The expansion of the dispatching asynchronous + -- select will have to duplicate the triggering statements. Postpone + -- the analysis of the statements till expansion. Analyze only if the + -- expander is disabled in order to catch any semantic errors. + + if Is_Disp_Select then + if not Expander_Active then + Analyze_Statements (Statements (Abortable_Part (N))); + Analyze (Triggering_Alternative (N)); + end if; + + -- Analyze the statements. We analyze statements in the abortable part, + -- because this is the section that is executed first, and that way our + -- remembering of saved values and checks is accurate. - Analyze_Statements (Statements (Abortable_Part (N))); - Analyze (Triggering_Alternative (N)); + else + Analyze_Statements (Statements (Abortable_Part (N))); + Analyze (Triggering_Alternative (N)); + end if; end Analyze_Asynchronous_Select; ------------------------------------ @@ -458,11 +442,46 @@ package body Sem_Ch9 is ------------------------------------ procedure Analyze_Conditional_Entry_Call (N : Node_Id) is + Trigger : constant Node_Id := + Entry_Call_Statement (Entry_Call_Alternative (N)); + Is_Disp_Select : Boolean := False; + begin - Check_Restriction (No_Select_Statements, N); Tasking_Used := True; - Analyze (Entry_Call_Alternative (N)); - Analyze_Statements (Else_Statements (N)); + Check_SPARK_Restriction ("select statement is not allowed", N); + Check_Restriction (No_Select_Statements, N); + + -- Ada 2005 (AI-345): The trigger may be a dispatching call + + if Ada_Version >= Ada_2005 then + Analyze (Trigger); + Check_Triggering_Statement (Trigger, N, Is_Disp_Select); + end if; + + if List_Length (Else_Statements (N)) = 1 + and then Nkind (First (Else_Statements (N))) in N_Delay_Statement + then + Error_Msg_N + ("suspicious form of conditional entry call?!", N); + Error_Msg_N + ("\`SELECT OR` may be intended rather than `SELECT ELSE`!", N); + end if; + + -- Postpone the analysis of the statements till expansion. Analyze only + -- if the expander is disabled in order to catch any semantic errors. + + if Is_Disp_Select then + if not Expander_Active then + Analyze (Entry_Call_Alternative (N)); + Analyze_Statements (Else_Statements (N)); + end if; + + -- Regular select analysis + + else + Analyze (Entry_Call_Alternative (N)); + Analyze_Statements (Else_Statements (N)); + end if; end Analyze_Conditional_Entry_Call; -------------------------------- @@ -471,6 +490,7 @@ package body Sem_Ch9 is procedure Analyze_Delay_Alternative (N : Node_Id) is Expr : Node_Id; + Typ : Entity_Id; begin Tasking_Used := True; @@ -480,30 +500,30 @@ package body Sem_Ch9 is Analyze_List (Pragmas_Before (N)); end if; - if Nkind (Parent (N)) = N_Selective_Accept - or else Nkind (Parent (N)) = N_Timed_Entry_Call - then + if Nkind_In (Parent (N), N_Selective_Accept, N_Timed_Entry_Call) then Expr := Expression (Delay_Statement (N)); - -- defer full analysis until the statement is expanded, to insure + -- 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); - + Preanalyze_And_Resolve (Expr, Standard_Duration); else - Pre_Analyze_And_Resolve (Expr); + Preanalyze_And_Resolve (Expr); end if; - if Nkind (Delay_Statement (N)) = N_Delay_Until_Statement and then - not Is_RTE (Base_Type (Etype (Expr)), RO_CA_Time) and then - not Is_RTE (Base_Type (Etype (Expr)), RO_RT_Time) + 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; @@ -523,10 +543,10 @@ package body Sem_Ch9 is 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_SPARK_Restriction ("delay statement is not allowed", N); + Check_Restriction (No_Relative_Delay, N); Check_Restriction (No_Delay, N); Check_Potentially_Blocking_Operation (N); Analyze_And_Resolve (E, Standard_Duration); @@ -538,16 +558,19 @@ package body Sem_Ch9 is ------------------------- procedure Analyze_Delay_Until (N : Node_Id) is - E : constant Node_Id := Expression (N); + E : constant Node_Id := Expression (N); + Typ : Entity_Id; begin Tasking_Used := True; + Check_SPARK_Restriction ("delay statement is not allowed", N); Check_Restriction (No_Delay, N); Check_Potentially_Blocking_Operation (N); Analyze (E); + Typ := First_Subtype (Etype (E)); - if not Is_RTE (Base_Type (Etype (E)), RO_CA_Time) and then - not Is_RTE (Base_Type (Etype (E)), RO_RT_Time) + 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; @@ -563,8 +586,8 @@ package body Sem_Ch9 is 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; + Entry_Name : Entity_Id; begin Tasking_Used := True; @@ -609,13 +632,13 @@ package body Sem_Ch9 is (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. + -- 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 := @@ -632,7 +655,13 @@ package body Sem_Ch9 is then Set_Etype (Def, Empty); Set_Analyzed (Def, False); - Set_Discrete_Subtype_Definition (Index_Spec, Def); + + -- 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); @@ -674,24 +703,39 @@ package body Sem_Ch9 is end if; Exp_Ch9.Expand_Entry_Barrier (N, Entry_Name); - New_Scope (Entry_Name); + Push_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 + -- 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. + -- 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_Protected_Body_Subprogram (Id, - Protected_Body_Subprogram (Entry_Name)); + Set_Entry_Parameters_Type + (Id, Entry_Parameters_Type (Entry_Name)); + + -- Add a declaration for the Protection object, renaming declarations + -- for the discriminals and privals and finally a declaration for the + -- entry family index (if applicable). + + if Full_Expander_Active + and then Is_Protected_Type (P_Type) + then + Install_Private_Data_Declarations + (Sloc (N), Entry_Name, P_Type, N, Decls); + end if; if Present (Decls) then Analyze_Declarations (Decls); + Inspect_Deferred_Constant_Completion (Decls); end if; if Present (Stats) then @@ -707,10 +751,13 @@ package body Sem_Ch9 is -- 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; + E1 : Entity_Id; + E2 : Entity_Id; begin E1 := First_Entity (Entry_Name); @@ -721,9 +768,8 @@ package body Sem_Ch9 is 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 matching body entity, then we already had a detected + -- error of some kind, so just don't worry about these warnings. if No (E2) then goto Continue; @@ -736,6 +782,7 @@ package body Sem_Ch9 is Set_Referenced (E2, Referenced (E1)); Set_Referenced (E1); + Set_Entry_Component (E2, Entry_Component (E1)); <> Next_Entity (E1); @@ -763,7 +810,6 @@ package body Sem_Ch9 is then End_Scope; end if; - end Analyze_Entry_Body; ------------------------------------ @@ -780,11 +826,16 @@ package body Sem_Ch9 is if Present (Index) then Analyze (Index); + + -- The entry index functions like a loop variable, thus it is known + -- to have a valid value. + + Set_Is_Known_Valid (Defining_Identifier (Index)); end if; if Present (Formals) then Set_Scope (Id, Current_Scope); - New_Scope (Id); + Push_Scope (Id); Process_Formals (Formals, Parent (N)); End_Scope; end if; @@ -799,6 +850,7 @@ package body Sem_Ch9 is begin Tasking_Used := True; + Check_SPARK_Restriction ("entry call is not allowed", N); if Present (Pragmas_Before (N)) then Analyze_List (Pragmas_Before (N)); @@ -807,7 +859,7 @@ package body Sem_Ch9 is if Nkind (Call) = N_Attribute_Reference then -- Possibly a stream attribute, but definitely illegal. Other - -- illegalitles, such as procedure calls, are diagnosed after + -- illegalities, such as procedure calls, are diagnosed after -- resolution. Error_Msg_N ("entry call alternative requires an entry call", Call); @@ -826,37 +878,136 @@ package body Sem_Ch9 is ------------------------------- 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); + Def_Id : constant Entity_Id := Defining_Identifier (N); + Formals : constant List_Id := Parameter_Specifications (N); begin - Generate_Definition (Id); + Generate_Definition (Def_Id); + Set_Contract (Def_Id, Make_Contract (Sloc (Def_Id))); Tasking_Used := True; + -- Case of no discrete subtype definition + if No (D_Sdef) then - Set_Ekind (Id, E_Entry); + Set_Ekind (Def_Id, E_Entry); + + -- Processing for discrete subtype definition present + else - Enter_Name (Id); - Set_Ekind (Id, E_Entry_Family); + Enter_Name (Def_Id); + Set_Ekind (Def_Id, E_Entry_Family); Analyze (D_Sdef); - Make_Index (D_Sdef, N, Id); + Make_Index (D_Sdef, N, Def_Id); + + -- Check subtype with predicate in entry family + + Bad_Predicated_Subtype_Use + ("subtype& has predicate, not allowed in entry family", + D_Sdef, Etype (D_Sdef)); + + -- Check entry family static bounds outside allowed limits + + -- Note: originally this check was not performed here, but in that + -- case the check happens deep in the expander, and the message is + -- posted at the wrong location, and omitted in -gnatc mode. + -- If the type of the entry index is a generic formal, no check + -- is possible. In an instance, the check is not static and a run- + -- time exception will be raised if the bounds are unreasonable. + + declare + PEI : constant Entity_Id := RTE (RE_Protected_Entry_Index); + LB : constant Uint := Expr_Value (Type_Low_Bound (PEI)); + UB : constant Uint := Expr_Value (Type_High_Bound (PEI)); + + LBR : Node_Id; + UBR : Node_Id; + + begin + + -- No bounds checking if the type is generic or if previous error. + -- In an instance the check is dynamic. + + if Is_Generic_Type (Etype (D_Sdef)) + or else In_Instance + or else Error_Posted (D_Sdef) + then + goto Skip_LB; + + elsif Nkind (D_Sdef) = N_Range then + LBR := Low_Bound (D_Sdef); + + elsif Is_Entity_Name (D_Sdef) + and then Is_Type (Entity (D_Sdef)) + then + LBR := Type_Low_Bound (Entity (D_Sdef)); + + else + goto Skip_LB; + end if; + + if Is_Static_Expression (LBR) + and then Expr_Value (LBR) < LB + then + Error_Msg_Uint_1 := LB; + Error_Msg_N ("entry family low bound must be '>'= ^!", D_Sdef); + end if; + + <> + if Is_Generic_Type (Etype (D_Sdef)) + or else In_Instance + or else Error_Posted (D_Sdef) + then + goto Skip_UB; + + elsif Nkind (D_Sdef) = N_Range then + UBR := High_Bound (D_Sdef); + + elsif Is_Entity_Name (D_Sdef) + and then Is_Type (Entity (D_Sdef)) + then + UBR := Type_High_Bound (Entity (D_Sdef)); + + else + goto Skip_UB; + end if; + + if Is_Static_Expression (UBR) + and then Expr_Value (UBR) > UB + then + Error_Msg_Uint_1 := UB; + Error_Msg_N ("entry family high bound must be '<'= ^!", D_Sdef); + end if; + + <> + null; + end; end if; - Set_Etype (Id, Standard_Void_Type); - Set_Convention (Id, Convention_Entry); - Set_Accept_Address (Id, New_Elmt_List); + -- Decorate Def_Id + + Set_Etype (Def_Id, Standard_Void_Type); + Set_Convention (Def_Id, Convention_Entry); + Set_Accept_Address (Def_Id, New_Elmt_List); + + -- Process formals if Present (Formals) then - Set_Scope (Id, Current_Scope); - New_Scope (Id); + Set_Scope (Def_Id, Current_Scope); + Push_Scope (Def_Id); Process_Formals (Formals, N); - Create_Extra_Formals (Id); + Create_Extra_Formals (Def_Id); End_Scope; end if; - if Ekind (Id) = E_Entry then - New_Overloaded_Entity (Id); + if Ekind (Def_Id) = E_Entry then + New_Overloaded_Entity (Def_Id); + end if; + + Generate_Reference_To_Formals (Def_Id); + + if Has_Aspects (N) then + Analyze_Aspect_Specifications (N, Def_Id); end if; end Analyze_Entry_Declaration; @@ -864,22 +1015,20 @@ package body Sem_Ch9 is -- 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. + -- The Defining_Identifier of the entry index specification is local to the + -- entry body, but it must be available in the entry barrier which is + -- evaluated outside of the entry body. The index is eventually renamed as + -- a run-time object, so is visibility is strictly a front-end concern. In + -- order to make it available to the barrier, we create an additional + -- scope, as for a loop, whose only declaration is the index name. This + -- loop is not attached to the tree and does not appear as an entity local + -- to the protected type, so its existence need only be known to routines + -- that process entry families. procedure Analyze_Entry_Index_Specification (N : Node_Id) is Iden : constant Node_Id := Defining_Identifier (N); Def : constant Node_Id := Discrete_Subtype_Definition (N); - Loop_Id : constant Entity_Id := - Make_Defining_Identifier (Sloc (N), - Chars => New_Internal_Name ('L')); + Loop_Id : constant Entity_Id := Make_Temporary (Sloc (N), 'L'); begin Tasking_Used := True; @@ -896,7 +1045,7 @@ package body Sem_Ch9 is Set_Ekind (Loop_Id, E_Loop); Set_Scope (Loop_Id, Current_Scope); - New_Scope (Loop_Id); + Push_Scope (Loop_Id); Enter_Name (Iden); Set_Ekind (Iden, E_Entry_Index_Parameter); Set_Etype (Iden, Etype (Def)); @@ -907,8 +1056,8 @@ package body Sem_Ch9 is ---------------------------- procedure Analyze_Protected_Body (N : Node_Id) is - Body_Id : constant Entity_Id := Defining_Identifier (N); - Last_E : Entity_Id; + 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 @@ -918,9 +1067,9 @@ package body Sem_Ch9 is 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). + -- 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; @@ -953,21 +1102,21 @@ package body Sem_Ch9 is Spec_Id := Etype (Spec_Id); end if; - New_Scope (Spec_Id); + Push_Scope (Spec_Id); Set_Corresponding_Spec (N, Spec_Id); Set_Corresponding_Body (Parent (Spec_Id), Body_Id); Set_Has_Completion (Spec_Id); Install_Declarations (Spec_Id); - Exp_Ch9.Expand_Protected_Body_Declarations (N, Spec_Id); + Expand_Protected_Body_Declarations (N, Spec_Id); Last_E := Last_Entity (Spec_Id); Analyze_Declarations (Declarations (N)); - -- For visibility purposes, all entities in the body are private. - -- Set First_Private_Entity accordingly, if there was no private - -- part in the protected declaration. + -- 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 @@ -991,8 +1140,58 @@ package body Sem_Ch9 is E : Entity_Id; L : Entity_Id; + procedure Undelay_Itypes (T : Entity_Id); + -- Itypes created for the private components of a protected type + -- do not receive freeze nodes, because there is no scope in which + -- they can be elaborated, and they can depend on discriminants of + -- the enclosed protected type. Given that the components can be + -- composite types with inner components, we traverse recursively + -- the private components of the protected type, and indicate that + -- all itypes within are frozen. This ensures that no freeze nodes + -- will be generated for them. + -- + -- On the other hand, components of the corresponding record are + -- frozen (or receive itype references) as for other records. + + -------------------- + -- Undelay_Itypes -- + -------------------- + + procedure Undelay_Itypes (T : Entity_Id) is + Comp : Entity_Id; + + begin + if Is_Protected_Type (T) then + Comp := First_Private_Entity (T); + elsif Is_Record_Type (T) then + Comp := First_Entity (T); + else + return; + end if; + + while Present (Comp) loop + if Is_Type (Comp) + and then Is_Itype (Comp) + then + Set_Has_Delayed_Freeze (Comp, False); + Set_Is_Frozen (Comp); + + if Is_Record_Type (Comp) + or else Is_Protected_Type (Comp) + then + Undelay_Itypes (Comp); + end if; + end if; + + Next_Entity (Comp); + end loop; + end Undelay_Itypes; + + -- Start of processing for Analyze_Protected_Definition + begin Tasking_Used := True; + Check_SPARK_Restriction ("protected definition is not allowed", N); Analyze_Declarations (Visible_Declarations (N)); if Present (Private_Declarations (N)) @@ -1003,7 +1202,6 @@ package body Sem_Ch9 is if Present (L) then Set_First_Private_Entity (Current_Scope, Next_Entity (L)); - else Set_First_Private_Entity (Current_Scope, First_Entity (Current_Scope)); @@ -1011,12 +1209,8 @@ package body Sem_Ch9 is end if; E := First_Entity (Current_Scope); - while Present (E) loop - - if Ekind (E) = E_Function - or else Ekind (E) = E_Procedure - then + if Ekind_In (E, E_Function, E_Procedure) then Set_Convention (E, Convention_Protected); elsif Is_Task_Type (Etype (E)) @@ -1028,26 +1222,29 @@ package body Sem_Ch9 is Next_Entity (E); end loop; + Undelay_Itypes (Current_Scope); + 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 -- - ---------------------------- + ---------------------------------------- + -- Analyze_Protected_Type_Declaration -- + ---------------------------------------- - 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; + procedure Analyze_Protected_Type_Declaration (N : Node_Id) is + Def_Id : constant Entity_Id := Defining_Identifier (N); + E : Entity_Id; + T : Entity_Id; begin if No_Run_Time_Mode then Error_Msg_CRT ("protected type", N); + + if Has_Aspects (N) then + Analyze_Aspect_Specifications (N, Def_Id); + end if; + return; end if; @@ -1056,7 +1253,10 @@ package body Sem_Ch9 is T := Find_Type_Name (N); - if Ekind (T) = E_Incomplete_Type then + -- In the case of an incomplete type, use the full view, unless it's not + -- present (as can occur for an incomplete view from a limited with). + + if Ekind (T) = E_Incomplete_Type and then Present (Full_View (T)) then T := Full_View (T); Set_Completion_Referenced (T); end if; @@ -1067,56 +1267,17 @@ package body Sem_Ch9 is 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 - 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. + Push_Scope (T); - 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 Ada_Version >= Ada_2005 then + Check_Interfaces (N, T); end if; if Present (Discriminant_Specifications (N)) then if Has_Discriminants (T) then -- Install discriminants. Also, verify conformance of - -- discriminants of previous and current view. ??? + -- discriminants of previous and current view. ??? Install_Declarations (T); else @@ -1126,8 +1287,36 @@ package body Sem_Ch9 is Set_Is_Constrained (T, not Has_Discriminants (T)); + -- If aspects are present, analyze them now. They can make references + -- to the discriminants of the type, but not to any components. + + if Has_Aspects (N) then + Analyze_Aspect_Specifications (N, Def_Id); + end if; + Analyze (Protected_Definition (N)); + -- In the case where the protected type is declared at a nested level + -- and the No_Local_Protected_Objects restriction applies, issue a + -- warning that objects of the type will violate the restriction. + + if Restriction_Check_Required (No_Local_Protected_Objects) + and then not Is_Library_Level_Entity (T) + and then Comes_From_Source (T) + then + Error_Msg_Sloc := Restrictions_Loc (No_Local_Protected_Objects); + + if Error_Msg_Sloc = No_Location then + Error_Msg_N + ("objects of this type will violate " & + "`No_Local_Protected_Objects`?", N); + else + Error_Msg_N + ("objects of this type will violate " & + "`No_Local_Protected_Objects`?#", N); + end if; + end if; + -- Protected types with entries are controlled (because of the -- Protection component if nothing else), same for any protected type -- with interrupt handlers. Note that we need to analyze the protected @@ -1143,11 +1332,10 @@ package body Sem_Ch9 is 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. + -- 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); @@ -1159,44 +1347,65 @@ package body Sem_Ch9 is End_Scope; + -- Case of a completion of a private declaration + 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); + -- Deal with preelaborable initialization. Note that this processing + -- is done by Process_Full_View, but as can be seen below, in this + -- case the call to Process_Full_View is skipped if any serious + -- errors have occurred, and we don't want to lose this check. + + if Known_To_Have_Preelab_Init (Def_Id) then + Set_Must_Have_Preelab_Init (T); + end if; + + -- Create corresponding record now, because some private dependents + -- may be subtypes of the partial view. + + -- Skip if errors are present, to prevent cascaded messages + + if Serious_Errors_Detected = 0 + + -- Also skip if expander is not active + + and then Full_Expander_Active + then + Expand_N_Protected_Type_Declaration (N); + Process_Full_View (N, T, Def_Id); + end if; end if; - end Analyze_Protected_Type; + end Analyze_Protected_Type_Declaration; --------------------- -- Analyze_Requeue -- --------------------- procedure Analyze_Requeue (N : Node_Id) is - Count : Natural := 0; - Entry_Name : Node_Id := Name (N); - Entry_Id : Entity_Id; - I : Interp_Index; - It : Interp; - Enclosing : Entity_Id; - Target_Obj : Node_Id := Empty; - Req_Scope : Entity_Id; - Outer_Ent : Entity_Id; + Count : Natural := 0; + Entry_Name : Node_Id := Name (N); + Entry_Id : Entity_Id; + I : Interp_Index; + Is_Disp_Req : Boolean; + It : Interp; + Enclosing : Entity_Id; + Target_Obj : Node_Id := Empty; + Req_Scope : Entity_Id; + Outer_Ent : Entity_Id; begin + Tasking_Used := True; + Check_SPARK_Restriction ("requeue statement is not allowed", N); 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 + if not Ekind_In (Enclosing, E_Block, E_Loop) then Error_Msg_N ("requeue must appear within accept or entry body", N); return; end if; @@ -1213,8 +1422,8 @@ package body Sem_Ch9 is 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 an explicit target object is given then we have to check the + -- restrictions of 9.5.4(6). if Present (Target_Obj) then @@ -1235,10 +1444,10 @@ package body Sem_Ch9 is 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). + -- 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 @@ -1254,14 +1463,23 @@ package body Sem_Ch9 is -- Overloaded case, find right interpretation if Is_Overloaded (Entry_Name) then - Get_First_Interp (Entry_Name, I, It); Entry_Id := Empty; + -- Loop over candidate interpretations and filter out any that are + -- not parameterless, are not type conformant, are not entries, or + -- do not come from source. + + Get_First_Interp (Entry_Name, I, It); while Present (It.Nam) loop - if No (First_Formal (It.Nam)) - or else Subtype_Conformant (Enclosing, It.Nam) - then + -- Note: we test type conformance here, not subtype conformance. + -- Subtype conformance will be tested later on, but it is better + -- for error output in some cases not to do that here. + + if (No (First_Formal (It.Nam)) + or else (Type_Conformant (Enclosing, It.Nam))) + and then Ekind (It.Nam) = E_Entry + then -- Ada 2005 (AI-345): Since protected and task types have -- primitive entry wrappers, we only consider source entries. @@ -1291,8 +1509,8 @@ package body Sem_Ch9 is -- Non-overloaded cases - -- For the case of a reference to an element of an entry family, - -- the Entry_Name is an indexed component. + -- 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 @@ -1312,9 +1530,9 @@ package body Sem_Ch9 is 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. + -- 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 @@ -1328,11 +1546,27 @@ package body Sem_Ch9 is Entry_Id := Entity (Entry_Name); end if; + -- Ada 2012 (AI05-0030): Potential dispatching requeue statement. The + -- target type must be a concurrent interface class-wide type and the + -- target must be a procedure, flagged by pragma Implemented. + + Is_Disp_Req := + Ada_Version >= Ada_2012 + and then Present (Target_Obj) + and then Is_Class_Wide_Type (Etype (Target_Obj)) + and then Is_Concurrent_Interface (Etype (Target_Obj)) + and then Ekind (Entry_Id) = E_Procedure + and then Has_Rep_Pragma (Entry_Id, Name_Implemented); + -- Resolve entry, and check that it is subtype conformant with the -- enclosing construct if this construct has formals (RM 9.5.4(5)). + -- Ada 2005 (AI05-0030): Do not emit an error for this specific case. - if not Is_Entry (Entry_Id) then + if not Is_Entry (Entry_Id) + and then not Is_Disp_Req + then Error_Msg_N ("expect entry name in requeue statement", Name (N)); + elsif Ekind (Entry_Id) = E_Entry_Family and then Nkind (Entry_Name) /= N_Indexed_Component then @@ -1343,35 +1577,74 @@ package body Sem_Ch9 is Generate_Reference (Entry_Id, Entry_Name); if Present (First_Formal (Entry_Id)) then - Check_Subtype_Conformant (Enclosing, Entry_Id, Name (N)); + if VM_Target = JVM_Target then + Error_Msg_N + ("arguments unsupported in requeue statement", + First_Formal (Entry_Id)); + return; + end if; + + -- Ada 2012 (AI05-0030): Perform type conformance after skipping + -- the first parameter of Entry_Id since it is the interface + -- controlling formal. + + if Ada_Version >= Ada_2012 + and then Is_Disp_Req + then + declare + Enclosing_Formal : Entity_Id; + Target_Formal : Entity_Id; + + begin + Enclosing_Formal := First_Formal (Enclosing); + Target_Formal := Next_Formal (First_Formal (Entry_Id)); + while Present (Enclosing_Formal) + and then Present (Target_Formal) + loop + if not Conforming_Types + (T1 => Etype (Enclosing_Formal), + T2 => Etype (Target_Formal), + Ctype => Subtype_Conformant) + then + Error_Msg_Node_2 := Target_Formal; + Error_Msg_NE + ("formal & is not subtype conformant with &" & + "in dispatching requeue", N, Enclosing_Formal); + end if; + + Next_Formal (Enclosing_Formal); + Next_Formal (Target_Formal); + end loop; + end; + else + Check_Subtype_Conformant (Enclosing, Entry_Id, Name (N)); + end if; -- Processing for parameters accessed by the requeue declare - Ent : Entity_Id := First_Formal (Enclosing); + 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 + -- For OUT or IN OUT parameter, the effect of the requeue is + -- to assign the parameter a value on exit from the requeued + -- body, so we can set it as source assigned. We also clear + -- the Is_True_Constant indication. We do not need to clear + -- Current_Value, since the effect of the requeue is to + -- perform an unconditional goto so that any further + -- references will not occur anyway. + + if Ekind_In (Ent, E_Out_Parameter, E_In_Out_Parameter) then Set_Never_Set_In_Source (Ent, False); Set_Is_True_Constant (Ent, False); end if; -- For all parameters, the requeue acts as a reference, - -- since the value of the parameter is passed to the - -- new entry, so we want to suppress unreferenced warnings. + -- 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); @@ -1396,8 +1669,11 @@ package body Sem_Ch9 is Alt_Count : Uint := Uint_0; begin - Check_Restriction (No_Select_Statements, N); Tasking_Used := True; + Check_SPARK_Restriction ("select statement is not allowed", N); + Check_Restriction (No_Select_Statements, N); + + -- Loop to analyze alternatives Alt := First (Alts); while Present (Alt) loop @@ -1499,24 +1775,24 @@ package body Sem_Ch9 is end if; end Analyze_Selective_Accept; - ------------------------------ - -- Analyze_Single_Protected -- - ------------------------------ + ------------------------------------------ + -- Analyze_Single_Protected_Declaration -- + ------------------------------------------ - procedure Analyze_Single_Protected (N : Node_Id) is + procedure Analyze_Single_Protected_Declaration (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); Id : constant Node_Id := Defining_Identifier (N); T : Entity_Id; T_Decl : Node_Id; O_Decl : Node_Id; - O_Name : constant Entity_Id := New_Copy (Id); + O_Name : constant Entity_Id := Id; begin Generate_Definition (Id); Tasking_Used := True; - -- The node is rewritten as a protected type declaration, - -- in exact analogy with what is done with single tasks. + -- 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), @@ -1528,21 +1804,17 @@ package body Sem_Ch9 is Protected_Definition => Relocate_Node (Protected_Definition (N)), Interface_List => Interface_List (N)); - -- Ada 2005 (AI-399): Mark the object as aliased. Required to use - -- the attribute 'access - O_Decl := Make_Object_Declaration (Loc, Defining_Identifier => O_Name, - Aliased_Present => Ada_Version >= Ada_05, 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 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); @@ -1552,31 +1824,35 @@ package body Sem_Ch9 is 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. + -- 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_Protected_Type_Declaration (N); - ------------------------- - -- Analyze_Single_Task -- - ------------------------- + if Has_Aspects (N) then + Analyze_Aspect_Specifications (N, Id); + end if; + end Analyze_Single_Protected_Declaration; + + ------------------------------------- + -- Analyze_Single_Task_Declaration -- + ------------------------------------- - procedure Analyze_Single_Task (N : Node_Id) is + procedure Analyze_Single_Task_Declaration (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); Id : constant Node_Id := Defining_Identifier (N); T : Entity_Id; T_Decl : Node_Id; O_Decl : Node_Id; - O_Name : constant Entity_Id := New_Copy (Id); + O_Name : constant Entity_Id := Id; begin Generate_Definition (Id); Tasking_Used := True; - -- The node is rewritten as a task type declaration, followed - -- by an object declaration of that anonymous task type. + -- 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), @@ -1588,21 +1864,26 @@ package body Sem_Ch9 is Task_Definition => Relocate_Node (Task_Definition (N)), Interface_List => Interface_List (N)); - -- Ada 2005 (AI-399): Mark the object as aliased. Required to use - -- the attribute 'access + -- We use the original defining identifier of the single task in the + -- generated object declaration, so that debugging information can + -- be attached to it when compiling with -gnatD. The parent of the + -- entity is the new object declaration. The single_task_declaration + -- is not used further in semantics or code generation, but is scanned + -- when generating debug information, and therefore needs the updated + -- Sloc information for the entity (see Sprint). Aspect specifications + -- are moved from the single task node to the object declaration node. O_Decl := Make_Object_Declaration (Loc, Defining_Identifier => O_Name, - Aliased_Present => Ada_Version >= Ada_05, 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 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); @@ -1612,12 +1893,16 @@ package body Sem_Ch9 is 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. + -- 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_Type_Declaration (N); + + if Has_Aspects (N) then + Analyze_Aspect_Specifications (N, Id); + end if; + end Analyze_Single_Task_Declaration; ----------------------- -- Analyze_Task_Body -- @@ -1625,17 +1910,19 @@ package body Sem_Ch9 is procedure Analyze_Task_Body (N : Node_Id) is Body_Id : constant Entity_Id := Defining_Identifier (N); + Decls : constant List_Id := Declarations (N); + HSS : constant Node_Id := Handled_Statement_Sequence (N); Last_E : Entity_Id; Spec_Id : Entity_Id; - -- This is initially the entity of the task or task type involved, - -- but is replaced by the task type always in the case of a single - -- task declaration, since this is the proper scope to be used. + -- 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) + -- 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; @@ -1683,18 +1970,19 @@ package body Sem_Ch9 is Spec_Id := Etype (Spec_Id); end if; - New_Scope (Spec_Id); + Push_Scope (Spec_Id); Set_Corresponding_Spec (N, Spec_Id); Set_Corresponding_Body (Parent (Spec_Id), Body_Id); Set_Has_Completion (Spec_Id); Install_Declarations (Spec_Id); Last_E := Last_Entity (Spec_Id); - Analyze_Declarations (Declarations (N)); + Analyze_Declarations (Decls); + Inspect_Deferred_Constant_Completion (Decls); - -- For visibility purposes, all entities in the body are private. - -- Set First_Private_Entity accordingly, if there was no private - -- part in the protected declaration. + -- 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 @@ -1704,7 +1992,24 @@ package body Sem_Ch9 is end if; end if; - Analyze (Handled_Statement_Sequence (N)); + -- Mark all handlers as not suitable for local raise optimization, + -- since this optimization causes difficulties in a task context. + + if Present (Exception_Handlers (HSS)) then + declare + Handlr : Node_Id; + begin + Handlr := First (Exception_Handlers (HSS)); + while Present (Handlr) loop + Set_Local_Raise_Not_OK (Handlr); + Next (Handlr); + end loop; + end; + end if; + + -- Now go ahead and complete analysis of the task body + + Analyze (HSS); Check_Completion (Body_Id); Check_References (Body_Id); Check_References (Spec_Id); @@ -1716,7 +2021,6 @@ package body Sem_Ch9 is begin Ent := First_Entity (Spec_Id); - while Present (Ent) loop if Is_Entry (Ent) and then not Entry_Accepted (Ent) @@ -1729,7 +2033,7 @@ package body Sem_Ch9 is end loop; end; - Process_End_Label (Handled_Statement_Sequence (N), 't', Ref_Id); + Process_End_Label (HSS, 't', Ref_Id); End_Scope; end Analyze_Task_Body; @@ -1742,6 +2046,7 @@ package body Sem_Ch9 is begin Tasking_Used := True; + Check_SPARK_Restriction ("task definition is not allowed", N); if Present (Visible_Declarations (N)) then Analyze_Declarations (Visible_Declarations (N)); @@ -1762,19 +2067,15 @@ package body Sem_Ch9 is 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 -- - ----------------------- + ----------------------------------- + -- Analyze_Task_Type_Declaration -- + ----------------------------------- - 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; + procedure Analyze_Task_Type_Declaration (N : Node_Id) is + Def_Id : constant Entity_Id := Defining_Identifier (N); + T : Entity_Id; begin Check_Restriction (No_Tasking, N); @@ -1782,9 +2083,20 @@ package body Sem_Ch9 is T := Find_Type_Name (N); Generate_Definition (T); + -- In the case of an incomplete type, use the full view, unless it's not + -- present (as can occur for an incomplete view from a limited with). + -- Initialize the Corresponding_Record_Type (which overlays the Private + -- Dependents field of the incomplete view). + if Ekind (T) = E_Incomplete_Type then - T := Full_View (T); - Set_Completion_Referenced (T); + if Present (Full_View (T)) then + T := Full_View (T); + Set_Completion_Referenced (T); + + else + Set_Ekind (T, E_Task_Type); + Set_Corresponding_Record_Type (T, Empty); + end if; end if; Set_Ekind (T, E_Task_Type); @@ -1794,47 +2106,10 @@ package body Sem_Ch9 is 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 - 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); + Push_Scope (T); - 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 Ada_Version >= Ada_2005 then + Check_Interfaces (N, T); end if; if Present (Discriminant_Specifications (N)) then @@ -1845,7 +2120,7 @@ package body Sem_Ch9 is if Has_Discriminants (T) then -- Install discriminants. Also, verify conformance of - -- discriminants of previous and current view. ??? + -- discriminants of previous and current view. ??? Install_Declarations (T); else @@ -1855,25 +2130,65 @@ package body Sem_Ch9 is Set_Is_Constrained (T, not Has_Discriminants (T)); + if Has_Aspects (N) then + Analyze_Aspect_Specifications (N, Def_Id); + end if; + if Present (Task_Definition (N)) then Analyze_Task_Definition (Task_Definition (N)); end if; - if not Is_Library_Level_Entity (T) then - Check_Restriction (No_Task_Hierarchy, N); + -- In the case where the task type is declared at a nested level and the + -- No_Task_Hierarchy restriction applies, issue a warning that objects + -- of the type will violate the restriction. + + if Restriction_Check_Required (No_Task_Hierarchy) + and then not Is_Library_Level_Entity (T) + and then Comes_From_Source (T) + then + Error_Msg_Sloc := Restrictions_Loc (No_Task_Hierarchy); + + if Error_Msg_Sloc = No_Location then + Error_Msg_N + ("objects of this type will violate `No_Task_Hierarchy`?", N); + else + Error_Msg_N + ("objects of this type will violate `No_Task_Hierarchy`?#", N); + end if; end if; End_Scope; + -- Case of a completion of a private declaration + if T /= Def_Id and then Is_Private_Type (Def_Id) - 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); + -- Deal with preelaborable initialization. Note that this processing + -- is done by Process_Full_View, but as can be seen below, in this + -- case the call to Process_Full_View is skipped if any serious + -- errors have occurred, and we don't want to lose this check. + + if Known_To_Have_Preelab_Init (Def_Id) then + Set_Must_Have_Preelab_Init (T); + end if; + + -- Create corresponding record now, because some private dependents + -- may be subtypes of the partial view. + + -- Skip if errors are present, to prevent cascaded messages + + if Serious_Errors_Detected = 0 + + -- Also skip if expander is not active + + and then Full_Expander_Active + then + Expand_N_Task_Type_Declaration (N); + Process_Full_View (N, T, Def_Id); + end if; end if; - end Analyze_Task_Type; + end Analyze_Task_Type_Declaration; ----------------------------------- -- Analyze_Terminate_Alternative -- @@ -1897,11 +2212,37 @@ package body Sem_Ch9 is ------------------------------ procedure Analyze_Timed_Entry_Call (N : Node_Id) is + Trigger : constant Node_Id := + Entry_Call_Statement (Entry_Call_Alternative (N)); + Is_Disp_Select : Boolean := False; + begin - Check_Restriction (No_Select_Statements, N); Tasking_Used := True; - Analyze (Entry_Call_Alternative (N)); - Analyze (Delay_Alternative (N)); + Check_SPARK_Restriction ("select statement is not allowed", N); + Check_Restriction (No_Select_Statements, N); + + -- Ada 2005 (AI-345): The trigger may be a dispatching call + + if Ada_Version >= Ada_2005 then + Analyze (Trigger); + Check_Triggering_Statement (Trigger, N, Is_Disp_Select); + end if; + + -- Postpone the analysis of the statements till expansion. Analyze only + -- if the expander is disabled in order to catch any semantic errors. + + if Is_Disp_Select then + if not Expander_Active then + Analyze (Entry_Call_Alternative (N)); + Analyze (Delay_Alternative (N)); + end if; + + -- Regular select analysis + + else + Analyze (Entry_Call_Alternative (N)); + Analyze (Delay_Alternative (N)); + end if; end Analyze_Timed_Entry_Call; ------------------------------------ @@ -1919,21 +2260,20 @@ package body Sem_Ch9 is 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) not in N_Delay_Statement and then Nkind (Trigger) /= N_Entry_Call_Statement then - if Ada_Version < Ada_05 then + if Ada_Version < Ada_2005 then Error_Msg_N ("triggering statement must be delay or entry call", Trigger); - -- Ada 2005 (AI-345): If a procedure_call_statement is used - -- for a procedure_or_entry_call, the procedure_name or 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. + -- Ada 2005 (AI-345): If a procedure_call_statement is used for a + -- procedure_or_entry_call, the procedure_name or procedure_prefix + -- of the procedure_call_statement shall denote an entry renamed by a + -- procedure, or (a view of) a primitive subprogram of a limited + -- interface whose first parameter is a controlling parameter. elsif Nkind (Trigger) = N_Procedure_Call_Statement and then not Is_Renamed_Entry (Entity (Name (Trigger))) @@ -2005,18 +2345,10 @@ package body Sem_Ch9 is -- 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); + -- Record an unknown count restriction, and if the + -- restriction is active, post a message or warning. - -- Otherwise we record an unknown count restriction - - else - Check_Restriction (R, D); - end if; + Check_Restriction (R, D); end if; end; end if; @@ -2037,262 +2369,207 @@ package body Sem_Ch9 is end if; end Check_Max_Entries; - -------------------------------- - -- Check_Overriding_Indicator -- - -------------------------------- + ---------------------- + -- Check_Interfaces -- + ---------------------- - 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; + procedure Check_Interfaces (N : Node_Id; T : Entity_Id) is + Iface : Node_Id; + Iface_Typ : Entity_Id; - begin - Ent := First (Ifaces); + begin + pragma Assert + (Nkind_In (N, N_Protected_Type_Declaration, N_Task_Type_Declaration)); - while Present (Ent) loop - if Etype (Ent) = Iface then - return True; - end if; + if Present (Interface_List (N)) then + Set_Is_Tagged_Type (T); - Next (Ent); - end loop; + Iface := First (Interface_List (N)); + while Present (Iface) loop + Iface_Typ := Find_Type_Of_Subtype_Indic (Iface); + + if not Is_Interface (Iface_Typ) then + Error_Msg_NE + ("(Ada 2005) & must be an interface", Iface, Iface_Typ); - return False; - end Includes_Interface; + else + -- Ada 2005 (AI-251): "The declaration of a specific descendant + -- of an interface type freezes the interface type" RM 13.14. - -- Start of processing for Matches_Prefixed_View_Profile + Freeze_Before (N, Etype (Iface)); - begin - Proc_Param := First (Proc_Params); - Proc_Param_Typ := Etype (Parameter_Type (Proc_Param)); + if Nkind (N) = N_Protected_Type_Declaration then - -- The first parameter of the abstract procedure must be of an - -- interface type. The task or protected type must also implement - -- that interface. + -- Ada 2005 (AI-345): Protected types can only implement + -- limited, synchronized, or protected interfaces (note that + -- the predicate Is_Limited_Interface includes synchronized + -- and protected interfaces). - if not Is_Interface (Proc_Param_Typ) - or else not Includes_Interface (Proc_Param_Typ, Ifaces) - then - return False; - end if; + if Is_Task_Interface (Iface_Typ) then + Error_Msg_N ("(Ada 2005) protected type cannot implement " + & "a task interface", Iface); - 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. + elsif not Is_Limited_Interface (Iface_Typ) then + Error_Msg_N ("(Ada 2005) protected type cannot implement " + & "a non-limited interface", Iface); + end if; - if In_Present (Entry_Param) /= In_Present (Proc_Param) - or else Out_Present (Entry_Param) /= Out_Present (Proc_Param) - or else Etype (Parameter_Type (Entry_Param)) /= - Etype (Parameter_Type (Proc_Param)) - then - return False; + else pragma Assert (Nkind (N) = N_Task_Type_Declaration); + + -- Ada 2005 (AI-345): Task types can only implement limited, + -- synchronized, or task interfaces (note that the predicate + -- Is_Limited_Interface includes synchronized and task + -- interfaces). + + if Is_Protected_Interface (Iface_Typ) then + Error_Msg_N ("(Ada 2005) task type cannot implement a " & + "protected interface", Iface); + + elsif not Is_Limited_Interface (Iface_Typ) then + Error_Msg_N ("(Ada 2005) task type cannot implement a " & + "non-limited interface", Iface); + end if; + end if; end if; - Next (Entry_Param); - Next (Proc_Param); + Next (Iface); end loop; + end if; - -- One of the lists is longer than the other + if not Has_Private_Declaration (T) then + return; + end if; - if Present (Entry_Param) or else Present (Proc_Param) then - return False; - end if; + -- Additional checks on full-types associated with private type + -- declarations. Search for the private type declaration. - return True; - end Matches_Prefixed_View_Profile; + declare + Full_T_Ifaces : Elist_Id; + Iface : Node_Id; + Priv_T : Entity_Id; + Priv_T_Ifaces : Elist_Id; - -- Start of processing for Check_Overriding_Indicator + begin + Priv_T := First_Entity (Scope (T)); + loop + pragma Assert (Present (Priv_T)); - begin - if Present (Ifaces) then - Decl := First (Vis_Decls); - while Present (Decl) loop + if Is_Type (Priv_T) and then Present (Full_View (Priv_T)) then + exit when Full_View (Priv_T) = T; + end if; - -- Consider entries with either "overriding" or "not overriding" - -- indicator present. + Next_Entity (Priv_T); + end loop; - if Nkind (Decl) = N_Entry_Declaration - and then (Must_Override (Decl) - or else - Must_Not_Override (Decl)) - then - Def_Id := Defining_Identifier (Decl); + -- In case of synchronized types covering interfaces the private type + -- declaration must be limited. - Overrides := False; + if Present (Interface_List (N)) + and then not Is_Limited_Type (Priv_T) + then + Error_Msg_Sloc := Sloc (Priv_T); + Error_Msg_N ("(Ada 2005) limited type declaration expected for " & + "private type#", T); + end if; - Hom := Homonym (Def_Id); - while Present (Hom) loop + -- RM 7.3 (7.1/2): If the full view has a partial view that is + -- tagged then check RM 7.3 subsidiary rules. - -- The current entry may override a procedure from an - -- implemented interface. + if Is_Tagged_Type (Priv_T) + and then not Error_Posted (N) + then + -- RM 7.3 (7.2/2): The partial view shall be a synchronized tagged + -- type if and only if the full type is a synchronized tagged type - if Ekind (Hom) = E_Procedure - and then (Is_Abstract (Hom) - or else - Null_Present (Parent (Hom))) - then - Aliased_Hom := Hom; + if Is_Synchronized_Tagged_Type (Priv_T) + and then not Is_Synchronized_Tagged_Type (T) + then + Error_Msg_N + ("(Ada 2005) full view must be a synchronized tagged " & + "type (RM 7.3 (7.2/2))", Priv_T); - while Present (Alias (Aliased_Hom)) loop - Aliased_Hom := Alias (Aliased_Hom); - end loop; + elsif Is_Synchronized_Tagged_Type (T) + and then not Is_Synchronized_Tagged_Type (Priv_T) + then + Error_Msg_N + ("(Ada 2005) partial view must be a synchronized tagged " & + "type (RM 7.3 (7.2/2))", T); + end if; - if Matches_Prefixed_View_Profile (Ifaces, - Parameter_Specifications (Decl), - Parameter_Specifications (Parent (Aliased_Hom))) - then - Overrides := True; - exit; - end if; - end if; + -- RM 7.3 (7.3/2): The partial view shall be a descendant of an + -- interface type if and only if the full type is descendant of + -- the interface type. - Hom := Homonym (Hom); - end loop; + if Present (Interface_List (N)) + or else (Is_Tagged_Type (Priv_T) + and then Has_Interfaces + (Priv_T, Use_Full_View => False)) + then + if Is_Tagged_Type (Priv_T) then + Collect_Interfaces + (Priv_T, Priv_T_Ifaces, Use_Full_View => False); + end if; - if 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; + if Is_Tagged_Type (T) then + Collect_Interfaces (T, Full_T_Ifaces); end if; - -- Consider subprograms with either "overriding" or "not - -- overriding" indicator present. + Iface := Find_Hidden_Interface (Priv_T_Ifaces, Full_T_Ifaces); - 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; + if Present (Iface) then + Error_Msg_NE + ("interface & not implemented by full type " & + "(RM-2005 7.3 (7.3/2))", Priv_T, Iface); + end if; - Hom := Homonym (Hom); - end loop; + Iface := Find_Hidden_Interface (Full_T_Ifaces, Priv_T_Ifaces); - 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; + if Present (Iface) then + Error_Msg_NE + ("interface & not implemented by partial " & + "view (RM-2005 7.3 (7.3/2))", T, Iface); end if; end if; + end if; + end; + end Check_Interfaces; - Next (Decl); - end loop; + -------------------------------- + -- Check_Triggering_Statement -- + -------------------------------- - -- 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. + procedure Check_Triggering_Statement + (Trigger : Node_Id; + Error_Node : Node_Id; + Is_Dispatching : out Boolean) + is + Param : Node_Id; - else - Decl := First (Vis_Decls); + begin + Is_Dispatching := False; - 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); + -- It is not possible to have a dispatching trigger if we are not in + -- Ada 2005 mode. - 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; + if Ada_Version >= Ada_2005 + and then Nkind (Trigger) = N_Procedure_Call_Statement + and then Present (Parameter_Associations (Trigger)) + then + Param := First (Parameter_Associations (Trigger)); - Next (Decl); - end loop; + if Is_Controlling_Actual (Param) + and then Is_Interface (Etype (Param)) + then + if Is_Limited_Record (Etype (Param)) then + Is_Dispatching := True; + else + Error_Msg_N + ("dispatching operation of limited or synchronized " & + "interface required (RM 9.7.2(3))!", Error_Node); + end if; + end if; end if; - end Check_Overriding_Indicator; + end Check_Triggering_Statement; -------------------------- -- Find_Concurrent_Spec -- @@ -2319,10 +2596,8 @@ package body Sem_Ch9 is 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);