From 0aae9893a5293e4abce0f45febe1285246164655 Mon Sep 17 00:00:00 2001
From: peter klausler <pklausler@nvidia.com>
Date: Thu, 19 Jul 2018 09:53:42 -0700
Subject: [PATCH] [flang] checkpoint

Original-commit: flang-compiler/f18@7fae33797a4245c0be531dda27ec0fb8cddf4d37
Reviewed-on: https://github.com/flang-compiler/f18/pull/144
Tree-same-pre-rewrite: false
---
 flang/lib/evaluate/expression.cc  |  81 +++++++++++++++++++++
 flang/lib/evaluate/expression.h   |  64 ++++++++++++++---
 flang/lib/evaluate/type.h         |  14 +++-
 flang/lib/parser/message.h        |   4 ++
 flang/lib/parser/parse-tree.h     |   2 +-
 flang/lib/semantics/expression.cc | 115 +++++++++++++++++++++++-------
 flang/lib/semantics/expression.h  |  27 ++++---
 flang/lib/semantics/type.h        |   2 +-
 8 files changed, 263 insertions(+), 46 deletions(-)

diff --git a/flang/lib/evaluate/expression.cc b/flang/lib/evaluate/expression.cc
index b2d4e9036fea..f2032eca7039 100644
--- a/flang/lib/evaluate/expression.cc
+++ b/flang/lib/evaluate/expression.cc
@@ -381,6 +381,87 @@ std::optional<typename IntegerExpr<KIND>::Constant> IntegerExpr<KIND>::Fold(
       u_);
 }
 
+template<int KIND>
+std::optional<typename RealExpr<KIND>::Constant>
+RealExpr<KIND>::ConstantValue() const {
+  if (auto c{std::get_if<Constant>(&u_)}) {
+    return {*c};
+  }
+  return {};
+}
+
+template<int KIND> void RealExpr<KIND>::Fold(FoldingContext &context) {
+  // TODO
+}
+
+template<int KIND>
+std::optional<typename ComplexExpr<KIND>::Constant>
+ComplexExpr<KIND>::ConstantValue() const {
+  if (auto c{std::get_if<Constant>(&u_)}) {
+    return {*c};
+  }
+  return {};
+}
+
+template<int KIND> void ComplexExpr<KIND>::Fold(FoldingContext &context) {
+  // TODO
+}
+
+template<int KIND>
+std::optional<typename CharacterExpr<KIND>::Constant>
+CharacterExpr<KIND>::ConstantValue() const {
+  if (auto c{std::get_if<Constant>(&u_)}) {
+    return {*c};
+  }
+  return {};
+}
+
+template<int KIND> void CharacterExpr<KIND>::Fold(FoldingContext &context) {
+  // TODO
+}
+
+std::optional<bool> LogicalExpr::ConstantValue() const {
+  if (auto c{std::get_if<bool>(&u_)}) {
+    return {*c};
+  }
+  return {};
+}
+
+void LogicalExpr::Fold(FoldingContext &context) {
+  // TODO and comparisons too
+}
+
+std::optional<GenericConstant> GenericExpr::ConstantValue() const {
+  return std::visit([](const auto &x) -> std::optional<GenericConstant> {
+    if (auto c{x.ConstantValue()}) {
+      return {GenericConstant{std::move(*c)}};
+    }
+    return {};
+  }, u);
+}
+
+template<Category CAT> std::optional<CategoryConstant<CAT>> CategoryExpr<CAT>::ConstantValue() const {
+  return std::visit([](const auto &x) -> std::optional<CategoryConstant<CAT>> {
+    if (auto c{x.ConstantValue()}) {
+      return {CategoryConstant<CAT>{std::move(*c)}};
+    }
+    return {};
+  }, u);
+}
+
+template<Category CAT> void CategoryExpr<CAT>::Fold(FoldingContext &context) {
+  std::visit([&](auto &x){ x.Fold(context); }, u);
+}
+
+void GenericExpr::Fold(FoldingContext &context) {
+  std::visit([&](auto &x){ x.Fold(context); }, u);
+}
+
+template struct CategoryExpr<Category::Integer>;
+template struct CategoryExpr<Category::Real>;
+template struct CategoryExpr<Category::Complex>;
+template struct CategoryExpr<Category::Character>;
+
 template class Expr<Category::Integer, 1>;
 template class Expr<Category::Integer, 2>;
 template class Expr<Category::Integer, 4>;
diff --git a/flang/lib/evaluate/expression.h b/flang/lib/evaluate/expression.h
index 4b333aa95d2a..947e1763dd3c 100644
--- a/flang/lib/evaluate/expression.h
+++ b/flang/lib/evaluate/expression.h
@@ -236,6 +236,9 @@ public:
   Expr(std::enable_if_t<!std::is_reference_v<A>, A> &&x) : u_{std::move(x)} {}
   template<typename A> Expr(CopyableIndirection<A> &&x) : u_{std::move(x)} {}
 
+  std::optional<Constant> ConstantValue() const;
+  void Fold(FoldingContext &c);
+
 private:
   std::variant<Constant, CopyableIndirection<DataRef>,
       CopyableIndirection<ComplexPart>, CopyableIndirection<FunctionRef>,
@@ -285,6 +288,9 @@ public:
   Expr(std::enable_if_t<!std::is_reference_v<A>, A> &&x) : u_{std::move(x)} {}
   template<typename A> Expr(CopyableIndirection<A> &&x) : u_{std::move(x)} {}
 
+  std::optional<Constant> ConstantValue() const;
+  void Fold(FoldingContext &c);
+
 private:
   std::variant<Constant, CopyableIndirection<DataRef>,
       CopyableIndirection<FunctionRef>, Parentheses, Negate, Add, Subtract,
@@ -315,6 +321,8 @@ public:
   Expr(std::enable_if_t<!std::is_reference_v<A>, A> &&x) : u_{std::move(x)} {}
   template<typename A> Expr(CopyableIndirection<A> &&x) : u_{std::move(x)} {}
 
+  std::optional<Constant> ConstantValue() const;
+  void Fold(FoldingContext &c);
   SubscriptIntegerExpr LEN() const;
 
 private:
@@ -335,6 +343,7 @@ template<typename EXPR> struct Comparison : Binary<EXPR, EXPR, bool> {
     : Binary<EXPR, EXPR, bool>{a, b}, opr{r} {}
   Comparison(RelationalOperator r, EXPR &&a, EXPR &&b)
     : Binary<EXPR, EXPR, bool>{std::move(a), std::move(b)}, opr{r} {}
+  std::optional<bool> Fold(FoldingContext &c);
   RelationalOperator opr;
 };
 
@@ -359,11 +368,12 @@ extern template struct Comparison<CharacterExpr<1>>;
 // of a specific category.
 template<Category CAT> struct CategoryComparison {
   CLASS_BOILERPLATE(CategoryComparison)
+  template<int KIND> using KindComparison = Comparison<Expr<CAT, KIND>>;
   template<int KIND>
-  CategoryComparison(const Comparison<Expr<CAT, KIND>> &x) : u{x} {}
+  CategoryComparison(const KindComparison<KIND> &x) : u{x} {}
   template<int KIND>
-  CategoryComparison(Comparison<Expr<CAT, KIND>> &&x) : u{std::move(x)} {}
-  template<int K> using KindComparison = Comparison<Expr<CAT, K>>;
+  CategoryComparison(KindComparison<KIND> &&x) : u{std::move(x)} {}
+  std::optional<bool> Fold(FoldingContext &c);
   typename KindsVariant<CAT, KindComparison>::type u;
 };
 
@@ -372,7 +382,7 @@ template<> class Expr<Category::Logical, 1> {
 public:
   using Constant = bool;
   struct Not : Unary<Expr, bool> {
-    using Unary<Expr, Constant>::Unary;
+    using Unary<Expr, bool>::Unary;
   };
   using Bin = Binary<Expr, Expr, bool>;
   struct And : public Bin {
@@ -389,7 +399,7 @@ public:
   };
 
   CLASS_BOILERPLATE(Expr)
-  Expr(Constant x) : u_{x} {}
+  Expr(bool x) : u_{x} {}
   template<Category CAT, int KIND>
   Expr(const Comparison<Expr<CAT, KIND>> &x) : u_{CategoryComparison<CAT>{x}} {}
   template<Category CAT, int KIND>
@@ -400,8 +410,11 @@ public:
   Expr(std::enable_if_t<!std::is_reference_v<A>, A> &&x) : u_{std::move(x)} {}
   template<typename A> Expr(CopyableIndirection<A> &&x) : u_{std::move(x)} {}
 
+  std::optional<bool> ConstantValue() const;
+  void Fold(FoldingContext &c);
+
 private:
-  std::variant<Constant, CopyableIndirection<DataRef>,
+  std::variant<bool, CopyableIndirection<DataRef>,
       CopyableIndirection<FunctionRef>, Not, And, Or, Eqv, Neqv,
       CategoryComparison<Category::Integer>, CategoryComparison<Category::Real>,
       CategoryComparison<Category::Complex>,
@@ -427,17 +440,43 @@ extern template class Expr<Category::Complex, 16>;
 extern template class Expr<Category::Character, 1>;
 extern template class Expr<Category::Logical, 1>;
 
+// Holds a constant of any kind in an intrinsic type category.
+template<Category CAT> struct CategoryConstant {
+  CLASS_BOILERPLATE(CategoryConstant)
+  template<int KIND> using KindConstant = typename Expr<CAT, KIND>::Constant;
+  template<typename A> CategoryConstant(const A &x) : u{x} {}
+  template<typename A> CategoryConstant(std::enable_if_t<!std::is_reference_v<A>, A> &&x) : u{std::move(x)} {}
+  typename KindsVariant<CAT, KindConstant>::type u;
+};
+
+// Holds a constant of any intrinsic category and size.
+struct GenericConstant {
+  CLASS_BOILERPLATE(GenericConstant)
+  template<Category CAT, int KIND>
+  GenericConstant(const typename Expr<CAT, KIND>::Constant &x) : u{CategoryConstant<CAT>{x}} {}
+  template<Category CAT, int KIND>
+  GenericConstant(typename Expr<CAT, KIND>::Constant &&x) : u{CategoryConstant<CAT>{std::move(x)}} {}
+  template<typename A> GenericConstant(const A &x) : u{x} {}
+  template<typename A>
+  GenericConstant(std::enable_if_t<!std::is_reference_v<A>, A> &&x)
+    : u{std::move(x)} {}
+  std::variant<CategoryConstant<Category::Integer>, CategoryConstant<Category::Real>, CategoryConstant<Category::Complex>, CategoryConstant<Category::Character>, bool> u;
+};
+
 // Dynamically polymorphic expressions that can hold any supported kind
-// of a specific category.
+// of a specific intrinsic type category.
 template<Category CAT> struct CategoryExpr {
   CLASS_BOILERPLATE(CategoryExpr)
-  template<int KIND> CategoryExpr(const Expr<CAT, KIND> &x) : u{x} {}
-  template<int KIND> CategoryExpr(Expr<CAT, KIND> &&x) : u{std::move(x)} {}
-  template<int K> using KindExpr = Expr<CAT, K>;
+  template<int KIND> using KindExpr = Expr<CAT, KIND>;
+  template<int KIND> CategoryExpr(const KindExpr<KIND> &x) : u{x} {}
+  template<int KIND> CategoryExpr(KindExpr<KIND> &&x) : u{std::move(x)} {}
+  std::optional<CategoryConstant<CAT>> ConstantValue() const;
+  void Fold(FoldingContext &);
   typename KindsVariant<CAT, KindExpr>::type u;
 };
 
-// A completely generic expression, polymorphic across the type categories.
+// A completely generic expression, polymorphic across the intrinsic type
+// categories and each of their kinds.
 struct GenericExpr {
   CLASS_BOILERPLATE(GenericExpr)
   template<Category CAT, int KIND>
@@ -448,6 +487,9 @@ struct GenericExpr {
   template<typename A>
   GenericExpr(std::enable_if_t<!std::is_reference_v<A>, A> &&x)
     : u{std::move(x)} {}
+  std::optional<GenericConstant> ConstantValue() const;
+  void Fold(FoldingContext &);
+  int Rank() const { return 1; }  // TODO
   std::variant<GenericIntegerExpr, GenericRealExpr, GenericComplexExpr,
       GenericCharacterExpr, LogicalExpr>
       u;
diff --git a/flang/lib/evaluate/type.h b/flang/lib/evaluate/type.h
index f17b8918f786..809be00bd5f1 100644
--- a/flang/lib/evaluate/type.h
+++ b/flang/lib/evaluate/type.h
@@ -117,13 +117,24 @@ using DefaultCharacter = Type<Category::Character, 1>;
 
 using SubscriptInteger = Type<Category::Integer, 8>;
 
+// These macros invoke other macros on each of the supported kinds of
+// a given category.
+#define COMMA ,
+#define FOR_EACH_INTEGER_KIND(M,SEP) M(1) SEP M(2) SEP M(4) SEP M(8) SEP M(16)
+#define FOR_EACH_REAL_KIND(M,SEP) M(2) SEP M(4) SEP M(8) SEP M(10) SEP M(16)
+#define FOR_EACH_COMPLEX_KIND(M,SEP) FOR_EACH_REAL_KIND(M,SEP)
+#define FOR_EACH_CHARACTER_KIND(M,SEP) M(1)
+#define FOR_EACH_LOGICAL_KIND(M,SEP) M(1) SEP M(2) SEP M(4) SEP M(8)
+
 // These templates create instances of std::variant<> that can contain
 // applications of some class template to all of the supported kinds of
 // a category of intrinsic type.
+#define TKIND(K) T<K>
 template<Category CAT, template<int> class T> struct KindsVariant;
 template<template<int> class T> struct KindsVariant<Category::Integer, T> {
-  using type = std::variant<T<1>, T<2>, T<4>, T<8>, T<16>>;
+  using type = std::variant<FOR_EACH_INTEGER_KIND(TKIND,COMMA)>;
 };
+// TODO use FOR_EACH...
 template<template<int> class T> struct KindsVariant<Category::Real, T> {
   using type = std::variant<T<2>, T<4>, T<8>, T<10>, T<16>>;
 };
@@ -136,5 +147,6 @@ template<template<int> class T> struct KindsVariant<Category::Character, T> {
 template<template<int> class T> struct KindsVariant<Category::Logical, T> {
   using type = std::variant<T<1>, T<2>, T<4>, T<8>>;
 };
+#undef TKIND
 }  // namespace Fortran::evaluate
 #endif  // FORTRAN_EVALUATE_TYPE_H_
diff --git a/flang/lib/parser/message.h b/flang/lib/parser/message.h
index dcc1eacf36bd..1f0c5c3122b0 100644
--- a/flang/lib/parser/message.h
+++ b/flang/lib/parser/message.h
@@ -113,6 +113,8 @@ public:
 
   Message(ProvenanceRange pr, const MessageFixedText &t)
     : location_{pr}, text_{t} {}
+  Message(ProvenanceRange pr, const MessageFormattedText &s)
+    : location_{pr}, text_{std::move(s)} {}
   Message(ProvenanceRange pr, MessageFormattedText &&s)
     : location_{pr}, text_{std::move(s)} {}
   Message(ProvenanceRange pr, const MessageExpectedText &t)
@@ -120,6 +122,8 @@ public:
 
   Message(CharBlock csr, const MessageFixedText &t)
     : location_{csr}, text_{t} {}
+  Message(CharBlock csr, const MessageFormattedText &s)
+    : location_{csr}, text_{std::move(s)} {}
   Message(CharBlock csr, MessageFormattedText &&s)
     : location_{csr}, text_{std::move(s)} {}
   Message(CharBlock csr, const MessageExpectedText &t)
diff --git a/flang/lib/parser/parse-tree.h b/flang/lib/parser/parse-tree.h
index 4cf9d58d4299..a40972a1ec35 100644
--- a/flang/lib/parser/parse-tree.h
+++ b/flang/lib/parser/parse-tree.h
@@ -62,7 +62,7 @@ class Symbol;
 }  // namespace Fortran::semantics
 
 namespace Fortran::evaluate {
-class GenericExpr;
+struct GenericExpr;
 }  // namespace Fortran::evaluate
 
 // Most non-template classes in this file use these default definitions
diff --git a/flang/lib/semantics/expression.cc b/flang/lib/semantics/expression.cc
index 4f58a5e4be8a..297ec280c3ec 100644
--- a/flang/lib/semantics/expression.cc
+++ b/flang/lib/semantics/expression.cc
@@ -19,45 +19,112 @@ using namespace Fortran::parser::literals;
 
 namespace Fortran::semantics {
 
-std::optional<evaluate::GenericExpr> ExpressionAnalyzer::Analyze(
-    const parser::Expr &x) {
-  return std::visit(
-      common::visitors{
-          [&](const parser::LiteralConstant &c) { return Analyze(c); },
-          [&](const auto &) { return std::optional<evaluate::GenericExpr>{}; }},
-      x.u);
+template<typename A>
+std::optional<evaluate::GenericExpr> AnalyzeHelper(ExpressionAnalyzer &ea, const A &tree) {
+  return ea.Analyze(tree);
 }
 
-std::optional<evaluate::GenericExpr> ExpressionAnalyzer::Analyze(
-    const parser::IntLiteralConstant &x) {
-  std::uint64_t kind = defaultIntegerKind_;
-  const auto &kindParam{std::get<std::optional<parser::KindParam>>(x.t)};
-  if (kindParam.has_value()) {
-    std::visit(common::visitors{[&](std::uint64_t k) { kind = k; },
-                   [&](const auto &) {
-                     messages_.Say(at_, "unimp kind param"_err_en_US);
-                   }},
-        kindParam->u);
+template<typename A>
+std::optional<evaluate::GenericExpr> AnalyzeHelper(ExpressionAnalyzer &ea,
+  const parser::Scalar<A> &tree) {
+  std::optional<evaluate::GenericExpr> result{AnalyzeHelper(ea, tree.thing)};
+  if (result.has_value()) {
+    if (result->Rank() > 1) {
+      ea.Say("must be scalar"_err_en_US);
+      return {};
+    }
   }
+  return result;
+}
+
+template<typename A>
+std::optional<evaluate::GenericExpr> AnalyzeHelper(ExpressionAnalyzer &ea,
+  const parser::Constant<A> &tree) {
+  std::optional<evaluate::GenericExpr> result{AnalyzeHelper(ea, tree.thing)};
+  if (result.has_value()) {
+    result->Fold(ea.context());
+    if (!result->ConstantValue().has_value()) {
+      ea.Say("must be constant"_err_en_US);
+      return {};
+    }
+  }
+  return result;
+}
+
+template<typename A>
+std::optional<evaluate::GenericExpr> AnalyzeHelper(ExpressionAnalyzer &ea,
+  const parser::Integer<A> &tree) {
+  std::optional<evaluate::GenericExpr> result{AnalyzeHelper(ea, tree.thing)};
+  if (result.has_value() && !std::holds_alternative<evaluate::GenericIntegerExpr>(result->u)) {
+    ea.Say("must be integer"_err_en_US);
+    return {};
+  }
+  return result;
+}
+
+template<> std::optional<evaluate::GenericExpr> AnalyzeHelper(ExpressionAnalyzer &ea,
+  const parser::Name &n) {
+  // TODO
+  return {};
+}
+
+ExpressionAnalyzer::KindParam
+ExpressionAnalyzer::Analyze(const std::optional<parser::KindParam> &kindParam,
+                            KindParam defaultKind, KindParam kanjiKind) {
+  if (!kindParam.has_value()) {
+    return defaultKind;
+  }
+  return std::visit(common::visitors{[](std::uint64_t k) { return static_cast<KindParam>(k); },
+    [&](const parser::Scalar<parser::Integer<parser::Constant<parser::Name>>> &n) {
+      if (std::optional<evaluate::GenericExpr> oge{AnalyzeHelper(*this, n)}) {
+        if (std::optional<evaluate::GenericConstant> ogc{oge->ConstantValue()}) {
+          // TODO pmk more here next
+        }
+      }
+      return defaultKind;
+    },
+    [&](parser::KindParam::Kanji) {
+      if (kanjiKind >= 0) {
+        return kanjiKind;
+      }
+      Say("Kanji not allowed here"_err_en_US);
+      return defaultKind; }}, kindParam->u);
+}
+
+template<> std::optional<evaluate::GenericExpr> AnalyzeHelper(ExpressionAnalyzer &ea,
+    const parser::IntLiteralConstant &x) {
+  auto kind{ea.Analyze(std::get<std::optional<parser::KindParam>>(x.t),
+                       ea.defaultIntegerKind())};
   std::uint64_t value{std::get<std::uint64_t>(x.t)};
   switch (kind) {
-  case 4:
-    return {evaluate::GenericExpr{
-        evaluate::GenericIntegerExpr{evaluate::IntegerExpr<4>{value}}}};
+#define CASE(k) case k: return {evaluate::GenericExpr{evaluate::GenericIntegerExpr{evaluate::IntegerExpr<k>{value}}}};
+  FOR_EACH_INTEGER_KIND(CASE,)
+#undef CASE
   default:
-    messages_.Say(at_,
-        parser::MessageFormattedText{
+    ea.Say(parser::MessageFormattedText{
             "unimplemented INTEGER kind (%ju)"_err_en_US,
             static_cast<std::uintmax_t>(kind)});
     return {};
   }
 }
 
-std::optional<evaluate::GenericExpr> ExpressionAnalyzer::Analyze(
+template<> std::optional<evaluate::GenericExpr> AnalyzeHelper(ExpressionAnalyzer &ea,
     const parser::LiteralConstant &x) {
   return std::visit(
       common::visitors{
-          [&](const parser::IntLiteralConstant &c) { return Analyze(c); },
+          [&](const parser::IntLiteralConstant &c) { return AnalyzeHelper(ea, c); },
+          // TODO next [&](const parser::RealLiteralConstant &c) { return AnalyzeHelper(ea, c); },
+          // TODO: remaining cases
+          [&](const auto &) { return std::optional<evaluate::GenericExpr>{}; }},
+      x.u);
+}
+
+std::optional<evaluate::GenericExpr> ExpressionAnalyzer::Analyze(
+    const parser::Expr &x) {
+  return std::visit(
+      common::visitors{
+          [&](const parser::LiteralConstant &c) { return AnalyzeHelper(*this, c); },
+          // TODO: remaining cases
           [&](const auto &) { return std::optional<evaluate::GenericExpr>{}; }},
       x.u);
 }
diff --git a/flang/lib/semantics/expression.h b/flang/lib/semantics/expression.h
index 2cbd4feefd67..48c751987dd8 100644
--- a/flang/lib/semantics/expression.h
+++ b/flang/lib/semantics/expression.h
@@ -25,17 +25,28 @@ namespace Fortran::semantics {
 
 class ExpressionAnalyzer {
 public:
-  ExpressionAnalyzer(parser::Messages &m, std::uint64_t dIK)
-    : messages_{m}, defaultIntegerKind_{dIK} {}
+  using KindParam = std::int64_t;
+  ExpressionAnalyzer(evaluate::FoldingContext &c, KindParam dIK)
+    : context_{c}, defaultIntegerKind_{dIK} {}
+
+  evaluate::FoldingContext &context() { return context_; }
+  KindParam defaultIntegerKind() const { return defaultIntegerKind_; }
+
+  template<typename M>
+  void Say(const M &msg) {
+    if (context_.messages != nullptr) {
+      context_.messages->Say(context_.at, msg);
+    }
+  }
+
+  // Performs semantic checking on an expression.  If successful,
+  // returns its typed expression representation.
   std::optional<evaluate::GenericExpr> Analyze(const parser::Expr &);
-  std::optional<evaluate::GenericExpr> Analyze(
-      const parser::IntLiteralConstant &);
-  std::optional<evaluate::GenericExpr> Analyze(const parser::LiteralConstant &);
+  KindParam Analyze(const std::optional<parser::KindParam> &, KindParam defaultKind, KindParam kanjiKind = -1 /* not allowed here */);
 
 private:
-  parser::Messages &messages_;
-  const parser::CharBlock at_;
-  std::uint64_t defaultIntegerKind_{4};
+  evaluate::FoldingContext context_;
+  KindParam defaultIntegerKind_{4};
 };
 }  // namespace Fortran::semantics
 #endif  // FORTRAN_SEMANTICS_EXPRESSION_H_
diff --git a/flang/lib/semantics/type.h b/flang/lib/semantics/type.h
index e89fa37f6662..e50f5a2a225b 100644
--- a/flang/lib/semantics/type.h
+++ b/flang/lib/semantics/type.h
@@ -42,7 +42,7 @@ leaves are concrete types:
     DerivedTypeSpec
 
 TypeSpec classes are immutable. For intrinsic types (except character) there
-are a limited number of instances -- one for each kind.
+is a limited number of instances -- one for each kind.
 
 A DerivedTypeSpec is based on a DerivedTypeDef (from a derived type statement)
 with kind and len parameter values provided.