303 lines · cpp
1//===-- lib/runtime/ISO_Fortran_binding.cpp ---------------------*- C++ -*-===//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-exception6//7//===----------------------------------------------------------------------===//8 9// Implements the required interoperability API from ISO_Fortran_binding.h10// as specified in section 18.5.5 of Fortran 2018.11 12#include "ISO_Fortran_util.h"13#include "flang-rt/runtime/descriptor.h"14#include "flang-rt/runtime/terminator.h"15#include "flang-rt/runtime/type-code.h"16#include "flang/Common/ISO_Fortran_binding_wrapper.h"17#include "flang/Runtime/pointer.h"18#include <cstdlib>19 20namespace Fortran::ISO {21extern "C" {22 23RT_EXT_API_GROUP_BEGIN24 25RT_API_ATTRS 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 36RT_API_ATTRS int CFI_allocate(CFI_cdesc_t *descriptor,37 const CFI_index_t lower_bounds[], const CFI_index_t upper_bounds[],38 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 object48 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_LAST) {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 = extent == 0 ? 1 : lb;75 dim->extent = extent;76 dim->sm = byteSize;77 byteSize *= extent;78 }79 void *p{runtime::AllocateValidatedPointerPayload(byteSize)};80 if (!p && byteSize) {81 return CFI_ERROR_MEM_ALLOCATION;82 }83 descriptor->base_addr = p;84 descriptor->elem_len = elem_len;85 return CFI_SUCCESS;86}87 88RT_API_ATTRS 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_pointer) {96 if (!runtime::ValidatePointerPayload(*descriptor)) {97 return CFI_INVALID_DESCRIPTOR;98 }99 } else if (descriptor->attribute != CFI_attribute_allocatable) {100 // Non-interoperable object101 return CFI_INVALID_DESCRIPTOR;102 }103 if (!descriptor->base_addr) {104 return CFI_ERROR_BASE_ADDR_NULL;105 }106 std::free(descriptor->base_addr);107 descriptor->base_addr = nullptr;108 return CFI_SUCCESS;109}110 111RT_API_ATTRS int CFI_establish(CFI_cdesc_t *descriptor, void *base_addr,112 CFI_attribute_t attribute, CFI_type_t type, std::size_t elem_len,113 CFI_rank_t rank, const CFI_index_t extents[]) {114 int cfiStatus{VerifyEstablishParameters(descriptor, base_addr, attribute,115 type, elem_len, rank, extents, /*external=*/true)};116 if (cfiStatus != CFI_SUCCESS) {117 return cfiStatus;118 }119 if (type != CFI_type_struct && type != CFI_type_other &&120 !IsCharacterType(type)) {121 elem_len = MinElemLen(type);122 }123 if (elem_len <= 0) {124 return CFI_INVALID_ELEM_LEN;125 }126 EstablishDescriptor(127 descriptor, base_addr, attribute, type, elem_len, rank, extents);128 return CFI_SUCCESS;129}130 131RT_API_ATTRS int CFI_is_contiguous(const CFI_cdesc_t *descriptor) {132 // See Descriptor::IsContiguous for the rationale.133 bool stridesAreContiguous{true};134 CFI_index_t bytes = descriptor->elem_len;135 for (int j{0}; j < descriptor->rank; ++j) {136 stridesAreContiguous &=137 (bytes == descriptor->dim[j].sm) || (descriptor->dim[j].extent == 1);138 bytes *= descriptor->dim[j].extent;139 }140 if (stridesAreContiguous || bytes == 0) {141 return 1;142 }143 return 0;144}145 146RT_API_ATTRS int CFI_section(CFI_cdesc_t *result, const CFI_cdesc_t *source,147 const CFI_index_t lower_bounds[], const CFI_index_t upper_bounds[],148 const CFI_index_t strides[]) {149 CFI_index_t extent[CFI_MAX_RANK];150 CFI_index_t actualStride[CFI_MAX_RANK];151 CFI_rank_t resRank{0};152 153 if (!result || !source) {154 return CFI_INVALID_DESCRIPTOR;155 }156 if (source->rank == 0) {157 return CFI_INVALID_RANK;158 }159 if (IsAssumedSize(source) && !upper_bounds) {160 return CFI_INVALID_DESCRIPTOR;161 }162 if (runtime::TypeCode{result->type} != runtime::TypeCode{source->type}) {163 return CFI_INVALID_TYPE;164 }165 if (source->elem_len != result->elem_len) {166 return CFI_INVALID_ELEM_LEN;167 }168 if (result->attribute == CFI_attribute_allocatable) {169 return CFI_INVALID_ATTRIBUTE;170 }171 if (!source->base_addr) {172 return CFI_ERROR_BASE_ADDR_NULL;173 }174 175 char *shiftedBaseAddr{static_cast<char *>(source->base_addr)};176 bool isZeroSized{false};177 for (int j{0}; j < source->rank; ++j) {178 const CFI_dim_t &dim{source->dim[j]};179 const CFI_index_t srcLB{dim.lower_bound};180 const CFI_index_t srcUB{srcLB + dim.extent - 1};181 const CFI_index_t lb{lower_bounds ? lower_bounds[j] : srcLB};182 const CFI_index_t ub{upper_bounds ? upper_bounds[j] : srcUB};183 const CFI_index_t stride{strides ? strides[j] : 1};184 185 if (stride == 0 && lb != ub) {186 return CFI_ERROR_OUT_OF_BOUNDS;187 }188 if ((lb <= ub && stride >= 0) || (lb >= ub && stride < 0)) {189 if ((lb < srcLB) || (lb > srcUB) || (ub < srcLB) || (ub > srcUB)) {190 return CFI_ERROR_OUT_OF_BOUNDS;191 }192 shiftedBaseAddr += (lb - srcLB) * dim.sm;193 extent[j] = stride != 0 ? 1 + (ub - lb) / stride : 1;194 } else {195 isZeroSized = true;196 extent[j] = 0;197 }198 actualStride[j] = stride;199 resRank += (stride != 0);200 }201 if (resRank != result->rank) {202 return CFI_INVALID_DESCRIPTOR;203 }204 205 // For zero-sized arrays, base_addr is processor-dependent (see 18.5.3).206 // We keep it on the source base_addr207 result->base_addr = isZeroSized ? source->base_addr : shiftedBaseAddr;208 resRank = 0;209 for (int j{0}; j < source->rank; ++j) {210 if (actualStride[j] != 0) {211 result->dim[resRank].extent = extent[j];212 result->dim[resRank].lower_bound = extent[j] == 0 ? 1213 : lower_bounds ? lower_bounds[j]214 : source->dim[j].lower_bound;215 result->dim[resRank].sm = actualStride[j] * source->dim[j].sm;216 ++resRank;217 }218 }219 return CFI_SUCCESS;220}221 222RT_API_ATTRS int CFI_select_part(CFI_cdesc_t *result, const CFI_cdesc_t *source,223 std::size_t displacement, std::size_t elem_len) {224 if (!result || !source) {225 return CFI_INVALID_DESCRIPTOR;226 }227 if (result->rank != source->rank) {228 return CFI_INVALID_RANK;229 }230 if (result->attribute == CFI_attribute_allocatable) {231 return CFI_INVALID_ATTRIBUTE;232 }233 if (!source->base_addr) {234 return CFI_ERROR_BASE_ADDR_NULL;235 }236 if (IsAssumedSize(source)) {237 return CFI_INVALID_DESCRIPTOR;238 }239 240 if (!IsCharacterType(result->type)) {241 elem_len = result->elem_len;242 }243 if (displacement + elem_len > source->elem_len) {244 return CFI_INVALID_ELEM_LEN;245 }246 247 result->base_addr = displacement + static_cast<char *>(source->base_addr);248 result->elem_len = elem_len;249 for (int j{0}; j < source->rank; ++j) {250 result->dim[j].lower_bound = 0;251 result->dim[j].extent = source->dim[j].extent;252 result->dim[j].sm = source->dim[j].sm;253 }254 return CFI_SUCCESS;255}256 257RT_API_ATTRS int CFI_setpointer(CFI_cdesc_t *result, const CFI_cdesc_t *source,258 const CFI_index_t lower_bounds[]) {259 if (!result) {260 return CFI_INVALID_DESCRIPTOR;261 }262 if (result->attribute != CFI_attribute_pointer) {263 return CFI_INVALID_ATTRIBUTE;264 }265 if (!source) {266 result->base_addr = nullptr;267 return CFI_SUCCESS;268 }269 if (source->rank != result->rank) {270 return CFI_INVALID_RANK;271 }272 if (runtime::TypeCode{source->type} != runtime::TypeCode{result->type}) {273 return CFI_INVALID_TYPE;274 }275 if (source->elem_len != result->elem_len) {276 return CFI_INVALID_ELEM_LEN;277 }278 if (!source->base_addr && source->attribute != CFI_attribute_pointer) {279 return CFI_ERROR_BASE_ADDR_NULL;280 }281 if (IsAssumedSize(source)) {282 return CFI_INVALID_DESCRIPTOR;283 }284 285 const bool copySrcLB{!lower_bounds};286 result->base_addr = source->base_addr;287 if (source->base_addr) {288 for (int j{0}; j < result->rank; ++j) {289 CFI_index_t extent{source->dim[j].extent};290 result->dim[j].extent = extent;291 result->dim[j].sm = source->dim[j].sm;292 result->dim[j].lower_bound = extent == 0 ? 1293 : copySrcLB ? source->dim[j].lower_bound294 : lower_bounds[j];295 }296 }297 return CFI_SUCCESS;298}299 300RT_EXT_API_GROUP_END301} // extern "C"302} // namespace Fortran::ISO303