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