diff --git a/flang/include/flang/Evaluate/characteristics.h b/flang/include/flang/Evaluate/characteristics.h --- a/flang/include/flang/Evaluate/characteristics.h +++ b/flang/include/flang/Evaluate/characteristics.h @@ -45,7 +45,7 @@ using common::CopyableIndirection; -// Are these procedures distinguishable for a generic name? +// Are these procedures distinguishable for a generic name or FINAL? bool Distinguishable(const Procedure &, const Procedure &); // Are these procedures distinguishable for a generic operator or assignment? bool DistinguishableOpOrAssign(const Procedure &, const Procedure &); diff --git a/flang/include/flang/Evaluate/type.h b/flang/include/flang/Evaluate/type.h --- a/flang/include/flang/Evaluate/type.h +++ b/flang/include/flang/Evaluate/type.h @@ -166,11 +166,9 @@ bool HasDeferredTypeParameter() const; // 7.3.2.3 & 15.5.2.4 type compatibility. - // x.IsTypeCompatibleWith(y) is true if "x => y" or passing actual y to + // x.IsTkCompatibleWith(y) is true if "x => y" or passing actual y to // dummy argument x would be valid. Be advised, this is not a reflexive - // relation. - bool IsTypeCompatibleWith(const DynamicType &) const; - // Type compatible and kind type parameters match + // relation. Kind type parameters must match. bool IsTkCompatibleWith(const DynamicType &) const; // Result will be missing when a symbol is absent or diff --git a/flang/include/flang/Semantics/symbol.h b/flang/include/flang/Semantics/symbol.h --- a/flang/include/flang/Semantics/symbol.h +++ b/flang/include/flang/Semantics/symbol.h @@ -248,6 +248,8 @@ const std::list ¶mNames() const { return paramNames_; } const SymbolVector ¶mDecls() const { return paramDecls_; } bool sequence() const { return sequence_; } + std::map &finals() { return finals_; } + const std::map &finals() const { return finals_; } bool isForwardReferenced() const { return isForwardReferenced_; } void add_paramName(const SourceName &name) { paramNames_.push_back(name); } void add_paramDecl(const Symbol &symbol) { paramDecls_.push_back(symbol); } @@ -279,6 +281,7 @@ // These are the names of the derived type's components in component // order. A parent component, if any, appears first in this list. std::list componentNames_; + std::map finals_; // FINAL :: subr bool sequence_{false}; bool isForwardReferenced_{false}; friend llvm::raw_ostream &operator<<( @@ -322,8 +325,6 @@ std::size_t alignment_{0}; // required alignment in bytes }; -class FinalProcDetails {}; // TODO - class MiscDetails { public: ENUM_CLASS(Kind, None, ConstructName, ScopeName, PassName, ComplexPartRe, @@ -471,7 +472,7 @@ ObjectEntityDetails, ProcEntityDetails, AssocEntityDetails, DerivedTypeDetails, UseDetails, UseErrorDetails, HostAssocDetails, GenericDetails, ProcBindingDetails, NamelistDetails, CommonBlockDetails, - FinalProcDetails, TypeParamDetails, MiscDetails>; + TypeParamDetails, MiscDetails>; llvm::raw_ostream &operator<<(llvm::raw_ostream &, const Details &); std::string DetailsToString(const Details &); 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 @@ -162,6 +162,7 @@ } bool IsAssumedLengthCharacter(const Symbol &); bool IsExternal(const Symbol &); +bool IsModuleProcedure(const Symbol &); // Is the symbol modifiable in this scope std::optional WhyNotModifiable( const Symbol &, const Scope &); @@ -283,6 +284,20 @@ return value && *value == 0; } +// 15.2.2 +enum class ProcedureDefinitionClass { + None, + Intrinsic, + External, + Internal, + Module, + Dummy, + Pointer, + StatementFunction +}; + +ProcedureDefinitionClass ClassifyProcedure(const Symbol &); + // Derived type component iterator that provides a C++ LegacyForwardIterator // iterator over the Ordered, Direct, Ultimate or Potential components of a // DerivedTypeSpec. These iterators can be used with STL algorithms diff --git a/flang/lib/Evaluate/characteristics.cpp b/flang/lib/Evaluate/characteristics.cpp --- a/flang/lib/Evaluate/characteristics.cpp +++ b/flang/lib/Evaluate/characteristics.cpp @@ -130,7 +130,7 @@ const TypeAndShape &that, const char *thisIs, const char *thatIs, bool isElemental) const { const auto &len{that.LEN()}; - if (!type_.IsTypeCompatibleWith(that.type_)) { + if (!type_.IsTkCompatibleWith(that.type_)) { messages.Say( "%1$s type '%2$s' is not compatible with %3$s type '%4$s'"_err_en_US, thatIs, that.type_.AsFortran(len ? len->AsFortran() : ""), thisIs, 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 @@ -965,7 +965,6 @@ [](const GenericDetails &) { return true; }, [](const ProcBindingDetails &) { return true; }, [](const UseDetails &x) { return IsProcedure(x.symbol()); }, - // TODO: FinalProcDetails? [](const auto &) { return false; }, }, symbol.details()); 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 @@ -218,19 +218,6 @@ } } -static const semantics::Symbol *FindComponent( - const semantics::DerivedTypeSpec &derived, parser::CharBlock name) { - if (const auto *scope{derived.scope()}) { - auto iter{scope->find(name)}; - if (iter != scope->end()) { - return &*iter->second; - } else if (const auto *parent{GetParentTypeSpec(derived)}) { - return FindComponent(*parent, name); - } - } - return nullptr; -} - // Compares two derived type representations to see whether they both // represent the "same type" in the sense of section 7.5.2.4. using SetOfDerivedTypePairs = @@ -294,24 +281,9 @@ if (x.attrs().test(semantics::Attr::PRIVATE)) { return false; } -#if 0 // TODO - if (const auto *xObject{x.detailsIf()}) { - if (const auto *yObject{y.detailsIf()}) { -#else - if (x.has()) { - if (y.has()) { -#endif - // TODO: compare types, type parameters, bounds, &c. - return true; -} -else { - return false; -} -} // namespace Fortran::evaluate -else { - // TODO: non-object components - return true; -} + // TODO: compare types, parameters, bounds, &c. + return x.has() == + y.has(); } static bool AreCompatibleDerivedTypes(const semantics::DerivedTypeSpec *x, @@ -334,45 +306,9 @@ return param && param->attr() == common::TypeParamAttr::Kind; } -static bool IsKindTypeParameter( - const semantics::DerivedTypeSpec &derived, parser::CharBlock name) { - const semantics::Symbol *symbol{FindComponent(derived, name)}; - return symbol && IsKindTypeParameter(*symbol); -} - -bool DynamicType::IsTypeCompatibleWith(const DynamicType &that) const { - if (derived_) { - if (!AreCompatibleDerivedTypes(derived_, that.derived_, IsPolymorphic())) { - return false; - } - // The values of derived type KIND parameters must match. - for (const auto &[name, param] : derived_->parameters()) { - if (IsKindTypeParameter(*derived_, name)) { - bool ok{false}; - if (auto myValue{ToInt64(param.GetExplicit())}) { - if (const auto *thatParam{that.derived_->FindParameter(name)}) { - if (auto thatValue{ToInt64(thatParam->GetExplicit())}) { - ok = *myValue == *thatValue; - } - } - } - if (!ok) { - return false; - } - } - } - return true; - } else if (category_ == that.category_ && kind_ == that.kind_) { - // CHARACTER length is not checked here - return true; - } else { - return IsUnlimitedPolymorphic(); - } -} - // Do the kind type parameters of type1 have the same values as the -// corresponding kind type parameters of the type2? -static bool IsKindCompatible(const semantics::DerivedTypeSpec &type1, +// corresponding kind type parameters of type2? +static bool AreKindCompatible(const semantics::DerivedTypeSpec &type1, const semantics::DerivedTypeSpec &type2) { for (const auto &[name, param1] : type1.parameters()) { if (param1.isKind()) { @@ -385,18 +321,20 @@ return true; } +// See 7.3.2.3 (5) & 15.5.2.4 bool DynamicType::IsTkCompatibleWith(const DynamicType &that) const { - if (category_ != TypeCategory::Derived) { - return category_ == that.category_ && kind_ == that.kind_; - } else if (IsUnlimitedPolymorphic()) { + if (IsUnlimitedPolymorphic()) { return true; } else if (that.IsUnlimitedPolymorphic()) { return false; - } else if (!derived_ || !that.derived_ || - !IsKindCompatible(*derived_, *that.derived_)) { - return false; // kind params don't match + } else if (category_ != that.category_) { + return false; + } else if (derived_) { + return that.derived_ && + AreCompatibleDerivedTypes(derived_, that.derived_, IsPolymorphic()) && + AreKindCompatible(*derived_, *that.derived_); } else { - return AreCompatibleDerivedTypes(derived_, that.derived_, IsPolymorphic()); + return kind_ == that.kind_; } } 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 @@ -144,8 +144,7 @@ parser::ContextualMessages &messages{context.messages()}; PadShortCharacterActual(actual, dummy.type, actualType, messages); ConvertIntegerActual(actual, dummy.type, actualType, messages); - bool typesCompatible{ - dummy.type.type().IsTypeCompatibleWith(actualType.type())}; + bool typesCompatible{dummy.type.type().IsTkCompatibleWith(actualType.type())}; if (typesCompatible) { if (isElemental) { } else if (dummy.type.attrs().test( @@ -215,13 +214,17 @@ "Actual argument associated with TYPE(*) %s may not have type-bound procedure '%s'"_err_en_US, dummyName, tbp->name()); } - if (const Symbol * - finalizer{FindImmediateComponent(*derived, [](const Symbol &symbol) { - return symbol.has(); - })}) { // 15.5.2.4(2) - evaluate::SayWithDeclaration(messages, *finalizer, - "Actual argument associated with TYPE(*) %s may not have FINAL subroutine '%s'"_err_en_US, - dummyName, finalizer->name()); + const auto &finals{ + derived->typeSymbol().get().finals()}; + if (!finals.empty()) { // 15.5.2.4(2) + 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()); + } } } if (actualIsCoindexed) { @@ -431,14 +434,14 @@ "If a POINTER or ALLOCATABLE dummy or actual argument is polymorphic, both must be so"_err_en_US); } } else if (!actualIsUnlimited && typesCompatible) { - if (!actualType.type().IsTypeCompatibleWith(dummy.type.type())) { + if (!actualType.type().IsTkCompatibleWith(dummy.type.type())) { if (dummy.intent == common::Intent::In) { // extension: allow with warning, rule is only relevant for definables messages.Say( - "POINTER or ALLOCATABLE dummy and actual arguments should have the same declared type"_en_US); + "POINTER or ALLOCATABLE dummy and actual arguments should have the same declared type and kind"_en_US); } else { messages.Say( - "POINTER or ALLOCATABLE dummy and actual arguments must have the same declared type"_err_en_US); + "POINTER or ALLOCATABLE dummy and actual arguments must have the same declared type and kind"_err_en_US); } } if (const auto *derived{ diff --git a/flang/lib/Semantics/check-declarations.cpp b/flang/lib/Semantics/check-declarations.cpp --- a/flang/lib/Semantics/check-declarations.cpp +++ b/flang/lib/Semantics/check-declarations.cpp @@ -66,6 +66,10 @@ void CheckSubprogram(const Symbol &, const SubprogramDetails &); void CheckAssumedTypeEntity(const Symbol &, const ObjectEntityDetails &); void CheckDerivedType(const Symbol &, const DerivedTypeDetails &); + bool CheckFinal( + const Symbol &subroutine, SourceName, const Symbol &derivedType); + bool CheckDistinguishableFinals(const Symbol &f1, SourceName f1name, + const Symbol &f2, SourceName f2name, const Symbol &derivedType); void CheckGeneric(const Symbol &, const GenericDetails &); void CheckHostAssoc(const Symbol &, const HostAssocDetails &); bool CheckDefinedOperator( @@ -781,24 +785,24 @@ } void CheckHelper::CheckDerivedType( - const Symbol &symbol, const DerivedTypeDetails &details) { - const Scope *scope{symbol.scope()}; + const Symbol &derivedType, const DerivedTypeDetails &details) { + const Scope *scope{derivedType.scope()}; if (!scope) { CHECK(details.isForwardReferenced()); return; } - CHECK(scope->symbol() == &symbol); + CHECK(scope->symbol() == &derivedType); CHECK(scope->IsDerivedType()); - if (symbol.attrs().test(Attr::ABSTRACT) && // C734 - (symbol.attrs().test(Attr::BIND_C) || details.sequence())) { + if (derivedType.attrs().test(Attr::ABSTRACT) && // C734 + (derivedType.attrs().test(Attr::BIND_C) || details.sequence())) { messages_.Say("An ABSTRACT derived type must be extensible"_err_en_US); } - if (const DeclTypeSpec * parent{FindParentTypeSpec(symbol)}) { + if (const DeclTypeSpec * parent{FindParentTypeSpec(derivedType)}) { const DerivedTypeSpec *parentDerived{parent->AsDerived()}; if (!IsExtensibleType(parentDerived)) { // C705 messages_.Say("The parent type is not extensible"_err_en_US); } - if (!symbol.attrs().test(Attr::ABSTRACT) && parentDerived && + if (!derivedType.attrs().test(Attr::ABSTRACT) && parentDerived && parentDerived->typeSymbol().attrs().test(Attr::ABSTRACT)) { ScopeComponentIterator components{*parentDerived}; for (const Symbol &component : components) { @@ -811,7 +815,7 @@ } } } - DerivedTypeSpec derived{symbol.name(), symbol}; + DerivedTypeSpec derived{derivedType.name(), derivedType}; derived.set_scope(*scope); if (FindCoarrayUltimateComponent(derived) && // C736 !(parentDerived && FindCoarrayUltimateComponent(*parentDerived))) { @@ -819,7 +823,7 @@ "Type '%s' has a coarray ultimate component so the type at the base " "of its type extension chain ('%s') must be a type that has a " "coarray ultimate component"_err_en_US, - symbol.name(), scope->GetDerivedTypeBase().GetSymbol()->name()); + derivedType.name(), scope->GetDerivedTypeBase().GetSymbol()->name()); } if (FindEventOrLockPotentialComponent(derived) && // C737 !(FindEventOrLockPotentialComponent(*parentDerived) || @@ -829,13 +833,154 @@ "at the base of its type extension chain ('%s') must either have an " "EVENT_TYPE or LOCK_TYPE component, or be EVENT_TYPE or " "LOCK_TYPE"_err_en_US, - symbol.name(), scope->GetDerivedTypeBase().GetSymbol()->name()); + derivedType.name(), scope->GetDerivedTypeBase().GetSymbol()->name()); } } - if (HasIntrinsicTypeName(symbol)) { // C729 + if (HasIntrinsicTypeName(derivedType)) { // C729 messages_.Say("A derived type name cannot be the name of an intrinsic" " type"_err_en_US); } + std::map previous; + for (const auto &pair : details.finals()) { + SourceName source{pair.first}; + const Symbol &ref{*pair.second}; + if (CheckFinal(ref, source, derivedType) && + std::all_of(previous.begin(), previous.end(), + [&](std::pair prev) { + return CheckDistinguishableFinals( + ref, source, *prev.second, prev.first, derivedType); + })) { + previous.emplace(source, ref); + } + } +} + +// C786 +bool CheckHelper::CheckFinal( + const Symbol &subroutine, SourceName finalName, const Symbol &derivedType) { + if (!IsModuleProcedure(subroutine)) { + SayWithDeclaration(subroutine, finalName, + "FINAL subroutine '%s' of derived type '%s' must be a module procedure"_err_en_US, + subroutine.name(), derivedType.name()); + return false; + } + const Procedure *proc{Characterize(subroutine)}; + if (!proc) { + return false; // error recovery + } + if (!proc->IsSubroutine()) { + SayWithDeclaration(subroutine, finalName, + "FINAL subroutine '%s' of derived type '%s' must be a subroutine"_err_en_US, + subroutine.name(), derivedType.name()); + return false; + } + if (proc->dummyArguments.size() != 1) { + SayWithDeclaration(subroutine, finalName, + "FINAL subroutine '%s' of derived type '%s' must have a single dummy argument"_err_en_US, + subroutine.name(), derivedType.name()); + return false; + } + const auto &arg{proc->dummyArguments[0]}; + const Symbol *errSym{&subroutine}; + if (const auto *details{subroutine.detailsIf()}) { + if (!details->dummyArgs().empty()) { + if (const Symbol * argSym{details->dummyArgs()[0]}) { + errSym = argSym; + } + } + } + const auto *ddo{std::get_if(&arg.u)}; + if (!ddo) { + SayWithDeclaration(subroutine, finalName, + "FINAL subroutine '%s' of derived type '%s' must have a single dummy argument that is a data object"_err_en_US, + subroutine.name(), derivedType.name()); + return false; + } + bool ok{true}; + if (arg.IsOptional()) { + SayWithDeclaration(*errSym, finalName, + "FINAL subroutine '%s' of derived type '%s' must not have an OPTIONAL dummy argument"_err_en_US, + subroutine.name(), derivedType.name()); + ok = false; + } + if (ddo->attrs.test(DummyDataObject::Attr::Allocatable)) { + SayWithDeclaration(*errSym, finalName, + "FINAL subroutine '%s' of derived type '%s' must not have an ALLOCATABLE dummy argument"_err_en_US, + subroutine.name(), derivedType.name()); + ok = false; + } + if (ddo->attrs.test(DummyDataObject::Attr::Pointer)) { + SayWithDeclaration(*errSym, finalName, + "FINAL subroutine '%s' of derived type '%s' must not have a POINTER dummy argument"_err_en_US, + subroutine.name(), derivedType.name()); + ok = false; + } + if (ddo->intent == common::Intent::Out) { + SayWithDeclaration(*errSym, finalName, + "FINAL subroutine '%s' of derived type '%s' must not have a dummy argument with INTENT(OUT)"_err_en_US, + subroutine.name(), derivedType.name()); + ok = false; + } + if (ddo->attrs.test(DummyDataObject::Attr::Value)) { + SayWithDeclaration(*errSym, finalName, + "FINAL subroutine '%s' of derived type '%s' must not have a dummy argument with the VALUE attribute"_err_en_US, + subroutine.name(), derivedType.name()); + ok = false; + } + if (ddo->type.corank() > 0) { + SayWithDeclaration(*errSym, finalName, + "FINAL subroutine '%s' of derived type '%s' must not have a coarray dummy argument"_err_en_US, + subroutine.name(), derivedType.name()); + ok = false; + } + if (ddo->type.type().IsPolymorphic()) { + SayWithDeclaration(*errSym, finalName, + "FINAL subroutine '%s' of derived type '%s' must not have a polymorphic dummy argument"_err_en_US, + subroutine.name(), derivedType.name()); + ok = false; + } else if (ddo->type.type().category() != TypeCategory::Derived || + &ddo->type.type().GetDerivedTypeSpec().typeSymbol() != &derivedType) { + SayWithDeclaration(*errSym, finalName, + "FINAL subroutine '%s' of derived type '%s' must have a TYPE(%s) dummy argument"_err_en_US, + subroutine.name(), derivedType.name(), derivedType.name()); + ok = false; + } else { // check that all LEN type parameters are assumed + for (auto ref : OrderParameterDeclarations(derivedType)) { + if (const auto *paramDetails{ref->detailsIf()}) { + if (paramDetails->attr() == common::TypeParamAttr::Len) { + const auto *value{ + ddo->type.type().GetDerivedTypeSpec().FindParameter(ref->name())}; + if (!value || !value->isAssumed()) { + SayWithDeclaration(*errSym, finalName, + "FINAL subroutine '%s' of derived type '%s' must have a dummy argument with an assumed LEN type parameter '%s=*'"_err_en_US, + subroutine.name(), derivedType.name(), ref->name()); + ok = false; + } + } + } + } + } + return ok; +} + +bool CheckHelper::CheckDistinguishableFinals(const Symbol &f1, + SourceName f1Name, const Symbol &f2, SourceName f2Name, + const Symbol &derivedType) { + const Procedure *p1{Characterize(f1)}; + const Procedure *p2{Characterize(f2)}; + if (p1 && p2) { + if (characteristics::Distinguishable(*p1, *p2)) { + return true; + } + if (auto *msg{messages_.Say(f1Name, + "FINAL subroutines '%s' and '%s' of derived type '%s' cannot be distinguished by rank or KIND type parameter value"_err_en_US, + f1Name, f2Name, derivedType.name())}) { + msg->Attach(f2Name, "FINAL declaration of '%s'"_en_US, f2.name()) + .Attach(f1.name(), "Definition of '%s'"_en_US, f1Name) + .Attach(f2.name(), "Definition of '%s'"_en_US, f2Name); + } + } + return false; } void CheckHelper::CheckHostAssoc( diff --git a/flang/lib/Semantics/mod-file.h b/flang/lib/Semantics/mod-file.h --- a/flang/lib/Semantics/mod-file.h +++ b/flang/lib/Semantics/mod-file.h @@ -53,7 +53,8 @@ void WriteOne(const Scope &); void Write(const Symbol &); std::string GetAsString(const Symbol &); - void PutSymbols(const Scope &); + // Returns true if a derived type with bindings and "contains" was emitted + bool PutSymbols(const Scope &); void PutSymbol(llvm::raw_ostream &, const Symbol &); void PutDerivedType(const Symbol &); void PutSubprogram(const Symbol &); diff --git a/flang/lib/Semantics/mod-file.cpp b/flang/lib/Semantics/mod-file.cpp --- a/flang/lib/Semantics/mod-file.cpp +++ b/flang/lib/Semantics/mod-file.cpp @@ -177,7 +177,7 @@ } // Put out the visible symbols from scope. -void ModFileWriter::PutSymbols(const Scope &scope) { +bool ModFileWriter::PutSymbols(const Scope &scope) { std::string buf; llvm::raw_string_ostream typeBindings{ buf}; // stuff after CONTAINS in derived type @@ -187,6 +187,9 @@ if (auto str{typeBindings.str()}; !str.empty()) { CHECK(scope.IsDerivedType()); decls_ << "contains\n" << str; + return true; + } else { + return false; } } @@ -257,9 +260,6 @@ decls_ << "::/" << symbol.name() << "/\n"; } }, - [&](const FinalProcDetails &) { - typeBindings << "final::" << symbol.name() << '\n'; - }, [](const HostAssocDetails &) {}, [](const MiscDetails &) {}, [&](const auto &) { PutEntity(decls_, symbol); }, @@ -287,7 +287,17 @@ if (details.sequence()) { decls_ << "sequence\n"; } - PutSymbols(typeScope); + bool contains{PutSymbols(typeScope)}; + if (!details.finals().empty()) { + const char *sep{contains ? "final::" : "contains\nfinal::"}; + for (const auto &pair : details.finals()) { + decls_ << sep << pair.second->name(); + sep = ","; + } + if (*sep == ',') { + decls_ << '\n'; + } + } decls_ << "end type\n"; } diff --git a/flang/lib/Semantics/pointer-assignment.cpp b/flang/lib/Semantics/pointer-assignment.cpp --- a/flang/lib/Semantics/pointer-assignment.cpp +++ b/flang/lib/Semantics/pointer-assignment.cpp @@ -219,7 +219,7 @@ " derived type when target is unlimited polymorphic"_err_en_US; } } else { - if (!lhsType_->type().IsTypeCompatibleWith(rhsType->type())) { + if (!lhsType_->type().IsTkCompatibleWith(rhsType->type())) { msg = MessageFormattedText{ "Target type %s is not compatible with pointer type %s"_err_en_US, rhsType->type().AsFortran(), lhsType_->type().AsFortran()}; diff --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp --- a/flang/lib/Semantics/resolve-names.cpp +++ b/flang/lib/Semantics/resolve-names.cpp @@ -4028,8 +4028,22 @@ } void DeclarationVisitor::Post(const parser::FinalProcedureStmt &x) { - for (auto &name : x.v) { - MakeTypeSymbol(name, FinalProcDetails{}); + if (currScope().IsDerivedType() && currScope().symbol()) { + if (auto *details{currScope().symbol()->detailsIf()}) { + for (const auto &subrName : x.v) { + if (const auto *name{ResolveName(subrName)}) { + auto pair{ + details->finals().emplace(name->source, DEREF(name->symbol))}; + if (!pair.second) { // C787 + Say(name->source, + "FINAL subroutine '%s' already appeared in this derived type"_err_en_US, + name->source) + .Attach(pair.first->first, + "earlier appearance of this FINAL subroutine"_en_US); + } + } + } + } } } diff --git a/flang/lib/Semantics/symbol.cpp b/flang/lib/Semantics/symbol.cpp --- a/flang/lib/Semantics/symbol.cpp +++ b/flang/lib/Semantics/symbol.cpp @@ -228,7 +228,6 @@ [](const ProcBindingDetails &) { return "ProcBinding"; }, [](const NamelistDetails &) { return "Namelist"; }, [](const CommonBlockDetails &) { return "CommonBlockDetails"; }, - [](const FinalProcDetails &) { return "FinalProc"; }, [](const TypeParamDetails &) { return "TypeParam"; }, [](const MiscDetails &) { return "Misc"; }, [](const AssocEntityDetails &) { return "AssocEntity"; }, @@ -436,7 +435,6 @@ os << ' ' << object->name(); } }, - [&](const FinalProcDetails &) {}, [&](const TypeParamDetails &x) { DumpOptional(os, "type", x.type()); os << ' ' << common::EnumToString(x.attr()); 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 @@ -637,20 +637,23 @@ } bool IsFinalizable(const DerivedTypeSpec &derived) { - ScopeComponentIterator components{derived}; - return std::find_if(components.begin(), components.end(), - [](const Symbol &x) { return x.has(); }) != - components.end(); + if (!derived.typeSymbol().get().finals().empty()) { + return true; + } + DirectComponentIterator components{derived}; + return bool{std::find_if(components.begin(), components.end(), + [](const Symbol &component) { return IsFinalizable(component); })}; } -// TODO The following function returns true for all types with FINAL procedures -// This is because we don't yet fill in the data for FinalProcDetails bool HasImpureFinal(const DerivedTypeSpec &derived) { - ScopeComponentIterator components{derived}; - return std::find_if( - components.begin(), components.end(), [](const Symbol &x) { - return x.has() && !x.attrs().test(Attr::PURE); - }) != components.end(); + if (const auto *details{ + derived.typeSymbol().detailsIf()}) { + const auto &finals{details->finals()}; + return std::any_of(finals.begin(), finals.end(), + [](const auto &x) { return !x.second->attrs().test(Attr::PURE); }); + } else { + return false; + } } bool IsCoarray(const Symbol &symbol) { return symbol.Corank() > 0; } @@ -701,10 +704,12 @@ // C722 and C723: For a function to be assumed length, it must be external and // of CHARACTER type bool IsExternal(const Symbol &symbol) { - return (symbol.has() && symbol.owner().IsGlobal()) || - symbol.attrs().test(Attr::EXTERNAL); + return ClassifyProcedure(symbol) == ProcedureDefinitionClass::External; } +bool IsModuleProcedure(const Symbol &symbol) { + return ClassifyProcedure(symbol) == ProcedureDefinitionClass::Module; +} const Symbol *IsExternalInPureContext( const Symbol &symbol, const Scope &scope) { if (const auto *pureProc{FindPureProcedureContaining(scope)}) { @@ -1005,6 +1010,39 @@ return nullptr; } +ProcedureDefinitionClass ClassifyProcedure(const Symbol &symbol) { // 15.2.2 + const Symbol &ultimate{symbol.GetUltimate()}; + if (ultimate.attrs().test(Attr::INTRINSIC)) { + return ProcedureDefinitionClass::Intrinsic; + } else if (ultimate.attrs().test(Attr::EXTERNAL)) { + return ProcedureDefinitionClass::External; + } else if (const auto *procDetails{ultimate.detailsIf()}) { + if (procDetails->isDummy()) { + return ProcedureDefinitionClass::Dummy; + } else if (IsPointer(ultimate)) { + return ProcedureDefinitionClass::Pointer; + } + } else if (const Symbol * subp{FindSubprogram(symbol)}) { + if (const auto *subpDetails{subp->detailsIf()}) { + if (subpDetails->stmtFunction()) { + return ProcedureDefinitionClass::StatementFunction; + } + } + switch (ultimate.owner().kind()) { + case Scope::Kind::Global: + return ProcedureDefinitionClass::External; + case Scope::Kind::Module: + return ProcedureDefinitionClass::Module; + case Scope::Kind::MainProgram: + case Scope::Kind::Subprogram: + return ProcedureDefinitionClass::Internal; + default: + break; + } + } + return ProcedureDefinitionClass::None; +} + // ComponentIterator implementation template 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 @@ -29,7 +29,7 @@ class(tbp), intent(in) :: this end subroutine subroutine subr02(this) - class(final), intent(in) :: this + type(final), intent(inout) :: this end subroutine subroutine poly(x) @@ -113,7 +113,7 @@ subroutine test05 ! 15.5.2.4(2) type(final) :: x - !ERROR: Actual argument associated with TYPE(*) dummy argument 'x=' may not have FINAL subroutine 'subr02' + !ERROR: Actual argument associated with TYPE(*) dummy argument 'x=' may not have derived type 'final' with FINAL subroutine 'subr02' call typestar(x) end subroutine diff --git a/flang/test/Semantics/call05.f90 b/flang/test/Semantics/call05.f90 --- a/flang/test/Semantics/call05.f90 +++ b/flang/test/Semantics/call05.f90 @@ -89,9 +89,9 @@ call spp(up) !ERROR: Actual argument type 'CLASS(*)' is not compatible with dummy argument type 't' call spa(ua) - !ERROR: POINTER or ALLOCATABLE dummy and actual arguments must have the same declared type + !ERROR: POINTER or ALLOCATABLE dummy and actual arguments must have the same declared type and kind call spp(pp2) - !ERROR: POINTER or ALLOCATABLE dummy and actual arguments must have the same declared type + !ERROR: POINTER or ALLOCATABLE dummy and actual arguments must have the same declared type and kind call spa(pa2) !ERROR: Rank of dummy argument is 1, but actual argument has rank 2 call smp(mpmat) diff --git a/flang/test/Semantics/final01.f90 b/flang/test/Semantics/final01.f90 new file mode 100644 --- /dev/null +++ b/flang/test/Semantics/final01.f90 @@ -0,0 +1,119 @@ +! RUN: %S/test_errors.sh %s %t %f18 +! Test FINAL subroutine constraints C786-C789 +module m1 + external :: external + intrinsic :: sin + real :: object + procedure(valid), pointer :: pointer + type :: parent(kind1, len1) + integer, kind :: kind1 = 1 + integer, len :: len1 = 1 + end type + type, extends(parent) :: child(kind2, len2) + integer, kind :: kind2 = 2 + integer, len :: len2 = 2 + contains + final :: valid +!ERROR: FINAL subroutine 'external' of derived type 'child' must be a module procedure +!ERROR: FINAL subroutine 'sin' of derived type 'child' must be a module procedure +!ERROR: FINAL subroutine 'object' of derived type 'child' must be a module procedure +!ERROR: FINAL subroutine 'pointer' of derived type 'child' must be a module procedure +!ERROR: FINAL subroutine 'func' of derived type 'child' must be a subroutine + final :: external, sin, object, pointer, func +!ERROR: FINAL subroutine 's01' of derived type 'child' must have a single dummy argument that is a data object +!ERROR: FINAL subroutine 's02' of derived type 'child' must have a single dummy argument that is a data object +!ERROR: FINAL subroutine 's03' of derived type 'child' must not have a dummy argument with INTENT(OUT) +!ERROR: FINAL subroutine 's04' of derived type 'child' must not have a dummy argument with the VALUE attribute +!ERROR: FINAL subroutine 's05' of derived type 'child' must not have a POINTER dummy argument +!ERROR: FINAL subroutine 's06' of derived type 'child' must not have an ALLOCATABLE dummy argument +!ERROR: FINAL subroutine 's07' of derived type 'child' must not have a coarray dummy argument +!ERROR: FINAL subroutine 's08' of derived type 'child' must not have a polymorphic dummy argument +!ERROR: FINAL subroutine 's09' of derived type 'child' must not have a polymorphic dummy argument +!ERROR: FINAL subroutine 's10' of derived type 'child' must not have an OPTIONAL dummy argument + final :: s01, s02, s03, s04, s05, s06, s07, s08, s09, s10 +!ERROR: FINAL subroutine 's11' of derived type 'child' must have a single dummy argument +!ERROR: FINAL subroutine 's12' of derived type 'child' must have a single dummy argument +!ERROR: FINAL subroutine 's13' of derived type 'child' must have a dummy argument with an assumed LEN type parameter 'len1=*' +!ERROR: FINAL subroutine 's13' of derived type 'child' must have a dummy argument with an assumed LEN type parameter 'len2=*' +!ERROR: FINAL subroutine 's14' of derived type 'child' must have a dummy argument with an assumed LEN type parameter 'len2=*' +!ERROR: FINAL subroutine 's15' of derived type 'child' must have a dummy argument with an assumed LEN type parameter 'len1=*' +!ERROR: FINAL subroutine 's16' of derived type 'child' must not have a polymorphic dummy argument +!ERROR: FINAL subroutine 's17' of derived type 'child' must have a TYPE(child) dummy argument + final :: s11, s12, s13, s14, s15, s16, s17 +!ERROR: FINAL subroutine 'valid' already appeared in this derived type + final :: valid +!ERROR: FINAL subroutines 'valid2' and 'valid' of derived type 'child' cannot be distinguished by rank or KIND type parameter value + final :: valid2 + end type + contains + subroutine valid(x) + type(child(len1=*, len2=*)), intent(inout) :: x + end subroutine + subroutine valid2(x) + type(child(len1=*, len2=*)), intent(inout) :: x + end subroutine + real function func(x) + type(child(len1=*, len2=*)), intent(inout) :: x + func = 0. + end function + subroutine s01(*) + end subroutine + subroutine s02(x) + external :: x + end subroutine + subroutine s03(x) + type(child(kind1=3, len1=*, len2=*)), intent(out) :: x + end subroutine + subroutine s04(x) + type(child(kind1=4, len1=*, len2=*)), value :: x + end subroutine + subroutine s05(x) + type(child(kind1=5, len1=*, len2=*)), pointer :: x + end subroutine + subroutine s06(x) + type(child(kind1=6, len1=*, len2=*)), allocatable :: x + end subroutine + subroutine s07(x) + type(child(kind1=7, len1=*, len2=*)) :: x[*] + end subroutine + subroutine s08(x) + class(child(kind1=8, len1=*, len2=*)) :: x + end subroutine + subroutine s09(x) + class(*) :: x + end subroutine + subroutine s10(x) + type(child(kind1=10, len1=*, len2=*)), optional :: x + end subroutine + subroutine s11(x, y) + type(child(kind1=11, len1=*, len2=*)) :: x, y + end subroutine + subroutine s12 + end subroutine + subroutine s13(x) + type(child(kind1=13)) :: x + end subroutine + subroutine s14(x) + type(child(kind1=14, len1=*,len2=2)) :: x + end subroutine + subroutine s15(x) + type(child(kind1=15, len2=*)) :: x + end subroutine + subroutine s16(x) + type(*) :: x + end subroutine + subroutine s17(x) + type(parent(kind1=17, len1=*)) :: x + end subroutine + subroutine nested + type :: t + contains +!ERROR: FINAL subroutine 'internal' of derived type 't' must be a module procedure + final :: internal + end type + contains + subroutine internal(x) + type(t), intent(inout) :: x + end subroutine + end subroutine +end module diff --git a/flang/test/Semantics/modfile10.f90 b/flang/test/Semantics/modfile10.f90 --- a/flang/test/Semantics/modfile10.f90 +++ b/flang/test/Semantics/modfile10.f90 @@ -64,8 +64,8 @@ ! type::t2 ! integer(4)::x ! contains -! final::c ! procedure,non_overridable,private::d +! final::c ! end type ! type,abstract::t2a ! contains diff --git a/flang/test/Semantics/resolve32.f90 b/flang/test/Semantics/resolve32.f90 --- a/flang/test/Semantics/resolve32.f90 +++ b/flang/test/Semantics/resolve32.f90 @@ -57,7 +57,7 @@ contains procedure, nopass :: b => s final :: f - !ERROR: Type parameter, component, or procedure binding 'i' already defined in this type + !ERROR: FINAL subroutine 'i' of derived type 't2' must be a module procedure final :: i end type type t3 diff --git a/flang/test/Semantics/resolve55.f90 b/flang/test/Semantics/resolve55.f90 --- a/flang/test/Semantics/resolve55.f90 +++ b/flang/test/Semantics/resolve55.f90 @@ -36,25 +36,24 @@ end do end subroutine s4 -subroutine s5() +module m ! Cannot have a variable of a finalizable type in a locality spec type t1 integer :: i contains final :: f end type t1 - - type(t1) :: var - -!ERROR: Finalizable variable 'var' not allowed in a locality-spec - do concurrent(i=1:5) local(var) - end do - -contains + contains + subroutine s5() + type(t1) :: var + !ERROR: Finalizable variable 'var' not allowed in a locality-spec + do concurrent(i=1:5) local(var) + end do + end subroutine s5 subroutine f(x) type(t1) :: x end subroutine f -end subroutine s5 +end module m subroutine s6 ! Cannot have a nonpointer polymorphic dummy argument in a locality spec