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 "terminator.h"
13 #include "flang/Runtime/cpp-type.h"
14 #include "flang/Runtime/descriptor.h"
15 #include "flang/Runtime/memory.h"
16 #include <functional>
17 #include <map>
18 #include <type_traits>
19
20 namespace Fortran::runtime {
21
22 class Terminator;
23
24 std::size_t TrimTrailingSpaces(const char *, std::size_t);
25
26 OwningPtr<char> SaveDefaultCharacter(
27 const char *, std::size_t, const Terminator &);
28
29 // For validating and recognizing default CHARACTER values in a
30 // case-insensitive manner. Returns the zero-based index into the
31 // null-terminated array of upper-case possibilities when the value is valid,
32 // or -1 when it has no match.
33 int IdentifyValue(
34 const char *value, std::size_t length, const char *possibilities[]);
35
36 // Truncates or pads as necessary
37 void ToFortranDefaultCharacter(
38 char *to, std::size_t toLength, const char *from);
39
40 // Utility for dealing with elemental LOGICAL arguments
IsLogicalElementTrue(const Descriptor & logical,const SubscriptValue at[])41 inline bool IsLogicalElementTrue(
42 const Descriptor &logical, const SubscriptValue at[]) {
43 // A LOGICAL value is false if and only if all of its bytes are zero.
44 const char *p{logical.Element<char>(at)};
45 for (std::size_t j{logical.ElementBytes()}; j-- > 0; ++p) {
46 if (*p) {
47 return true;
48 }
49 }
50 return false;
51 }
52
53 // Check array conformability; a scalar 'x' conforms. Crashes on error.
54 void CheckConformability(const Descriptor &to, const Descriptor &x,
55 Terminator &, const char *funcName, const char *toName,
56 const char *fromName);
57
58 // Helper to store integer value in result[at].
59 template <int KIND> struct StoreIntegerAt {
operatorStoreIntegerAt60 void operator()(const Fortran::runtime::Descriptor &result, std::size_t at,
61 std::int64_t value) const {
62 *result.ZeroBasedIndexedElement<Fortran::runtime::CppTypeFor<
63 Fortran::common::TypeCategory::Integer, KIND>>(at) = value;
64 }
65 };
66
67 // Validate a KIND= argument
68 void CheckIntegerKind(Terminator &, int kind, const char *intrinsic);
69
70 template <typename TO, typename FROM>
PutContiguousConverted(TO * to,FROM * from,std::size_t count)71 inline void PutContiguousConverted(TO *to, FROM *from, std::size_t count) {
72 while (count-- > 0) {
73 *to++ = *from++;
74 }
75 }
76
GetInt64(const char * p,std::size_t bytes,Terminator & terminator)77 static inline std::int64_t GetInt64(
78 const char *p, std::size_t bytes, Terminator &terminator) {
79 switch (bytes) {
80 case 1:
81 return *reinterpret_cast<const CppTypeFor<TypeCategory::Integer, 1> *>(p);
82 case 2:
83 return *reinterpret_cast<const CppTypeFor<TypeCategory::Integer, 2> *>(p);
84 case 4:
85 return *reinterpret_cast<const CppTypeFor<TypeCategory::Integer, 4> *>(p);
86 case 8:
87 return *reinterpret_cast<const CppTypeFor<TypeCategory::Integer, 8> *>(p);
88 default:
89 terminator.Crash("GetInt64: no case for %zd bytes", bytes);
90 }
91 }
92
93 template <typename INT>
SetInteger(INT & x,int kind,std::int64_t value)94 inline bool SetInteger(INT &x, int kind, std::int64_t value) {
95 switch (kind) {
96 case 1:
97 reinterpret_cast<CppTypeFor<TypeCategory::Integer, 1> &>(x) = value;
98 return value == reinterpret_cast<CppTypeFor<TypeCategory::Integer, 1> &>(x);
99 case 2:
100 reinterpret_cast<CppTypeFor<TypeCategory::Integer, 2> &>(x) = value;
101 return value == reinterpret_cast<CppTypeFor<TypeCategory::Integer, 2> &>(x);
102 case 4:
103 reinterpret_cast<CppTypeFor<TypeCategory::Integer, 4> &>(x) = value;
104 return value == reinterpret_cast<CppTypeFor<TypeCategory::Integer, 4> &>(x);
105 case 8:
106 reinterpret_cast<CppTypeFor<TypeCategory::Integer, 8> &>(x) = value;
107 return value == reinterpret_cast<CppTypeFor<TypeCategory::Integer, 8> &>(x);
108 default:
109 return false;
110 }
111 }
112
113 // Maps intrinsic runtime type category and kind values to the appropriate
114 // instantiation of a function object template and calls it with the supplied
115 // arguments.
116 template <template <TypeCategory, int> class FUNC, typename RESULT,
117 typename... A>
ApplyType(TypeCategory cat,int kind,Terminator & terminator,A &&...x)118 inline RESULT ApplyType(
119 TypeCategory cat, int kind, Terminator &terminator, A &&...x) {
120 switch (cat) {
121 case TypeCategory::Integer:
122 switch (kind) {
123 case 1:
124 return FUNC<TypeCategory::Integer, 1>{}(std::forward<A>(x)...);
125 case 2:
126 return FUNC<TypeCategory::Integer, 2>{}(std::forward<A>(x)...);
127 case 4:
128 return FUNC<TypeCategory::Integer, 4>{}(std::forward<A>(x)...);
129 case 8:
130 return FUNC<TypeCategory::Integer, 8>{}(std::forward<A>(x)...);
131 #ifdef __SIZEOF_INT128__
132 case 16:
133 return FUNC<TypeCategory::Integer, 16>{}(std::forward<A>(x)...);
134 #endif
135 default:
136 terminator.Crash("not yet implemented: INTEGER(KIND=%d)", kind);
137 }
138 case TypeCategory::Real:
139 switch (kind) {
140 #if 0 // TODO: REAL(2 & 3)
141 case 2:
142 return FUNC<TypeCategory::Real, 2>{}(std::forward<A>(x)...);
143 case 3:
144 return FUNC<TypeCategory::Real, 3>{}(std::forward<A>(x)...);
145 #endif
146 case 4:
147 return FUNC<TypeCategory::Real, 4>{}(std::forward<A>(x)...);
148 case 8:
149 return FUNC<TypeCategory::Real, 8>{}(std::forward<A>(x)...);
150 case 10:
151 if constexpr (HasCppTypeFor<TypeCategory::Real, 10>) {
152 return FUNC<TypeCategory::Real, 10>{}(std::forward<A>(x)...);
153 }
154 break;
155 case 16:
156 if constexpr (HasCppTypeFor<TypeCategory::Real, 16>) {
157 return FUNC<TypeCategory::Real, 16>{}(std::forward<A>(x)...);
158 }
159 break;
160 }
161 terminator.Crash("not yet implemented: REAL(KIND=%d)", kind);
162 case TypeCategory::Complex:
163 switch (kind) {
164 #if 0 // TODO: COMPLEX(2 & 3)
165 case 2:
166 return FUNC<TypeCategory::Complex, 2>{}(std::forward<A>(x)...);
167 case 3:
168 return FUNC<TypeCategory::Complex, 3>{}(std::forward<A>(x)...);
169 #endif
170 case 4:
171 return FUNC<TypeCategory::Complex, 4>{}(std::forward<A>(x)...);
172 case 8:
173 return FUNC<TypeCategory::Complex, 8>{}(std::forward<A>(x)...);
174 case 10:
175 if constexpr (HasCppTypeFor<TypeCategory::Real, 10>) {
176 return FUNC<TypeCategory::Complex, 10>{}(std::forward<A>(x)...);
177 }
178 break;
179 case 16:
180 if constexpr (HasCppTypeFor<TypeCategory::Real, 16>) {
181 return FUNC<TypeCategory::Complex, 16>{}(std::forward<A>(x)...);
182 }
183 break;
184 }
185 terminator.Crash("not yet implemented: COMPLEX(KIND=%d)", kind);
186 case TypeCategory::Character:
187 switch (kind) {
188 case 1:
189 return FUNC<TypeCategory::Character, 1>{}(std::forward<A>(x)...);
190 case 2:
191 return FUNC<TypeCategory::Character, 2>{}(std::forward<A>(x)...);
192 case 4:
193 return FUNC<TypeCategory::Character, 4>{}(std::forward<A>(x)...);
194 default:
195 terminator.Crash("not yet implemented: CHARACTER(KIND=%d)", kind);
196 }
197 case TypeCategory::Logical:
198 switch (kind) {
199 case 1:
200 return FUNC<TypeCategory::Logical, 1>{}(std::forward<A>(x)...);
201 case 2:
202 return FUNC<TypeCategory::Logical, 2>{}(std::forward<A>(x)...);
203 case 4:
204 return FUNC<TypeCategory::Logical, 4>{}(std::forward<A>(x)...);
205 case 8:
206 return FUNC<TypeCategory::Logical, 8>{}(std::forward<A>(x)...);
207 default:
208 terminator.Crash("not yet implemented: LOGICAL(KIND=%d)", kind);
209 }
210 default:
211 terminator.Crash(
212 "not yet implemented: type category(%d)", static_cast<int>(cat));
213 }
214 }
215
216 // Maps a runtime INTEGER kind value to the appropriate instantiation of
217 // a function object template and calls it with the supplied arguments.
218 template <template <int KIND> class FUNC, typename RESULT, typename... A>
ApplyIntegerKind(int kind,Terminator & terminator,A &&...x)219 inline RESULT ApplyIntegerKind(int kind, Terminator &terminator, A &&...x) {
220 switch (kind) {
221 case 1:
222 return FUNC<1>{}(std::forward<A>(x)...);
223 case 2:
224 return FUNC<2>{}(std::forward<A>(x)...);
225 case 4:
226 return FUNC<4>{}(std::forward<A>(x)...);
227 case 8:
228 return FUNC<8>{}(std::forward<A>(x)...);
229 #ifdef __SIZEOF_INT128__
230 case 16:
231 return FUNC<16>{}(std::forward<A>(x)...);
232 #endif
233 default:
234 terminator.Crash("not yet implemented: INTEGER(KIND=%d)", kind);
235 }
236 }
237
238 template <template <int KIND> class FUNC, typename RESULT, typename... A>
ApplyFloatingPointKind(int kind,Terminator & terminator,A &&...x)239 inline RESULT ApplyFloatingPointKind(
240 int kind, Terminator &terminator, A &&...x) {
241 switch (kind) {
242 #if 0 // TODO: REAL/COMPLEX (2 & 3)
243 case 2:
244 return FUNC<2>{}(std::forward<A>(x)...);
245 case 3:
246 return FUNC<3>{}(std::forward<A>(x)...);
247 #endif
248 case 4:
249 return FUNC<4>{}(std::forward<A>(x)...);
250 case 8:
251 return FUNC<8>{}(std::forward<A>(x)...);
252 case 10:
253 if constexpr (HasCppTypeFor<TypeCategory::Real, 10>) {
254 return FUNC<10>{}(std::forward<A>(x)...);
255 }
256 break;
257 case 16:
258 if constexpr (HasCppTypeFor<TypeCategory::Real, 16>) {
259 return FUNC<16>{}(std::forward<A>(x)...);
260 }
261 break;
262 }
263 terminator.Crash("not yet implemented: REAL/COMPLEX(KIND=%d)", kind);
264 }
265
266 template <template <int KIND> class FUNC, typename RESULT, typename... A>
ApplyCharacterKind(int kind,Terminator & terminator,A &&...x)267 inline RESULT ApplyCharacterKind(int kind, Terminator &terminator, A &&...x) {
268 switch (kind) {
269 case 1:
270 return FUNC<1>{}(std::forward<A>(x)...);
271 case 2:
272 return FUNC<2>{}(std::forward<A>(x)...);
273 case 4:
274 return FUNC<4>{}(std::forward<A>(x)...);
275 default:
276 terminator.Crash("not yet implemented: CHARACTER(KIND=%d)", kind);
277 }
278 }
279
280 template <template <int KIND> class FUNC, typename RESULT, typename... A>
ApplyLogicalKind(int kind,Terminator & terminator,A &&...x)281 inline RESULT ApplyLogicalKind(int kind, Terminator &terminator, A &&...x) {
282 switch (kind) {
283 case 1:
284 return FUNC<1>{}(std::forward<A>(x)...);
285 case 2:
286 return FUNC<2>{}(std::forward<A>(x)...);
287 case 4:
288 return FUNC<4>{}(std::forward<A>(x)...);
289 case 8:
290 return FUNC<8>{}(std::forward<A>(x)...);
291 default:
292 terminator.Crash("not yet implemented: LOGICAL(KIND=%d)", kind);
293 }
294 }
295
296 // Calculate result type of (X op Y) for *, //, DOT_PRODUCT, &c.
GetResultType(TypeCategory xCat,int xKind,TypeCategory yCat,int yKind)297 std::optional<std::pair<TypeCategory, int>> inline constexpr GetResultType(
298 TypeCategory xCat, int xKind, TypeCategory yCat, int yKind) {
299 int maxKind{std::max(xKind, yKind)};
300 switch (xCat) {
301 case TypeCategory::Integer:
302 switch (yCat) {
303 case TypeCategory::Integer:
304 return std::make_pair(TypeCategory::Integer, maxKind);
305 case TypeCategory::Real:
306 case TypeCategory::Complex:
307 return std::make_pair(yCat, yKind);
308 default:
309 break;
310 }
311 break;
312 case TypeCategory::Real:
313 switch (yCat) {
314 case TypeCategory::Integer:
315 return std::make_pair(TypeCategory::Real, xKind);
316 case TypeCategory::Real:
317 case TypeCategory::Complex:
318 return std::make_pair(yCat, maxKind);
319 default:
320 break;
321 }
322 break;
323 case TypeCategory::Complex:
324 switch (yCat) {
325 case TypeCategory::Integer:
326 return std::make_pair(TypeCategory::Complex, xKind);
327 case TypeCategory::Real:
328 case TypeCategory::Complex:
329 return std::make_pair(TypeCategory::Complex, maxKind);
330 default:
331 break;
332 }
333 break;
334 case TypeCategory::Character:
335 if (yCat == TypeCategory::Character) {
336 return std::make_pair(TypeCategory::Character, maxKind);
337 } else {
338 return std::nullopt;
339 }
340 case TypeCategory::Logical:
341 if (yCat == TypeCategory::Logical) {
342 return std::make_pair(TypeCategory::Logical, maxKind);
343 } else {
344 return std::nullopt;
345 }
346 default:
347 break;
348 }
349 return std::nullopt;
350 }
351
352 // Accumulate floating-point results in (at least) double precision
353 template <TypeCategory CAT, int KIND>
354 using AccumulationType = CppTypeFor<CAT,
355 CAT == TypeCategory::Real || CAT == TypeCategory::Complex
356 ? std::max(KIND, static_cast<int>(sizeof(double)))
357 : KIND>;
358
359 } // namespace Fortran::runtime
360 #endif // FORTRAN_RUNTIME_TOOLS_H_
361