[flang] Fix problems with constant arrays with lower bounds that are not 1

[PeteSteinfeld]

Summary

There were two problems with constant arrays whose lower bound is not 1.
First, when folding the arrays, we were creating the folded array to have lower
bounds of 1 but not re-adjusting their lower bounds to the declared values.
Second, we were not calculating the extents correctly. Both of these problems
led to bogus error messages.

I fixed the first problem by adjusting the lower bounds in
NonPointerInitializationExpr() in Evaluate/check-expression.cpp. I found an
existing class and method that did exactly what was needed that was originally
designed to expand a scalar value into an array called ScalarConstantExpander.
I renamed this class to reflect its generalization to ArrayConstantMaker.

I fixed the second problem by changing the formula that calculates upper bounds
in in the function ComputeUpperBound() in Evaluate/shape.cpp.

I added tests that trigger the bogus error messages mentioned above along with
a constant folding tests that uses array operands with shapes that conform but
have different bounds.

[klausler]

Can you fix the problem by just calling "x.set_lbounds(GetLowerBounds())" on the folded result array and leaving ScalarConstantExpander alone?

[PeteSteinfeld]

In D95449#2523153, @klausler wrote:

Can you fix the problem by just calling "x.set_lbounds(GetLowerBounds())" on the folded result array and leaving ScalarConstantExpander alone?

The expression that needs to have its lower bounds modified is of type Expr<SomeType>. But the set_lbounds() method is defined for the types Constant<T>, ConstantBase<T>, and ConstantBounds<T>. So to use set_lbounds(), I need to walk down through the layers of Expr<> objects to get to an object of type Constant<T> and then call set_lbounds() on it.

So I could create a class to do this, but that class would be very similar to the exiting class that I've renamed as ArrayConstantMaker. Potential differences would be that it might not require a method that takes Parenthese<T> as an arugment (I'm not sure about this), the call to Reshape() would not be required, and the new class would need fewer constructors.

Thus, it seems to me that it's better to use a single class to create constant arrays with new lower bounds that handles both scalars and arrays.

Let me know if my analysis is wrong, or if you agree with my analysis but not me conclusion.

[klausler]

In D95449#2524183, @PeteSteinfeld wrote:

In D95449#2523153, @klausler wrote:

Can you fix the problem by just calling "x.set_lbounds(GetLowerBounds())" on the folded result array and leaving ScalarConstantExpander alone?

The expression that needs to have its lower bounds modified is of type Expr<SomeType>. But the set_lbounds() method is defined for the types Constant<T>, ConstantBase<T>, and ConstantBounds<T>. So to use set_lbounds(), I need to walk down through the layers of Expr<> objects to get to an object of type Constant<T> and then call set_lbounds() on it.

So I could create a class to do this, but that class would be very similar to the exiting class that I've renamed as ArrayConstantMaker. Potential differences would be that it might not require a method that takes Parenthese<T> as an arugment (I'm not sure about this), the call to Reshape() would not be required, and the new class would need fewer constructors.

Thus, it seems to me that it's better to use a single class to create constant arrays with new lower bounds that handles both scalars and arrays.

Let me know if my analysis is wrong, or if you agree with my analysis but not me conclusion.

I think I'd rather have two specifically purposed facilities for scalar expansion and for setting lower bounds than one mash-up of those two. If you must combine them, make sure that there's a CHECK that ensures that the original array is either scalar or has exactly the same shape.

[PeteSteinfeld]

I implemented a separate class to handle changing the lower bounds of array
constants as suggested by Peter. In the process I noticed that there was an
unused class in Evaluate/check-expression.cpp. Also, when implementing the new
class I found a bug when handling parenthesized expressions which also exists
in the class I was previously using, so I fixed it in both places. I also
added new tests that include parenthesized expressions.

[tskeith]

flang/lib/Evaluate/check-expression.cpp

320

I think this needs to be return std::move(x);

[PeteSteinfeld]

flang/lib/Evaluate/check-expression.cpp

320

Thanks, Tim. I'll change it.

[tskeith]

flang/lib/Evaluate/check-expression.cpp

312

Since lbounds has to be a non-empty optional, why make it optional at all? I.e. why not declare it as ConstantSubscripts &&lbounds?

[PeteSteinfeld]

flang/lib/Evaluate/check-expression.cpp

312

Thanks, Tim. Will do.

[PeteSteinfeld]

Changes in response to comments by Tim. Basically, better handling with
respect to moving data around by using rvalue references and eliminating
unnecessary use of the type "std::optional<>".

[tskeith]

flang/test/Evaluate/folding16.f90

4

I think you should be able to add this line to check the lower bound of c:
logical, parameter :: test_c = lbound(c, 1) == -1

But when I tried that it failed. (It's possible I don't understand these folding tests.)

[PeteSteinfeld]

flang/test/Evaluate/folding16.f90

4

Good catch! This test already has tests that test for the lower bound of arrays where the lower bound was negative, and the test was not reporting failure. It turns out, though, that the test itself was erroneous because the test script only checks for constants that begin with "test_". I will fix the test and the underlying bug.

I checked the other tests in this directory, and folding09.f90 has the same problem. Stay tuned for another change.

[PeteSteinfeld]

flang/test/Evaluate/folding16.f90

4

@tskeith, I've investigated this, and your test reveals two bugs, one with our tests and the other with constant folding of the intrinsic "lbound". Neither is related to the other changes in this commit, though.

So my plan is to merge this change request (almost) as is and then fix these other two bugs in a separate change. The one change I'll make is to the test folding16.f90 to enable the new tests I've added. Let me know if you think that's a bad idea.

[tskeith]

flang/test/Evaluate/folding16.f90

4

Sounds good to me.

[PeteSteinfeld]

Responsed to comments from Tim.

Tim noticed that constant folding for the intrinsic "lbounds" wasn't working,
even though we had a test for it which was passing. This revealed a problem in
our tests that I fixed. I'll fix the constant folding problem in a later
change.

flang/include/flang/Evaluate/tools.h

public:
   }
   template <typename T> Constant<T> Expand(Constant<T> &&x) {
     auto expanded{x.Reshape(std::move(extents_))};
     if (lbounds_) {
       expanded.set_lbounds(std::move(*lbounds_));
     }
     return expanded;
   }
-  template <typename T> Constant<T> Expand(Parentheses<T> &&x) {
-    return Expand(std::move(x)); // Constant<> can be parenthesized
+  template <typename T> Expr<T> Expand(Parentheses<T> &&x) {
+    return Expand(std::move(x.left())); // Constant<> can be parenthesized
   }
   template <typename T> Expr<T> Expand(Expr<T> &&x) {
     return std::visit([&](auto &&x) { return Expr<T>{Expand(std::move(x))}; },
         std::move(x.u));
   }
 
 private:
   ConstantSubscripts extents_;

flang/lib/Evaluate/check-expression.cpp

 bool IsInitialProcedureTarget(const Expr<SomeType> &expr) {
   if (const auto *proc{std::get_if<ProcedureDesignator>(&expr.u)}) {
     return IsInitialProcedureTarget(*proc);
   } else {
     return IsNullPointer(expr);
   }
 }
 
-class ScalarExpansionVisitor : public AnyTraverse<ScalarExpansionVisitor,
-                                   std::optional<Expr<SomeType>>> {
+class ArrayConstantBoundChanger {
 public:
-  using Result = std::optional<Expr<SomeType>>;
-  using Base = AnyTraverse<ScalarExpansionVisitor, Result>;
-  ScalarExpansionVisitor(
-      ConstantSubscripts &&shape, std::optional<ConstantSubscripts> &&lb)
-      : Base{*this}, shape_{std::move(shape)}, lbounds_{std::move(lb)} {}
-  using Base::operator();
-  template <typename T> Result operator()(const Constant<T> &x) {
-    auto expanded{x.Reshape(std::move(shape_))};
-    if (lbounds_) {
-      expanded.set_lbounds(std::move(*lbounds_));
-    }
-    return AsGenericExpr(std::move(expanded));
+  ArrayConstantBoundChanger(ConstantSubscripts &&lbounds)
+      : lbounds_{std::move(lbounds)} {}
+
+  template <typename A> A ChangeLbounds(A &&x) const {
+    return std::move(x); // default case
+  template <typename T> Constant<T> ChangeLbounds(Constant<T> &&x) {
+    x.set_lbounds(std::move(lbounds_));
+    return std::move(x);
+  }
+  template <typename T> Expr<T> ChangeLbounds(Parentheses<T> &&x) {
+    return ChangeLbounds(
+        std::move(x.left())); // Constant<> can be parenthesized
+  }
+  template <typename T> Expr<T> ChangeLbounds(Expr<T> &&x) {
+    return std::visit(
+        [&](auto &&x) { return Expr<T>{ChangeLbounds(std::move(x))}; },
+        std::move(x.u)); // recurse until we hit a constant
   }
 
 private:
-  ConstantSubscripts shape_;
-  std::optional<ConstantSubscripts> lbounds_;
+  ConstantSubscripts &&lbounds_;
 };
 
 // Converts, folds, and then checks type, rank, and shape of an
 // initialization expression for a named constant, a non-pointer
 // variable static initializatio, a component default initializer,
 // a type parameter default value, or instantiated type parameter value.
 std::optional<Expr<SomeType>> NonPointerInitializationExpr(const Symbol &symbol,
     Expr<SomeType> &&x, FoldingContext &context,
if (auto converted{ConvertToType(symTS->type(), std::move(x))}) {
           if (folded.Rank() == symRank) {
             return {std::move(folded)};
           } else {
             context.messages().Say(
                 "Implied-shape parameter '%s' has rank %d but its initializer has rank %d"_err_en_US,
                 symbol.name(), symRank, folded.Rank());
           }
         } else if (auto extents{AsConstantExtents(context, symTS->shape())}) {
-          if (folded.Rank() == 0 && symRank > 0) {
+          if (folded.Rank() == 0 && symRank == 0) {
+            // symbol and constant are both scalars
+            return {std::move(folded)};
+          } else if (folded.Rank() == 0 && symRank > 0) {
+            // expand the scalar constant to an array
             return ScalarConstantExpander{std::move(*extents),
                 AsConstantExtents(
                     context, GetLowerBounds(context, NamedEntity{symbol}))}
                 .Expand(std::move(folded));
           } else if (auto resultShape{GetShape(context, folded)}) {
             if (CheckConformance(context.messages(), symTS->shape(),
                     *resultShape, "initialized object",
                     "initialization expression", false, false)) {
-              return {std::move(folded)};
+              // make a constant array with adjusted lower bounds
+              return ArrayConstantBoundChanger{
+                  std::move(*AsConstantExtents(
+                      context, GetLowerBounds(context, NamedEntity{symbol})))}
+                  .ChangeLbounds(std::move(folded));
             }
           }
         } else if (IsNamedConstant(symbol)) {
           if (IsExplicitShape(symbol)) {
             context.messages().Say(
                 "Named constant '%s' array must have constant shape"_err_en_US,
                 symbol.name());
           } else {

flang/lib/Evaluate/shape.cpp

 MaybeExtentExpr GetExtent(FoldingContext &context, const Subscript &subscript,
     const NamedEntity &base, int dimension) {
   return Fold(context, GetExtent(subscript, base, dimension));
 }
 
 MaybeExtentExpr ComputeUpperBound(
     ExtentExpr &&lower, MaybeExtentExpr &&extent) {
   if (extent) {
-    return std::move(*extent) - std::move(lower) + ExtentExpr{1};
+    return std::move(*extent) + std::move(lower) - ExtentExpr{1};
   } else {
     return std::nullopt;
   }
 }
 
 MaybeExtentExpr ComputeUpperBound(
     FoldingContext &context, ExtentExpr &&lower, MaybeExtentExpr &&extent) {
   return Fold(context, ComputeUpperBound(std::move(lower), std::move(extent)));

flang/test/Evaluate/folding09.f90

 ! RUN: %S/test_folding.sh %s %t %f18
 ! Test folding of IS_CONTIGUOUS on simply contiguous items (9.5.4)
 ! When IS_CONTIGUOUS() is constant, it's .TRUE.
 
 module m
   real, target :: hosted(2)
  contains
   function f()
     real, pointer, contiguous :: f(:)
     f => hosted
   end function
   subroutine test(arr1, arr2, arr3, mat)
     real, intent(in) :: arr1(:), arr2(10), mat(10, 10)
     real, intent(in), contiguous :: arr3(:)
     real :: scalar
-    logical, parameter :: isc01 = is_contiguous(0)
-    logical, parameter :: isc02 = is_contiguous(scalar)
-    logical, parameter :: isc03 = is_contiguous(scalar + scalar)
-    logical, parameter :: isc04 = is_contiguous([0, 1, 2])
-    logical, parameter :: isc05 = is_contiguous(arr1 + 1.0)
-    logical, parameter :: isc06 = is_contiguous(arr2)
-    logical, parameter :: isc07 = is_contiguous(mat)
-    logical, parameter :: isc08 = is_contiguous(mat(1:10,1))
-    logical, parameter :: isc09 = is_contiguous(arr2(1:10:1))
-    logical, parameter :: isc10 = is_contiguous(arr3)
-    logical, parameter :: isc11 = is_contiguous(f())
+    logical, parameter :: test_isc01 = is_contiguous(0)
+    logical, parameter :: test_isc02 = is_contiguous(scalar)
+    logical, parameter :: test_isc03 = is_contiguous(scalar + scalar)
+    logical, parameter :: test_isc04 = is_contiguous([0, 1, 2])
+    logical, parameter :: test_isc05 = is_contiguous(arr1 + 1.0)
+    logical, parameter :: test_isc06 = is_contiguous(arr2)
+    logical, parameter :: test_isc07 = is_contiguous(mat)
+    logical, parameter :: test_isc08 = is_contiguous(mat(1:10,1))
+    logical, parameter :: test_isc09 = is_contiguous(arr2(1:10:1))
+    logical, parameter :: test_isc10 = is_contiguous(arr3)
+    logical, parameter :: test_isc11 = is_contiguous(f())
   end subroutine
 end module

flang/test/Evaluate/folding16.f90

 ! RUN: %S/test_folding.sh %s %t %f18
 ! Ensure that lower bounds are accounted for in intrinsic folding;
 ! this is a regression test for a bug in which they were not
+module m
   real, parameter :: a(-1:-1) = 1.
   real, parameter :: b(-1:-1) = log(a)
-logical, parameter :: test = lbound(a,1)==-1 .and. lbound(b,1)==-1 .and. &
-                             lbound(log(a),1)==1 .and. all(b==0)
+  integer, parameter :: c(-1:1) = [33, 22, 11]
+  integer, parameter :: d(1:3) = [33, 22, 11]
+  integer, parameter :: e(-2:0) = ([33, 22, 11])
+  ! The following test is commented out because constant folding for "lbound"
+  ! is currently broken
+  !logical, parameter :: test_1 = lbound(a,1)==-1 .and. lbound(b,1)==-1 .and. &
+  !                             lbound(log(a),1)==1 .and. all(b==0)
+  logical, parameter :: test_2 = all(c .eq. d)
+  logical, parameter :: test_3 = all(c .eq. e)
+  logical, parameter :: test_4 = all(d .eq. e)
 end

flang/test/Evaluate/test_folding.sh

 #!/usr/bin/env bash
 # This script verifies expression folding.
 # It compiles a source file with '-fdebug-dump-symbols' and looks for
 # parameter declarations to check they have been folded as expected.
 # To check folding of an expression EXPR, the fortran program passed to this script
 # must contain the following:
 #   logical, parameter :: test_x = <compare EXPR to expected value>
-# This script will test that all parameter with a name starting with "test_" have
-# been folded to .true.
+# This script will test that all parameter with a name starting with "test_"
+# have been folded to .true.
 # For instance, acos folding can be tested with:
 #
 #   real(4), parameter :: res_acos = acos(0.5_4)
 #   real(4), parameter :: exp_acos = 1.047
 #   logical, parameter :: test_acos = abs(res_acos - exp_acos).LE.(0.001_4)
 #
 # There are two kinds of failure:
 #   - test_x is folded to .false.. This means the expression was folded

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

subroutine arrayconstructorvalues()
   !ERROR: No intrinsic or user-defined ASSIGNMENT(=) matches operand types INTEGER(4) and TYPE(base_type)
   !ERROR: ABSTRACT derived type 'base_type' may not be used in a structure constructor
   !ERROR: Values in array constructor must have the same declared type when no explicit type appears
   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)]
+  real, dimension(-1:0), parameter :: good3 = [77.7, 66.6]
   !ERROR: Implied DO index is active in surrounding implied DO loop and may not have the same name
   real, dimension(100), parameter :: bad = [((88.8, i = 1, 10), i = 1, 10)]
 
   !ERROR: Value of named constant 'bad2' ([INTEGER(4)::(int(j,kind=4),INTEGER(8)::j=1_8,1_8,0_8)]) cannot be computed as a constant value
   !ERROR: The stride of an implied DO loop must not be zero
   integer, parameter :: bad2(*) = [(j, j=1,1,0)]
+  integer, parameter, dimension(-1:0) :: negLower = (/343,512/)
+  integer, parameter, dimension(-1:0) :: negLower1 = ((/343,512/))
+
+  real :: local
+
+  local = good3(0)
+  !ERROR: Subscript value (2) is out of range on dimension 1 in reference to a constant array value
+  local = good3(2)
+  call inner(negLower(:)) ! OK
+  call inner(negLower1(:)) ! OK
+
+  contains
+    subroutine inner(arg)
+      integer :: arg(:)
+    end subroutine inner
 end subroutine checkC7115
 subroutine checkOkDuplicates
   real :: realArray(21) = &
     [ ((1.0, iDuplicate = 1,j), &
        (0.0, iDuplicate = j,3 ), &
         j = 1,5 ) ]
 end subroutine