ada: Further work in semantic analysis of iterated component associations

This finishes up the transition to preanalysis of a copy of the expression
for iterated component associations in all contexts, thus voiding the need
to clean things up afterward.

However, this requires a larger cleanup in semantics analysis of aggregates,
in particular for others choices, which are currently skipped in Sem_Aggr,
with Exp_Aggr trying to patch things up afterward but leaving some legality
loopholes in the end.  That's why this makes sure that all the expressions
appearing in aggregates are either analyzed or preanalyzed by Sem_Aggr, as
documented in the spec of Sem, modulo the copy in an iteration context.

gcc/ada/ChangeLog:

	* exp_aggr.adb (Build_Array_Aggr_Code): Remove obsolete comment.
	(Convert_To_Positional): Remove Ctyp local variable.
	(Is_Static_Element): Remove Dims parameter and do not preanalyze the
	expression there.
	(Expand_Array_Aggregate): Make Ctyp a constant.
	(Compute_Others_Present): Do not preanalyze the expression there.
	* sem_aggr.adb (Resolve_Array_Aggregate): New Ctyp constant.  Use it
	throughout the procedure to denote the component type.
	(Resolve_Aggr_Expr): Always preanalyze a copy of the expression in
	an iteration context.  Preanalyze it directly when the expander is
	active and the choice may cover multiple components.  Otherwise,
	fully analyze it.
	Do not reanalyze an iterated component association with an others
	choice either when there are positional components.
	(Resolve_Iterated_Component_Association): Do not remove references
	from the expression after invoking Resolve_Aggr_Expr on it.

2 files changed, 86 insertions, 126 deletions

diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb
index c01011c..c935543 100644
--- a/gcc/ada/exp_aggr.adb
+++ b/gcc/ada/exp_aggr.adb
@@ -1645,8 +1645,7 @@ package body Exp_Aggr is
          if Is_Iterated_Component then
 
             --  Create a new scope for the loop variable so that the
-            --  following Gen_Assign (that ends up calling
-            --  Preanalyze_And_Resolve) can correctly find it.
+            --  following Gen_Assign can correctly find it.
 
             Ent := New_Internal_Entity (E_Loop,
                  Current_Scope, Loc, 'L');
@@ -4410,7 +4409,6 @@ package body Exp_Aggr is
       Dims                 : constant Nat := Number_Dimensions (Typ);
       Max_Others_Replicate : constant Nat := Max_Aggregate_Size (N);
 
-      Ctyp              : Entity_Id := Component_Type (Typ);
       Static_Components : Boolean   := True;
 
       procedure Check_Static_Components;
@@ -4430,7 +4428,7 @@ package body Exp_Aggr is
       --  Return True if the aggregate N is flat (which is not trivial in the
       --  case of multidimensional aggregates).
 
-      function Is_Static_Element (N : Node_Id; Dims : Nat) return Boolean;
+      function Is_Static_Element (N : Node_Id) return Boolean;
       --  Return True if N, an element of a component association list, i.e.
       --  N_Component_Association or N_Iterated_Component_Association, has a
       --  compile-time known value and can be passed as is to the back-end
@@ -4474,7 +4472,7 @@ package body Exp_Aggr is
          then
             Assoc := First (Component_Associations (N));
             while Present (Assoc) loop
-               if not Is_Static_Element (Assoc, Dims) then
+               if not Is_Static_Element (Assoc) then
                   Static_Components := False;
                   exit;
                end if;
@@ -4699,7 +4697,7 @@ package body Exp_Aggr is
                               --  only if either the element is static or is
                               --  an aggregate (we already know it is OK).
 
-                              elsif not Is_Static_Element (Elmt, Dims)
+                              elsif not Is_Static_Element (Elmt)
                                 and then Nkind (Expr) /= N_Aggregate
                               then
                                  return False;
@@ -4856,7 +4854,7 @@ package body Exp_Aggr is
       -- Is_Static_Element --
       -----------------------
 
-      function Is_Static_Element (N : Node_Id; Dims : Nat) return Boolean is
+      function Is_Static_Element (N : Node_Id) return Boolean is
          Expr : constant Node_Id := Expression (N);
 
       begin
@@ -4874,14 +4872,6 @@ package body Exp_Aggr is
          then
             return True;
 
-         --  However, one may write static expressions that are syntactically
-         --  ambiguous, so preanalyze the expression before checking it again,
-         --  but only at the innermost level for a multidimensional array.
-
-         elsif Dims = 1 then
-            Preanalyze_And_Resolve (Expr, Ctyp);
-            return Compile_Time_Known_Value (Expr);
-
          else
             return False;
          end if;
@@ -4922,10 +4912,6 @@ package body Exp_Aggr is
          return;
       end if;
 
-      --  Special handling for mutably taggeds
-
-      Ctyp := Get_Corresponding_Mutably_Tagged_Type_If_Present (Ctyp);
-
       Check_Static_Components;
 
       --  If the size is known, or all the components are static, try to
@@ -5019,8 +5005,12 @@ package body Exp_Aggr is
       Typ : constant Entity_Id := Etype (N);
       --  Typ is the correct constrained array subtype of the aggregate
 
-      Ctyp : Entity_Id := Component_Type (Typ);
-      --  Ctyp is the corresponding component type.
+      Component_Typ : constant Entity_Id := Component_Type (Typ);
+      --  Component_Typ is the corresponding component type
+
+      Ctyp : constant Entity_Id :=
+        Get_Corresponding_Mutably_Tagged_Type_If_Present (Component_Typ);
+      --  Ctyp is the corresponding component type to be used
 
       Aggr_Dimension : constant Pos := Number_Dimensions (Typ);
       --  Number of aggregate index dimensions
@@ -5355,21 +5345,6 @@ package body Exp_Aggr is
               and then Nkind (First (Choice_List (Assoc))) = N_Others_Choice
             then
                Others_Present (Dim) := True;
-
-               --  An others_clause may be superfluous if previous components
-               --  cover the full given range of a constrained array. In such
-               --  a case an others_clause does not contribute any additional
-               --  components and has not been analyzed. We analyze it now to
-               --  detect type errors in the expression, even though no code
-               --  will be generated for it.
-
-               if Dim = Aggr_Dimension
-                 and then Nkind (Assoc) /= N_Iterated_Component_Association
-                 and then not Analyzed (Expression (Assoc))
-                 and then not Box_Present (Assoc)
-               then
-                  Preanalyze_And_Resolve (Expression (Assoc), Ctyp);
-               end if;
             end if;
          end if;
 
@@ -5392,8 +5367,7 @@ package body Exp_Aggr is
             if Present (Component_Associations (Sub_Aggr)) then
                Assoc := First (Component_Associations (Sub_Aggr));
                while Present (Assoc) loop
-                  Expr := Expression (Assoc);
-                  Compute_Others_Present (Expr, Dim + 1);
+                  Compute_Others_Present (Expression (Assoc), Dim + 1);
                   Next (Assoc);
                end loop;
             end if;
@@ -5966,10 +5940,6 @@ package body Exp_Aggr is
 
       pragma Assert (not Raises_Constraint_Error (N));
 
-      --  Special handling for mutably taggeds
-
-      Ctyp := Get_Corresponding_Mutably_Tagged_Type_If_Present (Ctyp);
-
       --  STEP 1a
 
       --  Check that the index range defined by aggregate bounds is
diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb
index e5bd4fd..8cc00ad 100644
--- a/gcc/ada/sem_aggr.adb
+++ b/gcc/ada/sem_aggr.adb
@@ -1589,6 +1589,9 @@ package body Sem_Aggr is
       Failure : constant Boolean := False;
       Success : constant Boolean := True;
 
+      Ctyp : constant Entity_Id :=
+        Get_Corresponding_Mutably_Tagged_Type_If_Present (Component_Typ);
+
       Index_Typ      : constant Entity_Id := Etype (Index);
       Index_Typ_Low  : constant Node_Id   := Type_Low_Bound  (Index_Typ);
       Index_Typ_High : constant Node_Id   := Type_High_Bound (Index_Typ);
@@ -2005,7 +2008,7 @@ package body Sem_Aggr is
                --  operator, it is still an operator symbol, which will be
                --  transformed into a string when analyzed.
 
-               if Is_Character_Type (Component_Typ)
+               if Is_Character_Type (Ctyp)
                  and then No (Next_Index (Nxt_Ind))
                  and then Nkind (Expr) in N_String_Literal | N_Operator_Symbol
                then
@@ -2043,7 +2046,7 @@ package body Sem_Aggr is
 
             Resolution_OK :=
               Resolve_Array_Aggregate
-                (Expr, Nxt_Ind, Nxt_Ind_Constr, Component_Typ,
+                (Expr, Nxt_Ind, Nxt_Ind_Constr, Ctyp,
                  Iterated => Iterated_Expr, Others_Allowed => Others_Allowed);
 
             if Resolution_OK = Failure then
@@ -2051,38 +2054,60 @@ package body Sem_Aggr is
             end if;
 
          else
-            --  Do not resolve the expressions of discrete or others choices
-            --  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 and then not Iterated_Expr)
-              or else not Expander_Active
-              or else In_Spec_Expression
-            then
-               Analyze_And_Resolve (Expr, Component_Typ);
-               Check_Expr_OK_In_Limited_Aggregate (Expr);
-               Check_Non_Static_Context (Expr);
-               Aggregate_Constraint_Checks (Expr, Component_Typ);
-               Check_Unset_Reference (Expr);
+            --  In an iterated context, preanalyze 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.
 
-            --  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.
+            --  If the parent is a component association, we also temporarily
+            --  point its Expression field to the copy, because analysis may
+            --  expect this invariant to hold.
 
-            elsif Iterated_Expr then
+            if Iterated_Expr then
                declare
+                  In_Assoc : constant Boolean :=
+                    Nkind (Parent (Expr)) in N_Component_Association
+                                          |  N_Iterated_Component_Association;
                   New_Expr : constant Node_Id := Copy_Separate_Tree (Expr);
 
                begin
                   Set_Parent (New_Expr, Parent (Expr));
-                  Preanalyze_And_Resolve (New_Expr, Component_Typ);
+                  if In_Assoc then
+                     Set_Expression (Parent (Expr), New_Expr);
+                  end if;
+
+                  Preanalyze_And_Resolve (New_Expr, Ctyp);
+                  Check_Expr_OK_In_Limited_Aggregate (New_Expr);
+                  Check_Expression_Dimensions (New_Expr, Ctyp);
+
+                  if In_Assoc then
+                     Set_Expression (Parent (Expr), Expr);
+                  end if;
                end;
+
+            --  If the expander is active and the choice may cover multiple
+            --  components, then we cannot expand (see the spec of Sem), so
+            --  we preanalyze the expression.
+
+            elsif Expander_Active and then not Single_Elmt then
+               Preanalyze_And_Resolve (Expr, Ctyp);
+               Check_Expr_OK_In_Limited_Aggregate (Expr);
+               Check_Expression_Dimensions (Expr, Ctyp);
+
+               --  The range given by the choice may be empty, in which case we
+               --  do not want spurious warnings about CE raised at run time.
+
+               Remove_Warning_Messages (Expr);
+
+            --  Otherwise, we perform a full analysis of the expression
+
+            else
+               Analyze_And_Resolve (Expr, Ctyp);
+               Check_Expr_OK_In_Limited_Aggregate (Expr);
+               Check_Expression_Dimensions (Expr, Ctyp);
+               Check_Non_Static_Context (Expr);
+               Check_Unset_Reference (Expr);
+               Aggregate_Constraint_Checks (Expr, Ctyp);
             end if;
          end if;
 
@@ -2092,10 +2117,10 @@ package body Sem_Aggr is
          --  component assignments. If the expression covers several components
          --  the analysis and the predicate check take place later.
 
-         if Has_Predicates (Component_Typ)
+         if Has_Predicates (Ctyp)
            and then Analyzed (Expr)
          then
-            Apply_Predicate_Check (Expr, Component_Typ);
+            Apply_Predicate_Check (Expr, Ctyp);
          end if;
 
          if Raises_Constraint_Error (Expr)
@@ -2112,7 +2137,7 @@ package body Sem_Aggr is
          --  the expander is not active.
 
          if Do_Range_Check (Expr) then
-            Generate_Range_Check (Expr, Component_Typ, CE_Range_Check_Failed);
+            Generate_Range_Check (Expr, Ctyp, CE_Range_Check_Failed);
          end if;
 
          return Resolution_OK;
@@ -2130,29 +2155,6 @@ package body Sem_Aggr is
          Id   : constant Entity_Id  := Defining_Identifier (N);
          Expr : constant Node_Id    := Expression (N);
 
-         -----------------------
-         -- Remove_References --
-         -----------------------
-
-         function Remove_Reference (N : Node_Id) return Traverse_Result;
-         --  Remove reference to the entity Id after analysis, so it can be
-         --  properly reanalyzed after construct is expanded into a loop.
-
-         function Remove_Reference (N : Node_Id) return Traverse_Result is
-         begin
-            if Nkind (N) = N_Identifier
-               and then Present (Entity (N))
-               and then Entity (N) = Id
-            then
-               Set_Entity (N, Empty);
-               Set_Etype (N, Empty);
-            end if;
-            Set_Analyzed (N, False);
-            return OK;
-         end Remove_Reference;
-
-         procedure Remove_References is new Traverse_Proc (Remove_Reference);
-
          --  Local variables
 
          Choice         : Node_Id;
@@ -2221,19 +2223,10 @@ package body Sem_Aggr is
             Set_Scope (Id, Scop);
          end if;
 
-         --  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 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.
+         --  Analyze expression without expansion, to verify legality
 
          Resolution_OK := Resolve_Aggr_Expr (Expr, Iterated_Elmt => True);
 
-         if Operating_Mode /= Check_Semantics then
-            Remove_References (Expr);
-         end if;
-
          End_Scope;
 
          return Resolution_OK;
@@ -2346,8 +2339,6 @@ package body Sem_Aggr is
       ----------------------------------------
 
       procedure Warn_On_Null_Component_Association (Expr : Node_Id) is
-         Comp_Typ : constant Entity_Id := Component_Type (Etype (N));
-
          procedure Check_Case_Expr (N : Node_Id);
          --  Check if a case expression may initialize some component with a
          --  null value.
@@ -2445,14 +2436,14 @@ package body Sem_Aggr is
               Make_Raise_Constraint_Error (Sloc (Null_Expr),
                 Reason => CE_Access_Check_Failed));
 
-            Set_Etype    (Null_Expr, Comp_Typ);
+            Set_Etype    (Null_Expr, Ctyp);
             Set_Analyzed (Null_Expr);
          end Warn_On_Null_Expression_And_Rewrite;
 
       --  Start of processing for Warn_On_Null_Component_Association
 
       begin
-         pragma Assert (Can_Never_Be_Null (Comp_Typ));
+         pragma Assert (Can_Never_Be_Null (Ctyp));
 
          case Nkind (Expr) is
             when N_If_Expression =>
@@ -3063,7 +3054,7 @@ package body Sem_Aggr is
                   --            (if Func (J) = 0 then A(J)'Access else Null)];
 
                   elsif Ada_Version >= Ada_2022
-                    and then Can_Never_Be_Null (Component_Type (Etype (N)))
+                    and then Can_Never_Be_Null (Ctyp)
                     and then Nkind (Assoc) = N_Iterated_Component_Association
                     and then Nkind (Expression (Assoc)) in N_If_Expression
                                                          | N_Case_Expression
@@ -3125,13 +3116,6 @@ package body Sem_Aggr is
                      Set_Parent (Expr, Parent (Expression (Assoc)));
                      Analyze (Expr);
 
-                     --  Compute its dimensions now, rather than at the end of
-                     --  resolution, because in the case of multidimensional
-                     --  aggregates subsequent expansion may lead to spurious
-                     --  errors.
-
-                     Check_Expression_Dimensions (Expr, Component_Typ);
-
                      --  If the expression is a literal, propagate this info
                      --  to the expression in the association, to enable some
                      --  optimizations downstream.
@@ -3140,8 +3124,7 @@ package body Sem_Aggr is
                        and then Present (Entity (Expr))
                        and then Ekind (Entity (Expr)) = E_Enumeration_Literal
                      then
-                        Analyze_And_Resolve
-                          (Expression (Assoc), Component_Typ);
+                        Analyze_And_Resolve (Expression (Assoc), Ctyp);
                      end if;
 
                      Full_Analysis := Save_Analysis;
@@ -3151,8 +3134,7 @@ package body Sem_Aggr is
                      --  types.
 
                      if Is_Tagged_Type (Etype (Expr))
-                       and then Is_Class_Wide_Equivalent_Type
-                                  (Component_Type (Etype (N)))
+                       and then Is_Class_Wide_Equivalent_Type (Ctyp)
                      then
                         null;
 
@@ -3161,7 +3143,7 @@ package body Sem_Aggr is
                      elsif Is_Tagged_Type (Etype (Expr)) then
                         Check_Dynamically_Tagged_Expression
                           (Expr => Expr,
-                           Typ  => Component_Type (Etype (N)),
+                           Typ  => Ctyp,
                            Related_Nod => N);
                      end if;
                   end;
@@ -3169,7 +3151,7 @@ package body Sem_Aggr is
                elsif Is_Tagged_Type (Etype (Expression (Assoc))) then
                   Check_Dynamically_Tagged_Expression
                     (Expr        => Expression (Assoc),
-                     Typ         => Component_Type (Etype (N)),
+                     Typ         => Ctyp,
                      Related_Nod => N);
                end if;
 
@@ -3593,7 +3575,7 @@ package body Sem_Aggr is
                if Is_Tagged_Type (Etype (Expr)) then
                   Check_Dynamically_Tagged_Expression
                     (Expr => Expr,
-                     Typ  => Component_Type (Etype (N)),
+                     Typ  => Ctyp,
                      Related_Nod => N);
                end if;
             end if;
@@ -3625,6 +3607,14 @@ package body Sem_Aggr is
                   return Failure;
                end if;
 
+            --  ??? Checks for dynamically tagged expressions below will
+            --  be only applied to iterated_component_association after
+            --  expansion; in particular, errors might not be reported when
+            --  -gnatc switch is used.
+
+            elsif Nkind (Assoc) = N_Iterated_Component_Association then
+               null;   --  handled above, in a loop context
+
             elsif not Resolve_Aggr_Expr (Expression (Assoc),
                                          Single_Elmt => False)
             then
@@ -3635,7 +3625,7 @@ package body Sem_Aggr is
             --  In order to diagnose the semantic error we create a duplicate
             --  tree to analyze it and perform the check.
 
-            elsif Nkind (Assoc) /= N_Iterated_Component_Association then
+            else
                declare
                   Save_Analysis : constant Boolean := Full_Analysis;
                   Expr          : constant Node_Id :=
@@ -3651,7 +3641,7 @@ package body Sem_Aggr is
                   if Is_Tagged_Type (Etype (Expr)) then
                      Check_Dynamically_Tagged_Expression
                        (Expr        => Expr,
-                        Typ         => Component_Type (Etype (N)),
+                        Typ         => Ctyp,
                         Related_Nod => N);
                   end if;
                end;
@@ -3778,7 +3768,7 @@ package body Sem_Aggr is
 
       --  Check the dimensions of each component in the array aggregate
 
-      Analyze_Dimension_Array_Aggregate (N, Component_Typ);
+      Analyze_Dimension_Array_Aggregate (N, Ctyp);
 
       if Serious_Errors_Detected /= Saved_SED then
          return Failure;