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/expression.h"
14 #include "flang/Evaluate/tools.h"
15 #include "flang/Semantics/symbol.h"
16
17 namespace Fortran::evaluate {
18
DEFINE_DEFAULT_CONSTRUCTORS_AND_ASSIGNMENTS(ActualArgument)19 DEFINE_DEFAULT_CONSTRUCTORS_AND_ASSIGNMENTS(ActualArgument)
20 ActualArgument::ActualArgument(Expr<SomeType> &&x) : u_{std::move(x)} {}
ActualArgument(common::CopyableIndirection<Expr<SomeType>> && v)21 ActualArgument::ActualArgument(common::CopyableIndirection<Expr<SomeType>> &&v)
22 : u_{std::move(v)} {}
ActualArgument(AssumedType x)23 ActualArgument::ActualArgument(AssumedType x) : u_{x} {}
ActualArgument(common::Label x)24 ActualArgument::ActualArgument(common::Label x) : u_{x} {}
~ActualArgument()25 ActualArgument::~ActualArgument() {}
26
AssumedType(const Symbol & symbol)27 ActualArgument::AssumedType::AssumedType(const Symbol &symbol)
28 : symbol_{symbol} {
29 const semantics::DeclTypeSpec *type{symbol.GetType()};
30 CHECK(type && type->category() == semantics::DeclTypeSpec::TypeStar);
31 }
32
Rank() const33 int ActualArgument::AssumedType::Rank() const { return symbol_->Rank(); }
34
operator =(Expr<SomeType> && expr)35 ActualArgument &ActualArgument::operator=(Expr<SomeType> &&expr) {
36 u_ = std::move(expr);
37 return *this;
38 }
39
GetType() const40 std::optional<DynamicType> ActualArgument::GetType() const {
41 if (const Expr<SomeType> *expr{UnwrapExpr()}) {
42 return expr->GetType();
43 } else if (std::holds_alternative<AssumedType>(u_)) {
44 return DynamicType::AssumedType();
45 } else {
46 return std::nullopt;
47 }
48 }
49
Rank() const50 int ActualArgument::Rank() const {
51 if (const Expr<SomeType> *expr{UnwrapExpr()}) {
52 return expr->Rank();
53 } else {
54 return std::get<AssumedType>(u_).Rank();
55 }
56 }
57
operator ==(const ActualArgument & that) const58 bool ActualArgument::operator==(const ActualArgument &that) const {
59 return keyword_ == that.keyword_ && isPassedObject_ == that.isPassedObject_ &&
60 u_ == that.u_;
61 }
62
Parenthesize()63 void ActualArgument::Parenthesize() {
64 u_ = evaluate::Parenthesize(std::move(DEREF(UnwrapExpr())));
65 }
66
SpecificIntrinsic(IntrinsicProcedure n,characteristics::Procedure && chars)67 SpecificIntrinsic::SpecificIntrinsic(
68 IntrinsicProcedure n, characteristics::Procedure &&chars)
69 : name{n}, characteristics{
70 new characteristics::Procedure{std::move(chars)}} {}
71
DEFINE_DEFAULT_CONSTRUCTORS_AND_ASSIGNMENTS(SpecificIntrinsic)72 DEFINE_DEFAULT_CONSTRUCTORS_AND_ASSIGNMENTS(SpecificIntrinsic)
73
74 SpecificIntrinsic::~SpecificIntrinsic() {}
75
operator ==(const SpecificIntrinsic & that) const76 bool SpecificIntrinsic::operator==(const SpecificIntrinsic &that) const {
77 return name == that.name && characteristics == that.characteristics;
78 }
79
ProcedureDesignator(Component && c)80 ProcedureDesignator::ProcedureDesignator(Component &&c)
81 : u{common::CopyableIndirection<Component>::Make(std::move(c))} {}
82
operator ==(const ProcedureDesignator & that) const83 bool ProcedureDesignator::operator==(const ProcedureDesignator &that) const {
84 return u == that.u;
85 }
86
GetType() const87 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
Rank() const100 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
GetInterfaceSymbol() const118 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->interface().symbol();
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
IsElemental() const133 bool ProcedureDesignator::IsElemental() const {
134 if (const Symbol * interface{GetInterfaceSymbol()}) {
135 return interface->attrs().test(semantics::Attr::ELEMENTAL);
136 } else if (const Symbol * symbol{GetSymbol()}) {
137 return symbol->attrs().test(semantics::Attr::ELEMENTAL);
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
GetSpecificIntrinsic() const147 const SpecificIntrinsic *ProcedureDesignator::GetSpecificIntrinsic() const {
148 return std::get_if<SpecificIntrinsic>(&u);
149 }
150
GetComponent() const151 const Component *ProcedureDesignator::GetComponent() const {
152 if (auto *c{std::get_if<common::CopyableIndirection<Component>>(&u)}) {
153 return &c->value();
154 } else {
155 return nullptr;
156 }
157 }
158
GetSymbol() const159 const Symbol *ProcedureDesignator::GetSymbol() const {
160 return std::visit(common::visitors{
161 [](SymbolRef symbol) { return &*symbol; },
162 [](const common::CopyableIndirection<Component> &c) {
163 return &c.value().GetLastSymbol();
164 },
165 [](const auto &) -> const Symbol * { return nullptr; },
166 },
167 u);
168 }
169
GetName() const170 std::string ProcedureDesignator::GetName() const {
171 return std::visit(
172 common::visitors{
173 [](const SpecificIntrinsic &i) { return i.name; },
174 [](const Symbol &symbol) { return symbol.name().ToString(); },
175 [](const common::CopyableIndirection<Component> &c) {
176 return c.value().GetLastSymbol().name().ToString();
177 },
178 },
179 u);
180 }
181
LEN() const182 std::optional<Expr<SubscriptInteger>> ProcedureRef::LEN() const {
183 if (const auto *intrinsic{std::get_if<SpecificIntrinsic>(&proc_.u)}) {
184 if (intrinsic->name == "repeat") {
185 // LEN(REPEAT(ch,n)) == LEN(ch) * n
186 CHECK(arguments_.size() == 2);
187 const auto *stringArg{
188 UnwrapExpr<Expr<SomeCharacter>>(arguments_[0].value())};
189 const auto *nCopiesArg{
190 UnwrapExpr<Expr<SomeInteger>>(arguments_[1].value())};
191 CHECK(stringArg && nCopiesArg);
192 if (auto stringLen{stringArg->LEN()}) {
193 auto converted{ConvertTo(*stringLen, common::Clone(*nCopiesArg))};
194 return *std::move(stringLen) * std::move(converted);
195 }
196 }
197 // Some other cases (e.g., LEN(CHAR(...))) are handled in
198 // ProcedureDesignator::LEN() because they're independent of the
199 // lengths of the actual arguments.
200 }
201 return proc_.LEN();
202 }
203
Rank() const204 int ProcedureRef::Rank() const {
205 if (IsElemental()) {
206 for (const auto &arg : arguments_) {
207 if (arg) {
208 if (int rank{arg->Rank()}; rank > 0) {
209 return rank;
210 }
211 }
212 }
213 return 0;
214 } else {
215 return proc_.Rank();
216 }
217 }
218
~ProcedureRef()219 ProcedureRef::~ProcedureRef() {}
220
Deleter(ProcedureRef * p)221 void ProcedureRef::Deleter(ProcedureRef *p) { delete p; }
222
223 FOR_EACH_SPECIFIC_TYPE(template class FunctionRef, )
224 } // namespace Fortran::evaluate
225