[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

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 (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 (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 (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));
+        }
       }
     }
   }

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,

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>;

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