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