llvm-project/flang/lib/Evaluate/variable.cpp

//===-- lib/Evaluate/variable.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/variable.h"
#include "flang/Common/idioms.h"
#include "flang/Evaluate/check-expression.h"
#include "flang/Evaluate/fold.h"
#include "flang/Evaluate/tools.h"
#include "flang/Parser/char-block.h"
#include "flang/Parser/characters.h"
#include "flang/Parser/message.h"
#include "flang/Semantics/scope.h"
#include "flang/Semantics/symbol.h"
#include <type_traits>

using namespace Fortran::parser::literals;

namespace Fortran::evaluate {

// Constructors, accessors, mutators

Triplet::Triplet() : stride_{Expr<SubscriptInteger>{1}} {}

Triplet::Triplet(std::optional<Expr<SubscriptInteger>> &&l,
    std::optional<Expr<SubscriptInteger>> &&u,
    std::optional<Expr<SubscriptInteger>> &&s)
    : stride_{s ? std::move(*s) : Expr<SubscriptInteger>{1}} {
  if (l) {
    lower_.emplace(std::move(*l));
  }
  if (u) {
    upper_.emplace(std::move(*u));
  }
}

std::optional<Expr<SubscriptInteger>> Triplet::lower() const {
  if (lower_) {
    return {lower_.value().value()};
  }
  return std::nullopt;
}

Triplet &Triplet::set_lower(Expr<SubscriptInteger> &&expr) {
  lower_.emplace(std::move(expr));
  return *this;
}

std::optional<Expr<SubscriptInteger>> Triplet::upper() const {
  if (upper_) {
    return {upper_.value().value()};
  }
  return std::nullopt;
}

Triplet &Triplet::set_upper(Expr<SubscriptInteger> &&expr) {
  upper_.emplace(std::move(expr));
  return *this;
}

Expr<SubscriptInteger> Triplet::stride() const { return stride_.value(); }

Triplet &Triplet::set_stride(Expr<SubscriptInteger> &&expr) {
  stride_.value() = std::move(expr);
  return *this;
}

bool Triplet::IsStrideOne() const {
  if (auto stride{ToInt64(stride_.value())}) {
    return stride == 1;
  } else {
    return false;
  }
}

CoarrayRef::CoarrayRef(SymbolVector &&base, std::vector<Subscript> &&ss,
    std::vector<Expr<SubscriptInteger>> &&css)
    : base_{std::move(base)}, subscript_(std::move(ss)),
      cosubscript_(std::move(css)) {
  CHECK(!base_.empty());
  CHECK(!cosubscript_.empty());
}

std::optional<Expr<SomeInteger>> CoarrayRef::stat() const {
  if (stat_) {
    return stat_.value().value();
  } else {
    return std::nullopt;
  }
}

std::optional<Expr<SomeInteger>> CoarrayRef::team() const {
  if (team_) {
    return team_.value().value();
  } else {
    return std::nullopt;
  }
}

CoarrayRef &CoarrayRef::set_stat(Expr<SomeInteger> &&v) {
  CHECK(IsVariable(v));
  stat_.emplace(std::move(v));
  return *this;
}

CoarrayRef &CoarrayRef::set_team(Expr<SomeInteger> &&v, bool isTeamNumber) {
  CHECK(IsVariable(v));
  team_.emplace(std::move(v));
  teamIsTeamNumber_ = isTeamNumber;
  return *this;
}

const Symbol &CoarrayRef::GetFirstSymbol() const { return base_.front(); }

const Symbol &CoarrayRef::GetLastSymbol() const { return base_.back(); }

void Substring::SetBounds(std::optional<Expr<SubscriptInteger>> &lower,
    std::optional<Expr<SubscriptInteger>> &upper) {
  if (lower) {
    set_lower(std::move(lower.value()));
  }
  if (upper) {
    set_upper(std::move(upper.value()));
  }
}

Expr<SubscriptInteger> Substring::lower() const {
  if (lower_) {
    return lower_.value().value();
  } else {
    return AsExpr(Constant<SubscriptInteger>{1});
  }
}

Substring &Substring::set_lower(Expr<SubscriptInteger> &&expr) {
  lower_.emplace(std::move(expr));
  return *this;
}

std::optional<Expr<SubscriptInteger>> Substring::upper() const {
  if (upper_) {
    return upper_.value().value();
  } else {
    return std::visit(
        common::visitors{
            [](const DataRef &dataRef) { return dataRef.LEN(); },
            [](const StaticDataObject::Pointer &object)
                -> std::optional<Expr<SubscriptInteger>> {
              return AsExpr(Constant<SubscriptInteger>{object->data().size()});
            },
        },
        parent_);
  }
}

Substring &Substring::set_upper(Expr<SubscriptInteger> &&expr) {
  upper_.emplace(std::move(expr));
  return *this;
}

std::optional<Expr<SomeCharacter>> Substring::Fold(FoldingContext &context) {
  if (!lower_) {
    lower_ = AsExpr(Constant<SubscriptInteger>{1});
  }
  lower_.value() = evaluate::Fold(context, std::move(lower_.value().value()));
  std::optional<ConstantSubscript> lbi{ToInt64(lower_.value().value())};
  if (lbi && *lbi < 1) {
    context.messages().Say(
        "Lower bound (%jd) on substring is less than one"_en_US, *lbi);
    *lbi = 1;
    lower_ = AsExpr(Constant<SubscriptInteger>{1});
  }
  if (!upper_) {
    upper_ = upper();
    if (!upper_) {
      return std::nullopt;
    }
  }
  upper_.value() = evaluate::Fold(context, std::move(upper_.value().value()));
  if (std::optional<ConstantSubscript> ubi{ToInt64(upper_.value().value())}) {
    auto *literal{std::get_if<StaticDataObject::Pointer>(&parent_)};
    std::optional<ConstantSubscript> length;
    if (literal) {
      length = (*literal)->data().size();
    } else if (const Symbol * symbol{GetLastSymbol()}) {
      if (const semantics::DeclTypeSpec * type{symbol->GetType()}) {
        if (type->category() == semantics::DeclTypeSpec::Character) {
          length = ToInt64(type->characterTypeSpec().length().GetExplicit());
        }
      }
    }
    if (*ubi < 1 || (lbi && *ubi < *lbi)) {
      // Zero-length string: canonicalize
      *lbi = 1, *ubi = 0;
      lower_ = AsExpr(Constant<SubscriptInteger>{*lbi});
      upper_ = AsExpr(Constant<SubscriptInteger>{*ubi});
    } else if (length && *ubi > *length) {
      context.messages().Say("Upper bound (%jd) on substring is greater "
                             "than character length (%jd)"_en_US,
          *ubi, *length);
      *ubi = *length;
    }
    if (lbi && literal) {
      auto newStaticData{StaticDataObject::Create()};
      auto items{0}; // If the lower bound is greater, the length is 0
      if (*ubi >= *lbi) {
        items = *ubi - *lbi + 1;
      }
      auto width{(*literal)->itemBytes()};
      auto bytes{items * width};
      auto startByte{(*lbi - 1) * width};
      const auto *from{&(*literal)->data()[0] + startByte};
      for (auto j{0}; j < bytes; ++j) {
        newStaticData->data().push_back(from[j]);
      }
      parent_ = newStaticData;
      lower_ = AsExpr(Constant<SubscriptInteger>{1});
      ConstantSubscript length = newStaticData->data().size();
      upper_ = AsExpr(Constant<SubscriptInteger>{length});
      switch (width) {
      case 1:
        return {
            AsCategoryExpr(AsExpr(Constant<Type<TypeCategory::Character, 1>>{
                *newStaticData->AsString()}))};
      case 2:
        return {AsCategoryExpr(Constant<Type<TypeCategory::Character, 2>>{
            *newStaticData->AsU16String()})};
      case 4:
        return {AsCategoryExpr(Constant<Type<TypeCategory::Character, 4>>{
            *newStaticData->AsU32String()})};
      default:
        CRASH_NO_CASE;
      }
    }
  }
  return std::nullopt;
}

DescriptorInquiry::DescriptorInquiry(
    const NamedEntity &base, Field field, int dim)
    : base_{base}, field_{field}, dimension_{dim} {
  const Symbol &last{base_.GetLastSymbol()};
  CHECK(IsDescriptor(last));
  CHECK(((field == Field::Len || field == Field::Rank) && dim == 0) ||
      (field != Field::Len && dim >= 0 && dim < last.Rank()));
}

DescriptorInquiry::DescriptorInquiry(NamedEntity &&base, Field field, int dim)
    : base_{std::move(base)}, field_{field}, dimension_{dim} {
  const Symbol &last{base_.GetLastSymbol()};
  CHECK(IsDescriptor(last));
  CHECK((field == Field::Len && dim == 0) ||
      (field != Field::Len && dim >= 0 && dim < last.Rank()));
}

// LEN()
static std::optional<Expr<SubscriptInteger>> SymbolLEN(const Symbol &symbol) {
  const Symbol &ultimate{symbol.GetUltimate()};
  if (const auto *assoc{ultimate.detailsIf<semantics::AssocEntityDetails>()}) {
    if (const auto *chExpr{UnwrapExpr<Expr<SomeCharacter>>(assoc->expr())}) {
      return chExpr->LEN();
    }
  }
  if (auto dyType{DynamicType::From(ultimate)}) {
    if (auto len{dyType->GetCharLength()}) {
      if (ultimate.owner().IsDerivedType() || IsScopeInvariantExpr(*len)) {
        return AsExpr(Extremum<SubscriptInteger>{
            Ordering::Greater, Expr<SubscriptInteger>{0}, std::move(*len)});
      }
    }
  }
  if (IsDescriptor(ultimate) && !ultimate.owner().IsDerivedType()) {
    return Expr<SubscriptInteger>{
        DescriptorInquiry{NamedEntity{symbol}, DescriptorInquiry::Field::Len}};
  }
  return std::nullopt;
}

std::optional<Expr<SubscriptInteger>> BaseObject::LEN() const {
  return std::visit(
      common::visitors{
          [](const Symbol &symbol) { return SymbolLEN(symbol); },
          [](const StaticDataObject::Pointer &object)
              -> std::optional<Expr<SubscriptInteger>> {
            return AsExpr(Constant<SubscriptInteger>{object->data().size()});
          },
      },
      u);
}

std::optional<Expr<SubscriptInteger>> Component::LEN() const {
  return SymbolLEN(GetLastSymbol());
}

std::optional<Expr<SubscriptInteger>> NamedEntity::LEN() const {
  return SymbolLEN(GetLastSymbol());
}

std::optional<Expr<SubscriptInteger>> ArrayRef::LEN() const {
  return base_.LEN();
}

std::optional<Expr<SubscriptInteger>> CoarrayRef::LEN() const {
  return SymbolLEN(GetLastSymbol());
}

std::optional<Expr<SubscriptInteger>> DataRef::LEN() const {
  return std::visit(common::visitors{
                        [](SymbolRef symbol) { return SymbolLEN(symbol); },
                        [](const auto &x) { return x.LEN(); },
                    },
      u);
}

std::optional<Expr<SubscriptInteger>> Substring::LEN() const {
  if (auto top{upper()}) {
    return AsExpr(Extremum<SubscriptInteger>{Ordering::Greater,
        AsExpr(Constant<SubscriptInteger>{0}),
        *std::move(top) - lower() + AsExpr(Constant<SubscriptInteger>{1})});
  } else {
    return std::nullopt;
  }
}

template <typename T>
std::optional<Expr<SubscriptInteger>> Designator<T>::LEN() const {
  if constexpr (T::category == TypeCategory::Character) {
    return std::visit(common::visitors{
                          [](SymbolRef symbol) { return SymbolLEN(symbol); },
                          [](const auto &x) { return x.LEN(); },
                      },
        u);
  } else {
    common::die("Designator<non-char>::LEN() called");
    return std::nullopt;
  }
}

std::optional<Expr<SubscriptInteger>> ProcedureDesignator::LEN() const {
  using T = std::optional<Expr<SubscriptInteger>>;
  return std::visit(
      common::visitors{
          [](SymbolRef symbol) -> T { return SymbolLEN(symbol); },
          [](const common::CopyableIndirection<Component> &c) -> T {
            return c.value().LEN();
          },
          [](const SpecificIntrinsic &i) -> T {
            // Some cases whose results' lengths can be determined
            // from the lengths of their arguments are handled in
            // ProcedureRef::LEN() before coming here.
            if (const auto &result{i.characteristics.value().functionResult}) {
              if (const auto *type{result->GetTypeAndShape()}) {
                if (auto length{type->type().GetCharLength()}) {
                  return std::move(*length);
                }
              }
            }
            return std::nullopt;
          },
      },
      u);
}

// Rank()
int BaseObject::Rank() const {
  return std::visit(common::visitors{
                        [](SymbolRef symbol) { return symbol->Rank(); },
                        [](const StaticDataObject::Pointer &) { return 0; },
                    },
      u);
}

int Component::Rank() const {
  if (int rank{symbol_->Rank()}; rank > 0) {
    return rank;
  }
  return base().Rank();
}

int NamedEntity::Rank() const {
  return std::visit(common::visitors{
                        [](const SymbolRef s) { return s->Rank(); },
                        [](const Component &c) { return c.Rank(); },
                    },
      u_);
}

int Subscript::Rank() const {
  return std::visit(common::visitors{
                        [](const IndirectSubscriptIntegerExpr &x) {
                          return x.value().Rank();
                        },
                        [](const Triplet &) { return 1; },
                    },
      u);
}

int ArrayRef::Rank() const {
  int rank{0};
  for (const auto &expr : subscript_) {
    rank += expr.Rank();
  }
  if (rank > 0) {
    return rank;
  } else if (const Component * component{base_.UnwrapComponent()}) {
    return component->base().Rank();
  } else {
    return 0;
  }
}

int CoarrayRef::Rank() const {
  if (!subscript_.empty()) {
    int rank{0};
    for (const auto &expr : subscript_) {
      rank += expr.Rank();
    }
    return rank;
  } else {
    return base_.back()->Rank();
  }
}

int DataRef::Rank() const {
  return std::visit(common::visitors{
                        [](SymbolRef symbol) { return symbol->Rank(); },
                        [](const auto &x) { return x.Rank(); },
                    },
      u);
}

int Substring::Rank() const {
  return std::visit(common::visitors{
                        [](const DataRef &dataRef) { return dataRef.Rank(); },
                        [](const StaticDataObject::Pointer &) { return 0; },
                    },
      parent_);
}

int ComplexPart::Rank() const { return complex_.Rank(); }

template <typename T> int Designator<T>::Rank() const {
  return std::visit(common::visitors{
                        [](SymbolRef symbol) { return symbol->Rank(); },
                        [](const auto &x) { return x.Rank(); },
                    },
      u);
}

// GetBaseObject(), GetFirstSymbol(), GetLastSymbol(), &c.
const Symbol &Component::GetFirstSymbol() const {
  return base_.value().GetFirstSymbol();
}

const Symbol &NamedEntity::GetFirstSymbol() const {
  return std::visit(common::visitors{
                        [](SymbolRef s) -> const Symbol & { return s; },
                        [](const Component &c) -> const Symbol & {
                          return c.GetFirstSymbol();
                        },
                    },
      u_);
}

const Symbol &NamedEntity::GetLastSymbol() const {
  return std::visit(common::visitors{
                        [](SymbolRef s) -> const Symbol & { return s; },
                        [](const Component &c) -> const Symbol & {
                          return c.GetLastSymbol();
                        },
                    },
      u_);
}

const Component *NamedEntity::UnwrapComponent() const {
  return std::visit(common::visitors{
                        [](SymbolRef) -> const Component * { return nullptr; },
                        [](const Component &c) { return &c; },
                    },
      u_);
}

Component *NamedEntity::UnwrapComponent() {
  return std::visit(common::visitors{
                        [](SymbolRef &) -> Component * { return nullptr; },
                        [](Component &c) { return &c; },
                    },
      u_);
}

const Symbol &ArrayRef::GetFirstSymbol() const {
  return base_.GetFirstSymbol();
}

const Symbol &ArrayRef::GetLastSymbol() const { return base_.GetLastSymbol(); }

const Symbol &DataRef::GetFirstSymbol() const {
  return *std::visit(common::visitors{
                         [](SymbolRef symbol) { return &*symbol; },
                         [](const auto &x) { return &x.GetFirstSymbol(); },
                     },
      u);
}

const Symbol &DataRef::GetLastSymbol() const {
  return *std::visit(common::visitors{
                         [](SymbolRef symbol) { return &*symbol; },
                         [](const auto &x) { return &x.GetLastSymbol(); },
                     },
      u);
}

BaseObject Substring::GetBaseObject() const {
  return std::visit(common::visitors{
                        [](const DataRef &dataRef) {
                          return BaseObject{dataRef.GetFirstSymbol()};
                        },
                        [](StaticDataObject::Pointer pointer) {
                          return BaseObject{std::move(pointer)};
                        },
                    },
      parent_);
}

const Symbol *Substring::GetLastSymbol() const {
  return std::visit(
      common::visitors{
          [](const DataRef &dataRef) { return &dataRef.GetLastSymbol(); },
          [](const auto &) -> const Symbol * { return nullptr; },
      },
      parent_);
}

template <typename T> BaseObject Designator<T>::GetBaseObject() const {
  return std::visit(
      common::visitors{
          [](SymbolRef symbol) { return BaseObject{symbol}; },
          [](const Substring &sstring) { return sstring.GetBaseObject(); },
          [](const auto &x) {
#if !__clang__ && __GNUC__ == 7 && __GNUC_MINOR__ == 2
            if constexpr (std::is_same_v<std::decay_t<decltype(x)>,
                              Substring>) {
              return x.GetBaseObject();
            } else
#endif
              return BaseObject{x.GetFirstSymbol()};
          },
      },
      u);
}

template <typename T> const Symbol *Designator<T>::GetLastSymbol() const {
  return std::visit(
      common::visitors{
          [](SymbolRef symbol) { return &*symbol; },
          [](const Substring &sstring) { return sstring.GetLastSymbol(); },
          [](const auto &x) {
#if !__clang__ && __GNUC__ == 7 && __GNUC_MINOR__ == 2
            if constexpr (std::is_same_v<std::decay_t<decltype(x)>,
                              Substring>) {
              return x.GetLastSymbol();
            } else
#endif
              return &x.GetLastSymbol();
          },
      },
      u);
}

template <typename T>
std::optional<DynamicType> Designator<T>::GetType() const {
  if constexpr (IsLengthlessIntrinsicType<Result>) {
    return Result::GetType();
  } else if (const Symbol * symbol{GetLastSymbol()}) {
    return DynamicType::From(*symbol);
  } else if constexpr (Result::category == TypeCategory::Character) {
    if (const Substring * substring{std::get_if<Substring>(&u)}) {
      const auto *parent{substring->GetParentIf<StaticDataObject::Pointer>()};
      CHECK(parent);
      return DynamicType{TypeCategory::Character, (*parent)->itemBytes()};
    }
  }
  return std::nullopt;
}

static NamedEntity AsNamedEntity(const SymbolVector &x) {
  CHECK(!x.empty());
  NamedEntity result{x.front()};
  int j{0};
  for (const Symbol &symbol : x) {
    if (j++ != 0) {
      DataRef base{result.IsSymbol() ? DataRef{result.GetLastSymbol()}
                                     : DataRef{result.GetComponent()}};
      result = NamedEntity{Component{std::move(base), symbol}};
    }
  }
  return result;
}

NamedEntity CoarrayRef::GetBase() const { return AsNamedEntity(base_); }

// Equality testing

// For the purposes of comparing type parameter expressions while
// testing the compatibility of procedure characteristics, two
// object dummy arguments with the same name are considered equal.
static bool AreSameSymbol(const Symbol &x, const Symbol &y) {
  if (&x == &y) {
    return true;
  }
  if (x.name() == y.name()) {
    if (const auto *xObject{x.detailsIf<semantics::ObjectEntityDetails>()}) {
      if (const auto *yObject{y.detailsIf<semantics::ObjectEntityDetails>()}) {
        return xObject->isDummy() && yObject->isDummy();
      }
    }
  }
  return false;
}

// Implements operator==() for a union type, using special case handling
// for Symbol references.
template <typename A> static bool TestVariableEquality(const A &x, const A &y) {
  const SymbolRef *xSymbol{std::get_if<SymbolRef>(&x.u)};
  if (const SymbolRef * ySymbol{std::get_if<SymbolRef>(&y.u)}) {
    return xSymbol && AreSameSymbol(*xSymbol, *ySymbol);
  } else {
    return x.u == y.u;
  }
}

bool BaseObject::operator==(const BaseObject &that) const {
  return TestVariableEquality(*this, that);
}
bool Component::operator==(const Component &that) const {
  return base_ == that.base_ && &*symbol_ == &*that.symbol_;
}
bool NamedEntity::operator==(const NamedEntity &that) const {
  if (IsSymbol()) {
    return that.IsSymbol() &&
        AreSameSymbol(GetFirstSymbol(), that.GetFirstSymbol());
  } else {
    return !that.IsSymbol() && GetComponent() == that.GetComponent();
  }
}
bool TypeParamInquiry::operator==(const TypeParamInquiry &that) const {
  return &*parameter_ == &*that.parameter_ && base_ == that.base_;
}
bool Triplet::operator==(const Triplet &that) const {
  return lower_ == that.lower_ && upper_ == that.upper_ &&
      stride_ == that.stride_;
}
bool Subscript::operator==(const Subscript &that) const { return u == that.u; }
bool ArrayRef::operator==(const ArrayRef &that) const {
  return base_ == that.base_ && subscript_ == that.subscript_;
}
bool CoarrayRef::operator==(const CoarrayRef &that) const {
  return base_ == that.base_ && subscript_ == that.subscript_ &&
      cosubscript_ == that.cosubscript_ && stat_ == that.stat_ &&
      team_ == that.team_ && teamIsTeamNumber_ == that.teamIsTeamNumber_;
}
bool DataRef::operator==(const DataRef &that) const {
  return TestVariableEquality(*this, that);
}
bool Substring::operator==(const Substring &that) const {
  return parent_ == that.parent_ && lower_ == that.lower_ &&
      upper_ == that.upper_;
}
bool ComplexPart::operator==(const ComplexPart &that) const {
  return part_ == that.part_ && complex_ == that.complex_;
}
bool ProcedureRef::operator==(const ProcedureRef &that) const {
  return proc_ == that.proc_ && arguments_ == that.arguments_;
}
template <typename T>
bool Designator<T>::operator==(const Designator<T> &that) const {
  return TestVariableEquality(*this, that);
}
bool DescriptorInquiry::operator==(const DescriptorInquiry &that) const {
  return field_ == that.field_ && base_ == that.base_ &&
      dimension_ == that.dimension_;
}

INSTANTIATE_VARIABLE_TEMPLATES
} // namespace Fortran::evaluate

template class Fortran::common::Indirection<Fortran::evaluate::Component, true>;