1//===-- runtime/tools.h -----------------------------------------*- C++ -*-===//
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#ifndef FORTRAN_RUNTIME_TOOLS_H_
10#define FORTRAN_RUNTIME_TOOLS_H_
11
12#include "freestanding-tools.h"
13#include "stat.h"
14#include "terminator.h"
15#include "flang/Runtime/cpp-type.h"
16#include "flang/Runtime/descriptor.h"
17#include "flang/Runtime/memory.h"
18#include <cstring>
19#include <functional>
20#include <map>
21#include <type_traits>
22
23namespace Fortran::runtime {
24
25class Terminator;
26
27RT_API_ATTRS std::size_t TrimTrailingSpaces(const char *, std::size_t);
28
29RT_API_ATTRS OwningPtr<char> SaveDefaultCharacter(
30 const char *, std::size_t, const Terminator &);
31
32// For validating and recognizing default CHARACTER values in a
33// case-insensitive manner. Returns the zero-based index into the
34// null-terminated array of upper-case possibilities when the value is valid,
35// or -1 when it has no match.
36RT_API_ATTRS int IdentifyValue(
37 const char *value, std::size_t length, const char *possibilities[]);
38
39// Truncates or pads as necessary
40RT_API_ATTRS void ToFortranDefaultCharacter(
41 char *to, std::size_t toLength, const char *from);
42
43// Utility for dealing with elemental LOGICAL arguments
44inline RT_API_ATTRS bool IsLogicalElementTrue(
45 const Descriptor &logical, const SubscriptValue at[]) {
46 // A LOGICAL value is false if and only if all of its bytes are zero.
47 const char *p{logical.Element<char>(at)};
48 for (std::size_t j{logical.ElementBytes()}; j-- > 0; ++p) {
49 if (*p) {
50 return true;
51 }
52 }
53 return false;
54}
55
56// Check array conformability; a scalar 'x' conforms. Crashes on error.
57RT_API_ATTRS void CheckConformability(const Descriptor &to, const Descriptor &x,
58 Terminator &, const char *funcName, const char *toName,
59 const char *fromName);
60
61// Helper to store integer value in result[at].
62template <int KIND> struct StoreIntegerAt {
63 RT_API_ATTRS void operator()(const Fortran::runtime::Descriptor &result,
64 std::size_t at, std::int64_t value) const {
65 *result.ZeroBasedIndexedElement<Fortran::runtime::CppTypeFor<
66 Fortran::common::TypeCategory::Integer, KIND>>(at) = value;
67 }
68};
69
70// Validate a KIND= argument
71RT_API_ATTRS void CheckIntegerKind(
72 Terminator &, int kind, const char *intrinsic);
73
74template <typename TO, typename FROM>
75inline RT_API_ATTRS void PutContiguousConverted(
76 TO *to, FROM *from, std::size_t count) {
77 while (count-- > 0) {
78 *to++ = *from++;
79 }
80}
81
82static inline RT_API_ATTRS std::int64_t GetInt64(
83 const char *p, std::size_t bytes, Terminator &terminator) {
84 switch (bytes) {
85 case 1:
86 return *reinterpret_cast<const CppTypeFor<TypeCategory::Integer, 1> *>(p);
87 case 2:
88 return *reinterpret_cast<const CppTypeFor<TypeCategory::Integer, 2> *>(p);
89 case 4:
90 return *reinterpret_cast<const CppTypeFor<TypeCategory::Integer, 4> *>(p);
91 case 8:
92 return *reinterpret_cast<const CppTypeFor<TypeCategory::Integer, 8> *>(p);
93 default:
94 terminator.Crash("GetInt64: no case for %zd bytes", bytes);
95 }
96}
97
98static inline RT_API_ATTRS std::optional<std::int64_t> GetInt64Safe(
99 const char *p, std::size_t bytes, Terminator &terminator) {
100 switch (bytes) {
101 case 1:
102 return *reinterpret_cast<const CppTypeFor<TypeCategory::Integer, 1> *>(p);
103 case 2:
104 return *reinterpret_cast<const CppTypeFor<TypeCategory::Integer, 2> *>(p);
105 case 4:
106 return *reinterpret_cast<const CppTypeFor<TypeCategory::Integer, 4> *>(p);
107 case 8:
108 return *reinterpret_cast<const CppTypeFor<TypeCategory::Integer, 8> *>(p);
109 case 16: {
110 using Int128 = CppTypeFor<TypeCategory::Integer, 16>;
111 auto n{*reinterpret_cast<const Int128 *>(p)};
112 std::int64_t result{static_cast<std::int64_t>(n)};
113 if (static_cast<Int128>(result) == n) {
114 return result;
115 }
116 return std::nullopt;
117 }
118 default:
119 terminator.Crash("GetInt64Safe: no case for %zd bytes", bytes);
120 }
121}
122
123template <typename INT>
124inline RT_API_ATTRS bool SetInteger(INT &x, int kind, std::int64_t value) {
125 switch (kind) {
126 case 1:
127 reinterpret_cast<CppTypeFor<TypeCategory::Integer, 1> &>(x) = value;
128 return value == reinterpret_cast<CppTypeFor<TypeCategory::Integer, 1> &>(x);
129 case 2:
130 reinterpret_cast<CppTypeFor<TypeCategory::Integer, 2> &>(x) = value;
131 return value == reinterpret_cast<CppTypeFor<TypeCategory::Integer, 2> &>(x);
132 case 4:
133 reinterpret_cast<CppTypeFor<TypeCategory::Integer, 4> &>(x) = value;
134 return value == reinterpret_cast<CppTypeFor<TypeCategory::Integer, 4> &>(x);
135 case 8:
136 reinterpret_cast<CppTypeFor<TypeCategory::Integer, 8> &>(x) = value;
137 return value == reinterpret_cast<CppTypeFor<TypeCategory::Integer, 8> &>(x);
138 default:
139 return false;
140 }
141}
142
143// Maps intrinsic runtime type category and kind values to the appropriate
144// instantiation of a function object template and calls it with the supplied
145// arguments.
146template <template <TypeCategory, int> class FUNC, typename RESULT,
147 typename... A>
148inline RT_API_ATTRS RESULT ApplyType(
149 TypeCategory cat, int kind, Terminator &terminator, A &&...x) {
150 switch (cat) {
151 case TypeCategory::Integer:
152 switch (kind) {
153 case 1:
154 return FUNC<TypeCategory::Integer, 1>{}(std::forward<A>(x)...);
155 case 2:
156 return FUNC<TypeCategory::Integer, 2>{}(std::forward<A>(x)...);
157 case 4:
158 return FUNC<TypeCategory::Integer, 4>{}(std::forward<A>(x)...);
159 case 8:
160 return FUNC<TypeCategory::Integer, 8>{}(std::forward<A>(x)...);
161#if defined __SIZEOF_INT128__ && !AVOID_NATIVE_UINT128_T
162 case 16:
163 return FUNC<TypeCategory::Integer, 16>{}(std::forward<A>(x)...);
164#endif
165 default:
166 terminator.Crash("not yet implemented: INTEGER(KIND=%d)", kind);
167 }
168 case TypeCategory::Real:
169 switch (kind) {
170#if 0 // TODO: REAL(2 & 3)
171 case 2:
172 return FUNC<TypeCategory::Real, 2>{}(std::forward<A>(x)...);
173 case 3:
174 return FUNC<TypeCategory::Real, 3>{}(std::forward<A>(x)...);
175#endif
176 case 4:
177 return FUNC<TypeCategory::Real, 4>{}(std::forward<A>(x)...);
178 case 8:
179 return FUNC<TypeCategory::Real, 8>{}(std::forward<A>(x)...);
180 case 10:
181 if constexpr (HasCppTypeFor<TypeCategory::Real, 10>) {
182 return FUNC<TypeCategory::Real, 10>{}(std::forward<A>(x)...);
183 }
184 break;
185 case 16:
186 if constexpr (HasCppTypeFor<TypeCategory::Real, 16>) {
187 return FUNC<TypeCategory::Real, 16>{}(std::forward<A>(x)...);
188 }
189 break;
190 }
191 terminator.Crash("not yet implemented: REAL(KIND=%d)", kind);
192 case TypeCategory::Complex:
193 switch (kind) {
194#if 0 // TODO: COMPLEX(2 & 3)
195 case 2:
196 return FUNC<TypeCategory::Complex, 2>{}(std::forward<A>(x)...);
197 case 3:
198 return FUNC<TypeCategory::Complex, 3>{}(std::forward<A>(x)...);
199#endif
200 case 4:
201 return FUNC<TypeCategory::Complex, 4>{}(std::forward<A>(x)...);
202 case 8:
203 return FUNC<TypeCategory::Complex, 8>{}(std::forward<A>(x)...);
204 case 10:
205 if constexpr (HasCppTypeFor<TypeCategory::Real, 10>) {
206 return FUNC<TypeCategory::Complex, 10>{}(std::forward<A>(x)...);
207 }
208 break;
209 case 16:
210 if constexpr (HasCppTypeFor<TypeCategory::Real, 16>) {
211 return FUNC<TypeCategory::Complex, 16>{}(std::forward<A>(x)...);
212 }
213 break;
214 }
215 terminator.Crash("not yet implemented: COMPLEX(KIND=%d)", kind);
216 case TypeCategory::Character:
217 switch (kind) {
218 case 1:
219 return FUNC<TypeCategory::Character, 1>{}(std::forward<A>(x)...);
220 case 2:
221 return FUNC<TypeCategory::Character, 2>{}(std::forward<A>(x)...);
222 case 4:
223 return FUNC<TypeCategory::Character, 4>{}(std::forward<A>(x)...);
224 default:
225 terminator.Crash("not yet implemented: CHARACTER(KIND=%d)", kind);
226 }
227 case TypeCategory::Logical:
228 switch (kind) {
229 case 1:
230 return FUNC<TypeCategory::Logical, 1>{}(std::forward<A>(x)...);
231 case 2:
232 return FUNC<TypeCategory::Logical, 2>{}(std::forward<A>(x)...);
233 case 4:
234 return FUNC<TypeCategory::Logical, 4>{}(std::forward<A>(x)...);
235 case 8:
236 return FUNC<TypeCategory::Logical, 8>{}(std::forward<A>(x)...);
237 default:
238 terminator.Crash("not yet implemented: LOGICAL(KIND=%d)", kind);
239 }
240 default:
241 terminator.Crash(
242 "not yet implemented: type category(%d)", static_cast<int>(cat));
243 }
244}
245
246// Maps a runtime INTEGER kind value to the appropriate instantiation of
247// a function object template and calls it with the supplied arguments.
248template <template <int KIND> class FUNC, typename RESULT, typename... A>
249inline RT_API_ATTRS RESULT ApplyIntegerKind(
250 int kind, Terminator &terminator, A &&...x) {
251 switch (kind) {
252 case 1:
253 return FUNC<1>{}(std::forward<A>(x)...);
254 case 2:
255 return FUNC<2>{}(std::forward<A>(x)...);
256 case 4:
257 return FUNC<4>{}(std::forward<A>(x)...);
258 case 8:
259 return FUNC<8>{}(std::forward<A>(x)...);
260#if defined __SIZEOF_INT128__ && !AVOID_NATIVE_UINT128_T
261 case 16:
262 return FUNC<16>{}(std::forward<A>(x)...);
263#endif
264 default:
265 terminator.Crash("not yet implemented: INTEGER(KIND=%d)", kind);
266 }
267}
268
269template <template <int KIND> class FUNC, typename RESULT, typename... A>
270inline RT_API_ATTRS RESULT ApplyFloatingPointKind(
271 int kind, Terminator &terminator, A &&...x) {
272 switch (kind) {
273#if 0 // TODO: REAL/COMPLEX (2 & 3)
274 case 2:
275 return FUNC<2>{}(std::forward<A>(x)...);
276 case 3:
277 return FUNC<3>{}(std::forward<A>(x)...);
278#endif
279 case 4:
280 return FUNC<4>{}(std::forward<A>(x)...);
281 case 8:
282 return FUNC<8>{}(std::forward<A>(x)...);
283 case 10:
284 if constexpr (HasCppTypeFor<TypeCategory::Real, 10>) {
285 return FUNC<10>{}(std::forward<A>(x)...);
286 }
287 break;
288 case 16:
289 if constexpr (HasCppTypeFor<TypeCategory::Real, 16>) {
290 return FUNC<16>{}(std::forward<A>(x)...);
291 }
292 break;
293 }
294 terminator.Crash("not yet implemented: REAL/COMPLEX(KIND=%d)", kind);
295}
296
297template <template <int KIND> class FUNC, typename RESULT, typename... A>
298inline RT_API_ATTRS RESULT ApplyCharacterKind(
299 int kind, Terminator &terminator, A &&...x) {
300 switch (kind) {
301 case 1:
302 return FUNC<1>{}(std::forward<A>(x)...);
303 case 2:
304 return FUNC<2>{}(std::forward<A>(x)...);
305 case 4:
306 return FUNC<4>{}(std::forward<A>(x)...);
307 default:
308 terminator.Crash("not yet implemented: CHARACTER(KIND=%d)", kind);
309 }
310}
311
312template <template <int KIND> class FUNC, typename RESULT, typename... A>
313inline RT_API_ATTRS RESULT ApplyLogicalKind(
314 int kind, Terminator &terminator, A &&...x) {
315 switch (kind) {
316 case 1:
317 return FUNC<1>{}(std::forward<A>(x)...);
318 case 2:
319 return FUNC<2>{}(std::forward<A>(x)...);
320 case 4:
321 return FUNC<4>{}(std::forward<A>(x)...);
322 case 8:
323 return FUNC<8>{}(std::forward<A>(x)...);
324 default:
325 terminator.Crash("not yet implemented: LOGICAL(KIND=%d)", kind);
326 }
327}
328
329// Calculate result type of (X op Y) for *, //, DOT_PRODUCT, &c.
330std::optional<std::pair<TypeCategory, int>> inline constexpr RT_API_ATTRS
331GetResultType(TypeCategory xCat, int xKind, TypeCategory yCat, int yKind) {
332 int maxKind{std::max(xKind, yKind)};
333 switch (xCat) {
334 case TypeCategory::Integer:
335 switch (yCat) {
336 case TypeCategory::Integer:
337 return std::make_pair(TypeCategory::Integer, maxKind);
338 case TypeCategory::Real:
339 case TypeCategory::Complex:
340#if !(defined __SIZEOF_INT128__ && !AVOID_NATIVE_UINT128_T)
341 if (xKind == 16) {
342 break;
343 }
344#endif
345 return std::make_pair(yCat, yKind);
346 default:
347 break;
348 }
349 break;
350 case TypeCategory::Real:
351 switch (yCat) {
352 case TypeCategory::Integer:
353#if !(defined __SIZEOF_INT128__ && !AVOID_NATIVE_UINT128_T)
354 if (yKind == 16) {
355 break;
356 }
357#endif
358 return std::make_pair(TypeCategory::Real, xKind);
359 case TypeCategory::Real:
360 case TypeCategory::Complex:
361 return std::make_pair(yCat, maxKind);
362 default:
363 break;
364 }
365 break;
366 case TypeCategory::Complex:
367 switch (yCat) {
368 case TypeCategory::Integer:
369#if !(defined __SIZEOF_INT128__ && !AVOID_NATIVE_UINT128_T)
370 if (yKind == 16) {
371 break;
372 }
373#endif
374 return std::make_pair(TypeCategory::Complex, xKind);
375 case TypeCategory::Real:
376 case TypeCategory::Complex:
377 return std::make_pair(TypeCategory::Complex, maxKind);
378 default:
379 break;
380 }
381 break;
382 case TypeCategory::Character:
383 if (yCat == TypeCategory::Character) {
384 return std::make_pair(TypeCategory::Character, maxKind);
385 } else {
386 return std::nullopt;
387 }
388 case TypeCategory::Logical:
389 if (yCat == TypeCategory::Logical) {
390 return std::make_pair(TypeCategory::Logical, maxKind);
391 } else {
392 return std::nullopt;
393 }
394 default:
395 break;
396 }
397 return std::nullopt;
398}
399
400// Accumulate floating-point results in (at least) double precision
401template <TypeCategory CAT, int KIND>
402using AccumulationType = CppTypeFor<CAT,
403 CAT == TypeCategory::Real || CAT == TypeCategory::Complex
404 ? std::max(KIND, static_cast<int>(sizeof(double)))
405 : KIND>;
406
407// memchr() for any character type
408template <typename CHAR>
409static inline RT_API_ATTRS const CHAR *FindCharacter(
410 const CHAR *data, CHAR ch, std::size_t chars) {
411 const CHAR *end{data + chars};
412 for (const CHAR *p{data}; p < end; ++p) {
413 if (*p == ch) {
414 return p;
415 }
416 }
417 return nullptr;
418}
419
420template <>
421inline RT_API_ATTRS const char *FindCharacter(
422 const char *data, char ch, std::size_t chars) {
423 return reinterpret_cast<const char *>(
424 std::memchr(s: data, c: static_cast<int>(ch), n: chars));
425}
426
427// Copy payload data from one allocated descriptor to another.
428// Assumes element counts and element sizes match, and that both
429// descriptors are allocated.
430RT_API_ATTRS void ShallowCopyDiscontiguousToDiscontiguous(
431 const Descriptor &to, const Descriptor &from);
432RT_API_ATTRS void ShallowCopyDiscontiguousToContiguous(
433 const Descriptor &to, const Descriptor &from);
434RT_API_ATTRS void ShallowCopyContiguousToDiscontiguous(
435 const Descriptor &to, const Descriptor &from);
436RT_API_ATTRS void ShallowCopy(const Descriptor &to, const Descriptor &from,
437 bool toIsContiguous, bool fromIsContiguous);
438RT_API_ATTRS void ShallowCopy(const Descriptor &to, const Descriptor &from);
439
440// Ensures that a character string is null-terminated, allocating a /p length +1
441// size memory for null-terminator if necessary. Returns the original or a newly
442// allocated null-terminated string (responsibility for deallocation is on the
443// caller).
444RT_API_ATTRS char *EnsureNullTerminated(
445 char *str, std::size_t length, Terminator &terminator);
446
447RT_API_ATTRS bool IsValidCharDescriptor(const Descriptor *value);
448
449RT_API_ATTRS bool IsValidIntDescriptor(const Descriptor *intVal);
450
451// Copy a null-terminated character array \p rawValue to descriptor \p value.
452// The copy starts at the given \p offset, if not present then start at 0.
453// If descriptor `errmsg` is provided, error messages will be stored to it.
454// Returns stats specified in standard.
455RT_API_ATTRS std::int32_t CopyCharsToDescriptor(const Descriptor &value,
456 const char *rawValue, std::size_t rawValueLength,
457 const Descriptor *errmsg = nullptr, std::size_t offset = 0);
458
459RT_API_ATTRS void StoreIntToDescriptor(
460 const Descriptor *length, std::int64_t value, Terminator &terminator);
461
462// Defines a utility function for copying and padding characters
463template <typename TO, typename FROM>
464RT_API_ATTRS void CopyAndPad(
465 TO *to, const FROM *from, std::size_t toChars, std::size_t fromChars) {
466 if constexpr (sizeof(TO) != sizeof(FROM)) {
467 std::size_t copyChars{std::min(a: toChars, b: fromChars)};
468 for (std::size_t j{0}; j < copyChars; ++j) {
469 to[j] = from[j];
470 }
471 for (std::size_t j{copyChars}; j < toChars; ++j) {
472 to[j] = static_cast<TO>(' ');
473 }
474 } else if (toChars <= fromChars) {
475 std::memcpy(dest: to, src: from, n: toChars * sizeof(TO));
476 } else {
477 std::memcpy(dest: to, src: from, n: std::min(a: toChars, b: fromChars) * sizeof(TO));
478 for (std::size_t j{fromChars}; j < toChars; ++j) {
479 to[j] = static_cast<TO>(' ');
480 }
481 }
482}
483
484} // namespace Fortran::runtime
485#endif // FORTRAN_RUNTIME_TOOLS_H_
486

source code of flang/runtime/tools.h