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
19namespace Fortran::ISO {
20extern "C" {
21
22RT_EXT_API_GROUP_BEGIN
23
24RT_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
35RT_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{byteSize ? std::malloc(size: byteSize) : std::malloc(size: 1)};
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
87RT_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(ptr: descriptor->base_addr);
103 descriptor->base_addr = nullptr;
104 return CFI_SUCCESS;
105}
106
107RT_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
127RT_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
142RT_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
218RT_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
253RT_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
296RT_EXT_API_GROUP_END
297} // extern "C"
298} // namespace Fortran::ISO
299

source code of flang/runtime/ISO_Fortran_binding.cpp