flang/lib/Evaluate/call.cpp

   1 //===-- lib/Evaluate/call.cpp ---------------------------------------------===//
   2 //
   3 // Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
   4 // See https://llvm.org/LICENSE.txt for license information.
   5 // SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
   6 //
   7 //===----------------------------------------------------------------------===//
   8
   9 #include "flang/Evaluate/call.h"
  10 #include "flang/Common/Fortran.h"
  11 #include "flang/Common/idioms.h"
  12 #include "flang/Evaluate/characteristics.h"
  13 #include "flang/Evaluate/check-expression.h"
  14 #include "flang/Evaluate/expression.h"
  15 #include "flang/Evaluate/tools.h"
  16 #include "flang/Semantics/symbol.h"
  17
  18 namespace Fortran::evaluate {
  19
  20 DEFINE_DEFAULT_CONSTRUCTORS_AND_ASSIGNMENTS(ActualArgument)
  21 ActualArgument::ActualArgument(Expr<SomeType> &&x) : u_{std::move(x)} {}
  22 ActualArgument::ActualArgument(common::CopyableIndirection<Expr<SomeType>> &&v)
  23     : u_{std::move(v)} {}
  24 ActualArgument::ActualArgument(AssumedType x) : u_{x} {}
  25 ActualArgument::ActualArgument(common::Label x) : u_{x} {}
  26 ActualArgument::~ActualArgument() {}
  27
  28 ActualArgument::AssumedType::AssumedType(const Symbol &symbol)
  29     : symbol_{symbol} {
  30   const semantics::DeclTypeSpec *type{symbol.GetType()};
  31   CHECK(type && type->category() == semantics::DeclTypeSpec::TypeStar);
  32 }
  33
  34 int ActualArgument::AssumedType::Rank() const { return symbol_->Rank(); }
  35
  36 ActualArgument &ActualArgument::operator=(Expr<SomeType> &&expr) {
  37   u_ = std::move(expr);
  38   return *this;
  39 }
  40
  41 std::optional<DynamicType> ActualArgument::GetType() const {
  42   if (const Expr<SomeType> *expr{UnwrapExpr()}) {
  43     return expr->GetType();
  44   } else if (std::holds_alternative<AssumedType>(u_)) {
  45     return DynamicType::AssumedType();
  46   } else {
  47     return std::nullopt;
  48   }
  49 }
  50
  51 int ActualArgument::Rank() const {
  52   if (const Expr<SomeType> *expr{UnwrapExpr()}) {
  53     return expr->Rank();
  54   } else {
  55     return std::get<AssumedType>(u_).Rank();
  56   }
  57 }
  58
  59 bool ActualArgument::operator==(const ActualArgument &that) const {
  60   return keyword_ == that.keyword_ && attrs_ == that.attrs_ && u_ == that.u_;
  61 }
  62
  63 void ActualArgument::Parenthesize() {
  64   u_ = evaluate::Parenthesize(std::move(DEREF(UnwrapExpr())));
  65 }
  66
  67 SpecificIntrinsic::SpecificIntrinsic(
  68     IntrinsicProcedure n, characteristics::Procedure &&chars)
  69     : name{n}, characteristics{
  70                    new characteristics::Procedure{std::move(chars)}} {}
  71
  72 DEFINE_DEFAULT_CONSTRUCTORS_AND_ASSIGNMENTS(SpecificIntrinsic)
  73
  74 SpecificIntrinsic::~SpecificIntrinsic() {}
  75
  76 bool SpecificIntrinsic::operator==(const SpecificIntrinsic &that) const {
  77   return name == that.name && characteristics == that.characteristics;
  78 }
  79
  80 ProcedureDesignator::ProcedureDesignator(Component &&c)
  81     : u{common::CopyableIndirection<Component>::Make(std::move(c))} {}
  82
  83 bool ProcedureDesignator::operator==(const ProcedureDesignator &that) const {
  84   return u == that.u;
  85 }
  86
  87 std::optional<DynamicType> ProcedureDesignator::GetType() const {
  88   if (const auto *intrinsic{std::get_if<SpecificIntrinsic>(&u)}) {
  89     if (const auto &result{intrinsic->characteristics.value().functionResult}) {
  90       if (const auto *typeAndShape{result->GetTypeAndShape()}) {
  91         return typeAndShape->type();
  92       }
  93     }
  94   } else {
  95     return DynamicType::From(GetSymbol());
  96   }
  97   return std::nullopt;
  98 }
  99
 100 int ProcedureDesignator::Rank() const {
 101   if (const Symbol * symbol{GetSymbol()}) {
 102     // Subtle: will be zero for functions returning procedure pointers
 103     return symbol->Rank();
 104   }
 105   if (const auto *intrinsic{std::get_if<SpecificIntrinsic>(&u)}) {
 106     if (const auto &result{intrinsic->characteristics.value().functionResult}) {
 107       if (const auto *typeAndShape{result->GetTypeAndShape()}) {
 108         CHECK(!typeAndShape->attrs().test(
 109             characteristics::TypeAndShape::Attr::AssumedRank));
 110         return typeAndShape->Rank();
 111       }
 112       // Otherwise, intrinsic returns a procedure pointer (e.g. NULL(MOLD=pptr))
 113     }
 114   }
 115   return 0;
 116 }
 117
 118 const Symbol *ProcedureDesignator::GetInterfaceSymbol() const {
 119   if (const Symbol * symbol{GetSymbol()}) {
 120     const Symbol &ultimate{symbol->GetUltimate()};
 121     if (const auto *proc{ultimate.detailsIf<semantics::ProcEntityDetails>()}) {
 122       return proc->procInterface();
 123     } else if (const auto *binding{
 124                    ultimate.detailsIf<semantics::ProcBindingDetails>()}) {
 125       return &binding->symbol();
 126     } else if (ultimate.has<semantics::SubprogramDetails>()) {
 127       return &ultimate;
 128     }
 129   }
 130   return nullptr;
 131 }
 132
 133 bool ProcedureDesignator::IsElemental() const {
 134   if (const Symbol * interface{GetInterfaceSymbol()}) {
 135     return IsElementalProcedure(*interface);
 136   } else if (const Symbol * symbol{GetSymbol()}) {
 137     return IsElementalProcedure(*symbol);
 138   } else if (const auto *intrinsic{std::get_if<SpecificIntrinsic>(&u)}) {
 139     return intrinsic->characteristics.value().attrs.test(
 140         characteristics::Procedure::Attr::Elemental);
 141   } else {
 142     DIE("ProcedureDesignator::IsElemental(): no case");
 143   }
 144   return false;
 145 }
 146
 147 bool ProcedureDesignator::IsPure() const {
 148   if (const Symbol * interface{GetInterfaceSymbol()}) {
 149     return IsPureProcedure(*interface);
 150   } else if (const Symbol * symbol{GetSymbol()}) {
 151     return IsPureProcedure(*symbol);
 152   } else if (const auto *intrinsic{std::get_if<SpecificIntrinsic>(&u)}) {
 153     return intrinsic->characteristics.value().attrs.test(
 154         characteristics::Procedure::Attr::Pure);
 155   } else {
 156     DIE("ProcedureDesignator::IsPure(): no case");
 157   }
 158   return false;
 159 }
 160
 161 const SpecificIntrinsic *ProcedureDesignator::GetSpecificIntrinsic() const {
 162   return std::get_if<SpecificIntrinsic>(&u);
 163 }
 164
 165 const Component *ProcedureDesignator::GetComponent() const {
 166   if (auto *c{std::get_if<common::CopyableIndirection<Component>>(&u)}) {
 167     return &c->value();
 168   } else {
 169     return nullptr;
 170   }
 171 }
 172
 173 const Symbol *ProcedureDesignator::GetSymbol() const {
 174   return common::visit(
 175       common::visitors{
 176           [](SymbolRef symbol) { return &*symbol; },
 177           [](const common::CopyableIndirection<Component> &c) {
 178             return &c.value().GetLastSymbol();
 179           },
 180           [](const auto &) -> const Symbol * { return nullptr; },
 181       },
 182       u);
 183 }
 184
 185 const SymbolRef *ProcedureDesignator::UnwrapSymbolRef() const {
 186   return std::get_if<SymbolRef>(&u);
 187 }
 188
 189 std::string ProcedureDesignator::GetName() const {
 190   return common::visit(
 191       common::visitors{
 192           [](const SpecificIntrinsic &i) { return i.name; },
 193           [](const Symbol &symbol) { return symbol.name().ToString(); },
 194           [](const common::CopyableIndirection<Component> &c) {
 195             return c.value().GetLastSymbol().name().ToString();
 196           },
 197       },
 198       u);
 199 }
 200
 201 std::optional<Expr<SubscriptInteger>> ProcedureRef::LEN() const {
 202   if (const auto *intrinsic{std::get_if<SpecificIntrinsic>(&proc_.u)}) {
 203     if (intrinsic->name == "repeat") {
 204       // LEN(REPEAT(ch,n)) == LEN(ch) * n
 205       CHECK(arguments_.size() == 2);
 206       const auto *stringArg{
 207           UnwrapExpr<Expr<SomeCharacter>>(arguments_[0].value())};
 208       const auto *nCopiesArg{
 209           UnwrapExpr<Expr<SomeInteger>>(arguments_[1].value())};
 210       CHECK(stringArg && nCopiesArg);
 211       if (auto stringLen{stringArg->LEN()}) {
 212         auto converted{ConvertTo(*stringLen, common::Clone(*nCopiesArg))};
 213         return *std::move(stringLen) * std::move(converted);
 214       }
 215     }
 216     // Some other cases (e.g., LEN(CHAR(...))) are handled in
 217     // ProcedureDesignator::LEN() because they're independent of the
 218     // lengths of the actual arguments.
 219   }
 220   if (auto len{proc_.LEN()}) {
 221     if (IsActuallyConstant(*len)) {
 222       return len;
 223     }
 224     // TODO: Handle cases where the length of a function result is a
 225     // safe expression in terms of actual argument values, after substituting
 226     // actual argument expressions for INTENT(IN)/VALUE dummy arguments.
 227   }
 228   return std::nullopt;
 229 }
 230
 231 int ProcedureRef::Rank() const {
 232   if (IsElemental()) {
 233     for (const auto &arg : arguments_) {
 234       if (arg) {
 235         if (int rank{arg->Rank()}; rank > 0) {
 236           return rank;
 237         }
 238       }
 239     }
 240     return 0;
 241   } else {
 242     return proc_.Rank();
 243   }
 244 }
 245
 246 ProcedureRef::~ProcedureRef() {}
 247
 248 void ProcedureRef::Deleter(ProcedureRef *p) { delete p; }
 249
 250 } // namespace Fortran::evaluate