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