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 "../include/flang/ISO_Fortran_binding.h"
13 #include "descriptor.h"
14 #include <cstdlib>
15
16 namespace Fortran::ISO {
17 extern "C" {
18
IsCharacterType(CFI_type_t ty)19 static inline constexpr bool IsCharacterType(CFI_type_t ty) {
20 return ty == CFI_type_char || ty == CFI_type_char16_t ||
21 ty == CFI_type_char32_t;
22 }
IsAssumedSize(const CFI_cdesc_t * dv)23 static inline constexpr bool IsAssumedSize(const CFI_cdesc_t *dv) {
24 return dv->rank > 0 && dv->dim[dv->rank - 1].extent == -1;
25 }
26
CFI_address(const CFI_cdesc_t * descriptor,const CFI_index_t subscripts[])27 void *CFI_address(
28 const CFI_cdesc_t *descriptor, const CFI_index_t subscripts[]) {
29 char *p{static_cast<char *>(descriptor->base_addr)};
30 const CFI_rank_t rank{descriptor->rank};
31 const CFI_dim_t *dim{descriptor->dim};
32 for (CFI_rank_t j{0}; j < rank; ++j, ++dim) {
33 p += (subscripts[j] - dim->lower_bound) * dim->sm;
34 }
35 return p;
36 }
37
CFI_allocate(CFI_cdesc_t * descriptor,const CFI_index_t lower_bounds[],const CFI_index_t upper_bounds[],std::size_t elem_len)38 int CFI_allocate(CFI_cdesc_t *descriptor, const CFI_index_t lower_bounds[],
39 const CFI_index_t upper_bounds[], std::size_t elem_len) {
40 if (!descriptor) {
41 return CFI_INVALID_DESCRIPTOR;
42 }
43 if (descriptor->version != CFI_VERSION) {
44 return CFI_INVALID_DESCRIPTOR;
45 }
46 if (descriptor->attribute != CFI_attribute_allocatable &&
47 descriptor->attribute != CFI_attribute_pointer) {
48 // Non-interoperable object
49 return CFI_INVALID_ATTRIBUTE;
50 }
51 if (descriptor->attribute == CFI_attribute_allocatable &&
52 descriptor->base_addr) {
53 return CFI_ERROR_BASE_ADDR_NOT_NULL;
54 }
55 if (descriptor->rank > CFI_MAX_RANK) {
56 return CFI_INVALID_RANK;
57 }
58 if (descriptor->type < CFI_type_signed_char ||
59 descriptor->type > CFI_type_struct) {
60 return CFI_INVALID_TYPE;
61 }
62 if (!IsCharacterType(descriptor->type)) {
63 elem_len = descriptor->elem_len;
64 if (elem_len <= 0) {
65 return CFI_INVALID_ELEM_LEN;
66 }
67 }
68 std::size_t rank{descriptor->rank};
69 CFI_dim_t *dim{descriptor->dim};
70 std::size_t byteSize{elem_len};
71 for (std::size_t j{0}; j < rank; ++j, ++dim) {
72 CFI_index_t lb{lower_bounds[j]};
73 CFI_index_t ub{upper_bounds[j]};
74 CFI_index_t extent{ub >= lb ? ub - lb + 1 : 0};
75 dim->lower_bound = lb;
76 dim->extent = extent;
77 dim->sm = byteSize;
78 byteSize *= extent;
79 }
80 void *p{std::malloc(byteSize)};
81 if (!p && byteSize) {
82 return CFI_ERROR_MEM_ALLOCATION;
83 }
84 descriptor->base_addr = p;
85 descriptor->elem_len = elem_len;
86 return CFI_SUCCESS;
87 }
88
CFI_deallocate(CFI_cdesc_t * descriptor)89 int CFI_deallocate(CFI_cdesc_t *descriptor) {
90 if (!descriptor) {
91 return CFI_INVALID_DESCRIPTOR;
92 }
93 if (descriptor->version != CFI_VERSION) {
94 return CFI_INVALID_DESCRIPTOR;
95 }
96 if (descriptor->attribute != CFI_attribute_allocatable &&
97 descriptor->attribute != CFI_attribute_pointer) {
98 // Non-interoperable object
99 return CFI_INVALID_DESCRIPTOR;
100 }
101 if (!descriptor->base_addr) {
102 return CFI_ERROR_BASE_ADDR_NULL;
103 }
104 std::free(descriptor->base_addr);
105 descriptor->base_addr = nullptr;
106 return CFI_SUCCESS;
107 }
108
MinElemLen(CFI_type_t type)109 static constexpr std::size_t MinElemLen(CFI_type_t type) {
110 std::size_t minElemLen{0};
111 switch (type) {
112 case CFI_type_signed_char:
113 minElemLen = sizeof(signed char);
114 break;
115 case CFI_type_short:
116 minElemLen = sizeof(short);
117 break;
118 case CFI_type_int:
119 minElemLen = sizeof(int);
120 break;
121 case CFI_type_long:
122 minElemLen = sizeof(long);
123 break;
124 case CFI_type_long_long:
125 minElemLen = sizeof(long long);
126 break;
127 case CFI_type_size_t:
128 minElemLen = sizeof(std::size_t);
129 break;
130 case CFI_type_int8_t:
131 minElemLen = sizeof(std::int8_t);
132 break;
133 case CFI_type_int16_t:
134 minElemLen = sizeof(std::int16_t);
135 break;
136 case CFI_type_int32_t:
137 minElemLen = sizeof(std::int32_t);
138 break;
139 case CFI_type_int64_t:
140 minElemLen = sizeof(std::int64_t);
141 break;
142 case CFI_type_int128_t:
143 minElemLen = 2 * sizeof(std::int64_t);
144 break;
145 case CFI_type_int_least8_t:
146 minElemLen = sizeof(std::int_least8_t);
147 break;
148 case CFI_type_int_least16_t:
149 minElemLen = sizeof(std::int_least16_t);
150 break;
151 case CFI_type_int_least32_t:
152 minElemLen = sizeof(std::int_least32_t);
153 break;
154 case CFI_type_int_least64_t:
155 minElemLen = sizeof(std::int_least64_t);
156 break;
157 case CFI_type_int_least128_t:
158 minElemLen = 2 * sizeof(std::int_least64_t);
159 break;
160 case CFI_type_int_fast8_t:
161 minElemLen = sizeof(std::int_fast8_t);
162 break;
163 case CFI_type_int_fast16_t:
164 minElemLen = sizeof(std::int_fast16_t);
165 break;
166 case CFI_type_int_fast32_t:
167 minElemLen = sizeof(std::int_fast32_t);
168 break;
169 case CFI_type_int_fast64_t:
170 minElemLen = sizeof(std::int_fast64_t);
171 break;
172 case CFI_type_intmax_t:
173 minElemLen = sizeof(std::intmax_t);
174 break;
175 case CFI_type_intptr_t:
176 minElemLen = sizeof(std::intptr_t);
177 break;
178 case CFI_type_ptrdiff_t:
179 minElemLen = sizeof(std::ptrdiff_t);
180 break;
181 case CFI_type_float:
182 minElemLen = sizeof(float);
183 break;
184 case CFI_type_double:
185 minElemLen = sizeof(double);
186 break;
187 case CFI_type_long_double:
188 minElemLen = sizeof(long double);
189 break;
190 case CFI_type_float_Complex:
191 minElemLen = 2 * sizeof(float);
192 break;
193 case CFI_type_double_Complex:
194 minElemLen = 2 * sizeof(double);
195 break;
196 case CFI_type_long_double_Complex:
197 minElemLen = 2 * sizeof(long double);
198 break;
199 case CFI_type_Bool:
200 minElemLen = 1;
201 break;
202 case CFI_type_cptr:
203 minElemLen = sizeof(void *);
204 break;
205 case CFI_type_char16_t:
206 minElemLen = sizeof(char16_t);
207 break;
208 case CFI_type_char32_t:
209 minElemLen = sizeof(char32_t);
210 break;
211 }
212 return minElemLen;
213 }
214
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[])215 int CFI_establish(CFI_cdesc_t *descriptor, void *base_addr,
216 CFI_attribute_t attribute, CFI_type_t type, std::size_t elem_len,
217 CFI_rank_t rank, const CFI_index_t extents[]) {
218 if (attribute != CFI_attribute_other && attribute != CFI_attribute_pointer &&
219 attribute != CFI_attribute_allocatable) {
220 return CFI_INVALID_ATTRIBUTE;
221 }
222 if (rank > CFI_MAX_RANK) {
223 return CFI_INVALID_RANK;
224 }
225 if (base_addr && attribute == CFI_attribute_allocatable) {
226 return CFI_ERROR_BASE_ADDR_NOT_NULL;
227 }
228 if (rank > 0 && base_addr && !extents) {
229 return CFI_INVALID_EXTENT;
230 }
231 if (type < CFI_type_signed_char || type > CFI_type_struct) {
232 return CFI_INVALID_TYPE;
233 }
234 if (!descriptor) {
235 return CFI_INVALID_DESCRIPTOR;
236 }
237 std::size_t minElemLen{MinElemLen(type)};
238 if (minElemLen > 0) {
239 elem_len = minElemLen;
240 } else if (elem_len <= 0) {
241 return CFI_INVALID_ELEM_LEN;
242 }
243 descriptor->base_addr = base_addr;
244 descriptor->elem_len = elem_len;
245 descriptor->version = CFI_VERSION;
246 descriptor->rank = rank;
247 descriptor->type = type;
248 descriptor->attribute = attribute;
249 descriptor->f18Addendum = 0;
250 std::size_t byteSize{elem_len};
251 constexpr std::size_t lower_bound{0};
252 if (base_addr) {
253 for (std::size_t j{0}; j < rank; ++j) {
254 descriptor->dim[j].lower_bound = lower_bound;
255 descriptor->dim[j].extent = extents[j];
256 descriptor->dim[j].sm = byteSize;
257 byteSize *= extents[j];
258 }
259 }
260 return CFI_SUCCESS;
261 }
262
CFI_is_contiguous(const CFI_cdesc_t * descriptor)263 int CFI_is_contiguous(const CFI_cdesc_t *descriptor) {
264 CFI_index_t bytes = descriptor->elem_len;
265 for (int j{0}; j < descriptor->rank; ++j) {
266 if (bytes != descriptor->dim[j].sm) {
267 return 0;
268 }
269 bytes *= descriptor->dim[j].extent;
270 }
271 return 1;
272 }
273
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[])274 int CFI_section(CFI_cdesc_t *result, const CFI_cdesc_t *source,
275 const CFI_index_t lower_bounds[], const CFI_index_t upper_bounds[],
276 const CFI_index_t strides[]) {
277 CFI_index_t extent[CFI_MAX_RANK];
278 CFI_index_t actualStride[CFI_MAX_RANK];
279 CFI_rank_t resRank{0};
280
281 if (!result || !source) {
282 return CFI_INVALID_DESCRIPTOR;
283 }
284 if (source->rank == 0) {
285 return CFI_INVALID_RANK;
286 }
287 if (IsAssumedSize(source) && !upper_bounds) {
288 return CFI_INVALID_DESCRIPTOR;
289 }
290 if ((result->type != source->type) ||
291 (result->elem_len != source->elem_len)) {
292 return CFI_INVALID_DESCRIPTOR;
293 }
294 if (result->attribute == CFI_attribute_allocatable) {
295 return CFI_INVALID_ATTRIBUTE;
296 }
297 if (!source->base_addr) {
298 return CFI_ERROR_BASE_ADDR_NULL;
299 }
300
301 char *shiftedBaseAddr{static_cast<char *>(source->base_addr)};
302 bool isZeroSized{false};
303 for (int j{0}; j < source->rank; ++j) {
304 const CFI_dim_t &dim{source->dim[j]};
305 const CFI_index_t srcLB{dim.lower_bound};
306 const CFI_index_t srcUB{srcLB + dim.extent - 1};
307 const CFI_index_t lb{lower_bounds ? lower_bounds[j] : srcLB};
308 const CFI_index_t ub{upper_bounds ? upper_bounds[j] : srcUB};
309 const CFI_index_t stride{strides ? strides[j] : 1};
310
311 if (stride == 0 && lb != ub) {
312 return CFI_ERROR_OUT_OF_BOUNDS;
313 }
314 if ((lb <= ub && stride >= 0) || (lb >= ub && stride < 0)) {
315 if ((lb < srcLB) || (lb > srcUB) || (ub < srcLB) || (ub > srcUB)) {
316 return CFI_ERROR_OUT_OF_BOUNDS;
317 }
318 shiftedBaseAddr += (lb - srcLB) * dim.sm;
319 extent[j] = stride != 0 ? 1 + (ub - lb) / stride : 1;
320 } else {
321 isZeroSized = true;
322 extent[j] = 0;
323 }
324 actualStride[j] = stride;
325 resRank += (stride != 0);
326 }
327 if (resRank != result->rank) {
328 return CFI_INVALID_DESCRIPTOR;
329 }
330
331 // For zero-sized arrays, base_addr is processor-dependent (see 18.5.3).
332 // We keep it on the source base_addr
333 result->base_addr = isZeroSized ? source->base_addr : shiftedBaseAddr;
334 resRank = 0;
335 for (int j{0}; j < source->rank; ++j) {
336 if (actualStride[j] != 0) {
337 result->dim[resRank].lower_bound = 0;
338 result->dim[resRank].extent = extent[j];
339 result->dim[resRank].sm = actualStride[j] * source->dim[j].sm;
340 ++resRank;
341 }
342 }
343 return CFI_SUCCESS;
344 }
345
CFI_select_part(CFI_cdesc_t * result,const CFI_cdesc_t * source,std::size_t displacement,std::size_t elem_len)346 int CFI_select_part(CFI_cdesc_t *result, const CFI_cdesc_t *source,
347 std::size_t displacement, std::size_t elem_len) {
348 if (!result || !source) {
349 return CFI_INVALID_DESCRIPTOR;
350 }
351 if (result->rank != source->rank) {
352 return CFI_INVALID_RANK;
353 }
354 if (result->attribute == CFI_attribute_allocatable) {
355 return CFI_INVALID_ATTRIBUTE;
356 }
357 if (!source->base_addr) {
358 return CFI_ERROR_BASE_ADDR_NULL;
359 }
360 if (IsAssumedSize(source)) {
361 return CFI_INVALID_DESCRIPTOR;
362 }
363
364 if (!IsCharacterType(result->type)) {
365 elem_len = result->elem_len;
366 }
367 if (displacement + elem_len > source->elem_len) {
368 return CFI_INVALID_ELEM_LEN;
369 }
370
371 result->base_addr = displacement + static_cast<char *>(source->base_addr);
372 result->elem_len = elem_len;
373 for (int j{0}; j < source->rank; ++j) {
374 result->dim[j].lower_bound = 0;
375 result->dim[j].extent = source->dim[j].extent;
376 result->dim[j].sm = source->dim[j].sm;
377 }
378 return CFI_SUCCESS;
379 }
380
CFI_setpointer(CFI_cdesc_t * result,const CFI_cdesc_t * source,const CFI_index_t lower_bounds[])381 int CFI_setpointer(CFI_cdesc_t *result, const CFI_cdesc_t *source,
382 const CFI_index_t lower_bounds[]) {
383 if (!result) {
384 return CFI_INVALID_DESCRIPTOR;
385 }
386 if (result->attribute != CFI_attribute_pointer) {
387 return CFI_INVALID_ATTRIBUTE;
388 }
389 if (!source) {
390 result->base_addr = nullptr;
391 return CFI_SUCCESS;
392 }
393 if (source->rank != result->rank) {
394 return CFI_INVALID_RANK;
395 }
396 if (source->type != result->type) {
397 return CFI_INVALID_TYPE;
398 }
399 if (source->elem_len != result->elem_len) {
400 return CFI_INVALID_ELEM_LEN;
401 }
402 if (!source->base_addr && source->attribute != CFI_attribute_pointer) {
403 return CFI_ERROR_BASE_ADDR_NULL;
404 }
405 if (IsAssumedSize(source)) {
406 return CFI_INVALID_DESCRIPTOR;
407 }
408
409 const bool copySrcLB{!lower_bounds};
410 result->base_addr = source->base_addr;
411 if (source->base_addr) {
412 for (int j{0}; j < result->rank; ++j) {
413 result->dim[j].extent = source->dim[j].extent;
414 result->dim[j].sm = source->dim[j].sm;
415 result->dim[j].lower_bound =
416 copySrcLB ? source->dim[j].lower_bound : lower_bounds[j];
417 }
418 }
419 return CFI_SUCCESS;
420 }
421 } // extern "C"
422 } // namespace Fortran::ISO
423