[flang] Correct handling of non-default lower bounds in ASSOCIATE wit…

…h named constants

Work through several issues with LBOUND() and UBOUND() of ASSOCIATE
construct entities that have been associated with named constants or
subobjects of named constants that are sporting non-default lower bounds.
Sometimes the non-default lower bounds matter, sometimes they don't.
Add a fairly exhaustive test to work through the possibilities.

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

flang/include/flang/Evaluate/constant.h

@@ -63,12 +63,23 @@ class ConstantBounds {
   explicit ConstantBounds(ConstantSubscripts &&shape);
   ~ConstantBounds();
   const ConstantSubscripts &shape() const { return shape_; }
+  int Rank() const { return GetRank(shape_); }
+  Constant<SubscriptInteger> SHAPE() const;
+
+  // It is possible in this representation for a constant array to have
+  // lower bounds other than 1, which is of course not expressible in
+  // Fortran.  This case arises only from definitions of named constant
+  // arrays with such bounds, as in:
+  //   REAL, PARAMETER :: NAMED(0:1) = [1.,2.]
+  // Bundling the lower bounds of the named constant with its
+  // constant value allows folding of subscripted array element
+  // references, LBOUND, and UBOUND without having to thread the named
+  // constant or its bounds throughout folding.
   const ConstantSubscripts &lbounds() const { return lbounds_; }
   ConstantSubscripts ComputeUbounds(std::optional<int> dim) const;
   void set_lbounds(ConstantSubscripts &&);
   void SetLowerBoundsToOne();
-  int Rank() const { return GetRank(shape_); }
-  Constant<SubscriptInteger> SHAPE() const;
+  bool HasNonDefaultLowerBound() const;
 
   // If no optional dimension order argument is passed, increments a vector of
   // subscripts in Fortran array order (first dimension varying most quickly).

flang/lib/Evaluate/constant.cpp

@@ -56,6 +56,15 @@ Constant<SubscriptInteger> ConstantBounds::SHAPE() const {
   return AsConstantShape(shape_);
 }
 
+bool ConstantBounds::HasNonDefaultLowerBound() const {
+  for (auto n : lbounds_) {
+    if (n != 1) {
+      return true;
+    }
+  }
+  return false;
+}
+
 ConstantSubscript ConstantBounds::SubscriptsToOffset(
     const ConstantSubscripts &index) const {
   CHECK(GetRank(index) == GetRank(shape_));

flang/lib/Evaluate/fold-implementation.h

@@ -255,11 +255,11 @@ std::optional<Constant<T>> Folder<T>::ApplyComponent(
     const std::vector<Constant<SubscriptInteger>> *subscripts) {
   if (auto scalar{structures.GetScalarValue()}) {
     if (std::optional<Expr<SomeType>> expr{scalar->Find(component)}) {
-      if (const Constant<T> *value{UnwrapConstantValue<T>(expr.value())}) {
-        if (!subscripts) {
-          return std::move(*value);
-        } else {
+      if (const Constant<T> *value{UnwrapConstantValue<T>(*expr)}) {
+        if (subscripts) {
           return ApplySubscripts(*value, *subscripts);
+        } else {
+          return *value;
         }
       }
     }

flang/lib/Evaluate/fold-integer.cpp

@@ -126,7 +126,7 @@ class GetConstantArrayBoundHelper {
   }
 
   template <typename T> ConstantSubscripts Get(const Parentheses<T> &x) {
-    // Cause of temp variable inside parentheses - return [1, ... 1] for lower
+    // Case of temp variable inside parentheses - return [1, ... 1] for lower
     // bounds and shape for upper bounds
     if (getLbound_) {
       return ConstantSubscripts(x.Rank(), ConstantSubscript{1});

flang/lib/Evaluate/formatting.cpp

@@ -19,23 +19,35 @@
 
 namespace Fortran::evaluate {
 
-static void ShapeAsFortran(
-    llvm::raw_ostream &o, const ConstantSubscripts &shape) {
-  if (GetRank(shape) > 1) {
+static void ShapeAsFortran(llvm::raw_ostream &o,
+    const ConstantSubscripts &shape, const ConstantSubscripts &lbounds,
+    bool hasNonDefaultLowerBound) {
+  if (GetRank(shape) > 1 || hasNonDefaultLowerBound) {
     o << ",shape=";
     char ch{'['};
     for (auto dim : shape) {
       o << ch << dim;
       ch = ',';
     }
-    o << "])";
+    o << ']';
+    if (hasNonDefaultLowerBound) {
+      o << ",%lbound=";
+      ch = '[';
+      for (auto lb : lbounds) {
+        o << ch << lb;
+        ch = ',';
+      }
+      o << ']';
+    }
+    o << ')';
   }
 }
 
 template <typename RESULT, typename VALUE>
 llvm::raw_ostream &ConstantBase<RESULT, VALUE>::AsFortran(
     llvm::raw_ostream &o) const {
-  if (Rank() > 1) {
+  bool hasNonDefaultLowerBound{HasNonDefaultLowerBound()};
+  if (Rank() > 1 || hasNonDefaultLowerBound) {
     o << "reshape(";
   }
   if (Rank() > 0) {
@@ -71,14 +83,15 @@ llvm::raw_ostream &ConstantBase<RESULT, VALUE>::AsFortran(
   if (Rank() > 0) {
     o << ']';
   }
-  ShapeAsFortran(o, shape());
+  ShapeAsFortran(o, shape(), lbounds(), hasNonDefaultLowerBound);
   return o;
 }
 
 template <int KIND>
 llvm::raw_ostream &Constant<Type<TypeCategory::Character, KIND>>::AsFortran(
     llvm::raw_ostream &o) const {
-  if (Rank() > 1) {
+  bool hasNonDefaultLowerBound{HasNonDefaultLowerBound()};
+  if (Rank() > 1 || hasNonDefaultLowerBound) {
     o << "reshape(";
   }
   if (Rank() > 0) {
@@ -98,7 +111,7 @@ llvm::raw_ostream &Constant<Type<TypeCategory::Character, KIND>>::AsFortran(
   if (Rank() > 0) {
     o << ']';
   }
-  ShapeAsFortran(o, shape());
+  ShapeAsFortran(o, shape(), lbounds(), hasNonDefaultLowerBound);
   return o;
 }
 

flang/lib/Evaluate/shape.cpp

@@ -314,7 +314,7 @@ class GetLowerBoundHelper
               DescriptorInquiry::Field::LowerBound, dimension_}};
         }
       } else {
-        auto exprLowerBound{((*this)(assoc->expr()))};
+        Result exprLowerBound{((*this)(assoc->expr()))};
         if (IsActuallyConstant(exprLowerBound)) {
           return std::move(exprLowerBound);
         } else {
@@ -334,8 +334,8 @@ class GetLowerBoundHelper
     }
   }
 
-  Result operator()(const Symbol &symbol0) const {
-    return GetLowerBound(symbol0, NamedEntity{symbol0});
+  Result operator()(const Symbol &symbol) const {
+    return GetLowerBound(symbol, NamedEntity{symbol});
   }
 
   Result operator()(const Component &component) const {
@@ -346,8 +346,30 @@ class GetLowerBoundHelper
     return Result{1};
   }
 
+  template <typename T> Result operator()(const Expr<T> &expr) const {
+    if (const Symbol * whole{UnwrapWholeSymbolOrComponentDataRef(expr)}) {
+      return (*this)(*whole);
+    } else if constexpr (common::HasMember<Constant<T>, decltype(expr.u)>) {
+      if (const auto *con{std::get_if<Constant<T>>(&expr.u)}) {
+        ConstantSubscripts lb{con->lbounds()};
+        if (dimension_ < GetRank(lb)) {
+          return Result{lb[dimension_]};
+        }
+      } else { // operation
+        return Result{1};
+      }
+    } else {
+      return (*this)(expr.u);
+    }
+    if constexpr (LBOUND_SEMANTICS) {
+      return Result{};
+    } else {
+      return Result{1};
+    }
+  }
+
 private:
-  int dimension_;
+  int dimension_; // zero-based
   FoldingContext *context_{nullptr};
 };
 
@@ -618,16 +640,27 @@ static MaybeExtentExpr GetUBOUND(
       if (auto ubound{GetExplicitUBOUND(context, shapeSpec)}) {
         return *ubound;
       } else if (details->IsAssumedSize() && dimension + 1 == symbol.Rank()) {
-        return std::nullopt;
+        return std::nullopt; // UBOUND() folding replaces with -1
       } else if (auto lb{GetLBOUND(base, dimension)}) {
         return ComputeUpperBound(std::move(*lb), GetExtent(base, dimension));
       }
     }
   } else if (const auto *assoc{
                  symbol.detailsIf<semantics::AssocEntityDetails>()}) {
-    if (auto extent{GetAssociatedExtent(base, *assoc, dimension)}) {
-      if (auto lb{GetLBOUND(base, dimension)}) {
-        return ComputeUpperBound(std::move(*lb), std::move(extent));
+    if (assoc->rank()) { // SELECT RANK case
+      const Symbol &resolved{ResolveAssociations(symbol)};
+      if (IsDescriptor(resolved) && dimension < *assoc->rank()) {
+        ExtentExpr lb{DescriptorInquiry{NamedEntity{base},
+            DescriptorInquiry::Field::LowerBound, dimension}};
+        ExtentExpr extent{DescriptorInquiry{
+            std::move(base), DescriptorInquiry::Field::Extent, dimension}};
+        return ComputeUpperBound(std::move(lb), std::move(extent));
+      }
+    } else if (assoc->expr()) {
+      if (auto extent{GetAssociatedExtent(base, *assoc, dimension)}) {
+        if (auto lb{GetLBOUND(base, dimension)}) {
+          return ComputeUpperBound(std::move(*lb), std::move(extent));
+        }
       }
     }
   }
@@ -644,29 +677,12 @@ MaybeExtentExpr GetUBOUND(
 }
 
 static Shape GetUBOUNDs(FoldingContext *context, const NamedEntity &base) {
-  const Symbol &symbol{
-      ResolveAssociationsExceptSelectRank(base.GetLastSymbol())};
-  if (const auto *details{symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
-    Shape result;
-    int dim{0};
-    for (const auto &shapeSpec : details->shape()) {
-      if (auto ubound{GetExplicitUBOUND(context, shapeSpec)}) {
-        result.emplace_back(*ubound);
-      } else if (details->IsAssumedSize() && dim + 1 == base.Rank()) {
-        result.emplace_back(std::nullopt); // UBOUND folding replaces with -1
-      } else if (auto lb{GetLBOUND(base, dim)}) {
-        result.emplace_back(
-            ComputeUpperBound(std::move(*lb), GetExtent(base, dim)));
-      } else {
-        result.emplace_back(); // unknown
-      }
-      ++dim;
-    }
-    CHECK(GetRank(result) == symbol.Rank());
-    return result;
-  } else {
-    return std::move(GetShape(symbol).value());
+  Shape result;
+  int rank{base.Rank()};
+  for (int dim{0}; dim < rank; ++dim) {
+    result.emplace_back(GetUBOUND(context, base, dim));
   }
+  return result;
 }
 
 Shape GetUBOUNDs(FoldingContext &context, const NamedEntity &base) {

flang/lib/Semantics/expression.cpp

@@ -311,9 +311,10 @@ MaybeExpr ExpressionAnalyzer::ApplySubscripts(
 
 void ExpressionAnalyzer::CheckConstantSubscripts(ArrayRef &ref) {
   // Fold subscript expressions and check for an empty triplet.
-  Shape lb{GetLBOUNDs(foldingContext_, ref.base())};
+  const Symbol &arraySymbol{ref.base().GetLastSymbol()};
+  Shape lb{GetLBOUNDs(foldingContext_, NamedEntity{arraySymbol})};
   CHECK(lb.size() >= ref.subscript().size());
-  Shape ub{GetUBOUNDs(foldingContext_, ref.base())};
+  Shape ub{GetUBOUNDs(foldingContext_, NamedEntity{arraySymbol})};
   CHECK(ub.size() >= ref.subscript().size());
   bool anyPossiblyEmptyDim{false};
   int dim{0};

flang/lib/Semantics/resolve-names.cpp

@@ -8599,8 +8599,7 @@ void ResolveNamesVisitor::FinishDerivedTypeInstantiation(Scope &scope) {
             auto origDetails{origComp.get<ObjectEntityDetails>()};
             if (const MaybeExpr & init{origDetails.init()}) {
               SomeExpr newInit{*init};
-              MaybeExpr folded{
-                  evaluate::Fold(foldingContext, std::move(newInit))};
+              MaybeExpr folded{FoldExpr(std::move(newInit))};
               details->set_init(std::move(folded));
             }
           }

flang/test/Lower/HLFIR/constant.f90

@@ -42,11 +42,11 @@ subroutine test_constant_array_char()
 subroutine test_constant_with_lower_bounds()
   integer, parameter :: i(-1:0, -1:0) = reshape([1,2,3,4], shape=[2,2])
   print *, i
-! CHECK:  %[[VAL_12:.*]] = fir.address_of(@_QQro[[name:.*]]) : !fir.ref<!fir.array<2x2xi32>>
-! CHECK:  %[[VAL_13:.*]] = arith.constant 2 : index
+! CHECK:  %[[VAL_12:.*]] = fir.address_of(@_QFtest_constant_with_lower_boundsECi) : !fir.ref<!fir.array<2x2xi32>>
+! CHECK:  %[[VAL_13:.*]] = arith.constant -1 : index
 ! CHECK:  %[[VAL_14:.*]] = arith.constant 2 : index
 ! CHECK:  %[[VAL_15:.*]] = arith.constant -1 : index
-! CHECK:  %[[VAL_16:.*]] = arith.constant -1 : index
-! CHECK:  %[[VAL_17:.*]] = fir.shape_shift %[[VAL_15]], %[[VAL_13]], %[[VAL_16]], %[[VAL_14]] : (index, index, index, index) -> !fir.shapeshift<2>
-! CHECK:  hlfir.declare %[[VAL_12]](%[[VAL_17]]) {fortran_attrs = #fir.var_attrs<parameter>, uniq_name = "_QQro[[name]]"} : (!fir.ref<!fir.array<2x2xi32>>, !fir.shapeshift<2>) -> (!fir.box<!fir.array<2x2xi32>>, !fir.ref<!fir.array<2x2xi32>>)
+! CHECK:  %[[VAL_16:.*]] = arith.constant 2 : index
+! CHECK:  %[[VAL_17:.*]] = fir.shape_shift %[[VAL_13]], %[[VAL_14]], %[[VAL_15]], %[[VAL_16]] : (index, index, index, index) -> !fir.shapeshift<2>
+! CHECK:  hlfir.declare %[[VAL_12]](%[[VAL_17]]) {fortran_attrs = #fir.var_attrs<parameter>, uniq_name = "_QFtest_constant_with_lower_boundsECi"} : (!fir.ref<!fir.array<2x2xi32>>, !fir.shapeshift<2>) -> (!fir.box<!fir.array<2x2xi32>>, !fir.ref<!fir.array<2x2xi32>>)
 end subroutine

flang/test/Semantics/associate02.f90

@@ -0,0 +1,78 @@
+! RUN: %flang_fc1 -fdebug-unparse  %s  2>&1 | FileCheck %s
+! Sometimes associations with named constants involving non-default
+! lower bounds expose those bounds to LBOUND()/UBOUND(), sometimes
+! they do not.
+subroutine s(n)
+  integer, intent(in) :: n
+  type t
+    real component(0:1,2:3)
+  end type
+  real, parameter :: abcd(2,2) = reshape([1.,2.,3.,4.], shape(abcd))
+  real, parameter :: namedConst1(-1:0,-2:-1) = abcd
+  type(t), parameter :: namedConst2 = t(abcd)
+  type(t), parameter :: namedConst3(2:3,3:4) = reshape([(namedConst2,j=1,size(namedConst3))], shape(namedConst3))
+!CHECK: PRINT *, [INTEGER(4)::1_4,1_4], [INTEGER(4)::2_4,2_4], [INTEGER(4)::2_4,2_4]
+  print *, lbound(abcd), ubound(abcd), shape(abcd)
+!CHECK: PRINT *, [INTEGER(4)::-1_4,-2_4], [INTEGER(4)::0_4,-1_4], [INTEGER(4)::2_4,2_4]
+  print *, lbound(namedConst1), ubound(namedConst1), shape(namedConst1)
+!CHECK: PRINT *, [INTEGER(4)::0_4,2_4], [INTEGER(4)::1_4,3_4], [INTEGER(4)::2_4,2_4]
+  print *, lbound(namedConst2%component), ubound(namedConst2%component), shape(namedConst2%component)
+!CHECK: PRINT *, [INTEGER(4)::2_4,3_4], [INTEGER(4)::3_4,4_4], [INTEGER(4)::2_4,2_4]
+  print *, lbound(namedConst3), ubound(namedConst3), shape(namedConst3)
+!CHECK: PRINT *, [INTEGER(4)::0_4,2_4], [INTEGER(4)::1_4,3_4], [INTEGER(4)::2_4,2_4]
+  print *, lbound(namedConst3(n,n)%component), ubound(namedConst3(n,n)%component), shape(namedConst3(n,n)%component)
+!CHECK: PRINT *, [INTEGER(4)::1_4,1_4], [INTEGER(4)::2_4,2_4], [INTEGER(4)::2_4,2_4]
+  print *, lbound(namedConst3%component(0,2)), ubound(namedConst3%component(0,2)), shape(namedConst3%component(0,2))
+  associate (a => abcd)
+!CHECK:  PRINT *, [INTEGER(4)::1_4,1_4], [INTEGER(4)::2_4,2_4], [INTEGER(4)::2_4,2_4]
+    print *, lbound(a), ubound(a), shape(a)
+  end associate
+  associate (a => namedConst1)
+!CHECK:  PRINT *, [INTEGER(4)::-1_4,-2_4], [INTEGER(4)::0_4,-1_4], [INTEGER(4)::2_4,2_4]
+    print *, lbound(a), ubound(a), shape(a)
+  end associate
+  associate (a => (namedConst1))
+!CHECK:  PRINT *, [INTEGER(4)::1_4,1_4], [INTEGER(4)::2_4,2_4], [INTEGER(4)::2_4,2_4]
+    print *, lbound(a), ubound(a), shape(a)
+  end associate
+  associate (a => namedConst1 * 2.)
+!CHECK:  PRINT *, [INTEGER(4)::1_4,1_4], [INTEGER(4)::2_4,2_4], [INTEGER(4)::2_4,2_4]
+    print *, lbound(a), ubound(a), shape(a)
+  end associate
+  associate (a => namedConst2%component)
+!CHECK:  PRINT *, [INTEGER(4)::0_4,2_4], [INTEGER(4)::1_4,3_4], [INTEGER(4)::2_4,2_4]
+    print *, lbound(a), ubound(a), shape(a)
+  end associate
+  associate (a => (namedConst2%component))
+!CHECK:  PRINT *, [INTEGER(4)::1_4,1_4], [INTEGER(4)::2_4,2_4], [INTEGER(4)::2_4,2_4]
+    print *, lbound(a), ubound(a), shape(a)
+  end associate
+  associate (a => namedConst2%component * 2.)
+!CHECK:  PRINT *, [INTEGER(4)::1_4,1_4], [INTEGER(4)::2_4,2_4], [INTEGER(4)::2_4,2_4]
+    print *, lbound(a), ubound(a), shape(a)
+  end associate
+  associate (a => namedConst3)
+!CHECK:  PRINT *, [INTEGER(4)::2_4,3_4], [INTEGER(4)::3_4,4_4], [INTEGER(4)::2_4,2_4]
+    print *, lbound(a), ubound(a), shape(a)
+  end associate
+  associate (a => (namedConst3))
+!CHECK:  PRINT *, [INTEGER(4)::1_4,1_4], [INTEGER(4)::2_4,2_4], [INTEGER(4)::2_4,2_4]
+    print *, lbound(a), ubound(a), shape(a)
+  end associate
+  associate (a => namedConst3(n,n)%component)
+!CHECK:  PRINT *, [INTEGER(4)::0_4,2_4], [INTEGER(4)::1_4,3_4], [INTEGER(4)::2_4,2_4]
+    print *, lbound(a), ubound(a), shape(a)
+  end associate
+  associate (a => (namedConst3(n,n)%component))
+!CHECK:  PRINT *, [INTEGER(4)::1_4,1_4], [INTEGER(4)::2_4,2_4], [INTEGER(4)::2_4,2_4]
+    print *, lbound(a), ubound(a), shape(a)
+  end associate
+  associate (a => namedConst3(n,n)%component * 2.)
+!CHECK:  PRINT *, [INTEGER(4)::1_4,1_4], [INTEGER(4)::2_4,2_4], [INTEGER(4)::2_4,2_4]
+    print *, lbound(a), ubound(a), shape(a)
+  end associate
+  associate (a => namedConst3%component(0,2))
+!CHECK: PRINT *, [INTEGER(4)::1_4,1_4], [INTEGER(4)::2_4,2_4], [INTEGER(4)::2_4,2_4]
+    print *, lbound(a), ubound(a), shape(a)
+  end associate
+end