Skip to content

R
riscv-gcc-1
Commit ac7d724d by Ed Schonberg Committed by Arnaud Charlet
Options

sem_ch5.adb: remove spurious warning from non-empty loop. 

2013-04-11  Ed Schonberg  <schonberg@adacore.com>

	* 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
parent 8fde064e
Showing with 152 additions and 218 deletions
gcc/ada/ChangeLog
2013-04-11 Ed Schonberg <schonberg@adacore.com>
* 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 <dewar@adacore.com> 2013-04-11 Robert Dewar <dewar@adacore.com>
* errout.ads: Minor reformatting. * errout.ads: Minor reformatting.
......
gcc/ada/sem_ch5.adb
...@@ -222,10 +222,9 @@ package body Sem_Ch5 is ...@@ -222,10 +222,9 @@ package body Sem_Ch5 is
if Is_Entity_Name (Opnd) if Is_Entity_Name (Opnd)
and then (Ekind (Entity (Opnd)) = E_Out_Parameter and then (Ekind (Entity (Opnd)) = E_Out_Parameter
or else Ekind (Entity (Opnd)) = or else Ekind_In (Entity (Opnd),
E_In_Out_Parameter E_In_Out_Parameter,
or else Ekind (Entity (Opnd)) = E_Generic_In_Out_Parameter)
E_Generic_In_Out_Parameter
or else or else
(Ekind (Entity (Opnd)) = E_Variable (Ekind (Entity (Opnd)) = E_Variable
and then Nkind (Parent (Entity (Opnd))) = and then Nkind (Parent (Entity (Opnd))) =
...@@ -607,9 +606,7 @@ package body Sem_Ch5 is ...@@ -607,9 +606,7 @@ package body Sem_Ch5 is
-- as well to anonymous access-to-subprogram types that are component -- as well to anonymous access-to-subprogram types that are component
-- subtypes or formal parameters. -- subtypes or formal parameters.
if Ada_Version >= Ada_2005 if Ada_Version >= Ada_2005 and then Is_Access_Type (T1) then
and then Is_Access_Type (T1)
then
if Is_Local_Anonymous_Access (T1) if Is_Local_Anonymous_Access (T1)
or else Ekind (T2) = E_Anonymous_Access_Subprogram_Type or else Ekind (T2) = E_Anonymous_Access_Subprogram_Type
...@@ -665,11 +662,9 @@ package body Sem_Ch5 is ...@@ -665,11 +662,9 @@ package body Sem_Ch5 is
-- assignment within the block. -- assignment within the block.
elsif Is_Array_Type (T1) elsif Is_Array_Type (T1)
and then and then (Nkind (Rhs) /= N_Type_Conversion
(Nkind (Rhs) /= N_Type_Conversion
or else Is_Constrained (Etype (Rhs))) or else Is_Constrained (Etype (Rhs)))
and then and then (Nkind (Rhs) /= N_Function_Call
(Nkind (Rhs) /= N_Function_Call
or else Nkind (N) /= N_Block_Statement) or else Nkind (N) /= N_Block_Statement)
then then
-- Assignment verifies that the length of the Lsh and Rhs are equal, -- Assignment verifies that the length of the Lsh and Rhs are equal,
...@@ -1198,9 +1193,7 @@ package body Sem_Ch5 is ...@@ -1198,9 +1193,7 @@ package body Sem_Ch5 is
-- A case statement with a single OTHERS alternative is not allowed -- A case statement with a single OTHERS alternative is not allowed
-- in SPARK. -- in SPARK.
if Others_Present if Others_Present and then List_Length (Alternatives (N)) = 1 then
and then List_Length (Alternatives (N)) = 1
then
Check_SPARK_Restriction Check_SPARK_Restriction
("OTHERS as unique case alternative is not allowed", N); ("OTHERS as unique case alternative is not allowed", N);
end if; end if;
...@@ -1297,9 +1290,7 @@ package body Sem_Ch5 is ...@@ -1297,9 +1290,7 @@ package body Sem_Ch5 is
Scope_Id := Scope_Stack.Table (J).Entity; Scope_Id := Scope_Stack.Table (J).Entity;
Kind := Ekind (Scope_Id); Kind := Ekind (Scope_Id);
if Kind = E_Loop if Kind = E_Loop and then (No (Target) or else Scope_Id = U_Name) then
and then (No (Target) or else Scope_Id = U_Name)
then
Set_Has_Exit (Scope_Id); Set_Has_Exit (Scope_Id);
exit; exit;
...@@ -1423,9 +1414,7 @@ package body Sem_Ch5 is ...@@ -1423,9 +1414,7 @@ package body Sem_Ch5 is
Scope_Id := Scope_Stack.Table (J).Entity; Scope_Id := Scope_Stack.Table (J).Entity;
if Label_Scope = Scope_Id if Label_Scope = Scope_Id
or else (Ekind (Scope_Id) /= E_Block or else not Ekind_In (Scope_Id, E_Block, E_Loop, E_Return_Statement)
and then Ekind (Scope_Id) /= E_Loop
and then Ekind (Scope_Id) /= E_Return_Statement)
then then
if Scope_Id /= Label_Scope then if Scope_Id /= Label_Scope then
Error_Msg_N Error_Msg_N
...@@ -1447,9 +1436,9 @@ package body Sem_Ch5 is ...@@ -1447,9 +1436,9 @@ package body Sem_Ch5 is
-- The expander has circuitry to completely delete code that it can tell -- 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 -- 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 -- the analyzer, we ensure that code that will be deleted in this manner
-- analyzed but not expanded. This is obviously more efficient, but more -- is analyzed but not expanded. This is obviously more efficient, but
-- significantly, difficulties arise if code is expanded and then -- more significantly, difficulties arise if code is expanded and then
-- eliminated (e.g. exception table entries disappear). Similarly, itypes -- eliminated (e.g. exception table entries disappear). Similarly, itypes
-- generated in deleted code must be frozen from start, because the nodes -- generated in deleted code must be frozen from start, because the nodes
-- on which they depend will not be available at the freeze point. -- on which they depend will not be available at the freeze point.
...@@ -2161,15 +2150,11 @@ package body Sem_Ch5 is ...@@ -2161,15 +2150,11 @@ package body Sem_Ch5 is
-- Propagate staticness to loop range itself, in case the -- Propagate staticness to loop range itself, in case the
-- corresponding subtype is static. -- corresponding subtype is static.
if New_Lo /= Lo if New_Lo /= Lo and then Is_Static_Expression (New_Lo) then
and then Is_Static_Expression (New_Lo)
then
Rewrite (Low_Bound (R), New_Copy (New_Lo)); Rewrite (Low_Bound (R), New_Copy (New_Lo));
end if; end if;
if New_Hi /= Hi if New_Hi /= Hi and then Is_Static_Expression (New_Hi) then
and then Is_Static_Expression (New_Hi)
then
Rewrite (High_Bound (R), New_Copy (New_Hi)); Rewrite (High_Bound (R), New_Copy (New_Hi));
end if; end if;
end Process_Bounds; end Process_Bounds;
...@@ -2238,8 +2223,7 @@ package body Sem_Ch5 is ...@@ -2238,8 +2223,7 @@ package body Sem_Ch5 is
-- new iterator form. -- new iterator form.
if Nkind (DS_Copy) = N_Function_Call if Nkind (DS_Copy) = N_Function_Call
or else or else (Is_Entity_Name (DS_Copy)
(Is_Entity_Name (DS_Copy)
and then not Is_Type (Entity (DS_Copy))) and then not Is_Type (Entity (DS_Copy)))
then then
-- This is an iterator specification. Rewrite it as such and -- This is an iterator specification. Rewrite it as such and
...@@ -2395,9 +2379,8 @@ package body Sem_Ch5 is ...@@ -2395,9 +2379,8 @@ package body Sem_Ch5 is
-- instance, since in practice they tend to be dubious in these -- instance, since in practice they tend to be dubious in these
-- cases since they can result from intended parametrization. -- cases since they can result from intended parametrization.
if not Inside_A_Generic if not Inside_A_Generic and then not In_Instance then
and then not In_Instance
then
-- Specialize msg if invalid values could make the loop -- Specialize msg if invalid values could make the loop
-- non-null after all. -- non-null after all.
...@@ -2436,7 +2419,7 @@ package body Sem_Ch5 is ...@@ -2436,7 +2419,7 @@ package body Sem_Ch5 is
-- The other case for a warning is a reverse loop where the -- The other case for a warning is a reverse loop where the
-- upper bound is the integer literal zero or one, and 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 -- For example, we have
...@@ -2449,11 +2432,24 @@ package body Sem_Ch5 is ...@@ -2449,11 +2432,24 @@ package body Sem_Ch5 is
and then Nkind (Original_Node (H)) = N_Integer_Literal and then Nkind (Original_Node (H)) = N_Integer_Literal
and then and then
(Intval (Original_Node (H)) = Uint_0 (Intval (Original_Node (H)) = Uint_0
or else Intval (Original_Node (H)) = Uint_1) or else
Intval (Original_Node (H)) = Uint_1)
then then
-- 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 ("??loop range may be null", DS);
Error_Msg_N ("\??bounds may be wrong way round", DS); Error_Msg_N ("\??bounds may be wrong way round", DS);
end if; end if;
end if;
end; end;
end if; end if;
end Analyze_Loop_Parameter_Specification; end Analyze_Loop_Parameter_Specification;
...@@ -2839,9 +2835,7 @@ package body Sem_Ch5 is ...@@ -2839,9 +2835,7 @@ package body Sem_Ch5 is
P : Node_Id; P : Node_Id;
begin begin
if Is_List_Member (N) if Is_List_Member (N) and then Comes_From_Source (N) then
and then Comes_From_Source (N)
then
declare declare
Nxt : Node_Id; Nxt : Node_Id;
...@@ -2993,9 +2987,8 @@ package body Sem_Ch5 is ...@@ -2993,9 +2987,8 @@ package body Sem_Ch5 is
Analyze (R_Copy); Analyze (R_Copy);
if Nkind (R_Copy) in N_Subexpr if Nkind (R_Copy) in N_Subexpr and then Is_Overloaded (R_Copy) then
and then Is_Overloaded (R_Copy)
then
-- Apply preference rules for range of predefined integer types, or -- Apply preference rules for range of predefined integer types, or
-- diagnose true ambiguity. -- diagnose true ambiguity.
...@@ -3037,9 +3030,7 @@ package body Sem_Ch5 is ...@@ -3037,9 +3030,7 @@ package body Sem_Ch5 is
-- Subtype mark in iteration scheme -- Subtype mark in iteration scheme
if Is_Entity_Name (R_Copy) if Is_Entity_Name (R_Copy) and then Is_Type (Entity (R_Copy)) then
and then Is_Type (Entity (R_Copy))
then
null; null;
-- Expression in range, or Ada 2012 iterator -- Expression in range, or Ada 2012 iterator
......
gcc/ada/sem_ch8.adb
...@@ -450,6 +450,25 @@ package body Sem_Ch8 is ...@@ -450,6 +450,25 @@ package body Sem_Ch8 is
-- when compiling a subunit or instantiating a generic body on the fly, -- when compiling a subunit or instantiating a generic body on the fly,
-- when it is necessary to save and restore full environments. -- 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; function Has_Implicit_Character_Literal (N : Node_Id) return Boolean;
-- Find a type derived from Character or Wide_Character in the prefix of N. -- 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. -- Used to resolved qualified names whose selector is a character literal.
...@@ -1076,9 +1095,7 @@ package body Sem_Ch8 is ...@@ -1076,9 +1095,7 @@ package body Sem_Ch8 is
then then
null; null;
elsif Ada_Version >= Ada_2005 elsif Ada_Version >= Ada_2005 and then Nkind (Nam) in N_Has_Entity then
and then Nkind (Nam) in N_Has_Entity
then
declare declare
Nam_Decl : Node_Id; Nam_Decl : Node_Id;
Nam_Ent : Entity_Id; Nam_Ent : Entity_Id;
...@@ -1132,10 +1149,10 @@ package body Sem_Ch8 is ...@@ -1132,10 +1149,10 @@ package body Sem_Ch8 is
elsif Nkind (Nam_Decl) = N_Object_Declaration elsif Nkind (Nam_Decl) = N_Object_Declaration
and then In_Instance and then In_Instance
and then Present and then
(Corresponding_Generic_Association (Nam_Decl)) Present (Corresponding_Generic_Association (Nam_Decl))
and then Nkind (Expression (Nam_Decl)) and then Nkind (Expression (Nam_Decl)) =
= N_Raise_Constraint_Error N_Raise_Constraint_Error
then then
Error_Msg_N Error_Msg_N
("renamed actual does not exclude `NULL` " ("renamed actual does not exclude `NULL` "
...@@ -1385,9 +1402,7 @@ package body Sem_Ch8 is ...@@ -1385,9 +1402,7 @@ package body Sem_Ch8 is
begin begin
E := First_Entity (Old_P); E := First_Entity (Old_P);
while Present (E) while Present (E) and then E /= New_P loop
and then E /= New_P
loop
if Is_Type (E) if Is_Type (E)
and then Nkind (Parent (E)) = N_Subtype_Declaration and then Nkind (Parent (E)) = N_Subtype_Declaration
then then
...@@ -1589,8 +1604,7 @@ package body Sem_Ch8 is ...@@ -1589,8 +1604,7 @@ package body Sem_Ch8 is
begin begin
if (Is_Entity_Name (P) and then Ekind (Entity (P)) = E_Entry_Family) if (Is_Entity_Name (P) and then Ekind (Entity (P)) = E_Entry_Family)
or else (Nkind (P) = N_Selected_Component or else (Nkind (P) = N_Selected_Component
and then and then Ekind (Entity (Selector_Name (P))) = E_Entry_Family)
Ekind (Entity (Selector_Name (P))) = E_Entry_Family)
then then
if Is_Entity_Name (P) then if Is_Entity_Name (P) then
Old_S := Entity (P); Old_S := Entity (P);
...@@ -1982,9 +1996,7 @@ package body Sem_Ch8 is ...@@ -1982,9 +1996,7 @@ package body Sem_Ch8 is
Ren_Formal := First_Formal (Ren); Ren_Formal := First_Formal (Ren);
Sub_Formal := First_Formal (Sub); Sub_Formal := First_Formal (Sub);
while Present (Ren_Formal) while Present (Ren_Formal) and then Present (Sub_Formal) loop
and then Present (Sub_Formal)
loop
if Has_Null_Exclusion (Parent (Ren_Formal)) if Has_Null_Exclusion (Parent (Ren_Formal))
and then and then
not (Has_Null_Exclusion (Parent (Sub_Formal)) not (Has_Null_Exclusion (Parent (Sub_Formal))
...@@ -2004,8 +2016,7 @@ package body Sem_Ch8 is ...@@ -2004,8 +2016,7 @@ package body Sem_Ch8 is
if Nkind (Parent (Ren)) = N_Function_Specification if Nkind (Parent (Ren)) = N_Function_Specification
and then Nkind (Parent (Sub)) = N_Function_Specification and then Nkind (Parent (Sub)) = N_Function_Specification
and then Has_Null_Exclusion (Parent (Ren)) and then Has_Null_Exclusion (Parent (Ren))
and then and then not (Has_Null_Exclusion (Parent (Sub))
not (Has_Null_Exclusion (Parent (Sub))
or else Can_Never_Be_Null (Etype (Sub))) or else Can_Never_Be_Null (Etype (Sub)))
then then
Error_Msg_N Error_Msg_N
...@@ -2081,9 +2092,7 @@ package body Sem_Ch8 is ...@@ -2081,9 +2092,7 @@ package body Sem_Ch8 is
then then
F_Nam := First_Entity (Entity (Nam)); F_Nam := First_Entity (Entity (Nam));
F_Spec := First_Formal (Formal_Spec); F_Spec := First_Formal (Formal_Spec);
while Present (F_Nam) while Present (F_Nam) and then Present (F_Spec) loop
and then Present (F_Spec)
loop
if Is_Controlling_Formal (F_Nam) if Is_Controlling_Formal (F_Nam)
and then Has_Unknown_Discriminants (Etype (F_Spec)) and then Has_Unknown_Discriminants (Etype (F_Spec))
and then not Is_Class_Wide_Type (Etype (F_Spec)) and then not Is_Class_Wide_Type (Etype (F_Spec))
...@@ -2114,10 +2123,8 @@ package body Sem_Ch8 is ...@@ -2114,10 +2123,8 @@ package body Sem_Ch8 is
if Present (Alias (Subp)) then if Present (Alias (Subp)) then
return Alias (Subp); return Alias (Subp);
elsif elsif Nkind (Unit_Declaration_Node (Subp)) = N_Subprogram_Declaration
Nkind (Unit_Declaration_Node (Subp)) = N_Subprogram_Declaration and then Present (Corresponding_Body (Unit_Declaration_Node (Subp)))
and then Present
(Corresponding_Body (Unit_Declaration_Node (Subp)))
then then
-- Check if renamed entity is a renaming_as_body -- Check if renamed entity is a renaming_as_body
...@@ -2167,7 +2174,8 @@ package body Sem_Ch8 is ...@@ -2167,7 +2174,8 @@ package body Sem_Ch8 is
-- this must be treated as a normal attribute reference, to be -- this must be treated as a normal attribute reference, to be
-- expanded in subsequent instantiations. -- 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 and then Full_Expander_Active
then then
declare declare
...@@ -2490,8 +2498,7 @@ package body Sem_Ch8 is ...@@ -2490,8 +2498,7 @@ package body Sem_Ch8 is
(Is_Tagged_Type (T) (Is_Tagged_Type (T)
or else or else
(Is_Access_Type (T) (Is_Access_Type (T)
and then and then Is_Tagged_Type (Designated_Type (T))))
Is_Tagged_Type (Designated_Type (T))))
and then Scope (Entity (Selector_Name (Nam))) /= T and then Scope (Entity (Selector_Name (Nam))) /= T
then then
Analyze_Renamed_Primitive_Operation Analyze_Renamed_Primitive_Operation
...@@ -2506,9 +2513,7 @@ package body Sem_Ch8 is ...@@ -2506,9 +2513,7 @@ package body Sem_Ch8 is
-- This is not allowed for renaming as body if the renamed -- This is not allowed for renaming as body if the renamed
-- spec is already frozen (see RM 8.5.4(5) for details). -- spec is already frozen (see RM 8.5.4(5) for details).
if Present (Rename_Spec) if Present (Rename_Spec) and then Is_Frozen (Rename_Spec) then
and then Is_Frozen (Rename_Spec)
then
Error_Msg_N Error_Msg_N
("renaming-as-body cannot rename entry as subprogram", N); ("renaming-as-body cannot rename entry as subprogram", N);
Error_Msg_NE Error_Msg_NE
...@@ -2607,9 +2612,7 @@ package body Sem_Ch8 is ...@@ -2607,9 +2612,7 @@ package body Sem_Ch8 is
-- when performing a null exclusion check between a renaming and a -- when performing a null exclusion check between a renaming and a
-- renamed subprogram that has been found to be illegal. -- renamed subprogram that has been found to be illegal.
if Ada_Version >= Ada_2005 if Ada_Version >= Ada_2005 and then Entity (Nam) /= Any_Id then
and then Entity (Nam) /= Any_Id
then
Check_Null_Exclusion Check_Null_Exclusion
(Ren => New_S, (Ren => New_S,
Sub => Entity (Nam)); Sub => Entity (Nam));
...@@ -2710,13 +2713,11 @@ package body Sem_Ch8 is ...@@ -2710,13 +2713,11 @@ package body Sem_Ch8 is
if CW_Actual then if CW_Actual then
null; null;
else elsif not Is_Actual or else No (Enclosing_Instance) then
Check_Mode_Conformant (New_S, Old_S); Check_Mode_Conformant (New_S, Old_S);
end if; end if;
if Is_Actual if Is_Actual and then Error_Posted (New_S) then
and then Error_Posted (New_S)
then
Error_Msg_NE ("invalid actual subprogram: & #!", N, Old_S); Error_Msg_NE ("invalid actual subprogram: & #!", N, Old_S);
end if; end if;
end if; end if;
...@@ -2754,8 +2755,7 @@ package body Sem_Ch8 is ...@@ -2754,8 +2755,7 @@ package body Sem_Ch8 is
and then and then
(Chars (Old_S) /= Name_Op_Ne (Chars (Old_S) /= Name_Op_Ne
or else Ekind (Old_S) = E_Operator or else Ekind (Old_S) = E_Operator
or else or else Is_Intrinsic_Subprogram
Is_Intrinsic_Subprogram
(Corresponding_Equality (Old_S)))); (Corresponding_Equality (Old_S))));
if Ekind (Alias (New_S)) = E_Operator then if Ekind (Alias (New_S)) = E_Operator then
...@@ -2909,7 +2909,6 @@ package body Sem_Ch8 is ...@@ -2909,7 +2909,6 @@ package body Sem_Ch8 is
F1 := First_Formal (Candidate_Renaming); F1 := First_Formal (Candidate_Renaming);
F2 := First_Formal (New_S); F2 := First_Formal (New_S);
T1 := First_Subtype (Etype (F1)); T1 := First_Subtype (Etype (F1));
while Present (F1) and then Present (F2) loop while Present (F1) and then Present (F2) loop
Next_Formal (F1); Next_Formal (F1);
Next_Formal (F2); Next_Formal (F2);
...@@ -2980,8 +2979,7 @@ package body Sem_Ch8 is ...@@ -2980,8 +2979,7 @@ package body Sem_Ch8 is
if Comes_From_Source (N) if Comes_From_Source (N)
and then Present (Old_S) and then Present (Old_S)
and then and then (Nkind (Old_S) = N_Defining_Operator_Symbol
(Nkind (Old_S) = N_Defining_Operator_Symbol
or else Ekind (Old_S) = E_Operator) or else Ekind (Old_S) = E_Operator)
and then Nkind (New_S) = N_Defining_Operator_Symbol and then Nkind (New_S) = N_Defining_Operator_Symbol
and then Chars (Old_S) /= Chars (New_S) and then Chars (Old_S) /= Chars (New_S)
...@@ -3003,8 +3001,7 @@ package body Sem_Ch8 is ...@@ -3003,8 +3001,7 @@ package body Sem_Ch8 is
and then Comes_From_Source (N) and then Comes_From_Source (N)
and then Scope (Old_S) /= Standard_Standard and then Scope (Old_S) /= Standard_Standard
and then Warn_On_Redundant_Constructs and then Warn_On_Redundant_Constructs
and then and then (Is_Immediately_Visible (Old_S)
(Is_Immediately_Visible (Old_S)
or else Is_Potentially_Use_Visible (Old_S)) or else Is_Potentially_Use_Visible (Old_S))
and then Is_Overloadable (Current_Scope) and then Is_Overloadable (Current_Scope)
and then Chars (Current_Scope) /= Chars (Old_S) and then Chars (Current_Scope) /= Chars (Old_S)
...@@ -3102,9 +3099,7 @@ package body Sem_Ch8 is ...@@ -3102,9 +3099,7 @@ package body Sem_Ch8 is
if Is_Entity_Name (Pack_Name) then if Is_Entity_Name (Pack_Name) then
Pack := Entity (Pack_Name); Pack := Entity (Pack_Name);
if Ekind (Pack) /= E_Package if Ekind (Pack) /= E_Package and then Etype (Pack) /= Any_Type then
and then Etype (Pack) /= Any_Type
then
if Ekind (Pack) = E_Generic_Package then if Ekind (Pack) = E_Generic_Package then
Error_Msg_N -- CODEFIX Error_Msg_N -- CODEFIX
("a generic package is not allowed in a use clause", ("a generic package is not allowed in a use clause",
...@@ -3224,14 +3219,12 @@ package body Sem_Ch8 is ...@@ -3224,14 +3219,12 @@ package body Sem_Ch8 is
function Mentioned (Nam : Node_Id) return Boolean is function Mentioned (Nam : Node_Id) return Boolean is
begin begin
return Nkind (Name (Item)) = N_Selected_Component return Nkind (Name (Item)) = N_Selected_Component
and then and then Chars (Prefix (Name (Item))) = Chars (Nam);
Chars (Prefix (Name (Item))) = Chars (Nam);
end Mentioned; end Mentioned;
begin begin
Pref := Prefix (Id); Pref := Prefix (Id);
Item := First (Context_Items (Parent (N))); 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 if Nkind (Item) = N_With_Clause
and then Limited_Present (Item) and then Limited_Present (Item)
...@@ -3260,9 +3253,7 @@ package body Sem_Ch8 is ...@@ -3260,9 +3253,7 @@ package body Sem_Ch8 is
begin begin
if In_Open_Scopes (Pack) then if In_Open_Scopes (Pack) then
if Warn_On_Redundant_Constructs if Warn_On_Redundant_Constructs and then Pack = Current_Scope then
and then Pack = Current_Scope
then
Error_Msg_NE -- CODEFIX Error_Msg_NE -- CODEFIX
("& is already use-visible within itself?r?", Pack_Name, Pack); ("& is already use-visible within itself?r?", Pack_Name, Pack);
end if; end if;
...@@ -3572,9 +3563,7 @@ package body Sem_Ch8 is ...@@ -3572,9 +3563,7 @@ package body Sem_Ch8 is
Old_S : Entity_Id; Old_S : Entity_Id;
begin begin
if Is_Frozen (Subp) if Is_Frozen (Subp) and then not Has_Completion (Subp) then
and then not Has_Completion (Subp)
then
B_Node := B_Node :=
Build_Renamed_Body Build_Renamed_Body
(Parent (Declaration_Node (Subp)), Defining_Entity (N)); (Parent (Declaration_Node (Subp)), Defining_Entity (N));
...@@ -3591,9 +3580,7 @@ package body Sem_Ch8 is ...@@ -3591,9 +3580,7 @@ package body Sem_Ch8 is
Analyze (B_Node); Analyze (B_Node);
end if; end if;
if Is_Intrinsic_Subprogram (Old_S) if Is_Intrinsic_Subprogram (Old_S) and then not In_Instance then
and then not In_Instance
then
Error_Msg_N Error_Msg_N
("subprogram used in renaming_as_body cannot be intrinsic", ("subprogram used in renaming_as_body cannot be intrinsic",
Name (N)); Name (N));
...@@ -3629,7 +3616,6 @@ package body Sem_Ch8 is ...@@ -3629,7 +3616,6 @@ package body Sem_Ch8 is
-- for details on their handling. -- for details on their handling.
elsif Is_Concurrent_Type (Scope (E)) then elsif Is_Concurrent_Type (Scope (E)) then
P := Parent (N); P := Parent (N);
while Present (P) while Present (P)
and then not Nkind_In (P, N_Parameter_Specification, and then not Nkind_In (P, N_Parameter_Specification,
...@@ -3670,10 +3656,7 @@ package body Sem_Ch8 is ...@@ -3670,10 +3656,7 @@ package body Sem_Ch8 is
begin begin
Item := First (Context_Items (Parent (N))); 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 if Nkind (Item) = N_With_Clause
-- Protect the frontend against previous critical errors -- Protect the frontend against previous critical errors
...@@ -3766,6 +3749,30 @@ package body Sem_Ch8 is ...@@ -3766,6 +3749,30 @@ package body Sem_Ch8 is
end if; end if;
end Check_Library_Unit_Renaming; 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 -- -- End_Scope --
--------------- ---------------
...@@ -3952,8 +3959,7 @@ package body Sem_Ch8 is ...@@ -3952,8 +3959,7 @@ package body Sem_Ch8 is
if Nkind (Id) = N_Defining_Operator_Symbol if Nkind (Id) = N_Defining_Operator_Symbol
and then and then
(Is_Primitive_Operator_In_Use (Is_Primitive_Operator_In_Use (Id, First_Formal (Id))
(Id, First_Formal (Id))
or else or else
(Present (Next_Formal (First_Formal (Id))) (Present (Next_Formal (First_Formal (Id)))
and then and then
...@@ -3961,7 +3967,6 @@ package body Sem_Ch8 is ...@@ -3961,7 +3967,6 @@ package body Sem_Ch8 is
(Id, Next_Formal (First_Formal (Id))))) (Id, Next_Formal (First_Formal (Id)))))
then then
null; null;
else else
Set_Is_Potentially_Use_Visible (Id, False); Set_Is_Potentially_Use_Visible (Id, False);
end if; end if;
...@@ -4802,9 +4807,7 @@ package body Sem_Ch8 is ...@@ -4802,9 +4807,7 @@ package body Sem_Ch8 is
-- Find current instance -- Find current instance
Inst := Current_Scope; Inst := Current_Scope;
while Present (Inst) while Present (Inst) and then Inst /= Standard_Standard loop
and then Inst /= Standard_Standard
loop
if Is_Generic_Instance (Inst) then if Is_Generic_Instance (Inst) then
exit; exit;
end if; end if;
...@@ -5202,9 +5205,7 @@ package body Sem_Ch8 is ...@@ -5202,9 +5205,7 @@ package body Sem_Ch8 is
end; end;
if No (Id) if No (Id)
and then (Ekind (P_Name) = E_Procedure and then Ekind_In (P_Name, E_Procedure, E_Function)
or else
Ekind (P_Name) = E_Function)
and then Is_Generic_Instance (P_Name) and then Is_Generic_Instance (P_Name)
then then
-- Expanded name denotes entity in (instance of) generic subprogram. -- Expanded name denotes entity in (instance of) generic subprogram.
...@@ -5463,9 +5464,7 @@ package body Sem_Ch8 is ...@@ -5463,9 +5464,7 @@ package body Sem_Ch8 is
-- Ada 2005 (AI-50217): Check usage of entities in limited withed units -- Ada 2005 (AI-50217): Check usage of entities in limited withed units
if Ekind (P_Name) = E_Package if Ekind (P_Name) = E_Package and then From_With_Type (P_Name) then
and then From_With_Type (P_Name)
then
if From_With_Type (Id) if From_With_Type (Id)
or else Is_Type (Id) or else Is_Type (Id)
or else Ekind (Id) = E_Package or else Ekind (Id) = E_Package
...@@ -5538,17 +5537,14 @@ package body Sem_Ch8 is ...@@ -5538,17 +5537,14 @@ package body Sem_Ch8 is
if Ekind (Id) = E_Void then if Ekind (Id) = E_Void then
Premature_Usage (N); Premature_Usage (N);
elsif Is_Overloadable (Id) elsif Is_Overloadable (Id) and then Present (Homonym (Id)) then
and then Present (Homonym (Id))
then
declare declare
H : Entity_Id := Homonym (Id); H : Entity_Id := Homonym (Id);
begin begin
while Present (H) loop while Present (H) loop
if Scope (H) = Scope (Id) if Scope (H) = Scope (Id)
and then and then (not Is_Hidden (H)
(not Is_Hidden (H)
or else Is_Immediately_Visible (H)) or else Is_Immediately_Visible (H))
then then
Collect_Interps (N); Collect_Interps (N);
...@@ -5618,17 +5614,6 @@ package body Sem_Ch8 is ...@@ -5618,17 +5614,6 @@ package body Sem_Ch8 is
Old_S : Entity_Id; Old_S : Entity_Id;
Inst : 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; function Is_Visible_Operation (Op : Entity_Id) return Boolean;
-- If the renamed entity is an implicit operator, check whether it is -- If the renamed entity is an implicit operator, check whether it is
-- visible because its operand type is properly visible. This check -- visible because its operand type is properly visible. This check
...@@ -5644,32 +5629,6 @@ package body Sem_Ch8 is ...@@ -5644,32 +5629,6 @@ package body Sem_Ch8 is
-- Determine whether a candidate subprogram is defined within the -- Determine whether a candidate subprogram is defined within the
-- enclosing instance. If yes, it has precedence over outer candidates. -- 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 -- -- Is_Visible_Operation --
-------------------------- --------------------------
...@@ -5683,8 +5642,7 @@ package body Sem_Ch8 is ...@@ -5683,8 +5642,7 @@ package body Sem_Ch8 is
if Ekind (Op) /= E_Operator if Ekind (Op) /= E_Operator
or else Scope (Op) /= Standard_Standard or else Scope (Op) /= Standard_Standard
or else (In_Instance or else (In_Instance
and then and then (not Is_Actual
(not Is_Actual
or else Present (Enclosing_Instance))) or else Present (Enclosing_Instance)))
then then
return True; return True;
...@@ -5776,7 +5734,10 @@ package body Sem_Ch8 is ...@@ -5776,7 +5734,10 @@ package body Sem_Ch8 is
Candidate_Renaming := Empty; Candidate_Renaming := Empty;
if not Is_Overloaded (Nam) then 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; Candidate_Renaming := New_S;
if Is_Visible_Operation (Entity (Nam)) then if Is_Visible_Operation (Entity (Nam)) then
...@@ -5786,8 +5747,8 @@ package body Sem_Ch8 is ...@@ -5786,8 +5747,8 @@ package body Sem_Ch8 is
elsif elsif
Present (First_Formal (Entity (Nam))) Present (First_Formal (Entity (Nam)))
and then Present (First_Formal (New_S)) and then Present (First_Formal (New_S))
and then (Base_Type (Etype (First_Formal (Entity (Nam)))) and then (Base_Type (Etype (First_Formal (Entity (Nam)))) =
= Base_Type (Etype (First_Formal (New_S)))) Base_Type (Etype (First_Formal (New_S))))
then then
Candidate_Renaming := Entity (Nam); Candidate_Renaming := Entity (Nam);
end if; end if;
...@@ -5851,8 +5812,8 @@ package body Sem_Ch8 is ...@@ -5851,8 +5812,8 @@ package body Sem_Ch8 is
elsif elsif
Present (First_Formal (It.Nam)) Present (First_Formal (It.Nam))
and then Present (First_Formal (New_S)) and then Present (First_Formal (New_S))
and then (Base_Type (Etype (First_Formal (It.Nam))) and then (Base_Type (Etype (First_Formal (It.Nam))) =
= Base_Type (Etype (First_Formal (New_S)))) Base_Type (Etype (First_Formal (New_S))))
then then
Candidate_Renaming := It.Nam; Candidate_Renaming := It.Nam;
end if; end if;
...@@ -6148,9 +6109,9 @@ package body Sem_Ch8 is ...@@ -6148,9 +6109,9 @@ package body Sem_Ch8 is
-- entry, as is P.X; this is an error. -- entry, as is P.X; this is an error.
if Ekind (P_Name) /= E_Function if Ekind (P_Name) /= E_Function
and then (not Is_Overloaded (P) and then
or else (not Is_Overloaded (P)
Nkind (Parent (N)) = N_Procedure_Call_Statement) or else Nkind (Parent (N)) = N_Procedure_Call_Statement)
then then
-- Prefix may mention a package that is hidden by a local -- Prefix may mention a package that is hidden by a local
-- declaration: let the user know. Scan the full homonym -- declaration: let the user know. Scan the full homonym
...@@ -6327,9 +6288,7 @@ package body Sem_Ch8 is ...@@ -6327,9 +6288,7 @@ package body Sem_Ch8 is
-- Warn_On_Obsolescent_ Feature). Once this issue -- Warn_On_Obsolescent_ Feature). Once this issue
-- is cleared in the sources, it can be enabled. -- is cleared in the sources, it can be enabled.
elsif Warn_On_Obsolescent_Feature elsif Warn_On_Obsolescent_Feature and then False then
and then False
then
Error_Msg_N Error_Msg_N
("applying 'Class to an untagged incomplete type" ("applying 'Class to an untagged incomplete type"
& " is an obsolescent feature (RM J.11)?r?", N); & " is an obsolescent feature (RM J.11)?r?", N);
...@@ -6596,9 +6555,7 @@ package body Sem_Ch8 is ...@@ -6596,9 +6555,7 @@ package body Sem_Ch8 is
Priv_Id : Entity_Id := Empty; Priv_Id : Entity_Id := Empty;
begin begin
if Ekind (P) = E_Package if Ekind (P) = E_Package and then not In_Open_Scopes (P) then
and then not In_Open_Scopes (P)
then
Priv_Id := First_Private_Entity (P); Priv_Id := First_Private_Entity (P);
end if; end if;
...@@ -6611,9 +6568,7 @@ package body Sem_Ch8 is ...@@ -6611,9 +6568,7 @@ package body Sem_Ch8 is
end if; end if;
Id := First_Entity (P); Id := First_Entity (P);
while Present (Id) while Present (Id) and then Id /= Priv_Id loop
and then Id /= Priv_Id
loop
if Is_Standard_Character_Type (Id) and then Is_Base_Type (Id) then if Is_Standard_Character_Type (Id) and then Is_Base_Type (Id) then
-- We replace the node with the literal itself, resolve as a -- We replace the node with the literal itself, resolve as a
...@@ -6695,7 +6650,6 @@ package body Sem_Ch8 is ...@@ -6695,7 +6650,6 @@ package body Sem_Ch8 is
begin begin
Predef_Op := Current_Entity (Selector_Name (N)); Predef_Op := Current_Entity (Selector_Name (N));
while Present (Predef_Op) while Present (Predef_Op)
and then Scope (Predef_Op) /= Standard_Standard and then Scope (Predef_Op) /= Standard_Standard
loop loop
...@@ -6760,9 +6714,7 @@ package body Sem_Ch8 is ...@@ -6760,9 +6714,7 @@ package body Sem_Ch8 is
-- Start of processing for Has_Implicit_Operator -- Start of processing for Has_Implicit_Operator
begin begin
if Ekind (P) = E_Package if Ekind (P) = E_Package and then not In_Open_Scopes (P) then
and then not In_Open_Scopes (P)
then
Priv_Id := First_Private_Entity (P); Priv_Id := First_Private_Entity (P);
end if; end if;
...@@ -7202,9 +7154,7 @@ package body Sem_Ch8 is ...@@ -7202,9 +7154,7 @@ package body Sem_Ch8 is
-- of the stack is related to the current compilation. -- of the stack is related to the current compilation.
Scop := Current_Scope; Scop := Current_Scope;
while Present (Scop) while Present (Scop) and then Scop /= Standard_Standard loop
and then Scop /= Standard_Standard
loop
if Is_Compilation_Unit (Scop) if Is_Compilation_Unit (Scop)
and then not Is_Child_Unit (Scop) and then not Is_Child_Unit (Scop)
then then
...@@ -7495,14 +7445,9 @@ package body Sem_Ch8 is ...@@ -7495,14 +7445,9 @@ package body Sem_Ch8 is
-- name resolution on component associations. (see 4717-008). In such a -- name resolution on component associations. (see 4717-008). In such a
-- case, look for the visible homonym on the chain. -- case, look for the visible homonym on the chain.
if In_Instance if In_Instance and then Present (Homonym (E)) then
and then Present (Homonym (E))
then
E := Homonym (E); 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); E := Homonym (E);
end loop; end loop;
...@@ -7610,15 +7555,13 @@ package body Sem_Ch8 is ...@@ -7610,15 +7555,13 @@ package body Sem_Ch8 is
and then and then
(Nkind (The_Unit) = N_Package_Body (Nkind (The_Unit) = N_Package_Body
or else (Nkind (The_Unit) = N_Subprogram_Body or else (Nkind (The_Unit) = N_Subprogram_Body
and then and then not Acts_As_Spec (Cunit (Current_Sem_Unit))))
not Acts_As_Spec (Cunit (Current_Sem_Unit))))
then then
With_Sys := Find_System (Library_Unit (Cunit (Current_Sem_Unit))); With_Sys := Find_System (Library_Unit (Cunit (Current_Sem_Unit)));
end if; end if;
if No (With_Sys) if No (With_Sys) and then Present (N) then
and then Present (N)
then
-- If we are compiling a subunit, we need to examine its -- If we are compiling a subunit, we need to examine its
-- context as well (Current_Sem_Unit is the parent unit); -- context as well (Current_Sem_Unit is the parent unit);
...@@ -7736,7 +7679,8 @@ package body Sem_Ch8 is ...@@ -7736,7 +7679,8 @@ package body Sem_Ch8 is
pragma Assert pragma Assert
(Nkind (Parent (E)) = N_Defining_Program_Unit_Name (Nkind (Parent (E)) = N_Defining_Program_Unit_Name
and then and then
Nkind (Parent (Parent (E))) = N_Package_Specification); Nkind (Parent (Parent (E))) =
N_Package_Specification);
Set_Is_Immediately_Visible (E, Set_Is_Immediately_Visible (E,
Limited_View_Installed (Parent (Parent (E)))); Limited_View_Installed (Parent (Parent (E))));
end if; end if;
...@@ -7746,9 +7690,8 @@ package body Sem_Ch8 is ...@@ -7746,9 +7690,8 @@ package body Sem_Ch8 is
Next_Entity (E); Next_Entity (E);
if not Full_Vis if not Full_Vis and then Is_Package_Or_Generic_Package (S) then
and then Is_Package_Or_Generic_Package (S)
then
-- We are in the visible part of the package scope -- We are in the visible part of the package scope
exit when E = First_Private_Entity (S); exit when E = First_Private_Entity (S);
...@@ -7798,8 +7741,7 @@ package body Sem_Ch8 is ...@@ -7798,8 +7741,7 @@ package body Sem_Ch8 is
elsif Is_Hidden_Open_Scope (S) then elsif Is_Hidden_Open_Scope (S) then
null; null;
elsif (Ekind (S) = E_Procedure elsif Ekind_In (S, E_Procedure, E_Function)
or else Ekind (S) = E_Function)
and then Has_Completion (S) and then Has_Completion (S)
then then
Full_Vis := True; Full_Vis := True;
...@@ -8044,8 +7986,8 @@ package body Sem_Ch8 is ...@@ -8044,8 +7986,8 @@ package body Sem_Ch8 is
and then In_Open_Scopes 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))) and then (No (Next_Formal (First_Formal (Id)))
or else Etype (First_Formal (Id)) or else Etype (First_Formal (Id)) =
= Etype (Next_Formal (First_Formal (Id))) Etype (Next_Formal (First_Formal (Id)))
or else Chars (Prev) = Name_Op_Expon) or else Chars (Prev) = Name_Op_Expon)
then then
goto Next_Usable_Entity; goto Next_Usable_Entity;
...@@ -8074,14 +8016,11 @@ package body Sem_Ch8 is ...@@ -8074,14 +8016,11 @@ package body Sem_Ch8 is
-- On exit, we know entity is not hidden, unless it is private -- On exit, we know entity is not hidden, unless it is private
if not Is_Hidden (Id) if not Is_Hidden (Id)
and then ((not Is_Child_Unit (Id)) and then ((not Is_Child_Unit (Id)) or else Is_Visible_Lib_Unit (Id))
or else Is_Visible_Lib_Unit (Id))
then then
Set_Is_Potentially_Use_Visible (Id); Set_Is_Potentially_Use_Visible (Id);
if Is_Private_Type (Id) if Is_Private_Type (Id) and then Present (Full_View (Id)) then
and then Present (Full_View (Id))
then
Set_Is_Potentially_Use_Visible (Full_View (Id)); Set_Is_Potentially_Use_Visible (Full_View (Id));
end if; end if;
end if; end if;
...@@ -8252,9 +8191,7 @@ package body Sem_Ch8 is ...@@ -8252,9 +8191,7 @@ package body Sem_Ch8 is
-- a limited view unless we only have a limited view of its enclosing -- a limited view unless we only have a limited view of its enclosing
-- package. -- package.
elsif From_With_Type (T) elsif From_With_Type (T) and then From_With_Type (Scope (T)) then
and then From_With_Type (Scope (T))
then
Error_Msg_N Error_Msg_N
("incomplete type from limited view " ("incomplete type from limited view "
& "cannot appear in use clause", Id); & "cannot appear in use clause", Id);
...@@ -8386,7 +8323,6 @@ package body Sem_Ch8 is ...@@ -8386,7 +8323,6 @@ package body Sem_Ch8 is
and then and then
Nkind (Parent (Clause2)) = N_Compilation_Unit Nkind (Parent (Clause2)) = N_Compilation_Unit
then then
-- If the unit is a subprogram body that acts as spec, -- If the unit is a subprogram body that acts as spec,
-- the context clause is shared with the constructed -- the context clause is shared with the constructed
-- subprogram spec. Clearly there is no redundancy. -- subprogram spec. Clearly there is no redundancy.
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment