[flang] Extension: Accept Hollerith actual arguments as if they were BOZ

[klausler]

Summary

When a Hollerith (or short character) literal is presented as an actual
argument that corresponds to a dummy argument for which a BOZ literal
would be acceptable, treat the Hollerith as if it had been a BOZ
literal in the same way -- and with the same code -- as f18 already
does for the similar extension in DATA statements.

flang/include/flang/Evaluate/tools.h

Constant<T> PackageConstant(std::vector<Scalar<T>> &&elements,
   }
 }
 
 // Nonstandard conversions of constants (integer->logical, logical->integer)
 // that can appear in DATA statements as an extension.
 std::optional<Expr<SomeType>> DataConstantConversionExtension(
     FoldingContext &, const DynamicType &, const Expr<SomeType> &);
 
+// Convert Hollerith or short character to a another type as if the
+// Hollerith data had been BOZ.
+std::optional<Expr<SomeType>> HollerithToBOZ(
+    FoldingContext &, const Expr<SomeType> &, const DynamicType &);
+
 } // namespace Fortran::evaluate
 
 namespace Fortran::semantics {
 
 class Scope;
 
 // If a symbol represents an ENTRY, return the symbol of the main entry
 // point to its subprogram.

flang/lib/Evaluate/tools.cpp

bool MayBePassedAsAbsentOptional(
   // 15.5.2.12 1. is pretty clear that an unallocated allocatable/pointer actual
   // may be passed to a non-allocatable/non-pointer optional dummy. Note that
   // other compilers (like nag, nvfortran, ifort, gfortran and xlf) seems to
   // ignore this point in intrinsic contexts (e.g CMPLX argument).
   return (sym && semantics::IsOptional(*sym)) ||
       IsAllocatableOrPointerObject(expr, context);
 }
 
+std::optional<Expr<SomeType>> HollerithToBOZ(FoldingContext &context,
+    const Expr<SomeType> &expr, const DynamicType &type) {
+  if (std::optional<std::string> chValue{GetScalarConstantValue<Ascii>(expr)}) {
+    // Pad on the right with spaces when short, truncate the right if long.
+    // TODO: big-endian targets
+    auto bytes{static_cast<std::size_t>(
+        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<unsigned char>(ch)};
+      bits = bits.IOR(chBOZ.SHIFTL(8 * j));
+    }
+    return ConvertToType(type, Expr<SomeType>{bits});
+  } else {
+    return std::nullopt;
+  }
+}
+
 } // namespace Fortran::evaluate
 
 namespace Fortran::semantics {
 
 const Symbol &ResolveAssociations(const Symbol &original) {
   const Symbol &symbol{original.GetUltimate()};
   if (const auto *details{symbol.detailsIf<AssocEntityDetails>()}) {
     if (const Symbol * nested{UnwrapWholeSymbolDataRef(details->expr())}) {

flang/lib/Semantics/check-call.h

 parser::Messages CheckExplicitInterface(
     const evaluate::characteristics::Procedure &, evaluate::ActualArguments &,
     const evaluate::FoldingContext &, const Scope &,
     const evaluate::SpecificIntrinsic *intrinsic);
 
 // 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

flang/lib/Semantics/check-call.cpp

static bool DefersSameTypeParameters(
   return true;
 }
 
 static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
     const std::string &dummyName, evaluate::Expr<evaluate::SomeType> &actual,
     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(
                    characteristics::TypeAndShape::Attr::AssumedRank)) {
     } else if (!dummy.type.attrs().test(
                    characteristics::TypeAndShape::Attr::AssumedShape) &&
         !dummy.type.attrs().test(
             characteristics::TypeAndShape::Attr::DeferredShape) &&
if (auto *expr{arg.UnwrapExpr()}) {
     }
   }
 }
 
 static void CheckExplicitInterfaceArg(evaluate::ActualArgument &arg,
     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()) {
     dummyName += " '"s + parser::ToLowerCaseLetters(dummy.name) + "='";
   }
   auto restorer{
       messages.SetLocation(arg.sourceLocation().value_or(messages.at()))};
   auto checkActualArgForLabel = [&](evaluate::ActualArgument &arg) {
common::visit(
               if (auto *expr{arg.UnwrapExpr()}) {
                 if (auto type{characteristics::TypeAndShape::Characterize(
                         *expr, context)}) {
                   arg.set_dummyIntent(object.intent);
                   bool isElemental{
                       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
                 } else if (object.type.type().IsTypelessIntrinsicArgument() &&
                     evaluate::IsNullPointer(*expr)) {
                   // ok, ASSOCIATED(NULL())
                 } else if ((object.attrs.test(characteristics::DummyDataObject::
                                     Attr::Pointer) ||
static bool CheckElementalConformance(parser::ContextualMessages &messages,
   }
   return true;
 }
 
 static parser::Messages CheckExplicitInterface(
     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);
   if (buffer.empty()) {
     int index{0};
     evaluate::FoldingContext localContext{context, messages};
     for (auto &actual : actuals) {
       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(
               "Dummy argument #%d is not OPTIONAL and is not associated with "
               "an actual argument in this procedure reference"_err_en_US,
               index);
         } else {
           messages.Say("Dummy argument '%s=' (#%d) is not OPTIONAL and is not "
parser::Messages CheckExplicitInterface(const characteristics::Procedure &proc,
     evaluate::ActualArguments &actuals, const evaluate::FoldingContext &context,
     const Scope &scope, const evaluate::SpecificIntrinsic *intrinsic) {
   return CheckExplicitInterface(
       proc, actuals, context, &scope, intrinsic, true);
 }
 
 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();
 }
 
 void CheckArguments(const characteristics::Procedure &proc,
     evaluate::ActualArguments &actuals, evaluate::FoldingContext &context,
     const Scope &scope, bool treatingExternalAsImplicit,
     const evaluate::SpecificIntrinsic *intrinsic) {
   bool explicitInterface{proc.HasExplicitInterface()};

flang/lib/Semantics/data-to-inits.cpp

 
 template <typename DSV>
 std::optional<std::pair<SomeExpr, bool>>
 DataInitializationCompiler<DSV>::ConvertElement(
     const SomeExpr &expr, const evaluate::DynamicType &type) {
   if (auto converted{evaluate::ConvertToType(type, SomeExpr{expr})}) {
     return {std::make_pair(std::move(*converted), false)};
   }
-  if (std::optional<std::string> chValue{
-          evaluate::GetScalarConstantValue<evaluate::Ascii>(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<std::size_t>(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<unsigned char>(ch)};
-      bits = bits.IOR(chBOZ.SHIFTL(8 * j));
-    }
-    if (auto converted{evaluate::ConvertToType(type, SomeExpr{bits})}) {
-      return {std::make_pair(std::move(*converted), true)};
-    }
-  }
+  // (most) other Fortran compilers do.
+  if (auto converted{evaluate::HollerithToBOZ(
+          exprAnalyzer_.GetFoldingContext(), expr, type)}) {
   SemanticsContext &context{exprAnalyzer_.context()};
   if (context.IsEnabled(common::LanguageFeature::LogicalIntegerAssignment)) {
     if (MaybeExpr converted{evaluate::DataConstantConversionExtension(
             exprAnalyzer_.GetFoldingContext(), type, expr)}) {
       if (context.ShouldWarn(
               common::LanguageFeature::LogicalIntegerAssignment)) {
         context.Say(
             "nonstandard usage: initialization of %s with %s"_port_en_US,