[flang] TRANSFER() intrinsic function

API, implementation, and unit tests for the intrinsic
function TRANSFER.

Differential Revision: https://reviews.llvm.org/D99799

9 files changed, 242 insertions, 32 deletions

diff --git a/flang/runtime/CMakeLists.txt b/flang/runtime/CMakeLists.txt
index 49ac98d01f1d..6f95ff89d041 100644
--- a/flang/runtime/CMakeLists.txt
+++ b/flang/runtime/CMakeLists.txt
@@ -51,6 +51,7 @@ add_flang_library(FortranRuntime
   io-stmt.cpp
   main.cpp
   memory.cpp
+  misc-intrinsic.cpp
   numeric.cpp
   reduction.cpp
   stat.cpp
diff --git a/flang/runtime/descriptor.cpp b/flang/runtime/descriptor.cpp
index 54069febabba..3a750255eb23 100644
--- a/flang/runtime/descriptor.cpp
+++ b/flang/runtime/descriptor.cpp
@@ -260,6 +260,17 @@ void Descriptor::Dump(FILE *f) const {
   }
 }
 
+DescriptorAddendum &DescriptorAddendum::operator=(
+    const DescriptorAddendum &that) {
+  derivedType_ = that.derivedType_;
+  flags_ = that.flags_;
+  auto lenParms{that.LenParameters()};
+  for (std::size_t j{0}; j < lenParms; ++j) {
+    len_[j] = that.len_[j];
+  }
+  return *this;
+}
+
 std::size_t DescriptorAddendum::SizeInBytes() const {
   return SizeInBytes(LenParameters());
 }
diff --git a/flang/runtime/descriptor.h b/flang/runtime/descriptor.h
index d909822dafc4..2ce90f39f747 100644
--- a/flang/runtime/descriptor.h
+++ b/flang/runtime/descriptor.h
@@ -93,6 +93,7 @@ public:
   explicit DescriptorAddendum(
       const typeInfo::DerivedType *dt = nullptr, std::uint64_t flags = 0)
       : derivedType_{dt}, flags_{flags} {}
+  DescriptorAddendum &operator=(const DescriptorAddendum &);
 
   const typeInfo::DerivedType *derivedType() const { return derivedType_; }
   DescriptorAddendum &set_derivedType(const typeInfo::DerivedType *dt) {
diff --git a/flang/runtime/misc-intrinsic.cpp b/flang/runtime/misc-intrinsic.cpp
new file mode 100644
index 000000000000..7b4fa5fa3a31
--- /dev/null
+++ b/flang/runtime/misc-intrinsic.cpp
@@ -0,0 +1,72 @@
+//===-- runtime/misc-intrinsic.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 "misc-intrinsic.h"
+#include "descriptor.h"
+#include "terminator.h"
+#include <algorithm>
+#include <cstring>
+
+namespace Fortran::runtime {
+extern "C" {
+
+void RTNAME(Transfer)(Descriptor &result, const Descriptor &source,
+    const Descriptor &mold, const char *sourceFile, int line) {
+  if (mold.rank() > 0) {
+    std::size_t moldElementBytes{mold.ElementBytes()};
+    std::size_t elements{
+        (source.Elements() * source.ElementBytes() + moldElementBytes - 1) /
+        moldElementBytes};
+    return RTNAME(TransferSize)(result, source, mold, sourceFile, line,
+        static_cast<std::int64_t>(elements));
+  } else {
+    return RTNAME(TransferSize)(result, source, mold, sourceFile, line, 1);
+  }
+}
+
+void RTNAME(TransferSize)(Descriptor &result, const Descriptor &source,
+    const Descriptor &mold, const char *sourceFile, int line,
+    std::int64_t size) {
+  int rank{mold.rank() > 0 ? 1 : 0};
+  std::size_t elementBytes{mold.ElementBytes()};
+  result.Establish(mold.type(), elementBytes, nullptr, rank, nullptr,
+      CFI_attribute_allocatable, mold.Addendum() != nullptr);
+  if (rank > 0) {
+    result.GetDimension(0).SetBounds(1, size);
+  }
+  if (const DescriptorAddendum * addendum{mold.Addendum()}) {
+    *result.Addendum() = *addendum;
+    auto &flags{result.Addendum()->flags()};
+    flags &= ~DescriptorAddendum::StaticDescriptor;
+    flags |= DescriptorAddendum::DoNotFinalize;
+  }
+  if (int stat{result.Allocate()}) {
+    Terminator{sourceFile, line}.Crash(
+        "TRANSFER: could not allocate memory for result; STAT=%d", stat);
+  }
+  char *to{result.OffsetElement<char>()};
+  std::size_t resultBytes{size * elementBytes};
+  const std::size_t sourceElementBytes{source.ElementBytes()};
+  std::size_t sourceElements{source.Elements()};
+  SubscriptValue sourceAt[maxRank];
+  source.GetLowerBounds(sourceAt);
+  while (resultBytes > 0 && sourceElements > 0) {
+    std::size_t toMove{std::min(resultBytes, sourceElementBytes)};
+    std::memcpy(to, source.Element<char>(sourceAt), toMove);
+    to += toMove;
+    resultBytes -= toMove;
+    --sourceElements;
+    source.IncrementSubscripts(sourceAt);
+  }
+  if (resultBytes > 0) {
+    std::memset(to, 0, resultBytes);
+  }
+}
+
+} // extern "C"
+} // namespace Fortran::runtime
diff --git a/flang/runtime/misc-intrinsic.h b/flang/runtime/misc-intrinsic.h
new file mode 100644
index 000000000000..16fa355cee2d
--- /dev/null
+++ b/flang/runtime/misc-intrinsic.h
@@ -0,0 +1,29 @@
+//===-- runtime/misc-intrinsic.h --------------------------------*- C++ -*-===//
+//
+// 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
+//
+//===----------------------------------------------------------------------===//
+
+// Miscellaneous intrinsic procedures
+
+#ifndef FORTRAN_RUNTIME_MISC_INTRINSIC_H_
+#define FORTRAN_RUNTIME_MISC_INTRINSIC_H_
+
+#include "entry-names.h"
+#include <cstdint>
+
+namespace Fortran::runtime {
+
+class Descriptor;
+
+extern "C" {
+void RTNAME(Transfer)(Descriptor &result, const Descriptor &source,
+    const Descriptor &mold, const char *sourceFile, int line);
+void RTNAME(TransferSize)(Descriptor &result, const Descriptor &source,
+    const Descriptor &mold, const char *sourceFile, int line,
+    std::int64_t size);
+} // extern "C"
+} // namespace Fortran::runtime
+#endif // FORTRAN_RUNTIME_MISC_INTRINSIC_H_
diff --git a/flang/unittests/RuntimeGTest/CMakeLists.txt b/flang/unittests/RuntimeGTest/CMakeLists.txt
index 1d4e2d01508e..38f08d7912ba 100644
--- a/flang/unittests/RuntimeGTest/CMakeLists.txt
+++ b/flang/unittests/RuntimeGTest/CMakeLists.txt
@@ -1,6 +1,7 @@
 add_flang_unittest(FlangRuntimeTests
   CharacterTest.cpp
   CrashHandlerFixture.cpp
+  MiscIntrinsic.cpp
   Numeric.cpp
   NumericalFormatTest.cpp
   Reduction.cpp
diff --git a/flang/unittests/RuntimeGTest/MiscIntrinsic.cpp b/flang/unittests/RuntimeGTest/MiscIntrinsic.cpp
new file mode 100644
index 000000000000..62213d01021e
--- /dev/null
+++ b/flang/unittests/RuntimeGTest/MiscIntrinsic.cpp
@@ -0,0 +1,70 @@
+//===-- flang/unittests/RuntimeGTest/MiscIntrinsic.cpp ----------*- C++ -*-===//
+//
+// 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 "gtest/gtest.h"
+#include "tools.h"
+#include "../../runtime/allocatable.h"
+#include "../../runtime/cpp-type.h"
+#include "../../runtime/descriptor.h"
+#include "../../runtime/misc-intrinsic.h"
+
+using namespace Fortran::runtime;
+
+// TRANSFER examples from Fortran 2018
+
+TEST(MiscIntrinsic, TransferScalar) {
+  StaticDescriptor<2, true, 2> staticDesc[2];
+  auto &result{staticDesc[0].descriptor()};
+  auto source{MakeArray<TypeCategory::Integer, 4>(
+      std::vector<int>{}, std::vector<std::int32_t>{1082130432})};
+  auto &mold{staticDesc[1].descriptor()};
+  mold.Establish(TypeCategory::Real, 4, nullptr, 0);
+  RTNAME(Transfer)(result, *source, mold, __FILE__, __LINE__);
+  EXPECT_EQ(result.rank(), 0);
+  EXPECT_EQ(result.type().raw(), (TypeCode{TypeCategory::Real, 4}.raw()));
+  EXPECT_EQ(*result.OffsetElement<float>(), 4.0);
+  result.Destroy();
+}
+
+TEST(MiscIntrinsic, TransferMold) {
+  StaticDescriptor<2, true, 2> staticDesc[2];
+  auto &result{staticDesc[0].descriptor()};
+  auto source{MakeArray<TypeCategory::Real, 4>(
+      std::vector<int>{3}, std::vector<float>{1.1F, 2.2F, 3.3F})};
+  auto &mold{staticDesc[1].descriptor()};
+  SubscriptValue extent[1]{1};
+  mold.Establish(TypeCategory::Complex, 4, nullptr, 1, extent);
+  RTNAME(Transfer)(result, *source, mold, __FILE__, __LINE__);
+  EXPECT_EQ(result.rank(), 1);
+  EXPECT_EQ(result.GetDimension(0).LowerBound(), 1);
+  EXPECT_EQ(result.GetDimension(0).Extent(), 2);
+  EXPECT_EQ(result.type().raw(), (TypeCode{TypeCategory::Complex, 4}.raw()));
+  EXPECT_EQ(result.OffsetElement<float>()[0], 1.1F);
+  EXPECT_EQ(result.OffsetElement<float>()[1], 2.2F);
+  EXPECT_EQ(result.OffsetElement<float>()[2], 3.3F);
+  EXPECT_EQ(result.OffsetElement<float>()[3], 0.0F);
+  result.Destroy();
+}
+
+TEST(MiscIntrinsic, TransferSize) {
+  StaticDescriptor<2, true, 2> staticDesc[2];
+  auto &result{staticDesc[0].descriptor()};
+  auto source{MakeArray<TypeCategory::Real, 4>(
+      std::vector<int>{3}, std::vector<float>{1.1F, 2.2F, 3.3F})};
+  auto &mold{staticDesc[1].descriptor()};
+  SubscriptValue extent[1]{1};
+  mold.Establish(TypeCategory::Complex, 4, nullptr, 1, extent);
+  RTNAME(TransferSize)(result, *source, mold, __FILE__, __LINE__, 1);
+  EXPECT_EQ(result.rank(), 1);
+  EXPECT_EQ(result.GetDimension(0).LowerBound(), 1);
+  EXPECT_EQ(result.GetDimension(0).Extent(), 1);
+  EXPECT_EQ(result.type().raw(), (TypeCode{TypeCategory::Complex, 4}.raw()));
+  EXPECT_EQ(result.OffsetElement<float>()[0], 1.1F);
+  EXPECT_EQ(result.OffsetElement<float>()[1], 2.2F);
+  result.Destroy();
+}
diff --git a/flang/unittests/RuntimeGTest/Reduction.cpp b/flang/unittests/RuntimeGTest/Reduction.cpp
index e8471b63cd11..111b5674285f 100644
--- a/flang/unittests/RuntimeGTest/Reduction.cpp
+++ b/flang/unittests/RuntimeGTest/Reduction.cpp
@@ -8,6 +8,7 @@
 
 #include "../../runtime/reduction.h"
 #include "gtest/gtest.h"
+#include "tools.h"
 #include "../../runtime/allocatable.h"
 #include "../../runtime/cpp-type.h"
 #include "../../runtime/descriptor.h"
@@ -20,38 +21,6 @@
 using namespace Fortran::runtime;
 using Fortran::common::TypeCategory;
 
-template <typename A>
-static void StoreElement(void *p, const A &x, std::size_t bytes) {
-  std::memcpy(p, &x, bytes);
-}
-
-template <typename CHAR>
-static void StoreElement(
-    void *p, const std::basic_string<CHAR> &str, std::size_t bytes) {
-  ASSERT_LE(bytes, sizeof(CHAR) * str.size());
-  std::memcpy(p, str.data(), bytes);
-}
-
-template <TypeCategory CAT, int KIND, typename A>
-static OwningPtr<Descriptor> MakeArray(const std::vector<int> &shape,
-    const std::vector<A> &data, std::size_t elemLen = KIND) {
-  auto rank{static_cast<int>(shape.size())};
-  auto result{Descriptor::Create(TypeCode{CAT, KIND}, elemLen, nullptr, rank,
-      nullptr, CFI_attribute_allocatable)};
-  for (int j{0}; j < rank; ++j) {
-    result->GetDimension(j).SetBounds(1, shape[j]);
-  }
-  int stat{result->Allocate()};
-  EXPECT_EQ(stat, 0) << stat;
-  EXPECT_LE(data.size(), result->Elements());
-  char *p{result->OffsetElement<char>()};
-  for (const auto &x : data) {
-    StoreElement(p, x, elemLen);
-    p += elemLen;
-  }
-  return result;
-}
-
 TEST(Reductions, SumInt4) {
   auto array{MakeArray<TypeCategory::Integer, 4>(
       std::vector<int>{2, 3}, std::vector<std::int32_t>{1, 2, 3, 4, 5, 6})};
diff --git a/flang/unittests/RuntimeGTest/tools.h b/flang/unittests/RuntimeGTest/tools.h
new file mode 100644
index 000000000000..c2c31dcef414
--- /dev/null
+++ b/flang/unittests/RuntimeGTest/tools.h
@@ -0,0 +1,56 @@
+//===-- flang/unittests/RuntimeGTest/tools.h --------------------*- C++ -*-===//
+//
+// 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
+//
+//===----------------------------------------------------------------------===//
+
+#ifndef FORTRAN_UNITTESTS_RUNTIME_TOOLS_H_
+#define FORTRAN_UNITTESTS_RUNTIME_TOOLS_H_
+
+#include "gtest/gtest.h"
+#include "../../runtime/allocatable.h"
+#include "../../runtime/cpp-type.h"
+#include "../../runtime/descriptor.h"
+#include "../../runtime/type-code.h"
+#include <cstdint>
+#include <cstring>
+#include <vector>
+
+namespace Fortran::runtime {
+
+template <typename A>
+static void StoreElement(void *p, const A &x, std::size_t bytes) {
+  std::memcpy(p, &x, bytes);
+}
+
+template <typename CHAR>
+static void StoreElement(
+    void *p, const std::basic_string<CHAR> &str, std::size_t bytes) {
+  ASSERT_LE(bytes, sizeof(CHAR) * str.size());
+  std::memcpy(p, str.data(), bytes);
+}
+
+template <TypeCategory CAT, int KIND, typename A>
+static OwningPtr<Descriptor> MakeArray(const std::vector<int> &shape,
+    const std::vector<A> &data, std::size_t elemLen = KIND) {
+  auto rank{static_cast<int>(shape.size())};
+  auto result{Descriptor::Create(TypeCode{CAT, KIND}, elemLen, nullptr, rank,
+      nullptr, CFI_attribute_allocatable)};
+  for (int j{0}; j < rank; ++j) {
+    result->GetDimension(j).SetBounds(1, shape[j]);
+  }
+  int stat{result->Allocate()};
+  EXPECT_EQ(stat, 0) << stat;
+  EXPECT_LE(data.size(), result->Elements());
+  char *p{result->OffsetElement<char>()};
+  for (A x : data) {
+    StoreElement(p, x, elemLen);
+    p += elemLen;
+  }
+  return result;
+}
+
+} // namespace Fortran::runtime
+#endif // FORTRAN_UNITTESTS_RUNTIME_TOOLS_H_