From ac7d724dc0ecc1ea34daae88f41f9b3870cfbc0f Mon Sep 17 00:00:00 2001 From: Ed Schonberg Date: Thu, 11 Apr 2013 09:35:46 +0000 Subject: [PATCH] sem_ch5.adb: remove spurious warning from non-empty loop. 2013-04-11 Ed Schonberg * sem_ch5.adb: remove spurious warning from non-empty loop. * sem_ch8.adb (Enclosing_Instance): Make public to other routines in the package, in order to suppress redundant semantic checks on subprogram renamings in nested instantiations. From-SVN: r197746 --- gcc/ada/ChangeLog | 7 + gcc/ada/sem_ch5.adb | 123 +++++++------- gcc/ada/sem_ch8.adb | 392 ++++++++++++++++++-------------------------- 3 files changed, 228 insertions(+), 294 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index d72ad62485d..a9c5133eb8f 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,10 @@ +2013-04-11 Ed Schonberg + + * sem_ch5.adb: remove spurious warning from non-empty loop. + * sem_ch8.adb (Enclosing_Instance): Make public to other routines + in the package, in order to suppress redundant semantic checks + on subprogram renamings in nested instantiations. + 2013-04-11 Robert Dewar * errout.ads: Minor reformatting. diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index 2e8f3a7b2f0..d098609d5c5 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -141,13 +141,13 @@ package body Sem_Ch5 is -- directly. elsif (Is_Prival (Ent) - and then - (Ekind (Current_Scope) = E_Function - or else Ekind (Enclosing_Dynamic_Scope - (Current_Scope)) = E_Function)) + and then + (Ekind (Current_Scope) = E_Function + or else Ekind (Enclosing_Dynamic_Scope + (Current_Scope)) = E_Function)) or else (Ekind (Ent) = E_Component - and then Is_Protected_Type (Scope (Ent))) + and then Is_Protected_Type (Scope (Ent))) then Error_Msg_N ("protected function cannot modify protected object", N); @@ -222,16 +222,15 @@ package body Sem_Ch5 is if Is_Entity_Name (Opnd) and then (Ekind (Entity (Opnd)) = E_Out_Parameter - or else Ekind (Entity (Opnd)) = - E_In_Out_Parameter - or else Ekind (Entity (Opnd)) = - E_Generic_In_Out_Parameter + or else Ekind_In (Entity (Opnd), + E_In_Out_Parameter, + E_Generic_In_Out_Parameter) or else (Ekind (Entity (Opnd)) = E_Variable and then Nkind (Parent (Entity (Opnd))) = - N_Object_Renaming_Declaration + N_Object_Renaming_Declaration and then Nkind (Parent (Parent (Entity (Opnd)))) = - N_Accept_Statement)) + N_Accept_Statement)) then Opnd_Type := Get_Actual_Subtype (Opnd); @@ -394,7 +393,7 @@ package body Sem_Ch5 is end loop; if (Nkind (Ent) = N_Attribute_Reference - and then Attribute_Name (Ent) = Name_Priority) + and then Attribute_Name (Ent) = Name_Priority) -- Renamings of the attribute Priority applied to protected -- objects have been previously expanded into calls to the @@ -402,15 +401,15 @@ package body Sem_Ch5 is or else (Nkind (Ent) = N_Function_Call - and then (Entity (Name (Ent)) = RTE (RE_Get_Ceiling) - or else - Entity (Name (Ent)) = RTE (RO_PE_Get_Ceiling))) + and then (Entity (Name (Ent)) = RTE (RE_Get_Ceiling) + or else + Entity (Name (Ent)) = RTE (RO_PE_Get_Ceiling))) then -- The enclosing subprogram cannot be a protected function S := Current_Scope; while not (Is_Subprogram (S) - and then Convention (S) = Convention_Protected) + and then Convention (S) = Convention_Protected) and then S /= Standard_Standard loop S := Scope (S); @@ -583,8 +582,8 @@ package body Sem_Ch5 is Propagate_Tag (Lhs, Rhs); elsif Nkind (Rhs) = N_Function_Call - and then Is_Entity_Name (Name (Rhs)) - and then Is_Abstract_Subprogram (Entity (Name (Rhs))) + and then Is_Entity_Name (Name (Rhs)) + and then Is_Abstract_Subprogram (Entity (Name (Rhs))) then Error_Msg_N ("call to abstract function must be dispatching", Name (Rhs)); @@ -607,9 +606,7 @@ package body Sem_Ch5 is -- as well to anonymous access-to-subprogram types that are component -- subtypes or formal parameters. - if Ada_Version >= Ada_2005 - and then Is_Access_Type (T1) - then + if Ada_Version >= Ada_2005 and then Is_Access_Type (T1) then if Is_Local_Anonymous_Access (T1) or else Ekind (T2) = E_Anonymous_Access_Subprogram_Type @@ -665,12 +662,10 @@ package body Sem_Ch5 is -- assignment within the block. elsif Is_Array_Type (T1) - and then - (Nkind (Rhs) /= N_Type_Conversion - or else Is_Constrained (Etype (Rhs))) - and then - (Nkind (Rhs) /= N_Function_Call - or else Nkind (N) /= N_Block_Statement) + and then (Nkind (Rhs) /= N_Type_Conversion + or else Is_Constrained (Etype (Rhs))) + and then (Nkind (Rhs) /= N_Function_Call + or else Nkind (N) /= N_Block_Statement) then -- Assignment verifies that the length of the Lsh and Rhs are equal, -- but of course the indexes do not have to match. If the right-hand @@ -1172,7 +1167,7 @@ package body Sem_Ch5 is elsif Ada_Version = Ada_83 and then (Is_Generic_Type (Exp_Btype) - or else Is_Generic_Type (Root_Type (Exp_Btype))) + or else Is_Generic_Type (Root_Type (Exp_Btype))) then Error_Msg_N ("(Ada 83) case expression cannot be of a generic type", Exp); @@ -1198,9 +1193,7 @@ package body Sem_Ch5 is -- A case statement with a single OTHERS alternative is not allowed -- in SPARK. - if Others_Present - and then List_Length (Alternatives (N)) = 1 - then + if Others_Present and then List_Length (Alternatives (N)) = 1 then Check_SPARK_Restriction ("OTHERS as unique case alternative is not allowed", N); end if; @@ -1297,9 +1290,7 @@ package body Sem_Ch5 is Scope_Id := Scope_Stack.Table (J).Entity; Kind := Ekind (Scope_Id); - if Kind = E_Loop - and then (No (Target) or else Scope_Id = U_Name) - then + if Kind = E_Loop and then (No (Target) or else Scope_Id = U_Name) then Set_Has_Exit (Scope_Id); exit; @@ -1423,9 +1414,7 @@ package body Sem_Ch5 is Scope_Id := Scope_Stack.Table (J).Entity; if Label_Scope = Scope_Id - or else (Ekind (Scope_Id) /= E_Block - and then Ekind (Scope_Id) /= E_Loop - and then Ekind (Scope_Id) /= E_Return_Statement) + or else not Ekind_In (Scope_Id, E_Block, E_Loop, E_Return_Statement) then if Scope_Id /= Label_Scope then Error_Msg_N @@ -1447,9 +1436,9 @@ package body Sem_Ch5 is -- The expander has circuitry to completely delete code that it can tell -- will not be executed (as a result of compile time known conditions). In - -- the analyzer, we ensure that code that will be deleted in this manner is - -- analyzed but not expanded. This is obviously more efficient, but more - -- significantly, difficulties arise if code is expanded and then + -- the analyzer, we ensure that code that will be deleted in this manner + -- is analyzed but not expanded. This is obviously more efficient, but + -- more significantly, difficulties arise if code is expanded and then -- eliminated (e.g. exception table entries disappear). Similarly, itypes -- generated in deleted code must be frozen from start, because the nodes -- on which they depend will not be available at the freeze point. @@ -2161,15 +2150,11 @@ package body Sem_Ch5 is -- Propagate staticness to loop range itself, in case the -- corresponding subtype is static. - if New_Lo /= Lo - and then Is_Static_Expression (New_Lo) - then + if New_Lo /= Lo and then Is_Static_Expression (New_Lo) then Rewrite (Low_Bound (R), New_Copy (New_Lo)); end if; - if New_Hi /= Hi - and then Is_Static_Expression (New_Hi) - then + if New_Hi /= Hi and then Is_Static_Expression (New_Hi) then Rewrite (High_Bound (R), New_Copy (New_Hi)); end if; end Process_Bounds; @@ -2238,9 +2223,8 @@ package body Sem_Ch5 is -- new iterator form. if Nkind (DS_Copy) = N_Function_Call - or else - (Is_Entity_Name (DS_Copy) - and then not Is_Type (Entity (DS_Copy))) + or else (Is_Entity_Name (DS_Copy) + and then not Is_Type (Entity (DS_Copy))) then -- This is an iterator specification. Rewrite it as such and -- analyze it to capture function calls that may require @@ -2351,7 +2335,7 @@ package body Sem_Ch5 is and then Is_Itype (Etype (Id)) and then Nkind (Parent (Loop_Nod)) = N_Expression_With_Actions and then Nkind (Original_Node (Parent (Loop_Nod))) = - N_Quantified_Expression) + N_Quantified_Expression) then Set_Etype (Id, Etype (DS)); end if; @@ -2395,9 +2379,8 @@ package body Sem_Ch5 is -- instance, since in practice they tend to be dubious in these -- cases since they can result from intended parametrization. - if not Inside_A_Generic - and then not In_Instance - then + if not Inside_A_Generic and then not In_Instance then + -- Specialize msg if invalid values could make the loop -- non-null after all. @@ -2436,7 +2419,7 @@ package body Sem_Ch5 is -- The other case for a warning is a reverse loop where the -- upper bound is the integer literal zero or one, and the - -- lower bound can be positive. + -- lower bound may exceed this value. -- For example, we have @@ -2449,10 +2432,23 @@ package body Sem_Ch5 is and then Nkind (Original_Node (H)) = N_Integer_Literal and then (Intval (Original_Node (H)) = Uint_0 - or else Intval (Original_Node (H)) = Uint_1) + or else + Intval (Original_Node (H)) = Uint_1) then - Error_Msg_N ("??loop range may be null", DS); - Error_Msg_N ("\??bounds may be wrong way round", DS); + -- Lower bound may in fact be known and known not to exceed + -- upper bound (e.g. reverse 0 .. 1) and that's OK. + + if Compile_Time_Known_Value (L) + and then Expr_Value (L) <= Expr_Value (H) + then + null; + + -- Otherwise warning is warranted + + else + Error_Msg_N ("??loop range may be null", DS); + Error_Msg_N ("\??bounds may be wrong way round", DS); + end if; end if; end; end if; @@ -2839,9 +2835,7 @@ package body Sem_Ch5 is P : Node_Id; begin - if Is_List_Member (N) - and then Comes_From_Source (N) - then + if Is_List_Member (N) and then Comes_From_Source (N) then declare Nxt : Node_Id; @@ -2993,9 +2987,8 @@ package body Sem_Ch5 is Analyze (R_Copy); - if Nkind (R_Copy) in N_Subexpr - and then Is_Overloaded (R_Copy) - then + if Nkind (R_Copy) in N_Subexpr and then Is_Overloaded (R_Copy) then + -- Apply preference rules for range of predefined integer types, or -- diagnose true ambiguity. @@ -3037,9 +3030,7 @@ package body Sem_Ch5 is -- Subtype mark in iteration scheme - if Is_Entity_Name (R_Copy) - and then Is_Type (Entity (R_Copy)) - then + if Is_Entity_Name (R_Copy) and then Is_Type (Entity (R_Copy)) then null; -- Expression in range, or Ada 2012 iterator diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index 9ff423b36fc..214fb11800f 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -450,6 +450,25 @@ package body Sem_Ch8 is -- when compiling a subunit or instantiating a generic body on the fly, -- when it is necessary to save and restore full environments. + function Enclosing_Instance return Entity_Id; + -- In an instance nested within another one, several semantic checks are + -- unnecessary because the legality of the nested instance has been checked + -- in the enclosing generic unit. This applies in particular to legality + -- checks on actuals for formal subprograms of the inner instance, which + -- are checked as subprogram renamings, and may be complicated by confusion + -- in private/full views. This function returns the instance enclosing the + -- current one if there is such, else it returns Empty. + -- + -- If the renaming determines the entity for the default of a formal + -- subprogram nested within another instance, choose the innermost + -- candidate. This is because if the formal has a box, and we are within + -- an enclosing instance where some candidate interpretations are local + -- to this enclosing instance, we know that the default was properly + -- resolved when analyzing the generic, so we prefer the local + -- candidates to those that are external. This is not always the case + -- but is a reasonable heuristic on the use of nested generics. The + -- proper solution requires a full renaming model. + function Has_Implicit_Character_Literal (N : Node_Id) return Boolean; -- Find a type derived from Character or Wide_Character in the prefix of N. -- Used to resolved qualified names whose selector is a character literal. @@ -1076,9 +1095,7 @@ package body Sem_Ch8 is then null; - elsif Ada_Version >= Ada_2005 - and then Nkind (Nam) in N_Has_Entity - then + elsif Ada_Version >= Ada_2005 and then Nkind (Nam) in N_Has_Entity then declare Nam_Decl : Node_Id; Nam_Ent : Entity_Id; @@ -1103,7 +1120,7 @@ package body Sem_Ch8 is -- have a null exclusion or a null-excluding subtype. if Is_Formal_Object (Nam_Ent) - and then In_Generic_Scope (Id) + and then In_Generic_Scope (Id) then if not Can_Never_Be_Null (Etype (Nam_Ent)) then Error_Msg_N @@ -1132,10 +1149,10 @@ package body Sem_Ch8 is elsif Nkind (Nam_Decl) = N_Object_Declaration and then In_Instance - and then Present - (Corresponding_Generic_Association (Nam_Decl)) - and then Nkind (Expression (Nam_Decl)) - = N_Raise_Constraint_Error + and then + Present (Corresponding_Generic_Association (Nam_Decl)) + and then Nkind (Expression (Nam_Decl)) = + N_Raise_Constraint_Error then Error_Msg_N ("renamed actual does not exclude `NULL` " @@ -1214,7 +1231,7 @@ package body Sem_Ch8 is Nkind (Original_Node (Nam)) /= N_Attribute_Reference) or else (Nkind (Nam) = N_Type_Conversion - and then Is_Tagged_Type (Entity (Subtype_Mark (Nam)))) + and then Is_Tagged_Type (Entity (Subtype_Mark (Nam)))) then null; @@ -1385,9 +1402,7 @@ package body Sem_Ch8 is begin E := First_Entity (Old_P); - while Present (E) - and then E /= New_P - loop + while Present (E) and then E /= New_P loop if Is_Type (E) and then Nkind (Parent (E)) = N_Subtype_Declaration then @@ -1589,8 +1604,7 @@ package body Sem_Ch8 is begin if (Is_Entity_Name (P) and then Ekind (Entity (P)) = E_Entry_Family) or else (Nkind (P) = N_Selected_Component - and then - Ekind (Entity (Selector_Name (P))) = E_Entry_Family) + and then Ekind (Entity (Selector_Name (P))) = E_Entry_Family) then if Is_Entity_Name (P) then Old_S := Entity (P); @@ -1982,13 +1996,11 @@ package body Sem_Ch8 is Ren_Formal := First_Formal (Ren); Sub_Formal := First_Formal (Sub); - while Present (Ren_Formal) - and then Present (Sub_Formal) - loop + while Present (Ren_Formal) and then Present (Sub_Formal) loop if Has_Null_Exclusion (Parent (Ren_Formal)) and then not (Has_Null_Exclusion (Parent (Sub_Formal)) - or else Can_Never_Be_Null (Etype (Sub_Formal))) + or else Can_Never_Be_Null (Etype (Sub_Formal))) then Error_Msg_NE ("`NOT NULL` required for parameter &", @@ -2004,9 +2016,8 @@ package body Sem_Ch8 is if Nkind (Parent (Ren)) = N_Function_Specification and then Nkind (Parent (Sub)) = N_Function_Specification and then Has_Null_Exclusion (Parent (Ren)) - and then - not (Has_Null_Exclusion (Parent (Sub)) - or else Can_Never_Be_Null (Etype (Sub))) + and then not (Has_Null_Exclusion (Parent (Sub)) + or else Can_Never_Be_Null (Etype (Sub))) then Error_Msg_N ("return must specify `NOT NULL`", @@ -2081,9 +2092,7 @@ package body Sem_Ch8 is then F_Nam := First_Entity (Entity (Nam)); F_Spec := First_Formal (Formal_Spec); - while Present (F_Nam) - and then Present (F_Spec) - loop + while Present (F_Nam) and then Present (F_Spec) loop if Is_Controlling_Formal (F_Nam) and then Has_Unknown_Discriminants (Etype (F_Spec)) and then not Is_Class_Wide_Type (Etype (F_Spec)) @@ -2114,10 +2123,8 @@ package body Sem_Ch8 is if Present (Alias (Subp)) then return Alias (Subp); - elsif - Nkind (Unit_Declaration_Node (Subp)) = N_Subprogram_Declaration - and then Present - (Corresponding_Body (Unit_Declaration_Node (Subp))) + elsif Nkind (Unit_Declaration_Node (Subp)) = N_Subprogram_Declaration + and then Present (Corresponding_Body (Unit_Declaration_Node (Subp))) then -- Check if renamed entity is a renaming_as_body @@ -2167,7 +2174,8 @@ package body Sem_Ch8 is -- this must be treated as a normal attribute reference, to be -- expanded in subsequent instantiations. - if Is_Actual and then Is_Abstract_Subprogram (Formal_Spec) + if Is_Actual + and then Is_Abstract_Subprogram (Formal_Spec) and then Full_Expander_Active then declare @@ -2382,8 +2390,8 @@ package body Sem_Ch8 is pragma Assert (Is_Primitive (Entity (Nam)) - and then - Is_Abstract_Type (Find_Dispatching_Type (Entity (Nam)))); + and then + Is_Abstract_Type (Find_Dispatching_Type (Entity (Nam)))); declare Old_Decl : constant Node_Id := Unit_Declaration_Node (Rename_Spec); @@ -2490,8 +2498,7 @@ package body Sem_Ch8 is (Is_Tagged_Type (T) or else (Is_Access_Type (T) - and then - Is_Tagged_Type (Designated_Type (T)))) + and then Is_Tagged_Type (Designated_Type (T)))) and then Scope (Entity (Selector_Name (Nam))) /= T then Analyze_Renamed_Primitive_Operation @@ -2506,9 +2513,7 @@ package body Sem_Ch8 is -- This is not allowed for renaming as body if the renamed -- spec is already frozen (see RM 8.5.4(5) for details). - if Present (Rename_Spec) - and then Is_Frozen (Rename_Spec) - then + if Present (Rename_Spec) and then Is_Frozen (Rename_Spec) then Error_Msg_N ("renaming-as-body cannot rename entry as subprogram", N); Error_Msg_NE @@ -2607,9 +2612,7 @@ package body Sem_Ch8 is -- when performing a null exclusion check between a renaming and a -- renamed subprogram that has been found to be illegal. - if Ada_Version >= Ada_2005 - and then Entity (Nam) /= Any_Id - then + if Ada_Version >= Ada_2005 and then Entity (Nam) /= Any_Id then Check_Null_Exclusion (Ren => New_S, Sub => Entity (Nam)); @@ -2710,13 +2713,11 @@ package body Sem_Ch8 is if CW_Actual then null; - else + elsif not Is_Actual or else No (Enclosing_Instance) then Check_Mode_Conformant (New_S, Old_S); end if; - if Is_Actual - and then Error_Posted (New_S) - then + if Is_Actual and then Error_Posted (New_S) then Error_Msg_NE ("invalid actual subprogram: & #!", N, Old_S); end if; end if; @@ -2750,13 +2751,12 @@ package body Sem_Ch8 is Set_Is_Intrinsic_Subprogram (New_S, - Is_Intrinsic_Subprogram (Old_S) - and then - (Chars (Old_S) /= Name_Op_Ne - or else Ekind (Old_S) = E_Operator - or else - Is_Intrinsic_Subprogram - (Corresponding_Equality (Old_S)))); + Is_Intrinsic_Subprogram (Old_S) + and then + (Chars (Old_S) /= Name_Op_Ne + or else Ekind (Old_S) = E_Operator + or else Is_Intrinsic_Subprogram + (Corresponding_Equality (Old_S)))); if Ekind (Alias (New_S)) = E_Operator then Set_Has_Delayed_Freeze (New_S, False); @@ -2909,7 +2909,6 @@ package body Sem_Ch8 is F1 := First_Formal (Candidate_Renaming); F2 := First_Formal (New_S); T1 := First_Subtype (Etype (F1)); - while Present (F1) and then Present (F2) loop Next_Formal (F1); Next_Formal (F2); @@ -2980,9 +2979,8 @@ package body Sem_Ch8 is if Comes_From_Source (N) and then Present (Old_S) - and then - (Nkind (Old_S) = N_Defining_Operator_Symbol - or else Ekind (Old_S) = E_Operator) + and then (Nkind (Old_S) = N_Defining_Operator_Symbol + or else Ekind (Old_S) = E_Operator) and then Nkind (New_S) = N_Defining_Operator_Symbol and then Chars (Old_S) /= Chars (New_S) then @@ -3003,9 +3001,8 @@ package body Sem_Ch8 is and then Comes_From_Source (N) and then Scope (Old_S) /= Standard_Standard and then Warn_On_Redundant_Constructs - and then - (Is_Immediately_Visible (Old_S) - or else Is_Potentially_Use_Visible (Old_S)) + and then (Is_Immediately_Visible (Old_S) + or else Is_Potentially_Use_Visible (Old_S)) and then Is_Overloadable (Current_Scope) and then Chars (Current_Scope) /= Chars (Old_S) then @@ -3102,9 +3099,7 @@ package body Sem_Ch8 is if Is_Entity_Name (Pack_Name) then Pack := Entity (Pack_Name); - if Ekind (Pack) /= E_Package - and then Etype (Pack) /= Any_Type - then + if Ekind (Pack) /= E_Package and then Etype (Pack) /= Any_Type then if Ekind (Pack) = E_Generic_Package then Error_Msg_N -- CODEFIX ("a generic package is not allowed in a use clause", @@ -3224,14 +3219,12 @@ package body Sem_Ch8 is function Mentioned (Nam : Node_Id) return Boolean is begin return Nkind (Name (Item)) = N_Selected_Component - and then - Chars (Prefix (Name (Item))) = Chars (Nam); + and then Chars (Prefix (Name (Item))) = Chars (Nam); end Mentioned; begin Pref := Prefix (Id); Item := First (Context_Items (Parent (N))); - while Present (Item) and then Item /= N loop if Nkind (Item) = N_With_Clause and then Limited_Present (Item) @@ -3260,9 +3253,7 @@ package body Sem_Ch8 is begin if In_Open_Scopes (Pack) then - if Warn_On_Redundant_Constructs - and then Pack = Current_Scope - then + if Warn_On_Redundant_Constructs and then Pack = Current_Scope then Error_Msg_NE -- CODEFIX ("& is already use-visible within itself?r?", Pack_Name, Pack); end if; @@ -3572,9 +3563,7 @@ package body Sem_Ch8 is Old_S : Entity_Id; begin - if Is_Frozen (Subp) - and then not Has_Completion (Subp) - then + if Is_Frozen (Subp) and then not Has_Completion (Subp) then B_Node := Build_Renamed_Body (Parent (Declaration_Node (Subp)), Defining_Entity (N)); @@ -3591,12 +3580,10 @@ package body Sem_Ch8 is Analyze (B_Node); end if; - if Is_Intrinsic_Subprogram (Old_S) - and then not In_Instance - then + if Is_Intrinsic_Subprogram (Old_S) and then not In_Instance then Error_Msg_N ("subprogram used in renaming_as_body cannot be intrinsic", - Name (N)); + Name (N)); end if; else @@ -3629,11 +3616,10 @@ package body Sem_Ch8 is -- for details on their handling. elsif Is_Concurrent_Type (Scope (E)) then - P := Parent (N); while Present (P) and then not Nkind_In (P, N_Parameter_Specification, - N_Component_Declaration) + N_Component_Declaration) loop P := Parent (P); end loop; @@ -3670,13 +3656,10 @@ package body Sem_Ch8 is begin Item := First (Context_Items (Parent (N))); - - while Present (Item) - and then Item /= N - loop + while Present (Item) and then Item /= N loop if Nkind (Item) = N_With_Clause - -- Protect the frontend against previous critical errors + -- Protect the frontend against previous critical errors and then Nkind (Name (Item)) /= N_Selected_Component and then Entity (Name (Item)) = Pack @@ -3745,9 +3728,9 @@ package body Sem_Ch8 is ("renamed unit must be a child unit of generic parent", Name (N)); elsif Nkind (N) in N_Generic_Renaming_Declaration - and then Nkind (Name (N)) = N_Expanded_Name - and then Is_Generic_Instance (Entity (Prefix (Name (N)))) - and then Is_Generic_Unit (Old_E) + and then Nkind (Name (N)) = N_Expanded_Name + and then Is_Generic_Instance (Entity (Prefix (Name (N)))) + and then Is_Generic_Unit (Old_E) then Error_Msg_N ("renamed generic unit must be a library unit", Name (N)); @@ -3766,6 +3749,30 @@ package body Sem_Ch8 is end if; end Check_Library_Unit_Renaming; + ------------------------ + -- Enclosing_Instance -- + ------------------------ + + function Enclosing_Instance return Entity_Id is + S : Entity_Id; + + begin + if not Is_Generic_Instance (Current_Scope) then + return Empty; + end if; + + S := Scope (Current_Scope); + while S /= Standard_Standard loop + if Is_Generic_Instance (S) then + return S; + end if; + + S := Scope (S); + end loop; + + return Empty; + end Enclosing_Instance; + --------------- -- End_Scope -- --------------- @@ -3952,16 +3959,14 @@ package body Sem_Ch8 is if Nkind (Id) = N_Defining_Operator_Symbol and then - (Is_Primitive_Operator_In_Use - (Id, First_Formal (Id)) - or else - (Present (Next_Formal (First_Formal (Id))) - and then - Is_Primitive_Operator_In_Use - (Id, Next_Formal (First_Formal (Id))))) + (Is_Primitive_Operator_In_Use (Id, First_Formal (Id)) + or else + (Present (Next_Formal (First_Formal (Id))) + and then + Is_Primitive_Operator_In_Use + (Id, Next_Formal (First_Formal (Id))))) then null; - else Set_Is_Potentially_Use_Visible (Id, False); end if; @@ -4222,10 +4227,10 @@ package body Sem_Ch8 is Nkind (N) = N_Identifier and then (Nkind (Parent (N)) = N_Procedure_Call_Statement - or else - (Nkind (Parent (N)) = N_Parameter_Association - and then N = Explicit_Actual_Parameter (Parent (N)) - and then Nkind (Parent (Parent (N))) = + or else + (Nkind (Parent (N)) = N_Parameter_Association + and then N = Explicit_Actual_Parameter (Parent (N)) + and then Nkind (Parent (Parent (N))) = N_Procedure_Call_Statement)); end Is_Actual_Parameter; @@ -4802,9 +4807,7 @@ package body Sem_Ch8 is -- Find current instance Inst := Current_Scope; - while Present (Inst) - and then Inst /= Standard_Standard - loop + while Present (Inst) and then Inst /= Standard_Standard loop if Is_Generic_Instance (Inst) then exit; end if; @@ -5202,9 +5205,7 @@ package body Sem_Ch8 is end; if No (Id) - and then (Ekind (P_Name) = E_Procedure - or else - Ekind (P_Name) = E_Function) + and then Ekind_In (P_Name, E_Procedure, E_Function) and then Is_Generic_Instance (P_Name) then -- Expanded name denotes entity in (instance of) generic subprogram. @@ -5463,9 +5464,7 @@ package body Sem_Ch8 is -- Ada 2005 (AI-50217): Check usage of entities in limited withed units - if Ekind (P_Name) = E_Package - and then From_With_Type (P_Name) - then + if Ekind (P_Name) = E_Package and then From_With_Type (P_Name) then if From_With_Type (Id) or else Is_Type (Id) or else Ekind (Id) = E_Package @@ -5481,11 +5480,11 @@ package body Sem_Ch8 is if Is_Task_Type (P_Name) and then ((Ekind (Id) = E_Entry - and then Nkind (Parent (N)) /= N_Attribute_Reference) + and then Nkind (Parent (N)) /= N_Attribute_Reference) or else - (Ekind (Id) = E_Entry_Family - and then - Nkind (Parent (Parent (N))) /= N_Attribute_Reference)) + (Ekind (Id) = E_Entry_Family + and then + Nkind (Parent (Parent (N))) /= N_Attribute_Reference)) then -- If both the task type and the entry are in scope, this may still -- be the expanded name of an entry formal. @@ -5538,18 +5537,15 @@ package body Sem_Ch8 is if Ekind (Id) = E_Void then Premature_Usage (N); - elsif Is_Overloadable (Id) - and then Present (Homonym (Id)) - then + elsif Is_Overloadable (Id) and then Present (Homonym (Id)) then declare H : Entity_Id := Homonym (Id); begin while Present (H) loop if Scope (H) = Scope (Id) - and then - (not Is_Hidden (H) - or else Is_Immediately_Visible (H)) + and then (not Is_Hidden (H) + or else Is_Immediately_Visible (H)) then Collect_Interps (N); exit; @@ -5618,17 +5614,6 @@ package body Sem_Ch8 is Old_S : Entity_Id; Inst : Entity_Id; - function Enclosing_Instance return Entity_Id; - -- If the renaming determines the entity for the default of a formal - -- subprogram nested within another instance, choose the innermost - -- candidate. This is because if the formal has a box, and we are within - -- an enclosing instance where some candidate interpretations are local - -- to this enclosing instance, we know that the default was properly - -- resolved when analyzing the generic, so we prefer the local - -- candidates to those that are external. This is not always the case - -- but is a reasonable heuristic on the use of nested generics. The - -- proper solution requires a full renaming model. - function Is_Visible_Operation (Op : Entity_Id) return Boolean; -- If the renamed entity is an implicit operator, check whether it is -- visible because its operand type is properly visible. This check @@ -5644,32 +5629,6 @@ package body Sem_Ch8 is -- Determine whether a candidate subprogram is defined within the -- enclosing instance. If yes, it has precedence over outer candidates. - ------------------------ - -- Enclosing_Instance -- - ------------------------ - - function Enclosing_Instance return Entity_Id is - S : Entity_Id; - - begin - if not Is_Generic_Instance (Current_Scope) - and then not Is_Actual - then - return Empty; - end if; - - S := Scope (Current_Scope); - while S /= Standard_Standard loop - if Is_Generic_Instance (S) then - return S; - end if; - - S := Scope (S); - end loop; - - return Empty; - end Enclosing_Instance; - -------------------------- -- Is_Visible_Operation -- -------------------------- @@ -5683,9 +5642,8 @@ package body Sem_Ch8 is if Ekind (Op) /= E_Operator or else Scope (Op) /= Standard_Standard or else (In_Instance - and then - (not Is_Actual - or else Present (Enclosing_Instance))) + and then (not Is_Actual + or else Present (Enclosing_Instance))) then return True; @@ -5776,7 +5734,10 @@ package body Sem_Ch8 is Candidate_Renaming := Empty; if not Is_Overloaded (Nam) then - if Entity_Matches_Spec (Entity (Nam), New_S) then + if Is_Actual and then Present (Enclosing_Instance) then + Old_S := Entity (Nam); + + elsif Entity_Matches_Spec (Entity (Nam), New_S) then Candidate_Renaming := New_S; if Is_Visible_Operation (Entity (Nam)) then @@ -5786,8 +5747,8 @@ package body Sem_Ch8 is elsif Present (First_Formal (Entity (Nam))) and then Present (First_Formal (New_S)) - and then (Base_Type (Etype (First_Formal (Entity (Nam)))) - = Base_Type (Etype (First_Formal (New_S)))) + and then (Base_Type (Etype (First_Formal (Entity (Nam)))) = + Base_Type (Etype (First_Formal (New_S)))) then Candidate_Renaming := Entity (Nam); end if; @@ -5851,8 +5812,8 @@ package body Sem_Ch8 is elsif Present (First_Formal (It.Nam)) and then Present (First_Formal (New_S)) - and then (Base_Type (Etype (First_Formal (It.Nam))) - = Base_Type (Etype (First_Formal (New_S)))) + and then (Base_Type (Etype (First_Formal (It.Nam))) = + Base_Type (Etype (First_Formal (New_S)))) then Candidate_Renaming := It.Nam; end if; @@ -5964,10 +5925,10 @@ package body Sem_Ch8 is ((RTE_Available (RE_Dispatch_Table_Wrapper) and then Scope (Selector) = RTE (RE_Dispatch_Table_Wrapper)) - or else - (RTE_Available (RE_No_Dispatch_Table_Wrapper) - and then Scope (Selector) = - RTE (RE_No_Dispatch_Table_Wrapper))) + or else + (RTE_Available (RE_No_Dispatch_Table_Wrapper) + and then Scope (Selector) = + RTE (RE_No_Dispatch_Table_Wrapper))) then C_Etype := Empty; @@ -6071,7 +6032,7 @@ package body Sem_Ch8 is elsif Is_Appropriate_For_Entry_Prefix (P_Type) and then not In_Open_Scopes (P_Name) and then (not Is_Concurrent_Type (Etype (P_Name)) - or else not In_Open_Scopes (Etype (P_Name))) + or else not In_Open_Scopes (Etype (P_Name))) then -- Call to protected operation or entry. Type checking is -- needed on the prefix. @@ -6148,9 +6109,9 @@ package body Sem_Ch8 is -- entry, as is P.X; this is an error. if Ekind (P_Name) /= E_Function - and then (not Is_Overloaded (P) - or else - Nkind (Parent (N)) = N_Procedure_Call_Statement) + and then + (not Is_Overloaded (P) + or else Nkind (Parent (N)) = N_Procedure_Call_Statement) then -- Prefix may mention a package that is hidden by a local -- declaration: let the user know. Scan the full homonym @@ -6327,9 +6288,7 @@ package body Sem_Ch8 is -- Warn_On_Obsolescent_ Feature). Once this issue -- is cleared in the sources, it can be enabled. - elsif Warn_On_Obsolescent_Feature - and then False - then + elsif Warn_On_Obsolescent_Feature and then False then Error_Msg_N ("applying 'Class to an untagged incomplete type" & " is an obsolescent feature (RM J.11)?r?", N); @@ -6596,9 +6555,7 @@ package body Sem_Ch8 is Priv_Id : Entity_Id := Empty; begin - if Ekind (P) = E_Package - and then not In_Open_Scopes (P) - then + if Ekind (P) = E_Package and then not In_Open_Scopes (P) then Priv_Id := First_Private_Entity (P); end if; @@ -6611,9 +6568,7 @@ package body Sem_Ch8 is end if; Id := First_Entity (P); - while Present (Id) - and then Id /= Priv_Id - loop + while Present (Id) and then Id /= Priv_Id loop if Is_Standard_Character_Type (Id) and then Is_Base_Type (Id) then -- We replace the node with the literal itself, resolve as a @@ -6695,7 +6650,6 @@ package body Sem_Ch8 is begin Predef_Op := Current_Entity (Selector_Name (N)); - while Present (Predef_Op) and then Scope (Predef_Op) /= Standard_Standard loop @@ -6760,9 +6714,7 @@ package body Sem_Ch8 is -- Start of processing for Has_Implicit_Operator begin - if Ekind (P) = E_Package - and then not In_Open_Scopes (P) - then + if Ekind (P) = E_Package and then not In_Open_Scopes (P) then Priv_Id := First_Private_Entity (P); end if; @@ -7202,9 +7154,7 @@ package body Sem_Ch8 is -- of the stack is related to the current compilation. Scop := Current_Scope; - while Present (Scop) - and then Scop /= Standard_Standard - loop + while Present (Scop) and then Scop /= Standard_Standard loop if Is_Compilation_Unit (Scop) and then not Is_Child_Unit (Scop) then @@ -7495,14 +7445,9 @@ package body Sem_Ch8 is -- name resolution on component associations. (see 4717-008). In such a -- case, look for the visible homonym on the chain. - if In_Instance - and then Present (Homonym (E)) - then + if In_Instance and then Present (Homonym (E)) then E := Homonym (E); - - while Present (E) - and then not In_Open_Scopes (Scope (E)) - loop + while Present (E) and then not In_Open_Scopes (Scope (E)) loop E := Homonym (E); end loop; @@ -7609,16 +7554,14 @@ package body Sem_Ch8 is if No (With_Sys) and then (Nkind (The_Unit) = N_Package_Body - or else (Nkind (The_Unit) = N_Subprogram_Body - and then - not Acts_As_Spec (Cunit (Current_Sem_Unit)))) + or else (Nkind (The_Unit) = N_Subprogram_Body + and then not Acts_As_Spec (Cunit (Current_Sem_Unit)))) then With_Sys := Find_System (Library_Unit (Cunit (Current_Sem_Unit))); end if; - if No (With_Sys) - and then Present (N) - then + if No (With_Sys) and then Present (N) then + -- If we are compiling a subunit, we need to examine its -- context as well (Current_Sem_Unit is the parent unit); @@ -7735,8 +7678,9 @@ package body Sem_Ch8 is else pragma Assert (Nkind (Parent (E)) = N_Defining_Program_Unit_Name - and then - Nkind (Parent (Parent (E))) = N_Package_Specification); + and then + Nkind (Parent (Parent (E))) = + N_Package_Specification); Set_Is_Immediately_Visible (E, Limited_View_Installed (Parent (Parent (E)))); end if; @@ -7746,9 +7690,8 @@ package body Sem_Ch8 is Next_Entity (E); - if not Full_Vis - and then Is_Package_Or_Generic_Package (S) - then + if not Full_Vis and then Is_Package_Or_Generic_Package (S) then + -- We are in the visible part of the package scope exit when E = First_Private_Entity (S); @@ -7798,8 +7741,7 @@ package body Sem_Ch8 is elsif Is_Hidden_Open_Scope (S) then null; - elsif (Ekind (S) = E_Procedure - or else Ekind (S) = E_Function) + elsif Ekind_In (S, E_Procedure, E_Function) and then Has_Completion (S) then Full_Vis := True; @@ -7974,7 +7916,7 @@ package body Sem_Ch8 is Id := First_Entity (P); while Present (Id) and then (Id /= First_Private_Entity (P) - or else Private_With_OK) -- Ada 2005 (AI-262) + or else Private_With_OK) -- Ada 2005 (AI-262) loop Prev := Current_Entity (Id); while Present (Prev) loop @@ -8042,10 +7984,10 @@ package body Sem_Ch8 is elsif Ekind (Prev) = E_Operator and then Operator_Matches_Spec (Prev, Id) and then In_Open_Scopes - (Scope (Base_Type (Etype (First_Formal (Id))))) + (Scope (Base_Type (Etype (First_Formal (Id))))) and then (No (Next_Formal (First_Formal (Id))) - or else Etype (First_Formal (Id)) - = Etype (Next_Formal (First_Formal (Id))) + or else Etype (First_Formal (Id)) = + Etype (Next_Formal (First_Formal (Id))) or else Chars (Prev) = Name_Op_Expon) then goto Next_Usable_Entity; @@ -8074,14 +8016,11 @@ package body Sem_Ch8 is -- On exit, we know entity is not hidden, unless it is private if not Is_Hidden (Id) - and then ((not Is_Child_Unit (Id)) - or else Is_Visible_Lib_Unit (Id)) + and then ((not Is_Child_Unit (Id)) or else Is_Visible_Lib_Unit (Id)) then Set_Is_Potentially_Use_Visible (Id); - if Is_Private_Type (Id) - and then Present (Full_View (Id)) - then + if Is_Private_Type (Id) and then Present (Full_View (Id)) then Set_Is_Potentially_Use_Visible (Full_View (Id)); end if; end if; @@ -8252,12 +8191,10 @@ package body Sem_Ch8 is -- a limited view unless we only have a limited view of its enclosing -- package. - elsif From_With_Type (T) - and then From_With_Type (Scope (T)) - then + elsif From_With_Type (T) and then From_With_Type (Scope (T)) then Error_Msg_N ("incomplete type from limited view " - & "cannot appear in use clause", Id); + & "cannot appear in use clause", Id); -- If the subtype mark designates a subtype in a different package, -- we have to check that the parent type is visible, otherwise the @@ -8321,18 +8258,18 @@ package body Sem_Ch8 is if Warn_On_Redundant_Constructs and then Is_Known_Used - -- with P; with P; use P; - -- package P is package X is package body X is - -- type T ... use P.T; + -- with P; with P; use P; + -- package P is package X is package body X is + -- type T ... use P.T; - -- The compilation unit is the body of X. GNAT first compiles the - -- spec of X, then proceeds to the body. At that point P is marked - -- as use visible. The analysis then reinstalls the spec along with - -- its context. The use clause P.T is now recognized as redundant, - -- but in the wrong context. Do not emit a warning in such cases. - -- Do not emit a warning either if we are in an instance, there is - -- no redundancy between an outer use_clause and one that appears - -- within the generic. + -- The compilation unit is the body of X. GNAT first compiles the + -- spec of X, then proceeds to the body. At that point P is marked + -- as use visible. The analysis then reinstalls the spec along with + -- its context. The use clause P.T is now recognized as redundant, + -- but in the wrong context. Do not emit a warning in such cases. + -- Do not emit a warning either if we are in an instance, there is + -- no redundancy between an outer use_clause and one that appears + -- within the generic. and then not Spec_Reloaded_For_Body and then not In_Instance @@ -8386,7 +8323,6 @@ package body Sem_Ch8 is and then Nkind (Parent (Clause2)) = N_Compilation_Unit then - -- If the unit is a subprogram body that acts as spec, -- the context clause is shared with the constructed -- subprogram spec. Clearly there is no redundancy. -- 2.30.2