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 
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 
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 
54 auto IsVariableHelper::operator()(const Symbol &symbol) const -> Result {
55   const Symbol &root{GetAssociationRoot(symbol)};
56   return !IsNamedConstant(root) && root.has<semantics::ObjectEntityDetails>();
57 }
58 auto IsVariableHelper::operator()(const Component &x) const -> Result {
59   const Symbol &comp{x.GetLastSymbol()};
60   return (*this)(comp) && (IsPointer(comp) || (*this)(x.base()));
61 }
62 auto IsVariableHelper::operator()(const ArrayRef &x) const -> Result {
63   return (*this)(x.base());
64 }
65 auto IsVariableHelper::operator()(const Substring &x) const -> Result {
66   return (*this)(x.GetBaseObject());
67 }
68 auto IsVariableHelper::operator()(const ProcedureDesignator &x) const
69     -> Result {
70   if (const Symbol * symbol{x.GetSymbol()}) {
71     const Symbol *result{FindFunctionResult(*symbol)};
72     return result && IsPointer(*result) && !IsProcedurePointer(*result);
73   }
74   return false;
75 }
76 
77 // Conversions of COMPLEX component expressions to REAL.
78 ConvertRealOperandsResult ConvertRealOperands(
79     parser::ContextualMessages &messages, Expr<SomeType> &&x,
80     Expr<SomeType> &&y, int defaultRealKind) {
81   return std::visit(
82       common::visitors{
83           [&](Expr<SomeInteger> &&ix,
84               Expr<SomeInteger> &&iy) -> ConvertRealOperandsResult {
85             // Can happen in a CMPLX() constructor.  Per F'2018,
86             // both integer operands are converted to default REAL.
87             return {AsSameKindExprs<TypeCategory::Real>(
88                 ConvertToKind<TypeCategory::Real>(
89                     defaultRealKind, std::move(ix)),
90                 ConvertToKind<TypeCategory::Real>(
91                     defaultRealKind, std::move(iy)))};
92           },
93           [&](Expr<SomeInteger> &&ix,
94               Expr<SomeReal> &&ry) -> ConvertRealOperandsResult {
95             return {AsSameKindExprs<TypeCategory::Real>(
96                 ConvertTo(ry, std::move(ix)), std::move(ry))};
97           },
98           [&](Expr<SomeReal> &&rx,
99               Expr<SomeInteger> &&iy) -> ConvertRealOperandsResult {
100             return {AsSameKindExprs<TypeCategory::Real>(
101                 std::move(rx), ConvertTo(rx, std::move(iy)))};
102           },
103           [&](Expr<SomeReal> &&rx,
104               Expr<SomeReal> &&ry) -> ConvertRealOperandsResult {
105             return {AsSameKindExprs<TypeCategory::Real>(
106                 std::move(rx), std::move(ry))};
107           },
108           [&](Expr<SomeInteger> &&ix,
109               BOZLiteralConstant &&by) -> ConvertRealOperandsResult {
110             return {AsSameKindExprs<TypeCategory::Real>(
111                 ConvertToKind<TypeCategory::Real>(
112                     defaultRealKind, std::move(ix)),
113                 ConvertToKind<TypeCategory::Real>(
114                     defaultRealKind, std::move(by)))};
115           },
116           [&](BOZLiteralConstant &&bx,
117               Expr<SomeInteger> &&iy) -> ConvertRealOperandsResult {
118             return {AsSameKindExprs<TypeCategory::Real>(
119                 ConvertToKind<TypeCategory::Real>(
120                     defaultRealKind, std::move(bx)),
121                 ConvertToKind<TypeCategory::Real>(
122                     defaultRealKind, std::move(iy)))};
123           },
124           [&](Expr<SomeReal> &&rx,
125               BOZLiteralConstant &&by) -> ConvertRealOperandsResult {
126             return {AsSameKindExprs<TypeCategory::Real>(
127                 std::move(rx), ConvertTo(rx, std::move(by)))};
128           },
129           [&](BOZLiteralConstant &&bx,
130               Expr<SomeReal> &&ry) -> ConvertRealOperandsResult {
131             return {AsSameKindExprs<TypeCategory::Real>(
132                 ConvertTo(ry, std::move(bx)), std::move(ry))};
133           },
134           [&](auto &&, auto &&) -> ConvertRealOperandsResult { // C718
135             messages.Say("operands must be INTEGER or REAL"_err_en_US);
136             return std::nullopt;
137           },
138       },
139       std::move(x.u), std::move(y.u));
140 }
141 
142 // Helpers for NumericOperation and its subroutines below.
143 static std::optional<Expr<SomeType>> NoExpr() { return std::nullopt; }
144 
145 template <TypeCategory CAT>
146 std::optional<Expr<SomeType>> Package(Expr<SomeKind<CAT>> &&catExpr) {
147   return {AsGenericExpr(std::move(catExpr))};
148 }
149 template <TypeCategory CAT>
150 std::optional<Expr<SomeType>> Package(
151     std::optional<Expr<SomeKind<CAT>>> &&catExpr) {
152   if (catExpr) {
153     return {AsGenericExpr(std::move(*catExpr))};
154   }
155   return NoExpr();
156 }
157 
158 // Mixed REAL+INTEGER operations.  REAL**INTEGER is a special case that
159 // does not require conversion of the exponent expression.
160 template <template <typename> class OPR>
161 std::optional<Expr<SomeType>> MixedRealLeft(
162     Expr<SomeReal> &&rx, Expr<SomeInteger> &&iy) {
163   return Package(std::visit(
164       [&](auto &&rxk) -> Expr<SomeReal> {
165         using resultType = ResultType<decltype(rxk)>;
166         if constexpr (std::is_same_v<OPR<resultType>, Power<resultType>>) {
167           return AsCategoryExpr(
168               RealToIntPower<resultType>{std::move(rxk), std::move(iy)});
169         }
170         // G++ 8.1.0 emits bogus warnings about missing return statements if
171         // this statement is wrapped in an "else", as it should be.
172         return AsCategoryExpr(OPR<resultType>{
173             std::move(rxk), ConvertToType<resultType>(std::move(iy))});
174       },
175       std::move(rx.u)));
176 }
177 
178 std::optional<Expr<SomeComplex>> ConstructComplex(
179     parser::ContextualMessages &messages, Expr<SomeType> &&real,
180     Expr<SomeType> &&imaginary, int defaultRealKind) {
181   if (auto converted{ConvertRealOperands(
182           messages, std::move(real), std::move(imaginary), defaultRealKind)}) {
183     return {std::visit(
184         [](auto &&pair) {
185           return MakeComplex(std::move(pair[0]), std::move(pair[1]));
186         },
187         std::move(*converted))};
188   }
189   return std::nullopt;
190 }
191 
192 std::optional<Expr<SomeComplex>> ConstructComplex(
193     parser::ContextualMessages &messages, std::optional<Expr<SomeType>> &&real,
194     std::optional<Expr<SomeType>> &&imaginary, int defaultRealKind) {
195   if (auto parts{common::AllPresent(std::move(real), std::move(imaginary))}) {
196     return ConstructComplex(messages, std::get<0>(std::move(*parts)),
197         std::get<1>(std::move(*parts)), defaultRealKind);
198   }
199   return std::nullopt;
200 }
201 
202 Expr<SomeReal> GetComplexPart(const Expr<SomeComplex> &z, bool isImaginary) {
203   return std::visit(
204       [&](const auto &zk) {
205         static constexpr int kind{ResultType<decltype(zk)>::kind};
206         return AsCategoryExpr(ComplexComponent<kind>{isImaginary, zk});
207       },
208       z.u);
209 }
210 
211 // Convert REAL to COMPLEX of the same kind. Preserving the real operand kind
212 // and then applying complex operand promotion rules allows the result to have
213 // the highest precision of REAL and COMPLEX operands as required by Fortran
214 // 2018 10.9.1.3.
215 Expr<SomeComplex> PromoteRealToComplex(Expr<SomeReal> &&someX) {
216   return std::visit(
217       [](auto &&x) {
218         using RT = ResultType<decltype(x)>;
219         return AsCategoryExpr(ComplexConstructor<RT::kind>{
220             std::move(x), AsExpr(Constant<RT>{Scalar<RT>{}})});
221       },
222       std::move(someX.u));
223 }
224 
225 // Handle mixed COMPLEX+REAL (or INTEGER) operations in a better way
226 // than just converting the second operand to COMPLEX and performing the
227 // corresponding COMPLEX+COMPLEX operation.
228 template <template <typename> class OPR, TypeCategory RCAT>
229 std::optional<Expr<SomeType>> MixedComplexLeft(
230     parser::ContextualMessages &messages, Expr<SomeComplex> &&zx,
231     Expr<SomeKind<RCAT>> &&iry, int defaultRealKind) {
232   Expr<SomeReal> zr{GetComplexPart(zx, false)};
233   Expr<SomeReal> zi{GetComplexPart(zx, true)};
234   if constexpr (std::is_same_v<OPR<LargestReal>, Add<LargestReal>> ||
235       std::is_same_v<OPR<LargestReal>, Subtract<LargestReal>>) {
236     // (a,b) + x -> (a+x, b)
237     // (a,b) - x -> (a-x, b)
238     if (std::optional<Expr<SomeType>> rr{
239             NumericOperation<OPR>(messages, AsGenericExpr(std::move(zr)),
240                 AsGenericExpr(std::move(iry)), defaultRealKind)}) {
241       return Package(ConstructComplex(messages, std::move(*rr),
242           AsGenericExpr(std::move(zi)), defaultRealKind));
243     }
244   } else if constexpr (std::is_same_v<OPR<LargestReal>,
245                            Multiply<LargestReal>> ||
246       std::is_same_v<OPR<LargestReal>, Divide<LargestReal>>) {
247     // (a,b) * x -> (a*x, b*x)
248     // (a,b) / x -> (a/x, b/x)
249     auto copy{iry};
250     auto rr{NumericOperation<OPR>(messages, AsGenericExpr(std::move(zr)),
251         AsGenericExpr(std::move(iry)), defaultRealKind)};
252     auto ri{NumericOperation<OPR>(messages, AsGenericExpr(std::move(zi)),
253         AsGenericExpr(std::move(copy)), defaultRealKind)};
254     if (auto parts{common::AllPresent(std::move(rr), std::move(ri))}) {
255       return Package(ConstructComplex(messages, std::get<0>(std::move(*parts)),
256           std::get<1>(std::move(*parts)), defaultRealKind));
257     }
258   } else if constexpr (RCAT == TypeCategory::Integer &&
259       std::is_same_v<OPR<LargestReal>, Power<LargestReal>>) {
260     // COMPLEX**INTEGER is a special case that doesn't convert the exponent.
261     static_assert(RCAT == TypeCategory::Integer);
262     return Package(std::visit(
263         [&](auto &&zxk) {
264           using Ty = ResultType<decltype(zxk)>;
265           return AsCategoryExpr(
266               AsExpr(RealToIntPower<Ty>{std::move(zxk), std::move(iry)}));
267         },
268         std::move(zx.u)));
269   } else if (defaultRealKind != 666) { // dodge unused parameter warning
270     // (a,b) ** x -> (a,b) ** (x,0)
271     if constexpr (RCAT == TypeCategory::Integer) {
272       Expr<SomeComplex> zy{ConvertTo(zx, std::move(iry))};
273       return Package(PromoteAndCombine<OPR>(std::move(zx), std::move(zy)));
274     } else {
275       Expr<SomeComplex> zy{PromoteRealToComplex(std::move(iry))};
276       return Package(PromoteAndCombine<OPR>(std::move(zx), std::move(zy)));
277     }
278   }
279   return NoExpr();
280 }
281 
282 // Mixed COMPLEX operations with the COMPLEX operand on the right.
283 //  x + (a,b) -> (x+a, b)
284 //  x - (a,b) -> (x-a, -b)
285 //  x * (a,b) -> (x*a, x*b)
286 //  x / (a,b) -> (x,0) / (a,b)   (and **)
287 template <template <typename> class OPR, TypeCategory LCAT>
288 std::optional<Expr<SomeType>> MixedComplexRight(
289     parser::ContextualMessages &messages, Expr<SomeKind<LCAT>> &&irx,
290     Expr<SomeComplex> &&zy, int defaultRealKind) {
291   if constexpr (std::is_same_v<OPR<LargestReal>, Add<LargestReal>> ||
292       std::is_same_v<OPR<LargestReal>, Multiply<LargestReal>>) {
293     // x + (a,b) -> (a,b) + x -> (a+x, b)
294     // x * (a,b) -> (a,b) * x -> (a*x, b*x)
295     return MixedComplexLeft<OPR, LCAT>(
296         messages, std::move(zy), std::move(irx), defaultRealKind);
297   } else if constexpr (std::is_same_v<OPR<LargestReal>,
298                            Subtract<LargestReal>>) {
299     // x - (a,b) -> (x-a, -b)
300     Expr<SomeReal> zr{GetComplexPart(zy, false)};
301     Expr<SomeReal> zi{GetComplexPart(zy, true)};
302     if (std::optional<Expr<SomeType>> rr{
303             NumericOperation<Subtract>(messages, AsGenericExpr(std::move(irx)),
304                 AsGenericExpr(std::move(zr)), defaultRealKind)}) {
305       return Package(ConstructComplex(messages, std::move(*rr),
306           AsGenericExpr(-std::move(zi)), defaultRealKind));
307     }
308   } else if (defaultRealKind != 666) { // dodge unused parameter warning
309     // x / (a,b) -> (x,0) / (a,b)
310     if constexpr (LCAT == TypeCategory::Integer) {
311       Expr<SomeComplex> zx{ConvertTo(zy, std::move(irx))};
312       return Package(PromoteAndCombine<OPR>(std::move(zx), std::move(zy)));
313     } else {
314       Expr<SomeComplex> zx{PromoteRealToComplex(std::move(irx))};
315       return Package(PromoteAndCombine<OPR>(std::move(zx), std::move(zy)));
316     }
317   }
318   return NoExpr();
319 }
320 
321 // N.B. When a "typeless" BOZ literal constant appears as one (not both!) of
322 // the operands to a dyadic operation where one is permitted, it assumes the
323 // type and kind of the other operand.
324 template <template <typename> class OPR>
325 std::optional<Expr<SomeType>> NumericOperation(
326     parser::ContextualMessages &messages, Expr<SomeType> &&x,
327     Expr<SomeType> &&y, int defaultRealKind) {
328   return std::visit(
329       common::visitors{
330           [](Expr<SomeInteger> &&ix, Expr<SomeInteger> &&iy) {
331             return Package(PromoteAndCombine<OPR, TypeCategory::Integer>(
332                 std::move(ix), std::move(iy)));
333           },
334           [](Expr<SomeReal> &&rx, Expr<SomeReal> &&ry) {
335             return Package(PromoteAndCombine<OPR, TypeCategory::Real>(
336                 std::move(rx), std::move(ry)));
337           },
338           // Mixed REAL/INTEGER operations
339           [](Expr<SomeReal> &&rx, Expr<SomeInteger> &&iy) {
340             return MixedRealLeft<OPR>(std::move(rx), std::move(iy));
341           },
342           [](Expr<SomeInteger> &&ix, Expr<SomeReal> &&ry) {
343             return Package(std::visit(
344                 [&](auto &&ryk) -> Expr<SomeReal> {
345                   using resultType = ResultType<decltype(ryk)>;
346                   return AsCategoryExpr(
347                       OPR<resultType>{ConvertToType<resultType>(std::move(ix)),
348                           std::move(ryk)});
349                 },
350                 std::move(ry.u)));
351           },
352           // Homogeneous and mixed COMPLEX operations
353           [](Expr<SomeComplex> &&zx, Expr<SomeComplex> &&zy) {
354             return Package(PromoteAndCombine<OPR, TypeCategory::Complex>(
355                 std::move(zx), std::move(zy)));
356           },
357           [&](Expr<SomeComplex> &&zx, Expr<SomeInteger> &&iy) {
358             return MixedComplexLeft<OPR>(
359                 messages, std::move(zx), std::move(iy), defaultRealKind);
360           },
361           [&](Expr<SomeComplex> &&zx, Expr<SomeReal> &&ry) {
362             return MixedComplexLeft<OPR>(
363                 messages, std::move(zx), std::move(ry), defaultRealKind);
364           },
365           [&](Expr<SomeInteger> &&ix, Expr<SomeComplex> &&zy) {
366             return MixedComplexRight<OPR>(
367                 messages, std::move(ix), std::move(zy), defaultRealKind);
368           },
369           [&](Expr<SomeReal> &&rx, Expr<SomeComplex> &&zy) {
370             return MixedComplexRight<OPR>(
371                 messages, std::move(rx), std::move(zy), defaultRealKind);
372           },
373           // Operations with one typeless operand
374           [&](BOZLiteralConstant &&bx, Expr<SomeInteger> &&iy) {
375             return NumericOperation<OPR>(messages,
376                 AsGenericExpr(ConvertTo(iy, std::move(bx))), std::move(y),
377                 defaultRealKind);
378           },
379           [&](BOZLiteralConstant &&bx, Expr<SomeReal> &&ry) {
380             return NumericOperation<OPR>(messages,
381                 AsGenericExpr(ConvertTo(ry, std::move(bx))), std::move(y),
382                 defaultRealKind);
383           },
384           [&](Expr<SomeInteger> &&ix, BOZLiteralConstant &&by) {
385             return NumericOperation<OPR>(messages, std::move(x),
386                 AsGenericExpr(ConvertTo(ix, std::move(by))), defaultRealKind);
387           },
388           [&](Expr<SomeReal> &&rx, BOZLiteralConstant &&by) {
389             return NumericOperation<OPR>(messages, std::move(x),
390                 AsGenericExpr(ConvertTo(rx, std::move(by))), defaultRealKind);
391           },
392           // Default case
393           [&](auto &&, auto &&) {
394             // TODO: defined operator
395             messages.Say("non-numeric operands to numeric operation"_err_en_US);
396             return NoExpr();
397           },
398       },
399       std::move(x.u), std::move(y.u));
400 }
401 
402 template std::optional<Expr<SomeType>> NumericOperation<Power>(
403     parser::ContextualMessages &, Expr<SomeType> &&, Expr<SomeType> &&,
404     int defaultRealKind);
405 template std::optional<Expr<SomeType>> NumericOperation<Multiply>(
406     parser::ContextualMessages &, Expr<SomeType> &&, Expr<SomeType> &&,
407     int defaultRealKind);
408 template std::optional<Expr<SomeType>> NumericOperation<Divide>(
409     parser::ContextualMessages &, Expr<SomeType> &&, Expr<SomeType> &&,
410     int defaultRealKind);
411 template std::optional<Expr<SomeType>> NumericOperation<Add>(
412     parser::ContextualMessages &, Expr<SomeType> &&, Expr<SomeType> &&,
413     int defaultRealKind);
414 template std::optional<Expr<SomeType>> NumericOperation<Subtract>(
415     parser::ContextualMessages &, Expr<SomeType> &&, Expr<SomeType> &&,
416     int defaultRealKind);
417 
418 std::optional<Expr<SomeType>> Negation(
419     parser::ContextualMessages &messages, Expr<SomeType> &&x) {
420   return std::visit(
421       common::visitors{
422           [&](BOZLiteralConstant &&) {
423             messages.Say("BOZ literal cannot be negated"_err_en_US);
424             return NoExpr();
425           },
426           [&](NullPointer &&) {
427             messages.Say("NULL() cannot be negated"_err_en_US);
428             return NoExpr();
429           },
430           [&](ProcedureDesignator &&) {
431             messages.Say("Subroutine cannot be negated"_err_en_US);
432             return NoExpr();
433           },
434           [&](ProcedureRef &&) {
435             messages.Say("Pointer to subroutine cannot be negated"_err_en_US);
436             return NoExpr();
437           },
438           [&](Expr<SomeInteger> &&x) { return Package(-std::move(x)); },
439           [&](Expr<SomeReal> &&x) { return Package(-std::move(x)); },
440           [&](Expr<SomeComplex> &&x) { return Package(-std::move(x)); },
441           [&](Expr<SomeCharacter> &&) {
442             // TODO: defined operator
443             messages.Say("CHARACTER cannot be negated"_err_en_US);
444             return NoExpr();
445           },
446           [&](Expr<SomeLogical> &&) {
447             // TODO: defined operator
448             messages.Say("LOGICAL cannot be negated"_err_en_US);
449             return NoExpr();
450           },
451           [&](Expr<SomeDerived> &&) {
452             // TODO: defined operator
453             messages.Say("Operand cannot be negated"_err_en_US);
454             return NoExpr();
455           },
456       },
457       std::move(x.u));
458 }
459 
460 Expr<SomeLogical> LogicalNegation(Expr<SomeLogical> &&x) {
461   return std::visit(
462       [](auto &&xk) { return AsCategoryExpr(LogicalNegation(std::move(xk))); },
463       std::move(x.u));
464 }
465 
466 template <typename T>
467 Expr<LogicalResult> PackageRelation(
468     RelationalOperator opr, Expr<T> &&x, Expr<T> &&y) {
469   static_assert(IsSpecificIntrinsicType<T>);
470   return Expr<LogicalResult>{
471       Relational<SomeType>{Relational<T>{opr, std::move(x), std::move(y)}}};
472 }
473 
474 template <TypeCategory CAT>
475 Expr<LogicalResult> PromoteAndRelate(
476     RelationalOperator opr, Expr<SomeKind<CAT>> &&x, Expr<SomeKind<CAT>> &&y) {
477   return std::visit(
478       [=](auto &&xy) {
479         return PackageRelation(opr, std::move(xy[0]), std::move(xy[1]));
480       },
481       AsSameKindExprs(std::move(x), std::move(y)));
482 }
483 
484 std::optional<Expr<LogicalResult>> Relate(parser::ContextualMessages &messages,
485     RelationalOperator opr, Expr<SomeType> &&x, Expr<SomeType> &&y) {
486   return std::visit(
487       common::visitors{
488           [=](Expr<SomeInteger> &&ix,
489               Expr<SomeInteger> &&iy) -> std::optional<Expr<LogicalResult>> {
490             return PromoteAndRelate(opr, std::move(ix), std::move(iy));
491           },
492           [=](Expr<SomeReal> &&rx,
493               Expr<SomeReal> &&ry) -> std::optional<Expr<LogicalResult>> {
494             return PromoteAndRelate(opr, std::move(rx), std::move(ry));
495           },
496           [&](Expr<SomeReal> &&rx, Expr<SomeInteger> &&iy) {
497             return Relate(messages, opr, std::move(x),
498                 AsGenericExpr(ConvertTo(rx, std::move(iy))));
499           },
500           [&](Expr<SomeInteger> &&ix, Expr<SomeReal> &&ry) {
501             return Relate(messages, opr,
502                 AsGenericExpr(ConvertTo(ry, std::move(ix))), std::move(y));
503           },
504           [&](Expr<SomeComplex> &&zx,
505               Expr<SomeComplex> &&zy) -> std::optional<Expr<LogicalResult>> {
506             if (opr == RelationalOperator::EQ ||
507                 opr == RelationalOperator::NE) {
508               return PromoteAndRelate(opr, std::move(zx), std::move(zy));
509             } else {
510               messages.Say(
511                   "COMPLEX data may be compared only for equality"_err_en_US);
512               return std::nullopt;
513             }
514           },
515           [&](Expr<SomeComplex> &&zx, Expr<SomeInteger> &&iy) {
516             return Relate(messages, opr, std::move(x),
517                 AsGenericExpr(ConvertTo(zx, std::move(iy))));
518           },
519           [&](Expr<SomeComplex> &&zx, Expr<SomeReal> &&ry) {
520             return Relate(messages, opr, std::move(x),
521                 AsGenericExpr(ConvertTo(zx, std::move(ry))));
522           },
523           [&](Expr<SomeInteger> &&ix, Expr<SomeComplex> &&zy) {
524             return Relate(messages, opr,
525                 AsGenericExpr(ConvertTo(zy, std::move(ix))), std::move(y));
526           },
527           [&](Expr<SomeReal> &&rx, Expr<SomeComplex> &&zy) {
528             return Relate(messages, opr,
529                 AsGenericExpr(ConvertTo(zy, std::move(rx))), std::move(y));
530           },
531           [&](Expr<SomeCharacter> &&cx, Expr<SomeCharacter> &&cy) {
532             return std::visit(
533                 [&](auto &&cxk,
534                     auto &&cyk) -> std::optional<Expr<LogicalResult>> {
535                   using Ty = ResultType<decltype(cxk)>;
536                   if constexpr (std::is_same_v<Ty, ResultType<decltype(cyk)>>) {
537                     return PackageRelation(opr, std::move(cxk), std::move(cyk));
538                   } else {
539                     messages.Say(
540                         "CHARACTER operands do not have same KIND"_err_en_US);
541                     return std::nullopt;
542                   }
543                 },
544                 std::move(cx.u), std::move(cy.u));
545           },
546           // Default case
547           [&](auto &&, auto &&) {
548             DIE("invalid types for relational operator");
549             return std::optional<Expr<LogicalResult>>{};
550           },
551       },
552       std::move(x.u), std::move(y.u));
553 }
554 
555 Expr<SomeLogical> BinaryLogicalOperation(
556     LogicalOperator opr, Expr<SomeLogical> &&x, Expr<SomeLogical> &&y) {
557   CHECK(opr != LogicalOperator::Not);
558   return std::visit(
559       [=](auto &&xy) {
560         using Ty = ResultType<decltype(xy[0])>;
561         return Expr<SomeLogical>{BinaryLogicalOperation<Ty::kind>(
562             opr, std::move(xy[0]), std::move(xy[1]))};
563       },
564       AsSameKindExprs(std::move(x), std::move(y)));
565 }
566 
567 template <TypeCategory TO>
568 std::optional<Expr<SomeType>> ConvertToNumeric(int kind, Expr<SomeType> &&x) {
569   static_assert(common::IsNumericTypeCategory(TO));
570   return std::visit(
571       [=](auto &&cx) -> std::optional<Expr<SomeType>> {
572         using cxType = std::decay_t<decltype(cx)>;
573         if constexpr (!common::HasMember<cxType, TypelessExpression>) {
574           if constexpr (IsNumericTypeCategory(ResultType<cxType>::category)) {
575             return Expr<SomeType>{ConvertToKind<TO>(kind, std::move(cx))};
576           }
577         }
578         return std::nullopt;
579       },
580       std::move(x.u));
581 }
582 
583 std::optional<Expr<SomeType>> ConvertToType(
584     const DynamicType &type, Expr<SomeType> &&x) {
585   switch (type.category()) {
586   case TypeCategory::Integer:
587     if (auto *boz{std::get_if<BOZLiteralConstant>(&x.u)}) {
588       // Extension to C7109: allow BOZ literals to appear in integer contexts
589       // when the type is unambiguous.
590       return Expr<SomeType>{
591           ConvertToKind<TypeCategory::Integer>(type.kind(), std::move(*boz))};
592     }
593     return ConvertToNumeric<TypeCategory::Integer>(type.kind(), std::move(x));
594   case TypeCategory::Real:
595     if (auto *boz{std::get_if<BOZLiteralConstant>(&x.u)}) {
596       return Expr<SomeType>{
597           ConvertToKind<TypeCategory::Real>(type.kind(), std::move(*boz))};
598     }
599     return ConvertToNumeric<TypeCategory::Real>(type.kind(), std::move(x));
600   case TypeCategory::Complex:
601     return ConvertToNumeric<TypeCategory::Complex>(type.kind(), std::move(x));
602   case TypeCategory::Character:
603     if (auto *cx{UnwrapExpr<Expr<SomeCharacter>>(x)}) {
604       auto converted{
605           ConvertToKind<TypeCategory::Character>(type.kind(), std::move(*cx))};
606       if (type.charLength()) {
607         if (const auto &len{type.charLength()->GetExplicit()}) {
608           Expr<SomeInteger> lenParam{*len};
609           Expr<SubscriptInteger> length{Convert<SubscriptInteger>{lenParam}};
610           converted = std::visit(
611               [&](auto &&x) {
612                 using Ty = std::decay_t<decltype(x)>;
613                 using CharacterType = typename Ty::Result;
614                 return Expr<SomeCharacter>{
615                     Expr<CharacterType>{SetLength<CharacterType::kind>{
616                         std::move(x), std::move(length)}}};
617               },
618               std::move(converted.u));
619         }
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 
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 
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 
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 
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 
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 
686 bool IsProcedure(const Expr<SomeType> &expr) {
687   return std::holds_alternative<ProcedureDesignator>(expr.u);
688 }
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 
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 
707 template <typename A> inline const ProcedureRef *UnwrapProcedureRef(const A &) {
708   return nullptr;
709 }
710 
711 template <typename T>
712 inline const ProcedureRef *UnwrapProcedureRef(const FunctionRef<T> &func) {
713   return &func;
714 }
715 
716 template <typename T>
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()
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>;
740   IsNullPointerHelper() : Base(*this) {}
741   using Base::operator();
742   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   }
748   bool operator()(const NullPointer &) const { return true; }
749 };
750 bool IsNullPointer(const Expr<SomeType> &expr) {
751   return IsNullPointerHelper{}(expr);
752 }
753 
754 // GetSymbolVector()
755 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 }
762 auto GetSymbolVectorHelper::operator()(const Component &x) const -> Result {
763   Result result{(*this)(x.base())};
764   result.emplace_back(x.GetLastSymbol());
765   return result;
766 }
767 auto GetSymbolVectorHelper::operator()(const ArrayRef &x) const -> Result {
768   return GetSymbolVector(x.base());
769 }
770 auto GetSymbolVectorHelper::operator()(const CoarrayRef &x) const -> Result {
771   return x.base();
772 }
773 
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>;
787   CollectSymbolsHelper() : Base{*this} {}
788   using Base::operator();
789   semantics::UnorderedSymbolSet operator()(const Symbol &symbol) const {
790     return {symbol};
791   }
792 };
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>;
805   HasVectorSubscriptHelper() : Base{*this} {}
806   using Base::operator();
807   bool operator()(const Subscript &ss) const {
808     return !std::holds_alternative<Triplet>(ss.u) && ss.Rank() > 0;
809   }
810   bool operator()(const ProcedureRef &) const {
811     return false; // don't descend into function call arguments
812   }
813 };
814 
815 bool HasVectorSubscript(const Expr<SomeType> &expr) {
816   return HasVectorSubscriptHelper{}(expr);
817 }
818 
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 
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:
858   explicit FindImpureCallHelper(FoldingContext &c) : Base{*this}, context_{c} {}
859   using Base::operator();
860   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 
874 std::optional<std::string> FindImpureCall(
875     FoldingContext &context, const Expr<SomeType> &expr) {
876   return FindImpureCallHelper{context}(expr);
877 }
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.
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
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()
940 static const Symbol *GetLastPointerSymbol(const Symbol &symbol) {
941   return IsPointer(GetAssociationRoot(symbol)) ? &symbol : nullptr;
942 }
943 static const Symbol *GetLastPointerSymbol(const SymbolRef &symbol) {
944   return GetLastPointerSymbol(*symbol);
945 }
946 static const Symbol *GetLastPointerSymbol(const Component &x) {
947   const Symbol &c{x.GetLastSymbol()};
948   return IsPointer(c) ? &c : GetLastPointerSymbol(x.base());
949 }
950 static const Symbol *GetLastPointerSymbol(const NamedEntity &x) {
951   const auto *c{x.UnwrapComponent()};
952   return c ? GetLastPointerSymbol(*c) : GetLastPointerSymbol(x.GetLastSymbol());
953 }
954 static const Symbol *GetLastPointerSymbol(const ArrayRef &x) {
955   return GetLastPointerSymbol(x.base());
956 }
957 static const Symbol *GetLastPointerSymbol(const CoarrayRef &x) {
958   return nullptr;
959 }
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 
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.
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 
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 
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 
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 
1047 bool IsPureProcedure(const Scope &scope) {
1048   const Symbol *symbol{scope.GetSymbol()};
1049   return symbol && IsPureProcedure(*symbol);
1050 }
1051 
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 
1069 bool IsFunction(const Scope &scope) {
1070   const Symbol *symbol{scope.GetSymbol()};
1071   return symbol && IsFunction(*symbol);
1072 }
1073 
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 
1086 bool IsProcedure(const Scope &scope) {
1087   const Symbol *symbol{scope.GetSymbol()};
1088   return symbol && IsProcedure(*symbol);
1089 }
1090 
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 
1097 bool IsProcedurePointer(const Symbol &original) {
1098   const Symbol &symbol{GetAssociationRoot(original)};
1099   return symbol.has<ProcEntityDetails>() && IsPointer(symbol);
1100 }
1101 
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 (symbol.attrs().test(Attr::SAVE)) {
1111     return true;
1112   } else if (scopeKind == Scope::Kind::DerivedType) {
1113     return false; // this is a component
1114   } else if (IsNamedConstant(symbol)) {
1115     return false;
1116   } else if (const auto *object{symbol.detailsIf<ObjectEntityDetails>()};
1117              object && object->init()) {
1118     return true;
1119   } else if (IsProcedurePointer(symbol) &&
1120       symbol.get<ProcEntityDetails>().init()) {
1121     return true;
1122   } else if (const Symbol * block{FindCommonBlockContaining(symbol)};
1123              block && block->attrs().test(Attr::SAVE)) {
1124     return true;
1125   } else if (IsDummy(symbol) || IsFunctionResult(symbol)) {
1126     return false;
1127   } else {
1128     return scope.hasSAVE();
1129   }
1130 }
1131 
1132 bool IsDummy(const Symbol &symbol) {
1133   return std::visit(
1134       common::visitors{[](const EntityDetails &x) { return x.isDummy(); },
1135           [](const ObjectEntityDetails &x) { return x.isDummy(); },
1136           [](const ProcEntityDetails &x) { return x.isDummy(); },
1137           [](const auto &) { return false; }},
1138       ResolveAssociations(symbol).details());
1139 }
1140 
1141 bool IsFunctionResult(const Symbol &original) {
1142   const Symbol &symbol{GetAssociationRoot(original)};
1143   return (symbol.has<ObjectEntityDetails>() &&
1144              symbol.get<ObjectEntityDetails>().isFuncResult()) ||
1145       (symbol.has<ProcEntityDetails>() &&
1146           symbol.get<ProcEntityDetails>().isFuncResult());
1147 }
1148 
1149 bool IsKindTypeParameter(const Symbol &symbol) {
1150   const auto *param{symbol.GetUltimate().detailsIf<TypeParamDetails>()};
1151   return param && param->attr() == common::TypeParamAttr::Kind;
1152 }
1153 
1154 bool IsLenTypeParameter(const Symbol &symbol) {
1155   const auto *param{symbol.GetUltimate().detailsIf<TypeParamDetails>()};
1156   return param && param->attr() == common::TypeParamAttr::Len;
1157 }
1158 
1159 int CountLenParameters(const DerivedTypeSpec &type) {
1160   return std::count_if(type.parameters().begin(), type.parameters().end(),
1161       [](const auto &pair) { return pair.second.isLen(); });
1162 }
1163 
1164 int CountNonConstantLenParameters(const DerivedTypeSpec &type) {
1165   return std::count_if(
1166       type.parameters().begin(), type.parameters().end(), [](const auto &pair) {
1167         if (!pair.second.isLen()) {
1168           return false;
1169         } else if (const auto &expr{pair.second.GetExplicit()}) {
1170           return !IsConstantExpr(*expr);
1171         } else {
1172           return true;
1173         }
1174       });
1175 }
1176 
1177 const Symbol &GetUsedModule(const UseDetails &details) {
1178   return DEREF(details.symbol().owner().symbol());
1179 }
1180 
1181 static const Symbol *FindFunctionResult(
1182     const Symbol &original, UnorderedSymbolSet &seen) {
1183   const Symbol &root{GetAssociationRoot(original)};
1184   ;
1185   if (!seen.insert(root).second) {
1186     return nullptr; // don't loop
1187   }
1188   return std::visit(
1189       common::visitors{[](const SubprogramDetails &subp) {
1190                          return subp.isFunction() ? &subp.result() : nullptr;
1191                        },
1192           [&](const ProcEntityDetails &proc) {
1193             const Symbol *iface{proc.interface().symbol()};
1194             return iface ? FindFunctionResult(*iface, seen) : nullptr;
1195           },
1196           [&](const ProcBindingDetails &binding) {
1197             return FindFunctionResult(binding.symbol(), seen);
1198           },
1199           [](const auto &) -> const Symbol * { return nullptr; }},
1200       root.details());
1201 }
1202 
1203 const Symbol *FindFunctionResult(const Symbol &symbol) {
1204   UnorderedSymbolSet seen;
1205   return FindFunctionResult(symbol, seen);
1206 }
1207 
1208 // These are here in Evaluate/tools.cpp so that Evaluate can use
1209 // them; they cannot be defined in symbol.h due to the dependence
1210 // on Scope.
1211 
1212 bool SymbolSourcePositionCompare::operator()(
1213     const SymbolRef &x, const SymbolRef &y) const {
1214   return x->GetSemanticsContext().allCookedSources().Precedes(
1215       x->name(), y->name());
1216 }
1217 bool SymbolSourcePositionCompare::operator()(
1218     const MutableSymbolRef &x, const MutableSymbolRef &y) const {
1219   return x->GetSemanticsContext().allCookedSources().Precedes(
1220       x->name(), y->name());
1221 }
1222 
1223 SemanticsContext &Symbol::GetSemanticsContext() const {
1224   return DEREF(owner_).context();
1225 }
1226 
1227 } // namespace Fortran::semantics
1228