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

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.

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

5 files changed, 85 insertions, 36 deletions

diff --git a/flang/include/flang/Evaluate/check-expression.h b/flang/include/flang/Evaluate/check-expression.h
index f1aab7b57947..21f48be0f7d3 100644
--- a/flang/include/flang/Evaluate/check-expression.h
+++ b/flang/include/flang/Evaluate/check-expression.h
@@ -34,6 +34,15 @@ 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.
diff --git a/flang/lib/Evaluate/check-expression.cpp b/flang/lib/Evaluate/check-expression.cpp
index aaed4c33b1e1..53c93354c239 100644
--- a/flang/lib/Evaluate/check-expression.cpp
+++ b/flang/lib/Evaluate/check-expression.cpp
@@ -18,13 +18,18 @@
 
 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} {}
@@ -36,12 +41,15 @@ public:
   }
 
   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 {
@@ -72,7 +80,12 @@ public:
   }
 
   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(
@@ -80,7 +93,8 @@ private:
   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);
@@ -92,7 +106,9 @@ bool IsConstantExprHelper::IsConstantStructureConstructorComponent(
   }
 }
 
-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)}) {
@@ -122,7 +138,9 @@ bool IsConstantExprHelper::operator()(const ProcedureRef &call) const {
   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;
@@ -132,13 +150,21 @@ bool IsConstantExprHelper::IsConstantExprShape(const Shape &shape) const {
 }
 
 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; }
diff --git a/flang/lib/Evaluate/shape.cpp b/flang/lib/Evaluate/shape.cpp
index a387845625f2..96a99c823f19 100644
--- a/flang/lib/Evaluate/shape.cpp
+++ b/flang/lib/Evaluate/shape.cpp
@@ -10,6 +10,7 @@
 #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"
@@ -249,7 +250,8 @@ auto GetLowerBoundHelper::operator()(const Symbol &symbol0) -> Result {
     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},
@@ -282,7 +284,8 @@ auto GetLowerBoundHelper::operator()(const Component &component) -> Result {
       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{
@@ -340,9 +343,21 @@ static MaybeExtentExpr GetNonNegativeExtent(
     } 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) {
@@ -372,21 +387,15 @@ MaybeExtentExpr GetExtent(const NamedEntity &base, int dimension) {
       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;
           }
         }
       }
@@ -437,7 +446,11 @@ MaybeExtentExpr GetExtent(FoldingContext &context, const Subscript &subscript,
 MaybeExtentExpr ComputeUpperBound(
     ExtentExpr &&lower, MaybeExtentExpr &&extent) {
   if (extent) {
-    return std::move(*extent) + std::move(lower) - ExtentExpr{1};
+    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;
   }
@@ -454,7 +467,8 @@ MaybeExtentExpr GetUpperBound(const NamedEntity &base, int dimension) {
     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;
@@ -487,10 +501,10 @@ Shape GetUpperBounds(const NamedEntity &base) {
     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(
diff --git a/flang/test/Semantics/modfile33.f90 b/flang/test/Semantics/modfile33.f90
index a348e2b5db71..5eae92a8a7f9 100644
--- a/flang/test/Semantics/modfile33.f90
+++ b/flang/test/Semantics/modfile33.f90
@@ -572,7 +572,7 @@ end
 !  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
diff --git a/flang/test/Semantics/offsets01.f90 b/flang/test/Semantics/offsets01.f90
index c3d66a5bc94a..ccd70769bcee 100644
--- a/flang/test/Semantics/offsets01.f90
+++ b/flang/test/Semantics/offsets01.f90
@@ -38,14 +38,14 @@ 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=