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 "ISO_Fortran_util.h" 13 #include "terminator.h" 14 #include "flang/ISO_Fortran_binding_wrapper.h" 15 #include "flang/Runtime/descriptor.h" 16 #include "flang/Runtime/type-code.h" 17 #include <cstdlib> 18 19 namespace Fortran::ISO { 20 extern "C" { 21 22 void *CFI_address( 23 const CFI_cdesc_t *descriptor, const CFI_index_t subscripts[]) { 24 char *p{static_cast<char *>(descriptor->base_addr)}; 25 const CFI_rank_t rank{descriptor->rank}; 26 const CFI_dim_t *dim{descriptor->dim}; 27 for (CFI_rank_t j{0}; j < rank; ++j, ++dim) { 28 p += (subscripts[j] - dim->lower_bound) * dim->sm; 29 } 30 return p; 31 } 32 33 int CFI_allocate(CFI_cdesc_t *descriptor, const CFI_index_t lower_bounds[], 34 const CFI_index_t upper_bounds[], std::size_t elem_len) { 35 if (!descriptor) { 36 return CFI_INVALID_DESCRIPTOR; 37 } 38 if (descriptor->version != CFI_VERSION) { 39 return CFI_INVALID_DESCRIPTOR; 40 } 41 if (descriptor->attribute != CFI_attribute_allocatable && 42 descriptor->attribute != CFI_attribute_pointer) { 43 // Non-interoperable object 44 return CFI_INVALID_ATTRIBUTE; 45 } 46 if (descriptor->attribute == CFI_attribute_allocatable && 47 descriptor->base_addr) { 48 return CFI_ERROR_BASE_ADDR_NOT_NULL; 49 } 50 if (descriptor->rank > CFI_MAX_RANK) { 51 return CFI_INVALID_RANK; 52 } 53 if (descriptor->type < CFI_type_signed_char || 54 descriptor->type > CFI_TYPE_LAST) { 55 return CFI_INVALID_TYPE; 56 } 57 if (!IsCharacterType(descriptor->type)) { 58 elem_len = descriptor->elem_len; 59 if (elem_len <= 0) { 60 return CFI_INVALID_ELEM_LEN; 61 } 62 } 63 std::size_t rank{descriptor->rank}; 64 CFI_dim_t *dim{descriptor->dim}; 65 std::size_t byteSize{elem_len}; 66 for (std::size_t j{0}; j < rank; ++j, ++dim) { 67 CFI_index_t lb{lower_bounds[j]}; 68 CFI_index_t ub{upper_bounds[j]}; 69 CFI_index_t extent{ub >= lb ? ub - lb + 1 : 0}; 70 dim->lower_bound = extent == 0 ? 1 : lb; 71 dim->extent = extent; 72 dim->sm = byteSize; 73 byteSize *= extent; 74 } 75 void *p{std::malloc(byteSize)}; 76 if (!p && byteSize) { 77 return CFI_ERROR_MEM_ALLOCATION; 78 } 79 descriptor->base_addr = p; 80 descriptor->elem_len = elem_len; 81 return CFI_SUCCESS; 82 } 83 84 int CFI_deallocate(CFI_cdesc_t *descriptor) { 85 if (!descriptor) { 86 return CFI_INVALID_DESCRIPTOR; 87 } 88 if (descriptor->version != CFI_VERSION) { 89 return CFI_INVALID_DESCRIPTOR; 90 } 91 if (descriptor->attribute != CFI_attribute_allocatable && 92 descriptor->attribute != CFI_attribute_pointer) { 93 // Non-interoperable object 94 return CFI_INVALID_DESCRIPTOR; 95 } 96 if (!descriptor->base_addr) { 97 return CFI_ERROR_BASE_ADDR_NULL; 98 } 99 std::free(descriptor->base_addr); 100 descriptor->base_addr = nullptr; 101 return CFI_SUCCESS; 102 } 103 104 int CFI_establish(CFI_cdesc_t *descriptor, void *base_addr, 105 CFI_attribute_t attribute, CFI_type_t type, std::size_t elem_len, 106 CFI_rank_t rank, const CFI_index_t extents[]) { 107 int cfiStatus{VerifyEstablishParameters(descriptor, base_addr, attribute, 108 type, elem_len, rank, extents, /*external=*/true)}; 109 if (cfiStatus != CFI_SUCCESS) { 110 return cfiStatus; 111 } 112 if (type != CFI_type_struct && type != CFI_type_other && 113 !IsCharacterType(type)) { 114 elem_len = MinElemLen(type); 115 } 116 if (elem_len <= 0) { 117 return CFI_INVALID_ELEM_LEN; 118 } 119 EstablishDescriptor( 120 descriptor, base_addr, attribute, type, elem_len, rank, extents); 121 return CFI_SUCCESS; 122 } 123 124 int CFI_is_contiguous(const CFI_cdesc_t *descriptor) { 125 CFI_index_t bytes = descriptor->elem_len; 126 for (int j{0}; j < descriptor->rank; ++j) { 127 if (bytes != descriptor->dim[j].sm) { 128 return 0; 129 } 130 bytes *= descriptor->dim[j].extent; 131 } 132 return 1; 133 } 134 135 int CFI_section(CFI_cdesc_t *result, const CFI_cdesc_t *source, 136 const CFI_index_t lower_bounds[], const CFI_index_t upper_bounds[], 137 const CFI_index_t strides[]) { 138 CFI_index_t extent[CFI_MAX_RANK]; 139 CFI_index_t actualStride[CFI_MAX_RANK]; 140 CFI_rank_t resRank{0}; 141 142 if (!result || !source) { 143 return CFI_INVALID_DESCRIPTOR; 144 } 145 if (source->rank == 0) { 146 return CFI_INVALID_RANK; 147 } 148 if (IsAssumedSize(source) && !upper_bounds) { 149 return CFI_INVALID_DESCRIPTOR; 150 } 151 if (runtime::TypeCode{result->type} != runtime::TypeCode{source->type}) { 152 return CFI_INVALID_TYPE; 153 } 154 if (source->elem_len != result->elem_len) { 155 return CFI_INVALID_ELEM_LEN; 156 } 157 if (result->attribute == CFI_attribute_allocatable) { 158 return CFI_INVALID_ATTRIBUTE; 159 } 160 if (!source->base_addr) { 161 return CFI_ERROR_BASE_ADDR_NULL; 162 } 163 164 char *shiftedBaseAddr{static_cast<char *>(source->base_addr)}; 165 bool isZeroSized{false}; 166 for (int j{0}; j < source->rank; ++j) { 167 const CFI_dim_t &dim{source->dim[j]}; 168 const CFI_index_t srcLB{dim.lower_bound}; 169 const CFI_index_t srcUB{srcLB + dim.extent - 1}; 170 const CFI_index_t lb{lower_bounds ? lower_bounds[j] : srcLB}; 171 const CFI_index_t ub{upper_bounds ? upper_bounds[j] : srcUB}; 172 const CFI_index_t stride{strides ? strides[j] : 1}; 173 174 if (stride == 0 && lb != ub) { 175 return CFI_ERROR_OUT_OF_BOUNDS; 176 } 177 if ((lb <= ub && stride >= 0) || (lb >= ub && stride < 0)) { 178 if ((lb < srcLB) || (lb > srcUB) || (ub < srcLB) || (ub > srcUB)) { 179 return CFI_ERROR_OUT_OF_BOUNDS; 180 } 181 shiftedBaseAddr += (lb - srcLB) * dim.sm; 182 extent[j] = stride != 0 ? 1 + (ub - lb) / stride : 1; 183 } else { 184 isZeroSized = true; 185 extent[j] = 0; 186 } 187 actualStride[j] = stride; 188 resRank += (stride != 0); 189 } 190 if (resRank != result->rank) { 191 return CFI_INVALID_DESCRIPTOR; 192 } 193 194 // For zero-sized arrays, base_addr is processor-dependent (see 18.5.3). 195 // We keep it on the source base_addr 196 result->base_addr = isZeroSized ? source->base_addr : shiftedBaseAddr; 197 resRank = 0; 198 for (int j{0}; j < source->rank; ++j) { 199 if (actualStride[j] != 0) { 200 result->dim[resRank].extent = extent[j]; 201 result->dim[resRank].lower_bound = extent[j] == 0 ? 1 202 : lower_bounds ? lower_bounds[j] 203 : source->dim[j].lower_bound; 204 result->dim[resRank].sm = actualStride[j] * source->dim[j].sm; 205 ++resRank; 206 } 207 } 208 return CFI_SUCCESS; 209 } 210 211 int CFI_select_part(CFI_cdesc_t *result, const CFI_cdesc_t *source, 212 std::size_t displacement, std::size_t elem_len) { 213 if (!result || !source) { 214 return CFI_INVALID_DESCRIPTOR; 215 } 216 if (result->rank != source->rank) { 217 return CFI_INVALID_RANK; 218 } 219 if (result->attribute == CFI_attribute_allocatable) { 220 return CFI_INVALID_ATTRIBUTE; 221 } 222 if (!source->base_addr) { 223 return CFI_ERROR_BASE_ADDR_NULL; 224 } 225 if (IsAssumedSize(source)) { 226 return CFI_INVALID_DESCRIPTOR; 227 } 228 229 if (!IsCharacterType(result->type)) { 230 elem_len = result->elem_len; 231 } 232 if (displacement + elem_len > source->elem_len) { 233 return CFI_INVALID_ELEM_LEN; 234 } 235 236 result->base_addr = displacement + static_cast<char *>(source->base_addr); 237 result->elem_len = elem_len; 238 for (int j{0}; j < source->rank; ++j) { 239 result->dim[j].lower_bound = 0; 240 result->dim[j].extent = source->dim[j].extent; 241 result->dim[j].sm = source->dim[j].sm; 242 } 243 return CFI_SUCCESS; 244 } 245 246 int CFI_setpointer(CFI_cdesc_t *result, const CFI_cdesc_t *source, 247 const CFI_index_t lower_bounds[]) { 248 if (!result) { 249 return CFI_INVALID_DESCRIPTOR; 250 } 251 if (result->attribute != CFI_attribute_pointer) { 252 return CFI_INVALID_ATTRIBUTE; 253 } 254 if (!source) { 255 result->base_addr = nullptr; 256 return CFI_SUCCESS; 257 } 258 if (source->rank != result->rank) { 259 return CFI_INVALID_RANK; 260 } 261 if (runtime::TypeCode{source->type} != runtime::TypeCode{result->type}) { 262 return CFI_INVALID_TYPE; 263 } 264 if (source->elem_len != result->elem_len) { 265 return CFI_INVALID_ELEM_LEN; 266 } 267 if (!source->base_addr && source->attribute != CFI_attribute_pointer) { 268 return CFI_ERROR_BASE_ADDR_NULL; 269 } 270 if (IsAssumedSize(source)) { 271 return CFI_INVALID_DESCRIPTOR; 272 } 273 274 const bool copySrcLB{!lower_bounds}; 275 result->base_addr = source->base_addr; 276 if (source->base_addr) { 277 for (int j{0}; j < result->rank; ++j) { 278 CFI_index_t extent{source->dim[j].extent}; 279 result->dim[j].extent = extent; 280 result->dim[j].sm = source->dim[j].sm; 281 result->dim[j].lower_bound = extent == 0 ? 1 282 : copySrcLB ? source->dim[j].lower_bound 283 : lower_bounds[j]; 284 } 285 } 286 return CFI_SUCCESS; 287 } 288 } // extern "C" 289 } // namespace Fortran::ISO 290