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