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