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