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