1	//===-- lib/Semantics/check-declarations.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	// Static declaration checking
10
11	#include "check-declarations.h"
12	#include "definable.h"
13	#include "pointer-assignment.h"
14	#include "flang/Evaluate/check-expression.h"
15	#include "flang/Evaluate/fold.h"
16	#include "flang/Evaluate/tools.h"
17	#include "flang/Parser/characters.h"
18	#include "flang/Semantics/scope.h"
19	#include "flang/Semantics/semantics.h"
20	#include "flang/Semantics/symbol.h"
21	#include "flang/Semantics/tools.h"
22	#include "flang/Semantics/type.h"
23	#include <algorithm>
24	#include <map>
25	#include <string>
26
27	namespace Fortran::semantics {
28
29	namespace characteristics = evaluate::characteristics;
30	using characteristics::DummyArgument;
31	using characteristics::DummyDataObject;
32	using characteristics::DummyProcedure;
33	using characteristics::FunctionResult;
34	using characteristics::Procedure;
35
36	class DistinguishabilityHelper;
37
38	class CheckHelper {
39	public:
40	explicit CheckHelper(SemanticsContext &c) : context_{c} {}
41
42	SemanticsContext &context() { return context_; }
43	void Check() { Check(context_.globalScope()); }
44	void Check(const ParamValue &, bool canBeAssumed);
45	void Check(const Bound &bound) {
46	CheckSpecExpr(bound.GetExplicit(), /*forElementalFunctionResult=*/false);
47	}
48	void Check(const ShapeSpec &spec) {
49	Check(spec.lbound());
50	Check(spec.ubound());
51	}
52	void Check(const ArraySpec &);
53	void Check(const DeclTypeSpec &, bool canHaveAssumedTypeParameters);
54	void Check(const Symbol &);
55	void CheckCommonBlock(const Symbol &);
56	void Check(const Scope &);
57	const Procedure *Characterize(const Symbol &);
58
59	private:
60	template <typename A>
61	void CheckSpecExpr(const A &x, bool forElementalFunctionResult) {
62	evaluate::CheckSpecificationExpr(
63	x, DEREF(scope_), foldingContext_, forElementalFunctionResult);
64	}
65	void CheckValue(const Symbol &, const DerivedTypeSpec *);
66	void CheckVolatile(const Symbol &, const DerivedTypeSpec *);
67	void CheckContiguous(const Symbol &);
68	void CheckPointer(const Symbol &);
69	void CheckPassArg(
70	const Symbol &proc, const Symbol *interface, const WithPassArg &);
71	void CheckProcBinding(const Symbol &, const ProcBindingDetails &);
72	void CheckObjectEntity(const Symbol &, const ObjectEntityDetails &);
73	void CheckPointerInitialization(const Symbol &);
74	void CheckArraySpec(const Symbol &, const ArraySpec &);
75	void CheckProcEntity(const Symbol &, const ProcEntityDetails &);
76	void CheckSubprogram(const Symbol &, const SubprogramDetails &);
77	void CheckExternal(const Symbol &);
78	void CheckAssumedTypeEntity(const Symbol &, const ObjectEntityDetails &);
79	void CheckDerivedType(const Symbol &, const DerivedTypeDetails &);
80	bool CheckFinal(
81	const Symbol &subroutine, SourceName, const Symbol &derivedType);
82	bool CheckDistinguishableFinals(const Symbol &f1, SourceName f1name,
83	const Symbol &f2, SourceName f2name, const Symbol &derivedType);
84	void CheckGeneric(const Symbol &, const GenericDetails &);
85	void CheckHostAssoc(const Symbol &, const HostAssocDetails &);
86	bool CheckDefinedOperator(
87	SourceName, GenericKind, const Symbol &, const Procedure &);
88	std::optional<parser::MessageFixedText> CheckNumberOfArgs(
89	const GenericKind &, std::size_t);
90	bool CheckDefinedOperatorArg(
91	const SourceName &, const Symbol &, const Procedure &, std::size_t);
92	bool CheckDefinedAssignment(const Symbol &, const Procedure &);
93	bool CheckDefinedAssignmentArg(const Symbol &, const DummyArgument &, int);
94	void CollectSpecifics(
95	DistinguishabilityHelper &, const Symbol &, const GenericDetails &);
96	void CheckSpecifics(const Symbol &, const GenericDetails &);
97	void CheckEquivalenceSet(const EquivalenceSet &);
98	void CheckEquivalenceObject(const EquivalenceObject &);
99	void CheckBlockData(const Scope &);
100	void CheckGenericOps(const Scope &);
101	bool CheckConflicting(const Symbol &, Attr, Attr);
102	void WarnMissingFinal(const Symbol &);
103	void CheckSymbolType(const Symbol &); // C702
104	bool InPure() const {
105	return innermostSymbol_ && IsPureProcedure(*innermostSymbol_);
106	}
107	bool InElemental() const {
108	return innermostSymbol_ && IsElementalProcedure(*innermostSymbol_);
109	}
110	bool InFunction() const {
111	return innermostSymbol_ && IsFunction(*innermostSymbol_);
112	}
113	bool InInterface() const {
114	const SubprogramDetails *subp{innermostSymbol_
115	? innermostSymbol_->detailsIf<SubprogramDetails>()
116	: nullptr};
117	return subp && subp->isInterface();
118	}
119	template <typename... A>
120	parser::Message *SayWithDeclaration(const Symbol &symbol, A &&...x) {
121	parser::Message *msg{messages_.Say(std::forward<A>(x)...)};
122	if (msg && messages_.at().begin() != symbol.name().begin()) {
123	evaluate::AttachDeclaration(*msg, symbol);
124	}
125	return msg;
126	}
127	bool InModuleFile() const {
128	return FindModuleFileContaining(context_.FindScope(messages_.at())) !=
129	nullptr;
130	}
131	template <typename FeatureOrUsageWarning, typename... A>
132	parser::Message *Warn(FeatureOrUsageWarning warning, A &&...x) {
133	if (!context_.ShouldWarn(warning) || InModuleFile()) {
134	return nullptr;
135	} else {
136	return messages_.Say(warning, std::forward<A>(x)...);
137	}
138	}
139	template <typename FeatureOrUsageWarning, typename... A>
140	parser::Message *Warn(
141	FeatureOrUsageWarning warning, parser::CharBlock source, A &&...x) {
142	if (!context_.ShouldWarn(warning) ||
143	FindModuleFileContaining(context_.FindScope(source))) {
144	return nullptr;
145	} else {
146	return messages_.Say(warning, source, std::forward<A>(x)...);
147	}
148	}
149	bool IsResultOkToDiffer(const FunctionResult &);
150	void CheckGlobalName(const Symbol &);
151	void CheckProcedureAssemblyName(const Symbol &symbol);
152	void CheckExplicitSave(const Symbol &);
153	parser::Messages WhyNotInteroperableDerivedType(const Symbol &);
154	parser::Messages WhyNotInteroperableObject(
155	const Symbol &, bool allowNonInteroperableType = false);
156	parser::Messages WhyNotInteroperableFunctionResult(const Symbol &);
157	parser::Messages WhyNotInteroperableProcedure(const Symbol &, bool isError);
158	void CheckBindC(const Symbol &);
159	// Check functions for defined I/O procedures
160	void CheckDefinedIoProc(
161	const Symbol &, const GenericDetails &, common::DefinedIo);
162	bool CheckDioDummyIsData(const Symbol &, const Symbol *, std::size_t);
163	void CheckDioDummyIsDerived(
164	const Symbol &, const Symbol &, common::DefinedIo ioKind, const Symbol &);
165	void CheckDioDummyIsDefaultInteger(const Symbol &, const Symbol &);
166	void CheckDioDummyIsScalar(const Symbol &, const Symbol &);
167	void CheckDioDummyAttrs(const Symbol &, const Symbol &, Attr);
168	void CheckDioDtvArg(const Symbol &proc, const Symbol &subp, const Symbol *arg,
169	common::DefinedIo, const Symbol &generic);
170	void CheckGenericVsIntrinsic(const Symbol &, const GenericDetails &);
171	void CheckDefaultIntegerArg(const Symbol &, const Symbol *, Attr);
172	void CheckDioAssumedLenCharacterArg(
173	const Symbol &, const Symbol *, std::size_t, Attr);
174	void CheckDioVlistArg(const Symbol &, const Symbol *, std::size_t);
175	void CheckDioArgCount(const Symbol &, common::DefinedIo ioKind, std::size_t);
176	struct TypeWithDefinedIo {
177	const DerivedTypeSpec &type;
178	common::DefinedIo ioKind;
179	const Symbol &proc;
180	const Symbol &generic;
181	};
182	void CheckAlreadySeenDefinedIo(const DerivedTypeSpec &, common::DefinedIo,
183	const Symbol &, const Symbol &generic);
184	void CheckModuleProcedureDef(const Symbol &);
185
186	SemanticsContext &context_;
187	evaluate::FoldingContext &foldingContext_{context_.foldingContext()};
188	parser::ContextualMessages &messages_{foldingContext_.messages()};
189	const Scope *scope_{nullptr};
190	bool scopeIsUninstantiatedPDT_{false};
191	// This symbol is the one attached to the innermost enclosing scope
192	// that has a symbol.
193	const Symbol *innermostSymbol_{nullptr};
194	// Cache of calls to Procedure::Characterize(Symbol)
195	std::map<SymbolRef, std::optional<Procedure>, SymbolAddressCompare>
196	characterizeCache_;
197	// Collection of module procedure symbols with non-BIND(C)
198	// global names, qualified by their module.
199	std::map<std::pair<SourceName, const Symbol *>, SymbolRef> moduleProcs_;
200	// Collection of symbols with global names, BIND(C) or otherwise
201	std::map<std::string, SymbolRef> globalNames_;
202	// Collection of external procedures without global definitions
203	std::map<std::string, SymbolRef> externalNames_;
204	// Collection of target dependent assembly names of external and BIND(C)
205	// procedures.
206	std::map<std::string, SymbolRef> procedureAssemblyNames_;
207	// Derived types that have been examined by WhyNotInteroperable_XXX
208	UnorderedSymbolSet examinedByWhyNotInteroperable_;
209	};
210
211	class DistinguishabilityHelper {
212	public:
213	DistinguishabilityHelper(SemanticsContext &context) : context_{context} {}
214	void Add(const Symbol &, GenericKind, const Symbol &, const Procedure &);
215	void Check(const Scope &);
216
217	private:
218	void SayNotDistinguishable(const Scope &, const SourceName &, GenericKind,
219	const Symbol &, const Symbol &, bool isHardConflict);
220	void AttachDeclaration(parser::Message &, const Scope &, const Symbol &);
221
222	SemanticsContext &context_;
223	struct ProcedureInfo {
224	GenericKind kind;
225	const Procedure &procedure;
226	};
227	std::map<SourceName, std::map<const Symbol *, ProcedureInfo>>
228	nameToSpecifics_;
229	};
230
231	void CheckHelper::Check(const ParamValue &value, bool canBeAssumed) {
232	if (value.isAssumed()) {
233	if (!canBeAssumed) { // C795, C721, C726
234	messages_.Say(
235	"An assumed (*) type parameter may be used only for a (non-statement function) dummy argument, associate name, character named constant, or external function result"_err_en_US);
236	}
237	} else {
238	CheckSpecExpr(value.GetExplicit(), /*forElementalFunctionResult=*/false);
239	}
240	}
241
242	void CheckHelper::Check(const ArraySpec &shape) {
243	for (const auto &spec : shape) {
244	Check(spec);
245	}
246	}
247
248	void CheckHelper::Check(
249	const DeclTypeSpec &type, bool canHaveAssumedTypeParameters) {
250	if (type.category() == DeclTypeSpec::Character) {
251	Check(type.characterTypeSpec().length(), canHaveAssumedTypeParameters);
252	} else if (const DerivedTypeSpec *derived{type.AsDerived()}) {
253	for (auto &parm : derived->parameters()) {
254	Check(parm.second, canHaveAssumedTypeParameters);
255	}
256	}
257	}
258
259	static bool IsBlockData(const Scope &scope) {
260	return scope.kind() == Scope::Kind::BlockData;
261	}
262
263	static bool IsBlockData(const Symbol &symbol) {
264	return symbol.scope() && IsBlockData(*symbol.scope());
265	}
266
267	void CheckHelper::Check(const Symbol &symbol) {
268	if (symbol.has<UseErrorDetails>()) {
269	return;
270	}
271	if (symbol.name().size() > common::maxNameLen &&
272	&symbol == &symbol.GetUltimate()) {
273	Warn(common::LanguageFeature::LongNames, symbol.name(),
274	"%s has length %d, which is greater than the maximum name length %d"_port_en_US,
275	symbol.name(), symbol.name().size(), common::maxNameLen);
276	}
277	if (context_.HasError(symbol)) {
278	return;
279	}
280	auto restorer{messages_.SetLocation(symbol.name())};
281	context_.set_location(symbol.name());
282	const DeclTypeSpec *type{symbol.GetType()};
283	const DerivedTypeSpec *derived{type ? type->AsDerived() : nullptr};
284	bool isDone{false};
285	common::visit(
286	common::visitors{
287	[&](const UseDetails &x) { isDone = true; },
288	[&](const HostAssocDetails &x) {
289	CheckHostAssoc(symbol, x);
290	isDone = true;
291	},
292	[&](const ProcBindingDetails &x) {
293	CheckProcBinding(symbol, x);
294	isDone = true;
295	},
296	[&](const ObjectEntityDetails &x) { CheckObjectEntity(symbol, x); },
297	[&](const ProcEntityDetails &x) { CheckProcEntity(symbol, x); },
298	[&](const SubprogramDetails &x) { CheckSubprogram(symbol, x); },
299	[&](const DerivedTypeDetails &x) { CheckDerivedType(symbol, x); },
300	[&](const GenericDetails &x) { CheckGeneric(symbol, x); },
301	[](const auto &) {},
302	},
303	symbol.details());
304	if (symbol.attrs().test(Attr::VOLATILE)) {
305	CheckVolatile(symbol, derived);
306	}
307	if (symbol.attrs().test(Attr::BIND_C)) {
308	CheckBindC(symbol);
309	}
310	if (symbol.attrs().test(Attr::SAVE) &&
311	!symbol.implicitAttrs().test(Attr::SAVE)) {
312	CheckExplicitSave(symbol);
313	}
314	if (symbol.attrs().test(Attr::CONTIGUOUS)) {
315	CheckContiguous(symbol);
316	}
317	CheckGlobalName(symbol);
318	CheckProcedureAssemblyName(symbol);
319	if (symbol.attrs().test(Attr::ASYNCHRONOUS) &&
320	!evaluate::IsVariable(symbol)) {
321	messages_.Say(
322	"An entity may not have the ASYNCHRONOUS attribute unless it is a variable"_err_en_US);
323	}
324	if (symbol.attrs().HasAny({Attr::INTENT_IN, Attr::INTENT_INOUT,
325	Attr::INTENT_OUT, Attr::OPTIONAL, Attr::VALUE}) &&
326	!IsDummy(symbol)) {
327	if (context_.IsEnabled(
328	common::LanguageFeature::IgnoreIrrelevantAttributes)) {
329	context_.Warn(common::LanguageFeature::IgnoreIrrelevantAttributes,
330	"Only a dummy argument should have an INTENT, VALUE, or OPTIONAL attribute"_warn_en_US);
331	} else {
332	messages_.Say(
333	"Only a dummy argument may have an INTENT, VALUE, or OPTIONAL attribute"_err_en_US);
334	}
335	} else if (symbol.attrs().test(Attr::VALUE)) {
336	CheckValue(symbol, derived);
337	}
338
339	if (isDone) {
340	return; // following checks do not apply
341	}
342
343	if (symbol.attrs().test(Attr::PROTECTED)) {
344	if (symbol.owner().kind() != Scope::Kind::Module) { // C854
345	messages_.Say(
346	"A PROTECTED entity must be in the specification part of a module"_err_en_US);
347	}
348	if (!evaluate::IsVariable(symbol) && !IsProcedurePointer(symbol)) { // C855
349	messages_.Say(
350	"A PROTECTED entity must be a variable or pointer"_err_en_US);
351	}
352	if (FindCommonBlockContaining(symbol)) { // C856
353	messages_.Say(
354	"A PROTECTED entity may not be in a common block"_err_en_US);
355	}
356	}
357	if (IsPointer(symbol)) {
358	CheckPointer(symbol);
359	}
360	if (InPure()) {
361	if (InInterface()) {
362	// Declarations in interface definitions "have no effect" if they
363	// are not pertinent to the characteristics of the procedure.
364	// Restrictions on entities in pure procedure interfaces don't need
365	// enforcement.
366	} else if (symbol.has<AssocEntityDetails>() ||
367	FindCommonBlockContaining(symbol)) {
368	// can look like they have SAVE but are fine in PURE
369	} else if (IsSaved(symbol)) {
370	if (IsInitialized(symbol)) {
371	messages_.Say(
372	"A pure subprogram may not initialize a variable"_err_en_US);
373	} else {
374	messages_.Say(
375	"A pure subprogram may not have a variable with the SAVE attribute"_err_en_US);
376	}
377	}
378	if (symbol.attrs().test(Attr::VOLATILE) &&
379	(IsDummy(symbol) || !InInterface())) {
380	messages_.Say(
381	"A pure subprogram may not have a variable with the VOLATILE attribute"_err_en_US);
382	}
383	if (innermostSymbol_ && innermostSymbol_->name() == "__builtin_c_funloc") {
384	// The intrinsic procedure C_FUNLOC() gets a pass on this check.
385	} else if (IsProcedure(symbol) && !IsPureProcedure(symbol) &&
386	IsDummy(symbol)) {
387	messages_.Say(
388	"A dummy procedure of a pure subprogram must be pure"_err_en_US);
389	}
390	}
391	const auto *object{symbol.detailsIf<ObjectEntityDetails>()};
392	if (type) { // Section 7.2, paragraph 7; C795
393	bool isChar{type->category() == DeclTypeSpec::Character};
394	bool canHaveAssumedParameter{(isChar && IsNamedConstant(symbol)) ||
395	(IsAssumedLengthCharacter(symbol) && // C722
396	(IsExternal(symbol) ||
397	ClassifyProcedure(symbol) ==
398	ProcedureDefinitionClass::Dummy)) ||
399	symbol.test(Symbol::Flag::ParentComp)};
400	if (!IsStmtFunctionDummy(symbol)) { // C726
401	if (object) {
402	canHaveAssumedParameter |= object->isDummy() ||
403	(isChar && object->isFuncResult()) ||
404	IsStmtFunctionResult(symbol); // Avoids multiple messages
405	} else {
406	canHaveAssumedParameter |= symbol.has<AssocEntityDetails>();
407	}
408	}
409	if (IsProcedurePointer(symbol) && symbol.HasExplicitInterface()) {
410	// Don't check function result types here
411	} else {
412	Check(*type, canHaveAssumedParameter);
413	}
414	if (InFunction() && IsFunctionResult(symbol)) {
415	if (InPure()) {
416	if (type->IsPolymorphic() && IsAllocatable(symbol)) { // C1585
417	messages_.Say(
418	"Result of pure function may not be both polymorphic and ALLOCATABLE"_err_en_US);
419	}
420	if (derived) {
421	// These cases would be caught be the general validation of local
422	// variables in a pure context, but these messages are more specific.
423	if (HasImpureFinal(symbol)) { // C1584
424	messages_.Say(
425	"Result of pure function may not have an impure FINAL subroutine"_err_en_US);
426	}
427	if (auto bad{
428	FindPolymorphicAllocatablePotentialComponent(*derived)}) {
429	SayWithDeclaration(*bad,
430	"Result of pure function may not have polymorphic ALLOCATABLE potential component '%s'"_err_en_US,
431	bad.BuildResultDesignatorName());
432	}
433	}
434	}
435	if (InElemental() && isChar) { // F'2023 C15121
436	CheckSpecExpr(type->characterTypeSpec().length().GetExplicit(),
437	/*forElementalFunctionResult=*/true);
438	// TODO: check PDT LEN parameters
439	}
440	}
441	}
442	if (IsAssumedLengthCharacter(symbol) && IsFunction(symbol)) { // C723
443	if (symbol.attrs().test(Attr::RECURSIVE)) {
444	messages_.Say(
445	"An assumed-length CHARACTER(*) function cannot be RECURSIVE"_err_en_US);
446	}
447	if (symbol.Rank() > 0) {
448	messages_.Say(
449	"An assumed-length CHARACTER(*) function cannot return an array"_err_en_US);
450	}
451	if (!IsStmtFunction(symbol)) {
452	if (IsElementalProcedure(symbol)) {
453	messages_.Say(
454	"An assumed-length CHARACTER(*) function cannot be ELEMENTAL"_err_en_US);
455	} else if (IsPureProcedure(symbol)) {
456	messages_.Say(
457	"An assumed-length CHARACTER(*) function cannot be PURE"_err_en_US);
458	}
459	}
460	if (const Symbol *result{FindFunctionResult(symbol)}) {
461	if (IsPointer(*result)) {
462	messages_.Say(
463	"An assumed-length CHARACTER(*) function cannot return a POINTER"_err_en_US);
464	}
465	}
466	if (IsProcedurePointer(symbol) && IsDummy(symbol)) {
467	Warn(common::UsageWarning::Portability,
468	"A dummy procedure pointer should not have assumed-length CHARACTER(*) result type"_port_en_US);
469	// The non-dummy case is a hard error that's caught elsewhere.
470	}
471	}
472	if (IsDummy(symbol)) {
473	if (IsNamedConstant(symbol)) {
474	messages_.Say(
475	"A dummy argument may not also be a named constant"_err_en_US);
476	}
477	} else if (IsFunctionResult(symbol)) {
478	if (IsNamedConstant(symbol)) {
479	messages_.Say(
480	"A function result may not also be a named constant"_err_en_US);
481	}
482	}
483	if (IsAutomatic(symbol)) {
484	if (const Symbol * common{FindCommonBlockContaining(symbol)}) {
485	messages_.Say(
486	"Automatic data object '%s' may not appear in COMMON block /%s/"_err_en_US,
487	symbol.name(), common->name());
488	} else if (symbol.owner().IsModule()) {
489	messages_.Say(
490	"Automatic data object '%s' may not appear in a module"_err_en_US,
491	symbol.name());
492	} else if (IsBlockData(symbol.owner())) {
493	messages_.Say(
494	"Automatic data object '%s' may not appear in a BLOCK DATA subprogram"_err_en_US,
495	symbol.name());
496	} else if (symbol.owner().kind() == Scope::Kind::MainProgram) {
497	if (context_.IsEnabled(common::LanguageFeature::AutomaticInMainProgram)) {
498	Warn(common::LanguageFeature::AutomaticInMainProgram,
499	"Automatic data object '%s' should not appear in the specification part of a main program"_port_en_US,
500	symbol.name());
501	} else {
502	messages_.Say(
503	"Automatic data object '%s' may not appear in the specification part of a main program"_err_en_US,
504	symbol.name());
505	}
506	}
507	}
508	if (IsProcedure(symbol)) {
509	if (IsAllocatable(symbol)) {
510	messages_.Say(
511	"Procedure '%s' may not be ALLOCATABLE"_err_en_US, symbol.name());
512	}
513	if (!symbol.HasExplicitInterface() && symbol.Rank() > 0) {
514	messages_.Say(
515	"Procedure '%s' may not be an array without an explicit interface"_err_en_US,
516	symbol.name());
517	}
518	}
519	}
520
521	void CheckHelper::CheckCommonBlock(const Symbol &symbol) {
522	CheckGlobalName(symbol);
523	if (symbol.attrs().test(Attr::BIND_C)) {
524	CheckBindC(symbol);
525	}
526	for (MutableSymbolRef ref : symbol.get<CommonBlockDetails>().objects()) {
527	if (ref->test(Symbol::Flag::CrayPointee)) {
528	messages_.Say(ref->name(),
529	"Cray pointee '%s' may not be a member of a COMMON block"_err_en_US,
530	ref->name());
531	}
532	}
533	}
534
535	// C859, C860
536	void CheckHelper::CheckExplicitSave(const Symbol &symbol) {
537	const Symbol &ultimate{symbol.GetUltimate()};
538	if (ultimate.test(Symbol::Flag::InDataStmt)) {
539	// checked elsewhere
540	} else if (symbol.has<UseDetails>()) {
541	messages_.Say(
542	"The USE-associated name '%s' may not have an explicit SAVE attribute"_err_en_US,
543	symbol.name());
544	} else if (IsDummy(ultimate)) {
545	messages_.Say(
546	"The dummy argument '%s' may not have an explicit SAVE attribute"_err_en_US,
547	symbol.name());
548	} else if (IsFunctionResult(ultimate)) {
549	messages_.Say(
550	"The function result variable '%s' may not have an explicit SAVE attribute"_err_en_US,
551	symbol.name());
552	} else if (const Symbol * common{FindCommonBlockContaining(ultimate)}) {
553	messages_.Say(
554	"The entity '%s' in COMMON block /%s/ may not have an explicit SAVE attribute"_err_en_US,
555	symbol.name(), common->name());
556	} else if (IsAutomatic(ultimate)) {
557	messages_.Say(
558	"The automatic object '%s' may not have an explicit SAVE attribute"_err_en_US,
559	symbol.name());
560	} else if (!evaluate::IsVariable(ultimate) && !IsProcedurePointer(ultimate)) {
561	messages_.Say(
562	"The entity '%s' with an explicit SAVE attribute must be a variable, procedure pointer, or COMMON block"_err_en_US,
563	symbol.name());
564	}
565	}
566
567	void CheckHelper::CheckValue(
568	const Symbol &symbol, const DerivedTypeSpec *derived) { // C863 - C865
569	if (IsProcedure(symbol)) {
570	messages_.Say(
571	"VALUE attribute may apply only to a dummy data object"_err_en_US);
572	return; // don't pile on
573	}
574	if (IsAssumedSizeArray(symbol)) {
575	messages_.Say(
576	"VALUE attribute may not apply to an assumed-size array"_err_en_US);
577	}
578	if (evaluate::IsCoarray(symbol)) {
579	messages_.Say("VALUE attribute may not apply to a coarray"_err_en_US);
580	}
581	if (IsAllocatable(symbol)) {
582	messages_.Say("VALUE attribute may not apply to an ALLOCATABLE"_err_en_US);
583	} else if (IsPointer(symbol)) {
584	messages_.Say("VALUE attribute may not apply to a POINTER"_err_en_US);
585	}
586	if (IsIntentInOut(symbol)) {
587	messages_.Say(
588	"VALUE attribute may not apply to an INTENT(IN OUT) argument"_err_en_US);
589	} else if (IsIntentOut(symbol)) {
590	messages_.Say(
591	"VALUE attribute may not apply to an INTENT(OUT) argument"_err_en_US);
592	}
593	if (symbol.attrs().test(Attr::VOLATILE)) {
594	messages_.Say("VALUE attribute may not apply to a VOLATILE"_err_en_US);
595	}
596	if (innermostSymbol_ && IsBindCProcedure(*innermostSymbol_)) {
597	if (IsOptional(symbol)) {
598	messages_.Say(
599	"VALUE attribute may not apply to an OPTIONAL in a BIND(C) procedure"_err_en_US);
600	}
601	if (symbol.Rank() > 0) {
602	messages_.Say(
603	"VALUE attribute may not apply to an array in a BIND(C) procedure"_err_en_US);
604	}
605	}
606	if (derived) {
607	if (FindCoarrayUltimateComponent(*derived)) {
608	messages_.Say(
609	"VALUE attribute may not apply to a type with a coarray ultimate component"_err_en_US);
610	}
611	}
612	if (evaluate::IsAssumedRank(symbol)) {
613	messages_.Say(
614	"VALUE attribute may not apply to an assumed-rank array"_err_en_US);
615	}
616	if (IsAssumedLengthCharacter(symbol)) {
617	// F'2008 feature not widely implemented
618	Warn(common::UsageWarning::Portability,
619	"VALUE attribute on assumed-length CHARACTER may not be portable"_port_en_US);
620	}
621	}
622
623	void CheckHelper::CheckAssumedTypeEntity( // C709
624	const Symbol &symbol, const ObjectEntityDetails &details) {
625	if (const DeclTypeSpec *type{symbol.GetType()};
626	type && type->category() == DeclTypeSpec::TypeStar) {
627	if (!IsDummy(symbol)) {
628	messages_.Say(
629	"Assumed-type entity '%s' must be a dummy argument"_err_en_US,
630	symbol.name());
631	} else {
632	if (symbol.attrs().test(Attr::ALLOCATABLE)) {
633	messages_.Say("Assumed-type argument '%s' cannot have the ALLOCATABLE"
634	" attribute"_err_en_US,
635	symbol.name());
636	}
637	if (symbol.attrs().test(Attr::POINTER)) {
638	messages_.Say("Assumed-type argument '%s' cannot have the POINTER"
639	" attribute"_err_en_US,
640	symbol.name());
641	}
642	if (symbol.attrs().test(Attr::VALUE)) {
643	messages_.Say("Assumed-type argument '%s' cannot have the VALUE"
644	" attribute"_err_en_US,
645	symbol.name());
646	}
647	if (symbol.attrs().test(Attr::INTENT_OUT)) {
648	messages_.Say(
649	"Assumed-type argument '%s' cannot be INTENT(OUT)"_err_en_US,
650	symbol.name());
651	}
652	if (evaluate::IsCoarray(symbol)) {
653	messages_.Say(
654	"Assumed-type argument '%s' cannot be a coarray"_err_en_US,
655	symbol.name());
656	}
657	if (details.IsArray() && details.shape().IsExplicitShape()) {
658	messages_.Say("Assumed-type array argument '%s' must be assumed shape,"
659	" assumed size, or assumed rank"_err_en_US,
660	symbol.name());
661	}
662	}
663	}
664	}
665
666	void CheckHelper::CheckObjectEntity(
667	const Symbol &symbol, const ObjectEntityDetails &details) {
668	CheckSymbolType(symbol);
669	CheckArraySpec(symbol, details.shape());
670	CheckConflicting(symbol, Attr::ALLOCATABLE, Attr::PARAMETER);
671	CheckConflicting(symbol, Attr::ASYNCHRONOUS, Attr::PARAMETER);
672	CheckConflicting(symbol, Attr::SAVE, Attr::PARAMETER);
673	CheckConflicting(symbol, Attr::TARGET, Attr::PARAMETER);
674	CheckConflicting(symbol, Attr::VOLATILE, Attr::PARAMETER);
675	Check(details.shape());
676	Check(details.coshape());
677	if (details.shape().Rank() > common::maxRank) {
678	messages_.Say(
679	"'%s' has rank %d, which is greater than the maximum supported rank %d"_err_en_US,
680	symbol.name(), details.shape().Rank(), common::maxRank);
681	} else if (details.shape().Rank() + details.coshape().Rank() >
682	common::maxRank) {
683	messages_.Say(
684	"'%s' has rank %d and corank %d, whose sum is greater than the maximum supported rank %d"_err_en_US,
685	symbol.name(), details.shape().Rank(), details.coshape().Rank(),
686	common::maxRank);
687	}
688	CheckAssumedTypeEntity(symbol, details);
689	WarnMissingFinal(symbol);
690	const DeclTypeSpec *type{details.type()};
691	const DerivedTypeSpec *derived{type ? type->AsDerived() : nullptr};
692	bool isComponent{symbol.owner().IsDerivedType()};
693	const Symbol *commonBlock{FindCommonBlockContaining(symbol)};
694	bool isLocalVariable{!commonBlock && !isComponent && !details.isDummy() &&
695	symbol.owner().kind() != Scope::Kind::OtherConstruct};
696	if (int corank{evaluate::GetCorank(symbol)}; corank > 0) { // it's a coarray
697	bool isDeferredCoshape{details.coshape().CanBeDeferredShape()};
698	if (IsAllocatable(symbol)) {
699	if (!isDeferredCoshape) { // C827
700	messages_.Say("'%s' is an ALLOCATABLE coarray and must have a deferred"
701	" coshape"_err_en_US,
702	symbol.name());
703	}
704	} else if (isComponent) { // C746
705	std::string deferredMsg{
706	isDeferredCoshape ? "" : " and have a deferred coshape"};
707	messages_.Say("Component '%s' is a coarray and must have the ALLOCATABLE"
708	" attribute%s"_err_en_US,
709	symbol.name(), deferredMsg);
710	} else {
711	if (!details.coshape().CanBeAssumedSize()) { // C828
712	messages_.Say(
713	"'%s' is a non-ALLOCATABLE coarray and must have an explicit coshape"_err_en_US,
714	symbol.name());
715	}
716	}
717	if (IsBadCoarrayType(derived)) { // C747 & C824
718	messages_.Say(
719	"Coarray '%s' may not have type TEAM_TYPE, C_PTR, or C_FUNPTR"_err_en_US,
720	symbol.name());
721	}
722	if (evaluate::IsAssumedRank(symbol)) {
723	messages_.Say("Coarray '%s' may not be an assumed-rank array"_err_en_US,
724	symbol.name());
725	}
726	if (IsNamedConstant(symbol)) {
727	messages_.Say(
728	"Coarray '%s' may not be a named constant"_err_en_US, symbol.name());
729	}
730	if (IsFunctionResult(symbol)) {
731	messages_.Say("Function result may not be a coarray"_err_en_US);
732	} else if (commonBlock) {
733	messages_.Say("Coarray '%s' may not be in COMMON block '/%s/'"_err_en_US,
734	symbol.name(), commonBlock->name());
735	} else if (isLocalVariable && !IsAllocatableOrPointer(symbol) &&
736	!IsSaved(symbol)) {
737	messages_.Say(
738	"Local coarray must have the SAVE or ALLOCATABLE attribute"_err_en_US);
739	}
740	for (int j{0}; j < corank; ++j) {
741	if (auto lcbv{evaluate::ToInt64(evaluate::Fold(
742	context().foldingContext(), evaluate::GetLCOBOUND(symbol, j)))}) {
743	if (auto ucbv{
744	evaluate::ToInt64(evaluate::Fold(context().foldingContext(),
745	evaluate::GetUCOBOUND(symbol, j)))}) {
746	if (ucbv < lcbv) {
747	messages_.Say(
748	"Cobounds %jd:%jd of codimension %d produce an empty coarray"_err_en_US,
749	std::intmax_t{*lcbv}, std::intmax_t{*ucbv}, j + 1);
750	}
751	}
752	}
753	}
754	} else { // not a coarray
755	if (!isComponent && !IsPointer(symbol) && derived) {
756	if (IsEventTypeOrLockType(derived)) {
757	messages_.Say(
758	"Variable '%s' with EVENT_TYPE or LOCK_TYPE must be a coarray"_err_en_US,
759	symbol.name());
760	} else if (auto component{FindEventOrLockPotentialComponent(
761	*derived, /*ignoreCoarrays=*/true)}) {
762	messages_.Say(
763	"Variable '%s' with EVENT_TYPE or LOCK_TYPE potential component '%s' must be a coarray"_err_en_US,
764	symbol.name(), component.BuildResultDesignatorName());
765	}
766	}
767	}
768	if (details.isDummy()) {
769	if (IsIntentOut(symbol)) {
770	// Some of these errors would also be caught by the general check
771	// for definability of automatically deallocated local variables,
772	// but these messages are more specific.
773	if (FindUltimateComponent(symbol, [](const Symbol &x) {
774	return evaluate::IsCoarray(x) && IsAllocatable(x);
775	})) { // C846
776	messages_.Say(
777	"An INTENT(OUT) dummy argument may not be, or contain, an ALLOCATABLE coarray"_err_en_US);
778	}
779	if (IsOrContainsEventOrLockComponent(symbol)) { // C847
780	messages_.Say(
781	"An INTENT(OUT) dummy argument may not be, or contain, EVENT_TYPE or LOCK_TYPE"_err_en_US);
782	}
783	if (IsAssumedSizeArray(symbol)) { // C834
784	if (type && type->IsPolymorphic()) {
785	messages_.Say(
786	"An INTENT(OUT) assumed-size dummy argument array may not be polymorphic"_err_en_US);
787	}
788	if (derived) {
789	if (derived->HasDefaultInitialization()) {
790	messages_.Say(
791	"An INTENT(OUT) assumed-size dummy argument array may not have a derived type with any default component initialization"_err_en_US);
792	}
793	if (IsFinalizable(*derived)) {
794	messages_.Say(
795	"An INTENT(OUT) assumed-size dummy argument array may not be finalizable"_err_en_US);
796	}
797	}
798	}
799	}
800	if (InPure() && !IsStmtFunction(DEREF(innermostSymbol_)) &&
801	!IsPointer(symbol) && !IsIntentIn(symbol) &&
802	!symbol.attrs().test(Attr::VALUE)) {
803	const char *what{InFunction() ? "function" : "subroutine"};
804	bool ok{true};
805	if (IsIntentOut(symbol)) {
806	if (type && type->IsPolymorphic()) { // C1588
807	messages_.Say(
808	"An INTENT(OUT) dummy argument of a pure %s may not be polymorphic"_err_en_US,
809	what);
810	ok = false;
811	} else if (derived) {
812	if (FindUltimateComponent(*derived, [](const Symbol &x) {
813	const DeclTypeSpec *type{x.GetType()};
814	return type && type->IsPolymorphic();
815	})) { // C1588
816	messages_.Say(
817	"An INTENT(OUT) dummy argument of a pure %s may not have a polymorphic ultimate component"_err_en_US,
818	what);
819	ok = false;
820	}
821	if (HasImpureFinal(symbol)) { // C1587
822	messages_.Say(
823	"An INTENT(OUT) dummy argument of a pure %s may not have an impure FINAL subroutine"_err_en_US,
824	what);
825	ok = false;
826	}
827	}
828	} else if (!IsIntentInOut(symbol)) { // C1586
829	messages_.Say(
830	"non-POINTER dummy argument of pure %s must have INTENT() or VALUE attribute"_err_en_US,
831	what);
832	ok = false;
833	}
834	if (ok && InFunction() && !InModuleFile() && !InElemental()) {
835	if (context_.IsEnabled(common::LanguageFeature::RelaxedPureDummy)) {
836	Warn(common::LanguageFeature::RelaxedPureDummy,
837	"non-POINTER dummy argument of pure function should be INTENT(IN) or VALUE"_warn_en_US);
838	} else {
839	messages_.Say(
840	"non-POINTER dummy argument of pure function must be INTENT(IN) or VALUE"_err_en_US);
841	}
842	}
843	}
844	if (auto ignoreTKR{GetIgnoreTKR(symbol)}; !ignoreTKR.empty()) {
845	const Symbol *ownerSymbol{symbol.owner().symbol()};
846	bool inModuleProc{ownerSymbol && IsModuleProcedure(*ownerSymbol)};
847	bool inExplicitExternalInterface{
848	InInterface() && !IsSeparateModuleProcedureInterface(ownerSymbol)};
849	if (!InInterface() && !inModuleProc) {
850	messages_.Say(
851	"!DIR$ IGNORE_TKR may apply only in an interface or a module procedure"_err_en_US);
852	}
853	if (ownerSymbol && ownerSymbol->attrs().test(Attr::ELEMENTAL) &&
854	details.ignoreTKR().test(common::IgnoreTKR::Rank)) {
855	messages_.Say(
856	"!DIR$ IGNORE_TKR(R) may not apply in an ELEMENTAL procedure"_err_en_US);
857	}
858	if (IsPassedViaDescriptor(symbol)) {
859	if (IsAllocatableOrObjectPointer(&symbol)) {
860	if (inExplicitExternalInterface) {
861	Warn(common::UsageWarning::IgnoreTKRUsage,
862	"!DIR$ IGNORE_TKR should not apply to an allocatable or pointer"_warn_en_US);
863	} else {
864	messages_.Say(
865	"!DIR$ IGNORE_TKR may not apply to an allocatable or pointer"_err_en_US);
866	}
867	} else if (ignoreTKR.test(common::IgnoreTKR::Rank)) {
868	if (ignoreTKR.count() == 1 && evaluate::IsAssumedRank(symbol)) {
869	Warn(common::UsageWarning::IgnoreTKRUsage,
870	"!DIR$ IGNORE_TKR(R) is not meaningful for an assumed-rank array"_warn_en_US);
871	} else if (inExplicitExternalInterface) {
872	Warn(common::UsageWarning::IgnoreTKRUsage,
873	"!DIR$ IGNORE_TKR(R) should not apply to a dummy argument passed via descriptor"_warn_en_US);
874	} else {
875	messages_.Say(
876	"!DIR$ IGNORE_TKR(R) may not apply to a dummy argument passed via descriptor"_err_en_US);
877	}
878	}
879	}
880	}
881	} else if (!details.ignoreTKR().empty()) {
882	messages_.Say(
883	"!DIR$ IGNORE_TKR directive may apply only to a dummy data argument"_err_en_US);
884	}
885	if (InElemental()) {
886	if (details.isDummy()) { // C15100
887	if (details.shape().Rank() > 0) {
888	messages_.Say(
889	"A dummy argument of an ELEMENTAL procedure must be scalar"_err_en_US);
890	}
891	if (IsAllocatable(symbol)) {
892	messages_.Say(
893	"A dummy argument of an ELEMENTAL procedure may not be ALLOCATABLE"_err_en_US);
894	}
895	if (evaluate::IsCoarray(symbol)) {
896	messages_.Say(
897	"A dummy argument of an ELEMENTAL procedure may not be a coarray"_err_en_US);
898	}
899	if (IsPointer(symbol)) {
900	messages_.Say(
901	"A dummy argument of an ELEMENTAL procedure may not be a POINTER"_err_en_US);
902	}
903	if (!symbol.attrs().HasAny(Attrs{Attr::VALUE, Attr::INTENT_IN,
904	Attr::INTENT_INOUT, Attr::INTENT_OUT})) { // F'2023 C15120
905	messages_.Say(
906	"A dummy argument of an ELEMENTAL procedure must have an INTENT() or VALUE attribute"_err_en_US);
907	}
908	} else if (IsFunctionResult(symbol)) { // C15101
909	if (details.shape().Rank() > 0) {
910	messages_.Say(
911	"The result of an ELEMENTAL function must be scalar"_err_en_US);
912	}
913	if (IsAllocatable(symbol)) {
914	messages_.Say(
915	"The result of an ELEMENTAL function may not be ALLOCATABLE"_err_en_US);
916	}
917	if (IsPointer(symbol)) {
918	messages_.Say(
919	"The result of an ELEMENTAL function may not be a POINTER"_err_en_US);
920	}
921	}
922	}
923	if (HasDeclarationInitializer(symbol)) { // C808; ignore DATA initialization
924	CheckPointerInitialization(symbol);
925	if (IsAutomatic(symbol)) {
926	messages_.Say(
927	"An automatic variable or component must not be initialized"_err_en_US);
928	} else if (IsDummy(symbol)) {
929	messages_.Say("A dummy argument must not be initialized"_err_en_US);
930	} else if (IsFunctionResult(symbol)) {
931	messages_.Say("A function result must not be initialized"_err_en_US);
932	} else if (IsInBlankCommon(symbol)) {
933	Warn(common::LanguageFeature::InitBlankCommon,
934	"A variable in blank COMMON should not be initialized"_port_en_US);
935	}
936	}
937	if (symbol.owner().kind() == Scope::Kind::BlockData) {
938	if (IsAllocatable(symbol)) {
939	messages_.Say(
940	"An ALLOCATABLE variable may not appear in a BLOCK DATA subprogram"_err_en_US);
941	} else if (IsInitialized(symbol) && !FindCommonBlockContaining(symbol)) {
942	messages_.Say(
943	"An initialized variable in BLOCK DATA must be in a COMMON block"_err_en_US);
944	}
945	}
946	if (derived && InPure() && !InInterface() &&
947	IsAutomaticallyDestroyed(symbol) &&
948	!IsIntentOut(symbol) /*has better messages*/ &&
949	!IsFunctionResult(symbol) /*ditto*/) {
950	// Check automatically deallocated local variables for possible
951	// problems with finalization in PURE.
952	if (auto whyNot{WhyNotDefinable(symbol.name(), symbol.owner(),
953	{DefinabilityFlag::PotentialDeallocation}, symbol)}) {
954	if (auto *msg{messages_.Say(
955	"'%s' may not be a local variable in a pure subprogram"_err_en_US,
956	symbol.name())}) {
957	msg->Attach(std::move(whyNot->set_severity(parser::Severity::Because)));
958	}
959	}
960	}
961	if (symbol.attrs().test(Attr::EXTERNAL)) {
962	SayWithDeclaration(symbol,
963	"'%s' is a data object and may not be EXTERNAL"_err_en_US,
964	symbol.name());
965	}
966	if (symbol.test(Symbol::Flag::CrayPointee)) {
967	// NB, IsSaved was too smart here.
968	if (details.init()) {
969	messages_.Say(
970	"Cray pointee '%s' may not be initialized"_err_en_US, symbol.name());
971	}
972	if (symbol.attrs().test(Attr::SAVE)) {
973	messages_.Say(
974	"Cray pointee '%s' may not have the SAVE attribute"_err_en_US,
975	symbol.name());
976	}
977	}
978	if (derived) {
979	bool isUnsavedLocal{
980	isLocalVariable && !IsAllocatable(symbol) && !IsSaved(symbol)};
981	if (IsFunctionResult(symbol) || IsPointer(symbol) ||
982	evaluate::IsCoarray(symbol) || isUnsavedLocal) {
983	if (auto badPotential{FindCoarrayPotentialComponent(*derived)}) {
984	if (IsFunctionResult(symbol)) { // F'2023 C825
985	SayWithDeclaration(*badPotential,
986	"Function result '%s' may not have a coarray potential component '%s'"_err_en_US,
987	symbol.name(), badPotential.BuildResultDesignatorName());
988	} else if (IsPointer(symbol)) { // F'2023 C825
989	SayWithDeclaration(*badPotential,
990	"Pointer '%s' may not have a coarray potential component '%s'"_err_en_US,
991	symbol.name(), badPotential.BuildResultDesignatorName());
992	} else if (evaluate::IsCoarray(symbol)) { // F'2023 C825
993	SayWithDeclaration(*badPotential,
994	"Coarray '%s' may not have a coarray potential component '%s'"_err_en_US,
995	symbol.name(), badPotential.BuildResultDesignatorName());
996	} else if (isUnsavedLocal) { // F'2023 C826
997	SayWithDeclaration(*badPotential,
998	"Local variable '%s' without the SAVE or ALLOCATABLE attribute may not have a coarray potential subobject component '%s'"_err_en_US,
999	symbol.name(), badPotential.BuildResultDesignatorName());
1000	} else {
1001	DIE("caught unexpected bad coarray potential component");
1002	}
1003	}
1004	} else if (isComponent && (IsAllocatable(symbol) || symbol.Rank() > 0)) {
1005	if (auto badUltimate{FindCoarrayUltimateComponent(*derived)}) {
1006	// TODO: still an error in F'2023?
1007	SayWithDeclaration(*badUltimate,
1008	"Allocatable or array component '%s' may not have a coarray ultimate component '%s'"_err_en_US,
1009	symbol.name(), badUltimate.BuildResultDesignatorName());
1010	}
1011	}
1012	}
1013
1014	// Check CUDA attributes and special circumstances of being in device
1015	// subprograms
1016	const Scope &progUnit{GetProgramUnitContaining(symbol)};
1017	const auto *subpDetails{!isComponent && progUnit.symbol()
1018	? progUnit.symbol()->detailsIf<SubprogramDetails>()
1019	: nullptr};
1020	bool inDeviceSubprogram{IsCUDADeviceContext(&symbol.owner())};
1021	if (inDeviceSubprogram) {
1022	if (IsSaved(symbol)) {
1023	Warn(common::UsageWarning::CUDAUsage,
1024	"'%s' should not have the SAVE attribute or initialization in a device subprogram"_warn_en_US,
1025	symbol.name());
1026	}
1027	if (IsPointer(symbol)) {
1028	Warn(common::UsageWarning::CUDAUsage,
1029	"Pointer '%s' may not be associated in a device subprogram"_warn_en_US,
1030	symbol.name());
1031	}
1032	if (details.isDummy() &&
1033	details.cudaDataAttr().value_or(common::CUDADataAttr::Device) !=
1034	common::CUDADataAttr::Device &&
1035	details.cudaDataAttr().value_or(common::CUDADataAttr::Device) !=
1036	common::CUDADataAttr::Managed &&
1037	details.cudaDataAttr().value_or(common::CUDADataAttr::Device) !=
1038	common::CUDADataAttr::Shared) {
1039	Warn(common::UsageWarning::CUDAUsage,
1040	"Dummy argument '%s' may not have ATTRIBUTES(%s) in a device subprogram"_warn_en_US,
1041	symbol.name(),
1042	parser::ToUpperCaseLetters(
1043	common::EnumToString(*details.cudaDataAttr())));
1044	}
1045	}
1046	if (details.cudaDataAttr()) {
1047	if (auto dyType{evaluate::DynamicType::From(symbol)}) {
1048	if (dyType->category() != TypeCategory::Derived) {
1049	if (!IsCUDAIntrinsicType(*dyType)) {
1050	messages_.Say(
1051	"'%s' has intrinsic type '%s' that is not available on the device"_err_en_US,
1052	symbol.name(), dyType->AsFortran());
1053	}
1054	}
1055	}
1056	auto attr{*details.cudaDataAttr()};
1057	switch (attr) {
1058	case common::CUDADataAttr::Constant:
1059	if (subpDetails && !inDeviceSubprogram) {
1060	messages_.Say(
1061	"Object '%s' with ATTRIBUTES(CONSTANT) may not be declared in a host subprogram"_err_en_US,
1062	symbol.name());
1063	} else if (IsAllocatableOrPointer(symbol) ||
1064	symbol.attrs().test(Attr::TARGET)) {
1065	messages_.Say(
1066	"Object '%s' with ATTRIBUTES(CONSTANT) may not be allocatable, pointer, or target"_err_en_US,
1067	symbol.name());
1068	} else if (auto shape{evaluate::GetShape(foldingContext_, symbol)};
1069	!shape ||
1070	!evaluate::AsConstantExtents(foldingContext_, *shape)) {
1071	messages_.Say(
1072	"Object '%s' with ATTRIBUTES(CONSTANT) must have constant array bounds"_err_en_US,
1073	symbol.name());
1074	}
1075	break;
1076	case common::CUDADataAttr::Device:
1077	if (isComponent && !IsAllocatable(symbol) && !IsPointer(symbol)) {
1078	messages_.Say(
1079	"Component '%s' with ATTRIBUTES(DEVICE) must also be allocatable or pointer"_err_en_US,
1080	symbol.name());
1081	}
1082	break;
1083	case common::CUDADataAttr::Managed:
1084	if (!IsAutomatic(symbol) && !IsAllocatable(symbol) &&
1085	!details.isDummy() && !evaluate::IsExplicitShape(symbol)) {
1086	messages_.Say(
1087	"Object '%s' with ATTRIBUTES(MANAGED) must also be allocatable, automatic, explicit shape, or a dummy argument"_err_en_US,
1088	symbol.name());
1089	}
1090	break;
1091	case common::CUDADataAttr::Pinned:
1092	if (inDeviceSubprogram) {
1093	Warn(common::UsageWarning::CUDAUsage,
1094	"Object '%s' with ATTRIBUTES(PINNED) may not be declared in a device subprogram"_warn_en_US,
1095	symbol.name());
1096	} else if (IsPointer(symbol)) {
1097	Warn(common::UsageWarning::CUDAUsage,
1098	"Object '%s' with ATTRIBUTES(PINNED) may not be a pointer"_warn_en_US,
1099	symbol.name());
1100	} else if (!IsAllocatable(symbol)) {
1101	Warn(common::UsageWarning::CUDAUsage,
1102	"Object '%s' with ATTRIBUTES(PINNED) should also be allocatable"_warn_en_US,
1103	symbol.name());
1104	}
1105	break;
1106	case common::CUDADataAttr::Shared:
1107	if (IsAllocatableOrPointer(symbol) || symbol.attrs().test(Attr::TARGET)) {
1108	messages_.Say(
1109	"Object '%s' with ATTRIBUTES(SHARED) may not be allocatable, pointer, or target"_err_en_US,
1110	symbol.name());
1111	} else if (!inDeviceSubprogram) {
1112	messages_.Say(
1113	"Object '%s' with ATTRIBUTES(SHARED) must be declared in a device subprogram"_err_en_US,
1114	symbol.name());
1115	}
1116	break;
1117	case common::CUDADataAttr::Unified:
1118	if (((!subpDetails &&
1119	symbol.owner().kind() != Scope::Kind::MainProgram) ||
1120	inDeviceSubprogram) &&
1121	!isComponent) {
1122	messages_.Say(
1123	"Object '%s' with ATTRIBUTES(UNIFIED) must be declared in a host subprogram"_err_en_US,
1124	symbol.name());
1125	}
1126	break;
1127	case common::CUDADataAttr::Texture:
1128	messages_.Say(
1129	"ATTRIBUTES(TEXTURE) is obsolete and no longer supported"_err_en_US);
1130	break;
1131	}
1132	if (attr != common::CUDADataAttr::Pinned) {
1133	if (details.commonBlock()) {
1134	messages_.Say(
1135	"Object '%s' with ATTRIBUTES(%s) may not be in COMMON"_err_en_US,
1136	symbol.name(),
1137	parser::ToUpperCaseLetters(common::EnumToString(attr)));
1138	} else if (FindEquivalenceSet(symbol)) {
1139	messages_.Say(
1140	"Object '%s' with ATTRIBUTES(%s) may not be in an equivalence group"_err_en_US,
1141	symbol.name(),
1142	parser::ToUpperCaseLetters(common::EnumToString(attr)));
1143	}
1144	}
1145	if (subpDetails /* not a module variable */ && IsSaved(symbol) &&
1146	!inDeviceSubprogram && !IsAllocatable(symbol) &&
1147	attr == common::CUDADataAttr::Device) {
1148	messages_.Say(
1149	"Saved object '%s' in host code may not have ATTRIBUTES(DEVICE) unless allocatable"_err_en_US,
1150	symbol.name(),
1151	parser::ToUpperCaseLetters(common::EnumToString(attr)));
1152	}
1153	if (isComponent) {
1154	if (attr == common::CUDADataAttr::Device) {
1155	const DeclTypeSpec *type{symbol.GetType()};
1156	if (const DerivedTypeSpec *
1157	derived{type ? type->AsDerived() : nullptr}) {
1158	DirectComponentIterator directs{*derived};
1159	if (auto iter{std::find_if(directs.begin(), directs.end(),
1160	[](const Symbol &) { return false; })}) {
1161	messages_.Say(
1162	"Derived type component '%s' may not have ATTRIBUTES(DEVICE) as it has a direct device component '%s'"_err_en_US,
1163	symbol.name(), iter.BuildResultDesignatorName());
1164	}
1165	}
1166	} else if (attr == common::CUDADataAttr::Constant ||
1167	attr == common::CUDADataAttr::Shared) {
1168	messages_.Say(
1169	"Derived type component '%s' may not have ATTRIBUTES(%s)"_err_en_US,
1170	symbol.name(),
1171	parser::ToUpperCaseLetters(common::EnumToString(attr)));
1172	}
1173	} else if (!subpDetails && symbol.owner().kind() != Scope::Kind::Module &&
1174	symbol.owner().kind() != Scope::Kind::MainProgram &&
1175	symbol.owner().kind() != Scope::Kind::BlockConstruct) {
1176	messages_.Say(
1177	"ATTRIBUTES(%s) may apply only to module, host subprogram, block, or device subprogram data"_err_en_US,
1178	parser::ToUpperCaseLetters(common::EnumToString(attr)));
1179	}
1180	}
1181
1182	if (derived && derived->IsVectorType()) {
1183	CHECK(type);
1184	std::string typeName{type->AsFortran()};
1185	if (IsAssumedShape(symbol)) {
1186	SayWithDeclaration(symbol,
1187	"Assumed-shape entity of %s type is not supported"_err_en_US,
1188	typeName);
1189	} else if (IsDeferredShape(symbol)) {
1190	SayWithDeclaration(symbol,
1191	"Deferred-shape entity of %s type is not supported"_err_en_US,
1192	typeName);
1193	} else if (evaluate::IsAssumedRank(symbol)) {
1194	SayWithDeclaration(symbol,
1195	"Assumed rank entity of %s type is not supported"_err_en_US,
1196	typeName);
1197	}
1198	}
1199	}
1200
1201	void CheckHelper::CheckPointerInitialization(const Symbol &symbol) {
1202	if (IsPointer(symbol) && !context_.HasError(symbol) &&
1203	!scopeIsUninstantiatedPDT_) {
1204	if (const auto *object{symbol.detailsIf<ObjectEntityDetails>()}) {
1205	if (object->init()) { // C764, C765; C808
1206	if (auto designator{evaluate::AsGenericExpr(symbol)}) {
1207	auto restorer{messages_.SetLocation(symbol.name())};
1208	context_.set_location(symbol.name());
1209	CheckInitialDataPointerTarget(
1210	context_, *designator, *object->init(), DEREF(scope_));
1211	}
1212	}
1213	} else if (const auto *proc{symbol.detailsIf<ProcEntityDetails>()}) {
1214	if (proc->init() && *proc->init()) {
1215	// C1519 - must be nonelemental external or module procedure,
1216	// or an unrestricted specific intrinsic function.
1217	const Symbol &local{DEREF(*proc->init())};
1218	const Symbol &ultimate{local.GetUltimate()};
1219	bool checkTarget{true};
1220	if (ultimate.attrs().test(Attr::INTRINSIC)) {
1221	if (auto intrinsic{context_.intrinsics().IsSpecificIntrinsicFunction(
1222	ultimate.name().ToString())};
1223	!intrinsic || intrinsic->isRestrictedSpecific) { // C1030
1224	context_.Say(
1225	"Intrinsic procedure '%s' is not an unrestricted specific "
1226	"intrinsic permitted for use as the initializer for procedure "
1227	"pointer '%s'"_err_en_US,
1228	ultimate.name(), symbol.name());
1229	checkTarget = false;
1230	}
1231	} else if (!(ultimate.attrs().test(Attr::EXTERNAL) ||
1232	ultimate.owner().kind() == Scope::Kind::Module ||
1233	ultimate.owner().IsTopLevel()) ||
1234	IsDummy(ultimate) || IsPointer(ultimate)) {
1235	context_.Say(
1236	"Procedure pointer '%s' initializer '%s' is neither an external nor a module procedure"_err_en_US,
1237	symbol.name(), ultimate.name());
1238	checkTarget = false;
1239	} else if (IsElementalProcedure(ultimate)) {
1240	context_.Say("Procedure pointer '%s' cannot be initialized with the "
1241	"elemental procedure '%s'"_err_en_US,
1242	symbol.name(), ultimate.name());
1243	checkTarget = false;
1244	}
1245	if (checkTarget) {
1246	SomeExpr lhs{evaluate::ProcedureDesignator{symbol}};
1247	SomeExpr rhs{evaluate::ProcedureDesignator{**proc->init()}};
1248	CheckPointerAssignment(context_, lhs, rhs,
1249	GetProgramUnitOrBlockConstructContaining(symbol),
1250	/*isBoundsRemapping=*/false, /*isAssumedRank=*/false);
1251	}
1252	}
1253	}
1254	}
1255	}
1256
1257	// The six different kinds of array-specs:
1258	// array-spec -> explicit-shape-list | deferred-shape-list
1259	// | assumed-shape-list | implied-shape-list
1260	// | assumed-size | assumed-rank
1261	// explicit-shape -> [ lb : ] ub
1262	// deferred-shape -> :
1263	// assumed-shape -> [ lb ] :
1264	// implied-shape -> [ lb : ] *
1265	// assumed-size -> [ explicit-shape-list , ] [ lb : ] *
1266	// assumed-rank -> ..
1267	// Note:
1268	// - deferred-shape is also an assumed-shape
1269	// - A single "*" or "lb:*" might be assumed-size or implied-shape-list
1270	void CheckHelper::CheckArraySpec(
1271	const Symbol &symbol, const ArraySpec &arraySpec) {
1272	if (arraySpec.Rank() == 0) {
1273	return;
1274	}
1275	bool isExplicit{arraySpec.IsExplicitShape()};
1276	bool canBeDeferred{arraySpec.CanBeDeferredShape()};
1277	bool canBeImplied{arraySpec.CanBeImpliedShape()};
1278	bool canBeAssumedShape{arraySpec.CanBeAssumedShape()};
1279	bool canBeAssumedSize{arraySpec.CanBeAssumedSize()};
1280	bool isAssumedRank{arraySpec.IsAssumedRank()};
1281	bool isCUDAShared{
1282	GetCUDADataAttr(&symbol).value_or(common::CUDADataAttr::Device) ==
1283	common::CUDADataAttr::Shared};
1284	bool isCrayPointee{symbol.test(Symbol::Flag::CrayPointee)};
1285	std::optional<parser::MessageFixedText> msg;
1286	if (isCrayPointee && !isExplicit && !canBeAssumedSize) {
1287	msg =
1288	"Cray pointee '%s' must have explicit shape or assumed size"_err_en_US;
1289	} else if (IsAllocatableOrPointer(symbol) && !canBeDeferred &&
1290	!isAssumedRank) {
1291	if (symbol.owner().IsDerivedType()) { // C745
1292	if (IsAllocatable(symbol)) {
1293	msg = "Allocatable array component '%s' must have"
1294	" deferred shape"_err_en_US;
1295	} else {
1296	msg = "Array pointer component '%s' must have deferred shape"_err_en_US;
1297	}
1298	} else {
1299	if (IsAllocatable(symbol)) { // C832
1300	msg = "Allocatable array '%s' must have deferred shape or"
1301	" assumed rank"_err_en_US;
1302	} else {
1303	msg = "Array pointer '%s' must have deferred shape or"
1304	" assumed rank"_err_en_US;
1305	}
1306	}
1307	} else if (IsDummy(symbol)) {
1308	if (canBeImplied && !canBeAssumedSize) { // C836
1309	msg = "Dummy array argument '%s' may not have implied shape"_err_en_US;
1310	}
1311	} else if (canBeAssumedShape && !canBeDeferred) {
1312	msg = "Assumed-shape array '%s' must be a dummy argument"_err_en_US;
1313	} else if (isAssumedRank) { // C837
1314	msg = "Assumed-rank array '%s' must be a dummy argument"_err_en_US;
1315	} else if (canBeAssumedSize && !canBeImplied && !isCUDAShared &&
1316	!isCrayPointee) { // C833
1317	msg = "Assumed-size array '%s' must be a dummy argument"_err_en_US;
1318	} else if (canBeImplied) {
1319	if (!IsNamedConstant(symbol) && !isCUDAShared &&
1320	!isCrayPointee) { // C835, C836
1321	msg = "Implied-shape array '%s' must be a named constant or a "
1322	"dummy argument"_err_en_US;
1323	}
1324	} else if (IsNamedConstant(symbol)) {
1325	if (!isExplicit && !canBeImplied) {
1326	msg = "Named constant '%s' array must have constant or"
1327	" implied shape"_err_en_US;
1328	}
1329	} else if (!isExplicit &&
1330	!(IsAllocatableOrPointer(symbol) || isCrayPointee)) {
1331	if (symbol.owner().IsDerivedType()) { // C749
1332	msg = "Component array '%s' without ALLOCATABLE or POINTER attribute must"
1333	" have explicit shape"_err_en_US;
1334	} else { // C816
1335	msg = "Array '%s' without ALLOCATABLE or POINTER attribute must have"
1336	" explicit shape"_err_en_US;
1337	}
1338	}
1339	if (msg) {
1340	context_.Say(std::move(*msg), symbol.name());
1341	}
1342	}
1343
1344	void CheckHelper::CheckProcEntity(
1345	const Symbol &symbol, const ProcEntityDetails &details) {
1346	CheckSymbolType(symbol);
1347	const Symbol *interface{details.procInterface()};
1348	if (details.isDummy()) {
1349	if (!symbol.attrs().test(Attr::POINTER) && // C843
1350	symbol.attrs().HasAny(
1351	{Attr::INTENT_IN, Attr::INTENT_OUT, Attr::INTENT_INOUT})) {
1352	messages_.Say("A dummy procedure without the POINTER attribute"
1353	" may not have an INTENT attribute"_err_en_US);
1354	}
1355	if (InElemental()) { // C15100
1356	messages_.Say(
1357	"An ELEMENTAL subprogram may not have a dummy procedure"_err_en_US);
1358	}
1359	if (interface && IsElementalProcedure(*interface)) {
1360	// There's no explicit constraint or "shall" that we can find in the
1361	// standard for this check, but it seems to be implied in multiple
1362	// sites, and ELEMENTAL non-intrinsic actual arguments *are*
1363	// explicitly forbidden. But we allow "PROCEDURE(SIN)::dummy"
1364	// because it is explicitly legal to *pass* the specific intrinsic
1365	// function SIN as an actual argument.
1366	if (interface->attrs().test(Attr::INTRINSIC)) {
1367	Warn(common::UsageWarning::Portability,
1368	"A dummy procedure should not have an ELEMENTAL intrinsic as its interface"_port_en_US);
1369	} else {
1370	messages_.Say("A dummy procedure may not be ELEMENTAL"_err_en_US);
1371	}
1372	}
1373	} else if (IsPointer(symbol)) {
1374	CheckPointerInitialization(symbol);
1375	if (interface) {
1376	if (interface->attrs().test(Attr::INTRINSIC)) {
1377	auto intrinsic{context_.intrinsics().IsSpecificIntrinsicFunction(
1378	interface->name().ToString())};
1379	if (!intrinsic || intrinsic->isRestrictedSpecific) { // C1515
1380	messages_.Say(
1381	"Intrinsic procedure '%s' is not an unrestricted specific "
1382	"intrinsic permitted for use as the definition of the interface "
1383	"to procedure pointer '%s'"_err_en_US,
1384	interface->name(), symbol.name());
1385	} else if (IsElementalProcedure(*interface)) {
1386	Warn(common::UsageWarning::Portability,
1387	"Procedure pointer '%s' should not have an ELEMENTAL intrinsic as its interface"_port_en_US,
1388	symbol.name()); // C1517
1389	}
1390	} else if (IsElementalProcedure(*interface)) {
1391	messages_.Say("Procedure pointer '%s' may not be ELEMENTAL"_err_en_US,
1392	symbol.name()); // C1517
1393	}
1394	}
1395	if (symbol.owner().IsDerivedType()) {
1396	CheckPassArg(symbol, interface, details);
1397	}
1398	} else if (symbol.owner().IsDerivedType()) {
1399	const auto &name{symbol.name()};
1400	messages_.Say(name,
1401	"Procedure component '%s' must have POINTER attribute"_err_en_US, name);
1402	}
1403	CheckExternal(symbol);
1404	}
1405
1406	// When a module subprogram has the MODULE prefix the following must match
1407	// with the corresponding separate module procedure interface body:
1408	// - C1549: characteristics and dummy argument names
1409	// - C1550: binding label
1410	// - C1551: NON_RECURSIVE prefix
1411	class SubprogramMatchHelper {
1412	public:
1413	explicit SubprogramMatchHelper(CheckHelper &checkHelper)
1414	: checkHelper{checkHelper} {}
1415
1416	void Check(const Symbol &, const Symbol &);
1417
1418	private:
1419	SemanticsContext &context() { return checkHelper.context(); }
1420	void CheckDummyArg(const Symbol &, const Symbol &, const DummyArgument &,
1421	const DummyArgument &);
1422	void CheckDummyDataObject(const Symbol &, const Symbol &,
1423	const DummyDataObject &, const DummyDataObject &);
1424	void CheckDummyProcedure(const Symbol &, const Symbol &,
1425	const DummyProcedure &, const DummyProcedure &);
1426	bool CheckSameIntent(
1427	const Symbol &, const Symbol &, common::Intent, common::Intent);
1428	template <typename... A>
1429	void Say(
1430	const Symbol &, const Symbol &, parser::MessageFixedText &&, A &&...);
1431	template <typename ATTRS>
1432	bool CheckSameAttrs(const Symbol &, const Symbol &, ATTRS, ATTRS);
1433	bool ShapesAreCompatible(const DummyDataObject &, const DummyDataObject &);
1434	evaluate::Shape FoldShape(const evaluate::Shape &);
1435	std::optional<evaluate::Shape> FoldShape(
1436	const std::optional<evaluate::Shape> &shape) {
1437	if (shape) {
1438	return FoldShape(*shape);
1439	}
1440	return std::nullopt;
1441	}
1442	std::string AsFortran(DummyDataObject::Attr attr) {
1443	return parser::ToUpperCaseLetters(DummyDataObject::EnumToString(attr));
1444	}
1445	std::string AsFortran(DummyProcedure::Attr attr) {
1446	return parser::ToUpperCaseLetters(DummyProcedure::EnumToString(attr));
1447	}
1448
1449	CheckHelper &checkHelper;
1450	};
1451
1452	// 15.6.2.6 para 3 - can the result of an ENTRY differ from its function?
1453	bool CheckHelper::IsResultOkToDiffer(const FunctionResult &result) {
1454	if (result.attrs.test(FunctionResult::Attr::Allocatable) ||
1455	result.attrs.test(FunctionResult::Attr::Pointer)) {
1456	return false;
1457	}
1458	const auto *typeAndShape{result.GetTypeAndShape()};
1459	if (!typeAndShape || typeAndShape->Rank() != 0) {
1460	return false;
1461	}
1462	auto category{typeAndShape->type().category()};
1463	if (category == TypeCategory::Character ||
1464	category == TypeCategory::Derived) {
1465	return false;
1466	}
1467	int kind{typeAndShape->type().kind()};
1468	return kind == context_.GetDefaultKind(category) ||
1469	(category == TypeCategory::Real &&
1470	kind == context_.doublePrecisionKind());
1471	}
1472
1473	void CheckHelper::CheckSubprogram(
1474	const Symbol &symbol, const SubprogramDetails &details) {
1475	// Evaluate a procedure definition's characteristics to flush out
1476	// any errors that analysis might expose, in case this subprogram hasn't
1477	// had any calls in this compilation unit that would have validated them.
1478	if (!context_.HasError(symbol) && !details.isDummy() &&
1479	!details.isInterface() && !details.stmtFunction()) {
1480	if (!Procedure::Characterize(symbol, foldingContext_)) {
1481	context_.SetError(symbol);
1482	}
1483	}
1484	if (const Symbol *iface{FindSeparateModuleSubprogramInterface(&symbol)}) {
1485	SubprogramMatchHelper{*this}.Check(symbol, *iface);
1486	}
1487	if (const Scope *entryScope{details.entryScope()}) {
1488	// ENTRY F'2023 15.6.2.6
1489	std::optional<parser::MessageFixedText> error;
1490	const Symbol *subprogram{entryScope->symbol()};
1491	const SubprogramDetails *subprogramDetails{nullptr};
1492	if (subprogram) {
1493	subprogramDetails = subprogram->detailsIf<SubprogramDetails>();
1494	}
1495	if (!(entryScope->parent().IsGlobal() || entryScope->parent().IsModule() ||
1496	entryScope->parent().IsSubmodule())) {
1497	error = "ENTRY may not appear in an internal subprogram"_err_en_US;
1498	} else if (subprogramDetails && details.isFunction() &&
1499	subprogramDetails->isFunction() &&
1500	!context_.HasError(details.result()) &&
1501	!context_.HasError(subprogramDetails->result())) {
1502	auto result{FunctionResult::Characterize(
1503	details.result(), context_.foldingContext())};
1504	auto subpResult{FunctionResult::Characterize(
1505	subprogramDetails->result(), context_.foldingContext())};
1506	if (result && subpResult && *result != *subpResult &&
1507	(!IsResultOkToDiffer(*result) || !IsResultOkToDiffer(*subpResult))) {
1508	error =
1509	"Result of ENTRY is not compatible with result of containing function"_err_en_US;
1510	}
1511	}
1512	if (error) {
1513	if (auto *msg{messages_.Say(symbol.name(), *error)}) {
1514	if (subprogram) {
1515	msg->Attach(subprogram->name(), "Containing subprogram"_en_US);
1516	}
1517	}
1518	}
1519	}
1520	if (details.isFunction() &&
1521	details.result().name() != symbol.name()) { // F'2023 C1569 & C1583
1522	if (auto iter{symbol.owner().find(details.result().name())};
1523	iter != symbol.owner().end()) {
1524	const Symbol &resNameSym{*iter->second};
1525	if (const auto *resNameSubp{resNameSym.detailsIf<SubprogramDetails>()}) {
1526	if (const Scope * resNameEntryScope{resNameSubp->entryScope()}) {
1527	const Scope *myScope{
1528	details.entryScope() ? details.entryScope() : symbol.scope()};
1529	if (resNameEntryScope == myScope) {
1530	if (auto *msg{messages_.Say(symbol.name(),
1531	"Explicit RESULT('%s') of function '%s' cannot have the same name as a distinct ENTRY into the same scope"_err_en_US,
1532	details.result().name(), symbol.name())}) {
1533	msg->Attach(
1534	resNameSym.name(), "ENTRY with conflicting name"_en_US);
1535	}
1536	}
1537	}
1538	}
1539	}
1540	}
1541	if (const MaybeExpr & stmtFunction{details.stmtFunction()}) {
1542	if (auto msg{evaluate::CheckStatementFunction(
1543	symbol, *stmtFunction, context_.foldingContext())}) {
1544	SayWithDeclaration(symbol, std::move(*msg));
1545	} else if (IsPointer(symbol)) {
1546	SayWithDeclaration(symbol,
1547	"A statement function must not have the POINTER attribute"_err_en_US);
1548	} else if (details.result().flags().test(Symbol::Flag::Implicit)) {
1549	// 15.6.4 p2 weird requirement
1550	if (const Symbol *
1551	host{symbol.owner().parent().FindSymbol(symbol.name())}) {
1552	evaluate::AttachDeclaration(
1553	Warn(common::LanguageFeature::StatementFunctionExtensions,
1554	symbol.name(),
1555	"An implicitly typed statement function should not appear when the same symbol is available in its host scope"_port_en_US),
1556	*host);
1557	}
1558	}
1559	if (GetProgramUnitOrBlockConstructContaining(symbol).kind() ==
1560	Scope::Kind::BlockConstruct) { // C1107
1561	messages_.Say(symbol.name(),
1562	"A statement function definition may not appear in a BLOCK construct"_err_en_US);
1563	}
1564	}
1565	if (IsElementalProcedure(symbol)) {
1566	// See comment on the similar check in CheckProcEntity()
1567	if (details.isDummy()) {
1568	messages_.Say("A dummy procedure may not be ELEMENTAL"_err_en_US);
1569	} else {
1570	for (const Symbol *dummy : details.dummyArgs()) {
1571	if (!dummy) { // C15100
1572	messages_.Say(
1573	"An ELEMENTAL subroutine may not have an alternate return dummy argument"_err_en_US);
1574	}
1575	}
1576	}
1577	}
1578	if (details.isInterface()) {
1579	if (!details.isDummy() && details.isFunction() &&
1580	IsAssumedLengthCharacter(details.result())) { // C721
1581	messages_.Say(details.result().name(),
1582	"A function interface may not declare an assumed-length CHARACTER(*) result"_err_en_US);
1583	}
1584	if (symbol.attrs().test(Attr::ABSTRACT) &&
1585	(symbol.name() == "integer" || symbol.name() == "unsigned" ||
1586	symbol.name() == "real" || symbol.name() == "complex" ||
1587	symbol.name() == "character" ||
1588	symbol.name() == "logical")) { // F'2023 C1503
1589	messages_.Say(
1590	"An ABSTRACT interface may not have the same name as an intrinsic type"_err_en_US);
1591	}
1592	}
1593	CheckExternal(symbol);
1594	CheckModuleProcedureDef(symbol);
1595	auto cudaAttrs{details.cudaSubprogramAttrs()};
1596	if (cudaAttrs &&
1597	(*cudaAttrs == common::CUDASubprogramAttrs::Global ||
1598	*cudaAttrs == common::CUDASubprogramAttrs::Grid_Global) &&
1599	details.isFunction()) {
1600	messages_.Say(symbol.name(),
1601	"A function may not have ATTRIBUTES(GLOBAL) or ATTRIBUTES(GRID_GLOBAL)"_err_en_US);
1602	}
1603	if (cudaAttrs &&
1604	(*cudaAttrs == common::CUDASubprogramAttrs::Global ||
1605	*cudaAttrs == common::CUDASubprogramAttrs::Grid_Global) &&
1606	symbol.attrs().HasAny({Attr::RECURSIVE, Attr::PURE, Attr::ELEMENTAL})) {
1607	messages_.Say(symbol.name(),
1608	"A kernel subprogram may not be RECURSIVE, PURE, or ELEMENTAL"_err_en_US);
1609	}
1610	if (cudaAttrs && *cudaAttrs != common::CUDASubprogramAttrs::Host) {
1611	// CUDA device subprogram checks
1612	if (ClassifyProcedure(symbol) == ProcedureDefinitionClass::Internal) {
1613	messages_.Say(symbol.name(),
1614	"A device subprogram may not be an internal subprogram"_err_en_US);
1615	}
1616	}
1617	if ((!details.cudaLaunchBounds().empty() ||
1618	!details.cudaClusterDims().empty()) &&
1619	!(cudaAttrs &&
1620	(*cudaAttrs == common::CUDASubprogramAttrs::Global ||
1621	*cudaAttrs == common::CUDASubprogramAttrs::Grid_Global))) {
1622	messages_.Say(symbol.name(),
1623	"A subroutine may not have LAUNCH_BOUNDS() or CLUSTER_DIMS() unless it has ATTRIBUTES(GLOBAL) or ATTRIBUTES(GRID_GLOBAL)"_err_en_US);
1624	}
1625	if (!IsStmtFunction(symbol)) {
1626	if (const Scope * outerDevice{FindCUDADeviceContext(&symbol.owner())};
1627	outerDevice && outerDevice->symbol()) {
1628	if (auto *msg{messages_.Say(symbol.name(),
1629	"'%s' may not be an internal procedure of CUDA device subprogram '%s'"_err_en_US,
1630	symbol.name(), outerDevice->symbol()->name())}) {
1631	msg->Attach(outerDevice->symbol()->name(),
1632	"Containing CUDA device subprogram"_en_US);
1633	}
1634	}
1635	}
1636	}
1637
1638	void CheckHelper::CheckExternal(const Symbol &symbol) {
1639	if (IsExternal(symbol)) {
1640	std::string interfaceName{symbol.name().ToString()};
1641	if (const auto *bind{symbol.GetBindName()}) {
1642	interfaceName = *bind;
1643	}
1644	if (const Symbol * global{FindGlobal(symbol)};
1645	global && global != &symbol) {
1646	std::string definitionName{global->name().ToString()};
1647	if (const auto *bind{global->GetBindName()}) {
1648	definitionName = *bind;
1649	}
1650	if (interfaceName == definitionName) {
1651	parser::Message *msg{nullptr};
1652	if (!IsProcedure(*global)) {
1653	if ((symbol.flags().test(Symbol::Flag::Function) ||
1654	symbol.flags().test(Symbol::Flag::Subroutine))) {
1655	msg = Warn(common::UsageWarning::ExternalNameConflict,
1656	"The global entity '%s' corresponding to the local procedure '%s' is not a callable subprogram"_warn_en_US,
1657	global->name(), symbol.name());
1658	}
1659	} else if (auto chars{Characterize(symbol)}) {
1660	if (auto globalChars{Characterize(*global)}) {
1661	if (chars->HasExplicitInterface()) {
1662	std::string whyNot;
1663	if (!chars->IsCompatibleWith(*globalChars,
1664	/*ignoreImplicitVsExplicit=*/false, &whyNot)) {
1665	msg = Warn(common::UsageWarning::ExternalInterfaceMismatch,
1666	"The global subprogram '%s' is not compatible with its local procedure declaration (%s)"_warn_en_US,
1667	global->name(), whyNot);
1668	}
1669	} else if (!globalChars->CanBeCalledViaImplicitInterface()) {
1670	// TODO: This should be a hard error if the procedure has
1671	// actually been called (as opposed to just being used as a
1672	// procedure pointer target or passed as an actual argument).
1673	msg = Warn(common::UsageWarning::ExternalInterfaceMismatch,
1674	"The global subprogram '%s' should not be referenced via the implicit interface '%s'"_warn_en_US,
1675	global->name(), symbol.name());
1676	}
1677	}
1678	}
1679	if (msg) {
1680	if (msg->IsFatal()) {
1681	context_.SetError(symbol);
1682	}
1683	evaluate::AttachDeclaration(msg, *global);
1684	evaluate::AttachDeclaration(msg, symbol);
1685	}
1686	}
1687	} else if (auto iter{externalNames_.find(interfaceName)};
1688	iter != externalNames_.end()) {
1689	const Symbol &previous{*iter->second};
1690	if (auto chars{Characterize(symbol)}) {
1691	if (auto previousChars{Characterize(previous)}) {
1692	std::string whyNot;
1693	if (!chars->IsCompatibleWith(*previousChars,
1694	/*ignoreImplicitVsExplicit=*/false, &whyNot)) {
1695	if (auto *msg{Warn(common::UsageWarning::ExternalInterfaceMismatch,
1696	"The external interface '%s' is not compatible with an earlier definition (%s)"_warn_en_US,
1697	symbol.name(), whyNot)}) {
1698	evaluate::AttachDeclaration(msg, previous);
1699	evaluate::AttachDeclaration(msg, symbol);
1700	}
1701	}
1702	}
1703	}
1704	} else {
1705	externalNames_.emplace(interfaceName, symbol);
1706	}
1707	}
1708	}
1709
1710	void CheckHelper::CheckDerivedType(
1711	const Symbol &derivedType, const DerivedTypeDetails &details) {
1712	if (details.isForwardReferenced() && !context_.HasError(derivedType)) {
1713	messages_.Say("The derived type '%s' has not been defined"_err_en_US,
1714	derivedType.name());
1715	}
1716	const Scope *scope{derivedType.scope()};
1717	if (!scope) {
1718	CHECK(details.isForwardReferenced());
1719	return;
1720	}
1721	CHECK(scope->symbol() == &derivedType);
1722	CHECK(scope->IsDerivedType());
1723	if (derivedType.attrs().test(Attr::ABSTRACT) && // C734
1724	(derivedType.attrs().test(Attr::BIND_C) || details.sequence())) {
1725	messages_.Say("An ABSTRACT derived type must be extensible"_err_en_US);
1726	}
1727	if (const DeclTypeSpec *parent{FindParentTypeSpec(derivedType)}) {
1728	const DerivedTypeSpec *parentDerived{parent->AsDerived()};
1729	if (!IsExtensibleType(parentDerived)) { // C705
1730	messages_.Say("The parent type is not extensible"_err_en_US);
1731	}
1732	if (!derivedType.attrs().test(Attr::ABSTRACT) && parentDerived &&
1733	parentDerived->typeSymbol().attrs().test(Attr::ABSTRACT)) {
1734	ScopeComponentIterator components{*parentDerived};
1735	for (const Symbol &component : components) {
1736	if (component.attrs().test(Attr::DEFERRED)) {
1737	if (scope->FindComponent(component.name()) == &component) {
1738	SayWithDeclaration(component,
1739	"Non-ABSTRACT extension of ABSTRACT derived type '%s' lacks a binding for DEFERRED procedure '%s'"_err_en_US,
1740	parentDerived->typeSymbol().name(), component.name());
1741	}
1742	}
1743	}
1744	}
1745	DerivedTypeSpec derived{derivedType.name(), derivedType};
1746	derived.set_scope(*scope);
1747	if (FindCoarrayUltimateComponent(derived) && // C736
1748	!(parentDerived && FindCoarrayUltimateComponent(*parentDerived))) {
1749	messages_.Say(
1750	"Type '%s' has a coarray ultimate component so the type at the base "
1751	"of its type extension chain ('%s') must be a type that has a "
1752	"coarray ultimate component"_err_en_US,
1753	derivedType.name(), scope->GetDerivedTypeBase().GetSymbol()->name());
1754	}
1755	if (FindEventOrLockPotentialComponent(derived) && // C737
1756	!(FindEventOrLockPotentialComponent(*parentDerived) ||
1757	IsEventTypeOrLockType(parentDerived))) {
1758	messages_.Say(
1759	"Type '%s' has an EVENT_TYPE or LOCK_TYPE component, so the type "
1760	"at the base of its type extension chain ('%s') must either have an "
1761	"EVENT_TYPE or LOCK_TYPE component, or be EVENT_TYPE or "
1762	"LOCK_TYPE"_err_en_US,
1763	derivedType.name(), scope->GetDerivedTypeBase().GetSymbol()->name());
1764	}
1765	}
1766	if (HasIntrinsicTypeName(derivedType)) { // C729
1767	messages_.Say("A derived type name cannot be the name of an intrinsic"
1768	" type"_err_en_US);
1769	}
1770	std::map<SourceName, SymbolRef> previous;
1771	for (const auto &pair : details.finals()) {
1772	SourceName source{pair.first};
1773	const Symbol &ref{*pair.second};
1774	if (CheckFinal(ref, source, derivedType) &&
1775	std::all_of(previous.begin(), previous.end(),
1776	[&](std::pair<SourceName, SymbolRef> prev) {
1777	return CheckDistinguishableFinals(
1778	ref, source, *prev.second, prev.first, derivedType);
1779	})) {
1780	previous.emplace(source, ref);
1781	}
1782	}
1783	}
1784
1785	// C786
1786	bool CheckHelper::CheckFinal(
1787	const Symbol &subroutine, SourceName finalName, const Symbol &derivedType) {
1788	if (!IsModuleProcedure(subroutine)) {
1789	SayWithDeclaration(subroutine, finalName,
1790	"FINAL subroutine '%s' of derived type '%s' must be a module procedure"_err_en_US,
1791	subroutine.name(), derivedType.name());
1792	return false;
1793	}
1794	const Procedure *proc{Characterize(subroutine)};
1795	if (!proc) {
1796	return false; // error recovery
1797	}
1798	if (!proc->IsSubroutine()) {
1799	SayWithDeclaration(subroutine, finalName,
1800	"FINAL subroutine '%s' of derived type '%s' must be a subroutine"_err_en_US,
1801	subroutine.name(), derivedType.name());
1802	return false;
1803	}
1804	if (proc->dummyArguments.size() != 1) {
1805	SayWithDeclaration(subroutine, finalName,
1806	"FINAL subroutine '%s' of derived type '%s' must have a single dummy argument"_err_en_US,
1807	subroutine.name(), derivedType.name());
1808	return false;
1809	}
1810	const auto &arg{proc->dummyArguments[0]};
1811	const Symbol *errSym{&subroutine};
1812	if (const auto *details{subroutine.detailsIf<SubprogramDetails>()}) {
1813	if (!details->dummyArgs().empty()) {
1814	if (const Symbol *argSym{details->dummyArgs()[0]}) {
1815	errSym = argSym;
1816	}
1817	}
1818	}
1819	const auto *ddo{std::get_if<DummyDataObject>(&arg.u)};
1820	if (!ddo) {
1821	SayWithDeclaration(subroutine, finalName,
1822	"FINAL subroutine '%s' of derived type '%s' must have a single dummy argument that is a data object"_err_en_US,
1823	subroutine.name(), derivedType.name());
1824	return false;
1825	}
1826	bool ok{true};
1827	if (arg.IsOptional()) {
1828	SayWithDeclaration(*errSym, finalName,
1829	"FINAL subroutine '%s' of derived type '%s' must not have an OPTIONAL dummy argument"_err_en_US,
1830	subroutine.name(), derivedType.name());
1831	ok = false;
1832	}
1833	if (ddo->attrs.test(DummyDataObject::Attr::Allocatable)) {
1834	SayWithDeclaration(*errSym, finalName,
1835	"FINAL subroutine '%s' of derived type '%s' must not have an ALLOCATABLE dummy argument"_err_en_US,
1836	subroutine.name(), derivedType.name());
1837	ok = false;
1838	}
1839	if (ddo->attrs.test(DummyDataObject::Attr::Pointer)) {
1840	SayWithDeclaration(*errSym, finalName,
1841	"FINAL subroutine '%s' of derived type '%s' must not have a POINTER dummy argument"_err_en_US,
1842	subroutine.name(), derivedType.name());
1843	ok = false;
1844	}
1845	if (ddo->intent == common::Intent::Out) {
1846	SayWithDeclaration(*errSym, finalName,
1847	"FINAL subroutine '%s' of derived type '%s' must not have a dummy argument with INTENT(OUT)"_err_en_US,
1848	subroutine.name(), derivedType.name());
1849	ok = false;
1850	}
1851	if (ddo->attrs.test(DummyDataObject::Attr::Value)) {
1852	SayWithDeclaration(*errSym, finalName,
1853	"FINAL subroutine '%s' of derived type '%s' must not have a dummy argument with the VALUE attribute"_err_en_US,
1854	subroutine.name(), derivedType.name());
1855	ok = false;
1856	}
1857	if (ddo->type.corank() > 0) {
1858	SayWithDeclaration(*errSym, finalName,
1859	"FINAL subroutine '%s' of derived type '%s' must not have a coarray dummy argument"_err_en_US,
1860	subroutine.name(), derivedType.name());
1861	ok = false;
1862	}
1863	if (ddo->type.type().IsPolymorphic()) {
1864	SayWithDeclaration(*errSym, finalName,
1865	"FINAL subroutine '%s' of derived type '%s' must not have a polymorphic dummy argument"_err_en_US,
1866	subroutine.name(), derivedType.name());
1867	ok = false;
1868	} else if (ddo->type.type().category() != TypeCategory::Derived ||
1869	&ddo->type.type().GetDerivedTypeSpec().typeSymbol() != &derivedType) {
1870	SayWithDeclaration(*errSym, finalName,
1871	"FINAL subroutine '%s' of derived type '%s' must have a TYPE(%s) dummy argument"_err_en_US,
1872	subroutine.name(), derivedType.name(), derivedType.name());
1873	ok = false;
1874	} else { // check that all LEN type parameters are assumed
1875	for (auto ref : OrderParameterDeclarations(derivedType)) {
1876	if (IsLenTypeParameter(*ref)) {
1877	const auto *value{
1878	ddo->type.type().GetDerivedTypeSpec().FindParameter(ref->name())};
1879	if (!value || !value->isAssumed()) {
1880	SayWithDeclaration(*errSym, finalName,
1881	"FINAL subroutine '%s' of derived type '%s' must have a dummy argument with an assumed LEN type parameter '%s=*'"_err_en_US,
1882	subroutine.name(), derivedType.name(), ref->name());
1883	ok = false;
1884	}
1885	}
1886	}
1887	}
1888	return ok;
1889	}
1890
1891	bool CheckHelper::CheckDistinguishableFinals(const Symbol &f1,
1892	SourceName f1Name, const Symbol &f2, SourceName f2Name,
1893	const Symbol &derivedType) {
1894	const Procedure *p1{Characterize(f1)};
1895	const Procedure *p2{Characterize(f2)};
1896	if (p1 && p2) {
1897	std::optional<bool> areDistinct{characteristics::Distinguishable(
1898	context_.languageFeatures(), *p1, *p2)};
1899	if (areDistinct.value_or(u: false)) {
1900	return true;
1901	}
1902	if (auto *msg{messages_.Say(f1Name,
1903	"FINAL subroutines '%s' and '%s' of derived type '%s' cannot be distinguished by rank or KIND type parameter value"_err_en_US,
1904	f1Name, f2Name, derivedType.name())}) {
1905	msg->Attach(f2Name, "FINAL declaration of '%s'"_en_US, f2.name())
1906	.Attach(f1.name(), "Definition of '%s'"_en_US, f1Name)
1907	.Attach(f2.name(), "Definition of '%s'"_en_US, f2Name);
1908	}
1909	}
1910	return false;
1911	}
1912
1913	void CheckHelper::CheckHostAssoc(
1914	const Symbol &symbol, const HostAssocDetails &details) {
1915	const Symbol &hostSymbol{details.symbol()};
1916	if (hostSymbol.test(Symbol::Flag::ImplicitOrError)) {
1917	if (details.implicitOrSpecExprError) {
1918	messages_.Say("Implicitly typed local entity '%s' not allowed in"
1919	" specification expression"_err_en_US,
1920	symbol.name());
1921	} else if (details.implicitOrExplicitTypeError) {
1922	messages_.Say(
1923	"No explicit type declared for '%s'"_err_en_US, symbol.name());
1924	}
1925	}
1926	}
1927
1928	void CheckHelper::CheckGeneric(
1929	const Symbol &symbol, const GenericDetails &details) {
1930	CheckSpecifics(symbol, details);
1931	common::visit(common::visitors{
1932	[&](const common::DefinedIo &io) {
1933	CheckDefinedIoProc(symbol, details, io);
1934	},
1935	[&](const GenericKind::OtherKind &other) {
1936	if (other == GenericKind::OtherKind::Name) {
1937	CheckGenericVsIntrinsic(symbol, details);
1938	}
1939	},
1940	[](const auto &) {},
1941	},
1942	details.kind().u);
1943	// Ensure that shadowed symbols are checked
1944	if (details.specific()) {
1945	Check(*details.specific());
1946	}
1947	if (details.derivedType()) {
1948	Check(*details.derivedType());
1949	}
1950	}
1951
1952	// Check that the specifics of this generic are distinguishable from each other
1953	void CheckHelper::CollectSpecifics(DistinguishabilityHelper &helper,
1954	const Symbol &generic, const GenericDetails &details) {
1955	GenericKind kind{details.kind()};
1956	for (const Symbol &specific : details.specificProcs()) {
1957	if (specific.attrs().test(Attr::ABSTRACT)) {
1958	if (auto *msg{messages_.Say(generic.name(),
1959	"Generic interface '%s' must not use abstract interface '%s' as a specific procedure"_err_en_US,
1960	generic.name(), specific.name())}) {
1961	msg->Attach(
1962	specific.name(), "Definition of '%s'"_en_US, specific.name());
1963	}
1964	continue;
1965	}
1966	if (specific.attrs().test(Attr::INTRINSIC)) {
1967	// GNU Fortran allows INTRINSIC procedures in generics.
1968	auto intrinsic{context_.intrinsics().IsSpecificIntrinsicFunction(
1969	specific.name().ToString())};
1970	if (intrinsic && !intrinsic->isRestrictedSpecific) {
1971	if (auto *msg{Warn(common::LanguageFeature::IntrinsicAsSpecific,
1972	specific.name(),
1973	"Specific procedure '%s' of generic interface '%s' should not be INTRINSIC"_port_en_US,
1974	specific.name(), generic.name())}) {
1975	msg->Attach(
1976	generic.name(), "Definition of '%s'"_en_US, generic.name());
1977	}
1978	} else {
1979	if (auto *msg{Warn(common::LanguageFeature::IntrinsicAsSpecific,
1980	specific.name(),
1981	"Procedure '%s' of generic interface '%s' is INTRINSIC but not an unrestricted specific intrinsic function"_port_en_US,
1982	specific.name(), generic.name())}) {
1983	msg->Attach(
1984	generic.name(), "Definition of '%s'"_en_US, generic.name());
1985	}
1986	continue;
1987	}
1988	}
1989	if (IsStmtFunction(specific)) {
1990	if (auto *msg{messages_.Say(specific.name(),
1991	"Specific procedure '%s' of generic interface '%s' may not be a statement function"_err_en_US,
1992	specific.name(), generic.name())}) {
1993	msg->Attach(generic.name(), "Definition of '%s'"_en_US, generic.name());
1994	}
1995	continue;
1996	}
1997	if (const Procedure *procedure{Characterize(specific)}) {
1998	if (procedure->HasExplicitInterface()) {
1999	helper.Add(generic, kind, specific, *procedure);
2000	} else {
2001	if (auto *msg{messages_.Say(specific.name(),
2002	"Specific procedure '%s' of generic interface '%s' must have an explicit interface"_err_en_US,
2003	specific.name(), generic.name())}) {
2004	msg->Attach(
2005	generic.name(), "Definition of '%s'"_en_US, generic.name());
2006	}
2007	}
2008	}
2009	}
2010	if (const Scope * parent{generic.owner().GetDerivedTypeParent()}) {
2011	if (const Symbol * inherited{parent->FindComponent(generic.name())}) {
2012	if (IsAccessible(*inherited, generic.owner().parent())) {
2013	if (const auto *details{inherited->detailsIf<GenericDetails>()}) {
2014	// Include specifics of inherited generic of the same name, too
2015	CollectSpecifics(helper, *inherited, *details);
2016	}
2017	}
2018	}
2019	}
2020	}
2021
2022	void CheckHelper::CheckSpecifics(
2023	const Symbol &generic, const GenericDetails &details) {
2024	DistinguishabilityHelper helper{context_};
2025	CollectSpecifics(helper, generic, details);
2026	helper.Check(generic.owner());
2027	}
2028
2029	static bool CUDAHostDeviceDiffer(
2030	const Procedure &proc, const DummyDataObject &arg) {
2031	auto procCUDA{
2032	proc.cudaSubprogramAttrs.value_or(common::CUDASubprogramAttrs::Host)};
2033	bool procIsHostOnly{procCUDA == common::CUDASubprogramAttrs::Host};
2034	bool procIsDeviceOnly{
2035	!procIsHostOnly && procCUDA != common::CUDASubprogramAttrs::HostDevice};
2036	const auto &argCUDA{arg.cudaDataAttr};
2037	bool argIsHostOnly{!argCUDA || *argCUDA == common::CUDADataAttr::Pinned};
2038	bool argIsDeviceOnly{(!argCUDA && procIsDeviceOnly) ||
2039	(argCUDA &&
2040	(*argCUDA != common::CUDADataAttr::Managed &&
2041	*argCUDA != common::CUDADataAttr::Pinned &&
2042	*argCUDA != common::CUDADataAttr::Unified))};
2043	return (procIsHostOnly && argIsDeviceOnly) ||
2044	(procIsDeviceOnly && argIsHostOnly);
2045	}
2046
2047	static bool ConflictsWithIntrinsicAssignment(const Procedure &proc) {
2048	const auto &lhsData{std::get<DummyDataObject>(proc.dummyArguments[0].u)};
2049	const auto &lhsTnS{lhsData.type};
2050	const auto &rhsData{std::get<DummyDataObject>(proc.dummyArguments[1].u)};
2051	const auto &rhsTnS{rhsData.type};
2052	return !CUDAHostDeviceDiffer(proc, lhsData) &&
2053	!CUDAHostDeviceDiffer(proc, rhsData) &&
2054	Tristate::No ==
2055	IsDefinedAssignment(
2056	lhsTnS.type(), lhsTnS.Rank(), rhsTnS.type(), rhsTnS.Rank());
2057	}
2058
2059	static bool ConflictsWithIntrinsicOperator(
2060	const GenericKind &kind, const Procedure &proc) {
2061	if (!kind.IsIntrinsicOperator()) {
2062	return false;
2063	}
2064	const auto &arg0Data{std::get<DummyDataObject>(proc.dummyArguments[0].u)};
2065	if (CUDAHostDeviceDiffer(proc, arg0Data)) {
2066	return false;
2067	}
2068	const auto &arg0TnS{arg0Data.type};
2069	auto type0{arg0TnS.type()};
2070	if (proc.dummyArguments.size() == 1) { // unary
2071	return common::visit(
2072	common::visitors{
2073	[&](common::NumericOperator) { return IsIntrinsicNumeric(type0); },
2074	[&](common::LogicalOperator) { return IsIntrinsicLogical(type0); },
2075	[](const auto &) -> bool { DIE("bad generic kind"); },
2076	},
2077	kind.u);
2078	} else { // binary
2079	int rank0{arg0TnS.Rank()};
2080	const auto &arg1Data{std::get<DummyDataObject>(proc.dummyArguments[1].u)};
2081	if (CUDAHostDeviceDiffer(proc, arg1Data)) {
2082	return false;
2083	}
2084	const auto &arg1TnS{arg1Data.type};
2085	auto type1{arg1TnS.type()};
2086	int rank1{arg1TnS.Rank()};
2087	return common::visit(
2088	common::visitors{
2089	[&](common::NumericOperator) {
2090	return IsIntrinsicNumeric(type0, rank0, type1, rank1);
2091	},
2092	[&](common::LogicalOperator) {
2093	return IsIntrinsicLogical(type0, rank0, type1, rank1);
2094	},
2095	[&](common::RelationalOperator opr) {
2096	return IsIntrinsicRelational(opr, type0, rank0, type1, rank1);
2097	},
2098	[&](GenericKind::OtherKind x) {
2099	CHECK(x == GenericKind::OtherKind::Concat);
2100	return IsIntrinsicConcat(type0, rank0, type1, rank1);
2101	},
2102	[](const auto &) -> bool { DIE("bad generic kind"); },
2103	},
2104	kind.u);
2105	}
2106	}
2107
2108	// Check if this procedure can be used for defined operators (see 15.4.3.4.2).
2109	bool CheckHelper::CheckDefinedOperator(SourceName opName, GenericKind kind,
2110	const Symbol &specific, const Procedure &proc) {
2111	if (context_.HasError(specific)) {
2112	return false;
2113	}
2114	std::optional<parser::MessageFixedText> msg;
2115	auto checkDefinedOperatorArgs{
2116	[&](SourceName opName, const Symbol &specific, const Procedure &proc) {
2117	bool arg0Defined{CheckDefinedOperatorArg(opName, specific, proc, 0)};
2118	bool arg1Defined{CheckDefinedOperatorArg(opName, specific, proc, 1)};
2119	return arg0Defined && arg1Defined;
2120	}};
2121	if (specific.attrs().test(Attr::NOPASS)) { // C774
2122	msg = "%s procedure '%s' may not have NOPASS attribute"_err_en_US;
2123	} else if (!proc.functionResult.has_value()) {
2124	msg = "%s procedure '%s' must be a function"_err_en_US;
2125	} else if (proc.functionResult->IsAssumedLengthCharacter()) {
2126	const auto *subpDetails{specific.detailsIf<SubprogramDetails>()};
2127	if (subpDetails && !subpDetails->isDummy() && subpDetails->isInterface()) {
2128	// Error is caught by more general test for interfaces with
2129	// assumed-length character function results
2130	return true;
2131	}
2132	msg = "%s function '%s' may not have assumed-length CHARACTER(*)"
2133	" result"_err_en_US;
2134	} else if (auto m{CheckNumberOfArgs(kind, proc.dummyArguments.size())}) {
2135	if (m->IsFatal()) {
2136	msg = *m;
2137	} else {
2138	evaluate::AttachDeclaration(
2139	Warn(common::UsageWarning::DefinedOperatorArgs, specific.name(),
2140	std::move(*m), MakeOpName(opName), specific.name()),
2141	specific);
2142	return true;
2143	}
2144	} else if (!checkDefinedOperatorArgs(opName, specific, proc)) {
2145	return false; // error was reported
2146	} else if (ConflictsWithIntrinsicOperator(kind, proc)) {
2147	msg = "%s function '%s' conflicts with intrinsic operator"_err_en_US;
2148	}
2149	if (msg) {
2150	SayWithDeclaration(
2151	specific, std::move(*msg), MakeOpName(opName), specific.name());
2152	context_.SetError(specific);
2153	return false;
2154	}
2155	return true;
2156	}
2157
2158	// If the number of arguments is wrong for this intrinsic operator, return
2159	// false and return the error message in msg.
2160	std::optional<parser::MessageFixedText> CheckHelper::CheckNumberOfArgs(
2161	const GenericKind &kind, std::size_t nargs) {
2162	if (!kind.IsIntrinsicOperator()) {
2163	if (nargs < 1 || nargs > 2) {
2164	if (context_.ShouldWarn(common::UsageWarning::DefinedOperatorArgs)) {
2165	return "%s function '%s' should have 1 or 2 dummy arguments"_warn_en_US;
2166	}
2167	}
2168	return std::nullopt;
2169	}
2170	std::size_t min{2}, max{2}; // allowed number of args; default is binary
2171	common::visit(common::visitors{
2172	[&](const common::NumericOperator &x) {
2173	if (x == common::NumericOperator::Add ||
2174	x == common::NumericOperator::Subtract) {
2175	min = 1; // + and - are unary or binary
2176	}
2177	},
2178	[&](const common::LogicalOperator &x) {
2179	if (x == common::LogicalOperator::Not) {
2180	min = 1; // .NOT. is unary
2181	max = 1;
2182	}
2183	},
2184	[](const common::RelationalOperator &) {
2185	// all are binary
2186	},
2187	[](const GenericKind::OtherKind &x) {
2188	CHECK(x == GenericKind::OtherKind::Concat);
2189	},
2190	[](const auto &) { DIE("expected intrinsic operator"); },
2191	},
2192	kind.u);
2193	if (nargs >= min && nargs <= max) {
2194	return std::nullopt;
2195	} else if (max == 1) {
2196	return "%s function '%s' must have one dummy argument"_err_en_US;
2197	} else if (min == 2) {
2198	return "%s function '%s' must have two dummy arguments"_err_en_US;
2199	} else {
2200	return "%s function '%s' must have one or two dummy arguments"_err_en_US;
2201	}
2202	}
2203
2204	bool CheckHelper::CheckDefinedOperatorArg(const SourceName &opName,
2205	const Symbol &symbol, const Procedure &proc, std::size_t pos) {
2206	if (pos >= proc.dummyArguments.size()) {
2207	return true;
2208	}
2209	auto &arg{proc.dummyArguments.at(pos)};
2210	std::optional<parser::MessageFixedText> msg;
2211	if (arg.IsOptional()) {
2212	msg =
2213	"In %s function '%s', dummy argument '%s' may not be OPTIONAL"_err_en_US;
2214	} else if (const auto *dataObject{std::get_if<DummyDataObject>(&arg.u)};
2215	dataObject == nullptr) {
2216	msg =
2217	"In %s function '%s', dummy argument '%s' must be a data object"_err_en_US;
2218	} else if (dataObject->intent == common::Intent::Out) {
2219	msg =
2220	"In %s function '%s', dummy argument '%s' may not be INTENT(OUT)"_err_en_US;
2221	} else if (dataObject->intent != common::Intent::In &&
2222	!dataObject->attrs.test(DummyDataObject::Attr::Value)) {
2223	evaluate::AttachDeclaration(
2224	Warn(common::UsageWarning::DefinedOperatorArgs,
2225	"In %s function '%s', dummy argument '%s' should have INTENT(IN) or VALUE attribute"_warn_en_US,
2226	parser::ToUpperCaseLetters(opName.ToString()), symbol.name(),
2227	arg.name),
2228	symbol);
2229	return true;
2230	}
2231	if (msg) {
2232	SayWithDeclaration(symbol, std::move(*msg),
2233	parser::ToUpperCaseLetters(opName.ToString()), symbol.name(), arg.name);
2234	return false;
2235	}
2236	return true;
2237	}
2238
2239	// Check if this procedure can be used for defined assignment (see 15.4.3.4.3).
2240	bool CheckHelper::CheckDefinedAssignment(
2241	const Symbol &specific, const Procedure &proc) {
2242	if (context_.HasError(specific)) {
2243	return false;
2244	}
2245	std::optional<parser::MessageFixedText> msg;
2246	if (specific.attrs().test(Attr::NOPASS)) { // C774
2247	msg = "Defined assignment procedure '%s' may not have"
2248	" NOPASS attribute"_err_en_US;
2249	} else if (!proc.IsSubroutine()) {
2250	msg = "Defined assignment procedure '%s' must be a subroutine"_err_en_US;
2251	} else if (proc.dummyArguments.size() != 2) {
2252	msg = "Defined assignment subroutine '%s' must have"
2253	" two dummy arguments"_err_en_US;
2254	} else {
2255	// Check both arguments even if the first has an error.
2256	bool ok0{CheckDefinedAssignmentArg(specific, proc.dummyArguments[0], 0)};
2257	bool ok1{CheckDefinedAssignmentArg(specific, proc.dummyArguments[1], 1)};
2258	if (!(ok0 && ok1)) {
2259	return false; // error was reported
2260	} else if (ConflictsWithIntrinsicAssignment(proc)) {
2261	msg =
2262	"Defined assignment subroutine '%s' conflicts with intrinsic assignment"_err_en_US;
2263	} else {
2264	return true; // OK
2265	}
2266	}
2267	SayWithDeclaration(specific, std::move(msg.value()), specific.name());
2268	context_.SetError(specific);
2269	return false;
2270	}
2271
2272	bool CheckHelper::CheckDefinedAssignmentArg(
2273	const Symbol &symbol, const DummyArgument &arg, int pos) {
2274	std::optional<parser::MessageFixedText> msg;
2275	if (arg.IsOptional()) {
2276	msg = "In defined assignment subroutine '%s', dummy argument '%s'"
2277	" may not be OPTIONAL"_err_en_US;
2278	} else if (const auto *dataObject{std::get_if<DummyDataObject>(&arg.u)}) {
2279	if (pos == 0) {
2280	if (dataObject->intent == common::Intent::In) {
2281	msg = "In defined assignment subroutine '%s', first dummy argument '%s'"
2282	" may not have INTENT(IN)"_err_en_US;
2283	} else if (dataObject->intent != common::Intent::Out &&
2284	dataObject->intent != common::Intent::InOut) {
2285	msg =
2286	"In defined assignment subroutine '%s', first dummy argument '%s' should have INTENT(OUT) or INTENT(INOUT)"_warn_en_US;
2287	}
2288	} else if (pos == 1) {
2289	if (dataObject->intent == common::Intent::Out) {
2290	msg = "In defined assignment subroutine '%s', second dummy"
2291	" argument '%s' may not have INTENT(OUT)"_err_en_US;
2292	} else if (dataObject->intent != common::Intent::In &&
2293	!dataObject->attrs.test(DummyDataObject::Attr::Value)) {
2294	msg =
2295	"In defined assignment subroutine '%s', second dummy argument '%s' should have INTENT(IN) or VALUE attribute"_warn_en_US;
2296	} else if (dataObject->attrs.test(DummyDataObject::Attr::Pointer)) {
2297	msg =
2298	"In defined assignment subroutine '%s', second dummy argument '%s' must not be a pointer"_err_en_US;
2299	} else if (dataObject->attrs.test(DummyDataObject::Attr::Allocatable)) {
2300	msg =
2301	"In defined assignment subroutine '%s', second dummy argument '%s' must not be an allocatable"_err_en_US;
2302	}
2303	} else {
2304	DIE("pos must be 0 or 1");
2305	}
2306	} else {
2307	msg = "In defined assignment subroutine '%s', dummy argument '%s'"
2308	" must be a data object"_err_en_US;
2309	}
2310	if (msg) {
2311	if (msg->IsFatal()) {
2312	SayWithDeclaration(symbol, std::move(*msg), symbol.name(), arg.name);
2313	context_.SetError(symbol);
2314	return false;
2315	} else {
2316	evaluate::AttachDeclaration(
2317	Warn(common::UsageWarning::DefinedOperatorArgs, std::move(*msg),
2318	symbol.name(), arg.name),
2319	symbol);
2320	}
2321	}
2322	return true;
2323	}
2324
2325	// Report a conflicting attribute error if symbol has both of these attributes
2326	bool CheckHelper::CheckConflicting(const Symbol &symbol, Attr a1, Attr a2) {
2327	if (symbol.attrs().test(a1) && symbol.attrs().test(a2)) {
2328	messages_.Say("'%s' may not have both the %s and %s attributes"_err_en_US,
2329	symbol.name(), AttrToString(a1), AttrToString(a2));
2330	return true;
2331	} else {
2332	return false;
2333	}
2334	}
2335
2336	void CheckHelper::WarnMissingFinal(const Symbol &symbol) {
2337	const auto *object{symbol.detailsIf<ObjectEntityDetails>()};
2338	if (!object || object->IsAssumedRank() ||
2339	(!IsAutomaticallyDestroyed(symbol) &&
2340	symbol.owner().kind() != Scope::Kind::DerivedType)) {
2341	return;
2342	}
2343	const DeclTypeSpec *type{object->type()};
2344	const DerivedTypeSpec *derived{type ? type->AsDerived() : nullptr};
2345	const Symbol *derivedSym{derived ? &derived->typeSymbol() : nullptr};
2346	int rank{object->shape().Rank()};
2347	const Symbol *initialDerivedSym{derivedSym};
2348	while (const auto *derivedDetails{
2349	derivedSym ? derivedSym->detailsIf<DerivedTypeDetails>() : nullptr}) {
2350	if (!derivedDetails->finals().empty() &&
2351	!derivedDetails->GetFinalForRank(rank)) {
2352	if (auto *msg{derivedSym == initialDerivedSym
2353	? Warn(common::UsageWarning::Final, symbol.name(),
2354	"'%s' of derived type '%s' does not have a FINAL subroutine for its rank (%d)"_warn_en_US,
2355	symbol.name(), derivedSym->name(), rank)
2356	: Warn(common::UsageWarning::Final, symbol.name(),
2357	"'%s' of derived type '%s' extended from '%s' does not have a FINAL subroutine for its rank (%d)"_warn_en_US,
2358	symbol.name(), initialDerivedSym->name(),
2359	derivedSym->name(), rank)}) {
2360	msg->Attach(derivedSym->name(),
2361	"Declaration of derived type '%s'"_en_US, derivedSym->name());
2362	}
2363	return;
2364	}
2365	derived = derivedSym->GetParentTypeSpec();
2366	derivedSym = derived ? &derived->typeSymbol() : nullptr;
2367	}
2368	}
2369
2370	const Procedure *CheckHelper::Characterize(const Symbol &symbol) {
2371	auto it{characterizeCache_.find(symbol)};
2372	if (it == characterizeCache_.end()) {
2373	auto pair{characterizeCache_.emplace(SymbolRef{symbol},
2374	Procedure::Characterize(symbol, context_.foldingContext()))};
2375	it = pair.first;
2376	}
2377	return common::GetPtrFromOptional(it->second);
2378	}
2379
2380	void CheckHelper::CheckVolatile(const Symbol &symbol,
2381	const DerivedTypeSpec *derived) { // C866 - C868
2382	if (IsIntentIn(symbol)) {
2383	messages_.Say(
2384	"VOLATILE attribute may not apply to an INTENT(IN) argument"_err_en_US);
2385	}
2386	if (IsProcedure(symbol)) {
2387	messages_.Say("VOLATILE attribute may apply only to a variable"_err_en_US);
2388	}
2389	if (symbol.has<UseDetails>() || symbol.has<HostAssocDetails>()) {
2390	const Symbol &ultimate{symbol.GetUltimate()};
2391	if (evaluate::IsCoarray(ultimate)) {
2392	messages_.Say(
2393	"VOLATILE attribute may not apply to a coarray accessed by USE or host association"_err_en_US);
2394	}
2395	if (derived) {
2396	if (FindCoarrayUltimateComponent(*derived)) {
2397	messages_.Say(
2398	"VOLATILE attribute may not apply to a type with a coarray ultimate component accessed by USE or host association"_err_en_US);
2399	}
2400	}
2401	}
2402	}
2403
2404	void CheckHelper::CheckContiguous(const Symbol &symbol) {
2405	if (evaluate::IsVariable(symbol) &&
2406	((IsPointer(symbol) && symbol.Rank() > 0) || IsAssumedShape(symbol) ||
2407	evaluate::IsAssumedRank(symbol))) {
2408	} else {
2409	parser::MessageFixedText msg{symbol.owner().IsDerivedType()
2410	? "CONTIGUOUS component '%s' should be an array with the POINTER attribute"_port_en_US
2411	: "CONTIGUOUS entity '%s' should be an array pointer, assumed-shape, or assumed-rank"_port_en_US};
2412	if (!context_.IsEnabled(common::LanguageFeature::RedundantContiguous)) {
2413	msg.set_severity(parser::Severity::Error);
2414	messages_.Say(std::move(msg), symbol.name());
2415	} else {
2416	Warn(common::LanguageFeature::RedundantContiguous, std::move(msg),
2417	symbol.name());
2418	}
2419	}
2420	}
2421
2422	void CheckHelper::CheckPointer(const Symbol &symbol) { // C852
2423	CheckConflicting(symbol, Attr::POINTER, Attr::TARGET);
2424	CheckConflicting(symbol, Attr::POINTER, Attr::ALLOCATABLE); // C751
2425	CheckConflicting(symbol, Attr::POINTER, Attr::INTRINSIC);
2426	// Prohibit constant pointers. The standard does not explicitly prohibit
2427	// them, but the PARAMETER attribute requires a entity-decl to have an
2428	// initialization that is a constant-expr, and the only form of
2429	// initialization that allows a constant-expr is the one that's not a "=>"
2430	// pointer initialization. See C811, C807, and section 8.5.13.
2431	CheckConflicting(symbol, Attr::POINTER, Attr::PARAMETER);
2432	if (symbol.Corank() > 0) {
2433	messages_.Say(
2434	"'%s' may not have the POINTER attribute because it is a coarray"_err_en_US,
2435	symbol.name());
2436	}
2437	}
2438
2439	// C760 constraints on the passed-object dummy argument
2440	// C757 constraints on procedure pointer components
2441	void CheckHelper::CheckPassArg(
2442	const Symbol &proc, const Symbol *interface0, const WithPassArg &details) {
2443	if (proc.attrs().test(Attr::NOPASS)) {
2444	return;
2445	}
2446	const auto &name{proc.name()};
2447	const Symbol *interface {
2448	interface0 ? FindInterface(*interface0) : nullptr
2449	};
2450	if (!interface) {
2451	messages_.Say(name,
2452	"Procedure component '%s' must have NOPASS attribute or explicit interface"_err_en_US,
2453	name);
2454	return;
2455	}
2456	const auto *subprogram{interface->detailsIf<SubprogramDetails>()};
2457	if (!subprogram) {
2458	messages_.Say(name,
2459	"Procedure component '%s' has invalid interface '%s'"_err_en_US, name,
2460	interface->name());
2461	return;
2462	}
2463	std::optional<SourceName> passName{details.passName()};
2464	const auto &dummyArgs{subprogram->dummyArgs()};
2465	if (!passName) {
2466	if (dummyArgs.empty()) {
2467	messages_.Say(name,
2468	proc.has<ProcEntityDetails>()
2469	? "Procedure component '%s' with no dummy arguments"
2470	" must have NOPASS attribute"_err_en_US
2471	: "Procedure binding '%s' with no dummy arguments"
2472	" must have NOPASS attribute"_err_en_US,
2473	name);
2474	context_.SetError(*interface);
2475	return;
2476	}
2477	Symbol *argSym{dummyArgs[0]};
2478	if (!argSym) {
2479	messages_.Say(interface->name(),
2480	"Cannot use an alternate return as the passed-object dummy "
2481	"argument"_err_en_US);
2482	return;
2483	}
2484	passName = dummyArgs[0]->name();
2485	}
2486	std::optional<int> passArgIndex{};
2487	for (std::size_t i{0}; i < dummyArgs.size(); ++i) {
2488	if (dummyArgs[i] && dummyArgs[i]->name() == *passName) {
2489	passArgIndex = i;
2490	break;
2491	}
2492	}
2493	if (!passArgIndex) { // C758
2494	messages_.Say(*passName,
2495	"'%s' is not a dummy argument of procedure interface '%s'"_err_en_US,
2496	*passName, interface->name());
2497	return;
2498	}
2499	const Symbol &passArg{*dummyArgs[*passArgIndex]};
2500	std::optional<parser::MessageFixedText> msg;
2501	if (!passArg.has<ObjectEntityDetails>()) {
2502	msg = "Passed-object dummy argument '%s' of procedure '%s'"
2503	" must be a data object"_err_en_US;
2504	} else if (passArg.attrs().test(Attr::POINTER)) {
2505	msg = "Passed-object dummy argument '%s' of procedure '%s'"
2506	" may not have the POINTER attribute"_err_en_US;
2507	} else if (passArg.attrs().test(Attr::ALLOCATABLE)) {
2508	msg = "Passed-object dummy argument '%s' of procedure '%s'"
2509	" may not have the ALLOCATABLE attribute"_err_en_US;
2510	} else if (passArg.attrs().test(Attr::VALUE)) {
2511	msg = "Passed-object dummy argument '%s' of procedure '%s'"
2512	" may not have the VALUE attribute"_err_en_US;
2513	} else if (passArg.Rank() > 0) {
2514	msg = "Passed-object dummy argument '%s' of procedure '%s'"
2515	" must be scalar"_err_en_US;
2516	}
2517	if (msg) {
2518	messages_.Say(name, std::move(*msg), passName.value(), name);
2519	return;
2520	}
2521	const DeclTypeSpec *type{passArg.GetType()};
2522	if (!type) {
2523	return; // an error already occurred
2524	}
2525	const Symbol &typeSymbol{*proc.owner().GetSymbol()};
2526	const DerivedTypeSpec *derived{type->AsDerived()};
2527	if (!derived || derived->typeSymbol() != typeSymbol) {
2528	messages_.Say(name,
2529	"Passed-object dummy argument '%s' of procedure '%s'"
2530	" must be of type '%s' but is '%s'"_err_en_US,
2531	passName.value(), name, typeSymbol.name(), type->AsFortran());
2532	return;
2533	}
2534	if (IsExtensibleType(derived) != type->IsPolymorphic()) {
2535	messages_.Say(name,
2536	type->IsPolymorphic()
2537	? "Passed-object dummy argument '%s' of procedure '%s'"
2538	" may not be polymorphic because '%s' is not extensible"_err_en_US
2539	: "Passed-object dummy argument '%s' of procedure '%s'"
2540	" must be polymorphic because '%s' is extensible"_err_en_US,
2541	passName.value(), name, typeSymbol.name());
2542	return;
2543	}
2544	for (const auto &[paramName, paramValue] : derived->parameters()) {
2545	if (paramValue.isLen() && !paramValue.isAssumed()) {
2546	messages_.Say(name,
2547	"Passed-object dummy argument '%s' of procedure '%s'"
2548	" has non-assumed length parameter '%s'"_err_en_US,
2549	passName.value(), name, paramName);
2550	}
2551	}
2552	}
2553
2554	void CheckHelper::CheckProcBinding(
2555	const Symbol &symbol, const ProcBindingDetails &binding) {
2556	const Scope &dtScope{symbol.owner()};
2557	CHECK(dtScope.kind() == Scope::Kind::DerivedType);
2558	bool isInaccessibleDeferred{false};
2559	const Symbol *overridden{
2560	FindOverriddenBinding(symbol, isInaccessibleDeferred)};
2561	if (symbol.attrs().test(Attr::DEFERRED)) {
2562	if (const Symbol *dtSymbol{dtScope.symbol()}) {
2563	if (!dtSymbol->attrs().test(Attr::ABSTRACT)) { // C733
2564	SayWithDeclaration(*dtSymbol,
2565	"Procedure bound to non-ABSTRACT derived type '%s' may not be DEFERRED"_err_en_US,
2566	dtSymbol->name());
2567	}
2568	}
2569	if (symbol.attrs().test(Attr::NON_OVERRIDABLE)) {
2570	messages_.Say(
2571	"Type-bound procedure '%s' may not be both DEFERRED and NON_OVERRIDABLE"_err_en_US,
2572	symbol.name());
2573	}
2574	if (overridden && !overridden->attrs().test(Attr::DEFERRED)) {
2575	SayWithDeclaration(*overridden,
2576	"Override of non-DEFERRED '%s' must not be DEFERRED"_err_en_US,
2577	symbol.name());
2578	}
2579	}
2580	if (binding.symbol().attrs().test(Attr::INTRINSIC) &&
2581	!context_.intrinsics().IsSpecificIntrinsicFunction(
2582	binding.symbol().name().ToString())) {
2583	messages_.Say(
2584	"Intrinsic procedure '%s' is not a specific intrinsic permitted for use in the definition of binding '%s'"_err_en_US,
2585	binding.symbol().name(), symbol.name());
2586	}
2587	if (overridden) {
2588	if (isInaccessibleDeferred) {
2589	evaluate::AttachDeclaration(
2590	Warn(common::LanguageFeature::InaccessibleDeferredOverride,
2591	symbol.name(),
2592	"Override of PRIVATE DEFERRED '%s' should appear in its module"_warn_en_US,
2593	symbol.name()),
2594	*overridden);
2595	}
2596	if (overridden->attrs().test(Attr::NON_OVERRIDABLE)) {
2597	SayWithDeclaration(*overridden,
2598	"Override of NON_OVERRIDABLE '%s' is not permitted"_err_en_US,
2599	symbol.name());
2600	}
2601	if (const auto *overriddenBinding{
2602	overridden->detailsIf<ProcBindingDetails>()}) {
2603	if (!IsPureProcedure(symbol) && IsPureProcedure(*overridden)) {
2604	SayWithDeclaration(*overridden,
2605	"An overridden pure type-bound procedure binding must also be pure"_err_en_US);
2606	return;
2607	}
2608	if (!IsElementalProcedure(binding.symbol()) &&
2609	IsElementalProcedure(*overridden)) {
2610	SayWithDeclaration(*overridden,
2611	"A type-bound procedure and its override must both, or neither, be ELEMENTAL"_err_en_US);
2612	return;
2613	}
2614	bool isNopass{symbol.attrs().test(Attr::NOPASS)};
2615	if (isNopass != overridden->attrs().test(Attr::NOPASS)) {
2616	SayWithDeclaration(*overridden,
2617	isNopass
2618	? "A NOPASS type-bound procedure may not override a passed-argument procedure"_err_en_US
2619	: "A passed-argument type-bound procedure may not override a NOPASS procedure"_err_en_US);
2620	} else {
2621	const auto *bindingChars{Characterize(symbol)};
2622	const auto *overriddenChars{Characterize(*overridden)};
2623	if (bindingChars && overriddenChars) {
2624	if (isNopass) {
2625	if (!bindingChars->CanOverride(*overriddenChars, std::nullopt)) {
2626	SayWithDeclaration(*overridden,
2627	"A NOPASS type-bound procedure and its override must have identical interfaces"_err_en_US);
2628	}
2629	} else if (!context_.HasError(binding.symbol())) {
2630	auto passIndex{bindingChars->FindPassIndex(binding.passName())};
2631	auto overriddenPassIndex{
2632	overriddenChars->FindPassIndex(overriddenBinding->passName())};
2633	if (passIndex && overriddenPassIndex) {
2634	if (*passIndex != *overriddenPassIndex) {
2635	SayWithDeclaration(*overridden,
2636	"A type-bound procedure and its override must use the same PASS argument"_err_en_US);
2637	} else if (!bindingChars->CanOverride(
2638	*overriddenChars, passIndex)) {
2639	SayWithDeclaration(*overridden,
2640	"A type-bound procedure and its override must have compatible interfaces"_err_en_US);
2641	}
2642	}
2643	}
2644	}
2645	}
2646	if (symbol.attrs().test(Attr::PRIVATE)) {
2647	if (FindModuleContaining(dtScope) ==
2648	FindModuleContaining(overridden->owner())) {
2649	// types declared in same madule
2650	if (!overridden->attrs().test(Attr::PRIVATE)) {
2651	SayWithDeclaration(*overridden,
2652	"A PRIVATE procedure may not override a PUBLIC procedure"_err_en_US);
2653	}
2654	} else { // types declared in distinct madules
2655	if (!CheckAccessibleSymbol(dtScope.parent(), *overridden)) {
2656	SayWithDeclaration(*overridden,
2657	"A PRIVATE procedure may not override an accessible procedure"_err_en_US);
2658	}
2659	}
2660	}
2661	} else {
2662	SayWithDeclaration(*overridden,
2663	"A type-bound procedure binding may not have the same name as a parent component"_err_en_US);
2664	}
2665	}
2666	CheckPassArg(symbol, &binding.symbol(), binding);
2667	}
2668
2669	void CheckHelper::Check(const Scope &scope) {
2670	scope_ = &scope;
2671	common::Restorer<const Symbol *> restorer{innermostSymbol_, innermostSymbol_};
2672	if (const Symbol *symbol{scope.symbol()}) {
2673	innermostSymbol_ = symbol;
2674	}
2675	if (scope.IsParameterizedDerivedTypeInstantiation()) {
2676	auto restorer{common::ScopedSet(scopeIsUninstantiatedPDT_, false)};
2677	auto restorer2{context_.foldingContext().messages().SetContext(
2678	scope.instantiationContext().get())};
2679	for (const auto &pair : scope) {
2680	CheckPointerInitialization(*pair.second);
2681	}
2682	} else {
2683	auto restorer{common::ScopedSet(
2684	scopeIsUninstantiatedPDT_, scope.IsParameterizedDerivedType())};
2685	for (const auto &set : scope.equivalenceSets()) {
2686	CheckEquivalenceSet(set);
2687	}
2688	for (const auto &pair : scope) {
2689	Check(*pair.second);
2690	}
2691	if (scope.IsSubmodule() && scope.symbol()) {
2692	// Submodule names are not in their parent's scopes
2693	Check(*scope.symbol());
2694	}
2695	for (const auto &pair : scope.commonBlocks()) {
2696	CheckCommonBlock(*pair.second);
2697	}
2698	int mainProgCnt{0};
2699	for (const Scope &child : scope.children()) {
2700	Check(child);
2701	// A program shall consist of exactly one main program (5.2.2).
2702	if (child.kind() == Scope::Kind::MainProgram) {
2703	++mainProgCnt;
2704	if (mainProgCnt > 1) {
2705	messages_.Say(child.sourceRange(),
2706	"A source file cannot contain more than one main program"_err_en_US);
2707	}
2708	}
2709	}
2710	if (scope.kind() == Scope::Kind::BlockData) {
2711	CheckBlockData(scope);
2712	}
2713	if (auto name{scope.GetName()}) {
2714	auto iter{scope.find(*name)};
2715	if (iter != scope.end()) {
2716	const char *kind{nullptr};
2717	switch (scope.kind()) {
2718	case Scope::Kind::Module:
2719	kind = scope.symbol()->get<ModuleDetails>().isSubmodule()
2720	? "submodule"
2721	: "module";
2722	break;
2723	case Scope::Kind::MainProgram:
2724	kind = "main program";
2725	break;
2726	case Scope::Kind::BlockData:
2727	kind = "BLOCK DATA subprogram";
2728	break;
2729	default:;
2730	}
2731	if (kind) {
2732	Warn(common::LanguageFeature::BenignNameClash, iter->second->name(),
2733	"Name '%s' declared in a %s should not have the same name as the %s"_port_en_US,
2734	*name, kind, kind);
2735	}
2736	}
2737	}
2738	CheckGenericOps(scope);
2739	}
2740	}
2741
2742	void CheckHelper::CheckEquivalenceSet(const EquivalenceSet &set) {
2743	auto iter{
2744	std::find_if(set.begin(), set.end(), [](const EquivalenceObject &object) {
2745	return FindCommonBlockContaining(object.symbol) != nullptr;
2746	})};
2747	if (iter != set.end()) {
2748	const Symbol &commonBlock{DEREF(FindCommonBlockContaining(iter->symbol))};
2749	for (auto &object : set) {
2750	if (&object != &*iter) {
2751	if (auto *details{object.symbol.detailsIf<ObjectEntityDetails>()}) {
2752	if (details->commonBlock()) {
2753	if (details->commonBlock() != &commonBlock) { // 8.10.3 paragraph 1
2754	if (auto *msg{messages_.Say(object.symbol.name(),
2755	"Two objects in the same EQUIVALENCE set may not be members of distinct COMMON blocks"_err_en_US)}) {
2756	msg->Attach(iter->symbol.name(),
2757	"Other object in EQUIVALENCE set"_en_US)
2758	.Attach(details->commonBlock()->name(),
2759	"COMMON block containing '%s'"_en_US,
2760	object.symbol.name())
2761	.Attach(commonBlock.name(),
2762	"COMMON block containing '%s'"_en_US,
2763	iter->symbol.name());
2764	}
2765	}
2766	} else {
2767	// Mark all symbols in the equivalence set with the same COMMON
2768	// block to prevent spurious error messages about initialization
2769	// in BLOCK DATA outside COMMON
2770	details->set_commonBlock(commonBlock);
2771	}
2772	}
2773	}
2774	}
2775	}
2776	for (const EquivalenceObject &object : set) {
2777	CheckEquivalenceObject(object);
2778	}
2779	}
2780
2781	static bool InCommonWithBind(const Symbol &symbol) {
2782	if (const auto *details{symbol.detailsIf<ObjectEntityDetails>()}) {
2783	const Symbol *commonBlock{details->commonBlock()};
2784	return commonBlock && commonBlock->attrs().test(Attr::BIND_C);
2785	} else {
2786	return false;
2787	}
2788	}
2789
2790	void CheckHelper::CheckEquivalenceObject(const EquivalenceObject &object) {
2791	parser::MessageFixedText msg;
2792	const Symbol &symbol{object.symbol};
2793	if (symbol.owner().IsDerivedType()) {
2794	msg =
2795	"Derived type component '%s' is not allowed in an equivalence set"_err_en_US;
2796	} else if (IsDummy(symbol)) {
2797	msg = "Dummy argument '%s' is not allowed in an equivalence set"_err_en_US;
2798	} else if (symbol.IsFuncResult()) {
2799	msg = "Function result '%s' is not allow in an equivalence set"_err_en_US;
2800	} else if (IsPointer(symbol)) {
2801	msg = "Pointer '%s' is not allowed in an equivalence set"_err_en_US;
2802	} else if (IsAllocatable(symbol)) {
2803	msg =
2804	"Allocatable variable '%s' is not allowed in an equivalence set"_err_en_US;
2805	} else if (symbol.Corank() > 0) {
2806	msg = "Coarray '%s' is not allowed in an equivalence set"_err_en_US;
2807	} else if (symbol.has<UseDetails>()) {
2808	msg =
2809	"Use-associated variable '%s' is not allowed in an equivalence set"_err_en_US;
2810	} else if (symbol.attrs().test(Attr::BIND_C)) {
2811	msg =
2812	"Variable '%s' with BIND attribute is not allowed in an equivalence set"_err_en_US;
2813	} else if (symbol.attrs().test(Attr::TARGET)) {
2814	msg =
2815	"Variable '%s' with TARGET attribute is not allowed in an equivalence set"_err_en_US;
2816	} else if (IsNamedConstant(symbol)) {
2817	msg = "Named constant '%s' is not allowed in an equivalence set"_err_en_US;
2818	} else if (InCommonWithBind(symbol)) {
2819	msg =
2820	"Variable '%s' in common block with BIND attribute is not allowed in an equivalence set"_err_en_US;
2821	} else if (!symbol.has<ObjectEntityDetails>()) {
2822	msg = "'%s' in equivalence set is not a data object"_err_en_US;
2823	} else if (const auto *type{symbol.GetType()}) {
2824	const auto *derived{type->AsDerived()};
2825	if (derived && !derived->IsVectorType()) {
2826	if (const auto *comp{
2827	FindUltimateComponent(*derived, IsAllocatableOrPointer)}) {
2828	msg = IsPointer(*comp)
2829	? "Derived type object '%s' with pointer ultimate component is not allowed in an equivalence set"_err_en_US
2830	: "Derived type object '%s' with allocatable ultimate component is not allowed in an equivalence set"_err_en_US;
2831	} else if (!derived->typeSymbol().get<DerivedTypeDetails>().sequence()) {
2832	msg =
2833	"Nonsequence derived type object '%s' is not allowed in an equivalence set"_err_en_US;
2834	}
2835	} else if (IsAutomatic(symbol)) {
2836	msg =
2837	"Automatic object '%s' is not allowed in an equivalence set"_err_en_US;
2838	} else if (symbol.test(Symbol::Flag::CrayPointee)) {
2839	messages_.Say(object.symbol.name(),
2840	"Cray pointee '%s' may not be a member of an EQUIVALENCE group"_err_en_US,
2841	object.symbol.name());
2842	}
2843	}
2844	if (!msg.text().empty()) {
2845	context_.Say(object.source, std::move(msg), symbol.name());
2846	}
2847	}
2848
2849	void CheckHelper::CheckBlockData(const Scope &scope) {
2850	// BLOCK DATA subprograms should contain only named common blocks.
2851	// C1415 presents a list of statements that shouldn't appear in
2852	// BLOCK DATA, but so long as the subprogram contains no executable
2853	// code and allocates no storage outside named COMMON, we're happy
2854	// (e.g., an ENUM is strictly not allowed).
2855	for (const auto &pair : scope) {
2856	const Symbol &symbol{*pair.second};
2857	if (!(symbol.has<CommonBlockDetails>() || symbol.has<UseDetails>() ||
2858	symbol.has<UseErrorDetails>() || symbol.has<DerivedTypeDetails>() ||
2859	symbol.has<SubprogramDetails>() ||
2860	symbol.has<ObjectEntityDetails>() ||
2861	(symbol.has<ProcEntityDetails>() &&
2862	!symbol.attrs().test(Attr::POINTER)))) {
2863	messages_.Say(symbol.name(),
2864	"'%s' may not appear in a BLOCK DATA subprogram"_err_en_US,
2865	symbol.name());
2866	}
2867	}
2868	}
2869
2870	// Check distinguishability of generic assignment and operators.
2871	// For these, generics and generic bindings must be considered together.
2872	void CheckHelper::CheckGenericOps(const Scope &scope) {
2873	DistinguishabilityHelper helper{context_};
2874	auto addSpecifics{[&](const Symbol &generic) {
2875	if (!IsAccessible(generic, scope)) {
2876	return;
2877	}
2878	const auto *details{generic.GetUltimate().detailsIf<GenericDetails>()};
2879	if (!details) {
2880	// Not a generic; ensure characteristics are defined if a function.
2881	auto restorer{messages_.SetLocation(generic.name())};
2882	if (IsFunction(generic) && !context_.HasError(generic)) {
2883	if (const Symbol *result{FindFunctionResult(generic)};
2884	result && !context_.HasError(*result)) {
2885	Characterize(generic);
2886	}
2887	}
2888	return;
2889	}
2890	GenericKind kind{details->kind()};
2891	if (!kind.IsAssignment() && !kind.IsOperator()) {
2892	return;
2893	}
2894	const SymbolVector &specifics{details->specificProcs()};
2895	const std::vector<SourceName> &bindingNames{details->bindingNames()};
2896	for (std::size_t i{0}; i < specifics.size(); ++i) {
2897	const Symbol &specific{*specifics[i]};
2898	auto restorer{messages_.SetLocation(bindingNames[i])};
2899	if (const Procedure *proc{Characterize(specific)}) {
2900	if (kind.IsAssignment()) {
2901	if (!CheckDefinedAssignment(specific, *proc)) {
2902	continue;
2903	}
2904	} else {
2905	if (!CheckDefinedOperator(generic.name(), kind, specific, *proc)) {
2906	continue;
2907	}
2908	}
2909	helper.Add(generic, kind, specific, *proc);
2910	}
2911	}
2912	}};
2913	for (const auto &pair : scope) {
2914	const Symbol &symbol{*pair.second};
2915	addSpecifics(symbol);
2916	const Symbol &ultimate{symbol.GetUltimate()};
2917	if (ultimate.has<DerivedTypeDetails>()) {
2918	if (const Scope *typeScope{ultimate.scope()}) {
2919	for (const auto &pair2 : *typeScope) {
2920	addSpecifics(*pair2.second);
2921	}
2922	}
2923	}
2924	}
2925	helper.Check(scope);
2926	}
2927
2928	static bool IsSubprogramDefinition(const Symbol &symbol) {
2929	const auto *subp{symbol.detailsIf<SubprogramDetails>()};
2930	return subp && !subp->isInterface() && symbol.scope() &&
2931	symbol.scope()->kind() == Scope::Kind::Subprogram;
2932	}
2933
2934	static bool IsExternalProcedureDefinition(const Symbol &symbol) {
2935	return IsBlockData(symbol) ||
2936	(IsSubprogramDefinition(symbol) &&
2937	(IsExternal(symbol) || symbol.GetBindName()));
2938	}
2939
2940	static std::optional<std::string> DefinesGlobalName(const Symbol &symbol) {
2941	if (const auto *module{symbol.detailsIf<ModuleDetails>()}) {
2942	if (!module->isSubmodule() && !symbol.owner().IsIntrinsicModules()) {
2943	return symbol.name().ToString();
2944	}
2945	} else if (IsBlockData(symbol)) {
2946	return symbol.name().ToString();
2947	} else {
2948	const std::string *bindC{symbol.GetBindName()};
2949	if (symbol.has<CommonBlockDetails>() ||
2950	IsExternalProcedureDefinition(symbol) ||
2951	(symbol.owner().IsGlobal() && IsExternal(symbol))) {
2952	return bindC ? *bindC : symbol.name().ToString();
2953	} else if (bindC &&
2954	(symbol.has<ObjectEntityDetails>() || IsModuleProcedure(symbol))) {
2955	return *bindC;
2956	}
2957	}
2958	return std::nullopt;
2959	}
2960
2961	static bool IsSameSymbolFromHermeticModule(
2962	const Symbol &symbol, const Symbol &other) {
2963	return symbol.name() == other.name() && symbol.owner().IsModule() &&
2964	other.owner().IsModule() && symbol.owner() != other.owner() &&
2965	symbol.owner().GetName() &&
2966	symbol.owner().GetName() == other.owner().GetName();
2967	}
2968
2969	// 19.2 p2
2970	void CheckHelper::CheckGlobalName(const Symbol &symbol) {
2971	if (auto global{DefinesGlobalName(symbol)}) {
2972	auto pair{globalNames_.emplace(std::move(*global), symbol)};
2973	if (!pair.second) {
2974	const Symbol &other{*pair.first->second};
2975	if (context_.HasError(symbol) || context_.HasError(other)) {
2976	// don't pile on
2977	} else if (symbol.has<CommonBlockDetails>() &&
2978	other.has<CommonBlockDetails>() && symbol.name() == other.name()) {
2979	// Two common blocks can have the same global name so long as
2980	// they're not in the same scope.
2981	} else if ((IsProcedure(symbol) || IsBlockData(symbol)) &&
2982	(IsProcedure(other) || IsBlockData(symbol: other)) &&
2983	(!IsExternalProcedureDefinition(symbol) ||
2984	!IsExternalProcedureDefinition(symbol: other))) {
2985	// both are procedures/BLOCK DATA, not both definitions
2986	} else if (IsSameSymbolFromHermeticModule(symbol, other)) {
2987	// Both symbols are the same thing.
2988	} else if (symbol.has<ModuleDetails>()) {
2989	Warn(common::LanguageFeature::BenignNameClash, symbol.name(),
2990	"Module '%s' conflicts with a global name"_port_en_US,
2991	pair.first->first);
2992	} else if (other.has<ModuleDetails>()) {
2993	Warn(common::LanguageFeature::BenignNameClash, symbol.name(),
2994	"Global name '%s' conflicts with a module"_port_en_US,
2995	pair.first->first);
2996	} else if (auto *msg{messages_.Say(symbol.name(),
2997	"Two entities have the same global name '%s'"_err_en_US,
2998	pair.first->first)}) {
2999	msg->Attach(other.name(), "Conflicting declaration"_en_US);
3000	context_.SetError(symbol);
3001	context_.SetError(other);
3002	}
3003	}
3004	}
3005	}
3006
3007	void CheckHelper::CheckProcedureAssemblyName(const Symbol &symbol) {
3008	if (!IsProcedure(symbol) || symbol != symbol.GetUltimate())
3009	return;
3010	const std::string *bindName{symbol.GetBindName()};
3011	const bool hasExplicitBindingLabel{
3012	symbol.GetIsExplicitBindName() && bindName};
3013	if (hasExplicitBindingLabel || IsExternal(symbol)) {
3014	const std::string assemblyName{hasExplicitBindingLabel
3015	? *bindName
3016	: common::GetExternalAssemblyName(
3017	symbol.name().ToString(), context_.underscoring())};
3018	auto pair{procedureAssemblyNames_.emplace(std::move(assemblyName), symbol)};
3019	if (!pair.second) {
3020	const Symbol &other{*pair.first->second};
3021	const bool otherHasExplicitBindingLabel{
3022	other.GetIsExplicitBindName() && other.GetBindName()};
3023	if (otherHasExplicitBindingLabel != hasExplicitBindingLabel) {
3024	// The BIND(C,NAME="...") binding label is the same as the name that
3025	// will be used in LLVM IR for an external procedure declared without
3026	// BIND(C) in the same file. While this is not forbidden by the
3027	// standard, this name collision would lead to a crash when producing
3028	// the IR.
3029	if (auto *msg{messages_.Say(symbol.name(),
3030	"%s procedure assembly name conflicts with %s procedure assembly name"_err_en_US,
3031	hasExplicitBindingLabel ? "BIND(C)" : "Non BIND(C)",
3032	hasExplicitBindingLabel ? "non BIND(C)" : "BIND(C)")}) {
3033	msg->Attach(other.name(), "Conflicting declaration"_en_US);
3034	}
3035	context_.SetError(symbol);
3036	context_.SetError(other);
3037	}
3038	// Otherwise, the global names also match and the conflict is analyzed
3039	// by CheckGlobalName.
3040	}
3041	}
3042	}
3043
3044	parser::Messages CheckHelper::WhyNotInteroperableDerivedType(
3045	const Symbol &symbol) {
3046	parser::Messages msgs;
3047	if (examinedByWhyNotInteroperable_.find(symbol) !=
3048	examinedByWhyNotInteroperable_.end()) {
3049	return msgs;
3050	}
3051	examinedByWhyNotInteroperable_.insert(symbol);
3052	if (const auto *derived{symbol.detailsIf<DerivedTypeDetails>()}) {
3053	if (derived->sequence()) { // C1801
3054	msgs.Say(symbol.name(),
3055	"An interoperable derived type cannot have the SEQUENCE attribute"_err_en_US);
3056	} else if (!derived->paramNameOrder().empty()) { // C1802
3057	msgs.Say(symbol.name(),
3058	"An interoperable derived type cannot have a type parameter"_err_en_US);
3059	} else if (const auto *parent{
3060	symbol.scope()->GetDerivedTypeParent()}) { // C1803
3061	if (symbol.attrs().test(Attr::BIND_C)) {
3062	msgs.Say(symbol.name(),
3063	"A derived type with the BIND attribute cannot be an extended derived type"_err_en_US);
3064	} else {
3065	bool interoperableParent{true};
3066	if (parent->symbol()) {
3067	auto bad{WhyNotInteroperableDerivedType(*parent->symbol())};
3068	if (bad.AnyFatalError()) {
3069	auto &msg{msgs.Say(symbol.name(),
3070	"The parent of an interoperable type is not interoperable"_err_en_US)};
3071	bad.AttachTo(msg, parser::Severity::None);
3072	interoperableParent = false;
3073	}
3074	}
3075	if (interoperableParent) {
3076	msgs.Say(symbol.name(),
3077	"An interoperable type should not be an extended derived type"_warn_en_US);
3078	}
3079	}
3080	}
3081	const Symbol *parentComponent{symbol.scope()
3082	? derived->GetParentComponent(*symbol.scope())
3083	: nullptr};
3084	for (const auto &pair : *symbol.scope()) {
3085	const Symbol &component{*pair.second};
3086	if (&component == parentComponent) {
3087	continue; // was checked above
3088	}
3089	if (IsProcedure(component)) { // C1804
3090	msgs.Say(component.name(),
3091	"An interoperable derived type cannot have a type bound procedure"_err_en_US);
3092	} else if (IsAllocatableOrPointer(component)) { // C1806
3093	msgs.Say(component.name(),
3094	"An interoperable derived type cannot have a pointer or allocatable component"_err_en_US);
3095	} else if (const auto *type{component.GetType()}) {
3096	if (const auto *derived{type->AsDerived()}) {
3097	auto bad{WhyNotInteroperableDerivedType(derived->typeSymbol())};
3098	if (bad.AnyFatalError()) {
3099	auto &msg{msgs.Say(component.name(),
3100	"Component '%s' of an interoperable derived type must have an interoperable type but does not"_err_en_US,
3101	component.name())};
3102	bad.AttachTo(msg, parser::Severity::None);
3103	} else if (!derived->typeSymbol().GetUltimate().attrs().test(
3104	Attr::BIND_C)) {
3105	auto &msg{
3106	msgs.Say(component.name(),
3107	"Derived type of component '%s' of an interoperable derived type should have the BIND attribute"_warn_en_US,
3108	component.name())
3109	.Attach(derived->typeSymbol().name(),
3110	"Non-BIND(C) component type"_en_US)};
3111	bad.AttachTo(msg, parser::Severity::None);
3112	} else {
3113	msgs.Annex(std::move(bad));
3114	}
3115	} else if (auto dyType{evaluate::DynamicType::From(*type)}; dyType &&
3116	!evaluate::IsInteroperableIntrinsicType(
3117	*dyType, &context_.languageFeatures())
3118	.value_or(false)) {
3119	if (type->category() == DeclTypeSpec::Logical) {
3120	if (context_.ShouldWarn(common::UsageWarning::LogicalVsCBool)) {
3121	msgs.Say(common::UsageWarning::LogicalVsCBool, component.name(),
3122	"A LOGICAL component of an interoperable type should have the interoperable KIND=C_BOOL"_port_en_US);
3123	}
3124	} else if (type->category() == DeclTypeSpec::Character && dyType &&
3125	dyType->kind() == 1) {
3126	if (context_.ShouldWarn(common::UsageWarning::BindCCharLength)) {
3127	msgs.Say(common::UsageWarning::BindCCharLength, component.name(),
3128	"A CHARACTER component of an interoperable type should have length 1"_port_en_US);
3129	}
3130	} else {
3131	msgs.Say(component.name(),
3132	"Each component of an interoperable derived type must have an interoperable type"_err_en_US);
3133	}
3134	}
3135	}
3136	if (auto extents{
3137	evaluate::GetConstantExtents(foldingContext_, &component)};
3138	extents && evaluate::GetSize(*extents) == 0) {
3139	msgs.Say(component.name(),
3140	"An array component of an interoperable type must have at least one element"_err_en_US);
3141	}
3142	}
3143	if (derived->componentNames().empty()) { // F'2023 C1805
3144	if (context_.ShouldWarn(common::LanguageFeature::EmptyBindCDerivedType)) {
3145	msgs.Say(common::LanguageFeature::EmptyBindCDerivedType, symbol.name(),
3146	"A derived type with the BIND attribute should not be empty"_warn_en_US);
3147	}
3148	}
3149	}
3150	if (msgs.AnyFatalError()) {
3151	examinedByWhyNotInteroperable_.erase(symbol);
3152	}
3153	return msgs;
3154	}
3155
3156	parser::Messages CheckHelper::WhyNotInteroperableObject(
3157	const Symbol &symbol, bool allowNonInteroperableType) {
3158	parser::Messages msgs;
3159	if (examinedByWhyNotInteroperable_.find(symbol) !=
3160	examinedByWhyNotInteroperable_.end()) {
3161	return msgs;
3162	}
3163	bool isExplicitBindC{symbol.attrs().test(Attr::BIND_C)};
3164	examinedByWhyNotInteroperable_.insert(symbol);
3165	CHECK(symbol.has<ObjectEntityDetails>());
3166	if (isExplicitBindC && !symbol.owner().IsModule()) {
3167	msgs.Say(symbol.name(),
3168	"A variable with BIND(C) attribute may only appear in the specification part of a module"_err_en_US);
3169	}
3170	auto shape{evaluate::GetShape(foldingContext_, symbol)};
3171	if (shape) {
3172	if (evaluate::GetRank(*shape) == 0) { // 18.3.4
3173	if (IsAllocatableOrPointer(symbol) && !IsDummy(symbol)) {
3174	msgs.Say(symbol.name(),
3175	"A scalar interoperable variable may not be ALLOCATABLE or POINTER"_err_en_US);
3176	}
3177	} else if (auto extents{
3178	evaluate::AsConstantExtents(foldingContext_, *shape)}) {
3179	if (evaluate::GetSize(*extents) == 0) {
3180	msgs.Say(symbol.name(),
3181	"Interoperable array must have at least one element"_err_en_US);
3182	}
3183	} else if (!evaluate::IsExplicitShape(symbol) &&
3184	!IsAssumedSizeArray(symbol) &&
3185	!(IsDummy(symbol) && !symbol.attrs().test(Attr::VALUE))) {
3186	msgs.Say(symbol.name(),
3187	"BIND(C) array must have explicit shape or be assumed-size unless a dummy argument without the VALUE attribute"_err_en_US);
3188	}
3189	}
3190	if (const auto *type{symbol.GetType()}) {
3191	const auto *derived{type->AsDerived()};
3192	if (derived && !derived->typeSymbol().attrs().test(Attr::BIND_C)) {
3193	if (allowNonInteroperableType) { // portability warning only
3194	evaluate::AttachDeclaration(
3195	context_.Warn(common::UsageWarning::Portability, symbol.name(),
3196	"The derived type of this interoperable object should be BIND(C)"_port_en_US),
3197	derived->typeSymbol());
3198	} else if (!context_.IsEnabled(
3199	common::LanguageFeature::NonBindCInteroperability)) {
3200	msgs.Say(symbol.name(),
3201	"The derived type of an interoperable object must be BIND(C)"_err_en_US)
3202	.Attach(derived->typeSymbol().name(), "Non-BIND(C) type"_en_US);
3203	} else if (auto bad{
3204	WhyNotInteroperableDerivedType(derived->typeSymbol())};
3205	bad.AnyFatalError()) {
3206	bad.AttachTo(
3207	msgs.Say(symbol.name(),
3208	"The derived type of an interoperable object must be interoperable, but is not"_err_en_US)
3209	.Attach(derived->typeSymbol().name(),
3210	"Non-interoperable type"_en_US),
3211	parser::Severity::None);
3212	} else {
3213	msgs.Say(symbol.name(),
3214	"The derived type of an interoperable object should be BIND(C)"_warn_en_US)
3215	.Attach(derived->typeSymbol().name(), "Non-BIND(C) type"_en_US);
3216	}
3217	}
3218	if (type->IsAssumedType()) { // ok
3219	} else if (IsAssumedLengthCharacter(symbol) &&
3220	!IsAllocatableOrPointer(symbol)) {
3221	} else if (IsAllocatableOrPointer(symbol) &&
3222	type->category() == DeclTypeSpec::Character &&
3223	type->characterTypeSpec().length().isDeferred()) {
3224	// ok; F'2023 18.3.7 p2(6)
3225	} else if (derived) { // type has been checked
3226	} else if (auto dyType{evaluate::DynamicType::From(*type)}; dyType &&
3227	evaluate::IsInteroperableIntrinsicType(
3228	*dyType, InModuleFile() ? nullptr : &context_.languageFeatures())
3229	.value_or(false)) {
3230	// F'2023 18.3.7 p2(4,5)
3231	// N.B. Language features are not passed to IsInteroperableIntrinsicType
3232	// when processing a module file, since the module file might have been
3233	// compiled with CUDA while the client is not.
3234	} else if (type->category() == DeclTypeSpec::Logical) {
3235	if (context_.ShouldWarn(common::UsageWarning::LogicalVsCBool)) {
3236	if (IsDummy(symbol)) {
3237	msgs.Say(common::UsageWarning::LogicalVsCBool, symbol.name(),
3238	"A BIND(C) LOGICAL dummy argument should have the interoperable KIND=C_BOOL"_port_en_US);
3239	} else {
3240	msgs.Say(common::UsageWarning::LogicalVsCBool, symbol.name(),
3241	"A BIND(C) LOGICAL object should have the interoperable KIND=C_BOOL"_port_en_US);
3242	}
3243	}
3244	} else if (symbol.attrs().test(Attr::VALUE)) {
3245	msgs.Say(symbol.name(),
3246	"A BIND(C) VALUE dummy argument must have an interoperable type"_err_en_US);
3247	} else {
3248	msgs.Say(symbol.name(),
3249	"A BIND(C) object must have an interoperable type"_err_en_US);
3250	}
3251	}
3252	if (IsOptional(symbol) && !symbol.attrs().test(Attr::VALUE)) {
3253	msgs.Say(symbol.name(),
3254	"An interoperable procedure with an OPTIONAL dummy argument might not be portable"_port_en_US);
3255	}
3256	if (IsDescriptor(symbol) && IsPointer(symbol) &&
3257	symbol.attrs().test(Attr::CONTIGUOUS)) {
3258	msgs.Say(symbol.name(),
3259	"An interoperable pointer must not be CONTIGUOUS"_err_en_US);
3260	}
3261	if (msgs.AnyFatalError()) {
3262	examinedByWhyNotInteroperable_.erase(symbol);
3263	}
3264	return msgs;
3265	}
3266
3267	parser::Messages CheckHelper::WhyNotInteroperableFunctionResult(
3268	const Symbol &symbol) {
3269	parser::Messages msgs;
3270	if (IsPointer(symbol) || IsAllocatable(symbol)) {
3271	msgs.Say(symbol.name(),
3272	"Interoperable function result may not have ALLOCATABLE or POINTER attribute"_err_en_US);
3273	}
3274	if (const DeclTypeSpec * type{symbol.GetType()};
3275	type && type->category() == DeclTypeSpec::Character) {
3276	bool isConstOne{false}; // 18.3.1(1)
3277	if (const auto &len{type->characterTypeSpec().length().GetExplicit()}) {
3278	if (auto constLen{evaluate::ToInt64(*len)}) {
3279	isConstOne = constLen == 1;
3280	}
3281	}
3282	if (!isConstOne) {
3283	msgs.Say(symbol.name(),
3284	"Interoperable character function result must have length one"_err_en_US);
3285	}
3286	}
3287	if (symbol.Rank() > 0) {
3288	msgs.Say(symbol.name(),
3289	"Interoperable function result must be scalar"_err_en_US);
3290	}
3291	return msgs;
3292	}
3293
3294	parser::Messages CheckHelper::WhyNotInteroperableProcedure(
3295	const Symbol &symbol, bool isError) {
3296	parser::Messages msgs;
3297	if (examinedByWhyNotInteroperable_.find(symbol) !=
3298	examinedByWhyNotInteroperable_.end()) {
3299	return msgs;
3300	}
3301	isError |= symbol.attrs().test(Attr::BIND_C);
3302	examinedByWhyNotInteroperable_.insert(symbol);
3303	if (const auto *proc{symbol.detailsIf<ProcEntityDetails>()}) {
3304	if (isError) {
3305	if (!proc->procInterface() ||
3306	!proc->procInterface()->attrs().test(Attr::BIND_C)) {
3307	msgs.Say(symbol.name(),
3308	"An interface name with the BIND attribute must appear if the BIND attribute appears in a procedure declaration"_err_en_US);
3309	}
3310	} else if (!proc->procInterface()) {
3311	msgs.Say(symbol.name(),
3312	"An interoperable procedure should have an interface"_port_en_US);
3313	} else if (!proc->procInterface()->attrs().test(Attr::BIND_C)) {
3314	auto bad{WhyNotInteroperableProcedure(
3315	*proc->procInterface(), /*isError=*/false)};
3316	if (bad.AnyFatalError()) {
3317	bad.AttachTo(msgs.Say(symbol.name(),
3318	"An interoperable procedure must have an interoperable interface"_err_en_US));
3319	} else {
3320	msgs.Say(symbol.name(),
3321	"An interoperable procedure should have an interface with the BIND attribute"_warn_en_US);
3322	}
3323	}
3324	} else if (const auto *subp{symbol.detailsIf<SubprogramDetails>()}) {
3325	for (const Symbol *dummy : subp->dummyArgs()) {
3326	if (dummy) {
3327	parser::Messages dummyMsgs;
3328	if (dummy->has<ProcEntityDetails>() ||
3329	dummy->has<SubprogramDetails>()) {
3330	dummyMsgs = WhyNotInteroperableProcedure(*dummy, /*isError=*/false);
3331	if (dummyMsgs.empty() && !dummy->attrs().test(Attr::BIND_C)) {
3332	dummyMsgs.Say(dummy->name(),
3333	"A dummy procedure of an interoperable procedure should be BIND(C)"_warn_en_US);
3334	}
3335	} else if (dummy->has<ObjectEntityDetails>()) {
3336	// Emit only optional portability warnings for non-interoperable
3337	// types when the dummy argument is not VALUE and will be implemented
3338	// on the C side by either a cdesc_t * or a void *. F'2023 18.3.7 (5)
3339	bool allowNonInteroperableType{!dummy->attrs().test(Attr::VALUE) &&
3340	(IsDescriptor(*dummy) || IsAssumedType(*dummy))};
3341	dummyMsgs =
3342	WhyNotInteroperableObject(*dummy, allowNonInteroperableType);
3343	} else {
3344	CheckBindC(*dummy);
3345	}
3346	msgs.Annex(std::move(dummyMsgs));
3347	} else {
3348	msgs.Say(symbol.name(),
3349	"A subprogram interface with the BIND attribute may not have an alternate return argument"_err_en_US);
3350	}
3351	}
3352	if (subp->isFunction()) {
3353	if (subp->result().has<ObjectEntityDetails>()) {
3354	msgs.Annex(WhyNotInteroperableFunctionResult(subp->result()));
3355	} else {
3356	msgs.Say(subp->result().name(),
3357	"The result of an interoperable function must be a data object"_err_en_US);
3358	}
3359	}
3360	}
3361	if (msgs.AnyFatalError()) {
3362	examinedByWhyNotInteroperable_.erase(symbol);
3363	}
3364	return msgs;
3365	}
3366
3367	void CheckHelper::CheckBindC(const Symbol &symbol) {
3368	bool isExplicitBindC{symbol.attrs().test(Attr::BIND_C)};
3369	if (isExplicitBindC) {
3370	CheckConflicting(symbol, Attr::BIND_C, Attr::ELEMENTAL);
3371	CheckConflicting(symbol, Attr::BIND_C, Attr::INTRINSIC);
3372	CheckConflicting(symbol, Attr::BIND_C, Attr::PARAMETER);
3373	} else {
3374	// symbol must be interoperable (e.g., dummy argument of interoperable
3375	// procedure interface) but is not itself BIND(C).
3376	}
3377	parser::Messages whyNot;
3378	if (const std::string * bindName{symbol.GetBindName()};
3379	bindName) { // has a binding name
3380	if (!bindName->empty()) {
3381	bool ok{bindName->front() == '_' || parser::IsLetter(bindName->front())};
3382	for (char ch : *bindName) {
3383	ok &= ch == '_' || parser::IsLetter(ch) || parser::IsDecimalDigit(ch);
3384	}
3385	if (!ok) {
3386	messages_.Say(symbol.name(),
3387	"Symbol has a BIND(C) name that is not a valid C language identifier"_err_en_US);
3388	context_.SetError(symbol);
3389	}
3390	}
3391	}
3392	if (symbol.GetIsExplicitBindName()) { // BIND(C,NAME=...); C1552, C1529
3393	auto defClass{ClassifyProcedure(symbol)};
3394	if (IsProcedurePointer(symbol)) {
3395	messages_.Say(symbol.name(),
3396	"A procedure pointer may not have a BIND attribute with a name"_err_en_US);
3397	context_.SetError(symbol);
3398	} else if (defClass == ProcedureDefinitionClass::None ||
3399	IsExternal(symbol)) {
3400	} else if (symbol.attrs().test(Attr::ABSTRACT)) {
3401	messages_.Say(symbol.name(),
3402	"An ABSTRACT interface may not have a BIND attribute with a name"_err_en_US);
3403	context_.SetError(symbol);
3404	} else if (defClass == ProcedureDefinitionClass::Internal ||
3405	defClass == ProcedureDefinitionClass::Dummy) {
3406	messages_.Say(symbol.name(),
3407	"An internal or dummy procedure may not have a BIND(C,NAME=) binding label"_err_en_US);
3408	context_.SetError(symbol);
3409	}
3410	}
3411	if (symbol.has<ObjectEntityDetails>()) {
3412	whyNot = WhyNotInteroperableObject(symbol);
3413	} else if (symbol.has<ProcEntityDetails>() ||
3414	symbol.has<SubprogramDetails>()) {
3415	whyNot = WhyNotInteroperableProcedure(symbol, /*isError=*/isExplicitBindC);
3416	} else if (symbol.has<DerivedTypeDetails>()) {
3417	whyNot = WhyNotInteroperableDerivedType(symbol);
3418	}
3419	if (!whyNot.empty()) {
3420	bool anyFatal{whyNot.AnyFatalError()};
3421	if (anyFatal ||
3422	(!InModuleFile() &&
3423	context_.ShouldWarn(
3424	common::LanguageFeature::NonBindCInteroperability))) {
3425	context_.messages().Annex(std::move(whyNot));
3426	}
3427	if (anyFatal) {
3428	context_.SetError(symbol);
3429	}
3430	}
3431	}
3432
3433	bool CheckHelper::CheckDioDummyIsData(
3434	const Symbol &subp, const Symbol *arg, std::size_t position) {
3435	if (arg && arg->detailsIf<ObjectEntityDetails>()) {
3436	if (evaluate::IsAssumedRank(*arg)) {
3437	messages_.Say(arg->name(),
3438	"Dummy argument '%s' may not be assumed-rank"_err_en_US, arg->name());
3439	return false;
3440	} else {
3441	return true;
3442	}
3443	} else {
3444	if (arg) {
3445	messages_.Say(arg->name(),
3446	"Dummy argument '%s' must be a data object"_err_en_US, arg->name());
3447	} else {
3448	messages_.Say(subp.name(),
3449	"Dummy argument %d of '%s' must be a data object"_err_en_US, position,
3450	subp.name());
3451	}
3452	return false;
3453	}
3454	}
3455
3456	void CheckHelper::CheckAlreadySeenDefinedIo(const DerivedTypeSpec &derivedType,
3457	common::DefinedIo ioKind, const Symbol &proc, const Symbol &generic) {
3458	// Check for conflict between non-type-bound defined I/O and type-bound
3459	// generics. It's okay to have two or more distinct defined I/O procedures for
3460	// the same type if they're coming from distinct non-type-bound interfaces.
3461	// (The non-type-bound interfaces would have been merged into a single generic
3462	// -- with errors where indistinguishable -- when both were visible from the
3463	// same scope.)
3464	if (generic.owner().IsDerivedType()) {
3465	return;
3466	}
3467	if (const Scope * dtScope{derivedType.scope()}) {
3468	if (auto iter{dtScope->find(generic.name())}; iter != dtScope->end() &&
3469	IsAccessible(*iter->second, generic.owner())) {
3470	for (auto specRef : iter->second->get<GenericDetails>().specificProcs()) {
3471	const Symbol *specific{&specRef->get<ProcBindingDetails>().symbol()};
3472	if (specific == &proc) {
3473	continue; // unambiguous, accept
3474	}
3475	if (const auto *peDetails{specific->detailsIf<ProcEntityDetails>()}) {
3476	specific = peDetails->procInterface();
3477	if (!specific) {
3478	continue;
3479	}
3480	}
3481	if (const auto *specDT{GetDtvArgDerivedType(*specific)};
3482	specDT && evaluate::AreSameDerivedType(derivedType, *specDT)) {
3483	SayWithDeclaration(*specRef, proc.name(),
3484	"Derived type '%s' has conflicting type-bound input/output procedure '%s'"_err_en_US,
3485	derivedType.name(), GenericKind::AsFortran(ioKind));
3486	return;
3487	}
3488	}
3489	}
3490	}
3491	}
3492
3493	void CheckHelper::CheckDioDummyIsDerived(const Symbol &proc, const Symbol &arg,
3494	common::DefinedIo ioKind, const Symbol &generic) {
3495	if (const DeclTypeSpec *type{arg.GetType()}) {
3496	if (const DerivedTypeSpec *derivedType{type->AsDerived()}) {
3497	CheckAlreadySeenDefinedIo(*derivedType, ioKind, proc, generic);
3498	bool isPolymorphic{type->IsPolymorphic()};
3499	if (isPolymorphic != IsExtensibleType(derivedType)) {
3500	messages_.Say(arg.name(),
3501	"Dummy argument '%s' of a defined input/output procedure must be %s when the derived type is %s"_err_en_US,
3502	arg.name(), isPolymorphic ? "TYPE()" : "CLASS()",
3503	isPolymorphic ? "not extensible" : "extensible");
3504	}
3505	} else {
3506	messages_.Say(arg.name(),
3507	"Dummy argument '%s' of a defined input/output procedure must have a derived type"_err_en_US,
3508	arg.name());
3509	}
3510	}
3511	}
3512
3513	void CheckHelper::CheckDioDummyIsDefaultInteger(
3514	const Symbol &subp, const Symbol &arg) {
3515	if (const DeclTypeSpec *type{arg.GetType()};
3516	type && type->IsNumeric(TypeCategory::Integer)) {
3517	if (const auto kind{evaluate::ToInt64(type->numericTypeSpec().kind())};
3518	kind && *kind == context_.GetDefaultKind(TypeCategory::Integer)) {
3519	return;
3520	}
3521	}
3522	messages_.Say(arg.name(),
3523	"Dummy argument '%s' of a defined input/output procedure must be an INTEGER of default KIND"_err_en_US,
3524	arg.name());
3525	}
3526
3527	void CheckHelper::CheckDioDummyIsScalar(const Symbol &subp, const Symbol &arg) {
3528	if (arg.Rank() > 0) {
3529	messages_.Say(arg.name(),
3530	"Dummy argument '%s' of a defined input/output procedure must be a scalar"_err_en_US,
3531	arg.name());
3532	}
3533	}
3534
3535	void CheckHelper::CheckDioDtvArg(const Symbol &proc, const Symbol &subp,
3536	const Symbol *arg, common::DefinedIo ioKind, const Symbol &generic) {
3537	// Dtv argument looks like: dtv-type-spec, INTENT(INOUT) :: dtv
3538	if (CheckDioDummyIsData(subp, arg, position: 0)) {
3539	CheckDioDummyIsDerived(proc, *arg, ioKind, generic);
3540	CheckDioDummyAttrs(subp, *arg,
3541	ioKind == common::DefinedIo::ReadFormatted ||
3542	ioKind == common::DefinedIo::ReadUnformatted
3543	? Attr::INTENT_INOUT
3544	: Attr::INTENT_IN);
3545	}
3546	}
3547
3548	// If an explicit INTRINSIC name is a function, so must all the specifics be,
3549	// and similarly for subroutines
3550	void CheckHelper::CheckGenericVsIntrinsic(
3551	const Symbol &symbol, const GenericDetails &generic) {
3552	if (symbol.attrs().test(Attr::INTRINSIC)) {
3553	const evaluate::IntrinsicProcTable &table{
3554	context_.foldingContext().intrinsics()};
3555	bool isSubroutine{table.IsIntrinsicSubroutine(symbol.name().ToString())};
3556	if (isSubroutine || table.IsIntrinsicFunction(symbol.name().ToString())) {
3557	for (const SymbolRef &ref : generic.specificProcs()) {
3558	const Symbol &ultimate{ref->GetUltimate()};
3559	bool specificFunc{ultimate.test(Symbol::Flag::Function)};
3560	bool specificSubr{ultimate.test(Symbol::Flag::Subroutine)};
3561	if (!specificFunc && !specificSubr) {
3562	if (const auto *proc{ultimate.detailsIf<SubprogramDetails>()}) {
3563	if (proc->isFunction()) {
3564	specificFunc = true;
3565	} else {
3566	specificSubr = true;
3567	}
3568	}
3569	}
3570	if ((specificFunc || specificSubr) &&
3571	isSubroutine != specificSubr) { // C848
3572	messages_.Say(symbol.name(),
3573	"Generic interface '%s' with explicit intrinsic %s of the same name may not have specific procedure '%s' that is a %s"_err_en_US,
3574	symbol.name(), isSubroutine ? "subroutine" : "function",
3575	ref->name(), isSubroutine ? "function" : "subroutine");
3576	}
3577	}
3578	}
3579	}
3580	}
3581
3582	void CheckHelper::CheckDefaultIntegerArg(
3583	const Symbol &subp, const Symbol *arg, Attr intent) {
3584	// Argument looks like: INTEGER, INTENT(intent) :: arg
3585	if (CheckDioDummyIsData(subp, arg, position: 1)) {
3586	CheckDioDummyIsDefaultInteger(subp, arg: *arg);
3587	CheckDioDummyIsScalar(subp, arg: *arg);
3588	CheckDioDummyAttrs(subp, *arg, intent);
3589	}
3590	}
3591
3592	void CheckHelper::CheckDioAssumedLenCharacterArg(const Symbol &subp,
3593	const Symbol *arg, std::size_t argPosition, Attr intent) {
3594	// Argument looks like: CHARACTER (LEN=*), INTENT(intent) :: (iotype OR iomsg)
3595	if (CheckDioDummyIsData(subp, arg, position: argPosition)) {
3596	CheckDioDummyAttrs(subp, *arg, intent);
3597	const DeclTypeSpec *type{arg ? arg->GetType() : nullptr};
3598	const IntrinsicTypeSpec *intrinsic{type ? type->AsIntrinsic() : nullptr};
3599	const auto kind{
3600	intrinsic ? evaluate::ToInt64(intrinsic->kind()) : std::nullopt};
3601	if (!IsAssumedLengthCharacter(*arg) ||
3602	(!kind ||
3603	*kind !=
3604	context_.defaultKinds().GetDefaultKind(
3605	TypeCategory::Character))) {
3606	messages_.Say(arg->name(),
3607	"Dummy argument '%s' of a defined input/output procedure must be assumed-length CHARACTER of default kind"_err_en_US,
3608	arg->name());
3609	}
3610	}
3611	}
3612
3613	void CheckHelper::CheckDioVlistArg(
3614	const Symbol &subp, const Symbol *arg, std::size_t argPosition) {
3615	// Vlist argument looks like: INTEGER, INTENT(IN) :: v_list(:)
3616	if (CheckDioDummyIsData(subp, arg, position: argPosition)) {
3617	CheckDioDummyIsDefaultInteger(subp, arg: *arg);
3618	CheckDioDummyAttrs(subp, *arg, Attr::INTENT_IN);
3619	const auto *objectDetails{arg->detailsIf<ObjectEntityDetails>()};
3620	if (!objectDetails || !objectDetails->shape().CanBeAssumedShape() ||
3621	objectDetails->shape().Rank() != 1) {
3622	messages_.Say(arg->name(),
3623	"Dummy argument '%s' of a defined input/output procedure must be assumed shape vector"_err_en_US,
3624	arg->name());
3625	}
3626	}
3627	}
3628
3629	void CheckHelper::CheckDioArgCount(
3630	const Symbol &subp, common::DefinedIo ioKind, std::size_t argCount) {
3631	const std::size_t requiredArgCount{
3632	(std::size_t)(ioKind == common::DefinedIo::ReadFormatted ||
3633	ioKind == common::DefinedIo::WriteFormatted
3634	? 6
3635	: 4)};
3636	if (argCount != requiredArgCount) {
3637	SayWithDeclaration(subp,
3638	"Defined input/output procedure '%s' must have %d dummy arguments rather than %d"_err_en_US,
3639	subp.name(), requiredArgCount, argCount);
3640	context_.SetError(subp);
3641	}
3642	}
3643
3644	void CheckHelper::CheckDioDummyAttrs(
3645	const Symbol &subp, const Symbol &arg, Attr goodIntent) {
3646	// Defined I/O procedures can't have attributes other than INTENT
3647	Attrs attrs{arg.attrs()};
3648	if (!attrs.test(goodIntent)) {
3649	messages_.Say(arg.name(),
3650	"Dummy argument '%s' of a defined input/output procedure must have intent '%s'"_err_en_US,
3651	arg.name(), AttrToString(goodIntent));
3652	}
3653	attrs = attrs - Attr::INTENT_IN - Attr::INTENT_OUT - Attr::INTENT_INOUT;
3654	if (!attrs.empty()) {
3655	messages_.Say(arg.name(),
3656	"Dummy argument '%s' of a defined input/output procedure may not have any attributes"_err_en_US,
3657	arg.name());
3658	}
3659	}
3660
3661	// Enforce semantics for defined input/output procedures (12.6.4.8.2) and C777
3662	void CheckHelper::CheckDefinedIoProc(const Symbol &symbol,
3663	const GenericDetails &details, common::DefinedIo ioKind) {
3664	for (auto ref : details.specificProcs()) {
3665	const Symbol &ultimate{ref->GetUltimate()};
3666	const auto *binding{ultimate.detailsIf<ProcBindingDetails>()};
3667	if (ultimate.attrs().test(Attr::NOPASS)) { // C774
3668	messages_.Say(
3669	"Defined input/output procedure '%s' may not have NOPASS attribute"_err_en_US,
3670	ultimate.name());
3671	context_.SetError(ultimate);
3672	}
3673	const Symbol *specificProc{binding ? &binding->symbol() : &ultimate};
3674	const Symbol *specificSubp{specificProc};
3675	if (const auto *peDetails{specificSubp->detailsIf<ProcEntityDetails>()}) {
3676	specificSubp = peDetails->procInterface();
3677	if (!specificSubp) {
3678	continue;
3679	}
3680	}
3681	if (const auto *subpDetails{specificSubp->detailsIf<SubprogramDetails>()}) {
3682	const std::vector<Symbol *> &dummyArgs{subpDetails->dummyArgs()};
3683	CheckDioArgCount(*specificSubp, ioKind, dummyArgs.size());
3684	int argCount{0};
3685	for (auto *arg : dummyArgs) {
3686	if (arg && arg->Corank() > 0) {
3687	evaluate::AttachDeclaration(
3688	messages_.Say(arg->name(),
3689	"Dummy argument '%s' of defined input/output procedure '%s' may not be a coarray"_err_en_US,
3690	arg->name(), ultimate.name()),
3691	*arg);
3692	}
3693	switch (argCount++) {
3694	case 0:
3695	// dtv-type-spec, INTENT(INOUT) :: dtv
3696	CheckDioDtvArg(*specificProc, *specificSubp, arg, ioKind, symbol);
3697	break;
3698	case 1:
3699	// INTEGER, INTENT(IN) :: unit
3700	CheckDefaultIntegerArg(*specificSubp, arg, Attr::INTENT_IN);
3701	break;
3702	case 2:
3703	if (ioKind == common::DefinedIo::ReadFormatted ||
3704	ioKind == common::DefinedIo::WriteFormatted) {
3705	// CHARACTER (LEN=*), INTENT(IN) :: iotype
3706	CheckDioAssumedLenCharacterArg(
3707	*specificSubp, arg, argCount, Attr::INTENT_IN);
3708	} else {
3709	// INTEGER, INTENT(OUT) :: iostat
3710	CheckDefaultIntegerArg(*specificSubp, arg, Attr::INTENT_OUT);
3711	}
3712	break;
3713	case 3:
3714	if (ioKind == common::DefinedIo::ReadFormatted ||
3715	ioKind == common::DefinedIo::WriteFormatted) {
3716	// INTEGER, INTENT(IN) :: v_list(:)
3717	CheckDioVlistArg(*specificSubp, arg, argCount);
3718	} else {
3719	// CHARACTER (LEN=*), INTENT(INOUT) :: iomsg
3720	CheckDioAssumedLenCharacterArg(
3721	*specificSubp, arg, argCount, Attr::INTENT_INOUT);
3722	}
3723	break;
3724	case 4:
3725	// INTEGER, INTENT(OUT) :: iostat
3726	CheckDefaultIntegerArg(*specificSubp, arg, Attr::INTENT_OUT);
3727	break;
3728	case 5:
3729	// CHARACTER (LEN=*), INTENT(INOUT) :: iomsg
3730	CheckDioAssumedLenCharacterArg(
3731	*specificSubp, arg, argCount, Attr::INTENT_INOUT);
3732	break;
3733	default:;
3734	}
3735	}
3736	}
3737	}
3738	}
3739
3740	void CheckHelper::CheckSymbolType(const Symbol &symbol) {
3741	const Symbol *result{FindFunctionResult(symbol)};
3742	const Symbol &relevant{result ? *result : symbol};
3743	if (IsAllocatable(relevant)) { // always ok
3744	} else if (IsProcedurePointer(symbol) && result && IsPointer(*result)) {
3745	// procedure pointer returning allocatable or pointer: ok
3746	} else if (IsPointer(relevant) && !IsProcedure(relevant)) {
3747	// object pointers are always ok
3748	} else if (auto dyType{evaluate::DynamicType::From(relevant)}) {
3749	if (dyType->IsPolymorphic() && !dyType->IsAssumedType() &&
3750	!(IsDummy(symbol) && !IsProcedure(relevant))) { // C708
3751	messages_.Say(
3752	"CLASS entity '%s' must be a dummy argument, allocatable, or object pointer"_err_en_US,
3753	symbol.name());
3754	}
3755	if (dyType->HasDeferredTypeParameter()) { // C702
3756	messages_.Say(
3757	"'%s' has a type %s with a deferred type parameter but is neither an allocatable nor an object pointer"_err_en_US,
3758	symbol.name(), dyType->AsFortran());
3759	}
3760	if (!symbol.has<ObjectEntityDetails>()) {
3761	if (const DerivedTypeSpec *
3762	derived{evaluate::GetDerivedTypeSpec(*dyType)}) {
3763	if (IsEventTypeOrLockType(derived)) {
3764	messages_.Say(
3765	"Entity '%s' with EVENT_TYPE or LOCK_TYPE must be an object"_err_en_US,
3766	symbol.name());
3767	} else if (auto iter{FindEventOrLockPotentialComponent(*derived)}) {
3768	messages_.Say(
3769	"Entity '%s' with EVENT_TYPE or LOCK_TYPE potential subobject component '%s' must be an object"_err_en_US,
3770	symbol.name(), iter.BuildResultDesignatorName());
3771	}
3772	}
3773	}
3774	}
3775	}
3776
3777	void CheckHelper::CheckModuleProcedureDef(const Symbol &symbol) {
3778	auto procClass{ClassifyProcedure(symbol)};
3779	if (const auto *subprogram{symbol.detailsIf<SubprogramDetails>()};
3780	subprogram &&
3781	(procClass == ProcedureDefinitionClass::Module &&
3782	symbol.attrs().test(Attr::MODULE)) &&
3783	!subprogram->bindName() && !subprogram->isInterface()) {
3784	const Symbol &interface {
3785	subprogram->moduleInterface() ? *subprogram->moduleInterface() : symbol
3786	};
3787	if (const Symbol *
3788	module{interface.owner().kind() == Scope::Kind::Module
3789	? interface.owner().symbol()
3790	: nullptr};
3791	module && module->has<ModuleDetails>()) {
3792	std::pair<SourceName, const Symbol *> key{symbol.name(), module};
3793	auto iter{moduleProcs_.find(key)};
3794	if (iter == moduleProcs_.end()) {
3795	moduleProcs_.emplace(std::move(key), symbol);
3796	} else if (
3797	auto *msg{messages_.Say(symbol.name(),
3798	"Module procedure '%s' in '%s' has multiple definitions"_err_en_US,
3799	symbol.name(), GetModuleOrSubmoduleName(*module))}) {
3800	msg->Attach(iter->second->name(), "Previous definition of '%s'"_en_US,
3801	symbol.name());
3802	}
3803	}
3804	}
3805	}
3806
3807	void SubprogramMatchHelper::Check(
3808	const Symbol &symbol1, const Symbol &symbol2) {
3809	const auto details1{symbol1.get<SubprogramDetails>()};
3810	const auto details2{symbol2.get<SubprogramDetails>()};
3811	if (details1.isFunction() != details2.isFunction()) {
3812	Say(symbol1, symbol2,
3813	details1.isFunction()
3814	? "Module function '%s' was declared as a subroutine in the"
3815	" corresponding interface body"_err_en_US
3816	: "Module subroutine '%s' was declared as a function in the"
3817	" corresponding interface body"_err_en_US);
3818	return;
3819	}
3820	const auto &args1{details1.dummyArgs()};
3821	const auto &args2{details2.dummyArgs()};
3822	int nargs1{static_cast<int>(args1.size())};
3823	int nargs2{static_cast<int>(args2.size())};
3824	if (nargs1 != nargs2) {
3825	Say(symbol1, symbol2,
3826	"Module subprogram '%s' has %d args but the corresponding interface"
3827	" body has %d"_err_en_US,
3828	nargs1, nargs2);
3829	return;
3830	}
3831	bool nonRecursive1{symbol1.attrs().test(Attr::NON_RECURSIVE)};
3832	if (nonRecursive1 != symbol2.attrs().test(Attr::NON_RECURSIVE)) { // C1551
3833	Say(symbol1, symbol2,
3834	nonRecursive1
3835	? "Module subprogram '%s' has NON_RECURSIVE prefix but"
3836	" the corresponding interface body does not"_err_en_US
3837	: "Module subprogram '%s' does not have NON_RECURSIVE prefix but "
3838	"the corresponding interface body does"_err_en_US);
3839	}
3840	const std::string *bindName1{details1.bindName()};
3841	const std::string *bindName2{details2.bindName()};
3842	if (!bindName1 && !bindName2) {
3843	// OK - neither has a binding label
3844	} else if (!bindName1) {
3845	Say(symbol1, symbol2,
3846	"Module subprogram '%s' does not have a binding label but the"
3847	" corresponding interface body does"_err_en_US);
3848	} else if (!bindName2) {
3849	Say(symbol1, symbol2,
3850	"Module subprogram '%s' has a binding label but the"
3851	" corresponding interface body does not"_err_en_US);
3852	} else if (*bindName1 != *bindName2) {
3853	Say(symbol1, symbol2,
3854	"Module subprogram '%s' has binding label '%s' but the corresponding"
3855	" interface body has '%s'"_err_en_US,
3856	*details1.bindName(), *details2.bindName());
3857	}
3858	const Procedure *proc1{checkHelper.Characterize(symbol1)};
3859	const Procedure *proc2{checkHelper.Characterize(symbol2)};
3860	if (!proc1 || !proc2) {
3861	return;
3862	}
3863	if (proc1->attrs.test(Procedure::Attr::Pure) !=
3864	proc2->attrs.test(Procedure::Attr::Pure)) {
3865	Say(symbol1, symbol2,
3866	"Module subprogram '%s' and its corresponding interface body are not both PURE"_err_en_US);
3867	}
3868	if (proc1->attrs.test(Procedure::Attr::Elemental) !=
3869	proc2->attrs.test(Procedure::Attr::Elemental)) {
3870	Say(symbol1, symbol2,
3871	"Module subprogram '%s' and its corresponding interface body are not both ELEMENTAL"_err_en_US);
3872	}
3873	if (proc1->attrs.test(Procedure::Attr::BindC) !=
3874	proc2->attrs.test(Procedure::Attr::BindC)) {
3875	Say(symbol1, symbol2,
3876	"Module subprogram '%s' and its corresponding interface body are not both BIND(C)"_err_en_US);
3877	}
3878	if (proc1->functionResult && proc2->functionResult) {
3879	std::string whyNot;
3880	if (!proc1->functionResult->IsCompatibleWith(
3881	*proc2->functionResult, &whyNot)) {
3882	Say(symbol1, symbol2,
3883	"Result of function '%s' is not compatible with the result of the corresponding interface body: %s"_err_en_US,
3884	whyNot);
3885	}
3886	}
3887	for (int i{0}; i < nargs1; ++i) {
3888	const Symbol *arg1{args1[i]};
3889	const Symbol *arg2{args2[i]};
3890	if (arg1 && !arg2) {
3891	Say(symbol1, symbol2,
3892	"Dummy argument %2$d of '%1$s' is not an alternate return indicator"
3893	" but the corresponding argument in the interface body is"_err_en_US,
3894	i + 1);
3895	} else if (!arg1 && arg2) {
3896	Say(symbol1, symbol2,
3897	"Dummy argument %2$d of '%1$s' is an alternate return indicator but"
3898	" the corresponding argument in the interface body is not"_err_en_US,
3899	i + 1);
3900	} else if (arg1 && arg2) {
3901	SourceName name1{arg1->name()};
3902	SourceName name2{arg2->name()};
3903	if (name1 != name2) {
3904	Say(*arg1, *arg2,
3905	"Dummy argument name '%s' does not match corresponding name '%s'"
3906	" in interface body"_err_en_US,
3907	name2);
3908	} else {
3909	CheckDummyArg(
3910	*arg1, *arg2, proc1->dummyArguments[i], proc2->dummyArguments[i]);
3911	}
3912	}
3913	}
3914	}
3915
3916	void SubprogramMatchHelper::CheckDummyArg(const Symbol &symbol1,
3917	const Symbol &symbol2, const DummyArgument &arg1,
3918	const DummyArgument &arg2) {
3919	common::visit(
3920	common::visitors{
3921	[&](const DummyDataObject &obj1, const DummyDataObject &obj2) {
3922	CheckDummyDataObject(symbol1, symbol2, obj1, obj2);
3923	},
3924	[&](const DummyProcedure &proc1, const DummyProcedure &proc2) {
3925	CheckDummyProcedure(symbol1, symbol2, proc1, proc2);
3926	},
3927	[&](const DummyDataObject &, const auto &) {
3928	Say(symbol1, symbol2,
3929	"Dummy argument '%s' is a data object; the corresponding"
3930	" argument in the interface body is not"_err_en_US);
3931	},
3932	[&](const DummyProcedure &, const auto &) {
3933	Say(symbol1, symbol2,
3934	"Dummy argument '%s' is a procedure; the corresponding"
3935	" argument in the interface body is not"_err_en_US);
3936	},
3937	[&](const auto &, const auto &) {
3938	llvm_unreachable("Dummy arguments are not data objects or"
3939	"procedures");
3940	},
3941	},
3942	arg1.u, arg2.u);
3943	}
3944
3945	void SubprogramMatchHelper::CheckDummyDataObject(const Symbol &symbol1,
3946	const Symbol &symbol2, const DummyDataObject &obj1,
3947	const DummyDataObject &obj2) {
3948	if (!CheckSameIntent(symbol1, symbol2, obj1.intent, obj2.intent)) {
3949	} else if (!CheckSameAttrs(symbol1, symbol2, obj1.attrs, obj2.attrs)) {
3950	} else if (!obj1.type.type().IsEquivalentTo(obj2.type.type())) {
3951	Say(symbol1, symbol2,
3952	"Dummy argument '%s' has type %s; the corresponding argument in the interface body has distinct type %s"_err_en_US,
3953	obj1.type.type().AsFortran(), obj2.type.type().AsFortran());
3954	} else if (!ShapesAreCompatible(obj1, obj2)) {
3955	Say(symbol1, symbol2,
3956	"The shape of dummy argument '%s' does not match the shape of the"
3957	" corresponding argument in the interface body"_err_en_US);
3958	}
3959	// TODO: coshape
3960	}
3961
3962	void SubprogramMatchHelper::CheckDummyProcedure(const Symbol &symbol1,
3963	const Symbol &symbol2, const DummyProcedure &proc1,
3964	const DummyProcedure &proc2) {
3965	std::string whyNot;
3966	if (!CheckSameIntent(symbol1, symbol2, proc1.intent, proc2.intent)) {
3967	} else if (!CheckSameAttrs(symbol1, symbol2, proc1.attrs, proc2.attrs)) {
3968	} else if (!proc2.IsCompatibleWith(proc1, &whyNot)) {
3969	Say(symbol1, symbol2,
3970	"Dummy procedure '%s' is not compatible with the corresponding argument in the interface body: %s"_err_en_US,
3971	whyNot);
3972	} else if (proc1 != proc2) {
3973	evaluate::AttachDeclaration(
3974	symbol1.owner().context().Warn(
3975	common::UsageWarning::MismatchingDummyProcedure,
3976	"Dummy procedure '%s' does not exactly match the corresponding argument in the interface body"_warn_en_US,
3977	symbol1.name()),
3978	symbol2);
3979	}
3980	}
3981
3982	bool SubprogramMatchHelper::CheckSameIntent(const Symbol &symbol1,
3983	const Symbol &symbol2, common::Intent intent1, common::Intent intent2) {
3984	if (intent1 == intent2) {
3985	return true;
3986	} else {
3987	Say(symbol1, symbol2,
3988	"The intent of dummy argument '%s' does not match the intent"
3989	" of the corresponding argument in the interface body"_err_en_US);
3990	return false;
3991	}
3992	}
3993
3994	// Report an error referring to first symbol with declaration of second symbol
3995	template <typename... A>
3996	void SubprogramMatchHelper::Say(const Symbol &symbol1, const Symbol &symbol2,
3997	parser::MessageFixedText &&text, A &&...args) {
3998	auto &message{context().Say(symbol1.name(), std::move(text), symbol1.name(),
3999	std::forward<A>(args)...)};
4000	evaluate::AttachDeclaration(message, symbol2);
4001	}
4002
4003	template <typename ATTRS>
4004	bool SubprogramMatchHelper::CheckSameAttrs(
4005	const Symbol &symbol1, const Symbol &symbol2, ATTRS attrs1, ATTRS attrs2) {
4006	if (attrs1 == attrs2) {
4007	return true;
4008	}
4009	attrs1.IterateOverMembers([&](auto attr) {
4010	if (!attrs2.test(attr)) {
4011	Say(symbol1, symbol2,
4012	"Dummy argument '%s' has the %s attribute; the corresponding"
4013	" argument in the interface body does not"_err_en_US,
4014	AsFortran(attr));
4015	}
4016	});
4017	attrs2.IterateOverMembers([&](auto attr) {
4018	if (!attrs1.test(attr)) {
4019	Say(symbol1, symbol2,
4020	"Dummy argument '%s' does not have the %s attribute; the"
4021	" corresponding argument in the interface body does"_err_en_US,
4022	AsFortran(attr));
4023	}
4024	});
4025	return false;
4026	}
4027
4028	bool SubprogramMatchHelper::ShapesAreCompatible(
4029	const DummyDataObject &obj1, const DummyDataObject &obj2) {
4030	return characteristics::ShapesAreCompatible(
4031	FoldShape(obj1.type.shape()), FoldShape(obj2.type.shape()));
4032	}
4033
4034	evaluate::Shape SubprogramMatchHelper::FoldShape(const evaluate::Shape &shape) {
4035	evaluate::Shape result;
4036	for (const auto &extent : shape) {
4037	result.emplace_back(
4038	evaluate::Fold(context().foldingContext(), common::Clone(extent)));
4039	}
4040	return result;
4041	}
4042
4043	void DistinguishabilityHelper::Add(const Symbol &generic, GenericKind kind,
4044	const Symbol &specific, const Procedure &procedure) {
4045	const Symbol &ultimate{specific.GetUltimate()};
4046	if (!context_.HasError(ultimate)) {
4047	nameToSpecifics_[generic.name()].emplace(
4048	&ultimate, ProcedureInfo{kind, procedure});
4049	}
4050	}
4051
4052	void DistinguishabilityHelper::Check(const Scope &scope) {
4053	if (FindModuleFileContaining(scope)) {
4054	// Distinguishability was checked when the module was created;
4055	// don't let optional warnings then become errors now.
4056	return;
4057	}
4058	for (const auto &[name, info] : nameToSpecifics_) {
4059	for (auto iter1{info.begin()}; iter1 != info.end(); ++iter1) {
4060	const auto &[ultimate, procInfo]{*iter1};
4061	const auto &[kind, proc]{procInfo};
4062	for (auto iter2{iter1}; ++iter2 != info.end();) {
4063	const auto &[ultimate2, procInfo2]{*iter2};
4064	if (&*ultimate == &*ultimate2) {
4065	continue; // ok, actually the same procedure/binding
4066	} else if (const auto *binding1{
4067	ultimate->detailsIf<ProcBindingDetails>()}) {
4068	if (const auto *binding2{
4069	ultimate2->detailsIf<ProcBindingDetails>()}) {
4070	if (&binding1->symbol().GetUltimate() ==
4071	&binding2->symbol().GetUltimate()) {
4072	continue; // ok, (NOPASS) bindings resolve identically
4073	} else if (ultimate->name() == ultimate2->name()) {
4074	continue; // override, possibly of DEFERRED
4075	}
4076	}
4077	} else if (ultimate->has<ProcBindingDetails>() &&
4078	ultimate2->has<ProcBindingDetails>() &&
4079	ultimate->name() == ultimate2->name()) {
4080	continue; // override, possibly of DEFERRED
4081	}
4082	auto distinguishable{kind.IsName()
4083	? evaluate::characteristics::Distinguishable
4084	: evaluate::characteristics::DistinguishableOpOrAssign};
4085	std::optional<bool> distinct{distinguishable(
4086	context_.languageFeatures(), proc, procInfo2.procedure)};
4087	if (!distinct.value_or(false)) {
4088	SayNotDistinguishable(GetTopLevelUnitContaining(scope), name, kind,
4089	*ultimate, *ultimate2, distinct.has_value());
4090	}
4091	}
4092	}
4093	}
4094	}
4095
4096	void DistinguishabilityHelper::SayNotDistinguishable(const Scope &scope,
4097	const SourceName &name, GenericKind kind, const Symbol &proc1,
4098	const Symbol &proc2, bool isHardConflict) {
4099	bool isUseAssociated{!scope.sourceRange().Contains(name)};
4100	// The rules for distinguishing specific procedures (F'2023 15.4.3.4.5)
4101	// are inadequate for some real-world cases like pFUnit.
4102	// When there are optional dummy arguments or unlimited polymorphic
4103	// dummy data object arguments, the best that we can do is emit an optional
4104	// portability warning. Also, named generics created by USE association
4105	// merging shouldn't receive hard errors for ambiguity.
4106	// (Non-named generics might be defined I/O procedures or defined
4107	// assignments that need to be used by the runtime.)
4108	bool isWarning{!isHardConflict || (isUseAssociated && kind.IsName())};
4109	if (isWarning &&
4110	(!context_.ShouldWarn(
4111	common::LanguageFeature::IndistinguishableSpecifics) ||
4112	FindModuleFileContaining(scope))) {
4113	return;
4114	}
4115	std::string name1{proc1.name().ToString()};
4116	std::string name2{proc2.name().ToString()};
4117	if (kind.IsOperator() || kind.IsAssignment()) {
4118	// proc1 and proc2 may come from different scopes so qualify their names
4119	if (proc1.owner().IsDerivedType()) {
4120	name1 = proc1.owner().GetName()->ToString() + '%' + name1;
4121	}
4122	if (proc2.owner().IsDerivedType()) {
4123	name2 = proc2.owner().GetName()->ToString() + '%' + name2;
4124	}
4125	}
4126	parser::Message *msg;
4127	if (!isUseAssociated) {
4128	CHECK(isWarning == !isHardConflict);
4129	msg = &context_.Say(name,
4130	isHardConflict
4131	? "Generic '%s' may not have specific procedures '%s' and '%s' as their interfaces are not distinguishable"_err_en_US
4132	: "Generic '%s' should not have specific procedures '%s' and '%s' as their interfaces are not distinguishable by the rules in the standard"_port_en_US,
4133	MakeOpName(name), name1, name2);
4134	} else {
4135	msg = &context_.Say(*GetTopLevelUnitContaining(proc1).GetName(),
4136	isHardConflict
4137	? (isWarning
4138	? "USE-associated generic '%s' should not have specific procedures '%s' and '%s' as their interfaces are not distinguishable"_warn_en_US
4139	: "USE-associated generic '%s' may not have specific procedures '%s' and '%s' as their interfaces are not distinguishable"_err_en_US)
4140	: "USE-associated generic '%s' should not have specific procedures '%s' and '%s' as their interfaces are not distinguishable by the rules in the standard"_port_en_US,
4141	MakeOpName(name), name1, name2);
4142	}
4143	AttachDeclaration(*msg, scope, proc1);
4144	AttachDeclaration(*msg, scope, proc2);
4145	}
4146
4147	// `evaluate::AttachDeclaration` doesn't handle the generic case where `proc`
4148	// comes from a different module but is not necessarily use-associated.
4149	void DistinguishabilityHelper::AttachDeclaration(
4150	parser::Message &msg, const Scope &scope, const Symbol &proc) {
4151	const Scope &unit{GetTopLevelUnitContaining(proc)};
4152	if (unit == scope) {
4153	evaluate::AttachDeclaration(msg, proc);
4154	} else {
4155	msg.Attach(unit.GetName().value(),
4156	"'%s' is USE-associated from module '%s'"_en_US, proc.name(),
4157	unit.GetName().value());
4158	}
4159	}
4160
4161	void CheckDeclarations(SemanticsContext &context) {
4162	CheckHelper{context}.Check();
4163	}
4164	} // namespace Fortran::semantics
4165