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 &);
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
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); }
// 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<<(
std::size_t alignment_{0}; // required alignment in bytes
};
-class FinalProcDetails {}; // TODO
-
class MiscDetails {
public:
ENUM_CLASS(Kind, None, ConstructName, ScopeName, PassName, ComplexPartRe,
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 &);
}
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 &);
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
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,
[](const GenericDetails &) { return true; },
[](const ProcBindingDetails &) { return true; },
[](const UseDetails &x) { return IsProcedure(x.symbol()); },
- // TODO: FinalProcDetails?
[](const auto &) { return false; },
},
symbol.details());
}
}
-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 =
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,
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()) {
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_;
}
}
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(
"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) {
"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{
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(
}
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) {
}
}
}
- DerivedTypeSpec derived{symbol.name(), symbol};
+ DerivedTypeSpec derived{derivedType.name(), derivedType};
derived.set_scope(*scope);
if (FindCoarrayUltimateComponent(derived) && // C736
!(parentDerived && FindCoarrayUltimateComponent(*parentDerived))) {
"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) ||
"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(
}
// 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
if (auto str{typeBindings.str()}; !str.empty()) {
CHECK(scope.IsDerivedType());
decls_ << "contains\n" << str;
+ return true;
+ } else {
+ return false;
}
}
decls_ << "::/" << symbol.name() << "/\n";
}
},
- [&](const FinalProcDetails &) {
- typeBindings << "final::" << symbol.name() << '\n';
- },
[](const HostAssocDetails &) {},
[](const MiscDetails &) {},
[&](const auto &) { PutEntity(decls_, symbol); },
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";
}
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 &);
" 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()};
}
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);
+ }
+ }
+ }
+ }
}
}
[](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"; },
os << ' ' << object->name();
}
},
- [&](const FinalProcDetails &) {},
[&](const TypeParamDetails &x) {
DumpOptional(os, "type", x.type());
os << ' ' << common::EnumToString(x.attr());
}
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; }
// 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)}) {
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>
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)
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
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)
--- /dev/null
+! 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
! type::t2
! integer(4)::x
! contains
-! final::c
! procedure,non_overridable,private::d
+! final::c
! end type
! type,abstract::t2a
! contains
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
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
projects / platform / upstream / llvm.git / commitdiff