[flang] intrinsic pattern matching

Original-commit: flang-compiler/f18@ca0ee1660a
Reviewed-on: https://github.com/flang-compiler/f18/pull/212
Tree-same-pre-rewrite: false

flang/lib/common/bit-population-count.h

@@ -81,5 +81,9 @@ template<typename UINT> inline constexpr bool Parity(UINT x) {
 }
 
 // "Parity is for farmers." -- Seymour R. Cray
+
+template<typename UINT> inline constexpr int TrailingZeroCount(UINT x) {
+  return BitPopulationCount(x ^ (x - 1)) - !x;
 }
+}  // namespace Fortran::common
 #endif  // FORTRAN_COMMON_BIT_POPULATION_COUNT_H_

flang/lib/common/constexpr-bitset.h

@@ -22,6 +22,7 @@
 #include <cstddef>
 #include <cstdint>
 #include <initializer_list>
+#include <optional>
 #include <type_traits>
 
 namespace Fortran::common {
@@ -86,18 +87,14 @@ public:
   }
   constexpr BitSet operator|(BitSet &&that) const { return bits_ | that.bits_; }
 
-  constexpr BitSet operator==(const BitSet &that) const {
+  constexpr bool operator==(const BitSet &that) const {
     return bits_ == that.bits_;
   }
-  constexpr BitSet operator==(BitSet &&that) const {
-    return bits_ == that.bits_;
-  }
-  constexpr BitSet operator!=(const BitSet &that) const {
-    return bits_ == that.bits_;
-  }
-  constexpr BitSet operator!=(BitSet &&that) const {
+  constexpr bool operator==(BitSet &&that) const { return bits_ == that.bits_; }
+  constexpr bool operator!=(const BitSet &that) const {
     return bits_ == that.bits_;
   }
+  constexpr bool operator!=(BitSet &&that) const { return bits_ == that.bits_; }
 
   static constexpr std::size_t size() { return BITS; }
   constexpr bool test(std::size_t x) const {
@@ -139,6 +136,14 @@ public:
     return *this;
   }
 
+  constexpr std::optional<std::size_t> LeastElement() const {
+    if (bits_ == 0) {
+      return std::nullopt;
+    } else {
+      return {TrailingZeroCount(bits_)};
+    }
+  }
+
 private:
   Word bits_{0};
 };

flang/lib/common/enum-set.h

@@ -21,9 +21,11 @@
 // class" feature without loss of convenience.
 
 #include "constexpr-bitset.h"
+#include "idioms.h"
 #include <bitset>
 #include <cstddef>
 #include <initializer_list>
+#include <optional>
 #include <type_traits>
 
 namespace Fortran::common {
@@ -113,16 +115,16 @@ public:
     return result;
   }
 
-  constexpr EnumSet operator==(const EnumSet &that) const {
+  constexpr bool operator==(const EnumSet &that) const {
     return bitset_ == that.bitset_;
   }
-  constexpr EnumSet operator==(EnumSet &&that) const {
+  constexpr bool operator==(EnumSet &&that) const {
     return bitset_ == that.bitset_;
   }
-  constexpr EnumSet operator!=(const EnumSet &that) const {
+  constexpr bool operator!=(const EnumSet &that) const {
     return bitset_ != that.bitset_;
   }
-  constexpr EnumSet operator!=(EnumSet &&that) const {
+  constexpr bool operator!=(EnumSet &&that) const {
     return bitset_ != that.bitset_;
   }
 
@@ -176,6 +178,23 @@ public:
   void erase(enumerationType x) { reset(x); }
   void erase(enumerationType &&x) { reset(x); }
 
+  constexpr std::optional<enumerationType> LeastElement() const {
+    if (empty()) {
+      return std::nullopt;
+    } else if constexpr (std::is_same_v<bitsetType, common::BitSet<BITS>>) {
+      return {static_cast<enumerationType>(*bitset_.LeastElement())};
+    } else {
+      // std::bitset: just iterate
+      for (std::size_t j{0}; j < BITS; ++j) {
+        auto enumerator{static_cast<enumerationType>(j)};
+        if (bitset_.test(enumerator)) {
+          return {enumerator};
+        }
+      }
+      die("EnumSet::LeastElement(): no bit found in non-empty std::bitset");
+    }
+  }
+
 private:
   bitsetType bitset_;
 };

flang/lib/evaluate/intrinsics.h

@@ -19,6 +19,7 @@
 #include "../common/idioms.h"
 #include "../parser/char-block.h"
 #include <memory>
+#include <optional>
 #include <vector>
 
 namespace Fortran::semantics {
@@ -30,11 +31,15 @@ namespace Fortran::evaluate {
 // Placeholder
 ENUM_CLASS(IntrinsicProcedure, IAND, IEOR, IOR, LEN, MAX, MIN)
 
-// Characterize actual arguments
+// Characterize an actual argument to an intrinsic procedure reference
 struct ActualArgumentCharacteristics {
-  parser::CharBlock keyword;
+  std::optional<parser::CharBlock> keyword;
+  bool isBOZ{false};
+  bool isAssumedRank{false};
   DynamicType type;
   int rank;
+  std::optional<int> vectorSize;
+  std::optional<int> intValue;
 };
 
 struct CallCharacteristics {
@@ -44,10 +49,13 @@ struct CallCharacteristics {
 };
 
 struct SpecificIntrinsic {
-  const char *name;
-  bool isElemental;
+  explicit SpecificIntrinsic(const char *n) : name{n} {}
+  SpecificIntrinsic(const char *n, bool isElem, DynamicType dt, int r)
+    : name{n}, isElemental{isElem}, type{dt}, rank{r} {}
+  const char *name;  // not owned
+  bool isElemental{false};
   DynamicType type;
-  int rank;
+  int rank{0};
 };
 
 class IntrinsicTable {
@@ -57,7 +65,7 @@ private:
 public:
   ~IntrinsicTable();
   static IntrinsicTable Configure(const semantics::IntrinsicTypeDefaultKinds &);
-  const SpecificIntrinsic *Probe(const CallCharacteristics &);
+  std::optional<SpecificIntrinsic> Probe(const CallCharacteristics &);
 
 private:
   Implementation *impl_{nullptr};

flang/lib/evaluate/type.h

@@ -44,6 +44,14 @@ namespace Fortran::evaluate {
 using common::TypeCategory;
 
 struct DynamicType {
+  bool operator==(const DynamicType &that) const {
+    return category == that.category && kind == that.kind &&
+        derived == that.derived;
+  }
+  std::string Dump() const {
+    return EnumToString(category) + '(' + std::to_string(kind) + ')';
+  }
+
   TypeCategory category;
   int kind{0};
   const semantics::DerivedTypeSpec *derived{nullptr};
@@ -58,9 +66,7 @@ template<TypeCategory CATEGORY, int KIND> struct TypeBase {
   static constexpr DynamicType dynamicType{CATEGORY, KIND};
   static constexpr TypeCategory category{CATEGORY};
   static constexpr int kind{KIND};
-  static std::string Dump() {
-    return EnumToString(category) + '(' + std::to_string(kind) + ')';
-  }
+  static std::string Dump() { return dynamicType.Dump(); }
 };
 
 template<int KIND>

flang/lib/parser/char-block.h

@@ -74,6 +74,13 @@ public:
   bool operator>=(const CharBlock &that) const { return Compare(that) >= 0; }
   bool operator>(const CharBlock &that) const { return Compare(that) > 0; }
 
+  bool operator<(const char *that) const { return Compare(that) < 0; }
+  bool operator<=(const char *that) const { return Compare(that) <= 0; }
+  bool operator==(const char *that) const { return Compare(that) == 0; }
+  bool operator!=(const char *that) const { return Compare(that) != 0; }
+  bool operator>=(const char *that) const { return Compare(that) >= 0; }
+  bool operator>(const char *that) const { return Compare(that) > 0; }
+
 private:
   int Compare(const CharBlock &that) const {
     std::size_t bytes{std::min(size(), that.size())};
@@ -85,6 +92,14 @@ private:
     return size() < that.size() ? -1 : size() > that.size();
   }
 
+  int Compare(const char *that) const {
+    std::size_t bytes{size()};
+    if (int cmp{std::strncmp(begin(), that, bytes)}) {
+      return cmp;
+    }
+    return that[bytes] == '\0' ? 0 : -1;
+  }
+
   common::Interval<const char *> interval_{nullptr, 0};
 };
 

flang/lib/semantics/expression.cc

@@ -1215,6 +1215,17 @@ void ExprAnalyzer::CheckUnsubscriptedComponent(const Component &component) {
 
 namespace Fortran::semantics {
 
+int IntrinsicTypeDefaultKinds::DefaultKind(TypeCategory category) const {
+  switch (category) {
+  case TypeCategory::Integer: return defaultIntegerKind;
+  case TypeCategory::Real:
+  case TypeCategory::Complex: return defaultRealKind;
+  case TypeCategory::Character: return defaultCharacterKind;
+  case TypeCategory::Logical: return defaultLogicalKind;
+  default: CRASH_NO_CASE; return 0;
+  }
+}
+
 evaluate::MaybeExpr AnalyzeExpr(evaluate::FoldingContext &context,
     const IntrinsicTypeDefaultKinds &defaults, const parser::Expr &expr) {
   return evaluate::ExprAnalyzer{context, defaults}.Analyze(expr);

flang/lib/semantics/expression.h

@@ -31,6 +31,7 @@ struct IntrinsicTypeDefaultKinds {
   int defaultQuadPrecisionKind{evaluate::DefaultDoublePrecision::kind};
   int defaultCharacterKind{evaluate::DefaultCharacter::kind};
   int defaultLogicalKind{evaluate::DefaultLogical::kind};
+  int DefaultKind(TypeCategory) const;
 };
 
 // Semantic analysis of one expression.