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/pointer.h"
  17 #include "flang/Runtime/type-code.h"
  18 #include <cstdlib>
  19
  20 namespace Fortran::ISO {
  21 extern "C" {
  22
  23 RT_EXT_API_GROUP_BEGIN
  24
  25 RT_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
  36 RT_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 object
  48     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
  88 RT_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 object
 101     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
 111 RT_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
 131 RT_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
 146 RT_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_addr
 207   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 ? 1
 213           : 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
 222 RT_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
 257 RT_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 ? 1
 293           : copySrcLB                          ? source->dim[j].lower_bound
 294                                                : lower_bounds[j];
 295     }
 296   }
 297   return CFI_SUCCESS;
 298 }
 299
 300 RT_EXT_API_GROUP_END
 301 } // extern "C"
 302 } // namespace Fortran::ISO