diff --git a/flang/include/flang/Runtime/allocatable.h b/flang/include/flang/Runtime/allocatable.h --- a/flang/include/flang/Runtime/allocatable.h +++ b/flang/include/flang/Runtime/allocatable.h @@ -93,7 +93,7 @@ // 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); diff --git a/flang/runtime/allocatable.cpp b/flang/runtime/allocatable.cpp --- a/flang/runtime/allocatable.cpp +++ b/flang/runtime/allocatable.cpp @@ -11,7 +11,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 +40,31 @@ 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 handld 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) { + 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; } diff --git a/flang/unittests/Runtime/Allocatable.cpp b/flang/unittests/Runtime/Allocatable.cpp new file mode 100644 --- /dev/null +++ b/flang/unittests/Runtime/Allocatable.cpp @@ -0,0 +1,81 @@ +//===-- 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 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__); + std::cout << "MOVE_ALLOC: " << stat << " " + << std::string(errMsg->OffsetElement(), errMsg->ElementBytes()) + << std::endl; + EXPECT_EQ(stat, 18); + EXPECT_EQ(std::strncmp(errMsg->OffsetElement(), "Invalid descriptor", + errMsg->ElementBytes()), + 0); +} diff --git a/flang/unittests/Runtime/CMakeLists.txt b/flang/unittests/Runtime/CMakeLists.txt --- a/flang/unittests/Runtime/CMakeLists.txt +++ b/flang/unittests/Runtime/CMakeLists.txt @@ -1,4 +1,5 @@ add_flang_unittest(FlangRuntimeTests + Allocatable.cpp BufferTest.cpp CharacterTest.cpp CommandTest.cpp