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