From e8709a4d6a9b84c7b69143a39e06a07a7b80835d Mon Sep 17 00:00:00 2001
From: peter klausler <pklausler@nvidia.com>
Date: Thu, 7 Feb 2019 12:05:27 -0800
Subject: [PATCH] [flang] checkpoint Constant<SomeDerived> based on
 StructureConstructor

Original-commit: flang-compiler/f18@47986f0c7e1c5e47ac1aa0830c08e1dafe186fd8
Reviewed-on: https://github.com/flang-compiler/f18/pull/287
Tree-same-pre-rewrite: false
---
 flang/lib/evaluate/common.h      |  4 --
 flang/lib/evaluate/constant.cc   | 18 +++++++--
 flang/lib/evaluate/constant.h    | 85 ++++++++++++++++++++++++++++++----------
 flang/lib/evaluate/expression.cc |  2 +-
 flang/lib/evaluate/expression.h  | 39 ++++++++++++++++--
 flang/lib/evaluate/fold.cc       | 47 ++++++++++++++++++----
 flang/lib/evaluate/type.cc       | 67 ++++++++++++++++++++++++++++++-
 flang/lib/evaluate/type.h        | 51 +++++++++++++-----------
 8 files changed, 249 insertions(+), 64 deletions(-)

diff --git a/flang/lib/evaluate/common.h b/flang/lib/evaluate/common.h
index d63e0cd..bd42d17 100644
--- a/flang/lib/evaluate/common.h
+++ b/flang/lib/evaluate/common.h
@@ -29,10 +29,6 @@ namespace Fortran::semantics {
 class DerivedTypeSpec;
 }
 
-namespace Fortran::semantics {
-class DerivedTypeSpec;
-}
-
 namespace Fortran::evaluate {
 
 using common::RelationalOperator;
diff --git a/flang/lib/evaluate/constant.cc b/flang/lib/evaluate/constant.cc
index 3350649..3772aa7 100644
--- a/flang/lib/evaluate/constant.cc
+++ b/flang/lib/evaluate/constant.cc
@@ -13,12 +13,16 @@
 // limitations under the License.
 
 #include "constant.h"
+#include "expression.h"
 #include "type.h"
 #include "../parser/characters.h"
 
 namespace Fortran::evaluate {
+
+template<typename T> ConstantBase<T>::~ConstantBase() {}
+
 template<typename T>
-std::ostream &Constant<T>::AsFortran(std::ostream &o) const {
+std::ostream &ConstantBase<T>::AsFortran(std::ostream &o) const {
   if (Rank() > 1) {
     o << "reshape(";
   }
@@ -47,7 +51,7 @@ std::ostream &Constant<T>::AsFortran(std::ostream &o) const {
       }
       o << '_' << Result::kind;
     } else {
-      value.u.AsFortran(o);
+      value.AsFortran(o);
     }
   }
   if (Rank() > 0) {
@@ -66,7 +70,8 @@ std::ostream &Constant<T>::AsFortran(std::ostream &o) const {
 }
 
 template<typename T>
-auto Constant<T>::At(const std::vector<std::int64_t> &index) const -> Value {
+auto ConstantBase<T>::At(const std::vector<std::int64_t> &index) const
+    -> Value {
   CHECK(index.size() == static_cast<std::size_t>(Rank()));
   std::int64_t stride{1}, offset{0};
   int dim{0};
@@ -79,7 +84,7 @@ auto Constant<T>::At(const std::vector<std::int64_t> &index) const -> Value {
   return values_.at(offset);
 }
 
-template<typename T> Constant<SubscriptInteger> Constant<T>::SHAPE() const {
+template<typename T> Constant<SubscriptInteger> ConstantBase<T>::SHAPE() const {
   using IntType = Scalar<SubscriptInteger>;
   std::vector<IntType> result;
   for (std::int64_t dim : shape_) {
@@ -88,5 +93,10 @@ template<typename T> Constant<SubscriptInteger> Constant<T>::SHAPE() const {
   return {std::move(result), std::vector<std::int64_t>{Rank()}};
 }
 
+Constant<SomeDerived>::Constant(const semantics::DerivedTypeSpec &spec,
+    std::vector<StructureConstructor> &&x, std::vector<std::int64_t> &&s)
+  : Base{std::move(x), std::move(s)}, spec_{&spec} {}
+
+FOR_EACH_SPECIFIC_TYPE(template class ConstantBase)
 FOR_EACH_INTRINSIC_KIND(template class Constant)
 }
diff --git a/flang/lib/evaluate/constant.h b/flang/lib/evaluate/constant.h
index 5c73f96..a3983c4 100644
--- a/flang/lib/evaluate/constant.h
+++ b/flang/lib/evaluate/constant.h
@@ -24,24 +24,24 @@ namespace Fortran::evaluate {
 // N.B. Generic constants are represented by generic expressions
 // (like Expr<SomeInteger> & Expr<SomeType>) wrapping the appropriate
 // instantiations of Constant.
-template<typename T> class Constant {
-  static_assert(std::is_same_v<T, SomeDerived> || IsSpecificIntrinsicType<T>);
 
+template<typename> class Constant;
+
+template<typename RESULT> class ConstantBase {
 public:
-  using Result = T;
+  using Result = RESULT;
   using Value = Scalar<Result>;
 
-  CLASS_BOILERPLATE(Constant)
-  template<typename A> Constant(const A &x) : values_{x} {}
+  template<typename A> ConstantBase(const A &x) : values_{x} {}
   template<typename A>
-  Constant(std::enable_if_t<!std::is_reference_v<A>, A> &&x)
+  ConstantBase(std::enable_if_t<!std::is_reference_v<A>, A> &&x)
     : values_{std::move(x)} {}
-  Constant(std::vector<Value> &&x, std::vector<std::int64_t> &&s)
+  ConstantBase(std::vector<Value> &&x, std::vector<std::int64_t> &&s)
     : values_(std::move(x)), shape_(std::move(s)) {}
+  ~ConstantBase();
 
-  constexpr DynamicType GetType() const { return Result::GetType(); }
   int Rank() const { return static_cast<int>(shape_.size()); }
-  bool operator==(const Constant &that) const {
+  bool operator==(const ConstantBase &that) const {
     return shape_ == that.shape_ && values_ == that.values_;
   }
   bool empty() const { return values_.empty(); }
@@ -59,25 +59,68 @@ public:
   Constant<SubscriptInteger> SHAPE() const;
   std::ostream &AsFortran(std::ostream &) const;
 
-private:
+protected:
   std::vector<Value> values_;
   std::vector<std::int64_t> shape_;
-  // TODO pmk: make CHARACTER values contiguous (they're strings now)
+
+private:
+  const Constant<Result> &AsConstant() const {
+    return *static_cast<const Constant<Result> *>(this);
+  }
+
+  DynamicType GetType() const { return AsConstant().GetType(); }
+};
+
+template<typename T> class Constant : public ConstantBase<T> {
+public:
+  using Result = T;
+  using ConstantBase<Result>::ConstantBase;
+  CLASS_BOILERPLATE(Constant)
+  static constexpr DynamicType GetType() { return Result::GetType(); }
 };
 
-// Would prefer to have this be a member function of Constant enabled
-// only for CHARACTER, but std::enable_if<> isn't effective in that context.
 template<int KIND>
-std::int64_t ConstantLEN(
-    const Constant<Type<TypeCategory::Character, KIND>> &c) {
-  if (c.empty()) {
-    return 0;
-  } else {
-    std::vector<std::int64_t> ones(c.Rank(), 1);
-    return c.At(ones).size();
+class Constant<Type<TypeCategory::Character, KIND>>
+  : public ConstantBase<Type<TypeCategory::Character, KIND>> {
+public:
+  using Result = Type<TypeCategory::Character, KIND>;
+  using ConstantBase<Result>::ConstantBase;
+  CLASS_BOILERPLATE(Constant)
+  static constexpr DynamicType GetType() { return Result::GetType(); }
+  std::int64_t LEN() const {
+    if (this->values_.empty()) {
+      return 0;
+    } else {
+      return static_cast<std::int64_t>(this->values_.front().size());
+    }
   }
-}
+  // TODO pmk: make CHARACTER values contiguous (they're strings now)
+};
+
+template<> class Constant<SomeDerived> : public ConstantBase<SomeDerived> {
+public:
+  using Result = SomeDerived;
+  using Base = ConstantBase<Result>;
+  template<typename A>
+  Constant(const semantics::DerivedTypeSpec &spec, const A &x)
+    : Base{x}, spec_{&spec} {}
+  template<typename A>
+  Constant(const semantics::DerivedTypeSpec &spec,
+      std::enable_if_t<!std::is_reference_v<A>, A> &&x)
+    : Base{std::move(x)}, spec_{&spec} {}
+  Constant(const semantics::DerivedTypeSpec &, std::vector<Value> &&,
+      std::vector<std::int64_t> &&);
+
+  CLASS_BOILERPLATE(Constant)
+  DynamicType GetType() const {
+    return DynamicType{TypeCategory::Derived, 0, spec_};
+  }
+
+private:
+  const semantics::DerivedTypeSpec *spec_;
+};
 
+FOR_EACH_SPECIFIC_TYPE(extern template class ConstantBase)
 FOR_EACH_INTRINSIC_KIND(extern template class Constant)
 }
 #endif  // FORTRAN_EVALUATE_CONSTANT_H_
diff --git a/flang/lib/evaluate/expression.cc b/flang/lib/evaluate/expression.cc
index 114250c..5123bca 100644
--- a/flang/lib/evaluate/expression.cc
+++ b/flang/lib/evaluate/expression.cc
@@ -150,7 +150,7 @@ Expr<SubscriptInteger> Expr<Type<TypeCategory::Character, KIND>>::LEN() const {
   return std::visit(
       common::visitors{
           [](const Constant<Result> &c) {
-            return AsExpr(Constant<SubscriptInteger>{ConstantLEN(c)});
+            return AsExpr(Constant<SubscriptInteger>{c.LEN()});
           },
           [](const ArrayConstructor<Result> &a) { return a.LEN(); },
           [](const Parentheses<Result> &x) { return x.left().LEN(); },
diff --git a/flang/lib/evaluate/expression.h b/flang/lib/evaluate/expression.h
index b52f8b3..af606e75 100644
--- a/flang/lib/evaluate/expression.h
+++ b/flang/lib/evaluate/expression.h
@@ -633,14 +633,47 @@ public:
 
 FOR_EACH_LOGICAL_KIND(extern template class Expr)
 
+class StructureConstructor {
+public:
+  using Values = std::list<std::pair<const semantics::Symbol *,
+      CopyableIndirection<Expr<SomeType>>>>;
+
+  // N.B. CLASS_BOILERPLATE() can't be used here due to forward reference
+  // to Expr<SomeType> preventing the use of "= default" constructors and
+  // assignment operators.
+  StructureConstructor() = delete;
+  explicit StructureConstructor(const semantics::DerivedTypeSpec &spec)
+    : derivedTypeSpec_{&spec} {}
+  StructureConstructor(const StructureConstructor &);
+  StructureConstructor(StructureConstructor &&);
+  ~StructureConstructor();
+  StructureConstructor &operator=(const StructureConstructor &);
+  StructureConstructor &operator=(StructureConstructor &&);
+
+  const semantics::DerivedTypeSpec &derivedTypeSpec() const {
+    return *derivedTypeSpec_;
+  }
+  Values &values() { return values_; }
+  const Values &values() const { return values_; }
+  bool operator==(const StructureConstructor &) const;
+
+  StructureConstructor &Add(const semantics::Symbol &, Expr<SomeType> &&);
+  int Rank() const { return 0; }
+  DynamicType GetType() const;
+  std::ostream &AsFortran(std::ostream &) const;
+
+private:
+  const semantics::DerivedTypeSpec *derivedTypeSpec_;
+  Values values_;
+};
+
 // An expression whose result has a derived type.
 template<> class Expr<SomeDerived> : public ExpressionBase<SomeDerived> {
 public:
   using Result = SomeDerived;
   EVALUATE_UNION_CLASS_BOILERPLATE(Expr)
-  // TODO: structure constructor
-  std::variant<Designator<Result>, ArrayConstructor<Result>,
-      FunctionRef<Result>>
+  std::variant<Constant<Result>, ArrayConstructor<Result>, StructureConstructor,
+      Designator<Result>, FunctionRef<Result>>
       u;
 };
 
diff --git a/flang/lib/evaluate/fold.cc b/flang/lib/evaluate/fold.cc
index d24e07e..cd5a9ba 100644
--- a/flang/lib/evaluate/fold.cc
+++ b/flang/lib/evaluate/fold.cc
@@ -57,6 +57,7 @@ Expr<Type<TypeCategory::Integer, KIND>> FoldOperation(
     FoldingContext &, TypeParamInquiry<KIND> &&);
 template<typename T>
 Expr<T> FoldOperation(FoldingContext &, ArrayConstructor<T> &&);
+Expr<SomeDerived> FoldOperation(FoldingContext &, StructureConstructor &&);
 
 // Overloads, instantiations, and specializations of FoldOperation().
 
@@ -230,9 +231,13 @@ public:
   Expr<T> FoldArray(ArrayConstructor<T> &&array) {
     if (FoldArray(array.values)) {
       std::int64_t n = elements_.size();
-      Expr<T> result{
-          Constant<T>{std::move(elements_), std::vector<std::int64_t>{n}}};
-      return result;
+      if constexpr (std::is_same_v<T, SomeDerived>) {
+        return Expr<T>{Constant<T>{array.type.spec(), std::move(elements_),
+            std::vector<std::int64_t>{n}}};
+      } else {
+        return Expr<T>{
+            Constant<T>{std::move(elements_), std::vector<std::int64_t>{n}}};
+      }
     } else {
       return Expr<T>{std::move(array)};
     }
@@ -304,11 +309,14 @@ Expr<T> FoldOperation(FoldingContext &context, ArrayConstructor<T> &&array) {
   return result;
 }
 
-// TODO this specialization is a placeholder: don't fold array constructors
-// of derived type for now
 Expr<SomeDerived> FoldOperation(
-    FoldingContext &context, ArrayConstructor<SomeDerived> &&array) {
-  return Expr<SomeDerived>{std::move(array)};
+    FoldingContext &context, StructureConstructor &&structure) {
+  StructureConstructor result{structure.derivedTypeSpec()};
+  for (auto &&[symbol, value] : std::move(structure.values())) {
+    result.Add(*symbol, Fold(context, std::move(*value)));
+  }
+  return Expr<SomeDerived>{
+      Constant<SomeDerived>{result.derivedTypeSpec(), result}};
 }
 
 // Substitute a bare type parameter reference with its value if it has one now
@@ -783,6 +791,8 @@ template<typename A>
 bool IsConstExpr(ConstExprContext &, const ArrayConstructorValues<A> &);
 template<typename A>
 bool IsConstExpr(ConstExprContext &, const ArrayConstructor<A> &);
+bool IsConstExpr(ConstExprContext &, const semantics::DerivedTypeSpec &);
+bool IsConstExpr(ConstExprContext &, const StructureConstructor &);
 bool IsConstExpr(ConstExprContext &, const BaseObject &);
 bool IsConstExpr(ConstExprContext &, const Component &);
 bool IsConstExpr(ConstExprContext &, const Triplet &);
@@ -843,6 +853,29 @@ template<typename A>
 bool IsConstExpr(ConstExprContext &context, const ArrayConstructor<A> &array) {
   return IsConstExpr(context, array.values);
 }
+bool IsConstExpr(
+    ConstExprContext &context, const semantics::DerivedTypeSpec &spec) {
+  for (const auto &nameValue : spec.parameters()) {
+    const auto &value{nameValue.second};
+    if (!value.isExplicit() || !value.GetExplicit().has_value() ||
+        !IsConstExpr(context, *value.GetExplicit())) {
+      return false;
+    }
+  }
+  return true;
+}
+bool IsConstExpr(
+    ConstExprContext &context, const StructureConstructor &structure) {
+  if (!IsConstExpr(context, structure.derivedTypeSpec())) {
+    return false;
+  }
+  for (const auto &symbolExpr : structure.values()) {
+    if (!IsConstExpr(context, symbolExpr.second)) {
+      return false;
+    }
+  }
+  return true;
+}
 bool IsConstExpr(ConstExprContext &context, const BaseObject &base) {
   return IsConstExpr(context, base.u);
 }
diff --git a/flang/lib/evaluate/type.cc b/flang/lib/evaluate/type.cc
index ee45eb1..1a521d4 100644
--- a/flang/lib/evaluate/type.cc
+++ b/flang/lib/evaluate/type.cc
@@ -13,6 +13,7 @@
 // limitations under the License.
 
 #include "type.h"
+#include "expression.h"
 #include "fold.h"
 #include "../common/idioms.h"
 #include "../semantics/scope.h"
@@ -20,6 +21,8 @@
 #include "../semantics/type.h"
 #include <algorithm>
 #include <optional>
+#include <ostream>
+#include <sstream>
 #include <string>
 
 using namespace std::literals::string_literals;
@@ -182,7 +185,69 @@ bool SomeKind<TypeCategory::Derived>::operator==(
   return spec_ == that.spec_ && descriptor_ == that.descriptor_;
 }
 
+static std::ostream &DerivedTypeSpecAsFortran(
+    std::ostream &o, const semantics::DerivedTypeSpec &spec) {
+  o << "TYPE("s << spec.typeSymbol().name().ToString();
+  if (!spec.parameters().empty()) {
+    char ch{'('};
+    for (const auto &[name, value] : spec.parameters()) {
+      value.GetExplicit()->AsFortran(o << ch << name.ToString() << '=');
+      ch = ',';
+    }
+    o << ')';
+  }
+  return o;
+}
+
 std::string SomeDerived::AsFortran() const {
-  return "TYPE("s + spec().typeSymbol().name().ToString() + ')';
+  std::stringstream out;
+  DerivedTypeSpecAsFortran(out, spec());
+  return out.str();
+}
+
+StructureConstructor::StructureConstructor(const StructureConstructor &that)
+  : derivedTypeSpec_{that.derivedTypeSpec_}, values_{that.values_} {}
+StructureConstructor::StructureConstructor(StructureConstructor &&that)
+  : derivedTypeSpec_{that.derivedTypeSpec_}, values_{std::move(that.values_)} {}
+StructureConstructor::~StructureConstructor() {}
+StructureConstructor &StructureConstructor::operator=(
+    const StructureConstructor &that) {
+  derivedTypeSpec_ = that.derivedTypeSpec_;
+  values_ = that.values_;
+  return *this;
+}
+StructureConstructor &StructureConstructor::operator=(
+    StructureConstructor &&that) {
+  derivedTypeSpec_ = that.derivedTypeSpec_;
+  values_ = std::move(that.values_);
+  return *this;
+}
+
+bool StructureConstructor::operator==(const StructureConstructor &that) const {
+  return derivedTypeSpec_ == that.derivedTypeSpec_ && values_ == that.values_;
+}
+
+DynamicType StructureConstructor::GetType() const {
+  return {TypeCategory::Derived, 0, derivedTypeSpec_};
+}
+
+StructureConstructor &StructureConstructor::Add(
+    const Symbol &symbol, Expr<SomeType> &&expr) {
+  values_.emplace_back(&symbol, std::move(expr));
+  return *this;
+}
+
+std::ostream &StructureConstructor::AsFortran(std::ostream &o) const {
+  DerivedTypeSpecAsFortran(o, *derivedTypeSpec_);
+  if (values_.empty()) {
+    o << '(';
+  } else {
+    char ch{'('};
+    for (const auto &[symbol, value] : values_) {
+      value->AsFortran(o << ch << symbol->name().ToString() << '=');
+      ch = ',';
+    }
+  }
+  return o << ')';
 }
 }
diff --git a/flang/lib/evaluate/type.h b/flang/lib/evaluate/type.h
index 1fc5a6a..d40a255 100644
--- a/flang/lib/evaluate/type.h
+++ b/flang/lib/evaluate/type.h
@@ -33,6 +33,7 @@
 #include <cinttypes>
 #include <optional>
 #include <string>
+#include <type_traits>
 #include <variant>
 
 namespace Fortran::semantics {
@@ -176,8 +177,6 @@ public:
 
 // Type functions
 
-template<typename T> using Scalar = typename std::decay_t<T>::Scalar;
-
 // 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>;
@@ -245,33 +244,22 @@ template<typename T>
 constexpr bool IsLengthlessIntrinsicType{
     common::HasMember<T, LengthlessIntrinsicTypes>};
 
-// When Scalar<T> is S, then TypeOf<S> is T.
-// TypeOf is implemented by scanning all supported types for a match
-// with Type<T>::Scalar.
-template<typename CONST> struct TypeOfHelper {
-  template<typename T> struct Predicate {
-    static constexpr bool value() {
-      return std::is_same_v<std::decay_t<CONST>,
-          std::decay_t<typename T::Scalar>>;
-    }
-  };
-  static constexpr int index{
-      common::SearchMembers<Predicate, AllIntrinsicTypes>};
-  using type = std::conditional_t<index >= 0,
-      std::tuple_element_t<index, AllIntrinsicTypes>, void>;
-};
-
-template<typename CONST> using TypeOf = typename TypeOfHelper<CONST>::type;
-
 // Represents a type of any supported kind within a particular category.
 template<TypeCategory CATEGORY> struct SomeKind {
   static constexpr TypeCategory category{CATEGORY};
   constexpr bool operator==(const SomeKind &) const { return true; }
 };
 
+// Represents a completely generic type (but not typeless).
+struct SomeType {};
+
+// Represents a derived type
+class StructureConstructor;
+
 template<> class SomeKind<TypeCategory::Derived> {
 public:
   static constexpr TypeCategory category{TypeCategory::Derived};
+  using Scalar = StructureConstructor;
 
   CLASS_BOILERPLATE(SomeKind)
   explicit SomeKind(const semantics::DerivedTypeSpec &dts,
@@ -297,11 +285,28 @@ using SomeComplex = SomeKind<TypeCategory::Complex>;
 using SomeCharacter = SomeKind<TypeCategory::Character>;
 using SomeLogical = SomeKind<TypeCategory::Logical>;
 using SomeDerived = SomeKind<TypeCategory::Derived>;
-
-// Represents a completely generic type (but not typeless).
 using SomeCategory = std::tuple<SomeInteger, SomeReal, SomeComplex,
     SomeCharacter, SomeLogical, SomeDerived>;
-struct SomeType {};
+
+template<typename T> using Scalar = typename std::decay_t<T>::Scalar;
+
+// When Scalar<T> is S, then TypeOf<S> is T.
+// TypeOf is implemented by scanning all supported types for a match
+// with Type<T>::Scalar.
+template<typename CONST> struct TypeOfHelper {
+  template<typename T> struct Predicate {
+    static constexpr bool value() {
+      return std::is_same_v<std::decay_t<CONST>,
+          std::decay_t<typename T::Scalar>>;
+    }
+  };
+  static constexpr int index{
+      common::SearchMembers<Predicate, AllIntrinsicTypes>};
+  using type = std::conditional_t<index >= 0,
+      std::tuple_element_t<index, AllIntrinsicTypes>, void>;
+};
+
+template<typename CONST> using TypeOf = typename TypeOfHelper<CONST>::type;
 
 // For generating "[extern] template class", &c. boilerplate
 #define EXPAND_FOR_EACH_INTEGER_KIND(M, P) \
-- 
2.7.4