diff --git a/flang/include/flang/Evaluate/tools.h b/flang/include/flang/Evaluate/tools.h --- a/flang/include/flang/Evaluate/tools.h +++ b/flang/include/flang/Evaluate/tools.h @@ -1227,11 +1227,6 @@ int CountLenParameters(const DerivedTypeSpec &); int CountNonConstantLenParameters(const DerivedTypeSpec &); -// 15.5.2.4(4), type compatibility for dummy and actual arguments. -// Also used for assignment compatibility checking -bool AreTypeParamCompatible( - const semantics::DerivedTypeSpec &, const semantics::DerivedTypeSpec &); - const Symbol &GetUsedModule(const UseDetails &); const Symbol *FindFunctionResult(const Symbol &); diff --git a/flang/include/flang/Semantics/tools.h b/flang/include/flang/Semantics/tools.h --- a/flang/include/flang/Semantics/tools.h +++ b/flang/include/flang/Semantics/tools.h @@ -169,6 +169,7 @@ inline bool IsImpliedDoIndex(const Symbol &symbol) { return symbol.owner().kind() == Scope::Kind::ImpliedDos; } +SymbolVector FinalsForDerivedTypeInstantiation(const DerivedTypeSpec &); bool IsFinalizable( const Symbol &, std::set * = nullptr); bool IsFinalizable( diff --git a/flang/lib/Evaluate/tools.cpp b/flang/lib/Evaluate/tools.cpp --- a/flang/lib/Evaluate/tools.cpp +++ b/flang/lib/Evaluate/tools.cpp @@ -1598,31 +1598,6 @@ }); } -// Are the type parameters of type1 compile-time compatible with the -// corresponding kind type parameters of type2? Return true if all constant -// valued parameters are equal. -// Used to check assignment statements and argument passing. See 15.5.2.4(4) -bool AreTypeParamCompatible(const semantics::DerivedTypeSpec &type1, - const semantics::DerivedTypeSpec &type2) { - for (const auto &[name, param1] : type1.parameters()) { - if (semantics::MaybeIntExpr paramExpr1{param1.GetExplicit()}) { - if (IsConstantExpr(*paramExpr1)) { - const semantics::ParamValue *param2{type2.FindParameter(name)}; - if (param2) { - if (semantics::MaybeIntExpr paramExpr2{param2->GetExplicit()}) { - if (IsConstantExpr(*paramExpr2)) { - if (ToInt64(*paramExpr1) != ToInt64(*paramExpr2)) { - return false; - } - } - } - } - } - } - } - return true; -} - const Symbol &GetUsedModule(const UseDetails &details) { return DEREF(details.symbol().owner().symbol()); } diff --git a/flang/lib/Evaluate/type.cpp b/flang/lib/Evaluate/type.cpp --- a/flang/lib/Evaluate/type.cpp +++ b/flang/lib/Evaluate/type.cpp @@ -262,13 +262,65 @@ y.has(); } +static bool AreTypeParamCompatible(const semantics::DerivedTypeSpec &x, + const semantics::DerivedTypeSpec &y, bool ignoreLenParameters) { + const auto *xScope{x.typeSymbol().scope()}; + const auto *yScope{y.typeSymbol().scope()}; + for (const auto &[paramName, value] : x.parameters()) { + const auto *yValue{y.FindParameter(paramName)}; + if (!yValue) { + return false; + } + const auto *xParm{xScope ? xScope->FindComponent(paramName) : nullptr}; + const auto *yParm{yScope ? yScope->FindComponent(paramName) : nullptr}; + if (xParm && yParm) { + const auto *xTPD{xParm->detailsIf()}; + const auto *yTPD{yParm->detailsIf()}; + if (xTPD && yTPD) { + if (xTPD->attr() != yTPD->attr()) { + return false; + } + if (!ignoreLenParameters || + xTPD->attr() != common::TypeParamAttr::Len) { + auto xExpr{value.GetExplicit()}; + auto yExpr{yValue->GetExplicit()}; + if (xExpr && yExpr) { + auto xVal{ToInt64(*xExpr)}; + auto yVal{ToInt64(*yExpr)}; + if (xVal && yVal && *xVal != *yVal) { + return false; + } + } + } + } + } + } + for (const auto &[paramName, _] : y.parameters()) { + if (!x.FindParameter(paramName)) { + return false; // y has more parameters than x + } + } + return true; +} + static bool AreSameDerivedType(const semantics::DerivedTypeSpec &x, - const semantics::DerivedTypeSpec &y, SetOfDerivedTypePairs &inProgress) { + const semantics::DerivedTypeSpec &y, bool ignoreTypeParameterValues, + bool ignoreLenParameters, SetOfDerivedTypePairs &inProgress) { + if (&x == &y) { + return true; + } + if (!ignoreTypeParameterValues && + !AreTypeParamCompatible(x, y, ignoreLenParameters)) { + return false; + } const auto &xSymbol{x.typeSymbol()}; const auto &ySymbol{y.typeSymbol()}; - if (&x == &y || xSymbol == ySymbol) { + if (xSymbol == ySymbol) { return true; } + if (xSymbol.name() != ySymbol.name()) { + return false; + } auto thisQuery{std::make_pair(&x, &y)}; if (inProgress.find(thisQuery) != inProgress.end()) { return true; // recursive use of types in components @@ -276,9 +328,6 @@ inProgress.insert(thisQuery); const auto &xDetails{xSymbol.get()}; const auto &yDetails{ySymbol.get()}; - if (xSymbol.name() != ySymbol.name()) { - return false; - } if (!(xDetails.sequence() && yDetails.sequence()) && !(xSymbol.attrs().test(semantics::Attr::BIND_C) && ySymbol.attrs().test(semantics::Attr::BIND_C))) { @@ -310,19 +359,23 @@ bool AreSameDerivedType( const semantics::DerivedTypeSpec &x, const semantics::DerivedTypeSpec &y) { SetOfDerivedTypePairs inProgress; - return AreSameDerivedType(x, y, inProgress); + return AreSameDerivedType(x, y, false, false, inProgress); } static bool AreCompatibleDerivedTypes(const semantics::DerivedTypeSpec *x, - const semantics::DerivedTypeSpec *y, bool isPolymorphic) { + const semantics::DerivedTypeSpec *y, bool isPolymorphic, + bool ignoreTypeParameterValues, bool ignoreLenTypeParameters) { if (!x || !y) { return false; } else { - if (AreSameDerivedType(*x, *y)) { + SetOfDerivedTypePairs inProgress; + if (AreSameDerivedType(*x, *y, ignoreTypeParameterValues, + ignoreLenTypeParameters, inProgress)) { return true; } else { return isPolymorphic && - AreCompatibleDerivedTypes(x, GetParentTypeSpec(*y), true); + AreCompatibleDerivedTypes(x, GetParentTypeSpec(*y), true, + ignoreTypeParameterValues, ignoreLenTypeParameters); } } } @@ -345,9 +398,8 @@ } else { const auto *xdt{GetDerivedTypeSpec(x)}; const auto *ydt{GetDerivedTypeSpec(y)}; - return AreCompatibleDerivedTypes(xdt, ydt, x.IsPolymorphic()) && - (ignoreTypeParameterValues || - (xdt && ydt && AreTypeParamCompatible(*xdt, *ydt))); + return AreCompatibleDerivedTypes( + xdt, ydt, x.IsPolymorphic(), ignoreTypeParameterValues, false); } } @@ -382,12 +434,13 @@ const auto *thatDts{evaluate::GetDerivedTypeSpec(that)}; if (!thisDts || !thatDts) { return std::nullopt; - } else if (!AreCompatibleDerivedTypes(thatDts, thisDts, true)) { + } else if (!AreCompatibleDerivedTypes(thatDts, thisDts, true, true, true)) { // Note that I check *thisDts, not its parent, so that EXTENDS_TYPE_OF() // is .true. when they are the same type. This is technically // an implementation-defined case in the standard, but every other // compiler works this way. - if (IsPolymorphic() && AreCompatibleDerivedTypes(thisDts, thatDts, true)) { + if (IsPolymorphic() && + AreCompatibleDerivedTypes(thisDts, thatDts, true, true, true)) { // 'that' is *this or an extension of *this, and so runtime *this // could be an extension of 'that' return std::nullopt; diff --git a/flang/lib/Semantics/check-call.cpp b/flang/lib/Semantics/check-call.cpp --- a/flang/lib/Semantics/check-call.cpp +++ b/flang/lib/Semantics/check-call.cpp @@ -296,16 +296,14 @@ "Actual argument associated with TYPE(*) %s may not have type-bound procedure '%s'"_err_en_US, dummyName, tbp->name()); } - const auto &finals{ - derived->typeSymbol().get().finals()}; + auto finals{FinalsForDerivedTypeInstantiation(*derived)}; 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(), - finals.begin()->first)}) { - msg->Attach(finals.begin()->first, - "FINAL subroutine '%s' in derived type '%s'"_en_US, - finals.begin()->first, derived->typeSymbol().name()); + dummyName, derived->typeSymbol().name(), name)}) { + msg->Attach(name, "FINAL subroutine '%s' in derived type '%s'"_en_US, + name, derived->typeSymbol().name()); } } } diff --git a/flang/lib/Semantics/definable.cpp b/flang/lib/Semantics/definable.cpp --- a/flang/lib/Semantics/definable.cpp +++ b/flang/lib/Semantics/definable.cpp @@ -228,8 +228,7 @@ while (spec) { bool anyElemental{false}; const Symbol *anyRankMatch{nullptr}; - for (const auto &[_, ref] : - spec->typeSymbol().get().finals()) { + for (auto ref : FinalsForDerivedTypeInstantiation(*spec)) { const Symbol &ultimate{ref->GetUltimate()}; anyElemental |= ultimate.attrs().test(Attr::ELEMENTAL); if (const auto *subp{ultimate.detailsIf()}) { diff --git a/flang/lib/Semantics/runtime-type-info.cpp b/flang/lib/Semantics/runtime-type-info.cpp --- a/flang/lib/Semantics/runtime-type-info.cpp +++ b/flang/lib/Semantics/runtime-type-info.cpp @@ -573,12 +573,11 @@ // do not (the runtime will call all of them). std::map specials{ DescribeSpecialGenerics(dtScope, dtScope, derivedTypeSpec)}; - const DerivedTypeDetails &dtDetails{dtSymbol->get()}; - for (const auto &pair : dtDetails.finals()) { - DescribeSpecialProc(specials, *pair.second, false /*!isAssignment*/, - true, std::nullopt, nullptr, derivedTypeSpec); - } if (derivedTypeSpec) { + for (auto &ref : FinalsForDerivedTypeInstantiation(*derivedTypeSpec)) { + DescribeSpecialProc(specials, *ref, false /*!isAssignment*/, true, + std::nullopt, nullptr, derivedTypeSpec); + } IncorporateDefinedIoGenericInterfaces(specials, GenericKind::DefinedIo::ReadFormatted, &scope, derivedTypeSpec); IncorporateDefinedIoGenericInterfaces(specials, diff --git a/flang/lib/Semantics/tools.cpp b/flang/lib/Semantics/tools.cpp --- a/flang/lib/Semantics/tools.cpp +++ b/flang/lib/Semantics/tools.cpp @@ -702,6 +702,30 @@ return false; } +SymbolVector FinalsForDerivedTypeInstantiation(const DerivedTypeSpec &spec) { + SymbolVector result; + const Symbol &typeSymbol{spec.typeSymbol()}; + if (const auto *derived{typeSymbol.detailsIf()}) { + for (const auto &pair : derived->finals()) { + const Symbol &subr{*pair.second}; + // Errors in FINAL subroutines are caught in CheckFinal + // in check-declarations.cpp. + if (const auto *subprog{subr.detailsIf()}; + subprog && subprog->dummyArgs().size() == 1) { + if (const Symbol * arg{subprog->dummyArgs()[0]}) { + if (const DeclTypeSpec * type{arg->GetType()}) { + if (type->category() == DeclTypeSpec::TypeDerived && + evaluate::AreSameDerivedType(spec, type->derivedTypeSpec())) { + result.emplace_back(subr); + } + } + } + } + } + } + return result; +} + bool IsFinalizable( const Symbol &symbol, std::set *inProgress) { if (IsPointer(symbol)) { @@ -720,7 +744,7 @@ bool IsFinalizable(const DerivedTypeSpec &derived, std::set *inProgress) { - if (!derived.typeSymbol().get().finals().empty()) { + if (!FinalsForDerivedTypeInstantiation(derived).empty()) { return true; } std::set basis; @@ -742,14 +766,12 @@ } bool HasImpureFinal(const DerivedTypeSpec &derived) { - if (const auto *details{ - derived.typeSymbol().detailsIf()}) { - const auto &finals{details->finals()}; - return std::any_of(finals.begin(), finals.end(), - [](const auto &x) { return !IsPureProcedure(*x.second); }); - } else { - return false; + for (auto ref : FinalsForDerivedTypeInstantiation(derived)) { + if (!IsPureProcedure(*ref)) { + return true; + } } + return false; } bool IsAssumedLengthCharacter(const Symbol &symbol) { diff --git a/flang/lib/Semantics/type.cpp b/flang/lib/Semantics/type.cpp --- a/flang/lib/Semantics/type.cpp +++ b/flang/lib/Semantics/type.cpp @@ -188,7 +188,7 @@ } bool DerivedTypeSpec::HasDestruction() const { - if (!typeSymbol().get().finals().empty()) { + if (!FinalsForDerivedTypeInstantiation(*this).empty()) { return true; } DirectComponentIterator components{*this}; @@ -366,7 +366,7 @@ } newScope.set_instantiationContext(contextMessage); } - // Instantiate every non-parameter symbol from the original derived + // Instantiate nearly every non-parameter symbol from the original derived // type's scope into the new instance. auto restorer2{foldingContext.messages().SetContext(contextMessage)}; if (PlumbPDTInstantiationDepth(&containingScope) > 100) { diff --git a/flang/test/Semantics/call03.f90 b/flang/test/Semantics/call03.f90 --- a/flang/test/Semantics/call03.f90 +++ b/flang/test/Semantics/call03.f90 @@ -168,12 +168,16 @@ !WARNING: Actual argument expression length '0' is less than expected length '2' call ch2("") call pdtdefault(vardefault) + !ERROR: Actual argument type 'pdt(n=3_4)' is not compatible with dummy argument type 'pdt' call pdtdefault(var3) + !ERROR: Actual argument type 'pdt(n=4_4)' is not compatible with dummy argument type 'pdt' call pdtdefault(var4) ! error - call pdt3(vardefault) ! error + !ERROR: Actual argument type 'pdt' is not compatible with dummy argument type 'pdt(n=4_4)' + call pdt3(vardefault) !ERROR: Actual argument type 'pdt(n=3_4)' is not compatible with dummy argument type 'pdt(n=4_4)' - call pdt3(var3) ! error + call pdt3(var3) call pdt3(var4) + !ERROR: Actual argument type 'pdt' is not compatible with dummy argument type 'pdt(n=*)' call pdt4(vardefault) call pdt4(var3) call pdt4(var4) diff --git a/flang/test/Semantics/final03.f90 b/flang/test/Semantics/final03.f90 new file mode 100644 --- /dev/null +++ b/flang/test/Semantics/final03.f90 @@ -0,0 +1,28 @@ +! RUN: %python %S/test_errors.py %s %flang_fc1 +! PDT sensitivity of FINAL subroutines +module m + type :: pdt(k) + integer, kind :: k + contains + final :: finalArr, finalElem + end type + contains + subroutine finalArr(x) + type(pdt(1)), intent(in out) :: x(:) + end + elemental subroutine finalElem(x) + type(pdt(3)), intent(in out) :: x + end +end + +program test + use m + type(pdt(1)) x1(1) + type(pdt(2)) x2(1) + type(pdt(3)) x3(1) + !ERROR: Left-hand side of assignment is not definable + !BECAUSE: Variable 'x1([INTEGER(8)::1_8])' has a vector subscript and cannot be finalized by non-elemental subroutine 'finalarr' + x1([1]) = pdt(1)() + x2([1]) = pdt(2)() ! ok, doesn't match either + x3([1]) = pdt(3)() ! ok, calls finalElem +end