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
CFI_address(const CFI_cdesc_t * descriptor,const CFI_index_t subscripts[])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
CFI_allocate(CFI_cdesc_t * descriptor,const CFI_index_t lower_bounds[],const CFI_index_t upper_bounds[],std::size_t elem_len)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
CFI_deallocate(CFI_cdesc_t * descriptor)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
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[])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
CFI_is_contiguous(const CFI_cdesc_t * descriptor)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
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[])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
CFI_select_part(CFI_cdesc_t * result,const CFI_cdesc_t * source,std::size_t displacement,std::size_t elem_len)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
CFI_setpointer(CFI_cdesc_t * result,const CFI_cdesc_t * source,const CFI_index_t lower_bounds[])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
303