From 455de5543c9e27f64563292ec57142da01e5fc5a Mon Sep 17 00:00:00 2001 From: Peter Klausler Date: Mon, 19 Jan 2026 11:00:26 -0800 Subject: [PATCH] [flang] Fix non-portable TYPE(*) usage in generic (#176235) Fortran allows a scalar actual argument of any type to correspond with a TYPE(*) dummy argument that is an assumed-size array. This usage isn't portable, and it didn't work with a generic procedure with this compiler, only specific procedures. It affected at least one API in OpenMPI. Fix generic resolution to allow for this case, add a distinguishability test to detect generic interfaces that have ambiguous specific procedures due to it, and add an optional portability warning (off by default). --- .../include/flang/Support/Fortran-features.h | 2 +- flang/lib/Evaluate/characteristics.cpp | 6 ++++ flang/lib/Semantics/check-call.cpp | 10 ++++-- flang/lib/Semantics/expression.cpp | 35 ++++++++++++------- flang/test/Semantics/call03.f90 | 1 + flang/test/Semantics/call46.f90 | 32 +++++++++++++++++ 6 files changed, 69 insertions(+), 17 deletions(-) create mode 100644 flang/test/Semantics/call46.f90 diff --git a/flang/include/flang/Support/Fortran-features.h b/flang/include/flang/Support/Fortran-features.h index 9c8d7e36b1ef..8586a60c5b21 100644 --- a/flang/include/flang/Support/Fortran-features.h +++ b/flang/include/flang/Support/Fortran-features.h @@ -80,7 +80,7 @@ ENUM_CLASS(UsageWarning, Portability, PointerToUndefinable, NullActualForDefaultIntentAllocatable, UseAssociationIntoSameNameSubprogram, HostAssociatedIntentOutInSpecExpr, NonVolatilePointerToVolatile, RealConstantWidening, VolatileOrAsynchronousTemporary, UnusedVariable, - UsedUndefinedVariable, BadValueInDeadCode) + UsedUndefinedVariable, BadValueInDeadCode, AssumedTypeSizeDummy) using LanguageFeatures = EnumSet; using UsageWarnings = EnumSet; diff --git a/flang/lib/Evaluate/characteristics.cpp b/flang/lib/Evaluate/characteristics.cpp index 542f1223e658..65495e5eff21 100644 --- a/flang/lib/Evaluate/characteristics.cpp +++ b/flang/lib/Evaluate/characteristics.cpp @@ -1887,6 +1887,12 @@ bool DistinguishUtils::Distinguishable(const TypeAndShape &x, if (ignoreTKR.test(common::IgnoreTKR::Rank)) { } else if (x.attrs().test(TypeAndShape::Attr::AssumedRank) || y.attrs().test(TypeAndShape::Attr::AssumedRank)) { + } else if ((x.attrs().test(TypeAndShape::Attr::AssumedSize) && + x.type().IsAssumedType() && y.Rank() == 0) || + (y.attrs().test(TypeAndShape::Attr::AssumedSize) && + y.type().IsAssumedType() && x.Rank() == 0)) { + // F'2023 15.5.2.5 p14, third bullet: scalar actual can be passed + // to TYPE(*) assumed-size dummy argument } else if (x.Rank() != y.Rank()) { return true; } diff --git a/flang/lib/Semantics/check-call.cpp b/flang/lib/Semantics/check-call.cpp index c7150acab33f..87c7674d4d99 100644 --- a/flang/lib/Semantics/check-call.cpp +++ b/flang/lib/Semantics/check-call.cpp @@ -573,6 +573,12 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy, "Assumed-size array may not be associated with assumed-shape %s"_err_en_US, dummyName); } + } else if (dummyIsAssumedSize && dummy.type.type().IsAssumedType() && + actualRank == 0 && !actualIsAssumedRank) { + // F'2023 15.5.2.5 p14 third bullet allows a scalar actual + // argument to associate with a TYPE(*) assumed-size dummy + foldingContext.Warn(common::UsageWarning::AssumedTypeSizeDummy, + "A scalar actual argument for an assumed-size TYPE(*) dummy is not portable"_port_en_US); } else if (dummyRank > 0) { bool basicError{false}; if (actualRank == 0 && !actualIsAssumedRank && @@ -589,9 +595,7 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy, actualType.type().category() == TypeCategory::Character && actualType.type().kind() == 1}; if (!actualIsCKindCharacter) { - if (!actualIsArrayElement && - !(dummy.type.type().IsAssumedType() && dummyIsAssumedSize) && - !dummyIsAssumedRank && + if (!actualIsArrayElement && !dummyIsAssumedRank && !dummy.ignoreTKR.test(common::IgnoreTKR::Rank)) { basicError = true; messages.Say( diff --git a/flang/lib/Semantics/expression.cpp b/flang/lib/Semantics/expression.cpp index b3643e0d35d5..ddcce446ea31 100644 --- a/flang/lib/Semantics/expression.cpp +++ b/flang/lib/Semantics/expression.cpp @@ -2712,7 +2712,10 @@ static bool CheckCompatibleArgument(bool isElemental, } else if (!isElemental && actual.Rank() != x.type.Rank() && !x.type.attrs().test( characteristics::TypeAndShape::Attr::AssumedRank) && - !x.ignoreTKR.test(common::IgnoreTKR::Rank)) { + !x.ignoreTKR.test(common::IgnoreTKR::Rank) && + !(x.type.type().IsAssumedType() && + x.type.attrs().test( + characteristics::TypeAndShape::Attr::AssumedSize))) { return false; } else if (auto actualType{actual.GetType()}) { return x.type.type().IsTkCompatibleWith(*actualType, x.ignoreTKR); @@ -2964,6 +2967,7 @@ auto ExpressionAnalyzer::ResolveGeneric(const Symbol &symbol, continue; } } + tried.push_back(*specific); if (semantics::CheckInterfaceForGeneric(*procedure, localActuals, context_, false /* no integer conversions */) && CheckCompatibleArguments( @@ -2996,7 +3000,6 @@ auto ExpressionAnalyzer::ResolveGeneric(const Symbol &symbol, crtMatchingDistance = ComputeCudaMatchingDistance( context_.languageFeatures(), *procedure, localActuals); } else { - tried.push_back(*specific); } } } @@ -3155,17 +3158,23 @@ void ExpressionAnalyzer::EmitGenericResolutionError(const Symbol &symbol, if (auto procChars{characteristics::Procedure::Characterize( specific, GetFoldingContext())}) { if (procChars->HasExplicitInterface()) { - if (auto reasons{semantics::CheckExplicitInterface(*procChars, - arguments, context_, &scope, /*intrinsic=*/nullptr, - /*allocActualArgumentConversions=*/false, - /*extentErrors=*/false, - /*ignoreImplicitVsExplicit=*/false)}; - !reasons.empty()) { - reasons.AttachTo( - msg->Attach(specific.name(), - "Specific procedure '%s' does not match the actual arguments because"_en_US, - specific.name()), - parser::Severity::None); + auto reasons{semantics::CheckExplicitInterface(*procChars, arguments, + context_, &scope, /*intrinsic=*/nullptr, + /*allocActualArgumentConversions=*/false, + /*extentErrors=*/false, + /*ignoreImplicitVsExplicit=*/false)}; + if (reasons.AnyFatalError() != dueToAmbiguity) { + if (dueToAmbiguity) { + msg->Attach(specific.name(), + "Specific procedure '%s' matched the actual arguments"_en_US, + specific.name()); + } else { + reasons.AttachTo( + msg->Attach(specific.name(), + "Specific procedure '%s' does not match the actual arguments because"_en_US, + specific.name()), + parser::Severity::None); + } } } } diff --git a/flang/test/Semantics/call03.f90 b/flang/test/Semantics/call03.f90 index e44efe463301..6a1009392f94 100644 --- a/flang/test/Semantics/call03.f90 +++ b/flang/test/Semantics/call03.f90 @@ -237,6 +237,7 @@ module m01 call charray(assumed_shape_char(1)) ! not an error if character call assumedsize(arr(1)) ! not an error if element in sequence call assumedrank(x) ! not an error + !PORTABILITY: A scalar actual argument for an assumed-size TYPE(*) dummy is not portable [-Wassumed-type-size-dummy] call assumedtypeandsize(x) ! not an error end subroutine diff --git a/flang/test/Semantics/call46.f90 b/flang/test/Semantics/call46.f90 new file mode 100644 index 000000000000..139f1a70d053 --- /dev/null +++ b/flang/test/Semantics/call46.f90 @@ -0,0 +1,32 @@ +!RUN: %python %S/test_errors.py %s %flang_fc1 -pedantic +module m + interface generic1 ! ok + module procedure :: sub1 + end interface + !ERROR: Generic 'generic2' may not have specific procedures 'sub1' and 'sub2' as their interfaces are not distinguishable + interface generic2 + module procedure :: sub1, sub2 + end interface + contains + subroutine sub1(a,len) + type(*), intent(in) :: a(*) + integer len + print *, 'in sub' + end + subroutine sub2(a,len) + character(*), intent(in) :: a + integer len + print *, 'in sub2' + end +end + +program test + use m + character(3) :: foo = "abc" + !PORTABILITY: A scalar actual argument for an assumed-size TYPE(*) dummy is not portable [-Wassumed-type-size-dummy] + call sub1(foo, 3) ! ok + !PORTABILITY: A scalar actual argument for an assumed-size TYPE(*) dummy is not portable [-Wassumed-type-size-dummy] + call generic1(foo, 3) ! ok + !ERROR: The actual arguments to the generic procedure 'generic2' matched multiple specific procedures, perhaps due to use of NULL() without MOLD= or an actual procedure with an implicit interface + call generic2(foo, 3) +end