Skip to content

Commit 29fd3e2

Browse files
klauslerklausler
authored
[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.)
1 parent c9626e6 commit 29fd3e2

File tree

8 files changed

+38
-44
lines changed

8 files changed

+38
-44
lines changed

‎flang/include/flang/Evaluate/characteristics.h

Lines changed: 4 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -273,10 +273,10 @@ struct DummyArgument {
273273
~DummyArgument();
274274
bool operator==(const DummyArgument &) const;
275275
bool operator!=(const DummyArgument &that) const { return !(*this == that); }
276-
static std::optional<DummyArgument> FromActual(
277-
std::string &&, const Expr<SomeType> &, FoldingContext &);
278-
static std::optional<DummyArgument> FromActual(
279-
std::string &&, const ActualArgument &, FoldingContext &);
276+
static std::optional<DummyArgument> FromActual(std::string &&,
277+
const Expr<SomeType> &, FoldingContext &, bool forImplicitInterface);
278+
static std::optional<DummyArgument> FromActual(std::string &&,
279+
const ActualArgument &, FoldingContext &, bool forImplicitInterface);
280280
bool IsOptional() const;
281281
void SetOptional(bool = true);
282282
common::Intent GetIntent() const;

‎flang/lib/Evaluate/characteristics.cpp

Lines changed: 17 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -792,8 +792,9 @@ static std::optional<DummyArgument> CharacterizeDummyArgument(
792792
return std::nullopt;
793793
}
794794

795-
std::optional<DummyArgument> DummyArgument::FromActual(
796-
std::string &&name, const Expr<SomeType> &expr, FoldingContext &context) {
795+
std::optional<DummyArgument> DummyArgument::FromActual(std::string &&name,
796+
const Expr<SomeType> &expr, FoldingContext &context,
797+
bool forImplicitInterface) {
797798
return common::visit(
798799
common::visitors{
799800
[&](const BOZLiteralConstant &) {
@@ -828,6 +829,13 @@ std::optional<DummyArgument> DummyArgument::FromActual(
828829
},
829830
[&](const auto &) {
830831
if (auto type{TypeAndShape::Characterize(expr, context)}) {
832+
if (forImplicitInterface &&
833+
!type->type().IsUnlimitedPolymorphic() &&
834+
type->type().IsPolymorphic()) {
835+
// Pass the monomorphic declared type to an implicit interface
836+
type->set_type(DynamicType{
837+
type->type().GetDerivedTypeSpec(), /*poly=*/false});
838+
}
831839
DummyDataObject obj{std::move(*type)};
832840
obj.attrs.set(DummyDataObject::Attr::DeducedFromActual);
833841
return std::make_optional<DummyArgument>(
@@ -840,10 +848,11 @@ std::optional<DummyArgument> DummyArgument::FromActual(
840848
expr.u);
841849
}
842850

843-
std::optional<DummyArgument> DummyArgument::FromActual(
844-
std::string &&name, const ActualArgument &arg, FoldingContext &context) {
851+
std::optional<DummyArgument> DummyArgument::FromActual(std::string &&name,
852+
const ActualArgument &arg, FoldingContext &context,
853+
bool forImplicitInterface) {
845854
if (const auto *expr{arg.UnwrapExpr()}) {
846-
return FromActual(std::move(name), *expr, context);
855+
return FromActual(std::move(name), *expr, context, forImplicitInterface);
847856
} else if (arg.GetAssumedTypeDummy()) {
848857
return std::nullopt;
849858
} else {
@@ -1325,8 +1334,9 @@ std::optional<Procedure> Procedure::FromActuals(const ProcedureDesignator &proc,
13251334
for (const auto &arg : args) {
13261335
++j;
13271336
if (arg) {
1328-
if (auto dummy{DummyArgument::FromActual(
1329-
"x"s + std::to_string(j), *arg, context)}) {
1337+
if (auto dummy{DummyArgument::FromActual("x"s + std::to_string(j),
1338+
*arg, context,
1339+
/*forImplicitInterface=*/true)}) {
13301340
callee->dummyArguments.emplace_back(std::move(*dummy));
13311341
continue;
13321342
}

‎flang/lib/Evaluate/intrinsics.cpp

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -2325,8 +2325,8 @@ std::optional<SpecificCall> IntrinsicInterface::Match(
23252325
}
23262326
}
23272327
}
2328-
if (auto dc{characteristics::DummyArgument::FromActual(
2329-
std::move(kw), *expr, context)}) {
2328+
if (auto dc{characteristics::DummyArgument::FromActual(std::move(kw),
2329+
*expr, context, /*forImplicitInterface=*/false)}) {
23302330
dummyArgs.emplace_back(std::move(*dc));
23312331
if (d.typePattern.kindCode == KindCode::same && !sameDummyArg) {
23322332
sameDummyArg = j;

‎flang/lib/Lower/CallInterface.cpp

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -247,7 +247,8 @@ Fortran::lower::CallerInterface::characterize() const {
247247
std::optional<Fortran::evaluate::characteristics::DummyArgument>
248248
argCharacteristic =
249249
Fortran::evaluate::characteristics::DummyArgument::FromActual(
250-
"actual", *expr, foldingContext);
250+
"actual", *expr, foldingContext,
251+
/*forImplicitInterface=*/true);
251252
assert(argCharacteristic &&
252253
"failed to characterize argument in implicit call");
253254
characteristic->dummyArguments.emplace_back(

‎flang/lib/Semantics/check-call.cpp

Lines changed: 8 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -38,14 +38,14 @@ static void CheckImplicitInterfaceArg(evaluate::ActualArgument &arg,
3838
if (auto type{arg.GetType()}) {
3939
if (type->IsAssumedType()) {
4040
messages.Say(
41-
"Assumed type argument requires an explicit interface"_err_en_US);
42-
} else if (type->IsPolymorphic()) {
41+
"Assumed type actual argument requires an explicit interface"_err_en_US);
42+
} else if (type->IsUnlimitedPolymorphic()) {
4343
messages.Say(
44-
"Polymorphic argument requires an explicit interface"_err_en_US);
44+
"Unlimited polymorphic actual argument requires an explicit interface"_err_en_US);
4545
} else if (const DerivedTypeSpec * derived{GetDerivedTypeSpec(type)}) {
4646
if (!derived->parameters().empty()) {
4747
messages.Say(
48-
"Parameterized derived type argument requires an explicit interface"_err_en_US);
48+
"Parameterized derived type actual argument requires an explicit interface"_err_en_US);
4949
}
5050
}
5151
}
@@ -76,7 +76,8 @@ static void CheckImplicitInterfaceArg(evaluate::ActualArgument &arg,
7676
"VOLATILE argument requires an explicit interface"_err_en_US);
7777
}
7878
} else if (auto argChars{characteristics::DummyArgument::FromActual(
79-
"actual argument", *expr, context)}) {
79+
"actual argument", *expr, context,
80+
/*forImplicitInterface=*/true)}) {
8081
const auto *argProcDesignator{
8182
std::get_if<evaluate::ProcedureDesignator>(&expr->u)};
8283
if (const auto *argProcSymbol{
@@ -913,7 +914,8 @@ static void CheckProcedureArg(evaluate::ActualArgument &arg,
913914
}
914915
}
915916
if (auto argChars{characteristics::DummyArgument::FromActual(
916-
"actual argument", *expr, foldingContext)}) {
917+
"actual argument", *expr, foldingContext,
918+
/*forImplicitInterface=*/true)}) {
917919
if (!argChars->IsTypelessIntrinsicDummy()) {
918920
if (auto *argProc{
919921
std::get_if<characteristics::DummyProcedure>(&argChars->u)}) {

‎flang/test/Semantics/call13.f90

Lines changed: 4 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -24,13 +24,12 @@ subroutine s(assumedRank, coarray, class, classStar, typeStar)
2424
call implicit11(assumedRank) ! 15.4.2.2(3)(c)
2525
!ERROR: Coarray argument requires an explicit interface
2626
call implicit12(coarray) ! 15.4.2.2(3)(d)
27-
!ERROR: Parameterized derived type argument requires an explicit interface
27+
!ERROR: Parameterized derived type actual argument requires an explicit interface
2828
call implicit13(pdtx) ! 15.4.2.2(3)(e)
29-
!ERROR: Polymorphic argument requires an explicit interface
30-
call implicit14(class) ! 15.4.2.2(3)(f)
31-
!ERROR: Polymorphic argument requires an explicit interface
29+
call implicit14(class) ! ok
30+
!ERROR: Unlimited polymorphic actual argument requires an explicit interface
3231
call implicit15(classStar) ! 15.4.2.2(3)(f)
33-
!ERROR: Assumed type argument requires an explicit interface
32+
!ERROR: Assumed type actual argument requires an explicit interface
3433
call implicit16(typeStar) ! 15.4.2.2(3)(f)
3534
!ERROR: TYPE(*) dummy argument may only be used as an actual argument
3635
if (typeStar) then

‎flang/test/Semantics/call40.f90

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -16,7 +16,7 @@ subroutine val_errors(array, string, polymorphic, derived)
1616
!ERROR: %VAL argument must be a scalar numerical or logical expression
1717
call foo3(%val(derived))
1818
!ERROR: %VAL argument must be a scalar numerical or logical expression
19-
!ERROR: Assumed type argument requires an explicit interface
19+
!ERROR: Assumed type actual argument requires an explicit interface
2020
call foo4(%val(polymorphic))
2121
end subroutine
2222

‎flang/test/Semantics/label18.f90#

Lines changed: 0 additions & 18 deletions
This file was deleted.

0 commit comments

Comments
 (0)