Bug Summary

File:build/source/flang/include/flang/Runtime/descriptor.h
Warning:line 263, column 11
The expression is an uninitialized value. The computed value will also be garbage

Annotated Source Code

Press '?' to see keyboard shortcuts

clang -cc1 -cc1 -triple x86_64-pc-linux-gnu -analyze -disable-free -clear-ast-before-backend -disable-llvm-verifier -discard-value-names -main-file-name transformational.cpp -analyzer-checker=core -analyzer-checker=apiModeling -analyzer-checker=unix -analyzer-checker=deadcode -analyzer-checker=cplusplus -analyzer-checker=security.insecureAPI.UncheckedReturn -analyzer-checker=security.insecureAPI.getpw -analyzer-checker=security.insecureAPI.gets -analyzer-checker=security.insecureAPI.mktemp -analyzer-checker=security.insecureAPI.mkstemp -analyzer-checker=security.insecureAPI.vfork -analyzer-checker=nullability.NullPassedToNonnull -analyzer-checker=nullability.NullReturnedFromNonnull -analyzer-output plist -w -setup-static-analyzer -analyzer-config-compatibility-mode=true -mrelocation-model pic -pic-level 2 -mframe-pointer=none -relaxed-aliasing -fmath-errno -ffp-contract=on -fno-rounding-math -mconstructor-aliases -funwind-tables=2 -target-cpu x86-64 -tune-cpu generic -debugger-tuning=gdb -ffunction-sections -fdata-sections -fcoverage-compilation-dir=/build/source/build-llvm/tools/clang/stage2-bins -resource-dir /usr/lib/llvm-17/lib/clang/17 -isystem /build/source/llvm/../mlir/include -isystem tools/mlir/include -isystem tools/clang/include -isystem /build/source/llvm/../clang/include -D FLANG_INCLUDE_TESTS=1 -D FLANG_LITTLE_ENDIAN=1 -D FLANG_VENDOR="Debian " -D _DEBUG -D _GLIBCXX_ASSERTIONS -D _GNU_SOURCE -D _LIBCPP_ENABLE_ASSERTIONS -D __STDC_CONSTANT_MACROS -D __STDC_FORMAT_MACROS -D __STDC_LIMIT_MACROS -I tools/flang/runtime -I /build/source/flang/runtime -I /build/source/flang/include -I tools/flang/include -I include -I /build/source/llvm/include -D _FORTIFY_SOURCE=2 -D NDEBUG -U _GLIBCXX_ASSERTIONS -U _LIBCPP_ENABLE_ASSERTIONS -U NDEBUG -internal-isystem /usr/lib/gcc/x86_64-linux-gnu/10/../../../../include/c++/10 -internal-isystem /usr/lib/gcc/x86_64-linux-gnu/10/../../../../include/x86_64-linux-gnu/c++/10 -internal-isystem /usr/lib/gcc/x86_64-linux-gnu/10/../../../../include/c++/10/backward -internal-isystem /usr/lib/llvm-17/lib/clang/17/include -internal-isystem /usr/local/include -internal-isystem /usr/lib/gcc/x86_64-linux-gnu/10/../../../../x86_64-linux-gnu/include -internal-externc-isystem /usr/include/x86_64-linux-gnu -internal-externc-isystem /include -internal-externc-isystem /usr/include -fmacro-prefix-map=/build/source/build-llvm/tools/clang/stage2-bins=build-llvm/tools/clang/stage2-bins -fmacro-prefix-map=/build/source/= -fcoverage-prefix-map=/build/source/build-llvm/tools/clang/stage2-bins=build-llvm/tools/clang/stage2-bins -fcoverage-prefix-map=/build/source/= -source-date-epoch 1683717183 -O2 -Wno-unused-command-line-argument -Wno-unused-parameter -Wwrite-strings -Wno-missing-field-initializers -Wno-long-long -Wno-maybe-uninitialized -Wno-class-memaccess -Wno-redundant-move -Wno-pessimizing-move -Wno-noexcept-type -Wno-comment -Wno-misleading-indentation -Wno-deprecated-copy -Wno-ctad-maybe-unsupported -std=c++17 -fdeprecated-macro -fdebug-compilation-dir=/build/source/build-llvm/tools/clang/stage2-bins -fdebug-prefix-map=/build/source/build-llvm/tools/clang/stage2-bins=build-llvm/tools/clang/stage2-bins -fdebug-prefix-map=/build/source/= -ferror-limit 19 -fvisibility-inlines-hidden -stack-protector 2 -fgnuc-version=4.2.1 -fcolor-diagnostics -vectorize-loops -vectorize-slp -analyzer-output=html -analyzer-config stable-report-filename=true -faddrsig -D__GCC_HAVE_DWARF2_CFI_ASM=1 -o /tmp/scan-build-2023-05-10-133810-16478-1 -x c++ /build/source/flang/runtime/transformational.cpp

/build/source/flang/runtime/transformational.cpp

→
1//===-- runtime/transformational.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 transformational intrinsic functions of Fortran 2018 that
10// rearrange or duplicate data without (much) regard to type. These are
11// CSHIFT, EOSHIFT, PACK, RESHAPE, SPREAD, TRANSPOSE, and UNPACK.
12//
13// Many of these are defined in the 2018 standard with text that makes sense
14// only if argument arrays have lower bounds of one. Rather than interpret
15// these cases as implying a hidden constraint, these implementations
16// work with arbitrary lower bounds. This may be technically an extension
17// of the standard but it more likely to conform with its intent.
18
19#include "flang/Runtime/transformational.h"
20#include "copy.h"
21#include "terminator.h"
22#include "tools.h"
23#include "flang/Runtime/descriptor.h"
24#include <algorithm>
25
26namespace Fortran::runtime {
27
28// Utility for CSHIFT & EOSHIFT rank > 1 cases that determines the shift count
29// for each of the vector sections of the result.
30class ShiftControl {
31public:
32 ShiftControl(const Descriptor &s, Terminator &t, int dim)
33 : shift_{s}, terminator_{t}, shiftRank_{s.rank()}, dim_{dim} {}
34 void Init(const Descriptor &source, const char *which) {
35 int rank{source.rank()};
36 RUNTIME_CHECK(terminator_, shiftRank_ == 0 || shiftRank_ == rank - 1)if (shiftRank_ == 0 || shiftRank_ == rank - 1) ; else (terminator_
).CheckFailed("shiftRank_ == 0 || shiftRank_ == rank - 1", "flang/runtime/transformational.cpp"
, 36);
37 auto catAndKind{shift_.type().GetCategoryAndKind()};
38 RUNTIME_CHECK(if (catAndKind && catAndKind->first == TypeCategory
::Integer) ; else (terminator_).CheckFailed("catAndKind && catAndKind->first == TypeCategory::Integer"
, "flang/runtime/transformational.cpp", 39)
39 terminator_, catAndKind && catAndKind->first == TypeCategory::Integer)if (catAndKind && catAndKind->first == TypeCategory
::Integer) ; else (terminator_).CheckFailed("catAndKind && catAndKind->first == TypeCategory::Integer"
, "flang/runtime/transformational.cpp", 39);
40 shiftElemLen_ = catAndKind->second;
41 if (shiftRank_ > 0) {
42 int k{0};
43 for (int j{0}; j < rank; ++j) {
44 if (j + 1 != dim_) {
45 const Dimension &shiftDim{shift_.GetDimension(k)};
46 lb_[k++] = shiftDim.LowerBound();
47 if (shiftDim.Extent() != source.GetDimension(j).Extent()) {
48 terminator_.Crash("%s: on dimension %d, SHIFT= has extent %jd but "
49 "SOURCE= has extent %jd",
50 which, k, static_cast<std::intmax_t>(shiftDim.Extent()),
51 static_cast<std::intmax_t>(source.GetDimension(j).Extent()));
52 }
53 }
54 }
55 } else {
56 shiftCount_ =
57 GetInt64(shift_.OffsetElement<char>(), shiftElemLen_, terminator_);
58 }
59 }
60 SubscriptValue GetShift(const SubscriptValue resultAt[]) const {
61 if (shiftRank_ > 0) {
62 SubscriptValue shiftAt[maxRank];
63 int k{0};
64 for (int j{0}; j < shiftRank_ + 1; ++j) {
65 if (j + 1 != dim_) {
66 shiftAt[k] = lb_[k] + resultAt[j] - 1;
67 ++k;
68 }
69 }
70 return GetInt64(
71 shift_.Element<char>(shiftAt), shiftElemLen_, terminator_);
72 } else {
73 return shiftCount_; // invariant count extracted in Init()
74 }
75 }
76
77private:
78 const Descriptor &shift_;
79 Terminator &terminator_;
80 int shiftRank_;
81 int dim_;
82 SubscriptValue lb_[maxRank];
83 std::size_t shiftElemLen_;
84 SubscriptValue shiftCount_{};
85};
86
87// Fill an EOSHIFT result with default boundary values
88static void DefaultInitialize(
89 const Descriptor &result, Terminator &terminator) {
90 auto catAndKind{result.type().GetCategoryAndKind()};
91 RUNTIME_CHECK(if (catAndKind && catAndKind->first != TypeCategory
::Derived) ; else (terminator).CheckFailed("catAndKind && catAndKind->first != TypeCategory::Derived"
, "flang/runtime/transformational.cpp", 92)
92 terminator, catAndKind && catAndKind->first != TypeCategory::Derived)if (catAndKind && catAndKind->first != TypeCategory
::Derived) ; else (terminator).CheckFailed("catAndKind && catAndKind->first != TypeCategory::Derived"
, "flang/runtime/transformational.cpp", 92);
93 std::size_t elementLen{result.ElementBytes()};
94 std::size_t bytes{result.Elements() * elementLen};
95 if (catAndKind->first == TypeCategory::Character) {
96 switch (int kind{catAndKind->second}) {
97 case 1:
98 std::fill_n(result.OffsetElement<char>(), bytes, ' ');
99 break;
100 case 2:
101 std::fill_n(result.OffsetElement<char16_t>(), bytes / 2,
102 static_cast<char16_t>(' '));
103 break;
104 case 4:
105 std::fill_n(result.OffsetElement<char32_t>(), bytes / 4,
106 static_cast<char32_t>(' '));
107 break;
108 default:
109 terminator.Crash("not yet implemented: EOSHIFT: CHARACTER kind %d", kind);
110 }
111 } else {
112 std::memset(result.raw().base_addr, 0, bytes);
113 }
114}
115
116static inline std::size_t AllocateResult(Descriptor &result,
117 const Descriptor &source, int rank, const SubscriptValue extent[],
118 Terminator &terminator, const char *function) {
119 std::size_t elementLen{source.ElementBytes()};
120 const DescriptorAddendum *sourceAddendum{source.Addendum()};
121 result.Establish(source.type(), elementLen, nullptr, rank, extent,
122 CFI_attribute_allocatable2, sourceAddendum != nullptr);
123 if (sourceAddendum) {
124 *result.Addendum() = *sourceAddendum;
125 }
126 for (int j{0}; j < rank; ++j) {
127 result.GetDimension(j).SetBounds(1, extent[j]);
128 }
129 if (int stat{result.Allocate()}) {
130 terminator.Crash(
131 "%s: Could not allocate memory for result (stat=%d)", function, stat);
132 }
133 return elementLen;
134}
135
136template <TypeCategory CAT, int KIND>
137static inline std::size_t AllocateBesselResult(Descriptor &result, int32_t n1,
138 int32_t n2, Terminator &terminator, const char *function) {
139 int rank{1};
140 SubscriptValue extent[maxRank];
141 for (int j{0}; j < maxRank; j++) {
142 extent[j] = 0;
143 }
144 if (n1 <= n2) {
145 extent[0] = n2 - n1 + 1;
146 }
147
148 std::size_t elementLen{Descriptor::BytesFor(CAT, KIND)};
149 result.Establish(TypeCode{CAT, KIND}, elementLen, nullptr, rank, extent,
150 CFI_attribute_allocatable2, false);
151 for (int j{0}; j < rank; ++j) {
152 result.GetDimension(j).SetBounds(1, extent[j]);
153 }
154 if (int stat{result.Allocate()}) {
155 terminator.Crash(
156 "%s: Could not allocate memory for result (stat=%d)", function, stat);
157 }
158 return elementLen;
159}
160
161template <TypeCategory CAT, int KIND>
162static inline void DoBesselJn(Descriptor &result, int32_t n1, int32_t n2,
163 CppTypeFor<CAT, KIND> x, CppTypeFor<CAT, KIND> bn2,
164 CppTypeFor<CAT, KIND> bn2_1, const char *sourceFile, int line) {
165 Terminator terminator{sourceFile, line};
166 AllocateBesselResult<CAT, KIND>(result, n1, n2, terminator, "BESSEL_JN");
167
168 // The standard requires that n1 and n2 be non-negative. However, some other
169 // compilers generate results even when n1 and/or n2 are negative. For now,
170 // we also do not enforce the non-negativity constraint.
171 if (n2 < n1) {
172 return;
173 }
174
175 SubscriptValue at[maxRank];
176 for (int j{0}; j < maxRank; ++j) {
177 at[j] = 0;
178 }
179
180 // if n2 >= n1, there will be at least one element in the result.
181 at[0] = n2 - n1 + 1;
182 *result.Element<CppTypeFor<CAT, KIND>>(at) = bn2;
183
184 if (n2 == n1) {
185 return;
186 }
187
188 at[0] = n2 - n1;
189 *result.Element<CppTypeFor<CAT, KIND>>(at) = bn2_1;
190
191 // Bessel functions of the first kind are stable for a backward recursion
192 // (see https://dlmf.nist.gov/10.74.iv and https://dlmf.nist.gov/10.6.E1).
193 //
194 // J(n-1, x) = (2.0 / x) * n * J(n, x) - J(n+1, x)
195 //
196 // which is equivalent to
197 //
198 // J(n, x) = (2.0 / x) * (n + 1) * J(n+1, x) - J(n+2, x)
199 //
200 CppTypeFor<CAT, KIND> bn_2 = bn2;
201 CppTypeFor<CAT, KIND> bn_1 = bn2_1;
202 CppTypeFor<CAT, KIND> twoOverX = 2.0 / x;
203 for (int n{n2 - 2}; n >= n1; --n) {
204 auto bn = twoOverX * (n + 1) * bn_1 - bn_2;
205
206 at[0] = n - n1 + 1;
207 *result.Element<CppTypeFor<CAT, KIND>>(at) = bn;
208
209 bn_2 = bn_1;
210 bn_1 = bn;
211 }
212}
213
214template <TypeCategory CAT, int KIND>
215static inline void DoBesselJnX0(Descriptor &result, int32_t n1, int32_t n2,
216 const char *sourceFile, int line) {
217 Terminator terminator{sourceFile, line};
218 AllocateBesselResult<CAT, KIND>(result, n1, n2, terminator, "BESSEL_JN");
219
220 // The standard requires that n1 and n2 be non-negative. However, some other
221 // compilers generate results even when n1 and/or n2 are negative. For now,
222 // we also do not enforce the non-negativity constraint.
223 if (n2 < n1) {
224 return;
225 }
226
227 SubscriptValue at[maxRank];
228 for (int j{0}; j < maxRank; ++j) {
229 at[j] = 0;
230 }
231
232 // J(0, 0.0) = 1.0, when n == 0.
233 // J(n, 0.0) = 0.0, when n > 0.
234 at[0] = 1;
235 *result.Element<CppTypeFor<CAT, KIND>>(at) = (n1 == 0) ? 1.0 : 0.0;
236 for (int j{2}; j <= n2 - n1 + 1; ++j) {
237 at[0] = j;
238 *result.Element<CppTypeFor<CAT, KIND>>(at) = 0.0;
239 }
240}
241
242template <TypeCategory CAT, int KIND>
243static inline void DoBesselYn(Descriptor &result, int32_t n1, int32_t n2,
244 CppTypeFor<CAT, KIND> x, CppTypeFor<CAT, KIND> bn1,
245 CppTypeFor<CAT, KIND> bn1_1, const char *sourceFile, int line) {
246 Terminator terminator{sourceFile, line};
247 AllocateBesselResult<CAT, KIND>(result, n1, n2, terminator, "BESSEL_YN");
248
249 // The standard requires that n1 and n2 be non-negative. However, some other
250 // compilers generate results even when n1 and/or n2 are negative. For now,
251 // we also do not enforce the non-negativity constraint.
252 if (n2 < n1) {
253 return;
254 }
255
256 SubscriptValue at[maxRank];
257 for (int j{0}; j < maxRank; ++j) {
258 at[j] = 0;
259 }
260
261 // if n2 >= n1, there will be at least one element in the result.
262 at[0] = 1;
263 *result.Element<CppTypeFor<CAT, KIND>>(at) = bn1;
264
265 if (n2 == n1) {
266 return;
267 }
268
269 at[0] = 2;
270 *result.Element<CppTypeFor<CAT, KIND>>(at) = bn1_1;
271
272 // Bessel functions of the second kind are stable for a forward recursion
273 // (see https://dlmf.nist.gov/10.74.iv and https://dlmf.nist.gov/10.6.E1).
274 //
275 // Y(n+1, x) = (2.0 / x) * n * Y(n, x) - Y(n-1, x)
276 //
277 // which is equivalent to
278 //
279 // Y(n, x) = (2.0 / x) * (n - 1) * Y(n-1, x) - Y(n-2, x)
280 //
281 CppTypeFor<CAT, KIND> bn_2 = bn1;
282 CppTypeFor<CAT, KIND> bn_1 = bn1_1;
283 CppTypeFor<CAT, KIND> twoOverX = 2.0 / x;
284 for (int n{n1 + 2}; n <= n2; ++n) {
285 auto bn = twoOverX * (n - 1) * bn_1 - bn_2;
286
287 at[0] = n - n1 + 1;
288 *result.Element<CppTypeFor<CAT, KIND>>(at) = bn;
289
290 bn_2 = bn_1;
291 bn_1 = bn;
292 }
293}
294
295template <TypeCategory CAT, int KIND>
296static inline void DoBesselYnX0(Descriptor &result, int32_t n1, int32_t n2,
297 const char *sourceFile, int line) {
298 Terminator terminator{sourceFile, line};
299 AllocateBesselResult<CAT, KIND>(result, n1, n2, terminator, "BESSEL_YN");
300
301 // The standard requires that n1 and n2 be non-negative. However, some other
302 // compilers generate results even when n1 and/or n2 are negative. For now,
303 // we also do not enforce the non-negativity constraint.
304 if (n2 < n1) {
305 return;
306 }
307
308 SubscriptValue at[maxRank];
309 for (int j{0}; j < maxRank; ++j) {
310 at[j] = 0;
311 }
312
313 // Y(n, 0.0) = -Inf, when n >= 0
314 for (int j{1}; j <= n2 - n1 + 1; ++j) {
315 at[0] = j;
316 *result.Element<CppTypeFor<CAT, KIND>>(at) =
317 -std::numeric_limits<CppTypeFor<CAT, KIND>>::infinity();
318 }
319}
320
321extern "C" {
322
323// BESSEL_JN
324// TODO: REAL(2 & 3)
325void RTNAME(BesselJn_4)_FortranABesselJn_4(Descriptor &result, int32_t n1, int32_t n2,
326 CppTypeFor<TypeCategory::Real, 4> x, CppTypeFor<TypeCategory::Real, 4> bn2,
327 CppTypeFor<TypeCategory::Real, 4> bn2_1, const char *sourceFile, int line) {
328 DoBesselJn<TypeCategory::Real, 4>(
329 result, n1, n2, x, bn2, bn2_1, sourceFile, line);
330}
331
332void RTNAME(BesselJn_8)_FortranABesselJn_8(Descriptor &result, int32_t n1, int32_t n2,
333 CppTypeFor<TypeCategory::Real, 8> x, CppTypeFor<TypeCategory::Real, 8> bn2,
334 CppTypeFor<TypeCategory::Real, 8> bn2_1, const char *sourceFile, int line) {
335 DoBesselJn<TypeCategory::Real, 8>(
336 result, n1, n2, x, bn2, bn2_1, sourceFile, line);
337}
338
339#if LDBL_MANT_DIG64 == 64
340void RTNAME(BesselJn_10)_FortranABesselJn_10(Descriptor &result, int32_t n1, int32_t n2,
341 CppTypeFor<TypeCategory::Real, 10> x,
342 CppTypeFor<TypeCategory::Real, 10> bn2,
343 CppTypeFor<TypeCategory::Real, 10> bn2_1, const char *sourceFile,
344 int line) {
345 DoBesselJn<TypeCategory::Real, 10>(
346 result, n1, n2, x, bn2, bn2_1, sourceFile, line);
347}
348#endif
349
350#if LDBL_MANT_DIG64 == 113 || HAS_FLOAT1281
351void RTNAME(BesselJn_16)_FortranABesselJn_16(Descriptor &result, int32_t n1, int32_t n2,
352 CppTypeFor<TypeCategory::Real, 16> x,
353 CppTypeFor<TypeCategory::Real, 16> bn2,
354 CppTypeFor<TypeCategory::Real, 16> bn2_1, const char *sourceFile,
355 int line) {
356 DoBesselJn<TypeCategory::Real, 16>(
357 result, n1, n2, x, bn2, bn2_1, sourceFile, line);
358}
359#endif
360
361// TODO: REAL(2 & 3)
362void RTNAME(BesselJnX0_4)_FortranABesselJnX0_4(Descriptor &result, int32_t n1, int32_t n2,
363 const char *sourceFile, int line) {
364 DoBesselJnX0<TypeCategory::Real, 4>(result, n1, n2, sourceFile, line);
365}
366
367void RTNAME(BesselJnX0_8)_FortranABesselJnX0_8(Descriptor &result, int32_t n1, int32_t n2,
368 const char *sourceFile, int line) {
369 DoBesselJnX0<TypeCategory::Real, 8>(result, n1, n2, sourceFile, line);
370}
371
372#if LDBL_MANT_DIG64 == 64
373void RTNAME(BesselJnX0_10)_FortranABesselJnX0_10(Descriptor &result, int32_t n1, int32_t n2,
374 const char *sourceFile, int line) {
375 DoBesselJnX0<TypeCategory::Real, 10>(result, n1, n2, sourceFile, line);
376}
377#endif
378
379#if LDBL_MANT_DIG64 == 113 || HAS_FLOAT1281
380void RTNAME(BesselJnX0_16)_FortranABesselJnX0_16(Descriptor &result, int32_t n1, int32_t n2,
381 const char *sourceFile, int line) {
382 DoBesselJnX0<TypeCategory::Real, 16>(result, n1, n2, sourceFile, line);
383}
384#endif
385
386// BESSEL_YN
387// TODO: REAL(2 & 3)
388void RTNAME(BesselYn_4)_FortranABesselYn_4(Descriptor &result, int32_t n1, int32_t n2,
389 CppTypeFor<TypeCategory::Real, 4> x, CppTypeFor<TypeCategory::Real, 4> bn1,
390 CppTypeFor<TypeCategory::Real, 4> bn1_1, const char *sourceFile, int line) {
391 DoBesselYn<TypeCategory::Real, 4>(
392 result, n1, n2, x, bn1, bn1_1, sourceFile, line);
393}
394
395void RTNAME(BesselYn_8)_FortranABesselYn_8(Descriptor &result, int32_t n1, int32_t n2,
396 CppTypeFor<TypeCategory::Real, 8> x, CppTypeFor<TypeCategory::Real, 8> bn1,
397 CppTypeFor<TypeCategory::Real, 8> bn1_1, const char *sourceFile, int line) {
398 DoBesselYn<TypeCategory::Real, 8>(
399 result, n1, n2, x, bn1, bn1_1, sourceFile, line);
400}
401
402#if LDBL_MANT_DIG64 == 64
403void RTNAME(BesselYn_10)_FortranABesselYn_10(Descriptor &result, int32_t n1, int32_t n2,
404 CppTypeFor<TypeCategory::Real, 10> x,
405 CppTypeFor<TypeCategory::Real, 10> bn1,
406 CppTypeFor<TypeCategory::Real, 10> bn1_1, const char *sourceFile,
407 int line) {
408 DoBesselYn<TypeCategory::Real, 10>(
409 result, n1, n2, x, bn1, bn1_1, sourceFile, line);
410}
411#endif
412
413#if LDBL_MANT_DIG64 == 113 || HAS_FLOAT1281
414void RTNAME(BesselYn_16)_FortranABesselYn_16(Descriptor &result, int32_t n1, int32_t n2,
415 CppTypeFor<TypeCategory::Real, 16> x,
416 CppTypeFor<TypeCategory::Real, 16> bn1,
417 CppTypeFor<TypeCategory::Real, 16> bn1_1, const char *sourceFile,
418 int line) {
419 DoBesselYn<TypeCategory::Real, 16>(
420 result, n1, n2, x, bn1, bn1_1, sourceFile, line);
421}
422#endif
423
424// TODO: REAL(2 & 3)
425void RTNAME(BesselYnX0_4)_FortranABesselYnX0_4(Descriptor &result, int32_t n1, int32_t n2,
426 const char *sourceFile, int line) {
427 DoBesselYnX0<TypeCategory::Real, 4>(result, n1, n2, sourceFile, line);
428}
429
430void RTNAME(BesselYnX0_8)_FortranABesselYnX0_8(Descriptor &result, int32_t n1, int32_t n2,
431 const char *sourceFile, int line) {
432 DoBesselYnX0<TypeCategory::Real, 8>(result, n1, n2, sourceFile, line);
433}
434
435#if LDBL_MANT_DIG64 == 64
436void RTNAME(BesselYnX0_10)_FortranABesselYnX0_10(Descriptor &result, int32_t n1, int32_t n2,
437 const char *sourceFile, int line) {
438 DoBesselYnX0<TypeCategory::Real, 10>(result, n1, n2, sourceFile, line);
439}
440#endif
441
442#if LDBL_MANT_DIG64 == 113 || HAS_FLOAT1281
443void RTNAME(BesselYnX0_16)_FortranABesselYnX0_16(Descriptor &result, int32_t n1, int32_t n2,
444 const char *sourceFile, int line) {
445 DoBesselYnX0<TypeCategory::Real, 16>(result, n1, n2, sourceFile, line);
446}
447#endif
448
449// CSHIFT where rank of ARRAY argument > 1
450void RTNAME(Cshift)_FortranACshift(Descriptor &result, const Descriptor &source,
451 const Descriptor &shift, int dim, const char *sourceFile, int line) {
452 Terminator terminator{sourceFile, line};
453 int rank{source.rank()};
454 RUNTIME_CHECK(terminator, rank > 1)if (rank > 1) ; else (terminator).CheckFailed("rank > 1"
, "flang/runtime/transformational.cpp", 454);
455 if (dim < 1 || dim > rank) {
456 terminator.Crash(
457 "CSHIFT: DIM=%d must be >= 1 and <= SOURCE= rank %d", dim, rank);
458 }
459 ShiftControl shiftControl{shift, terminator, dim};
460 shiftControl.Init(source, "CSHIFT");
461 SubscriptValue extent[maxRank];
462 source.GetShape(extent);
463 AllocateResult(result, source, rank, extent, terminator, "CSHIFT");
464 SubscriptValue resultAt[maxRank];
465 for (int j{0}; j < rank; ++j) {
466 resultAt[j] = 1;
467 }
468 SubscriptValue sourceLB[maxRank];
469 source.GetLowerBounds(sourceLB);
470 SubscriptValue dimExtent{extent[dim - 1]};
471 SubscriptValue dimLB{sourceLB[dim - 1]};
472 SubscriptValue &resDim{resultAt[dim - 1]};
473 for (std::size_t n{result.Elements()}; n > 0; n -= dimExtent) {
474 SubscriptValue shiftCount{shiftControl.GetShift(resultAt)};
475 SubscriptValue sourceAt[maxRank];
476 for (int j{0}; j < rank; ++j) {
477 sourceAt[j] = sourceLB[j] + resultAt[j] - 1;
478 }
479 SubscriptValue &sourceDim{sourceAt[dim - 1]};
480 sourceDim = dimLB + shiftCount % dimExtent;
481 if (sourceDim < dimLB) {
482 sourceDim += dimExtent;
483 }
484 for (resDim = 1; resDim <= dimExtent; ++resDim) {
485 CopyElement(result, resultAt, source, sourceAt, terminator);
486 if (++sourceDim == dimLB + dimExtent) {
487 sourceDim = dimLB;
488 }
489 }
490 result.IncrementSubscripts(resultAt);
491 }
492}
493
494// CSHIFT where rank of ARRAY argument == 1
495void RTNAME(CshiftVector)_FortranACshiftVector(Descriptor &result, const Descriptor &source,
496 std::int64_t shift, const char *sourceFile, int line) {
497 Terminator terminator{sourceFile, line};
498 RUNTIME_CHECK(terminator, source.rank() == 1)if (source.rank() == 1) ; else (terminator).CheckFailed("source.rank() == 1"
, "flang/runtime/transformational.cpp", 498);
499 const Dimension &sourceDim{source.GetDimension(0)};
500 SubscriptValue extent{sourceDim.Extent()};
501 AllocateResult(result, source, 1, &extent, terminator, "CSHIFT");
502 SubscriptValue lb{sourceDim.LowerBound()};
503 for (SubscriptValue j{0}; j < extent; ++j) {
504 SubscriptValue resultAt{1 + j};
505 SubscriptValue sourceAt{lb + (j + shift) % extent};
506 if (sourceAt < lb) {
507 sourceAt += extent;
508 }
509 CopyElement(result, &resultAt, source, &sourceAt, terminator);
510 }
511}
512
513// EOSHIFT of rank > 1
514void RTNAME(Eoshift)_FortranAEoshift(Descriptor &result, const Descriptor &source,
515 const Descriptor &shift, const Descriptor *boundary, int dim,
516 const char *sourceFile, int line) {
517 Terminator terminator{sourceFile, line};
518 SubscriptValue extent[maxRank];
519 int rank{source.GetShape(extent)};
520 RUNTIME_CHECK(terminator, rank > 1)if (rank > 1) ; else (terminator).CheckFailed("rank > 1"
, "flang/runtime/transformational.cpp", 520);
521 if (dim < 1 || dim > rank) {
522 terminator.Crash(
523 "EOSHIFT: DIM=%d must be >= 1 and <= SOURCE= rank %d", dim, rank);
524 }
525 std::size_t elementLen{
526 AllocateResult(result, source, rank, extent, terminator, "EOSHIFT")};
527 int boundaryRank{-1};
528 if (boundary) {
529 boundaryRank = boundary->rank();
530 RUNTIME_CHECK(terminator, boundaryRank == 0 || boundaryRank == rank - 1)if (boundaryRank == 0 || boundaryRank == rank - 1) ; else (terminator
).CheckFailed("boundaryRank == 0 || boundaryRank == rank - 1"
, "flang/runtime/transformational.cpp", 530);
531 RUNTIME_CHECK(terminator, boundary->type() == source.type())if (boundary->type() == source.type()) ; else (terminator)
.CheckFailed("boundary->type() == source.type()", "flang/runtime/transformational.cpp"
, 531);
532 if (boundary->ElementBytes() != elementLen) {
533 terminator.Crash("EOSHIFT: BOUNDARY= has element byte length %zd, but "
534 "SOURCE= has length %zd",
535 boundary->ElementBytes(), elementLen);
536 }
537 if (boundaryRank > 0) {
538 int k{0};
539 for (int j{0}; j < rank; ++j) {
540 if (j != dim - 1) {
541 if (boundary->GetDimension(k).Extent() != extent[j]) {
542 terminator.Crash("EOSHIFT: BOUNDARY= has extent %jd on dimension "
543 "%d but must conform with extent %jd of SOURCE=",
544 static_cast<std::intmax_t>(boundary->GetDimension(k).Extent()),
545 k + 1, static_cast<std::intmax_t>(extent[j]));
546 }
547 ++k;
548 }
549 }
550 }
551 }
552 ShiftControl shiftControl{shift, terminator, dim};
553 shiftControl.Init(source, "EOSHIFT");
554 SubscriptValue resultAt[maxRank];
555 for (int j{0}; j < rank; ++j) {
556 resultAt[j] = 1;
557 }
558 if (!boundary) {
559 DefaultInitialize(result, terminator);
560 }
561 SubscriptValue sourceLB[maxRank];
562 source.GetLowerBounds(sourceLB);
563 SubscriptValue boundaryAt[maxRank];
564 if (boundaryRank > 0) {
565 boundary->GetLowerBounds(boundaryAt);
566 }
567 SubscriptValue dimExtent{extent[dim - 1]};
568 SubscriptValue dimLB{sourceLB[dim - 1]};
569 SubscriptValue &resDim{resultAt[dim - 1]};
570 for (std::size_t n{result.Elements()}; n > 0; n -= dimExtent) {
571 SubscriptValue shiftCount{shiftControl.GetShift(resultAt)};
572 SubscriptValue sourceAt[maxRank];
573 for (int j{0}; j < rank; ++j) {
574 sourceAt[j] = sourceLB[j] + resultAt[j] - 1;
575 }
576 SubscriptValue &sourceDim{sourceAt[dim - 1]};
577 sourceDim = dimLB + shiftCount;
578 for (resDim = 1; resDim <= dimExtent; ++resDim) {
579 if (sourceDim >= dimLB && sourceDim < dimLB + dimExtent) {
580 CopyElement(result, resultAt, source, sourceAt, terminator);
581 } else if (boundary) {
582 CopyElement(result, resultAt, *boundary, boundaryAt, terminator);
583 }
584 ++sourceDim;
585 }
586 result.IncrementSubscripts(resultAt);
587 if (boundaryRank > 0) {
588 boundary->IncrementSubscripts(boundaryAt);
589 }
590 }
591}
592
593// EOSHIFT of vector
594void RTNAME(EoshiftVector)_FortranAEoshiftVector(Descriptor &result, const Descriptor &source,
595 std::int64_t shift, const Descriptor *boundary, const char *sourceFile,
596 int line) {
597 Terminator terminator{sourceFile, line};
598 RUNTIME_CHECK(terminator, source.rank() == 1)if (source.rank() == 1) ; else (terminator).CheckFailed("source.rank() == 1"
, "flang/runtime/transformational.cpp", 598);
599 SubscriptValue extent{source.GetDimension(0).Extent()};
600 std::size_t elementLen{
601 AllocateResult(result, source, 1, &extent, terminator, "EOSHIFT")};
602 if (boundary) {
603 RUNTIME_CHECK(terminator, boundary->rank() == 0)if (boundary->rank() == 0) ; else (terminator).CheckFailed
("boundary->rank() == 0", "flang/runtime/transformational.cpp"
, 603);
604 RUNTIME_CHECK(terminator, boundary->type() == source.type())if (boundary->type() == source.type()) ; else (terminator)
.CheckFailed("boundary->type() == source.type()", "flang/runtime/transformational.cpp"
, 604);
605 if (boundary->ElementBytes() != elementLen) {
606 terminator.Crash("EOSHIFT: BOUNDARY= has element byte length %zd but "
607 "SOURCE= has length %zd",
608 boundary->ElementBytes(), elementLen);
609 }
610 }
611 if (!boundary) {
612 DefaultInitialize(result, terminator);
613 }
614 SubscriptValue lb{source.GetDimension(0).LowerBound()};
615 for (SubscriptValue j{1}; j <= extent; ++j) {
616 SubscriptValue sourceAt{lb + j - 1 + shift};
617 if (sourceAt >= lb && sourceAt < lb + extent) {
618 CopyElement(result, &j, source, &sourceAt, terminator);
619 } else if (boundary) {
620 CopyElement(result, &j, *boundary, 0, terminator);
621 }
622 }
623}
624
625// PACK
626void RTNAME(Pack)_FortranAPack(Descriptor &result, const Descriptor &source,
627 const Descriptor &mask, const Descriptor *vector, const char *sourceFile,
628 int line) {
629 Terminator terminator{sourceFile, line};
630 CheckConformability(source, mask, terminator, "PACK", "ARRAY=", "MASK=");
631 auto maskType{mask.type().GetCategoryAndKind()};
632 RUNTIME_CHECK(if (maskType && maskType->first == TypeCategory::Logical
) ; else (terminator).CheckFailed("maskType && maskType->first == TypeCategory::Logical"
, "flang/runtime/transformational.cpp", 633)
633 terminator, maskType && maskType->first == TypeCategory::Logical)if (maskType && maskType->first == TypeCategory::Logical
) ; else (terminator).CheckFailed("maskType && maskType->first == TypeCategory::Logical"
, "flang/runtime/transformational.cpp", 633);
634 SubscriptValue trues{0};
635 if (mask.rank() == 0) {
636 if (IsLogicalElementTrue(mask, nullptr)) {
637 trues = source.Elements();
638 }
639 } else {
640 SubscriptValue maskAt[maxRank];
641 mask.GetLowerBounds(maskAt);
642 for (std::size_t n{mask.Elements()}; n > 0; --n) {
643 if (IsLogicalElementTrue(mask, maskAt)) {
644 ++trues;
645 }
646 mask.IncrementSubscripts(maskAt);
647 }
648 }
649 SubscriptValue extent{trues};
650 if (vector) {
651 RUNTIME_CHECK(terminator, vector->rank() == 1)if (vector->rank() == 1) ; else (terminator).CheckFailed("vector->rank() == 1"
, "flang/runtime/transformational.cpp", 651);
652 RUNTIME_CHECK(terminator, source.type() == vector->type())if (source.type() == vector->type()) ; else (terminator).CheckFailed
("source.type() == vector->type()", "flang/runtime/transformational.cpp"
, 652);
653 if (source.ElementBytes() != vector->ElementBytes()) {
654 terminator.Crash("PACK: SOURCE= has element byte length %zd, but VECTOR= "
655 "has length %zd",
656 source.ElementBytes(), vector->ElementBytes());
657 }
658 extent = vector->GetDimension(0).Extent();
659 if (extent < trues) {
660 terminator.Crash("PACK: VECTOR= has extent %jd but there are %jd MASK= "
661 "elements that are .TRUE.",
662 static_cast<std::intmax_t>(extent),
663 static_cast<std::intmax_t>(trues));
664 }
665 }
666 AllocateResult(result, source, 1, &extent, terminator, "PACK");
667 SubscriptValue sourceAt[maxRank], resultAt{1};
668 source.GetLowerBounds(sourceAt);
669 if (mask.rank() == 0) {
670 if (IsLogicalElementTrue(mask, nullptr)) {
671 for (SubscriptValue n{trues}; n > 0; --n) {
672 CopyElement(result, &resultAt, source, sourceAt, terminator);
673 ++resultAt;
674 source.IncrementSubscripts(sourceAt);
675 }
676 }
677 } else {
678 SubscriptValue maskAt[maxRank];
679 mask.GetLowerBounds(maskAt);
680 for (std::size_t n{source.Elements()}; n > 0; --n) {
681 if (IsLogicalElementTrue(mask, maskAt)) {
682 CopyElement(result, &resultAt, source, sourceAt, terminator);
683 ++resultAt;
684 }
685 source.IncrementSubscripts(sourceAt);
686 mask.IncrementSubscripts(maskAt);
687 }
688 }
689 if (vector) {
690 SubscriptValue vectorAt{
691 vector->GetDimension(0).LowerBound() + resultAt - 1};
692 for (; resultAt <= extent; ++resultAt, ++vectorAt) {
693 CopyElement(result, &resultAt, *vector, &vectorAt, terminator);
694 }
695 }
696}
697
698// RESHAPE
699// F2018 16.9.163
700void RTNAME(Reshape)_FortranAReshape(Descriptor &result, const Descriptor &source,
701 const Descriptor &shape, const Descriptor *pad, const Descriptor *order,
702 const char *sourceFile, int line) {
703 // Compute and check the rank of the result.
704 Terminator terminator{sourceFile, line};
705 RUNTIME_CHECK(terminator, shape.rank() == 1)if (shape.rank() == 1) ; else (terminator).CheckFailed("shape.rank() == 1"
, "flang/runtime/transformational.cpp", 705);
706 RUNTIME_CHECK(terminator, shape.type().IsInteger())if (shape.type().IsInteger()) ; else (terminator).CheckFailed
("shape.type().IsInteger()", "flang/runtime/transformational.cpp"
, 706);
707 SubscriptValue resultRank{shape.GetDimension(0).Extent()};
708 if (resultRank < 0 || resultRank > static_cast<SubscriptValue>(maxRank)) {
709 terminator.Crash(
710 "RESHAPE: SHAPE= vector length %jd implies a bad result rank",
711 static_cast<std::intmax_t>(resultRank));
712 }
713
714 // Extract and check the shape of the result; compute its element count.
715 SubscriptValue resultExtent[maxRank];
716 std::size_t shapeElementBytes{shape.ElementBytes()};
717 std::size_t resultElements{1};
718 SubscriptValue shapeSubscript{shape.GetDimension(0).LowerBound()};
719 for (int j{0}; j < resultRank; ++j, ++shapeSubscript) {
720 resultExtent[j] = GetInt64(
721 shape.Element<char>(&shapeSubscript), shapeElementBytes, terminator);
722 if (resultExtent[j] < 0) {
723 terminator.Crash("RESHAPE: bad value for SHAPE(%d)=%jd", j + 1,
724 static_cast<std::intmax_t>(resultExtent[j]));
725 }
726 resultElements *= resultExtent[j];
727 }
728
729 // Check that there are sufficient elements in the SOURCE=, or that
730 // the optional PAD= argument is present and nonempty.
731 std::size_t elementBytes{source.ElementBytes()};
732 std::size_t sourceElements{source.Elements()};
733 std::size_t padElements{pad ? pad->Elements() : 0};
734 if (resultElements > sourceElements) {
735 if (padElements <= 0) {
736 terminator.Crash(
737 "RESHAPE: not enough elements, need %zd but only have %zd",
738 resultElements, sourceElements);
739 }
740 if (pad->ElementBytes() != elementBytes) {
741 terminator.Crash("RESHAPE: PAD= has element byte length %zd but SOURCE= "
742 "has length %zd",
743 pad->ElementBytes(), elementBytes);
744 }
745 }
746
747 // Extract and check the optional ORDER= argument, which must be a
748 // permutation of [1..resultRank].
749 int dimOrder[maxRank];
750 if (order) {
751 RUNTIME_CHECK(terminator, order->rank() == 1)if (order->rank() == 1) ; else (terminator).CheckFailed("order->rank() == 1"
, "flang/runtime/transformational.cpp", 751);
752 RUNTIME_CHECK(terminator, order->type().IsInteger())if (order->type().IsInteger()) ; else (terminator).CheckFailed
("order->type().IsInteger()", "flang/runtime/transformational.cpp"
, 752);
753 if (order->GetDimension(0).Extent() != resultRank) {
754 terminator.Crash("RESHAPE: the extent of ORDER (%jd) must match the rank"
755 " of the SHAPE (%d)",
756 static_cast<std::intmax_t>(order->GetDimension(0).Extent()),
757 resultRank);
758 }
759 std::uint64_t values{0};
760 SubscriptValue orderSubscript{order->GetDimension(0).LowerBound()};
761 std::size_t orderElementBytes{order->ElementBytes()};
762 for (SubscriptValue j{0}; j < resultRank; ++j, ++orderSubscript) {
763 auto k{GetInt64(order->Element<char>(&orderSubscript), orderElementBytes,
764 terminator)};
765 if (k < 1 || k > resultRank || ((values >> k) & 1)) {
766 terminator.Crash("RESHAPE: bad value for ORDER element (%jd)",
767 static_cast<std::intmax_t>(k));
768 }
769 values |= std::uint64_t{1} << k;
770 dimOrder[j] = k - 1;
771 }
772 } else {
773 for (int j{0}; j < resultRank; ++j) {
774 dimOrder[j] = j;
775 }
776 }
777
778 // Allocate result descriptor
779 AllocateResult(
780 result, source, resultRank, resultExtent, terminator, "RESHAPE");
781
782 // Populate the result's elements.
783 SubscriptValue resultSubscript[maxRank];
784 result.GetLowerBounds(resultSubscript);
785 SubscriptValue sourceSubscript[maxRank];
786 source.GetLowerBounds(sourceSubscript);
787 std::size_t resultElement{0};
788 std::size_t elementsFromSource{std::min(resultElements, sourceElements)};
789 for (; resultElement < elementsFromSource; ++resultElement) {
790 CopyElement(result, resultSubscript, source, sourceSubscript, terminator);
791 source.IncrementSubscripts(sourceSubscript);
792 result.IncrementSubscripts(resultSubscript, dimOrder);
793 }
794 if (resultElement < resultElements) {
795 // Remaining elements come from the optional PAD= argument.
796 SubscriptValue padSubscript[maxRank];
797 pad->GetLowerBounds(padSubscript);
798 for (; resultElement < resultElements; ++resultElement) {
799 CopyElement(result, resultSubscript, *pad, padSubscript, terminator);
800 pad->IncrementSubscripts(padSubscript);
801 result.IncrementSubscripts(resultSubscript, dimOrder);
802 }
803 }
804}
805
806// SPREAD
807void RTNAME(Spread)_FortranASpread(Descriptor &result, const Descriptor &source, int dim,
808 std::int64_t ncopies, const char *sourceFile, int line) {
809 Terminator terminator{sourceFile, line};
810 int rank{source.rank() + 1};
811 RUNTIME_CHECK(terminator, rank <= maxRank)if (rank <= maxRank) ; else (terminator).CheckFailed("rank <= maxRank"
, "flang/runtime/transformational.cpp", 811);
812 if (dim < 1 || dim > rank) {
813 terminator.Crash("SPREAD: DIM=%d argument for rank-%d source array "
814 "must be greater than 1 and less than or equal to %d",
815 dim, rank - 1, rank);
816 }
817 ncopies = std::max<std::int64_t>(ncopies, 0);
818 SubscriptValue extent[maxRank];
819 int k{0};
820 for (int j{0}; j < rank; ++j) {
821 extent[j] = j == dim - 1 ? ncopies : source.GetDimension(k++).Extent();
822 }
823 AllocateResult(result, source, rank, extent, terminator, "SPREAD");
824 SubscriptValue resultAt[maxRank];
825 for (int j{0}; j < rank; ++j) {
826 resultAt[j] = 1;
827 }
828 SubscriptValue &resultDim{resultAt[dim - 1]};
829 SubscriptValue sourceAt[maxRank];
830 source.GetLowerBounds(sourceAt);
831 for (std::size_t n{result.Elements()}; n > 0; n -= ncopies) {
832 for (resultDim = 1; resultDim <= ncopies; ++resultDim) {
833 CopyElement(result, resultAt, source, sourceAt, terminator);
834 }
835 result.IncrementSubscripts(resultAt);
836 source.IncrementSubscripts(sourceAt);
837 }
838}
839
840// TRANSPOSE
841void RTNAME(Transpose)_FortranATranspose(Descriptor &result, const Descriptor &matrix,
842 const char *sourceFile, int line) {
843 Terminator terminator{sourceFile, line};
844 RUNTIME_CHECK(terminator, matrix.rank() == 2)if (matrix.rank() == 2) ; else (terminator).CheckFailed("matrix.rank() == 2"
, "flang/runtime/transformational.cpp", 844);
845 SubscriptValue extent[2]{
846 matrix.GetDimension(1).Extent(), matrix.GetDimension(0).Extent()};
847 AllocateResult(result, matrix, 2, extent, terminator, "TRANSPOSE");
848 SubscriptValue resultAt[2]{1, 1};
849 SubscriptValue matrixLB[2];
850 matrix.GetLowerBounds(matrixLB);
851 for (std::size_t n{result.Elements()}; n-- > 0;
852 result.IncrementSubscripts(resultAt)) {
853 SubscriptValue matrixAt[2]{
854 matrixLB[0] + resultAt[1] - 1, matrixLB[1] + resultAt[0] - 1};
855 CopyElement(result, resultAt, matrix, matrixAt, terminator);
856 }
857}
858
859// UNPACK
860void RTNAME(Unpack)_FortranAUnpack(Descriptor &result, const Descriptor &vector,
861 const Descriptor &mask, const Descriptor &field, const char *sourceFile,
862 int line) {
863 Terminator terminator{sourceFile, line};
864 RUNTIME_CHECK(terminator, vector.rank() == 1)if (vector.rank() == 1) ; else (terminator).CheckFailed("vector.rank() == 1"
, "flang/runtime/transformational.cpp", 864);
1
Assuming the condition is true
→
2
←
Taking true branch
→
865 int rank{mask.rank()};
866 RUNTIME_CHECK(terminator, rank > 0)if (rank > 0) ; else (terminator).CheckFailed("rank > 0"
, "flang/runtime/transformational.cpp", 866);
3
←
Assuming 'rank' is > 0
→
4
←
Taking true branch
→
867 SubscriptValue extent[maxRank];
868 mask.GetShape(extent);
869 CheckConformability(mask, field, terminator, "UNPACK", "MASK=", "FIELD=");
870 std::size_t elementLen{
871 AllocateResult(result, field, rank, extent, terminator, "UNPACK")};
872 RUNTIME_CHECK(terminator, vector.type() == field.type())if (vector.type() == field.type()) ; else (terminator).CheckFailed
("vector.type() == field.type()", "flang/runtime/transformational.cpp"
, 872);
5
←
Taking true branch
→
873 if (vector.ElementBytes() != elementLen) {
6
←
Assuming the condition is false
→
7
←
Taking false branch
→
874 terminator.Crash(
875 "UNPACK: VECTOR= has element byte length %zd but FIELD= has length %zd",
876 vector.ElementBytes(), elementLen);
877 }
878 SubscriptValue resultAt[maxRank], maskAt[maxRank], fieldAt[maxRank],
879 vectorAt{vector.GetDimension(0).LowerBound()};
880 for (int j{0}; j < rank; ++j) {
8
←
Loop condition is true. Entering loop body
→
9
←
Loop condition is false. Execution continues on line 883
→
881 resultAt[j] = 1;
882 }
883 mask.GetLowerBounds(maskAt);
884 field.GetLowerBounds(fieldAt);
885 SubscriptValue vectorElements{vector.GetDimension(0).Extent()};
886 SubscriptValue vectorLeft{vectorElements};
887 for (std::size_t n{result.Elements()}; n-- > 0;) {
10
←
Assuming the condition is true
→
11
←
Loop condition is true. Entering loop body
→
888 if (IsLogicalElementTrue(mask, maskAt)) {
12
←
Assuming the condition is false
→
13
←
Taking false branch
→
889 if (vectorLeft-- == 0) {
890 terminator.Crash(
891 "UNPACK: VECTOR= argument has fewer elements (%d) than "
892 "MASK= has .TRUE. entries",
893 vectorElements);
894 }
895 CopyElement(result, resultAt, vector, &vectorAt, terminator);
896 ++vectorAt;
897 } else {
898 CopyElement(result, resultAt, field, fieldAt, terminator);
899 }
900 result.IncrementSubscripts(resultAt);
14
←
Calling 'Descriptor::IncrementSubscripts'
→
901 mask.IncrementSubscripts(maskAt);
902 field.IncrementSubscripts(fieldAt);
903 }
904}
905
906} // extern "C"
907} // namespace Fortran::runtime
←

/build/source/flang/include/flang/Runtime/descriptor.h

1//===-- include/flang/Runtime/descriptor.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_DESCRIPTOR_H_
10#define FORTRAN_RUNTIME_DESCRIPTOR_H_
11
12// Defines data structures used during execution of a Fortran program
13// to implement nontrivial dummy arguments, pointers, allocatables,
14// function results, and the special behaviors of instances of derived types.
15// This header file includes and extends the published language
16// interoperability header that is required by the Fortran 2018 standard
17// as a subset of definitions suitable for exposure to user C/C++ code.
18// User C code is welcome to depend on that ISO_Fortran_binding.h file,
19// but should never reference this internal header.
20
21#include "flang/ISO_Fortran_binding.h"
22#include "flang/Runtime/memory.h"
23#include "flang/Runtime/type-code.h"
24#include <algorithm>
25#include <cassert>
26#include <cinttypes>
27#include <cstddef>
28#include <cstdio>
29#include <cstring>
30
31namespace Fortran::runtime::typeInfo {
32using TypeParameterValue = std::int64_t;
33class DerivedType;
34} // namespace Fortran::runtime::typeInfo
35
36namespace Fortran::runtime {
37
38using SubscriptValue = ISO::CFI_index_t;
39
40static constexpr int maxRank{CFI_MAX_RANK15};
41
42// A C++ view of the sole interoperable standard descriptor (ISO::CFI_cdesc_t)
43// and its type and per-dimension information.
44
45class Dimension {
46public:
47 SubscriptValue LowerBound() const { return raw_.lower_bound; }
48 SubscriptValue Extent() const { return raw_.extent; }
49 SubscriptValue UpperBound() const { return LowerBound() + Extent() - 1; }
50 SubscriptValue ByteStride() const { return raw_.sm; }
51
52 Dimension &SetBounds(SubscriptValue lower, SubscriptValue upper) {
53 if (upper >= lower) {
54 raw_.lower_bound = lower;
55 raw_.extent = upper - lower + 1;
56 } else {
57 raw_.lower_bound = 1;
58 raw_.extent = 0;
59 }
60 return *this;
61 }
62 // Do not use this API to cause the LB of an empty dimension
63 // to be anything other than 1. Use SetBounds() instead if you can.
64 Dimension &SetLowerBound(SubscriptValue lower) {
65 raw_.lower_bound = lower;
66 return *this;
67 }
68 Dimension &SetUpperBound(SubscriptValue upper) {
69 auto lower{raw_.lower_bound};
70 raw_.extent = upper >= lower ? upper - lower + 1 : 0;
71 return *this;
72 }
73 Dimension &SetExtent(SubscriptValue extent) {
74 raw_.extent = extent;
75 return *this;
76 }
77 Dimension &SetByteStride(SubscriptValue bytes) {
78 raw_.sm = bytes;
79 return *this;
80 }
81
82private:
83 ISO::CFI_dim_t raw_;
84};
85
86// The storage for this object follows the last used dim[] entry in a
87// Descriptor (CFI_cdesc_t) generic descriptor. Space matters here, since
88// descriptors serve as POINTER and ALLOCATABLE components of derived type
89// instances. The presence of this structure is implied by the flag
90// CFI_cdesc_t.f18Addendum, and the number of elements in the len_[]
91// array is determined by derivedType_->LenParameters().
92class DescriptorAddendum {
93public:
94 explicit DescriptorAddendum(const typeInfo::DerivedType *dt = nullptr)
95 : derivedType_{dt} {}
96 DescriptorAddendum &operator=(const DescriptorAddendum &);
97
98 const typeInfo::DerivedType *derivedType() const { return derivedType_; }
99 DescriptorAddendum &set_derivedType(const typeInfo::DerivedType *dt) {
100 derivedType_ = dt;
101 return *this;
102 }
103
104 std::size_t LenParameters() const;
105
106 typeInfo::TypeParameterValue LenParameterValue(int which) const {
107 return len_[which];
108 }
109 static constexpr std::size_t SizeInBytes(int lenParameters) {
110 // TODO: Don't waste that last word if lenParameters == 0
111 return sizeof(DescriptorAddendum) +
112 std::max(lenParameters - 1, 0) * sizeof(typeInfo::TypeParameterValue);
113 }
114 std::size_t SizeInBytes() const;
115
116 void SetLenParameterValue(int which, typeInfo::TypeParameterValue x) {
117 len_[which] = x;
118 }
119
120 void Dump(FILE * = stdoutstdout) const;
121
122private:
123 const typeInfo::DerivedType *derivedType_;
124 typeInfo::TypeParameterValue len_[1]; // must be the last component
125 // The LEN type parameter values can also include captured values of
126 // specification expressions that were used for bounds and for LEN type
127 // parameters of components. The values have been truncated to the LEN
128 // type parameter's type, if shorter than 64 bits, then sign-extended.
129};
130
131// A C++ view of a standard descriptor object.
132class Descriptor {
133public:
134 // Be advised: this class type is not suitable for use when allocating
135 // a descriptor -- it is a dynamic view of the common descriptor format.
136 // If used in a simple declaration of a local variable or dynamic allocation,
137 // the size is going to be correct only by accident, since the true size of
138 // a descriptor depends on the number of its dimensions and the presence and
139 // size of an addendum, which depends on the type of the data.
140 // Use the class template StaticDescriptor (below) to declare a descriptor
141 // whose type and rank are fixed and known at compilation time. Use the
142 // Create() static member functions otherwise to dynamically allocate a
143 // descriptor.
144
145 Descriptor(const Descriptor &);
146 Descriptor &operator=(const Descriptor &);
147
148 // Returns the number of bytes occupied by an element of the given
149 // category and kind including any alignment padding required
150 // between adjacent elements.
151 static std::size_t BytesFor(TypeCategory category, int kind);
152
153 void Establish(TypeCode t, std::size_t elementBytes, void *p = nullptr,
154 int rank = maxRank, const SubscriptValue *extent = nullptr,
155 ISO::CFI_attribute_t attribute = CFI_attribute_other0,
156 bool addendum = false);
157 void Establish(TypeCategory, int kind, void *p = nullptr, int rank = maxRank,
158 const SubscriptValue *extent = nullptr,
159 ISO::CFI_attribute_t attribute = CFI_attribute_other0,
160 bool addendum = false);
161 void Establish(int characterKind, std::size_t characters, void *p = nullptr,
162 int rank = maxRank, const SubscriptValue *extent = nullptr,
163 ISO::CFI_attribute_t attribute = CFI_attribute_other0,
164 bool addendum = false);
165 void Establish(const typeInfo::DerivedType &dt, void *p = nullptr,
166 int rank = maxRank, const SubscriptValue *extent = nullptr,
167 ISO::CFI_attribute_t attribute = CFI_attribute_other0);
168
169 static OwningPtr<Descriptor> Create(TypeCode t, std::size_t elementBytes,
170 void *p = nullptr, int rank = maxRank,
171 const SubscriptValue *extent = nullptr,
172 ISO::CFI_attribute_t attribute = CFI_attribute_other0,
173 int derivedTypeLenParameters = 0);
174 static OwningPtr<Descriptor> Create(TypeCategory, int kind, void *p = nullptr,
175 int rank = maxRank, const SubscriptValue *extent = nullptr,
176 ISO::CFI_attribute_t attribute = CFI_attribute_other0);
177 static OwningPtr<Descriptor> Create(int characterKind,
178 SubscriptValue characters, void *p = nullptr, int rank = maxRank,
179 const SubscriptValue *extent = nullptr,
180 ISO::CFI_attribute_t attribute = CFI_attribute_other0);
181 static OwningPtr<Descriptor> Create(const typeInfo::DerivedType &dt,
182 void *p = nullptr, int rank = maxRank,
183 const SubscriptValue *extent = nullptr,
184 ISO::CFI_attribute_t attribute = CFI_attribute_other0);
185
186 ISO::CFI_cdesc_t &raw() { return raw_; }
187 const ISO::CFI_cdesc_t &raw() const { return raw_; }
188 std::size_t ElementBytes() const { return raw_.elem_len; }
189 int rank() const { return raw_.rank; }
190 TypeCode type() const { return TypeCode{raw_.type}; }
191
192 Descriptor &set_base_addr(void *p) {
193 raw_.base_addr = p;
194 return *this;
195 }
196
197 bool IsPointer() const { return raw_.attribute == CFI_attribute_pointer1; }
198 bool IsAllocatable() const {
199 return raw_.attribute == CFI_attribute_allocatable2;
200 }
201 bool IsAllocated() const { return raw_.base_addr != nullptr; }
202
203 Dimension &GetDimension(int dim) {
204 return *reinterpret_cast<Dimension *>(&raw_.dim[dim]);
205 }
206 const Dimension &GetDimension(int dim) const {
207 return *reinterpret_cast<const Dimension *>(&raw_.dim[dim]);
208 }
209
210 std::size_t SubscriptByteOffset(
211 int dim, SubscriptValue subscriptValue) const {
212 const Dimension &dimension{GetDimension(dim)};
213 return (subscriptValue - dimension.LowerBound()) * dimension.ByteStride();
214 }
215
216 std::size_t SubscriptsToByteOffset(const SubscriptValue subscript[]) const {
217 std::size_t offset{0};
218 for (int j{0}; j < raw_.rank; ++j) {
219 offset += SubscriptByteOffset(j, subscript[j]);
220 }
221 return offset;
222 }
223
224 template <typename A = char> A *OffsetElement(std::size_t offset = 0) const {
225 return reinterpret_cast<A *>(
226 reinterpret_cast<char *>(raw_.base_addr) + offset);
227 }
228
229 template <typename A> A *Element(const SubscriptValue subscript[]) const {
230 return OffsetElement<A>(SubscriptsToByteOffset(subscript));
231 }
232
233 template <typename A> A *ZeroBasedIndexedElement(std::size_t n) const {
234 SubscriptValue at[maxRank];
235 if (SubscriptsForZeroBasedElementNumber(at, n)) {
236 return Element<A>(at);
237 }
238 return nullptr;
239 }
240
241 int GetLowerBounds(SubscriptValue subscript[]) const {
242 for (int j{0}; j < raw_.rank; ++j) {
243 subscript[j] = GetDimension(j).LowerBound();
244 }
245 return raw_.rank;
246 }
247
248 int GetShape(SubscriptValue subscript[]) const {
249 for (int j{0}; j < raw_.rank; ++j) {
250 subscript[j] = GetDimension(j).Extent();
251 }
252 return raw_.rank;
253 }
254
255 // When the passed subscript vector contains the last (or first)
256 // subscripts of the array, these wrap the subscripts around to
257 // their first (or last) values and return false.
258 bool IncrementSubscripts(
259 SubscriptValue subscript[], const int *permutation = nullptr) const {
260 for (int j{0}; j < raw_.rank; ++j) {
15
←
Assuming 'j' is < field 'rank'
→
20
←
Assuming 'j' is < field 'rank'
→
261 int k{permutation
16.1
'permutation' is null
21.1
'permutation' is null
16.1
'permutation' is null
21.1
'permutation' is null
 ? permutation[j] : j};
16
←
Loop condition is true. Entering loop body
→
17
←
'?' condition is false
→
21
←
Loop condition is true. Entering loop body
→
22
←
'?' condition is false
→
23
←
'k' initialized to 1
→
262 const Dimension &dim{GetDimension(k)};
263 if (subscript[k]++ < dim.UpperBound()) {
18
←
Assuming the condition is false
→
19
←
Taking false branch
→
24
←
The expression is an uninitialized value. The computed value will also be garbage
264 return true;
265 }
266 subscript[k] = dim.LowerBound();
267 }
268 return false;
269 }
270
271 bool DecrementSubscripts(
272 SubscriptValue[], const int *permutation = nullptr) const;
273
274 // False when out of range.
275 bool SubscriptsForZeroBasedElementNumber(SubscriptValue subscript[],
276 std::size_t elementNumber, const int *permutation = nullptr) const {
277 if (raw_.rank == 0) {
278 return elementNumber == 0;
279 }
280 std::size_t dimCoefficient[maxRank];
281 int k0{permutation ? permutation[0] : 0};
282 dimCoefficient[0] = 1;
283 auto coefficient{static_cast<std::size_t>(GetDimension(k0).Extent())};
284 for (int j{1}; j < raw_.rank; ++j) {
285 int k{permutation ? permutation[j] : j};
286 const Dimension &dim{GetDimension(k)};
287 dimCoefficient[j] = coefficient;
288 coefficient *= dim.Extent();
289 }
290 if (elementNumber >= coefficient) {
291 return false; // out of range
292 }
293 for (int j{raw_.rank - 1}; j > 0; --j) {
294 int k{permutation ? permutation[j] : j};
295 const Dimension &dim{GetDimension(k)};
296 std::size_t quotient{elementNumber / dimCoefficient[j]};
297 subscript[k] = quotient + dim.LowerBound();
298 elementNumber -= quotient * dimCoefficient[j];
299 }
300 subscript[k0] = elementNumber + GetDimension(k0).LowerBound();
301 return true;
302 }
303
304 std::size_t ZeroBasedElementNumber(
305 const SubscriptValue *, const int *permutation = nullptr) const;
306
307 DescriptorAddendum *Addendum() {
308 if (raw_.f18Addendum != 0) {
309 return reinterpret_cast<DescriptorAddendum *>(&GetDimension(rank()));
310 } else {
311 return nullptr;
312 }
313 }
314 const DescriptorAddendum *Addendum() const {
315 if (raw_.f18Addendum != 0) {
316 return reinterpret_cast<const DescriptorAddendum *>(
317 &GetDimension(rank()));
318 } else {
319 return nullptr;
320 }
321 }
322
323 // Returns size in bytes of the descriptor (not the data)
324 static constexpr std::size_t SizeInBytes(
325 int rank, bool addendum = false, int lengthTypeParameters = 0) {
326 std::size_t bytes{sizeof(Descriptor) - sizeof(Dimension)};
327 bytes += rank * sizeof(Dimension);
328 if (addendum || lengthTypeParameters > 0) {
329 bytes += DescriptorAddendum::SizeInBytes(lengthTypeParameters);
330 }
331 return bytes;
332 }
333
334 std::size_t SizeInBytes() const;
335
336 std::size_t Elements() const;
337
338 // Allocate() assumes Elements() and ElementBytes() work;
339 // define the extents of the dimensions and the element length
340 // before calling. It (re)computes the byte strides after
341 // allocation. Does not allocate automatic components or
342 // perform default component initialization.
343 int Allocate();
344
345 // Deallocates storage; does not call FINAL subroutines or
346 // deallocate allocatable/automatic components.
347 int Deallocate();
348
349 // Deallocates storage, including allocatable and automatic
350 // components. Optionally invokes FINAL subroutines.
351 int Destroy(bool finalize = false, bool destroyPointers = false);
352
353 bool IsContiguous(int leadingDimensions = maxRank) const {
354 auto bytes{static_cast<SubscriptValue>(ElementBytes())};
355 if (leadingDimensions > raw_.rank) {
356 leadingDimensions = raw_.rank;
357 }
358 for (int j{0}; j < leadingDimensions; ++j) {
359 const Dimension &dim{GetDimension(j)};
360 if (bytes != dim.ByteStride()) {
361 return false;
362 }
363 bytes *= dim.Extent();
364 }
365 return true;
366 }
367
368 // Establishes a pointer to a section or element.
369 bool EstablishPointerSection(const Descriptor &source,
370 const SubscriptValue *lower = nullptr,
371 const SubscriptValue *upper = nullptr,
372 const SubscriptValue *stride = nullptr);
373
374 void Check() const;
375
376 void Dump(FILE * = stdoutstdout) const;
377
378private:
379 ISO::CFI_cdesc_t raw_;
380};
381static_assert(sizeof(Descriptor) == sizeof(ISO::CFI_cdesc_t));
382
383// Properly configured instances of StaticDescriptor will occupy the
384// exact amount of storage required for the descriptor, its dimensional
385// information, and possible addendum. To build such a static descriptor,
386// declare an instance of StaticDescriptor<>, extract a reference to its
387// descriptor via the descriptor() accessor, and then built a Descriptor
388// therein via descriptor.Establish(), e.g.:
389// StaticDescriptor<R,A,LP> statDesc;
390// Descriptor &descriptor{statDesc.descriptor()};
391// descriptor.Establish( ... );
392template <int MAX_RANK = maxRank, bool ADDENDUM = false, int MAX_LEN_PARMS = 0>
393class alignas(Descriptor) StaticDescriptor {
394public:
395 static constexpr int maxRank{MAX_RANK};
396 static constexpr int maxLengthTypeParameters{MAX_LEN_PARMS};
397 static constexpr bool hasAddendum{ADDENDUM || MAX_LEN_PARMS > 0};
398 static constexpr std::size_t byteSize{
399 Descriptor::SizeInBytes(maxRank, hasAddendum, maxLengthTypeParameters)};
400
401 Descriptor &descriptor() { return *reinterpret_cast<Descriptor *>(storage_); }
402 const Descriptor &descriptor() const {
403 return *reinterpret_cast<const Descriptor *>(storage_);
404 }
405
406 void Check() {
407 assert(descriptor().rank() <= maxRank)(static_cast <bool> (descriptor().rank() <= maxRank)
? void (0) : __assert_fail ("descriptor().rank() <= maxRank"
, "flang/include/flang/Runtime/descriptor.h", 407, __extension__
__PRETTY_FUNCTION__));
408 assert(descriptor().SizeInBytes() <= byteSize)(static_cast <bool> (descriptor().SizeInBytes() <= byteSize
) ? void (0) : __assert_fail ("descriptor().SizeInBytes() <= byteSize"
, "flang/include/flang/Runtime/descriptor.h", 408, __extension__
__PRETTY_FUNCTION__));
409 if (DescriptorAddendum * addendum{descriptor().Addendum()}) {
410 assert(hasAddendum)(static_cast <bool> (hasAddendum) ? void (0) : __assert_fail
("hasAddendum", "flang/include/flang/Runtime/descriptor.h", 410
, __extension__ __PRETTY_FUNCTION__));
411 assert(addendum->LenParameters() <= maxLengthTypeParameters)(static_cast <bool> (addendum->LenParameters() <=
maxLengthTypeParameters) ? void (0) : __assert_fail ("addendum->LenParameters() <= maxLengthTypeParameters"
, "flang/include/flang/Runtime/descriptor.h", 411, __extension__
__PRETTY_FUNCTION__));
412 } else {
413 assert(!hasAddendum)(static_cast <bool> (!hasAddendum) ? void (0) : __assert_fail
("!hasAddendum", "flang/include/flang/Runtime/descriptor.h",
413, __extension__ __PRETTY_FUNCTION__));
414 assert(maxLengthTypeParameters == 0)(static_cast <bool> (maxLengthTypeParameters == 0) ? void
(0) : __assert_fail ("maxLengthTypeParameters == 0", "flang/include/flang/Runtime/descriptor.h"
, 414, __extension__ __PRETTY_FUNCTION__));
415 }
416 descriptor().Check();
417 }
418
419private:
420 char storage_[byteSize]{};
421};
422} // namespace Fortran::runtime
423#endif // FORTRAN_RUNTIME_DESCRIPTOR_H_