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