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

[via flang-commits]

llvmbot wrote:


<!--LLVM PR SUMMARY COMMENT-->

@llvm/pr-subscribers-flang-semantics

Author: Peter Klausler (klausler)

<details>
<summary>Changes</summary>

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.

---
Full diff: https://github.com/llvm/llvm-project/pull/187524.diff


6 Files Affected:

- (modified) flang/include/flang/Support/Fortran-features.h (+1-1) 
- (modified) flang/lib/Semantics/check-call.cpp (+1) 
- (modified) flang/lib/Semantics/definable.cpp (+13-2) 
- (modified) flang/lib/Semantics/definable.h (+2-1) 
- (modified) flang/lib/Support/Fortran-features.cpp (+1) 
- (added) flang/test/Semantics/bug181353.f90 (+29) 


``````````diff
diff --git a/flang/include/flang/Support/Fortran-features.h b/flang/include/flang/Support/Fortran-features.h
index ce35e06091bfd..f7dc966500fbb 100644
--- a/flang/include/flang/Support/Fortran-features.h
+++ b/flang/include/flang/Support/Fortran-features.h
@@ -83,7 +83,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>;
diff --git a/flang/lib/Semantics/check-call.cpp b/flang/lib/Semantics/check-call.cpp
index fb459be0933af..2dd47508a0b3f 100644
--- a/flang/lib/Semantics/check-call.cpp
+++ b/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) {
diff --git a/flang/lib/Semantics/definable.cpp b/flang/lib/Semantics/definable.cpp
index de16422b89abd..aabf830f0681b 100644
--- a/flang/lib/Semantics/definable.cpp
+++ b/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 an impure FINAL procedure and must be definable in this pure context"_warn_en_US,
+              original.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)}) {
diff --git a/flang/lib/Semantics/definable.h b/flang/lib/Semantics/definable.h
index 0d027961417be..816dad3c17fab 100644
--- a/flang/lib/Semantics/definable.h
+++ b/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>;
diff --git a/flang/lib/Support/Fortran-features.cpp b/flang/lib/Support/Fortran-features.cpp
index 79fa807af06a6..833b0d5b7aa14 100644
--- a/flang/lib/Support/Fortran-features.cpp
+++ b/flang/lib/Support/Fortran-features.cpp
@@ -154,6 +154,7 @@ LanguageFeatureControl::LanguageFeatureControl() {
   warnLanguage_.set(LanguageFeature::NullActualForAllocatable);
   warnUsage_.set(UsageWarning::BadValueInDeadCode);
   warnUsage_.set(UsageWarning::MisplacedIgnoreTKR);
+  warnUsage_.set(UsageWarning::ImpureFinalInPure);
 }
 
 std::optional<LanguageControlFlag> LanguageFeatureControl::FindWarning(
diff --git a/flang/test/Semantics/bug181353.f90 b/flang/test/Semantics/bug181353.f90
new file mode 100644
index 0000000000000..53be2caf8c125
--- /dev/null
+++ b/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 an impure FINAL procedure and must be definable in this pure context
+    call outer%inner%set()
+  end
+end

``````````

</details>


https://github.com/llvm/llvm-project/pull/187524