1//===-- runtime/tools.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#include "tools.h"
10#include "terminator.h"
11#include <algorithm>
12#include <cstdint>
13#include <cstdlib>
14#include <cstring>
15
16namespace Fortran::runtime {
17
18RT_OFFLOAD_API_GROUP_BEGIN
19
20RT_API_ATTRS std::size_t TrimTrailingSpaces(const char *s, std::size_t n) {
21 while (n > 0 && s[n - 1] == ' ') {
22 --n;
23 }
24 return n;
25}
26
27RT_API_ATTRS OwningPtr<char> SaveDefaultCharacter(
28 const char *s, std::size_t length, const Terminator &terminator) {
29 if (s) {
30 auto *p{static_cast<char *>(AllocateMemoryOrCrash(terminator, length + 1))};
31 std::memcpy(p, s, length);
32 p[length] = '\0';
33 return OwningPtr<char>{p};
34 } else {
35 return OwningPtr<char>{};
36 }
37}
38
39static RT_API_ATTRS bool CaseInsensitiveMatch(
40 const char *value, std::size_t length, const char *possibility) {
41 for (; length-- > 0; ++possibility) {
42 char ch{*value++};
43 if (ch >= 'a' && ch <= 'z') {
44 ch += 'A' - 'a';
45 }
46 if (*possibility != ch) {
47 if (*possibility != '\0' || ch != ' ') {
48 return false;
49 }
50 // Ignore trailing blanks (12.5.6.2 p1)
51 while (length-- > 0) {
52 if (*value++ != ' ') {
53 return false;
54 }
55 }
56 return true;
57 }
58 }
59 return *possibility == '\0';
60}
61
62RT_API_ATTRS int IdentifyValue(
63 const char *value, std::size_t length, const char *possibilities[]) {
64 if (value) {
65 for (int j{0}; possibilities[j]; ++j) {
66 if (CaseInsensitiveMatch(value, length, possibility: possibilities[j])) {
67 return j;
68 }
69 }
70 }
71 return -1;
72}
73
74RT_API_ATTRS void ToFortranDefaultCharacter(
75 char *to, std::size_t toLength, const char *from) {
76 std::size_t len{Fortran::runtime::strlen(from)};
77 if (len < toLength) {
78 std::memcpy(dest: to, src: from, n: len);
79 std::memset(s: to + len, c: ' ', n: toLength - len);
80 } else {
81 std::memcpy(dest: to, src: from, n: toLength);
82 }
83}
84
85RT_API_ATTRS void CheckConformability(const Descriptor &to, const Descriptor &x,
86 Terminator &terminator, const char *funcName, const char *toName,
87 const char *xName) {
88 if (x.rank() == 0) {
89 return; // scalar conforms with anything
90 }
91 int rank{to.rank()};
92 if (x.rank() != rank) {
93 terminator.Crash(
94 "Incompatible array arguments to %s: %s has rank %d but %s has rank %d",
95 funcName, toName, rank, xName, x.rank());
96 } else {
97 for (int j{0}; j < rank; ++j) {
98 auto toExtent{static_cast<std::int64_t>(to.GetDimension(j).Extent())};
99 auto xExtent{static_cast<std::int64_t>(x.GetDimension(j).Extent())};
100 if (xExtent != toExtent) {
101 terminator.Crash("Incompatible array arguments to %s: dimension %d of "
102 "%s has extent %" PRId64 " but %s has extent %" PRId64,
103 funcName, j + 1, toName, toExtent, xName, xExtent);
104 }
105 }
106 }
107}
108
109RT_API_ATTRS void CheckIntegerKind(
110 Terminator &terminator, int kind, const char *intrinsic) {
111 if (kind < 1 || kind > 16 || (kind & (kind - 1)) != 0) {
112 terminator.Crash("not yet implemented: INTEGER(KIND=%d) in %s intrinsic",
113 intrinsic, kind);
114 }
115}
116
117RT_API_ATTRS void ShallowCopyDiscontiguousToDiscontiguous(
118 const Descriptor &to, const Descriptor &from) {
119 SubscriptValue toAt[maxRank], fromAt[maxRank];
120 to.GetLowerBounds(toAt);
121 from.GetLowerBounds(fromAt);
122 std::size_t elementBytes{to.ElementBytes()};
123 for (std::size_t n{to.Elements()}; n-- > 0;
124 to.IncrementSubscripts(toAt), from.IncrementSubscripts(fromAt)) {
125 std::memcpy(
126 to.Element<char>(toAt), from.Element<char>(fromAt), elementBytes);
127 }
128}
129
130RT_API_ATTRS void ShallowCopyDiscontiguousToContiguous(
131 const Descriptor &to, const Descriptor &from) {
132 char *toAt{to.OffsetElement()};
133 SubscriptValue fromAt[maxRank];
134 from.GetLowerBounds(fromAt);
135 std::size_t elementBytes{to.ElementBytes()};
136 for (std::size_t n{to.Elements()}; n-- > 0;
137 toAt += elementBytes, from.IncrementSubscripts(fromAt)) {
138 std::memcpy(dest: toAt, src: from.Element<char>(fromAt), n: elementBytes);
139 }
140}
141
142RT_API_ATTRS void ShallowCopyContiguousToDiscontiguous(
143 const Descriptor &to, const Descriptor &from) {
144 SubscriptValue toAt[maxRank];
145 to.GetLowerBounds(toAt);
146 char *fromAt{from.OffsetElement()};
147 std::size_t elementBytes{to.ElementBytes()};
148 for (std::size_t n{to.Elements()}; n-- > 0;
149 to.IncrementSubscripts(toAt), fromAt += elementBytes) {
150 std::memcpy(dest: to.Element<char>(toAt), src: fromAt, n: elementBytes);
151 }
152}
153
154RT_API_ATTRS void ShallowCopy(const Descriptor &to, const Descriptor &from,
155 bool toIsContiguous, bool fromIsContiguous) {
156 if (toIsContiguous) {
157 if (fromIsContiguous) {
158 std::memcpy(dest: to.OffsetElement(), src: from.OffsetElement(),
159 n: to.Elements() * to.ElementBytes());
160 } else {
161 ShallowCopyDiscontiguousToContiguous(to, from);
162 }
163 } else {
164 if (fromIsContiguous) {
165 ShallowCopyContiguousToDiscontiguous(to, from);
166 } else {
167 ShallowCopyDiscontiguousToDiscontiguous(to, from);
168 }
169 }
170}
171
172RT_API_ATTRS void ShallowCopy(const Descriptor &to, const Descriptor &from) {
173 ShallowCopy(to, from, to.IsContiguous(), from.IsContiguous());
174}
175
176RT_API_ATTRS char *EnsureNullTerminated(
177 char *str, std::size_t length, Terminator &terminator) {
178 if (runtime::memchr(str, '\0', length) == nullptr) {
179 char *newCmd{(char *)AllocateMemoryOrCrash(terminator, length + 1)};
180 std::memcpy(dest: newCmd, src: str, n: length);
181 newCmd[length] = '\0';
182 return newCmd;
183 } else {
184 return str;
185 }
186}
187
188RT_API_ATTRS bool IsValidCharDescriptor(const Descriptor *value) {
189 return value && value->IsAllocated() &&
190 value->type() == TypeCode(TypeCategory::Character, 1) &&
191 value->rank() == 0;
192}
193
194RT_API_ATTRS bool IsValidIntDescriptor(const Descriptor *intVal) {
195 // Check that our descriptor is allocated and is a scalar integer with
196 // kind != 1 (i.e. with a large enough decimal exponent range).
197 return intVal && intVal->IsAllocated() && intVal->rank() == 0 &&
198 intVal->type().IsInteger() && intVal->type().GetCategoryAndKind() &&
199 intVal->type().GetCategoryAndKind()->second != 1;
200}
201
202RT_API_ATTRS std::int32_t CopyCharsToDescriptor(const Descriptor &value,
203 const char *rawValue, std::size_t rawValueLength, const Descriptor *errmsg,
204 std::size_t offset) {
205
206 const std::int64_t toCopy{std::min(static_cast<std::int64_t>(rawValueLength),
207 static_cast<std::int64_t>(value.ElementBytes() - offset))};
208 if (toCopy < 0) {
209 return ToErrmsg(errmsg, StatValueTooShort);
210 }
211
212 std::memcpy(value.OffsetElement(offset), rawValue, toCopy);
213
214 if (static_cast<std::int64_t>(rawValueLength) > toCopy) {
215 return ToErrmsg(errmsg, StatValueTooShort);
216 }
217
218 return StatOk;
219}
220
221RT_API_ATTRS void StoreIntToDescriptor(
222 const Descriptor *length, std::int64_t value, Terminator &terminator) {
223 auto typeCode{length->type().GetCategoryAndKind()};
224 int kind{typeCode->second};
225 ApplyIntegerKind<StoreIntegerAt, void>(
226 kind, terminator, *length, /* atIndex = */ 0, value);
227}
228
229template <int KIND> struct FitsInIntegerKind {
230 RT_API_ATTRS bool operator()([[maybe_unused]] std::int64_t value) {
231 if constexpr (KIND >= 8) {
232 return true;
233 } else {
234 return value <=
235 std::numeric_limits<
236 CppTypeFor<Fortran::common::TypeCategory::Integer, KIND>>::max();
237 }
238 }
239};
240
241// Utility: establishes & allocates the result array for a partial
242// reduction (i.e., one with DIM=).
243RT_API_ATTRS void CreatePartialReductionResult(Descriptor &result,
244 const Descriptor &x, std::size_t resultElementSize, int dim,
245 Terminator &terminator, const char *intrinsic, TypeCode typeCode) {
246 int xRank{x.rank()};
247 if (dim < 1 || dim > xRank) {
248 terminator.Crash(
249 "%s: bad DIM=%d for ARRAY with rank %d", intrinsic, dim, xRank);
250 }
251 int zeroBasedDim{dim - 1};
252 SubscriptValue resultExtent[maxRank];
253 for (int j{0}; j < zeroBasedDim; ++j) {
254 resultExtent[j] = x.GetDimension(j).Extent();
255 }
256 for (int j{zeroBasedDim + 1}; j < xRank; ++j) {
257 resultExtent[j - 1] = x.GetDimension(j).Extent();
258 }
259 result.Establish(typeCode, resultElementSize, nullptr, xRank - 1,
260 resultExtent, CFI_attribute_allocatable);
261 for (int j{0}; j + 1 < xRank; ++j) {
262 result.GetDimension(j).SetBounds(1, resultExtent[j]);
263 }
264 if (int stat{result.Allocate()}) {
265 terminator.Crash(
266 "%s: could not allocate memory for result; STAT=%d", intrinsic, stat);
267 }
268}
269
270RT_OFFLOAD_API_GROUP_END
271} // namespace Fortran::runtime
272

source code of flang/runtime/tools.cpp