[flang] Add implementation of move_alloc to the runtime

This patch adds a move_alloc implementation to the flang runtime.
Most of the checks required by the standard for move_alloc are
done by semenatic analysis; these checks are not replicated here.

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

flang/include/flang/Runtime/allocatable.h

@@ -93,7 +93,7 @@ int RTNAME(AllocatableAllocateSource)(Descriptor &, const Descriptor &source,
 // but note the order of first two arguments is reversed for consistency
 // with the other APIs for allocatables.)  The destination descriptor
 // must be initialized.
-int RTNAME(MoveAlloc)(Descriptor &to, const Descriptor &from,
+std::int32_t RTNAME(MoveAlloc)(Descriptor &to, Descriptor &from,
     bool hasStat = false, const Descriptor *errMsg = nullptr,
     const char *sourceFile = nullptr, int sourceLine = 0);
 

flang/runtime/allocatable.cpp

@@ -12,6 +12,9 @@
 #include "stat.h"
 #include "terminator.h"
 #include "type-info.h"
+#include "flang/ISO_Fortran_binding.h"
+#include "flang/Runtime/assign.h"
+#include "flang/Runtime/descriptor.h"
 
 namespace Fortran::runtime {
 extern "C" {
@@ -38,10 +41,31 @@ void RTNAME(AllocatableInitDerived)(Descriptor &descriptor,
       derivedType, nullptr, rank, nullptr, CFI_attribute_allocatable);
 }
 
-int RTNAME(MoveAlloc)(Descriptor &to, const Descriptor & /*from*/,
-    bool /*hasStat*/, const Descriptor * /*errMsg*/,
-    const char * /*sourceFile*/, int /*sourceLine*/) {
-  INTERNAL_CHECK(false); // TODO: MoveAlloc is not yet implemented
+std::int32_t RTNAME(MoveAlloc)(Descriptor &to, Descriptor &from, bool hasStat,
+    const Descriptor *errMsg, const char *sourceFile, int sourceLine) {
+  Terminator terminator{sourceFile, sourceLine};
+  // Should be handled by semantic analysis
+  RUNTIME_CHECK(terminator, to.type() == from.type());
+  RUNTIME_CHECK(terminator, to.IsAllocatable() && from.IsAllocatable());
+
+  // If to and from are the same allocatable they must not be allocated
+  // and nothing should be done.
+  if (from.raw().base_addr == to.raw().base_addr && from.IsAllocated()) {
+    return ReturnError(terminator, StatInvalidDescriptor, errMsg, hasStat);
+  }
+
+  if (to.IsAllocated()) {
+    int stat{to.Destroy(/*finalize=*/true)};
+    if (stat != StatOk) {
+      return ReturnError(terminator, stat, errMsg, hasStat);
+    }
+  }
+
+  // If from isn't allocated, the standard defines that nothing should be done.
+  if (from.IsAllocated()) {
+    to = from;
+    from.raw().base_addr = nullptr;
+  }
   return StatOk;
 }
 

flang/unittests/Runtime/Allocatable.cpp

@@ -0,0 +1,80 @@
+//===-- flang/unittests/Runtime/Allocatable.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 "flang/Runtime/allocatable.h"
+#include "gtest/gtest.h"
+#include "tools.h"
+#include "flang/Common/Fortran.h"
+#include "flang/ISO_Fortran_binding.h"
+#include "flang/Optimizer/Builder/FIRBuilder.h"
+#include "flang/Optimizer/Support/InitFIR.h"
+#include "flang/Optimizer/Support/KindMapping.h"
+#include "flang/Runtime/descriptor.h"
+#include "flang/Runtime/memory.h"
+
+using namespace Fortran::runtime;
+
+static OwningPtr<Descriptor> createAllocatable(
+    Fortran::common::TypeCategory tc, int kind, int rank = 1) {
+  return Descriptor::Create(TypeCode{tc, kind}, kind, nullptr, rank, nullptr,
+      CFI_attribute_allocatable);
+}
+
+TEST(AllocatableTest, MoveAlloc) {
+  using Fortran::common::TypeCategory;
+  // INTEGER(4), ALLOCATABLE :: a(:)
+  auto a{createAllocatable(TypeCategory::Integer, 4)};
+  // INTEGER(4), ALLOCATABLE :: b(:)
+  auto b{createAllocatable(TypeCategory::Integer, 4)};
+  // ALLOCATE(a(20))
+  a->GetDimension(0).SetBounds(1, 20);
+  a->Allocate();
+
+  EXPECT_TRUE(a->IsAllocated());
+  EXPECT_FALSE(b->IsAllocated());
+
+  // Simple move_alloc
+  RTNAME(MoveAlloc)(*b, *a, false, nullptr, __FILE__, __LINE__);
+  EXPECT_FALSE(a->IsAllocated());
+  EXPECT_TRUE(b->IsAllocated());
+
+  // move_alloc with stat
+  std::int32_t stat{
+      RTNAME(MoveAlloc)(*a, *b, true, nullptr, __FILE__, __LINE__)};
+  EXPECT_TRUE(a->IsAllocated());
+  EXPECT_FALSE(b->IsAllocated());
+  EXPECT_EQ(stat, 0);
+
+  // move_alloc with errMsg
+  auto errMsg{Descriptor::Create(
+      sizeof(char), 64, nullptr, 0, nullptr, CFI_attribute_allocatable)};
+  errMsg->Allocate();
+  RTNAME(MoveAlloc)(*b, *a, false, errMsg.get(), __FILE__, __LINE__);
+  EXPECT_FALSE(a->IsAllocated());
+  EXPECT_TRUE(b->IsAllocated());
+
+  // move_alloc with stat and errMsg
+  stat = RTNAME(MoveAlloc)(*a, *b, true, errMsg.get(), __FILE__, __LINE__);
+  EXPECT_TRUE(a->IsAllocated());
+  EXPECT_FALSE(b->IsAllocated());
+  EXPECT_EQ(stat, 0);
+
+  // move_alloc with the same deallocated array
+  stat = RTNAME(MoveAlloc)(*b, *b, true, errMsg.get(), __FILE__, __LINE__);
+  EXPECT_FALSE(b->IsAllocated());
+  EXPECT_EQ(stat, 0);
+
+  // move_alloc with the same allocated array should fail
+  stat = RTNAME(MoveAlloc)(*a, *a, true, errMsg.get(), __FILE__, __LINE__);
+  EXPECT_EQ(stat, 18);
+  std::string_view errStr{errMsg->OffsetElement(), errMsg->ElementBytes()};
+  auto trim_pos = errStr.find_last_not_of(' ');
+  if (trim_pos != errStr.npos)
+    errStr.remove_suffix(errStr.size() - trim_pos - 1);
+  EXPECT_EQ(errStr, "Invalid descriptor");
+}

flang/unittests/Runtime/CMakeLists.txt

@@ -1,4 +1,5 @@
 add_flang_unittest(FlangRuntimeTests
+  Allocatable.cpp
   BufferTest.cpp
   CharacterTest.cpp
   CommandTest.cpp