1//===-- unittests/Evaluate/ISO-Fortran-binding.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-rt/runtime/descriptor.h"
10#include "flang/Common/ISO_Fortran_binding_wrapper.h"
11#include "flang/Testing/testing.h"
12#include "llvm/Support/raw_ostream.h"
13#include <type_traits>
14
15using namespace Fortran::runtime;
16using namespace Fortran::ISO;
17
18// CFI_CDESC_T test helpers
19template <int rank> class Test_CFI_CDESC_T {
20public:
21 Test_CFI_CDESC_T() {}
22 ~Test_CFI_CDESC_T() {}
23 void Check() {
24 // Test CFI_CDESC_T macro defined in section 18.5.4 of F2018 standard
25 // CFI_CDESC_T must give storage that is:
26 using type = decltype(dvStorage_);
27 // unqualified
28 MATCH(false, std::is_const<type>::value);
29 MATCH(false, std::is_volatile<type>::value);
30 // suitable in size
31 if (rank > 0) {
32 MATCH(sizeof(dvStorage_), Descriptor::SizeInBytes(rank_, false));
33 } else { // C++ implementation over-allocates for rank=0 by 24bytes.
34 MATCH(true, sizeof(dvStorage_) >= Descriptor::SizeInBytes(rank_, false));
35 }
36 // suitable in alignment
37 MATCH(0,
38 reinterpret_cast<std::uintptr_t>(&dvStorage_) &
39 (alignof(CFI_cdesc_t) - 1));
40 }
41
42private:
43 static constexpr int rank_{rank};
44 CFI_CDESC_T(rank) dvStorage_;
45};
46
47template <int rank> static void TestCdescMacroForAllRanksSmallerThan() {
48 static_assert(rank > 0, "rank<0!");
49 Test_CFI_CDESC_T<rank> obj;
50 obj.Check();
51 TestCdescMacroForAllRanksSmallerThan<rank - 1>();
52}
53
54template <> void TestCdescMacroForAllRanksSmallerThan<0>() {
55 Test_CFI_CDESC_T<0> obj;
56 obj.Check();
57}
58
59// CFI_establish test helper
60static void AddNoiseToCdesc(CFI_cdesc_t *dv, CFI_rank_t rank) {
61 static const int trap{0};
62 dv->rank = 16;
63 // This address is not supposed to be used. Any write attempt should trigger
64 // program termination
65 dv->base_addr = const_cast<int *>(&trap);
66 dv->elem_len = 320;
67 dv->type = CFI_type_struct;
68 dv->attribute = CFI_attribute_pointer;
69 for (int i{0}; i < rank; i++) {
70 dv->dim[i].extent = -42;
71 dv->dim[i].lower_bound = -42;
72 dv->dim[i].sm = -42;
73 }
74}
75
76#ifdef VERBOSE
77static void DumpTestWorld(const void *bAddr, CFI_attribute_t attr,
78 CFI_type_t ty, std::size_t eLen, CFI_rank_t rank,
79 const CFI_index_t *eAddr) {
80 llvm::outs() << " base_addr: ";
81 llvm::outs().write_hex(reinterpret_cast<std::intptr_t>(bAddr))
82 << " attribute: " << static_cast<int>(attr)
83 << " type: " << static_cast<int>(ty) << " elem_len: " << eLen
84 << " rank: " << static_cast<int>(rank) << " extent: ";
85 llvm::outs().write_hex(reinterpret_cast<std::intptr_t>(eAddr)) << '\n';
86 llvm::outs().flush();
87}
88#endif
89
90static void check_CFI_establish(CFI_cdesc_t *dv, void *base_addr,
91 CFI_attribute_t attribute, CFI_type_t type, std::size_t elem_len,
92 CFI_rank_t rank, const CFI_index_t extents[]) {
93#ifdef VERBOSE
94 DumpTestWorld(base_addr, attribute, type, elem_len, rank, extent);
95#endif
96 // CFI_establish reqs from F2018 section 18.5.5
97 int retCode{
98 CFI_establish(dv, base_addr, attribute, type, elem_len, rank, extents)};
99 Descriptor *res{reinterpret_cast<Descriptor *>(dv)};
100 if (retCode == CFI_SUCCESS) {
101 res->Check();
102 MATCH((attribute == CFI_attribute_pointer), res->IsPointer());
103 MATCH((attribute == CFI_attribute_allocatable), res->IsAllocatable());
104 MATCH(rank, res->rank());
105 MATCH(reinterpret_cast<std::intptr_t>(dv->base_addr),
106 reinterpret_cast<std::intptr_t>(base_addr));
107 MATCH(true, dv->version == CFI_VERSION);
108 if (base_addr != nullptr) {
109 MATCH(true, res->IsContiguous());
110 for (int i{0}; i < rank; ++i) {
111 MATCH(extents[i], res->GetDimension(i).Extent());
112 }
113 }
114 if (attribute == CFI_attribute_allocatable) {
115 MATCH(res->IsAllocated(), false);
116 }
117 if (attribute == CFI_attribute_pointer) {
118 if (base_addr != nullptr) {
119 for (int i{0}; i < rank; ++i) {
120 MATCH(0, res->GetDimension(i).LowerBound());
121 }
122 }
123 }
124 if (type == CFI_type_struct || type == CFI_type_char ||
125 type == CFI_type_char16_t || type == CFI_type_char32_t ||
126 type == CFI_type_other) {
127 MATCH(elem_len, res->ElementBytes());
128 }
129 }
130 // Checking failure/success according to combination of args forbidden by the
131 // standard:
132 int numErr{0};
133 int expectedRetCode{CFI_SUCCESS};
134 if (base_addr != nullptr && attribute == CFI_attribute_allocatable) {
135 ++numErr;
136 expectedRetCode = CFI_ERROR_BASE_ADDR_NOT_NULL;
137 }
138 if (rank > CFI_MAX_RANK) {
139 ++numErr;
140 expectedRetCode = CFI_INVALID_RANK;
141 }
142 if (type < 0 || type > CFI_TYPE_LAST) {
143 ++numErr;
144 expectedRetCode = CFI_INVALID_TYPE;
145 }
146
147 if ((type == CFI_type_struct || type == CFI_type_char ||
148 type == CFI_type_char16_t || type == CFI_type_char32_t ||
149 type == CFI_type_other) &&
150 elem_len <= 0) {
151 ++numErr;
152 expectedRetCode = CFI_INVALID_ELEM_LEN;
153 }
154 if (rank > 0 && base_addr != nullptr && extents == nullptr) {
155 ++numErr;
156 expectedRetCode = CFI_INVALID_EXTENT;
157 }
158 if (numErr > 1) {
159 MATCH(true, retCode != CFI_SUCCESS);
160 } else {
161 MATCH(retCode, expectedRetCode);
162 }
163}
164
165static void run_CFI_establish_tests() {
166 // Testing CFI_establish defined in section 18.5.5
167 CFI_index_t extents[CFI_MAX_RANK];
168 for (int i{0}; i < CFI_MAX_RANK; ++i) {
169 extents[i] = i + 66;
170 }
171 CFI_CDESC_T(CFI_MAX_RANK) dv_storage;
172 CFI_cdesc_t *dv{&dv_storage};
173 char base;
174 void *dummyAddr{&base};
175 // Define test space
176 CFI_attribute_t attrCases[]{
177 CFI_attribute_pointer, CFI_attribute_allocatable, CFI_attribute_other};
178 CFI_type_t typeCases[]{CFI_type_int, CFI_type_struct, CFI_type_double,
179 CFI_type_char, CFI_type_char16_t, CFI_type_char32_t, CFI_type_other,
180 CFI_TYPE_LAST + 1};
181 CFI_index_t *extentCases[]{extents, nullptr};
182 void *baseAddrCases[]{dummyAddr, nullptr};
183 CFI_rank_t rankCases[]{0, 1, CFI_MAX_RANK, CFI_MAX_RANK + 1};
184 std::size_t lenCases[]{0, 42};
185
186 for (CFI_attribute_t attribute : attrCases) {
187 for (void *base_addr : baseAddrCases) {
188 for (CFI_index_t *extent : extentCases) {
189 for (CFI_rank_t rank : rankCases) {
190 for (CFI_type_t type : typeCases) {
191 for (size_t elem_len : lenCases) {
192 AddNoiseToCdesc(dv, CFI_MAX_RANK);
193 check_CFI_establish(
194 dv, base_addr, attribute, type, elem_len, rank, extent);
195 }
196 }
197 }
198 }
199 }
200 }
201 // If base_addr is null, extents shall be ignored even if rank !=0
202 const int rank3d{3};
203 CFI_CDESC_T(rank3d) dv3darrayStorage;
204 CFI_cdesc_t *dv_3darray{&dv3darrayStorage};
205 AddNoiseToCdesc(dv_3darray, rank3d); // => dv_3darray->dim[2].extent = -42
206 check_CFI_establish(dv_3darray, nullptr, CFI_attribute_other, CFI_type_int, 4,
207 rank3d, extents);
208 MATCH(false,
209 dv_3darray->dim[2].extent == 2 + 66); // extents was read
210}
211
212static void check_CFI_address(
213 const CFI_cdesc_t *dv, const CFI_index_t subscripts[]) {
214 // 18.5.5.2
215 void *addr{CFI_address(dv, subscripts)};
216 const Descriptor *desc{reinterpret_cast<const Descriptor *>(dv)};
217 void *addrCheck{desc->Element<void>(subscripts)};
218 MATCH(true, addr == addrCheck);
219}
220
221// Helper function to set lower bound of descriptor
222static void EstablishLowerBounds(CFI_cdesc_t *dv, CFI_index_t *sub) {
223 for (int i{0}; i < dv->rank; ++i) {
224 dv->dim[i].lower_bound = sub[i];
225 }
226}
227
228// Helper to get size without making internal compiler functions accessible
229static std::size_t ByteSize(CFI_type_t ty, std::size_t size) {
230 CFI_CDESC_T(0) storage;
231 CFI_cdesc_t *dv{&storage};
232 int retCode{
233 CFI_establish(dv, nullptr, CFI_attribute_other, ty, size, 0, nullptr)};
234 return retCode == CFI_SUCCESS ? dv->elem_len : 0;
235}
236
237static void run_CFI_address_tests() {
238 // Test CFI_address defined in 18.5.5.2
239 // Create test world
240 CFI_index_t extents[CFI_MAX_RANK];
241 CFI_CDESC_T(CFI_MAX_RANK) dv_storage;
242 CFI_cdesc_t *dv{&dv_storage};
243 char base;
244 void *dummyAddr{&base};
245 CFI_attribute_t attrCases[]{
246 CFI_attribute_pointer, CFI_attribute_allocatable, CFI_attribute_other};
247 CFI_type_t validTypeCases[]{
248 CFI_type_int, CFI_type_struct, CFI_type_double, CFI_type_char};
249 CFI_index_t subscripts[CFI_MAX_RANK];
250 CFI_index_t negativeLowerBounds[CFI_MAX_RANK];
251 CFI_index_t zeroLowerBounds[CFI_MAX_RANK];
252 CFI_index_t positiveLowerBounds[CFI_MAX_RANK];
253 CFI_index_t *lowerBoundCases[]{
254 negativeLowerBounds, zeroLowerBounds, positiveLowerBounds};
255 for (int i{0}; i < CFI_MAX_RANK; ++i) {
256 negativeLowerBounds[i] = -1;
257 zeroLowerBounds[i] = 0;
258 positiveLowerBounds[i] = 1;
259 extents[i] = i + 2;
260 subscripts[i] = i + 1;
261 }
262
263 // test for scalar
264 for (CFI_attribute_t attribute : attrCases) {
265 for (CFI_type_t type : validTypeCases) {
266 CFI_establish(dv, dummyAddr, attribute, type, 42, 0, nullptr);
267 check_CFI_address(dv, nullptr);
268 }
269 }
270 // test for arrays
271 CFI_establish(dv, dummyAddr, CFI_attribute_other, CFI_type_int, 0,
272 CFI_MAX_RANK, extents);
273 for (CFI_index_t *lowerBounds : lowerBoundCases) {
274 EstablishLowerBounds(dv, lowerBounds);
275 for (CFI_type_t type : validTypeCases) {
276 for (bool contiguous : {true, false}) {
277 std::size_t size{ByteSize(type, 12)};
278 dv->elem_len = size;
279 for (int i{0}; i < dv->rank; ++i) {
280 dv->dim[i].sm = size + (contiguous ? 0 : dv->elem_len);
281 size = dv->dim[i].sm * dv->dim[i].extent;
282 }
283 for (CFI_attribute_t attribute : attrCases) {
284 dv->attribute = attribute;
285 check_CFI_address(dv, subscripts);
286 }
287 }
288 }
289 }
290 // Test on an assumed size array.
291 CFI_establish(
292 dv, dummyAddr, CFI_attribute_other, CFI_type_int, 0, 3, extents);
293 dv->dim[2].extent = -1;
294 check_CFI_address(dv, subscripts);
295}
296
297static void check_CFI_allocate(CFI_cdesc_t *dv,
298 const CFI_index_t lower_bounds[], const CFI_index_t upper_bounds[],
299 std::size_t elem_len) {
300 // 18.5.5.3
301 // Backup descriptor data for future checks
302 const CFI_rank_t rank{dv->rank};
303 const std::size_t desc_elem_len{dv->elem_len};
304 const CFI_attribute_t attribute{dv->attribute};
305 const CFI_type_t type{dv->type};
306 const void *base_addr{dv->base_addr};
307 const int version{dv->version};
308#ifdef VERBOSE
309 DumpTestWorld(base_addr, attribute, type, elem_len, rank, nullptr);
310#endif
311 int retCode{CFI_allocate(dv, lower_bounds, upper_bounds, elem_len)};
312 Descriptor *desc = reinterpret_cast<Descriptor *>(dv);
313 if (retCode == CFI_SUCCESS) {
314 // check res properties from 18.5.5.3 par 3
315 MATCH(true, dv->base_addr != nullptr);
316 for (int i{0}; i < rank; ++i) {
317 MATCH(lower_bounds[i], dv->dim[i].lower_bound);
318 MATCH(upper_bounds[i], dv->dim[i].extent + dv->dim[i].lower_bound - 1);
319 }
320 if (type == CFI_type_char) {
321 MATCH(elem_len, dv->elem_len);
322 } else {
323 MATCH(true, desc_elem_len == dv->elem_len);
324 }
325 MATCH(true, desc->IsContiguous());
326 } else {
327 MATCH(true, base_addr == dv->base_addr);
328 }
329
330 // Below dv members shall not be altered by CFI_allocate regardless of
331 // success/failure
332 MATCH(true, attribute == dv->attribute);
333 MATCH(true, rank == dv->rank);
334 MATCH(true, type == dv->type);
335 MATCH(true, version == dv->version);
336
337 // Success/failure according to standard
338 int numErr{0};
339 int expectedRetCode{CFI_SUCCESS};
340 if (rank > CFI_MAX_RANK) {
341 ++numErr;
342 expectedRetCode = CFI_INVALID_RANK;
343 }
344 if (type < 0 || type > CFI_TYPE_LAST) {
345 ++numErr;
346 expectedRetCode = CFI_INVALID_TYPE;
347 }
348 if (base_addr != nullptr && attribute == CFI_attribute_allocatable) {
349 // This is less restrictive than 18.5.5.3 arg req for which pointers arg
350 // shall be unassociated. However, this match ALLOCATE behavior
351 // (9.7.3/9.7.4)
352 ++numErr;
353 expectedRetCode = CFI_ERROR_BASE_ADDR_NOT_NULL;
354 }
355 if (attribute != CFI_attribute_pointer &&
356 attribute != CFI_attribute_allocatable) {
357 ++numErr;
358 expectedRetCode = CFI_INVALID_ATTRIBUTE;
359 }
360 if (rank > 0 && (lower_bounds == nullptr || upper_bounds == nullptr)) {
361 ++numErr;
362 expectedRetCode = CFI_INVALID_EXTENT;
363 }
364
365 // Memory allocation failures are unpredictable in this test.
366 if (numErr == 0 && retCode != CFI_SUCCESS) {
367 MATCH(true, retCode == CFI_ERROR_MEM_ALLOCATION);
368 } else if (numErr > 1) {
369 MATCH(true, retCode != CFI_SUCCESS);
370 } else {
371 MATCH(expectedRetCode, retCode);
372 }
373 // clean-up
374 if (retCode == CFI_SUCCESS) {
375 CFI_deallocate(dv);
376 }
377}
378
379static void run_CFI_allocate_tests() {
380 // 18.5.5.3
381 // create test world
382 CFI_CDESC_T(CFI_MAX_RANK) dv_storage;
383 CFI_cdesc_t *dv{&dv_storage};
384 char base;
385 void *dummyAddr{&base};
386 CFI_attribute_t attrCases[]{
387 CFI_attribute_pointer, CFI_attribute_allocatable, CFI_attribute_other};
388 CFI_type_t typeCases[]{CFI_type_int, CFI_type_struct, CFI_type_double,
389 CFI_type_char, CFI_type_other, CFI_TYPE_LAST + 1};
390 void *baseAddrCases[]{dummyAddr, nullptr};
391 CFI_rank_t rankCases[]{0, 1, CFI_MAX_RANK, CFI_MAX_RANK + 1};
392 std::size_t lenCases[]{0, 42};
393 CFI_index_t lb1[CFI_MAX_RANK];
394 CFI_index_t ub1[CFI_MAX_RANK];
395 for (int i{0}; i < CFI_MAX_RANK; ++i) {
396 lb1[i] = -1;
397 ub1[i] = 0;
398 }
399
400 check_CFI_establish(
401 dv, nullptr, CFI_attribute_other, CFI_type_int, 0, 0, nullptr);
402 for (CFI_type_t type : typeCases) {
403 std::size_t ty_len{ByteSize(type, 12)};
404 for (CFI_attribute_t attribute : attrCases) {
405 for (void *base_addr : baseAddrCases) {
406 for (CFI_rank_t rank : rankCases) {
407 for (size_t elem_len : lenCases) {
408 dv->base_addr = base_addr;
409 dv->rank = rank;
410 dv->attribute = attribute;
411 dv->type = type;
412 dv->elem_len = ty_len;
413 check_CFI_allocate(dv, lb1, ub1, elem_len);
414 }
415 }
416 }
417 }
418 }
419}
420
421static void run_CFI_section_tests() {
422 // simple tests
423 bool testPreConditions{true};
424 constexpr CFI_index_t m{5}, n{6}, o{7};
425 constexpr CFI_rank_t rank{3};
426 long long array[o][n][m]; // Fortran A(m,n,o)
427 long long counter{1};
428
429 for (CFI_index_t k{0}; k < o; ++k) {
430 for (CFI_index_t j{0}; j < n; ++j) {
431 for (CFI_index_t i{0}; i < m; ++i) {
432 array[k][j][i] = counter++; // Fortran A(i,j,k)
433 }
434 }
435 }
436 CFI_CDESC_T(rank) sourceStorage;
437 CFI_cdesc_t *source{&sourceStorage};
438 CFI_index_t extent[rank] = {m, n, o};
439 int retCode{CFI_establish(source, &array, CFI_attribute_other,
440 CFI_type_long_long, 0, rank, extent)};
441 testPreConditions &= (retCode == CFI_SUCCESS);
442
443 CFI_index_t lb[rank] = {2, 5, 4};
444 CFI_index_t ub[rank] = {4, 5, 6};
445 CFI_index_t strides[rank] = {2, 0, 2};
446 constexpr CFI_rank_t resultRank{rank - 1};
447
448 CFI_CDESC_T(resultRank) resultStorage;
449 CFI_cdesc_t *result{&resultStorage};
450 retCode = CFI_establish(result, nullptr, CFI_attribute_other,
451 CFI_type_long_long, 0, resultRank, nullptr);
452 testPreConditions &= (retCode == CFI_SUCCESS);
453
454 if (!testPreConditions) {
455 MATCH(true, testPreConditions);
456 return;
457 }
458
459 retCode = CFI_section(
460 result, source, lb, ub, strides); // Fortran B = A(2:4:2, 5:5:0, 4:6:2)
461 MATCH(true, retCode == CFI_SUCCESS);
462
463 const CFI_index_t lbs0{source->dim[0].lower_bound};
464 const CFI_index_t lbs1{source->dim[1].lower_bound};
465 const CFI_index_t lbs2{source->dim[2].lower_bound};
466
467 CFI_index_t resJ{result->dim[1].lower_bound};
468 for (CFI_index_t k{lb[2]}; k <= ub[2]; k += strides[2]) {
469 for (CFI_index_t j{lb[1]}; j <= ub[1]; j += strides[1] ? strides[1] : 1) {
470 CFI_index_t resI{result->dim[0].lower_bound};
471 for (CFI_index_t i{lb[0]}; i <= ub[0]; i += strides[0]) {
472 // check A(i,j,k) == B(resI, resJ) == array[k-1][j-1][i-1]
473 const CFI_index_t resSubcripts[]{resI, resJ};
474 const CFI_index_t srcSubcripts[]{i, j, k};
475 MATCH(true,
476 CFI_address(source, srcSubcripts) ==
477 CFI_address(result, resSubcripts));
478 MATCH(true,
479 CFI_address(source, srcSubcripts) ==
480 &array[k - lbs2][j - lbs1][i - lbs0]);
481 ++resI;
482 }
483 }
484 ++resJ;
485 }
486
487 strides[0] = -1;
488 lb[0] = 4;
489 ub[0] = 2;
490 retCode = CFI_section(
491 result, source, lb, ub, strides); // Fortran B = A(4:2:-1, 5:5:0, 4:6:2)
492 MATCH(true, retCode == CFI_SUCCESS);
493
494 resJ = result->dim[1].lower_bound;
495 for (CFI_index_t k{lb[2]}; k <= ub[2]; k += strides[2]) {
496 for (CFI_index_t j{lb[1]}; j <= ub[1]; j += 1) {
497 CFI_index_t resI{result->dim[1].lower_bound + result->dim[0].extent - 1};
498 for (CFI_index_t i{2}; i <= 4; ++i) {
499 // check A(i,j,k) == B(resI, resJ) == array[k-1][j-1][i-1]
500 const CFI_index_t resSubcripts[]{resI, resJ};
501 const CFI_index_t srcSubcripts[]{i, j, k};
502 MATCH(true,
503 CFI_address(source, srcSubcripts) ==
504 CFI_address(result, resSubcripts));
505 MATCH(true,
506 CFI_address(source, srcSubcripts) ==
507 &array[k - lbs2][j - lbs1][i - lbs0]);
508 --resI;
509 }
510 }
511 ++resJ;
512 }
513}
514
515static void run_CFI_select_part_tests() {
516 constexpr std::size_t name_len{5};
517 typedef struct {
518 double distance;
519 int stars;
520 char name[name_len];
521 } Galaxy;
522
523 const CFI_rank_t rank{2};
524 constexpr CFI_index_t universeSize[]{2, 3};
525 Galaxy universe[universeSize[1]][universeSize[0]];
526
527 for (int i{0}; i < universeSize[1]; ++i) {
528 for (int j{0}; j < universeSize[0]; ++j) {
529 // Initializing Fortran var universe(j,i)
530 universe[i][j].distance = j + i * 32;
531 universe[i][j].stars = j * 2 + i * 64;
532 universe[i][j].name[2] = static_cast<char>(j);
533 universe[i][j].name[3] = static_cast<char>(i);
534 }
535 }
536
537 CFI_CDESC_T(rank) resStorage, srcStorage;
538 CFI_cdesc_t *result{&resStorage};
539 CFI_cdesc_t *source{&srcStorage};
540
541 bool testPreConditions{true};
542 int retCode{CFI_establish(result, nullptr, CFI_attribute_other, CFI_type_int,
543 sizeof(int), rank, nullptr)};
544 testPreConditions &= (retCode == CFI_SUCCESS);
545 retCode = CFI_establish(source, &universe, CFI_attribute_other,
546 CFI_type_struct, sizeof(Galaxy), rank, universeSize);
547 testPreConditions &= (retCode == CFI_SUCCESS);
548 if (!testPreConditions) {
549 MATCH(true, testPreConditions);
550 return;
551 }
552
553 std::size_t displacement{offsetof(Galaxy, stars)};
554 std::size_t elem_len{0}; // ignored
555 retCode = CFI_select_part(result, source, displacement, elem_len);
556 MATCH(CFI_SUCCESS, retCode);
557
558 bool baseAddrShiftedOk{
559 static_cast<char *>(source->base_addr) + displacement ==
560 result->base_addr};
561 MATCH(true, baseAddrShiftedOk);
562 if (!baseAddrShiftedOk) {
563 return;
564 }
565
566 MATCH(sizeof(int), result->elem_len);
567 for (CFI_index_t j{0}; j < universeSize[1]; ++j) {
568 for (CFI_index_t i{0}; i < universeSize[0]; ++i) {
569 CFI_index_t subscripts[]{
570 result->dim[0].lower_bound + i, result->dim[1].lower_bound + j};
571 MATCH(
572 i * 2 + j * 64, *static_cast<int *>(CFI_address(result, subscripts)));
573 }
574 }
575
576 // Test for Fortran character type
577 retCode = CFI_establish(
578 result, nullptr, CFI_attribute_other, CFI_type_char, 2, rank, nullptr);
579 testPreConditions &= (retCode == CFI_SUCCESS);
580 if (!testPreConditions) {
581 MATCH(true, testPreConditions);
582 return;
583 }
584
585 displacement = offsetof(Galaxy, name) + 2;
586 elem_len = 2; // not ignored this time
587 retCode = CFI_select_part(result, source, displacement, elem_len);
588 MATCH(CFI_SUCCESS, retCode);
589
590 baseAddrShiftedOk = static_cast<char *>(source->base_addr) + displacement ==
591 result->base_addr;
592 MATCH(true, baseAddrShiftedOk);
593 if (!baseAddrShiftedOk) {
594 return;
595 }
596
597 MATCH(elem_len, result->elem_len);
598 for (CFI_index_t j{0}; j < universeSize[1]; ++j) {
599 for (CFI_index_t i{0}; i < universeSize[0]; ++i) {
600 CFI_index_t subscripts[]{
601 result->dim[0].lower_bound + i, result->dim[1].lower_bound + j};
602 MATCH(static_cast<char>(i),
603 static_cast<char *>(CFI_address(result, subscripts))[0]);
604 MATCH(static_cast<char>(j),
605 static_cast<char *>(CFI_address(result, subscripts))[1]);
606 }
607 }
608}
609
610static void run_CFI_setpointer_tests() {
611 constexpr CFI_rank_t rank{3};
612 CFI_CDESC_T(rank) resStorage, srcStorage;
613 CFI_cdesc_t *result{&resStorage};
614 CFI_cdesc_t *source{&srcStorage};
615 CFI_index_t lower_bounds[rank];
616 CFI_index_t extents[rank];
617 for (int i{0}; i < rank; ++i) {
618 lower_bounds[i] = i;
619 extents[i] = 2;
620 }
621
622 char target;
623 char *dummyBaseAddress{&target};
624 bool testPreConditions{true};
625 CFI_type_t type{CFI_type_int};
626 std::size_t elem_len{ByteSize(type, 42)};
627 int retCode{CFI_establish(
628 result, nullptr, CFI_attribute_pointer, type, elem_len, rank, nullptr)};
629 testPreConditions &= (retCode == CFI_SUCCESS);
630 retCode = CFI_establish(source, dummyBaseAddress, CFI_attribute_other, type,
631 elem_len, rank, extents);
632 testPreConditions &= (retCode == CFI_SUCCESS);
633 if (!testPreConditions) {
634 MATCH(true, testPreConditions);
635 return;
636 }
637
638 retCode = CFI_setpointer(result, source, lower_bounds);
639 MATCH(CFI_SUCCESS, retCode);
640
641 // The following members must be invariant
642 MATCH(rank, result->rank);
643 MATCH(elem_len, result->elem_len);
644 MATCH(type, result->type);
645 // check pointer association
646 MATCH(true, result->base_addr == source->base_addr);
647 for (int j{0}; j < rank; ++j) {
648 MATCH(source->dim[j].extent, result->dim[j].extent);
649 MATCH(source->dim[j].sm, result->dim[j].sm);
650 MATCH(lower_bounds[j], result->dim[j].lower_bound);
651 }
652}
653
654static void run_CFI_is_contiguous_tests() {
655 // INTEGER :: A(0:3,0:3)
656 constexpr CFI_rank_t rank{2};
657 CFI_index_t extents[rank] = {4, 4};
658 CFI_CDESC_T(rank) dv_storage;
659 CFI_cdesc_t *dv{&dv_storage};
660 Descriptor *dvDesc{reinterpret_cast<Descriptor *>(dv)};
661 char base;
662 void *base_addr{&base};
663 int retCode{CFI_establish(dv, base_addr, CFI_attribute_other, CFI_type_int,
664 /*elem_len=*/0, rank, extents)};
665 MATCH(retCode == CFI_SUCCESS, true);
666
667 MATCH(true, CFI_is_contiguous(dv) == 1);
668 MATCH(true, dvDesc->IsContiguous());
669
670 CFI_CDESC_T(rank) sectionDescriptorStorage;
671 CFI_cdesc_t *section{&sectionDescriptorStorage};
672 Descriptor *sectionDesc{reinterpret_cast<Descriptor *>(section)};
673 retCode = CFI_establish(section, base_addr, CFI_attribute_other, CFI_type_int,
674 /*elem_len=*/0, rank, extents);
675 MATCH(retCode == CFI_SUCCESS, true);
676
677 // Test empty section B = A(0:3:2,0:3:-2) is contiguous.
678 CFI_index_t lb[rank] = {0, 0};
679 CFI_index_t ub[rank] = {3, 3};
680 CFI_index_t strides[rank] = {2, -2};
681 retCode = CFI_section(section, dv, lb, ub, strides);
682 MATCH(true, retCode == CFI_SUCCESS);
683 MATCH(true, CFI_is_contiguous(section) == 1);
684 MATCH(true, sectionDesc->IsContiguous());
685
686 // Test 1 element section B = A(0:1:2,0:1:2) is contiguous.
687 lb[0] = 0;
688 lb[1] = 0;
689 ub[0] = 1;
690 ub[1] = 1;
691 strides[0] = 2;
692 strides[1] = 2;
693 retCode = CFI_section(section, dv, lb, ub, strides);
694 MATCH(true, retCode == CFI_SUCCESS);
695 MATCH(true, CFI_is_contiguous(section) == 1);
696 MATCH(true, sectionDesc->IsContiguous());
697
698 // Test section B = A(0:3:1,0:2:1) is contiguous.
699 lb[0] = 0;
700 lb[1] = 0;
701 ub[0] = 3;
702 ub[1] = 2;
703 strides[0] = 1;
704 strides[1] = 1;
705 retCode = CFI_section(section, dv, lb, ub, strides);
706 sectionDesc->Dump();
707 MATCH(true, retCode == CFI_SUCCESS);
708 MATCH(true, CFI_is_contiguous(section) == 1);
709 MATCH(true, sectionDesc->IsContiguous());
710
711 // Test section B = A(0:2:1,0:2:1) is not contiguous.
712 lb[0] = 0;
713 lb[1] = 0;
714 ub[0] = 2;
715 ub[1] = 2;
716 strides[0] = 1;
717 strides[1] = 1;
718 retCode = CFI_section(section, dv, lb, ub, strides);
719 sectionDesc->Dump();
720 MATCH(true, retCode == CFI_SUCCESS);
721 MATCH(true, CFI_is_contiguous(section) == 0);
722 MATCH(false, sectionDesc->IsContiguous());
723
724 // Test section B = A(0:3:2,0:3:1) is not contiguous.
725 lb[0] = 0;
726 lb[1] = 0;
727 ub[0] = 3;
728 ub[1] = 3;
729 strides[0] = 2;
730 strides[1] = 1;
731 retCode = CFI_section(section, dv, lb, ub, strides);
732 MATCH(true, retCode == CFI_SUCCESS);
733 MATCH(true, CFI_is_contiguous(section) == 0);
734 MATCH(false, sectionDesc->IsContiguous());
735
736 // Test section B = A(0:3:1,0:3:2) is not contiguous.
737 lb[0] = 0;
738 lb[1] = 0;
739 ub[0] = 3;
740 ub[1] = 3;
741 strides[0] = 1;
742 strides[1] = 2;
743 retCode = CFI_section(section, dv, lb, ub, strides);
744 MATCH(true, retCode == CFI_SUCCESS);
745 MATCH(true, CFI_is_contiguous(section) == 0);
746 MATCH(false, sectionDesc->IsContiguous());
747
748 // Test section B = A(0:3:1,0:0:2) is contiguous.
749 lb[0] = 0;
750 lb[1] = 0;
751 ub[0] = 3;
752 ub[1] = 0;
753 strides[0] = 1;
754 strides[1] = 2;
755 retCode = CFI_section(section, dv, lb, ub, strides);
756 MATCH(true, retCode == CFI_SUCCESS);
757 MATCH(true, CFI_is_contiguous(section) == 1);
758 MATCH(true, sectionDesc->IsContiguous());
759
760 // INTEGER :: C(0:0, 0:3)
761 CFI_index_t c_extents[rank] = {1, 4};
762 CFI_CDESC_T(rank) c_dv_storage;
763 CFI_cdesc_t *cdv{&c_dv_storage};
764 retCode = CFI_establish(cdv, base_addr, CFI_attribute_other, CFI_type_int,
765 /*elem_len=*/0, rank, c_extents);
766 MATCH(retCode == CFI_SUCCESS, true);
767
768 // Test section B = C(0:0:2, 0:3:1) is contiguous.
769 lb[0] = 0;
770 lb[1] = 0;
771 ub[0] = 0;
772 ub[1] = 3;
773 strides[0] = 2;
774 strides[1] = 1;
775 retCode = CFI_section(section, cdv, lb, ub, strides);
776 MATCH(true, retCode == CFI_SUCCESS);
777 MATCH(true, CFI_is_contiguous(section) == 1);
778 MATCH(true, sectionDesc->IsContiguous());
779}
780
781int main() {
782 TestCdescMacroForAllRanksSmallerThan<CFI_MAX_RANK>();
783 run_CFI_establish_tests();
784 run_CFI_address_tests();
785 run_CFI_allocate_tests();
786 // TODO: test CFI_deallocate
787 run_CFI_is_contiguous_tests();
788 run_CFI_section_tests();
789 run_CFI_select_part_tests();
790 run_CFI_setpointer_tests();
791 return testing::Complete();
792}
793

source code of flang-rt/unittests/Evaluate/ISO-Fortran-binding.cpp