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 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 
30 std::optional<Expr<SomeType>> AsGenericExpr(const Symbol &symbol) {
31   return AsGenericExpr(DataRef{symbol});
32 }
33 
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 
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 
66 auto IsVariableHelper::operator()(const Symbol &symbol) const -> Result {
67   const Symbol &root{GetAssociationRoot(symbol)};
68   return !IsNamedConstant(root) && root.has<semantics::ObjectEntityDetails>();
69 }
70 auto IsVariableHelper::operator()(const Component &x) const -> Result {
71   const Symbol &comp{x.GetLastSymbol()};
72   return (*this)(comp) && (IsPointer(comp) || (*this)(x.base()));
73 }
74 auto IsVariableHelper::operator()(const ArrayRef &x) const -> Result {
75   return (*this)(x.base());
76 }
77 auto IsVariableHelper::operator()(const Substring &x) const -> Result {
78   return (*this)(x.GetBaseObject());
79 }
80 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.
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.
155 static std::optional<Expr<SomeType>> NoExpr() { return std::nullopt; }
156 
157 template <TypeCategory CAT>
158 std::optional<Expr<SomeType>> Package(Expr<SomeKind<CAT>> &&catExpr) {
159   return {AsGenericExpr(std::move(catExpr))};
160 }
161 template <TypeCategory CAT>
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>
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 
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 
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 
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.
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>
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>
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>
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 
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 
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 <typename T>
479 Expr<LogicalResult> PackageRelation(
480     RelationalOperator opr, Expr<T> &&x, Expr<T> &&y) {
481   static_assert(IsSpecificIntrinsicType<T>);
482   return Expr<LogicalResult>{
483       Relational<SomeType>{Relational<T>{opr, std::move(x), std::move(y)}}};
484 }
485 
486 template <TypeCategory CAT>
487 Expr<LogicalResult> PromoteAndRelate(
488     RelationalOperator opr, Expr<SomeKind<CAT>> &&x, Expr<SomeKind<CAT>> &&y) {
489   return std::visit(
490       [=](auto &&xy) {
491         return PackageRelation(opr, std::move(xy[0]), std::move(xy[1]));
492       },
493       AsSameKindExprs(std::move(x), std::move(y)));
494 }
495 
496 std::optional<Expr<LogicalResult>> Relate(parser::ContextualMessages &messages,
497     RelationalOperator opr, Expr<SomeType> &&x, Expr<SomeType> &&y) {
498   return std::visit(
499       common::visitors{
500           [=](Expr<SomeInteger> &&ix,
501               Expr<SomeInteger> &&iy) -> std::optional<Expr<LogicalResult>> {
502             return PromoteAndRelate(opr, std::move(ix), std::move(iy));
503           },
504           [=](Expr<SomeReal> &&rx,
505               Expr<SomeReal> &&ry) -> std::optional<Expr<LogicalResult>> {
506             return PromoteAndRelate(opr, std::move(rx), std::move(ry));
507           },
508           [&](Expr<SomeReal> &&rx, Expr<SomeInteger> &&iy) {
509             return Relate(messages, opr, std::move(x),
510                 AsGenericExpr(ConvertTo(rx, std::move(iy))));
511           },
512           [&](Expr<SomeInteger> &&ix, Expr<SomeReal> &&ry) {
513             return Relate(messages, opr,
514                 AsGenericExpr(ConvertTo(ry, std::move(ix))), std::move(y));
515           },
516           [&](Expr<SomeComplex> &&zx,
517               Expr<SomeComplex> &&zy) -> std::optional<Expr<LogicalResult>> {
518             if (opr == RelationalOperator::EQ ||
519                 opr == RelationalOperator::NE) {
520               return PromoteAndRelate(opr, std::move(zx), std::move(zy));
521             } else {
522               messages.Say(
523                   "COMPLEX data may be compared only for equality"_err_en_US);
524               return std::nullopt;
525             }
526           },
527           [&](Expr<SomeComplex> &&zx, Expr<SomeInteger> &&iy) {
528             return Relate(messages, opr, std::move(x),
529                 AsGenericExpr(ConvertTo(zx, std::move(iy))));
530           },
531           [&](Expr<SomeComplex> &&zx, Expr<SomeReal> &&ry) {
532             return Relate(messages, opr, std::move(x),
533                 AsGenericExpr(ConvertTo(zx, std::move(ry))));
534           },
535           [&](Expr<SomeInteger> &&ix, Expr<SomeComplex> &&zy) {
536             return Relate(messages, opr,
537                 AsGenericExpr(ConvertTo(zy, std::move(ix))), std::move(y));
538           },
539           [&](Expr<SomeReal> &&rx, Expr<SomeComplex> &&zy) {
540             return Relate(messages, opr,
541                 AsGenericExpr(ConvertTo(zy, std::move(rx))), std::move(y));
542           },
543           [&](Expr<SomeCharacter> &&cx, Expr<SomeCharacter> &&cy) {
544             return std::visit(
545                 [&](auto &&cxk,
546                     auto &&cyk) -> std::optional<Expr<LogicalResult>> {
547                   using Ty = ResultType<decltype(cxk)>;
548                   if constexpr (std::is_same_v<Ty, ResultType<decltype(cyk)>>) {
549                     return PackageRelation(opr, std::move(cxk), std::move(cyk));
550                   } else {
551                     messages.Say(
552                         "CHARACTER operands do not have same KIND"_err_en_US);
553                     return std::nullopt;
554                   }
555                 },
556                 std::move(cx.u), std::move(cy.u));
557           },
558           // Default case
559           [&](auto &&, auto &&) {
560             DIE("invalid types for relational operator");
561             return std::optional<Expr<LogicalResult>>{};
562           },
563       },
564       std::move(x.u), std::move(y.u));
565 }
566 
567 Expr<SomeLogical> BinaryLogicalOperation(
568     LogicalOperator opr, Expr<SomeLogical> &&x, Expr<SomeLogical> &&y) {
569   CHECK(opr != LogicalOperator::Not);
570   return std::visit(
571       [=](auto &&xy) {
572         using Ty = ResultType<decltype(xy[0])>;
573         return Expr<SomeLogical>{BinaryLogicalOperation<Ty::kind>(
574             opr, std::move(xy[0]), std::move(xy[1]))};
575       },
576       AsSameKindExprs(std::move(x), std::move(y)));
577 }
578 
579 template <TypeCategory TO>
580 std::optional<Expr<SomeType>> ConvertToNumeric(int kind, Expr<SomeType> &&x) {
581   static_assert(common::IsNumericTypeCategory(TO));
582   return std::visit(
583       [=](auto &&cx) -> std::optional<Expr<SomeType>> {
584         using cxType = std::decay_t<decltype(cx)>;
585         if constexpr (!common::HasMember<cxType, TypelessExpression>) {
586           if constexpr (IsNumericTypeCategory(ResultType<cxType>::category)) {
587             return Expr<SomeType>{ConvertToKind<TO>(kind, std::move(cx))};
588           }
589         }
590         return std::nullopt;
591       },
592       std::move(x.u));
593 }
594 
595 std::optional<Expr<SomeType>> ConvertToType(
596     const DynamicType &type, Expr<SomeType> &&x) {
597   switch (type.category()) {
598   case TypeCategory::Integer:
599     if (auto *boz{std::get_if<BOZLiteralConstant>(&x.u)}) {
600       // Extension to C7109: allow BOZ literals to appear in integer contexts
601       // when the type is unambiguous.
602       return Expr<SomeType>{
603           ConvertToKind<TypeCategory::Integer>(type.kind(), std::move(*boz))};
604     }
605     return ConvertToNumeric<TypeCategory::Integer>(type.kind(), std::move(x));
606   case TypeCategory::Real:
607     if (auto *boz{std::get_if<BOZLiteralConstant>(&x.u)}) {
608       return Expr<SomeType>{
609           ConvertToKind<TypeCategory::Real>(type.kind(), std::move(*boz))};
610     }
611     return ConvertToNumeric<TypeCategory::Real>(type.kind(), std::move(x));
612   case TypeCategory::Complex:
613     return ConvertToNumeric<TypeCategory::Complex>(type.kind(), std::move(x));
614   case TypeCategory::Character:
615     if (auto *cx{UnwrapExpr<Expr<SomeCharacter>>(x)}) {
616       auto converted{
617           ConvertToKind<TypeCategory::Character>(type.kind(), std::move(*cx))};
618       if (type.charLength()) {
619         if (const auto &len{type.charLength()->GetExplicit()}) {
620           Expr<SomeInteger> lenParam{*len};
621           Expr<SubscriptInteger> length{Convert<SubscriptInteger>{lenParam}};
622           converted = std::visit(
623               [&](auto &&x) {
624                 using Ty = std::decay_t<decltype(x)>;
625                 using CharacterType = typename Ty::Result;
626                 return Expr<SomeCharacter>{
627                     Expr<CharacterType>{SetLength<CharacterType::kind>{
628                         std::move(x), std::move(length)}}};
629               },
630               std::move(converted.u));
631         }
632       }
633       return Expr<SomeType>{std::move(converted)};
634     }
635     break;
636   case TypeCategory::Logical:
637     if (auto *cx{UnwrapExpr<Expr<SomeLogical>>(x)}) {
638       return Expr<SomeType>{
639           ConvertToKind<TypeCategory::Logical>(type.kind(), std::move(*cx))};
640     }
641     break;
642   case TypeCategory::Derived:
643     if (auto fromType{x.GetType()}) {
644       if (type == *fromType) {
645         return std::move(x);
646       }
647     }
648     break;
649   }
650   return std::nullopt;
651 }
652 
653 std::optional<Expr<SomeType>> ConvertToType(
654     const DynamicType &to, std::optional<Expr<SomeType>> &&x) {
655   if (x) {
656     return ConvertToType(to, std::move(*x));
657   } else {
658     return std::nullopt;
659   }
660 }
661 
662 std::optional<Expr<SomeType>> ConvertToType(
663     const Symbol &symbol, Expr<SomeType> &&x) {
664   if (auto symType{DynamicType::From(symbol)}) {
665     return ConvertToType(*symType, std::move(x));
666   }
667   return std::nullopt;
668 }
669 
670 std::optional<Expr<SomeType>> ConvertToType(
671     const Symbol &to, std::optional<Expr<SomeType>> &&x) {
672   if (x) {
673     return ConvertToType(to, std::move(*x));
674   } else {
675     return std::nullopt;
676   }
677 }
678 
679 bool IsAssumedRank(const Symbol &original) {
680   const Symbol &symbol{semantics::ResolveAssociations(original)};
681   if (const auto *details{symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
682     return details->IsAssumedRank();
683   } else {
684     return false;
685   }
686 }
687 
688 bool IsAssumedRank(const ActualArgument &arg) {
689   if (const auto *expr{arg.UnwrapExpr()}) {
690     return IsAssumedRank(*expr);
691   } else {
692     const Symbol *assumedTypeDummy{arg.GetAssumedTypeDummy()};
693     CHECK(assumedTypeDummy);
694     return IsAssumedRank(*assumedTypeDummy);
695   }
696 }
697 
698 bool IsProcedure(const Expr<SomeType> &expr) {
699   return std::holds_alternative<ProcedureDesignator>(expr.u);
700 }
701 bool IsFunction(const Expr<SomeType> &expr) {
702   const auto *designator{std::get_if<ProcedureDesignator>(&expr.u)};
703   return designator && designator->GetType().has_value();
704 }
705 
706 bool IsProcedurePointerTarget(const Expr<SomeType> &expr) {
707   return std::visit(common::visitors{
708                         [](const NullPointer &) { return true; },
709                         [](const ProcedureDesignator &) { return true; },
710                         [](const ProcedureRef &) { return true; },
711                         [&](const auto &) {
712                           const Symbol *last{GetLastSymbol(expr)};
713                           return last && IsProcedurePointer(*last);
714                         },
715                     },
716       expr.u);
717 }
718 
719 template <typename A> inline const ProcedureRef *UnwrapProcedureRef(const A &) {
720   return nullptr;
721 }
722 
723 template <typename T>
724 inline const ProcedureRef *UnwrapProcedureRef(const FunctionRef<T> &func) {
725   return &func;
726 }
727 
728 template <typename T>
729 inline const ProcedureRef *UnwrapProcedureRef(const Expr<T> &expr) {
730   return std::visit(
731       [](const auto &x) { return UnwrapProcedureRef(x); }, expr.u);
732 }
733 
734 // IsObjectPointer()
735 bool IsObjectPointer(const Expr<SomeType> &expr, FoldingContext &context) {
736   if (IsNullPointer(expr)) {
737     return true;
738   } else if (IsProcedurePointerTarget(expr)) {
739     return false;
740   } else if (const auto *funcRef{UnwrapProcedureRef(expr)}) {
741     return IsVariable(*funcRef);
742   } else if (const Symbol * symbol{GetLastSymbol(expr)}) {
743     return IsPointer(symbol->GetUltimate());
744   } else {
745     return false;
746   }
747 }
748 
749 // IsNullPointer()
750 struct IsNullPointerHelper : public AllTraverse<IsNullPointerHelper, false> {
751   using Base = AllTraverse<IsNullPointerHelper, false>;
752   IsNullPointerHelper() : Base(*this) {}
753   using Base::operator();
754   bool operator()(const ProcedureRef &call) const {
755     auto *intrinsic{call.proc().GetSpecificIntrinsic()};
756     return intrinsic &&
757         intrinsic->characteristics.value().attrs.test(
758             characteristics::Procedure::Attr::NullPointer);
759   }
760   bool operator()(const NullPointer &) const { return true; }
761 };
762 bool IsNullPointer(const Expr<SomeType> &expr) {
763   return IsNullPointerHelper{}(expr);
764 }
765 
766 // GetSymbolVector()
767 auto GetSymbolVectorHelper::operator()(const Symbol &x) const -> Result {
768   if (const auto *details{x.detailsIf<semantics::AssocEntityDetails>()}) {
769     return (*this)(details->expr());
770   } else {
771     return {x.GetUltimate()};
772   }
773 }
774 auto GetSymbolVectorHelper::operator()(const Component &x) const -> Result {
775   Result result{(*this)(x.base())};
776   result.emplace_back(x.GetLastSymbol());
777   return result;
778 }
779 auto GetSymbolVectorHelper::operator()(const ArrayRef &x) const -> Result {
780   return GetSymbolVector(x.base());
781 }
782 auto GetSymbolVectorHelper::operator()(const CoarrayRef &x) const -> Result {
783   return x.base();
784 }
785 
786 const Symbol *GetLastTarget(const SymbolVector &symbols) {
787   auto end{std::crend(symbols)};
788   // N.B. Neither clang nor g++ recognizes "symbols.crbegin()" here.
789   auto iter{std::find_if(std::crbegin(symbols), end, [](const Symbol &x) {
790     return x.attrs().HasAny(
791         {semantics::Attr::POINTER, semantics::Attr::TARGET});
792   })};
793   return iter == end ? nullptr : &**iter;
794 }
795 
796 struct CollectSymbolsHelper
797     : public SetTraverse<CollectSymbolsHelper, semantics::UnorderedSymbolSet> {
798   using Base = SetTraverse<CollectSymbolsHelper, semantics::UnorderedSymbolSet>;
799   CollectSymbolsHelper() : Base{*this} {}
800   using Base::operator();
801   semantics::UnorderedSymbolSet operator()(const Symbol &symbol) const {
802     return {symbol};
803   }
804 };
805 template <typename A> semantics::UnorderedSymbolSet CollectSymbols(const A &x) {
806   return CollectSymbolsHelper{}(x);
807 }
808 template semantics::UnorderedSymbolSet CollectSymbols(const Expr<SomeType> &);
809 template semantics::UnorderedSymbolSet CollectSymbols(
810     const Expr<SomeInteger> &);
811 template semantics::UnorderedSymbolSet CollectSymbols(
812     const Expr<SubscriptInteger> &);
813 
814 // HasVectorSubscript()
815 struct HasVectorSubscriptHelper : public AnyTraverse<HasVectorSubscriptHelper> {
816   using Base = AnyTraverse<HasVectorSubscriptHelper>;
817   HasVectorSubscriptHelper() : Base{*this} {}
818   using Base::operator();
819   bool operator()(const Subscript &ss) const {
820     return !std::holds_alternative<Triplet>(ss.u) && ss.Rank() > 0;
821   }
822   bool operator()(const ProcedureRef &) const {
823     return false; // don't descend into function call arguments
824   }
825 };
826 
827 bool HasVectorSubscript(const Expr<SomeType> &expr) {
828   return HasVectorSubscriptHelper{}(expr);
829 }
830 
831 parser::Message *AttachDeclaration(
832     parser::Message &message, const Symbol &symbol) {
833   const Symbol *unhosted{&symbol};
834   while (
835       const auto *assoc{unhosted->detailsIf<semantics::HostAssocDetails>()}) {
836     unhosted = &assoc->symbol();
837   }
838   if (const auto *binding{
839           unhosted->detailsIf<semantics::ProcBindingDetails>()}) {
840     if (binding->symbol().name() != symbol.name()) {
841       message.Attach(binding->symbol().name(),
842           "Procedure '%s' of type '%s' is bound to '%s'"_en_US, symbol.name(),
843           symbol.owner().GetName().value(), binding->symbol().name());
844       return &message;
845     }
846     unhosted = &binding->symbol();
847   }
848   if (const auto *use{symbol.detailsIf<semantics::UseDetails>()}) {
849     message.Attach(use->location(),
850         "'%s' is USE-associated with '%s' in module '%s'"_en_US, symbol.name(),
851         unhosted->name(), GetUsedModule(*use).name());
852   } else {
853     message.Attach(
854         unhosted->name(), "Declaration of '%s'"_en_US, unhosted->name());
855   }
856   return &message;
857 }
858 
859 parser::Message *AttachDeclaration(
860     parser::Message *message, const Symbol &symbol) {
861   return message ? AttachDeclaration(*message, symbol) : nullptr;
862 }
863 
864 class FindImpureCallHelper
865     : public AnyTraverse<FindImpureCallHelper, std::optional<std::string>> {
866   using Result = std::optional<std::string>;
867   using Base = AnyTraverse<FindImpureCallHelper, Result>;
868 
869 public:
870   explicit FindImpureCallHelper(FoldingContext &c) : Base{*this}, context_{c} {}
871   using Base::operator();
872   Result operator()(const ProcedureRef &call) const {
873     if (auto chars{
874             characteristics::Procedure::Characterize(call.proc(), context_)}) {
875       if (chars->attrs.test(characteristics::Procedure::Attr::Pure)) {
876         return (*this)(call.arguments());
877       }
878     }
879     return call.proc().GetName();
880   }
881 
882 private:
883   FoldingContext &context_;
884 };
885 
886 std::optional<std::string> FindImpureCall(
887     FoldingContext &context, const Expr<SomeType> &expr) {
888   return FindImpureCallHelper{context}(expr);
889 }
890 std::optional<std::string> FindImpureCall(
891     FoldingContext &context, const ProcedureRef &proc) {
892   return FindImpureCallHelper{context}(proc);
893 }
894 
895 // Compare procedure characteristics for equality except that lhs may be
896 // Pure or Elemental when rhs is not.
897 static bool CharacteristicsMatch(const characteristics::Procedure &lhs,
898     const characteristics::Procedure &rhs) {
899   using Attr = characteristics::Procedure::Attr;
900   auto lhsAttrs{rhs.attrs};
901   lhsAttrs.set(
902       Attr::Pure, lhs.attrs.test(Attr::Pure) | rhs.attrs.test(Attr::Pure));
903   lhsAttrs.set(Attr::Elemental,
904       lhs.attrs.test(Attr::Elemental) | rhs.attrs.test(Attr::Elemental));
905   return lhsAttrs == rhs.attrs && lhs.functionResult == rhs.functionResult &&
906       lhs.dummyArguments == rhs.dummyArguments;
907 }
908 
909 // Common handling for procedure pointer compatibility of left- and right-hand
910 // sides.  Returns nullopt if they're compatible.  Otherwise, it returns a
911 // message that needs to be augmented by the names of the left and right sides
912 std::optional<parser::MessageFixedText> CheckProcCompatibility(bool isCall,
913     const std::optional<characteristics::Procedure> &lhsProcedure,
914     const characteristics::Procedure *rhsProcedure) {
915   std::optional<parser::MessageFixedText> msg;
916   if (!lhsProcedure) {
917     msg = "In assignment to object %s, the target '%s' is a procedure"
918           " designator"_err_en_US;
919   } else if (!rhsProcedure) {
920     msg = "In assignment to procedure %s, the characteristics of the target"
921           " procedure '%s' could not be determined"_err_en_US;
922   } else if (CharacteristicsMatch(*lhsProcedure, *rhsProcedure)) {
923     // OK
924   } else if (isCall) {
925     msg = "Procedure %s associated with result of reference to function '%s'"
926           " that is an incompatible procedure pointer"_err_en_US;
927   } else if (lhsProcedure->IsPure() && !rhsProcedure->IsPure()) {
928     msg = "PURE procedure %s may not be associated with non-PURE"
929           " procedure designator '%s'"_err_en_US;
930   } else if (lhsProcedure->IsFunction() && !rhsProcedure->IsFunction()) {
931     msg = "Function %s may not be associated with subroutine"
932           " designator '%s'"_err_en_US;
933   } else if (!lhsProcedure->IsFunction() && rhsProcedure->IsFunction()) {
934     msg = "Subroutine %s may not be associated with function"
935           " designator '%s'"_err_en_US;
936   } else if (lhsProcedure->HasExplicitInterface() &&
937       !rhsProcedure->HasExplicitInterface()) {
938     msg = "Procedure %s with explicit interface may not be associated with"
939           " procedure designator '%s' with implicit interface"_err_en_US;
940   } else if (!lhsProcedure->HasExplicitInterface() &&
941       rhsProcedure->HasExplicitInterface()) {
942     msg = "Procedure %s with implicit interface may not be associated with"
943           " procedure designator '%s' with explicit interface"_err_en_US;
944   } else {
945     msg = "Procedure %s associated with incompatible procedure"
946           " designator '%s'"_err_en_US;
947   }
948   return msg;
949 }
950 
951 // GetLastPointerSymbol()
952 static const Symbol *GetLastPointerSymbol(const Symbol &symbol) {
953   return IsPointer(GetAssociationRoot(symbol)) ? &symbol : nullptr;
954 }
955 static const Symbol *GetLastPointerSymbol(const SymbolRef &symbol) {
956   return GetLastPointerSymbol(*symbol);
957 }
958 static const Symbol *GetLastPointerSymbol(const Component &x) {
959   const Symbol &c{x.GetLastSymbol()};
960   return IsPointer(c) ? &c : GetLastPointerSymbol(x.base());
961 }
962 static const Symbol *GetLastPointerSymbol(const NamedEntity &x) {
963   const auto *c{x.UnwrapComponent()};
964   return c ? GetLastPointerSymbol(*c) : GetLastPointerSymbol(x.GetLastSymbol());
965 }
966 static const Symbol *GetLastPointerSymbol(const ArrayRef &x) {
967   return GetLastPointerSymbol(x.base());
968 }
969 static const Symbol *GetLastPointerSymbol(const CoarrayRef &x) {
970   return nullptr;
971 }
972 const Symbol *GetLastPointerSymbol(const DataRef &x) {
973   return std::visit([](const auto &y) { return GetLastPointerSymbol(y); }, x.u);
974 }
975 
976 } // namespace Fortran::evaluate
977 
978 namespace Fortran::semantics {
979 
980 const Symbol &ResolveAssociations(const Symbol &original) {
981   const Symbol &symbol{original.GetUltimate()};
982   if (const auto *details{symbol.detailsIf<AssocEntityDetails>()}) {
983     if (const Symbol * nested{UnwrapWholeSymbolDataRef(details->expr())}) {
984       return ResolveAssociations(*nested);
985     }
986   }
987   return symbol;
988 }
989 
990 // When a construct association maps to a variable, and that variable
991 // is not an array with a vector-valued subscript, return the base
992 // Symbol of that variable, else nullptr.  Descends into other construct
993 // associations when one associations maps to another.
994 static const Symbol *GetAssociatedVariable(const AssocEntityDetails &details) {
995   if (const auto &expr{details.expr()}) {
996     if (IsVariable(*expr) && !HasVectorSubscript(*expr)) {
997       if (const Symbol * varSymbol{GetFirstSymbol(*expr)}) {
998         return &GetAssociationRoot(*varSymbol);
999       }
1000     }
1001   }
1002   return nullptr;
1003 }
1004 
1005 const Symbol &GetAssociationRoot(const Symbol &original) {
1006   const Symbol &symbol{ResolveAssociations(original)};
1007   if (const auto *details{symbol.detailsIf<AssocEntityDetails>()}) {
1008     if (const Symbol * root{GetAssociatedVariable(*details)}) {
1009       return *root;
1010     }
1011   }
1012   return symbol;
1013 }
1014 
1015 bool IsVariableName(const Symbol &original) {
1016   const Symbol &symbol{ResolveAssociations(original)};
1017   if (symbol.has<ObjectEntityDetails>()) {
1018     return !IsNamedConstant(symbol);
1019   } else if (const auto *assoc{symbol.detailsIf<AssocEntityDetails>()}) {
1020     const auto &expr{assoc->expr()};
1021     return expr && IsVariable(*expr) && !HasVectorSubscript(*expr);
1022   } else {
1023     return false;
1024   }
1025 }
1026 
1027 bool IsPureProcedure(const Symbol &original) {
1028   const Symbol &symbol{original.GetUltimate()};
1029   if (const auto *procDetails{symbol.detailsIf<ProcEntityDetails>()}) {
1030     if (const Symbol * procInterface{procDetails->interface().symbol()}) {
1031       // procedure component with a pure interface
1032       return IsPureProcedure(*procInterface);
1033     }
1034   } else if (const auto *details{symbol.detailsIf<ProcBindingDetails>()}) {
1035     return IsPureProcedure(details->symbol());
1036   } else if (!IsProcedure(symbol)) {
1037     return false;
1038   }
1039   if (IsStmtFunction(symbol)) {
1040     // Section 15.7(1) states that a statement function is PURE if it does not
1041     // reference an IMPURE procedure or a VOLATILE variable
1042     if (const auto &expr{symbol.get<SubprogramDetails>().stmtFunction()}) {
1043       for (const SymbolRef &ref : evaluate::CollectSymbols(*expr)) {
1044         if (IsFunction(*ref) && !IsPureProcedure(*ref)) {
1045           return false;
1046         }
1047         if (ref->GetUltimate().attrs().test(Attr::VOLATILE)) {
1048           return false;
1049         }
1050       }
1051     }
1052     return true; // statement function was not found to be impure
1053   }
1054   return symbol.attrs().test(Attr::PURE) ||
1055       (symbol.attrs().test(Attr::ELEMENTAL) &&
1056           !symbol.attrs().test(Attr::IMPURE));
1057 }
1058 
1059 bool IsPureProcedure(const Scope &scope) {
1060   const Symbol *symbol{scope.GetSymbol()};
1061   return symbol && IsPureProcedure(*symbol);
1062 }
1063 
1064 bool IsFunction(const Symbol &symbol) {
1065   return std::visit(
1066       common::visitors{
1067           [](const SubprogramDetails &x) { return x.isFunction(); },
1068           [&](const SubprogramNameDetails &) {
1069             return symbol.test(Symbol::Flag::Function);
1070           },
1071           [](const ProcEntityDetails &x) {
1072             const auto &ifc{x.interface()};
1073             return ifc.type() || (ifc.symbol() && IsFunction(*ifc.symbol()));
1074           },
1075           [](const ProcBindingDetails &x) { return IsFunction(x.symbol()); },
1076           [](const auto &) { return false; },
1077       },
1078       symbol.GetUltimate().details());
1079 }
1080 
1081 bool IsFunction(const Scope &scope) {
1082   const Symbol *symbol{scope.GetSymbol()};
1083   return symbol && IsFunction(*symbol);
1084 }
1085 
1086 bool IsProcedure(const Symbol &symbol) {
1087   return std::visit(common::visitors{
1088                         [](const SubprogramDetails &) { return true; },
1089                         [](const SubprogramNameDetails &) { return true; },
1090                         [](const ProcEntityDetails &) { return true; },
1091                         [](const GenericDetails &) { return true; },
1092                         [](const ProcBindingDetails &) { return true; },
1093                         [](const auto &) { return false; },
1094                     },
1095       symbol.GetUltimate().details());
1096 }
1097 
1098 bool IsProcedure(const Scope &scope) {
1099   const Symbol *symbol{scope.GetSymbol()};
1100   return symbol && IsProcedure(*symbol);
1101 }
1102 
1103 const Symbol *FindCommonBlockContaining(const Symbol &original) {
1104   const Symbol &root{GetAssociationRoot(original)};
1105   const auto *details{root.detailsIf<ObjectEntityDetails>()};
1106   return details ? details->commonBlock() : nullptr;
1107 }
1108 
1109 bool IsProcedurePointer(const Symbol &original) {
1110   const Symbol &symbol{GetAssociationRoot(original)};
1111   return symbol.has<ProcEntityDetails>() && IsPointer(symbol);
1112 }
1113 
1114 bool IsSaved(const Symbol &original) {
1115   const Symbol &symbol{GetAssociationRoot(original)};
1116   const Scope &scope{symbol.owner()};
1117   auto scopeKind{scope.kind()};
1118   if (symbol.has<AssocEntityDetails>()) {
1119     return false; // ASSOCIATE(non-variable)
1120   } else if (scopeKind == Scope::Kind::Module) {
1121     return true; // BLOCK DATA entities must all be in COMMON, handled below
1122   } else if (symbol.attrs().test(Attr::SAVE)) {
1123     return true;
1124   } else if (scopeKind == Scope::Kind::DerivedType) {
1125     return false; // this is a component
1126   } else if (IsNamedConstant(symbol)) {
1127     return false;
1128   } else if (const auto *object{symbol.detailsIf<ObjectEntityDetails>()};
1129              object && object->init()) {
1130     return true;
1131   } else if (IsProcedurePointer(symbol) &&
1132       symbol.get<ProcEntityDetails>().init()) {
1133     return true;
1134   } else if (const Symbol * block{FindCommonBlockContaining(symbol)};
1135              block && block->attrs().test(Attr::SAVE)) {
1136     return true;
1137   } else if (IsDummy(symbol) || IsFunctionResult(symbol)) {
1138     return false;
1139   } else {
1140     return scope.hasSAVE();
1141   }
1142 }
1143 
1144 bool IsDummy(const Symbol &symbol) {
1145   return std::visit(
1146       common::visitors{[](const EntityDetails &x) { return x.isDummy(); },
1147           [](const ObjectEntityDetails &x) { return x.isDummy(); },
1148           [](const ProcEntityDetails &x) { return x.isDummy(); },
1149           [](const auto &) { return false; }},
1150       ResolveAssociations(symbol).details());
1151 }
1152 
1153 bool IsFunctionResult(const Symbol &original) {
1154   const Symbol &symbol{GetAssociationRoot(original)};
1155   return (symbol.has<ObjectEntityDetails>() &&
1156              symbol.get<ObjectEntityDetails>().isFuncResult()) ||
1157       (symbol.has<ProcEntityDetails>() &&
1158           symbol.get<ProcEntityDetails>().isFuncResult());
1159 }
1160 
1161 bool IsKindTypeParameter(const Symbol &symbol) {
1162   const auto *param{symbol.GetUltimate().detailsIf<TypeParamDetails>()};
1163   return param && param->attr() == common::TypeParamAttr::Kind;
1164 }
1165 
1166 bool IsLenTypeParameter(const Symbol &symbol) {
1167   const auto *param{symbol.GetUltimate().detailsIf<TypeParamDetails>()};
1168   return param && param->attr() == common::TypeParamAttr::Len;
1169 }
1170 
1171 int CountLenParameters(const DerivedTypeSpec &type) {
1172   return std::count_if(type.parameters().begin(), type.parameters().end(),
1173       [](const auto &pair) { return pair.second.isLen(); });
1174 }
1175 
1176 int CountNonConstantLenParameters(const DerivedTypeSpec &type) {
1177   return std::count_if(
1178       type.parameters().begin(), type.parameters().end(), [](const auto &pair) {
1179         if (!pair.second.isLen()) {
1180           return false;
1181         } else if (const auto &expr{pair.second.GetExplicit()}) {
1182           return !IsConstantExpr(*expr);
1183         } else {
1184           return true;
1185         }
1186       });
1187 }
1188 
1189 // Are the type parameters of type1 compile-time compatible with the
1190 // corresponding kind type parameters of type2?  Return true if all constant
1191 // valued parameters are equal.
1192 // Used to check assignment statements and argument passing.  See 15.5.2.4(4)
1193 bool AreTypeParamCompatible(const semantics::DerivedTypeSpec &type1,
1194     const semantics::DerivedTypeSpec &type2) {
1195   for (const auto &[name, param1] : type1.parameters()) {
1196     if (semantics::MaybeIntExpr paramExpr1{param1.GetExplicit()}) {
1197       if (IsConstantExpr(*paramExpr1)) {
1198         const semantics::ParamValue *param2{type2.FindParameter(name)};
1199         if (param2) {
1200           if (semantics::MaybeIntExpr paramExpr2{param2->GetExplicit()}) {
1201             if (IsConstantExpr(*paramExpr2)) {
1202               if (ToInt64(*paramExpr1) != ToInt64(*paramExpr2)) {
1203                 return false;
1204               }
1205             }
1206           }
1207         }
1208       }
1209     }
1210   }
1211   return true;
1212 }
1213 
1214 const Symbol &GetUsedModule(const UseDetails &details) {
1215   return DEREF(details.symbol().owner().symbol());
1216 }
1217 
1218 static const Symbol *FindFunctionResult(
1219     const Symbol &original, UnorderedSymbolSet &seen) {
1220   const Symbol &root{GetAssociationRoot(original)};
1221   ;
1222   if (!seen.insert(root).second) {
1223     return nullptr; // don't loop
1224   }
1225   return std::visit(
1226       common::visitors{[](const SubprogramDetails &subp) {
1227                          return subp.isFunction() ? &subp.result() : nullptr;
1228                        },
1229           [&](const ProcEntityDetails &proc) {
1230             const Symbol *iface{proc.interface().symbol()};
1231             return iface ? FindFunctionResult(*iface, seen) : nullptr;
1232           },
1233           [&](const ProcBindingDetails &binding) {
1234             return FindFunctionResult(binding.symbol(), seen);
1235           },
1236           [](const auto &) -> const Symbol * { return nullptr; }},
1237       root.details());
1238 }
1239 
1240 const Symbol *FindFunctionResult(const Symbol &symbol) {
1241   UnorderedSymbolSet seen;
1242   return FindFunctionResult(symbol, seen);
1243 }
1244 
1245 // These are here in Evaluate/tools.cpp so that Evaluate can use
1246 // them; they cannot be defined in symbol.h due to the dependence
1247 // on Scope.
1248 
1249 bool SymbolSourcePositionCompare::operator()(
1250     const SymbolRef &x, const SymbolRef &y) const {
1251   return x->GetSemanticsContext().allCookedSources().Precedes(
1252       x->name(), y->name());
1253 }
1254 bool SymbolSourcePositionCompare::operator()(
1255     const MutableSymbolRef &x, const MutableSymbolRef &y) const {
1256   return x->GetSemanticsContext().allCookedSources().Precedes(
1257       x->name(), y->name());
1258 }
1259 
1260 SemanticsContext &Symbol::GetSemanticsContext() const {
1261   return DEREF(owner_).context();
1262 }
1263 
1264 } // namespace Fortran::semantics
1265