| //===-- lib/Evaluate/call.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/call.h" |
| #include "flang/Common/Fortran.h" |
| #include "flang/Common/idioms.h" |
| #include "flang/Evaluate/characteristics.h" |
| #include "flang/Evaluate/check-expression.h" |
| #include "flang/Evaluate/expression.h" |
| #include "flang/Evaluate/tools.h" |
| #include "flang/Semantics/symbol.h" |
| |
| namespace Fortran::evaluate { |
| |
| DEFINE_DEFAULT_CONSTRUCTORS_AND_ASSIGNMENTS(ActualArgument) |
| ActualArgument::ActualArgument(Expr<SomeType> &&x) : u_{std::move(x)} {} |
| ActualArgument::ActualArgument(common::CopyableIndirection<Expr<SomeType>> &&v) |
| : u_{std::move(v)} {} |
| ActualArgument::ActualArgument(AssumedType x) : u_{x} {} |
| ActualArgument::ActualArgument(common::Label x) : u_{x} {} |
| ActualArgument::~ActualArgument() {} |
| |
| ActualArgument::AssumedType::AssumedType(const Symbol &symbol) |
| : symbol_{symbol} { |
| const semantics::DeclTypeSpec *type{symbol.GetType()}; |
| CHECK(type && type->category() == semantics::DeclTypeSpec::TypeStar); |
| } |
| |
| int ActualArgument::AssumedType::Rank() const { return symbol_->Rank(); } |
| |
| ActualArgument &ActualArgument::operator=(Expr<SomeType> &&expr) { |
| u_ = std::move(expr); |
| return *this; |
| } |
| |
| std::optional<DynamicType> ActualArgument::GetType() const { |
| if (const Expr<SomeType> *expr{UnwrapExpr()}) { |
| return expr->GetType(); |
| } else if (std::holds_alternative<AssumedType>(u_)) { |
| return DynamicType::AssumedType(); |
| } else { |
| return std::nullopt; |
| } |
| } |
| |
| int ActualArgument::Rank() const { |
| if (const Expr<SomeType> *expr{UnwrapExpr()}) { |
| return expr->Rank(); |
| } else { |
| return std::get<AssumedType>(u_).Rank(); |
| } |
| } |
| |
| bool ActualArgument::operator==(const ActualArgument &that) const { |
| return keyword_ == that.keyword_ && attrs_ == that.attrs_ && u_ == that.u_; |
| } |
| |
| void ActualArgument::Parenthesize() { |
| u_ = evaluate::Parenthesize(std::move(DEREF(UnwrapExpr()))); |
| } |
| |
| SpecificIntrinsic::SpecificIntrinsic( |
| IntrinsicProcedure n, characteristics::Procedure &&chars) |
| : name{n}, characteristics{ |
| new characteristics::Procedure{std::move(chars)}} {} |
| |
| DEFINE_DEFAULT_CONSTRUCTORS_AND_ASSIGNMENTS(SpecificIntrinsic) |
| |
| SpecificIntrinsic::~SpecificIntrinsic() {} |
| |
| bool SpecificIntrinsic::operator==(const SpecificIntrinsic &that) const { |
| return name == that.name && characteristics == that.characteristics; |
| } |
| |
| ProcedureDesignator::ProcedureDesignator(Component &&c) |
| : u{common::CopyableIndirection<Component>::Make(std::move(c))} {} |
| |
| bool ProcedureDesignator::operator==(const ProcedureDesignator &that) const { |
| return u == that.u; |
| } |
| |
| std::optional<DynamicType> ProcedureDesignator::GetType() const { |
| if (const auto *intrinsic{std::get_if<SpecificIntrinsic>(&u)}) { |
| if (const auto &result{intrinsic->characteristics.value().functionResult}) { |
| if (const auto *typeAndShape{result->GetTypeAndShape()}) { |
| return typeAndShape->type(); |
| } |
| } |
| } else { |
| return DynamicType::From(GetSymbol()); |
| } |
| return std::nullopt; |
| } |
| |
| int ProcedureDesignator::Rank() const { |
| if (const Symbol * symbol{GetSymbol()}) { |
| // Subtle: will be zero for functions returning procedure pointers |
| return symbol->Rank(); |
| } |
| if (const auto *intrinsic{std::get_if<SpecificIntrinsic>(&u)}) { |
| if (const auto &result{intrinsic->characteristics.value().functionResult}) { |
| if (const auto *typeAndShape{result->GetTypeAndShape()}) { |
| CHECK(!typeAndShape->attrs().test( |
| characteristics::TypeAndShape::Attr::AssumedRank)); |
| return typeAndShape->Rank(); |
| } |
| // Otherwise, intrinsic returns a procedure pointer (e.g. NULL(MOLD=pptr)) |
| } |
| } |
| return 0; |
| } |
| |
| const Symbol *ProcedureDesignator::GetInterfaceSymbol() const { |
| if (const Symbol * symbol{GetSymbol()}) { |
| const Symbol &ultimate{symbol->GetUltimate()}; |
| if (const auto *proc{ultimate.detailsIf<semantics::ProcEntityDetails>()}) { |
| return proc->procInterface(); |
| } else if (const auto *binding{ |
| ultimate.detailsIf<semantics::ProcBindingDetails>()}) { |
| return &binding->symbol(); |
| } else if (ultimate.has<semantics::SubprogramDetails>()) { |
| return &ultimate; |
| } |
| } |
| return nullptr; |
| } |
| |
| bool ProcedureDesignator::IsElemental() const { |
| if (const Symbol * interface{GetInterfaceSymbol()}) { |
| return IsElementalProcedure(*interface); |
| } else if (const Symbol * symbol{GetSymbol()}) { |
| return IsElementalProcedure(*symbol); |
| } else if (const auto *intrinsic{std::get_if<SpecificIntrinsic>(&u)}) { |
| return intrinsic->characteristics.value().attrs.test( |
| characteristics::Procedure::Attr::Elemental); |
| } else { |
| DIE("ProcedureDesignator::IsElemental(): no case"); |
| } |
| return false; |
| } |
| |
| bool ProcedureDesignator::IsPure() const { |
| if (const Symbol * interface{GetInterfaceSymbol()}) { |
| return IsPureProcedure(*interface); |
| } else if (const Symbol * symbol{GetSymbol()}) { |
| return IsPureProcedure(*symbol); |
| } else if (const auto *intrinsic{std::get_if<SpecificIntrinsic>(&u)}) { |
| return intrinsic->characteristics.value().attrs.test( |
| characteristics::Procedure::Attr::Pure); |
| } else { |
| DIE("ProcedureDesignator::IsPure(): no case"); |
| } |
| return false; |
| } |
| |
| const SpecificIntrinsic *ProcedureDesignator::GetSpecificIntrinsic() const { |
| return std::get_if<SpecificIntrinsic>(&u); |
| } |
| |
| const Component *ProcedureDesignator::GetComponent() const { |
| if (auto *c{std::get_if<common::CopyableIndirection<Component>>(&u)}) { |
| return &c->value(); |
| } else { |
| return nullptr; |
| } |
| } |
| |
| const Symbol *ProcedureDesignator::GetSymbol() const { |
| return common::visit( |
| common::visitors{ |
| [](SymbolRef symbol) { return &*symbol; }, |
| [](const common::CopyableIndirection<Component> &c) { |
| return &c.value().GetLastSymbol(); |
| }, |
| [](const auto &) -> const Symbol * { return nullptr; }, |
| }, |
| u); |
| } |
| |
| const SymbolRef *ProcedureDesignator::UnwrapSymbolRef() const { |
| return std::get_if<SymbolRef>(&u); |
| } |
| |
| std::string ProcedureDesignator::GetName() const { |
| return common::visit( |
| common::visitors{ |
| [](const SpecificIntrinsic &i) { return i.name; }, |
| [](const Symbol &symbol) { return symbol.name().ToString(); }, |
| [](const common::CopyableIndirection<Component> &c) { |
| return c.value().GetLastSymbol().name().ToString(); |
| }, |
| }, |
| u); |
| } |
| |
| std::optional<Expr<SubscriptInteger>> ProcedureRef::LEN() const { |
| if (const auto *intrinsic{std::get_if<SpecificIntrinsic>(&proc_.u)}) { |
| if (intrinsic->name == "repeat") { |
| // LEN(REPEAT(ch,n)) == LEN(ch) * n |
| CHECK(arguments_.size() == 2); |
| const auto *stringArg{ |
| UnwrapExpr<Expr<SomeCharacter>>(arguments_[0].value())}; |
| const auto *nCopiesArg{ |
| UnwrapExpr<Expr<SomeInteger>>(arguments_[1].value())}; |
| CHECK(stringArg && nCopiesArg); |
| if (auto stringLen{stringArg->LEN()}) { |
| auto converted{ConvertTo(*stringLen, common::Clone(*nCopiesArg))}; |
| return *std::move(stringLen) * std::move(converted); |
| } |
| } |
| // Some other cases (e.g., LEN(CHAR(...))) are handled in |
| // ProcedureDesignator::LEN() because they're independent of the |
| // lengths of the actual arguments. |
| } |
| if (auto len{proc_.LEN()}) { |
| if (IsActuallyConstant(*len)) { |
| return len; |
| } |
| // TODO: Handle cases where the length of a function result is a |
| // safe expression in terms of actual argument values, after substituting |
| // actual argument expressions for INTENT(IN)/VALUE dummy arguments. |
| } |
| return std::nullopt; |
| } |
| |
| int ProcedureRef::Rank() const { |
| if (IsElemental()) { |
| for (const auto &arg : arguments_) { |
| if (arg) { |
| if (int rank{arg->Rank()}; rank > 0) { |
| return rank; |
| } |
| } |
| } |
| return 0; |
| } else { |
| return proc_.Rank(); |
| } |
| } |
| |
| ProcedureRef::~ProcedureRef() {} |
| |
| void ProcedureRef::Deleter(ProcedureRef *p) { delete p; } |
| |
| } // namespace Fortran::evaluate |