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/Common/type-kinds.h"
12	#include "flang/Evaluate/characteristics.h"
13	#include "flang/Evaluate/traverse.h"
14	#include "flang/Parser/message.h"
15	#include "flang/Semantics/tools.h"
16	#include "llvm/ADT/StringSwitch.h"
17	#include <algorithm>
18	#include <variant>
19
20	using namespace Fortran::parser::literals;
21
22	namespace Fortran::evaluate {
23
24	// Can x*(a,b) be represented as (x*a,x*b)? This code duplication
25	// of the subexpression "x" cannot (yet?) be reliably undone by
26	// common subexpression elimination in lowering, so it's disabled
27	// here for now to avoid the risk of potential duplication of
28	// expensive subexpressions (e.g., large array expressions, references
29	// to expensive functions) in generate code.
30	static constexpr bool allowOperandDuplication{false};
31
32	std::optional<Expr<SomeType>> AsGenericExpr(DataRef &&ref) {
33	if (auto dyType{DynamicType::From(ref.GetLastSymbol())}) {
34	return TypedWrapper<Designator, DataRef>(*dyType, std::move(ref));
35	} else {
36	return std::nullopt;
37	}
38	}
39
40	std::optional<Expr<SomeType>> AsGenericExpr(const Symbol &symbol) {
41	return AsGenericExpr(DataRef{symbol});
42	}
43
44	Expr<SomeType> Parenthesize(Expr<SomeType> &&expr) {
45	return common::visit(
46	[&](auto &&x) {
47	using T = std::decay_t<decltype(x)>;
48	if constexpr (common::HasMember<T, TypelessExpression>) {
49	return expr; // no parentheses around typeless
50	} else if constexpr (std::is_same_v<T, Expr<SomeDerived>>) {
51	return AsGenericExpr(Parentheses<SomeDerived>{std::move(x)});
52	} else {
53	return common::visit(
54	[](auto &&y) {
55	using T = ResultType<decltype(y)>;
56	return AsGenericExpr(Parentheses<T>{std::move(y)});
57	},
58	std::move(x.u));
59	}
60	},
61	std::move(expr.u));
62	}
63
64	std::optional<DataRef> ExtractDataRef(
65	const ActualArgument &arg, bool intoSubstring, bool intoComplexPart) {
66	return ExtractDataRef(arg.UnwrapExpr(), intoSubstring, intoComplexPart);
67	}
68
69	std::optional<DataRef> ExtractSubstringBase(const Substring &substring) {
70	return common::visit(
71	common::visitors{
72	[&](const DataRef &x) -> std::optional<DataRef> { return x; },
73	[&](const StaticDataObject::Pointer &) -> std::optional<DataRef> {
74	return std::nullopt;
75	},
76	},
77	substring.parent());
78	}
79
80	// IsVariable()
81
82	auto IsVariableHelper::operator()(const Symbol &symbol) const -> Result {
83	// ASSOCIATE(x => expr) -- x counts as a variable, but undefinable
84	const Symbol &ultimate{symbol.GetUltimate()};
85	return !IsNamedConstant(ultimate) &&
86	(ultimate.has<semantics::ObjectEntityDetails>() ||
87	(ultimate.has<semantics::EntityDetails>() &&
88	ultimate.attrs().test(semantics::Attr::TARGET)) ||
89	ultimate.has<semantics::AssocEntityDetails>());
90	}
91	auto IsVariableHelper::operator()(const Component &x) const -> Result {
92	const Symbol &comp{x.GetLastSymbol()};
93	return (*this)(comp) && (IsPointer(comp) || (*this)(x.base()));
94	}
95	auto IsVariableHelper::operator()(const ArrayRef &x) const -> Result {
96	return (*this)(x.base());
97	}
98	auto IsVariableHelper::operator()(const Substring &x) const -> Result {
99	return (*this)(x.GetBaseObject());
100	}
101	auto IsVariableHelper::operator()(const ProcedureDesignator &x) const
102	-> Result {
103	if (const Symbol * symbol{x.GetSymbol()}) {
104	const Symbol *result{FindFunctionResult(*symbol)};
105	return result && IsPointer(*result) && !IsProcedurePointer(*result);
106	}
107	return false;
108	}
109
110	// Conversions of COMPLEX component expressions to REAL.
111	ConvertRealOperandsResult ConvertRealOperands(
112	parser::ContextualMessages &messages, Expr<SomeType> &&x,
113	Expr<SomeType> &&y, int defaultRealKind) {
114	return common::visit(
115	common::visitors{
116	[&](Expr<SomeInteger> &&ix,
117	Expr<SomeInteger> &&iy) -> ConvertRealOperandsResult {
118	// Can happen in a CMPLX() constructor. Per F'2018,
119	// both integer operands are converted to default REAL.
120	return {AsSameKindExprs<TypeCategory::Real>(
121	ConvertToKind<TypeCategory::Real>(
122	defaultRealKind, std::move(ix)),
123	ConvertToKind<TypeCategory::Real>(
124	defaultRealKind, std::move(iy)))};
125	},
126	[&](Expr<SomeInteger> &&ix,
127	Expr<SomeUnsigned> &&iy) -> ConvertRealOperandsResult {
128	return {AsSameKindExprs<TypeCategory::Real>(
129	ConvertToKind<TypeCategory::Real>(
130	defaultRealKind, std::move(ix)),
131	ConvertToKind<TypeCategory::Real>(
132	defaultRealKind, std::move(iy)))};
133	},
134	[&](Expr<SomeUnsigned> &&ix,
135	Expr<SomeInteger> &&iy) -> ConvertRealOperandsResult {
136	return {AsSameKindExprs<TypeCategory::Real>(
137	ConvertToKind<TypeCategory::Real>(
138	defaultRealKind, std::move(ix)),
139	ConvertToKind<TypeCategory::Real>(
140	defaultRealKind, std::move(iy)))};
141	},
142	[&](Expr<SomeUnsigned> &&ix,
143	Expr<SomeUnsigned> &&iy) -> ConvertRealOperandsResult {
144	return {AsSameKindExprs<TypeCategory::Real>(
145	ConvertToKind<TypeCategory::Real>(
146	defaultRealKind, std::move(ix)),
147	ConvertToKind<TypeCategory::Real>(
148	defaultRealKind, std::move(iy)))};
149	},
150	[&](Expr<SomeInteger> &&ix,
151	Expr<SomeReal> &&ry) -> ConvertRealOperandsResult {
152	return {AsSameKindExprs<TypeCategory::Real>(
153	ConvertTo(ry, std::move(ix)), std::move(ry))};
154	},
155	[&](Expr<SomeUnsigned> &&ix,
156	Expr<SomeReal> &&ry) -> ConvertRealOperandsResult {
157	return {AsSameKindExprs<TypeCategory::Real>(
158	ConvertTo(ry, std::move(ix)), std::move(ry))};
159	},
160	[&](Expr<SomeReal> &&rx,
161	Expr<SomeInteger> &&iy) -> ConvertRealOperandsResult {
162	return {AsSameKindExprs<TypeCategory::Real>(
163	std::move(rx), ConvertTo(rx, std::move(iy)))};
164	},
165	[&](Expr<SomeReal> &&rx,
166	Expr<SomeUnsigned> &&iy) -> ConvertRealOperandsResult {
167	return {AsSameKindExprs<TypeCategory::Real>(
168	std::move(rx), ConvertTo(rx, std::move(iy)))};
169	},
170	[&](Expr<SomeReal> &&rx,
171	Expr<SomeReal> &&ry) -> ConvertRealOperandsResult {
172	return {AsSameKindExprs<TypeCategory::Real>(
173	std::move(rx), std::move(ry))};
174	},
175	[&](Expr<SomeInteger> &&ix,
176	BOZLiteralConstant &&by) -> ConvertRealOperandsResult {
177	return {AsSameKindExprs<TypeCategory::Real>(
178	ConvertToKind<TypeCategory::Real>(
179	defaultRealKind, std::move(ix)),
180	ConvertToKind<TypeCategory::Real>(
181	defaultRealKind, std::move(by)))};
182	},
183	[&](Expr<SomeUnsigned> &&ix,
184	BOZLiteralConstant &&by) -> ConvertRealOperandsResult {
185	return {AsSameKindExprs<TypeCategory::Real>(
186	ConvertToKind<TypeCategory::Real>(
187	defaultRealKind, std::move(ix)),
188	ConvertToKind<TypeCategory::Real>(
189	defaultRealKind, std::move(by)))};
190	},
191	[&](BOZLiteralConstant &&bx,
192	Expr<SomeInteger> &&iy) -> ConvertRealOperandsResult {
193	return {AsSameKindExprs<TypeCategory::Real>(
194	ConvertToKind<TypeCategory::Real>(
195	defaultRealKind, std::move(bx)),
196	ConvertToKind<TypeCategory::Real>(
197	defaultRealKind, std::move(iy)))};
198	},
199	[&](BOZLiteralConstant &&bx,
200	Expr<SomeUnsigned> &&iy) -> ConvertRealOperandsResult {
201	return {AsSameKindExprs<TypeCategory::Real>(
202	ConvertToKind<TypeCategory::Real>(
203	defaultRealKind, std::move(bx)),
204	ConvertToKind<TypeCategory::Real>(
205	defaultRealKind, std::move(iy)))};
206	},
207	[&](Expr<SomeReal> &&rx,
208	BOZLiteralConstant &&by) -> ConvertRealOperandsResult {
209	return {AsSameKindExprs<TypeCategory::Real>(
210	std::move(rx), ConvertTo(rx, std::move(by)))};
211	},
212	[&](BOZLiteralConstant &&bx,
213	Expr<SomeReal> &&ry) -> ConvertRealOperandsResult {
214	return {AsSameKindExprs<TypeCategory::Real>(
215	ConvertTo(ry, std::move(bx)), std::move(ry))};
216	},
217	[&](BOZLiteralConstant &&,
218	BOZLiteralConstant &&) -> ConvertRealOperandsResult {
219	messages.Say("operands cannot both be BOZ"_err_en_US);
220	return std::nullopt;
221	},
222	[&](auto &&, auto &&) -> ConvertRealOperandsResult { // C718
223	messages.Say(
224	"operands must be INTEGER, UNSIGNED, REAL, or BOZ"_err_en_US);
225	return std::nullopt;
226	},
227	},
228	std::move(x.u), std::move(y.u));
229	}
230
231	// Helpers for NumericOperation and its subroutines below.
232	static std::optional<Expr<SomeType>> NoExpr() { return std::nullopt; }
233
234	template <TypeCategory CAT>
235	std::optional<Expr<SomeType>> Package(Expr<SomeKind<CAT>> &&catExpr) {
236	return {AsGenericExpr(std::move(catExpr))};
237	}
238	template <TypeCategory CAT>
239	std::optional<Expr<SomeType>> Package(
240	std::optional<Expr<SomeKind<CAT>>> &&catExpr) {
241	if (catExpr) {
242	return {AsGenericExpr(std::move(*catExpr))};
243	} else {
244	return std::nullopt;
245	}
246	}
247
248	// Mixed REAL+INTEGER operations. REAL**INTEGER is a special case that
249	// does not require conversion of the exponent expression.
250	template <template <typename> class OPR>
251	std::optional<Expr<SomeType>> MixedRealLeft(
252	Expr<SomeReal> &&rx, Expr<SomeInteger> &&iy) {
253	return Package(common::visit(
254	[&](auto &&rxk) -> Expr<SomeReal> {
255	using resultType = ResultType<decltype(rxk)>;
256	if constexpr (std::is_same_v<OPR<resultType>, Power<resultType>>) {
257	return AsCategoryExpr(
258	RealToIntPower<resultType>{std::move(rxk), std::move(iy)});
259	}
260	// G++ 8.1.0 emits bogus warnings about missing return statements if
261	// this statement is wrapped in an "else", as it should be.
262	return AsCategoryExpr(OPR<resultType>{
263	std::move(rxk), ConvertToType<resultType>(std::move(iy))});
264	},
265	std::move(rx.u)));
266	}
267
268	template <int KIND>
269	Expr<SomeComplex> MakeComplex(Expr<Type<TypeCategory::Real, KIND>> &&re,
270	Expr<Type<TypeCategory::Real, KIND>> &&im) {
271	return AsCategoryExpr(ComplexConstructor<KIND>{std::move(re), std::move(im)});
272	}
273
274	std::optional<Expr<SomeComplex>> ConstructComplex(
275	parser::ContextualMessages &messages, Expr<SomeType> &&real,
276	Expr<SomeType> &&imaginary, int defaultRealKind) {
277	if (auto converted{ConvertRealOperands(
278	messages, std::move(real), std::move(imaginary), defaultRealKind)}) {
279	return {common::visit(
280	[](auto &&pair) {
281	return MakeComplex(std::move(pair[0]), std::move(pair[1]));
282	},
283	std::move(*converted))};
284	}
285	return std::nullopt;
286	}
287
288	std::optional<Expr<SomeComplex>> ConstructComplex(
289	parser::ContextualMessages &messages, std::optional<Expr<SomeType>> &&real,
290	std::optional<Expr<SomeType>> &&imaginary, int defaultRealKind) {
291	if (auto parts{common::AllPresent(std::move(real), std::move(imaginary))}) {
292	return ConstructComplex(messages, std::get<0>(std::move(*parts)),
293	std::get<1>(std::move(*parts)), defaultRealKind);
294	}
295	return std::nullopt;
296	}
297
298	// Extracts the real or imaginary part of the result of a COMPLEX
299	// expression, when that expression is simple enough to be duplicated.
300	template <bool GET_IMAGINARY> struct ComplexPartExtractor {
301	template <typename A> static std::optional<Expr<SomeReal>> Get(const A &) {
302	return std::nullopt;
303	}
304
305	template <int KIND>
306	static std::optional<Expr<SomeReal>> Get(
307	const Parentheses<Type<TypeCategory::Complex, KIND>> &kz) {
308	if (auto x{Get(kz.left())}) {
309	return AsGenericExpr(AsSpecificExpr(
310	Parentheses<Type<TypeCategory::Real, KIND>>{std::move(*x)}));
311	} else {
312	return std::nullopt;
313	}
314	}
315
316	template <int KIND>
317	static std::optional<Expr<SomeReal>> Get(
318	const Negate<Type<TypeCategory::Complex, KIND>> &kz) {
319	if (auto x{Get(kz.left())}) {
320	return AsGenericExpr(AsSpecificExpr(
321	Negate<Type<TypeCategory::Real, KIND>>{std::move(*x)}));
322	} else {
323	return std::nullopt;
324	}
325	}
326
327	template <int KIND>
328	static std::optional<Expr<SomeReal>> Get(
329	const Convert<Type<TypeCategory::Complex, KIND>, TypeCategory::Complex>
330	&kz) {
331	if (auto x{Get(kz.left())}) {
332	return AsGenericExpr(AsSpecificExpr(
333	Convert<Type<TypeCategory::Real, KIND>, TypeCategory::Real>{
334	AsGenericExpr(std::move(*x))}));
335	} else {
336	return std::nullopt;
337	}
338	}
339
340	template <int KIND>
341	static std::optional<Expr<SomeReal>> Get(const ComplexConstructor<KIND> &kz) {
342	return GET_IMAGINARY ? Get(kz.right()) : Get(kz.left());
343	}
344
345	template <int KIND>
346	static std::optional<Expr<SomeReal>> Get(
347	const Constant<Type<TypeCategory::Complex, KIND>> &kz) {
348	if (auto cz{kz.GetScalarValue()}) {
349	return AsGenericExpr(
350	AsSpecificExpr(GET_IMAGINARY ? cz->AIMAG() : cz->REAL()));
351	} else {
352	return std::nullopt;
353	}
354	}
355
356	template <int KIND>
357	static std::optional<Expr<SomeReal>> Get(
358	const Designator<Type<TypeCategory::Complex, KIND>> &kz) {
359	if (const auto *symbolRef{std::get_if<SymbolRef>(&kz.u)}) {
360	return AsGenericExpr(AsSpecificExpr(
361	Designator<Type<TypeCategory::Complex, KIND>>{ComplexPart{
362	DataRef{*symbolRef},
363	GET_IMAGINARY ? ComplexPart::Part::IM : ComplexPart::Part::RE}}));
364	} else {
365	return std::nullopt;
366	}
367	}
368
369	template <int KIND>
370	static std::optional<Expr<SomeReal>> Get(
371	const Expr<Type<TypeCategory::Complex, KIND>> &kz) {
372	return Get(kz.u);
373	}
374
375	static std::optional<Expr<SomeReal>> Get(const Expr<SomeComplex> &z) {
376	return Get(z.u);
377	}
378	};
379
380	// Convert REAL to COMPLEX of the same kind. Preserving the real operand kind
381	// and then applying complex operand promotion rules allows the result to have
382	// the highest precision of REAL and COMPLEX operands as required by Fortran
383	// 2018 10.9.1.3.
384	Expr<SomeComplex> PromoteRealToComplex(Expr<SomeReal> &&someX) {
385	return common::visit(
386	[](auto &&x) {
387	using RT = ResultType<decltype(x)>;
388	return AsCategoryExpr(ComplexConstructor<RT::kind>{
389	std::move(x), AsExpr(Constant<RT>{Scalar<RT>{}})});
390	},
391	std::move(someX.u));
392	}
393
394	// Handle mixed COMPLEX+REAL (or INTEGER) operations in a better way
395	// than just converting the second operand to COMPLEX and performing the
396	// corresponding COMPLEX+COMPLEX operation.
397	template <template <typename> class OPR, TypeCategory RCAT>
398	std::optional<Expr<SomeType>> MixedComplexLeft(
399	parser::ContextualMessages &messages, const Expr<SomeComplex> &zx,
400	const Expr<SomeKind<RCAT>> &iry, [[maybe_unused]] int defaultRealKind) {
401	if constexpr (RCAT == TypeCategory::Integer &&
402	std::is_same_v<OPR<LargestReal>, Power<LargestReal>>) {
403	// COMPLEX**INTEGER is a special case that doesn't convert the exponent.
404	return Package(common::visit(
405	[&](const auto &zxk) {
406	using Ty = ResultType<decltype(zxk)>;
407	return AsCategoryExpr(AsExpr(
408	RealToIntPower<Ty>{common::Clone(zxk), common::Clone(iry)}));
409	},
410	zx.u));
411	}
412	std::optional<Expr<SomeReal>> zr{ComplexPartExtractor<false>{}.Get(zx)};
413	std::optional<Expr<SomeReal>> zi{ComplexPartExtractor<true>{}.Get(zx)};
414	if (!zr || !zi) {
415	} else if constexpr (std::is_same_v<OPR<LargestReal>, Add<LargestReal>> ||
416	std::is_same_v<OPR<LargestReal>, Subtract<LargestReal>>) {
417	// (a,b) + x -> (a+x, b)
418	// (a,b) - x -> (a-x, b)
419	if (std::optional<Expr<SomeType>> rr{
420	NumericOperation<OPR>(messages, AsGenericExpr(std::move(*zr)),
421	AsGenericExpr(common::Clone(iry)), defaultRealKind)}) {
422	return Package(ConstructComplex(messages, std::move(*rr),
423	AsGenericExpr(std::move(*zi)), defaultRealKind));
424	}
425	} else if constexpr (allowOperandDuplication &&
426	(std::is_same_v<OPR<LargestReal>, Multiply<LargestReal>> ||
427	std::is_same_v<OPR<LargestReal>, Divide<LargestReal>>)) {
428	// (a,b) * x -> (a*x, b*x)
429	// (a,b) / x -> (a/x, b/x)
430	auto copy{iry};
431	auto rr{NumericOperation<OPR>(messages, AsGenericExpr(std::move(*zr)),
432	AsGenericExpr(common::Clone(iry)), defaultRealKind)};
433	auto ri{NumericOperation<OPR>(messages, AsGenericExpr(std::move(*zi)),
434	AsGenericExpr(std::move(copy)), defaultRealKind)};
435	if (auto parts{common::AllPresent(std::move(rr), std::move(ri))}) {
436	return Package(ConstructComplex(messages, std::get<0>(std::move(*parts)),
437	std::get<1>(std::move(*parts)), defaultRealKind));
438	}
439	}
440	return std::nullopt;
441	}
442
443	// Mixed COMPLEX operations with the COMPLEX operand on the right.
444	// x + (a,b) -> (x+a, b)
445	// x - (a,b) -> (x-a, -b)
446	// x * (a,b) -> (x*a, x*b)
447	// x / (a,b) -> (x,0) / (a,b) (and **)
448	template <template <typename> class OPR, TypeCategory LCAT>
449	std::optional<Expr<SomeType>> MixedComplexRight(
450	parser::ContextualMessages &messages, const Expr<SomeKind<LCAT>> &irx,
451	const Expr<SomeComplex> &zy, [[maybe_unused]] int defaultRealKind) {
452	if constexpr (std::is_same_v<OPR<LargestReal>, Add<LargestReal>>) {
453	// x + (a,b) -> (a,b) + x -> (a+x, b)
454	return MixedComplexLeft<OPR, LCAT>(messages, zy, irx, defaultRealKind);
455	} else if constexpr (allowOperandDuplication &&
456	std::is_same_v<OPR<LargestReal>, Multiply<LargestReal>>) {
457	// x * (a,b) -> (a,b) * x -> (a*x, b*x)
458	return MixedComplexLeft<OPR, LCAT>(messages, zy, irx, defaultRealKind);
459	} else if constexpr (std::is_same_v<OPR<LargestReal>,
460	Subtract<LargestReal>>) {
461	// x - (a,b) -> (x-a, -b)
462	std::optional<Expr<SomeReal>> zr{ComplexPartExtractor<false>{}.Get(zy)};
463	std::optional<Expr<SomeReal>> zi{ComplexPartExtractor<true>{}.Get(zy)};
464	if (zr && zi) {
465	if (std::optional<Expr<SomeType>> rr{NumericOperation<Subtract>(messages,
466	AsGenericExpr(common::Clone(irx)), AsGenericExpr(std::move(*zr)),
467	defaultRealKind)}) {
468	return Package(ConstructComplex(messages, std::move(*rr),
469	AsGenericExpr(-std::move(*zi)), defaultRealKind));
470	}
471	}
472	}
473	return std::nullopt;
474	}
475
476	// Promotes REAL(rk) and COMPLEX(zk) operands COMPLEX(max(rk,zk))
477	// then combine them with an operator.
478	template <template <typename> class OPR, TypeCategory XCAT, TypeCategory YCAT>
479	Expr<SomeComplex> PromoteMixedComplexReal(
480	Expr<SomeKind<XCAT>> &&x, Expr<SomeKind<YCAT>> &&y) {
481	static_assert(XCAT == TypeCategory::Complex || YCAT == TypeCategory::Complex);
482	static_assert(XCAT == TypeCategory::Real || YCAT == TypeCategory::Real);
483	return common::visit(
484	[&](const auto &kx, const auto &ky) {
485	constexpr int maxKind{std::max(
486	ResultType<decltype(kx)>::kind, ResultType<decltype(ky)>::kind)};
487	using ZTy = Type<TypeCategory::Complex, maxKind>;
488	return Expr<SomeComplex>{
489	Expr<ZTy>{OPR<ZTy>{ConvertToType<ZTy>(std::move(x)),
490	ConvertToType<ZTy>(std::move(y))}}};
491	},
492	x.u, y.u);
493	}
494
495	// N.B. When a "typeless" BOZ literal constant appears as one (not both!) of
496	// the operands to a dyadic operation where one is permitted, it assumes the
497	// type and kind of the other operand.
498	template <template <typename> class OPR, bool CAN_BE_UNSIGNED>
499	std::optional<Expr<SomeType>> NumericOperation(
500	parser::ContextualMessages &messages, Expr<SomeType> &&x,
501	Expr<SomeType> &&y, int defaultRealKind) {
502	return common::visit(
503	common::visitors{
504	[](Expr<SomeInteger> &&ix, Expr<SomeInteger> &&iy) {
505	return Package(PromoteAndCombine<OPR, TypeCategory::Integer>(
506	std::move(ix), std::move(iy)));
507	},
508	[](Expr<SomeReal> &&rx, Expr<SomeReal> &&ry) {
509	return Package(PromoteAndCombine<OPR, TypeCategory::Real>(
510	std::move(rx), std::move(ry)));
511	},
512	[&](Expr<SomeUnsigned> &&ix, Expr<SomeUnsigned> &&iy) {
513	if constexpr (CAN_BE_UNSIGNED) {
514	return Package(PromoteAndCombine<OPR, TypeCategory::Unsigned>(
515	std::move(ix), std::move(iy)));
516	} else {
517	messages.Say("Operands must not be UNSIGNED"_err_en_US);
518	return NoExpr();
519	}
520	},
521	// Mixed REAL/INTEGER operations
522	[](Expr<SomeReal> &&rx, Expr<SomeInteger> &&iy) {
523	return MixedRealLeft<OPR>(std::move(rx), std::move(iy));
524	},
525	[](Expr<SomeInteger> &&ix, Expr<SomeReal> &&ry) {
526	return Package(common::visit(
527	[&](auto &&ryk) -> Expr<SomeReal> {
528	using resultType = ResultType<decltype(ryk)>;
529	return AsCategoryExpr(
530	OPR<resultType>{ConvertToType<resultType>(std::move(ix)),
531	std::move(ryk)});
532	},
533	std::move(ry.u)));
534	},
535	// Homogeneous and mixed COMPLEX operations
536	[](Expr<SomeComplex> &&zx, Expr<SomeComplex> &&zy) {
537	return Package(PromoteAndCombine<OPR, TypeCategory::Complex>(
538	std::move(zx), std::move(zy)));
539	},
540	[&](Expr<SomeComplex> &&zx, Expr<SomeInteger> &&iy) {
541	if (auto result{
542	MixedComplexLeft<OPR>(messages, zx, iy, defaultRealKind)}) {
543	return result;
544	} else {
545	return Package(PromoteAndCombine<OPR, TypeCategory::Complex>(
546	std::move(zx), ConvertTo(zx, std::move(iy))));
547	}
548	},
549	[&](Expr<SomeComplex> &&zx, Expr<SomeReal> &&ry) {
550	if (auto result{
551	MixedComplexLeft<OPR>(messages, zx, ry, defaultRealKind)}) {
552	return result;
553	} else {
554	return Package(
555	PromoteMixedComplexReal<OPR>(std::move(zx), std::move(ry)));
556	}
557	},
558	[&](Expr<SomeInteger> &&ix, Expr<SomeComplex> &&zy) {
559	if (auto result{MixedComplexRight<OPR>(
560	messages, ix, zy, defaultRealKind)}) {
561	return result;
562	} else {
563	return Package(PromoteAndCombine<OPR, TypeCategory::Complex>(
564	ConvertTo(zy, std::move(ix)), std::move(zy)));
565	}
566	},
567	[&](Expr<SomeReal> &&rx, Expr<SomeComplex> &&zy) {
568	if (auto result{MixedComplexRight<OPR>(
569	messages, rx, zy, defaultRealKind)}) {
570	return result;
571	} else {
572	return Package(
573	PromoteMixedComplexReal<OPR>(std::move(rx), std::move(zy)));
574	}
575	},
576	// Operations with one typeless operand
577	[&](BOZLiteralConstant &&bx, Expr<SomeInteger> &&iy) {
578	return NumericOperation<OPR, CAN_BE_UNSIGNED>(messages,
579	AsGenericExpr(ConvertTo(iy, std::move(bx))), std::move(y),
580	defaultRealKind);
581	},
582	[&](BOZLiteralConstant &&bx, Expr<SomeUnsigned> &&iy) {
583	return NumericOperation<OPR, CAN_BE_UNSIGNED>(messages,
584	AsGenericExpr(ConvertTo(iy, std::move(bx))), std::move(y),
585	defaultRealKind);
586	},
587	[&](BOZLiteralConstant &&bx, Expr<SomeReal> &&ry) {
588	return NumericOperation<OPR, CAN_BE_UNSIGNED>(messages,
589	AsGenericExpr(ConvertTo(ry, std::move(bx))), std::move(y),
590	defaultRealKind);
591	},
592	[&](Expr<SomeInteger> &&ix, BOZLiteralConstant &&by) {
593	return NumericOperation<OPR, CAN_BE_UNSIGNED>(messages,
594	std::move(x), AsGenericExpr(ConvertTo(ix, std::move(by))),
595	defaultRealKind);
596	},
597	[&](Expr<SomeUnsigned> &&ix, BOZLiteralConstant &&by) {
598	return NumericOperation<OPR, CAN_BE_UNSIGNED>(messages,
599	std::move(x), AsGenericExpr(ConvertTo(ix, std::move(by))),
600	defaultRealKind);
601	},
602	[&](Expr<SomeReal> &&rx, BOZLiteralConstant &&by) {
603	return NumericOperation<OPR, CAN_BE_UNSIGNED>(messages,
604	std::move(x), AsGenericExpr(ConvertTo(rx, std::move(by))),
605	defaultRealKind);
606	},
607	// Error cases
608	[&](Expr<SomeUnsigned> &&, auto &&) {
609	messages.Say("Both operands must be UNSIGNED"_err_en_US);
610	return NoExpr();
611	},
612	[&](auto &&, Expr<SomeUnsigned> &&) {
613	messages.Say("Both operands must be UNSIGNED"_err_en_US);
614	return NoExpr();
615	},
616	[&](auto &&, auto &&) {
617	messages.Say("non-numeric operands to numeric operation"_err_en_US);
618	return NoExpr();
619	},
620	},
621	std::move(x.u), std::move(y.u));
622	}
623
624	template std::optional<Expr<SomeType>> NumericOperation<Power, false>(
625	parser::ContextualMessages &, Expr<SomeType> &&, Expr<SomeType> &&,
626	int defaultRealKind);
627	template std::optional<Expr<SomeType>> NumericOperation<Multiply>(
628	parser::ContextualMessages &, Expr<SomeType> &&, Expr<SomeType> &&,
629	int defaultRealKind);
630	template std::optional<Expr<SomeType>> NumericOperation<Divide>(
631	parser::ContextualMessages &, Expr<SomeType> &&, Expr<SomeType> &&,
632	int defaultRealKind);
633	template std::optional<Expr<SomeType>> NumericOperation<Add>(
634	parser::ContextualMessages &, Expr<SomeType> &&, Expr<SomeType> &&,
635	int defaultRealKind);
636	template std::optional<Expr<SomeType>> NumericOperation<Subtract>(
637	parser::ContextualMessages &, Expr<SomeType> &&, Expr<SomeType> &&,
638	int defaultRealKind);
639
640	std::optional<Expr<SomeType>> Negation(
641	parser::ContextualMessages &messages, Expr<SomeType> &&x) {
642	return common::visit(
643	common::visitors{
644	[&](BOZLiteralConstant &&) {
645	messages.Say("BOZ literal cannot be negated"_err_en_US);
646	return NoExpr();
647	},
648	[&](NullPointer &&) {
649	messages.Say("NULL() cannot be negated"_err_en_US);
650	return NoExpr();
651	},
652	[&](ProcedureDesignator &&) {
653	messages.Say("Subroutine cannot be negated"_err_en_US);
654	return NoExpr();
655	},
656	[&](ProcedureRef &&) {
657	messages.Say("Pointer to subroutine cannot be negated"_err_en_US);
658	return NoExpr();
659	},
660	[&](Expr<SomeInteger> &&x) { return Package(-std::move(x)); },
661	[&](Expr<SomeReal> &&x) { return Package(-std::move(x)); },
662	[&](Expr<SomeComplex> &&x) { return Package(-std::move(x)); },
663	[&](Expr<SomeCharacter> &&) {
664	messages.Say("CHARACTER cannot be negated"_err_en_US);
665	return NoExpr();
666	},
667	[&](Expr<SomeLogical> &&) {
668	messages.Say("LOGICAL cannot be negated"_err_en_US);
669	return NoExpr();
670	},
671	[&](Expr<SomeUnsigned> &&x) { return Package(-std::move(x)); },
672	[&](Expr<SomeDerived> &&) {
673	messages.Say("Operand cannot be negated"_err_en_US);
674	return NoExpr();
675	},
676	},
677	std::move(x.u));
678	}
679
680	Expr<SomeLogical> LogicalNegation(Expr<SomeLogical> &&x) {
681	return common::visit(
682	[](auto &&xk) { return AsCategoryExpr(LogicalNegation(std::move(xk))); },
683	std::move(x.u));
684	}
685
686	template <TypeCategory CAT>
687	Expr<LogicalResult> PromoteAndRelate(
688	RelationalOperator opr, Expr<SomeKind<CAT>> &&x, Expr<SomeKind<CAT>> &&y) {
689	return common::visit(
690	[=](auto &&xy) {
691	return PackageRelation(opr, std::move(xy[0]), std::move(xy[1]));
692	},
693	AsSameKindExprs(std::move(x), std::move(y)));
694	}
695
696	std::optional<Expr<LogicalResult>> Relate(parser::ContextualMessages &messages,
697	RelationalOperator opr, Expr<SomeType> &&x, Expr<SomeType> &&y) {
698	return common::visit(
699	common::visitors{
700	[=](Expr<SomeInteger> &&ix,
701	Expr<SomeInteger> &&iy) -> std::optional<Expr<LogicalResult>> {
702	return PromoteAndRelate(opr, std::move(ix), std::move(iy));
703	},
704	[=](Expr<SomeUnsigned> &&ix,
705	Expr<SomeUnsigned> &&iy) -> std::optional<Expr<LogicalResult>> {
706	return PromoteAndRelate(opr, std::move(ix), std::move(iy));
707	},
708	[=](Expr<SomeReal> &&rx,
709	Expr<SomeReal> &&ry) -> std::optional<Expr<LogicalResult>> {
710	return PromoteAndRelate(opr, std::move(rx), std::move(ry));
711	},
712	[&](Expr<SomeReal> &&rx, Expr<SomeInteger> &&iy) {
713	return Relate(messages, opr, std::move(x),
714	AsGenericExpr(ConvertTo(rx, std::move(iy))));
715	},
716	[&](Expr<SomeInteger> &&ix, Expr<SomeReal> &&ry) {
717	return Relate(messages, opr,
718	AsGenericExpr(ConvertTo(ry, std::move(ix))), std::move(y));
719	},
720	[&](Expr<SomeComplex> &&zx,
721	Expr<SomeComplex> &&zy) -> std::optional<Expr<LogicalResult>> {
722	if (opr == RelationalOperator::EQ ||
723	opr == RelationalOperator::NE) {
724	return PromoteAndRelate(opr, std::move(zx), std::move(zy));
725	} else {
726	messages.Say(
727	"COMPLEX data may be compared only for equality"_err_en_US);
728	return std::nullopt;
729	}
730	},
731	[&](Expr<SomeComplex> &&zx, Expr<SomeInteger> &&iy) {
732	return Relate(messages, opr, std::move(x),
733	AsGenericExpr(ConvertTo(zx, std::move(iy))));
734	},
735	[&](Expr<SomeComplex> &&zx, Expr<SomeReal> &&ry) {
736	return Relate(messages, opr, std::move(x),
737	AsGenericExpr(ConvertTo(zx, std::move(ry))));
738	},
739	[&](Expr<SomeInteger> &&ix, Expr<SomeComplex> &&zy) {
740	return Relate(messages, opr,
741	AsGenericExpr(ConvertTo(zy, std::move(ix))), std::move(y));
742	},
743	[&](Expr<SomeReal> &&rx, Expr<SomeComplex> &&zy) {
744	return Relate(messages, opr,
745	AsGenericExpr(ConvertTo(zy, std::move(rx))), std::move(y));
746	},
747	[&](Expr<SomeCharacter> &&cx, Expr<SomeCharacter> &&cy) {
748	return common::visit(
749	[&](auto &&cxk,
750	auto &&cyk) -> std::optional<Expr<LogicalResult>> {
751	using Ty = ResultType<decltype(cxk)>;
752	if constexpr (std::is_same_v<Ty, ResultType<decltype(cyk)>>) {
753	return PackageRelation(opr, std::move(cxk), std::move(cyk));
754	} else {
755	messages.Say(
756	"CHARACTER operands do not have same KIND"_err_en_US);
757	return std::nullopt;
758	}
759	},
760	std::move(cx.u), std::move(cy.u));
761	},
762	// Default case
763	[&](auto &&, auto &&) {
764	DIE("invalid types for relational operator");
765	return std::optional<Expr<LogicalResult>>{};
766	},
767	},
768	std::move(x.u), std::move(y.u));
769	}
770
771	Expr<SomeLogical> BinaryLogicalOperation(
772	LogicalOperator opr, Expr<SomeLogical> &&x, Expr<SomeLogical> &&y) {
773	CHECK(opr != LogicalOperator::Not);
774	return common::visit(
775	[=](auto &&xy) {
776	using Ty = ResultType<decltype(xy[0])>;
777	return Expr<SomeLogical>{BinaryLogicalOperation<Ty::kind>(
778	opr, std::move(xy[0]), std::move(xy[1]))};
779	},
780	AsSameKindExprs(std::move(x), std::move(y)));
781	}
782
783	template <TypeCategory TO>
784	std::optional<Expr<SomeType>> ConvertToNumeric(int kind, Expr<SomeType> &&x) {
785	static_assert(common::IsNumericTypeCategory(TO));
786	return common::visit(
787	[=](auto &&cx) -> std::optional<Expr<SomeType>> {
788	using cxType = std::decay_t<decltype(cx)>;
789	if constexpr (!common::HasMember<cxType, TypelessExpression>) {
790	if constexpr (IsNumericTypeCategory(ResultType<cxType>::category)) {
791	return Expr<SomeType>{ConvertToKind<TO>(kind, std::move(cx))};
792	}
793	}
794	return std::nullopt;
795	},
796	std::move(x.u));
797	}
798
799	std::optional<Expr<SomeType>> ConvertToType(
800	const DynamicType &type, Expr<SomeType> &&x) {
801	if (type.IsTypelessIntrinsicArgument()) {
802	return std::nullopt;
803	}
804	switch (type.category()) {
805	case TypeCategory::Integer:
806	if (auto *boz{std::get_if<BOZLiteralConstant>(&x.u)}) {
807	// Extension to C7109: allow BOZ literals to appear in integer contexts
808	// when the type is unambiguous.
809	return Expr<SomeType>{
810	ConvertToKind<TypeCategory::Integer>(type.kind(), std::move(*boz))};
811	}
812	return ConvertToNumeric<TypeCategory::Integer>(type.kind(), std::move(x));
813	case TypeCategory::Unsigned:
814	if (auto *boz{std::get_if<BOZLiteralConstant>(&x.u)}) {
815	return Expr<SomeType>{
816	ConvertToKind<TypeCategory::Unsigned>(type.kind(), std::move(*boz))};
817	}
818	if (auto *cx{UnwrapExpr<Expr<SomeUnsigned>>(x)}) {
819	return Expr<SomeType>{
820	ConvertToKind<TypeCategory::Unsigned>(type.kind(), std::move(*cx))};
821	}
822	break;
823	case TypeCategory::Real:
824	if (auto *boz{std::get_if<BOZLiteralConstant>(&x.u)}) {
825	return Expr<SomeType>{
826	ConvertToKind<TypeCategory::Real>(type.kind(), std::move(*boz))};
827	}
828	return ConvertToNumeric<TypeCategory::Real>(type.kind(), std::move(x));
829	case TypeCategory::Complex:
830	return ConvertToNumeric<TypeCategory::Complex>(type.kind(), std::move(x));
831	case TypeCategory::Character:
832	if (auto *cx{UnwrapExpr<Expr<SomeCharacter>>(x)}) {
833	auto converted{
834	ConvertToKind<TypeCategory::Character>(type.kind(), std::move(*cx))};
835	if (auto length{type.GetCharLength()}) {
836	converted = common::visit(
837	[&](auto &&x) {
838	using CharacterType = ResultType<decltype(x)>;
839	return Expr<SomeCharacter>{
840	Expr<CharacterType>{SetLength<CharacterType::kind>{
841	std::move(x), std::move(*length)}}};
842	},
843	std::move(converted.u));
844	}
845	return Expr<SomeType>{std::move(converted)};
846	}
847	break;
848	case TypeCategory::Logical:
849	if (auto *cx{UnwrapExpr<Expr<SomeLogical>>(x)}) {
850	return Expr<SomeType>{
851	ConvertToKind<TypeCategory::Logical>(type.kind(), std::move(*cx))};
852	}
853	break;
854	case TypeCategory::Derived:
855	if (auto fromType{x.GetType()}) {
856	if (type.IsTkCompatibleWith(*fromType)) {
857	// "x" could be assigned or passed to "type", or appear in a
858	// structure constructor as a value for a component with "type"
859	return std::move(x);
860	}
861	}
862	break;
863	}
864	return std::nullopt;
865	}
866
867	std::optional<Expr<SomeType>> ConvertToType(
868	const DynamicType &to, std::optional<Expr<SomeType>> &&x) {
869	if (x) {
870	return ConvertToType(to, std::move(*x));
871	} else {
872	return std::nullopt;
873	}
874	}
875
876	std::optional<Expr<SomeType>> ConvertToType(
877	const Symbol &symbol, Expr<SomeType> &&x) {
878	if (auto symType{DynamicType::From(symbol)}) {
879	return ConvertToType(*symType, std::move(x));
880	}
881	return std::nullopt;
882	}
883
884	std::optional<Expr<SomeType>> ConvertToType(
885	const Symbol &to, std::optional<Expr<SomeType>> &&x) {
886	if (x) {
887	return ConvertToType(to, std::move(*x));
888	} else {
889	return std::nullopt;
890	}
891	}
892
893	bool IsAssumedRank(const Symbol &original) {
894	if (const auto *assoc{original.detailsIf<semantics::AssocEntityDetails>()}) {
895	if (assoc->rank()) {
896	return false; // in RANK(n) or RANK(*)
897	} else if (assoc->IsAssumedRank()) {
898	return true; // RANK DEFAULT
899	}
900	}
901	const Symbol &symbol{semantics::ResolveAssociations(original)};
902	const auto *object{symbol.detailsIf<semantics::ObjectEntityDetails>()};
903	return object && object->IsAssumedRank();
904	}
905
906	bool IsAssumedRank(const ActualArgument &arg) {
907	if (const auto *expr{arg.UnwrapExpr()}) {
908	return IsAssumedRank(*expr);
909	} else {
910	const Symbol *assumedTypeDummy{arg.GetAssumedTypeDummy()};
911	CHECK(assumedTypeDummy);
912	return IsAssumedRank(*assumedTypeDummy);
913	}
914	}
915
916	int GetCorank(const ActualArgument &arg) {
917	const auto *expr{arg.UnwrapExpr()};
918	return GetCorank(*expr);
919	}
920
921	bool IsProcedureDesignator(const Expr<SomeType> &expr) {
922	return std::holds_alternative<ProcedureDesignator>(expr.u);
923	}
924	bool IsFunctionDesignator(const Expr<SomeType> &expr) {
925	const auto *designator{std::get_if<ProcedureDesignator>(&expr.u)};
926	return designator && designator->GetType().has_value();
927	}
928
929	bool IsPointer(const Expr<SomeType> &expr) {
930	return IsObjectPointer(expr) || IsProcedurePointer(expr);
931	}
932
933	bool IsProcedurePointer(const Expr<SomeType> &expr) {
934	if (IsNullProcedurePointer(&expr)) {
935	return true;
936	} else if (const auto *funcRef{UnwrapProcedureRef(expr)}) {
937	if (const Symbol * proc{funcRef->proc().GetSymbol()}) {
938	const Symbol *result{FindFunctionResult(*proc)};
939	return result && IsProcedurePointer(*result);
940	} else {
941	return false;
942	}
943	} else if (const auto *proc{std::get_if<ProcedureDesignator>(&expr.u)}) {
944	return IsProcedurePointer(proc->GetSymbol());
945	} else {
946	return false;
947	}
948	}
949
950	bool IsProcedure(const Expr<SomeType> &expr) {
951	return IsProcedureDesignator(expr) || IsProcedurePointer(expr);
952	}
953
954	bool IsProcedurePointerTarget(const Expr<SomeType> &expr) {
955	return common::visit(common::visitors{
956	[](const NullPointer &) { return true; },
957	[](const ProcedureDesignator &) { return true; },
958	[](const ProcedureRef &) { return true; },
959	[&](const auto &) {
960	const Symbol *last{GetLastSymbol(expr)};
961	return last && IsProcedurePointer(*last);
962	},
963	},
964	expr.u);
965	}
966
967	bool IsObjectPointer(const Expr<SomeType> &expr) {
968	if (IsNullObjectPointer(&expr)) {
969	return true;
970	} else if (IsProcedurePointerTarget(expr)) {
971	return false;
972	} else if (const auto *funcRef{UnwrapProcedureRef(expr)}) {
973	return IsVariable(*funcRef);
974	} else if (const Symbol * symbol{UnwrapWholeSymbolOrComponentDataRef(expr)}) {
975	return IsPointer(symbol->GetUltimate());
976	} else {
977	return false;
978	}
979	}
980
981	// IsNullPointer() & variations
982
983	template <bool IS_PROC_PTR> struct IsNullPointerHelper {
984	template <typename A> bool operator()(const A &) const { return false; }
985	bool operator()(const ProcedureRef &call) const {
986	if constexpr (IS_PROC_PTR) {
987	const auto *intrinsic{call.proc().GetSpecificIntrinsic()};
988	return intrinsic &&
989	intrinsic->characteristics.value().attrs.test(
990	characteristics::Procedure::Attr::NullPointer);
991	} else {
992	return false;
993	}
994	}
995	template <typename T> bool operator()(const FunctionRef<T> &call) const {
996	if constexpr (IS_PROC_PTR) {
997	return false;
998	} else {
999	const auto *intrinsic{call.proc().GetSpecificIntrinsic()};
1000	return intrinsic &&
1001	intrinsic->characteristics.value().attrs.test(
1002	characteristics::Procedure::Attr::NullPointer);
1003	}
1004	}
1005	template <typename T> bool operator()(const Designator<T> &x) const {
1006	if (const auto *component{std::get_if<Component>(&x.u)}) {
1007	if (const auto *baseSym{std::get_if<SymbolRef>(&component->base().u)}) {
1008	const Symbol &base{**baseSym};
1009	if (const auto *object{
1010	base.detailsIf<semantics::ObjectEntityDetails>()}) {
1011	// TODO: nested component and array references
1012	if (IsNamedConstant(base) && object->init()) {
1013	if (auto structCons{
1014	GetScalarConstantValue<SomeDerived>(*object->init())}) {
1015	auto iter{structCons->values().find(component->GetLastSymbol())};
1016	if (iter != structCons->values().end()) {
1017	return (*this)(iter->second.value());
1018	}
1019	}
1020	}
1021	}
1022	}
1023	}
1024	return false;
1025	}
1026	bool operator()(const NullPointer &) const { return true; }
1027	template <typename T> bool operator()(const Parentheses<T> &x) const {
1028	return (*this)(x.left());
1029	}
1030	template <typename T> bool operator()(const Expr<T> &x) const {
1031	return common::visit(*this, x.u);
1032	}
1033	};
1034
1035	bool IsNullObjectPointer(const Expr<SomeType> *expr) {
1036	return expr && IsNullPointerHelper<false>{}(*expr);
1037	}
1038
1039	bool IsNullProcedurePointer(const Expr<SomeType> *expr) {
1040	return expr && IsNullPointerHelper<true>{}(*expr);
1041	}
1042
1043	bool IsNullPointer(const Expr<SomeType> *expr) {
1044	return IsNullObjectPointer(expr) || IsNullProcedurePointer(expr);
1045	}
1046
1047	bool IsBareNullPointer(const Expr<SomeType> *expr) {
1048	return expr && std::holds_alternative<NullPointer>(expr->u);
1049	}
1050
1051	struct IsNullAllocatableHelper {
1052	template <typename A> bool operator()(const A &) const { return false; }
1053	template <typename T> bool operator()(const FunctionRef<T> &call) const {
1054	const auto *intrinsic{call.proc().GetSpecificIntrinsic()};
1055	return intrinsic &&
1056	intrinsic->characteristics.value().attrs.test(
1057	characteristics::Procedure::Attr::NullAllocatable);
1058	}
1059	template <typename T> bool operator()(const Parentheses<T> &x) const {
1060	return (*this)(x.left());
1061	}
1062	template <typename T> bool operator()(const Expr<T> &x) const {
1063	return common::visit(*this, x.u);
1064	}
1065	};
1066
1067	bool IsNullAllocatable(const Expr<SomeType> *x) {
1068	return x && IsNullAllocatableHelper{}(*x);
1069	}
1070
1071	bool IsNullPointerOrAllocatable(const Expr<SomeType> *x) {
1072	return IsNullPointer(x) || IsNullAllocatable(x);
1073	}
1074
1075	// GetSymbolVector()
1076	auto GetSymbolVectorHelper::operator()(const Symbol &x) const -> Result {
1077	if (const auto *details{x.detailsIf<semantics::AssocEntityDetails>()}) {
1078	if (IsVariable(details->expr()) && !UnwrapProcedureRef(*details->expr())) {
1079	// associate(x => variable that is not a pointer returned by a function)
1080	return (*this)(details->expr());
1081	}
1082	}
1083	return {x.GetUltimate()};
1084	}
1085	auto GetSymbolVectorHelper::operator()(const Component &x) const -> Result {
1086	Result result{(*this)(x.base())};
1087	result.emplace_back(x.GetLastSymbol());
1088	return result;
1089	}
1090	auto GetSymbolVectorHelper::operator()(const ArrayRef &x) const -> Result {
1091	return GetSymbolVector(x.base());
1092	}
1093	auto GetSymbolVectorHelper::operator()(const CoarrayRef &x) const -> Result {
1094	return GetSymbolVector(x.base());
1095	}
1096
1097	const Symbol *GetLastTarget(const SymbolVector &symbols) {
1098	auto end{std::crend(symbols)};
1099	// N.B. Neither clang nor g++ recognizes "symbols.crbegin()" here.
1100	auto iter{std::find_if(std::crbegin(symbols), end, [](const Symbol &x) {
1101	return x.attrs().HasAny(
1102	{semantics::Attr::POINTER, semantics::Attr::TARGET});
1103	})};
1104	return iter == end ? nullptr : &**iter;
1105	}
1106
1107	struct CollectSymbolsHelper
1108	: public SetTraverse<CollectSymbolsHelper, semantics::UnorderedSymbolSet> {
1109	using Base = SetTraverse<CollectSymbolsHelper, semantics::UnorderedSymbolSet>;
1110	CollectSymbolsHelper() : Base{*this} {}
1111	using Base::operator();
1112	semantics::UnorderedSymbolSet operator()(const Symbol &symbol) const {
1113	return {symbol};
1114	}
1115	};
1116	template <typename A> semantics::UnorderedSymbolSet CollectSymbols(const A &x) {
1117	return CollectSymbolsHelper{}(x);
1118	}
1119	template semantics::UnorderedSymbolSet CollectSymbols(const Expr<SomeType> &);
1120	template semantics::UnorderedSymbolSet CollectSymbols(
1121	const Expr<SomeInteger> &);
1122	template semantics::UnorderedSymbolSet CollectSymbols(
1123	const Expr<SubscriptInteger> &);
1124
1125	struct CollectCudaSymbolsHelper : public SetTraverse<CollectCudaSymbolsHelper,
1126	semantics::UnorderedSymbolSet> {
1127	using Base =
1128	SetTraverse<CollectCudaSymbolsHelper, semantics::UnorderedSymbolSet>;
1129	CollectCudaSymbolsHelper() : Base{*this} {}
1130	using Base::operator();
1131	semantics::UnorderedSymbolSet operator()(const Symbol &symbol) const {
1132	return {symbol};
1133	}
1134	// Overload some of the operator() to filter out the symbols that are not
1135	// of interest for CUDA data transfer logic.
1136	semantics::UnorderedSymbolSet operator()(const DescriptorInquiry &) const {
1137	return {};
1138	}
1139	semantics::UnorderedSymbolSet operator()(const Subscript &) const {
1140	return {};
1141	}
1142	semantics::UnorderedSymbolSet operator()(const ProcedureRef &) const {
1143	return {};
1144	}
1145	};
1146	template <typename A>
1147	semantics::UnorderedSymbolSet CollectCudaSymbols(const A &x) {
1148	return CollectCudaSymbolsHelper{}(x);
1149	}
1150	template semantics::UnorderedSymbolSet CollectCudaSymbols(
1151	const Expr<SomeType> &);
1152	template semantics::UnorderedSymbolSet CollectCudaSymbols(
1153	const Expr<SomeInteger> &);
1154	template semantics::UnorderedSymbolSet CollectCudaSymbols(
1155	const Expr<SubscriptInteger> &);
1156
1157	bool HasCUDAImplicitTransfer(const Expr<SomeType> &expr) {
1158	semantics::UnorderedSymbolSet hostSymbols;
1159	semantics::UnorderedSymbolSet deviceSymbols;
1160	semantics::UnorderedSymbolSet cudaSymbols{CollectCudaSymbols(expr)};
1161
1162	SymbolVector symbols{GetSymbolVector(expr)};
1163	std::reverse(symbols.begin(), symbols.end());
1164	bool skipNext{false};
1165	for (const Symbol &sym : symbols) {
1166	if (cudaSymbols.find(sym) != cudaSymbols.end()) {
1167	bool isComponent{sym.owner().IsDerivedType()};
1168	bool skipComponent{false};
1169	if (!skipNext) {
1170	if (IsCUDADeviceSymbol(sym)) {
1171	deviceSymbols.insert(sym);
1172	} else if (isComponent) {
1173	skipComponent = true; // Component is not device. Look on the base.
1174	} else {
1175	hostSymbols.insert(sym);
1176	}
1177	}
1178	skipNext = isComponent && !skipComponent;
1179	} else {
1180	skipNext = false;
1181	}
1182	}
1183	bool hasConstant{HasConstant(expr)};
1184	return (hasConstant || (hostSymbols.size() > 0)) && deviceSymbols.size() > 0;
1185	}
1186
1187	// HasVectorSubscript()
1188	struct HasVectorSubscriptHelper
1189	: public AnyTraverse<HasVectorSubscriptHelper, bool,
1190	/*TraverseAssocEntityDetails=*/false> {
1191	using Base = AnyTraverse<HasVectorSubscriptHelper, bool, false>;
1192	HasVectorSubscriptHelper() : Base{*this} {}
1193	using Base::operator();
1194	bool operator()(const Subscript &ss) const {
1195	return !std::holds_alternative<Triplet>(ss.u) && ss.Rank() > 0;
1196	}
1197	bool operator()(const ProcedureRef &) const {
1198	return false; // don't descend into function call arguments
1199	}
1200	};
1201
1202	bool HasVectorSubscript(const Expr<SomeType> &expr) {
1203	return HasVectorSubscriptHelper{}(expr);
1204	}
1205
1206	// HasConstant()
1207	struct HasConstantHelper : public AnyTraverse<HasConstantHelper, bool,
1208	/*TraverseAssocEntityDetails=*/false> {
1209	using Base = AnyTraverse<HasConstantHelper, bool, false>;
1210	HasConstantHelper() : Base{*this} {}
1211	using Base::operator();
1212	template <typename T> bool operator()(const Constant<T> &) const {
1213	return true;
1214	}
1215	// Only look for constant not in subscript.
1216	bool operator()(const Subscript &) const { return false; }
1217	};
1218
1219	bool HasConstant(const Expr<SomeType> &expr) {
1220	return HasConstantHelper{}(expr);
1221	}
1222
1223	parser::Message *AttachDeclaration(
1224	parser::Message &message, const Symbol &symbol) {
1225	const Symbol *unhosted{&symbol};
1226	while (
1227	const auto *assoc{unhosted->detailsIf<semantics::HostAssocDetails>()}) {
1228	unhosted = &assoc->symbol();
1229	}
1230	if (const auto *use{symbol.detailsIf<semantics::UseDetails>()}) {
1231	message.Attach(use->location(),
1232	"'%s' is USE-associated with '%s' in module '%s'"_en_US, symbol.name(),
1233	unhosted->name(), GetUsedModule(*use).name());
1234	} else {
1235	message.Attach(
1236	unhosted->name(), "Declaration of '%s'"_en_US, unhosted->name());
1237	}
1238	if (const auto *binding{
1239	unhosted->detailsIf<semantics::ProcBindingDetails>()}) {
1240	if (!symbol.attrs().test(semantics::Attr::DEFERRED) &&
1241	binding->symbol().name() != symbol.name()) {
1242	message.Attach(binding->symbol().name(),
1243	"Procedure '%s' of type '%s' is bound to '%s'"_en_US, symbol.name(),
1244	symbol.owner().GetName().value(), binding->symbol().name());
1245	}
1246	}
1247	return &message;
1248	}
1249
1250	parser::Message *AttachDeclaration(
1251	parser::Message *message, const Symbol &symbol) {
1252	return message ? AttachDeclaration(*message, symbol) : nullptr;
1253	}
1254
1255	class FindImpureCallHelper
1256	: public AnyTraverse<FindImpureCallHelper, std::optional<std::string>,
1257	/*TraverseAssocEntityDetails=*/false> {
1258	using Result = std::optional<std::string>;
1259	using Base = AnyTraverse<FindImpureCallHelper, Result, false>;
1260
1261	public:
1262	explicit FindImpureCallHelper(FoldingContext &c) : Base{*this}, context_{c} {}
1263	using Base::operator();
1264	Result operator()(const ProcedureRef &call) const {
1265	if (auto chars{characteristics::Procedure::Characterize(
1266	call.proc(), context_, /*emitError=*/false)}) {
1267	if (chars->attrs.test(characteristics::Procedure::Attr::Pure)) {
1268	return (*this)(call.arguments());
1269	}
1270	}
1271	return call.proc().GetName();
1272	}
1273
1274	private:
1275	FoldingContext &context_;
1276	};
1277
1278	std::optional<std::string> FindImpureCall(
1279	FoldingContext &context, const Expr<SomeType> &expr) {
1280	return FindImpureCallHelper{context}(expr);
1281	}
1282	std::optional<std::string> FindImpureCall(
1283	FoldingContext &context, const ProcedureRef &proc) {
1284	return FindImpureCallHelper{context}(proc);
1285	}
1286
1287	// Common handling for procedure pointer compatibility of left- and right-hand
1288	// sides. Returns nullopt if they're compatible. Otherwise, it returns a
1289	// message that needs to be augmented by the names of the left and right sides
1290	// and the content of the "whyNotCompatible" string.
1291	std::optional<parser::MessageFixedText> CheckProcCompatibility(bool isCall,
1292	const std::optional<characteristics::Procedure> &lhsProcedure,
1293	const characteristics::Procedure *rhsProcedure,
1294	const SpecificIntrinsic *specificIntrinsic, std::string &whyNotCompatible,
1295	std::optional<std::string> &warning, bool ignoreImplicitVsExplicit) {
1296	std::optional<parser::MessageFixedText> msg;
1297	if (!lhsProcedure) {
1298	msg = "In assignment to object %s, the target '%s' is a procedure"
1299	" designator"_err_en_US;
1300	} else if (!rhsProcedure) {
1301	msg = "In assignment to procedure %s, the characteristics of the target"
1302	" procedure '%s' could not be determined"_err_en_US;
1303	} else if (!isCall && lhsProcedure->functionResult &&
1304	rhsProcedure->functionResult &&
1305	!lhsProcedure->functionResult->IsCompatibleWith(
1306	*rhsProcedure->functionResult, &whyNotCompatible)) {
1307	msg =
1308	"Function %s associated with incompatible function designator '%s': %s"_err_en_US;
1309	} else if (lhsProcedure->IsCompatibleWith(*rhsProcedure,
1310	ignoreImplicitVsExplicit, &whyNotCompatible, specificIntrinsic,
1311	&warning)) {
1312	// OK
1313	} else if (isCall) {
1314	msg = "Procedure %s associated with result of reference to function '%s'"
1315	" that is an incompatible procedure pointer: %s"_err_en_US;
1316	} else if (lhsProcedure->IsPure() && !rhsProcedure->IsPure()) {
1317	msg = "PURE procedure %s may not be associated with non-PURE"
1318	" procedure designator '%s'"_err_en_US;
1319	} else if (lhsProcedure->IsFunction() && rhsProcedure->IsSubroutine()) {
1320	msg = "Function %s may not be associated with subroutine"
1321	" designator '%s'"_err_en_US;
1322	} else if (lhsProcedure->IsSubroutine() && rhsProcedure->IsFunction()) {
1323	msg = "Subroutine %s may not be associated with function"
1324	" designator '%s'"_err_en_US;
1325	} else if (lhsProcedure->HasExplicitInterface() &&
1326	!rhsProcedure->HasExplicitInterface()) {
1327	// Section 10.2.2.4, paragraph 3 prohibits associating a procedure pointer
1328	// that has an explicit interface with a procedure whose characteristics
1329	// don't match. That's the case if the target procedure has an implicit
1330	// interface. But this case is allowed by several other compilers as long
1331	// as the explicit interface can be called via an implicit interface.
1332	if (!lhsProcedure->CanBeCalledViaImplicitInterface()) {
1333	msg = "Procedure %s with explicit interface that cannot be called via "
1334	"an implicit interface cannot be associated with procedure "
1335	"designator with an implicit interface"_err_en_US;
1336	}
1337	} else if (!lhsProcedure->HasExplicitInterface() &&
1338	rhsProcedure->HasExplicitInterface()) {
1339	// OK if the target can be called via an implicit interface
1340	if (!rhsProcedure->CanBeCalledViaImplicitInterface() &&
1341	!specificIntrinsic) {
1342	msg = "Procedure %s with implicit interface may not be associated "
1343	"with procedure designator '%s' with explicit interface that "
1344	"cannot be called via an implicit interface"_err_en_US;
1345	}
1346	} else {
1347	msg = "Procedure %s associated with incompatible procedure"
1348	" designator '%s': %s"_err_en_US;
1349	}
1350	return msg;
1351	}
1352
1353	const Symbol *UnwrapWholeSymbolDataRef(const DataRef &dataRef) {
1354	const SymbolRef *p{std::get_if<SymbolRef>(&dataRef.u)};
1355	return p ? &p->get() : nullptr;
1356	}
1357
1358	const Symbol *UnwrapWholeSymbolDataRef(const std::optional<DataRef> &dataRef) {
1359	return dataRef ? UnwrapWholeSymbolDataRef(*dataRef) : nullptr;
1360	}
1361
1362	const Symbol *UnwrapWholeSymbolOrComponentDataRef(const DataRef &dataRef) {
1363	if (const Component * c{std::get_if<Component>(&dataRef.u)}) {
1364	return c->base().Rank() == 0 ? &c->GetLastSymbol() : nullptr;
1365	} else {
1366	return UnwrapWholeSymbolDataRef(dataRef);
1367	}
1368	}
1369
1370	const Symbol *UnwrapWholeSymbolOrComponentDataRef(
1371	const std::optional<DataRef> &dataRef) {
1372	return dataRef ? UnwrapWholeSymbolOrComponentDataRef(*dataRef) : nullptr;
1373	}
1374
1375	const Symbol *UnwrapWholeSymbolOrComponentOrCoarrayRef(const DataRef &dataRef) {
1376	if (const CoarrayRef * c{std::get_if<CoarrayRef>(&dataRef.u)}) {
1377	return UnwrapWholeSymbolOrComponentOrCoarrayRef(c->base());
1378	} else {
1379	return UnwrapWholeSymbolOrComponentDataRef(dataRef);
1380	}
1381	}
1382
1383	const Symbol *UnwrapWholeSymbolOrComponentOrCoarrayRef(
1384	const std::optional<DataRef> &dataRef) {
1385	return dataRef ? UnwrapWholeSymbolOrComponentOrCoarrayRef(*dataRef) : nullptr;
1386	}
1387
1388	// GetLastPointerSymbol()
1389	static const Symbol *GetLastPointerSymbol(const Symbol &symbol) {
1390	return IsPointer(GetAssociationRoot(symbol)) ? &symbol : nullptr;
1391	}
1392	static const Symbol *GetLastPointerSymbol(const SymbolRef &symbol) {
1393	return GetLastPointerSymbol(*symbol);
1394	}
1395	static const Symbol *GetLastPointerSymbol(const Component &x) {
1396	const Symbol &c{x.GetLastSymbol()};
1397	return IsPointer(c) ? &c : GetLastPointerSymbol(x.base());
1398	}
1399	static const Symbol *GetLastPointerSymbol(const NamedEntity &x) {
1400	const auto *c{x.UnwrapComponent()};
1401	return c ? GetLastPointerSymbol(*c) : GetLastPointerSymbol(x.GetLastSymbol());
1402	}
1403	static const Symbol *GetLastPointerSymbol(const ArrayRef &x) {
1404	return GetLastPointerSymbol(x.base());
1405	}
1406	static const Symbol *GetLastPointerSymbol(const CoarrayRef &x) {
1407	return nullptr;
1408	}
1409	const Symbol *GetLastPointerSymbol(const DataRef &x) {
1410	return common::visit(
1411	[](const auto &y) { return GetLastPointerSymbol(y); }, x.u);
1412	}
1413
1414	template <TypeCategory TO, TypeCategory FROM>
1415	static std::optional<Expr<SomeType>> DataConstantConversionHelper(
1416	FoldingContext &context, const DynamicType &toType,
1417	const Expr<SomeType> &expr) {
1418	if (!common::IsValidKindOfIntrinsicType(FROM, toType.kind())) {
1419	return std::nullopt;
1420	}
1421	DynamicType sizedType{FROM, toType.kind()};
1422	if (auto sized{
1423	Fold(context, ConvertToType(sizedType, Expr<SomeType>{expr}))}) {
1424	if (const auto *someExpr{UnwrapExpr<Expr<SomeKind<FROM>>>(*sized)}) {
1425	return common::visit(
1426	[](const auto &w) -> std::optional<Expr<SomeType>> {
1427	using FromType = ResultType<decltype(w)>;
1428	static constexpr int kind{FromType::kind};
1429	if constexpr (IsValidKindOfIntrinsicType(TO, kind)) {
1430	if (const auto *fromConst{UnwrapExpr<Constant<FromType>>(w)}) {
1431	using FromWordType = typename FromType::Scalar;
1432	using LogicalType = value::Logical<FromWordType::bits>;
1433	using ElementType =
1434	std::conditional_t<TO == TypeCategory::Logical, LogicalType,
1435	typename LogicalType::Word>;
1436	std::vector<ElementType> values;
1437	auto at{fromConst->lbounds()};
1438	auto shape{fromConst->shape()};
1439	for (auto n{GetSize(shape)}; n-- > 0;
1440	fromConst->IncrementSubscripts(at)) {
1441	auto elt{fromConst->At(at)};
1442	if constexpr (TO == TypeCategory::Logical) {
1443	values.emplace_back(std::move(elt));
1444	} else {
1445	values.emplace_back(elt.word());
1446	}
1447	}
1448	return {AsGenericExpr(AsExpr(Constant<Type<TO, kind>>{
1449	std::move(values), std::move(shape)}))};
1450	}
1451	}
1452	return std::nullopt;
1453	},
1454	someExpr->u);
1455	}
1456	}
1457	return std::nullopt;
1458	}
1459
1460	std::optional<Expr<SomeType>> DataConstantConversionExtension(
1461	FoldingContext &context, const DynamicType &toType,
1462	const Expr<SomeType> &expr0) {
1463	Expr<SomeType> expr{Fold(context, Expr<SomeType>{expr0})};
1464	if (!IsActuallyConstant(expr)) {
1465	return std::nullopt;
1466	}
1467	if (auto fromType{expr.GetType()}) {
1468	if (toType.category() == TypeCategory::Logical &&
1469	fromType->category() == TypeCategory::Integer) {
1470	return DataConstantConversionHelper<TypeCategory::Logical,
1471	TypeCategory::Integer>(context, toType, expr);
1472	}
1473	if (toType.category() == TypeCategory::Integer &&
1474	fromType->category() == TypeCategory::Logical) {
1475	return DataConstantConversionHelper<TypeCategory::Integer,
1476	TypeCategory::Logical>(context, toType, expr);
1477	}
1478	}
1479	return std::nullopt;
1480	}
1481
1482	bool IsAllocatableOrPointerObject(const Expr<SomeType> &expr) {
1483	const semantics::Symbol *sym{UnwrapWholeSymbolOrComponentDataRef(expr)};
1484	return (sym &&
1485	semantics::IsAllocatableOrObjectPointer(&sym->GetUltimate())) ||
1486	evaluate::IsObjectPointer(expr) || evaluate::IsNullAllocatable(&expr);
1487	}
1488
1489	bool IsAllocatableDesignator(const Expr<SomeType> &expr) {
1490	// Allocatable sub-objects are not themselves allocatable (9.5.3.1 NOTE 2).
1491	if (const semantics::Symbol *
1492	sym{UnwrapWholeSymbolOrComponentOrCoarrayRef(expr)}) {
1493	return semantics::IsAllocatable(sym->GetUltimate());
1494	}
1495	return false;
1496	}
1497
1498	bool MayBePassedAsAbsentOptional(const Expr<SomeType> &expr) {
1499	const semantics::Symbol *sym{UnwrapWholeSymbolOrComponentDataRef(expr)};
1500	// 15.5.2.12 1. is pretty clear that an unallocated allocatable/pointer actual
1501	// may be passed to a non-allocatable/non-pointer optional dummy. Note that
1502	// other compilers (like nag, nvfortran, ifort, gfortran and xlf) seems to
1503	// ignore this point in intrinsic contexts (e.g CMPLX argument).
1504	return (sym && semantics::IsOptional(*sym)) ||
1505	IsAllocatableOrPointerObject(expr);
1506	}
1507
1508	std::optional<Expr<SomeType>> HollerithToBOZ(FoldingContext &context,
1509	const Expr<SomeType> &expr, const DynamicType &type) {
1510	if (std::optional<std::string> chValue{GetScalarConstantValue<Ascii>(expr)}) {
1511	// Pad on the right with spaces when short, truncate the right if long.
1512	auto bytes{static_cast<std::size_t>(
1513	ToInt64(type.MeasureSizeInBytes(context, false)).value())};
1514	BOZLiteralConstant bits{0};
1515	for (std::size_t j{0}; j < bytes; ++j) {
1516	auto idx{isHostLittleEndian ? j : bytes - j - 1};
1517	char ch{idx >= chValue->size() ? ' ' : chValue->at(idx)};
1518	BOZLiteralConstant chBOZ{static_cast<unsigned char>(ch)};
1519	bits = bits.IOR(chBOZ.SHIFTL(8 * j));
1520	}
1521	return ConvertToType(type, Expr<SomeType>{bits});
1522	} else {
1523	return std::nullopt;
1524	}
1525	}
1526
1527	// Extracts a whole symbol being used as a bound of a dummy argument,
1528	// possibly wrapped with parentheses or MAX(0, ...).
1529	// Works with any integer expression.
1530	template <typename T> const Symbol *GetBoundSymbol(const Expr<T> &);
1531	template <int KIND>
1532	const Symbol *GetBoundSymbol(
1533	const Expr<Type<TypeCategory::Integer, KIND>> &expr) {
1534	using T = Type<TypeCategory::Integer, KIND>;
1535	return common::visit(
1536	common::visitors{
1537	[](const Extremum<T> &max) -> const Symbol * {
1538	if (max.ordering == Ordering::Greater) {
1539	if (auto zero{ToInt64(max.left())}; zero && *zero == 0) {
1540	return GetBoundSymbol(max.right());
1541	}
1542	}
1543	return nullptr;
1544	},
1545	[](const Parentheses<T> &x) { return GetBoundSymbol(x.left()); },
1546	[](const Designator<T> &x) -> const Symbol * {
1547	if (const auto *ref{std::get_if<SymbolRef>(&x.u)}) {
1548	return &**ref;
1549	}
1550	return nullptr;
1551	},
1552	[](const Convert<T, TypeCategory::Integer> &x) {
1553	return common::visit(
1554	[](const auto &y) -> const Symbol * {
1555	using yType = std::decay_t<decltype(y)>;
1556	using yResult = typename yType::Result;
1557	if constexpr (yResult::kind <= KIND) {
1558	return GetBoundSymbol(y);
1559	} else {
1560	return nullptr;
1561	}
1562	},
1563	x.left().u);
1564	},
1565	[](const auto &) -> const Symbol * { return nullptr; },
1566	},
1567	expr.u);
1568	}
1569	template <>
1570	const Symbol *GetBoundSymbol<SomeInteger>(const Expr<SomeInteger> &expr) {
1571	return common::visit(
1572	[](const auto &kindExpr) { return GetBoundSymbol(kindExpr); }, expr.u);
1573	}
1574
1575	template <typename T>
1576	std::optional<bool> AreEquivalentInInterface(
1577	const Expr<T> &x, const Expr<T> &y) {
1578	auto xVal{ToInt64(x)};
1579	auto yVal{ToInt64(y)};
1580	if (xVal && yVal) {
1581	return *xVal == *yVal;
1582	} else if (xVal || yVal) {
1583	return false;
1584	}
1585	const Symbol *xSym{GetBoundSymbol(x)};
1586	const Symbol *ySym{GetBoundSymbol(y)};
1587	if (xSym && ySym) {
1588	if (&xSym->GetUltimate() == &ySym->GetUltimate()) {
1589	return true; // USE/host associated same symbol
1590	}
1591	auto xNum{semantics::GetDummyArgumentNumber(xSym)};
1592	auto yNum{semantics::GetDummyArgumentNumber(ySym)};
1593	if (xNum && yNum) {
1594	if (*xNum == *yNum) {
1595	auto xType{DynamicType::From(*xSym)};
1596	auto yType{DynamicType::From(*ySym)};
1597	return xType && yType && xType->IsEquivalentTo(*yType);
1598	}
1599	}
1600	return false;
1601	} else if (xSym || ySym) {
1602	return false;
1603	}
1604	// Neither expression is an integer constant or a whole symbol.
1605	if (x == y) {
1606	return true;
1607	} else {
1608	return std::nullopt; // not sure
1609	}
1610	}
1611	template std::optional<bool> AreEquivalentInInterface<SubscriptInteger>(
1612	const Expr<SubscriptInteger> &, const Expr<SubscriptInteger> &);
1613	template std::optional<bool> AreEquivalentInInterface<SomeInteger>(
1614	const Expr<SomeInteger> &, const Expr<SomeInteger> &);
1615
1616	bool CheckForCoindexedObject(parser::ContextualMessages &messages,
1617	const std::optional<ActualArgument> &arg, const std::string &procName,
1618	const std::string &argName) {
1619	if (arg && ExtractCoarrayRef(arg->UnwrapExpr())) {
1620	messages.Say(arg->sourceLocation(),
1621	"'%s' argument to '%s' may not be a coindexed object"_err_en_US,
1622	argName, procName);
1623	return false;
1624	} else {
1625	return true;
1626	}
1627	}
1628
1629	bool CheckForSymbolMatch(const Expr<SomeType> *lhs, const Expr<SomeType> *rhs) {
1630	if (lhs && rhs) {
1631	if (SymbolVector lhsSymbols{GetSymbolVector(*lhs)}; !lhsSymbols.empty()) {
1632	const Symbol &first{*lhsSymbols.front()};
1633	for (const Symbol &symbol : GetSymbolVector(*rhs)) {
1634	if (first == symbol) {
1635	return true;
1636	}
1637	}
1638	}
1639	}
1640	return false;
1641	}
1642
1643	namespace operation {
1644	template <typename T> Expr<SomeType> AsSomeExpr(const T &x) {
1645	return AsGenericExpr(common::Clone(x));
1646	}
1647
1648	template <bool IgnoreResizingConverts>
1649	struct ArgumentExtractor
1650	: public Traverse<ArgumentExtractor<IgnoreResizingConverts>,
1651	std::pair<operation::Operator, std::vector<Expr<SomeType>>>, false> {
1652	using Arguments = std::vector<Expr<SomeType>>;
1653	using Result = std::pair<operation::Operator, Arguments>;
1654	using Base =
1655	Traverse<ArgumentExtractor<IgnoreResizingConverts>, Result, false>;
1656	static constexpr auto IgnoreResizes{IgnoreResizingConverts};
1657	static constexpr auto Logical{common::TypeCategory::Logical};
1658	ArgumentExtractor() : Base(*this) {}
1659
1660	Result Default() const { return {}; }
1661
1662	using Base::operator();
1663
1664	template <int Kind>
1665	Result operator()(const Constant<Type<Logical, Kind>> &x) const {
1666	if (const auto &val{x.GetScalarValue()}) {
1667	return val->IsTrue()
1668	? std::make_pair(operation::Operator::True, Arguments{})
1669	: std::make_pair(operation::Operator::False, Arguments{});
1670	}
1671	return Default();
1672	}
1673
1674	template <typename R> Result operator()(const FunctionRef<R> &x) const {
1675	Result result{operation::OperationCode(x.proc()), {}};
1676	for (size_t i{0}, e{x.arguments().size()}; i != e; ++i) {
1677	if (auto *e{x.UnwrapArgExpr(i)}) {
1678	result.second.push_back(*e);
1679	}
1680	}
1681	return result;
1682	}
1683
1684	template <typename D, typename R, typename... Os>
1685	Result operator()(const Operation<D, R, Os...> &x) const {
1686	if constexpr (std::is_same_v<D, Parentheses<R>>) {
1687	// Ignore top-level parentheses.
1688	return (*this)(x.template operand<0>());
1689	}
1690	if constexpr (IgnoreResizes && std::is_same_v<D, Convert<R, R::category>>) {
1691	// Ignore conversions within the same category.
1692	// Atomic operations on int(kind=1) may be implicitly widened
1693	// to int(kind=4) for example.
1694	return (*this)(x.template operand<0>());
1695	} else {
1696	return std::make_pair(operation::OperationCode(x),
1697	OperationArgs(x, std::index_sequence_for<Os...>{}));
1698	}
1699	}
1700
1701	template <typename T> Result operator()(const Designator<T> &x) const {
1702	return {operation::Operator::Identity, {AsSomeExpr(x)}};
1703	}
1704
1705	template <typename T> Result operator()(const Constant<T> &x) const {
1706	return {operation::Operator::Identity, {AsSomeExpr(x)}};
1707	}
1708
1709	template <typename... Rs>
1710	Result Combine(Result &&result, Rs &&...results) const {
1711	// There shouldn't be any combining needed, since we're stopping the
1712	// traversal at the top-level operation, but implement one that picks
1713	// the first non-empty result.
1714	if constexpr (sizeof...(Rs) == 0) {
1715	return std::move(result);
1716	} else {
1717	if (!result.second.empty()) {
1718	return std::move(result);
1719	} else {
1720	return Combine(std::move(results)...);
1721	}
1722	}
1723	}
1724
1725	private:
1726	template <typename D, typename R, typename... Os, size_t... Is>
1727	Arguments OperationArgs(
1728	const Operation<D, R, Os...> &x, std::index_sequence<Is...>) const {
1729	return Arguments{Expr<SomeType>(x.template operand<Is>())...};
1730	}
1731	};
1732	} // namespace operation
1733
1734	std::string operation::ToString(operation::Operator op) {
1735	switch (op) {
1736	case Operator::Unknown:
1737	return "??";
1738	case Operator::Add:
1739	return "+";
1740	case Operator::And:
1741	return "AND";
1742	case Operator::Associated:
1743	return "ASSOCIATED";
1744	case Operator::Call:
1745	return "function-call";
1746	case Operator::Constant:
1747	return "constant";
1748	case Operator::Convert:
1749	return "type-conversion";
1750	case Operator::Div:
1751	return "/";
1752	case Operator::Eq:
1753	return "==";
1754	case Operator::Eqv:
1755	return "EQV";
1756	case Operator::False:
1757	return ".FALSE.";
1758	case Operator::Ge:
1759	return ">=";
1760	case Operator::Gt:
1761	return ">";
1762	case Operator::Identity:
1763	return "identity";
1764	case Operator::Intrinsic:
1765	return "intrinsic";
1766	case Operator::Le:
1767	return "<=";
1768	case Operator::Lt:
1769	return "<";
1770	case Operator::Max:
1771	return "MAX";
1772	case Operator::Min:
1773	return "MIN";
1774	case Operator::Mul:
1775	return "*";
1776	case Operator::Ne:
1777	return "/=";
1778	case Operator::Neqv:
1779	return "NEQV/EOR";
1780	case Operator::Not:
1781	return "NOT";
1782	case Operator::Or:
1783	return "OR";
1784	case Operator::Pow:
1785	return "**";
1786	case Operator::Resize:
1787	return "resize";
1788	case Operator::Sub:
1789	return "-";
1790	case Operator::True:
1791	return ".TRUE.";
1792	}
1793	llvm_unreachable("Unhandler operator");
1794	}
1795
1796	operation::Operator operation::OperationCode(const ProcedureDesignator &proc) {
1797	Operator code{llvm::StringSwitch<Operator>(proc.GetName())
1798	.Case("associated", Operator::Associated)
1799	.Case("min", Operator::Min)
1800	.Case("max", Operator::Max)
1801	.Case("iand", Operator::And)
1802	.Case("ior", Operator::Or)
1803	.Case("ieor", Operator::Neqv)
1804	.Default(Operator::Call)};
1805	if (code == Operator::Call && proc.GetSpecificIntrinsic()) {
1806	return Operator::Intrinsic;
1807	}
1808	return code;
1809	}
1810
1811	std::pair<operation::Operator, std::vector<Expr<SomeType>>>
1812	GetTopLevelOperation(const Expr<SomeType> &expr) {
1813	return operation::ArgumentExtractor<true>{}(expr);
1814	}
1815
1816	namespace operation {
1817	struct ConvertCollector
1818	: public Traverse<ConvertCollector,
1819	std::pair<std::optional<Expr<SomeType>>, std::vector<DynamicType>>,
1820	false> {
1821	using Result =
1822	std::pair<std::optional<Expr<SomeType>>, std::vector<DynamicType>>;
1823	using Base = Traverse<ConvertCollector, Result, false>;
1824	ConvertCollector() : Base(*this) {}
1825
1826	Result Default() const { return {}; }
1827
1828	using Base::operator();
1829
1830	template <typename T> Result operator()(const Designator<T> &x) const {
1831	return {AsSomeExpr(x), {}};
1832	}
1833
1834	template <typename T> Result operator()(const FunctionRef<T> &x) const {
1835	return {AsSomeExpr(x), {}};
1836	}
1837
1838	template <typename T> Result operator()(const Constant<T> &x) const {
1839	return {AsSomeExpr(x), {}};
1840	}
1841
1842	template <typename D, typename R, typename... Os>
1843	Result operator()(const Operation<D, R, Os...> &x) const {
1844	if constexpr (std::is_same_v<D, Parentheses<R>>) {
1845	// Ignore parentheses.
1846	return (*this)(x.template operand<0>());
1847	} else if constexpr (is_convert_v<D>) {
1848	// Convert should always have a typed result, so it should be safe to
1849	// dereference x.GetType().
1850	return Combine(
1851	{std::nullopt, {*x.GetType()}}, (*this)(x.template operand<0>()));
1852	} else if constexpr (is_complex_constructor_v<D>) {
1853	// This is a conversion iff the imaginary operand is 0.
1854	if (IsZero(x.template operand<1>())) {
1855	return Combine(
1856	{std::nullopt, {*x.GetType()}}, (*this)(x.template operand<0>()));
1857	} else {
1858	return {AsSomeExpr(x.derived()), {}};
1859	}
1860	} else {
1861	return {AsSomeExpr(x.derived()), {}};
1862	}
1863	}
1864
1865	template <typename... Rs>
1866	Result Combine(Result &&result, Rs &&...results) const {
1867	Result v(std::move(result));
1868	auto setValue{[](std::optional<Expr<SomeType>> &x,
1869	std::optional<Expr<SomeType>> &&y) {
1870	assert((!x.has_value() || !y.has_value()) && "Multiple designators");
1871	if (!x.has_value()) {
1872	x = std::move(y);
1873	}
1874	}};
1875	auto moveAppend{[](auto &accum, auto &&other) {
1876	for (auto &&s : other) {
1877	accum.push_back(std::move(s));
1878	}
1879	}};
1880	(setValue(v.first, std::move(results).first), ...);
1881	(moveAppend(v.second, std::move(results).second), ...);
1882	return v;
1883	}
1884
1885	private:
1886	template <typename A> static bool IsZero(const A &x) { return false; }
1887	template <typename T> static bool IsZero(const Expr<T> &x) {
1888	return common::visit([](auto &&s) { return IsZero(s); }, x.u);
1889	}
1890	template <typename T> static bool IsZero(const Constant<T> &x) {
1891	if (auto &&maybeScalar{x.GetScalarValue()}) {
1892	return maybeScalar->IsZero();
1893	} else {
1894	return false;
1895	}
1896	}
1897
1898	template <typename T> struct is_convert {
1899	static constexpr bool value{false};
1900	};
1901	template <typename T, common::TypeCategory C>
1902	struct is_convert<Convert<T, C>> {
1903	static constexpr bool value{true};
1904	};
1905	template <int K> struct is_convert<ComplexComponent<K>> {
1906	// Conversion from complex to real.
1907	static constexpr bool value{true};
1908	};
1909	template <typename T>
1910	static constexpr bool is_convert_v{is_convert<T>::value};
1911
1912	template <typename T> struct is_complex_constructor {
1913	static constexpr bool value{false};
1914	};
1915	template <int K> struct is_complex_constructor<ComplexConstructor<K>> {
1916	static constexpr bool value{true};
1917	};
1918	template <typename T>
1919	static constexpr bool is_complex_constructor_v{
1920	is_complex_constructor<T>::value};
1921	};
1922	} // namespace operation
1923
1924	std::optional<Expr<SomeType>> GetConvertInput(const Expr<SomeType> &x) {
1925	// This returns Expr<SomeType>{x} when x is a designator/functionref/constant.
1926	return operation::ConvertCollector{}(x).first;
1927	}
1928
1929	bool IsSameOrConvertOf(const Expr<SomeType> &expr, const Expr<SomeType> &x) {
1930	// Check if expr is same as x, or a sequence of Convert operations on x.
1931	if (expr == x) {
1932	return true;
1933	} else if (auto maybe{GetConvertInput(expr)}) {
1934	return *maybe == x;
1935	} else {
1936	return false;
1937	}
1938	}
1939	} // namespace Fortran::evaluate
1940
1941	namespace Fortran::semantics {
1942
1943	const Symbol &ResolveAssociations(
1944	const Symbol &original, bool stopAtTypeGuard) {
1945	const Symbol &symbol{original.GetUltimate()};
1946	if (const auto *details{symbol.detailsIf<AssocEntityDetails>()}) {
1947	if (!details->rank() /* not RANK(n) or RANK(*) */ &&
1948	!(stopAtTypeGuard && details->isTypeGuard())) {
1949	if (const Symbol * nested{UnwrapWholeSymbolDataRef(details->expr())}) {
1950	return ResolveAssociations(*nested);
1951	}
1952	}
1953	}
1954	return symbol;
1955	}
1956
1957	// When a construct association maps to a variable, and that variable
1958	// is not an array with a vector-valued subscript, return the base
1959	// Symbol of that variable, else nullptr. Descends into other construct
1960	// associations when one associations maps to another.
1961	static const Symbol *GetAssociatedVariable(const AssocEntityDetails &details) {
1962	if (const auto &expr{details.expr()}) {
1963	if (IsVariable(*expr) && !HasVectorSubscript(*expr)) {
1964	if (const Symbol * varSymbol{GetFirstSymbol(*expr)}) {
1965	return &GetAssociationRoot(*varSymbol);
1966	}
1967	}
1968	}
1969	return nullptr;
1970	}
1971
1972	const Symbol &GetAssociationRoot(const Symbol &original, bool stopAtTypeGuard) {
1973	const Symbol &symbol{ResolveAssociations(original, stopAtTypeGuard)};
1974	if (const auto *details{symbol.detailsIf<AssocEntityDetails>()}) {
1975	if (const Symbol * root{GetAssociatedVariable(*details)}) {
1976	return *root;
1977	}
1978	}
1979	return symbol;
1980	}
1981
1982	const Symbol *GetMainEntry(const Symbol *symbol) {
1983	if (symbol) {
1984	if (const auto *subpDetails{symbol->detailsIf<SubprogramDetails>()}) {
1985	if (const Scope * scope{subpDetails->entryScope()}) {
1986	if (const Symbol * main{scope->symbol()}) {
1987	return main;
1988	}
1989	}
1990	}
1991	}
1992	return symbol;
1993	}
1994
1995	bool IsVariableName(const Symbol &original) {
1996	const Symbol &ultimate{original.GetUltimate()};
1997	return !IsNamedConstant(ultimate) &&
1998	(ultimate.has<ObjectEntityDetails>() ||
1999	ultimate.has<AssocEntityDetails>());
2000	}
2001
2002	static bool IsPureProcedureImpl(
2003	const Symbol &original, semantics::UnorderedSymbolSet &set) {
2004	// An ENTRY is pure if its containing subprogram is
2005	const Symbol &symbol{DEREF(GetMainEntry(&original.GetUltimate()))};
2006	if (set.find(symbol) != set.end()) {
2007	return true;
2008	}
2009	set.emplace(symbol);
2010	if (const auto *procDetails{symbol.detailsIf<ProcEntityDetails>()}) {
2011	if (procDetails->procInterface()) {
2012	// procedure with a pure interface
2013	return IsPureProcedureImpl(*procDetails->procInterface(), set);
2014	}
2015	} else if (const auto *details{symbol.detailsIf<ProcBindingDetails>()}) {
2016	return IsPureProcedureImpl(details->symbol(), set);
2017	} else if (!IsProcedure(symbol)) {
2018	return false;
2019	}
2020	if (IsStmtFunction(symbol)) {
2021	// Section 15.7(1) states that a statement function is PURE if it does not
2022	// reference an IMPURE procedure or a VOLATILE variable
2023	if (const auto &expr{symbol.get<SubprogramDetails>().stmtFunction()}) {
2024	for (const SymbolRef &ref : evaluate::CollectSymbols(*expr)) {
2025	if (&*ref == &symbol) {
2026	return false; // error recovery, recursion is caught elsewhere
2027	}
2028	if (IsFunction(*ref) && !IsPureProcedureImpl(*ref, set)) {
2029	return false;
2030	}
2031	if (ref->GetUltimate().attrs().test(Attr::VOLATILE)) {
2032	return false;
2033	}
2034	}
2035	}
2036	return true; // statement function was not found to be impure
2037	}
2038	return symbol.attrs().test(Attr::PURE) ||
2039	(symbol.attrs().test(Attr::ELEMENTAL) &&
2040	!symbol.attrs().test(Attr::IMPURE));
2041	}
2042
2043	bool IsPureProcedure(const Symbol &original) {
2044	semantics::UnorderedSymbolSet set;
2045	return IsPureProcedureImpl(original, set);
2046	}
2047
2048	bool IsPureProcedure(const Scope &scope) {
2049	const Symbol *symbol{scope.GetSymbol()};
2050	return symbol && IsPureProcedure(*symbol);
2051	}
2052
2053	bool IsExplicitlyImpureProcedure(const Symbol &original) {
2054	// An ENTRY is IMPURE if its containing subprogram is so
2055	return DEREF(GetMainEntry(&original.GetUltimate()))
2056	.attrs()
2057	.test(Attr::IMPURE);
2058	}
2059
2060	bool IsElementalProcedure(const Symbol &original) {
2061	// An ENTRY is elemental if its containing subprogram is
2062	const Symbol &symbol{DEREF(GetMainEntry(&original.GetUltimate()))};
2063	if (IsProcedure(symbol)) {
2064	auto &foldingContext{symbol.owner().context().foldingContext()};
2065	auto restorer{foldingContext.messages().DiscardMessages()};
2066	auto proc{evaluate::characteristics::Procedure::Characterize(
2067	symbol, foldingContext)};
2068	return proc &&
2069	proc->attrs.test(evaluate::characteristics::Procedure::Attr::Elemental);
2070	} else {
2071	return false;
2072	}
2073	}
2074
2075	bool IsFunction(const Symbol &symbol) {
2076	const Symbol &ultimate{symbol.GetUltimate()};
2077	return ultimate.test(Symbol::Flag::Function) ||
2078	(!ultimate.test(Symbol::Flag::Subroutine) &&
2079	common::visit(
2080	common::visitors{
2081	[](const SubprogramDetails &x) { return x.isFunction(); },
2082	[](const ProcEntityDetails &x) {
2083	const Symbol *ifc{x.procInterface()};
2084	return x.type() || (ifc && IsFunction(*ifc));
2085	},
2086	[](const ProcBindingDetails &x) {
2087	return IsFunction(x.symbol());
2088	},
2089	[](const auto &) { return false; },
2090	},
2091	ultimate.details()));
2092	}
2093
2094	bool IsFunction(const Scope &scope) {
2095	const Symbol *symbol{scope.GetSymbol()};
2096	return symbol && IsFunction(*symbol);
2097	}
2098
2099	bool IsProcedure(const Symbol &symbol) {
2100	return common::visit(common::visitors{
2101	[&symbol](const SubprogramDetails &) {
2102	const Scope *scope{symbol.scope()};
2103	// Main programs & BLOCK DATA are not procedures.
2104	return !scope ||
2105	scope->kind() == Scope::Kind::Subprogram;
2106	},
2107	[](const SubprogramNameDetails &) { return true; },
2108	[](const ProcEntityDetails &) { return true; },
2109	[](const GenericDetails &) { return true; },
2110	[](const ProcBindingDetails &) { return true; },
2111	[](const auto &) { return false; },
2112	},
2113	symbol.GetUltimate().details());
2114	}
2115
2116	bool IsProcedure(const Scope &scope) {
2117	const Symbol *symbol{scope.GetSymbol()};
2118	return symbol && IsProcedure(*symbol);
2119	}
2120
2121	bool IsProcedurePointer(const Symbol &original) {
2122	const Symbol &symbol{GetAssociationRoot(original)};
2123	return IsPointer(symbol) && IsProcedure(symbol);
2124	}
2125
2126	bool IsProcedurePointer(const Symbol *symbol) {
2127	return symbol && IsProcedurePointer(*symbol);
2128	}
2129
2130	bool IsObjectPointer(const Symbol *original) {
2131	if (original) {
2132	const Symbol &symbol{GetAssociationRoot(*original)};
2133	return IsPointer(symbol) && !IsProcedure(symbol);
2134	} else {
2135	return false;
2136	}
2137	}
2138
2139	bool IsAllocatableOrObjectPointer(const Symbol *original) {
2140	if (original) {
2141	const Symbol &ultimate{original->GetUltimate()};
2142	if (const auto *assoc{ultimate.detailsIf<AssocEntityDetails>()}) {
2143	// Only SELECT RANK construct entities can be ALLOCATABLE/POINTER.
2144	return (assoc->rank() || assoc->IsAssumedSize() ||
2145	assoc->IsAssumedRank()) &&
2146	IsAllocatableOrObjectPointer(UnwrapWholeSymbolDataRef(assoc->expr()));
2147	} else {
2148	return IsAllocatable(ultimate) ||
2149	(IsPointer(ultimate) && !IsProcedure(ultimate));
2150	}
2151	} else {
2152	return false;
2153	}
2154	}
2155
2156	const Symbol *FindCommonBlockContaining(const Symbol &original) {
2157	const Symbol &root{GetAssociationRoot(original)};
2158	const auto *details{root.detailsIf<ObjectEntityDetails>()};
2159	return details ? details->commonBlock() : nullptr;
2160	}
2161
2162	// 3.11 automatic data object
2163	bool IsAutomatic(const Symbol &original) {
2164	const Symbol &symbol{original.GetUltimate()};
2165	if (const auto *object{symbol.detailsIf<ObjectEntityDetails>()}) {
2166	if (!object->isDummy() && !IsAllocatable(symbol) && !IsPointer(symbol)) {
2167	if (const DeclTypeSpec * type{symbol.GetType()}) {
2168	// If a type parameter value is not a constant expression, the
2169	// object is automatic.
2170	if (type->category() == DeclTypeSpec::Character) {
2171	if (const auto &length{
2172	type->characterTypeSpec().length().GetExplicit()}) {
2173	if (!evaluate::IsConstantExpr(*length)) {
2174	return true;
2175	}
2176	}
2177	} else if (const DerivedTypeSpec * derived{type->AsDerived()}) {
2178	for (const auto &pair : derived->parameters()) {
2179	if (const auto &value{pair.second.GetExplicit()}) {
2180	if (!evaluate::IsConstantExpr(*value)) {
2181	return true;
2182	}
2183	}
2184	}
2185	}
2186	}
2187	// If an array bound is not a constant expression, the object is
2188	// automatic.
2189	for (const ShapeSpec &dim : object->shape()) {
2190	if (const auto &lb{dim.lbound().GetExplicit()}) {
2191	if (!evaluate::IsConstantExpr(*lb)) {
2192	return true;
2193	}
2194	}
2195	if (const auto &ub{dim.ubound().GetExplicit()}) {
2196	if (!evaluate::IsConstantExpr(*ub)) {
2197	return true;
2198	}
2199	}
2200	}
2201	}
2202	}
2203	return false;
2204	}
2205
2206	bool IsSaved(const Symbol &original) {
2207	const Symbol &symbol{GetAssociationRoot(original)};
2208	const Scope &scope{symbol.owner()};
2209	const common::LanguageFeatureControl &features{
2210	scope.context().languageFeatures()};
2211	auto scopeKind{scope.kind()};
2212	if (symbol.has<AssocEntityDetails>()) {
2213	return false; // ASSOCIATE(non-variable)
2214	} else if (scopeKind == Scope::Kind::DerivedType) {
2215	return false; // this is a component
2216	} else if (symbol.attrs().test(Attr::SAVE)) {
2217	// explicit or implied SAVE attribute
2218	// N.B.: semantics sets implied SAVE for main program
2219	// local variables whose derived types have coarray
2220	// potential subobject components.
2221	return true;
2222	} else if (IsDummy(symbol) || IsFunctionResult(symbol) ||
2223	IsAutomatic(symbol) || IsNamedConstant(symbol)) {
2224	return false;
2225	} else if (scopeKind == Scope::Kind::Module ||
2226	(scopeKind == Scope::Kind::MainProgram &&
2227	(symbol.attrs().test(Attr::TARGET) || evaluate::IsCoarray(symbol)))) {
2228	// 8.5.16p4
2229	// In main programs, implied SAVE matters only for pointer
2230	// initialization targets and coarrays.
2231	return true;
2232	} else if (scopeKind == Scope::Kind::MainProgram &&
2233	(features.IsEnabled(common::LanguageFeature::SaveMainProgram) ||
2234	(features.IsEnabled(
2235	common::LanguageFeature::SaveBigMainProgramVariables) &&
2236	symbol.size() > 32))) {
2237	// With SaveBigMainProgramVariables, keeping all unsaved main program
2238	// variables of 32 bytes or less on the stack allows keeping numerical and
2239	// logical scalars, small scalar characters or derived, small arrays, and
2240	// scalar descriptors on the stack. This leaves more room for lower level
2241	// optimizers to do register promotion or get easy aliasing information.
2242	return true;
2243	} else if (features.IsEnabled(common::LanguageFeature::DefaultSave) &&
2244	(scopeKind == Scope::Kind::MainProgram ||
2245	(scope.kind() == Scope::Kind::Subprogram &&
2246	!(scope.symbol() &&
2247	scope.symbol()->attrs().test(Attr::RECURSIVE))))) {
2248	// -fno-automatic/-save/-Msave option applies to all objects in executable
2249	// main programs and subprograms unless they are explicitly RECURSIVE.
2250	return true;
2251	} else if (symbol.test(Symbol::Flag::InDataStmt)) {
2252	return true;
2253	} else if (const auto *object{symbol.detailsIf<ObjectEntityDetails>()};
2254	object && object->init()) {
2255	return true;
2256	} else if (IsProcedurePointer(symbol) && symbol.has<ProcEntityDetails>() &&
2257	symbol.get<ProcEntityDetails>().init()) {
2258	return true;
2259	} else if (scope.hasSAVE()) {
2260	return true; // bare SAVE statement
2261	} else if (const Symbol *block{FindCommonBlockContaining(symbol)};
2262	block && block->attrs().test(Attr::SAVE)) {
2263	return true; // in COMMON with SAVE
2264	} else {
2265	return false;
2266	}
2267	}
2268
2269	bool IsDummy(const Symbol &symbol) {
2270	return common::visit(
2271	common::visitors{[](const EntityDetails &x) { return x.isDummy(); },
2272	[](const ObjectEntityDetails &x) { return x.isDummy(); },
2273	[](const ProcEntityDetails &x) { return x.isDummy(); },
2274	[](const SubprogramDetails &x) { return x.isDummy(); },
2275	[](const auto &) { return false; }},
2276	ResolveAssociations(symbol).details());
2277	}
2278
2279	bool IsAssumedShape(const Symbol &symbol) {
2280	const Symbol &ultimate{ResolveAssociations(symbol)};
2281	const auto *object{ultimate.detailsIf<ObjectEntityDetails>()};
2282	return object && object->IsAssumedShape() &&
2283	!semantics::IsAllocatableOrObjectPointer(&ultimate);
2284	}
2285
2286	bool IsDeferredShape(const Symbol &symbol) {
2287	const Symbol &ultimate{ResolveAssociations(symbol)};
2288	const auto *object{ultimate.detailsIf<ObjectEntityDetails>()};
2289	return object && object->CanBeDeferredShape() &&
2290	semantics::IsAllocatableOrObjectPointer(&ultimate);
2291	}
2292
2293	bool IsFunctionResult(const Symbol &original) {
2294	const Symbol &symbol{GetAssociationRoot(original)};
2295	return common::visit(
2296	common::visitors{
2297	[](const EntityDetails &x) { return x.isFuncResult(); },
2298	[](const ObjectEntityDetails &x) { return x.isFuncResult(); },
2299	[](const ProcEntityDetails &x) { return x.isFuncResult(); },
2300	[](const auto &) { return false; },
2301	},
2302	symbol.details());
2303	}
2304
2305	bool IsKindTypeParameter(const Symbol &symbol) {
2306	const auto *param{symbol.GetUltimate().detailsIf<TypeParamDetails>()};
2307	return param && param->attr() == common::TypeParamAttr::Kind;
2308	}
2309
2310	bool IsLenTypeParameter(const Symbol &symbol) {
2311	const auto *param{symbol.GetUltimate().detailsIf<TypeParamDetails>()};
2312	return param && param->attr() == common::TypeParamAttr::Len;
2313	}
2314
2315	bool IsExtensibleType(const DerivedTypeSpec *derived) {
2316	return !IsSequenceOrBindCType(derived) && !IsIsoCType(derived);
2317	}
2318
2319	bool IsSequenceOrBindCType(const DerivedTypeSpec *derived) {
2320	return derived &&
2321	(derived->typeSymbol().attrs().test(Attr::BIND_C) ||
2322	derived->typeSymbol().get<DerivedTypeDetails>().sequence());
2323	}
2324
2325	static bool IsSameModule(const Scope *x, const Scope *y) {
2326	if (x == y) {
2327	return true;
2328	} else if (x && y) {
2329	// Allow for a builtin module to be read from distinct paths
2330	const Symbol *xSym{x->symbol()};
2331	const Symbol *ySym{y->symbol()};
2332	if (xSym && ySym && xSym->name() == ySym->name()) {
2333	const auto *xMod{xSym->detailsIf<ModuleDetails>()};
2334	const auto *yMod{ySym->detailsIf<ModuleDetails>()};
2335	if (xMod && yMod) {
2336	auto xHash{xMod->moduleFileHash()};
2337	auto yHash{yMod->moduleFileHash()};
2338	return xHash && yHash && *xHash == *yHash;
2339	}
2340	}
2341	}
2342	return false;
2343	}
2344
2345	bool IsBuiltinDerivedType(const DerivedTypeSpec *derived, const char *name) {
2346	if (derived) {
2347	const auto &symbol{derived->typeSymbol()};
2348	const Scope &scope{symbol.owner()};
2349	return symbol.name() == "__builtin_"s + name &&
2350	IsSameModule(&scope, scope.context().GetBuiltinsScope());
2351	} else {
2352	return false;
2353	}
2354	}
2355
2356	bool IsBuiltinCPtr(const Symbol &symbol) {
2357	if (const DeclTypeSpec *declType = symbol.GetType()) {
2358	if (const DerivedTypeSpec *derived = declType->AsDerived()) {
2359	return IsIsoCType(derived);
2360	}
2361	}
2362	return false;
2363	}
2364
2365	bool IsFromBuiltinModule(const Symbol &symbol) {
2366	const Scope &scope{symbol.GetUltimate().owner()};
2367	return IsSameModule(&scope, scope.context().GetBuiltinsScope());
2368	}
2369
2370	bool IsIsoCType(const DerivedTypeSpec *derived) {
2371	return IsBuiltinDerivedType(derived, "c_ptr") ||
2372	IsBuiltinDerivedType(derived, "c_funptr");
2373	}
2374
2375	bool IsEventType(const DerivedTypeSpec *derived) {
2376	return IsBuiltinDerivedType(derived, "event_type");
2377	}
2378
2379	bool IsLockType(const DerivedTypeSpec *derived) {
2380	return IsBuiltinDerivedType(derived, "lock_type");
2381	}
2382
2383	bool IsNotifyType(const DerivedTypeSpec *derived) {
2384	return IsBuiltinDerivedType(derived, "notify_type");
2385	}
2386
2387	bool IsIeeeFlagType(const DerivedTypeSpec *derived) {
2388	return IsBuiltinDerivedType(derived, "ieee_flag_type");
2389	}
2390
2391	bool IsIeeeRoundType(const DerivedTypeSpec *derived) {
2392	return IsBuiltinDerivedType(derived, "ieee_round_type");
2393	}
2394
2395	bool IsTeamType(const DerivedTypeSpec *derived) {
2396	return IsBuiltinDerivedType(derived, "team_type");
2397	}
2398
2399	bool IsBadCoarrayType(const DerivedTypeSpec *derived) {
2400	return IsTeamType(derived) || IsIsoCType(derived);
2401	}
2402
2403	bool IsEventTypeOrLockType(const DerivedTypeSpec *derivedTypeSpec) {
2404	return IsEventType(derivedTypeSpec) || IsLockType(derivedTypeSpec);
2405	}
2406
2407	int CountLenParameters(const DerivedTypeSpec &type) {
2408	return llvm::count_if(
2409	type.parameters(), [](const auto &pair) { return pair.second.isLen(); });
2410	}
2411
2412	int CountNonConstantLenParameters(const DerivedTypeSpec &type) {
2413	return llvm::count_if(type.parameters(), [](const auto &pair) {
2414	if (!pair.second.isLen()) {
2415	return false;
2416	} else if (const auto &expr{pair.second.GetExplicit()}) {
2417	return !IsConstantExpr(*expr);
2418	} else {
2419	return true;
2420	}
2421	});
2422	}
2423
2424	const Symbol &GetUsedModule(const UseDetails &details) {
2425	return DEREF(details.symbol().owner().symbol());
2426	}
2427
2428	static const Symbol *FindFunctionResult(
2429	const Symbol &original, UnorderedSymbolSet &seen) {
2430	const Symbol &root{GetAssociationRoot(original)};
2431	;
2432	if (!seen.insert(root).second) {
2433	return nullptr; // don't loop
2434	}
2435	return common::visit(
2436	common::visitors{[](const SubprogramDetails &subp) {
2437	return subp.isFunction() ? &subp.result() : nullptr;
2438	},
2439	[&](const ProcEntityDetails &proc) {
2440	const Symbol *iface{proc.procInterface()};
2441	return iface ? FindFunctionResult(*iface, seen) : nullptr;
2442	},
2443	[&](const ProcBindingDetails &binding) {
2444	return FindFunctionResult(binding.symbol(), seen);
2445	},
2446	[](const auto &) -> const Symbol * { return nullptr; }},
2447	root.details());
2448	}
2449
2450	const Symbol *FindFunctionResult(const Symbol &symbol) {
2451	UnorderedSymbolSet seen;
2452	return FindFunctionResult(symbol, seen);
2453	}
2454
2455	// These are here in Evaluate/tools.cpp so that Evaluate can use
2456	// them; they cannot be defined in symbol.h due to the dependence
2457	// on Scope.
2458
2459	bool SymbolSourcePositionCompare::operator()(
2460	const SymbolRef &x, const SymbolRef &y) const {
2461	return x->GetSemanticsContext().allCookedSources().Precedes(
2462	x->name(), y->name());
2463	}
2464	bool SymbolSourcePositionCompare::operator()(
2465	const MutableSymbolRef &x, const MutableSymbolRef &y) const {
2466	return x->GetSemanticsContext().allCookedSources().Precedes(
2467	x->name(), y->name());
2468	}
2469
2470	SemanticsContext &Symbol::GetSemanticsContext() const {
2471	return DEREF(owner_).context();
2472	}
2473
2474	bool AreTkCompatibleTypes(const DeclTypeSpec *x, const DeclTypeSpec *y) {
2475	if (x && y) {
2476	if (auto xDt{evaluate::DynamicType::From(*x)}) {
2477	if (auto yDt{evaluate::DynamicType::From(*y)}) {
2478	return xDt->IsTkCompatibleWith(*yDt);
2479	}
2480	}
2481	}
2482	return false;
2483	}
2484
2485	common::IgnoreTKRSet GetIgnoreTKR(const Symbol &symbol) {
2486	common::IgnoreTKRSet result;
2487	if (const auto *object{symbol.detailsIf<ObjectEntityDetails>()}) {
2488	result = object->ignoreTKR();
2489	if (const Symbol * ownerSymbol{symbol.owner().symbol()}) {
2490	if (const auto *ownerSubp{ownerSymbol->detailsIf<SubprogramDetails>()}) {
2491	if (ownerSubp->defaultIgnoreTKR()) {
2492	result |= common::ignoreTKRAll;
2493	}
2494	}
2495	}
2496	}
2497	return result;
2498	}
2499
2500	std::optional<int> GetDummyArgumentNumber(const Symbol *symbol) {
2501	if (symbol) {
2502	if (IsDummy(*symbol)) {
2503	if (const Symbol * subpSym{symbol->owner().symbol()}) {
2504	if (const auto *subp{subpSym->detailsIf<SubprogramDetails>()}) {
2505	int j{0};
2506	for (const Symbol *dummy : subp->dummyArgs()) {
2507	if (dummy == symbol) {
2508	return j;
2509	}
2510	++j;
2511	}
2512	}
2513	}
2514	}
2515	}
2516	return std::nullopt;
2517	}
2518
2519	// Given a symbol that is a SubprogramNameDetails in a submodule, try to
2520	// find its interface definition in its module or ancestor submodule.
2521	const Symbol *FindAncestorModuleProcedure(const Symbol *symInSubmodule) {
2522	if (symInSubmodule && symInSubmodule->owner().IsSubmodule()) {
2523	if (const auto *nameDetails{
2524	symInSubmodule->detailsIf<semantics::SubprogramNameDetails>()};
2525	nameDetails &&
2526	nameDetails->kind() == semantics::SubprogramKind::Module) {
2527	const Symbol *next{symInSubmodule->owner().symbol()};
2528	while (const Symbol * submodSym{next}) {
2529	next = nullptr;
2530	if (const auto *modDetails{
2531	submodSym->detailsIf<semantics::ModuleDetails>()};
2532	modDetails && modDetails->isSubmodule() && modDetails->scope()) {
2533	if (const semantics::Scope & parent{modDetails->scope()->parent()};
2534	parent.IsSubmodule() || parent.IsModule()) {
2535	if (auto iter{parent.find(symInSubmodule->name())};
2536	iter != parent.end()) {
2537	const Symbol &proc{iter->second->GetUltimate()};
2538	if (IsProcedure(proc)) {
2539	return &proc;
2540	}
2541	} else if (parent.IsSubmodule()) {
2542	next = parent.symbol();
2543	}
2544	}
2545	}
2546	}
2547	}
2548	}
2549	return nullptr;
2550	}
2551
2552	} // namespace Fortran::semantics
2553