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