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_float: 182 minElemLen = sizeof(float); 183 break; 184 case CFI_type_double: 185 minElemLen = sizeof(double); 186 break; 187 case CFI_type_long_double: 188 minElemLen = sizeof(long double); 189 break; 190 case CFI_type_float_Complex: 191 minElemLen = 2 * sizeof(float); 192 break; 193 case CFI_type_double_Complex: 194 minElemLen = 2 * sizeof(double); 195 break; 196 case CFI_type_long_double_Complex: 197 minElemLen = 2 * sizeof(long double); 198 break; 199 case CFI_type_Bool: 200 minElemLen = 1; 201 break; 202 case CFI_type_cptr: 203 minElemLen = sizeof(void *); 204 break; 205 case CFI_type_char16_t: 206 minElemLen = sizeof(char16_t); 207 break; 208 case CFI_type_char32_t: 209 minElemLen = sizeof(char32_t); 210 break; 211 } 212 return minElemLen; 213 } 214 215 int CFI_establish(CFI_cdesc_t *descriptor, void *base_addr, 216 CFI_attribute_t attribute, CFI_type_t type, std::size_t elem_len, 217 CFI_rank_t rank, const CFI_index_t extents[]) { 218 if (attribute != CFI_attribute_other && attribute != CFI_attribute_pointer && 219 attribute != CFI_attribute_allocatable) { 220 return CFI_INVALID_ATTRIBUTE; 221 } 222 if (rank > CFI_MAX_RANK) { 223 return CFI_INVALID_RANK; 224 } 225 if (base_addr && attribute == CFI_attribute_allocatable) { 226 return CFI_ERROR_BASE_ADDR_NOT_NULL; 227 } 228 if (rank > 0 && base_addr && !extents) { 229 return CFI_INVALID_EXTENT; 230 } 231 if (type < CFI_type_signed_char || type > CFI_TYPE_LAST) { 232 return CFI_INVALID_TYPE; 233 } 234 if (!descriptor) { 235 return CFI_INVALID_DESCRIPTOR; 236 } 237 if (type == CFI_type_struct || type == CFI_type_other || 238 IsCharacterType(type)) { 239 if (elem_len <= 0) { 240 return CFI_INVALID_ELEM_LEN; 241 } 242 } else { 243 elem_len = MinElemLen(type); 244 assert(elem_len > 0 && "Unknown element length for type"); 245 } 246 descriptor->base_addr = base_addr; 247 descriptor->elem_len = elem_len; 248 descriptor->version = CFI_VERSION; 249 descriptor->rank = rank; 250 descriptor->type = type; 251 descriptor->attribute = attribute; 252 descriptor->f18Addendum = 0; 253 std::size_t byteSize{elem_len}; 254 constexpr std::size_t lower_bound{0}; 255 if (base_addr) { 256 for (std::size_t j{0}; j < rank; ++j) { 257 descriptor->dim[j].lower_bound = lower_bound; 258 descriptor->dim[j].extent = extents[j]; 259 descriptor->dim[j].sm = byteSize; 260 byteSize *= extents[j]; 261 } 262 } 263 return CFI_SUCCESS; 264 } 265 266 int CFI_is_contiguous(const CFI_cdesc_t *descriptor) { 267 CFI_index_t bytes = descriptor->elem_len; 268 for (int j{0}; j < descriptor->rank; ++j) { 269 if (bytes != descriptor->dim[j].sm) { 270 return 0; 271 } 272 bytes *= descriptor->dim[j].extent; 273 } 274 return 1; 275 } 276 277 int CFI_section(CFI_cdesc_t *result, const CFI_cdesc_t *source, 278 const CFI_index_t lower_bounds[], const CFI_index_t upper_bounds[], 279 const CFI_index_t strides[]) { 280 CFI_index_t extent[CFI_MAX_RANK]; 281 CFI_index_t actualStride[CFI_MAX_RANK]; 282 CFI_rank_t resRank{0}; 283 284 if (!result || !source) { 285 return CFI_INVALID_DESCRIPTOR; 286 } 287 if (source->rank == 0) { 288 return CFI_INVALID_RANK; 289 } 290 if (IsAssumedSize(source) && !upper_bounds) { 291 return CFI_INVALID_DESCRIPTOR; 292 } 293 if ((result->type != source->type) || 294 (result->elem_len != source->elem_len)) { 295 return CFI_INVALID_DESCRIPTOR; 296 } 297 if (result->attribute == CFI_attribute_allocatable) { 298 return CFI_INVALID_ATTRIBUTE; 299 } 300 if (!source->base_addr) { 301 return CFI_ERROR_BASE_ADDR_NULL; 302 } 303 304 char *shiftedBaseAddr{static_cast<char *>(source->base_addr)}; 305 bool isZeroSized{false}; 306 for (int j{0}; j < source->rank; ++j) { 307 const CFI_dim_t &dim{source->dim[j]}; 308 const CFI_index_t srcLB{dim.lower_bound}; 309 const CFI_index_t srcUB{srcLB + dim.extent - 1}; 310 const CFI_index_t lb{lower_bounds ? lower_bounds[j] : srcLB}; 311 const CFI_index_t ub{upper_bounds ? upper_bounds[j] : srcUB}; 312 const CFI_index_t stride{strides ? strides[j] : 1}; 313 314 if (stride == 0 && lb != ub) { 315 return CFI_ERROR_OUT_OF_BOUNDS; 316 } 317 if ((lb <= ub && stride >= 0) || (lb >= ub && stride < 0)) { 318 if ((lb < srcLB) || (lb > srcUB) || (ub < srcLB) || (ub > srcUB)) { 319 return CFI_ERROR_OUT_OF_BOUNDS; 320 } 321 shiftedBaseAddr += (lb - srcLB) * dim.sm; 322 extent[j] = stride != 0 ? 1 + (ub - lb) / stride : 1; 323 } else { 324 isZeroSized = true; 325 extent[j] = 0; 326 } 327 actualStride[j] = stride; 328 resRank += (stride != 0); 329 } 330 if (resRank != result->rank) { 331 return CFI_INVALID_DESCRIPTOR; 332 } 333 334 // For zero-sized arrays, base_addr is processor-dependent (see 18.5.3). 335 // We keep it on the source base_addr 336 result->base_addr = isZeroSized ? source->base_addr : shiftedBaseAddr; 337 resRank = 0; 338 for (int j{0}; j < source->rank; ++j) { 339 if (actualStride[j] != 0) { 340 result->dim[resRank].lower_bound = 0; 341 result->dim[resRank].extent = extent[j]; 342 result->dim[resRank].sm = actualStride[j] * source->dim[j].sm; 343 ++resRank; 344 } 345 } 346 return CFI_SUCCESS; 347 } 348 349 int CFI_select_part(CFI_cdesc_t *result, const CFI_cdesc_t *source, 350 std::size_t displacement, std::size_t elem_len) { 351 if (!result || !source) { 352 return CFI_INVALID_DESCRIPTOR; 353 } 354 if (result->rank != source->rank) { 355 return CFI_INVALID_RANK; 356 } 357 if (result->attribute == CFI_attribute_allocatable) { 358 return CFI_INVALID_ATTRIBUTE; 359 } 360 if (!source->base_addr) { 361 return CFI_ERROR_BASE_ADDR_NULL; 362 } 363 if (IsAssumedSize(source)) { 364 return CFI_INVALID_DESCRIPTOR; 365 } 366 367 if (!IsCharacterType(result->type)) { 368 elem_len = result->elem_len; 369 } 370 if (displacement + elem_len > source->elem_len) { 371 return CFI_INVALID_ELEM_LEN; 372 } 373 374 result->base_addr = displacement + static_cast<char *>(source->base_addr); 375 result->elem_len = elem_len; 376 for (int j{0}; j < source->rank; ++j) { 377 result->dim[j].lower_bound = 0; 378 result->dim[j].extent = source->dim[j].extent; 379 result->dim[j].sm = source->dim[j].sm; 380 } 381 return CFI_SUCCESS; 382 } 383 384 int CFI_setpointer(CFI_cdesc_t *result, const CFI_cdesc_t *source, 385 const CFI_index_t lower_bounds[]) { 386 if (!result) { 387 return CFI_INVALID_DESCRIPTOR; 388 } 389 if (result->attribute != CFI_attribute_pointer) { 390 return CFI_INVALID_ATTRIBUTE; 391 } 392 if (!source) { 393 result->base_addr = nullptr; 394 return CFI_SUCCESS; 395 } 396 if (source->rank != result->rank) { 397 return CFI_INVALID_RANK; 398 } 399 if (source->type != result->type) { 400 return CFI_INVALID_TYPE; 401 } 402 if (source->elem_len != result->elem_len) { 403 return CFI_INVALID_ELEM_LEN; 404 } 405 if (!source->base_addr && source->attribute != CFI_attribute_pointer) { 406 return CFI_ERROR_BASE_ADDR_NULL; 407 } 408 if (IsAssumedSize(source)) { 409 return CFI_INVALID_DESCRIPTOR; 410 } 411 412 const bool copySrcLB{!lower_bounds}; 413 result->base_addr = source->base_addr; 414 if (source->base_addr) { 415 for (int j{0}; j < result->rank; ++j) { 416 result->dim[j].extent = source->dim[j].extent; 417 result->dim[j].sm = source->dim[j].sm; 418 result->dim[j].lower_bound = 419 copySrcLB ? source->dim[j].lower_bound : lower_bounds[j]; 420 } 421 } 422 return CFI_SUCCESS; 423 } 424 } // extern "C" 425 } // namespace Fortran::ISO 426