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