diff --git a/flang/lib/Evaluate/shape.cpp b/flang/lib/Evaluate/shape.cpp --- a/flang/lib/Evaluate/shape.cpp +++ b/flang/lib/Evaluate/shape.cpp @@ -316,6 +316,26 @@ return result; } +// If the upper and lower bounds are constant, return a constant expression for +// the extent. In particular, if the upper bound is less than the lower bound, +// return zero. +static MaybeExtentExpr GetNonNegativeExtent( + const semantics::ShapeSpec &shapeSpec) { + const auto &ubound{shapeSpec.ubound().GetExplicit()}; + const auto &lbound{shapeSpec.lbound().GetExplicit()}; + std::optional uval{ToInt64(ubound)}; + std::optional lval{ToInt64(lbound)}; + if (uval && lval) { + if (*uval < *lval) { + return ExtentExpr{0}; + } else { + return ExtentExpr{*uval - *lval + 1}; + } + } + return common::Clone(ubound.value()) - common::Clone(lbound.value()) + + ExtentExpr{1}; +} + MaybeExtentExpr GetExtent(const NamedEntity &base, int dimension) { CHECK(dimension >= 0); const Symbol &symbol{ResolveAssociations(base.GetLastSymbol())}; @@ -330,11 +350,12 @@ int j{0}; for (const auto &shapeSpec : details->shape()) { if (j++ == dimension) { - if (shapeSpec.ubound().isExplicit()) { - if (const auto &ubound{shapeSpec.ubound().GetExplicit()}) { - if (const auto &lbound{shapeSpec.lbound().GetExplicit()}) { - return common::Clone(ubound.value()) - - common::Clone(lbound.value()) + ExtentExpr{1}; + if (const auto &ubound{shapeSpec.ubound().GetExplicit()}) { + if (shapeSpec.ubound().GetExplicit()) { + // 8.5.8.2, paragraph 3. If the upper bound is less than the + // lower bound, the extent is zero. + if (shapeSpec.lbound().GetExplicit()) { + return GetNonNegativeExtent(shapeSpec); } else { return ubound.value(); } diff --git a/flang/test/Evaluate/folding21.f90 b/flang/test/Evaluate/folding21.f90 new file mode 100644 --- /dev/null +++ b/flang/test/Evaluate/folding21.f90 @@ -0,0 +1,35 @@ +! RUN: %S/test_folding.sh %s %t %flang_fc1 +! REQUIRES: shell +! Check array sizes with varying extents, including extents where the upper +! bound is less than the lower bound +module m + contains + subroutine s1(a,b) + real nada1(-2:-1) ! size = 2 + real nada2(-1:-1) ! size = 1 + real nada3( 0:-1) ! size = 0 + real nada4( 1:-1) ! size = 0 + real nada5( 2:-1) ! size = 0 + real nada6( 3:-1) ! size = 0 + real nada7( 5, 3:-1) ! size = 0 + real nada8( -1) ! size = 0 + + integer, parameter :: size1 = size(nada1) + integer, parameter :: size2 = size(nada2) + integer, parameter :: size3 = size(nada3) + integer, parameter :: size4 = size(nada4) + integer, parameter :: size5 = size(nada5) + integer, parameter :: size6 = size(nada6) + integer, parameter :: size7 = size(nada7) + integer, parameter :: size8 = size(nada8) + + logical, parameter :: test_size_1 = size1 == 2 + logical, parameter :: test_size_2 = size2 == 1 + logical, parameter :: test_size_3 = size3 == 0 + logical, parameter :: test_size_4 = size4 == 0 + logical, parameter :: test_size_5 = size5 == 0 + logical, parameter :: test_size_6 = size6 == 0 + logical, parameter :: test_size_7 = size7 == 0 + logical, parameter :: test_size_8 = size8 == 0 + end subroutine +end module