[flang-commits] [flang] 6bc14f2 - [flang] Foil attempts to require interoperable pointers be CONTIGUOUS

[Peter Klausler via flang-commits]

Author: Peter Klausler
Date: 2023-08-08T11:44:46-07:00
New Revision: 6bc14f238e4b1b44080dbe53bc394bd3c584ba39

URL: https://github.com/llvm/llvm-project/commit/6bc14f238e4b1b44080dbe53bc394bd3c584ba39
DIFF: https://github.com/llvm/llvm-project/commit/6bc14f238e4b1b44080dbe53bc394bd3c584ba39.diff

LOG: [flang] Foil attempts to require interoperable pointers be CONTIGUOUS

BIND(C) interoperable pointer descriptors may not be required to be
CONTIGUOUS in procedure interfaces.

(Also fixed erroneous true result from IsDescriptor() predicate for
assumed-size arrays that was exposed by testing.)

Fixes llvm-test-suite/Fortran/gfortran/regression/bind_c_contiguous.f90.

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

Added: 
    flang/test/Semantics/bind-c13.f90

Modified: 
    flang/lib/Evaluate/type.cpp
    flang/lib/Semantics/check-declarations.cpp

Removed: 
    


################################################################################
diff  --git a/flang/lib/Evaluate/type.cpp b/flang/lib/Evaluate/type.cpp
index 12e931afddf4dc..cdded9677d73c6 100644
--- a/flang/lib/Evaluate/type.cpp
+++ b/flang/lib/Evaluate/type.cpp
@@ -34,13 +34,23 @@ static bool IsDescriptor(const DeclTypeSpec *type) {
 }
 
 static bool IsDescriptor(const ObjectEntityDetails &details) {
-  if (IsDescriptor(details.type())) {
+  if (IsDescriptor(details.type()) || details.IsAssumedRank()) {
     return true;
   }
+  std::size_t j{0};
   for (const ShapeSpec &shapeSpec : details.shape()) {
-    const auto &lb{shapeSpec.lbound().GetExplicit()};
-    const auto &ub{shapeSpec.ubound().GetExplicit()};
-    if (!lb || !ub || !IsConstantExpr(*lb) || !IsConstantExpr(*ub)) {
+    ++j;
+    if (const auto &lb{shapeSpec.lbound().GetExplicit()};
+        !lb || !IsConstantExpr(*lb)) {
+      return true;
+    }
+    if (const auto &ub{shapeSpec.ubound().GetExplicit()}) {
+      if (!IsConstantExpr(*ub)) {
+        return true;
+      }
+    } else if (j == details.shape().size() && details.isDummy()) {
+      // assumed size array
+    } else {
       return true;
     }
   }

diff  --git a/flang/lib/Semantics/check-declarations.cpp b/flang/lib/Semantics/check-declarations.cpp
index 3713990a9823f7..9c215ed8738223 100644
--- a/flang/lib/Semantics/check-declarations.cpp
+++ b/flang/lib/Semantics/check-declarations.cpp
@@ -2720,6 +2720,11 @@ void CheckHelper::CheckBindC(const Symbol &symbol) {
       WarnIfNotInModuleFile(symbol.name(),
           "An interoperable procedure with an OPTIONAL dummy argument might not be portable"_port_en_US);
     }
+    if (IsDescriptor(symbol) && IsPointer(symbol) &&
+        symbol.attrs().test(Attr::CONTIGUOUS)) {
+      messages_.Say(symbol.name(),
+          "An interoperable pointer must not be CONTIGUOUS"_err_en_US);
+    }
   } else if (const auto *proc{symbol.detailsIf<ProcEntityDetails>()}) {
     if (!proc->procInterface() ||
         !proc->procInterface()->attrs().test(Attr::BIND_C)) {

diff  --git a/flang/test/Semantics/bind-c13.f90 b/flang/test/Semantics/bind-c13.f90
new file mode 100644
index 00000000000000..14e20a36f4f33c
--- /dev/null
+++ b/flang/test/Semantics/bind-c13.f90
@@ -0,0 +1,12 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1
+! Interoperable objects that require descriptors cannot be CONTIGUOUS
+subroutine interop(ptr,ashape,arank,eshape,asize) bind(c)
+  !ERROR: An interoperable pointer must not be CONTIGUOUS
+  real, pointer, contiguous :: ptr(:)
+  real, contiguous :: ashape(:) ! ok
+  real, contiguous :: arank(..) ! ok
+  !ERROR: CONTIGUOUS entity 'eshape' must be an array pointer, assumed-shape, or assumed-rank
+  real, contiguous :: eshape(10)
+  !ERROR: CONTIGUOUS entity 'asize' must be an array pointer, assumed-shape, or assumed-rank
+  real, contiguous :: asize(*)
+end