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