lib/Evaluate/type.cpp

//===-- lib/Evaluate/type.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/type.h"
#include "flang/Common/idioms.h"
#include "flang/Evaluate/expression.h"
#include "flang/Evaluate/fold.h"
#include "flang/Evaluate/target.h"
#include "flang/Parser/characters.h"
#include "flang/Semantics/scope.h"
#include "flang/Semantics/symbol.h"
#include "flang/Semantics/tools.h"
#include "flang/Semantics/type.h"
#include <algorithm>
#include <optional>
#include <string>

// IsDescriptor() predicate: true when a symbol is implemented
// at runtime with a descriptor.
namespace Fortran::semantics {

static bool IsDescriptor(const DeclTypeSpec *type) {
  if (type) {
    if (auto dynamicType{evaluate::DynamicType::From(*type)}) {
      return dynamicType->RequiresDescriptor();
    }
  }
  return false;
}

static bool IsDescriptor(const ObjectEntityDetails &details) {
  if (IsDescriptor(details.type()) || details.IsAssumedRank()) {
    return true;
  }
  for (const ShapeSpec &shapeSpec : details.shape()) {
    if (const auto &ub{shapeSpec.ubound().GetExplicit()}) {
      if (!IsConstantExpr(*ub)) {
        return true;
      }
    } else {
      return shapeSpec.ubound().isColon();
    }
  }
  return false;
}

bool IsDescriptor(const Symbol &symbol) {
  return common::visit(
      common::visitors{
          [&](const ObjectEntityDetails &d) {
            return IsAllocatableOrPointer(symbol) || IsDescriptor(d);
          },
          [&](const ProcEntityDetails &d) { return false; },
          [&](const EntityDetails &d) { return IsDescriptor(d.type()); },
          [](const AssocEntityDetails &d) {
            if (const auto &expr{d.expr()}) {
              if (expr->Rank() > 0) {
                return true;
              }
              if (const auto dynamicType{expr->GetType()}) {
                if (dynamicType->RequiresDescriptor()) {
                  return true;
                }
              }
            }
            return false;
          },
          [](const SubprogramDetails &d) {
            return d.isFunction() && IsDescriptor(d.result());
          },
          [](const UseDetails &d) { return IsDescriptor(d.symbol()); },
          [](const HostAssocDetails &d) { return IsDescriptor(d.symbol()); },
          [](const auto &) { return false; },
      },
      symbol.details());
}

bool IsPassedViaDescriptor(const Symbol &symbol) {
  if (!IsDescriptor(symbol)) {
    return false;
  }
  if (IsAllocatableOrPointer(symbol)) {
    return true;
  }
  if (semantics::IsAssumedSizeArray(symbol)) {
    return false;
  }
  if (const auto *object{
          symbol.GetUltimate().detailsIf<ObjectEntityDetails>()}) {
    if (object->isDummy()) {
      if (object->type() &&
          object->type()->category() == DeclTypeSpec::Character) {
        return false;
      }
      bool isExplicitShape{true};
      for (const ShapeSpec &shapeSpec : object->shape()) {
        if (!shapeSpec.lbound().GetExplicit() ||
            !shapeSpec.ubound().GetExplicit()) {
          isExplicitShape = false;
          break;
        }
      }
      if (isExplicitShape) {
        return false; // explicit shape but non-constant bounds
      }
    }
  }
  return true;
}
} // namespace Fortran::semantics

namespace Fortran::evaluate {

DynamicType::DynamicType(int k, const semantics::ParamValue &pv)
    : category_{TypeCategory::Character}, kind_{k} {
  CHECK(IsValidKindOfIntrinsicType(category_, kind_));
  if (auto n{ToInt64(pv.GetExplicit())}) {
    knownLength_ = *n > 0 ? *n : 0;
  } else {
    charLengthParamValue_ = &pv;
  }
}

template <typename A> inline bool PointeeComparison(const A *x, const A *y) {
  return x == y || (x && y && *x == *y);
}

bool DynamicType::operator==(const DynamicType &that) const {
  return category_ == that.category_ && kind_ == that.kind_ &&
      PointeeComparison(charLengthParamValue_, that.charLengthParamValue_) &&
      knownLength().has_value() == that.knownLength().has_value() &&
      (!knownLength() || *knownLength() == *that.knownLength()) &&
      PointeeComparison(derived_, that.derived_);
}

std::optional<Expr<SubscriptInteger>> DynamicType::GetCharLength() const {
  if (category_ == TypeCategory::Character) {
    if (knownLength()) {
      return AsExpr(Constant<SubscriptInteger>(*knownLength()));
    } else if (charLengthParamValue_) {
      if (auto length{charLengthParamValue_->GetExplicit()}) {
        return ConvertToType<SubscriptInteger>(std::move(*length));
      }
    }
  }
  return std::nullopt;
}

std::size_t DynamicType::GetAlignment(
    const TargetCharacteristics &targetCharacteristics) const {
  if (category_ == TypeCategory::Derived) {
    switch (GetDerivedTypeSpec().category()) {
      SWITCH_COVERS_ALL_CASES
    case semantics::DerivedTypeSpec::Category::DerivedType:
      if (derived_ && derived_->scope()) {
        return derived_->scope()->alignment().value_or(1);
      }
      break;
    case semantics::DerivedTypeSpec::Category::IntrinsicVector:
    case semantics::DerivedTypeSpec::Category::PairVector:
    case semantics::DerivedTypeSpec::Category::QuadVector:
      if (derived_ && derived_->scope()) {
        return derived_->scope()->size();
      } else {
        common::die("Missing scope for Vector type.");
      }
    }
  } else {
    return targetCharacteristics.GetAlignment(category_, kind());
  }
  return 1; // needs to be after switch to dodge a bogus gcc warning
}

std::optional<Expr<SubscriptInteger>> DynamicType::MeasureSizeInBytes(
    FoldingContext &context, bool aligned,
    std::optional<std::int64_t> charLength) const {
  switch (category_) {
  case TypeCategory::Integer:
  case TypeCategory::Real:
  case TypeCategory::Complex:
  case TypeCategory::Logical:
    return Expr<SubscriptInteger>{
        context.targetCharacteristics().GetByteSize(category_, kind())};
  case TypeCategory::Character:
    if (auto len{charLength ? Expr<SubscriptInteger>{Constant<SubscriptInteger>{
                                  *charLength}}
                            : GetCharLength()}) {
      return Fold(context,
          Expr<SubscriptInteger>{
              context.targetCharacteristics().GetByteSize(category_, kind())} *
              std::move(*len));
    }
    break;
  case TypeCategory::Derived:
    if (!IsPolymorphic() && derived_ && derived_->scope()) {
      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)};
    }
    break;
  }
  return std::nullopt;
}

bool DynamicType::IsAssumedLengthCharacter() const {
  return category_ == TypeCategory::Character && charLengthParamValue_ &&
      charLengthParamValue_->isAssumed();
}

bool DynamicType::IsNonConstantLengthCharacter() const {
  if (category_ != TypeCategory::Character) {
    return false;
  } else if (knownLength()) {
    return false;
  } else if (!charLengthParamValue_) {
    return true;
  } else if (const auto &expr{charLengthParamValue_->GetExplicit()}) {
    return !IsConstantExpr(*expr);
  } else {
    return true;
  }
}

bool DynamicType::IsTypelessIntrinsicArgument() const {
  return category_ == TypeCategory::Integer && kind_ == TypelessKind;
}

bool DynamicType::IsLengthlessIntrinsicType() const {
  return common::IsNumericTypeCategory(category_) ||
      category_ == TypeCategory::Logical;
}

const semantics::DerivedTypeSpec *GetDerivedTypeSpec(
    const std::optional<DynamicType> &type) {
  return type ? GetDerivedTypeSpec(*type) : nullptr;
}

const semantics::DerivedTypeSpec *GetDerivedTypeSpec(const DynamicType &type) {
  if (type.category() == TypeCategory::Derived &&
      !type.IsUnlimitedPolymorphic()) {
    return &type.GetDerivedTypeSpec();
  } else {
    return nullptr;
  }
}

static const semantics::Symbol *FindParentComponent(
    const semantics::DerivedTypeSpec &derived) {
  const semantics::Symbol &typeSymbol{derived.typeSymbol()};
  const semantics::Scope *scope{derived.scope()};
  if (!scope) {
    scope = typeSymbol.scope();
  }
  if (scope) {
    const auto &dtDetails{typeSymbol.get<semantics::DerivedTypeDetails>()};
    // TODO: Combine with semantics::DerivedTypeDetails::GetParentComponent
    if (auto extends{dtDetails.GetParentComponentName()}) {
      if (auto iter{scope->find(*extends)}; iter != scope->cend()) {
        if (const semantics::Symbol & symbol{*iter->second};
            symbol.test(semantics::Symbol::Flag::ParentComp)) {
          return &symbol;
        }
      }
    }
  }
  return nullptr;
}

const semantics::DerivedTypeSpec *GetParentTypeSpec(
    const semantics::DerivedTypeSpec &derived) {
  if (const semantics::Symbol * parent{FindParentComponent(derived)}) {
    return &parent->get<semantics::ObjectEntityDetails>()
                .type()
                ->derivedTypeSpec();
  } else {
    return nullptr;
  }
}

// Compares two derived type representations to see whether they both
// represent the "same type" in the sense of section F'2023 7.5.2.4.
using SetOfDerivedTypePairs =
    std::set<std::pair<const semantics::DerivedTypeSpec *,
        const semantics::DerivedTypeSpec *>>;

static bool AreSameDerivedType(const semantics::DerivedTypeSpec &,
    const semantics::DerivedTypeSpec &, bool ignoreTypeParameterValues,
    bool ignoreLenParameters, SetOfDerivedTypePairs &inProgress);

// F2023 7.5.3.2
static bool AreSameComponent(const semantics::Symbol &x,
    const semantics::Symbol &y, SetOfDerivedTypePairs &inProgress) {
  if (x.attrs() != y.attrs()) {
    return false;
  }
  if (x.attrs().test(semantics::Attr::PRIVATE)) {
    return false;
  }
  if (x.size() && y.size()) {
    if (x.offset() != y.offset() || x.size() != y.size()) {
      return false;
    }
  }
  const auto *xObj{x.detailsIf<semantics::ObjectEntityDetails>()};
  const auto *yObj{y.detailsIf<semantics::ObjectEntityDetails>()};
  const auto *xProc{x.detailsIf<semantics::ProcEntityDetails>()};
  const auto *yProc{y.detailsIf<semantics::ProcEntityDetails>()};
  if (!xObj != !yObj || !xProc != !yProc) {
    return false;
  }
  auto xType{DynamicType::From(x)};
  auto yType{DynamicType::From(y)};
  if (xType && yType) {
    if (xType->category() == TypeCategory::Derived) {
      if (yType->category() != TypeCategory::Derived ||
          !xType->IsUnlimitedPolymorphic() !=
              !yType->IsUnlimitedPolymorphic() ||
          (!xType->IsUnlimitedPolymorphic() &&
              !AreSameDerivedType(xType->GetDerivedTypeSpec(),
                  yType->GetDerivedTypeSpec(), false, false, inProgress))) {
        return false;
      }
    } else if (!xType->IsTkLenCompatibleWith(*yType)) {
      return false;
    }
  } else if (xType || yType || !(xProc && yProc)) {
    return false;
  }
  if (xProc) {
    // TODO: compare argument types, &c.
  }
  return true;
}

// TODO: These utilities were cloned out of Semantics to avoid a cyclic
// dependency and should be repackaged into then "namespace semantics"
// part of Evaluate/tools.cpp.

static const semantics::Symbol *GetParentComponent(
    const semantics::DerivedTypeDetails &details,
    const semantics::Scope &scope) {
  if (auto extends{details.GetParentComponentName()}) {
    if (auto iter{scope.find(*extends)}; iter != scope.cend()) {
      if (const Symbol & symbol{*iter->second};
          symbol.test(semantics::Symbol::Flag::ParentComp)) {
        return &symbol;
      }
    }
  }
  return nullptr;
}

static const semantics::Symbol *GetParentComponent(
    const semantics::Symbol *symbol, const semantics::Scope &scope) {
  if (symbol) {
    if (const auto *dtDetails{
            symbol->detailsIf<semantics::DerivedTypeDetails>()}) {
      return GetParentComponent(*dtDetails, scope);
    }
  }
  return nullptr;
}

static const semantics::DerivedTypeSpec *GetParentTypeSpec(
    const semantics::Symbol *symbol, const semantics::Scope &scope) {
  if (const Symbol * parentComponent{GetParentComponent(symbol, scope)}) {
    return &parentComponent->get<semantics::ObjectEntityDetails>()
                .type()
                ->derivedTypeSpec();
  } else {
    return nullptr;
  }
}

static const semantics::Scope *GetDerivedTypeParent(
    const semantics::Scope *scope) {
  if (scope) {
    CHECK(scope->IsDerivedType());
    if (const auto *parent{GetParentTypeSpec(scope->GetSymbol(), *scope)}) {
      return parent->scope();
    }
  }
  return nullptr;
}

static const semantics::Symbol *FindComponent(
    const semantics::Scope *scope, parser::CharBlock name) {
  if (!scope) {
    return nullptr;
  }
  CHECK(scope->IsDerivedType());
  auto found{scope->find(name)};
  if (found != scope->end()) {
    return &*found->second;
  } else {
    return FindComponent(GetDerivedTypeParent(scope), name);
  }
}

static bool AreTypeParamCompatible(const semantics::DerivedTypeSpec &x,
    const semantics::DerivedTypeSpec &y, bool ignoreLenParameters) {
  const auto *xScope{x.typeSymbol().scope()};
  const auto *yScope{y.typeSymbol().scope()};
  for (const auto &[paramName, value] : x.parameters()) {
    const auto *yValue{y.FindParameter(paramName)};
    if (!yValue) {
      return false;
    }
    const auto *xParm{FindComponent(xScope, paramName)};
    const auto *yParm{FindComponent(yScope, paramName)};
    if (xParm && yParm) {
      const auto *xTPD{xParm->detailsIf<semantics::TypeParamDetails>()};
      const auto *yTPD{yParm->detailsIf<semantics::TypeParamDetails>()};
      if (xTPD && yTPD) {
        if (xTPD->attr() != yTPD->attr()) {
          return false;
        }
        if (!ignoreLenParameters ||
            xTPD->attr() != common::TypeParamAttr::Len) {
          auto xExpr{value.GetExplicit()};
          auto yExpr{yValue->GetExplicit()};
          if (xExpr && yExpr) {
            auto xVal{ToInt64(*xExpr)};
            auto yVal{ToInt64(*yExpr)};
            if (xVal && yVal && *xVal != *yVal) {
              return false;
            }
          }
        }
      }
    }
  }
  for (const auto &[paramName, _] : y.parameters()) {
    if (!x.FindParameter(paramName)) {
      return false; // y has more parameters than x
    }
  }
  return true;
}

// F2023 7.5.3.2
static bool AreSameDerivedType(const semantics::DerivedTypeSpec &x,
    const semantics::DerivedTypeSpec &y, bool ignoreTypeParameterValues,
    bool ignoreLenParameters, SetOfDerivedTypePairs &inProgress) {
  if (&x == &y) {
    return true;
  }
  if (!ignoreTypeParameterValues &&
      !AreTypeParamCompatible(x, y, ignoreLenParameters)) {
    return false;
  }
  const auto &xSymbol{x.typeSymbol().GetUltimate()};
  const auto &ySymbol{y.typeSymbol().GetUltimate()};
  if (xSymbol == ySymbol) {
    return true;
  }
  if (xSymbol.name() != ySymbol.name()) {
    return false;
  }
  auto thisQuery{std::make_pair(&x, &y)};
  if (inProgress.find(thisQuery) != inProgress.end()) {
    return true; // recursive use of types in components
  }
  inProgress.insert(thisQuery);
  const auto &xDetails{xSymbol.get<semantics::DerivedTypeDetails>()};
  const auto &yDetails{ySymbol.get<semantics::DerivedTypeDetails>()};
  if (!(xDetails.sequence() && yDetails.sequence()) &&
      !(xSymbol.attrs().test(semantics::Attr::BIND_C) &&
          ySymbol.attrs().test(semantics::Attr::BIND_C))) {
    // PGI does not enforce this requirement; all other Fortran
    // compilers do with a hard error when violations are caught.
    return false;
  }
  // Compare the component lists in their orders of declaration.
  auto xEnd{xDetails.componentNames().cend()};
  auto yComponentName{yDetails.componentNames().cbegin()};
  auto yEnd{yDetails.componentNames().cend()};
  for (auto xComponentName{xDetails.componentNames().cbegin()};
       xComponentName != xEnd; ++xComponentName, ++yComponentName) {
    if (yComponentName == yEnd || *xComponentName != *yComponentName ||
        !xSymbol.scope() || !ySymbol.scope()) {
      return false;
    }
    const auto xLookup{xSymbol.scope()->find(*xComponentName)};
    const auto yLookup{ySymbol.scope()->find(*yComponentName)};
    if (xLookup == xSymbol.scope()->end() ||
        yLookup == ySymbol.scope()->end() ||
        !AreSameComponent(*xLookup->second, *yLookup->second, inProgress)) {
      return false;
    }
  }
  return yComponentName == yEnd;
}

bool AreSameDerivedType(
    const semantics::DerivedTypeSpec &x, const semantics::DerivedTypeSpec &y) {
  SetOfDerivedTypePairs inProgress;
  return AreSameDerivedType(x, y, false, false, inProgress);
}

bool AreSameDerivedTypeIgnoringTypeParameters(
    const semantics::DerivedTypeSpec &x, const semantics::DerivedTypeSpec &y) {
  SetOfDerivedTypePairs inProgress;
  return AreSameDerivedType(x, y, true, true, inProgress);
}

static bool AreSameDerivedType(
    const semantics::DerivedTypeSpec *x, const semantics::DerivedTypeSpec *y) {
  return x == y || (x && y && AreSameDerivedType(*x, *y));
}

bool DynamicType::IsEquivalentTo(const DynamicType &that) const {
  return category_ == that.category_ && kind_ == that.kind_ &&
      (charLengthParamValue_ == that.charLengthParamValue_ ||
          (charLengthParamValue_ && that.charLengthParamValue_ &&
              charLengthParamValue_->IsEquivalentInInterface(
                  *that.charLengthParamValue_))) &&
      knownLength().has_value() == that.knownLength().has_value() &&
      (!knownLength() || *knownLength() == *that.knownLength()) &&
      AreSameDerivedType(derived_, that.derived_);
}

static bool AreCompatibleDerivedTypes(const semantics::DerivedTypeSpec *x,
    const semantics::DerivedTypeSpec *y, bool isPolymorphic,
    bool ignoreTypeParameterValues, bool ignoreLenTypeParameters) {
  if (!x || !y) {
    return false;
  } else {
    SetOfDerivedTypePairs inProgress;
    if (AreSameDerivedType(*x, *y, ignoreTypeParameterValues,
            ignoreLenTypeParameters, inProgress)) {
      return true;
    } else {
      return isPolymorphic &&
          AreCompatibleDerivedTypes(x, GetParentTypeSpec(*y), true,
              ignoreTypeParameterValues, ignoreLenTypeParameters);
    }
  }
}

static bool AreCompatibleTypes(const DynamicType &x, const DynamicType &y,
    bool ignoreTypeParameterValues, bool ignoreLengths) {
  if (x.IsUnlimitedPolymorphic()) {
    return true;
  } else if (y.IsUnlimitedPolymorphic()) {
    return false;
  } else if (x.category() != y.category()) {
    return false;
  } else if (x.category() == TypeCategory::Character) {
    const auto xLen{x.knownLength()};
    const auto yLen{y.knownLength()};
    return x.kind() == y.kind() &&
        (ignoreLengths || !xLen || !yLen || *xLen == *yLen);
  } else if (x.category() != TypeCategory::Derived) {
    if (x.IsTypelessIntrinsicArgument()) {
      return y.IsTypelessIntrinsicArgument();
    } else {
      return !y.IsTypelessIntrinsicArgument() && x.kind() == y.kind();
    }
  } else {
    const auto *xdt{GetDerivedTypeSpec(x)};
    const auto *ydt{GetDerivedTypeSpec(y)};
    return AreCompatibleDerivedTypes(
        xdt, ydt, x.IsPolymorphic(), ignoreTypeParameterValues, false);
  }
}

// See 7.3.2.3 (5) & 15.5.2.4
bool DynamicType::IsTkCompatibleWith(const DynamicType &that) const {
  return AreCompatibleTypes(*this, that, false, true);
}

bool DynamicType::IsTkCompatibleWith(
    const DynamicType &that, common::IgnoreTKRSet ignoreTKR) const {
  if (ignoreTKR.test(common::IgnoreTKR::Type) &&
      (category() == TypeCategory::Derived ||
          that.category() == TypeCategory::Derived ||
          category() != that.category())) {
    return true;
  } else if (ignoreTKR.test(common::IgnoreTKR::Kind) &&
      category() == that.category()) {
    return true;
  } else {
    return AreCompatibleTypes(*this, that, false, true);
  }
}

bool DynamicType::IsTkLenCompatibleWith(const DynamicType &that) const {
  return AreCompatibleTypes(*this, that, false, false);
}

// 16.9.165
std::optional<bool> DynamicType::SameTypeAs(const DynamicType &that) const {
  bool x{AreCompatibleTypes(*this, that, true, true)};
  bool y{AreCompatibleTypes(that, *this, true, true)};
  if (!x && !y) {
    return false;
  } else if (x && y && !IsPolymorphic() && !that.IsPolymorphic()) {
    return true;
  } else {
    return std::nullopt;
  }
}

// 16.9.76
std::optional<bool> DynamicType::ExtendsTypeOf(const DynamicType &that) const {
  if (IsUnlimitedPolymorphic() || that.IsUnlimitedPolymorphic()) {
    return std::nullopt; // unknown
  }
  const auto *thisDts{evaluate::GetDerivedTypeSpec(*this)};
  const auto *thatDts{evaluate::GetDerivedTypeSpec(that)};
  if (!thisDts || !thatDts) {
    return std::nullopt;
  } else if (!AreCompatibleDerivedTypes(thatDts, thisDts, true, true, true)) {
    // Note that I check *thisDts, not its parent, so that EXTENDS_TYPE_OF()
    // is .true. when they are the same type.  This is technically
    // an implementation-defined case in the standard, but every other
    // compiler works this way.
    if (IsPolymorphic() &&
        AreCompatibleDerivedTypes(thisDts, thatDts, true, true, true)) {
      // 'that' is *this or an extension of *this, and so runtime *this
      // could be an extension of 'that'
      return std::nullopt;
    } else {
      return false;
    }
  } else if (that.IsPolymorphic()) {
    return std::nullopt; // unknown
  } else {
    return true;
  }
}

std::optional<DynamicType> DynamicType::From(
    const semantics::DeclTypeSpec &type) {
  if (const auto *intrinsic{type.AsIntrinsic()}) {
    if (auto kind{ToInt64(intrinsic->kind())}) {
      TypeCategory category{intrinsic->category()};
      if (IsValidKindOfIntrinsicType(category, *kind)) {
        if (category == TypeCategory::Character) {
          const auto &charType{type.characterTypeSpec()};
          return DynamicType{static_cast<int>(*kind), charType.length()};
        } else {
          return DynamicType{category, static_cast<int>(*kind)};
        }
      }
    }
  } else if (const auto *derived{type.AsDerived()}) {
    return DynamicType{
        *derived, type.category() == semantics::DeclTypeSpec::ClassDerived};
  } else if (type.category() == semantics::DeclTypeSpec::ClassStar) {
    return DynamicType::UnlimitedPolymorphic();
  } else if (type.category() == semantics::DeclTypeSpec::TypeStar) {
    return DynamicType::AssumedType();
  } else {
    common::die("DynamicType::From(DeclTypeSpec): failed");
  }
  return std::nullopt;
}

std::optional<DynamicType> DynamicType::From(const semantics::Symbol &symbol) {
  return From(symbol.GetType()); // Symbol -> DeclTypeSpec -> DynamicType
}

DynamicType DynamicType::ResultTypeForMultiply(const DynamicType &that) const {
  switch (category_) {
  case TypeCategory::Integer:
    switch (that.category_) {
    case TypeCategory::Integer:
      return DynamicType{TypeCategory::Integer, std::max(kind(), that.kind())};
    case TypeCategory::Real:
    case TypeCategory::Complex:
      return that;
    default:
      CRASH_NO_CASE;
    }
    break;
  case TypeCategory::Real:
    switch (that.category_) {
    case TypeCategory::Integer:
      return *this;
    case TypeCategory::Real:
      return DynamicType{TypeCategory::Real, std::max(kind(), that.kind())};
    case TypeCategory::Complex:
      return DynamicType{TypeCategory::Complex, std::max(kind(), that.kind())};
    default:
      CRASH_NO_CASE;
    }
    break;
  case TypeCategory::Complex:
    switch (that.category_) {
    case TypeCategory::Integer:
      return *this;
    case TypeCategory::Real:
    case TypeCategory::Complex:
      return DynamicType{TypeCategory::Complex, std::max(kind(), that.kind())};
    default:
      CRASH_NO_CASE;
    }
    break;
  case TypeCategory::Logical:
    switch (that.category_) {
    case TypeCategory::Logical:
      return DynamicType{TypeCategory::Logical, std::max(kind(), that.kind())};
    default:
      CRASH_NO_CASE;
    }
    break;
  default:
    CRASH_NO_CASE;
  }
  return *this;
}

bool DynamicType::RequiresDescriptor() const {
  return IsPolymorphic() || IsNonConstantLengthCharacter() ||
      (derived_ && CountNonConstantLenParameters(*derived_) > 0);
}

bool DynamicType::HasDeferredTypeParameter() const {
  if (derived_) {
    for (const auto &pair : derived_->parameters()) {
      if (pair.second.isDeferred()) {
        return true;
      }
    }
  }
  return charLengthParamValue_ && charLengthParamValue_->isDeferred();
}

bool SomeKind<TypeCategory::Derived>::operator==(
    const SomeKind<TypeCategory::Derived> &that) const {
  return PointeeComparison(derivedTypeSpec_, that.derivedTypeSpec_);
}

int SelectedCharKind(const std::string &s, int defaultKind) { // F'2023 16.9.180
  auto lower{parser::ToLowerCaseLetters(s)};
  auto n{lower.size()};
  while (n > 0 && lower[0] == ' ') {
    lower.erase(0, 1);
    --n;
  }
  while (n > 0 && lower[n - 1] == ' ') {
    lower.erase(--n, 1);
  }
  if (lower == "ascii") {
    return 1;
  } else if (lower == "ucs-2") {
    return 2;
  } else if (lower == "iso_10646" || lower == "ucs-4") {
    return 4;
  } else if (lower == "default") {
    return defaultKind;
  } else {
    return -1;
  }
}

std::optional<DynamicType> ComparisonType(
    const DynamicType &t1, const DynamicType &t2) {
  switch (t1.category()) {
  case TypeCategory::Integer:
    switch (t2.category()) {
    case TypeCategory::Integer:
      return DynamicType{TypeCategory::Integer, std::max(t1.kind(), t2.kind())};
    case TypeCategory::Real:
    case TypeCategory::Complex:
      return t2;
    default:
      return std::nullopt;
    }
  case TypeCategory::Real:
    switch (t2.category()) {
    case TypeCategory::Integer:
      return t1;
    case TypeCategory::Real:
    case TypeCategory::Complex:
      return DynamicType{t2.category(), std::max(t1.kind(), t2.kind())};
    default:
      return std::nullopt;
    }
  case TypeCategory::Complex:
    switch (t2.category()) {
    case TypeCategory::Integer:
      return t1;
    case TypeCategory::Real:
    case TypeCategory::Complex:
      return DynamicType{TypeCategory::Complex, std::max(t1.kind(), t2.kind())};
    default:
      return std::nullopt;
    }
  case TypeCategory::Character:
    switch (t2.category()) {
    case TypeCategory::Character:
      return DynamicType{
          TypeCategory::Character, std::max(t1.kind(), t2.kind())};
    default:
      return std::nullopt;
    }
  case TypeCategory::Logical:
    switch (t2.category()) {
    case TypeCategory::Logical:
      return DynamicType{TypeCategory::Logical, LogicalResult::kind};
    default:
      return std::nullopt;
    }
  default:
    return std::nullopt;
  }
}

std::optional<bool> IsInteroperableIntrinsicType(const DynamicType &type,
    const common::LanguageFeatureControl *features, bool checkCharLength) {
  switch (type.category()) {
  case TypeCategory::Integer:
    return true;
  case TypeCategory::Real:
  case TypeCategory::Complex:
    return type.kind() >= 4 /* not a short or half float */ || !features ||
        features->IsEnabled(common::LanguageFeature::CUDA);
  case TypeCategory::Logical:
    return type.kind() == 1; // C_BOOL
  case TypeCategory::Character:
    if (type.kind() != 1) { // C_CHAR
      return false;
    } else if (checkCharLength) {
      if (type.knownLength()) {
        return *type.knownLength() == 1;
      } else {
        return std::nullopt;
      }
    } else {
      return true;
    }
  default:
    // Derived types are tested in Semantics/check-declarations.cpp
    return false;
  }
}

bool IsCUDAIntrinsicType(const DynamicType &type) {
  switch (type.category()) {
  case TypeCategory::Integer:
  case TypeCategory::Logical:
    return type.kind() <= 8;
  case TypeCategory::Real:
    return type.kind() >= 2 && type.kind() <= 8;
  case TypeCategory::Complex:
    return type.kind() == 2 || type.kind() == 4 || type.kind() == 8;
  case TypeCategory::Character:
    return type.kind() == 1;
  default:
    // Derived types are tested in Semantics/check-declarations.cpp
    return false;
  }
}

DynamicType DynamicType::DropNonConstantCharacterLength() const {
  if (charLengthParamValue_ && charLengthParamValue_->isExplicit()) {
    if (std::optional<std::int64_t> len{knownLength()}) {
      return DynamicType(kind_, *len);
    } else {
      return DynamicType(category_, kind_);
    }
  }
  return *this;
}

} // namespace Fortran::evaluate