[flang-commits] [flang] [flang] Improve USE merging of homonymous types, interfaces, and proc… (PR #79364)
Peter Klausler via flang-commits
flang-commits at lists.llvm.org
Wed Jan 24 12:37:30 PST 2024
https://github.com/klausler created https://github.com/llvm/llvm-project/pull/79364
…edures
Fortran allows a generic interface to have the same name as a derived type in the same scope. It also allows a generic interface to have the same name as one of its specific procedures.
When two modules define the same name, possibly more than once each, things get exciting. The standard is not clear, and other compilers do variously different things. We are currently emitting some errors prematurely for some usage in pfUnit due to how it combines two versions of a package together via USE association.
This patch handles combinations of derived types and generic interfaces and their specific procedures in a more principled way. Errors due to ambiguity are deferred to actual usage of derived types and specific procedures -- and when they're not used, the program is unambiguous and no error issues.
>From 904c2bff277fef7b15e243e3218163af4a3b14b9 Mon Sep 17 00:00:00 2001
From: Peter Klausler <pklausler at nvidia.com>
Date: Tue, 23 Jan 2024 14:24:45 -0800
Subject: [PATCH] [flang] Improve USE merging of homonymous types, interfaces,
and procedures
Fortran allows a generic interface to have the same name as a derived
type in the same scope. It also allows a generic interface to have
the same name as one of its specific procedures.
When two modules define the same name, possibly more than once each,
things get exciting. The standard is not clear, and other compilers do
variously different things. We are currently emitting some errors
prematurely for some usage in pfUnit due to how it combines two versions
of a package together via USE association.
This patch handles combinations of derived types and generic interfaces
and their specific procedures in a more principled way. Errors
due to ambiguity are deferred to actual usage of derived types
and specific procedures -- and when they're not used, the program
is unambiguous and no error issues.
---
flang/include/flang/Semantics/symbol.h | 4 +-
flang/include/flang/Semantics/tools.h | 3 +
flang/lib/Semantics/expression.cpp | 3 +
flang/lib/Semantics/resolve-names.cpp | 373 +++++++++++++++----------
flang/lib/Semantics/symbol.cpp | 4 +-
flang/lib/Semantics/tools.cpp | 17 ++
flang/test/Semantics/resolve17.f90 | 37 +--
flang/test/Semantics/resolve18.f90 | 108 ++++++-
flang/test/Semantics/symbol27.f90 | 4 +-
9 files changed, 356 insertions(+), 197 deletions(-)
diff --git a/flang/include/flang/Semantics/symbol.h b/flang/include/flang/Semantics/symbol.h
index 5163d66bed18064..4535a92ce3dd8e4 100644
--- a/flang/include/flang/Semantics/symbol.h
+++ b/flang/include/flang/Semantics/symbol.h
@@ -637,7 +637,9 @@ class GenericDetails {
const SymbolVector &uses() const { return uses_; }
// specific and derivedType indicate a specific procedure or derived type
- // with the same name as this generic. Only one of them may be set.
+ // with the same name as this generic. Only one of them may be set in
+ // a scope that declares them, but both can be set during USE association
+ // when generics are combined.
Symbol *specific() { return specific_; }
const Symbol *specific() const { return specific_; }
void set_specific(Symbol &specific);
diff --git a/flang/include/flang/Semantics/tools.h b/flang/include/flang/Semantics/tools.h
index 38ae3e30a68fb17..df66e1adb550233 100644
--- a/flang/include/flang/Semantics/tools.h
+++ b/flang/include/flang/Semantics/tools.h
@@ -692,5 +692,8 @@ std::string GetModuleOrSubmoduleName(const Symbol &);
// Return the assembly name emitted for a common block.
std::string GetCommonBlockObjectName(const Symbol &, bool underscoring);
+// Check for ambiguous USE associations
+bool HadUseError(SemanticsContext &, SourceName at, const Symbol *);
+
} // namespace Fortran::semantics
#endif // FORTRAN_SEMANTICS_TOOLS_H_
diff --git a/flang/lib/Semantics/expression.cpp b/flang/lib/Semantics/expression.cpp
index bfc380183e23f55..f7e8d8582d5cebc 100644
--- a/flang/lib/Semantics/expression.cpp
+++ b/flang/lib/Semantics/expression.cpp
@@ -235,6 +235,9 @@ MaybeExpr ExpressionAnalyzer::Designate(DataRef &&ref) {
return std::nullopt;
} else if (MaybeExpr result{AsGenericExpr(std::move(ref))}) {
return result;
+ } else if (semantics::HadUseError(
+ context_, GetContextualMessages().at(), &symbol)) {
+ return std::nullopt;
} else {
if (!context_.HasError(last) && !context_.HasError(symbol)) {
AttachDeclaration(
diff --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp
index e4a841ec28486c4..5320937fa89c12a 100644
--- a/flang/lib/Semantics/resolve-names.cpp
+++ b/flang/lib/Semantics/resolve-names.cpp
@@ -2991,205 +2991,293 @@ void ModuleVisitor::EraseRenamedUse(const Symbol *useSymbol) {
}
void ModuleVisitor::DoAddUse(SourceName location, SourceName localName,
- Symbol &localSymbol, const Symbol &useSymbol) {
+ Symbol &originalLocal, const Symbol &useSymbol) {
if (localName != useSymbol.name()) {
EraseRenamedUse(&useSymbol);
}
- if (auto *details{localSymbol.detailsIf<UseErrorDetails>()}) {
+ Symbol *localSymbol{&originalLocal};
+ if (auto *details{localSymbol->detailsIf<UseErrorDetails>()}) {
details->add_occurrence(location, *useModuleScope_);
return;
}
const Symbol &useUltimate{useSymbol.GetUltimate()};
- if (localSymbol.has<UnknownDetails>()) {
- localSymbol.set_details(UseDetails{localName, useSymbol});
- localSymbol.attrs() =
+ if (localSymbol->has<UnknownDetails>()) {
+ localSymbol->set_details(UseDetails{localName, useSymbol});
+ localSymbol->attrs() =
useSymbol.attrs() & ~Attrs{Attr::PUBLIC, Attr::PRIVATE, Attr::SAVE};
- localSymbol.implicitAttrs() =
- localSymbol.attrs() & Attrs{Attr::ASYNCHRONOUS, Attr::VOLATILE};
- localSymbol.flags() = useSymbol.flags();
+ localSymbol->implicitAttrs() =
+ localSymbol->attrs() & Attrs{Attr::ASYNCHRONOUS, Attr::VOLATILE};
+ localSymbol->flags() = useSymbol.flags();
return;
}
- Symbol &localUltimate{localSymbol.GetUltimate()};
+ Symbol &localUltimate{localSymbol->GetUltimate()};
if (&localUltimate == &useUltimate) {
// use-associating the same symbol again -- ok
return;
}
- auto checkAmbiguousDerivedType{[this, location, localName](
- const Symbol *t1, const Symbol *t2) {
- if (t1 && t2) {
- t1 = &t1->GetUltimate();
- t2 = &t2->GetUltimate();
- if (&t1 != &t2) {
- Say(location,
- "Generic interface '%s' has ambiguous derived types from modules '%s' and '%s'"_err_en_US,
- localName, t1->owner().GetName().value(),
- t2->owner().GetName().value());
+ // There are many possible combinations of symbol types that could arrive
+ // with the same (local) name vie USE association from distinct modules.
+ // Fortran allows a generic interface to share its name with a derived type,
+ // or with the name of a non-generic procedure (which should be one of the
+ // generic's specific procedures). Implementing all these possibilities is
+ // complicated.
+ // Error cases are converted into UseErrorDetails symbols to trigger error
+ // messages when/if bad combinations are actually used later in the program.
+ // The error cases are:
+ // - two distinct derived types
+ // - two distinct non-generic procedures
+ // - a generic and a non-generic that is not already one of its specifics
+ // - anything other than a derived type, non-generic procedure, or
+ // generic procedure being combined with something other than an
+ // prior USE association of itself
+
+ auto *localGeneric{localUltimate.detailsIf<GenericDetails>()};
+ const auto *useGeneric{useUltimate.detailsIf<GenericDetails>()};
+
+ Symbol *localDerivedType{nullptr};
+ if (localUltimate.has<DerivedTypeDetails>()) {
+ localDerivedType = &localUltimate;
+ } else if (localGeneric) {
+ if (auto *dt{localGeneric->derivedType()};
+ dt && !dt->attrs().test(Attr::PRIVATE)) {
+ localDerivedType = dt;
+ }
+ }
+ const Symbol *useDerivedType{nullptr};
+ if (useUltimate.has<DerivedTypeDetails>()) {
+ useDerivedType = &useUltimate;
+ } else if (useGeneric) {
+ if (const auto *dt{useGeneric->derivedType()};
+ dt && !dt->attrs().test(Attr::PRIVATE)) {
+ useDerivedType = dt;
+ }
+ }
+
+ Symbol *localProcedure{nullptr};
+ if (localGeneric) {
+ if (localGeneric->specific() &&
+ !localGeneric->specific()->attrs().test(Attr::PRIVATE)) {
+ localProcedure = localGeneric->specific();
+ }
+ } else if (IsProcedure(localUltimate)) {
+ localProcedure = &localUltimate;
+ }
+ const Symbol *useProcedure{nullptr};
+ if (useGeneric) {
+ if (useGeneric->specific() &&
+ !useGeneric->specific()->attrs().test(Attr::PRIVATE)) {
+ useProcedure = useGeneric->specific();
+ }
+ } else if (IsProcedure(useUltimate)) {
+ useProcedure = &useUltimate;
+ }
+
+ // Creates a UseErrorDetails symbol in the current scope for a
+ // current UseDetails symbol, but leaves the UseDetails in the
+ // scope's name map.
+ auto CreateLocalUseError{[&]() {
+ EraseSymbol(*localSymbol);
+ UseErrorDetails details{localSymbol->get<UseDetails>()};
+ details.add_occurrence(location, *useModuleScope_);
+ Symbol *newSymbol{&MakeSymbol(localName, Attrs{}, std::move(details))};
+ // Restore *localSymbol in currScope
+ auto iter{currScope().find(localName)};
+ CHECK(iter != currScope().end() && &*iter->second == newSymbol);
+ iter->second = MutableSymbolRef{*localSymbol};
+ return newSymbol;
+ }};
+
+ // When two derived types arrived, try to combine them.
+ const Symbol *combinedDerivedType{nullptr};
+ if (!useDerivedType) {
+ combinedDerivedType = localDerivedType;
+ } else if (!localDerivedType) {
+ combinedDerivedType = useDerivedType;
+ } else {
+ const Scope *localScope{localDerivedType->scope()};
+ const Scope *useScope{useDerivedType->scope()};
+ if (localScope && useScope && localScope->derivedTypeSpec() &&
+ useScope->derivedTypeSpec() &&
+ evaluate::AreSameDerivedType(
+ *localScope->derivedTypeSpec(), *useScope->derivedTypeSpec())) {
+ combinedDerivedType = localDerivedType;
+ } else {
+ // Create a local UseErrorDetails for the ambiguous derived type
+ if (localGeneric) {
+ combinedDerivedType = CreateLocalUseError();
+ } else {
+ ConvertToUseError(*localSymbol, location, *useModuleScope_);
+ combinedDerivedType = localSymbol;
+ }
+ }
+ if (!localGeneric && !useGeneric) {
+ return; // both symbols are derived types; done
+ }
+ }
+
+ auto AreSameProcedure{[&](const Symbol &p1, const Symbol &p2) {
+ if (&p1 == &p2) {
+ return true;
+ } else if (p1.name() != p2.name()) {
+ return false;
+ } else if (p1.attrs().test(Attr::INTRINSIC) ||
+ p2.attrs().test(Attr::INTRINSIC)) {
+ return p1.attrs().test(Attr::INTRINSIC) &&
+ p2.attrs().test(Attr::INTRINSIC);
+ } else if (!IsProcedure(p1) || !IsProcedure(p2)) {
+ return false;
+ } else if (IsPointer(p1) || IsPointer(p2)) {
+ return false;
+ } else if (const auto *subp{p1.detailsIf<SubprogramDetails>()};
+ subp && !subp->isInterface()) {
+ return false; // defined in module, not an external
+ } else if (const auto *subp{p2.detailsIf<SubprogramDetails>()};
+ subp && !subp->isInterface()) {
+ return false; // defined in module, not an external
+ } else {
+ // Both are external interfaces, perhaps to the same procedure
+ auto class1{ClassifyProcedure(p1)};
+ auto class2{ClassifyProcedure(p2)};
+ if (class1 == ProcedureDefinitionClass::External &&
+ class2 == ProcedureDefinitionClass::External) {
+ auto chars1{evaluate::characteristics::Procedure::Characterize(
+ p1, GetFoldingContext())};
+ auto chars2{evaluate::characteristics::Procedure::Characterize(
+ p2, GetFoldingContext())};
+ // same procedure interface defined identically in two modules?
+ return chars1 && chars2 && *chars1 == *chars2;
+ } else {
return false;
}
}
- return true;
}};
- auto *localGeneric{localUltimate.detailsIf<GenericDetails>()};
- const auto *useGeneric{useUltimate.detailsIf<GenericDetails>()};
- auto combine{false};
+ // When two non-generic procedures arrived, try to combine them.
+ const Symbol *combinedProcedure{nullptr};
+ if (!localProcedure) {
+ combinedProcedure = useProcedure;
+ } else if (!useProcedure) {
+ combinedProcedure = localProcedure;
+ } else {
+ if (AreSameProcedure(
+ localProcedure->GetUltimate(), useProcedure->GetUltimate())) {
+ if (!localGeneric && !useGeneric) {
+ return; // both symbols are non-generic procedures
+ }
+ combinedProcedure = localProcedure;
+ }
+ }
+
+ // Prepare to merge generics
+ bool cantCombine{false};
if (localGeneric) {
- if (useGeneric) {
- combine = checkAmbiguousDerivedType(
- localGeneric->derivedType(), useGeneric->derivedType());
- } else if (useUltimate.has<DerivedTypeDetails>()) {
- combine =
- checkAmbiguousDerivedType(&useUltimate, localGeneric->derivedType());
+ if (useGeneric || useDerivedType) {
} else if (&useUltimate == &BypassGeneric(localUltimate).GetUltimate()) {
return; // nothing to do; used subprogram is local's specific
} else if (useUltimate.attrs().test(Attr::INTRINSIC) &&
- useUltimate.name() == localSymbol.name()) {
+ useUltimate.name() == localSymbol->name()) {
return; // local generic can extend intrinsic
+ } else {
+ for (const auto &ref : localGeneric->specificProcs()) {
+ if (&ref->GetUltimate() == &useUltimate) {
+ return; // used non-generic is already a specific of local generic
+ }
+ }
+ cantCombine = true;
}
} else if (useGeneric) {
- if (localUltimate.has<DerivedTypeDetails>()) {
- combine =
- checkAmbiguousDerivedType(&localUltimate, useGeneric->derivedType());
+ if (localDerivedType) {
} else if (&localUltimate == &BypassGeneric(useUltimate).GetUltimate() ||
- (localSymbol.attrs().test(Attr::INTRINSIC) &&
+ (localSymbol->attrs().test(Attr::INTRINSIC) &&
localUltimate.name() == useUltimate.name())) {
// Local is the specific of the used generic or an intrinsic with the
// same name; replace it.
- EraseSymbol(localSymbol);
+ EraseSymbol(*localSymbol);
Symbol &newSymbol{MakeSymbol(localName,
useUltimate.attrs() & ~Attrs{Attr::PUBLIC, Attr::PRIVATE},
UseDetails{localName, useUltimate})};
newSymbol.flags() = useSymbol.flags();
return;
- }
- } else if (localUltimate.name() != useUltimate.name()) {
- // not the same procedure
- } else if (localUltimate.attrs().test(Attr::INTRINSIC) &&
- useUltimate.attrs().test(Attr::INTRINSIC)) {
- return;
- } else {
- auto localClass{ClassifyProcedure(localUltimate)};
- auto useClass{ClassifyProcedure(useUltimate)};
- if (localClass == ProcedureDefinitionClass::External &&
- useClass == ProcedureDefinitionClass::External) {
- auto localChars{evaluate::characteristics::Procedure::Characterize(
- localUltimate, GetFoldingContext())};
- auto useChars{evaluate::characteristics::Procedure::Characterize(
- useUltimate, GetFoldingContext())};
- if (localChars && useChars && *localChars == *useChars) {
- return; // same procedure defined identically in two modules
+ } else {
+ for (const auto &ref : useGeneric->specificProcs()) {
+ if (&ref->GetUltimate() == &localUltimate) {
+ return; // local non-generic is already a specific of used generic
+ }
}
+ cantCombine = true;
}
+ } else {
+ cantCombine = true;
}
- if (!combine) {
- if (!ConvertToUseError(localSymbol, location, *useModuleScope_)) {
+
+ // If symbols are not combinable, create a use error.
+ if (cantCombine) {
+ if (!ConvertToUseError(*localSymbol, location, *useModuleScope_)) {
Say(location,
"Cannot use-associate '%s'; it is already declared in this scope"_err_en_US,
localName)
- .Attach(localSymbol.name(), "Previous declaration of '%s'"_en_US,
+ .Attach(localSymbol->name(), "Previous declaration of '%s'"_en_US,
localName);
}
return;
}
- // Two items are being use-associated from different modules
- // to the same local name. At least one of them must be a generic,
- // and the other one can be a generic or a derived type.
- // (It could also have been the specific of the generic, but those
- // cases are handled above without needing to make a local copy of the
- // generic.)
+ // At this point, there must be at least one generic interface.
+ CHECK(localGeneric || (useGeneric && (localDerivedType || localProcedure)));
- std::optional<parser::MessageFixedText> msg;
if (localGeneric) {
- if (localSymbol.has<UseDetails>()) {
- // Create a local copy of a previously use-associated generic so that
- // it can be locally extended without corrupting the original.
+ // Create a local copy of a previously use-associated generic so that
+ // it can be locally extended without corrupting the original.
+ if (localSymbol->has<UseDetails>()) {
GenericDetails generic;
- generic.CopyFrom(*localGeneric);
- if (Symbol * spec{localGeneric->specific()};
- spec && !spec->attrs().test(Attr::PRIVATE)) {
- generic.set_specific(*spec);
- } else if (Symbol * dt{generic.derivedType()};
- dt && dt->attrs().test(Attr::PRIVATE)) {
- generic.clear_derivedType();
- }
- EraseSymbol(localSymbol);
+ generic.CopyFrom(DEREF(localGeneric));
+ EraseSymbol(*localSymbol);
Symbol &newSymbol{MakeSymbol(
- localSymbol.name(), localSymbol.attrs(), std::move(generic))};
- newSymbol.flags() = localSymbol.flags();
+ localSymbol->name(), localSymbol->attrs(), std::move(generic))};
+ newSymbol.flags() = localSymbol->flags();
localGeneric = &newSymbol.get<GenericDetails>();
- localGeneric->AddUse(localSymbol);
+ localGeneric->AddUse(*localSymbol);
+ localSymbol = &newSymbol;
}
if (useGeneric) {
// Combine two use-associated generics
- localSymbol.attrs() =
+ localSymbol->attrs() =
useSymbol.attrs() & ~Attrs{Attr::PUBLIC, Attr::PRIVATE};
- localSymbol.flags() = useSymbol.flags();
+ localSymbol->flags() = useSymbol.flags();
AddGenericUse(*localGeneric, localName, useUltimate);
+ localGeneric->clear_derivedType();
localGeneric->CopyFrom(*useGeneric);
- if (const Symbol * useSpec{useGeneric->specific()};
- useSpec && !useSpec->attrs().test(Attr::PRIVATE)) {
- if (localGeneric->derivedType()) {
- msg =
- "Cannot use-associate generic interface '%s' with specific procedure of the same name when another such interface and derived type are in scope"_err_en_US;
- } else if (!localGeneric->specific()) {
- localGeneric->set_specific(*const_cast<Symbol *>(useSpec));
- } else if (&localGeneric->specific()->GetUltimate() !=
- &useSpec->GetUltimate()) {
- msg =
- "Cannot use-associate generic interface '%s' with specific procedure of the same name when another such interface and procedure are in scope"_err_en_US;
- }
- } else if (const Symbol * useDT{useGeneric->derivedType()};
- useDT && !useDT->attrs().test(Attr::PRIVATE)) {
- if (localGeneric->specific()) {
- msg =
- "Cannot use-associate generic interface '%s' with derived type of the same name when another such interface and procedure are in scope"_err_en_US;
- } else if (!localGeneric->derivedType()) {
- localGeneric->set_derivedType(*const_cast<Symbol *>(useDT));
- } else if (&localGeneric->derivedType()->GetUltimate() !=
- &useDT->GetUltimate()) {
- msg =
- "Cannot use-associate generic interface '%s' with derived type of the same name when another such interface and derived type are in scope"_err_en_US;
- }
- }
- } else {
- CHECK(useUltimate.has<DerivedTypeDetails>());
- if (!localGeneric->derivedType()) {
- localGeneric->set_derivedType(
- AddGenericUse(*localGeneric, localName, useUltimate));
- } else if (&localGeneric->derivedType()->GetUltimate() != &useUltimate) {
- msg =
- "Cannot use-associate derived type '%s' when a generic interface and derived type of the same name are in scope"_err_en_US;
- }
+ }
+ localGeneric->clear_derivedType();
+ if (combinedDerivedType) {
+ localGeneric->set_derivedType(*const_cast<Symbol *>(combinedDerivedType));
+ }
+ localGeneric->clear_specific();
+ if (combinedProcedure) {
+ localGeneric->set_specific(*const_cast<Symbol *>(combinedProcedure));
}
} else {
- CHECK(useGeneric && localUltimate.has<DerivedTypeDetails>());
- CHECK(localSymbol.has<UseDetails>());
+ CHECK(localSymbol->has<UseDetails>());
// Create a local copy of the use-associated generic, then extend it
- // with the local derived type.
- if (!useGeneric->derivedType() ||
- &useGeneric->derivedType()->GetUltimate() == &localUltimate) {
- GenericDetails generic;
- generic.CopyFrom(*useGeneric);
- EraseSymbol(localSymbol);
- Symbol &newSymbol{MakeSymbol(localName,
- useUltimate.attrs() & ~Attrs{Attr::PUBLIC, Attr::PRIVATE},
- std::move(generic))};
- newSymbol.flags() = useUltimate.flags();
- auto &newUseGeneric{newSymbol.get<GenericDetails>()};
- AddGenericUse(newUseGeneric, localName, useUltimate);
- newUseGeneric.AddUse(localSymbol);
- newUseGeneric.set_derivedType(localSymbol);
- } else if (useGeneric->derivedType()) {
- msg =
- "Cannot use-associate generic interface '%s' with derived type of the same name when another such derived type is in scope"_err_en_US;
+ // with the combined derived type &/or non-generic procedure.
+ GenericDetails generic;
+ generic.CopyFrom(*useGeneric);
+ EraseSymbol(*localSymbol);
+ Symbol &newSymbol{MakeSymbol(localName,
+ useUltimate.attrs() & ~Attrs{Attr::PUBLIC, Attr::PRIVATE},
+ std::move(generic))};
+ newSymbol.flags() = useUltimate.flags();
+ auto &newUseGeneric{newSymbol.get<GenericDetails>()};
+ AddGenericUse(newUseGeneric, localName, useUltimate);
+ newUseGeneric.AddUse(*localSymbol);
+ if (combinedDerivedType) {
+ newUseGeneric.set_derivedType(*const_cast<Symbol *>(combinedDerivedType));
+ }
+ if (combinedProcedure) {
+ newUseGeneric.set_specific(*const_cast<Symbol *>(combinedProcedure));
}
- }
- if (msg) {
- Say(location, std::move(*msg), localName)
- .Attach(localSymbol.name(), "Previous USE of '%s'"_en_US, localName);
}
}
@@ -4425,18 +4513,7 @@ void DeclarationVisitor::EndDecl() {
}
bool DeclarationVisitor::CheckUseError(const parser::Name &name) {
- const auto *details{
- name.symbol ? name.symbol->detailsIf<UseErrorDetails>() : nullptr};
- if (!details) {
- return false;
- }
- Message &msg{Say(name, "Reference to '%s' is ambiguous"_err_en_US)};
- for (const auto &[location, module] : details->occurrences()) {
- msg.Attach(location, "'%s' was use-associated from module '%s'"_en_US,
- name.source, module->GetName().value());
- }
- context().SetError(*name.symbol);
- return true;
+ return HadUseError(context(), name.source, name.symbol);
}
// Report error if accessibility of symbol doesn't match isPrivate.
diff --git a/flang/lib/Semantics/symbol.cpp b/flang/lib/Semantics/symbol.cpp
index 6b9f1071f6091ef..2ab3189cf4064e3 100644
--- a/flang/lib/Semantics/symbol.cpp
+++ b/flang/lib/Semantics/symbol.cpp
@@ -192,12 +192,10 @@ void GenericDetails::AddSpecificProc(
}
void GenericDetails::set_specific(Symbol &specific) {
CHECK(!specific_);
- CHECK(!derivedType_);
specific_ = &specific;
}
void GenericDetails::clear_specific() { specific_ = nullptr; }
void GenericDetails::set_derivedType(Symbol &derivedType) {
- CHECK(!specific_);
CHECK(!derivedType_);
derivedType_ = &derivedType;
}
@@ -211,7 +209,7 @@ const Symbol *GenericDetails::CheckSpecific() const {
return const_cast<GenericDetails *>(this)->CheckSpecific();
}
Symbol *GenericDetails::CheckSpecific() {
- if (specific_) {
+ if (specific_ && !specific_->has<UseErrorDetails>()) {
for (const Symbol &proc : specificProcs_) {
if (&proc == specific_) {
return nullptr;
diff --git a/flang/lib/Semantics/tools.cpp b/flang/lib/Semantics/tools.cpp
index 39d6fdc97512aaa..f931ae07072010c 100644
--- a/flang/lib/Semantics/tools.cpp
+++ b/flang/lib/Semantics/tools.cpp
@@ -1685,4 +1685,21 @@ std::string GetCommonBlockObjectName(const Symbol &common, bool underscoring) {
: common.name().ToString();
}
+bool HadUseError(
+ SemanticsContext &context, SourceName at, const Symbol *symbol) {
+ if (const auto *details{
+ symbol ? symbol->detailsIf<UseErrorDetails>() : nullptr}) {
+ auto &msg{context.Say(
+ at, "Reference to '%s' is ambiguous"_err_en_US, symbol->name())};
+ for (const auto &[location, module] : details->occurrences()) {
+ msg.Attach(location, "'%s' was use-associated from module '%s'"_en_US, at,
+ module->GetName().value());
+ }
+ context.SetError(*symbol);
+ return true;
+ } else {
+ return false;
+ }
+}
+
} // namespace Fortran::semantics
diff --git a/flang/test/Semantics/resolve17.f90 b/flang/test/Semantics/resolve17.f90
index b7b58e0f0f3f7b8..a782a6a7ac3eb95 100644
--- a/flang/test/Semantics/resolve17.f90
+++ b/flang/test/Semantics/resolve17.f90
@@ -175,29 +175,14 @@ module m9b
interface g
module procedure g
end interface
-contains
- subroutine g(x)
- real :: x
- end
-end module
-module m9c
- interface g
- module procedure g
- end interface
contains
subroutine g()
end
end module
-subroutine s9a
- use m9a
- !ERROR: Cannot use-associate generic interface 'g' with specific procedure of the same name when another such interface and procedure are in scope
- use m9b
-end
-subroutine s9b
+subroutine s9
!ERROR: USE-associated generic 'g' may not have specific procedures 'g' and 'g' as their interfaces are not distinguishable
use m9a
- !ERROR: Cannot use-associate generic interface 'g' with specific procedure of the same name when another such interface and procedure are in scope
- use m9c
+ use m9b
end
module m10a
@@ -223,24 +208,6 @@ subroutine s(x)
end
end
-module m11a
- interface g
- end interface
- type g
- end type
-end module
-module m11b
- interface g
- end interface
- type g
- end type
-end module
-module m11c
- use m11a
- !ERROR: Generic interface 'g' has ambiguous derived types from modules 'm11a' and 'm11b'
- use m11b
-end module
-
module m12a
interface ga
module procedure sa
diff --git a/flang/test/Semantics/resolve18.f90 b/flang/test/Semantics/resolve18.f90
index ab9813bcce10b48..467fceb58657e3f 100644
--- a/flang/test/Semantics/resolve18.f90
+++ b/flang/test/Semantics/resolve18.f90
@@ -229,10 +229,10 @@ function foo(x)
subroutine test15
use m15a
- !ERROR: Cannot use-associate generic interface 'foo' with specific procedure of the same name when another such interface and procedure are in scope
- use m15b
+ use m15b ! ok
end
+
module m16a
type foo
integer j
@@ -259,18 +259,110 @@ function bar(x,y)
subroutine test16
use m16a
- !ERROR: Generic interface 'foo' has ambiguous derived types from modules 'm16a' and 'm16b'
- use m16b
+ use m16b ! ok
end
subroutine test17
use m15a
- !ERROR: Cannot use-associate generic interface 'foo' with derived type of the same name when another such interface and procedure are in scope
- use m16a
+ use m16a ! ok
end
subroutine test18
use m16a
- !ERROR: Cannot use-associate generic interface 'foo' with specific procedure of the same name when another such interface and derived type are in scope
- use m15a
+ use m15a ! ok
+end
+
+module m21
+ type foo
+ integer a
+ end type
+ interface foo
+ module procedure f1
+ end interface
+ contains
+ function f1(a)
+ f1 = a
+ end
+end
+
+module m22
+ type foo
+ real b
+ end type
+ interface foo
+ module procedure f2
+ end interface
+ contains
+ function f2(a,b)
+ f2 = a + b
+ end
+end
+
+module m23
+ interface foo
+ module procedure foo
+ module procedure f3
+ end interface
+ contains
+ function foo()
+ foo = 0.
+ end
+ function f3(a,b,c)
+ f3 = a + b + c
+ end
+end
+
+module m24
+ interface foo
+ module procedure foo
+ module procedure f4
+ end interface
+ contains
+ function foo(a)
+ foo = a
+ end
+ function f4(a,b,c,d)
+ f4 = a + b + c +d
+ end
+end
+
+subroutine s_21_22_a
+ use m21
+ use m22
+ print *, foo(1.) ! Intel error
+ print *, foo(1.,2.) ! Intel error
+end
+
+subroutine s_21_22_b
+ use m21
+ use m22
+ !ERROR: 'foo' is not a derived type
+ type(foo) x ! definite error: GNU and Intel catch
+end
+
+subroutine s_21_23
+ use m21
+ use m23
+ type(foo) x ! Intel and NAG error
+ print *, foo(1.) ! Intel error
+ print *, foo(1.,2.,3.) ! Intel error
+ call ext(foo) ! GNU and Intel error
+end
+
+subroutine s_22_23
+ use m22
+ use m23
+ type(foo) x ! Intel and NAG error
+ print *, foo(1.,2.) ! Intel error
+ print *, foo(1.,2.,3.) ! Intel error
+ call ext(foo) ! Intel error
+end
+
+subroutine s_23_24
+ use m23
+ use m24
+ print *, foo(1.,2.,3.) ! NAG error
+ print *, foo(1.,2.,3.,4.) ! XLF error
+ !ERROR: 'foo' is not a specific procedure
+ call ext(foo) ! definite error
end
diff --git a/flang/test/Semantics/symbol27.f90 b/flang/test/Semantics/symbol27.f90
index 8ac8f73dc70b09e..3b479e8d207fe43 100644
--- a/flang/test/Semantics/symbol27.f90
+++ b/flang/test/Semantics/symbol27.f90
@@ -28,7 +28,7 @@ subroutine test1a
!DEF: /test1a/foo (Function) Generic
!DEF: /test1a/x ObjectEntity TYPE(foo)
type(foo) :: x
- !DEF: /test1a/foo Use
+ !REF: /m1a/foo
!REF: /m1b/bar
print *, foo(1), foo()
end subroutine
@@ -41,7 +41,7 @@ subroutine test1b
!DEF: /test1b/foo (Function) Generic
!DEF: /test1b/x ObjectEntity TYPE(foo)
type(foo) :: x
- !DEF: /test1b/foo Use
+ !REF: /m1a/foo
!REF: /m1b/bar
print *, foo(1), foo()
end subroutine
More information about the flang-commits
mailing list