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