[flang-commits] [flang] [flang] Acknowledge non-enforcement of C7108 (PR #139169)
Peter Klausler via flang-commits
flang-commits at lists.llvm.org
Sat May 10 13:18:47 PDT 2025
https://github.com/klausler updated https://github.com/llvm/llvm-project/pull/139169
>From e761cf3e39d17ab1e8ff025534eac4a0119a9b8b Mon Sep 17 00:00:00 2001
From: Peter Klausler <pklausler at nvidia.com>
Date: Thu, 8 May 2025 15:02:01 -0700
Subject: [PATCH] [flang] Acknowledge non-enforcement of C7108
Fortran 2023 constraint C7108 prohibits the use of a structure
constructor in a way that is ambiguous with a generic function
reference (intrinsic or user-defined). Sadly, no Fortran
compiler implements this constraint, and the common portable
interpretation seems to be the generic resolution, not the
structure constructor.
Restructure the processing of structure constructors in expression
analysis so that it can be driven both from the parse tree as well
as from generic resolution, and then use it to detect ambigous
structure constructor / generic function cases, so that a portability
warning can be issued. And document this as a new intentional
violation of the standard in Extensions.md.
Fixes https://github.com/llvm/llvm-project/issues/138807.
---
flang/docs/Extensions.md | 5 +
flang/include/flang/Semantics/expression.h | 13 +
.../include/flang/Support/Fortran-features.h | 2 +-
flang/lib/Semantics/expression.cpp | 452 +++++++++++-------
flang/lib/Support/Fortran-features.cpp | 1 +
flang/test/Semantics/c7108.f90 | 41 ++
flang/test/Semantics/generic09.f90 | 4 +
flang/test/Semantics/resolve11.f90 | 3 +-
flang/test/Semantics/resolve17.f90 | 2 +
flang/test/Semantics/resolve18.f90 | 1 +
10 files changed, 338 insertions(+), 186 deletions(-)
create mode 100644 flang/test/Semantics/c7108.f90
diff --git a/flang/docs/Extensions.md b/flang/docs/Extensions.md
index 5c7751763eab1..00a7e2bac84e6 100644
--- a/flang/docs/Extensions.md
+++ b/flang/docs/Extensions.md
@@ -159,6 +159,11 @@ end
to be constant will generate a compilation error. `ieee_support_standard`
depends in part on `ieee_support_halting`, so this also applies to
`ieee_support_standard` calls.
+* F'2023 constraint C7108 prohibits the use of a structure constructor
+ that could also be interpreted as a generic function reference.
+ No other Fortran compiler enforces C7108 (to our knowledge);
+ they all resolve the ambiguity by interpreting the call as a function
+ reference. We do the same, with a portability warning.
## Extensions, deletions, and legacy features supported by default
diff --git a/flang/include/flang/Semantics/expression.h b/flang/include/flang/Semantics/expression.h
index eee23dba4831f..30f5dfd8a44cd 100644
--- a/flang/include/flang/Semantics/expression.h
+++ b/flang/include/flang/Semantics/expression.h
@@ -394,6 +394,19 @@ class ExpressionAnalyzer {
MaybeExpr AnalyzeComplex(MaybeExpr &&re, MaybeExpr &&im, const char *what);
std::optional<Chevrons> AnalyzeChevrons(const parser::CallStmt &);
+ // CheckStructureConstructor() is used for parsed structure constructors
+ // as well as for generic function references.
+ struct ComponentSpec {
+ ComponentSpec() = default;
+ ComponentSpec(ComponentSpec &&) = default;
+ parser::CharBlock source, exprSource;
+ bool hasKeyword{false};
+ const Symbol *keywordSymbol{nullptr};
+ MaybeExpr expr;
+ };
+ MaybeExpr CheckStructureConstructor(parser::CharBlock typeName,
+ const semantics::DerivedTypeSpec &, std::list<ComponentSpec> &&);
+
MaybeExpr IterativelyAnalyzeSubexpressions(const parser::Expr &);
semantics::SemanticsContext &context_;
diff --git a/flang/include/flang/Support/Fortran-features.h b/flang/include/flang/Support/Fortran-features.h
index 6cb1bcdb0003f..aa3396c46963c 100644
--- a/flang/include/flang/Support/Fortran-features.h
+++ b/flang/include/flang/Support/Fortran-features.h
@@ -54,7 +54,7 @@ ENUM_CLASS(LanguageFeature, BackslashEscapes, OldDebugLines,
PolymorphicActualAllocatableOrPointerToMonomorphicDummy, RelaxedPureDummy,
UndefinableAsynchronousOrVolatileActual, AutomaticInMainProgram, PrintCptr,
SavedLocalInSpecExpr, PrintNamelist, AssumedRankPassedToNonAssumedRank,
- IgnoreIrrelevantAttributes, Unsigned)
+ IgnoreIrrelevantAttributes, Unsigned, AmbiguousStructureConstructor)
// Portability and suspicious usage warnings
ENUM_CLASS(UsageWarning, Portability, PointerToUndefinable,
diff --git a/flang/lib/Semantics/expression.cpp b/flang/lib/Semantics/expression.cpp
index e139bda7e4950..8b80f907953c8 100644
--- a/flang/lib/Semantics/expression.cpp
+++ b/flang/lib/Semantics/expression.cpp
@@ -2063,23 +2063,9 @@ static MaybeExpr ImplicitConvertTo(const semantics::Symbol &sym,
return std::nullopt;
}
-MaybeExpr ExpressionAnalyzer::Analyze(
- const parser::StructureConstructor &structure) {
- auto &parsedType{std::get<parser::DerivedTypeSpec>(structure.t)};
- parser::Name structureType{std::get<parser::Name>(parsedType.t)};
- parser::CharBlock &typeName{structureType.source};
- if (semantics::Symbol *typeSymbol{structureType.symbol}) {
- if (typeSymbol->has<semantics::DerivedTypeDetails>()) {
- semantics::DerivedTypeSpec dtSpec{typeName, typeSymbol->GetUltimate()};
- if (!CheckIsValidForwardReference(dtSpec)) {
- return std::nullopt;
- }
- }
- }
- if (!parsedType.derivedTypeSpec) {
- return std::nullopt;
- }
- const auto &spec{*parsedType.derivedTypeSpec};
+MaybeExpr ExpressionAnalyzer::CheckStructureConstructor(
+ parser::CharBlock typeName, const semantics::DerivedTypeSpec &spec,
+ std::list<ComponentSpec> &&componentSpecs) {
const Symbol &typeSymbol{spec.typeSymbol()};
if (!spec.scope() || !typeSymbol.has<semantics::DerivedTypeDetails>()) {
return std::nullopt; // error recovery
@@ -2090,10 +2076,10 @@ MaybeExpr ExpressionAnalyzer::Analyze(
const Symbol *parentComponent{typeDetails.GetParentComponent(*spec.scope())};
if (typeSymbol.attrs().test(semantics::Attr::ABSTRACT)) { // C796
- AttachDeclaration(Say(typeName,
- "ABSTRACT derived type '%s' may not be used in a "
- "structure constructor"_err_en_US,
- typeName),
+ AttachDeclaration(
+ Say(typeName,
+ "ABSTRACT derived type '%s' may not be used in a structure constructor"_err_en_US,
+ typeName),
typeSymbol); // C7114
}
@@ -2123,22 +2109,19 @@ MaybeExpr ExpressionAnalyzer::Analyze(
bool checkConflicts{true}; // until we hit one
auto &messages{GetContextualMessages()};
- // NULL() can be a valid component
- auto restorer{AllowNullPointer()};
-
- for (const auto &component :
- std::get<std::list<parser::ComponentSpec>>(structure.t)) {
- const parser::Expr &expr{
- std::get<parser::ComponentDataSource>(component.t).v.value()};
- parser::CharBlock source{expr.source};
+ for (ComponentSpec &componentSpec : componentSpecs) {
+ parser::CharBlock source{componentSpec.source};
+ parser::CharBlock exprSource{componentSpec.exprSource};
auto restorer{messages.SetLocation(source)};
- const Symbol *symbol{nullptr};
- MaybeExpr value{Analyze(expr)};
+ const Symbol *symbol{componentSpec.keywordSymbol};
+ MaybeExpr &maybeValue{componentSpec.expr};
+ if (!maybeValue.has_value()) {
+ return std::nullopt;
+ }
+ Expr<SomeType> &value{*maybeValue};
std::optional<DynamicType> valueType{DynamicType::From(value)};
- if (const auto &kw{std::get<std::optional<parser::Keyword>>(component.t)}) {
+ if (componentSpec.hasKeyword) {
anyKeyword = true;
- source = kw->v.source;
- symbol = kw->v.symbol;
if (!symbol) {
// Skip overridden inaccessible parent components in favor of
// their later overrides.
@@ -2190,9 +2173,9 @@ MaybeExpr ExpressionAnalyzer::Analyze(
}
}
if (symbol) {
- const semantics::Scope &innermost{context_.FindScope(expr.source)};
+ const semantics::Scope &innermost{context_.FindScope(exprSource)};
if (auto msg{CheckAccessibleSymbol(innermost, *symbol)}) {
- Say(expr.source, std::move(*msg));
+ Say(exprSource, std::move(*msg));
}
if (checkConflicts) {
auto componentIter{
@@ -2200,8 +2183,7 @@ MaybeExpr ExpressionAnalyzer::Analyze(
if (unavailable.find(symbol->name()) != unavailable.cend()) {
// C797, C798
Say(source,
- "Component '%s' conflicts with another component earlier in "
- "this structure constructor"_err_en_US,
+ "Component '%s' conflicts with another component earlier in this structure constructor"_err_en_US,
symbol->name());
} else if (symbol->test(Symbol::Flag::ParentComp)) {
// Make earlier components unavailable once a whole parent appears.
@@ -2219,143 +2201,136 @@ MaybeExpr ExpressionAnalyzer::Analyze(
}
}
unavailable.insert(symbol->name());
- if (value) {
- if (symbol->has<semantics::TypeParamDetails>()) {
- Say(expr.source,
- "Type parameter '%s' may not appear as a component of a structure constructor"_err_en_US,
- symbol->name());
- }
- if (!(symbol->has<semantics::ProcEntityDetails>() ||
- symbol->has<semantics::ObjectEntityDetails>())) {
- continue; // recovery
- }
- if (IsPointer(*symbol)) { // C7104, C7105, C1594(4)
- semantics::CheckStructConstructorPointerComponent(
- context_, *symbol, *value, innermost);
- result.Add(*symbol, Fold(std::move(*value)));
- continue;
- }
- if (IsNullPointer(&*value)) {
- if (IsAllocatable(*symbol)) {
- if (IsBareNullPointer(&*value)) {
- // NULL() with no arguments allowed by 7.5.10 para 6 for
- // ALLOCATABLE.
- result.Add(*symbol, Expr<SomeType>{NullPointer{}});
- continue;
- }
- if (IsNullObjectPointer(&*value)) {
- AttachDeclaration(
- Warn(common::LanguageFeature::
- NullMoldAllocatableComponentValue,
- expr.source,
- "NULL() with arguments is not standard conforming as the value for allocatable component '%s'"_port_en_US,
- symbol->name()),
- *symbol);
- // proceed to check type & shape
- } else {
- AttachDeclaration(
- Say(expr.source,
- "A NULL procedure pointer may not be used as the value for component '%s'"_err_en_US,
- symbol->name()),
- *symbol);
- continue;
- }
+ if (symbol->has<semantics::TypeParamDetails>()) {
+ Say(exprSource,
+ "Type parameter '%s' may not appear as a component of a structure constructor"_err_en_US,
+ symbol->name());
+ }
+ if (!(symbol->has<semantics::ProcEntityDetails>() ||
+ symbol->has<semantics::ObjectEntityDetails>())) {
+ continue; // recovery
+ }
+ if (IsPointer(*symbol)) { // C7104, C7105, C1594(4)
+ semantics::CheckStructConstructorPointerComponent(
+ context_, *symbol, value, innermost);
+ result.Add(*symbol, Fold(std::move(value)));
+ continue;
+ }
+ if (IsNullPointer(&value)) {
+ if (IsAllocatable(*symbol)) {
+ if (IsBareNullPointer(&value)) {
+ // NULL() with no arguments allowed by 7.5.10 para 6 for
+ // ALLOCATABLE.
+ result.Add(*symbol, Expr<SomeType>{NullPointer{}});
+ continue;
+ }
+ if (IsNullObjectPointer(&value)) {
+ AttachDeclaration(
+ Warn(common::LanguageFeature::NullMoldAllocatableComponentValue,
+ exprSource,
+ "NULL() with arguments is not standard conforming as the value for allocatable component '%s'"_port_en_US,
+ symbol->name()),
+ *symbol);
+ // proceed to check type & shape
} else {
AttachDeclaration(
- Say(expr.source,
- "A NULL pointer may not be used as the value for component '%s'"_err_en_US,
+ Say(exprSource,
+ "A NULL procedure pointer may not be used as the value for component '%s'"_err_en_US,
symbol->name()),
*symbol);
continue;
}
- } else if (IsNullAllocatable(&*value) && IsAllocatable(*symbol)) {
- result.Add(*symbol, Expr<SomeType>{NullPointer{}});
+ } else {
+ AttachDeclaration(
+ Say(exprSource,
+ "A NULL pointer may not be used as the value for component '%s'"_err_en_US,
+ symbol->name()),
+ *symbol);
continue;
- } else if (auto *derived{evaluate::GetDerivedTypeSpec(
- evaluate::DynamicType::From(*symbol))}) {
- if (auto iter{FindPointerPotentialComponent(*derived)};
- iter && pureContext) { // F'2023 C15104(4)
- if (const Symbol *
- visible{semantics::FindExternallyVisibleObject(
- *value, *pureContext)}) {
- Say(expr.source,
- "The externally visible object '%s' may not be used in a pure procedure as the value for component '%s' which has the pointer component '%s'"_err_en_US,
- visible->name(), symbol->name(),
- iter.BuildResultDesignatorName());
- } else if (ExtractCoarrayRef(*value)) {
- Say(expr.source,
- "A coindexed object may not be used in a pure procedure as the value for component '%s' which has the pointer component '%s'"_err_en_US,
- symbol->name(), iter.BuildResultDesignatorName());
- }
+ }
+ } else if (IsNullAllocatable(&value) && IsAllocatable(*symbol)) {
+ result.Add(*symbol, Expr<SomeType>{NullPointer{}});
+ continue;
+ } else if (auto *derived{evaluate::GetDerivedTypeSpec(
+ evaluate::DynamicType::From(*symbol))}) {
+ if (auto iter{FindPointerPotentialComponent(*derived)};
+ iter && pureContext) { // F'2023 C15104(4)
+ if (const Symbol *
+ visible{semantics::FindExternallyVisibleObject(
+ value, *pureContext)}) {
+ Say(exprSource,
+ "The externally visible object '%s' may not be used in a pure procedure as the value for component '%s' which has the pointer component '%s'"_err_en_US,
+ visible->name(), symbol->name(),
+ iter.BuildResultDesignatorName());
+ } else if (ExtractCoarrayRef(value)) {
+ Say(exprSource,
+ "A coindexed object may not be used in a pure procedure as the value for component '%s' which has the pointer component '%s'"_err_en_US,
+ symbol->name(), iter.BuildResultDesignatorName());
}
}
- // Make implicit conversion explicit to allow folding of the structure
- // constructors and help semantic checking, unless the component is
- // allocatable, in which case the value could be an unallocated
- // allocatable (see Fortran 2018 7.5.10 point 7). The explicit
- // convert would cause a segfault. Lowering will deal with
- // conditionally converting and preserving the lower bounds in this
- // case.
- if (MaybeExpr converted{ImplicitConvertTo(
- *symbol, std::move(*value), IsAllocatable(*symbol))}) {
- if (auto componentShape{GetShape(GetFoldingContext(), *symbol)}) {
- if (auto valueShape{GetShape(GetFoldingContext(), *converted)}) {
- if (GetRank(*componentShape) == 0 && GetRank(*valueShape) > 0) {
+ }
+ // Make implicit conversion explicit to allow folding of the structure
+ // constructors and help semantic checking, unless the component is
+ // allocatable, in which case the value could be an unallocated
+ // allocatable (see Fortran 2018 7.5.10 point 7). The explicit
+ // convert would cause a segfault. Lowering will deal with
+ // conditionally converting and preserving the lower bounds in this
+ // case.
+ if (MaybeExpr converted{ImplicitConvertTo(
+ *symbol, std::move(value), IsAllocatable(*symbol))}) {
+ if (auto componentShape{GetShape(GetFoldingContext(), *symbol)}) {
+ if (auto valueShape{GetShape(GetFoldingContext(), *converted)}) {
+ if (GetRank(*componentShape) == 0 && GetRank(*valueShape) > 0) {
+ AttachDeclaration(
+ Say(exprSource,
+ "Rank-%d array value is not compatible with scalar component '%s'"_err_en_US,
+ GetRank(*valueShape), symbol->name()),
+ *symbol);
+ } else {
+ auto checked{CheckConformance(messages, *componentShape,
+ *valueShape, CheckConformanceFlags::RightIsExpandableDeferred,
+ "component", "value")};
+ if (checked && *checked && GetRank(*componentShape) > 0 &&
+ GetRank(*valueShape) == 0 &&
+ (IsDeferredShape(*symbol) ||
+ !IsExpandableScalar(*converted, GetFoldingContext(),
+ *componentShape, true /*admit PURE call*/))) {
AttachDeclaration(
- Say(expr.source,
- "Rank-%d array value is not compatible with scalar component '%s'"_err_en_US,
- GetRank(*valueShape), symbol->name()),
+ Say(exprSource,
+ "Scalar value cannot be expanded to shape of array component '%s'"_err_en_US,
+ symbol->name()),
*symbol);
- } else {
- auto checked{
- CheckConformance(messages, *componentShape, *valueShape,
- CheckConformanceFlags::RightIsExpandableDeferred,
- "component", "value")};
- if (checked && *checked && GetRank(*componentShape) > 0 &&
- GetRank(*valueShape) == 0 &&
- (IsDeferredShape(*symbol) ||
- !IsExpandableScalar(*converted, GetFoldingContext(),
- *componentShape, true /*admit PURE call*/))) {
- AttachDeclaration(
- Say(expr.source,
- "Scalar value cannot be expanded to shape of array component '%s'"_err_en_US,
- symbol->name()),
- *symbol);
- }
- if (checked.value_or(true)) {
- result.Add(*symbol, std::move(*converted));
- }
}
- } else {
- Say(expr.source, "Shape of value cannot be determined"_err_en_US);
+ if (checked.value_or(true)) {
+ result.Add(*symbol, std::move(*converted));
+ }
}
} else {
- AttachDeclaration(
- Say(expr.source,
- "Shape of component '%s' cannot be determined"_err_en_US,
- symbol->name()),
- *symbol);
- }
- } else if (auto symType{DynamicType::From(symbol)}) {
- if (IsAllocatable(*symbol) && symType->IsUnlimitedPolymorphic() &&
- valueType) {
- // ok
- } else if (valueType) {
- AttachDeclaration(
- Say(expr.source,
- "Value in structure constructor of type '%s' is "
- "incompatible with component '%s' of type '%s'"_err_en_US,
- valueType->AsFortran(), symbol->name(),
- symType->AsFortran()),
- *symbol);
- } else {
- AttachDeclaration(
- Say(expr.source,
- "Value in structure constructor is incompatible with "
- "component '%s' of type %s"_err_en_US,
- symbol->name(), symType->AsFortran()),
- *symbol);
+ Say(exprSource, "Shape of value cannot be determined"_err_en_US);
}
+ } else {
+ AttachDeclaration(
+ Say(exprSource,
+ "Shape of component '%s' cannot be determined"_err_en_US,
+ symbol->name()),
+ *symbol);
+ }
+ } else if (auto symType{DynamicType::From(symbol)}) {
+ if (IsAllocatable(*symbol) && symType->IsUnlimitedPolymorphic() &&
+ valueType) {
+ // ok
+ } else if (valueType) {
+ AttachDeclaration(
+ Say(exprSource,
+ "Value in structure constructor of type '%s' is incompatible with component '%s' of type '%s'"_err_en_US,
+ valueType->AsFortran(), symbol->name(), symType->AsFortran()),
+ *symbol);
+ } else {
+ AttachDeclaration(
+ Say(exprSource,
+ "Value in structure constructor is incompatible with component '%s' of type %s"_err_en_US,
+ symbol->name(), symType->AsFortran()),
+ *symbol);
}
}
}
@@ -2375,10 +2350,10 @@ MaybeExpr ExpressionAnalyzer::Analyze(
} else if (IsPointer(symbol)) {
result.Add(symbol, Expr<SomeType>{NullPointer{}});
} else if (object) { // C799
- AttachDeclaration(Say(typeName,
- "Structure constructor lacks a value for "
- "component '%s'"_err_en_US,
- symbol.name()),
+ AttachDeclaration(
+ Say(typeName,
+ "Structure constructor lacks a value for component '%s'"_err_en_US,
+ symbol.name()),
symbol);
}
}
@@ -2388,6 +2363,45 @@ MaybeExpr ExpressionAnalyzer::Analyze(
return AsMaybeExpr(Expr<SomeDerived>{std::move(result)});
}
+MaybeExpr ExpressionAnalyzer::Analyze(
+ const parser::StructureConstructor &structure) {
+ const auto &parsedType{std::get<parser::DerivedTypeSpec>(structure.t)};
+ parser::Name structureType{std::get<parser::Name>(parsedType.t)};
+ parser::CharBlock &typeName{structureType.source};
+ if (semantics::Symbol * typeSymbol{structureType.symbol}) {
+ if (typeSymbol->has<semantics::DerivedTypeDetails>()) {
+ semantics::DerivedTypeSpec dtSpec{typeName, typeSymbol->GetUltimate()};
+ if (!CheckIsValidForwardReference(dtSpec)) {
+ return std::nullopt;
+ }
+ }
+ }
+ if (!parsedType.derivedTypeSpec) {
+ return std::nullopt;
+ }
+ auto restorer{AllowNullPointer()}; // NULL() can be a valid component
+ std::list<ComponentSpec> componentSpecs;
+ for (const auto &component :
+ std::get<std::list<parser::ComponentSpec>>(structure.t)) {
+ const parser::Expr &expr{
+ std::get<parser::ComponentDataSource>(component.t).v.value()};
+ auto restorer{GetContextualMessages().SetLocation(expr.source)};
+ ComponentSpec compSpec;
+ compSpec.exprSource = expr.source;
+ compSpec.expr = Analyze(expr);
+ if (const auto &kw{std::get<std::optional<parser::Keyword>>(component.t)}) {
+ compSpec.source = kw->v.source;
+ compSpec.hasKeyword = true;
+ compSpec.keywordSymbol = kw->v.symbol;
+ } else {
+ compSpec.source = expr.source;
+ }
+ componentSpecs.emplace_back(std::move(compSpec));
+ }
+ return CheckStructureConstructor(
+ typeName, DEREF(parsedType.derivedTypeSpec), std::move(componentSpecs));
+}
+
static std::optional<parser::CharBlock> GetPassName(
const semantics::Symbol &proc) {
return common::visit(
@@ -2835,24 +2849,26 @@ std::pair<const Symbol *, bool> ExpressionAnalyzer::ResolveGeneric(
const Symbol &symbol, const ActualArguments &actuals,
const AdjustActuals &adjustActuals, bool isSubroutine,
bool mightBeStructureConstructor) {
- const Symbol *elemental{nullptr}; // matching elemental specific proc
- const Symbol *nonElemental{nullptr}; // matching non-elemental specific
const Symbol &ultimate{symbol.GetUltimate()};
- int crtMatchingDistance{cudaInfMatchingValue};
// Check for a match with an explicit INTRINSIC
+ const Symbol *explicitIntrinsic{nullptr};
if (ultimate.attrs().test(semantics::Attr::INTRINSIC)) {
parser::Messages buffer;
- auto restorer{foldingContext_.messages().SetMessages(buffer)};
+ auto restorer{GetContextualMessages().SetMessages(buffer)};
ActualArguments localActuals{actuals};
if (context_.intrinsics().Probe(
CallCharacteristics{ultimate.name().ToString(), isSubroutine},
localActuals, foldingContext_) &&
!buffer.AnyFatalError()) {
- return {&ultimate, false};
+ explicitIntrinsic = &ultimate;
}
}
- if (const auto *details{ultimate.detailsIf<semantics::GenericDetails>()}) {
- for (const Symbol &specific0 : details->specificProcs()) {
+ const Symbol *elemental{nullptr}; // matching elemental specific proc
+ const Symbol *nonElemental{nullptr}; // matching non-elemental specific
+ const auto *genericDetails{ultimate.detailsIf<semantics::GenericDetails>()};
+ if (genericDetails && !explicitIntrinsic) {
+ int crtMatchingDistance{cudaInfMatchingValue};
+ for (const Symbol &specific0 : genericDetails->specificProcs()) {
const Symbol &specific1{BypassGeneric(specific0)};
if (isSubroutine != !IsFunction(specific1)) {
continue;
@@ -2905,25 +2921,93 @@ std::pair<const Symbol *, bool> ExpressionAnalyzer::ResolveGeneric(
}
}
}
- if (nonElemental) {
- return {&AccessSpecific(symbol, *nonElemental), false};
- } else if (elemental) {
- return {&AccessSpecific(symbol, *elemental), false};
+ }
+ // Is there a derived type of the same name?
+ const Symbol *derivedType{nullptr};
+ if (mightBeStructureConstructor && !isSubroutine && genericDetails) {
+ if (const Symbol * dt{genericDetails->derivedType()}) {
+ const Symbol &ultimate{dt->GetUltimate()};
+ if (ultimate.has<semantics::DerivedTypeDetails>()) {
+ derivedType = &ultimate;
+ }
}
- // Check parent derived type
- if (const auto *parentScope{symbol.owner().GetDerivedTypeParent()}) {
- if (const Symbol *extended{parentScope->FindComponent(symbol.name())}) {
- auto pair{ResolveGeneric(
- *extended, actuals, adjustActuals, isSubroutine, false)};
- if (pair.first) {
- return pair;
+ }
+ // F'2023 C7108 checking. No Fortran compiler actually enforces this
+ // constraint, so it's just a portability warning here.
+ if (derivedType && (explicitIntrinsic || nonElemental || elemental) &&
+ context_.ShouldWarn(
+ common::LanguageFeature::AmbiguousStructureConstructor)) {
+ // See whethr there's ambiguity with a structure constructor.
+ bool possiblyAmbiguous{true};
+ if (const semantics::Scope * dtScope{derivedType->scope()}) {
+ parser::Messages buffer;
+ auto restorer{GetContextualMessages().SetMessages(buffer)};
+ std::list<ComponentSpec> componentSpecs;
+ for (const auto &actual : actuals) {
+ if (actual) {
+ ComponentSpec compSpec;
+ if (const Expr<SomeType> *expr{actual->UnwrapExpr()}) {
+ compSpec.expr = *expr;
+ } else {
+ possiblyAmbiguous = false;
+ }
+ if (auto loc{actual->sourceLocation()}) {
+ compSpec.source = compSpec.exprSource = *loc;
+ }
+ if (auto kw{actual->keyword()}) {
+ compSpec.hasKeyword = true;
+ compSpec.keywordSymbol = dtScope->FindComponent(*kw);
+ }
+ componentSpecs.emplace_back(std::move(compSpec));
+ } else {
+ possiblyAmbiguous = false;
}
}
+ semantics::DerivedTypeSpec dtSpec{derivedType->name(), *derivedType};
+ dtSpec.set_scope(*dtScope);
+ possiblyAmbiguous = possiblyAmbiguous &&
+ CheckStructureConstructor(
+ derivedType->name(), dtSpec, std::move(componentSpecs))
+ .has_value() &&
+ !buffer.AnyFatalError();
+ }
+ if (possiblyAmbiguous) {
+ if (explicitIntrinsic) {
+ Warn(common::LanguageFeature::AmbiguousStructureConstructor,
+ "Reference to the intrinsic function '%s' is ambiguous with a structure constructor of the same name"_port_en_US,
+ symbol.name());
+ } else {
+ Warn(common::LanguageFeature::AmbiguousStructureConstructor,
+ "Reference to generic function '%s' (resolving to specific '%s') is ambiguous with a structure constructor of the same name"_port_en_US,
+ symbol.name(),
+ nonElemental ? nonElemental->name() : elemental->name());
+ }
}
- if (mightBeStructureConstructor && details->derivedType()) {
- return {details->derivedType(), false};
+ }
+ // Return the right resolution, if there is one. Explicit intrinsics
+ // are preferred, then non-elements specifics, then elementals, and
+ // lastly structure constructors.
+ if (explicitIntrinsic) {
+ return {explicitIntrinsic, false};
+ } else if (nonElemental) {
+ return {&AccessSpecific(symbol, *nonElemental), false};
+ } else if (elemental) {
+ return {&AccessSpecific(symbol, *elemental), false};
+ }
+ // Check parent derived type
+ if (const auto *parentScope{symbol.owner().GetDerivedTypeParent()}) {
+ if (const Symbol * extended{parentScope->FindComponent(symbol.name())}) {
+ auto pair{ResolveGeneric(
+ *extended, actuals, adjustActuals, isSubroutine, false)};
+ if (pair.first) {
+ return pair;
+ }
}
}
+ // Structure constructor?
+ if (derivedType) {
+ return {derivedType, false};
+ }
// Check for generic or explicit INTRINSIC of the same name in outer scopes.
// See 15.5.5.2 for details.
if (!symbol.owner().IsGlobal() && !symbol.owner().IsDerivedType()) {
diff --git a/flang/lib/Support/Fortran-features.cpp b/flang/lib/Support/Fortran-features.cpp
index 49a5989849eaa..bee8984102b82 100644
--- a/flang/lib/Support/Fortran-features.cpp
+++ b/flang/lib/Support/Fortran-features.cpp
@@ -45,6 +45,7 @@ LanguageFeatureControl::LanguageFeatureControl() {
warnLanguage_.set(LanguageFeature::HollerithPolymorphic);
warnLanguage_.set(LanguageFeature::ListDirectedSize);
warnLanguage_.set(LanguageFeature::IgnoreIrrelevantAttributes);
+ warnLanguage_.set(LanguageFeature::AmbiguousStructureConstructor);
warnUsage_.set(UsageWarning::ShortArrayActual);
warnUsage_.set(UsageWarning::FoldingException);
warnUsage_.set(UsageWarning::FoldingAvoidsRuntimeCrash);
diff --git a/flang/test/Semantics/c7108.f90 b/flang/test/Semantics/c7108.f90
new file mode 100644
index 0000000000000..c23a0abe3ee03
--- /dev/null
+++ b/flang/test/Semantics/c7108.f90
@@ -0,0 +1,41 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1 -pedantic -Werror
+! F'2023 C7108 is portably unenforced.
+module m
+ type foo
+ integer n
+ end type
+ interface foo
+ procedure bar0, bar1, bar2, bar3
+ end interface
+ contains
+ type(foo) function bar0(n)
+ integer, intent(in) :: n
+ print *, 'bar0'
+ bar0%n = n
+ end
+ type(foo) function bar1()
+ print *, 'bar1'
+ bar1%n = 1
+ end
+ type(foo) function bar2(a)
+ real, intent(in) :: a
+ print *, 'bar2'
+ bar2%n = a
+ end
+ type(foo) function bar3(L)
+ logical, intent(in) :: L
+ print *, 'bar3'
+ bar3%n = merge(4,5,L)
+ end
+end
+
+program p
+ use m
+ type(foo) x
+ x = foo(); print *, x ! ok, not ambiguous
+ !PORTABILITY: Reference to generic function 'foo' (resolving to specific 'bar0') is ambiguous with a structure constructor of the same name
+ x = foo(2); print *, x ! ambigous
+ !PORTABILITY: Reference to generic function 'foo' (resolving to specific 'bar2') is ambiguous with a structure constructor of the same name
+ x = foo(3.); print *, x ! ambiguous due to data conversion
+ x = foo(.true.); print *, x ! ok, not ambigous
+end
diff --git a/flang/test/Semantics/generic09.f90 b/flang/test/Semantics/generic09.f90
index 6159dd4b701d7..d93d7453ed6dd 100644
--- a/flang/test/Semantics/generic09.f90
+++ b/flang/test/Semantics/generic09.f90
@@ -1,4 +1,5 @@
! RUN: %flang_fc1 -fdebug-unparse %s 2>&1 | FileCheck %s
+
module m1
type foo
integer n
@@ -32,6 +33,9 @@ type(foo) function f2(a)
end
end
+!CHECK: portability: Reference to generic function 'foo' (resolving to specific 'f1') is ambiguous with a structure constructor of the same name
+!CHECK: portability: Reference to generic function 'foo' (resolving to specific 'f2') is ambiguous with a structure constructor of the same name
+
program main
use m3
type(foo) x
diff --git a/flang/test/Semantics/resolve11.f90 b/flang/test/Semantics/resolve11.f90
index 39a30b858ebb6..9ae4f52c4fd54 100644
--- a/flang/test/Semantics/resolve11.f90
+++ b/flang/test/Semantics/resolve11.f90
@@ -66,7 +66,8 @@ subroutine s4
!ERROR: 'fun' is PRIVATE in 'm4'
use m4, only: foo, fun
type(foo) x ! ok
- print *, foo() ! ok
+ !PORTABILITY: Reference to generic function 'foo' (resolving to specific 'fun') is ambiguous with a structure constructor of the same name
+ print *, foo()
end
module m5
diff --git a/flang/test/Semantics/resolve17.f90 b/flang/test/Semantics/resolve17.f90
index 770af756d03bc..6a6e355abe0b8 100644
--- a/flang/test/Semantics/resolve17.f90
+++ b/flang/test/Semantics/resolve17.f90
@@ -290,6 +290,7 @@ module m14d
contains
subroutine test
real :: y
+ !PORTABILITY: Reference to generic function 'foo' (resolving to specific 'bar') is ambiguous with a structure constructor of the same name
y = foo(1.0)
x = foo(2)
end subroutine
@@ -301,6 +302,7 @@ module m14e
contains
subroutine test
real :: y
+ !PORTABILITY: Reference to generic function 'foo' (resolving to specific 'bar') is ambiguous with a structure constructor of the same name
y = foo(1.0)
x = foo(2)
end subroutine
diff --git a/flang/test/Semantics/resolve18.f90 b/flang/test/Semantics/resolve18.f90
index fef526908bbf9..547db5e85714c 100644
--- a/flang/test/Semantics/resolve18.f90
+++ b/flang/test/Semantics/resolve18.f90
@@ -348,6 +348,7 @@ subroutine s_21_23
use m21
use m23
type(foo) x ! Intel and NAG error
+ !PORTABILITY: Reference to generic function 'foo' (resolving to specific 'f1') is ambiguous with a structure constructor of the same name
print *, foo(1.) ! Intel error
print *, foo(1.,2.,3.) ! Intel error
call ext(foo) ! GNU and Intel error
More information about the flang-commits
mailing list