flang/runtime/ISO_Fortran_binding.cpp

   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 RT_EXT_API_GROUP_BEGIN
  23
  24 RT_API_ATTRS void *CFI_address(
  25     const CFI_cdesc_t *descriptor, const CFI_index_t subscripts[]) {
  26   char *p{static_cast<char *>(descriptor->base_addr)};
  27   const CFI_rank_t rank{descriptor->rank};
  28   const CFI_dim_t *dim{descriptor->dim};
  29   for (CFI_rank_t j{0}; j < rank; ++j, ++dim) {
  30     p += (subscripts[j] - dim->lower_bound) * dim->sm;
  31   }
  32   return p;
  33 }
  34
  35 RT_API_ATTRS int CFI_allocate(CFI_cdesc_t *descriptor,
  36     const CFI_index_t lower_bounds[], const CFI_index_t upper_bounds[],
  37     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_LAST) {
  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 = extent == 0 ? 1 : lb;
  74     dim->extent = extent;
  75     dim->sm = byteSize;
  76     byteSize *= extent;
  77   }
  78   void *p{std::malloc(byteSize)};
  79   if (!p && byteSize) {
  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 RT_API_ATTRS 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   std::free(descriptor->base_addr);
 103   descriptor->base_addr = nullptr;
 104   return CFI_SUCCESS;
 105 }
 106
 107 RT_API_ATTRS int CFI_establish(CFI_cdesc_t *descriptor, void *base_addr,
 108     CFI_attribute_t attribute, CFI_type_t type, std::size_t elem_len,
 109     CFI_rank_t rank, const CFI_index_t extents[]) {
 110   int cfiStatus{VerifyEstablishParameters(descriptor, base_addr, attribute,
 111       type, elem_len, rank, extents, /*external=*/true)};
 112   if (cfiStatus != CFI_SUCCESS) {
 113     return cfiStatus;
 114   }
 115   if (type != CFI_type_struct && type != CFI_type_other &&
 116       !IsCharacterType(type)) {
 117     elem_len = MinElemLen(type);
 118   }
 119   if (elem_len <= 0) {
 120     return CFI_INVALID_ELEM_LEN;
 121   }
 122   EstablishDescriptor(
 123       descriptor, base_addr, attribute, type, elem_len, rank, extents);
 124   return CFI_SUCCESS;
 125 }
 126
 127 RT_API_ATTRS int CFI_is_contiguous(const CFI_cdesc_t *descriptor) {
 128   // See Descriptor::IsContiguous for the rationale.
 129   bool stridesAreContiguous{true};
 130   CFI_index_t bytes = descriptor->elem_len;
 131   for (int j{0}; j < descriptor->rank; ++j) {
 132     stridesAreContiguous &=
 133         (bytes == descriptor->dim[j].sm) || (descriptor->dim[j].extent == 1);
 134     bytes *= descriptor->dim[j].extent;
 135   }
 136   if (stridesAreContiguous || bytes == 0) {
 137     return 1;
 138   }
 139   return 0;
 140 }
 141
 142 RT_API_ATTRS int CFI_section(CFI_cdesc_t *result, const CFI_cdesc_t *source,
 143     const CFI_index_t lower_bounds[], const CFI_index_t upper_bounds[],
 144     const CFI_index_t strides[]) {
 145   CFI_index_t extent[CFI_MAX_RANK];
 146   CFI_index_t actualStride[CFI_MAX_RANK];
 147   CFI_rank_t resRank{0};
 148
 149   if (!result || !source) {
 150     return CFI_INVALID_DESCRIPTOR;
 151   }
 152   if (source->rank == 0) {
 153     return CFI_INVALID_RANK;
 154   }
 155   if (IsAssumedSize(source) && !upper_bounds) {
 156     return CFI_INVALID_DESCRIPTOR;
 157   }
 158   if (runtime::TypeCode{result->type} != runtime::TypeCode{source->type}) {
 159     return CFI_INVALID_TYPE;
 160   }
 161   if (source->elem_len != result->elem_len) {
 162     return CFI_INVALID_ELEM_LEN;
 163   }
 164   if (result->attribute == CFI_attribute_allocatable) {
 165     return CFI_INVALID_ATTRIBUTE;
 166   }
 167   if (!source->base_addr) {
 168     return CFI_ERROR_BASE_ADDR_NULL;
 169   }
 170
 171   char *shiftedBaseAddr{static_cast<char *>(source->base_addr)};
 172   bool isZeroSized{false};
 173   for (int j{0}; j < source->rank; ++j) {
 174     const CFI_dim_t &dim{source->dim[j]};
 175     const CFI_index_t srcLB{dim.lower_bound};
 176     const CFI_index_t srcUB{srcLB + dim.extent - 1};
 177     const CFI_index_t lb{lower_bounds ? lower_bounds[j] : srcLB};
 178     const CFI_index_t ub{upper_bounds ? upper_bounds[j] : srcUB};
 179     const CFI_index_t stride{strides ? strides[j] : 1};
 180
 181     if (stride == 0 && lb != ub) {
 182       return CFI_ERROR_OUT_OF_BOUNDS;
 183     }
 184     if ((lb <= ub && stride >= 0) || (lb >= ub && stride < 0)) {
 185       if ((lb < srcLB) || (lb > srcUB) || (ub < srcLB) || (ub > srcUB)) {
 186         return CFI_ERROR_OUT_OF_BOUNDS;
 187       }
 188       shiftedBaseAddr += (lb - srcLB) * dim.sm;
 189       extent[j] = stride != 0 ? 1 + (ub - lb) / stride : 1;
 190     } else {
 191       isZeroSized = true;
 192       extent[j] = 0;
 193     }
 194     actualStride[j] = stride;
 195     resRank += (stride != 0);
 196   }
 197   if (resRank != result->rank) {
 198     return CFI_INVALID_DESCRIPTOR;
 199   }
 200
 201   // For zero-sized arrays, base_addr is processor-dependent (see 18.5.3).
 202   // We keep it on the source base_addr
 203   result->base_addr = isZeroSized ? source->base_addr : shiftedBaseAddr;
 204   resRank = 0;
 205   for (int j{0}; j < source->rank; ++j) {
 206     if (actualStride[j] != 0) {
 207       result->dim[resRank].extent = extent[j];
 208       result->dim[resRank].lower_bound = extent[j] == 0 ? 1
 209           : lower_bounds                                ? lower_bounds[j]
 210                          : source->dim[j].lower_bound;
 211       result->dim[resRank].sm = actualStride[j] * source->dim[j].sm;
 212       ++resRank;
 213     }
 214   }
 215   return CFI_SUCCESS;
 216 }
 217
 218 RT_API_ATTRS int CFI_select_part(CFI_cdesc_t *result, const CFI_cdesc_t *source,
 219     std::size_t displacement, std::size_t elem_len) {
 220   if (!result || !source) {
 221     return CFI_INVALID_DESCRIPTOR;
 222   }
 223   if (result->rank != source->rank) {
 224     return CFI_INVALID_RANK;
 225   }
 226   if (result->attribute == CFI_attribute_allocatable) {
 227     return CFI_INVALID_ATTRIBUTE;
 228   }
 229   if (!source->base_addr) {
 230     return CFI_ERROR_BASE_ADDR_NULL;
 231   }
 232   if (IsAssumedSize(source)) {
 233     return CFI_INVALID_DESCRIPTOR;
 234   }
 235
 236   if (!IsCharacterType(result->type)) {
 237     elem_len = result->elem_len;
 238   }
 239   if (displacement + elem_len > source->elem_len) {
 240     return CFI_INVALID_ELEM_LEN;
 241   }
 242
 243   result->base_addr = displacement + static_cast<char *>(source->base_addr);
 244   result->elem_len = elem_len;
 245   for (int j{0}; j < source->rank; ++j) {
 246     result->dim[j].lower_bound = 0;
 247     result->dim[j].extent = source->dim[j].extent;
 248     result->dim[j].sm = source->dim[j].sm;
 249   }
 250   return CFI_SUCCESS;
 251 }
 252
 253 RT_API_ATTRS int CFI_setpointer(CFI_cdesc_t *result, const CFI_cdesc_t *source,
 254     const CFI_index_t lower_bounds[]) {
 255   if (!result) {
 256     return CFI_INVALID_DESCRIPTOR;
 257   }
 258   if (result->attribute != CFI_attribute_pointer) {
 259     return CFI_INVALID_ATTRIBUTE;
 260   }
 261   if (!source) {
 262     result->base_addr = nullptr;
 263     return CFI_SUCCESS;
 264   }
 265   if (source->rank != result->rank) {
 266     return CFI_INVALID_RANK;
 267   }
 268   if (runtime::TypeCode{source->type} != runtime::TypeCode{result->type}) {
 269     return CFI_INVALID_TYPE;
 270   }
 271   if (source->elem_len != result->elem_len) {
 272     return CFI_INVALID_ELEM_LEN;
 273   }
 274   if (!source->base_addr && source->attribute != CFI_attribute_pointer) {
 275     return CFI_ERROR_BASE_ADDR_NULL;
 276   }
 277   if (IsAssumedSize(source)) {
 278     return CFI_INVALID_DESCRIPTOR;
 279   }
 280
 281   const bool copySrcLB{!lower_bounds};
 282   result->base_addr = source->base_addr;
 283   if (source->base_addr) {
 284     for (int j{0}; j < result->rank; ++j) {
 285       CFI_index_t extent{source->dim[j].extent};
 286       result->dim[j].extent = extent;
 287       result->dim[j].sm = source->dim[j].sm;
 288       result->dim[j].lower_bound = extent == 0 ? 1
 289           : copySrcLB                          ? source->dim[j].lower_bound
 290                                                : lower_bounds[j];
 291     }
 292   }
 293   return CFI_SUCCESS;
 294 }
 295
 296 RT_EXT_API_GROUP_END
 297 } // extern "C"
 298 } // namespace Fortran::ISO