--- /dev/null
+//===-------include/flang/Evaluate/initial-image.h ------------------------===//
+//
+// 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_INITIAL_IMAGE_H_
+#define FORTRAN_EVALUATE_INITIAL_IMAGE_H_
+
+// Represents the initialized storage of an object during DATA statement
+// processing, including the conversion of that image to a constant
+// initializer for a symbol.
+
+#include "expression.h"
+#include <map>
+#include <optional>
+#include <vector>
+
+namespace Fortran::evaluate {
+
+class InitialImage {
+public:
+ explicit InitialImage(std::size_t bytes) : data_(bytes) {}
+
+ std::size_t size() const { return data_.size(); }
+
+ template <typename A> bool Add(ConstantSubscript, std::size_t, const A &) {
+ return false;
+ }
+ template <typename T>
+ bool Add(ConstantSubscript offset, std::size_t bytes, const Constant<T> &x) {
+ CHECK(offset >= 0 && offset + bytes <= data_.size());
+ auto elementBytes{x.GetType().MeasureSizeInBytes()};
+ CHECK(elementBytes && bytes == x.values().size() * *elementBytes);
+ std::memcpy(&data_.at(offset), &x.values().at(0), bytes);
+ return true;
+ }
+ template <int KIND>
+ bool Add(ConstantSubscript offset, std::size_t bytes,
+ const Constant<Type<TypeCategory::Character, KIND>> &x) {
+ CHECK(offset >= 0 && offset + bytes <= data_.size());
+ auto elements{TotalElementCount(x.shape())};
+ auto elementBytes{bytes > 0 ? bytes / elements : 0};
+ CHECK(elements * elementBytes == bytes);
+ for (auto at{x.lbounds()}; elements-- > 0; x.IncrementSubscripts(at)) {
+ auto scalar{x.At(at)}; // this is a std string; size() in chars
+ // Subtle: an initializer for a substring may have been
+ // expanded to the length of the entire string.
+ CHECK(scalar.size() * KIND == elementBytes ||
+ (elements == 0 && scalar.size() * KIND > elementBytes));
+ std::memcpy(&data_[offset], scalar.data(), elementBytes);
+ offset += elementBytes;
+ }
+ return true;
+ }
+ bool Add(ConstantSubscript, std::size_t, const Constant<SomeDerived> &);
+ template <typename T>
+ bool Add(ConstantSubscript offset, std::size_t bytes, const Expr<T> &x) {
+ return std::visit(
+ [&](const auto &y) { return Add(offset, bytes, y); }, x.u);
+ }
+
+ void AddPointer(ConstantSubscript, const Expr<SomeType> &);
+
+ // Conversions to constant initializers
+ std::optional<Expr<SomeType>> AsConstant(FoldingContext &,
+ const DynamicType &, const ConstantSubscripts &,
+ ConstantSubscript offset = 0) const;
+ std::optional<Expr<SomeType>> AsConstantDataPointer(
+ const DynamicType &, ConstantSubscript offset = 0) const;
+ const ProcedureDesignator &AsConstantProcPointer(
+ ConstantSubscript offset = 0) const;
+
+ friend class AsConstantHelper;
+ friend class AsConstantDataPointerHelper;
+
+private:
+ std::vector<char> data_;
+ std::map<ConstantSubscript, Expr<SomeType>> pointers_;
+};
+
+} // namespace Fortran::evaluate
+#endif // FORTRAN_EVALUATE_INITIAL_IMAGE_H_
--- /dev/null
+//===-- lib/Evaluate/initial-image.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/initial-image.h"
+#include "flang/Semantics/scope.h"
+#include "flang/Semantics/tools.h"
+
+namespace Fortran::evaluate {
+
+bool InitialImage::Add(ConstantSubscript offset, std::size_t bytes,
+ const Constant<SomeDerived> &x) {
+ CHECK(offset >= 0 && offset + bytes <= data_.size());
+ auto elements{TotalElementCount(x.shape())};
+ auto elementBytes{bytes > 0 ? bytes / elements : 0};
+ CHECK(elements * elementBytes == bytes);
+ auto at{x.lbounds()};
+ for (auto elements{TotalElementCount(x.shape())}; elements-- > 0;
+ x.IncrementSubscripts(at)) {
+ auto scalar{x.At(at)};
+ // TODO: length type parameter values?
+ for (const auto &[symbolRef, indExpr] : scalar) {
+ const Symbol &component{*symbolRef};
+ CHECK(component.offset() + component.size() <= elementBytes);
+ if (IsPointer(component)) {
+ AddPointer(offset + component.offset(), indExpr.value());
+ } else if (!Add(offset + component.offset(), component.size(),
+ indExpr.value())) {
+ return false;
+ }
+ }
+ offset += elementBytes;
+ }
+ return true;
+}
+
+void InitialImage::AddPointer(
+ ConstantSubscript offset, const Expr<SomeType> &pointer) {
+ pointers_.emplace(offset, pointer);
+}
+
+// Classes used with common::SearchTypes() to (re)construct Constant<> values
+// of the right type to initialize each symbol from the values that have
+// been placed into its initialization image by DATA statements.
+class AsConstantHelper {
+public:
+ using Result = std::optional<Expr<SomeType>>;
+ using Types = AllTypes;
+ AsConstantHelper(FoldingContext &context, const DynamicType &type,
+ const ConstantSubscripts &extents, const InitialImage &image,
+ ConstantSubscript offset = 0)
+ : context_{context}, type_{type}, image_{image}, extents_{extents},
+ offset_{offset} {
+ CHECK(!type.IsPolymorphic());
+ }
+ template <typename T> Result Test() {
+ if (T::category != type_.category()) {
+ return std::nullopt;
+ }
+ if constexpr (T::category != TypeCategory::Derived) {
+ if (T::kind != type_.kind()) {
+ return std::nullopt;
+ }
+ }
+ using Const = Constant<T>;
+ using Scalar = typename Const::Element;
+ std::size_t elements{TotalElementCount(extents_)};
+ std::vector<Scalar> typedValue(elements);
+ auto stride{type_.MeasureSizeInBytes()};
+ CHECK(stride > 0);
+ CHECK(offset_ + elements * *stride <= image_.data_.size());
+ if constexpr (T::category == TypeCategory::Derived) {
+ const semantics::DerivedTypeSpec &derived{type_.GetDerivedTypeSpec()};
+ for (auto iter : DEREF(derived.scope())) {
+ const Symbol &component{*iter.second};
+ bool isPointer{IsPointer(component)};
+ if (component.has<semantics::ObjectEntityDetails>() ||
+ component.has<semantics::ProcEntityDetails>()) {
+ auto componentType{DynamicType::From(component)};
+ CHECK(componentType);
+ auto at{offset_ + component.offset()};
+ if (isPointer) {
+ for (std::size_t j{0}; j < elements; ++j, at += *stride) {
+ Result value{image_.AsConstantDataPointer(*componentType, at)};
+ CHECK(value);
+ typedValue[j].emplace(component, std::move(*value));
+ }
+ } else {
+ auto componentExtents{GetConstantExtents(context_, component)};
+ CHECK(componentExtents);
+ for (std::size_t j{0}; j < elements; ++j, at += *stride) {
+ Result value{image_.AsConstant(
+ context_, *componentType, *componentExtents, at)};
+ CHECK(value);
+ typedValue[j].emplace(component, std::move(*value));
+ }
+ }
+ }
+ }
+ 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};
+ for (std::size_t j{0}; j < elements; ++j) {
+ using Char = typename Scalar::value_type;
+ const Char *data{reinterpret_cast<const Char *>(
+ &image_.data_[offset_ + j * *stride])};
+ typedValue[j].assign(data, length);
+ }
+ return AsGenericExpr(
+ Const{length, std::move(typedValue), std::move(extents_)});
+ } else {
+ // Lengthless intrinsic type
+ CHECK(sizeof(Scalar) <= *stride);
+ for (std::size_t j{0}; j < elements; ++j) {
+ std::memcpy(&typedValue[j], &image_.data_[offset_ + j * *stride],
+ sizeof(Scalar));
+ }
+ return AsGenericExpr(Const{std::move(typedValue), std::move(extents_)});
+ }
+ }
+
+private:
+ FoldingContext &context_;
+ const DynamicType &type_;
+ const InitialImage &image_;
+ ConstantSubscripts extents_; // a copy
+ ConstantSubscript offset_;
+};
+
+std::optional<Expr<SomeType>> InitialImage::AsConstant(FoldingContext &context,
+ const DynamicType &type, const ConstantSubscripts &extents,
+ ConstantSubscript offset) const {
+ return common::SearchTypes(
+ AsConstantHelper{context, type, extents, *this, offset});
+}
+
+class AsConstantDataPointerHelper {
+public:
+ using Result = std::optional<Expr<SomeType>>;
+ using Types = AllTypes;
+ AsConstantDataPointerHelper(const DynamicType &type,
+ const InitialImage &image, ConstantSubscript offset = 0)
+ : type_{type}, image_{image}, offset_{offset} {}
+ template <typename T> Result Test() {
+ if (T::category != type_.category()) {
+ return std::nullopt;
+ }
+ if constexpr (T::category != TypeCategory::Derived) {
+ if (T::kind != type_.kind()) {
+ return std::nullopt;
+ }
+ }
+ auto iter{image_.pointers_.find(offset_)};
+ if (iter == image_.pointers_.end()) {
+ return AsGenericExpr(NullPointer{});
+ }
+ return iter->second;
+ }
+
+private:
+ const DynamicType &type_;
+ const InitialImage &image_;
+ ConstantSubscript offset_;
+};
+
+std::optional<Expr<SomeType>> InitialImage::AsConstantDataPointer(
+ const DynamicType &type, ConstantSubscript offset) const {
+ return common::SearchTypes(AsConstantDataPointerHelper{type, *this, offset});
+}
+
+const ProcedureDesignator &InitialImage::AsConstantProcPointer(
+ ConstantSubscript offset) const {
+ auto iter{pointers_.find(0)};
+ CHECK(iter != pointers_.end());
+ return DEREF(std::get_if<ProcedureDesignator>(&iter->second.u));
+}
+
+} // namespace Fortran::evaluate