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