diff --git a/flang/include/flang/Parser/parse-tree.h b/flang/include/flang/Parser/parse-tree.h index 0a40aa8b8f616..6749e2093719d 100644 --- a/flang/include/flang/Parser/parse-tree.h +++ b/flang/include/flang/Parser/parse-tree.h @@ -3194,7 +3194,7 @@ WRAPPER_CLASS(AltReturnSpec, Label); // expr | variable | procedure-name | proc-component-ref | // alt-return-spec struct ActualArg { - WRAPPER_CLASS(PercentRef, Variable); // %REF(v) extension + WRAPPER_CLASS(PercentRef, Expr); // %REF(x) extension WRAPPER_CLASS(PercentVal, Expr); // %VAL(x) extension UNION_CLASS_BOILERPLATE(ActualArg); ActualArg(Expr &&x) : u{common::Indirection(std::move(x))} {} diff --git a/flang/lib/Parser/program-parsers.cpp b/flang/lib/Parser/program-parsers.cpp index ff5e58ebc721c..6f25ba4827220 100644 --- a/flang/lib/Parser/program-parsers.cpp +++ b/flang/lib/Parser/program-parsers.cpp @@ -472,8 +472,8 @@ TYPE_PARSER(construct(expr) || construct(Parser{}) || extension( "nonstandard usage: %REF"_port_en_US, - construct(construct( - "%REF" >> parenthesized(variable)))) || + construct( + construct("%REF" >> parenthesized(expr)))) || extension( "nonstandard usage: %VAL"_port_en_US, construct( diff --git a/flang/lib/Semantics/check-call.cpp b/flang/lib/Semantics/check-call.cpp index 48c888c0dfb26..9af2e37bb256d 100644 --- a/flang/lib/Semantics/check-call.cpp +++ b/flang/lib/Semantics/check-call.cpp @@ -35,7 +35,8 @@ static void CheckImplicitInterfaceArg(evaluate::ActualArgument &arg, "Keyword '%s=' may not appear in a reference to a procedure with an implicit interface"_err_en_US, *kw); } - if (auto type{arg.GetType()}) { + auto type{arg.GetType()}; + if (type) { if (type->IsAssumedType()) { messages.Say( "Assumed type actual argument requires an explicit interface"_err_en_US); @@ -49,6 +50,11 @@ static void CheckImplicitInterfaceArg(evaluate::ActualArgument &arg, } } } + if (arg.isPercentVal() && + (!type || !type->IsLengthlessIntrinsicType() || arg.Rank() != 0)) { + messages.Say( + "%VAL argument must be a scalar numeric or logical expression"_err_en_US); + } if (const auto *expr{arg.UnwrapExpr()}) { if (IsBOZLiteral(*expr)) { messages.Say("BOZ argument requires an explicit interface"_err_en_US); @@ -314,7 +320,8 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy, SemanticsContext &context, evaluate::FoldingContext &foldingContext, const Scope *scope, const evaluate::SpecificIntrinsic *intrinsic, bool allowActualArgumentConversions, bool extentErrors, - const characteristics::Procedure &procedure) { + const characteristics::Procedure &procedure, + const evaluate::ActualArgument &arg) { // Basic type & rank checking parser::ContextualMessages &messages{foldingContext.messages()}; @@ -939,11 +946,25 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy, } } - // Breaking change warnings + // Warning for breaking F'2023 change with character allocatables if (intrinsic && dummy.intent != common::Intent::In) { WarnOnDeferredLengthCharacterScalar( context, &actual, messages.at(), dummyName.c_str()); } + + // %VAL() and %REF() checking for explicit interface + if ((arg.isPercentRef() || arg.isPercentVal()) && + dummy.IsPassedByDescriptor(procedure.IsBindC())) { + messages.Say( + "%VAL or %REF are not allowed for %s that must be passed by means of a descriptor"_err_en_US, + dummyName); + } + if (arg.isPercentVal() && + (!actualType.type().IsLengthlessIntrinsicType() || + actualType.Rank() != 0)) { + messages.Say( + "%VAL argument must be a scalar numeric or logical expression"_err_en_US); + } } static void CheckProcedureArg(evaluate::ActualArgument &arg, @@ -1152,7 +1173,7 @@ static void CheckExplicitInterfaceArg(evaluate::ActualArgument &arg, object.type.Rank() == 0 && proc.IsElemental()}; CheckExplicitDataArg(object, dummyName, *expr, *type, isElemental, context, foldingContext, scope, intrinsic, - allowActualArgumentConversions, extentErrors, proc); + allowActualArgumentConversions, extentErrors, proc, arg); } else if (object.type.type().IsTypelessIntrinsicArgument() && IsBOZLiteral(*expr)) { // ok diff --git a/flang/lib/Semantics/expression.cpp b/flang/lib/Semantics/expression.cpp index 50e2b41212d7d..e42a8df1c3dc5 100644 --- a/flang/lib/Semantics/expression.cpp +++ b/flang/lib/Semantics/expression.cpp @@ -4187,13 +4187,13 @@ void ArgumentAnalyzer::Analyze( }, [&](const parser::AltReturnSpec &label) { if (!isSubroutine) { - context_.Say("alternate return specification may not appear on" - " function reference"_err_en_US); + context_.Say( + "alternate return specification may not appear on function reference"_err_en_US); } actual = ActualArgument(label.v); }, [&](const parser::ActualArg::PercentRef &percentRef) { - actual = AnalyzeVariable(percentRef.v); + actual = AnalyzeExpr(percentRef.v); if (actual.has_value()) { actual->set_isPercentRef(); } @@ -4202,12 +4202,6 @@ void ArgumentAnalyzer::Analyze( actual = AnalyzeExpr(percentVal.v); if (actual.has_value()) { actual->set_isPercentVal(); - std::optional type{actual->GetType()}; - if (!type || !type->IsLengthlessIntrinsicType() || - actual->Rank() != 0) { - context_.SayAt(percentVal.v, - "%VAL argument must be a scalar numerical or logical expression"_err_en_US); - } } }, }, diff --git a/flang/test/Semantics/call40.f90 b/flang/test/Semantics/call40.f90 index c248be6937e21..e240b5a432184 100644 --- a/flang/test/Semantics/call40.f90 +++ b/flang/test/Semantics/call40.f90 @@ -9,15 +9,22 @@ subroutine val_errors(array, string, polymorphic, derived) character(*) :: string type(t) :: derived type(*) :: polymorphic - !ERROR: %VAL argument must be a scalar numerical or logical expression + interface + subroutine foo5(a) + integer a(:) + end + end interface + !ERROR: %VAL argument must be a scalar numeric or logical expression call foo1(%val(array)) - !ERROR: %VAL argument must be a scalar numerical or logical expression + !ERROR: %VAL argument must be a scalar numeric or logical expression call foo2(%val(string)) - !ERROR: %VAL argument must be a scalar numerical or logical expression + !ERROR: %VAL argument must be a scalar numeric or logical expression call foo3(%val(derived)) - !ERROR: %VAL argument must be a scalar numerical or logical expression !ERROR: Assumed type actual argument requires an explicit interface + !ERROR: %VAL argument must be a scalar numeric or logical expression call foo4(%val(polymorphic)) + !ERROR: %VAL or %REF are not allowed for dummy argument 'a=' that must be passed by means of a descriptor + call foo5(%ref(array)) end subroutine subroutine val_ok()