[flang-commits] [flang] [Flang] KIND De-Templatization (PR #206907)
Michael Kruse via flang-commits
flang-commits at lists.llvm.org
Wed Jul 1 01:32:12 PDT 2026
https://github.com/Meinersbur created https://github.com/llvm/llvm-project/pull/206907
Not intended to be landed, but for performance measurements
Mostly done by AI
>From 2db2e902fe08498093a17bb3b9ce347d759f4d05 Mon Sep 17 00:00:00 2001
From: Michael Kruse <llvm-project at meinersbur.de>
Date: Mon, 8 Jun 2026 09:43:56 +0200
Subject: [PATCH 1/2] [Flang][CMake] Add missing CMakePushCheckState for
standalone build
---
flang/cmake/modules/FlangCommon.cmake | 1 +
1 file changed, 1 insertion(+)
diff --git a/flang/cmake/modules/FlangCommon.cmake b/flang/cmake/modules/FlangCommon.cmake
index c01afa43d0c1a..a1e80f737e543 100644
--- a/flang/cmake/modules/FlangCommon.cmake
+++ b/flang/cmake/modules/FlangCommon.cmake
@@ -12,6 +12,7 @@
include(CheckCSourceCompiles)
include(CheckIncludeFile)
+include(CMakePushCheckState)
# The out of tree builds of the compiler and the Fortran runtime
# must use the same setting of FLANG_RUNTIME_F128_MATH_LIB
>From b78790dd99443f17a8290ee6d255bb17174881ec Mon Sep 17 00:00:00 2001
From: Michael Kruse <llvm-project at meinersbur.de>
Date: Wed, 1 Jul 2026 10:28:18 +0200
Subject: [PATCH 2/2] [Flang] KIND De-templatization
---
flang/CMakeLists.txt | 10 +
flang/include/flang/Evaluate/call.h | 25 +-
.../flang/Evaluate/character-value-impl.h | 181 ++++
.../include/flang/Evaluate/character-value.h | 172 ++++
.../include/flang/Evaluate/characteristics.h | 3 +-
flang/include/flang/Evaluate/complex-value.h | 92 ++
flang/include/flang/Evaluate/complex.h | 114 ---
flang/include/flang/Evaluate/constant.h | 38 +-
flang/include/flang/Evaluate/expression.h | 271 ++++--
.../include/flang/Evaluate/fold-designator.h | 6 +-
flang/include/flang/Evaluate/fold.h | 16 +-
flang/include/flang/Evaluate/initial-image.h | 24 +-
flang/include/flang/Evaluate/integer-value.h | 280 ++++++
flang/include/flang/Evaluate/integer.h | 10 +-
flang/include/flang/Evaluate/logical-value.h | 97 ++
flang/include/flang/Evaluate/logical.h | 110 ---
flang/include/flang/Evaluate/match.h | 17 +-
flang/include/flang/Evaluate/object-sizes.h | 82 ++
flang/include/flang/Evaluate/real-value.h | 171 ++++
flang/include/flang/Evaluate/real.h | 42 +-
flang/include/flang/Evaluate/rewrite.h | 30 +-
flang/include/flang/Evaluate/rounding-bits.h | 4 +
flang/include/flang/Evaluate/shape.h | 4 +-
flang/include/flang/Evaluate/static-data.h | 1 +
flang/include/flang/Evaluate/tools.h | 212 +++--
flang/include/flang/Evaluate/type.h | 199 ++--
flang/include/flang/Evaluate/variable.h | 6 +
flang/include/flang/Lower/DirectivesCommon.h | 40 +-
flang/include/flang/Lower/Mangler.h | 17 +-
flang/include/flang/Lower/Support/Utils.h | 14 +-
flang/include/flang/Semantics/dump-expr.h | 6 +-
flang/lib/Evaluate/CMakeLists.txt | 65 +-
flang/lib/Evaluate/character-value-impl.cpp | 462 +++++++++
flang/lib/Evaluate/character-value.cpp | 180 ++++
flang/lib/Evaluate/character.h | 81 +-
flang/lib/Evaluate/characteristics.cpp | 8 +-
flang/lib/Evaluate/check-expression.cpp | 30 +-
flang/lib/Evaluate/complex-value.cpp | 269 ++++++
flang/lib/Evaluate/complex.cpp | 136 ---
flang/lib/Evaluate/constant.cpp | 104 +-
flang/lib/Evaluate/expression.cpp | 80 +-
flang/lib/Evaluate/fold-character.cpp | 115 ++-
flang/lib/Evaluate/fold-complex.cpp | 31 +-
flang/lib/Evaluate/fold-designator.cpp | 31 +-
flang/lib/Evaluate/fold-implementation.h | 446 ++++++---
flang/lib/Evaluate/fold-integer.cpp | 485 +++++-----
flang/lib/Evaluate/fold-logical.cpp | 434 +++------
flang/lib/Evaluate/fold-matmul.h | 15 +-
flang/lib/Evaluate/fold-real.cpp | 95 +-
flang/lib/Evaluate/fold-reduction.h | 41 +-
flang/lib/Evaluate/fold.cpp | 5 +-
flang/lib/Evaluate/formatting.cpp | 80 +-
flang/lib/Evaluate/host.h | 150 ++-
flang/lib/Evaluate/initial-image.cpp | 78 +-
flang/lib/Evaluate/int-power.h | 6 +-
flang/lib/Evaluate/integer-value.cpp | 891 ++++++++++++++++++
flang/lib/Evaluate/integer.cpp | 1 +
flang/lib/Evaluate/intrinsics-library.cpp | 15 +-
flang/lib/Evaluate/logical-value.cpp | 102 ++
flang/lib/Evaluate/logical.cpp | 17 -
flang/lib/Evaluate/object-size-probe.cpp | 93 ++
flang/lib/Evaluate/real-value-impl.h | 240 +++++
flang/lib/Evaluate/real-value.cpp | 809 ++++++++++++++++
flang/lib/Evaluate/real.cpp | 3 +
flang/lib/Evaluate/shape.cpp | 106 ++-
flang/lib/Evaluate/static-data.cpp | 11 +
flang/lib/Evaluate/target.cpp | 105 +--
flang/lib/Evaluate/tools.cpp | 281 +++---
flang/lib/Evaluate/type.cpp | 34 +-
flang/lib/Evaluate/variable.cpp | 83 +-
flang/lib/Lower/Bridge.cpp | 3 +-
flang/lib/Lower/CallInterface.cpp | 10 +-
flang/lib/Lower/ConvertArrayConstructor.cpp | 38 +-
flang/lib/Lower/ConvertConstant.cpp | 251 ++---
flang/lib/Lower/ConvertExpr.cpp | 268 +++---
flang/lib/Lower/ConvertExprToHLFIR.cpp | 207 ++--
flang/lib/Lower/ConvertType.cpp | 19 +-
flang/lib/Lower/Support/Utils.cpp | 143 ++-
flang/lib/Semantics/check-call.cpp | 5 +-
flang/lib/Semantics/check-case.cpp | 22 +-
flang/lib/Semantics/check-coarray.cpp | 2 +-
flang/lib/Semantics/check-data.cpp | 2 +-
flang/lib/Semantics/check-io.h | 8 +-
flang/lib/Semantics/check-omp-atomic.cpp | 14 +-
flang/lib/Semantics/data-to-inits.cpp | 6 +-
flang/lib/Semantics/dump-expr.cpp | 9 +-
flang/lib/Semantics/expression.cpp | 321 ++++---
flang/lib/Semantics/openmp-utils.cpp | 4 +-
flang/lib/Semantics/pointer-assignment.cpp | 10 +-
flang/lib/Semantics/resolve-names-utils.cpp | 2 +-
flang/lib/Semantics/resolve-names.cpp | 36 +-
flang/lib/Semantics/runtime-type-info.cpp | 83 +-
flang/lib/Semantics/type.cpp | 13 +-
.../intrinsic-module-path_per_target.f90 | 2 +-
flang/test/Evaluate/folding05.f90 | Bin 11212 -> 11103 bytes
flang/test/Semantics/bug2236.f90 | 2 +-
flang/unittests/Evaluate/expression.cpp | 21 +-
flang/unittests/Evaluate/folding.cpp | 20 +-
flang/unittests/Evaluate/integer.cpp | 1 +
flang/unittests/Evaluate/intrinsics.cpp | 166 ++--
flang/unittests/Evaluate/logical.cpp | 7 +-
flang/unittests/Evaluate/real.cpp | 138 +--
102 files changed, 7433 insertions(+), 2912 deletions(-)
create mode 100644 flang/include/flang/Evaluate/character-value-impl.h
create mode 100644 flang/include/flang/Evaluate/character-value.h
create mode 100644 flang/include/flang/Evaluate/complex-value.h
delete mode 100644 flang/include/flang/Evaluate/complex.h
create mode 100644 flang/include/flang/Evaluate/integer-value.h
create mode 100644 flang/include/flang/Evaluate/logical-value.h
delete mode 100644 flang/include/flang/Evaluate/logical.h
create mode 100644 flang/include/flang/Evaluate/object-sizes.h
create mode 100644 flang/include/flang/Evaluate/real-value.h
create mode 100644 flang/lib/Evaluate/character-value-impl.cpp
create mode 100644 flang/lib/Evaluate/character-value.cpp
create mode 100644 flang/lib/Evaluate/complex-value.cpp
delete mode 100644 flang/lib/Evaluate/complex.cpp
create mode 100644 flang/lib/Evaluate/integer-value.cpp
create mode 100644 flang/lib/Evaluate/logical-value.cpp
delete mode 100644 flang/lib/Evaluate/logical.cpp
create mode 100644 flang/lib/Evaluate/object-size-probe.cpp
create mode 100644 flang/lib/Evaluate/real-value-impl.h
create mode 100644 flang/lib/Evaluate/real-value.cpp
diff --git a/flang/CMakeLists.txt b/flang/CMakeLists.txt
index a8bd5e266aefa..8fe2178b509c0 100644
--- a/flang/CMakeLists.txt
+++ b/flang/CMakeLists.txt
@@ -296,7 +296,17 @@ endif()
# Always build tco tool
set(LLVM_BUILD_TOOLS ON)
+# The first entry holds build-time generated, per-configuration headers (namely
+# flang/Evaluate/object-sizes-generated.h emitted by
+# flang-evaluate-object-size-probe and picked up via __has_include from
+# flang/Evaluate/object-sizes.h). It is per-$<CONFIG> because multi-config
+# generators (Ninja Multi-Config, Visual Studio, Xcode) may produce different
+# object layouts per configuration (e.g. MSVC's _ITERATOR_DEBUG_LEVEL changes
+# std::string/std::variant sizes in Debug). The generated header has a distinct
+# name from its checked-in fallback, so include ordering does not matter; this
+# directory only needs to be on the path.
include_directories(BEFORE
+ ${FLANG_BINARY_DIR}/include/object-sizes/$<CONFIG>
${FLANG_BINARY_DIR}/include
${FLANG_SOURCE_DIR}/include)
diff --git a/flang/include/flang/Evaluate/call.h b/flang/include/flang/Evaluate/call.h
index 01b41f36b9977..107fab9e8adb5 100644
--- a/flang/include/flang/Evaluate/call.h
+++ b/flang/include/flang/Evaluate/call.h
@@ -299,20 +299,39 @@ template <typename A> class FunctionRef : public ProcedureRef {
FunctionRef(ProcedureDesignator &&p, ActualArguments &&a)
: ProcedureRef{std::move(p), std::move(a)} {}
+ // Records the runtime kind of an intrinsic function result when it cannot be
+ // recovered from the procedure designator's symbol (e.g. user procedures
+ // declared with an intrinsic interface). Zero means "unspecified".
+ int resultKind() const { return resultKind_; }
+ void set_resultKind(int k) { resultKind_ = k; }
+
std::optional<DynamicType> GetType() const {
- if constexpr (IsLengthlessIntrinsicType<A>) {
- return A::GetType();
- } else if (auto type{proc_.GetType()}) {
+ // The result kind is a runtime property taken from the procedure's
+ // interface rather than a compile-time template parameter of A.
+ if (auto type{proc_.GetType()}) {
// TODO: Non constant explicit length parameters of PDTs result should
// likely be dropped too. This is not as easy as for characters since some
// long lived DerivedTypeSpec pointer would need to be created here. It is
// not clear if this is causing any issue so far since the storage size of
// PDTs is independent of length parameters.
return type->DropNonConstantCharacterLength();
+ } else if constexpr (IsLengthlessIntrinsicType<A>) {
+ // User procedures may be declared with an interface that is a specific
+ // intrinsic; in that case there is no result type available from the
+ // procedure symbol. The result of such a procedure is always a
+ // lengthless intrinsic type whose kind was recorded when the reference
+ // was analyzed.
+ if (resultKind_ == 0) {
+ return std::nullopt;
+ }
+ return DynamicType{A::category, resultKind_};
} else {
return std::nullopt;
}
}
+
+private:
+ int resultKind_{0};
};
} // namespace Fortran::evaluate
#endif // FORTRAN_EVALUATE_CALL_H_
diff --git a/flang/include/flang/Evaluate/character-value-impl.h b/flang/include/flang/Evaluate/character-value-impl.h
new file mode 100644
index 0000000000000..b6cfa6587abfa
--- /dev/null
+++ b/flang/include/flang/Evaluate/character-value-impl.h
@@ -0,0 +1,181 @@
+//===-- include/flang/Evaluate/character-value-impl.h -----------*- C++ -*-===//
+//
+// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
+// See https://llvm.org/LICENSE.txt for license information.
+// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
+//
+//===----------------------------------------------------------------------===//
+
+#ifndef FORTRAN_EVALUATE_CHARACTER_VALUE_IMPL_H_
+#define FORTRAN_EVALUATE_CHARACTER_VALUE_IMPL_H_
+
+#include "llvm/Support/ErrorHandling.h"
+#include <cstddef>
+#include <optional>
+#include <string>
+#include <utility>
+#include <variant>
+
+namespace Fortran::evaluate::value {
+
+// CharacterValueImpl: runtime-kind character string (kind 1/2/4).
+// Interface compatible to std::string
+class CharacterValueImpl {
+public:
+ CharacterValueImpl() = default;
+ explicit CharacterValueImpl(std::string s) : storage_{std::move(s)} {}
+ explicit CharacterValueImpl(std::u16string s) : storage_{std::move(s)} {}
+ explicit CharacterValueImpl(std::u32string s) : storage_{std::move(s)} {}
+
+ // Fill constructors: create a string of n copies of the given character.
+ CharacterValueImpl(std::size_t n, char c) : storage_{std::string(n, c)} {}
+ CharacterValueImpl(std::size_t n, char16_t c)
+ : storage_{std::u16string(n, c)} {}
+ CharacterValueImpl(std::size_t n, char32_t c)
+ : storage_{std::u32string(n, c)} {}
+
+ // Comparison operators
+ bool operator==(const CharacterValueImpl &y) const {
+ return storage_ == y.storage_;
+ }
+ bool operator!=(const CharacterValueImpl &y) const { return !(*this == y); }
+ bool operator<(const CharacterValueImpl &y) const;
+ bool operator>(const CharacterValueImpl &y) const { return y < *this; }
+ bool operator<=(const CharacterValueImpl &y) const { return !(y < *this); }
+ bool operator>=(const CharacterValueImpl &y) const { return !(*this < y); }
+
+ int kind() const;
+ int bits() const;
+ bool IsMonostate() const { return storage_.index() == 0; }
+ bool IsZero() const;
+ bool StoreRawBytes(void *to, std::size_t bytes) const;
+ static CharacterValueImpl Zero(int kind);
+
+ // Dispatch a callable over the active string alternative, mirroring
+ // RealValueImpl::WithReal. Precondition: not monostate.
+ template <typename F>
+ auto WithChar(F &&f) const -> decltype(std::declval<F>()(
+ std::declval<const std::string &>())) {
+ switch (storage_.index()) {
+ case 1:
+ return f(std::get<std::string>(storage_));
+ case 2:
+ return f(std::get<std::u16string>(storage_));
+ case 3:
+ return f(std::get<std::u32string>(storage_));
+ default:
+ llvm_unreachable("operation on uninitialized CharacterValue");
+ }
+ }
+
+ std::size_t size() const;
+
+ // String length (synonym for size()).
+ std::size_t length() const { return size(); }
+
+ // True when the string is empty.
+ bool empty() const { return size() == 0; }
+
+ // Assign n copies of the given character, fixing the kind from the char type.
+ void assign(std::size_t n, char c) { storage_ = std::string(n, c); }
+ void assign(std::size_t n, char16_t c) { storage_ = std::u16string(n, c); }
+ void assign(std::size_t n, char32_t c) { storage_ = std::u32string(n, c); }
+
+ // Assign from a raw character pointer and length.
+ void assign(const char *p, std::size_t n) { storage_ = std::string(p, n); }
+ void assign(const char16_t *p, std::size_t n) {
+ storage_ = std::u16string(p, n);
+ }
+ void assign(const char32_t *p, std::size_t n) {
+ storage_ = std::u32string(p, n);
+ }
+
+ // Erase from position pos to end.
+ void erase(std::size_t pos);
+
+ // Append n copies of the given character (widened to the stored type).
+ void append(std::size_t n, char c);
+ void append(std::size_t n, char16_t c);
+ void append(std::size_t n, char32_t c);
+
+ // Replace the substring [pos, pos+len) with characters from other.
+ CharacterValueImpl &replace(
+ std::size_t pos, std::size_t len, const CharacterValueImpl &other);
+
+ // Return a suffix starting at pos.
+ CharacterValueImpl substr(std::size_t pos) const;
+
+ // Return a substring of len characters starting at pos.
+ CharacterValueImpl substr(std::size_t pos, std::size_t len) const;
+
+ // Return the string as std::string if kind==1, or nullopt otherwise.
+ std::optional<std::string> ToStdString() const;
+
+ // Reserve storage for at least n characters.
+ void reserve(std::size_t n);
+
+ // Return the character at position i as char32_t (safe for all kinds).
+ char32_t operator[](std::size_t i) const;
+
+ // Concatenate two same-kind strings.
+ CharacterValueImpl operator+(const CharacterValueImpl &y) const;
+
+ // Append another same-kind string.
+ CharacterValueImpl &operator+=(const CharacterValueImpl &y);
+
+ // Append a character, converting it to the string's element type.
+ CharacterValueImpl &operator+=(char c);
+
+ // Sentinel value for "not found" positions (same as std::string::npos).
+ static constexpr std::size_t npos{std::string::npos};
+
+ // Find-family methods; return npos when not found.
+ // Argument is a scalar character (widened to char32_t for dispatch).
+ std::size_t find_first_not_of(char c) const {
+ return find_first_not_of_char(static_cast<char32_t>(c));
+ }
+ std::size_t find_first_not_of(char16_t c) const {
+ return find_first_not_of_char(static_cast<char32_t>(c));
+ }
+ std::size_t find_first_not_of(char32_t c) const {
+ return find_first_not_of_char(c);
+ }
+ std::size_t find_last_not_of(char c) const {
+ return find_last_not_of_char(static_cast<char32_t>(c));
+ }
+ std::size_t find_last_not_of(char16_t c) const {
+ return find_last_not_of_char(static_cast<char32_t>(c));
+ }
+ std::size_t find_last_not_of(char32_t c) const {
+ return find_last_not_of_char(c);
+ }
+
+ // Find-family methods using a CharacterValueImpl as the character set.
+ std::size_t find_first_not_of(const CharacterValueImpl &set) const;
+ std::size_t find_last_not_of(const CharacterValueImpl &set) const;
+
+ // Find-family methods taking a CharacterValueImpl set/pattern.
+ std::size_t find(const CharacterValueImpl &pattern) const;
+ std::size_t rfind(const CharacterValueImpl &pattern) const;
+ std::size_t find_first_of(const CharacterValueImpl &set) const;
+ std::size_t find_last_of(const CharacterValueImpl &set) const;
+
+ // Byte size of one character unit (1, 2, or 4).
+ std::size_t charSize() const;
+
+ // Raw byte pointer to the underlying character data.
+ const void *data() const { return charData(); }
+ void *charData();
+ const void *charData() const;
+
+private:
+ std::size_t find_first_not_of_char(char32_t c) const;
+ std::size_t find_last_not_of_char(char32_t c) const;
+
+ using Storage =
+ std::variant<std::monostate, std::string, std::u16string, std::u32string>;
+ Storage storage_;
+};
+
+} // namespace Fortran::evaluate::value
+#endif // FORTRAN_EVALUATE_CHARACTER_VALUE_IMPL_H_
diff --git a/flang/include/flang/Evaluate/character-value.h b/flang/include/flang/Evaluate/character-value.h
new file mode 100644
index 0000000000000..af2460a1f341c
--- /dev/null
+++ b/flang/include/flang/Evaluate/character-value.h
@@ -0,0 +1,172 @@
+//===-- include/flang/Evaluate/character-value.h ----------------*- C++ -*-===//
+//
+// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
+// See https://llvm.org/LICENSE.txt for license information.
+// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
+//
+//===----------------------------------------------------------------------===//
+
+#ifndef FORTRAN_EVALUATE_CHAR_VALUE_H_
+#define FORTRAN_EVALUATE_CHAR_VALUE_H_
+
+#include "flang/Evaluate/object-sizes.h"
+#include <cstddef>
+#include <iosfwd>
+#include <optional>
+
+namespace Fortran::evaluate::value {
+
+class CharacterValueImpl;
+
+// ----------------------------------------------------------------------------
+// CharacterValue: runtime-kind character string (kind 1/2/4).
+// Interface compatible to std::string
+// ----------------------------------------------------------------------------
+class CharacterValue {
+public:
+ CharacterValue();
+ CharacterValue(const CharacterValue &);
+ CharacterValue(CharacterValue &&);
+ ~CharacterValue();
+ CharacterValue &operator=(const CharacterValue &);
+ CharacterValue &operator=(CharacterValue &&);
+
+ explicit CharacterValue(std::string s);
+ explicit CharacterValue(std::u16string s);
+ explicit CharacterValue(std::u32string s);
+
+ // Fill constructors: create a string of n copies of the given character.
+ CharacterValue(std::size_t n, char c);
+ CharacterValue(std::size_t n, char16_t c);
+ CharacterValue(std::size_t n, char32_t c);
+
+ // Comparison operators
+ bool operator==(const CharacterValue &y) const;
+ bool operator!=(const CharacterValue &y) const { return !(*this == y); }
+ bool operator<(const CharacterValue &y) const;
+ bool operator>(const CharacterValue &y) const { return y < *this; }
+ bool operator<=(const CharacterValue &y) const { return !(y < *this); }
+ bool operator>=(const CharacterValue &y) const { return !(*this < y); }
+
+ int kind() const;
+ int bits() const;
+ bool IsMonostate() const;
+ bool IsZero() const;
+ static CharacterValue Zero(int kind);
+
+ std::size_t size() const;
+
+ // String length (synonym for size()).
+ std::size_t length() const { return size(); }
+
+ // True when the string is empty.
+ bool empty() const { return size() == 0; }
+
+ // Assign n copies of the given character, fixing the kind from the char type.
+ void assign(std::size_t n, char c);
+ void assign(std::size_t n, char16_t c);
+ void assign(std::size_t n, char32_t c);
+
+ // Assign from a raw character pointer and length.
+ void assign(const char *p, std::size_t n);
+ void assign(const char16_t *p, std::size_t n);
+ void assign(const char32_t *p, std::size_t n);
+
+ // Erase from position pos to end.
+ void erase(std::size_t pos);
+
+ // Append n copies of the given character (widened to the stored type).
+ void append(std::size_t n, char c);
+ void append(std::size_t n, char16_t c);
+ void append(std::size_t n, char32_t c);
+
+ // Replace the substring [pos, pos+len) with characters from other.
+ CharacterValue &replace(
+ std::size_t pos, std::size_t len, const CharacterValue &other);
+
+ // Return a suffix starting at pos.
+ CharacterValue substr(std::size_t pos) const;
+
+ // Return a substring of len characters starting at pos.
+ CharacterValue substr(std::size_t pos, std::size_t len) const;
+
+ // Return the string as std::string if kind==1, or nullopt otherwise.
+ std::optional<std::string> ToStdString() const;
+
+ // Reserve storage for at least n characters.
+ void reserve(std::size_t n);
+
+ // Return the character at position i as char32_t (safe for all kinds).
+ char32_t operator[](std::size_t i) const;
+
+ // Concatenate two same-kind strings.
+ CharacterValue operator+(const CharacterValue &y) const;
+
+ // Append another same-kind string.
+ CharacterValue &operator+=(const CharacterValue &y);
+
+ // Append a character, converting it to the string's element type.
+ CharacterValue &operator+=(char c);
+
+ // Sentinel value for "not found" positions (same as std::string::npos).
+ static constexpr std::size_t npos{~std::size_t{0}};
+
+ // Find-family methods; return npos when not found.
+ // Argument is a scalar character (widened to char32_t for dispatch).
+ std::size_t find_first_not_of(char c) const {
+ return find_first_not_of_char(static_cast<char32_t>(c));
+ }
+ std::size_t find_first_not_of(char16_t c) const {
+ return find_first_not_of_char(static_cast<char32_t>(c));
+ }
+ std::size_t find_first_not_of(char32_t c) const {
+ return find_first_not_of_char(c);
+ }
+ std::size_t find_last_not_of(char c) const {
+ return find_last_not_of_char(static_cast<char32_t>(c));
+ }
+ std::size_t find_last_not_of(char16_t c) const {
+ return find_last_not_of_char(static_cast<char32_t>(c));
+ }
+ std::size_t find_last_not_of(char32_t c) const {
+ return find_last_not_of_char(c);
+ }
+
+ // Find-family methods using a CharacterValue as the character set.
+ std::size_t find_first_not_of(const CharacterValue &set) const;
+ std::size_t find_last_not_of(const CharacterValue &set) const;
+
+ // Find-family methods taking a CharacterValue set/pattern.
+ std::size_t find(const CharacterValue &pattern) const;
+ std::size_t rfind(const CharacterValue &pattern) const;
+ std::size_t find_first_of(const CharacterValue &set) const;
+ std::size_t find_last_of(const CharacterValue &set) const;
+
+ // Byte size of one character unit (1, 2, or 4).
+ std::size_t charSize() const;
+
+ // Raw byte pointer to the underlying character data.
+ const void *data() const;
+ void *charData();
+ const void *charData() const;
+
+ CharacterValueImpl &value() {
+ return *reinterpret_cast<CharacterValueImpl *>(this);
+ }
+ const CharacterValueImpl &value() const {
+ return *reinterpret_cast<const CharacterValueImpl *>(this);
+ }
+
+private:
+ std::size_t find_first_not_of_char(char32_t c) const;
+ std::size_t find_last_not_of_char(char32_t c) const;
+
+ alignas(
+ detail::kCharacterObjectAlign) char opaque_[detail::kCharacterObjectSize];
+};
+
+static_assert(sizeof(CharacterValue) == detail::kCharacterObjectSize);
+static_assert(alignof(CharacterValue) == detail::kCharacterObjectAlign);
+
+} // namespace Fortran::evaluate::value
+#endif // FORTRAN_EVALUATE_CHAR_VALUE_H_
diff --git a/flang/include/flang/Evaluate/characteristics.h b/flang/include/flang/Evaluate/characteristics.h
index af0d429b6aa3b..c12d3005c69c4 100644
--- a/flang/include/flang/Evaluate/characteristics.h
+++ b/flang/include/flang/Evaluate/characteristics.h
@@ -118,9 +118,8 @@ class TypeAndShape {
}
// Specialization for character designators
- template <int KIND>
static std::optional<TypeAndShape> Characterize(
- const Designator<Type<TypeCategory::Character, KIND>> &x,
+ const Designator<Type<TypeCategory::Character>> &x,
FoldingContext &context, bool invariantOnly = true) {
const auto *symbol{UnwrapWholeSymbolOrComponentDataRef(x)};
if (symbol && !symbol->owner().IsDerivedType()) { // Whole variable
diff --git a/flang/include/flang/Evaluate/complex-value.h b/flang/include/flang/Evaluate/complex-value.h
new file mode 100644
index 0000000000000..890c2c48144a7
--- /dev/null
+++ b/flang/include/flang/Evaluate/complex-value.h
@@ -0,0 +1,92 @@
+//===-- include/flang/Evaluate/complex-value.h ------------------*- C++ -*-===//
+//
+// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
+// See https://llvm.org/LICENSE.txt for license information.
+// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
+//
+//===----------------------------------------------------------------------===//
+
+#ifndef FORTRAN_EVALUATE_COMPLEX_VALUE_H_
+#define FORTRAN_EVALUATE_COMPLEX_VALUE_H_
+
+#include "real-value.h"
+
+namespace llvm {
+class raw_ostream;
+}
+
+namespace Fortran::evaluate::value {
+
+// ----------------------------------------------------------------------------
+// ComplexValue: pair of RealValue components.
+// ----------------------------------------------------------------------------
+class ComplexValue {
+public:
+ ComplexValue() = default;
+ ComplexValue(const RealValue &r, const RealValue &i)
+ : re_{r}, im_{r.IsMonostate() ? i : i.ConvertToKind(r.kind())} {}
+ explicit ComplexValue(const RealValue &r)
+ : ComplexValue{r, RealValue::Zero(r.kind())} {}
+
+ // Comparison operators
+ bool operator==(const ComplexValue &y) const;
+ bool operator!=(const ComplexValue &y) const { return !(*this == y); }
+
+ static ComplexValue NotANumber(int kind) {
+ return {RealValue::NotANumber(kind), RealValue::NotANumber(kind)};
+ }
+
+ // Runtime kind / width accessors
+ int kind() const;
+ int bits() const;
+ // A COMPLEX is the former monostate iff its real part is.
+ bool IsMonostate() const { return re_.IsMonostate(); }
+ bool IsZero() const;
+ bool IsInfinite() const;
+ bool IsNotANumber() const;
+ bool IsSignalingNaN() const;
+ bool Equals(const ComplexValue &y) const;
+ bool StoreRawBytes(void *to, std::size_t strideBytes) const;
+ static ComplexValue FromRawBytes(const void *raw, std::size_t bytes);
+ static ComplexValue Zero(int kind);
+
+ RealValue REAL() const;
+ RealValue AIMAG() const;
+
+ // Unary operations
+ ComplexValue CONJG() const;
+ ComplexValue Negate() const;
+ ComplexValue FlushSubnormalToZero() const;
+
+ // Binary arithmetic
+ ValueWithRealFlags<ComplexValue> Add(const ComplexValue &,
+ Rounding rounding = TargetCharacteristics::defaultRounding) const;
+ ValueWithRealFlags<ComplexValue> Subtract(const ComplexValue &,
+ Rounding rounding = TargetCharacteristics::defaultRounding) const;
+ ValueWithRealFlags<ComplexValue> Multiply(const ComplexValue &,
+ Rounding rounding = TargetCharacteristics::defaultRounding) const;
+ ValueWithRealFlags<ComplexValue> Divide(const ComplexValue &,
+ Rounding rounding = TargetCharacteristics::defaultRounding) const;
+ ValueWithRealFlags<RealValue> ABS(
+ Rounding rounding = TargetCharacteristics::defaultRounding) const;
+
+ ComplexValue ConvertToKind(int kind) const;
+
+ static ValueWithRealFlags<ComplexValue> FromInteger(const IntegerValue &n,
+ int kind, bool isUnsigned = false,
+ Rounding rounding = TargetCharacteristics::defaultRounding);
+
+ ValueWithRealFlags<ComplexValue> KahanSummation(const ComplexValue &y,
+ ComplexValue &correction,
+ Rounding rounding = TargetCharacteristics::defaultRounding) const;
+
+ std::string DumpHexadecimal() const;
+ llvm::raw_ostream &AsFortran(llvm::raw_ostream &, int kind) const;
+
+private:
+ RealValue re_;
+ RealValue im_;
+};
+
+} // namespace Fortran::evaluate::value
+#endif // FORTRAN_EVALUATE_COMPLEX_VALUE_H_
diff --git a/flang/include/flang/Evaluate/complex.h b/flang/include/flang/Evaluate/complex.h
deleted file mode 100644
index 9781db9a25a64..0000000000000
--- a/flang/include/flang/Evaluate/complex.h
+++ /dev/null
@@ -1,114 +0,0 @@
-//===-- include/flang/Evaluate/complex.h ------------------------*- C++ -*-===//
-//
-// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
-// See https://llvm.org/LICENSE.txt for license information.
-// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
-//
-//===----------------------------------------------------------------------===//
-
-#ifndef FORTRAN_EVALUATE_COMPLEX_H_
-#define FORTRAN_EVALUATE_COMPLEX_H_
-
-#include "formatting.h"
-#include "real.h"
-#include <string>
-
-namespace llvm {
-class raw_ostream;
-}
-
-namespace Fortran::evaluate::value {
-
-template <typename REAL_TYPE> class Complex {
-public:
- using Part = REAL_TYPE;
- static constexpr int bits{2 * Part::bits};
-
- constexpr Complex() {} // (+0.0, +0.0)
- constexpr Complex(const Complex &) = default;
- constexpr Complex(const Part &r, const Part &i) : re_{r}, im_{i} {}
- explicit constexpr Complex(const Part &r) : re_{r} {}
- constexpr Complex &operator=(const Complex &) = default;
- constexpr Complex &operator=(Complex &&) = default;
-
- constexpr bool operator==(const Complex &that) const {
- return re_ == that.re_ && im_ == that.im_;
- }
-
- constexpr const Part &REAL() const { return re_; }
- constexpr const Part &AIMAG() const { return im_; }
- constexpr Complex CONJG() const { return {re_, im_.Negate()}; }
- constexpr Complex Negate() const { return {re_.Negate(), im_.Negate()}; }
-
- constexpr bool Equals(const Complex &that) const {
- return re_.Compare(that.re_) == Relation::Equal &&
- im_.Compare(that.im_) == Relation::Equal;
- }
-
- constexpr bool IsZero() const { return re_.IsZero() && im_.IsZero(); }
-
- constexpr bool IsInfinite() const {
- return re_.IsInfinite() || im_.IsInfinite();
- }
-
- constexpr bool IsNotANumber() const {
- return re_.IsNotANumber() || im_.IsNotANumber();
- }
-
- constexpr bool IsSignalingNaN() const {
- return re_.IsSignalingNaN() || im_.IsSignalingNaN();
- }
-
- template <typename INT>
- static ValueWithRealFlags<Complex> FromInteger(const INT &n,
- bool isUnsigned = false,
- Rounding rounding = TargetCharacteristics::defaultRounding) {
- ValueWithRealFlags<Complex> result;
- result.value.re_ = Part::FromInteger(n, isUnsigned, rounding)
- .AccumulateFlags(result.flags);
- return result;
- }
-
- ValueWithRealFlags<Complex> Add(const Complex &,
- Rounding rounding = TargetCharacteristics::defaultRounding) const;
- ValueWithRealFlags<Complex> Subtract(const Complex &,
- Rounding rounding = TargetCharacteristics::defaultRounding) const;
- ValueWithRealFlags<Complex> Multiply(const Complex &,
- Rounding rounding = TargetCharacteristics::defaultRounding) const;
- ValueWithRealFlags<Complex> Divide(const Complex &,
- Rounding rounding = TargetCharacteristics::defaultRounding) const;
- ValueWithRealFlags<Complex> KahanSummation(const Complex &,
- Complex &correction,
- Rounding rounding = TargetCharacteristics::defaultRounding) const;
-
- // ABS/CABS = HYPOT(re_, imag_) = SQRT(re_**2 + im_**2)
- ValueWithRealFlags<Part> ABS(
- Rounding rounding = TargetCharacteristics::defaultRounding) const {
- return re_.HYPOT(im_, rounding);
- }
-
- constexpr Complex FlushSubnormalToZero() const {
- return {re_.FlushSubnormalToZero(), im_.FlushSubnormalToZero()};
- }
-
- static constexpr Complex NotANumber() {
- return {Part::NotANumber(), Part::NotANumber()};
- }
-
- std::string DumpHexadecimal() const;
- llvm::raw_ostream &AsFortran(llvm::raw_ostream &, int kind) const;
-
- // TODO: unit testing
-
-private:
- Part re_, im_;
-};
-
-extern template class Complex<Real<Integer<16>, 11>>;
-extern template class Complex<Real<Integer<16>, 8>>;
-extern template class Complex<Real<Integer<32>, 24>>;
-extern template class Complex<Real<Integer<64>, 53>>;
-extern template class Complex<Real<X87IntegerContainer, 64>>;
-extern template class Complex<Real<Integer<128>, 113>>;
-} // namespace Fortran::evaluate::value
-#endif // FORTRAN_EVALUATE_COMPLEX_H_
diff --git a/flang/include/flang/Evaluate/constant.h b/flang/include/flang/Evaluate/constant.h
index 9ae37cd999aa9..7b1e027132b99 100644
--- a/flang/include/flang/Evaluate/constant.h
+++ b/flang/include/flang/Evaluate/constant.h
@@ -99,8 +99,8 @@ class ConstantBounds {
ConstantSubscripts lbounds_;
};
-// Constant<> is specialized for Character kinds and SomeDerived.
-// The non-Character intrinsic types, and SomeDerived, share enough
+// Constant<> is specialized for CharacterValue kinds and SomeDerived.
+// The non-CharacterValue intrinsic types, and SomeDerived, share enough
// common behavior that they use this common base class.
template <typename RESULT, typename ELEMENT = Scalar<RESULT>>
class ConstantBase : public ConstantBounds {
@@ -131,7 +131,22 @@ class ConstantBase : public ConstantBounds {
Result &result() { return result_; }
const Result &result() const { return result_; }
- constexpr DynamicType GetType() const { return result_.GetType(); }
+ DynamicType GetType() const {
+ if constexpr (Result::category == TypeCategory::Derived) {
+ return result_.GetType();
+ } else {
+ // Source the kind from the runtime field rather than the compile-time
+ // template parameter, in preparation for removing the parameter. For
+ // categories whose Result carries no kind (Integer/Unsigned/Logical),
+ // result_ is default-constructed (kind 0); fall back to the kind that
+ // the stored scalar value carries at runtime.
+ int kind{result_.runtimeKind()};
+ if (kind == 0 && !values_.empty()) {
+ kind = values_.front().kind();
+ }
+ return DynamicType{Result::category, kind};
+ }
+ }
llvm::raw_ostream &AsFortran(llvm::raw_ostream &) const;
std::string AsFortran() const;
@@ -141,6 +156,7 @@ class ConstantBase : public ConstantBounds {
ConstantSubscripts &resultSubscripts, const std::vector<int> *dimOrder);
Result result_; // usually empty except for Real & Complex
+ // PAPAYA: store result kind
std::vector<Element> values_;
};
@@ -170,10 +186,10 @@ template <typename T> class Constant : public ConstantBase<T> {
ConstantSubscripts &resultSubscripts, const std::vector<int> *dimOrder);
};
-template <int KIND>
-class Constant<Type<TypeCategory::Character, KIND>> : public ConstantBounds {
+template <>
+class Constant<Type<TypeCategory::Character>> : public ConstantBounds {
public:
- using Result = Type<TypeCategory::Character, KIND>;
+ using Result = Type<TypeCategory::Character>;
using Element = Scalar<Result>;
CLASS_BOILERPLATE(Constant)
@@ -184,8 +200,10 @@ class Constant<Type<TypeCategory::Character, KIND>> : public ConstantBounds {
~Constant();
bool operator==(const Constant &that) const {
- return LEN() == that.LEN() && shape() == that.shape() &&
- values_ == that.values_;
+ // Kind is now a runtime property; constants of different character kinds
+ // were distinct C++ types in the baseline and must remain unequal here.
+ return kind_ == that.kind_ && LEN() == that.LEN() &&
+ shape() == that.shape() && values_ == that.values_;
}
bool empty() const;
std::size_t size() const;
@@ -212,7 +230,7 @@ class Constant<Type<TypeCategory::Character, KIND>> : public ConstantBounds {
Constant Reshape(ConstantSubscripts &&) const;
llvm::raw_ostream &AsFortran(llvm::raw_ostream &) const;
std::string AsFortran() const;
- DynamicType GetType() const { return {KIND, length_}; }
+ DynamicType GetType() const { return {kind_, length_}; }
std::size_t CopyFrom(const Constant &source, std::size_t count,
ConstantSubscripts &resultSubscripts, const std::vector<int> *dimOrder);
@@ -220,6 +238,8 @@ class Constant<Type<TypeCategory::Character, KIND>> : public ConstantBounds {
Scalar<Result> values_; // one contiguous string
ConstantSubscript length_;
bool wasHollerith_{false};
+
+ int kind_{0}; // runtime character kind
};
class StructureConstructor;
diff --git a/flang/include/flang/Evaluate/expression.h b/flang/include/flang/Evaluate/expression.h
index 1afe8ae74c415..d961a409b0ff6 100644
--- a/flang/include/flang/Evaluate/expression.h
+++ b/flang/include/flang/Evaluate/expression.h
@@ -178,10 +178,20 @@ class Operation {
}
}
- static constexpr std::conditional_t<Result::category != TypeCategory::Derived,
+ std::conditional_t<Result::category != TypeCategory::Derived,
std::optional<DynamicType>, void>
- GetType() {
- return Result::GetType();
+ GetType() const {
+ if constexpr (Result::category != TypeCategory::Derived) {
+ // The result kind of most operations equals their first operand's kind;
+ // derive it at runtime rather than from the compile-time Result::kind.
+ // Operations whose result kind differs (Convert, Relational) override
+ // this. An operand may be typeless on an error path, so propagate that
+ // rather than aborting.
+ if (auto operandType{this->left().GetType()}) {
+ return DynamicType{Result::category, operandType->kind()};
+ }
+ return std::nullopt;
+ }
}
int Rank() const {
int rank{left().Rank()};
@@ -222,7 +232,16 @@ struct Convert : public Operation<Convert<TO, FROMCAT>, TO, SomeKind<FROMCAT>> {
using Operand = SomeKind<FROMCAT>;
using Base = Operation<Convert, Result, Operand>;
using Base::Base;
+ // A conversion's result kind is the target kind, not the operand kind, so it
+ // is stored at runtime (defaulting to the compile-time target kind while it
+ // remains a template parameter) rather than derived from the operand.
+ std::optional<DynamicType> GetType() const {
+ return DynamicType{Result::category, resultKind_};
+ }
llvm::raw_ostream &AsFortran(llvm::raw_ostream &) const;
+ // TODO(kind-flip): the conversion target kind must be supplied at
+ // construction (it was formerly the compile-time Result::kind, now removed).
+ int resultKind_{0};
};
template <typename A>
@@ -251,12 +270,11 @@ template <typename A> struct Negate : public Operation<Negate<A>, A, A> {
using Base::Base;
};
-template <int KIND>
struct ComplexComponent
- : public Operation<ComplexComponent<KIND>, Type<TypeCategory::Real, KIND>,
- Type<TypeCategory::Complex, KIND>> {
- using Result = Type<TypeCategory::Real, KIND>;
- using Operand = Type<TypeCategory::Complex, KIND>;
+ : public Operation<ComplexComponent, Type<TypeCategory::Real>,
+ Type<TypeCategory::Complex>> {
+ using Result = Type<TypeCategory::Real>;
+ using Operand = Type<TypeCategory::Complex>;
using Base = Operation<ComplexComponent, Result, Operand>;
CLASS_BOILERPLATE(ComplexComponent)
ComplexComponent(bool isImaginary, const Expr<Operand> &x)
@@ -267,24 +285,21 @@ struct ComplexComponent
bool isImaginaryPart{true};
};
-template <int KIND>
-struct Not : public Operation<Not<KIND>, Type<TypeCategory::Logical, KIND>,
- Type<TypeCategory::Logical, KIND>> {
- using Result = Type<TypeCategory::Logical, KIND>;
+struct Not : public Operation<Not, Type<TypeCategory::Logical>,
+ Type<TypeCategory::Logical>> {
+ using Result = Type<TypeCategory::Logical>;
using Operand = Result;
using Base = Operation<Not, Result, Operand>;
using Base::Base;
};
-// Character lengths are determined by context in Fortran and do not
+// CharacterValue lengths are determined by context in Fortran and do not
// have explicit syntax for changing them. Expressions represent
// changes of length (e.g., for assignments and structure constructors)
// with this operation.
-template <int KIND>
-struct SetLength
- : public Operation<SetLength<KIND>, Type<TypeCategory::Character, KIND>,
- Type<TypeCategory::Character, KIND>, SubscriptInteger> {
- using Result = Type<TypeCategory::Character, KIND>;
+struct SetLength : public Operation<SetLength, Type<TypeCategory::Character>,
+ Type<TypeCategory::Character>, SubscriptInteger> {
+ using Result = Type<TypeCategory::Character>;
using CharacterOperand = Result;
using LengthOperand = SubscriptInteger;
using Base = Operation<SetLength, Result, CharacterOperand, LengthOperand>;
@@ -350,34 +365,28 @@ template <typename A> struct Extremum : public Operation<Extremum<A>, A, A, A> {
Ordering ordering{Ordering::Greater};
};
-template <int KIND>
struct ComplexConstructor
- : public Operation<ComplexConstructor<KIND>,
- Type<TypeCategory::Complex, KIND>, Type<TypeCategory::Real, KIND>,
- Type<TypeCategory::Real, KIND>> {
- using Result = Type<TypeCategory::Complex, KIND>;
- using Operand = Type<TypeCategory::Real, KIND>;
+ : public Operation<ComplexConstructor, Type<TypeCategory::Complex>,
+ Type<TypeCategory::Real>, Type<TypeCategory::Real>> {
+ using Result = Type<TypeCategory::Complex>;
+ using Operand = Type<TypeCategory::Real>;
using Base = Operation<ComplexConstructor, Result, Operand, Operand>;
using Base::Base;
};
-template <int KIND>
struct Concat
- : public Operation<Concat<KIND>, Type<TypeCategory::Character, KIND>,
- Type<TypeCategory::Character, KIND>,
- Type<TypeCategory::Character, KIND>> {
- using Result = Type<TypeCategory::Character, KIND>;
+ : public Operation<Concat, Type<TypeCategory::Character>,
+ Type<TypeCategory::Character>, Type<TypeCategory::Character>> {
+ using Result = Type<TypeCategory::Character>;
using Operand = Result;
using Base = Operation<Concat, Result, Operand, Operand>;
using Base::Base;
};
-template <int KIND>
struct LogicalOperation
- : public Operation<LogicalOperation<KIND>,
- Type<TypeCategory::Logical, KIND>, Type<TypeCategory::Logical, KIND>,
- Type<TypeCategory::Logical, KIND>> {
- using Result = Type<TypeCategory::Logical, KIND>;
+ : public Operation<LogicalOperation, Type<TypeCategory::Logical>,
+ Type<TypeCategory::Logical>, Type<TypeCategory::Logical>> {
+ using Result = Type<TypeCategory::Logical>;
using Operand = Result;
using Base = Operation<LogicalOperation, Result, Operand, Operand>;
CLASS_BOILERPLATE(LogicalOperation)
@@ -437,6 +446,9 @@ template <typename RESULT> class ArrayConstructorValues;
struct ImpliedDoIndex {
using Result = SubscriptInteger;
bool operator==(const ImpliedDoIndex &) const;
+ static constexpr DynamicType GetType() {
+ return DynamicType{TypeCategory::Integer, subscriptIntegerKind};
+ }
static constexpr int Rank() { return 0; }
static constexpr int Corank() { return 0; }
parser::CharBlock name; // nested implied DOs must use distinct names
@@ -499,6 +511,33 @@ template <typename RESULT> class ArrayConstructorValues {
Values values_;
};
+// Determine the runtime result kind of an array constructor by inspecting
+// its element values (recursing into implied DOs). Returns 0 if none of the
+// elements have a known type.
+template <typename RESULT>
+int GleanArrayConstructorResultKind(
+ const ArrayConstructorValues<RESULT> &values) {
+ for (const auto &v : values) {
+ int kind{common::visit(
+ [](const auto &x) -> int {
+ if constexpr (std::is_same_v<std::decay_t<decltype(x)>,
+ Expr<RESULT>>) {
+ if (auto type{x.GetType()}) {
+ return type->kind();
+ }
+ return 0;
+ } else {
+ return GleanArrayConstructorResultKind<RESULT>(x.values());
+ }
+ },
+ v.u)};
+ if (kind != 0) {
+ return kind;
+ }
+ }
+ return 0;
+}
+
// Note that there are specializations of ArrayConstructor for character
// and derived types, since they must carry additional type information,
// but that an empty ArrayConstructor can be constructed for any type
@@ -509,30 +548,52 @@ class ArrayConstructor : public ArrayConstructorValues<RESULT> {
using Result = RESULT;
using Base = ArrayConstructorValues<Result>;
DEFAULT_CONSTRUCTORS_AND_ASSIGNMENTS(ArrayConstructor)
- explicit ArrayConstructor(Base &&values) : Base{std::move(values)} {}
- template <typename T> explicit ArrayConstructor(const Expr<T> &) {}
+ explicit ArrayConstructor(Base &&values)
+ : Base{std::move(values)},
+ resultKind_{GleanArrayConstructorResultKind<Result>(*this)} {}
+ template <typename T> explicit ArrayConstructor(const Expr<T> &x) {
+ if (auto type{x.GetType()}) {
+ resultKind_ = type->kind();
+ }
+ }
static constexpr Result result() { return Result{}; }
- static constexpr DynamicType GetType() { return Result::GetType(); }
+ // The element kind is stored at runtime (defaulting to the compile-time kind
+ // while it remains a template parameter) rather than taken from Result.
+ DynamicType GetType() const {
+ return DynamicType{Result::category, resultKind_};
+ }
llvm::raw_ostream &AsFortran(llvm::raw_ostream &) const;
+ // The element kind is supplied at construction (formerly the compile-time
+ // Result::kind, now removed).
+ int resultKind_{0};
};
-template <int KIND>
-class ArrayConstructor<Type<TypeCategory::Character, KIND>>
- : public ArrayConstructorValues<Type<TypeCategory::Character, KIND>> {
+template <>
+class ArrayConstructor<Type<TypeCategory::Character>>
+ : public ArrayConstructorValues<Type<TypeCategory::Character>> {
public:
- using Result = Type<TypeCategory::Character, KIND>;
+ using Result = Type<TypeCategory::Character>;
using Base = ArrayConstructorValues<Result>;
DEFAULT_CONSTRUCTORS_AND_ASSIGNMENTS(ArrayConstructor)
explicit ArrayConstructor(Base &&values) : Base{std::move(values)} {}
- template <typename T> explicit ArrayConstructor(const Expr<T> &) {}
+ template <typename T> explicit ArrayConstructor(const Expr<T> &x) {
+ if (auto type{x.GetType()}) {
+ resultKind_ = type->kind();
+ }
+ }
ArrayConstructor &set_LEN(Expr<SubscriptInteger> &&);
bool operator==(const ArrayConstructor &) const;
static constexpr Result result() { return Result{}; }
- static constexpr DynamicType GetType() { return Result::GetType(); }
+ DynamicType GetType() const {
+ return DynamicType{Result::category, resultKind_};
+ }
llvm::raw_ostream &AsFortran(llvm::raw_ostream &) const;
const Expr<SubscriptInteger> *LEN() const {
return length_ ? &length_->value() : nullptr;
}
+ // The character kind is supplied at construction (formerly the compile-time
+ // Result::kind, now removed).
+ int resultKind_{0};
private:
std::optional<common::CopyableIndirection<Expr<SubscriptInteger>>> length_;
@@ -563,13 +624,26 @@ class ArrayConstructor<SomeDerived>
// Expression representations for each type category.
-template <int KIND>
-class Expr<Type<TypeCategory::Integer, KIND>>
- : public ExpressionBase<Type<TypeCategory::Integer, KIND>> {
+template <>
+class Expr<Type<TypeCategory::Integer>>
+ : public ExpressionBase<Type<TypeCategory::Integer>> {
public:
- using Result = Type<TypeCategory::Integer, KIND>;
+ using Result = Type<TypeCategory::Integer>;
EVALUATE_UNION_CLASS_BOILERPLATE(Expr)
+ // Compiler-internal integer literals (subscripts, bounds, shapes) default to
+ // the subscript integer kind, which is the widest commonly-used kind and so
+ // is range-safe; the kind is carried at runtime in the resulting Constant.
+ explicit Expr(int n) : Expr(static_cast<long long>(n)) {}
+ explicit Expr(unsigned n) : Expr(static_cast<unsigned long long>(n)) {}
+ explicit Expr(long n) : Expr(static_cast<long long>(n)) {}
+ explicit Expr(unsigned long n) : Expr(static_cast<unsigned long long>(n)) {}
+ explicit Expr(long long n)
+ : u{Constant<Result>{typename Result::Scalar{n, subscriptIntegerKind},
+ Result{subscriptIntegerKind}}} {}
+ explicit Expr(unsigned long long n)
+ : u{Constant<Result>{typename Result::Scalar{n, subscriptIntegerKind},
+ Result{subscriptIntegerKind}}} {}
private:
using Conversions = std::tuple<Convert<Result, TypeCategory::Integer>,
@@ -578,14 +652,9 @@ class Expr<Type<TypeCategory::Integer, KIND>>
using Operations = std::tuple<Parentheses<Result>, Negate<Result>,
Add<Result>, Subtract<Result>, Multiply<Result>, Divide<Result>,
Power<Result>, Extremum<Result>, ConditionalExpr<Result>>;
- using Indices = std::conditional_t<KIND == ImpliedDoIndex::Result::kind,
- std::tuple<ImpliedDoIndex>, std::tuple<>>;
- using TypeParamInquiries =
- std::conditional_t<KIND == TypeParamInquiry::Result::kind,
- std::tuple<TypeParamInquiry>, std::tuple<>>;
- using DescriptorInquiries =
- std::conditional_t<KIND == DescriptorInquiry::Result::kind,
- std::tuple<DescriptorInquiry>, std::tuple<>>;
+ using Indices = std::tuple<ImpliedDoIndex>;
+ using TypeParamInquiries = std::tuple<TypeParamInquiry>;
+ using DescriptorInquiries = std::tuple<DescriptorInquiry>;
using Others = std::tuple<Constant<Result>, ArrayConstructor<Result>,
Designator<Result>, FunctionRef<Result>>;
@@ -595,13 +664,23 @@ class Expr<Type<TypeCategory::Integer, KIND>>
u;
};
-template <int KIND>
-class Expr<Type<TypeCategory::Unsigned, KIND>>
- : public ExpressionBase<Type<TypeCategory::Unsigned, KIND>> {
+template <>
+class Expr<Type<TypeCategory::Unsigned>>
+ : public ExpressionBase<Type<TypeCategory::Unsigned>> {
public:
- using Result = Type<TypeCategory::Unsigned, KIND>;
+ using Result = Type<TypeCategory::Unsigned>;
EVALUATE_UNION_CLASS_BOILERPLATE(Expr)
+ explicit Expr(int n) : Expr(static_cast<long long>(n)) {}
+ explicit Expr(unsigned n) : Expr(static_cast<unsigned long long>(n)) {}
+ explicit Expr(long n) : Expr(static_cast<long long>(n)) {}
+ explicit Expr(unsigned long n) : Expr(static_cast<unsigned long long>(n)) {}
+ explicit Expr(long long n)
+ : u{Constant<Result>{typename Result::Scalar{n, subscriptIntegerKind},
+ Result{subscriptIntegerKind}}} {}
+ explicit Expr(unsigned long long n)
+ : u{Constant<Result>{typename Result::Scalar{n, subscriptIntegerKind},
+ Result{subscriptIntegerKind}}} {}
private:
using Conversions = std::tuple<Convert<Result, TypeCategory::Integer>,
@@ -618,11 +697,11 @@ class Expr<Type<TypeCategory::Unsigned, KIND>>
u;
};
-template <int KIND>
-class Expr<Type<TypeCategory::Real, KIND>>
- : public ExpressionBase<Type<TypeCategory::Real, KIND>> {
+template <>
+class Expr<Type<TypeCategory::Real>>
+ : public ExpressionBase<Type<TypeCategory::Real>> {
public:
- using Result = Type<TypeCategory::Real, KIND>;
+ using Result = Type<TypeCategory::Real>;
EVALUATE_UNION_CLASS_BOILERPLATE(Expr)
explicit Expr(const Scalar<Result> &x) : u{Constant<Result>{x}} {}
@@ -633,7 +712,7 @@ class Expr<Type<TypeCategory::Real, KIND>>
using Conversions = std::variant<Convert<Result, TypeCategory::Integer>,
Convert<Result, TypeCategory::Real>,
Convert<Result, TypeCategory::Unsigned>>;
- using Operations = std::variant<ComplexComponent<KIND>, Parentheses<Result>,
+ using Operations = std::variant<ComplexComponent, Parentheses<Result>,
Negate<Result>, Add<Result>, Subtract<Result>, Multiply<Result>,
Divide<Result>, Power<Result>, RealToIntPower<Result>, Extremum<Result>,
ConditionalExpr<Result>>;
@@ -644,17 +723,17 @@ class Expr<Type<TypeCategory::Real, KIND>>
common::CombineVariants<Operations, Conversions, Others> u;
};
-template <int KIND>
-class Expr<Type<TypeCategory::Complex, KIND>>
- : public ExpressionBase<Type<TypeCategory::Complex, KIND>> {
+template <>
+class Expr<Type<TypeCategory::Complex>>
+ : public ExpressionBase<Type<TypeCategory::Complex>> {
public:
- using Result = Type<TypeCategory::Complex, KIND>;
+ using Result = Type<TypeCategory::Complex>;
EVALUATE_UNION_CLASS_BOILERPLATE(Expr)
explicit Expr(const Scalar<Result> &x) : u{Constant<Result>{x}} {}
using Operations = std::variant<Parentheses<Result>, Negate<Result>,
Convert<Result, TypeCategory::Complex>, Add<Result>, Subtract<Result>,
Multiply<Result>, Divide<Result>, Power<Result>, RealToIntPower<Result>,
- ComplexConstructor<KIND>, ConditionalExpr<Result>>;
+ ComplexConstructor, ConditionalExpr<Result>>;
using Others = std::variant<Constant<Result>, ArrayConstructor<Result>,
Designator<Result>, FunctionRef<Result>>;
@@ -667,11 +746,11 @@ FOR_EACH_UNSIGNED_KIND(extern template class Expr, )
FOR_EACH_REAL_KIND(extern template class Expr, )
FOR_EACH_COMPLEX_KIND(extern template class Expr, )
-template <int KIND>
-class Expr<Type<TypeCategory::Character, KIND>>
- : public ExpressionBase<Type<TypeCategory::Character, KIND>> {
+template <>
+class Expr<Type<TypeCategory::Character>>
+ : public ExpressionBase<Type<TypeCategory::Character>> {
public:
- using Result = Type<TypeCategory::Character, KIND>;
+ using Result = Type<TypeCategory::Character>;
EVALUATE_UNION_CLASS_BOILERPLATE(Expr)
explicit Expr(const Scalar<Result> &x) : u{Constant<Result>{x}} {}
explicit Expr(Scalar<Result> &&x) : u{Constant<Result>{std::move(x)}} {}
@@ -679,8 +758,8 @@ class Expr<Type<TypeCategory::Character, KIND>>
std::optional<Expr<SubscriptInteger>> LEN() const;
std::variant<Constant<Result>, ArrayConstructor<Result>, Designator<Result>,
- FunctionRef<Result>, Parentheses<Result>, Convert<Result>, Concat<KIND>,
- Extremum<Result>, SetLength<KIND>, ConditionalExpr<Result>>
+ FunctionRef<Result>, Parentheses<Result>, Convert<Result>, Concat,
+ Extremum<Result>, SetLength, ConditionalExpr<Result>>
u;
};
@@ -691,7 +770,7 @@ FOR_EACH_CHARACTER_KIND(extern template class Expr, )
// categories and kinds of comparable operands.
// Fortran defines a numeric relation with distinct types or kinds as
// first undergoing the same operand conversions that occur with the intrinsic
-// addition operator. Character relations must have the same kind.
+// addition operator. CharacterValue relations must have the same kind.
// There are no relations between LOGICAL values.
template <typename T>
@@ -711,6 +790,10 @@ class Relational : public Operation<Relational<T>, LogicalResult, T, T> {
: Base{a, b}, opr{r} {}
Relational(RelationalOperator r, Expr<Operand> &&a, Expr<Operand> &&b)
: Base{std::move(a), std::move(b)}, opr{r} {}
+ // A relation's result is always LogicalResult, independent of operand kind.
+ static constexpr std::optional<DynamicType> GetType() {
+ return DynamicType{TypeCategory::Logical, logicalResultKind};
+ }
bool operator==(const Relational &) const;
RelationalOperator opr;
};
@@ -722,7 +805,9 @@ template <> class Relational<SomeType> {
public:
using Result = LogicalResult;
EVALUATE_UNION_CLASS_BOILERPLATE(Relational)
- static constexpr DynamicType GetType() { return Result::GetType(); }
+ static constexpr DynamicType GetType() {
+ return DynamicType{TypeCategory::Logical, logicalResultKind};
+ }
int Rank() const {
return common::visit([](const auto &x) { return x.Rank(); }, u);
}
@@ -741,20 +826,19 @@ extern template class Relational<SomeType>;
// do not include Relational<> operations as possibilities,
// since the results of Relationals are always LogicalResult
// (kind=4).
-template <int KIND>
-class Expr<Type<TypeCategory::Logical, KIND>>
- : public ExpressionBase<Type<TypeCategory::Logical, KIND>> {
+template <>
+class Expr<Type<TypeCategory::Logical>>
+ : public ExpressionBase<Type<TypeCategory::Logical>> {
public:
- using Result = Type<TypeCategory::Logical, KIND>;
+ using Result = Type<TypeCategory::Logical>;
EVALUATE_UNION_CLASS_BOILERPLATE(Expr)
explicit Expr(const Scalar<Result> &x) : u{Constant<Result>{x}} {}
- explicit Expr(bool x) : u{Constant<Result>{x}} {}
+ explicit Expr(bool x) : u{Constant<Result>{x, Result{logicalResultKind}}} {}
private:
- using Operations = std::tuple<Convert<Result>, Parentheses<Result>, Not<KIND>,
- LogicalOperation<KIND>, ConditionalExpr<Result>>;
- using Relations = std::conditional_t<KIND == LogicalResult::kind,
- std::tuple<Relational<SomeType>>, std::tuple<>>;
+ using Operations = std::tuple<Convert<Result>, Parentheses<Result>, Not,
+ LogicalOperation, ConditionalExpr<Result>>;
+ using Relations = std::tuple<Relational<SomeType>>;
using Others = std::tuple<Constant<Result>, ArrayConstructor<Result>,
Designator<Result>, FunctionRef<Result>>;
@@ -891,21 +975,18 @@ template <> class Expr<SomeType> : public ExpressionBase<SomeType> {
// its destructor is externalized to reduce redundant default instances.
~Expr();
- template <TypeCategory CAT, int KIND>
- explicit Expr(const Expr<Type<CAT, KIND>> &x) : u{Expr<SomeKind<CAT>>{x}} {}
+ template <TypeCategory CAT>
+ explicit Expr(const Expr<Type<CAT>> &x) : u{Expr<SomeKind<CAT>>{x}} {}
- template <TypeCategory CAT, int KIND>
- explicit Expr(Expr<Type<CAT, KIND>> &&x)
- : u{Expr<SomeKind<CAT>>{std::move(x)}} {}
+ template <TypeCategory CAT>
+ explicit Expr(Expr<Type<CAT>> &&x) : u{Expr<SomeKind<CAT>>{std::move(x)}} {}
- template <TypeCategory CAT, int KIND>
- Expr &operator=(const Expr<Type<CAT, KIND>> &x) {
+ template <TypeCategory CAT> Expr &operator=(const Expr<Type<CAT>> &x) {
u = Expr<SomeKind<CAT>>{x};
return *this;
}
- template <TypeCategory CAT, int KIND>
- Expr &operator=(Expr<Type<CAT, KIND>> &&x) {
+ template <TypeCategory CAT> Expr &operator=(Expr<Type<CAT>> &&x) {
u = Expr<SomeKind<CAT>>{std::move(x)};
return *this;
}
diff --git a/flang/include/flang/Evaluate/fold-designator.h b/flang/include/flang/Evaluate/fold-designator.h
index 9622d2661d3f4..eb329208744df 100644
--- a/flang/include/flang/Evaluate/fold-designator.h
+++ b/flang/include/flang/Evaluate/fold-designator.h
@@ -114,13 +114,13 @@ class DesignatorFolder {
return common::visit(
[&](const auto &x) { return FoldDesignator(x, which); }, designator.u);
}
- template <int KIND>
std::optional<OffsetSymbol> FoldDesignator(
- const Designator<Type<TypeCategory::Character, KIND>> &designator,
+ const Designator<Type<TypeCategory::Character>> &designator,
ConstantSubscript which) {
+ const int KIND{designator.GetType().value().kind()};
return common::visit(
common::visitors{
- [&](const Substring &ss) {
+ [&, KIND](const Substring &ss) {
if (const auto *dataRef{ss.GetParentIf<DataRef>()}) {
if (auto result{FoldDesignator(*dataRef, which)}) {
if (auto start{ToInt64(ss.lower())}) {
diff --git a/flang/include/flang/Evaluate/fold.h b/flang/include/flang/Evaluate/fold.h
index df43489aa679c..4982192718318 100644
--- a/flang/include/flang/Evaluate/fold.h
+++ b/flang/include/flang/Evaluate/fold.h
@@ -79,21 +79,17 @@ constexpr auto GetScalarConstantValue(const EXPR &expr)
// When an expression is a constant integer, ToInt64() extracts its value.
// Ensure that the expression has been folded beforehand when folding might
// be required.
-template <int KIND>
-constexpr std::optional<std::int64_t> ToInt64(
- const Expr<Type<TypeCategory::Integer, KIND>> &expr) {
- if (auto scalar{
- GetScalarConstantValue<Type<TypeCategory::Integer, KIND>>(expr)}) {
+inline std::optional<std::int64_t> ToInt64(
+ const Expr<Type<TypeCategory::Integer>> &expr) {
+ if (auto scalar{GetScalarConstantValue<Type<TypeCategory::Integer>>(expr)}) {
return scalar->ToInt64();
} else {
return std::nullopt;
}
}
-template <int KIND>
-constexpr std::optional<std::int64_t> ToInt64(
- const Expr<Type<TypeCategory::Unsigned, KIND>> &expr) {
- if (auto scalar{
- GetScalarConstantValue<Type<TypeCategory::Unsigned, KIND>>(expr)}) {
+inline std::optional<std::int64_t> ToInt64(
+ const Expr<Type<TypeCategory::Unsigned>> &expr) {
+ if (auto scalar{GetScalarConstantValue<Type<TypeCategory::Unsigned>>(expr)}) {
return scalar->ToInt64();
} else {
return std::nullopt;
diff --git a/flang/include/flang/Evaluate/initial-image.h b/flang/include/flang/Evaluate/initial-image.h
index 9a767db95f6c6..04cca92689439 100644
--- a/flang/include/flang/Evaluate/initial-image.h
+++ b/flang/include/flang/Evaluate/initial-image.h
@@ -14,6 +14,7 @@
// initializer for a symbol.
#include "expression.h"
+#include <cstring>
#include <map>
#include <optional>
#include <vector>
@@ -56,21 +57,24 @@ class InitialImage {
return OkNoChange;
} else {
// TODO endianness
- auto *to{&data_.at(offset)};
- const auto *from{&x.values().at(0)};
- if (std::memcmp(to, from, bytes) == 0) {
- return OkNoChange;
- } else {
- std::memcpy(to, from, bytes);
- return Ok;
+ auto strideBytes{static_cast<std::size_t>(*elementBytes)};
+ Result result{OkNoChange};
+ auto at{x.lbounds()};
+ for (std::size_t j{0}; j < x.values().size();
+ ++j, x.IncrementSubscripts(at)) {
+ auto *to{&data_.at(offset + j * strideBytes)};
+ const auto &scalar{x.At(at)};
+ if (scalar.StoreRawBytes(to, strideBytes)) {
+ result = Ok;
+ }
}
+ return result;
}
}
}
- template <int KIND>
Result Add(ConstantSubscript offset, std::size_t bytes,
- const Constant<Type<TypeCategory::Character, KIND>> &x,
- FoldingContext &) {
+ const Constant<Type<TypeCategory::Character>> &x, FoldingContext &) {
+ const int KIND{x.GetType().kind()};
if (offset < 0 || offset + bytes > data_.size()) {
return OutOfRange;
} else {
diff --git a/flang/include/flang/Evaluate/integer-value.h b/flang/include/flang/Evaluate/integer-value.h
new file mode 100644
index 0000000000000..4332e4cf22a91
--- /dev/null
+++ b/flang/include/flang/Evaluate/integer-value.h
@@ -0,0 +1,280 @@
+//===-- include/flang/Evaluate/integer-value.h ------------------*- C++ -*-===//
+//
+// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
+// See https://llvm.org/LICENSE.txt for license information.
+// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
+//
+//===----------------------------------------------------------------------===//
+
+#ifndef FORTRAN_EVALUATE_INTEGER_VALUE_H_
+#define FORTRAN_EVALUATE_INTEGER_VALUE_H_
+
+// Emulates binary integers of an arbitrary (but fixed) bit size for use
+// when the host C++ environment does not support that size or when the
+// full suite of Fortran's integer intrinsic scalar functions are needed.
+// The data model is typeless, so signed* and unsigned operations
+// are distinguished from each other with distinct member function interfaces.
+// (*"Signed" here means two's-complement, just to be clear. Ones'-complement
+// and signed-magnitude encodings appear to be extinct in 2018.)
+
+#include "flang/Evaluate/common.h"
+#include "llvm/ADT/APInt.h"
+#include <cstdint>
+#include <type_traits>
+
+// Some environments, viz. glibc 2.17 and *BSD, allow the macro HUGE
+// to leak out of <math.h>.
+#undef HUGE
+
+namespace Fortran::evaluate::value {
+
+// Detects the runtime-kind integer facade (which exposes toAPInt()) vs. a raw
+// fixed-width value::Integer.
+template <typename, typename = void> struct HasWord : std::false_type {};
+template <typename T>
+struct HasWord<T, std::void_t<decltype(std::declval<const T &>().toAPInt())>>
+ : std::true_type {};
+
+// ----------------------------------------------------------------------------
+// IntegerValue: runtime-kind two's-complement integer (also used for UNSIGNED).
+// ----------------------------------------------------------------------------
+class IntegerValue {
+public:
+ // The value is held as a single arbitrary-precision integer; its bit width is
+ // the runtime kind's width (8/16/32/64/80/128). A zero-width APInt
+ // (APInt::getZeroWidth()) models the former monostate: a default-initialized
+ // value of as-yet-unknown width.
+ using Storage = llvm::APInt;
+
+ // These result aggregates hold IntegerValue members by value, so they cannot
+ // be defined until IntegerValue itself is a complete type. Forward-declare
+ // them here (member declarations may return an incomplete type) and define
+ // them immediately after the class below.
+ struct ValueWithOverflow;
+ struct ValueWithCarry;
+ struct Product;
+ struct QuotientWithRemainder;
+ struct PowerWithErrors;
+
+ // Constructors
+ IntegerValue() {}
+ IntegerValue(const IntegerValue &) = default;
+ IntegerValue(IntegerValue &&) = default;
+ IntegerValue &operator=(const IntegerValue &) = default;
+ IntegerValue &operator=(IntegerValue &&) = default;
+
+ // PAPAYA: Replace with IntegerValue(std::uint64_t, int kind, bool isSigned);
+ // Don't rely on the signedness of the type; int128_t also not supported
+ template <typename INT, typename = std::enable_if_t<std::is_integral_v<INT>>>
+ IntegerValue(INT n, int kind) {
+ // PAPAYA: assert(n <= UINT64_MAX);
+ // The runtime kind is carried by the APInt's bit width. A signed host
+ // value is sign-extended, an unsigned one zero-extended, then silently
+ // truncated to the requested width (matching value::Integer's integral
+ // constructor; implicitTrunc avoids APInt's "does not fit" assertion).
+ storage_ = llvm::APInt(BitsForKind(kind), static_cast<std::uint64_t>(n),
+ std::is_signed_v<INT>,
+ /*implicitTrunc=*/true);
+ }
+
+ // Comparison operators
+ bool operator==(const IntegerValue &y) const;
+ bool operator!=(const IntegerValue &y) const { return !(*this == y); }
+ bool operator<(const IntegerValue &y) const {
+ return CompareSigned(y) == Ordering::Less;
+ }
+ bool operator>(const IntegerValue &y) const { return y < *this; }
+ bool operator<=(const IntegerValue &y) const { return !(y < *this); }
+ bool operator>=(const IntegerValue &y) const { return !(*this < y); }
+
+ // Left-justified mask (e.g., MASKL(1) has only its sign bit set)
+ static IntegerValue MASKL(int places, int kind);
+ // Right-justified mask (e.g., MASKR(1) == 1, MASKR(2) == 3, &c.)
+ static IntegerValue MASKR(int places, int kind);
+ static IntegerValue HUGE(int kind);
+ static IntegerValue Least(int kind);
+
+ // Decimal exponent range, formerly a compile-time constant; now selected by
+ // the runtime kind (1/2/4/8/16).
+ static int RANGE(int kind);
+ static int UnsignedRANGE(int kind);
+ // Binary digits excluding the sign bit (== bits - 1).
+ static int DIGITS(int kind) { return 8 * kind - 1; }
+
+ // Runtime kind / width accessors
+ int kind() const;
+ int bits() const;
+ // A zero-width APInt is never a real value (every Fortran integer kind has a
+ // positive width), so it uniquely marks the default-initialized state.
+ bool IsMonostate() const { return storage_.getBitWidth() == 0; }
+ bool IsZero() const;
+ bool IsNegative() const;
+ bool StoreRawBytes(void *to, int kind) const;
+ static IntegerValue FromRawBytes(const void *raw, int kind);
+ static IntegerValue Zero(int kind);
+
+ // Raw access to the underlying arbitrary-precision value (precondition: not
+ // monostate). Used by RealValue/ComplexValue to bridge to llvm::APFloat.
+ const llvm::APInt &toAPInt() const { return ap(); }
+ static IntegerValue FromAPInt(const llvm::APInt &i) { return Wrap(i); }
+
+ std::uint64_t ToUInt64() const;
+ std::int64_t ToInt64() const;
+ std::uint64_t ToUInt() const;
+
+ template <typename SINT = std::int64_t> SINT ToSInt() const {
+ if (IsMonostate()) {
+ return 0;
+ }
+ return static_cast<SINT>(ap().getRawData()[0]);
+ }
+
+ // Signed/unsigned comparisons
+ Ordering CompareSigned(const IntegerValue &y) const;
+ Ordering CompareUnsigned(const IntegerValue &y) const;
+ Ordering CompareToZeroSigned() const;
+ bool BGE(const IntegerValue &y) const;
+ bool BGT(const IntegerValue &y) const;
+ bool BLE(const IntegerValue &y) const;
+ bool BLT(const IntegerValue &y) const;
+
+ // Arithmetic
+ ValueWithOverflow Negate() const;
+ ValueWithOverflow ABS() const;
+
+ ValueWithCarry AddUnsigned(const IntegerValue &y, bool carryIn = false) const;
+ ValueWithOverflow AddSigned(const IntegerValue &y) const;
+ ValueWithOverflow SubtractSigned(const IntegerValue &y) const;
+ ValueWithOverflow AddUnsignedToOverflow(const IntegerValue &y) const;
+ ValueWithOverflow DIM(const IntegerValue &y) const;
+ ValueWithOverflow SIGN(const IntegerValue &sign) const;
+
+ Product MultiplySigned(const IntegerValue &y) const;
+ Product MultiplyUnsigned(const IntegerValue &y) const;
+ QuotientWithRemainder DivideSigned(const IntegerValue &y) const;
+ QuotientWithRemainder DivideUnsigned(const IntegerValue &y) const;
+ ValueWithOverflow MODULO(const IntegerValue &y) const;
+ PowerWithErrors Power(const IntegerValue &e) const;
+
+ // Bitwise operations
+ IntegerValue NOT() const;
+ IntegerValue IAND(const IntegerValue &y) const;
+ IntegerValue IOR(const IntegerValue &y) const;
+ IntegerValue IEOR(const IntegerValue &y) const;
+ IntegerValue MERGE_BITS(
+ const IntegerValue &y, const IntegerValue &mask) const;
+ IntegerValue MAX(const IntegerValue &y) const {
+ return CompareSigned(y) == Ordering::Less ? y : *this;
+ }
+ IntegerValue MIN(const IntegerValue &y) const {
+ return CompareSigned(y) == Ordering::Less ? *this : y;
+ }
+
+ // Shift operations
+ IntegerValue ISHFT(int count) const;
+ IntegerValue SHIFTL(int count) const;
+ IntegerValue SHIFTR(int count) const;
+ IntegerValue SHIFTA(int count) const;
+ IntegerValue ISHFTC(int count, int size = 0) const;
+ IntegerValue IBITS(int pos, int size) const;
+ IntegerValue IBSET(int pos) const;
+ IntegerValue IBCLR(int pos) const;
+ IntegerValue DSHIFTL(const IntegerValue &fill, int count) const;
+ IntegerValue DSHIFTR(const IntegerValue &v2, int count) const;
+ bool BTEST(int pos) const;
+ int LEADZ() const;
+ int TRAILZ() const;
+ int POPCNT() const;
+ bool POPPAR() const;
+
+ // Returns this value re-interpreted with a different kind (sign-preserving).
+ IntegerValue ConvertToKind(int kind) const;
+
+ // The destination kind is no longer a compile-time property, so the target
+ // width (in bits, e.g. 8 * TO::kind) is supplied by the caller.
+ // Definitions appear after the class, where ValueWithOverflow is complete.
+ static ValueWithOverflow ConvertSigned(const IntegerValue &from, int toBits);
+
+ static ValueWithOverflow ConvertUnsigned(
+ const IntegerValue &from, int toBits);
+
+ // The result kind is no longer a compile-time property, so the caller
+ // supplies the target width (in bits, e.g. 8 * T::kind). The literal is
+ // read directly into that fixed-width alternative so both the stored kind
+ // and the overflow flag are correct for the target kind.
+ static ValueWithOverflow Read(
+ const char *&pp, int base, bool isSigned, int toBits);
+
+ // Formatting
+ std::string SignedDecimal() const;
+ std::string UnsignedDecimal() const;
+ std::string Hexadecimal() const;
+
+private:
+ // Wraps an APInt result back into the facade.
+ static IntegerValue Wrap(const llvm::APInt &i) {
+ IntegerValue r;
+ r.storage_ = i;
+ return r;
+ }
+
+ // The active arbitrary-precision value (precondition: not monostate).
+ const llvm::APInt &ap() const { return storage_; }
+ unsigned width() const { return ap().getBitWidth(); }
+
+ // y converted (sign-preserving) to this value's width, so that binary
+ // operations operate on operands of equal width. A monostate operand is
+ // treated as a zero of this width.
+ llvm::APInt coerce(const IntegerValue &y) const {
+ if (y.IsMonostate()) {
+ return llvm::APInt(width(), 0);
+ }
+ return y.ap().sextOrTrunc(width());
+ }
+
+ // Maps a Fortran integer kind (1/2/4/8/10/16) to its bit width.
+ static unsigned BitsForKind(int kind);
+
+ // Double shifts with explicit fill, used by DSHIFTL/DSHIFTR.
+ IntegerValue ShiftLWithFill(const IntegerValue &fill, int count) const;
+ IntegerValue ShiftRWithFill(const IntegerValue &fill, int count) const;
+
+ // Core width conversion on an APInt source.
+ // Definitions appear after the class, where ValueWithOverflow is complete.
+ static ValueWithOverflow ConvertAP(
+ const llvm::APInt &src, int toBits, bool isSigned);
+
+public: // PAPAYA: make private
+ Storage storage_{llvm::APInt::getZeroWidth()};
+};
+
+// Out-of-class definitions of the result aggregates (IntegerValue is now a
+// complete type, so it may appear as a by-value member).
+struct IntegerValue::ValueWithOverflow {
+ IntegerValue value;
+ bool overflow{false};
+};
+struct IntegerValue::ValueWithCarry {
+ IntegerValue value;
+ bool carry{false};
+};
+struct IntegerValue::Product {
+ IntegerValue upper, lower;
+ bool SignedMultiplicationOverflowed() const { return overflow; }
+ bool overflow{false};
+};
+struct IntegerValue::QuotientWithRemainder {
+ IntegerValue quotient, remainder;
+ bool divisionByZero{false}, overflow{false};
+};
+struct IntegerValue::PowerWithErrors {
+ IntegerValue power;
+ bool divisionByZero{false}, overflow{false}, zeroToZero{false};
+};
+
+// ConvertAP is defined out-of-line in integer-value.cpp (now that
+// ValueWithOverflow is complete its declaration in the private section is
+// sufficient here).
+
+} // namespace Fortran::evaluate::value
+#endif // FORTRAN_EVALUATE_INTEGER_VALUE_H_
diff --git a/flang/include/flang/Evaluate/integer.h b/flang/include/flang/Evaluate/integer.h
index 5953fc81cb111..3347a89ab4015 100644
--- a/flang/include/flang/Evaluate/integer.h
+++ b/flang/include/flang/Evaluate/integer.h
@@ -9,13 +9,8 @@
#ifndef FORTRAN_EVALUATE_INTEGER_H_
#define FORTRAN_EVALUATE_INTEGER_H_
-// Emulates binary integers of an arbitrary (but fixed) bit size for use
-// when the host C++ environment does not support that size or when the
-// full suite of Fortran's integer intrinsic scalar functions are needed.
-// The data model is typeless, so signed* and unsigned operations
-// are distinguished from each other with distinct member function interfaces.
-// (*"Signed" here means two's-complement, just to be clear. Ones'-complement
-// and signed-magnitude encodings appear to be extinct in 2018.)
+// Fixed-width binary integer template used internally by RealValue and related
+// code. Prefer IntegerValue for new code.
#include "flang/Common/bit-population-count.h"
#include "flang/Common/leading-zero-bit-count.h"
@@ -1066,5 +1061,6 @@ using X87IntegerContainer =
extern template class Integer<80, isHostLittleEndian, 16, std::uint16_t,
std::uint32_t, 128>;
extern template class Integer<128>;
+
} // namespace Fortran::evaluate::value
#endif // FORTRAN_EVALUATE_INTEGER_H_
diff --git a/flang/include/flang/Evaluate/logical-value.h b/flang/include/flang/Evaluate/logical-value.h
new file mode 100644
index 0000000000000..1b68ee3f9cdf5
--- /dev/null
+++ b/flang/include/flang/Evaluate/logical-value.h
@@ -0,0 +1,97 @@
+//===-- include/flang/Evaluate/logical-value.h ------------------*- C++ -*-===//
+//
+// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
+// See https://llvm.org/LICENSE.txt for license information.
+// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
+//
+//===----------------------------------------------------------------------===//
+
+#ifndef FORTRAN_EVALUATE_LOGICAL_VALUE_H_
+#define FORTRAN_EVALUATE_LOGICAL_VALUE_H_
+
+#include "integer-value.h"
+#include <utility>
+
+namespace Fortran::evaluate::value {
+
+// ----------------------------------------------------------------------------
+// LogicalValue: runtime-kind logical.
+// ----------------------------------------------------------------------------
+class LogicalValue {
+public:
+ // Raw bit pattern of the value, held as the runtime-kind integer facade.
+ using Word = IntegerValue;
+ // The value is held as a single IntegerValue whose bit width is the logical
+ // kind's width (8/16/32/64 for kinds 1/2/4/8), preserving the kind's raw bit
+ // representation for word()/TRANSFER. Its 1-bit monostate (inherited from
+ // IntegerValue) models the former monostate. All supported logical kinds use
+ // C's representation (.TRUE. == 1, .FALSE. == 0), so any non-zero word is
+ // .TRUE.
+ using Storage = IntegerValue;
+
+ LogicalValue() : storage_(0, 4) {} // kind-4 .FALSE.
+ LogicalValue(const LogicalValue &) = default;
+ LogicalValue(LogicalValue &&) = default;
+ LogicalValue &operator=(const LogicalValue &) = default;
+ LogicalValue &operator=(LogicalValue &&) = default;
+
+ // The default kind (4) is used when no runtime kind is supplied.
+ LogicalValue(bool truth, int kind = 4) : storage_(truth ? 1 : 0, kind) {}
+ // Interpret w as the raw bit pattern of a logical of the given runtime kind.
+ LogicalValue(const Word &w, int kind);
+
+ // Comparison operators
+ bool operator==(const LogicalValue &y) const {
+ return IsTrue() == y.IsTrue();
+ }
+ bool operator!=(const LogicalValue &y) const {
+ return IsTrue() != y.IsTrue();
+ }
+ bool operator<(const LogicalValue &y) const {
+ return !IsTrue() && y.IsTrue();
+ }
+ bool operator>(const LogicalValue &y) const { return y < *this; }
+ bool operator<=(const LogicalValue &y) const { return !(y < *this); }
+ bool operator>=(const LogicalValue &y) const { return !(*this < y); }
+
+ // Runtime kind / width accessors
+ int kind() const;
+ int bits() const;
+ // IntegerValue's 1-bit monostate marks the default-initialized state.
+ bool IsMonostate() const { return storage_.IsMonostate(); }
+ bool IsZero() const;
+ bool IsTrue() const;
+ bool IsCanonical() const;
+ bool StoreRawBytes(void *to, std::size_t bytes) const;
+ static LogicalValue FromRawBytes(const void *raw, std::size_t bytes);
+ static LogicalValue Zero(int kind);
+
+ Word word() const;
+
+ // Logical operations
+ LogicalValue NOT() const;
+ LogicalValue AND(const LogicalValue &y) const;
+ LogicalValue OR(const LogicalValue &y) const;
+ LogicalValue EQV(const LogicalValue &y) const;
+ LogicalValue NEQV(const LogicalValue &y) const;
+ LogicalValue ConvertToKind(int kind) const { return {IsTrue(), kind}; }
+
+private:
+ // Wraps a raw integer word result back into the facade.
+ static LogicalValue Wrap(Word w) {
+ LogicalValue v;
+ v.storage_ = std::move(w);
+ return v;
+ }
+
+ // The canonical .TRUE. word (1) at this value's width.
+ Word One() const { return Word(1, kind()); }
+
+ // Maps a Fortran logical kind (1/2/4/8) to its bit width (8 * kind).
+ static int BitsForKind(int kind);
+
+ Storage storage_;
+};
+
+} // namespace Fortran::evaluate::value
+#endif // FORTRAN_EVALUATE_LOGICAL_VALUE_H_
diff --git a/flang/include/flang/Evaluate/logical.h b/flang/include/flang/Evaluate/logical.h
deleted file mode 100644
index 5996853215e30..0000000000000
--- a/flang/include/flang/Evaluate/logical.h
+++ /dev/null
@@ -1,110 +0,0 @@
-//===-- include/flang/Evaluate/logical.h ------------------------*- C++ -*-===//
-//
-// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
-// See https://llvm.org/LICENSE.txt for license information.
-// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
-//
-//===----------------------------------------------------------------------===//
-
-#ifndef FORTRAN_EVALUATE_LOGICAL_H_
-#define FORTRAN_EVALUATE_LOGICAL_H_
-
-#include "integer.h"
-#include <cinttypes>
-
-namespace Fortran::evaluate::value {
-
-template <int BITS, bool IS_LIKE_C = true> class Logical {
-public:
- static constexpr int bits{BITS};
- using Word = Integer<bits>;
-
- // Module ISO_C_BINDING kind C_BOOL is LOGICAL(KIND=1) and must have
- // C's bit representation (.TRUE. -> 1, .FALSE. -> 0).
- static constexpr bool IsLikeC{BITS <= 8 || IS_LIKE_C};
-
- constexpr Logical() {} // .FALSE.
- template <int B, bool C>
- constexpr Logical(Logical<B, C> x) : word_{Represent(x.IsTrue())} {}
- constexpr Logical(bool truth) : word_{Represent(truth)} {}
- // A raw word, for DATA initialization
- constexpr Logical(Word &&w) : word_{std::move(w)} {}
-
- template <int B, bool C> constexpr Logical &operator=(Logical<B, C> x) {
- word_ = Represent(x.IsTrue());
- return *this;
- }
-
- Word word() const { return word_; }
- bool IsCanonical() const {
- return word_ == canonicalFalse || word_ == canonicalTrue;
- }
-
- // Fortran actually has only .EQV. & .NEQV. relational operations
- // for LOGICAL, but this template class supports more so that
- // it can be used with the STL for sorting and as a key type for
- // std::set<> & std::map<>.
- template <int B, bool C>
- constexpr bool operator<(const Logical<B, C> &that) const {
- return !IsTrue() && that.IsTrue();
- }
- template <int B, bool C>
- constexpr bool operator<=(const Logical<B, C> &) const {
- return !IsTrue();
- }
- template <int B, bool C>
- constexpr bool operator==(const Logical<B, C> &that) const {
- return IsTrue() == that.IsTrue();
- }
- template <int B, bool C>
- constexpr bool operator!=(const Logical<B, C> &that) const {
- return IsTrue() != that.IsTrue();
- }
- template <int B, bool C>
- constexpr bool operator>=(const Logical<B, C> &) const {
- return IsTrue();
- }
- template <int B, bool C>
- constexpr bool operator>(const Logical<B, C> &that) const {
- return IsTrue() && !that.IsTrue();
- }
-
- constexpr bool IsTrue() const {
- if constexpr (IsLikeC) {
- return !word_.IsZero();
- } else {
- return word_.BTEST(0);
- }
- }
-
- constexpr Logical NOT() const { return {word_.IEOR(canonicalTrue)}; }
-
- constexpr Logical AND(const Logical &that) const {
- return {word_.IAND(that.word_)};
- }
-
- constexpr Logical OR(const Logical &that) const {
- return {word_.IOR(that.word_)};
- }
-
- constexpr Logical EQV(const Logical &that) const { return NEQV(that).NOT(); }
-
- constexpr Logical NEQV(const Logical &that) const {
- return {word_.IEOR(that.word_)};
- }
-
-private:
- static constexpr Word canonicalTrue{IsLikeC ? 1 : -std::uint64_t{1}};
- static constexpr Word canonicalFalse{0};
- static constexpr Word Represent(bool x) {
- return x ? canonicalTrue : canonicalFalse;
- }
- Word word_;
-};
-
-extern template class Logical<8>;
-extern template class Logical<16>;
-extern template class Logical<32>;
-extern template class Logical<64>;
-} // namespace Fortran::evaluate::value
-#endif // FORTRAN_EVALUATE_LOGICAL_H_
diff --git a/flang/include/flang/Evaluate/match.h b/flang/include/flang/Evaluate/match.h
index dfbfd1b4b64e3..c579862752ee9 100644
--- a/flang/include/flang/Evaluate/match.h
+++ b/flang/include/flang/Evaluate/match.h
@@ -36,9 +36,9 @@ struct IsOperation<T, std::void_t<decltype(T::operands)>> {
template <typename T>
constexpr bool is_operation_v{detail::IsOperation<T>::value};
-template <common::TypeCategory C, int K>
-const evaluate::Expr<Type<C, K>> &deparen(const evaluate::Expr<Type<C, K>> &x) {
- if (auto *parens{std::get_if<Parentheses<Type<C, K>>>(&x.u)}) {
+template <common::TypeCategory C>
+const evaluate::Expr<Type<C>> &deparen(const evaluate::Expr<Type<C>> &x) {
+ if (auto *parens{std::get_if<Parentheses<Type<C>>>(&x.u)}) {
return deparen(parens->template operand<0>());
} else {
return x;
@@ -189,16 +189,13 @@ OperationPattern(const Ops &..., llvm::type_identity<OpType>)
// only from operand patterns. This will make it usable in AnyOfPattern.
template <common::LogicalOperator Operator, typename ValType, typename... Ops>
struct LogicalOperationPattern
- : public OperationPattern<LogicalOperation<ValType::kind>, Ops...> {
- using Base = OperationPattern<LogicalOperation<ValType::kind>, Ops...>;
+ : public OperationPattern<LogicalOperation, Ops...> {
+ using Base = OperationPattern<LogicalOperation, Ops...>;
static constexpr common::LogicalOperator opCode{Operator};
private:
- template <int K> bool matchOp(const LogicalOperation<K> &op) const {
- if constexpr (ValType::kind == K) {
- return op.logicalOperator == opCode;
- }
- return false;
+ bool matchOp(const LogicalOperation &op) const {
+ return op.logicalOperator == opCode;
}
template <typename U> bool matchOp(const U &) const { return false; }
diff --git a/flang/include/flang/Evaluate/object-sizes.h b/flang/include/flang/Evaluate/object-sizes.h
new file mode 100644
index 0000000000000..2eb13f1f84e2d
--- /dev/null
+++ b/flang/include/flang/Evaluate/object-sizes.h
@@ -0,0 +1,82 @@
+//===-- include/flang/Evaluate/object-sizes.h -------------------*- C++ -*-===//
+//
+// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
+// See https://llvm.org/LICENSE.txt for license information.
+// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
+//
+//===----------------------------------------------------------------------===//
+
+#ifndef FORTRAN_EVALUATE_OBJECT_SIZES_H_
+#define FORTRAN_EVALUATE_OBJECT_SIZES_H_
+
+#include <cstddef>
+
+// Object size/alignment for the opaque facades RealValue / CharacterValue and
+// their variant-backed implementations RealValueImpl / CharacterValueImpl.
+//
+// When not cross-compiling, flang-evaluate-object-size-probe measures these
+// with the very toolchain (and per build configuration) used for the build and
+// emits flang/Evaluate/object-sizes-generated.h into the build tree's include
+// directory. We prefer those measured values whenever that header is available
+// on the include path, regardless of -I ordering. The constants below are the
+// fallback used otherwise -- in particular when cross-compiling, where the
+// probe cannot run on the build host. They are verified against the
+// implementation classes by static_asserts in real-value.cpp and
+// character-value.cpp.
+//
+// The probe itself (object-size-probe.cpp) compiles with
+// FORTRAN_EVALUATE_OBJECT_SIZE_PROBE defined: it generates the header, so it
+// must not depend on it. The dedicated #if branch below omits __has_include so
+// dependency scanners do not record the generated header (probe -> generated
+// header -> probe cycle).
+#if defined(FORTRAN_EVALUATE_OBJECT_SIZE_PROBE)
+
+#error When probing for the object size, must not rely on the default/fallback
+
+#elif __has_include(<flang/Evaluate/object-sizes-generated.h>)
+#include <flang/Evaluate/object-sizes-generated.h>
+#else
+
+namespace Fortran::evaluate::value::detail {
+
+// These fallbacks assume a 64-bit (LP64/LLP64) host, which covers the targets
+// flang is built for (x86_64, AArch64, PowerPC64). The native build measures
+// the real values via object-sizes-generated.h; this is only reached when
+// cross-compiling.
+
+// RealValueImpl is a std::variant over flang's fixed-width value::Real types,
+// whose widest alternative is a 16-byte, 16-byte-aligned Integer<>. Because
+// all the alternatives are PODs, its layout depends on neither the
+// architecture, the C++ standard library, nor its debug/hardening mode: it is
+// 32/16 for gcc, clang and MSVC on x86_64/AArch64/PowerPC, in release as well
+// as in _GLIBCXX_DEBUG, libc++ hardening and MSVC _ITERATOR_DEBUG_LEVEL builds.
+inline constexpr std::size_t kRealObjectSize{32};
+inline constexpr std::size_t kRealObjectAlign{16};
+
+// CharacterValueImpl is a std::variant over std::string / std::u16string /
+// std::u32string, so its size is governed solely by sizeof(std::string). This
+// is determined by the standard library (and its configuration), not the
+// architecture:
+// * libc++: sizeof(std::string)==24 => variant 32
+// * libstdc++: sizeof(std::string)==32 => variant 40 (unchanged by
+// _GLIBCXX_ASSERTIONS or _GLIBCXX_DEBUG)
+// * MSVC STL, release: sizeof(std::string)==32 => variant 40
+// * MSVC STL, debug: _ITERATOR_DEBUG_LEVEL==2 adds a container-proxy
+// pointer
+// => variant 48
+// libc++ hardening modes do not change the layout.
+#if defined(_LIBCPP_VERSION)
+inline constexpr std::size_t kCharacterObjectSize{32};
+#elif defined(_MSC_VER) && \
+ ((defined(_ITERATOR_DEBUG_LEVEL) && _ITERATOR_DEBUG_LEVEL >= 2) || \
+ (!defined(_ITERATOR_DEBUG_LEVEL) && defined(_DEBUG)))
+inline constexpr std::size_t kCharacterObjectSize{48};
+#else
+inline constexpr std::size_t kCharacterObjectSize{40};
+#endif
+inline constexpr std::size_t kCharacterObjectAlign{8};
+
+} // namespace Fortran::evaluate::value::detail
+
+#endif // defined(FORTRAN_EVALUATE_OBJECT_SIZE_PROBE) / __has_include
+#endif // FORTRAN_EVALUATE_OBJECT_SIZES_H_
diff --git a/flang/include/flang/Evaluate/real-value.h b/flang/include/flang/Evaluate/real-value.h
new file mode 100644
index 0000000000000..96f4ca890e383
--- /dev/null
+++ b/flang/include/flang/Evaluate/real-value.h
@@ -0,0 +1,171 @@
+//===-- include/flang/Evaluate/real-value.h ---------------------*- C++ -*-===//
+//
+// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
+// See https://llvm.org/LICENSE.txt for license information.
+// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
+//
+//===----------------------------------------------------------------------===//
+
+#ifndef FORTRAN_EVALUATE_REAL_VALUE_H_
+#define FORTRAN_EVALUATE_REAL_VALUE_H_
+
+#include "flang/Evaluate/integer-value.h"
+#include "flang/Evaluate/object-sizes.h"
+#include "flang/Evaluate/target.h"
+
+// Some environments, viz. glibc 2.17 and *BSD, allow the macro HUGE
+// to leak out of <math.h>.
+#undef HUGE
+
+namespace llvm {
+class raw_ostream;
+}
+
+namespace Fortran::evaluate::value {
+
+class RealValueImpl;
+
+// ----------------------------------------------------------------------------
+// RealValue: runtime-kind IEEE floating-point value.
+// ----------------------------------------------------------------------------
+class RealValue {
+public:
+ using Word = IntegerValue;
+
+ RealValue();
+ RealValue(const RealValue &);
+ RealValue(RealValue &&);
+ ~RealValue();
+ RealValue &operator=(const RealValue &);
+ RealValue &operator=(RealValue &&);
+
+ // Interpret w as the raw bit pattern of a value of the given runtime kind.
+ RealValue(const Word &w, int kind);
+
+ // Comparison operators
+ bool operator==(const RealValue &y) const;
+
+ // Kind-property inquiries, formerly compile-time constants derived from the
+ // PREC template parameter; now selected by the runtime KIND.
+ static int binaryPrecision(int kind);
+ static int isImplicitMSB(int kind);
+ static int DIGITS(int kind);
+ static int PRECISION(int kind);
+ static int RANGE(int kind);
+ static int MAXEXPONENT(int kind);
+ static int MINEXPONENT(int kind);
+
+ static RealValue HUGE(int kind);
+ static RealValue EPSILON(int kind);
+ static RealValue TINY(int kind);
+ static RealValue NotANumber(int kind);
+
+ // Runtime kind / width accessors
+ int kind() const;
+ int bits() const;
+ bool IsMonostate() const;
+ bool IsZero() const;
+ bool IsNegative() const;
+ bool IsNotANumber() const;
+ bool IsQuietNaN() const;
+ bool IsSignalingNaN() const;
+ bool IsInfinite() const;
+ bool IsFinite() const;
+ bool IsNormal() const;
+ int Exponent() const;
+ bool StoreRawBytes(void *to, std::size_t bytes) const;
+ static RealValue FromRawBytes(const void *raw, std::size_t bytes);
+ static RealValue Zero(int kind);
+
+ // The raw bit pattern at the value's runtime width.
+ IntegerValue RawBits() const;
+
+ // Comparisons
+ Relation Compare(const RealValue &y) const;
+
+ // Unary operations
+ RealValue ABS() const;
+ RealValue Negate() const;
+ RealValue SIGN(const RealValue &x) const;
+ RealValue SetSign(bool toNegative) const;
+ RealValue FlushSubnormalToZero() const;
+
+ // Binary arithmetic
+ ValueWithRealFlags<RealValue> Add(const RealValue &y,
+ Rounding rounding = TargetCharacteristics::defaultRounding) const;
+ ValueWithRealFlags<RealValue> Subtract(const RealValue &y,
+ Rounding rounding = TargetCharacteristics::defaultRounding) const;
+ ValueWithRealFlags<RealValue> Multiply(const RealValue &y,
+ Rounding rounding = TargetCharacteristics::defaultRounding) const;
+ ValueWithRealFlags<RealValue> Divide(const RealValue &y,
+ Rounding rounding = TargetCharacteristics::defaultRounding) const;
+ ValueWithRealFlags<RealValue> SQRT(
+ Rounding rounding = TargetCharacteristics::defaultRounding) const;
+ ValueWithRealFlags<RealValue> HYPOT(const RealValue &y,
+ Rounding rounding = TargetCharacteristics::defaultRounding) const;
+ ValueWithRealFlags<RealValue> MOD(const RealValue &y,
+ Rounding rounding = TargetCharacteristics::defaultRounding) const;
+ ValueWithRealFlags<RealValue> MODULO(const RealValue &y,
+ Rounding rounding = TargetCharacteristics::defaultRounding) const;
+ ValueWithRealFlags<RealValue> DIM(const RealValue &y,
+ Rounding rounding = TargetCharacteristics::defaultRounding) const;
+
+ // Convert this value to a different real kind (single rounding).
+ RealValue ConvertToKind(int kind) const { return Convert(*this, kind).value; }
+
+ RealValue FRACTION() const;
+ RealValue RRSPACING() const;
+ RealValue SPACING() const;
+ RealValue SET_EXPONENT(std::int64_t e) const;
+
+ ValueWithRealFlags<RealValue> NEAREST(bool upward) const;
+ ValueWithRealFlags<RealValue> ToWholeNumber(
+ common::RoundingMode mode = common::RoundingMode::ToZero) const;
+ // Convert this real to an integer of the given bit width.
+ ValueWithRealFlags<IntegerValue> ToInteger(
+ common::RoundingMode mode = common::RoundingMode::ToZero,
+ int toBits = 0) const;
+
+ ValueWithRealFlags<RealValue> SCALE(const IntegerValue &by,
+ Rounding rounding = TargetCharacteristics::defaultRounding) const;
+
+ ValueWithRealFlags<RealValue> KahanSummation(const RealValue &y,
+ RealValue &correction,
+ Rounding rounding = TargetCharacteristics::defaultRounding) const;
+
+ IntegerValue EXPONENT() const;
+
+ // Conversion from an integer facade (REAL()).
+ static ValueWithRealFlags<RealValue> FromInteger(const IntegerValue &n,
+ int kind, bool isUnsigned = false,
+ Rounding rounding = TargetCharacteristics::defaultRounding);
+
+ // Conversion between real kinds.
+ static ValueWithRealFlags<RealValue> Convert(const RealValue &from, int kind,
+ Rounding rounding = TargetCharacteristics::defaultRounding);
+
+ static ValueWithRealFlags<RealValue> Read(const char *&pp, int kind,
+ Rounding rounding = TargetCharacteristics::defaultRounding);
+
+ std::string DumpHexadecimal() const;
+ llvm::raw_ostream &AsFortran(
+ llvm::raw_ostream &o, int kind, bool minimal = false) const;
+
+private:
+ alignas(detail::kRealObjectAlign) char opaque_[detail::kRealObjectSize];
+
+ RealValueImpl &impl() { return *reinterpret_cast<RealValueImpl *>(this); }
+ const RealValueImpl &impl() const {
+ return *reinterpret_cast<const RealValueImpl *>(this);
+ }
+
+ static RealValue FromImpl(const RealValueImpl &x);
+ static RealValue FromImpl(RealValueImpl &&x);
+ static ValueWithRealFlags<RealValue> FromImpl(
+ const ValueWithRealFlags<RealValueImpl> &x);
+};
+
+static_assert(sizeof(RealValue) == detail::kRealObjectSize);
+
+} // namespace Fortran::evaluate::value
+#endif // FORTRAN_EVALUATE_REAL_VALUE_H_
diff --git a/flang/include/flang/Evaluate/real.h b/flang/include/flang/Evaluate/real.h
index 391d4e057f134..475c64de72866 100644
--- a/flang/include/flang/Evaluate/real.h
+++ b/flang/include/flang/Evaluate/real.h
@@ -9,14 +9,14 @@
#ifndef FORTRAN_EVALUATE_REAL_H_
#define FORTRAN_EVALUATE_REAL_H_
-#include "formatting.h"
-#include "integer.h"
-#include "rounding-bits.h"
+// Fixed-width IEEE binary floating-point template used internally by RealValue.
+// Prefer RealValue for new code.
+
#include "flang/Common/real.h"
+#include "flang/Evaluate/integer.h"
+#include "flang/Evaluate/rounding-bits.h"
#include "flang/Evaluate/target.h"
-#include <cinttypes>
-#include <limits>
-#include <string>
+#include "llvm/ADT/APFloat.h"
// Some environments, viz. glibc 2.17 and *BSD, allow the macro HUGE
// to leak out of <math.h>.
@@ -25,6 +25,7 @@
namespace llvm {
class raw_ostream;
}
+
namespace Fortran::evaluate::value {
// LOG10(2.)*1E12
@@ -452,6 +453,10 @@ template <typename WORD, int PREC> class Real {
llvm::raw_ostream &, int kind, bool minimal = false) const;
std::string AsFortran(int kind, bool minimal = false) const;
+ template <typename R>
+ friend ValueWithRealFlags<R> FromIntegerValue(
+ const IntegerValue &n, bool isUnsigned, Rounding rounding);
+
private:
using Significand = Integer<significandBits>; // no implicit bit
@@ -515,5 +520,30 @@ extern template class Real<Integer<64>, 53>; // IEEE double
extern template class Real<X87IntegerContainer, 64>; // 80387 extended precision
extern template class Real<Integer<128>, 113>; // IEEE quad
// N.B. No "double-double" support.
+
+// Maps a Fortran REAL kind to its fixed-width backing format and calls f with
+// a prototype value of that type. Defined inline here so that real.cpp can
+// instantiate it.
+template <typename F> static inline auto realWithKind(int kind, F &&f) {
+ using namespace Fortran::evaluate::value;
+ switch (kind) {
+ case 2:
+ return f(Real<Integer<16>, 11>{});
+ case 3:
+ return f(Real<Integer<16>, 8>{});
+ case 4:
+ return f(Real<Integer<32>, 24>{});
+ case 8:
+ return f(Real<Integer<64>, 53>{});
+ case 10:
+ return f(Real<X87IntegerContainer, 64>{});
+ case 16:
+ return f(Real<Integer<128>, 113>{});
+ default:
+ llvm_unreachable("arbitrary bits not yet supported");
+ return f(Real<Integer<64>, 53>{});
+ }
+}
+
} // namespace Fortran::evaluate::value
#endif // FORTRAN_EVALUATE_REAL_H_
diff --git a/flang/include/flang/Evaluate/rewrite.h b/flang/include/flang/Evaluate/rewrite.h
index 50259cc0959f4..085f4d5de09fb 100644
--- a/flang/include/flang/Evaluate/rewrite.h
+++ b/flang/include/flang/Evaluate/rewrite.h
@@ -130,23 +130,37 @@ template <typename Rewriter> struct Mutator {
return D(Mutate(std::move(op.template operand<Is>()))...);
}
+ // A Convert's result kind is a runtime property carried in resultKind_, not
+ // an operand. Reconstructing it from operands alone (as the generic MutateOp
+ // does) would reset resultKind_ to its default of 0, producing an invalid
+ // (kind-0) conversion, so preserve it explicitly here.
+ template <typename TO, common::TypeCategory FROMCAT, size_t... Is>
+ Convert<TO, FROMCAT> MutateOp(
+ Convert<TO, FROMCAT> &&op, std::index_sequence<Is...>) const {
+ const int resultKind{op.resultKind_};
+ Convert<TO, FROMCAT> result(
+ Mutate(std::move(op.template operand<Is>()))...);
+ result.resultKind_ = resultKind;
+ return result;
+ }
+
template <typename T, size_t... Is>
Extremum<T> MutateOp(Extremum<T> &&op, std::index_sequence<Is...>) const {
return Extremum<T>(
op.ordering, Mutate(std::move(op.template operand<Is>()))...);
}
- template <int K, size_t... Is>
- ComplexComponent<K> MutateOp(
- ComplexComponent<K> &&op, std::index_sequence<Is...>) const {
- return ComplexComponent<K>(
+ template <size_t... Is>
+ ComplexComponent MutateOp(
+ ComplexComponent &&op, std::index_sequence<Is...>) const {
+ return ComplexComponent(
op.isImaginaryPart, Mutate(std::move(op.template operand<Is>()))...);
}
- template <int K, size_t... Is>
- LogicalOperation<K> MutateOp(
- LogicalOperation<K> &&op, std::index_sequence<Is...>) const {
- return LogicalOperation<K>(
+ template <size_t... Is>
+ LogicalOperation MutateOp(
+ LogicalOperation &&op, std::index_sequence<Is...>) const {
+ return LogicalOperation(
op.logicalOperator, Mutate(std::move(op.template operand<Is>()))...);
}
diff --git a/flang/include/flang/Evaluate/rounding-bits.h b/flang/include/flang/Evaluate/rounding-bits.h
index c30b0fb703771..615a2fda2978b 100644
--- a/flang/include/flang/Evaluate/rounding-bits.h
+++ b/flang/include/flang/Evaluate/rounding-bits.h
@@ -17,6 +17,8 @@
namespace Fortran::evaluate::value {
+class IntegerValue;
+
class RoundingBits {
public:
constexpr RoundingBits(
@@ -41,6 +43,8 @@ class RoundingBits {
}
}
+ RoundingBits(const IntegerValue &fraction, int rshift);
+
constexpr bool guard() const { return guard_; }
constexpr bool round() const { return round_; }
constexpr bool sticky() const { return sticky_; }
diff --git a/flang/include/flang/Evaluate/shape.h b/flang/include/flang/Evaluate/shape.h
index e5c2d6e8cb63d..703570c5518db 100644
--- a/flang/include/flang/Evaluate/shape.h
+++ b/flang/include/flang/Evaluate/shape.h
@@ -258,7 +258,9 @@ class GetShapeHelper
template <typename T>
MaybeExtentExpr GetArrayConstructorExtent(
const ArrayConstructorValues<T> &values) const {
- ExtentExpr result{0};
+ ExtentExpr result{
+ Constant<ExtentType>{ExtentType::Scalar{0, subscriptIntegerKind},
+ ExtentType{subscriptIntegerKind}}};
for (const auto &value : values) {
if (MaybeExtentExpr n{GetArrayConstructorValueExtent(value)}) {
AccumulateExtent(result, std::move(*n));
diff --git a/flang/include/flang/Evaluate/static-data.h b/flang/include/flang/Evaluate/static-data.h
index 833cc6cc6f3fa..f9cc60a4e574e 100644
--- a/flang/include/flang/Evaluate/static-data.h
+++ b/flang/include/flang/Evaluate/static-data.h
@@ -63,6 +63,7 @@ class StaticDataObject {
StaticDataObject &Push(const std::string &, bool /*ignored*/ = false);
StaticDataObject &Push(const std::u16string &, bool bigEndian = false);
StaticDataObject &Push(const std::u32string &, bool bigEndian = false);
+ StaticDataObject &Push(const value::CharacterValue &, bool bigEndian = false);
std::optional<std::string> AsString() const;
std::optional<std::u16string> AsU16String(bool bigEndian = false) const;
std::optional<std::u32string> AsU32String(bool bigEndian = false) const;
diff --git a/flang/include/flang/Evaluate/tools.h b/flang/include/flang/Evaluate/tools.h
index d2d0b69e6337d..fd00107452444 100644
--- a/flang/include/flang/Evaluate/tools.h
+++ b/flang/include/flang/Evaluate/tools.h
@@ -545,50 +545,66 @@ const Symbol *GetLastPointerSymbol(const evaluate::DataRef &);
// one arbitrary expression to the type of another with ConvertTo(to, from).
template <typename TO, TypeCategory FROMCAT>
-Expr<TO> ConvertToType(Expr<SomeKind<FROMCAT>> &&x) {
+Expr<TO> ConvertToType(int toKind, Expr<SomeKind<FROMCAT>> &&x) {
static_assert(IsSpecificIntrinsicType<TO>);
if constexpr (FROMCAT == TO::category) {
- if (auto *already{std::get_if<Expr<TO>>(&x.u)}) {
- return std::move(*already);
- } else {
- return Expr<TO>{Convert<TO, FROMCAT>{std::move(x)}};
+ // There is a single Expr<TO> alternative for the category now; if it
+ // already has the requested kind no conversion is needed.
+ auto &inner{std::get<Expr<TO>>(x.u)};
+ if (auto fromType{inner.GetType()};
+ fromType && fromType->kind() == toKind) {
+ return std::move(inner);
}
+ Convert<TO, FROMCAT> conv{std::move(x)};
+ conv.resultKind_ = toKind;
+ return Expr<TO>{std::move(conv)};
} else if constexpr (TO::category == TypeCategory::Complex) {
using Part = typename TO::Part;
- Scalar<Part> zero;
- return Expr<TO>{ComplexConstructor<TO::kind>{
- ConvertToType<Part>(std::move(x)), Expr<Part>{Constant<Part>{zero}}}};
+ Scalar<Part> zero{Scalar<Part>::Zero(toKind)};
+ return Expr<TO>{
+ ComplexConstructor{ConvertToType<Part>(toKind, std::move(x)),
+ Expr<Part>{Constant<Part>{zero, Part{toKind}}}}};
} else if constexpr (FROMCAT == TypeCategory::Complex) {
// Extract and convert the real component of a complex value
return common::visit(
[&](auto &&z) {
using ZType = ResultType<decltype(z)>;
using Part = typename ZType::Part;
- return ConvertToType<TO, TypeCategory::Real>(Expr<SomeReal>{
- Expr<Part>{ComplexComponent<Part::kind>{false, std::move(z)}}});
+ return ConvertToType<TO, TypeCategory::Real>(toKind,
+ Expr<SomeReal>{
+ Expr<Part>{ComplexComponent{false, std::move(z)}}});
},
std::move(x.u));
} else {
- return Expr<TO>{Convert<TO, FROMCAT>{std::move(x)}};
+ Convert<TO, FROMCAT> conv{std::move(x)};
+ conv.resultKind_ = toKind;
+ return Expr<TO>{std::move(conv)};
}
}
-template <typename TO, TypeCategory FROMCAT, int FROMKIND>
-Expr<TO> ConvertToType(Expr<Type<FROMCAT, FROMKIND>> &&x) {
- return ConvertToType<TO, FROMCAT>(Expr<SomeKind<FROMCAT>>{std::move(x)});
+template <typename TO, TypeCategory FROMCAT>
+Expr<TO> ConvertToType(int toKind, Expr<Type<FROMCAT>> &&x) {
+ return ConvertToType<TO, FROMCAT>(
+ toKind, Expr<SomeKind<FROMCAT>>{std::move(x)});
}
-template <typename TO> Expr<TO> ConvertToType(BOZLiteralConstant &&x) {
+template <typename TO>
+Expr<TO> ConvertToType(int toKind, BOZLiteralConstant &&x) {
static_assert(IsSpecificIntrinsicType<TO>);
if constexpr (TO::category == TypeCategory::Integer ||
TO::category == TypeCategory::Unsigned) {
- return Expr<TO>{
- Constant<TO>{Scalar<TO>::ConvertUnsigned(std::move(x)).value}};
+ return Expr<TO>{Constant<TO>{
+ Scalar<TO>::ConvertUnsigned(std::move(x), 8 * toKind).value,
+ TO{toKind}}};
} else {
static_assert(TO::category == TypeCategory::Real);
using Word = typename Scalar<TO>::Word;
return Expr<TO>{
- Constant<TO>{Scalar<TO>{Word::ConvertUnsigned(std::move(x)).value}}};
+ Constant<TO>{Scalar<TO>{Word::ConvertUnsigned(std::move(x),
+ Type<TypeCategory::Real>::bits(toKind))
+ .value,
+ toKind},
+ TO{toKind}}};
}
}
@@ -606,10 +622,11 @@ std::optional<Expr<SomeType>> ConvertToType(
const Symbol &, std::optional<Expr<SomeType>> &&);
// Conversions to the type of another expression
-template <TypeCategory TC, int TK, typename FROM>
-common::IfNoLvalue<Expr<Type<TC, TK>>, FROM> ConvertTo(
- const Expr<Type<TC, TK>> &, FROM &&x) {
- return ConvertToType<Type<TC, TK>>(std::move(x));
+template <TypeCategory TC, typename FROM>
+common::IfNoLvalue<Expr<Type<TC>>, FROM> ConvertTo(
+ const Expr<Type<TC>> &to, FROM &&x) {
+ int toKind{to.GetType() ? to.GetType()->kind() : 0};
+ return ConvertToType<Type<TC>>(toKind, std::move(x));
}
template <TypeCategory TC, typename FROM>
@@ -618,8 +635,9 @@ common::IfNoLvalue<Expr<SomeKind<TC>>, FROM> ConvertTo(
return common::visit(
[&](const auto &toKindExpr) {
using KindExpr = std::decay_t<decltype(toKindExpr)>;
+ int toKind{toKindExpr.GetType() ? toKindExpr.GetType()->kind() : 0};
return AsCategoryExpr(
- ConvertToType<ResultType<KindExpr>>(std::move(from)));
+ ConvertToType<ResultType<KindExpr>>(toKind, std::move(from)));
},
to.u);
}
@@ -635,29 +653,13 @@ common::IfNoLvalue<Expr<SomeType>, FROM> ConvertTo(
}
// Convert an expression of some known category to a dynamically chosen
-// kind of some category (usually but not necessarily distinct).
-template <TypeCategory TOCAT, typename VALUE> struct ConvertToKindHelper {
- using Result = std::optional<Expr<SomeKind<TOCAT>>>;
- using Types = CategoryTypes<TOCAT>;
- ConvertToKindHelper(int k, VALUE &&x) : kind{k}, value{std::move(x)} {}
- template <typename T> Result Test() {
- if (kind == T::kind) {
- return std::make_optional(
- AsCategoryExpr(ConvertToType<T>(std::move(value))));
- }
- return std::nullopt;
- }
- int kind;
- VALUE value;
-};
-
+// kind of some category (usually but not necessarily distinct). There is
+// now a single Expr<Type<TOCAT>> alternative per category, so the requested
+// kind is simply carried at runtime by the resulting conversion node.
template <TypeCategory TOCAT, typename VALUE>
common::IfNoLvalue<Expr<SomeKind<TOCAT>>, VALUE> ConvertToKind(
int kind, VALUE &&x) {
- auto result{common::SearchTypes(
- ConvertToKindHelper<TOCAT, VALUE>{kind, std::move(x)})};
- CHECK(result.has_value());
- return *result;
+ return AsCategoryExpr(ConvertToType<Type<TOCAT>>(kind, std::move(x)));
}
// Given a type category CAT, SameKindExprs<CAT, N> is a variant that
@@ -678,25 +680,30 @@ using SameKindExprs =
template <TypeCategory CAT>
SameKindExprs<CAT, 2> AsSameKindExprs(
Expr<SomeKind<CAT>> &&x, Expr<SomeKind<CAT>> &&y) {
- return common::visit(
- [&](auto &&kx, auto &&ky) -> SameKindExprs<CAT, 2> {
- using XTy = ResultType<decltype(kx)>;
- using YTy = ResultType<decltype(ky)>;
- if constexpr (std::is_same_v<XTy, YTy>) {
- return {SameExprs<XTy>{std::move(kx), std::move(ky)}};
- } else if constexpr (XTy::kind < YTy::kind) {
- return {SameExprs<YTy>{ConvertTo(ky, std::move(kx)), std::move(ky)}};
- } else {
- return {SameExprs<XTy>{std::move(kx), ConvertTo(kx, std::move(ky))}};
- }
-#if !__clang__ && 100 * __GNUC__ + __GNUC_MINOR__ == 801
- // Silence a bogus warning about a missing return with G++ 8.1.0.
- // Doesn't execute, but must be correctly typed.
- CHECK(!"can't happen");
- return {SameExprs<XTy>{std::move(kx), std::move(kx)}};
-#endif
- },
- std::move(x.u), std::move(y.u));
+ // There is a single Expr<Type<CAT>> alternative per category; the operands
+ // may still have distinct runtime kinds, so convert the smaller-kind operand
+ // to the kind of the larger one.
+ Expr<Type<CAT>> kx{std::get<Expr<Type<CAT>>>(std::move(x.u))};
+ Expr<Type<CAT>> ky{std::get<Expr<Type<CAT>>>(std::move(y.u))};
+ int xKind{kx.GetType() ? kx.GetType()->kind() : 0};
+ int yKind{ky.GetType() ? ky.GetType()->kind() : 0};
+ if (xKind == yKind) {
+ return {SameExprs<Type<CAT>>{std::move(kx), std::move(ky)}};
+ } else if (xKind < yKind) {
+ // Convert the smaller-kind operand up to the larger one's kind. The
+ // conversion must read ky's runtime kind *before* ky is moved into the
+ // result; the evaluation order of arguments in an aggregate initializer is
+ // unspecified, so do the conversion into a named local first rather than
+ // relying on the order of {ConvertTo(ky, ...), std::move(ky)}. (In the
+ // baseline the target kind was a compile-time template parameter, so a
+ // moved-from operand was harmless; now that the kind is a runtime property
+ // of the operand, reading it after a move yields a bogus kind.)
+ Expr<Type<CAT>> converted{ConvertTo(ky, std::move(kx))};
+ return {SameExprs<Type<CAT>>{std::move(converted), std::move(ky)}};
+ } else {
+ Expr<Type<CAT>> converted{ConvertTo(kx, std::move(ky))};
+ return {SameExprs<Type<CAT>>{std::move(kx), std::move(converted)}};
+ }
}
// Ensure that both operands of an intrinsic REAL operation (or CMPLX()
@@ -791,19 +798,17 @@ Expr<LogicalResult> PackageRelation(
Relational<SomeType>{Relational<T>{opr, std::move(x), std::move(y)}}};
}
-template <int K>
-Expr<Type<TypeCategory::Logical, K>> LogicalNegation(
- Expr<Type<TypeCategory::Logical, K>> &&x) {
- return AsExpr(Not<K>{std::move(x)});
+inline Expr<Type<TypeCategory::Logical>> LogicalNegation(
+ Expr<Type<TypeCategory::Logical>> &&x) {
+ return AsExpr(Not{std::move(x)});
}
Expr<SomeLogical> LogicalNegation(Expr<SomeLogical> &&);
-template <int K>
-Expr<Type<TypeCategory::Logical, K>> BinaryLogicalOperation(LogicalOperator opr,
- Expr<Type<TypeCategory::Logical, K>> &&x,
- Expr<Type<TypeCategory::Logical, K>> &&y) {
- return AsExpr(LogicalOperation<K>{opr, std::move(x), std::move(y)});
+inline Expr<Type<TypeCategory::Logical>> BinaryLogicalOperation(
+ LogicalOperator opr, Expr<Type<TypeCategory::Logical>> &&x,
+ Expr<Type<TypeCategory::Logical>> &&y) {
+ return AsExpr(LogicalOperation{opr, std::move(x), std::move(y)});
}
Expr<SomeLogical> BinaryLogicalOperation(
@@ -814,29 +819,28 @@ Expr<SomeLogical> BinaryLogicalOperation(
// emit any message. Use the more general templates (above) in other
// situations.
-template <TypeCategory C, int K>
-Expr<Type<C, K>> operator-(Expr<Type<C, K>> &&x) {
- return AsExpr(Negate<Type<C, K>>{std::move(x)});
+template <TypeCategory C> Expr<Type<C>> operator-(Expr<Type<C>> &&x) {
+ return AsExpr(Negate<Type<C>>{std::move(x)});
}
-template <TypeCategory C, int K>
-Expr<Type<C, K>> operator+(Expr<Type<C, K>> &&x, Expr<Type<C, K>> &&y) {
- return AsExpr(Combine<Add, Type<C, K>>(std::move(x), std::move(y)));
+template <TypeCategory C>
+Expr<Type<C>> operator+(Expr<Type<C>> &&x, Expr<Type<C>> &&y) {
+ return AsExpr(Combine<Add, Type<C>>(std::move(x), std::move(y)));
}
-template <TypeCategory C, int K>
-Expr<Type<C, K>> operator-(Expr<Type<C, K>> &&x, Expr<Type<C, K>> &&y) {
- return AsExpr(Combine<Subtract, Type<C, K>>(std::move(x), std::move(y)));
+template <TypeCategory C>
+Expr<Type<C>> operator-(Expr<Type<C>> &&x, Expr<Type<C>> &&y) {
+ return AsExpr(Combine<Subtract, Type<C>>(std::move(x), std::move(y)));
}
-template <TypeCategory C, int K>
-Expr<Type<C, K>> operator*(Expr<Type<C, K>> &&x, Expr<Type<C, K>> &&y) {
- return AsExpr(Combine<Multiply, Type<C, K>>(std::move(x), std::move(y)));
+template <TypeCategory C>
+Expr<Type<C>> operator*(Expr<Type<C>> &&x, Expr<Type<C>> &&y) {
+ return AsExpr(Combine<Multiply, Type<C>>(std::move(x), std::move(y)));
}
-template <TypeCategory C, int K>
-Expr<Type<C, K>> operator/(Expr<Type<C, K>> &&x, Expr<Type<C, K>> &&y) {
- return AsExpr(Combine<Divide, Type<C, K>>(std::move(x), std::move(y)));
+template <TypeCategory C>
+Expr<Type<C>> operator/(Expr<Type<C>> &&x, Expr<Type<C>> &&y) {
+ return AsExpr(Combine<Divide, Type<C>>(std::move(x), std::move(y)));
}
template <TypeCategory C> Expr<SomeKind<C>> operator-(Expr<SomeKind<C>> &&x) {
@@ -868,6 +872,14 @@ Expr<SomeKind<CAT>> operator/(
return PromoteAndCombine<Divide, CAT>(std::move(x), std::move(y));
}
+// Detects wrapper representations (e.g. FunctionRef) that can record the
+// runtime result kind explicitly because it cannot always be recovered from
+// the wrapped representation alone.
+template <typename T, typename = void> constexpr bool HasSetResultKind{false};
+template <typename T>
+constexpr bool HasSetResultKind<T,
+ std::void_t<decltype(std::declval<T>().set_resultKind(0))>>{true};
+
// A utility for use with common::SearchTypes to create generic expressions
// when an intrinsic type category for (say) a variable is known
// but the kind parameter value is not.
@@ -880,10 +892,15 @@ struct TypeKindVisitor {
TypeKindVisitor(int k, const VALUE &x) : kind{k}, value{x} {}
template <typename T> Result Test() {
- if (kind == T::kind) {
- return AsGenericExpr(TEMPLATE<T>{std::move(value)});
+ // There is a single Type<CAT> per category now; the runtime kind is
+ // generally carried by the wrapped representation (e.g. its symbol
+ // descriptor). Some wrappers (FunctionRef) cannot always recover it that
+ // way, so record it explicitly when supported.
+ TEMPLATE<T> wrapper{std::move(value)};
+ if constexpr (HasSetResultKind<TEMPLATE<T>>) {
+ wrapper.set_resultKind(kind);
}
- return std::nullopt;
+ return AsGenericExpr(std::move(wrapper));
}
int kind;
@@ -1232,7 +1249,7 @@ class ScalarConstantExpander {
};
// Given a collection of element values, package them as a Constant.
-// If the type is Character or a derived type, take the length or type
+// If the type is CharacterValue or a derived type, take the length or type
// (resp.) from a another Constant.
template <typename T>
Constant<T> PackageConstant(std::vector<Scalar<T>> &&elements,
@@ -1244,7 +1261,18 @@ Constant<T> PackageConstant(std::vector<Scalar<T>> &&elements,
return Constant<T>{reference.GetType().GetDerivedTypeSpec(),
std::move(elements), ConstantSubscripts{shape}};
} else {
- return Constant<T>{std::move(elements), ConstantSubscripts{shape}};
+ // Propagate the reference constant's runtime kind so that an empty result
+ // (which has no element values to source a kind from) still yields a
+ // Constant with a valid kind. The kind of an Integer/Unsigned/Logical
+ // constant is usually carried by its element values rather than its
+ // Result, so consult both (mirroring ConstantBase::GetType()) without
+ // calling GetType(), which would assert on a kind-0 empty reference.
+ int kind{reference.result().runtimeKind()};
+ if (kind == 0 && !reference.empty()) {
+ kind = reference.values().front().kind();
+ }
+ return Constant<T>{std::move(elements), ConstantSubscripts{shape},
+ typename Constant<T>::Result{kind}};
}
}
@@ -1451,7 +1479,7 @@ using OperatorSet = common::EnumSet<Operator, 32>;
std::string ToString(Operator op);
-template <int Kind> Operator OperationCode(const LogicalOperation<Kind> &op) {
+inline Operator OperationCode(const LogicalOperation &op) {
switch (op.logicalOperator) {
case common::LogicalOperator::And:
return Operator::And;
diff --git a/flang/include/flang/Evaluate/type.h b/flang/include/flang/Evaluate/type.h
index e25122d873f2c..35b08c3017d00 100644
--- a/flang/include/flang/Evaluate/type.h
+++ b/flang/include/flang/Evaluate/type.h
@@ -16,12 +16,13 @@
// are suitable for use as template parameters to instantiate other class
// templates, like expressions, over the supported types and kinds.
+#include "character-value.h"
#include "common.h"
-#include "complex.h"
+#include "complex-value.h"
#include "formatting.h"
-#include "integer.h"
-#include "logical.h"
-#include "real.h"
+#include "integer-value.h"
+#include "logical-value.h"
+#include "real-value.h"
#include "flang/Common/idioms.h"
#include "flang/Common/real.h"
#include "flang/Common/template.h"
@@ -53,15 +54,27 @@ using common::TypeCategory;
class TargetCharacteristics;
// Specific intrinsic types are represented by specializations of
-// this class template Type<CATEGORY, KIND>.
-template <TypeCategory CATEGORY, int KIND = 0> class Type;
-
-using SubscriptInteger = Type<TypeCategory::Integer, 8>;
-using CInteger = Type<TypeCategory::Integer, 4>;
-using LargestInt = Type<TypeCategory::Integer, 16>;
-using LogicalResult = Type<TypeCategory::Logical, 4>;
-using LargestReal = Type<TypeCategory::Real, 16>;
-using Ascii = Type<TypeCategory::Character, 1>;
+// this class template Type<CATEGORY>. The kind of a Type is carried at
+// runtime rather than as a template parameter.
+template <TypeCategory CATEGORY> class Type;
+
+// Default kinds for type aliases that used to encode a specific kind in their
+// template arguments. Now that Type is not parameterized on kind, the kind is
+// carried at runtime; these named constants preserve the previously-implied
+// kind values for the constructors and width computations that need them.
+inline constexpr int subscriptIntegerKind{8};
+inline constexpr int cIntegerKind{4};
+inline constexpr int largestIntKind{16};
+inline constexpr int logicalResultKind{4};
+inline constexpr int largestRealKind{16};
+inline constexpr int asciiKind{1};
+
+using SubscriptInteger = Type<TypeCategory::Integer>;
+using CInteger = Type<TypeCategory::Integer>;
+using LargestInt = Type<TypeCategory::Integer>;
+using LogicalResult = Type<TypeCategory::Logical>;
+using LargestReal = Type<TypeCategory::Real>;
+using Ascii = Type<TypeCategory::Character>;
// DynamicType is meant to be suitable for use as the result type for
// GetType() functions and member functions; consequently, it must be
@@ -253,26 +266,33 @@ const semantics::DerivedTypeSpec *GetDerivedTypeSpec(
const semantics::DerivedTypeSpec *GetParentTypeSpec(
const semantics::DerivedTypeSpec &);
-template <TypeCategory CATEGORY, int KIND = 0> struct TypeBase {
+template <TypeCategory CATEGORY> struct TypeBase {
static constexpr TypeCategory category{CATEGORY};
- static constexpr int kind{KIND};
- constexpr bool operator==(const TypeBase &) const { return true; }
- static constexpr DynamicType GetType() { return {category, kind}; }
- static std::string AsFortran() { return GetType().AsFortran(); }
+ // The kind is carried at runtime. A default-constructed Type has a kind of
+ // zero, which denotes an as-yet-unspecified kind.
+ constexpr TypeBase(int k = 0) : runtimeKind_{k} {}
+ constexpr bool operator==(const TypeBase &that) const {
+ return runtimeKind_ == that.runtimeKind_;
+ }
+ constexpr int runtimeKind() const { return runtimeKind_; }
+ constexpr int kind() const { return runtimeKind_; }
+ constexpr DynamicType GetType() const { return {category, runtimeKind_}; }
+ std::string AsFortran() const { return GetType().AsFortran(); }
+ int runtimeKind_{0};
};
-template <int KIND>
-class Type<TypeCategory::Integer, KIND>
- : public TypeBase<TypeCategory::Integer, KIND> {
+template <>
+class Type<TypeCategory::Integer> : public TypeBase<TypeCategory::Integer> {
public:
- using Scalar = value::Integer<8 * KIND>;
+ using TypeBase::TypeBase;
+ using Scalar = value::IntegerValue;
};
-template <int KIND>
-class Type<TypeCategory::Unsigned, KIND>
- : public TypeBase<TypeCategory::Unsigned, KIND> {
+template <>
+class Type<TypeCategory::Unsigned> : public TypeBase<TypeCategory::Unsigned> {
public:
- using Scalar = value::Integer<8 * KIND>;
+ using TypeBase::TypeBase;
+ using Scalar = value::IntegerValue;
};
// Records when a default REAL literal constant is inexactly converted to binary
@@ -291,62 +311,51 @@ class TrackInexactLiteralConversion {
bool isFromInexactLiteralConversion_{false};
};
-template <int KIND>
-class Type<TypeCategory::Real, KIND>
- : public TypeBase<TypeCategory::Real, KIND>,
- public TrackInexactLiteralConversion {
-public:
- static constexpr int precision{common::PrecisionOfRealKind(KIND)};
- static constexpr int bits{common::BitsForBinaryPrecision(precision)};
- using Scalar =
- value::Real<std::conditional_t<precision == 64,
- value::X87IntegerContainer, value::Integer<bits>>,
- precision>;
-};
-
-// The KIND type parameter on COMPLEX is the kind of each of its components.
-template <int KIND>
-class Type<TypeCategory::Complex, KIND>
- : public TypeBase<TypeCategory::Complex, KIND>,
- public TrackInexactLiteralConversion {
-public:
- using Part = Type<TypeCategory::Real, KIND>;
- using Scalar = value::Complex<typename Part::Scalar>;
-};
-
template <>
-class Type<TypeCategory::Character, 1>
- : public TypeBase<TypeCategory::Character, 1> {
+class Type<TypeCategory::Real> : public TypeBase<TypeCategory::Real>,
+ public TrackInexactLiteralConversion {
public:
- using Scalar = std::string;
+ using TypeBase::TypeBase;
+ static constexpr int precision(int kind) {
+ return common::PrecisionOfRealKind(kind);
+ }
+ static constexpr int bits(int kind) {
+ return common::BitsForBinaryPrecision(precision(kind));
+ }
+ using Scalar = value::RealValue;
};
+// The kind of a COMPLEX value is the kind of each of its components.
template <>
-class Type<TypeCategory::Character, 2>
- : public TypeBase<TypeCategory::Character, 2> {
+class Type<TypeCategory::Complex> : public TypeBase<TypeCategory::Complex>,
+ public TrackInexactLiteralConversion {
public:
- using Scalar = std::u16string;
+ using TypeBase::TypeBase;
+ using Part = Type<TypeCategory::Real>;
+ using Scalar = value::ComplexValue;
};
template <>
-class Type<TypeCategory::Character, 4>
- : public TypeBase<TypeCategory::Character, 4> {
+class Type<TypeCategory::Character> : public TypeBase<TypeCategory::Character> {
public:
- using Scalar = std::u32string;
+ using TypeBase::TypeBase;
+ using Scalar = value::CharacterValue;
};
-template <int KIND>
-class Type<TypeCategory::Logical, KIND>
- : public TypeBase<TypeCategory::Logical, KIND> {
+template <>
+class Type<TypeCategory::Logical> : public TypeBase<TypeCategory::Logical> {
public:
- using Scalar = value::Logical<8 * KIND>;
+ using TypeBase::TypeBase;
+ using Scalar = value::LogicalValue;
};
// Type functions
// Given a specific type, find the type of the same kind in another category.
-template <TypeCategory CATEGORY, typename T>
-using SameKind = Type<CATEGORY, std::decay_t<T>::kind>;
+// The kind is now a runtime property, so "same kind" is no longer expressible
+// purely in the type system; SameKind maps only the category.
+// PAPAYA: Remove completely
+// template <TypeCategory CATEGORY, typename T> using SameKind = Type<CATEGORY>;
// Many expressions, including subscripts, CHARACTER lengths, array bounds,
// and effective type parameter values, are of a maximal kind of INTEGER.
@@ -356,17 +365,10 @@ using IndirectSubscriptIntegerExpr =
// For each intrinsic type category CAT, CategoryTypes<CAT> is an instantiation
// of std::tuple<Type<CAT, K>> that comprises every kind value K in that
// category that could possibly be supported on any target.
-template <TypeCategory CATEGORY, int KIND>
-using CategoryKindTuple =
- std::conditional_t<common::IsValidKindOfIntrinsicType(CATEGORY, KIND),
- std::tuple<Type<CATEGORY, KIND>>, std::tuple<>>;
-
-template <TypeCategory CATEGORY, int... KINDS>
-using CategoryTypesHelper =
- common::CombineTuples<CategoryKindTuple<CATEGORY, KINDS>...>;
-
+// With kind carried at runtime there is a single Type per category.
+// PAPAYA: Remove completely
template <TypeCategory CATEGORY>
-using CategoryTypes = CategoryTypesHelper<CATEGORY, 1, 2, 3, 4, 8, 10, 16, 32>;
+using CategoryTypes = std::tuple<Type<CATEGORY>>;
using IntegerTypes = CategoryTypes<TypeCategory::Integer>;
using RealTypes = CategoryTypes<TypeCategory::Real>;
@@ -511,42 +513,21 @@ bool AreSameDerivedTypeIgnoringTypeParameters(
bool AreSameDerivedTypeIgnoringSequence(
const semantics::DerivedTypeSpec &, const semantics::DerivedTypeSpec &);
-// For generating "[extern] template class", &c. boilerplate
-#define EXPAND_FOR_EACH_INTEGER_KIND(M, P, S) \
- M(P, S, 1) M(P, S, 2) M(P, S, 4) M(P, S, 8) M(P, S, 16)
-#define EXPAND_FOR_EACH_REAL_KIND(M, P, S) \
- M(P, S, 2) M(P, S, 3) M(P, S, 4) M(P, S, 8) M(P, S, 10) M(P, S, 16)
-#define EXPAND_FOR_EACH_COMPLEX_KIND(M, P, S) EXPAND_FOR_EACH_REAL_KIND(M, P, S)
-#define EXPAND_FOR_EACH_CHARACTER_KIND(M, P, S) M(P, S, 1) M(P, S, 2) M(P, S, 4)
-#define EXPAND_FOR_EACH_LOGICAL_KIND(M, P, S) \
- M(P, S, 1) M(P, S, 2) M(P, S, 4) M(P, S, 8)
-#define EXPAND_FOR_EACH_UNSIGNED_KIND EXPAND_FOR_EACH_INTEGER_KIND
-
-#define FOR_EACH_INTEGER_KIND_HELP(PREFIX, SUFFIX, K) \
- PREFIX<Type<TypeCategory::Integer, K>> SUFFIX;
-#define FOR_EACH_REAL_KIND_HELP(PREFIX, SUFFIX, K) \
- PREFIX<Type<TypeCategory::Real, K>> SUFFIX;
-#define FOR_EACH_COMPLEX_KIND_HELP(PREFIX, SUFFIX, K) \
- PREFIX<Type<TypeCategory::Complex, K>> SUFFIX;
-#define FOR_EACH_CHARACTER_KIND_HELP(PREFIX, SUFFIX, K) \
- PREFIX<Type<TypeCategory::Character, K>> SUFFIX;
-#define FOR_EACH_LOGICAL_KIND_HELP(PREFIX, SUFFIX, K) \
- PREFIX<Type<TypeCategory::Logical, K>> SUFFIX;
-#define FOR_EACH_UNSIGNED_KIND_HELP(PREFIX, SUFFIX, K) \
- PREFIX<Type<TypeCategory::Unsigned, K>> SUFFIX;
-
+// For generating "[extern] template class", &c. boilerplate. With kind
+// carried at runtime there is a single Type per category, so these now expand
+// to one instantiation per category rather than one per kind.
#define FOR_EACH_INTEGER_KIND(PREFIX, SUFFIX) \
- EXPAND_FOR_EACH_INTEGER_KIND(FOR_EACH_INTEGER_KIND_HELP, PREFIX, SUFFIX)
+ PREFIX<Type<TypeCategory::Integer>> SUFFIX;
#define FOR_EACH_REAL_KIND(PREFIX, SUFFIX) \
- EXPAND_FOR_EACH_REAL_KIND(FOR_EACH_REAL_KIND_HELP, PREFIX, SUFFIX)
+ PREFIX<Type<TypeCategory::Real>> SUFFIX;
#define FOR_EACH_COMPLEX_KIND(PREFIX, SUFFIX) \
- EXPAND_FOR_EACH_COMPLEX_KIND(FOR_EACH_COMPLEX_KIND_HELP, PREFIX, SUFFIX)
+ PREFIX<Type<TypeCategory::Complex>> SUFFIX;
#define FOR_EACH_CHARACTER_KIND(PREFIX, SUFFIX) \
- EXPAND_FOR_EACH_CHARACTER_KIND(FOR_EACH_CHARACTER_KIND_HELP, PREFIX, SUFFIX)
+ PREFIX<Type<TypeCategory::Character>> SUFFIX;
#define FOR_EACH_LOGICAL_KIND(PREFIX, SUFFIX) \
- EXPAND_FOR_EACH_LOGICAL_KIND(FOR_EACH_LOGICAL_KIND_HELP, PREFIX, SUFFIX)
+ PREFIX<Type<TypeCategory::Logical>> SUFFIX;
#define FOR_EACH_UNSIGNED_KIND(PREFIX, SUFFIX) \
- EXPAND_FOR_EACH_UNSIGNED_KIND(FOR_EACH_UNSIGNED_KIND_HELP, PREFIX, SUFFIX)
+ PREFIX<Type<TypeCategory::Unsigned>> SUFFIX;
#define FOR_EACH_LENGTHLESS_INTRINSIC_KIND(PREFIX, SUFFIX) \
FOR_EACH_INTEGER_KIND(PREFIX, SUFFIX) \
@@ -573,5 +554,15 @@ bool AreSameDerivedTypeIgnoringSequence(
#define FOR_EACH_TYPE_AND_KIND(PREFIX, SUFFIX) \
FOR_EACH_INTRINSIC_KIND(PREFIX, SUFFIX) \
FOR_EACH_CATEGORY_TYPE(PREFIX, SUFFIX)
+
+// CharacterValue comparison with Fortran blank-padding semantics. This
+// overload is necessary because value::CharacterValue holds an opaque variant
+// over string types, while the generic Compare in common.h only handles
+// std::basic_string directly. Being a non-template, it is preferred over that
+// generic template for value::CharacterValue operands. It is defined in
+// character-value.cpp, which can see the CharacterValueImpl storage.
+Ordering Compare(
+ const value::CharacterValue &x, const value::CharacterValue &y);
+
} // namespace Fortran::evaluate
#endif // FORTRAN_EVALUATE_TYPE_H_
diff --git a/flang/include/flang/Evaluate/variable.h b/flang/include/flang/Evaluate/variable.h
index 4f64ede3d407d..b922aea2f3af0 100644
--- a/flang/include/flang/Evaluate/variable.h
+++ b/flang/include/flang/Evaluate/variable.h
@@ -136,6 +136,9 @@ class NamedEntity {
class TypeParamInquiry {
public:
using Result = SubscriptInteger;
+ static constexpr DynamicType GetType() {
+ return DynamicType{TypeCategory::Integer, subscriptIntegerKind};
+ }
CLASS_BOILERPLATE(TypeParamInquiry)
TypeParamInquiry(NamedEntity &&x, const Symbol ¶m)
: base_{std::move(x)}, parameter_{param} {}
@@ -413,6 +416,9 @@ FOR_EACH_CHARACTER_KIND(extern template class Designator, )
class DescriptorInquiry {
public:
using Result = SubscriptInteger;
+ static constexpr DynamicType GetType() {
+ return DynamicType{TypeCategory::Integer, subscriptIntegerKind};
+ }
ENUM_CLASS(Field, LowerBound, Extent, Stride, Rank, Len)
CLASS_BOILERPLATE(DescriptorInquiry)
diff --git a/flang/include/flang/Lower/DirectivesCommon.h b/flang/include/flang/Lower/DirectivesCommon.h
index 195c2f6102066..1373ce7bff97a 100644
--- a/flang/include/flang/Lower/DirectivesCommon.h
+++ b/flang/include/flang/Lower/DirectivesCommon.h
@@ -100,27 +100,27 @@ static T AsRvalueRef(const T &t) {
// (if present) is not needed. When it's present, though, it causes generated
// names to contain "int(..., kind=8)".
struct PeelConvert {
- template <Fortran::common::TypeCategory Category, int Kind>
- static Fortran::semantics::MaybeExpr visit_with_category(
- const Fortran::evaluate::Expr<Fortran::evaluate::Type<Category, Kind>>
- &expr) {
- return Fortran::common::visit(
- [](auto &&s) { return visit_with_category<Category, Kind>(s); },
- expr.u);
- }
- template <Fortran::common::TypeCategory Category, int Kind>
- static Fortran::semantics::MaybeExpr visit_with_category(
- const Fortran::evaluate::Convert<Fortran::evaluate::Type<Category, Kind>,
- Category> &expr) {
- return AsGenericExpr(AsRvalueRef(expr.left()));
- }
- template <Fortran::common::TypeCategory Category, int Kind, typename T>
- static Fortran::semantics::MaybeExpr visit_with_category(const T &) {
- return std::nullopt; //
- }
+ // Trait to detect a same-category evaluate::Convert (a kind conversion)
+ // without instantiating Convert<> for categories that do not support it
+ // (e.g. Derived).
+ template <typename T>
+ struct IsKindConvert : std::false_type {};
+ template <typename TO, Fortran::common::TypeCategory FROM>
+ struct IsKindConvert<Fortran::evaluate::Convert<TO, FROM>> {
+ static constexpr bool value{TO::category == FROM};
+ };
+
template <Fortran::common::TypeCategory Category, typename T>
- static Fortran::semantics::MaybeExpr visit_with_category(const T &) {
- return std::nullopt; //
+ static Fortran::semantics::MaybeExpr visit_with_category(const T &x) {
+ if constexpr (std::is_same_v<T, Fortran::evaluate::Expr<
+ Fortran::evaluate::Type<Category>>>) {
+ return Fortran::common::visit(
+ [](auto &&s) { return visit_with_category<Category>(s); }, x.u);
+ } else if constexpr (IsKindConvert<T>::value) {
+ return AsGenericExpr(AsRvalueRef(x.left()));
+ } else {
+ return std::nullopt;
+ }
}
template <Fortran::common::TypeCategory Category>
diff --git a/flang/include/flang/Lower/Mangler.h b/flang/include/flang/Lower/Mangler.h
index 99da96b0d6ba5..3136131fc0049 100644
--- a/flang/include/flang/Lower/Mangler.h
+++ b/flang/include/flang/Lower/Mangler.h
@@ -66,22 +66,21 @@ mangleArrayLiteral(size_t size,
Fortran::common::ConstantSubscript charLen = -1,
llvm::StringRef derivedName = {});
-template <Fortran::common::TypeCategory TC, int KIND>
+template <Fortran::common::TypeCategory TC>
std::string mangleArrayLiteral(
mlir::Type,
- const Fortran::evaluate::Constant<Fortran::evaluate::Type<TC, KIND>> &x) {
+ const Fortran::evaluate::Constant<Fortran::evaluate::Type<TC>> &x) {
return mangleArrayLiteral(x.values().size() * sizeof(x.values()[0]),
- x.shape(), TC, KIND);
+ x.shape(), TC, x.GetType().kind());
}
-template <int KIND>
-std::string
-mangleArrayLiteral(mlir::Type,
- const Fortran::evaluate::Constant<Fortran::evaluate::Type<
- Fortran::common::TypeCategory::Character, KIND>> &x) {
+inline std::string mangleArrayLiteral(
+ mlir::Type,
+ const Fortran::evaluate::Constant<
+ Fortran::evaluate::Type<Fortran::common::TypeCategory::Character>> &x) {
return mangleArrayLiteral(x.values().size() * sizeof(x.values()[0]),
x.shape(), Fortran::common::TypeCategory::Character,
- KIND, x.LEN());
+ x.GetType().kind(), x.LEN());
}
inline std::string mangleArrayLiteral(
diff --git a/flang/include/flang/Lower/Support/Utils.h b/flang/include/flang/Lower/Support/Utils.h
index 025baa5282786..3beff3b5c94a0 100644
--- a/flang/include/flang/Lower/Support/Utils.h
+++ b/flang/include/flang/Lower/Support/Utils.h
@@ -67,10 +67,10 @@ static Fortran::lower::SomeExpr toEvExpr(const A &x) {
}
template <Fortran::common::TypeCategory FROM>
-static Fortran::lower::SomeExpr ignoreEvConvert(
- const Fortran::evaluate::Convert<
- Fortran::evaluate::Type<Fortran::common::TypeCategory::Integer, 8>,
- FROM> &x) {
+static Fortran::lower::SomeExpr
+ignoreEvConvert(const Fortran::evaluate::Convert<
+ Fortran::evaluate::Type<Fortran::common::TypeCategory::Integer>,
+ FROM> &x) {
return toEvExpr(x.left());
}
template <typename A>
@@ -81,9 +81,9 @@ static Fortran::lower::SomeExpr ignoreEvConvert(const A &x) {
/// A vector subscript expression may be wrapped with a cast to INTEGER*8.
/// Get rid of it here so the vector can be loaded. Add it back when
/// generating the elemental evaluation (inside the loop nest).
-inline Fortran::lower::SomeExpr
-ignoreEvConvert(const Fortran::evaluate::Expr<Fortran::evaluate::Type<
- Fortran::common::TypeCategory::Integer, 8>> &x) {
+inline Fortran::lower::SomeExpr ignoreEvConvert(
+ const Fortran::evaluate::Expr<
+ Fortran::evaluate::Type<Fortran::common::TypeCategory::Integer>> &x) {
return Fortran::common::visit(
[](const auto &v) { return ignoreEvConvert(v); }, x.u);
}
diff --git a/flang/include/flang/Semantics/dump-expr.h b/flang/include/flang/Semantics/dump-expr.h
index d79a294258ff1..1f8345e5ff71d 100644
--- a/flang/include/flang/Semantics/dump-expr.h
+++ b/flang/include/flang/Semantics/dump-expr.h
@@ -232,14 +232,12 @@ class DumpEvaluateExpr {
LLVM_DUMP_METHOD void DumpEvExpr(const evaluate::Expr<evaluate::SomeType> &x);
LLVM_DUMP_METHOD void DumpEvExpr(
- const evaluate::Expr<evaluate::Type<common::TypeCategory::Integer, 4>> &x);
-LLVM_DUMP_METHOD void DumpEvExpr(
- const evaluate::Expr<evaluate::Type<common::TypeCategory::Integer, 8>> &x);
+ const evaluate::Expr<evaluate::Type<common::TypeCategory::Integer>> &x);
LLVM_DUMP_METHOD void DumpEvExpr(const evaluate::ArrayRef &x);
LLVM_DUMP_METHOD void DumpEvExpr(const evaluate::DataRef &x);
LLVM_DUMP_METHOD void DumpEvExpr(const evaluate::Substring &x);
LLVM_DUMP_METHOD void DumpEvExpr(
- const evaluate::Designator<evaluate::Type<common::TypeCategory::Integer, 4>>
+ const evaluate::Designator<evaluate::Type<common::TypeCategory::Integer>>
&x);
} // namespace Fortran::semantics
diff --git a/flang/lib/Evaluate/CMakeLists.txt b/flang/lib/Evaluate/CMakeLists.txt
index 472ecb6d8d079..0a379a0f21a79 100644
--- a/flang/lib/Evaluate/CMakeLists.txt
+++ b/flang/lib/Evaluate/CMakeLists.txt
@@ -30,10 +30,12 @@ endif ()
add_flang_library(FortranEvaluate
call.cpp
+ character-value-impl.cpp
+ character-value.cpp
characteristics.cpp
check-expression.cpp
common.cpp
- complex.cpp
+ complex-value.cpp
constant.cpp
expression.cpp
fold.cpp
@@ -48,10 +50,12 @@ add_flang_library(FortranEvaluate
host.cpp
initial-image.cpp
integer.cpp
+ integer-value.cpp
intrinsics.cpp
intrinsics-library.cpp
- logical.cpp
+ logical-value.cpp
real.cpp
+ real-value.cpp
shape.cpp
static-data.cpp
target.cpp
@@ -59,6 +63,8 @@ add_flang_library(FortranEvaluate
type.cpp
variable.cpp
+ PARTIAL_SOURCES_INTENDED
+
LINK_LIBS
FortranSupport
FortranDecimal
@@ -74,9 +80,9 @@ add_flang_library(FortranEvaluate
[["flang/Evaluate/shape.h"]]
[["flang/Evaluate/characteristics.h"]]
[["flang/Evaluate/variable.h"]]
- [["flang/Evaluate/real.h"]]
+ [["flang/Evaluate/real-value.h"]]
[["flang/Evaluate/type.h"]]
- [["flang/Evaluate/integer.h"]]
+ [["flang/Evaluate/integer-value.h"]]
[["flang/Evaluate/expression.h"]]
[["flang/Evaluate/tools.h"]]
@@ -87,3 +93,54 @@ add_flang_library(FortranEvaluate
acc_gen
omp_gen
)
+
+# Automatic deduction of the opaque object size/alignment used by the RealValue
+# and CharacterValue facades (real-value.h / character-value.h). These embed a
+# fixed-size, suitably
+# aligned byte buffer standing in for their variant-backed implementation
+# (RealValueImpl / CharacterValueImpl) so the implementation headers stay private.
+# The required size/alignment is toolchain specific, so we compile a tiny probe
+# with this very toolchain and let it emit the matching object-sizes.h into the
+# build tree's include directory, which is searched before the source tree (see
+# the include_directories(BEFORE ...) in flang/CMakeLists.txt). The checked-in
+# object-sizes.h then acts purely as a fallback, which is what gets used when
+# cross-compiling (the probe cannot run on the host).
+#
+# The header is emitted per configuration ($<CONFIG>) and built by that
+# configuration's probe, because multi-config generators may produce different
+# object layouts per configuration. $<CONFIG> in the OUTPUT/DEPENDS below is the
+# documented Ninja Multi-Config pattern; on single-config generators it simply
+# expands to the active build type.
+if (NOT CMAKE_CROSSCOMPILING)
+ add_executable(flang-evaluate-object-size-probe object-size-probe.cpp)
+ set_target_properties(flang-evaluate-object-size-probe PROPERTIES
+ CXX_STANDARD 17
+ CXX_STANDARD_REQUIRED ON
+ RUNTIME_OUTPUT_DIRECTORY "${CMAKE_CURRENT_BINARY_DIR}")
+ # The probe only needs sizeof/alignof from the headers; it does not link any
+ # LLVM runtime, so opt out of the ABI-breaking-checks symbol enforcement that
+ # would otherwise require linking LLVMSupport.
+ #
+ # FORTRAN_EVALUATE_OBJECT_SIZE_PROBE makes object-sizes.h ignore the generated
+ # header that this probe produces, so the probe does not depend on its own
+ # output (which would create a build-graph cycle).
+ target_compile_definitions(flang-evaluate-object-size-probe PRIVATE
+ LLVM_DISABLE_ABI_BREAKING_CHECKS_ENFORCING=1
+ FORTRAN_EVALUATE_OBJECT_SIZE_PROBE)
+
+ set(_object_sizes_dir
+ "${FLANG_BINARY_DIR}/include/object-sizes/$<CONFIG>/flang/Evaluate")
+ set(_object_sizes_h "${_object_sizes_dir}/object-sizes-generated.h")
+
+ add_custom_command(
+ OUTPUT "${_object_sizes_h}"
+ COMMAND "${CMAKE_COMMAND}" -E make_directory "${_object_sizes_dir}"
+ COMMAND "$<TARGET_FILE:flang-evaluate-object-size-probe>" "${_object_sizes_h}"
+ DEPENDS flang-evaluate-object-size-probe
+ COMMENT "Deducing RealValueImpl/CharacterValueImpl object size and alignment ($<CONFIG>)"
+ VERBATIM)
+
+ add_custom_target(flang-evaluate-object-size DEPENDS "${_object_sizes_h}")
+
+ add_dependencies(FortranEvaluate flang-evaluate-object-size)
+endif()
diff --git a/flang/lib/Evaluate/character-value-impl.cpp b/flang/lib/Evaluate/character-value-impl.cpp
new file mode 100644
index 0000000000000..a769980e7b0b7
--- /dev/null
+++ b/flang/lib/Evaluate/character-value-impl.cpp
@@ -0,0 +1,462 @@
+//===-- lib/Evaluate/character-value-impl.cpp -----------------------------===//
+//
+// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
+// See https://llvm.org/LICENSE.txt for license information.
+// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
+//
+//===----------------------------------------------------------------------===//
+
+#include "flang/Evaluate/character-value-impl.h"
+#include "flang/Common/idioms.h"
+#include "llvm/Support/ErrorHandling.h"
+#include <algorithm>
+#include <cstring>
+
+namespace Fortran::evaluate::value {
+
+int CharacterValueImpl::kind() const {
+ switch (storage_.index()) {
+ case 1:
+ return 1;
+ case 2:
+ return 2;
+ case 3:
+ return 4;
+ default:
+ llvm_unreachable("unspecified char kind");
+ }
+}
+
+int CharacterValueImpl::bits() const { return 8 * kind(); }
+
+CharacterValueImpl CharacterValueImpl::Zero(int kind) {
+ switch (kind) {
+ case 2:
+ return CharacterValueImpl{std::u16string{}};
+ case 4:
+ return CharacterValueImpl{std::u32string{}};
+ case 1:
+ return CharacterValueImpl{std::string{}};
+ default:
+ llvm_unreachable("unsupported char kind");
+ }
+}
+
+bool CharacterValueImpl::IsZero() const {
+ if (IsMonostate()) {
+ return true;
+ }
+ return std::visit(
+ [](const auto &s) -> bool {
+ if constexpr (std::is_same_v<std::decay_t<decltype(s)>,
+ std::monostate>) {
+ return true;
+ } else if (s.empty()) {
+ return true;
+ } else {
+ using CharT = typename std::decay_t<decltype(s)>::value_type;
+ return std::all_of(
+ s.begin(), s.end(), [](CharT c) { return c == CharT{}; });
+ }
+ },
+ storage_);
+}
+
+bool CharacterValueImpl::StoreRawBytes(void *to, std::size_t bytes) const {
+ return std::visit(
+ [&](const auto &s) -> bool {
+ if constexpr (std::is_same_v<std::decay_t<decltype(s)>,
+ std::monostate>) {
+ if (bytes == 0) {
+ return false;
+ }
+ if (std::all_of(static_cast<const char *>(to),
+ static_cast<const char *>(to) + bytes,
+ [](char x) { return x == 0; })) {
+ return false;
+ }
+ std::memset(to, 0, bytes);
+ return true;
+ } else {
+ std::size_t payloadBytes{std::min(bytes,
+ s.size() *
+ sizeof(typename std::decay_t<decltype(s)>::value_type))};
+ if (std::memcmp(to, s.data(), payloadBytes) != 0 ||
+ (payloadBytes < bytes &&
+ !std::all_of(static_cast<const char *>(to) + payloadBytes,
+ static_cast<const char *>(to) + bytes,
+ [](char x) { return x == 0; }))) {
+ std::memcpy(to, s.data(), payloadBytes);
+ if (payloadBytes < bytes) {
+ std::memset(static_cast<char *>(to) + payloadBytes, 0,
+ bytes - payloadBytes);
+ }
+ return true;
+ }
+ return false;
+ }
+ },
+ storage_);
+}
+
+std::size_t CharacterValueImpl::size() const {
+ return common::visit(
+ [](const auto &s) -> std::size_t {
+ if constexpr (std::is_same_v<std::decay_t<decltype(s)>,
+ std::monostate>) {
+ return 0;
+ } else {
+ return s.size();
+ }
+ },
+ storage_);
+}
+
+void CharacterValueImpl::erase(std::size_t pos) {
+ std::visit(
+ [pos](auto &s) {
+ if constexpr (!std::is_same_v<std::decay_t<decltype(s)>,
+ std::monostate>) {
+ s.erase(pos);
+ } else {
+ llvm_unreachable("operation not supported on uninitialized value");
+ }
+ },
+ storage_);
+}
+
+void CharacterValueImpl::append(std::size_t n, char c) {
+ std::visit(
+ [n, c](auto &s) {
+ if constexpr (!std::is_same_v<std::decay_t<decltype(s)>,
+ std::monostate>) {
+ using CharT = typename std::decay_t<decltype(s)>::value_type;
+ s.append(n, static_cast<CharT>(c));
+ } else {
+ llvm_unreachable("operation not supported on uninitialized value");
+ }
+ },
+ storage_);
+}
+
+void CharacterValueImpl::append(std::size_t n, char16_t c) {
+ std::visit(
+ [n, c](auto &s) {
+ if constexpr (!std::is_same_v<std::decay_t<decltype(s)>,
+ std::monostate>) {
+ using CharT = typename std::decay_t<decltype(s)>::value_type;
+ s.append(n, static_cast<CharT>(c));
+ } else {
+ llvm_unreachable("operation not supported on uninitialized value");
+ }
+ },
+ storage_);
+}
+
+void CharacterValueImpl::append(std::size_t n, char32_t c) {
+ std::visit(
+ [n, c](auto &s) {
+ if constexpr (!std::is_same_v<std::decay_t<decltype(s)>,
+ std::monostate>) {
+ using CharT = typename std::decay_t<decltype(s)>::value_type;
+ s.append(n, static_cast<CharT>(c));
+ } else {
+ llvm_unreachable("operation not supported on uninitialized value");
+ }
+ },
+ storage_);
+}
+
+CharacterValueImpl &CharacterValueImpl::replace(
+ std::size_t pos, std::size_t len, const CharacterValueImpl &other) {
+ std::visit(
+ [pos, len](auto &s, const auto &o) {
+ if constexpr (!std::is_same_v<std::decay_t<decltype(s)>,
+ std::monostate> &&
+ !std::is_same_v<std::decay_t<decltype(o)>, std::monostate> &&
+ std::is_same_v<std::decay_t<decltype(s)>,
+ std::decay_t<decltype(o)>>) {
+ s.replace(pos, len, o);
+ } else {
+ llvm_unreachable("operation not supported on uninitialized value or "
+ "values of different kinds");
+ }
+ },
+ storage_, other.storage_);
+ return *this;
+}
+
+CharacterValueImpl CharacterValueImpl::substr(std::size_t pos) const {
+ return std::visit(
+ [pos](const auto &s) -> CharacterValueImpl {
+ if constexpr (std::is_same_v<std::decay_t<decltype(s)>,
+ std::monostate>) {
+ llvm_unreachable("operation not supported on uninitialized value");
+ } else {
+ return CharacterValueImpl{s.substr(pos)};
+ }
+ },
+ storage_);
+}
+
+CharacterValueImpl CharacterValueImpl::substr(
+ std::size_t pos, std::size_t len) const {
+ return std::visit(
+ [pos, len](const auto &s) -> CharacterValueImpl {
+ if constexpr (std::is_same_v<std::decay_t<decltype(s)>,
+ std::monostate>) {
+ llvm_unreachable("operation not supported on uninitialized value");
+ } else {
+ return CharacterValueImpl{s.substr(pos, len)};
+ }
+ },
+ storage_);
+}
+
+std::optional<std::string> CharacterValueImpl::ToStdString() const {
+ if (const auto *s{std::get_if<std::string>(&storage_)}) {
+ return *s;
+ }
+ return std::nullopt;
+}
+
+void CharacterValueImpl::reserve(std::size_t n) {
+ std::visit(
+ [n](auto &s) {
+ if constexpr (!std::is_same_v<std::decay_t<decltype(s)>,
+ std::monostate>) {
+ s.reserve(n);
+ }
+ },
+ storage_);
+}
+
+char32_t CharacterValueImpl::operator[](std::size_t i) const {
+ return std::visit(
+ [i](const auto &s) -> char32_t {
+ if constexpr (!std::is_same_v<std::decay_t<decltype(s)>,
+ std::monostate>) {
+ return static_cast<char32_t>(s[i]);
+ } else {
+ llvm_unreachable("operation not supported on uninitialized value");
+ }
+ return 0;
+ },
+ storage_);
+}
+
+bool CharacterValueImpl::operator<(const CharacterValueImpl &y) const {
+ return std::visit(
+ [](const auto &a, const auto &b) -> bool {
+ if constexpr (std::is_same_v<std::decay_t<decltype(a)>,
+ std::decay_t<decltype(b)>> &&
+ !std::is_same_v<std::decay_t<decltype(a)>, std::monostate>) {
+ return a < b;
+ } else {
+ llvm_unreachable("operation not supported on uninitialized value or "
+ "values of different kinds");
+ }
+ return false;
+ },
+ storage_, y.storage_);
+}
+
+CharacterValueImpl CharacterValueImpl::operator+(
+ const CharacterValueImpl &y) const {
+ return std::visit(
+ [](const auto &a, const auto &b) -> CharacterValueImpl {
+ if constexpr (std::is_same_v<std::decay_t<decltype(a)>,
+ std::decay_t<decltype(b)>> &&
+ !std::is_same_v<std::decay_t<decltype(a)>, std::monostate>) {
+ return CharacterValueImpl{a + b};
+ } else {
+ llvm_unreachable("operation not supported on uninitialized value or "
+ "values of different kinds");
+ }
+ return CharacterValueImpl{};
+ },
+ storage_, y.storage_);
+}
+
+CharacterValueImpl &CharacterValueImpl::operator+=(
+ const CharacterValueImpl &y) {
+ std::visit(
+ [](auto &a, const auto &b) {
+ if constexpr (std::is_same_v<std::decay_t<decltype(a)>,
+ std::decay_t<decltype(b)>> &&
+ !std::is_same_v<std::decay_t<decltype(a)>, std::monostate>) {
+ a += b;
+ } else {
+ llvm_unreachable("operation not supported on uninitialized value or "
+ "values of different kinds");
+ }
+ },
+ storage_, y.storage_);
+ return *this;
+}
+
+CharacterValueImpl &CharacterValueImpl::operator+=(char c) {
+ std::visit(
+ [c](auto &s) {
+ if constexpr (!std::is_same_v<std::decay_t<decltype(s)>,
+ std::monostate>) {
+ using CharT = typename std::decay_t<decltype(s)>::value_type;
+ s.push_back(static_cast<CharT>(c));
+ } else {
+ llvm_unreachable("operation not supported on uninitialized value");
+ }
+ },
+ storage_);
+ return *this;
+}
+
+std::size_t CharacterValueImpl::find_first_not_of(
+ const CharacterValueImpl &set) const {
+ return std::visit(
+ [](const auto &s, const auto &p) -> std::size_t {
+ if constexpr (std::is_same_v<std::decay_t<decltype(s)>,
+ std::decay_t<decltype(p)>> &&
+ !std::is_same_v<std::decay_t<decltype(s)>, std::monostate>) {
+ return s.find_first_not_of(p);
+ }
+ return std::string::npos;
+ },
+ storage_, set.storage_);
+}
+
+std::size_t CharacterValueImpl::find_last_not_of(
+ const CharacterValueImpl &set) const {
+ return std::visit(
+ [](const auto &s, const auto &p) -> std::size_t {
+ if constexpr (std::is_same_v<std::decay_t<decltype(s)>,
+ std::decay_t<decltype(p)>> &&
+ !std::is_same_v<std::decay_t<decltype(s)>, std::monostate>) {
+ return s.find_last_not_of(p);
+ }
+ return std::string::npos;
+ },
+ storage_, set.storage_);
+}
+
+std::size_t CharacterValueImpl::find(const CharacterValueImpl &pattern) const {
+ return std::visit(
+ [](const auto &s, const auto &p) -> std::size_t {
+ if constexpr (std::is_same_v<std::decay_t<decltype(s)>,
+ std::decay_t<decltype(p)>> &&
+ !std::is_same_v<std::decay_t<decltype(s)>, std::monostate>) {
+ return s.find(p);
+ }
+ return std::string::npos;
+ },
+ storage_, pattern.storage_);
+}
+
+std::size_t CharacterValueImpl::rfind(const CharacterValueImpl &pattern) const {
+ return std::visit(
+ [](const auto &s, const auto &p) -> std::size_t {
+ if constexpr (std::is_same_v<std::decay_t<decltype(s)>,
+ std::decay_t<decltype(p)>> &&
+ !std::is_same_v<std::decay_t<decltype(s)>, std::monostate>) {
+ return s.rfind(p);
+ }
+ return std::string::npos;
+ },
+ storage_, pattern.storage_);
+}
+
+std::size_t CharacterValueImpl::find_first_of(
+ const CharacterValueImpl &set) const {
+ return std::visit(
+ [](const auto &s, const auto &p) -> std::size_t {
+ if constexpr (std::is_same_v<std::decay_t<decltype(s)>,
+ std::decay_t<decltype(p)>> &&
+ !std::is_same_v<std::decay_t<decltype(s)>, std::monostate>) {
+ return s.find_first_of(p);
+ }
+ return std::string::npos;
+ },
+ storage_, set.storage_);
+}
+
+std::size_t CharacterValueImpl::find_last_of(
+ const CharacterValueImpl &set) const {
+ return std::visit(
+ [](const auto &s, const auto &p) -> std::size_t {
+ if constexpr (std::is_same_v<std::decay_t<decltype(s)>,
+ std::decay_t<decltype(p)>> &&
+ !std::is_same_v<std::decay_t<decltype(s)>, std::monostate>) {
+ return s.find_last_of(p);
+ }
+ return std::string::npos;
+ },
+ storage_, set.storage_);
+}
+
+std::size_t CharacterValueImpl::charSize() const {
+ return std::visit(
+ [](const auto &s) -> std::size_t {
+ if constexpr (std::is_same_v<std::decay_t<decltype(s)>,
+ std::monostate>) {
+ llvm_unreachable("operation not supported on uninitialized value");
+ } else {
+ return sizeof(typename std::decay_t<decltype(s)>::value_type);
+ }
+ },
+ storage_);
+}
+
+void *CharacterValueImpl::charData() {
+ return std::visit(
+ [](auto &s) -> void * {
+ if constexpr (std::is_same_v<std::decay_t<decltype(s)>,
+ std::monostate>) {
+ return nullptr;
+ } else {
+ return static_cast<void *>(s.data());
+ }
+ },
+ storage_);
+}
+
+const void *CharacterValueImpl::charData() const {
+ return std::visit(
+ [](const auto &s) -> const void * {
+ if constexpr (std::is_same_v<std::decay_t<decltype(s)>,
+ std::monostate>) {
+ return nullptr;
+ } else {
+ return static_cast<const void *>(s.data());
+ }
+ },
+ storage_);
+}
+
+std::size_t CharacterValueImpl::find_first_not_of_char(char32_t c) const {
+ return std::visit(
+ [c](const auto &s) -> std::size_t {
+ if constexpr (!std::is_same_v<std::decay_t<decltype(s)>,
+ std::monostate>) {
+ using CharT = typename std::decay_t<decltype(s)>::value_type;
+ // assert(static_cast<CharT>(c) == c);
+ return s.find_first_not_of(static_cast<CharT>(c));
+ }
+ return std::string::npos;
+ },
+ storage_);
+}
+
+std::size_t CharacterValueImpl::find_last_not_of_char(char32_t c) const {
+ return std::visit(
+ [c](const auto &s) -> std::size_t {
+ if constexpr (!std::is_same_v<std::decay_t<decltype(s)>,
+ std::monostate>) {
+ using CharT = typename std::decay_t<decltype(s)>::value_type;
+ // assert(static_cast<CharT>(c) == c);
+ return s.find_last_not_of(static_cast<CharT>(c));
+ }
+ return std::string::npos;
+ },
+ storage_);
+}
+
+} // namespace Fortran::evaluate::value
diff --git a/flang/lib/Evaluate/character-value.cpp b/flang/lib/Evaluate/character-value.cpp
new file mode 100644
index 0000000000000..1511986cf3792
--- /dev/null
+++ b/flang/lib/Evaluate/character-value.cpp
@@ -0,0 +1,180 @@
+//===-- lib/Evaluate/character-value.cpp ----------------------------------===//
+//
+// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
+// See https://llvm.org/LICENSE.txt for license information.
+// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
+//
+//===----------------------------------------------------------------------===//
+
+#include "flang/Evaluate/character-value.h"
+#include "flang/Evaluate/character-value-impl.h"
+#include "flang/Evaluate/common.h"
+#include "llvm/Support/ErrorHandling.h"
+#include <new>
+#include <string>
+
+namespace Fortran::evaluate::value {
+
+static_assert(sizeof(CharacterValueImpl) == detail::kCharacterObjectSize);
+static_assert(alignof(CharacterValueImpl) <= detail::kCharacterObjectAlign);
+static_assert(sizeof(CharacterValue) == sizeof(CharacterValueImpl));
+
+CharacterValue::CharacterValue() { new (this) CharacterValueImpl(); }
+CharacterValue::~CharacterValue() { value().~CharacterValueImpl(); }
+CharacterValue::CharacterValue(const CharacterValue &x) {
+ new (this) CharacterValueImpl(x.value());
+}
+CharacterValue::CharacterValue(CharacterValue &&x) {
+ new (this) CharacterValueImpl(std::move(x.value()));
+}
+CharacterValue &CharacterValue::operator=(const CharacterValue &x) {
+ value() = x.value();
+ return *this;
+}
+CharacterValue &CharacterValue::operator=(CharacterValue &&x) {
+ value() = std::move(x.value());
+ return *this;
+}
+
+CharacterValue::CharacterValue(std::string s) {
+ new (this) CharacterValueImpl(std::move(s));
+}
+CharacterValue::CharacterValue(std::u16string s) {
+ new (this) CharacterValueImpl(std::move(s));
+}
+CharacterValue::CharacterValue(std::u32string s) {
+ new (this) CharacterValueImpl(std::move(s));
+}
+CharacterValue::CharacterValue(std::size_t n, char c) {
+ new (this) CharacterValueImpl(n, c);
+}
+CharacterValue::CharacterValue(std::size_t n, char16_t c) {
+ new (this) CharacterValueImpl(n, c);
+}
+CharacterValue::CharacterValue(std::size_t n, char32_t c) {
+ new (this) CharacterValueImpl(n, c);
+}
+
+bool CharacterValue::operator==(const CharacterValue &y) const {
+ return value() == y.value();
+}
+bool CharacterValue::operator<(const CharacterValue &y) const {
+ return value() < y.value();
+}
+int CharacterValue::kind() const { return value().kind(); }
+int CharacterValue::bits() const { return value().bits(); }
+bool CharacterValue::IsMonostate() const { return value().IsMonostate(); }
+bool CharacterValue::IsZero() const { return value().IsZero(); }
+CharacterValue CharacterValue::Zero(int kind) {
+ CharacterValue result;
+ result.value() = CharacterValueImpl::Zero(kind);
+ return result;
+}
+
+std::size_t CharacterValue::size() const { return value().size(); }
+void CharacterValue::assign(std::size_t n, char c) { value().assign(n, c); }
+void CharacterValue::assign(std::size_t n, char16_t c) { value().assign(n, c); }
+void CharacterValue::assign(std::size_t n, char32_t c) { value().assign(n, c); }
+void CharacterValue::assign(const char *p, std::size_t n) {
+ value().assign(p, n);
+}
+void CharacterValue::assign(const char16_t *p, std::size_t n) {
+ value().assign(p, n);
+}
+void CharacterValue::assign(const char32_t *p, std::size_t n) {
+ value().assign(p, n);
+}
+void CharacterValue::erase(std::size_t pos) { value().erase(pos); }
+void CharacterValue::append(std::size_t n, char c) { value().append(n, c); }
+void CharacterValue::append(std::size_t n, char16_t c) { value().append(n, c); }
+void CharacterValue::append(std::size_t n, char32_t c) { value().append(n, c); }
+CharacterValue &CharacterValue::replace(
+ std::size_t pos, std::size_t len, const CharacterValue &other) {
+ value().replace(pos, len, other.value());
+ return *this;
+}
+CharacterValue CharacterValue::substr(std::size_t pos) const {
+ CharacterValue result;
+ result.value() = value().substr(pos);
+ return result;
+}
+CharacterValue CharacterValue::substr(std::size_t pos, std::size_t len) const {
+ CharacterValue result;
+ result.value() = value().substr(pos, len);
+ return result;
+}
+std::optional<std::string> CharacterValue::ToStdString() const {
+ return value().ToStdString();
+}
+void CharacterValue::reserve(std::size_t n) { value().reserve(n); }
+char32_t CharacterValue::operator[](std::size_t i) const { return value()[i]; }
+CharacterValue CharacterValue::operator+(const CharacterValue &y) const {
+ CharacterValue result;
+ result.value() = value() + y.value();
+ return result;
+}
+CharacterValue &CharacterValue::operator+=(const CharacterValue &y) {
+ value() += y.value();
+ return *this;
+}
+CharacterValue &CharacterValue::operator+=(char c) {
+ value() += c;
+ return *this;
+}
+std::size_t CharacterValue::find_first_not_of(const CharacterValue &set) const {
+ return value().find_first_not_of(set.value());
+}
+std::size_t CharacterValue::find_last_not_of(const CharacterValue &set) const {
+ return value().find_last_not_of(set.value());
+}
+std::size_t CharacterValue::find(const CharacterValue &pattern) const {
+ return value().find(pattern.value());
+}
+std::size_t CharacterValue::rfind(const CharacterValue &pattern) const {
+ return value().rfind(pattern.value());
+}
+std::size_t CharacterValue::find_first_of(const CharacterValue &set) const {
+ return value().find_first_of(set.value());
+}
+std::size_t CharacterValue::find_last_of(const CharacterValue &set) const {
+ return value().find_last_of(set.value());
+}
+std::size_t CharacterValue::charSize() const { return value().charSize(); }
+const void *CharacterValue::data() const { return value().data(); }
+void *CharacterValue::charData() { return value().charData(); }
+const void *CharacterValue::charData() const { return value().charData(); }
+std::size_t CharacterValue::find_first_not_of_char(char32_t c) const {
+ return value().find_first_not_of(c);
+}
+std::size_t CharacterValue::find_last_not_of_char(char32_t c) const {
+ return value().find_last_not_of(c);
+}
+
+} // namespace Fortran::evaluate::value
+
+namespace Fortran::evaluate {
+
+// Fortran CHARACTER comparison: the shorter operand is blank-padded to the
+// length of the longer before comparing. We recover the active string
+// alternative via WithChar and defer to the std::basic_string overload of
+// Compare in common.h, which performs the blank padding.
+Ordering Compare(
+ const value::CharacterValue &x, const value::CharacterValue &y) {
+ if (x.IsMonostate() || y.IsMonostate()) {
+ return Ordering::Equal;
+ }
+ return x.value().WithChar([&y](const auto &xs) -> Ordering {
+ using XS = std::decay_t<decltype(xs)>;
+ return y.value().WithChar([&xs](const auto &ys) -> Ordering {
+ if constexpr (std::is_same_v<XS, std::decay_t<decltype(ys)>>) {
+ return Compare(xs, ys);
+ } else {
+ // Same-KIND operands always share a storage type; differing types
+ // cannot arise from a well-typed relational expression.
+ llvm_unreachable("character comparison across differing kinds");
+ }
+ });
+ });
+}
+
+} // namespace Fortran::evaluate
diff --git a/flang/lib/Evaluate/character.h b/flang/lib/Evaluate/character.h
index 2d6747741161b..3fde836e0850b 100644
--- a/flang/lib/Evaluate/character.h
+++ b/flang/lib/Evaluate/character.h
@@ -9,7 +9,9 @@
#ifndef FORTRAN_EVALUATE_CHARACTER_H_
#define FORTRAN_EVALUATE_CHARACTER_H_
+#include "flang/Evaluate/character-value.h"
#include "flang/Evaluate/type.h"
+#include <cstdint>
#include <string>
// Provides implementations of intrinsic functions operating on character
@@ -17,87 +19,102 @@
namespace Fortran::evaluate {
-template <int KIND> class CharacterUtils {
- using Character = Scalar<Type<TypeCategory::Character, KIND>>;
- using CharT = typename Character::value_type;
+class CharacterUtils {
+ using CharacterValue = Scalar<Type<TypeCategory::Character>>;
+ using CharT = char32_t;
public:
// CHAR also implements ACHAR under assumption that character encodings
// contain ASCII
- static Character CHAR(std::uint64_t code) {
- return Character{{static_cast<CharT>(code)}};
+ static CharacterValue CHAR(std::uint64_t code, int kind) {
+ return CharacterOfKind(1, static_cast<CharT>(code), kind);
}
// ICHAR also implements IACHAR under assumption that character encodings
// contain ASCII
- static std::int64_t ICHAR(const Character &c) {
+ static std::int64_t ICHAR(const CharacterValue &c) {
CHECK(c.length() == 1);
- // Convert first to an unsigned integer type to avoid sign extension
- return static_cast<common::HostUnsignedIntType<(8 * KIND)>>(c[0]);
+ // Mask to the character kind width to avoid sign extension for KIND=1.
+ auto ch{static_cast<std::uint64_t>(c[0])};
+ switch (c.kind()) {
+ case 1:
+ return static_cast<std::int64_t>(ch & 0xffu);
+ case 2:
+ return static_cast<std::int64_t>(ch & 0xffffu);
+ case 4:
+ return static_cast<std::int64_t>(ch & 0xffffffffu);
+ }
+ llvm_unreachable("unsupported character kind");
}
- static Character NEW_LINE() { return Character{{NewLine()}}; }
+ static CharacterValue NEW_LINE(int kind) {
+ return CharacterOfKind(1, NewLine(), kind);
+ }
- static Character ADJUSTL(const Character &str) {
+ static CharacterValue ADJUSTL(const CharacterValue &str) {
auto pos{str.find_first_not_of(Space())};
- if (pos != Character::npos && pos != 0) {
- return Character{str.substr(pos) + Character(pos, Space())};
+ if (pos != CharacterValue::npos && pos != 0) {
+ return CharacterValue{
+ str.substr(pos) + CharacterOfKind(pos, Space(), str.kind())};
}
// else empty or only spaces, or no leading spaces
return str;
}
- static Character ADJUSTR(const Character &str) {
+ static CharacterValue ADJUSTR(const CharacterValue &str) {
auto pos{str.find_last_not_of(Space())};
- if (pos != Character::npos && pos != str.length() - 1) {
+ if (pos != CharacterValue::npos && pos != str.length() - 1) {
auto delta{str.length() - 1 - pos};
- return Character{Character(delta, Space()) + str.substr(0, pos + 1)};
+ return CharacterValue{
+ CharacterOfKind(delta, Space(), str.kind()) + str.substr(0, pos + 1)};
}
// else empty or only spaces, or no trailing spaces
return str;
}
- static ConstantSubscript INDEX(
- const Character &str, const Character &substr, bool back = false) {
+ static ConstantSubscript INDEX(const CharacterValue &str,
+ const CharacterValue &substr, bool back = false) {
auto pos{back ? str.rfind(substr) : str.find(substr)};
return static_cast<ConstantSubscript>(pos == str.npos ? 0 : pos + 1);
}
static ConstantSubscript SCAN(
- const Character &str, const Character &set, bool back = false) {
+ const CharacterValue &str, const CharacterValue &set, bool back = false) {
auto pos{back ? str.find_last_of(set) : str.find_first_of(set)};
return static_cast<ConstantSubscript>(pos == str.npos ? 0 : pos + 1);
}
static ConstantSubscript VERIFY(
- const Character &str, const Character &set, bool back = false) {
+ const CharacterValue &str, const CharacterValue &set, bool back = false) {
auto pos{back ? str.find_last_not_of(set) : str.find_first_not_of(set)};
return static_cast<ConstantSubscript>(pos == str.npos ? 0 : pos + 1);
}
// Resize adds spaces on the right if the new size is bigger than the
// original, or by trimming the rightmost characters otherwise.
- static Character Resize(const Character &str, std::size_t newLength) {
+ static CharacterValue Resize(
+ const CharacterValue &str, std::size_t newLength) {
auto oldLength{str.length()};
if (newLength > oldLength) {
- return str + Character(newLength - oldLength, Space());
+ return str + CharacterOfKind(newLength - oldLength, Space(), str.kind());
} else {
return str.substr(0, newLength);
}
}
- static ConstantSubscript LEN_TRIM(const Character &str) {
+ static ConstantSubscript LEN_TRIM(const CharacterValue &str) {
auto j{str.length()};
for (; j >= 1; --j) {
- if (str[j - 1] != ' ') {
+ if (str[j - 1] != CharT{0x20}) {
break;
}
}
return static_cast<ConstantSubscript>(j);
}
- static Character REPEAT(const Character &str, ConstantSubscript ncopies) {
- Character result;
+ static CharacterValue REPEAT(
+ const CharacterValue &str, ConstantSubscript ncopies) {
+ CharacterValue result{CharacterOfKind(0, CharT{}, str.kind())};
if (!str.empty() && ncopies > 0) {
result.reserve(ncopies * str.size());
while (ncopies-- > 0) {
@@ -107,7 +124,7 @@ template <int KIND> class CharacterUtils {
return result;
}
- static Character TRIM(const Character &str) {
+ static CharacterValue TRIM(const CharacterValue &str) {
return str.substr(0, LEN_TRIM(str));
}
@@ -115,6 +132,18 @@ template <int KIND> class CharacterUtils {
// Following helpers assume that character encodings contain ASCII
static constexpr CharT Space() { return 0x20; }
static constexpr CharT NewLine() { return 0x0a; }
+
+ static CharacterValue CharacterOfKind(std::size_t n, CharT ch, int kind) {
+ switch (kind) {
+ case 1:
+ return CharacterValue(n, static_cast<char>(ch));
+ case 2:
+ return CharacterValue(n, static_cast<char16_t>(ch));
+ case 4:
+ return CharacterValue(n, ch);
+ }
+ llvm_unreachable("unsupported character kind");
+ }
};
} // namespace Fortran::evaluate
diff --git a/flang/lib/Evaluate/characteristics.cpp b/flang/lib/Evaluate/characteristics.cpp
index 63d4c74d553e3..b950c46e5dead 100644
--- a/flang/lib/Evaluate/characteristics.cpp
+++ b/flang/lib/Evaluate/characteristics.cpp
@@ -195,9 +195,11 @@ std::optional<Expr<SubscriptInteger>> TypeAndShape::MeasureElementSizeInBytes(
CHECK(type_.category() == TypeCategory::Character);
return Fold(foldingContext,
Expr<SubscriptInteger>{
- foldingContext.targetCharacteristics().GetByteSize(
- type_.category(), type_.kind())} *
- Expr<SubscriptInteger>{*LEN_});
+ Constant<SubscriptInteger>{SubscriptInteger::Scalar{
+ foldingContext.targetCharacteristics().GetByteSize(
+ type_.category(), type_.kind()),
+ subscriptIntegerKind}}} *
+ common::Clone(*LEN_));
}
if (auto elementBytes{type_.MeasureSizeInBytes(foldingContext, align)}) {
return Fold(foldingContext, std::move(*elementBytes));
diff --git a/flang/lib/Evaluate/check-expression.cpp b/flang/lib/Evaluate/check-expression.cpp
index 62c93e5d20737..451b867661204 100644
--- a/flang/lib/Evaluate/check-expression.cpp
+++ b/flang/lib/Evaluate/check-expression.cpp
@@ -71,10 +71,8 @@ class IsConstantExprHelper
return (*this)(component.base());
}
// Prevent integer division by known zeroes in constant expressions.
- template <int KIND>
- bool operator()(
- const Divide<Type<TypeCategory::Integer, KIND>> &division) const {
- using T = Type<TypeCategory::Integer, KIND>;
+ bool operator()(const Divide<Type<TypeCategory::Integer>> &division) const {
+ using T = Type<TypeCategory::Integer>;
if ((*this)(division.left()) && (*this)(division.right())) {
const auto divisor{GetScalarConstantValue<T>(division.right())};
return !divisor || !divisor->IsZero();
@@ -475,9 +473,9 @@ class SuspiciousRealLiteralFinder
SuspiciousRealLiteralFinder(int kind, FoldingContext &c)
: Base{*this}, kind_{kind}, context_{c} {}
using Base::operator();
- template <int KIND>
- bool operator()(const Constant<Type<TypeCategory::Real, KIND>> &x) const {
- if (kind_ > KIND && x.result().isFromInexactLiteralConversion()) {
+ bool operator()(const Constant<Type<TypeCategory::Real>> &x) const {
+ if (kind_ > x.result().kind() &&
+ x.result().isFromInexactLiteralConversion()) {
context_.Warn(common::UsageWarning::RealConstantWidening,
"Default real literal in REAL(%d) context might need a kind suffix, as its rounded value %s is inexact"_warn_en_US,
kind_, x.AsFortran());
@@ -486,9 +484,9 @@ class SuspiciousRealLiteralFinder
return false;
}
}
- template <int KIND>
- bool operator()(const Constant<Type<TypeCategory::Complex, KIND>> &x) const {
- if (kind_ > KIND && x.result().isFromInexactLiteralConversion()) {
+ bool operator()(const Constant<Type<TypeCategory::Complex>> &x) const {
+ if (kind_ > x.result().kind() &&
+ x.result().isFromInexactLiteralConversion()) {
context_.Warn(common::UsageWarning::RealConstantWidening,
"Default real literal in COMPLEX(%d) context might need a kind suffix, as its rounded value %s is inexact"_warn_en_US,
kind_, x.AsFortran());
@@ -497,13 +495,14 @@ class SuspiciousRealLiteralFinder
return false;
}
}
- template <TypeCategory TOCAT, int TOKIND, TypeCategory FROMCAT>
- bool operator()(const Convert<Type<TOCAT, TOKIND>, FROMCAT> &x) const {
+ template <TypeCategory TOCAT, TypeCategory FROMCAT>
+ bool operator()(const Convert<Type<TOCAT>, FROMCAT> &x) const {
if constexpr ((TOCAT == TypeCategory::Real ||
TOCAT == TypeCategory::Complex) &&
(FROMCAT == TypeCategory::Real || FROMCAT == TypeCategory::Complex)) {
auto fromType{x.left().GetType()};
- if (!fromType || fromType->kind() < TOKIND) {
+ auto toType{x.GetType()};
+ if (!fromType || !toType || fromType->kind() < toType->kind()) {
return false;
}
}
@@ -542,9 +541,8 @@ class InexactLiteralConversionFlagClearer
using Base = AnyTraverse<InexactLiteralConversionFlagClearer>;
InexactLiteralConversionFlagClearer() : Base(*this) {}
using Base::operator();
- template <int KIND>
- bool operator()(const Constant<Type<TypeCategory::Real, KIND>> &x) const {
- auto &mut{const_cast<Type<TypeCategory::Real, KIND> &>(x.result())};
+ bool operator()(const Constant<Type<TypeCategory::Real>> &x) const {
+ auto &mut{const_cast<Type<TypeCategory::Real> &>(x.result())};
mut.set_isFromInexactLiteralConversion(false);
return false;
}
diff --git a/flang/lib/Evaluate/complex-value.cpp b/flang/lib/Evaluate/complex-value.cpp
new file mode 100644
index 0000000000000..c240c083afd5e
--- /dev/null
+++ b/flang/lib/Evaluate/complex-value.cpp
@@ -0,0 +1,269 @@
+//===-- lib/Evaluate/complex-value.cpp ------------------------------------===//
+//
+// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
+// See https://llvm.org/LICENSE.txt for license information.
+// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
+//
+//===----------------------------------------------------------------------===//
+
+#include "flang/Evaluate/complex-value.h"
+#include "flang/Common/idioms.h"
+#include "llvm/Support/raw_ostream.h"
+#include <string>
+
+namespace Fortran::evaluate::value {
+
+// ============================================================================
+// ComplexValue out-of-line definitions.
+// ============================================================================
+
+int ComplexValue::kind() const {
+ if (IsMonostate()) {
+ llvm_unreachable("uninitialized value has not a kind assigned");
+ }
+ return re_.kind();
+}
+
+int ComplexValue::bits() const { return REAL().bits() + AIMAG().bits(); }
+
+ComplexValue ComplexValue::Zero(int kind) {
+ RealValue zero{RealValue::Zero(kind)};
+ return ComplexValue{zero, zero};
+}
+
+ComplexValue ComplexValue::FromRawBytes(const void *raw, std::size_t bytes) {
+ CHECK(bytes % 2 == 0);
+ std::size_t partBytes{bytes / 2};
+ const char *data{static_cast<const char *>(raw)};
+ RealValue realPart{RealValue::FromRawBytes(data, partBytes)};
+ RealValue imagPart{RealValue::FromRawBytes(data + partBytes, partBytes)};
+ return {realPart, imagPart};
+}
+
+bool ComplexValue::StoreRawBytes(void *to, std::size_t strideBytes) const {
+ CHECK(strideBytes % 2 == 0);
+ if (IsMonostate()) {
+ llvm_unreachable("uninitialized value");
+ }
+ auto *bytes{static_cast<char *>(to)};
+ std::size_t partBytes{strideBytes / 2};
+ bool changed{false};
+ changed = re_.StoreRawBytes(bytes, partBytes) || changed;
+ changed = im_.StoreRawBytes(bytes + partBytes, partBytes) || changed;
+ return changed;
+}
+
+bool ComplexValue::IsZero() const { return re_.IsZero() && im_.IsZero(); }
+
+bool ComplexValue::IsInfinite() const {
+ return re_.IsInfinite() || im_.IsInfinite();
+}
+
+bool ComplexValue::IsNotANumber() const {
+ return re_.IsNotANumber() || im_.IsNotANumber();
+}
+
+bool ComplexValue::IsSignalingNaN() const {
+ return re_.IsSignalingNaN() || im_.IsSignalingNaN();
+}
+
+bool ComplexValue::operator==(const ComplexValue &y) const {
+ if (IsMonostate() || y.IsMonostate()) {
+ return IsMonostate() && y.IsMonostate();
+ }
+ return re_ == y.re_ && im_ == y.im_;
+}
+
+bool ComplexValue::Equals(const ComplexValue &y) const {
+ if (IsMonostate()) {
+ llvm_unreachable("uncomparable values");
+ }
+ return re_.Compare(y.re_) == Relation::Equal &&
+ im_.Compare(y.im_) == Relation::Equal;
+}
+
+RealValue ComplexValue::REAL() const { return re_; }
+
+RealValue ComplexValue::AIMAG() const { return im_; }
+
+ComplexValue ComplexValue::CONJG() const {
+ if (IsMonostate()) {
+ return ComplexValue{};
+ }
+ return ComplexValue{re_, im_.Negate()};
+}
+
+ComplexValue ComplexValue::Negate() const {
+ if (IsMonostate()) {
+ return ComplexValue{};
+ }
+ return ComplexValue{re_.Negate(), im_.Negate()};
+}
+
+ComplexValue ComplexValue::FlushSubnormalToZero() const {
+ if (IsMonostate()) {
+ return ComplexValue{};
+ }
+ return ComplexValue{re_.FlushSubnormalToZero(), im_.FlushSubnormalToZero()};
+}
+
+ValueWithRealFlags<ComplexValue> ComplexValue::Add(
+ const ComplexValue &y, Rounding rounding) const {
+ if (IsMonostate()) {
+ llvm_unreachable("unsupported operation over uninitialized value");
+ }
+ RealFlags flags;
+ RealValue reSum{re_.Add(y.re_, rounding).AccumulateFlags(flags)};
+ RealValue imSum{im_.Add(y.im_, rounding).AccumulateFlags(flags)};
+ return {ComplexValue{reSum, imSum}, flags};
+}
+
+ValueWithRealFlags<ComplexValue> ComplexValue::Subtract(
+ const ComplexValue &y, Rounding rounding) const {
+ if (IsMonostate()) {
+ llvm_unreachable("unsupported operation over uninitialized value");
+ }
+ RealFlags flags;
+ RealValue reDiff{re_.Subtract(y.re_, rounding).AccumulateFlags(flags)};
+ RealValue imDiff{im_.Subtract(y.im_, rounding).AccumulateFlags(flags)};
+ return {ComplexValue{reDiff, imDiff}, flags};
+}
+
+ValueWithRealFlags<ComplexValue> ComplexValue::Multiply(
+ const ComplexValue &y, Rounding rounding) const {
+ if (IsMonostate()) {
+ llvm_unreachable("unsupported operation over uninitialized value");
+ }
+ // (a + ib)*(c + id) -> ac - bd + i(ad + bc)
+ RealFlags flags;
+ RealValue ac{re_.Multiply(y.re_, rounding).AccumulateFlags(flags)};
+ RealValue bd{im_.Multiply(y.im_, rounding).AccumulateFlags(flags)};
+ RealValue ad{re_.Multiply(y.im_, rounding).AccumulateFlags(flags)};
+ RealValue bc{im_.Multiply(y.re_, rounding).AccumulateFlags(flags)};
+ RealValue acbd{ac.Subtract(bd, rounding).AccumulateFlags(flags)};
+ RealValue adbc{ad.Add(bc, rounding).AccumulateFlags(flags)};
+ return {ComplexValue{acbd, adbc}, flags};
+}
+
+ValueWithRealFlags<ComplexValue> ComplexValue::Divide(
+ const ComplexValue &that, Rounding rounding) const {
+ if (IsMonostate()) {
+ llvm_unreachable("unsupported operation over uninitialized value");
+ }
+ // (a + ib)/(c + id) -> [(a+ib)*(c-id)] / [(c+id)*(c-id)]
+ // -> [ac+bd+i(bc-ad)] / (cc+dd) -- note (cc+dd) is real
+ // -> ((ac+bd)/(cc+dd)) + i((bc-ad)/(cc+dd))
+ RealFlags flags;
+ RealValue cc{that.re_.Multiply(that.re_, rounding).AccumulateFlags(flags)};
+ RealValue dd{that.im_.Multiply(that.im_, rounding).AccumulateFlags(flags)};
+ RealValue ccPdd{cc.Add(dd, rounding).AccumulateFlags(flags)};
+ if (!flags.test(RealFlag::Overflow) && !flags.test(RealFlag::Underflow)) {
+ // den = (cc+dd) did not overflow or underflow; try the naive
+ // sequence without scaling to avoid extra roundings.
+ RealValue ac{re_.Multiply(that.re_, rounding).AccumulateFlags(flags)};
+ RealValue ad{re_.Multiply(that.im_, rounding).AccumulateFlags(flags)};
+ RealValue bc{im_.Multiply(that.re_, rounding).AccumulateFlags(flags)};
+ RealValue bd{im_.Multiply(that.im_, rounding).AccumulateFlags(flags)};
+ RealValue acPbd{ac.Add(bd, rounding).AccumulateFlags(flags)};
+ RealValue bcSad{bc.Subtract(ad, rounding).AccumulateFlags(flags)};
+ RealValue re{acPbd.Divide(ccPdd, rounding).AccumulateFlags(flags)};
+ RealValue im{bcSad.Divide(ccPdd, rounding).AccumulateFlags(flags)};
+ if (!flags.test(RealFlag::Overflow) && !flags.test(RealFlag::Underflow)) {
+ return {ComplexValue{re, im}, flags};
+ }
+ }
+ // Scale numerator and denominator by d/c (if c>=d) or c/d (if c<d)
+ flags.clear();
+ RealValue scale; // will be <= 1.0 in magnitude
+ bool cGEd{that.re_.ABS().Compare(that.im_.ABS()) != Relation::Less};
+ if (cGEd) {
+ scale = that.im_.Divide(that.re_, rounding).AccumulateFlags(flags);
+ } else {
+ scale = that.re_.Divide(that.im_, rounding).AccumulateFlags(flags);
+ }
+ RealValue den;
+ if (cGEd) {
+ RealValue dS{scale.Multiply(that.im_, rounding).AccumulateFlags(flags)};
+ den = dS.Add(that.re_, rounding).AccumulateFlags(flags);
+ } else {
+ RealValue cS{scale.Multiply(that.re_, rounding).AccumulateFlags(flags)};
+ den = cS.Add(that.im_, rounding).AccumulateFlags(flags);
+ }
+ RealValue aS{scale.Multiply(re_, rounding).AccumulateFlags(flags)};
+ RealValue bS{scale.Multiply(im_, rounding).AccumulateFlags(flags)};
+ RealValue re1, im1;
+ if (cGEd) {
+ re1 = re_.Add(bS, rounding).AccumulateFlags(flags);
+ im1 = im_.Subtract(aS, rounding).AccumulateFlags(flags);
+ } else {
+ re1 = aS.Add(im_, rounding).AccumulateFlags(flags);
+ im1 = bS.Subtract(re_, rounding).AccumulateFlags(flags);
+ }
+ RealValue re{re1.Divide(den, rounding).AccumulateFlags(flags)};
+ RealValue im{im1.Divide(den, rounding).AccumulateFlags(flags)};
+ return {ComplexValue{re, im}, flags};
+}
+
+ValueWithRealFlags<RealValue> ComplexValue::ABS(Rounding rounding) const {
+ if (IsMonostate()) {
+ return ValueWithRealFlags<RealValue>{};
+ }
+ return re_.HYPOT(im_, rounding);
+}
+
+ComplexValue ComplexValue::ConvertToKind(int kind) const {
+ if (IsMonostate()) {
+ return ComplexValue{};
+ }
+ return ComplexValue{re_.ConvertToKind(kind), im_.ConvertToKind(kind)};
+}
+
+ValueWithRealFlags<ComplexValue> ComplexValue::FromInteger(
+ const IntegerValue &n, int kind, bool isUnsigned, Rounding rounding) {
+ if (n.IsMonostate()) {
+ return ValueWithRealFlags<ComplexValue>{};
+ }
+ ValueWithRealFlags<ComplexValue> result;
+ result.value.re_ = RealValue::FromInteger(n, kind, isUnsigned, rounding)
+ .AccumulateFlags(result.flags);
+ result.value.im_ = RealValue::Zero(kind);
+ return result;
+}
+
+ValueWithRealFlags<ComplexValue> ComplexValue::KahanSummation(
+ const ComplexValue &y, ComplexValue &correction, Rounding rounding) const {
+ if (IsMonostate()) {
+ return ValueWithRealFlags<ComplexValue>{};
+ }
+ RealFlags flags;
+ RealValue reSum{re_.KahanSummation(y.re_, correction.re_, rounding)
+ .AccumulateFlags(flags)};
+ RealValue imSum{im_.KahanSummation(y.im_, correction.im_, rounding)
+ .AccumulateFlags(flags)};
+ return {ComplexValue{reSum, imSum}, flags};
+}
+
+std::string ComplexValue::DumpHexadecimal() const {
+ if (IsMonostate()) {
+ llvm_unreachable("unsupported operation over uninitialized value");
+ }
+ std::string result{'('};
+ result += re_.DumpHexadecimal();
+ result += ',';
+ result += im_.DumpHexadecimal();
+ result += ')';
+ return result;
+}
+
+llvm::raw_ostream &ComplexValue::AsFortran(
+ llvm::raw_ostream &o, int kind) const {
+ if (IsMonostate()) {
+ o << "0";
+ return o;
+ }
+ re_.AsFortran(o << '(', kind);
+ im_.AsFortran(o << ',', kind);
+ return o << ')';
+}
+
+} // namespace Fortran::evaluate::value
diff --git a/flang/lib/Evaluate/complex.cpp b/flang/lib/Evaluate/complex.cpp
deleted file mode 100644
index a245fb38c82b9..0000000000000
--- a/flang/lib/Evaluate/complex.cpp
+++ /dev/null
@@ -1,136 +0,0 @@
-//===-- lib/Evaluate/complex.cpp ------------------------------------------===//
-//
-// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
-// See https://llvm.org/LICENSE.txt for license information.
-// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
-//
-//===----------------------------------------------------------------------===//
-
-#include "flang/Evaluate/complex.h"
-#include "llvm/Support/raw_ostream.h"
-
-namespace Fortran::evaluate::value {
-
-template <typename R>
-ValueWithRealFlags<Complex<R>> Complex<R>::Add(
- const Complex &that, Rounding rounding) const {
- RealFlags flags;
- Part reSum{re_.Add(that.re_, rounding).AccumulateFlags(flags)};
- Part imSum{im_.Add(that.im_, rounding).AccumulateFlags(flags)};
- return {Complex{reSum, imSum}, flags};
-}
-
-template <typename R>
-ValueWithRealFlags<Complex<R>> Complex<R>::Subtract(
- const Complex &that, Rounding rounding) const {
- RealFlags flags;
- Part reDiff{re_.Subtract(that.re_, rounding).AccumulateFlags(flags)};
- Part imDiff{im_.Subtract(that.im_, rounding).AccumulateFlags(flags)};
- return {Complex{reDiff, imDiff}, flags};
-}
-
-template <typename R>
-ValueWithRealFlags<Complex<R>> Complex<R>::Multiply(
- const Complex &that, Rounding rounding) const {
- // (a + ib)*(c + id) -> ac - bd + i(ad + bc)
- RealFlags flags;
- Part ac{re_.Multiply(that.re_, rounding).AccumulateFlags(flags)};
- Part bd{im_.Multiply(that.im_, rounding).AccumulateFlags(flags)};
- Part ad{re_.Multiply(that.im_, rounding).AccumulateFlags(flags)};
- Part bc{im_.Multiply(that.re_, rounding).AccumulateFlags(flags)};
- Part acbd{ac.Subtract(bd, rounding).AccumulateFlags(flags)};
- Part adbc{ad.Add(bc, rounding).AccumulateFlags(flags)};
- return {Complex{acbd, adbc}, flags};
-}
-
-template <typename R>
-ValueWithRealFlags<Complex<R>> Complex<R>::Divide(
- const Complex &that, Rounding rounding) const {
- // (a + ib)/(c + id) -> [(a+ib)*(c-id)] / [(c+id)*(c-id)]
- // -> [ac+bd+i(bc-ad)] / (cc+dd) -- note (cc+dd) is real
- // -> ((ac+bd)/(cc+dd)) + i((bc-ad)/(cc+dd))
- RealFlags flags;
- Part cc{that.re_.Multiply(that.re_, rounding).AccumulateFlags(flags)};
- Part dd{that.im_.Multiply(that.im_, rounding).AccumulateFlags(flags)};
- Part ccPdd{cc.Add(dd, rounding).AccumulateFlags(flags)};
- if (!flags.test(RealFlag::Overflow) && !flags.test(RealFlag::Underflow)) {
- // den = (cc+dd) did not overflow or underflow; try the naive
- // sequence without scaling to avoid extra roundings.
- Part ac{re_.Multiply(that.re_, rounding).AccumulateFlags(flags)};
- Part ad{re_.Multiply(that.im_, rounding).AccumulateFlags(flags)};
- Part bc{im_.Multiply(that.re_, rounding).AccumulateFlags(flags)};
- Part bd{im_.Multiply(that.im_, rounding).AccumulateFlags(flags)};
- Part acPbd{ac.Add(bd, rounding).AccumulateFlags(flags)};
- Part bcSad{bc.Subtract(ad, rounding).AccumulateFlags(flags)};
- Part re{acPbd.Divide(ccPdd, rounding).AccumulateFlags(flags)};
- Part im{bcSad.Divide(ccPdd, rounding).AccumulateFlags(flags)};
- if (!flags.test(RealFlag::Overflow) && !flags.test(RealFlag::Underflow)) {
- return {Complex{re, im}, flags};
- }
- }
- // Scale numerator and denominator by d/c (if c>=d) or c/d (if c<d)
- flags.clear();
- Part scale; // will be <= 1.0 in magnitude
- bool cGEd{that.re_.ABS().Compare(that.im_.ABS()) != Relation::Less};
- if (cGEd) {
- scale = that.im_.Divide(that.re_, rounding).AccumulateFlags(flags);
- } else {
- scale = that.re_.Divide(that.im_, rounding).AccumulateFlags(flags);
- }
- Part den;
- if (cGEd) {
- Part dS{scale.Multiply(that.im_, rounding).AccumulateFlags(flags)};
- den = dS.Add(that.re_, rounding).AccumulateFlags(flags);
- } else {
- Part cS{scale.Multiply(that.re_, rounding).AccumulateFlags(flags)};
- den = cS.Add(that.im_, rounding).AccumulateFlags(flags);
- }
- Part aS{scale.Multiply(re_, rounding).AccumulateFlags(flags)};
- Part bS{scale.Multiply(im_, rounding).AccumulateFlags(flags)};
- Part re1, im1;
- if (cGEd) {
- re1 = re_.Add(bS, rounding).AccumulateFlags(flags);
- im1 = im_.Subtract(aS, rounding).AccumulateFlags(flags);
- } else {
- re1 = aS.Add(im_, rounding).AccumulateFlags(flags);
- im1 = bS.Subtract(re_, rounding).AccumulateFlags(flags);
- }
- Part re{re1.Divide(den, rounding).AccumulateFlags(flags)};
- Part im{im1.Divide(den, rounding).AccumulateFlags(flags)};
- return {Complex{re, im}, flags};
-}
-
-template <typename R>
-ValueWithRealFlags<Complex<R>> Complex<R>::KahanSummation(
- const Complex &that, Complex &correction, Rounding rounding) const {
- RealFlags flags;
- Part reSum{re_.KahanSummation(that.re_, correction.re_, rounding)
- .AccumulateFlags(flags)};
- Part imSum{im_.KahanSummation(that.im_, correction.im_, rounding)
- .AccumulateFlags(flags)};
- return {Complex{reSum, imSum}, flags};
-}
-
-template <typename R> std::string Complex<R>::DumpHexadecimal() const {
- std::string result{'('};
- result += re_.DumpHexadecimal();
- result += ',';
- result += im_.DumpHexadecimal();
- result += ')';
- return result;
-}
-
-template <typename R>
-llvm::raw_ostream &Complex<R>::AsFortran(llvm::raw_ostream &o, int kind) const {
- re_.AsFortran(o << '(', kind);
- im_.AsFortran(o << ',', kind);
- return o << ')';
-}
-
-template class Complex<Real<Integer<16>, 11>>;
-template class Complex<Real<Integer<16>, 8>>;
-template class Complex<Real<Integer<32>, 24>>;
-template class Complex<Real<Integer<64>, 53>>;
-template class Complex<Real<X87IntegerContainer, 64>>;
-template class Complex<Real<Integer<128>, 113>>;
-} // namespace Fortran::evaluate::value
diff --git a/flang/lib/Evaluate/constant.cpp b/flang/lib/Evaluate/constant.cpp
index 7fe000892ac1a..09bdb492b4d17 100644
--- a/flang/lib/Evaluate/constant.cpp
+++ b/flang/lib/Evaluate/constant.cpp
@@ -87,7 +87,7 @@ std::optional<uint64_t> TotalElementCount(const ConstantSubscripts &shape) {
CHECK(dim >= 0);
uint64_t osize{size};
size = osize * dim;
- if (size > std::numeric_limits<decltype(dim)>::max() ||
+ if (size > (uint64_t)std::numeric_limits<decltype(dim)>::max() ||
(dim != 0 && size / dim != osize)) {
return std::nullopt;
}
@@ -154,6 +154,20 @@ ConstantBase<RESULT, ELEMENT>::~ConstantBase() {}
template <typename RESULT, typename ELEMENT>
bool ConstantBase<RESULT, ELEMENT>::operator==(const ConstantBase &that) const {
+ if constexpr (RESULT::category != TypeCategory::Derived) {
+ // Now that kind is a runtime property rather than a compile-time template
+ // parameter, two constants of the same category but different kinds are no
+ // longer distinct C++ types; they must be treated as unequal here (as they
+ // were in the baseline, where they were different types altogether) before
+ // comparing element values of mismatched storage widths.
+ // PAPAYA: In the baseline, `this` and `that` had the same type
+ // (ConstantBase<RESULT, ELEMENT>). Calling this when the kinds of RESULT
+ // are different was not possible. Type mismatch must have been resolved
+ // before.
+ if (GetType().kind() != that.GetType().kind()) {
+ return false;
+ }
+ }
return shape() == that.shape() && values_ == that.values_;
}
@@ -198,7 +212,16 @@ auto Constant<T>::At(const ConstantSubscripts &index) const -> Element {
template <typename T>
auto Constant<T>::Reshape(ConstantSubscripts &&dims) const -> Constant {
- return {Base::Reshape(dims), std::move(dims)};
+ // Preserve the runtime kind: rebuilding from just the reshaped values would
+ // lose it for an empty result (no element values to source a kind from).
+ // Consult both the Result and the element values as ConstantBase::GetType()
+ // does, but without calling GetType(), which would assert on a kind-0 empty
+ // constant.
+ int kind{Base::result().runtimeKind()};
+ if (kind == 0 && !Base::empty()) {
+ kind = Base::values_.front().kind();
+ }
+ return {Base::Reshape(dims), std::move(dims), typename Base::Result{kind}};
}
template <typename T>
@@ -207,25 +230,34 @@ std::size_t Constant<T>::CopyFrom(const Constant<T> &source, std::size_t count,
return Base::CopyFrom(source, count, resultSubscripts, dimOrder);
}
-// Constant<Type<TypeCategory::Character, KIND> specializations
-template <int KIND>
-Constant<Type<TypeCategory::Character, KIND>>::Constant(
- const Scalar<Result> &str)
- : values_{str}, length_{static_cast<ConstantSubscript>(values_.size())} {}
+// Constant<Type<TypeCategory::Character>> specialization
+Constant<Type<TypeCategory::Character>>::Constant(const Scalar<Result> &str)
+ : values_{str}, length_{static_cast<ConstantSubscript>(values_.size())},
+ kind_{values_.kind()} {}
-template <int KIND>
-Constant<Type<TypeCategory::Character, KIND>>::Constant(Scalar<Result> &&str)
- : values_{std::move(str)}, length_{static_cast<ConstantSubscript>(
- values_.size())} {}
+Constant<Type<TypeCategory::Character>>::Constant(Scalar<Result> &&str)
+ : values_{std::move(str)},
+ length_{static_cast<ConstantSubscript>(values_.size())},
+ kind_{values_.kind()} {}
-template <int KIND>
-Constant<Type<TypeCategory::Character, KIND>>::Constant(ConstantSubscript len,
+Constant<Type<TypeCategory::Character>>::Constant(ConstantSubscript len,
std::vector<Scalar<Result>> &&strings, ConstantSubscripts &&sh)
: ConstantBounds(std::move(sh)), length_{len} {
CHECK(TotalElementCount(shape()) &&
strings.size() == *TotalElementCount(shape()));
- values_.assign(strings.size() * length_,
- static_cast<typename Scalar<Result>::value_type>(' '));
+ // The character kind is a runtime property carried by the element strings.
+ kind_ = strings.empty() ? 1 : strings.front().kind();
+ switch (kind_) {
+ case 1:
+ values_.assign(strings.size() * length_, char{' '});
+ break;
+ case 2:
+ values_.assign(strings.size() * length_, static_cast<char16_t>(' '));
+ break;
+ default:
+ values_.assign(strings.size() * length_, static_cast<char32_t>(' '));
+ break;
+ }
ConstantSubscript at{0};
for (const auto &str : strings) {
auto strLen{static_cast<ConstantSubscript>(str.size())};
@@ -239,16 +271,13 @@ Constant<Type<TypeCategory::Character, KIND>>::Constant(ConstantSubscript len,
CHECK(at == static_cast<ConstantSubscript>(values_.size()));
}
-template <int KIND>
-Constant<Type<TypeCategory::Character, KIND>>::~Constant() {}
+Constant<Type<TypeCategory::Character>>::~Constant() {}
-template <int KIND>
-bool Constant<Type<TypeCategory::Character, KIND>>::empty() const {
+bool Constant<Type<TypeCategory::Character>>::empty() const {
return size() == 0;
}
-template <int KIND>
-std::size_t Constant<Type<TypeCategory::Character, KIND>>::size() const {
+std::size_t Constant<Type<TypeCategory::Character>>::size() const {
if (length_ == 0) {
std::optional<uint64_t> n{TotalElementCount(shape())};
CHECK(n);
@@ -258,23 +287,21 @@ std::size_t Constant<Type<TypeCategory::Character, KIND>>::size() const {
}
}
-template <int KIND>
-auto Constant<Type<TypeCategory::Character, KIND>>::At(
+auto Constant<Type<TypeCategory::Character>>::At(
const ConstantSubscripts &index) const -> Scalar<Result> {
auto offset{SubscriptsToOffset(index)};
return values_.substr(offset * length_, length_);
}
-template <int KIND>
-auto Constant<Type<TypeCategory::Character, KIND>>::Substring(
- ConstantSubscript lo, ConstantSubscript hi) const
- -> std::optional<Constant> {
+auto Constant<Type<TypeCategory::Character>>::Substring(ConstantSubscript lo,
+ ConstantSubscript hi) const -> std::optional<Constant> {
std::vector<Element> elements;
ConstantSubscript n{GetSize(shape())};
ConstantSubscript newLength{0};
if (lo > hi) { // zero-length results
while (n-- > 0) {
- elements.emplace_back(); // ""
+ // An empty string still carries the character kind of this constant.
+ elements.emplace_back(Scalar<Result>::Zero(kind_)); // ""
}
} else if (lo < 1 || hi > length_) {
return std::nullopt;
@@ -287,8 +314,7 @@ auto Constant<Type<TypeCategory::Character, KIND>>::Substring(
return Constant{newLength, std::move(elements), ConstantSubscripts{shape()}};
}
-template <int KIND>
-auto Constant<Type<TypeCategory::Character, KIND>>::Reshape(
+auto Constant<Type<TypeCategory::Character>>::Reshape(
ConstantSubscripts &&dims) const -> Constant<Result> {
std::optional<uint64_t> optN{TotalElementCount(dims)};
CHECK(optN);
@@ -307,11 +333,9 @@ auto Constant<Type<TypeCategory::Character, KIND>>::Reshape(
return {length_, std::move(elements), std::move(dims)};
}
-template <int KIND>
-std::size_t Constant<Type<TypeCategory::Character, KIND>>::CopyFrom(
- const Constant<Type<TypeCategory::Character, KIND>> &source,
- std::size_t count, ConstantSubscripts &resultSubscripts,
- const std::vector<int> *dimOrder) {
+std::size_t Constant<Type<TypeCategory::Character>>::CopyFrom(
+ const Constant<Type<TypeCategory::Character>> &source, std::size_t count,
+ ConstantSubscripts &resultSubscripts, const std::vector<int> *dimOrder) {
CHECK(length_ == source.length_);
if (length_ == 0) {
// It's possible that the array of strings consists of all empty strings.
@@ -320,12 +344,14 @@ std::size_t Constant<Type<TypeCategory::Character, KIND>>::CopyFrom(
return count;
} else {
std::size_t copied{0};
- std::size_t elementBytes{length_ * sizeof(decltype(values_[0]))};
+ std::size_t charSize{values_.charSize()};
+ std::size_t elementBytes{length_ * charSize};
ConstantSubscripts sourceSubscripts{source.lbounds()};
while (copied < count) {
- auto *dest{&values_.at(SubscriptsToOffset(resultSubscripts) * length_)};
- const auto *src{&source.values_.at(
- source.SubscriptsToOffset(sourceSubscripts) * length_)};
+ auto *dest{static_cast<char *>(values_.charData()) +
+ SubscriptsToOffset(resultSubscripts) * elementBytes};
+ const auto *src{static_cast<const char *>(source.values_.charData()) +
+ source.SubscriptsToOffset(sourceSubscripts) * elementBytes};
std::memcpy(dest, src, elementBytes);
copied++;
source.IncrementSubscripts(sourceSubscripts);
diff --git a/flang/lib/Evaluate/expression.cpp b/flang/lib/Evaluate/expression.cpp
index 128c39b3eb004..867ed883c43ce 100644
--- a/flang/lib/Evaluate/expression.cpp
+++ b/flang/lib/Evaluate/expression.cpp
@@ -26,14 +26,14 @@ using namespace Fortran::parser::literals;
namespace Fortran::evaluate {
-template <int KIND>
std::optional<Expr<SubscriptInteger>>
-Expr<Type<TypeCategory::Character, KIND>>::LEN() const {
+Expr<Type<TypeCategory::Character>>::LEN() const {
using T = std::optional<Expr<SubscriptInteger>>;
return common::visit(
common::visitors{
[](const Constant<Result> &c) -> T {
- return AsExpr(Constant<SubscriptInteger>{c.LEN()});
+ return AsExpr(Constant<SubscriptInteger>{
+ SubscriptInteger::Scalar{c.LEN(), subscriptIntegerKind}});
},
[](const ArrayConstructor<Result> &a) -> T {
if (const auto *len{a.LEN()}) {
@@ -47,7 +47,7 @@ Expr<Type<TypeCategory::Character, KIND>>::LEN() const {
return common::visit(
[&](const auto &kx) { return kx.LEN(); }, x.left().u);
},
- [](const Concat<KIND> &c) -> T {
+ [](const Concat &c) -> T {
if (auto llen{c.left().LEN()}) {
if (auto rlen{c.right().LEN()}) {
return *std::move(llen) + *std::move(rlen);
@@ -76,7 +76,7 @@ Expr<Type<TypeCategory::Character, KIND>>::LEN() const {
},
[](const Designator<Result> &dr) { return dr.LEN(); },
[](const FunctionRef<Result> &fr) { return fr.LEN(); },
- [](const SetLength<KIND> &x) -> T { return x.right(); },
+ [](const SetLength &x) -> T { return x.right(); },
},
u);
}
@@ -97,18 +97,16 @@ const typename ExpressionBase<A>::Derived &ExpressionBase<A>::derived() const {
template <typename A>
std::optional<DynamicType> ExpressionBase<A>::GetType() const {
- if constexpr (IsLengthlessIntrinsicType<Result>) {
- return Result::GetType();
- } else {
- return common::visit(
- [&](const auto &x) -> std::optional<DynamicType> {
- if constexpr (!common::HasMember<decltype(x), TypelessExpression>) {
- return x.GetType();
- }
- return std::nullopt; // w/o "else" to dodge bogus g++ 8.1 warning
- },
- derived().u);
- }
+ // The kind is a runtime property of the active alternative now, so always
+ // recover the type by visiting rather than from a compile-time Result.
+ return common::visit(
+ [&](const auto &x) -> std::optional<DynamicType> {
+ if constexpr (!common::HasMember<decltype(x), TypelessExpression>) {
+ return x.GetType();
+ }
+ return std::nullopt; // w/o "else" to dodge bogus g++ 8.1 warning
+ },
+ derived().u);
}
template <typename A> int ExpressionBase<A>::Rank() const {
@@ -157,8 +155,7 @@ bool ConditionalExpr<A>::operator==(const ConditionalExpr &that) const {
elseValue_ == that.elseValue_;
}
-template <int KIND>
-bool LogicalOperation<KIND>::operator==(const LogicalOperation &that) const {
+bool LogicalOperation::operator==(const LogicalOperation &that) const {
return logicalOperator == that.logicalOperator && Base::operator==(that);
}
@@ -194,15 +191,13 @@ bool ArrayConstructorValues<R>::operator==(
return values_ == that.values_;
}
-template <int KIND>
-auto ArrayConstructor<Type<TypeCategory::Character, KIND>>::set_LEN(
+auto ArrayConstructor<Type<TypeCategory::Character>>::set_LEN(
Expr<SubscriptInteger> &&len) -> ArrayConstructor & {
length_.emplace(std::move(len));
return *this;
}
-template <int KIND>
-bool ArrayConstructor<Type<TypeCategory::Character, KIND>>::operator==(
+bool ArrayConstructor<Type<TypeCategory::Character>>::operator==(
const ArrayConstructor &that) const {
return length_ == that.length_ &&
static_cast<const Base &>(*this) == static_cast<const Base &>(that);
@@ -227,39 +222,33 @@ bool StructureConstructor::operator==(const StructureConstructor &that) const {
return result_ == that.result_ && values_ == that.values_;
}
-template <int KIND>
-bool Expr<Type<TypeCategory::Integer, KIND>>::operator==(
- const Expr<Type<TypeCategory::Integer, KIND>> &that) const {
+bool Expr<Type<TypeCategory::Integer>>::operator==(
+ const Expr<Type<TypeCategory::Integer>> &that) const {
return u == that.u;
}
-template <int KIND>
-bool Expr<Type<TypeCategory::Real, KIND>>::operator==(
- const Expr<Type<TypeCategory::Real, KIND>> &that) const {
+bool Expr<Type<TypeCategory::Real>>::operator==(
+ const Expr<Type<TypeCategory::Real>> &that) const {
return u == that.u;
}
-template <int KIND>
-bool Expr<Type<TypeCategory::Complex, KIND>>::operator==(
- const Expr<Type<TypeCategory::Complex, KIND>> &that) const {
+bool Expr<Type<TypeCategory::Complex>>::operator==(
+ const Expr<Type<TypeCategory::Complex>> &that) const {
return u == that.u;
}
-template <int KIND>
-bool Expr<Type<TypeCategory::Logical, KIND>>::operator==(
- const Expr<Type<TypeCategory::Logical, KIND>> &that) const {
+bool Expr<Type<TypeCategory::Logical>>::operator==(
+ const Expr<Type<TypeCategory::Logical>> &that) const {
return u == that.u;
}
-template <int KIND>
-bool Expr<Type<TypeCategory::Character, KIND>>::operator==(
- const Expr<Type<TypeCategory::Character, KIND>> &that) const {
+bool Expr<Type<TypeCategory::Character>>::operator==(
+ const Expr<Type<TypeCategory::Character>> &that) const {
return u == that.u;
}
-template <int KIND>
-bool Expr<Type<TypeCategory::Unsigned, KIND>>::operator==(
- const Expr<Type<TypeCategory::Unsigned, KIND>> &that) const {
+bool Expr<Type<TypeCategory::Unsigned>>::operator==(
+ const Expr<Type<TypeCategory::Unsigned>> &that) const {
return u == that.u;
}
@@ -370,15 +359,16 @@ void GenericAssignmentWrapper::Deleter(GenericAssignmentWrapper *p) {
}
template <TypeCategory CAT> int Expr<SomeKind<CAT>>::GetKind() const {
+ // Recover the kind from the runtime type of the active alternative rather
+ // than from its compile-time Result::kind, in preparation for removing the
+ // KIND template parameter from Type.
return common::visit(
- [](const auto &kx) { return std::decay_t<decltype(kx)>::Result::kind; },
- u);
+ [](const auto &kx) { return kx.GetType().value().kind(); }, u);
}
int Expr<SomeCharacter>::GetKind() const {
return common::visit(
- [](const auto &kx) { return std::decay_t<decltype(kx)>::Result::kind; },
- u);
+ [](const auto &kx) { return kx.GetType().value().kind(); }, u);
}
std::optional<Expr<SubscriptInteger>> Expr<SomeCharacter>::LEN() const {
diff --git a/flang/lib/Evaluate/fold-character.cpp b/flang/lib/Evaluate/fold-character.cpp
index a43742ae8dc68..df6a249e7a827 100644
--- a/flang/lib/Evaluate/fold-character.cpp
+++ b/flang/lib/Evaluate/fold-character.cpp
@@ -32,51 +32,78 @@ static std::optional<ConstantSubscript> GetConstantLength(
}
}
+// Dispatches a compile-time CHARACTER KIND to a runtime kind by invoking
+// f(std::integral_constant<int, KIND>{}). All branches must return the same
+// type.
+template <typename F> static auto WithCharKind(int kind, F &&f) {
+ switch (kind) {
+ case 2:
+ return f(std::integral_constant<int, 2>{});
+ case 4:
+ return f(std::integral_constant<int, 4>{});
+ default:
+ return f(std::integral_constant<int, 1>{});
+ }
+}
+
template <typename T>
static std::optional<Scalar<T>> Identity(
Scalar<T> str, std::optional<ConstantSubscript> len) {
if (len) {
- return CharacterUtils<T::kind>::REPEAT(
- str, std::max<ConstantSubscript>(*len, 0));
+ return CharacterUtils::REPEAT(str, std::max<ConstantSubscript>(*len, 0));
} else {
return std::nullopt;
}
}
-template <int KIND>
-Expr<Type<TypeCategory::Character, KIND>> FoldIntrinsicFunction(
+Expr<Type<TypeCategory::Character>> FoldIntrinsicFunction(
FoldingContext &context,
- FunctionRef<Type<TypeCategory::Character, KIND>> &&funcRef) {
- using T = Type<TypeCategory::Character, KIND>;
- using StringType = Scalar<T>; // std::string or larger
- using SingleCharType = typename StringType::value_type; // char &c.
+ FunctionRef<Type<TypeCategory::Character>> &&funcRef) {
+ using T = Type<TypeCategory::Character>;
+ using StringType = Scalar<T>; // CharacterValue
+ const int kind{funcRef.GetType().value().kind()};
auto *intrinsic{std::get_if<SpecificIntrinsic>(&funcRef.proc().u)};
CHECK(intrinsic);
std::string name{intrinsic->name};
if (name == "achar" || name == "char") {
using IntT = SubscriptInteger;
+ // The code argument is folded as a subscript-kind (KIND=8) integer; force
+ // that kind here (it is a runtime property now that the type is kindless)
+ // so that the range check and CHAR conversion below operate on a
+ // full-width value rather than the argument's narrower native kind.
+ Folder<IntT>(context, /*forOptionalArgument=*/false,
+ /*toKind=*/subscriptIntegerKind)
+ .Folding(funcRef.arguments().at(0));
return FoldElementalIntrinsic<T, IntT>(context, std::move(funcRef),
ScalarFunc<T, IntT>([&](const Scalar<IntT> &i) {
- if (i.IsNegative() || i.BGE(Scalar<IntT>{0}.IBSET(8 * KIND))) {
+ if (i.IsNegative() ||
+ i.BGE(value::IntegerValue{0, subscriptIntegerKind}.IBSET(
+ 8 * kind))) {
context.Warn(common::UsageWarning::FoldingValueChecks,
"%s(I=%jd) is out of range for CHARACTER(KIND=%d)"_warn_en_US,
parser::ToUpperCaseLetters(name),
- static_cast<std::intmax_t>(i.ToInt64()), KIND);
+ static_cast<std::intmax_t>(i.ToInt64()), kind);
}
- return CharacterUtils<KIND>::CHAR(i.ToUInt64());
+ return CharacterUtils::CHAR(i.ToUInt64(), kind);
}));
} else if (name == "adjustl") {
- return FoldElementalIntrinsic<T, T>(
- context, std::move(funcRef), CharacterUtils<KIND>::ADJUSTL);
+ return FoldElementalIntrinsic<T, T>(context, std::move(funcRef),
+ ScalarFunc<T, T>(
+ [](const Scalar<T> &s) { return CharacterUtils::ADJUSTL(s); }));
} else if (name == "adjustr") {
- return FoldElementalIntrinsic<T, T>(
- context, std::move(funcRef), CharacterUtils<KIND>::ADJUSTR);
+ return FoldElementalIntrinsic<T, T>(context, std::move(funcRef),
+ ScalarFunc<T, T>(
+ [](const Scalar<T> &s) { return CharacterUtils::ADJUSTR(s); }));
} else if (name == "max") {
return FoldMINorMAX(context, std::move(funcRef), Ordering::Greater);
} else if (name == "maxval") {
- SingleCharType least{0};
- if (auto identity{Identity<T>(
- StringType{least}, GetConstantLength(context, funcRef, 0))}) {
+ StringType least{WithCharKind(kind, [](auto k) {
+ using CharT = std::conditional_t<k.value == 1, char,
+ std::conditional_t<k.value == 2, char16_t, char32_t>>;
+ return StringType(std::size_t{1}, CharT{0});
+ })};
+ if (auto identity{
+ Identity<T>(least, GetConstantLength(context, funcRef, 0))}) {
return FoldMaxvalMinval<T>(
context, std::move(funcRef), RelationalOperator::GT, *identity);
}
@@ -84,15 +111,26 @@ Expr<Type<TypeCategory::Character, KIND>> FoldIntrinsicFunction(
return FoldMINorMAX(context, std::move(funcRef), Ordering::Less);
} else if (name == "minval") {
// Collating sequences correspond to positive integers (3.31)
- auto most{static_cast<SingleCharType>(0xffffffff >> (8 * (4 - KIND)))};
- if (auto identity{Identity<T>(
- StringType{most}, GetConstantLength(context, funcRef, 0))}) {
+ StringType most{WithCharKind(kind, [](auto k) {
+ using CharT = std::conditional_t<k.value == 1, char,
+ std::conditional_t<k.value == 2, char16_t, char32_t>>;
+ return StringType(std::size_t{1},
+ static_cast<CharT>(0xffffffffu >> (8 * (4 - k.value))));
+ })};
+ if (auto identity{
+ Identity<T>(most, GetConstantLength(context, funcRef, 0))}) {
return FoldMaxvalMinval<T>(
context, std::move(funcRef), RelationalOperator::LT, *identity);
}
} else if (name == "new_line") {
- return Expr<T>{Constant<T>{CharacterUtils<KIND>::NEW_LINE()}};
+ return Expr<T>{Constant<T>{CharacterUtils::NEW_LINE(kind)}};
} else if (name == "repeat") { // not elemental
+ // NCOPIES is folded as a subscript-kind (KIND=8) integer; force that kind
+ // (it is a runtime property now that the type is kindless) so the result
+ // length computation LEN(STRING)*NCOPIES uses a full-width value.
+ Folder<SubscriptInteger>(context, /*forOptionalArgument=*/false,
+ /*toKind=*/subscriptIntegerKind)
+ .Folding(funcRef.arguments().at(1));
if (auto scalars{GetScalarConstantArguments<T, SubscriptInteger>(
context, funcRef.arguments(), /*hasOptionalArgument=*/false)}) {
auto str{std::get<Scalar<T>>(*scalars)};
@@ -107,51 +145,58 @@ Expr<Type<TypeCategory::Character, KIND>> FoldIntrinsicFunction(
"Result of REPEAT() is too large to compute at compilation time (%g characters)"_port_en_US,
static_cast<double>(n) * str.size());
} else {
- return Expr<T>{Constant<T>{CharacterUtils<KIND>::REPEAT(str, n)}};
+ return Expr<T>{Constant<T>{CharacterUtils::REPEAT(str, n)}};
}
}
} else if (name == "trim") { // not elemental
if (auto scalar{GetScalarConstantArguments<T>(
context, funcRef.arguments(), /*hasOptionalArgument=*/false)}) {
- return Expr<T>{Constant<T>{
- CharacterUtils<KIND>::TRIM(std::get<Scalar<T>>(*scalar))}};
+ return Expr<T>{
+ Constant<T>{CharacterUtils::TRIM(std::get<Scalar<T>>(*scalar))}};
}
} else if (name == "__builtin_compiler_options") {
auto &o = context.targetCharacteristics().compilerOptionsString();
- return Expr<T>{Constant<T>{StringType(o.begin(), o.end())}};
+ return Expr<T>{Constant<T>{WithCharKind(kind, [&](auto k) {
+ using RawStr = std::conditional_t<k.value == 1, std::string,
+ std::conditional_t<k.value == 2, std::u16string, std::u32string>>;
+ return StringType{RawStr(o.begin(), o.end())};
+ })}};
} else if (name == "__builtin_compiler_version") {
auto &v = context.targetCharacteristics().compilerVersionString();
- return Expr<T>{Constant<T>{StringType(v.begin(), v.end())}};
+ return Expr<T>{Constant<T>{WithCharKind(kind, [&](auto k) {
+ using RawStr = std::conditional_t<k.value == 1, std::string,
+ std::conditional_t<k.value == 2, std::u16string, std::u32string>>;
+ return StringType{RawStr(v.begin(), v.end())};
+ })}};
}
return Expr<T>{std::move(funcRef)};
}
-template <int KIND>
-Expr<Type<TypeCategory::Character, KIND>> FoldOperation(
- FoldingContext &context, Concat<KIND> &&x) {
+Expr<Type<TypeCategory::Character>> FoldOperation(
+ FoldingContext &context, Concat &&x) {
if (auto array{ApplyElementwise(context, x)}) {
return *array;
}
- using Result = Type<TypeCategory::Character, KIND>;
+ using Result = Type<TypeCategory::Character>;
if (auto folded{OperandsAreConstants(x)}) {
return Expr<Result>{Constant<Result>{folded->first + folded->second}};
}
return Expr<Result>{std::move(x)};
}
-template <int KIND>
-Expr<Type<TypeCategory::Character, KIND>> FoldOperation(
- FoldingContext &context, SetLength<KIND> &&x) {
+Expr<Type<TypeCategory::Character>> FoldOperation(
+ FoldingContext &context, SetLength &&x) {
if (auto array{ApplyElementwise(context, x)}) {
return *array;
}
- using Result = Type<TypeCategory::Character, KIND>;
+ using Result = Type<TypeCategory::Character>;
if (auto folded{OperandsAreConstants(x)}) {
auto oldLength{static_cast<ConstantSubscript>(folded->first.size())};
auto newLength{folded->second.ToInt64()};
if (newLength < oldLength) {
folded->first.erase(newLength);
} else {
+ // append(n, char) widens the fill character to the string's element type.
folded->first.append(newLength - oldLength, ' ');
}
CHECK(static_cast<ConstantSubscript>(folded->first.size()) == newLength);
diff --git a/flang/lib/Evaluate/fold-complex.cpp b/flang/lib/Evaluate/fold-complex.cpp
index 84066ee5be71b..d2f7493f690d1 100644
--- a/flang/lib/Evaluate/fold-complex.cpp
+++ b/flang/lib/Evaluate/fold-complex.cpp
@@ -12,12 +12,11 @@
namespace Fortran::evaluate {
-template <int KIND>
-Expr<Type<TypeCategory::Complex, KIND>> FoldIntrinsicFunction(
- FoldingContext &context,
- FunctionRef<Type<TypeCategory::Complex, KIND>> &&funcRef) {
- using T = Type<TypeCategory::Complex, KIND>;
+Expr<Type<TypeCategory::Complex>> FoldIntrinsicFunction(FoldingContext &context,
+ FunctionRef<Type<TypeCategory::Complex>> &&funcRef) {
+ using T = Type<TypeCategory::Complex>;
using Part = typename T::Part;
+ const int kind{funcRef.GetType().value().kind()};
ActualArguments &args{funcRef.arguments()};
auto *intrinsic{std::get_if<SpecificIntrinsic>(&funcRef.proc().u)};
CHECK(intrinsic);
@@ -26,13 +25,13 @@ Expr<Type<TypeCategory::Complex, KIND>> FoldIntrinsicFunction(
name == "atan" || name == "atanh" || name == "cos" || name == "cosh" ||
name == "exp" || name == "log" || name == "sin" || name == "sinh" ||
name == "sqrt" || name == "tan" || name == "tanh") {
- if (auto callable{GetHostRuntimeWrapper<T, T>(name)}) {
+ if (auto callable{GetHostRuntimeWrapper<T, T>(name, kind)}) {
return FoldElementalIntrinsic<T, T>(
context, std::move(funcRef), *callable);
} else {
context.Warn(common::UsageWarning::FoldingFailure,
"%s(complex(kind=%d)) cannot be folded on host"_warn_en_US, name,
- KIND);
+ kind);
}
} else if (name == "conjg") {
return FoldElementalIntrinsic<T, T>(
@@ -41,7 +40,7 @@ Expr<Type<TypeCategory::Complex, KIND>> FoldIntrinsicFunction(
if (args.size() > 0 && args[0].has_value()) {
if (auto *x{UnwrapExpr<Expr<SomeComplex>>(args[0])}) {
// CMPLX(X [, KIND]) with complex X
- return Fold(context, ConvertToType<T>(std::move(*x)));
+ return Fold(context, ConvertToType<T>(kind, std::move(*x)));
} else {
if (args.size() >= 2 && args[1].has_value()) {
// Do not fold CMPLX with an Y argument that may be absent at runtime
@@ -56,11 +55,10 @@ Expr<Type<TypeCategory::Complex, KIND>> FoldIntrinsicFunction(
Expr<SomeType> re{std::move(*args[0].value().UnwrapExpr())};
Expr<SomeType> im{args.size() >= 2 && args[1].has_value()
? std::move(*args[1]->UnwrapExpr())
- : AsGenericExpr(Constant<Part>{Scalar<Part>{}})};
+ : AsGenericExpr(Constant<Part>{Scalar<Part>::Zero(kind)})};
return Fold(context,
- Expr<T>{
- ComplexConstructor<KIND>{ToReal<KIND>(context, std::move(re)),
- ToReal<KIND>(context, std::move(im))}});
+ Expr<T>{ComplexConstructor{ToReal(context, std::move(re), kind),
+ ToReal(context, std::move(im), kind)}});
}
}
} else if (name == "dot_product") {
@@ -68,7 +66,7 @@ Expr<Type<TypeCategory::Complex, KIND>> FoldIntrinsicFunction(
} else if (name == "matmul") {
return FoldMatmul(context, std::move(funcRef));
} else if (name == "product") {
- auto one{Scalar<Part>::FromInteger(value::Integer<8>{1}).value};
+ auto one{Scalar<Part>::FromInteger(value::IntegerValue{1, 1}, kind).value};
return FoldProduct<T>(context, std::move(funcRef), Scalar<T>{one});
} else if (name == "sum") {
return FoldSum<T>(context, std::move(funcRef));
@@ -76,13 +74,12 @@ Expr<Type<TypeCategory::Complex, KIND>> FoldIntrinsicFunction(
return Expr<T>{std::move(funcRef)};
}
-template <int KIND>
-Expr<Type<TypeCategory::Complex, KIND>> FoldOperation(
- FoldingContext &context, ComplexConstructor<KIND> &&x) {
+Expr<Type<TypeCategory::Complex>> FoldOperation(
+ FoldingContext &context, ComplexConstructor &&x) {
if (auto array{ApplyElementwise(context, x)}) {
return *array;
}
- using ComplexType = Type<TypeCategory::Complex, KIND>;
+ using ComplexType = Type<TypeCategory::Complex>;
if (auto folded{OperandsAreConstants(x)}) {
using RealType = typename ComplexType::Part;
Constant<ComplexType> result{
diff --git a/flang/lib/Evaluate/fold-designator.cpp b/flang/lib/Evaluate/fold-designator.cpp
index d7751ec389917..3068965c8b9b6 100644
--- a/flang/lib/Evaluate/fold-designator.cpp
+++ b/flang/lib/Evaluate/fold-designator.cpp
@@ -98,9 +98,13 @@ std::optional<OffsetSymbol> DesignatorFolder::FoldDesignator(
},
[&](const Triplet &triplet) {
auto start{ToInt64(Fold(context_,
- triplet.lower().value_or(ExtentExpr{lower})))};
+ triplet.lower().value_or(ExtentExpr{
+ Constant<ExtentType>{ExtentType::Scalar{
+ lower, subscriptIntegerKind}}})))};
auto end{ToInt64(Fold(context_,
- triplet.upper().value_or(ExtentExpr{upper})))};
+ triplet.upper().value_or(ExtentExpr{
+ Constant<ExtentType>{ExtentType::Scalar{
+ upper, subscriptIntegerKind}}})))};
auto step{ToInt64(Fold(context_, triplet.stride()))};
if (start && end && step) {
if (*step != 0) {
@@ -237,11 +241,13 @@ static std::optional<ArrayRef> OffsetToArrayRef(FoldingContext &context,
}
auto quotient{at / extent};
auto remainder{at - quotient * extent};
- subscripts.emplace_back(ExtentExpr{(*lower)[dim] + remainder});
+ subscripts.emplace_back(ExtentExpr{Constant<ExtentType>{
+ ExtentType::Scalar{(*lower)[dim] + remainder, subscriptIntegerKind}}});
at = quotient;
}
// This final subscript might be out of range for use in error reporting.
- subscripts.emplace_back(ExtentExpr{(*lower)[rank - 1] + at});
+ subscripts.emplace_back(ExtentExpr{Constant<ExtentType>{
+ ExtentType::Scalar{(*lower)[rank - 1] + at, subscriptIntegerKind}}});
offset -= element * static_cast<std::size_t>(*elementBytes);
return ArrayRef{std::move(entity), std::move(subscripts)};
}
@@ -350,12 +356,17 @@ std::optional<Expr<SomeType>> OffsetToDesignator(FoldingContext &context,
return common::visit(
[&](const auto &x) -> std::optional<Expr<SomeType>> {
using T = typename std::decay_t<decltype(x)>::Result;
- return AsGenericExpr(Designator<T>{
- Substring{ExtractDataRef(std::move(*cExpr)).value(),
- std::optional<Expr<SubscriptInteger>>{
- 1 + (offset / T::kind)},
- std::optional<Expr<SubscriptInteger>>{
- 1 + ((offset + size - 1) / T::kind)}}});
+ const int charKind{x.GetType().value().kind()};
+ return AsGenericExpr(Designator<T>{Substring{
+ ExtractDataRef(std::move(*cExpr)).value(),
+ std::optional<Expr<SubscriptInteger>>{
+ Constant<SubscriptInteger>{SubscriptInteger::Scalar{
+ 1 + (offset / charKind),
+ subscriptIntegerKind}}},
+ std::optional<Expr<SubscriptInteger>>{
+ Constant<SubscriptInteger>{SubscriptInteger::Scalar{
+ 1 + ((offset + size - 1) / charKind),
+ subscriptIntegerKind}}}}});
},
cExpr->u);
}
diff --git a/flang/lib/Evaluate/fold-implementation.h b/flang/lib/Evaluate/fold-implementation.h
index 2df2b9e5a300b..562bbb7de5ce1 100644
--- a/flang/lib/Evaluate/fold-implementation.h
+++ b/flang/lib/Evaluate/fold-implementation.h
@@ -54,8 +54,22 @@ static constexpr bool useKahanSummation{false};
// Utilities
template <typename T> class Folder {
public:
- explicit Folder(FoldingContext &c, bool forOptionalArgument = false)
- : context_{c}, forOptionalArgument_{forOptionalArgument} {}
+ // toKind, when nonzero, forces the folded argument to be converted into
+ // category T at that specific kind. This restores the behavior that was
+ // implicit when T carried a static KIND template parameter: helpers that
+ // fold an argument as e.g. a default (KIND=4) integer relied on the
+ // conversion to that kind happening here (and being reflected structurally
+ // in the argument expression).
+ //
+ // typelessKind, when nonzero, is the kind given to an otherwise typeless
+ // operand such as a BOZ literal constant. Unlike toKind it does not reshape
+ // arguments that already have a type; it merely supplies the kind that a BOZ
+ // would have assumed from the static KIND on T before the migration to
+ // runtime kinds.
+ explicit Folder(FoldingContext &c, bool forOptionalArgument = false,
+ int toKind = 0, int typelessKind = 0)
+ : context_{c}, forOptionalArgument_{forOptionalArgument}, toKind_{toKind},
+ typelessKind_{typelessKind} {}
std::optional<Constant<T>> GetNamedConstant(const Symbol &);
std::optional<Constant<T>> ApplySubscripts(const Constant<T> &array,
const std::vector<Constant<SubscriptInteger>> &subscripts);
@@ -83,17 +97,22 @@ template <typename T> class Folder {
private:
FoldingContext &context_;
bool forOptionalArgument_{false};
+ int toKind_{0};
+ int typelessKind_{0};
};
std::optional<Constant<SubscriptInteger>> GetConstantSubscript(
FoldingContext &, Subscript &, const NamedEntity &, int dim);
-// Helper to use host runtime on scalars for folding.
+// Helper to use host runtime on scalars for folding. Because the specific
+// intrinsic types no longer carry their kind as a template parameter, the
+// runtime result kind and argument types must be supplied explicitly so that
+// the host runtime table can be searched for the right specialization.
template <typename TR, typename... TA>
std::optional<std::function<Scalar<TR>(FoldingContext &, Scalar<TA>...)>>
-GetHostRuntimeWrapper(const std::string &name) {
- std::vector<DynamicType> argTypes{TA{}.GetType()...};
- if (auto hostWrapper{GetHostRuntimeWrapper(name, TR{}.GetType(), argTypes)}) {
+GetHostRuntimeWrapper(const std::string &name, DynamicType resultType,
+ std::vector<DynamicType> argTypes) {
+ if (auto hostWrapper{GetHostRuntimeWrapper(name, resultType, argTypes)}) {
return [hostWrapper](
FoldingContext &context, Scalar<TA>... args) -> Scalar<TR> {
std::vector<Expr<SomeType>> genericArgs{
@@ -106,6 +125,15 @@ GetHostRuntimeWrapper(const std::string &name) {
return std::nullopt;
}
+// Convenience overload for the common case where the result and all arguments
+// share a single runtime kind (e.g. COS(real(k)) -> real(k)).
+template <typename TR, typename... TA>
+std::optional<std::function<Scalar<TR>(FoldingContext &, Scalar<TA>...)>>
+GetHostRuntimeWrapper(const std::string &name, int kind) {
+ return GetHostRuntimeWrapper<TR, TA...>(name, DynamicType{TR::category, kind},
+ std::vector<DynamicType>{DynamicType{TA::category, kind}...});
+}
+
// FoldOperation() rewrites expression tree nodes.
// If there is any possibility that the rewritten node will
// not have the same representation type, the result of
@@ -145,6 +173,13 @@ Expr<T> FoldOperation(FoldingContext &, ArrayConstructor<T> &&);
Expr<SomeDerived> FoldOperation(FoldingContext &, StructureConstructor &&);
template <typename T>
Expr<T> FoldOperation(FoldingContext &, ConditionalExpr<T> &&);
+// Defined in fold-complex.cpp. Declared here so that the COMPLEX-to-COMPLEX
+// case of FoldOperation(Convert) below resolves to this folder (which reduces a
+// constructor of constant parts to a COMPLEX constant) rather than to the
+// generic no-op FoldOperation() template, which would leave a non-constant
+// ComplexConstructor node behind.
+Expr<Type<TypeCategory::Complex>> FoldOperation(
+ FoldingContext &, ComplexConstructor &&);
template <typename T>
std::optional<Constant<T>> Folder<T>::GetNamedConstant(const Symbol &symbol0) {
@@ -257,7 +292,16 @@ std::optional<Constant<T>> Folder<T>::ApplySubscripts(const Constant<T> &array,
return Constant<T>{array.result().derivedTypeSpec(), std::move(values),
std::move(resultShape)};
} else {
- return Constant<T>{std::move(values), std::move(resultShape)};
+ // Propagate the source array's runtime kind so an empty result still
+ // carries a valid kind. Consult both the Result and the element values
+ // (as ConstantBase::GetType() does) without calling GetType(), which
+ // would assert on a kind-0 empty array.
+ int kind{array.result().runtimeKind()};
+ if (kind == 0 && !array.empty()) {
+ kind = array.values().front().kind();
+ }
+ return Constant<T>{std::move(values), std::move(resultShape),
+ typename Constant<T>::Result{kind}};
}
}
@@ -293,7 +337,9 @@ std::optional<Constant<T>> Folder<T>::ApplyComponent(
CHECK(typedExpr);
array = std::make_unique<ArrayConstructor<T>>(*typedExpr);
if constexpr (T::category == TypeCategory::Character) {
- array->set_LEN(Expr<SubscriptInteger>{value->LEN()});
+ array->set_LEN(Expr<SubscriptInteger>{
+ Constant<SubscriptInteger>{SubscriptInteger::Scalar{
+ value->LEN(), subscriptIntegerKind}}});
}
}
if (subscripts) {
@@ -364,11 +410,10 @@ template <typename T> Expr<T> Folder<T>::Folding(Designator<T> &&designator) {
} else if constexpr (T::category == TypeCategory::Real) {
if (auto *zPart{std::get_if<ComplexPart>(&designator.u)}) {
*zPart = FoldOperation(context_, std::move(*zPart));
- using ComplexT = Type<TypeCategory::Complex, T::kind>;
+ using ComplexT = Type<TypeCategory::Complex>;
if (auto zConst{Folder<ComplexT>{context_}.Folding(zPart->complex())}) {
return Fold(context_,
- Expr<T>{ComplexComponent<T::kind>{
- zPart->part() == ComplexPart::Part::IM,
+ Expr<T>{ComplexComponent{zPart->part() == ComplexPart::Part::IM,
Expr<ComplexT>{std::move(*zConst)}}});
} else {
return Expr<T>{Designator<T>{std::move(*zPart)}};
@@ -414,7 +459,34 @@ Constant<T> *Folder<T>::Folding(std::optional<ActualArgument> &arg) {
if (auto *expr{UnwrapExpr<Expr<SomeType>>(arg)}) {
*expr = Fold(context_, std::move(*expr));
if constexpr (T::category != TypeCategory::Derived) {
- if (!UnwrapExpr<Expr<T>>(*expr)) {
+ auto fromType{expr->GetType()};
+ // Decide the kind into which the argument should be folded. The kind is
+ // a runtime property now that T no longer carries a static KIND, so it
+ // has to be reconstructed here:
+ // * A forced kind (toKind_) reshapes the argument to category T at that
+ // kind unconditionally -- this is how helpers that fold an argument as
+ // e.g. a default (KIND=4) integer obtain that kind.
+ // * An argument of a different category is converted into category T
+ // while preserving the kind it already carries.
+ // * A typeless operand (e.g. a BOZ literal, which has no GetType()) is
+ // given the typelessKind_ fallback.
+ // An argument that is already of category T (and of the forced kind, if
+ // any) is left untouched: the elemental scalar kernels operate on
+ // runtime-kind values, so it need not be reshaped.
+ int destinationKind{0};
+ if (toKind_ != 0) {
+ if (!fromType || fromType->category() != T::category ||
+ fromType->kind() != toKind_) {
+ destinationKind = toKind_;
+ }
+ } else if (fromType) {
+ if (fromType->category() != T::category) {
+ destinationKind = fromType->kind();
+ }
+ } else {
+ destinationKind = typelessKind_;
+ }
+ if (destinationKind != 0) {
if (const Symbol *
var{forOptionalArgument_
? UnwrapWholeSymbolOrComponentDataRef(*expr)
@@ -422,7 +494,8 @@ Constant<T> *Folder<T>::Folding(std::optional<ActualArgument> &arg) {
var && (IsOptional(*var) || IsAllocatableOrObjectPointer(var))) {
// can't safely convert item that may not be present
} else if (auto converted{
- ConvertToType(T::GetType(), std::move(*expr))}) {
+ ConvertToType(DynamicType{T::category, destinationKind},
+ std::move(*expr))}) {
*expr = Fold(context_, std::move(*converted));
}
}
@@ -435,10 +508,11 @@ Constant<T> *Folder<T>::Folding(std::optional<ActualArgument> &arg) {
template <typename... A, std::size_t... I>
std::optional<std::tuple<const Constant<A> *...>> GetConstantArgumentsHelper(
FoldingContext &context, ActualArguments &arguments,
- bool hasOptionalArgument, std::index_sequence<I...>) {
+ bool hasOptionalArgument, int typelessKind, std::index_sequence<I...>) {
static_assert(sizeof...(A) > 0);
std::tuple<const Constant<A> *...> args{
- Folder<A>{context, hasOptionalArgument}.Folding(arguments.at(I))...};
+ Folder<A>{context, hasOptionalArgument, /*toKind=*/0, typelessKind}
+ .Folding(arguments.at(I))...};
if ((... && (std::get<I>(args)))) {
return args;
} else {
@@ -448,9 +522,10 @@ std::optional<std::tuple<const Constant<A> *...>> GetConstantArgumentsHelper(
template <typename... A>
std::optional<std::tuple<const Constant<A> *...>> GetConstantArguments(
- FoldingContext &context, ActualArguments &args, bool hasOptionalArgument) {
- return GetConstantArgumentsHelper<A...>(
- context, args, hasOptionalArgument, std::index_sequence_for<A...>{});
+ FoldingContext &context, ActualArguments &args, bool hasOptionalArgument,
+ int typelessKind = 0) {
+ return GetConstantArgumentsHelper<A...>(context, args, hasOptionalArgument,
+ typelessKind, std::index_sequence_for<A...>{});
}
template <typename... A, std::size_t... I>
@@ -488,9 +563,21 @@ template <template <typename, typename...> typename WrapperType, typename TR,
Expr<TR> FoldElementalIntrinsicHelper(FoldingContext &context,
FunctionRef<TR> &&funcRef, WrapperType<TR, TA...> func,
bool hasOptionalArgument, std::index_sequence<I...>) {
+ // The result kind is a runtime property carried by the procedure result
+ // type. Capture it before any element is computed so that an empty result
+ // (e.g. an elemental intrinsic applied to a zero-length array) still reports
+ // the correct kind rather than gleaning kind 0 from the absent elements.
+ // Derived types have no kind (DynamicType::kind() asserts on them), so only
+ // query it for intrinsic categories.
+ int resultKind{0};
+ if constexpr (TR::category != TypeCategory::Derived) {
+ if (funcRef.GetType()) {
+ resultKind = funcRef.GetType()->kind();
+ }
+ }
if (std::optional<std::tuple<const Constant<TA> *...>> args{
- GetConstantArguments<TA...>(
- context, funcRef.arguments(), hasOptionalArgument)}) {
+ GetConstantArguments<TA...>(context, funcRef.arguments(),
+ hasOptionalArgument, /*typelessKind=*/resultKind)}) {
// Compute the shape of the result based on shapes of arguments
ConstantSubscripts shape;
int rank{0};
@@ -552,7 +639,8 @@ Expr<TR> FoldElementalIntrinsicHelper(FoldingContext &context,
std::move(results), std::move(shape)}};
}
} else {
- return Expr<TR>{Constant<TR>{std::move(results), std::move(shape)}};
+ return Expr<TR>{
+ Constant<TR>{std::move(results), std::move(shape), TR{resultKind}}};
}
}
return Expr<TR>{std::move(funcRef)};
@@ -622,7 +710,8 @@ template <typename T> Expr<T> Folder<T>::CSHIFT(FunctionRef<T> &&funcRef) {
return Expr<T>{std::move(funcRef)};
}
auto convertedShift{Fold(context_,
- ConvertToType<SubscriptInteger>(Expr<SomeInteger>{*shiftExpr}))};
+ ConvertToType<SubscriptInteger>(
+ subscriptIntegerKind, Expr<SomeInteger>{*shiftExpr}))};
const auto *shift{UnwrapConstantValue<SubscriptInteger>(convertedShift)};
if (!shift) {
return Expr<T>{std::move(funcRef)};
@@ -701,7 +790,8 @@ template <typename T> Expr<T> Folder<T>::EOSHIFT(FunctionRef<T> &&funcRef) {
}
// Apply type conversions to the shift= and boundary= arguments.
auto convertedShift{Fold(context_,
- ConvertToType<SubscriptInteger>(Expr<SomeInteger>{*shiftExpr}))};
+ ConvertToType<SubscriptInteger>(
+ subscriptIntegerKind, Expr<SomeInteger>{*shiftExpr}))};
const auto *shift{UnwrapConstantValue<SubscriptInteger>(convertedShift)};
if (!shift) {
return Expr<T>{std::move(funcRef)};
@@ -800,15 +890,27 @@ template <typename T> Expr<T> Folder<T>::EOSHIFT(FunctionRef<T> &&funcRef) {
}
resultElements.push_back(boundary->At(boundaryAt));
} else if constexpr (T::category == TypeCategory::Integer ||
- T::category == TypeCategory::Unsigned ||
- T::category == TypeCategory::Real ||
- T::category == TypeCategory::Complex ||
- T::category == TypeCategory::Logical) {
+ T::category == TypeCategory::Unsigned) {
+ resultElements.emplace_back(0, funcRef.GetType().value().kind());
+ } else if constexpr (T::category == TypeCategory::Real ||
+ T::category == TypeCategory::Complex) {
+ resultElements.emplace_back(
+ Scalar<T>::Zero(funcRef.GetType().value().kind()));
+ } else if constexpr (T::category == TypeCategory::Logical) {
resultElements.emplace_back();
} else if constexpr (T::category == TypeCategory::Character) {
auto len{static_cast<std::size_t>(array->LEN())};
- typename Scalar<T>::value_type space{' '};
- resultElements.emplace_back(len, space);
+ switch (funcRef.GetType().value().kind()) {
+ case 2:
+ resultElements.emplace_back(len, char16_t{' '});
+ break;
+ case 4:
+ resultElements.emplace_back(len, char32_t{' '});
+ break;
+ default:
+ resultElements.emplace_back(len, char{' '});
+ break;
+ }
} else {
DIE("no derived type boundary");
}
@@ -839,7 +941,7 @@ template <typename T> Expr<T> Folder<T>::PACK(FunctionRef<T> &&funcRef) {
const auto *array{UnwrapConstantValue<T>(args[0])};
const auto *vector{UnwrapConstantValue<T>(args[2])};
auto convertedMask{Fold(context_,
- ConvertToType<LogicalResult>(
+ ConvertToType<LogicalResult>(logicalResultKind,
Expr<SomeLogical>{DEREF(UnwrapExpr<Expr<SomeLogical>>(args[1]))}))};
const auto *mask{UnwrapConstantValue<LogicalResult>(convertedMask)};
if (!array || !mask || (args[2] && !vector)) {
@@ -1048,7 +1150,7 @@ template <typename T> Expr<T> Folder<T>::UNPACK(FunctionRef<T> &&funcRef) {
CHECK(args.size() == 3);
const auto *vector{UnwrapConstantValue<T>(args[0])};
auto convertedMask{Fold(context_,
- ConvertToType<LogicalResult>(
+ ConvertToType<LogicalResult>(logicalResultKind,
Expr<SomeLogical>{DEREF(UnwrapExpr<Expr<SomeLogical>>(args[1]))}))};
const auto *mask{UnwrapConstantValue<LogicalResult>(convertedMask)};
const auto *field{UnwrapConstantValue<T>(args[2])};
@@ -1123,8 +1225,8 @@ Expr<T> FoldMINorMAX(
// optional arguments that may show up in 3rd + argument.
// - The code below only accepts more than 2 arguments if all the
// arguments are constant (and hence known to be present).
- // - ConvertExprToHLFIR can't currently handle Extremum<Character>
- // - Semantics doesn't currently generate Extremum<Character>
+ // - ConvertExprToHLFIR can't currently handle Extremum<CharacterValue>
+ // - Semantics doesn't currently generate Extremum<CharacterValue>
// The original code did the folding of arguments and the overall extremum
// operation in a single pass. This was shorter code-wise, but took me
// a while to tease out all the logic and was doing redundant work.
@@ -1226,7 +1328,9 @@ Expr<T> RewriteSpecificMINorMAX(
using TR = ResultType<decltype(x)>;
FunctionRef<TR> maxRef{
ProcedureDesignator{funcRef.proc()}, ActualArguments{args}};
- return Fold(context, ConvertToType<T>(AsCategoryExpr(std::move(maxRef))));
+ return Fold(context,
+ ConvertToType<T>(funcRef.GetType().value().kind(),
+ AsCategoryExpr(std::move(maxRef))));
}};
if (auto *sx{UnwrapExpr<Expr<SomeReal>>(*resultTypeArg)}) {
return common::visit(insertConversion, sx->u);
@@ -1238,22 +1342,16 @@ Expr<T> RewriteSpecificMINorMAX(
}
// FoldIntrinsicFunction()
-template <int KIND>
-Expr<Type<TypeCategory::Integer, KIND>> FoldIntrinsicFunction(
- FoldingContext &context, FunctionRef<Type<TypeCategory::Integer, KIND>> &&);
-template <int KIND>
-Expr<Type<TypeCategory::Unsigned, KIND>> FoldIntrinsicFunction(
- FoldingContext &context,
- FunctionRef<Type<TypeCategory::Unsigned, KIND>> &&);
-template <int KIND>
-Expr<Type<TypeCategory::Real, KIND>> FoldIntrinsicFunction(
- FoldingContext &context, FunctionRef<Type<TypeCategory::Real, KIND>> &&);
-template <int KIND>
-Expr<Type<TypeCategory::Complex, KIND>> FoldIntrinsicFunction(
- FoldingContext &context, FunctionRef<Type<TypeCategory::Complex, KIND>> &&);
-template <int KIND>
-Expr<Type<TypeCategory::Logical, KIND>> FoldIntrinsicFunction(
- FoldingContext &context, FunctionRef<Type<TypeCategory::Logical, KIND>> &&);
+Expr<Type<TypeCategory::Integer>> FoldIntrinsicFunction(
+ FoldingContext &context, FunctionRef<Type<TypeCategory::Integer>> &&);
+Expr<Type<TypeCategory::Unsigned>> FoldIntrinsicFunction(
+ FoldingContext &context, FunctionRef<Type<TypeCategory::Unsigned>> &&);
+Expr<Type<TypeCategory::Real>> FoldIntrinsicFunction(
+ FoldingContext &context, FunctionRef<Type<TypeCategory::Real>> &&);
+Expr<Type<TypeCategory::Complex>> FoldIntrinsicFunction(
+ FoldingContext &context, FunctionRef<Type<TypeCategory::Complex>> &&);
+Expr<Type<TypeCategory::Logical>> FoldIntrinsicFunction(
+ FoldingContext &context, FunctionRef<Type<TypeCategory::Logical>> &&);
template <typename T>
Expr<T> FoldOperation(FoldingContext &context, FunctionRef<T> &&funcRef) {
@@ -1308,6 +1406,16 @@ template <typename T> class ArrayConstructorFolder {
charLength_ = ToInt64(Fold(context_, common::Clone(*len)));
knownCharLength_ = charLength_.has_value();
}
+ } else if constexpr (!std::is_same_v<T, SomeDerived>) {
+ // Seed the runtime kind of the result so that a folded *empty* array
+ // constructor (which has no element values to source a kind from) still
+ // yields a Constant with a valid kind. Now that kind is a runtime
+ // property, an empty Constant whose Result kind is left at zero would
+ // produce an invalid (kind-0) DynamicType. Use the raw resultKind_
+ // field rather than array.GetType(), which would itself assert on a
+ // kind-0 constructor; for non-empty constructors the element values
+ // still supply a valid kind.
+ resultInfo_.runtimeKind_ = array.resultKind_;
}
// Calls FoldArray(const ArrayConstructorValues<T> &) below
if (FoldArray(array)) {
@@ -1469,6 +1577,17 @@ AsFlatArrayConstructor(const Expr<SomeKind<CAT>> &expr) {
template <typename T>
std::optional<Expr<T>> FromArrayConstructor(
FoldingContext &context, ArrayConstructor<T> &&values, const Shape &shape) {
+ // The element kind is a runtime property. MapOperation() seeds the result
+ // array constructor from an operand expression used purely as a type mold,
+ // which (for operations like Convert whose result kind differs from the
+ // operand kind) leaves the result kind set to the operand's kind. Re-derive
+ // it from the actual elements, which already carry the correct result kind,
+ // whenever any element is present.
+ if constexpr (T::category != TypeCategory::Derived) {
+ if (int kind{GleanArrayConstructorResultKind<T>(values)}) {
+ values.resultKind_ = kind;
+ }
+ }
if (auto constShape{AsConstantExtents(context, shape)};
constShape && !HasNegativeExtent(*constShape)) {
Expr<T> result{Fold(context, Expr<T>{std::move(values)})};
@@ -1794,7 +1913,19 @@ common::IfNoLvalue<std::optional<TO>, FROM> ConvertString(FROM &&s) {
template <typename TO, TypeCategory FROMCAT>
Expr<TO> FoldOperation(
FoldingContext &context, Convert<TO, FROMCAT> &&convert) {
- if (auto array{ApplyElementwise(context, convert)}) {
+ const int convertKind{convert.resultKind_};
+ // Fold the operand first so that the conversion sees a constant when its
+ // argument reduces to one (e.g. a complex constructor of constant parts that
+ // had not been folded before the conversion was wrapped around it). Other
+ // unary folders (e.g. Parentheses, Negate) likewise fold their operand.
+ convert.left() = Fold(context, std::move(convert.left()));
+ if (auto array{ApplyElementwise(context, convert,
+ std::function<Expr<TO>(Expr<SomeKind<FROMCAT>> &&)>{
+ [convertKind](Expr<SomeKind<FROMCAT>> &&operand) {
+ Convert<TO, FROMCAT> elt{std::move(operand)};
+ elt.resultKind_ = convertKind;
+ return Expr<TO>{std::move(elt)};
+ }})}) {
return *array;
}
struct {
@@ -1809,97 +1940,147 @@ Expr<TO> FoldOperation(
TypeCategory constexpr FromCat{FROMCAT};
static_assert(FromCat == Operand::category);
auto &convert{msvcWorkaround.convert};
+ // The destination kind is a runtime property of the Convert node now,
+ // not the compile-time TO::kind that no longer exists.
+ const int toKind{convert.GetType().value().kind()};
if (auto value{GetScalarConstantValue<Operand>(kindExpr)}) {
FoldingContext &ctx{msvcWorkaround.context};
+ const int fromKind{value->kind()};
if constexpr (TO::category == TypeCategory::Integer) {
if constexpr (FromCat == TypeCategory::Integer) {
- auto converted{Scalar<TO>::ConvertSigned(*value)};
+ auto converted{Scalar<TO>::ConvertSigned(*value, 8 * toKind)};
if (converted.overflow) {
ctx.Warn(common::UsageWarning::FoldingException,
"conversion of %s_%d to INTEGER(%d) overflowed; result is %s"_warn_en_US,
- value->SignedDecimal(), Operand::kind, TO::kind,
+ value->SignedDecimal(), fromKind, toKind,
converted.value.SignedDecimal());
}
- return ScalarConstantToExpr(std::move(converted.value));
+ return Expr<TO>{Constant<TO>{std::move(converted.value)}};
} else if constexpr (FromCat == TypeCategory::Unsigned) {
- auto converted{Scalar<TO>::ConvertUnsigned(*value)};
+ auto converted{Scalar<TO>::ConvertUnsigned(*value, 8 * toKind)};
if ((converted.overflow || converted.value.IsNegative())) {
ctx.Warn(common::UsageWarning::FoldingException,
"conversion of %s_U%d to INTEGER(%d) overflowed; result is %s"_warn_en_US,
- value->UnsignedDecimal(), Operand::kind, TO::kind,
+ value->UnsignedDecimal(), fromKind, toKind,
converted.value.SignedDecimal());
}
- return ScalarConstantToExpr(std::move(converted.value));
+ return Expr<TO>{Constant<TO>{std::move(converted.value)}};
} else if constexpr (FromCat == TypeCategory::Real) {
- auto converted{value->template ToInteger<Scalar<TO>>()};
+ auto converted{
+ value->ToInteger(common::RoundingMode::ToZero, 8 * toKind)};
if (converted.flags.test(RealFlag::InvalidArgument)) {
ctx.Warn(common::UsageWarning::FoldingException,
"REAL(%d) to INTEGER(%d) conversion: invalid argument"_warn_en_US,
- Operand::kind, TO::kind);
+ fromKind, toKind);
} else if (converted.flags.test(RealFlag::Overflow)) {
ctx.Warn(common::UsageWarning::FoldingException,
"REAL(%d) to INTEGER(%d) conversion overflowed"_warn_en_US,
- Operand::kind, TO::kind);
+ fromKind, toKind);
}
- return ScalarConstantToExpr(std::move(converted.value));
+ return Expr<TO>{Constant<TO>{std::move(converted.value)}};
}
} else if constexpr (TO::category == TypeCategory::Unsigned) {
if constexpr (FromCat == TypeCategory::Integer ||
FromCat == TypeCategory::Unsigned) {
- return Expr<TO>{
- Constant<TO>{Scalar<TO>::ConvertUnsigned(*value).value}};
+ return Expr<TO>{Constant<TO>{
+ Scalar<TO>::ConvertUnsigned(*value, 8 * toKind).value}};
} else if constexpr (FromCat == TypeCategory::Real) {
- return Expr<TO>{
- Constant<TO>{value->template ToInteger<Scalar<TO>>().value}};
+ return Expr<TO>{Constant<TO>{
+ value->ToInteger(common::RoundingMode::ToZero, 8 * toKind)
+ .value}};
}
} else if constexpr (TO::category == TypeCategory::Real) {
if constexpr (FromCat == TypeCategory::Integer ||
FromCat == TypeCategory::Unsigned) {
auto converted{Scalar<TO>::FromInteger(
- *value, FromCat == TypeCategory::Unsigned)};
+ *value, toKind, FromCat == TypeCategory::Unsigned)};
if (!converted.flags.empty()) {
char buffer[64];
std::snprintf(buffer, sizeof buffer,
- "INTEGER(%d) to REAL(%d) conversion", Operand::kind,
- TO::kind);
+ "INTEGER(%d) to REAL(%d) conversion", fromKind, toKind);
ctx.RealFlagWarnings(converted.flags, buffer);
}
- return ScalarConstantToExpr(std::move(converted.value));
+ return Expr<TO>{Constant<TO>{std::move(converted.value)}};
} else if constexpr (FromCat == TypeCategory::Real) {
- auto converted{Scalar<TO>::Convert(*value)};
+ auto converted{Scalar<TO>::Convert(*value, toKind)};
char buffer[64];
if (!converted.flags.empty()) {
std::snprintf(buffer, sizeof buffer,
- "REAL(%d) to REAL(%d) conversion", Operand::kind, TO::kind);
+ "REAL(%d) to REAL(%d) conversion", fromKind, toKind);
ctx.RealFlagWarnings(converted.flags, buffer);
}
if (ctx.targetCharacteristics().areSubnormalsFlushedToZero()) {
converted.value = converted.value.FlushSubnormalToZero();
}
- return ScalarConstantToExpr(std::move(converted.value));
+ return Expr<TO>{Constant<TO>{std::move(converted.value)}};
}
} else if constexpr (TO::category == TypeCategory::Complex) {
if constexpr (FromCat == TypeCategory::Complex) {
+ // The component conversions carry their target real kind at
+ // runtime; it must be set explicitly (it was formerly the
+ // compile-time TO::Part::kind).
+ Convert<typename TO::Part> reConv{AsCategoryExpr(
+ Constant<typename Operand::Part>{value->REAL()})};
+ reConv.resultKind_ = toKind;
+ Convert<typename TO::Part> imConv{AsCategoryExpr(
+ Constant<typename Operand::Part>{value->AIMAG()})};
+ imConv.resultKind_ = toKind;
return FoldOperation(ctx,
- ComplexConstructor<TO::kind>{
- AsExpr(Convert<typename TO::Part>{AsCategoryExpr(
- Constant<typename Operand::Part>{value->REAL()})}),
- AsExpr(Convert<typename TO::Part>{AsCategoryExpr(
- Constant<typename Operand::Part>{value->AIMAG()})})});
+ ComplexConstructor{Fold(ctx, AsExpr(std::move(reConv))),
+ Fold(ctx, AsExpr(std::move(imConv)))});
}
} else if constexpr (TO::category == TypeCategory::Character &&
FromCat == TypeCategory::Character) {
- if (auto converted{ConvertString<Scalar<TO>>(std::move(*value))}) {
- return ScalarConstantToExpr(std::move(*converted));
+ if (toKind == fromKind) {
+ return Expr<TO>{Constant<TO>{std::move(*value)}};
+ } else {
+ // Reinterpret the source characters (which are <= 127, i.e.
+ // ASCII) into a string of the destination kind.
+ bool ok{true};
+ value::CharacterValue out;
+ const std::size_t n{value->length()};
+ auto build{[&](auto sample) {
+ using ToChar = decltype(sample);
+ std::basic_string<ToChar> toStr;
+ for (std::size_t i{0}; i < n; ++i) {
+ char32_t c{(*value)[i]};
+ if (static_cast<std::uint64_t>(c) > 127) {
+ ok = false;
+ return;
+ }
+ toStr.push_back(static_cast<ToChar>(c));
+ }
+ out = value::CharacterValue{std::move(toStr)};
+ }};
+ switch (toKind) {
+ case 2:
+ build(char16_t{});
+ break;
+ case 4:
+ build(char32_t{});
+ break;
+ default:
+ build(char{});
+ break;
+ }
+ if (ok) {
+ return Expr<TO>{Constant<TO>{std::move(out)}};
+ }
}
} else if constexpr (TO::category == TypeCategory::Logical &&
FromCat == TypeCategory::Logical) {
- return Expr<TO>{value->IsTrue()};
+ // The conversion's target kind is a runtime property; build the
+ // result LOGICAL constant with that kind rather than letting it
+ // default (the Expr<Logical>(bool) constructor would otherwise
+ // produce logicalResultKind=4 and silently drop the conversion).
+ return Expr<TO>{
+ Constant<TO>{value::LogicalValue{value->IsTrue(), toKind}}};
}
} else if constexpr (TO::category == FromCat &&
FromCat != TypeCategory::Character) {
// Conversion of non-constant in same type category
- if constexpr (std::is_same_v<Operand, TO>) {
+ auto fromTy{kindExpr.GetType()};
+ if (fromTy && fromTy->kind() == toKind) {
return std::move(kindExpr); // remove needless conversion
} else if constexpr (TO::category == TypeCategory::Logical ||
TO::category == TypeCategory::Integer) {
@@ -1907,16 +2088,26 @@ Expr<TO> FoldOperation(
std::get_if<Convert<Operand, TO::category>>(&kindExpr.u)}) {
// Conversion of conversion of same category & kind
if (auto *x{std::get_if<Expr<TO>>(&innerConv->left().u)}) {
- if constexpr (TO::category == TypeCategory::Logical ||
- TO::kind <= Operand::kind) {
- return std::move(*x); // no-op Logical or Integer
- // widening/narrowing conversion pair
- } else if constexpr (std::is_same_v<TO,
- DescriptorInquiry::Result>) {
- if (std::holds_alternative<DescriptorInquiry>(x->u) ||
- std::holds_alternative<TypeParamInquiry>(x->u)) {
+ // intermediateKind is the kind of the middle (Operand) result;
+ // xKind is the kind of the innermost expression, which must
+ // match the outer target for the round trip to be a no-op.
+ auto intermediateTy{kindExpr.GetType()};
+ auto xTy{x->GetType()};
+ int intermediateKind{
+ intermediateTy ? intermediateTy->kind() : 0};
+ int xKind{xTy ? xTy->kind() : 0};
+ if constexpr (TO::category == TypeCategory::Logical) {
+ return std::move(*x); // no-op Logical conversion pair
+ } else { // Integer
+ if (xKind == toKind && toKind <= intermediateKind) {
+ return std::move(*x); // widening/narrowing conversion pair
+ } else if (toKind == subscriptIntegerKind &&
+ xKind == toKind) {
// int(int(size(...),kind=k),kind=8) -> size(...)
- return std::move(*x);
+ if (std::holds_alternative<DescriptorInquiry>(x->u) ||
+ std::holds_alternative<TypeParamInquiry>(x->u)) {
+ return std::move(*x);
+ }
}
}
}
@@ -1961,7 +2152,7 @@ Expr<T> FoldOperation(FoldingContext &context, Negate<T> &&x) {
auto negated{value->Negate()};
if (negated.overflow) {
context.Warn(common::UsageWarning::FoldingException,
- "INTEGER(%d) negation overflowed"_warn_en_US, T::kind);
+ "INTEGER(%d) negation overflowed"_warn_en_US, value->kind());
}
return Expr<T>{Constant<T>{std::move(negated.value)}};
} else if constexpr (T::category == TypeCategory::Unsigned) {
@@ -2003,7 +2194,7 @@ Expr<T> FoldOperation(FoldingContext &context, Add<T> &&x) {
auto sum{folded->first.AddSigned(folded->second)};
if (sum.overflow) {
context.Warn(common::UsageWarning::FoldingException,
- "INTEGER(%d) addition overflowed"_warn_en_US, T::kind);
+ "INTEGER(%d) addition overflowed"_warn_en_US, folded->first.kind());
}
return Expr<T>{Constant<T>{sum.value}};
} else if constexpr (T::category == TypeCategory::Unsigned) {
@@ -2051,7 +2242,8 @@ Expr<T> FoldOperation(FoldingContext &context, Subtract<T> &&x) {
auto difference{folded->first.SubtractSigned(folded->second)};
if (difference.overflow) {
context.Warn(common::UsageWarning::FoldingException,
- "INTEGER(%d) subtraction overflowed"_warn_en_US, T::kind);
+ "INTEGER(%d) subtraction overflowed"_warn_en_US,
+ folded->first.kind());
}
return Expr<T>{Constant<T>{difference.value}};
} else if constexpr (T::category == TypeCategory::Unsigned) {
@@ -2091,7 +2283,8 @@ Expr<T> FoldOperation(FoldingContext &context, Multiply<T> &&x) {
auto product{folded->first.MultiplySigned(folded->second)};
if (product.SignedMultiplicationOverflowed()) {
context.Warn(common::UsageWarning::FoldingException,
- "INTEGER(%d) multiplication overflowed"_warn_en_US, T::kind);
+ "INTEGER(%d) multiplication overflowed"_warn_en_US,
+ folded->first.kind());
}
return Expr<T>{Constant<T>{product.lower}};
} else if constexpr (T::category == TypeCategory::Unsigned) {
@@ -2114,13 +2307,15 @@ Expr<T> FoldOperation(FoldingContext &context, Multiply<T> &&x) {
if (auto c{GetScalarConstantValue<T>(x.left())}) {
if (c->IsZero() && x.right().Rank() == 0) {
return std::move(x.left());
- } else if (c->CompareSigned(Scalar<T>{1}) == Ordering::Equal) {
+ } else if (c->CompareSigned(value::IntegerValue{1, c->kind()}) ==
+ Ordering::Equal) {
if (IsVariable(x.right())) {
return FoldOperation(context, Parentheses<T>{std::move(x.right())});
} else {
return std::move(x.right());
}
- } else if (c->CompareSigned(Scalar<T>{-1}) == Ordering::Equal) {
+ } else if (c->CompareSigned(value::IntegerValue{-1, c->kind()}) ==
+ Ordering::Equal) {
return FoldOperation(context, Negate<T>{std::move(x.right())});
}
}
@@ -2138,19 +2333,19 @@ Expr<T> FoldOperation(FoldingContext &context, Divide<T> &&x) {
auto quotAndRem{folded->first.DivideSigned(folded->second)};
if (quotAndRem.divisionByZero) {
context.Warn(common::UsageWarning::FoldingException,
- "INTEGER(%d) division by zero"_warn_en_US, T::kind);
+ "INTEGER(%d) division by zero"_warn_en_US, folded->first.kind());
return Expr<T>{std::move(x)};
}
if (quotAndRem.overflow) {
context.Warn(common::UsageWarning::FoldingException,
- "INTEGER(%d) division overflowed"_warn_en_US, T::kind);
+ "INTEGER(%d) division overflowed"_warn_en_US, folded->first.kind());
}
return Expr<T>{Constant<T>{quotAndRem.quotient}};
} else if constexpr (T::category == TypeCategory::Unsigned) {
auto quotAndRem{folded->first.DivideUnsigned(folded->second)};
if (quotAndRem.divisionByZero) {
context.Warn(common::UsageWarning::FoldingException,
- "UNSIGNED(%d) division by zero"_warn_en_US, T::kind);
+ "UNSIGNED(%d) division by zero"_warn_en_US, folded->first.kind());
return Expr<T>{std::move(x)};
}
return Expr<T>{Constant<T>{quotAndRem.quotient}};
@@ -2164,10 +2359,10 @@ Expr<T> FoldOperation(FoldingContext &context, Divide<T> &&x) {
if constexpr (T::category == TypeCategory::Real) {
if (folded->second.IsZero() && context.moduleFileName().has_value()) {
using IntType = typename T::Scalar::Word;
- auto intNumerator{folded->first.template ToInteger<IntType>()};
+ auto intNumerator{folded->first.ToInteger()};
isCanonicalNaNOrInf = intNumerator.flags == RealFlags{} &&
- intNumerator.value >= IntType{-1} &&
- intNumerator.value <= IntType{1};
+ intNumerator.value >= IntType{-1, 16} &&
+ intNumerator.value <= IntType{1, 16};
}
}
if (!isCanonicalNaNOrInf) {
@@ -2192,13 +2387,14 @@ Expr<T> FoldOperation(FoldingContext &context, Power<T> &&x) {
auto power{folded->first.Power(folded->second)};
if (power.divisionByZero) {
context.Warn(common::UsageWarning::FoldingException,
- "INTEGER(%d) zero to negative power"_warn_en_US, T::kind);
+ "INTEGER(%d) zero to negative power"_warn_en_US,
+ folded->first.kind());
} else if (power.overflow) {
context.Warn(common::UsageWarning::FoldingException,
- "INTEGER(%d) power overflowed"_warn_en_US, T::kind);
+ "INTEGER(%d) power overflowed"_warn_en_US, folded->first.kind());
} else if (power.zeroToZero) {
context.Warn(common::UsageWarning::FoldingException,
- "INTEGER(%d) 0**0 is not defined"_warn_en_US, T::kind);
+ "INTEGER(%d) 0**0 is not defined"_warn_en_US, folded->first.kind());
}
return Expr<T>{Constant<T>{power.power}};
} else {
@@ -2209,13 +2405,14 @@ Expr<T> FoldOperation(FoldingContext &context, Power<T> &&x) {
} else {
return Expr<T>(Constant<T>{folded->first}); // 0. ** nonzero -> 0.
}
- } else if (auto callable{GetHostRuntimeWrapper<T, T, T>("pow")}) {
+ } else if (auto callable{GetHostRuntimeWrapper<T, T, T>(
+ "pow", folded->first.kind())}) {
return Expr<T>{
Constant<T>{(*callable)(context, folded->first, folded->second)}};
} else {
context.Warn(common::UsageWarning::FoldingFailure,
"Power for %s cannot be folded on host"_warn_en_US,
- T{}.AsFortran());
+ DynamicType{T::category, folded->first.kind()}.AsFortran());
}
}
}
@@ -2285,9 +2482,9 @@ Expr<T> FoldOperation(FoldingContext &context, Extremum<T> &&x) {
auto maxLen{std::max(folded->first.length(), folded->second.length())};
bool isFirst{x.ordering == Compare(folded->first, folded->second)};
auto res{isFirst ? std::move(folded->first) : std::move(folded->second)};
- res = res.length() == maxLen
- ? std::move(res)
- : CharacterUtils<T::kind>::Resize(res, maxLen);
+ if (res.length() != maxLen) {
+ res = CharacterUtils::Resize(res, maxLen);
+ }
return Expr<T>{Constant<T>{std::move(res)}};
}
return Expr<T>{Constant<T>{folded->second}};
@@ -2295,28 +2492,28 @@ Expr<T> FoldOperation(FoldingContext &context, Extremum<T> &&x) {
return Expr<T>{std::move(x)};
}
-template <int KIND>
-Expr<Type<TypeCategory::Real, KIND>> ToReal(
- FoldingContext &context, Expr<SomeType> &&expr) {
- using Result = Type<TypeCategory::Real, KIND>;
+inline Expr<Type<TypeCategory::Real>> ToReal(
+ FoldingContext &context, Expr<SomeType> &&expr, int kind) {
+ using Result = Type<TypeCategory::Real>;
std::optional<Expr<Result>> result;
common::visit(
[&](auto &&x) {
using From = std::decay_t<decltype(x)>;
if constexpr (std::is_same_v<From, BOZLiteralConstant>) {
// Move the bits without any integer->real conversion
- From original{x};
- result = ConvertToType<Result>(std::move(x));
+ BOZLiteralConstant original{x};
+ result = ConvertToType<Result>(kind, std::move(x));
const auto *constant{UnwrapExpr<Constant<Result>>(*result)};
CHECK(constant);
Scalar<Result> real{constant->GetScalarValue().value()};
- From converted{From::ConvertUnsigned(real.RawBits()).value};
+ BOZLiteralConstant converted{
+ BOZLiteralConstant::ConvertUnsigned(real.RawBits(), 128).value};
if (original != converted) { // C1601
context.Warn(common::UsageWarning::FoldingValueChecks,
"Nonzero bits truncated from BOZ literal constant in REAL intrinsic"_warn_en_US);
}
} else if constexpr (IsNumericCategoryExpr<From>()) {
- result = Fold(context, ConvertToType<Result>(std::move(x)));
+ result = Fold(context, ConvertToType<Result>(kind, std::move(x)));
} else {
common::die("ToReal: bad argument expression");
}
@@ -2326,16 +2523,15 @@ Expr<Type<TypeCategory::Real, KIND>> ToReal(
}
// REAL(z) and AIMAG(z)
-template <int KIND>
-Expr<Type<TypeCategory::Real, KIND>> FoldOperation(
- FoldingContext &context, ComplexComponent<KIND> &&x) {
- using Operand = Type<TypeCategory::Complex, KIND>;
- using Result = Type<TypeCategory::Real, KIND>;
+inline Expr<Type<TypeCategory::Real>> FoldOperation(
+ FoldingContext &context, ComplexComponent &&x) {
+ using Operand = Type<TypeCategory::Complex>;
+ using Result = Type<TypeCategory::Real>;
if (auto array{ApplyElementwise(context, x,
std::function<Expr<Result>(Expr<Operand> &&)>{
[=](Expr<Operand> &&operand) {
- return Expr<Result>{ComplexComponent<KIND>{
- x.isImaginaryPart, std::move(operand)}};
+ return Expr<Result>{
+ ComplexComponent{x.isImaginaryPart, std::move(operand)}};
}})}) {
return *array;
}
diff --git a/flang/lib/Evaluate/fold-integer.cpp b/flang/lib/Evaluate/fold-integer.cpp
index 9f2bb94a9213f..f94f87ffb7ffb 100644
--- a/flang/lib/Evaluate/fold-integer.cpp
+++ b/flang/lib/Evaluate/fold-integer.cpp
@@ -17,16 +17,18 @@ namespace Fortran::evaluate {
// Return scalar value if asScalar == true and shape-dim array otherwise.
template <typename T>
Expr<T> PackageConstantBounds(
- const ConstantSubscripts &&bounds, bool asScalar = false) {
+ const ConstantSubscripts &&bounds, int kind, bool asScalar = false) {
if (asScalar) {
- return Expr<T>{Constant<T>{bounds.at(0)}};
+ return Expr<T>{
+ Constant<T>{typename T::Scalar{bounds.at(0), kind}, T{kind}}};
} else {
// As rank-dim array
const int rank{GetRank(bounds)};
std::vector<Scalar<T>> packed(rank);
std::transform(bounds.begin(), bounds.end(), packed.begin(),
- [](ConstantSubscript x) { return Scalar<T>(x); });
- return Expr<T>{Constant<T>{std::move(packed), ConstantSubscripts{rank}}};
+ [kind](ConstantSubscript x) { return Scalar<T>(x, kind); });
+ return Expr<T>{
+ Constant<T>{std::move(packed), ConstantSubscripts{rank}, T{kind}}};
}
}
@@ -99,17 +101,17 @@ class GetConstantArrayBoundHelper {
public:
template <typename T>
static Expr<T> GetLbound(
- const Expr<SomeType> &array, std::optional<int> dim) {
+ const Expr<SomeType> &array, std::optional<int> dim, int kind) {
return PackageConstantBounds<T>(
- GetConstantArrayBoundHelper(dim, /*getLbound=*/true).Get(array),
+ GetConstantArrayBoundHelper(dim, /*getLbound=*/true).Get(array), kind,
dim.has_value());
}
template <typename T>
static Expr<T> GetUbound(
- const Expr<SomeType> &array, std::optional<int> dim) {
+ const Expr<SomeType> &array, std::optional<int> dim, int kind) {
return PackageConstantBounds<T>(
- GetConstantArrayBoundHelper(dim, /*getLbound=*/false).Get(array),
+ GetConstantArrayBoundHelper(dim, /*getLbound=*/false).Get(array), kind,
dim.has_value());
}
@@ -173,10 +175,10 @@ class GetConstantArrayBoundHelper {
bool arrayFromParenthesesExpr{false};
};
-template <int KIND>
-Expr<Type<TypeCategory::Integer, KIND>> LBOUND(FoldingContext &context,
- FunctionRef<Type<TypeCategory::Integer, KIND>> &&funcRef) {
- using T = Type<TypeCategory::Integer, KIND>;
+Expr<Type<TypeCategory::Integer>> LBOUND(FoldingContext &context,
+ FunctionRef<Type<TypeCategory::Integer>> &&funcRef) {
+ using T = Type<TypeCategory::Integer>;
+ const int kind{funcRef.GetType().value().kind()};
ActualArguments &args{funcRef.arguments()};
if (const auto *array{UnwrapExpr<Expr<SomeType>>(args[0])}) {
std::optional<int> dim;
@@ -201,33 +203,33 @@ Expr<Type<TypeCategory::Integer, KIND>> LBOUND(FoldingContext &context,
lowerBoundsAreOne = false;
if (dim) {
if (auto lb{GetLBOUND(context, *named, *dim)}) {
- return Fold(context, ConvertToType<T>(std::move(*lb)));
+ return Fold(context, ConvertToType<T>(kind, std::move(*lb)));
}
} else if (auto extents{
AsExtentArrayExpr(GetLBOUNDs(context, *named))}) {
return Fold(context,
- ConvertToType<T>(Expr<ExtentType>{std::move(*extents)}));
+ ConvertToType<T>(kind, Expr<ExtentType>{std::move(*extents)}));
}
} else {
lowerBoundsAreOne = symbol.Rank() == 0; // LBOUND(array%component)
}
}
if (IsActuallyConstant(*array)) {
- return GetConstantArrayBoundHelper::GetLbound<T>(*array, dim);
+ return GetConstantArrayBoundHelper::GetLbound<T>(*array, dim, kind);
}
if (lowerBoundsAreOne) {
ConstantSubscripts ones(rank, ConstantSubscript{1});
- return PackageConstantBounds<T>(std::move(ones), dim.has_value());
+ return PackageConstantBounds<T>(std::move(ones), kind, dim.has_value());
}
}
}
return Expr<T>{std::move(funcRef)};
}
-template <int KIND>
-Expr<Type<TypeCategory::Integer, KIND>> UBOUND(FoldingContext &context,
- FunctionRef<Type<TypeCategory::Integer, KIND>> &&funcRef) {
- using T = Type<TypeCategory::Integer, KIND>;
+Expr<Type<TypeCategory::Integer>> UBOUND(FoldingContext &context,
+ FunctionRef<Type<TypeCategory::Integer>> &&funcRef) {
+ using T = Type<TypeCategory::Integer>;
+ const int kind{funcRef.GetType().value().kind()};
ActualArguments &args{funcRef.arguments()};
if (auto *array{UnwrapExpr<Expr<SomeType>>(args[0])}) {
std::optional<int> dim;
@@ -249,17 +251,19 @@ Expr<Type<TypeCategory::Integer, KIND>> UBOUND(FoldingContext &context,
takeBoundsFromShape = false;
if (dim) {
if (auto ub{GetUBOUND(context, *named, *dim)}) {
- return Fold(context, ConvertToType<T>(std::move(*ub)));
+ return Fold(context, ConvertToType<T>(kind, std::move(*ub)));
}
} else {
Shape ubounds{GetUBOUNDs(context, *named)};
if (semantics::IsAssumedSizeArray(symbol)) {
CHECK(!ubounds.back());
- ubounds.back() = ExtentExpr{-1};
+ ubounds.back() = ExtentExpr{Constant<ExtentType>{
+ ExtentType::Scalar{-1, subscriptIntegerKind}}};
}
if (auto extents{AsExtentArrayExpr(ubounds)}) {
return Fold(context,
- ConvertToType<T>(Expr<ExtentType>{std::move(*extents)}));
+ ConvertToType<T>(
+ kind, Expr<ExtentType>{std::move(*extents)}));
}
}
} else {
@@ -267,17 +271,18 @@ Expr<Type<TypeCategory::Integer, KIND>> UBOUND(FoldingContext &context,
}
}
if (IsActuallyConstant(*array)) {
- return GetConstantArrayBoundHelper::GetUbound<T>(*array, dim);
+ return GetConstantArrayBoundHelper::GetUbound<T>(*array, dim, kind);
}
if (takeBoundsFromShape) {
if (auto shape{GetContextFreeShape(context, *array)}) {
if (dim) {
if (auto &dimSize{shape->at(*dim)}) {
return Fold(context,
- ConvertToType<T>(Expr<ExtentType>{std::move(*dimSize)}));
+ ConvertToType<T>(
+ kind, Expr<ExtentType>{std::move(*dimSize)}));
}
} else if (auto shapeExpr{AsExtentArrayExpr(*shape)}) {
- return Fold(context, ConvertToType<T>(std::move(*shapeExpr)));
+ return Fold(context, ConvertToType<T>(kind, std::move(*shapeExpr)));
}
}
}
@@ -287,10 +292,10 @@ Expr<Type<TypeCategory::Integer, KIND>> UBOUND(FoldingContext &context,
}
// LCOBOUND() & UCOBOUND()
-template <int KIND>
-Expr<Type<TypeCategory::Integer, KIND>> COBOUND(FoldingContext &context,
- FunctionRef<Type<TypeCategory::Integer, KIND>> &&funcRef, bool isUCOBOUND) {
- using T = Type<TypeCategory::Integer, KIND>;
+Expr<Type<TypeCategory::Integer>> COBOUND(FoldingContext &context,
+ FunctionRef<Type<TypeCategory::Integer>> &&funcRef, bool isUCOBOUND) {
+ using T = Type<TypeCategory::Integer>;
+ const int kind{funcRef.GetType().value().kind()};
ActualArguments &args{funcRef.arguments()};
if (const Symbol * coarray{UnwrapWholeSymbolOrComponentDataRef(args[0])}) {
std::optional<int> dim;
@@ -306,27 +311,29 @@ Expr<Type<TypeCategory::Integer, KIND>> COBOUND(FoldingContext &context,
if (dim) {
if (auto cb{isUCOBOUND ? GetUCOBOUND(*coarray, *dim)
: GetLCOBOUND(*coarray, *dim)}) {
- return Fold(context, ConvertToType<T>(std::move(*cb)));
+ return Fold(context, ConvertToType<T>(kind, std::move(*cb)));
}
} else if (auto cbs{
AsExtentArrayExpr(isUCOBOUND ? GetUCOBOUNDs(*coarray)
: GetLCOBOUNDs(*coarray))}) {
- return Fold(context, ConvertToType<T>(Expr<ExtentType>{std::move(*cbs)}));
+ return Fold(
+ context, ConvertToType<T>(kind, Expr<ExtentType>{std::move(*cbs)}));
}
}
return Expr<T>{std::move(funcRef)};
}
// COUNT()
-template <typename T, int MASK_KIND> class CountAccumulator {
- using MaskT = Type<TypeCategory::Logical, MASK_KIND>;
+template <typename T> class CountAccumulator {
+ using MaskT = LogicalResult;
public:
- CountAccumulator(const Constant<MaskT> &mask) : mask_{mask} {}
+ CountAccumulator(const Constant<MaskT> &mask, int kind)
+ : mask_{mask}, kind_{kind} {}
void operator()(
Scalar<T> &element, const ConstantSubscripts &at, bool /*first*/) {
if (mask_.At(at).IsTrue()) {
- auto incremented{element.AddSigned(Scalar<T>{1})};
+ auto incremented{element.AddSigned(Scalar<T>{1, kind_})};
overflow_ |= incremented.overflow;
element = incremented.value;
}
@@ -336,20 +343,22 @@ template <typename T, int MASK_KIND> class CountAccumulator {
private:
const Constant<MaskT> &mask_;
+ int kind_;
bool overflow_{false};
};
-template <typename T, int maskKind>
+template <typename T>
static Expr<T> FoldCount(FoldingContext &context, FunctionRef<T> &&ref) {
- using KindLogical = Type<TypeCategory::Logical, maskKind>;
+ using KindLogical = LogicalResult;
static_assert(T::category == TypeCategory::Integer);
+ const int kind{ref.GetType().value().kind()};
std::optional<int> dim;
if (std::optional<ArrayAndMask<KindLogical>> arrayAndMask{
ProcessReductionArgs<KindLogical>(
context, ref.arguments(), dim, /*ARRAY=*/0, /*DIM=*/1)}) {
- CountAccumulator<T, maskKind> accumulator{arrayAndMask->array};
+ CountAccumulator<T> accumulator{arrayAndMask->array, kind};
Constant<T> result{DoReduction<T>(arrayAndMask->array, arrayAndMask->mask,
- dim, Scalar<T>{}, accumulator)};
+ dim, Scalar<T>{0, kind}, accumulator)};
if (accumulator.overflow()) {
context.Warn(common::UsageWarning::FoldingException,
"Result of intrinsic function COUNT overflows its result type"_warn_en_US);
@@ -371,7 +380,7 @@ template <WhichLocation WHICH> class LocationHelper {
AllIntrinsicTypes, RelationalTypes>;
template <typename T> Result Test() const {
- if (T::category != type_.category() || T::kind != type_.kind()) {
+ if (T::category != type_.category()) {
return std::nullopt;
}
CHECK(arg_.size() == (WHICH == WhichLocation::Findloc ? 6 : 5));
@@ -487,7 +496,7 @@ template <WhichLocation WHICH> class LocationHelper {
}
std::vector<Scalar<SubscriptInteger>> resultElements;
for (ConstantSubscript j : resultIndices) {
- resultElements.emplace_back(j);
+ resultElements.emplace_back(j, subscriptIntegerKind);
}
return Constant<SubscriptInteger>{
std::move(resultElements), std::move(resultShape)};
@@ -505,9 +514,8 @@ template <WhichLocation WHICH> class LocationHelper {
if constexpr (T::category == TypeCategory::Logical) {
// array(at) .EQV. value?
static_assert(WHICH == WhichLocation::Findloc);
- cmp.emplace(ConvertToType<LogicalResult>(
- Expr<T>{LogicalOperation<T::kind>{LogicalOperator::Eqv,
- Expr<T>{Constant<T>{element}}, Expr<T>{Constant<T>{*value}}}}));
+ cmp.emplace(Expr<LogicalResult>{LogicalOperation{LogicalOperator::Eqv,
+ Expr<T>{Constant<T>{element}}, Expr<T>{Constant<T>{*value}}}});
} else { // compare array(at) to value
if constexpr (T::category == TypeCategory::Real &&
(WHICH == WhichLocation::Maxloc ||
@@ -572,10 +580,11 @@ static std::optional<Constant<SubscriptInteger>> FoldLocationCall(
template <WhichLocation which, typename T>
static Expr<T> FoldLocation(FoldingContext &context, FunctionRef<T> &&ref) {
static_assert(T::category == TypeCategory::Integer);
+ const int kind{ref.GetType().value().kind()};
if (std::optional<Constant<SubscriptInteger>> found{
FoldLocationCall<which>(ref.arguments(), context)}) {
- return Expr<T>{Fold(
- context, ConvertToType<T>(Expr<SubscriptInteger>{std::move(*found)}))};
+ return Expr<T>{Fold(context,
+ ConvertToType<T>(kind, Expr<SubscriptInteger>{std::move(*found)}))};
} else {
return Expr<T>{std::move(ref)};
}
@@ -607,34 +616,42 @@ std::optional<Expr<T>> FoldIntrinsicFunctionCommon(
auto *intrinsic{std::get_if<SpecificIntrinsic>(&funcRef.proc().u)};
CHECK(intrinsic);
std::string name{intrinsic->name};
- using Int4 = Type<TypeCategory::Integer, 4>;
+ const int kind{funcRef.GetType().value().kind()};
+ using Int4 = Type<TypeCategory::Integer>;
+ auto resultInt{[kind](std::int64_t v) {
+ return Expr<T>{Constant<T>{Scalar<T>{v, kind}, T{kind}}};
+ }};
if (name == "bit_size") {
- return Expr<T>{Scalar<T>::bits};
+ return resultInt(8 * kind);
} else if (name == "digits") {
if (const auto *cx{UnwrapExpr<Expr<SomeInteger>>(args[0])}) {
- return Expr<T>{common::visit(
- [](const auto &kx) {
- return Scalar<ResultType<decltype(kx)>>::DIGITS;
+ return resultInt(common::visit(
+ [](const auto &kx) -> std::int64_t {
+ using KX = ResultType<decltype(kx)>;
+ return Scalar<KX>::DIGITS(kx.GetType().value().kind());
},
- cx->u)};
+ cx->u));
} else if (const auto *cx{UnwrapExpr<Expr<SomeUnsigned>>(args[0])}) {
- return Expr<T>{common::visit(
- [](const auto &kx) {
- return Scalar<ResultType<decltype(kx)>>::DIGITS + 1;
+ return resultInt(common::visit(
+ [](const auto &kx) -> std::int64_t {
+ using KX = ResultType<decltype(kx)>;
+ return Scalar<KX>::DIGITS(kx.GetType().value().kind()) + 1;
},
- cx->u)};
+ cx->u));
} else if (const auto *cx{UnwrapExpr<Expr<SomeReal>>(args[0])}) {
- return Expr<T>{common::visit(
- [](const auto &kx) {
- return Scalar<ResultType<decltype(kx)>>::DIGITS;
+ return resultInt(common::visit(
+ [](const auto &kx) -> std::int64_t {
+ using KX = ResultType<decltype(kx)>;
+ return Scalar<KX>::DIGITS(kx.GetType().value().kind());
},
- cx->u)};
+ cx->u));
} else if (const auto *cx{UnwrapExpr<Expr<SomeComplex>>(args[0])}) {
- return Expr<T>{common::visit(
- [](const auto &kx) {
- return Scalar<typename ResultType<decltype(kx)>::Part>::DIGITS;
+ return resultInt(common::visit(
+ [](const auto &kx) -> std::int64_t {
+ using Part = typename ResultType<decltype(kx)>::Part;
+ return Scalar<Part>::DIGITS(kx.GetType().value().kind());
},
- cx->u)};
+ cx->u));
}
} else if (name == "dot_product") {
return FoldDotProduct<T>(context, std::move(funcRef));
@@ -645,17 +662,19 @@ std::optional<Expr<T>> FoldIntrinsicFunctionCommon(
// than BIT_SIZE. It can be converted to Int4 to simplify.
if (const auto *argCon{Folder<T>(context).Folding(args[0])};
argCon && argCon->empty()) {
- } else if (const auto *shiftCon{Folder<Int4>(context).Folding(args[2])}) {
+ } else if (const auto *shiftCon{Folder<Int4>(
+ context, /*forOptionalArgument=*/false, /*toKind=*/4)
+ .Folding(args[2])}) {
for (const auto &scalar : shiftCon->values()) {
std::int64_t shiftVal{scalar.ToInt64()};
if (shiftVal < 0) {
context.messages().Say("SHIFT=%jd count for %s is negative"_err_en_US,
std::intmax_t{shiftVal}, name);
break;
- } else if (shiftVal > T::Scalar::bits) {
+ } else if (shiftVal > 8 * kind) {
context.messages().Say(
"SHIFT=%jd count for %s is greater than %d"_err_en_US,
- std::intmax_t{shiftVal}, name, T::Scalar::bits);
+ std::intmax_t{shiftVal}, name, 8 * kind);
break;
}
}
@@ -679,11 +698,11 @@ std::optional<Expr<T>> FoldIntrinsicFunctionCommon(
return FoldElementalIntrinsic<T, T, T>(
context, std::move(funcRef), ScalarFunc<T, T, T>(fptr));
} else if (name == "iall") {
- return FoldBitReduction(
- context, std::move(funcRef), &Scalar<T>::IAND, Scalar<T>{}.NOT());
+ return FoldBitReduction(context, std::move(funcRef), &Scalar<T>::IAND,
+ Scalar<T>{0, kind}.NOT());
} else if (name == "iany") {
return FoldBitReduction(
- context, std::move(funcRef), &Scalar<T>::IOR, Scalar<T>{});
+ context, std::move(funcRef), &Scalar<T>::IOR, Scalar<T>{0, kind});
} else if (name == "ibclr" || name == "ibset") {
// Second argument can be of any kind. However, it must be smaller
// than BIT_SIZE. It can be converted to Int4 to simplify.
@@ -696,7 +715,9 @@ std::optional<Expr<T>> FoldIntrinsicFunctionCommon(
}
if (const auto *argCon{Folder<T>(context).Folding(args[0])};
argCon && argCon->empty()) {
- } else if (const auto *posCon{Folder<Int4>(context).Folding(args[1])}) {
+ } else if (const auto *posCon{Folder<Int4>(
+ context, /*forOptionalArgument=*/false, /*toKind=*/4)
+ .Folding(args[1])}) {
for (const auto &scalar : posCon->values()) {
std::int64_t posVal{scalar.ToInt64()};
if (posVal < 0) {
@@ -704,10 +725,10 @@ std::optional<Expr<T>> FoldIntrinsicFunctionCommon(
"bit position for %s (%jd) is negative"_err_en_US, name,
std::intmax_t{posVal});
break;
- } else if (posVal >= T::Scalar::bits) {
+ } else if (posVal >= 8 * kind) {
context.messages().Say(
"bit position for %s (%jd) is not less than %d"_err_en_US, name,
- std::intmax_t{posVal}, T::Scalar::bits);
+ std::intmax_t{posVal}, 8 * kind);
break;
}
}
@@ -718,8 +739,12 @@ std::optional<Expr<T>> FoldIntrinsicFunctionCommon(
return std::invoke(fptr, i, static_cast<int>(pos.ToInt64()));
}));
} else if (name == "ibits") {
- const auto *posCon{Folder<Int4>(context).Folding(args[1])};
- const auto *lenCon{Folder<Int4>(context).Folding(args[2])};
+ const auto *posCon{
+ Folder<Int4>(context, /*forOptionalArgument=*/false, /*toKind=*/4)
+ .Folding(args[1])};
+ const auto *lenCon{
+ Folder<Int4>(context, /*forOptionalArgument=*/false, /*toKind=*/4)
+ .Folding(args[2])};
if (const auto *argCon{Folder<T>(context).Folding(args[0])};
argCon && argCon->empty()) {
} else {
@@ -743,10 +768,10 @@ std::optional<Expr<T>> FoldIntrinsicFunctionCommon(
"bit length for IBITS(LEN=%jd) is negative"_err_en_US,
std::intmax_t{lenVal});
break;
- } else if (posVal + lenVal > T::Scalar::bits) {
+ } else if (posVal + lenVal > 8 * kind) {
context.messages().Say(
"IBITS() must have POS+LEN (>=%jd) no greater than %d"_err_en_US,
- std::intmax_t{posVal + lenVal}, T::Scalar::bits);
+ std::intmax_t{posVal + lenVal}, 8 * kind);
break;
}
}
@@ -766,7 +791,7 @@ std::optional<Expr<T>> FoldIntrinsicFunctionCommon(
using From = std::decay_t<decltype(x)>;
if constexpr (std::is_same_v<From, BOZLiteralConstant> ||
IsNumericCategoryExpr<From>()) {
- return Fold(context, ConvertToType<T>(std::move(x)));
+ return Fold(context, ConvertToType<T>(kind, std::move(x)));
}
DIE("int() argument type not valid");
},
@@ -774,14 +799,16 @@ std::optional<Expr<T>> FoldIntrinsicFunctionCommon(
}
} else if (name == "iparity") {
return FoldBitReduction(
- context, std::move(funcRef), &Scalar<T>::IEOR, Scalar<T>{});
+ context, std::move(funcRef), &Scalar<T>::IEOR, Scalar<T>{0, kind});
} else if (name == "ishft" || name == "ishftc") {
const auto *argCon{Folder<T>(context).Folding(args[0])};
- const auto *shiftCon{Folder<Int4>(context).Folding(args[1])};
+ const auto *shiftCon{
+ Folder<Int4>(context, /*forOptionalArgument=*/false, /*toKind=*/4)
+ .Folding(args[1])};
const auto *shiftVals{shiftCon ? &shiftCon->values() : nullptr};
const auto *sizeCon{args.size() == 3
- ? Folder<Int4>{context, /*forOptionalArgument=*/true}.Folding(
- args[2])
+ ? Folder<Int4>{context, /*forOptionalArgument=*/true, /*toKind=*/4}
+ .Folding(args[2])
: nullptr};
const auto *sizeVals{sizeCon ? &sizeCon->values() : nullptr};
if ((argCon && argCon->empty()) || !shiftVals || shiftVals->empty() ||
@@ -790,15 +817,15 @@ std::optional<Expr<T>> FoldIntrinsicFunctionCommon(
} else {
for (const auto &scalar : *shiftVals) {
std::int64_t shiftVal{scalar.ToInt64()};
- if (shiftVal < -T::Scalar::bits) {
+ if (shiftVal < -8 * kind) {
context.messages().Say(
"SHIFT=%jd count for %s is less than %d"_err_en_US,
- std::intmax_t{shiftVal}, name, -T::Scalar::bits);
+ std::intmax_t{shiftVal}, name, -8 * kind);
break;
- } else if (shiftVal > T::Scalar::bits) {
+ } else if (shiftVal > 8 * kind) {
context.messages().Say(
"SHIFT=%jd count for %s is greater than %d"_err_en_US,
- std::intmax_t{shiftVal}, name, T::Scalar::bits);
+ std::intmax_t{shiftVal}, name, 8 * kind);
break;
}
}
@@ -810,10 +837,10 @@ std::optional<Expr<T>> FoldIntrinsicFunctionCommon(
"SIZE=%jd count for ishftc is not positive"_err_en_US,
std::intmax_t{sizeVal}, name);
break;
- } else if (sizeVal > T::Scalar::bits) {
+ } else if (sizeVal > 8 * kind) {
context.messages().Say(
"SIZE=%jd count for ishftc is greater than %d"_err_en_US,
- std::intmax_t{sizeVal}, T::Scalar::bits);
+ std::intmax_t{sizeVal}, 8 * kind);
break;
}
}
@@ -864,10 +891,10 @@ std::optional<Expr<T>> FoldIntrinsicFunctionCommon(
if (auto *expr{UnwrapExpr<Expr<SomeKind<T::category>>>(args[0])}) {
// Rewrite to IAND(INT(n,k),255_k) for k=KIND(T)
intrinsic->name = "iand";
- auto converted{ConvertToType<T>(std::move(*expr))};
+ auto converted{ConvertToType<T>(kind, std::move(*expr))};
*expr =
Fold(context, Expr<SomeKind<T::category>>{std::move(converted)});
- args.emplace_back(AsGenericExpr(Expr<T>{Scalar<T>{255}}));
+ args.emplace_back(AsGenericExpr(Expr<T>{Scalar<T>{255, kind}}));
return FoldIntrinsicFunction(context, std::move(funcRef));
}
}
@@ -878,9 +905,10 @@ std::optional<Expr<T>> FoldIntrinsicFunctionCommon(
const auto fptr{name == "maskl" || name == "umaskl" ? &Scalar<T>::MASKL
: &Scalar<T>::MASKR};
return FoldElementalIntrinsic<T, Int4>(context, std::move(funcRef),
- ScalarFunc<T, Int4>([&fptr](const Scalar<Int4> &places) -> Scalar<T> {
- return fptr(static_cast<int>(places.ToInt64()));
- }));
+ ScalarFunc<T, Int4>(
+ [&fptr, kind](const Scalar<Int4> &places) -> Scalar<T> {
+ return fptr(static_cast<int>(places.ToInt64()), kind);
+ }));
} else if (name == "matmul") {
return FoldMatmul(context, std::move(funcRef));
} else if (name == "max") {
@@ -889,7 +917,7 @@ std::optional<Expr<T>> FoldIntrinsicFunctionCommon(
return FoldMaxvalMinval<T>(context, std::move(funcRef),
RelationalOperator::GT,
T::category == TypeCategory::Unsigned ? typename T::Scalar{}
- : T::Scalar::Least());
+ : T::Scalar::Least(kind));
} else if (name == "merge_bits") {
return FoldElementalIntrinsic<T, T, T, T>(
context, std::move(funcRef), &Scalar<T>::MERGE_BITS);
@@ -899,14 +927,14 @@ std::optional<Expr<T>> FoldIntrinsicFunctionCommon(
return FoldMaxvalMinval<T>(context, std::move(funcRef),
RelationalOperator::LT,
T::category == TypeCategory::Unsigned ? typename T::Scalar{}.NOT()
- : T::Scalar::HUGE());
+ : T::Scalar::HUGE(kind));
} else if (name == "not") {
return FoldElementalIntrinsic<T, T>(
context, std::move(funcRef), &Scalar<T>::NOT);
} else if (name == "product") {
- return FoldProduct<T>(context, std::move(funcRef), Scalar<T>{1});
+ return FoldProduct<T>(context, std::move(funcRef), Scalar<T>{1, kind});
} else if (name == "radix") {
- return Expr<T>{2};
+ return Expr<T>{Constant<T>{typename T::Scalar{2, kind}}};
} else if (name == "shifta" || name == "shiftr" || name == "shiftl") {
// Second argument can be of any kind. However, it must be smaller or
// equal than BIT_SIZE. It can be converted to Int4 to simplify.
@@ -921,17 +949,19 @@ std::optional<Expr<T>> FoldIntrinsicFunctionCommon(
}
if (const auto *argCon{Folder<T>(context).Folding(args[0])};
argCon && argCon->empty()) {
- } else if (const auto *shiftCon{Folder<Int4>(context).Folding(args[1])}) {
+ } else if (const auto *shiftCon{Folder<Int4>(
+ context, /*forOptionalArgument=*/false, /*toKind=*/4)
+ .Folding(args[1])}) {
for (const auto &scalar : shiftCon->values()) {
std::int64_t shiftVal{scalar.ToInt64()};
if (shiftVal < 0) {
context.messages().Say("SHIFT=%jd count for %s is negative"_err_en_US,
- std::intmax_t{shiftVal}, name, -T::Scalar::bits);
+ std::intmax_t{shiftVal}, name, -8 * kind);
break;
- } else if (shiftVal > T::Scalar::bits) {
+ } else if (shiftVal > 8 * kind) {
context.messages().Say(
"SHIFT=%jd count for %s is greater than %d"_err_en_US,
- std::intmax_t{shiftVal}, name, T::Scalar::bits);
+ std::intmax_t{shiftVal}, name, 8 * kind);
break;
}
}
@@ -947,22 +977,21 @@ std::optional<Expr<T>> FoldIntrinsicFunctionCommon(
return std::nullopt;
}
-template <int KIND>
-Expr<Type<TypeCategory::Integer, KIND>> FoldIntrinsicFunction(
- FoldingContext &context,
- FunctionRef<Type<TypeCategory::Integer, KIND>> &&funcRef) {
+Expr<Type<TypeCategory::Integer>> FoldIntrinsicFunction(FoldingContext &context,
+ FunctionRef<Type<TypeCategory::Integer>> &&funcRef) {
if (auto foldedCommon{FoldIntrinsicFunctionCommon(context, funcRef)}) {
return std::move(*foldedCommon);
}
- using T = Type<TypeCategory::Integer, KIND>;
+ using T = Type<TypeCategory::Integer>;
+ const int kind{funcRef.GetType().value().kind()};
ActualArguments &args{funcRef.arguments()};
auto *intrinsic{std::get_if<SpecificIntrinsic>(&funcRef.proc().u)};
CHECK(intrinsic);
std::string name{intrinsic->name};
- auto FromInt64{[&name, &context](std::int64_t n) {
- Scalar<T> result{n};
+ auto FromInt64{[&name, &context, kind](std::int64_t n) {
+ Scalar<T> result{n, kind};
if (result.ToInt64() != n) {
context.Warn(common::UsageWarning::FoldingException,
"Result of intrinsic function '%s' (%jd) overflows its result type"_warn_en_US,
@@ -970,14 +999,20 @@ Expr<Type<TypeCategory::Integer, KIND>> FoldIntrinsicFunction(
}
return result;
}};
+ auto resultInt{[kind](std::int64_t v) {
+ return Expr<T>{Constant<T>{Scalar<T>{v, kind}, T{kind}}};
+ }};
+ auto fromScalar{[kind](Scalar<T> s) {
+ return Expr<T>{Constant<T>{std::move(s), T{kind}}};
+ }};
if (name == "abs") { // incl. babs, iiabs, jiaabs, & kiabs
return FoldElementalIntrinsic<T, T>(context, std::move(funcRef),
- ScalarFunc<T, T>([&context](const Scalar<T> &i) -> Scalar<T> {
+ ScalarFunc<T, T>([&context, kind](const Scalar<T> &i) -> Scalar<T> {
typename Scalar<T>::ValueWithOverflow j{i.ABS()};
if (j.overflow) {
context.Warn(common::UsageWarning::FoldingException,
- "abs(integer(kind=%d)) folding overflowed"_warn_en_US, KIND);
+ "abs(integer(kind=%d)) folding overflowed"_warn_en_US, kind);
}
return j.value;
}));
@@ -992,7 +1027,7 @@ Expr<Type<TypeCategory::Integer, KIND>> FoldIntrinsicFunction(
using TR = ResultType<decltype(kx)>;
return FoldElementalIntrinsic<T, TR>(context, std::move(funcRef),
ScalarFunc<T, TR>([&](const Scalar<TR> &x) {
- auto y{x.template ToInteger<Scalar<T>>(mode)};
+ auto y{x.ToInteger(mode, 8 * kind)};
if (y.flags.test(RealFlag::Overflow)) {
context.Warn(common::UsageWarning::FoldingException,
"%s intrinsic folding overflow"_warn_en_US, name);
@@ -1003,18 +1038,7 @@ Expr<Type<TypeCategory::Integer, KIND>> FoldIntrinsicFunction(
cx->u);
}
} else if (name == "count") {
- int maskKind = args[0]->GetType()->kind();
- switch (maskKind) {
- SWITCH_COVERS_ALL_CASES
- case 1:
- return FoldCount<T, 1>(context, std::move(funcRef));
- case 2:
- return FoldCount<T, 2>(context, std::move(funcRef));
- case 4:
- return FoldCount<T, 4>(context, std::move(funcRef));
- case 8:
- return FoldCount<T, 8>(context, std::move(funcRef));
- }
+ return FoldCount<T>(context, std::move(funcRef));
} else if (name == "dim") {
return FoldElementalIntrinsic<T, T, T>(context, std::move(funcRef),
ScalarFunc<T, T, T>(
@@ -1031,8 +1055,8 @@ Expr<Type<TypeCategory::Integer, KIND>> FoldIntrinsicFunction(
return common::visit(
[&funcRef, &context](const auto &x) -> Expr<T> {
using TR = typename std::decay_t<decltype(x)>::Result;
- return FoldElementalIntrinsic<T, TR>(context, std::move(funcRef),
- &Scalar<TR>::template EXPONENT<Scalar<T>>);
+ return FoldElementalIntrinsic<T, TR>(
+ context, std::move(funcRef), &Scalar<TR>::EXPONENT);
},
sx->u);
} else {
@@ -1041,7 +1065,7 @@ Expr<Type<TypeCategory::Integer, KIND>> FoldIntrinsicFunction(
} else if (name == "findloc") {
return FoldLocation<WhichLocation::Findloc, T>(context, std::move(funcRef));
} else if (name == "huge") {
- return Expr<T>{Scalar<T>::HUGE()};
+ return fromScalar(Scalar<T>::HUGE(kind));
} else if (name == "iachar" || name == "ichar") {
auto *someChar{UnwrapExpr<Expr<SomeCharacter>>(args[0])};
CHECK(someChar);
@@ -1060,27 +1084,12 @@ Expr<Type<TypeCategory::Integer, KIND>> FoldIntrinsicFunction(
return common::visit(
[&funcRef, &context, &FromInt64](const auto &str) -> Expr<T> {
using Char = typename std::decay_t<decltype(str)>::Result;
- (void)FromInt64;
return FoldElementalIntrinsic<T, Char>(context,
std::move(funcRef),
- ScalarFunc<T, Char>(
-#ifndef _MSC_VER
- [&FromInt64](const Scalar<Char> &c) {
- return FromInt64(CharacterUtils<Char::kind>::ICHAR(
- CharacterUtils<Char::kind>::Resize(c, 1)));
- }));
-#else // _MSC_VER
- // MSVC 14 get confused by the original code above and
- // ends up emitting an error about passing a std::string
- // to the std::u16string instantiation of
- // CharacterUtils<2>::ICHAR(). Can't find a work-around,
- // so remove the FromInt64 error checking lambda that
- // seems to have caused the proble.
- [](const Scalar<Char> &c) {
- return CharacterUtils<Char::kind>::ICHAR(
- CharacterUtils<Char::kind>::Resize(c, 1));
- }));
-#endif // _MSC_VER
+ ScalarFunc<T, Char>([&FromInt64](const Scalar<Char> &c) {
+ return FromInt64(
+ CharacterUtils::ICHAR(CharacterUtils::Resize(c, 1)));
+ }));
},
someChar->u);
}
@@ -1098,13 +1107,12 @@ Expr<Type<TypeCategory::Integer, KIND>> FoldIntrinsicFunction(
const Scalar<TC> &other,
const Scalar<LogicalResult> &back) {
return FromInt64(name == "index"
- ? CharacterUtils<TC::kind>::INDEX(
- str, other, back.IsTrue())
- : name == "scan"
- ? CharacterUtils<TC::kind>::SCAN(
+ ? CharacterUtils::INDEX(
str, other, back.IsTrue())
- : CharacterUtils<TC::kind>::VERIFY(
- str, other, back.IsTrue()));
+ : name == "scan" ? CharacterUtils::SCAN(str,
+ other, back.IsTrue())
+ : CharacterUtils::VERIFY(str,
+ other, back.IsTrue()));
}});
} else {
return FoldElementalIntrinsic<T, TC, TC>(context,
@@ -1113,10 +1121,10 @@ Expr<Type<TypeCategory::Integer, KIND>> FoldIntrinsicFunction(
[&name, &FromInt64](
const Scalar<TC> &str, const Scalar<TC> &other) {
return FromInt64(name == "index"
- ? CharacterUtils<TC::kind>::INDEX(str, other)
+ ? CharacterUtils::INDEX(str, other)
: name == "scan"
- ? CharacterUtils<TC::kind>::SCAN(str, other)
- : CharacterUtils<TC::kind>::VERIFY(str, other));
+ ? CharacterUtils::SCAN(str, other)
+ : CharacterUtils::VERIFY(str, other));
}});
}
},
@@ -1125,7 +1133,7 @@ Expr<Type<TypeCategory::Integer, KIND>> FoldIntrinsicFunction(
DIE("first argument must be CHARACTER");
}
} else if (name == "int_ptr_kind") {
- return Expr<T>{8};
+ return resultInt(8);
} else if (name == "kind") {
// FoldOperation(FunctionRef &&) in fold-implementation.h will not
// have folded the argument; in the case of TypeParamInquiry,
@@ -1134,14 +1142,15 @@ Expr<Type<TypeCategory::Integer, KIND>> FoldIntrinsicFunction(
if (const auto *inquiry{UnwrapExpr<TypeParamInquiry>(*expr)}) {
if (const auto *typeSpec{inquiry->parameter().GetType()}) {
if (const auto *intrinType{typeSpec->AsIntrinsic()}) {
- if (auto k{ToInt64(Fold(
- context, Expr<SubscriptInteger>{intrinType->kind()}))}) {
- return Expr<T>{*k};
+ if (auto k{ToInt64(Fold(context,
+ ConvertToType<SubscriptInteger>(subscriptIntegerKind,
+ common::Clone(intrinType->kind()))))}) {
+ return resultInt(*k);
}
}
}
} else if (auto dyType{expr->GetType()}) {
- return Expr<T>{dyType->kind()};
+ return resultInt(dyType->kind());
}
}
} else if (name == "lbound") {
@@ -1152,12 +1161,16 @@ Expr<Type<TypeCategory::Integer, KIND>> FoldIntrinsicFunction(
name == "popcnt") {
if (auto *sn{UnwrapExpr<Expr<SomeKind<T::category>>>(args[0])}) {
return common::visit(
- [&funcRef, &context, &name](const auto &n) -> Expr<T> {
+ [&funcRef, &context, &name, kind](const auto &n) -> Expr<T> {
using TI = typename std::decay_t<decltype(n)>::Result;
+ // These intrinsics return a default INTEGER count; the result kind
+ // is a runtime property now, so the synthesized scalar must be
+ // built with the result width (8 * kind) rather than defaulting to
+ // a width-less IntegerValue.
if (name == "poppar") {
return FoldElementalIntrinsic<T, TI>(context, std::move(funcRef),
- ScalarFunc<T, TI>([](const Scalar<TI> &i) -> Scalar<T> {
- return Scalar<T>{i.POPPAR() ? 1 : 0};
+ ScalarFunc<T, TI>([kind](const Scalar<TI> &i) -> Scalar<T> {
+ return Scalar<T>{i.POPPAR() ? 1 : 0, kind};
}));
}
auto fptr{&Scalar<TI>::LEADZ};
@@ -1174,8 +1187,8 @@ Expr<Type<TypeCategory::Integer, KIND>> FoldIntrinsicFunction(
// `i` should be declared as `const Scalar<TI>&`.
// We declare it as `auto` to workaround an msvc bug:
// https://developercommunity.visualstudio.com/t/Regression:-nested-closure-assumes-wrong/10130223
- ScalarFunc<T, TI>([&fptr](const auto &i) -> Scalar<T> {
- return Scalar<T>{std::invoke(fptr, i)};
+ ScalarFunc<T, TI>([&fptr, kind](const auto &i) -> Scalar<T> {
+ return Scalar<T>{std::invoke(fptr, i), kind};
}));
},
sn->u);
@@ -1188,7 +1201,7 @@ Expr<Type<TypeCategory::Integer, KIND>> FoldIntrinsicFunction(
[&](auto &kx) {
if (auto len{kx.LEN()}) {
if (IsScopeInvariantExpr(*len, &context)) {
- return Fold(context, ConvertToType<T>(*std::move(len)));
+ return Fold(context, ConvertToType<T>(kind, *std::move(len)));
} else {
return Expr<T>{std::move(funcRef)};
}
@@ -1207,7 +1220,7 @@ Expr<Type<TypeCategory::Integer, KIND>> FoldIntrinsicFunction(
using TC = typename std::decay_t<decltype(kch)>::Result;
return FoldElementalIntrinsic<T, TC>(context, std::move(funcRef),
ScalarFunc<T, TC>{[&FromInt64](const Scalar<TC> &str) {
- return FromInt64(CharacterUtils<TC::kind>::LEN_TRIM(str));
+ return FromInt64(CharacterUtils::LEN_TRIM(str));
}});
},
charExpr->u);
@@ -1219,9 +1232,10 @@ Expr<Type<TypeCategory::Integer, KIND>> FoldIntrinsicFunction(
} else if (name == "maxexponent") {
if (auto *sx{UnwrapExpr<Expr<SomeReal>>(args[0])}) {
return common::visit(
- [](const auto &x) {
+ [&](const auto &x) {
using TR = typename std::decay_t<decltype(x)>::Result;
- return Expr<T>{Scalar<TR>::MAXEXPONENT};
+ return resultInt(
+ Scalar<TR>::MAXEXPONENT(x.GetType().value().kind()));
},
sx->u);
}
@@ -1232,9 +1246,10 @@ Expr<Type<TypeCategory::Integer, KIND>> FoldIntrinsicFunction(
} else if (name == "minexponent") {
if (auto *sx{UnwrapExpr<Expr<SomeReal>>(args[0])}) {
return common::visit(
- [](const auto &x) {
+ [&](const auto &x) {
using TR = typename std::decay_t<decltype(x)>::Result;
- return Expr<T>{Scalar<TR>::MINEXPONENT};
+ return resultInt(
+ Scalar<TR>::MINEXPONENT(x.GetType().value().kind()));
},
sx->u);
}
@@ -1289,43 +1304,49 @@ Expr<Type<TypeCategory::Integer, KIND>> FoldIntrinsicFunction(
}));
} else if (name == "precision") {
if (const auto *cx{UnwrapExpr<Expr<SomeReal>>(args[0])}) {
- return Expr<T>{common::visit(
- [](const auto &kx) {
- return Scalar<ResultType<decltype(kx)>>::PRECISION;
+ return resultInt(common::visit(
+ [](const auto &kx) -> std::int64_t {
+ using KX = ResultType<decltype(kx)>;
+ return Scalar<KX>::PRECISION(kx.GetType().value().kind());
},
- cx->u)};
+ cx->u));
} else if (const auto *cx{UnwrapExpr<Expr<SomeComplex>>(args[0])}) {
- return Expr<T>{common::visit(
- [](const auto &kx) {
- return Scalar<typename ResultType<decltype(kx)>::Part>::PRECISION;
+ return resultInt(common::visit(
+ [](const auto &kx) -> std::int64_t {
+ using Part = typename ResultType<decltype(kx)>::Part;
+ return Scalar<Part>::PRECISION(kx.GetType().value().kind());
},
- cx->u)};
+ cx->u));
}
} else if (name == "range") {
if (const auto *cx{UnwrapExpr<Expr<SomeInteger>>(args[0])}) {
- return Expr<T>{common::visit(
- [](const auto &kx) {
- return Scalar<ResultType<decltype(kx)>>::RANGE;
+ return resultInt(common::visit(
+ [](const auto &kx) -> std::int64_t {
+ using KX = ResultType<decltype(kx)>;
+ return Scalar<KX>::RANGE(kx.GetType().value().kind());
},
- cx->u)};
+ cx->u));
} else if (const auto *cx{UnwrapExpr<Expr<SomeUnsigned>>(args[0])}) {
- return Expr<T>{common::visit(
- [](const auto &kx) {
- return Scalar<ResultType<decltype(kx)>>::UnsignedRANGE;
+ return resultInt(common::visit(
+ [](const auto &kx) -> std::int64_t {
+ using KX = ResultType<decltype(kx)>;
+ return Scalar<KX>::UnsignedRANGE(kx.GetType().value().kind());
},
- cx->u)};
+ cx->u));
} else if (const auto *cx{UnwrapExpr<Expr<SomeReal>>(args[0])}) {
- return Expr<T>{common::visit(
- [](const auto &kx) {
- return Scalar<ResultType<decltype(kx)>>::RANGE;
+ return resultInt(common::visit(
+ [](const auto &kx) -> std::int64_t {
+ using KX = ResultType<decltype(kx)>;
+ return Scalar<KX>::RANGE(kx.GetType().value().kind());
},
- cx->u)};
+ cx->u));
} else if (const auto *cx{UnwrapExpr<Expr<SomeComplex>>(args[0])}) {
- return Expr<T>{common::visit(
- [](const auto &kx) {
- return Scalar<typename ResultType<decltype(kx)>::Part>::RANGE;
+ return resultInt(common::visit(
+ [](const auto &kx) -> std::int64_t {
+ using Part = typename ResultType<decltype(kx)>::Part;
+ return Scalar<Part>::RANGE(kx.GetType().value().kind());
},
- cx->u)};
+ cx->u));
}
} else if (name == "rank") {
if (args[0]) {
@@ -1336,55 +1357,56 @@ Expr<Type<TypeCategory::Integer, KIND>> FoldIntrinsicFunction(
symbol = args[0]->GetAssumedTypeDummy();
}
if (symbol && IsAssumedRank(*symbol)) {
- // DescriptorInquiry can only be placed in expression of kind
- // DescriptorInquiry::Result::kind.
- return ConvertToType<T>(
- Expr<Type<TypeCategory::Integer, DescriptorInquiry::Result::kind>>{
- DescriptorInquiry{
- NamedEntity{*symbol}, DescriptorInquiry::Field::Rank}});
+ return ConvertToType<T>(kind,
+ Expr<DescriptorInquiry::Result>{DescriptorInquiry{
+ NamedEntity{*symbol}, DescriptorInquiry::Field::Rank}});
}
- return Expr<T>{args[0]->Rank()};
+ return resultInt(args[0]->Rank());
}
} else if (name == "selected_char_kind") {
- if (const auto *chCon{UnwrapExpr<Constant<TypeOf<std::string>>>(args[0])}) {
- if (std::optional<std::string> value{chCon->GetScalarValue()}) {
- int defaultKind{
- context.defaults().GetDefaultKind(TypeCategory::Character)};
- return Expr<T>{SelectedCharKind(*value, defaultKind)};
+ if (const auto *chCon{
+ UnwrapExpr<Constant<TypeOf<value::CharacterValue>>>(args[0])}) {
+ if (std::optional<value::CharacterValue> charVal{
+ chCon->GetScalarValue()}) {
+ if (std::optional<std::string> value{charVal->ToStdString()}) {
+ int defaultKind{
+ context.defaults().GetDefaultKind(TypeCategory::Character)};
+ return resultInt(SelectedCharKind(*value, defaultKind));
+ }
}
}
} else if (name == "selected_int_kind" || name == "selected_unsigned_kind") {
if (auto p{ToInt64(args[0])}) {
- return Expr<T>{context.targetCharacteristics().SelectedIntKind(*p)};
+ return resultInt(context.targetCharacteristics().SelectedIntKind(*p));
}
} else if (name == "selected_logical_kind") {
if (auto p{ToInt64(args[0])}) {
- return Expr<T>{context.targetCharacteristics().SelectedLogicalKind(*p)};
+ return resultInt(context.targetCharacteristics().SelectedLogicalKind(*p));
}
} else if (name == "selected_real_kind" ||
name == "__builtin_ieee_selected_real_kind") {
if (auto p{GetInt64ArgOr(args[0], 0)}) {
if (auto r{GetInt64ArgOr(args[1], 0)}) {
if (auto radix{GetInt64ArgOr(args[2], 2)}) {
- return Expr<T>{
- context.targetCharacteristics().SelectedRealKind(*p, *r, *radix)};
+ return resultInt(
+ context.targetCharacteristics().SelectedRealKind(*p, *r, *radix));
}
}
}
} else if (name == "shape") {
if (auto shape{GetContextFreeShape(context, args[0])}) {
if (auto shapeExpr{AsExtentArrayExpr(*shape)}) {
- return Fold(context, ConvertToType<T>(std::move(*shapeExpr)));
+ return Fold(context, ConvertToType<T>(kind, std::move(*shapeExpr)));
}
}
} else if (name == "sign") {
return FoldElementalIntrinsic<T, T, T>(context, std::move(funcRef),
- ScalarFunc<T, T, T>([&context](const Scalar<T> &j,
+ ScalarFunc<T, T, T>([&context, kind](const Scalar<T> &j,
const Scalar<T> &k) -> Scalar<T> {
typename Scalar<T>::ValueWithOverflow result{j.SIGN(k)};
if (result.overflow) {
context.Warn(common::UsageWarning::FoldingException,
- "sign(integer(kind=%d)) folding overflowed"_warn_en_US, KIND);
+ "sign(integer(kind=%d)) folding overflowed"_warn_en_US, kind);
}
return result.value;
}));
@@ -1397,7 +1419,7 @@ Expr<Type<TypeCategory::Integer, KIND>> FoldIntrinsicFunction(
return MakeInvalidIntrinsic<T>(std::move(funcRef));
} else if (dim) {
if (auto &extent{shape->at(*dim)}) {
- return Fold(context, ConvertToType<T>(std::move(*extent)));
+ return Fold(context, ConvertToType<T>(kind, std::move(*extent)));
}
}
} else if (auto extents{common::AllElementsPresent(std::move(*shape))}) {
@@ -1406,22 +1428,24 @@ Expr<Type<TypeCategory::Integer, KIND>> FoldIntrinsicFunction(
for (auto &&extent : std::move(*extents)) {
product = std::move(product) * std::move(extent);
}
- return Expr<T>{ConvertToType<T>(Fold(context, std::move(product)))};
+ return Expr<T>{
+ ConvertToType<T>(kind, Fold(context, std::move(product)))};
}
}
} else if (name == "sizeof") { // in bytes; extension
if (auto info{
characteristics::TypeAndShape::Characterize(args[0], context)}) {
if (auto bytes{info->MeasureSizeInBytes(context)}) {
- return Expr<T>{Fold(context, ConvertToType<T>(std::move(*bytes)))};
+ return Expr<T>{
+ Fold(context, ConvertToType<T>(kind, std::move(*bytes)))};
}
}
} else if (name == "storage_size") { // in bits
if (auto info{
characteristics::TypeAndShape::Characterize(args[0], context)}) {
if (auto bytes{info->MeasureElementSizeInBytes(context, true)}) {
- return Expr<T>{
- Fold(context, Expr<T>{8} * ConvertToType<T>(std::move(*bytes)))};
+ return Expr<T>{Fold(
+ context, resultInt(8) * ConvertToType<T>(kind, std::move(*bytes)))};
}
}
} else if (name == "ubound") {
@@ -1447,26 +1471,26 @@ Expr<Type<TypeCategory::Integer, KIND>> FoldIntrinsicFunction(
common::UsageWarning::FoldingValueChecks, *context.moduleFileName(),
"NUMERIC_STORAGE_SIZE from ISO_FORTRAN_ENV is not well-defined when default INTEGER and REAL are not consistent due to compiler options"_warn_en_US);
}
- return Expr<T>{8 * std::min(intBytes, realBytes)};
+ return resultInt(8 * std::min(intBytes, realBytes));
}
}
return Expr<T>{std::move(funcRef)};
}
-template <int KIND>
-Expr<Type<TypeCategory::Unsigned, KIND>> FoldIntrinsicFunction(
+Expr<Type<TypeCategory::Unsigned>> FoldIntrinsicFunction(
FoldingContext &context,
- FunctionRef<Type<TypeCategory::Unsigned, KIND>> &&funcRef) {
+ FunctionRef<Type<TypeCategory::Unsigned>> &&funcRef) {
if (auto foldedCommon{FoldIntrinsicFunctionCommon(context, funcRef)}) {
return std::move(*foldedCommon);
}
- using T = Type<TypeCategory::Unsigned, KIND>;
+ using T = Type<TypeCategory::Unsigned>;
+ const int kind{funcRef.GetType().value().kind()};
ActualArguments &args{funcRef.arguments()};
auto *intrinsic{std::get_if<SpecificIntrinsic>(&funcRef.proc().u)};
CHECK(intrinsic);
std::string name{intrinsic->name};
if (name == "huge") {
- return Expr<T>{Scalar<T>{}.NOT()};
+ return Expr<T>{Constant<T>{Scalar<T>{0, kind}.NOT(), T{kind}}};
} else if (name == "mod" || name == "modulo") {
bool badPConst{false};
if (auto *pExpr{UnwrapExpr<Expr<T>>(args[1])}) {
@@ -1512,7 +1536,8 @@ Expr<TypeParamInquiry::Result> FoldOperation(
if (paramExpr && IsConstantExpr(*paramExpr, &context)) {
Expr<SomeInteger> intExpr{*paramExpr};
return Fold(context,
- ConvertToType<TypeParamInquiry::Result>(std::move(intExpr)));
+ ConvertToType<TypeParamInquiry::Result>(
+ subscriptIntegerKind, std::move(intExpr)));
}
}
}
@@ -1534,7 +1559,8 @@ Expr<TypeParamInquiry::Result> FoldOperation(
(!isLen || ToInt64(*initExpr))) {
Expr<SomeInteger> expr{*initExpr};
return Fold(context,
- ConvertToType<TypeParamInquiry::Result>(std::move(expr)));
+ ConvertToType<TypeParamInquiry::Result>(
+ subscriptIntegerKind, std::move(expr)));
}
}
}
@@ -1542,8 +1568,9 @@ Expr<TypeParamInquiry::Result> FoldOperation(
if (const auto *value{pdt->FindParameter(parameterName)}) {
if (value->isExplicit()) {
auto folded{Fold(context,
- AsExpr(ConvertToType<TypeParamInquiry::Result>(
- Expr<SomeInteger>{value->GetExplicit().value()})))};
+ AsExpr(
+ ConvertToType<TypeParamInquiry::Result>(subscriptIntegerKind,
+ Expr<SomeInteger>{value->GetExplicit().value()})))};
if (!isLen || ToInt64(folded)) {
return folded;
}
diff --git a/flang/lib/Evaluate/fold-logical.cpp b/flang/lib/Evaluate/fold-logical.cpp
index ab8c5876a13f5..769e9904bbe4b 100644
--- a/flang/lib/Evaluate/fold-logical.cpp
+++ b/flang/lib/Evaluate/fold-logical.cpp
@@ -18,7 +18,8 @@ template <typename T>
static std::optional<Expr<SomeType>> ZeroExtend(const Constant<T> &c) {
std::vector<Scalar<LargestInt>> exts;
for (const auto &v : c.values()) {
- exts.push_back(Scalar<LargestInt>::ConvertUnsigned(v).value);
+ exts.push_back(
+ Scalar<LargestInt>::ConvertUnsigned(v, 8 * largestIntKind).value);
}
return AsGenericExpr(
Constant<LargestInt>(std::move(exts), ConstantSubscripts(c.shape())));
@@ -46,22 +47,22 @@ static Expr<T> FoldAllAnyParity(FoldingContext &context, FunctionRef<T> &&ref,
// are constant. It is guaranteed that 'x' is evaluated at most once.
// TODO: unsigned
-template <int X_RKIND, int MOLD_IKIND>
-Expr<SomeReal> RealToIntBoundHelper(bool round, bool negate) {
- using RType = Type<TypeCategory::Real, X_RKIND>;
- using RealType = Scalar<RType>;
- using IntType = Scalar<Type<TypeCategory::Integer, MOLD_IKIND>>;
- RealType result{}; // 0.
+static Expr<SomeReal> RealToIntBound(
+ int xRKind, int moldIKind, bool round, bool negate) {
+ using RealType = Scalar<Type<TypeCategory::Real>>;
+ using IntType = Scalar<Type<TypeCategory::Integer>>;
+ RealType result{RealType::Zero(xRKind)}; // 0.
common::RoundingMode roundingMode{round
? common::RoundingMode::TiesAwayFromZero
: common::RoundingMode::ToZero};
// Add decreasing powers of two to the result to find the largest magnitude
// value that can be converted to the integer type without overflow.
- RealType at{RealType::FromInteger(IntType{negate ? -1 : 1}).value};
+ RealType at{
+ RealType::FromInteger(IntType{negate ? -1 : 1, moldIKind}, xRKind).value};
bool decrement{true};
- while (!at.template ToInteger<IntType>(roundingMode)
+ while (!at.ToInteger(roundingMode, 8 * moldIKind)
.flags.test(RealFlag::Overflow)) {
- auto tmp{at.SCALE(IntType{1})};
+ auto tmp{at.SCALE(IntType{1, moldIKind})};
if (tmp.flags.test(RealFlag::Overflow)) {
decrement = false;
break;
@@ -70,192 +71,84 @@ Expr<SomeReal> RealToIntBoundHelper(bool round, bool negate) {
}
while (true) {
if (decrement) {
- at = at.SCALE(IntType{-1}).value;
+ at = at.SCALE(IntType{-1, moldIKind}).value;
} else {
decrement = true;
}
auto tmp{at.Add(result)};
if (tmp.flags.test(RealFlag::Inexact)) {
break;
- } else if (!tmp.value.template ToInteger<IntType>(roundingMode)
+ } else if (!tmp.value.ToInteger(roundingMode, 8 * moldIKind)
.flags.test(RealFlag::Overflow)) {
result = tmp.value;
}
}
- return AsCategoryExpr(Constant<RType>{std::move(result)});
-}
-
-static Expr<SomeReal> RealToIntBound(
- int xRKind, int moldIKind, bool round, bool negate) {
- switch (xRKind) {
-#define ICASES(RK) \
- switch (moldIKind) { \
- case 1: \
- return RealToIntBoundHelper<RK, 1>(round, negate); \
- break; \
- case 2: \
- return RealToIntBoundHelper<RK, 2>(round, negate); \
- break; \
- case 4: \
- return RealToIntBoundHelper<RK, 4>(round, negate); \
- break; \
- case 8: \
- return RealToIntBoundHelper<RK, 8>(round, negate); \
- break; \
- case 16: \
- return RealToIntBoundHelper<RK, 16>(round, negate); \
- break; \
- } \
- break
- case 2:
- ICASES(2);
- break;
- case 3:
- ICASES(3);
- break;
- case 4:
- ICASES(4);
- break;
- case 8:
- ICASES(8);
- break;
- case 10:
- ICASES(10);
- break;
- case 16:
- ICASES(16);
- break;
- }
- DIE("RealToIntBound: no case");
-#undef ICASES
+ return AsCategoryExpr(Constant<Type<TypeCategory::Real>>{std::move(result)});
}
-class RealToIntLimitHelper {
-public:
- using Result = std::optional<Expr<SomeReal>>;
- using Types = RealTypes;
- RealToIntLimitHelper(
- FoldingContext &context, Expr<SomeReal> &&hi, Expr<SomeReal> &lo)
- : context_{context}, hi_{std::move(hi)}, lo_{lo} {}
- template <typename T> Result Test() {
- if (UnwrapExpr<Expr<T>>(hi_)) {
- bool promote{T::kind < 16};
- Result constResult;
- if (auto hiV{GetScalarConstantValue<T>(hi_)}) {
- auto loV{GetScalarConstantValue<T>(lo_)};
- CHECK(loV.has_value());
- auto diff{hiV->Subtract(*loV, Rounding{common::RoundingMode::ToZero})};
- promote = promote &&
- (diff.flags.test(RealFlag::Overflow) ||
- diff.flags.test(RealFlag::Inexact));
- constResult = AsCategoryExpr(Constant<T>{std::move(diff.value)});
- }
- if (promote) {
- constexpr int nextKind{T::kind < 4 ? 4 : T::kind == 4 ? 8 : 16};
- using T2 = Type<TypeCategory::Real, nextKind>;
- hi_ = Expr<SomeReal>{Fold(context_, ConvertToType<T2>(std::move(hi_)))};
- lo_ = Expr<SomeReal>{Fold(context_, ConvertToType<T2>(std::move(lo_)))};
- if (constResult) {
- // Use promoted constants on next iteration of SearchTypes
- return std::nullopt;
- }
- }
+static std::optional<Expr<SomeReal>> RealToIntLimit(
+ FoldingContext &context, Expr<SomeReal> &&hi, Expr<SomeReal> &lo) {
+ using RealT = Type<TypeCategory::Real>;
+ // The result kind is carried at runtime; iterate promoting to wider kinds
+ // until the difference (hi - lo) can be represented exactly.
+ while (true) {
+ int kind{hi.GetType().value().kind()};
+ bool promote{kind < 16};
+ std::optional<Expr<SomeReal>> constResult;
+ if (auto hiV{GetScalarConstantValue<RealT>(hi)}) {
+ auto loV{GetScalarConstantValue<RealT>(lo)};
+ CHECK(loV.has_value());
+ auto diff{hiV->Subtract(*loV, Rounding{common::RoundingMode::ToZero})};
+ promote = promote &&
+ (diff.flags.test(RealFlag::Overflow) ||
+ diff.flags.test(RealFlag::Inexact));
+ constResult = AsCategoryExpr(Constant<RealT>{std::move(diff.value)});
+ }
+ if (promote) {
+ int nextKind{kind < 4 ? 4 : kind == 4 ? 8 : 16};
+ hi = Expr<SomeReal>{
+ Fold(context, ConvertToType<RealT>(nextKind, std::move(hi)))};
+ lo = Expr<SomeReal>{
+ Fold(context, ConvertToType<RealT>(nextKind, std::move(lo)))};
if (constResult) {
- return constResult;
- } else {
- return AsCategoryExpr(std::move(hi_) - Expr<SomeReal>{lo_});
+ // Recompute the difference at the promoted kind.
+ continue;
}
+ }
+ if (constResult) {
+ return constResult;
} else {
- return std::nullopt;
+ return AsCategoryExpr(std::move(hi) - Expr<SomeReal>{lo});
}
}
-
-private:
- FoldingContext &context_;
- Expr<SomeReal> hi_;
- Expr<SomeReal> &lo_;
-};
-
-static std::optional<Expr<SomeReal>> RealToIntLimit(
- FoldingContext &context, Expr<SomeReal> &&hi, Expr<SomeReal> &lo) {
- return common::SearchTypes(RealToIntLimitHelper{context, std::move(hi), lo});
}
// RealToRealBounds() returns a pair (HUGE(x),REAL(HUGE(mold),KIND(x)))
// when REAL(HUGE(x),KIND(mold)) overflows, and std::nullopt otherwise.
-template <int X_RKIND, int MOLD_RKIND>
-std::optional<std::pair<Expr<SomeReal>, Expr<SomeReal>>>
-RealToRealBoundsHelper() {
- using RType = Type<TypeCategory::Real, X_RKIND>;
- using RealType = Scalar<RType>;
- using MoldRealType = Scalar<Type<TypeCategory::Real, MOLD_RKIND>>;
- if (!MoldRealType::Convert(RealType::HUGE()).flags.test(RealFlag::Overflow)) {
- return std::nullopt;
- } else {
- return std::make_pair(AsCategoryExpr(Constant<RType>{
- RealType::Convert(MoldRealType::HUGE()).value}),
- AsCategoryExpr(Constant<RType>{RealType::HUGE()}));
- }
-}
-
static std::optional<std::pair<Expr<SomeReal>, Expr<SomeReal>>>
RealToRealBounds(int xRKind, int moldRKind) {
- switch (xRKind) {
-#define RCASES(RK) \
- switch (moldRKind) { \
- case 2: \
- return RealToRealBoundsHelper<RK, 2>(); \
- break; \
- case 3: \
- return RealToRealBoundsHelper<RK, 3>(); \
- break; \
- case 4: \
- return RealToRealBoundsHelper<RK, 4>(); \
- break; \
- case 8: \
- return RealToRealBoundsHelper<RK, 8>(); \
- break; \
- case 10: \
- return RealToRealBoundsHelper<RK, 10>(); \
- break; \
- case 16: \
- return RealToRealBoundsHelper<RK, 16>(); \
- break; \
- } \
- break
- case 2:
- RCASES(2);
- break;
- case 3:
- RCASES(3);
- break;
- case 4:
- RCASES(4);
- break;
- case 8:
- RCASES(8);
- break;
- case 10:
- RCASES(10);
- break;
- case 16:
- RCASES(16);
- break;
+ using RealType = Scalar<Type<TypeCategory::Real>>;
+ if (!RealType::Convert(RealType::HUGE(xRKind), moldRKind)
+ .flags.test(RealFlag::Overflow)) {
+ return std::nullopt;
+ } else {
+ return std::make_pair(
+ AsCategoryExpr(Constant<Type<TypeCategory::Real>>{
+ RealType::Convert(RealType::HUGE(moldRKind), xRKind).value}),
+ AsCategoryExpr(
+ Constant<Type<TypeCategory::Real>>{RealType::HUGE(xRKind)}));
}
- DIE("RealToRealBounds: no case");
-#undef RCASES
}
-template <int X_IKIND, int MOLD_RKIND>
-std::optional<Expr<SomeInteger>> IntToRealBoundHelper(bool negate) {
- using IType = Type<TypeCategory::Integer, X_IKIND>;
- using IntType = Scalar<IType>;
- using RealType = Scalar<Type<TypeCategory::Real, MOLD_RKIND>>;
- IntType result{}; // 0
+static std::optional<Expr<SomeInteger>> IntToRealBound(
+ int xIKind, int moldRKind, bool negate) {
+ using IntType = Scalar<Type<TypeCategory::Integer>>;
+ using RealType = Scalar<Type<TypeCategory::Real>>;
+ IntType result{0, xIKind}; // 0
while (true) {
std::optional<IntType> next;
- for (int bit{0}; bit < IntType::bits; ++bit) {
- IntType power{IntType{}.IBSET(bit)};
+ for (int bit{0}; bit < 8 * xIKind; ++bit) {
+ IntType power{IntType{0, xIKind}.IBSET(bit)};
if (power.IsNegative()) {
if (!negate) {
break;
@@ -265,7 +158,8 @@ std::optional<Expr<SomeInteger>> IntToRealBoundHelper(bool negate) {
}
auto tmp{power.AddSigned(result)};
if (tmp.overflow ||
- RealType::FromInteger(tmp.value).flags.test(RealFlag::Overflow)) {
+ RealType::FromInteger(tmp.value, moldRKind)
+ .flags.test(RealFlag::Overflow)) {
break;
}
next = tmp.value;
@@ -277,112 +171,23 @@ std::optional<Expr<SomeInteger>> IntToRealBoundHelper(bool negate) {
break;
}
}
- if (result.CompareSigned(IntType::HUGE()) == Ordering::Equal) {
+ if (result.CompareSigned(IntType::HUGE(xIKind)) == Ordering::Equal) {
return std::nullopt;
} else {
- return AsCategoryExpr(Constant<IType>{std::move(result)});
- }
-}
-
-static std::optional<Expr<SomeInteger>> IntToRealBound(
- int xIKind, int moldRKind, bool negate) {
- switch (xIKind) {
-#define RCASES(IK) \
- switch (moldRKind) { \
- case 2: \
- return IntToRealBoundHelper<IK, 2>(negate); \
- break; \
- case 3: \
- return IntToRealBoundHelper<IK, 3>(negate); \
- break; \
- case 4: \
- return IntToRealBoundHelper<IK, 4>(negate); \
- break; \
- case 8: \
- return IntToRealBoundHelper<IK, 8>(negate); \
- break; \
- case 10: \
- return IntToRealBoundHelper<IK, 10>(negate); \
- break; \
- case 16: \
- return IntToRealBoundHelper<IK, 16>(negate); \
- break; \
- } \
- break
- case 1:
- RCASES(1);
- break;
- case 2:
- RCASES(2);
- break;
- case 4:
- RCASES(4);
- break;
- case 8:
- RCASES(8);
- break;
- case 16:
- RCASES(16);
- break;
- }
- DIE("IntToRealBound: no case");
-#undef RCASES
-}
-
-template <int X_IKIND, int MOLD_IKIND>
-std::optional<Expr<SomeInteger>> IntToIntBoundHelper() {
- if constexpr (X_IKIND <= MOLD_IKIND) {
- return std::nullopt;
- } else {
- using XIType = Type<TypeCategory::Integer, X_IKIND>;
- using IntegerType = Scalar<XIType>;
- using MoldIType = Type<TypeCategory::Integer, MOLD_IKIND>;
- using MoldIntegerType = Scalar<MoldIType>;
- return AsCategoryExpr(Constant<XIType>{
- IntegerType::ConvertSigned(MoldIntegerType::HUGE()).value});
+ return AsCategoryExpr(
+ Constant<Type<TypeCategory::Integer>>{std::move(result)});
}
}
static std::optional<Expr<SomeInteger>> IntToIntBound(
int xIKind, int moldIKind) {
- switch (xIKind) {
-#define ICASES(IK) \
- switch (moldIKind) { \
- case 1: \
- return IntToIntBoundHelper<IK, 1>(); \
- break; \
- case 2: \
- return IntToIntBoundHelper<IK, 2>(); \
- break; \
- case 4: \
- return IntToIntBoundHelper<IK, 4>(); \
- break; \
- case 8: \
- return IntToIntBoundHelper<IK, 8>(); \
- break; \
- case 16: \
- return IntToIntBoundHelper<IK, 16>(); \
- break; \
- } \
- break
- case 1:
- ICASES(1);
- break;
- case 2:
- ICASES(2);
- break;
- case 4:
- ICASES(4);
- break;
- case 8:
- ICASES(8);
- break;
- case 16:
- ICASES(16);
- break;
+ if (xIKind <= moldIKind) {
+ return std::nullopt;
}
- DIE("IntToIntBound: no case");
-#undef ICASES
+ using IntegerType = Scalar<Type<TypeCategory::Integer>>;
+ return AsCategoryExpr(Constant<Type<TypeCategory::Integer>>{
+ IntegerType::ConvertSigned(IntegerType::HUGE(moldIKind), 8 * xIKind)
+ .value});
}
// ApplyIntrinsic() constructs the typed expression representation
@@ -398,8 +203,9 @@ class IntrinsicCallHelper {
using Result = std::optional<Expr<SomeType>>;
using Types = LengthlessIntrinsicTypes;
template <typename T> Result Test() {
- if (T::category == typeAndShape_->type().category() &&
- T::kind == typeAndShape_->type().kind()) {
+ // The kind is carried at runtime by the procedure's result type, so only
+ // the category needs to be matched among the lengthless intrinsic types.
+ if (T::category == typeAndShape_->type().category()) {
return AsGenericExpr(FunctionRef<T>{
ProcedureDesignator{std::move(call_.specificIntrinsic)},
std::move(call_.arguments)});
@@ -447,7 +253,9 @@ static Expr<SomeType> IntTransferMold(
shape = ConstantSubscripts{1};
}
Constant<SubscriptInteger> value{
- std::vector<Scalar<SubscriptInteger>>{0}, std::move(shape)};
+ std::vector<Scalar<SubscriptInteger>>{
+ Scalar<SubscriptInteger>{0, subscriptIntegerKind}},
+ std::move(shape)};
auto expr{ConvertToType(iType, AsGenericExpr(std::move(value)))};
CHECK(expr.has_value());
return std::move(*expr);
@@ -463,11 +271,11 @@ static Expr<SomeType> GetRealBits(FoldingContext &context, Expr<SomeReal> &&x) {
context.targetCharacteristics(), *xType, asVector)}});
}
-template <int KIND>
-static Expr<Type<TypeCategory::Logical, KIND>> RewriteOutOfRange(
+static Expr<Type<TypeCategory::Logical>> RewriteOutOfRange(
FoldingContext &context,
- FunctionRef<Type<TypeCategory::Logical, KIND>> &&funcRef) {
- using ResultType = Type<TypeCategory::Logical, KIND>;
+ FunctionRef<Type<TypeCategory::Logical>> &&funcRef) {
+ using ResultType = Type<TypeCategory::Logical>;
+ const int resultKind{funcRef.GetType().value().kind()};
ActualArguments &args{funcRef.arguments()};
// Fold x= and round= unconditionally
if (auto *x{UnwrapExpr<Expr<SomeType>>(args[0])}) {
@@ -493,12 +301,14 @@ static Expr<Type<TypeCategory::Logical, KIND>> RewriteOutOfRange(
if (auto hi{IntToIntBound(iXKind, iMoldKind)}) {
// 'hi' is INT(HUGE(mold), KIND(x))
// OUT_OF_RANGE(x,mold) = (x + (hi + 1)) .UGT. (2*hi + 1)
- auto one{DEREF(UnwrapExpr<Expr<SomeInteger>>(ConvertToType(
- xType, AsGenericExpr(Constant<SubscriptInteger>{1}))))};
+ auto one{DEREF(UnwrapExpr<Expr<SomeInteger>>(ConvertToType(xType,
+ AsGenericExpr(Constant<SubscriptInteger>{
+ SubscriptInteger::Scalar{1, subscriptIntegerKind}}))))};
auto lhs{std::move(*iXExpr) +
(Expr<SomeInteger>{*hi} + Expr<SomeInteger>{one})};
- auto two{DEREF(UnwrapExpr<Expr<SomeInteger>>(ConvertToType(
- xType, AsGenericExpr(Constant<SubscriptInteger>{2}))))};
+ auto two{DEREF(UnwrapExpr<Expr<SomeInteger>>(ConvertToType(xType,
+ AsGenericExpr(Constant<SubscriptInteger>{
+ SubscriptInteger::Scalar{2, subscriptIntegerKind}}))))};
auto rhs{std::move(two) * std::move(*hi) + std::move(one)};
result = CompareUnsigned(context, "bgt",
Expr<SomeType>{std::move(lhs)}, Expr<SomeType>{std::move(rhs)});
@@ -585,7 +395,9 @@ static Expr<Type<TypeCategory::Logical, KIND>> RewriteOutOfRange(
GetRealBits(context, std::move(absR) - std::move(moldHuge))};
auto &diffBitsI{DEREF(UnwrapExpr<Expr<SomeInteger>>(diffBits))};
Expr<SomeType> decr{std::move(diffBitsI) -
- Expr<SomeInteger>{Expr<SubscriptInteger>{1}}};
+ Expr<SomeInteger>{
+ Expr<SubscriptInteger>{Constant<SubscriptInteger>{
+ SubscriptInteger::Scalar{1, subscriptIntegerKind}}}}};
result = CompareUnsigned(context, "blt", std::move(decr),
GetRealBits(context, std::move(xHuge)));
} else {
@@ -602,8 +414,9 @@ static Expr<Type<TypeCategory::Logical, KIND>> RewriteOutOfRange(
if (x->Rank() > 0) {
if (auto nez{Relate(context.messages(), RelationalOperator::NE,
std::move(*x),
- AsGenericExpr(Constant<SubscriptInteger>{0}))}) {
- result = Expr<LogicalResult>{LogicalOperation<LogicalResult::kind>{
+ AsGenericExpr(Constant<SubscriptInteger>{
+ SubscriptInteger::Scalar{0, subscriptIntegerKind}}))}) {
+ result = Expr<LogicalResult>{LogicalOperation{
LogicalOperator::And, std::move(*nez), std::move(scalarFalse)}};
}
} else {
@@ -612,8 +425,8 @@ static Expr<Type<TypeCategory::Logical, KIND>> RewriteOutOfRange(
}
if (result) {
auto restorer{context.messages().DiscardMessages()};
- return Fold(
- context, AsExpr(ConvertToType<ResultType>(std::move(*result))));
+ return Fold(context,
+ AsExpr(ConvertToType<ResultType>(resultKind, std::move(*result))));
}
}
}
@@ -638,11 +451,10 @@ static std::optional<common::RoundingMode> GetRoundingMode(
return std::nullopt;
}
-template <int KIND>
-Expr<Type<TypeCategory::Logical, KIND>> FoldIntrinsicFunction(
- FoldingContext &context,
- FunctionRef<Type<TypeCategory::Logical, KIND>> &&funcRef) {
- using T = Type<TypeCategory::Logical, KIND>;
+Expr<Type<TypeCategory::Logical>> FoldIntrinsicFunction(FoldingContext &context,
+ FunctionRef<Type<TypeCategory::Logical>> &&funcRef) {
+ using T = Type<TypeCategory::Logical>;
+ const int kind{funcRef.GetType().value().kind()};
ActualArguments &args{funcRef.arguments()};
auto *intrinsic{std::get_if<SpecificIntrinsic>(&funcRef.proc().u)};
CHECK(intrinsic);
@@ -673,7 +485,9 @@ Expr<Type<TypeCategory::Logical, KIND>> FoldIntrinsicFunction(
std::optional<Expr<SomeType>> constArgs[2];
for (int i{0}; i <= 1; i++) {
if (BOZLiteralConstant * x{UnwrapExpr<BOZLiteralConstant>(args[i])}) {
- constArgs[i] = AsGenericExpr(Constant<LargestInt>{std::move(*x)});
+ // Copy rather than move: when only one operand is constant the fold
+ // below is skipped and args[i] must retain its original BOZ value.
+ constArgs[i] = AsGenericExpr(Constant<LargestInt>{*x});
} else if (auto *x{UnwrapExpr<Expr<SomeInteger>>(args[i])}) {
common::visit(
[&](const auto &ix) {
@@ -714,7 +528,7 @@ Expr<Type<TypeCategory::Logical, KIND>> FoldIntrinsicFunction(
return Expr<T>{std::move(funcRef)};
}
} else if (name == "btest") {
- using SameInt = Type<TypeCategory::Integer, KIND>;
+ using SameInt = Type<TypeCategory::Integer>;
if (const auto *ix{UnwrapExpr<Expr<SomeInteger>>(args[0])}) {
return common::visit(
[&](const auto &x) {
@@ -724,7 +538,7 @@ Expr<Type<TypeCategory::Logical, KIND>> FoldIntrinsicFunction(
ScalarFunc<T, IT, SameInt>(
[&](const Scalar<IT> &x, const Scalar<SameInt> &pos) {
auto posVal{pos.ToInt64()};
- if (posVal < 0 || posVal >= x.bits) {
+ if (posVal < 0 || posVal >= x.bits()) {
context.messages().Say(
"POS=%jd out of range for BTEST"_err_en_US,
static_cast<std::intmax_t>(posVal));
@@ -742,7 +556,7 @@ Expr<Type<TypeCategory::Logical, KIND>> FoldIntrinsicFunction(
ScalarFunc<T, UT, SameInt>(
[&](const Scalar<UT> &x, const Scalar<SameInt> &pos) {
auto posVal{pos.ToInt64()};
- if (posVal < 0 || posVal >= x.bits) {
+ if (posVal < 0 || posVal >= x.bits()) {
context.messages().Say(
"POS=%jd out of range for BTEST"_err_en_US,
static_cast<std::intmax_t>(posVal));
@@ -771,7 +585,7 @@ Expr<Type<TypeCategory::Logical, KIND>> FoldIntrinsicFunction(
if (args[0] && args[0]->UnwrapExpr() &&
IsActuallyConstant(*args[0]->UnwrapExpr())) {
auto restorer{context.messages().DiscardMessages()};
- using DefaultReal = Type<TypeCategory::Real, 4>;
+ using DefaultReal = Type<TypeCategory::Real>;
return FoldElementalIntrinsic<T, DefaultReal>(context, std::move(funcRef),
ScalarFunc<T, DefaultReal>([](const Scalar<DefaultReal> &x) {
return Scalar<T>{x.IsNotANumber()};
@@ -779,7 +593,7 @@ Expr<Type<TypeCategory::Logical, KIND>> FoldIntrinsicFunction(
}
} else if (name == "__builtin_ieee_is_negative") {
auto restorer{context.messages().DiscardMessages()};
- using DefaultReal = Type<TypeCategory::Real, 4>;
+ using DefaultReal = Type<TypeCategory::Real>;
if (args[0] && args[0]->UnwrapExpr() &&
IsActuallyConstant(*args[0]->UnwrapExpr())) {
return FoldElementalIntrinsic<T, DefaultReal>(context, std::move(funcRef),
@@ -789,7 +603,7 @@ Expr<Type<TypeCategory::Logical, KIND>> FoldIntrinsicFunction(
}
} else if (name == "__builtin_ieee_is_normal") {
auto restorer{context.messages().DiscardMessages()};
- using DefaultReal = Type<TypeCategory::Real, 4>;
+ using DefaultReal = Type<TypeCategory::Real>;
if (args[0] && args[0]->UnwrapExpr() &&
IsActuallyConstant(*args[0]->UnwrapExpr())) {
return FoldElementalIntrinsic<T, DefaultReal>(context, std::move(funcRef),
@@ -818,7 +632,7 @@ Expr<Type<TypeCategory::Logical, KIND>> FoldIntrinsicFunction(
} else if (name == "is_iostat_end") {
if (args[0] && args[0]->UnwrapExpr() &&
IsActuallyConstant(*args[0]->UnwrapExpr())) {
- using Int64 = Type<TypeCategory::Integer, 8>;
+ using Int64 = Type<TypeCategory::Integer>;
return FoldElementalIntrinsic<T, Int64>(context, std::move(funcRef),
ScalarFunc<T, Int64>([](const Scalar<Int64> &x) {
return Scalar<T>{x.ToInt64() == FORTRAN_RUNTIME_IOSTAT_END};
@@ -827,7 +641,7 @@ Expr<Type<TypeCategory::Logical, KIND>> FoldIntrinsicFunction(
} else if (name == "is_iostat_eor") {
if (args[0] && args[0]->UnwrapExpr() &&
IsActuallyConstant(*args[0]->UnwrapExpr())) {
- using Int64 = Type<TypeCategory::Integer, 8>;
+ using Int64 = Type<TypeCategory::Integer>;
return FoldElementalIntrinsic<T, Int64>(context, std::move(funcRef),
ScalarFunc<T, Int64>([](const Scalar<Int64> &x) {
return Scalar<T>{x.ToInt64() == FORTRAN_RUNTIME_IOSTAT_EOR};
@@ -839,22 +653,22 @@ Expr<Type<TypeCategory::Logical, KIND>> FoldIntrinsicFunction(
auto *cx1{UnwrapExpr<Expr<SomeCharacter>>(args[1])};
if (cx0 && cx1) {
return Fold(context,
- ConvertToType<T>(
+ ConvertToType<T>(kind,
PackageRelation(name == "lge" ? RelationalOperator::GE
: name == "lgt" ? RelationalOperator::GT
: name == "lle" ? RelationalOperator::LE
: RelationalOperator::LT,
- ConvertToType<Ascii>(std::move(*cx0)),
- ConvertToType<Ascii>(std::move(*cx1)))));
+ ConvertToType<Ascii>(asciiKind, std::move(*cx0)),
+ ConvertToType<Ascii>(asciiKind, std::move(*cx1)))));
}
} else if (name == "logical") {
if (auto *expr{UnwrapExpr<Expr<SomeLogical>>(args[0])}) {
- return Fold(context, ConvertToType<T>(std::move(*expr)));
+ return Fold(context, ConvertToType<T>(kind, std::move(*expr)));
}
} else if (name == "matmul") {
return FoldMatmul(context, std::move(funcRef));
} else if (name == "out_of_range") {
- return RewriteOutOfRange<KIND>(context, std::move(funcRef));
+ return RewriteOutOfRange(context, std::move(funcRef));
} else if (name == "parity") {
return FoldAllAnyParity(
context, std::move(funcRef), &Scalar<T>::NEQV, Scalar<T>{false});
@@ -1004,13 +818,12 @@ Expr<LogicalResult> FoldOperation(
std::move(relation.u));
}
-template <int KIND>
-Expr<Type<TypeCategory::Logical, KIND>> FoldOperation(
- FoldingContext &context, Not<KIND> &&x) {
+Expr<Type<TypeCategory::Logical>> FoldOperation(
+ FoldingContext &context, Not &&x) {
if (auto array{ApplyElementwise(context, x)}) {
return *array;
}
- using Ty = Type<TypeCategory::Logical, KIND>;
+ using Ty = Type<TypeCategory::Logical>;
auto &operand{x.left()};
if (auto value{GetScalarConstantValue<Ty>(operand)}) {
return Expr<Ty>{Constant<Ty>{!value->IsTrue()}};
@@ -1018,14 +831,13 @@ Expr<Type<TypeCategory::Logical, KIND>> FoldOperation(
return Expr<Ty>{x};
}
-template <int KIND>
-Expr<Type<TypeCategory::Logical, KIND>> FoldOperation(
- FoldingContext &context, LogicalOperation<KIND> &&operation) {
- using LOGICAL = Type<TypeCategory::Logical, KIND>;
+Expr<Type<TypeCategory::Logical>> FoldOperation(
+ FoldingContext &context, LogicalOperation &&operation) {
+ using LOGICAL = Type<TypeCategory::Logical>;
if (auto array{ApplyElementwise(context, operation,
std::function<Expr<LOGICAL>(Expr<LOGICAL> &&, Expr<LOGICAL> &&)>{
[=](Expr<LOGICAL> &&x, Expr<LOGICAL> &&y) {
- return Expr<LOGICAL>{LogicalOperation<KIND>{
+ return Expr<LOGICAL>{LogicalOperation{
operation.logicalOperator, std::move(x), std::move(y)}};
}})}) {
return *array;
diff --git a/flang/lib/Evaluate/fold-matmul.h b/flang/lib/Evaluate/fold-matmul.h
index a8a24c09774e8..85479f3a0e7d7 100644
--- a/flang/lib/Evaluate/fold-matmul.h
+++ b/flang/lib/Evaluate/fold-matmul.h
@@ -16,6 +16,8 @@ namespace Fortran::evaluate {
template <typename T>
static Expr<T> FoldMatmul(FoldingContext &context, FunctionRef<T> &&funcRef) {
using Element = typename Constant<T>::Element;
+ const DynamicType resultDynamicType{funcRef.GetType().value()};
+ const int kind{resultDynamicType.kind()};
auto args{funcRef.arguments()};
CHECK(args.size() == 2);
Folder<T> folder{context};
@@ -52,7 +54,18 @@ static Expr<T> FoldMatmul(FoldingContext &context, FunctionRef<T> &&funcRef) {
bAt[1] += ci;
}
Element sum{};
+ if constexpr (T::category == TypeCategory::Integer ||
+ T::category == TypeCategory::Unsigned) {
+ sum = Scalar<T>{0, kind};
+ } else if constexpr (T::category == TypeCategory::Real ||
+ T::category == TypeCategory::Complex) {
+ sum = Element::Zero(kind);
+ }
[[maybe_unused]] Element correction{};
+ if constexpr (T::category == TypeCategory::Real ||
+ T::category == TypeCategory::Complex) {
+ correction = Element::Zero(kind);
+ }
for (ConstantSubscript j{0}; j < commonExtent; ++j) {
Element aElt{ma->At(aAt)};
Element bElt{mb->At(bAt)};
@@ -90,7 +103,7 @@ static Expr<T> FoldMatmul(FoldingContext &context, FunctionRef<T> &&funcRef) {
if (overflow) {
context.Warn(common::UsageWarning::FoldingException,
"MATMUL of %s data overflowed during computation"_warn_en_US,
- T::AsFortran());
+ resultDynamicType.AsFortran());
}
ConstantSubscripts shape;
if (ma->Rank() == 2) {
diff --git a/flang/lib/Evaluate/fold-real.cpp b/flang/lib/Evaluate/fold-real.cpp
index 9c591e2ef36ec..f7c5c27af7ff7 100644
--- a/flang/lib/Evaluate/fold-real.cpp
+++ b/flang/lib/Evaluate/fold-real.cpp
@@ -19,11 +19,15 @@ static Expr<T> FoldTransformationalBessel(
/// Bessel runtime functions use `int` integer arguments. Convert integer
/// arguments to Int4, any overflow error will be reported during the
/// conversion folding.
- using Int4 = Type<TypeCategory::Integer, 4>;
+ using Int4 = Type<TypeCategory::Integer>;
+ const int kind{funcRef.GetType().value().kind()};
if (auto args{GetConstantArguments<Int4, Int4, T>(
context, funcRef.arguments(), /*hasOptionalArgument=*/false)}) {
const std::string &name{std::get<SpecificIntrinsic>(funcRef.proc().u).name};
- if (auto elementalBessel{GetHostRuntimeWrapper<T, Int4, T>(name)}) {
+ if (auto elementalBessel{GetHostRuntimeWrapper<T, Int4, T>(name,
+ DynamicType{T::category, kind},
+ std::vector<DynamicType>{DynamicType{TypeCategory::Integer, 4},
+ DynamicType{T::category, kind}})}) {
std::vector<Scalar<T>> results;
int n1{static_cast<int>(
std::get<0>(*args)->GetScalarValue().value().ToInt64())};
@@ -31,27 +35,27 @@ static Expr<T> FoldTransformationalBessel(
std::get<1>(*args)->GetScalarValue().value().ToInt64())};
Scalar<T> x{std::get<2>(*args)->GetScalarValue().value()};
for (int i{n1}; i <= n2; ++i) {
- results.emplace_back((*elementalBessel)(context, Scalar<Int4>{i}, x));
+ results.emplace_back(
+ (*elementalBessel)(context, value::IntegerValue{i, 4}, x));
}
return Expr<T>{Constant<T>{
std::move(results), ConstantSubscripts{std::max(n2 - n1 + 1, 0)}}};
} else {
context.Warn(common::UsageWarning::FoldingFailure,
"%s(integer(kind=4), real(kind=%d)) cannot be folded on host"_warn_en_US,
- name, T::kind);
+ name, kind);
}
}
return Expr<T>{std::move(funcRef)};
}
// NORM2
-template <int KIND> class Norm2Accumulator {
- using T = Type<TypeCategory::Real, KIND>;
-
+template <typename T> class Norm2Accumulator {
public:
Norm2Accumulator(
const Constant<T> &array, const Constant<T> &maxAbs, Rounding rounding)
- : array_{array}, maxAbs_{maxAbs}, rounding_{rounding} {};
+ : array_{array}, maxAbs_{maxAbs}, rounding_{rounding},
+ correction_{Scalar<T>::Zero(array.GetType().kind())} {};
void operator()(
Scalar<T> &element, const ConstantSubscripts &at, bool /*first*/) {
// Summation of scaled elements:
@@ -103,22 +107,22 @@ template <int KIND> class Norm2Accumulator {
const Constant<T> &maxAbs_;
const Rounding rounding_;
bool overflow_{false};
- Scalar<T> correction_{};
+ Scalar<T> correction_;
ConstantSubscripts maxAbsAt_{maxAbs_.lbounds()};
};
-template <int KIND>
-static Expr<Type<TypeCategory::Real, KIND>> FoldNorm2(FoldingContext &context,
- FunctionRef<Type<TypeCategory::Real, KIND>> &&funcRef) {
- using T = Type<TypeCategory::Real, KIND>;
+static Expr<Type<TypeCategory::Real>> FoldNorm2(
+ FoldingContext &context, FunctionRef<Type<TypeCategory::Real>> &&funcRef) {
+ using T = Type<TypeCategory::Real>;
using Element = typename Constant<T>::Element;
+ const int kind{funcRef.GetType().value().kind()};
std::optional<int> dim;
if (std::optional<ArrayAndMask<T>> arrayAndMask{
ProcessReductionArgs<T>(context, funcRef.arguments(), dim,
/*X=*/0, /*DIM=*/1)}) {
MaxvalMinvalAccumulator<T, /*ABS=*/true> maxAbsAccumulator{
RelationalOperator::GT, context, arrayAndMask->array};
- const Element identity{};
+ const Element identity{Element::Zero(kind)};
Constant<T> maxAbs{DoReduction<T>(arrayAndMask->array, arrayAndMask->mask,
dim, identity, maxAbsAccumulator)};
Norm2Accumulator norm2Accumulator{arrayAndMask->array, maxAbs,
@@ -127,20 +131,19 @@ static Expr<Type<TypeCategory::Real, KIND>> FoldNorm2(FoldingContext &context,
dim, identity, norm2Accumulator)};
if (norm2Accumulator.overflow()) {
context.Warn(common::UsageWarning::FoldingException,
- "NORM2() of REAL(%d) data overflowed"_warn_en_US, KIND);
+ "NORM2() of REAL(%d) data overflowed"_warn_en_US, kind);
}
return Expr<T>{std::move(result)};
}
return Expr<T>{std::move(funcRef)};
}
-template <int KIND>
-Expr<Type<TypeCategory::Real, KIND>> FoldIntrinsicFunction(
- FoldingContext &context,
- FunctionRef<Type<TypeCategory::Real, KIND>> &&funcRef) {
- using T = Type<TypeCategory::Real, KIND>;
- using ComplexT = Type<TypeCategory::Complex, KIND>;
- using Int4 = Type<TypeCategory::Integer, 4>;
+Expr<Type<TypeCategory::Real>> FoldIntrinsicFunction(
+ FoldingContext &context, FunctionRef<Type<TypeCategory::Real>> &&funcRef) {
+ using T = Type<TypeCategory::Real>;
+ using ComplexT = Type<TypeCategory::Complex>;
+ using Int4 = Type<TypeCategory::Integer>;
+ const int kind{funcRef.GetType().value().kind()};
ActualArguments &args{funcRef.arguments()};
auto *intrinsic{std::get_if<SpecificIntrinsic>(&funcRef.proc().u)};
CHECK(intrinsic);
@@ -154,12 +157,12 @@ Expr<Type<TypeCategory::Real, KIND>> FoldIntrinsicFunction(
name == "log_gamma" || name == "sin" || name == "sinh" || name == "tan" ||
name == "tanh") {
CHECK(args.size() == 1);
- if (auto callable{GetHostRuntimeWrapper<T, T>(name)}) {
+ if (auto callable{GetHostRuntimeWrapper<T, T>(name, kind)}) {
return FoldElementalIntrinsic<T, T>(
context, std::move(funcRef), *callable);
} else {
context.Warn(common::UsageWarning::FoldingFailure,
- "%s(real(kind=%d)) cannot be folded on host"_warn_en_US, name, KIND);
+ "%s(real(kind=%d)) cannot be folded on host"_warn_en_US, name, kind);
}
} else if (name == "amax0" || name == "amin0" || name == "amin1" ||
name == "amax1" || name == "dmin1" || name == "dmax1") {
@@ -167,24 +170,27 @@ Expr<Type<TypeCategory::Real, KIND>> FoldIntrinsicFunction(
} else if (name == "atan" || name == "atan2") {
std::string localName{name == "atan" ? "atan2" : name};
CHECK(args.size() == 2);
- if (auto callable{GetHostRuntimeWrapper<T, T, T>(localName)}) {
+ if (auto callable{GetHostRuntimeWrapper<T, T, T>(localName, kind)}) {
return FoldElementalIntrinsic<T, T, T>(
context, std::move(funcRef), *callable);
} else {
context.Warn(common::UsageWarning::FoldingFailure,
"%s(real(kind=%d), real(kind%d)) cannot be folded on host"_warn_en_US,
- name, KIND, KIND);
+ name, kind, kind);
}
} else if (name == "bessel_jn" || name == "bessel_yn") {
if (args.size() == 2) { // elemental
// runtime functions use int arg
- if (auto callable{GetHostRuntimeWrapper<T, Int4, T>(name)}) {
+ if (auto callable{GetHostRuntimeWrapper<T, Int4, T>(name,
+ DynamicType{T::category, kind},
+ std::vector<DynamicType>{DynamicType{TypeCategory::Integer, 4},
+ DynamicType{T::category, kind}})}) {
return FoldElementalIntrinsic<T, Int4, T>(
context, std::move(funcRef), *callable);
} else {
context.Warn(common::UsageWarning::FoldingFailure,
"%s(integer(kind=4), real(kind=%d)) cannot be folded on host"_warn_en_US,
- name, KIND);
+ name, kind);
}
} else {
return FoldTransformationalBessel<T>(std::move(funcRef), context);
@@ -247,18 +253,18 @@ Expr<Type<TypeCategory::Real, KIND>> FoldIntrinsicFunction(
const auto *yExpr{args[1]->UnwrapExpr()};
if (xExpr && yExpr) {
return Fold(context,
- ToReal<T::kind>(context, common::Clone(*xExpr)) *
- ToReal<T::kind>(context, common::Clone(*yExpr)));
+ ToReal(context, common::Clone(*xExpr), kind) *
+ ToReal(context, common::Clone(*yExpr), kind));
}
}
} else if (name == "epsilon") {
- return Expr<T>{Scalar<T>::EPSILON()};
+ return Expr<T>{Scalar<T>::EPSILON(kind)};
} else if (name == "fraction") {
return FoldElementalIntrinsic<T, T>(context, std::move(funcRef),
ScalarFunc<T, T>(
[](const Scalar<T> &x) -> Scalar<T> { return x.FRACTION(); }));
} else if (name == "huge") {
- return Expr<T>{Scalar<T>::HUGE()};
+ return Expr<T>{Scalar<T>::HUGE(kind)};
} else if (name == "hypot") {
CHECK(args.size() == 2);
return FoldElementalIntrinsic<T, T, T>(context, std::move(funcRef),
@@ -277,12 +283,12 @@ Expr<Type<TypeCategory::Real, KIND>> FoldIntrinsicFunction(
return FoldMINorMAX(context, std::move(funcRef), Ordering::Greater);
} else if (name == "maxval") {
return FoldMaxvalMinval<T>(context, std::move(funcRef),
- RelationalOperator::GT, T::Scalar::HUGE().Negate());
+ RelationalOperator::GT, Scalar<T>::HUGE(kind).Negate());
} else if (name == "min") {
return FoldMINorMAX(context, std::move(funcRef), Ordering::Less);
} else if (name == "minval") {
- return FoldMaxvalMinval<T>(
- context, std::move(funcRef), RelationalOperator::LT, T::Scalar::HUGE());
+ return FoldMaxvalMinval<T>(context, std::move(funcRef),
+ RelationalOperator::LT, Scalar<T>::HUGE(kind));
} else if (name == "mod") {
CHECK(args.size() == 2);
bool badPConst{false};
@@ -360,13 +366,13 @@ Expr<Type<TypeCategory::Real, KIND>> FoldIntrinsicFunction(
sExpr->u);
}
} else if (name == "norm2") {
- return FoldNorm2<T::kind>(context, std::move(funcRef));
+ return FoldNorm2(context, std::move(funcRef));
} else if (name == "product") {
- auto one{Scalar<T>::FromInteger(value::Integer<8>{1}).value};
+ auto one{Scalar<T>::FromInteger(value::IntegerValue{1, 1}, kind).value};
return FoldProduct<T>(context, std::move(funcRef), one);
} else if (name == "real" || name == "dble") {
if (auto *expr{args[0].value().UnwrapExpr()}) {
- return ToReal<KIND>(context, std::move(*expr));
+ return ToReal(context, std::move(*expr), kind);
}
} else if (name == "rrspacing") {
return FoldElementalIntrinsic<T, T>(context, std::move(funcRef),
@@ -381,8 +387,7 @@ Expr<Type<TypeCategory::Real, KIND>> FoldIntrinsicFunction(
std::move(funcRef),
ScalarFunc<T, T, TBY>(
[&](const Scalar<T> &x, const Scalar<TBY> &y) -> Scalar<T> {
- ValueWithRealFlags<Scalar<T>> result{
- x.template SCALE<Scalar<TBY>>(y)};
+ ValueWithRealFlags<Scalar<T>> result{x.SCALE(y)};
if (result.flags.test(RealFlag::Overflow)) {
context.Warn(common::UsageWarning::FoldingException,
"SCALE/IEEE_SCALB intrinsic folding overflow"_warn_en_US);
@@ -425,7 +430,7 @@ Expr<Type<TypeCategory::Real, KIND>> FoldIntrinsicFunction(
} else if (name == "sum") {
return FoldSum<T>(context, std::move(funcRef));
} else if (name == "tiny") {
- return Expr<T>{Scalar<T>::TINY()};
+ return Expr<T>{Scalar<T>::TINY(kind)};
} else if (name == "__builtin_fma") {
CHECK(args.size() == 3);
} else if (name == "__builtin_ieee_next_after") {
@@ -436,13 +441,15 @@ Expr<Type<TypeCategory::Real, KIND>> FoldIntrinsicFunction(
return FoldElementalIntrinsic<T, T, TY>(context, std::move(funcRef),
ScalarFunc<T, T, TY>([&](const Scalar<T> &x,
const Scalar<TY> &y) -> Scalar<T> {
- auto xBig{Scalar<LargestReal>::Convert(x).value};
- auto yBig{Scalar<LargestReal>::Convert(y).value};
+ auto xBig{
+ Scalar<LargestReal>::Convert(x, largestRealKind).value};
+ auto yBig{
+ Scalar<LargestReal>::Convert(y, largestRealKind).value};
switch (xBig.Compare(yBig)) {
case Relation::Unordered:
context.Warn(common::UsageWarning::FoldingValueChecks,
"IEEE_NEXT_AFTER intrinsic folding: arguments are unordered"_warn_en_US);
- return x.NotANumber();
+ return Scalar<T>::NotANumber(kind);
case Relation::Equal:
break;
case Relation::Less:
diff --git a/flang/lib/Evaluate/fold-reduction.h b/flang/lib/Evaluate/fold-reduction.h
index a068364135295..ae2427e37056d 100644
--- a/flang/lib/Evaluate/fold-reduction.h
+++ b/flang/lib/Evaluate/fold-reduction.h
@@ -18,6 +18,8 @@ template <typename T>
static Expr<T> FoldDotProduct(
FoldingContext &context, FunctionRef<T> &&funcRef) {
using Element = typename Constant<T>::Element;
+ const DynamicType resultDynamicType{funcRef.GetType().value()};
+ const int kind{resultDynamicType.kind()};
auto args{funcRef.arguments()};
CHECK(args.size() == 2);
Folder<T> folder{context};
@@ -32,6 +34,13 @@ static Expr<T> FoldDotProduct(
return MakeInvalidIntrinsic(std::move(funcRef));
}
Element sum{};
+ if constexpr (T::category == TypeCategory::Real ||
+ T::category == TypeCategory::Complex) {
+ sum = Element::Zero(kind);
+ } else if constexpr (T::category == TypeCategory::Integer ||
+ T::category == TypeCategory::Unsigned) {
+ sum = Element{0, kind};
+ }
bool overflow{false};
if constexpr (T::category == TypeCategory::Complex) {
std::vector<Element> conjugates;
@@ -43,7 +52,7 @@ static Expr<T> FoldDotProduct(
Expr<T> products{Fold(
context, Expr<T>{std::move(conjgA)} * Expr<T>{Constant<T>{*vb}})};
Constant<T> &cProducts{DEREF(UnwrapConstantValue<T>(products))};
- [[maybe_unused]] Element correction{};
+ [[maybe_unused]] Element correction{Element::Zero(kind)};
const auto &rounding{context.targetCharacteristics().roundingMode()};
for (const Element &x : cProducts.values()) {
if constexpr (useKahanSummation) {
@@ -58,7 +67,7 @@ static Expr<T> FoldDotProduct(
}
} else if constexpr (T::category == TypeCategory::Logical) {
Expr<T> conjunctions{Fold(context,
- Expr<T>{LogicalOperation<T::kind>{LogicalOperator::And,
+ Expr<T>{LogicalOperation{LogicalOperator::And,
Expr<T>{Constant<T>{*va}}, Expr<T>{Constant<T>{*vb}}}})};
Constant<T> &cConjunctions{DEREF(UnwrapConstantValue<T>(conjunctions))};
for (const Element &x : cConjunctions.values()) {
@@ -88,7 +97,7 @@ static Expr<T> FoldDotProduct(
Expr<T> products{
Fold(context, Expr<T>{Constant<T>{*va}} * Expr<T>{Constant<T>{*vb}})};
Constant<T> &cProducts{DEREF(UnwrapConstantValue<T>(products))};
- [[maybe_unused]] Element correction{};
+ [[maybe_unused]] Element correction{Element::Zero(kind)};
const auto &rounding{context.targetCharacteristics().roundingMode()};
for (const Element &x : cProducts.values()) {
if constexpr (useKahanSummation) {
@@ -105,7 +114,7 @@ static Expr<T> FoldDotProduct(
if (overflow) {
context.Warn(common::UsageWarning::FoldingException,
"DOT_PRODUCT of %s data overflowed during computation"_warn_en_US,
- T::AsFortran());
+ resultDynamicType.AsFortran());
}
return Expr<T>{Constant<T>{std::move(sum)}};
}
@@ -324,7 +333,8 @@ static Expr<T> FoldProduct(
arrayAndMask->array, arrayAndMask->mask, dim, identity, accumulator)}};
if (accumulator.overflow()) {
context.Warn(common::UsageWarning::FoldingException,
- "PRODUCT() of %s data overflowed"_warn_en_US, T::AsFortran());
+ "PRODUCT() of %s data overflowed"_warn_en_US,
+ ref.GetType().value().AsFortran());
}
return result;
}
@@ -337,7 +347,12 @@ template <typename T> class SumAccumulator {
public:
SumAccumulator(const Constant<T> &array, Rounding rounding)
- : array_{array}, rounding_{rounding} {}
+ : array_{array}, rounding_{rounding}, kind_{array.GetType().kind()} {
+ if constexpr (T::category == TypeCategory::Real ||
+ T::category == TypeCategory::Complex) {
+ correction_ = Element::Zero(kind_);
+ }
+ }
void operator()(
Element &element, const ConstantSubscripts &at, bool /*first*/) {
if constexpr (T::category == TypeCategory::Integer) {
@@ -358,7 +373,7 @@ template <typename T> class SumAccumulator {
T::category != TypeCategory::Unsigned) {
auto corrected{element.Add(correction_, rounding_)};
overflow_ |= corrected.flags.test(RealFlag::Overflow);
- correction_ = Scalar<T>{};
+ correction_ = Element::Zero(kind_);
element = corrected.value;
}
}
@@ -367,6 +382,7 @@ template <typename T> class SumAccumulator {
const Constant<T> &array_;
Rounding rounding_;
bool overflow_{false};
+ int kind_;
Element correction_{};
};
@@ -377,8 +393,16 @@ static Expr<T> FoldSum(FoldingContext &context, FunctionRef<T> &&ref) {
T::category == TypeCategory::Real ||
T::category == TypeCategory::Complex);
using Element = typename Constant<T>::Element;
+ const int kind{ref.GetType().value().kind()};
std::optional<int> dim;
Element identity{};
+ if constexpr (T::category == TypeCategory::Integer ||
+ T::category == TypeCategory::Unsigned) {
+ identity = Scalar<T>{0, kind};
+ } else if constexpr (T::category == TypeCategory::Real ||
+ T::category == TypeCategory::Complex) {
+ identity = Element::Zero(kind);
+ }
if (std::optional<ArrayAndMask<T>> arrayAndMask{
ProcessReductionArgs<T>(context, ref.arguments(), dim,
/*ARRAY=*/0, /*DIM=*/1, /*MASK=*/2)}) {
@@ -388,7 +412,8 @@ static Expr<T> FoldSum(FoldingContext &context, FunctionRef<T> &&ref) {
arrayAndMask->array, arrayAndMask->mask, dim, identity, accumulator)}};
if (accumulator.overflow()) {
context.Warn(common::UsageWarning::FoldingException,
- "SUM() of %s data overflowed"_warn_en_US, T::AsFortran());
+ "SUM() of %s data overflowed"_warn_en_US,
+ ref.GetType().value().AsFortran());
}
return result;
}
diff --git a/flang/lib/Evaluate/fold.cpp b/flang/lib/Evaluate/fold.cpp
index a2f6bc0f2ae51..17a1997aec3fe 100644
--- a/flang/lib/Evaluate/fold.cpp
+++ b/flang/lib/Evaluate/fold.cpp
@@ -51,7 +51,7 @@ std::optional<Constant<SubscriptInteger>> GetConstantSubscript(
std::vector<SubscriptInteger::Scalar> values;
while ((*stride > 0 && *lbi <= *ubi) ||
(*stride < 0 && *lbi >= *ubi)) {
- values.emplace_back(*lbi);
+ values.emplace_back(*lbi, subscriptIntegerKind);
*lbi += *stride;
}
return Constant<SubscriptInteger>{std::move(values),
@@ -214,7 +214,8 @@ std::optional<std::int64_t> GetInt64ArgOr(
Expr<ImpliedDoIndex::Result> FoldOperation(
FoldingContext &context, ImpliedDoIndex &&iDo) {
if (std::optional<ConstantSubscript> value{context.GetImpliedDo(iDo.name)}) {
- return Expr<ImpliedDoIndex::Result>{*value};
+ return Expr<ImpliedDoIndex::Result>{Constant<ImpliedDoIndex::Result>{
+ ImpliedDoIndex::Result::Scalar{*value, subscriptIntegerKind}}};
} else {
return Expr<ImpliedDoIndex::Result>{std::move(iDo)};
}
diff --git a/flang/lib/Evaluate/formatting.cpp b/flang/lib/Evaluate/formatting.cpp
index 3604484254196..30492dcbee1a6 100644
--- a/flang/lib/Evaluate/formatting.cpp
+++ b/flang/lib/Evaluate/formatting.cpp
@@ -8,6 +8,8 @@
#include "flang/Evaluate/formatting.h"
#include "flang/Evaluate/call.h"
+#include "flang/Evaluate/character-value-impl.h"
+// #include "flang/Evaluate/char-storage-access.h"
#include "flang/Evaluate/constant.h"
#include "flang/Evaluate/expression.h"
#include "flang/Evaluate/fold.h"
@@ -73,22 +75,30 @@ llvm::raw_ostream &ConstantBase<RESULT, VALUE>::AsFortran(
o << ',';
}
if constexpr (Result::category == TypeCategory::Integer) {
- o << value.SignedDecimal() << '_' << Result::kind;
+ o << value.SignedDecimal() << '_' << value.kind();
} else if constexpr (Result::category == TypeCategory::Unsigned) {
- o << value.UnsignedDecimal() << "U_" << Result::kind;
+ o << value.UnsignedDecimal() << "U_" << value.kind();
} else if constexpr (Result::category == TypeCategory::Real ||
Result::category == TypeCategory::Complex) {
- value.AsFortran(o, Result::kind);
+ value.AsFortran(o, value.kind());
} else if constexpr (Result::category == TypeCategory::Character) {
- o << Result::kind << '_' << parser::QuoteCharacterLiteral(value, true);
+ o << value.kind() << '_';
+ common::visit(
+ [&o](const auto &s) {
+ if constexpr (!std::is_same_v<std::decay_t<decltype(s)>,
+ std::monostate>) {
+ o << parser::QuoteCharacterLiteral(s, true);
+ }
+ },
+ GetCharacterStorage(value));
} else if constexpr (Result::category == TypeCategory::Logical) {
if (!value.IsCanonical()) {
o << "transfer(" << value.word().ToInt64() << "_8,.false._"
- << Result::kind << ')';
+ << value.kind() << ')';
} else if (value.IsTrue()) {
- o << ".true." << '_' << Result::kind;
+ o << ".true." << '_' << value.kind();
} else {
- o << ".false." << '_' << Result::kind;
+ o << ".false." << '_' << value.kind();
}
} else {
StructureConstructor{result_.derivedTypeSpec(), value}.AsFortran(o);
@@ -109,8 +119,7 @@ std::string ConstantBase<RESULT, VALUE>::AsFortran() const {
return result;
}
-template <int KIND>
-llvm::raw_ostream &Constant<Type<TypeCategory::Character, KIND>>::AsFortran(
+llvm::raw_ostream &Constant<Type<TypeCategory::Character>>::AsFortran(
llvm::raw_ostream &o) const {
bool hasNonDefaultLowerBound{printLbounds && HasNonDefaultLowerBound()};
if (Rank() > 1 || hasNonDefaultLowerBound) {
@@ -125,10 +134,14 @@ llvm::raw_ostream &Constant<Type<TypeCategory::Character, KIND>>::AsFortran(
if (j > 0) {
o << ',';
}
- if (Result::kind != 1) {
- o << Result::kind << '_';
+ if (kind_ != 1) {
+ o << kind_ << '_';
+ }
+
+ if (!value.value().IsMonostate()) {
+ value.value().WithChar(
+ [&o](const auto &s) { o << parser::QuoteCharacterLiteral(s); });
}
- o << parser::QuoteCharacterLiteral(value);
}
if (Rank() > 0) {
o << ']';
@@ -137,8 +150,7 @@ llvm::raw_ostream &Constant<Type<TypeCategory::Character, KIND>>::AsFortran(
return o;
}
-template <int KIND>
-std::string Constant<Type<TypeCategory::Character, KIND>>::AsFortran() const {
+std::string Constant<Type<TypeCategory::Character>>::AsFortran() const {
std::string result;
llvm::raw_string_ostream sstream(result);
AsFortran(sstream);
@@ -320,8 +332,7 @@ enum class Precedence { // in increasing order for sane comparisons
template <typename A> constexpr Precedence ToPrecedence(const A &) {
return Precedence::Top;
}
-template <int KIND>
-static Precedence ToPrecedence(const LogicalOperation<KIND> &x) {
+static Precedence ToPrecedence(const LogicalOperation &x) {
switch (x.logicalOperator) {
SWITCH_COVERS_ALL_CASES
case LogicalOperator::And:
@@ -335,9 +346,7 @@ static Precedence ToPrecedence(const LogicalOperation<KIND> &x) {
return Precedence::Equivalence;
}
}
-template <int KIND> constexpr Precedence ToPrecedence(const Not<KIND> &) {
- return Precedence::Not;
-}
+inline Precedence ToPrecedence(const Not &) { return Precedence::Not; }
template <typename T> constexpr Precedence ToPrecedence(const Relational<T> &) {
return Precedence::Relational;
}
@@ -347,9 +356,7 @@ template <typename T> constexpr Precedence ToPrecedence(const Add<T> &) {
template <typename T> constexpr Precedence ToPrecedence(const Subtract<T> &) {
return Precedence::Additive;
}
-template <int KIND> constexpr Precedence ToPrecedence(const Concat<KIND> &) {
- return Precedence::Additive;
-}
+inline Precedence ToPrecedence(const Concat &) { return Precedence::Additive; }
template <typename T> constexpr Precedence ToPrecedence(const Negate<T> &) {
return Precedence::Negate;
}
@@ -412,20 +419,16 @@ template <typename A>
constexpr OperatorSpelling SpellOperator(const Parentheses<A> &) {
return OperatorSpelling{"(", "", ")"};
}
-template <int KIND>
-static OperatorSpelling SpellOperator(const ComplexComponent<KIND> &x) {
+static OperatorSpelling SpellOperator(const ComplexComponent &x) {
return {x.isImaginaryPart ? "aimag(" : "real(", "", ")"};
}
-template <int KIND>
-constexpr OperatorSpelling SpellOperator(const Not<KIND> &) {
+constexpr OperatorSpelling SpellOperator(const Not &) {
return OperatorSpelling{".NOT.", "", ""};
}
-template <int KIND>
-constexpr OperatorSpelling SpellOperator(const SetLength<KIND> &) {
+constexpr OperatorSpelling SpellOperator(const SetLength &) {
return OperatorSpelling{"%SET_LENGTH(", ",", ")"};
}
-template <int KIND>
-constexpr OperatorSpelling SpellOperator(const ComplexConstructor<KIND> &) {
+constexpr OperatorSpelling SpellOperator(const ComplexConstructor &) {
return OperatorSpelling{"(", ",", ")"};
}
template <typename A> constexpr OperatorSpelling SpellOperator(const Add<A> &) {
@@ -456,12 +459,10 @@ static OperatorSpelling SpellOperator(const Extremum<A> &x) {
return OperatorSpelling{
x.ordering == Ordering::Less ? "min(" : "max(", ",", ")"};
}
-template <int KIND>
-constexpr OperatorSpelling SpellOperator(const Concat<KIND> &) {
+constexpr OperatorSpelling SpellOperator(const Concat &) {
return OperatorSpelling{"", "//", ""};
}
-template <int KIND>
-static OperatorSpelling SpellOperator(const LogicalOperation<KIND> &x) {
+static OperatorSpelling SpellOperator(const LogicalOperation &x) {
return OperatorSpelling{"", AsFortran(x.logicalOperator), ""};
}
template <typename T>
@@ -523,7 +524,7 @@ llvm::raw_ostream &Convert<TO, FROMCAT>::AsFortran(llvm::raw_ostream &o) const {
} else {
this->left().AsFortran(o << "uint(");
}
- return o << ",kind=" << TO::kind << ')';
+ return o << ",kind=" << this->resultKind_ << ')';
}
llvm::raw_ostream &Relational<SomeType>::AsFortran(llvm::raw_ostream &o) const {
@@ -544,7 +545,8 @@ template <typename T>
llvm::raw_ostream &EmitArray(llvm::raw_ostream &o, const ImpliedDo<T> &implDo) {
o << '(';
EmitArray(o, implDo.values());
- o << ',' << ImpliedDoIndex::Result::AsFortran()
+ o << ','
+ << DynamicType{TypeCategory::Integer, subscriptIntegerKind}.AsFortran()
<< "::" << implDo.name().ToString() << '=';
implDo.lower().AsFortran(o) << ',';
implDo.upper().AsFortran(o) << ',';
@@ -571,9 +573,7 @@ llvm::raw_ostream &ArrayConstructor<T>::AsFortran(llvm::raw_ostream &o) const {
return o << ']';
}
-template <int KIND>
-llvm::raw_ostream &
-ArrayConstructor<Type<TypeCategory::Character, KIND>>::AsFortran(
+llvm::raw_ostream &ArrayConstructor<Type<TypeCategory::Character>>::AsFortran(
llvm::raw_ostream &o) const {
o << '[';
if (const auto *len{LEN()}) {
@@ -850,7 +850,7 @@ llvm::raw_ostream &DescriptorInquiry::AsFortran(llvm::raw_ostream &o) const {
o << ",dim=" << (dimension_ + 1);
}
}
- return o << ",kind=" << DescriptorInquiry::Result::kind << ")";
+ return o << ",kind=" << subscriptIntegerKind << ")";
}
llvm::raw_ostream &Assignment::AsFortran(llvm::raw_ostream &o) const {
diff --git a/flang/lib/Evaluate/host.h b/flang/lib/Evaluate/host.h
index fbb52f2886a40..82b9f77de8b87 100644
--- a/flang/lib/Evaluate/host.h
+++ b/flang/lib/Evaluate/host.h
@@ -56,6 +56,25 @@ class HostFloatingPointEnvironment {
// Type mapping from F18 types to host types
struct UnsupportedType {}; // There is no host type for the F18 type
+// Compile-time (category, kind) tag used only within this header. Since the
+// migration to runtime kinds, Fortran's Type<CAT> no longer carries its kind
+// as a template parameter (kind is a runtime property of the value). The
+// host-folding layer, however, still needs a distinct compile-time type per
+// (category, kind) so that it can be mapped to a concrete host C++ type (and
+// back) and so that the per-kind host runtime function tables can be
+// enumerated. TypeKind also exposes the kindless Fortran Type<CAT> and its
+// runtime-kind Scalar so that generic helpers (GetScalarConstantValue,
+// Constant, ...) can be reached through ::FortranType.
+template <common::TypeCategory CAT, int KIND> struct TypeKind {
+ static constexpr common::TypeCategory category{CAT};
+ static constexpr int kind{KIND};
+ using FortranType = Fortran::evaluate::Type<CAT>;
+ using Scalar = Fortran::evaluate::Scalar<FortranType>;
+ // Meaningful for COMPLEX only: the real component's (category, kind) tag.
+ using Part = TypeKind<common::TypeCategory::Real, KIND>;
+ static constexpr DynamicType GetType() { return DynamicType{CAT, KIND}; }
+};
+
template <typename FTN_T> struct HostTypeHelper {
using Type = UnsupportedType;
};
@@ -65,6 +84,17 @@ template <typename... T> constexpr inline bool HostTypeExists() {
return (... && (!std::is_same_v<HostType<T>, UnsupportedType>));
}
+template <typename, typename = void> struct HasValueMethod : std::false_type {};
+template <typename T>
+struct HasValueMethod<T,
+ std::void_t<decltype(std::declval<const T &>().value())>> : std::true_type {
+};
+
+template <typename, typename = void> struct HasRawBits : std::false_type {};
+template <typename T>
+struct HasRawBits<T, std::void_t<decltype(std::declval<const T &>().RawBits())>>
+ : std::true_type {};
+
// Type mapping from host types to F18 types FortranType<HOST_T> is defined
// after all HosTypeHelper definition because it reverses them to avoid
// duplication.
@@ -77,8 +107,30 @@ inline constexpr Scalar<FTN_T> CastHostToFortran(const HostType<FTN_T> &x) {
sizeof(Scalar<FTN_T>) != sizeof(HostType<FTN_T>)) {
// X87 is usually padded to 12 or 16bytes. Need to cast piecewise for
// complex
- return Scalar<FTN_T>{CastHostToFortran<typename FTN_T::Part>(std::real(x)),
- CastHostToFortran<typename FTN_T::Part>(std::imag(x))};
+#if HAS_QUADMATHLIB
+ if constexpr (std::is_same_v<HostType<FTN_T>, __complex128>) {
+ return Scalar<FTN_T>{CastHostToFortran<typename FTN_T::Part>(__real__ x),
+ CastHostToFortran<typename FTN_T::Part>(__imag__ x)};
+ } else
+#endif
+ return Scalar<FTN_T>{
+ CastHostToFortran<typename FTN_T::Part>(std::real(x)),
+ CastHostToFortran<typename FTN_T::Part>(std::imag(x))};
+ } else if constexpr (FTN_T::category == TypeCategory::Real &&
+ HasRawBits<Scalar<FTN_T>>::value) {
+ return Scalar<FTN_T>::FromRawBytes(
+ &x, std::min(sizeof x, static_cast<std::size_t>(FTN_T::kind)));
+ } else if constexpr (FTN_T::category == TypeCategory::Real &&
+ HasValueMethod<Scalar<FTN_T>>::value) {
+ using ValueWord = typename Scalar<FTN_T>::Word;
+ return Scalar<FTN_T>{
+ ValueWord::FromRawBytes(
+ &x, std::min(sizeof x, static_cast<std::size_t>(FTN_T::kind))),
+ FTN_T::kind};
+ } else if constexpr ((FTN_T::category == TypeCategory::Integer ||
+ FTN_T::category == TypeCategory::Unsigned) &&
+ value::HasWord<Scalar<FTN_T>>::value) {
+ return Scalar<FTN_T>{x};
} else {
return *reinterpret_cast<const Scalar<FTN_T> *>(&x);
}
@@ -90,38 +142,67 @@ inline constexpr HostType<FTN_T> CastFortranToHost(const Scalar<FTN_T> &x) {
static_assert(HostTypeExists<FTN_T>());
if constexpr (FTN_T::category == TypeCategory::Complex) {
using FortranPartType = typename FTN_T::Part;
- return HostType<FTN_T>{CastFortranToHost<FortranPartType>(x.REAL()),
- CastFortranToHost<FortranPartType>(x.AIMAG())};
- } else if constexpr (std::is_same_v<FTN_T, Type<TypeCategory::Real, 10>>) {
+#if HAS_QUADMATHLIB
+ if constexpr (std::is_same_v<HostType<FTN_T>, __complex128>) {
+ HostType<FTN_T> y;
+ __real__ y = CastFortranToHost<FortranPartType>(x.REAL());
+ __imag__ y = CastFortranToHost<FortranPartType>(x.AIMAG());
+ return y;
+ } else
+#endif
+ return HostType<FTN_T>{CastFortranToHost<FortranPartType>(x.REAL()),
+ CastFortranToHost<FortranPartType>(x.AIMAG())};
+ } else if constexpr (std::is_same_v<FTN_T,
+ TypeKind<TypeCategory::Real, 10>> &&
+ !HasValueMethod<Scalar<FTN_T>>::value &&
+ !HasRawBits<Scalar<FTN_T>>::value) {
// x87 80-bit floating-point occupies 16 bytes as a C "long double";
// copy the data to avoid a legitimate (but benign due to little-endianness)
// warning from GCC >= 11.2.0.
HostType<FTN_T> y;
std::memcpy(&y, &x, sizeof x);
return y;
+ } else if constexpr (FTN_T::category == TypeCategory::Real &&
+ HasRawBits<Scalar<FTN_T>>::value) {
+ HostType<FTN_T> y{};
+ x.StoreRawBytes(&y, sizeof y);
+ return y;
+ } else if constexpr (FTN_T::category == TypeCategory::Real &&
+ HasValueMethod<Scalar<FTN_T>>::value) {
+ HostType<FTN_T> y{};
+ x.RawBits().StoreRawBytes(&y, FTN_T::kind);
+ return y;
+ } else if constexpr ((FTN_T::category == TypeCategory::Integer ||
+ FTN_T::category == TypeCategory::Unsigned) &&
+ value::HasWord<Scalar<FTN_T>>::value) {
+ if constexpr (std::is_signed_v<HostType<FTN_T>>) {
+ return x.template ToSInt<HostType<FTN_T>>();
+ } else {
+ return static_cast<HostType<FTN_T>>(x.ToUInt64());
+ }
} else {
static_assert(sizeof x == sizeof(HostType<FTN_T>));
return *reinterpret_cast<const HostType<FTN_T> *>(&x);
}
}
-template <> struct HostTypeHelper<Type<TypeCategory::Integer, 1>> {
+template <> struct HostTypeHelper<TypeKind<TypeCategory::Integer, 1>> {
using Type = std::int8_t;
};
-template <> struct HostTypeHelper<Type<TypeCategory::Integer, 2>> {
+template <> struct HostTypeHelper<TypeKind<TypeCategory::Integer, 2>> {
using Type = std::int16_t;
};
-template <> struct HostTypeHelper<Type<TypeCategory::Integer, 4>> {
+template <> struct HostTypeHelper<TypeKind<TypeCategory::Integer, 4>> {
using Type = std::int32_t;
};
-template <> struct HostTypeHelper<Type<TypeCategory::Integer, 8>> {
+template <> struct HostTypeHelper<TypeKind<TypeCategory::Integer, 8>> {
using Type = std::int64_t;
};
-template <> struct HostTypeHelper<Type<TypeCategory::Integer, 16>> {
+template <> struct HostTypeHelper<TypeKind<TypeCategory::Integer, 16>> {
#if (defined(__GNUC__) || defined(__clang__)) && defined(__SIZEOF_INT128__)
using Type = __int128_t;
#else
@@ -134,7 +215,7 @@ template <> struct HostTypeHelper<Type<TypeCategory::Integer, 16>> {
template <>
struct HostTypeHelper<
- Type<TypeCategory::Real, common::RealKindForPrecision(24)>> {
+ TypeKind<TypeCategory::Real, common::RealKindForPrecision(24)>> {
// IEEE 754 32bits
using Type = std::conditional_t<sizeof(float) == 4 &&
std::numeric_limits<float>::is_iec559,
@@ -143,7 +224,7 @@ struct HostTypeHelper<
template <>
struct HostTypeHelper<
- Type<TypeCategory::Real, common::RealKindForPrecision(53)>> {
+ TypeKind<TypeCategory::Real, common::RealKindForPrecision(53)>> {
// IEEE 754 64bits
using Type = std::conditional_t<sizeof(double) == 8 &&
std::numeric_limits<double>::is_iec559,
@@ -152,7 +233,7 @@ struct HostTypeHelper<
template <>
struct HostTypeHelper<
- Type<TypeCategory::Real, common::RealKindForPrecision(64)>> {
+ TypeKind<TypeCategory::Real, common::RealKindForPrecision(64)>> {
// X87 80bits
using Type = std::conditional_t<sizeof(long double) >= 10 &&
std::numeric_limits<long double>::digits == 64 &&
@@ -161,12 +242,12 @@ struct HostTypeHelper<
};
#if HAS_QUADMATHLIB
-template <> struct HostTypeHelper<Type<TypeCategory::Real, 16>> {
+template <> struct HostTypeHelper<TypeKind<TypeCategory::Real, 16>> {
// IEEE 754 128bits
using Type = __float128;
};
#else
-template <> struct HostTypeHelper<Type<TypeCategory::Real, 16>> {
+template <> struct HostTypeHelper<TypeKind<TypeCategory::Real, 16>> {
// IEEE 754 128bits
using Type = std::conditional_t<sizeof(long double) == 16 &&
std::numeric_limits<long double>::digits == 113 &&
@@ -175,28 +256,47 @@ template <> struct HostTypeHelper<Type<TypeCategory::Real, 16>> {
};
#endif
-template <int KIND> struct HostTypeHelper<Type<TypeCategory::Complex, KIND>> {
- using RealT = Fortran::evaluate::Type<TypeCategory::Real, KIND>;
+template <int KIND>
+struct HostTypeHelper<TypeKind<TypeCategory::Complex, KIND>> {
+ using RealT = TypeKind<TypeCategory::Real, KIND>;
using Type = std::conditional_t<HostTypeExists<RealT>(),
std::complex<HostType<RealT>>, UnsupportedType>;
};
#if HAS_QUADMATHLIB
-template <> struct HostTypeHelper<Type<TypeCategory::Complex, 16>> {
- using RealT = Fortran::evaluate::Type<TypeCategory::Real, 16>;
+template <> struct HostTypeHelper<TypeKind<TypeCategory::Complex, 16>> {
+ using RealT = TypeKind<TypeCategory::Real, 16>;
using Type = __complex128;
};
#endif
-template <int KIND> struct HostTypeHelper<Type<TypeCategory::Logical, KIND>> {
+template <int KIND>
+struct HostTypeHelper<TypeKind<TypeCategory::Logical, KIND>> {
using Type = std::conditional_t<KIND <= 8, std::uint8_t, UnsupportedType>;
};
-template <int KIND> struct HostTypeHelper<Type<TypeCategory::Character, KIND>> {
- using Type =
- Scalar<typename Fortran::evaluate::Type<TypeCategory::Character, KIND>>;
+template <int KIND>
+struct HostTypeHelper<TypeKind<TypeCategory::Character, KIND>> {
+ using Type = typename TypeKind<TypeCategory::Character, KIND>::Scalar;
};
+// Enumerates every (category, kind) tag the host-folding layer understands.
+// This replaces the former reliance on AllIntrinsicTypes, which no longer
+// distinguishes kinds at the type level.
+using AllHostKindTypes = std::tuple<TypeKind<TypeCategory::Integer, 1>,
+ TypeKind<TypeCategory::Integer, 2>, TypeKind<TypeCategory::Integer, 4>,
+ TypeKind<TypeCategory::Integer, 8>, TypeKind<TypeCategory::Integer, 16>,
+ TypeKind<TypeCategory::Real, 2>, TypeKind<TypeCategory::Real, 3>,
+ TypeKind<TypeCategory::Real, 4>, TypeKind<TypeCategory::Real, 8>,
+ TypeKind<TypeCategory::Real, 10>, TypeKind<TypeCategory::Real, 16>,
+ TypeKind<TypeCategory::Complex, 2>, TypeKind<TypeCategory::Complex, 3>,
+ TypeKind<TypeCategory::Complex, 4>, TypeKind<TypeCategory::Complex, 8>,
+ TypeKind<TypeCategory::Complex, 10>, TypeKind<TypeCategory::Complex, 16>,
+ TypeKind<TypeCategory::Logical, 1>, TypeKind<TypeCategory::Logical, 2>,
+ TypeKind<TypeCategory::Logical, 4>, TypeKind<TypeCategory::Logical, 8>,
+ TypeKind<TypeCategory::Character, 1>, TypeKind<TypeCategory::Character, 2>,
+ TypeKind<TypeCategory::Character, 4>>;
+
// Type mapping from host types to F18 types. This need to be placed after all
// HostTypeHelper specializations.
template <typename T, typename... TT> struct IndexInTupleHelper {};
@@ -207,13 +307,13 @@ struct IndexInTupleHelper<T, std::tuple<TT...>> {
struct UnknownType {}; // the host type does not match any F18 types
template <typename HOST_T> struct FortranTypeHelper {
using HostTypeMapping =
- common::MapTemplate<HostType, AllIntrinsicTypes, std::tuple>;
+ common::MapTemplate<HostType, AllHostKindTypes, std::tuple>;
static constexpr int index{
IndexInTupleHelper<HOST_T, HostTypeMapping>::value};
// Both conditional types are "instantiated", so a valid type must be
// created for invalid index even if not used.
using Type = std::conditional_t<index >= 0,
- std::tuple_element_t<(index >= 0) ? index : 0, AllIntrinsicTypes>,
+ std::tuple_element_t<(index >= 0) ? index : 0, AllHostKindTypes>,
UnknownType>;
};
diff --git a/flang/lib/Evaluate/initial-image.cpp b/flang/lib/Evaluate/initial-image.cpp
index 050c55e399b57..72ea980dbb6bd 100644
--- a/flang/lib/Evaluate/initial-image.cpp
+++ b/flang/lib/Evaluate/initial-image.cpp
@@ -100,11 +100,8 @@ class AsConstantHelper {
if (T::category != type_.category()) {
return std::nullopt;
}
- if constexpr (T::category != TypeCategory::Derived) {
- if (T::kind != type_.kind()) {
- return std::nullopt;
- }
- }
+ // There is a single Type per category now; the kind is a runtime property
+ // taken from type_ rather than a compile-time template parameter.
using Const = Constant<T>;
using Scalar = typename Const::Element;
std::optional<uint64_t> optElements{TotalElementCount(extents_)};
@@ -159,9 +156,9 @@ class AsConstantHelper {
return AsGenericExpr(
Const{derived, std::move(typedValue), std::move(extents_)});
} else if constexpr (T::category == TypeCategory::Character) {
- auto length{static_cast<ConstantSubscript>(stride) / T::kind};
+ int charKind{type_.kind()};
+ auto length{static_cast<ConstantSubscript>(stride) / charKind};
for (std::size_t j{0}; j < elements; ++j) {
- using Char = typename Scalar::value_type;
auto at{static_cast<std::size_t>(offset_ + j * stride)};
auto chunk{length};
if (at + chunk > image_.data_.size()) {
@@ -172,22 +169,50 @@ class AsConstantHelper {
chunk = image_.data_.size() - at;
}
}
- if (chunk > 0) {
- const Char *data{reinterpret_cast<const Char *>(&image_.data_[at])};
- typedValue[j].assign(data, chunk);
- }
- if (chunk < length && padWithZero_) {
- typedValue[j].append(length - chunk, Char{});
+ // The element character type depends on the runtime kind.
+ auto build{[&](auto charProto) {
+ using Char = decltype(charProto);
+ std::basic_string<Char> s;
+ if (chunk > 0) {
+ s.assign(reinterpret_cast<const Char *>(&image_.data_[at]),
+ static_cast<std::size_t>(chunk));
+ }
+ if (chunk < length && padWithZero_) {
+ s.append(static_cast<std::size_t>(length - chunk), Char{});
+ }
+ typedValue[j] = value::CharacterValue{std::move(s)};
+ }};
+ switch (charKind) {
+ case 1:
+ build(char{});
+ break;
+ case 2:
+ build(char16_t{});
+ break;
+ default:
+ build(char32_t{});
+ break;
}
}
return AsGenericExpr(
Const{length, std::move(typedValue), std::move(extents_)});
} else {
// Lengthless intrinsic type
- CHECK(sizeof(Scalar) <= stride);
+ std::size_t byteLen;
+ if constexpr (T::category == TypeCategory::Integer ||
+ T::category == TypeCategory::Unsigned) {
+ byteLen = type_.kind(); // kind is the storage size in bytes
+ } else if constexpr (T::category == TypeCategory::Real ||
+ T::category == TypeCategory::Complex) {
+ byteLen = (Scalar::Zero(type_.kind()).bits() + 7) / 8;
+ } else {
+ // Logical: kind is the storage size in bytes.
+ byteLen = type_.kind();
+ }
+ CHECK(byteLen <= stride);
for (std::size_t j{0}; j < elements; ++j) {
auto at{static_cast<std::size_t>(offset_ + j * stride)};
- std::size_t chunk{sizeof(Scalar)};
+ std::size_t chunk{byteLen};
if (at + chunk > image_.data_.size()) {
CHECK(padWithZero_);
if (at >= image_.data_.size()) {
@@ -198,7 +223,28 @@ class AsConstantHelper {
}
// TODO endianness
if (chunk > 0) {
- std::memcpy(&typedValue[j], &image_.data_[at], chunk);
+ // Largest intrinsic raw image is COMPLEX(16) at 32 bytes.
+ constexpr std::size_t maxRawBytes{32};
+ CHECK(byteLen <= maxRawBytes);
+ alignas(16) std::uint8_t rawBuf[maxRawBytes]{};
+ std::memcpy(rawBuf, &image_.data_[at], chunk);
+ const int valueKind{type_.kind()};
+ if constexpr (T::category == TypeCategory::Real) {
+ typedValue[j] =
+ Scalar{value::IntegerValue::FromRawBytes(rawBuf, valueKind),
+ valueKind};
+ } else if constexpr (T::category == TypeCategory::Complex) {
+ std::size_t partBytes{byteLen / 2};
+ typedValue[j] =
+ Scalar{value::RealValue{
+ value::IntegerValue::FromRawBytes(rawBuf, valueKind),
+ valueKind},
+ value::RealValue{value::IntegerValue::FromRawBytes(
+ rawBuf + partBytes, valueKind),
+ valueKind}};
+ } else {
+ typedValue[j] = Scalar::FromRawBytes(rawBuf, valueKind);
+ }
}
}
return AsGenericExpr(Const{std::move(typedValue), std::move(extents_)});
diff --git a/flang/lib/Evaluate/int-power.h b/flang/lib/Evaluate/int-power.h
index 2ee012ceb77a3..301c91e81eedc 100644
--- a/flang/lib/Evaluate/int-power.h
+++ b/flang/lib/Evaluate/int-power.h
@@ -21,7 +21,7 @@ ValueWithRealFlags<REAL> TimesIntPowerOf(const REAL &factor, const REAL &base,
Rounding rounding = TargetCharacteristics::defaultRounding) {
ValueWithRealFlags<REAL> result{factor};
if (base.IsNotANumber()) {
- result.value = REAL::NotANumber();
+ result.value = REAL::NotANumber(base.kind());
result.flags.set(RealFlag::InvalidArgument);
} else if (power.IsZero()) {
if (base.IsZero() || base.IsInfinite()) {
@@ -31,7 +31,7 @@ ValueWithRealFlags<REAL> TimesIntPowerOf(const REAL &factor, const REAL &base,
bool negativePower{power.IsNegative()};
INT absPower{power.ABS().value};
REAL squares{base};
- int nbits{INT::bits - absPower.LEADZ()};
+ int nbits{absPower.bits() - absPower.LEADZ()};
for (int j{0}; j < nbits; ++j) {
if (j > 0) { // avoid spurious overflow on last iteration
squares =
@@ -54,7 +54,7 @@ ValueWithRealFlags<REAL> TimesIntPowerOf(const REAL &factor, const REAL &base,
template <typename REAL, typename INT>
ValueWithRealFlags<REAL> IntPower(const REAL &base, const INT &power,
Rounding rounding = TargetCharacteristics::defaultRounding) {
- REAL one{REAL::FromInteger(INT{1}).value};
+ REAL one{REAL::FromInteger(INT{1, base.kind()}, base.kind()).value};
return TimesIntPowerOf(one, base, power, rounding);
}
} // namespace Fortran::evaluate
diff --git a/flang/lib/Evaluate/integer-value.cpp b/flang/lib/Evaluate/integer-value.cpp
new file mode 100644
index 0000000000000..d008b4a108e2d
--- /dev/null
+++ b/flang/lib/Evaluate/integer-value.cpp
@@ -0,0 +1,891 @@
+//===-- lib/Evaluate/integer-value.cpp ------------------------------------===//
+//
+// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
+// See https://llvm.org/LICENSE.txt for license information.
+// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
+//
+//===----------------------------------------------------------------------===//
+
+#include "flang/Evaluate/integer-value.h"
+#include "flang/Evaluate/integer.h"
+#include <cstring>
+#include <string>
+
+namespace Fortran::evaluate::value {
+
+namespace {
+
+// Converts a fixed-width value::Integer to an APInt of the same width,
+// preserving its raw bit pattern.
+template <typename T> llvm::APInt IntegerToAP(const T &n) {
+ constexpr unsigned w = T::bits;
+ constexpr unsigned nWords = (w + 63) / 64;
+ std::uint64_t words[nWords];
+ T cur{n};
+ for (unsigned i = 0; i < nWords; ++i) {
+ words[i] = cur.template ToUInt<std::uint64_t>();
+ cur = cur.SHIFTR(64);
+ }
+ return llvm::APInt(w, llvm::ArrayRef<std::uint64_t>(words, nWords));
+}
+
+} // namespace
+
+// ============================================================================
+// IntegerValue out-of-line definitions.
+// ============================================================================
+
+// --- Construction / raw bytes -----------------------------------------------
+
+IntegerValue IntegerValue::FromRawBytes(const void *raw, int kind) {
+ if (kind == 0) {
+ // Matches the historical default case (used by InitialImage):
+ // zero-initialized widest raw word.
+ return Wrap(llvm::APInt(128, 0));
+ }
+ unsigned bits{BitsForKind(kind)};
+ unsigned nWords{(bits + 63) / 64};
+ llvm::SmallVector<std::uint64_t, 4> words(nWords, 0);
+ std::size_t copyBytes{static_cast<std::size_t>((bits + 7) / 8)};
+ std::memcpy(words.data(), raw, copyBytes);
+ return Wrap(llvm::APInt(bits, llvm::ArrayRef(words.data(), nWords)));
+}
+
+bool IntegerValue::StoreRawBytes(void *to, int kind) const {
+ unsigned outBits{BitsForKind(kind)};
+ llvm::APInt out{
+ IsMonostate() ? llvm::APInt(outBits, 0) : ap().zextOrTrunc(outBits)};
+ std::size_t payloadBytes{static_cast<std::size_t>((outBits + 7) / 8)};
+ if (std::memcmp(to, out.getRawData(), payloadBytes) != 0) {
+ std::memcpy(to, out.getRawData(), payloadBytes);
+ return true;
+ }
+ return false;
+}
+
+// --- Integral conversions ---------------------------------------------------
+
+std::uint64_t IntegerValue::ToUInt64() const {
+ if (IsMonostate()) {
+ return 0;
+ }
+ return ap().getRawData()[0]; // low 64 bits, zero-extended
+}
+
+std::int64_t IntegerValue::ToInt64() const {
+ if (IsMonostate()) {
+ return 0;
+ }
+ return ap().sextOrTrunc(64).getSExtValue();
+}
+
+std::uint64_t IntegerValue::ToUInt() const {
+ if (IsMonostate()) {
+ return 0;
+ }
+ return ap().getRawData()[0];
+}
+
+// --- Kind helpers -----------------------------------------------------------
+
+unsigned IntegerValue::BitsForKind(int kind) {
+ switch (kind) {
+ case 1:
+ return 8;
+ case 2:
+ return 16;
+ case 3:
+ return 16; // bfloat16 shares 16-bit storage with REAL(2)
+ case 4:
+ return 32;
+ case 8:
+ return 64;
+ case 10:
+ return 80;
+ case 16:
+ return 128;
+ default:
+ llvm_unreachable("arbritrary bits not yet supported");
+ return 32;
+ }
+}
+
+// Returns this value re-interpreted with a different kind (sign-preserving).
+IntegerValue IntegerValue::ConvertToKind(int kind) const {
+ unsigned w{BitsForKind(kind)};
+ if (IsMonostate()) {
+ return Wrap(llvm::APInt(w, 0));
+ }
+ return Wrap(ap().sextOrTrunc(w));
+}
+
+// --- Kind-parameterized ranges ----------------------------------------------
+
+int IntegerValue::RANGE(int kind) { return DecimalRange(kind * 8 - 1); }
+
+int IntegerValue::UnsignedRANGE(int kind) { return DecimalRange(kind * 8); }
+
+// --- Equality ---------------------------------------------------------------
+
+bool IntegerValue::operator==(const IntegerValue &y) const {
+ if (IsMonostate() && y.IsMonostate()) {
+ return true;
+ }
+ if (IsMonostate() != y.IsMonostate()) {
+ llvm_unreachable("uncomparable integers");
+ return false;
+ }
+ if (width() != y.width()) {
+ llvm_unreachable("uncomparable integers");
+ return false;
+ }
+ return ap() == y.ap();
+}
+
+// --- Kind / raw access ------------------------------------------------------
+
+int IntegerValue::kind() const {
+ if (IsMonostate()) {
+ llvm_unreachable("default-initialized value representing 0 with unknown "
+ "width does not know its kind. By definition");
+ return 0;
+ }
+ return static_cast<int>(width()) / 8;
+}
+
+int IntegerValue::bits() const {
+ if (IsMonostate()) {
+ return 0;
+ }
+ return static_cast<int>(width());
+}
+
+IntegerValue IntegerValue::Zero(int kind) {
+ return Wrap(llvm::APInt(BitsForKind(kind), 0));
+}
+
+// --- Predicates and comparisons ---------------------------------------------
+
+bool IntegerValue::IsZero() const {
+ if (IsMonostate()) {
+ return true; // uninitialized int representing 0 is zero
+ }
+ return ap().isZero();
+}
+
+bool IntegerValue::IsNegative() const {
+ if (IsMonostate()) {
+ return false; // uninitialized int representing 0 is not negative
+ }
+ return ap().isNegative();
+}
+
+Ordering IntegerValue::CompareSigned(const IntegerValue &y) const {
+ if (IsMonostate()) {
+ llvm_unreachable("uncomparable ints");
+ return Ordering::Equal;
+ }
+ // PAPAYA: Use APInt::compareSigned
+ llvm::APInt b{coerce(y)};
+ if (ap().slt(b)) {
+ return Ordering::Less;
+ }
+ if (ap().sgt(b)) {
+ return Ordering::Greater;
+ }
+ return Ordering::Equal;
+}
+
+Ordering IntegerValue::CompareUnsigned(const IntegerValue &y) const {
+ if (IsMonostate()) {
+ llvm_unreachable("uncomparable ints; cast bitwidth first");
+ return Ordering::Equal;
+ }
+ // PAPAYA: Use APInt::compare
+ llvm::APInt b{coerce(y)};
+ if (ap().ult(b)) {
+ return Ordering::Less;
+ }
+ if (ap().ugt(b)) {
+ return Ordering::Greater;
+ }
+ return Ordering::Equal;
+}
+
+Ordering IntegerValue::CompareToZeroSigned() const {
+ if (IsMonostate()) {
+ llvm_unreachable("uncomparable ints");
+ return Ordering::Equal;
+ }
+ if (ap().isNegative()) {
+ return Ordering::Less;
+ }
+ if (ap().isZero()) {
+ return Ordering::Equal;
+ }
+ return Ordering::Greater;
+}
+
+bool IntegerValue::BGE(const IntegerValue &y) const {
+ if (IsMonostate()) {
+ llvm_unreachable("uncomparable ints");
+ return false;
+ }
+ return ap().uge(coerce(y));
+}
+
+bool IntegerValue::BGT(const IntegerValue &y) const {
+ if (IsMonostate()) {
+ llvm_unreachable("uncomparable ints");
+ return false;
+ }
+ return ap().ugt(coerce(y));
+}
+
+bool IntegerValue::BLE(const IntegerValue &y) const {
+ if (IsMonostate()) {
+ llvm_unreachable("uncomparable ints");
+ return false;
+ }
+ return ap().ule(coerce(y));
+}
+
+bool IntegerValue::BLT(const IntegerValue &y) const {
+ if (IsMonostate()) {
+ llvm_unreachable("uncomparable ints");
+ return false;
+ }
+ return ap().ult(coerce(y));
+}
+
+// --- Arithmetic -------------------------------------------------------------
+
+typename IntegerValue::ValueWithOverflow IntegerValue::Negate() const {
+ if (IsMonostate()) {
+ return ValueWithOverflow{}; // negation of uninitialized int 0 is zero
+ }
+ // Overflow occurs only for the most negative value (its negation is itself).
+ return {Wrap(-ap()), ap().isMinSignedValue()};
+}
+
+typename IntegerValue::ValueWithOverflow IntegerValue::ABS() const {
+ if (IsMonostate()) {
+ return ValueWithOverflow{}; // absolute of uninitialized int 0 is zero
+ }
+ if (ap().isNegative()) {
+ return Negate();
+ }
+ return {*this, false};
+}
+
+typename IntegerValue::ValueWithCarry IntegerValue::AddUnsigned(
+ const IntegerValue &y, bool carryIn) const {
+ if (IsMonostate()) {
+ llvm_unreachable("incompatiable ints");
+ return ValueWithCarry{};
+ }
+ bool carry1{false}, carry2{false};
+ llvm::APInt sum{ap().uadd_ov(coerce(y), carry1)};
+ if (carryIn) {
+ sum = sum.uadd_ov(llvm::APInt(width(), 1), carry2);
+ }
+ return {Wrap(sum), carry1 || carry2};
+}
+
+typename IntegerValue::ValueWithOverflow IntegerValue::AddSigned(
+ const IntegerValue &y) const {
+ if (IsMonostate()) {
+ llvm_unreachable("incompatible ints");
+ return ValueWithOverflow{};
+ }
+ bool overflow{false};
+ llvm::APInt sum{ap().sadd_ov(coerce(y), overflow)};
+ return {Wrap(sum), overflow};
+}
+
+typename IntegerValue::ValueWithOverflow IntegerValue::SubtractSigned(
+ const IntegerValue &y) const {
+ if (IsMonostate()) {
+ llvm_unreachable("incompatiable ints");
+ return ValueWithOverflow{};
+ }
+ bool overflow{false};
+ llvm::APInt diff{ap().ssub_ov(coerce(y), overflow)};
+ return {Wrap(diff), overflow};
+}
+
+typename IntegerValue::ValueWithOverflow IntegerValue::AddUnsignedToOverflow(
+ const IntegerValue &y) const {
+ if (IsMonostate()) {
+ llvm_unreachable("incompatiable ints");
+ return ValueWithOverflow{};
+ }
+ bool carry{false};
+ llvm::APInt sum{ap().uadd_ov(coerce(y), carry)};
+ return {Wrap(sum), carry};
+}
+
+typename IntegerValue::ValueWithOverflow IntegerValue::DIM(
+ const IntegerValue &y) const {
+ if (IsMonostate()) {
+ llvm_unreachable("incompatiable ints");
+ return ValueWithOverflow{};
+ }
+ // DIM(X,Y) = MAX(X-Y, 0)
+ if (CompareSigned(y) != Ordering::Greater) {
+ return {Wrap(llvm::APInt(width(), 0)), false};
+ }
+ return SubtractSigned(y);
+}
+
+typename IntegerValue::ValueWithOverflow IntegerValue::SIGN(
+ const IntegerValue &sign) const {
+ if (IsMonostate()) {
+ llvm_unreachable("incompatiable ints");
+ return ValueWithOverflow{};
+ }
+ bool toNegative{sign.IsNegative()};
+ if (toNegative == ap().isNegative()) {
+ return {*this, false};
+ }
+ if (toNegative) {
+ return Negate();
+ }
+ return ABS();
+}
+
+typename IntegerValue::Product IntegerValue::MultiplySigned(
+ const IntegerValue &y) const {
+ if (IsMonostate()) {
+ llvm_unreachable("incompatiable ints");
+ return Product{};
+ }
+ unsigned w{width()};
+ llvm::APInt full{ap().sext(2 * w) * coerce(y).sext(2 * w)};
+ llvm::APInt lower{full.trunc(w)};
+ llvm::APInt upper{full.extractBits(w, w)};
+ bool overflow{lower.isNegative()
+ ? static_cast<unsigned>(upper.popcount()) != w
+ : !upper.isZero()};
+ return {Wrap(upper), Wrap(lower), overflow};
+}
+
+typename IntegerValue::Product IntegerValue::MultiplyUnsigned(
+ const IntegerValue &y) const {
+ if (IsMonostate()) {
+ llvm_unreachable("incompatiable ints");
+ return Product{};
+ }
+ unsigned w{width()};
+ llvm::APInt full{ap().zext(2 * w) * coerce(y).zext(2 * w)};
+ llvm::APInt lower{full.trunc(w)};
+ llvm::APInt upper{full.extractBits(w, w)};
+ return {Wrap(upper), Wrap(lower), false};
+}
+
+typename IntegerValue::QuotientWithRemainder IntegerValue::DivideSigned(
+ const IntegerValue &y) const {
+ if (IsMonostate()) {
+ llvm_unreachable("incompatiable ints");
+ return QuotientWithRemainder{};
+ }
+ unsigned w{width()};
+ llvm::APInt a{ap()};
+ llvm::APInt b{coerce(y)};
+ if (b.isZero()) {
+ // Division by zero saturates toward the sign of the dividend.
+ llvm::APInt q{a.isNegative() ? llvm::APInt::getSignedMinValue(w)
+ : llvm::APInt::getSignedMaxValue(w)};
+ return {Wrap(q), Wrap(llvm::APInt(w, 0)), true, false};
+ }
+ if (a.isMinSignedValue() && b.isAllOnes()) {
+ // The sole signed overflow case: most-negative / -1.
+ return {Wrap(a), Wrap(llvm::APInt(w, 0)), false, true};
+ }
+ llvm::APInt q, r;
+ llvm::APInt::sdivrem(a, b, q, r);
+ return {Wrap(q), Wrap(r), false, false};
+}
+
+typename IntegerValue::QuotientWithRemainder IntegerValue::DivideUnsigned(
+ const IntegerValue &y) const {
+ if (IsMonostate()) {
+ llvm_unreachable("incompatiable ints");
+ return QuotientWithRemainder{};
+ }
+ unsigned w{width()};
+ llvm::APInt a{ap()};
+ llvm::APInt b{coerce(y)};
+ if (b.isZero()) {
+ return {
+ Wrap(llvm::APInt::getAllOnes(w)), Wrap(llvm::APInt(w, 0)), true, false};
+ }
+ llvm::APInt q, r;
+ llvm::APInt::udivrem(a, b, q, r);
+ return {Wrap(q), Wrap(r), false, false};
+}
+
+typename IntegerValue::ValueWithOverflow IntegerValue::MODULO(
+ const IntegerValue &y) const {
+ if (IsMonostate()) {
+ llvm_unreachable("incompatiable ints");
+ return ValueWithOverflow{};
+ }
+ // Result has the sign of the divisor argument.
+ bool distinctSigns{ap().isNegative() != coerce(y).isNegative()};
+ QuotientWithRemainder divided{DivideSigned(y)};
+ if (distinctSigns && !divided.remainder.IsZero()) {
+ return {divided.remainder.AddUnsigned(y).value, divided.overflow};
+ }
+ return {divided.remainder, divided.overflow};
+}
+
+typename IntegerValue::PowerWithErrors IntegerValue::Power(
+ const IntegerValue &e) const {
+ if (IsMonostate()) {
+ llvm_unreachable("incompatiable ints");
+ return PowerWithErrors{};
+ }
+ unsigned w{width()};
+ IntegerValue exponent{Wrap(coerce(e))};
+ IntegerValue one{Wrap(llvm::APInt(w, 1))};
+ IntegerValue negativeOne{Wrap(llvm::APInt::getAllOnes(w))};
+ PowerWithErrors result;
+ result.power = one;
+ if (exponent.IsZero()) {
+ // x**0 -> 1 (including 0**0, which other Fortrans also define as 1).
+ result.zeroToZero = IsZero();
+ } else if (exponent.IsNegative()) {
+ if (IsZero()) {
+ result.divisionByZero = true;
+ result.power = Wrap(llvm::APInt::getSignedMaxValue(w));
+ } else if (CompareSigned(one) == Ordering::Equal) {
+ result.power = *this; // 1**x -> 1
+ } else if (CompareSigned(negativeOne) == Ordering::Equal) {
+ if (exponent.BTEST(0)) {
+ result.power = *this; // (-1)**x -> -1 if x is odd
+ }
+ } else {
+ result.power = Wrap(llvm::APInt(w, 0)); // |j| > 1 and k < 0 -> 0
+ }
+ } else {
+ IntegerValue shifted{*this};
+ int nbits{static_cast<int>(w) - exponent.LEADZ()};
+ for (int j{0}; j < nbits; ++j) {
+ if (exponent.BTEST(j)) {
+ Product product{result.power.MultiplySigned(shifted)};
+ result.power = product.lower;
+ result.overflow |= product.SignedMultiplicationOverflowed();
+ }
+ if (j + 1 < nbits) {
+ Product squared{shifted.MultiplySigned(shifted)};
+ result.overflow |= squared.SignedMultiplicationOverflowed();
+ shifted = squared.lower;
+ }
+ }
+ }
+ return result;
+}
+
+// --- Bitwise ----------------------------------------------------------------
+
+IntegerValue IntegerValue::NOT() const {
+ if (IsMonostate()) {
+ llvm_unreachable("incompatible ints");
+ return IntegerValue{};
+ }
+ return Wrap(~ap());
+}
+
+IntegerValue IntegerValue::IAND(const IntegerValue &y) const {
+ if (IsMonostate()) {
+ llvm_unreachable("incompatiable ints");
+ return IntegerValue{};
+ }
+ return Wrap(ap() & coerce(y));
+}
+
+IntegerValue IntegerValue::IOR(const IntegerValue &y) const {
+ if (IsMonostate()) {
+ llvm_unreachable("incompatible ints");
+ return IntegerValue{};
+ }
+ return Wrap(ap() | coerce(y));
+}
+
+IntegerValue IntegerValue::IEOR(const IntegerValue &y) const {
+ if (IsMonostate()) {
+ llvm_unreachable("incompatible ints");
+ return IntegerValue{};
+ }
+ return Wrap(ap() ^ coerce(y));
+}
+
+IntegerValue IntegerValue::MERGE_BITS(
+ const IntegerValue &y, const IntegerValue &mask) const {
+ if (IsMonostate()) {
+ llvm_unreachable("incompatible ints");
+ return IntegerValue{};
+ }
+ llvm::APInt m{coerce(mask)};
+ return Wrap((ap() & m) | (coerce(y) & ~m));
+}
+
+// --- Shifts and bit queries -------------------------------------------------
+
+IntegerValue IntegerValue::ISHFT(int count) const {
+ if (IsMonostate()) {
+ llvm_unreachable("incompatible ints");
+ return IntegerValue{};
+ }
+ return count < 0 ? SHIFTR(-count) : SHIFTL(count);
+}
+
+IntegerValue IntegerValue::SHIFTL(int count) const {
+ if (IsMonostate()) {
+ llvm_unreachable("incompatible ints");
+ return IntegerValue{};
+ }
+ unsigned w{width()};
+ if (count <= 0) {
+ return *this;
+ }
+ if (static_cast<unsigned>(count) >= w) {
+ return Wrap(llvm::APInt(w, 0));
+ }
+ return Wrap(ap().shl(static_cast<unsigned>(count)));
+}
+
+IntegerValue IntegerValue::SHIFTR(int count) const {
+ if (IsMonostate()) {
+ llvm_unreachable("incompatible ints");
+ return IntegerValue{};
+ }
+ unsigned w{width()};
+ if (count <= 0) {
+ return *this;
+ }
+ if (static_cast<unsigned>(count) >= w) {
+ return Wrap(llvm::APInt(w, 0));
+ }
+ return Wrap(ap().lshr(static_cast<unsigned>(count)));
+}
+
+IntegerValue IntegerValue::SHIFTA(int count) const {
+ if (IsMonostate()) {
+ llvm_unreachable("incompatible ints");
+ return IntegerValue{};
+ }
+ unsigned w{width()};
+ if (count <= 0) {
+ return *this;
+ }
+ if (static_cast<unsigned>(count) >= w) {
+ // Saturates to all sign bits.
+ return Wrap(
+ ap().isNegative() ? llvm::APInt::getAllOnes(w) : llvm::APInt(w, 0));
+ }
+ return Wrap(ap().ashr(static_cast<unsigned>(count)));
+}
+
+IntegerValue IntegerValue::ISHFTC(int count, int size) const {
+ if (IsMonostate()) {
+ llvm_unreachable("incompatible ints");
+ return IntegerValue{};
+ }
+ int w{static_cast<int>(width())};
+ if (size <= 0) {
+ size = w;
+ }
+ if (count == 0 || size <= 0) {
+ return *this;
+ }
+ if (size > w) {
+ size = w;
+ }
+ count %= size;
+ if (count == 0) {
+ return *this;
+ }
+ int middleBits{size - count}, leastBits{count};
+ if (count < 0) {
+ middleBits = -count;
+ leastBits = size + count;
+ }
+ if (size == w) {
+ return SHIFTL(leastBits).IOR(SHIFTR(middleBits));
+ }
+ IntegerValue unchanged{IAND(Wrap(llvm::APInt::getHighBitsSet(w, w - size)))};
+ IntegerValue middle{
+ IAND(Wrap(llvm::APInt::getLowBitsSet(w, middleBits))).SHIFTL(leastBits)};
+ IntegerValue least{
+ SHIFTR(middleBits).IAND(Wrap(llvm::APInt::getLowBitsSet(w, leastBits)))};
+ return unchanged.IOR(middle).IOR(least);
+}
+
+IntegerValue IntegerValue::IBITS(int pos, int size) const {
+ if (IsMonostate()) {
+ llvm_unreachable("incompatible ints");
+ return IntegerValue{};
+ }
+ int w{static_cast<int>(width())};
+ int clamped{size < 0 ? 0 : (size > w ? w : size)};
+ return SHIFTR(pos).IAND(Wrap(llvm::APInt::getLowBitsSet(w, clamped)));
+}
+
+IntegerValue IntegerValue::IBSET(int pos) const {
+ if (IsMonostate()) {
+ llvm_unreachable("incompatible ints");
+ return IntegerValue{};
+ }
+ if (pos < 0 || pos >= static_cast<int>(width())) {
+ return *this;
+ }
+ llvm::APInt r{ap()};
+ r.setBit(static_cast<unsigned>(pos));
+ return Wrap(r);
+}
+
+IntegerValue IntegerValue::IBCLR(int pos) const {
+ if (IsMonostate()) {
+ llvm_unreachable("incompatible ints");
+ return IntegerValue{};
+ }
+ if (pos < 0 || pos >= static_cast<int>(width())) {
+ return *this;
+ }
+ llvm::APInt r{ap()};
+ r.clearBit(static_cast<unsigned>(pos));
+ return Wrap(r);
+}
+
+IntegerValue IntegerValue::DSHIFTL(const IntegerValue &fill, int count) const {
+ if (IsMonostate()) {
+ llvm_unreachable("incompatible ints");
+ return IntegerValue{};
+ }
+ return ShiftLWithFill(fill, count);
+}
+
+IntegerValue IntegerValue::DSHIFTR(const IntegerValue &v2, int count) const {
+ if (IsMonostate()) {
+ llvm_unreachable("incompatible ints");
+ return IntegerValue{};
+ }
+ // DSHIFTR(I,J): shift I:J right; the *first* argument is the left fill.
+ return v2.ShiftRWithFill(*this, count);
+}
+
+bool IntegerValue::BTEST(int pos) const {
+ if (IsMonostate()) {
+ return false; // uninitialized int representing 0 has no bits set
+ }
+ if (pos < 0 || pos >= static_cast<int>(width())) {
+ return false;
+ }
+ return ap()[static_cast<unsigned>(pos)];
+}
+
+int IntegerValue::LEADZ() const {
+ if (IsMonostate()) {
+ llvm_unreachable("incompatible ints");
+ return 0;
+ }
+ return static_cast<int>(ap().countl_zero());
+}
+
+int IntegerValue::TRAILZ() const {
+ if (IsMonostate()) {
+ llvm_unreachable("incompatible ints");
+ return 0;
+ }
+ return static_cast<int>(ap().countr_zero());
+}
+
+int IntegerValue::POPCNT() const {
+ if (IsMonostate()) {
+ return 0; // uninitialized int representing 0 has no bits set
+ }
+ return static_cast<int>(ap().popcount());
+}
+
+bool IntegerValue::POPPAR() const {
+ if (IsMonostate()) {
+ llvm_unreachable("incompatible ints");
+ return false;
+ }
+ return ap().popcount() & 1;
+}
+
+// Double shifts with explicit fill (mirrors value::Integer::SHIFT*WithFill).
+IntegerValue IntegerValue::ShiftLWithFill(
+ const IntegerValue &fill, int count) const {
+ int w{static_cast<int>(width())};
+ if (count <= 0) {
+ return *this;
+ }
+ if (count >= 2 * w) {
+ return Wrap(llvm::APInt(static_cast<unsigned>(w), 0));
+ }
+ if (count > w) {
+ return fill.SHIFTL(count - w);
+ }
+ if (count == w) {
+ return fill;
+ }
+ return SHIFTL(count).IOR(fill.SHIFTR(w - count));
+}
+
+IntegerValue IntegerValue::ShiftRWithFill(
+ const IntegerValue &fill, int count) const {
+ int w{static_cast<int>(width())};
+ if (count <= 0) {
+ return *this;
+ }
+ if (count >= 2 * w) {
+ return Wrap(llvm::APInt(static_cast<unsigned>(w), 0));
+ }
+ if (count > w) {
+ return fill.SHIFTR(count - w);
+ }
+ if (count == w) {
+ return fill;
+ }
+ return SHIFTR(count).IOR(fill.SHIFTL(w - count));
+}
+
+// --- Kind-parameterized constants -------------------------------------------
+
+namespace {
+IntegerValue MakeMASKR(int places, unsigned bits) {
+ if (places <= 0) {
+ return IntegerValue::FromAPInt(llvm::APInt(bits, 0));
+ }
+ if (static_cast<unsigned>(places) >= bits) {
+ return IntegerValue::FromAPInt(llvm::APInt::getAllOnes(bits));
+ }
+ return IntegerValue::FromAPInt(llvm::APInt::getLowBitsSet(bits, places));
+}
+
+IntegerValue MakeMASKL(int places, unsigned bits) {
+ if (places <= 0) {
+ return IntegerValue::FromAPInt(llvm::APInt(bits, 0));
+ }
+ if (static_cast<unsigned>(places) >= bits) {
+ return MakeMASKR(static_cast<int>(bits), bits);
+ }
+ return IntegerValue::FromAPInt(llvm::APInt::getHighBitsSet(bits, places));
+}
+} // namespace
+
+IntegerValue IntegerValue::MASKL(int places, int kind) {
+ return MakeMASKL(places, BitsForKind(kind));
+}
+
+IntegerValue IntegerValue::MASKR(int places, int kind) {
+ return MakeMASKR(places, BitsForKind(kind));
+}
+
+IntegerValue IntegerValue::HUGE(int kind) {
+ unsigned bits{BitsForKind(kind)};
+ return MakeMASKR(static_cast<int>(bits) - 1, bits);
+}
+
+IntegerValue IntegerValue::Least(int kind) {
+ return MakeMASKL(1, BitsForKind(kind));
+}
+
+// --- Formatting -------------------------------------------------------------
+
+std::string IntegerValue::SignedDecimal() const {
+ if (IsMonostate()) {
+ return "0";
+ }
+ llvm::SmallVector<char, 32> buffer;
+ ap().toString(buffer, 10, /*Signed=*/true, /*formatAsCLiteral=*/false);
+ return std::string(buffer.data(), buffer.size());
+}
+
+std::string IntegerValue::UnsignedDecimal() const {
+ if (IsMonostate()) {
+ return "0";
+ }
+ llvm::SmallVector<char, 32> buffer;
+ ap().toString(buffer, 10, /*Signed=*/false, /*formatAsCLiteral=*/false);
+ return std::string(buffer.data(), buffer.size());
+}
+
+std::string IntegerValue::Hexadecimal() const {
+ if (IsMonostate()) {
+ return "0";
+ }
+ llvm::SmallVector<char, 32> buffer;
+ ap().toString(buffer, 16, /*Signed=*/false, /*formatAsCLiteral=*/false);
+ // value::Integer::Hexadecimal emits lower-case digits with no "0x" prefix.
+ std::string result(buffer.data(), buffer.size());
+ for (char &c : result) {
+ if (c >= 'A' && c <= 'F') {
+ c = static_cast<char>(c - 'A' + 'a');
+ }
+ }
+ return result;
+}
+
+// --- Private helpers --------------------------------------------------------
+
+typename IntegerValue::ValueWithOverflow IntegerValue::Read(
+ const char *&pp, int base, bool isSigned, int toBits) {
+ auto pick = [&](auto target) -> ValueWithOverflow {
+ using T = decltype(target);
+ auto r{T::Read(pp, base, isSigned)};
+ return {Wrap(IntegerToAP(r.value)), r.overflow};
+ };
+ switch (toBits) {
+ case 8:
+ return pick(Integer<8>{});
+ case 16:
+ return pick(Integer<16>{});
+ case 32:
+ return pick(Integer<32>{});
+ case 64:
+ return pick(Integer<64>{});
+ case 80:
+ return pick(X87IntegerContainer{});
+ case 128:
+ return pick(Integer<128>{});
+ default:
+ llvm_unreachable("arbitrary precisions not supported");
+ return pick(Integer<128>{});
+ }
+}
+
+IntegerValue::ValueWithOverflow IntegerValue::ConvertAP(
+ const llvm::APInt &src, int toBits, bool isSigned) {
+ unsigned to{static_cast<unsigned>(toBits)};
+ llvm::APInt value{isSigned ? src.sextOrTrunc(to) : src.zextOrTrunc(to)};
+ bool overflow;
+ if (isSigned) {
+ overflow = src.getBitWidth() > to && value.sext(src.getBitWidth()) != src;
+ } else {
+ overflow = src.getActiveBits() > to;
+ }
+ return {Wrap(value), overflow};
+}
+
+IntegerValue::ValueWithOverflow IntegerValue::ConvertSigned(
+ const IntegerValue &from, int toBits) {
+ if (from.IsMonostate()) {
+ return {};
+ }
+ return ConvertAP(from.ap(), toBits, /*isSigned=*/true);
+}
+
+IntegerValue::ValueWithOverflow IntegerValue::ConvertUnsigned(
+ const IntegerValue &from, int toBits) {
+ if (from.IsMonostate()) {
+ return {};
+ }
+ return ConvertAP(from.ap(), toBits, /*isSigned=*/false);
+}
+
+} // namespace Fortran::evaluate::value
diff --git a/flang/lib/Evaluate/integer.cpp b/flang/lib/Evaluate/integer.cpp
index 17a38fa17a67c..9978f7fcf2a7d 100644
--- a/flang/lib/Evaluate/integer.cpp
+++ b/flang/lib/Evaluate/integer.cpp
@@ -29,4 +29,5 @@ static_assert(Integer<64>::partBits == 32);
static_assert(std::is_same_v<typename Integer<64>::Part, std::uint32_t>);
static_assert(Integer<128>::partBits == 32);
static_assert(std::is_same_v<typename Integer<128>::Part, std::uint32_t>);
+
} // namespace Fortran::evaluate::value
diff --git a/flang/lib/Evaluate/intrinsics-library.cpp b/flang/lib/Evaluate/intrinsics-library.cpp
index 54726ac539d60..a8c800c8d6ab5 100644
--- a/flang/lib/Evaluate/intrinsics-library.cpp
+++ b/flang/lib/Evaluate/intrinsics-library.cpp
@@ -155,7 +155,7 @@ static Expr<SomeType> ApplyHostFunctionHelper(FuncType func,
host::HostType<TR> hostResult{};
Scalar<TR> result{};
std::tuple<Scalar<TA>...> scalarArgs{
- GetScalarConstantValue<TA>(args[I]).value()...};
+ GetScalarConstantValue<typename TA::FortranType>(args[I]).value()...};
if (context.targetCharacteristics().areSubnormalsFlushedToZero() &&
!hostFPE.hasSubnormalFlushingHardwareControl()) {
hostResult = func(host::CastFortranToHost<TA>(
@@ -169,7 +169,7 @@ static Expr<SomeType> ApplyHostFunctionHelper(FuncType func,
CheckFloatingPointIssues<TR>(hostFPE, result);
}
hostFPE.CheckAndRestoreFloatingPointEnvironment(context);
- return AsGenericExpr(Constant<TR>(std::move(result)));
+ return AsGenericExpr(Constant<typename TR::FortranType>(std::move(result)));
}
template <typename HostTR, typename... HostTA>
Expr<SomeType> ApplyHostFunction(FuncPointer<HostTR, HostTA...> func,
@@ -822,8 +822,11 @@ static const Expr<SomeType> &GetArg(
template <typename T>
static bool IsInRange(const Expr<T> &expr, int lb, int ub) {
if (auto scalar{GetScalarConstantValue<T>(expr)}) {
- auto lbValue{Scalar<T>::FromInteger(value::Integer<8>{lb}).value};
- auto ubValue{Scalar<T>::FromInteger(value::Integer<8>{ub}).value};
+ int kind{scalar->kind()};
+ auto lbValue{
+ Scalar<T>::FromInteger(value::IntegerValue{lb, 1}, kind).value};
+ auto ubValue{
+ Scalar<T>::FromInteger(value::IntegerValue{ub, 1}, kind).value};
return Satisfies(RelationalOperator::LE, lbValue.Compare(*scalar)) &&
Satisfies(RelationalOperator::LE, scalar->Compare(ubValue));
}
@@ -858,8 +861,8 @@ static bool VerifyStrictlyPositiveIfReal(
[&](const auto &x) -> bool {
using T = typename std::decay_t<decltype(x)>::Result;
auto scalar{GetScalarConstantValue<T>(x)};
- return Satisfies(
- RelationalOperator::LT, Scalar<T>{}.Compare(*scalar));
+ return Satisfies(RelationalOperator::LT,
+ Scalar<T>::Zero(scalar->kind()).Compare(*scalar));
},
someReal->u)};
if (!isStrictlyPositive) {
diff --git a/flang/lib/Evaluate/logical-value.cpp b/flang/lib/Evaluate/logical-value.cpp
new file mode 100644
index 0000000000000..2913a550c6399
--- /dev/null
+++ b/flang/lib/Evaluate/logical-value.cpp
@@ -0,0 +1,102 @@
+//===-- lib/Evaluate/logical-value.cpp ------------------------------------===//
+//
+// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
+// See https://llvm.org/LICENSE.txt for license information.
+// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
+//
+//===----------------------------------------------------------------------===//
+
+#include "flang/Evaluate/logical-value.h"
+
+namespace Fortran::evaluate::value {
+
+// ============================================================================
+// LogicalValue out-of-line definitions.
+// ============================================================================
+
+int LogicalValue::BitsForKind(int kind) {
+ switch (kind) {
+ case 1:
+ return 8;
+ case 2:
+ return 16;
+ case 4:
+ return 32;
+ case 8:
+ return 64;
+ default:
+ llvm_unreachable("arbitrary kinds not supported");
+ return 32;
+ }
+}
+
+int LogicalValue::kind() const { return storage_.kind(); }
+
+int LogicalValue::bits() const { return storage_.bits(); }
+
+LogicalValue LogicalValue::Zero(int kind) { return LogicalValue{false, kind}; }
+
+bool LogicalValue::IsZero() const { return IsMonostate() || !IsTrue(); }
+
+bool LogicalValue::IsTrue() const { return !storage_.IsZero(); }
+
+bool LogicalValue::IsCanonical() const {
+ if (IsMonostate()) {
+ return true;
+ }
+ return storage_.ToUInt64() <= 1;
+}
+
+LogicalValue LogicalValue::FromRawBytes(const void *raw, std::size_t bytes) {
+ Word w{Word::FromRawBytes(raw, static_cast<int>(bytes))};
+ return LogicalValue{w, w.kind()};
+}
+
+typename LogicalValue::Word LogicalValue::word() const { return storage_; }
+
+bool LogicalValue::StoreRawBytes(void *to, std::size_t bytes) const {
+ return storage_.StoreRawBytes(to, static_cast<int>(bytes));
+}
+
+LogicalValue LogicalValue::NOT() const {
+ if (IsMonostate()) {
+ return LogicalValue{};
+ }
+ return Wrap(storage_.IEOR(One()));
+}
+
+LogicalValue LogicalValue::AND(const LogicalValue &y) const {
+ if (IsMonostate()) {
+ return LogicalValue{};
+ }
+ return Wrap(storage_.IAND(y.word()));
+}
+
+LogicalValue LogicalValue::OR(const LogicalValue &y) const {
+ if (IsMonostate()) {
+ return LogicalValue{};
+ }
+ return Wrap(storage_.IOR(y.word()));
+}
+
+LogicalValue LogicalValue::EQV(const LogicalValue &y) const {
+ if (IsMonostate()) {
+ return LogicalValue{};
+ }
+ return Wrap(storage_.IEOR(y.word()).IEOR(One()));
+}
+
+LogicalValue LogicalValue::NEQV(const LogicalValue &y) const {
+ if (IsMonostate()) {
+ return LogicalValue{};
+ }
+ return Wrap(storage_.IEOR(y.word()));
+}
+
+LogicalValue::LogicalValue(const Word &w, int kind) {
+ int width{BitsForKind(kind)};
+ storage_ =
+ w.IsMonostate() ? Word(0, kind) : Word::ConvertUnsigned(w, width).value;
+}
+
+} // namespace Fortran::evaluate::value
diff --git a/flang/lib/Evaluate/logical.cpp b/flang/lib/Evaluate/logical.cpp
deleted file mode 100644
index 520d11fb967f4..0000000000000
--- a/flang/lib/Evaluate/logical.cpp
+++ /dev/null
@@ -1,17 +0,0 @@
-//===-- lib/Evaluate/logical.cpp ------------------------------------------===//
-//
-// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
-// See https://llvm.org/LICENSE.txt for license information.
-// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
-//
-//===----------------------------------------------------------------------===//
-
-#include "flang/Evaluate/logical.h"
-
-namespace Fortran::evaluate::value {
-
-template class Logical<8>;
-template class Logical<16>;
-template class Logical<32>;
-template class Logical<64>;
-} // namespace Fortran::evaluate::value
diff --git a/flang/lib/Evaluate/object-size-probe.cpp b/flang/lib/Evaluate/object-size-probe.cpp
new file mode 100644
index 0000000000000..87e9e392c13ea
--- /dev/null
+++ b/flang/lib/Evaluate/object-size-probe.cpp
@@ -0,0 +1,93 @@
+//===-- lib/Evaluate/object-size-probe.cpp -------------------------------===//
+//
+// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
+// See https://llvm.org/LICENSE.txt for license information.
+// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
+//
+//===----------------------------------------------------------------------===//
+//
+// Build-time helper that measures the object size and alignment of the
+// variant-backed implementation classes RealValueImpl and CharacterValue.
+//
+// The opaque facades RealValue (real-value.h) and CharacterValue
+// (character-value.h) embed a fixed-size, suitably aligned byte buffer in place
+// of their implementation so that the implementation headers do not have to be
+// exposed. The required buffer size/alignment is target-toolchain specific
+// (e.g. std::string layout differs between standard libraries), so instead of
+// hard-coding it we compile this tiny program with the very same toolchain and
+// let it emit the matching object-sizes-generated.h header. object-sizes.h
+// then prefers that generated header (via __has_include) over its built-in
+// fallback constants.
+//
+// When cross-compiling this program cannot be executed on the build host, so
+// the fallback constants in object-sizes.h are used instead (see the CMake
+// logic that guards running this probe behind NOT CMAKE_CROSSCOMPILING).
+//
+//===----------------------------------------------------------------------===//
+
+#include "real-value-impl.h"
+#include "flang/Evaluate/character-value-impl.h"
+#include <cstddef>
+#include <cstdio>
+#include <cstdlib>
+
+using Fortran::evaluate::value::CharacterValueImpl;
+using Fortran::evaluate::value::RealValueImpl;
+
+int main(int argc, char **argv) {
+ if (argc != 2) {
+ std::fprintf(stderr, "usage: %s <object-sizes-generated.h>\n", argv[0]);
+ return EXIT_FAILURE;
+ }
+
+ std::FILE *out{std::fopen(argv[1], "w")};
+ if (!out) {
+ std::fprintf(
+ stderr, "object-size-probe: cannot open %s for writing\n", argv[1]);
+ return EXIT_FAILURE;
+ }
+
+ std::fprintf(out,
+ "//===-- include/flang/Evaluate/object-sizes-generated.h ---*- C++ "
+ "-*-===//\n"
+ "//\n"
+ "// Part of the LLVM Project, under the Apache License v2.0 with LLVM "
+ "Exceptions.\n"
+ "// See https://llvm.org/LICENSE.txt for license information.\n"
+ "// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception\n"
+ "//\n"
+ "//"
+ "===---------------------------------------------------------------------"
+ "-===//\n"
+ "//\n"
+ "// Generated at build time by flang-evaluate-object-size-probe.\n"
+ "// Do not edit; edit flang/lib/Evaluate/object-size-probe.cpp instead.\n"
+ "// Included by flang/Evaluate/object-sizes.h when present on the path.\n"
+ "//\n"
+ "//"
+ "===---------------------------------------------------------------------"
+ "-===//\n"
+ "\n"
+ "#ifndef FORTRAN_EVALUATE_OBJECT_SIZES_GENERATED_H_\n"
+ "#define FORTRAN_EVALUATE_OBJECT_SIZES_GENERATED_H_\n"
+ "\n"
+ "#include <cstddef>\n"
+ "\n"
+ "namespace Fortran::evaluate::value::detail {\n"
+ "\n"
+ "// Object size/alignment for RealValue / RealValueImpl.\n"
+ "inline constexpr std::size_t kRealObjectSize{%zu};\n"
+ "inline constexpr std::size_t kRealObjectAlign{%zu};\n"
+ "\n"
+ "// Object size/alignment for Character / CharacterValue.\n"
+ "inline constexpr std::size_t kCharacterObjectSize{%zu};\n"
+ "inline constexpr std::size_t kCharacterObjectAlign{%zu};\n"
+ "\n"
+ "} // namespace Fortran::evaluate::value::detail\n"
+ "#endif // FORTRAN_EVALUATE_OBJECT_SIZES_GENERATED_H_\n",
+ sizeof(RealValueImpl), alignof(RealValueImpl), sizeof(CharacterValueImpl),
+ alignof(CharacterValueImpl));
+
+ std::fclose(out);
+ return 0;
+}
diff --git a/flang/lib/Evaluate/real-value-impl.h b/flang/lib/Evaluate/real-value-impl.h
new file mode 100644
index 0000000000000..585ccf0360bb8
--- /dev/null
+++ b/flang/lib/Evaluate/real-value-impl.h
@@ -0,0 +1,240 @@
+//===-- lib/Evaluate/real-value-impl.h ------------------------*- C++ -*-===//
+//
+// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
+// See https://llvm.org/LICENSE.txt for license information.
+// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
+//
+//===----------------------------------------------------------------------===//
+
+#ifndef FORTRAN_EVALUATE_REAL_VALUE_IMPL_H_
+#define FORTRAN_EVALUATE_REAL_VALUE_IMPL_H_
+
+#include "flang/Evaluate/real.h"
+#include "llvm/Support/ErrorHandling.h"
+#include <type_traits>
+#include <utility>
+#include <variant>
+
+// Some environments, viz. glibc 2.17 and *BSD, allow the macro HUGE
+// to leak out of <math.h>.
+#undef HUGE
+
+namespace llvm {
+class raw_ostream;
+}
+
+namespace Fortran::evaluate::value {
+
+// RealValueImpl: runtime-kind IEEE floating-point value (variant-backed).
+class RealValueImpl {
+public:
+ // Per-KIND fixed-width backing formats.
+ using R2 = Real<Integer<16>, 11>; // IEEE half
+ using R3 = Real<Integer<16>, 8>; // bfloat16
+ using R4 = Real<Integer<32>, 24>; // IEEE single
+ using R8 = Real<Integer<64>, 53>; // IEEE double
+ using R10 = Real<X87IntegerContainer, 64>; // 80387 extended precision
+ using R16 = Real<Integer<128>, 113>; // IEEE quad
+ // Widest representation: used for raw access and as the common type when
+ // converting between kinds.
+ using Word = IntegerValue;
+ // The value is held in its actual fixed-width value::Real format; the active
+ // std::variant alternative carries the runtime REAL kind. std::monostate
+ // models a default-initialized zero of an as-yet-unknown kind. All
+ // operations are expressed by forwarding to the stored value::Real.
+ using Storage = std::variant<std::monostate, R2, R3, R4, R8, R10, R16>;
+
+ RealValueImpl() = default;
+ RealValueImpl(const RealValueImpl &) = default;
+ RealValueImpl(RealValueImpl &&) = default;
+ RealValueImpl &operator=(const RealValueImpl &) = default;
+ RealValueImpl &operator=(RealValueImpl &&) = default;
+
+ // Interpret w as the raw bit pattern of a value of the given runtime kind.
+ RealValueImpl(const Word &w, int kind);
+
+ // Comparison operators
+ bool operator==(const RealValueImpl &y) const;
+
+ // Kind-property inquiries, formerly compile-time constants derived from the
+ // PREC template parameter; now selected by the runtime KIND.
+ static int binaryPrecision(int kind);
+ static int isImplicitMSB(int kind);
+ static int DIGITS(int kind);
+ static int PRECISION(int kind);
+ static int RANGE(int kind);
+ static int MAXEXPONENT(int kind);
+ static int MINEXPONENT(int kind);
+
+ static RealValueImpl HUGE(int kind);
+ static RealValueImpl EPSILON(int kind);
+ static RealValueImpl TINY(int kind);
+ static RealValueImpl NotANumber(int kind);
+
+ // Runtime kind / width accessors
+ int kind() const;
+ int bits() const;
+ bool IsMonostate() const { return storage_.index() == 0; }
+ bool IsZero() const;
+ bool IsNegative() const;
+ bool IsNotANumber() const;
+ bool IsQuietNaN() const;
+ bool IsSignalingNaN() const;
+ bool IsInfinite() const;
+ bool IsFinite() const;
+ bool IsNormal() const;
+ int Exponent() const;
+ bool StoreRawBytes(void *to, std::size_t bytes) const;
+ static RealValueImpl FromRawBytes(const void *raw, std::size_t bytes);
+ static RealValueImpl Zero(int kind);
+
+ // The raw bit pattern at the value's runtime width.
+ IntegerValue RawBits() const;
+
+ // Comparisons
+ Relation Compare(const RealValueImpl &y) const;
+
+ // Unary operations
+ RealValueImpl ABS() const;
+ RealValueImpl Negate() const;
+ RealValueImpl SIGN(const RealValueImpl &x) const;
+ RealValueImpl SetSign(bool toNegative) const;
+ RealValueImpl FlushSubnormalToZero() const;
+
+ // Binary arithmetic
+ ValueWithRealFlags<RealValueImpl> Add(const RealValueImpl &y,
+ Rounding rounding = TargetCharacteristics::defaultRounding) const;
+ ValueWithRealFlags<RealValueImpl> Subtract(const RealValueImpl &y,
+ Rounding rounding = TargetCharacteristics::defaultRounding) const;
+ ValueWithRealFlags<RealValueImpl> Multiply(const RealValueImpl &y,
+ Rounding rounding = TargetCharacteristics::defaultRounding) const;
+ ValueWithRealFlags<RealValueImpl> Divide(const RealValueImpl &y,
+ Rounding rounding = TargetCharacteristics::defaultRounding) const;
+ ValueWithRealFlags<RealValueImpl> SQRT(
+ Rounding rounding = TargetCharacteristics::defaultRounding) const;
+ ValueWithRealFlags<RealValueImpl> HYPOT(const RealValueImpl &y,
+ Rounding rounding = TargetCharacteristics::defaultRounding) const;
+ ValueWithRealFlags<RealValueImpl> MOD(const RealValueImpl &y,
+ Rounding rounding = TargetCharacteristics::defaultRounding) const;
+ ValueWithRealFlags<RealValueImpl> MODULO(const RealValueImpl &y,
+ Rounding rounding = TargetCharacteristics::defaultRounding) const;
+ ValueWithRealFlags<RealValueImpl> DIM(const RealValueImpl &y,
+ Rounding rounding = TargetCharacteristics::defaultRounding) const;
+
+ // Convert this value to a different real kind (single rounding).
+ RealValueImpl ConvertToKind(int kind) const {
+ return Convert(*this, kind).value;
+ }
+
+ RealValueImpl FRACTION() const;
+ RealValueImpl RRSPACING() const;
+ RealValueImpl SPACING() const;
+ RealValueImpl SET_EXPONENT(std::int64_t e) const;
+
+ ValueWithRealFlags<RealValueImpl> NEAREST(bool upward) const;
+ ValueWithRealFlags<RealValueImpl> ToWholeNumber(
+ common::RoundingMode mode = common::RoundingMode::ToZero) const;
+ // Convert this real to an integer of the given bit width.
+ ValueWithRealFlags<IntegerValue> ToInteger(
+ common::RoundingMode mode = common::RoundingMode::ToZero,
+ int toBits = 0) const;
+
+ ValueWithRealFlags<RealValueImpl> SCALE(const IntegerValue &by,
+ Rounding rounding = TargetCharacteristics::defaultRounding) const;
+
+ ValueWithRealFlags<RealValueImpl> KahanSummation(const RealValueImpl &y,
+ RealValueImpl &correction,
+ Rounding rounding = TargetCharacteristics::defaultRounding) const;
+
+ IntegerValue EXPONENT() const;
+
+ // Conversion from an integer facade (REAL()).
+ static ValueWithRealFlags<RealValueImpl> FromInteger(const IntegerValue &n,
+ int kind, bool isUnsigned = false,
+ Rounding rounding = TargetCharacteristics::defaultRounding);
+
+ // Conversion between real kinds.
+ static ValueWithRealFlags<RealValueImpl> Convert(const RealValueImpl &from,
+ int kind, Rounding rounding = TargetCharacteristics::defaultRounding);
+
+ static ValueWithRealFlags<RealValueImpl> Read(const char *&pp, int kind,
+ Rounding rounding = TargetCharacteristics::defaultRounding);
+
+ std::string DumpHexadecimal() const;
+ llvm::raw_ostream &AsFortran(
+ llvm::raw_ostream &o, int kind, bool minimal = false) const;
+
+ template <typename F>
+ auto WithReal(
+ F &&f) const -> decltype(std::declval<F>()(std::declval<R8>())) {
+ switch (storage_.index()) {
+ case 1:
+ return f(std::get<R2>(storage_));
+ case 2:
+ return f(std::get<R3>(storage_));
+ case 3:
+ return f(std::get<R4>(storage_));
+ case 4:
+ return f(std::get<R8>(storage_));
+ case 5:
+ return f(std::get<R10>(storage_));
+ case 6:
+ return f(std::get<R16>(storage_));
+ default:
+ llvm_unreachable("operation on uninitialized RealValueImpl");
+ }
+ }
+
+ template <typename T> static RealValueImpl Wrap(const T &r) {
+ RealValueImpl v;
+ v.storage_ = r;
+ return v;
+ }
+
+ template <typename T>
+ static ValueWithRealFlags<RealValueImpl> Wrap(
+ const ValueWithRealFlags<T> &x) {
+ ValueWithRealFlags<RealValueImpl> r;
+ r.value = Wrap(x.value);
+ r.flags = x.flags;
+ return r;
+ }
+
+ template <typename V> static std::decay_t<V> As(const RealValueImpl &y) {
+ using R = std::decay_t<V>;
+ if (y.IsMonostate()) {
+ return R{};
+ }
+ return y.WithReal([](const auto &yv) -> R {
+ using YR = std::decay_t<decltype(yv)>;
+ if constexpr (std::is_same_v<YR, R>) {
+ return yv;
+ } else {
+ return R::Convert(yv).value;
+ }
+ });
+ }
+
+ template <typename R> static constexpr int KindOf() {
+ if constexpr (std::is_same_v<R, R2>) {
+ return 2;
+ } else if constexpr (std::is_same_v<R, R3>) {
+ return 3;
+ } else if constexpr (std::is_same_v<R, R4>) {
+ return 4;
+ } else if constexpr (std::is_same_v<R, R8>) {
+ return 8;
+ } else if constexpr (std::is_same_v<R, R10>) {
+ return 10;
+ } else if constexpr (std::is_same_v<R, R16>) {
+ return 16;
+ }
+ llvm_unreachable(
+ "uninitialized value has not a defined kind or unsupported width");
+ }
+
+ Storage storage_;
+};
+
+} // namespace Fortran::evaluate::value
+#endif // FORTRAN_EVALUATE_REAL_VALUE_IMPL_H_
diff --git a/flang/lib/Evaluate/real-value.cpp b/flang/lib/Evaluate/real-value.cpp
new file mode 100644
index 0000000000000..e4a511c592316
--- /dev/null
+++ b/flang/lib/Evaluate/real-value.cpp
@@ -0,0 +1,809 @@
+//===-- lib/Evaluate/real-value.cpp ---------------------------------------===//
+//
+// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
+// See https://llvm.org/LICENSE.txt for license information.
+// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
+//
+//===----------------------------------------------------------------------===//
+
+#include "flang/Evaluate/real-value.h"
+#include "int-power.h"
+#include "real-value-impl.h"
+#include "flang/Common/idioms.h"
+#include "flang/Decimal/decimal.h"
+#include "flang/Evaluate/rounding-bits.h"
+#include "llvm/Support/raw_ostream.h"
+#include <algorithm>
+#include <cstring>
+#include <new>
+#include <string>
+
+namespace Fortran::evaluate::value {
+
+RoundingBits::RoundingBits(const IntegerValue &fraction, int rshift) {
+ const int fb{fraction.bits()};
+ if (rshift > 0 && rshift < fb + 1) {
+ guard_ = fraction.BTEST(rshift - 1);
+ }
+ if (rshift > 1 && rshift < fb + 2) {
+ round_ = fraction.BTEST(rshift - 2);
+ }
+ if (rshift > 2) {
+ if (rshift >= fb + 2) {
+ sticky_ = !fraction.IsZero();
+ } else {
+ auto mask{IntegerValue::MASKR(rshift - 2, fraction.kind())};
+ sticky_ = !fraction.IAND(mask).IsZero();
+ }
+ }
+}
+
+static_assert(sizeof(RealValueImpl) == detail::kRealObjectSize);
+static_assert(alignof(RealValueImpl) <= detail::kRealObjectAlign);
+static_assert(sizeof(RealValue) == sizeof(RealValueImpl));
+
+// ============================================================================
+// RealValue facade.
+// ============================================================================
+
+RealValue RealValue::FromImpl(const RealValueImpl &x) {
+ RealValue r;
+ r.impl() = x;
+ return r;
+}
+
+RealValue RealValue::FromImpl(RealValueImpl &&x) {
+ RealValue r;
+ r.impl() = std::move(x);
+ return r;
+}
+
+ValueWithRealFlags<RealValue> RealValue::FromImpl(
+ const ValueWithRealFlags<RealValueImpl> &x) {
+ ValueWithRealFlags<RealValue> r;
+ r.value.impl() = x.value;
+ r.flags = x.flags;
+ return r;
+}
+
+RealValue::RealValue() { new (this) RealValueImpl(); }
+RealValue::~RealValue() { impl().~RealValueImpl(); }
+RealValue::RealValue(const RealValue &x) { new (this) RealValueImpl(x.impl()); }
+RealValue::RealValue(RealValue &&x) {
+ new (this) RealValueImpl(std::move(x.impl()));
+}
+RealValue &RealValue::operator=(const RealValue &x) {
+ impl() = x.impl();
+ return *this;
+}
+RealValue &RealValue::operator=(RealValue &&x) {
+ impl() = std::move(x.impl());
+ return *this;
+}
+
+RealValue::RealValue(const Word &w, int kind) {
+ new (this) RealValueImpl(w, kind);
+}
+
+bool RealValue::operator==(const RealValue &y) const {
+ return impl() == y.impl();
+}
+
+int RealValue::binaryPrecision(int kind) {
+ return RealValueImpl::binaryPrecision(kind);
+}
+int RealValue::isImplicitMSB(int kind) {
+ return RealValueImpl::isImplicitMSB(kind);
+}
+int RealValue::DIGITS(int kind) { return RealValueImpl::DIGITS(kind); }
+int RealValue::PRECISION(int kind) { return RealValueImpl::PRECISION(kind); }
+int RealValue::RANGE(int kind) { return RealValueImpl::RANGE(kind); }
+int RealValue::MAXEXPONENT(int kind) {
+ return RealValueImpl::MAXEXPONENT(kind);
+}
+int RealValue::MINEXPONENT(int kind) {
+ return RealValueImpl::MINEXPONENT(kind);
+}
+RealValue RealValue::HUGE(int kind) {
+ return FromImpl(RealValueImpl::HUGE(kind));
+}
+RealValue RealValue::EPSILON(int kind) {
+ return FromImpl(RealValueImpl::EPSILON(kind));
+}
+RealValue RealValue::TINY(int kind) {
+ return FromImpl(RealValueImpl::TINY(kind));
+}
+RealValue RealValue::NotANumber(int kind) {
+ return FromImpl(RealValueImpl::NotANumber(kind));
+}
+
+int RealValue::kind() const { return impl().kind(); }
+int RealValue::bits() const { return impl().bits(); }
+bool RealValue::IsMonostate() const { return impl().IsMonostate(); }
+bool RealValue::IsZero() const { return impl().IsZero(); }
+bool RealValue::IsNegative() const { return impl().IsNegative(); }
+bool RealValue::IsNotANumber() const { return impl().IsNotANumber(); }
+bool RealValue::IsQuietNaN() const { return impl().IsQuietNaN(); }
+bool RealValue::IsSignalingNaN() const { return impl().IsSignalingNaN(); }
+bool RealValue::IsInfinite() const { return impl().IsInfinite(); }
+bool RealValue::IsFinite() const { return impl().IsFinite(); }
+bool RealValue::IsNormal() const { return impl().IsNormal(); }
+int RealValue::Exponent() const { return impl().Exponent(); }
+bool RealValue::StoreRawBytes(void *to, std::size_t bytes) const {
+ return impl().StoreRawBytes(to, bytes);
+}
+RealValue RealValue::FromRawBytes(const void *raw, std::size_t bytes) {
+ return FromImpl(RealValueImpl::FromRawBytes(raw, bytes));
+}
+RealValue RealValue::Zero(int kind) {
+ return FromImpl(RealValueImpl::Zero(kind));
+}
+IntegerValue RealValue::RawBits() const { return impl().RawBits(); }
+Relation RealValue::Compare(const RealValue &y) const {
+ return impl().Compare(y.impl());
+}
+RealValue RealValue::ABS() const { return FromImpl(impl().ABS()); }
+RealValue RealValue::Negate() const { return FromImpl(impl().Negate()); }
+RealValue RealValue::SIGN(const RealValue &x) const {
+ return FromImpl(impl().SIGN(x.impl()));
+}
+RealValue RealValue::SetSign(bool toNegative) const {
+ return FromImpl(impl().SetSign(toNegative));
+}
+RealValue RealValue::FlushSubnormalToZero() const {
+ return FromImpl(impl().FlushSubnormalToZero());
+}
+ValueWithRealFlags<RealValue> RealValue::Add(
+ const RealValue &y, Rounding rounding) const {
+ return FromImpl(impl().Add(y.impl(), rounding));
+}
+ValueWithRealFlags<RealValue> RealValue::Subtract(
+ const RealValue &y, Rounding rounding) const {
+ return FromImpl(impl().Subtract(y.impl(), rounding));
+}
+ValueWithRealFlags<RealValue> RealValue::Multiply(
+ const RealValue &y, Rounding rounding) const {
+ return FromImpl(impl().Multiply(y.impl(), rounding));
+}
+ValueWithRealFlags<RealValue> RealValue::Divide(
+ const RealValue &y, Rounding rounding) const {
+ return FromImpl(impl().Divide(y.impl(), rounding));
+}
+ValueWithRealFlags<RealValue> RealValue::SQRT(Rounding rounding) const {
+ return FromImpl(impl().SQRT(rounding));
+}
+ValueWithRealFlags<RealValue> RealValue::HYPOT(
+ const RealValue &y, Rounding rounding) const {
+ return FromImpl(impl().HYPOT(y.impl(), rounding));
+}
+ValueWithRealFlags<RealValue> RealValue::MOD(
+ const RealValue &y, Rounding rounding) const {
+ return FromImpl(impl().MOD(y.impl(), rounding));
+}
+ValueWithRealFlags<RealValue> RealValue::MODULO(
+ const RealValue &y, Rounding rounding) const {
+ return FromImpl(impl().MODULO(y.impl(), rounding));
+}
+ValueWithRealFlags<RealValue> RealValue::DIM(
+ const RealValue &y, Rounding rounding) const {
+ return FromImpl(impl().DIM(y.impl(), rounding));
+}
+RealValue RealValue::FRACTION() const { return FromImpl(impl().FRACTION()); }
+RealValue RealValue::RRSPACING() const { return FromImpl(impl().RRSPACING()); }
+RealValue RealValue::SPACING() const { return FromImpl(impl().SPACING()); }
+RealValue RealValue::SET_EXPONENT(std::int64_t e) const {
+ return FromImpl(impl().SET_EXPONENT(e));
+}
+ValueWithRealFlags<RealValue> RealValue::NEAREST(bool upward) const {
+ return FromImpl(impl().NEAREST(upward));
+}
+ValueWithRealFlags<RealValue> RealValue::ToWholeNumber(
+ common::RoundingMode mode) const {
+ return FromImpl(impl().ToWholeNumber(mode));
+}
+ValueWithRealFlags<IntegerValue> RealValue::ToInteger(
+ common::RoundingMode mode, int toBits) const {
+ return impl().ToInteger(mode, toBits);
+}
+ValueWithRealFlags<RealValue> RealValue::SCALE(
+ const IntegerValue &by, Rounding rounding) const {
+ return FromImpl(impl().SCALE(by, rounding));
+}
+IntegerValue RealValue::EXPONENT() const { return impl().EXPONENT(); }
+ValueWithRealFlags<RealValue> RealValue::KahanSummation(
+ const RealValue &y, RealValue &correction, Rounding rounding) const {
+ return FromImpl(impl().KahanSummation(y.impl(), correction.impl(), rounding));
+}
+ValueWithRealFlags<RealValue> RealValue::FromInteger(
+ const IntegerValue &n, int kind, bool isUnsigned, Rounding rounding) {
+ return FromImpl(RealValueImpl::FromInteger(n, kind, isUnsigned, rounding));
+}
+ValueWithRealFlags<RealValue> RealValue::Convert(
+ const RealValue &from, int kind, Rounding rounding) {
+ return FromImpl(RealValueImpl::Convert(from.impl(), kind, rounding));
+}
+ValueWithRealFlags<RealValue> RealValue::Read(
+ const char *&pp, int kind, Rounding rounding) {
+ return FromImpl(RealValueImpl::Read(pp, kind, rounding));
+}
+std::string RealValue::DumpHexadecimal() const {
+ return impl().DumpHexadecimal();
+}
+llvm::raw_ostream &RealValue::AsFortran(
+ llvm::raw_ostream &o, int kind, bool minimal) const {
+ return impl().AsFortran(o, kind, minimal);
+}
+
+// ============================================================================
+// RealValueImpl out-of-line definitions.
+// ============================================================================
+
+namespace {
+
+template <typename INT> IntegerValue IntegerValueFromFixed(const INT &n) {
+ constexpr unsigned bits{INT::bits};
+ constexpr unsigned nWords{(bits + 63) / 64};
+ std::uint64_t words[nWords]{};
+ INT cur{n};
+ for (unsigned i = 0; i < nWords; ++i) {
+ words[i] = cur.template ToUInt<std::uint64_t>();
+ if constexpr (bits > 64) {
+ cur = cur.SHIFTR(64);
+ }
+ }
+ return IntegerValue::FromAPInt(
+ llvm::APInt(bits, llvm::ArrayRef(words, nWords)));
+}
+
+template <typename INT> INT FixedIntegerFromValue(const IntegerValue &v) {
+ if (v.IsMonostate()) {
+ return {};
+ }
+ constexpr unsigned bits{INT::bits};
+ llvm::APInt z{v.toAPInt().zextOrTrunc(bits)};
+ const std::uint64_t *raw{z.getRawData()};
+ if constexpr (bits <= 64) {
+ return INT{raw[0]};
+ } else {
+ return INT{raw[0]}.IOR(INT{raw[1]}.SHIFTL(64));
+ }
+}
+
+} // namespace
+
+template <typename R>
+ValueWithRealFlags<R> FromIntegerValue(
+ const IntegerValue &n, bool isUnsigned, Rounding rounding) {
+ using Fraction = typename R::Fraction;
+ bool isNegative{!isUnsigned && n.IsNegative()};
+ IntegerValue absN{n};
+ if (isNegative) {
+ absN = n.Negate().value;
+ }
+ int leadz{absN.LEADZ()};
+ const int absBits{absN.bits()};
+ if (leadz >= absBits) {
+ return {};
+ }
+ ValueWithRealFlags<R> result;
+ const int exponent{R::exponentBias + absBits - leadz - 1};
+ const int bitsNeeded{absBits - (leadz + R::isImplicitMSB)};
+ const int bitsLost{bitsNeeded - R::significandBits};
+ if (bitsLost <= 0) {
+ Fraction fraction{FixedIntegerFromValue<Fraction>(absN)};
+ result.flags |= result.value.Normalize(
+ isNegative, exponent, fraction.SHIFTL(-bitsLost));
+ } else {
+ Fraction fraction{FixedIntegerFromValue<Fraction>(absN.SHIFTR(bitsLost))};
+ result.flags |= result.value.Normalize(isNegative, exponent, fraction);
+ RoundingBits roundingBits{absN, bitsLost};
+ result.flags |= result.value.Round(rounding, roundingBits);
+ }
+ return result;
+}
+
+RealValueImpl::RealValueImpl(const Word &w, int kind) {
+ realWithKind(kind, [&](auto proto) {
+ using R = decltype(proto);
+ if (w.IsMonostate()) {
+ storage_ = R{};
+ } else {
+ storage_ = R{FixedIntegerFromValue<typename R::Word>(w)};
+ }
+ });
+}
+
+bool RealValueImpl::operator==(const RealValueImpl &y) const {
+ return WithReal([&y](const auto &v1) -> bool {
+ return y.WithReal([&v1](const auto &v2) -> bool {
+ if constexpr (std::is_same_v<std::decay_t<decltype(v1)>,
+ std::decay_t<decltype(v2)>>) {
+ return v1 == v2;
+ }
+ llvm_unreachable("Uncomparable reals");
+ });
+ });
+}
+
+int RealValueImpl::kind() const {
+ if (IsMonostate()) {
+ llvm_unreachable("uninitialized value has not a defined kind");
+ }
+ return WithReal(
+ [](const auto &v) { return KindOf<std::decay_t<decltype(v)>>(); });
+}
+
+int RealValueImpl::bits() const {
+ if (IsMonostate()) {
+ return 0;
+ }
+ return WithReal(
+ [](const auto &v) -> int { return std::decay_t<decltype(v)>::bits; });
+}
+
+RealValueImpl RealValueImpl::Zero(int kind) {
+ RealValueImpl result;
+ realWithKind(kind, [&](auto proto) { result.storage_ = decltype(proto){}; });
+ return result;
+}
+
+// PAPAYA: Remove, not a 1-to-1 relationship
+static int RealKindFromByteCount(std::size_t bytes) {
+ switch (bytes) {
+ case 2:
+ return 2;
+ case 4:
+ return 4;
+ case 8:
+ return 8;
+ case 10:
+ return 10;
+ case 16:
+ return 16;
+ default:
+ return 8;
+ }
+}
+
+// PAPAYA: Replace bytes by kind (all types)
+RealValueImpl RealValueImpl::FromRawBytes(const void *raw, std::size_t bytes) {
+ int kind{RealKindFromByteCount(bytes)};
+ return RealValueImpl{IntegerValue::FromRawBytes(raw, kind), kind};
+}
+
+IntegerValue RealValueImpl::RawBits() const {
+ if (IsMonostate()) {
+ return {};
+ }
+ return WithReal(
+ [](const auto &v) { return IntegerValueFromFixed(v.RawBits()); });
+}
+
+bool RealValueImpl::StoreRawBytes(void *to, std::size_t bytes) const {
+ auto raw{RawBits()};
+ std::size_t payloadBytes{
+ std::min(bytes, static_cast<std::size_t>((bits() + 7) / 8))};
+ bool changed{raw.StoreRawBytes(to, kind())};
+ if (payloadBytes < bytes &&
+ !std::all_of(static_cast<const char *>(to) + payloadBytes,
+ static_cast<const char *>(to) + bytes,
+ [](char x) { return x == 0; })) {
+ std::memset(
+ static_cast<char *>(to) + payloadBytes, 0, bytes - payloadBytes);
+ changed = true;
+ }
+ return changed;
+}
+
+int RealValueImpl::binaryPrecision(int kind) {
+ return realWithKind(
+ kind, [](auto p) { return decltype(p)::binaryPrecision; });
+}
+int RealValueImpl::isImplicitMSB(int kind) {
+ return realWithKind(
+ kind, [](auto p) -> int { return decltype(p)::isImplicitMSB; });
+}
+int RealValueImpl::DIGITS(int kind) {
+ return realWithKind(kind, [](auto p) { return decltype(p)::DIGITS; });
+}
+int RealValueImpl::PRECISION(int kind) {
+ return realWithKind(kind, [](auto p) { return decltype(p)::PRECISION; });
+}
+int RealValueImpl::RANGE(int kind) {
+ return realWithKind(kind, [](auto p) { return decltype(p)::RANGE; });
+}
+int RealValueImpl::MAXEXPONENT(int kind) {
+ return realWithKind(kind, [](auto p) { return decltype(p)::MAXEXPONENT; });
+}
+int RealValueImpl::MINEXPONENT(int kind) {
+ return realWithKind(kind, [](auto p) { return decltype(p)::MINEXPONENT; });
+}
+RealValueImpl RealValueImpl::HUGE(int kind) {
+ return realWithKind(kind, [](auto p) { return Wrap(decltype(p)::HUGE()); });
+}
+RealValueImpl RealValueImpl::EPSILON(int kind) {
+ return realWithKind(
+ kind, [](auto p) { return Wrap(decltype(p)::EPSILON()); });
+}
+RealValueImpl RealValueImpl::TINY(int kind) {
+ return realWithKind(kind, [](auto p) { return Wrap(decltype(p)::TINY()); });
+}
+RealValueImpl RealValueImpl::NotANumber(int kind) {
+ return realWithKind(
+ kind, [](auto p) { return Wrap(decltype(p)::NotANumber()); });
+}
+
+bool RealValueImpl::IsZero() const {
+ if (IsMonostate()) {
+ return true;
+ }
+ return WithReal([](const auto &v) { return v.IsZero(); });
+}
+
+bool RealValueImpl::IsNegative() const {
+ if (IsMonostate()) {
+ return false;
+ }
+ return WithReal([](const auto &v) { return v.IsNegative(); });
+}
+
+bool RealValueImpl::IsNotANumber() const {
+ if (IsMonostate()) {
+ return false;
+ }
+ return WithReal([](const auto &v) { return v.IsNotANumber(); });
+}
+
+bool RealValueImpl::IsQuietNaN() const {
+ if (IsMonostate()) {
+ return false;
+ }
+ return WithReal([](const auto &v) { return v.IsQuietNaN(); });
+}
+
+bool RealValueImpl::IsSignalingNaN() const {
+ if (IsMonostate()) {
+ return false;
+ }
+ return WithReal([](const auto &v) { return v.IsSignalingNaN(); });
+}
+
+bool RealValueImpl::IsInfinite() const {
+ if (IsMonostate()) {
+ return false;
+ }
+ return WithReal([](const auto &v) { return v.IsInfinite(); });
+}
+
+bool RealValueImpl::IsFinite() const {
+ if (IsMonostate()) {
+ return true;
+ }
+ return WithReal([](const auto &v) { return v.IsFinite(); });
+}
+
+bool RealValueImpl::IsNormal() const {
+ if (IsMonostate()) {
+ return true;
+ }
+ return WithReal([](const auto &v) { return v.IsNormal(); });
+}
+
+int RealValueImpl::Exponent() const {
+ if (IsMonostate()) {
+ return 0;
+ }
+ return WithReal([](const auto &v) { return v.Exponent(); });
+}
+
+Relation RealValueImpl::Compare(const RealValueImpl &y) const {
+ if (IsMonostate()) {
+ llvm_unreachable("uncomparable value");
+ }
+ return WithReal([&](const auto &v) {
+ using R = std::decay_t<decltype(v)>;
+ return v.Compare(As<R>(y));
+ });
+}
+
+RealValueImpl RealValueImpl::ABS() const {
+ if (IsMonostate()) {
+ return RealValueImpl{};
+ }
+ return WithReal([](const auto &v) { return Wrap(v.ABS()); });
+}
+
+RealValueImpl RealValueImpl::Negate() const {
+ if (IsMonostate()) {
+ return RealValueImpl{};
+ }
+ return WithReal([](const auto &v) { return Wrap(v.Negate()); });
+}
+
+RealValueImpl RealValueImpl::SIGN(const RealValueImpl &x) const {
+ if (IsMonostate()) {
+ llvm_unreachable("unsupported operation over uninitialized value");
+ }
+ return WithReal([&](const auto &v) {
+ using R = std::decay_t<decltype(v)>;
+ return Wrap(v.SIGN(As<R>(x)));
+ });
+}
+
+RealValueImpl RealValueImpl::SetSign(bool toNegative) const {
+ if (IsMonostate()) {
+ llvm_unreachable("unsupported operation over uninitialized value");
+ }
+ return WithReal([&](const auto &v) { return Wrap(v.SetSign(toNegative)); });
+}
+
+RealValueImpl RealValueImpl::FlushSubnormalToZero() const {
+ if (IsMonostate()) {
+ llvm_unreachable("unsupported operation over uninitialized value");
+ }
+ return WithReal([](const auto &v) { return Wrap(v.FlushSubnormalToZero()); });
+}
+
+ValueWithRealFlags<RealValueImpl> RealValueImpl::Add(
+ const RealValueImpl &y, Rounding rounding) const {
+ if (IsMonostate()) {
+ llvm_unreachable("unsupported operation over uninitialized value");
+ }
+ return WithReal([&](const auto &v) {
+ using R = std::decay_t<decltype(v)>;
+ return Wrap(v.Add(As<R>(y), rounding));
+ });
+}
+
+ValueWithRealFlags<RealValueImpl> RealValueImpl::Subtract(
+ const RealValueImpl &y, Rounding rounding) const {
+ if (IsMonostate()) {
+ llvm_unreachable("unsupported operation over uninitialized value");
+ }
+ return WithReal([&](const auto &v) {
+ using R = std::decay_t<decltype(v)>;
+ return Wrap(v.Subtract(As<R>(y), rounding));
+ });
+}
+
+ValueWithRealFlags<RealValueImpl> RealValueImpl::Multiply(
+ const RealValueImpl &y, Rounding rounding) const {
+ if (IsMonostate()) {
+ llvm_unreachable("unsupported operation over uninitialized value");
+ }
+ return WithReal([&](const auto &v) {
+ using R = std::decay_t<decltype(v)>;
+ return Wrap(v.Multiply(As<R>(y), rounding));
+ });
+}
+
+ValueWithRealFlags<RealValueImpl> RealValueImpl::Divide(
+ const RealValueImpl &y, Rounding rounding) const {
+ if (IsMonostate()) {
+ llvm_unreachable("unsupported operation over uninitialized value");
+ }
+ return WithReal([&](const auto &v) {
+ using R = std::decay_t<decltype(v)>;
+ return Wrap(v.Divide(As<R>(y), rounding));
+ });
+}
+
+ValueWithRealFlags<RealValueImpl> RealValueImpl::SQRT(Rounding rounding) const {
+ if (IsMonostate()) {
+ llvm_unreachable("unsupported operation over uninitialized value");
+ }
+ return WithReal([&](const auto &v) { return Wrap(v.SQRT(rounding)); });
+}
+
+ValueWithRealFlags<RealValueImpl> RealValueImpl::HYPOT(
+ const RealValueImpl &y, Rounding rounding) const {
+ if (IsMonostate()) {
+ llvm_unreachable("unsupported operation over uninitialized value");
+ }
+ return WithReal([&](const auto &v) {
+ using R = std::decay_t<decltype(v)>;
+ return Wrap(v.HYPOT(As<R>(y), rounding));
+ });
+}
+
+ValueWithRealFlags<RealValueImpl> RealValueImpl::MOD(
+ const RealValueImpl &y, Rounding rounding) const {
+ if (IsMonostate()) {
+ llvm_unreachable("unsupported operation over uninitialized value");
+ }
+ return WithReal([&](const auto &v) {
+ using R = std::decay_t<decltype(v)>;
+ return Wrap(v.MOD(As<R>(y), rounding));
+ });
+}
+
+ValueWithRealFlags<RealValueImpl> RealValueImpl::MODULO(
+ const RealValueImpl &y, Rounding rounding) const {
+ if (IsMonostate()) {
+ llvm_unreachable("unsupported operation over uninitialized value");
+ }
+ return WithReal([&](const auto &v) {
+ using R = std::decay_t<decltype(v)>;
+ return Wrap(v.MODULO(As<R>(y), rounding));
+ });
+}
+
+ValueWithRealFlags<RealValueImpl> RealValueImpl::DIM(
+ const RealValueImpl &y, Rounding rounding) const {
+ if (IsMonostate()) {
+ llvm_unreachable("unsupported operation over uninitialized value");
+ }
+ return WithReal([&](const auto &v) {
+ using R = std::decay_t<decltype(v)>;
+ return Wrap(v.DIM(As<R>(y), rounding));
+ });
+}
+
+RealValueImpl RealValueImpl::FRACTION() const {
+ if (IsMonostate()) {
+ llvm_unreachable("unsupported operation over uninitialized value");
+ }
+ return WithReal([](const auto &v) { return Wrap(v.FRACTION()); });
+}
+
+RealValueImpl RealValueImpl::RRSPACING() const {
+ if (IsMonostate()) {
+ llvm_unreachable("unsupported operation over uninitialized value");
+ }
+ return WithReal([](const auto &v) { return Wrap(v.RRSPACING()); });
+}
+
+RealValueImpl RealValueImpl::SPACING() const {
+ if (IsMonostate()) {
+ llvm_unreachable("unsupported operation over uninitialized value");
+ }
+ return WithReal([](const auto &v) { return Wrap(v.SPACING()); });
+}
+
+RealValueImpl RealValueImpl::SET_EXPONENT(std::int64_t e) const {
+ if (IsMonostate()) {
+ llvm_unreachable("unsupported operation over uninitialized value");
+ }
+ return WithReal([&](const auto &v) { return Wrap(v.SET_EXPONENT(e)); });
+}
+
+ValueWithRealFlags<RealValueImpl> RealValueImpl::NEAREST(bool upward) const {
+ if (IsMonostate()) {
+ llvm_unreachable("unsupported operation over uninitialized value");
+ }
+ return WithReal([&](const auto &v) { return Wrap(v.NEAREST(upward)); });
+}
+
+ValueWithRealFlags<RealValueImpl> RealValueImpl::ToWholeNumber(
+ common::RoundingMode mode) const {
+ if (IsMonostate()) {
+ llvm_unreachable("unsupported operation over uninitialized value");
+ }
+ return WithReal([&](const auto &v) { return Wrap(v.ToWholeNumber(mode)); });
+}
+
+ValueWithRealFlags<IntegerValue> RealValueImpl::ToInteger(
+ common::RoundingMode mode, int toBits) const {
+ if (IsMonostate()) {
+ return ValueWithRealFlags<IntegerValue>{};
+ }
+ return WithReal([&](const auto &v) -> ValueWithRealFlags<IntegerValue> {
+ auto pick{[&](auto target) -> ValueWithRealFlags<IntegerValue> {
+ using W = decltype(target);
+ auto r{v.template ToInteger<W>(mode)};
+ ValueWithRealFlags<IntegerValue> result;
+ result.value = IntegerValueFromFixed(r.value);
+ result.flags = r.flags;
+ return result;
+ }};
+ switch (toBits) {
+ case 8:
+ return pick(Integer<8>{});
+ case 16:
+ return pick(Integer<16>{});
+ case 32:
+ return pick(Integer<32>{});
+ case 64:
+ return pick(Integer<64>{});
+ case 128:
+ return pick(Integer<128>{});
+ default:
+ return pick(Integer<64>{});
+ }
+ });
+}
+
+ValueWithRealFlags<RealValueImpl> RealValueImpl::SCALE(
+ const IntegerValue &by, Rounding rounding) const {
+ if (IsMonostate()) {
+ return ValueWithRealFlags<RealValueImpl>{};
+ }
+ return WithReal([&](const auto &v) -> ValueWithRealFlags<RealValueImpl> {
+ return Wrap(v.SCALE(Integer<64>{by.ToInt64()}, rounding));
+ });
+}
+
+IntegerValue RealValueImpl::EXPONENT() const {
+ if (IsMonostate()) {
+ return IntegerValue{};
+ }
+ return WithReal([](const auto &v) -> IntegerValue {
+ return IntegerValueFromFixed(v.template EXPONENT<Integer<32>>());
+ });
+}
+
+ValueWithRealFlags<RealValueImpl> RealValueImpl::KahanSummation(
+ const RealValueImpl &y, RealValueImpl &correction,
+ Rounding rounding) const {
+ if (IsMonostate()) {
+ llvm_unreachable("unsupported operation over uninitialized value");
+ }
+ return WithReal([&](const auto &v) {
+ using R = std::decay_t<decltype(v)>;
+ R corr{As<R>(correction)};
+ auto r{v.KahanSummation(As<R>(y), corr, rounding)};
+ correction = Wrap(corr);
+ return Wrap(r);
+ });
+}
+
+ValueWithRealFlags<RealValueImpl> RealValueImpl::FromInteger(
+ const IntegerValue &n, int kind, bool isUnsigned, Rounding rounding) {
+ if (n.IsMonostate()) {
+ return ValueWithRealFlags<RealValueImpl>{};
+ }
+ return realWithKind(
+ kind, [&](auto proto) -> ValueWithRealFlags<RealValueImpl> {
+ auto r{FromIntegerValue<decltype(proto)>(n, isUnsigned, rounding)};
+ return {Wrap(r.value), r.flags};
+ });
+}
+
+ValueWithRealFlags<RealValueImpl> RealValueImpl::Convert(
+ const RealValueImpl &from, int kind, Rounding rounding) {
+ return realWithKind(
+ kind, [&](auto proto) -> ValueWithRealFlags<RealValueImpl> {
+ using R = decltype(proto);
+ if (from.IsMonostate()) {
+ return Wrap(R::Convert(R{}, rounding));
+ }
+ return from.WithReal(
+ [&](const auto &v) -> ValueWithRealFlags<RealValueImpl> {
+ return Wrap(R::Convert(v, rounding));
+ });
+ });
+}
+
+ValueWithRealFlags<RealValueImpl> RealValueImpl::Read(
+ const char *&pp, int kind, Rounding rounding) {
+ return realWithKind(
+ kind, [&](auto proto) -> ValueWithRealFlags<RealValueImpl> {
+ auto r{decltype(proto)::Read(pp, rounding)};
+ ValueWithRealFlags<RealValueImpl> result;
+ result.value = Wrap(r.value);
+ result.flags = r.flags;
+ return result;
+ });
+}
+
+std::string RealValueImpl::DumpHexadecimal() const {
+ if (IsMonostate()) {
+ llvm_unreachable("unsupported operation over uninitialized value");
+ }
+ return WithReal([](const auto &v) { return v.DumpHexadecimal(); });
+}
+
+llvm::raw_ostream &RealValueImpl::AsFortran(
+ llvm::raw_ostream &o, int kind, bool minimal) const {
+ if (IsMonostate()) {
+ o << "0";
+ return o;
+ }
+ WithReal([&](const auto &v) {
+ v.AsFortran(o, kind, minimal);
+ return 0;
+ });
+ return o;
+}
+
+} // namespace Fortran::evaluate::value
diff --git a/flang/lib/Evaluate/real.cpp b/flang/lib/Evaluate/real.cpp
index eb335ce328517..551d85403733c 100644
--- a/flang/lib/Evaluate/real.cpp
+++ b/flang/lib/Evaluate/real.cpp
@@ -10,9 +10,11 @@
#include "int-power.h"
#include "flang/Common/idioms.h"
#include "flang/Decimal/decimal.h"
+#include "flang/Evaluate/formatting.h"
#include "flang/Parser/characters.h"
#include "llvm/Support/raw_ostream.h"
#include <limits>
+#include <string>
namespace Fortran::evaluate::value {
@@ -831,4 +833,5 @@ template class Real<Integer<32>, 24>;
template class Real<Integer<64>, 53>;
template class Real<X87IntegerContainer, 64>;
template class Real<Integer<128>, 113>;
+
} // namespace Fortran::evaluate::value
diff --git a/flang/lib/Evaluate/shape.cpp b/flang/lib/Evaluate/shape.cpp
index 27913c3559c71..e0fbc4e36f8c8 100644
--- a/flang/lib/Evaluate/shape.cpp
+++ b/flang/lib/Evaluate/shape.cpp
@@ -24,6 +24,14 @@ using namespace std::placeholders; // _1, _2, &c. for std::bind()
namespace Fortran::evaluate {
+static Scalar<ExtentType> MakeExtentScalar(ConstantSubscript n) {
+ return Scalar<ExtentType>{n, subscriptIntegerKind};
+}
+
+static ExtentExpr MakeExtentExpr(ConstantSubscript n) {
+ return ExtentExpr{Constant<ExtentType>{MakeExtentScalar(n)}};
+}
+
FoldingContext &GetFoldingContextFrom(const Symbol &symbol) {
return symbol.owner().context().foldingContext();
}
@@ -98,7 +106,12 @@ std::optional<ExtentExpr> AsExtentArrayExpr(const Shape &shape) {
return std::nullopt;
}
}
- return ExtentExpr{ArrayConstructor<ExtentType>{std::move(values)}};
+ ArrayConstructor<ExtentType> result{std::move(values)};
+ // The kind is a runtime property; set it explicitly so that an empty shape
+ // (e.g. SHAPE() of a scalar) yields an extent array of the proper subscript
+ // integer kind rather than a kind gleaned as zero from absent elements.
+ result.resultKind_ = subscriptIntegerKind;
+ return ExtentExpr{std::move(result)};
}
std::optional<Constant<ExtentType>> AsConstantShape(
@@ -116,9 +129,13 @@ Constant<SubscriptInteger> AsConstantShape(const ConstantSubscripts &shape) {
using IntType = Scalar<SubscriptInteger>;
std::vector<IntType> result;
for (auto dim : shape) {
- result.emplace_back(dim);
+ result.emplace_back(dim, subscriptIntegerKind);
}
- return {std::move(result), ConstantSubscripts{GetRank(shape)}};
+ // The kind is a runtime property; pass it explicitly so that a zero-length
+ // shape array (e.g. SHAPE() of a scalar) still reports the correct kind
+ // rather than deriving kind 0 from an absent first element.
+ return {std::move(result), ConstantSubscripts{GetRank(shape)},
+ SubscriptInteger{subscriptIntegerKind}};
}
ConstantSubscripts AsConstantExtents(const Constant<ExtentType> &shape) {
@@ -141,7 +158,7 @@ std::optional<ConstantSubscripts> AsConstantExtents(
Shape AsShape(const ConstantSubscripts &shape) {
Shape result;
for (const auto &extent : shape) {
- result.emplace_back(ExtentExpr{extent});
+ result.emplace_back(MakeExtentExpr(extent));
}
return result;
}
@@ -176,8 +193,8 @@ static ExtentExpr ComputeTripCount(
ExtentExpr span{
(std::move(upper) - std::move(lower) + std::move(strideCopy)) /
std::move(stride)};
- return ExtentExpr{
- Extremum<ExtentType>{Ordering::Greater, std::move(span), ExtentExpr{0}}};
+ return ExtentExpr{Extremum<ExtentType>{
+ Ordering::Greater, std::move(span), MakeExtentExpr(0)}};
}
ExtentExpr CountTrips(
@@ -201,7 +218,7 @@ MaybeExtentExpr CountTrips(MaybeExtentExpr &&lower, MaybeExtentExpr &&upper,
}
MaybeExtentExpr GetSize(Shape &&shape) {
- ExtentExpr extent{1};
+ ExtentExpr extent{MakeExtentExpr(1)};
for (auto &&dim : std::move(shape)) {
if (dim) {
extent = std::move(extent) * std::move(*dim);
@@ -245,10 +262,11 @@ class GetLowerBoundHelper
int d, FoldingContext *context, bool invariantOnly)
: Base{*this}, dimension_{d}, context_{context},
invariantOnly_{invariantOnly} {}
- static Result Default() { return Result{1}; }
+ static ExtentExpr OneExpr() { return MakeExtentExpr(1); }
+ static Result Default() { return Result{OneExpr()}; }
static Result Combine(Result &&, Result &&) {
// Operator results and array references always have lower bounds == 1
- return Result{1};
+ return Result{OneExpr()};
}
Result GetLowerBound(const Symbol &symbol0, NamedEntity &&base) const {
@@ -281,10 +299,10 @@ class GetLowerBoundHelper
if (context_) {
auto extent{ToInt64(Fold(*context_,
ExtentExpr{*ubound} - ExtentExpr{*lbound} +
- ExtentExpr{1}))};
+ MakeExtentExpr(1)))};
if (extent) {
if (extent <= 0) {
- return Result{1};
+ return Result{OneExpr()};
}
ok = true;
} else {
@@ -294,7 +312,7 @@ class GetLowerBoundHelper
auto ubValue{ToInt64(*ubound)};
if (lbValue && ubValue) {
if (*lbValue > *ubValue) {
- return Result{1};
+ return Result{OneExpr()};
}
ok = true;
} else {
@@ -307,7 +325,7 @@ class GetLowerBoundHelper
return *lbound;
}
} else {
- return Result{1};
+ return Result{OneExpr()};
}
}
if (IsDescriptor(symbol)) {
@@ -318,7 +336,7 @@ class GetLowerBoundHelper
} else if (const auto *assoc{
symbol.detailsIf<semantics::AssocEntityDetails>()}) {
if (assoc->IsAssumedSize()) { // RANK(*)
- return Result{1};
+ return Result{OneExpr()};
} else if (assoc->IsAssumedRank()) { // RANK DEFAULT
} else if (assoc->rank()) { // RANK(n)
const Symbol &resolved{ResolveAssociations(symbol)};
@@ -343,7 +361,7 @@ class GetLowerBoundHelper
if constexpr (LBOUND_SEMANTICS) {
return Result{};
} else {
- return Result{1};
+ return Result{OneExpr()};
}
}
@@ -356,7 +374,7 @@ class GetLowerBoundHelper
return GetLowerBound(
component.GetLastSymbol(), NamedEntity{common::Clone(component)});
}
- return Result{1};
+ return Result{OneExpr()};
}
template <typename T> Result operator()(const Expr<T> &expr) const {
@@ -366,10 +384,10 @@ class GetLowerBoundHelper
if (const auto *con{std::get_if<Constant<T>>(&expr.u)}) {
ConstantSubscripts lb{con->lbounds()};
if (dimension_ < GetRank(lb)) {
- return Result{lb[dimension_]};
+ return Result{MakeExtentExpr(lb[dimension_])};
}
} else { // operation
- return Result{1};
+ return Result{OneExpr()};
}
} else {
return (*this)(expr.u);
@@ -377,7 +395,7 @@ class GetLowerBoundHelper
if constexpr (LBOUND_SEMANTICS) {
return Result{};
} else {
- return Result{1};
+ return Result{OneExpr()};
}
}
@@ -462,9 +480,9 @@ static MaybeExtentExpr GetNonNegativeExtent(
std::optional<ConstantSubscript> lval{ToInt64(lbound)};
if (uval && lval) {
if (*uval < *lval) {
- return ExtentExpr{0};
+ return MakeExtentExpr(0);
} else {
- return ExtentExpr{*uval - *lval + 1};
+ return MakeExtentExpr(*uval - *lval + 1);
}
} else if (lbound && ubound && lbound->Rank() == 0 && ubound->Rank() == 0 &&
(!invariantOnly ||
@@ -473,11 +491,11 @@ static MaybeExtentExpr GetNonNegativeExtent(
// result is never negative
if (lval.value_or(0) == 1) {
return ExtentExpr{Extremum<SubscriptInteger>{
- Ordering::Greater, ExtentExpr{0}, common::Clone(*ubound)}};
+ Ordering::Greater, MakeExtentExpr(0), common::Clone(*ubound)}};
} else {
- return ExtentExpr{
- Extremum<SubscriptInteger>{Ordering::Greater, ExtentExpr{0},
- common::Clone(*ubound) - common::Clone(*lbound) + ExtentExpr{1}}};
+ return ExtentExpr{Extremum<SubscriptInteger>{Ordering::Greater,
+ MakeExtentExpr(0),
+ common::Clone(*ubound) - common::Clone(*lbound) + MakeExtentExpr(1)}};
}
} else {
return std::nullopt;
@@ -598,7 +616,7 @@ MaybeExtentExpr ComputeUpperBound(
if (ToInt64(lower).value_or(0) == 1) {
return std::move(*extent);
} else {
- return std::move(*extent) + std::move(lower) - ExtentExpr{1};
+ return std::move(*extent) + std::move(lower) - MakeExtentExpr(1);
}
} else {
return std::nullopt;
@@ -658,7 +676,7 @@ static MaybeExtentExpr GetExplicitUBOUND(FoldingContext *context,
if (cstExtent > 0) {
return *ubound;
} else if (cstExtent == 0) {
- return ExtentExpr{0};
+ return MakeExtentExpr(0);
}
}
}
@@ -952,8 +970,8 @@ auto GetShapeHelper::operator()(const ProcedureRef &call) const -> Result {
if (semantics::IsAssumedRank(*call.arguments().front())) {
return Shape{MaybeExtentExpr{}};
} else {
- return Shape{
- MaybeExtentExpr{ExtentExpr{call.arguments().front()->Rank()}}};
+ return Shape{MaybeExtentExpr{
+ MakeExtentExpr(call.arguments().front()->Rank())}};
}
}
} else if (intrinsic->name == "all" || intrinsic->name == "any" ||
@@ -993,7 +1011,7 @@ auto GetShapeHelper::operator()(const ProcedureRef &call) const -> Result {
}
} else {
// xxxLOC(no DIM=) result is vector(1:RANK(ARRAY=))
- return Shape{ExtentExpr{rank}};
+ return Shape{MakeExtentExpr(rank)};
}
}
}
@@ -1003,7 +1021,7 @@ auto GetShapeHelper::operator()(const ProcedureRef &call) const -> Result {
}
} else if (intrinsic->name == "lcobound" || intrinsic->name == "ucobound") {
if (call.arguments().size() == 3 && !call.arguments().at(1).has_value()) {
- return Shape(1, ExtentExpr{GetCorank(call.arguments().at(0))});
+ return Shape(1, MakeExtentExpr(GetCorank(call.arguments().at(0))));
}
} else if (intrinsic->name == "matmul") {
if (call.arguments().size() == 2) {
@@ -1034,7 +1052,7 @@ auto GetShapeHelper::operator()(const ProcedureRef &call) const -> Result {
if (auto arraySize{GetSize(std::move(*arrayShape))}) {
ActualArguments toMerge{
ActualArgument{AsGenericExpr(std::move(*arraySize))},
- ActualArgument{AsGenericExpr(ExtentExpr{0})},
+ ActualArgument{AsGenericExpr(MakeExtentExpr(0))},
common::Clone(call.arguments().at(1))};
auto specific{context_->intrinsics().Probe(
CallCharacteristics{"merge"}, toMerge, *context_)};
@@ -1047,7 +1065,8 @@ auto GetShapeHelper::operator()(const ProcedureRef &call) const -> Result {
} else {
// Non-scalar MASK= -> [COUNT(mask, KIND=extent_kind)]
ActualArgument kindArg{
- AsGenericExpr(Constant<ExtentType>{ExtentType::kind})};
+ AsGenericExpr(Constant<ExtentType>{ExtentType::Scalar{
+ subscriptIntegerKind, subscriptIntegerKind}})};
kindArg.set_keyword(context_->SaveTempName("kind"));
ActualArguments toCount{
ActualArgument{common::Clone(
@@ -1068,8 +1087,8 @@ auto GetShapeHelper::operator()(const ProcedureRef &call) const -> Result {
if (const auto *shapeExpr{
call.arguments().at(1).value().UnwrapExpr()}) {
auto shapeArg{std::get<Expr<SomeInteger>>(shapeExpr->u)};
- if (auto result{AsShapeResult(
- ConvertToType<ExtentType>(std::move(shapeArg)))}) {
+ if (auto result{AsShapeResult(ConvertToType<ExtentType>(
+ subscriptIntegerKind, std::move(shapeArg)))}) {
return result;
}
}
@@ -1088,8 +1107,10 @@ auto GetShapeHelper::operator()(const ProcedureRef &call) const -> Result {
if (*dim >= 1 &&
static_cast<std::size_t>(*dim) <= arrayShape->size() + 1) {
arrayShape->emplace(arrayShape->begin() + *dim - 1,
- Extremum<SubscriptInteger>{Ordering::Greater, ExtentExpr{0},
- ConvertToType<ExtentType>(common::Clone(*nCopies))});
+ Extremum<SubscriptInteger>{Ordering::Greater,
+ MakeExtentExpr(0),
+ ConvertToType<ExtentType>(
+ subscriptIntegerKind, common::Clone(*nCopies))});
return std::move(*arrayShape);
}
}
@@ -1100,8 +1121,8 @@ auto GetShapeHelper::operator()(const ProcedureRef &call) const -> Result {
// SIZE= is present; shape is vector [SIZE=]
if (const auto *size{
UnwrapExpr<Expr<SomeInteger>>(call.arguments().at(2))}) {
- return Shape{
- MaybeExtentExpr{ConvertToType<ExtentType>(common::Clone(*size))}};
+ return Shape{MaybeExtentExpr{ConvertToType<ExtentType>(
+ subscriptIntegerKind, common::Clone(*size))}};
}
} else if (context_) {
if (auto moldTypeAndShape{characteristics::TypeAndShape::Characterize(
@@ -1123,7 +1144,7 @@ auto GetShapeHelper::operator()(const ProcedureRef &call) const -> Result {
*sourceBytes = Fold(*context_, std::move(*sourceBytes));
if (auto sourceBytesConst{ToInt64(*sourceBytes)}) {
if (*sourceBytesConst == 0) {
- return Shape{ExtentExpr{0}};
+ return Shape{MakeExtentExpr(0)};
}
}
if (auto moldElementBytes{
@@ -1135,7 +1156,8 @@ auto GetShapeHelper::operator()(const ProcedureRef &call) const -> Result {
if (moldElementBytesConst && *moldElementBytesConst != 0) {
ExtentExpr extent{Fold(*context_,
(std::move(*sourceBytes) +
- common::Clone(*moldElementBytes) - ExtentExpr{1}) /
+ common::Clone(*moldElementBytes) -
+ MakeExtentExpr(1)) /
common::Clone(*moldElementBytes))};
return Shape{MaybeExtentExpr{std::move(extent)}};
}
@@ -1148,7 +1170,7 @@ auto GetShapeHelper::operator()(const ProcedureRef &call) const -> Result {
} else if (intrinsic->name == "this_image") {
if (call.arguments().size() == 2) {
// THIS_IMAGE(coarray, no DIM, [TEAM])
- return Shape(1, ExtentExpr{GetCorank(call.arguments().at(0))});
+ return Shape(1, MakeExtentExpr(GetCorank(call.arguments().at(0))));
}
} else if (intrinsic->name == "transpose") {
if (call.arguments().size() >= 1) {
diff --git a/flang/lib/Evaluate/static-data.cpp b/flang/lib/Evaluate/static-data.cpp
index 9063de0f3a938..f44ca925ddf41 100644
--- a/flang/lib/Evaluate/static-data.cpp
+++ b/flang/lib/Evaluate/static-data.cpp
@@ -7,6 +7,8 @@
//===----------------------------------------------------------------------===//
#include "flang/Evaluate/static-data.h"
+// #include "flang/Evaluate/char-storage-access.h"
+#include "flang/Evaluate/character-value-impl.h"
#include "flang/Parser/characters.h"
namespace Fortran::evaluate {
@@ -54,6 +56,15 @@ StaticDataObject &StaticDataObject::Push(
return *this;
}
+StaticDataObject &StaticDataObject::Push(
+ const value::CharacterValue &v, bool bigEndian) {
+ if (v.value().IsMonostate()) {
+ return *this;
+ }
+ return v.value().WithChar(
+ [&](const auto &s) -> StaticDataObject & { return Push(s, bigEndian); });
+}
+
std::optional<std::string> StaticDataObject::AsString() const {
if (itemBytes_ <= 1) {
std::string result;
diff --git a/flang/lib/Evaluate/target.cpp b/flang/lib/Evaluate/target.cpp
index c443278148304..921f80bd63e38 100644
--- a/flang/lib/Evaluate/target.cpp
+++ b/flang/lib/Evaluate/target.cpp
@@ -155,103 +155,52 @@ void TargetCharacteristics::set_roundingMode(Rounding rounding) {
// SELECTED_INT_KIND() -- F'2018 16.9.169
// and SELECTED_UNSIGNED_KIND() extension (same results)
-class SelectedIntKindVisitor {
-public:
- SelectedIntKindVisitor(
- const TargetCharacteristics &targetCharacteristics, std::int64_t p)
- : targetCharacteristics_{targetCharacteristics}, precision_{p} {}
- using Result = std::optional<int>;
- using Types = IntegerTypes;
- template <typename T> Result Test() const {
- if (Scalar<T>::RANGE >= precision_ &&
- targetCharacteristics_.IsTypeEnabled(T::category, T::kind)) {
- return T::kind;
- } else {
- return std::nullopt;
- }
- }
-
-private:
- const TargetCharacteristics &targetCharacteristics_;
- std::int64_t precision_;
-};
-
int TargetCharacteristics::SelectedIntKind(std::int64_t precision) const {
- if (auto kind{
- common::SearchTypes(SelectedIntKindVisitor{*this, precision})}) {
- return *kind;
- } else {
- return -1;
+ // Candidate kinds in ascending order; the smallest satisfying kind wins.
+ for (int kind : {1, 2, 4, 8, 16}) {
+ if (value::IntegerValue::RANGE(kind) >= precision &&
+ IsTypeEnabled(TypeCategory::Integer, kind)) {
+ return kind;
+ }
}
+ return -1;
}
// SELECTED_LOGICAL_KIND() -- F'2023 16.9.182
-class SelectedLogicalKindVisitor {
-public:
- SelectedLogicalKindVisitor(
- const TargetCharacteristics &targetCharacteristics, std::int64_t bits)
- : targetCharacteristics_{targetCharacteristics}, bits_{bits} {}
- using Result = std::optional<int>;
- using Types = LogicalTypes;
- template <typename T> Result Test() const {
- if (Scalar<T>::bits >= bits_ &&
- targetCharacteristics_.IsTypeEnabled(T::category, T::kind)) {
- return T::kind;
- } else {
- return std::nullopt;
- }
- }
-
-private:
- const TargetCharacteristics &targetCharacteristics_;
- std::int64_t bits_;
-};
-
int TargetCharacteristics::SelectedLogicalKind(std::int64_t bits) const {
- if (auto kind{common::SearchTypes(SelectedLogicalKindVisitor{*this, bits})}) {
- return *kind;
- } else {
- return -1;
+ for (int kind : {1, 2, 4, 8}) {
+ if (value::LogicalValue::Zero(kind).bits() >= bits &&
+ IsTypeEnabled(TypeCategory::Logical, kind)) {
+ return kind;
+ }
}
+ return -1;
}
// SELECTED_REAL_KIND() -- F'2018 16.9.170
-class SelectedRealKindVisitor {
-public:
- SelectedRealKindVisitor(const TargetCharacteristics &targetCharacteristics,
- std::int64_t p, std::int64_t r)
- : targetCharacteristics_{targetCharacteristics}, precision_{p}, range_{
- r} {}
- using Result = std::optional<int>;
- using Types = RealTypes;
- template <typename T> Result Test() const {
- if (Scalar<T>::PRECISION >= precision_ && Scalar<T>::RANGE >= range_ &&
- targetCharacteristics_.IsTypeEnabled(T::category, T::kind)) {
- return {T::kind};
- } else {
- return std::nullopt;
- }
- }
-
-private:
- const TargetCharacteristics &targetCharacteristics_;
- std::int64_t precision_, range_;
-};
-
int TargetCharacteristics::SelectedRealKind(
std::int64_t precision, std::int64_t range, std::int64_t radix) const {
if (radix != 2) {
return -5;
}
- if (auto kind{common::SearchTypes(
- SelectedRealKindVisitor{*this, precision, range})}) {
- return *kind;
+ auto search{[&](std::int64_t p, std::int64_t r) -> int {
+ for (int kind : {2, 3, 4, 8, 10, 16}) {
+ if (value::RealValue::PRECISION(kind) >= p &&
+ value::RealValue::RANGE(kind) >= r &&
+ IsTypeEnabled(TypeCategory::Real, kind)) {
+ return kind;
+ }
+ }
+ return -1;
+ }};
+ if (int kind{search(precision, range)}; kind > 0) {
+ return kind;
}
// No kind has both sufficient precision and sufficient range.
// The negative return value encodes whether any kinds exist that
// could satisfy either constraint independently.
- bool pOK{common::SearchTypes(SelectedRealKindVisitor{*this, precision, 0})};
- bool rOK{common::SearchTypes(SelectedRealKindVisitor{*this, 0, range})};
+ bool pOK{search(precision, 0) > 0};
+ bool rOK{search(0, range) > 0};
if (pOK) {
if (rOK) {
return -4;
diff --git a/flang/lib/Evaluate/tools.cpp b/flang/lib/Evaluate/tools.cpp
index 82dcd1e795f49..e8d910651a57b 100644
--- a/flang/lib/Evaluate/tools.cpp
+++ b/flang/lib/Evaluate/tools.cpp
@@ -153,23 +153,29 @@ ConvertRealOperandsResult ConvertRealOperands(
},
[&](Expr<SomeInteger> &&ix,
Expr<SomeReal> &&ry) -> ConvertRealOperandsResult {
+ // ConvertTo reads ry's runtime kind; sequence it before ry is
+ // moved (argument evaluation order is unspecified).
+ auto cvt{ConvertTo(ry, std::move(ix))};
return {AsSameKindExprs<TypeCategory::Real>(
- ConvertTo(ry, std::move(ix)), std::move(ry))};
+ std::move(cvt), std::move(ry))};
},
[&](Expr<SomeUnsigned> &&ix,
Expr<SomeReal> &&ry) -> ConvertRealOperandsResult {
+ auto cvt{ConvertTo(ry, std::move(ix))};
return {AsSameKindExprs<TypeCategory::Real>(
- ConvertTo(ry, std::move(ix)), std::move(ry))};
+ std::move(cvt), std::move(ry))};
},
[&](Expr<SomeReal> &&rx,
Expr<SomeInteger> &&iy) -> ConvertRealOperandsResult {
+ auto cvt{ConvertTo(rx, std::move(iy))};
return {AsSameKindExprs<TypeCategory::Real>(
- std::move(rx), ConvertTo(rx, std::move(iy)))};
+ std::move(rx), std::move(cvt))};
},
[&](Expr<SomeReal> &&rx,
Expr<SomeUnsigned> &&iy) -> ConvertRealOperandsResult {
+ auto cvt{ConvertTo(rx, std::move(iy))};
return {AsSameKindExprs<TypeCategory::Real>(
- std::move(rx), ConvertTo(rx, std::move(iy)))};
+ std::move(rx), std::move(cvt))};
},
[&](Expr<SomeReal> &&rx,
Expr<SomeReal> &&ry) -> ConvertRealOperandsResult {
@@ -210,13 +216,15 @@ ConvertRealOperandsResult ConvertRealOperands(
},
[&](Expr<SomeReal> &&rx,
BOZLiteralConstant &&by) -> ConvertRealOperandsResult {
+ auto cvt{ConvertTo(rx, std::move(by))};
return {AsSameKindExprs<TypeCategory::Real>(
- std::move(rx), ConvertTo(rx, std::move(by)))};
+ std::move(rx), std::move(cvt))};
},
[&](BOZLiteralConstant &&bx,
Expr<SomeReal> &&ry) -> ConvertRealOperandsResult {
+ auto cvt{ConvertTo(ry, std::move(bx))};
return {AsSameKindExprs<TypeCategory::Real>(
- ConvertTo(ry, std::move(bx)), std::move(ry))};
+ std::move(cvt), std::move(ry))};
},
[&](BOZLiteralConstant &&,
BOZLiteralConstant &&) -> ConvertRealOperandsResult {
@@ -263,16 +271,17 @@ std::optional<Expr<SomeType>> MixedRealLeft(
}
// G++ 8.1.0 emits bogus warnings about missing return statements if
// this statement is wrapped in an "else", as it should be.
- return AsCategoryExpr(OPR<resultType>{
- std::move(rxk), ConvertToType<resultType>(std::move(iy))});
+ int rk{rxk.GetType() ? rxk.GetType()->kind() : 0};
+ auto converted{ConvertToType<resultType>(rk, std::move(iy))};
+ return AsCategoryExpr(
+ OPR<resultType>{std::move(rxk), std::move(converted)});
},
std::move(rx.u)));
}
-template <int KIND>
-Expr<SomeComplex> MakeComplex(Expr<Type<TypeCategory::Real, KIND>> &&re,
- Expr<Type<TypeCategory::Real, KIND>> &&im) {
- return AsCategoryExpr(ComplexConstructor<KIND>{std::move(re), std::move(im)});
+static Expr<SomeComplex> MakeComplex(
+ Expr<Type<TypeCategory::Real>> &&re, Expr<Type<TypeCategory::Real>> &&im) {
+ return AsCategoryExpr(ComplexConstructor{std::move(re), std::move(im)});
}
std::optional<Expr<SomeComplex>> ConstructComplex(
@@ -302,82 +311,84 @@ std::optional<Expr<SomeComplex>> ConstructComplex(
// Extracts the real or imaginary part of the result of a COMPLEX
// expression, when that expression is simple enough to be duplicated.
template <bool GET_IMAGINARY> struct ComplexPartExtractor {
+ using RealType = Type<TypeCategory::Real>;
+ using ComplexType = Type<TypeCategory::Complex>;
+
+ // Extract the single Expr<Type<Real>> alternative from an Expr<SomeReal>.
+ static Expr<RealType> Specific(Expr<SomeReal> &&x) {
+ return std::get<Expr<RealType>>(std::move(x.u));
+ }
+
template <typename A> static std::optional<Expr<SomeReal>> Get(const A &) {
return std::nullopt;
}
- template <int KIND>
- static std::optional<Expr<SomeReal>> Get(
- const Parentheses<Type<TypeCategory::Complex, KIND>> &kz) {
+ static std::optional<Expr<SomeReal>> Get(const Parentheses<ComplexType> &kz) {
if (auto x{Get(kz.left())}) {
- return AsGenericExpr(AsSpecificExpr(
- Parentheses<Type<TypeCategory::Real, KIND>>{std::move(*x)}));
+ return AsCategoryExpr(Parentheses<RealType>{Specific(std::move(*x))});
} else {
return std::nullopt;
}
}
- template <int KIND>
- static std::optional<Expr<SomeReal>> Get(
- const Negate<Type<TypeCategory::Complex, KIND>> &kz) {
+ static std::optional<Expr<SomeReal>> Get(const Negate<ComplexType> &kz) {
if (auto x{Get(kz.left())}) {
- return AsGenericExpr(AsSpecificExpr(
- Negate<Type<TypeCategory::Real, KIND>>{std::move(*x)}));
+ return AsCategoryExpr(Negate<RealType>{Specific(std::move(*x))});
} else {
return std::nullopt;
}
}
- template <int KIND>
static std::optional<Expr<SomeReal>> Get(
- const Convert<Type<TypeCategory::Complex, KIND>, TypeCategory::Complex>
- &kz) {
+ const Convert<ComplexType, TypeCategory::Complex> &kz) {
if (auto x{Get(kz.left())}) {
- return AsGenericExpr(AsSpecificExpr(
- Convert<Type<TypeCategory::Real, KIND>, TypeCategory::Real>{
- AsGenericExpr(std::move(*x))}));
+ Convert<RealType, TypeCategory::Real> conv{std::move(*x)};
+ conv.resultKind_ = kz.resultKind_;
+ return AsCategoryExpr(std::move(conv));
} else {
return std::nullopt;
}
}
- template <int KIND>
- static std::optional<Expr<SomeReal>> Get(const ComplexConstructor<KIND> &kz) {
+ static std::optional<Expr<SomeReal>> Get(const ComplexConstructor &kz) {
return GET_IMAGINARY ? Get(kz.right()) : Get(kz.left());
}
- template <int KIND>
- static std::optional<Expr<SomeReal>> Get(
- const Constant<Type<TypeCategory::Complex, KIND>> &kz) {
+ static std::optional<Expr<SomeReal>> Get(const Constant<ComplexType> &kz) {
if (auto cz{kz.GetScalarValue()}) {
- return AsGenericExpr(
- AsSpecificExpr(GET_IMAGINARY ? cz->AIMAG() : cz->REAL()));
+ int rk{kz.GetType().kind()};
+ auto part{GET_IMAGINARY ? cz->AIMAG() : cz->REAL()};
+ return AsCategoryExpr(
+ AsExpr(Constant<RealType>{std::move(part), RealType{rk}}));
} else {
return std::nullopt;
}
}
- template <int KIND>
- static std::optional<Expr<SomeReal>> Get(
- const Designator<Type<TypeCategory::Complex, KIND>> &kz) {
+ static std::optional<Expr<SomeReal>> Get(const Designator<ComplexType> &kz) {
if (const auto *symbolRef{std::get_if<SymbolRef>(&kz.u)}) {
- return AsGenericExpr(AsSpecificExpr(
- Designator<Type<TypeCategory::Complex, KIND>>{ComplexPart{
- DataRef{*symbolRef},
- GET_IMAGINARY ? ComplexPart::Part::IM : ComplexPart::Part::RE}}));
+ return AsCategoryExpr(
+ Designator<RealType>{ComplexPart{DataRef{*symbolRef},
+ GET_IMAGINARY ? ComplexPart::Part::IM : ComplexPart::Part::RE}});
} else {
return std::nullopt;
}
}
- template <int KIND>
- static std::optional<Expr<SomeReal>> Get(
- const Expr<Type<TypeCategory::Complex, KIND>> &kz) {
- return Get(kz.u);
+ // NOTE: The legacy (static-kind) code returned Get(kz.u)/Get(z.u), passing
+ // the Expr's variant member to the generic Get(const A&) overload above,
+ // which always yields std::nullopt. The mixed COMPLEX+REAL/INTEGER operand
+ // decomposition in MixedComplexLeft/Right (e.g. (a,b)+x -> (a+x,b)) is
+ // therefore intentionally disabled: such operands are promoted to COMPLEX
+ // and combined with a COMPLEX operation instead. Preserve that behavior;
+ // visiting the variant here would change generated code (and, for example,
+ // break OpenMP ATOMIC UPDATE recognition of `z = z + x`).
+ static std::optional<Expr<SomeReal>> Get(const Expr<ComplexType> &) {
+ return std::nullopt;
}
- static std::optional<Expr<SomeReal>> Get(const Expr<SomeComplex> &z) {
- return Get(z.u);
+ static std::optional<Expr<SomeReal>> Get(const Expr<SomeComplex> &) {
+ return std::nullopt;
}
};
@@ -389,8 +400,9 @@ Expr<SomeComplex> PromoteRealToComplex(Expr<SomeReal> &&someX) {
return common::visit(
[](auto &&x) {
using RT = ResultType<decltype(x)>;
- return AsCategoryExpr(ComplexConstructor<RT::kind>{
- std::move(x), AsExpr(Constant<RT>{Scalar<RT>{}})});
+ int rk{x.GetType() ? x.GetType()->kind() : 0};
+ return AsCategoryExpr(ComplexConstructor{
+ std::move(x), AsExpr(Constant<RT>{Scalar<RT>::Zero(rk), RT{rk}})});
},
std::move(someX.u));
}
@@ -486,12 +498,14 @@ Expr<SomeComplex> PromoteMixedComplexReal(
static_assert(XCAT == TypeCategory::Real || YCAT == TypeCategory::Real);
return common::visit(
[&](const auto &kx, const auto &ky) {
- constexpr int maxKind{std::max(
- ResultType<decltype(kx)>::kind, ResultType<decltype(ky)>::kind)};
- using ZTy = Type<TypeCategory::Complex, maxKind>;
+ int xk{kx.GetType() ? kx.GetType()->kind() : 0};
+ int yk{ky.GetType() ? ky.GetType()->kind() : 0};
+ int maxKind{std::max(xk, yk)};
+ using ZTy = Type<TypeCategory::Complex>;
+ auto cx{ConvertToType<ZTy>(maxKind, std::move(x))};
+ auto cy{ConvertToType<ZTy>(maxKind, std::move(y))};
return Expr<SomeComplex>{
- Expr<ZTy>{OPR<ZTy>{ConvertToType<ZTy>(std::move(x)),
- ConvertToType<ZTy>(std::move(y))}}};
+ Expr<ZTy>{OPR<ZTy>{std::move(cx), std::move(cy)}}};
},
x.u, y.u);
}
@@ -525,9 +539,10 @@ std::optional<Expr<SomeType>> NumericOperation(
return Package(common::visit(
[&](auto &&ryk) -> Expr<SomeReal> {
using resultType = ResultType<decltype(ryk)>;
+ int rk{ryk.GetType() ? ryk.GetType()->kind() : 0};
+ auto converted{ConvertToType<resultType>(rk, std::move(ix))};
return AsCategoryExpr(
- OPR<resultType>{ConvertToType<resultType>(std::move(ix)),
- std::move(ryk)});
+ OPR<resultType>{std::move(converted), std::move(ryk)});
},
std::move(ry.u)));
},
@@ -541,8 +556,9 @@ std::optional<Expr<SomeType>> NumericOperation(
MixedComplexLeft<OPR>(messages, zx, iy, defaultRealKind)}) {
return result;
} else {
+ auto cvt{ConvertTo(zx, std::move(iy))};
return Package(PromoteAndCombine<OPR, TypeCategory::Complex>(
- std::move(zx), ConvertTo(zx, std::move(iy))));
+ std::move(zx), std::move(cvt)));
}
},
[&](Expr<SomeComplex> &&zx, Expr<SomeReal> &&ry) {
@@ -559,8 +575,9 @@ std::optional<Expr<SomeType>> NumericOperation(
messages, ix, zy, defaultRealKind)}) {
return result;
} else {
+ auto cvt{ConvertTo(zy, std::move(ix))};
return Package(PromoteAndCombine<OPR, TypeCategory::Complex>(
- ConvertTo(zy, std::move(ix)), std::move(zy)));
+ std::move(cvt), std::move(zy)));
}
},
[&](Expr<SomeReal> &&rx, Expr<SomeComplex> &&zy) {
@@ -574,31 +591,36 @@ std::optional<Expr<SomeType>> NumericOperation(
},
// Operations with one typeless operand
[&](BOZLiteralConstant &&bx, Expr<SomeInteger> &&iy) {
+ // ConvertTo reads iy's runtime kind; iy aliases y, so sequence the
+ // conversion before y is moved (argument order is unspecified).
+ auto cvt{ConvertTo(iy, std::move(bx))};
return NumericOperation<OPR>(messages,
- AsGenericExpr(ConvertTo(iy, std::move(bx))), std::move(y),
- defaultRealKind);
+ AsGenericExpr(std::move(cvt)), std::move(y), defaultRealKind);
},
[&](BOZLiteralConstant &&bx, Expr<SomeUnsigned> &&iy) {
+ auto cvt{ConvertTo(iy, std::move(bx))};
return NumericOperation<OPR>(messages,
- AsGenericExpr(ConvertTo(iy, std::move(bx))), std::move(y),
- defaultRealKind);
+ AsGenericExpr(std::move(cvt)), std::move(y), defaultRealKind);
},
[&](BOZLiteralConstant &&bx, Expr<SomeReal> &&ry) {
+ auto cvt{ConvertTo(ry, std::move(bx))};
return NumericOperation<OPR>(messages,
- AsGenericExpr(ConvertTo(ry, std::move(bx))), std::move(y),
- defaultRealKind);
+ AsGenericExpr(std::move(cvt)), std::move(y), defaultRealKind);
},
[&](Expr<SomeInteger> &&ix, BOZLiteralConstant &&by) {
+ auto cvt{ConvertTo(ix, std::move(by))};
return NumericOperation<OPR>(messages, std::move(x),
- AsGenericExpr(ConvertTo(ix, std::move(by))), defaultRealKind);
+ AsGenericExpr(std::move(cvt)), defaultRealKind);
},
[&](Expr<SomeUnsigned> &&ix, BOZLiteralConstant &&by) {
+ auto cvt{ConvertTo(ix, std::move(by))};
return NumericOperation<OPR>(messages, std::move(x),
- AsGenericExpr(ConvertTo(ix, std::move(by))), defaultRealKind);
+ AsGenericExpr(std::move(cvt)), defaultRealKind);
},
[&](Expr<SomeReal> &&rx, BOZLiteralConstant &&by) {
+ auto cvt{ConvertTo(rx, std::move(by))};
return NumericOperation<OPR>(messages, std::move(x),
- AsGenericExpr(ConvertTo(rx, std::move(by))), defaultRealKind);
+ AsGenericExpr(std::move(cvt)), defaultRealKind);
},
// Error cases
[&](Expr<SomeUnsigned> &&, auto &&) {
@@ -706,12 +728,17 @@ std::optional<Expr<LogicalResult>> Relate(parser::ContextualMessages &messages,
return PromoteAndRelate(opr, std::move(rx), std::move(ry));
},
[&](Expr<SomeReal> &&rx, Expr<SomeInteger> &&iy) {
+ // ConvertTo reads rx's runtime kind; rx aliases x, so the
+ // conversion must complete before x is moved (argument evaluation
+ // order is unspecified).
+ auto converted{ConvertTo(rx, std::move(iy))};
return Relate(messages, opr, std::move(x),
- AsGenericExpr(ConvertTo(rx, std::move(iy))));
+ AsGenericExpr(std::move(converted)));
},
[&](Expr<SomeInteger> &&ix, Expr<SomeReal> &&ry) {
- return Relate(messages, opr,
- AsGenericExpr(ConvertTo(ry, std::move(ix))), std::move(y));
+ auto converted{ConvertTo(ry, std::move(ix))};
+ return Relate(messages, opr, AsGenericExpr(std::move(converted)),
+ std::move(y));
},
[&](Expr<SomeComplex> &&zx,
Expr<SomeComplex> &&zy) -> std::optional<Expr<LogicalResult>> {
@@ -725,20 +752,24 @@ std::optional<Expr<LogicalResult>> Relate(parser::ContextualMessages &messages,
}
},
[&](Expr<SomeComplex> &&zx, Expr<SomeInteger> &&iy) {
+ auto converted{ConvertTo(zx, std::move(iy))};
return Relate(messages, opr, std::move(x),
- AsGenericExpr(ConvertTo(zx, std::move(iy))));
+ AsGenericExpr(std::move(converted)));
},
[&](Expr<SomeComplex> &&zx, Expr<SomeReal> &&ry) {
+ auto converted{ConvertTo(zx, std::move(ry))};
return Relate(messages, opr, std::move(x),
- AsGenericExpr(ConvertTo(zx, std::move(ry))));
+ AsGenericExpr(std::move(converted)));
},
[&](Expr<SomeInteger> &&ix, Expr<SomeComplex> &&zy) {
- return Relate(messages, opr,
- AsGenericExpr(ConvertTo(zy, std::move(ix))), std::move(y));
+ auto converted{ConvertTo(zy, std::move(ix))};
+ return Relate(messages, opr, AsGenericExpr(std::move(converted)),
+ std::move(y));
},
[&](Expr<SomeReal> &&rx, Expr<SomeComplex> &&zy) {
- return Relate(messages, opr,
- AsGenericExpr(ConvertTo(zy, std::move(rx))), std::move(y));
+ auto converted{ConvertTo(zy, std::move(rx))};
+ return Relate(messages, opr, AsGenericExpr(std::move(converted)),
+ std::move(y));
},
[&](Expr<SomeCharacter> &&cx, Expr<SomeCharacter> &&cy) {
return common::visit(
@@ -769,9 +800,8 @@ Expr<SomeLogical> BinaryLogicalOperation(
CHECK(opr != LogicalOperator::Not);
return common::visit(
[=](auto &&xy) {
- using Ty = ResultType<decltype(xy[0])>;
- return Expr<SomeLogical>{BinaryLogicalOperation<Ty::kind>(
- opr, std::move(xy[0]), std::move(xy[1]))};
+ return Expr<SomeLogical>{
+ BinaryLogicalOperation(opr, std::move(xy[0]), std::move(xy[1]))};
},
AsSameKindExprs(std::move(x), std::move(y)));
}
@@ -832,9 +862,8 @@ std::optional<Expr<SomeType>> ConvertToType(
converted = common::visit(
[&](auto &&x) {
using CharacterType = ResultType<decltype(x)>;
- return Expr<SomeCharacter>{
- Expr<CharacterType>{SetLength<CharacterType::kind>{
- std::move(x), std::move(*length)}}};
+ return Expr<SomeCharacter>{Expr<CharacterType>{
+ SetLength{std::move(x), std::move(*length)}}};
},
std::move(converted.u));
}
@@ -1489,17 +1518,14 @@ static std::optional<Expr<SomeType>> DataConstantConversionHelper(
if (auto sized{
Fold(context, ConvertToType(sizedType, Expr<SomeType>{expr}))}) {
if (const auto *someExpr{UnwrapExpr<Expr<SomeKind<FROM>>>(*sized)}) {
+ int kind{toType.kind()};
return common::visit(
- [](const auto &w) -> std::optional<Expr<SomeType>> {
+ [kind](const auto &w) -> std::optional<Expr<SomeType>> {
using FromType = ResultType<decltype(w)>;
- static constexpr int kind{FromType::kind};
- if constexpr (IsValidKindOfIntrinsicType(TO, kind)) {
+ if (IsValidKindOfIntrinsicType(TO, kind)) {
if (const auto *fromConst{UnwrapExpr<Constant<FromType>>(w)}) {
- using FromWordType = typename FromType::Scalar;
- using LogicalType = value::Logical<FromWordType::bits>;
- using ElementType =
- std::conditional_t<TO == TypeCategory::Logical, LogicalType,
- typename LogicalType::Word>;
+ using ToType = Type<TO>;
+ using ElementType = Scalar<ToType>;
std::vector<ElementType> values;
auto at{fromConst->lbounds()};
auto shape{fromConst->shape()};
@@ -1507,13 +1533,23 @@ static std::optional<Expr<SomeType>> DataConstantConversionHelper(
fromConst->IncrementSubscripts(at)) {
auto elt{fromConst->At(at)};
if constexpr (TO == TypeCategory::Logical) {
- values.emplace_back(std::move(elt));
+ // Reinterpret the integer element's bits as a logical of
+ // the destination kind.
+ values.emplace_back(elt, kind);
+ } else if constexpr (FROM == TypeCategory::Logical) {
+ values.emplace_back(value::IntegerValue::ConvertUnsigned(
+ elt.word(), 8 * kind)
+ .value);
} else {
- values.emplace_back(elt.word());
+ // Reinterpret the source element's bits as an integer of
+ // the destination kind (same numeric kind value).
+ values.emplace_back(
+ value::IntegerValue::ConvertUnsigned(elt, 8 * kind)
+ .value);
}
}
- return {AsGenericExpr(AsExpr(Constant<Type<TO, kind>>{
- std::move(values), std::move(shape)}))};
+ return {AsGenericExpr(AsExpr(Constant<Type<TO>>{
+ std::move(values), std::move(shape), Type<TO>{kind}}))};
}
}
return std::nullopt;
@@ -1574,15 +1610,20 @@ bool MayBePassedAsAbsentOptional(const Expr<SomeType> &expr) {
std::optional<Expr<SomeType>> HollerithToBOZ(FoldingContext &context,
const Expr<SomeType> &expr, const DynamicType &type) {
- if (std::optional<std::string> chValue{GetScalarConstantValue<Ascii>(expr)}) {
+ if (std::optional<value::CharacterValue> chCharVal{
+ GetScalarConstantValue<Ascii>(expr)}) {
+ std::optional<std::string> chValue{chCharVal->ToStdString()};
+ if (!chValue) {
+ return std::nullopt;
+ }
// Pad on the right with spaces when short, truncate the right if long.
auto bytes{static_cast<std::size_t>(
ToInt64(type.MeasureSizeInBytes(context, false)).value())};
- BOZLiteralConstant bits{0};
+ BOZLiteralConstant bits{0, 16};
for (std::size_t j{0}; j < bytes; ++j) {
auto idx{isHostLittleEndian ? j : bytes - j - 1};
char ch{idx >= chValue->size() ? ' ' : chValue->at(idx)};
- BOZLiteralConstant chBOZ{static_cast<unsigned char>(ch)};
+ BOZLiteralConstant chBOZ{static_cast<unsigned char>(ch), 16};
bits = bits.IOR(chBOZ.SHIFTL(8 * j));
}
return ConvertToType(type, Expr<SomeType>{bits});
@@ -1595,10 +1636,9 @@ std::optional<Expr<SomeType>> HollerithToBOZ(FoldingContext &context,
// possibly wrapped with parentheses or MAX(0, ...).
// Works with any integer expression.
template <typename T> const Symbol *GetBoundSymbol(const Expr<T> &);
-template <int KIND>
-const Symbol *GetBoundSymbol(
- const Expr<Type<TypeCategory::Integer, KIND>> &expr) {
- using T = Type<TypeCategory::Integer, KIND>;
+const Symbol *GetBoundSymbol(const Expr<Type<TypeCategory::Integer>> &expr) {
+ using T = Type<TypeCategory::Integer>;
+ int exprKind{expr.GetType() ? expr.GetType()->kind() : 0};
return common::visit(
common::visitors{
[](const Extremum<T> &max) -> const Symbol * {
@@ -1616,12 +1656,11 @@ const Symbol *GetBoundSymbol(
}
return nullptr;
},
- [](const Convert<T, TypeCategory::Integer> &x) {
+ [exprKind](const Convert<T, TypeCategory::Integer> &x) {
return common::visit(
- [](const auto &y) -> const Symbol * {
- using yType = std::decay_t<decltype(y)>;
- using yResult = typename yType::Result;
- if constexpr (yResult::kind <= KIND) {
+ [exprKind](const auto &y) -> const Symbol * {
+ int yKind{y.GetType() ? y.GetType()->kind() : 0};
+ if (yKind <= exprKind) {
return GetBoundSymbol(y);
} else {
return nullptr;
@@ -1728,8 +1767,7 @@ struct ArgumentExtractor
using Base::operator();
- template <int Kind>
- Result operator()(const Constant<Type<Logical, Kind>> &x) const {
+ Result operator()(const Constant<Type<Logical>> &x) const {
if (const auto &val{x.GetScalarValue()}) {
return val->IsTrue()
? std::make_pair(operation::Operator::True, Arguments{})
@@ -1932,14 +1970,17 @@ struct ConvertCollector
return (*this)(x.template operand<0>());
} else if constexpr (is_convert_v<D>) {
// Convert should always have a typed result, so it should be safe to
- // dereference x.GetType().
- return Combine(
- {std::nullopt, {*x.GetType()}}, (*this)(x.template operand<0>()));
+ // dereference its GetType(). Use the derived node's GetType(): a
+ // Convert's result kind is its target kind (carried at runtime in
+ // resultKind_), whereas the base Operation::GetType() would derive the
+ // kind from the (source) operand, which is wrong for a conversion.
+ return Combine({std::nullopt, {*x.derived().GetType()}},
+ (*this)(x.template operand<0>()));
} else if constexpr (is_complex_constructor_v<D>) {
// This is a conversion iff the imaginary operand is 0.
if (IsZero(x.template operand<1>())) {
- return Combine(
- {std::nullopt, {*x.GetType()}}, (*this)(x.template operand<0>()));
+ return Combine({std::nullopt, {*x.derived().GetType()}},
+ (*this)(x.template operand<0>()));
} else {
return {AsSomeExpr(x.derived()), {}};
}
@@ -1989,24 +2030,18 @@ struct ConvertCollector
}
template <typename T> struct is_convert {
- static constexpr bool value{false};
+ // ComplexComponent is a conversion from complex to real.
+ static constexpr bool value{std::is_same_v<T, ComplexComponent>};
};
template <typename T, common::TypeCategory C>
struct is_convert<Convert<T, C>> {
static constexpr bool value{true};
};
- template <int K> struct is_convert<ComplexComponent<K>> {
- // Conversion from complex to real.
- static constexpr bool value{true};
- };
template <typename T>
static constexpr bool is_convert_v{is_convert<T>::value};
template <typename T> struct is_complex_constructor {
- static constexpr bool value{false};
- };
- template <int K> struct is_complex_constructor<ComplexConstructor<K>> {
- static constexpr bool value{true};
+ static constexpr bool value{std::is_same_v<T, ComplexConstructor>};
};
template <typename T>
static constexpr bool is_complex_constructor_v{
diff --git a/flang/lib/Evaluate/type.cpp b/flang/lib/Evaluate/type.cpp
index 988be5673ad05..1a76681d3a7be 100644
--- a/flang/lib/Evaluate/type.cpp
+++ b/flang/lib/Evaluate/type.cpp
@@ -142,10 +142,13 @@ bool DynamicType::operator==(const DynamicType &that) const {
std::optional<Expr<SubscriptInteger>> DynamicType::GetCharLength() const {
if (category_ == TypeCategory::Character) {
if (knownLength()) {
- return AsExpr(Constant<SubscriptInteger>(*knownLength()));
+ return AsExpr(Constant<SubscriptInteger>{
+ SubscriptInteger::Scalar{*knownLength(), subscriptIntegerKind},
+ SubscriptInteger{subscriptIntegerKind}});
} else if (charLengthParamValue_) {
if (auto length{charLengthParamValue_->GetExplicit()}) {
- return ConvertToType<SubscriptInteger>(std::move(*length));
+ return ConvertToType<SubscriptInteger>(
+ subscriptIntegerKind, std::move(*length));
}
}
}
@@ -186,15 +189,24 @@ std::optional<Expr<SubscriptInteger>> DynamicType::MeasureSizeInBytes(
case TypeCategory::Real:
case TypeCategory::Complex:
case TypeCategory::Logical:
- return Expr<SubscriptInteger>{
- context.targetCharacteristics().GetByteSize(category_, kind())};
+ return Expr<SubscriptInteger>{Constant<SubscriptInteger>{
+ SubscriptInteger::Scalar{
+ context.targetCharacteristics().GetByteSize(category_, kind()),
+ subscriptIntegerKind},
+ SubscriptInteger{subscriptIntegerKind}}};
case TypeCategory::Character:
if (auto len{charLength ? Expr<SubscriptInteger>{Constant<SubscriptInteger>{
- *charLength}}
+ SubscriptInteger::Scalar{
+ *charLength, subscriptIntegerKind},
+ SubscriptInteger{subscriptIntegerKind}}}
: GetCharLength()}) {
return Fold(context,
- Expr<SubscriptInteger>{
- context.targetCharacteristics().GetByteSize(category_, kind())} *
+ Expr<SubscriptInteger>{Constant<SubscriptInteger>{
+ SubscriptInteger::Scalar{
+ context.targetCharacteristics().GetByteSize(
+ category_, kind()),
+ subscriptIntegerKind},
+ SubscriptInteger{subscriptIntegerKind}}} *
std::move(*len));
}
break;
@@ -203,8 +215,10 @@ std::optional<Expr<SubscriptInteger>> DynamicType::MeasureSizeInBytes(
auto size{derived_->scope()->size()};
auto align{aligned ? derived_->scope()->alignment().value_or(0) : 0};
auto alignedSize{align > 0 ? ((size + align - 1) / align) * align : size};
- return Expr<SubscriptInteger>{
- static_cast<ConstantSubscript>(alignedSize)};
+ return Expr<SubscriptInteger>{Constant<SubscriptInteger>{
+ SubscriptInteger::Scalar{static_cast<ConstantSubscript>(alignedSize),
+ subscriptIntegerKind},
+ SubscriptInteger{subscriptIntegerKind}}};
}
break;
}
@@ -861,7 +875,7 @@ std::optional<DynamicType> ComparisonType(
case TypeCategory::Logical:
switch (t2.category()) {
case TypeCategory::Logical:
- return DynamicType{TypeCategory::Logical, LogicalResult::kind};
+ return DynamicType{TypeCategory::Logical, logicalResultKind};
default:
return std::nullopt;
}
diff --git a/flang/lib/Evaluate/variable.cpp b/flang/lib/Evaluate/variable.cpp
index b257dad42fc58..1000b7e3ca2b0 100644
--- a/flang/lib/Evaluate/variable.cpp
+++ b/flang/lib/Evaluate/variable.cpp
@@ -24,12 +24,16 @@ namespace Fortran::evaluate {
// Constructors, accessors, mutators
-Triplet::Triplet() : stride_{Expr<SubscriptInteger>{1}} {}
+Triplet::Triplet()
+ : stride_{Expr<SubscriptInteger>{Constant<SubscriptInteger>{
+ SubscriptInteger::Scalar{1, subscriptIntegerKind}}}} {}
Triplet::Triplet(std::optional<Expr<SubscriptInteger>> &&l,
std::optional<Expr<SubscriptInteger>> &&u,
std::optional<Expr<SubscriptInteger>> &&s)
- : stride_{s ? std::move(*s) : Expr<SubscriptInteger>{1}} {
+ : stride_{s ? std::move(*s)
+ : Expr<SubscriptInteger>{Constant<SubscriptInteger>{
+ SubscriptInteger::Scalar{1, subscriptIntegerKind}}}} {
if (l) {
lower_.emplace(std::move(*l));
}
@@ -135,7 +139,8 @@ Expr<SubscriptInteger> Substring::lower() const {
if (lower_) {
return lower_.value().value();
} else {
- return AsExpr(Constant<SubscriptInteger>{1});
+ return AsExpr(Constant<SubscriptInteger>{
+ SubscriptInteger::Scalar{1, subscriptIntegerKind}});
}
}
@@ -153,7 +158,8 @@ std::optional<Expr<SubscriptInteger>> Substring::upper() const {
[](const DataRef &dataRef) { return dataRef.LEN(); },
[](const StaticDataObject::Pointer &object)
-> std::optional<Expr<SubscriptInteger>> {
- return AsExpr(Constant<SubscriptInteger>{object->data().size()});
+ return AsExpr(Constant<SubscriptInteger>{SubscriptInteger::Scalar{
+ object->data().size(), subscriptIntegerKind}});
},
},
parent_);
@@ -178,7 +184,8 @@ std::optional<Expr<SomeCharacter>> Substring::Fold(FoldingContext &context) {
return std::nullopt;
}
if (!lower_) {
- lower_ = AsExpr(Constant<SubscriptInteger>{1});
+ lower_ = AsExpr(Constant<SubscriptInteger>{
+ SubscriptInteger::Scalar{1, subscriptIntegerKind}});
}
lower_.value() = evaluate::Fold(context, std::move(lower_.value().value()));
std::optional<ConstantSubscript> lbi{ToInt64(lower_.value().value())};
@@ -188,16 +195,18 @@ std::optional<Expr<SomeCharacter>> Substring::Fold(FoldingContext &context) {
if (*lbi > *ubi) { // empty result; canonicalize
*lbi = 1;
*ubi = 0;
- lower_ = AsExpr(Constant<SubscriptInteger>{*lbi});
- upper_ = AsExpr(Constant<SubscriptInteger>{*ubi});
+ lower_ = AsExpr(Constant<SubscriptInteger>{
+ SubscriptInteger::Scalar{*lbi, subscriptIntegerKind}});
+ upper_ = AsExpr(Constant<SubscriptInteger>{
+ SubscriptInteger::Scalar{*ubi, subscriptIntegerKind}});
}
std::optional<ConstantSubscript> length;
- std::optional<Expr<SomeCharacter>> strings; // a Constant<Character>
+ std::optional<Expr<SomeCharacter>> strings; // a Constant<CharacterValue>
if (const auto *literal{std::get_if<StaticDataObject::Pointer>(&parent_)}) {
length = (*literal)->data().size();
if (auto str{(*literal)->AsString()}) {
- strings =
- Expr<SomeCharacter>(Expr<Ascii>(Constant<Ascii>{std::move(*str)}));
+ strings = Expr<SomeCharacter>(
+ Expr<Ascii>(Constant<Ascii>{value::CharacterValue{std::move(*str)}}));
}
} else if (const auto *dataRef{std::get_if<DataRef>(&parent_)}) {
if (auto expr{AsGenericExpr(DataRef{*dataRef})}) {
@@ -229,7 +238,8 @@ std::optional<Expr<SomeCharacter>> Substring::Fold(FoldingContext &context) {
"Lower bound (%jd) on substring is less than one"_warn_en_US,
static_cast<std::intmax_t>(*lbi));
*lbi = 1;
- lower_ = AsExpr(Constant<SubscriptInteger>{1});
+ lower_ = AsExpr(Constant<SubscriptInteger>{
+ SubscriptInteger::Scalar{1, subscriptIntegerKind}});
}
if (length && *ubi > *length) {
context.Warn(common::UsageWarning::Bounds,
@@ -237,7 +247,8 @@ std::optional<Expr<SomeCharacter>> Substring::Fold(FoldingContext &context) {
static_cast<std::intmax_t>(*ubi),
static_cast<std::intmax_t>(*length));
*ubi = *length;
- upper_ = AsExpr(Constant<SubscriptInteger>{*ubi});
+ upper_ = AsExpr(Constant<SubscriptInteger>{
+ SubscriptInteger::Scalar{*ubi, subscriptIntegerKind}});
}
}
return result;
@@ -285,11 +296,15 @@ static std::optional<Expr<SubscriptInteger>> SymbolLEN(const Symbol &symbol) {
}
if (len) {
if (auto constLen{ToInt64(*len)}) {
- return Expr<SubscriptInteger>{std::max<std::int64_t>(*constLen, 0)};
+ return Expr<SubscriptInteger>{
+ Constant<SubscriptInteger>{SubscriptInteger::Scalar{
+ std::max<std::int64_t>(*constLen, 0), subscriptIntegerKind}}};
} else if (ultimate.owner().IsDerivedType() ||
IsScopeInvariantExpr(*len)) {
- return AsExpr(Extremum<SubscriptInteger>{
- Ordering::Greater, Expr<SubscriptInteger>{0}, std::move(*len)});
+ return AsExpr(Extremum<SubscriptInteger>{Ordering::Greater,
+ Expr<SubscriptInteger>{Constant<SubscriptInteger>{
+ SubscriptInteger::Scalar{0, subscriptIntegerKind}}},
+ std::move(*len)});
}
}
}
@@ -306,7 +321,8 @@ std::optional<Expr<SubscriptInteger>> BaseObject::LEN() const {
[](const Symbol &symbol) { return SymbolLEN(symbol); },
[](const StaticDataObject::Pointer &object)
-> std::optional<Expr<SubscriptInteger>> {
- return AsExpr(Constant<SubscriptInteger>{object->data().size()});
+ return AsExpr(Constant<SubscriptInteger>{SubscriptInteger::Scalar{
+ object->data().size(), subscriptIntegerKind}});
},
},
u);
@@ -339,8 +355,11 @@ std::optional<Expr<SubscriptInteger>> DataRef::LEN() const {
std::optional<Expr<SubscriptInteger>> Substring::LEN() const {
if (auto top{upper()}) {
return AsExpr(Extremum<SubscriptInteger>{Ordering::Greater,
- AsExpr(Constant<SubscriptInteger>{0}),
- *std::move(top) - lower() + AsExpr(Constant<SubscriptInteger>{1})});
+ AsExpr(Constant<SubscriptInteger>{
+ SubscriptInteger::Scalar{0, subscriptIntegerKind}}),
+ *std::move(top) - lower() +
+ AsExpr(Constant<SubscriptInteger>{
+ SubscriptInteger::Scalar{1, subscriptIntegerKind}})});
} else {
return std::nullopt;
}
@@ -649,21 +668,37 @@ template <typename T> const Symbol *Designator<T>::GetLastSymbol() const {
template <typename T>
std::optional<DynamicType> Designator<T>::GetType() const {
- if constexpr (IsLengthlessIntrinsicType<Result>) {
- return Result::GetType();
- }
if constexpr (Result::category == TypeCategory::Character) {
if (std::holds_alternative<Substring>(u)) {
+ // The character kind is a runtime property carried by the designated
+ // entity rather than a compile-time template parameter.
+ int charKind{asciiKind};
+ if (const Symbol * symbol{GetLastSymbol()}) {
+ if (auto dt{DynamicType::From(*symbol)}) {
+ charKind = dt->kind();
+ }
+ }
if (auto len{LEN()}) {
if (auto n{ToInt64(*len)}) {
- return DynamicType{T::kind, *n};
+ return DynamicType{charKind, *n};
}
}
- return DynamicType{TypeCategory::Character, T::kind};
+ return DynamicType{TypeCategory::Character, charKind};
}
}
if (const Symbol * symbol{GetLastSymbol()}) {
- return DynamicType::From(*symbol);
+ auto type{DynamicType::From(*symbol)};
+ if constexpr (Result::category == TypeCategory::Real) {
+ if (type && std::holds_alternative<ComplexPart>(u)) {
+ // A %RE/%IM part reference designates the REAL component of a COMPLEX
+ // entity, so it has REAL type of the same (runtime) kind. Without
+ // this the kind would be taken from the COMPLEX base symbol but the
+ // category would be wrong, since the kind is no longer fixed by the
+ // template parameter of the Designator's result type.
+ return DynamicType{Result::category, type->kind()};
+ }
+ }
+ return type;
}
return std::nullopt;
}
diff --git a/flang/lib/Lower/Bridge.cpp b/flang/lib/Lower/Bridge.cpp
index 78f9de9c9420e..8bf27ccafd220 100644
--- a/flang/lib/Lower/Bridge.cpp
+++ b/flang/lib/Lower/Bridge.cpp
@@ -6879,8 +6879,7 @@ class FirConverter : public Fortran::lower::AbstractConverter {
return Fortran::common::visit(
[&](const auto &someKind) -> std::string {
using T = std::decay_t<decltype(someKind)>;
- using TK = Fortran::evaluate::Type<T::Result::category,
- T::Result::kind>;
+ using TK = typename T::Result;
if (const auto *constant =
std::get_if<Fortran::evaluate::Constant<TK>>(
&someKind.u)) {
diff --git a/flang/lib/Lower/CallInterface.cpp b/flang/lib/Lower/CallInterface.cpp
index 3fcf314faefb6..a70eb00c6431e 100644
--- a/flang/lib/Lower/CallInterface.cpp
+++ b/flang/lib/Lower/CallInterface.cpp
@@ -362,12 +362,18 @@ static Fortran::evaluate::ExtentExpr
getExtentExpr(const Fortran::semantics::ShapeSpec &shapeSpec) {
if (shapeSpec.ubound().isStar())
// F'2023 18.5.3 point 5.
- return Fortran::evaluate::ExtentExpr{-1};
+ return Fortran::evaluate::ExtentExpr{
+ Fortran::evaluate::Constant<Fortran::evaluate::ExtentType>{
+ Fortran::evaluate::ExtentType::Scalar{
+ -1, Fortran::evaluate::subscriptIntegerKind}}};
const auto &ubound = shapeSpec.ubound().GetExplicit();
const auto &lbound = shapeSpec.lbound().GetExplicit();
assert(lbound && ubound && "shape must be explicit");
return Fortran::common::Clone(*ubound) - Fortran::common::Clone(*lbound) +
- Fortran::evaluate::ExtentExpr{1};
+ Fortran::evaluate::ExtentExpr{
+ Fortran::evaluate::Constant<Fortran::evaluate::ExtentType>{
+ Fortran::evaluate::ExtentType::Scalar{
+ 1, Fortran::evaluate::subscriptIntegerKind}}};
}
static void
diff --git a/flang/lib/Lower/ConvertArrayConstructor.cpp b/flang/lib/Lower/ConvertArrayConstructor.cpp
index 69bcd20f7f1b6..6c0d9145306db 100644
--- a/flang/lib/Lower/ConvertArrayConstructor.cpp
+++ b/flang/lib/Lower/ConvertArrayConstructor.cpp
@@ -504,15 +504,15 @@ namespace {
/// evaluating an ac-value.
template <typename T>
struct LengthAndTypeCollector {
- static mlir::Type collect(mlir::Location,
- Fortran::lower::AbstractConverter &converter,
- const Fortran::evaluate::ArrayConstructor<T> &,
- Fortran::lower::SymMap &,
- Fortran::lower::StatementContext &,
- mlir::SmallVectorImpl<mlir::Value> &) {
+ static mlir::Type
+ collect(mlir::Location, Fortran::lower::AbstractConverter &converter,
+ const Fortran::evaluate::ArrayConstructor<T> &arrayCtorExpr,
+ Fortran::lower::SymMap &, Fortran::lower::StatementContext &,
+ mlir::SmallVectorImpl<mlir::Value> &) {
// Numerical and Logical types.
return Fortran::lower::getFIRType(&converter.getMLIRContext(), T::category,
- T::kind, /*lenParams*/ {});
+ arrayCtorExpr.GetType().kind(),
+ /*lenParams*/ {});
}
};
@@ -531,16 +531,16 @@ struct LengthAndTypeCollector<Fortran::evaluate::SomeDerived> {
}
};
-template <int Kind>
using Character =
- Fortran::evaluate::Type<Fortran::common::TypeCategory::Character, Kind>;
-template <int Kind>
-struct LengthAndTypeCollector<Character<Kind>> {
- static mlir::Type collect(
- mlir::Location loc, Fortran::lower::AbstractConverter &converter,
- const Fortran::evaluate::ArrayConstructor<Character<Kind>> &arrayCtorExpr,
- Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx,
- mlir::SmallVectorImpl<mlir::Value> &lengths) {
+ Fortran::evaluate::Type<Fortran::common::TypeCategory::Character>;
+template <>
+struct LengthAndTypeCollector<Character> {
+ static mlir::Type
+ collect(mlir::Location loc, Fortran::lower::AbstractConverter &converter,
+ const Fortran::evaluate::ArrayConstructor<Character> &arrayCtorExpr,
+ Fortran::lower::SymMap &symMap,
+ Fortran::lower::StatementContext &stmtCtx,
+ mlir::SmallVectorImpl<mlir::Value> &lengths) {
llvm::SmallVector<Fortran::lower::LenParameterTy> typeLengths;
if (const Fortran::evaluate::ExtentExpr *lenExpr = arrayCtorExpr.LEN()) {
lengths.push_back(
@@ -549,9 +549,9 @@ struct LengthAndTypeCollector<Character<Kind>> {
Fortran::evaluate::ToInt64(*lenExpr))
typeLengths.push_back(*cstLen);
}
- return Fortran::lower::getFIRType(&converter.getMLIRContext(),
- Fortran::common::TypeCategory::Character,
- Kind, typeLengths);
+ return Fortran::lower::getFIRType(
+ &converter.getMLIRContext(), Fortran::common::TypeCategory::Character,
+ arrayCtorExpr.GetType().kind(), typeLengths);
}
};
} // namespace
diff --git a/flang/lib/Lower/ConvertConstant.cpp b/flang/lib/Lower/ConvertConstant.cpp
index ca24965c51668..7e4e3519a99cb 100644
--- a/flang/lib/Lower/ConvertConstant.cpp
+++ b/flang/lib/Lower/ConvertConstant.cpp
@@ -11,6 +11,8 @@
//===----------------------------------------------------------------------===//
#include "flang/Lower/ConvertConstant.h"
+// #include "flang/Evaluate/char-storage-access.h"
+#include "flang/Evaluate/character-value-impl.h"
#include "flang/Evaluate/expression.h"
#include "flang/Lower/AbstractConverter.h"
#include "flang/Lower/BuiltinModules.h"
@@ -48,18 +50,18 @@ static llvm::APFloat consAPFloat(const llvm::fltSemantics &fsem,
//===----------------------------------------------------------------------===//
/// Generate an mlir attribute from a literal value
-template <Fortran::common::TypeCategory TC, int KIND>
+template <Fortran::common::TypeCategory TC>
static mlir::Attribute convertToAttribute(
fir::FirOpBuilder &builder,
- const Fortran::evaluate::Scalar<Fortran::evaluate::Type<TC, KIND>> &value,
+ const Fortran::evaluate::Scalar<Fortran::evaluate::Type<TC>> &value,
mlir::Type type) {
if constexpr (TC == Fortran::common::TypeCategory::Integer) {
- if constexpr (KIND <= 8)
+ if (value.kind() <= 8)
return builder.getIntegerAttr(type, value.ToInt64());
else {
- static_assert(KIND <= 16, "integers with KIND > 16 are not supported");
+ assert(value.kind() <= 16 && "integers with KIND > 16 are not supported");
return builder.getIntegerAttr(
- type, llvm::APInt(KIND * 8,
+ type, llvm::APInt(value.kind() * 8,
{value.ToUInt64(), value.SHIFTR(64).ToUInt64()}));
}
} else if constexpr (TC == Fortran::common::TypeCategory::Logical) {
@@ -70,8 +72,8 @@ static mlir::Attribute convertToAttribute(
} else {
auto getFloatAttr = [&](const auto &value, mlir::Type type) {
std::string str = value.DumpHexadecimal();
- auto floatVal =
- consAPFloat(builder.getKindMap().getFloatSemantics(KIND), str);
+ auto floatVal = consAPFloat(
+ builder.getKindMap().getFloatSemantics(value.kind()), str);
return builder.getFloatAttr(type, floatVal);
};
@@ -126,12 +128,11 @@ class DenseGlobalBuilder {
setDefaultAlignment);
}
- template <Fortran::common::TypeCategory TC, int KIND>
+ template <Fortran::common::TypeCategory TC>
static fir::GlobalOp tryCreating(
fir::FirOpBuilder &builder, mlir::Location loc, mlir::Type symTy,
llvm::StringRef globalName, mlir::StringAttr linkage, bool isConst,
- const Fortran::evaluate::Constant<Fortran::evaluate::Type<TC, KIND>>
- &constant,
+ const Fortran::evaluate::Constant<Fortran::evaluate::Type<TC>> &constant,
cuf::DataAttributeAttr dataAttr, bool setDefaultAlignment = true) {
DenseGlobalBuilder globalBuilder;
globalBuilder.tryConvertingToAttributes(builder, constant);
@@ -144,21 +145,21 @@ class DenseGlobalBuilder {
DenseGlobalBuilder() = default;
/// Try converting an evaluate::Constant to a list of MLIR attributes.
- template <Fortran::common::TypeCategory TC, int KIND>
+ template <Fortran::common::TypeCategory TC>
void tryConvertingToAttributes(
fir::FirOpBuilder &builder,
- const Fortran::evaluate::Constant<Fortran::evaluate::Type<TC, KIND>>
+ const Fortran::evaluate::Constant<Fortran::evaluate::Type<TC>>
&constant) {
- using Element =
- Fortran::evaluate::Scalar<Fortran::evaluate::Type<TC, KIND>>;
+ using Element = Fortran::evaluate::Scalar<Fortran::evaluate::Type<TC>>;
static_assert(TC != Fortran::common::TypeCategory::Character,
"must be numerical or logical");
+ int kind = constant.GetType().kind();
auto attrTc = TC == Fortran::common::TypeCategory::Logical
? Fortran::common::TypeCategory::Integer
: TC;
attributeElementType =
- Fortran::lower::getFIRType(builder.getContext(), attrTc, KIND, {});
+ Fortran::lower::getFIRType(builder.getContext(), attrTc, kind, {});
const std::vector<Element> &values = constant.values();
auto sameElements = [&]() -> bool {
@@ -170,15 +171,15 @@ class DenseGlobalBuilder {
};
if (sameElements()) {
- auto attr = convertToAttribute<TC, KIND>(builder, values.front(),
- attributeElementType);
+ auto attr =
+ convertToAttribute<TC>(builder, values.front(), attributeElementType);
attributes.assign(values.size(), attr);
return;
}
for (auto element : values)
attributes.push_back(
- convertToAttribute<TC, KIND>(builder, element, attributeElementType));
+ convertToAttribute<TC>(builder, element, attributeElementType));
}
/// Try converting an evaluate::Expr to a list of MLIR attributes.
@@ -190,8 +191,7 @@ class DenseGlobalBuilder {
using TR = Fortran::evaluate::ResultType<decltype(x)>;
if (const auto *constant =
std::get_if<Fortran::evaluate::Constant<TR>>(&x.u))
- tryConvertingToAttributes<TR::category, TR::kind>(builder,
- *constant);
+ tryConvertingToAttributes<TR::category>(builder, *constant);
},
expr.u);
}
@@ -241,25 +241,25 @@ fir::GlobalOp Fortran::lower::tryCreatingDenseGlobal(
//===----------------------------------------------------------------------===//
/// Generate a real constant with a value `value`.
-template <int KIND>
static mlir::Value genRealConstant(fir::FirOpBuilder &builder,
mlir::Location loc,
- const llvm::APFloat &value) {
- mlir::Type fltTy = Fortran::lower::convertReal(builder.getContext(), KIND);
+ const llvm::APFloat &value, int kind) {
+ mlir::Type fltTy = Fortran::lower::convertReal(builder.getContext(), kind);
return builder.createRealConstant(loc, fltTy, value);
}
/// Convert a scalar literal constant to IR.
-template <Fortran::common::TypeCategory TC, int KIND>
+template <Fortran::common::TypeCategory TC>
static mlir::Value genScalarLit(
fir::FirOpBuilder &builder, mlir::Location loc,
- const Fortran::evaluate::Scalar<Fortran::evaluate::Type<TC, KIND>> &value) {
+ const Fortran::evaluate::Scalar<Fortran::evaluate::Type<TC>> &value) {
if constexpr (TC == Fortran::common::TypeCategory::Integer ||
TC == Fortran::common::TypeCategory::Unsigned) {
+ int kind = value.kind();
// MLIR requires constants to be signless
mlir::Type ty = Fortran::lower::getFIRType(
- builder.getContext(), Fortran::common::TypeCategory::Integer, KIND, {});
- if (KIND == 16) {
+ builder.getContext(), Fortran::common::TypeCategory::Integer, kind, {});
+ if (kind == 16) {
auto bigInt = llvm::APInt(ty.getIntOrFloatBitWidth(),
TC == Fortran::common::TypeCategory::Unsigned
? value.UnsignedDecimal()
@@ -270,41 +270,50 @@ static mlir::Value genScalarLit(
}
return builder.createIntegerConstant(loc, ty, value.ToInt64());
} else if constexpr (TC == Fortran::common::TypeCategory::Logical) {
+ int kind = value.kind();
if (value.IsCanonical())
return builder.createBool(loc, value.IsTrue());
mlir::Type logicalType = Fortran::lower::getFIRType(
- builder.getContext(), Fortran::common::TypeCategory::Logical, KIND, {});
+ builder.getContext(), Fortran::common::TypeCategory::Logical, kind, {});
mlir::Type intType = Fortran::lower::getFIRType(
- builder.getContext(), Fortran::common::TypeCategory::Integer, KIND, {});
+ builder.getContext(), Fortran::common::TypeCategory::Integer, kind, {});
mlir::Value integer =
builder.createIntegerConstant(loc, intType, value.word().ToInt64());
return fir::BitcastOp::create(builder, loc, logicalType, integer);
} else if constexpr (TC == Fortran::common::TypeCategory::Real) {
+ int kind = value.kind();
std::string str = value.DumpHexadecimal();
- if constexpr (KIND == 2) {
+ switch (kind) {
+ case 2: {
auto floatVal = consAPFloat(llvm::APFloatBase::IEEEhalf(), str);
- return genRealConstant<KIND>(builder, loc, floatVal);
- } else if constexpr (KIND == 3) {
+ return genRealConstant(builder, loc, floatVal, kind);
+ }
+ case 3: {
auto floatVal = consAPFloat(llvm::APFloatBase::BFloat(), str);
- return genRealConstant<KIND>(builder, loc, floatVal);
- } else if constexpr (KIND == 4) {
+ return genRealConstant(builder, loc, floatVal, kind);
+ }
+ case 4: {
auto floatVal = consAPFloat(llvm::APFloatBase::IEEEsingle(), str);
- return genRealConstant<KIND>(builder, loc, floatVal);
- } else if constexpr (KIND == 10) {
+ return genRealConstant(builder, loc, floatVal, kind);
+ }
+ case 10: {
auto floatVal = consAPFloat(llvm::APFloatBase::x87DoubleExtended(), str);
- return genRealConstant<KIND>(builder, loc, floatVal);
- } else if constexpr (KIND == 16) {
+ return genRealConstant(builder, loc, floatVal, kind);
+ }
+ case 16: {
auto floatVal = consAPFloat(llvm::APFloatBase::IEEEquad(), str);
- return genRealConstant<KIND>(builder, loc, floatVal);
- } else {
+ return genRealConstant(builder, loc, floatVal, kind);
+ }
+ default: {
// convert everything else to double
auto floatVal = consAPFloat(llvm::APFloatBase::IEEEdouble(), str);
- return genRealConstant<KIND>(builder, loc, floatVal);
+ return genRealConstant(builder, loc, floatVal, kind);
+ }
}
} else if constexpr (TC == Fortran::common::TypeCategory::Complex) {
- mlir::Value real = genScalarLit<Fortran::common::TypeCategory::Real, KIND>(
+ mlir::Value real = genScalarLit<Fortran::common::TypeCategory::Real>(
builder, loc, value.REAL());
- mlir::Value imag = genScalarLit<Fortran::common::TypeCategory::Real, KIND>(
+ mlir::Value imag = genScalarLit<Fortran::common::TypeCategory::Real>(
builder, loc, value.AIMAG());
return fir::factory::Complex{builder, loc}.createComplex(real, imag);
} else /*constexpr*/ {
@@ -313,75 +322,105 @@ static mlir::Value genScalarLit(
}
/// Create fir::string_lit from a scalar character constant.
-template <int KIND>
static fir::StringLitOp
createStringLitOp(fir::FirOpBuilder &builder, mlir::Location loc,
const Fortran::evaluate::Scalar<Fortran::evaluate::Type<
- Fortran::common::TypeCategory::Character, KIND>> &value,
+ Fortran::common::TypeCategory::Character>> &value,
[[maybe_unused]] int64_t len) {
- if constexpr (KIND == 1) {
- assert(value.size() == static_cast<std::uint64_t>(len));
- return builder.createStringLitOp(loc, value);
- } else {
- using ET = typename std::decay_t<decltype(value)>::value_type;
- fir::CharacterType type =
- fir::CharacterType::get(builder.getContext(), KIND, len);
- mlir::MLIRContext *context = builder.getContext();
- std::int64_t size = static_cast<std::int64_t>(value.size());
- mlir::ShapedType shape = mlir::RankedTensorType::get(
- llvm::ArrayRef<std::int64_t>{size},
- mlir::IntegerType::get(builder.getContext(), sizeof(ET) * 8));
- auto denseAttr = mlir::DenseElementsAttr::get(
- shape, llvm::ArrayRef<ET>{value.data(), value.size()});
- auto denseTag = mlir::StringAttr::get(context, fir::StringLitOp::xlist());
- mlir::NamedAttribute dataAttr(denseTag, denseAttr);
- auto sizeTag = mlir::StringAttr::get(context, fir::StringLitOp::size());
- mlir::NamedAttribute sizeAttr(sizeTag, builder.getI64IntegerAttr(len));
- llvm::SmallVector<mlir::NamedAttribute> attrs = {dataAttr, sizeAttr};
- return fir::StringLitOp::create(builder, loc,
- llvm::ArrayRef<mlir::Type>{type},
- mlir::ValueRange{}, attrs);
+ int kind = value.kind();
+#if 0
+ if (kind == 1) {
+ const std::string &rawStr = std::get<std::string>(GetCharacterStorage(value));
+ assert(rawStr.size() == static_cast<std::uint64_t>(len));
+ return builder.createStringLitOp(loc, rawStr);
}
+#endif
+ return value.value().WithChar([&](const auto &rawStr) -> fir::StringLitOp {
+ using RawStr = std::decay_t<decltype(rawStr)>;
+ if constexpr (std::is_same_v<RawStr, std::monostate>) {
+ llvm_unreachable("unexpected character storage");
+ } else if constexpr (std::is_same_v<RawStr, std::string>) {
+ assert(rawStr.size() == static_cast<std::uint64_t>(len));
+ return builder.createStringLitOp(loc, rawStr);
+ } else {
+ using ET = typename RawStr::value_type;
+ fir::CharacterType type =
+ fir::CharacterType::get(builder.getContext(), kind, len);
+ mlir::MLIRContext *context = builder.getContext();
+ std::int64_t size = static_cast<std::int64_t>(rawStr.size());
+ mlir::ShapedType shape = mlir::RankedTensorType::get(
+ llvm::ArrayRef<std::int64_t>{size},
+ mlir::IntegerType::get(builder.getContext(), sizeof(ET) * 8));
+ auto denseAttr = mlir::DenseElementsAttr::get(
+ shape, llvm::ArrayRef<ET>{rawStr.data(), rawStr.size()});
+ auto denseTag = mlir::StringAttr::get(context, fir::StringLitOp::xlist());
+ mlir::NamedAttribute dataAttr(denseTag, denseAttr);
+ auto sizeTag = mlir::StringAttr::get(context, fir::StringLitOp::size());
+ mlir::NamedAttribute sizeAttr(sizeTag, builder.getI64IntegerAttr(len));
+ llvm::SmallVector<mlir::NamedAttribute> attrs = {dataAttr, sizeAttr};
+ return fir::StringLitOp::create(builder, loc,
+ llvm::ArrayRef<mlir::Type>{type},
+ mlir::ValueRange{}, attrs);
+ }
+ });
}
/// Convert a scalar literal CHARACTER to IR.
-template <int KIND>
static mlir::Value
genScalarLit(fir::FirOpBuilder &builder, mlir::Location loc,
const Fortran::evaluate::Scalar<Fortran::evaluate::Type<
- Fortran::common::TypeCategory::Character, KIND>> &value,
+ Fortran::common::TypeCategory::Character>> &value,
int64_t len, bool outlineInReadOnlyMemory) {
+ int kind = value.kind();
// When in an initializer context, construct the literal op itself and do
// not construct another constant object in rodata.
if (!outlineInReadOnlyMemory)
- return createStringLitOp<KIND>(builder, loc, value, len);
+ return createStringLitOp(builder, loc, value, len);
- // Otherwise, the string is in a plain old expression so "outline" the value
- // in read only data by hash consing it to a constant literal object.
+ // Otherwise, the string is in a plain old expression so "outline" the value
+ // in read only data by hash consing it to a constant literal object.
+#if 0
// ASCII global constants are created using an mlir string attribute.
- if constexpr (KIND == 1) {
- return fir::getBase(fir::factory::createStringLiteral(builder, loc, value));
+ if (kind == 1) {
+ const std::string &rawStr2 = std::get<std::string>(GetCharacterStorage(value));
+ return fir::getBase(
+ fir::factory::createStringLiteral(builder, loc, rawStr2));
}
-
- auto size = builder.getKindMap().getCharacterBitsize(KIND) / 8 * value.size();
- llvm::StringRef strVal(reinterpret_cast<const char *>(value.c_str()), size);
- std::string globalName = fir::factory::uniqueCGIdent(
- KIND == 1 ? "cl"s : "cl"s + std::to_string(KIND), strVal);
- fir::GlobalOp global = builder.getNamedGlobal(globalName);
- fir::CharacterType type =
- fir::CharacterType::get(builder.getContext(), KIND, len);
- if (!global)
- global = builder.createGlobalConstant(
- loc, type, globalName,
- [&](fir::FirOpBuilder &builder) {
- fir::StringLitOp str =
- createStringLitOp<KIND>(builder, loc, value, len);
- fir::HasValueOp::create(builder, loc, str);
- },
- builder.createLinkOnceLinkage());
- return fir::AddrOfOp::create(builder, loc, global.resultType(),
- global.getSymbol());
+#endif
+
+ return value.value().WithChar([&](const auto &rawStr2) -> mlir::Value {
+ using RawStr2 = std::decay_t<decltype(rawStr2)>;
+ if constexpr (std::is_same_v<RawStr2, std::monostate>) {
+ llvm_unreachable("unexpected character storage");
+ } else if constexpr (std::is_same_v<RawStr2, std::string>) {
+ // const std::string &rawStr2 =
+ // std::get<std::string>(GetCharacterStorage(value));
+ return fir::getBase(
+ fir::factory::createStringLiteral(builder, loc, rawStr2));
+ } else {
+ auto size =
+ builder.getKindMap().getCharacterBitsize(kind) / 8 * rawStr2.size();
+ llvm::StringRef strVal(reinterpret_cast<const char *>(rawStr2.data()),
+ size);
+ std::string globalName =
+ fir::factory::uniqueCGIdent("cl"s + std::to_string(kind), strVal);
+ fir::GlobalOp global = builder.getNamedGlobal(globalName);
+ fir::CharacterType type =
+ fir::CharacterType::get(builder.getContext(), kind, len);
+ if (!global)
+ global = builder.createGlobalConstant(
+ loc, type, globalName,
+ [&](fir::FirOpBuilder &builder) {
+ fir::StringLitOp str =
+ createStringLitOp(builder, loc, value, len);
+ fir::HasValueOp::create(builder, loc, str);
+ },
+ builder.createLinkOnceLinkage());
+ return fir::AddrOfOp::create(builder, loc, global.resultType(),
+ global.getSymbol());
+ }
+ });
}
// Helper to generate StructureConstructor component values.
@@ -629,8 +668,8 @@ genInlinedArrayLit(Fortran::lower::AbstractConverter &converter,
if constexpr (T::category == Fortran::common::TypeCategory::Character) {
do {
mlir::Value elementVal =
- genScalarLit<T::kind>(builder, loc, con.At(subscripts), con.LEN(),
- /*outlineInReadOnlyMemory=*/false);
+ genScalarLit(builder, loc, con.At(subscripts), con.LEN(),
+ /*outlineInReadOnlyMemory=*/false);
array =
fir::InsertValueOp::create(builder, loc, arrayTy, array, elementVal,
builder.getArrayAttr(createIdx()));
@@ -652,9 +691,9 @@ genInlinedArrayLit(Fortran::lower::AbstractConverter &converter,
mlir::Type eleTy = mlir::cast<fir::SequenceType>(arrayTy).getElementType();
do {
auto getElementVal = [&]() {
- return builder.createConvert(loc, eleTy,
- genScalarLit<T::category, T::kind>(
- builder, loc, con.At(subscripts)));
+ return builder.createConvert(
+ loc, eleTy,
+ genScalarLit<T::category>(builder, loc, con.At(subscripts)));
};
Fortran::evaluate::ConstantSubscripts nextSubscripts = subscripts;
bool nextIsSame = con.IncrementSubscripts(nextSubscripts) &&
@@ -758,7 +797,7 @@ genArrayLit(Fortran::lower::AbstractConverter &converter, mlir::Location loc,
converter, con.GetType().GetDerivedTypeSpec());
else
eleTy = Fortran::lower::getFIRType(builder.getContext(), T::category,
- T::kind, typeParams);
+ con.GetType().kind(), typeParams);
auto arrayTy = fir::SequenceType::get(shape, eleTy);
mlir::Value array = outlineInReadOnlyMemory
? genOutlineArrayLit(converter, loc, arrayTy, con)
@@ -794,8 +833,7 @@ fir::ExtendedValue Fortran::lower::ConstantBuilder<T>::gen(
assert(opt.has_value() && "constant has no value");
if constexpr (T::category == Fortran::common::TypeCategory::Character) {
fir::FirOpBuilder &builder = converter.getFirOpBuilder();
- auto value =
- genScalarLit<T::kind>(builder, loc, opt.value(), constant.LEN(),
+ auto value = genScalarLit(builder, loc, opt.value(), constant.LEN(),
outlineBigConstantsInReadOnlyMemory);
mlir::Value len = builder.createIntegerConstant(
loc, builder.getCharacterLengthType(), constant.LEN());
@@ -806,8 +844,8 @@ fir::ExtendedValue Fortran::lower::ConstantBuilder<T>::gen(
return genScalarLit(converter, loc, *opt, eleTy,
outlineBigConstantsInReadOnlyMemory);
} else {
- return genScalarLit<T::category, T::kind>(converter.getFirOpBuilder(), loc,
- opt.value());
+ return genScalarLit<T::category>(converter.getFirOpBuilder(), loc,
+ opt.value());
}
}
@@ -828,12 +866,11 @@ genConstantValue(Fortran::lower::AbstractConverter &converter,
fir::emitFatalError(loc, "not a constant derived type expression");
}
-template <Fortran::common::TypeCategory TC, int KIND>
+template <Fortran::common::TypeCategory TC>
static fir::ExtendedValue genConstantValue(
Fortran::lower::AbstractConverter &converter, mlir::Location loc,
- const Fortran::evaluate::Expr<Fortran::evaluate::Type<TC, KIND>>
- &constantExpr) {
- using T = Fortran::evaluate::Type<TC, KIND>;
+ const Fortran::evaluate::Expr<Fortran::evaluate::Type<TC>> &constantExpr) {
+ using T = Fortran::evaluate::Type<TC>;
if (const auto *constant =
std::get_if<Fortran::evaluate::Constant<T>>(&constantExpr.u))
return Fortran::lower::convertConstant(converter, loc, *constant,
diff --git a/flang/lib/Lower/ConvertExpr.cpp b/flang/lib/Lower/ConvertExpr.cpp
index 32cd710e9b5b4..5ef79230a231a 100644
--- a/flang/lib/Lower/ConvertExpr.cpp
+++ b/flang/lib/Lower/ConvertExpr.cpp
@@ -13,7 +13,7 @@
#include "flang/Lower/ConvertExpr.h"
#include "flang/Common/unwrap.h"
#include "flang/Evaluate/fold.h"
-#include "flang/Evaluate/real.h"
+#include "flang/Evaluate/real-value.h"
#include "flang/Evaluate/traverse.h"
#include "flang/Lower/Allocatable.h"
#include "flang/Lower/Bridge.h"
@@ -788,11 +788,10 @@ class ScalarExprLowering {
}
/// Generate an integral constant of `value`
- template <int KIND>
- mlir::Value genIntegerConstant(mlir::MLIRContext *context,
+ mlir::Value genIntegerConstant(mlir::MLIRContext *context, int kind,
std::int64_t value) {
mlir::Type type =
- converter.genType(Fortran::common::TypeCategory::Integer, KIND);
+ converter.genType(Fortran::common::TypeCategory::Integer, kind);
return builder.createIntegerConstant(getLoc(), type, value);
}
@@ -1041,7 +1040,10 @@ class ScalarExprLowering {
auto castResult = [&](mlir::Value v) {
using ResTy = Fortran::evaluate::DescriptorInquiry::Result;
return builder.createConvert(
- loc, converter.genType(ResTy::category, ResTy::kind), v);
+ loc,
+ converter.genType(ResTy::category,
+ Fortran::evaluate::subscriptIntegerKind),
+ v);
};
switch (desc.field()) {
case Fortran::evaluate::DescriptorInquiry::Field::Len:
@@ -1071,39 +1073,39 @@ class ScalarExprLowering {
cplx, isImagPart);
}
- template <int KIND>
- ExtValue genval(const Fortran::evaluate::ComplexComponent<KIND> &part) {
+ ExtValue genval(const Fortran::evaluate::ComplexComponent &part) {
return extractComplexPart(genunbox(part.left()), part.isImaginaryPart);
}
- template <int KIND>
- ExtValue genval(const Fortran::evaluate::Negate<Fortran::evaluate::Type<
- Fortran::common::TypeCategory::Integer, KIND>> &op) {
+ ExtValue
+ genval(const Fortran::evaluate::Negate<
+ Fortran::evaluate::Type<Fortran::common::TypeCategory::Integer>> &op) {
mlir::Value input = genunbox(op.left());
// Like LLVM, integer negation is the binary op "0 - value"
- mlir::Value zero = genIntegerConstant<KIND>(builder.getContext(), 0);
+ mlir::Value zero = genIntegerConstant(builder.getContext(),
+ op.GetType().value().kind(), 0);
return mlir::arith::SubIOp::create(builder, getLoc(), zero, input);
}
- template <int KIND>
ExtValue genval(const Fortran::evaluate::Negate<Fortran::evaluate::Type<
- Fortran::common::TypeCategory::Unsigned, KIND>> &op) {
+ Fortran::common::TypeCategory::Unsigned>> &op) {
auto loc = getLoc();
+ int kind = op.GetType().value().kind();
mlir::Type signlessType =
- converter.genType(Fortran::common::TypeCategory::Integer, KIND);
+ converter.genType(Fortran::common::TypeCategory::Integer, kind);
mlir::Value input = genunbox(op.left());
mlir::Value signless = builder.createConvert(loc, signlessType, input);
- mlir::Value zero = genIntegerConstant<KIND>(builder.getContext(), 0);
+ mlir::Value zero = genIntegerConstant(builder.getContext(), kind, 0);
mlir::Value neg = mlir::arith::SubIOp::create(builder, loc, zero, signless);
return builder.createConvert(loc, input.getType(), neg);
}
- template <int KIND>
- ExtValue genval(const Fortran::evaluate::Negate<Fortran::evaluate::Type<
- Fortran::common::TypeCategory::Real, KIND>> &op) {
+ ExtValue
+ genval(const Fortran::evaluate::Negate<
+ Fortran::evaluate::Type<Fortran::common::TypeCategory::Real>> &op) {
return mlir::arith::NegFOp::create(builder, getLoc(), genunbox(op.left()));
}
- template <int KIND>
- ExtValue genval(const Fortran::evaluate::Negate<Fortran::evaluate::Type<
- Fortran::common::TypeCategory::Complex, KIND>> &op) {
+ ExtValue
+ genval(const Fortran::evaluate::Negate<
+ Fortran::evaluate::Type<Fortran::common::TypeCategory::Complex>> &op) {
return fir::NegcOp::create(builder, getLoc(), genunbox(op.left()));
}
@@ -1124,9 +1126,8 @@ class ScalarExprLowering {
#undef GENBIN
#define GENBIN(GenBinEvOp, GenBinTyCat, GenBinFirOp) \
- template <int KIND> \
ExtValue genval(const Fortran::evaluate::GenBinEvOp<Fortran::evaluate::Type< \
- Fortran::common::TypeCategory::GenBinTyCat, KIND>> &x) { \
+ Fortran::common::TypeCategory::GenBinTyCat>> &x) { \
return createBinaryOp<GenBinFirOp>(x); \
}
@@ -1146,44 +1147,42 @@ class ScalarExprLowering {
GENBIN(Divide, Unsigned, mlir::arith::DivUIOp)
GENBIN(Divide, Real, mlir::arith::DivFOp)
- template <int KIND>
- ExtValue genval(const Fortran::evaluate::Divide<Fortran::evaluate::Type<
- Fortran::common::TypeCategory::Complex, KIND>> &op) {
- mlir::Type ty =
- converter.genType(Fortran::common::TypeCategory::Complex, KIND);
+ ExtValue
+ genval(const Fortran::evaluate::Divide<
+ Fortran::evaluate::Type<Fortran::common::TypeCategory::Complex>> &op) {
+ mlir::Type ty = converter.genType(Fortran::common::TypeCategory::Complex,
+ op.GetType().value().kind());
mlir::Value lhs = genunbox(op.left());
mlir::Value rhs = genunbox(op.right());
return fir::genDivC(builder, getLoc(), ty, lhs, rhs);
}
- template <Fortran::common::TypeCategory TC, int KIND>
- ExtValue genval(
- const Fortran::evaluate::Power<Fortran::evaluate::Type<TC, KIND>> &op) {
- mlir::Type ty = converter.genType(TC, KIND);
+ template <Fortran::common::TypeCategory TC>
+ ExtValue
+ genval(const Fortran::evaluate::Power<Fortran::evaluate::Type<TC>> &op) {
+ mlir::Type ty = converter.genType(TC, op.GetType().value().kind());
mlir::Value lhs = genunbox(op.left());
mlir::Value rhs = genunbox(op.right());
return fir::genPow(builder, getLoc(), ty, lhs, rhs);
}
- template <Fortran::common::TypeCategory TC, int KIND>
- ExtValue genval(
- const Fortran::evaluate::RealToIntPower<Fortran::evaluate::Type<TC, KIND>>
- &op) {
- mlir::Type ty = converter.genType(TC, KIND);
+ template <Fortran::common::TypeCategory TC>
+ ExtValue
+ genval(const Fortran::evaluate::RealToIntPower<Fortran::evaluate::Type<TC>>
+ &op) {
+ mlir::Type ty = converter.genType(TC, op.GetType().value().kind());
mlir::Value lhs = genunbox(op.left());
mlir::Value rhs = genunbox(op.right());
return fir::genPow(builder, getLoc(), ty, lhs, rhs);
}
- template <int KIND>
- ExtValue genval(const Fortran::evaluate::ComplexConstructor<KIND> &op) {
+ ExtValue genval(const Fortran::evaluate::ComplexConstructor &op) {
mlir::Value realPartValue = genunbox(op.left());
return fir::factory::Complex{builder, getLoc()}.createComplex(
realPartValue, genunbox(op.right()));
}
- template <int KIND>
- ExtValue genval(const Fortran::evaluate::Concat<KIND> &op) {
+ ExtValue genval(const Fortran::evaluate::Concat &op) {
ExtValue lhs = genval(op.left());
ExtValue rhs = genval(op.right());
const fir::CharBoxValue *lhsChar = lhs.getCharBox();
@@ -1195,10 +1194,9 @@ class ScalarExprLowering {
}
/// MIN and MAX operations
- template <Fortran::common::TypeCategory TC, int KIND>
+ template <Fortran::common::TypeCategory TC>
ExtValue
- genval(const Fortran::evaluate::Extremum<Fortran::evaluate::Type<TC, KIND>>
- &op) {
+ genval(const Fortran::evaluate::Extremum<Fortran::evaluate::Type<TC>> &op) {
mlir::Value lhs = genunbox(op.left());
mlir::Value rhs = genunbox(op.right());
switch (op.ordering) {
@@ -1238,8 +1236,7 @@ class ScalarExprLowering {
return fir::CharBoxValue{charAddr, newLenValue};
}
- template <int KIND>
- ExtValue genval(const Fortran::evaluate::SetLength<KIND> &x) {
+ ExtValue genval(const Fortran::evaluate::SetLength &x) {
mlir::Value newLenValue = genunbox(x.right());
fir::ExtendedValue lhs = gen(x.left());
fir::factory::CharacterExprHelper charHelper(builder, getLoc());
@@ -1249,32 +1246,31 @@ class ScalarExprLowering {
return fir::ExtendedValue{temp};
}
- template <int KIND>
- ExtValue genval(const Fortran::evaluate::Relational<Fortran::evaluate::Type<
- Fortran::common::TypeCategory::Integer, KIND>> &op) {
+ ExtValue
+ genval(const Fortran::evaluate::Relational<
+ Fortran::evaluate::Type<Fortran::common::TypeCategory::Integer>> &op) {
return createCompareOp<mlir::arith::CmpIOp>(
op, translateSignedRelational(op.opr));
}
- template <int KIND>
ExtValue genval(const Fortran::evaluate::Relational<Fortran::evaluate::Type<
- Fortran::common::TypeCategory::Unsigned, KIND>> &op) {
+ Fortran::common::TypeCategory::Unsigned>> &op) {
return createCompareOp<mlir::arith::CmpIOp>(
- op, translateUnsignedRelational(op.opr), KIND);
+ op, translateUnsignedRelational(op.opr),
+ op.left().GetType().value().kind());
}
- template <int KIND>
- ExtValue genval(const Fortran::evaluate::Relational<Fortran::evaluate::Type<
- Fortran::common::TypeCategory::Real, KIND>> &op) {
+ ExtValue
+ genval(const Fortran::evaluate::Relational<
+ Fortran::evaluate::Type<Fortran::common::TypeCategory::Real>> &op) {
return createFltCmpOp<mlir::arith::CmpFOp>(
op, translateFloatRelational(op.opr));
}
- template <int KIND>
- ExtValue genval(const Fortran::evaluate::Relational<Fortran::evaluate::Type<
- Fortran::common::TypeCategory::Complex, KIND>> &op) {
+ ExtValue
+ genval(const Fortran::evaluate::Relational<
+ Fortran::evaluate::Type<Fortran::common::TypeCategory::Complex>> &op) {
return createFltCmpOp<fir::CmpcOp>(op, translateFloatRelational(op.opr));
}
- template <int KIND>
ExtValue genval(const Fortran::evaluate::Relational<Fortran::evaluate::Type<
- Fortran::common::TypeCategory::Character, KIND>> &op) {
+ Fortran::common::TypeCategory::Character>> &op) {
return createCharCompare(op, translateSignedRelational(op.opr));
}
@@ -1284,12 +1280,12 @@ class ScalarExprLowering {
op.u);
}
- template <Fortran::common::TypeCategory TC1, int KIND,
+ template <Fortran::common::TypeCategory TC1,
Fortran::common::TypeCategory TC2>
- ExtValue
- genval(const Fortran::evaluate::Convert<Fortran::evaluate::Type<TC1, KIND>,
- TC2> &convert) {
- mlir::Type ty = converter.genType(TC1, KIND);
+ ExtValue genval(const Fortran::evaluate::Convert<Fortran::evaluate::Type<TC1>,
+ TC2> &convert) {
+ int kind = convert.GetType().value().kind();
+ mlir::Type ty = converter.genType(TC1, kind);
auto fromExpr = genval(convert.left());
auto loc = getLoc();
return fromExpr.match(
@@ -1297,7 +1293,7 @@ class ScalarExprLowering {
if constexpr (TC1 == Fortran::common::TypeCategory::Character &&
TC2 == TC1) {
return fir::factory::convertCharacterKind(builder, loc, boxchar,
- KIND);
+ kind);
} else {
fir::emitFatalError(
loc, "unsupported evaluate::Convert between CHARACTER type "
@@ -1321,8 +1317,7 @@ class ScalarExprLowering {
return fir::substBase(input, newBase);
}
- template <int KIND>
- ExtValue genval(const Fortran::evaluate::Not<KIND> &op) {
+ ExtValue genval(const Fortran::evaluate::Not &op) {
mlir::Value logical = genunbox(op.left());
mlir::Value one = genBoolConstant(true);
mlir::Value val =
@@ -1330,8 +1325,7 @@ class ScalarExprLowering {
return mlir::arith::XOrIOp::create(builder, getLoc(), val, one);
}
- template <int KIND>
- ExtValue genval(const Fortran::evaluate::LogicalOperation<KIND> &op) {
+ ExtValue genval(const Fortran::evaluate::LogicalOperation &op) {
mlir::IntegerType i1Type = builder.getI1Type();
mlir::Value slhs = genunbox(op.left());
mlir::Value srhs = genunbox(op.right());
@@ -1355,10 +1349,9 @@ class ScalarExprLowering {
llvm_unreachable("unhandled logical operation");
}
- template <Fortran::common::TypeCategory TC, int KIND>
+ template <Fortran::common::TypeCategory TC>
ExtValue
- genval(const Fortran::evaluate::Constant<Fortran::evaluate::Type<TC, KIND>>
- &con) {
+ genval(const Fortran::evaluate::Constant<Fortran::evaluate::Type<TC>> &con) {
return Fortran::lower::convertConstant(
converter, getLoc(), con,
/*outlineBigConstantsInReadOnlyMemory=*/!inInitializer);
@@ -1560,7 +1553,7 @@ class ScalarExprLowering {
Fortran::semantics::MaybeSubscriptIntExpr sub = bound.GetExplicit();
if (sub.has_value())
return genval(*sub);
- return genIntegerConstant<8>(builder.getContext(), 1);
+ return genIntegerConstant(builder.getContext(), 8, 1);
}
TODO(getLoc(), "non explicit semantics::Bound implementation");
}
@@ -3036,9 +3029,8 @@ class ScalarExprLowering {
return asArray(x);
}
- template <int KIND>
ExtValue genval(const Fortran::evaluate::Expr<Fortran::evaluate::Type<
- Fortran::common::TypeCategory::Logical, KIND>> &exp) {
+ Fortran::common::TypeCategory::Logical>> &exp) {
if (mlir::Value val = getIfOverridenExpr(exp))
return val;
return Fortran::common::visit([&](const auto &e) { return genval(e); },
@@ -5119,13 +5111,13 @@ class ArrayExprLowering {
fir::emitFatalError(loc, "convert on adjusted extended value");
});
}
- template <Fortran::common::TypeCategory TC1, int KIND,
+ template <Fortran::common::TypeCategory TC1,
Fortran::common::TypeCategory TC2>
- CC genarr(const Fortran::evaluate::Convert<Fortran::evaluate::Type<TC1, KIND>,
- TC2> &x) {
+ CC genarr(
+ const Fortran::evaluate::Convert<Fortran::evaluate::Type<TC1>, TC2> &x) {
mlir::Location loc = getLoc();
auto lambda = genarr(x.left());
- mlir::Type ty = converter.genType(TC1, KIND);
+ mlir::Type ty = converter.genType(TC1, x.GetType().value().kind());
return [=](IterSpace iters) -> ExtValue {
auto exv = lambda(iters);
mlir::Value val = fir::getBase(exv);
@@ -5137,8 +5129,7 @@ class ArrayExprLowering {
};
}
- template <int KIND>
- CC genarr(const Fortran::evaluate::ComplexComponent<KIND> &x) {
+ CC genarr(const Fortran::evaluate::ComplexComponent &x) {
mlir::Location loc = getLoc();
auto lambda = genarr(x.left());
bool isImagPart = x.isImaginaryPart;
@@ -5168,15 +5159,16 @@ class ArrayExprLowering {
return fir::substBase(val, newBase);
};
}
- template <Fortran::common::TypeCategory CAT, int KIND>
+ template <Fortran::common::TypeCategory CAT>
CC genarrIntNeg(
- const Fortran::evaluate::Expr<Fortran::evaluate::Type<CAT, KIND>> &left) {
+ const Fortran::evaluate::Expr<Fortran::evaluate::Type<CAT>> &left) {
mlir::Location loc = getLoc();
+ int kind = left.GetType().value().kind();
auto f = genarr(left);
return [=](IterSpace iters) -> ExtValue {
mlir::Value val = fir::getBase(f(iters));
mlir::Type ty =
- converter.genType(Fortran::common::TypeCategory::Integer, KIND);
+ converter.genType(Fortran::common::TypeCategory::Integer, kind);
mlir::Value zero = builder.createIntegerConstant(loc, ty, 0);
if constexpr (CAT == Fortran::common::TypeCategory::Unsigned) {
mlir::Value signless = builder.createConvert(loc, ty, val);
@@ -5187,28 +5179,26 @@ class ArrayExprLowering {
return mlir::arith::SubIOp::create(builder, loc, zero, val);
};
}
- template <int KIND>
- CC genarr(const Fortran::evaluate::Negate<Fortran::evaluate::Type<
- Fortran::common::TypeCategory::Integer, KIND>> &x) {
+ CC genarr(
+ const Fortran::evaluate::Negate<
+ Fortran::evaluate::Type<Fortran::common::TypeCategory::Integer>> &x) {
return genarrIntNeg(x.left());
}
- template <int KIND>
CC genarr(const Fortran::evaluate::Negate<Fortran::evaluate::Type<
- Fortran::common::TypeCategory::Unsigned, KIND>> &x) {
+ Fortran::common::TypeCategory::Unsigned>> &x) {
return genarrIntNeg(x.left());
}
- template <int KIND>
- CC genarr(const Fortran::evaluate::Negate<Fortran::evaluate::Type<
- Fortran::common::TypeCategory::Real, KIND>> &x) {
+ CC genarr(const Fortran::evaluate::Negate<
+ Fortran::evaluate::Type<Fortran::common::TypeCategory::Real>> &x) {
mlir::Location loc = getLoc();
auto f = genarr(x.left());
return [=](IterSpace iters) -> ExtValue {
return mlir::arith::NegFOp::create(builder, loc, fir::getBase(f(iters)));
};
}
- template <int KIND>
- CC genarr(const Fortran::evaluate::Negate<Fortran::evaluate::Type<
- Fortran::common::TypeCategory::Complex, KIND>> &x) {
+ CC genarr(
+ const Fortran::evaluate::Negate<
+ Fortran::evaluate::Type<Fortran::common::TypeCategory::Complex>> &x) {
mlir::Location loc = getLoc();
auto f = genarr(x.left());
return [=](IterSpace iters) -> ExtValue {
@@ -5235,9 +5225,8 @@ class ArrayExprLowering {
#undef GENBIN
#define GENBIN(GenBinEvOp, GenBinTyCat, GenBinFirOp) \
- template <int KIND> \
CC genarr(const Fortran::evaluate::GenBinEvOp<Fortran::evaluate::Type< \
- Fortran::common::TypeCategory::GenBinTyCat, KIND>> &x) { \
+ Fortran::common::TypeCategory::GenBinTyCat>> &x) { \
return createBinaryOp<GenBinFirOp>(x); \
}
@@ -5257,12 +5246,12 @@ class ArrayExprLowering {
GENBIN(Divide, Unsigned, mlir::arith::DivUIOp)
GENBIN(Divide, Real, mlir::arith::DivFOp)
- template <int KIND>
- CC genarr(const Fortran::evaluate::Divide<Fortran::evaluate::Type<
- Fortran::common::TypeCategory::Complex, KIND>> &x) {
+ CC genarr(
+ const Fortran::evaluate::Divide<
+ Fortran::evaluate::Type<Fortran::common::TypeCategory::Complex>> &x) {
mlir::Location loc = getLoc();
- mlir::Type ty =
- converter.genType(Fortran::common::TypeCategory::Complex, KIND);
+ mlir::Type ty = converter.genType(Fortran::common::TypeCategory::Complex,
+ x.GetType().value().kind());
auto lf = genarr(x.left());
auto rf = genarr(x.right());
return [=](IterSpace iters) -> ExtValue {
@@ -5272,11 +5261,10 @@ class ArrayExprLowering {
};
}
- template <Fortran::common::TypeCategory TC, int KIND>
- CC genarr(
- const Fortran::evaluate::Power<Fortran::evaluate::Type<TC, KIND>> &x) {
+ template <Fortran::common::TypeCategory TC>
+ CC genarr(const Fortran::evaluate::Power<Fortran::evaluate::Type<TC>> &x) {
mlir::Location loc = getLoc();
- mlir::Type ty = converter.genType(TC, KIND);
+ mlir::Type ty = converter.genType(TC, x.GetType().value().kind());
auto lf = genarr(x.left());
auto rf = genarr(x.right());
return [=](IterSpace iters) -> ExtValue {
@@ -5285,9 +5273,8 @@ class ArrayExprLowering {
return fir::genPow(builder, loc, ty, lhs, rhs);
};
}
- template <Fortran::common::TypeCategory TC, int KIND>
- CC genarr(
- const Fortran::evaluate::Extremum<Fortran::evaluate::Type<TC, KIND>> &x) {
+ template <Fortran::common::TypeCategory TC>
+ CC genarr(const Fortran::evaluate::Extremum<Fortran::evaluate::Type<TC>> &x) {
mlir::Location loc = getLoc();
auto lf = genarr(x.left());
auto rf = genarr(x.right());
@@ -5309,12 +5296,11 @@ class ArrayExprLowering {
}
llvm_unreachable("unknown ordering");
}
- template <Fortran::common::TypeCategory TC, int KIND>
+ template <Fortran::common::TypeCategory TC>
CC genarr(
- const Fortran::evaluate::RealToIntPower<Fortran::evaluate::Type<TC, KIND>>
- &x) {
+ const Fortran::evaluate::RealToIntPower<Fortran::evaluate::Type<TC>> &x) {
mlir::Location loc = getLoc();
- auto ty = converter.genType(TC, KIND);
+ auto ty = converter.genType(TC, x.GetType().value().kind());
auto lf = genarr(x.left());
auto rf = genarr(x.right());
return [=](IterSpace iters) {
@@ -5323,8 +5309,7 @@ class ArrayExprLowering {
return fir::genPow(builder, loc, ty, lhs, rhs);
};
}
- template <int KIND>
- CC genarr(const Fortran::evaluate::ComplexConstructor<KIND> &x) {
+ CC genarr(const Fortran::evaluate::ComplexConstructor &x) {
mlir::Location loc = getLoc();
auto lf = genarr(x.left());
auto rf = genarr(x.right());
@@ -5336,8 +5321,7 @@ class ArrayExprLowering {
}
/// Fortran's concatenation operator `//`.
- template <int KIND>
- CC genarr(const Fortran::evaluate::Concat<KIND> &x) {
+ CC genarr(const Fortran::evaluate::Concat &x) {
mlir::Location loc = getLoc();
auto lf = genarr(x.left());
auto rf = genarr(x.right());
@@ -5355,14 +5339,14 @@ class ArrayExprLowering {
};
}
- template <int KIND>
- CC genarr(const Fortran::evaluate::SetLength<KIND> &x) {
+ CC genarr(const Fortran::evaluate::SetLength &x) {
auto lf = genarr(x.left());
mlir::Value rhs = fir::getBase(asScalar(x.right()));
fir::CharBoxValue temp =
fir::factory::CharacterExprHelper(builder, getLoc())
.createCharacterTemp(
- fir::CharacterType::getUnknownLen(builder.getContext(), KIND),
+ fir::CharacterType::getUnknownLen(builder.getContext(),
+ x.GetType().value().kind()),
rhs);
return [=](IterSpace iters) -> ExtValue {
fir::factory::CharacterExprHelper(builder, getLoc())
@@ -5390,17 +5374,17 @@ class ArrayExprLowering {
// Get rid of it here so the vector can be loaded. Add it back when
// generating the elemental evaluation (inside the loop nest).
- static Fortran::lower::SomeExpr
- ignoreEvConvert(const Fortran::evaluate::Expr<Fortran::evaluate::Type<
- Fortran::common::TypeCategory::Integer, 8>> &x) {
+ static Fortran::lower::SomeExpr ignoreEvConvert(
+ const Fortran::evaluate::Expr<
+ Fortran::evaluate::Type<Fortran::common::TypeCategory::Integer>> &x) {
return Fortran::common::visit(
[&](const auto &v) { return ignoreEvConvert(v); }, x.u);
}
template <Fortran::common::TypeCategory FROM>
static Fortran::lower::SomeExpr ignoreEvConvert(
const Fortran::evaluate::Convert<
- Fortran::evaluate::Type<Fortran::common::TypeCategory::Integer, 8>,
- FROM> &x) {
+ Fortran::evaluate::Type<Fortran::common::TypeCategory::Integer>, FROM>
+ &x) {
return toEvExpr(x.left());
}
template <typename A>
@@ -6577,8 +6561,7 @@ class ArrayExprLowering {
// LOCICAL operators (.NOT., .AND., .EQV., etc.)
//===--------------------------------------------------------------------===//
- template <int KIND>
- CC genarr(const Fortran::evaluate::Not<KIND> &x) {
+ CC genarr(const Fortran::evaluate::Not &x) {
mlir::Location loc = getLoc();
mlir::IntegerType i1Ty = builder.getI1Type();
auto lambda = genarr(x.left());
@@ -6617,8 +6600,7 @@ class ArrayExprLowering {
return OP::create(builder, loc, pred, lhs, rhs);
};
}
- template <int KIND>
- CC genarr(const Fortran::evaluate::LogicalOperation<KIND> &x) {
+ CC genarr(const Fortran::evaluate::LogicalOperation &x) {
switch (x.logicalOperator) {
case Fortran::evaluate::LogicalOperator::And:
return createBinaryBoolOp<mlir::arith::AndIOp>(x);
@@ -6670,32 +6652,30 @@ class ArrayExprLowering {
return fir::runtime::genCharCompare(builder, loc, pred, lhs, rhs);
};
}
- template <int KIND>
- CC genarr(const Fortran::evaluate::Relational<Fortran::evaluate::Type<
- Fortran::common::TypeCategory::Integer, KIND>> &x) {
+ CC genarr(
+ const Fortran::evaluate::Relational<
+ Fortran::evaluate::Type<Fortran::common::TypeCategory::Integer>> &x) {
return createCompareOp<mlir::arith::CmpIOp>(
translateSignedRelational(x.opr), x);
}
- template <int KIND>
CC genarr(const Fortran::evaluate::Relational<Fortran::evaluate::Type<
- Fortran::common::TypeCategory::Unsigned, KIND>> &x) {
+ Fortran::common::TypeCategory::Unsigned>> &x) {
return createCompareOp<mlir::arith::CmpIOp>(
- translateUnsignedRelational(x.opr), x, KIND);
+ translateUnsignedRelational(x.opr), x,
+ x.left().GetType().value().kind());
}
- template <int KIND>
CC genarr(const Fortran::evaluate::Relational<Fortran::evaluate::Type<
- Fortran::common::TypeCategory::Character, KIND>> &x) {
+ Fortran::common::TypeCategory::Character>> &x) {
return createCompareCharOp(translateSignedRelational(x.opr), x);
}
- template <int KIND>
- CC genarr(const Fortran::evaluate::Relational<Fortran::evaluate::Type<
- Fortran::common::TypeCategory::Real, KIND>> &x) {
+ CC genarr(const Fortran::evaluate::Relational<
+ Fortran::evaluate::Type<Fortran::common::TypeCategory::Real>> &x) {
return createCompareOp<mlir::arith::CmpFOp>(translateFloatRelational(x.opr),
x);
}
- template <int KIND>
- CC genarr(const Fortran::evaluate::Relational<Fortran::evaluate::Type<
- Fortran::common::TypeCategory::Complex, KIND>> &x) {
+ CC genarr(
+ const Fortran::evaluate::Relational<
+ Fortran::evaluate::Type<Fortran::common::TypeCategory::Complex>> &x) {
return createCompareOp<fir::CmpcOp>(translateFloatRelational(x.opr), x);
}
CC genarr(
diff --git a/flang/lib/Lower/ConvertExprToHLFIR.cpp b/flang/lib/Lower/ConvertExprToHLFIR.cpp
index ad680269dea5c..f240fd303b0d5 100644
--- a/flang/lib/Lower/ConvertExprToHLFIR.cpp
+++ b/flang/lib/Lower/ConvertExprToHLFIR.cpp
@@ -86,7 +86,7 @@ class HlfirDesignatorBuilder {
// Character designators variant contains substrings
using CharacterDesignators =
decltype(Fortran::evaluate::Designator<Fortran::evaluate::Type<
- Fortran::evaluate::TypeCategory::Character, 1>>::u);
+ Fortran::evaluate::TypeCategory::Character>>::u);
hlfir::EntityWithAttributes
gen(const CharacterDesignators &designatorVariant,
bool vectorSubscriptDesignatorToValue = true) {
@@ -99,7 +99,7 @@ class HlfirDesignatorBuilder {
// Character designators variant contains complex parts
using RealDesignators =
decltype(Fortran::evaluate::Designator<Fortran::evaluate::Type<
- Fortran::evaluate::TypeCategory::Real, 4>>::u);
+ Fortran::evaluate::TypeCategory::Real>>::u);
hlfir::EntityWithAttributes
gen(const RealDesignators &designatorVariant,
bool vectorSubscriptDesignatorToValue = true) {
@@ -112,7 +112,7 @@ class HlfirDesignatorBuilder {
// All other designators are similar
using OtherDesignators =
decltype(Fortran::evaluate::Designator<Fortran::evaluate::Type<
- Fortran::evaluate::TypeCategory::Integer, 4>>::u);
+ Fortran::evaluate::TypeCategory::Integer>>::u);
hlfir::EntityWithAttributes
gen(const OtherDesignators &designatorVariant,
bool vectorSubscriptDesignatorToValue = true) {
@@ -1045,11 +1045,11 @@ struct BinaryOp {};
#undef GENBIN
#define GENBIN(GenBinEvOp, GenBinTyCat, GenBinFirOp) \
- template <int KIND> \
- struct BinaryOp<Fortran::evaluate::GenBinEvOp<Fortran::evaluate::Type< \
- Fortran::common::TypeCategory::GenBinTyCat, KIND>>> { \
- using Op = Fortran::evaluate::GenBinEvOp<Fortran::evaluate::Type< \
- Fortran::common::TypeCategory::GenBinTyCat, KIND>>; \
+ template <> \
+ struct BinaryOp<Fortran::evaluate::GenBinEvOp< \
+ Fortran::evaluate::Type<Fortran::common::TypeCategory::GenBinTyCat>>> { \
+ using Op = Fortran::evaluate::GenBinEvOp< \
+ Fortran::evaluate::Type<Fortran::common::TypeCategory::GenBinTyCat>>; \
static hlfir::EntityWithAttributes gen(mlir::Location loc, \
fir::FirOpBuilder &builder, \
const Op &, hlfir::Entity lhs, \
@@ -1082,16 +1082,18 @@ GENBIN(Divide, Integer, mlir::arith::DivSIOp)
GENBIN(Divide, Unsigned, mlir::arith::DivUIOp)
GENBIN(Divide, Real, mlir::arith::DivFOp)
-template <int KIND>
+template <>
struct BinaryOp<Fortran::evaluate::Divide<
- Fortran::evaluate::Type<Fortran::common::TypeCategory::Complex, KIND>>> {
+ Fortran::evaluate::Type<Fortran::common::TypeCategory::Complex>>> {
using Op = Fortran::evaluate::Divide<
- Fortran::evaluate::Type<Fortran::common::TypeCategory::Complex, KIND>>;
+ Fortran::evaluate::Type<Fortran::common::TypeCategory::Complex>>;
static hlfir::EntityWithAttributes gen(mlir::Location loc,
- fir::FirOpBuilder &builder, const Op &,
- hlfir::Entity lhs, hlfir::Entity rhs) {
+ fir::FirOpBuilder &builder,
+ const Op &op, hlfir::Entity lhs,
+ hlfir::Entity rhs) {
mlir::Type ty = Fortran::lower::getFIRType(
- builder.getContext(), Fortran::common::TypeCategory::Complex, KIND,
+ builder.getContext(), Fortran::common::TypeCategory::Complex,
+ op.GetType().value().kind(),
/*params=*/{});
// TODO: Ideally, complex number division operations should always be
@@ -1107,36 +1109,38 @@ struct BinaryOp<Fortran::evaluate::Divide<
}
};
-template <Fortran::common::TypeCategory TC, int KIND>
-struct BinaryOp<Fortran::evaluate::Power<Fortran::evaluate::Type<TC, KIND>>> {
- using Op = Fortran::evaluate::Power<Fortran::evaluate::Type<TC, KIND>>;
+template <Fortran::common::TypeCategory TC>
+struct BinaryOp<Fortran::evaluate::Power<Fortran::evaluate::Type<TC>>> {
+ using Op = Fortran::evaluate::Power<Fortran::evaluate::Type<TC>>;
static hlfir::EntityWithAttributes gen(mlir::Location loc,
- fir::FirOpBuilder &builder, const Op &,
- hlfir::Entity lhs, hlfir::Entity rhs) {
- mlir::Type ty = Fortran::lower::getFIRType(builder.getContext(), TC, KIND,
+ fir::FirOpBuilder &builder,
+ const Op &op, hlfir::Entity lhs,
+ hlfir::Entity rhs) {
+ mlir::Type ty = Fortran::lower::getFIRType(builder.getContext(), TC,
+ op.GetType().value().kind(),
/*params=*/{});
return hlfir::EntityWithAttributes{fir::genPow(builder, loc, ty, lhs, rhs)};
}
};
-template <Fortran::common::TypeCategory TC, int KIND>
+template <Fortran::common::TypeCategory TC>
struct BinaryOp<
- Fortran::evaluate::RealToIntPower<Fortran::evaluate::Type<TC, KIND>>> {
- using Op =
- Fortran::evaluate::RealToIntPower<Fortran::evaluate::Type<TC, KIND>>;
+ Fortran::evaluate::RealToIntPower<Fortran::evaluate::Type<TC>>> {
+ using Op = Fortran::evaluate::RealToIntPower<Fortran::evaluate::Type<TC>>;
static hlfir::EntityWithAttributes gen(mlir::Location loc,
- fir::FirOpBuilder &builder, const Op &,
- hlfir::Entity lhs, hlfir::Entity rhs) {
- mlir::Type ty = Fortran::lower::getFIRType(builder.getContext(), TC, KIND,
+ fir::FirOpBuilder &builder,
+ const Op &op, hlfir::Entity lhs,
+ hlfir::Entity rhs) {
+ mlir::Type ty = Fortran::lower::getFIRType(builder.getContext(), TC,
+ op.GetType().value().kind(),
/*params=*/{});
return hlfir::EntityWithAttributes{fir::genPow(builder, loc, ty, lhs, rhs)};
}
};
-template <Fortran::common::TypeCategory TC, int KIND>
-struct BinaryOp<
- Fortran::evaluate::Extremum<Fortran::evaluate::Type<TC, KIND>>> {
- using Op = Fortran::evaluate::Extremum<Fortran::evaluate::Type<TC, KIND>>;
+template <Fortran::common::TypeCategory TC>
+struct BinaryOp<Fortran::evaluate::Extremum<Fortran::evaluate::Type<TC>>> {
+ using Op = Fortran::evaluate::Extremum<Fortran::evaluate::Type<TC>>;
static hlfir::EntityWithAttributes gen(mlir::Location loc,
fir::FirOpBuilder &builder,
const Op &op, hlfir::Entity lhs,
@@ -1154,11 +1158,11 @@ struct BinaryOp<
// MIN and MAX are represented as evaluate::ProcedureRef and are not going
// through here. So far the frontend does not generate character Extremum so
// there is no way to test it.
-template <int KIND>
+template <>
struct BinaryOp<Fortran::evaluate::Extremum<
- Fortran::evaluate::Type<Fortran::common::TypeCategory::Character, KIND>>> {
+ Fortran::evaluate::Type<Fortran::common::TypeCategory::Character>>> {
using Op = Fortran::evaluate::Extremum<
- Fortran::evaluate::Type<Fortran::common::TypeCategory::Character, KIND>>;
+ Fortran::evaluate::Type<Fortran::common::TypeCategory::Character>>;
static hlfir::EntityWithAttributes gen(mlir::Location loc,
fir::FirOpBuilder &, const Op &,
hlfir::Entity, hlfir::Entity) {
@@ -1191,11 +1195,11 @@ translateSignedRelational(Fortran::common::RelationalOperator rop) {
llvm_unreachable("unhandled INTEGER relational operator");
}
-template <int KIND>
+template <>
struct BinaryOp<Fortran::evaluate::Relational<
- Fortran::evaluate::Type<Fortran::common::TypeCategory::Integer, KIND>>> {
+ Fortran::evaluate::Type<Fortran::common::TypeCategory::Integer>>> {
using Op = Fortran::evaluate::Relational<
- Fortran::evaluate::Type<Fortran::common::TypeCategory::Integer, KIND>>;
+ Fortran::evaluate::Type<Fortran::common::TypeCategory::Integer>>;
static hlfir::EntityWithAttributes gen(mlir::Location loc,
fir::FirOpBuilder &builder,
const Op &op, hlfir::Entity lhs,
@@ -1207,17 +1211,16 @@ struct BinaryOp<Fortran::evaluate::Relational<
}
};
-template <int KIND>
+template <>
struct BinaryOp<Fortran::evaluate::Relational<
- Fortran::evaluate::Type<Fortran::common::TypeCategory::Unsigned, KIND>>> {
+ Fortran::evaluate::Type<Fortran::common::TypeCategory::Unsigned>>> {
using Op = Fortran::evaluate::Relational<
- Fortran::evaluate::Type<Fortran::common::TypeCategory::Unsigned, KIND>>;
+ Fortran::evaluate::Type<Fortran::common::TypeCategory::Unsigned>>;
static hlfir::EntityWithAttributes gen(mlir::Location loc,
fir::FirOpBuilder &builder,
const Op &op, hlfir::Entity lhs,
hlfir::Entity rhs) {
- int bits = Fortran::evaluate::Type<Fortran::common::TypeCategory::Integer,
- KIND>::Scalar::bits;
+ int bits = 8 * op.left().GetType().value().kind();
auto signlessType = mlir::IntegerType::get(
builder.getContext(), bits,
mlir::IntegerType::SignednessSemantics::Signless);
@@ -1230,11 +1233,11 @@ struct BinaryOp<Fortran::evaluate::Relational<
}
};
-template <int KIND>
+template <>
struct BinaryOp<Fortran::evaluate::Relational<
- Fortran::evaluate::Type<Fortran::common::TypeCategory::Real, KIND>>> {
+ Fortran::evaluate::Type<Fortran::common::TypeCategory::Real>>> {
using Op = Fortran::evaluate::Relational<
- Fortran::evaluate::Type<Fortran::common::TypeCategory::Real, KIND>>;
+ Fortran::evaluate::Type<Fortran::common::TypeCategory::Real>>;
static hlfir::EntityWithAttributes gen(mlir::Location loc,
fir::FirOpBuilder &builder,
const Op &op, hlfir::Entity lhs,
@@ -1246,11 +1249,11 @@ struct BinaryOp<Fortran::evaluate::Relational<
}
};
-template <int KIND>
+template <>
struct BinaryOp<Fortran::evaluate::Relational<
- Fortran::evaluate::Type<Fortran::common::TypeCategory::Complex, KIND>>> {
+ Fortran::evaluate::Type<Fortran::common::TypeCategory::Complex>>> {
using Op = Fortran::evaluate::Relational<
- Fortran::evaluate::Type<Fortran::common::TypeCategory::Complex, KIND>>;
+ Fortran::evaluate::Type<Fortran::common::TypeCategory::Complex>>;
static hlfir::EntityWithAttributes gen(mlir::Location loc,
fir::FirOpBuilder &builder,
const Op &op, hlfir::Entity lhs,
@@ -1262,11 +1265,11 @@ struct BinaryOp<Fortran::evaluate::Relational<
}
};
-template <int KIND>
+template <>
struct BinaryOp<Fortran::evaluate::Relational<
- Fortran::evaluate::Type<Fortran::common::TypeCategory::Character, KIND>>> {
+ Fortran::evaluate::Type<Fortran::common::TypeCategory::Character>>> {
using Op = Fortran::evaluate::Relational<
- Fortran::evaluate::Type<Fortran::common::TypeCategory::Character, KIND>>;
+ Fortran::evaluate::Type<Fortran::common::TypeCategory::Character>>;
static hlfir::EntityWithAttributes gen(mlir::Location loc,
fir::FirOpBuilder &builder,
const Op &op, hlfir::Entity lhs,
@@ -1277,9 +1280,9 @@ struct BinaryOp<Fortran::evaluate::Relational<
}
};
-template <int KIND>
-struct BinaryOp<Fortran::evaluate::LogicalOperation<KIND>> {
- using Op = Fortran::evaluate::LogicalOperation<KIND>;
+template <>
+struct BinaryOp<Fortran::evaluate::LogicalOperation> {
+ using Op = Fortran::evaluate::LogicalOperation;
static hlfir::EntityWithAttributes gen(mlir::Location loc,
fir::FirOpBuilder &builder,
const Op &op, hlfir::Entity lhs,
@@ -1334,9 +1337,9 @@ struct BinaryOp<Fortran::evaluate::LogicalOperation<KIND>> {
}
};
-template <int KIND>
-struct BinaryOp<Fortran::evaluate::ComplexConstructor<KIND>> {
- using Op = Fortran::evaluate::ComplexConstructor<KIND>;
+template <>
+struct BinaryOp<Fortran::evaluate::ComplexConstructor> {
+ using Op = Fortran::evaluate::ComplexConstructor;
static hlfir::EntityWithAttributes gen(mlir::Location loc,
fir::FirOpBuilder &builder, const Op &,
hlfir::Entity lhs, hlfir::Entity rhs) {
@@ -1346,9 +1349,9 @@ struct BinaryOp<Fortran::evaluate::ComplexConstructor<KIND>> {
}
};
-template <int KIND>
-struct BinaryOp<Fortran::evaluate::SetLength<KIND>> {
- using Op = Fortran::evaluate::SetLength<KIND>;
+template <>
+struct BinaryOp<Fortran::evaluate::SetLength> {
+ using Op = Fortran::evaluate::SetLength;
static hlfir::EntityWithAttributes gen(mlir::Location loc,
fir::FirOpBuilder &builder, const Op &,
hlfir::Entity string,
@@ -1367,9 +1370,9 @@ struct BinaryOp<Fortran::evaluate::SetLength<KIND>> {
}
};
-template <int KIND>
-struct BinaryOp<Fortran::evaluate::Concat<KIND>> {
- using Op = Fortran::evaluate::Concat<KIND>;
+template <>
+struct BinaryOp<Fortran::evaluate::Concat> {
+ using Op = Fortran::evaluate::Concat;
hlfir::EntityWithAttributes gen(mlir::Location loc,
fir::FirOpBuilder &builder, const Op &,
hlfir::Entity lhs, hlfir::Entity rhs) {
@@ -1404,9 +1407,9 @@ struct BinaryOp<Fortran::evaluate::Concat<KIND>> {
template <typename T>
struct UnaryOp {};
-template <int KIND>
-struct UnaryOp<Fortran::evaluate::Not<KIND>> {
- using Op = Fortran::evaluate::Not<KIND>;
+template <>
+struct UnaryOp<Fortran::evaluate::Not> {
+ using Op = Fortran::evaluate::Not;
static hlfir::EntityWithAttributes gen(mlir::Location loc,
fir::FirOpBuilder &builder, const Op &,
hlfir::Entity lhs) {
@@ -1417,17 +1420,18 @@ struct UnaryOp<Fortran::evaluate::Not<KIND>> {
}
};
-template <int KIND>
+template <>
struct UnaryOp<Fortran::evaluate::Negate<
- Fortran::evaluate::Type<Fortran::common::TypeCategory::Integer, KIND>>> {
+ Fortran::evaluate::Type<Fortran::common::TypeCategory::Integer>>> {
using Op = Fortran::evaluate::Negate<
- Fortran::evaluate::Type<Fortran::common::TypeCategory::Integer, KIND>>;
+ Fortran::evaluate::Type<Fortran::common::TypeCategory::Integer>>;
static hlfir::EntityWithAttributes gen(mlir::Location loc,
- fir::FirOpBuilder &builder, const Op &,
- hlfir::Entity lhs) {
+ fir::FirOpBuilder &builder,
+ const Op &op, hlfir::Entity lhs) {
// Like LLVM, integer negation is the binary op "0 - value"
mlir::Type type = Fortran::lower::getFIRType(
- builder.getContext(), Fortran::common::TypeCategory::Integer, KIND,
+ builder.getContext(), Fortran::common::TypeCategory::Integer,
+ op.GetType().value().kind(),
/*params=*/{});
mlir::Value zero = builder.createIntegerConstant(loc, type, 0);
return hlfir::EntityWithAttributes{
@@ -1435,16 +1439,15 @@ struct UnaryOp<Fortran::evaluate::Negate<
}
};
-template <int KIND>
+template <>
struct UnaryOp<Fortran::evaluate::Negate<
- Fortran::evaluate::Type<Fortran::common::TypeCategory::Unsigned, KIND>>> {
+ Fortran::evaluate::Type<Fortran::common::TypeCategory::Unsigned>>> {
using Op = Fortran::evaluate::Negate<
- Fortran::evaluate::Type<Fortran::common::TypeCategory::Unsigned, KIND>>;
+ Fortran::evaluate::Type<Fortran::common::TypeCategory::Unsigned>>;
static hlfir::EntityWithAttributes gen(mlir::Location loc,
- fir::FirOpBuilder &builder, const Op &,
- hlfir::Entity lhs) {
- int bits = Fortran::evaluate::Type<Fortran::common::TypeCategory::Integer,
- KIND>::Scalar::bits;
+ fir::FirOpBuilder &builder,
+ const Op &op, hlfir::Entity lhs) {
+ int bits = 8 * op.GetType().value().kind();
mlir::Type signlessType = mlir::IntegerType::get(
builder.getContext(), bits,
mlir::IntegerType::SignednessSemantics::Signless);
@@ -1457,11 +1460,11 @@ struct UnaryOp<Fortran::evaluate::Negate<
}
};
-template <int KIND>
+template <>
struct UnaryOp<Fortran::evaluate::Negate<
- Fortran::evaluate::Type<Fortran::common::TypeCategory::Real, KIND>>> {
+ Fortran::evaluate::Type<Fortran::common::TypeCategory::Real>>> {
using Op = Fortran::evaluate::Negate<
- Fortran::evaluate::Type<Fortran::common::TypeCategory::Real, KIND>>;
+ Fortran::evaluate::Type<Fortran::common::TypeCategory::Real>>;
static hlfir::EntityWithAttributes gen(mlir::Location loc,
fir::FirOpBuilder &builder, const Op &,
hlfir::Entity lhs) {
@@ -1470,11 +1473,11 @@ struct UnaryOp<Fortran::evaluate::Negate<
}
};
-template <int KIND>
+template <>
struct UnaryOp<Fortran::evaluate::Negate<
- Fortran::evaluate::Type<Fortran::common::TypeCategory::Complex, KIND>>> {
+ Fortran::evaluate::Type<Fortran::common::TypeCategory::Complex>>> {
using Op = Fortran::evaluate::Negate<
- Fortran::evaluate::Type<Fortran::common::TypeCategory::Complex, KIND>>;
+ Fortran::evaluate::Type<Fortran::common::TypeCategory::Complex>>;
static hlfir::EntityWithAttributes gen(mlir::Location loc,
fir::FirOpBuilder &builder, const Op &,
hlfir::Entity lhs) {
@@ -1482,9 +1485,9 @@ struct UnaryOp<Fortran::evaluate::Negate<
}
};
-template <int KIND>
-struct UnaryOp<Fortran::evaluate::ComplexComponent<KIND>> {
- using Op = Fortran::evaluate::ComplexComponent<KIND>;
+template <>
+struct UnaryOp<Fortran::evaluate::ComplexComponent> {
+ using Op = Fortran::evaluate::ComplexComponent;
static hlfir::EntityWithAttributes gen(mlir::Location loc,
fir::FirOpBuilder &builder,
const Op &op, hlfir::Entity lhs) {
@@ -1515,21 +1518,19 @@ struct UnaryOp<Fortran::evaluate::Parentheses<T>> {
}
};
-template <Fortran::common::TypeCategory TC1, int KIND,
- Fortran::common::TypeCategory TC2>
-struct UnaryOp<
- Fortran::evaluate::Convert<Fortran::evaluate::Type<TC1, KIND>, TC2>> {
- using Op =
- Fortran::evaluate::Convert<Fortran::evaluate::Type<TC1, KIND>, TC2>;
+template <Fortran::common::TypeCategory TC1, Fortran::common::TypeCategory TC2>
+struct UnaryOp<Fortran::evaluate::Convert<Fortran::evaluate::Type<TC1>, TC2>> {
+ using Op = Fortran::evaluate::Convert<Fortran::evaluate::Type<TC1>, TC2>;
static hlfir::EntityWithAttributes gen(mlir::Location loc,
- fir::FirOpBuilder &builder, const Op &,
- hlfir::Entity lhs) {
+ fir::FirOpBuilder &builder,
+ const Op &op, hlfir::Entity lhs) {
+ int kind = op.GetType().value().kind();
if constexpr (TC1 == Fortran::common::TypeCategory::Character &&
TC2 == TC1) {
- return hlfir::convertCharacterKind(loc, builder, lhs, KIND);
+ return hlfir::convertCharacterKind(loc, builder, lhs, kind);
}
mlir::Type type = Fortran::lower::getFIRType(builder.getContext(), TC1,
- KIND, /*params=*/{});
+ kind, /*params=*/{});
mlir::Value res = builder.convertWithSemantics(loc, type, lhs);
return hlfir::EntityWithAttributes{res};
}
@@ -1677,7 +1678,8 @@ class HlfirBuilder {
getConverter(), op.derived().GetType().GetDerivedTypeSpec());
} else {
elementType =
- Fortran::lower::getFIRType(builder.getContext(), R::category, R::kind,
+ Fortran::lower::getFIRType(builder.getContext(), R::category,
+ op.derived().GetType().value().kind(),
/*params=*/{});
}
mlir::Value shape = hlfir::genShape(loc, builder, left);
@@ -1730,7 +1732,8 @@ class HlfirBuilder {
// Elemental expression.
mlir::Type elementType =
- Fortran::lower::getFIRType(builder.getContext(), R::category, R::kind,
+ Fortran::lower::getFIRType(builder.getContext(), R::category,
+ op.derived().GetType().value().kind(),
/*params=*/{});
// TODO: "merge" shape, get cst shape from front-end if possible.
mlir::Value shape;
@@ -1786,8 +1789,8 @@ class HlfirBuilder {
getStmtCtx())
.genNamedEntity(desc.base());
using ResTy = Fortran::evaluate::DescriptorInquiry::Result;
- mlir::Type resultType =
- getConverter().genType(ResTy::category, ResTy::kind);
+ mlir::Type resultType = getConverter().genType(
+ ResTy::category, Fortran::evaluate::subscriptIntegerKind);
auto castResult = [&](mlir::Value v) {
return hlfir::EntityWithAttributes{
builder.createConvert(loc, resultType, v)};
diff --git a/flang/lib/Lower/ConvertType.cpp b/flang/lib/Lower/ConvertType.cpp
index 974fcd44e3b05..acb023ce61164 100644
--- a/flang/lib/Lower/ConvertType.cpp
+++ b/flang/lib/Lower/ConvertType.cpp
@@ -55,8 +55,7 @@ static mlir::Type genRealType(mlir::MLIRContext *context, int kind) {
template <int KIND>
int getIntegerBits() {
- return Fortran::evaluate::Type<Fortran::common::TypeCategory::Integer,
- KIND>::Scalar::bits;
+ return 8 * KIND;
}
static mlir::Type genIntegerType(mlir::MLIRContext *context, int kind,
bool isUnsigned = false) {
@@ -66,6 +65,7 @@ static mlir::Type genIntegerType(mlir::MLIRContext *context, int kind,
(isUnsigned ? mlir::IntegerType::SignednessSemantics::Unsigned
: mlir::IntegerType::SignednessSemantics::Signless);
+ // PAPAYA: return 8*kind;
switch (kind) {
case 1:
return mlir::IntegerType::get(context, getIntegerBits<1>(), signedness);
@@ -488,11 +488,10 @@ struct TypeBuilderImpl {
// To get the character length from a symbol, make an fold a designator for
// the symbol to cover the case where the symbol is an assumed length named
// constant and its length comes from its init expression length.
- template <int Kind>
fir::SequenceType::Extent
getCharacterLengthHelper(const Fortran::semantics::Symbol &symbol) {
using TC =
- Fortran::evaluate::Type<Fortran::common::TypeCategory::Character, Kind>;
+ Fortran::evaluate::Type<Fortran::common::TypeCategory::Character>;
auto designator = Fortran::evaluate::Fold(
converter.getFoldingContext(),
Fortran::evaluate::Expr<TC>{Fortran::evaluate::Designator<TC>{symbol}});
@@ -517,17 +516,7 @@ struct TypeBuilderImpl {
type->category() != Fortran::semantics::DeclTypeSpec::Character ||
!type->AsIntrinsic())
llvm::report_fatal_error("not a character symbol");
- int kind =
- toInt64(Fortran::common::Clone(type->AsIntrinsic()->kind())).value();
- switch (kind) {
- case 1:
- return getCharacterLengthHelper<1>(symbol);
- case 2:
- return getCharacterLengthHelper<2>(symbol);
- case 4:
- return getCharacterLengthHelper<4>(symbol);
- }
- llvm_unreachable("unknown character kind");
+ return getCharacterLengthHelper(symbol);
}
template <typename A>
diff --git a/flang/lib/Lower/Support/Utils.cpp b/flang/lib/Lower/Support/Utils.cpp
index 6d38e1ff550a4..3c9b151ecf80c 100644
--- a/flang/lib/Lower/Support/Utils.cpp
+++ b/flang/lib/Lower/Support/Utils.cpp
@@ -98,17 +98,14 @@ class HashEvaluateExpr {
static unsigned getHashValue(const Fortran::evaluate::ComplexPart &x) {
return getHashValue(x.complex()) - static_cast<unsigned>(x.part());
}
- template <Fortran::common::TypeCategory TC1, int KIND,
+ template <Fortran::common::TypeCategory TC1,
Fortran::common::TypeCategory TC2>
static unsigned getHashValue(
- const Fortran::evaluate::Convert<Fortran::evaluate::Type<TC1, KIND>, TC2>
- &x) {
+ const Fortran::evaluate::Convert<Fortran::evaluate::Type<TC1>, TC2> &x) {
return getHashValue(x.left()) - (static_cast<unsigned>(TC1) + 2u) -
- (static_cast<unsigned>(KIND) + 5u);
+ (static_cast<unsigned>(x.GetType().value().kind()) + 5u);
}
- template <int KIND>
- static unsigned
- getHashValue(const Fortran::evaluate::ComplexComponent<KIND> &x) {
+ static unsigned getHashValue(const Fortran::evaluate::ComplexComponent &x) {
return getHashValue(x.left()) -
(static_cast<unsigned>(x.isImaginaryPart) + 1u) * 3u;
}
@@ -116,47 +113,53 @@ class HashEvaluateExpr {
static unsigned getHashValue(const Fortran::evaluate::Parentheses<T> &x) {
return getHashValue(x.left()) * 17u;
}
- template <Fortran::common::TypeCategory TC, int KIND>
+ template <Fortran::common::TypeCategory TC>
static unsigned getHashValue(
- const Fortran::evaluate::Negate<Fortran::evaluate::Type<TC, KIND>> &x) {
+ const Fortran::evaluate::Negate<Fortran::evaluate::Type<TC>> &x) {
return getHashValue(x.left()) - (static_cast<unsigned>(TC) + 5u) -
- (static_cast<unsigned>(KIND) + 7u);
+ (static_cast<unsigned>(x.GetType().value().kind()) + 7u);
}
- template <Fortran::common::TypeCategory TC, int KIND>
- static unsigned getHashValue(
- const Fortran::evaluate::Add<Fortran::evaluate::Type<TC, KIND>> &x) {
+ template <Fortran::common::TypeCategory TC>
+ static unsigned
+ getHashValue(const Fortran::evaluate::Add<Fortran::evaluate::Type<TC>> &x) {
return (getHashValue(x.left()) + getHashValue(x.right())) * 23u +
- static_cast<unsigned>(TC) + static_cast<unsigned>(KIND);
+ static_cast<unsigned>(TC) +
+ static_cast<unsigned>(x.GetType().value().kind());
}
- template <Fortran::common::TypeCategory TC, int KIND>
+ template <Fortran::common::TypeCategory TC>
static unsigned getHashValue(
- const Fortran::evaluate::Subtract<Fortran::evaluate::Type<TC, KIND>> &x) {
+ const Fortran::evaluate::Subtract<Fortran::evaluate::Type<TC>> &x) {
return (getHashValue(x.left()) - getHashValue(x.right())) * 19u +
- static_cast<unsigned>(TC) + static_cast<unsigned>(KIND);
+ static_cast<unsigned>(TC) +
+ static_cast<unsigned>(x.GetType().value().kind());
}
- template <Fortran::common::TypeCategory TC, int KIND>
+ template <Fortran::common::TypeCategory TC>
static unsigned getHashValue(
- const Fortran::evaluate::Multiply<Fortran::evaluate::Type<TC, KIND>> &x) {
+ const Fortran::evaluate::Multiply<Fortran::evaluate::Type<TC>> &x) {
return (getHashValue(x.left()) + getHashValue(x.right())) * 29u +
- static_cast<unsigned>(TC) + static_cast<unsigned>(KIND);
+ static_cast<unsigned>(TC) +
+ static_cast<unsigned>(x.GetType().value().kind());
}
- template <Fortran::common::TypeCategory TC, int KIND>
+ template <Fortran::common::TypeCategory TC>
static unsigned getHashValue(
- const Fortran::evaluate::Divide<Fortran::evaluate::Type<TC, KIND>> &x) {
+ const Fortran::evaluate::Divide<Fortran::evaluate::Type<TC>> &x) {
return (getHashValue(x.left()) - getHashValue(x.right())) * 31u +
- static_cast<unsigned>(TC) + static_cast<unsigned>(KIND);
+ static_cast<unsigned>(TC) +
+ static_cast<unsigned>(x.GetType().value().kind());
}
- template <Fortran::common::TypeCategory TC, int KIND>
- static unsigned getHashValue(
- const Fortran::evaluate::Power<Fortran::evaluate::Type<TC, KIND>> &x) {
+ template <Fortran::common::TypeCategory TC>
+ static unsigned
+ getHashValue(const Fortran::evaluate::Power<Fortran::evaluate::Type<TC>> &x) {
return (getHashValue(x.left()) - getHashValue(x.right())) * 37u +
- static_cast<unsigned>(TC) + static_cast<unsigned>(KIND);
+ static_cast<unsigned>(TC) +
+ static_cast<unsigned>(x.GetType().value().kind());
}
- template <Fortran::common::TypeCategory TC, int KIND>
+ template <Fortran::common::TypeCategory TC>
static unsigned getHashValue(
- const Fortran::evaluate::Extremum<Fortran::evaluate::Type<TC, KIND>> &x) {
+ const Fortran::evaluate::Extremum<Fortran::evaluate::Type<TC>> &x) {
return (getHashValue(x.left()) + getHashValue(x.right())) * 41u +
- static_cast<unsigned>(TC) + static_cast<unsigned>(KIND) +
+ static_cast<unsigned>(TC) +
+ static_cast<unsigned>(x.GetType().value().kind()) +
static_cast<unsigned>(x.ordering) * 7u;
}
template <typename T>
@@ -164,28 +167,23 @@ class HashEvaluateExpr {
return getHashValue(x.condition()) * 151u -
getHashValue(x.thenValue()) * 3u + getHashValue(x.elseValue());
}
- template <Fortran::common::TypeCategory TC, int KIND>
+ template <Fortran::common::TypeCategory TC>
static unsigned getHashValue(
- const Fortran::evaluate::RealToIntPower<Fortran::evaluate::Type<TC, KIND>>
- &x) {
+ const Fortran::evaluate::RealToIntPower<Fortran::evaluate::Type<TC>> &x) {
return (getHashValue(x.left()) - getHashValue(x.right())) * 43u +
- static_cast<unsigned>(TC) + static_cast<unsigned>(KIND);
+ static_cast<unsigned>(TC) +
+ static_cast<unsigned>(x.GetType().value().kind());
}
- template <int KIND>
- static unsigned
- getHashValue(const Fortran::evaluate::ComplexConstructor<KIND> &x) {
+ static unsigned getHashValue(const Fortran::evaluate::ComplexConstructor &x) {
return (getHashValue(x.left()) - getHashValue(x.right())) * 47u +
- static_cast<unsigned>(KIND);
+ static_cast<unsigned>(x.GetType().value().kind());
}
- template <int KIND>
- static unsigned getHashValue(const Fortran::evaluate::Concat<KIND> &x) {
+ static unsigned getHashValue(const Fortran::evaluate::Concat &x) {
return (getHashValue(x.left()) - getHashValue(x.right())) * 53u +
- static_cast<unsigned>(KIND);
+ static_cast<unsigned>(x.GetType().value().kind());
}
- template <int KIND>
- static unsigned getHashValue(const Fortran::evaluate::SetLength<KIND> &x) {
- return (getHashValue(x.left()) - getHashValue(x.right())) * 59u +
- static_cast<unsigned>(KIND);
+ static unsigned getHashValue(const Fortran::evaluate::SetLength &x) {
+ return (getHashValue(x.left()) - getHashValue(x.right())) * 59u;
}
static unsigned getHashValue(const Fortran::semantics::SymbolRef &sym) {
return getHashValue(sym.get());
@@ -247,22 +245,19 @@ class HashEvaluateExpr {
// FIXME: hash the contents.
return 149u;
}
- template <int KIND>
- static unsigned getHashValue(const Fortran::evaluate::Not<KIND> &x) {
- return getHashValue(x.left()) * 61u + static_cast<unsigned>(KIND);
+ static unsigned getHashValue(const Fortran::evaluate::Not &x) {
+ return getHashValue(x.left()) * 61u;
}
- template <int KIND>
- static unsigned
- getHashValue(const Fortran::evaluate::LogicalOperation<KIND> &x) {
+ static unsigned getHashValue(const Fortran::evaluate::LogicalOperation &x) {
unsigned result = getHashValue(x.left()) + getHashValue(x.right());
return result * 67u + static_cast<unsigned>(x.logicalOperator) * 5u;
}
- template <Fortran::common::TypeCategory TC, int KIND>
+ template <Fortran::common::TypeCategory TC>
static unsigned getHashValue(
- const Fortran::evaluate::Relational<Fortran::evaluate::Type<TC, KIND>>
- &x) {
+ const Fortran::evaluate::Relational<Fortran::evaluate::Type<TC>> &x) {
return (getHashValue(x.left()) + getHashValue(x.right())) * 71u +
- static_cast<unsigned>(TC) + static_cast<unsigned>(KIND) +
+ static_cast<unsigned>(TC) +
+ static_cast<unsigned>(x.left().GetType().value().kind()) +
static_cast<unsigned>(x.opr) * 11u;
}
template <typename A>
@@ -280,9 +275,8 @@ class HashEvaluateExpr {
return Fortran::common::visit(
[&](const auto &v) { return getHashValue(v); }, x.u);
}
- template <int BITS>
static unsigned
- getHashValue(const Fortran::evaluate::value::Integer<BITS> &x) {
+ getHashValue(const Fortran::evaluate::value::IntegerValue &x) {
return static_cast<unsigned>(x.ToSInt());
}
static unsigned getHashValue(const Fortran::evaluate::NullPointer &x) {
@@ -372,9 +366,8 @@ class IsEqualEvaluateExpr {
const Fortran::evaluate::Convert<A, TC2> &y) {
return isEqual(x.left(), y.left());
}
- template <int KIND>
- static bool isEqual(const Fortran::evaluate::ComplexComponent<KIND> &x,
- const Fortran::evaluate::ComplexComponent<KIND> &y) {
+ static bool isEqual(const Fortran::evaluate::ComplexComponent &x,
+ const Fortran::evaluate::ComplexComponent &y) {
return isEqual(x.left(), y.left()) &&
x.isImaginaryPart == y.isImaginaryPart;
}
@@ -434,19 +427,16 @@ class IsEqualEvaluateExpr {
const Fortran::evaluate::RealToIntPower<A> &y) {
return isBinaryEqual(x, y);
}
- template <int KIND>
- static bool isEqual(const Fortran::evaluate::ComplexConstructor<KIND> &x,
- const Fortran::evaluate::ComplexConstructor<KIND> &y) {
+ static bool isEqual(const Fortran::evaluate::ComplexConstructor &x,
+ const Fortran::evaluate::ComplexConstructor &y) {
return isBinaryEqual(x, y);
}
- template <int KIND>
- static bool isEqual(const Fortran::evaluate::Concat<KIND> &x,
- const Fortran::evaluate::Concat<KIND> &y) {
+ static bool isEqual(const Fortran::evaluate::Concat &x,
+ const Fortran::evaluate::Concat &y) {
return isBinaryEqual(x, y);
}
- template <int KIND>
- static bool isEqual(const Fortran::evaluate::SetLength<KIND> &x,
- const Fortran::evaluate::SetLength<KIND> &y) {
+ static bool isEqual(const Fortran::evaluate::SetLength &x,
+ const Fortran::evaluate::SetLength &y) {
return isBinaryEqual(x, y);
}
static bool isEqual(const Fortran::semantics::SymbolRef &x,
@@ -567,14 +557,12 @@ class IsEqualEvaluateExpr {
}
return true;
}
- template <int KIND>
- static bool isEqual(const Fortran::evaluate::Not<KIND> &x,
- const Fortran::evaluate::Not<KIND> &y) {
+ static bool isEqual(const Fortran::evaluate::Not &x,
+ const Fortran::evaluate::Not &y) {
return isEqual(x.left(), y.left());
}
- template <int KIND>
- static bool isEqual(const Fortran::evaluate::LogicalOperation<KIND> &x,
- const Fortran::evaluate::LogicalOperation<KIND> &y) {
+ static bool isEqual(const Fortran::evaluate::LogicalOperation &x,
+ const Fortran::evaluate::LogicalOperation &y) {
return isEqual(x.left(), y.left()) && isEqual(x.right(), y.right());
}
template <typename A>
@@ -600,9 +588,8 @@ class IsEqualEvaluateExpr {
return Fortran::common::visit(
[&](const auto &v, const auto &w) { return isEqual(v, w); }, x.u, y.u);
}
- template <int BITS>
- static bool isEqual(const Fortran::evaluate::value::Integer<BITS> &x,
- const Fortran::evaluate::value::Integer<BITS> &y) {
+ static bool isEqual(const Fortran::evaluate::value::IntegerValue &x,
+ const Fortran::evaluate::value::IntegerValue &y) {
return x == y;
}
static bool isEqual(const Fortran::evaluate::NullPointer &x,
diff --git a/flang/lib/Semantics/check-call.cpp b/flang/lib/Semantics/check-call.cpp
index da8880482d4dc..d4e5410b65f5a 100644
--- a/flang/lib/Semantics/check-call.cpp
+++ b/flang/lib/Semantics/check-call.cpp
@@ -259,7 +259,10 @@ static void CheckCharacterActual(evaluate::Expr<evaluate::SomeType> &actual,
ConvertToType(dummy.type.type(), std::move(actual))};
CHECK(converted);
actual = std::move(*converted);
- actualType.set_LEN(SubscriptIntExpr{*dummyLength});
+ actualType.set_LEN(SubscriptIntExpr{
+ evaluate::Constant<evaluate::SubscriptInteger>{
+ evaluate::SubscriptInteger::Scalar{
+ *dummyLength, evaluate::subscriptIntegerKind}}});
}
}
}
diff --git a/flang/lib/Semantics/check-case.cpp b/flang/lib/Semantics/check-case.cpp
index 9004d8b3a28f9..0b48f3464fd7d 100644
--- a/flang/lib/Semantics/check-case.cpp
+++ b/flang/lib/Semantics/check-case.cpp
@@ -84,8 +84,18 @@ template <typename T> class CaseValues {
evaluate::FoldingContext foldingContext{
context_.foldingContext(), foldingMessages};
auto folded{evaluate::Fold(foldingContext, SomeExpr{*x->v})};
+ // Convert each CASE value to the category and kind of the SELECT CASE
+ // expression, but without its length. The legacy static-kind code
+ // converted to T::GetType() (category + kind only); replicate that so
+ // that CHARACTER case values are not padded to the selector's length
+ // and LOGICAL case values are canonicalized to KIND=1, keeping the
+ // conflicting-case diagnostics stable.
+ evaluate::DynamicType convertType{caseExprType_.category(),
+ caseExprType_.category() == TypeCategory::Logical
+ ? 1
+ : caseExprType_.kind()};
if (auto converted{evaluate::Fold(foldingContext,
- evaluate::ConvertToType(T::GetType(), SomeExpr{folded}))}) {
+ evaluate::ConvertToType(convertType, SomeExpr{folded}))}) {
if (auto value{evaluate::GetScalarConstantValue<T>(*converted)}) {
auto back{evaluate::Fold(foldingContext,
evaluate::ConvertToType(*type, SomeExpr{*converted}))};
@@ -224,12 +234,8 @@ template <TypeCategory CAT> struct TypeVisitor {
using Result = bool;
using Types = evaluate::CategoryTypes<CAT>;
template <typename T> Result Test() {
- if (T::kind == exprType.kind()) {
- CaseValues<T>(context, exprType).Check(caseList);
- return true;
- } else {
- return false;
- }
+ CaseValues<T>(context, exprType).Check(caseList);
+ return true;
}
SemanticsContext &context;
const evaluate::DynamicType &exprType;
@@ -259,7 +265,7 @@ void CaseChecker::Enter(const parser::CaseConstruct &construct) {
TypeVisitor<TypeCategory::Unsigned>{context_, *exprType, caseList});
return;
case TypeCategory::Logical:
- CaseValues<evaluate::Type<TypeCategory::Logical, 1>>{context_, *exprType}
+ CaseValues<evaluate::Type<TypeCategory::Logical>>{context_, *exprType}
.Check(caseList);
return;
case TypeCategory::Character:
diff --git a/flang/lib/Semantics/check-coarray.cpp b/flang/lib/Semantics/check-coarray.cpp
index 00b97162ff0d4..b2861b7b8a543 100644
--- a/flang/lib/Semantics/check-coarray.cpp
+++ b/flang/lib/Semantics/check-coarray.cpp
@@ -209,7 +209,7 @@ void CoarrayChecker::Leave(const parser::SyncImagesStmt &x) {
someInt && evaluate::IsActuallyConstant(*someInt)) {
auto converted{evaluate::Fold(context_.foldingContext(),
evaluate::ConvertToType<evaluate::SubscriptInteger>(
- common::Clone(*someInt)))};
+ evaluate::subscriptIntegerKind, common::Clone(*someInt)))};
if (const auto *cst{
evaluate::UnwrapConstantValue<evaluate::SubscriptInteger>(
converted)}) {
diff --git a/flang/lib/Semantics/check-data.cpp b/flang/lib/Semantics/check-data.cpp
index 9dbbc163d85b3..b3094a78f02d4 100644
--- a/flang/lib/Semantics/check-data.cpp
+++ b/flang/lib/Semantics/check-data.cpp
@@ -27,7 +27,7 @@ namespace Fortran::semantics {
void DataChecker::Enter(const parser::DataImpliedDo &x) {
const auto &name{parser::UnwrapRef<parser::Name>(
std::get<parser::DataImpliedDo::Bounds>(x.t).Name())};
- int kind{evaluate::ResultType<evaluate::ImpliedDoIndex>::kind};
+ int kind{evaluate::subscriptIntegerKind};
if (const auto dynamicType{evaluate::DynamicType::From(DEREF(name.symbol))}) {
if (dynamicType->category() == TypeCategory::Integer) {
kind = dynamicType->kind();
diff --git a/flang/lib/Semantics/check-io.h b/flang/lib/Semantics/check-io.h
index 96a07ce13f7bb..966ee3f2f4ef2 100644
--- a/flang/lib/Semantics/check-io.h
+++ b/flang/lib/Semantics/check-io.h
@@ -91,8 +91,12 @@ class IoChecker : public virtual BaseChecker {
const auto foldExpr{
evaluate::Fold(context_.foldingContext(), common::Clone(*expr))};
if constexpr (std::is_same_v<R, std::string>) {
- return evaluate::GetScalarConstantValue<DefaultCharConstantType>(
- foldExpr);
+ if (auto charVal{
+ evaluate::GetScalarConstantValue<DefaultCharConstantType>(
+ foldExpr)}) {
+ return charVal->ToStdString();
+ }
+ return std::nullopt;
} else {
static_assert(std::is_same_v<R, std::int64_t>, "unexpected type");
return evaluate::ToInt64(foldExpr);
diff --git a/flang/lib/Semantics/check-omp-atomic.cpp b/flang/lib/Semantics/check-omp-atomic.cpp
index a61a868c9baa4..478bf461be218 100644
--- a/flang/lib/Semantics/check-omp-atomic.cpp
+++ b/flang/lib/Semantics/check-omp-atomic.cpp
@@ -59,8 +59,7 @@ template <typename...> struct IsIntegral {
static constexpr bool value{false};
};
-template <common::TypeCategory C, int K>
-struct IsIntegral<evaluate::Type<C, K>> {
+template <common::TypeCategory C> struct IsIntegral<evaluate::Type<C>> {
static constexpr bool value{//
C == common::TypeCategory::Integer ||
C == common::TypeCategory::Unsigned};
@@ -72,8 +71,7 @@ template <typename...> struct IsFloatingPoint {
static constexpr bool value{false};
};
-template <common::TypeCategory C, int K>
-struct IsFloatingPoint<evaluate::Type<C, K>> {
+template <common::TypeCategory C> struct IsFloatingPoint<evaluate::Type<C>> {
static constexpr bool value{//
C == common::TypeCategory::Real || C == common::TypeCategory::Complex};
};
@@ -88,8 +86,7 @@ template <typename...> struct IsLogical {
static constexpr bool value{false};
};
-template <common::TypeCategory C, int K>
-struct IsLogical<evaluate::Type<C, K>> {
+template <common::TypeCategory C> struct IsLogical<evaluate::Type<C>> {
static constexpr bool value{C == common::TypeCategory::Logical};
};
@@ -160,7 +157,7 @@ struct ReassocRewriter : public evaluate::rewrite::Identity {
// Since this works with clang, MSVC and at least GCC 8.5, I'm assuming
// that this is some kind of a GCC issue.
using MatchTypes = std::tuple<evaluate::Add<T>, evaluate::Multiply<T>,
- evaluate::LogicalOperation<T::kind>>;
+ evaluate::LogicalOperation>;
#else
using MatchTypes = typename decltype(outer1)::MatchTypes;
#endif
@@ -212,8 +209,7 @@ struct ReassocRewriter : public evaluate::rewrite::Identity {
if constexpr (!common::HasMember<TypeS, MatchTypes>) {
return evaluate::Expr<T>(TypeS(op));
} else if constexpr (is_logical_v<T>) {
- constexpr int K{T::kind};
- if constexpr (std::is_same_v<TypeS, evaluate::LogicalOperation<K>>) {
+ if constexpr (std::is_same_v<TypeS, evaluate::LogicalOperation>) {
// Logical operators take an extra argument in their constructor,
// so they need their own reconstruction code.
common::LogicalOperator opCode{op.logicalOperator};
diff --git a/flang/lib/Semantics/data-to-inits.cpp b/flang/lib/Semantics/data-to-inits.cpp
index cd9ec3059afec..2217910ddabfc 100644
--- a/flang/lib/Semantics/data-to-inits.cpp
+++ b/flang/lib/Semantics/data-to-inits.cpp
@@ -207,7 +207,7 @@ bool DataInitializationCompiler<DSV>::Scan(const parser::DataImpliedDo &ido) {
auto foldedUpper{evaluate::Fold(context, SomeExpr{*upperExpr})};
auto upper{ToInt64(foldedUpper)};
if (lower && upper) {
- int kind{evaluate::ResultType<evaluate::ImpliedDoIndex>::kind};
+ int kind{evaluate::subscriptIntegerKind};
if (const auto dynamicType{evaluate::DynamicType::From(*name.symbol)}) {
if (dynamicType->category() == TypeCategory::Integer) {
kind = dynamicType->kind();
@@ -828,8 +828,8 @@ static bool CombineEquivalencedInitialization(
(bytes % minElementBytes) != 0) {
minElementBytes = 1;
}
- const DeclTypeSpec &typeSpec{scope.MakeNumericType(
- TypeCategory::Integer, KindExpr{minElementBytes})};
+ const DeclTypeSpec &typeSpec{scope.MakeNumericType(TypeCategory::Integer,
+ KindExpr{static_cast<std::int64_t>(minElementBytes)})};
details.set_type(typeSpec);
ArraySpec arraySpec;
arraySpec.emplace_back(ShapeSpec::MakeExplicit(Bound{
diff --git a/flang/lib/Semantics/dump-expr.cpp b/flang/lib/Semantics/dump-expr.cpp
index 8d354cf65b61e..a68f6c6715dd6 100644
--- a/flang/lib/Semantics/dump-expr.cpp
+++ b/flang/lib/Semantics/dump-expr.cpp
@@ -218,12 +218,7 @@ void DumpEvaluateExpr::Outdent() {
void DumpEvExpr(const SomeExpr &x) { DumpEvaluateExpr::Dump(x); }
void DumpEvExpr(
- const evaluate::Expr<evaluate::Type<common::TypeCategory::Integer, 4>> &x) {
- DumpEvaluateExpr::Dump(x);
-}
-
-void DumpEvExpr(
- const evaluate::Expr<evaluate::Type<common::TypeCategory::Integer, 8>> &x) {
+ const evaluate::Expr<evaluate::Type<common::TypeCategory::Integer>> &x) {
DumpEvaluateExpr::Dump(x);
}
@@ -234,7 +229,7 @@ void DumpEvExpr(const evaluate::DataRef &x) { DumpEvaluateExpr::Dump(x); }
void DumpEvExpr(const evaluate::Substring &x) { DumpEvaluateExpr::Dump(x); }
void DumpEvExpr(
- const evaluate::Designator<evaluate::Type<common::TypeCategory::Integer, 4>>
+ const evaluate::Designator<evaluate::Type<common::TypeCategory::Integer>>
&x) {
DumpEvaluateExpr::Dump(x);
}
diff --git a/flang/lib/Semantics/expression.cpp b/flang/lib/Semantics/expression.cpp
index 50869a3c870ef..793d1d5b707a4 100644
--- a/flang/lib/Semantics/expression.cpp
+++ b/flang/lib/Semantics/expression.cpp
@@ -87,7 +87,9 @@ static std::optional<DynamicTypeWithLength> AnalyzeTypeSpec(
if (auto lenExpr{type.LEN()}) {
type.length = Fold(context,
AsExpr(Extremum<SubscriptInteger>{Ordering::Greater,
- Expr<SubscriptInteger>{0}, std::move(*lenExpr)}));
+ Expr<SubscriptInteger>{Constant<SubscriptInteger>{
+ SubscriptInteger::Scalar{0, subscriptIntegerKind}}},
+ std::move(*lenExpr)}));
}
return type;
} else {
@@ -722,61 +724,56 @@ int ExpressionAnalyzer::AnalyzeKindParam(
}
// Common handling of parser::IntLiteralConstant, SignedIntLiteralConstant,
-// and UnsignedLiteralConstant
-template <typename TYPES, TypeCategory CAT> struct IntTypeVisitor {
- using Result = MaybeExpr;
- using Types = TYPES;
- template <typename T> Result Test() {
- if (T::kind >= kind) {
- const char *p{digits.begin()};
- using Int = typename T::Scalar;
- typename Int::ValueWithOverflow num{0, false};
- const char *typeName{
- CAT == TypeCategory::Integer ? "INTEGER" : "UNSIGNED"};
- if (isNegated) {
- auto unsignedNum{Int::Read(p, 10, false /*unsigned*/)};
- num.value = unsignedNum.value.Negate().value;
- num.overflow = unsignedNum.overflow ||
- (CAT == TypeCategory::Integer && num.value > Int{0});
- if (!num.overflow && num.value.Negate().overflow) {
- analyzer.Warn(LanguageFeature::BigIntLiterals, digits,
- "negated maximum INTEGER(KIND=%d) literal"_port_en_US, T::kind);
- }
- } else {
- num = Int::Read(p, 10, /*isSigned=*/CAT == TypeCategory::Integer);
- }
- if (num.overflow) {
- if constexpr (CAT == TypeCategory::Unsigned) {
- analyzer.Warn(common::UsageWarning::UnsignedLiteralTruncation,
- "Unsigned literal too large for UNSIGNED(KIND=%d); truncated"_warn_en_US,
- kind);
- return Expr<SomeType>{
- Expr<SomeKind<CAT>>{Expr<T>{Constant<T>{std::move(num.value)}}}};
- }
+// and UnsignedLiteralConstant. Reads the literal at a candidate kind
+// (tryKind); returns the constant if it fits, or std::nullopt to request a
+// wider kind. The result kind is carried at runtime in the constant.
+template <TypeCategory CAT>
+static MaybeExpr ReadIntLiteralAtKind(ExpressionAnalyzer &analyzer,
+ parser::CharBlock digits, int requestedKind, int tryKind,
+ bool isDefaultKind, bool isNegated) {
+ using T = Type<CAT>;
+ using Int = Scalar<T>;
+ const char *p{digits.begin()};
+ typename Int::ValueWithOverflow num{Int{0, tryKind}, false};
+ const char *typeName{CAT == TypeCategory::Integer ? "INTEGER" : "UNSIGNED"};
+ if (isNegated) {
+ auto unsignedNum{Int::Read(p, 10, false /*unsigned*/, 8 * tryKind)};
+ num.value = unsignedNum.value.Negate().value;
+ num.overflow = unsignedNum.overflow ||
+ (CAT == TypeCategory::Integer && num.value > Int{0, tryKind});
+ if (!num.overflow && num.value.Negate().overflow) {
+ analyzer.Warn(LanguageFeature::BigIntLiterals, digits,
+ "negated maximum INTEGER(KIND=%d) literal"_port_en_US, tryKind);
+ }
+ } else {
+ num = Int::Read(
+ p, 10, /*isSigned=*/CAT == TypeCategory::Integer, 8 * tryKind);
+ }
+ if (num.overflow) {
+ if constexpr (CAT == TypeCategory::Unsigned) {
+ analyzer.Warn(common::UsageWarning::UnsignedLiteralTruncation,
+ "Unsigned literal too large for UNSIGNED(KIND=%d); truncated"_warn_en_US,
+ requestedKind);
+ return Expr<SomeType>{Expr<SomeKind<CAT>>{
+ Expr<T>{Constant<T>{std::move(num.value), T{requestedKind}}}}};
+ }
+ } else {
+ if (tryKind > requestedKind) {
+ if (!isDefaultKind ||
+ !analyzer.context().IsEnabled(LanguageFeature::BigIntLiterals)) {
+ return std::nullopt;
} else {
- if (T::kind > kind) {
- if (!isDefaultKind ||
- !analyzer.context().IsEnabled(LanguageFeature::BigIntLiterals)) {
- return std::nullopt;
- } else {
- analyzer.Warn(LanguageFeature::BigIntLiterals, digits,
- "Integer literal is too large for default %s(KIND=%d); "
- "assuming %s(KIND=%d)"_port_en_US,
- typeName, kind, typeName, T::kind);
- }
- }
- return Expr<SomeType>{
- Expr<SomeKind<CAT>>{Expr<T>{Constant<T>{std::move(num.value)}}}};
+ analyzer.Warn(LanguageFeature::BigIntLiterals, digits,
+ "Integer literal is too large for default %s(KIND=%d); "
+ "assuming %s(KIND=%d)"_port_en_US,
+ typeName, requestedKind, typeName, tryKind);
}
}
- return std::nullopt;
+ return Expr<SomeType>{Expr<SomeKind<CAT>>{
+ Expr<T>{Constant<T>{std::move(num.value), T{tryKind}}}}};
}
- ExpressionAnalyzer &analyzer;
- parser::CharBlock digits;
- std::int64_t kind;
- bool isDefaultKind;
- bool isNegated;
-};
+ return std::nullopt;
+}
template <typename TYPES, TypeCategory CAT, typename PARSED>
MaybeExpr ExpressionAnalyzer::IntLiteralConstant(
@@ -787,10 +784,18 @@ MaybeExpr ExpressionAnalyzer::IntLiteralConstant(
const char *typeName{CAT == TypeCategory::Integer ? "INTEGER" : "UNSIGNED"};
if (CheckIntrinsicKind(CAT, kind)) {
auto digits{std::get<parser::CharBlock>(x.t)};
- if (MaybeExpr result{common::SearchTypes(IntTypeVisitor<TYPES, CAT>{
- *this, digits, kind, isDefaultKind, isNegated})}) {
- return result;
- } else if (isDefaultKind) {
+ // Try the requested kind first, then progressively wider kinds (the
+ // BigIntLiterals extension promotes too-large default-kind literals).
+ for (int tryKind : {1, 2, 4, 8, 16}) {
+ if (tryKind < kind) {
+ continue;
+ }
+ if (MaybeExpr result{ReadIntLiteralAtKind<CAT>(
+ *this, digits, kind, tryKind, isDefaultKind, isNegated)}) {
+ return result;
+ }
+ }
+ if (isDefaultKind) {
Say(digits,
"Integer literal is too large for any allowable kind of %s"_err_en_US,
typeName);
@@ -828,45 +833,23 @@ MaybeExpr ExpressionAnalyzer::Analyze(
}
template <typename TYPE>
-Constant<TYPE> ReadRealLiteral(
- parser::CharBlock source, FoldingContext &context, bool isDefaultKind) {
+Constant<TYPE> ReadRealLiteral(parser::CharBlock source, int kind,
+ FoldingContext &context, bool isDefaultKind) {
const char *p{source.begin()};
- auto valWithFlags{
- Scalar<TYPE>::Read(p, context.targetCharacteristics().roundingMode())};
+ auto valWithFlags{Scalar<TYPE>::Read(
+ p, kind, context.targetCharacteristics().roundingMode())};
CHECK(p == source.end());
context.RealFlagWarnings(valWithFlags.flags, "conversion of REAL literal");
auto value{valWithFlags.value};
if (context.targetCharacteristics().areSubnormalsFlushedToZero()) {
value = value.FlushSubnormalToZero();
}
- typename Constant<TYPE>::Result resultInfo;
+ typename Constant<TYPE>::Result resultInfo{kind};
resultInfo.set_isFromInexactLiteralConversion(
isDefaultKind && valWithFlags.flags.test(RealFlag::Inexact));
return {value, resultInfo};
}
-struct RealTypeVisitor {
- using Result = std::optional<Expr<SomeReal>>;
- using Types = RealTypes;
-
- RealTypeVisitor(
- int k, parser::CharBlock lit, FoldingContext &ctx, bool isDeftKind)
- : kind{k}, literal{lit}, context{ctx}, isDefaultKind{isDeftKind} {}
-
- template <typename T> Result Test() {
- if (kind == T::kind) {
- return {
- AsCategoryExpr(ReadRealLiteral<T>(literal, context, isDefaultKind))};
- }
- return std::nullopt;
- }
-
- int kind;
- parser::CharBlock literal;
- FoldingContext &context;
- bool isDefaultKind;
-};
-
// Reads a real literal constant and encodes it with the right kind.
MaybeExpr ExpressionAnalyzer::Analyze(const parser::RealLiteralConstant &x) {
const auto &[xreal, xkind](x.t);
@@ -918,12 +901,13 @@ MaybeExpr ExpressionAnalyzer::Analyze(const parser::RealLiteralConstant &x) {
}
}
bool isDefaultKind{!xkind && letterKind.value_or('e') == 'e'};
- auto result{common::SearchTypes(
- RealTypeVisitor{kind, xreal.source, GetFoldingContext(), isDefaultKind})};
- if (!result) { // C717
+ if (!common::IsValidKindOfIntrinsicType(TypeCategory::Real, kind)) { // C717
Say("Unsupported REAL(KIND=%d)"_err_en_US, kind);
+ return std::nullopt;
}
- return AsMaybeExpr(std::move(result));
+ return AsMaybeExpr(
+ AsCategoryExpr(ReadRealLiteral<evaluate::Type<TypeCategory::Real>>(
+ xreal.source, kind, GetFoldingContext(), isDefaultKind)));
}
MaybeExpr ExpressionAnalyzer::Analyze(
@@ -968,17 +952,20 @@ MaybeExpr ExpressionAnalyzer::AnalyzeString(std::string &&string, int kind) {
}
switch (kind) {
case 1:
- return AsGenericExpr(Constant<Type<TypeCategory::Character, 1>>{
- parser::DecodeString<std::string, parser::Encoding::LATIN_1>(
- string, true)});
+ return AsGenericExpr(
+ Constant<Type<TypeCategory::Character>>{evaluate::value::CharacterValue{
+ parser::DecodeString<std::string, parser::Encoding::LATIN_1>(
+ string, true)}});
case 2:
- return AsGenericExpr(Constant<Type<TypeCategory::Character, 2>>{
- parser::DecodeString<std::u16string, parser::Encoding::UTF_8>(
- string, true)});
+ return AsGenericExpr(
+ Constant<Type<TypeCategory::Character>>{evaluate::value::CharacterValue{
+ parser::DecodeString<std::u16string, parser::Encoding::UTF_8>(
+ string, true)}});
case 4:
- return AsGenericExpr(Constant<Type<TypeCategory::Character, 4>>{
- parser::DecodeString<std::u32string, parser::Encoding::UTF_8>(
- string, true)});
+ return AsGenericExpr(
+ Constant<Type<TypeCategory::Character>>{evaluate::value::CharacterValue{
+ parser::DecodeString<std::u32string, parser::Encoding::UTF_8>(
+ string, true)}});
default:
CRASH_NO_CASE;
}
@@ -1006,13 +993,15 @@ MaybeExpr ExpressionAnalyzer::Analyze(const parser::LogicalLiteralConstant &x) {
auto kind{AnalyzeKindParam(std::get<std::optional<parser::KindParam>>(x.t),
GetDefaultKind(TypeCategory::Logical))};
bool value{std::get<bool>(x.t)};
- auto result{common::SearchTypes(
- TypeKindVisitor<TypeCategory::Logical, Constant, bool>{
- kind, std::move(value)})};
- if (!result) {
+ if (!common::IsValidKindOfIntrinsicType(TypeCategory::Logical, kind)) {
Say("unsupported LOGICAL(KIND=%d)"_err_en_US, kind); // C728
+ return std::nullopt;
}
- return result;
+ // The runtime kind is now a property of the value rather than a template
+ // parameter, so it must be threaded into the LOGICAL constant explicitly
+ // (the generic TypeKindVisitor path would otherwise default it to kind 4).
+ return AsGenericExpr(Constant<Type<TypeCategory::Logical>>{
+ evaluate::value::LogicalValue{value, kind}});
}
// BOZ typeless literals
@@ -1035,7 +1024,7 @@ MaybeExpr ExpressionAnalyzer::Analyze(const parser::BOZLiteralConstant &x) {
}
CHECK(*p == '"');
++p;
- auto value{BOZLiteralConstant::Read(p, base, false /*unsigned*/)};
+ auto value{BOZLiteralConstant::Read(p, base, false /*unsigned*/, 128)};
if (*p != '"') {
Say("Invalid digit ('%c') in BOZ literal '%s'"_err_en_US, *p,
x.v); // C7107, C7108
@@ -1070,7 +1059,7 @@ MaybeExpr ExpressionAnalyzer::Analyze(const parser::Name &n) {
// while processing other specification expressions in the PDT
// definition; the right kind value will be used later in each of its
// instantiations.
- int kind{SubscriptInteger::kind};
+ int kind{subscriptIntegerKind};
if (const auto *typeSpec{ultimate.GetType()}) {
if (const semantics::IntrinsicTypeSpec *
intrinType{typeSpec->AsIntrinsic()}) {
@@ -1177,12 +1166,17 @@ std::optional<Expr<SubscriptInteger>> ExpressionAnalyzer::GetSubstringBound(
Say("substring bound expression has rank %d"_err_en_US, expr->Rank());
}
if (auto *intExpr{std::get_if<Expr<SomeInteger>>(&expr->u)}) {
- if (auto *ssIntExpr{std::get_if<Expr<SubscriptInteger>>(&intExpr->u)}) {
- return {std::move(*ssIntExpr)};
+ // The kind is now a runtime property, so SubscriptInteger is the only
+ // variant alternative; compare the runtime kind rather than the
+ // (always-matching) alternative before deciding to convert.
+ auto dyType{intExpr->GetType()};
+ if (dyType && dyType->kind() == subscriptIntegerKind) {
+ return {std::move(std::get<Expr<SubscriptInteger>>(intExpr->u))};
}
- return {Expr<SubscriptInteger>{
- Convert<SubscriptInteger, TypeCategory::Integer>{
- std::move(*intExpr)}}};
+ Convert<SubscriptInteger, TypeCategory::Integer> conv{
+ std::move(*intExpr)};
+ conv.resultKind_ = subscriptIntegerKind;
+ return {Expr<SubscriptInteger>{std::move(conv)}};
} else {
Say("substring bound expression is not INTEGER"_err_en_US);
}
@@ -1258,22 +1252,25 @@ MaybeExpr ExpressionAnalyzer::Analyze(
common::visit([](const auto &ckExpr) { return ckExpr.LEN().value(); },
charExpr->u)};
if (!lower) {
- lower = Expr<SubscriptInteger>{1};
+ lower = Expr<SubscriptInteger>{Constant<SubscriptInteger>{
+ SubscriptInteger::Scalar{1, subscriptIntegerKind}}};
}
if (!upper) {
upper = Expr<SubscriptInteger>{
- static_cast<std::int64_t>(ToInt64(length).value())};
+ Constant<SubscriptInteger>{SubscriptInteger::Scalar{
+ static_cast<std::int64_t>(ToInt64(length).value()),
+ subscriptIntegerKind}}};
}
return common::visit(
[&](auto &&ckExpr) -> MaybeExpr {
using Result = ResultType<decltype(ckExpr)>;
auto *cp{std::get_if<Constant<Result>>(&ckExpr.u)};
CHECK(DEREF(cp).size() == 1);
+ int charKind{ckExpr.GetType().value().kind()};
StaticDataObject::Pointer staticData{StaticDataObject::Create()};
- staticData->set_alignment(Result::kind)
- .set_itemBytes(Result::kind)
- .Push(cp->GetScalarValue().value(),
- foldingContext_.targetCharacteristics().isBigEndian());
+ staticData->set_alignment(charKind).set_itemBytes(charKind).Push(
+ cp->GetScalarValue().value(),
+ foldingContext_.targetCharacteristics().isBigEndian());
Substring substring{std::move(staticData), std::move(lower.value()),
std::move(upper.value())};
return AsGenericExpr(
@@ -1309,12 +1306,18 @@ std::optional<Expr<SubscriptInteger>> ExpressionAnalyzer::AsSubscript(
expr->Rank());
}
if (auto *intExpr{std::get_if<Expr<SomeInteger>>(&expr->u)}) {
- if (auto *ssIntExpr{std::get_if<Expr<SubscriptInteger>>(&intExpr->u)}) {
- return std::move(*ssIntExpr);
+ // Since the kind is now a runtime property there is a single integer
+ // Type per category, so SubscriptInteger is the only variant alternative
+ // and matching it no longer implies the value already has the subscript
+ // kind. Compare the runtime kind and convert when it differs.
+ auto dyType{intExpr->GetType()};
+ if (dyType && dyType->kind() == subscriptIntegerKind) {
+ return std::move(std::get<Expr<SubscriptInteger>>(intExpr->u));
} else {
- return Expr<SubscriptInteger>{
- Convert<SubscriptInteger, TypeCategory::Integer>{
- std::move(*intExpr)}};
+ Convert<SubscriptInteger, TypeCategory::Integer> conv{
+ std::move(*intExpr)};
+ conv.resultKind_ = subscriptIntegerKind;
+ return Expr<SubscriptInteger>{std::move(conv)};
}
} else {
Say("Subscript expression is not INTEGER"_err_en_US);
@@ -1573,8 +1576,8 @@ MaybeExpr ExpressionAnalyzer::Analyze(const parser::CoindexedNamedObject &x) {
std::get<std::list<parser::Cosubscript>>(selector.t)) {
MaybeExpr coex{Analyze(cosub)};
if (auto *intExpr{UnwrapExpr<Expr<SomeInteger>>(coex)}) {
- cosubscripts.push_back(
- ConvertToType<SubscriptInteger>(std::move(*intExpr)));
+ cosubscripts.push_back(ConvertToType<SubscriptInteger>(
+ subscriptIntegerKind, std::move(*intExpr)));
} else {
cosubsOk = false;
}
@@ -1708,8 +1711,9 @@ class ArrayConstructorContext {
return AsMaybeExpr(ArrayConstructor<T>{type_->GetDerivedTypeSpec(),
MakeSpecific<T>(std::move(values_))});
}
- } else if (type_->kind() == T::kind) {
+ } else {
ArrayConstructor<T> result{MakeSpecific<T>(std::move(values_))};
+ result.resultKind_ = type_->kind();
if constexpr (T::category == TypeCategory::Character) {
if (auto len{LengthIfGood()}) {
// The ac-do-variables may be treated as constant expressions,
@@ -1761,23 +1765,20 @@ class ArrayConstructorContext {
parser::CharBlock name, std::int64_t lower, std::int64_t upper,
std::int64_t stride);
- template <int KIND>
- std::optional<Expr<Type<TypeCategory::Integer, KIND>>> ToSpecificInt(
- MaybeExpr &&y) {
+ std::optional<Expr<ImpliedDoIntType>> ToSpecificInt(MaybeExpr &&y) {
if (y) {
Expr<SomeInteger> *intExpr{UnwrapExpr<Expr<SomeInteger>>(*y)};
return Fold(exprAnalyzer_.GetFoldingContext(),
- ConvertToType<Type<TypeCategory::Integer, KIND>>(
- std::move(DEREF(intExpr))));
+ ConvertToType<ImpliedDoIntType>(
+ subscriptIntegerKind, std::move(DEREF(intExpr))));
} else {
return std::nullopt;
}
}
- template <int KIND, typename A>
- std::optional<Expr<Type<TypeCategory::Integer, KIND>>> GetSpecificIntExpr(
- const A &x) {
- return ToSpecificInt<KIND>(exprAnalyzer_.Analyze(x));
+ template <typename A>
+ std::optional<Expr<ImpliedDoIntType>> GetSpecificIntExpr(const A &x) {
+ return ToSpecificInt(exprAnalyzer_.Analyze(x));
}
// Nested array constructors all reference the same ExpressionAnalyzer,
@@ -1945,13 +1946,13 @@ void ArrayConstructorContext::Add(const parser::AcValue::Triplet &triplet) {
if (strideType->kind() > kind) {
kind = strideType->kind();
}
- auto lower{ToSpecificInt<ImpliedDoIntType::kind>(std::move(lowerExpr))};
- auto upper{ToSpecificInt<ImpliedDoIntType::kind>(std::move(upperExpr))};
+ auto lower{ToSpecificInt(std::move(lowerExpr))};
+ auto upper{ToSpecificInt(std::move(upperExpr))};
if (lower && upper) {
- auto stride{
- ToSpecificInt<ImpliedDoIntType::kind>(std::move(strideExpr))};
+ auto stride{ToSpecificInt(std::move(strideExpr))};
if (!stride) {
- stride = Expr<ImpliedDoIntType>{1};
+ stride = Expr<ImpliedDoIntType>{Constant<ImpliedDoIntType>{
+ ImpliedDoIntType::Scalar{1, subscriptIntegerKind}}};
}
DynamicType type{TypeCategory::Integer, kind};
if (!type_) {
@@ -1985,7 +1986,7 @@ void ArrayConstructorContext::Add(const parser::AcImpliedDo &impliedDo) {
exprAnalyzer_.Analyze(bounds.Name());
const auto &parsedName{parser::UnwrapRef<parser::Name>(bounds.Name())};
parser::CharBlock name{parsedName.source};
- int kind{ImpliedDoIntType::kind};
+ int kind{subscriptIntegerKind};
if (const Symbol *symbol{parsedName.symbol}) {
if (auto dynamicType{DynamicType::From(symbol)}) {
if (dynamicType->category() == TypeCategory::Integer) {
@@ -1994,14 +1995,15 @@ void ArrayConstructorContext::Add(const parser::AcImpliedDo &impliedDo) {
}
}
std::optional<Expr<ImpliedDoIntType>> lower{
- GetSpecificIntExpr<ImpliedDoIntType::kind>(bounds.Lower())};
+ GetSpecificIntExpr(bounds.Lower())};
std::optional<Expr<ImpliedDoIntType>> upper{
- GetSpecificIntExpr<ImpliedDoIntType::kind>(bounds.Upper())};
+ GetSpecificIntExpr(bounds.Upper())};
if (lower && upper) {
std::optional<Expr<ImpliedDoIntType>> stride{
- GetSpecificIntExpr<ImpliedDoIntType::kind>(bounds.Step())};
+ GetSpecificIntExpr(bounds.Step())};
if (!stride) {
- stride = Expr<ImpliedDoIntType>{1};
+ stride = Expr<ImpliedDoIntType>{Constant<ImpliedDoIntType>{
+ ImpliedDoIntType::Scalar{1, subscriptIntegerKind}}};
}
if (exprAnalyzer_.AddImpliedDo(name, kind)) {
// Check for constant bounds; the loop may require complete unrolling
@@ -3512,8 +3514,8 @@ std::optional<Chevrons> ExpressionAnalyzer::AnalyzeChevrons(
return std::nullopt;
}
} else {
- result.emplace_back(
- AsGenericExpr(evaluate::Constant<evaluate::CInteger>{-1}));
+ result.emplace_back(AsGenericExpr(evaluate::Constant<evaluate::CInteger>{
+ evaluate::CInteger::Scalar{-1, evaluate::cIntegerKind}}));
}
if (auto expr{Analyze(std::get<1>(chevrons->t))};
expr && checkLaunchArg(*expr, "block")) {
@@ -4034,8 +4036,9 @@ MaybeExpr ExpressionAnalyzer::Analyze(const parser::ConditionalExpr &x) {
return common::visit(
common::visitors{
[&](Expr<SomeDerived> &&elseVal) -> MaybeExpr {
- Expr<LogicalResult> cond{ConvertToType<LogicalResult>(
- std::move(std::get<Expr<SomeLogical>>(condExpr->u)))};
+ Expr<LogicalResult> cond{
+ ConvertToType<LogicalResult>(logicalResultKind,
+ std::move(std::get<Expr<SomeLogical>>(condExpr->u)))};
Expr<SomeDerived> thenVal{
std::move(std::get<Expr<SomeDerived>>(thenExpr->u))};
return AsGenericExpr(
@@ -4055,6 +4058,7 @@ MaybeExpr ExpressionAnalyzer::Analyze(const parser::ConditionalExpr &x) {
using T =
typename std::decay_t<decltype(elseKindExpr)>::Result;
Expr<LogicalResult> cond{ConvertToType<LogicalResult>(
+ logicalResultKind,
std::move(std::get<Expr<SomeLogical>>(condExpr->u)))};
Expr<T> thenVal{std::move(std::get<Expr<T>>(
std::get<CategoryType>(thenExpr->u).u))};
@@ -4141,7 +4145,7 @@ MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::Concat &x) {
[&](auto &&x, auto &&y) -> MaybeExpr {
using T = ResultType<decltype(x)>;
if constexpr (std::is_same_v<T, ResultType<decltype(y)>>) {
- return AsGenericExpr(Concat<T::kind>{std::move(x), std::move(y)});
+ return AsGenericExpr(Concat{std::move(x), std::move(y)});
} else {
DIE("different types for intrinsic concat");
}
@@ -4571,7 +4575,8 @@ Expr<SubscriptInteger> ExpressionAnalyzer::AnalyzeKindSelector(
const std::optional<parser::KindSelector> &selector) {
int defaultKind{GetDefaultKind(category)};
if (!selector) {
- return Expr<SubscriptInteger>{defaultKind};
+ return Expr<SubscriptInteger>{Constant<SubscriptInteger>{
+ SubscriptInteger::Scalar{defaultKind, subscriptIntegerKind}}};
}
return common::visit(
common::visitors{
@@ -4579,13 +4584,16 @@ Expr<SubscriptInteger> ExpressionAnalyzer::AnalyzeKindSelector(
if (MaybeExpr kind{Analyze(x)}) {
if (std::optional<std::int64_t> code{ToInt64(*kind)}) {
if (CheckIntrinsicKind(category, *code)) {
- return Expr<SubscriptInteger>{*code};
+ return Expr<SubscriptInteger>{Constant<SubscriptInteger>{
+ SubscriptInteger::Scalar{*code, subscriptIntegerKind}}};
}
} else if (auto *intExpr{UnwrapExpr<Expr<SomeInteger>>(*kind)}) {
- return ConvertToType<SubscriptInteger>(std::move(*intExpr));
+ return ConvertToType<SubscriptInteger>(
+ subscriptIntegerKind, std::move(*intExpr));
}
}
- return Expr<SubscriptInteger>{defaultKind};
+ return Expr<SubscriptInteger>{Constant<SubscriptInteger>{
+ SubscriptInteger::Scalar{defaultKind, subscriptIntegerKind}}};
},
[&](const parser::KindSelector::StarSize &x) {
std::intmax_t size = x.v;
@@ -4594,7 +4602,8 @@ Expr<SubscriptInteger> ExpressionAnalyzer::AnalyzeKindSelector(
} else if (category == TypeCategory::Complex) {
size /= 2;
}
- return Expr<SubscriptInteger>{size};
+ return Expr<SubscriptInteger>{Constant<SubscriptInteger>{
+ SubscriptInteger::Scalar{size, subscriptIntegerKind}}};
},
},
selector->u);
@@ -4719,7 +4728,11 @@ MaybeExpr ExpressionAnalyzer::MakeFunctionRef(parser::CharBlock callSite,
if (result.IsProcedurePointer()) {
return Expr<SomeType>{std::move(procRef)};
} else {
- // Not a procedure pointer, so type and shape are known.
+ // Not a procedure pointer, so type and shape are known. The result
+ // kind is recorded on the FunctionRef by TypedWrapper so that
+ // FunctionRef::GetType() can recover it even when the procedure
+ // designator's symbol cannot provide a result type (e.g. user
+ // procedures declared with an intrinsic interface).
return TypedWrapper<FunctionRef, ProcedureRef>(
DEREF(result.GetTypeAndShape()).type(), std::move(procRef));
}
@@ -5350,7 +5363,7 @@ std::optional<ActualArgument> ArgumentAnalyzer::AnalyzeExpr(
// (or a smaller numeric type) by legacy code.
if (auto hollerith{UnwrapExpr<Constant<Ascii>>(*argExpr)};
hollerith && hollerith->wasHollerith()) {
- std::string bytes{hollerith->values()};
+ auto bytes{hollerith->values()};
while ((bytes.size() % 8) != 0) {
bytes += ' ';
}
@@ -5610,7 +5623,7 @@ bool ExprChecker::Pre(const parser::DataImpliedDo &ido) {
parser::Walk(std::get<parser::DataImpliedDo::Bounds>(ido.t), *this);
const auto &bounds{std::get<parser::DataImpliedDo::Bounds>(ido.t)};
const auto &name{parser::UnwrapRef<parser::Name>(bounds.Name())};
- int kind{evaluate::ResultType<evaluate::ImpliedDoIndex>::kind};
+ int kind{evaluate::subscriptIntegerKind};
if (const auto dynamicType{evaluate::DynamicType::From(DEREF(name.symbol))}) {
if (dynamicType->category() == TypeCategory::Integer) {
kind = dynamicType->kind();
diff --git a/flang/lib/Semantics/openmp-utils.cpp b/flang/lib/Semantics/openmp-utils.cpp
index 633ec2ae45aaa..22e28d5b8bac1 100644
--- a/flang/lib/Semantics/openmp-utils.cpp
+++ b/flang/lib/Semantics/openmp-utils.cpp
@@ -814,8 +814,8 @@ struct ArrayExpressionRecognizer {
return common::visit([](auto &&s) { return isArrayExpression(s); }, x.u);
}
- template <TypeCategory C, int K>
- static bool isArrayExpression(const evaluate::Expr<evaluate::Type<C, K>> &x) {
+ template <TypeCategory C>
+ static bool isArrayExpression(const evaluate::Expr<evaluate::Type<C>> &x) {
return common::visit([](auto &&s) { return isArrayExpression(s); },
evaluate::match::deparen(x).u);
}
diff --git a/flang/lib/Semantics/pointer-assignment.cpp b/flang/lib/Semantics/pointer-assignment.cpp
index 97179b4030147..d8ef60bfad5cb 100644
--- a/flang/lib/Semantics/pointer-assignment.cpp
+++ b/flang/lib/Semantics/pointer-assignment.cpp
@@ -535,11 +535,17 @@ static bool CheckPointerBounds(
},
[&](const evaluate::Assignment::BoundsRemapping &bounds) {
isBoundsRemapping = true;
- evaluate::ExtentExpr lhsSizeExpr{1};
+ evaluate::ExtentExpr lhsSizeExpr{
+ evaluate::Constant<evaluate::ExtentType>{
+ evaluate::ExtentType::Scalar{
+ 1, evaluate::subscriptIntegerKind}}};
for (const auto &bound : bounds) {
lhsSizeExpr = std::move(lhsSizeExpr) *
(common::Clone(bound.second) - common::Clone(bound.first) +
- evaluate::ExtentExpr{1});
+ evaluate::ExtentExpr{
+ evaluate::Constant<evaluate::ExtentType>{
+ evaluate::ExtentType::Scalar{
+ 1, evaluate::subscriptIntegerKind}}});
}
if (std::optional<std::int64_t> lhsSize{evaluate::ToInt64(
evaluate::Fold(context, std::move(lhsSizeExpr)))}) {
diff --git a/flang/lib/Semantics/resolve-names-utils.cpp b/flang/lib/Semantics/resolve-names-utils.cpp
index ef34c89182f7f..9c7e8590fc754 100644
--- a/flang/lib/Semantics/resolve-names-utils.cpp
+++ b/flang/lib/Semantics/resolve-names-utils.cpp
@@ -314,7 +314,7 @@ Bound ArraySpecAnalyzer::GetBound(const parser::SpecificationExpr &x) {
if (auto *intExpr{evaluate::UnwrapExpr<SomeIntExpr>(*maybeExpr)}) {
expr = evaluate::Fold(context_.foldingContext(),
evaluate::ConvertToType<evaluate::SubscriptInteger>(
- std::move(*intExpr)));
+ evaluate::subscriptIntegerKind, std::move(*intExpr)));
}
}
return Bound{std::move(expr)};
diff --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp
index a92d73ff1bc80..7b4f1b99415fc 100644
--- a/flang/lib/Semantics/resolve-names.cpp
+++ b/flang/lib/Semantics/resolve-names.cpp
@@ -220,7 +220,7 @@ class BaseVisitor {
MaybeSubscriptIntExpr EvaluateSubscriptIntExpr(const T &expr) {
if (MaybeIntExpr maybeIntExpr{EvaluateIntExpr(expr)}) {
return FoldExpr(evaluate::ConvertToType<evaluate::SubscriptInteger>(
- std::move(*maybeIntExpr)));
+ evaluate::subscriptIntegerKind, std::move(*maybeIntExpr)));
} else {
return std::nullopt;
}
@@ -2463,8 +2463,11 @@ void AttrsVisitor::SetBindNameOn(Symbol &symbol) {
return;
}
symbol.SetIsCDefined(isCDefined_);
- std::optional<std::string> label{
- evaluate::GetScalarConstantValue<evaluate::Ascii>(bindName_)};
+ std::optional<std::string> label;
+ if (auto charVal{
+ evaluate::GetScalarConstantValue<evaluate::Ascii>(bindName_)}) {
+ label = charVal->ToStdString();
+ }
// 18.9.2(2): discard leading and trailing blanks
if (label) {
symbol.SetIsExplicitBindName(true);
@@ -5976,7 +5979,7 @@ bool DeclarationVisitor::Pre(const parser::Enumerator &enumerator) {
// Enumerators are treated as PARAMETER (section 7.6 paragraph (4))
symbol = &MakeSymbol(name, Attrs{Attr::PARAMETER}, ObjectEntityDetails{});
symbol->SetType(context().MakeNumericType(
- TypeCategory::Integer, evaluate::CInteger::kind));
+ TypeCategory::Integer, evaluate::cIntegerKind));
}
if (auto &init{std::get<std::optional<parser::ScalarIntConstantExpr>>(
@@ -5997,8 +6000,17 @@ bool DeclarationVisitor::Pre(const parser::Enumerator &enumerator) {
if (symbol) {
if (enumerationState_.value) {
- symbol->get<ObjectEntityDetails>().set_init(SomeExpr{
- evaluate::Expr<evaluate::CInteger>{*enumerationState_.value}});
+ // Enumerators have C int kind; build the initializer constant with that
+ // runtime kind explicitly. The Expr<CInteger>(int) constructor would
+ // otherwise default to subscriptIntegerKind (8), since the kind is now a
+ // runtime property of the value rather than a template parameter.
+ symbol->get<ObjectEntityDetails>().set_init(
+ SomeExpr{evaluate::Expr<evaluate::CInteger>{
+ evaluate::Constant<evaluate::CInteger>{
+ evaluate::value::IntegerValue{
+ static_cast<std::int64_t>(*enumerationState_.value),
+ evaluate::cIntegerKind},
+ evaluate::CInteger{evaluate::cIntegerKind}}}});
} else {
context().SetError(*symbol);
}
@@ -9016,12 +9028,14 @@ class ExecutionPartAsyncIOSkimmer : public ExecutionPartSkimmerBase {
bool Pre(const parser::IoControlSpec::Asynchronous &async) {
if (auto folded{evaluate::Fold(
context_.foldingContext(), AnalyzeExpr(context_, async.v))}) {
- if (auto str{
+ if (auto charVal{
evaluate::GetScalarConstantValue<evaluate::Ascii>(*folded)}) {
- for (char ch : *str) {
- if (ch != ' ') {
- inAsyncIO_ = ch == 'y' || ch == 'Y';
- break;
+ if (auto str{charVal->ToStdString()}) {
+ for (char ch : *str) {
+ if (ch != ' ') {
+ inAsyncIO_ = ch == 'y' || ch == 'Y';
+ break;
+ }
}
}
}
diff --git a/flang/lib/Semantics/runtime-type-info.cpp b/flang/lib/Semantics/runtime-type-info.cpp
index 2cee1e23646d0..8597679c669d5 100644
--- a/flang/lib/Semantics/runtime-type-info.cpp
+++ b/flang/lib/Semantics/runtime-type-info.cpp
@@ -298,7 +298,9 @@ static evaluate::StructureConstructorValues &AddValue(
}
static SomeExpr IntToExpr(std::int64_t n) {
- return evaluate::AsGenericExpr(evaluate::ExtentExpr{n});
+ return evaluate::AsGenericExpr(
+ evaluate::ExtentExpr{evaluate::Constant<evaluate::ExtentType>{
+ evaluate::ExtentType::Scalar{n, evaluate::subscriptIntegerKind}}});
}
static evaluate::StructureConstructor Structure(
@@ -322,24 +324,24 @@ static int GetIntegerKind(const Symbol &symbol, bool canBeUninstantiated) {
// Save a rank-1 array constant of some numeric type as an
// initialized data object in a scope.
template <typename T>
-static SomeExpr SaveNumericPointerTarget(
- Scope &scope, SourceName name, std::vector<typename T::Scalar> &&x) {
+static SomeExpr SaveNumericPointerTarget(Scope &scope, SourceName name,
+ int kind, std::vector<typename T::Scalar> &&x) {
if (x.empty()) {
return SomeExpr{evaluate::NullPointer{}};
} else {
ObjectEntityDetails object;
if (const auto *spec{scope.FindType(
- DeclTypeSpec{NumericTypeSpec{T::category, KindExpr{T::kind}}})}) {
+ DeclTypeSpec{NumericTypeSpec{T::category, KindExpr{kind}}})}) {
object.set_type(*spec);
} else {
- object.set_type(scope.MakeNumericType(T::category, KindExpr{T::kind}));
+ object.set_type(scope.MakeNumericType(T::category, KindExpr{kind}));
}
auto elements{static_cast<evaluate::ConstantSubscript>(x.size())};
ArraySpec arraySpec;
arraySpec.push_back(ShapeSpec::MakeExplicit(Bound{0}, Bound{elements - 1}));
object.set_shape(arraySpec);
object.set_init(evaluate::AsGenericExpr(evaluate::Constant<T>{
- std::move(x), evaluate::ConstantSubscripts{elements}}));
+ std::move(x), evaluate::ConstantSubscripts{elements}, T{kind}}));
Symbol &symbol{*scope
.try_emplace(name, Attrs{Attr::TARGET, Attr::SAVE},
std::move(object))
@@ -362,9 +364,10 @@ static SomeExpr SaveObjectInit(
evaluate::Designator<evaluate::SomeDerived>{symbol});
}
-template <int KIND> static SomeExpr IntExpr(std::int64_t n) {
- return evaluate::AsGenericExpr(
- evaluate::Constant<evaluate::Type<TypeCategory::Integer, KIND>>{n});
+static SomeExpr IntExpr(int kind, std::int64_t n) {
+ using IntType = evaluate::Type<TypeCategory::Integer>;
+ return evaluate::AsGenericExpr(evaluate::Constant<IntType>{
+ evaluate::Scalar<IntType>{n, kind}, IntType{kind}});
}
static std::optional<std::string> GetSuffixIfTypeKindParameters(
@@ -492,8 +495,8 @@ const Symbol *RuntimeTableBuilder::DescribeType(
AddValue(dtValues, derivedTypeSchema_, "uninstantiated"s,
SomeExpr{evaluate::NullPointer{}});
}
- using Int8 = evaluate::Type<TypeCategory::Integer, 8>;
- using Int1 = evaluate::Type<TypeCategory::Integer, 1>;
+ using Int8 = evaluate::Type<TypeCategory::Integer>;
+ using Int1 = evaluate::Type<TypeCategory::Integer>;
std::vector<Int8::Scalar> kinds;
std::vector<Int1::Scalar> lenKinds;
if (parameters) {
@@ -516,10 +519,10 @@ const Symbol *RuntimeTableBuilder::DescribeType(
}
}
}
- kinds.emplace_back(value);
+ kinds.emplace_back(value, 8);
} else { // LEN= parameter
lenKinds.emplace_back(
- GetIntegerKind(*inst, isPDTDefinitionWithKindParameters));
+ GetIntegerKind(*inst, isPDTDefinitionWithKindParameters), 1);
}
}
}
@@ -527,10 +530,10 @@ const Symbol *RuntimeTableBuilder::DescribeType(
AddValue(dtValues, derivedTypeSchema_, "kindparameter"s,
SaveNumericPointerTarget<Int8>(scope,
SaveObjectName((fir::kKindParameterSeparator + distinctName).str()),
- std::move(kinds)));
+ 8, std::move(kinds)));
AddValue(dtValues, derivedTypeSchema_, "lenparameterkind"s,
SaveNumericPointerTarget<Int1>(scope,
- SaveObjectName((fir::kLenKindSeparator + distinctName).str()),
+ SaveObjectName((fir::kLenKindSeparator + distinctName).str()), 1,
std::move(lenKinds)));
// Traverse the components of the derived type
if (!isPDTDefinitionWithKindParameters) {
@@ -647,27 +650,28 @@ const Symbol *RuntimeTableBuilder::DescribeType(
static_cast<evaluate::ConstantSubscript>(specials.size())}));
}
AddValue(dtValues, derivedTypeSchema_, "specialbitset"s,
- IntExpr<4>(specialBitSet));
+ IntExpr(4, specialBitSet));
// Note the presence/absence of a parent component
AddValue(dtValues, derivedTypeSchema_, "hasparent"s,
- IntExpr<1>(dtScope.GetDerivedTypeParent() != nullptr));
+ IntExpr(1, dtScope.GetDerivedTypeParent() != nullptr));
// To avoid wasting run time attempting to initialize derived type
// instances without any initialized components, analyze the type
// and set a flag if there's nothing to do for it at run time.
AddValue(dtValues, derivedTypeSchema_, "noinitializationneeded"s,
- IntExpr<1>(derivedTypeSpec &&
- !derivedTypeSpec->HasDefaultInitialization(false, false)));
+ IntExpr(1,
+ derivedTypeSpec &&
+ !derivedTypeSpec->HasDefaultInitialization(false, false)));
// Similarly, a flag to short-circuit destruction when not needed.
AddValue(dtValues, derivedTypeSchema_, "nodestructionneeded"s,
- IntExpr<1>(derivedTypeSpec && !derivedTypeSpec->HasDestruction()));
+ IntExpr(1, derivedTypeSpec && !derivedTypeSpec->HasDestruction()));
// Similarly, a flag to short-circuit finalization when not needed.
AddValue(dtValues, derivedTypeSchema_, "nofinalizationneeded"s,
- IntExpr<1>(
- derivedTypeSpec && !MayRequireFinalization(*derivedTypeSpec)));
+ IntExpr(
+ 1, derivedTypeSpec && !MayRequireFinalization(*derivedTypeSpec)));
// Similarly, a flag to enable optimized runtime assignment.
AddValue(dtValues, derivedTypeSchema_, "nodefinedassignment"s,
- IntExpr<1>(
- derivedTypeSpec && !MayHaveDefinedAssignment(*derivedTypeSpec)));
+ IntExpr(
+ 1, derivedTypeSpec && !MayHaveDefinedAssignment(*derivedTypeSpec)));
}
dtObject.get<ObjectEntityDetails>().set_init(MaybeExpr{
StructureExpr(Structure(derivedTypeSchema_, std::move(dtValues)))});
@@ -717,7 +721,7 @@ SomeExpr RuntimeTableBuilder::GetEnumValue(const char *name) const {
const Symbol &symbol{GetSchemaSymbol(name)};
auto value{evaluate::ToInt64(symbol.get<ObjectEntityDetails>().init())};
CHECK(value.has_value());
- return IntExpr<1>(*value);
+ return IntExpr(1, *value);
}
Symbol &RuntimeTableBuilder::CreateObject(
@@ -751,7 +755,8 @@ SomeExpr RuntimeTableBuilder::SaveNameAsPointerTarget(
}
using evaluate::Ascii;
using AsciiExpr = evaluate::Expr<Ascii>;
- object.set_init(evaluate::AsGenericExpr(AsciiExpr{name}));
+ object.set_init(evaluate::AsGenericExpr(AsciiExpr{
+ evaluate::Constant<Ascii>{evaluate::value::CharacterValue{name}}}));
Symbol &symbol{
*scope
.try_emplace(
@@ -783,14 +788,14 @@ evaluate::StructureConstructor RuntimeTableBuilder::DescribeComponent(
AddValue(values, componentSchema_, "name"s,
SaveNameAsPointerTarget(scope, symbol.name().ToString()));
AddValue(values, componentSchema_, "category"s,
- IntExpr<1>(static_cast<int>(dyType.category())));
+ IntExpr(1, static_cast<int>(dyType.category())));
if (dyType.IsUnlimitedPolymorphic() ||
dyType.category() == TypeCategory::Derived) {
- AddValue(values, componentSchema_, "kind"s, IntExpr<1>(0));
+ AddValue(values, componentSchema_, "kind"s, IntExpr(1, 0));
} else {
- AddValue(values, componentSchema_, "kind"s, IntExpr<1>(dyType.kind()));
+ AddValue(values, componentSchema_, "kind"s, IntExpr(1, dyType.kind()));
}
- AddValue(values, componentSchema_, "offset"s, IntExpr<8>(symbol.offset()));
+ AddValue(values, componentSchema_, "offset"s, IntExpr(8, symbol.offset()));
// CHARACTER length
auto len{typeAndShape->LEN()};
if (const semantics::DerivedTypeSpec *
@@ -803,7 +808,11 @@ evaluate::StructureConstructor RuntimeTableBuilder::DescribeComponent(
if (const auto *clamped{evaluate::UnwrapExpr<
evaluate::Extremum<evaluate::SubscriptInteger>>(*len)}) {
if (clamped->ordering == evaluate::Ordering::Greater &&
- clamped->left() == evaluate::Expr<evaluate::SubscriptInteger>{0}) {
+ clamped->left() ==
+ evaluate::Expr<evaluate::SubscriptInteger>{
+ evaluate::Constant<evaluate::SubscriptInteger>{
+ evaluate::SubscriptInteger::Scalar{
+ 0, evaluate::subscriptIntegerKind}}}) {
len = common::Clone(clamped->right());
}
}
@@ -864,7 +873,7 @@ evaluate::StructureConstructor RuntimeTableBuilder::DescribeComponent(
SomeExpr{evaluate::NullPointer{}});
}
// Shape information
- AddValue(values, componentSchema_, "rank"s, IntExpr<1>(rank));
+ AddValue(values, componentSchema_, "rank"s, IntExpr(1, rank));
if (rank > 0 && !IsAllocatable(symbol) && !IsPointer(symbol)) {
std::vector<evaluate::StructureConstructor> bounds;
evaluate::NamedEntity entity{symbol};
@@ -929,7 +938,7 @@ evaluate::StructureConstructor RuntimeTableBuilder::DescribeComponent(
evaluate::StructureConstructorValues values;
AddValue(values, procPtrSchema_, "name"s,
SaveNameAsPointerTarget(scope, symbol.name().ToString()));
- AddValue(values, procPtrSchema_, "offset"s, IntExpr<8>(symbol.offset()));
+ AddValue(values, procPtrSchema_, "offset"s, IntExpr(8, symbol.offset()));
if (auto init{proc.init()}; init && *init) {
AddValue(values, procPtrSchema_, "initialization"s,
SomeExpr{evaluate::ProcedureDesignator{**init}});
@@ -1204,7 +1213,7 @@ void RuntimeTableBuilder::DescribeSpecialProc(
} else {
which = scalarFinalEnum_;
if (int rank{typeAndShape.Rank()}; rank > 0) {
- which = IntExpr<1>(ToInt64(which).value() + rank);
+ which = IntExpr(1, ToInt64(which).value() + rank);
if (dummyData.IsPassedByDescriptor(proc->IsBindC())) {
argThatMightBeDescriptor = 1;
}
@@ -1266,7 +1275,7 @@ void RuntimeTableBuilder::DescribeSpecialProc(
AddValue(
values, specialSchema_, "which"s, SomeExpr{std::move(which.value())});
AddValue(values, specialSchema_, "isargdescriptorset"s,
- IntExpr<1>(isArgDescriptorSet));
+ IntExpr(1, isArgDescriptorSet));
int bindingIndex{0};
if (bindings) {
int j{0};
@@ -1279,9 +1288,9 @@ void RuntimeTableBuilder::DescribeSpecialProc(
}
}
CHECK(bindingIndex <= 255);
- AddValue(values, specialSchema_, "istypebound"s, IntExpr<1>(bindingIndex));
+ AddValue(values, specialSchema_, "istypebound"s, IntExpr(1, bindingIndex));
AddValue(values, specialSchema_, "specialcaseflag"s,
- IntExpr<1>(specialCaseFlag));
+ IntExpr(1, specialCaseFlag));
AddValue(values, specialSchema_, procCompName,
SomeExpr{evaluate::ProcedureDesignator{specific}});
// index might already be present in the case of an override
diff --git a/flang/lib/Semantics/type.cpp b/flang/lib/Semantics/type.cpp
index cddb83fe6aca6..2cc27981a92fa 100644
--- a/flang/lib/Semantics/type.cpp
+++ b/flang/lib/Semantics/type.cpp
@@ -118,7 +118,7 @@ void DerivedTypeSpec::EvaluateParameters(SemanticsContext &context) {
auto &messages{foldingContext.messages()};
for (const Symbol &symbol : OrderParameterDeclarations(typeSymbol_)) {
SourceName name{symbol.name()};
- int parameterKind{evaluate::TypeParamInquiry::Result::kind};
+ int parameterKind{evaluate::subscriptIntegerKind};
// Compute the integer kind value of the type parameter,
// which may depend on the values of earlier ones.
if (const auto *typeSpec{symbol.GetType()}) {
@@ -422,12 +422,17 @@ void DerivedTypeSpec::Instantiate(Scope &containingScope) {
sep = ',';
if (MaybeIntExpr expr{paramValue->GetExplicit()}) {
desc += expr->AsFortran();
- instanceDetails.set_init(
- std::move(DEREF(evaluate::UnwrapExpr<SomeIntExpr>(*expr))));
+ // Determine the parameter's type before moving the expression into
+ // the instance's initializer: with kind now a runtime property,
+ // GetType() of a moved-from expression no longer yields a valid
+ // kind (it formerly came from the compile-time KIND template
+ // parameter).
if (auto dyType{expr->GetType()}) {
instanceDetails.set_type(newScope.MakeNumericType(
TypeCategory::Integer, KindExpr{dyType->kind()}));
}
+ instanceDetails.set_init(
+ std::move(DEREF(evaluate::UnwrapExpr<SomeIntExpr>(*expr))));
}
if (!instanceDetails.type()) {
if (const DeclTypeSpec * type{details.type()}) {
@@ -651,7 +656,7 @@ const DeclTypeSpec &InstantiateHelper::InstantiateIntrinsicType(
if (MaybeExpr analyzed{AnalyzeExpr(scope_.context(), *originalKindExpr)}) {
if (auto *intExpr{evaluate::UnwrapExpr<SomeIntExpr>(*analyzed)}) {
kindExpr = evaluate::ConvertToType<evaluate::SubscriptInteger>(
- std::move(*intExpr));
+ evaluate::subscriptIntegerKind, std::move(*intExpr));
}
}
}
diff --git a/flang/test/Driver/intrinsic-module-path_per_target.f90 b/flang/test/Driver/intrinsic-module-path_per_target.f90
index b0a2ac9c7c6b4..32364b90a2000 100644
--- a/flang/test/Driver/intrinsic-module-path_per_target.f90
+++ b/flang/test/Driver/intrinsic-module-path_per_target.f90
@@ -42,7 +42,7 @@
!-----------------------------------------
! DEFAULTPATH: "-fc1"
-! DEFAULTPATH-SAME: "-fintrinsic-modules-path" "{{.*(\\\\|/)}}finclude{{(\\\\|/)}}flang{{(\\\\|/)}}{{[^/\]+}}"
+! DEFAULTPATH-SAME: "-fintrinsic-modules-path" "{{.*(\\\\|/)}}finclude{{(\\\\|/)}}flang{{(\\\\|/)}}{{[^/\]+/?}}"
! NOINPUTONE: Source file 'basictestmoduleone.mod' was not found
! NOINPUTTWO: Source file 'basictestmoduletwo.mod' was not found
diff --git a/flang/test/Evaluate/folding05.f90 b/flang/test/Evaluate/folding05.f90
index aed1906e6a640e9c9e71a800179b2b5d4bdbb688..5fcaf938fedaaa6309c258ac770278d987e51ea1 100644
GIT binary patch
delta 10
RcmX>Tem`tN+{V+4+5jHw1n&R<
delta 138
zcmcZ~b|!p6T)m=#r?ZD+kV1Z0YEfEFez`(&Mrv|)W?s5NX0bv_W^rOtPHKumex5>j
zW?o8uIZ&)LRiPwbAyFYIKfSbA!8bU}nM+Y2sWdYuMIp7QD8EP#$c=Dw^z^Y(D6T9n
iNzK(QhiK*E%FRzH%}E7Xkyw<NT#{N8pSiK%y%qpyXfbC1
diff --git a/flang/test/Semantics/bug2236.f90 b/flang/test/Semantics/bug2236.f90
index ec101ecf467e7..450888fee9e59 100644
--- a/flang/test/Semantics/bug2236.f90
+++ b/flang/test/Semantics/bug2236.f90
@@ -1,4 +1,4 @@
-!RUN: flang -c -Xflang -fdisable-real-10 %s 2>&1 | FileCheck --allow-empty %s
+!RUN: %flang -c -Xflang -fdisable-real-10 %s 2>&1 | FileCheck --allow-empty %s
!REQUIRES: x86-registered-target
!CHECK-NOT: error
!Ensure ieee_arithmetic.mod can be used even when REAL(10) is disabled.
diff --git a/flang/unittests/Evaluate/expression.cpp b/flang/unittests/Evaluate/expression.cpp
index d575f36def287..dad556b8c9b08 100644
--- a/flang/unittests/Evaluate/expression.cpp
+++ b/flang/unittests/Evaluate/expression.cpp
@@ -12,13 +12,14 @@
using namespace Fortran::evaluate;
int main() {
- using DefaultIntegerExpr = Expr<Type<TypeCategory::Integer, 4>>;
- TEST(DefaultIntegerExpr::Result::AsFortran() == "INTEGER(4)");
- MATCH("666_4", DefaultIntegerExpr{666}.AsFortran());
- MATCH("-1_4", (-DefaultIntegerExpr{1}).AsFortran());
+ using DefaultIntegerExpr = Expr<Type<TypeCategory::Integer>>;
+ TEST(DefaultIntegerExpr::Result{subscriptIntegerKind}.AsFortran() ==
+ "INTEGER(8)");
+ MATCH("666_8", DefaultIntegerExpr{666}.AsFortran());
+ MATCH("-1_8", (-DefaultIntegerExpr{1}).AsFortran());
auto ex1{
DefaultIntegerExpr{2} + DefaultIntegerExpr{3} * -DefaultIntegerExpr{4}};
- MATCH("2_4+3_4*(-4_4)", ex1.AsFortran());
+ MATCH("2_8+3_8*(-4_8)", ex1.AsFortran());
Fortran::common::IntrinsicTypeDefaultKinds defaults;
auto intrinsics{Fortran::evaluate::IntrinsicProcTable::Configure(defaults)};
TargetCharacteristics targetCharacteristics;
@@ -27,13 +28,13 @@ int main() {
FoldingContext context{Fortran::parser::ContextualMessages{nullptr}, defaults,
intrinsics, targetCharacteristics, languageFeatures, tempNames};
ex1 = Fold(context, std::move(ex1));
- MATCH("-10_4", ex1.AsFortran());
- MATCH("1_4/2_4", (DefaultIntegerExpr{1} / DefaultIntegerExpr{2}).AsFortran());
+ MATCH("-10_8", ex1.AsFortran());
+ MATCH("1_8/2_8", (DefaultIntegerExpr{1} / DefaultIntegerExpr{2}).AsFortran());
DefaultIntegerExpr a{1};
DefaultIntegerExpr b{2};
- MATCH("1_4", a.AsFortran());
+ MATCH("1_8", a.AsFortran());
a = b;
- MATCH("2_4", a.AsFortran());
- MATCH("2_4", b.AsFortran());
+ MATCH("2_8", a.AsFortran());
+ MATCH("2_8", b.AsFortran());
return testing::Complete();
}
diff --git a/flang/unittests/Evaluate/folding.cpp b/flang/unittests/Evaluate/folding.cpp
index 832e55d44316d..a1b4e858c68a0 100644
--- a/flang/unittests/Evaluate/folding.cpp
+++ b/flang/unittests/Evaluate/folding.cpp
@@ -21,7 +21,13 @@ struct RunOnTypes<Test, std::tuple<T...>> {
// test for fold.h GetScalarConstantValue function
struct TestGetScalarConstantValue {
template <typename T> static void Run() {
- Expr<T> exprFullyTyped{Constant<T>{Scalar<T>{}}};
+ Scalar<T> value{};
+ if constexpr (T::category == TypeCategory::Character) {
+ // A kindless Character scalar is monostate, but a character Constant
+ // needs a concrete kind; use the default character kind.
+ value = Scalar<T>::Zero(1);
+ }
+ Expr<T> exprFullyTyped{Constant<T>{std::move(value)}};
Expr<SomeKind<T::category>> exprSomeKind{exprFullyTyped};
Expr<SomeType> exprSomeType{exprSomeKind};
TEST(GetScalarConstantValue<T>(exprFullyTyped).has_value());
@@ -39,7 +45,8 @@ Scalar<T> CallHostRt(
}
void TestHostRuntimeSubnormalFlushing() {
- using R4 = Type<TypeCategory::Real, 4>;
+ using R4 = host::TypeKind<TypeCategory::Real, 4>;
+ using FR4 = R4::FortranType;
if constexpr (std::is_same_v<host::HostType<R4>, float>) {
Fortran::parser::CharBlock src;
Fortran::parser::ContextualMessages messages{src, nullptr};
@@ -56,13 +63,14 @@ void TestHostRuntimeSubnormalFlushing() {
FoldingContext noFlushingContext{messages, defaults, intrinsics,
noFlushingTargetCharacteristics, languageFeatures, tempNames};
- DynamicType r4{R4{}.GetType()};
+ DynamicType r4{R4::GetType()};
// Test subnormal argument flushing
if (auto callable{GetHostRuntimeWrapper("log", r4, {r4})}) {
// Biggest IEEE 32bits subnormal power of two
- const Scalar<R4> x1{Scalar<R4>::Word{0x00400000}};
- Scalar<R4> y1Flushing{CallHostRt<R4>(*callable, flushingContext, x1)};
- Scalar<R4> y1NoFlushing{CallHostRt<R4>(*callable, noFlushingContext, x1)};
+ const Scalar<FR4> x1{Scalar<FR4>::Word{0x00400000u, 4}, 4};
+ Scalar<FR4> y1Flushing{CallHostRt<FR4>(*callable, flushingContext, x1)};
+ Scalar<FR4> y1NoFlushing{
+ CallHostRt<FR4>(*callable, noFlushingContext, x1)};
// We would expect y1Flushing to be NaN, but some libc logf implementation
// "workaround" subnormal flushing by returning a constant negative
// results for all subnormal values (-1.03972076416015625e2_4). In case of
diff --git a/flang/unittests/Evaluate/integer.cpp b/flang/unittests/Evaluate/integer.cpp
index 5ab22cc6443a7..56bf7e72ca1ca 100644
--- a/flang/unittests/Evaluate/integer.cpp
+++ b/flang/unittests/Evaluate/integer.cpp
@@ -1,4 +1,5 @@
#include "flang/Evaluate/integer.h"
+#include "flang/Evaluate/integer-value.h"
#include "flang/Testing/testing.h"
#include <cstdio>
#include <string>
diff --git a/flang/unittests/Evaluate/intrinsics.cpp b/flang/unittests/Evaluate/intrinsics.cpp
index cca2f8c30247e..c7fba080884cd 100644
--- a/flang/unittests/Evaluate/intrinsics.cpp
+++ b/flang/unittests/Evaluate/intrinsics.cpp
@@ -43,8 +43,44 @@ class CookedStrings {
std::map<std::string, std::size_t> offsets_;
};
-template <typename A> auto Const(A &&x) -> Constant<TypeOf<A>> {
- return Constant<TypeOf<A>>{std::move(x)};
+// Since the migration to runtime kinds, Fortran's Type<CAT> no longer carries
+// its kind as a template parameter, so the kind can no longer be recovered from
+// a (kindless) scalar value alone. This compile-time tag bundles the kindless
+// Fortran Type<CAT> with the kind that the test wants, so the existing
+// IntN/RealN/... aliases keep working: TagN::GetType() yields the runtime
+// DynamicType, Scalar<TagN> resolves to the runtime-kind Scalar, and
+// Const<TagN> stamps the kind onto the constant's result type.
+template <common::TypeCategory CAT, int KIND> struct TestTypeKind {
+ static constexpr common::TypeCategory category{CAT};
+ static constexpr int kind{KIND};
+ using FortranType = Type<CAT>;
+ using Scalar = Fortran::evaluate::Scalar<FortranType>;
+ static constexpr DynamicType GetType() { return DynamicType{CAT, KIND}; }
+};
+
+// With the collapsed-kind scalars, TypeOf<> can no longer recover the kind of a
+// scalar (all kinds of a category share one Scalar type), so a TestTypeKind tag
+// may be supplied to stamp the desired kind onto the constant:
+// Const<Int4>(...).
+template <typename T = void, typename A> auto Const(A &&x) {
+ if constexpr (std::is_void_v<T>) {
+ return Constant<TypeOf<A>>{std::move(x)};
+ } else {
+ using FT = typename T::FortranType;
+ constexpr int kind{T::kind};
+ // A default-constructed (monostate) numeric scalar cannot report its kind,
+ // which formatting and folding require, so materialize a zero value in the
+ // requested runtime kind.
+ if constexpr (FT::category == TypeCategory::Integer ||
+ FT::category == TypeCategory::Unsigned) {
+ return Constant<FT>{Scalar<FT>{x.ToInt64(), kind}, FT{kind}};
+ } else if constexpr (FT::category == TypeCategory::Real ||
+ FT::category == TypeCategory::Complex) {
+ return Constant<FT>{Scalar<FT>::Zero(kind), FT{kind}};
+ } else {
+ return Constant<FT>{std::move(x), FT{kind}};
+ }
+ }
}
template <typename A> struct NamedArg {
@@ -152,63 +188,65 @@ void TestIntrinsics() {
IntrinsicProcTable table{IntrinsicProcTable::Configure(defaults)};
table.Dump(llvm::outs());
- using Int1 = Type<TypeCategory::Integer, 1>;
- using Int4 = Type<TypeCategory::Integer, 4>;
- using Int8 = Type<TypeCategory::Integer, 8>;
- using Real4 = Type<TypeCategory::Real, 4>;
- using Real8 = Type<TypeCategory::Real, 8>;
- using Complex4 = Type<TypeCategory::Complex, 4>;
- using Complex8 = Type<TypeCategory::Complex, 8>;
- using Char = Type<TypeCategory::Character, 1>;
- using Log4 = Type<TypeCategory::Logical, 4>;
+ using Int1 = TestTypeKind<TypeCategory::Integer, 1>;
+ using Int4 = TestTypeKind<TypeCategory::Integer, 4>;
+ using Int8 = TestTypeKind<TypeCategory::Integer, 8>;
+ using Real4 = TestTypeKind<TypeCategory::Real, 4>;
+ using Real8 = TestTypeKind<TypeCategory::Real, 8>;
+ using Complex4 = TestTypeKind<TypeCategory::Complex, 4>;
+ using Complex8 = TestTypeKind<TypeCategory::Complex, 8>;
+ using Char = TestTypeKind<TypeCategory::Character, 1>;
+ using Log4 = TestTypeKind<TypeCategory::Logical, 4>;
TestCall{defaults, table, "bad"}
- .Push(Const(Scalar<Int4>{}))
+ .Push(Const<Int4>(Scalar<Int4>{}))
.DoCall(); // bad intrinsic name
TestCall{defaults, table, "abs"}
- .Push(Named("a", Const(Scalar<Int4>{})))
+ .Push(Named("a", Const<Int4>(Scalar<Int4>{})))
.DoCall(Int4::GetType());
TestCall{defaults, table, "abs"}
- .Push(Const(Scalar<Int4>{}))
+ .Push(Const<Int4>(Scalar<Int4>{}))
.DoCall(Int4::GetType());
TestCall{defaults, table, "abs"}
- .Push(Named("bad", Const(Scalar<Int4>{})))
+ .Push(Named("bad", Const<Int4>(Scalar<Int4>{})))
.DoCall(); // bad keyword
TestCall{defaults, table, "abs"}.DoCall(); // insufficient args
TestCall{defaults, table, "abs"}
- .Push(Const(Scalar<Int4>{}))
- .Push(Const(Scalar<Int4>{}))
+ .Push(Const<Int4>(Scalar<Int4>{}))
+ .Push(Const<Int4>(Scalar<Int4>{}))
.DoCall(); // too many args
TestCall{defaults, table, "abs"}
- .Push(Const(Scalar<Int4>{}))
- .Push(Named("a", Const(Scalar<Int4>{})))
+ .Push(Const<Int4>(Scalar<Int4>{}))
+ .Push(Named("a", Const<Int4>(Scalar<Int4>{})))
.DoCall();
TestCall{defaults, table, "abs"}
- .Push(Named("a", Const(Scalar<Int4>{})))
- .Push(Const(Scalar<Int4>{}))
+ .Push(Named("a", Const<Int4>(Scalar<Int4>{})))
+ .Push(Const<Int4>(Scalar<Int4>{}))
.DoCall();
TestCall{defaults, table, "abs"}
- .Push(Const(Scalar<Int1>{}))
+ .Push(Const<Int1>(Scalar<Int1>{}))
.DoCall(Int1::GetType());
TestCall{defaults, table, "abs"}
- .Push(Const(Scalar<Int4>{}))
+ .Push(Const<Int4>(Scalar<Int4>{}))
.DoCall(Int4::GetType());
TestCall{defaults, table, "abs"}
- .Push(Const(Scalar<Int8>{}))
+ .Push(Const<Int8>(Scalar<Int8>{}))
.DoCall(Int8::GetType());
TestCall{defaults, table, "abs"}
- .Push(Const(Scalar<Real4>{}))
+ .Push(Const<Real4>(Scalar<Real4>{}))
.DoCall(Real4::GetType());
TestCall{defaults, table, "abs"}
- .Push(Const(Scalar<Real8>{}))
+ .Push(Const<Real8>(Scalar<Real8>{}))
.DoCall(Real8::GetType());
TestCall{defaults, table, "abs"}
- .Push(Const(Scalar<Complex4>{}))
+ .Push(Const<Complex4>(Scalar<Complex4>{}))
.DoCall(Real4::GetType());
TestCall{defaults, table, "abs"}
- .Push(Const(Scalar<Complex8>{}))
+ .Push(Const<Complex8>(Scalar<Complex8>{}))
.DoCall(Real8::GetType());
- TestCall{defaults, table, "abs"}.Push(Const(Scalar<Char>{})).DoCall();
+ TestCall{defaults, table, "abs"}
+ .Push(Const(Scalar<Char>::Zero(Char::kind)))
+ .DoCall();
TestCall{defaults, table, "abs"}.Push(Const(Scalar<Log4>{})).DoCall();
// "Ext" in names for calls allowed as extensions
@@ -218,14 +256,14 @@ void TestIntrinsics() {
max0ExtCall{defaults, table, "max0"},
amin1ExtCall{defaults, table, "amin1"};
for (int j{0}; j < 10; ++j) {
- maxCallR.Push(Const(Scalar<Real4>{}));
- maxCallI.Push(Const(Scalar<Int4>{}));
- max0Call.Push(Const(Scalar<Int4>{}));
- max0ExtCall.Push(Const(Scalar<Real4>{}));
- max1Call.Push(Const(Scalar<Real4>{}));
- amin0Call.Push(Const(Scalar<Int4>{}));
- amin1ExtCall.Push(Const(Scalar<Int4>{}));
- amin1Call.Push(Const(Scalar<Real4>{}));
+ maxCallR.Push(Const<Real4>(Scalar<Real4>{}));
+ maxCallI.Push(Const<Int4>(Scalar<Int4>{}));
+ max0Call.Push(Const<Int4>(Scalar<Int4>{}));
+ max0ExtCall.Push(Const<Real4>(Scalar<Real4>{}));
+ max1Call.Push(Const<Real4>(Scalar<Real4>{}));
+ amin0Call.Push(Const<Int4>(Scalar<Int4>{}));
+ amin1ExtCall.Push(Const<Int4>(Scalar<Int4>{}));
+ amin1Call.Push(Const<Real4>(Scalar<Real4>{}));
}
maxCallR.DoCall(Real4::GetType());
maxCallI.DoCall(Int4::GetType());
@@ -237,63 +275,65 @@ void TestIntrinsics() {
amin1ExtCall.DoCall(Real4::GetType());
TestCall{defaults, table, "conjg"}
- .Push(Const(Scalar<Complex4>{}))
+ .Push(Const<Complex4>(Scalar<Complex4>{}))
.DoCall(Complex4::GetType());
TestCall{defaults, table, "conjg"}
- .Push(Const(Scalar<Complex8>{}))
+ .Push(Const<Complex8>(Scalar<Complex8>{}))
.DoCall(Complex8::GetType());
TestCall{defaults, table, "dconjg"}
- .Push(Const(Scalar<Complex8>{}))
+ .Push(Const<Complex8>(Scalar<Complex8>{}))
.DoCall(Complex8::GetType());
- TestCall{defaults, table, "float"}.Push(Const(Scalar<Real4>{})).DoCall();
TestCall{defaults, table, "float"}
- .Push(Const(Scalar<Int4>{}))
+ .Push(Const<Real4>(Scalar<Real4>{}))
+ .DoCall();
+ TestCall{defaults, table, "float"}
+ .Push(Const<Int4>(Scalar<Int4>{}))
.DoCall(Real4::GetType());
- TestCall{defaults, table, "idint"}.Push(Const(Scalar<Int4>{})).DoCall();
+ TestCall{defaults, table, "idint"}.Push(Const<Int4>(Scalar<Int4>{})).DoCall();
TestCall{defaults, table, "idint"}
- .Push(Const(Scalar<Real8>{}))
+ .Push(Const<Real8>(Scalar<Real8>{}))
.DoCall(Int4::GetType());
// Allowed as extensions
TestCall{defaults, table, "float"}
- .Push(Const(Scalar<Int8>{}))
+ .Push(Const<Int8>(Scalar<Int8>{}))
.DoCall(Real4::GetType());
TestCall{defaults, table, "idint"}
- .Push(Const(Scalar<Real4>{}))
+ .Push(Const<Real4>(Scalar<Real4>{}))
.DoCall(Int4::GetType());
TestCall{defaults, table, "num_images"}.DoCall(Int4::GetType());
TestCall{defaults, table, "num_images"}
- .Push(Const(Scalar<Int1>{}))
+ .Push(Const<Int1>(Scalar<Int1>{}))
.DoCall(Int4::GetType());
TestCall{defaults, table, "num_images"}
- .Push(Const(Scalar<Int4>{}))
+ .Push(Const<Int4>(Scalar<Int4>{}))
.DoCall(Int4::GetType());
TestCall{defaults, table, "num_images"}
- .Push(Const(Scalar<Int8>{}))
+ .Push(Const<Int8>(Scalar<Int8>{}))
.DoCall(Int4::GetType());
TestCall{defaults, table, "num_images"}
- .Push(Named("team_number", Const(Scalar<Int4>{})))
+ .Push(Named("team_number", Const<Int4>(Scalar<Int4>{})))
.DoCall(Int4::GetType());
TestCall{defaults, table, "num_images"}
- .Push(Const(Scalar<Int4>{}))
- .Push(Const(Scalar<Int4>{}))
+ .Push(Const<Int4>(Scalar<Int4>{}))
+ .Push(Const<Int4>(Scalar<Int4>{}))
.DoCall(); // too many args
TestCall{defaults, table, "num_images"}
- .Push(Named("bad", Const(Scalar<Int4>{})))
+ .Push(Named("bad", Const<Int4>(Scalar<Int4>{})))
.DoCall(); // bad keyword
TestCall{defaults, table, "num_images"}
- .Push(Const(Scalar<Char>{}))
+ .Push(Const(Scalar<Char>::Zero(Char::kind)))
.DoCall(); // bad type
TestCall{defaults, table, "num_images"}
.Push(Const(Scalar<Log4>{}))
.DoCall(); // bad type
TestCall{defaults, table, "num_images"}
- .Push(Const(Scalar<Complex8>{}))
+ .Push(Const<Complex8>(Scalar<Complex8>{}))
.DoCall(); // bad type
TestCall{defaults, table, "num_images"}
- .Push(Const(Scalar<Real4>{}))
+ .Push(Const<Real4>(Scalar<Real4>{}))
.DoCall(); // bad type
// This test temporarily removed because it requires access to
@@ -302,26 +342,26 @@ void TestIntrinsics() {
// TestCall{defaults, table, "team_number"}.DoCall(Int4::GetType());
TestCall{defaults, table, "team_number"}
- .Push(Const(Scalar<Int4>{}))
- .Push(Const(Scalar<Int4>{}))
+ .Push(Const<Int4>(Scalar<Int4>{}))
+ .Push(Const<Int4>(Scalar<Int4>{}))
.DoCall(); // too many args
TestCall{defaults, table, "team_number"}
- .Push(Named("bad", Const(Scalar<Int4>{})))
+ .Push(Named("bad", Const<Int4>(Scalar<Int4>{})))
.DoCall(); // bad keyword
TestCall{defaults, table, "team_number"}
- .Push(Const(Scalar<Int4>{}))
+ .Push(Const<Int4>(Scalar<Int4>{}))
.DoCall(); // bad type
TestCall{defaults, table, "team_number"}
- .Push(Const(Scalar<Char>{}))
+ .Push(Const(Scalar<Char>::Zero(Char::kind)))
.DoCall(); // bad type
TestCall{defaults, table, "team_number"}
.Push(Const(Scalar<Log4>{}))
.DoCall(); // bad type
TestCall{defaults, table, "team_number"}
- .Push(Const(Scalar<Complex8>{}))
+ .Push(Const<Complex8>(Scalar<Complex8>{}))
.DoCall(); // bad type
TestCall{defaults, table, "team_number"}
- .Push(Const(Scalar<Real4>{}))
+ .Push(Const<Real4>(Scalar<Real4>{}))
.DoCall(); // bad type
// TODO: test other intrinsics
diff --git a/flang/unittests/Evaluate/logical.cpp b/flang/unittests/Evaluate/logical.cpp
index ba7d0d8d0c0e3..f21795f3e006e 100644
--- a/flang/unittests/Evaluate/logical.cpp
+++ b/flang/unittests/Evaluate/logical.cpp
@@ -3,13 +3,12 @@
#include <cstdio>
template <int KIND> void testKind() {
- using Type =
- Fortran::evaluate::Type<Fortran::common::TypeCategory::Logical, KIND>;
+ using Type = Fortran::evaluate::Type<Fortran::common::TypeCategory::Logical>;
TEST(Fortran::evaluate::IsSpecificIntrinsicType<Type>);
TEST(Type::category == Fortran::common::TypeCategory::Logical);
- TEST(Type::kind == KIND);
+ TEST(Type{KIND}.kind() == KIND);
using Value = Fortran::evaluate::Scalar<Type>;
- MATCH(8 * KIND, Value::bits);
+ MATCH(8 * KIND, Value::Zero(KIND).bits());
TEST(!Value{}.IsTrue());
TEST(!Value{false}.IsTrue());
TEST(Value{true}.IsTrue());
diff --git a/flang/unittests/Evaluate/real.cpp b/flang/unittests/Evaluate/real.cpp
index a28da5c3273ce..2b8a9da712362 100644
--- a/flang/unittests/Evaluate/real.cpp
+++ b/flang/unittests/Evaluate/real.cpp
@@ -10,16 +10,36 @@
using namespace Fortran::evaluate;
using namespace Fortran::common;
-using Real2 = Scalar<Type<TypeCategory::Real, 2>>;
-using Real3 = Scalar<Type<TypeCategory::Real, 3>>;
-using Real4 = Scalar<Type<TypeCategory::Real, 4>>;
-using Real8 = Scalar<Type<TypeCategory::Real, 8>>;
+using Real2 = Scalar<Type<TypeCategory::Real>>;
+using Real3 = Scalar<Type<TypeCategory::Real>>;
+using Real4 = Scalar<Type<TypeCategory::Real>>;
+using Real8 = Scalar<Type<TypeCategory::Real>>;
#ifdef __x86_64__
-using Real10 = Scalar<Type<TypeCategory::Real, 10>>;
+using Real10 = Scalar<Type<TypeCategory::Real>>;
#endif
-using Real16 = Scalar<Type<TypeCategory::Real, 16>>;
-using Integer4 = Scalar<Type<TypeCategory::Integer, 4>>;
-using Integer8 = Scalar<Type<TypeCategory::Integer, 8>>;
+using Real16 = Scalar<Type<TypeCategory::Real>>;
+using Integer4 = Scalar<Type<TypeCategory::Integer>>;
+using Integer8 = Scalar<Type<TypeCategory::Integer>>;
+
+// Storage width in bits for a Fortran real KIND.
+static constexpr int BitsOfRealKind(int kind) {
+ switch (kind) {
+ case 2:
+ return 16;
+ case 3:
+ return 16;
+ case 4:
+ return 32;
+ case 8:
+ return 64;
+ case 10:
+ return 80;
+ case 16:
+ return 128;
+ default:
+ return 0;
+ }
+}
void dumpTest() {
struct {
@@ -42,18 +62,21 @@ void dumpTest() {
{0, nullptr},
};
for (int j{0}; table[j].expected != nullptr; ++j) {
- TEST(Real4{Integer4{table[j].raw}}.DumpHexadecimal() == table[j].expected)
+ TEST((Real4{Integer4{table[j].raw, 4}, 4}.DumpHexadecimal() ==
+ table[j].expected))
("%d", j);
}
}
-template <typename R> void basicTests(int rm, Rounding rounding) {
- static constexpr int kind{R::bits / 8};
+template <int KIND> void basicTests(int rm, Rounding rounding) {
+ using R = Scalar<Type<TypeCategory::Real>>;
+ constexpr int bits{BitsOfRealKind(KIND)};
+ static constexpr int kind{KIND};
char desc[64];
using Word = typename R::Word;
- std::snprintf(desc, sizeof desc, "bits=%d, le=%d, kind=%d", R::bits,
- Word::littleEndian, kind);
- R zero;
+ std::snprintf(desc, sizeof desc, "bits=%d, le=%d, kind=%d", bits,
+ isHostLittleEndian, kind);
+ R zero{Word{std::uint64_t{0}, KIND}, KIND};
TEST(!zero.IsNegative())(desc);
TEST(!zero.IsNotANumber())(desc);
TEST(!zero.IsInfinite())(desc);
@@ -62,9 +85,9 @@ template <typename R> void basicTests(int rm, Rounding rounding) {
TEST(zero.RawBits().IsZero())(desc);
MATCH(0, zero.RawBits().ToUInt64())(desc);
TEST(zero.ABS().RawBits().IsZero())(desc);
- TEST(zero.Negate().RawBits().IEOR(Word::MASKL(1)).IsZero())(desc);
+ TEST(zero.Negate().RawBits().IEOR(Word::MASKL(1, kind)).IsZero())(desc);
TEST(zero.Compare(zero) == Relation::Equal)(desc);
- R minusZero{Word{std::uint64_t{1}}.SHIFTL(R::bits - 1)};
+ R minusZero{Word{std::uint64_t{1}, KIND}.SHIFTL(bits - 1), KIND};
TEST(minusZero.IsNegative())(desc);
TEST(!minusZero.IsNotANumber())(desc);
TEST(!minusZero.IsInfinite())(desc);
@@ -79,11 +102,12 @@ template <typename R> void basicTests(int rm, Rounding rounding) {
ValueWithRealFlags<R> vr;
MATCH(0, vr.value.RawBits().ToUInt64())(desc);
TEST(vr.flags.empty())(desc);
- R nan{Word{std::uint64_t{1}}
- .SHIFTL(R::bits)
- .SubtractSigned(Word{std::uint64_t{1}})
- .value};
- MATCH(R::bits, nan.RawBits().POPCNT())(desc);
+ R nan{Word{std::uint64_t{1}, KIND}
+ .SHIFTL(bits)
+ .SubtractSigned(Word{std::uint64_t{1}, KIND})
+ .value,
+ KIND};
+ MATCH(bits, nan.RawBits().POPCNT())(desc);
TEST(!nan.IsNegative())(desc);
TEST(nan.IsNotANumber())(desc);
TEST(!nan.IsInfinite())(desc);
@@ -93,19 +117,20 @@ template <typename R> void basicTests(int rm, Rounding rounding) {
TEST(nan.Compare(zero) == Relation::Unordered)(desc);
TEST(nan.Compare(minusZero) == Relation::Unordered)(desc);
TEST(nan.Compare(nan) == Relation::Unordered)(desc);
- int significandBits{R::binaryPrecision - R::isImplicitMSB};
- int exponentBits{R::bits - significandBits - 1};
+ int significandBits{R::binaryPrecision(KIND) - R::isImplicitMSB(KIND)};
+ int exponentBits{bits - significandBits - 1};
std::uint64_t maxExponent{(std::uint64_t{1} << exponentBits) - 1};
MATCH(nan.Exponent(), maxExponent)(desc);
- Word infWord{Word{maxExponent}.SHIFTL(significandBits)};
- Word negInfWord{
- Word{maxExponent}.SHIFTL(significandBits).IOR(Word::MASKL(1))};
+ Word infWord{Word{maxExponent, KIND}.SHIFTL(significandBits)};
+ Word negInfWord{Word{maxExponent, KIND}
+ .SHIFTL(significandBits)
+ .IOR(Word::MASKL(1, kind))};
if constexpr (kind == 10) { // x87
infWord = infWord.IBSET(63);
negInfWord = negInfWord.IBSET(63);
}
- R inf{infWord};
- R negInf{negInfWord};
+ R inf{infWord, KIND};
+ R negInf{negInfWord, KIND};
TEST(!inf.IsNegative())(desc);
TEST(!inf.IsNotANumber())(desc);
TEST(inf.IsInfinite())(desc);
@@ -139,14 +164,14 @@ template <typename R> void basicTests(int rm, Rounding rounding) {
x <<= j;
std::snprintf(ldesc, sizeof ldesc, "%s j=%d x=0x%jx rm=%d", desc,
static_cast<int>(j), static_cast<std::intmax_t>(x), rm);
- Integer8 ix{x};
+ Integer8 ix{x, 8};
TEST(!ix.IsNegative())(ldesc);
MATCH(x, ix.ToUInt64())(ldesc);
- vr = R::FromInteger(ix, false, rounding);
+ vr = R::FromInteger(ix, KIND, false, rounding);
TEST(!vr.value.IsNegative())(ldesc);
TEST(!vr.value.IsNotANumber())(ldesc);
TEST(!vr.value.IsZero())(ldesc);
- auto ivf = vr.value.template ToInteger<Integer8>();
+ auto ivf = vr.value.ToInteger(RoundingMode::ToZero, 64);
if (j > (maxExponent / 2)) {
TEST(vr.flags.test(RealFlag::Overflow))(ldesc);
TEST(vr.value.IsInfinite())(ldesc);
@@ -164,8 +189,8 @@ template <typename R> void basicTests(int rm, Rounding rounding) {
const char *p{decimal.data()};
MATCH(x, static_cast<std::uint64_t>(std::stold(decimal)))
("%s %s", ldesc, p);
- auto check{R::Read(p, rounding)};
- auto icheck{check.value.template ToInteger<Integer8>()};
+ auto check{R::Read(p, KIND, rounding)};
+ auto icheck{check.value.ToInteger(RoundingMode::ToZero, 64)};
MATCH(x, icheck.value.ToUInt64())(ldesc);
TEST(vr.value.Compare(check.value) == Relation::Equal)(ldesc);
}
@@ -178,11 +203,11 @@ template <typename R> void basicTests(int rm, Rounding rounding) {
std::int64_t nx = x;
MATCH(x, ix.ToUInt64())(ldesc);
MATCH(nx, ix.ToInt64())(ldesc);
- vr = R::FromInteger(ix);
+ vr = R::FromInteger(ix, KIND);
TEST(vr.value.IsNegative())(ldesc);
TEST(!vr.value.IsNotANumber())(ldesc);
TEST(!vr.value.IsZero())(ldesc);
- ivf = vr.value.template ToInteger<Integer8>();
+ ivf = vr.value.ToInteger(RoundingMode::ToZero, 64);
if (j > (maxExponent / 2)) {
TEST(vr.flags.test(RealFlag::Overflow))(ldesc);
TEST(vr.value.IsInfinite())(ldesc);
@@ -294,16 +319,17 @@ inline std::uint32_t FlagsToBits(const RealFlags &flags) {
}
#endif // __clang__
-template <typename UINT = std::uint32_t, typename FLT = float, typename REAL>
+template <typename UINT = std::uint32_t, typename FLT = float, int KIND = 4>
void inttest(std::int64_t x, int pass, Rounding rounding) {
+ using REAL = Scalar<Type<TypeCategory::Real>>;
union {
UINT ui;
FLT f;
} u;
ScopedHostFloatingPointEnvironment fpenv;
- Integer8 ix{x};
+ Integer8 ix{x, 8};
ValueWithRealFlags<REAL> real;
- real = real.value.FromInteger(ix, false, rounding);
+ real = REAL::FromInteger(ix, KIND, false, rounding);
#ifndef __clang__ // broken and also slow
fpenv.ClearFlags();
#endif
@@ -351,17 +377,17 @@ FLT TimesIntPowerOfTen(FLT x, int power) {
return x * ToIntPower<FLT>(10.0, power);
}
-template <typename UINT = std::uint32_t, typename FLT = float,
- typename REAL = Real4>
+template <typename UINT = std::uint32_t, typename FLT = float, int KIND = 4>
void subsetTests(int pass, Rounding rounding, std::uint32_t opds) {
+ using REAL = Scalar<Type<TypeCategory::Real>>;
for (int j{0}; j < 63; ++j) {
std::int64_t x{1};
x <<= j;
- inttest<UINT, FLT, REAL>(x, pass, rounding);
- inttest<UINT, FLT, REAL>(-x, pass, rounding);
+ inttest<UINT, FLT, KIND>(x, pass, rounding);
+ inttest<UINT, FLT, KIND>(-x, pass, rounding);
}
- inttest<UINT, FLT, REAL>(0, pass, rounding);
- inttest<UINT, FLT, REAL>(
+ inttest<UINT, FLT, KIND>(0, pass, rounding);
+ inttest<UINT, FLT, KIND>(
static_cast<std::int64_t>(0x8000000000000000), pass, rounding);
union {
@@ -375,7 +401,7 @@ void subsetTests(int pass, Rounding rounding, std::uint32_t opds) {
UINT rj{MakeReal(j)};
u.ui = rj;
FLT fj{u.f};
- REAL x{typename REAL::Word{std::uint64_t{rj}}};
+ REAL x{typename REAL::Word{std::uint64_t{rj}, KIND}, KIND};
// unary operations
{
@@ -422,7 +448,7 @@ void subsetTests(int pass, Rounding rounding, std::uint32_t opds) {
MATCH(IsInfinite(rj), x.IsInfinite())
("%d IsInfinite(0x%jx)", pass, static_cast<std::intmax_t>(rj));
- static constexpr int kind{REAL::bits / 8};
+ static constexpr int kind{KIND};
std::string s, cssBuf;
llvm::raw_string_ostream ss{s};
llvm::raw_string_ostream css{cssBuf};
@@ -444,7 +470,7 @@ void subsetTests(int pass, Rounding rounding, std::uint32_t opds) {
if (*p == '(') {
++p;
}
- auto readBack{REAL::Read(p, rounding)};
+ auto readBack{REAL::Read(p, KIND, rounding)};
MATCH(rj, readBack.value.RawBits().ToUInt64())
("%d Read(AsFortran()) 0x%jx %s %g", pass,
static_cast<std::intmax_t>(rj), s.data(), static_cast<double>(fj));
@@ -460,7 +486,7 @@ void subsetTests(int pass, Rounding rounding, std::uint32_t opds) {
UINT rk{MakeReal(k)};
u.ui = rk;
FLT fk{u.f};
- REAL y{typename REAL::Word{std::uint64_t{rk}}};
+ REAL y{typename REAL::Word{std::uint64_t{rk}, KIND}, KIND};
{
ValueWithRealFlags<REAL> sum{x.Add(y, rounding)};
#ifndef __clang__ // broken and also slow
@@ -534,17 +560,17 @@ void subsetTests(int pass, Rounding rounding, std::uint32_t opds) {
}
void roundTest(int rm, Rounding rounding, std::uint32_t opds) {
- basicTests<Real2>(rm, rounding);
- basicTests<Real3>(rm, rounding);
- basicTests<Real4>(rm, rounding);
- basicTests<Real8>(rm, rounding);
+ basicTests<2>(rm, rounding);
+ basicTests<3>(rm, rounding);
+ basicTests<4>(rm, rounding);
+ basicTests<8>(rm, rounding);
#ifdef __x86_64__
- basicTests<Real10>(rm, rounding);
+ basicTests<10>(rm, rounding);
#endif
- basicTests<Real16>(rm, rounding);
+ basicTests<16>(rm, rounding);
ScopedHostFloatingPointEnvironment::SetRounding(rounding);
- subsetTests<std::uint32_t, float, Real4>(rm, rounding, opds);
- subsetTests<std::uint64_t, double, Real8>(rm, rounding, opds);
+ subsetTests<std::uint32_t, float, 4>(rm, rounding, opds);
+ subsetTests<std::uint64_t, double, 8>(rm, rounding, opds);
}
int main() {
More information about the flang-commits
mailing list