check-call.cpp source code [flang/lib/Semantics/check-call.cpp]

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

source code of flang/lib/Semantics/check-call.cpp