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