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 "pointer-assignment.h"
11 #include "flang/Evaluate/characteristics.h"
12 #include "flang/Evaluate/check-expression.h"
13 #include "flang/Evaluate/shape.h"
14 #include "flang/Evaluate/tools.h"
15 #include "flang/Parser/characters.h"
16 #include "flang/Parser/message.h"
17 #include "flang/Semantics/scope.h"
18 #include "flang/Semantics/tools.h"
19 #include <map>
20 #include <string>
21 
22 using namespace Fortran::parser::literals;
23 namespace characteristics = Fortran::evaluate::characteristics;
24 
25 namespace Fortran::semantics {
26 
27 static void CheckImplicitInterfaceArg(
28     evaluate::ActualArgument &arg, parser::ContextualMessages &messages) {
29   if (auto kw{arg.keyword()}) {
30     messages.Say(*kw,
31         "Keyword '%s=' may not appear in a reference to a procedure with an implicit interface"_err_en_US,
32         *kw);
33   }
34   if (auto type{arg.GetType()}) {
35     if (type->IsAssumedType()) {
36       messages.Say(
37           "Assumed type argument requires an explicit interface"_err_en_US);
38     } else if (type->IsPolymorphic()) {
39       messages.Say(
40           "Polymorphic argument requires an explicit interface"_err_en_US);
41     } else if (const DerivedTypeSpec * derived{GetDerivedTypeSpec(type)}) {
42       if (!derived->parameters().empty()) {
43         messages.Say(
44             "Parameterized derived type argument requires an explicit interface"_err_en_US);
45       }
46     }
47   }
48   if (const auto *expr{arg.UnwrapExpr()}) {
49     if (IsBOZLiteral(*expr)) {
50       messages.Say("BOZ argument requires an explicit interface"_err_en_US);
51     } else if (evaluate::IsNullPointer(*expr)) {
52       messages.Say(
53           "Null pointer argument requires an explicit interface"_err_en_US);
54     } else if (auto named{evaluate::ExtractNamedEntity(*expr)}) {
55       const Symbol &symbol{named->GetLastSymbol()};
56       if (symbol.Corank() > 0) {
57         messages.Say(
58             "Coarray argument requires an explicit interface"_err_en_US);
59       }
60       if (const auto *details{symbol.detailsIf<ObjectEntityDetails>()}) {
61         if (details->IsAssumedRank()) {
62           messages.Say(
63               "Assumed rank argument requires an explicit interface"_err_en_US);
64         }
65       }
66       if (symbol.attrs().test(Attr::ASYNCHRONOUS)) {
67         messages.Say(
68             "ASYNCHRONOUS argument requires an explicit interface"_err_en_US);
69       }
70       if (symbol.attrs().test(Attr::VOLATILE)) {
71         messages.Say(
72             "VOLATILE argument requires an explicit interface"_err_en_US);
73       }
74     }
75   }
76 }
77 
78 // When scalar CHARACTER actual arguments are known to be short,
79 // we extend them on the right with spaces and a warning.
80 static void PadShortCharacterActual(evaluate::Expr<evaluate::SomeType> &actual,
81     const characteristics::TypeAndShape &dummyType,
82     characteristics::TypeAndShape &actualType,
83     evaluate::FoldingContext &context, parser::ContextualMessages &messages) {
84   if (dummyType.type().category() == TypeCategory::Character &&
85       actualType.type().category() == TypeCategory::Character &&
86       dummyType.type().kind() == actualType.type().kind() &&
87       GetRank(actualType.shape()) == 0) {
88     if (dummyType.LEN() && actualType.LEN()) {
89       auto dummyLength{ToInt64(Fold(context, common::Clone(*dummyType.LEN())))};
90       auto actualLength{
91           ToInt64(Fold(context, common::Clone(*actualType.LEN())))};
92       if (dummyLength && actualLength && *actualLength < *dummyLength) {
93         messages.Say(
94             "Actual length '%jd' is less than expected length '%jd'"_en_US,
95             *actualLength, *dummyLength);
96         auto converted{ConvertToType(dummyType.type(), std::move(actual))};
97         CHECK(converted);
98         actual = std::move(*converted);
99         actualType.set_LEN(SubscriptIntExpr{*dummyLength});
100       }
101     }
102   }
103 }
104 
105 // Automatic conversion of different-kind INTEGER scalar actual
106 // argument expressions (not variables) to INTEGER scalar dummies.
107 // We return nonstandard INTEGER(8) results from intrinsic functions
108 // like SIZE() by default in order to facilitate the use of large
109 // arrays.  Emit a warning when downconverting.
110 static void ConvertIntegerActual(evaluate::Expr<evaluate::SomeType> &actual,
111     const characteristics::TypeAndShape &dummyType,
112     characteristics::TypeAndShape &actualType,
113     parser::ContextualMessages &messages) {
114   if (dummyType.type().category() == TypeCategory::Integer &&
115       actualType.type().category() == TypeCategory::Integer &&
116       dummyType.type().kind() != actualType.type().kind() &&
117       GetRank(dummyType.shape()) == 0 && GetRank(actualType.shape()) == 0 &&
118       !evaluate::IsVariable(actual)) {
119     auto converted{
120         evaluate::ConvertToType(dummyType.type(), std::move(actual))};
121     CHECK(converted);
122     actual = std::move(*converted);
123     if (dummyType.type().kind() < actualType.type().kind()) {
124       messages.Say(
125           "Actual argument scalar expression of type INTEGER(%d) was converted to smaller dummy argument type INTEGER(%d)"_en_US,
126           actualType.type().kind(), dummyType.type().kind());
127     }
128     actualType = dummyType;
129   }
130 }
131 
132 static bool DefersSameTypeParameters(
133     const DerivedTypeSpec &actual, const DerivedTypeSpec &dummy) {
134   for (const auto &pair : actual.parameters()) {
135     const ParamValue &actualValue{pair.second};
136     const ParamValue *dummyValue{dummy.FindParameter(pair.first)};
137     if (!dummyValue || (actualValue.isDeferred() != dummyValue->isDeferred())) {
138       return false;
139     }
140   }
141   return true;
142 }
143 
144 static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
145     const std::string &dummyName, evaluate::Expr<evaluate::SomeType> &actual,
146     characteristics::TypeAndShape &actualType, bool isElemental,
147     evaluate::FoldingContext &context, const Scope *scope,
148     const evaluate::SpecificIntrinsic *intrinsic,
149     bool allowIntegerConversions) {
150 
151   // Basic type & rank checking
152   parser::ContextualMessages &messages{context.messages()};
153   PadShortCharacterActual(actual, dummy.type, actualType, context, messages);
154   if (allowIntegerConversions) {
155     ConvertIntegerActual(actual, dummy.type, actualType, messages);
156   }
157   bool typesCompatible{dummy.type.type().IsTkCompatibleWith(actualType.type())};
158   if (typesCompatible) {
159     if (isElemental) {
160     } else if (dummy.type.attrs().test(
161                    characteristics::TypeAndShape::Attr::AssumedRank)) {
162     } else if (!dummy.type.attrs().test(
163                    characteristics::TypeAndShape::Attr::AssumedShape) &&
164         (actualType.Rank() > 0 || IsArrayElement(actual))) {
165       // Sequence association (15.5.2.11) applies -- rank need not match
166       // if the actual argument is an array or array element designator.
167     } else {
168       // Let CheckConformance accept scalars; storage association
169       // cases are checked here below.
170       CheckConformance(messages, dummy.type.shape(), actualType.shape(),
171           evaluate::CheckConformanceFlags::EitherScalarExpandable,
172           "dummy argument", "actual argument");
173     }
174   } else {
175     const auto &len{actualType.LEN()};
176     messages.Say(
177         "Actual argument type '%s' is not compatible with dummy argument type '%s'"_err_en_US,
178         actualType.type().AsFortran(len ? len->AsFortran() : ""),
179         dummy.type.type().AsFortran());
180   }
181 
182   bool actualIsPolymorphic{actualType.type().IsPolymorphic()};
183   bool dummyIsPolymorphic{dummy.type.type().IsPolymorphic()};
184   bool actualIsCoindexed{ExtractCoarrayRef(actual).has_value()};
185   bool actualIsAssumedSize{actualType.attrs().test(
186       characteristics::TypeAndShape::Attr::AssumedSize)};
187   bool dummyIsAssumedSize{dummy.type.attrs().test(
188       characteristics::TypeAndShape::Attr::AssumedSize)};
189   bool dummyIsAsynchronous{
190       dummy.attrs.test(characteristics::DummyDataObject::Attr::Asynchronous)};
191   bool dummyIsVolatile{
192       dummy.attrs.test(characteristics::DummyDataObject::Attr::Volatile)};
193   bool dummyIsValue{
194       dummy.attrs.test(characteristics::DummyDataObject::Attr::Value)};
195 
196   if (actualIsPolymorphic && dummyIsPolymorphic &&
197       actualIsCoindexed) { // 15.5.2.4(2)
198     messages.Say(
199         "Coindexed polymorphic object may not be associated with a polymorphic %s"_err_en_US,
200         dummyName);
201   }
202   if (actualIsPolymorphic && !dummyIsPolymorphic &&
203       actualIsAssumedSize) { // 15.5.2.4(2)
204     messages.Say(
205         "Assumed-size polymorphic array may not be associated with a monomorphic %s"_err_en_US,
206         dummyName);
207   }
208 
209   // Derived type actual argument checks
210   const Symbol *actualFirstSymbol{evaluate::GetFirstSymbol(actual)};
211   bool actualIsAsynchronous{
212       actualFirstSymbol && actualFirstSymbol->attrs().test(Attr::ASYNCHRONOUS)};
213   bool actualIsVolatile{
214       actualFirstSymbol && actualFirstSymbol->attrs().test(Attr::VOLATILE)};
215   if (const auto *derived{evaluate::GetDerivedTypeSpec(actualType.type())}) {
216     if (dummy.type.type().IsAssumedType()) {
217       if (!derived->parameters().empty()) { // 15.5.2.4(2)
218         messages.Say(
219             "Actual argument associated with TYPE(*) %s may not have a parameterized derived type"_err_en_US,
220             dummyName);
221       }
222       if (const Symbol *
223           tbp{FindImmediateComponent(*derived, [](const Symbol &symbol) {
224             return symbol.has<ProcBindingDetails>();
225           })}) { // 15.5.2.4(2)
226         evaluate::SayWithDeclaration(messages, *tbp,
227             "Actual argument associated with TYPE(*) %s may not have type-bound procedure '%s'"_err_en_US,
228             dummyName, tbp->name());
229       }
230       const auto &finals{
231           derived->typeSymbol().get<DerivedTypeDetails>().finals()};
232       if (!finals.empty()) { // 15.5.2.4(2)
233         if (auto *msg{messages.Say(
234                 "Actual argument associated with TYPE(*) %s may not have derived type '%s' with FINAL subroutine '%s'"_err_en_US,
235                 dummyName, derived->typeSymbol().name(),
236                 finals.begin()->first)}) {
237           msg->Attach(finals.begin()->first,
238               "FINAL subroutine '%s' in derived type '%s'"_en_US,
239               finals.begin()->first, derived->typeSymbol().name());
240         }
241       }
242     }
243     if (actualIsCoindexed) {
244       if (dummy.intent != common::Intent::In && !dummyIsValue) {
245         if (auto bad{
246                 FindAllocatableUltimateComponent(*derived)}) { // 15.5.2.4(6)
247           evaluate::SayWithDeclaration(messages, *bad,
248               "Coindexed actual argument with ALLOCATABLE ultimate component '%s' must be associated with a %s with VALUE or INTENT(IN) attributes"_err_en_US,
249               bad.BuildResultDesignatorName(), dummyName);
250         }
251       }
252       if (auto coarrayRef{evaluate::ExtractCoarrayRef(actual)}) { // C1537
253         const Symbol &coarray{coarrayRef->GetLastSymbol()};
254         if (const DeclTypeSpec * type{coarray.GetType()}) {
255           if (const DerivedTypeSpec * derived{type->AsDerived()}) {
256             if (auto bad{semantics::FindPointerUltimateComponent(*derived)}) {
257               evaluate::SayWithDeclaration(messages, coarray,
258                   "Coindexed object '%s' with POINTER ultimate component '%s' cannot be associated with %s"_err_en_US,
259                   coarray.name(), bad.BuildResultDesignatorName(), dummyName);
260             }
261           }
262         }
263       }
264     }
265     if (actualIsVolatile != dummyIsVolatile) { // 15.5.2.4(22)
266       if (auto bad{semantics::FindCoarrayUltimateComponent(*derived)}) {
267         evaluate::SayWithDeclaration(messages, *bad,
268             "VOLATILE attribute must match for %s when actual argument has a coarray ultimate component '%s'"_err_en_US,
269             dummyName, bad.BuildResultDesignatorName());
270       }
271     }
272   }
273 
274   // Rank and shape checks
275   const auto *actualLastSymbol{evaluate::GetLastSymbol(actual)};
276   if (actualLastSymbol) {
277     actualLastSymbol = &ResolveAssociations(*actualLastSymbol);
278   }
279   const ObjectEntityDetails *actualLastObject{actualLastSymbol
280           ? actualLastSymbol->detailsIf<ObjectEntityDetails>()
281           : nullptr};
282   int actualRank{evaluate::GetRank(actualType.shape())};
283   bool actualIsPointer{evaluate::IsObjectPointer(actual, context)};
284   bool dummyIsAssumedRank{dummy.type.attrs().test(
285       characteristics::TypeAndShape::Attr::AssumedRank)};
286   if (dummy.type.attrs().test(
287           characteristics::TypeAndShape::Attr::AssumedShape)) {
288     // 15.5.2.4(16)
289     if (actualRank == 0) {
290       messages.Say(
291           "Scalar actual argument may not be associated with assumed-shape %s"_err_en_US,
292           dummyName);
293     }
294     if (actualIsAssumedSize && actualLastSymbol) {
295       evaluate::SayWithDeclaration(messages, *actualLastSymbol,
296           "Assumed-size array may not be associated with assumed-shape %s"_err_en_US,
297           dummyName);
298     }
299   } else if (actualRank == 0 && dummy.type.Rank() > 0) {
300     // Actual is scalar, dummy is an array.  15.5.2.4(14), 15.5.2.11
301     if (actualIsCoindexed) {
302       messages.Say(
303           "Coindexed scalar actual argument must be associated with a scalar %s"_err_en_US,
304           dummyName);
305     }
306     if (!IsArrayElement(actual) &&
307         !(actualType.type().category() == TypeCategory::Character &&
308             actualType.type().kind() == 1) &&
309         !(dummy.type.type().IsAssumedType() && dummyIsAssumedSize) &&
310         !dummyIsAssumedRank) {
311       messages.Say(
312           "Whole scalar actual argument may not be associated with a %s array"_err_en_US,
313           dummyName);
314     }
315     if (actualIsPolymorphic) {
316       messages.Say(
317           "Polymorphic scalar may not be associated with a %s array"_err_en_US,
318           dummyName);
319     }
320     if (actualIsPointer) {
321       messages.Say(
322           "Scalar POINTER target may not be associated with a %s array"_err_en_US,
323           dummyName);
324     }
325     if (actualLastObject && actualLastObject->IsAssumedShape()) {
326       messages.Say(
327           "Element of assumed-shape array may not be associated with a %s array"_err_en_US,
328           dummyName);
329     }
330   }
331   if (actualLastObject && actualLastObject->IsCoarray() &&
332       IsAllocatable(*actualLastSymbol) && dummy.intent == common::Intent::Out &&
333       !(intrinsic &&
334           evaluate::AcceptsIntentOutAllocatableCoarray(
335               intrinsic->name))) { // C846
336     messages.Say(
337         "ALLOCATABLE coarray '%s' may not be associated with INTENT(OUT) %s"_err_en_US,
338         actualLastSymbol->name(), dummyName);
339   }
340 
341   // Definability
342   const char *reason{nullptr};
343   if (dummy.intent == common::Intent::Out) {
344     reason = "INTENT(OUT)";
345   } else if (dummy.intent == common::Intent::InOut) {
346     reason = "INTENT(IN OUT)";
347   } else if (dummyIsAsynchronous) {
348     reason = "ASYNCHRONOUS";
349   } else if (dummyIsVolatile) {
350     reason = "VOLATILE";
351   }
352   if (reason && scope) {
353     bool vectorSubscriptIsOk{isElemental || dummyIsValue}; // 15.5.2.4(21)
354     if (auto why{WhyNotModifiable(
355             messages.at(), actual, *scope, vectorSubscriptIsOk)}) {
356       if (auto *msg{messages.Say(
357               "Actual argument associated with %s %s must be definable"_err_en_US, // C1158
358               reason, dummyName)}) {
359         msg->Attach(*why);
360       }
361     }
362   }
363 
364   // Cases when temporaries might be needed but must not be permitted.
365   bool dummyIsPointer{
366       dummy.attrs.test(characteristics::DummyDataObject::Attr::Pointer)};
367   bool dummyIsContiguous{
368       dummy.attrs.test(characteristics::DummyDataObject::Attr::Contiguous)};
369   bool actualIsContiguous{IsSimplyContiguous(actual, context)};
370   bool dummyIsAssumedShape{dummy.type.attrs().test(
371       characteristics::TypeAndShape::Attr::AssumedShape)};
372   if ((actualIsAsynchronous || actualIsVolatile) &&
373       (dummyIsAsynchronous || dummyIsVolatile) && !dummyIsValue) {
374     if (actualIsCoindexed) { // C1538
375       messages.Say(
376           "Coindexed ASYNCHRONOUS or VOLATILE actual argument may not be associated with %s with ASYNCHRONOUS or VOLATILE attributes unless VALUE"_err_en_US,
377           dummyName);
378     }
379     if (actualRank > 0 && !actualIsContiguous) {
380       if (dummyIsContiguous ||
381           !(dummyIsAssumedShape || dummyIsAssumedRank ||
382               (actualIsPointer && dummyIsPointer))) { // C1539 & C1540
383         messages.Say(
384             "ASYNCHRONOUS or VOLATILE actual argument that is not simply contiguous may not be associated with a contiguous %s"_err_en_US,
385             dummyName);
386       }
387     }
388   }
389 
390   // 15.5.2.6 -- dummy is ALLOCATABLE
391   bool dummyIsAllocatable{
392       dummy.attrs.test(characteristics::DummyDataObject::Attr::Allocatable)};
393   bool actualIsAllocatable{
394       actualLastSymbol && IsAllocatable(*actualLastSymbol)};
395   if (dummyIsAllocatable) {
396     if (!actualIsAllocatable) {
397       messages.Say(
398           "ALLOCATABLE %s must be associated with an ALLOCATABLE actual argument"_err_en_US,
399           dummyName);
400     }
401     if (actualIsAllocatable && actualIsCoindexed &&
402         dummy.intent != common::Intent::In) {
403       messages.Say(
404           "ALLOCATABLE %s must have INTENT(IN) to be associated with a coindexed actual argument"_err_en_US,
405           dummyName);
406     }
407     if (!actualIsCoindexed && actualLastSymbol &&
408         actualLastSymbol->Corank() != dummy.type.corank()) {
409       messages.Say(
410           "ALLOCATABLE %s has corank %d but actual argument has corank %d"_err_en_US,
411           dummyName, dummy.type.corank(), actualLastSymbol->Corank());
412     }
413   }
414 
415   // 15.5.2.7 -- dummy is POINTER
416   if (dummyIsPointer) {
417     if (dummyIsContiguous && !actualIsContiguous) {
418       messages.Say(
419           "Actual argument associated with CONTIGUOUS POINTER %s must be simply contiguous"_err_en_US,
420           dummyName);
421     }
422     if (!actualIsPointer) {
423       if (dummy.intent == common::Intent::In) {
424         semantics::CheckPointerAssignment(
425             context, parser::CharBlock{}, dummyName, dummy, actual);
426       } else {
427         messages.Say(
428             "Actual argument associated with POINTER %s must also be POINTER unless INTENT(IN)"_err_en_US,
429             dummyName);
430       }
431     }
432   }
433 
434   // 15.5.2.5 -- actual & dummy are both POINTER or both ALLOCATABLE
435   if ((actualIsPointer && dummyIsPointer) ||
436       (actualIsAllocatable && dummyIsAllocatable)) {
437     bool actualIsUnlimited{actualType.type().IsUnlimitedPolymorphic()};
438     bool dummyIsUnlimited{dummy.type.type().IsUnlimitedPolymorphic()};
439     if (actualIsUnlimited != dummyIsUnlimited) {
440       if (typesCompatible) {
441         messages.Say(
442             "If a POINTER or ALLOCATABLE dummy or actual argument is unlimited polymorphic, both must be so"_err_en_US);
443       }
444     } else if (dummyIsPolymorphic != actualIsPolymorphic) {
445       if (dummy.intent == common::Intent::In && typesCompatible) {
446         // extension: allow with warning, rule is only relevant for definables
447         messages.Say(
448             "If a POINTER or ALLOCATABLE dummy or actual argument is polymorphic, both should be so"_en_US);
449       } else {
450         messages.Say(
451             "If a POINTER or ALLOCATABLE dummy or actual argument is polymorphic, both must be so"_err_en_US);
452       }
453     } else if (!actualIsUnlimited && typesCompatible) {
454       if (!actualType.type().IsTkCompatibleWith(dummy.type.type())) {
455         if (dummy.intent == common::Intent::In) {
456           // extension: allow with warning, rule is only relevant for definables
457           messages.Say(
458               "POINTER or ALLOCATABLE dummy and actual arguments should have the same declared type and kind"_en_US);
459         } else {
460           messages.Say(
461               "POINTER or ALLOCATABLE dummy and actual arguments must have the same declared type and kind"_err_en_US);
462         }
463       }
464       if (const auto *derived{
465               evaluate::GetDerivedTypeSpec(actualType.type())}) {
466         if (!DefersSameTypeParameters(
467                 *derived, *evaluate::GetDerivedTypeSpec(dummy.type.type()))) {
468           messages.Say(
469               "Dummy and actual arguments must defer the same type parameters when POINTER or ALLOCATABLE"_err_en_US);
470         }
471       }
472     }
473   }
474 
475   // 15.5.2.8 -- coarray dummy arguments
476   if (dummy.type.corank() > 0) {
477     if (actualType.corank() == 0) {
478       messages.Say(
479           "Actual argument associated with coarray %s must be a coarray"_err_en_US,
480           dummyName);
481     }
482     if (dummyIsVolatile) {
483       if (!actualIsVolatile) {
484         messages.Say(
485             "non-VOLATILE coarray may not be associated with VOLATILE coarray %s"_err_en_US,
486             dummyName);
487       }
488     } else {
489       if (actualIsVolatile) {
490         messages.Say(
491             "VOLATILE coarray may not be associated with non-VOLATILE coarray %s"_err_en_US,
492             dummyName);
493       }
494     }
495     if (actualRank == dummy.type.Rank() && !actualIsContiguous) {
496       if (dummyIsContiguous) {
497         messages.Say(
498             "Actual argument associated with a CONTIGUOUS coarray %s must be simply contiguous"_err_en_US,
499             dummyName);
500       } else if (!dummyIsAssumedShape && !dummyIsAssumedRank) {
501         messages.Say(
502             "Actual argument associated with coarray %s (not assumed shape or rank) must be simply contiguous"_err_en_US,
503             dummyName);
504       }
505     }
506   }
507 
508   // NULL(MOLD=) checking for non-intrinsic procedures
509   bool dummyIsOptional{
510       dummy.attrs.test(characteristics::DummyDataObject::Attr::Optional)};
511   bool actualIsNull{evaluate::IsNullPointer(actual)};
512   if (!intrinsic && !dummyIsPointer && !dummyIsOptional && actualIsNull) {
513     messages.Say(
514         "Actual argument associated with %s may not be null pointer %s"_err_en_US,
515         dummyName, actual.AsFortran());
516   }
517 }
518 
519 static void CheckProcedureArg(evaluate::ActualArgument &arg,
520     const characteristics::Procedure &proc,
521     const characteristics::DummyProcedure &dummy, const std::string &dummyName,
522     evaluate::FoldingContext &context) {
523   parser::ContextualMessages &messages{context.messages()};
524   const characteristics::Procedure &interface { dummy.procedure.value() };
525   if (const auto *expr{arg.UnwrapExpr()}) {
526     bool dummyIsPointer{
527         dummy.attrs.test(characteristics::DummyProcedure::Attr::Pointer)};
528     const auto *argProcDesignator{
529         std::get_if<evaluate::ProcedureDesignator>(&expr->u)};
530     const auto *argProcSymbol{
531         argProcDesignator ? argProcDesignator->GetSymbol() : nullptr};
532     if (auto argChars{characteristics::DummyArgument::FromActual(
533             "actual argument", *expr, context)}) {
534       if (!argChars->IsTypelessIntrinsicDummy()) {
535         if (auto *argProc{
536                 std::get_if<characteristics::DummyProcedure>(&argChars->u)}) {
537           characteristics::Procedure &argInterface{argProc->procedure.value()};
538           argInterface.attrs.reset(
539               characteristics::Procedure::Attr::NullPointer);
540           if (!argProcSymbol || argProcSymbol->attrs().test(Attr::INTRINSIC)) {
541             // It's ok to pass ELEMENTAL unrestricted intrinsic functions.
542             argInterface.attrs.reset(
543                 characteristics::Procedure::Attr::Elemental);
544           } else if (argInterface.attrs.test(
545                          characteristics::Procedure::Attr::Elemental)) {
546             if (argProcSymbol) { // C1533
547               evaluate::SayWithDeclaration(messages, *argProcSymbol,
548                   "Non-intrinsic ELEMENTAL procedure '%s' may not be passed as an actual argument"_err_en_US,
549                   argProcSymbol->name());
550               return; // avoid piling on with checks below
551             } else {
552               argInterface.attrs.reset(
553                   characteristics::Procedure::Attr::NullPointer);
554             }
555           }
556           if (!interface.IsPure()) {
557             // 15.5.2.9(1): if dummy is not pure, actual need not be.
558             argInterface.attrs.reset(characteristics::Procedure::Attr::Pure);
559           }
560           if (interface.HasExplicitInterface()) {
561             if (interface != argInterface) {
562               // 15.5.2.9(1): Explicit interfaces must match
563               if (argInterface.HasExplicitInterface()) {
564                 messages.Say(
565                     "Actual procedure argument has interface incompatible with %s"_err_en_US,
566                     dummyName);
567                 return;
568               } else if (proc.IsPure()) {
569                 messages.Say(
570                     "Actual procedure argument for %s of a PURE procedure must have an explicit interface"_err_en_US,
571                     dummyName);
572               } else {
573                 messages.Say(
574                     "Actual procedure argument has an implicit interface "
575                     "which is not known to be compatible with %s which has an "
576                     "explicit interface"_en_US,
577                     dummyName);
578               }
579             }
580           } else { // 15.5.2.9(2,3)
581             if (interface.IsSubroutine() && argInterface.IsFunction()) {
582               messages.Say(
583                   "Actual argument associated with procedure %s is a function but must be a subroutine"_err_en_US,
584                   dummyName);
585             } else if (interface.IsFunction()) {
586               if (argInterface.IsFunction()) {
587                 if (interface.functionResult != argInterface.functionResult) {
588                   messages.Say(
589                       "Actual argument function associated with procedure %s has incompatible result type"_err_en_US,
590                       dummyName);
591                 }
592               } else if (argInterface.IsSubroutine()) {
593                 messages.Say(
594                     "Actual argument associated with procedure %s is a subroutine but must be a function"_err_en_US,
595                     dummyName);
596               }
597             }
598           }
599         } else {
600           messages.Say(
601               "Actual argument associated with procedure %s is not a procedure"_err_en_US,
602               dummyName);
603         }
604       } else if (IsNullPointer(*expr)) {
605         if (!dummyIsPointer) {
606           messages.Say(
607               "Actual argument associated with procedure %s is a null pointer"_err_en_US,
608               dummyName);
609         }
610       } else {
611         messages.Say(
612             "Actual argument associated with procedure %s is typeless"_err_en_US,
613             dummyName);
614       }
615     }
616     if (interface.HasExplicitInterface() && dummyIsPointer &&
617         dummy.intent != common::Intent::In) {
618       const Symbol *last{GetLastSymbol(*expr)};
619       if (!(last && IsProcedurePointer(*last))) {
620         // 15.5.2.9(5) -- dummy procedure POINTER
621         // Interface compatibility has already been checked above by comparison.
622         messages.Say(
623             "Actual argument associated with procedure pointer %s must be a POINTER unless INTENT(IN)"_err_en_US,
624             dummyName);
625       }
626     }
627   } else {
628     messages.Say(
629         "Assumed-type argument may not be forwarded as procedure %s"_err_en_US,
630         dummyName);
631   }
632 }
633 
634 static void CheckExplicitInterfaceArg(evaluate::ActualArgument &arg,
635     const characteristics::DummyArgument &dummy,
636     const characteristics::Procedure &proc, evaluate::FoldingContext &context,
637     const Scope *scope, const evaluate::SpecificIntrinsic *intrinsic,
638     bool allowIntegerConversions) {
639   auto &messages{context.messages()};
640   std::string dummyName{"dummy argument"};
641   if (!dummy.name.empty()) {
642     dummyName += " '"s + parser::ToLowerCaseLetters(dummy.name) + "='";
643   }
644   std::visit(
645       common::visitors{
646           [&](const characteristics::DummyDataObject &object) {
647             if (auto *expr{arg.UnwrapExpr()}) {
648               if (auto type{characteristics::TypeAndShape::Characterize(
649                       *expr, context)}) {
650                 arg.set_dummyIntent(object.intent);
651                 bool isElemental{object.type.Rank() == 0 && proc.IsElemental()};
652                 CheckExplicitDataArg(object, dummyName, *expr, *type,
653                     isElemental, context, scope, intrinsic,
654                     allowIntegerConversions);
655               } else if (object.type.type().IsTypelessIntrinsicArgument() &&
656                   IsBOZLiteral(*expr)) {
657                 // ok
658               } else if (object.type.type().IsTypelessIntrinsicArgument() &&
659                   evaluate::IsNullPointer(*expr)) {
660                 // ok, ASSOCIATED(NULL())
661               } else if ((object.attrs.test(characteristics::DummyDataObject::
662                                   Attr::Pointer) ||
663                              object.attrs.test(characteristics::
664                                      DummyDataObject::Attr::Optional)) &&
665                   evaluate::IsNullPointer(*expr)) {
666                 // ok, FOO(NULL())
667               } else {
668                 messages.Say(
669                     "Actual argument '%s' associated with %s is not a variable or typed expression"_err_en_US,
670                     expr->AsFortran(), dummyName);
671               }
672             } else {
673               const Symbol &assumed{DEREF(arg.GetAssumedTypeDummy())};
674               if (!object.type.type().IsAssumedType()) {
675                 messages.Say(
676                     "Assumed-type '%s' may be associated only with an assumed-type %s"_err_en_US,
677                     assumed.name(), dummyName);
678               } else if (const auto *details{
679                              assumed.detailsIf<ObjectEntityDetails>()}) {
680                 if (!(details->IsAssumedShape() || details->IsAssumedRank())) {
681                   messages.Say( // C711
682                       "Assumed-type '%s' must be either assumed shape or assumed rank to be associated with assumed-type %s"_err_en_US,
683                       assumed.name(), dummyName);
684                 }
685               }
686             }
687           },
688           [&](const characteristics::DummyProcedure &dummy) {
689             CheckProcedureArg(arg, proc, dummy, dummyName, context);
690           },
691           [&](const characteristics::AlternateReturn &) {
692             // All semantic checking is done elsewhere
693           },
694       },
695       dummy.u);
696 }
697 
698 static void RearrangeArguments(const characteristics::Procedure &proc,
699     evaluate::ActualArguments &actuals, parser::ContextualMessages &messages) {
700   CHECK(proc.HasExplicitInterface());
701   if (actuals.size() < proc.dummyArguments.size()) {
702     actuals.resize(proc.dummyArguments.size());
703   } else if (actuals.size() > proc.dummyArguments.size()) {
704     messages.Say(
705         "Too many actual arguments (%zd) passed to procedure that expects only %zd"_err_en_US,
706         actuals.size(), proc.dummyArguments.size());
707   }
708   std::map<std::string, evaluate::ActualArgument> kwArgs;
709   for (auto &x : actuals) {
710     if (x && x->keyword()) {
711       auto emplaced{
712           kwArgs.try_emplace(x->keyword()->ToString(), std::move(*x))};
713       if (!emplaced.second) {
714         messages.Say(*x->keyword(),
715             "Argument keyword '%s=' appears on more than one effective argument in this procedure reference"_err_en_US,
716             *x->keyword());
717       }
718       x.reset();
719     }
720   }
721   if (!kwArgs.empty()) {
722     int index{0};
723     for (const auto &dummy : proc.dummyArguments) {
724       if (!dummy.name.empty()) {
725         auto iter{kwArgs.find(dummy.name)};
726         if (iter != kwArgs.end()) {
727           evaluate::ActualArgument &x{iter->second};
728           if (actuals[index]) {
729             messages.Say(*x.keyword(),
730                 "Keyword argument '%s=' has already been specified positionally (#%d) in this procedure reference"_err_en_US,
731                 *x.keyword(), index + 1);
732           } else {
733             actuals[index] = std::move(x);
734           }
735           kwArgs.erase(iter);
736         }
737       }
738       ++index;
739     }
740     for (auto &bad : kwArgs) {
741       evaluate::ActualArgument &x{bad.second};
742       messages.Say(*x.keyword(),
743           "Argument keyword '%s=' is not recognized for this procedure reference"_err_en_US,
744           *x.keyword());
745     }
746   }
747 }
748 
749 // The actual argument arrays to an ELEMENTAL procedure must conform.
750 static bool CheckElementalConformance(parser::ContextualMessages &messages,
751     const characteristics::Procedure &proc, evaluate::ActualArguments &actuals,
752     evaluate::FoldingContext &context) {
753   std::optional<evaluate::Shape> shape;
754   std::string shapeName;
755   int index{0};
756   for (const auto &arg : actuals) {
757     const auto &dummy{proc.dummyArguments.at(index++)};
758     if (arg) {
759       if (const auto *expr{arg->UnwrapExpr()}) {
760         if (auto argShape{evaluate::GetShape(context, *expr)}) {
761           if (GetRank(*argShape) > 0) {
762             std::string argName{"actual argument ("s + expr->AsFortran() +
763                 ") corresponding to dummy argument #" + std::to_string(index) +
764                 " ('" + dummy.name + "')"};
765             if (shape) {
766               auto tristate{evaluate::CheckConformance(messages, *shape,
767                   *argShape, evaluate::CheckConformanceFlags::None,
768                   shapeName.c_str(), argName.c_str())};
769               if (tristate && !*tristate) {
770                 return false;
771               }
772             } else {
773               shape = std::move(argShape);
774               shapeName = argName;
775             }
776           }
777         }
778       }
779     }
780   }
781   return true;
782 }
783 
784 static parser::Messages CheckExplicitInterface(
785     const characteristics::Procedure &proc, evaluate::ActualArguments &actuals,
786     const evaluate::FoldingContext &context, const Scope *scope,
787     const evaluate::SpecificIntrinsic *intrinsic,
788     bool allowIntegerConversions) {
789   parser::Messages buffer;
790   parser::ContextualMessages messages{context.messages().at(), &buffer};
791   RearrangeArguments(proc, actuals, messages);
792   if (buffer.empty()) {
793     int index{0};
794     evaluate::FoldingContext localContext{context, messages};
795     for (auto &actual : actuals) {
796       const auto &dummy{proc.dummyArguments.at(index++)};
797       if (actual) {
798         CheckExplicitInterfaceArg(*actual, dummy, proc, localContext, scope,
799             intrinsic, allowIntegerConversions);
800       } else if (!dummy.IsOptional()) {
801         if (dummy.name.empty()) {
802           messages.Say(
803               "Dummy argument #%d is not OPTIONAL and is not associated with "
804               "an actual argument in this procedure reference"_err_en_US,
805               index);
806         } else {
807           messages.Say("Dummy argument '%s=' (#%d) is not OPTIONAL and is not "
808                        "associated with an actual argument in this procedure "
809                        "reference"_err_en_US,
810               dummy.name, index);
811         }
812       }
813     }
814     if (proc.IsElemental() && !buffer.AnyFatalError()) {
815       CheckElementalConformance(messages, proc, actuals, localContext);
816     }
817   }
818   return buffer;
819 }
820 
821 parser::Messages CheckExplicitInterface(const characteristics::Procedure &proc,
822     evaluate::ActualArguments &actuals, const evaluate::FoldingContext &context,
823     const Scope &scope, const evaluate::SpecificIntrinsic *intrinsic) {
824   return CheckExplicitInterface(
825       proc, actuals, context, &scope, intrinsic, true);
826 }
827 
828 bool CheckInterfaceForGeneric(const characteristics::Procedure &proc,
829     evaluate::ActualArguments &actuals, const evaluate::FoldingContext &context,
830     bool allowIntegerConversions) {
831   return !CheckExplicitInterface(
832       proc, actuals, context, nullptr, nullptr, allowIntegerConversions)
833               .AnyFatalError();
834 }
835 
836 void CheckArguments(const characteristics::Procedure &proc,
837     evaluate::ActualArguments &actuals, evaluate::FoldingContext &context,
838     const Scope &scope, bool treatingExternalAsImplicit,
839     const evaluate::SpecificIntrinsic *intrinsic) {
840   bool explicitInterface{proc.HasExplicitInterface()};
841   if (explicitInterface) {
842     auto buffer{
843         CheckExplicitInterface(proc, actuals, context, scope, intrinsic)};
844     if (treatingExternalAsImplicit && !buffer.empty()) {
845       if (auto *msg{context.messages().Say(
846               "Warning: if the procedure's interface were explicit, this reference would be in error:"_en_US)}) {
847         buffer.AttachTo(*msg);
848       }
849     }
850     if (auto *msgs{context.messages().messages()}) {
851       msgs->Merge(std::move(buffer));
852     }
853   }
854   if (!explicitInterface || treatingExternalAsImplicit) {
855     for (auto &actual : actuals) {
856       if (actual) {
857         CheckImplicitInterfaceArg(*actual, context.messages());
858       }
859     }
860   }
861 }
862 } // namespace Fortran::semantics
863