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