[flang] Fix folding of ac-implied-do indices in structure c'tors

Array constructors with implied DO loops that oversee structure
constructors were being prematurely folded into invalid constants
containing symbolic references to the ac-implied-do indices,
because they are indeed "constant expressions" as that term is
used in the Fortran standard and implemented as IsConstantExpr().
What's actually needed in structure constructor folding is a
test for actual constant values, which is what results from
folding them later with repetition in the context of folding
an ac-implied-do.

Differential Revision: https://reviews.llvm.org/D115470

Author: klausler

flang/lib/Evaluate/fold-implementation.h

@@ -1094,7 +1094,7 @@ Expr<ImpliedDoIndex::Result> FoldOperation(FoldingContext &, ImpliedDoIndex &&);
 // Array constructor folding
 template <typename T> class ArrayConstructorFolder {
 public:
-  explicit ArrayConstructorFolder(const FoldingContext &c) : context_{c} {}
+  explicit ArrayConstructorFolder(FoldingContext &c) : context_{c} {}
 
   Expr<T> FoldArray(ArrayConstructor<T> &&array) {
     // Calls FoldArray(const ArrayConstructorValues<T> &) below
@@ -1118,8 +1118,8 @@ template <typename T> class ArrayConstructorFolder {
   }
 
 private:
-  bool FoldArray(const common::CopyableIndirection<Expr<T>> &expr) {
-    Expr<T> folded{Fold(context_, common::Clone(expr.value()))};
+  bool FoldArray(const Expr<T> &expr) {
+    Expr<T> folded{Fold(context_, common::Clone(expr))};
     if (const auto *c{UnwrapConstantValue<T>(folded)}) {
       // Copy elements in Fortran array element order
       if (!c->empty()) {
@@ -1133,6 +1133,9 @@ template <typename T> class ArrayConstructorFolder {
       return false;
     }
   }
+  bool FoldArray(const common::CopyableIndirection<Expr<T>> &expr) {
+    return FoldArray(expr.value());
+  }
   bool FoldArray(const ImpliedDo<T> &iDo) {
     Expr<SubscriptInteger> lower{
         Fold(context_, Expr<SubscriptInteger>{iDo.lower()})};
@@ -1172,7 +1175,7 @@ template <typename T> class ArrayConstructorFolder {
     return true;
   }
 
-  FoldingContext context_;
+  FoldingContext &context_;
   std::vector<Scalar<T>> elements_;
 };
 

flang/lib/Evaluate/fold.cpp

@@ -65,29 +65,32 @@ std::optional<Constant<SubscriptInteger>> GetConstantSubscript(
 Expr<SomeDerived> FoldOperation(
     FoldingContext &context, StructureConstructor &&structure) {
   StructureConstructor ctor{structure.derivedTypeSpec()};
-  bool constantExtents{true};
+  bool isConstant{true};
   for (auto &&[symbol, value] : std::move(structure)) {
     auto expr{Fold(context, std::move(value.value()))};
-    if (!IsPointer(symbol)) {
-      bool ok{false};
+    if (IsPointer(symbol)) {
+      if (IsProcedure(symbol)) {
+        isConstant &= IsInitialProcedureTarget(expr);
+      } else {
+        isConstant &= IsInitialDataTarget(expr);
+      }
+    } else {
+      isConstant &= IsActuallyConstant(expr);
       if (auto valueShape{GetConstantExtents(context, expr)}) {
         if (auto componentShape{GetConstantExtents(context, symbol)}) {
           if (GetRank(*componentShape) > 0 && GetRank(*valueShape) == 0) {
             expr = ScalarConstantExpander{std::move(*componentShape)}.Expand(
                 std::move(expr));
-            ok = expr.Rank() > 0;
+            isConstant &= expr.Rank() > 0;
           } else {
-            ok = *valueShape == *componentShape;
+            isConstant &= *valueShape == *componentShape;
           }
         }
       }
-      if (!ok) {
-        constantExtents = false;
-      }
     }
-    ctor.Add(symbol, Fold(context, std::move(expr)));
+    ctor.Add(symbol, std::move(expr));
   }
-  if (constantExtents && IsConstantExpr(ctor)) {
+  if (isConstant) {
     return Expr<SomeDerived>{Constant<SomeDerived>{std::move(ctor)}};
   } else {
     return Expr<SomeDerived>{std::move(ctor)};

flang/test/Evaluate/folding30.f90

@@ -0,0 +1,11 @@
+! RUN: %python %S/test_folding.py %s %flang_fc1
+! Tests folding of structure constructors in array constructors
+module m
+  type :: t1
+    integer :: n
+  end type
+  type(t1), parameter :: xs1(*) = [(t1(j),j=1,5,2)]
+  type(t1), parameter :: xs2(*) = [(t1(j),j=5,1,-2)]
+  logical, parameter :: test_1 = all(xs1%n == [1, 3, 5])
+  logical, parameter :: test_2 = all(xs2%n == [5, 3, 1])
+end module