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