[flang-commits] [flang] d84faa4 - [flang] Ignore FINAL subroutines with mismatching type parameters
Peter Klausler via flang-commits
flang-commits at lists.llvm.org
Fri Mar 10 08:53:29 PST 2023
Author: Peter Klausler
Date: 2023-03-10T08:53:21-08:00
New Revision: d84faa428ef05436ea8b5fdbbab9e9b9c0a12985
URL: https://github.com/llvm/llvm-project/commit/d84faa428ef05436ea8b5fdbbab9e9b9c0a12985
DIFF: https://github.com/llvm/llvm-project/commit/d84faa428ef05436ea8b5fdbbab9e9b9c0a12985.diff
LOG: [flang] Ignore FINAL subroutines with mismatching type parameters
When a parameterized derived type has FINAL subroutines, only
those FINAL subroutines whose dummy argument's type matches the
type parameter values of a particular instantiation are relevant
to that instantiation.
Differential Revision: https://reviews.llvm.org/D145741
Added:
flang/test/Semantics/final03.f90
Modified:
flang/include/flang/Evaluate/tools.h
flang/include/flang/Semantics/tools.h
flang/lib/Evaluate/tools.cpp
flang/lib/Evaluate/type.cpp
flang/lib/Semantics/check-call.cpp
flang/lib/Semantics/definable.cpp
flang/lib/Semantics/runtime-type-info.cpp
flang/lib/Semantics/tools.cpp
flang/lib/Semantics/type.cpp
flang/test/Semantics/call03.f90
Removed:
################################################################################
diff --git a/flang/include/flang/Evaluate/tools.h b/flang/include/flang/Evaluate/tools.h
index 448909d365940..fa525197f00e9 100644
--- a/flang/include/flang/Evaluate/tools.h
+++ b/flang/include/flang/Evaluate/tools.h
@@ -1227,11 +1227,6 @@ const Symbol *FindCommonBlockContaining(const Symbol &);
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
index 4c3630c67ebd2..a652ac94b025d 100644
--- a/flang/include/flang/Semantics/tools.h
+++ b/flang/include/flang/Semantics/tools.h
@@ -169,6 +169,7 @@ inline bool IsProtected(const Symbol &symbol) {
inline bool IsImpliedDoIndex(const Symbol &symbol) {
return symbol.owner().kind() == Scope::Kind::ImpliedDos;
}
+SymbolVector FinalsForDerivedTypeInstantiation(const DerivedTypeSpec &);
bool IsFinalizable(
const Symbol &, std::set<const DerivedTypeSpec *> * = nullptr);
bool IsFinalizable(
diff --git a/flang/lib/Evaluate/tools.cpp b/flang/lib/Evaluate/tools.cpp
index e5bc9cd953fd0..3f62c2c7e4ef9 100644
--- a/flang/lib/Evaluate/tools.cpp
+++ b/flang/lib/Evaluate/tools.cpp
@@ -1598,31 +1598,6 @@ int CountNonConstantLenParameters(const DerivedTypeSpec &type) {
});
}
-// 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
index 6c9431b50022f..acedf59328c26 100644
--- a/flang/lib/Evaluate/type.cpp
+++ b/flang/lib/Evaluate/type.cpp
@@ -262,13 +262,65 @@ static bool AreSameComponent(const semantics::Symbol &x,
y.has<semantics::ObjectEntityDetails>();
}
+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<semantics::TypeParamDetails>()};
+ const auto *yTPD{yParm->detailsIf<semantics::TypeParamDetails>()};
+ 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 @@ static bool AreSameDerivedType(const semantics::DerivedTypeSpec &x,
inProgress.insert(thisQuery);
const auto &xDetails{xSymbol.get<semantics::DerivedTypeDetails>()};
const auto &yDetails{ySymbol.get<semantics::DerivedTypeDetails>()};
- 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 @@ static bool AreSameDerivedType(const semantics::DerivedTypeSpec &x,
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 @@ static bool AreCompatibleTypes(const DynamicType &x, const DynamicType &y,
} 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 @@ std::optional<bool> DynamicType::ExtendsTypeOf(const DynamicType &that) const {
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
index 275673e6e5ea8..e4b65fc8adfe4 100644
--- a/flang/lib/Semantics/check-call.cpp
+++ b/flang/lib/Semantics/check-call.cpp
@@ -296,16 +296,14 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
"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<DerivedTypeDetails>().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
index aa9246fb223e0..613a62cc4986b 100644
--- a/flang/lib/Semantics/definable.cpp
+++ b/flang/lib/Semantics/definable.cpp
@@ -228,8 +228,7 @@ std::optional<parser::Message> WhyNotDefinable(parser::CharBlock at,
while (spec) {
bool anyElemental{false};
const Symbol *anyRankMatch{nullptr};
- for (const auto &[_, ref] :
- spec->typeSymbol().get<DerivedTypeDetails>().finals()) {
+ for (auto ref : FinalsForDerivedTypeInstantiation(*spec)) {
const Symbol &ultimate{ref->GetUltimate()};
anyElemental |= ultimate.attrs().test(Attr::ELEMENTAL);
if (const auto *subp{ultimate.detailsIf<SubprogramDetails>()}) {
diff --git a/flang/lib/Semantics/runtime-type-info.cpp b/flang/lib/Semantics/runtime-type-info.cpp
index 94a1af6bff578..29f63524b5c07 100644
--- a/flang/lib/Semantics/runtime-type-info.cpp
+++ b/flang/lib/Semantics/runtime-type-info.cpp
@@ -573,12 +573,11 @@ const Symbol *RuntimeTableBuilder::DescribeType(Scope &dtScope) {
// do not (the runtime will call all of them).
std::map<int, evaluate::StructureConstructor> specials{
DescribeSpecialGenerics(dtScope, dtScope, derivedTypeSpec)};
- const DerivedTypeDetails &dtDetails{dtSymbol->get<DerivedTypeDetails>()};
- 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
index 41a5ac215826a..25d1f6c9fa490 100644
--- a/flang/lib/Semantics/tools.cpp
+++ b/flang/lib/Semantics/tools.cpp
@@ -702,6 +702,30 @@ bool IsSeparateModuleProcedureInterface(const Symbol *symbol) {
return false;
}
+SymbolVector FinalsForDerivedTypeInstantiation(const DerivedTypeSpec &spec) {
+ SymbolVector result;
+ const Symbol &typeSymbol{spec.typeSymbol()};
+ if (const auto *derived{typeSymbol.detailsIf<DerivedTypeDetails>()}) {
+ 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<SubprogramDetails>()};
+ 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<const DerivedTypeSpec *> *inProgress) {
if (IsPointer(symbol)) {
@@ -720,7 +744,7 @@ bool IsFinalizable(
bool IsFinalizable(const DerivedTypeSpec &derived,
std::set<const DerivedTypeSpec *> *inProgress) {
- if (!derived.typeSymbol().get<DerivedTypeDetails>().finals().empty()) {
+ if (!FinalsForDerivedTypeInstantiation(derived).empty()) {
return true;
}
std::set<const DerivedTypeSpec *> basis;
@@ -742,14 +766,12 @@ bool IsFinalizable(const DerivedTypeSpec &derived,
}
bool HasImpureFinal(const DerivedTypeSpec &derived) {
- if (const auto *details{
- derived.typeSymbol().detailsIf<DerivedTypeDetails>()}) {
- 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
index afc2baaaeedef..d895f01dba2ea 100644
--- a/flang/lib/Semantics/type.cpp
+++ b/flang/lib/Semantics/type.cpp
@@ -188,7 +188,7 @@ bool DerivedTypeSpec::HasDefaultInitialization(bool ignoreAllocatable) const {
}
bool DerivedTypeSpec::HasDestruction() const {
- if (!typeSymbol().get<DerivedTypeDetails>().finals().empty()) {
+ if (!FinalsForDerivedTypeInstantiation(*this).empty()) {
return true;
}
DirectComponentIterator components{*this};
@@ -366,7 +366,7 @@ void DerivedTypeSpec::Instantiate(Scope &containingScope) {
}
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
index a34394cccb8ae..7a860062262a9 100644
--- a/flang/test/Semantics/call03.f90
+++ b/flang/test/Semantics/call03.f90
@@ -168,12 +168,16 @@ subroutine test06 ! 15.5.2.4(4)
!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
index 0000000000000..c4013efb424eb
--- /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
More information about the flang-commits
mailing list