diff --git a/flang/lib/Semantics/check-call.cpp b/flang/lib/Semantics/check-call.cpp index 28a12a5798cb0..a89e10bd3e6d4 100644 --- a/flang/lib/Semantics/check-call.cpp +++ b/flang/lib/Semantics/check-call.cpp @@ -300,12 +300,15 @@ static void ConvertLogicalActual(evaluate::Expr &actual, } static bool DefersSameTypeParameters( - const DerivedTypeSpec &actual, const DerivedTypeSpec &dummy) { - for (const auto &pair : actual.parameters()) { - const ParamValue &actualValue{pair.second}; - const ParamValue *dummyValue{dummy.FindParameter(pair.first)}; - if (!dummyValue || (actualValue.isDeferred() != dummyValue->isDeferred())) { - return false; + const DerivedTypeSpec *actual, const DerivedTypeSpec *dummy) { + if (actual && dummy) { + for (const auto &pair : actual->parameters()) { + const ParamValue &actualValue{pair.second}; + const ParamValue *dummyValue{dummy->FindParameter(pair.first)}; + if (!dummyValue || + (actualValue.isDeferred() != dummyValue->isDeferred())) { + return false; + } } } return true; @@ -370,9 +373,37 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy, } bool dummyIsAssumedRank{dummy.type.attrs().test( characteristics::TypeAndShape::Attr::AssumedRank)}; + bool actualIsAssumedSize{actualType.attrs().test( + characteristics::TypeAndShape::Attr::AssumedSize)}; + bool actualIsAssumedRank{evaluate::IsAssumedRank(actual)}; + bool actualIsPointer{evaluate::IsObjectPointer(actual)}; + bool actualIsAllocatable{evaluate::IsAllocatableDesignator(actual)}; + bool actualMayBeAssumedSize{actualIsAssumedSize || + (actualIsAssumedRank && !actualIsPointer && !actualIsAllocatable)}; + bool actualIsPolymorphic{actualType.type().IsPolymorphic()}; + const auto *actualDerived{evaluate::GetDerivedTypeSpec(actualType.type())}; if (typesCompatible) { if (isElemental) { } else if (dummyIsAssumedRank) { + if (actualMayBeAssumedSize && dummy.intent == common::Intent::Out) { + // An INTENT(OUT) dummy might be a no-op at run time + bool dummyHasSignificantIntentOut{actualIsPolymorphic || + (actualDerived && + (actualDerived->HasDefaultInitialization( + /*ignoreAllocatable=*/false, /*ignorePointer=*/true) || + actualDerived->HasDestruction()))}; + const char *actualDesc{ + actualIsAssumedSize ? "Assumed-size" : "Assumed-rank"}; + if (dummyHasSignificantIntentOut) { + messages.Say( + "%s actual argument may not be associated with INTENT(OUT) assumed-rank dummy argument requiring finalization, destruction, or initialization"_err_en_US, + actualDesc); + } else { + context.Warn(common::UsageWarning::Portability, messages.at(), + "%s actual argument should not be associated with INTENT(OUT) assumed-rank dummy argument"_port_en_US, + actualDesc); + } + } } else if (dummy.ignoreTKR.test(common::IgnoreTKR::Rank)) { } else if (dummyRank > 0 && !dummyIsAllocatableOrPointer && !dummy.type.attrs().test( @@ -401,11 +432,7 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy, dummy.type.type().AsFortran()); } - bool actualIsPolymorphic{actualType.type().IsPolymorphic()}; - bool dummyIsPolymorphic{dummy.type.type().IsPolymorphic()}; bool actualIsCoindexed{ExtractCoarrayRef(actual).has_value()}; - bool actualIsAssumedSize{actualType.attrs().test( - characteristics::TypeAndShape::Attr::AssumedSize)}; bool dummyIsAssumedSize{dummy.type.attrs().test( characteristics::TypeAndShape::Attr::AssumedSize)}; bool dummyIsAsynchronous{ @@ -414,7 +441,7 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy, dummy.attrs.test(characteristics::DummyDataObject::Attr::Volatile)}; bool dummyIsValue{ dummy.attrs.test(characteristics::DummyDataObject::Attr::Value)}; - + bool dummyIsPolymorphic{dummy.type.type().IsPolymorphic()}; if (actualIsPolymorphic && dummyIsPolymorphic && actualIsCoindexed) { // 15.5.2.4(2) messages.Say( @@ -434,37 +461,36 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy, actualFirstSymbol && actualFirstSymbol->attrs().test(Attr::ASYNCHRONOUS)}; bool actualIsVolatile{ actualFirstSymbol && actualFirstSymbol->attrs().test(Attr::VOLATILE)}; - const auto *derived{evaluate::GetDerivedTypeSpec(actualType.type())}; - if (derived && !derived->IsVectorType()) { + if (actualDerived && !actualDerived->IsVectorType()) { if (dummy.type.type().IsAssumedType()) { - if (!derived->parameters().empty()) { // 15.5.2.4(2) + if (!actualDerived->parameters().empty()) { // 15.5.2.4(2) messages.Say( "Actual argument associated with TYPE(*) %s may not have a parameterized derived type"_err_en_US, dummyName); } if (const Symbol * - tbp{FindImmediateComponent(*derived, [](const Symbol &symbol) { + tbp{FindImmediateComponent(*actualDerived, [](const Symbol &symbol) { return symbol.has(); })}) { // 15.5.2.4(2) evaluate::SayWithDeclaration(messages, *tbp, "Actual argument associated with TYPE(*) %s may not have type-bound procedure '%s'"_err_en_US, dummyName, tbp->name()); } - auto finals{FinalsForDerivedTypeInstantiation(*derived)}; + auto finals{FinalsForDerivedTypeInstantiation(*actualDerived)}; if (!finals.empty()) { // 15.5.2.4(2) SourceName name{finals.front()->name()}; if (auto *msg{messages.Say( "Actual argument associated with TYPE(*) %s may not have derived type '%s' with FINAL subroutine '%s'"_err_en_US, - dummyName, derived->typeSymbol().name(), name)}) { + dummyName, actualDerived->typeSymbol().name(), name)}) { msg->Attach(name, "FINAL subroutine '%s' in derived type '%s'"_en_US, - name, derived->typeSymbol().name()); + name, actualDerived->typeSymbol().name()); } } } if (actualIsCoindexed) { if (dummy.intent != common::Intent::In && !dummyIsValue) { - if (auto bad{ - FindAllocatableUltimateComponent(*derived)}) { // 15.5.2.4(6) + if (auto bad{FindAllocatableUltimateComponent( + *actualDerived)}) { // 15.5.2.4(6) evaluate::SayWithDeclaration(messages, *bad, "Coindexed actual argument with ALLOCATABLE ultimate component '%s' must be associated with a %s with VALUE or INTENT(IN) attributes"_err_en_US, bad.BuildResultDesignatorName(), dummyName); @@ -484,7 +510,7 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy, } } if (actualIsVolatile != dummyIsVolatile) { // 15.5.2.4(22) - if (auto bad{semantics::FindCoarrayUltimateComponent(*derived)}) { + if (auto bad{semantics::FindCoarrayUltimateComponent(*actualDerived)}) { evaluate::SayWithDeclaration(messages, *bad, "VOLATILE attribute must match for %s when actual argument has a coarray ultimate component '%s'"_err_en_US, dummyName, bad.BuildResultDesignatorName()); @@ -501,8 +527,6 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy, ? actualLastSymbol->detailsIf() : nullptr}; int actualRank{actualType.Rank()}; - bool actualIsPointer{evaluate::IsObjectPointer(actual)}; - bool actualIsAssumedRank{evaluate::IsAssumedRank(actual)}; if (dummy.type.attrs().test( characteristics::TypeAndShape::Attr::AssumedShape)) { // 15.5.2.4(16) @@ -730,7 +754,6 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy, } // 15.5.2.6 -- dummy is ALLOCATABLE - bool actualIsAllocatable{evaluate::IsAllocatableDesignator(actual)}; bool dummyIsOptional{ dummy.attrs.test(characteristics::DummyDataObject::Attr::Optional)}; bool actualIsNull{evaluate::IsNullPointer(actual)}; @@ -851,10 +874,8 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy, } } // 15.5.2.5(4) - const auto *derived{evaluate::GetDerivedTypeSpec(actualType.type())}; - if ((derived && - !DefersSameTypeParameters(*derived, - *evaluate::GetDerivedTypeSpec(dummy.type.type()))) || + const auto *dummyDerived{evaluate::GetDerivedTypeSpec(dummy.type.type())}; + if (!DefersSameTypeParameters(actualDerived, dummyDerived) || dummy.type.type().HasDeferredTypeParameter() != actualType.type().HasDeferredTypeParameter()) { messages.Say( diff --git a/flang/lib/Semantics/tools.cpp b/flang/lib/Semantics/tools.cpp index 3723b28fecef5..891e57c43c373 100644 --- a/flang/lib/Semantics/tools.cpp +++ b/flang/lib/Semantics/tools.cpp @@ -688,7 +688,7 @@ bool IsInitialized(const Symbol &symbol, bool ignoreDataStatements, } else if (IsNamedConstant(symbol)) { return false; } else if (const auto *object{symbol.detailsIf()}) { - if (!object->isDummy() && object->type()) { + if ((!object->isDummy() || IsIntentOut(symbol)) && object->type()) { if (const auto *derived{object->type()->AsDerived()}) { return derived->HasDefaultInitialization( ignoreAllocatable, ignorePointer); @@ -705,7 +705,7 @@ bool IsDestructible(const Symbol &symbol, const Symbol *derivedTypeSymbol) { IsPointer(symbol)) { return false; } else if (const auto *object{symbol.detailsIf()}) { - if (!object->isDummy() && object->type()) { + if ((!object->isDummy() || IsIntentOut(symbol)) && object->type()) { if (const auto *derived{object->type()->AsDerived()}) { return &derived->typeSymbol() != derivedTypeSymbol && derived->HasDestruction(); diff --git a/flang/test/Semantics/call42.f90 b/flang/test/Semantics/call42.f90 new file mode 100644 index 0000000000000..2d5303b58cb01 --- /dev/null +++ b/flang/test/Semantics/call42.f90 @@ -0,0 +1,138 @@ +! RUN: %python %S/test_errors.py %s %flang_fc1 -pedantic +module m + type boring + end type + type hasAlloc + real, allocatable :: x + end type + type hasInit + real :: x = 1. + end type + type hasFinal + contains + final final + end type + contains + elemental subroutine final(x) + type(hasFinal), intent(in out) :: x + end + + recursive subroutine typeOutAssumedRank(a,b,c,d) + type(boring), intent(out) :: a(..) + type(hasAlloc), intent(out) :: b(..) + type(hasInit), intent(out) :: c(..) + type(hasFinal), intent(out) :: d(..) + !PORTABILITY: Assumed-rank actual argument should not be associated with INTENT(OUT) assumed-rank dummy argument + !ERROR: Assumed-rank actual argument may not be associated with INTENT(OUT) assumed-rank dummy argument requiring finalization, destruction, or initialization + !ERROR: Assumed-rank actual argument may not be associated with INTENT(OUT) assumed-rank dummy argument requiring finalization, destruction, or initialization + !ERROR: Assumed-rank actual argument may not be associated with INTENT(OUT) assumed-rank dummy argument requiring finalization, destruction, or initialization + call typeOutAssumedRank(a, b, c, d) + !PORTABILITY: Assumed-rank actual argument should not be associated with INTENT(OUT) assumed-rank dummy argument + !ERROR: Assumed-rank actual argument may not be associated with INTENT(OUT) assumed-rank dummy argument requiring finalization, destruction, or initialization + !ERROR: Assumed-rank actual argument may not be associated with INTENT(OUT) assumed-rank dummy argument requiring finalization, destruction, or initialization + !ERROR: Assumed-rank actual argument may not be associated with INTENT(OUT) assumed-rank dummy argument requiring finalization, destruction, or initialization + call classOutAssumedRank(a, b, c, d) + !PORTABILITY: Assumed-rank actual argument should not be associated with INTENT(OUT) assumed-rank dummy argument + !ERROR: Assumed-rank actual argument may not be associated with INTENT(OUT) assumed-rank dummy argument requiring finalization, destruction, or initialization + !ERROR: Assumed-rank actual argument may not be associated with INTENT(OUT) assumed-rank dummy argument requiring finalization, destruction, or initialization + !ERROR: Assumed-rank actual argument may not be associated with INTENT(OUT) assumed-rank dummy argument requiring finalization, destruction, or initialization + call unlimitedOutAssumedRank(a, b, c, d) + end + recursive subroutine typeOutAssumedRankAlloc(a,b,c,d) + type(boring), intent(out), allocatable :: a(..) + type(hasAlloc), intent(out), allocatable :: b(..) + type(hasInit), intent(out), allocatable :: c(..) + type(hasFinal), intent(out), allocatable :: d(..) + call typeOutAssumedRank(a, b, c, d) + call typeOutAssumedRankAlloc(a, b, c, d) + end + recursive subroutine classOutAssumedRank(a,b,c,d) + class(boring), intent(out) :: a(..) + class(hasAlloc), intent(out) :: b(..) + class(hasInit), intent(out) :: c(..) + class(hasFinal), intent(out) :: d(..) + !ERROR: Assumed-rank actual argument may not be associated with INTENT(OUT) assumed-rank dummy argument requiring finalization, destruction, or initialization + !ERROR: Assumed-rank actual argument may not be associated with INTENT(OUT) assumed-rank dummy argument requiring finalization, destruction, or initialization + !ERROR: Assumed-rank actual argument may not be associated with INTENT(OUT) assumed-rank dummy argument requiring finalization, destruction, or initialization + !ERROR: Assumed-rank actual argument may not be associated with INTENT(OUT) assumed-rank dummy argument requiring finalization, destruction, or initialization + call typeOutAssumedRank(a, b, c, d) + !ERROR: Assumed-rank actual argument may not be associated with INTENT(OUT) assumed-rank dummy argument requiring finalization, destruction, or initialization + !ERROR: Assumed-rank actual argument may not be associated with INTENT(OUT) assumed-rank dummy argument requiring finalization, destruction, or initialization + !ERROR: Assumed-rank actual argument may not be associated with INTENT(OUT) assumed-rank dummy argument requiring finalization, destruction, or initialization + !ERROR: Assumed-rank actual argument may not be associated with INTENT(OUT) assumed-rank dummy argument requiring finalization, destruction, or initialization + call classOutAssumedRank(a, b, c, d) + !ERROR: Assumed-rank actual argument may not be associated with INTENT(OUT) assumed-rank dummy argument requiring finalization, destruction, or initialization + !ERROR: Assumed-rank actual argument may not be associated with INTENT(OUT) assumed-rank dummy argument requiring finalization, destruction, or initialization + !ERROR: Assumed-rank actual argument may not be associated with INTENT(OUT) assumed-rank dummy argument requiring finalization, destruction, or initialization + !ERROR: Assumed-rank actual argument may not be associated with INTENT(OUT) assumed-rank dummy argument requiring finalization, destruction, or initialization + call unlimitedOutAssumedRank(a, b, c, d) + end + recursive subroutine classOutAssumedRankAlloc(a,b,c,d) + class(boring), intent(out), allocatable :: a(..) + class(hasAlloc), intent(out), allocatable :: b(..) + class(hasInit), intent(out), allocatable :: c(..) + class(hasFinal), intent(out), allocatable :: d(..) + call classOutAssumedRank(a, b, c, d) + call classOutAssumedRankAlloc(a, b, c, d) + call unlimitedOutAssumedRank(a, b, c, d) + end + recursive subroutine unlimitedOutAssumedRank(a,b,c,d) + class(*), intent(out) :: a(..), b(..), c(..), d(..) + !ERROR: Assumed-rank actual argument may not be associated with INTENT(OUT) assumed-rank dummy argument requiring finalization, destruction, or initialization + !ERROR: Assumed-rank actual argument may not be associated with INTENT(OUT) assumed-rank dummy argument requiring finalization, destruction, or initialization + !ERROR: Assumed-rank actual argument may not be associated with INTENT(OUT) assumed-rank dummy argument requiring finalization, destruction, or initialization + !ERROR: Assumed-rank actual argument may not be associated with INTENT(OUT) assumed-rank dummy argument requiring finalization, destruction, or initialization + call unlimitedOutAssumedRank(a, b, c, d) + end + recursive subroutine unlimitedOutAssumedRankAlloc(a,b,c,d) + class(*), intent(out), allocatable :: a(..), b(..), c(..), d(..) + call unlimitedOutAssumedRank(a, b, c, d) + call unlimitedOutAssumedRankAlloc(a, b, c, d) + end + + subroutine typeAssumedSize(a,b,c,d) + type(boring) a(*) + type(hasAlloc) b(*) + type(hasInit) c(*) + type(hasFinal) d(*) + !PORTABILITY: Assumed-size actual argument should not be associated with INTENT(OUT) assumed-rank dummy argument + !ERROR: Assumed-size actual argument may not be associated with INTENT(OUT) assumed-rank dummy argument requiring finalization, destruction, or initialization + !ERROR: Assumed-size actual argument may not be associated with INTENT(OUT) assumed-rank dummy argument requiring finalization, destruction, or initialization + !ERROR: Assumed-size actual argument may not be associated with INTENT(OUT) assumed-rank dummy argument requiring finalization, destruction, or initialization + call typeOutAssumedRank(a,b,c,d) + !PORTABILITY: Assumed-size actual argument should not be associated with INTENT(OUT) assumed-rank dummy argument + !ERROR: Assumed-size actual argument may not be associated with INTENT(OUT) assumed-rank dummy argument requiring finalization, destruction, or initialization + !ERROR: Assumed-size actual argument may not be associated with INTENT(OUT) assumed-rank dummy argument requiring finalization, destruction, or initialization + !ERROR: Assumed-size actual argument may not be associated with INTENT(OUT) assumed-rank dummy argument requiring finalization, destruction, or initialization + call classOutAssumedRank(a,b,c,d) + !PORTABILITY: Assumed-size actual argument should not be associated with INTENT(OUT) assumed-rank dummy argument + !ERROR: Assumed-size actual argument may not be associated with INTENT(OUT) assumed-rank dummy argument requiring finalization, destruction, or initialization + !ERROR: Assumed-size actual argument may not be associated with INTENT(OUT) assumed-rank dummy argument requiring finalization, destruction, or initialization + !ERROR: Assumed-size actual argument may not be associated with INTENT(OUT) assumed-rank dummy argument requiring finalization, destruction, or initialization + call unlimitedOutAssumedRank(a,b,c,d) + end + subroutine classAssumedSize(a,b,c,d) + class(boring) a(*) + class(hasAlloc) b(*) + class(hasInit) c(*) + class(hasFinal) d(*) + !ERROR: Assumed-size actual argument may not be associated with INTENT(OUT) assumed-rank dummy argument requiring finalization, destruction, or initialization + !ERROR: Assumed-size actual argument may not be associated with INTENT(OUT) assumed-rank dummy argument requiring finalization, destruction, or initialization + !ERROR: Assumed-size actual argument may not be associated with INTENT(OUT) assumed-rank dummy argument requiring finalization, destruction, or initialization + !ERROR: Assumed-size actual argument may not be associated with INTENT(OUT) assumed-rank dummy argument requiring finalization, destruction, or initialization + call classOutAssumedRank(a,b,c,d) + !ERROR: Assumed-size actual argument may not be associated with INTENT(OUT) assumed-rank dummy argument requiring finalization, destruction, or initialization + !ERROR: Assumed-size actual argument may not be associated with INTENT(OUT) assumed-rank dummy argument requiring finalization, destruction, or initialization + !ERROR: Assumed-size actual argument may not be associated with INTENT(OUT) assumed-rank dummy argument requiring finalization, destruction, or initialization + !ERROR: Assumed-size actual argument may not be associated with INTENT(OUT) assumed-rank dummy argument requiring finalization, destruction, or initialization + call unlimitedOutAssumedRank(a,b,c,d) + end + subroutine unlimitedAssumedSize(a,b,c,d) + class(*) a(*), b(*), c(*), d(*) + !ERROR: Assumed-size actual argument may not be associated with INTENT(OUT) assumed-rank dummy argument requiring finalization, destruction, or initialization + !ERROR: Assumed-size actual argument may not be associated with INTENT(OUT) assumed-rank dummy argument requiring finalization, destruction, or initialization + !ERROR: Assumed-size actual argument may not be associated with INTENT(OUT) assumed-rank dummy argument requiring finalization, destruction, or initialization + !ERROR: Assumed-size actual argument may not be associated with INTENT(OUT) assumed-rank dummy argument requiring finalization, destruction, or initialization + call unlimitedOutAssumedRank(a, b, c, d) + end +end