[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

diff --git a/flang/lib/Semantics/check-call.cpp b/flang/lib/Semantics/check-call.cpp
index 37db60f..773d0eb 100644 (file)
--- 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 33dcc85..32fe384 100644 (file)
--- 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 7ef9ba8..e4c94e3 100644 (file)
--- 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 (file)
index 0000000..4b7a52e
--- /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