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