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