[flang-commits] [flang] [flang] Fix non-portable TYPE(*) usage in generic (PR #176235)
Peter Klausler via flang-commits
flang-commits at lists.llvm.org
Thu Jan 15 12:11:20 PST 2026
https://github.com/klausler created https://github.com/llvm/llvm-project/pull/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).
>From bac77d45647862798a2614cb824bf34253d10d43 Mon Sep 17 00:00:00 2001
From: Peter Klausler <pklausler at nvidia.com>
Date: Thu, 15 Jan 2026 12:02:57 -0800
Subject: [PATCH] [flang] Fix non-portable TYPE(*) usage in generic
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 | 9 ++++--
flang/test/Semantics/call03.f90 | 1 +
flang/test/Semantics/call46.f90 | 32 +++++++++++++++++++
6 files changed, 53 insertions(+), 7 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 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..45bdce5e7d115 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);
}
}
}
@@ -3160,7 +3163,7 @@ void ExpressionAnalyzer::EmitGenericResolutionError(const Symbol &symbol,
/*allocActualArgumentConversions=*/false,
/*extentErrors=*/false,
/*ignoreImplicitVsExplicit=*/false)};
- !reasons.empty()) {
+ reasons.AnyFatalError()) {
reasons.AttachTo(
msg->Attach(specific.name(),
"Specific procedure '%s' does not match the actual arguments because"_en_US,
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