|
173
|
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 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
|
|
|
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
|
|
|
54 auto IsVariableHelper::operator()(const Symbol &symbol) const -> Result {
|
|
|
55 return !symbol.attrs().test(semantics::Attr::PARAMETER);
|
|
|
56 }
|
|
|
57 auto IsVariableHelper::operator()(const Component &x) const -> Result {
|
|
|
58 return (*this)(x.base());
|
|
|
59 }
|
|
|
60 auto IsVariableHelper::operator()(const ArrayRef &x) const -> Result {
|
|
|
61 return (*this)(x.base());
|
|
|
62 }
|
|
|
63 auto IsVariableHelper::operator()(const Substring &x) const -> Result {
|
|
|
64 return (*this)(x.GetBaseObject());
|
|
|
65 }
|
|
|
66 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.
|
|
|
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.
|
|
|
138 static std::optional<Expr<SomeType>> NoExpr() { return std::nullopt; }
|
|
|
139
|
|
|
140 template <TypeCategory CAT>
|
|
|
141 std::optional<Expr<SomeType>> Package(Expr<SomeKind<CAT>> &&catExpr) {
|
|
|
142 return {AsGenericExpr(std::move(catExpr))};
|
|
|
143 }
|
|
|
144 template <TypeCategory CAT>
|
|
|
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>
|
|
|
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
|
|
|
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
|
|
|
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
|
|
|
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.
|
|
|
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>
|
|
|
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<Multiply>(messages, AsGenericExpr(std::move(zr)),
|
|
|
246 AsGenericExpr(std::move(iry)), defaultRealKind)};
|
|
|
247 auto ri{NumericOperation<Multiply>(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>
|
|
|
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<Add, 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>
|
|
|
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
|
|
|
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
|
|
|
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>
|
|
|
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>
|
|
|
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
|
|
|
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 messages.Say(
|
|
|
504 "COMPLEX data may be compared only for equality"_err_en_US);
|
|
|
505 } else {
|
|
|
506 auto rr{Relate(messages, opr,
|
|
|
507 AsGenericExpr(GetComplexPart(zx, false)),
|
|
|
508 AsGenericExpr(GetComplexPart(zy, false)))};
|
|
|
509 auto ri{
|
|
|
510 Relate(messages, opr, AsGenericExpr(GetComplexPart(zx, true)),
|
|
|
511 AsGenericExpr(GetComplexPart(zy, true)))};
|
|
|
512 if (auto parts{
|
|
|
513 common::AllPresent(std::move(rr), std::move(ri))}) {
|
|
|
514 // (a,b)==(c,d) -> (a==c) .AND. (b==d)
|
|
|
515 // (a,b)/=(c,d) -> (a/=c) .OR. (b/=d)
|
|
|
516 LogicalOperator combine{opr == RelationalOperator::EQ
|
|
|
517 ? LogicalOperator::And
|
|
|
518 : LogicalOperator::Or};
|
|
|
519 return Expr<LogicalResult>{
|
|
|
520 LogicalOperation<LogicalResult::kind>{combine,
|
|
|
521 std::get<0>(std::move(*parts)),
|
|
|
522 std::get<1>(std::move(*parts))}};
|
|
|
523 }
|
|
|
524 }
|
|
|
525 return std::nullopt;
|
|
|
526 },
|
|
|
527 [&](Expr<SomeComplex> &&zx, Expr<SomeInteger> &&iy) {
|
|
|
528 return Relate(messages, opr, std::move(x),
|
|
|
529 AsGenericExpr(ConvertTo(zx, std::move(iy))));
|
|
|
530 },
|
|
|
531 [&](Expr<SomeComplex> &&zx, Expr<SomeReal> &&ry) {
|
|
|
532 return Relate(messages, opr, std::move(x),
|
|
|
533 AsGenericExpr(ConvertTo(zx, std::move(ry))));
|
|
|
534 },
|
|
|
535 [&](Expr<SomeInteger> &&ix, Expr<SomeComplex> &&zy) {
|
|
|
536 return Relate(messages, opr,
|
|
|
537 AsGenericExpr(ConvertTo(zy, std::move(ix))), std::move(y));
|
|
|
538 },
|
|
|
539 [&](Expr<SomeReal> &&rx, Expr<SomeComplex> &&zy) {
|
|
|
540 return Relate(messages, opr,
|
|
|
541 AsGenericExpr(ConvertTo(zy, std::move(rx))), std::move(y));
|
|
|
542 },
|
|
|
543 [&](Expr<SomeCharacter> &&cx, Expr<SomeCharacter> &&cy) {
|
|
|
544 return std::visit(
|
|
|
545 [&](auto &&cxk,
|
|
|
546 auto &&cyk) -> std::optional<Expr<LogicalResult>> {
|
|
|
547 using Ty = ResultType<decltype(cxk)>;
|
|
|
548 if constexpr (std::is_same_v<Ty, ResultType<decltype(cyk)>>) {
|
|
|
549 return PackageRelation(opr, std::move(cxk), std::move(cyk));
|
|
|
550 } else {
|
|
|
551 messages.Say(
|
|
|
552 "CHARACTER operands do not have same KIND"_err_en_US);
|
|
|
553 return std::nullopt;
|
|
|
554 }
|
|
|
555 },
|
|
|
556 std::move(cx.u), std::move(cy.u));
|
|
|
557 },
|
|
|
558 // Default case
|
|
|
559 [&](auto &&, auto &&) {
|
|
|
560 DIE("invalid types for relational operator");
|
|
|
561 return std::optional<Expr<LogicalResult>>{};
|
|
|
562 },
|
|
|
563 },
|
|
|
564 std::move(x.u), std::move(y.u));
|
|
|
565 }
|
|
|
566
|
|
|
567 Expr<SomeLogical> BinaryLogicalOperation(
|
|
|
568 LogicalOperator opr, Expr<SomeLogical> &&x, Expr<SomeLogical> &&y) {
|
|
|
569 CHECK(opr != LogicalOperator::Not);
|
|
|
570 return std::visit(
|
|
|
571 [=](auto &&xy) {
|
|
|
572 using Ty = ResultType<decltype(xy[0])>;
|
|
|
573 return Expr<SomeLogical>{BinaryLogicalOperation<Ty::kind>(
|
|
|
574 opr, std::move(xy[0]), std::move(xy[1]))};
|
|
|
575 },
|
|
|
576 AsSameKindExprs(std::move(x), std::move(y)));
|
|
|
577 }
|
|
|
578
|
|
|
579 template <TypeCategory TO>
|
|
|
580 std::optional<Expr<SomeType>> ConvertToNumeric(int kind, Expr<SomeType> &&x) {
|
|
|
581 static_assert(common::IsNumericTypeCategory(TO));
|
|
|
582 return std::visit(
|
|
|
583 [=](auto &&cx) -> std::optional<Expr<SomeType>> {
|
|
|
584 using cxType = std::decay_t<decltype(cx)>;
|
|
|
585 if constexpr (!common::HasMember<cxType, TypelessExpression>) {
|
|
|
586 if constexpr (IsNumericTypeCategory(ResultType<cxType>::category)) {
|
|
|
587 return Expr<SomeType>{ConvertToKind<TO>(kind, std::move(cx))};
|
|
|
588 }
|
|
|
589 }
|
|
|
590 return std::nullopt;
|
|
|
591 },
|
|
|
592 std::move(x.u));
|
|
|
593 }
|
|
|
594
|
|
|
595 std::optional<Expr<SomeType>> ConvertToType(
|
|
|
596 const DynamicType &type, Expr<SomeType> &&x) {
|
|
|
597 switch (type.category()) {
|
|
|
598 case TypeCategory::Integer:
|
|
|
599 if (auto *boz{std::get_if<BOZLiteralConstant>(&x.u)}) {
|
|
|
600 // Extension to C7109: allow BOZ literals to appear in integer contexts
|
|
|
601 // when the type is unambiguous.
|
|
|
602 return Expr<SomeType>{
|
|
|
603 ConvertToKind<TypeCategory::Integer>(type.kind(), std::move(*boz))};
|
|
|
604 }
|
|
|
605 return ConvertToNumeric<TypeCategory::Integer>(type.kind(), std::move(x));
|
|
|
606 case TypeCategory::Real:
|
|
|
607 if (auto *boz{std::get_if<BOZLiteralConstant>(&x.u)}) {
|
|
|
608 return Expr<SomeType>{
|
|
|
609 ConvertToKind<TypeCategory::Real>(type.kind(), std::move(*boz))};
|
|
|
610 }
|
|
|
611 return ConvertToNumeric<TypeCategory::Real>(type.kind(), std::move(x));
|
|
|
612 case TypeCategory::Complex:
|
|
|
613 return ConvertToNumeric<TypeCategory::Complex>(type.kind(), std::move(x));
|
|
|
614 case TypeCategory::Character:
|
|
|
615 if (auto *cx{UnwrapExpr<Expr<SomeCharacter>>(x)}) {
|
|
|
616 auto converted{
|
|
|
617 ConvertToKind<TypeCategory::Character>(type.kind(), std::move(*cx))};
|
|
|
618 if (type.charLength()) {
|
|
|
619 if (const auto &len{type.charLength()->GetExplicit()}) {
|
|
|
620 Expr<SomeInteger> lenParam{*len};
|
|
|
621 Expr<SubscriptInteger> length{Convert<SubscriptInteger>{lenParam}};
|
|
|
622 converted = std::visit(
|
|
|
623 [&](auto &&x) {
|
|
|
624 using Ty = std::decay_t<decltype(x)>;
|
|
|
625 using CharacterType = typename Ty::Result;
|
|
|
626 return Expr<SomeCharacter>{
|
|
|
627 Expr<CharacterType>{SetLength<CharacterType::kind>{
|
|
|
628 std::move(x), std::move(length)}}};
|
|
|
629 },
|
|
|
630 std::move(converted.u));
|
|
|
631 }
|
|
|
632 }
|
|
|
633 return Expr<SomeType>{std::move(converted)};
|
|
|
634 }
|
|
|
635 break;
|
|
|
636 case TypeCategory::Logical:
|
|
|
637 if (auto *cx{UnwrapExpr<Expr<SomeLogical>>(x)}) {
|
|
|
638 return Expr<SomeType>{
|
|
|
639 ConvertToKind<TypeCategory::Logical>(type.kind(), std::move(*cx))};
|
|
|
640 }
|
|
|
641 break;
|
|
|
642 case TypeCategory::Derived:
|
|
|
643 if (auto fromType{x.GetType()}) {
|
|
|
644 if (type == *fromType) {
|
|
|
645 return std::move(x);
|
|
|
646 }
|
|
|
647 }
|
|
|
648 break;
|
|
|
649 }
|
|
|
650 return std::nullopt;
|
|
|
651 }
|
|
|
652
|
|
|
653 std::optional<Expr<SomeType>> ConvertToType(
|
|
|
654 const DynamicType &to, std::optional<Expr<SomeType>> &&x) {
|
|
|
655 if (x) {
|
|
|
656 return ConvertToType(to, std::move(*x));
|
|
|
657 } else {
|
|
|
658 return std::nullopt;
|
|
|
659 }
|
|
|
660 }
|
|
|
661
|
|
|
662 std::optional<Expr<SomeType>> ConvertToType(
|
|
|
663 const Symbol &symbol, Expr<SomeType> &&x) {
|
|
|
664 if (int xRank{x.Rank()}; xRank > 0) {
|
|
|
665 if (symbol.Rank() != xRank) {
|
|
|
666 return std::nullopt;
|
|
|
667 }
|
|
|
668 }
|
|
|
669 if (auto symType{DynamicType::From(symbol)}) {
|
|
|
670 return ConvertToType(*symType, std::move(x));
|
|
|
671 }
|
|
|
672 return std::nullopt;
|
|
|
673 }
|
|
|
674
|
|
|
675 std::optional<Expr<SomeType>> ConvertToType(
|
|
|
676 const Symbol &to, std::optional<Expr<SomeType>> &&x) {
|
|
|
677 if (x) {
|
|
|
678 return ConvertToType(to, std::move(*x));
|
|
|
679 } else {
|
|
|
680 return std::nullopt;
|
|
|
681 }
|
|
|
682 }
|
|
|
683
|
|
|
684 bool IsAssumedRank(const Symbol &symbol0) {
|
|
|
685 const Symbol &symbol{ResolveAssociations(symbol0)};
|
|
|
686 if (const auto *details{symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
|
|
|
687 return details->IsAssumedRank();
|
|
|
688 } else {
|
|
|
689 return false;
|
|
|
690 }
|
|
|
691 }
|
|
|
692
|
|
|
693 bool IsAssumedRank(const ActualArgument &arg) {
|
|
|
694 if (const auto *expr{arg.UnwrapExpr()}) {
|
|
|
695 return IsAssumedRank(*expr);
|
|
|
696 } else {
|
|
|
697 const Symbol *assumedTypeDummy{arg.GetAssumedTypeDummy()};
|
|
|
698 CHECK(assumedTypeDummy);
|
|
|
699 return IsAssumedRank(*assumedTypeDummy);
|
|
|
700 }
|
|
|
701 }
|
|
|
702
|
|
|
703 bool IsProcedure(const Expr<SomeType> &expr) {
|
|
|
704 return std::holds_alternative<ProcedureDesignator>(expr.u);
|
|
|
705 }
|
|
|
706
|
|
|
707 bool IsProcedurePointer(const Expr<SomeType> &expr) {
|
|
|
708 return std::visit(common::visitors{
|
|
|
709 [](const NullPointer &) { return true; },
|
|
|
710 [](const ProcedureDesignator &) { return true; },
|
|
|
711 [](const ProcedureRef &) { return true; },
|
|
|
712 [](const auto &) { return false; },
|
|
|
713 },
|
|
|
714 expr.u);
|
|
|
715 }
|
|
|
716
|
|
|
717 // IsNullPointer()
|
|
|
718 struct IsNullPointerHelper : public AllTraverse<IsNullPointerHelper, false> {
|
|
|
719 using Base = AllTraverse<IsNullPointerHelper, false>;
|
|
|
720 IsNullPointerHelper() : Base(*this) {}
|
|
|
721 using Base::operator();
|
|
|
722 bool operator()(const ProcedureRef &call) const {
|
|
|
723 auto *intrinsic{call.proc().GetSpecificIntrinsic()};
|
|
|
724 return intrinsic &&
|
|
|
725 intrinsic->characteristics.value().attrs.test(
|
|
|
726 characteristics::Procedure::Attr::NullPointer);
|
|
|
727 }
|
|
|
728 bool operator()(const NullPointer &) const { return true; }
|
|
|
729 };
|
|
|
730 bool IsNullPointer(const Expr<SomeType> &expr) {
|
|
|
731 return IsNullPointerHelper{}(expr);
|
|
|
732 }
|
|
|
733
|
|
|
734 // GetSymbolVector()
|
|
|
735 auto GetSymbolVectorHelper::operator()(const Symbol &x) const -> Result {
|
|
|
736 if (const auto *details{x.detailsIf<semantics::AssocEntityDetails>()}) {
|
|
|
737 return (*this)(details->expr());
|
|
|
738 } else {
|
|
|
739 return {x.GetUltimate()};
|
|
|
740 }
|
|
|
741 }
|
|
|
742 auto GetSymbolVectorHelper::operator()(const Component &x) const -> Result {
|
|
|
743 Result result{(*this)(x.base())};
|
|
|
744 result.emplace_back(x.GetLastSymbol());
|
|
|
745 return result;
|
|
|
746 }
|
|
|
747 auto GetSymbolVectorHelper::operator()(const ArrayRef &x) const -> Result {
|
|
|
748 return GetSymbolVector(x.base());
|
|
|
749 }
|
|
|
750 auto GetSymbolVectorHelper::operator()(const CoarrayRef &x) const -> Result {
|
|
|
751 return x.base();
|
|
|
752 }
|
|
|
753
|
|
|
754 const Symbol *GetLastTarget(const SymbolVector &symbols) {
|
|
|
755 auto end{std::crend(symbols)};
|
|
|
756 // N.B. Neither clang nor g++ recognizes "symbols.crbegin()" here.
|
|
|
757 auto iter{std::find_if(std::crbegin(symbols), end, [](const Symbol &x) {
|
|
|
758 return x.attrs().HasAny(
|
|
|
759 {semantics::Attr::POINTER, semantics::Attr::TARGET});
|
|
|
760 })};
|
|
|
761 return iter == end ? nullptr : &**iter;
|
|
|
762 }
|
|
|
763
|
|
|
764 const Symbol &ResolveAssociations(const Symbol &symbol) {
|
|
|
765 if (const auto *details{symbol.detailsIf<semantics::AssocEntityDetails>()}) {
|
|
|
766 if (const Symbol * nested{UnwrapWholeSymbolDataRef(details->expr())}) {
|
|
|
767 return ResolveAssociations(*nested);
|
|
|
768 }
|
|
|
769 }
|
|
|
770 return symbol.GetUltimate();
|
|
|
771 }
|
|
|
772
|
|
|
773 struct CollectSymbolsHelper
|
|
|
774 : public SetTraverse<CollectSymbolsHelper, semantics::SymbolSet> {
|
|
|
775 using Base = SetTraverse<CollectSymbolsHelper, semantics::SymbolSet>;
|
|
|
776 CollectSymbolsHelper() : Base{*this} {}
|
|
|
777 using Base::operator();
|
|
|
778 semantics::SymbolSet operator()(const Symbol &symbol) const {
|
|
|
779 return {symbol};
|
|
|
780 }
|
|
|
781 };
|
|
|
782 template <typename A> semantics::SymbolSet CollectSymbols(const A &x) {
|
|
|
783 return CollectSymbolsHelper{}(x);
|
|
|
784 }
|
|
|
785 template semantics::SymbolSet CollectSymbols(const Expr<SomeType> &);
|
|
|
786 template semantics::SymbolSet CollectSymbols(const Expr<SomeInteger> &);
|
|
|
787 template semantics::SymbolSet CollectSymbols(const Expr<SubscriptInteger> &);
|
|
|
788
|
|
|
789 // HasVectorSubscript()
|
|
|
790 struct HasVectorSubscriptHelper : public AnyTraverse<HasVectorSubscriptHelper> {
|
|
|
791 using Base = AnyTraverse<HasVectorSubscriptHelper>;
|
|
|
792 HasVectorSubscriptHelper() : Base{*this} {}
|
|
|
793 using Base::operator();
|
|
|
794 bool operator()(const Subscript &ss) const {
|
|
|
795 return !std::holds_alternative<Triplet>(ss.u) && ss.Rank() > 0;
|
|
|
796 }
|
|
|
797 bool operator()(const ProcedureRef &) const {
|
|
|
798 return false; // don't descend into function call arguments
|
|
|
799 }
|
|
|
800 };
|
|
|
801
|
|
|
802 bool HasVectorSubscript(const Expr<SomeType> &expr) {
|
|
|
803 return HasVectorSubscriptHelper{}(expr);
|
|
|
804 }
|
|
|
805
|
|
|
806 parser::Message *AttachDeclaration(
|
|
|
807 parser::Message &message, const Symbol &symbol) {
|
|
|
808 const Symbol *unhosted{&symbol};
|
|
|
809 while (
|
|
|
810 const auto *assoc{unhosted->detailsIf<semantics::HostAssocDetails>()}) {
|
|
|
811 unhosted = &assoc->symbol();
|
|
|
812 }
|
|
|
813 if (const auto *binding{
|
|
|
814 unhosted->detailsIf<semantics::ProcBindingDetails>()}) {
|
|
|
815 if (binding->symbol().name() != symbol.name()) {
|
|
|
816 message.Attach(binding->symbol().name(),
|
|
|
817 "Procedure '%s' is bound to '%s'"_en_US, symbol.name(),
|
|
|
818 binding->symbol().name());
|
|
|
819 return &message;
|
|
|
820 }
|
|
|
821 unhosted = &binding->symbol();
|
|
|
822 }
|
|
|
823 if (const auto *use{symbol.detailsIf<semantics::UseDetails>()}) {
|
|
|
824 message.Attach(use->location(),
|
|
|
825 "'%s' is USE-associated with '%s' in module '%s'"_en_US, symbol.name(),
|
|
|
826 unhosted->name(), use->module().name());
|
|
|
827 } else {
|
|
|
828 message.Attach(
|
|
|
829 unhosted->name(), "Declaration of '%s'"_en_US, unhosted->name());
|
|
|
830 }
|
|
|
831 return &message;
|
|
|
832 }
|
|
|
833
|
|
|
834 parser::Message *AttachDeclaration(
|
|
|
835 parser::Message *message, const Symbol &symbol) {
|
|
|
836 if (message) {
|
|
|
837 AttachDeclaration(*message, symbol);
|
|
|
838 }
|
|
|
839 return message;
|
|
|
840 }
|
|
|
841
|
|
|
842 class FindImpureCallHelper
|
|
|
843 : public AnyTraverse<FindImpureCallHelper, std::optional<std::string>> {
|
|
|
844 using Result = std::optional<std::string>;
|
|
|
845 using Base = AnyTraverse<FindImpureCallHelper, Result>;
|
|
|
846
|
|
|
847 public:
|
|
|
848 explicit FindImpureCallHelper(const IntrinsicProcTable &intrinsics)
|
|
|
849 : Base{*this}, intrinsics_{intrinsics} {}
|
|
|
850 using Base::operator();
|
|
|
851 Result operator()(const ProcedureRef &call) const {
|
|
|
852 if (auto chars{characteristics::Procedure::Characterize(
|
|
|
853 call.proc(), intrinsics_)}) {
|
|
|
854 if (chars->attrs.test(characteristics::Procedure::Attr::Pure)) {
|
|
|
855 return (*this)(call.arguments());
|
|
|
856 }
|
|
|
857 }
|
|
|
858 return call.proc().GetName();
|
|
|
859 }
|
|
|
860
|
|
|
861 private:
|
|
|
862 const IntrinsicProcTable &intrinsics_;
|
|
|
863 };
|
|
|
864
|
|
|
865 std::optional<std::string> FindImpureCall(
|
|
|
866 const IntrinsicProcTable &intrinsics, const Expr<SomeType> &expr) {
|
|
|
867 return FindImpureCallHelper{intrinsics}(expr);
|
|
|
868 }
|
|
|
869 std::optional<std::string> FindImpureCall(
|
|
|
870 const IntrinsicProcTable &intrinsics, const ProcedureRef &proc) {
|
|
|
871 return FindImpureCallHelper{intrinsics}(proc);
|
|
|
872 }
|
|
|
873
|
|
|
874 } // namespace Fortran::evaluate
|
