251 lines · 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-exception6//7//===----------------------------------------------------------------------===//8 9#include "flang/Evaluate/call.h"10#include "flang/Common/idioms.h"11#include "flang/Evaluate/characteristics.h"12#include "flang/Evaluate/check-expression.h"13#include "flang/Evaluate/expression.h"14#include "flang/Evaluate/tools.h"15#include "flang/Semantics/symbol.h"16#include "flang/Support/Fortran.h"17 18namespace Fortran::evaluate {19 20DEFINE_DEFAULT_CONSTRUCTORS_AND_ASSIGNMENTS(ActualArgument)21ActualArgument::ActualArgument(Expr<SomeType> &&x) : u_{std::move(x)} {}22ActualArgument::ActualArgument(common::CopyableIndirection<Expr<SomeType>> &&v)23 : u_{std::move(v)} {}24ActualArgument::ActualArgument(AssumedType x) : u_{x} {}25ActualArgument::ActualArgument(common::Label x) : u_{x} {}26ActualArgument::~ActualArgument() {}27 28ActualArgument::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 34int ActualArgument::AssumedType::Rank() const { return symbol_->Rank(); }35 36ActualArgument &ActualArgument::operator=(Expr<SomeType> &&expr) {37 u_ = std::move(expr);38 return *this;39}40 41std::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 51int 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 59bool ActualArgument::operator==(const ActualArgument &that) const {60 return keyword_ == that.keyword_ && attrs_ == that.attrs_ && u_ == that.u_;61}62 63void ActualArgument::Parenthesize() {64 u_ = evaluate::Parenthesize(std::move(DEREF(UnwrapExpr())));65}66 67SpecificIntrinsic::SpecificIntrinsic(68 IntrinsicProcedure n, characteristics::Procedure &&chars)69 : name{n}, characteristics{70 new characteristics::Procedure{std::move(chars)}} {}71 72DEFINE_DEFAULT_CONSTRUCTORS_AND_ASSIGNMENTS(SpecificIntrinsic)73 74SpecificIntrinsic::~SpecificIntrinsic() {}75 76bool SpecificIntrinsic::operator==(const SpecificIntrinsic &that) const {77 return name == that.name && characteristics == that.characteristics;78}79 80ProcedureDesignator::ProcedureDesignator(Component &&c)81 : u{common::CopyableIndirection<Component>::Make(std::move(c))} {}82 83bool ProcedureDesignator::operator==(const ProcedureDesignator &that) const {84 return u == that.u;85}86 87std::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 100int ProcedureDesignator::Rank() const {101 if (const Symbol * symbol{GetSymbol()}) {102 // Subtle: will be zero for functions returning procedure pointers103 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 118const 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 133bool 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 147bool 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 161const SpecificIntrinsic *ProcedureDesignator::GetSpecificIntrinsic() const {162 return std::get_if<SpecificIntrinsic>(&u);163}164 165const 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 173const 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 185const SymbolRef *ProcedureDesignator::UnwrapSymbolRef() const {186 return std::get_if<SymbolRef>(&u);187}188 189std::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 201std::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) * n205 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 in217 // ProcedureDesignator::LEN() because they're independent of the218 // 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 a225 // safe expression in terms of actual argument values, after substituting226 // actual argument expressions for INTENT(IN)/VALUE dummy arguments.227 }228 return std::nullopt;229}230 231int 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 246ProcedureRef::~ProcedureRef() {}247 248void ProcedureRef::Deleter(ProcedureRef *p) { delete p; }249 250} // namespace Fortran::evaluate251