From 37b2e2b04cf434b368b1edf29609be21952316f9 Mon Sep 17 00:00:00 2001 From: peter klausler Date: Wed, 30 Sep 2020 13:34:23 -0700 Subject: [PATCH] [flang] Semantic analysis for FINAL subroutines Represent FINAL subroutines in the symbol table entries of derived types. Enforce constraints. Update tests that have inadvertent violations or modified messages. Added a test. The specific procedure distinguishability checking code for generics was used to enforce distinguishability of FINAL procedures. (Also cleaned up some confusion and redundancy noticed in the type compatibility infrastructure while digging into that area.) Differential revision: https://reviews.llvm.org/D88613 --- flang/include/flang/Evaluate/characteristics.h | 2 +- flang/include/flang/Evaluate/type.h | 6 +- flang/include/flang/Semantics/symbol.h | 7 +- flang/include/flang/Semantics/tools.h | 15 +++ flang/lib/Evaluate/characteristics.cpp | 2 +- flang/lib/Evaluate/tools.cpp | 1 - flang/lib/Evaluate/type.cpp | 90 +++---------- flang/lib/Semantics/check-call.cpp | 27 ++-- flang/lib/Semantics/check-declarations.cpp | 167 +++++++++++++++++++++++-- flang/lib/Semantics/mod-file.cpp | 20 ++- flang/lib/Semantics/mod-file.h | 3 +- flang/lib/Semantics/pointer-assignment.cpp | 2 +- flang/lib/Semantics/resolve-names.cpp | 18 ++- flang/lib/Semantics/symbol.cpp | 2 - flang/lib/Semantics/tools.cpp | 64 ++++++++-- flang/test/Semantics/call03.f90 | 4 +- flang/test/Semantics/call05.f90 | 4 +- flang/test/Semantics/final01.f90 | 119 ++++++++++++++++++ flang/test/Semantics/modfile10.f90 | 2 +- flang/test/Semantics/resolve32.f90 | 2 +- flang/test/Semantics/resolve55.f90 | 19 ++- 21 files changed, 427 insertions(+), 149 deletions(-) create mode 100644 flang/test/Semantics/final01.f90 diff --git a/flang/include/flang/Evaluate/characteristics.h b/flang/include/flang/Evaluate/characteristics.h index fe7cc2d..bde734c 100644 --- a/flang/include/flang/Evaluate/characteristics.h +++ b/flang/include/flang/Evaluate/characteristics.h @@ -45,7 +45,7 @@ namespace Fortran::evaluate::characteristics { 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 index 663ece6..183cb6d 100644 --- a/flang/include/flang/Evaluate/type.h +++ b/flang/include/flang/Evaluate/type.h @@ -166,11 +166,9 @@ public: 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 index 5f861d1..ca6ab22 100644 --- a/flang/include/flang/Semantics/symbol.h +++ b/flang/include/flang/Semantics/symbol.h @@ -248,6 +248,8 @@ public: 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 @@ private: // 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 @@ private: 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 @@ using Details = std::variant; + 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 index 58ba7bf..6e1e06b 100644 --- a/flang/include/flang/Semantics/tools.h +++ b/flang/include/flang/Semantics/tools.h @@ -162,6 +162,7 @@ inline bool IsAssumedRankArray(const Symbol &symbol) { } 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 @@ template bool IsZero(const T &expr) { 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 index de01336..a28f4dd 100644 --- a/flang/lib/Evaluate/characteristics.cpp +++ b/flang/lib/Evaluate/characteristics.cpp @@ -130,7 +130,7 @@ bool TypeAndShape::IsCompatibleWith(parser::ContextualMessages &messages, 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 index 567a376..b560cce 100644 --- a/flang/lib/Evaluate/tools.cpp +++ b/flang/lib/Evaluate/tools.cpp @@ -965,7 +965,6 @@ bool IsProcedure(const Symbol &symbol) { [](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 index e96e191..e370f2b 100644 --- a/flang/lib/Evaluate/type.cpp +++ b/flang/lib/Evaluate/type.cpp @@ -218,19 +218,6 @@ const semantics::DerivedTypeSpec *GetParentTypeSpec( } } -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 @@ static bool AreSameComponent(const semantics::Symbol &x, 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 @@ bool IsKindTypeParameter(const semantics::Symbol &symbol) { 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 @@ static bool IsKindCompatible(const semantics::DerivedTypeSpec &type1, 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 index 8c3810c..7e1d57c 100644 --- a/flang/lib/Semantics/check-call.cpp +++ b/flang/lib/Semantics/check-call.cpp @@ -144,8 +144,7 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy, 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 @@ 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()); } - 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 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy, "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 index 896af3c..dee26ab 100644 --- a/flang/lib/Semantics/check-declarations.cpp +++ b/flang/lib/Semantics/check-declarations.cpp @@ -66,6 +66,10 @@ private: 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::CheckSubprogram( } 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 @@ void CheckHelper::CheckDerivedType( } } } - 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 @@ void CheckHelper::CheckDerivedType( "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 @@ void CheckHelper::CheckDerivedType( "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.cpp b/flang/lib/Semantics/mod-file.cpp index ef62a94..f714a3b 100644 --- a/flang/lib/Semantics/mod-file.cpp +++ b/flang/lib/Semantics/mod-file.cpp @@ -177,7 +177,7 @@ std::string ModFileWriter::GetAsString(const Symbol &symbol) { } // 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 @@ void ModFileWriter::PutSymbols(const Scope &scope) { if (auto str{typeBindings.str()}; !str.empty()) { CHECK(scope.IsDerivedType()); decls_ << "contains\n" << str; + return true; + } else { + return false; } } @@ -257,9 +260,6 @@ void ModFileWriter::PutSymbol( decls_ << "::/" << symbol.name() << "/\n"; } }, - [&](const FinalProcDetails &) { - typeBindings << "final::" << symbol.name() << '\n'; - }, [](const HostAssocDetails &) {}, [](const MiscDetails &) {}, [&](const auto &) { PutEntity(decls_, symbol); }, @@ -287,7 +287,17 @@ void ModFileWriter::PutDerivedType(const Symbol &typeSymbol) { 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/mod-file.h b/flang/lib/Semantics/mod-file.h index 17ffe804..08bf2e8 100644 --- a/flang/lib/Semantics/mod-file.h +++ b/flang/lib/Semantics/mod-file.h @@ -53,7 +53,8 @@ private: 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/pointer-assignment.cpp b/flang/lib/Semantics/pointer-assignment.cpp index 58719de..735e842 100644 --- a/flang/lib/Semantics/pointer-assignment.cpp +++ b/flang/lib/Semantics/pointer-assignment.cpp @@ -219,7 +219,7 @@ bool PointerAssignmentChecker::Check(const evaluate::Designator &d) { " 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 index b501ac6..0bdf871 100644 --- a/flang/lib/Semantics/resolve-names.cpp +++ b/flang/lib/Semantics/resolve-names.cpp @@ -4028,8 +4028,22 @@ void DeclarationVisitor::Post( } 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 index 1e046e0..06c4ac4 100644 --- a/flang/lib/Semantics/symbol.cpp +++ b/flang/lib/Semantics/symbol.cpp @@ -228,7 +228,6 @@ std::string DetailsToString(const Details &details) { [](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 @@ llvm::raw_ostream &operator<<(llvm::raw_ostream &os, const Details &details) { 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 index 848aef0..8bcbdc7 100644 --- a/flang/lib/Semantics/tools.cpp +++ b/flang/lib/Semantics/tools.cpp @@ -637,20 +637,23 @@ bool IsFinalizable(const Symbol &symbol) { } 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 @@ bool IsInBlankCommon(const Symbol &symbol) { // 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 @@ const Symbol *FindSeparateModuleSubprogramInterface(const Symbol *proc) { 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 index b220325..28a0d29 100644 --- a/flang/test/Semantics/call03.f90 +++ b/flang/test/Semantics/call03.f90 @@ -29,7 +29,7 @@ module m01 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 @@ module m01 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 index c317d30..86da81d 100644 --- a/flang/test/Semantics/call05.f90 +++ b/flang/test/Semantics/call05.f90 @@ -89,9 +89,9 @@ module m 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 index 0000000..3f59150 --- /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 index 2949ab6..ef10f1f 100644 --- a/flang/test/Semantics/modfile10.f90 +++ b/flang/test/Semantics/modfile10.f90 @@ -64,8 +64,8 @@ end module ! 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 index d06eede..326ae1f 100644 --- a/flang/test/Semantics/resolve32.f90 +++ b/flang/test/Semantics/resolve32.f90 @@ -57,7 +57,7 @@ module m 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 index 9e61265..48af4ab 100644 --- a/flang/test/Semantics/resolve55.f90 +++ b/flang/test/Semantics/resolve55.f90 @@ -36,25 +36,24 @@ subroutine s4(arg) 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 -- 2.7.4