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