[flang] Accept proc ptr function result as actual argument without IN… (#128771)

…TENT

A dummy procedure pointer with no INTENT attribute may associate with an
actual argument that is the result of a reference to a function that
returns a procedure pointer, we think.

Fixes #126950.

Author: klausler

flang/lib/Semantics/check-call.cpp

@@ -1049,8 +1049,8 @@ static void CheckProcedureArg(evaluate::ActualArgument &arg,
     SemanticsContext &context, bool ignoreImplicitVsExplicit) {
   evaluate::FoldingContext &foldingContext{context.foldingContext()};
   parser::ContextualMessages &messages{foldingContext.messages()};
-  auto restorer{
-      messages.SetLocation(arg.sourceLocation().value_or(messages.at()))};
+  parser::CharBlock location{arg.sourceLocation().value_or(messages.at())};
+  auto restorer{messages.SetLocation(location)};
   const characteristics::Procedure &interface { dummy.procedure.value() };
   if (const auto *expr{arg.UnwrapExpr()}) {
     bool dummyIsPointer{
@@ -1175,22 +1175,30 @@ static void CheckProcedureArg(evaluate::ActualArgument &arg,
             dummyName);
       }
     }
-    if (dummyIsPointer && dummy.intent != common::Intent::In) {
-      const Symbol *last{GetLastSymbol(*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
+    if (dummyIsPointer) {
+      if (dummy.intent == common::Intent::In) {
+        // need not be definable, can be a target
+      } else if (!IsProcedurePointer(*expr)) {
         messages.Say(
-            "Actual argument associated with procedure pointer %s must be a pointer unless INTENT(IN)"_err_en_US,
+            "Actual argument associated with procedure pointer %s is not a procedure pointer"_err_en_US,
             dummyName);
+      } else if (dummy.intent == common::Intent::Default) {
+        // ok, needs to be definable only if defined at run time
+      } else {
+        DefinabilityFlags flags{DefinabilityFlag::PointerDefinition};
+        if (dummy.intent != common::Intent::Out) {
+          flags.set(DefinabilityFlag::DoNotNoteDefinition);
+        }
+        if (auto whyNot{WhyNotDefinable(
+                location, context.FindScope(location), flags, *expr)}) {
+          if (auto *msg{messages.Say(
+                  "Actual argument associated with INTENT(%s) procedure pointer %s is not definable"_err_en_US,
+                  dummy.intent == common::Intent::Out ? "OUT" : "IN OUT",
+                  dummyName)}) {
+            msg->Attach(
+                std::move(whyNot->set_severity(parser::Severity::Because)));
+          }
+        }
       }
     }
   } else {

flang/test/Semantics/call09.f90

@@ -82,27 +82,26 @@ subroutine test1 ! 15.5.2.9(5)
     call s01(null(intPtr))
     !ERROR: Actual argument associated with procedure dummy argument 'p=' is typeless
     call s01(B"0101")
-    !ERROR: Actual argument associated with procedure pointer dummy argument 'p=' must be a pointer unless INTENT(IN)
+    !ERROR: Actual argument associated with procedure pointer dummy argument 'p=' is not a procedure pointer
     call s02(realfunc)
     call s02(p) ! ok
     !ERROR: Actual procedure argument has interface incompatible with dummy argument 'p=': function results have distinct types: REAL(4) vs INTEGER(4)
     call s02(ip)
-    !ERROR: Actual argument associated with procedure pointer dummy argument 'p=' must be a pointer unless INTENT(IN)
-    call s02(procptr())
+    call s02(procptr()) ! believed to be ok
     call s02(null()) ! ok
-    !ERROR: Actual argument associated with procedure pointer dummy argument 'p=' must be a pointer unless INTENT(IN)
+    !ERROR: Actual argument associated with INTENT(IN OUT) procedure pointer dummy argument 'p=' is not definable
+    !BECAUSE: 'NULL()' is a null pointer
     call s05(null())
-    !ERROR: Actual argument associated with procedure pointer dummy argument 'p=' must be a pointer unless INTENT(IN)
+    !ERROR: Actual argument associated with procedure pointer dummy argument 'p=' is not a procedure pointer
     call s02(sin)
-    !ERROR: Actual argument associated with procedure pointer dummy argument 'p=' must be a pointer unless INTENT(IN)
+    !ERROR: Actual argument associated with procedure pointer dummy argument 'p=' is not a procedure pointer
     call s02b(realfunc)
     call s02b(p) ! ok
     !ERROR: Actual argument function associated with procedure dummy argument 'p=' is not compatible: function results have distinct types: REAL(4) vs INTEGER(4)
     call s02b(ip)
-    !ERROR: Actual argument associated with procedure pointer dummy argument 'p=' must be a pointer unless INTENT(IN)
-    call s02b(procptr())
+    call s02b(procptr()) ! believed to be ok
     call s02b(null())
-    !ERROR: Actual argument associated with procedure pointer dummy argument 'p=' must be a pointer unless INTENT(IN)
+    !ERROR: Actual argument associated with procedure pointer dummy argument 'p=' is not a procedure pointer
     call s02b(sin)
   end subroutine
 

flang/test/Semantics/call24.f90

@@ -39,7 +39,7 @@ subroutine test()
   !ERROR: References to the procedure 'bar' require an explicit interface
   !BECAUSE: a dummy procedure is optional or a pointer
   !WARNING: If the procedure's interface were explicit, this reference would be in error
-  !BECAUSE: Actual argument associated with procedure pointer dummy argument 'a_pointer=' must be a pointer unless INTENT(IN)
+  !BECAUSE: Actual argument associated with procedure pointer dummy argument 'a_pointer=' is not a procedure pointer
   call bar(sin)
 
   !ERROR: References to the procedure 'baz' require an explicit interface

flang/test/Semantics/definable01.f90

@@ -77,7 +77,8 @@ subroutine test3(objp, 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)
+    !CHECK: error: Actual argument associated with INTENT(IN OUT) procedure pointer dummy argument 'pp=' is not definable
+    !CHECK: because: 'procp' is an INTENT(IN) dummy argument
     call test3b(procp)
   end subroutine
   subroutine test3a(op)