[flang] Downgrade an overly strict error to a warning (#187524)

Fortran allows a PURE subroutine to have dummy argument with INTENT(IN
OUT). An actual argument that is associated with an INTENT(IN OUT) dummy
argument must be definable. Consequently, there's a hole in the language
that allows a PURE subroutine to modify arbitrary global state: the
argument could have a derived type with an impure FINAL subroutine, and
that FINAL subroutine could be invoked by an assignment to the dummy
argument. I consider this to be a mistake in the language design.

So the compiler was reporting this case as an error, although it is
indeed conforming usage, and not flagged by any other compiler.
Unfortunately, somebody has a code that needs this usage to be accepted,
because (I presume) they can't modify the dummy argument to be
INTENT(IN).

Consequently, we'll need to allow this usage. But it will elicit a
warning, and the warning is on by default.

flang/include/flang/Support/Fortran-features.h

@@ -84,7 +84,7 @@ ENUM_CLASS(UsageWarning, Portability, PointerToUndefinable,
     HostAssociatedIntentOutInSpecExpr, NonVolatilePointerToVolatile,
     RealConstantWidening, VolatileOrAsynchronousTemporary, UnusedVariable,
     UsedUndefinedVariable, BadValueInDeadCode, AssumedTypeSizeDummy,
-    MisplacedIgnoreTKR, NamelistParameter)
+    MisplacedIgnoreTKR, NamelistParameter, ImpureFinalInPure)
 
 using LanguageFeatures = EnumSet<LanguageFeature, LanguageFeature_enumSize>;
 using UsageWarnings = EnumSet<UsageWarning, UsageWarning_enumSize>;

flang/lib/Semantics/check-call.cpp

@@ -766,6 +766,7 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
     DefinabilityFlags flags{DefinabilityFlag::PolymorphicOkInPure};
     if (dummy.intent == common::Intent::InOut) {
       flags.set(DefinabilityFlag::AllowEventLockOrNotifyType);
+      flags.set(DefinabilityFlag::OnlyWarnOnImpureFinalInPureContext);
       undefinableMessage =
           "Actual argument associated with INTENT(IN OUT) %s is not definable"_err_en_US;
     } else if (dummy.intent == common::Intent::Out) {

flang/lib/Semantics/definable.cpp

@@ -220,8 +220,19 @@ static std::optional<parser::Message> WhyNotDefinableLast(parser::CharBlock at,
   }
   if (dyType && inPure) {
     if (const Symbol * impure{HasImpureFinal(ultimate)}) {
-      return BlameSymbol(at, "'%s' has an impure FINAL procedure '%s'"_en_US,
-          original, impure->name());
+      if (flags.test(DefinabilityFlag::OnlyWarnOnImpureFinalInPureContext)) {
+        if (scope.context().ShouldWarn(
+                common::UsageWarning::ImpureFinalInPure)) {
+          parser::Message message{at,
+              "'%s' has impure FINAL procedure '%s' and must be definable in this pure context"_warn_en_US,
+              original.name(), impure->name()};
+          evaluate::AttachDeclaration(message, original);
+          return message;
+        }
+      } else {
+        return BlameSymbol(at, "'%s' has an impure FINAL procedure '%s'"_en_US,
+            original, impure->name());
+      }
     }
     if (!flags.test(DefinabilityFlag::PolymorphicOkInPure)) {
       if (const DerivedTypeSpec * derived{GetDerivedTypeSpec(dyType)}) {

flang/lib/Semantics/definable.h

@@ -33,7 +33,8 @@ ENUM_CLASS(DefinabilityFlag,
     SourcedAllocation, // ALLOCATE(a,SOURCE=)
     PolymorphicOkInPure, // don't check for polymorphic type in pure subprogram
     DoNotNoteDefinition, // context does not imply definition
-    AllowEventLockOrNotifyType, PotentialDeallocation)
+    AllowEventLockOrNotifyType, PotentialDeallocation,
+    OnlyWarnOnImpureFinalInPureContext)
 
 using DefinabilityFlags =
     common::EnumSet<DefinabilityFlag, DefinabilityFlag_enumSize>;

flang/lib/Support/Fortran-features.cpp

@@ -161,6 +161,7 @@ LanguageFeatureControl::LanguageFeatureControl() {
   warnLanguage_.set(LanguageFeature::NullActualForAllocatable);
   warnUsage_.set(UsageWarning::BadValueInDeadCode);
   warnUsage_.set(UsageWarning::MisplacedIgnoreTKR);
+  warnUsage_.set(UsageWarning::ImpureFinalInPure);
   warnLanguage_.set(LanguageFeature::OpenMPThreadprivateEquivalence);
 }
 

flang/test/Semantics/bug181353.f90

@@ -0,0 +1,29 @@
+!RUN: %python %S/test_errors.py %s %flang_fc1 -Werror
+module m
+  type impure_t
+   contains
+    final :: finalize
+  end type
+  type inner_t
+    type(impure_t) :: impure
+   contains
+    procedure :: set => inner_set
+  end type
+  type outer_t
+    type(inner_t) :: inner
+  end type
+  interface
+    module subroutine finalize(this)
+      type(impure_t), intent(inout) :: this
+    end
+    pure module subroutine inner_set(this)
+      class(inner_t), intent(inout) :: this
+    end
+  end interface
+ contains
+  pure subroutine test(outer)
+    type(outer_t), intent(inout) :: outer
+    !WARNING: 'inner' has impure FINAL procedure 'finalize' and must be definable in this pure context
+    call outer%inner%set()
+  end
+end