[flang] Fix another bug checking simple contiguity

The test still wasn't correct for structure components. If the last
part-ref is a non-array or a single array element, but the whole
ArrayRef has non-zero rank, it is not contiguous. Otherwise, if there
are subscripts on the last part-ref they can be checked normally.

Add some tests for cases that were previously failing, and also for
cases with vector subscripts.

Original-commit: flang-compiler/f18@aa0a0887325bd1fc6c3a1ad40fc6711d2e458a1c
Reviewed-on: https://github.com/flang-compiler/f18/pull/961

diff --git a/flang/lib/evaluate/check-expression.cpp b/flang/lib/evaluate/check-expression.cpp
index 34b9025..b809211 100644 (file)
--- a/flang/lib/evaluate/check-expression.cpp
+++ b/flang/lib/evaluate/check-expression.cpp
@@ -277,11 +277,18 @@ public:
   }
 
   Result operator()(const ArrayRef &x) const {
-    return (x.base().IsSymbol() || x.base().Rank() == 0) &&
-        CheckSubscripts(x.subscript()) && (*this)(x.base());
+    const auto &symbol{x.GetLastSymbol()};
+    if (!(*this)(symbol)) {
+      return false;
+    } else if (auto rank{CheckSubscripts(x.subscript())}) {
+      // a(:)%b(1,1) is not contiguous; a(1)%b(:,:) is
+      return *rank > 0 || x.Rank() == 0;
+    } else {
+      return false;
+    }
   }
   Result operator()(const CoarrayRef &x) const {
-    return CheckSubscripts(x.subscript());
+    return CheckSubscripts(x.subscript()).has_value();
   }
   Result operator()(const Component &x) const {
     return x.base().Rank() == 0 && (*this)(x.GetLastSymbol());
@@ -304,24 +311,30 @@ public:
   }
 
 private:
-  static bool CheckSubscripts(const std::vector<Subscript> &subscript) {
+  // If the subscripts can possibly be on a simply-contiguous array reference,
+  // return the rank.
+  static std::optional<int> CheckSubscripts(
+      const std::vector<Subscript> &subscript) {
     bool anyTriplet{false};
+    int rank{0};
     for (auto j{subscript.size()}; j-- > 0;) {
       if (const auto *triplet{std::get_if<Triplet>(&subscript[j].u)}) {
         if (!triplet->IsStrideOne()) {
-          return false;
+          return std::nullopt;
         } else if (anyTriplet) {
           if (triplet->lower() || triplet->upper()) {
-            return false;  // all triplets before the last one must be just ":"
+            // all triplets before the last one must be just ":"
+            return std::nullopt;
           }
         } else {
           anyTriplet = true;
         }
+        ++rank;
       } else if (anyTriplet || subscript[j].Rank() > 0) {
-        return false;
+        return std::nullopt;
       }
     }
-    return true;
+    return rank;
   }
 
   const IntrinsicProcTable &table_;

diff --git a/flang/test/semantics/assign03.f90 b/flang/test/semantics/assign03.f90
index 08070fd..7c48953 100644 (file)
--- a/flang/test/semantics/assign03.f90
+++ b/flang/test/semantics/assign03.f90
@@ -142,12 +142,22 @@ contains
     end type
     type(t), target :: x
     type(t), target :: y(10,10)
+    integer :: v(10)
     p(1:16) => x%a
+    p(1:8) => x%a(:,3:4)
     p(1:1) => x%b  ! We treat scalars as simply contiguous
+    p(1:1) => x%a(1,1)
+    p(1:1) => y(1,1)%a(1,1)
+    p(1:1) => y(:,1)%a(1,1)  ! Rank 1 RHS
     !ERROR: Pointer bounds remapping target must have rank 1 or be simply contiguous
     p(1:4) => x%a(::2,::2)
     !ERROR: Pointer bounds remapping target must have rank 1 or be simply contiguous
     p(1:100) => y(:,:)%b
+    !ERROR: Pointer bounds remapping target must have rank 1 or be simply contiguous
+    p(1:100) => y(:,:)%a(1,1)
+    !ERROR: Pointer bounds remapping target must have rank 1 or be simply contiguous
+    !ERROR: An array section with a vector subscript may not be a pointer target
+    p(1:4) => x%a(:,v)
   end
 
   subroutine s11
@@ -155,8 +165,31 @@ contains
     complex, pointer :: p(:)
     real, pointer :: q(:)
     p(1:100) => x(:,:)
+    q(1:10) => x(1,:)%im
     !ERROR: Pointer bounds remapping target must have rank 1 or be simply contiguous
     q(1:100) => x(:,:)%re
   end
 
+  ! Check is_contiguous, which is usually the same as when pointer bounds
+  ! remapping is used. If it's not simply contiguous it's not constant so
+  ! an error is reported.
+  subroutine s12
+    integer, pointer :: p(:)
+    type :: t
+      integer :: a(4, 4)
+      integer :: b
+    end type
+    type(t), target :: x
+    type(t), target :: y(10,10)
+    integer :: v(10)
+    logical, parameter :: l1 = is_contiguous(x%a(:,:))
+    logical, parameter :: l2 = is_contiguous(y(1,1)%a(1,1))
+    !ERROR: Must be a constant value
+    logical, parameter :: l3 = is_contiguous(y(:,1)%a(1,1))
+    !ERROR: Must be a constant value
+    logical, parameter :: l4 = is_contiguous(x%a(:,v))
+    !ERROR: Must be a constant value
+    logical, parameter :: l5 = is_contiguous(y(v,1)%a(1,1))
+  end
+
 end