[flang] Don't reference non-invariant symbols in shape expressions

[klausler]

Summary

When an array's shape involves references to symbols that are not
invariant in a scope -- the classic example being a dummy array
with an explicit shape involving other dummy arguments -- the
compiler was creating shape expressions that referenced those
symbols. This might be valid if those symbols are somehow
captured and copied at each entry point to a subprogram, and
the copies referenced in the shapes instead, but that's not
the case.

This patch introduces a new expression predicate IsScopeInvariantExpr(),
which defines a class of expressions that contains constant expressions
(in the sense that the standard uses that term) as well as references
to items that may be safely accessed in a context-free way throughout
their scopes. This includes dummy arguments that are INTENT(IN)
and not VALUE, descriptor inquiries into descriptors that cannot
change, and bare LEN type parameters within the definitions of
derived types. The new predicate is then used in shape analysis
to winnow out results that would have otherwise been contextual.

[jeanPerier]

Looks great

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

 // strict sense of the Fortran standard); it may not (yet) be a hard
 // constant value.
 template <typename A> bool IsConstantExpr(const A &);
 extern template bool IsConstantExpr(const Expr<SomeType> &);
 extern template bool IsConstantExpr(const Expr<SomeInteger> &);
 extern template bool IsConstantExpr(const Expr<SubscriptInteger> &);
 extern template bool IsConstantExpr(const StructureConstructor &);
 
+// Predicate: true when an expression is a constant expression (in the
+// strict sense of the Fortran standard) or a dummy argument with
+// INTENT(IN) and no VALUE.  This is useful for representing explicit
+// shapes of other dummy arguments.
+template <typename A> bool IsScopeInvariantExpr(const A &);
+extern template bool IsScopeInvariantExpr(const Expr<SomeType> &);
+extern template bool IsScopeInvariantExpr(const Expr<SomeInteger> &);
+extern template bool IsScopeInvariantExpr(const Expr<SubscriptInteger> &);
+
 // 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> &);
 
 // Checks whether an expression is an object designator with
 // constant addressing and no vector-valued subscript.

flang/lib/Evaluate/check-expression.cpp

 #include "flang/Evaluate/type.h"
 #include "flang/Semantics/symbol.h"
 #include "flang/Semantics/tools.h"
 #include <set>
 #include <string>
 
 namespace Fortran::evaluate {
 
-// Constant expression predicate IsConstantExpr().
+// Constant expression predicates IsConstantExpr() & IsScopeInvariantExpr().
 // This code determines whether an expression is a "constant expression"
 // in the sense of section 10.1.12.  This is not the same thing as being
 // able to fold it (yet) into a known constant value; specifically,
 // the expression may reference derived type kind parameters whose values
 // are not yet known.
-class IsConstantExprHelper : public AllTraverse<IsConstantExprHelper, true> {
+//
+// The variant form (IsScopeInvariantExpr()) also accepts symbols that are
+// INTENT(IN) dummy arguments without the VALUE attribute.
+template <bool INVARIANT>
+class IsConstantExprHelper
+    : public AllTraverse<IsConstantExprHelper<INVARIANT>, true> {
 public:
   using Base = AllTraverse<IsConstantExprHelper, true>;
   IsConstantExprHelper() : Base{*this} {}
   using Base::operator();
 
   // A missing expression is not considered to be constant.
   template <typename A> bool operator()(const std::optional<A> &x) const {
     return x && (*this)(*x);
   }
 
   bool operator()(const TypeParamInquiry &inq) const {
-    return semantics::IsKindTypeParameter(inq.parameter());
+    return INVARIANT || semantics::IsKindTypeParameter(inq.parameter());
   }
   bool operator()(const semantics::Symbol &symbol) const {
     const auto &ultimate{GetAssociationRoot(symbol)};
     return IsNamedConstant(ultimate) || IsImpliedDoIndex(ultimate) ||
-        IsInitialProcedureTarget(ultimate);
+        IsInitialProcedureTarget(ultimate) ||
+        ultimate.has<semantics::TypeParamDetails>() ||
+        (INVARIANT && IsIntentIn(symbol) &&
+            !symbol.attrs().test(semantics::Attr::VALUE));
   }
   bool operator()(const CoarrayRef &) const { return false; }
   bool operator()(const semantics::ParamValue &param) const {
     return param.isExplicit() && (*this)(param.GetExplicit());
   }
   bool operator()(const ProcedureRef &) const;
   bool operator()(const StructureConstructor &constructor) const {
     for (const auto &[symRef, expr] : constructor) {
bool operator()(
     if (const auto divisor{GetScalarConstantValue<T>(division.right())}) {
       return !divisor->IsZero() && (*this)(division.left());
     } else {
       return false;
     }
   }
 
   bool operator()(const Constant<SomeDerived> &) const { return true; }
-  bool operator()(const DescriptorInquiry &) const { return false; }
+  bool operator()(const DescriptorInquiry &x) const {
+    const Symbol &sym{x.base().GetLastSymbol()};
+    return INVARIANT && !IsAllocatable(sym) &&
+        (!IsDummy(sym) ||
+            (IsIntentIn(sym) && !sym.attrs().test(semantics::Attr::VALUE)));
+  }
 
 private:
   bool IsConstantStructureConstructorComponent(
       const Symbol &, const Expr<SomeType> &) const;
   bool IsConstantExprShape(const Shape &) const;
 };
 
-bool IsConstantExprHelper::IsConstantStructureConstructorComponent(
+template <bool INVARIANT>
+bool IsConstantExprHelper<INVARIANT>::IsConstantStructureConstructorComponent(
     const Symbol &component, const Expr<SomeType> &expr) const {
   if (IsAllocatable(component)) {
     return IsNullPointer(expr);
   } else if (IsPointer(component)) {
     return IsNullPointer(expr) || IsInitialDataTarget(expr) ||
         IsInitialProcedureTarget(expr);
   } else {
     return (*this)(expr);
   }
 }
 
-bool IsConstantExprHelper::operator()(const ProcedureRef &call) const {
+template <bool INVARIANT>
+bool IsConstantExprHelper<INVARIANT>::operator()(
+    const ProcedureRef &call) const {
   // LBOUND, UBOUND, and SIZE with DIM= arguments will have been rewritten
   // into DescriptorInquiry operations.
   if (const auto *intrinsic{std::get_if<SpecificIntrinsic>(&call.proc().u)}) {
     if (intrinsic->name == "kind" ||
         intrinsic->name == IntrinsicProcTable::InvalidName) {
       // kind is always a constant, and we avoid cascading errors by considering
       // invalid calls to intrinsics to be constant
       return true;
if (intrinsic->name == "kind" ||
       auto shape{GetShape(call.arguments()[0]->UnwrapExpr())};
       return shape && IsConstantExprShape(*shape);
     }
     // TODO: STORAGE_SIZE
   }
   return false;
 }
 
-bool IsConstantExprHelper::IsConstantExprShape(const Shape &shape) const {
+template <bool INVARIANT>
+bool IsConstantExprHelper<INVARIANT>::IsConstantExprShape(
+    const Shape &shape) const {
   for (const auto &extent : shape) {
     if (!(*this)(extent)) {
       return false;
     }
   }
   return true;
 }
 
 template <typename A> bool IsConstantExpr(const A &x) {
-  return IsConstantExprHelper{}(x);
+  return IsConstantExprHelper<false>{}(x);
 }
 template bool IsConstantExpr(const Expr<SomeType> &);
 template bool IsConstantExpr(const Expr<SomeInteger> &);
 template bool IsConstantExpr(const Expr<SubscriptInteger> &);
 template bool IsConstantExpr(const StructureConstructor &);
 
+// IsScopeInvariantExpr()
+template <typename A> bool IsScopeInvariantExpr(const A &x) {
+  return IsConstantExprHelper<true>{}(x);
+}
+template bool IsScopeInvariantExpr(const Expr<SomeType> &);
+template bool IsScopeInvariantExpr(const Expr<SomeInteger> &);
+template bool IsScopeInvariantExpr(const Expr<SubscriptInteger> &);
+
 // IsActuallyConstant()
 struct IsActuallyConstantHelper {
   template <typename A> bool operator()(const A &) { return false; }
   template <typename T> bool operator()(const Constant<T> &) { return true; }
   template <typename T> bool operator()(const Parentheses<T> &x) {
     return (*this)(x.left());
   }
   template <typename T> bool operator()(const Expr<T> &x) {

flang/lib/Evaluate/shape.cpp

 //===-- lib/Evaluate/shape.cpp --------------------------------------------===//
 //
 // Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
 // See https://llvm.org/LICENSE.txt for license information.
 // SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
 //
 //===----------------------------------------------------------------------===//
 
 #include "flang/Evaluate/shape.h"
 #include "flang/Common/idioms.h"
 #include "flang/Common/template.h"
 #include "flang/Evaluate/characteristics.h"
+#include "flang/Evaluate/check-expression.h"
 #include "flang/Evaluate/fold.h"
 #include "flang/Evaluate/intrinsics.h"
 #include "flang/Evaluate/tools.h"
 #include "flang/Evaluate/type.h"
 #include "flang/Parser/message.h"
 #include "flang/Semantics/symbol.h"
 #include <functional>
 

 };
 
 auto GetLowerBoundHelper::operator()(const Symbol &symbol0) -> Result {
   const Symbol &symbol{symbol0.GetUltimate()};
   if (const auto *details{symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
     int j{0};
     for (const auto &shapeSpec : details->shape()) {
       if (j++ == dimension_) {
-        if (const auto &bound{shapeSpec.lbound().GetExplicit()}) {
+        const auto &bound{shapeSpec.lbound().GetExplicit()};
+        if (bound && IsScopeInvariantExpr(*bound)) {
           return *bound;
         } else if (IsDescriptor(symbol)) {
           return ExtentExpr{DescriptorInquiry{NamedEntity{symbol0},
               DescriptorInquiry::Field::LowerBound, dimension_}};
         } else {
           break;
         }
       }

 auto GetLowerBoundHelper::operator()(const Component &component) -> Result {
   if (component.base().Rank() == 0) {
     const Symbol &symbol{component.GetLastSymbol().GetUltimate()};
     if (const auto *details{
             symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
       int j{0};
       for (const auto &shapeSpec : details->shape()) {
         if (j++ == dimension_) {
-          if (const auto &bound{shapeSpec.lbound().GetExplicit()}) {
+          const auto &bound{shapeSpec.lbound().GetExplicit()};
+          if (bound && IsScopeInvariantExpr(*bound)) {
             return *bound;
           } else if (IsDescriptor(symbol)) {
             return ExtentExpr{
                 DescriptorInquiry{NamedEntity{common::Clone(component)},
                     DescriptorInquiry::Field::LowerBound, dimension_}};
           } else {
             break;
           }
static MaybeExtentExpr GetNonNegativeExtent(
   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};
     }
+  } else if (lbound && ubound && IsScopeInvariantExpr(*lbound) &&
+      IsScopeInvariantExpr(*ubound)) {
+    // Apply effective IDIM (MAX calculation with 0) so thet the
+    // result is never negative
+    if (lval.value_or(0) == 1) {
+      return ExtentExpr{Extremum<SubscriptInteger>{
+          Ordering::Greater, ExtentExpr{0}, common::Clone(*ubound)}};
+    } else {
+      return ExtentExpr{
+          Extremum<SubscriptInteger>{Ordering::Greater, ExtentExpr{0},
+              common::Clone(*ubound) - common::Clone(*lbound) + ExtentExpr{1}}};
+    }
+  } else {
+    return std::nullopt;
   }
-  return common::Clone(ubound.value()) - common::Clone(lbound.value()) +
-      ExtentExpr{1};
 }
 
 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 (IsImpliedShape(symbol) && details->init()) {
         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 (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();
-              }
-            }
+          if (auto extent{GetNonNegativeExtent(shapeSpec)}) {
+            return extent;
           } else if (details->IsAssumedSize() && j == symbol.Rank()) {
             return std::nullopt;
           } else if (semantics::IsDescriptor(symbol)) {
             return ExtentExpr{DescriptorInquiry{NamedEntity{base},
                 DescriptorInquiry::Field::Extent, dimension}};
+          } else {
+            break;
           }
         }
       }
     }
   }
   return std::nullopt;
 }
 

 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) {
+    if (ToInt64(lower).value_or(0) == 1) {
+      return std::move(*extent);
+    } else {
       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)));
 }
 
 MaybeExtentExpr GetUpperBound(const NamedEntity &base, int dimension) {
   const Symbol &symbol{ResolveAssociations(base.GetLastSymbol())};
   if (const auto *details{symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
     int j{0};
     for (const auto &shapeSpec : details->shape()) {
       if (j++ == dimension) {
-        if (const auto &bound{shapeSpec.ubound().GetExplicit()}) {
+        const auto &bound{shapeSpec.ubound().GetExplicit()};
+        if (bound && IsScopeInvariantExpr(*bound)) {
           return *bound;
         } else if (details->IsAssumedSize() && dimension + 1 == symbol.Rank()) {
           break;
         } else {
           return ComputeUpperBound(
               GetLowerBound(base, dimension), GetExtent(base, dimension));
         }
       }

 }
 
 Shape GetUpperBounds(const NamedEntity &base) {
   const Symbol &symbol{ResolveAssociations(base.GetLastSymbol())};
   if (const auto *details{symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
     Shape result;
     int dim{0};
     for (const auto &shapeSpec : details->shape()) {
-      if (const auto &bound{shapeSpec.ubound().GetExplicit()}) {
+      const auto &bound{shapeSpec.ubound().GetExplicit()};
+      if (bound && IsScopeInvariantExpr(*bound)) {
         result.push_back(*bound);
-      } else if (details->IsAssumedSize()) {
-        CHECK(dim + 1 == base.Rank());
+      } else if (details->IsAssumedSize() && dim + 1 == base.Rank()) {
         result.emplace_back(std::nullopt); // UBOUND folding replaces with -1
       } else {
         result.emplace_back(
             ComputeUpperBound(GetLowerBound(base, dim), GetExtent(base, dim)));
       }
       ++dim;
     }
     CHECK(GetRank(result) == symbol.Rank());

flang/test/Semantics/modfile33.f90

 !  end
 ! end interface
 !contains
 ! subroutine s1(n, x, y, z, a, b)
 !  integer(8) :: n
 !  real(4) :: x
 !  real(4) :: y(1_8:4_8, 1_8:n)
 !  real(4) :: z(1_8:2_8, 1_8:2_8, 1_8:2_8)
-!  real(4) :: a(1_8:int(int(4_8*(n-1_8+1_8),kind=4),kind=8))
+!  real(4) :: a(1_8:int(int(4_8*size(y,dim=2),kind=4),kind=8))
 !  real(4) :: b(1_8:add(y, z))
 ! end
 !end
 
 ! Parameterized derived type
 module m7
   type :: t(k)
     integer, kind :: k

flang/test/Semantics/offsets01.f90

subroutine s4
   integer, allocatable :: z1(:)     !CHECK: z1, ALLOCATABLE size=48 offset=
   integer, allocatable :: z2(:,:)   !CHECK: z2, ALLOCATABLE size=72 offset=
   integer, allocatable :: z3(:,:,:) !CHECK: z3, ALLOCATABLE size=96 offset=
 end
 
 ! Descriptors with length parameters
 subroutine s5(n)
   integer :: n
-  type :: t1(l)
-    integer, len :: l
-    real :: a(l)
+  type :: t1(n)
+    integer, len :: n
+    real :: a(n)
   end type
-  type :: t2(l1, l2)
-    integer, len :: l1
-    integer, len :: l2
-    real :: b(l1, l2)
+  type :: t2(n1, n2)
+    integer, len :: n1
+    integer, len :: n2
+    real :: b(n1, n2)
   end type
   type(t1(n))   :: x1 !CHECK: x1 size=40 offset=
   type(t2(n,n)) :: x2 !CHECK: x2 size=48 offset=
   !CHECK: a size=48 offset=0:
   !CHECK: b size=72 offset=0:
 end