[flang] Limit shape inquiries rewrite to associate construct entity

[jeanPerier]

Summary

The previous code was rewriting all shape inquires on associate
construct entities to inquires on the associated expression or variable.

This is is incorrect because at the point of inquiry, some statement
between the association and the inquiry may have modified the expression
operands or variable in a way that changes its shapes or bounds.

For instance, in the example below, expression rewrites was previously
replacing size(x, 1) by size(p, 1) which is invalid if p is a
pointer.

associate(x => p + 1)
 call call_that_may_modify_p_shape()
 print *, size(x, 1)
end associate

This change restricts rewrites of shape inquiries on associate construct entity
to use the associated expression shape and bounds if and only if the
shape/bounds are compile time constant. Otherwise, this may be invalid.

[PeteSteinfeld]

The criterion you're using to figure out whether to rewrite the expression seems wrong to me. Rather than checking if the bounds are constant, I think that we should be checking to see if the right hand side of the ASSOCIATE clause is a variable. Here's a program that I believe will give the wrong result if we implement this change:

program test_associate
  real, dimension(:), allocatable :: ra

  allocate (ra(10))
  print *, 'size(ra): ', size(ra)
  associate (x => ra)
    print *, 'size(x): ', size(x)
    deallocate(ra)
    allocate(ra(20))
    print *, 'size(x): ', size(x)
  end associate
end program test_associate
I believe that, for a conforming compiler, the final `print` statement should print `size(x):  20`.  But with the changes you propose, we print `size(x):  10`.

Interestingly, the only compiler I can find that agrees with me is NAG.  Every other compiler I've tried prints `size(x):  10`.

[jeanPerier]

In D133857#3789550, @PeteSteinfeld wrote:

Here's a program that I believe will give the wrong result if we implement this change:
I believe that, for a conforming compiler, the final print statement should print size(x): 20. But with the changes you propose, we print size(x): 10.
Interestingly, the only compiler I can find that agrees with me is NAG. Every other compiler I've tried prints size(x): 10.

I disagree here, I think the program you wrote is non-conforming since deallocate(ra) destroyed x storage (violates 9.7.3.2 point 1). If you do this test with a pointer (without deallocating the pointer, just setting a new target to the pointer), I believe this is conforming, and the expected result is 10 (this times, both NAG and all other compilers agree with this change).

That is because when the selector is an allocatable or pointer, the selector is associated with the current data object/target (and not the pointer/allocatable itself). See:

11.1.3.3 point 1: The associating entity does not have the ALLOCATABLE or POINTER attributes;

And:

19.5.1.6 point 2:
In an ASSOCIATE or SELECT TYPE construct, the following rules apply.
• If a selector is allocatable, it shall be allocated; the associate name is associated with the data object and does not have the ALLOCATABLE attribute.
• If a selector has the POINTER attribute, it shall be associated; the associate name is associated with the target of the pointer and does not have the POINTER attribute.

And:

9.7.3.2 point 1: An allocatable variable shall not be deallocated if it or any subobject of it is argument associated with a dummy argument or construct associated with an associate name.

In D133857#3789550, @PeteSteinfeld wrote:

The criterion you're using to figure out whether to rewrite the expression seems wrong to me. Rather than checking if the bounds are constant, I think that we should be checking to see if the right hand side of the ASSOCIATE clause is a variable.

I disagree here, based on the arguments above, both ASSOCIATE(X => P) and ASSOCIATE(X => P+1) with p a pointer or allocatable should not lead SIZE(X) to be resolved to SIZE(P) as it used to be. So the fact that the selector is a variable or an expression does not matter, and the shape and bounds of the associate name are "frozen" at the time of the association.

[PeteSteinfeld]

Thanks, Jean.

I can't come up with a conforming example that breaks your implementation.

[jeanPerier]

Revert bad unrelated bad change in an if condition.

flang/include/flang/Evaluate/check-expression.h

 
 // Predicate: true when an expression actually is a typed Constant<T>,
 // perhaps with parentheses and wrapping around it.  False for all typeless
 // expressions, including BOZ literals.
 template <typename A> bool IsActuallyConstant(const A &);
 extern template bool IsActuallyConstant(const Expr<SomeType> &);
 extern template bool IsActuallyConstant(const Expr<SomeInteger> &);
 extern template bool IsActuallyConstant(const Expr<SubscriptInteger> &);
+extern template bool IsActuallyConstant(
+    const std::optional<Expr<SubscriptInteger>> &);
 
 // Checks whether an expression is an object designator with
 // constant addressing and no vector-valued subscript.
 // If a non-null ContextualMessages pointer is passed, an error message
 // will be generated if and only if the result of the function is false.
 bool IsInitialDataTarget(
     const Expr<SomeType> &, parser::ContextualMessages * = nullptr);
 

flang/lib/Evaluate/check-expression.cpp

 
 template <typename A> bool IsActuallyConstant(const A &x) {
   return IsActuallyConstantHelper{}(x);
 }
 
 template bool IsActuallyConstant(const Expr<SomeType> &);
 template bool IsActuallyConstant(const Expr<SomeInteger> &);
 template bool IsActuallyConstant(const Expr<SubscriptInteger> &);
+template bool IsActuallyConstant(const std::optional<Expr<SubscriptInteger>> &);
 
 // Object pointer initialization checking predicate IsInitialDataTarget().
 // This code determines whether an expression is allowable as the static
 // data address used to initialize a pointer with "=> x".  See C765.
 class IsInitialDataTargetHelper
     : public AllTraverse<IsInitialDataTargetHelper, true> {
 public:
   using Base = AllTraverse<IsInitialDataTargetHelper, true>;

flang/lib/Evaluate/shape.cpp

if (const auto *details{
                    symbol.detailsIf<semantics::AssocEntityDetails>()}) {
       if (assoc->rank()) { // SELECT RANK case
         const Symbol &resolved{ResolveAssociations(symbol)};
         if (IsDescriptor(resolved) && dimension_ < *assoc->rank()) {
           return ExtentExpr{DescriptorInquiry{std::move(base),
               DescriptorInquiry::Field::LowerBound, dimension_}};
         }
       } else {
-        return (*this)(assoc->expr());
+        auto exprLowerBound{((*this)(assoc->expr()))};
+        if (IsActuallyConstant(exprLowerBound)) {
+          return std::move(exprLowerBound);
+        } else {
+          // If the lower bound of the associated entity is not resolved to
+          // constant expression at the time of the association, it is unsafe
+          // to re-evaluate it later in the associate construct. Statements
+          // in-between may have modified its operands value.
+          return ExtentExpr{DescriptorInquiry{std::move(base),
+              DescriptorInquiry::Field::LowerBound, dimension_}};
+        }
       }
     }
     if constexpr (LBOUND_SEMANTICS) {
       return Result{};
     } else {
       return Result{1};
     }
   }
if (lval.value_or(0) == 1) {
           Extremum<SubscriptInteger>{Ordering::Greater, ExtentExpr{0},
               common::Clone(*ubound) - common::Clone(*lbound) + ExtentExpr{1}}};
     }
   } else {
     return std::nullopt;
   }
 }
 
+MaybeExtentExpr GetAssociatedExtent(const NamedEntity &base,
+    const semantics::AssocEntityDetails &assoc, int dimension) {
+  if (auto shape{GetShape(assoc.expr())}) {
+    if (dimension < static_cast<int>(shape->size())) {
+      auto &extent{shape->at(dimension)};
+      if (extent && IsActuallyConstant(*extent)) {
+        return std::move(extent);
+      } else {
+        // Otherwise, evaluating the associated expression extent expression
+        // after the associate statement is unsafe given statements inside the
+        // associate may have modified the associated expression operands
+        // values.
+        return ExtentExpr{DescriptorInquiry{
+            NamedEntity{base}, DescriptorInquiry::Field::Extent, dimension}};
+      }
+    }
+  }
+  return std::nullopt;
+}
+
 MaybeExtentExpr GetExtent(const NamedEntity &base, int dimension) {
   CHECK(dimension >= 0);
   const Symbol &last{base.GetLastSymbol()};
   const Symbol &symbol{ResolveAssociations(last)};
   if (const auto *assoc{last.detailsIf<semantics::AssocEntityDetails>()}) {
     if (assoc->rank()) { // SELECT RANK case
       if (semantics::IsDescriptor(symbol) && dimension < *assoc->rank()) {
         return ExtentExpr{DescriptorInquiry{
             NamedEntity{base}, DescriptorInquiry::Field::Extent, dimension}};
       }
-    } else if (auto shape{GetShape(assoc->expr())}) {
-      if (dimension < static_cast<int>(shape->size())) {
-        return std::move(shape->at(dimension));
-      }
+    } else {
+      return GetAssociatedExtent(base, *assoc, dimension);
     }
   }
   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));
         }
if (dimension < rank) {
         return std::nullopt;
       } else {
         return ComputeUpperBound(
             GetRawLowerBound(base, dimension), GetExtent(base, dimension));
       }
     }
   } else if (const auto *assoc{
                  symbol.detailsIf<semantics::AssocEntityDetails>()}) {
-    if (auto shape{GetShape(assoc->expr())}) {
-      if (dimension < static_cast<int>(shape->size())) {
-        return ComputeUpperBound(
-            GetRawLowerBound(base, dimension), std::move(shape->at(dimension)));
-      }
+    if (auto extent{GetAssociatedExtent(base, *assoc, dimension)}) {
+          GetRawLowerBound(base, dimension), std::move(extent));
     }
   }
   return std::nullopt;
 }
 
 MaybeExtentExpr GetRawUpperBound(
     FoldingContext &context, const NamedEntity &base, int dimension) {
   return Fold(context, GetRawUpperBound(base, dimension));
if (dimension < rank) {
       } else if (details->IsAssumedSize() && dimension + 1 == symbol.Rank()) {
         return std::nullopt;
       } 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 shape{GetShape(assoc->expr())}) {
-      if (dimension < static_cast<int>(shape->size())) {
-        if (auto lb{GetLBOUND(base, dimension)}) {
-          return ComputeUpperBound(
-              std::move(*lb), std::move(shape->at(dimension)));
-        }
+    if (auto extent{GetAssociatedExtent(base, *assoc, dimension)}) {
+        return ComputeUpperBound(std::move(*lb), std::move(extent));
       }
     }
   }
   return std::nullopt;
 }
 
 MaybeExtentExpr GetUBOUND(const NamedEntity &base, int dimension) {
   return GetUBOUND(nullptr, base, dimension);
return common::visit(
           [&](const semantics::ProcEntityDetails &proc) {
             if (const Symbol * interface{proc.interface().symbol()}) {
               return (*this)(*interface);
             } else {
               return ScalarShape();
             }
           },
           [&](const semantics::AssocEntityDetails &assoc) {
+            NamedEntity base{symbol};
             if (assoc.rank()) { // SELECT RANK case
               int n{assoc.rank().value()};
-              NamedEntity base{symbol};
               return Result{CreateShape(n, base)};
             } else {
-              return (*this)(assoc.expr());
+              auto exprShape{((*this)(assoc.expr()))};
+              if (exprShape) {
+                int rank{static_cast<int>(exprShape->size())};
+                for (int dimension{0}; dimension < rank; ++dimension) {
+                  auto &extent{(*exprShape)[dimension]};
+                  if (extent && !IsActuallyConstant(*extent)) {
+                    extent = GetExtent(base, dimension);
+                  }
+                }
+              }
+              return exprShape;
             }
           },
           [&](const semantics::SubprogramDetails &subp) -> Result {
             if (subp.isFunction()) {
               auto resultShape{(*this)(subp.result())};
               if (resultShape && !useResultSymbolShape_) {
                 // Ensure the shape is constant. Otherwise, it may be referring
                 // to symbols that belong to the subroutine scope and are

flang/test/Evaluate/rewrite01.f90

subroutine len_test(a,b, c, d, e, n, m)
   !CHECK: PRINT *, int(max(0_8,max(0_8,int(n,kind=8))-4_8+1_8),kind=4)
   print *, len(e(4:))
   !CHECK: PRINT *, len(fun1(n-m))
   print *, len(fun1(n-m))
   !CHECK: PRINT *, len(mofun(m+1_4))
   print *, len(mofun(m+1))
 end subroutine len_test
 
+!CHECK-LABEL: associate_tests
+subroutine associate_tests(p)
+  real, pointer :: p(:)
+  real :: a(10:20)
+  interface
+    subroutine may_change_p_bounds(p)
+      real, pointer :: p(:)
+    end subroutine
+  end interface
+  associate(x => p)
+    call may_change_p_bounds(p)
+    !CHECK: PRINT *, lbound(x,dim=1,kind=8), size(x,dim=1,kind=8)+lbound(x,dim=1,kind=8)-1_8, size(x,dim=1,kind=8)
+    print *, lbound(x, 1, kind=8), ubound(x, 1, kind=8), size(x, 1, kind=8)
+  end associate
+  associate(x => p+1)
+    call may_change_p_bounds(p)
+    !CHECK: PRINT *, 1_8, size(x,dim=1,kind=8), size(x,dim=1,kind=8)
+    print *, lbound(x, 1, kind=8), ubound(x, 1, kind=8), size(x, 1, kind=8)
+  end associate
+  associate(x => a)
+    !CHECK: PRINT *, 10_8, 20_8, 11_8
+    print *, lbound(x, 1, kind=8), ubound(x, 1, kind=8), size(x, 1, kind=8)
+  end associate
+  associate(x => a+42.)
+    !CHECK: PRINT *, 1_8, 11_8, 11_8
+    print *, lbound(x, 1, kind=8), ubound(x, 1, kind=8), size(x, 1, kind=8)
+  end associate
+end subroutine
+
 end module