1 //===-- lib/Evaluate/tools.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/tools.h"
10 #include "flang/Common/idioms.h"
11 #include "flang/Evaluate/characteristics.h"
12 #include "flang/Evaluate/traverse.h"
13 #include "flang/Parser/message.h"
14 #include "flang/Semantics/tools.h"
15 #include <algorithm>
16 #include <variant>
17
18 using namespace Fortran::parser::literals;
19
20 namespace Fortran::evaluate {
21
Parenthesize(Expr<SomeType> && expr)22 Expr<SomeType> Parenthesize(Expr<SomeType> &&expr) {
23 return std::visit(
24 [&](auto &&x) {
25 using T = std::decay_t<decltype(x)>;
26 if constexpr (common::HasMember<T, TypelessExpression> ||
27 std::is_same_v<T, Expr<SomeDerived>>) {
28 return expr; // no parentheses around typeless or derived type
29 } else {
30 return std::visit(
31 [](auto &&y) {
32 using T = ResultType<decltype(y)>;
33 return AsGenericExpr(Parentheses<T>{std::move(y)});
34 },
35 std::move(x.u));
36 }
37 },
38 std::move(expr.u));
39 }
40
ExtractSubstringBase(const Substring & substring)41 std::optional<DataRef> ExtractSubstringBase(const Substring &substring) {
42 return std::visit(
43 common::visitors{
44 [&](const DataRef &x) -> std::optional<DataRef> { return x; },
45 [&](const StaticDataObject::Pointer &) -> std::optional<DataRef> {
46 return std::nullopt;
47 },
48 },
49 substring.parent());
50 }
51
52 // IsVariable()
53
operator ()(const Symbol & symbol) const54 auto IsVariableHelper::operator()(const Symbol &symbol) const -> Result {
55 return !symbol.attrs().test(semantics::Attr::PARAMETER);
56 }
operator ()(const Component & x) const57 auto IsVariableHelper::operator()(const Component &x) const -> Result {
58 return (*this)(x.base());
59 }
operator ()(const ArrayRef & x) const60 auto IsVariableHelper::operator()(const ArrayRef &x) const -> Result {
61 return (*this)(x.base());
62 }
operator ()(const Substring & x) const63 auto IsVariableHelper::operator()(const Substring &x) const -> Result {
64 return (*this)(x.GetBaseObject());
65 }
operator ()(const ProcedureDesignator & x) const66 auto IsVariableHelper::operator()(const ProcedureDesignator &x) const
67 -> Result {
68 const Symbol *symbol{x.GetSymbol()};
69 return symbol && IsPointer(*symbol);
70 }
71
72 // Conversions of COMPLEX component expressions to REAL.
ConvertRealOperands(parser::ContextualMessages & messages,Expr<SomeType> && x,Expr<SomeType> && y,int defaultRealKind)73 ConvertRealOperandsResult ConvertRealOperands(
74 parser::ContextualMessages &messages, Expr<SomeType> &&x,
75 Expr<SomeType> &&y, int defaultRealKind) {
76 return std::visit(
77 common::visitors{
78 [&](Expr<SomeInteger> &&ix,
79 Expr<SomeInteger> &&iy) -> ConvertRealOperandsResult {
80 // Can happen in a CMPLX() constructor. Per F'2018,
81 // both integer operands are converted to default REAL.
82 return {AsSameKindExprs<TypeCategory::Real>(
83 ConvertToKind<TypeCategory::Real>(
84 defaultRealKind, std::move(ix)),
85 ConvertToKind<TypeCategory::Real>(
86 defaultRealKind, std::move(iy)))};
87 },
88 [&](Expr<SomeInteger> &&ix,
89 Expr<SomeReal> &&ry) -> ConvertRealOperandsResult {
90 return {AsSameKindExprs<TypeCategory::Real>(
91 ConvertTo(ry, std::move(ix)), std::move(ry))};
92 },
93 [&](Expr<SomeReal> &&rx,
94 Expr<SomeInteger> &&iy) -> ConvertRealOperandsResult {
95 return {AsSameKindExprs<TypeCategory::Real>(
96 std::move(rx), ConvertTo(rx, std::move(iy)))};
97 },
98 [&](Expr<SomeReal> &&rx,
99 Expr<SomeReal> &&ry) -> ConvertRealOperandsResult {
100 return {AsSameKindExprs<TypeCategory::Real>(
101 std::move(rx), std::move(ry))};
102 },
103 [&](Expr<SomeInteger> &&ix,
104 BOZLiteralConstant &&by) -> ConvertRealOperandsResult {
105 return {AsSameKindExprs<TypeCategory::Real>(
106 ConvertToKind<TypeCategory::Real>(
107 defaultRealKind, std::move(ix)),
108 ConvertToKind<TypeCategory::Real>(
109 defaultRealKind, std::move(by)))};
110 },
111 [&](BOZLiteralConstant &&bx,
112 Expr<SomeInteger> &&iy) -> ConvertRealOperandsResult {
113 return {AsSameKindExprs<TypeCategory::Real>(
114 ConvertToKind<TypeCategory::Real>(
115 defaultRealKind, std::move(bx)),
116 ConvertToKind<TypeCategory::Real>(
117 defaultRealKind, std::move(iy)))};
118 },
119 [&](Expr<SomeReal> &&rx,
120 BOZLiteralConstant &&by) -> ConvertRealOperandsResult {
121 return {AsSameKindExprs<TypeCategory::Real>(
122 std::move(rx), ConvertTo(rx, std::move(by)))};
123 },
124 [&](BOZLiteralConstant &&bx,
125 Expr<SomeReal> &&ry) -> ConvertRealOperandsResult {
126 return {AsSameKindExprs<TypeCategory::Real>(
127 ConvertTo(ry, std::move(bx)), std::move(ry))};
128 },
129 [&](auto &&, auto &&) -> ConvertRealOperandsResult { // C718
130 messages.Say("operands must be INTEGER or REAL"_err_en_US);
131 return std::nullopt;
132 },
133 },
134 std::move(x.u), std::move(y.u));
135 }
136
137 // Helpers for NumericOperation and its subroutines below.
NoExpr()138 static std::optional<Expr<SomeType>> NoExpr() { return std::nullopt; }
139
140 template <TypeCategory CAT>
Package(Expr<SomeKind<CAT>> && catExpr)141 std::optional<Expr<SomeType>> Package(Expr<SomeKind<CAT>> &&catExpr) {
142 return {AsGenericExpr(std::move(catExpr))};
143 }
144 template <TypeCategory CAT>
Package(std::optional<Expr<SomeKind<CAT>>> && catExpr)145 std::optional<Expr<SomeType>> Package(
146 std::optional<Expr<SomeKind<CAT>>> &&catExpr) {
147 if (catExpr) {
148 return {AsGenericExpr(std::move(*catExpr))};
149 }
150 return NoExpr();
151 }
152
153 // Mixed REAL+INTEGER operations. REAL**INTEGER is a special case that
154 // does not require conversion of the exponent expression.
155 template <template <typename> class OPR>
MixedRealLeft(Expr<SomeReal> && rx,Expr<SomeInteger> && iy)156 std::optional<Expr<SomeType>> MixedRealLeft(
157 Expr<SomeReal> &&rx, Expr<SomeInteger> &&iy) {
158 return Package(std::visit(
159 [&](auto &&rxk) -> Expr<SomeReal> {
160 using resultType = ResultType<decltype(rxk)>;
161 if constexpr (std::is_same_v<OPR<resultType>, Power<resultType>>) {
162 return AsCategoryExpr(
163 RealToIntPower<resultType>{std::move(rxk), std::move(iy)});
164 }
165 // G++ 8.1.0 emits bogus warnings about missing return statements if
166 // this statement is wrapped in an "else", as it should be.
167 return AsCategoryExpr(OPR<resultType>{
168 std::move(rxk), ConvertToType<resultType>(std::move(iy))});
169 },
170 std::move(rx.u)));
171 }
172
ConstructComplex(parser::ContextualMessages & messages,Expr<SomeType> && real,Expr<SomeType> && imaginary,int defaultRealKind)173 std::optional<Expr<SomeComplex>> ConstructComplex(
174 parser::ContextualMessages &messages, Expr<SomeType> &&real,
175 Expr<SomeType> &&imaginary, int defaultRealKind) {
176 if (auto converted{ConvertRealOperands(
177 messages, std::move(real), std::move(imaginary), defaultRealKind)}) {
178 return {std::visit(
179 [](auto &&pair) {
180 return MakeComplex(std::move(pair[0]), std::move(pair[1]));
181 },
182 std::move(*converted))};
183 }
184 return std::nullopt;
185 }
186
ConstructComplex(parser::ContextualMessages & messages,std::optional<Expr<SomeType>> && real,std::optional<Expr<SomeType>> && imaginary,int defaultRealKind)187 std::optional<Expr<SomeComplex>> ConstructComplex(
188 parser::ContextualMessages &messages, std::optional<Expr<SomeType>> &&real,
189 std::optional<Expr<SomeType>> &&imaginary, int defaultRealKind) {
190 if (auto parts{common::AllPresent(std::move(real), std::move(imaginary))}) {
191 return ConstructComplex(messages, std::get<0>(std::move(*parts)),
192 std::get<1>(std::move(*parts)), defaultRealKind);
193 }
194 return std::nullopt;
195 }
196
GetComplexPart(const Expr<SomeComplex> & z,bool isImaginary)197 Expr<SomeReal> GetComplexPart(const Expr<SomeComplex> &z, bool isImaginary) {
198 return std::visit(
199 [&](const auto &zk) {
200 static constexpr int kind{ResultType<decltype(zk)>::kind};
201 return AsCategoryExpr(ComplexComponent<kind>{isImaginary, zk});
202 },
203 z.u);
204 }
205
206 // Convert REAL to COMPLEX of the same kind. Preserving the real operand kind
207 // and then applying complex operand promotion rules allows the result to have
208 // the highest precision of REAL and COMPLEX operands as required by Fortran
209 // 2018 10.9.1.3.
PromoteRealToComplex(Expr<SomeReal> && someX)210 Expr<SomeComplex> PromoteRealToComplex(Expr<SomeReal> &&someX) {
211 return std::visit(
212 [](auto &&x) {
213 using RT = ResultType<decltype(x)>;
214 return AsCategoryExpr(ComplexConstructor<RT::kind>{
215 std::move(x), AsExpr(Constant<RT>{Scalar<RT>{}})});
216 },
217 std::move(someX.u));
218 }
219
220 // Handle mixed COMPLEX+REAL (or INTEGER) operations in a better way
221 // than just converting the second operand to COMPLEX and performing the
222 // corresponding COMPLEX+COMPLEX operation.
223 template <template <typename> class OPR, TypeCategory RCAT>
MixedComplexLeft(parser::ContextualMessages & messages,Expr<SomeComplex> && zx,Expr<SomeKind<RCAT>> && iry,int defaultRealKind)224 std::optional<Expr<SomeType>> MixedComplexLeft(
225 parser::ContextualMessages &messages, Expr<SomeComplex> &&zx,
226 Expr<SomeKind<RCAT>> &&iry, int defaultRealKind) {
227 Expr<SomeReal> zr{GetComplexPart(zx, false)};
228 Expr<SomeReal> zi{GetComplexPart(zx, true)};
229 if constexpr (std::is_same_v<OPR<LargestReal>, Add<LargestReal>> ||
230 std::is_same_v<OPR<LargestReal>, Subtract<LargestReal>>) {
231 // (a,b) + x -> (a+x, b)
232 // (a,b) - x -> (a-x, b)
233 if (std::optional<Expr<SomeType>> rr{
234 NumericOperation<OPR>(messages, AsGenericExpr(std::move(zr)),
235 AsGenericExpr(std::move(iry)), defaultRealKind)}) {
236 return Package(ConstructComplex(messages, std::move(*rr),
237 AsGenericExpr(std::move(zi)), defaultRealKind));
238 }
239 } else if constexpr (std::is_same_v<OPR<LargestReal>,
240 Multiply<LargestReal>> ||
241 std::is_same_v<OPR<LargestReal>, Divide<LargestReal>>) {
242 // (a,b) * x -> (a*x, b*x)
243 // (a,b) / x -> (a/x, b/x)
244 auto copy{iry};
245 auto rr{NumericOperation<OPR>(messages, AsGenericExpr(std::move(zr)),
246 AsGenericExpr(std::move(iry)), defaultRealKind)};
247 auto ri{NumericOperation<OPR>(messages, AsGenericExpr(std::move(zi)),
248 AsGenericExpr(std::move(copy)), defaultRealKind)};
249 if (auto parts{common::AllPresent(std::move(rr), std::move(ri))}) {
250 return Package(ConstructComplex(messages, std::get<0>(std::move(*parts)),
251 std::get<1>(std::move(*parts)), defaultRealKind));
252 }
253 } else if constexpr (RCAT == TypeCategory::Integer &&
254 std::is_same_v<OPR<LargestReal>, Power<LargestReal>>) {
255 // COMPLEX**INTEGER is a special case that doesn't convert the exponent.
256 static_assert(RCAT == TypeCategory::Integer);
257 return Package(std::visit(
258 [&](auto &&zxk) {
259 using Ty = ResultType<decltype(zxk)>;
260 return AsCategoryExpr(
261 AsExpr(RealToIntPower<Ty>{std::move(zxk), std::move(iry)}));
262 },
263 std::move(zx.u)));
264 } else if (defaultRealKind != 666) { // dodge unused parameter warning
265 // (a,b) ** x -> (a,b) ** (x,0)
266 if constexpr (RCAT == TypeCategory::Integer) {
267 Expr<SomeComplex> zy{ConvertTo(zx, std::move(iry))};
268 return Package(PromoteAndCombine<OPR>(std::move(zx), std::move(zy)));
269 } else {
270 Expr<SomeComplex> zy{PromoteRealToComplex(std::move(iry))};
271 return Package(PromoteAndCombine<OPR>(std::move(zx), std::move(zy)));
272 }
273 }
274 return NoExpr();
275 }
276
277 // Mixed COMPLEX operations with the COMPLEX operand on the right.
278 // x + (a,b) -> (x+a, b)
279 // x - (a,b) -> (x-a, -b)
280 // x * (a,b) -> (x*a, x*b)
281 // x / (a,b) -> (x,0) / (a,b) (and **)
282 template <template <typename> class OPR, TypeCategory LCAT>
MixedComplexRight(parser::ContextualMessages & messages,Expr<SomeKind<LCAT>> && irx,Expr<SomeComplex> && zy,int defaultRealKind)283 std::optional<Expr<SomeType>> MixedComplexRight(
284 parser::ContextualMessages &messages, Expr<SomeKind<LCAT>> &&irx,
285 Expr<SomeComplex> &&zy, int defaultRealKind) {
286 if constexpr (std::is_same_v<OPR<LargestReal>, Add<LargestReal>> ||
287 std::is_same_v<OPR<LargestReal>, Multiply<LargestReal>>) {
288 // x + (a,b) -> (a,b) + x -> (a+x, b)
289 // x * (a,b) -> (a,b) * x -> (a*x, b*x)
290 return MixedComplexLeft<OPR, LCAT>(
291 messages, std::move(zy), std::move(irx), defaultRealKind);
292 } else if constexpr (std::is_same_v<OPR<LargestReal>,
293 Subtract<LargestReal>>) {
294 // x - (a,b) -> (x-a, -b)
295 Expr<SomeReal> zr{GetComplexPart(zy, false)};
296 Expr<SomeReal> zi{GetComplexPart(zy, true)};
297 if (std::optional<Expr<SomeType>> rr{
298 NumericOperation<Subtract>(messages, AsGenericExpr(std::move(irx)),
299 AsGenericExpr(std::move(zr)), defaultRealKind)}) {
300 return Package(ConstructComplex(messages, std::move(*rr),
301 AsGenericExpr(-std::move(zi)), defaultRealKind));
302 }
303 } else if (defaultRealKind != 666) { // dodge unused parameter warning
304 // x / (a,b) -> (x,0) / (a,b)
305 if constexpr (LCAT == TypeCategory::Integer) {
306 Expr<SomeComplex> zx{ConvertTo(zy, std::move(irx))};
307 return Package(PromoteAndCombine<OPR>(std::move(zx), std::move(zy)));
308 } else {
309 Expr<SomeComplex> zx{PromoteRealToComplex(std::move(irx))};
310 return Package(PromoteAndCombine<OPR>(std::move(zx), std::move(zy)));
311 }
312 }
313 return NoExpr();
314 }
315
316 // N.B. When a "typeless" BOZ literal constant appears as one (not both!) of
317 // the operands to a dyadic operation where one is permitted, it assumes the
318 // type and kind of the other operand.
319 template <template <typename> class OPR>
NumericOperation(parser::ContextualMessages & messages,Expr<SomeType> && x,Expr<SomeType> && y,int defaultRealKind)320 std::optional<Expr<SomeType>> NumericOperation(
321 parser::ContextualMessages &messages, Expr<SomeType> &&x,
322 Expr<SomeType> &&y, int defaultRealKind) {
323 return std::visit(
324 common::visitors{
325 [](Expr<SomeInteger> &&ix, Expr<SomeInteger> &&iy) {
326 return Package(PromoteAndCombine<OPR, TypeCategory::Integer>(
327 std::move(ix), std::move(iy)));
328 },
329 [](Expr<SomeReal> &&rx, Expr<SomeReal> &&ry) {
330 return Package(PromoteAndCombine<OPR, TypeCategory::Real>(
331 std::move(rx), std::move(ry)));
332 },
333 // Mixed REAL/INTEGER operations
334 [](Expr<SomeReal> &&rx, Expr<SomeInteger> &&iy) {
335 return MixedRealLeft<OPR>(std::move(rx), std::move(iy));
336 },
337 [](Expr<SomeInteger> &&ix, Expr<SomeReal> &&ry) {
338 return Package(std::visit(
339 [&](auto &&ryk) -> Expr<SomeReal> {
340 using resultType = ResultType<decltype(ryk)>;
341 return AsCategoryExpr(
342 OPR<resultType>{ConvertToType<resultType>(std::move(ix)),
343 std::move(ryk)});
344 },
345 std::move(ry.u)));
346 },
347 // Homogeneous and mixed COMPLEX operations
348 [](Expr<SomeComplex> &&zx, Expr<SomeComplex> &&zy) {
349 return Package(PromoteAndCombine<OPR, TypeCategory::Complex>(
350 std::move(zx), std::move(zy)));
351 },
352 [&](Expr<SomeComplex> &&zx, Expr<SomeInteger> &&iy) {
353 return MixedComplexLeft<OPR>(
354 messages, std::move(zx), std::move(iy), defaultRealKind);
355 },
356 [&](Expr<SomeComplex> &&zx, Expr<SomeReal> &&ry) {
357 return MixedComplexLeft<OPR>(
358 messages, std::move(zx), std::move(ry), defaultRealKind);
359 },
360 [&](Expr<SomeInteger> &&ix, Expr<SomeComplex> &&zy) {
361 return MixedComplexRight<OPR>(
362 messages, std::move(ix), std::move(zy), defaultRealKind);
363 },
364 [&](Expr<SomeReal> &&rx, Expr<SomeComplex> &&zy) {
365 return MixedComplexRight<OPR>(
366 messages, std::move(rx), std::move(zy), defaultRealKind);
367 },
368 // Operations with one typeless operand
369 [&](BOZLiteralConstant &&bx, Expr<SomeInteger> &&iy) {
370 return NumericOperation<OPR>(messages,
371 AsGenericExpr(ConvertTo(iy, std::move(bx))), std::move(y),
372 defaultRealKind);
373 },
374 [&](BOZLiteralConstant &&bx, Expr<SomeReal> &&ry) {
375 return NumericOperation<OPR>(messages,
376 AsGenericExpr(ConvertTo(ry, std::move(bx))), std::move(y),
377 defaultRealKind);
378 },
379 [&](Expr<SomeInteger> &&ix, BOZLiteralConstant &&by) {
380 return NumericOperation<OPR>(messages, std::move(x),
381 AsGenericExpr(ConvertTo(ix, std::move(by))), defaultRealKind);
382 },
383 [&](Expr<SomeReal> &&rx, BOZLiteralConstant &&by) {
384 return NumericOperation<OPR>(messages, std::move(x),
385 AsGenericExpr(ConvertTo(rx, std::move(by))), defaultRealKind);
386 },
387 // Default case
388 [&](auto &&, auto &&) {
389 // TODO: defined operator
390 messages.Say("non-numeric operands to numeric operation"_err_en_US);
391 return NoExpr();
392 },
393 },
394 std::move(x.u), std::move(y.u));
395 }
396
397 template std::optional<Expr<SomeType>> NumericOperation<Power>(
398 parser::ContextualMessages &, Expr<SomeType> &&, Expr<SomeType> &&,
399 int defaultRealKind);
400 template std::optional<Expr<SomeType>> NumericOperation<Multiply>(
401 parser::ContextualMessages &, Expr<SomeType> &&, Expr<SomeType> &&,
402 int defaultRealKind);
403 template std::optional<Expr<SomeType>> NumericOperation<Divide>(
404 parser::ContextualMessages &, Expr<SomeType> &&, Expr<SomeType> &&,
405 int defaultRealKind);
406 template std::optional<Expr<SomeType>> NumericOperation<Add>(
407 parser::ContextualMessages &, Expr<SomeType> &&, Expr<SomeType> &&,
408 int defaultRealKind);
409 template std::optional<Expr<SomeType>> NumericOperation<Subtract>(
410 parser::ContextualMessages &, Expr<SomeType> &&, Expr<SomeType> &&,
411 int defaultRealKind);
412
Negation(parser::ContextualMessages & messages,Expr<SomeType> && x)413 std::optional<Expr<SomeType>> Negation(
414 parser::ContextualMessages &messages, Expr<SomeType> &&x) {
415 return std::visit(
416 common::visitors{
417 [&](BOZLiteralConstant &&) {
418 messages.Say("BOZ literal cannot be negated"_err_en_US);
419 return NoExpr();
420 },
421 [&](NullPointer &&) {
422 messages.Say("NULL() cannot be negated"_err_en_US);
423 return NoExpr();
424 },
425 [&](ProcedureDesignator &&) {
426 messages.Say("Subroutine cannot be negated"_err_en_US);
427 return NoExpr();
428 },
429 [&](ProcedureRef &&) {
430 messages.Say("Pointer to subroutine cannot be negated"_err_en_US);
431 return NoExpr();
432 },
433 [&](Expr<SomeInteger> &&x) { return Package(-std::move(x)); },
434 [&](Expr<SomeReal> &&x) { return Package(-std::move(x)); },
435 [&](Expr<SomeComplex> &&x) { return Package(-std::move(x)); },
436 [&](Expr<SomeCharacter> &&) {
437 // TODO: defined operator
438 messages.Say("CHARACTER cannot be negated"_err_en_US);
439 return NoExpr();
440 },
441 [&](Expr<SomeLogical> &&) {
442 // TODO: defined operator
443 messages.Say("LOGICAL cannot be negated"_err_en_US);
444 return NoExpr();
445 },
446 [&](Expr<SomeDerived> &&) {
447 // TODO: defined operator
448 messages.Say("Operand cannot be negated"_err_en_US);
449 return NoExpr();
450 },
451 },
452 std::move(x.u));
453 }
454
LogicalNegation(Expr<SomeLogical> && x)455 Expr<SomeLogical> LogicalNegation(Expr<SomeLogical> &&x) {
456 return std::visit(
457 [](auto &&xk) { return AsCategoryExpr(LogicalNegation(std::move(xk))); },
458 std::move(x.u));
459 }
460
461 template <typename T>
PackageRelation(RelationalOperator opr,Expr<T> && x,Expr<T> && y)462 Expr<LogicalResult> PackageRelation(
463 RelationalOperator opr, Expr<T> &&x, Expr<T> &&y) {
464 static_assert(IsSpecificIntrinsicType<T>);
465 return Expr<LogicalResult>{
466 Relational<SomeType>{Relational<T>{opr, std::move(x), std::move(y)}}};
467 }
468
469 template <TypeCategory CAT>
PromoteAndRelate(RelationalOperator opr,Expr<SomeKind<CAT>> && x,Expr<SomeKind<CAT>> && y)470 Expr<LogicalResult> PromoteAndRelate(
471 RelationalOperator opr, Expr<SomeKind<CAT>> &&x, Expr<SomeKind<CAT>> &&y) {
472 return std::visit(
473 [=](auto &&xy) {
474 return PackageRelation(opr, std::move(xy[0]), std::move(xy[1]));
475 },
476 AsSameKindExprs(std::move(x), std::move(y)));
477 }
478
Relate(parser::ContextualMessages & messages,RelationalOperator opr,Expr<SomeType> && x,Expr<SomeType> && y)479 std::optional<Expr<LogicalResult>> Relate(parser::ContextualMessages &messages,
480 RelationalOperator opr, Expr<SomeType> &&x, Expr<SomeType> &&y) {
481 return std::visit(
482 common::visitors{
483 [=](Expr<SomeInteger> &&ix,
484 Expr<SomeInteger> &&iy) -> std::optional<Expr<LogicalResult>> {
485 return PromoteAndRelate(opr, std::move(ix), std::move(iy));
486 },
487 [=](Expr<SomeReal> &&rx,
488 Expr<SomeReal> &&ry) -> std::optional<Expr<LogicalResult>> {
489 return PromoteAndRelate(opr, std::move(rx), std::move(ry));
490 },
491 [&](Expr<SomeReal> &&rx, Expr<SomeInteger> &&iy) {
492 return Relate(messages, opr, std::move(x),
493 AsGenericExpr(ConvertTo(rx, std::move(iy))));
494 },
495 [&](Expr<SomeInteger> &&ix, Expr<SomeReal> &&ry) {
496 return Relate(messages, opr,
497 AsGenericExpr(ConvertTo(ry, std::move(ix))), std::move(y));
498 },
499 [&](Expr<SomeComplex> &&zx,
500 Expr<SomeComplex> &&zy) -> std::optional<Expr<LogicalResult>> {
501 if (opr == RelationalOperator::EQ ||
502 opr == RelationalOperator::NE) {
503 return PromoteAndRelate(opr, std::move(zx), std::move(zy));
504 } else {
505 messages.Say(
506 "COMPLEX data may be compared only for equality"_err_en_US);
507 return std::nullopt;
508 }
509 },
510 [&](Expr<SomeComplex> &&zx, Expr<SomeInteger> &&iy) {
511 return Relate(messages, opr, std::move(x),
512 AsGenericExpr(ConvertTo(zx, std::move(iy))));
513 },
514 [&](Expr<SomeComplex> &&zx, Expr<SomeReal> &&ry) {
515 return Relate(messages, opr, std::move(x),
516 AsGenericExpr(ConvertTo(zx, std::move(ry))));
517 },
518 [&](Expr<SomeInteger> &&ix, Expr<SomeComplex> &&zy) {
519 return Relate(messages, opr,
520 AsGenericExpr(ConvertTo(zy, std::move(ix))), std::move(y));
521 },
522 [&](Expr<SomeReal> &&rx, Expr<SomeComplex> &&zy) {
523 return Relate(messages, opr,
524 AsGenericExpr(ConvertTo(zy, std::move(rx))), std::move(y));
525 },
526 [&](Expr<SomeCharacter> &&cx, Expr<SomeCharacter> &&cy) {
527 return std::visit(
528 [&](auto &&cxk,
529 auto &&cyk) -> std::optional<Expr<LogicalResult>> {
530 using Ty = ResultType<decltype(cxk)>;
531 if constexpr (std::is_same_v<Ty, ResultType<decltype(cyk)>>) {
532 return PackageRelation(opr, std::move(cxk), std::move(cyk));
533 } else {
534 messages.Say(
535 "CHARACTER operands do not have same KIND"_err_en_US);
536 return std::nullopt;
537 }
538 },
539 std::move(cx.u), std::move(cy.u));
540 },
541 // Default case
542 [&](auto &&, auto &&) {
543 DIE("invalid types for relational operator");
544 return std::optional<Expr<LogicalResult>>{};
545 },
546 },
547 std::move(x.u), std::move(y.u));
548 }
549
BinaryLogicalOperation(LogicalOperator opr,Expr<SomeLogical> && x,Expr<SomeLogical> && y)550 Expr<SomeLogical> BinaryLogicalOperation(
551 LogicalOperator opr, Expr<SomeLogical> &&x, Expr<SomeLogical> &&y) {
552 CHECK(opr != LogicalOperator::Not);
553 return std::visit(
554 [=](auto &&xy) {
555 using Ty = ResultType<decltype(xy[0])>;
556 return Expr<SomeLogical>{BinaryLogicalOperation<Ty::kind>(
557 opr, std::move(xy[0]), std::move(xy[1]))};
558 },
559 AsSameKindExprs(std::move(x), std::move(y)));
560 }
561
562 template <TypeCategory TO>
ConvertToNumeric(int kind,Expr<SomeType> && x)563 std::optional<Expr<SomeType>> ConvertToNumeric(int kind, Expr<SomeType> &&x) {
564 static_assert(common::IsNumericTypeCategory(TO));
565 return std::visit(
566 [=](auto &&cx) -> std::optional<Expr<SomeType>> {
567 using cxType = std::decay_t<decltype(cx)>;
568 if constexpr (!common::HasMember<cxType, TypelessExpression>) {
569 if constexpr (IsNumericTypeCategory(ResultType<cxType>::category)) {
570 return Expr<SomeType>{ConvertToKind<TO>(kind, std::move(cx))};
571 }
572 }
573 return std::nullopt;
574 },
575 std::move(x.u));
576 }
577
ConvertToType(const DynamicType & type,Expr<SomeType> && x)578 std::optional<Expr<SomeType>> ConvertToType(
579 const DynamicType &type, Expr<SomeType> &&x) {
580 switch (type.category()) {
581 case TypeCategory::Integer:
582 if (auto *boz{std::get_if<BOZLiteralConstant>(&x.u)}) {
583 // Extension to C7109: allow BOZ literals to appear in integer contexts
584 // when the type is unambiguous.
585 return Expr<SomeType>{
586 ConvertToKind<TypeCategory::Integer>(type.kind(), std::move(*boz))};
587 }
588 return ConvertToNumeric<TypeCategory::Integer>(type.kind(), std::move(x));
589 case TypeCategory::Real:
590 if (auto *boz{std::get_if<BOZLiteralConstant>(&x.u)}) {
591 return Expr<SomeType>{
592 ConvertToKind<TypeCategory::Real>(type.kind(), std::move(*boz))};
593 }
594 return ConvertToNumeric<TypeCategory::Real>(type.kind(), std::move(x));
595 case TypeCategory::Complex:
596 return ConvertToNumeric<TypeCategory::Complex>(type.kind(), std::move(x));
597 case TypeCategory::Character:
598 if (auto *cx{UnwrapExpr<Expr<SomeCharacter>>(x)}) {
599 auto converted{
600 ConvertToKind<TypeCategory::Character>(type.kind(), std::move(*cx))};
601 if (type.charLength()) {
602 if (const auto &len{type.charLength()->GetExplicit()}) {
603 Expr<SomeInteger> lenParam{*len};
604 Expr<SubscriptInteger> length{Convert<SubscriptInteger>{lenParam}};
605 converted = std::visit(
606 [&](auto &&x) {
607 using Ty = std::decay_t<decltype(x)>;
608 using CharacterType = typename Ty::Result;
609 return Expr<SomeCharacter>{
610 Expr<CharacterType>{SetLength<CharacterType::kind>{
611 std::move(x), std::move(length)}}};
612 },
613 std::move(converted.u));
614 }
615 }
616 return Expr<SomeType>{std::move(converted)};
617 }
618 break;
619 case TypeCategory::Logical:
620 if (auto *cx{UnwrapExpr<Expr<SomeLogical>>(x)}) {
621 return Expr<SomeType>{
622 ConvertToKind<TypeCategory::Logical>(type.kind(), std::move(*cx))};
623 }
624 break;
625 case TypeCategory::Derived:
626 if (auto fromType{x.GetType()}) {
627 if (type == *fromType) {
628 return std::move(x);
629 }
630 }
631 break;
632 }
633 return std::nullopt;
634 }
635
ConvertToType(const DynamicType & to,std::optional<Expr<SomeType>> && x)636 std::optional<Expr<SomeType>> ConvertToType(
637 const DynamicType &to, std::optional<Expr<SomeType>> &&x) {
638 if (x) {
639 return ConvertToType(to, std::move(*x));
640 } else {
641 return std::nullopt;
642 }
643 }
644
ConvertToType(const Symbol & symbol,Expr<SomeType> && x)645 std::optional<Expr<SomeType>> ConvertToType(
646 const Symbol &symbol, Expr<SomeType> &&x) {
647 if (auto symType{DynamicType::From(symbol)}) {
648 return ConvertToType(*symType, std::move(x));
649 }
650 return std::nullopt;
651 }
652
ConvertToType(const Symbol & to,std::optional<Expr<SomeType>> && x)653 std::optional<Expr<SomeType>> ConvertToType(
654 const Symbol &to, std::optional<Expr<SomeType>> &&x) {
655 if (x) {
656 return ConvertToType(to, std::move(*x));
657 } else {
658 return std::nullopt;
659 }
660 }
661
IsAssumedRank(const Symbol & original)662 bool IsAssumedRank(const Symbol &original) {
663 const Symbol &symbol{semantics::ResolveAssociations(original)};
664 if (const auto *details{symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
665 return details->IsAssumedRank();
666 } else {
667 return false;
668 }
669 }
670
IsAssumedRank(const ActualArgument & arg)671 bool IsAssumedRank(const ActualArgument &arg) {
672 if (const auto *expr{arg.UnwrapExpr()}) {
673 return IsAssumedRank(*expr);
674 } else {
675 const Symbol *assumedTypeDummy{arg.GetAssumedTypeDummy()};
676 CHECK(assumedTypeDummy);
677 return IsAssumedRank(*assumedTypeDummy);
678 }
679 }
680
IsProcedure(const Expr<SomeType> & expr)681 bool IsProcedure(const Expr<SomeType> &expr) {
682 return std::holds_alternative<ProcedureDesignator>(expr.u);
683 }
IsFunction(const Expr<SomeType> & expr)684 bool IsFunction(const Expr<SomeType> &expr) {
685 const auto *designator{std::get_if<ProcedureDesignator>(&expr.u)};
686 return designator && designator->GetType().has_value();
687 }
688
IsProcedurePointer(const Expr<SomeType> & expr)689 bool IsProcedurePointer(const Expr<SomeType> &expr) {
690 return std::visit(common::visitors{
691 [](const NullPointer &) { return true; },
692 [](const ProcedureDesignator &) { return true; },
693 [](const ProcedureRef &) { return true; },
694 [](const auto &) { return false; },
695 },
696 expr.u);
697 }
698
UnwrapProcedureRef(const A &)699 template <typename A> inline const ProcedureRef *UnwrapProcedureRef(const A &) {
700 return nullptr;
701 }
702
703 template <typename T>
UnwrapProcedureRef(const FunctionRef<T> & func)704 inline const ProcedureRef *UnwrapProcedureRef(const FunctionRef<T> &func) {
705 return &func;
706 }
707
708 template <typename T>
UnwrapProcedureRef(const Expr<T> & expr)709 inline const ProcedureRef *UnwrapProcedureRef(const Expr<T> &expr) {
710 return std::visit(
711 [](const auto &x) { return UnwrapProcedureRef(x); }, expr.u);
712 }
713
714 // IsObjectPointer()
IsObjectPointer(const Expr<SomeType> & expr,FoldingContext & context)715 bool IsObjectPointer(const Expr<SomeType> &expr, FoldingContext &context) {
716 if (IsNullPointer(expr)) {
717 return true;
718 } else if (IsProcedurePointer(expr)) {
719 return false;
720 } else if (const auto *procRef{UnwrapProcedureRef(expr)}) {
721 auto proc{
722 characteristics::Procedure::Characterize(procRef->proc(), context)};
723 return proc && proc->functionResult &&
724 proc->functionResult->attrs.test(
725 characteristics::FunctionResult::Attr::Pointer);
726 } else if (const Symbol * symbol{GetLastSymbol(expr)}) {
727 return IsPointer(symbol->GetUltimate());
728 } else {
729 return false;
730 }
731 }
732
733 // IsNullPointer()
734 struct IsNullPointerHelper : public AllTraverse<IsNullPointerHelper, false> {
735 using Base = AllTraverse<IsNullPointerHelper, false>;
IsNullPointerHelperFortran::evaluate::IsNullPointerHelper736 IsNullPointerHelper() : Base(*this) {}
737 using Base::operator();
operator ()Fortran::evaluate::IsNullPointerHelper738 bool operator()(const ProcedureRef &call) const {
739 auto *intrinsic{call.proc().GetSpecificIntrinsic()};
740 return intrinsic &&
741 intrinsic->characteristics.value().attrs.test(
742 characteristics::Procedure::Attr::NullPointer);
743 }
operator ()Fortran::evaluate::IsNullPointerHelper744 bool operator()(const NullPointer &) const { return true; }
745 };
IsNullPointer(const Expr<SomeType> & expr)746 bool IsNullPointer(const Expr<SomeType> &expr) {
747 return IsNullPointerHelper{}(expr);
748 }
749
750 // GetSymbolVector()
operator ()(const Symbol & x) const751 auto GetSymbolVectorHelper::operator()(const Symbol &x) const -> Result {
752 if (const auto *details{x.detailsIf<semantics::AssocEntityDetails>()}) {
753 return (*this)(details->expr());
754 } else {
755 return {x.GetUltimate()};
756 }
757 }
operator ()(const Component & x) const758 auto GetSymbolVectorHelper::operator()(const Component &x) const -> Result {
759 Result result{(*this)(x.base())};
760 result.emplace_back(x.GetLastSymbol());
761 return result;
762 }
operator ()(const ArrayRef & x) const763 auto GetSymbolVectorHelper::operator()(const ArrayRef &x) const -> Result {
764 return GetSymbolVector(x.base());
765 }
operator ()(const CoarrayRef & x) const766 auto GetSymbolVectorHelper::operator()(const CoarrayRef &x) const -> Result {
767 return x.base();
768 }
769
GetLastTarget(const SymbolVector & symbols)770 const Symbol *GetLastTarget(const SymbolVector &symbols) {
771 auto end{std::crend(symbols)};
772 // N.B. Neither clang nor g++ recognizes "symbols.crbegin()" here.
773 auto iter{std::find_if(std::crbegin(symbols), end, [](const Symbol &x) {
774 return x.attrs().HasAny(
775 {semantics::Attr::POINTER, semantics::Attr::TARGET});
776 })};
777 return iter == end ? nullptr : &**iter;
778 }
779
780 struct CollectSymbolsHelper
781 : public SetTraverse<CollectSymbolsHelper, semantics::SymbolSet> {
782 using Base = SetTraverse<CollectSymbolsHelper, semantics::SymbolSet>;
CollectSymbolsHelperFortran::evaluate::CollectSymbolsHelper783 CollectSymbolsHelper() : Base{*this} {}
784 using Base::operator();
operator ()Fortran::evaluate::CollectSymbolsHelper785 semantics::SymbolSet operator()(const Symbol &symbol) const {
786 return {symbol};
787 }
788 };
CollectSymbols(const A & x)789 template <typename A> semantics::SymbolSet CollectSymbols(const A &x) {
790 return CollectSymbolsHelper{}(x);
791 }
792 template semantics::SymbolSet CollectSymbols(const Expr<SomeType> &);
793 template semantics::SymbolSet CollectSymbols(const Expr<SomeInteger> &);
794 template semantics::SymbolSet CollectSymbols(const Expr<SubscriptInteger> &);
795
796 // HasVectorSubscript()
797 struct HasVectorSubscriptHelper : public AnyTraverse<HasVectorSubscriptHelper> {
798 using Base = AnyTraverse<HasVectorSubscriptHelper>;
HasVectorSubscriptHelperFortran::evaluate::HasVectorSubscriptHelper799 HasVectorSubscriptHelper() : Base{*this} {}
800 using Base::operator();
operator ()Fortran::evaluate::HasVectorSubscriptHelper801 bool operator()(const Subscript &ss) const {
802 return !std::holds_alternative<Triplet>(ss.u) && ss.Rank() > 0;
803 }
operator ()Fortran::evaluate::HasVectorSubscriptHelper804 bool operator()(const ProcedureRef &) const {
805 return false; // don't descend into function call arguments
806 }
807 };
808
HasVectorSubscript(const Expr<SomeType> & expr)809 bool HasVectorSubscript(const Expr<SomeType> &expr) {
810 return HasVectorSubscriptHelper{}(expr);
811 }
812
AttachDeclaration(parser::Message & message,const Symbol & symbol)813 parser::Message *AttachDeclaration(
814 parser::Message &message, const Symbol &symbol) {
815 const Symbol *unhosted{&symbol};
816 while (
817 const auto *assoc{unhosted->detailsIf<semantics::HostAssocDetails>()}) {
818 unhosted = &assoc->symbol();
819 }
820 if (const auto *binding{
821 unhosted->detailsIf<semantics::ProcBindingDetails>()}) {
822 if (binding->symbol().name() != symbol.name()) {
823 message.Attach(binding->symbol().name(),
824 "Procedure '%s' of type '%s' is bound to '%s'"_en_US, symbol.name(),
825 symbol.owner().GetName().value(), binding->symbol().name());
826 return &message;
827 }
828 unhosted = &binding->symbol();
829 }
830 if (const auto *use{symbol.detailsIf<semantics::UseDetails>()}) {
831 message.Attach(use->location(),
832 "'%s' is USE-associated with '%s' in module '%s'"_en_US, symbol.name(),
833 unhosted->name(), GetUsedModule(*use).name());
834 } else {
835 message.Attach(
836 unhosted->name(), "Declaration of '%s'"_en_US, unhosted->name());
837 }
838 return &message;
839 }
840
AttachDeclaration(parser::Message * message,const Symbol & symbol)841 parser::Message *AttachDeclaration(
842 parser::Message *message, const Symbol &symbol) {
843 return message ? AttachDeclaration(*message, symbol) : nullptr;
844 }
845
846 class FindImpureCallHelper
847 : public AnyTraverse<FindImpureCallHelper, std::optional<std::string>> {
848 using Result = std::optional<std::string>;
849 using Base = AnyTraverse<FindImpureCallHelper, Result>;
850
851 public:
FindImpureCallHelper(FoldingContext & c)852 explicit FindImpureCallHelper(FoldingContext &c) : Base{*this}, context_{c} {}
853 using Base::operator();
operator ()(const ProcedureRef & call) const854 Result operator()(const ProcedureRef &call) const {
855 if (auto chars{
856 characteristics::Procedure::Characterize(call.proc(), context_)}) {
857 if (chars->attrs.test(characteristics::Procedure::Attr::Pure)) {
858 return (*this)(call.arguments());
859 }
860 }
861 return call.proc().GetName();
862 }
863
864 private:
865 FoldingContext &context_;
866 };
867
FindImpureCall(FoldingContext & context,const Expr<SomeType> & expr)868 std::optional<std::string> FindImpureCall(
869 FoldingContext &context, const Expr<SomeType> &expr) {
870 return FindImpureCallHelper{context}(expr);
871 }
FindImpureCall(FoldingContext & context,const ProcedureRef & proc)872 std::optional<std::string> FindImpureCall(
873 FoldingContext &context, const ProcedureRef &proc) {
874 return FindImpureCallHelper{context}(proc);
875 }
876
877 // Compare procedure characteristics for equality except that lhs may be
878 // Pure or Elemental when rhs is not.
CharacteristicsMatch(const characteristics::Procedure & lhs,const characteristics::Procedure & rhs)879 static bool CharacteristicsMatch(const characteristics::Procedure &lhs,
880 const characteristics::Procedure &rhs) {
881 using Attr = characteristics::Procedure::Attr;
882 auto lhsAttrs{rhs.attrs};
883 lhsAttrs.set(
884 Attr::Pure, lhs.attrs.test(Attr::Pure) | rhs.attrs.test(Attr::Pure));
885 lhsAttrs.set(Attr::Elemental,
886 lhs.attrs.test(Attr::Elemental) | rhs.attrs.test(Attr::Elemental));
887 return lhsAttrs == rhs.attrs && lhs.functionResult == rhs.functionResult &&
888 lhs.dummyArguments == rhs.dummyArguments;
889 }
890
891 // Common handling for procedure pointer compatibility of left- and right-hand
892 // sides. Returns nullopt if they're compatible. Otherwise, it returns a
893 // message that needs to be augmented by the names of the left and right sides
CheckProcCompatibility(bool isCall,const std::optional<characteristics::Procedure> & lhsProcedure,const characteristics::Procedure * rhsProcedure)894 std::optional<parser::MessageFixedText> CheckProcCompatibility(bool isCall,
895 const std::optional<characteristics::Procedure> &lhsProcedure,
896 const characteristics::Procedure *rhsProcedure) {
897 std::optional<parser::MessageFixedText> msg;
898 if (!lhsProcedure) {
899 msg = "In assignment to object %s, the target '%s' is a procedure"
900 " designator"_err_en_US;
901 } else if (!rhsProcedure) {
902 msg = "In assignment to procedure %s, the characteristics of the target"
903 " procedure '%s' could not be determined"_err_en_US;
904 } else if (CharacteristicsMatch(*lhsProcedure, *rhsProcedure)) {
905 // OK
906 } else if (isCall) {
907 msg = "Procedure %s associated with result of reference to function '%s'"
908 " that is an incompatible procedure pointer"_err_en_US;
909 } else if (lhsProcedure->IsPure() && !rhsProcedure->IsPure()) {
910 msg = "PURE procedure %s may not be associated with non-PURE"
911 " procedure designator '%s'"_err_en_US;
912 } else if (lhsProcedure->IsFunction() && !rhsProcedure->IsFunction()) {
913 msg = "Function %s may not be associated with subroutine"
914 " designator '%s'"_err_en_US;
915 } else if (!lhsProcedure->IsFunction() && rhsProcedure->IsFunction()) {
916 msg = "Subroutine %s may not be associated with function"
917 " designator '%s'"_err_en_US;
918 } else if (lhsProcedure->HasExplicitInterface() &&
919 !rhsProcedure->HasExplicitInterface()) {
920 msg = "Procedure %s with explicit interface may not be associated with"
921 " procedure designator '%s' with implicit interface"_err_en_US;
922 } else if (!lhsProcedure->HasExplicitInterface() &&
923 rhsProcedure->HasExplicitInterface()) {
924 msg = "Procedure %s with implicit interface may not be associated with"
925 " procedure designator '%s' with explicit interface"_err_en_US;
926 } else {
927 msg = "Procedure %s associated with incompatible procedure"
928 " designator '%s'"_err_en_US;
929 }
930 return msg;
931 }
932
933 // GetLastPointerSymbol()
GetLastPointerSymbol(const Symbol & symbol)934 static const Symbol *GetLastPointerSymbol(const Symbol &symbol) {
935 return IsPointer(GetAssociationRoot(symbol)) ? &symbol : nullptr;
936 }
GetLastPointerSymbol(const SymbolRef & symbol)937 static const Symbol *GetLastPointerSymbol(const SymbolRef &symbol) {
938 return GetLastPointerSymbol(*symbol);
939 }
GetLastPointerSymbol(const Component & x)940 static const Symbol *GetLastPointerSymbol(const Component &x) {
941 const Symbol &c{x.GetLastSymbol()};
942 return IsPointer(c) ? &c : GetLastPointerSymbol(x.base());
943 }
GetLastPointerSymbol(const NamedEntity & x)944 static const Symbol *GetLastPointerSymbol(const NamedEntity &x) {
945 const auto *c{x.UnwrapComponent()};
946 return c ? GetLastPointerSymbol(*c) : GetLastPointerSymbol(x.GetLastSymbol());
947 }
GetLastPointerSymbol(const ArrayRef & x)948 static const Symbol *GetLastPointerSymbol(const ArrayRef &x) {
949 return GetLastPointerSymbol(x.base());
950 }
GetLastPointerSymbol(const CoarrayRef & x)951 static const Symbol *GetLastPointerSymbol(const CoarrayRef &x) {
952 return nullptr;
953 }
GetLastPointerSymbol(const DataRef & x)954 const Symbol *GetLastPointerSymbol(const DataRef &x) {
955 return std::visit([](const auto &y) { return GetLastPointerSymbol(y); }, x.u);
956 }
957
958 } // namespace Fortran::evaluate
959
960 namespace Fortran::semantics {
961
ResolveAssociations(const Symbol & original)962 const Symbol &ResolveAssociations(const Symbol &original) {
963 const Symbol &symbol{original.GetUltimate()};
964 if (const auto *details{symbol.detailsIf<AssocEntityDetails>()}) {
965 if (const Symbol * nested{UnwrapWholeSymbolDataRef(details->expr())}) {
966 return ResolveAssociations(*nested);
967 }
968 }
969 return symbol;
970 }
971
972 // When a construct association maps to a variable, and that variable
973 // is not an array with a vector-valued subscript, return the base
974 // Symbol of that variable, else nullptr. Descends into other construct
975 // associations when one associations maps to another.
GetAssociatedVariable(const AssocEntityDetails & details)976 static const Symbol *GetAssociatedVariable(const AssocEntityDetails &details) {
977 if (const auto &expr{details.expr()}) {
978 if (IsVariable(*expr) && !HasVectorSubscript(*expr)) {
979 if (const Symbol * varSymbol{GetFirstSymbol(*expr)}) {
980 return &GetAssociationRoot(*varSymbol);
981 }
982 }
983 }
984 return nullptr;
985 }
986
GetAssociationRoot(const Symbol & original)987 const Symbol &GetAssociationRoot(const Symbol &original) {
988 const Symbol &symbol{ResolveAssociations(original)};
989 if (const auto *details{symbol.detailsIf<AssocEntityDetails>()}) {
990 if (const Symbol * root{GetAssociatedVariable(*details)}) {
991 return *root;
992 }
993 }
994 return symbol;
995 }
996
IsVariableName(const Symbol & original)997 bool IsVariableName(const Symbol &original) {
998 const Symbol &symbol{ResolveAssociations(original)};
999 if (symbol.has<ObjectEntityDetails>()) {
1000 return !IsNamedConstant(symbol);
1001 } else if (const auto *assoc{symbol.detailsIf<AssocEntityDetails>()}) {
1002 const auto &expr{assoc->expr()};
1003 return expr && IsVariable(*expr) && !HasVectorSubscript(*expr);
1004 } else {
1005 return false;
1006 }
1007 }
1008
IsPureProcedure(const Symbol & original)1009 bool IsPureProcedure(const Symbol &original) {
1010 const Symbol &symbol{original.GetUltimate()};
1011 if (const auto *procDetails{symbol.detailsIf<ProcEntityDetails>()}) {
1012 if (const Symbol * procInterface{procDetails->interface().symbol()}) {
1013 // procedure component with a pure interface
1014 return IsPureProcedure(*procInterface);
1015 }
1016 } else if (const auto *details{symbol.detailsIf<ProcBindingDetails>()}) {
1017 return IsPureProcedure(details->symbol());
1018 } else if (!IsProcedure(symbol)) {
1019 return false;
1020 }
1021 if (IsStmtFunction(symbol)) {
1022 // Section 15.7(1) states that a statement function is PURE if it does not
1023 // reference an IMPURE procedure or a VOLATILE variable
1024 if (const auto &expr{symbol.get<SubprogramDetails>().stmtFunction()}) {
1025 for (const SymbolRef &ref : evaluate::CollectSymbols(*expr)) {
1026 if (IsFunction(*ref) && !IsPureProcedure(*ref)) {
1027 return false;
1028 }
1029 if (ref->GetUltimate().attrs().test(Attr::VOLATILE)) {
1030 return false;
1031 }
1032 }
1033 }
1034 return true; // statement function was not found to be impure
1035 }
1036 return symbol.attrs().test(Attr::PURE) ||
1037 (symbol.attrs().test(Attr::ELEMENTAL) &&
1038 !symbol.attrs().test(Attr::IMPURE));
1039 }
1040
IsPureProcedure(const Scope & scope)1041 bool IsPureProcedure(const Scope &scope) {
1042 const Symbol *symbol{scope.GetSymbol()};
1043 return symbol && IsPureProcedure(*symbol);
1044 }
1045
IsFunction(const Symbol & symbol)1046 bool IsFunction(const Symbol &symbol) {
1047 return std::visit(
1048 common::visitors{
1049 [](const SubprogramDetails &x) { return x.isFunction(); },
1050 [&](const SubprogramNameDetails &) {
1051 return symbol.test(Symbol::Flag::Function);
1052 },
1053 [](const ProcEntityDetails &x) {
1054 const auto &ifc{x.interface()};
1055 return ifc.type() || (ifc.symbol() && IsFunction(*ifc.symbol()));
1056 },
1057 [](const ProcBindingDetails &x) { return IsFunction(x.symbol()); },
1058 [](const auto &) { return false; },
1059 },
1060 symbol.GetUltimate().details());
1061 }
1062
IsFunction(const Scope & scope)1063 bool IsFunction(const Scope &scope) {
1064 const Symbol *symbol{scope.GetSymbol()};
1065 return symbol && IsFunction(*symbol);
1066 }
1067
IsProcedure(const Symbol & symbol)1068 bool IsProcedure(const Symbol &symbol) {
1069 return std::visit(common::visitors{
1070 [](const SubprogramDetails &) { return true; },
1071 [](const SubprogramNameDetails &) { return true; },
1072 [](const ProcEntityDetails &) { return true; },
1073 [](const GenericDetails &) { return true; },
1074 [](const ProcBindingDetails &) { return true; },
1075 [](const auto &) { return false; },
1076 },
1077 symbol.GetUltimate().details());
1078 }
1079
IsProcedure(const Scope & scope)1080 bool IsProcedure(const Scope &scope) {
1081 const Symbol *symbol{scope.GetSymbol()};
1082 return symbol && IsProcedure(*symbol);
1083 }
1084
FindCommonBlockContaining(const Symbol & original)1085 const Symbol *FindCommonBlockContaining(const Symbol &original) {
1086 const Symbol &root{GetAssociationRoot(original)};
1087 const auto *details{root.detailsIf<ObjectEntityDetails>()};
1088 return details ? details->commonBlock() : nullptr;
1089 }
1090
IsProcedurePointer(const Symbol & original)1091 bool IsProcedurePointer(const Symbol &original) {
1092 const Symbol &symbol{original.GetUltimate()};
1093 return symbol.has<ProcEntityDetails>() && IsPointer(symbol);
1094 }
1095
IsSaved(const Symbol & original)1096 bool IsSaved(const Symbol &original) {
1097 const Symbol &symbol{GetAssociationRoot(original)};
1098 const Scope &scope{symbol.owner()};
1099 auto scopeKind{scope.kind()};
1100 if (symbol.has<AssocEntityDetails>()) {
1101 return false; // ASSOCIATE(non-variable)
1102 } else if (scopeKind == Scope::Kind::Module) {
1103 return true; // BLOCK DATA entities must all be in COMMON, handled below
1104 } else if (symbol.attrs().test(Attr::SAVE)) {
1105 return true;
1106 } else if (scopeKind == Scope::Kind::DerivedType) {
1107 return false; // this is a component
1108 } else if (IsNamedConstant(symbol)) {
1109 return false;
1110 } else if (const auto *object{symbol.detailsIf<ObjectEntityDetails>()};
1111 object && object->init()) {
1112 return true;
1113 } else if (IsProcedurePointer(symbol) &&
1114 symbol.get<ProcEntityDetails>().init()) {
1115 return true;
1116 } else if (const Symbol * block{FindCommonBlockContaining(symbol)};
1117 block && block->attrs().test(Attr::SAVE)) {
1118 return true;
1119 } else if (IsDummy(symbol) || IsFunctionResult(symbol)) {
1120 return false;
1121 } else {
1122 return scope.hasSAVE();
1123 }
1124 }
1125
IsDummy(const Symbol & symbol)1126 bool IsDummy(const Symbol &symbol) {
1127 return std::visit(
1128 common::visitors{[](const EntityDetails &x) { return x.isDummy(); },
1129 [](const ObjectEntityDetails &x) { return x.isDummy(); },
1130 [](const ProcEntityDetails &x) { return x.isDummy(); },
1131 [](const auto &) { return false; }},
1132 ResolveAssociations(symbol).details());
1133 }
1134
IsFunctionResult(const Symbol & original)1135 bool IsFunctionResult(const Symbol &original) {
1136 const Symbol &symbol{GetAssociationRoot(original)};
1137 return (symbol.has<ObjectEntityDetails>() &&
1138 symbol.get<ObjectEntityDetails>().isFuncResult()) ||
1139 (symbol.has<ProcEntityDetails>() &&
1140 symbol.get<ProcEntityDetails>().isFuncResult());
1141 }
1142
IsKindTypeParameter(const Symbol & symbol)1143 bool IsKindTypeParameter(const Symbol &symbol) {
1144 const auto *param{symbol.GetUltimate().detailsIf<TypeParamDetails>()};
1145 return param && param->attr() == common::TypeParamAttr::Kind;
1146 }
1147
IsLenTypeParameter(const Symbol & symbol)1148 bool IsLenTypeParameter(const Symbol &symbol) {
1149 const auto *param{symbol.GetUltimate().detailsIf<TypeParamDetails>()};
1150 return param && param->attr() == common::TypeParamAttr::Len;
1151 }
1152
CountLenParameters(const DerivedTypeSpec & type)1153 int CountLenParameters(const DerivedTypeSpec &type) {
1154 return std::count_if(type.parameters().begin(), type.parameters().end(),
1155 [](const auto &pair) { return pair.second.isLen(); });
1156 }
1157
CountNonConstantLenParameters(const DerivedTypeSpec & type)1158 int CountNonConstantLenParameters(const DerivedTypeSpec &type) {
1159 return std::count_if(
1160 type.parameters().begin(), type.parameters().end(), [](const auto &pair) {
1161 if (!pair.second.isLen()) {
1162 return false;
1163 } else if (const auto &expr{pair.second.GetExplicit()}) {
1164 return !IsConstantExpr(*expr);
1165 } else {
1166 return true;
1167 }
1168 });
1169 }
1170
GetUsedModule(const UseDetails & details)1171 const Symbol &GetUsedModule(const UseDetails &details) {
1172 return DEREF(details.symbol().owner().symbol());
1173 }
1174
1175 } // namespace Fortran::semantics
1176