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