[flang] Correct epistemological edge cases for IS_CONTIGUOUS folding

[klausler]

Summary

Don't return a hard .FALSE. when folding IS_CONTIGUOUS() unless the
subscript triplets are discontiguous and array section is nonempty,
or if the array section is nonempty and there is a vector subscript.

[clementval]

LGTM

flang/include/flang/Evaluate/variable.h

const Expr<SubscriptInteger> *GetUpper() const {
     return upper_.has_value() ? &upper_->value() : nullptr;
   }
   Triplet &set_upper(Expr<SubscriptInteger> &&);
   Expr<SubscriptInteger> stride() const; // N.B. result is not optional<>
   const Expr<SubscriptInteger> &GetStride() const { return stride_.value(); }
   Triplet &set_stride(Expr<SubscriptInteger> &&);
 
   bool operator==(const Triplet &) const;
-  std::optional<bool> IsStrideOne() const;
   llvm::raw_ostream &AsFortran(llvm::raw_ostream &) const;
 
 private:
   std::optional<IndirectSubscriptIntegerExpr> lower_, upper_;
   IndirectSubscriptIntegerExpr stride_;
 };
 
 // R919 subscript when rank 0, R923 vector-subscript when rank 1

flang/lib/Evaluate/check-expression.cpp

Result operator()(const semantics::Symbol &symbol) const {
     }
   }
 
   Result operator()(const ArrayRef &x) const {
     if (x.Rank() == 0) {
       return true; // scalars considered contiguous
     }
     int subscriptRank{0};
-    auto subscripts{CheckSubscripts(x.subscript(), subscriptRank)};
+    auto baseLbounds{GetLBOUNDs(context_, x.base())};
+    auto baseUbounds{GetUBOUNDs(context_, x.base())};
+    auto subscripts{CheckSubscripts(
+        x.subscript(), subscriptRank, &baseLbounds, &baseUbounds)};
     if (!subscripts.value_or(false)) {
       return subscripts; // subscripts not known to be contiguous
     } else if (subscriptRank > 0) {
       // a(1)%b(:,:) is contiguous if and only if a(1)%b is contiguous.
       return (*this)(x.base());
     } else {
       // a(:)%b(1,1) is (probably) not contiguous.
       return std::nullopt;
if (auto chars{
       }
     }
     return std::nullopt;
   }
 
   Result operator()(const NullPointer &) const { return true; }
 
 private:
-  static std::optional<bool> CheckSubscripts(
-      const std::vector<Subscript> &subscript, int &rank) {
+  // Returns "true" for a provably empty or simply contiguous array section;
+  // return "false" for a provably nonempty discontiguous section or for use
+  // of a vector subscript.
+  std::optional<bool> CheckSubscripts(const std::vector<Subscript> &subscript,
+      int &rank, const Shape *baseLbounds = nullptr,
+      const Shape *baseUbounds = nullptr) const {
     bool anyTriplet{false};
     rank = 0;
+    // Detect any provably empty dimension in this array section, which would
+    // render the whole section empty and therefore vacuously contiguous.
+    std::optional<bool> result;
     for (auto j{subscript.size()}; j-- > 0;) {
       if (const auto *triplet{std::get_if<Triplet>(&subscript[j].u)}) {
-        auto isStride1{triplet->IsStrideOne()};
-        if (!isStride1.value_or(false)) {
-          return isStride1;
+        ++rank;
+        if (auto stride{ToInt64(triplet->stride())}) {
+          const Expr<SubscriptInteger> *lowerBound{triplet->GetLower()};
+          if (!lowerBound && baseLbounds && j < baseLbounds->size()) {
+            lowerBound = common::GetPtrFromOptional(baseLbounds->at(j));
+          }
+          const Expr<SubscriptInteger> *upperBound{triplet->GetUpper()};
+          if (!upperBound && baseUbounds && j < baseUbounds->size()) {
+            upperBound = common::GetPtrFromOptional(baseUbounds->at(j));
+          }
+          std::optional<ConstantSubscript> lowerVal{lowerBound
+                  ? ToInt64(Fold(context_, Expr<SubscriptInteger>{*lowerBound}))
+                  : std::nullopt};
+          std::optional<ConstantSubscript> upperVal{upperBound
+                  ? ToInt64(Fold(context_, Expr<SubscriptInteger>{*upperBound}))
+                  : std::nullopt};
+          if (lowerVal && upperVal) {
+            if (*lowerVal < *upperVal) {
+              if (*stride < 0) {
+                result = true; // empty dimension
+              } else if (!result && *stride > 1 &&
+                  *lowerVal + *stride <= *upperVal) {
+                result = false; // discontiguous if not empty
+              }
+            } else if (*lowerVal > *upperVal) {
+              if (*stride > 0) {
+                result = true; // empty dimension
+              } else if (!result && *stride < 0 &&
+                  *lowerVal + *stride >= *upperVal) {
+                result = false; // discontiguous if not empty
+              }
+            }
+          }
+        }
+      } else if (subscript[j].Rank() > 0) {
+        ++rank;
+        if (!result) {
+          result = false; // vector subscript
+        }
+      }
+    }
+    if (rank == 0) {
+      result = true; // scalar
+    }
+    if (result) {
+      return result;
+    }
+    // Not provably discontiguous at this point.
+    // Return "true" if simply contiguous, otherwise nullopt.
+    for (auto j{subscript.size()}; j-- > 0;) {
+      if (const auto *triplet{std::get_if<Triplet>(&subscript[j].u)}) {
+        auto stride{ToInt64(triplet->stride())};
+        if (!stride || stride != 1) {
+          return std::nullopt;
         } else if (anyTriplet) {
-          if (triplet->lower() || triplet->upper()) {
+          if (triplet->GetLower() || triplet->GetUpper()) {
             // all triplets before the last one must be just ":" for
             // simple contiguity
             return std::nullopt;
           }
         } else {
           anyTriplet = true;
         }
         ++rank;
-      } else if (anyTriplet || subscript[j].Rank() > 0) {
-        return false;
+      } else if (anyTriplet) {
+        return std::nullopt;
       }
     }
-    return true;
+    return true; // simply contiguous
   }
 
   FoldingContext &context_;
 };
 
 template <typename A>
 std::optional<bool> IsContiguous(const A &x, FoldingContext &context) {
   if (IsVariable(x)) {

flang/lib/Evaluate/variable.cpp

 
 Expr<SubscriptInteger> Triplet::stride() const { return stride_.value(); }
 
 Triplet &Triplet::set_stride(Expr<SubscriptInteger> &&expr) {
   stride_.value() = std::move(expr);
   return *this;
 }
 
-std::optional<bool> Triplet::IsStrideOne() const {
-  if (auto stride{ToInt64(stride_.value())}) {
-    return stride == 1;
-  } else {
-    return std::nullopt;
-  }
-}
-
 CoarrayRef::CoarrayRef(SymbolVector &&base, std::vector<Subscript> &&ss,
     std::vector<Expr<SubscriptInteger>> &&css)
     : base_{std::move(base)}, subscript_(std::move(ss)),
       cosubscript_(std::move(css)) {
   CHECK(!base_.empty());
   CHECK(!cosubscript_.empty());
 }
 

flang/test/Semantics/assign03.f90

subroutine s12
     logical(kind=merge(-1,1,is_contiguous(x%a(:,v)))) :: l5 ! known false
     !ERROR: Must be a constant value
     logical(kind=merge(-1,-2,is_contiguous(y(v,1)%a(1,1)))) :: l6 ! unknown
     !ERROR: Must be a constant value
     logical(kind=merge(-1,-2,is_contiguous(p(:)))) :: l7 ! unknown
     logical(kind=merge(1,-1,is_contiguous(pc(:)))) :: l8 ! known true
     logical(kind=merge(-1,1,is_contiguous(pc(1:10:2)))) :: l9 ! known false
     logical(kind=merge(-1,1,is_contiguous(pc(10:1:-1)))) :: l10 ! known false
+    logical(kind=merge(1,-1,is_contiguous(pc(1:10:1)))) :: l11 ! known true
+    logical(kind=merge(-1,1,is_contiguous(pc(10:1:-1)))) :: l12 ! known false
+    !ERROR: Must be a constant value
+    logical(kind=merge(-1,1,is_contiguous(pc(::-1)))) :: l13 ! unknown (could be empty)
+    logical(kind=merge(1,-1,is_contiguous(y(1,1)%a(::-1,1)))) :: l14 ! known true (empty)
+    logical(kind=merge(1,-1,is_contiguous(y(1,1)%a(1,::-1)))) :: l15 ! known true (empty)
   end
   subroutine test3(b)
     integer, intent(inout) :: b(..)
     !ERROR: Must be a constant value
     integer, parameter :: i = rank(b)
   end subroutine
 
   subroutine s13
     external :: s_external
     procedure(), pointer :: ptr
     !Ok - don't emit an error about incompatible Subroutine attribute
     ptr => s_external
     call ptr
   end subroutine
 end