diff options
| -rw-r--r-- | gcc/ada/ChangeLog | 18 | ||||
| -rw-r--r-- | gcc/ada/einfo.adb | 2 | ||||
| -rw-r--r-- | gcc/ada/exp_ch5.adb | 13 | ||||
| -rw-r--r-- | gcc/ada/exp_util.adb | 11 | ||||
| -rw-r--r-- | gcc/ada/sem_attr.adb | 4 | ||||
| -rw-r--r-- | gcc/ada/sem_ch4.adb | 15 | ||||
| -rw-r--r-- | gcc/ada/sem_util.adb | 423 | ||||
| -rw-r--r-- | gcc/ada/sem_util.ads | 5 |
8 files changed, 223 insertions, 268 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 9aa5cb098ca..5b18da40103 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,5 +1,23 @@ 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 diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index 5da314a9ea4..926190b823d 100644 --- a/gcc/ada/einfo.adb +++ b/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 diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index 78f876b8e8d..96506f88109 100644 --- a/gcc/ada/exp_ch5.adb +++ b/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 diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index d2a5f84e0cd..0b6d7a3e628 100644 --- a/gcc/ada/exp_util.adb +++ b/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)); diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index 8b703261ff3..d22118e4db8 100644 --- a/gcc/ada/sem_attr.adb +++ b/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"); diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 7f9f086ad8c..8ac94e92602 100644 --- a/gcc/ada/sem_ch4.adb +++ b/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. diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 0782c502546..62a5bdb9743 100644 --- a/gcc/ada/sem_util.adb +++ b/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 diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index d6963416f72..8140f61fb34 100644 --- a/gcc/ada/sem_util.ads +++ b/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; |