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 "../include/flang/ISO_Fortran_binding.h" 13 #include "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 } else { 242 elem_len = MinElemLen(type); 243 assert(elem_len > 0 && "Unknown element length for type"); 244 } 245 descriptor->base_addr = base_addr; 246 descriptor->elem_len = elem_len; 247 descriptor->version = CFI_VERSION; 248 descriptor->rank = rank; 249 descriptor->type = type; 250 descriptor->attribute = attribute; 251 descriptor->f18Addendum = 0; 252 std::size_t byteSize{elem_len}; 253 constexpr std::size_t lower_bound{0}; 254 if (base_addr) { 255 for (std::size_t j{0}; j < rank; ++j) { 256 descriptor->dim[j].lower_bound = lower_bound; 257 descriptor->dim[j].extent = extents[j]; 258 descriptor->dim[j].sm = byteSize; 259 byteSize *= extents[j]; 260 } 261 } 262 return CFI_SUCCESS; 263 } 264 265 int CFI_is_contiguous(const CFI_cdesc_t *descriptor) { 266 CFI_index_t bytes = descriptor->elem_len; 267 for (int j{0}; j < descriptor->rank; ++j) { 268 if (bytes != descriptor->dim[j].sm) { 269 return 0; 270 } 271 bytes *= descriptor->dim[j].extent; 272 } 273 return 1; 274 } 275 276 int CFI_section(CFI_cdesc_t *result, const CFI_cdesc_t *source, 277 const CFI_index_t lower_bounds[], const CFI_index_t upper_bounds[], 278 const CFI_index_t strides[]) { 279 CFI_index_t extent[CFI_MAX_RANK]; 280 CFI_index_t actualStride[CFI_MAX_RANK]; 281 CFI_rank_t resRank{0}; 282 283 if (!result || !source) { 284 return CFI_INVALID_DESCRIPTOR; 285 } 286 if (source->rank == 0) { 287 return CFI_INVALID_RANK; 288 } 289 if (IsAssumedSize(source) && !upper_bounds) { 290 return CFI_INVALID_DESCRIPTOR; 291 } 292 if ((result->type != source->type) || 293 (result->elem_len != source->elem_len)) { 294 return CFI_INVALID_DESCRIPTOR; 295 } 296 if (result->attribute == CFI_attribute_allocatable) { 297 return CFI_INVALID_ATTRIBUTE; 298 } 299 if (!source->base_addr) { 300 return CFI_ERROR_BASE_ADDR_NULL; 301 } 302 303 char *shiftedBaseAddr{static_cast<char *>(source->base_addr)}; 304 bool isZeroSized{false}; 305 for (int j{0}; j < source->rank; ++j) { 306 const CFI_dim_t &dim{source->dim[j]}; 307 const CFI_index_t srcLB{dim.lower_bound}; 308 const CFI_index_t srcUB{srcLB + dim.extent - 1}; 309 const CFI_index_t lb{lower_bounds ? lower_bounds[j] : srcLB}; 310 const CFI_index_t ub{upper_bounds ? upper_bounds[j] : srcUB}; 311 const CFI_index_t stride{strides ? strides[j] : 1}; 312 313 if (stride == 0 && lb != ub) { 314 return CFI_ERROR_OUT_OF_BOUNDS; 315 } 316 if ((lb <= ub && stride >= 0) || (lb >= ub && stride < 0)) { 317 if ((lb < srcLB) || (lb > srcUB) || (ub < srcLB) || (ub > srcUB)) { 318 return CFI_ERROR_OUT_OF_BOUNDS; 319 } 320 shiftedBaseAddr += (lb - srcLB) * dim.sm; 321 extent[j] = stride != 0 ? 1 + (ub - lb) / stride : 1; 322 } else { 323 isZeroSized = true; 324 extent[j] = 0; 325 } 326 actualStride[j] = stride; 327 resRank += (stride != 0); 328 } 329 if (resRank != result->rank) { 330 return CFI_INVALID_DESCRIPTOR; 331 } 332 333 // For zero-sized arrays, base_addr is processor-dependent (see 18.5.3). 334 // We keep it on the source base_addr 335 result->base_addr = isZeroSized ? source->base_addr : shiftedBaseAddr; 336 resRank = 0; 337 for (int j{0}; j < source->rank; ++j) { 338 if (actualStride[j] != 0) { 339 result->dim[resRank].lower_bound = 0; 340 result->dim[resRank].extent = extent[j]; 341 result->dim[resRank].sm = actualStride[j] * source->dim[j].sm; 342 ++resRank; 343 } 344 } 345 return CFI_SUCCESS; 346 } 347 348 int CFI_select_part(CFI_cdesc_t *result, const CFI_cdesc_t *source, 349 std::size_t displacement, std::size_t elem_len) { 350 if (!result || !source) { 351 return CFI_INVALID_DESCRIPTOR; 352 } 353 if (result->rank != source->rank) { 354 return CFI_INVALID_RANK; 355 } 356 if (result->attribute == CFI_attribute_allocatable) { 357 return CFI_INVALID_ATTRIBUTE; 358 } 359 if (!source->base_addr) { 360 return CFI_ERROR_BASE_ADDR_NULL; 361 } 362 if (IsAssumedSize(source)) { 363 return CFI_INVALID_DESCRIPTOR; 364 } 365 366 if (!IsCharacterType(result->type)) { 367 elem_len = result->elem_len; 368 } 369 if (displacement + elem_len > source->elem_len) { 370 return CFI_INVALID_ELEM_LEN; 371 } 372 373 result->base_addr = displacement + static_cast<char *>(source->base_addr); 374 result->elem_len = elem_len; 375 for (int j{0}; j < source->rank; ++j) { 376 result->dim[j].lower_bound = 0; 377 result->dim[j].extent = source->dim[j].extent; 378 result->dim[j].sm = source->dim[j].sm; 379 } 380 return CFI_SUCCESS; 381 } 382 383 int CFI_setpointer(CFI_cdesc_t *result, const CFI_cdesc_t *source, 384 const CFI_index_t lower_bounds[]) { 385 if (!result) { 386 return CFI_INVALID_DESCRIPTOR; 387 } 388 if (result->attribute != CFI_attribute_pointer) { 389 return CFI_INVALID_ATTRIBUTE; 390 } 391 if (!source) { 392 result->base_addr = nullptr; 393 return CFI_SUCCESS; 394 } 395 if (source->rank != result->rank) { 396 return CFI_INVALID_RANK; 397 } 398 if (source->type != result->type) { 399 return CFI_INVALID_TYPE; 400 } 401 if (source->elem_len != result->elem_len) { 402 return CFI_INVALID_ELEM_LEN; 403 } 404 if (!source->base_addr && source->attribute != CFI_attribute_pointer) { 405 return CFI_ERROR_BASE_ADDR_NULL; 406 } 407 if (IsAssumedSize(source)) { 408 return CFI_INVALID_DESCRIPTOR; 409 } 410 411 const bool copySrcLB{!lower_bounds}; 412 result->base_addr = source->base_addr; 413 if (source->base_addr) { 414 for (int j{0}; j < result->rank; ++j) { 415 result->dim[j].extent = source->dim[j].extent; 416 result->dim[j].sm = source->dim[j].sm; 417 result->dim[j].lower_bound = 418 copySrcLB ? source->dim[j].lower_bound : lower_bounds[j]; 419 } 420 } 421 return CFI_SUCCESS; 422 } 423 } // extern "C" 424 } // namespace Fortran::ISO 425