From cc3a298607f8b33c06cbf5163c8eaf07f138d6c0 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Fri, 8 Sep 2017 11:13:07 +0200 Subject: [PATCH] [multiple changes] 2017-09-08 Hristian Kirtchev * sem_util.adb (Copy_Node_With_Replacement): Update the Renamed_Object field of a replicated object renaming declaration. 2017-09-08 Patrick Bernardi * exp_ch9.adb (Is_Pure_Barrier): Allow type conversions and components of objects. Simplified the detection of the Count attribute by identifying the corresponding run-time calls. 2017-09-08 Yannick Moy * exp_ch9.adb, exp_disp.adb, repinfo.adb, sem_ch12.adb, sem_dim.adb, sem_type.adb, sinfo.ads: Minor reformatting. 2017-09-08 Ed Schonberg * freeze.adb (Has_Incomplete_Compoent): New predicate, subsidiary of Freeze_Profile, used to inhibit the freezing of the profile of an expression function declared within a nested package, when some type in the profile depends on a private type declared in an enclosing package. 2017-09-08 Bob Duff * gnat1drv.adb (Gnat1drv): Do not set the Force_ALI_Tree_File flag in the subunit case. It's still OK to set it in the "missing subunits" case, because that won't cause the obsolete .ali files that cause confusion. 2017-09-08 Bob Duff * sinput-l.adb: Remove unused "with Unchecked_Conversion;". It's unclear why this didn't cause a warning. * a-uncdea.ads, a-unccon.ads: Add "Ada." to names in the pragmas. It's unclear why this didn't cause an error. From-SVN: r251869 --- gcc/ada/ChangeLog | 40 ++++++++++++++++++++++ gcc/ada/a-unccon.ads | 6 ++-- gcc/ada/a-uncdea.ads | 2 +- gcc/ada/exp_ch9.adb | 79 +++++++++++++++++++++++++------------------- gcc/ada/exp_disp.adb | 5 +-- gcc/ada/freeze.adb | 60 +++++++++++++++++++++++++++++++++ gcc/ada/gnat1drv.adb | 6 ++-- gcc/ada/repinfo.adb | 1 + gcc/ada/sem_ch12.adb | 32 ++++++++++-------- gcc/ada/sem_dim.adb | 29 +++++++++------- gcc/ada/sem_type.adb | 6 ++-- gcc/ada/sem_util.adb | 16 ++++++--- gcc/ada/sinfo.ads | 4 +-- gcc/ada/sinput-l.adb | 2 -- 14 files changed, 209 insertions(+), 79 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 1014e0e87da..e4501eae9ed 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,43 @@ +2017-09-08 Hristian Kirtchev + + * sem_util.adb (Copy_Node_With_Replacement): + Update the Renamed_Object field of a replicated object renaming + declaration. + +2017-09-08 Patrick Bernardi + + * exp_ch9.adb (Is_Pure_Barrier): Allow type + conversions and components of objects. Simplified the detection + of the Count attribute by identifying the corresponding run-time + calls. + +2017-09-08 Yannick Moy + + * exp_ch9.adb, exp_disp.adb, repinfo.adb, sem_ch12.adb, sem_dim.adb, + sem_type.adb, sinfo.ads: Minor reformatting. + +2017-09-08 Ed Schonberg + + * freeze.adb (Has_Incomplete_Compoent): New predicate, subsidiary + of Freeze_Profile, used to inhibit the freezing of the profile + of an expression function declared within a nested package, when + some type in the profile depends on a private type declared in + an enclosing package. + +2017-09-08 Bob Duff + + * gnat1drv.adb (Gnat1drv): Do not set the Force_ALI_Tree_File flag in + the subunit case. It's still OK to set it in the "missing subunits" + case, because that won't cause the obsolete .ali files that cause + confusion. + +2017-09-08 Bob Duff + + * sinput-l.adb: Remove unused "with Unchecked_Conversion;". It's + unclear why this didn't cause a warning. + * a-uncdea.ads, a-unccon.ads: Add "Ada." to names in the + pragmas. It's unclear why this didn't cause an error. + 2017-09-08 Hristian Kirtchev * exp_spark.adb (Expand_SPARK_N_Object_Renaming_Declaration): diff --git a/gcc/ada/a-unccon.ads b/gcc/ada/a-unccon.ads index a3b4318d1c4..a8429c16a41 100644 --- a/gcc/ada/a-unccon.ads +++ b/gcc/ada/a-unccon.ads @@ -19,6 +19,6 @@ generic function Ada.Unchecked_Conversion (S : Source) return Target; -pragma No_Elaboration_Code_All (Unchecked_Conversion); -pragma Pure (Unchecked_Conversion); -pragma Import (Intrinsic, Unchecked_Conversion); +pragma No_Elaboration_Code_All (Ada.Unchecked_Conversion); +pragma Pure (Ada.Unchecked_Conversion); +pragma Import (Intrinsic, Ada.Unchecked_Conversion); diff --git a/gcc/ada/a-uncdea.ads b/gcc/ada/a-uncdea.ads index d566b4b343f..a61cd5003f9 100644 --- a/gcc/ada/a-uncdea.ads +++ b/gcc/ada/a-uncdea.ads @@ -20,4 +20,4 @@ generic procedure Ada.Unchecked_Deallocation (X : in out Name); pragma Preelaborate (Unchecked_Deallocation); -pragma Import (Intrinsic, Unchecked_Deallocation); +pragma Import (Intrinsic, Ada.Unchecked_Deallocation); diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index ecca4c3534c..64bc84a9151 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -5999,8 +5999,9 @@ package body Exp_Ch9 is Renamed : Node_Id; begin - -- Check for case of _object.all.field (note that the explicit - -- dereference gets inserted by analyze/expand of _object.field). + -- Check if the name is a component of the protected object. If + -- the expander is active, the component has been transformed into + -- a renaming of _object.all.component. if Expander_Active then Renamed := Renamed_Object (Entity (N)); @@ -6010,7 +6011,7 @@ package body Exp_Ch9 is and then Nkind (Renamed) = N_Selected_Component and then Chars (Prefix (Prefix (Renamed))) = Name_uObject; else - return Scope (Entity (N)) = Current_Scope; + return Is_Protected_Component (Entity (N)); end if; end Is_Simple_Barrier_Name; @@ -6019,25 +6020,6 @@ package body Exp_Ch9 is --------------------- function Is_Pure_Barrier (N : Node_Id) return Traverse_Result is - function Is_Count_Attribute (N : Node_Id) return Boolean; - -- Check whether N is part of an expansion of the Count attribute. - -- Return True if N represents the expanded function call. - - ------------------------ - -- Is_Count_Attribute -- - ------------------------ - - function Is_Count_Attribute (N : Node_Id) return Boolean is - begin - return - Nkind (N) = N_Function_Call - and then Present (Original_Node (N)) - and then Nkind (Original_Node (N)) = N_Attribute_Reference - and then Attribute_Name (Original_Node (N)) = Name_Count; - end Is_Count_Attribute; - - -- Start of processing for Is_Pure_Barrier - begin case Nkind (N) is when N_Expanded_Name @@ -6045,11 +6027,8 @@ package body Exp_Ch9 is => if No (Entity (N)) then return Abandon; - end if; - if Present (Parent (N)) - and then Is_Count_Attribute (Parent (N)) - then + elsif Is_Universal_Numeric_Type (Entity (N)) then return OK; end if; @@ -6062,24 +6041,35 @@ package body Exp_Ch9 is => return OK; - when E_Component - | E_Variable - => - -- A variable in the protected type is expanded as a - -- component. + when E_Component => + return OK; + when E_Variable => if Is_Simple_Barrier_Name (N) then return OK; end if; + when E_Function => + + -- The count attribute has been transformed into run-time + -- calls. + + if Is_RTE (Entity (N), RE_Protected_Count) + or else Is_RTE (Entity (N), RE_Protected_Count_Entry) + then + return OK; + end if; + when others => null; end case; when N_Function_Call => - if Is_Count_Attribute (N) then - return OK; - end if; + + -- Function call checks are carried out as part of the analysis + -- of the function call name. + + return OK; when N_Character_Literal | N_Integer_Literal @@ -6097,6 +6087,27 @@ package body Exp_Ch9 is when N_Short_Circuit => return OK; + when N_Indexed_Component + | N_Selected_Component + => + if not Is_Access_Type (Etype (Prefix (N))) then + return OK; + end if; + + when N_Type_Conversion => + + -- Conversions to Universal_Integer will not raise constraint + -- errors. + + if Cannot_Raise_Constraint_Error (N) + or else Etype (N) = Universal_Integer + then + return OK; + end if; + + when N_Unchecked_Type_Conversion => + return OK; + when others => null; end case; diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index e5e2c615387..872ac6488b6 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -5895,7 +5895,7 @@ package body Exp_Disp is -- Retrieve the ultimate alias of the primitive for proper -- handling of renamings and eliminated primitives. - E := Ultimate_Alias (Prim); + E := Ultimate_Alias (Prim); -- If the alias is not a primitive operation then Prim does -- not rename another primitive, but rather an operation @@ -7806,7 +7806,8 @@ package body Exp_Disp is then declare Par_Type : constant Entity_Id := - Find_Dispatching_Type (Alias (Prim)); + Find_Dispatching_Type (Alias (Prim)); + begin if Present (Par_Type) and then Par_Type /= Typ diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index c20beefa3e2..8a3bf36fac2 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -3427,6 +3427,60 @@ package body Freeze is R_Type : Entity_Id; Warn_Node : Node_Id; + function Has_Incomplete_Component (T : Entity_Id) return Boolean; + -- If a type includes a private component from an enclosing scope + -- it cannot be frozen yet. This can happen in a package nested + -- within another, when freezing an expression function whose + -- profile depends on a type in some outer scope. Those types will + -- be frozen at a later time in the enclosing unit. + + ------------------------------ + -- Has_Incomplete_Component -- + ------------------------------ + + function Has_Incomplete_Component (T : Entity_Id) return Boolean is + Comp : Entity_Id; + Comp_Typ : Entity_Id; + + begin + if Nkind (N) /= N_Subprogram_Body + or else not Was_Expression_Function (N) + then + return False; + + elsif In_Instance then + return False; + + elsif Is_Record_Type (T) then + Comp := First_Entity (T); + + while Present (Comp) loop + Comp_Typ := Etype (Comp); + if Ekind_In (Comp, E_Component, E_Discriminant) + and then Is_Private_Type (Comp_Typ) + and then No (Full_View (Comp_Typ)) + and then In_Open_Scopes (Scope (Comp_Typ)) + and then Scope (Comp_Typ) /= Current_Scope + then + return True; + end if; + Comp := Next_Entity (Comp); + end loop; + + return False; + + elsif Is_Array_Type (T) then + Comp_Typ := Component_Type (T); + return Is_Private_Type (Comp_Typ) + and then No (Full_View (Comp_Typ)) + and then In_Open_Scopes (Scope (Comp_Typ)) + and then Scope (Comp_Typ) /= Current_Scope; + + else + return False; + end if; + end Has_Incomplete_Component; + begin -- Loop through formals @@ -3446,6 +3500,12 @@ package body Freeze is Set_Etype (Formal, F_Type); end if; + if Has_Incomplete_Component (F_Type) then + Set_Is_Frozen (E, False); + Result := No_List; + return False; + end if; + if not From_Limited_With (F_Type) then Freeze_And_Append (F_Type, N, Result); end if; diff --git a/gcc/ada/gnat1drv.adb b/gcc/ada/gnat1drv.adb index 6264c0b38e0..b1bbea90b74 100644 --- a/gcc/ada/gnat1drv.adb +++ b/gcc/ada/gnat1drv.adb @@ -1353,9 +1353,9 @@ begin Write_Str (" (subunit)"); Write_Eol; - -- Force generation of ALI file, for backward compatibility - - Opt.Force_ALI_Tree_File := True; + -- Do not generate an ALI file in this case, because it would + -- become obsolete when the parent is compiled, and thus + -- confuse tools such as gnatfind. elsif Main_Unit_Kind = N_Subprogram_Declaration then Write_Str (" (subprogram spec)"); diff --git a/gcc/ada/repinfo.adb b/gcc/ada/repinfo.adb index 2634ee8b7c6..c42de8c1ac6 100644 --- a/gcc/ada/repinfo.adb +++ b/gcc/ada/repinfo.adb @@ -894,6 +894,7 @@ package body Repinfo is Cfbit := Component_Bit_Offset (Comp); if Rep_Not_Constant (Cfbit) then + -- If the record is not packed, then we know that all fields -- whose position is not specified have a starting normalized -- bit position of zero. diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 94bd498d74a..6e4a4f926f0 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -1902,7 +1902,7 @@ package body Sem_Ch12 is -- only uses them to elaborate entities in a package -- body. - declare + Explicit_Freeze_Check : declare Actual : constant Entity_Id := Entity (Match); Needs_Freezing : Boolean; @@ -1920,16 +1920,20 @@ package body Sem_Ch12 is -------------------------- procedure Check_Generic_Parent is - Par : Entity_Id; + Par : Entity_Id; + begin - if Nkind (Parent (Actual)) = N_Package_Specification + if Nkind (Parent (Actual)) = + N_Package_Specification then Par := Scope (Generic_Parent (Parent (Actual))); + if Is_Generic_Instance (Par) and then Scope (Par) = Current_Scope - and then (No (Freeze_Node (Par)) - or else - not Is_List_Member (Freeze_Node (Par))) + and then + (No (Freeze_Node (Par)) + or else + not Is_List_Member (Freeze_Node (Par))) then Set_Has_Delayed_Freeze (Par); Append_Elmt (Par, Actuals_To_Freeze); @@ -1937,6 +1941,8 @@ package body Sem_Ch12 is end if; end Check_Generic_Parent; + -- Start of processing for Explicit_Freeze_Check + begin if not Expander_Active or else not Has_Completion (Actual) @@ -1944,9 +1950,9 @@ package body Sem_Ch12 is or else Is_Frozen (Actual) or else (Present (Renamed_Entity (Actual)) - and then not - In_Same_Source_Unit - (I_Node, (Renamed_Entity (Actual)))) + and then + not In_Same_Source_Unit + (I_Node, (Renamed_Entity (Actual)))) then null; @@ -1978,7 +1984,7 @@ package body Sem_Ch12 is Append_Elmt (Actual, Actuals_To_Freeze); end if; end if; - end; + end Explicit_Freeze_Check; end if; -- For use type and use package appearing in the generic part, @@ -9297,8 +9303,8 @@ package body Sem_Ch12 is and then (Nkind_In (Gen_Unit, N_Generic_Package_Declaration, N_Package_Declaration) or else (Gen_Unit = Body_Unit - and then True_Sloc (N, Act_Unit) - < Sloc (Orig_Body))) + and then True_Sloc (N, Act_Unit) < + Sloc (Orig_Body))) and then Is_In_Main_Unit (Original_Node (Gen_Unit)) and then In_Same_Scope (Gen_Id, Act_Id)); @@ -9314,7 +9320,7 @@ package body Sem_Ch12 is if Expander_Active and then (No (Freeze_Node (Act_Id)) - or else not Is_List_Member (Freeze_Node (Act_Id))) + or else not Is_List_Member (Freeze_Node (Act_Id))) then Ensure_Freeze_Node (Act_Id); F_Node := Freeze_Node (Act_Id); diff --git a/gcc/ada/sem_dim.adb b/gcc/ada/sem_dim.adb index 6e829f91691..6330703e071 100644 --- a/gcc/ada/sem_dim.adb +++ b/gcc/ada/sem_dim.adb @@ -195,12 +195,12 @@ package body Sem_Dim is OK_For_Dimension : constant array (Node_Kind) of Boolean := (N_Attribute_Reference => True, N_Case_Expression => True, - N_If_Expression => True, N_Expanded_Name => True, N_Explicit_Dereference => True, N_Defining_Identifier => True, N_Function_Call => True, N_Identifier => True, + N_If_Expression => True, N_Indexed_Component => True, N_Integer_Literal => True, N_Op_Abs => True, @@ -1169,6 +1169,9 @@ package body Sem_Dim is when N_Binary_Op => Analyze_Dimension_Binary_Op (N); + when N_Case_Expression => + Analyze_Dimension_Case_Expression (N); + when N_Component_Declaration => Analyze_Dimension_Component_Declaration (N); @@ -1187,20 +1190,17 @@ package body Sem_Dim is => Analyze_Dimension_Has_Etype (N); - when N_Case_Expression => - Analyze_Dimension_Case_Expression (N); - - when N_If_Expression => - Analyze_Dimension_If_Expression (N); - - -- In the presence of a repaired syntax error, an identifier - -- may be introduced without a usable type. + -- In the presence of a repaired syntax error, an identifier may be + -- introduced without a usable type. when N_Identifier => if Present (Etype (N)) then Analyze_Dimension_Has_Etype (N); end if; + when N_If_Expression => + Analyze_Dimension_If_Expression (N); + when N_Number_Declaration => Analyze_Dimension_Number_Declaration (N); @@ -1787,9 +1787,12 @@ package body Sem_Dim is --------------------------------------- procedure Analyze_Dimension_Case_Expression (N : Node_Id) is + Frst : constant Node_Id := First (Alternatives (N)); + Frst_Expr : constant Node_Id := Expression (Frst); + Dims : constant Dimension_Type := Dimensions_Of (Frst_Expr); + Alt : Node_Id; - Frst : constant Node_Id := First (Alternatives (N)); - Dims : constant Dimension_Type := Dimensions_Of (Expression (Frst)); + begin Alt := Next (Frst); while Present (Alt) loop @@ -1800,7 +1803,8 @@ package body Sem_Dim is Next (Alt); end loop; - Copy_Dimensions (Expression (Frst), N); + + Copy_Dimensions (Frst_Expr, N); end Analyze_Dimension_Case_Expression; --------------------------------------------- @@ -2144,6 +2148,7 @@ package body Sem_Dim is procedure Analyze_Dimension_If_Expression (N : Node_Id) is Then_Expr : constant Node_Id := Next (First (Expressions (N))); Else_Expr : constant Node_Id := Next (Then_Expr); + begin if Dimensions_Of (Then_Expr) /= Dimensions_Of (Else_Expr) then Error_Msg_N ("dimensions mismatch in conditional expression", N); diff --git a/gcc/ada/sem_type.adb b/gcc/ada/sem_type.adb index c9d8f4b324b..c70d892bf0b 100644 --- a/gcc/ada/sem_type.adb +++ b/gcc/ada/sem_type.adb @@ -2947,9 +2947,9 @@ package body Sem_Type is -- Continue climbing else - -- Use the full-view of private types (if allowed). - -- Guard against infinite loops when full view has same - -- type as parent, as can happen with interface extensions, + -- Use the full-view of private types (if allowed). Guard + -- against infinite loops when full view has same type as + -- parent, as can happen with interface extensions. if Use_Full_View and then Is_Private_Type (Par) diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 968de988e9c..f57b7c58208 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -17659,8 +17659,8 @@ package body Sem_Util is (New_Node, Default_Node.Comes_From_Source); end if; - -- If the node is a call and has named associations, set the - -- corresponding links in the copy. + -- Update the named association links for calls to mention the + -- copied actual parameters. if Nkind_In (Old_Node, N_Entry_Call_Statement, N_Function_Call, @@ -17668,6 +17668,13 @@ package body Sem_Util is and then Present (First_Named_Actual (Old_Node)) then Adjust_Named_Associations (Old_Node, New_Node); + + -- Update the Renamed_Object attribute of an object renaming + -- declaration to mention the replicated name. + + elsif Nkind (Old_Node) = N_Object_Renaming_Declaration then + Set_Renamed_Object + (Defining_Entity (New_Node), Name (New_Node)); end if; -- Reset First_Real_Statement for Handled_Sequence_Of_Statements. @@ -17679,8 +17686,9 @@ package body Sem_Util is and then Present (First_Real_Statement (Old_Node)) then declare - Old_F : constant Node_Id := First_Real_Statement (Old_Node); - N1, N2 : Node_Id; + Old_F : constant Node_Id := First_Real_Statement (Old_Node); + N1 : Node_Id; + N2 : Node_Id; begin N1 := First (Statements (Old_Node)); diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index 93b0653e719..0aef4b6f723 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -11852,8 +11852,8 @@ package Sinfo is N_Case_Expression_Alternative => (1 => False, -- Actions (List1-Sem) 2 => False, -- unused - 3 => True, -- Statements (List3) - 4 => True, -- Expression (Node4) + 3 => True, -- Expression (Node3) + 4 => True, -- Discrete_Choices (List4) 5 => False), -- unused N_Case_Statement => diff --git a/gcc/ada/sinput-l.adb b/gcc/ada/sinput-l.adb index d7e337b35a2..360e7117e45 100644 --- a/gcc/ada/sinput-l.adb +++ b/gcc/ada/sinput-l.adb @@ -45,8 +45,6 @@ with System; use System; with System.OS_Lib; use System.OS_Lib; -with Unchecked_Conversion; - package body Sinput.L is Prep_Buffer : Text_Buffer_Ptr := null; -- 2.30.2