[flang] Allow array constructor implied DO loop indices as constant expressions

[klausler]

Summary

When the bounds of an implied DO loop in an array constructor are
constant, the index variable of that loop is considered a constant
expression and can be used as such in the items in the value list
of the implied DO loop. Since the KIND type parameter values of items
in the value list can depend on the various values taken by such an
index, it is not possible to represent those values with a single
typed expression. So implement such loops by taking multiple passes
over the parse tree of the implied DO loop instead.

[jeanPerier]

Looks good to me

flang/include/flang/Parser/message.h

common::Restorer<CharBlock> SetLocation(CharBlock at) {
     return common::ScopedSet(at_, std::move(at));
   }
 
   // Diverts messages to another buffer; restored when the returned
   // value is deleted.
   common::Restorer<Messages *> SetMessages(Messages &buffer) {
     return common::ScopedSet(messages_, &buffer);
   }
-  // Discard messages; destination restored when the returned value is deleted.
+  // Discard future messages until the returned value is deleted.
   common::Restorer<Messages *> DiscardMessages() {
     return common::ScopedSet(messages_, nullptr);
   }
 
   template <typename... A> Message *Say(CharBlock at, A &&...args) {
     if (messages_ != nullptr) {
       return &messages_->Say(at, std::forward<A>(args)...);
     } else {

flang/include/flang/Semantics/expression.h

public:
   std::optional<int> IsImpliedDo(parser::CharBlock) const;
 
   // Allows a whole assumed-size array to appear for the lifetime of
   // the returned value.
   common::Restorer<bool> AllowWholeAssumedSizeArray() {
     return common::ScopedSet(isWholeAssumedSizeArrayOk_, true);
   }
 
+  common::Restorer<bool> DoNotUseSavedTypedExprs() {
+    return common::ScopedSet(useSavedTypedExprs_, false);
+  }
+
   Expr<SubscriptInteger> AnalyzeKindSelector(common::TypeCategory category,
       const std::optional<parser::KindSelector> &);
 
   MaybeExpr Analyze(const parser::Expr &);
   MaybeExpr Analyze(const parser::Variable &);
   MaybeExpr Analyze(const parser::Designator &);
   MaybeExpr Analyze(const parser::DataStmtValue &);
 
private:
   MaybeExpr MakeFunctionRef(parser::CharBlock intrinsic, ActualArguments &&);
   template <typename T> T Fold(T &&expr) {
     return evaluate::Fold(foldingContext_, std::move(expr));
   }
 
   semantics::SemanticsContext &context_;
   FoldingContext &foldingContext_{context_.foldingContext()};
   std::map<parser::CharBlock, int> impliedDos_; // values are INTEGER kinds
-  bool fatalErrors_{false};
   bool isWholeAssumedSizeArrayOk_{false};
+  bool useSavedTypedExprs_{true};
   friend class ArgumentAnalyzer;
 };
 
 inline bool AreConformable(int leftRank, int rightRank) {
   return leftRank == 0 || rightRank == 0 || leftRank == rightRank;
 }
 
 template <typename L, typename R>

flang/lib/Semantics/expression.cpp

if (type_ && type_->category() == T::category) {
               ArrayConstructor<T>{MakeSpecific<T>(std::move(values_))});
         }
       }
     }
     return std::nullopt;
   }
 
 private:
+  using ImpliedDoIntType = ResultType<ImpliedDoIndex>;
+
   void Push(MaybeExpr &&);
+  void Add(const parser::AcValue::Triplet &);
+  void Add(const parser::Expr &);
+  void Add(const parser::AcImpliedDo &);
+  void UnrollConstantImpliedDo(const parser::AcImpliedDo &,
+      parser::CharBlock name, std::int64_t lower, std::int64_t upper,
+      std::int64_t stride);
 
   template <int KIND, typename A>
   std::optional<Expr<Type<TypeCategory::Integer, KIND>>> GetSpecificIntExpr(
       const A &x) {
     if (MaybeExpr y{exprAnalyzer_.Analyze(x)}) {
       Expr<SomeInteger> *intExpr{UnwrapExpr<Expr<SomeInteger>>(*y)};
-      return ConvertToType<Type<TypeCategory::Integer, KIND>>(
-          std::move(DEREF(intExpr)));
+      return Fold(exprAnalyzer_.GetFoldingContext(),
+          ConvertToType<Type<TypeCategory::Integer, KIND>>(
+              std::move(DEREF(intExpr))));
     }
     return std::nullopt;
   }
 
   // Nested array constructors all reference the same ExpressionAnalyzer,
   // which represents the nest of active implied DO loop indices.
   ExpressionAnalyzer &exprAnalyzer_;
   std::optional<DynamicTypeWithLength> type_;
   bool explicitType_{type_.has_value()};
   std::optional<std::int64_t> constantLength_;
   ArrayConstructorValues<SomeType> values_;
-  bool messageDisplayedOnce{false};
+  std::uint64_t messageDisplayedSet_{0};
 };
 
 void ArrayConstructorContext::Push(MaybeExpr &&x) {
   if (!x) {
     return;
   }
   if (auto dyType{x->GetType()}) {
     DynamicTypeWithLength xType{*dyType};
if (auto dyType{x->GetType()}) {
     } else if (!explicitType_) {
       if (static_cast<const DynamicType &>(*type_) ==
           static_cast<const DynamicType &>(xType)) {
         values_.Push(std::move(*x));
         if (auto thisLen{ToInt64(xType.LEN())}) {
           if (constantLength_) {
             if (exprAnalyzer_.context().warnOnNonstandardUsage() &&
                 *thisLen != *constantLength_) {
+              if (!(messageDisplayedSet_ & 1)) {
                 exprAnalyzer_.Say(
                     "Character literal in array constructor without explicit "
-                  "type has different length than earlier element"_en_US);
+                    "type has different length than earlier elements"_en_US);
+                messageDisplayedSet_ |= 1;
+              }
             }
             if (*thisLen > *constantLength_) {
               // Language extension: use the longest literal to determine the
               // length of the array constructor's character elements, not the
               // first, when there is no explicit type.
               *constantLength_ = *thisLen;
               type_->length = xType.LEN();
             }
           } else {
             constantLength_ = *thisLen;
             type_->length = xType.LEN();
           }
         }
       } else {
-        if (!messageDisplayedOnce) {
+        if (!(messageDisplayedSet_ & 2)) {
           exprAnalyzer_.Say(
               "Values in array constructor must have the same declared type "
               "when no explicit type appears"_err_en_US); // C7110
-          messageDisplayedOnce = true;
+          messageDisplayedSet_ |= 2;
         }
       }
     } else {
       if (auto cast{ConvertToType(*type_, std::move(*x))}) {
         values_.Push(std::move(*cast));
-      } else {
+      } else if (!(messageDisplayedSet_ & 4)) {
         exprAnalyzer_.Say(
             "Value in array constructor of type '%s' could not "
             "be converted to the type of the array '%s'"_err_en_US,
             x->GetType()->AsFortran(), type_->AsFortran()); // C7111, C7112
+        messageDisplayedSet_ |= 4;
       }
     }
   }
 }
 
 void ArrayConstructorContext::Add(const parser::AcValue &x) {
-  using IntType = ResultType<ImpliedDoIndex>;
   std::visit(
       common::visitors{
-          [&](const parser::AcValue::Triplet &triplet) {
-            // Transform l:u(:s) into (_,_=l,u(,s)) with an anonymous index '_'
-            std::optional<Expr<IntType>> lower{
-                GetSpecificIntExpr<IntType::kind>(std::get<0>(triplet.t))};
-            std::optional<Expr<IntType>> upper{
-                GetSpecificIntExpr<IntType::kind>(std::get<1>(triplet.t))};
-            std::optional<Expr<IntType>> stride{
-                GetSpecificIntExpr<IntType::kind>(std::get<2>(triplet.t))};
-            if (lower && upper) {
-              if (!stride) {
-                stride = Expr<IntType>{1};
-              }
-              if (!type_) {
-                type_ = DynamicTypeWithLength{IntType::GetType()};
-              }
-              auto v{std::move(values_)};
-              parser::CharBlock anonymous;
-              Push(Expr<SomeType>{
-                  Expr<SomeInteger>{Expr<IntType>{ImpliedDoIndex{anonymous}}}});
-              std::swap(v, values_);
-              values_.Push(ImpliedDo<SomeType>{anonymous, std::move(*lower),
-                  std::move(*upper), std::move(*stride), std::move(v)});
-            }
-          },
-          [&](const common::Indirection<parser::Expr> &expr) {
-            auto restorer{exprAnalyzer_.GetContextualMessages().SetLocation(
-                expr.value().source)};
-            if (MaybeExpr v{exprAnalyzer_.Analyze(expr.value())}) {
-              if (auto exprType{v->GetType()}) {
-                if (exprType->IsUnlimitedPolymorphic()) {
-                  exprAnalyzer_.Say(
-                      "Cannot have an unlimited polymorphic value in an "
+          [&](const parser::AcValue::Triplet &triplet) { Add(triplet); },
+          [&](const common::Indirection<parser::Expr> &expr) {
+            Add(expr.value());
+          },
+          [&](const common::Indirection<parser::AcImpliedDo> &impliedDo) {
+            Add(impliedDo.value());
+          },
+      },
+      x.u);
+}
+
+// Transforms l:u(:s) into (_,_=l,u(,s)) with an anonymous index '_'
+void ArrayConstructorContext::Add(const parser::AcValue::Triplet &triplet) {
+  std::optional<Expr<ImpliedDoIntType>> lower{
+      GetSpecificIntExpr<ImpliedDoIntType::kind>(std::get<0>(triplet.t))};
+  std::optional<Expr<ImpliedDoIntType>> upper{
+      GetSpecificIntExpr<ImpliedDoIntType::kind>(std::get<1>(triplet.t))};
+  std::optional<Expr<ImpliedDoIntType>> stride{
+      GetSpecificIntExpr<ImpliedDoIntType::kind>(std::get<2>(triplet.t))};
+      stride = Expr<ImpliedDoIntType>{1};
+      type_ = DynamicTypeWithLength{ImpliedDoIntType::GetType()};
+        Expr<SomeInteger>{Expr<ImpliedDoIntType>{ImpliedDoIndex{anonymous}}}});
+}
+
+void ArrayConstructorContext::Add(const parser::Expr &expr) {
+  auto restorer{exprAnalyzer_.GetContextualMessages().SetLocation(expr.source)};
+  if (MaybeExpr v{exprAnalyzer_.Analyze(expr)}) {
+      if (!(messageDisplayedSet_ & 8) && exprType->IsUnlimitedPolymorphic()) {
+        exprAnalyzer_.Say("Cannot have an unlimited polymorphic value in an "
                           "array constructor"_err_en_US); // C7113
-                }
-              }
-              Push(std::move(*v));
-            }
-          },
-          [&](const common::Indirection<parser::AcImpliedDo> &impliedDo) {
-            const auto &control{
-                std::get<parser::AcImpliedDoControl>(impliedDo.value().t)};
-            const auto &bounds{
-                std::get<parser::AcImpliedDoControl::Bounds>(control.t)};
-            exprAnalyzer_.Analyze(bounds.name);
-            parser::CharBlock name{bounds.name.thing.thing.source};
-            const Symbol *symbol{bounds.name.thing.thing.symbol};
-            int kind{IntType::kind};
-            if (const auto dynamicType{DynamicType::From(symbol)}) {
-              kind = dynamicType->kind();
-            }
-            if (exprAnalyzer_.AddImpliedDo(name, kind)) {
-              std::optional<Expr<IntType>> lower{
-                  GetSpecificIntExpr<IntType::kind>(bounds.lower)};
-              std::optional<Expr<IntType>> upper{
-                  GetSpecificIntExpr<IntType::kind>(bounds.upper)};
-              if (lower && upper) {
-                std::optional<Expr<IntType>> stride{
-                    GetSpecificIntExpr<IntType::kind>(bounds.step)};
-                auto v{std::move(values_)};
-                for (const auto &value :
-                    std::get<std::list<parser::AcValue>>(impliedDo.value().t)) {
-                  Add(value);
-                }
-                if (!stride) {
-                  stride = Expr<IntType>{1};
-                }
-                std::swap(v, values_);
-                values_.Push(ImpliedDo<SomeType>{name, std::move(*lower),
-                    std::move(*upper), std::move(*stride), std::move(v)});
-              }
-              exprAnalyzer_.RemoveImpliedDo(name);
-            } else {
-              exprAnalyzer_.SayAt(name,
-                  "Implied DO index is active in surrounding implied DO loop "
-                  "and may not have the same name"_err_en_US); // C7115
-            }
-          },
-      },
-      x.u);
+        messageDisplayedSet_ |= 8;
+}
+
+void ArrayConstructorContext::Add(const parser::AcImpliedDo &impliedDo) {
+  const auto &control{std::get<parser::AcImpliedDoControl>(impliedDo.t)};
+  const auto &bounds{std::get<parser::AcImpliedDoControl::Bounds>(control.t)};
+  int kind{ImpliedDoIntType::kind};
+  if (!exprAnalyzer_.AddImpliedDo(name, kind)) {
+    if (!(messageDisplayedSet_ & 0x20)) {
+      exprAnalyzer_.SayAt(name,
+          "Implied DO index is active in surrounding implied DO loop "
+          "and may not have the same name"_err_en_US); // C7115
+      messageDisplayedSet_ |= 0x20;
+    }
+    return;
+  }
+  std::optional<Expr<ImpliedDoIntType>> lower{
+      GetSpecificIntExpr<ImpliedDoIntType::kind>(bounds.lower)};
+  std::optional<Expr<ImpliedDoIntType>> upper{
+      GetSpecificIntExpr<ImpliedDoIntType::kind>(bounds.upper)};
+    std::optional<Expr<ImpliedDoIntType>> stride{
+        GetSpecificIntExpr<ImpliedDoIntType::kind>(bounds.step)};
+    if (!stride) {
+      stride = Expr<ImpliedDoIntType>{1};
+    }
+    // Check for constant bounds; the loop may require complete unrolling
+    // of the parse tree if all bounds are constant in order to allow the
+    // implied DO loop index to qualify as a constant expression.
+    auto cLower{ToInt64(lower)};
+    auto cUpper{ToInt64(upper)};
+    auto cStride{ToInt64(stride)};
+    if (!(messageDisplayedSet_ & 0x10) && cStride && *cStride == 0) {
+      exprAnalyzer_.SayAt(bounds.step.value().thing.thing.value().source,
+          "The stride of an implied DO loop must not be zero"_err_en_US);
+      messageDisplayedSet_ |= 0x10;
+    }
+    bool isConstant{cLower && cUpper && cStride && *cStride != 0};
+    bool isNonemptyConstant{isConstant &&
+        ((*cStride > 0 && *cLower <= *cUpper) ||
+            (*cStride < 0 && *cLower >= *cUpper))};
+    bool unrollConstantLoop{false};
+    parser::Messages buffer;
+    auto saveMessagesDisplayed{messageDisplayedSet_};
+    {
+      auto messageRestorer{
+          exprAnalyzer_.GetContextualMessages().SetMessages(buffer)};
+          std::get<std::list<parser::AcValue>>(impliedDo.t)) {
+      if (isNonemptyConstant && buffer.AnyFatalError()) {
+        unrollConstantLoop = true;
+      } else {
+    }
+    if (unrollConstantLoop) {
+      messageDisplayedSet_ = saveMessagesDisplayed;
+      UnrollConstantImpliedDo(impliedDo, name, *cLower, *cUpper, *cStride);
+    } else if (auto *messages{
+                   exprAnalyzer_.GetContextualMessages().messages()}) {
+      messages->Annex(std::move(buffer));
+    }
+  }
+
+// Fortran considers an implied DO index of an array constructor to be
+// a constant expression if the bounds of the implied DO loop are constant.
+// Usually this doesn't matter, but if we emitted spurious messages as a
+// result of not using constant values for the index while analyzing the
+// items, we need to do it again the "hard" way with multiple iterations over
+// the parse tree.
+void ArrayConstructorContext::UnrollConstantImpliedDo(
+    const parser::AcImpliedDo &impliedDo, parser::CharBlock name,
+    std::int64_t lower, std::int64_t upper, std::int64_t stride) {
+  auto &foldingContext{exprAnalyzer_.GetFoldingContext()};
+  auto restorer{exprAnalyzer_.DoNotUseSavedTypedExprs()};
+  for (auto &at{foldingContext.StartImpliedDo(name, lower)};
+       (stride > 0 && at <= upper) || (stride < 0 && at >= upper);
+       at += stride) {
+    for (const auto &value :
+        std::get<std::list<parser::AcValue>>(impliedDo.t)) {
+      Add(value);
+    }
+  }
+  foldingContext.EndImpliedDo(name);
 }
 
 MaybeExpr ArrayConstructorContext::ToExpr() {
   return common::SearchTypes(std::move(*this));
 }
 
 MaybeExpr ExpressionAnalyzer::Analyze(const parser::ArrayConstructor &array) {
   const parser::AcSpec &acSpec{array.v};
if (auto *func{
     }
   }
 }
 
 // Common handling of parse tree node types that retain the
 // representation of the analyzed expression.
 template <typename PARSED>
 MaybeExpr ExpressionAnalyzer::ExprOrVariable(const PARSED &x) {
-  if (x.typedExpr) {
+  if (useSavedTypedExprs_ && x.typedExpr) {
     return x.typedExpr->v;
   }
   if constexpr (std::is_same_v<PARSED, parser::Expr> ||
       std::is_same_v<PARSED, parser::Variable>) {
     FixMisparsedFunctionReference(context_, x.u);
   }
   if (AssumedTypeDummy(x)) { // C710
     Say("TYPE(*) dummy argument may only be used as an actual argument"_err_en_US);
   } else if (MaybeExpr result{evaluate::Fold(foldingContext_, Analyze(x.u))}) {
     SetExpr(x, std::move(*result));
     return x.typedExpr->v;
   }
   ResetExpr(x);
   if (!context_.AnyFatalError()) {
     std::string buf;
     llvm::raw_string_ostream dump{buf};
     parser::DumpTree(dump, x);
     Say("Internal error: Expression analysis failed on: %s"_err_en_US,
         dump.str());
   }
-  fatalErrors_ = true;
   return std::nullopt;
 }
 
 MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr &expr) {
   auto restorer{GetContextualMessages().SetLocation(expr.source)};
   return ExprOrVariable(expr);
 }
 

flang/test/Evaluate/folding13.f90

+! RUN: %S/test_folding.sh %s %t %f18
+! Test folding of array constructors with constant implied DO bounds;
+! their indices are constant expressions and can be used as such.
+module m1
+  integer, parameter :: kinds(*) = [1, 2, 4, 8]
+  integer(kind=8), parameter :: clipping(*) = [integer(kind=8) :: &
+    (int(z'100010101', kind=kinds(j)), j=1,4)]
+  integer(kind=8), parameter :: expected(*) = [ &
+    int(z'01',8), int(z'0101',8), int(z'00010101',8), int(z'100010101',8)]
+  logical, parameter :: test_clipping = all(clipping == expected)
+end module

flang/test/Semantics/array-constr-values.f90

subroutine arrayconstructorvalues()
   intarray = (/ base_type(10), 2, 3, 4, 5 /)
 end subroutine arrayconstructorvalues
 subroutine checkC7115()
   real, dimension(10), parameter :: good1 = [(99.9, i = 1, 10)]
   real, dimension(100), parameter :: good2 = [((88.8, i = 1, 10), j = 1, 10)]
   !ERROR: Implied DO index is active in surrounding implied DO loop and may not have the same name
   !ERROR: 'i' is already declared in this scoping unit
   real, dimension(100), parameter :: bad = [((88.8, i = 1, 10), i = 1, 10)]
+
+  !ERROR: The stride of an implied DO loop must not be zero
+  integer, parameter :: bad2(*) = [(j, j=1,1,0)]
 end subroutine checkC7115