1	//===-- lib/Semantics/check-call.cpp --------------------------------------===//
2	//
3	// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
4	// See https://llvm.org/LICENSE.txt for license information.
5	// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
6	//
7	//===----------------------------------------------------------------------===//
8
9	#include "check-call.h"
10	#include "definable.h"
11	#include "pointer-assignment.h"
12	#include "flang/Evaluate/characteristics.h"
13	#include "flang/Evaluate/check-expression.h"
14	#include "flang/Evaluate/fold-designator.h"
15	#include "flang/Evaluate/shape.h"
16	#include "flang/Evaluate/tools.h"
17	#include "flang/Parser/characters.h"
18	#include "flang/Parser/message.h"
19	#include "flang/Semantics/scope.h"
20	#include "flang/Semantics/tools.h"
21	#include <map>
22	#include <string>
23
24	using namespace Fortran::parser::literals;
25	namespace characteristics = Fortran::evaluate::characteristics;
26
27	namespace Fortran::semantics {
28
29	static void CheckImplicitInterfaceArg(evaluate::ActualArgument &arg,
30	parser::ContextualMessages &messages, SemanticsContext &context) {
31	auto restorer{
32	messages.SetLocation(arg.sourceLocation().value_or(messages.at()))};
33	if (auto kw{arg.keyword()}) {
34	messages.Say(*kw,
35	"Keyword '%s=' may not appear in a reference to a procedure with an implicit interface"_err_en_US,
36	*kw);
37	}
38	auto type{arg.GetType()};
39	if (type) {
40	if (type->IsAssumedType()) {
41	messages.Say(
42	"Assumed type actual argument requires an explicit interface"_err_en_US);
43	} else if (type->IsUnlimitedPolymorphic()) {
44	messages.Say(
45	"Unlimited polymorphic actual argument requires an explicit interface"_err_en_US);
46	} else if (const DerivedTypeSpec * derived{GetDerivedTypeSpec(type)}) {
47	if (!derived->parameters().empty()) {
48	messages.Say(
49	"Parameterized derived type actual argument requires an explicit interface"_err_en_US);
50	}
51	}
52	}
53	if (arg.isPercentVal() &&
54	(!type || !type->IsLengthlessIntrinsicType() || arg.Rank() != 0)) {
55	messages.Say(
56	"%VAL argument must be a scalar numeric or logical expression"_err_en_US);
57	}
58	if (const auto *expr{arg.UnwrapExpr()}) {
59	if (const Symbol * base{GetFirstSymbol(*expr)};
60	base && IsFunctionResult(*base)) {
61	context.NoteDefinedSymbol(*base);
62	}
63	if (IsBOZLiteral(*expr)) {
64	messages.Say("BOZ argument requires an explicit interface"_err_en_US);
65	} else if (evaluate::IsNullPointerOrAllocatable(expr)) {
66	messages.Say(
67	"Null pointer argument requires an explicit interface"_err_en_US);
68	} else if (auto named{evaluate::ExtractNamedEntity(*expr)}) {
69	const Symbol &symbol{named->GetLastSymbol()};
70	if (evaluate::IsAssumedRank(symbol)) {
71	messages.Say(
72	"Assumed rank argument requires an explicit interface"_err_en_US);
73	}
74	if (symbol.attrs().test(Attr::ASYNCHRONOUS)) {
75	messages.Say(
76	"ASYNCHRONOUS argument requires an explicit interface"_err_en_US);
77	}
78	if (symbol.attrs().test(Attr::VOLATILE)) {
79	messages.Say(
80	"VOLATILE argument requires an explicit interface"_err_en_US);
81	}
82	} else if (auto argChars{characteristics::DummyArgument::FromActual(
83	"actual argument", *expr, context.foldingContext(),
84	/*forImplicitInterface=*/true)}) {
85	const auto *argProcDesignator{
86	std::get_if<evaluate::ProcedureDesignator>(&expr->u)};
87	if (const auto *argProcSymbol{
88	argProcDesignator ? argProcDesignator->GetSymbol() : nullptr}) {
89	if (!argChars->IsTypelessIntrinsicDummy() && argProcDesignator &&
90	argProcDesignator->IsElemental()) { // C1533
91	evaluate::SayWithDeclaration(messages, *argProcSymbol,
92	"Non-intrinsic ELEMENTAL procedure '%s' may not be passed as an actual argument"_err_en_US,
93	argProcSymbol->name());
94	} else if (const auto *subp{argProcSymbol->GetUltimate()
95	.detailsIf<SubprogramDetails>()}) {
96	if (subp->stmtFunction()) {
97	evaluate::SayWithDeclaration(messages, *argProcSymbol,
98	"Statement function '%s' may not be passed as an actual argument"_err_en_US,
99	argProcSymbol->name());
100	}
101	}
102	}
103	}
104	}
105	}
106
107	// F'2023 15.5.2.12p1: "Sequence association only applies when the dummy
108	// argument is an explicit-shape or assumed-size array."
109	static bool CanAssociateWithStorageSequence(
110	const characteristics::DummyDataObject &dummy) {
111	return !dummy.type.attrs().test(
112	characteristics::TypeAndShape::Attr::AssumedRank) &&
113	!dummy.type.attrs().test(
114	characteristics::TypeAndShape::Attr::AssumedShape) &&
115	!dummy.attrs.test(characteristics::DummyDataObject::Attr::Allocatable) &&
116	!dummy.attrs.test(characteristics::DummyDataObject::Attr::Pointer) &&
117	dummy.type.corank() == 0;
118	}
119
120	// When a CHARACTER actual argument is known to be short,
121	// we extend it on the right with spaces and a warning if
122	// possible. When it is long, and not required to be equal,
123	// the usage conforms to the standard and no warning is needed.
124	static void CheckCharacterActual(evaluate::Expr<evaluate::SomeType> &actual,
125	const characteristics::DummyDataObject &dummy,
126	characteristics::TypeAndShape &actualType, SemanticsContext &context,
127	parser::ContextualMessages &messages, bool extentErrors,
128	const std::string &dummyName) {
129	if (dummy.type.type().category() == TypeCategory::Character &&
130	actualType.type().category() == TypeCategory::Character &&
131	dummy.type.type().kind() == actualType.type().kind() &&
132	!dummy.attrs.test(
133	characteristics::DummyDataObject::Attr::DeducedFromActual)) {
134	bool actualIsAssumedRank{evaluate::IsAssumedRank(actual)};
135	if (actualIsAssumedRank &&
136	!dummy.type.attrs().test(
137	characteristics::TypeAndShape::Attr::AssumedRank)) {
138	if (!context.languageFeatures().IsEnabled(
139	common::LanguageFeature::AssumedRankPassedToNonAssumedRank)) {
140	messages.Say(
141	"Assumed-rank character array may not be associated with a dummy argument that is not assumed-rank"_err_en_US);
142	} else {
143	context.Warn(common::LanguageFeature::AssumedRankPassedToNonAssumedRank,
144	messages.at(),
145	"Assumed-rank character array should not be associated with a dummy argument that is not assumed-rank"_port_en_US);
146	}
147	}
148	if (dummy.type.LEN() && actualType.LEN()) {
149	evaluate::FoldingContext &foldingContext{context.foldingContext()};
150	auto dummyLength{
151	ToInt64(Fold(foldingContext, common::Clone(*dummy.type.LEN())))};
152	auto actualLength{
153	ToInt64(Fold(foldingContext, common::Clone(*actualType.LEN())))};
154	if (dummyLength && actualLength) {
155	bool canAssociate{CanAssociateWithStorageSequence(dummy)};
156	if (dummy.type.Rank() > 0 && canAssociate) {
157	// Character storage sequence association (F'2023 15.5.2.12p4)
158	if (auto dummySize{evaluate::ToInt64(evaluate::Fold(
159	foldingContext, evaluate::GetSize(dummy.type.shape())))}) {
160	auto dummyChars{*dummySize * *dummyLength};
161	if (actualType.Rank() == 0 && !actualIsAssumedRank) {
162	evaluate::DesignatorFolder folder{
163	context.foldingContext(), /*getLastComponent=*/true};
164	if (auto actualOffset{folder.FoldDesignator(actual)}) {
165	std::int64_t actualChars{*actualLength};
166	if (IsAllocatableOrPointer(actualOffset->symbol())) {
167	// don't use actualOffset->symbol().size()!
168	} else if (static_cast<std::size_t>(actualOffset->offset()) >=
169	actualOffset->symbol().size() ||
170	!evaluate::IsContiguous(
171	actualOffset->symbol(), foldingContext)) {
172	// If substring, take rest of substring
173	if (*actualLength > 0) {
174	actualChars -=
175	(actualOffset->offset() / actualType.type().kind()) %
176	*actualLength;
177	}
178	} else {
179	actualChars = (static_cast<std::int64_t>(
180	actualOffset->symbol().size()) -
181	actualOffset->offset()) /
182	actualType.type().kind();
183	}
184	if (actualChars < dummyChars) {
185	if (extentErrors) {
186	messages.Say(
187	"Actual argument has fewer characters remaining in storage sequence (%jd) than %s (%jd)"_err_en_US,
188	static_cast<std::intmax_t>(actualChars), dummyName,
189	static_cast<std::intmax_t>(dummyChars));
190	} else if (context.ShouldWarn(
191	common::UsageWarning::ShortCharacterActual)) {
192	messages.Say(common::UsageWarning::ShortCharacterActual,
193	"Actual argument has fewer characters remaining in storage sequence (%jd) than %s (%jd)"_warn_en_US,
194	static_cast<std::intmax_t>(actualChars), dummyName,
195	static_cast<std::intmax_t>(dummyChars));
196	}
197	}
198	}
199	} else { // actual.type.Rank() > 0
200	if (auto actualSize{evaluate::ToInt64(evaluate::Fold(
201	foldingContext, evaluate::GetSize(actualType.shape())))};
202	actualSize &&
203	*actualSize * *actualLength < *dummySize * *dummyLength) {
204	if (extentErrors) {
205	messages.Say(
206	"Actual argument array has fewer characters (%jd) than %s array (%jd)"_err_en_US,
207	static_cast<std::intmax_t>(*actualSize * *actualLength),
208	dummyName,
209	static_cast<std::intmax_t>(*dummySize * *dummyLength));
210	} else if (context.ShouldWarn(
211	common::UsageWarning::ShortCharacterActual)) {
212	messages.Say(common::UsageWarning::ShortCharacterActual,
213	"Actual argument array has fewer characters (%jd) than %s array (%jd)"_warn_en_US,
214	static_cast<std::intmax_t>(*actualSize * *actualLength),
215	dummyName,
216	static_cast<std::intmax_t>(*dummySize * *dummyLength));
217	}
218	}
219	}
220	}
221	} else if (*actualLength != *dummyLength) {
222	// Not using storage sequence association, and the lengths don't
223	// match.
224	if (!canAssociate) {
225	// F'2023 15.5.2.5 paragraph 4
226	messages.Say(
227	"Actual argument variable length '%jd' does not match the expected length '%jd'"_err_en_US,
228	*actualLength, *dummyLength);
229	} else if (*actualLength < *dummyLength) {
230	CHECK(dummy.type.Rank() == 0);
231	bool isVariable{evaluate::IsVariable(actual)};
232	if (context.ShouldWarn(
233	common::UsageWarning::ShortCharacterActual)) {
234	if (isVariable) {
235	messages.Say(common::UsageWarning::ShortCharacterActual,
236	"Actual argument variable length '%jd' is less than expected length '%jd'"_warn_en_US,
237	*actualLength, *dummyLength);
238	} else {
239	messages.Say(common::UsageWarning::ShortCharacterActual,
240	"Actual argument expression length '%jd' is less than expected length '%jd'"_warn_en_US,
241	*actualLength, *dummyLength);
242	}
243	}
244	if (!isVariable) {
245	auto converted{
246	ConvertToType(dummy.type.type(), std::move(actual))};
247	CHECK(converted);
248	actual = std::move(*converted);
249	actualType.set_LEN(SubscriptIntExpr{*dummyLength});
250	}
251	}
252	}
253	}
254	}
255	}
256	}
257
258	// Automatic conversion of different-kind INTEGER scalar actual
259	// argument expressions (not variables) to INTEGER scalar dummies.
260	// We return nonstandard INTEGER(8) results from intrinsic functions
261	// like SIZE() by default in order to facilitate the use of large
262	// arrays. Emit a warning when downconverting.
263	static void ConvertIntegerActual(evaluate::Expr<evaluate::SomeType> &actual,
264	const characteristics::TypeAndShape &dummyType,
265	characteristics::TypeAndShape &actualType,
266	parser::ContextualMessages &messages, SemanticsContext &semanticsContext) {
267	if (dummyType.type().category() == TypeCategory::Integer &&
268	actualType.type().category() == TypeCategory::Integer &&
269	dummyType.type().kind() != actualType.type().kind() &&
270	dummyType.Rank() == 0 && actualType.Rank() == 0 &&
271	!evaluate::IsVariable(actual)) {
272	auto converted{
273	evaluate::ConvertToType(dummyType.type(), std::move(actual))};
274	CHECK(converted);
275	actual = std::move(*converted);
276	if (dummyType.type().kind() < actualType.type().kind()) {
277	if (!semanticsContext.IsEnabled(
278	common::LanguageFeature::ActualIntegerConvertedToSmallerKind)) {
279	messages.Say(
280	"Actual argument scalar expression of type INTEGER(%d) cannot be implicitly converted to smaller dummy argument type INTEGER(%d)"_err_en_US,
281	actualType.type().kind(), dummyType.type().kind());
282	} else if (semanticsContext.ShouldWarn(common::LanguageFeature::
283	ActualIntegerConvertedToSmallerKind)) {
284	messages.Say(
285	common::LanguageFeature::ActualIntegerConvertedToSmallerKind,
286	"Actual argument scalar expression of type INTEGER(%d) was converted to smaller dummy argument type INTEGER(%d)"_port_en_US,
287	actualType.type().kind(), dummyType.type().kind());
288	}
289	}
290	actualType = dummyType;
291	}
292	}
293
294	// Automatic conversion of different-kind LOGICAL scalar actual argument
295	// expressions (not variables) to LOGICAL scalar dummies when the dummy is of
296	// default logical kind. This allows expressions in dummy arguments to work when
297	// the default logical kind is not the one used in LogicalResult. This will
298	// always be safe even when downconverting so no warning is needed.
299	static void ConvertLogicalActual(evaluate::Expr<evaluate::SomeType> &actual,
300	const characteristics::TypeAndShape &dummyType,
301	characteristics::TypeAndShape &actualType) {
302	if (dummyType.type().category() == TypeCategory::Logical &&
303	actualType.type().category() == TypeCategory::Logical &&
304	dummyType.type().kind() != actualType.type().kind() &&
305	!evaluate::IsVariable(actual)) {
306	auto converted{
307	evaluate::ConvertToType(dummyType.type(), std::move(actual))};
308	CHECK(converted);
309	actual = std::move(*converted);
310	actualType = dummyType;
311	}
312	}
313
314	static bool DefersSameTypeParameters(
315	const DerivedTypeSpec *actual, const DerivedTypeSpec *dummy) {
316	if (actual && dummy) {
317	for (const auto &pair : actual->parameters()) {
318	const ParamValue &actualValue{pair.second};
319	const ParamValue *dummyValue{dummy->FindParameter(pair.first)};
320	if (!dummyValue ||
321	(actualValue.isDeferred() != dummyValue->isDeferred())) {
322	return false;
323	}
324	}
325	}
326	return true;
327	}
328
329	static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
330	const std::string &dummyName, evaluate::Expr<evaluate::SomeType> &actual,
331	characteristics::TypeAndShape &actualType, bool isElemental,
332	SemanticsContext &context, evaluate::FoldingContext &foldingContext,
333	const Scope *scope, const evaluate::SpecificIntrinsic *intrinsic,
334	bool allowActualArgumentConversions, bool extentErrors,
335	const characteristics::Procedure &procedure,
336	const evaluate::ActualArgument &arg) {
337
338	// Basic type & rank checking
339	parser::ContextualMessages &messages{foldingContext.messages()};
340	CheckCharacterActual(
341	actual, dummy, actualType, context, messages, extentErrors, dummyName);
342	bool dummyIsAllocatable{
343	dummy.attrs.test(characteristics::DummyDataObject::Attr::Allocatable)};
344	bool dummyIsPointer{
345	dummy.attrs.test(characteristics::DummyDataObject::Attr::Pointer)};
346	bool dummyIsAllocatableOrPointer{dummyIsAllocatable || dummyIsPointer};
347	allowActualArgumentConversions &= !dummyIsAllocatableOrPointer;
348	bool typesCompatibleWithIgnoreTKR{
349	(dummy.ignoreTKR.test(common::IgnoreTKR::Type) &&
350	(dummy.type.type().category() == TypeCategory::Derived ||
351	actualType.type().category() == TypeCategory::Derived ||
352	dummy.type.type().category() != actualType.type().category())) ||
353	(dummy.ignoreTKR.test(common::IgnoreTKR::Kind) &&
354	dummy.type.type().category() == actualType.type().category())};
355	allowActualArgumentConversions &= !typesCompatibleWithIgnoreTKR;
356	if (allowActualArgumentConversions) {
357	ConvertIntegerActual(actual, dummy.type, actualType, messages, context);
358	ConvertLogicalActual(actual, dummy.type, actualType);
359	}
360	bool typesCompatible{typesCompatibleWithIgnoreTKR ||
361	dummy.type.type().IsTkCompatibleWith(actualType.type())};
362	int dummyRank{dummy.type.Rank()};
363	if (typesCompatible) {
364	if (const auto *constantChar{
365	evaluate::UnwrapConstantValue<evaluate::Ascii>(actual)};
366	constantChar && constantChar->wasHollerith() &&
367	dummy.type.type().IsUnlimitedPolymorphic() &&
368	context.ShouldWarn(common::LanguageFeature::HollerithPolymorphic)) {
369	messages.Say(common::LanguageFeature::HollerithPolymorphic,
370	"passing Hollerith to unlimited polymorphic as if it were CHARACTER"_port_en_US);
371	}
372	} else if (dummyRank == 0 && allowActualArgumentConversions) {
373	// Extension: pass Hollerith literal to scalar as if it had been BOZ
374	if (auto converted{evaluate::HollerithToBOZ(
375	foldingContext, actual, dummy.type.type())}) {
376	if (context.ShouldWarn(
377	common::LanguageFeature::HollerithOrCharacterAsBOZ)) {
378	messages.Say(common::LanguageFeature::HollerithOrCharacterAsBOZ,
379	"passing Hollerith or character literal as if it were BOZ"_port_en_US);
380	}
381	actual = *converted;
382	actualType.type() = dummy.type.type();
383	typesCompatible = true;
384	}
385	}
386	bool dummyIsAssumedRank{dummy.type.attrs().test(
387	characteristics::TypeAndShape::Attr::AssumedRank)};
388	bool actualIsAssumedSize{actualType.attrs().test(
389	characteristics::TypeAndShape::Attr::AssumedSize)};
390	bool actualIsAssumedRank{evaluate::IsAssumedRank(actual)};
391	bool actualIsPointer{evaluate::IsObjectPointer(actual)};
392	bool actualIsAllocatable{evaluate::IsAllocatableDesignator(actual)};
393	bool actualMayBeAssumedSize{actualIsAssumedSize ||
394	(actualIsAssumedRank && !actualIsPointer && !actualIsAllocatable)};
395	bool actualIsPolymorphic{actualType.type().IsPolymorphic()};
396	const auto *actualDerived{evaluate::GetDerivedTypeSpec(actualType.type())};
397	if (typesCompatible) {
398	if (isElemental) {
399	} else if (dummyIsAssumedRank) {
400	if (actualMayBeAssumedSize && dummy.intent == common::Intent::Out) {
401	// An INTENT(OUT) dummy might be a no-op at run time
402	bool dummyHasSignificantIntentOut{actualIsPolymorphic ||
403	(actualDerived &&
404	(actualDerived->HasDefaultInitialization(
405	/*ignoreAllocatable=*/false, /*ignorePointer=*/true) ||
406	actualDerived->HasDestruction()))};
407	const char *actualDesc{
408	actualIsAssumedSize ? "Assumed-size" : "Assumed-rank"};
409	if (dummyHasSignificantIntentOut) {
410	messages.Say(
411	"%s actual argument may not be associated with INTENT(OUT) assumed-rank dummy argument requiring finalization, destruction, or initialization"_err_en_US,
412	actualDesc);
413	} else {
414	context.Warn(common::UsageWarning::Portability, messages.at(),
415	"%s actual argument should not be associated with INTENT(OUT) assumed-rank dummy argument"_port_en_US,
416	actualDesc);
417	}
418	}
419	} else if (dummy.ignoreTKR.test(common::IgnoreTKR::Rank)) {
420	} else if (dummyRank > 0 && !dummyIsAllocatableOrPointer &&
421	!dummy.type.attrs().test(
422	characteristics::TypeAndShape::Attr::AssumedShape) &&
423	!dummy.type.attrs().test(
424	characteristics::TypeAndShape::Attr::DeferredShape) &&
425	(actualType.Rank() > 0 || IsArrayElement(actual))) {
426	// Sequence association (15.5.2.11) applies -- rank need not match
427	// if the actual argument is an array or array element designator,
428	// and the dummy is an array, but not assumed-shape or an INTENT(IN)
429	// pointer that's standing in for an assumed-shape dummy.
430	} else if (dummy.type.shape() && actualType.shape()) {
431	// Let CheckConformance accept actual scalars; storage association
432	// cases are checked here below.
433	CheckConformance(messages, *dummy.type.shape(), *actualType.shape(),
434	dummyIsAllocatableOrPointer
435	? evaluate::CheckConformanceFlags::None
436	: evaluate::CheckConformanceFlags::RightScalarExpandable,
437	"dummy argument", "actual argument");
438	}
439	} else {
440	const auto &len{actualType.LEN()};
441	messages.Say(
442	"Actual argument type '%s' is not compatible with dummy argument type '%s'"_err_en_US,
443	actualType.type().AsFortran(len ? len->AsFortran() : ""),
444	dummy.type.type().AsFortran());
445	}
446
447	auto actualCoarrayRef{ExtractCoarrayRef(actual)};
448	bool dummyIsAssumedSize{dummy.type.attrs().test(
449	characteristics::TypeAndShape::Attr::AssumedSize)};
450	bool dummyIsAsynchronous{
451	dummy.attrs.test(characteristics::DummyDataObject::Attr::Asynchronous)};
452	bool dummyIsVolatile{
453	dummy.attrs.test(characteristics::DummyDataObject::Attr::Volatile)};
454	bool dummyIsValue{
455	dummy.attrs.test(characteristics::DummyDataObject::Attr::Value)};
456	bool dummyIsPolymorphic{dummy.type.type().IsPolymorphic()};
457	if (actualIsPolymorphic && dummyIsPolymorphic &&
458	actualCoarrayRef) { // 15.5.2.4(2)
459	messages.Say(
460	"Coindexed polymorphic object may not be associated with a polymorphic %s"_err_en_US,
461	dummyName);
462	}
463	if (actualIsPolymorphic && !dummyIsPolymorphic &&
464	actualIsAssumedSize) { // 15.5.2.4(2)
465	messages.Say(
466	"Assumed-size polymorphic array may not be associated with a monomorphic %s"_err_en_US,
467	dummyName);
468	}
469
470	// Derived type actual argument checks
471	const Symbol *actualFirstSymbol{evaluate::GetFirstSymbol(actual)};
472	bool actualIsAsynchronous{
473	actualFirstSymbol && actualFirstSymbol->attrs().test(Attr::ASYNCHRONOUS)};
474	bool actualIsVolatile{
475	actualFirstSymbol && actualFirstSymbol->attrs().test(Attr::VOLATILE)};
476	if (actualDerived && !actualDerived->IsVectorType()) {
477	if (dummy.type.type().IsAssumedType()) {
478	if (!actualDerived->parameters().empty()) { // 15.5.2.4(2)
479	messages.Say(
480	"Actual argument associated with TYPE(*) %s may not have a parameterized derived type"_err_en_US,
481	dummyName);
482	}
483	if (const Symbol *
484	tbp{FindImmediateComponent(*actualDerived, [](const Symbol &symbol) {
485	return symbol.has<ProcBindingDetails>();
486	})}) { // 15.5.2.4(2)
487	evaluate::SayWithDeclaration(messages, *tbp,
488	"Actual argument associated with TYPE(*) %s may not have type-bound procedure '%s'"_err_en_US,
489	dummyName, tbp->name());
490	}
491	auto finals{FinalsForDerivedTypeInstantiation(*actualDerived)};
492	if (!finals.empty()) { // 15.5.2.4(2)
493	SourceName name{finals.front()->name()};
494	if (auto *msg{messages.Say(
495	"Actual argument associated with TYPE(*) %s may not have derived type '%s' with FINAL subroutine '%s'"_err_en_US,
496	dummyName, actualDerived->typeSymbol().name(), name)}) {
497	msg->Attach(name, "FINAL subroutine '%s' in derived type '%s'"_en_US,
498	name, actualDerived->typeSymbol().name());
499	}
500	}
501	}
502	if (actualCoarrayRef) {
503	if (dummy.intent != common::Intent::In && !dummyIsValue) {
504	if (auto bad{FindAllocatableUltimateComponent(
505	*actualDerived)}) { // 15.5.2.4(6)
506	evaluate::SayWithDeclaration(messages, *bad,
507	"Coindexed actual argument with ALLOCATABLE ultimate component '%s' must be associated with a %s with VALUE or INTENT(IN) attributes"_err_en_US,
508	bad.BuildResultDesignatorName(), dummyName);
509	}
510	}
511	const Symbol &coarray{actualCoarrayRef->GetLastSymbol()};
512	if (const DeclTypeSpec * type{coarray.GetType()}) { // C1537
513	if (const DerivedTypeSpec * derived{type->AsDerived()}) {
514	if (auto bad{semantics::FindPointerUltimateComponent(*derived)}) {
515	evaluate::SayWithDeclaration(messages, coarray,
516	"Coindexed object '%s' with POINTER ultimate component '%s' cannot be associated with %s"_err_en_US,
517	coarray.name(), bad.BuildResultDesignatorName(), dummyName);
518	}
519	}
520	}
521	}
522	if (actualIsVolatile != dummyIsVolatile) { // 15.5.2.4(22)
523	if (auto bad{semantics::FindCoarrayUltimateComponent(*actualDerived)}) {
524	evaluate::SayWithDeclaration(messages, *bad,
525	"VOLATILE attribute must match for %s when actual argument has a coarray ultimate component '%s'"_err_en_US,
526	dummyName, bad.BuildResultDesignatorName());
527	}
528	}
529	}
530
531	// Rank and shape checks
532	const auto *actualLastSymbol{evaluate::GetLastSymbol(actual)};
533	if (actualLastSymbol) {
534	actualLastSymbol = &ResolveAssociations(*actualLastSymbol);
535	}
536	int actualRank{actualType.Rank()};
537	if (dummy.type.attrs().test(
538	characteristics::TypeAndShape::Attr::AssumedShape)) {
539	// 15.5.2.4(16)
540	if (actualIsAssumedRank) {
541	messages.Say(
542	"Assumed-rank actual argument may not be associated with assumed-shape %s"_err_en_US,
543	dummyName);
544	} else if (actualRank == 0) {
545	messages.Say(
546	"Scalar actual argument may not be associated with assumed-shape %s"_err_en_US,
547	dummyName);
548	} else if (actualIsAssumedSize && actualLastSymbol) {
549	evaluate::SayWithDeclaration(messages, *actualLastSymbol,
550	"Assumed-size array may not be associated with assumed-shape %s"_err_en_US,
551	dummyName);
552	}
553	} else if (dummyRank > 0) {
554	bool basicError{false};
555	if (actualRank == 0 && !actualIsAssumedRank &&
556	!dummyIsAllocatableOrPointer) {
557	// Actual is scalar, dummy is an array. F'2023 15.5.2.5p14
558	if (actualCoarrayRef) {
559	basicError = true;
560	messages.Say(
561	"Coindexed scalar actual argument must be associated with a scalar %s"_err_en_US,
562	dummyName);
563	}
564	bool actualIsArrayElement{IsArrayElement(actual) != nullptr};
565	bool actualIsCKindCharacter{
566	actualType.type().category() == TypeCategory::Character &&
567	actualType.type().kind() == 1};
568	if (!actualIsCKindCharacter) {
569	if (!actualIsArrayElement &&
570	!(dummy.type.type().IsAssumedType() && dummyIsAssumedSize) &&
571	!dummyIsAssumedRank &&
572	!dummy.ignoreTKR.test(common::IgnoreTKR::Rank)) {
573	basicError = true;
574	messages.Say(
575	"Whole scalar actual argument may not be associated with a %s array"_err_en_US,
576	dummyName);
577	}
578	if (actualIsPolymorphic) {
579	basicError = true;
580	messages.Say(
581	"Polymorphic scalar may not be associated with a %s array"_err_en_US,
582	dummyName);
583	}
584	bool isOkBecauseContiguous{
585	context.IsEnabled(
586	common::LanguageFeature::ContiguousOkForSeqAssociation) &&
587	actualLastSymbol &&
588	evaluate::IsContiguous(*actualLastSymbol, foldingContext)};
589	if (actualIsArrayElement && actualLastSymbol &&
590	!dummy.ignoreTKR.test(common::IgnoreTKR::Contiguous)) {
591	if (IsPointer(*actualLastSymbol)) {
592	if (isOkBecauseContiguous) {
593	context.Warn(
594	common::LanguageFeature::ContiguousOkForSeqAssociation,
595	messages.at(),
596	"Element of contiguous pointer array is accepted for storage sequence association"_port_en_US);
597	} else {
598	basicError = true;
599	messages.Say(
600	"Element of pointer array may not be associated with a %s array"_err_en_US,
601	dummyName);
602	}
603	} else if (IsAssumedShape(*actualLastSymbol) &&
604	!dummy.ignoreTKR.test(common::IgnoreTKR::Contiguous)) {
605	if (isOkBecauseContiguous) {
606	context.Warn(
607	common::LanguageFeature::ContiguousOkForSeqAssociation,
608	messages.at(),
609	"Element of contiguous assumed-shape array is accepted for storage sequence association"_port_en_US);
610	} else {
611	basicError = true;
612	messages.Say(
613	"Element of assumed-shape array may not be associated with a %s array"_err_en_US,
614	dummyName);
615	}
616	}
617	}
618	}
619	}
620	// Storage sequence association (F'2023 15.5.2.12p3) checks.
621	// Character storage sequence association is checked in
622	// CheckCharacterActual().
623	if (!basicError &&
624	actualType.type().category() != TypeCategory::Character &&
625	CanAssociateWithStorageSequence(dummy) &&
626	!dummy.attrs.test(
627	characteristics::DummyDataObject::Attr::DeducedFromActual)) {
628	if (auto dummySize{evaluate::ToInt64(evaluate::Fold(
629	foldingContext, evaluate::GetSize(dummy.type.shape())))}) {
630	if (actualIsAssumedRank) {
631	if (!context.languageFeatures().IsEnabled(
632	common::LanguageFeature::AssumedRankPassedToNonAssumedRank)) {
633	messages.Say(
634	"Assumed-rank array may not be associated with a dummy argument that is not assumed-rank"_err_en_US);
635	} else {
636	context.Warn(
637	common::LanguageFeature::AssumedRankPassedToNonAssumedRank,
638	messages.at(),
639	"Assumed-rank array should not be associated with a dummy argument that is not assumed-rank"_port_en_US);
640	}
641	} else if (actualRank == 0) {
642	if (evaluate::IsArrayElement(actual)) {
643	// Actual argument is a scalar array element
644	evaluate::DesignatorFolder folder{
645	context.foldingContext(), /*getLastComponent=*/true};
646	if (auto actualOffset{folder.FoldDesignator(actual)}) {
647	std::optional<std::int64_t> actualElements;
648	if (IsAllocatableOrPointer(actualOffset->symbol())) {
649	// don't use actualOffset->symbol().size()!
650	} else if (static_cast<std::size_t>(actualOffset->offset()) >=
651	actualOffset->symbol().size() ||
652	!evaluate::IsContiguous(
653	actualOffset->symbol(), foldingContext)) {
654	actualElements = 1;
655	} else if (auto actualSymType{evaluate::DynamicType::From(
656	actualOffset->symbol())}) {
657	if (auto actualSymTypeBytes{
658	evaluate::ToInt64(evaluate::Fold(foldingContext,
659	actualSymType->MeasureSizeInBytes(
660	foldingContext, false)))};
661	actualSymTypeBytes && *actualSymTypeBytes > 0) {
662	actualElements = (static_cast<std::int64_t>(
663	actualOffset->symbol().size()) -
664	actualOffset->offset()) /
665	*actualSymTypeBytes;
666	}
667	}
668	if (actualElements && *actualElements < *dummySize) {
669	if (extentErrors) {
670	messages.Say(
671	"Actual argument has fewer elements remaining in storage sequence (%jd) than %s array (%jd)"_err_en_US,
672	static_cast<std::intmax_t>(*actualElements), dummyName,
673	static_cast<std::intmax_t>(*dummySize));
674	} else if (context.ShouldWarn(
675	common::UsageWarning::ShortArrayActual)) {
676	messages.Say(common::UsageWarning::ShortArrayActual,
677	"Actual argument has fewer elements remaining in storage sequence (%jd) than %s array (%jd)"_warn_en_US,
678	static_cast<std::intmax_t>(*actualElements), dummyName,
679	static_cast<std::intmax_t>(*dummySize));
680	}
681	}
682	}
683	}
684	} else {
685	if (auto actualSize{evaluate::ToInt64(evaluate::Fold(
686	foldingContext, evaluate::GetSize(actualType.shape())))};
687	actualSize && *actualSize < *dummySize) {
688	if (extentErrors) {
689	messages.Say(
690	"Actual argument array has fewer elements (%jd) than %s array (%jd)"_err_en_US,
691	static_cast<std::intmax_t>(*actualSize), dummyName,
692	static_cast<std::intmax_t>(*dummySize));
693	} else if (context.ShouldWarn(
694	common::UsageWarning::ShortArrayActual)) {
695	messages.Say(common::UsageWarning::ShortArrayActual,
696	"Actual argument array has fewer elements (%jd) than %s array (%jd)"_warn_en_US,
697	static_cast<std::intmax_t>(*actualSize), dummyName,
698	static_cast<std::intmax_t>(*dummySize));
699	}
700	}
701	}
702	}
703	}
704	}
705	const ObjectEntityDetails *actualLastObject{actualLastSymbol
706	? actualLastSymbol->detailsIf<ObjectEntityDetails>()
707	: nullptr};
708	if (actualLastObject && actualLastObject->IsCoarray() &&
709	dummy.attrs.test(characteristics::DummyDataObject::Attr::Allocatable) &&
710	dummy.intent == common::Intent::Out &&
711	!(intrinsic &&
712	evaluate::AcceptsIntentOutAllocatableCoarray(
713	intrinsic->name))) { // C846
714	messages.Say(
715	"ALLOCATABLE coarray '%s' may not be associated with INTENT(OUT) %s"_err_en_US,
716	actualLastSymbol->name(), dummyName);
717	}
718
719	// Definability checking
720	// Problems with polymorphism are caught in the callee's definition.
721	if (scope) {
722	std::optional<parser::MessageFixedText> undefinableMessage;
723	DefinabilityFlags flags{DefinabilityFlag::PolymorphicOkInPure};
724	if (dummy.intent == common::Intent::InOut) {
725	flags.set(DefinabilityFlag::AllowEventLockOrNotifyType);
726	undefinableMessage =
727	"Actual argument associated with INTENT(IN OUT) %s is not definable"_err_en_US;
728	} else if (dummy.intent == common::Intent::Out) {
729	undefinableMessage =
730	"Actual argument associated with INTENT(OUT) %s is not definable"_err_en_US;
731	} else if (context.ShouldWarn(common::LanguageFeature::
732	UndefinableAsynchronousOrVolatileActual)) {
733	if (dummy.attrs.test(
734	characteristics::DummyDataObject::Attr::Asynchronous)) {
735	undefinableMessage =
736	"Actual argument associated with ASYNCHRONOUS %s is not definable"_warn_en_US;
737	} else if (dummy.attrs.test(
738	characteristics::DummyDataObject::Attr::Volatile)) {
739	undefinableMessage =
740	"Actual argument associated with VOLATILE %s is not definable"_warn_en_US;
741	}
742	}
743	if (undefinableMessage) {
744	if (isElemental) { // 15.5.2.4(21)
745	flags.set(DefinabilityFlag::VectorSubscriptIsOk);
746	}
747	if (actualIsPointer && dummyIsPointer) { // 19.6.8
748	flags.set(DefinabilityFlag::PointerDefinition);
749	}
750	if (auto whyNot{WhyNotDefinable(messages.at(), *scope, flags, actual)}) {
751	if (whyNot->IsFatal()) {
752	if (auto *msg{messages.Say(*undefinableMessage, dummyName)}) {
753	if (!msg->IsFatal()) {
754	msg->set_languageFeature(common::LanguageFeature::
755	UndefinableAsynchronousOrVolatileActual);
756	}
757	msg->Attach(
758	std::move(whyNot->set_severity(parser::Severity::Because)));
759	}
760	} else {
761	messages.Say(std::move(*whyNot));
762	}
763	}
764	} else if (dummy.intent != common::Intent::In ||
765	(dummyIsPointer && !actualIsPointer)) {
766	if (auto named{evaluate::ExtractNamedEntity(actual)}) {
767	if (const Symbol & base{named->GetFirstSymbol()};
768	IsFunctionResult(base)) {
769	context.NoteDefinedSymbol(base);
770	}
771	}
772	}
773	}
774
775	bool dummyIsContiguous{
776	dummy.attrs.test(characteristics::DummyDataObject::Attr::Contiguous)};
777	bool actualIsContiguous{IsSimplyContiguous(actual, foldingContext)};
778
779	// Cases when temporaries might be needed but must not be permitted.
780	bool dummyIsAssumedShape{dummy.type.attrs().test(
781	characteristics::TypeAndShape::Attr::AssumedShape)};
782	if ((actualIsAsynchronous || actualIsVolatile) &&
783	(dummyIsAsynchronous || dummyIsVolatile) && !dummyIsValue) {
784	if (actualCoarrayRef) { // C1538
785	messages.Say(
786	"Coindexed ASYNCHRONOUS or VOLATILE actual argument may not be associated with %s with ASYNCHRONOUS or VOLATILE attributes unless VALUE"_err_en_US,
787	dummyName);
788	}
789	if ((actualRank > 0 || actualIsAssumedRank) && !actualIsContiguous) {
790	if (dummyIsContiguous ||
791	!(dummyIsAssumedShape || dummyIsAssumedRank ||
792	(actualIsPointer && dummyIsPointer))) { // C1539 & C1540
793	messages.Say(
794	"ASYNCHRONOUS or VOLATILE actual argument that is not simply contiguous may not be associated with a contiguous ASYNCHRONOUS or VOLATILE %s"_err_en_US,
795	dummyName);
796	}
797	}
798	}
799
800	// 15.5.2.6 -- dummy is ALLOCATABLE
801	bool dummyIsOptional{
802	dummy.attrs.test(characteristics::DummyDataObject::Attr::Optional)};
803	if (dummyIsAllocatable) {
804	if (actualIsAllocatable) {
805	if (actualCoarrayRef && dummy.intent != common::Intent::In) {
806	messages.Say(
807	"ALLOCATABLE %s must have INTENT(IN) to be associated with a coindexed actual argument"_err_en_US,
808	dummyName);
809	}
810	if (!actualCoarrayRef && actualLastSymbol && dummy.type.corank() == 0 &&
811	actualLastSymbol->Corank() > 0) {
812	messages.Say(
813	"ALLOCATABLE %s is not a coarray but actual argument has corank %d"_err_en_US,
814	dummyName, actualLastSymbol->Corank());
815	}
816	} else if (evaluate::IsBareNullPointer(&actual)) {
817	if (dummyIsOptional) {
818	} else if (dummy.intent == common::Intent::Default &&
819	context.ShouldWarn(
820	common::UsageWarning::NullActualForDefaultIntentAllocatable)) {
821	messages.Say(
822	"A null pointer should not be associated with allocatable %s without INTENT(IN)"_warn_en_US,
823	dummyName);
824	} else if (dummy.intent == common::Intent::In &&
825	context.ShouldWarn(
826	common::LanguageFeature::NullActualForAllocatable)) {
827	messages.Say(common::LanguageFeature::NullActualForAllocatable,
828	"Allocatable %s is associated with a null pointer"_port_en_US,
829	dummyName);
830	}
831	// INTENT(OUT) and INTENT(IN OUT) cases are caught elsewhere as being
832	// undefinable actual arguments.
833	} else if (evaluate::IsNullAllocatable(&actual)) {
834	if (dummyIsOptional) {
835	} else if (dummy.intent == common::Intent::Default &&
836	context.ShouldWarn(
837	common::UsageWarning::NullActualForDefaultIntentAllocatable)) {
838	messages.Say(
839	"A null allocatable should not be associated with allocatable %s without INTENT(IN)"_warn_en_US,
840	dummyName);
841	}
842	// INTENT(OUT) and INTENT(IN OUT) cases are caught elsewhere
843	} else {
844	messages.Say(
845	"ALLOCATABLE %s must be associated with an ALLOCATABLE actual argument"_err_en_US,
846	dummyName);
847	}
848	}
849
850	// 15.5.2.7 -- dummy is POINTER
851	if (dummyIsPointer) {
852	if (actualIsPointer || dummy.intent == common::Intent::In) {
853	if (scope) {
854	semantics::CheckPointerAssignment(context, messages.at(), dummyName,
855	dummy, actual, *scope,
856	/*isAssumedRank=*/dummyIsAssumedRank, actualIsPointer);
857	}
858	} else if (!actualIsPointer) {
859	messages.Say(
860	"Actual argument associated with POINTER %s must also be POINTER unless INTENT(IN)"_err_en_US,
861	dummyName);
862	}
863	}
864
865	// 15.5.2.5 -- actual & dummy are both POINTER or both ALLOCATABLE
866	// For INTENT(IN), and for a polymorphic actual being associated with a
867	// monomorphic dummy, we relax two checks that are in Fortran to
868	// prevent the callee from changing the type or to avoid having
869	// to use a descriptor.
870	if (!typesCompatible) {
871	// Don't pile on the errors emitted above
872	} else if ((actualIsPointer && dummyIsPointer) ||
873	(actualIsAllocatable && dummyIsAllocatable)) {
874	bool actualIsUnlimited{actualType.type().IsUnlimitedPolymorphic()};
875	bool dummyIsUnlimited{dummy.type.type().IsUnlimitedPolymorphic()};
876	bool checkTypeCompatibility{true};
877	if (actualIsUnlimited != dummyIsUnlimited) {
878	checkTypeCompatibility = false;
879	if (dummyIsUnlimited && dummy.intent == common::Intent::In &&
880	context.IsEnabled(common::LanguageFeature::RelaxedIntentInChecking)) {
881	if (context.ShouldWarn(
882	common::LanguageFeature::RelaxedIntentInChecking)) {
883	messages.Say(common::LanguageFeature::RelaxedIntentInChecking,
884	"If a POINTER or ALLOCATABLE dummy or actual argument is unlimited polymorphic, both should be so"_port_en_US);
885	}
886	} else {
887	messages.Say(
888	"If a POINTER or ALLOCATABLE dummy or actual argument is unlimited polymorphic, both must be so"_err_en_US);
889	}
890	} else if (dummyIsPolymorphic != actualIsPolymorphic) {
891	if (dummyIsPolymorphic && dummy.intent == common::Intent::In &&
892	context.IsEnabled(common::LanguageFeature::RelaxedIntentInChecking)) {
893	if (context.ShouldWarn(
894	common::LanguageFeature::RelaxedIntentInChecking)) {
895	messages.Say(common::LanguageFeature::RelaxedIntentInChecking,
896	"If a POINTER or ALLOCATABLE dummy or actual argument is polymorphic, both should be so"_port_en_US);
897	}
898	} else if (actualIsPolymorphic &&
899	context.IsEnabled(common::LanguageFeature::
900	PolymorphicActualAllocatableOrPointerToMonomorphicDummy)) {
901	if (context.ShouldWarn(common::LanguageFeature::
902	PolymorphicActualAllocatableOrPointerToMonomorphicDummy)) {
903	messages.Say(
904	common::LanguageFeature::
905	PolymorphicActualAllocatableOrPointerToMonomorphicDummy,
906	"If a POINTER or ALLOCATABLE actual argument is polymorphic, the corresponding dummy argument should also be so"_port_en_US);
907	}
908	} else {
909	checkTypeCompatibility = false;
910	messages.Say(
911	"If a POINTER or ALLOCATABLE dummy or actual argument is polymorphic, both must be so"_err_en_US);
912	}
913	}
914	if (checkTypeCompatibility && !actualIsUnlimited) {
915	if (!actualType.type().IsTkCompatibleWith(dummy.type.type())) {
916	if (dummy.intent == common::Intent::In &&
917	context.IsEnabled(
918	common::LanguageFeature::RelaxedIntentInChecking)) {
919	if (context.ShouldWarn(
920	common::LanguageFeature::RelaxedIntentInChecking)) {
921	messages.Say(common::LanguageFeature::RelaxedIntentInChecking,
922	"POINTER or ALLOCATABLE dummy and actual arguments should have the same declared type and kind"_port_en_US);
923	}
924	} else {
925	messages.Say(
926	"POINTER or ALLOCATABLE dummy and actual arguments must have the same declared type and kind"_err_en_US);
927	}
928	}
929	// 15.5.2.5(4)
930	const auto *dummyDerived{evaluate::GetDerivedTypeSpec(dummy.type.type())};
931	if (!DefersSameTypeParameters(actualDerived, dummyDerived) ||
932	dummy.type.type().HasDeferredTypeParameter() !=
933	actualType.type().HasDeferredTypeParameter()) {
934	messages.Say(
935	"Dummy and actual arguments must defer the same type parameters when POINTER or ALLOCATABLE"_err_en_US);
936	}
937	}
938	}
939
940	// 15.5.2.8 -- coarray dummy arguments
941	if (dummy.type.corank() > 0) {
942	if (actualType.corank() == 0) {
943	messages.Say(
944	"Actual argument associated with coarray %s must be a coarray"_err_en_US,
945	dummyName);
946	} else if (actualType.corank() != dummy.type.corank() &&
947	dummyIsAllocatableOrPointer) {
948	messages.Say(
949	"ALLOCATABLE or POINTER %s has corank %d but actual argument has corank %d"_err_en_US,
950	dummyName, dummy.type.corank(), actualType.corank());
951	}
952	if (dummyIsVolatile) {
953	if (!actualIsVolatile) {
954	messages.Say(
955	"non-VOLATILE coarray may not be associated with VOLATILE coarray %s"_err_en_US,
956	dummyName);
957	}
958	} else {
959	if (actualIsVolatile) {
960	messages.Say(
961	"VOLATILE coarray may not be associated with non-VOLATILE coarray %s"_err_en_US,
962	dummyName);
963	}
964	}
965	if (actualRank == dummyRank && !actualIsContiguous) {
966	if (dummyIsContiguous) {
967	messages.Say(
968	"Actual argument associated with a CONTIGUOUS coarray %s must be simply contiguous"_err_en_US,
969	dummyName);
970	} else if (!dummyIsAssumedShape && !dummyIsAssumedRank) {
971	messages.Say(
972	"Actual argument associated with coarray %s (not assumed shape or rank) must be simply contiguous"_err_en_US,
973	dummyName);
974	}
975	}
976	}
977
978	// NULL(MOLD=) checking for non-intrinsic procedures
979	if (!intrinsic && !dummyIsAllocatableOrPointer && !dummyIsOptional &&
980	evaluate::IsNullPointer(&actual)) {
981	messages.Say(
982	"Actual argument associated with %s may not be null pointer %s"_err_en_US,
983	dummyName, actual.AsFortran());
984	}
985
986	// Warn about dubious actual argument association with a TARGET dummy
987	// argument
988	if (dummy.attrs.test(characteristics::DummyDataObject::Attr::Target) &&
989	context.ShouldWarn(common::UsageWarning::NonTargetPassedToTarget)) {
990	bool actualIsVariable{evaluate::IsVariable(actual)};
991	bool actualIsTemp{
992	!actualIsVariable || HasVectorSubscript(actual) || actualCoarrayRef};
993	if (actualIsTemp) {
994	messages.Say(common::UsageWarning::NonTargetPassedToTarget,
995	"Any pointer associated with TARGET %s during this call will not be associated with the value of '%s' afterwards"_warn_en_US,
996	dummyName, actual.AsFortran());
997	} else {
998	auto actualSymbolVector{GetSymbolVector(actual)};
999	if (!evaluate::GetLastTarget(actualSymbolVector)) {
1000	messages.Say(common::UsageWarning::NonTargetPassedToTarget,
1001	"Any pointer associated with TARGET %s during this call must not be used afterwards, as '%s' is not a target"_warn_en_US,
1002	dummyName, actual.AsFortran());
1003	}
1004	}
1005	}
1006
1007	// CUDA specific checks
1008	// TODO: These are disabled in OpenACC constructs, which may not be
1009	// correct when the target is not a GPU.
1010	if (!intrinsic &&
1011	!dummy.attrs.test(characteristics::DummyDataObject::Attr::Value) &&
1012	!FindOpenACCConstructContaining(scope)) {
1013	std::optional<common::CUDADataAttr> actualDataAttr, dummyDataAttr;
1014	if (const auto *actualObject{actualLastSymbol
1015	? actualLastSymbol->detailsIf<ObjectEntityDetails>()
1016	: nullptr}) {
1017	actualDataAttr = actualObject->cudaDataAttr();
1018	}
1019	dummyDataAttr = dummy.cudaDataAttr;
1020	// Treat MANAGED like DEVICE for nonallocatable nonpointer arguments to
1021	// device subprograms
1022	if (procedure.cudaSubprogramAttrs.value_or(
1023	common::CUDASubprogramAttrs::Host) !=
1024	common::CUDASubprogramAttrs::Host &&
1025	!dummy.attrs.test(
1026	characteristics::DummyDataObject::Attr::Allocatable) &&
1027	!dummy.attrs.test(characteristics::DummyDataObject::Attr::Pointer)) {
1028	if (!dummyDataAttr || *dummyDataAttr == common::CUDADataAttr::Managed) {
1029	dummyDataAttr = common::CUDADataAttr::Device;
1030	}
1031	if ((!actualDataAttr && FindCUDADeviceContext(scope)) ||
1032	(actualDataAttr &&
1033	*actualDataAttr == common::CUDADataAttr::Managed)) {
1034	actualDataAttr = common::CUDADataAttr::Device;
1035	}
1036	// For device procedures, treat actual arguments with VALUE attribute as
1037	// device data
1038	if (!actualDataAttr && actualLastSymbol && IsValue(*actualLastSymbol) &&
1039	(*procedure.cudaSubprogramAttrs ==
1040	common::CUDASubprogramAttrs::Device)) {
1041	actualDataAttr = common::CUDADataAttr::Device;
1042	}
1043	}
1044	if (dummyDataAttr == common::CUDADataAttr::Device &&
1045	(dummyIsAssumedShape || dummyIsAssumedRank) &&
1046	!dummy.ignoreTKR.test(common::IgnoreTKR::Contiguous)) {
1047	if (auto contig{evaluate::IsContiguous(actual, foldingContext,
1048	/*namedConstantSectionsAreContiguous=*/true,
1049	/*firstDimensionStride1=*/true)}) {
1050	if (!*contig) {
1051	messages.Say(
1052	"actual argument associated with assumed shape/rank device %s is known to be discontiguous on its first dimension"_err_en_US,
1053	dummyName);
1054	}
1055	} else {
1056	messages.Say(
1057	"actual argument associated with assumed shape/rank device %s is not known to be contiguous on its first dimension"_warn_en_US,
1058	dummyName);
1059	}
1060	}
1061	std::optional<std::string> warning;
1062	bool isHostDeviceProc{procedure.cudaSubprogramAttrs &&
1063	*procedure.cudaSubprogramAttrs ==
1064	common::CUDASubprogramAttrs::HostDevice};
1065	if (!common::AreCompatibleCUDADataAttrs(dummyDataAttr, actualDataAttr,
1066	dummy.ignoreTKR, &warning, /*allowUnifiedMatchingRule=*/true,
1067	isHostDeviceProc, &context.languageFeatures())) {
1068	auto toStr{[](std::optional<common::CUDADataAttr> x) {
1069	return x ? "ATTRIBUTES("s +
1070	parser::ToUpperCaseLetters(common::EnumToString(*x)) + ")"s
1071	: "no CUDA data attribute"s;
1072	}};
1073	messages.Say(
1074	"%s has %s but its associated actual argument has %s"_err_en_US,
1075	dummyName, toStr(dummyDataAttr), toStr(actualDataAttr));
1076	}
1077	if (warning && context.ShouldWarn(common::UsageWarning::CUDAUsage)) {
1078	messages.Say(common::UsageWarning::CUDAUsage, "%s"_warn_en_US,
1079	std::move(*warning));
1080	}
1081	}
1082
1083	// Warning for breaking F'2023 change with character allocatables
1084	if (intrinsic && dummy.intent != common::Intent::In) {
1085	WarnOnDeferredLengthCharacterScalar(
1086	context, &actual, messages.at(), dummyName.c_str());
1087	}
1088
1089	// %VAL() and %REF() checking for explicit interface
1090	if ((arg.isPercentRef() || arg.isPercentVal()) &&
1091	dummy.IsPassedByDescriptor(procedure.IsBindC())) {
1092	messages.Say(
1093	"%%VAL or %%REF are not allowed for %s that must be passed by means of a descriptor"_err_en_US,
1094	dummyName);
1095	}
1096	if (arg.isPercentVal() &&
1097	(!actualType.type().IsLengthlessIntrinsicType() ||
1098	actualType.Rank() != 0)) {
1099	messages.Say(
1100	"%VAL argument must be a scalar numeric or logical expression"_err_en_US);
1101	}
1102	}
1103
1104	static void CheckProcedureArg(evaluate::ActualArgument &arg,
1105	const characteristics::Procedure &proc,
1106	const characteristics::DummyProcedure &dummy, const std::string &dummyName,
1107	SemanticsContext &context, bool ignoreImplicitVsExplicit) {
1108	evaluate::FoldingContext &foldingContext{context.foldingContext()};
1109	parser::ContextualMessages &messages{foldingContext.messages()};
1110	parser::CharBlock location{arg.sourceLocation().value_or(messages.at())};
1111	auto restorer{messages.SetLocation(location)};
1112	const characteristics::Procedure &interface { dummy.procedure.value() };
1113	if (const auto *expr{arg.UnwrapExpr()}) {
1114	bool dummyIsPointer{
1115	dummy.attrs.test(characteristics::DummyProcedure::Attr::Pointer)};
1116	const auto *argProcDesignator{
1117	std::get_if<evaluate::ProcedureDesignator>(&expr->u)};
1118	const auto *argProcSymbol{
1119	argProcDesignator ? argProcDesignator->GetSymbol() : nullptr};
1120	if (argProcSymbol) {
1121	if (const auto *subp{
1122	argProcSymbol->GetUltimate().detailsIf<SubprogramDetails>()}) {
1123	if (subp->stmtFunction()) {
1124	evaluate::SayWithDeclaration(messages, *argProcSymbol,
1125	"Statement function '%s' may not be passed as an actual argument"_err_en_US,
1126	argProcSymbol->name());
1127	return;
1128	}
1129	} else if (argProcSymbol->has<ProcBindingDetails>()) {
1130	if (!context.IsEnabled(common::LanguageFeature::BindingAsProcedure)) {
1131	evaluate::SayWithDeclaration(messages, *argProcSymbol,
1132	"Procedure binding '%s' passed as an actual argument"_err_en_US,
1133	argProcSymbol->name());
1134	} else if (context.ShouldWarn(
1135	common::LanguageFeature::BindingAsProcedure)) {
1136	evaluate::SayWithDeclaration(messages, *argProcSymbol,
1137	common::LanguageFeature::BindingAsProcedure,
1138	"Procedure binding '%s' passed as an actual argument"_port_en_US,
1139	argProcSymbol->name());
1140	}
1141	}
1142	}
1143	if (auto argChars{characteristics::DummyArgument::FromActual(
1144	"actual argument", *expr, foldingContext,
1145	/*forImplicitInterface=*/true)}) {
1146	if (!argChars->IsTypelessIntrinsicDummy()) {
1147	if (auto *argProc{
1148	std::get_if<characteristics::DummyProcedure>(&argChars->u)}) {
1149	characteristics::Procedure &argInterface{argProc->procedure.value()};
1150	argInterface.attrs.reset(
1151	characteristics::Procedure::Attr::NullPointer);
1152	argInterface.attrs.reset(
1153	characteristics::Procedure::Attr::NullAllocatable);
1154	if (!argProcSymbol || argProcSymbol->attrs().test(Attr::INTRINSIC)) {
1155	// It's ok to pass ELEMENTAL unrestricted intrinsic functions.
1156	argInterface.attrs.reset(
1157	characteristics::Procedure::Attr::Elemental);
1158	} else if (argInterface.attrs.test(
1159	characteristics::Procedure::Attr::Elemental)) {
1160	if (argProcSymbol) { // C1533
1161	evaluate::SayWithDeclaration(messages, *argProcSymbol,
1162	"Non-intrinsic ELEMENTAL procedure '%s' may not be passed as an actual argument"_err_en_US,
1163	argProcSymbol->name());
1164	return; // avoid piling on with checks below
1165	} else {
1166	argInterface.attrs.reset(
1167	characteristics::Procedure::Attr::NullPointer);
1168	argInterface.attrs.reset(
1169	characteristics::Procedure::Attr::NullAllocatable);
1170	}
1171	}
1172	if (interface.HasExplicitInterface()) {
1173	std::string whyNot;
1174	std::optional<std::string> warning;
1175	if (!interface.IsCompatibleWith(argInterface,
1176	ignoreImplicitVsExplicit, &whyNot,
1177	/*specificIntrinsic=*/nullptr, &warning)) {
1178	// 15.5.2.9(1): Explicit interfaces must match
1179	if (argInterface.HasExplicitInterface()) {
1180	messages.Say(
1181	"Actual procedure argument has interface incompatible with %s: %s"_err_en_US,
1182	dummyName, whyNot);
1183	return;
1184	} else if (proc.IsPure()) {
1185	messages.Say(
1186	"Actual procedure argument for %s of a PURE procedure must have an explicit interface"_err_en_US,
1187	dummyName);
1188	} else if (context.ShouldWarn(
1189	common::UsageWarning::ImplicitInterfaceActual)) {
1190	messages.Say(common::UsageWarning::ImplicitInterfaceActual,
1191	"Actual procedure argument has an implicit interface which is not known to be compatible with %s which has an explicit interface"_warn_en_US,
1192	dummyName);
1193	}
1194	} else if (warning &&
1195	context.ShouldWarn(common::UsageWarning::ProcDummyArgShapes)) {
1196	messages.Say(common::UsageWarning::ProcDummyArgShapes,
1197	"Actual procedure argument has possible interface incompatibility with %s: %s"_warn_en_US,
1198	dummyName, std::move(*warning));
1199	}
1200	} else { // 15.5.2.9(2,3)
1201	if (interface.IsSubroutine() && argInterface.IsFunction()) {
1202	messages.Say(
1203	"Actual argument associated with procedure %s is a function but must be a subroutine"_err_en_US,
1204	dummyName);
1205	} else if (interface.IsFunction()) {
1206	if (argInterface.IsFunction()) {
1207	std::string whyNot;
1208	if (!interface.functionResult->IsCompatibleWith(
1209	*argInterface.functionResult, &whyNot)) {
1210	messages.Say(
1211	"Actual argument function associated with procedure %s is not compatible: %s"_err_en_US,
1212	dummyName, whyNot);
1213	}
1214	} else if (argInterface.IsSubroutine()) {
1215	messages.Say(
1216	"Actual argument associated with procedure %s is a subroutine but must be a function"_err_en_US,
1217	dummyName);
1218	}
1219	}
1220	}
1221	} else {
1222	messages.Say(
1223	"Actual argument associated with procedure %s is not a procedure"_err_en_US,
1224	dummyName);
1225	}
1226	} else if (IsNullPointer(expr)) {
1227	if (!dummyIsPointer &&
1228	!dummy.attrs.test(
1229	characteristics::DummyProcedure::Attr::Optional)) {
1230	messages.Say(
1231	"Actual argument associated with procedure %s is a null pointer"_err_en_US,
1232	dummyName);
1233	}
1234	} else {
1235	messages.Say(
1236	"Actual argument associated with procedure %s is typeless"_err_en_US,
1237	dummyName);
1238	}
1239	}
1240	if (dummyIsPointer) {
1241	if (dummy.intent == common::Intent::In) {
1242	// need not be definable, can be a target
1243	} else if (!IsProcedurePointer(*expr)) {
1244	messages.Say(
1245	"Actual argument associated with procedure pointer %s is not a procedure pointer"_err_en_US,
1246	dummyName);
1247	} else if (dummy.intent == common::Intent::Default) {
1248	// ok, needs to be definable only if defined at run time
1249	} else {
1250	DefinabilityFlags flags{DefinabilityFlag::PointerDefinition};
1251	if (dummy.intent != common::Intent::Out) {
1252	flags.set(DefinabilityFlag::DoNotNoteDefinition);
1253	}
1254	if (auto whyNot{WhyNotDefinable(
1255	location, context.FindScope(location), flags, *expr)}) {
1256	if (auto *msg{messages.Say(
1257	"Actual argument associated with INTENT(%s) procedure pointer %s is not definable"_err_en_US,
1258	dummy.intent == common::Intent::Out ? "OUT" : "IN OUT",
1259	dummyName)}) {
1260	msg->Attach(
1261	std::move(whyNot->set_severity(parser::Severity::Because)));
1262	}
1263	}
1264	}
1265	}
1266	} else {
1267	messages.Say(
1268	"Assumed-type argument may not be forwarded as procedure %s"_err_en_US,
1269	dummyName);
1270	}
1271	}
1272
1273	// Allow BOZ literal actual arguments when they can be converted to a known
1274	// dummy argument type
1275	static void ConvertBOZLiteralArg(
1276	evaluate::ActualArgument &arg, const evaluate::DynamicType &type) {
1277	if (auto *expr{arg.UnwrapExpr()}) {
1278	if (IsBOZLiteral(*expr)) {
1279	if (auto converted{evaluate::ConvertToType(type, SomeExpr{*expr})}) {
1280	arg = std::move(*converted);
1281	}
1282	}
1283	}
1284	}
1285
1286	static void CheckExplicitInterfaceArg(evaluate::ActualArgument &arg,
1287	const characteristics::DummyArgument &dummy,
1288	const characteristics::Procedure &proc, SemanticsContext &context,
1289	const Scope *scope, const evaluate::SpecificIntrinsic *intrinsic,
1290	bool allowActualArgumentConversions, bool extentErrors,
1291	bool ignoreImplicitVsExplicit) {
1292	evaluate::FoldingContext &foldingContext{context.foldingContext()};
1293	auto &messages{foldingContext.messages()};
1294	std::string dummyName{"dummy argument"};
1295	if (!dummy.name.empty()) {
1296	dummyName += " '"s + parser::ToLowerCaseLetters(dummy.name) + "='";
1297	}
1298	auto restorer{
1299	messages.SetLocation(arg.sourceLocation().value_or(messages.at()))};
1300	auto CheckActualArgForLabel = [&](evaluate::ActualArgument &arg) {
1301	if (arg.isAlternateReturn()) {
1302	messages.Say(
1303	"Alternate return label '%d' cannot be associated with %s"_err_en_US,
1304	arg.GetLabel(), dummyName);
1305	return false;
1306	} else {
1307	return true;
1308	}
1309	};
1310	common::visit(
1311	common::visitors{
1312	[&](const characteristics::DummyDataObject &object) {
1313	if (CheckActualArgForLabel(arg)) {
1314	ConvertBOZLiteralArg(arg, object.type.type());
1315	if (auto *expr{arg.UnwrapExpr()}) {
1316	if (auto type{characteristics::TypeAndShape::Characterize(
1317	*expr, foldingContext)}) {
1318	arg.set_dummyIntent(object.intent);
1319	bool isElemental{
1320	object.type.Rank() == 0 && proc.IsElemental()};
1321	CheckExplicitDataArg(object, dummyName, *expr, *type,
1322	isElemental, context, foldingContext, scope, intrinsic,
1323	allowActualArgumentConversions, extentErrors, proc, arg);
1324	} else if (object.type.type().IsTypelessIntrinsicArgument() &&
1325	IsBOZLiteral(*expr)) {
1326	// ok
1327	} else if (object.type.type().IsTypelessIntrinsicArgument() &&
1328	evaluate::IsNullObjectPointer(expr)) {
1329	// ok, ASSOCIATED(NULL(without MOLD=))
1330	} else if (object.type.attrs().test(characteristics::
1331	TypeAndShape::Attr::AssumedRank) &&
1332	evaluate::IsNullObjectPointer(expr) &&
1333	(object.attrs.test(
1334	characteristics::DummyDataObject::Attr::Allocatable) ||
1335	object.attrs.test(
1336	characteristics::DummyDataObject::Attr::Pointer) ||
1337	!object.attrs.test(characteristics::DummyDataObject::
1338	Attr::Optional))) {
1339	messages.Say(
1340	"NULL() without MOLD= must not be associated with an assumed-rank dummy argument that is ALLOCATABLE, POINTER, or non-OPTIONAL"_err_en_US);
1341	} else if ((object.attrs.test(characteristics::DummyDataObject::
1342	Attr::Pointer) ||
1343	object.attrs.test(characteristics::
1344	DummyDataObject::Attr::Optional)) &&
1345	evaluate::IsNullObjectPointer(expr)) {
1346	// FOO(NULL(without MOLD=))
1347	if (object.type.type().IsAssumedLengthCharacter()) {
1348	messages.Say(
1349	"Actual argument associated with %s is a NULL() pointer without a MOLD= to provide a character length"_err_en_US,
1350	dummyName);
1351	} else if (const DerivedTypeSpec *
1352	derived{GetDerivedTypeSpec(object.type.type())}) {
1353	for (const auto &[pName, pValue] : derived->parameters()) {
1354	if (pValue.isAssumed()) {
1355	messages.Say(
1356	"Actual argument associated with %s is a NULL() pointer without a MOLD= to provide a value for the assumed type parameter '%s'"_err_en_US,
1357	dummyName, pName.ToString());
1358	break;
1359	}
1360	}
1361	}
1362	} else if (object.attrs.test(characteristics::DummyDataObject::
1363	Attr::Allocatable) &&
1364	(evaluate::IsNullAllocatable(expr) ||
1365	evaluate::IsBareNullPointer(expr))) {
1366	if (object.intent == common::Intent::Out ||
1367	object.intent == common::Intent::InOut) {
1368	messages.Say(
1369	"NULL() actual argument '%s' may not be associated with allocatable dummy argument %s that is INTENT(OUT) or INTENT(IN OUT)"_err_en_US,
1370	expr->AsFortran(), dummyName);
1371	} else if (object.intent == common::Intent::Default &&
1372	context.ShouldWarn(common::UsageWarning::
1373	NullActualForDefaultIntentAllocatable)) {
1374	messages.Say(common::UsageWarning::
1375	NullActualForDefaultIntentAllocatable,
1376	"NULL() actual argument '%s' should not be associated with allocatable dummy argument %s without INTENT(IN)"_warn_en_US,
1377	expr->AsFortran(), dummyName);
1378	} else if (context.ShouldWarn(common::LanguageFeature::
1379	NullActualForAllocatable)) {
1380	messages.Say(
1381	common::LanguageFeature::NullActualForAllocatable,
1382	"Allocatable %s is associated with %s"_port_en_US,
1383	dummyName, expr->AsFortran());
1384	}
1385	} else {
1386	messages.Say(
1387	"Actual argument '%s' associated with %s is not a variable or typed expression"_err_en_US,
1388	expr->AsFortran(), dummyName);
1389	}
1390	} else {
1391	const Symbol &assumed{DEREF(arg.GetAssumedTypeDummy())};
1392	if (!object.type.type().IsAssumedType()) {
1393	messages.Say(
1394	"Assumed-type '%s' may be associated only with an assumed-type %s"_err_en_US,
1395	assumed.name(), dummyName);
1396	} else if (object.type.attrs().test(characteristics::
1397	TypeAndShape::Attr::AssumedRank) &&
1398	!IsAssumedShape(assumed) &&
1399	!evaluate::IsAssumedRank(assumed)) {
1400	messages.Say( // C711
1401	"Assumed-type '%s' must be either assumed shape or assumed rank to be associated with assumed rank %s"_err_en_US,
1402	assumed.name(), dummyName);
1403	}
1404	}
1405	}
1406	},
1407	[&](const characteristics::DummyProcedure &dummy) {
1408	if (CheckActualArgForLabel(arg)) {
1409	CheckProcedureArg(arg, proc, dummy, dummyName, context,
1410	ignoreImplicitVsExplicit);
1411	}
1412	},
1413	[&](const characteristics::AlternateReturn &) {
1414	// All semantic checking is done elsewhere
1415	},
1416	},
1417	dummy.u);
1418	}
1419
1420	static void RearrangeArguments(const characteristics::Procedure &proc,
1421	evaluate::ActualArguments &actuals, parser::ContextualMessages &messages) {
1422	CHECK(proc.HasExplicitInterface());
1423	if (actuals.size() < proc.dummyArguments.size()) {
1424	actuals.resize(proc.dummyArguments.size());
1425	} else if (actuals.size() > proc.dummyArguments.size()) {
1426	messages.Say(
1427	"Too many actual arguments (%zd) passed to procedure that expects only %zd"_err_en_US,
1428	actuals.size(), proc.dummyArguments.size());
1429	}
1430	std::map<std::string, evaluate::ActualArgument> kwArgs;
1431	bool anyKeyword{false};
1432	int which{1};
1433	for (auto &x : actuals) {
1434	if (!x) {
1435	} else if (x->keyword()) {
1436	auto emplaced{
1437	kwArgs.try_emplace(x->keyword()->ToString(), std::move(*x))};
1438	if (!emplaced.second) {
1439	messages.Say(*x->keyword(),
1440	"Argument keyword '%s=' appears on more than one effective argument in this procedure reference"_err_en_US,
1441	*x->keyword());
1442	}
1443	x.reset();
1444	anyKeyword = true;
1445	} else if (anyKeyword) {
1446	messages.Say(x ? x->sourceLocation() : std::nullopt,
1447	"Actual argument #%d without a keyword may not follow any actual argument with a keyword"_err_en_US,
1448	which);
1449	}
1450	++which;
1451	}
1452	if (!kwArgs.empty()) {
1453	int index{0};
1454	for (const auto &dummy : proc.dummyArguments) {
1455	if (!dummy.name.empty()) {
1456	auto iter{kwArgs.find(dummy.name)};
1457	if (iter != kwArgs.end()) {
1458	evaluate::ActualArgument &x{iter->second};
1459	if (actuals[index]) {
1460	messages.Say(*x.keyword(),
1461	"Keyword argument '%s=' has already been specified positionally (#%d) in this procedure reference"_err_en_US,
1462	*x.keyword(), index + 1);
1463	} else {
1464	actuals[index] = std::move(x);
1465	}
1466	kwArgs.erase(iter);
1467	}
1468	}
1469	++index;
1470	}
1471	for (auto &bad : kwArgs) {
1472	evaluate::ActualArgument &x{bad.second};
1473	messages.Say(*x.keyword(),
1474	"Argument keyword '%s=' is not recognized for this procedure reference"_err_en_US,
1475	*x.keyword());
1476	}
1477	}
1478	}
1479
1480	// 15.8.1(3) -- In a reference to an elemental procedure, if any argument is an
1481	// array, each actual argument that corresponds to an INTENT(OUT) or
1482	// INTENT(INOUT) dummy argument shall be an array. The actual argument to an
1483	// ELEMENTAL procedure must conform.
1484	static bool CheckElementalConformance(parser::ContextualMessages &messages,
1485	const characteristics::Procedure &proc, evaluate::ActualArguments &actuals,
1486	evaluate::FoldingContext &context) {
1487	std::optional<evaluate::Shape> shape;
1488	std::string shapeName;
1489	int index{0};
1490	bool hasArrayArg{false};
1491	for (const auto &arg : actuals) {
1492	if (arg && !arg->isAlternateReturn() && arg->Rank() > 0) {
1493	hasArrayArg = true;
1494	break;
1495	}
1496	}
1497	for (const auto &arg : actuals) {
1498	const auto &dummy{proc.dummyArguments.at(index++)};
1499	if (arg) {
1500	if (const auto *expr{arg->UnwrapExpr()}) {
1501	if (const auto *wholeSymbol{evaluate::UnwrapWholeSymbolDataRef(arg)}) {
1502	wholeSymbol = &ResolveAssociations(*wholeSymbol);
1503	if (IsAssumedSizeArray(*wholeSymbol)) {
1504	evaluate::SayWithDeclaration(messages, *wholeSymbol,
1505	"Whole assumed-size array '%s' may not be used as an argument to an elemental procedure"_err_en_US,
1506	wholeSymbol->name());
1507	}
1508	}
1509	if (auto argShape{evaluate::GetShape(context, *expr)}) {
1510	if (GetRank(*argShape) > 0) {
1511	std::string argName{"actual argument ("s + expr->AsFortran() +
1512	") corresponding to dummy argument #" + std::to_string(index) +
1513	" ('" + dummy.name + "')"};
1514	if (shape) {
1515	auto tristate{evaluate::CheckConformance(messages, *shape,
1516	*argShape, evaluate::CheckConformanceFlags::None,
1517	shapeName.c_str(), argName.c_str())};
1518	if (tristate && !*tristate) {
1519	return false;
1520	}
1521	} else {
1522	shape = std::move(argShape);
1523	shapeName = argName;
1524	}
1525	} else if ((dummy.GetIntent() == common::Intent::Out ||
1526	dummy.GetIntent() == common::Intent::InOut) &&
1527	hasArrayArg) {
1528	messages.Say(
1529	"In an elemental procedure reference with at least one array argument, actual argument %s that corresponds to an INTENT(OUT) or INTENT(INOUT) dummy argument must be an array"_err_en_US,
1530	expr->AsFortran());
1531	}
1532	}
1533	}
1534	}
1535	}
1536	return true;
1537	}
1538
1539	// ASSOCIATED (16.9.16)
1540	static void CheckAssociated(evaluate::ActualArguments &arguments,
1541	SemanticsContext &semanticsContext, const Scope *scope) {
1542	evaluate::FoldingContext &foldingContext{semanticsContext.foldingContext()};
1543	parser::ContextualMessages &messages{foldingContext.messages()};
1544	bool ok{true};
1545	if (arguments.size() < 2) {
1546	return;
1547	}
1548	if (const auto &pointerArg{arguments[0]}) {
1549	if (const auto *pointerExpr{pointerArg->UnwrapExpr()}) {
1550	if (!IsPointer(*pointerExpr)) {
1551	messages.Say(pointerArg->sourceLocation(),
1552	"POINTER= argument of ASSOCIATED() must be a pointer"_err_en_US);
1553	return;
1554	}
1555	if (const auto &targetArg{arguments[1]}) {
1556	// The standard requires that the TARGET= argument, when present,
1557	// be type compatible with the POINTER= for a data pointer. In
1558	// the case of procedure pointers, the standard requires that it
1559	// be a valid RHS for a pointer assignment that has the POINTER=
1560	// argument as its LHS. Some popular compilers misinterpret this
1561	// requirement more strongly than necessary, and actually validate
1562	// the POINTER= argument as if it were serving as the LHS of a pointer
1563	// assignment. This, perhaps unintentionally, excludes function
1564	// results, including NULL(), from being used there, as well as
1565	// INTENT(IN) dummy pointers. Detect these conditions and emit
1566	// portability warnings.
1567	if (semanticsContext.ShouldWarn(common::UsageWarning::Portability)) {
1568	if (!evaluate::ExtractDataRef(*pointerExpr) &&
1569	!evaluate::IsProcedurePointer(*pointerExpr)) {
1570	messages.Say(common::UsageWarning::Portability,
1571	pointerArg->sourceLocation(),
1572	"POINTER= argument of ASSOCIATED() is required by some other compilers to be a pointer"_port_en_US);
1573	} else if (scope && !evaluate::UnwrapProcedureRef(*pointerExpr)) {
1574	if (auto whyNot{WhyNotDefinable(
1575	pointerArg->sourceLocation().value_or(messages.at()),
1576	*scope,
1577	DefinabilityFlags{DefinabilityFlag::PointerDefinition,
1578	DefinabilityFlag::DoNotNoteDefinition},
1579	*pointerExpr)}) {
1580	if (whyNot->IsFatal()) {
1581	if (auto *msg{messages.Say(common::UsageWarning::Portability,
1582	pointerArg->sourceLocation(),
1583	"POINTER= argument of ASSOCIATED() is required by some other compilers to be a valid left-hand side of a pointer assignment statement"_port_en_US)}) {
1584	msg->Attach(std::move(
1585	whyNot->set_severity(parser::Severity::Because)));
1586	}
1587	} else {
1588	messages.Say(std::move(*whyNot));
1589	}
1590	}
1591	}
1592	}
1593	if (const auto *targetExpr{targetArg->UnwrapExpr()}) {
1594	if (IsProcedurePointer(*pointerExpr) &&
1595	!IsBareNullPointer(pointerExpr)) { // POINTER= is a procedure
1596	if (auto pointerProc{characteristics::Procedure::Characterize(
1597	*pointerExpr, foldingContext)}) {
1598	if (IsBareNullPointer(targetExpr)) {
1599	} else if (IsProcedurePointerTarget(*targetExpr)) {
1600	if (auto targetProc{characteristics::Procedure::Characterize(
1601	*targetExpr, foldingContext)}) {
1602	bool isCall{!!UnwrapProcedureRef(*targetExpr)};
1603	std::string whyNot;
1604	std::optional<std::string> warning;
1605	const auto *targetProcDesignator{
1606	evaluate::UnwrapExpr<evaluate::ProcedureDesignator>(
1607	*targetExpr)};
1608	const evaluate::SpecificIntrinsic *specificIntrinsic{
1609	targetProcDesignator
1610	? targetProcDesignator->GetSpecificIntrinsic()
1611	: nullptr};
1612	std::optional<parser::MessageFixedText> msg{
1613	CheckProcCompatibility(isCall, pointerProc, &*targetProc,
1614	specificIntrinsic, whyNot, warning,
1615	/*ignoreImplicitVsExplicit=*/false)};
1616	std::optional<common::UsageWarning> whichWarning;
1617	if (!msg && warning &&
1618	semanticsContext.ShouldWarn(
1619	common::UsageWarning::ProcDummyArgShapes)) {
1620	whichWarning = common::UsageWarning::ProcDummyArgShapes;
1621	msg =
1622	"Procedures '%s' and '%s' may not be completely compatible: %s"_warn_en_US;
1623	whyNot = std::move(*warning);
1624	} else if (msg && !msg->IsFatal() &&
1625	semanticsContext.ShouldWarn(
1626	common::UsageWarning::ProcPointerCompatibility)) {
1627	whichWarning =
1628	common::UsageWarning::ProcPointerCompatibility;
1629	}
1630	if (msg && (msg->IsFatal() || whichWarning)) {
1631	if (auto *said{messages.Say(std::move(*msg),
1632	"pointer '" + pointerExpr->AsFortran() + "'",
1633	targetExpr->AsFortran(), whyNot)};
1634	said && whichWarning) {
1635	said->set_usageWarning(*whichWarning);
1636	}
1637	}
1638	}
1639	} else if (!IsNullProcedurePointer(targetExpr)) {
1640	messages.Say(
1641	"POINTER= argument '%s' is a procedure pointer but the TARGET= argument '%s' is not a procedure or procedure pointer"_err_en_US,
1642	pointerExpr->AsFortran(), targetExpr->AsFortran());
1643	}
1644	}
1645	} else if (IsVariable(*targetExpr) || IsNullPointer(targetExpr)) {
1646	// Object pointer and target
1647	if (ExtractDataRef(*targetExpr)) {
1648	if (SymbolVector symbols{GetSymbolVector(*targetExpr)};
1649	!evaluate::GetLastTarget(symbols)) {
1650	parser::Message *msg{messages.Say(targetArg->sourceLocation(),
1651	"TARGET= argument '%s' must have either the POINTER or the TARGET attribute"_err_en_US,
1652	targetExpr->AsFortran())};
1653	for (SymbolRef ref : symbols) {
1654	msg = evaluate::AttachDeclaration(msg, *ref);
1655	}
1656	} else if (HasVectorSubscript(*targetExpr) ||
1657	ExtractCoarrayRef(*targetExpr)) {
1658	messages.Say(targetArg->sourceLocation(),
1659	"TARGET= argument '%s' may not have a vector subscript or coindexing"_err_en_US,
1660	targetExpr->AsFortran());
1661	}
1662	}
1663	if (const auto pointerType{pointerArg->GetType()}) {
1664	if (const auto targetType{targetArg->GetType()}) {
1665	ok = pointerType->IsTkCompatibleWith(*targetType) ||
1666	targetType->IsTkCompatibleWith(*pointerType);
1667	}
1668	}
1669	} else {
1670	messages.Say(
1671	"POINTER= argument '%s' is an object pointer but the TARGET= argument '%s' is not a variable"_err_en_US,
1672	pointerExpr->AsFortran(), targetExpr->AsFortran());
1673	}
1674	if (!IsAssumedRank(*pointerExpr)) {
1675	if (IsAssumedRank(*targetExpr)) {
1676	messages.Say(
1677	"TARGET= argument '%s' may not be assumed-rank when POINTER= argument is not"_err_en_US,
1678	pointerExpr->AsFortran());
1679	} else if (pointerExpr->Rank() != targetExpr->Rank()) {
1680	messages.Say(
1681	"POINTER= argument and TARGET= argument have incompatible ranks %d and %d"_err_en_US,
1682	pointerExpr->Rank(), targetExpr->Rank());
1683	}
1684	}
1685	}
1686	}
1687	}
1688	} else {
1689	// No arguments to ASSOCIATED()
1690	ok = false;
1691	}
1692	if (!ok) {
1693	messages.Say(
1694	"Arguments of ASSOCIATED() must be a pointer and an optional valid target"_err_en_US);
1695	}
1696	}
1697
1698	// CO_REDUCE (F'2023 16.9.49)
1699	static void CheckCoReduce(
1700	evaluate::ActualArguments &arguments, evaluate::FoldingContext &context) {
1701	parser::ContextualMessages &messages{context.messages()};
1702	evaluate::CheckForCoindexedObject(
1703	context.messages(), arguments[0], "co_reduce", "a");
1704	evaluate::CheckForCoindexedObject(
1705	context.messages(), arguments[2], "co_reduce", "stat");
1706	evaluate::CheckForCoindexedObject(
1707	context.messages(), arguments[3], "co_reduce", "errmsg");
1708
1709	std::optional<evaluate::DynamicType> aType;
1710	if (const auto &a{arguments[0]}) {
1711	aType = a->GetType();
1712	}
1713	std::optional<characteristics::Procedure> procChars;
1714	if (const auto &operation{arguments[1]}) {
1715	if (const auto *expr{operation->UnwrapExpr()}) {
1716	if (const auto *designator{
1717	std::get_if<evaluate::ProcedureDesignator>(&expr->u)}) {
1718	procChars = characteristics::Procedure::Characterize(
1719	*designator, context, /*emitError=*/true);
1720	} else if (const auto *ref{
1721	std::get_if<evaluate::ProcedureRef>(&expr->u)}) {
1722	procChars = characteristics::Procedure::Characterize(*ref, context);
1723	}
1724	}
1725	}
1726
1727	static constexpr characteristics::DummyDataObject::Attrs notAllowedArgAttrs{
1728	characteristics::DummyDataObject::Attr::Optional,
1729	characteristics::DummyDataObject::Attr::Allocatable,
1730	characteristics::DummyDataObject::Attr::Pointer,
1731	};
1732	static constexpr characteristics::FunctionResult::Attrs
1733	notAllowedFuncResAttrs{
1734	characteristics::FunctionResult::Attr::Allocatable,
1735	characteristics::FunctionResult::Attr::Pointer,
1736	};
1737	const characteristics::TypeAndShape *result{
1738	procChars && procChars->functionResult
1739	? procChars->functionResult->GetTypeAndShape()
1740	: nullptr};
1741	if (!procChars || !procChars->IsPure() ||
1742	procChars->dummyArguments.size() != 2 || !procChars->functionResult) {
1743	messages.Say(
1744	"OPERATION= argument of CO_REDUCE() must be a pure function of two data arguments"_err_en_US);
1745	} else if (procChars->attrs.test(characteristics::Procedure::Attr::BindC)) {
1746	messages.Say(
1747	"A BIND(C) OPERATION= argument of CO_REDUCE() is not supported"_err_en_US);
1748	} else if (!result || result->Rank() != 0) {
1749	messages.Say(
1750	"OPERATION= argument of CO_REDUCE() must be a scalar function"_err_en_US);
1751	} else if (result->type().IsPolymorphic() ||
1752	(aType && !aType->IsTkLenCompatibleWith(result->type()))) {
1753	messages.Say(
1754	"OPERATION= argument of CO_REDUCE() must have the same type as A="_err_en_US);
1755	} else if (((procChars->functionResult->attrs & notAllowedFuncResAttrs) !=
1756	characteristics::FunctionResult::Attrs{}) ||
1757	procChars->functionResult->GetTypeAndShape()->type().IsPolymorphic()) {
1758	messages.Say(
1759	"Result of OPERATION= procedure of CO_REDUCE() must be scalar and neither allocatable, pointer, nor polymorphic"_err_en_US);
1760	} else {
1761	const characteristics::DummyDataObject *data[2]{};
1762	for (int j{0}; j < 2; ++j) {
1763	const auto &dummy{procChars->dummyArguments.at(j)};
1764	data[j] = std::get_if<characteristics::DummyDataObject>(&dummy.u);
1765	}
1766	if (!data[0] || !data[1]) {
1767	messages.Say(
1768	"OPERATION= argument of CO_REDUCE() may not have dummy procedure arguments"_err_en_US);
1769	} else {
1770	for (int j{0}; j < 2; ++j) {
1771	if (((data[j]->attrs & notAllowedArgAttrs) !=
1772	characteristics::DummyDataObject::Attrs{}) ||
1773	data[j]->type.Rank() != 0 || data[j]->type.type().IsPolymorphic() ||
1774	(aType && !data[j]->type.type().IsTkCompatibleWith(*aType))) {
1775	messages.Say(
1776	"Arguments of OPERATION= procedure of CO_REDUCE() must be both scalar of the same type as A=, and neither allocatable, pointer, polymorphic, nor optional"_err_en_US);
1777	break;
1778	}
1779	}
1780	static constexpr characteristics::DummyDataObject::Attrs attrs{
1781	characteristics::DummyDataObject::Attr::Asynchronous,
1782	characteristics::DummyDataObject::Attr::Target,
1783	characteristics::DummyDataObject::Attr::Value,
1784	};
1785	if ((data[0]->attrs & attrs) != (data[1]->attrs & attrs)) {
1786	messages.Say(
1787	"If either argument of the OPERATION= procedure of CO_REDUCE() has the ASYNCHRONOUS, TARGET, or VALUE attribute, both must have that attribute"_err_en_US);
1788	}
1789	}
1790	}
1791	}
1792
1793	// EVENT_QUERY (F'2023 16.9.82)
1794	static void CheckEvent_Query(evaluate::ActualArguments &arguments,
1795	evaluate::FoldingContext &foldingContext) {
1796	if (arguments.size() > 0 && arguments[0] &&
1797	ExtractCoarrayRef(*arguments[0]).has_value()) {
1798	foldingContext.messages().Say(arguments[0]->sourceLocation(),
1799	"EVENT= argument to EVENT_QUERY must not be coindexed"_err_en_US);
1800	}
1801	if (arguments.size() > 1 && arguments[1]) {
1802	if (auto dyType{arguments[1]->GetType()}) {
1803	int defaultInt{
1804	foldingContext.defaults().GetDefaultKind(TypeCategory::Integer)};
1805	if (dyType->category() == TypeCategory::Integer &&
1806	dyType->kind() < defaultInt) {
1807	foldingContext.messages().Say(arguments[1]->sourceLocation(),
1808	"COUNT= argument to EVENT_QUERY must be an integer with kind >= %d"_err_en_US,
1809	defaultInt);
1810	}
1811	}
1812	}
1813	if (arguments.size() > 2 && arguments[2]) {
1814	if (auto dyType{arguments[2]->GetType()}) {
1815	if (dyType->category() == TypeCategory::Integer && dyType->kind() < 2) {
1816	foldingContext.messages().Say(arguments[2]->sourceLocation(),
1817	"STAT= argument to EVENT_QUERY must be an integer with kind >= 2 when present"_err_en_US);
1818	}
1819	}
1820	}
1821	}
1822
1823	// IMAGE_INDEX (F'2023 16.9.107)
1824	static void CheckImage_Index(evaluate::ActualArguments &arguments,
1825	parser::ContextualMessages &messages) {
1826	if (arguments[1] && arguments[0]) {
1827	if (const auto subArrShape{
1828	evaluate::GetShape(arguments[1]->UnwrapExpr())}) {
1829	if (const auto *coarrayArgSymbol{UnwrapWholeSymbolOrComponentDataRef(
1830	arguments[0]->UnwrapExpr())}) {
1831	auto coarrayArgCorank{coarrayArgSymbol->Corank()};
1832	if (auto subArrSize{evaluate::ToInt64(*subArrShape->front())}) {
1833	if (subArrSize != coarrayArgCorank) {
1834	messages.Say(arguments[1]->sourceLocation(),
1835	"The size of 'SUB=' (%jd) for intrinsic 'image_index' must be equal to the corank of 'COARRAY=' (%d)"_err_en_US,
1836	static_cast<std::int64_t>(*subArrSize), coarrayArgCorank);
1837	}
1838	}
1839	}
1840	}
1841	}
1842	}
1843
1844	// Ensure that any optional argument that might be absent at run time
1845	// does not require data conversion.
1846	static void CheckMaxMin(const characteristics::Procedure &proc,
1847	evaluate::ActualArguments &arguments,
1848	parser::ContextualMessages &messages) {
1849	if (proc.functionResult) {
1850	if (const auto *typeAndShape{proc.functionResult->GetTypeAndShape()}) {
1851	for (std::size_t j{2}; j < arguments.size(); ++j) {
1852	if (arguments[j]) {
1853	if (const auto *expr{arguments[j]->UnwrapExpr()};
1854	expr && evaluate::MayBePassedAsAbsentOptional(*expr)) {
1855	if (auto thisType{expr->GetType()}) {
1856	if (thisType->category() == TypeCategory::Character &&
1857	typeAndShape->type().category() == TypeCategory::Character &&
1858	thisType->kind() == typeAndShape->type().kind()) {
1859	// don't care about lengths
1860	} else if (*thisType != typeAndShape->type()) {
1861	messages.Say(arguments[j]->sourceLocation(),
1862	"An actual argument to MAX/MIN requiring data conversion may not be OPTIONAL, POINTER, or ALLOCATABLE"_err_en_US);
1863	}
1864	}
1865	}
1866	}
1867	}
1868	}
1869	}
1870	}
1871
1872	static void CheckFree(evaluate::ActualArguments &arguments,
1873	parser::ContextualMessages &messages) {
1874	if (arguments.size() != 1) {
1875	messages.Say("FREE expects a single argument"_err_en_US);
1876	}
1877	auto arg = arguments[0];
1878	if (const Symbol * symbol{evaluate::UnwrapWholeSymbolDataRef(arg)};
1879	!symbol || !symbol->test(Symbol::Flag::CrayPointer)) {
1880	messages.Say("FREE should only be used with Cray pointers"_warn_en_US);
1881	}
1882	}
1883
1884	// MOVE_ALLOC (F'2023 16.9.147)
1885	static void CheckMove_Alloc(evaluate::ActualArguments &arguments,
1886	parser::ContextualMessages &messages) {
1887	if (arguments.size() >= 1) {
1888	evaluate::CheckForCoindexedObject(
1889	messages, arguments[0], "move_alloc", "from");
1890	}
1891	if (arguments.size() >= 2) {
1892	evaluate::CheckForCoindexedObject(
1893	messages, arguments[1], "move_alloc", "to");
1894	int fromCR{GetCorank(arguments[0])};
1895	int toCR{GetCorank(arguments[1])};
1896	if (fromCR != toCR) {
1897	messages.Say(*arguments[0]->sourceLocation(),
1898	"FROM= argument to MOVE_ALLOC has corank %d, but TO= argument has corank %d"_err_en_US,
1899	fromCR, toCR);
1900	}
1901	}
1902	if (arguments.size() >= 3) {
1903	evaluate::CheckForCoindexedObject(
1904	messages, arguments[2], "move_alloc", "stat");
1905	}
1906	if (arguments.size() >= 4) {
1907	evaluate::CheckForCoindexedObject(
1908	messages, arguments[3], "move_alloc", "errmsg");
1909	}
1910	if (arguments.size() >= 2 && arguments[0] && arguments[1]) {
1911	for (int j{0}; j < 2; ++j) {
1912	if (const Symbol *
1913	whole{UnwrapWholeSymbolOrComponentDataRef(arguments[j])};
1914	!whole || !IsAllocatable(whole->GetUltimate())) {
1915	messages.Say(*arguments[j]->sourceLocation(),
1916	"Argument #%d to MOVE_ALLOC must be allocatable"_err_en_US, j + 1);
1917	}
1918	}
1919	auto type0{arguments[0]->GetType()};
1920	auto type1{arguments[1]->GetType()};
1921	if (type0 && type1 && type0->IsPolymorphic() && !type1->IsPolymorphic()) {
1922	messages.Say(arguments[1]->sourceLocation(),
1923	"When MOVE_ALLOC(FROM=) is polymorphic, TO= must also be polymorphic"_err_en_US);
1924	}
1925	}
1926	}
1927
1928	// PRESENT (F'2023 16.9.163)
1929	static void CheckPresent(evaluate::ActualArguments &arguments,
1930	parser::ContextualMessages &messages) {
1931	if (arguments.size() == 1) {
1932	if (const auto &arg{arguments[0]}; arg) {
1933	const Symbol *symbol{nullptr};
1934	if (const auto *expr{arg->UnwrapExpr()}) {
1935	if (const auto *proc{
1936	std::get_if<evaluate::ProcedureDesignator>(&expr->u)}) {
1937	symbol = proc->GetSymbol();
1938	} else {
1939	symbol = evaluate::UnwrapWholeSymbolDataRef(*expr);
1940	}
1941	} else {
1942	symbol = arg->GetAssumedTypeDummy();
1943	}
1944	if (!symbol ||
1945	!symbol->GetUltimate().attrs().test(semantics::Attr::OPTIONAL)) {
1946	messages.Say(arg ? arg->sourceLocation() : messages.at(),
1947	"Argument of PRESENT() must be the name of a whole OPTIONAL dummy argument"_err_en_US);
1948	}
1949	}
1950	}
1951	}
1952
1953	// REDUCE (F'2023 16.9.173)
1954	static void CheckReduce(
1955	evaluate::ActualArguments &arguments, evaluate::FoldingContext &context) {
1956	std::optional<evaluate::DynamicType> arrayType;
1957	parser::ContextualMessages &messages{context.messages()};
1958	if (const auto &array{arguments[0]}) {
1959	arrayType = array->GetType();
1960	if (!arguments[/*identity=*/4]) {
1961	if (const auto *expr{array->UnwrapExpr()}) {
1962	if (auto shape{
1963	evaluate::GetShape(context, *expr, /*invariantOnly=*/false)}) {
1964	if (const auto &dim{arguments[2]}; dim && array->Rank() > 1) {
1965	// Partial reduction
1966	auto dimVal{evaluate::ToInt64(dim->UnwrapExpr())};
1967	std::int64_t j{0};
1968	int zeroDims{0};
1969	bool isSelectedDimEmpty{false};
1970	for (const auto &extent : *shape) {
1971	++j;
1972	if (evaluate::ToInt64(extent) == 0) {
1973	++zeroDims;
1974	isSelectedDimEmpty |= dimVal && j == *dimVal;
1975	}
1976	}
1977	if (isSelectedDimEmpty && zeroDims == 1) {
1978	messages.Say(
1979	"IDENTITY= must be present when DIM=%d and the array has zero extent on that dimension"_err_en_US,
1980	static_cast<int>(dimVal.value()));
1981	}
1982	} else { // no DIM= or DIM=1 on a vector: total reduction
1983	for (const auto &extent : *shape) {
1984	if (evaluate::ToInt64(extent) == 0) {
1985	messages.Say(
1986	"IDENTITY= must be present when the array is empty and the result is scalar"_err_en_US);
1987	break;
1988	}
1989	}
1990	}
1991	}
1992	}
1993	}
1994	}
1995	std::optional<characteristics::Procedure> procChars;
1996	if (const auto &operation{arguments[1]}) {
1997	if (const auto *expr{operation->UnwrapExpr()}) {
1998	if (const auto *designator{
1999	std::get_if<evaluate::ProcedureDesignator>(&expr->u)}) {
2000	procChars = characteristics::Procedure::Characterize(
2001	*designator, context, /*emitError=*/true);
2002	} else if (const auto *ref{
2003	std::get_if<evaluate::ProcedureRef>(&expr->u)}) {
2004	procChars = characteristics::Procedure::Characterize(*ref, context);
2005	}
2006	}
2007	}
2008	const auto *result{
2009	procChars ? procChars->functionResult->GetTypeAndShape() : nullptr};
2010	if (!procChars || !procChars->IsPure() ||
2011	procChars->dummyArguments.size() != 2 || !procChars->functionResult) {
2012	messages.Say(
2013	"OPERATION= argument of REDUCE() must be a pure function of two data arguments"_err_en_US);
2014	} else if (procChars->attrs.test(characteristics::Procedure::Attr::BindC)) {
2015	messages.Say(
2016	"A BIND(C) OPERATION= argument of REDUCE() is not supported"_err_en_US);
2017	} else if (!result || result->Rank() != 0) {
2018	messages.Say(
2019	"OPERATION= argument of REDUCE() must be a scalar function"_err_en_US);
2020	} else if (result->type().IsPolymorphic() ||
2021	(arrayType && !arrayType->IsTkLenCompatibleWith(result->type()))) {
2022	messages.Say(
2023	"OPERATION= argument of REDUCE() must have the same type as ARRAY="_err_en_US);
2024	} else {
2025	const characteristics::DummyDataObject *data[2]{};
2026	for (int j{0}; j < 2; ++j) {
2027	const auto &dummy{procChars->dummyArguments.at(j)};
2028	data[j] = std::get_if<characteristics::DummyDataObject>(&dummy.u);
2029	}
2030	if (!data[0] || !data[1]) {
2031	messages.Say(
2032	"OPERATION= argument of REDUCE() may not have dummy procedure arguments"_err_en_US);
2033	} else {
2034	for (int j{0}; j < 2; ++j) {
2035	if (data[j]->attrs.test(
2036	characteristics::DummyDataObject::Attr::Optional) ||
2037	data[j]->attrs.test(
2038	characteristics::DummyDataObject::Attr::Allocatable) ||
2039	data[j]->attrs.test(
2040	characteristics::DummyDataObject::Attr::Pointer) ||
2041	data[j]->type.Rank() != 0 || data[j]->type.type().IsPolymorphic() ||
2042	(arrayType &&
2043	!data[j]->type.type().IsTkCompatibleWith(*arrayType))) {
2044	messages.Say(
2045	"Arguments of OPERATION= procedure of REDUCE() must be both scalar of the same type as ARRAY=, and neither allocatable, pointer, polymorphic, nor optional"_err_en_US);
2046	}
2047	}
2048	static constexpr characteristics::DummyDataObject::Attr attrs[]{
2049	characteristics::DummyDataObject::Attr::Asynchronous,
2050	characteristics::DummyDataObject::Attr::Target,
2051	characteristics::DummyDataObject::Attr::Value,
2052	};
2053	for (std::size_t j{0}; j < sizeof attrs / sizeof *attrs; ++j) {
2054	if (data[0]->attrs.test(attrs[j]) != data[1]->attrs.test(attrs[j])) {
2055	messages.Say(
2056	"If either argument of the OPERATION= procedure of REDUCE() has the ASYNCHRONOUS, TARGET, or VALUE attribute, both must have that attribute"_err_en_US);
2057	break;
2058	}
2059	}
2060	}
2061	}
2062	// When the MASK= is present and has no .TRUE. element, and there is
2063	// no IDENTITY=, it's an error.
2064	if (const auto &mask{arguments[3]}; mask && !arguments[/*identity*/ 4]) {
2065	if (const auto *expr{mask->UnwrapExpr()}) {
2066	if (const auto *logical{
2067	std::get_if<evaluate::Expr<evaluate::SomeLogical>>(&expr->u)}) {
2068	if (common::visit(
2069	[](const auto &kindExpr) {
2070	using KindExprType = std::decay_t<decltype(kindExpr)>;
2071	using KindLogical = typename KindExprType::Result;
2072	if (const auto *c{evaluate::UnwrapConstantValue<KindLogical>(
2073	kindExpr)}) {
2074	for (const auto &element : c->values()) {
2075	if (element.IsTrue()) {
2076	return false;
2077	}
2078	}
2079	return true;
2080	}
2081	return false;
2082	},
2083	logical->u)) {
2084	messages.Say(
2085	"MASK= has no .TRUE. element, so IDENTITY= must be present"_err_en_US);
2086	}
2087	}
2088	}
2089	}
2090	}
2091
2092	// TRANSFER (16.9.193)
2093	static void CheckTransferOperandType(SemanticsContext &context,
2094	const evaluate::DynamicType &type, const char *which) {
2095	if (type.IsPolymorphic() &&
2096	context.ShouldWarn(common::UsageWarning::PolymorphicTransferArg)) {
2097	context.foldingContext().messages().Say(
2098	common::UsageWarning::PolymorphicTransferArg,
2099	"%s of TRANSFER is polymorphic"_warn_en_US, which);
2100	} else if (!type.IsUnlimitedPolymorphic() &&
2101	type.category() == TypeCategory::Derived &&
2102	context.ShouldWarn(common::UsageWarning::PointerComponentTransferArg)) {
2103	DirectComponentIterator directs{type.GetDerivedTypeSpec()};
2104	if (auto bad{std::find_if(directs.begin(), directs.end(), IsDescriptor)};
2105	bad != directs.end()) {
2106	evaluate::SayWithDeclaration(context.foldingContext().messages(), *bad,
2107	common::UsageWarning::PointerComponentTransferArg,
2108	"%s of TRANSFER contains allocatable or pointer component %s"_warn_en_US,
2109	which, bad.BuildResultDesignatorName());
2110	}
2111	}
2112	}
2113
2114	static void CheckTransfer(evaluate::ActualArguments &arguments,
2115	SemanticsContext &context, const Scope *scope) {
2116	evaluate::FoldingContext &foldingContext{context.foldingContext()};
2117	parser::ContextualMessages &messages{foldingContext.messages()};
2118	if (arguments.size() >= 2) {
2119	if (auto source{characteristics::TypeAndShape::Characterize(
2120	arguments[0], foldingContext)}) {
2121	CheckTransferOperandType(context, source->type(), "Source");
2122	if (auto mold{characteristics::TypeAndShape::Characterize(
2123	arguments[1], foldingContext)}) {
2124	CheckTransferOperandType(context, mold->type(), "Mold");
2125	if (mold->Rank() > 0 &&
2126	evaluate::ToInt64(
2127	evaluate::Fold(foldingContext,
2128	mold->MeasureElementSizeInBytes(foldingContext, false)))
2129	.value_or(1) == 0) {
2130	if (auto sourceSize{evaluate::ToInt64(evaluate::Fold(foldingContext,
2131	source->MeasureSizeInBytes(foldingContext)))}) {
2132	if (*sourceSize > 0) {
2133	messages.Say(
2134	"Element size of MOLD= array may not be zero when SOURCE= is not empty"_err_en_US);
2135	}
2136	} else if (context.ShouldWarn(common::UsageWarning::VoidMold)) {
2137	messages.Say(common::UsageWarning::VoidMold,
2138	"Element size of MOLD= array may not be zero unless SOURCE= is empty"_warn_en_US);
2139	}
2140	}
2141	}
2142	}
2143	if (arguments.size() > 2) { // SIZE=
2144	if (const Symbol *
2145	whole{UnwrapWholeSymbolOrComponentDataRef(arguments[2])}) {
2146	if (IsOptional(*whole)) {
2147	messages.Say(
2148	"SIZE= argument may not be the optional dummy argument '%s'"_err_en_US,
2149	whole->name());
2150	} else if (context.ShouldWarn(
2151	common::UsageWarning::TransferSizePresence) &&
2152	IsAllocatableOrObjectPointer(whole)) {
2153	messages.Say(common::UsageWarning::TransferSizePresence,
2154	"SIZE= argument that is allocatable or pointer must be present at execution; parenthesize to silence this warning"_warn_en_US);
2155	}
2156	}
2157	}
2158	}
2159	}
2160
2161	static void CheckSpecificIntrinsic(const characteristics::Procedure &proc,
2162	evaluate::ActualArguments &arguments, SemanticsContext &context,
2163	const Scope *scope, const evaluate::SpecificIntrinsic &intrinsic) {
2164	if (intrinsic.name == "associated") {
2165	CheckAssociated(arguments, context, scope);
2166	} else if (intrinsic.name == "co_reduce") {
2167	CheckCoReduce(arguments, context.foldingContext());
2168	} else if (intrinsic.name == "event_query") {
2169	CheckEvent_Query(arguments, context.foldingContext());
2170	} else if (intrinsic.name == "image_index") {
2171	CheckImage_Index(arguments, context.foldingContext().messages());
2172	} else if (intrinsic.name == "max" || intrinsic.name == "min") {
2173	CheckMaxMin(proc, arguments, context.foldingContext().messages());
2174	} else if (intrinsic.name == "move_alloc") {
2175	CheckMove_Alloc(arguments, context.foldingContext().messages());
2176	} else if (intrinsic.name == "present") {
2177	CheckPresent(arguments, context.foldingContext().messages());
2178	} else if (intrinsic.name == "reduce") {
2179	CheckReduce(arguments, context.foldingContext());
2180	} else if (intrinsic.name == "transfer") {
2181	CheckTransfer(arguments, context, scope);
2182	} else if (intrinsic.name == "free") {
2183	CheckFree(arguments, context.foldingContext().messages());
2184	}
2185	}
2186
2187	static parser::Messages CheckExplicitInterface(
2188	const characteristics::Procedure &proc, evaluate::ActualArguments &actuals,
2189	SemanticsContext &context, const Scope *scope,
2190	const evaluate::SpecificIntrinsic *intrinsic,
2191	bool allowActualArgumentConversions, bool extentErrors,
2192	bool ignoreImplicitVsExplicit) {
2193	evaluate::FoldingContext &foldingContext{context.foldingContext()};
2194	parser::ContextualMessages &messages{foldingContext.messages()};
2195	parser::Messages buffer;
2196	auto restorer{messages.SetMessages(buffer)};
2197	RearrangeArguments(proc, actuals, messages);
2198	if (!buffer.empty()) {
2199	return buffer;
2200	}
2201	int index{0};
2202	for (auto &actual : actuals) {
2203	const auto &dummy{proc.dummyArguments.at(index++)};
2204	if (actual) {
2205	CheckExplicitInterfaceArg(*actual, dummy, proc, context, scope, intrinsic,
2206	allowActualArgumentConversions, extentErrors,
2207	ignoreImplicitVsExplicit);
2208	} else if (!dummy.IsOptional()) {
2209	if (dummy.name.empty()) {
2210	messages.Say(
2211	"Dummy argument #%d is not OPTIONAL and is not associated with "
2212	"an actual argument in this procedure reference"_err_en_US,
2213	index);
2214	} else {
2215	messages.Say("Dummy argument '%s=' (#%d) is not OPTIONAL and is not "
2216	"associated with an actual argument in this procedure "
2217	"reference"_err_en_US,
2218	dummy.name, index);
2219	}
2220	}
2221	}
2222	if (proc.IsElemental() && !buffer.AnyFatalError()) {
2223	CheckElementalConformance(messages, proc, actuals, foldingContext);
2224	}
2225	if (intrinsic) {
2226	CheckSpecificIntrinsic(proc, actuals, context, scope, *intrinsic);
2227	}
2228	return buffer;
2229	}
2230
2231	bool CheckInterfaceForGeneric(const characteristics::Procedure &proc,
2232	evaluate::ActualArguments &actuals, SemanticsContext &context,
2233	bool allowActualArgumentConversions) {
2234	return proc.HasExplicitInterface() &&
2235	!CheckExplicitInterface(proc, actuals, context, nullptr, nullptr,
2236	allowActualArgumentConversions, /*extentErrors=*/false,
2237	/*ignoreImplicitVsExplicit=*/false)
2238	.AnyFatalError();
2239	}
2240
2241	bool CheckArgumentIsConstantExprInRange(
2242	const evaluate::ActualArguments &actuals, int index, int lowerBound,
2243	int upperBound, parser::ContextualMessages &messages) {
2244	CHECK(index >= 0 && static_cast<unsigned>(index) < actuals.size());
2245
2246	const std::optional<evaluate::ActualArgument> &argOptional{actuals[index]};
2247	if (!argOptional) {
2248	DIE("Actual argument should have value");
2249	return false;
2250	}
2251
2252	const evaluate::ActualArgument &arg{argOptional.value()};
2253	const evaluate::Expr<evaluate::SomeType> *argExpr{arg.UnwrapExpr()};
2254	CHECK(argExpr != nullptr);
2255
2256	if (!IsConstantExpr(*argExpr)) {
2257	messages.Say("Actual argument #%d must be a constant expression"_err_en_US,
2258	index + 1);
2259	return false;
2260	}
2261
2262	// This does not imply that the kind of the argument is 8. The kind
2263	// for the intrinsic's argument should have been check prior. This is just
2264	// a conversion so that we can read the constant value.
2265	auto scalarValue{evaluate::ToInt64(argExpr)};
2266	CHECK(scalarValue.has_value());
2267
2268	if (*scalarValue < lowerBound || *scalarValue > upperBound) {
2269	messages.Say(
2270	"Argument #%d must be a constant expression in range %d to %d"_err_en_US,
2271	index + 1, lowerBound, upperBound);
2272	return false;
2273	}
2274	return true;
2275	}
2276
2277	bool CheckPPCIntrinsic(const Symbol &generic, const Symbol &specific,
2278	const evaluate::ActualArguments &actuals,
2279	evaluate::FoldingContext &context) {
2280	parser::ContextualMessages &messages{context.messages()};
2281
2282	if (specific.name() == "__ppc_mtfsf") {
2283	return CheckArgumentIsConstantExprInRange(actuals, 0, 0, 7, messages);
2284	}
2285	if (specific.name() == "__ppc_mtfsfi") {
2286	return CheckArgumentIsConstantExprInRange(actuals, 0, 0, 7, messages) &&
2287	CheckArgumentIsConstantExprInRange(actuals, 1, 0, 15, messages);
2288	}
2289	if (specific.name().ToString().compare(0, 14, "__ppc_vec_sld_") == 0) {
2290	return CheckArgumentIsConstantExprInRange(actuals, 2, 0, 15, messages);
2291	}
2292	if (specific.name().ToString().compare(0, 15, "__ppc_vec_sldw_") == 0) {
2293	return CheckArgumentIsConstantExprInRange(actuals, 2, 0, 3, messages);
2294	}
2295	if (specific.name().ToString().compare(0, 14, "__ppc_vec_ctf_") == 0) {
2296	return CheckArgumentIsConstantExprInRange(actuals, 1, 0, 31, messages);
2297	}
2298	if (specific.name().ToString().compare(0, 16, "__ppc_vec_permi_") == 0) {
2299	return CheckArgumentIsConstantExprInRange(actuals, 2, 0, 3, messages);
2300	}
2301	if (specific.name().ToString().compare(0, 21, "__ppc_vec_splat_s32__") == 0) {
2302	return CheckArgumentIsConstantExprInRange(actuals, 0, -16, 15, messages);
2303	}
2304	if (specific.name().ToString().compare(0, 16, "__ppc_vec_splat_") == 0) {
2305	// The value of arg2 in vec_splat must be a constant expression that is
2306	// greater than or equal to 0, and less than the number of elements in arg1.
2307	auto *expr{actuals[0].value().UnwrapExpr()};
2308	auto type{characteristics::TypeAndShape::Characterize(*expr, context)};
2309	assert(type && "unknown type");
2310	const auto *derived{evaluate::GetDerivedTypeSpec(type.value().type())};
2311	if (derived && derived->IsVectorType()) {
2312	for (const auto &pair : derived->parameters()) {
2313	if (pair.first == "element_kind") {
2314	auto vecElemKind{Fortran::evaluate::ToInt64(pair.second.GetExplicit())
2315	.value_or(0)};
2316	auto numElem{vecElemKind == 0 ? 0 : (16 / vecElemKind)};
2317	return CheckArgumentIsConstantExprInRange(
2318	actuals, 1, 0, numElem - 1, messages);
2319	}
2320	}
2321	} else
2322	assert(false && "vector type is expected");
2323	}
2324	return false;
2325	}
2326
2327	bool CheckWindowsIntrinsic(
2328	const Symbol &intrinsic, evaluate::FoldingContext &foldingContext) {
2329	parser::ContextualMessages &messages{foldingContext.messages()};
2330	// TODO: there are other intrinsics that are unsupported on Windows that
2331	// should be added here.
2332	if (intrinsic.name() == "getuid") {
2333	messages.Say(
2334	"User IDs do not exist on Windows. This function will always return 1"_warn_en_US);
2335	}
2336	if (intrinsic.name() == "getgid") {
2337	messages.Say(
2338	"Group IDs do not exist on Windows. This function will always return 1"_warn_en_US);
2339	}
2340	return true;
2341	}
2342
2343	bool CheckArguments(const characteristics::Procedure &proc,
2344	evaluate::ActualArguments &actuals, SemanticsContext &context,
2345	const Scope &scope, bool treatingExternalAsImplicit,
2346	bool ignoreImplicitVsExplicit,
2347	const evaluate::SpecificIntrinsic *intrinsic) {
2348	bool explicitInterface{proc.HasExplicitInterface()};
2349	evaluate::FoldingContext foldingContext{context.foldingContext()};
2350	parser::ContextualMessages &messages{foldingContext.messages()};
2351	bool allowArgumentConversions{true};
2352	if (!explicitInterface || treatingExternalAsImplicit) {
2353	parser::Messages buffer;
2354	{
2355	auto restorer{messages.SetMessages(buffer)};
2356	for (auto &actual : actuals) {
2357	if (actual) {
2358	CheckImplicitInterfaceArg(*actual, messages, context);
2359	}
2360	}
2361	}
2362	if (!buffer.empty()) {
2363	if (auto *msgs{messages.messages()}) {
2364	msgs->Annex(std::move(buffer));
2365	}
2366	return false; // don't pile on
2367	}
2368	allowArgumentConversions = false;
2369	}
2370	if (explicitInterface) {
2371	auto buffer{CheckExplicitInterface(proc, actuals, context, &scope,
2372	intrinsic, allowArgumentConversions,
2373	/*extentErrors=*/true, ignoreImplicitVsExplicit)};
2374	if (!buffer.empty()) {
2375	if (treatingExternalAsImplicit) {
2376	if (context.ShouldWarn(
2377	common::UsageWarning::KnownBadImplicitInterface)) {
2378	if (auto *msg{messages.Say(
2379	common::UsageWarning::KnownBadImplicitInterface,
2380	"If the procedure's interface were explicit, this reference would be in error"_warn_en_US)}) {
2381	buffer.AttachTo(*msg, parser::Severity::Because);
2382	}
2383	} else {
2384	buffer.clear();
2385	}
2386	}
2387	if (auto *msgs{messages.messages()}) {
2388	msgs->Annex(std::move(buffer));
2389	}
2390	return false;
2391	}
2392	}
2393	return true;
2394	}
2395	} // namespace Fortran::semantics
2396