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-exception
6//
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_alloc
35 RTNAME(MoveAlloc)(*b, *a, nullptr, false, nullptr, __FILE__, __LINE__);
36 EXPECT_FALSE(a->IsAllocated());
37 EXPECT_TRUE(b->IsAllocated());
38
39 // move_alloc with stat
40 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 errMsg
47 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 errMsg
55 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 array
62 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 fail
68 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(c: ' ');
73 if (trim_pos != errStr.npos)
74 errStr.remove_suffix(n: 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 :: r
121 // 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 decsriptor
129 // 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

source code of flang-rt/unittests/Runtime/Allocatable.cpp