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 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 &&); + 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 550a5c8f307d3..0e18eaedf2139 100644 --- a/flang/include/flang/Support/Fortran-features.h +++ b/flang/include/flang/Support/Fortran-features.h @@ -54,7 +54,8 @@ ENUM_CLASS(LanguageFeature, BackslashEscapes, OldDebugLines, PolymorphicActualAllocatableOrPointerToMonomorphicDummy, RelaxedPureDummy, UndefinableAsynchronousOrVolatileActual, AutomaticInMainProgram, PrintCptr, SavedLocalInSpecExpr, PrintNamelist, AssumedRankPassedToNonAssumedRank, - IgnoreIrrelevantAttributes, Unsigned, ContiguousOkForSeqAssociation) + IgnoreIrrelevantAttributes, Unsigned, AmbiguousStructureConstructor, + ContiguousOkForSeqAssociation) // 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 0659536aab98c..64cb46f2a6f4f 100644 --- a/flang/lib/Semantics/expression.cpp +++ b/flang/lib/Semantics/expression.cpp @@ -2069,23 +2069,9 @@ static MaybeExpr ImplicitConvertTo(const semantics::Symbol &sym, return std::nullopt; } -MaybeExpr ExpressionAnalyzer::Analyze( - const parser::StructureConstructor &structure) { - auto &parsedType{std::get(structure.t)}; - parser::Name structureType{std::get(parsedType.t)}; - parser::CharBlock &typeName{structureType.source}; - if (semantics::Symbol *typeSymbol{structureType.symbol}) { - if (typeSymbol->has()) { - 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 &&componentSpecs) { const Symbol &typeSymbol{spec.typeSymbol()}; if (!spec.scope() || !typeSymbol.has()) { return std::nullopt; // error recovery @@ -2096,10 +2082,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 } @@ -2129,22 +2115,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>(structure.t)) { - const parser::Expr &expr{ - std::get(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 &value{*maybeValue}; std::optional valueType{DynamicType::From(value)}; - if (const auto &kw{std::get>(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. @@ -2196,9 +2179,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{ @@ -2206,8 +2189,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. @@ -2225,143 +2207,136 @@ MaybeExpr ExpressionAnalyzer::Analyze( } } unavailable.insert(symbol->name()); - if (value) { - if (symbol->has()) { - Say(expr.source, - "Type parameter '%s' may not appear as a component of a structure constructor"_err_en_US, - symbol->name()); - } - if (!(symbol->has() || - symbol->has())) { - 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{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()) { + Say(exprSource, + "Type parameter '%s' may not appear as a component of a structure constructor"_err_en_US, + symbol->name()); + } + if (!(symbol->has() || + symbol->has())) { + 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{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{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{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); } } } @@ -2381,10 +2356,10 @@ MaybeExpr ExpressionAnalyzer::Analyze( } else if (IsPointer(symbol)) { result.Add(symbol, Expr{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); } } @@ -2394,6 +2369,45 @@ MaybeExpr ExpressionAnalyzer::Analyze( return AsMaybeExpr(Expr{std::move(result)}); } +MaybeExpr ExpressionAnalyzer::Analyze( + const parser::StructureConstructor &structure) { + const auto &parsedType{std::get(structure.t)}; + parser::Name structureType{std::get(parsedType.t)}; + parser::CharBlock &typeName{structureType.source}; + if (semantics::Symbol * typeSymbol{structureType.symbol}) { + if (typeSymbol->has()) { + 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 componentSpecs; + for (const auto &component : + std::get>(structure.t)) { + const parser::Expr &expr{ + std::get(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>(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 GetPassName( const semantics::Symbol &proc) { return common::visit( @@ -2841,24 +2855,26 @@ std::pair 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()}) { - 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()}; + if (genericDetails && !explicitIntrinsic) { + int crtMatchingDistance{cudaInfMatchingValue}; + for (const Symbol &specific0 : genericDetails->specificProcs()) { const Symbol &specific1{BypassGeneric(specific0)}; if (isSubroutine != !IsFunction(specific1)) { continue; @@ -2911,25 +2927,93 @@ std::pair ExpressionAnalyzer::ResolveGeneric( } } } - 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; + } + // 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()) { + derivedType = &ultimate; + } + } + } + // 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 componentSpecs; + for (const auto &actual : actuals) { + if (actual) { + ComponentSpec compSpec; + if (const Expr *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