[flang-commits] [flang] [flang] Require contiguous actual pointer for contiguous dummy pointer (PR #139298)

[Peter Klausler via flang-commits]

https://github.com/klausler created https://github.com/llvm/llvm-project/pull/139298

When the actual argument associated with an explicitly CONTIGUOUS pointer dummy argument is itself a pointer, it must also be contiguous. (A non-pointer actual argument can associate with a CONTIGUOUS pointer dummy argument if it's INTENT(IN), and in that case it's still just a warning if we can't prove at compilation time that the actual is contiguous.)

Fixes https://github.com/llvm/llvm-project/issues/138899.

>From 1b38bdca8f6d8eac9166bb5ec0a809457736ee19 Mon Sep 17 00:00:00 2001
From: Peter Klausler <pklausler at nvidia.com>
Date: Fri, 9 May 2025 10:47:34 -0700
Subject: [PATCH] [flang] Require contiguous actual pointer for contiguous
 dummy pointer

When the actual argument associated with an explicitly CONTIGUOUS
pointer dummy argument is itself a pointer, it must also be contiguous.
(A non-pointer actual argument can associate with a CONTIGUOUS pointer
dummy argument if it's INTENT(IN), and in that case it's still just a
warning if we can't prove at compilation time that the actual is
contiguous.)

Fixes https://github.com/llvm/llvm-project/issues/138899.
---
 flang/lib/Semantics/check-call.cpp         |  9 +++++----
 flang/lib/Semantics/pointer-assignment.cpp | 15 ++++++++++++++-
 flang/lib/Semantics/pointer-assignment.h   |  2 +-
 flang/test/Semantics/call07.f90            |  4 +++-
 4 files changed, 23 insertions(+), 7 deletions(-)

diff --git a/flang/lib/Semantics/check-call.cpp b/flang/lib/Semantics/check-call.cpp
index 11928860fea5f..2b1881868b8b3 100644
--- a/flang/lib/Semantics/check-call.cpp
+++ b/flang/lib/Semantics/check-call.cpp
@@ -754,12 +754,13 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
     }
   }
 
-  // Cases when temporaries might be needed but must not be permitted.
+  bool dummyIsContiguous{
+      dummy.attrs.test(characteristics::DummyDataObject::Attr::Contiguous)};
   bool actualIsContiguous{IsSimplyContiguous(actual, foldingContext)};
+
+  // Cases when temporaries might be needed but must not be permitted.
   bool dummyIsAssumedShape{dummy.type.attrs().test(
       characteristics::TypeAndShape::Attr::AssumedShape)};
-  bool dummyIsContiguous{
-      dummy.attrs.test(characteristics::DummyDataObject::Attr::Contiguous)};
   if ((actualIsAsynchronous || actualIsVolatile) &&
       (dummyIsAsynchronous || dummyIsVolatile) && !dummyIsValue) {
     if (actualCoarrayRef) { // C1538
@@ -834,7 +835,7 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
       if (scope) {
         semantics::CheckPointerAssignment(context, messages.at(), dummyName,
             dummy, actual, *scope,
-            /*isAssumedRank=*/dummyIsAssumedRank);
+            /*isAssumedRank=*/dummyIsAssumedRank, actualIsPointer);
       }
     } else if (!actualIsPointer) {
       messages.Say(
diff --git a/flang/lib/Semantics/pointer-assignment.cpp b/flang/lib/Semantics/pointer-assignment.cpp
index 36c9c5b845706..18a61af8c56f3 100644
--- a/flang/lib/Semantics/pointer-assignment.cpp
+++ b/flang/lib/Semantics/pointer-assignment.cpp
@@ -59,6 +59,7 @@ class PointerAssignmentChecker {
   PointerAssignmentChecker &set_isBoundsRemapping(bool);
   PointerAssignmentChecker &set_isAssumedRank(bool);
   PointerAssignmentChecker &set_pointerComponentLHS(const Symbol *);
+  PointerAssignmentChecker &set_isRHSPointerActualArgument(bool);
   bool CheckLeftHandSide(const SomeExpr &);
   bool Check(const SomeExpr &);
 
@@ -94,6 +95,7 @@ class PointerAssignmentChecker {
   bool isVolatile_{false};
   bool isBoundsRemapping_{false};
   bool isAssumedRank_{false};
+  bool isRHSPointerActualArgument_{false};
   const Symbol *pointerComponentLHS_{nullptr};
 };
 
@@ -133,6 +135,12 @@ PointerAssignmentChecker &PointerAssignmentChecker::set_pointerComponentLHS(
   return *this;
 }
 
+PointerAssignmentChecker &
+PointerAssignmentChecker::set_isRHSPointerActualArgument(bool isPointerActual) {
+  isRHSPointerActualArgument_ = isPointerActual;
+  return *this;
+}
+
 bool PointerAssignmentChecker::CharacterizeProcedure() {
   if (!characterizedProcedure_) {
     characterizedProcedure_ = true;
@@ -221,6 +229,9 @@ bool PointerAssignmentChecker::Check(const SomeExpr &rhs) {
         Say("CONTIGUOUS pointer may not be associated with a discontiguous target"_err_en_US);
         return false;
       }
+    } else if (isRHSPointerActualArgument_) {
+      Say("CONTIGUOUS pointer dummy argument may not be associated with non-CONTIGUOUS pointer actual argument"_err_en_US);
+      return false;
     } else {
       Warn(common::UsageWarning::PointerToPossibleNoncontiguous,
           "Target of CONTIGUOUS pointer association is not known to be contiguous"_warn_en_US);
@@ -585,12 +596,14 @@ bool CheckStructConstructorPointerComponent(SemanticsContext &context,
 
 bool CheckPointerAssignment(SemanticsContext &context, parser::CharBlock source,
     const std::string &description, const DummyDataObject &lhs,
-    const SomeExpr &rhs, const Scope &scope, bool isAssumedRank) {
+    const SomeExpr &rhs, const Scope &scope, bool isAssumedRank,
+    bool isPointerActualArgument) {
   return PointerAssignmentChecker{context, scope, source, description}
       .set_lhsType(common::Clone(lhs.type))
       .set_isContiguous(lhs.attrs.test(DummyDataObject::Attr::Contiguous))
       .set_isVolatile(lhs.attrs.test(DummyDataObject::Attr::Volatile))
       .set_isAssumedRank(isAssumedRank)
+      .set_isRHSPointerActualArgument(isPointerActualArgument)
       .Check(rhs);
 }
 
diff --git a/flang/lib/Semantics/pointer-assignment.h b/flang/lib/Semantics/pointer-assignment.h
index 269d64112fd29..ad7c6554d5a13 100644
--- a/flang/lib/Semantics/pointer-assignment.h
+++ b/flang/lib/Semantics/pointer-assignment.h
@@ -31,7 +31,7 @@ bool CheckPointerAssignment(SemanticsContext &, const SomeExpr &lhs,
 bool CheckPointerAssignment(SemanticsContext &, parser::CharBlock source,
     const std::string &description,
     const evaluate::characteristics::DummyDataObject &, const SomeExpr &rhs,
-    const Scope &, bool isAssumedRank);
+    const Scope &, bool isAssumedRank, bool IsPointerActualArgument);
 
 bool CheckStructConstructorPointerComponent(
     SemanticsContext &, const Symbol &lhs, const SomeExpr &rhs, const Scope &);
diff --git a/flang/test/Semantics/call07.f90 b/flang/test/Semantics/call07.f90
index 3b5c2838fadf7..92f2bdba882d5 100644
--- a/flang/test/Semantics/call07.f90
+++ b/flang/test/Semantics/call07.f90
@@ -27,8 +27,10 @@ subroutine test
     !PORTABILITY: CONTIGUOUS entity 'scalar' should be an array pointer, assumed-shape, or assumed-rank
     real, contiguous :: scalar
     call s01(a03) ! ok
-    !WARNING: Target of CONTIGUOUS pointer association is not known to be contiguous
+    !ERROR: CONTIGUOUS pointer dummy argument may not be associated with non-CONTIGUOUS pointer actual argument
     call s01(a02)
+    !WARNING: Target of CONTIGUOUS pointer association is not known to be contiguous
+    call s01(a02(:))
     !ERROR: CONTIGUOUS pointer may not be associated with a discontiguous target
     call s01(a03(::2))
     call s02(a02) ! ok