1	//===-- lib/Evaluate/tools.cpp --------------------------------------------===//
2	//
3	// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
4	// See https://llvm.org/LICENSE.txt for license information.
5	// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
6	//
7	//===----------------------------------------------------------------------===//
8
9	#include "flang/Evaluate/tools.h"
10	#include "flang/Common/idioms.h"
11	#include "flang/Evaluate/characteristics.h"
12	#include "flang/Evaluate/traverse.h"
13	#include "flang/Parser/message.h"
14	#include "flang/Semantics/tools.h"
15	#include <algorithm>
16	#include <variant>
17
18	using namespace Fortran::parser::literals;
19
20	namespace Fortran::evaluate {
21
22	// Can x*(a,b) be represented as (x*a,x*b)? This code duplication
23	// of the subexpression "x" cannot (yet?) be reliably undone by
24	// common subexpression elimination in lowering, so it's disabled
25	// here for now to avoid the risk of potential duplication of
26	// expensive subexpressions (e.g., large array expressions, references
27	// to expensive functions) in generate code.
28	static constexpr bool allowOperandDuplication{false};
29
30	std::optional<Expr<SomeType>> AsGenericExpr(DataRef &&ref) {
31	const Symbol &symbol{ref.GetLastSymbol()};
32	if (auto dyType{DynamicType::From(symbol)}) {
33	return TypedWrapper<Designator, DataRef>(*dyType, std::move(ref));
34	}
35	return std::nullopt;
36	}
37
38	std::optional<Expr<SomeType>> AsGenericExpr(const Symbol &symbol) {
39	return AsGenericExpr(DataRef{symbol});
40	}
41
42	Expr<SomeType> Parenthesize(Expr<SomeType> &&expr) {
43	return common::visit(
44	[&](auto &&x) {
45	using T = std::decay_t<decltype(x)>;
46	if constexpr (common::HasMember<T, TypelessExpression>) {
47	return expr; // no parentheses around typeless
48	} else if constexpr (std::is_same_v<T, Expr<SomeDerived>>) {
49	return AsGenericExpr(Parentheses<SomeDerived>{std::move(x)});
50	} else {
51	return common::visit(
52	[](auto &&y) {
53	using T = ResultType<decltype(y)>;
54	return AsGenericExpr(Parentheses<T>{std::move(y)});
55	},
56	std::move(x.u));
57	}
58	},
59	std::move(expr.u));
60	}
61
62	std::optional<DataRef> ExtractDataRef(
63	const ActualArgument &arg, bool intoSubstring, bool intoComplexPart) {
64	return ExtractDataRef(arg.UnwrapExpr(), intoSubstring, intoComplexPart);
65	}
66
67	std::optional<DataRef> ExtractSubstringBase(const Substring &substring) {
68	return common::visit(
69	common::visitors{
70	[&](const DataRef &x) -> std::optional<DataRef> { return x; },
71	[&](const StaticDataObject::Pointer &) -> std::optional<DataRef> {
72	return std::nullopt;
73	},
74	},
75	substring.parent());
76	}
77
78	// IsVariable()
79
80	auto IsVariableHelper::operator()(const Symbol &symbol) const -> Result {
81	// ASSOCIATE(x => expr) -- x counts as a variable, but undefinable
82	const Symbol &ultimate{symbol.GetUltimate()};
83	return !IsNamedConstant(ultimate) &&
84	(ultimate.has<semantics::ObjectEntityDetails>() ||
85	ultimate.has<semantics::AssocEntityDetails>());
86	}
87	auto IsVariableHelper::operator()(const Component &x) const -> Result {
88	const Symbol &comp{x.GetLastSymbol()};
89	return (*this)(comp) && (IsPointer(comp) || (*this)(x.base()));
90	}
91	auto IsVariableHelper::operator()(const ArrayRef &x) const -> Result {
92	return (*this)(x.base());
93	}
94	auto IsVariableHelper::operator()(const Substring &x) const -> Result {
95	return (*this)(x.GetBaseObject());
96	}
97	auto IsVariableHelper::operator()(const ProcedureDesignator &x) const
98	-> Result {
99	if (const Symbol * symbol{x.GetSymbol()}) {
100	const Symbol *result{FindFunctionResult(*symbol)};
101	return result && IsPointer(*result) && !IsProcedurePointer(*result);
102	}
103	return false;
104	}
105
106	// Conversions of COMPLEX component expressions to REAL.
107	ConvertRealOperandsResult ConvertRealOperands(
108	parser::ContextualMessages &messages, Expr<SomeType> &&x,
109	Expr<SomeType> &&y, int defaultRealKind) {
110	return common::visit(
111	common::visitors{
112	[&](Expr<SomeInteger> &&ix,
113	Expr<SomeInteger> &&iy) -> ConvertRealOperandsResult {
114	// Can happen in a CMPLX() constructor. Per F'2018,
115	// both integer operands are converted to default REAL.
116	return {AsSameKindExprs<TypeCategory::Real>(
117	ConvertToKind<TypeCategory::Real>(
118	defaultRealKind, std::move(ix)),
119	ConvertToKind<TypeCategory::Real>(
120	defaultRealKind, std::move(iy)))};
121	},
122	[&](Expr<SomeInteger> &&ix,
123	Expr<SomeReal> &&ry) -> ConvertRealOperandsResult {
124	return {AsSameKindExprs<TypeCategory::Real>(
125	ConvertTo(ry, std::move(ix)), std::move(ry))};
126	},
127	[&](Expr<SomeReal> &&rx,
128	Expr<SomeInteger> &&iy) -> ConvertRealOperandsResult {
129	return {AsSameKindExprs<TypeCategory::Real>(
130	std::move(rx), ConvertTo(rx, std::move(iy)))};
131	},
132	[&](Expr<SomeReal> &&rx,
133	Expr<SomeReal> &&ry) -> ConvertRealOperandsResult {
134	return {AsSameKindExprs<TypeCategory::Real>(
135	std::move(rx), std::move(ry))};
136	},
137	[&](Expr<SomeInteger> &&ix,
138	BOZLiteralConstant &&by) -> ConvertRealOperandsResult {
139	return {AsSameKindExprs<TypeCategory::Real>(
140	ConvertToKind<TypeCategory::Real>(
141	defaultRealKind, std::move(ix)),
142	ConvertToKind<TypeCategory::Real>(
143	defaultRealKind, std::move(by)))};
144	},
145	[&](BOZLiteralConstant &&bx,
146	Expr<SomeInteger> &&iy) -> ConvertRealOperandsResult {
147	return {AsSameKindExprs<TypeCategory::Real>(
148	ConvertToKind<TypeCategory::Real>(
149	defaultRealKind, std::move(bx)),
150	ConvertToKind<TypeCategory::Real>(
151	defaultRealKind, std::move(iy)))};
152	},
153	[&](Expr<SomeReal> &&rx,
154	BOZLiteralConstant &&by) -> ConvertRealOperandsResult {
155	return {AsSameKindExprs<TypeCategory::Real>(
156	std::move(rx), ConvertTo(rx, std::move(by)))};
157	},
158	[&](BOZLiteralConstant &&bx,
159	Expr<SomeReal> &&ry) -> ConvertRealOperandsResult {
160	return {AsSameKindExprs<TypeCategory::Real>(
161	ConvertTo(ry, std::move(bx)), std::move(ry))};
162	},
163	[&](auto &&, auto &&) -> ConvertRealOperandsResult { // C718
164	messages.Say("operands must be INTEGER or REAL"_err_en_US);
165	return std::nullopt;
166	},
167	},
168	std::move(x.u), std::move(y.u));
169	}
170
171	// Helpers for NumericOperation and its subroutines below.
172	static std::optional<Expr<SomeType>> NoExpr() { return std::nullopt; }
173
174	template <TypeCategory CAT>
175	std::optional<Expr<SomeType>> Package(Expr<SomeKind<CAT>> &&catExpr) {
176	return {AsGenericExpr(std::move(catExpr))};
177	}
178	template <TypeCategory CAT>
179	std::optional<Expr<SomeType>> Package(
180	std::optional<Expr<SomeKind<CAT>>> &&catExpr) {
181	if (catExpr) {
182	return {AsGenericExpr(std::move(*catExpr))};
183	} else {
184	return std::nullopt;
185	}
186	}
187
188	// Mixed REAL+INTEGER operations. REAL**INTEGER is a special case that
189	// does not require conversion of the exponent expression.
190	template <template <typename> class OPR>
191	std::optional<Expr<SomeType>> MixedRealLeft(
192	Expr<SomeReal> &&rx, Expr<SomeInteger> &&iy) {
193	return Package(common::visit(
194	[&](auto &&rxk) -> Expr<SomeReal> {
195	using resultType = ResultType<decltype(rxk)>;
196	if constexpr (std::is_same_v<OPR<resultType>, Power<resultType>>) {
197	return AsCategoryExpr(
198	RealToIntPower<resultType>{std::move(rxk), std::move(iy)});
199	}
200	// G++ 8.1.0 emits bogus warnings about missing return statements if
201	// this statement is wrapped in an "else", as it should be.
202	return AsCategoryExpr(OPR<resultType>{
203	std::move(rxk), ConvertToType<resultType>(std::move(iy))});
204	},
205	std::move(rx.u)));
206	}
207
208	template <int KIND>
209	Expr<SomeComplex> MakeComplex(Expr<Type<TypeCategory::Real, KIND>> &&re,
210	Expr<Type<TypeCategory::Real, KIND>> &&im) {
211	return AsCategoryExpr(ComplexConstructor<KIND>{std::move(re), std::move(im)});
212	}
213
214	std::optional<Expr<SomeComplex>> ConstructComplex(
215	parser::ContextualMessages &messages, Expr<SomeType> &&real,
216	Expr<SomeType> &&imaginary, int defaultRealKind) {
217	if (auto converted{ConvertRealOperands(
218	messages, std::move(real), std::move(imaginary), defaultRealKind)}) {
219	return {common::visit(
220	[](auto &&pair) {
221	return MakeComplex(std::move(pair[0]), std::move(pair[1]));
222	},
223	std::move(*converted))};
224	}
225	return std::nullopt;
226	}
227
228	std::optional<Expr<SomeComplex>> ConstructComplex(
229	parser::ContextualMessages &messages, std::optional<Expr<SomeType>> &&real,
230	std::optional<Expr<SomeType>> &&imaginary, int defaultRealKind) {
231	if (auto parts{common::AllPresent(std::move(real), std::move(imaginary))}) {
232	return ConstructComplex(messages, std::get<0>(std::move(*parts)),
233	std::get<1>(std::move(*parts)), defaultRealKind);
234	}
235	return std::nullopt;
236	}
237
238	// Extracts the real or imaginary part of the result of a COMPLEX
239	// expression, when that expression is simple enough to be duplicated.
240	template <bool GET_IMAGINARY> struct ComplexPartExtractor {
241	template <typename A> static std::optional<Expr<SomeReal>> Get(const A &) {
242	return std::nullopt;
243	}
244
245	template <int KIND>
246	static std::optional<Expr<SomeReal>> Get(
247	const Parentheses<Type<TypeCategory::Complex, KIND>> &kz) {
248	if (auto x{Get(kz.left())}) {
249	return AsGenericExpr(AsSpecificExpr(
250	Parentheses<Type<TypeCategory::Real, KIND>>{std::move(*x)}));
251	} else {
252	return std::nullopt;
253	}
254	}
255
256	template <int KIND>
257	static std::optional<Expr<SomeReal>> Get(
258	const Negate<Type<TypeCategory::Complex, KIND>> &kz) {
259	if (auto x{Get(kz.left())}) {
260	return AsGenericExpr(AsSpecificExpr(
261	Negate<Type<TypeCategory::Real, KIND>>{std::move(*x)}));
262	} else {
263	return std::nullopt;
264	}
265	}
266
267	template <int KIND>
268	static std::optional<Expr<SomeReal>> Get(
269	const Convert<Type<TypeCategory::Complex, KIND>, TypeCategory::Complex>
270	&kz) {
271	if (auto x{Get(kz.left())}) {
272	return AsGenericExpr(AsSpecificExpr(
273	Convert<Type<TypeCategory::Real, KIND>, TypeCategory::Real>{
274	AsGenericExpr(std::move(*x))}));
275	} else {
276	return std::nullopt;
277	}
278	}
279
280	template <int KIND>
281	static std::optional<Expr<SomeReal>> Get(const ComplexConstructor<KIND> &kz) {
282	return GET_IMAGINARY ? Get(kz.right()) : Get(kz.left());
283	}
284
285	template <int KIND>
286	static std::optional<Expr<SomeReal>> Get(
287	const Constant<Type<TypeCategory::Complex, KIND>> &kz) {
288	if (auto cz{kz.GetScalarValue()}) {
289	return AsGenericExpr(
290	AsSpecificExpr(GET_IMAGINARY ? cz->AIMAG() : cz->REAL()));
291	} else {
292	return std::nullopt;
293	}
294	}
295
296	template <int KIND>
297	static std::optional<Expr<SomeReal>> Get(
298	const Designator<Type<TypeCategory::Complex, KIND>> &kz) {
299	if (const auto *symbolRef{std::get_if<SymbolRef>(&kz.u)}) {
300	return AsGenericExpr(AsSpecificExpr(
301	Designator<Type<TypeCategory::Complex, KIND>>{ComplexPart{
302	DataRef{*symbolRef},
303	GET_IMAGINARY ? ComplexPart::Part::IM : ComplexPart::Part::RE}}));
304	} else {
305	return std::nullopt;
306	}
307	}
308
309	template <int KIND>
310	static std::optional<Expr<SomeReal>> Get(
311	const Expr<Type<TypeCategory::Complex, KIND>> &kz) {
312	return Get(kz.u);
313	}
314
315	static std::optional<Expr<SomeReal>> Get(const Expr<SomeComplex> &z) {
316	return Get(z.u);
317	}
318	};
319
320	// Convert REAL to COMPLEX of the same kind. Preserving the real operand kind
321	// and then applying complex operand promotion rules allows the result to have
322	// the highest precision of REAL and COMPLEX operands as required by Fortran
323	// 2018 10.9.1.3.
324	Expr<SomeComplex> PromoteRealToComplex(Expr<SomeReal> &&someX) {
325	return common::visit(
326	[](auto &&x) {
327	using RT = ResultType<decltype(x)>;
328	return AsCategoryExpr(ComplexConstructor<RT::kind>{
329	std::move(x), AsExpr(Constant<RT>{Scalar<RT>{}})});
330	},
331	std::move(someX.u));
332	}
333
334	// Handle mixed COMPLEX+REAL (or INTEGER) operations in a better way
335	// than just converting the second operand to COMPLEX and performing the
336	// corresponding COMPLEX+COMPLEX operation.
337	template <template <typename> class OPR, TypeCategory RCAT>
338	std::optional<Expr<SomeType>> MixedComplexLeft(
339	parser::ContextualMessages &messages, const Expr<SomeComplex> &zx,
340	const Expr<SomeKind<RCAT>> &iry, [[maybe_unused]] int defaultRealKind) {
341	if constexpr (RCAT == TypeCategory::Integer &&
342	std::is_same_v<OPR<LargestReal>, Power<LargestReal>>) {
343	// COMPLEX**INTEGER is a special case that doesn't convert the exponent.
344	return Package(common::visit(
345	[&](const auto &zxk) {
346	using Ty = ResultType<decltype(zxk)>;
347	return AsCategoryExpr(AsExpr(
348	RealToIntPower<Ty>{common::Clone(zxk), common::Clone(iry)}));
349	},
350	zx.u));
351	}
352	std::optional<Expr<SomeReal>> zr{ComplexPartExtractor<false>{}.Get(zx)};
353	std::optional<Expr<SomeReal>> zi{ComplexPartExtractor<true>{}.Get(zx)};
354	if (!zr || !zi) {
355	} else if constexpr (std::is_same_v<OPR<LargestReal>, Add<LargestReal>> ||
356	std::is_same_v<OPR<LargestReal>, Subtract<LargestReal>>) {
357	// (a,b) + x -> (a+x, b)
358	// (a,b) - x -> (a-x, b)
359	if (std::optional<Expr<SomeType>> rr{
360	NumericOperation<OPR>(messages, AsGenericExpr(std::move(*zr)),
361	AsGenericExpr(common::Clone(iry)), defaultRealKind)}) {
362	return Package(ConstructComplex(messages, std::move(*rr),
363	AsGenericExpr(std::move(*zi)), defaultRealKind));
364	}
365	} else if constexpr (allowOperandDuplication &&
366	(std::is_same_v<OPR<LargestReal>, Multiply<LargestReal>> ||
367	std::is_same_v<OPR<LargestReal>, Divide<LargestReal>>)) {
368	// (a,b) * x -> (a*x, b*x)
369	// (a,b) / x -> (a/x, b/x)
370	auto copy{iry};
371	auto rr{NumericOperation<OPR>(messages, AsGenericExpr(std::move(*zr)),
372	AsGenericExpr(common::Clone(iry)), defaultRealKind)};
373	auto ri{NumericOperation<OPR>(messages, AsGenericExpr(std::move(*zi)),
374	AsGenericExpr(std::move(copy)), defaultRealKind)};
375	if (auto parts{common::AllPresent(std::move(rr), std::move(ri))}) {
376	return Package(ConstructComplex(messages, std::get<0>(std::move(*parts)),
377	std::get<1>(std::move(*parts)), defaultRealKind));
378	}
379	}
380	return std::nullopt;
381	}
382
383	// Mixed COMPLEX operations with the COMPLEX operand on the right.
384	// x + (a,b) -> (x+a, b)
385	// x - (a,b) -> (x-a, -b)
386	// x * (a,b) -> (x*a, x*b)
387	// x / (a,b) -> (x,0) / (a,b) (and **)
388	template <template <typename> class OPR, TypeCategory LCAT>
389	std::optional<Expr<SomeType>> MixedComplexRight(
390	parser::ContextualMessages &messages, const Expr<SomeKind<LCAT>> &irx,
391	const Expr<SomeComplex> &zy, [[maybe_unused]] int defaultRealKind) {
392	if constexpr (std::is_same_v<OPR<LargestReal>, Add<LargestReal>>) {
393	// x + (a,b) -> (a,b) + x -> (a+x, b)
394	return MixedComplexLeft<OPR, LCAT>(messages, zy, irx, defaultRealKind);
395	} else if constexpr (allowOperandDuplication &&
396	std::is_same_v<OPR<LargestReal>, Multiply<LargestReal>>) {
397	// x * (a,b) -> (a,b) * x -> (a*x, b*x)
398	return MixedComplexLeft<OPR, LCAT>(messages, zy, irx, defaultRealKind);
399	} else if constexpr (std::is_same_v<OPR<LargestReal>,
400	Subtract<LargestReal>>) {
401	// x - (a,b) -> (x-a, -b)
402	std::optional<Expr<SomeReal>> zr{ComplexPartExtractor<false>{}.Get(zy)};
403	std::optional<Expr<SomeReal>> zi{ComplexPartExtractor<true>{}.Get(zy)};
404	if (zr && zi) {
405	if (std::optional<Expr<SomeType>> rr{NumericOperation<Subtract>(messages,
406	AsGenericExpr(common::Clone(irx)), AsGenericExpr(std::move(*zr)),
407	defaultRealKind)}) {
408	return Package(ConstructComplex(messages, std::move(*rr),
409	AsGenericExpr(-std::move(*zi)), defaultRealKind));
410	}
411	}
412	}
413	return std::nullopt;
414	}
415
416	// Promotes REAL(rk) and COMPLEX(zk) operands COMPLEX(max(rk,zk))
417	// then combine them with an operator.
418	template <template <typename> class OPR, TypeCategory XCAT, TypeCategory YCAT>
419	Expr<SomeComplex> PromoteMixedComplexReal(
420	Expr<SomeKind<XCAT>> &&x, Expr<SomeKind<YCAT>> &&y) {
421	static_assert(XCAT == TypeCategory::Complex || YCAT == TypeCategory::Complex);
422	static_assert(XCAT == TypeCategory::Real || YCAT == TypeCategory::Real);
423	return common::visit(
424	[&](const auto &kx, const auto &ky) {
425	constexpr int maxKind{std::max(
426	ResultType<decltype(kx)>::kind, ResultType<decltype(ky)>::kind)};
427	using ZTy = Type<TypeCategory::Complex, maxKind>;
428	return Expr<SomeComplex>{
429	Expr<ZTy>{OPR<ZTy>{ConvertToType<ZTy>(std::move(x)),
430	ConvertToType<ZTy>(std::move(y))}}};
431	},
432	x.u, y.u);
433	}
434
435	// N.B. When a "typeless" BOZ literal constant appears as one (not both!) of
436	// the operands to a dyadic operation where one is permitted, it assumes the
437	// type and kind of the other operand.
438	template <template <typename> class OPR>
439	std::optional<Expr<SomeType>> NumericOperation(
440	parser::ContextualMessages &messages, Expr<SomeType> &&x,
441	Expr<SomeType> &&y, int defaultRealKind) {
442	return common::visit(
443	common::visitors{
444	[](Expr<SomeInteger> &&ix, Expr<SomeInteger> &&iy) {
445	return Package(PromoteAndCombine<OPR, TypeCategory::Integer>(
446	std::move(ix), std::move(iy)));
447	},
448	[](Expr<SomeReal> &&rx, Expr<SomeReal> &&ry) {
449	return Package(PromoteAndCombine<OPR, TypeCategory::Real>(
450	std::move(rx), std::move(ry)));
451	},
452	// Mixed REAL/INTEGER operations
453	[](Expr<SomeReal> &&rx, Expr<SomeInteger> &&iy) {
454	return MixedRealLeft<OPR>(std::move(rx), std::move(iy));
455	},
456	[](Expr<SomeInteger> &&ix, Expr<SomeReal> &&ry) {
457	return Package(common::visit(
458	[&](auto &&ryk) -> Expr<SomeReal> {
459	using resultType = ResultType<decltype(ryk)>;
460	return AsCategoryExpr(
461	OPR<resultType>{ConvertToType<resultType>(std::move(ix)),
462	std::move(ryk)});
463	},
464	std::move(ry.u)));
465	},
466	// Homogeneous and mixed COMPLEX operations
467	[](Expr<SomeComplex> &&zx, Expr<SomeComplex> &&zy) {
468	return Package(PromoteAndCombine<OPR, TypeCategory::Complex>(
469	std::move(zx), std::move(zy)));
470	},
471	[&](Expr<SomeComplex> &&zx, Expr<SomeInteger> &&iy) {
472	if (auto result{
473	MixedComplexLeft<OPR>(messages, zx, iy, defaultRealKind)}) {
474	return result;
475	} else {
476	return Package(PromoteAndCombine<OPR, TypeCategory::Complex>(
477	std::move(zx), ConvertTo(zx, std::move(iy))));
478	}
479	},
480	[&](Expr<SomeComplex> &&zx, Expr<SomeReal> &&ry) {
481	if (auto result{
482	MixedComplexLeft<OPR>(messages, zx, ry, defaultRealKind)}) {
483	return result;
484	} else {
485	return Package(
486	PromoteMixedComplexReal<OPR>(std::move(zx), std::move(ry)));
487	}
488	},
489	[&](Expr<SomeInteger> &&ix, Expr<SomeComplex> &&zy) {
490	if (auto result{MixedComplexRight<OPR>(
491	messages, ix, zy, defaultRealKind)}) {
492	return result;
493	} else {
494	return Package(PromoteAndCombine<OPR, TypeCategory::Complex>(
495	ConvertTo(zy, std::move(ix)), std::move(zy)));
496	}
497	},
498	[&](Expr<SomeReal> &&rx, Expr<SomeComplex> &&zy) {
499	if (auto result{MixedComplexRight<OPR>(
500	messages, rx, zy, defaultRealKind)}) {
501	return result;
502	} else {
503	return Package(
504	PromoteMixedComplexReal<OPR>(std::move(rx), std::move(zy)));
505	}
506	},
507	// Operations with one typeless operand
508	[&](BOZLiteralConstant &&bx, Expr<SomeInteger> &&iy) {
509	return NumericOperation<OPR>(messages,
510	AsGenericExpr(ConvertTo(iy, std::move(bx))), std::move(y),
511	defaultRealKind);
512	},
513	[&](BOZLiteralConstant &&bx, Expr<SomeReal> &&ry) {
514	return NumericOperation<OPR>(messages,
515	AsGenericExpr(ConvertTo(ry, std::move(bx))), std::move(y),
516	defaultRealKind);
517	},
518	[&](Expr<SomeInteger> &&ix, BOZLiteralConstant &&by) {
519	return NumericOperation<OPR>(messages, std::move(x),
520	AsGenericExpr(ConvertTo(ix, std::move(by))), defaultRealKind);
521	},
522	[&](Expr<SomeReal> &&rx, BOZLiteralConstant &&by) {
523	return NumericOperation<OPR>(messages, std::move(x),
524	AsGenericExpr(ConvertTo(rx, std::move(by))), defaultRealKind);
525	},
526	// Default case
527	[&](auto &&, auto &&) {
528	messages.Say("non-numeric operands to numeric operation"_err_en_US);
529	return NoExpr();
530	},
531	},
532	std::move(x.u), std::move(y.u));
533	}
534
535	template std::optional<Expr<SomeType>> NumericOperation<Power>(
536	parser::ContextualMessages &, Expr<SomeType> &&, Expr<SomeType> &&,
537	int defaultRealKind);
538	template std::optional<Expr<SomeType>> NumericOperation<Multiply>(
539	parser::ContextualMessages &, Expr<SomeType> &&, Expr<SomeType> &&,
540	int defaultRealKind);
541	template std::optional<Expr<SomeType>> NumericOperation<Divide>(
542	parser::ContextualMessages &, Expr<SomeType> &&, Expr<SomeType> &&,
543	int defaultRealKind);
544	template std::optional<Expr<SomeType>> NumericOperation<Add>(
545	parser::ContextualMessages &, Expr<SomeType> &&, Expr<SomeType> &&,
546	int defaultRealKind);
547	template std::optional<Expr<SomeType>> NumericOperation<Subtract>(
548	parser::ContextualMessages &, Expr<SomeType> &&, Expr<SomeType> &&,
549	int defaultRealKind);
550
551	std::optional<Expr<SomeType>> Negation(
552	parser::ContextualMessages &messages, Expr<SomeType> &&x) {
553	return common::visit(
554	common::visitors{
555	[&](BOZLiteralConstant &&) {
556	messages.Say("BOZ literal cannot be negated"_err_en_US);
557	return NoExpr();
558	},
559	[&](NullPointer &&) {
560	messages.Say("NULL() cannot be negated"_err_en_US);
561	return NoExpr();
562	},
563	[&](ProcedureDesignator &&) {
564	messages.Say("Subroutine cannot be negated"_err_en_US);
565	return NoExpr();
566	},
567	[&](ProcedureRef &&) {
568	messages.Say("Pointer to subroutine cannot be negated"_err_en_US);
569	return NoExpr();
570	},
571	[&](Expr<SomeInteger> &&x) { return Package(-std::move(x)); },
572	[&](Expr<SomeReal> &&x) { return Package(-std::move(x)); },
573	[&](Expr<SomeComplex> &&x) { return Package(-std::move(x)); },
574	[&](Expr<SomeCharacter> &&) {
575	messages.Say("CHARACTER cannot be negated"_err_en_US);
576	return NoExpr();
577	},
578	[&](Expr<SomeLogical> &&) {
579	messages.Say("LOGICAL cannot be negated"_err_en_US);
580	return NoExpr();
581	},
582	[&](Expr<SomeDerived> &&) {
583	messages.Say("Operand cannot be negated"_err_en_US);
584	return NoExpr();
585	},
586	},
587	std::move(x.u));
588	}
589
590	Expr<SomeLogical> LogicalNegation(Expr<SomeLogical> &&x) {
591	return common::visit(
592	[](auto &&xk) { return AsCategoryExpr(LogicalNegation(std::move(xk))); },
593	std::move(x.u));
594	}
595
596	template <TypeCategory CAT>
597	Expr<LogicalResult> PromoteAndRelate(
598	RelationalOperator opr, Expr<SomeKind<CAT>> &&x, Expr<SomeKind<CAT>> &&y) {
599	return common::visit(
600	[=](auto &&xy) {
601	return PackageRelation(opr, std::move(xy[0]), std::move(xy[1]));
602	},
603	AsSameKindExprs(std::move(x), std::move(y)));
604	}
605
606	std::optional<Expr<LogicalResult>> Relate(parser::ContextualMessages &messages,
607	RelationalOperator opr, Expr<SomeType> &&x, Expr<SomeType> &&y) {
608	return common::visit(
609	common::visitors{
610	[=](Expr<SomeInteger> &&ix,
611	Expr<SomeInteger> &&iy) -> std::optional<Expr<LogicalResult>> {
612	return PromoteAndRelate(opr, std::move(ix), std::move(iy));
613	},
614	[=](Expr<SomeReal> &&rx,
615	Expr<SomeReal> &&ry) -> std::optional<Expr<LogicalResult>> {
616	return PromoteAndRelate(opr, std::move(rx), std::move(ry));
617	},
618	[&](Expr<SomeReal> &&rx, Expr<SomeInteger> &&iy) {
619	return Relate(messages, opr, std::move(x),
620	AsGenericExpr(ConvertTo(rx, std::move(iy))));
621	},
622	[&](Expr<SomeInteger> &&ix, Expr<SomeReal> &&ry) {
623	return Relate(messages, opr,
624	AsGenericExpr(ConvertTo(ry, std::move(ix))), std::move(y));
625	},
626	[&](Expr<SomeComplex> &&zx,
627	Expr<SomeComplex> &&zy) -> std::optional<Expr<LogicalResult>> {
628	if (opr == RelationalOperator::EQ ||
629	opr == RelationalOperator::NE) {
630	return PromoteAndRelate(opr, std::move(zx), std::move(zy));
631	} else {
632	messages.Say(
633	"COMPLEX data may be compared only for equality"_err_en_US);
634	return std::nullopt;
635	}
636	},
637	[&](Expr<SomeComplex> &&zx, Expr<SomeInteger> &&iy) {
638	return Relate(messages, opr, std::move(x),
639	AsGenericExpr(ConvertTo(zx, std::move(iy))));
640	},
641	[&](Expr<SomeComplex> &&zx, Expr<SomeReal> &&ry) {
642	return Relate(messages, opr, std::move(x),
643	AsGenericExpr(ConvertTo(zx, std::move(ry))));
644	},
645	[&](Expr<SomeInteger> &&ix, Expr<SomeComplex> &&zy) {
646	return Relate(messages, opr,
647	AsGenericExpr(ConvertTo(zy, std::move(ix))), std::move(y));
648	},
649	[&](Expr<SomeReal> &&rx, Expr<SomeComplex> &&zy) {
650	return Relate(messages, opr,
651	AsGenericExpr(ConvertTo(zy, std::move(rx))), std::move(y));
652	},
653	[&](Expr<SomeCharacter> &&cx, Expr<SomeCharacter> &&cy) {
654	return common::visit(
655	[&](auto &&cxk,
656	auto &&cyk) -> std::optional<Expr<LogicalResult>> {
657	using Ty = ResultType<decltype(cxk)>;
658	if constexpr (std::is_same_v<Ty, ResultType<decltype(cyk)>>) {
659	return PackageRelation(opr, std::move(cxk), std::move(cyk));
660	} else {
661	messages.Say(
662	"CHARACTER operands do not have same KIND"_err_en_US);
663	return std::nullopt;
664	}
665	},
666	std::move(cx.u), std::move(cy.u));
667	},
668	// Default case
669	[&](auto &&, auto &&) {
670	DIE("invalid types for relational operator");
671	return std::optional<Expr<LogicalResult>>{};
672	},
673	},
674	std::move(x.u), std::move(y.u));
675	}
676
677	Expr<SomeLogical> BinaryLogicalOperation(
678	LogicalOperator opr, Expr<SomeLogical> &&x, Expr<SomeLogical> &&y) {
679	CHECK(opr != LogicalOperator::Not);
680	return common::visit(
681	[=](auto &&xy) {
682	using Ty = ResultType<decltype(xy[0])>;
683	return Expr<SomeLogical>{BinaryLogicalOperation<Ty::kind>(
684	opr, std::move(xy[0]), std::move(xy[1]))};
685	},
686	AsSameKindExprs(std::move(x), std::move(y)));
687	}
688
689	template <TypeCategory TO>
690	std::optional<Expr<SomeType>> ConvertToNumeric(int kind, Expr<SomeType> &&x) {
691	static_assert(common::IsNumericTypeCategory(TO));
692	return common::visit(
693	[=](auto &&cx) -> std::optional<Expr<SomeType>> {
694	using cxType = std::decay_t<decltype(cx)>;
695	if constexpr (!common::HasMember<cxType, TypelessExpression>) {
696	if constexpr (IsNumericTypeCategory(ResultType<cxType>::category)) {
697	return Expr<SomeType>{ConvertToKind<TO>(kind, std::move(cx))};
698	}
699	}
700	return std::nullopt;
701	},
702	std::move(x.u));
703	}
704
705	std::optional<Expr<SomeType>> ConvertToType(
706	const DynamicType &type, Expr<SomeType> &&x) {
707	if (type.IsTypelessIntrinsicArgument()) {
708	return std::nullopt;
709	}
710	switch (type.category()) {
711	case TypeCategory::Integer:
712	if (auto *boz{std::get_if<BOZLiteralConstant>(&x.u)}) {
713	// Extension to C7109: allow BOZ literals to appear in integer contexts
714	// when the type is unambiguous.
715	return Expr<SomeType>{
716	ConvertToKind<TypeCategory::Integer>(type.kind(), std::move(*boz))};
717	}
718	return ConvertToNumeric<TypeCategory::Integer>(type.kind(), std::move(x));
719	case TypeCategory::Real:
720	if (auto *boz{std::get_if<BOZLiteralConstant>(&x.u)}) {
721	return Expr<SomeType>{
722	ConvertToKind<TypeCategory::Real>(type.kind(), std::move(*boz))};
723	}
724	return ConvertToNumeric<TypeCategory::Real>(type.kind(), std::move(x));
725	case TypeCategory::Complex:
726	return ConvertToNumeric<TypeCategory::Complex>(type.kind(), std::move(x));
727	case TypeCategory::Character:
728	if (auto *cx{UnwrapExpr<Expr<SomeCharacter>>(x)}) {
729	auto converted{
730	ConvertToKind<TypeCategory::Character>(type.kind(), std::move(*cx))};
731	if (auto length{type.GetCharLength()}) {
732	converted = common::visit(
733	[&](auto &&x) {
734	using CharacterType = ResultType<decltype(x)>;
735	return Expr<SomeCharacter>{
736	Expr<CharacterType>{SetLength<CharacterType::kind>{
737	std::move(x), std::move(*length)}}};
738	},
739	std::move(converted.u));
740	}
741	return Expr<SomeType>{std::move(converted)};
742	}
743	break;
744	case TypeCategory::Logical:
745	if (auto *cx{UnwrapExpr<Expr<SomeLogical>>(x)}) {
746	return Expr<SomeType>{
747	ConvertToKind<TypeCategory::Logical>(type.kind(), std::move(*cx))};
748	}
749	break;
750	case TypeCategory::Derived:
751	if (auto fromType{x.GetType()}) {
752	if (type.IsTkCompatibleWith(*fromType)) {
753	// "x" could be assigned or passed to "type", or appear in a
754	// structure constructor as a value for a component with "type"
755	return std::move(x);
756	}
757	}
758	break;
759	}
760	return std::nullopt;
761	}
762
763	std::optional<Expr<SomeType>> ConvertToType(
764	const DynamicType &to, std::optional<Expr<SomeType>> &&x) {
765	if (x) {
766	return ConvertToType(to, std::move(*x));
767	} else {
768	return std::nullopt;
769	}
770	}
771
772	std::optional<Expr<SomeType>> ConvertToType(
773	const Symbol &symbol, Expr<SomeType> &&x) {
774	if (auto symType{DynamicType::From(symbol)}) {
775	return ConvertToType(*symType, std::move(x));
776	}
777	return std::nullopt;
778	}
779
780	std::optional<Expr<SomeType>> ConvertToType(
781	const Symbol &to, std::optional<Expr<SomeType>> &&x) {
782	if (x) {
783	return ConvertToType(to, std::move(*x));
784	} else {
785	return std::nullopt;
786	}
787	}
788
789	bool IsAssumedRank(const Symbol &original) {
790	if (const auto *assoc{original.detailsIf<semantics::AssocEntityDetails>()}) {
791	if (assoc->rank()) {
792	return false; // in RANK(n) or RANK(*)
793	} else if (assoc->IsAssumedRank()) {
794	return true; // RANK DEFAULT
795	}
796	}
797	const Symbol &symbol{semantics::ResolveAssociations(original)};
798	const auto *object{symbol.detailsIf<semantics::ObjectEntityDetails>()};
799	return object && object->IsAssumedRank();
800	}
801
802	bool IsAssumedRank(const ActualArgument &arg) {
803	if (const auto *expr{arg.UnwrapExpr()}) {
804	return IsAssumedRank(*expr);
805	} else {
806	const Symbol *assumedTypeDummy{arg.GetAssumedTypeDummy()};
807	CHECK(assumedTypeDummy);
808	return IsAssumedRank(*assumedTypeDummy);
809	}
810	}
811
812	bool IsCoarray(const ActualArgument &arg) {
813	const auto *expr{arg.UnwrapExpr()};
814	return expr && IsCoarray(*expr);
815	}
816
817	bool IsCoarray(const Symbol &symbol) {
818	return GetAssociationRoot(symbol).Corank() > 0;
819	}
820
821	bool IsProcedure(const Expr<SomeType> &expr) {
822	return std::holds_alternative<ProcedureDesignator>(expr.u);
823	}
824	bool IsFunction(const Expr<SomeType> &expr) {
825	const auto *designator{std::get_if<ProcedureDesignator>(&expr.u)};
826	return designator && designator->GetType().has_value();
827	}
828
829	bool IsPointer(const Expr<SomeType> &expr) {
830	return IsObjectPointer(expr) || IsProcedurePointer(expr);
831	}
832
833	bool IsProcedurePointer(const Expr<SomeType> &expr) {
834	if (IsNullProcedurePointer(expr)) {
835	return true;
836	} else if (const auto *funcRef{UnwrapProcedureRef(expr)}) {
837	if (const Symbol * proc{funcRef->proc().GetSymbol()}) {
838	const Symbol *result{FindFunctionResult(*proc)};
839	return result && IsProcedurePointer(*result);
840	} else {
841	return false;
842	}
843	} else if (const auto *proc{std::get_if<ProcedureDesignator>(&expr.u)}) {
844	return IsProcedurePointer(proc->GetSymbol());
845	} else {
846	return false;
847	}
848	}
849
850	bool IsProcedurePointerTarget(const Expr<SomeType> &expr) {
851	return common::visit(common::visitors{
852	[](const NullPointer &) { return true; },
853	[](const ProcedureDesignator &) { return true; },
854	[](const ProcedureRef &) { return true; },
855	[&](const auto &) {
856	const Symbol *last{GetLastSymbol(expr)};
857	return last && IsProcedurePointer(*last);
858	},
859	},
860	expr.u);
861	}
862
863	bool IsObjectPointer(const Expr<SomeType> &expr) {
864	if (IsNullObjectPointer(expr)) {
865	return true;
866	} else if (IsProcedurePointerTarget(expr)) {
867	return false;
868	} else if (const auto *funcRef{UnwrapProcedureRef(expr)}) {
869	return IsVariable(*funcRef);
870	} else if (const Symbol * symbol{UnwrapWholeSymbolOrComponentDataRef(expr)}) {
871	return IsPointer(symbol->GetUltimate());
872	} else {
873	return false;
874	}
875	}
876
877	// IsNullPointer() & variations
878
879	template <bool IS_PROC_PTR> struct IsNullPointerHelper {
880	template <typename A> bool operator()(const A &) const { return false; }
881	bool operator()(const ProcedureRef &call) const {
882	if constexpr (IS_PROC_PTR) {
883	const auto *intrinsic{call.proc().GetSpecificIntrinsic()};
884	return intrinsic &&
885	intrinsic->characteristics.value().attrs.test(
886	characteristics::Procedure::Attr::NullPointer);
887	} else {
888	return false;
889	}
890	}
891	template <typename T> bool operator()(const FunctionRef<T> &call) const {
892	if constexpr (IS_PROC_PTR) {
893	return false;
894	} else {
895	const auto *intrinsic{call.proc().GetSpecificIntrinsic()};
896	return intrinsic &&
897	intrinsic->characteristics.value().attrs.test(
898	characteristics::Procedure::Attr::NullPointer);
899	}
900	}
901	template <typename T> bool operator()(const Designator<T> &x) const {
902	if (const auto *component{std::get_if<Component>(&x.u)}) {
903	if (const auto *baseSym{std::get_if<SymbolRef>(&component->base().u)}) {
904	const Symbol &base{**baseSym};
905	if (const auto *object{
906	base.detailsIf<semantics::ObjectEntityDetails>()}) {
907	// TODO: nested component and array references
908	if (IsNamedConstant(base) && object->init()) {
909	if (auto structCons{
910	GetScalarConstantValue<SomeDerived>(*object->init())}) {
911	auto iter{structCons->values().find(component->GetLastSymbol())};
912	if (iter != structCons->values().end()) {
913	return (*this)(iter->second.value());
914	}
915	}
916	}
917	}
918	}
919	}
920	return false;
921	}
922	bool operator()(const NullPointer &) const { return true; }
923	template <typename T> bool operator()(const Parentheses<T> &x) const {
924	return (*this)(x.left());
925	}
926	template <typename T> bool operator()(const Expr<T> &x) const {
927	return common::visit(*this, x.u);
928	}
929	};
930
931	bool IsNullObjectPointer(const Expr<SomeType> &expr) {
932	return IsNullPointerHelper<false>{}(expr);
933	}
934
935	bool IsNullProcedurePointer(const Expr<SomeType> &expr) {
936	return IsNullPointerHelper<true>{}(expr);
937	}
938
939	bool IsNullPointer(const Expr<SomeType> &expr) {
940	return IsNullObjectPointer(expr) || IsNullProcedurePointer(expr);
941	}
942
943	bool IsBareNullPointer(const Expr<SomeType> *expr) {
944	return expr && std::holds_alternative<NullPointer>(expr->u);
945	}
946
947	// GetSymbolVector()
948	auto GetSymbolVectorHelper::operator()(const Symbol &x) const -> Result {
949	if (const auto *details{x.detailsIf<semantics::AssocEntityDetails>()}) {
950	if (IsVariable(details->expr()) && !UnwrapProcedureRef(*details->expr())) {
951	// associate(x => variable that is not a pointer returned by a function)
952	return (*this)(details->expr());
953	}
954	}
955	return {x.GetUltimate()};
956	}
957	auto GetSymbolVectorHelper::operator()(const Component &x) const -> Result {
958	Result result{(*this)(x.base())};
959	result.emplace_back(x.GetLastSymbol());
960	return result;
961	}
962	auto GetSymbolVectorHelper::operator()(const ArrayRef &x) const -> Result {
963	return GetSymbolVector(x.base());
964	}
965	auto GetSymbolVectorHelper::operator()(const CoarrayRef &x) const -> Result {
966	return x.base();
967	}
968
969	const Symbol *GetLastTarget(const SymbolVector &symbols) {
970	auto end{std::crend(symbols)};
971	// N.B. Neither clang nor g++ recognizes "symbols.crbegin()" here.
972	auto iter{std::find_if(std::crbegin(symbols), end, [](const Symbol &x) {
973	return x.attrs().HasAny(
974	{semantics::Attr::POINTER, semantics::Attr::TARGET});
975	})};
976	return iter == end ? nullptr : &**iter;
977	}
978
979	struct CollectSymbolsHelper
980	: public SetTraverse<CollectSymbolsHelper, semantics::UnorderedSymbolSet> {
981	using Base = SetTraverse<CollectSymbolsHelper, semantics::UnorderedSymbolSet>;
982	CollectSymbolsHelper() : Base{*this} {}
983	using Base::operator();
984	semantics::UnorderedSymbolSet operator()(const Symbol &symbol) const {
985	return {symbol};
986	}
987	};
988	template <typename A> semantics::UnorderedSymbolSet CollectSymbols(const A &x) {
989	return CollectSymbolsHelper{}(x);
990	}
991	template semantics::UnorderedSymbolSet CollectSymbols(const Expr<SomeType> &);
992	template semantics::UnorderedSymbolSet CollectSymbols(
993	const Expr<SomeInteger> &);
994	template semantics::UnorderedSymbolSet CollectSymbols(
995	const Expr<SubscriptInteger> &);
996
997	// HasVectorSubscript()
998	struct HasVectorSubscriptHelper
999	: public AnyTraverse<HasVectorSubscriptHelper, bool,
1000	/*TraverseAssocEntityDetails=*/false> {
1001	using Base = AnyTraverse<HasVectorSubscriptHelper, bool, false>;
1002	HasVectorSubscriptHelper() : Base{*this} {}
1003	using Base::operator();
1004	bool operator()(const Subscript &ss) const {
1005	return !std::holds_alternative<Triplet>(ss.u) && ss.Rank() > 0;
1006	}
1007	bool operator()(const ProcedureRef &) const {
1008	return false; // don't descend into function call arguments
1009	}
1010	};
1011
1012	bool HasVectorSubscript(const Expr<SomeType> &expr) {
1013	return HasVectorSubscriptHelper{}(expr);
1014	}
1015
1016	parser::Message *AttachDeclaration(
1017	parser::Message &message, const Symbol &symbol) {
1018	const Symbol *unhosted{&symbol};
1019	while (
1020	const auto *assoc{unhosted->detailsIf<semantics::HostAssocDetails>()}) {
1021	unhosted = &assoc->symbol();
1022	}
1023	if (const auto *binding{
1024	unhosted->detailsIf<semantics::ProcBindingDetails>()}) {
1025	if (binding->symbol().name() != symbol.name()) {
1026	message.Attach(binding->symbol().name(),
1027	"Procedure '%s' of type '%s' is bound to '%s'"_en_US, symbol.name(),
1028	symbol.owner().GetName().value(), binding->symbol().name());
1029	return &message;
1030	}
1031	unhosted = &binding->symbol();
1032	}
1033	if (const auto *use{symbol.detailsIf<semantics::UseDetails>()}) {
1034	message.Attach(use->location(),
1035	"'%s' is USE-associated with '%s' in module '%s'"_en_US, symbol.name(),
1036	unhosted->name(), GetUsedModule(*use).name());
1037	} else {
1038	message.Attach(
1039	unhosted->name(), "Declaration of '%s'"_en_US, unhosted->name());
1040	}
1041	return &message;
1042	}
1043
1044	parser::Message *AttachDeclaration(
1045	parser::Message *message, const Symbol &symbol) {
1046	return message ? AttachDeclaration(*message, symbol) : nullptr;
1047	}
1048
1049	class FindImpureCallHelper
1050	: public AnyTraverse<FindImpureCallHelper, std::optional<std::string>,
1051	/*TraverseAssocEntityDetails=*/false> {
1052	using Result = std::optional<std::string>;
1053	using Base = AnyTraverse<FindImpureCallHelper, Result, false>;
1054
1055	public:
1056	explicit FindImpureCallHelper(FoldingContext &c) : Base{*this}, context_{c} {}
1057	using Base::operator();
1058	Result operator()(const ProcedureRef &call) const {
1059	if (auto chars{characteristics::Procedure::Characterize(
1060	call.proc(), context_, /*emitError=*/false)}) {
1061	if (chars->attrs.test(characteristics::Procedure::Attr::Pure)) {
1062	return (*this)(call.arguments());
1063	}
1064	}
1065	return call.proc().GetName();
1066	}
1067
1068	private:
1069	FoldingContext &context_;
1070	};
1071
1072	std::optional<std::string> FindImpureCall(
1073	FoldingContext &context, const Expr<SomeType> &expr) {
1074	return FindImpureCallHelper{context}(expr);
1075	}
1076	std::optional<std::string> FindImpureCall(
1077	FoldingContext &context, const ProcedureRef &proc) {
1078	return FindImpureCallHelper{context}(proc);
1079	}
1080
1081	// Common handling for procedure pointer compatibility of left- and right-hand
1082	// sides. Returns nullopt if they're compatible. Otherwise, it returns a
1083	// message that needs to be augmented by the names of the left and right sides
1084	// and the content of the "whyNotCompatible" string.
1085	std::optional<parser::MessageFixedText> CheckProcCompatibility(bool isCall,
1086	const std::optional<characteristics::Procedure> &lhsProcedure,
1087	const characteristics::Procedure *rhsProcedure,
1088	const SpecificIntrinsic *specificIntrinsic, std::string &whyNotCompatible,
1089	std::optional<std::string> &warning, bool ignoreImplicitVsExplicit) {
1090	std::optional<parser::MessageFixedText> msg;
1091	if (!lhsProcedure) {
1092	msg = "In assignment to object %s, the target '%s' is a procedure"
1093	" designator"_err_en_US;
1094	} else if (!rhsProcedure) {
1095	msg = "In assignment to procedure %s, the characteristics of the target"
1096	" procedure '%s' could not be determined"_err_en_US;
1097	} else if (!isCall && lhsProcedure->functionResult &&
1098	rhsProcedure->functionResult &&
1099	!lhsProcedure->functionResult->IsCompatibleWith(
1100	*rhsProcedure->functionResult, &whyNotCompatible)) {
1101	msg =
1102	"Function %s associated with incompatible function designator '%s': %s"_err_en_US;
1103	} else if (lhsProcedure->IsCompatibleWith(*rhsProcedure,
1104	ignoreImplicitVsExplicit, &whyNotCompatible, specificIntrinsic,
1105	&warning)) {
1106	// OK
1107	} else if (isCall) {
1108	msg = "Procedure %s associated with result of reference to function '%s'"
1109	" that is an incompatible procedure pointer: %s"_err_en_US;
1110	} else if (lhsProcedure->IsPure() && !rhsProcedure->IsPure()) {
1111	msg = "PURE procedure %s may not be associated with non-PURE"
1112	" procedure designator '%s'"_err_en_US;
1113	} else if (lhsProcedure->IsFunction() && rhsProcedure->IsSubroutine()) {
1114	msg = "Function %s may not be associated with subroutine"
1115	" designator '%s'"_err_en_US;
1116	} else if (lhsProcedure->IsSubroutine() && rhsProcedure->IsFunction()) {
1117	msg = "Subroutine %s may not be associated with function"
1118	" designator '%s'"_err_en_US;
1119	} else if (lhsProcedure->HasExplicitInterface() &&
1120	!rhsProcedure->HasExplicitInterface()) {
1121	// Section 10.2.2.4, paragraph 3 prohibits associating a procedure pointer
1122	// that has an explicit interface with a procedure whose characteristics
1123	// don't match. That's the case if the target procedure has an implicit
1124	// interface. But this case is allowed by several other compilers as long
1125	// as the explicit interface can be called via an implicit interface.
1126	if (!lhsProcedure->CanBeCalledViaImplicitInterface()) {
1127	msg = "Procedure %s with explicit interface that cannot be called via "
1128	"an implicit interface cannot be associated with procedure "
1129	"designator with an implicit interface"_err_en_US;
1130	}
1131	} else if (!lhsProcedure->HasExplicitInterface() &&
1132	rhsProcedure->HasExplicitInterface()) {
1133	// OK if the target can be called via an implicit interface
1134	if (!rhsProcedure->CanBeCalledViaImplicitInterface() &&
1135	!specificIntrinsic) {
1136	msg = "Procedure %s with implicit interface may not be associated "
1137	"with procedure designator '%s' with explicit interface that "
1138	"cannot be called via an implicit interface"_err_en_US;
1139	}
1140	} else {
1141	msg = "Procedure %s associated with incompatible procedure"
1142	" designator '%s': %s"_err_en_US;
1143	}
1144	return msg;
1145	}
1146
1147	// GetLastPointerSymbol()
1148	static const Symbol *GetLastPointerSymbol(const Symbol &symbol) {
1149	return IsPointer(GetAssociationRoot(symbol)) ? &symbol : nullptr;
1150	}
1151	static const Symbol *GetLastPointerSymbol(const SymbolRef &symbol) {
1152	return GetLastPointerSymbol(*symbol);
1153	}
1154	static const Symbol *GetLastPointerSymbol(const Component &x) {
1155	const Symbol &c{x.GetLastSymbol()};
1156	return IsPointer(c) ? &c : GetLastPointerSymbol(x.base());
1157	}
1158	static const Symbol *GetLastPointerSymbol(const NamedEntity &x) {
1159	const auto *c{x.UnwrapComponent()};
1160	return c ? GetLastPointerSymbol(*c) : GetLastPointerSymbol(x.GetLastSymbol());
1161	}
1162	static const Symbol *GetLastPointerSymbol(const ArrayRef &x) {
1163	return GetLastPointerSymbol(x.base());
1164	}
1165	static const Symbol *GetLastPointerSymbol(const CoarrayRef &x) {
1166	return nullptr;
1167	}
1168	const Symbol *GetLastPointerSymbol(const DataRef &x) {
1169	return common::visit(
1170	[](const auto &y) { return GetLastPointerSymbol(y); }, x.u);
1171	}
1172
1173	template <TypeCategory TO, TypeCategory FROM>
1174	static std::optional<Expr<SomeType>> DataConstantConversionHelper(
1175	FoldingContext &context, const DynamicType &toType,
1176	const Expr<SomeType> &expr) {
1177	DynamicType sizedType{FROM, toType.kind()};
1178	if (auto sized{
1179	Fold(context, ConvertToType(sizedType, Expr<SomeType>{expr}))}) {
1180	if (const auto *someExpr{UnwrapExpr<Expr<SomeKind<FROM>>>(*sized)}) {
1181	return common::visit(
1182	[](const auto &w) -> std::optional<Expr<SomeType>> {
1183	using FromType = ResultType<decltype(w)>;
1184	static constexpr int kind{FromType::kind};
1185	if constexpr (IsValidKindOfIntrinsicType(TO, kind)) {
1186	if (const auto *fromConst{UnwrapExpr<Constant<FromType>>(w)}) {
1187	using FromWordType = typename FromType::Scalar;
1188	using LogicalType = value::Logical<FromWordType::bits>;
1189	using ElementType =
1190	std::conditional_t<TO == TypeCategory::Logical, LogicalType,
1191	typename LogicalType::Word>;
1192	std::vector<ElementType> values;
1193	auto at{fromConst->lbounds()};
1194	auto shape{fromConst->shape()};
1195	for (auto n{GetSize(shape)}; n-- > 0;
1196	fromConst->IncrementSubscripts(at)) {
1197	auto elt{fromConst->At(at)};
1198	if constexpr (TO == TypeCategory::Logical) {
1199	values.emplace_back(std::move(elt));
1200	} else {
1201	values.emplace_back(elt.word());
1202	}
1203	}
1204	return {AsGenericExpr(AsExpr(Constant<Type<TO, kind>>{
1205	std::move(values), std::move(shape)}))};
1206	}
1207	}
1208	return std::nullopt;
1209	},
1210	someExpr->u);
1211	}
1212	}
1213	return std::nullopt;
1214	}
1215
1216	std::optional<Expr<SomeType>> DataConstantConversionExtension(
1217	FoldingContext &context, const DynamicType &toType,
1218	const Expr<SomeType> &expr0) {
1219	Expr<SomeType> expr{Fold(context, Expr<SomeType>{expr0})};
1220	if (!IsActuallyConstant(expr)) {
1221	return std::nullopt;
1222	}
1223	if (auto fromType{expr.GetType()}) {
1224	if (toType.category() == TypeCategory::Logical &&
1225	fromType->category() == TypeCategory::Integer) {
1226	return DataConstantConversionHelper<TypeCategory::Logical,
1227	TypeCategory::Integer>(context, toType, expr);
1228	}
1229	if (toType.category() == TypeCategory::Integer &&
1230	fromType->category() == TypeCategory::Logical) {
1231	return DataConstantConversionHelper<TypeCategory::Integer,
1232	TypeCategory::Logical>(context, toType, expr);
1233	}
1234	}
1235	return std::nullopt;
1236	}
1237
1238	bool IsAllocatableOrPointerObject(const Expr<SomeType> &expr) {
1239	const semantics::Symbol *sym{UnwrapWholeSymbolOrComponentDataRef(expr)};
1240	return (sym &&
1241	semantics::IsAllocatableOrObjectPointer(&sym->GetUltimate())) ||
1242	evaluate::IsObjectPointer(expr);
1243	}
1244
1245	bool IsAllocatableDesignator(const Expr<SomeType> &expr) {
1246	// Allocatable sub-objects are not themselves allocatable (9.5.3.1 NOTE 2).
1247	if (const semantics::Symbol *
1248	sym{UnwrapWholeSymbolOrComponentOrCoarrayRef(expr)}) {
1249	return semantics::IsAllocatable(sym->GetUltimate());
1250	}
1251	return false;
1252	}
1253
1254	bool MayBePassedAsAbsentOptional(const Expr<SomeType> &expr) {
1255	const semantics::Symbol *sym{UnwrapWholeSymbolOrComponentDataRef(expr)};
1256	// 15.5.2.12 1. is pretty clear that an unallocated allocatable/pointer actual
1257	// may be passed to a non-allocatable/non-pointer optional dummy. Note that
1258	// other compilers (like nag, nvfortran, ifort, gfortran and xlf) seems to
1259	// ignore this point in intrinsic contexts (e.g CMPLX argument).
1260	return (sym && semantics::IsOptional(*sym)) ||
1261	IsAllocatableOrPointerObject(expr);
1262	}
1263
1264	std::optional<Expr<SomeType>> HollerithToBOZ(FoldingContext &context,
1265	const Expr<SomeType> &expr, const DynamicType &type) {
1266	if (std::optional<std::string> chValue{GetScalarConstantValue<Ascii>(expr)}) {
1267	// Pad on the right with spaces when short, truncate the right if long.
1268	// TODO: big-endian targets
1269	auto bytes{static_cast<std::size_t>(
1270	ToInt64(type.MeasureSizeInBytes(context, false)).value())};
1271	BOZLiteralConstant bits{0};
1272	for (std::size_t j{0}; j < bytes; ++j) {
1273	char ch{j >= chValue->size() ? ' ' : chValue->at(j)};
1274	BOZLiteralConstant chBOZ{static_cast<unsigned char>(ch)};
1275	bits = bits.IOR(chBOZ.SHIFTL(8 * j));
1276	}
1277	return ConvertToType(type, Expr<SomeType>{bits});
1278	} else {
1279	return std::nullopt;
1280	}
1281	}
1282
1283	// Extracts a whole symbol being used as a bound of a dummy argument,
1284	// possibly wrapped with parentheses or MAX(0, ...).
1285	template <int KIND>
1286	static const Symbol *GetBoundSymbol(
1287	const Expr<Type<TypeCategory::Integer, KIND>> &expr) {
1288	using T = Type<TypeCategory::Integer, KIND>;
1289	return common::visit(
1290	common::visitors{
1291	[](const Extremum<T> &max) -> const Symbol * {
1292	if (max.ordering == Ordering::Greater) {
1293	if (auto zero{ToInt64(max.left())}; zero && *zero == 0) {
1294	return GetBoundSymbol(max.right());
1295	}
1296	}
1297	return nullptr;
1298	},
1299	[](const Parentheses<T> &x) { return GetBoundSymbol(x.left()); },
1300	[](const Designator<T> &x) -> const Symbol * {
1301	if (const auto *ref{std::get_if<SymbolRef>(&x.u)}) {
1302	return &**ref;
1303	}
1304	return nullptr;
1305	},
1306	[](const Convert<T, TypeCategory::Integer> &x) {
1307	return common::visit(
1308	[](const auto &y) -> const Symbol * {
1309	using yType = std::decay_t<decltype(y)>;
1310	using yResult = typename yType::Result;
1311	if constexpr (yResult::kind <= KIND) {
1312	return GetBoundSymbol(y);
1313	} else {
1314	return nullptr;
1315	}
1316	},
1317	x.left().u);
1318	},
1319	[](const auto &) -> const Symbol * { return nullptr; },
1320	},
1321	expr.u);
1322	}
1323
1324	std::optional<bool> AreEquivalentInInterface(
1325	const Expr<SubscriptInteger> &x, const Expr<SubscriptInteger> &y) {
1326	auto xVal{ToInt64(x)};
1327	auto yVal{ToInt64(y)};
1328	if (xVal && yVal) {
1329	return *xVal == *yVal;
1330	} else if (xVal || yVal) {
1331	return false;
1332	}
1333	const Symbol *xSym{GetBoundSymbol(x)};
1334	const Symbol *ySym{GetBoundSymbol(y)};
1335	if (xSym && ySym) {
1336	if (&xSym->GetUltimate() == &ySym->GetUltimate()) {
1337	return true; // USE/host associated same symbol
1338	}
1339	auto xNum{semantics::GetDummyArgumentNumber(xSym)};
1340	auto yNum{semantics::GetDummyArgumentNumber(ySym)};
1341	if (xNum && yNum) {
1342	if (*xNum == *yNum) {
1343	auto xType{DynamicType::From(*xSym)};
1344	auto yType{DynamicType::From(*ySym)};
1345	return xType && yType && xType->IsEquivalentTo(*yType);
1346	}
1347	}
1348	return false;
1349	} else if (xSym || ySym) {
1350	return false;
1351	}
1352	// Neither expression is an integer constant or a whole symbol.
1353	if (x == y) {
1354	return true;
1355	} else {
1356	return std::nullopt; // not sure
1357	}
1358	}
1359
1360	bool CheckForCoindexedObject(parser::ContextualMessages &messages,
1361	const std::optional<ActualArgument> &arg, const std::string &procName,
1362	const std::string &argName) {
1363	if (arg && ExtractCoarrayRef(arg->UnwrapExpr())) {
1364	messages.Say(arg->sourceLocation(),
1365	"'%s' argument to '%s' may not be a coindexed object"_err_en_US,
1366	argName, procName);
1367	return false;
1368	} else {
1369	return true;
1370	}
1371	}
1372
1373	} // namespace Fortran::evaluate
1374
1375	namespace Fortran::semantics {
1376
1377	const Symbol &ResolveAssociations(const Symbol &original) {
1378	const Symbol &symbol{original.GetUltimate()};
1379	if (const auto *details{symbol.detailsIf<AssocEntityDetails>()}) {
1380	if (!details->rank()) { // Not RANK(n) or RANK(*)
1381	if (const Symbol * nested{UnwrapWholeSymbolDataRef(details->expr())}) {
1382	return ResolveAssociations(*nested);
1383	}
1384	}
1385	}
1386	return symbol;
1387	}
1388
1389	// When a construct association maps to a variable, and that variable
1390	// is not an array with a vector-valued subscript, return the base
1391	// Symbol of that variable, else nullptr. Descends into other construct
1392	// associations when one associations maps to another.
1393	static const Symbol *GetAssociatedVariable(const AssocEntityDetails &details) {
1394	if (const auto &expr{details.expr()}) {
1395	if (IsVariable(*expr) && !HasVectorSubscript(*expr)) {
1396	if (const Symbol * varSymbol{GetFirstSymbol(*expr)}) {
1397	return &GetAssociationRoot(*varSymbol);
1398	}
1399	}
1400	}
1401	return nullptr;
1402	}
1403
1404	const Symbol &GetAssociationRoot(const Symbol &original) {
1405	const Symbol &symbol{ResolveAssociations(original)};
1406	if (const auto *details{symbol.detailsIf<AssocEntityDetails>()}) {
1407	if (const Symbol * root{GetAssociatedVariable(*details)}) {
1408	return *root;
1409	}
1410	}
1411	return symbol;
1412	}
1413
1414	const Symbol *GetMainEntry(const Symbol *symbol) {
1415	if (symbol) {
1416	if (const auto *subpDetails{symbol->detailsIf<SubprogramDetails>()}) {
1417	if (const Scope * scope{subpDetails->entryScope()}) {
1418	if (const Symbol * main{scope->symbol()}) {
1419	return main;
1420	}
1421	}
1422	}
1423	}
1424	return symbol;
1425	}
1426
1427	bool IsVariableName(const Symbol &original) {
1428	const Symbol &ultimate{original.GetUltimate()};
1429	return !IsNamedConstant(ultimate) &&
1430	(ultimate.has<ObjectEntityDetails>() ||
1431	ultimate.has<AssocEntityDetails>());
1432	}
1433
1434	static bool IsPureProcedureImpl(
1435	const Symbol &original, semantics::UnorderedSymbolSet &set) {
1436	// An ENTRY is pure if its containing subprogram is
1437	const Symbol &symbol{DEREF(GetMainEntry(&original.GetUltimate()))};
1438	if (set.find(symbol) != set.end()) {
1439	return true;
1440	}
1441	set.emplace(symbol);
1442	if (const auto *procDetails{symbol.detailsIf<ProcEntityDetails>()}) {
1443	if (procDetails->procInterface()) {
1444	// procedure with a pure interface
1445	return IsPureProcedureImpl(*procDetails->procInterface(), set);
1446	}
1447	} else if (const auto *details{symbol.detailsIf<ProcBindingDetails>()}) {
1448	return IsPureProcedureImpl(details->symbol(), set);
1449	} else if (!IsProcedure(symbol)) {
1450	return false;
1451	}
1452	if (IsStmtFunction(symbol)) {
1453	// Section 15.7(1) states that a statement function is PURE if it does not
1454	// reference an IMPURE procedure or a VOLATILE variable
1455	if (const auto &expr{symbol.get<SubprogramDetails>().stmtFunction()}) {
1456	for (const SymbolRef &ref : evaluate::CollectSymbols(*expr)) {
1457	if (&*ref == &symbol) {
1458	return false; // error recovery, recursion is caught elsewhere
1459	}
1460	if (IsFunction(*ref) && !IsPureProcedureImpl(*ref, set)) {
1461	return false;
1462	}
1463	if (ref->GetUltimate().attrs().test(Attr::VOLATILE)) {
1464	return false;
1465	}
1466	}
1467	}
1468	return true; // statement function was not found to be impure
1469	}
1470	return symbol.attrs().test(Attr::PURE) ||
1471	(symbol.attrs().test(Attr::ELEMENTAL) &&
1472	!symbol.attrs().test(Attr::IMPURE));
1473	}
1474
1475	bool IsPureProcedure(const Symbol &original) {
1476	semantics::UnorderedSymbolSet set;
1477	return IsPureProcedureImpl(original, set);
1478	}
1479
1480	bool IsPureProcedure(const Scope &scope) {
1481	const Symbol *symbol{scope.GetSymbol()};
1482	return symbol && IsPureProcedure(*symbol);
1483	}
1484
1485	bool IsExplicitlyImpureProcedure(const Symbol &original) {
1486	// An ENTRY is IMPURE if its containing subprogram is so
1487	return DEREF(GetMainEntry(&original.GetUltimate()))
1488	.attrs()
1489	.test(Attr::IMPURE);
1490	}
1491
1492	bool IsElementalProcedure(const Symbol &original) {
1493	// An ENTRY is elemental if its containing subprogram is
1494	const Symbol &symbol{DEREF(GetMainEntry(&original.GetUltimate()))};
1495	if (IsProcedure(symbol)) {
1496	auto &foldingContext{symbol.owner().context().foldingContext()};
1497	auto restorer{foldingContext.messages().DiscardMessages()};
1498	auto proc{evaluate::characteristics::Procedure::Characterize(
1499	symbol, foldingContext)};
1500	return proc &&
1501	proc->attrs.test(evaluate::characteristics::Procedure::Attr::Elemental);
1502	} else {
1503	return false;
1504	}
1505	}
1506
1507	bool IsFunction(const Symbol &symbol) {
1508	const Symbol &ultimate{symbol.GetUltimate()};
1509	return ultimate.test(Symbol::Flag::Function) ||
1510	(!ultimate.test(Symbol::Flag::Subroutine) &&
1511	common::visit(
1512	common::visitors{
1513	[](const SubprogramDetails &x) { return x.isFunction(); },
1514	[](const ProcEntityDetails &x) {
1515	const Symbol *ifc{x.procInterface()};
1516	return x.type() || (ifc && IsFunction(*ifc));
1517	},
1518	[](const ProcBindingDetails &x) {
1519	return IsFunction(x.symbol());
1520	},
1521	[](const auto &) { return false; },
1522	},
1523	ultimate.details()));
1524	}
1525
1526	bool IsFunction(const Scope &scope) {
1527	const Symbol *symbol{scope.GetSymbol()};
1528	return symbol && IsFunction(*symbol);
1529	}
1530
1531	bool IsProcedure(const Symbol &symbol) {
1532	return common::visit(common::visitors{
1533	[&symbol](const SubprogramDetails &) {
1534	const Scope *scope{symbol.scope()};
1535	// Main programs & BLOCK DATA are not procedures.
1536	return !scope ||
1537	scope->kind() == Scope::Kind::Subprogram;
1538	},
1539	[](const SubprogramNameDetails &) { return true; },
1540	[](const ProcEntityDetails &) { return true; },
1541	[](const GenericDetails &) { return true; },
1542	[](const ProcBindingDetails &) { return true; },
1543	[](const auto &) { return false; },
1544	},
1545	symbol.GetUltimate().details());
1546	}
1547
1548	bool IsProcedure(const Scope &scope) {
1549	const Symbol *symbol{scope.GetSymbol()};
1550	return symbol && IsProcedure(*symbol);
1551	}
1552
1553	bool IsProcedurePointer(const Symbol &original) {
1554	const Symbol &symbol{GetAssociationRoot(original)};
1555	return IsPointer(symbol) && IsProcedure(symbol);
1556	}
1557
1558	bool IsProcedurePointer(const Symbol *symbol) {
1559	return symbol && IsProcedurePointer(*symbol);
1560	}
1561
1562	bool IsObjectPointer(const Symbol *original) {
1563	if (original) {
1564	const Symbol &symbol{GetAssociationRoot(*original)};
1565	return IsPointer(symbol) && !IsProcedure(symbol);
1566	} else {
1567	return false;
1568	}
1569	}
1570
1571	bool IsAllocatableOrObjectPointer(const Symbol *original) {
1572	if (original) {
1573	const Symbol &ultimate{original->GetUltimate()};
1574	if (const auto *assoc{ultimate.detailsIf<AssocEntityDetails>()}) {
1575	// Only SELECT RANK construct entities can be ALLOCATABLE/POINTER.
1576	return (assoc->rank() || assoc->IsAssumedSize() ||
1577	assoc->IsAssumedRank()) &&
1578	IsAllocatableOrObjectPointer(UnwrapWholeSymbolDataRef(assoc->expr()));
1579	} else {
1580	return IsAllocatable(ultimate) ||
1581	(IsPointer(ultimate) && !IsProcedure(ultimate));
1582	}
1583	} else {
1584	return false;
1585	}
1586	}
1587
1588	const Symbol *FindCommonBlockContaining(const Symbol &original) {
1589	const Symbol &root{GetAssociationRoot(original)};
1590	const auto *details{root.detailsIf<ObjectEntityDetails>()};
1591	return details ? details->commonBlock() : nullptr;
1592	}
1593
1594	// 3.11 automatic data object
1595	bool IsAutomatic(const Symbol &original) {
1596	const Symbol &symbol{original.GetUltimate()};
1597	if (const auto *object{symbol.detailsIf<ObjectEntityDetails>()}) {
1598	if (!object->isDummy() && !IsAllocatable(symbol) && !IsPointer(symbol)) {
1599	if (const DeclTypeSpec * type{symbol.GetType()}) {
1600	// If a type parameter value is not a constant expression, the
1601	// object is automatic.
1602	if (type->category() == DeclTypeSpec::Character) {
1603	if (const auto &length{
1604	type->characterTypeSpec().length().GetExplicit()}) {
1605	if (!evaluate::IsConstantExpr(*length)) {
1606	return true;
1607	}
1608	}
1609	} else if (const DerivedTypeSpec * derived{type->AsDerived()}) {
1610	for (const auto &pair : derived->parameters()) {
1611	if (const auto &value{pair.second.GetExplicit()}) {
1612	if (!evaluate::IsConstantExpr(*value)) {
1613	return true;
1614	}
1615	}
1616	}
1617	}
1618	}
1619	// If an array bound is not a constant expression, the object is
1620	// automatic.
1621	for (const ShapeSpec &dim : object->shape()) {
1622	if (const auto &lb{dim.lbound().GetExplicit()}) {
1623	if (!evaluate::IsConstantExpr(*lb)) {
1624	return true;
1625	}
1626	}
1627	if (const auto &ub{dim.ubound().GetExplicit()}) {
1628	if (!evaluate::IsConstantExpr(*ub)) {
1629	return true;
1630	}
1631	}
1632	}
1633	}
1634	}
1635	return false;
1636	}
1637
1638	bool IsSaved(const Symbol &original) {
1639	const Symbol &symbol{GetAssociationRoot(original)};
1640	const Scope &scope{symbol.owner()};
1641	const common::LanguageFeatureControl &features{
1642	scope.context().languageFeatures()};
1643	auto scopeKind{scope.kind()};
1644	if (symbol.has<AssocEntityDetails>()) {
1645	return false; // ASSOCIATE(non-variable)
1646	} else if (scopeKind == Scope::Kind::DerivedType) {
1647	return false; // this is a component
1648	} else if (symbol.attrs().test(Attr::SAVE)) {
1649	return true; // explicit SAVE attribute
1650	} else if (IsDummy(symbol) || IsFunctionResult(symbol) ||
1651	IsAutomatic(symbol) || IsNamedConstant(symbol)) {
1652	return false;
1653	} else if (scopeKind == Scope::Kind::Module ||
1654	(scopeKind == Scope::Kind::MainProgram &&
1655	(symbol.attrs().test(Attr::TARGET) || evaluate::IsCoarray(symbol)))) {
1656	// 8.5.16p4
1657	// In main programs, implied SAVE matters only for pointer
1658	// initialization targets and coarrays.
1659	return true;
1660	} else if (scopeKind == Scope::Kind::MainProgram &&
1661	(features.IsEnabled(common::LanguageFeature::SaveMainProgram) ||
1662	(features.IsEnabled(
1663	common::LanguageFeature::SaveBigMainProgramVariables) &&
1664	symbol.size() > 32))) {
1665	// With SaveBigMainProgramVariables, keeping all unsaved main program
1666	// variables of 32 bytes or less on the stack allows keeping numerical and
1667	// logical scalars, small scalar characters or derived, small arrays, and
1668	// scalar descriptors on the stack. This leaves more room for lower level
1669	// optimizers to do register promotion or get easy aliasing information.
1670	return true;
1671	} else if (features.IsEnabled(common::LanguageFeature::DefaultSave) &&
1672	(scopeKind == Scope::Kind::MainProgram ||
1673	(scope.kind() == Scope::Kind::Subprogram &&
1674	!(scope.symbol() &&
1675	scope.symbol()->attrs().test(Attr::RECURSIVE))))) {
1676	// -fno-automatic/-save/-Msave option applies to all objects in executable
1677	// main programs and subprograms unless they are explicitly RECURSIVE.
1678	return true;
1679	} else if (symbol.test(Symbol::Flag::InDataStmt)) {
1680	return true;
1681	} else if (const auto *object{symbol.detailsIf<ObjectEntityDetails>()};
1682	object && object->init()) {
1683	return true;
1684	} else if (IsProcedurePointer(symbol) && symbol.has<ProcEntityDetails>() &&
1685	symbol.get<ProcEntityDetails>().init()) {
1686	return true;
1687	} else if (scope.hasSAVE()) {
1688	return true; // bare SAVE statement
1689	} else if (const Symbol * block{FindCommonBlockContaining(symbol)};
1690	block && block->attrs().test(Attr::SAVE)) {
1691	return true; // in COMMON with SAVE
1692	} else {
1693	return false;
1694	}
1695	}
1696
1697	bool IsDummy(const Symbol &symbol) {
1698	return common::visit(
1699	common::visitors{[](const EntityDetails &x) { return x.isDummy(); },
1700	[](const ObjectEntityDetails &x) { return x.isDummy(); },
1701	[](const ProcEntityDetails &x) { return x.isDummy(); },
1702	[](const SubprogramDetails &x) { return x.isDummy(); },
1703	[](const auto &) { return false; }},
1704	ResolveAssociations(symbol).details());
1705	}
1706
1707	bool IsAssumedShape(const Symbol &symbol) {
1708	const Symbol &ultimate{ResolveAssociations(symbol)};
1709	const auto *object{ultimate.detailsIf<ObjectEntityDetails>()};
1710	return object && object->IsAssumedShape() &&
1711	!semantics::IsAllocatableOrObjectPointer(&ultimate);
1712	}
1713
1714	bool IsDeferredShape(const Symbol &symbol) {
1715	const Symbol &ultimate{ResolveAssociations(symbol)};
1716	const auto *object{ultimate.detailsIf<ObjectEntityDetails>()};
1717	return object && object->CanBeDeferredShape() &&
1718	semantics::IsAllocatableOrObjectPointer(&ultimate);
1719	}
1720
1721	bool IsFunctionResult(const Symbol &original) {
1722	const Symbol &symbol{GetAssociationRoot(original)};
1723	return common::visit(
1724	common::visitors{
1725	[](const EntityDetails &x) { return x.isFuncResult(); },
1726	[](const ObjectEntityDetails &x) { return x.isFuncResult(); },
1727	[](const ProcEntityDetails &x) { return x.isFuncResult(); },
1728	[](const auto &) { return false; },
1729	},
1730	symbol.details());
1731	}
1732
1733	bool IsKindTypeParameter(const Symbol &symbol) {
1734	const auto *param{symbol.GetUltimate().detailsIf<TypeParamDetails>()};
1735	return param && param->attr() == common::TypeParamAttr::Kind;
1736	}
1737
1738	bool IsLenTypeParameter(const Symbol &symbol) {
1739	const auto *param{symbol.GetUltimate().detailsIf<TypeParamDetails>()};
1740	return param && param->attr() == common::TypeParamAttr::Len;
1741	}
1742
1743	bool IsExtensibleType(const DerivedTypeSpec *derived) {
1744	return !IsSequenceOrBindCType(derived) && !IsIsoCType(derived);
1745	}
1746
1747	bool IsSequenceOrBindCType(const DerivedTypeSpec *derived) {
1748	return derived &&
1749	(derived->typeSymbol().attrs().test(Attr::BIND_C) ||
1750	derived->typeSymbol().get<DerivedTypeDetails>().sequence());
1751	}
1752
1753	bool IsBuiltinDerivedType(const DerivedTypeSpec *derived, const char *name) {
1754	if (!derived) {
1755	return false;
1756	} else {
1757	const auto &symbol{derived->typeSymbol()};
1758	return &symbol.owner() == symbol.owner().context().GetBuiltinsScope() &&
1759	symbol.name() == "__builtin_"s + name;
1760	}
1761	}
1762
1763	bool IsBuiltinCPtr(const Symbol &symbol) {
1764	if (const DeclTypeSpec *declType = symbol.GetType()) {
1765	if (const DerivedTypeSpec *derived = declType->AsDerived()) {
1766	return IsIsoCType(derived);
1767	}
1768	}
1769	return false;
1770	}
1771
1772	bool IsIsoCType(const DerivedTypeSpec *derived) {
1773	return IsBuiltinDerivedType(derived, "c_ptr") ||
1774	IsBuiltinDerivedType(derived, "c_funptr");
1775	}
1776
1777	bool IsEventType(const DerivedTypeSpec *derived) {
1778	return IsBuiltinDerivedType(derived, "event_type");
1779	}
1780
1781	bool IsLockType(const DerivedTypeSpec *derived) {
1782	return IsBuiltinDerivedType(derived, "lock_type");
1783	}
1784
1785	bool IsNotifyType(const DerivedTypeSpec *derived) {
1786	return IsBuiltinDerivedType(derived, "notify_type");
1787	}
1788
1789	bool IsTeamType(const DerivedTypeSpec *derived) {
1790	return IsBuiltinDerivedType(derived, "team_type");
1791	}
1792
1793	bool IsBadCoarrayType(const DerivedTypeSpec *derived) {
1794	return IsTeamType(derived) || IsIsoCType(derived);
1795	}
1796
1797	bool IsEventTypeOrLockType(const DerivedTypeSpec *derivedTypeSpec) {
1798	return IsEventType(derivedTypeSpec) || IsLockType(derivedTypeSpec);
1799	}
1800
1801	int CountLenParameters(const DerivedTypeSpec &type) {
1802	return llvm::count_if(
1803	type.parameters(), [](const auto &pair) { return pair.second.isLen(); });
1804	}
1805
1806	int CountNonConstantLenParameters(const DerivedTypeSpec &type) {
1807	return llvm::count_if(type.parameters(), [](const auto &pair) {
1808	if (!pair.second.isLen()) {
1809	return false;
1810	} else if (const auto &expr{pair.second.GetExplicit()}) {
1811	return !IsConstantExpr(*expr);
1812	} else {
1813	return true;
1814	}
1815	});
1816	}
1817
1818	const Symbol &GetUsedModule(const UseDetails &details) {
1819	return DEREF(details.symbol().owner().symbol());
1820	}
1821
1822	static const Symbol *FindFunctionResult(
1823	const Symbol &original, UnorderedSymbolSet &seen) {
1824	const Symbol &root{GetAssociationRoot(original)};
1825	;
1826	if (!seen.insert(root).second) {
1827	return nullptr; // don't loop
1828	}
1829	return common::visit(
1830	common::visitors{[](const SubprogramDetails &subp) {
1831	return subp.isFunction() ? &subp.result() : nullptr;
1832	},
1833	[&](const ProcEntityDetails &proc) {
1834	const Symbol *iface{proc.procInterface()};
1835	return iface ? FindFunctionResult(*iface, seen) : nullptr;
1836	},
1837	[&](const ProcBindingDetails &binding) {
1838	return FindFunctionResult(binding.symbol(), seen);
1839	},
1840	[](const auto &) -> const Symbol * { return nullptr; }},
1841	root.details());
1842	}
1843
1844	const Symbol *FindFunctionResult(const Symbol &symbol) {
1845	UnorderedSymbolSet seen;
1846	return FindFunctionResult(symbol, seen);
1847	}
1848
1849	// These are here in Evaluate/tools.cpp so that Evaluate can use
1850	// them; they cannot be defined in symbol.h due to the dependence
1851	// on Scope.
1852
1853	bool SymbolSourcePositionCompare::operator()(
1854	const SymbolRef &x, const SymbolRef &y) const {
1855	return x->GetSemanticsContext().allCookedSources().Precedes(
1856	x->name(), y->name());
1857	}
1858	bool SymbolSourcePositionCompare::operator()(
1859	const MutableSymbolRef &x, const MutableSymbolRef &y) const {
1860	return x->GetSemanticsContext().allCookedSources().Precedes(
1861	x->name(), y->name());
1862	}
1863
1864	SemanticsContext &Symbol::GetSemanticsContext() const {
1865	return DEREF(owner_).context();
1866	}
1867
1868	bool AreTkCompatibleTypes(const DeclTypeSpec *x, const DeclTypeSpec *y) {
1869	if (x && y) {
1870	if (auto xDt{evaluate::DynamicType::From(*x)}) {
1871	if (auto yDt{evaluate::DynamicType::From(*y)}) {
1872	return xDt->IsTkCompatibleWith(*yDt);
1873	}
1874	}
1875	}
1876	return false;
1877	}
1878
1879	common::IgnoreTKRSet GetIgnoreTKR(const Symbol &symbol) {
1880	common::IgnoreTKRSet result;
1881	if (const auto *object{symbol.detailsIf<ObjectEntityDetails>()}) {
1882	result = object->ignoreTKR();
1883	if (const Symbol * ownerSymbol{symbol.owner().symbol()}) {
1884	if (const auto *ownerSubp{ownerSymbol->detailsIf<SubprogramDetails>()}) {
1885	if (ownerSubp->defaultIgnoreTKR()) {
1886	result |= common::ignoreTKRAll;
1887	}
1888	}
1889	}
1890	}
1891	return result;
1892	}
1893
1894	std::optional<int> GetDummyArgumentNumber(const Symbol *symbol) {
1895	if (symbol) {
1896	if (IsDummy(*symbol)) {
1897	if (const Symbol * subpSym{symbol->owner().symbol()}) {
1898	if (const auto *subp{subpSym->detailsIf<SubprogramDetails>()}) {
1899	int j{0};
1900	for (const Symbol *dummy : subp->dummyArgs()) {
1901	if (dummy == symbol) {
1902	return j;
1903	}
1904	++j;
1905	}
1906	}
1907	}
1908	}
1909	}
1910	return std::nullopt;
1911	}
1912
1913	} // namespace Fortran::semantics
1914