Skip to content

R
riscv-gcc-1
Commit 02bb0765 by Arnaud Charlet
Options

[multiple changes] 

2014-07-29  Robert Dewar  <dewar@adacore.com>

	* einfo.adb (Has_Protected): Test base type.
	* sem_ch4.adb (Analyze_Allocator): Reorganize code to make sure
	that we always properly check No_Protected_Type_Allocators.

2014-07-29  Ed Schonberg  <schonberg@adacore.com>

	* sem_util.ads, sem_util.adb (Defining_Entity):	Now applies to
	loop declarations as well.
	* exp_ch5.adb (Expand_Loop_Statement): Apply Qualify_Entity_Names
	to an iterator loop, because it may contain local renaming
	declarations that require debugging information.

2014-07-29  Robert Dewar  <dewar@adacore.com>

	* sem_util.ads, exp_util.adb, sem_attr.adb: Minor reformatting.

From-SVN: r213163
parent fc3a3f3b
Showing with 223 additions and 268 deletions
gcc/ada/ChangeLog
2014-07-29 Robert Dewar <dewar@adacore.com> 2014-07-29 Robert Dewar <dewar@adacore.com>
* einfo.adb (Has_Protected): Test base type.
* sem_ch4.adb (Analyze_Allocator): Reorganize code to make sure
that we always properly check No_Protected_Type_Allocators.
2014-07-29 Ed Schonberg <schonberg@adacore.com>
* sem_util.ads, sem_util.adb (Defining_Entity): Now applies to
loop declarations as well.
* exp_ch5.adb (Expand_Loop_Statement): Apply Qualify_Entity_Names
to an iterator loop, because it may contain local renaming
declarations that require debugging information.
2014-07-29 Robert Dewar <dewar@adacore.com>
* sem_util.ads, exp_util.adb, sem_attr.adb: Minor reformatting.
2014-07-29 Robert Dewar <dewar@adacore.com>
* einfo.ads, einfo.adb (Static_Real_Or_String_Predicate): New function * einfo.ads, einfo.adb (Static_Real_Or_String_Predicate): New function
(Set_Static_Real_Or_String_Predicate): New procedure (Set_Static_Real_Or_String_Predicate): New procedure
* sem_ch13.adb (Build_Predicate_Functions): Accomodate static * sem_ch13.adb (Build_Predicate_Functions): Accomodate static
......
gcc/ada/einfo.adb
...@@ -1647,7 +1647,7 @@ package body Einfo is ...@@ -1647,7 +1647,7 @@ package body Einfo is
function Has_Protected (Id : E) return B is function Has_Protected (Id : E) return B is
begin begin
return Flag271 (Id); return Flag271 (Base_Type (Id));
end Has_Protected; end Has_Protected;
function Has_Qualified_Name (Id : E) return B is function Has_Qualified_Name (Id : E) return B is
......
gcc/ada/exp_ch5.adb
...@@ -3946,6 +3946,19 @@ package body Exp_Ch5 is ...@@ -3946,6 +3946,19 @@ package body Exp_Ch5 is
and then Present (Iterator_Specification (Scheme)) and then Present (Iterator_Specification (Scheme))
then then
Expand_Iterator_Loop (N); Expand_Iterator_Loop (N);
-- An iterator loop may generate renaming declarations for elements
-- that require debug information. This is the case in particular
-- with element iterators, where debug information must be generated
-- for the temporary that holds the element value. These temporaries
-- are created within a transient block whose local declarations are
-- transferred to the loop, which now has non-trivial local objects.
if Nkind (N) = N_Loop_Statement
and then Present (Identifier (N))
then
Qualify_Entity_Names (N);
end if;
end if; end if;
-- When the iteration scheme mentiones attribute 'Loop_Entry, the loop -- When the iteration scheme mentiones attribute 'Loop_Entry, the loop
......
gcc/ada/exp_util.adb
...@@ -5447,6 +5447,8 @@ package body Exp_Util is ...@@ -5447,6 +5447,8 @@ package body Exp_Util is
-- that it is common and reasonable for code to be deleted in -- that it is common and reasonable for code to be deleted in
-- instances for various reasons. -- instances for various reasons.
-- Could we use Is_Statically_Unevaluated here???
if Nkind (Parent (N)) = N_If_Statement then if Nkind (Parent (N)) = N_If_Statement then
declare declare
C : constant Node_Id := Condition (Parent (N)); C : constant Node_Id := Condition (Parent (N));
...@@ -5495,6 +5497,7 @@ package body Exp_Util is ...@@ -5495,6 +5497,7 @@ package body Exp_Util is
declare declare
E : Entity_Id := First_Entity (Defining_Entity (N)); E : Entity_Id := First_Entity (Defining_Entity (N));
begin begin
while Present (E) loop while Present (E) loop
if Ekind (E) = E_Operator then if Ekind (E) = E_Operator then
...@@ -5510,7 +5513,7 @@ package body Exp_Util is ...@@ -5510,7 +5513,7 @@ package body Exp_Util is
elsif Nkind (N) = N_If_Statement then elsif Nkind (N) = N_If_Statement then
Kill_Dead_Code (Then_Statements (N)); Kill_Dead_Code (Then_Statements (N));
Kill_Dead_Code (Elsif_Parts (N)); Kill_Dead_Code (Elsif_Parts (N));
Kill_Dead_Code (Else_Statements (N)); Kill_Dead_Code (Else_Statements (N));
elsif Nkind (N) = N_Loop_Statement then elsif Nkind (N) = N_Loop_Statement then
...@@ -5543,8 +5546,10 @@ package body Exp_Util is ...@@ -5543,8 +5546,10 @@ package body Exp_Util is
procedure Kill_Dead_Code (L : List_Id; Warn : Boolean := False) is procedure Kill_Dead_Code (L : List_Id; Warn : Boolean := False) is
N : Node_Id; N : Node_Id;
W : Boolean; W : Boolean;
begin begin
W := Warn; W := Warn;
if Is_Non_Empty_List (L) then if Is_Non_Empty_List (L) then
N := First (L); N := First (L);
while Present (N) loop while Present (N) loop
...@@ -6770,7 +6775,7 @@ package body Exp_Util is ...@@ -6770,7 +6775,7 @@ package body Exp_Util is
Analyze (Block); Analyze (Block);
end if; end if;
when others => when others =>
null; null;
end case; end case;
end Process_Statements_For_Controlled_Objects; end Process_Statements_For_Controlled_Objects;
...@@ -6782,6 +6787,7 @@ package body Exp_Util is ...@@ -6782,6 +6787,7 @@ package body Exp_Util is
function Power_Of_Two (N : Node_Id) return Nat is function Power_Of_Two (N : Node_Id) return Nat is
Typ : constant Entity_Id := Etype (N); Typ : constant Entity_Id := Etype (N);
pragma Assert (Is_Integer_Type (Typ)); pragma Assert (Is_Integer_Type (Typ));
Siz : constant Nat := UI_To_Int (Esize (Typ)); Siz : constant Nat := UI_To_Int (Esize (Typ));
Val : Uint; Val : Uint;
...@@ -8703,7 +8709,6 @@ package body Exp_Util is ...@@ -8703,7 +8709,6 @@ package body Exp_Util is
Loc : constant Source_Ptr := Sloc (N); Loc : constant Source_Ptr := Sloc (N);
Stseq : constant Node_Id := Handled_Statement_Sequence (N); Stseq : constant Node_Id := Handled_Statement_Sequence (N);
Stmts : constant List_Id := Statements (Stseq); Stmts : constant List_Id := Statements (Stseq);
begin begin
if Abort_Allowed then if Abort_Allowed then
Prepend_To (Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer)); Prepend_To (Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer));
......
gcc/ada/sem_attr.adb
...@@ -5492,7 +5492,7 @@ package body Sem_Attr is ...@@ -5492,7 +5492,7 @@ package body Sem_Attr is
when Attribute_Scalar_Storage_Order => Scalar_Storage_Order : when Attribute_Scalar_Storage_Order => Scalar_Storage_Order :
declare declare
Ent : Entity_Id := Empty; Ent : Entity_Id := Empty;
begin begin
Check_E0; Check_E0;
...@@ -5505,7 +5505,7 @@ package body Sem_Attr is ...@@ -5505,7 +5505,7 @@ package body Sem_Attr is
-- the default bit order for the target. -- the default bit order for the target.
if not (GNAT_Mode and then Is_Generic_Type (P_Type)) if not (GNAT_Mode and then Is_Generic_Type (P_Type))
and then not In_Instance and then not In_Instance
then then
Error_Attr_P Error_Attr_P
("prefix of % attribute must be record or array type"); ("prefix of % attribute must be record or array type");
......
gcc/ada/sem_ch4.adb
...@@ -639,15 +639,6 @@ package body Sem_Ch4 is ...@@ -639,15 +639,6 @@ package body Sem_Ch4 is
end; end;
end if; end if;
-- Check restriction against dynamically allocated protected
-- objects. Note that when limited aggregates are supported,
-- a similar test should be applied to an allocator with a
-- qualified expression ???
if Has_Protected (Type_Id) then
Check_Restriction (No_Protected_Type_Allocators, N);
end if;
-- Check for missing initialization. Skip this check if we already -- Check for missing initialization. Skip this check if we already
-- had errors on analyzing the allocator, since in that case these -- had errors on analyzing the allocator, since in that case these
-- are probably cascaded errors. -- are probably cascaded errors.
...@@ -725,6 +716,12 @@ package body Sem_Ch4 is ...@@ -725,6 +716,12 @@ package body Sem_Ch4 is
Check_Restriction (No_Task_Allocators, N); Check_Restriction (No_Task_Allocators, N);
end if; end if;
-- Check restriction against dynamically allocated protected objects
if Has_Protected (Designated_Type (Acc_Type)) then
Check_Restriction (No_Protected_Type_Allocators, N);
end if;
-- AI05-0013-1: No_Nested_Finalization forbids allocators if the access -- AI05-0013-1: No_Nested_Finalization forbids allocators if the access
-- type is nested, and the designated type needs finalization. The rule -- type is nested, and the designated type needs finalization. The rule
-- is conservative in that class-wide types need finalization. -- is conservative in that class-wide types need finalization.
......
gcc/ada/sem_util.adb
...@@ -153,8 +153,8 @@ package body Sem_Util is ...@@ -153,8 +153,8 @@ package body Sem_Util is
elsif Nkind (Parent (Typ)) = N_Private_Type_Declaration then elsif Nkind (Parent (Typ)) = N_Private_Type_Declaration then
if Present (Full_View (Typ)) if Present (Full_View (Typ))
and then Nkind (Parent (Full_View (Typ))) and then
= N_Full_Type_Declaration Nkind (Parent (Full_View (Typ))) = N_Full_Type_Declaration
then then
Nod := Type_Definition (Parent (Full_View (Typ))); Nod := Type_Definition (Parent (Full_View (Typ)));
...@@ -2149,7 +2149,7 @@ package body Sem_Util is ...@@ -2149,7 +2149,7 @@ package body Sem_Util is
Get_Index_Bounds (Choice, L, H); Get_Index_Bounds (Choice, L, H);
pragma Assert pragma Assert
(Compile_Time_Known_Value (L) (Compile_Time_Known_Value (L)
and then Compile_Time_Known_Value (H)); and then Compile_Time_Known_Value (H));
Count_Components := Count_Components :=
Count_Components Count_Components
+ Expr_Value (H) - Expr_Value (L) + 1; + Expr_Value (H) - Expr_Value (L) + 1;
...@@ -2364,9 +2364,7 @@ package body Sem_Util is ...@@ -2364,9 +2364,7 @@ package body Sem_Util is
elsif not Comes_From_Source (Nam) then elsif not Comes_From_Source (Nam) then
return; return;
elsif Is_Entity_Name (Nam) elsif Is_Entity_Name (Nam) and then Is_Type (Entity (Nam)) then
and then Is_Type (Entity (Nam))
then
null; null;
else else
...@@ -2542,11 +2540,7 @@ package body Sem_Util is ...@@ -2542,11 +2540,7 @@ package body Sem_Util is
-- Check for Is_Imported needs commenting below ??? -- Check for Is_Imported needs commenting below ???
if VM_Target /= No_VM if VM_Target /= No_VM
and then (Ekind (Ent) = E_Variable and then Ekind_In (Ent, E_Variable, E_Constant, E_Loop_Parameter)
or else
Ekind (Ent) = E_Constant
or else
Ekind (Ent) = E_Loop_Parameter)
and then Scope (Ent) /= Empty and then Scope (Ent) /= Empty
and then not Is_Library_Level_Entity (Ent) and then not Is_Library_Level_Entity (Ent)
and then not Is_Imported (Ent) and then not Is_Imported (Ent)
...@@ -2562,9 +2556,7 @@ package body Sem_Util is ...@@ -2562,9 +2556,7 @@ package body Sem_Util is
Enclosing := Enclosing_Subprogram (Ent); Enclosing := Enclosing_Subprogram (Ent);
if Enclosing /= Empty if Enclosing /= Empty and then Enclosing /= Current_Subp then
and then Enclosing /= Current_Subp
then
Set_Has_Up_Level_Access (Ent, True); Set_Has_Up_Level_Access (Ent, True);
end if; end if;
end if; end if;
...@@ -2769,7 +2761,7 @@ package body Sem_Util is ...@@ -2769,7 +2761,7 @@ package body Sem_Util is
Comes_From_Source (N) Comes_From_Source (N)
and then Is_Entity_Name (N) and then Is_Entity_Name (N)
and then (Entity (N) = Standard_True and then (Entity (N) = Standard_True
or else Entity (N) = Standard_False); or else Entity (N) = Standard_False);
end Is_Trivial_Boolean; end Is_Trivial_Boolean;
------------------------- -------------------------
...@@ -2950,9 +2942,7 @@ package body Sem_Util is ...@@ -2950,9 +2942,7 @@ package body Sem_Util is
begin begin
S := Current_Scope; S := Current_Scope;
while Present (S) while Present (S) and then S /= Pref_Encl_Typ loop
and then S /= Pref_Encl_Typ
loop
if Scope (S) = Pref_Encl_Typ then if Scope (S) = Pref_Encl_Typ then
E := First_Entity (Pref_Encl_Typ); E := First_Entity (Pref_Encl_Typ);
while Present (E) while Present (E)
...@@ -2961,6 +2951,7 @@ package body Sem_Util is ...@@ -2961,6 +2951,7 @@ package body Sem_Util is
if E = S then if E = S then
return True; return True;
end if; end if;
Next_Entity (E); Next_Entity (E);
end loop; end loop;
end if; end if;
...@@ -2987,7 +2978,7 @@ package body Sem_Util is ...@@ -2987,7 +2978,7 @@ package body Sem_Util is
and then No (Cont_Encl_Typ) and then No (Cont_Encl_Typ)
and then Is_Public_Operation and then Is_Public_Operation
and then Scope_Depth (Pref_Encl_Typ) >= and then Scope_Depth (Pref_Encl_Typ) >=
Object_Access_Level (Context) Object_Access_Level (Context)
then then
Error_Msg_N Error_Msg_N
("??possible unprotected access to protected data", Expr); ("??possible unprotected access to protected data", Expr);
...@@ -3064,9 +3055,7 @@ package body Sem_Util is ...@@ -3064,9 +3055,7 @@ package body Sem_Util is
Ancestor := Etype (Full_T); Ancestor := Etype (Full_T);
Collect (Ancestor); Collect (Ancestor);
if Is_Interface (Ancestor) if Is_Interface (Ancestor) and then not Exclude_Parents then
and then not Exclude_Parents
then
Append_Unique_Elmt (Ancestor, Ifaces_List); Append_Unique_Elmt (Ancestor, Ifaces_List);
end if; end if;
end if; end if;
...@@ -3210,8 +3199,8 @@ package body Sem_Util is ...@@ -3210,8 +3199,8 @@ package body Sem_Util is
end if; end if;
while Present (ADT) while Present (ADT)
and then Is_Tag (Node (ADT)) and then Is_Tag (Node (ADT))
and then Related_Type (Node (ADT)) /= Iface and then Related_Type (Node (ADT)) /= Iface
loop loop
-- Skip secondary dispatch table referencing thunks to user -- Skip secondary dispatch table referencing thunks to user
-- defined primitives covered by this interface. -- defined primitives covered by this interface.
...@@ -3389,8 +3378,8 @@ package body Sem_Util is ...@@ -3389,8 +3378,8 @@ package body Sem_Util is
elsif Is_Generic_Type (B_Type) then elsif Is_Generic_Type (B_Type) then
if Nkind (B_Decl) = N_Formal_Type_Declaration if Nkind (B_Decl) = N_Formal_Type_Declaration
and then Nkind (Formal_Type_Definition (B_Decl)) and then Nkind (Formal_Type_Definition (B_Decl)) =
= N_Formal_Derived_Type_Definition N_Formal_Derived_Type_Definition
then then
Formal_Derived := True; Formal_Derived := True;
else else
...@@ -3489,8 +3478,7 @@ package body Sem_Util is ...@@ -3489,8 +3478,7 @@ package body Sem_Util is
-- package declaration are not primitive for it. -- package declaration are not primitive for it.
if Is_Prim if Is_Prim
and then (not Formal_Derived and then (not Formal_Derived or else Present (Alias (Id)))
or else Present (Alias (Id)))
then then
-- In the special case of an equality operator aliased to -- In the special case of an equality operator aliased to
-- an overriding dispatching equality belonging to the same -- an overriding dispatching equality belonging to the same
...@@ -4223,7 +4211,10 @@ package body Sem_Util is ...@@ -4223,7 +4211,10 @@ package body Sem_Util is
end if; end if;
end; end;
when N_Block_Statement => when
N_Block_Statement |
N_Loop_Statement
=>
return Entity (Identifier (N)); return Entity (Identifier (N));
when others => when others =>
...@@ -4241,10 +4232,9 @@ package body Sem_Util is ...@@ -4241,10 +4232,9 @@ package body Sem_Util is
Check_Concurrent : Boolean := False) return Boolean Check_Concurrent : Boolean := False) return Boolean
is is
E : Entity_Id; E : Entity_Id;
begin begin
if not Is_Entity_Name (N) if not Is_Entity_Name (N) or else No (Entity (N)) then
or else No (Entity (N))
then
return False; return False;
else else
E := Entity (N); E := Entity (N);
...@@ -4440,7 +4430,7 @@ package body Sem_Util is ...@@ -4440,7 +4430,7 @@ package body Sem_Util is
elsif Nkind (Obj1) = N_Selected_Component then elsif Nkind (Obj1) = N_Selected_Component then
return Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2)) return Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2))
and then and then
Entity (Selector_Name (Obj1)) = Entity (Selector_Name (Obj2)); Entity (Selector_Name (Obj1)) = Entity (Selector_Name (Obj2));
-- Both names are dereferences and the dereferenced names are known to -- Both names are dereferences and the dereferenced names are known to
-- denote the same object (RM 6.4.1(6.7/3)) -- denote the same object (RM 6.4.1(6.7/3))
...@@ -4509,10 +4499,11 @@ package body Sem_Util is ...@@ -4509,10 +4499,11 @@ package body Sem_Util is
and then Denotes_Same_Object (Hi1, Hi2); and then Denotes_Same_Object (Hi1, Hi2);
end; end;
-- In the recursion, literals appear as indexes. -- In the recursion, literals appear as indexes
elsif Nkind (Obj1) = N_Integer_Literal elsif Nkind (Obj1) = N_Integer_Literal
and then Nkind (Obj2) = N_Integer_Literal and then
Nkind (Obj2) = N_Integer_Literal
then then
return Intval (Obj1) = Intval (Obj2); return Intval (Obj1) = Intval (Obj2);
...@@ -4678,11 +4669,9 @@ package body Sem_Util is ...@@ -4678,11 +4669,9 @@ package body Sem_Util is
-- Start of processing for Designate_Next_Unit -- Start of processing for Designate_Next_Unit
begin begin
if (K1 = N_Identifier or else if (K1 = N_Identifier or else K1 = N_Defining_Identifier)
K1 = N_Defining_Identifier) and then
and then (K2 = N_Identifier or else K2 = N_Defining_Identifier)
(K2 = N_Identifier or else
K2 = N_Defining_Identifier)
then then
return Chars (Name1) = Chars (Name2); return Chars (Name1) = Chars (Name2);
...@@ -5106,7 +5095,7 @@ package body Sem_Util is ...@@ -5106,7 +5095,7 @@ package body Sem_Util is
-- same name as a generic formal which has been seen already. -- same name as a generic formal which has been seen already.
elsif Nkind (Parent (Def_Id)) = N_Package_Renaming_Declaration elsif Nkind (Parent (Def_Id)) = N_Package_Renaming_Declaration
and then not Comes_From_Source (Def_Id) and then not Comes_From_Source (Def_Id)
then then
Set_Is_Immediately_Visible (E, False); Set_Is_Immediately_Visible (E, False);
...@@ -5139,9 +5128,7 @@ package body Sem_Util is ...@@ -5139,9 +5128,7 @@ package body Sem_Util is
-- entity in the scope. -- entity in the scope.
Prev := First_Entity (Current_Scope); Prev := First_Entity (Current_Scope);
while Present (Prev) while Present (Prev) and then Next_Entity (Prev) /= E loop
and then Next_Entity (Prev) /= E
loop
Next_Entity (Prev); Next_Entity (Prev);
end loop; end loop;
...@@ -5301,7 +5288,7 @@ package body Sem_Util is ...@@ -5301,7 +5288,7 @@ package body Sem_Util is
end if; end if;
if Nkind (Parent (Parent (Def_Id))) = if Nkind (Parent (Parent (Def_Id))) =
N_Generic_Subprogram_Declaration N_Generic_Subprogram_Declaration
and then Def_Id = and then Def_Id =
Defining_Entity (Specification (Parent (Parent (Def_Id)))) Defining_Entity (Specification (Parent (Parent (Def_Id))))
then then
...@@ -5369,9 +5356,7 @@ package body Sem_Util is ...@@ -5369,9 +5356,7 @@ package body Sem_Util is
-- Declaring a homonym is not allowed in SPARK ... -- Declaring a homonym is not allowed in SPARK ...
if Present (C) if Present (C) and then Restriction_Check_Required (SPARK_05) then
and then Restriction_Check_Required (SPARK_05)
then
declare declare
Enclosing_Subp : constant Node_Id := Enclosing_Subprogram (Def_Id); Enclosing_Subp : constant Node_Id := Enclosing_Subprogram (Def_Id);
Enclosing_Pack : constant Node_Id := Enclosing_Package (Def_Id); Enclosing_Pack : constant Node_Id := Enclosing_Package (Def_Id);
...@@ -5419,38 +5404,38 @@ package body Sem_Util is ...@@ -5419,38 +5404,38 @@ package body Sem_Util is
if Warn_On_Hiding and then Present (C) if Warn_On_Hiding and then Present (C)
-- Don't warn for record components since they always have a well -- Don't warn for record components since they always have a well
-- defined scope which does not confuse other uses. Note that in -- defined scope which does not confuse other uses. Note that in
-- some cases, Ekind has not been set yet. -- some cases, Ekind has not been set yet.
and then Ekind (C) /= E_Component and then Ekind (C) /= E_Component
and then Ekind (C) /= E_Discriminant and then Ekind (C) /= E_Discriminant
and then Nkind (Parent (C)) /= N_Component_Declaration and then Nkind (Parent (C)) /= N_Component_Declaration
and then Ekind (Def_Id) /= E_Component and then Ekind (Def_Id) /= E_Component
and then Ekind (Def_Id) /= E_Discriminant and then Ekind (Def_Id) /= E_Discriminant
and then Nkind (Parent (Def_Id)) /= N_Component_Declaration and then Nkind (Parent (Def_Id)) /= N_Component_Declaration
-- Don't warn for one character variables. It is too common to use -- Don't warn for one character variables. It is too common to use
-- such variables as locals and will just cause too many false hits. -- such variables as locals and will just cause too many false hits.
and then Length_Of_Name (Chars (C)) /= 1 and then Length_Of_Name (Chars (C)) /= 1
-- Don't warn for non-source entities -- Don't warn for non-source entities
and then Comes_From_Source (C) and then Comes_From_Source (C)
and then Comes_From_Source (Def_Id) and then Comes_From_Source (Def_Id)
-- Don't warn unless entity in question is in extended main source -- Don't warn unless entity in question is in extended main source
and then In_Extended_Main_Source_Unit (Def_Id) and then In_Extended_Main_Source_Unit (Def_Id)
-- Finally, the hidden entity must be either immediately visible or -- Finally, the hidden entity must be either immediately visible or
-- use visible (i.e. from a used package). -- use visible (i.e. from a used package).
and then and then
(Is_Immediately_Visible (C) (Is_Immediately_Visible (C)
or else or else
Is_Potentially_Use_Visible (C)) Is_Potentially_Use_Visible (C))
then then
Error_Msg_Sloc := Sloc (C); Error_Msg_Sloc := Sloc (C);
Error_Msg_N ("declaration hides &#?h?", Def_Id); Error_Msg_N ("declaration hides &#?h?", Def_Id);
...@@ -5552,9 +5537,7 @@ package body Sem_Util is ...@@ -5552,9 +5537,7 @@ package body Sem_Util is
Actual : Node_Id; Actual : Node_Id;
begin begin
if (Nkind (Parnt) = N_Indexed_Component if Nkind_In (Parnt, N_Indexed_Component, N_Selected_Component)
or else
Nkind (Parnt) = N_Selected_Component)
and then N = Prefix (Parnt) and then N = Prefix (Parnt)
then then
Find_Actual (Parnt, Formal, Call); Find_Actual (Parnt, Formal, Call);
...@@ -5693,10 +5676,10 @@ package body Sem_Util is ...@@ -5693,10 +5676,10 @@ package body Sem_Util is
while Present (Old_Disc) and then Present (New_Disc) loop while Present (Old_Disc) and then Present (New_Disc) loop
if Old_Disc = Par_Disc then if Old_Disc = Par_Disc then
return New_Disc; return New_Disc;
else
Next_Discriminant (Old_Disc);
Next_Discriminant (New_Disc);
end if; end if;
Next_Discriminant (Old_Disc);
Next_Discriminant (New_Disc);
end loop; end loop;
-- Should always find it -- Should always find it
...@@ -5984,8 +5967,7 @@ package body Sem_Util is ...@@ -5984,8 +5967,7 @@ package body Sem_Util is
-- be a static subtype, since otherwise it would have -- be a static subtype, since otherwise it would have
-- been diagnosed as illegal. -- been diagnosed as illegal.
elsif Is_Entity_Name (Choice) elsif Is_Entity_Name (Choice) and then Is_Type (Entity (Choice))
and then Is_Type (Entity (Choice))
then then
exit Search when Is_In_Range (Expr, Etype (Choice), exit Search when Is_In_Range (Expr, Etype (Choice),
Assume_Valid => False); Assume_Valid => False);
...@@ -5999,7 +5981,7 @@ package body Sem_Util is ...@@ -5999,7 +5981,7 @@ package body Sem_Util is
begin begin
exit Search when exit Search when
Val >= Expr_Value (Low_Bound (R)) Val >= Expr_Value (Low_Bound (R))
and then and then
Val <= Expr_Value (High_Bound (R)); Val <= Expr_Value (High_Bound (R));
end; end;
...@@ -7273,8 +7255,7 @@ package body Sem_Util is ...@@ -7273,8 +7255,7 @@ package body Sem_Util is
-- where we do not know the alignment of Obj. -- where we do not know the alignment of Obj.
if Known_Alignment (Entity (Expr)) if Known_Alignment (Entity (Expr))
and then and then UI_To_Int (Alignment (Entity (Expr))) <
UI_To_Int (Alignment (Entity (Expr))) <
Ttypes.Maximum_Alignment Ttypes.Maximum_Alignment
then then
Set_Result (Unknown); Set_Result (Unknown);
...@@ -7509,7 +7490,7 @@ package body Sem_Util is ...@@ -7509,7 +7490,7 @@ package body Sem_Util is
if Nkind (Prop_Nam) = N_Others_Choice if Nkind (Prop_Nam) = N_Others_Choice
or else (Nkind (Prop_Nam) = N_Identifier or else (Nkind (Prop_Nam) = N_Identifier
and then Chars (Prop_Nam) = Property) and then Chars (Prop_Nam) = Property)
then then
return Is_True (Expr_Value (Expression (Prop))); return Is_True (Expr_Value (Expression (Prop)));
end if; end if;
...@@ -7563,24 +7544,20 @@ package body Sem_Util is ...@@ -7563,24 +7544,20 @@ package body Sem_Util is
return True; return True;
elsif Property = Name_Async_Writers elsif Property = Name_Async_Writers
and then and then (Present (AW)
(Present (AW) or else (No (AR) and then No (ER) and then No (EW)))
or else
(No (AR) and then No (ER) and then No (EW)))
then then
return True; return True;
elsif Property = Name_Effective_Reads elsif Property = Name_Effective_Reads
and then and then (Present (ER)
(Present (ER) or else (No (AR) and then No (AW) and then No (EW)))
or else
(No (AR) and then No (AW) and then No (EW)))
then then
return True; return True;
elsif Property = Name_Effective_Writes elsif Property = Name_Effective_Writes
and then and then (Present (EW)
(Present (EW) or else (No (AR) and then No (AW) and then No (ER))) or else (No (AR) and then No (AW) and then No (ER)))
then then
return True; return True;
...@@ -7646,9 +7623,7 @@ package body Sem_Util is ...@@ -7646,9 +7623,7 @@ package body Sem_Util is
-- Handle private types -- Handle private types
if Use_Full_View if Use_Full_View and then Present (Full_View (Typ)) then
and then Present (Full_View (Typ))
then
Typ := Full_View (Typ); Typ := Full_View (Typ);
end if; end if;
...@@ -7675,7 +7650,7 @@ package body Sem_Util is ...@@ -7675,7 +7650,7 @@ package body Sem_Util is
-- Handle private types -- Handle private types
or else (Present (Full_View (Etype (Typ))) or else (Present (Full_View (Etype (Typ)))
and then Full_View (Etype (Typ)) = Typ) and then Full_View (Etype (Typ)) = Typ)
-- Protect the frontend against wrong source with cyclic -- Protect the frontend against wrong source with cyclic
-- derivations -- derivations
...@@ -7714,13 +7689,12 @@ package body Sem_Util is ...@@ -7714,13 +7689,12 @@ package body Sem_Util is
return Has_No_Obvious_Side_Effects (Right_Opnd (N)); return Has_No_Obvious_Side_Effects (Right_Opnd (N));
elsif Nkind (N) in N_Binary_Op or else Nkind (N) in N_Short_Circuit then elsif Nkind (N) in N_Binary_Op or else Nkind (N) in N_Short_Circuit then
return Has_No_Obvious_Side_Effects (Left_Opnd (N)) return Has_No_Obvious_Side_Effects (Left_Opnd (N))
and then and then
Has_No_Obvious_Side_Effects (Right_Opnd (N)); Has_No_Obvious_Side_Effects (Right_Opnd (N));
elsif Nkind (N) = N_Expression_With_Actions elsif Nkind (N) = N_Expression_With_Actions
and then and then Is_Empty_List (Actions (N))
Is_Empty_List (Actions (N))
then then
return Has_No_Obvious_Side_Effects (Expression (N)); return Has_No_Obvious_Side_Effects (Expression (N));
...@@ -7850,13 +7824,13 @@ package body Sem_Util is ...@@ -7850,13 +7824,13 @@ package body Sem_Util is
Formal : constant Entity_Id := First_Formal (Init); Formal : constant Entity_Id := First_Formal (Init);
begin begin
if Ekind (Init) = E_Procedure if Ekind (Init) = E_Procedure
and then Chars (Init) = Name_Initialize and then Chars (Init) = Name_Initialize
and then Comes_From_Source (Init) and then Comes_From_Source (Init)
and then Present (Formal) and then Present (Formal)
and then Etype (Formal) = BT and then Etype (Formal) = BT
and then No (Next_Formal (Formal)) and then No (Next_Formal (Formal))
and then (Ada_Version < Ada_2012 and then (Ada_Version < Ada_2012
or else not Null_Present (Parent (Init))) or else not Null_Present (Parent (Init)))
then then
return True; return True;
end if; end if;
...@@ -8613,9 +8587,7 @@ package body Sem_Util is ...@@ -8613,9 +8587,7 @@ package body Sem_Util is
begin begin
S := Current_Scope; S := Current_Scope;
while Present (S) while Present (S) and then S /= Standard_Standard loop
and then S /= Standard_Standard
loop
if (Ekind (S) = E_Function if (Ekind (S) = E_Function
or else Ekind (S) = E_Package or else Ekind (S) = E_Package
or else Ekind (S) = E_Procedure) or else Ekind (S) = E_Procedure)
...@@ -8628,9 +8600,8 @@ package body Sem_Util is ...@@ -8628,9 +8600,8 @@ package body Sem_Util is
-- that it is not currently on the scope stack. -- that it is not currently on the scope stack.
if Is_Child_Unit (Curr_Unit) if Is_Child_Unit (Curr_Unit)
and then and then Nkind (Unit (Cunit (Current_Sem_Unit))) =
Nkind (Unit (Cunit (Current_Sem_Unit))) N_Package_Instantiation
= N_Package_Instantiation
and then not In_Open_Scopes (Curr_Unit) and then not In_Open_Scopes (Curr_Unit)
then then
return False; return False;
...@@ -8654,11 +8625,8 @@ package body Sem_Util is ...@@ -8654,11 +8625,8 @@ package body Sem_Util is
begin begin
S := Current_Scope; S := Current_Scope;
while Present (S) while Present (S) and then S /= Standard_Standard loop
and then S /= Standard_Standard if Ekind_In (S, E_Function, E_Procedure)
loop
if (Ekind (S) = E_Function
or else Ekind (S) = E_Procedure)
and then Is_Generic_Instance (S) and then Is_Generic_Instance (S)
then then
return True; return True;
...@@ -8685,11 +8653,8 @@ package body Sem_Util is ...@@ -8685,11 +8653,8 @@ package body Sem_Util is
begin begin
S := Current_Scope; S := Current_Scope;
while Present (S) while Present (S) and then S /= Standard_Standard loop
and then S /= Standard_Standard if Ekind_In (S, E_Function, E_Procedure)
loop
if (Ekind (S) = E_Function
or else Ekind (S) = E_Procedure)
and then Is_Generic_Instance (S) and then Is_Generic_Instance (S)
then then
return True; return True;
...@@ -8716,9 +8681,7 @@ package body Sem_Util is ...@@ -8716,9 +8681,7 @@ package body Sem_Util is
begin begin
S := Current_Scope; S := Current_Scope;
while Present (S) while Present (S) and then S /= Standard_Standard loop
and then S /= Standard_Standard
loop
if Ekind (S) = E_Package if Ekind (S) = E_Package
and then Is_Generic_Instance (S) and then Is_Generic_Instance (S)
and then not In_Package_Body (S) and then not In_Package_Body (S)
...@@ -8742,12 +8705,8 @@ package body Sem_Util is ...@@ -8742,12 +8705,8 @@ package body Sem_Util is
begin begin
S := Current_Scope; S := Current_Scope;
while Present (S) while Present (S) and then S /= Standard_Standard loop
and then S /= Standard_Standard if Ekind (S) = E_Package and then In_Package_Body (S) then
loop
if Ekind (S) = E_Package
and then In_Package_Body (S)
then
return True; return True;
else else
S := Scope (S); S := Scope (S);
...@@ -8827,10 +8786,9 @@ package body Sem_Util is ...@@ -8827,10 +8786,9 @@ package body Sem_Util is
Btyp := Base_Type (Etype (Pref)); Btyp := Base_Type (Etype (Pref));
end if; end if;
return return Present (Btyp)
Present (Btyp) and then (Is_Record_Type (Btyp) or else Is_Array_Type (Btyp))
and then (Is_Record_Type (Btyp) or else Is_Array_Type (Btyp)) and then Reverse_Storage_Order (Btyp);
and then Reverse_Storage_Order (Btyp);
end In_Reverse_Storage_Order_Object; end In_Reverse_Storage_Order_Object;
-------------------------------------- --------------------------------------
...@@ -8868,11 +8826,10 @@ package body Sem_Util is ...@@ -8868,11 +8826,10 @@ package body Sem_Util is
function In_Visible_Part (Scope_Id : Entity_Id) return Boolean is function In_Visible_Part (Scope_Id : Entity_Id) return Boolean is
begin begin
return return Is_Package_Or_Generic_Package (Scope_Id)
Is_Package_Or_Generic_Package (Scope_Id) and then In_Open_Scopes (Scope_Id)
and then In_Open_Scopes (Scope_Id) and then not In_Package_Body (Scope_Id)
and then not In_Package_Body (Scope_Id) and then not In_Private_Part (Scope_Id);
and then not In_Private_Part (Scope_Id);
end In_Visible_Part; end In_Visible_Part;
-------------------------------- --------------------------------
...@@ -9043,14 +9000,13 @@ package body Sem_Util is ...@@ -9043,14 +9000,13 @@ package body Sem_Util is
-- For a retrieval of a subcomponent of some composite object, -- For a retrieval of a subcomponent of some composite object,
-- retrieve the ultimate entity if there is one. -- retrieve the ultimate entity if there is one.
elsif Nkind (New_Prefix) = N_Selected_Component elsif Nkind_In (New_Prefix, N_Selected_Component,
or else Nkind (New_Prefix) = N_Indexed_Component N_Indexed_Component)
then then
Pref := Prefix (New_Prefix); Pref := Prefix (New_Prefix);
while Present (Pref) while Present (Pref)
and then and then Nkind_In (Pref, N_Selected_Component,
(Nkind (Pref) = N_Selected_Component N_Indexed_Component)
or else Nkind (Pref) = N_Indexed_Component)
loop loop
Pref := Prefix (Pref); Pref := Prefix (Pref);
end loop; end loop;
...@@ -9226,9 +9182,7 @@ package body Sem_Util is ...@@ -9226,9 +9182,7 @@ package body Sem_Util is
begin begin
Par := E2; Par := E2;
while Present (Par) while Present (Par) and then Par /= Standard_Standard loop
and then Par /= Standard_Standard
loop
if Par = E1 then if Par = E1 then
return True; return True;
end if; end if;
...@@ -9331,9 +9285,8 @@ package body Sem_Util is ...@@ -9331,9 +9285,8 @@ package body Sem_Util is
function Is_Attribute_Result (N : Node_Id) return Boolean is function Is_Attribute_Result (N : Node_Id) return Boolean is
begin begin
return return Nkind (N) = N_Attribute_Reference
Nkind (N) = N_Attribute_Reference and then Attribute_Name (N) = Name_Result;
and then Attribute_Name (N) = Name_Result;
end Is_Attribute_Result; end Is_Attribute_Result;
------------------------------------ ------------------------------------
...@@ -9532,9 +9485,8 @@ package body Sem_Util is ...@@ -9532,9 +9485,8 @@ package body Sem_Util is
function Is_Concurrent_Interface (T : Entity_Id) return Boolean is function Is_Concurrent_Interface (T : Entity_Id) return Boolean is
begin begin
return return Is_Interface (T)
Is_Interface (T) and then
and then
(Is_Protected_Interface (T) (Is_Protected_Interface (T)
or else Is_Synchronized_Interface (T) or else Is_Synchronized_Interface (T)
or else Is_Task_Interface (T)); or else Is_Task_Interface (T));
...@@ -9980,7 +9932,7 @@ package body Sem_Util is ...@@ -9980,7 +9932,7 @@ package body Sem_Util is
and then In_Package_Body (Current_Scope))) and then In_Package_Body (Current_Scope)))
and then (Is_Declared_Within_Variant (Comp) and then (Is_Declared_Within_Variant (Comp)
or else Has_Discriminant_Dependent_Constraint (Comp)) or else Has_Discriminant_Dependent_Constraint (Comp))
and then (not P_Aliased or else Ada_Version >= Ada_2005) and then (not P_Aliased or else Ada_Version >= Ada_2005)
then then
return True; return True;
...@@ -10025,14 +9977,10 @@ package body Sem_Util is ...@@ -10025,14 +9977,10 @@ package body Sem_Util is
function Is_Dereferenced (N : Node_Id) return Boolean is function Is_Dereferenced (N : Node_Id) return Boolean is
P : constant Node_Id := Parent (N); P : constant Node_Id := Parent (N);
begin begin
return return Nkind_In (P, N_Selected_Component,
(Nkind (P) = N_Selected_Component N_Explicit_Dereference,
or else N_Indexed_Component,
Nkind (P) = N_Explicit_Dereference N_Slice)
or else
Nkind (P) = N_Indexed_Component
or else
Nkind (P) = N_Slice)
and then Prefix (P) = N; and then Prefix (P) = N;
end Is_Dereferenced; end Is_Dereferenced;
...@@ -10205,7 +10153,8 @@ package body Sem_Util is ...@@ -10205,7 +10153,8 @@ package body Sem_Util is
end if; end if;
if Compile_Time_Known_Value (Lbd) if Compile_Time_Known_Value (Lbd)
and then Compile_Time_Known_Value (Hbd) and then
Compile_Time_Known_Value (Hbd)
then then
if Expr_Value (Hbd) < Expr_Value (Lbd) then if Expr_Value (Hbd) < Expr_Value (Lbd) then
return True; return True;
...@@ -10287,7 +10236,7 @@ package body Sem_Util is ...@@ -10287,7 +10236,7 @@ package body Sem_Util is
while Present (Ent) loop while Present (Ent) loop
if Ekind (Ent) = E_Component if Ekind (Ent) = E_Component
and then (No (Parent (Ent)) and then (No (Parent (Ent))
or else No (Expression (Parent (Ent)))) or else No (Expression (Parent (Ent))))
and then not Is_Fully_Initialized_Type (Etype (Ent)) and then not Is_Fully_Initialized_Type (Etype (Ent))
-- Special VM case for tag components, which need to be -- Special VM case for tag components, which need to be
...@@ -10464,9 +10413,8 @@ package body Sem_Util is ...@@ -10464,9 +10413,8 @@ package body Sem_Util is
begin begin
if Is_Class_Wide_Type (Typ) if Is_Class_Wide_Type (Typ)
and then and then Nam_In (Chars (Etype (Typ)), Name_Forward_Iterator,
Nam_In (Chars (Etype (Typ)), Name_Forward_Iterator, Name_Reversible_Iterator)
Name_Reversible_Iterator)
and then and then
Is_Predefined_File_Name Is_Predefined_File_Name
(Unit_File_Name (Get_Source_Unit (Etype (Typ)))) (Unit_File_Name (Get_Source_Unit (Etype (Typ))))
...@@ -10710,7 +10658,7 @@ package body Sem_Util is ...@@ -10710,7 +10658,7 @@ package body Sem_Util is
Is_Object_Reference (Selector_Name (N)) Is_Object_Reference (Selector_Name (N))
and then and then
(Is_Object_Reference (Prefix (N)) (Is_Object_Reference (Prefix (N))
or else Is_Access_Type (Etype (Prefix (N)))); or else Is_Access_Type (Etype (Prefix (N))));
when N_Explicit_Dereference => when N_Explicit_Dereference =>
return True; return True;
...@@ -11230,7 +11178,7 @@ package body Sem_Util is ...@@ -11230,7 +11178,7 @@ package body Sem_Util is
elsif Present (Controlling_Argument (N)) elsif Present (Controlling_Argument (N))
and then Is_Remote_Access_To_Class_Wide_Type and then Is_Remote_Access_To_Class_Wide_Type
(Etype (Controlling_Argument (N))) (Etype (Controlling_Argument (N)))
then then
-- Any primitive operation call with a controlling argument of -- Any primitive operation call with a controlling argument of
-- a RACW type is a remote call. -- a RACW type is a remote call.
...@@ -11306,16 +11254,13 @@ package body Sem_Util is ...@@ -11306,16 +11254,13 @@ package body Sem_Util is
begin begin
if Is_Class_Wide_Type (Typ) if Is_Class_Wide_Type (Typ)
and then Chars (Etype (Typ)) = Name_Reversible_Iterator and then Chars (Etype (Typ)) = Name_Reversible_Iterator
and then and then Is_Predefined_File_Name
Is_Predefined_File_Name (Unit_File_Name (Get_Source_Unit (Etype (Typ))))
(Unit_File_Name (Get_Source_Unit (Etype (Typ))))
then then
return True; return True;
elsif not Is_Tagged_Type (Typ) elsif not Is_Tagged_Type (Typ) or else not Is_Derived_Type (Typ) then
or else not Is_Derived_Type (Typ)
then
return False; return False;
else else
...@@ -11348,13 +11293,11 @@ package body Sem_Util is ...@@ -11348,13 +11293,11 @@ package body Sem_Util is
if not Is_List_Member (N) then if not Is_List_Member (N) then
declare declare
P : constant Node_Id := Parent (N); P : constant Node_Id := Parent (N);
K : constant Node_Kind := Nkind (P);
begin begin
return return Nkind_In (P, N_Expanded_Name,
(K = N_Expanded_Name or else N_Generic_Association,
K = N_Generic_Association or else N_Parameter_Association,
K = N_Parameter_Association or else N_Selected_Component)
K = N_Selected_Component)
and then Selector_Name (P) = N; and then Selector_Name (P) = N;
end; end;
...@@ -11429,7 +11372,8 @@ package body Sem_Util is ...@@ -11429,7 +11372,8 @@ package body Sem_Util is
N_Short_Circuit | N_Short_Circuit |
N_Membership_Test => N_Membership_Test =>
Is_Ok := Is_SPARK_Initialization_Expr (Left_Opnd (Orig_N)) Is_Ok := Is_SPARK_Initialization_Expr (Left_Opnd (Orig_N))
and then Is_SPARK_Initialization_Expr (Right_Opnd (Orig_N)); and then
Is_SPARK_Initialization_Expr (Right_Opnd (Orig_N));
when N_Aggregate | when N_Aggregate |
N_Extension_Aggregate => N_Extension_Aggregate =>
...@@ -11499,7 +11443,7 @@ package body Sem_Util is ...@@ -11499,7 +11443,7 @@ package body Sem_Util is
return Present (Entity (N)) return Present (Entity (N))
and then and then
(Ekind_In (Entity (N), E_Constant, E_Variable) (Ekind_In (Entity (N), E_Constant, E_Variable)
or else Ekind (Entity (N)) in Formal_Kind); or else Ekind (Entity (N)) in Formal_Kind);
else else
case Nkind (N) is case Nkind (N) is
...@@ -11913,7 +11857,7 @@ package body Sem_Util is ...@@ -11913,7 +11857,7 @@ package body Sem_Util is
elsif Nkind (N) = N_Explicit_Dereference elsif Nkind (N) = N_Explicit_Dereference
and then Present (Etype (Orig_Node)) and then Present (Etype (Orig_Node))
and then Ada_Version >= Ada_2012 and then Ada_Version >= Ada_2012
and then Has_Implicit_Dereference (Etype (Orig_Node)) and then Has_Implicit_Dereference (Etype (Orig_Node))
then then
return True; return True;
...@@ -11933,10 +11877,10 @@ package body Sem_Util is ...@@ -11933,10 +11877,10 @@ package body Sem_Util is
K : constant Entity_Kind := Ekind (E); K : constant Entity_Kind := Ekind (E);
begin begin
return (K = E_Variable return (K = E_Variable
and then Nkind (Parent (E)) /= N_Exception_Handler) and then Nkind (Parent (E)) /= N_Exception_Handler)
or else (K = E_Component or else (K = E_Component
and then not In_Protected_Function (E)) and then not In_Protected_Function (E))
or else K = E_Out_Parameter or else K = E_Out_Parameter
or else K = E_In_Out_Parameter or else K = E_In_Out_Parameter
or else K = E_Generic_In_Out_Parameter or else K = E_Generic_In_Out_Parameter
...@@ -12410,7 +12354,7 @@ package body Sem_Util is ...@@ -12410,7 +12354,7 @@ package body Sem_Util is
if Is_OK_Static_Expression (L_Low) if Is_OK_Static_Expression (L_Low)
and then and then
Is_OK_Static_Expression (L_High) Is_OK_Static_Expression (L_High)
then then
if Expr_Value (L_High) < Expr_Value (L_Low) then if Expr_Value (L_High) < Expr_Value (L_Low) then
L_Len := Uint_0; L_Len := Uint_0;
...@@ -13462,9 +13406,7 @@ package body Sem_Util is ...@@ -13462,9 +13406,7 @@ package body Sem_Util is
end; end;
end if; end if;
elsif F in List_Range elsif F in List_Range and then Parent (List_Id (F)) = N then
and then Parent (List_Id (F)) = N
then
Visit_List (List_Id (F)); Visit_List (List_Id (F));
return; return;
end if; end if;
...@@ -13540,8 +13482,7 @@ package body Sem_Util is ...@@ -13540,8 +13482,7 @@ package body Sem_Util is
end if; end if;
if Is_Type (Node (E)) if Is_Type (Node (E))
and then and then Old_Itype = Associated_Node_For_Itype (Node (E))
Old_Itype = Associated_Node_For_Itype (Node (E))
then then
Set_Associated_Node_For_Itype Set_Associated_Node_For_Itype
(Node (Next_Elmt (E)), New_Itype); (Node (Next_Elmt (E)), New_Itype);
...@@ -13637,9 +13578,8 @@ package body Sem_Util is ...@@ -13637,9 +13578,8 @@ package body Sem_Util is
begin begin
-- Handle case of an Itype, which must be copied -- Handle case of an Itype, which must be copied
if Has_Extension (N) if Has_Extension (N) and then Is_Itype (N) then
and then Is_Itype (N)
then
-- Nothing to do if already in the list. This can happen with an -- Nothing to do if already in the list. This can happen with an
-- Itype entity that appears more than once in the tree. -- Itype entity that appears more than once in the tree.
-- Note that we do not want to visit descendents in this case. -- Note that we do not want to visit descendents in this case.
...@@ -14071,14 +14011,13 @@ package body Sem_Util is ...@@ -14071,14 +14011,13 @@ package body Sem_Util is
then then
if No (Actuals) if No (Actuals)
and then and then
(Nkind (Parent (N)) = N_Procedure_Call_Statement Nkind_In (Parent (N), N_Procedure_Call_Statement,
or else N_Function_Call,
(Nkind (Parent (N)) = N_Function_Call N_Parameter_Association)
or else
Nkind (Parent (N)) = N_Parameter_Association))
and then Ekind (S) /= E_Function and then Ekind (S) /= E_Function
then then
Set_Etype (N, Etype (S)); Set_Etype (N, Etype (S));
else else
Error_Msg_Name_1 := Chars (S); Error_Msg_Name_1 := Chars (S);
Error_Msg_Sloc := Sloc (S); Error_Msg_Sloc := Sloc (S);
...@@ -14317,8 +14256,7 @@ package body Sem_Util is ...@@ -14317,8 +14256,7 @@ package body Sem_Util is
-- or container is also modified. -- or container is also modified.
if Ada_Version >= Ada_2012 if Ada_Version >= Ada_2012
and then and then Nkind (Parent (Ent)) = N_Iterator_Specification
Nkind (Parent (Ent)) = N_Iterator_Specification
then then
declare declare
Domain : constant Node_Id := Name (Parent (Ent)); Domain : constant Node_Id := Name (Parent (Ent));
...@@ -14409,10 +14347,9 @@ package body Sem_Util is ...@@ -14409,10 +14347,9 @@ package body Sem_Util is
function Is_Interface_Conversion (N : Node_Id) return Boolean is function Is_Interface_Conversion (N : Node_Id) return Boolean is
begin begin
return return Nkind (N) = N_Unchecked_Type_Conversion
Nkind (N) = N_Unchecked_Type_Conversion and then Nkind (Expression (N)) = N_Attribute_Reference
and then Nkind (Expression (N)) = N_Attribute_Reference and then Attribute_Name (Expression (N)) = Name_Address;
and then Attribute_Name (Expression (N)) = Name_Address;
end Is_Interface_Conversion; end Is_Interface_Conversion;
------------------ ------------------
...@@ -14786,9 +14723,7 @@ package body Sem_Util is ...@@ -14786,9 +14723,7 @@ package body Sem_Util is
return Any_Type; return Any_Type;
end if; end if;
if Is_Private_Type (Btype) if Is_Private_Type (Btype) and then not Is_Generic_Type (Btype) then
and then not Is_Generic_Type (Btype)
then
if Present (Full_View (Btype)) if Present (Full_View (Btype))
and then Is_Record_Type (Full_View (Btype)) and then Is_Record_Type (Full_View (Btype))
and then not Is_Frozen (Btype) and then not Is_Frozen (Btype)
...@@ -14875,16 +14810,16 @@ package body Sem_Util is ...@@ -14875,16 +14810,16 @@ package body Sem_Util is
return Chars (E1) = Chars (E2) return Chars (E1) = Chars (E2)
or else or else
(not Is_Internal_Name (Chars (E1)) (not Is_Internal_Name (Chars (E1))
and then Is_Internal_Name (Chars (E2)) and then Is_Internal_Name (Chars (E2))
and then Non_Internal_Name (E2) = Chars (E1)) and then Non_Internal_Name (E2) = Chars (E1))
or else or else
(not Is_Internal_Name (Chars (E2)) (not Is_Internal_Name (Chars (E2))
and then Is_Internal_Name (Chars (E1)) and then Is_Internal_Name (Chars (E1))
and then Non_Internal_Name (E1) = Chars (E2)) and then Non_Internal_Name (E1) = Chars (E2))
or else or else
(Is_Predefined_Dispatching_Operation (E1) (Is_Predefined_Dispatching_Operation (E1)
and then Is_Predefined_Dispatching_Operation (E2) and then Is_Predefined_Dispatching_Operation (E2)
and then Same_TSS (E1, E2)) and then Same_TSS (E1, E2))
or else or else
(Is_Init_Proc (E1) and then Is_Init_Proc (E2)); (Is_Init_Proc (E1) and then Is_Init_Proc (E2));
end Primitive_Names_Match; end Primitive_Names_Match;
...@@ -15484,12 +15419,7 @@ package body Sem_Util is ...@@ -15484,12 +15419,7 @@ package body Sem_Util is
-- For conditionals, we also allow loop parameters and all formals, -- For conditionals, we also allow loop parameters and all formals,
-- including in parameters. -- including in parameters.
elsif Cond elsif Cond and then Ekind_In (Ent, E_Loop_Parameter, E_In_Parameter) then
and then
(Ekind (Ent) = E_Loop_Parameter
or else
Ekind (Ent) = E_In_Parameter)
then
null; null;
-- For all other cases, not just unsafe, but impossible to capture -- For all other cases, not just unsafe, but impossible to capture
...@@ -15511,7 +15441,7 @@ package body Sem_Util is ...@@ -15511,7 +15441,7 @@ package body Sem_Util is
or else Present (Address_Clause (Ent)) or else Present (Address_Clause (Ent))
or else Address_Taken (Ent) or else Address_Taken (Ent)
or else (Is_Library_Level_Entity (Ent) or else (Is_Library_Level_Entity (Ent)
and then Ekind (Ent) = E_Variable) and then Ekind (Ent) = E_Variable)
then then
return False; return False;
end if; end if;
...@@ -15560,9 +15490,9 @@ package body Sem_Util is ...@@ -15560,9 +15490,9 @@ package body Sem_Util is
if Nkind (P) = N_If_Statement if Nkind (P) = N_If_Statement
or else Nkind (P) = N_Case_Statement or else Nkind (P) = N_Case_Statement
or else (Nkind (P) in N_Short_Circuit or else (Nkind (P) in N_Short_Circuit
and then Desc = Right_Opnd (P)) and then Desc = Right_Opnd (P))
or else (Nkind (P) = N_If_Expression or else (Nkind (P) = N_If_Expression
and then Desc /= First (Expressions (P))) and then Desc /= First (Expressions (P)))
or else Nkind (P) = N_Exception_Handler or else Nkind (P) = N_Exception_Handler
or else Nkind (P) = N_Selective_Accept or else Nkind (P) = N_Selective_Accept
or else Nkind (P) = N_Conditional_Entry_Call or else Nkind (P) = N_Conditional_Entry_Call
...@@ -15570,9 +15500,10 @@ package body Sem_Util is ...@@ -15570,9 +15500,10 @@ package body Sem_Util is
or else Nkind (P) = N_Asynchronous_Select or else Nkind (P) = N_Asynchronous_Select
then then
return False; return False;
else else
Desc := P; Desc := P;
P := Parent (P); P := Parent (P);
-- A special Ada 2012 case: the original node may be part -- A special Ada 2012 case: the original node may be part
-- of the else_actions of a conditional expression, in which -- of the else_actions of a conditional expression, in which
...@@ -15908,9 +15839,7 @@ package body Sem_Util is ...@@ -15908,9 +15839,7 @@ package body Sem_Util is
procedure Set_Debug_Info_Needed_If_Not_Set (E : Entity_Id) is procedure Set_Debug_Info_Needed_If_Not_Set (E : Entity_Id) is
begin begin
if Present (E) if Present (E) and then not Needs_Debug_Info (E) then
and then not Needs_Debug_Info (E)
then
Set_Debug_Info_Needed (E); Set_Debug_Info_Needed (E);
-- For a private type, indicate that the full view also needs -- For a private type, indicate that the full view also needs
...@@ -16540,12 +16469,9 @@ package body Sem_Util is ...@@ -16540,12 +16469,9 @@ package body Sem_Util is
if not Is_Public (Ent) then if not Is_Public (Ent) then
Set_Public_Status (Ent); Set_Public_Status (Ent);
if Is_Public (Ent) if Is_Public (Ent) and then Ekind (Ent) = E_Record_Subtype then
and then Ekind (Ent) = E_Record_Subtype
then -- The components of the propagated Itype must also be public
-- The components of the propagated Itype must be public
-- as well.
declare declare
Comp : Entity_Id; Comp : Entity_Id;
...@@ -16608,7 +16534,7 @@ package body Sem_Util is ...@@ -16608,7 +16534,7 @@ package body Sem_Util is
or else or else
(Is_Itype (Btyp) (Is_Itype (Btyp)
and then Nkind (Associated_Node_For_Itype (Btyp)) = and then Nkind (Associated_Node_For_Itype (Btyp)) =
N_Object_Declaration N_Object_Declaration
and then Is_Return_Object and then Is_Return_Object
(Defining_Identifier (Defining_Identifier
(Associated_Node_For_Itype (Btyp)))) (Associated_Node_For_Itype (Btyp))))
...@@ -16730,9 +16656,7 @@ package body Sem_Util is ...@@ -16730,9 +16656,7 @@ package body Sem_Util is
return Empty; return Empty;
end; end;
elsif Is_Private_Type (T) elsif Is_Private_Type (T) and then Present (Full_View (T)) then
and then Present (Full_View (T))
then
return Type_Without_Stream_Operation (Full_View (T), Op); return Type_Without_Stream_Operation (Full_View (T), Op);
else else
return Empty; return Empty;
...@@ -17032,8 +16956,7 @@ package body Sem_Util is ...@@ -17032,8 +16956,7 @@ package body Sem_Util is
Elmt : Elmt_Id; Elmt : Elmt_Id;
begin begin
pragma Assert (Is_Record_Type (Typ) pragma Assert (Is_Record_Type (Typ) and then Is_Tagged_Type (Typ));
and then Is_Tagged_Type (Typ));
-- Collect all the parents and progenitors of Typ. If the full-view of -- Collect all the parents and progenitors of Typ. If the full-view of
-- private parents and progenitors is available then it is used to -- private parents and progenitors is available then it is used to
...@@ -17133,8 +17056,7 @@ package body Sem_Util is ...@@ -17133,8 +17056,7 @@ package body Sem_Util is
if Is_Array_Type (Expec_Type) if Is_Array_Type (Expec_Type)
and then Number_Dimensions (Expec_Type) = 1 and then Number_Dimensions (Expec_Type) = 1
and then and then Covers (Etype (Component_Type (Expec_Type)), Found_Type)
Covers (Etype (Component_Type (Expec_Type)), Found_Type)
then then
-- Use type name if available. This excludes multidimensional -- Use type name if available. This excludes multidimensional
-- arrays and anonymous arrays. -- arrays and anonymous arrays.
...@@ -17284,9 +17206,7 @@ package body Sem_Util is ...@@ -17284,9 +17206,7 @@ package body Sem_Util is
elsif Is_Integer_Type (Expec_Type) elsif Is_Integer_Type (Expec_Type)
and then Is_RTE (Found_Type, RE_Address) and then Is_RTE (Found_Type, RE_Address)
and then (Nkind (Parent (Expr)) = N_Op_Add and then Nkind_In (Parent (Expr), N_Op_Add, N_Op_Subtract)
or else
Nkind (Parent (Expr)) = N_Op_Subtract)
and then Expr = Left_Opnd (Parent (Expr)) and then Expr = Left_Opnd (Parent (Expr))
and then Is_Integer_Type (Etype (Right_Opnd (Parent (Expr)))) and then Is_Integer_Type (Etype (Right_Opnd (Parent (Expr))))
then then
...@@ -17376,10 +17296,7 @@ package body Sem_Util is ...@@ -17376,10 +17296,7 @@ package body Sem_Util is
Error_Msg_N ("\\found package name!", Expr); Error_Msg_N ("\\found package name!", Expr);
elsif Is_Entity_Name (Expr) elsif Is_Entity_Name (Expr)
and then and then Ekind_In (Entity (Expr), E_Procedure, E_Generic_Procedure)
(Ekind (Entity (Expr)) = E_Procedure
or else
Ekind (Entity (Expr)) = E_Generic_Procedure)
then then
if Ekind (Expec_Type) = E_Access_Subprogram_Type then if Ekind (Expec_Type) = E_Access_Subprogram_Type then
Error_Msg_N Error_Msg_N
......
gcc/ada/sem_util.ads
...@@ -444,6 +444,11 @@ package Sem_Util is ...@@ -444,6 +444,11 @@ package Sem_Util is
-- specification. If the declaration has a defining unit name, then the -- specification. If the declaration has a defining unit name, then the
-- defining entity is obtained from the defining unit name ignoring any -- defining entity is obtained from the defining unit name ignoring any
-- child unit prefixes. -- child unit prefixes.
--
-- Iterator loops also have a defining entity, which holds the list of
-- local entities declared during loop expansion. These entities need
-- debugging information, generated through QUalify_Entity_Names, and
-- the loop declaration must be placed in the table Name_Qualify_Units.
function Denotes_Discriminant function Denotes_Discriminant
(N : Node_Id; (N : Node_Id;
......
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