diff --git a/flang/include/flang/Evaluate/tools.h b/flang/include/flang/Evaluate/tools.h --- a/flang/include/flang/Evaluate/tools.h +++ b/flang/include/flang/Evaluate/tools.h @@ -1076,6 +1076,11 @@ std::optional> DataConstantConversionExtension( FoldingContext &, const DynamicType &, const Expr &); +// Convert Hollerith or short character to a another type as if the +// Hollerith data had been BOZ. +std::optional> HollerithToBOZ( + FoldingContext &, const Expr &, const DynamicType &); + } // namespace Fortran::evaluate namespace Fortran::semantics { diff --git a/flang/lib/Evaluate/tools.cpp b/flang/lib/Evaluate/tools.cpp --- a/flang/lib/Evaluate/tools.cpp +++ b/flang/lib/Evaluate/tools.cpp @@ -1125,6 +1125,25 @@ IsAllocatableOrPointerObject(expr, context); } +std::optional> HollerithToBOZ(FoldingContext &context, + const Expr &expr, const DynamicType &type) { + if (std::optional chValue{GetScalarConstantValue(expr)}) { + // Pad on the right with spaces when short, truncate the right if long. + // TODO: big-endian targets + auto bytes{static_cast( + ToInt64(type.MeasureSizeInBytes(context, false)).value())}; + BOZLiteralConstant bits{0}; + for (std::size_t j{0}; j < bytes; ++j) { + char ch{j >= chValue->size() ? ' ' : chValue->at(j)}; + BOZLiteralConstant chBOZ{static_cast(ch)}; + bits = bits.IOR(chBOZ.SHIFTL(8 * j)); + } + return ConvertToType(type, Expr{bits}); + } else { + return std::nullopt; + } +} + } // namespace Fortran::evaluate namespace Fortran::semantics { diff --git a/flang/lib/Semantics/check-call.h b/flang/lib/Semantics/check-call.h --- a/flang/lib/Semantics/check-call.h +++ b/flang/lib/Semantics/check-call.h @@ -46,6 +46,6 @@ // Checks actual arguments for the purpose of resolving a generic interface. bool CheckInterfaceForGeneric(const evaluate::characteristics::Procedure &, evaluate::ActualArguments &, const evaluate::FoldingContext &, - bool allowIntegerConversions = false); + bool allowActualArgumentConversions = false); } // namespace Fortran::semantics #endif diff --git a/flang/lib/Semantics/check-call.cpp b/flang/lib/Semantics/check-call.cpp --- a/flang/lib/Semantics/check-call.cpp +++ b/flang/lib/Semantics/check-call.cpp @@ -167,15 +167,27 @@ characteristics::TypeAndShape &actualType, bool isElemental, evaluate::FoldingContext &context, const Scope *scope, const evaluate::SpecificIntrinsic *intrinsic, - bool allowIntegerConversions) { + bool allowActualArgumentConversions) { // Basic type & rank checking parser::ContextualMessages &messages{context.messages()}; CheckCharacterActual(actual, dummy.type, actualType, context, messages); - if (allowIntegerConversions) { + if (allowActualArgumentConversions) { ConvertIntegerActual(actual, dummy.type, actualType, messages); } bool typesCompatible{dummy.type.type().IsTkCompatibleWith(actualType.type())}; + if (!typesCompatible && dummy.type.Rank() == 0 && + allowActualArgumentConversions) { + // Extension: pass Hollerith literal to scalar as if it had been BOZ + if (auto converted{ + evaluate::HollerithToBOZ(context, actual, dummy.type.type())}) { + messages.Say( + "passing Hollerith or character literal as if it were BOZ"_port_en_US); + actual = *converted; + actualType.type() = dummy.type.type(); + typesCompatible = true; + } + } if (typesCompatible) { if (isElemental) { } else if (dummy.type.attrs().test( @@ -683,7 +695,7 @@ const characteristics::DummyArgument &dummy, const characteristics::Procedure &proc, evaluate::FoldingContext &context, const Scope *scope, const evaluate::SpecificIntrinsic *intrinsic, - bool allowIntegerConversions) { + bool allowActualArgumentConversions) { auto &messages{context.messages()}; std::string dummyName{"dummy argument"}; if (!dummy.name.empty()) { @@ -714,7 +726,7 @@ object.type.Rank() == 0 && proc.IsElemental()}; CheckExplicitDataArg(object, dummyName, *expr, *type, isElemental, context, scope, intrinsic, - allowIntegerConversions); + allowActualArgumentConversions); } else if (object.type.type().IsTypelessIntrinsicArgument() && IsBOZLiteral(*expr)) { // ok @@ -867,7 +879,7 @@ const characteristics::Procedure &proc, evaluate::ActualArguments &actuals, const evaluate::FoldingContext &context, const Scope *scope, const evaluate::SpecificIntrinsic *intrinsic, - bool allowIntegerConversions) { + bool allowActualArgumentConversions) { parser::Messages buffer; parser::ContextualMessages messages{context.messages().at(), &buffer}; RearrangeArguments(proc, actuals, messages); @@ -878,7 +890,7 @@ const auto &dummy{proc.dummyArguments.at(index++)}; if (actual) { CheckExplicitInterfaceArg(*actual, dummy, proc, localContext, scope, - intrinsic, allowIntegerConversions); + intrinsic, allowActualArgumentConversions); } else if (!dummy.IsOptional()) { if (dummy.name.empty()) { messages.Say( @@ -909,9 +921,9 @@ bool CheckInterfaceForGeneric(const characteristics::Procedure &proc, evaluate::ActualArguments &actuals, const evaluate::FoldingContext &context, - bool allowIntegerConversions) { + bool allowActualArgumentConversions) { return !CheckExplicitInterface( - proc, actuals, context, nullptr, nullptr, allowIntegerConversions) + proc, actuals, context, nullptr, nullptr, allowActualArgumentConversions) .AnyFatalError(); } diff --git a/flang/lib/Semantics/data-to-inits.cpp b/flang/lib/Semantics/data-to-inits.cpp --- a/flang/lib/Semantics/data-to-inits.cpp +++ b/flang/lib/Semantics/data-to-inits.cpp @@ -274,24 +274,11 @@ if (auto converted{evaluate::ConvertToType(type, SomeExpr{expr})}) { return {std::make_pair(std::move(*converted), false)}; } - if (std::optional chValue{ - evaluate::GetScalarConstantValue(expr)}) { - // Allow DATA initialization with Hollerith and kind=1 CHARACTER like - // (most) other Fortran compilers do. Pad on the right with spaces - // when short, truncate the right if long. - // TODO: big-endian targets - auto bytes{static_cast(evaluate::ToInt64( - type.MeasureSizeInBytes(exprAnalyzer_.GetFoldingContext(), false)) - .value())}; - evaluate::BOZLiteralConstant bits{0}; - for (std::size_t j{0}; j < bytes; ++j) { - char ch{j >= chValue->size() ? ' ' : chValue->at(j)}; - evaluate::BOZLiteralConstant chBOZ{static_cast(ch)}; - bits = bits.IOR(chBOZ.SHIFTL(8 * j)); - } - if (auto converted{evaluate::ConvertToType(type, SomeExpr{bits})}) { - return {std::make_pair(std::move(*converted), true)}; - } + // Allow DATA initialization with Hollerith and kind=1 CHARACTER like + // (most) other Fortran compilers do. + if (auto converted{evaluate::HollerithToBOZ( + exprAnalyzer_.GetFoldingContext(), expr, type)}) { + return {std::make_pair(std::move(*converted), true)}; } SemanticsContext &context{exprAnalyzer_.context()}; if (context.IsEnabled(common::LanguageFeature::LogicalIntegerAssignment)) {