135 lines · cpp
1//===-- unittests/Runtime/Allocatable.cpp -----------------------*- C++ -*-===//2//3// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.4// See https://llvm.org/LICENSE.txt for license information.5// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception6//7//===----------------------------------------------------------------------===//8 9#include "flang/Runtime/allocatable.h"10#include "gtest/gtest.h"11#include "flang-rt/runtime/tools.h"12 13using namespace Fortran::runtime;14 15static OwningPtr<Descriptor> createAllocatable(16 Fortran::common::TypeCategory tc, int kind, int rank = 1) {17 return Descriptor::Create(TypeCode{tc, kind}, kind, nullptr, rank, nullptr,18 CFI_attribute_allocatable);19}20 21TEST(AllocatableTest, MoveAlloc) {22 using Fortran::common::TypeCategory;23 // INTEGER(4), ALLOCATABLE :: a(:)24 auto a{createAllocatable(TypeCategory::Integer, 4)};25 // INTEGER(4), ALLOCATABLE :: b(:)26 auto b{createAllocatable(TypeCategory::Integer, 4)};27 // ALLOCATE(a(20))28 a->GetDimension(0).SetBounds(1, 20);29 a->Allocate(kNoAsyncObject);30 31 EXPECT_TRUE(a->IsAllocated());32 EXPECT_FALSE(b->IsAllocated());33 34 // Simple move_alloc35 RTNAME(MoveAlloc)(*b, *a, nullptr, false, nullptr, __FILE__, __LINE__);36 EXPECT_FALSE(a->IsAllocated());37 EXPECT_TRUE(b->IsAllocated());38 39 // move_alloc with stat40 std::int32_t stat{41 RTNAME(MoveAlloc)(*a, *b, nullptr, true, nullptr, __FILE__, __LINE__)};42 EXPECT_TRUE(a->IsAllocated());43 EXPECT_FALSE(b->IsAllocated());44 EXPECT_EQ(stat, 0);45 46 // move_alloc with errMsg47 auto errMsg{Descriptor::Create(48 sizeof(char), 64, nullptr, 0, nullptr, CFI_attribute_allocatable)};49 errMsg->Allocate(kNoAsyncObject);50 RTNAME(MoveAlloc)(*b, *a, nullptr, false, errMsg.get(), __FILE__, __LINE__);51 EXPECT_FALSE(a->IsAllocated());52 EXPECT_TRUE(b->IsAllocated());53 54 // move_alloc with stat and errMsg55 stat = RTNAME(MoveAlloc)(56 *a, *b, nullptr, true, errMsg.get(), __FILE__, __LINE__);57 EXPECT_TRUE(a->IsAllocated());58 EXPECT_FALSE(b->IsAllocated());59 EXPECT_EQ(stat, 0);60 61 // move_alloc with the same deallocated array62 stat = RTNAME(MoveAlloc)(63 *b, *b, nullptr, true, errMsg.get(), __FILE__, __LINE__);64 EXPECT_FALSE(b->IsAllocated());65 EXPECT_EQ(stat, 0);66 67 // move_alloc with the same allocated array should fail68 stat = RTNAME(MoveAlloc)(69 *a, *a, nullptr, true, errMsg.get(), __FILE__, __LINE__);70 EXPECT_EQ(stat, 109);71 std::string_view errStr{errMsg->OffsetElement(), errMsg->ElementBytes()};72 auto trim_pos = errStr.find_last_not_of(' ');73 if (trim_pos != errStr.npos)74 errStr.remove_suffix(errStr.size() - trim_pos - 1);75 EXPECT_EQ(errStr, "MOVE_ALLOC passed the same address as to and from");76}77 78TEST(AllocatableTest, AllocateFromScalarSource) {79 using Fortran::common::TypeCategory;80 // REAL(4), ALLOCATABLE :: a(:)81 auto a{createAllocatable(TypeCategory::Real, 4)};82 // ALLOCATE(a(2:11), SOURCE=3.4)83 float sourecStorage{3.4F};84 auto s{Descriptor::Create(TypeCategory::Real, 4,85 reinterpret_cast<void *>(&sourecStorage), 0, nullptr,86 CFI_attribute_pointer)};87 RTNAME(AllocatableSetBounds)(*a, 0, 2, 11);88 RTNAME(AllocatableAllocateSource)89 (*a, *s, /*hasStat=*/false, /*errMsg=*/nullptr, __FILE__, __LINE__);90 EXPECT_TRUE(a->IsAllocated());91 EXPECT_EQ(a->Elements(), 10u);92 EXPECT_EQ(a->GetDimension(0).LowerBound(), 2);93 EXPECT_EQ(a->GetDimension(0).UpperBound(), 11);94 EXPECT_EQ(*a->OffsetElement<float>(), 3.4F);95 a->Destroy();96}97 98TEST(AllocatableTest, AllocateSourceZeroSize) {99 using Fortran::common::TypeCategory;100 // REAL(4), ALLOCATABLE :: a(:)101 auto a{createAllocatable(TypeCategory::Real, 4)};102 // REAL(4) :: s(-1:-2) = 0.103 float sourecStorage{0.F};104 const SubscriptValue extents[1]{0};105 auto s{Descriptor::Create(TypeCategory::Real, 4,106 reinterpret_cast<void *>(&sourecStorage), 1, extents,107 CFI_attribute_other)};108 // ALLOCATE(a, SOURCE=s)109 RTNAME(AllocatableSetBounds)(*a, 0, -1, -2);110 RTNAME(AllocatableAllocateSource)111 (*a, *s, /*hasStat=*/false, /*errMsg=*/nullptr, __FILE__, __LINE__);112 EXPECT_TRUE(a->IsAllocated());113 EXPECT_EQ(a->Elements(), 0u);114 EXPECT_EQ(a->GetDimension(0).LowerBound(), 1);115 EXPECT_EQ(a->GetDimension(0).UpperBound(), 0);116 a->Destroy();117}118 119TEST(AllocatableTest, DoubleAllocation) {120 // CLASS(*), ALLOCATABLE :: r121 // ALLOCATE(REAL::r)122 auto r{createAllocatable(TypeCategory::Real, 4, 0)};123 EXPECT_FALSE(r->IsAllocated());124 EXPECT_TRUE(r->IsAllocatable());125 RTNAME(AllocatableAllocate)(*r);126 EXPECT_TRUE(r->IsAllocated());127 128 // Make sure AllocatableInitIntrinsicForAllocate doesn't reset the decsriptor129 // if it is allocated.130 // ALLOCATE(INTEGER::r)131 RTNAME(AllocatableInitIntrinsicForAllocate)132 (*r, Fortran::common::TypeCategory::Integer, 4);133 EXPECT_TRUE(r->IsAllocated());134}135