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 228 additions and 294 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
...@@ -141,13 +141,13 @@ package body Sem_Ch5 is ...@@ -141,13 +141,13 @@ package body Sem_Ch5 is
-- directly. -- directly.
elsif (Is_Prival (Ent) elsif (Is_Prival (Ent)
and then and then
(Ekind (Current_Scope) = E_Function (Ekind (Current_Scope) = E_Function
or else Ekind (Enclosing_Dynamic_Scope or else Ekind (Enclosing_Dynamic_Scope
(Current_Scope)) = E_Function)) (Current_Scope)) = E_Function))
or else or else
(Ekind (Ent) = E_Component (Ekind (Ent) = E_Component
and then Is_Protected_Type (Scope (Ent))) and then Is_Protected_Type (Scope (Ent)))
then then
Error_Msg_N Error_Msg_N
("protected function cannot modify protected object", N); ("protected function cannot modify protected object", N);
...@@ -222,16 +222,15 @@ package body Sem_Ch5 is ...@@ -222,16 +222,15 @@ 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))) =
N_Object_Renaming_Declaration N_Object_Renaming_Declaration
and then Nkind (Parent (Parent (Entity (Opnd)))) = and then Nkind (Parent (Parent (Entity (Opnd)))) =
N_Accept_Statement)) N_Accept_Statement))
then then
Opnd_Type := Get_Actual_Subtype (Opnd); Opnd_Type := Get_Actual_Subtype (Opnd);
...@@ -394,7 +393,7 @@ package body Sem_Ch5 is ...@@ -394,7 +393,7 @@ package body Sem_Ch5 is
end loop; end loop;
if (Nkind (Ent) = N_Attribute_Reference 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 -- Renamings of the attribute Priority applied to protected
-- objects have been previously expanded into calls to the -- objects have been previously expanded into calls to the
...@@ -402,15 +401,15 @@ package body Sem_Ch5 is ...@@ -402,15 +401,15 @@ package body Sem_Ch5 is
or else or else
(Nkind (Ent) = N_Function_Call (Nkind (Ent) = N_Function_Call
and then (Entity (Name (Ent)) = RTE (RE_Get_Ceiling) and then (Entity (Name (Ent)) = RTE (RE_Get_Ceiling)
or else or else
Entity (Name (Ent)) = RTE (RO_PE_Get_Ceiling))) Entity (Name (Ent)) = RTE (RO_PE_Get_Ceiling)))
then then
-- The enclosing subprogram cannot be a protected function -- The enclosing subprogram cannot be a protected function
S := Current_Scope; S := Current_Scope;
while not (Is_Subprogram (S) while not (Is_Subprogram (S)
and then Convention (S) = Convention_Protected) and then Convention (S) = Convention_Protected)
and then S /= Standard_Standard and then S /= Standard_Standard
loop loop
S := Scope (S); S := Scope (S);
...@@ -583,8 +582,8 @@ package body Sem_Ch5 is ...@@ -583,8 +582,8 @@ package body Sem_Ch5 is
Propagate_Tag (Lhs, Rhs); Propagate_Tag (Lhs, Rhs);
elsif Nkind (Rhs) = N_Function_Call elsif Nkind (Rhs) = N_Function_Call
and then Is_Entity_Name (Name (Rhs)) and then Is_Entity_Name (Name (Rhs))
and then Is_Abstract_Subprogram (Entity (Name (Rhs))) and then Is_Abstract_Subprogram (Entity (Name (Rhs)))
then then
Error_Msg_N Error_Msg_N
("call to abstract function must be dispatching", Name (Rhs)); ("call to abstract function must be dispatching", Name (Rhs));
...@@ -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,12 +662,10 @@ package body Sem_Ch5 is ...@@ -665,12 +662,10 @@ 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 (Nkind (Rhs) /= N_Function_Call
and then or else Nkind (N) /= N_Block_Statement)
(Nkind (Rhs) /= N_Function_Call
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,
-- but of course the indexes do not have to match. If the right-hand -- but of course the indexes do not have to match. If the right-hand
...@@ -1172,7 +1167,7 @@ package body Sem_Ch5 is ...@@ -1172,7 +1167,7 @@ package body Sem_Ch5 is
elsif Ada_Version = Ada_83 elsif Ada_Version = Ada_83
and then (Is_Generic_Type (Exp_Btype) 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 then
Error_Msg_N Error_Msg_N
("(Ada 83) case expression cannot be of a generic type", Exp); ("(Ada 83) case expression cannot be of a generic type", Exp);
...@@ -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,9 +2223,8 @@ package body Sem_Ch5 is ...@@ -2238,9 +2223,8 @@ 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
-- analyze it to capture function calls that may require -- analyze it to capture function calls that may require
...@@ -2351,7 +2335,7 @@ package body Sem_Ch5 is ...@@ -2351,7 +2335,7 @@ package body Sem_Ch5 is
and then Is_Itype (Etype (Id)) and then Is_Itype (Etype (Id))
and then Nkind (Parent (Loop_Nod)) = N_Expression_With_Actions and then Nkind (Parent (Loop_Nod)) = N_Expression_With_Actions
and then Nkind (Original_Node (Parent (Loop_Nod))) = and then Nkind (Original_Node (Parent (Loop_Nod))) =
N_Quantified_Expression) N_Quantified_Expression)
then then
Set_Etype (Id, Etype (DS)); Set_Etype (Id, Etype (DS));
end if; end if;
...@@ -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,10 +2432,23 @@ package body Sem_Ch5 is ...@@ -2449,10 +2432,23 @@ 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
Error_Msg_N ("??loop range may be null", DS); -- Lower bound may in fact be known and known not to exceed
Error_Msg_N ("\??bounds may be wrong way round", DS); -- 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 if;
end; end;
end if; end if;
...@@ -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;
...@@ -1103,7 +1120,7 @@ package body Sem_Ch8 is ...@@ -1103,7 +1120,7 @@ package body Sem_Ch8 is
-- have a null exclusion or a null-excluding subtype. -- have a null exclusion or a null-excluding subtype.
if Is_Formal_Object (Nam_Ent) if Is_Formal_Object (Nam_Ent)
and then In_Generic_Scope (Id) and then In_Generic_Scope (Id)
then then
if not Can_Never_Be_Null (Etype (Nam_Ent)) then if not Can_Never_Be_Null (Etype (Nam_Ent)) then
Error_Msg_N Error_Msg_N
...@@ -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` "
...@@ -1214,7 +1231,7 @@ package body Sem_Ch8 is ...@@ -1214,7 +1231,7 @@ package body Sem_Ch8 is
Nkind (Original_Node (Nam)) /= N_Attribute_Reference) Nkind (Original_Node (Nam)) /= N_Attribute_Reference)
or else (Nkind (Nam) = N_Type_Conversion 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 then
null; 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,13 +1996,11 @@ package body Sem_Ch8 is ...@@ -1982,13 +1996,11 @@ 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))
or else Can_Never_Be_Null (Etype (Sub_Formal))) or else Can_Never_Be_Null (Etype (Sub_Formal)))
then then
Error_Msg_NE Error_Msg_NE
("`NOT NULL` required for parameter &", ("`NOT NULL` required for parameter &",
...@@ -2004,9 +2016,8 @@ package body Sem_Ch8 is ...@@ -2004,9 +2016,8 @@ 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
("return must specify `NOT NULL`", ("return must specify `NOT NULL`",
...@@ -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
...@@ -2382,8 +2390,8 @@ package body Sem_Ch8 is ...@@ -2382,8 +2390,8 @@ package body Sem_Ch8 is
pragma Assert pragma Assert
(Is_Primitive (Entity (Nam)) (Is_Primitive (Entity (Nam))
and then and then
Is_Abstract_Type (Find_Dispatching_Type (Entity (Nam)))); Is_Abstract_Type (Find_Dispatching_Type (Entity (Nam))));
declare declare
Old_Decl : constant Node_Id := Old_Decl : constant Node_Id :=
Unit_Declaration_Node (Rename_Spec); Unit_Declaration_Node (Rename_Spec);
...@@ -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;
...@@ -2750,13 +2751,12 @@ package body Sem_Ch8 is ...@@ -2750,13 +2751,12 @@ package body Sem_Ch8 is
Set_Is_Intrinsic_Subprogram Set_Is_Intrinsic_Subprogram
(New_S, (New_S,
Is_Intrinsic_Subprogram (Old_S) Is_Intrinsic_Subprogram (Old_S)
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
Set_Has_Delayed_Freeze (New_S, False); Set_Has_Delayed_Freeze (New_S, False);
...@@ -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,9 +2979,8 @@ package body Sem_Ch8 is ...@@ -2980,9 +2979,8 @@ 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)
then then
...@@ -3003,9 +3001,8 @@ package body Sem_Ch8 is ...@@ -3003,9 +3001,8 @@ 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)
then then
...@@ -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,12 +3580,10 @@ package body Sem_Ch8 is ...@@ -3591,12 +3580,10 @@ 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));
end if; end if;
else else
...@@ -3629,11 +3616,10 @@ package body Sem_Ch8 is ...@@ -3629,11 +3616,10 @@ 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,
N_Component_Declaration) N_Component_Declaration)
loop loop
P := Parent (P); P := Parent (P);
end loop; end loop;
...@@ -3670,13 +3656,10 @@ package body Sem_Ch8 is ...@@ -3670,13 +3656,10 @@ 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
and then Nkind (Name (Item)) /= N_Selected_Component and then Nkind (Name (Item)) /= N_Selected_Component
and then Entity (Name (Item)) = Pack and then Entity (Name (Item)) = Pack
...@@ -3745,9 +3728,9 @@ package body Sem_Ch8 is ...@@ -3745,9 +3728,9 @@ package body Sem_Ch8 is
("renamed unit must be a child unit of generic parent", Name (N)); ("renamed unit must be a child unit of generic parent", Name (N));
elsif Nkind (N) in N_Generic_Renaming_Declaration elsif Nkind (N) in N_Generic_Renaming_Declaration
and then Nkind (Name (N)) = N_Expanded_Name and then Nkind (Name (N)) = N_Expanded_Name
and then Is_Generic_Instance (Entity (Prefix (Name (N)))) and then Is_Generic_Instance (Entity (Prefix (Name (N))))
and then Is_Generic_Unit (Old_E) and then Is_Generic_Unit (Old_E)
then then
Error_Msg_N Error_Msg_N
("renamed generic unit must be a library unit", Name (N)); ("renamed generic unit must be a library unit", Name (N));
...@@ -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,16 +3959,14 @@ package body Sem_Ch8 is ...@@ -3952,16 +3959,14 @@ 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 Is_Primitive_Operator_In_Use
Is_Primitive_Operator_In_Use (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;
...@@ -4222,10 +4227,10 @@ package body Sem_Ch8 is ...@@ -4222,10 +4227,10 @@ package body Sem_Ch8 is
Nkind (N) = N_Identifier Nkind (N) = N_Identifier
and then and then
(Nkind (Parent (N)) = N_Procedure_Call_Statement (Nkind (Parent (N)) = N_Procedure_Call_Statement
or else or else
(Nkind (Parent (N)) = N_Parameter_Association (Nkind (Parent (N)) = N_Parameter_Association
and then N = Explicit_Actual_Parameter (Parent (N)) and then N = Explicit_Actual_Parameter (Parent (N))
and then Nkind (Parent (Parent (N))) = and then Nkind (Parent (Parent (N))) =
N_Procedure_Call_Statement)); N_Procedure_Call_Statement));
end Is_Actual_Parameter; end Is_Actual_Parameter;
...@@ -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
...@@ -5481,11 +5480,11 @@ package body Sem_Ch8 is ...@@ -5481,11 +5480,11 @@ package body Sem_Ch8 is
if Is_Task_Type (P_Name) if Is_Task_Type (P_Name)
and then ((Ekind (Id) = E_Entry and then ((Ekind (Id) = E_Entry
and then Nkind (Parent (N)) /= N_Attribute_Reference) and then Nkind (Parent (N)) /= N_Attribute_Reference)
or else or else
(Ekind (Id) = E_Entry_Family (Ekind (Id) = E_Entry_Family
and then and then
Nkind (Parent (Parent (N))) /= N_Attribute_Reference)) Nkind (Parent (Parent (N))) /= N_Attribute_Reference))
then then
-- If both the task type and the entry are in scope, this may still -- If both the task type and the entry are in scope, this may still
-- be the expanded name of an entry formal. -- be the expanded name of an entry formal.
...@@ -5538,18 +5537,15 @@ package body Sem_Ch8 is ...@@ -5538,18 +5537,15 @@ 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);
exit; exit;
...@@ -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,9 +5642,8 @@ package body Sem_Ch8 is ...@@ -5683,9 +5642,8 @@ 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;
...@@ -5964,10 +5925,10 @@ package body Sem_Ch8 is ...@@ -5964,10 +5925,10 @@ package body Sem_Ch8 is
((RTE_Available (RE_Dispatch_Table_Wrapper) ((RTE_Available (RE_Dispatch_Table_Wrapper)
and then Scope (Selector) = and then Scope (Selector) =
RTE (RE_Dispatch_Table_Wrapper)) RTE (RE_Dispatch_Table_Wrapper))
or else or else
(RTE_Available (RE_No_Dispatch_Table_Wrapper) (RTE_Available (RE_No_Dispatch_Table_Wrapper)
and then Scope (Selector) = and then Scope (Selector) =
RTE (RE_No_Dispatch_Table_Wrapper))) RTE (RE_No_Dispatch_Table_Wrapper)))
then then
C_Etype := Empty; C_Etype := Empty;
...@@ -6071,7 +6032,7 @@ package body Sem_Ch8 is ...@@ -6071,7 +6032,7 @@ package body Sem_Ch8 is
elsif Is_Appropriate_For_Entry_Prefix (P_Type) elsif Is_Appropriate_For_Entry_Prefix (P_Type)
and then not In_Open_Scopes (P_Name) and then not In_Open_Scopes (P_Name)
and then (not Is_Concurrent_Type (Etype (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 then
-- Call to protected operation or entry. Type checking is -- Call to protected operation or entry. Type checking is
-- needed on the prefix. -- needed on the prefix.
...@@ -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;
...@@ -7609,16 +7554,14 @@ package body Sem_Ch8 is ...@@ -7609,16 +7554,14 @@ package body Sem_Ch8 is
if No (With_Sys) if No (With_Sys)
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);
...@@ -7735,8 +7678,9 @@ package body Sem_Ch8 is ...@@ -7735,8 +7678,9 @@ package body Sem_Ch8 is
else else
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;
...@@ -7974,7 +7916,7 @@ package body Sem_Ch8 is ...@@ -7974,7 +7916,7 @@ package body Sem_Ch8 is
Id := First_Entity (P); Id := First_Entity (P);
while Present (Id) while Present (Id)
and then (Id /= First_Private_Entity (P) 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 loop
Prev := Current_Entity (Id); Prev := Current_Entity (Id);
while Present (Prev) loop while Present (Prev) loop
...@@ -8042,10 +7984,10 @@ package body Sem_Ch8 is ...@@ -8042,10 +7984,10 @@ package body Sem_Ch8 is
elsif Ekind (Prev) = E_Operator elsif Ekind (Prev) = E_Operator
and then Operator_Matches_Spec (Prev, Id) and then Operator_Matches_Spec (Prev, Id)
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,12 +8191,10 @@ package body Sem_Ch8 is ...@@ -8252,12 +8191,10 @@ 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);
-- If the subtype mark designates a subtype in a different package, -- If the subtype mark designates a subtype in a different package,
-- we have to check that the parent type is visible, otherwise the -- we have to check that the parent type is visible, otherwise the
...@@ -8321,18 +8258,18 @@ package body Sem_Ch8 is ...@@ -8321,18 +8258,18 @@ package body Sem_Ch8 is
if Warn_On_Redundant_Constructs if Warn_On_Redundant_Constructs
and then Is_Known_Used and then Is_Known_Used
-- with P; with P; use P; -- with P; with P; use P;
-- package P is package X is package body X is -- package P is package X is package body X is
-- type T ... use P.T; -- type T ... use P.T;
-- The compilation unit is the body of X. GNAT first compiles the -- 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 -- 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 -- as use visible. The analysis then reinstalls the spec along with
-- its context. The use clause P.T is now recognized as redundant, -- 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. -- 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 -- 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 -- no redundancy between an outer use_clause and one that appears
-- within the generic. -- within the generic.
and then not Spec_Reloaded_For_Body and then not Spec_Reloaded_For_Body
and then not In_Instance and then not In_Instance
...@@ -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