From: Eric Botcazou <ebotca...@adacore.com>
The problem is that Insert_Actions gets confused as to where it should
insert actions coming from within an N_Iterated_Component_Association,
because some actions may be generated during semantic analysis and some
others during expansion.
Instead of another ad-hoc fix, this change extends the processing done
for N_Component_Association, that is to say waiting for the Loop_Actions
field to be set during expansion before inserting actions in there.
This in turn requires semantic analysis to stop generating actions for
N_Iterated_Component_Association nodes. The current processing is a
little unstable:
- for container aggregates, Resolve_Iterated_Association preanalyzes
a copy of the expression,
- for delta aggregates, Resolve_Delta_Array_Aggregate fully analyzes
a copy of the expression,
- for array aggregate, Resolve_Aggr_Expr entirely skips the analysis.
The change implements a preanalysis of a copy of the expression using
Copy_Separate_Tree, which should be sufficient since the expression is
supposed to be unanalyzed at this point, recursively in the context of
N_Iterated_Component_Association nodes.
gcc/ada/ChangeLog:
PR ada/117018
* exp_aggr.adb (Build_Array_Aggr_Code): Do not expect the
Loop_Actions field to be already present on association nodes.
* exp_util.adb (Insert_Actions): For association nodes, insert
into the Loop_Actions field only if it is already present.
* sem_aggr.adb (Resolve_Array_Aggregate): Add Iterated parameter.
(Resolve_Aggregate): Adjust calls to Resolve_Array_Aggregate.
(Resolve_Aggr_Expr): Add Iterated_Elmt defaulted parameter and
a default for Single_Elmt. Adjust call to Resolve_Array_Aggregate.
Preanalyze a copy of the expression in an iteration context.
(Resolve_Iterated_Component_Association): Pass Iterated_Elmt as
True to Resolve_Aggr_Expr and remove processing of Loop_Actions.
Do not check incorrect use of dynamically tagged expression in
an iteration context.
(Resolve_Iterated_Association): Use Copy_Separate_Tree instead of
New_Copy_Tree and set the Parent field of the result.
(Resolve_Delta_Array_Aggregate): Likewise. Only preanalyze the
copy instead of analyzing it.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/exp_aggr.adb | 51 +++++++++++++-----------
gcc/ada/exp_util.adb | 23 ++---------
gcc/ada/sem_aggr.adb | 94 ++++++++++++++++++++++++++++----------------
3 files changed, 91 insertions(+), 77 deletions(-)
diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb
index f4844b74842..ed50d94d3c8 100644
--- a/gcc/ada/exp_aggr.adb
+++ b/gcc/ada/exp_aggr.adb
@@ -1973,30 +1973,35 @@ package body Exp_Aggr is
Assoc := First (Component_Associations (N));
while Present (Assoc) loop
- Choice := First (Choice_List (Assoc));
- while Present (Choice) loop
- if Nkind (Choice) = N_Others_Choice then
- Others_Assoc := Assoc;
- exit;
- end if;
+ declare
+ First_Range : Boolean := True;
- Bounds := Get_Index_Bounds (Choice);
+ begin
+ Choice := First (Choice_List (Assoc));
+ while Present (Choice) loop
+ if Nkind (Choice) = N_Others_Choice then
+ Others_Assoc := Assoc;
+ exit;
+ end if;
- if Low /= High
- and then No (Loop_Actions (Assoc))
- then
- Set_Loop_Actions (Assoc, New_List);
- end if;
+ Bounds := Get_Index_Bounds (Choice);
- Nb_Choices := Nb_Choices + 1;
+ if First_Range and then Low /= High then
+ pragma Assert (No (Loop_Actions (Assoc)));
+ Set_Loop_Actions (Assoc, New_List);
+ First_Range := False;
+ end if;
- Table (Nb_Choices) :=
- (Choice_Lo => Low,
- Choice_Hi => High,
- Choice_Node => Get_Assoc_Expr (Assoc));
+ Nb_Choices := Nb_Choices + 1;
- Next (Choice);
- end loop;
+ Table (Nb_Choices) :=
+ (Choice_Lo => Low,
+ Choice_Hi => High,
+ Choice_Node => Get_Assoc_Expr (Assoc));
+
+ Next (Choice);
+ end loop;
+ end;
Next (Assoc);
end loop;
@@ -2059,12 +2064,10 @@ package body Exp_Aggr is
end if;
if First or else not Empty_Range (Low, High) then
- First := False;
- if Present (Loop_Actions (Others_Assoc)) then
- pragma Assert
- (Is_Empty_List (Loop_Actions (Others_Assoc)));
- else
+ if First then
+ pragma Assert (No (Loop_Actions (Others_Assoc)));
Set_Loop_Actions (Others_Assoc, New_List);
+ First := False;
end if;
Expr := Get_Assoc_Expr (Others_Assoc);
Append_List (Gen_Loop (Low, High, Expr), To => New_Code);
diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb
index b400505db7b..666c9bae04f 100644
--- a/gcc/ada/exp_util.adb
+++ b/gcc/ada/exp_util.adb
@@ -8116,9 +8116,9 @@ package body Exp_Util is
-- If a component association appears within a loop created for
-- an array aggregate, attach the actions to the association so
-- they can be subsequently inserted within the loop. For other
- -- component associations insert outside of the aggregate. For
+ -- component associations, insert outside of the aggregate. For
-- an association that will generate a loop, its Loop_Actions
- -- attribute is already initialized (see exp_aggr.adb).
+ -- field is already initialized (see exp_aggr.adb).
-- The list of Loop_Actions can in turn generate additional ones,
-- that are inserted before the associated node. If the associated
@@ -8131,27 +8131,12 @@ package body Exp_Util is
| N_Iterated_Element_Association
=>
if Nkind (Parent (P)) in N_Aggregate | N_Delta_Aggregate
-
- -- We must not climb up out of an N_Iterated_xxx_Association
- -- because the actions might contain references to the loop
- -- parameter, except if we come from the Discrete_Choices of
- -- N_Iterated_Component_Association which cannot contain any.
- -- But it turns out that setting the Loop_Actions field in
- -- the case of an N_Component_Association when the field was
- -- not already set can lead to gigi assertion failures that
- -- are presumably due to malformed trees, so don't do that.
-
- and then
- not (Nkind (P) = N_Iterated_Component_Association
- and then Is_List_Member (N)
- and then List_Containing (N) = Discrete_Choices (P))
- and then
- not (Nkind (P) = N_Component_Association
- and then No (Loop_Actions (P)))
+ and then Present (Loop_Actions (P))
then
if Is_Empty_List (Loop_Actions (P)) then
Set_Loop_Actions (P, Ins_Actions);
Analyze_List (Ins_Actions);
+
else
declare
Decl : Node_Id;
diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb
index b05b0b267fe..0faca2863d3 100644
--- a/gcc/ada/sem_aggr.adb
+++ b/gcc/ada/sem_aggr.adb
@@ -253,6 +253,7 @@ package body Sem_Aggr is
Index : Node_Id;
Index_Constr : Node_Id;
Component_Typ : Entity_Id;
+ Iterated : Boolean;
Others_Allowed : Boolean) return Boolean;
-- This procedure performs the semantic checks for an array aggregate.
-- True is returned if the aggregate resolution succeeds.
@@ -278,6 +279,9 @@ package body Sem_Aggr is
--
-- Component_Typ is the array component type.
--
+ -- Iterated indicates whether the aggregate appears in the context of an
+ -- iterated association for a parent aggregate.
+ --
-- Others_Allowed indicates whether an others choice is allowed
-- in the context where the top-level aggregate appeared.
--
@@ -1499,6 +1503,7 @@ package body Sem_Aggr is
Index => First_Index (Aggr_Typ),
Index_Constr => First_Index (Typ),
Component_Typ => Component_Type (Typ),
+ Iterated => False,
Others_Allowed => True);
else
Aggr_Resolved :=
@@ -1507,6 +1512,7 @@ package body Sem_Aggr is
Index => First_Index (Aggr_Typ),
Index_Constr => First_Index (Aggr_Typ),
Component_Typ => Component_Type (Typ),
+ Iterated => False,
Others_Allowed => False);
end if;
@@ -1575,6 +1581,7 @@ package body Sem_Aggr is
Index : Node_Id;
Index_Constr : Node_Id;
Component_Typ : Entity_Id;
+ Iterated : Boolean;
Others_Allowed : Boolean) return Boolean
is
Loc : constant Source_Ptr := Sloc (N);
@@ -1633,8 +1640,9 @@ package body Sem_Aggr is
-- cause raising CE at runtime.
function Resolve_Aggr_Expr
- (Expr : Node_Id;
- Single_Elmt : Boolean) return Boolean;
+ (Expr : Node_Id;
+ Iterated_Elmt : Boolean := False;
+ Single_Elmt : Boolean := True) return Boolean;
-- Resolves aggregate expression Expr. Returns False if resolution
-- fails. If Single_Elmt is set to False, the expression Expr may be
-- used to initialize several array aggregate elements (this can happen
@@ -1966,9 +1974,13 @@ package body Sem_Aggr is
-----------------------
function Resolve_Aggr_Expr
- (Expr : Node_Id;
- Single_Elmt : Boolean) return Boolean
+ (Expr : Node_Id;
+ Iterated_Elmt : Boolean := False;
+ Single_Elmt : Boolean := True) return Boolean
is
+ Iterated_Expr : constant Boolean := Iterated_Elmt or else Iterated;
+ -- True if the Expr is in an iteration context, possibly nested
+
Nxt_Ind : constant Node_Id := Next_Index (Index);
Nxt_Ind_Constr : constant Node_Id := Next_Index (Index_Constr);
-- Index is the current index corresponding to the expression
@@ -2040,12 +2052,15 @@ package body Sem_Aggr is
Set_Etype (Expr, Etype (N));
- Resolution_OK := Resolve_Array_Aggregate
- (Expr, Nxt_Ind, Nxt_Ind_Constr, Component_Typ, Others_Allowed);
+ Resolution_OK :=
+ Resolve_Array_Aggregate
+ (Expr, Nxt_Ind, Nxt_Ind_Constr, Component_Typ,
+ Iterated => Iterated_Expr, Others_Allowed => Others_Allowed);
if Resolution_OK = Failure then
return Failure;
end if;
+
else
-- If it's "... => <>", nothing to resolve
@@ -2055,15 +2070,15 @@ package body Sem_Aggr is
end if;
-- Do not resolve the expressions of discrete or others choices
- -- unless the expression covers a single component, or the
- -- expander is inactive.
+ -- unless the expression covers a single component, or else the
+ -- expander is inactive or this is a spec expression.
-- In SPARK mode, expressions that can perform side effects will
-- be recognized by the gnat2why back-end, and the whole
-- subprogram will be ignored. So semantic analysis can be
-- performed safely.
- if Single_Elmt
+ if (Single_Elmt and then not Iterated_Expr)
or else not Expander_Active
or else In_Spec_Expression
then
@@ -2072,6 +2087,20 @@ package body Sem_Aggr is
Check_Non_Static_Context (Expr);
Aggregate_Constraint_Checks (Expr, Component_Typ);
Check_Unset_Reference (Expr);
+
+ -- Analyze a copy of the expression, to verify legality. We use
+ -- a copy because the expression will be analyzed anew when the
+ -- enclosing aggregate is expanded, and the construct is rewritten
+ -- as a loop with a new index variable.
+
+ elsif Iterated_Expr then
+ declare
+ New_Expr : constant Node_Id := Copy_Separate_Tree (Expr);
+
+ begin
+ Set_Parent (New_Expr, Parent (Expr));
+ Preanalyze_And_Resolve (New_Expr, Component_Typ);
+ end;
end if;
end if;
@@ -2212,23 +2241,15 @@ package body Sem_Aggr is
-- Analyze expression without expansion, to verify legality.
-- When generating code, we then remove references to the index
- -- variable, because the expression will be analyzed anew after
- -- rewritting as a loop with a new index variable; when not
- -- generating code we leave the analyzed expression as it is.
+ -- variable, because the expression will be analyzed anew when the
+ -- enclosing aggregate is expanded, and the construct is rewritten
+ -- as a loop with a new index variable; when not generating code we
+ -- leave the analyzed expression as it is.
- Resolution_OK := Resolve_Aggr_Expr (Expr, Single_Elmt => False);
+ Resolution_OK := Resolve_Aggr_Expr (Expr, Iterated_Elmt => True);
if Operating_Mode /= Check_Semantics then
Remove_References (Expr);
- declare
- Loop_Action : Node_Id;
- begin
- Loop_Action := First (Loop_Actions (N));
- while Present (Loop_Action) loop
- Remove_References (Loop_Action);
- Next (Loop_Action);
- end loop;
- end;
end if;
End_Scope;
@@ -3582,17 +3603,19 @@ package body Sem_Aggr is
Check_Can_Never_Be_Null (Etype (N), Expr);
end if;
- if not Resolve_Aggr_Expr (Expr, Single_Elmt => True) then
+ if not Resolve_Aggr_Expr (Expr) then
return Failure;
end if;
-- Check incorrect use of dynamically tagged expression
- if Is_Tagged_Type (Etype (Expr)) then
- Check_Dynamically_Tagged_Expression
- (Expr => Expr,
- Typ => Component_Type (Etype (N)),
- Related_Nod => N);
+ if not Iterated then
+ if Is_Tagged_Type (Etype (Expr)) then
+ Check_Dynamically_Tagged_Expression
+ (Expr => Expr,
+ Typ => Component_Type (Etype (N)),
+ Related_Nod => N);
+ end if;
end if;
Next (Expr);
@@ -4030,10 +4053,10 @@ package body Sem_Aggr is
-- enclosing aggregate is expanded, and the construct is rewritten
-- as a loop with a new index variable.
- Expr := New_Copy_Tree (Expression (Comp));
+ Expr := Copy_Separate_Tree (Expression (Comp));
+ Set_Parent (Expr, Comp);
Preanalyze_And_Resolve (Expr, Elmt_Type);
End_Scope;
-
end Resolve_Iterated_Association;
-- Start of processing for Resolve_Container_Aggregate
@@ -4468,14 +4491,17 @@ package body Sem_Aggr is
Set_Is_Not_Self_Hidden (Id);
Set_Scope (Id, Ent);
end if;
+
Enter_Name (Id);
- -- Resolve a copy of the expression, after setting
- -- its parent properly to preserve its context.
+ -- Analyze a copy of the expression, to verify legality. We use
+ -- a copy because the expression will be analyzed anew when the
+ -- enclosing aggregate is expanded, and the construct is
+ -- rewritten as a loop with a new index variable.
- Expr := New_Copy_Tree (Expression (Assoc));
+ Expr := Copy_Separate_Tree (Expression (Assoc));
Set_Parent (Expr, Assoc);
- Analyze_And_Resolve (Expr, Component_Type (Typ));
+ Preanalyze_And_Resolve (Expr, Component_Type (Typ));
End_Scope;
end;
--
2.43.0
