[flang-commits] [PATCH] D139138: [flang] INTENT(IN) pointer may not be forwarded to INTENT(IN OUT) or (OUT) dummy

[Peter Klausler via Phabricator via flang-commits]

klausler created this revision.
klausler added a reviewer: clementval.
klausler added a project: Flang.
Herald added a subscriber: jdoerfert.
Herald added a project: All.
klausler requested review of this revision.

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.


https://reviews.llvm.org/D139138

Files:
  flang/lib/Semantics/check-call.cpp
  flang/test/Semantics/definable01.f90
  flang/test/Semantics/modifiable01.f90


Index: flang/test/Semantics/definable01.f90
===================================================================
--- flang/test/Semantics/definable01.f90
+++ 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 @@
     !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
Index: flang/lib/Semantics/check-call.cpp
===================================================================
--- flang/lib/Semantics/check-call.cpp
+++ flang/lib/Semantics/check-call.cpp
@@ -392,16 +392,22 @@
 
   // Definability
   const char *reason{nullptr};
+  bool dummyIsPointer{
+      dummy.attrs.test(characteristics::DummyDataObject::Attr::Pointer)};
   if (dummy.intent == common::Intent::Out) {
     reason = "INTENT(OUT)";
   } else if (dummy.intent == common::Intent::InOut) {
     reason = "INTENT(IN OUT)";
   }
   if (reason && scope) {
-    DefinabilityFlags flags;
+    // Problems with polymorphism are caught in the callee's definition.
+    DefinabilityFlags flags{DefinabilityFlag::PolymorphicOkInPure};
     if (isElemental || dummyIsValue) { // 15.5.2.4(21)
       flags.set(DefinabilityFlag::VectorSubscriptIsOk);
     }
+    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,
@@ -415,8 +421,6 @@
   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) &&
@@ -684,9 +688,15 @@
     }
     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(


-------------- next part --------------
A non-text attachment was scrubbed...
Name: D139138.479396.patch
Type: text/x-patch
Size: 3713 bytes
Desc: not available
URL: <http://lists.llvm.org/pipermail/flang-commits/attachments/20221201/a0858f32/attachment.bin>