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

[klausler]

Summary

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.

flang/lib/Semantics/check-call.cpp

if (actualLastObject && actualLastObject->IsCoarray() &&
           evaluate::AcceptsIntentOutAllocatableCoarray(
               intrinsic->name))) { // C846
     messages.Say(
         "ALLOCATABLE coarray '%s' may not be associated with INTENT(OUT) %s"_err_en_US,
         actualLastSymbol->name(), dummyName);
   }
 
   // Definability
-  if (scope) {
-    const char *reason{nullptr};
-    // 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 (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));
-        }
-      }
-    }
-  }
+  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 (actualIsPointer && dummyIsPointer) { // 19.6.8
+      flags.set(DefinabilityFlag::PointerDefinition);
+    }
 
   // Cases when temporaries might be needed but must not be permitted.
   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) &&
       (dummyIsAsynchronous || dummyIsVolatile) && !dummyIsValue) {
     if (actualIsCoindexed) { // C1538
       messages.Say(
           "Coindexed ASYNCHRONOUS or VOLATILE actual argument may not be associated with %s with ASYNCHRONOUS or VOLATILE attributes unless VALUE"_err_en_US,
           dummyName);
if (auto argChars{characteristics::DummyArgument::FromActual(
       } else {
         messages.Say(
             "Actual argument associated with procedure %s is typeless"_err_en_US,
             dummyName);
       }
     }
     if (dummyIsPointer && dummy.intent != common::Intent::In) {
       const Symbol *last{GetLastSymbol(*expr)};
-      if (!(last && IsProcedurePointer(*last)) &&
-          !(dummy.intent == common::Intent::Default &&
+      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(
             "Actual argument associated with procedure pointer %s must be a POINTER unless INTENT(IN)"_err_en_US,
             dummyName);
       }
     }
   } else {

flang/test/Semantics/definable01.f90

 ! RUN: not %flang_fc1 -fsyntax-only %s 2>&1 | FileCheck %s
-! Test WhyNotModifiable() explanations
+! Test WhyNotDefinable() explanations
 
 module prot
   real, protected :: prot
   type :: ptype
     real, pointer :: ptr
     real :: x
   end type
   type(ptype), protected :: protptr
subroutine test1(dummy)
     dummy%ptr = 0. ! ok
   end subroutine
   pure subroutine test2(ptr)
     integer, pointer, intent(in) :: ptr
     !CHECK: error: Input variable 'ptr' is not definable
     !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