1	//===-- lib/Evaluate/characteristics.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/characteristics.h"
10	#include "flang/Common/indirection.h"
11	#include "flang/Evaluate/check-expression.h"
12	#include "flang/Evaluate/fold.h"
13	#include "flang/Evaluate/intrinsics.h"
14	#include "flang/Evaluate/tools.h"
15	#include "flang/Evaluate/type.h"
16	#include "flang/Parser/message.h"
17	#include "flang/Semantics/scope.h"
18	#include "flang/Semantics/symbol.h"
19	#include "flang/Semantics/tools.h"
20	#include "llvm/Support/raw_ostream.h"
21	#include <initializer_list>
22
23	using namespace Fortran::parser::literals;
24
25	namespace Fortran::evaluate::characteristics {
26
27	// Copy attributes from a symbol to dst based on the mapping in pairs.
28	// An ASYNCHRONOUS attribute counts even if it is implied.
29	template <typename A, typename B>
30	static void CopyAttrs(const semantics::Symbol &src, A &dst,
31	const std::initializer_list<std::pair<semantics::Attr, B>> &pairs) {
32	for (const auto &pair : pairs) {
33	if (src.attrs().test(pair.first)) {
34	dst.attrs.set(pair.second);
35	}
36	}
37	}
38
39	// Shapes of function results and dummy arguments have to have
40	// the same rank, the same deferred dimensions, and the same
41	// values for explicit dimensions when constant.
42	bool ShapesAreCompatible(const std::optional<Shape> &x,
43	const std::optional<Shape> &y, bool *possibleWarning) {
44	if (!x || !y) {
45	return !x && !y;
46	}
47	if (x->size() != y->size()) {
48	return false;
49	}
50	auto yIter{y->begin()};
51	for (const auto &xDim : *x) {
52	const auto &yDim{*yIter++};
53	if (xDim && yDim) {
54	if (auto equiv{AreEquivalentInInterface(*xDim, *yDim)}) {
55	if (!*equiv) {
56	return false;
57	}
58	} else if (possibleWarning) {
59	*possibleWarning = true;
60	}
61	} else if (xDim || yDim) {
62	return false;
63	}
64	}
65	return true;
66	}
67
68	bool TypeAndShape::operator==(const TypeAndShape &that) const {
69	return type_.IsEquivalentTo(that.type_) &&
70	ShapesAreCompatible(shape_, that.shape_) && attrs_ == that.attrs_ &&
71	corank_ == that.corank_;
72	}
73
74	TypeAndShape &TypeAndShape::Rewrite(FoldingContext &context) {
75	LEN_ = Fold(context, std::move(LEN_));
76	if (LEN_) {
77	if (auto n{ToInt64(*LEN_)}) {
78	type_ = DynamicType{type_.kind(), *n};
79	}
80	}
81	shape_ = Fold(context, std::move(shape_));
82	return *this;
83	}
84
85	std::optional<TypeAndShape> TypeAndShape::Characterize(
86	const semantics::Symbol &symbol, FoldingContext &context,
87	bool invariantOnly) {
88	const auto &ultimate{symbol.GetUltimate()};
89	return common::visit(
90	common::visitors{
91	[&](const semantics::ProcEntityDetails &proc) {
92	if (proc.procInterface()) {
93	return Characterize(
94	*proc.procInterface(), context, invariantOnly);
95	} else if (proc.type()) {
96	return Characterize(*proc.type(), context, invariantOnly);
97	} else {
98	return std::optional<TypeAndShape>{};
99	}
100	},
101	[&](const semantics::AssocEntityDetails &assoc) {
102	return Characterize(assoc, context, invariantOnly);
103	},
104	[&](const semantics::ProcBindingDetails &binding) {
105	return Characterize(binding.symbol(), context, invariantOnly);
106	},
107	[&](const auto &x) -> std::optional<TypeAndShape> {
108	using Ty = std::decay_t<decltype(x)>;
109	if constexpr (std::is_same_v<Ty, semantics::EntityDetails> ||
110	std::is_same_v<Ty, semantics::ObjectEntityDetails> ||
111	std::is_same_v<Ty, semantics::TypeParamDetails>) {
112	if (const semantics::DeclTypeSpec * type{ultimate.GetType()}) {
113	if (auto dyType{DynamicType::From(*type)}) {
114	TypeAndShape result{std::move(*dyType),
115	GetShape(context, ultimate, invariantOnly)};
116	result.AcquireAttrs(ultimate);
117	result.AcquireLEN(ultimate);
118	return std::move(result.Rewrite(context));
119	}
120	}
121	}
122	return std::nullopt;
123	},
124	},
125	// GetUltimate() used here, not ResolveAssociations(), because
126	// we need the type/rank of an associate entity from TYPE IS,
127	// CLASS IS, or RANK statement.
128	ultimate.details());
129	}
130
131	std::optional<TypeAndShape> TypeAndShape::Characterize(
132	const semantics::AssocEntityDetails &assoc, FoldingContext &context,
133	bool invariantOnly) {
134	std::optional<TypeAndShape> result;
135	if (auto type{DynamicType::From(assoc.type())}) {
136	if (auto rank{assoc.rank()}) {
137	if (*rank >= 0 && *rank <= common::maxRank) {
138	result = TypeAndShape{std::move(*type), Shape(*rank)};
139	}
140	} else if (auto shape{GetShape(context, assoc.expr(), invariantOnly)}) {
141	result = TypeAndShape{std::move(*type), std::move(*shape)};
142	}
143	if (result && type->category() == TypeCategory::Character) {
144	if (const auto *chExpr{UnwrapExpr<Expr<SomeCharacter>>(assoc.expr())}) {
145	if (auto len{chExpr->LEN()}) {
146	result->set_LEN(std::move(*len));
147	}
148	}
149	}
150	}
151	return Fold(context, std::move(result));
152	}
153
154	std::optional<TypeAndShape> TypeAndShape::Characterize(
155	const semantics::DeclTypeSpec &spec, FoldingContext &context,
156	bool /*invariantOnly=*/) {
157	if (auto type{DynamicType::From(spec)}) {
158	return Fold(context, TypeAndShape{std::move(*type)});
159	} else {
160	return std::nullopt;
161	}
162	}
163
164	std::optional<TypeAndShape> TypeAndShape::Characterize(
165	const ActualArgument &arg, FoldingContext &context, bool invariantOnly) {
166	if (const auto *expr{arg.UnwrapExpr()}) {
167	return Characterize(*expr, context, invariantOnly);
168	} else if (const Symbol * assumed{arg.GetAssumedTypeDummy()}) {
169	return Characterize(*assumed, context, invariantOnly);
170	} else {
171	return std::nullopt;
172	}
173	}
174
175	bool TypeAndShape::IsCompatibleWith(parser::ContextualMessages &messages,
176	const TypeAndShape &that, const char *thisIs, const char *thatIs,
177	bool omitShapeConformanceCheck,
178	enum CheckConformanceFlags::Flags flags) const {
179	if (!type_.IsTkCompatibleWith(that.type_)) {
180	messages.Say(
181	"%1$s type '%2$s' is not compatible with %3$s type '%4$s'"_err_en_US,
182	thatIs, that.AsFortran(), thisIs, AsFortran());
183	return false;
184	}
185	return omitShapeConformanceCheck || (!shape_ && !that.shape_) ||
186	(shape_ && that.shape_ &&
187	CheckConformance(
188	messages, *shape_, *that.shape_, flags, thisIs, thatIs)
189	.value_or(true /*fail only when nonconformance is known now*/));
190	}
191
192	std::optional<Expr<SubscriptInteger>> TypeAndShape::MeasureElementSizeInBytes(
193	FoldingContext &foldingContext, bool align) const {
194	if (LEN_) {
195	CHECK(type_.category() == TypeCategory::Character);
196	return Fold(foldingContext,
197	Expr<SubscriptInteger>{
198	foldingContext.targetCharacteristics().GetByteSize(
199	type_.category(), type_.kind())} *
200	Expr<SubscriptInteger>{*LEN_});
201	}
202	if (auto elementBytes{type_.MeasureSizeInBytes(foldingContext, align)}) {
203	return Fold(foldingContext, std::move(*elementBytes));
204	}
205	return std::nullopt;
206	}
207
208	std::optional<Expr<SubscriptInteger>> TypeAndShape::MeasureSizeInBytes(
209	FoldingContext &foldingContext) const {
210	if (auto elements{GetSize(shape_)}) {
211	// Sizes of arrays (even with single elements) are multiples of
212	// their alignments.
213	if (auto elementBytes{
214	MeasureElementSizeInBytes(foldingContext, Rank() > 0)}) {
215	return Fold(
216	foldingContext, std::move(*elements) * std::move(*elementBytes));
217	}
218	}
219	return std::nullopt;
220	}
221
222	void TypeAndShape::AcquireAttrs(const semantics::Symbol &symbol) {
223	if (IsAssumedShape(symbol)) {
224	attrs_.set(Attr::AssumedShape);
225	} else if (IsDeferredShape(symbol)) {
226	attrs_.set(Attr::DeferredShape);
227	} else if (semantics::IsAssumedSizeArray(symbol)) {
228	attrs_.set(Attr::AssumedSize);
229	}
230	if (int corank{GetCorank(symbol)}; corank > 0) {
231	corank_ = corank;
232	}
233	if (const auto *object{
234	symbol.GetUltimate().detailsIf<semantics::ObjectEntityDetails>()};
235	object && object->IsAssumedRank()) {
236	attrs_.set(Attr::AssumedRank);
237	}
238	}
239
240	void TypeAndShape::AcquireLEN() {
241	if (auto len{type_.GetCharLength()}) {
242	LEN_ = std::move(len);
243	}
244	}
245
246	void TypeAndShape::AcquireLEN(const semantics::Symbol &symbol) {
247	if (type_.category() == TypeCategory::Character) {
248	if (auto len{DataRef{symbol}.LEN()}) {
249	LEN_ = std::move(*len);
250	}
251	}
252	}
253
254	std::string TypeAndShape::AsFortran() const {
255	return type_.AsFortran(LEN_ ? LEN_->AsFortran() : "");
256	}
257
258	llvm::raw_ostream &TypeAndShape::Dump(llvm::raw_ostream &o) const {
259	o << type_.AsFortran(LEN_ ? LEN_->AsFortran() : "");
260	attrs_.Dump(o, EnumToString);
261	if (!shape_) {
262	o << " dimension(..)";
263	} else if (!shape_->empty()) {
264	o << " dimension";
265	char sep{'('};
266	for (const auto &expr : *shape_) {
267	o << sep;
268	sep = ',';
269	if (expr) {
270	expr->AsFortran(o);
271	} else {
272	o << ':';
273	}
274	}
275	o << ')';
276	}
277	if (isPossibleSequenceAssociation_) {
278	o << " isPossibleSequenceAssociation";
279	}
280	return o;
281	}
282
283	bool DummyDataObject::operator==(const DummyDataObject &that) const {
284	return type == that.type && attrs == that.attrs && intent == that.intent &&
285	coshape == that.coshape && cudaDataAttr == that.cudaDataAttr;
286	}
287
288	static bool IsOkWithSequenceAssociation(
289	const TypeAndShape &t1, const TypeAndShape &t2) {
290	return t1.isPossibleSequenceAssociation() &&
291	(t2.isPossibleSequenceAssociation() || t2.CanBeSequenceAssociated());
292	}
293
294	bool DummyDataObject::IsCompatibleWith(const DummyDataObject &actual,
295	std::string *whyNot, std::optional<std::string> *warning) const {
296	if (!IsOkWithSequenceAssociation(type, actual.type) &&
297	!IsOkWithSequenceAssociation(actual.type, type)) {
298	bool possibleWarning{false};
299	if (!ShapesAreCompatible(
300	type.shape(), actual.type.shape(), &possibleWarning)) {
301	if (whyNot) {
302	*whyNot = "incompatible dummy data object shapes";
303	}
304	return false;
305	} else if (warning && possibleWarning) {
306	*warning = "distinct dummy data object shapes";
307	}
308	}
309	// Treat deduced dummy character type as if it were assumed-length character
310	// to avoid useless "implicit interfaces have distinct type" warnings from
311	// CALL FOO('abc'); CALL FOO('abcd').
312	bool deducedAssumedLength{type.type().category() == TypeCategory::Character &&
313	attrs.test(Attr::DeducedFromActual)};
314	bool compatibleTypes{deducedAssumedLength
315	? type.type().IsTkCompatibleWith(actual.type.type())
316	: type.type().IsTkLenCompatibleWith(actual.type.type())};
317	if (!compatibleTypes) {
318	if (whyNot) {
319	*whyNot = "incompatible dummy data object types: "s +
320	type.type().AsFortran() + " vs " + actual.type.type().AsFortran();
321	}
322	return false;
323	}
324	if (type.type().IsPolymorphic() != actual.type.type().IsPolymorphic()) {
325	if (whyNot) {
326	*whyNot = "incompatible dummy data object polymorphism: "s +
327	type.type().AsFortran() + " vs " + actual.type.type().AsFortran();
328	}
329	return false;
330	}
331	if (type.type().category() == TypeCategory::Character &&
332	!deducedAssumedLength) {
333	if (actual.type.type().IsAssumedLengthCharacter() !=
334	type.type().IsAssumedLengthCharacter()) {
335	if (whyNot) {
336	*whyNot = "assumed-length character vs explicit-length character";
337	}
338	return false;
339	}
340	if (!type.type().IsAssumedLengthCharacter() && type.LEN() &&
341	actual.type.LEN()) {
342	auto len{ToInt64(*type.LEN())};
343	auto actualLen{ToInt64(*actual.type.LEN())};
344	if (len.has_value() != actualLen.has_value()) {
345	if (whyNot) {
346	*whyNot = "constant-length vs non-constant-length character dummy "
347	"arguments";
348	}
349	return false;
350	} else if (len && *len != *actualLen) {
351	if (whyNot) {
352	*whyNot = "character dummy arguments with distinct lengths";
353	}
354	return false;
355	}
356	}
357	}
358	if (!attrs.test(Attr::DeducedFromActual) &&
359	!actual.attrs.test(Attr::DeducedFromActual) &&
360	type.attrs() != actual.type.attrs()) {
361	if (whyNot) {
362	*whyNot = "incompatible dummy data object shape attributes";
363	auto differences{type.attrs() ^ actual.type.attrs()};
364	auto sep{": "s};
365	differences.IterateOverMembers([&](TypeAndShape::Attr x) {
366	*whyNot += sep + std::string{TypeAndShape::EnumToString(x)};
367	sep = ", ";
368	});
369	}
370	return false;
371	}
372	if (!IdenticalSignificantAttrs(attrs, actual.attrs)) {
373	if (whyNot) {
374	*whyNot = "incompatible dummy data object attributes";
375	auto differences{attrs ^ actual.attrs};
376	auto sep{": "s};
377	differences.IterateOverMembers([&](DummyDataObject::Attr x) {
378	*whyNot += sep + std::string{EnumToString(x)};
379	sep = ", ";
380	});
381	}
382	return false;
383	}
384	if (intent != actual.intent) {
385	if (whyNot) {
386	*whyNot = "incompatible dummy data object intents";
387	}
388	return false;
389	}
390	if (coshape != actual.coshape) {
391	if (whyNot) {
392	*whyNot = "incompatible dummy data object coshapes";
393	}
394	return false;
395	}
396	if (ignoreTKR != actual.ignoreTKR) {
397	if (whyNot) {
398	*whyNot = "incompatible !DIR$ IGNORE_TKR directives";
399	}
400	}
401	if (!attrs.test(Attr::Value) &&
402	!common::AreCompatibleCUDADataAttrs(cudaDataAttr, actual.cudaDataAttr,
403	ignoreTKR, warning,
404	/*allowUnifiedMatchingRule=*/false,
405	/*=isHostDeviceProcedure*/ false)) {
406	if (whyNot) {
407	*whyNot = "incompatible CUDA data attributes";
408	}
409	}
410	return true;
411	}
412
413	static common::Intent GetIntent(const semantics::Attrs &attrs) {
414	if (attrs.test(semantics::Attr::INTENT_IN)) {
415	return common::Intent::In;
416	} else if (attrs.test(semantics::Attr::INTENT_OUT)) {
417	return common::Intent::Out;
418	} else if (attrs.test(semantics::Attr::INTENT_INOUT)) {
419	return common::Intent::InOut;
420	} else {
421	return common::Intent::Default;
422	}
423	}
424
425	std::optional<DummyDataObject> DummyDataObject::Characterize(
426	const semantics::Symbol &symbol, FoldingContext &context) {
427	if (const auto *object{symbol.detailsIf<semantics::ObjectEntityDetails>()};
428	object || symbol.has<semantics::EntityDetails>()) {
429	if (auto type{TypeAndShape::Characterize(
430	symbol, context, /*invariantOnly=*/false)}) {
431	std::optional<DummyDataObject> result{std::move(*type)};
432	using semantics::Attr;
433	CopyAttrs<DummyDataObject, DummyDataObject::Attr>(symbol, *result,
434	{
435	{Attr::OPTIONAL, DummyDataObject::Attr::Optional},
436	{Attr::ALLOCATABLE, DummyDataObject::Attr::Allocatable},
437	{Attr::ASYNCHRONOUS, DummyDataObject::Attr::Asynchronous},
438	{Attr::CONTIGUOUS, DummyDataObject::Attr::Contiguous},
439	{Attr::VALUE, DummyDataObject::Attr::Value},
440	{Attr::VOLATILE, DummyDataObject::Attr::Volatile},
441	{Attr::POINTER, DummyDataObject::Attr::Pointer},
442	{Attr::TARGET, DummyDataObject::Attr::Target},
443	});
444	result->intent = GetIntent(symbol.attrs());
445	result->ignoreTKR = GetIgnoreTKR(symbol);
446	if (object) {
447	result->cudaDataAttr = object->cudaDataAttr();
448	if (!result->cudaDataAttr &&
449	!result->attrs.test(DummyDataObject::Attr::Value) &&
450	semantics::IsCUDADeviceContext(&symbol.owner())) {
451	result->cudaDataAttr = common::CUDADataAttr::Device;
452	}
453	}
454	return result;
455	}
456	}
457	return std::nullopt;
458	}
459
460	bool DummyDataObject::CanBePassedViaImplicitInterface(
461	std::string *whyNot) const {
462	if ((attrs &
463	Attrs{Attr::Allocatable, Attr::Asynchronous, Attr::Optional,
464	Attr::Pointer, Attr::Target, Attr::Value, Attr::Volatile})
465	.any()) {
466	if (whyNot) {
467	*whyNot = "a dummy argument has the allocatable, asynchronous, optional, "
468	"pointer, target, value, or volatile attribute";
469	}
470	return false; // 15.4.2.2(3)(a)
471	} else if ((type.attrs() &
472	TypeAndShape::Attrs{TypeAndShape::Attr::AssumedShape,
473	TypeAndShape::Attr::AssumedRank})
474	.any() ||
475	type.corank() > 0) {
476	if (whyNot) {
477	*whyNot = "a dummy argument is assumed-shape, assumed-rank, or a coarray";
478	}
479	return false; // 15.4.2.2(3)(b-d)
480	} else if (type.type().IsPolymorphic()) {
481	if (whyNot) {
482	*whyNot = "a dummy argument is polymorphic";
483	}
484	return false; // 15.4.2.2(3)(f)
485	} else if (cudaDataAttr) {
486	if (whyNot) {
487	*whyNot = "a dummy argument has a CUDA data attribute";
488	}
489	return false;
490	} else if (const auto *derived{GetDerivedTypeSpec(type.type())}) {
491	if (derived->parameters().empty()) { // 15.4.2.2(3)(e)
492	return true;
493	} else {
494	if (whyNot) {
495	*whyNot = "a dummy argument has derived type parameters";
496	}
497	return false;
498	}
499	} else {
500	return true;
501	}
502	}
503
504	bool DummyDataObject::IsPassedByDescriptor(bool isBindC) const {
505	constexpr TypeAndShape::Attrs shapeRequiringBox{
506	TypeAndShape::Attr::AssumedShape, TypeAndShape::Attr::DeferredShape,
507	TypeAndShape::Attr::AssumedRank};
508	if ((attrs & Attrs{Attr::Allocatable, Attr::Pointer}).any()) {
509	return true;
510	} else if ((type.attrs() & shapeRequiringBox).any()) {
511	return true; // pass shape in descriptor
512	} else if (type.corank() > 0) {
513	return true; // pass coshape in descriptor
514	} else if (type.type().IsPolymorphic() && !type.type().IsAssumedType()) {
515	// Need to pass dynamic type info in a descriptor.
516	return true;
517	} else if (const auto *derived{GetDerivedTypeSpec(type.type())}) {
518	if (!derived->parameters().empty()) {
519	for (const auto &param : derived->parameters()) {
520	if (param.second.isLen()) {
521	// Need to pass length type parameters in a descriptor.
522	return true;
523	}
524	}
525	}
526	} else if (isBindC && type.type().IsAssumedLengthCharacter()) {
527	// Fortran 2018 18.3.6 point 2 (5)
528	return true;
529	}
530	return false;
531	}
532
533	llvm::raw_ostream &DummyDataObject::Dump(llvm::raw_ostream &o) const {
534	attrs.Dump(o, EnumToString);
535	if (intent != common::Intent::Default) {
536	o << "INTENT(" << common::EnumToString(intent) << ')';
537	}
538	type.Dump(o);
539	if (!coshape.empty()) {
540	char sep{'['};
541	for (const auto &expr : coshape) {
542	expr.AsFortran(o << sep);
543	sep = ',';
544	}
545	}
546	if (cudaDataAttr) {
547	o << " cudaDataAttr: " << common::EnumToString(*cudaDataAttr);
548	}
549	if (!ignoreTKR.empty()) {
550	ignoreTKR.Dump(o << ' ', common::EnumToString);
551	}
552	return o;
553	}
554
555	DummyProcedure::DummyProcedure(Procedure &&p)
556	: procedure{new Procedure{std::move(p)}} {}
557
558	bool DummyProcedure::operator==(const DummyProcedure &that) const {
559	return attrs == that.attrs && intent == that.intent &&
560	procedure.value() == that.procedure.value();
561	}
562
563	bool DummyProcedure::IsCompatibleWith(
564	const DummyProcedure &actual, std::string *whyNot) const {
565	if (attrs != actual.attrs) {
566	if (whyNot) {
567	*whyNot = "incompatible dummy procedure attributes";
568	}
569	return false;
570	}
571	if (intent != actual.intent) {
572	if (whyNot) {
573	*whyNot = "incompatible dummy procedure intents";
574	}
575	return false;
576	}
577	if (!procedure.value().IsCompatibleWith(actual.procedure.value(),
578	/*ignoreImplicitVsExplicit=*/false, whyNot)) {
579	if (whyNot) {
580	*whyNot = "incompatible dummy procedure interfaces: "s + *whyNot;
581	}
582	return false;
583	}
584	return true;
585	}
586
587	bool DummyProcedure::CanBePassedViaImplicitInterface(
588	std::string *whyNot) const {
589	if ((attrs & Attrs{Attr::Optional, Attr::Pointer}).any()) {
590	if (whyNot) {
591	*whyNot = "a dummy procedure is optional or a pointer";
592	}
593	return false; // 15.4.2.2(3)(a)
594	}
595	return true;
596	}
597
598	static std::string GetSeenProcs(
599	const semantics::UnorderedSymbolSet &seenProcs) {
600	// Sort the symbols so that they appear in the same order on all platforms
601	auto ordered{semantics::OrderBySourcePosition(seenProcs)};
602	std::string result;
603	llvm::interleave(
604	ordered,
605	[&](const SymbolRef p) { result += '\'' + p->name().ToString() + '\''; },
606	[&]() { result += ", "; });
607	return result;
608	}
609
610	// These functions with arguments of type UnorderedSymbolSet are used with
611	// mutually recursive calls when characterizing a Procedure, a DummyArgument,
612	// or a DummyProcedure to detect circularly defined procedures as required by
613	// 15.4.3.6, paragraph 2.
614	static std::optional<DummyArgument> CharacterizeDummyArgument(
615	const semantics::Symbol &symbol, FoldingContext &context,
616	semantics::UnorderedSymbolSet seenProcs);
617	static std::optional<FunctionResult> CharacterizeFunctionResult(
618	const semantics::Symbol &symbol, FoldingContext &context,
619	semantics::UnorderedSymbolSet seenProcs, bool emitError);
620
621	static std::optional<Procedure> CharacterizeProcedure(
622	const semantics::Symbol &original, FoldingContext &context,
623	semantics::UnorderedSymbolSet seenProcs, bool emitError) {
624	const auto &symbol{ResolveAssociations(original)};
625	if (seenProcs.find(symbol) != seenProcs.end()) {
626	std::string procsList{GetSeenProcs(seenProcs)};
627	context.messages().Say(symbol.name(),
628	"Procedure '%s' is recursively defined. Procedures in the cycle:"
629	" %s"_err_en_US,
630	symbol.name(), procsList);
631	return std::nullopt;
632	}
633	seenProcs.insert(symbol);
634	auto CheckForNested{[&](const Symbol &symbol) {
635	if (emitError) {
636	context.messages().Say(
637	"Procedure '%s' is referenced before being sufficiently defined in a context where it must be so"_err_en_US,
638	symbol.name());
639	}
640	}};
641	auto result{common::visit(
642	common::visitors{
643	[&](const semantics::SubprogramDetails &subp)
644	-> std::optional<Procedure> {
645	Procedure result;
646	if (subp.isFunction()) {
647	if (auto fr{CharacterizeFunctionResult(
648	subp.result(), context, seenProcs, emitError)}) {
649	result.functionResult = std::move(fr);
650	} else {
651	return std::nullopt;
652	}
653	} else {
654	result.attrs.set(Procedure::Attr::Subroutine);
655	}
656	for (const semantics::Symbol *arg : subp.dummyArgs()) {
657	if (!arg) {
658	if (subp.isFunction()) {
659	return std::nullopt;
660	} else {
661	result.dummyArguments.emplace_back(AlternateReturn{});
662	}
663	} else if (auto argCharacteristics{CharacterizeDummyArgument(
664	*arg, context, seenProcs)}) {
665	result.dummyArguments.emplace_back(
666	std::move(argCharacteristics.value()));
667	} else {
668	return std::nullopt;
669	}
670	}
671	result.cudaSubprogramAttrs = subp.cudaSubprogramAttrs();
672	return std::move(result);
673	},
674	[&](const semantics::ProcEntityDetails &proc)
675	-> std::optional<Procedure> {
676	if (symbol.attrs().test(semantics::Attr::INTRINSIC)) {
677	// Fails when the intrinsic is not a specific intrinsic function
678	// from F'2018 table 16.2. In order to handle forward references,
679	// attempts to use impermissible intrinsic procedures as the
680	// interfaces of procedure pointers are caught and flagged in
681	// declaration checking in Semantics.
682	auto intrinsic{context.intrinsics().IsSpecificIntrinsicFunction(
683	symbol.name().ToString())};
684	if (intrinsic && intrinsic->isRestrictedSpecific) {
685	intrinsic.reset(); // Exclude intrinsics from table 16.3.
686	}
687	return intrinsic;
688	}
689	if (const semantics::Symbol *
690	interfaceSymbol{proc.procInterface()}) {
691	auto result{CharacterizeProcedure(
692	*interfaceSymbol, context, seenProcs, /*emitError=*/false)};
693	if (result && (IsDummy(symbol) || IsPointer(symbol))) {
694	// Dummy procedures and procedure pointers may not be
695	// ELEMENTAL, but we do accept the use of elemental intrinsic
696	// functions as their interfaces.
697	result->attrs.reset(Procedure::Attr::Elemental);
698	}
699	return result;
700	} else {
701	Procedure result;
702	result.attrs.set(Procedure::Attr::ImplicitInterface);
703	const semantics::DeclTypeSpec *type{proc.type()};
704	if (symbol.test(semantics::Symbol::Flag::Subroutine)) {
705	// ignore any implicit typing
706	result.attrs.set(Procedure::Attr::Subroutine);
707	if (proc.isCUDAKernel()) {
708	result.cudaSubprogramAttrs =
709	common::CUDASubprogramAttrs::Global;
710	}
711	} else if (type) {
712	if (auto resultType{DynamicType::From(*type)}) {
713	result.functionResult = FunctionResult{*resultType};
714	} else {
715	return std::nullopt;
716	}
717	} else if (symbol.test(semantics::Symbol::Flag::Function)) {
718	return std::nullopt;
719	}
720	// The PASS name, if any, is not a characteristic.
721	return std::move(result);
722	}
723	},
724	[&](const semantics::ProcBindingDetails &binding) {
725	if (auto result{CharacterizeProcedure(binding.symbol(), context,
726	seenProcs, /*emitError=*/false)}) {
727	if (binding.symbol().attrs().test(semantics::Attr::INTRINSIC)) {
728	result->attrs.reset(Procedure::Attr::Elemental);
729	}
730	if (!symbol.attrs().test(semantics::Attr::NOPASS)) {
731	auto passName{binding.passName()};
732	for (auto &dummy : result->dummyArguments) {
733	if (!passName || dummy.name.c_str() == *passName) {
734	dummy.pass = true;
735	break;
736	}
737	}
738	}
739	return result;
740	} else {
741	return std::optional<Procedure>{};
742	}
743	},
744	[&](const semantics::UseDetails &use) {
745	return CharacterizeProcedure(
746	use.symbol(), context, seenProcs, /*emitError=*/false);
747	},
748	[](const semantics::UseErrorDetails &) {
749	// Ambiguous use-association will be handled later during symbol
750	// checks, ignore UseErrorDetails here without actual symbol usage.
751	return std::optional<Procedure>{};
752	},
753	[&](const semantics::HostAssocDetails &assoc) {
754	return CharacterizeProcedure(
755	assoc.symbol(), context, seenProcs, /*emitError=*/false);
756	},
757	[&](const semantics::GenericDetails &generic) {
758	if (const semantics::Symbol * specific{generic.specific()}) {
759	return CharacterizeProcedure(
760	*specific, context, seenProcs, emitError);
761	} else {
762	return std::optional<Procedure>{};
763	}
764	},
765	[&](const semantics::EntityDetails &x) {
766	CheckForNested(symbol);
767	return std::optional<Procedure>{};
768	},
769	[&](const semantics::SubprogramNameDetails &) {
770	if (const semantics::Symbol *
771	ancestor{FindAncestorModuleProcedure(&symbol)}) {
772	return CharacterizeProcedure(
773	*ancestor, context, seenProcs, emitError);
774	}
775	CheckForNested(symbol);
776	return std::optional<Procedure>{};
777	},
778	[&](const auto &) {
779	context.messages().Say(
780	"'%s' is not a procedure"_err_en_US, symbol.name());
781	return std::optional<Procedure>{};
782	},
783	},
784	symbol.details())};
785	if (result && !symbol.has<semantics::ProcBindingDetails>()) {
786	CopyAttrs<Procedure, Procedure::Attr>(symbol, *result,
787	{
788	{semantics::Attr::BIND_C, Procedure::Attr::BindC},
789	});
790	CopyAttrs<Procedure, Procedure::Attr>(DEREF(GetMainEntry(&symbol)), *result,
791	{
792	{semantics::Attr::ELEMENTAL, Procedure::Attr::Elemental},
793	});
794	if (IsPureProcedure(symbol) || // works for ENTRY too
795	(!IsExplicitlyImpureProcedure(symbol) &&
796	result->attrs.test(Procedure::Attr::Elemental))) {
797	result->attrs.set(Procedure::Attr::Pure);
798	}
799	}
800	return result;
801	}
802
803	static std::optional<DummyProcedure> CharacterizeDummyProcedure(
804	const semantics::Symbol &symbol, FoldingContext &context,
805	semantics::UnorderedSymbolSet seenProcs) {
806	if (auto procedure{CharacterizeProcedure(
807	symbol, context, seenProcs, /*emitError=*/true)}) {
808	// Dummy procedures may not be elemental. Elemental dummy procedure
809	// interfaces are errors when the interface is not intrinsic, and that
810	// error is caught elsewhere. Elemental intrinsic interfaces are
811	// made non-elemental.
812	procedure->attrs.reset(Procedure::Attr::Elemental);
813	DummyProcedure result{std::move(procedure.value())};
814	CopyAttrs<DummyProcedure, DummyProcedure::Attr>(symbol, result,
815	{
816	{semantics::Attr::OPTIONAL, DummyProcedure::Attr::Optional},
817	{semantics::Attr::POINTER, DummyProcedure::Attr::Pointer},
818	});
819	result.intent = GetIntent(symbol.attrs());
820	return result;
821	} else {
822	return std::nullopt;
823	}
824	}
825
826	llvm::raw_ostream &DummyProcedure::Dump(llvm::raw_ostream &o) const {
827	attrs.Dump(o, EnumToString);
828	if (intent != common::Intent::Default) {
829	o << "INTENT(" << common::EnumToString(intent) << ')';
830	}
831	procedure.value().Dump(o);
832	return o;
833	}
834
835	llvm::raw_ostream &AlternateReturn::Dump(llvm::raw_ostream &o) const {
836	return o << '*';
837	}
838
839	DummyArgument::~DummyArgument() {}
840
841	bool DummyArgument::operator==(const DummyArgument &that) const {
842	return u == that.u; // name and passed-object usage are not characteristics
843	}
844
845	bool DummyArgument::IsCompatibleWith(const DummyArgument &actual,
846	std::string *whyNot, std::optional<std::string> *warning) const {
847	if (const auto *ifaceData{std::get_if<DummyDataObject>(&u)}) {
848	if (const auto *actualData{std::get_if<DummyDataObject>(&actual.u)}) {
849	return ifaceData->IsCompatibleWith(*actualData, whyNot, warning);
850	}
851	if (whyNot) {
852	*whyNot = "one dummy argument is an object, the other is not";
853	}
854	} else if (const auto *ifaceProc{std::get_if<DummyProcedure>(&u)}) {
855	if (const auto *actualProc{std::get_if<DummyProcedure>(&actual.u)}) {
856	return ifaceProc->IsCompatibleWith(*actualProc, whyNot);
857	}
858	if (whyNot) {
859	*whyNot = "one dummy argument is a procedure, the other is not";
860	}
861	} else {
862	CHECK(std::holds_alternative<AlternateReturn>(u));
863	if (std::holds_alternative<AlternateReturn>(actual.u)) {
864	return true;
865	}
866	if (whyNot) {
867	*whyNot = "one dummy argument is an alternate return, the other is not";
868	}
869	}
870	return false;
871	}
872
873	static std::optional<DummyArgument> CharacterizeDummyArgument(
874	const semantics::Symbol &symbol, FoldingContext &context,
875	semantics::UnorderedSymbolSet seenProcs) {
876	auto name{symbol.name().ToString()};
877	if (symbol.has<semantics::ObjectEntityDetails>() ||
878	symbol.has<semantics::EntityDetails>()) {
879	if (auto obj{DummyDataObject::Characterize(symbol, context)}) {
880	return DummyArgument{std::move(name), std::move(obj.value())};
881	}
882	} else if (auto proc{
883	CharacterizeDummyProcedure(symbol, context, seenProcs)}) {
884	return DummyArgument{std::move(name), std::move(proc.value())};
885	}
886	return std::nullopt;
887	}
888
889	std::optional<DummyArgument> DummyArgument::FromActual(std::string &&name,
890	const Expr<SomeType> &expr, FoldingContext &context,
891	bool forImplicitInterface) {
892	return common::visit(
893	common::visitors{
894	[&](const BOZLiteralConstant &) {
895	DummyDataObject obj{
896	TypeAndShape{DynamicType::TypelessIntrinsicArgument()}};
897	obj.attrs.set(DummyDataObject::Attr::DeducedFromActual);
898	return std::make_optional<DummyArgument>(
899	std::move(name), std::move(obj));
900	},
901	[&](const NullPointer &) {
902	DummyDataObject obj{
903	TypeAndShape{DynamicType::TypelessIntrinsicArgument()}};
904	obj.attrs.set(DummyDataObject::Attr::DeducedFromActual);
905	return std::make_optional<DummyArgument>(
906	std::move(name), std::move(obj));
907	},
908	[&](const ProcedureDesignator &designator) {
909	if (auto proc{Procedure::Characterize(
910	designator, context, /*emitError=*/true)}) {
911	return std::make_optional<DummyArgument>(
912	std::move(name), DummyProcedure{std::move(*proc)});
913	} else {
914	return std::optional<DummyArgument>{};
915	}
916	},
917	[&](const ProcedureRef &call) {
918	if (auto proc{Procedure::Characterize(call, context)}) {
919	return std::make_optional<DummyArgument>(
920	std::move(name), DummyProcedure{std::move(*proc)});
921	} else {
922	return std::optional<DummyArgument>{};
923	}
924	},
925	[&](const auto &) {
926	if (auto type{TypeAndShape::Characterize(expr, context)}) {
927	if (forImplicitInterface &&
928	!type->type().IsUnlimitedPolymorphic() &&
929	type->type().IsPolymorphic()) {
930	// Pass the monomorphic declared type to an implicit interface
931	type->set_type(DynamicType{
932	type->type().GetDerivedTypeSpec(), /*poly=*/false});
933	}
934	if (type->type().category() == TypeCategory::Character &&
935	type->type().kind() == 1) {
936	type->set_isPossibleSequenceAssociation(true);
937	} else if (const Symbol * array{IsArrayElement(expr)}) {
938	type->set_isPossibleSequenceAssociation(
939	IsContiguous(*array, context).value_or(false));
940	} else {
941	type->set_isPossibleSequenceAssociation(expr.Rank() > 0);
942	}
943	DummyDataObject obj{std::move(*type)};
944	obj.attrs.set(DummyDataObject::Attr::DeducedFromActual);
945	return std::make_optional<DummyArgument>(
946	std::move(name), std::move(obj));
947	} else {
948	return std::optional<DummyArgument>{};
949	}
950	},
951	},
952	expr.u);
953	}
954
955	std::optional<DummyArgument> DummyArgument::FromActual(std::string &&name,
956	const ActualArgument &arg, FoldingContext &context,
957	bool forImplicitInterface) {
958	if (const auto *expr{arg.UnwrapExpr()}) {
959	return FromActual(std::move(name), *expr, context, forImplicitInterface);
960	} else if (arg.GetAssumedTypeDummy()) {
961	return std::nullopt;
962	} else {
963	return DummyArgument{AlternateReturn{}};
964	}
965	}
966
967	bool DummyArgument::IsOptional() const {
968	return common::visit(
969	common::visitors{
970	[](const DummyDataObject &data) {
971	return data.attrs.test(DummyDataObject::Attr::Optional);
972	},
973	[](const DummyProcedure &proc) {
974	return proc.attrs.test(DummyProcedure::Attr::Optional);
975	},
976	[](const AlternateReturn &) { return false; },
977	},
978	u);
979	}
980
981	void DummyArgument::SetOptional(bool value) {
982	common::visit(common::visitors{
983	[value](DummyDataObject &data) {
984	data.attrs.set(DummyDataObject::Attr::Optional, value);
985	},
986	[value](DummyProcedure &proc) {
987	proc.attrs.set(DummyProcedure::Attr::Optional, value);
988	},
989	[](AlternateReturn &) { DIE("cannot set optional"); },
990	},
991	u);
992	}
993
994	void DummyArgument::SetIntent(common::Intent intent) {
995	common::visit(common::visitors{
996	[intent](DummyDataObject &data) { data.intent = intent; },
997	[intent](DummyProcedure &proc) { proc.intent = intent; },
998	[](AlternateReturn &) { DIE("cannot set intent"); },
999	},
1000	u);
1001	}
1002
1003	common::Intent DummyArgument::GetIntent() const {
1004	return common::visit(
1005	common::visitors{
1006	[](const DummyDataObject &data) { return data.intent; },
1007	[](const DummyProcedure &proc) { return proc.intent; },
1008	[](const AlternateReturn &) -> common::Intent {
1009	DIE("Alternate returns have no intent");
1010	},
1011	},
1012	u);
1013	}
1014
1015	bool DummyArgument::CanBePassedViaImplicitInterface(std::string *whyNot) const {
1016	if (const auto *object{std::get_if<DummyDataObject>(&u)}) {
1017	return object->CanBePassedViaImplicitInterface(whyNot);
1018	} else if (const auto *proc{std::get_if<DummyProcedure>(&u)}) {
1019	return proc->CanBePassedViaImplicitInterface(whyNot);
1020	} else {
1021	return true;
1022	}
1023	}
1024
1025	bool DummyArgument::IsTypelessIntrinsicDummy() const {
1026	const auto *argObj{std::get_if<characteristics::DummyDataObject>(&u)};
1027	return argObj && argObj->type.type().IsTypelessIntrinsicArgument();
1028	}
1029
1030	llvm::raw_ostream &DummyArgument::Dump(llvm::raw_ostream &o) const {
1031	if (!name.empty()) {
1032	o << name << '=';
1033	}
1034	if (pass) {
1035	o << " PASS";
1036	}
1037	common::visit([&](const auto &x) { x.Dump(o); }, u);
1038	return o;
1039	}
1040
1041	FunctionResult::FunctionResult(DynamicType t) : u{TypeAndShape{t}} {}
1042	FunctionResult::FunctionResult(TypeAndShape &&t) : u{std::move(t)} {}
1043	FunctionResult::FunctionResult(Procedure &&p) : u{std::move(p)} {}
1044	FunctionResult::~FunctionResult() {}
1045
1046	bool FunctionResult::operator==(const FunctionResult &that) const {
1047	return attrs == that.attrs && cudaDataAttr == that.cudaDataAttr &&
1048	u == that.u;
1049	}
1050
1051	static std::optional<FunctionResult> CharacterizeFunctionResult(
1052	const semantics::Symbol &symbol, FoldingContext &context,
1053	semantics::UnorderedSymbolSet seenProcs, bool emitError) {
1054	if (const auto *object{symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
1055	if (auto type{TypeAndShape::Characterize(
1056	symbol, context, /*invariantOnly=*/false)}) {
1057	FunctionResult result{std::move(*type)};
1058	CopyAttrs<FunctionResult, FunctionResult::Attr>(symbol, result,
1059	{
1060	{semantics::Attr::ALLOCATABLE, FunctionResult::Attr::Allocatable},
1061	{semantics::Attr::CONTIGUOUS, FunctionResult::Attr::Contiguous},
1062	{semantics::Attr::POINTER, FunctionResult::Attr::Pointer},
1063	});
1064	result.cudaDataAttr = object->cudaDataAttr();
1065	return result;
1066	}
1067	} else if (auto maybeProc{CharacterizeProcedure(
1068	symbol, context, seenProcs, emitError)}) {
1069	FunctionResult result{std::move(*maybeProc)};
1070	result.attrs.set(FunctionResult::Attr::Pointer);
1071	return result;
1072	}
1073	return std::nullopt;
1074	}
1075
1076	std::optional<FunctionResult> FunctionResult::Characterize(
1077	const Symbol &symbol, FoldingContext &context) {
1078	semantics::UnorderedSymbolSet seenProcs;
1079	return CharacterizeFunctionResult(
1080	symbol, context, seenProcs, /*emitError=*/false);
1081	}
1082
1083	bool FunctionResult::IsAssumedLengthCharacter() const {
1084	if (const auto *ts{std::get_if<TypeAndShape>(&u)}) {
1085	return ts->type().IsAssumedLengthCharacter();
1086	} else {
1087	return false;
1088	}
1089	}
1090
1091	bool FunctionResult::CanBeReturnedViaImplicitInterface(
1092	std::string *whyNot) const {
1093	if (attrs.test(Attr::Pointer) || attrs.test(Attr::Allocatable)) {
1094	if (whyNot) {
1095	*whyNot = "the function result is a pointer or allocatable";
1096	}
1097	return false; // 15.4.2.2(4)(b)
1098	} else if (cudaDataAttr) {
1099	if (whyNot) {
1100	*whyNot = "the function result has CUDA attributes";
1101	}
1102	return false;
1103	} else if (const auto *typeAndShape{GetTypeAndShape()}) {
1104	if (typeAndShape->Rank() > 0) {
1105	if (whyNot) {
1106	*whyNot = "the function result is an array";
1107	}
1108	return false; // 15.4.2.2(4)(a)
1109	} else {
1110	const DynamicType &type{typeAndShape->type()};
1111	switch (type.category()) {
1112	case TypeCategory::Character:
1113	if (type.knownLength()) {
1114	return true;
1115	} else if (const auto *param{type.charLengthParamValue()}) {
1116	if (const auto &expr{param->GetExplicit()}) {
1117	if (IsConstantExpr(*expr)) { // 15.4.2.2(4)(c)
1118	return true;
1119	} else {
1120	if (whyNot) {
1121	*whyNot = "the function result's length is not constant";
1122	}
1123	return false;
1124	}
1125	} else if (param->isAssumed()) {
1126	return true;
1127	}
1128	}
1129	if (whyNot) {
1130	*whyNot = "the function result's length is not known to the caller";
1131	}
1132	return false;
1133	case TypeCategory::Derived:
1134	if (type.IsPolymorphic()) {
1135	if (whyNot) {
1136	*whyNot = "the function result is polymorphic";
1137	}
1138	return false;
1139	} else {
1140	const auto &spec{type.GetDerivedTypeSpec()};
1141	for (const auto &pair : spec.parameters()) {
1142	if (const auto &expr{pair.second.GetExplicit()}) {
1143	if (!IsConstantExpr(*expr)) {
1144	if (whyNot) {
1145	*whyNot = "the function result's derived type has a "
1146	"non-constant parameter";
1147	}
1148	return false; // 15.4.2.2(4)(c)
1149	}
1150	}
1151	}
1152	return true;
1153	}
1154	default:
1155	return true;
1156	}
1157	}
1158	} else {
1159	if (whyNot) {
1160	*whyNot = "the function result has unknown type or shape";
1161	}
1162	return false; // 15.4.2.2(4)(b) - procedure pointer?
1163	}
1164	}
1165
1166	static std::optional<std::string> AreIncompatibleFunctionResultShapes(
1167	const Shape &x, const Shape &y) {
1168	// Function results cannot be assumed-rank, hence the non optional arguments.
1169	int rank{GetRank(x)};
1170	if (int yrank{GetRank(y)}; yrank != rank) {
1171	return "rank "s + std::to_string(rank) + " vs " + std::to_string(yrank);
1172	}
1173	for (int j{0}; j < rank; ++j) {
1174	if (x[j] && y[j] && !(*x[j] == *y[j])) {
1175	return x[j]->AsFortran() + " vs " + y[j]->AsFortran();
1176	}
1177	}
1178	return std::nullopt;
1179	}
1180
1181	bool FunctionResult::IsCompatibleWith(
1182	const FunctionResult &actual, std::string *whyNot) const {
1183	Attrs actualAttrs{actual.attrs};
1184	if (!attrs.test(Attr::Contiguous)) {
1185	actualAttrs.reset(Attr::Contiguous);
1186	}
1187	if (attrs != actualAttrs) {
1188	if (whyNot) {
1189	*whyNot = "function results have incompatible attributes";
1190	}
1191	} else if (cudaDataAttr != actual.cudaDataAttr) {
1192	if (whyNot) {
1193	*whyNot = "function results have incompatible CUDA data attributes";
1194	}
1195	} else if (const auto *ifaceTypeShape{std::get_if<TypeAndShape>(&u)}) {
1196	if (const auto *actualTypeShape{std::get_if<TypeAndShape>(&actual.u)}) {
1197	std::optional<std::string> details;
1198	if (ifaceTypeShape->Rank() != actualTypeShape->Rank()) {
1199	if (whyNot) {
1200	*whyNot = "function results have distinct ranks";
1201	}
1202	} else if (!attrs.test(Attr::Allocatable) && !attrs.test(Attr::Pointer) &&
1203	(details = AreIncompatibleFunctionResultShapes(
1204	ifaceTypeShape->shape().value(),
1205	actualTypeShape->shape().value()))) {
1206	if (whyNot) {
1207	*whyNot = "function results have distinct extents (" + *details + ')';
1208	}
1209	} else if (ifaceTypeShape->type() != actualTypeShape->type()) {
1210	if (ifaceTypeShape->type().category() !=
1211	actualTypeShape->type().category()) {
1212	} else if (ifaceTypeShape->type().category() ==
1213	TypeCategory::Character) {
1214	if (ifaceTypeShape->type().kind() == actualTypeShape->type().kind()) {
1215	if (IsAssumedLengthCharacter() ||
1216	actual.IsAssumedLengthCharacter()) {
1217	return true;
1218	} else {
1219	auto len{ToInt64(ifaceTypeShape->LEN())};
1220	auto actualLen{ToInt64(actualTypeShape->LEN())};
1221	if (len.has_value() != actualLen.has_value()) {
1222	if (whyNot) {
1223	*whyNot = "constant-length vs non-constant-length character "
1224	"results";
1225	}
1226	} else if (len && *len != *actualLen) {
1227	if (whyNot) {
1228	*whyNot = "character results with distinct lengths";
1229	}
1230	} else {
1231	const auto *ifaceLenParam{
1232	ifaceTypeShape->type().charLengthParamValue()};
1233	const auto *actualLenParam{
1234	actualTypeShape->type().charLengthParamValue()};
1235	if (ifaceLenParam && actualLenParam &&
1236	ifaceLenParam->isExplicit() !=
1237	actualLenParam->isExplicit()) {
1238	if (whyNot) {
1239	*whyNot =
1240	"explicit-length vs deferred-length character results";
1241	}
1242	} else {
1243	return true;
1244	}
1245	}
1246	}
1247	}
1248	} else if (ifaceTypeShape->type().category() == TypeCategory::Derived) {
1249	if (ifaceTypeShape->type().IsPolymorphic() ==
1250	actualTypeShape->type().IsPolymorphic() &&
1251	!ifaceTypeShape->type().IsUnlimitedPolymorphic() &&
1252	!actualTypeShape->type().IsUnlimitedPolymorphic() &&
1253	AreSameDerivedType(ifaceTypeShape->type().GetDerivedTypeSpec(),
1254	actualTypeShape->type().GetDerivedTypeSpec())) {
1255	return true;
1256	}
1257	}
1258	if (whyNot) {
1259	*whyNot = "function results have distinct types: "s +
1260	ifaceTypeShape->type().AsFortran() + " vs "s +
1261	actualTypeShape->type().AsFortran();
1262	}
1263	} else {
1264	return true;
1265	}
1266	} else {
1267	if (whyNot) {
1268	*whyNot = "function result type and shape are not known";
1269	}
1270	}
1271	} else {
1272	const auto *ifaceProc{std::get_if<CopyableIndirection<Procedure>>(&u)};
1273	CHECK(ifaceProc != nullptr);
1274	if (const auto *actualProc{
1275	std::get_if<CopyableIndirection<Procedure>>(&actual.u)}) {
1276	if (ifaceProc->value().IsCompatibleWith(actualProc->value(),
1277	/*ignoreImplicitVsExplicit=*/false, whyNot)) {
1278	return true;
1279	}
1280	if (whyNot) {
1281	*whyNot =
1282	"function results are incompatible procedure pointers: "s + *whyNot;
1283	}
1284	} else {
1285	if (whyNot) {
1286	*whyNot =
1287	"one function result is a procedure pointer, the other is not";
1288	}
1289	}
1290	}
1291	return false;
1292	}
1293
1294	llvm::raw_ostream &FunctionResult::Dump(llvm::raw_ostream &o) const {
1295	attrs.Dump(o, EnumToString);
1296	common::visit(common::visitors{
1297	[&](const TypeAndShape &ts) { ts.Dump(o); },
1298	[&](const CopyableIndirection<Procedure> &p) {
1299	p.value().Dump(o << " procedure(") << ')';
1300	},
1301	},
1302	u);
1303	if (cudaDataAttr) {
1304	o << " cudaDataAttr: " << common::EnumToString(*cudaDataAttr);
1305	}
1306	return o;
1307	}
1308
1309	Procedure::Procedure(FunctionResult &&fr, DummyArguments &&args, Attrs a)
1310	: functionResult{std::move(fr)}, dummyArguments{std::move(args)}, attrs{a} {
1311	}
1312	Procedure::Procedure(DummyArguments &&args, Attrs a)
1313	: dummyArguments{std::move(args)}, attrs{a} {}
1314	Procedure::~Procedure() {}
1315
1316	bool Procedure::operator==(const Procedure &that) const {
1317	return attrs == that.attrs && functionResult == that.functionResult &&
1318	dummyArguments == that.dummyArguments &&
1319	cudaSubprogramAttrs == that.cudaSubprogramAttrs;
1320	}
1321
1322	bool Procedure::IsCompatibleWith(const Procedure &actual,
1323	bool ignoreImplicitVsExplicit, std::string *whyNot,
1324	const SpecificIntrinsic *specificIntrinsic,
1325	std::optional<std::string> *warning) const {
1326	// 15.5.2.9(1): if dummy is not pure, actual need not be.
1327	// Ditto with elemental.
1328	Attrs actualAttrs{actual.attrs};
1329	if (!attrs.test(Attr::Pure)) {
1330	actualAttrs.reset(Attr::Pure);
1331	}
1332	if (!attrs.test(Attr::Elemental) && specificIntrinsic) {
1333	actualAttrs.reset(Attr::Elemental);
1334	}
1335	Attrs differences{attrs ^ actualAttrs};
1336	differences.reset(Attr::Subroutine); // dealt with specifically later
1337	if (ignoreImplicitVsExplicit) {
1338	differences.reset(Attr::ImplicitInterface);
1339	}
1340	if (!differences.empty()) {
1341	if (whyNot) {
1342	auto sep{": "s};
1343	*whyNot = "incompatible procedure attributes";
1344	differences.IterateOverMembers([&](Attr x) {
1345	*whyNot += sep + std::string{EnumToString(x)};
1346	sep = ", ";
1347	});
1348	}
1349	} else if ((IsFunction() && actual.IsSubroutine()) ||
1350	(IsSubroutine() && actual.IsFunction())) {
1351	if (whyNot) {
1352	*whyNot =
1353	"incompatible procedures: one is a function, the other a subroutine";
1354	}
1355	} else if (functionResult && actual.functionResult &&
1356	!functionResult->IsCompatibleWith(*actual.functionResult, whyNot)) {
1357	} else if (cudaSubprogramAttrs != actual.cudaSubprogramAttrs) {
1358	if (whyNot) {
1359	*whyNot = "incompatible CUDA subprogram attributes";
1360	}
1361	} else if (dummyArguments.size() != actual.dummyArguments.size()) {
1362	if (whyNot) {
1363	*whyNot = "distinct numbers of dummy arguments";
1364	}
1365	} else {
1366	for (std::size_t j{0}; j < dummyArguments.size(); ++j) {
1367	// Subtlety: the dummy/actual distinction must be reversed for this
1368	// compatibility test in order to correctly check extended vs.
1369	// base types. Example:
1370	// subroutine s1(base); subroutine s2(extended)
1371	// procedure(s1), pointer :: p
1372	// p => s2 ! an error, s2 is more restricted, can't handle "base"
1373	std::optional<std::string> gotWarning;
1374	if (!actual.dummyArguments[j].IsCompatibleWith(
1375	dummyArguments[j], whyNot, warning ? &gotWarning : nullptr)) {
1376	if (whyNot) {
1377	*whyNot = "incompatible dummy argument #"s + std::to_string(j + 1) +
1378	": "s + *whyNot;
1379	}
1380	return false;
1381	} else if (warning && !*warning && gotWarning) {
1382	*warning = "possibly incompatible dummy argument #"s +
1383	std::to_string(j + 1) + ": "s + std::move(*gotWarning);
1384	}
1385	}
1386	return true;
1387	}
1388	return false;
1389	}
1390
1391	std::optional<int> Procedure::FindPassIndex(
1392	std::optional<parser::CharBlock> name) const {
1393	int argCount{static_cast<int>(dummyArguments.size())};
1394	if (name) {
1395	for (int index{0}; index < argCount; ++index) {
1396	if (*name == dummyArguments[index].name.c_str()) {
1397	return index;
1398	}
1399	}
1400	return std::nullopt;
1401	} else if (argCount > 0) {
1402	return 0;
1403	} else {
1404	return std::nullopt;
1405	}
1406	}
1407
1408	bool Procedure::CanOverride(
1409	const Procedure &that, std::optional<int> passIndex) const {
1410	// A pure procedure may override an impure one (7.5.7.3(2))
1411	if ((that.attrs.test(Attr::Pure) && !attrs.test(Attr::Pure)) ||
1412	that.attrs.test(Attr::Elemental) != attrs.test(Attr::Elemental) ||
1413	functionResult != that.functionResult) {
1414	return false;
1415	}
1416	int argCount{static_cast<int>(dummyArguments.size())};
1417	if (argCount != static_cast<int>(that.dummyArguments.size())) {
1418	return false;
1419	}
1420	for (int j{0}; j < argCount; ++j) {
1421	if (passIndex && j == *passIndex) {
1422	if (!that.dummyArguments[j].IsCompatibleWith(dummyArguments[j])) {
1423	return false;
1424	}
1425	} else if (dummyArguments[j] != that.dummyArguments[j]) {
1426	return false;
1427	}
1428	}
1429	return true;
1430	}
1431
1432	std::optional<Procedure> Procedure::Characterize(
1433	const semantics::Symbol &symbol, FoldingContext &context) {
1434	semantics::UnorderedSymbolSet seenProcs;
1435	return CharacterizeProcedure(symbol, context, seenProcs, /*emitError=*/true);
1436	}
1437
1438	std::optional<Procedure> Procedure::Characterize(
1439	const ProcedureDesignator &proc, FoldingContext &context, bool emitError) {
1440	if (const auto *symbol{proc.GetSymbol()}) {
1441	semantics::UnorderedSymbolSet seenProcs;
1442	return CharacterizeProcedure(*symbol, context, seenProcs, emitError);
1443	} else if (const auto *intrinsic{proc.GetSpecificIntrinsic()}) {
1444	return intrinsic->characteristics.value();
1445	} else {
1446	return std::nullopt;
1447	}
1448	}
1449
1450	std::optional<Procedure> Procedure::Characterize(
1451	const ProcedureRef &ref, FoldingContext &context) {
1452	if (auto callee{Characterize(ref.proc(), context, /*emitError=*/true)}) {
1453	if (callee->functionResult) {
1454	if (const Procedure *
1455	proc{callee->functionResult->IsProcedurePointer()}) {
1456	return {*proc};
1457	}
1458	}
1459	}
1460	return std::nullopt;
1461	}
1462
1463	std::optional<Procedure> Procedure::Characterize(
1464	const Expr<SomeType> &expr, FoldingContext &context) {
1465	if (const auto *procRef{UnwrapProcedureRef(expr)}) {
1466	return Characterize(*procRef, context);
1467	} else if (const auto *procDesignator{
1468	std::get_if<ProcedureDesignator>(&expr.u)}) {
1469	return Characterize(*procDesignator, context, /*emitError=*/true);
1470	} else if (const Symbol * symbol{UnwrapWholeSymbolOrComponentDataRef(expr)}) {
1471	return Characterize(*symbol, context);
1472	} else {
1473	context.messages().Say(
1474	"Expression '%s' is not a procedure"_err_en_US, expr.AsFortran());
1475	return std::nullopt;
1476	}
1477	}
1478
1479	std::optional<Procedure> Procedure::FromActuals(const ProcedureDesignator &proc,
1480	const ActualArguments &args, FoldingContext &context) {
1481	auto callee{Characterize(proc, context, /*emitError=*/true)};
1482	if (callee) {
1483	if (callee->dummyArguments.empty() &&
1484	callee->attrs.test(Procedure::Attr::ImplicitInterface)) {
1485	int j{0};
1486	for (const auto &arg : args) {
1487	++j;
1488	if (arg) {
1489	if (auto dummy{DummyArgument::FromActual("x"s + std::to_string(j),
1490	*arg, context,
1491	/*forImplicitInterface=*/true)}) {
1492	callee->dummyArguments.emplace_back(std::move(*dummy));
1493	continue;
1494	}
1495	}
1496	callee.reset();
1497	break;
1498	}
1499	}
1500	}
1501	return callee;
1502	}
1503
1504	bool Procedure::CanBeCalledViaImplicitInterface(std::string *whyNot) const {
1505	if (attrs.test(Attr::Elemental)) {
1506	if (whyNot) {
1507	*whyNot = "the procedure is elemental";
1508	}
1509	return false; // 15.4.2.2(5,6)
1510	} else if (attrs.test(Attr::BindC)) {
1511	if (whyNot) {
1512	*whyNot = "the procedure is BIND(C)";
1513	}
1514	return false; // 15.4.2.2(5,6)
1515	} else if (cudaSubprogramAttrs &&
1516	*cudaSubprogramAttrs != common::CUDASubprogramAttrs::Host &&
1517	*cudaSubprogramAttrs != common::CUDASubprogramAttrs::Global) {
1518	if (whyNot) {
1519	*whyNot = "the procedure is CUDA but neither HOST nor GLOBAL";
1520	}
1521	return false;
1522	} else if (IsFunction() &&
1523	!functionResult->CanBeReturnedViaImplicitInterface(whyNot)) {
1524	return false;
1525	} else {
1526	for (const DummyArgument &arg : dummyArguments) {
1527	if (!arg.CanBePassedViaImplicitInterface(whyNot)) {
1528	return false;
1529	}
1530	}
1531	return true;
1532	}
1533	}
1534
1535	llvm::raw_ostream &Procedure::Dump(llvm::raw_ostream &o) const {
1536	attrs.Dump(o, EnumToString);
1537	if (functionResult) {
1538	functionResult->Dump(o << "TYPE(") << ") FUNCTION";
1539	} else if (attrs.test(Attr::Subroutine)) {
1540	o << "SUBROUTINE";
1541	} else {
1542	o << "EXTERNAL";
1543	}
1544	char sep{'('};
1545	for (const auto &dummy : dummyArguments) {
1546	dummy.Dump(o << sep);
1547	sep = ',';
1548	}
1549	o << (sep == '(' ? "()" : ")");
1550	if (cudaSubprogramAttrs) {
1551	o << " cudaSubprogramAttrs: " << common::EnumToString(*cudaSubprogramAttrs);
1552	}
1553	return o;
1554	}
1555
1556	// Utility class to determine if Procedures, etc. are distinguishable
1557	class DistinguishUtils {
1558	public:
1559	explicit DistinguishUtils(const common::LanguageFeatureControl &features)
1560	: features_{features} {}
1561
1562	// Are these procedures distinguishable for a generic name?
1563	std::optional<bool> Distinguishable(
1564	const Procedure &, const Procedure &) const;
1565	// Are these procedures distinguishable for a generic operator or assignment?
1566	std::optional<bool> DistinguishableOpOrAssign(
1567	const Procedure &, const Procedure &) const;
1568
1569	private:
1570	struct CountDummyProcedures {
1571	CountDummyProcedures(const DummyArguments &args) {
1572	for (const DummyArgument &arg : args) {
1573	if (std::holds_alternative<DummyProcedure>(arg.u)) {
1574	total += 1;
1575	notOptional += !arg.IsOptional();
1576	}
1577	}
1578	}
1579	int total{0};
1580	int notOptional{0};
1581	};
1582
1583	bool AnyOptionalData(const DummyArguments &) const;
1584	bool AnyUnlimitedPolymorphicData(const DummyArguments &) const;
1585	bool Rule3Distinguishable(const Procedure &, const Procedure &) const;
1586	const DummyArgument *Rule1DistinguishingArg(
1587	const DummyArguments &, const DummyArguments &) const;
1588	int FindFirstToDistinguishByPosition(
1589	const DummyArguments &, const DummyArguments &) const;
1590	int FindLastToDistinguishByName(
1591	const DummyArguments &, const DummyArguments &) const;
1592	int CountCompatibleWith(const DummyArgument &, const DummyArguments &) const;
1593	int CountNotDistinguishableFrom(
1594	const DummyArgument &, const DummyArguments &) const;
1595	bool Distinguishable(const DummyArgument &, const DummyArgument &) const;
1596	bool Distinguishable(const DummyDataObject &, const DummyDataObject &) const;
1597	bool Distinguishable(const DummyProcedure &, const DummyProcedure &) const;
1598	bool Distinguishable(const FunctionResult &, const FunctionResult &) const;
1599	bool Distinguishable(
1600	const TypeAndShape &, const TypeAndShape &, common::IgnoreTKRSet) const;
1601	bool IsTkrCompatible(const DummyArgument &, const DummyArgument &) const;
1602	bool IsTkCompatible(const DummyDataObject &, const DummyDataObject &) const;
1603	const DummyArgument *GetAtEffectivePosition(
1604	const DummyArguments &, int) const;
1605	const DummyArgument *GetPassArg(const Procedure &) const;
1606
1607	const common::LanguageFeatureControl &features_;
1608	};
1609
1610	// Simpler distinguishability rules for operators and assignment
1611	std::optional<bool> DistinguishUtils::DistinguishableOpOrAssign(
1612	const Procedure &proc1, const Procedure &proc2) const {
1613	if ((proc1.IsFunction() && proc2.IsSubroutine()) ||
1614	(proc1.IsSubroutine() && proc2.IsFunction())) {
1615	return true;
1616	}
1617	auto &args1{proc1.dummyArguments};
1618	auto &args2{proc2.dummyArguments};
1619	if (args1.size() != args2.size()) {
1620	return true; // C1511: distinguishable based on number of arguments
1621	}
1622	for (std::size_t i{0}; i < args1.size(); ++i) {
1623	if (Distinguishable(args1[i], args2[i])) {
1624	return true; // C1511, C1512: distinguishable based on this arg
1625	}
1626	}
1627	return false;
1628	}
1629
1630	std::optional<bool> DistinguishUtils::Distinguishable(
1631	const Procedure &proc1, const Procedure &proc2) const {
1632	if ((proc1.IsFunction() && proc2.IsSubroutine()) ||
1633	(proc1.IsSubroutine() && proc2.IsFunction())) {
1634	return true;
1635	}
1636	auto &args1{proc1.dummyArguments};
1637	auto &args2{proc2.dummyArguments};
1638	auto count1{CountDummyProcedures(args1)};
1639	auto count2{CountDummyProcedures(args2)};
1640	if (count1.notOptional > count2.total || count2.notOptional > count1.total) {
1641	return true; // distinguishable based on C1514 rule 2
1642	}
1643	if (Rule3Distinguishable(proc1, proc2)) {
1644	return true; // distinguishable based on C1514 rule 3
1645	}
1646	if (Rule1DistinguishingArg(args1, args2)) {
1647	return true; // distinguishable based on C1514 rule 1
1648	}
1649	int pos1{FindFirstToDistinguishByPosition(args1, args2)};
1650	int name1{FindLastToDistinguishByName(args1, args2)};
1651	if (pos1 >= 0 && pos1 <= name1) {
1652	return true; // distinguishable based on C1514 rule 4
1653	}
1654	int pos2{FindFirstToDistinguishByPosition(args2, args1)};
1655	int name2{FindLastToDistinguishByName(args2, args1)};
1656	if (pos2 >= 0 && pos2 <= name2) {
1657	return true; // distinguishable based on C1514 rule 4
1658	}
1659	if (proc1.cudaSubprogramAttrs != proc2.cudaSubprogramAttrs) {
1660	return true;
1661	}
1662	// If there are no optional or unlimited polymorphic dummy arguments,
1663	// then we know the result for sure; otherwise, it's possible for
1664	// the procedures to be unambiguous.
1665	if ((AnyOptionalData(args1) || AnyUnlimitedPolymorphicData(args1)) &&
1666	(AnyOptionalData(args2) || AnyUnlimitedPolymorphicData(args2))) {
1667	return std::nullopt; // meaning "maybe"
1668	} else {
1669	return false;
1670	}
1671	}
1672
1673	bool DistinguishUtils::AnyOptionalData(const DummyArguments &args) const {
1674	for (const auto &arg : args) {
1675	if (std::holds_alternative<DummyDataObject>(arg.u) && arg.IsOptional()) {
1676	return true;
1677	}
1678	}
1679	return false;
1680	}
1681
1682	bool DistinguishUtils::AnyUnlimitedPolymorphicData(
1683	const DummyArguments &args) const {
1684	for (const auto &arg : args) {
1685	if (const auto *object{std::get_if<DummyDataObject>(&arg.u)}) {
1686	if (object->type.type().IsUnlimitedPolymorphic()) {
1687	return true;
1688	}
1689	}
1690	}
1691	return false;
1692	}
1693
1694	// C1514 rule 3: Procedures are distinguishable if both have a passed-object
1695	// dummy argument and those are distinguishable.
1696	bool DistinguishUtils::Rule3Distinguishable(
1697	const Procedure &proc1, const Procedure &proc2) const {
1698	const DummyArgument *pass1{GetPassArg(proc1)};
1699	const DummyArgument *pass2{GetPassArg(proc2)};
1700	return pass1 && pass2 && Distinguishable(*pass1, *pass2);
1701	}
1702
1703	// Find a non-passed-object dummy data object in one of the argument lists
1704	// that satisfies C1514 rule 1. I.e. x such that:
1705	// - m is the number of dummy data objects in one that are nonoptional,
1706	// are not passed-object, that x is TKR compatible with
1707	// - n is the number of non-passed-object dummy data objects, in the other
1708	// that are not distinguishable from x
1709	// - m is greater than n
1710	const DummyArgument *DistinguishUtils::Rule1DistinguishingArg(
1711	const DummyArguments &args1, const DummyArguments &args2) const {
1712	auto size1{args1.size()};
1713	auto size2{args2.size()};
1714	for (std::size_t i{0}; i < size1 + size2; ++i) {
1715	const DummyArgument &x{i < size1 ? args1[i] : args2[i - size1]};
1716	if (!x.pass && std::holds_alternative<DummyDataObject>(x.u)) {
1717	if (CountCompatibleWith(x, args1) >
1718	CountNotDistinguishableFrom(x, args2) ||
1719	CountCompatibleWith(x, args2) >
1720	CountNotDistinguishableFrom(x, args1)) {
1721	return &x;
1722	}
1723	}
1724	}
1725	return nullptr;
1726	}
1727
1728	// Find the index of the first nonoptional non-passed-object dummy argument
1729	// in args1 at an effective position such that either:
1730	// - args2 has no dummy argument at that effective position
1731	// - the dummy argument at that position is distinguishable from it
1732	int DistinguishUtils::FindFirstToDistinguishByPosition(
1733	const DummyArguments &args1, const DummyArguments &args2) const {
1734	int effective{0}; // position of arg1 in list, ignoring passed arg
1735	for (std::size_t i{0}; i < args1.size(); ++i) {
1736	const DummyArgument &arg1{args1.at(i)};
1737	if (!arg1.pass && !arg1.IsOptional()) {
1738	const DummyArgument *arg2{GetAtEffectivePosition(args2, effective)};
1739	if (!arg2 || Distinguishable(arg1, *arg2)) {
1740	return i;
1741	}
1742	}
1743	effective += !arg1.pass;
1744	}
1745	return -1;
1746	}
1747
1748	// Find the index of the last nonoptional non-passed-object dummy argument
1749	// in args1 whose name is such that either:
1750	// - args2 has no dummy argument with that name
1751	// - the dummy argument with that name is distinguishable from it
1752	int DistinguishUtils::FindLastToDistinguishByName(
1753	const DummyArguments &args1, const DummyArguments &args2) const {
1754	std::map<std::string, const DummyArgument *> nameToArg;
1755	for (const auto &arg2 : args2) {
1756	nameToArg.emplace(arg2.name, &arg2);
1757	}
1758	for (int i = args1.size() - 1; i >= 0; --i) {
1759	const DummyArgument &arg1{args1.at(i)};
1760	if (!arg1.pass && !arg1.IsOptional()) {
1761	auto it{nameToArg.find(arg1.name)};
1762	if (it == nameToArg.end() || Distinguishable(arg1, *it->second)) {
1763	return i;
1764	}
1765	}
1766	}
1767	return -1;
1768	}
1769
1770	// Count the dummy data objects in args that are nonoptional, are not
1771	// passed-object, and that x is TKR compatible with
1772	int DistinguishUtils::CountCompatibleWith(
1773	const DummyArgument &x, const DummyArguments &args) const {
1774	return llvm::count_if(args, [&](const DummyArgument &y) {
1775	return !y.pass && !y.IsOptional() && IsTkrCompatible(x, y);
1776	});
1777	}
1778
1779	// Return the number of dummy data objects in args that are not
1780	// distinguishable from x and not passed-object.
1781	int DistinguishUtils::CountNotDistinguishableFrom(
1782	const DummyArgument &x, const DummyArguments &args) const {
1783	return llvm::count_if(args, [&](const DummyArgument &y) {
1784	return !y.pass && std::holds_alternative<DummyDataObject>(y.u) &&
1785	!Distinguishable(y, x);
1786	});
1787	}
1788
1789	bool DistinguishUtils::Distinguishable(
1790	const DummyArgument &x, const DummyArgument &y) const {
1791	if (x.u.index() != y.u.index()) {
1792	return true; // different kind: data/proc/alt-return
1793	}
1794	return common::visit(
1795	common::visitors{
1796	[&](const DummyDataObject &z) {
1797	return Distinguishable(z, std::get<DummyDataObject>(y.u));
1798	},
1799	[&](const DummyProcedure &z) {
1800	return Distinguishable(z, std::get<DummyProcedure>(y.u));
1801	},
1802	[&](const AlternateReturn &) { return false; },
1803	},
1804	x.u);
1805	}
1806
1807	bool DistinguishUtils::Distinguishable(
1808	const DummyDataObject &x, const DummyDataObject &y) const {
1809	using Attr = DummyDataObject::Attr;
1810	if (Distinguishable(x.type, y.type, x.ignoreTKR | y.ignoreTKR)) {
1811	return true;
1812	} else if (x.attrs.test(Attr::Allocatable) && y.attrs.test(Attr::Pointer) &&
1813	y.intent != common::Intent::In) {
1814	return true;
1815	} else if (y.attrs.test(Attr::Allocatable) && x.attrs.test(Attr::Pointer) &&
1816	x.intent != common::Intent::In) {
1817	return true;
1818	} else if (!common::AreCompatibleCUDADataAttrs(x.cudaDataAttr, y.cudaDataAttr,
1819	x.ignoreTKR | y.ignoreTKR, nullptr,
1820	/*allowUnifiedMatchingRule=*/false,
1821	/*=isHostDeviceProcedure*/ false)) {
1822	return true;
1823	} else if (features_.IsEnabled(
1824	common::LanguageFeature::DistinguishableSpecifics) &&
1825	(x.attrs.test(Attr::Allocatable) || x.attrs.test(Attr::Pointer)) &&
1826	(y.attrs.test(Attr::Allocatable) || y.attrs.test(Attr::Pointer)) &&
1827	(x.type.type().IsUnlimitedPolymorphic() !=
1828	y.type.type().IsUnlimitedPolymorphic() ||
1829	x.type.type().IsPolymorphic() != y.type.type().IsPolymorphic())) {
1830	// Extension: Per 15.5.2.5(2), an allocatable/pointer dummy and its
1831	// corresponding actual argument must both or neither be polymorphic,
1832	// and must both or neither be unlimited polymorphic. So when exactly
1833	// one of two dummy arguments is polymorphic or unlimited polymorphic,
1834	// any actual argument that is admissible to one of them cannot also match
1835	// the other one.
1836	return true;
1837	} else {
1838	return false;
1839	}
1840	}
1841
1842	bool DistinguishUtils::Distinguishable(
1843	const DummyProcedure &x, const DummyProcedure &y) const {
1844	const Procedure &xProc{x.procedure.value()};
1845	const Procedure &yProc{y.procedure.value()};
1846	if (Distinguishable(xProc, yProc).value_or(false)) {
1847	return true;
1848	} else {
1849	const std::optional<FunctionResult> &xResult{xProc.functionResult};
1850	const std::optional<FunctionResult> &yResult{yProc.functionResult};
1851	return xResult ? !yResult || Distinguishable(*xResult, *yResult)
1852	: yResult.has_value();
1853	}
1854	}
1855
1856	bool DistinguishUtils::Distinguishable(
1857	const FunctionResult &x, const FunctionResult &y) const {
1858	if (x.u.index() != y.u.index()) {
1859	return true; // one is data object, one is procedure
1860	}
1861	if (x.cudaDataAttr != y.cudaDataAttr) {
1862	return true;
1863	}
1864	return common::visit(
1865	common::visitors{
1866	[&](const TypeAndShape &z) {
1867	return Distinguishable(
1868	z, std::get<TypeAndShape>(y.u), common::IgnoreTKRSet{});
1869	},
1870	[&](const CopyableIndirection<Procedure> &z) {
1871	return Distinguishable(z.value(),
1872	std::get<CopyableIndirection<Procedure>>(y.u).value())
1873	.value_or(false);
1874	},
1875	},
1876	x.u);
1877	}
1878
1879	bool DistinguishUtils::Distinguishable(const TypeAndShape &x,
1880	const TypeAndShape &y, common::IgnoreTKRSet ignoreTKR) const {
1881	if (!x.type().IsTkCompatibleWith(y.type(), ignoreTKR) &&
1882	!y.type().IsTkCompatibleWith(x.type(), ignoreTKR)) {
1883	return true;
1884	}
1885	if (ignoreTKR.test(common::IgnoreTKR::Rank)) {
1886	} else if (x.attrs().test(TypeAndShape::Attr::AssumedRank) ||
1887	y.attrs().test(TypeAndShape::Attr::AssumedRank)) {
1888	} else if (x.Rank() != y.Rank()) {
1889	return true;
1890	}
1891	return false;
1892	}
1893
1894	// Compatibility based on type, kind, and rank
1895
1896	bool DistinguishUtils::IsTkrCompatible(
1897	const DummyArgument &x, const DummyArgument &y) const {
1898	const auto *obj1{std::get_if<DummyDataObject>(&x.u)};
1899	const auto *obj2{std::get_if<DummyDataObject>(&y.u)};
1900	return obj1 && obj2 && IsTkCompatible(*obj1, *obj2) &&
1901	(obj1->type.Rank() == obj2->type.Rank() ||
1902	obj1->type.attrs().test(TypeAndShape::Attr::AssumedRank) ||
1903	obj2->type.attrs().test(TypeAndShape::Attr::AssumedRank) ||
1904	obj1->ignoreTKR.test(common::IgnoreTKR::Rank) ||
1905	obj2->ignoreTKR.test(common::IgnoreTKR::Rank));
1906	}
1907
1908	bool DistinguishUtils::IsTkCompatible(
1909	const DummyDataObject &x, const DummyDataObject &y) const {
1910	return x.type.type().IsTkCompatibleWith(
1911	y.type.type(), x.ignoreTKR | y.ignoreTKR);
1912	}
1913
1914	// Return the argument at the given index, ignoring the passed arg
1915	const DummyArgument *DistinguishUtils::GetAtEffectivePosition(
1916	const DummyArguments &args, int index) const {
1917	for (const DummyArgument &arg : args) {
1918	if (!arg.pass) {
1919	if (index == 0) {
1920	return &arg;
1921	}
1922	--index;
1923	}
1924	}
1925	return nullptr;
1926	}
1927
1928	// Return the passed-object dummy argument of this procedure, if any
1929	const DummyArgument *DistinguishUtils::GetPassArg(const Procedure &proc) const {
1930	for (const auto &arg : proc.dummyArguments) {
1931	if (arg.pass) {
1932	return &arg;
1933	}
1934	}
1935	return nullptr;
1936	}
1937
1938	std::optional<bool> Distinguishable(
1939	const common::LanguageFeatureControl &features, const Procedure &x,
1940	const Procedure &y) {
1941	return DistinguishUtils{features}.Distinguishable(x, y);
1942	}
1943
1944	std::optional<bool> DistinguishableOpOrAssign(
1945	const common::LanguageFeatureControl &features, const Procedure &x,
1946	const Procedure &y) {
1947	return DistinguishUtils{features}.DistinguishableOpOrAssign(x, y);
1948	}
1949
1950	DEFINE_DEFAULT_CONSTRUCTORS_AND_ASSIGNMENTS(DummyArgument)
1951	DEFINE_DEFAULT_CONSTRUCTORS_AND_ASSIGNMENTS(DummyProcedure)
1952	DEFINE_DEFAULT_CONSTRUCTORS_AND_ASSIGNMENTS(FunctionResult)
1953	DEFINE_DEFAULT_CONSTRUCTORS_AND_ASSIGNMENTS(Procedure)
1954	} // namespace Fortran::evaluate::characteristics
1955
1956	template class Fortran::common::Indirection<
1957	Fortran::evaluate::characteristics::Procedure, true>;
1958