[flang-commits] [flang] 7efec1a - [flang] Don't emit spurious error for polymorphic actual argument in PURE

[Peter Klausler via flang-commits]

Author: Peter Klausler
Date: 2022-12-02T13:17:06-08:00
New Revision: 7efec1a40a9a0b7dd43cb4dbbd3b1285741d240b

URL: https://github.com/llvm/llvm-project/commit/7efec1a40a9a0b7dd43cb4dbbd3b1285741d240b
DIFF: https://github.com/llvm/llvm-project/commit/7efec1a40a9a0b7dd43cb4dbbd3b1285741d240b.diff

LOG: [flang] Don't emit spurious error for polymorphic actual argument in PURE

Definability checking is unconditionally flagging the use of a polymorphic
variable as an actual argument for a procedure reference in a PURE subprogram
unless the corresponding dummy is INTENT(IN).  This isn't necessary, since
an INTENT(OUT) polymorphic dummy is already caught as an error in the definition
of the callee, which must also be PURE; and an INTENT(IN OUT) or intent-free
dummy is allowed to be passed a polymorphic actual in a PURE context, with
any attempt to deallocate it being caught in the callee.

So add a flag to the definability checker to disable the "polymorphic
definition in PURE context" check when using it to check actual arguments.

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

Added: 
    flang/test/Semantics/call28.f90

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

Removed: 
    


################################################################################
diff  --git a/flang/lib/Semantics/check-call.cpp b/flang/lib/Semantics/check-call.cpp
index 37db60fab7fb..773d0ebb740b 100644
--- a/flang/lib/Semantics/check-call.cpp
+++ b/flang/lib/Semantics/check-call.cpp
@@ -391,22 +391,25 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
   }
 
   // Definability
-  const char *reason{nullptr};
-  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;
-    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 (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));
+        }
       }
     }
   }

diff  --git a/flang/lib/Semantics/definable.cpp b/flang/lib/Semantics/definable.cpp
index 33dcc85c6e76..32fe384f44bd 100644
--- a/flang/lib/Semantics/definable.cpp
+++ b/flang/lib/Semantics/definable.cpp
@@ -149,7 +149,8 @@ static std::optional<parser::Message> WhyNotDefinableLast(parser::CharBlock at,
         "'%s' is an entity with either an EVENT_TYPE or LOCK_TYPE"_en_US,
         original);
   }
-  if (FindPureProcedureContaining(scope)) {
+  if (!flags.test(DefinabilityFlag::PolymorphicOkInPure) &&
+      FindPureProcedureContaining(scope)) {
     if (auto dyType{evaluate::DynamicType::From(ultimate)}) {
       if (dyType->IsPolymorphic()) { // C1596
         return BlameSymbol(at,

diff  --git a/flang/lib/Semantics/definable.h b/flang/lib/Semantics/definable.h
index 7ef9ba8b33c1..e4c94e3d7c5a 100644
--- a/flang/lib/Semantics/definable.h
+++ b/flang/lib/Semantics/definable.h
@@ -27,7 +27,8 @@ class Scope;
 
 ENUM_CLASS(DefinabilityFlag,
     VectorSubscriptIsOk, // a vector subscript may appear (i.e., assignment)
-    PointerDefinition) // a pointer is being defined, not its target
+    PointerDefinition, // a pointer is being defined, not its target
+    PolymorphicOkInPure) // don't check for polymorphic type in pure subprogram
 
 using DefinabilityFlags =
     common::EnumSet<DefinabilityFlag, DefinabilityFlag_enumSize>;

diff  --git a/flang/test/Semantics/call28.f90 b/flang/test/Semantics/call28.f90
new file mode 100644
index 000000000000..4b7a52ed4a01
--- /dev/null
+++ b/flang/test/Semantics/call28.f90
@@ -0,0 +1,22 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1
+
+module m1
+  type :: t
+  end type
+ contains
+  pure subroutine s1(x)
+    class(t), intent(in out) :: x
+    call s2(x)
+    call s3(x)
+  end subroutine
+  pure subroutine s2(x)
+    class(t), intent(in out) :: x
+    !ERROR: Left-hand side of assignment is not definable
+    !BECAUSE: 'x' is polymorphic in a pure subprogram
+    x = t()
+  end subroutine
+  pure subroutine s3(x)
+    !ERROR: An INTENT(OUT) dummy argument of a pure subroutine may not be polymorphic
+    class(t), intent(out) :: x
+  end subroutine
+end module