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 
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;
CriticalBodyEnforce(SemanticsContext & context,parser::CharBlock criticalSourcePosition)22 }
23 static inline constexpr bool IsAssumedSize(const CFI_cdesc_t *dv) {
24   return dv->rank > 0 && dv->dim[dv->rank - 1].extent == -1;
25 }
Pre(const T &)26 
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 
Post(const parser::ReturnStmt &)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_LAST) {
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 
89 int CFI_deallocate(CFI_cdesc_t *descriptor) {
Leave(const parser::SyncTeamStmt & x)90   if (!descriptor) {
91     return CFI_INVALID_DESCRIPTOR;
92   }
93   if (descriptor->version != CFI_VERSION) {
Leave(const parser::ImageSelector & imageSelector)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 
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;
Leave(const parser::FormTeamStmt & x)133   case CFI_type_int16_t:
134     minElemLen = sizeof(std::int16_t);
135     break;
136   case CFI_type_int32_t:
Enter(const parser::CriticalConstruct & x)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;
CheckNamesAreDistinct(const std::list<parser::CoarrayAssociation> & list)151   case CFI_type_int_least32_t:
152     minElemLen = sizeof(std::int_least32_t);
153     break;
154   case CFI_type_int_least64_t:
__anond55134690102() 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);
Say2(const parser::CharBlock & name1,parser::MessageFixedText && msg1,const parser::CharBlock & name2,parser::MessageFixedText && msg2)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 
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_LAST) {
232     return CFI_INVALID_TYPE;
233   }
234   if (!descriptor) {
235     return CFI_INVALID_DESCRIPTOR;
236   }
237   if (type == CFI_type_struct || type == CFI_type_other ||
238       IsCharacterType(type)) {
239     if (elem_len <= 0) {
240       return CFI_INVALID_ELEM_LEN;
241     }
242   } else {
243     elem_len = MinElemLen(type);
244     assert(elem_len > 0 && "Unknown element length for type");
245   }
246   descriptor->base_addr = base_addr;
247   descriptor->elem_len = elem_len;
248   descriptor->version = CFI_VERSION;
249   descriptor->rank = rank;
250   descriptor->type = type;
251   descriptor->attribute = attribute;
252   descriptor->f18Addendum = 0;
253   std::size_t byteSize{elem_len};
254   constexpr std::size_t lower_bound{0};
255   if (base_addr) {
256     for (std::size_t j{0}; j < rank; ++j) {
257       descriptor->dim[j].lower_bound = lower_bound;
258       descriptor->dim[j].extent = extents[j];
259       descriptor->dim[j].sm = byteSize;
260       byteSize *= extents[j];
261     }
262   }
263   return CFI_SUCCESS;
264 }
265 
266 int CFI_is_contiguous(const CFI_cdesc_t *descriptor) {
267   CFI_index_t bytes = descriptor->elem_len;
268   for (int j{0}; j < descriptor->rank; ++j) {
269     if (bytes != descriptor->dim[j].sm) {
270       return 0;
271     }
272     bytes *= descriptor->dim[j].extent;
273   }
274   return 1;
275 }
276 
277 int CFI_section(CFI_cdesc_t *result, const CFI_cdesc_t *source,
278     const CFI_index_t lower_bounds[], const CFI_index_t upper_bounds[],
279     const CFI_index_t strides[]) {
280   CFI_index_t extent[CFI_MAX_RANK];
281   CFI_index_t actualStride[CFI_MAX_RANK];
282   CFI_rank_t resRank{0};
283 
284   if (!result || !source) {
285     return CFI_INVALID_DESCRIPTOR;
286   }
287   if (source->rank == 0) {
288     return CFI_INVALID_RANK;
289   }
290   if (IsAssumedSize(source) && !upper_bounds) {
291     return CFI_INVALID_DESCRIPTOR;
292   }
293   if ((result->type != source->type) ||
294       (result->elem_len != source->elem_len)) {
295     return CFI_INVALID_DESCRIPTOR;
296   }
297   if (result->attribute == CFI_attribute_allocatable) {
298     return CFI_INVALID_ATTRIBUTE;
299   }
300   if (!source->base_addr) {
301     return CFI_ERROR_BASE_ADDR_NULL;
302   }
303 
304   char *shiftedBaseAddr{static_cast<char *>(source->base_addr)};
305   bool isZeroSized{false};
306   for (int j{0}; j < source->rank; ++j) {
307     const CFI_dim_t &dim{source->dim[j]};
308     const CFI_index_t srcLB{dim.lower_bound};
309     const CFI_index_t srcUB{srcLB + dim.extent - 1};
310     const CFI_index_t lb{lower_bounds ? lower_bounds[j] : srcLB};
311     const CFI_index_t ub{upper_bounds ? upper_bounds[j] : srcUB};
312     const CFI_index_t stride{strides ? strides[j] : 1};
313 
314     if (stride == 0 && lb != ub) {
315       return CFI_ERROR_OUT_OF_BOUNDS;
316     }
317     if ((lb <= ub && stride >= 0) || (lb >= ub && stride < 0)) {
318       if ((lb < srcLB) || (lb > srcUB) || (ub < srcLB) || (ub > srcUB)) {
319         return CFI_ERROR_OUT_OF_BOUNDS;
320       }
321       shiftedBaseAddr += (lb - srcLB) * dim.sm;
322       extent[j] = stride != 0 ? 1 + (ub - lb) / stride : 1;
323     } else {
324       isZeroSized = true;
325       extent[j] = 0;
326     }
327     actualStride[j] = stride;
328     resRank += (stride != 0);
329   }
330   if (resRank != result->rank) {
331     return CFI_INVALID_DESCRIPTOR;
332   }
333 
334   // For zero-sized arrays, base_addr is processor-dependent (see 18.5.3).
335   // We keep it on the source base_addr
336   result->base_addr = isZeroSized ? source->base_addr : shiftedBaseAddr;
337   resRank = 0;
338   for (int j{0}; j < source->rank; ++j) {
339     if (actualStride[j] != 0) {
340       result->dim[resRank].lower_bound = 0;
341       result->dim[resRank].extent = extent[j];
342       result->dim[resRank].sm = actualStride[j] * source->dim[j].sm;
343       ++resRank;
344     }
345   }
346   return CFI_SUCCESS;
347 }
348 
349 int CFI_select_part(CFI_cdesc_t *result, const CFI_cdesc_t *source,
350     std::size_t displacement, std::size_t elem_len) {
351   if (!result || !source) {
352     return CFI_INVALID_DESCRIPTOR;
353   }
354   if (result->rank != source->rank) {
355     return CFI_INVALID_RANK;
356   }
357   if (result->attribute == CFI_attribute_allocatable) {
358     return CFI_INVALID_ATTRIBUTE;
359   }
360   if (!source->base_addr) {
361     return CFI_ERROR_BASE_ADDR_NULL;
362   }
363   if (IsAssumedSize(source)) {
364     return CFI_INVALID_DESCRIPTOR;
365   }
366 
367   if (!IsCharacterType(result->type)) {
368     elem_len = result->elem_len;
369   }
370   if (displacement + elem_len > source->elem_len) {
371     return CFI_INVALID_ELEM_LEN;
372   }
373 
374   result->base_addr = displacement + static_cast<char *>(source->base_addr);
375   result->elem_len = elem_len;
376   for (int j{0}; j < source->rank; ++j) {
377     result->dim[j].lower_bound = 0;
378     result->dim[j].extent = source->dim[j].extent;
379     result->dim[j].sm = source->dim[j].sm;
380   }
381   return CFI_SUCCESS;
382 }
383 
384 int CFI_setpointer(CFI_cdesc_t *result, const CFI_cdesc_t *source,
385     const CFI_index_t lower_bounds[]) {
386   if (!result) {
387     return CFI_INVALID_DESCRIPTOR;
388   }
389   if (result->attribute != CFI_attribute_pointer) {
390     return CFI_INVALID_ATTRIBUTE;
391   }
392   if (!source) {
393     result->base_addr = nullptr;
394     return CFI_SUCCESS;
395   }
396   if (source->rank != result->rank) {
397     return CFI_INVALID_RANK;
398   }
399   if (source->type != result->type) {
400     return CFI_INVALID_TYPE;
401   }
402   if (source->elem_len != result->elem_len) {
403     return CFI_INVALID_ELEM_LEN;
404   }
405   if (!source->base_addr && source->attribute != CFI_attribute_pointer) {
406     return CFI_ERROR_BASE_ADDR_NULL;
407   }
408   if (IsAssumedSize(source)) {
409     return CFI_INVALID_DESCRIPTOR;
410   }
411 
412   const bool copySrcLB{!lower_bounds};
413   result->base_addr = source->base_addr;
414   if (source->base_addr) {
415     for (int j{0}; j < result->rank; ++j) {
416       result->dim[j].extent = source->dim[j].extent;
417       result->dim[j].sm = source->dim[j].sm;
418       result->dim[j].lower_bound =
419           copySrcLB ? source->dim[j].lower_bound : lower_bounds[j];
420     }
421   }
422   return CFI_SUCCESS;
423 }
424 } // extern "C"
425 } // namespace Fortran::ISO
426