diff --git a/flang/docs/Extensions.md b/flang/docs/Extensions.md index 70c310151256..aa60800246ba 100644 --- a/flang/docs/Extensions.md +++ b/flang/docs/Extensions.md @@ -131,8 +131,11 @@ end that can hold them, if one exists. * BOZ literals can be used as INTEGER values in contexts where the type is unambiguous: the right hand sides of assigments and initializations - of INTEGER entities, and as actual arguments to a few intrinsic functions - (ACHAR, BTEST, CHAR). BOZ literals are interpreted as default INTEGER + of INTEGER entities, as actual arguments to a few intrinsic functions + (ACHAR, BTEST, CHAR), and as actual arguments of references to + procedures with explicit interfaces whose corresponding dummy + argument has a numeric type to which the BOZ literal may be + converted. BOZ literals are interpreted as default INTEGER only when they appear as the first items of array constructors with no explicit type. Otherwise, they generally cannot be used if the type would not be known (e.g., `IAND(X'1',X'2')`). diff --git a/flang/lib/Evaluate/intrinsics.cpp b/flang/lib/Evaluate/intrinsics.cpp index a29d6865c2aa..52741ec63338 100644 --- a/flang/lib/Evaluate/intrinsics.cpp +++ b/flang/lib/Evaluate/intrinsics.cpp @@ -1347,10 +1347,17 @@ std::optional IntrinsicInterface::Match( d.rank == Rank::elementalOrBOZ) { continue; } else { - const IntrinsicDummyArgument &nextParam{dummy[j + 1]}; - messages.Say( - "Typeless (BOZ) not allowed for both '%s=' & '%s=' arguments"_err_en_US, // C7109 - d.keyword, nextParam.keyword); + const IntrinsicDummyArgument *nextParam{ + j + 1 < dummies ? &dummy[j + 1] : nullptr}; + if (nextParam && nextParam->rank == Rank::elementalOrBOZ) { + messages.Say( + "Typeless (BOZ) not allowed for both '%s=' & '%s=' arguments"_err_en_US, // C7109 + d.keyword, nextParam->keyword); + } else { + messages.Say( + "Typeless (BOZ) not allowed for '%s=' argument"_err_en_US, + d.keyword); + } } } else { // NULL(), procedure, or procedure pointer diff --git a/flang/lib/Evaluate/tools.cpp b/flang/lib/Evaluate/tools.cpp index 34a3b5dd7fca..707da891fd5a 100644 --- a/flang/lib/Evaluate/tools.cpp +++ b/flang/lib/Evaluate/tools.cpp @@ -607,6 +607,9 @@ std::optional> ConvertToNumeric(int kind, Expr &&x) { std::optional> ConvertToType( const DynamicType &type, Expr &&x) { + if (type.IsTypelessIntrinsicArgument()) { + return std::nullopt; + } switch (type.category()) { case TypeCategory::Integer: if (auto *boz{std::get_if(&x.u)}) { diff --git a/flang/lib/Semantics/check-call.cpp b/flang/lib/Semantics/check-call.cpp index ba2b47fbb769..18a1cc3259df 100644 --- a/flang/lib/Semantics/check-call.cpp +++ b/flang/lib/Semantics/check-call.cpp @@ -635,6 +635,19 @@ static void CheckProcedureArg(evaluate::ActualArgument &arg, } } +// Allow BOZ literal actual arguments when they can be converted to a known +// dummy argument type +static void ConvertBOZLiteralArg( + evaluate::ActualArgument &arg, const evaluate::DynamicType &type) { + if (auto *expr{arg.UnwrapExpr()}) { + if (IsBOZLiteral(*expr)) { + if (auto converted{evaluate::ConvertToType(type, SomeExpr{*expr})}) { + arg = std::move(*converted); + } + } + } +} + static void CheckExplicitInterfaceArg(evaluate::ActualArgument &arg, const characteristics::DummyArgument &dummy, const characteristics::Procedure &proc, evaluate::FoldingContext &context, @@ -648,6 +661,7 @@ static void CheckExplicitInterfaceArg(evaluate::ActualArgument &arg, std::visit( common::visitors{ [&](const characteristics::DummyDataObject &object) { + ConvertBOZLiteralArg(arg, object.type.type()); if (auto *expr{arg.UnwrapExpr()}) { if (auto type{characteristics::TypeAndShape::Characterize( *expr, context)}) { @@ -843,24 +857,35 @@ void CheckArguments(const characteristics::Procedure &proc, const Scope &scope, bool treatingExternalAsImplicit, const evaluate::SpecificIntrinsic *intrinsic) { bool explicitInterface{proc.HasExplicitInterface()}; + parser::ContextualMessages &messages{context.messages()}; + if (!explicitInterface || treatingExternalAsImplicit) { + parser::Messages buffer; + { + auto restorer{messages.SetMessages(buffer)}; + for (auto &actual : actuals) { + if (actual) { + CheckImplicitInterfaceArg(*actual, messages); + } + } + } + if (!buffer.empty()) { + if (auto *msgs{messages.messages()}) { + msgs->Annex(std::move(buffer)); + } + return; // don't pile on + } + } if (explicitInterface) { auto buffer{ CheckExplicitInterface(proc, actuals, context, scope, intrinsic)}; if (treatingExternalAsImplicit && !buffer.empty()) { - if (auto *msg{context.messages().Say( + if (auto *msg{messages.Say( "Warning: if the procedure's interface were explicit, this reference would be in error:"_en_US)}) { buffer.AttachTo(*msg); } } - if (auto *msgs{context.messages().messages()}) { - msgs->Merge(std::move(buffer)); - } - } - if (!explicitInterface || treatingExternalAsImplicit) { - for (auto &actual : actuals) { - if (actual) { - CheckImplicitInterfaceArg(*actual, context.messages()); - } + if (auto *msgs{messages.messages()}) { + msgs->Annex(std::move(buffer)); } } } diff --git a/flang/test/Semantics/boz-literal-constants.f90 b/flang/test/Semantics/boz-literal-constants.f90 index a0db6faddea9..ca1676a69646 100644 --- a/flang/test/Semantics/boz-literal-constants.f90 +++ b/flang/test/Semantics/boz-literal-constants.f90 @@ -8,6 +8,13 @@ subroutine bozchecks logical :: resbit complex :: rescmplx real :: dbl, e + interface + subroutine explicit(n, x, c) + integer :: n + real :: x + character :: c + end subroutine + end interface ! C7107 !ERROR: Invalid digit ('a') in BOZ literal 'b"110a"' integer, parameter :: a = B"110A" @@ -75,8 +82,17 @@ subroutine bozchecks res = MERGE_BITS(B"1101",B"0011",B"1011") res = MERGE_BITS(B"1101",3,B"1011") + !ERROR: Typeless (BOZ) not allowed for 'x=' argument + res = KIND(z'feedface') + res = REAL(B"1101") + !Ok + call explicit(z'deadbeef', o'666', 'a') + + !ERROR: Actual argument 'z'55'' associated with dummy argument 'c=' is not a variable or typed expression + call explicit(z'deadbeef', o'666', b'01010101') + !ERROR: BOZ argument requires an explicit interface call implictSub(Z'12345')