[flang-commits] [flang] 29fd3e2 - [flang] Allow polymorphic actual to implicit interface (#70873)
via flang-commits
flang-commits at lists.llvm.org
Mon Nov 13 13:32:02 PST 2023
Author: Peter Klausler
Date: 2023-11-13T13:31:58-08:00
New Revision: 29fd3e2aa8ea09264037c278648c9033250843e0
URL: https://github.com/llvm/llvm-project/commit/29fd3e2aa8ea09264037c278648c9033250843e0
DIFF: https://github.com/llvm/llvm-project/commit/29fd3e2aa8ea09264037c278648c9033250843e0.diff
LOG: [flang] Allow polymorphic actual to implicit interface (#70873)
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.)
Added:
Modified:
flang/include/flang/Evaluate/characteristics.h
flang/lib/Evaluate/characteristics.cpp
flang/lib/Evaluate/intrinsics.cpp
flang/lib/Lower/CallInterface.cpp
flang/lib/Semantics/check-call.cpp
flang/test/Semantics/call13.f90
flang/test/Semantics/call40.f90
Removed:
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 9e78a1b0f4f5b59..9eb01df5b592fdc 100644
--- a/flang/lib/Evaluate/intrinsics.cpp
+++ b/flang/lib/Evaluate/intrinsics.cpp
@@ -2325,8 +2325,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 4df203e6d31e276..51b0579fac36c0f 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