diff --git a/flang/include/flang/Evaluate/shape.h b/flang/include/flang/Evaluate/shape.h index 3e42ec691158b..f0505cfcdf2d7 100644 --- a/flang/include/flang/Evaluate/shape.h +++ b/flang/include/flang/Evaluate/shape.h @@ -71,6 +71,9 @@ template std::optional GetShape( FoldingContext &, const A &, bool invariantOnly = true); template +std::optional GetShape( + FoldingContext *, const A &, bool invariantOnly = true); +template std::optional GetShape(const A &, bool invariantOnly = true); // The dimension argument to these inquiries is zero-based, @@ -149,6 +152,8 @@ inline MaybeExtentExpr GetSize(const std::optional &maybeShape) { // Utility predicate: does an expression reference any implied DO index? bool ContainsAnyImpliedDoIndex(const ExtentExpr &); +// GetShape() + class GetShapeHelper : public AnyTraverse> { public: @@ -261,23 +266,27 @@ class GetShapeHelper template std::optional GetShape( - FoldingContext &context, const A &x, bool invariantOnly) { - if (auto shape{GetShapeHelper{&context, invariantOnly}(x)}) { - return Fold(context, std::move(shape)); + FoldingContext *context, const A &x, bool invariantOnly) { + if (auto shape{GetShapeHelper{context, invariantOnly}(x)}) { + if (context) { + return Fold(*context, std::move(shape)); + } else { + return shape; + } } else { return std::nullopt; } } template -std::optional GetShape(const A &x, bool invariantOnly) { - return GetShapeHelper{/*context=*/nullptr, invariantOnly}(x); +std::optional GetShape( + FoldingContext &context, const A &x, bool invariantOnly) { + return GetShape(&context, x, invariantOnly); } template -std::optional GetShape( - FoldingContext *context, const A &x, bool invariantOnly = true) { - return GetShapeHelper{context, invariantOnly}(x); +std::optional GetShape(const A &x, bool invariantOnly) { + return GetShape(/*context=*/nullptr, x, invariantOnly); } template diff --git a/flang/lib/Evaluate/shape.cpp b/flang/lib/Evaluate/shape.cpp index 58b824d9b8e64..fa957cfc08495 100644 --- a/flang/lib/Evaluate/shape.cpp +++ b/flang/lib/Evaluate/shape.cpp @@ -16,6 +16,7 @@ #include "flang/Evaluate/tools.h" #include "flang/Evaluate/type.h" #include "flang/Parser/message.h" +#include "flang/Semantics/semantics.h" #include "flang/Semantics/symbol.h" #include @@ -23,6 +24,10 @@ using namespace std::placeholders; // _1, _2, &c. for std::bind() namespace Fortran::evaluate { +FoldingContext &GetFoldingContextFrom(const Symbol &symbol) { + return symbol.owner().context().foldingContext(); +} + bool IsImpliedShape(const Symbol &original) { const Symbol &symbol{ResolveAssociations(original)}; const auto *details{symbol.detailsIf()}; @@ -483,7 +488,7 @@ static MaybeExtentExpr GetAssociatedExtent( const Symbol &symbol, int dimension) { if (const auto *assoc{symbol.detailsIf()}; assoc && !assoc->rank()) { // not SELECT RANK case - if (auto shape{GetShape(assoc->expr())}; + if (auto shape{GetShape(GetFoldingContextFrom(symbol), assoc->expr())}; shape && dimension < static_cast(shape->size())) { if (auto &extent{shape->at(dimension)}; // Don't return a non-constant extent, as the variables that @@ -519,7 +524,8 @@ MaybeExtentExpr GetExtent( } if (const auto *details{symbol.detailsIf()}) { if (IsImpliedShape(symbol) && details->init()) { - if (auto shape{GetShape(symbol, invariantOnly)}) { + if (auto shape{ + GetShape(GetFoldingContextFrom(symbol), symbol, invariantOnly)}) { if (dimension < static_cast(shape->size())) { return std::move(shape->at(dimension)); } @@ -568,7 +574,8 @@ MaybeExtentExpr GetExtent(const Subscript &subscript, const NamedEntity &base, MaybeExtentExpr{triplet.stride()}); }, [&](const IndirectSubscriptIntegerExpr &subs) -> MaybeExtentExpr { - if (auto shape{GetShape(subs.value())}; + if (auto shape{GetShape( + GetFoldingContextFrom(base.GetLastSymbol()), subs.value())}; shape && GetRank(*shape) == 1) { // vector-valued subscript return std::move(shape->at(0)); diff --git a/flang/test/Evaluate/bug124191.f90 b/flang/test/Evaluate/bug124191.f90 new file mode 100644 index 0000000000000..27d08032efa2f --- /dev/null +++ b/flang/test/Evaluate/bug124191.f90 @@ -0,0 +1,6 @@ +! RUN: %flang_fc1 -fsyntax-only -pedantic %s 2>&1 | FileCheck --allow-empty %s +! CHECK-NOT: error: +! Regression test for https://github.com/llvm/llvm-project/issues/124191 +character(3) :: arr(5) = ['aa.', 'bb.', 'cc.', 'dd.', 'ee.'] +arr([(mod(iachar(arr(i:i-1:-1)(1:1)),5)+1, i=2,5,3)]) = arr(5:2:-1) +end