Bug Summary

File:build/source/flang/include/flang/Evaluate/integer.h
Warning:line 160, column 25
Assigned value is garbage or undefined

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 type.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/lib/Evaluate -I /build/source/flang/lib/Evaluate -I /build/source/flang/include -I tools/flang/include -I include -I /build/source/llvm/include -D _FORTIFY_SOURCE=2 -D NDEBUG -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/lib/Evaluate/type.cpp

/build/source/flang/lib/Evaluate/type.cpp

1//===-- lib/Evaluate/type.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 "flang/Evaluate/type.h"
10#include "flang/Common/idioms.h"
11#include "flang/Evaluate/expression.h"
12#include "flang/Evaluate/fold.h"
13#include "flang/Evaluate/target.h"
14#include "flang/Parser/characters.h"
15#include "flang/Semantics/scope.h"
16#include "flang/Semantics/symbol.h"
17#include "flang/Semantics/tools.h"
18#include "flang/Semantics/type.h"
19#include <algorithm>
20#include <optional>
21#include <string>
22
23// IsDescriptor() predicate: true when a symbol is implemented
24// at runtime with a descriptor.
25namespace Fortran::semantics {
26
27static bool IsDescriptor(const DeclTypeSpec *type) {
28 if (type) {
29 if (auto dynamicType{evaluate::DynamicType::From(*type)}) {
30 return dynamicType->RequiresDescriptor();
31 }
32 }
33 return false;
34}
35
36static bool IsDescriptor(const ObjectEntityDetails &details) {
37 if (IsDescriptor(details.type())) {
38 return true;
39 }
40 for (const ShapeSpec &shapeSpec : details.shape()) {
41 const auto &lb{shapeSpec.lbound().GetExplicit()};
42 const auto &ub{shapeSpec.ubound().GetExplicit()};
43 if (!lb || !ub || !IsConstantExpr(*lb) || !IsConstantExpr(*ub)) {
44 return true;
45 }
46 }
47 return false;
48}
49
50bool IsDescriptor(const Symbol &symbol) {
51 return common::visit(
52 common::visitors{
53 [&](const ObjectEntityDetails &d) {
54 return IsAllocatableOrPointer(symbol) || IsDescriptor(d);
55 },
56 [&](const ProcEntityDetails &d) { return false; },
57 [&](const EntityDetails &d) { return IsDescriptor(d.type()); },
58 [](const AssocEntityDetails &d) {
59 if (const auto &expr{d.expr()}) {
60 if (expr->Rank() > 0) {
61 return true;
62 }
63 if (const auto dynamicType{expr->GetType()}) {
64 if (dynamicType->RequiresDescriptor()) {
65 return true;
66 }
67 }
68 }
69 return false;
70 },
71 [](const SubprogramDetails &d) {
72 return d.isFunction() && IsDescriptor(d.result());
73 },
74 [](const UseDetails &d) { return IsDescriptor(d.symbol()); },
75 [](const HostAssocDetails &d) { return IsDescriptor(d.symbol()); },
76 [](const auto &) { return false; },
77 },
78 symbol.details());
79}
80
81bool IsPassedViaDescriptor(const Symbol &symbol) {
82 if (!IsDescriptor(symbol)) {
83 return false;
84 }
85 if (IsAllocatableOrPointer(symbol)) {
86 return true;
87 }
88 if (const auto *object{
89 symbol.GetUltimate().detailsIf<ObjectEntityDetails>()}) {
90 if (object->isDummy()) {
91 if (object->type() &&
92 object->type()->category() == DeclTypeSpec::Character) {
93 return false;
94 }
95 if (object->IsAssumedSize()) {
96 return false;
97 }
98 bool isExplicitShape{true};
99 for (const ShapeSpec &shapeSpec : object->shape()) {
100 if (!shapeSpec.lbound().GetExplicit() ||
101 !shapeSpec.ubound().GetExplicit()) {
102 isExplicitShape = false;
103 break;
104 }
105 }
106 if (isExplicitShape) {
107 return false; // explicit shape but non-constant bounds
108 }
109 }
110 }
111 return true;
112}
113} // namespace Fortran::semantics
114
115namespace Fortran::evaluate {
116
117DynamicType::DynamicType(int k, const semantics::ParamValue &pv)
118 : category_{TypeCategory::Character}, kind_{k} {
119 CHECK(IsValidKindOfIntrinsicType(category_, kind_))((IsValidKindOfIntrinsicType(category_, kind_)) || (Fortran::
common::die("CHECK(" "IsValidKindOfIntrinsicType(category_, kind_)"
") failed" " at " "flang/lib/Evaluate/type.cpp" "(%d)", 119)
, false))
;
120 if (auto n{ToInt64(pv.GetExplicit())}) {
121 knownLength_ = *n > 0 ? *n : 0;
122 } else {
123 charLengthParamValue_ = &pv;
124 }
125}
126
127template <typename A> inline bool PointeeComparison(const A *x, const A *y) {
128 return x == y || (x && y && *x == *y);
129}
130
131bool DynamicType::operator==(const DynamicType &that) const {
132 return category_ == that.category_ && kind_ == that.kind_ &&
133 PointeeComparison(charLengthParamValue_, that.charLengthParamValue_) &&
134 knownLength().has_value() == that.knownLength().has_value() &&
135 (!knownLength() || *knownLength() == *that.knownLength()) &&
136 PointeeComparison(derived_, that.derived_);
137}
138
139std::optional<Expr<SubscriptInteger>> DynamicType::GetCharLength() const {
140 if (category_ == TypeCategory::Character) {
141 if (knownLength()) {
142 return AsExpr(Constant<SubscriptInteger>(*knownLength()));
143 } else if (charLengthParamValue_) {
144 if (auto length{charLengthParamValue_->GetExplicit()}) {
145 return ConvertToType<SubscriptInteger>(std::move(*length));
146 }
147 }
148 }
149 return std::nullopt;
150}
151
152std::size_t DynamicType::GetAlignment(
153 const TargetCharacteristics &targetCharacteristics) const {
154 if (category_ == TypeCategory::Derived) {
155 if (derived_ && derived_->scope()) {
156 return derived_->scope()->alignment().value_or(1);
157 }
158 } else {
159 return targetCharacteristics.GetAlignment(category_, kind_);
160 }
161 return 1; // needs to be after switch to dodge a bogus gcc warning
162}
163
164std::optional<Expr<SubscriptInteger>> DynamicType::MeasureSizeInBytes(
165 FoldingContext &context, bool aligned,
166 std::optional<std::int64_t> charLength) const {
167 switch (category_) {
1
Control jumps to 'case Character:' at line 174
168 case TypeCategory::Integer:
169 case TypeCategory::Real:
170 case TypeCategory::Complex:
171 case TypeCategory::Logical:
172 return Expr<SubscriptInteger>{
173 context.targetCharacteristics().GetByteSize(category_, kind_)};
174 case TypeCategory::Character:
175 if (auto len{charLength ? Expr<SubscriptInteger>{Constant<SubscriptInteger>{
2
Assuming the condition is true
3
'?' condition is true
4
Calling constructor for 'Constant<Fortran::evaluate::Type<Fortran::common::TypeCategory::Integer, 8>>'
5
Calling constructor for 'ConstantBase<Fortran::evaluate::Type<Fortran::common::TypeCategory::Integer, 8>, Fortran::evaluate::value::Integer<64>>'
176 *charLength}}
177 : GetCharLength()}) {
178 return Fold(context,
179 Expr<SubscriptInteger>{
180 context.targetCharacteristics().GetByteSize(category_, kind_)} *
181 std::move(*len));
182 }
183 break;
184 case TypeCategory::Derived:
185 if (!IsPolymorphic() && derived_ && derived_->scope()) {
186 auto size{derived_->scope()->size()};
187 auto align{aligned ? derived_->scope()->alignment().value_or(0) : 0};
188 auto alignedSize{align > 0 ? ((size + align - 1) / align) * align : size};
189 return Expr<SubscriptInteger>{
190 static_cast<ConstantSubscript>(alignedSize)};
191 }
192 break;
193 }
194 return std::nullopt;
195}
196
197bool DynamicType::IsAssumedLengthCharacter() const {
198 return category_ == TypeCategory::Character && charLengthParamValue_ &&
199 charLengthParamValue_->isAssumed();
200}
201
202bool DynamicType::IsNonConstantLengthCharacter() const {
203 if (category_ != TypeCategory::Character) {
204 return false;
205 } else if (knownLength()) {
206 return false;
207 } else if (!charLengthParamValue_) {
208 return true;
209 } else if (const auto &expr{charLengthParamValue_->GetExplicit()}) {
210 return !IsConstantExpr(*expr);
211 } else {
212 return true;
213 }
214}
215
216bool DynamicType::IsTypelessIntrinsicArgument() const {
217 return category_ == TypeCategory::Integer && kind_ == TypelessKind;
218}
219
220const semantics::DerivedTypeSpec *GetDerivedTypeSpec(
221 const std::optional<DynamicType> &type) {
222 return type ? GetDerivedTypeSpec(*type) : nullptr;
223}
224
225const semantics::DerivedTypeSpec *GetDerivedTypeSpec(const DynamicType &type) {
226 if (type.category() == TypeCategory::Derived &&
227 !type.IsUnlimitedPolymorphic()) {
228 return &type.GetDerivedTypeSpec();
229 } else {
230 return nullptr;
231 }
232}
233
234static const semantics::Symbol *FindParentComponent(
235 const semantics::DerivedTypeSpec &derived) {
236 const semantics::Symbol &typeSymbol{derived.typeSymbol()};
237 const semantics::Scope *scope{derived.scope()};
238 if (!scope) {
239 scope = typeSymbol.scope();
240 }
241 if (scope) {
242 const auto &dtDetails{typeSymbol.get<semantics::DerivedTypeDetails>()};
243 // TODO: Combine with semantics::DerivedTypeDetails::GetParentComponent
244 if (auto extends{dtDetails.GetParentComponentName()}) {
245 if (auto iter{scope->find(*extends)}; iter != scope->cend()) {
246 if (const semantics::Symbol & symbol{*iter->second};
247 symbol.test(semantics::Symbol::Flag::ParentComp)) {
248 return &symbol;
249 }
250 }
251 }
252 }
253 return nullptr;
254}
255
256const semantics::DerivedTypeSpec *GetParentTypeSpec(
257 const semantics::DerivedTypeSpec &derived) {
258 if (const semantics::Symbol * parent{FindParentComponent(derived)}) {
259 return &parent->get<semantics::ObjectEntityDetails>()
260 .type()
261 ->derivedTypeSpec();
262 } else {
263 return nullptr;
264 }
265}
266
267// Compares two derived type representations to see whether they both
268// represent the "same type" in the sense of section 7.5.2.4.
269using SetOfDerivedTypePairs =
270 std::set<std::pair<const semantics::DerivedTypeSpec *,
271 const semantics::DerivedTypeSpec *>>;
272
273static bool AreSameComponent(const semantics::Symbol &x,
274 const semantics::Symbol &y,
275 SetOfDerivedTypePairs & /* inProgress - not yet used */) {
276 if (x.attrs() != y.attrs()) {
277 return false;
278 }
279 if (x.attrs().test(semantics::Attr::PRIVATE)) {
280 return false;
281 }
282 // TODO: compare types, parameters, bounds, &c.
283 return x.has<semantics::ObjectEntityDetails>() ==
284 y.has<semantics::ObjectEntityDetails>();
285}
286
287// TODO: These utilities were cloned out of Semantics to avoid a cyclic
288// dependency and should be repackaged into then "namespace semantics"
289// part of Evaluate/tools.cpp.
290
291static const semantics::Symbol *GetParentComponent(
292 const semantics::DerivedTypeDetails &details,
293 const semantics::Scope &scope) {
294 if (auto extends{details.GetParentComponentName()}) {
295 if (auto iter{scope.find(*extends)}; iter != scope.cend()) {
296 if (const Symbol & symbol{*iter->second};
297 symbol.test(semantics::Symbol::Flag::ParentComp)) {
298 return &symbol;
299 }
300 }
301 }
302 return nullptr;
303}
304
305static const semantics::Symbol *GetParentComponent(
306 const semantics::Symbol *symbol, const semantics::Scope &scope) {
307 if (symbol) {
308 if (const auto *dtDetails{
309 symbol->detailsIf<semantics::DerivedTypeDetails>()}) {
310 return GetParentComponent(*dtDetails, scope);
311 }
312 }
313 return nullptr;
314}
315
316static const semantics::DerivedTypeSpec *GetParentTypeSpec(
317 const semantics::Symbol *symbol, const semantics::Scope &scope) {
318 if (const Symbol * parentComponent{GetParentComponent(symbol, scope)}) {
319 return &parentComponent->get<semantics::ObjectEntityDetails>()
320 .type()
321 ->derivedTypeSpec();
322 } else {
323 return nullptr;
324 }
325}
326
327static const semantics::Scope *GetDerivedTypeParent(
328 const semantics::Scope *scope) {
329 if (scope) {
330 CHECK(scope->IsDerivedType())((scope->IsDerivedType()) || (Fortran::common::die("CHECK("
"scope->IsDerivedType()" ") failed" " at " "flang/lib/Evaluate/type.cpp"
"(%d)", 330), false))
;
331 if (const auto *parent{GetParentTypeSpec(scope->GetSymbol(), *scope)}) {
332 return parent->scope();
333 }
334 }
335 return nullptr;
336}
337
338static const semantics::Symbol *FindComponent(
339 const semantics::Scope *scope, parser::CharBlock name) {
340 if (!scope) {
341 return nullptr;
342 }
343 CHECK(scope->IsDerivedType())((scope->IsDerivedType()) || (Fortran::common::die("CHECK("
"scope->IsDerivedType()" ") failed" " at " "flang/lib/Evaluate/type.cpp"
"(%d)", 343), false))
;
344 auto found{scope->find(name)};
345 if (found != scope->end()) {
346 return &*found->second;
347 } else {
348 return FindComponent(GetDerivedTypeParent(scope), name);
349 }
350}
351
352static bool AreTypeParamCompatible(const semantics::DerivedTypeSpec &x,
353 const semantics::DerivedTypeSpec &y, bool ignoreLenParameters) {
354 const auto *xScope{x.typeSymbol().scope()};
355 const auto *yScope{y.typeSymbol().scope()};
356 for (const auto &[paramName, value] : x.parameters()) {
357 const auto *yValue{y.FindParameter(paramName)};
358 if (!yValue) {
359 return false;
360 }
361 const auto *xParm{FindComponent(xScope, paramName)};
362 const auto *yParm{FindComponent(yScope, paramName)};
363 if (xParm && yParm) {
364 const auto *xTPD{xParm->detailsIf<semantics::TypeParamDetails>()};
365 const auto *yTPD{yParm->detailsIf<semantics::TypeParamDetails>()};
366 if (xTPD && yTPD) {
367 if (xTPD->attr() != yTPD->attr()) {
368 return false;
369 }
370 if (!ignoreLenParameters ||
371 xTPD->attr() != common::TypeParamAttr::Len) {
372 auto xExpr{value.GetExplicit()};
373 auto yExpr{yValue->GetExplicit()};
374 if (xExpr && yExpr) {
375 auto xVal{ToInt64(*xExpr)};
376 auto yVal{ToInt64(*yExpr)};
377 if (xVal && yVal && *xVal != *yVal) {
378 return false;
379 }
380 }
381 }
382 }
383 }
384 }
385 for (const auto &[paramName, _] : y.parameters()) {
386 if (!x.FindParameter(paramName)) {
387 return false; // y has more parameters than x
388 }
389 }
390 return true;
391}
392
393static bool AreSameDerivedType(const semantics::DerivedTypeSpec &x,
394 const semantics::DerivedTypeSpec &y, bool ignoreTypeParameterValues,
395 bool ignoreLenParameters, SetOfDerivedTypePairs &inProgress) {
396 if (&x == &y) {
397 return true;
398 }
399 if (!ignoreTypeParameterValues &&
400 !AreTypeParamCompatible(x, y, ignoreLenParameters)) {
401 return false;
402 }
403 const auto &xSymbol{x.typeSymbol()};
404 const auto &ySymbol{y.typeSymbol()};
405 if (xSymbol == ySymbol) {
406 return true;
407 }
408 if (xSymbol.name() != ySymbol.name()) {
409 return false;
410 }
411 auto thisQuery{std::make_pair(&x, &y)};
412 if (inProgress.find(thisQuery) != inProgress.end()) {
413 return true; // recursive use of types in components
414 }
415 inProgress.insert(thisQuery);
416 const auto &xDetails{xSymbol.get<semantics::DerivedTypeDetails>()};
417 const auto &yDetails{ySymbol.get<semantics::DerivedTypeDetails>()};
418 if (!(xDetails.sequence() && yDetails.sequence()) &&
419 !(xSymbol.attrs().test(semantics::Attr::BIND_C) &&
420 ySymbol.attrs().test(semantics::Attr::BIND_C))) {
421 // PGI does not enforce this requirement; all other Fortran
422 // processors do with a hard error when violations are caught.
423 return false;
424 }
425 // Compare the component lists in their orders of declaration.
426 auto xEnd{xDetails.componentNames().cend()};
427 auto yComponentName{yDetails.componentNames().cbegin()};
428 auto yEnd{yDetails.componentNames().cend()};
429 for (auto xComponentName{xDetails.componentNames().cbegin()};
430 xComponentName != xEnd; ++xComponentName, ++yComponentName) {
431 if (yComponentName == yEnd || *xComponentName != *yComponentName ||
432 !xSymbol.scope() || !ySymbol.scope()) {
433 return false;
434 }
435 const auto xLookup{xSymbol.scope()->find(*xComponentName)};
436 const auto yLookup{ySymbol.scope()->find(*yComponentName)};
437 if (xLookup == xSymbol.scope()->end() ||
438 yLookup == ySymbol.scope()->end() ||
439 !AreSameComponent(*xLookup->second, *yLookup->second, inProgress)) {
440 return false;
441 }
442 }
443 return yComponentName == yEnd;
444}
445
446bool AreSameDerivedType(
447 const semantics::DerivedTypeSpec &x, const semantics::DerivedTypeSpec &y) {
448 SetOfDerivedTypePairs inProgress;
449 return AreSameDerivedType(x, y, false, false, inProgress);
450}
451
452static bool AreCompatibleDerivedTypes(const semantics::DerivedTypeSpec *x,
453 const semantics::DerivedTypeSpec *y, bool isPolymorphic,
454 bool ignoreTypeParameterValues, bool ignoreLenTypeParameters) {
455 if (!x || !y) {
456 return false;
457 } else {
458 SetOfDerivedTypePairs inProgress;
459 if (AreSameDerivedType(*x, *y, ignoreTypeParameterValues,
460 ignoreLenTypeParameters, inProgress)) {
461 return true;
462 } else {
463 return isPolymorphic &&
464 AreCompatibleDerivedTypes(x, GetParentTypeSpec(*y), true,
465 ignoreTypeParameterValues, ignoreLenTypeParameters);
466 }
467 }
468}
469
470static bool AreCompatibleTypes(const DynamicType &x, const DynamicType &y,
471 bool ignoreTypeParameterValues, bool ignoreLengths) {
472 if (x.IsUnlimitedPolymorphic()) {
473 return true;
474 } else if (y.IsUnlimitedPolymorphic()) {
475 return false;
476 } else if (x.category() != y.category()) {
477 return false;
478 } else if (x.category() == TypeCategory::Character) {
479 const auto xLen{x.knownLength()};
480 const auto yLen{y.knownLength()};
481 return x.kind() == y.kind() &&
482 (ignoreLengths || !xLen || !yLen || *xLen == *yLen);
483 } else if (x.category() != TypeCategory::Derived) {
484 return x.kind() == y.kind();
485 } else {
486 const auto *xdt{GetDerivedTypeSpec(x)};
487 const auto *ydt{GetDerivedTypeSpec(y)};
488 return AreCompatibleDerivedTypes(
489 xdt, ydt, x.IsPolymorphic(), ignoreTypeParameterValues, false);
490 }
491}
492
493// See 7.3.2.3 (5) & 15.5.2.4
494bool DynamicType::IsTkCompatibleWith(const DynamicType &that) const {
495 return AreCompatibleTypes(*this, that, false, true);
496}
497
498bool DynamicType::IsTkCompatibleWith(
499 const DynamicType &that, common::IgnoreTKRSet ignoreTKR) const {
500 if (ignoreTKR.test(common::IgnoreTKR::Type) &&
501 (category() == TypeCategory::Derived ||
502 that.category() == TypeCategory::Derived ||
503 category() != that.category())) {
504 return true;
505 } else if (ignoreTKR.test(common::IgnoreTKR::Kind) &&
506 category() == that.category()) {
507 return true;
508 } else {
509 return AreCompatibleTypes(*this, that, false, true);
510 }
511}
512
513bool DynamicType::IsTkLenCompatibleWith(const DynamicType &that) const {
514 return AreCompatibleTypes(*this, that, false, false);
515}
516
517// 16.9.165
518std::optional<bool> DynamicType::SameTypeAs(const DynamicType &that) const {
519 bool x{AreCompatibleTypes(*this, that, true, true)};
520 bool y{AreCompatibleTypes(that, *this, true, true)};
521 if (!x && !y) {
522 return false;
523 } else if (x && y && !IsPolymorphic() && !that.IsPolymorphic()) {
524 return true;
525 } else {
526 return std::nullopt;
527 }
528}
529
530// 16.9.76
531std::optional<bool> DynamicType::ExtendsTypeOf(const DynamicType &that) const {
532 if (IsUnlimitedPolymorphic() || that.IsUnlimitedPolymorphic()) {
533 return std::nullopt; // unknown
534 }
535 const auto *thisDts{evaluate::GetDerivedTypeSpec(*this)};
536 const auto *thatDts{evaluate::GetDerivedTypeSpec(that)};
537 if (!thisDts || !thatDts) {
538 return std::nullopt;
539 } else if (!AreCompatibleDerivedTypes(thatDts, thisDts, true, true, true)) {
540 // Note that I check *thisDts, not its parent, so that EXTENDS_TYPE_OF()
541 // is .true. when they are the same type. This is technically
542 // an implementation-defined case in the standard, but every other
543 // compiler works this way.
544 if (IsPolymorphic() &&
545 AreCompatibleDerivedTypes(thisDts, thatDts, true, true, true)) {
546 // 'that' is *this or an extension of *this, and so runtime *this
547 // could be an extension of 'that'
548 return std::nullopt;
549 } else {
550 return false;
551 }
552 } else if (that.IsPolymorphic()) {
553 return std::nullopt; // unknown
554 } else {
555 return true;
556 }
557}
558
559std::optional<DynamicType> DynamicType::From(
560 const semantics::DeclTypeSpec &type) {
561 if (const auto *intrinsic{type.AsIntrinsic()}) {
562 if (auto kind{ToInt64(intrinsic->kind())}) {
563 TypeCategory category{intrinsic->category()};
564 if (IsValidKindOfIntrinsicType(category, *kind)) {
565 if (category == TypeCategory::Character) {
566 const auto &charType{type.characterTypeSpec()};
567 return DynamicType{static_cast<int>(*kind), charType.length()};
568 } else {
569 return DynamicType{category, static_cast<int>(*kind)};
570 }
571 }
572 }
573 } else if (const auto *derived{type.AsDerived()}) {
574 return DynamicType{
575 *derived, type.category() == semantics::DeclTypeSpec::ClassDerived};
576 } else if (type.category() == semantics::DeclTypeSpec::ClassStar) {
577 return DynamicType::UnlimitedPolymorphic();
578 } else if (type.category() == semantics::DeclTypeSpec::TypeStar) {
579 return DynamicType::AssumedType();
580 } else {
581 common::die("DynamicType::From(DeclTypeSpec): failed");
582 }
583 return std::nullopt;
584}
585
586std::optional<DynamicType> DynamicType::From(const semantics::Symbol &symbol) {
587 return From(symbol.GetType()); // Symbol -> DeclTypeSpec -> DynamicType
588}
589
590DynamicType DynamicType::ResultTypeForMultiply(const DynamicType &that) const {
591 switch (category_) {
592 case TypeCategory::Integer:
593 switch (that.category_) {
594 case TypeCategory::Integer:
595 return DynamicType{TypeCategory::Integer, std::max(kind_, that.kind_)};
596 case TypeCategory::Real:
597 case TypeCategory::Complex:
598 return that;
599 default:
600 CRASH_NO_CASEFortran::common::die("no case" " at " "flang/lib/Evaluate/type.cpp"
"(%d)", 600)
;
601 }
602 break;
603 case TypeCategory::Real:
604 switch (that.category_) {
605 case TypeCategory::Integer:
606 return *this;
607 case TypeCategory::Real:
608 return DynamicType{TypeCategory::Real, std::max(kind_, that.kind_)};
609 case TypeCategory::Complex:
610 return DynamicType{TypeCategory::Complex, std::max(kind_, that.kind_)};
611 default:
612 CRASH_NO_CASEFortran::common::die("no case" " at " "flang/lib/Evaluate/type.cpp"
"(%d)", 612)
;
613 }
614 break;
615 case TypeCategory::Complex:
616 switch (that.category_) {
617 case TypeCategory::Integer:
618 return *this;
619 case TypeCategory::Real:
620 case TypeCategory::Complex:
621 return DynamicType{TypeCategory::Complex, std::max(kind_, that.kind_)};
622 default:
623 CRASH_NO_CASEFortran::common::die("no case" " at " "flang/lib/Evaluate/type.cpp"
"(%d)", 623)
;
624 }
625 break;
626 case TypeCategory::Logical:
627 switch (that.category_) {
628 case TypeCategory::Logical:
629 return DynamicType{TypeCategory::Logical, std::max(kind_, that.kind_)};
630 default:
631 CRASH_NO_CASEFortran::common::die("no case" " at " "flang/lib/Evaluate/type.cpp"
"(%d)", 631)
;
632 }
633 break;
634 default:
635 CRASH_NO_CASEFortran::common::die("no case" " at " "flang/lib/Evaluate/type.cpp"
"(%d)", 635)
;
636 }
637 return *this;
638}
639
640bool DynamicType::RequiresDescriptor() const {
641 return IsPolymorphic() || IsNonConstantLengthCharacter() ||
642 (derived_ && CountNonConstantLenParameters(*derived_) > 0);
643}
644
645bool DynamicType::HasDeferredTypeParameter() const {
646 if (derived_) {
647 for (const auto &pair : derived_->parameters()) {
648 if (pair.second.isDeferred()) {
649 return true;
650 }
651 }
652 }
653 return charLengthParamValue_ && charLengthParamValue_->isDeferred();
654}
655
656bool SomeKind<TypeCategory::Derived>::operator==(
657 const SomeKind<TypeCategory::Derived> &that) const {
658 return PointeeComparison(derivedTypeSpec_, that.derivedTypeSpec_);
659}
660
661int SelectedCharKind(const std::string &s, int defaultKind) { // 16.9.168
662 auto lower{parser::ToLowerCaseLetters(s)};
663 auto n{lower.size()};
664 while (n > 0 && lower[0] == ' ') {
665 lower.erase(0, 1);
666 --n;
667 }
668 while (n > 0 && lower[n - 1] == ' ') {
669 lower.erase(--n, 1);
670 }
671 if (lower == "ascii") {
672 return 1;
673 } else if (lower == "ucs-2") {
674 return 2;
675 } else if (lower == "iso_10646" || lower == "ucs-4") {
676 return 4;
677 } else if (lower == "default") {
678 return defaultKind;
679 } else {
680 return -1;
681 }
682}
683
684std::optional<DynamicType> ComparisonType(
685 const DynamicType &t1, const DynamicType &t2) {
686 switch (t1.category()) {
687 case TypeCategory::Integer:
688 switch (t2.category()) {
689 case TypeCategory::Integer:
690 return DynamicType{TypeCategory::Integer, std::max(t1.kind(), t2.kind())};
691 case TypeCategory::Real:
692 case TypeCategory::Complex:
693 return t2;
694 default:
695 return std::nullopt;
696 }
697 case TypeCategory::Real:
698 switch (t2.category()) {
699 case TypeCategory::Integer:
700 return t1;
701 case TypeCategory::Real:
702 case TypeCategory::Complex:
703 return DynamicType{t2.category(), std::max(t1.kind(), t2.kind())};
704 default:
705 return std::nullopt;
706 }
707 case TypeCategory::Complex:
708 switch (t2.category()) {
709 case TypeCategory::Integer:
710 return t1;
711 case TypeCategory::Real:
712 case TypeCategory::Complex:
713 return DynamicType{TypeCategory::Complex, std::max(t1.kind(), t2.kind())};
714 default:
715 return std::nullopt;
716 }
717 case TypeCategory::Character:
718 switch (t2.category()) {
719 case TypeCategory::Character:
720 return DynamicType{
721 TypeCategory::Character, std::max(t1.kind(), t2.kind())};
722 default:
723 return std::nullopt;
724 }
725 case TypeCategory::Logical:
726 switch (t2.category()) {
727 case TypeCategory::Logical:
728 return DynamicType{TypeCategory::Logical, LogicalResult::kind};
729 default:
730 return std::nullopt;
731 }
732 default:
733 return std::nullopt;
734 }
735}
736
737bool IsInteroperableIntrinsicType(
738 const DynamicType &type, bool checkCharLength) {
739 switch (type.category()) {
740 case TypeCategory::Integer:
741 return true;
742 case TypeCategory::Real:
743 case TypeCategory::Complex:
744 return type.kind() >= 4; // no short or half floats
745 case TypeCategory::Logical:
746 return type.kind() == 1; // C_BOOL
747 case TypeCategory::Character:
748 if (checkCharLength && type.knownLength().value_or(0) != 1) {
749 return false;
750 }
751 return type.kind() == 1 /* C_CHAR */;
752 default:
753 // Derived types are tested in Semantics/check-declarations.cpp
754 return false;
755 }
756}
757
758} // namespace Fortran::evaluate

/build/source/flang/include/flang/Evaluate/constant.h

1//===-- include/flang/Evaluate/constant.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_EVALUATE_CONSTANT_H_
10#define FORTRAN_EVALUATE_CONSTANT_H_
11
12#include "formatting.h"
13#include "type.h"
14#include "flang/Common/default-kinds.h"
15#include "flang/Common/reference.h"
16#include <map>
17#include <vector>
18
19namespace llvm {
20class raw_ostream;
21}
22
23namespace Fortran::semantics {
24class Symbol;
25}
26
27namespace Fortran::evaluate {
28
29using semantics::Symbol;
30using SymbolRef = common::Reference<const Symbol>;
31
32// Wraps a constant value in a class templated by its resolved type.
33// This Constant<> template class should be instantiated only for
34// concrete intrinsic types and SomeDerived. There is no instance
35// Constant<SomeType> since there is no way to constrain each
36// element of its array to hold the same type. To represent a generic
37// constant, use a generic expression like Expr<SomeInteger> or
38// Expr<SomeType>) to wrap the appropriate instantiation of Constant<>.
39
40template <typename> class Constant;
41
42// When describing shapes of constants or specifying 1-based subscript
43// values as indices into constants, use a vector of integers.
44using ConstantSubscripts = std::vector<ConstantSubscript>;
45inline int GetRank(const ConstantSubscripts &s) {
46 return static_cast<int>(s.size());
47}
48
49std::size_t TotalElementCount(const ConstantSubscripts &);
50
51// Validate dimension re-ordering like ORDER in RESHAPE.
52// On success, return a vector that can be used as dimOrder in
53// ConstantBounds::IncrementSubscripts().
54std::optional<std::vector<int>> ValidateDimensionOrder(
55 int rank, const std::vector<int> &order);
56
57bool HasNegativeExtent(const ConstantSubscripts &);
58
59class ConstantBounds {
60public:
61 ConstantBounds() = default;
62 explicit ConstantBounds(const ConstantSubscripts &shape);
63 explicit ConstantBounds(ConstantSubscripts &&shape);
64 ~ConstantBounds();
65 const ConstantSubscripts &shape() const { return shape_; }
66 const ConstantSubscripts &lbounds() const { return lbounds_; }
67 ConstantSubscripts ComputeUbounds(std::optional<int> dim) const;
68 void set_lbounds(ConstantSubscripts &&);
69 void SetLowerBoundsToOne();
70 int Rank() const { return GetRank(shape_); }
71 Constant<SubscriptInteger> SHAPE() const;
72
73 // If no optional dimension order argument is passed, increments a vector of
74 // subscripts in Fortran array order (first dimension varying most quickly).
75 // Otherwise, increments the vector of subscripts according to the given
76 // dimension order (dimension dimOrder[0] varying most quickly; dimension
77 // indexing is zero based here). Returns false when last element was visited.
78 bool IncrementSubscripts(
79 ConstantSubscripts &, const std::vector<int> *dimOrder = nullptr) const;
80
81protected:
82 ConstantSubscript SubscriptsToOffset(const ConstantSubscripts &) const;
83
84private:
85 ConstantSubscripts shape_;
86 ConstantSubscripts lbounds_;
87};
88
89// Constant<> is specialized for Character kinds and SomeDerived.
90// The non-Character intrinsic types, and SomeDerived, share enough
91// common behavior that they use this common base class.
92template <typename RESULT, typename ELEMENT = Scalar<RESULT>>
93class ConstantBase : public ConstantBounds {
94 static_assert(RESULT::category != TypeCategory::Character);
95
96public:
97 using Result = RESULT;
98 using Element = ELEMENT;
99
100 template <typename A>
101 ConstantBase(const A &x, Result res = Result{}) : result_{res}, values_{x} {}
6
Calling constructor for 'Integer<64, true, 32, unsigned int, unsigned long>'
102 ConstantBase(ELEMENT &&x, Result res = Result{})
103 : result_{res}, values_{std::move(x)} {}
104 ConstantBase(
105 std::vector<Element> &&, ConstantSubscripts &&, Result = Result{});
106
107 DEFAULT_CONSTRUCTORS_AND_ASSIGNMENTS(ConstantBase)ConstantBase(const ConstantBase &) = default; ConstantBase
(ConstantBase &&) = default; ConstantBase &operator
=(const ConstantBase &) = default; ConstantBase &operator
=(ConstantBase &&) = default;
108 ~ConstantBase();
109
110 bool operator==(const ConstantBase &) const;
111 bool empty() const { return values_.empty(); }
112 std::size_t size() const { return values_.size(); }
113 const std::vector<Element> &values() const { return values_; }
114 constexpr Result result() const { return result_; }
115
116 constexpr DynamicType GetType() const { return result_.GetType(); }
117 llvm::raw_ostream &AsFortran(llvm::raw_ostream &) const;
118
119protected:
120 std::vector<Element> Reshape(const ConstantSubscripts &) const;
121 std::size_t CopyFrom(const ConstantBase &source, std::size_t count,
122 ConstantSubscripts &resultSubscripts, const std::vector<int> *dimOrder);
123
124 Result result_;
125 std::vector<Element> values_;
126};
127
128template <typename T> class Constant : public ConstantBase<T> {
129public:
130 using Result = T;
131 using Base = ConstantBase<T>;
132 using Element = Scalar<T>;
133
134 using Base::Base;
135 CLASS_BOILERPLATE(Constant)Constant() = delete; Constant(const Constant &) = default
; Constant(Constant &&) = default; Constant &operator
=(const Constant &) = default; Constant &operator=(Constant
&&) = default;
136
137 std::optional<Scalar<T>> GetScalarValue() const {
138 if (ConstantBounds::Rank() == 0) {
139 return Base::values_.at(0);
140 } else {
141 return std::nullopt;
142 }
143 }
144
145 // Apply subscripts. Excess subscripts are ignored, including the
146 // case of a scalar.
147 Element At(const ConstantSubscripts &) const;
148
149 Constant Reshape(ConstantSubscripts &&) const;
150 std::size_t CopyFrom(const Constant &source, std::size_t count,
151 ConstantSubscripts &resultSubscripts, const std::vector<int> *dimOrder);
152};
153
154template <int KIND>
155class Constant<Type<TypeCategory::Character, KIND>> : public ConstantBounds {
156public:
157 using Result = Type<TypeCategory::Character, KIND>;
158 using Element = Scalar<Result>;
159
160 CLASS_BOILERPLATE(Constant)Constant() = delete; Constant(const Constant &) = default
; Constant(Constant &&) = default; Constant &operator
=(const Constant &) = default; Constant &operator=(Constant
&&) = default;
161 explicit Constant(const Scalar<Result> &);
162 explicit Constant(Scalar<Result> &&);
163 Constant(
164 ConstantSubscript length, std::vector<Element> &&, ConstantSubscripts &&);
165 ~Constant();
166
167 bool operator==(const Constant &that) const {
168 return shape() == that.shape() && values_ == that.values_;
169 }
170 bool empty() const;
171 std::size_t size() const;
172
173 const Scalar<Result> &values() const { return values_; }
174 ConstantSubscript LEN() const { return length_; }
175
176 std::optional<Scalar<Result>> GetScalarValue() const {
177 if (Rank() == 0) {
178 return values_;
179 } else {
180 return std::nullopt;
181 }
182 }
183
184 // Apply subscripts, if any.
185 Scalar<Result> At(const ConstantSubscripts &) const;
186
187 // Extract substring(s); returns nullopt for errors.
188 std::optional<Constant> Substring(ConstantSubscript, ConstantSubscript) const;
189
190 Constant Reshape(ConstantSubscripts &&) const;
191 llvm::raw_ostream &AsFortran(llvm::raw_ostream &) const;
192 DynamicType GetType() const { return {KIND, length_}; }
193 std::size_t CopyFrom(const Constant &source, std::size_t count,
194 ConstantSubscripts &resultSubscripts, const std::vector<int> *dimOrder);
195
196private:
197 Scalar<Result> values_; // one contiguous string
198 ConstantSubscript length_;
199};
200
201class StructureConstructor;
202struct ComponentCompare {
203 bool operator()(SymbolRef x, SymbolRef y) const;
204};
205using StructureConstructorValues = std::map<SymbolRef,
206 common::CopyableIndirection<Expr<SomeType>>, ComponentCompare>;
207
208template <>
209class Constant<SomeDerived>
210 : public ConstantBase<SomeDerived, StructureConstructorValues> {
211public:
212 using Result = SomeDerived;
213 using Element = StructureConstructorValues;
214 using Base = ConstantBase<SomeDerived, StructureConstructorValues>;
215
216 Constant(const StructureConstructor &);
217 Constant(StructureConstructor &&);
218 Constant(const semantics::DerivedTypeSpec &,
219 std::vector<StructureConstructorValues> &&, ConstantSubscripts &&);
220 Constant(const semantics::DerivedTypeSpec &,
221 std::vector<StructureConstructor> &&, ConstantSubscripts &&);
222 CLASS_BOILERPLATE(Constant)Constant() = delete; Constant(const Constant &) = default
; Constant(Constant &&) = default; Constant &operator
=(const Constant &) = default; Constant &operator=(Constant
&&) = default;
223
224 std::optional<StructureConstructor> GetScalarValue() const;
225 StructureConstructor At(const ConstantSubscripts &) const;
226
227 Constant Reshape(ConstantSubscripts &&) const;
228 std::size_t CopyFrom(const Constant &source, std::size_t count,
229 ConstantSubscripts &resultSubscripts, const std::vector<int> *dimOrder);
230};
231
232FOR_EACH_LENGTHLESS_INTRINSIC_KIND(extern template class ConstantBase, )extern template class ConstantBase<Type<TypeCategory::Integer
, 1>> ; extern template class ConstantBase<Type<TypeCategory
::Integer, 2>> ; extern template class ConstantBase<
Type<TypeCategory::Integer, 4>> ; extern template class
ConstantBase<Type<TypeCategory::Integer, 8>> ; extern
template class ConstantBase<Type<TypeCategory::Integer
, 16>> ; extern template class ConstantBase<Type<
TypeCategory::Real, 2>> ; extern template class ConstantBase
<Type<TypeCategory::Real, 3>> ; extern template class
ConstantBase<Type<TypeCategory::Real, 4>> ; extern
template class ConstantBase<Type<TypeCategory::Real, 8
>> ; extern template class ConstantBase<Type<TypeCategory
::Real, 10>> ; extern template class ConstantBase<Type
<TypeCategory::Real, 16>> ; extern template class ConstantBase
<Type<TypeCategory::Complex, 2>> ; extern template
class ConstantBase<Type<TypeCategory::Complex, 3>>
; extern template class ConstantBase<Type<TypeCategory
::Complex, 4>> ; extern template class ConstantBase<
Type<TypeCategory::Complex, 8>> ; extern template class
ConstantBase<Type<TypeCategory::Complex, 10>> ; extern
template class ConstantBase<Type<TypeCategory::Complex
, 16>> ; extern template class ConstantBase<Type<
TypeCategory::Logical, 1>> ; extern template class ConstantBase
<Type<TypeCategory::Logical, 2>> ; extern template
class ConstantBase<Type<TypeCategory::Logical, 4>>
; extern template class ConstantBase<Type<TypeCategory
::Logical, 8>> ;
233extern template class ConstantBase<SomeDerived, StructureConstructorValues>;
234FOR_EACH_INTRINSIC_KIND(extern template class Constant, )extern template class Constant<Type<TypeCategory::Integer
, 1>> ; extern template class Constant<Type<TypeCategory
::Integer, 2>> ; extern template class Constant<Type
<TypeCategory::Integer, 4>> ; extern template class Constant
<Type<TypeCategory::Integer, 8>> ; extern template
class Constant<Type<TypeCategory::Integer, 16>> ;
extern template class Constant<Type<TypeCategory::Real
, 2>> ; extern template class Constant<Type<TypeCategory
::Real, 3>> ; extern template class Constant<Type<
TypeCategory::Real, 4>> ; extern template class Constant
<Type<TypeCategory::Real, 8>> ; extern template class
Constant<Type<TypeCategory::Real, 10>> ; extern template
class Constant<Type<TypeCategory::Real, 16>> ; extern
template class Constant<Type<TypeCategory::Complex, 2>>
; extern template class Constant<Type<TypeCategory::Complex
, 3>> ; extern template class Constant<Type<TypeCategory
::Complex, 4>> ; extern template class Constant<Type
<TypeCategory::Complex, 8>> ; extern template class Constant
<Type<TypeCategory::Complex, 10>> ; extern template
class Constant<Type<TypeCategory::Complex, 16>> ;
extern template class Constant<Type<TypeCategory::Logical
, 1>> ; extern template class Constant<Type<TypeCategory
::Logical, 2>> ; extern template class Constant<Type
<TypeCategory::Logical, 4>> ; extern template class Constant
<Type<TypeCategory::Logical, 8>> ; extern template
class Constant<Type<TypeCategory::Character, 1>>
; extern template class Constant<Type<TypeCategory::Character
, 2>> ; extern template class Constant<Type<TypeCategory
::Character, 4>> ;
235
236#define INSTANTIATE_CONSTANT_TEMPLATEStemplate class ConstantBase<Type<TypeCategory::Integer,
1>> ; template class ConstantBase<Type<TypeCategory
::Integer, 2>> ; template class ConstantBase<Type<
TypeCategory::Integer, 4>> ; template class ConstantBase
<Type<TypeCategory::Integer, 8>> ; template class
ConstantBase<Type<TypeCategory::Integer, 16>> ; template
class ConstantBase<Type<TypeCategory::Real, 2>> ;
template class ConstantBase<Type<TypeCategory::Real, 3
>> ; template class ConstantBase<Type<TypeCategory
::Real, 4>> ; template class ConstantBase<Type<TypeCategory
::Real, 8>> ; template class ConstantBase<Type<TypeCategory
::Real, 10>> ; template class ConstantBase<Type<TypeCategory
::Real, 16>> ; template class ConstantBase<Type<TypeCategory
::Complex, 2>> ; template class ConstantBase<Type<
TypeCategory::Complex, 3>> ; template class ConstantBase
<Type<TypeCategory::Complex, 4>> ; template class
ConstantBase<Type<TypeCategory::Complex, 8>> ; template
class ConstantBase<Type<TypeCategory::Complex, 10>>
; template class ConstantBase<Type<TypeCategory::Complex
, 16>> ; template class ConstantBase<Type<TypeCategory
::Logical, 1>> ; template class ConstantBase<Type<
TypeCategory::Logical, 2>> ; template class ConstantBase
<Type<TypeCategory::Logical, 4>> ; template class
ConstantBase<Type<TypeCategory::Logical, 8>> ; template
class ConstantBase<SomeDerived, StructureConstructorValues
>; template class Constant<Type<TypeCategory::Integer
, 1>> ; template class Constant<Type<TypeCategory
::Integer, 2>> ; template class Constant<Type<TypeCategory
::Integer, 4>> ; template class Constant<Type<TypeCategory
::Integer, 8>> ; template class Constant<Type<TypeCategory
::Integer, 16>> ; template class Constant<Type<TypeCategory
::Real, 2>> ; template class Constant<Type<TypeCategory
::Real, 3>> ; template class Constant<Type<TypeCategory
::Real, 4>> ; template class Constant<Type<TypeCategory
::Real, 8>> ; template class Constant<Type<TypeCategory
::Real, 10>> ; template class Constant<Type<TypeCategory
::Real, 16>> ; template class Constant<Type<TypeCategory
::Complex, 2>> ; template class Constant<Type<TypeCategory
::Complex, 3>> ; template class Constant<Type<TypeCategory
::Complex, 4>> ; template class Constant<Type<TypeCategory
::Complex, 8>> ; template class Constant<Type<TypeCategory
::Complex, 10>> ; template class Constant<Type<TypeCategory
::Complex, 16>> ; template class Constant<Type<TypeCategory
::Logical, 1>> ; template class Constant<Type<TypeCategory
::Logical, 2>> ; template class Constant<Type<TypeCategory
::Logical, 4>> ; template class Constant<Type<TypeCategory
::Logical, 8>> ; template class Constant<Type<TypeCategory
::Character, 1>> ; template class Constant<Type<TypeCategory
::Character, 2>> ; template class Constant<Type<TypeCategory
::Character, 4>> ;
\
237 FOR_EACH_LENGTHLESS_INTRINSIC_KIND(template class ConstantBase, )template class ConstantBase<Type<TypeCategory::Integer,
1>> ; template class ConstantBase<Type<TypeCategory
::Integer, 2>> ; template class ConstantBase<Type<
TypeCategory::Integer, 4>> ; template class ConstantBase
<Type<TypeCategory::Integer, 8>> ; template class
ConstantBase<Type<TypeCategory::Integer, 16>> ; template
class ConstantBase<Type<TypeCategory::Real, 2>> ;
template class ConstantBase<Type<TypeCategory::Real, 3
>> ; template class ConstantBase<Type<TypeCategory
::Real, 4>> ; template class ConstantBase<Type<TypeCategory
::Real, 8>> ; template class ConstantBase<Type<TypeCategory
::Real, 10>> ; template class ConstantBase<Type<TypeCategory
::Real, 16>> ; template class ConstantBase<Type<TypeCategory
::Complex, 2>> ; template class ConstantBase<Type<
TypeCategory::Complex, 3>> ; template class ConstantBase
<Type<TypeCategory::Complex, 4>> ; template class
ConstantBase<Type<TypeCategory::Complex, 8>> ; template
class ConstantBase<Type<TypeCategory::Complex, 10>>
; template class ConstantBase<Type<TypeCategory::Complex
, 16>> ; template class ConstantBase<Type<TypeCategory
::Logical, 1>> ; template class ConstantBase<Type<
TypeCategory::Logical, 2>> ; template class ConstantBase
<Type<TypeCategory::Logical, 4>> ; template class
ConstantBase<Type<TypeCategory::Logical, 8>> ;
\
238 template class ConstantBase<SomeDerived, StructureConstructorValues>; \
239 FOR_EACH_INTRINSIC_KIND(template class Constant, )template class Constant<Type<TypeCategory::Integer, 1>>
; template class Constant<Type<TypeCategory::Integer, 2
>> ; template class Constant<Type<TypeCategory::Integer
, 4>> ; template class Constant<Type<TypeCategory
::Integer, 8>> ; template class Constant<Type<TypeCategory
::Integer, 16>> ; template class Constant<Type<TypeCategory
::Real, 2>> ; template class Constant<Type<TypeCategory
::Real, 3>> ; template class Constant<Type<TypeCategory
::Real, 4>> ; template class Constant<Type<TypeCategory
::Real, 8>> ; template class Constant<Type<TypeCategory
::Real, 10>> ; template class Constant<Type<TypeCategory
::Real, 16>> ; template class Constant<Type<TypeCategory
::Complex, 2>> ; template class Constant<Type<TypeCategory
::Complex, 3>> ; template class Constant<Type<TypeCategory
::Complex, 4>> ; template class Constant<Type<TypeCategory
::Complex, 8>> ; template class Constant<Type<TypeCategory
::Complex, 10>> ; template class Constant<Type<TypeCategory
::Complex, 16>> ; template class Constant<Type<TypeCategory
::Logical, 1>> ; template class Constant<Type<TypeCategory
::Logical, 2>> ; template class Constant<Type<TypeCategory
::Logical, 4>> ; template class Constant<Type<TypeCategory
::Logical, 8>> ; template class Constant<Type<TypeCategory
::Character, 1>> ; template class Constant<Type<TypeCategory
::Character, 2>> ; template class Constant<Type<TypeCategory
::Character, 4>> ;
240} // namespace Fortran::evaluate
241#endif // FORTRAN_EVALUATE_CONSTANT_H_

/build/source/flang/include/flang/Evaluate/integer.h

1//===-- include/flang/Evaluate/integer.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_EVALUATE_INTEGER_H_
10#define FORTRAN_EVALUATE_INTEGER_H_
11
12// Emulates binary integers of an arbitrary (but fixed) bit size for use
13// when the host C++ environment does not support that size or when the
14// full suite of Fortran's integer intrinsic scalar functions are needed.
15// The data model is typeless, so signed* and unsigned operations
16// are distinguished from each other with distinct member function interfaces.
17// (*"Signed" here means two's-complement, just to be clear. Ones'-complement
18// and signed-magnitude encodings appear to be extinct in 2018.)
19
20#include "flang/Common/bit-population-count.h"
21#include "flang/Common/leading-zero-bit-count.h"
22#include "flang/Evaluate/common.h"
23#include <cinttypes>
24#include <climits>
25#include <cstddef>
26#include <cstdint>
27#include <string>
28#include <type_traits>
29
30// Some environments, viz. clang on Darwin, allow the macro HUGE
31// to leak out of <math.h> even when it is never directly included.
32#undef HUGE
33
34namespace Fortran::evaluate::value {
35
36// Implements an integer as an assembly of smaller host integer parts
37// that constitute the digits of a large-radix fixed-point number.
38// For best performance, the type of these parts should be half of the
39// size of the largest efficient integer supported by the host processor.
40// These parts are stored in either little- or big-endian order, which can
41// match that of the host's endianness or not; but if the ordering matches
42// that of the host, raw host data can be overlaid with a properly configured
43// instance of this class and used in situ.
44// To facilitate exhaustive testing of what would otherwise be more rare
45// edge cases, this class template may be configured to use other part
46// types &/or partial fields in the parts. The radix (i.e., the number
47// of possible values in a part), however, must be a power of two; this
48// template class is not generalized to enable, say, decimal arithmetic.
49// Member functions that correspond to Fortran intrinsic functions are
50// named accordingly in ALL CAPS so that they can be referenced easily in
51// the language standard.
52template <int BITS, bool IS_LITTLE_ENDIAN = isHostLittleEndian,
53 int PARTBITS = BITS <= 32 ? BITS : 32,
54 typename PART = HostUnsignedInt<PARTBITS>,
55 typename BIGPART = HostUnsignedInt<PARTBITS * 2>>
56class Integer {
57public:
58 static constexpr int bits{BITS};
59 static constexpr int partBits{PARTBITS};
60 using Part = PART;
61 using BigPart = BIGPART;
62 static_assert(std::is_integral_v<Part>);
63 static_assert(std::is_unsigned_v<Part>);
64 static_assert(std::is_integral_v<BigPart>);
65 static_assert(std::is_unsigned_v<BigPart>);
66 static_assert(CHAR_BIT8 * sizeof(BigPart) >= 2 * partBits);
67 static constexpr bool littleEndian{IS_LITTLE_ENDIAN};
68
69private:
70 static constexpr int maxPartBits{CHAR_BIT8 * sizeof(Part)};
71 static_assert(partBits > 0 && partBits <= maxPartBits);
72 static constexpr int extraPartBits{maxPartBits - partBits};
73 static constexpr int parts{(bits + partBits - 1) / partBits};
74 static_assert(parts >= 1);
75 static constexpr int extraTopPartBits{
76 extraPartBits + (parts * partBits) - bits};
77 static constexpr int topPartBits{maxPartBits - extraTopPartBits};
78 static_assert(topPartBits > 0 && topPartBits <= partBits);
79 static_assert((parts - 1) * partBits + topPartBits == bits);
80 static constexpr Part partMask{static_cast<Part>(~0) >> extraPartBits};
81 static constexpr Part topPartMask{static_cast<Part>(~0) >> extraTopPartBits};
82
83public:
84 // Some types used for member function results
85 struct ValueWithOverflow {
86 Integer value;
87 bool overflow;
88 };
89
90 struct ValueWithCarry {
91 Integer value;
92 bool carry;
93 };
94
95 struct Product {
96 bool SignedMultiplicationOverflowed() const {
97 return lower.IsNegative() ? (upper.POPCNT() != bits) : !upper.IsZero();
98 }
99 Integer upper, lower;
100 };
101
102 struct QuotientWithRemainder {
103 Integer quotient, remainder;
104 bool divisionByZero, overflow;
105 };
106
107 struct PowerWithErrors {
108 Integer power;
109 bool divisionByZero{false}, overflow{false}, zeroToZero{false};
110 };
111
112 // Constructors and value-generating static functions
113 constexpr Integer() { Clear(); } // default constructor: zero
114 constexpr Integer(const Integer &) = default;
115 constexpr Integer(Integer &&) = default;
116
117 // C++'s integral types can all be converted to Integer
118 // with silent truncation.
119 template <typename INT, typename = std::enable_if_t<std::is_integral_v<INT>>>
120 constexpr Integer(INT n) {
121 constexpr int nBits = CHAR_BIT8 * sizeof n;
122 if constexpr (nBits
6.1
'nBits' is >= 'partBits'
6.1
'nBits' is >= 'partBits'
6.1
'nBits' is >= 'partBits'
< partBits) {
7
Taking false branch
123 if constexpr (std::is_unsigned_v<INT>) {
124 // Zero-extend an unsigned smaller value.
125 SetLEPart(0, n);
126 for (int j{1}; j < parts; ++j) {
127 SetLEPart(j, 0);
128 }
129 } else {
130 // n has a signed type smaller than the usable
131 // bits in a Part.
132 // Avoid conversions that change both size and sign.
133 using SignedPart = std::make_signed_t<Part>;
134 Part p = static_cast<SignedPart>(n);
135 SetLEPart(0, p);
136 if constexpr (parts > 1) {
137 Part signExtension = static_cast<SignedPart>(-(n < 0));
138 for (int j{1}; j < parts; ++j) {
139 SetLEPart(j, signExtension);
140 }
141 }
142 }
143 } else {
144 // n has some integral type no smaller than the usable
145 // bits in a Part.
146 // Ensure that all shifts are smaller than a whole word.
147 if constexpr (std::is_unsigned_v<INT>
7.1
'is_unsigned_v' is false
7.1
'is_unsigned_v' is false
7.1
'is_unsigned_v' is false
) {
8
Taking false branch
148 for (int j{0}; j < parts; ++j) {
149 SetLEPart(j, static_cast<Part>(n));
150 if constexpr (nBits > partBits) {
151 n >>= partBits;
152 } else {
153 n = 0;
154 }
155 }
156 } else {
157 INT signExtension{-(n < 0)};
9
Assuming 'n' is < 0
158 static_assert(nBits >= partBits);
159 if constexpr (nBits
9.1
'nBits' is > 'partBits'
9.1
'nBits' is > 'partBits'
9.1
'nBits' is > 'partBits'
> partBits) {
10
Taking true branch
160 signExtension <<= nBits - partBits;
11
Assigned value is garbage or undefined
161 for (int j{0}; j < parts; ++j) {
162 SetLEPart(j, static_cast<Part>(n));
163 n >>= partBits;
164 n |= signExtension;
165 }
166 } else {
167 SetLEPart(0, static_cast<Part>(n));
168 for (int j{1}; j < parts; ++j) {
169 SetLEPart(j, static_cast<Part>(signExtension));
170 }
171 }
172 }
173 }
174 }
175
176 constexpr Integer &operator=(const Integer &) = default;
177
178 constexpr bool operator<(const Integer &that) const {
179 return CompareSigned(that) == Ordering::Less;
180 }
181 constexpr bool operator<=(const Integer &that) const {
182 return CompareSigned(that) != Ordering::Greater;
183 }
184 constexpr bool operator==(const Integer &that) const {
185 return CompareSigned(that) == Ordering::Equal;
186 }
187 constexpr bool operator!=(const Integer &that) const {
188 return !(*this == that);
189 }
190 constexpr bool operator>=(const Integer &that) const {
191 return CompareSigned(that) != Ordering::Less;
192 }
193 constexpr bool operator>(const Integer &that) const {
194 return CompareSigned(that) == Ordering::Greater;
195 }
196
197 // Left-justified mask (e.g., MASKL(1) has only its sign bit set)
198 static constexpr Integer MASKL(int places) {
199 if (places <= 0) {
200 return {};
201 } else if (places >= bits) {
202 return MASKR(bits);
203 } else {
204 return MASKR(bits - places).NOT();
205 }
206 }
207
208 // Right-justified mask (e.g., MASKR(1) == 1, MASKR(2) == 3, &c.)
209 static constexpr Integer MASKR(int places) {
210 Integer result{nullptr};
211 int j{0};
212 for (; j + 1 < parts && places >= partBits; ++j, places -= partBits) {
213 result.LEPart(j) = partMask;
214 }
215 if (places > 0) {
216 if (j + 1 < parts) {
217 result.LEPart(j++) = partMask >> (partBits - places);
218 } else if (j + 1 == parts) {
219 if (places >= topPartBits) {
220 result.LEPart(j++) = topPartMask;
221 } else {
222 result.LEPart(j++) = topPartMask >> (topPartBits - places);
223 }
224 }
225 }
226 for (; j < parts; ++j) {
227 result.LEPart(j) = 0;
228 }
229 return result;
230 }
231
232 static constexpr ValueWithOverflow Read(
233 const char *&pp, std::uint64_t base = 10, bool isSigned = false) {
234 Integer result;
235 bool overflow{false};
236 const char *p{pp};
237 while (*p == ' ' || *p == '\t') {
238 ++p;
239 }
240 bool negate{*p == '-'};
241 if (negate || *p == '+') {
242 while (*++p == ' ' || *p == '\t') {
243 }
244 }
245 Integer radix{base};
246 // This code makes assumptions about local contiguity in regions of the
247 // character set and only works up to base 36. These assumptions hold
248 // for all current combinations of surviving character sets (ASCII, UTF-8,
249 // EBCDIC) and the bases used in Fortran source and formatted I/O
250 // (viz., 2, 8, 10, & 16). But: management thought that a disclaimer
251 // might be needed here to warn future users of this code about these
252 // assumptions, so here you go, future programmer in some postapocalyptic
253 // hellscape, and best of luck with the inexorable killer robots.
254 for (; std::uint64_t digit = *p; ++p) {
255 if (digit >= '0' && digit <= '9' && digit < '0' + base) {
256 digit -= '0';
257 } else if (base > 10 && digit >= 'A' && digit < 'A' + base - 10) {
258 digit -= 'A' - 10;
259 } else if (base > 10 && digit >= 'a' && digit < 'a' + base - 10) {
260 digit -= 'a' - 10;
261 } else {
262 break;
263 }
264 Product shifted{result.MultiplyUnsigned(radix)};
265 overflow |= !shifted.upper.IsZero();
266 ValueWithCarry next{shifted.lower.AddUnsigned(Integer{digit})};
267 overflow |= next.carry;
268 result = next.value;
269 }
270 pp = p;
271 if (negate) {
272 result = result.Negate().value;
273 overflow |= isSigned && !result.IsNegative() && !result.IsZero();
274 } else {
275 overflow |= isSigned && result.IsNegative();
276 }
277 return {result, overflow};
278 }
279
280 template <typename FROM>
281 static constexpr ValueWithOverflow ConvertUnsigned(const FROM &that) {
282 std::uint64_t field{that.ToUInt64()};
283 ValueWithOverflow result{field, false};
284 if constexpr (bits < 64) {
285 result.overflow = (field >> bits) != 0;
286 }
287 for (int j{64}; j < that.bits && !result.overflow; j += 64) {
288 field = that.SHIFTR(j).ToUInt64();
289 if (bits <= j) {
290 result.overflow = field != 0;
291 } else {
292 result.value = result.value.IOR(Integer{field}.SHIFTL(j));
293 if (bits < j + 64) {
294 result.overflow = (field >> (bits - j)) != 0;
295 }
296 }
297 }
298 return result;
299 }
300
301 template <typename FROM>
302 static constexpr ValueWithOverflow ConvertSigned(const FROM &that) {
303 ValueWithOverflow result{ConvertUnsigned(that)};
304 if constexpr (bits > FROM::bits) {
305 if (that.IsNegative()) {
306 result.value = result.value.IOR(MASKL(bits - FROM::bits));
307 }
308 result.overflow = false;
309 } else if constexpr (bits < FROM::bits) {
310 auto back{FROM::template ConvertSigned(result.value)};
311 result.overflow = back.value.CompareUnsigned(that) != Ordering::Equal;
312 }
313 return result;
314 }
315
316 std::string UnsignedDecimal() const {
317 if constexpr (bits < 4) {
318 char digit = '0' + ToUInt64();
319 return {digit};
320 } else if (IsZero()) {
321 return {'0'};
322 } else {
323 QuotientWithRemainder qr{DivideUnsigned(10)};
324 char digit = '0' + qr.remainder.ToUInt64();
325 if (qr.quotient.IsZero()) {
326 return {digit};
327 } else {
328 return qr.quotient.UnsignedDecimal() + digit;
329 }
330 }
331 }
332
333 std::string SignedDecimal() const {
334 if (IsNegative()) {
335 return std::string{'-'} + Negate().value.UnsignedDecimal();
336 } else {
337 return UnsignedDecimal();
338 }
339 }
340
341 // Omits a leading "0x".
342 std::string Hexadecimal() const {
343 std::string result;
344 int digits{(bits + 3) >> 2};
345 for (int j{0}; j < digits; ++j) {
346 int pos{(digits - 1 - j) * 4};
347 char nybble = IBITS(pos, 4).ToUInt64();
348 if (nybble != 0 || !result.empty() || j + 1 == digits) {
349 char digit = '0' + nybble;
350 if (digit > '9') {
351 digit += 'a' - ('9' + 1);
352 }
353 result += digit;
354 }
355 }
356 return result;
357 }
358
359 static constexpr int DIGITS{bits - 1}; // don't count the sign bit
360 static constexpr Integer HUGE() { return MASKR(bits - 1); }
361 static constexpr Integer Least() { return MASKL(1); }
362 static constexpr int RANGE{// in the sense of SELECTED_INT_KIND
363 // This magic value is LOG10(2.)*1E12.
364 static_cast<int>(((bits - 1) * 301029995664) / 1000000000000)};
365
366 constexpr bool IsZero() const {
367 for (int j{0}; j < parts; ++j) {
368 if (part_[j] != 0) {
369 return false;
370 }
371 }
372 return true;
373 }
374
375 constexpr bool IsNegative() const {
376 return (LEPart(parts - 1) >> (topPartBits - 1)) & 1;
377 }
378
379 constexpr Ordering CompareToZeroSigned() const {
380 if (IsNegative()) {
381 return Ordering::Less;
382 } else if (IsZero()) {
383 return Ordering::Equal;
384 } else {
385 return Ordering::Greater;
386 }
387 }
388
389 // Count the number of contiguous most-significant bit positions
390 // that are clear.
391 constexpr int LEADZ() const {
392 if (LEPart(parts - 1) != 0) {
393 int lzbc{common::LeadingZeroBitCount(LEPart(parts - 1))};
394 return lzbc - extraTopPartBits;
395 }
396 int upperZeroes{topPartBits};
397 for (int j{1}; j < parts; ++j) {
398 if (Part p{LEPart(parts - 1 - j)}) {
399 int lzbc{common::LeadingZeroBitCount(p)};
400 return upperZeroes + lzbc - extraPartBits;
401 }
402 upperZeroes += partBits;
403 }
404 return bits;
405 }
406
407 // Count the number of bit positions that are set.
408 constexpr int POPCNT() const {
409 int count{0};
410 for (int j{0}; j < parts; ++j) {
411 count += common::BitPopulationCount(part_[j]);
412 }
413 return count;
414 }
415
416 // True when POPCNT is odd.
417 constexpr bool POPPAR() const { return POPCNT() & 1; }
418
419 constexpr int TRAILZ() const {
420 auto minus1{AddUnsigned(MASKR(bits))}; // { x-1, carry = x > 0 }
421 if (!minus1.carry) {
422 return bits; // was zero
423 } else {
424 // x ^ (x-1) has all bits set at and below original least-order set bit.
425 return IEOR(minus1.value).POPCNT() - 1;
426 }
427 }
428
429 constexpr bool BTEST(int pos) const {
430 if (pos < 0 || pos >= bits) {
431 return false;
432 } else {
433 return (LEPart(pos / partBits) >> (pos % partBits)) & 1;
434 }
435 }
436
437 constexpr Ordering CompareUnsigned(const Integer &y) const {
438 for (int j{parts}; j-- > 0;) {
439 if (LEPart(j) > y.LEPart(j)) {
440 return Ordering::Greater;
441 }
442 if (LEPart(j) < y.LEPart(j)) {
443 return Ordering::Less;
444 }
445 }
446 return Ordering::Equal;
447 }
448
449 constexpr bool BGE(const Integer &y) const {
450 return CompareUnsigned(y) != Ordering::Less;
451 }
452 constexpr bool BGT(const Integer &y) const {
453 return CompareUnsigned(y) == Ordering::Greater;
454 }
455 constexpr bool BLE(const Integer &y) const { return !BGT(y); }
456 constexpr bool BLT(const Integer &y) const { return !BGE(y); }
457
458 constexpr Ordering CompareSigned(const Integer &y) const {
459 bool isNegative{IsNegative()};
460 if (isNegative != y.IsNegative()) {
461 return isNegative ? Ordering::Less : Ordering::Greater;
462 }
463 return CompareUnsigned(y);
464 }
465
466 template <typename UINT = std::uint64_t> constexpr UINT ToUInt() const {
467 UINT n{LEPart(0)};
468 std::size_t filled{partBits};
469 constexpr std::size_t maxBits{CHAR_BIT8 * sizeof n};
470 for (int j{1}; filled < maxBits && j < parts; ++j, filled += partBits) {
471 n |= UINT{LEPart(j)} << filled;
472 }
473 return n;
474 }
475
476 template <typename SINT = std::int64_t, typename UINT = std::uint64_t>
477 constexpr SINT ToSInt() const {
478 SINT n = ToUInt<UINT>();
479 constexpr std::size_t maxBits{CHAR_BIT8 * sizeof n};
480 if constexpr (bits < maxBits) {
481 n |= -(n >> (bits - 1)) << bits;
482 }
483 return n;
484 }
485
486 constexpr std::uint64_t ToUInt64() const { return ToUInt<std::uint64_t>(); }
487
488 constexpr std::int64_t ToInt64() const {
489 return ToSInt<std::int64_t, std::uint64_t>();
490 }
491
492 // Ones'-complement (i.e., C's ~)
493 constexpr Integer NOT() const {
494 Integer result{nullptr};
495 for (int j{0}; j < parts; ++j) {
496 result.SetLEPart(j, ~LEPart(j));
497 }
498 return result;
499 }
500
501 // Two's-complement negation (-x = ~x + 1).
502 // An overflow flag accompanies the result, and will be true when the
503 // operand is the most negative signed number (MASKL(1)).
504 constexpr ValueWithOverflow Negate() const {
505 Integer result{nullptr};
506 Part carry{1};
507 for (int j{0}; j + 1 < parts; ++j) {
508 Part newCarry{LEPart(j) == 0 && carry};
509 result.SetLEPart(j, ~LEPart(j) + carry);
510 carry = newCarry;
511 }
512 Part top{LEPart(parts - 1)};
513 result.SetLEPart(parts - 1, ~top + carry);
514 bool overflow{top != 0 && result.LEPart(parts - 1) == top};
515 return {result, overflow};
516 }
517
518 constexpr ValueWithOverflow ABS() const {
519 if (IsNegative()) {
520 return Negate();
521 } else {
522 return {*this, false};
523 }
524 }
525
526 // Shifts the operand left when the count is positive, right when negative.
527 // Vacated bit positions are filled with zeroes.
528 constexpr Integer ISHFT(int count) const {
529 if (count < 0) {
530 return SHIFTR(-count);
531 } else {
532 return SHIFTL(count);
533 }
534 }
535
536 // Left shift with zero fill.
537 constexpr Integer SHIFTL(int count) const {
538 if (count <= 0) {
539 return *this;
540 } else {
541 Integer result{nullptr};
542 int shiftParts{count / partBits};
543 int bitShift{count - partBits * shiftParts};
544 int j{parts - 1};
545 if (bitShift == 0) {
546 for (; j >= shiftParts; --j) {
547 result.SetLEPart(j, LEPart(j - shiftParts));
548 }
549 for (; j >= 0; --j) {
550 result.LEPart(j) = 0;
551 }
552 } else {
553 for (; j > shiftParts; --j) {
554 result.SetLEPart(j,
555 ((LEPart(j - shiftParts) << bitShift) |
556 (LEPart(j - shiftParts - 1) >> (partBits - bitShift))));
557 }
558 if (j == shiftParts) {
559 result.SetLEPart(j, LEPart(0) << bitShift);
560 --j;
561 }
562 for (; j >= 0; --j) {
563 result.LEPart(j) = 0;
564 }
565 }
566 return result;
567 }
568 }
569
570 // Circular shift of a field of least-significant bits. The least-order
571 // "size" bits are shifted circularly in place by "count" positions;
572 // the shift is leftward if count is nonnegative, rightward otherwise.
573 // Higher-order bits are unchanged.
574 constexpr Integer ISHFTC(int count, int size = bits) const {
575 if (count == 0 || size <= 0) {
576 return *this;
577 }
578 if (size > bits) {
579 size = bits;
580 }
581 count %= size;
582 if (count == 0) {
583 return *this;
584 }
585 int middleBits{size - count}, leastBits{count};
586 if (count < 0) {
587 middleBits = -count;
588 leastBits = size + count;
589 }
590 if (size == bits) {
591 return SHIFTL(leastBits).IOR(SHIFTR(middleBits));
592 }
593 Integer unchanged{IAND(MASKL(bits - size))};
594 Integer middle{IAND(MASKR(middleBits)).SHIFTL(leastBits)};
595 Integer least{SHIFTR(middleBits).IAND(MASKR(leastBits))};
596 return unchanged.IOR(middle).IOR(least);
597 }
598
599 // Double shifts, aka shifts with specific fill.
600 constexpr Integer SHIFTLWithFill(const Integer &fill, int count) const {
601 if (count <= 0) {
602 return *this;
603 } else if (count >= 2 * bits) {
604 return {};
605 } else if (count > bits) {
606 return fill.SHIFTL(count - bits);
607 } else if (count == bits) {
608 return fill;
609 } else {
610 return SHIFTL(count).IOR(fill.SHIFTR(bits - count));
611 }
612 }
613
614 constexpr Integer SHIFTRWithFill(const Integer &fill, int count) const {
615 if (count <= 0) {
616 return *this;
617 } else if (count >= 2 * bits) {
618 return {};
619 } else if (count > bits) {
620 return fill.SHIFTR(count - bits);
621 } else if (count == bits) {
622 return fill;
623 } else {
624 return SHIFTR(count).IOR(fill.SHIFTL(bits - count));
625 }
626 }
627
628 constexpr Integer DSHIFTL(const Integer &fill, int count) const {
629 // DSHIFTL(I,J) shifts I:J left; the second argument is the right fill.
630 return SHIFTLWithFill(fill, count);
631 }
632
633 constexpr Integer DSHIFTR(const Integer &value, int count) const {
634 // DSHIFTR(I,J) shifts I:J right; the *first* argument is the left fill.
635 return value.SHIFTRWithFill(*this, count);
636 }
637
638 // Vacated upper bits are filled with zeroes.
639 constexpr Integer SHIFTR(int count) const {
640 if (count <= 0) {
641 return *this;
642 } else {
643 Integer result{nullptr};
644 int shiftParts{count / partBits};
645 int bitShift{count - partBits * shiftParts};
646 int j{0};
647 if (bitShift == 0) {
648 for (; j + shiftParts < parts; ++j) {
649 result.LEPart(j) = LEPart(j + shiftParts);
650 }
651 for (; j < parts; ++j) {
652 result.LEPart(j) = 0;
653 }
654 } else {
655 for (; j + shiftParts + 1 < parts; ++j) {
656 result.SetLEPart(j,
657 (LEPart(j + shiftParts) >> bitShift) |
658 (LEPart(j + shiftParts + 1) << (partBits - bitShift)));
659 }
660 if (j + shiftParts + 1 == parts) {
661 result.LEPart(j++) = LEPart(parts - 1) >> bitShift;
662 }
663 for (; j < parts; ++j) {
664 result.LEPart(j) = 0;
665 }
666 }
667 return result;
668 }
669 }
670
671 // Be advised, an arithmetic (sign-filling) right shift is not
672 // the same as a division by a power of two in all cases.
673 constexpr Integer SHIFTA(int count) const {
674 if (count <= 0) {
675 return *this;
676 } else if (IsNegative()) {
677 return SHIFTR(count).IOR(MASKL(count));
678 } else {
679 return SHIFTR(count);
680 }
681 }
682
683 // Clears a single bit.
684 constexpr Integer IBCLR(int pos) const {
685 if (pos < 0 || pos >= bits) {
686 return *this;
687 } else {
688 Integer result{*this};
689 result.LEPart(pos / partBits) &= ~(Part{1} << (pos % partBits));
690 return result;
691 }
692 }
693
694 // Sets a single bit.
695 constexpr Integer IBSET(int pos) const {
696 if (pos < 0 || pos >= bits) {
697 return *this;
698 } else {
699 Integer result{*this};
700 result.LEPart(pos / partBits) |= Part{1} << (pos % partBits);
701 return result;
702 }
703 }
704
705 // Extracts a field.
706 constexpr Integer IBITS(int pos, int size) const {
707 return SHIFTR(pos).IAND(MASKR(size));
708 }
709
710 constexpr Integer IAND(const Integer &y) const {
711 Integer result{nullptr};
712 for (int j{0}; j < parts; ++j) {
713 result.LEPart(j) = LEPart(j) & y.LEPart(j);
714 }
715 return result;
716 }
717
718 constexpr Integer IOR(const Integer &y) const {
719 Integer result{nullptr};
720 for (int j{0}; j < parts; ++j) {
721 result.LEPart(j) = LEPart(j) | y.LEPart(j);
722 }
723 return result;
724 }
725
726 constexpr Integer IEOR(const Integer &y) const {
727 Integer result{nullptr};
728 for (int j{0}; j < parts; ++j) {
729 result.LEPart(j) = LEPart(j) ^ y.LEPart(j);
730 }
731 return result;
732 }
733
734 constexpr Integer MERGE_BITS(const Integer &y, const Integer &mask) const {
735 return IAND(mask).IOR(y.IAND(mask.NOT()));
736 }
737
738 constexpr Integer MAX(const Integer &y) const {
739 if (CompareSigned(y) == Ordering::Less) {
740 return y;
741 } else {
742 return *this;
743 }
744 }
745
746 constexpr Integer MIN(const Integer &y) const {
747 if (CompareSigned(y) == Ordering::Less) {
748 return *this;
749 } else {
750 return y;
751 }
752 }
753
754 // Unsigned addition with carry.
755 constexpr ValueWithCarry AddUnsigned(
756 const Integer &y, bool carryIn = false) const {
757 Integer sum{nullptr};
758 BigPart carry{carryIn};
759 for (int j{0}; j + 1 < parts; ++j) {
760 carry += LEPart(j);
761 carry += y.LEPart(j);
762 sum.SetLEPart(j, carry);
763 carry >>= partBits;
764 }
765 carry += LEPart(parts - 1);
766 carry += y.LEPart(parts - 1);
767 sum.SetLEPart(parts - 1, carry);
768 return {sum, carry > topPartMask};
769 }
770
771 constexpr ValueWithOverflow AddSigned(const Integer &y) const {
772 bool isNegative{IsNegative()};
773 bool sameSign{isNegative == y.IsNegative()};
774 ValueWithCarry sum{AddUnsigned(y)};
775 bool overflow{sameSign && sum.value.IsNegative() != isNegative};
776 return {sum.value, overflow};
777 }
778
779 constexpr ValueWithOverflow SubtractSigned(const Integer &y) const {
780 bool isNegative{IsNegative()};
781 bool sameSign{isNegative == y.IsNegative()};
782 ValueWithCarry diff{AddUnsigned(y.Negate().value)};
783 bool overflow{!sameSign && diff.value.IsNegative() != isNegative};
784 return {diff.value, overflow};
785 }
786
787 // DIM(X,Y)=MAX(X-Y, 0)
788 constexpr ValueWithOverflow DIM(const Integer &y) const {
789 if (CompareSigned(y) != Ordering::Greater) {
790 return {};
791 } else {
792 return SubtractSigned(y);
793 }
794 }
795
796 constexpr ValueWithOverflow SIGN(bool toNegative) const {
797 if (toNegative == IsNegative()) {
798 return {*this, false};
799 } else if (toNegative) {
800 return Negate();
801 } else {
802 return ABS();
803 }
804 }
805
806 constexpr ValueWithOverflow SIGN(const Integer &sign) const {
807 return SIGN(sign.IsNegative());
808 }
809
810 constexpr Product MultiplyUnsigned(const Integer &y) const {
811 Part product[2 * parts]{}; // little-endian full product
812 for (int j{0}; j < parts; ++j) {
813 if (Part xpart{LEPart(j)}) {
814 for (int k{0}; k < parts; ++k) {
815 if (Part ypart{y.LEPart(k)}) {
816 BigPart xy{xpart};
817 xy *= ypart;
818#if defined __GNUC__4 && __GNUC__4 < 8
819 // && to < (2 * parts) was added to avoid GCC < 8 build failure on
820 // -Werror=array-bounds. This can be removed if -Werror is disable.
821 for (int to{j + k}; xy != 0 && to < (2 * parts); ++to) {
822#else
823 for (int to{j + k}; xy != 0; ++to) {
824#endif
825 xy += product[to];
826 product[to] = xy & partMask;
827 xy >>= partBits;
828 }
829 }
830 }
831 }
832 }
833 Integer upper{nullptr}, lower{nullptr};
834 for (int j{0}; j < parts; ++j) {
835 lower.LEPart(j) = product[j];
836 upper.LEPart(j) = product[j + parts];
837 }
838 if constexpr (topPartBits < partBits) {
839 upper = upper.SHIFTL(partBits - topPartBits);
840 upper.LEPart(0) |= lower.LEPart(parts - 1) >> topPartBits;
841 lower.LEPart(parts - 1) &= topPartMask;
842 }
843 return {upper, lower};
844 }
845
846 constexpr Product MultiplySigned(const Integer &y) const {
847 bool yIsNegative{y.IsNegative()};
848 Integer absy{y};
849 if (yIsNegative) {
850 absy = y.Negate().value;
851 }
852 bool isNegative{IsNegative()};
853 Integer absx{*this};
854 if (isNegative) {
855 absx = Negate().value;
856 }
857 Product product{absx.MultiplyUnsigned(absy)};
858 if (isNegative != yIsNegative) {
859 product.lower = product.lower.NOT();
860 product.upper = product.upper.NOT();
861 Integer one{1};
862 auto incremented{product.lower.AddUnsigned(one)};
863 product.lower = incremented.value;
864 if (incremented.carry) {
865 product.upper = product.upper.AddUnsigned(one).value;
866 }
867 }
868 return product;
869 }
870
871 constexpr QuotientWithRemainder DivideUnsigned(const Integer &divisor) const {
872 if (divisor.IsZero()) {
873 return {MASKR(bits), Integer{}, true, false}; // overflow to max value
874 }
875 int bitsDone{LEADZ()};
876 Integer top{SHIFTL(bitsDone)};
877 Integer quotient, remainder;
878 for (; bitsDone < bits; ++bitsDone) {
879 auto doubledTop{top.AddUnsigned(top)};
880 top = doubledTop.value;
881 remainder = remainder.AddUnsigned(remainder, doubledTop.carry).value;
882 bool nextBit{remainder.CompareUnsigned(divisor) != Ordering::Less};
883 quotient = quotient.AddUnsigned(quotient, nextBit).value;
884 if (nextBit) {
885 remainder = remainder.SubtractSigned(divisor).value;
886 }
887 }
888 return {quotient, remainder, false, false};
889 }
890
891 // A nonzero remainder has the sign of the dividend, i.e., it computes
892 // the MOD intrinsic (X-INT(X/Y)*Y), not MODULO (which is below).
893 // 8/5 = 1r3; -8/5 = -1r-3; 8/-5 = -1r3; -8/-5 = 1r-3
894 constexpr QuotientWithRemainder DivideSigned(Integer divisor) const {
895 bool dividendIsNegative{IsNegative()};
896 bool negateQuotient{dividendIsNegative};
897 Ordering divisorOrdering{divisor.CompareToZeroSigned()};
898 if (divisorOrdering == Ordering::Less) {
899 negateQuotient = !negateQuotient;
900 auto negated{divisor.Negate()};
901 if (negated.overflow) {
902 // divisor was (and is) the most negative number
903 if (CompareUnsigned(divisor) == Ordering::Equal) {
904 return {MASKR(1), Integer{}, false, bits <= 1};
905 } else {
906 return {Integer{}, *this, false, false};
907 }
908 }
909 divisor = negated.value;
910 } else if (divisorOrdering == Ordering::Equal) {
911 // division by zero
912 if (dividendIsNegative) {
913 return {MASKL(1), Integer{}, true, false};
914 } else {
915 return {MASKR(bits - 1), Integer{}, true, false};
916 }
917 }
918 Integer dividend{*this};
919 if (dividendIsNegative) {
920 auto negated{Negate()};
921 if (negated.overflow) {
922 // Dividend was (and remains) the most negative number.
923 // See whether the original divisor was -1 (if so, it's 1 now).
924 if (divisorOrdering == Ordering::Less &&
925 divisor.CompareUnsigned(Integer{1}) == Ordering::Equal) {
926 // most negative number / -1 is the sole overflow case
927 return {*this, Integer{}, false, true};
928 }
929 } else {
930 dividend = negated.value;
931 }
932 }
933 // Overflow is not possible, and both the dividend and divisor
934 // are now positive.
935 QuotientWithRemainder result{dividend.DivideUnsigned(divisor)};
936 if (negateQuotient) {
937 result.quotient = result.quotient.Negate().value;
938 }
939 if (dividendIsNegative) {
940 result.remainder = result.remainder.Negate().value;
941 }
942 return result;
943 }
944
945 // Result has the sign of the divisor argument.
946 // 8 mod 5 = 3; -8 mod 5 = 2; 8 mod -5 = -2; -8 mod -5 = -3
947 constexpr ValueWithOverflow MODULO(const Integer &divisor) const {
948 bool negativeDivisor{divisor.IsNegative()};
949 bool distinctSigns{IsNegative() != negativeDivisor};
950 QuotientWithRemainder divided{DivideSigned(divisor)};
951 if (distinctSigns && !divided.remainder.IsZero()) {
952 return {divided.remainder.AddUnsigned(divisor).value, divided.overflow};
953 } else {
954 return {divided.remainder, divided.overflow};
955 }
956 }
957
958 constexpr PowerWithErrors Power(const Integer &exponent) const {
959 PowerWithErrors result{1, false, false, false};
960 if (exponent.IsZero()) {
961 // x**0 -> 1, including the case 0**0, which is not defined specifically
962 // in F'18 afaict; however, other Fortrans tested all produce 1, not 0,
963 // apart from nagfor, which stops with an error at runtime.
964 // Ada, APL, C's pow(), Haskell, Julia, MATLAB, and R all produce 1 too.
965 // F'77 explicitly states that 0**0 is mathematically undefined and
966 // therefore prohibited.
967 result.zeroToZero = IsZero();
968 } else if (exponent.IsNegative()) {
969 if (IsZero()) {
970 result.divisionByZero = true;
971 result.power = MASKR(bits - 1);
972 } else if (CompareSigned(Integer{1}) == Ordering::Equal) {
973 result.power = *this; // 1**x -> 1
974 } else if (CompareSigned(Integer{-1}) == Ordering::Equal) {
975 if (exponent.BTEST(0)) {
976 result.power = *this; // (-1)**x -> -1 if x is odd
977 }
978 } else {
979 result.power.Clear(); // j**k -> 0 if |j| > 1 and k < 0
980 }
981 } else {
982 Integer shifted{*this};
983 Integer pow{exponent};
984 int nbits{bits - pow.LEADZ()};
985 for (int j{0}; j < nbits; ++j) {
986 if (pow.BTEST(j)) {
987 Product product{result.power.MultiplySigned(shifted)};
988 result.power = product.lower;
989 result.overflow |= product.SignedMultiplicationOverflowed();
990 }
991 if (j + 1 < nbits) {
992 Product squared{shifted.MultiplySigned(shifted)};
993 result.overflow |= squared.SignedMultiplicationOverflowed();
994 shifted = squared.lower;
995 }
996 }
997 }
998 return result;
999 }
1000
1001private:
1002 // A private constructor, selected by the use of nullptr,
1003 // that is used by member functions when it would be a waste
1004 // of time to initialize parts_[].
1005 constexpr Integer(std::nullptr_t) {}
1006
1007 // Accesses parts in little-endian order.
1008 constexpr const Part &LEPart(int part) const {
1009 if constexpr (littleEndian) {
1010 return part_[part];
1011 } else {
1012 return part_[parts - 1 - part];
1013 }
1014 }
1015
1016 constexpr Part &LEPart(int part) {
1017 if constexpr (littleEndian) {
1018 return part_[part];
1019 } else {
1020 return part_[parts - 1 - part];
1021 }
1022 }
1023
1024 constexpr void SetLEPart(int part, Part x) {
1025 LEPart(part) = x & PartMask(part);
1026 }
1027
1028 static constexpr Part PartMask(int part) {
1029 return part == parts - 1 ? topPartMask : partMask;
1030 }
1031
1032 constexpr void Clear() {
1033 for (int j{0}; j < parts; ++j) {
1034 part_[j] = 0;
1035 }
1036 }
1037
1038 Part part_[parts]{};
1039};
1040
1041extern template class Integer<8>;
1042extern template class Integer<16>;
1043extern template class Integer<32>;
1044extern template class Integer<64>;
1045extern template class Integer<80>;
1046extern template class Integer<128>;
1047} // namespace Fortran::evaluate::value
1048#endif // FORTRAN_EVALUATE_INTEGER_H_