1 // Copyright (c) 2018-2019, NVIDIA CORPORATION. All rights reserved.
2 //
3 // Licensed under the Apache License, Version 2.0 (the "License");
4 // you may not use this file except in compliance with the License.
5 // You may obtain a copy of the License at
6 //
7 // http://www.apache.org/licenses/LICENSE-2.0
8 //
9 // Unless required by applicable law or agreed to in writing, software
10 // distributed under the License is distributed on an "AS IS" BASIS,
11 // WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
12 // See the License for the specific language governing permissions and
13 // limitations under the License.
14
15 #include "tools.h"
16 #include "traverse.h"
17 #include "../common/idioms.h"
18 #include "../parser/message.h"
19 #include <algorithm>
20 #include <variant>
21
22 using namespace Fortran::parser::literals;
23
24 namespace Fortran::evaluate {
25
26 // IsVariable()
operator ()(const ProcedureDesignator & x) const27 auto IsVariableHelper::operator()(const ProcedureDesignator &x) const
28 -> Result {
29 const semantics::Symbol *symbol{x.GetSymbol()};
30 return symbol && symbol->attrs().test(semantics::Attr::POINTER);
31 }
32
33 // Conversions of complex component expressions to REAL.
ConvertRealOperands(parser::ContextualMessages & messages,Expr<SomeType> && x,Expr<SomeType> && y,int defaultRealKind)34 ConvertRealOperandsResult ConvertRealOperands(
35 parser::ContextualMessages &messages, Expr<SomeType> &&x,
36 Expr<SomeType> &&y, int defaultRealKind) {
37 return std::visit(
38 common::visitors{
39 [&](Expr<SomeInteger> &&ix,
40 Expr<SomeInteger> &&iy) -> ConvertRealOperandsResult {
41 // Can happen in a CMPLX() constructor. Per F'2018,
42 // both integer operands are converted to default REAL.
43 return {AsSameKindExprs<TypeCategory::Real>(
44 ConvertToKind<TypeCategory::Real>(
45 defaultRealKind, std::move(ix)),
46 ConvertToKind<TypeCategory::Real>(
47 defaultRealKind, std::move(iy)))};
48 },
49 [&](Expr<SomeInteger> &&ix,
50 Expr<SomeReal> &&ry) -> ConvertRealOperandsResult {
51 return {AsSameKindExprs<TypeCategory::Real>(
52 ConvertTo(ry, std::move(ix)), std::move(ry))};
53 },
54 [&](Expr<SomeReal> &&rx,
55 Expr<SomeInteger> &&iy) -> ConvertRealOperandsResult {
56 return {AsSameKindExprs<TypeCategory::Real>(
57 std::move(rx), ConvertTo(rx, std::move(iy)))};
58 },
59 [&](Expr<SomeReal> &&rx,
60 Expr<SomeReal> &&ry) -> ConvertRealOperandsResult {
61 return {AsSameKindExprs<TypeCategory::Real>(
62 std::move(rx), std::move(ry))};
63 },
64 [&](Expr<SomeInteger> &&ix,
65 BOZLiteralConstant &&by) -> ConvertRealOperandsResult {
66 return {AsSameKindExprs<TypeCategory::Real>(
67 ConvertToKind<TypeCategory::Real>(
68 defaultRealKind, std::move(ix)),
69 ConvertToKind<TypeCategory::Real>(
70 defaultRealKind, std::move(by)))};
71 },
72 [&](BOZLiteralConstant &&bx,
73 Expr<SomeInteger> &&iy) -> ConvertRealOperandsResult {
74 return {AsSameKindExprs<TypeCategory::Real>(
75 ConvertToKind<TypeCategory::Real>(
76 defaultRealKind, std::move(bx)),
77 ConvertToKind<TypeCategory::Real>(
78 defaultRealKind, std::move(iy)))};
79 },
80 [&](Expr<SomeReal> &&rx,
81 BOZLiteralConstant &&by) -> ConvertRealOperandsResult {
82 return {AsSameKindExprs<TypeCategory::Real>(
83 std::move(rx), ConvertTo(rx, std::move(by)))};
84 },
85 [&](BOZLiteralConstant &&bx,
86 Expr<SomeReal> &&ry) -> ConvertRealOperandsResult {
87 return {AsSameKindExprs<TypeCategory::Real>(
88 ConvertTo(ry, std::move(bx)), std::move(ry))};
89 },
90 [&](auto &&, auto &&) -> ConvertRealOperandsResult {
91 messages.Say("operands must be INTEGER or REAL"_err_en_US);
92 return std::nullopt;
93 },
94 },
95 std::move(x.u), std::move(y.u));
96 }
97
98 // Helpers for NumericOperation and its subroutines below.
NoExpr()99 static std::optional<Expr<SomeType>> NoExpr() { return std::nullopt; }
100
101 template<TypeCategory CAT>
Package(Expr<SomeKind<CAT>> && catExpr)102 std::optional<Expr<SomeType>> Package(Expr<SomeKind<CAT>> &&catExpr) {
103 return {AsGenericExpr(std::move(catExpr))};
104 }
105 template<TypeCategory CAT>
Package(std::optional<Expr<SomeKind<CAT>>> && catExpr)106 std::optional<Expr<SomeType>> Package(
107 std::optional<Expr<SomeKind<CAT>>> &&catExpr) {
108 if (catExpr.has_value()) {
109 return {AsGenericExpr(std::move(*catExpr))};
110 }
111 return NoExpr();
112 }
113
114 // Mixed REAL+INTEGER operations. REAL**INTEGER is a special case that
115 // does not require conversion of the exponent expression.
116 template<template<typename> class OPR>
MixedRealLeft(Expr<SomeReal> && rx,Expr<SomeInteger> && iy)117 std::optional<Expr<SomeType>> MixedRealLeft(
118 Expr<SomeReal> &&rx, Expr<SomeInteger> &&iy) {
119 return Package(std::visit(
120 [&](auto &&rxk) -> Expr<SomeReal> {
121 using resultType = ResultType<decltype(rxk)>;
122 if constexpr (std::is_same_v<OPR<resultType>, Power<resultType>>) {
123 return AsCategoryExpr(
124 RealToIntPower<resultType>{std::move(rxk), std::move(iy)});
125 }
126 // G++ 8.1.0 emits bogus warnings about missing return statements if
127 // this statement is wrapped in an "else", as it should be.
128 return AsCategoryExpr(OPR<resultType>{
129 std::move(rxk), ConvertToType<resultType>(std::move(iy))});
130 },
131 std::move(rx.u)));
132 }
133
ConstructComplex(parser::ContextualMessages & messages,Expr<SomeType> && real,Expr<SomeType> && imaginary,int defaultRealKind)134 std::optional<Expr<SomeComplex>> ConstructComplex(
135 parser::ContextualMessages &messages, Expr<SomeType> &&real,
136 Expr<SomeType> &&imaginary, int defaultRealKind) {
137 if (auto converted{ConvertRealOperands(
138 messages, std::move(real), std::move(imaginary), defaultRealKind)}) {
139 return {std::visit(
140 [](auto &&pair) {
141 return MakeComplex(std::move(pair[0]), std::move(pair[1]));
142 },
143 std::move(*converted))};
144 }
145 return std::nullopt;
146 }
147
ConstructComplex(parser::ContextualMessages & messages,std::optional<Expr<SomeType>> && real,std::optional<Expr<SomeType>> && imaginary,int defaultRealKind)148 std::optional<Expr<SomeComplex>> ConstructComplex(
149 parser::ContextualMessages &messages, std::optional<Expr<SomeType>> &&real,
150 std::optional<Expr<SomeType>> &&imaginary, int defaultRealKind) {
151 if (auto parts{common::AllPresent(std::move(real), std::move(imaginary))}) {
152 return ConstructComplex(messages, std::get<0>(std::move(*parts)),
153 std::get<1>(std::move(*parts)), defaultRealKind);
154 }
155 return std::nullopt;
156 }
157
GetComplexPart(const Expr<SomeComplex> & z,bool isImaginary)158 Expr<SomeReal> GetComplexPart(const Expr<SomeComplex> &z, bool isImaginary) {
159 return std::visit(
160 [&](const auto &zk) {
161 static constexpr int kind{ResultType<decltype(zk)>::kind};
162 return AsCategoryExpr(ComplexComponent<kind>{isImaginary, zk});
163 },
164 z.u);
165 }
166
167 // Handle mixed COMPLEX+REAL (or INTEGER) operations in a better way
168 // than just converting the second operand to COMPLEX and performing the
169 // corresponding COMPLEX+COMPLEX operation.
170 template<template<typename> class OPR, TypeCategory RCAT>
MixedComplexLeft(parser::ContextualMessages & messages,Expr<SomeComplex> && zx,Expr<SomeKind<RCAT>> && iry,int defaultRealKind)171 std::optional<Expr<SomeType>> MixedComplexLeft(
172 parser::ContextualMessages &messages, Expr<SomeComplex> &&zx,
173 Expr<SomeKind<RCAT>> &&iry, int defaultRealKind) {
174 Expr<SomeReal> zr{GetComplexPart(zx, false)};
175 Expr<SomeReal> zi{GetComplexPart(zx, true)};
176 if constexpr (std::is_same_v<OPR<LargestReal>, Add<LargestReal>> ||
177 std::is_same_v<OPR<LargestReal>, Subtract<LargestReal>>) {
178 // (a,b) + x -> (a+x, b)
179 // (a,b) - x -> (a-x, b)
180 if (std::optional<Expr<SomeType>> rr{
181 NumericOperation<OPR>(messages, AsGenericExpr(std::move(zr)),
182 AsGenericExpr(std::move(iry)), defaultRealKind)}) {
183 return Package(ConstructComplex(messages, std::move(*rr),
184 AsGenericExpr(std::move(zi)), defaultRealKind));
185 }
186 } else if constexpr (std::is_same_v<OPR<LargestReal>,
187 Multiply<LargestReal>> ||
188 std::is_same_v<OPR<LargestReal>, Divide<LargestReal>>) {
189 // (a,b) * x -> (a*x, b*x)
190 // (a,b) / x -> (a/x, b/x)
191 auto copy{iry};
192 auto rr{NumericOperation<Multiply>(messages, AsGenericExpr(std::move(zr)),
193 AsGenericExpr(std::move(iry)), defaultRealKind)};
194 auto ri{NumericOperation<Multiply>(messages, AsGenericExpr(std::move(zi)),
195 AsGenericExpr(std::move(copy)), defaultRealKind)};
196 if (auto parts{common::AllPresent(std::move(rr), std::move(ri))}) {
197 return Package(ConstructComplex(messages, std::get<0>(std::move(*parts)),
198 std::get<1>(std::move(*parts)), defaultRealKind));
199 }
200 } else if constexpr (RCAT == TypeCategory::Integer &&
201 std::is_same_v<OPR<LargestReal>, Power<LargestReal>>) {
202 // COMPLEX**INTEGER is a special case that doesn't convert the exponent.
203 static_assert(RCAT == TypeCategory::Integer);
204 return Package(std::visit(
205 [&](auto &&zxk) {
206 using Ty = ResultType<decltype(zxk)>;
207 return AsCategoryExpr(
208 AsExpr(RealToIntPower<Ty>{std::move(zxk), std::move(iry)}));
209 },
210 std::move(zx.u)));
211 } else if (defaultRealKind != 666) { // dodge unused parameter warning
212 // (a,b) ** x -> (a,b) ** (x,0)
213 Expr<SomeComplex> zy{ConvertTo(zx, std::move(iry))};
214 return Package(PromoteAndCombine<OPR>(std::move(zx), std::move(zy)));
215 }
216 return NoExpr();
217 }
218
219 // Mixed COMPLEX operations with the COMPLEX operand on the right.
220 // x + (a,b) -> (x+a, b)
221 // x - (a,b) -> (x-a, -b)
222 // x * (a,b) -> (x*a, x*b)
223 // x / (a,b) -> (x,0) / (a,b) (and **)
224 template<template<typename> class OPR, TypeCategory LCAT>
MixedComplexRight(parser::ContextualMessages & messages,Expr<SomeKind<LCAT>> && irx,Expr<SomeComplex> && zy,int defaultRealKind)225 std::optional<Expr<SomeType>> MixedComplexRight(
226 parser::ContextualMessages &messages, Expr<SomeKind<LCAT>> &&irx,
227 Expr<SomeComplex> &&zy, int defaultRealKind) {
228 if constexpr (std::is_same_v<OPR<LargestReal>, Add<LargestReal>> ||
229 std::is_same_v<OPR<LargestReal>, Multiply<LargestReal>>) {
230 // x + (a,b) -> (a,b) + x -> (a+x, b)
231 // x * (a,b) -> (a,b) * x -> (a*x, b*x)
232 return MixedComplexLeft<Add, LCAT>(
233 messages, std::move(zy), std::move(irx), defaultRealKind);
234 } else if constexpr (std::is_same_v<OPR<LargestReal>,
235 Subtract<LargestReal>>) {
236 // x - (a,b) -> (x-a, -b)
237 Expr<SomeReal> zr{GetComplexPart(zy, false)};
238 Expr<SomeReal> zi{GetComplexPart(zy, true)};
239 if (std::optional<Expr<SomeType>> rr{
240 NumericOperation<Subtract>(messages, AsGenericExpr(std::move(irx)),
241 AsGenericExpr(std::move(zr)), defaultRealKind)}) {
242 return Package(ConstructComplex(messages, std::move(*rr),
243 AsGenericExpr(-std::move(zi)), defaultRealKind));
244 }
245 } else if (defaultRealKind != 666) { // dodge unused parameter warning
246 // x / (a,b) -> (x,0) / (a,b)
247 Expr<SomeComplex> zx{ConvertTo(zy, std::move(irx))};
248 return Package(PromoteAndCombine<OPR>(std::move(zx), std::move(zy)));
249 }
250 return NoExpr();
251 }
252
253 // N.B. When a "typeless" BOZ literal constant appears as one (not both!) of
254 // the operands to a dyadic operation where one is permitted, it assumes the
255 // type and kind of the other operand.
256 template<template<typename> class OPR>
NumericOperation(parser::ContextualMessages & messages,Expr<SomeType> && x,Expr<SomeType> && y,int defaultRealKind)257 std::optional<Expr<SomeType>> NumericOperation(
258 parser::ContextualMessages &messages, Expr<SomeType> &&x,
259 Expr<SomeType> &&y, int defaultRealKind) {
260 return std::visit(
261 common::visitors{
262 [](Expr<SomeInteger> &&ix, Expr<SomeInteger> &&iy) {
263 return Package(PromoteAndCombine<OPR, TypeCategory::Integer>(
264 std::move(ix), std::move(iy)));
265 },
266 [](Expr<SomeReal> &&rx, Expr<SomeReal> &&ry) {
267 return Package(PromoteAndCombine<OPR, TypeCategory::Real>(
268 std::move(rx), std::move(ry)));
269 },
270 // Mixed REAL/INTEGER operations
271 [](Expr<SomeReal> &&rx, Expr<SomeInteger> &&iy) {
272 return MixedRealLeft<OPR>(std::move(rx), std::move(iy));
273 },
274 [](Expr<SomeInteger> &&ix, Expr<SomeReal> &&ry) {
275 return Package(std::visit(
276 [&](auto &&ryk) -> Expr<SomeReal> {
277 using resultType = ResultType<decltype(ryk)>;
278 return AsCategoryExpr(
279 OPR<resultType>{ConvertToType<resultType>(std::move(ix)),
280 std::move(ryk)});
281 },
282 std::move(ry.u)));
283 },
284 // Homogeneous and mixed COMPLEX operations
285 [](Expr<SomeComplex> &&zx, Expr<SomeComplex> &&zy) {
286 return Package(PromoteAndCombine<OPR, TypeCategory::Complex>(
287 std::move(zx), std::move(zy)));
288 },
289 [&](Expr<SomeComplex> &&zx, Expr<SomeInteger> &&zy) {
290 return MixedComplexLeft<OPR>(
291 messages, std::move(zx), std::move(zy), defaultRealKind);
292 },
293 [&](Expr<SomeComplex> &&zx, Expr<SomeReal> &&zy) {
294 return MixedComplexLeft<OPR>(
295 messages, std::move(zx), std::move(zy), defaultRealKind);
296 },
297 [&](Expr<SomeInteger> &&zx, Expr<SomeComplex> &&zy) {
298 return MixedComplexRight<OPR>(
299 messages, std::move(zx), std::move(zy), defaultRealKind);
300 },
301 [&](Expr<SomeReal> &&zx, Expr<SomeComplex> &&zy) {
302 return MixedComplexRight<OPR>(
303 messages, std::move(zx), std::move(zy), defaultRealKind);
304 },
305 // Operations with one typeless operand
306 [&](BOZLiteralConstant &&bx, Expr<SomeInteger> &&iy) {
307 return NumericOperation<OPR>(messages,
308 AsGenericExpr(ConvertTo(iy, std::move(bx))), std::move(y),
309 defaultRealKind);
310 },
311 [&](BOZLiteralConstant &&bx, Expr<SomeReal> &&ry) {
312 return NumericOperation<OPR>(messages,
313 AsGenericExpr(ConvertTo(ry, std::move(bx))), std::move(y),
314 defaultRealKind);
315 },
316 [&](Expr<SomeInteger> &&ix, BOZLiteralConstant &&by) {
317 return NumericOperation<OPR>(messages, std::move(x),
318 AsGenericExpr(ConvertTo(ix, std::move(by))), defaultRealKind);
319 },
320 [&](Expr<SomeReal> &&rx, BOZLiteralConstant &&by) {
321 return NumericOperation<OPR>(messages, std::move(x),
322 AsGenericExpr(ConvertTo(rx, std::move(by))), defaultRealKind);
323 },
324 // Default case
325 [&](auto &&, auto &&) {
326 // TODO: defined operator
327 messages.Say("non-numeric operands to numeric operation"_err_en_US);
328 return NoExpr();
329 },
330 },
331 std::move(x.u), std::move(y.u));
332 }
333
334 template std::optional<Expr<SomeType>> NumericOperation<Power>(
335 parser::ContextualMessages &, Expr<SomeType> &&, Expr<SomeType> &&,
336 int defaultRealKind);
337 template std::optional<Expr<SomeType>> NumericOperation<Multiply>(
338 parser::ContextualMessages &, Expr<SomeType> &&, Expr<SomeType> &&,
339 int defaultRealKind);
340 template std::optional<Expr<SomeType>> NumericOperation<Divide>(
341 parser::ContextualMessages &, Expr<SomeType> &&, Expr<SomeType> &&,
342 int defaultRealKind);
343 template std::optional<Expr<SomeType>> NumericOperation<Add>(
344 parser::ContextualMessages &, Expr<SomeType> &&, Expr<SomeType> &&,
345 int defaultRealKind);
346 template std::optional<Expr<SomeType>> NumericOperation<Subtract>(
347 parser::ContextualMessages &, Expr<SomeType> &&, Expr<SomeType> &&,
348 int defaultRealKind);
349
Negation(parser::ContextualMessages & messages,Expr<SomeType> && x)350 std::optional<Expr<SomeType>> Negation(
351 parser::ContextualMessages &messages, Expr<SomeType> &&x) {
352 return std::visit(
353 common::visitors{
354 [&](BOZLiteralConstant &&) {
355 messages.Say("BOZ literal cannot be negated"_err_en_US);
356 return NoExpr();
357 },
358 [&](NullPointer &&) {
359 messages.Say("NULL() cannot be negated"_err_en_US);
360 return NoExpr();
361 },
362 [&](ProcedureDesignator &&) {
363 messages.Say("Subroutine cannot be negated"_err_en_US);
364 return NoExpr();
365 },
366 [&](ProcedureRef &&) {
367 messages.Say("Pointer to subroutine cannot be negated"_err_en_US);
368 return NoExpr();
369 },
370 [&](Expr<SomeInteger> &&x) { return Package(-std::move(x)); },
371 [&](Expr<SomeReal> &&x) { return Package(-std::move(x)); },
372 [&](Expr<SomeComplex> &&x) { return Package(-std::move(x)); },
373 [&](Expr<SomeCharacter> &&) {
374 // TODO: defined operator
375 messages.Say("CHARACTER cannot be negated"_err_en_US);
376 return NoExpr();
377 },
378 [&](Expr<SomeLogical> &&) {
379 // TODO: defined operator
380 messages.Say("LOGICAL cannot be negated"_err_en_US);
381 return NoExpr();
382 },
383 [&](Expr<SomeDerived> &&) {
384 // TODO: defined operator
385 messages.Say("Operand cannot be negated"_err_en_US);
386 return NoExpr();
387 },
388 },
389 std::move(x.u));
390 }
391
LogicalNegation(Expr<SomeLogical> && x)392 Expr<SomeLogical> LogicalNegation(Expr<SomeLogical> &&x) {
393 return std::visit(
394 [](auto &&xk) { return AsCategoryExpr(LogicalNegation(std::move(xk))); },
395 std::move(x.u));
396 }
397
398 template<typename T>
PackageRelation(RelationalOperator opr,Expr<T> && x,Expr<T> && y)399 Expr<LogicalResult> PackageRelation(
400 RelationalOperator opr, Expr<T> &&x, Expr<T> &&y) {
401 static_assert(IsSpecificIntrinsicType<T>);
402 return Expr<LogicalResult>{
403 Relational<SomeType>{Relational<T>{opr, std::move(x), std::move(y)}}};
404 }
405
406 template<TypeCategory CAT>
PromoteAndRelate(RelationalOperator opr,Expr<SomeKind<CAT>> && x,Expr<SomeKind<CAT>> && y)407 Expr<LogicalResult> PromoteAndRelate(
408 RelationalOperator opr, Expr<SomeKind<CAT>> &&x, Expr<SomeKind<CAT>> &&y) {
409 return std::visit(
410 [=](auto &&xy) {
411 return PackageRelation(opr, std::move(xy[0]), std::move(xy[1]));
412 },
413 AsSameKindExprs(std::move(x), std::move(y)));
414 }
415
Relate(parser::ContextualMessages & messages,RelationalOperator opr,Expr<SomeType> && x,Expr<SomeType> && y)416 std::optional<Expr<LogicalResult>> Relate(parser::ContextualMessages &messages,
417 RelationalOperator opr, Expr<SomeType> &&x, Expr<SomeType> &&y) {
418 return std::visit(
419 common::visitors{
420 [=](Expr<SomeInteger> &&ix,
421 Expr<SomeInteger> &&iy) -> std::optional<Expr<LogicalResult>> {
422 return PromoteAndRelate(opr, std::move(ix), std::move(iy));
423 },
424 [=](Expr<SomeReal> &&rx,
425 Expr<SomeReal> &&ry) -> std::optional<Expr<LogicalResult>> {
426 return PromoteAndRelate(opr, std::move(rx), std::move(ry));
427 },
428 [&](Expr<SomeReal> &&rx, Expr<SomeInteger> &&iy) {
429 return Relate(messages, opr, std::move(x),
430 AsGenericExpr(ConvertTo(rx, std::move(iy))));
431 },
432 [&](Expr<SomeInteger> &&ix, Expr<SomeReal> &&ry) {
433 return Relate(messages, opr,
434 AsGenericExpr(ConvertTo(ry, std::move(ix))), std::move(y));
435 },
436 [&](Expr<SomeComplex> &&zx,
437 Expr<SomeComplex> &&zy) -> std::optional<Expr<LogicalResult>> {
438 if (opr != RelationalOperator::EQ &&
439 opr != RelationalOperator::NE) {
440 messages.Say(
441 "COMPLEX data may be compared only for equality"_err_en_US);
442 } else {
443 auto rr{Relate(messages, opr,
444 AsGenericExpr(GetComplexPart(zx, false)),
445 AsGenericExpr(GetComplexPart(zy, false)))};
446 auto ri{
447 Relate(messages, opr, AsGenericExpr(GetComplexPart(zx, true)),
448 AsGenericExpr(GetComplexPart(zy, true)))};
449 if (auto parts{
450 common::AllPresent(std::move(rr), std::move(ri))}) {
451 // (a,b)==(c,d) -> (a==c) .AND. (b==d)
452 // (a,b)/=(c,d) -> (a/=c) .OR. (b/=d)
453 LogicalOperator combine{opr == RelationalOperator::EQ
454 ? LogicalOperator::And
455 : LogicalOperator::Or};
456 return Expr<LogicalResult>{
457 LogicalOperation<LogicalResult::kind>{combine,
458 std::get<0>(std::move(*parts)),
459 std::get<1>(std::move(*parts))}};
460 }
461 }
462 return std::nullopt;
463 },
464 [&](Expr<SomeComplex> &&zx, Expr<SomeInteger> &&iy) {
465 return Relate(messages, opr, std::move(x),
466 AsGenericExpr(ConvertTo(zx, std::move(iy))));
467 },
468 [&](Expr<SomeComplex> &&zx, Expr<SomeReal> &&ry) {
469 return Relate(messages, opr, std::move(x),
470 AsGenericExpr(ConvertTo(zx, std::move(ry))));
471 },
472 [&](Expr<SomeInteger> &&ix, Expr<SomeComplex> &&zy) {
473 return Relate(messages, opr,
474 AsGenericExpr(ConvertTo(zy, std::move(ix))), std::move(y));
475 },
476 [&](Expr<SomeReal> &&rx, Expr<SomeComplex> &&zy) {
477 return Relate(messages, opr,
478 AsGenericExpr(ConvertTo(zy, std::move(rx))), std::move(y));
479 },
480 [&](Expr<SomeCharacter> &&cx, Expr<SomeCharacter> &&cy) {
481 return std::visit(
482 [&](auto &&cxk,
483 auto &&cyk) -> std::optional<Expr<LogicalResult>> {
484 using Ty = ResultType<decltype(cxk)>;
485 if constexpr (std::is_same_v<Ty, ResultType<decltype(cyk)>>) {
486 return PackageRelation(opr, std::move(cxk), std::move(cyk));
487 } else {
488 messages.Say(
489 "CHARACTER operands do not have same KIND"_err_en_US);
490 return std::nullopt;
491 }
492 },
493 std::move(cx.u), std::move(cy.u));
494 },
495 // Default case
496 [&](auto &&, auto &&) {
497 // TODO: defined operator
498 auto xtype{x.GetType()};
499 auto ytype{y.GetType()};
500 if (xtype.has_value() && ytype.has_value()) {
501 messages.Say(
502 "Relational operands do not have comparable types (%s vs. %s)"_err_en_US,
503 xtype->AsFortran(), ytype->AsFortran());
504 } else {
505 messages.Say(
506 "Relational operands do not have comparable types"_err_en_US);
507 }
508 return std::optional<Expr<LogicalResult>>{};
509 },
510 },
511 std::move(x.u), std::move(y.u));
512 }
513
BinaryLogicalOperation(LogicalOperator opr,Expr<SomeLogical> && x,Expr<SomeLogical> && y)514 Expr<SomeLogical> BinaryLogicalOperation(
515 LogicalOperator opr, Expr<SomeLogical> &&x, Expr<SomeLogical> &&y) {
516 return std::visit(
517 [=](auto &&xy) {
518 using Ty = ResultType<decltype(xy[0])>;
519 return Expr<SomeLogical>{BinaryLogicalOperation<Ty::kind>(
520 opr, std::move(xy[0]), std::move(xy[1]))};
521 },
522 AsSameKindExprs(std::move(x), std::move(y)));
523 }
524
525 template<TypeCategory TO>
ConvertToNumeric(int kind,Expr<SomeType> && x)526 std::optional<Expr<SomeType>> ConvertToNumeric(int kind, Expr<SomeType> &&x) {
527 static_assert(common::IsNumericTypeCategory(TO));
528 return std::visit(
529 [=](auto &&cx) -> std::optional<Expr<SomeType>> {
530 using cxType = std::decay_t<decltype(cx)>;
531 if constexpr (!common::HasMember<cxType, TypelessExpression>) {
532 if constexpr (IsNumericTypeCategory(ResultType<cxType>::category)) {
533 return Expr<SomeType>{ConvertToKind<TO>(kind, std::move(cx))};
534 }
535 }
536 return std::nullopt;
537 },
538 std::move(x.u));
539 }
540
ConvertToType(const DynamicType & type,Expr<SomeType> && x)541 std::optional<Expr<SomeType>> ConvertToType(
542 const DynamicType &type, Expr<SomeType> &&x) {
543 switch (type.category()) {
544 case TypeCategory::Integer:
545 if (auto *boz{std::get_if<BOZLiteralConstant>(&x.u)}) {
546 // Extension to C7109: allow BOZ literals to appear in integer contexts
547 // when the type is unambiguous.
548 return Expr<SomeType>{
549 ConvertToKind<TypeCategory::Integer>(type.kind(), std::move(*boz))};
550 }
551 return ConvertToNumeric<TypeCategory::Integer>(type.kind(), std::move(x));
552 case TypeCategory::Real:
553 if (auto *boz{std::get_if<BOZLiteralConstant>(&x.u)}) {
554 return Expr<SomeType>{
555 ConvertToKind<TypeCategory::Real>(type.kind(), std::move(*boz))};
556 }
557 return ConvertToNumeric<TypeCategory::Real>(type.kind(), std::move(x));
558 case TypeCategory::Complex:
559 return ConvertToNumeric<TypeCategory::Complex>(type.kind(), std::move(x));
560 case TypeCategory::Character:
561 if (auto *cx{UnwrapExpr<Expr<SomeCharacter>>(x)}) {
562 auto converted{
563 ConvertToKind<TypeCategory::Character>(type.kind(), std::move(*cx))};
564 if (type.charLength() != nullptr) {
565 if (const auto &len{type.charLength()->GetExplicit()}) {
566 Expr<SomeInteger> lenParam{*len};
567 Expr<SubscriptInteger> length{Convert<SubscriptInteger>{lenParam}};
568 converted = std::visit(
569 [&](auto &&x) {
570 using Ty = std::decay_t<decltype(x)>;
571 using CharacterType = typename Ty::Result;
572 return Expr<SomeCharacter>{
573 Expr<CharacterType>{SetLength<CharacterType::kind>{
574 std::move(x), std::move(length)}}};
575 },
576 std::move(converted.u));
577 }
578 }
579 return Expr<SomeType>{std::move(converted)};
580 }
581 break;
582 case TypeCategory::Logical:
583 if (auto *cx{UnwrapExpr<Expr<SomeLogical>>(x)}) {
584 return Expr<SomeType>{
585 ConvertToKind<TypeCategory::Logical>(type.kind(), std::move(*cx))};
586 }
587 break;
588 case TypeCategory::Derived:
589 if (auto fromType{x.GetType()}) {
590 if (type == *fromType) {
591 return std::move(x);
592 }
593 }
594 break;
595 }
596 return std::nullopt;
597 }
598
ConvertToType(const DynamicType & to,std::optional<Expr<SomeType>> && x)599 std::optional<Expr<SomeType>> ConvertToType(
600 const DynamicType &to, std::optional<Expr<SomeType>> &&x) {
601 if (x.has_value()) {
602 return ConvertToType(to, std::move(*x));
603 } else {
604 return std::nullopt;
605 }
606 }
607
ConvertToType(const semantics::Symbol & symbol,Expr<SomeType> && x)608 std::optional<Expr<SomeType>> ConvertToType(
609 const semantics::Symbol &symbol, Expr<SomeType> &&x) {
610 if (int xRank{x.Rank()}; xRank > 0) {
611 if (symbol.Rank() != xRank) {
612 return std::nullopt;
613 }
614 }
615 if (auto symType{DynamicType::From(symbol)}) {
616 return ConvertToType(*symType, std::move(x));
617 }
618 return std::nullopt;
619 }
620
ConvertToType(const semantics::Symbol & to,std::optional<Expr<SomeType>> && x)621 std::optional<Expr<SomeType>> ConvertToType(
622 const semantics::Symbol &to, std::optional<Expr<SomeType>> &&x) {
623 if (x.has_value()) {
624 return ConvertToType(to, std::move(*x));
625 } else {
626 return std::nullopt;
627 }
628 }
629
IsAssumedRank(const semantics::Symbol & symbol0)630 bool IsAssumedRank(const semantics::Symbol &symbol0) {
631 const semantics::Symbol &symbol{ResolveAssociations(symbol0)};
632 if (const auto *details{symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
633 return details->IsAssumedRank();
634 } else {
635 return false;
636 }
637 }
638
IsAssumedRank(const ActualArgument & arg)639 bool IsAssumedRank(const ActualArgument &arg) {
640 if (const auto *expr{arg.UnwrapExpr()}) {
641 return IsAssumedRank(*expr);
642 } else {
643 const semantics::Symbol *assumedTypeDummy{arg.GetAssumedTypeDummy()};
644 CHECK(assumedTypeDummy != nullptr);
645 return IsAssumedRank(*assumedTypeDummy);
646 }
647 }
648
649 // GetLastTarget()
operator ()(const semantics::Symbol & x) const650 auto GetLastTargetHelper::operator()(const semantics::Symbol &x) const
651 -> Result {
652 if (x.attrs().HasAny({semantics::Attr::POINTER, semantics::Attr::TARGET})) {
653 return &x;
654 } else {
655 return nullptr;
656 }
657 }
operator ()(const Component & x) const658 auto GetLastTargetHelper::operator()(const Component &x) const -> Result {
659 const semantics::Symbol &symbol{x.GetLastSymbol()};
660 if (symbol.attrs().HasAny(
661 {semantics::Attr::POINTER, semantics::Attr::TARGET})) {
662 return &symbol;
663 } else if (symbol.attrs().test(semantics::Attr::ALLOCATABLE)) {
664 return nullptr;
665 } else {
666 return std::nullopt;
667 }
668 }
669
ResolveAssociations(const semantics::Symbol & symbol)670 const semantics::Symbol &ResolveAssociations(const semantics::Symbol &symbol) {
671 if (const auto *details{symbol.detailsIf<semantics::AssocEntityDetails>()}) {
672 if (const Symbol * nested{UnwrapWholeSymbolDataRef(details->expr())}) {
673 return ResolveAssociations(*nested);
674 }
675 }
676 return symbol;
677 }
678
679 struct CollectSymbolsHelper
680 : public SetTraverse<CollectSymbolsHelper, SetOfSymbols> {
681 using Base = SetTraverse<CollectSymbolsHelper, SetOfSymbols>;
CollectSymbolsHelperFortran::evaluate::CollectSymbolsHelper682 CollectSymbolsHelper() : Base{*this} {}
683 using Base::operator();
operator ()Fortran::evaluate::CollectSymbolsHelper684 SetOfSymbols operator()(const semantics::Symbol &symbol) const {
685 return {&symbol};
686 }
687 };
CollectSymbols(const A & x)688 template<typename A> SetOfSymbols CollectSymbols(const A &x) {
689 return CollectSymbolsHelper{}(x);
690 }
691 template SetOfSymbols CollectSymbols(const Expr<SomeType> &);
692 template SetOfSymbols CollectSymbols(const Expr<SomeInteger> &);
693 template SetOfSymbols CollectSymbols(const Expr<SubscriptInteger> &);
694
695 }
696