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