diff --git a/flang/include/flang/Evaluate/characteristics.h b/flang/include/flang/Evaluate/characteristics.h index d685d250bf20b..b07affc302622 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 FromActual( - std::string &&, const Expr &, FoldingContext &); - static std::optional FromActual( - std::string &&, const ActualArgument &, FoldingContext &); + static std::optional FromActual(std::string &&, + const Expr &, FoldingContext &, bool forImplicitInterface); + static std::optional 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 c600cea5c420c..16aa08603bdad 100644 --- a/flang/lib/Evaluate/characteristics.cpp +++ b/flang/lib/Evaluate/characteristics.cpp @@ -792,8 +792,9 @@ static std::optional CharacterizeDummyArgument( return std::nullopt; } -std::optional DummyArgument::FromActual( - std::string &&name, const Expr &expr, FoldingContext &context) { +std::optional DummyArgument::FromActual(std::string &&name, + const Expr &expr, FoldingContext &context, + bool forImplicitInterface) { return common::visit( common::visitors{ [&](const BOZLiteralConstant &) { @@ -828,6 +829,13 @@ std::optional 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( @@ -840,10 +848,11 @@ std::optional DummyArgument::FromActual( expr.u); } -std::optional DummyArgument::FromActual( - std::string &&name, const ActualArgument &arg, FoldingContext &context) { +std::optional 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::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 c711b4feaca48..b08b9325f48be 100644 --- a/flang/lib/Evaluate/intrinsics.cpp +++ b/flang/lib/Evaluate/intrinsics.cpp @@ -2324,8 +2324,8 @@ std::optional 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 43bbbb933658a..514e1d607c491 100644 --- a/flang/lib/Lower/CallInterface.cpp +++ b/flang/lib/Lower/CallInterface.cpp @@ -247,7 +247,8 @@ Fortran::lower::CallerInterface::characterize() const { std::optional 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 bf80dbecab009..8d0ba8a394757 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(&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(&argChars->u)}) { diff --git a/flang/test/Semantics/call13.f90 b/flang/test/Semantics/call13.f90 index a5ef1ca34a66d..8b203e4b715d5 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 492fcdd1256af..c248be6937e21 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 47b2a61dbc4b5..0000000000000 --- 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