From: Eric Botcazou Date: Mon, 3 Dec 2018 15:49:23 +0000 (+0000) Subject: [Ada] Fix recent regression on array aggregate with dynamic subtype X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=2a1838cda7a0b88905580cc174ecd84960b7d957;p=gcc.git [Ada] Fix recent regression on array aggregate with dynamic subtype This prevents either a crash or an assertion failure in gigi on an array with dynamic subtype that is wrongly flagged as static by the front-end because of a recent improvement made in the handling of nested aggregates. The patch reuses the existing Static_Array_Aggregate predicate instead of fixing the problematic test, pluging a few loopholes in the process. The predicate is conservatively correct but should be good enough in practice. 2018-12-03 Eric Botcazou gcc/ada/ * exp_aggr.adb (Convert_To_Positional): Use Static_Array_Aggregate to decide whether to set Compile_Time_Known_Aggregate on an already flat aggregate. (Expand_Array_Aggregate): Remove test on Compile_Time_Known_Aggregate that turns out to be dead and simplify. (Is_Static_Component): New predicate extracted from... (Static_Array_Aggregate): ...here. Test neither Is_Tagged_Type nor Is_Controlled for the type, but test whether the component type has discriminants. Use the Is_Static_Component predicate consistently for the positional and named cases. gcc/testsuite/ * gnat.dg/array32.adb, gnat.dg/array32.ads: New testcase. From-SVN: r266755 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 2a3ff0ff548..132cc0a76fd 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,17 @@ +2018-12-03 Eric Botcazou + + * exp_aggr.adb (Convert_To_Positional): Use + Static_Array_Aggregate to decide whether to set + Compile_Time_Known_Aggregate on an already flat aggregate. + (Expand_Array_Aggregate): Remove test on + Compile_Time_Known_Aggregate that turns out to be dead and + simplify. + (Is_Static_Component): New predicate extracted from... + (Static_Array_Aggregate): ...here. Test neither Is_Tagged_Type + nor Is_Controlled for the type, but test whether the component + type has discriminants. Use the Is_Static_Component predicate + consistently for the positional and named cases. + 2018-12-03 Eric Botcazou * freeze.adb (Freeze_Entity): Do not freeze the partial view of diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index 866abed3920..45d517d1cb2 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -4759,17 +4759,8 @@ package body Exp_Aggr is -- initial value of a thread-local variable. if Is_Flat (N, Number_Dimensions (Typ)) then - Check_Static_Components; - if Static_Components then - if Is_Packed (Etype (N)) - or else - (Is_Record_Type (Component_Type (Etype (N))) - and then Has_Discriminants (Component_Type (Etype (N)))) - then - null; - else - Set_Compile_Time_Known_Aggregate (N); - end if; + if Static_Array_Aggregate (N) then + Set_Compile_Time_Known_Aggregate (N); end if; return; @@ -6205,15 +6196,8 @@ package body Exp_Aggr is or else (Parent_Kind = N_Assignment_Statement and then Inside_Init_Proc) then - if Static_Array_Aggregate (N) - or else Compile_Time_Known_Aggregate (N) - then - Set_Expansion_Delayed (N, False); - return; - else - Set_Expansion_Delayed (N); - return; - end if; + Set_Expansion_Delayed (N, not Static_Array_Aggregate (N)); + return; end if; -- STEP 4 @@ -8506,20 +8490,48 @@ package body Exp_Aggr is ---------------------------- function Static_Array_Aggregate (N : Node_Id) return Boolean is + + function Is_Static_Component (N : Node_Id) return Boolean; + -- Return True if N has a compile-time known value and can be passed as + -- is to the back-end without further expansion. + + --------------------------- + -- Is_Static_Component -- + --------------------------- + + function Is_Static_Component (N : Node_Id) return Boolean is + begin + if Nkind_In (N, N_Integer_Literal, N_Real_Literal) then + return True; + + elsif Is_Entity_Name (N) + and then Present (Entity (N)) + and then Ekind (Entity (N)) = E_Enumeration_Literal + then + return True; + + elsif Nkind (N) = N_Aggregate + and then Compile_Time_Known_Aggregate (N) + then + return True; + + else + return False; + end if; + end Is_Static_Component; + Bounds : constant Node_Id := Aggregate_Bounds (N); Typ : constant Entity_Id := Etype (N); - Comp_Type : constant Entity_Id := Component_Type (Typ); Agg : Node_Id; Expr : Node_Id; Lo : Node_Id; Hi : Node_Id; + -- Start of processing for Static_Array_Aggregate + begin - if Is_Tagged_Type (Typ) - or else Is_Controlled (Typ) - or else Is_Packed (Typ) - then + if Is_Packed (Typ) or else Has_Discriminants (Component_Type (Typ)) then return False; end if; @@ -8533,11 +8545,11 @@ package body Exp_Aggr is if No (Component_Associations (N)) then - -- Verify that all components are static integers + -- Verify that all components are static Expr := First (Expressions (N)); while Present (Expr) loop - if Nkind (Expr) /= N_Integer_Literal then + if not Is_Static_Component (Expr) then return False; end if; @@ -8567,17 +8579,7 @@ package body Exp_Aggr is -- component type. We also limit the size of a static aggregate -- to prevent runaway static expressions. - if Is_Array_Type (Comp_Type) - or else Is_Record_Type (Comp_Type) - then - if Nkind (Expression (Expr)) /= N_Aggregate - or else - not Compile_Time_Known_Aggregate (Expression (Expr)) - then - return False; - end if; - - elsif Nkind (Expression (Expr)) /= N_Integer_Literal then + if not Is_Static_Component (Expression (Expr)) then return False; end if; diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 2e63d0ad405..110932fdbbb 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,7 @@ +2018-12-03 Eric Botcazou + + * gnat.dg/array32.adb, gnat.dg/array32.ads: New testcase. + 2018-12-03 Eric Botcazou * gnat.dg/generic_inst2.adb, gnat.dg/generic_inst2.ads, diff --git a/gcc/testsuite/gnat.dg/array32.adb b/gcc/testsuite/gnat.dg/array32.adb new file mode 100644 index 00000000000..1932e40194d --- /dev/null +++ b/gcc/testsuite/gnat.dg/array32.adb @@ -0,0 +1,10 @@ +-- { dg-do compile } + +package body Array32 is + + procedure Init (A : out Arr) is + begin + A := ((I => 1), (I => 2)); + end; + +end Array32; diff --git a/gcc/testsuite/gnat.dg/array32.ads b/gcc/testsuite/gnat.dg/array32.ads new file mode 100644 index 00000000000..48c00466e6f --- /dev/null +++ b/gcc/testsuite/gnat.dg/array32.ads @@ -0,0 +1,11 @@ +package Array32 is + + type Rec is record + I : Integer; + end record; + + type Arr is array (Positive range <>) of Rec; + + procedure Init (A : out Arr); + +end Array32;