From b4213ffdafd1907f53c50b7bcdaa7fd269495592 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Tue, 19 Apr 2016 15:10:35 +0200 Subject: [PATCH] [multiple changes] 2016-04-19 Hristian Kirtchev * checks.adb, sem_util.adb, sem_res.adb, sem_attr.adb: Minor reformatting. 2016-04-19 Ed Schonberg * freeze.adb (Freeze_Profile): Refine predicate that checks whether a function that returns a limited view is declared in another unit and cannot be frozen at this point. 2016-04-19 Ed Schonberg * exp_aggr.adb (Component_Count): Handle properly superflat arrays, i.e. empty arrays where Hi < Lo - 1, to ensure that the return value of the function is Natural, rather than leaving the handling of such arrays to the caller of this function. From-SVN: r235200 --- gcc/ada/ChangeLog | 18 ++++++++++++++++++ gcc/ada/checks.adb | 34 +++++++++++++++++----------------- gcc/ada/exp_aggr.adb | 6 ++++++ gcc/ada/freeze.adb | 10 ++++++---- gcc/ada/sem_attr.adb | 5 ++--- gcc/ada/sem_res.adb | 4 ++-- gcc/ada/sem_util.adb | 28 +++++++++++++--------------- 7 files changed, 64 insertions(+), 41 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 7cc7ff9d410..3a514cd1d42 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,21 @@ +2016-04-19 Hristian Kirtchev + + * checks.adb, sem_util.adb, sem_res.adb, sem_attr.adb: Minor + reformatting. + +2016-04-19 Ed Schonberg + + * freeze.adb (Freeze_Profile): Refine predicate that checks + whether a function that returns a limited view is declared in + another unit and cannot be frozen at this point. + +2016-04-19 Ed Schonberg + + * exp_aggr.adb (Component_Count): Handle properly superflat + arrays, i.e. empty arrays where Hi < Lo - 1, to ensure that the + return value of the function is Natural, rather than leaving + the handling of such arrays to the caller of this function. + 2016-04-19 Arnaud Charlet * sem_prag.adb, sem_attr.adb, par-prag.adb, exp_aggr.adb, sem_type.adb diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index eca82d77818..47fe1bfe63f 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -2354,11 +2354,13 @@ package body Checks is -- Local variables - Actual_1 : Node_Id; - Actual_2 : Node_Id; - Check : Node_Id; - Formal_1 : Entity_Id; - Formal_2 : Entity_Id; + Actual_1 : Node_Id; + Actual_2 : Node_Id; + Check : Node_Id; + Formal_1 : Entity_Id; + Formal_2 : Entity_Id; + Orig_Act_1 : Node_Id; + Orig_Act_2 : Node_Id; -- Start of processing for Apply_Parameter_Aliasing_Checks @@ -2368,6 +2370,7 @@ package body Checks is Actual_1 := First_Actual (Call); Formal_1 := First_Formal (Subp); while Present (Actual_1) and then Present (Formal_1) loop + Orig_Act_1 := Original_Actual (Actual_1); -- Ensure that the actual is an object that is not passed by value. -- Elementary types are always passed by value, therefore actuals of @@ -2378,30 +2381,27 @@ package body Checks is -- will be done in place and a subsequent read will always see the -- correct value, see RM 6.2 (12/3). - if Nkind (Original_Actual (Actual_1)) = N_Aggregate - or else - (Nkind (Original_Actual (Actual_1)) = N_Qualified_Expression - and then Nkind (Expression (Original_Actual (Actual_1))) = - N_Aggregate) + if Nkind (Orig_Act_1) = N_Aggregate + or else (Nkind (Orig_Act_1) = N_Qualified_Expression + and then Nkind (Expression (Orig_Act_1)) = N_Aggregate) then null; - elsif Is_Object_Reference (Original_Actual (Actual_1)) - and then not Is_Elementary_Type (Etype (Original_Actual (Actual_1))) - and then - not Is_By_Reference_Type (Etype (Original_Actual (Actual_1))) + elsif Is_Object_Reference (Orig_Act_1) + and then not Is_Elementary_Type (Etype (Orig_Act_1)) + and then not Is_By_Reference_Type (Etype (Orig_Act_1)) then Actual_2 := Next_Actual (Actual_1); Formal_2 := Next_Formal (Formal_1); while Present (Actual_2) and then Present (Formal_2) loop + Orig_Act_2 := Original_Actual (Actual_2); -- The other actual we are testing against must also denote -- a non pass-by-value object. Generate the check only when -- the mode of the two formals may lead to aliasing. - if Is_Object_Reference (Original_Actual (Actual_2)) - and then not - Is_Elementary_Type (Etype (Original_Actual (Actual_2))) + if Is_Object_Reference (Orig_Act_2) + and then not Is_Elementary_Type (Etype (Orig_Act_2)) and then May_Cause_Aliasing (Formal_1, Formal_2) then Overlap_Check diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index cb97dca4d7c..94f8e0745ec 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -354,10 +354,16 @@ package body Exp_Aggr is Siz : constant Nat := Component_Count (Component_Type (T)); begin + -- Check for superflat arrays, i.e. arrays with such bounds + -- as 4 .. 2, to insure that this function never returns a + -- meaningless negative value. + if not Compile_Time_Known_Value (Lo) or else not Compile_Time_Known_Value (Hi) + or else Expr_Value (Hi) < Expr_Value (Lo) then return 0; + else return Siz * UI_To_Int (Expr_Value (Hi) - Expr_Value (Lo) + 1); diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index dd91f8028a1..f23e168bd22 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -3288,12 +3288,14 @@ package body Freeze is if Ekind (E) = E_Function then - -- Check whether function is declared elsewhere. + -- Check whether function is declared elsewhere. Previous code + -- used Get_Source_Unit on both arguments, but the values are + -- equal in the case of a parent and a child unit. + -- Confusion with subunits in code ???? Late_Freezing := - Get_Source_Unit (E) /= Get_Source_Unit (N) - and then Returns_Limited_View (E) - and then not In_Open_Scopes (Scope (E)); + not In_Same_Extended_Unit (E, N) + and then Returns_Limited_View (E); -- Freeze return type diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index fa44c1d96d6..66c6432dddf 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -10094,11 +10094,10 @@ package body Sem_Attr is Freeze_Before (N, Entity (P)); end if; - -- If it is a type, there is nothing to resolve. - -- If it is an object, complete its resolution. + -- If it is a type, there is nothing to resolve. If it is an + -- object, complete its resolution. elsif Is_Overloadable (Entity (P)) then - if not In_Spec_Expression then Freeze_Before (N, Entity (P)); end if; diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 85bf0c40963..29c56120650 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -6963,8 +6963,8 @@ package body Sem_Res is then null; else - Error_Msg_N ( - "deferred constant is frozen before completion", N); + Error_Msg_N + ("deferred constant is frozen before completion", N); end if; end if; diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index d4a276ca5d8..0d9b4d14394 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -13103,9 +13103,9 @@ package body Sem_Util is Par := Nod; while Present (Par) loop - if Nkind_In (Par, N_Function_Call, - N_Procedure_Call_Statement, - N_Entry_Call_Statement) + if Nkind_In (Par, N_Entry_Call_Statement, + N_Function_Call, + N_Procedure_Call_Statement) then return True; @@ -15978,22 +15978,20 @@ package body Sem_Util is if New_Sloc /= No_Location then Set_Sloc (New_Node, New_Sloc); - -- If we adjust the Sloc, then we are essentially making - -- a completely new node, so the Comes_From_Source flag - -- should be reset to the proper default value. - - Set_Comes_From_Source (New_Node, - Default_Node.Comes_From_Source); + -- If we adjust the Sloc, then we are essentially making a + -- completely new node, so the Comes_From_Source flag should + -- be reset to the proper default value. + Set_Comes_From_Source + (New_Node, Default_Node.Comes_From_Source); end if; - -- If the node is call and has named associations, - -- set the corresponding links in the copy. + -- If the node is a call and has named associations, set the + -- corresponding links in the copy. - if (Nkind (Old_Node) = N_Function_Call - or else Nkind (Old_Node) = N_Entry_Call_Statement - or else - Nkind (Old_Node) = N_Procedure_Call_Statement) + if Nkind_In (Old_Node, N_Entry_Call_Statement, + N_Function_Call, + N_Procedure_Call_Statement) and then Present (First_Named_Actual (Old_Node)) then Adjust_Named_Associations (Old_Node, New_Node); -- 2.30.2