[flang] Fold TRANSFER()

[klausler]

Summary

Fold usage of the raw data reinterpretation intrinsic function TRANSFER().

flang/include/flang/Evaluate/constant.h

public:
   // Apply subscripts, if any.
   Scalar<Result> At(const ConstantSubscripts &) const;
 
   // Extract substring(s); returns nullopt for errors.
   std::optional<Constant> Substring(ConstantSubscript, ConstantSubscript) const;
 
   Constant Reshape(ConstantSubscripts &&) const;
   llvm::raw_ostream &AsFortran(llvm::raw_ostream &) const;
-  static constexpr DynamicType GetType() {
-    return {TypeCategory::Character, KIND};
-  }
+  DynamicType GetType() const { return {KIND, length_}; }
   std::size_t CopyFrom(const Constant &source, std::size_t count,
       ConstantSubscripts &resultSubscripts, const std::vector<int> *dimOrder);
 
 private:
   Scalar<Result> values_; // one contiguous string
   ConstantSubscript length_;
 };
 

flang/include/flang/Evaluate/initial-image.h

if (offset < 0 || offset + bytes > data_.size()) {
       auto elementBytes{ToInt64(x.GetType().MeasureSizeInBytes(context, true))};
       if (!elementBytes ||
           bytes !=
               x.values().size() * static_cast<std::size_t>(*elementBytes)) {
         return SizeMismatch;
       } else if (bytes == 0) {
         return Ok;
       } else {
+        // TODO endianness
         std::memcpy(&data_.at(offset), &x.values().at(0), bytes);
         return Ok;
       }
     }
   }
   template <int KIND>
   Result Add(ConstantSubscript offset, std::size_t bytes,
       const Constant<Type<TypeCategory::Character, KIND>> &x,
if (offset < 0 || offset + bytes > data_.size()) {
           auto scalar{x.At(at)}; // this is a std string; size() in chars
           // Subtle: an initializer for a substring may have been
           // expanded to the length of the entire string.
           auto scalarBytes{scalar.size() * KIND};
           if (scalarBytes < elementBytes ||
               (scalarBytes > elementBytes && elements != 0)) {
             return SizeMismatch;
           }
+          // TODO endianness
           std::memcpy(&data_.at(offset), scalar.data(), elementBytes);
           offset += elementBytes;
         }
         return Ok;
       }
     }
   }
   Result Add(ConstantSubscript, std::size_t, const Constant<SomeDerived> &,
       FoldingContext &);
   template <typename T>
   Result Add(ConstantSubscript offset, std::size_t bytes, const Expr<T> &x,
       FoldingContext &c) {
     return common::visit(
         [&](const auto &y) { return Add(offset, bytes, y, c); }, x.u);
   }
 
   void AddPointer(ConstantSubscript, const Expr<SomeType> &);
 
   void Incorporate(ConstantSubscript toOffset, const InitialImage &from,
       ConstantSubscript fromOffset, ConstantSubscript bytes);
 
   // Conversions to constant initializers
   std::optional<Expr<SomeType>> AsConstant(FoldingContext &,
-      const DynamicType &, const ConstantSubscripts &,
+      const DynamicType &, const ConstantSubscripts &, bool padWithZero = false,
       ConstantSubscript offset = 0) const;
   std::optional<Expr<SomeType>> AsConstantPointer(
       ConstantSubscript offset = 0) const;
 
   friend class AsConstantHelper;
 
 private:
   std::vector<char> data_;
   std::map<ConstantSubscript, Expr<SomeType>> pointers_;
 };
 
 } // namespace Fortran::evaluate
 #endif // FORTRAN_EVALUATE_INITIAL_IMAGE_H_

flang/lib/Evaluate/fold-character.cpp

if (name == "achar" || name == "char") {
     }
   } else if (name == "trim") { // not elemental
     if (auto scalar{
             GetScalarConstantArguments<T>(context, funcRef.arguments())}) {
       return Expr<T>{Constant<T>{
           CharacterUtils<KIND>::TRIM(std::get<Scalar<T>>(*scalar))}};
     }
   }
-  // TODO: transfer
   return Expr<T>{std::move(funcRef)};
 }
 
 template <int KIND>
 Expr<Type<TypeCategory::Character, KIND>> FoldOperation(
     FoldingContext &context, Concat<KIND> &&x) {
   if (auto array{ApplyElementwise(context, x)}) {
     return *array;

flang/lib/Evaluate/fold-complex.cpp

Expr<Type<TypeCategory::Complex, KIND>> FoldIntrinsicFunction(
   } else if (name == "merge") {
     return FoldMerge<T>(context, std::move(funcRef));
   } else if (name == "product") {
     auto one{Scalar<Part>::FromInteger(value::Integer<8>{1}).value};
     return FoldProduct<T>(context, std::move(funcRef), Scalar<T>{one});
   } else if (name == "sum") {
     return FoldSum<T>(context, std::move(funcRef));
   }
-  // TODO: dot_product, matmul, transfer
+  // TODO: dot_product, matmul
   return Expr<T>{std::move(funcRef)};
 }
 
 template <int KIND>
 Expr<Type<TypeCategory::Complex, KIND>> FoldOperation(
     FoldingContext &context, ComplexConstructor<KIND> &&x) {
   if (auto array{ApplyElementwise(context, x)}) {
     return *array;

flang/lib/Evaluate/fold-implementation.h

public:
   Expr<T> CSHIFT(FunctionRef<T> &&);
   Expr<T> EOSHIFT(FunctionRef<T> &&);
   Expr<T> PACK(FunctionRef<T> &&);
   Expr<T> RESHAPE(FunctionRef<T> &&);
   Expr<T> SPREAD(FunctionRef<T> &&);
   Expr<T> TRANSPOSE(FunctionRef<T> &&);
   Expr<T> UNPACK(FunctionRef<T> &&);
 
+  Expr<T> TRANSFER(FunctionRef<T> &&);
+
 private:
   FoldingContext &context_;
 };
 
 std::optional<Constant<SubscriptInteger>> GetConstantSubscript(
     FoldingContext &, Subscript &, const NamedEntity &, int dim);
 
 // Helper to use host runtime on scalars for folding.
for (ConstantSubscript j{0}; j < maskElements; ++j) {
     }
     mask->IncrementSubscripts(maskAt);
     field->IncrementSubscripts(fieldAt);
   }
   return Expr<T>{
       PackageConstant<T>(std::move(resultElements), *vector, mask->shape())};
 }
 
+std::optional<Expr<SomeType>> FoldTransfer(
+    FoldingContext &, const ActualArguments &);
+
+template <typename T> Expr<T> Folder<T>::TRANSFER(FunctionRef<T> &&funcRef) {
+  if (auto folded{FoldTransfer(context_, funcRef.arguments())}) {
+    return DEREF(UnwrapExpr<Expr<T>>(*folded));
+  } else {
+    return Expr<T>{std::move(funcRef)};
+  }
+}
+
 template <typename T>
 Expr<T> FoldMINorMAX(
     FoldingContext &context, FunctionRef<T> &&funcRef, Ordering order) {
   static_assert(T::category == TypeCategory::Integer ||
       T::category == TypeCategory::Real ||
       T::category == TypeCategory::Character);
   std::vector<Constant<T> *> constantArgs;
   // Call Folding on all arguments, even if some are not constant,
if (auto *intrinsic{std::get_if<SpecificIntrinsic>(&funcRef.proc().u)}) {
     } else if (name == "eoshift") {
       return Folder<T>{context}.EOSHIFT(std::move(funcRef));
     } else if (name == "pack") {
       return Folder<T>{context}.PACK(std::move(funcRef));
     } else if (name == "reshape") {
       return Folder<T>{context}.RESHAPE(std::move(funcRef));
     } else if (name == "spread") {
       return Folder<T>{context}.SPREAD(std::move(funcRef));
+    } else if (name == "transfer") {
+      return Folder<T>{context}.TRANSFER(std::move(funcRef));
     } else if (name == "transpose") {
       return Folder<T>{context}.TRANSPOSE(std::move(funcRef));
     } else if (name == "unpack") {
       return Folder<T>{context}.UNPACK(std::move(funcRef));
     }
     // TODO: extends_type_of, same_type_as
     if constexpr (!std::is_same_v<T, SomeDerived>) {
       return FoldIntrinsicFunction(context, std::move(funcRef));

flang/lib/Evaluate/fold-integer.cpp

if (auto info{
             Fold(context, Expr<T>{8} * ConvertToType<T>(std::move(*bytes)))};
       }
     }
   } else if (name == "sum") {
     return FoldSum<T>(context, std::move(funcRef));
   } else if (name == "ubound") {
     return UBOUND(context, std::move(funcRef));
   }
-  // TODO: dot_product, ishftc, matmul, sign, transfer
+  // TODO: dot_product, ishftc, matmul, sign
   return Expr<T>{std::move(funcRef)};
 }
 
 // Substitutes a bare type parameter reference with its value if it has one now
 // in an instantiation.  Bare LEN type parameters are substituted only when
 // the known value is constant.
 Expr<TypeParamInquiry::Result> FoldOperation(
     FoldingContext &context, TypeParamInquiry &&inquiry) {

flang/lib/Evaluate/fold-logical.cpp

if (args[0] && args[1]) {
       name == "__builtin_ieee_support_sqrt" ||
       name == "__builtin_ieee_support_standard" ||
       name == "__builtin_ieee_support_subnormal" ||
       name == "__builtin_ieee_support_underflow_control") {
     return Expr<T>{true};
   }
   // TODO: dot_product, is_iostat_end,
   // is_iostat_eor, logical, matmul, out_of_range,
-  // parity, transfer
+  // parity
   return Expr<T>{std::move(funcRef)};
 }
 
 template <typename T>
 Expr<LogicalResult> FoldOperation(
     FoldingContext &context, Relational<T> &&relation) {
   if (auto array{ApplyElementwise(context, relation,
           std::function<Expr<LogicalResult>(Expr<T> &&, Expr<T> &&)>{

flang/lib/Evaluate/fold-real.cpp

return FoldElementalIntrinsic<T, T>(context, std::move(funcRef),
                 "%s intrinsic folding overflow"_warn_en_US, iName);
           } else if (result.flags.test(RealFlag::InvalidArgument)) {
             context.messages().Say(
                 "%s intrinsic folding: bad argument"_warn_en_US, iName);
           }
           return result.value;
         }));
   }
-  // TODO: dot_product, fraction, matmul, norm2, set_exponent, transfer
+  // TODO: dot_product, fraction, matmul, norm2, set_exponent
   return Expr<T>{std::move(funcRef)};
 }
 
 #ifdef _MSC_VER // disable bogus warning about missing definitions
 #pragma warning(disable : 4661)
 #endif
 FOR_EACH_REAL_KIND(template class ExpressionBase, )
 template class ExpressionBase<SomeReal>;
 } // namespace Fortran::evaluate

flang/lib/Evaluate/fold.cpp

 //===-- lib/Evaluate/fold.cpp ---------------------------------------------===//
 //
 // Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
 // See https://llvm.org/LICENSE.txt for license information.
 // SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
 //
 //===----------------------------------------------------------------------===//
 
 #include "flang/Evaluate/fold.h"
 #include "fold-implementation.h"
 #include "flang/Evaluate/characteristics.h"
+#include "flang/Evaluate/initial-image.h"
 
 namespace Fortran::evaluate {
 
 characteristics::TypeAndShape Fold(
     FoldingContext &context, characteristics::TypeAndShape &&x) {
   x.Rewrite(context);
   return std::move(x);
 }
Expr<ImpliedDoIndex::Result> FoldOperation(
     FoldingContext &context, ImpliedDoIndex &&iDo) {
   if (std::optional<ConstantSubscript> value{context.GetImpliedDo(iDo.name)}) {
     return Expr<ImpliedDoIndex::Result>{*value};
   } else {
     return Expr<ImpliedDoIndex::Result>{std::move(iDo)};
   }
 }
 
+// TRANSFER (F'2018 16.9.193)
+std::optional<Expr<SomeType>> FoldTransfer(
+    FoldingContext &context, const ActualArguments &arguments) {
+  CHECK(arguments.size() == 2 || arguments.size() == 3);
+  const auto *source{UnwrapExpr<Expr<SomeType>>(arguments[0])};
+  std::optional<std::size_t> sourceBytes;
+  if (source) {
+    if (auto sourceTypeAndShape{
+            characteristics::TypeAndShape::Characterize(*source, context)}) {
+      if (auto sourceBytesExpr{
+              sourceTypeAndShape->MeasureSizeInBytes(context)}) {
+        sourceBytes = ToInt64(*sourceBytesExpr);
+      }
+    }
+  }
+  std::optional<DynamicType> moldType;
+  if (arguments[1]) {
+    moldType = arguments[1]->GetType();
+  }
+  std::optional<ConstantSubscripts> extents;
+  if (arguments.size() == 2) { // no SIZE=
+    if (moldType && sourceBytes) {
+      if (arguments[1]->Rank() == 0) { // scalar MOLD=
+        extents = ConstantSubscripts{}; // empty extents (scalar result)
+      } else if (auto moldBytesExpr{
+                     moldType->MeasureSizeInBytes(context, true)}) {
+        if (auto moldBytes{ToInt64(Fold(context, std::move(*moldBytesExpr)))};
+            *moldBytes > 0) {
+          extents = ConstantSubscripts{
+              static_cast<ConstantSubscript>((*sourceBytes) + *moldBytes - 1) /
+              *moldBytes};
+        }
+      }
+    }
+  } else if (arguments[2]) { // SIZE= is present
+    if (const auto *sizeExpr{arguments[2]->UnwrapExpr()}) {
+      if (auto sizeValue{ToInt64(*sizeExpr)}) {
+        extents = ConstantSubscripts{*sizeValue};
+      }
+    }
+  }
+  if (sourceBytes && IsActuallyConstant(*source) && moldType && extents) {
+    InitialImage image{*sourceBytes};
+    InitialImage::Result imageResult{
+        image.Add(0, *sourceBytes, *source, context)};
+    CHECK(imageResult == InitialImage::Ok);
+    return image.AsConstant(context, *moldType, *extents, true /*pad with 0*/);
+  } else {
+    return std::nullopt;
+  }
+}
+
 template class ExpressionBase<SomeDerived>;
 template class ExpressionBase<SomeType>;
 
 } // namespace Fortran::evaluate

flang/lib/Evaluate/initial-image.cpp

 // of the right type to initialize each symbol from the values that have
 // been placed into its initialization image by DATA statements.
 class AsConstantHelper {
 public:
   using Result = std::optional<Expr<SomeType>>;
   using Types = AllTypes;
   AsConstantHelper(FoldingContext &context, const DynamicType &type,
       const ConstantSubscripts &extents, const InitialImage &image,
-      ConstantSubscript offset = 0)
+      bool padWithZero = false, ConstantSubscript offset = 0)
       : context_{context}, type_{type}, image_{image}, extents_{extents},
-        offset_{offset} {
+        padWithZero_{padWithZero}, offset_{offset} {
     CHECK(!type.IsPolymorphic());
   }
   template <typename T> Result Test() {
     if (T::category != type_.category()) {
       return std::nullopt;
     }
     if constexpr (T::category != TypeCategory::Derived) {
       if (T::kind != type_.kind()) {
         return std::nullopt;
       }
     }
     using Const = Constant<T>;
     using Scalar = typename Const::Element;
     std::size_t elements{TotalElementCount(extents_)};
     std::vector<Scalar> typedValue(elements);
     auto elemBytes{
         ToInt64(type_.MeasureSizeInBytes(context_, GetRank(extents_) > 0))};
     CHECK(elemBytes && *elemBytes >= 0);
     std::size_t stride{static_cast<std::size_t>(*elemBytes)};
-    CHECK(offset_ + elements * stride <= image_.data_.size());
+    CHECK(offset_ + elements * stride <= image_.data_.size() || padWithZero_);
     if constexpr (T::category == TypeCategory::Derived) {
       const semantics::DerivedTypeSpec &derived{type_.GetDerivedTypeSpec()};
       for (auto iter : DEREF(derived.scope())) {
         const Symbol &component{*iter.second};
         bool isProcPtr{IsProcedurePointer(component)};
         if (isProcPtr || component.has<semantics::ObjectEntityDetails>()) {
           auto at{offset_ + component.offset()};
           if (isProcPtr) {
if constexpr (T::category == TypeCategory::Derived) {
               }
             }
           } else if (!IsAllocatable(component)) {
             auto componentType{DynamicType::From(component)};
             CHECK(componentType.has_value());
             auto componentExtents{GetConstantExtents(context_, component)};
             CHECK(componentExtents.has_value());
             for (std::size_t j{0}; j < elements; ++j, at += stride) {
-              if (Result value{image_.AsConstant(
-                      context_, *componentType, *componentExtents, at)}) {
+              if (Result value{image_.AsConstant(context_, *componentType,
+                      *componentExtents, padWithZero_, at)}) {
                 typedValue[j].emplace(component, std::move(*value));
               }
             }
           }
         }
       }
       return AsGenericExpr(
           Const{derived, std::move(typedValue), std::move(extents_)});
     } else if constexpr (T::category == TypeCategory::Character) {
       auto length{static_cast<ConstantSubscript>(stride) / T::kind};
       for (std::size_t j{0}; j < elements; ++j) {
         using Char = typename Scalar::value_type;
-        const Char *data{reinterpret_cast<const Char *>(
-            &image_.data_[offset_ + j * stride])};
+        auto at{static_cast<std::size_t>(offset_ + j * stride)};
+        if (at + length > image_.data_.size()) {
+          CHECK(padWithZero_);
+          break;
+        }
+        const Char *data{reinterpret_cast<const Char *>(&image_.data_[at])};
         typedValue[j].assign(data, length);
       }
       return AsGenericExpr(
           Const{length, std::move(typedValue), std::move(extents_)});
     } else {
       // Lengthless intrinsic type
       CHECK(sizeof(Scalar) <= stride);
       for (std::size_t j{0}; j < elements; ++j) {
-        std::memcpy(&typedValue[j], &image_.data_[offset_ + j * stride],
-            sizeof(Scalar));
+        auto at{static_cast<std::size_t>(offset_ + j * stride)};
+        std::size_t chunk{sizeof(Scalar)};
+        if (at + chunk > image_.data_.size()) {
+          CHECK(padWithZero_);
+          if (at >= image_.data_.size()) {
+            break;
+          }
+          chunk = image_.data_.size() - at;
+        }
+        // TODO endianness
+        std::memcpy(&typedValue[j], &image_.data_[at], chunk);
       }
       return AsGenericExpr(Const{std::move(typedValue), std::move(extents_)});
     }
   }
 
 private:
   FoldingContext &context_;
   const DynamicType &type_;
   const InitialImage &image_;
   ConstantSubscripts extents_; // a copy
+  bool padWithZero_;
   ConstantSubscript offset_;
 };
 
 std::optional<Expr<SomeType>> InitialImage::AsConstant(FoldingContext &context,
     const DynamicType &type, const ConstantSubscripts &extents,
-    ConstantSubscript offset) const {
+    bool padWithZero, ConstantSubscript offset) const {
   return common::SearchTypes(
-      AsConstantHelper{context, type, extents, *this, offset});
+      AsConstantHelper{context, type, extents, *this, padWithZero, offset});
 }
 
 std::optional<Expr<SomeType>> InitialImage::AsConstantPointer(
     ConstantSubscript offset) const {
   auto iter{pointers_.find(offset)};
   return iter == pointers_.end() ? std::optional<Expr<SomeType>>{}
                                  : iter->second;
 }
 
 } // namespace Fortran::evaluate

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

if (const auto *object{component.detailsIf<ObjectEntityDetails>()}) {
             }
             if (initialized) {
               init.image.AddPointer(componentOffset, *object->init());
             }
           } else { // data, not pointer
             if (auto dyType{evaluate::DynamicType::From(component)}) {
               if (auto extents{evaluate::GetConstantExtents(
                       foldingContext, component)}) {
-                if (auto extant{init.image.AsConstant(
-                        foldingContext, *dyType, *extents, componentOffset)}) {
+                if (auto extant{init.image.AsConstant(foldingContext, *dyType,
+                        *extents, false /*don't pad*/, componentOffset)}) {
                   initialized = !(*extant == *object->init());
                 }
               }
             }
             if (initialized) {
               init.image.Add(componentOffset, component.size(), *object->init(),
                   foldingContext);
             }

flang/test/Evaluate/fold-transfer.f90

+! RUN: %python %S/test_folding.py %s %flang_fc1
+! Tests folding of TRANSFER(...)
+
+module m
+  logical, parameter :: test_r2i_s_1 = transfer(1., 0) == int(z'3f800000')
+  logical, parameter :: test_r2i_v_1 = all(transfer(1., [integer::]) == [int(z'3f800000')])
+  logical, parameter :: test_r2i_v_2 = all(transfer([1., 2.], [integer::]) == [int(z'3f800000'), int(z'40000000')])
+  logical, parameter :: test_r2i_vs_1 = all(transfer([1., 2.], [integer::], 1) == [int(z'3f800000')])
+
+  type :: t
+    real :: x = 0.
+  end type t
+  logical, parameter :: test_t2i_s_1 = transfer(t(1.), 0) == int(z'3f800000')
+  logical, parameter :: test_t2i_v_1 = all(transfer(t(1.), [integer::]) == [int(z'3f800000')])
+  logical, parameter :: test_t2i_v_2 = all(transfer([t(1.), t(2.)], [integer::]) == [int(z'3f800000'), int(z'40000000')])
+  logical, parameter :: test_t2i_vs_1 = all(transfer([t(1.), t(2.)], [integer::], 1) == [int(z'3f800000')])
+
+  type(t), parameter :: t1 = transfer(1., t())
+  logical, parameter :: test_r2t_s_1 = t1%x == 1.
+  type(t), parameter :: t2(*) = transfer(1., [t::])
+  logical, parameter :: test_r2t_v_1 = all(t2%x == [1.])
+  type(t), parameter :: t3(*) = transfer([1., 2.], [t::])
+  logical, parameter :: test_r2t_v_2 = all(t3%x == [1., 2.])
+  type(t), parameter :: t4(*) = transfer([1., 2.], t(), 1)
+  logical, parameter :: test_r2t_vs_1 = all(t4%x == [1.])
+
+  logical, parameter :: test_nan = transfer(int(z'7ff8000000000000', 8), 0._8) /= transfer(int(z'7ff8000000000000', 8), 0._8)
+
+  integer, parameter :: jc1 = transfer("abcd", 0)
+  logical, parameter :: test_c2i_s_1 = jc1 == int(z'61626364') .or. jc1 == int(z'64636261')
+  integer, parameter :: jc2(*) = transfer("abcd", [integer::])
+  logical, parameter :: test_c2i_v_1 = all(jc2 == int(z'61626364') .or. jc1 == int(z'64636261'))
+  integer, parameter :: jc3(*) = transfer(["abcd", "efgh"], [integer::])
+  logical, parameter :: test_c2i_v_2 = all(jc3 == [int(z'61626364'), int(z'65666768')]) .or. all(jc3 == [int(z'64636261'), int(z'68676665')])
+  integer, parameter :: jc4(*) = transfer(["abcd", "efgh"], 0, 1)
+  logical, parameter :: test_c2i_vs_1 = all(jc4 == [int(z'61626364')]) .or. all(jc4 == [int(z'64636261')])
+end module

flang/test/Evaluate/folding10.f90

 ! RUN: %python %S/test_folding.py %s %flang_fc1
 ! Tests folding of SHAPE(TRANSFER(...))
+! Adjusted to allow for folding (or not) of TRANSFER().
 
 module m
+  integer :: j
+  real :: a(3)
+  logical, parameter :: test_size_v1 = size(shape(transfer(j, 0_1,size=4))) == 1
+  logical, parameter :: test_size_v2 = all(shape(transfer(j, 0_1,size=4)) == [4])
+  logical, parameter :: test_scalar_v1 = size(shape(transfer(j, 0_1))) == 0
+  logical, parameter :: test_vector_v1 = size(shape(transfer(j, [0_1]))) == 1
+  logical, parameter :: test_vector_v2 = all(shape(transfer(j, [0_1])) == [4])
+  logical, parameter :: test_array_v1 = size(shape(transfer(j, reshape([0_1],[1,1])))) == 1
+  logical, parameter :: test_array_v2 = all(shape(transfer(j, reshape([0_1],[1,1]))) == [4])
+  logical, parameter :: test_array_v3 = all(shape(transfer(a, [(0.,0.)])) == [2])
+
   logical, parameter :: test_size_1 = size(shape(transfer(123456789,0_1,size=4))) == 1
   logical, parameter :: test_size_2 = all(shape(transfer(123456789,0_1,size=4)) == [4])
   logical, parameter :: test_scalar_1 = size(shape(transfer(123456789, 0_1))) == 0
   logical, parameter :: test_vector_1 = size(shape(transfer(123456789, [0_1]))) == 1
   logical, parameter :: test_vector_2 = all(shape(transfer(123456789, [0_1])) == [4])
   logical, parameter :: test_array_1 = size(shape(transfer(123456789, reshape([0_1],[1,1])))) == 1
   logical, parameter :: test_array_2 = all(shape(transfer(123456789, reshape([0_1],[1,1]))) == [4])
   logical, parameter :: test_array_3 = all(shape(transfer([1.,2.,3.], [(0.,0.)])) == [2])
 end module

flang/test/Semantics/array-constr-values.f90

subroutine arrayconstructorvalues()
   intarray = (/ 1, 2, 3, 4., 5/)  ! C7110
   ! Different kind type parameter
   !ERROR: Values in array constructor must have the same declared type when no explicit type appears
   intarray = (/ 1,2,3,4, k8 /)    ! C7110
 
   ! C7111
   !ERROR: Value in array constructor of type 'LOGICAL(4)' could not be converted to the type of the array 'INTEGER(4)'
   intarray = [integer:: .true., 2, 3, 4, 5]
-  !ERROR: Value in array constructor of type 'CHARACTER(1)' could not be converted to the type of the array 'INTEGER(4)'
+  !ERROR: Value in array constructor of type 'CHARACTER(KIND=1,LEN=22_8)' could not be converted to the type of the array 'INTEGER(4)'
   intarray = [integer:: "RAM stores information", 2, 3, 4, 5]
   !ERROR: Value in array constructor of type 'employee' could not be converted to the type of the array 'INTEGER(4)'
   intarray = [integer:: EMPLOYEE (19, "Jack"), 2, 3, 4, 5]
 
   ! C7112
   !ERROR: Value in array constructor of type 'INTEGER(4)' could not be converted to the type of the array 'employee'
   emparray = (/ EMPLOYEE:: EMPLOYEE(19, "Ganesh"), EMPLOYEE(22, "Omkar"), 19 /)
   !ERROR: Value in array constructor of type 'employeer' could not be converted to the type of the array 'employee'

flang/test/Semantics/case01.f90

select case (grade3)
      case default
      case (.true.)
      !ERROR: CASE DEFAULT conflicts with previous cases
      case default
   end select
 
   ! C1147
   select case (grade2)
-     !ERROR: CASE value has type 'CHARACTER(1)' which is not compatible with the SELECT CASE expression's type 'INTEGER(4)'
+     !ERROR: CASE value has type 'CHARACTER(KIND=1,LEN=1_8)' which is not compatible with the SELECT CASE expression's type 'INTEGER(4)'
      case (:'Z')
      case default
    end select
 
   select case (grade1)
      !ERROR: CASE value has type 'INTEGER(4)' which is not compatible with the SELECT CASE expression's type 'CHARACTER(KIND=1,LEN=1_8)'
      case (:1)
      case default
    end select
 
   select case (grade3)
      case default
      case (.true.)
      !ERROR: CASE value has type 'INTEGER(4)' which is not compatible with the SELECT CASE expression's type 'LOGICAL(4)'
      case (3)
   end select
 
   select case (grade2)
      case default
      case (2 :)
      !ERROR: CASE value has type 'LOGICAL(4)' which is not compatible with the SELECT CASE expression's type 'INTEGER(4)'
      case (.true. :)
      !ERROR: CASE value has type 'REAL(4)' which is not compatible with the SELECT CASE expression's type 'INTEGER(4)'
      case (1.0)
-     !ERROR: CASE value has type 'CHARACTER(1)' which is not compatible with the SELECT CASE expression's type 'INTEGER(4)'
+     !ERROR: CASE value has type 'CHARACTER(KIND=1,LEN=3_8)' which is not compatible with the SELECT CASE expression's type 'INTEGER(4)'
      case ('wow')
   end select
 
   select case (ASCII_parm1)
      case (ASCII_parm2)
-     !ERROR: CASE value has type 'CHARACTER(4)' which is not compatible with the SELECT CASE expression's type 'CHARACTER(1)'
+     !ERROR: CASE value has type 'CHARACTER(KIND=4,LEN=1_8)' which is not compatible with the SELECT CASE expression's type 'CHARACTER(KIND=1,LEN=1_8)'
      case (UCS32_parm)
-     !ERROR: CASE value has type 'CHARACTER(2)' which is not compatible with the SELECT CASE expression's type 'CHARACTER(1)'
+     !ERROR: CASE value has type 'CHARACTER(KIND=2,LEN=1_8)' which is not compatible with the SELECT CASE expression's type 'CHARACTER(KIND=1,LEN=1_8)'
      case (UCS16_parm)
-     !ERROR: CASE value has type 'CHARACTER(4)' which is not compatible with the SELECT CASE expression's type 'CHARACTER(1)'
+     !ERROR: CASE value has type 'CHARACTER(KIND=4,LEN=6_8)' which is not compatible with the SELECT CASE expression's type 'CHARACTER(KIND=1,LEN=1_8)'
      case (4_"ucs-32")
-     !ERROR: CASE value has type 'CHARACTER(2)' which is not compatible with the SELECT CASE expression's type 'CHARACTER(1)'
+     !ERROR: CASE value has type 'CHARACTER(KIND=2,LEN=6_8)' which is not compatible with the SELECT CASE expression's type 'CHARACTER(KIND=1,LEN=1_8)'
      case (2_"ucs-16")
      case default
    end select
 
   ! C1148
   select case (grade3)
      case default
      !ERROR: CASE range is not allowed for LOGICAL

flang/test/Semantics/select-rank.f90

subroutine CALL_ME_TYPES(x)
     integer :: x(..),j
     SELECT RANK(x)
     !ERROR: Must have INTEGER type, but is LOGICAL(4)
         RANK(.TRUE.)
     !ERROR: Must have INTEGER type, but is REAL(4)
         RANK(1.0)
     !ERROR: Must be a constant value
         RANK(RANK(x))
-    !ERROR: Must have INTEGER type, but is CHARACTER(1)
+    !ERROR: Must have INTEGER type, but is CHARACTER(KIND=1,LEN=6_8)
         RANK("STRING")
     END SELECT
    end subroutine
    subroutine CALL_SHAPE(x)
     implicit none
     integer :: x(..)
     integer :: j
     integer, pointer :: ptr

flang/test/Semantics/structconst02.f90

subroutine errors(n)
     !ERROR: Structure constructor lacks a value for component 'cx'
     call scalararg(scalar(len=n)()) ! triggers error on 'cx'
     call scalararg(scalar(4)(ix=1,rx=2.,zx=(3.,4.),cx='a',lx=.true.))
     call scalararg(scalar(4)(1,2.,(3.,4.),'a',.true.))
 !    call scalararg(scalar(4)(ix=5.,rx=6,zx=(7._8,8._2),cx=4_'b',lx=.true._4))
 !    call scalararg(scalar(4)(5.,6,(7._8,8._2),4_'b',.true._4))
     call scalararg(scalar(4)(ix=5.,rx=6,zx=(7._8,8._2),cx=4_'b',lx=.true.))
     call scalararg(scalar(4)(5.,6,(7._8,8._2),4_'b',.true.))
-    !ERROR: Value in structure constructor of type 'CHARACTER(1)' is incompatible with component 'ix' of type 'INTEGER(4)'
+    !ERROR: Value in structure constructor of type 'CHARACTER(KIND=1,LEN=1_8)' is incompatible with component 'ix' of type 'INTEGER(4)'
     call scalararg(scalar(4)(ix='a'))
     !ERROR: Value in structure constructor of type 'LOGICAL(4)' is incompatible with component 'ix' of type 'INTEGER(4)'
     call scalararg(scalar(4)(ix=.false.))
     !ERROR: Rank-1 array value is not compatible with scalar component 'ix'
     call scalararg(scalar(4)(ix=[1]))
     !TODO more!
   end subroutine errors
 end module module1