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