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 141 additions and 186 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
...@@ -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
...@@ -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_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)));
...@@ -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;
...@@ -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;
...@@ -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;
...@@ -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);
...@@ -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_Identifier or else K2 = N_Defining_Identifier)
K2 = N_Defining_Identifier)
then then
return Chars (Name1) = Chars (Name2); return Chars (Name1) = Chars (Name2);
...@@ -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;
...@@ -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);
...@@ -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 end if;
Next_Discriminant (Old_Disc); Next_Discriminant (Old_Disc);
Next_Discriminant (New_Disc); Next_Discriminant (New_Disc);
end if;
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);
...@@ -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);
...@@ -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;
...@@ -7719,8 +7694,7 @@ package body Sem_Util is ...@@ -7719,8 +7694,7 @@ package body Sem_Util is
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));
...@@ -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,8 +8786,7 @@ package body Sem_Util is ...@@ -8827,8 +8786,7 @@ 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,8 +8826,7 @@ package body Sem_Util is ...@@ -8868,8 +8826,7 @@ 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);
...@@ -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,8 +9285,7 @@ package body Sem_Util is ...@@ -9331,8 +9285,7 @@ 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,8 +9485,7 @@ package body Sem_Util is ...@@ -9532,8 +9485,7 @@ 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)
...@@ -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;
...@@ -10464,8 +10413,7 @@ package body Sem_Util is ...@@ -10464,8 +10413,7 @@ 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
...@@ -11307,15 +11255,12 @@ package body Sem_Util is ...@@ -11307,15 +11255,12 @@ 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 =>
...@@ -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,8 +14347,7 @@ package body Sem_Util is ...@@ -14409,8 +14347,7 @@ 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)
...@@ -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
...@@ -15570,6 +15500,7 @@ package body Sem_Util is ...@@ -15570,6 +15500,7 @@ 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);
...@@ -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;
...@@ -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