[flang-commits] [flang] 37b2e2b - [flang] Semantic analysis for FINAL subroutines
peter klausler via flang-commits
flang-commits at lists.llvm.org
Wed Sep 30 15:46:52 PDT 2020
Author: peter klausler
Date: 2020-09-30T15:46:15-07:00
New Revision: 37b2e2b04cf434b368b1edf29609be21952316f9
URL: https://github.com/llvm/llvm-project/commit/37b2e2b04cf434b368b1edf29609be21952316f9
DIFF: https://github.com/llvm/llvm-project/commit/37b2e2b04cf434b368b1edf29609be21952316f9.diff
LOG: [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
Added:
flang/test/Semantics/final01.f90
Modified:
flang/include/flang/Evaluate/characteristics.h
flang/include/flang/Evaluate/type.h
flang/include/flang/Semantics/symbol.h
flang/include/flang/Semantics/tools.h
flang/lib/Evaluate/characteristics.cpp
flang/lib/Evaluate/tools.cpp
flang/lib/Evaluate/type.cpp
flang/lib/Semantics/check-call.cpp
flang/lib/Semantics/check-declarations.cpp
flang/lib/Semantics/mod-file.cpp
flang/lib/Semantics/mod-file.h
flang/lib/Semantics/pointer-assignment.cpp
flang/lib/Semantics/resolve-names.cpp
flang/lib/Semantics/symbol.cpp
flang/lib/Semantics/tools.cpp
flang/test/Semantics/call03.f90
flang/test/Semantics/call05.f90
flang/test/Semantics/modfile10.f90
flang/test/Semantics/resolve32.f90
flang/test/Semantics/resolve55.f90
Removed:
################################################################################
diff --git a/flang/include/flang/Evaluate/characteristics.h b/flang/include/flang/Evaluate/characteristics.h
index fe7cc2dac0ca5..bde734cd510dc 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 663ece6eb4a09..183cb6de2781b 100644
--- a/flang/include/flang/Evaluate/type.h
+++ b/flang/include/flang/Evaluate/type.h
@@ -166,11 +166,9 @@ class DynamicType {
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 5f861d10332ed..ca6ab22c14ca2 100644
--- a/flang/include/flang/Semantics/symbol.h
+++ b/flang/include/flang/Semantics/symbol.h
@@ -248,6 +248,8 @@ class DerivedTypeDetails {
const std::list<SourceName> ¶mNames() const { return paramNames_; }
const SymbolVector ¶mDecls() const { return paramDecls_; }
bool sequence() const { return sequence_; }
+ std::map<SourceName, SymbolRef> &finals() { return finals_; }
+ const std::map<SourceName, SymbolRef> &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 @@ class DerivedTypeDetails {
// 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<SourceName> componentNames_;
+ std::map<SourceName, SymbolRef> finals_; // FINAL :: subr
bool sequence_{false};
bool isForwardReferenced_{false};
friend llvm::raw_ostream &operator<<(
@@ -322,8 +325,6 @@ class CommonBlockDetails {
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<UnknownDetails, MainProgramDetails, ModuleDetails,
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
index 58ba7bf700175..6e1e06b3ec761 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<parser::MessageFixedText> WhyNotModifiable(
const Symbol &, const Scope &);
@@ -283,6 +284,20 @@ template <typename T> 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 de013367f6aa1..a28f4dd004cc1 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 567a3768b103f..b560cce1192d4 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 e96e19150f4ee..e370f2b05b954 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<semantics::ObjectEntityDetails>()}) {
- if (const auto *yObject{y.detailsIf<semantics::ObjectEntityDetails>()}) {
-#else
- if (x.has<semantics::ObjectEntityDetails>()) {
- if (y.has<semantics::ObjectEntityDetails>()) {
-#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<semantics::ObjectEntityDetails>() ==
+ y.has<semantics::ObjectEntityDetails>();
}
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 8c3810cd9daa8..7e1d57cf579e5 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<FinalProcDetails>();
- })}) { // 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<DerivedTypeDetails>().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 896af3cc83e08..dee26ab592270 100644
--- a/flang/lib/Semantics/check-declarations.cpp
+++ b/flang/lib/Semantics/check-declarations.cpp
@@ -66,6 +66,10 @@ class CheckHelper {
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<SourceName, SymbolRef> 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<SourceName, SymbolRef> 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<SubprogramDetails>()}) {
+ if (!details->dummyArgs().empty()) {
+ if (const Symbol * argSym{details->dummyArgs()[0]}) {
+ errSym = argSym;
+ }
+ }
+ }
+ const auto *ddo{std::get_if<DummyDataObject>(&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<TypeParamDetails>()}) {
+ 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 ef62a94b1b89e..f714a3b1f9bfd 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 17ffe804c5be3..08bf2e864ffa1 100644
--- a/flang/lib/Semantics/mod-file.h
+++ b/flang/lib/Semantics/mod-file.h
@@ -53,7 +53,8 @@ class ModFileWriter {
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 58719deae366c..735e842411b1c 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<T> &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 b501ac69098f9..0bdf871cd4851 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<DerivedTypeDetails>()}) {
+ 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 1e046e013c8f1..06c4ac4275a08 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 848aef08e3a1f..8bcbdc70ec117 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<FinalProcDetails>(); }) !=
- components.end();
+ if (!derived.typeSymbol().get<DerivedTypeDetails>().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<FinalProcDetails>() && !x.attrs().test(Attr::PURE);
- }) != components.end();
+ 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 !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<SubprogramDetails>() && 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<ProcEntityDetails>()}) {
+ 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<SubprogramDetails>()}) {
+ 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 <ComponentKind componentKind>
diff --git a/flang/test/Semantics/call03.f90 b/flang/test/Semantics/call03.f90
index b220325812541..28a0d29ca5058 100644
--- a/flang/test/Semantics/call03.f90
+++ b/flang/test/Semantics/call03.f90
@@ -29,7 +29,7 @@ subroutine subr01(this)
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 test04 ! 15.5.2.4(2)
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 c317d30116074..86da81d5e8f1c 100644
--- a/flang/test/Semantics/call05.f90
+++ b/flang/test/Semantics/call05.f90
@@ -89,9 +89,9 @@ subroutine test
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 0000000000000..3f5915093dad7
--- /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 2949ab6965dc8..ef10f1f23e8e2 100644
--- a/flang/test/Semantics/modfile10.f90
+++ b/flang/test/Semantics/modfile10.f90
@@ -64,8 +64,8 @@ subroutine test
! 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 d06eede6ced5a..326ae1f909cf0 100644
--- a/flang/test/Semantics/resolve32.f90
+++ b/flang/test/Semantics/resolve32.f90
@@ -57,7 +57,7 @@ subroutine foo
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 9e61265430043..48af4abcf28ba 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
More information about the flang-commits
mailing list