[flang] Fix the extent calculation when upper bounds are less than lower bounds

[PeteSteinfeld]

Summary

When the upper bound is less than the lower bound, the extent is zero. This is
specified in section 8.5.8.2, paragraph 3.

Note that similar problems exist in the lowering code. This change only fixes
the problem for the front end.

I also added a test.

[klausler]

flang/lib/Evaluate/shape.cpp

24

This line forward declares a class name that you never define nor use later.

[PeteSteinfeld]

flang/lib/Evaluate/shape.cpp

24

D'oh! Thanks for catching this.

[PeteSteinfeld]

Responding to Peter's comment.

flang/lib/Evaluate/shape.cpp

 #include "flang/Evaluate/type.h"
 #include "flang/Parser/message.h"
 #include "flang/Semantics/symbol.h"
 #include <functional>
 
 using namespace std::placeholders; // _1, _2, &c. for std::bind()
 
 namespace Fortran::evaluate {
 
 bool IsImpliedShape(const Symbol &original) {
   const Symbol &symbol{ResolveAssociations(original)};
   const auto *details{symbol.detailsIf<semantics::ObjectEntityDetails>()};
   return details && symbol.attrs().test(semantics::Attr::PARAMETER) &&
       details->shape().IsImpliedShape();
 }
 
 bool IsExplicitShape(const Symbol &original) {
Shape GetLowerBounds(FoldingContext &context, const NamedEntity &base) {
   Shape result;
   int rank{base.Rank()};
   for (int dim{0}; dim < rank; ++dim) {
     result.emplace_back(GetLowerBound(context, base, dim));
   }
   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<ConstantSubscript> uval{ToInt64(ubound)};
+  std::optional<ConstantSubscript> 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())};
   if (const auto *details{symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
     if (IsImpliedShape(symbol) && details->init()) {
       if (auto shape{GetShape(symbol)}) {
         if (dimension < static_cast<int>(shape->size())) {
           return std::move(shape->at(dimension));
         }
       }
     } else {
       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 (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();
               }
             }
           } else if (details->IsAssumedSize() && j == symbol.Rank()) {
             return std::nullopt;
           } else if (semantics::IsDescriptor(symbol)) {
             return ExtentExpr{DescriptorInquiry{NamedEntity{base},

flang/test/Evaluate/folding21.f90

+! 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