// Copyright (c) 2018, NVIDIA CORPORATION. All rights reserved. // // Licensed under the Apache License, Version 2.0 (the "License"); // you may not use this file except in compliance with the License. // You may obtain a copy of the License at // // http://www.apache.org/licenses/LICENSE-2.0 // // Unless required by applicable law or agreed to in writing, software // distributed under the License is distributed on an "AS IS" BASIS, // WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. // See the License for the specific language governing permissions and // limitations under the License. // Implements the required interoperability API from ISO_Fortran_binding.h // as specified in section 18.5.5 of Fortran 2018. #include "descriptor.h" namespace Fortran::ISO { extern "C" { void *CFI_address( const CFI_cdesc_t *descriptor, const CFI_index_t subscripts[]) { auto p = reinterpret_cast(descriptor->base_addr); std::size_t rank{descriptor->rank}; const CFI_dim_t *dim{descriptor->dim}; for (std::size_t j{0}; j < rank; ++j, ++dim) { p += (subscripts[j] - dim->lower_bound) * dim->sm; } return reinterpret_cast(p); } int CFI_allocate(CFI_cdesc_t *descriptor, const CFI_index_t lower_bounds[], const CFI_index_t upper_bounds[], std::size_t elem_len) { if (descriptor->version != CFI_VERSION) { return CFI_INVALID_DESCRIPTOR; } if (descriptor->attribute != CFI_attribute_allocatable && descriptor->attribute != CFI_attribute_pointer) { // Non-interoperable object return CFI_INVALID_DESCRIPTOR; } if (descriptor->attribute == CFI_attribute_allocatable && descriptor->base_addr != nullptr) { return CFI_ERROR_BASE_ADDR_NOT_NULL; } if (descriptor->rank > CFI_MAX_RANK) { return CFI_INVALID_RANK; } if (descriptor->type < CFI_type_signed_char || descriptor->type > CFI_type_struct) { return CFI_INVALID_TYPE; } if (descriptor->type != CFI_type_cptr) { elem_len = descriptor->elem_len; if (elem_len <= 0) { return CFI_INVALID_ELEM_LEN; } } std::size_t rank{descriptor->rank}; CFI_dim_t *dim{descriptor->dim}; std::size_t byteSize{elem_len}; for (std::size_t j{0}; j < rank; ++j, ++dim) { CFI_index_t lb{lower_bounds[j]}; CFI_index_t ub{upper_bounds[j]}; CFI_index_t extent{ub >= lb ? ub - lb + 1 : 0}; dim->lower_bound = lb; dim->extent = extent; dim->sm = byteSize; byteSize *= extent; } void *p{new char[byteSize]}; if (p == nullptr) { return CFI_ERROR_MEM_ALLOCATION; } descriptor->base_addr = p; descriptor->elem_len = elem_len; return CFI_SUCCESS; } int CFI_deallocate(CFI_cdesc_t *descriptor) { if (descriptor->version != CFI_VERSION) { return CFI_INVALID_DESCRIPTOR; } if (descriptor->attribute != CFI_attribute_allocatable && descriptor->attribute != CFI_attribute_pointer) { // Non-interoperable object return CFI_INVALID_DESCRIPTOR; } if (descriptor->base_addr == nullptr) { return CFI_ERROR_BASE_ADDR_NULL; } delete[] static_cast(descriptor->base_addr); descriptor->base_addr = nullptr; return CFI_SUCCESS; } static constexpr std::size_t MinElemLen(CFI_type_t type) { std::size_t minElemLen{0}; switch (type) { case CFI_type_signed_char: minElemLen = sizeof(signed char); break; case CFI_type_short: minElemLen = sizeof(short); break; case CFI_type_int: minElemLen = sizeof(int); break; case CFI_type_long: minElemLen = sizeof(long); break; case CFI_type_long_long: minElemLen = sizeof(long long); break; case CFI_type_size_t: minElemLen = sizeof(std::size_t); break; case CFI_type_int8_t: minElemLen = sizeof(std::int8_t); break; case CFI_type_int16_t: minElemLen = sizeof(std::int16_t); break; case CFI_type_int32_t: minElemLen = sizeof(std::int32_t); break; case CFI_type_int64_t: minElemLen = sizeof(std::int64_t); break; case CFI_type_int128_t: minElemLen = 2 * sizeof(std::int64_t); break; case CFI_type_int_least8_t: minElemLen = sizeof(std::int_least8_t); break; case CFI_type_int_least16_t: minElemLen = sizeof(std::int_least16_t); break; case CFI_type_int_least32_t: minElemLen = sizeof(std::int_least32_t); break; case CFI_type_int_least64_t: minElemLen = sizeof(std::int_least64_t); break; case CFI_type_int_least128_t: minElemLen = 2 * sizeof(std::int_least64_t); break; case CFI_type_int_fast8_t: minElemLen = sizeof(std::int_fast8_t); break; case CFI_type_int_fast16_t: minElemLen = sizeof(std::int_fast16_t); break; case CFI_type_int_fast32_t: minElemLen = sizeof(std::int_fast32_t); break; case CFI_type_int_fast64_t: minElemLen = sizeof(std::int_fast64_t); break; case CFI_type_intmax_t: minElemLen = sizeof(std::intmax_t); break; case CFI_type_intptr_t: minElemLen = sizeof(std::intptr_t); break; case CFI_type_ptrdiff_t: minElemLen = sizeof(std::ptrdiff_t); break; case CFI_type_float: minElemLen = sizeof(float); break; case CFI_type_double: minElemLen = sizeof(double); break; case CFI_type_long_double: minElemLen = sizeof(long double); break; case CFI_type_float_Complex: minElemLen = 2 * sizeof(float); break; case CFI_type_double_Complex: minElemLen = 2 * sizeof(double); break; case CFI_type_long_double_Complex: minElemLen = 2 * sizeof(long double); break; case CFI_type_Bool: minElemLen = 1; break; case CFI_type_char: minElemLen = sizeof(char); break; } return minElemLen; } int CFI_establish(CFI_cdesc_t *descriptor, void *base_addr, CFI_attribute_t attribute, CFI_type_t type, std::size_t elem_len, CFI_rank_t rank, const CFI_index_t extents[]) { if (attribute != CFI_attribute_other && attribute != CFI_attribute_pointer && attribute != CFI_attribute_allocatable) { return CFI_INVALID_ATTRIBUTE; } if (rank > CFI_MAX_RANK) { return CFI_INVALID_RANK; } if (base_addr != nullptr && attribute != CFI_attribute_pointer) { return CFI_ERROR_BASE_ADDR_NOT_NULL; } if (rank > 0 && base_addr != nullptr && extents == nullptr) { return CFI_INVALID_EXTENT; } if (type < CFI_type_signed_char || type > CFI_type_struct) { return CFI_INVALID_TYPE; } std::size_t minElemLen{MinElemLen(type)}; if (minElemLen > 0) { elem_len = minElemLen; } else if (elem_len <= 0) { return CFI_INVALID_ELEM_LEN; } descriptor->base_addr = base_addr; descriptor->elem_len = elem_len; descriptor->version = CFI_VERSION; descriptor->rank = rank; descriptor->type = type; descriptor->attribute = attribute; descriptor->f18Addendum = 0; std::size_t byteSize{elem_len}; for (std::size_t j{0}; j < rank; ++j) { descriptor->dim[j].lower_bound = 1; descriptor->dim[j].extent = extents[j]; descriptor->dim[j].sm = byteSize; byteSize *= extents[j]; } return CFI_SUCCESS; } int CFI_is_contiguous(const CFI_cdesc_t *descriptor) { CFI_index_t bytes = descriptor->elem_len; for (int j{0}; j < descriptor->rank; ++j) { if (bytes != descriptor->dim[j].sm) { return 0; } bytes *= descriptor->dim[j].extent; } return 1; } int CFI_section(CFI_cdesc_t *result, const CFI_cdesc_t *source, const CFI_index_t lower_bounds[], const CFI_index_t upper_bounds[], const CFI_index_t strides[]) { return CFI_INVALID_DESCRIPTOR; // TODO } int CFI_select_part(CFI_cdesc_t *result, const CFI_cdesc_t *source, std::size_t displacement, std::size_t elem_len) { return CFI_INVALID_DESCRIPTOR; // TODO } int CFI_setpointer(CFI_cdesc_t *result, const CFI_cdesc_t *source, const CFI_index_t lower_bounds[]) { return CFI_INVALID_DESCRIPTOR; // TODO } } // extern "C" } // namespace Fortran::ISO