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

[klausler]

Summary

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.

[PeteSteinfeld]

All builds and tests correctly and looks good.

flang/lib/Semantics/check-call.cpp

if (actualLastObject && actualLastObject->IsCoarray() &&
           evaluate::AcceptsIntentOutAllocatableCoarray(
               intrinsic->name))) { // C846
     messages.Say(
         "ALLOCATABLE coarray '%s' may not be associated with INTENT(OUT) %s"_err_en_US,
         actualLastSymbol->name(), dummyName);
   }
 
   // Definability
+  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 && scope) {
-    DefinabilityFlags flags;
+    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));
         }
       }
     }
+  }
 
   // Cases when temporaries might be needed but must not be permitted.
   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{

flang/lib/Semantics/definable.h

 
 namespace Fortran::semantics {
 
 class Symbol;
 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>;
 
 // Tests a symbol or LHS variable or pointer for definability in a given scope.
 // When the entity is not definable, returns a "because:" Message suitable for
 // attachment to an error message to explain why the entity cannot be defined.
 // When the entity can be defined in that context, returns std::nullopt.

flang/lib/Semantics/definable.cpp

if (flags.test(DefinabilityFlag::PointerDefinition)) {
     }
     return std::nullopt; // pointer assignment - skip following checks
   }
   if (IsOrContainsEventOrLockComponent(ultimate)) {
     return BlameSymbol(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,
             "'%s' is polymorphic in a pure subprogram"_because_en_US, original);
       }
       if (const DerivedTypeSpec * derived{GetDerivedTypeSpec(dyType)}) {
         if (auto bad{FindPolymorphicAllocatableNonCoarrayUltimateComponent(
                 *derived)}) {

flang/test/Semantics/call28.f90

+! 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