[flang-commits] [flang] 455de55 - [flang] Fix non-portable TYPE(*) usage in generic (#176235)
via flang-commits
flang-commits at lists.llvm.org
Mon Jan 19 11:00:30 PST 2026
Author: Peter Klausler
Date: 2026-01-19T11:00:26-08:00
New Revision: 455de5543c9e27f64563292ec57142da01e5fc5a
URL: https://github.com/llvm/llvm-project/commit/455de5543c9e27f64563292ec57142da01e5fc5a
DIFF: https://github.com/llvm/llvm-project/commit/455de5543c9e27f64563292ec57142da01e5fc5a.diff
LOG: [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).
Added:
flang/test/Semantics/call46.f90
Modified:
flang/include/flang/Support/Fortran-features.h
flang/lib/Evaluate/characteristics.cpp
flang/lib/Semantics/check-call.cpp
flang/lib/Semantics/expression.cpp
flang/test/Semantics/call03.f90
Removed:
################################################################################
diff --git a/flang/include/flang/Support/Fortran-features.h b/flang/include/flang/Support/Fortran-features.h
index 9c8d7e36b1ef4..8586a60c5b21c 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<LanguageFeature, LanguageFeature_enumSize>;
using UsageWarnings = EnumSet<UsageWarning, UsageWarning_enumSize>;
diff --git a/flang/lib/Evaluate/characteristics.cpp b/flang/lib/Evaluate/characteristics.cpp
index 542f1223e658d..65495e5eff219 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 c7150acab33f2..87c7674d4d991 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 b3643e0d35d5f..ddcce446ea310 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 e44efe4633010..6a1009392f94b 100644
--- a/flang/test/Semantics/call03.f90
+++ b/flang/test/Semantics/call03.f90
@@ -237,6 +237,7 @@ subroutine test09(ashape, polyarray, c, assumed_shape_char) ! 15.5.2.4(14), 15.5
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 0000000000000..139f1a70d0534
--- /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
More information about the flang-commits
mailing list