1 //===-- runtime/ISO_Fortran_binding.cpp -----------------------------------===// 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 // Implements the required interoperability API from ISO_Fortran_binding.h 10 // as specified in section 18.5.5 of Fortran 2018. 11 12 #include "flang/ISO_Fortran_binding.h" 13 #include "flang/Runtime/descriptor.h" 14 #include <cstdlib> 15 16 namespace Fortran::ISO { 17 extern "C" { 18 19 static inline constexpr bool IsCharacterType(CFI_type_t ty) { 20 return ty == CFI_type_char || ty == CFI_type_char16_t || 21 ty == CFI_type_char32_t; 22 } 23 static inline constexpr bool IsAssumedSize(const CFI_cdesc_t *dv) { 24 return dv->rank > 0 && dv->dim[dv->rank - 1].extent == -1; 25 } 26 27 void *CFI_address( 28 const CFI_cdesc_t *descriptor, const CFI_index_t subscripts[]) { 29 char *p{static_cast<char *>(descriptor->base_addr)}; 30 const CFI_rank_t rank{descriptor->rank}; 31 const CFI_dim_t *dim{descriptor->dim}; 32 for (CFI_rank_t j{0}; j < rank; ++j, ++dim) { 33 p += (subscripts[j] - dim->lower_bound) * dim->sm; 34 } 35 return p; 36 } 37 38 int CFI_allocate(CFI_cdesc_t *descriptor, const CFI_index_t lower_bounds[], 39 const CFI_index_t upper_bounds[], std::size_t elem_len) { 40 if (!descriptor) { 41 return CFI_INVALID_DESCRIPTOR; 42 } 43 if (descriptor->version != CFI_VERSION) { 44 return CFI_INVALID_DESCRIPTOR; 45 } 46 if (descriptor->attribute != CFI_attribute_allocatable && 47 descriptor->attribute != CFI_attribute_pointer) { 48 // Non-interoperable object 49 return CFI_INVALID_ATTRIBUTE; 50 } 51 if (descriptor->attribute == CFI_attribute_allocatable && 52 descriptor->base_addr) { 53 return CFI_ERROR_BASE_ADDR_NOT_NULL; 54 } 55 if (descriptor->rank > CFI_MAX_RANK) { 56 return CFI_INVALID_RANK; 57 } 58 if (descriptor->type < CFI_type_signed_char || 59 descriptor->type > CFI_TYPE_LAST) { 60 return CFI_INVALID_TYPE; 61 } 62 if (!IsCharacterType(descriptor->type)) { 63 elem_len = descriptor->elem_len; 64 if (elem_len <= 0) { 65 return CFI_INVALID_ELEM_LEN; 66 } 67 } 68 std::size_t rank{descriptor->rank}; 69 CFI_dim_t *dim{descriptor->dim}; 70 std::size_t byteSize{elem_len}; 71 for (std::size_t j{0}; j < rank; ++j, ++dim) { 72 CFI_index_t lb{lower_bounds[j]}; 73 CFI_index_t ub{upper_bounds[j]}; 74 CFI_index_t extent{ub >= lb ? ub - lb + 1 : 0}; 75 dim->lower_bound = lb; 76 dim->extent = extent; 77 dim->sm = byteSize; 78 byteSize *= extent; 79 } 80 void *p{std::malloc(byteSize)}; 81 if (!p && byteSize) { 82 return CFI_ERROR_MEM_ALLOCATION; 83 } 84 descriptor->base_addr = p; 85 descriptor->elem_len = elem_len; 86 return CFI_SUCCESS; 87 } 88 89 int CFI_deallocate(CFI_cdesc_t *descriptor) { 90 if (!descriptor) { 91 return CFI_INVALID_DESCRIPTOR; 92 } 93 if (descriptor->version != CFI_VERSION) { 94 return CFI_INVALID_DESCRIPTOR; 95 } 96 if (descriptor->attribute != CFI_attribute_allocatable && 97 descriptor->attribute != CFI_attribute_pointer) { 98 // Non-interoperable object 99 return CFI_INVALID_DESCRIPTOR; 100 } 101 if (!descriptor->base_addr) { 102 return CFI_ERROR_BASE_ADDR_NULL; 103 } 104 std::free(descriptor->base_addr); 105 descriptor->base_addr = nullptr; 106 return CFI_SUCCESS; 107 } 108 109 static constexpr std::size_t MinElemLen(CFI_type_t type) { 110 std::size_t minElemLen{0}; 111 switch (type) { 112 case CFI_type_signed_char: 113 minElemLen = sizeof(signed char); 114 break; 115 case CFI_type_short: 116 minElemLen = sizeof(short); 117 break; 118 case CFI_type_int: 119 minElemLen = sizeof(int); 120 break; 121 case CFI_type_long: 122 minElemLen = sizeof(long); 123 break; 124 case CFI_type_long_long: 125 minElemLen = sizeof(long long); 126 break; 127 case CFI_type_size_t: 128 minElemLen = sizeof(std::size_t); 129 break; 130 case CFI_type_int8_t: 131 minElemLen = sizeof(std::int8_t); 132 break; 133 case CFI_type_int16_t: 134 minElemLen = sizeof(std::int16_t); 135 break; 136 case CFI_type_int32_t: 137 minElemLen = sizeof(std::int32_t); 138 break; 139 case CFI_type_int64_t: 140 minElemLen = sizeof(std::int64_t); 141 break; 142 case CFI_type_int128_t: 143 minElemLen = 2 * sizeof(std::int64_t); 144 break; 145 case CFI_type_int_least8_t: 146 minElemLen = sizeof(std::int_least8_t); 147 break; 148 case CFI_type_int_least16_t: 149 minElemLen = sizeof(std::int_least16_t); 150 break; 151 case CFI_type_int_least32_t: 152 minElemLen = sizeof(std::int_least32_t); 153 break; 154 case CFI_type_int_least64_t: 155 minElemLen = sizeof(std::int_least64_t); 156 break; 157 case CFI_type_int_least128_t: 158 minElemLen = 2 * sizeof(std::int_least64_t); 159 break; 160 case CFI_type_int_fast8_t: 161 minElemLen = sizeof(std::int_fast8_t); 162 break; 163 case CFI_type_int_fast16_t: 164 minElemLen = sizeof(std::int_fast16_t); 165 break; 166 case CFI_type_int_fast32_t: 167 minElemLen = sizeof(std::int_fast32_t); 168 break; 169 case CFI_type_int_fast64_t: 170 minElemLen = sizeof(std::int_fast64_t); 171 break; 172 case CFI_type_intmax_t: 173 minElemLen = sizeof(std::intmax_t); 174 break; 175 case CFI_type_intptr_t: 176 minElemLen = sizeof(std::intptr_t); 177 break; 178 case CFI_type_ptrdiff_t: 179 minElemLen = sizeof(std::ptrdiff_t); 180 break; 181 case CFI_type_half_float: 182 minElemLen = 2; 183 break; 184 case CFI_type_bfloat: 185 minElemLen = 2; 186 break; 187 case CFI_type_float: 188 minElemLen = sizeof(float); 189 break; 190 case CFI_type_double: 191 minElemLen = sizeof(double); 192 break; 193 case CFI_type_extended_double: 194 minElemLen = 10; 195 break; 196 case CFI_type_long_double: 197 minElemLen = sizeof(long double); 198 break; 199 case CFI_type_float128: 200 minElemLen = 16; 201 break; 202 case CFI_type_half_float_Complex: 203 minElemLen = 2 * MinElemLen(CFI_type_half_float); 204 break; 205 case CFI_type_bfloat_Complex: 206 minElemLen = 2 * MinElemLen(CFI_type_bfloat); 207 break; 208 case CFI_type_float_Complex: 209 minElemLen = 2 * sizeof(float); 210 break; 211 case CFI_type_double_Complex: 212 minElemLen = 2 * sizeof(double); 213 break; 214 case CFI_type_extended_double_Complex: 215 minElemLen = 2 * MinElemLen(CFI_type_extended_double); 216 break; 217 case CFI_type_long_double_Complex: 218 minElemLen = 2 * sizeof(long double); 219 break; 220 case CFI_type_float128_Complex: 221 minElemLen = 2 * MinElemLen(CFI_type_float128); 222 break; 223 case CFI_type_Bool: 224 minElemLen = 1; 225 break; 226 case CFI_type_cptr: 227 minElemLen = sizeof(void *); 228 break; 229 case CFI_type_char16_t: 230 minElemLen = sizeof(char16_t); 231 break; 232 case CFI_type_char32_t: 233 minElemLen = sizeof(char32_t); 234 break; 235 } 236 return minElemLen; 237 } 238 239 int CFI_establish(CFI_cdesc_t *descriptor, void *base_addr, 240 CFI_attribute_t attribute, CFI_type_t type, std::size_t elem_len, 241 CFI_rank_t rank, const CFI_index_t extents[]) { 242 if (attribute != CFI_attribute_other && attribute != CFI_attribute_pointer && 243 attribute != CFI_attribute_allocatable) { 244 return CFI_INVALID_ATTRIBUTE; 245 } 246 if (rank > CFI_MAX_RANK) { 247 return CFI_INVALID_RANK; 248 } 249 if (base_addr && attribute == CFI_attribute_allocatable) { 250 return CFI_ERROR_BASE_ADDR_NOT_NULL; 251 } 252 if (rank > 0 && base_addr && !extents) { 253 return CFI_INVALID_EXTENT; 254 } 255 if (type < CFI_type_signed_char || type > CFI_TYPE_LAST) { 256 return CFI_INVALID_TYPE; 257 } 258 if (!descriptor) { 259 return CFI_INVALID_DESCRIPTOR; 260 } 261 if (type == CFI_type_struct || type == CFI_type_other || 262 IsCharacterType(type)) { 263 if (elem_len <= 0) { 264 return CFI_INVALID_ELEM_LEN; 265 } 266 } else { 267 elem_len = MinElemLen(type); 268 assert(elem_len > 0 && "Unknown element length for type"); 269 } 270 descriptor->base_addr = base_addr; 271 descriptor->elem_len = elem_len; 272 descriptor->version = CFI_VERSION; 273 descriptor->rank = rank; 274 descriptor->type = type; 275 descriptor->attribute = attribute; 276 descriptor->f18Addendum = 0; 277 std::size_t byteSize{elem_len}; 278 constexpr std::size_t lower_bound{0}; 279 if (base_addr) { 280 for (std::size_t j{0}; j < rank; ++j) { 281 descriptor->dim[j].lower_bound = lower_bound; 282 descriptor->dim[j].extent = extents[j]; 283 descriptor->dim[j].sm = byteSize; 284 byteSize *= extents[j]; 285 } 286 } 287 return CFI_SUCCESS; 288 } 289 290 int CFI_is_contiguous(const CFI_cdesc_t *descriptor) { 291 CFI_index_t bytes = descriptor->elem_len; 292 for (int j{0}; j < descriptor->rank; ++j) { 293 if (bytes != descriptor->dim[j].sm) { 294 return 0; 295 } 296 bytes *= descriptor->dim[j].extent; 297 } 298 return 1; 299 } 300 301 int CFI_section(CFI_cdesc_t *result, const CFI_cdesc_t *source, 302 const CFI_index_t lower_bounds[], const CFI_index_t upper_bounds[], 303 const CFI_index_t strides[]) { 304 CFI_index_t extent[CFI_MAX_RANK]; 305 CFI_index_t actualStride[CFI_MAX_RANK]; 306 CFI_rank_t resRank{0}; 307 308 if (!result || !source) { 309 return CFI_INVALID_DESCRIPTOR; 310 } 311 if (source->rank == 0) { 312 return CFI_INVALID_RANK; 313 } 314 if (IsAssumedSize(source) && !upper_bounds) { 315 return CFI_INVALID_DESCRIPTOR; 316 } 317 if ((result->type != source->type) || 318 (result->elem_len != source->elem_len)) { 319 return CFI_INVALID_DESCRIPTOR; 320 } 321 if (result->attribute == CFI_attribute_allocatable) { 322 return CFI_INVALID_ATTRIBUTE; 323 } 324 if (!source->base_addr) { 325 return CFI_ERROR_BASE_ADDR_NULL; 326 } 327 328 char *shiftedBaseAddr{static_cast<char *>(source->base_addr)}; 329 bool isZeroSized{false}; 330 for (int j{0}; j < source->rank; ++j) { 331 const CFI_dim_t &dim{source->dim[j]}; 332 const CFI_index_t srcLB{dim.lower_bound}; 333 const CFI_index_t srcUB{srcLB + dim.extent - 1}; 334 const CFI_index_t lb{lower_bounds ? lower_bounds[j] : srcLB}; 335 const CFI_index_t ub{upper_bounds ? upper_bounds[j] : srcUB}; 336 const CFI_index_t stride{strides ? strides[j] : 1}; 337 338 if (stride == 0 && lb != ub) { 339 return CFI_ERROR_OUT_OF_BOUNDS; 340 } 341 if ((lb <= ub && stride >= 0) || (lb >= ub && stride < 0)) { 342 if ((lb < srcLB) || (lb > srcUB) || (ub < srcLB) || (ub > srcUB)) { 343 return CFI_ERROR_OUT_OF_BOUNDS; 344 } 345 shiftedBaseAddr += (lb - srcLB) * dim.sm; 346 extent[j] = stride != 0 ? 1 + (ub - lb) / stride : 1; 347 } else { 348 isZeroSized = true; 349 extent[j] = 0; 350 } 351 actualStride[j] = stride; 352 resRank += (stride != 0); 353 } 354 if (resRank != result->rank) { 355 return CFI_INVALID_DESCRIPTOR; 356 } 357 358 // For zero-sized arrays, base_addr is processor-dependent (see 18.5.3). 359 // We keep it on the source base_addr 360 result->base_addr = isZeroSized ? source->base_addr : shiftedBaseAddr; 361 resRank = 0; 362 for (int j{0}; j < source->rank; ++j) { 363 if (actualStride[j] != 0) { 364 result->dim[resRank].lower_bound = 0; 365 result->dim[resRank].extent = extent[j]; 366 result->dim[resRank].sm = actualStride[j] * source->dim[j].sm; 367 ++resRank; 368 } 369 } 370 return CFI_SUCCESS; 371 } 372 373 int CFI_select_part(CFI_cdesc_t *result, const CFI_cdesc_t *source, 374 std::size_t displacement, std::size_t elem_len) { 375 if (!result || !source) { 376 return CFI_INVALID_DESCRIPTOR; 377 } 378 if (result->rank != source->rank) { 379 return CFI_INVALID_RANK; 380 } 381 if (result->attribute == CFI_attribute_allocatable) { 382 return CFI_INVALID_ATTRIBUTE; 383 } 384 if (!source->base_addr) { 385 return CFI_ERROR_BASE_ADDR_NULL; 386 } 387 if (IsAssumedSize(source)) { 388 return CFI_INVALID_DESCRIPTOR; 389 } 390 391 if (!IsCharacterType(result->type)) { 392 elem_len = result->elem_len; 393 } 394 if (displacement + elem_len > source->elem_len) { 395 return CFI_INVALID_ELEM_LEN; 396 } 397 398 result->base_addr = displacement + static_cast<char *>(source->base_addr); 399 result->elem_len = elem_len; 400 for (int j{0}; j < source->rank; ++j) { 401 result->dim[j].lower_bound = 0; 402 result->dim[j].extent = source->dim[j].extent; 403 result->dim[j].sm = source->dim[j].sm; 404 } 405 return CFI_SUCCESS; 406 } 407 408 int CFI_setpointer(CFI_cdesc_t *result, const CFI_cdesc_t *source, 409 const CFI_index_t lower_bounds[]) { 410 if (!result) { 411 return CFI_INVALID_DESCRIPTOR; 412 } 413 if (result->attribute != CFI_attribute_pointer) { 414 return CFI_INVALID_ATTRIBUTE; 415 } 416 if (!source) { 417 result->base_addr = nullptr; 418 return CFI_SUCCESS; 419 } 420 if (source->rank != result->rank) { 421 return CFI_INVALID_RANK; 422 } 423 if (source->type != result->type) { 424 return CFI_INVALID_TYPE; 425 } 426 if (source->elem_len != result->elem_len) { 427 return CFI_INVALID_ELEM_LEN; 428 } 429 if (!source->base_addr && source->attribute != CFI_attribute_pointer) { 430 return CFI_ERROR_BASE_ADDR_NULL; 431 } 432 if (IsAssumedSize(source)) { 433 return CFI_INVALID_DESCRIPTOR; 434 } 435 436 const bool copySrcLB{!lower_bounds}; 437 result->base_addr = source->base_addr; 438 if (source->base_addr) { 439 for (int j{0}; j < result->rank; ++j) { 440 result->dim[j].extent = source->dim[j].extent; 441 result->dim[j].sm = source->dim[j].sm; 442 result->dim[j].lower_bound = 443 copySrcLB ? source->dim[j].lower_bound : lower_bounds[j]; 444 } 445 } 446 return CFI_SUCCESS; 447 } 448 } // extern "C" 449 } // namespace Fortran::ISO 450