[flang-commits] [flang] 066aecf - [flang] INTENT(IN) pointer may not be forwarded to INTENT(IN OUT) or (OUT) dummy

[Peter Klausler via flang-commits]

Author: Peter Klausler
Date: 2022-12-03T16:28:17-08:00
New Revision: 066aecff9272bdb0c02ff9379ede1bdbd854880e

URL: https://github.com/llvm/llvm-project/commit/066aecff9272bdb0c02ff9379ede1bdbd854880e
DIFF: https://github.com/llvm/llvm-project/commit/066aecff9272bdb0c02ff9379ede1bdbd854880e.diff

LOG: [flang] INTENT(IN) pointer may not be forwarded to INTENT(IN OUT) or (OUT) dummy

19.6.8 forbids using an INTENT(IN) pointer dummy argument in a pointer association
context, and associated such a pointer with a dummy argument of INTENT(IN OUT) or
INTENT(OUT) is a circumstance that needs to be caught as an error.

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

Added: 
    flang/test/Semantics/definable01.f90

Modified: 
    flang/lib/Semantics/check-call.cpp

Removed: 
    flang/test/Semantics/modifiable01.f90


################################################################################
diff  --git a/flang/lib/Semantics/check-call.cpp b/flang/lib/Semantics/check-call.cpp
index 5c12cea565d7a..9fa8e995273ea 100644
--- a/flang/lib/Semantics/check-call.cpp
+++ b/flang/lib/Semantics/check-call.cpp
@@ -391,25 +391,28 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
   }
 
   // Definability
-  if (scope) {
-    const char *reason{nullptr};
+  const char *reason{nullptr};
+  if (dummy.intent == common::Intent::Out) {
+    reason = "INTENT(OUT)";
+  } else if (dummy.intent == common::Intent::InOut) {
+    reason = "INTENT(IN OUT)";
+  }
+  bool dummyIsPointer{
+      dummy.attrs.test(characteristics::DummyDataObject::Attr::Pointer)};
+  if (reason && scope) {
     // Problems with polymorphism are caught in the callee's definition.
     DefinabilityFlags flags{DefinabilityFlag::PolymorphicOkInPure};
-    if (dummy.intent == common::Intent::Out) {
-      reason = "INTENT(OUT)";
-    } else if (dummy.intent == common::Intent::InOut) {
-      reason = "INTENT(IN OUT)";
+    if (isElemental || dummyIsValue) { // 15.5.2.4(21)
+      flags.set(DefinabilityFlag::VectorSubscriptIsOk);
     }
-    if (reason) {
-      if (isElemental || dummyIsValue) { // 15.5.2.4(21)
-        flags.set(DefinabilityFlag::VectorSubscriptIsOk);
-      }
-      if (auto whyNot{WhyNotDefinable(messages.at(), *scope, flags, actual)}) {
-        if (auto *msg{messages.Say(
-                "Actual argument associated with %s %s is not definable"_err_en_US,
-                reason, dummyName)}) {
-          msg->Attach(std::move(*whyNot));
-        }
+    if (actualIsPointer && dummyIsPointer) { // 19.6.8
+      flags.set(DefinabilityFlag::PointerDefinition);
+    }
+    if (auto whyNot{WhyNotDefinable(messages.at(), *scope, flags, actual)}) {
+      if (auto *msg{messages.Say(
+              "Actual argument associated with %s %s is not definable"_err_en_US,
+              reason, dummyName)}) {
+        msg->Attach(std::move(*whyNot));
       }
     }
   }
@@ -418,8 +421,6 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
   bool actualIsContiguous{IsSimplyContiguous(actual, context)};
   bool dummyIsAssumedShape{dummy.type.attrs().test(
       characteristics::TypeAndShape::Attr::AssumedShape)};
-  bool dummyIsPointer{
-      dummy.attrs.test(characteristics::DummyDataObject::Attr::Pointer)};
   bool dummyIsContiguous{
       dummy.attrs.test(characteristics::DummyDataObject::Attr::Contiguous)};
   if ((actualIsAsynchronous || actualIsVolatile) &&
@@ -691,9 +692,15 @@ static void CheckProcedureArg(evaluate::ActualArgument &arg,
     }
     if (dummyIsPointer && dummy.intent != common::Intent::In) {
       const Symbol *last{GetLastSymbol(*expr)};
-      if (!(last && IsProcedurePointer(*last)) &&
-          !(dummy.intent == common::Intent::Default &&
-              IsNullProcedurePointer(*expr))) {
+      if (last && IsProcedurePointer(*last)) {
+        if (dummy.intent != common::Intent::Default &&
+            IsIntentIn(last->GetUltimate())) { // 19.6.8
+          messages.Say(
+              "Actual argument associated with procedure pointer %s may not be INTENT(IN)"_err_en_US,
+              dummyName);
+        }
+      } else if (!(dummy.intent == common::Intent::Default &&
+                     IsNullProcedurePointer(*expr))) {
         // 15.5.2.9(5) -- dummy procedure POINTER
         // Interface compatibility has already been checked above
         messages.Say(

diff  --git a/flang/test/Semantics/modifiable01.f90 b/flang/test/Semantics/definable01.f90
similarity index 75%
rename from flang/test/Semantics/modifiable01.f90
rename to flang/test/Semantics/definable01.f90
index d6babc8735984..fff493fe7a415 100644
--- a/flang/test/Semantics/modifiable01.f90
+++ b/flang/test/Semantics/definable01.f90
@@ -1,5 +1,5 @@
 ! RUN: not %flang_fc1 -fsyntax-only %s 2>&1 | FileCheck %s
-! Test WhyNotModifiable() explanations
+! Test WhyNotDefinable() explanations
 
 module prot
   real, protected :: prot
@@ -67,4 +67,19 @@ pure subroutine test2(ptr)
     !CHECK: because: 'ptr' is externally visible via 'ptr' and not definable in a pure subprogram
     read(internal,*) ptr
   end subroutine
+  subroutine test3(objp, procp)
+    real, intent(in), pointer :: objp
+    procedure(sin), pointer, intent(in) :: procp
+    !CHECK: error: Actual argument associated with INTENT(IN OUT) dummy argument 'op=' is not definable
+    !CHECK: because: 'objp' is an INTENT(IN) dummy argument
+    call test3a(objp)
+    !CHECK: error: Actual argument associated with procedure pointer dummy argument 'pp=' may not be INTENT(IN)
+    call test3b(procp)
+  end subroutine
+  subroutine test3a(op)
+    real, intent(in out), pointer :: op
+  end subroutine
+  subroutine test3b(pp)
+    procedure(sin), pointer, intent(in out) :: pp
+  end subroutine
 end module