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

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