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