From c5aefc77534bafe28b40618d77fa0ef6eac3d777 Mon Sep 17 00:00:00 2001 From: Peter Klausler Date: Thu, 19 Mar 2026 15:27:01 -0500 Subject: [PATCH] [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. --- .../include/flang/Support/Fortran-features.h | 2 +- flang/lib/Semantics/check-call.cpp | 1 + flang/lib/Semantics/definable.cpp | 15 ++++++++-- flang/lib/Semantics/definable.h | 3 +- flang/lib/Support/Fortran-features.cpp | 1 + flang/test/Semantics/bug181353.f90 | 29 +++++++++++++++++++ 6 files changed, 47 insertions(+), 4 deletions(-) create mode 100644 flang/test/Semantics/bug181353.f90 diff --git a/flang/include/flang/Support/Fortran-features.h b/flang/include/flang/Support/Fortran-features.h index feadc11ab7f8..f2bd0d21f25b 100644 --- a/flang/include/flang/Support/Fortran-features.h +++ b/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; using UsageWarnings = EnumSet; diff --git a/flang/lib/Semantics/check-call.cpp b/flang/lib/Semantics/check-call.cpp index fb459be0933a..2dd47508a0b3 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 de16422b89ab..fdb4a2dcf880 100644 --- a/flang/lib/Semantics/definable.cpp +++ b/flang/lib/Semantics/definable.cpp @@ -220,8 +220,19 @@ static std::optional 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)}) { diff --git a/flang/lib/Semantics/definable.h b/flang/lib/Semantics/definable.h index 0d027961417b..816dad3c17fa 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; diff --git a/flang/lib/Support/Fortran-features.cpp b/flang/lib/Support/Fortran-features.cpp index 19080251b646..4201f0b9b1e4 100644 --- a/flang/lib/Support/Fortran-features.cpp +++ b/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); } diff --git a/flang/test/Semantics/bug181353.f90 b/flang/test/Semantics/bug181353.f90 new file mode 100644 index 000000000000..8754eb93e50d --- /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 impure FINAL procedure 'finalize' and must be definable in this pure context + call outer%inner%set() + end +end