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/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 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
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) * 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
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::evaluate
251

source code of flang/lib/Evaluate/call.cpp