[flang] Support DATA statement initialization of numeric with Hollerith/CHARACTER

[klausler]

Summary

This is a common Fortran language extension.

flang/lib/Semantics/check-data.cpp

private:
   bool Scan(const parser::Designator &);
   bool Scan(const parser::DataImpliedDo &);
   bool Scan(const parser::DataIDoObject &);
 
   // Initializes all elements of a designator, which can be an array or section.
   bool InitDesignator(const SomeExpr &);
   // Initializes a single object.
   bool InitElement(const evaluate::OffsetSymbol &, const SomeExpr &designator);
+  // If the returned flag is true, emit a warning about CHARACTER misusage.
+  std::optional<std::pair<SomeExpr, bool>> ConvertElement(
+      const SomeExpr &, const evaluate::DynamicType &);
 
   DataInitializations &inits_;
   evaluate::ExpressionAnalyzer &exprAnalyzer_;
   ValueListIterator values_;
 };
 
 bool DataInitializationCompiler::Scan(const parser::DataStmtObject &object) {
   return std::visit(
if (folder.isOutOfRange()) {
       return false;
     } else {
       ++values_;
     }
   }
   return folder.isEmpty();
 }
 
+std::optional<std::pair<SomeExpr, bool>>
+DataInitializationCompiler::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::Type<TypeCategory::Character, 1>>(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
+    std::size_t bytes{type.MeasureSizeInBytes().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)};
+    }
+  }
+  return std::nullopt;
+}
+
 bool DataInitializationCompiler::InitElement(
     const evaluate::OffsetSymbol &offsetSymbol, const SomeExpr &designator) {
   const Symbol &symbol{offsetSymbol.symbol()};
   const Symbol *lastSymbol{GetLastSymbol(designator)};
   bool isPointer{lastSymbol && IsPointer(*lastSymbol)};
   bool isProcPointer{lastSymbol && IsProcedurePointer(*lastSymbol)};
   evaluate::FoldingContext &context{exprAnalyzer_.GetFoldingContext()};
 
if (!expr) {
     exprAnalyzer_.Say(values_.LocateSource(),
         "Initializer for '%s' must not be a pointer"_err_en_US,
         DescribeElement());
   } else if (evaluate::IsProcedure(*expr)) {
     exprAnalyzer_.Say(values_.LocateSource(),
         "Initializer for '%s' must not be a procedure"_err_en_US,
         DescribeElement());
   } else if (auto designatorType{designator.GetType()}) {
-    if (auto converted{
-            evaluate::ConvertToType(*designatorType, SomeExpr{*expr})}) {
+    if (auto converted{ConvertElement(*expr, *designatorType)}) {
       // value non-pointer initialization
       if (std::holds_alternative<evaluate::BOZLiteralConstant>(expr->u) &&
           designatorType->category() != TypeCategory::Integer) { // 8.6.7(11)
         exprAnalyzer_.Say(values_.LocateSource(),
             "BOZ literal should appear in a DATA statement only as a value for an integer object, but '%s' is '%s'"_en_US,
             DescribeElement(), designatorType->AsFortran());
+      } else if (converted->second) {
+        exprAnalyzer_.context().Say(
+            "DATA statement value initializes '%s' of type '%s' with CHARACTER"_en_US,
+            DescribeElement(), designatorType->AsFortran());
       }
-      auto folded{evaluate::Fold(context, std::move(*converted))};
+      auto folded{evaluate::Fold(context, std::move(converted->first))};
       switch (
           GetImage().Add(offsetSymbol.offset(), offsetSymbol.size(), folded)) {
       case evaluate::InitialImage::Ok:
         return true;
       case evaluate::InitialImage::NotAConstant:
         exprAnalyzer_.Say(values_.LocateSource(),
             "DATA statement value '%s' for '%s' is not a constant"_err_en_US,
             folded.AsFortran(), DescribeElement());

flang/test/Semantics/data06.f90

subroutine s1
   real, target :: rt
   !ERROR: Data object 'rt' may not be used to initialize 'rpp', which is a procedure pointer
   data rpp/rt/
   !ERROR: Initializer for 'rt' must not be a pointer
   data rt/null()/
   !ERROR: Initializer for 'rt' must not be a procedure
   data rt/rfunc/
   integer :: jx, jy
-  !ERROR: DATA statement value could not be converted to the type 'INTEGER(4)' of the object 'jx'
+  !WARNING: DATA statement value initializes 'jx' of type 'INTEGER(4)' with CHARACTER
   data jx/'abc'/
   !ERROR: DATA statement value could not be converted to the type 'INTEGER(4)' of the object 'jx'
   data jx/t1()/
   !ERROR: DATA statement value could not be converted to the type 'INTEGER(4)' of the object 'jx'
   data jx/.false./
   !ERROR: must be a constant
   data jx/jy/
 end subroutine

flang/test/Semantics/data08.f90

+! RUN: %f18 -fdebug-dump-symbols -fparse-only %s 2>&1 | FileCheck %s
+! CHECK: DATA statement value initializes 'jx' of type 'INTEGER(4)' with CHARACTER
+! CHECK: DATA statement value initializes 'jy' of type 'INTEGER(4)' with CHARACTER
+! CHECK: DATA statement value initializes 'jz' of type 'INTEGER(4)' with CHARACTER
+! CHECK: DATA statement value initializes 'kx' of type 'INTEGER(8)' with CHARACTER
+! CHECK: jx (InDataStmt) size=4 offset=0: ObjectEntity type: INTEGER(4) init:1684234849_4
+! CHECK: jy (InDataStmt) size=4 offset=4: ObjectEntity type: INTEGER(4) init:543384161_4
+! CHECK: jz (InDataStmt) size=4 offset=8: ObjectEntity type: INTEGER(4) init:1684234849_4
+! CHECK: kx (InDataStmt) size=8 offset=16: ObjectEntity type: INTEGER(8) init:7523094288207667809_8
+
+integer :: jx, jy, jz
+integer(8) :: kx
+data jx/4habcd/
+data jy/3habc/
+data jz/5habcde/
+data kx/'abcdefgh'/
+end