From: Ronan Desplanques <desplanq...@adacore.com>
This patch makes Exp_Aggr.Convert_To_Positional accepts appropriate
empty aggregates. The end goal is to remove violations of the
No_Elaboration_Code restriction in some cases of library-level array
objects.
gcc/ada/
* exp_aggr.adb (Flatten): Do not reject empty aggregates. Adjust
criterion for emitting warning about ineffective others clause.
* sem_aggr.adb (Array_Aggr_Subtype): Fix typo. Add handling of
aggregates that were converted to positional form.
(Resolve_Aggregate): Tweak criterion for transforming into a
string literal.
(Resolve_Array_Aggregate): Tweak criterion for reusing existing
bounds of aggregate.
(Retrieve_Aggregate_Bounds): New procedure.
* sem_util.adb (Has_Static_Empty_Array_Bounds): New function.
* sem_util.ads (Has_Static_Empty_Array_Bounds): Likewise.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/exp_aggr.adb | 6 +++--
gcc/ada/sem_aggr.adb | 53 ++++++++++++++++++++++++++++++--------------
gcc/ada/sem_util.adb | 14 ++++++++++++
gcc/ada/sem_util.ads | 3 +++
4 files changed, 57 insertions(+), 19 deletions(-)
diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb
index df228713a28..419a98c681a 100644
--- a/gcc/ada/exp_aggr.adb
+++ b/gcc/ada/exp_aggr.adb
@@ -4657,8 +4657,7 @@ package body Exp_Aggr is
-- present we can proceed since the bounds can be obtained from the
-- aggregate.
- if Hiv < Lov
- or else (not Compile_Time_Known_Value (Blo) and then Others_Present)
+ if not Compile_Time_Known_Value (Blo) and then Others_Present
then
return False;
end if;
@@ -4801,6 +4800,9 @@ package body Exp_Aggr is
if Rep_Count = 0
and then Warn_On_Redundant_Constructs
+ -- We don't emit warnings on null arrays initialized
+ -- with an aggregate of the form "(others => ...)".
+ and then Vals'Length > 0
then
Error_Msg_N ("there are no others?r?", Elmt);
end if;
diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb
index bc53ea904a3..bddfbecf46d 100644
--- a/gcc/ada/sem_aggr.adb
+++ b/gcc/ada/sem_aggr.adb
@@ -468,6 +468,12 @@ package body Sem_Aggr is
-- corresponding to the same dimension are static and found to differ,
-- then emit a warning, and mark N as raising Constraint_Error.
+ procedure Retrieve_Aggregate_Bounds (This_Range : Node_Id);
+ -- In some cases, an appropriate list of aggregate bounds has been
+ -- created during resolution. Populate Aggr_Range with that list, and
+ -- remove the elements from the list so they can be added to another
+ -- list later.
+
-------------------------
-- Collect_Aggr_Bounds --
-------------------------
@@ -631,6 +637,24 @@ package body Sem_Aggr is
end if;
end Collect_Aggr_Bounds;
+ -------------------------------
+ -- Retrieve_Aggregate_Bounds --
+ -------------------------------
+
+ procedure Retrieve_Aggregate_Bounds (This_Range : Node_Id) is
+ R : Node_Id := This_Range;
+ begin
+ for J in 1 .. Aggr_Dimension loop
+ Aggr_Range (J) := R;
+ Next_Index (R);
+
+ -- Remove bounds from the list, so they can be reattached as
+ -- the First_Index/Next_Index again.
+
+ Remove (Aggr_Range (J));
+ end loop;
+ end Retrieve_Aggregate_Bounds;
+
-- Array_Aggr_Subtype variables
Itype : Entity_Id;
@@ -655,25 +679,17 @@ package body Sem_Aggr is
Set_Parent (Index_Constraints, N);
+ if Is_Rewrite_Substitution (N)
+ and then Present (Component_Associations (Original_Node (N)))
+ then
+ Retrieve_Aggregate_Bounds (First_Index (Etype (Original_Node (N))));
+
-- When resolving a null aggregate we created a list of aggregate bounds
-- for the consecutive dimensions. The bounds for the first dimension
-- are attached as the Aggregate_Bounds of the aggregate node.
- if Is_Null_Aggregate (N) then
- declare
- This_Range : Node_Id := Aggregate_Bounds (N);
- begin
- for J in 1 .. Aggr_Dimension loop
- Aggr_Range (J) := This_Range;
- Next_Index (This_Range);
-
- -- Remove bounds from the list, so they can be reattached as
- -- the First_Index/Next_Index again by the code that also
- -- handles non-null aggregates.
-
- Remove (Aggr_Range (J));
- end loop;
- end;
+ elsif Is_Null_Aggregate (N) then
+ Retrieve_Aggregate_Bounds (Aggregate_Bounds (N));
else
Collect_Aggr_Bounds (N, 1);
end if;
@@ -1378,6 +1394,7 @@ package body Sem_Aggr is
and then Is_OK_Static_Subtype (Component_Type (Typ))
and then Base_Type (Etype (First_Index (Typ))) =
Base_Type (Standard_Integer)
+ and then not Has_Static_Empty_Array_Bounds (Typ)
then
declare
Expr : Node_Id;
@@ -3595,10 +3612,12 @@ package body Sem_Aggr is
-- If the aggregate already has bounds attached to it, it means this is
-- a positional aggregate created as an optimization by
-- Exp_Aggr.Convert_To_Positional, so we don't want to change those
- -- bounds.
+ -- bounds, unless they depend on discriminants. If they do, we have to
+ -- perform analysis in the current context.
if Present (Aggregate_Bounds (N))
- and then not Others_Allowed
+ and then No (Others_N)
+ and then not Depends_On_Discriminant (Aggregate_Bounds (N))
and then not Comes_From_Source (N)
then
Aggr_Low := Low_Bound (Aggregate_Bounds (N));
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index 9d4fd74b98f..19941ae3060 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -13250,6 +13250,20 @@ package body Sem_Util is
return All_Static;
end Has_Static_Array_Bounds;
+ -----------------------------------
+ -- Has_Static_Empty_Array_Bounds --
+ -----------------------------------
+
+ function Has_Static_Empty_Array_Bounds (Typ : Node_Id) return Boolean is
+ All_Static : Boolean;
+ Has_Empty : Boolean;
+
+ begin
+ Examine_Array_Bounds (Typ, All_Static, Has_Empty);
+
+ return Has_Empty;
+ end Has_Static_Empty_Array_Bounds;
+
---------------------------------------
-- Has_Static_Non_Empty_Array_Bounds --
---------------------------------------
diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads
index 21e90dcf53b..eccbd4351d0 100644
--- a/gcc/ada/sem_util.ads
+++ b/gcc/ada/sem_util.ads
@@ -1531,6 +1531,9 @@ package Sem_Util is
function Has_Static_Array_Bounds (Typ : Node_Id) return Boolean;
-- Return whether an array type has static bounds
+ function Has_Static_Empty_Array_Bounds (Typ : Node_Id) return Boolean;
+ -- Return whether array type Typ has static empty bounds
+
function Has_Static_Non_Empty_Array_Bounds (Typ : Node_Id) return Boolean;
-- Determine whether array type Typ has static non-empty bounds
--
2.45.2
