[flang-commits] [flang] [flang] Allow polymorphic actual to implicit interface (PR #70873)
Peter Klausler via flang-commits
flang-commits at lists.llvm.org
Thu Nov 2 13:18:12 PDT 2023
https://github.com/klausler updated https://github.com/llvm/llvm-project/pull/70873
>From 897d230e8912af4025f5f474f5ce1711e7423410 Mon Sep 17 00:00:00 2001
From: Peter Klausler <pklausler at nvidia.com>
Date: Tue, 31 Oct 2023 16:09:36 -0700
Subject: [PATCH] [flang] Allow polymorphic actual to implicit interface
Semantics is emitting an error when an actual argument to a
procedure that has an implicit interface has a polymorphic
type. This is too general; while TYPE(*) and CLASS(*)
unlimited polymorphic items require the presence of an explicit
procedure interface, CLASS(T) data can be passed over an
implicit interface to a procedure expecting a corresponding
dummy argument with TYPE(T), so long as T is not parameterized.
(Only XLF handles this usage correctly among other Fortran compilers.)
(Making this work in the case of an actual CLASS(T) array may
well require additional changes in lowering to copy data to/from
a temporary buffer to ensure contiguity when the actual type of
the array is an extension of T.)
---
.../include/flang/Evaluate/characteristics.h | 8 +++----
flang/lib/Evaluate/characteristics.cpp | 24 +++++++++++++------
flang/lib/Evaluate/intrinsics.cpp | 4 ++--
flang/lib/Lower/CallInterface.cpp | 3 ++-
flang/lib/Semantics/check-call.cpp | 14 ++++++-----
flang/test/Semantics/call13.f90 | 9 ++++---
flang/test/Semantics/call40.f90 | 2 +-
flang/test/Semantics/label18.f90# | 18 --------------
8 files changed, 38 insertions(+), 44 deletions(-)
delete mode 100644 flang/test/Semantics/label18.f90#
diff --git a/flang/include/flang/Evaluate/characteristics.h b/flang/include/flang/Evaluate/characteristics.h
index d685d250bf20bf5..b07affc302622f0 100644
--- a/flang/include/flang/Evaluate/characteristics.h
+++ b/flang/include/flang/Evaluate/characteristics.h
@@ -273,10 +273,10 @@ struct DummyArgument {
~DummyArgument();
bool operator==(const DummyArgument &) const;
bool operator!=(const DummyArgument &that) const { return !(*this == that); }
- static std::optional<DummyArgument> FromActual(
- std::string &&, const Expr<SomeType> &, FoldingContext &);
- static std::optional<DummyArgument> FromActual(
- std::string &&, const ActualArgument &, FoldingContext &);
+ static std::optional<DummyArgument> FromActual(std::string &&,
+ const Expr<SomeType> &, FoldingContext &, bool forImplicitInterface);
+ static std::optional<DummyArgument> FromActual(std::string &&,
+ const ActualArgument &, FoldingContext &, bool forImplicitInterface);
bool IsOptional() const;
void SetOptional(bool = true);
common::Intent GetIntent() const;
diff --git a/flang/lib/Evaluate/characteristics.cpp b/flang/lib/Evaluate/characteristics.cpp
index c600cea5c420ccf..16aa08603bdad41 100644
--- a/flang/lib/Evaluate/characteristics.cpp
+++ b/flang/lib/Evaluate/characteristics.cpp
@@ -792,8 +792,9 @@ static std::optional<DummyArgument> CharacterizeDummyArgument(
return std::nullopt;
}
-std::optional<DummyArgument> DummyArgument::FromActual(
- std::string &&name, const Expr<SomeType> &expr, FoldingContext &context) {
+std::optional<DummyArgument> DummyArgument::FromActual(std::string &&name,
+ const Expr<SomeType> &expr, FoldingContext &context,
+ bool forImplicitInterface) {
return common::visit(
common::visitors{
[&](const BOZLiteralConstant &) {
@@ -828,6 +829,13 @@ std::optional<DummyArgument> DummyArgument::FromActual(
},
[&](const auto &) {
if (auto type{TypeAndShape::Characterize(expr, context)}) {
+ if (forImplicitInterface &&
+ !type->type().IsUnlimitedPolymorphic() &&
+ type->type().IsPolymorphic()) {
+ // Pass the monomorphic declared type to an implicit interface
+ type->set_type(DynamicType{
+ type->type().GetDerivedTypeSpec(), /*poly=*/false});
+ }
DummyDataObject obj{std::move(*type)};
obj.attrs.set(DummyDataObject::Attr::DeducedFromActual);
return std::make_optional<DummyArgument>(
@@ -840,10 +848,11 @@ std::optional<DummyArgument> DummyArgument::FromActual(
expr.u);
}
-std::optional<DummyArgument> DummyArgument::FromActual(
- std::string &&name, const ActualArgument &arg, FoldingContext &context) {
+std::optional<DummyArgument> DummyArgument::FromActual(std::string &&name,
+ const ActualArgument &arg, FoldingContext &context,
+ bool forImplicitInterface) {
if (const auto *expr{arg.UnwrapExpr()}) {
- return FromActual(std::move(name), *expr, context);
+ return FromActual(std::move(name), *expr, context, forImplicitInterface);
} else if (arg.GetAssumedTypeDummy()) {
return std::nullopt;
} else {
@@ -1325,8 +1334,9 @@ std::optional<Procedure> Procedure::FromActuals(const ProcedureDesignator &proc,
for (const auto &arg : args) {
++j;
if (arg) {
- if (auto dummy{DummyArgument::FromActual(
- "x"s + std::to_string(j), *arg, context)}) {
+ if (auto dummy{DummyArgument::FromActual("x"s + std::to_string(j),
+ *arg, context,
+ /*forImplicitInterface=*/true)}) {
callee->dummyArguments.emplace_back(std::move(*dummy));
continue;
}
diff --git a/flang/lib/Evaluate/intrinsics.cpp b/flang/lib/Evaluate/intrinsics.cpp
index c711b4feaca4831..b08b9325f48be67 100644
--- a/flang/lib/Evaluate/intrinsics.cpp
+++ b/flang/lib/Evaluate/intrinsics.cpp
@@ -2324,8 +2324,8 @@ std::optional<SpecificCall> IntrinsicInterface::Match(
}
}
}
- if (auto dc{characteristics::DummyArgument::FromActual(
- std::move(kw), *expr, context)}) {
+ if (auto dc{characteristics::DummyArgument::FromActual(std::move(kw),
+ *expr, context, /*forImplicitInterface=*/false)}) {
dummyArgs.emplace_back(std::move(*dc));
if (d.typePattern.kindCode == KindCode::same && !sameDummyArg) {
sameDummyArg = j;
diff --git a/flang/lib/Lower/CallInterface.cpp b/flang/lib/Lower/CallInterface.cpp
index 43bbbb933658a8a..514e1d607c491cc 100644
--- a/flang/lib/Lower/CallInterface.cpp
+++ b/flang/lib/Lower/CallInterface.cpp
@@ -247,7 +247,8 @@ Fortran::lower::CallerInterface::characterize() const {
std::optional<Fortran::evaluate::characteristics::DummyArgument>
argCharacteristic =
Fortran::evaluate::characteristics::DummyArgument::FromActual(
- "actual", *expr, foldingContext);
+ "actual", *expr, foldingContext,
+ /*forImplicitInterface=*/true);
assert(argCharacteristic &&
"failed to characterize argument in implicit call");
characteristic->dummyArguments.emplace_back(
diff --git a/flang/lib/Semantics/check-call.cpp b/flang/lib/Semantics/check-call.cpp
index bf80dbecab009d9..8d0ba8a394757c0 100644
--- a/flang/lib/Semantics/check-call.cpp
+++ b/flang/lib/Semantics/check-call.cpp
@@ -38,14 +38,14 @@ static void CheckImplicitInterfaceArg(evaluate::ActualArgument &arg,
if (auto type{arg.GetType()}) {
if (type->IsAssumedType()) {
messages.Say(
- "Assumed type argument requires an explicit interface"_err_en_US);
- } else if (type->IsPolymorphic()) {
+ "Assumed type actual argument requires an explicit interface"_err_en_US);
+ } else if (type->IsUnlimitedPolymorphic()) {
messages.Say(
- "Polymorphic argument requires an explicit interface"_err_en_US);
+ "Unlimited polymorphic actual argument requires an explicit interface"_err_en_US);
} else if (const DerivedTypeSpec * derived{GetDerivedTypeSpec(type)}) {
if (!derived->parameters().empty()) {
messages.Say(
- "Parameterized derived type argument requires an explicit interface"_err_en_US);
+ "Parameterized derived type actual argument requires an explicit interface"_err_en_US);
}
}
}
@@ -76,7 +76,8 @@ static void CheckImplicitInterfaceArg(evaluate::ActualArgument &arg,
"VOLATILE argument requires an explicit interface"_err_en_US);
}
} else if (auto argChars{characteristics::DummyArgument::FromActual(
- "actual argument", *expr, context)}) {
+ "actual argument", *expr, context,
+ /*forImplicitInterface=*/true)}) {
const auto *argProcDesignator{
std::get_if<evaluate::ProcedureDesignator>(&expr->u)};
if (const auto *argProcSymbol{
@@ -913,7 +914,8 @@ static void CheckProcedureArg(evaluate::ActualArgument &arg,
}
}
if (auto argChars{characteristics::DummyArgument::FromActual(
- "actual argument", *expr, foldingContext)}) {
+ "actual argument", *expr, foldingContext,
+ /*forImplicitInterface=*/true)}) {
if (!argChars->IsTypelessIntrinsicDummy()) {
if (auto *argProc{
std::get_if<characteristics::DummyProcedure>(&argChars->u)}) {
diff --git a/flang/test/Semantics/call13.f90 b/flang/test/Semantics/call13.f90
index a5ef1ca34a66d16..8b203e4b715d50b 100644
--- a/flang/test/Semantics/call13.f90
+++ b/flang/test/Semantics/call13.f90
@@ -24,13 +24,12 @@ subroutine s(assumedRank, coarray, class, classStar, typeStar)
call implicit11(assumedRank) ! 15.4.2.2(3)(c)
!ERROR: Coarray argument requires an explicit interface
call implicit12(coarray) ! 15.4.2.2(3)(d)
- !ERROR: Parameterized derived type argument requires an explicit interface
+ !ERROR: Parameterized derived type actual argument requires an explicit interface
call implicit13(pdtx) ! 15.4.2.2(3)(e)
- !ERROR: Polymorphic argument requires an explicit interface
- call implicit14(class) ! 15.4.2.2(3)(f)
- !ERROR: Polymorphic argument requires an explicit interface
+ call implicit14(class) ! ok
+ !ERROR: Unlimited polymorphic actual argument requires an explicit interface
call implicit15(classStar) ! 15.4.2.2(3)(f)
- !ERROR: Assumed type argument requires an explicit interface
+ !ERROR: Assumed type actual argument requires an explicit interface
call implicit16(typeStar) ! 15.4.2.2(3)(f)
!ERROR: TYPE(*) dummy argument may only be used as an actual argument
if (typeStar) then
diff --git a/flang/test/Semantics/call40.f90 b/flang/test/Semantics/call40.f90
index 492fcdd1256af52..c248be6937e21b3 100644
--- a/flang/test/Semantics/call40.f90
+++ b/flang/test/Semantics/call40.f90
@@ -16,7 +16,7 @@ subroutine val_errors(array, string, polymorphic, derived)
!ERROR: %VAL argument must be a scalar numerical or logical expression
call foo3(%val(derived))
!ERROR: %VAL argument must be a scalar numerical or logical expression
- !ERROR: Assumed type argument requires an explicit interface
+ !ERROR: Assumed type actual argument requires an explicit interface
call foo4(%val(polymorphic))
end subroutine
diff --git a/flang/test/Semantics/label18.f90# b/flang/test/Semantics/label18.f90#
deleted file mode 100644
index 47b2a61dbc4b5dc..000000000000000
--- a/flang/test/Semantics/label18.f90#
+++ /dev/null
@@ -1,18 +0,0 @@
-! RUN: %python %S/test_errors.py %s %flang_fc1 -pedantic
-program main
- if (.true.) then
- do j = 1, 2
- goto 1 ! ok; used to cause looping in label resolution
- end do
- else
- goto 1 ! ok
-1 end if
- if (.true.) then
- do j = 1, 2
- !WARNING: Label '1' is in a construct that should not be used as a branch target here
- goto 1
- end do
- end if
- !WARNING: Label '1' is in a construct that should not be used as a branch target here
- goto 1
-end
More information about the flang-commits
mailing list