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