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 &);
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(
});
}
-// 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());
}
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
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))) {
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);
}
}
}
} 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);
}
}
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;
"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());
}
}
}
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>()}) {
// 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,
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)) {
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;
}
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) {
}
bool DerivedTypeSpec::HasDestruction() const {
- if (!typeSymbol().get<DerivedTypeDetails>().finals().empty()) {
+ if (!FinalsForDerivedTypeInstantiation(*this).empty()) {
return true;
}
DirectComponentIterator components{*this};
}
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) {
!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)
--- /dev/null
+! 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