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