flang/unittests/Evaluate/ISO-Fortran-binding.cpp

   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
   7 using namespace Fortran::runtime;
   8 using namespace Fortran::ISO;
   9
  10 // CFI_CDESC_T test helpers
  11 template <int rank> class Test_CFI_CDESC_T {
  12 public:
  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
  34 private:
  35   static constexpr int rank_{rank};
  36   CFI_CDESC_T(rank) dvStorage_;
  37 };
  38
  39 template <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
  46 template <> void TestCdescMacroForAllRanksSmallerThan<0>() {
  47   Test_CFI_CDESC_T<0> obj;
  48   obj.Check();
  49 }
  50
  51 // CFI_establish test helper
  52 static 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
  69 static 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
  82 static 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
 157 static 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
 204 static 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
 214 static 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
 221 static 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
 229 static 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
 289 static 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
 371 static 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
 413 static 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
 507 static 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
 602 static 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
 646 int main() {
 647   TestCdescMacroForAllRanksSmallerThan<CFI_MAX_RANK>();
 648   run_CFI_establish_tests();
 649   run_CFI_address_tests();
 650   run_CFI_allocate_tests();
 651   // TODO: test CFI_deallocate
 652   // TODO: test CFI_is_contiguous
 653   run_CFI_section_tests();
 654   run_CFI_select_part_tests();
 655   run_CFI_setpointer_tests();
 656   return testing::Complete();
 657 }