173
+ − 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 (auto named{evaluate::ExtractNamedEntity(*expr)}) {
+ − 50 const Symbol &symbol{named->GetLastSymbol()};
+ − 51 if (symbol.Corank() > 0) {
+ − 52 messages.Say(
+ − 53 "Coarray argument requires an explicit interface"_err_en_US);
+ − 54 }
+ − 55 if (const auto *details{symbol.detailsIf<ObjectEntityDetails>()}) {
+ − 56 if (details->IsAssumedRank()) {
+ − 57 messages.Say(
+ − 58 "Assumed rank argument requires an explicit interface"_err_en_US);
+ − 59 }
+ − 60 }
+ − 61 if (symbol.attrs().test(Attr::ASYNCHRONOUS)) {
+ − 62 messages.Say(
+ − 63 "ASYNCHRONOUS argument requires an explicit interface"_err_en_US);
+ − 64 }
+ − 65 if (symbol.attrs().test(Attr::VOLATILE)) {
+ − 66 messages.Say(
+ − 67 "VOLATILE argument requires an explicit interface"_err_en_US);
+ − 68 }
+ − 69 }
+ − 70 }
+ − 71 }
+ − 72
+ − 73 // When scalar CHARACTER actual arguments are known to be short,
+ − 74 // we extend them on the right with spaces and a warning.
+ − 75 static void PadShortCharacterActual(evaluate::Expr<evaluate::SomeType> &actual,
+ − 76 const characteristics::TypeAndShape &dummyType,
+ − 77 const characteristics::TypeAndShape &actualType,
+ − 78 parser::ContextualMessages &messages) {
+ − 79 if (dummyType.type().category() == TypeCategory::Character &&
+ − 80 actualType.type().category() == TypeCategory::Character &&
+ − 81 dummyType.type().kind() == actualType.type().kind() &&
+ − 82 GetRank(actualType.shape()) == 0) {
+ − 83 if (auto dummyLEN{ToInt64(dummyType.LEN())}) {
+ − 84 if (auto actualLEN{ToInt64(actualType.LEN())}) {
+ − 85 if (*actualLEN < *dummyLEN) {
+ − 86 messages.Say(
+ − 87 "Actual length '%jd' is less than expected length '%jd'"_en_US,
+ − 88 *actualLEN, *dummyLEN);
+ − 89 auto converted{ConvertToType(dummyType.type(), std::move(actual))};
+ − 90 CHECK(converted);
+ − 91 actual = std::move(*converted);
+ − 92 }
+ − 93 }
+ − 94 }
+ − 95 }
+ − 96 }
+ − 97
+ − 98 // Automatic conversion of different-kind INTEGER scalar actual
+ − 99 // argument expressions (not variables) to INTEGER scalar dummies.
+ − 100 // We return nonstandard INTEGER(8) results from intrinsic functions
+ − 101 // like SIZE() by default in order to facilitate the use of large
+ − 102 // arrays. Emit a warning when downconverting.
+ − 103 static void ConvertIntegerActual(evaluate::Expr<evaluate::SomeType> &actual,
+ − 104 const characteristics::TypeAndShape &dummyType,
+ − 105 characteristics::TypeAndShape &actualType,
+ − 106 parser::ContextualMessages &messages) {
+ − 107 if (dummyType.type().category() == TypeCategory::Integer &&
+ − 108 actualType.type().category() == TypeCategory::Integer &&
+ − 109 dummyType.type().kind() != actualType.type().kind() &&
+ − 110 GetRank(dummyType.shape()) == 0 && GetRank(actualType.shape()) == 0 &&
+ − 111 !evaluate::IsVariable(actual)) {
+ − 112 auto converted{
+ − 113 evaluate::ConvertToType(dummyType.type(), std::move(actual))};
+ − 114 CHECK(converted);
+ − 115 actual = std::move(*converted);
+ − 116 if (dummyType.type().kind() < actualType.type().kind()) {
+ − 117 messages.Say(
+ − 118 "Actual argument scalar expression of type INTEGER(%d) was converted to smaller dummy argument type INTEGER(%d)"_en_US,
+ − 119 actualType.type().kind(), dummyType.type().kind());
+ − 120 }
+ − 121 actualType = dummyType;
+ − 122 }
+ − 123 }
+ − 124
+ − 125 static bool DefersSameTypeParameters(
+ − 126 const DerivedTypeSpec &actual, const DerivedTypeSpec &dummy) {
+ − 127 for (const auto &pair : actual.parameters()) {
+ − 128 const ParamValue &actualValue{pair.second};
+ − 129 const ParamValue *dummyValue{dummy.FindParameter(pair.first)};
+ − 130 if (!dummyValue || (actualValue.isDeferred() != dummyValue->isDeferred())) {
+ − 131 return false;
+ − 132 }
+ − 133 }
+ − 134 return true;
+ − 135 }
+ − 136
+ − 137 static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
+ − 138 const std::string &dummyName, evaluate::Expr<evaluate::SomeType> &actual,
+ − 139 characteristics::TypeAndShape &actualType, bool isElemental,
+ − 140 bool actualIsArrayElement, evaluate::FoldingContext &context,
+ − 141 const Scope *scope) {
+ − 142
+ − 143 // Basic type & rank checking
+ − 144 parser::ContextualMessages &messages{context.messages()};
+ − 145 PadShortCharacterActual(actual, dummy.type, actualType, messages);
+ − 146 ConvertIntegerActual(actual, dummy.type, actualType, messages);
+ − 147 bool typesCompatible{
+ − 148 dummy.type.type().IsTypeCompatibleWith(actualType.type())};
+ − 149 if (typesCompatible) {
+ − 150 if (isElemental) {
+ − 151 } else if (dummy.type.attrs().test(
+ − 152 characteristics::TypeAndShape::Attr::AssumedRank)) {
+ − 153 } else if (!dummy.type.attrs().test(
+ − 154 characteristics::TypeAndShape::Attr::AssumedShape) &&
+ − 155 (actualType.Rank() > 0 || actualIsArrayElement)) {
+ − 156 // Sequence association (15.5.2.11) applies -- rank need not match
+ − 157 // if the actual argument is an array or array element designator.
+ − 158 } else {
+ − 159 CheckConformance(messages, dummy.type.shape(), actualType.shape(),
+ − 160 "dummy argument", "actual argument");
+ − 161 }
+ − 162 } else {
+ − 163 const auto &len{actualType.LEN()};
+ − 164 messages.Say(
+ − 165 "Actual argument type '%s' is not compatible with dummy argument type '%s'"_err_en_US,
+ − 166 actualType.type().AsFortran(len ? len->AsFortran() : ""),
+ − 167 dummy.type.type().AsFortran());
+ − 168 }
+ − 169
+ − 170 bool actualIsPolymorphic{actualType.type().IsPolymorphic()};
+ − 171 bool dummyIsPolymorphic{dummy.type.type().IsPolymorphic()};
+ − 172 bool actualIsCoindexed{ExtractCoarrayRef(actual).has_value()};
+ − 173 bool actualIsAssumedSize{actualType.attrs().test(
+ − 174 characteristics::TypeAndShape::Attr::AssumedSize)};
+ − 175 bool dummyIsAssumedSize{dummy.type.attrs().test(
+ − 176 characteristics::TypeAndShape::Attr::AssumedSize)};
+ − 177 bool dummyIsAsynchronous{
+ − 178 dummy.attrs.test(characteristics::DummyDataObject::Attr::Asynchronous)};
+ − 179 bool dummyIsVolatile{
+ − 180 dummy.attrs.test(characteristics::DummyDataObject::Attr::Volatile)};
+ − 181 bool dummyIsValue{
+ − 182 dummy.attrs.test(characteristics::DummyDataObject::Attr::Value)};
+ − 183
+ − 184 if (actualIsPolymorphic && dummyIsPolymorphic &&
+ − 185 actualIsCoindexed) { // 15.5.2.4(2)
+ − 186 messages.Say(
+ − 187 "Coindexed polymorphic object may not be associated with a polymorphic %s"_err_en_US,
+ − 188 dummyName);
+ − 189 }
+ − 190 if (actualIsPolymorphic && !dummyIsPolymorphic &&
+ − 191 actualIsAssumedSize) { // 15.5.2.4(2)
+ − 192 messages.Say(
+ − 193 "Assumed-size polymorphic array may not be associated with a monomorphic %s"_err_en_US,
+ − 194 dummyName);
+ − 195 }
+ − 196
+ − 197 // Derived type actual argument checks
+ − 198 const Symbol *actualFirstSymbol{evaluate::GetFirstSymbol(actual)};
+ − 199 bool actualIsAsynchronous{
+ − 200 actualFirstSymbol && actualFirstSymbol->attrs().test(Attr::ASYNCHRONOUS)};
+ − 201 bool actualIsVolatile{
+ − 202 actualFirstSymbol && actualFirstSymbol->attrs().test(Attr::VOLATILE)};
+ − 203 if (const auto *derived{evaluate::GetDerivedTypeSpec(actualType.type())}) {
+ − 204 if (dummy.type.type().IsAssumedType()) {
+ − 205 if (!derived->parameters().empty()) { // 15.5.2.4(2)
+ − 206 messages.Say(
+ − 207 "Actual argument associated with TYPE(*) %s may not have a parameterized derived type"_err_en_US,
+ − 208 dummyName);
+ − 209 }
+ − 210 if (const Symbol *
+ − 211 tbp{FindImmediateComponent(*derived, [](const Symbol &symbol) {
+ − 212 return symbol.has<ProcBindingDetails>();
+ − 213 })}) { // 15.5.2.4(2)
+ − 214 evaluate::SayWithDeclaration(messages, *tbp,
+ − 215 "Actual argument associated with TYPE(*) %s may not have type-bound procedure '%s'"_err_en_US,
+ − 216 dummyName, tbp->name());
+ − 217 }
+ − 218 if (const Symbol *
+ − 219 finalizer{FindImmediateComponent(*derived, [](const Symbol &symbol) {
+ − 220 return symbol.has<FinalProcDetails>();
+ − 221 })}) { // 15.5.2.4(2)
+ − 222 evaluate::SayWithDeclaration(messages, *finalizer,
+ − 223 "Actual argument associated with TYPE(*) %s may not have FINAL subroutine '%s'"_err_en_US,
+ − 224 dummyName, finalizer->name());
+ − 225 }
+ − 226 }
+ − 227 if (actualIsCoindexed) {
+ − 228 if (dummy.intent != common::Intent::In && !dummyIsValue) {
+ − 229 if (auto bad{
+ − 230 FindAllocatableUltimateComponent(*derived)}) { // 15.5.2.4(6)
+ − 231 evaluate::SayWithDeclaration(messages, *bad,
+ − 232 "Coindexed actual argument with ALLOCATABLE ultimate component '%s' must be associated with a %s with VALUE or INTENT(IN) attributes"_err_en_US,
+ − 233 bad.BuildResultDesignatorName(), dummyName);
+ − 234 }
+ − 235 }
+ − 236 if (auto coarrayRef{evaluate::ExtractCoarrayRef(actual)}) { // C1537
+ − 237 const Symbol &coarray{coarrayRef->GetLastSymbol()};
+ − 238 if (const DeclTypeSpec * type{coarray.GetType()}) {
+ − 239 if (const DerivedTypeSpec * derived{type->AsDerived()}) {
+ − 240 if (auto bad{semantics::FindPointerUltimateComponent(*derived)}) {
+ − 241 evaluate::SayWithDeclaration(messages, coarray,
+ − 242 "Coindexed object '%s' with POINTER ultimate component '%s' cannot be associated with %s"_err_en_US,
+ − 243 coarray.name(), bad.BuildResultDesignatorName(), dummyName);
+ − 244 }
+ − 245 }
+ − 246 }
+ − 247 }
+ − 248 }
+ − 249 if (actualIsVolatile != dummyIsVolatile) { // 15.5.2.4(22)
+ − 250 if (auto bad{semantics::FindCoarrayUltimateComponent(*derived)}) {
+ − 251 evaluate::SayWithDeclaration(messages, *bad,
+ − 252 "VOLATILE attribute must match for %s when actual argument has a coarray ultimate component '%s'"_err_en_US,
+ − 253 dummyName, bad.BuildResultDesignatorName());
+ − 254 }
+ − 255 }
+ − 256 }
+ − 257
+ − 258 // Rank and shape checks
+ − 259 const auto *actualLastSymbol{evaluate::GetLastSymbol(actual)};
+ − 260 if (actualLastSymbol) {
+ − 261 actualLastSymbol = GetAssociationRoot(*actualLastSymbol);
+ − 262 }
+ − 263 const ObjectEntityDetails *actualLastObject{actualLastSymbol
+ − 264 ? actualLastSymbol->GetUltimate().detailsIf<ObjectEntityDetails>()
+ − 265 : nullptr};
+ − 266 int actualRank{evaluate::GetRank(actualType.shape())};
+ − 267 bool actualIsPointer{(actualLastSymbol && IsPointer(*actualLastSymbol)) ||
+ − 268 evaluate::IsNullPointer(actual)};
+ − 269 if (dummy.type.attrs().test(
+ − 270 characteristics::TypeAndShape::Attr::AssumedShape)) {
+ − 271 // 15.5.2.4(16)
+ − 272 if (actualRank == 0) {
+ − 273 messages.Say(
+ − 274 "Scalar actual argument may not be associated with assumed-shape %s"_err_en_US,
+ − 275 dummyName);
+ − 276 }
+ − 277 if (actualIsAssumedSize && actualLastSymbol) {
+ − 278 evaluate::SayWithDeclaration(messages, *actualLastSymbol,
+ − 279 "Assumed-size array may not be associated with assumed-shape %s"_err_en_US,
+ − 280 dummyName);
+ − 281 }
+ − 282 } else if (actualRank == 0 && dummy.type.Rank() > 0) {
+ − 283 // Actual is scalar, dummy is an array. 15.5.2.4(14), 15.5.2.11
+ − 284 if (actualIsCoindexed) {
+ − 285 messages.Say(
+ − 286 "Coindexed scalar actual argument must be associated with a scalar %s"_err_en_US,
+ − 287 dummyName);
+ − 288 }
+ − 289 if (actualLastSymbol && actualLastSymbol->Rank() == 0 &&
+ − 290 !(dummy.type.type().IsAssumedType() && dummyIsAssumedSize)) {
+ − 291 messages.Say(
+ − 292 "Whole scalar actual argument may not be associated with a %s array"_err_en_US,
+ − 293 dummyName);
+ − 294 }
+ − 295 if (actualIsPolymorphic) {
+ − 296 messages.Say(
+ − 297 "Polymorphic scalar may not be associated with a %s array"_err_en_US,
+ − 298 dummyName);
+ − 299 }
+ − 300 if (actualIsPointer) {
+ − 301 messages.Say(
+ − 302 "Scalar POINTER target may not be associated with a %s array"_err_en_US,
+ − 303 dummyName);
+ − 304 }
+ − 305 if (actualLastObject && actualLastObject->IsAssumedShape()) {
+ − 306 messages.Say(
+ − 307 "Element of assumed-shape array may not be associated with a %s array"_err_en_US,
+ − 308 dummyName);
+ − 309 }
+ − 310 }
+ − 311 if (actualLastObject && actualLastObject->IsCoarray() &&
+ − 312 IsAllocatable(*actualLastSymbol) &&
+ − 313 dummy.intent == common::Intent::Out) { // C846
+ − 314 messages.Say(
+ − 315 "ALLOCATABLE coarray '%s' may not be associated with INTENT(OUT) %s"_err_en_US,
+ − 316 actualLastSymbol->name(), dummyName);
+ − 317 }
+ − 318
+ − 319 // Definability
+ − 320 const char *reason{nullptr};
+ − 321 if (dummy.intent == common::Intent::Out) {
+ − 322 reason = "INTENT(OUT)";
+ − 323 } else if (dummy.intent == common::Intent::InOut) {
+ − 324 reason = "INTENT(IN OUT)";
+ − 325 } else if (dummyIsAsynchronous) {
+ − 326 reason = "ASYNCHRONOUS";
+ − 327 } else if (dummyIsVolatile) {
+ − 328 reason = "VOLATILE";
+ − 329 }
+ − 330 if (reason && scope) {
+ − 331 bool vectorSubscriptIsOk{isElemental || dummyIsValue}; // 15.5.2.4(21)
+ − 332 if (auto why{WhyNotModifiable(
+ − 333 messages.at(), actual, *scope, vectorSubscriptIsOk)}) {
+ − 334 if (auto *msg{messages.Say(
+ − 335 "Actual argument associated with %s %s must be definable"_err_en_US,
+ − 336 reason, dummyName)}) {
+ − 337 msg->Attach(*why);
+ − 338 }
+ − 339 }
+ − 340 }
+ − 341
+ − 342 // Cases when temporaries might be needed but must not be permitted.
+ − 343 bool dummyIsPointer{
+ − 344 dummy.attrs.test(characteristics::DummyDataObject::Attr::Pointer)};
+ − 345 bool dummyIsContiguous{
+ − 346 dummy.attrs.test(characteristics::DummyDataObject::Attr::Contiguous)};
+ − 347 bool actualIsContiguous{IsSimplyContiguous(actual, context.intrinsics())};
+ − 348 bool dummyIsAssumedRank{dummy.type.attrs().test(
+ − 349 characteristics::TypeAndShape::Attr::AssumedRank)};
+ − 350 bool dummyIsAssumedShape{dummy.type.attrs().test(
+ − 351 characteristics::TypeAndShape::Attr::AssumedShape)};
+ − 352 if ((actualIsAsynchronous || actualIsVolatile) &&
+ − 353 (dummyIsAsynchronous || dummyIsVolatile) && !dummyIsValue) {
+ − 354 if (actualIsCoindexed) { // C1538
+ − 355 messages.Say(
+ − 356 "Coindexed ASYNCHRONOUS or VOLATILE actual argument may not be associated with %s with ASYNCHRONOUS or VOLATILE attributes unless VALUE"_err_en_US,
+ − 357 dummyName);
+ − 358 }
+ − 359 if (actualRank > 0 && !actualIsContiguous) {
+ − 360 if (dummyIsContiguous ||
+ − 361 !(dummyIsAssumedShape || dummyIsAssumedRank ||
+ − 362 (actualIsPointer && dummyIsPointer))) { // C1539 & C1540
+ − 363 messages.Say(
+ − 364 "ASYNCHRONOUS or VOLATILE actual argument that is not simply contiguous may not be associated with a contiguous %s"_err_en_US,
+ − 365 dummyName);
+ − 366 }
+ − 367 }
+ − 368 }
+ − 369
+ − 370 // 15.5.2.6 -- dummy is ALLOCATABLE
+ − 371 bool dummyIsAllocatable{
+ − 372 dummy.attrs.test(characteristics::DummyDataObject::Attr::Allocatable)};
+ − 373 bool actualIsAllocatable{
+ − 374 actualLastSymbol && IsAllocatable(*actualLastSymbol)};
+ − 375 if (dummyIsAllocatable) {
+ − 376 if (!actualIsAllocatable) {
+ − 377 messages.Say(
+ − 378 "ALLOCATABLE %s must be associated with an ALLOCATABLE actual argument"_err_en_US,
+ − 379 dummyName);
+ − 380 }
+ − 381 if (actualIsAllocatable && actualIsCoindexed &&
+ − 382 dummy.intent != common::Intent::In) {
+ − 383 messages.Say(
+ − 384 "ALLOCATABLE %s must have INTENT(IN) to be associated with a coindexed actual argument"_err_en_US,
+ − 385 dummyName);
+ − 386 }
+ − 387 if (!actualIsCoindexed && actualLastSymbol &&
+ − 388 actualLastSymbol->Corank() != dummy.type.corank()) {
+ − 389 messages.Say(
+ − 390 "ALLOCATABLE %s has corank %d but actual argument has corank %d"_err_en_US,
+ − 391 dummyName, dummy.type.corank(), actualLastSymbol->Corank());
+ − 392 }
+ − 393 }
+ − 394
+ − 395 // 15.5.2.7 -- dummy is POINTER
+ − 396 if (dummyIsPointer) {
+ − 397 if (dummyIsContiguous && !actualIsContiguous) {
+ − 398 messages.Say(
+ − 399 "Actual argument associated with CONTIGUOUS POINTER %s must be simply contiguous"_err_en_US,
+ − 400 dummyName);
+ − 401 }
+ − 402 if (!actualIsPointer) {
+ − 403 if (dummy.intent == common::Intent::In) {
+ − 404 semantics::CheckPointerAssignment(
+ − 405 context, parser::CharBlock{}, dummyName, dummy, actual);
+ − 406 } else {
+ − 407 messages.Say(
+ − 408 "Actual argument associated with POINTER %s must also be POINTER unless INTENT(IN)"_err_en_US,
+ − 409 dummyName);
+ − 410 }
+ − 411 }
+ − 412 }
+ − 413
+ − 414 // 15.5.2.5 -- actual & dummy are both POINTER or both ALLOCATABLE
+ − 415 if ((actualIsPointer && dummyIsPointer) ||
+ − 416 (actualIsAllocatable && dummyIsAllocatable)) {
+ − 417 bool actualIsUnlimited{actualType.type().IsUnlimitedPolymorphic()};
+ − 418 bool dummyIsUnlimited{dummy.type.type().IsUnlimitedPolymorphic()};
+ − 419 if (actualIsUnlimited != dummyIsUnlimited) {
+ − 420 if (typesCompatible) {
+ − 421 messages.Say(
+ − 422 "If a POINTER or ALLOCATABLE dummy or actual argument is unlimited polymorphic, both must be so"_err_en_US);
+ − 423 }
+ − 424 } else if (dummyIsPolymorphic != actualIsPolymorphic) {
+ − 425 if (dummy.intent == common::Intent::In && typesCompatible) {
+ − 426 // extension: allow with warning, rule is only relevant for definables
+ − 427 messages.Say(
+ − 428 "If a POINTER or ALLOCATABLE dummy or actual argument is polymorphic, both should be so"_en_US);
+ − 429 } else {
+ − 430 messages.Say(
+ − 431 "If a POINTER or ALLOCATABLE dummy or actual argument is polymorphic, both must be so"_err_en_US);
+ − 432 }
+ − 433 } else if (!actualIsUnlimited && typesCompatible) {
+ − 434 if (!actualType.type().IsTypeCompatibleWith(dummy.type.type())) {
+ − 435 if (dummy.intent == common::Intent::In) {
+ − 436 // extension: allow with warning, rule is only relevant for definables
+ − 437 messages.Say(
+ − 438 "POINTER or ALLOCATABLE dummy and actual arguments should have the same declared type"_en_US);
+ − 439 } else {
+ − 440 messages.Say(
+ − 441 "POINTER or ALLOCATABLE dummy and actual arguments must have the same declared type"_err_en_US);
+ − 442 }
+ − 443 }
+ − 444 if (const auto *derived{
+ − 445 evaluate::GetDerivedTypeSpec(actualType.type())}) {
+ − 446 if (!DefersSameTypeParameters(
+ − 447 *derived, *evaluate::GetDerivedTypeSpec(dummy.type.type()))) {
+ − 448 messages.Say(
+ − 449 "Dummy and actual arguments must defer the same type parameters when POINTER or ALLOCATABLE"_err_en_US);
+ − 450 }
+ − 451 }
+ − 452 }
+ − 453 }
+ − 454
+ − 455 // 15.5.2.8 -- coarray dummy arguments
+ − 456 if (dummy.type.corank() > 0) {
+ − 457 if (actualType.corank() == 0) {
+ − 458 messages.Say(
+ − 459 "Actual argument associated with coarray %s must be a coarray"_err_en_US,
+ − 460 dummyName);
+ − 461 }
+ − 462 if (dummyIsVolatile) {
+ − 463 if (!actualIsVolatile) {
+ − 464 messages.Say(
+ − 465 "non-VOLATILE coarray may not be associated with VOLATILE coarray %s"_err_en_US,
+ − 466 dummyName);
+ − 467 }
+ − 468 } else {
+ − 469 if (actualIsVolatile) {
+ − 470 messages.Say(
+ − 471 "VOLATILE coarray may not be associated with non-VOLATILE coarray %s"_err_en_US,
+ − 472 dummyName);
+ − 473 }
+ − 474 }
+ − 475 if (actualRank == dummy.type.Rank() && !actualIsContiguous) {
+ − 476 if (dummyIsContiguous) {
+ − 477 messages.Say(
+ − 478 "Actual argument associated with a CONTIGUOUS coarray %s must be simply contiguous"_err_en_US,
+ − 479 dummyName);
+ − 480 } else if (!dummyIsAssumedShape && !dummyIsAssumedRank) {
+ − 481 messages.Say(
+ − 482 "Actual argument associated with coarray %s (not assumed shape or rank) must be simply contiguous"_err_en_US,
+ − 483 dummyName);
+ − 484 }
+ − 485 }
+ − 486 }
+ − 487 }
+ − 488
+ − 489 static void CheckProcedureArg(evaluate::ActualArgument &arg,
+ − 490 const characteristics::DummyProcedure &proc, const std::string &dummyName,
+ − 491 evaluate::FoldingContext &context) {
+ − 492 parser::ContextualMessages &messages{context.messages()};
+ − 493 const characteristics::Procedure &interface{proc.procedure.value()};
+ − 494 if (const auto *expr{arg.UnwrapExpr()}) {
+ − 495 bool dummyIsPointer{
+ − 496 proc.attrs.test(characteristics::DummyProcedure::Attr::Pointer)};
+ − 497 const auto *argProcDesignator{
+ − 498 std::get_if<evaluate::ProcedureDesignator>(&expr->u)};
+ − 499 const auto *argProcSymbol{
+ − 500 argProcDesignator ? argProcDesignator->GetSymbol() : nullptr};
+ − 501 if (auto argChars{characteristics::DummyArgument::FromActual(
+ − 502 "actual argument", *expr, context)}) {
+ − 503 if (auto *argProc{
+ − 504 std::get_if<characteristics::DummyProcedure>(&argChars->u)}) {
+ − 505 characteristics::Procedure &argInterface{argProc->procedure.value()};
+ − 506 argInterface.attrs.reset(characteristics::Procedure::Attr::NullPointer);
+ − 507 if (!argProcSymbol || argProcSymbol->attrs().test(Attr::INTRINSIC)) {
+ − 508 // It's ok to pass ELEMENTAL unrestricted intrinsic functions.
+ − 509 argInterface.attrs.reset(characteristics::Procedure::Attr::Elemental);
+ − 510 } else if (argInterface.attrs.test(
+ − 511 characteristics::Procedure::Attr::Elemental)) {
+ − 512 if (argProcSymbol) { // C1533
+ − 513 evaluate::SayWithDeclaration(messages, *argProcSymbol,
+ − 514 "Non-intrinsic ELEMENTAL procedure '%s' may not be passed as an actual argument"_err_en_US,
+ − 515 argProcSymbol->name());
+ − 516 return; // avoid piling on with checks below
+ − 517 } else {
+ − 518 argInterface.attrs.reset(
+ − 519 characteristics::Procedure::Attr::NullPointer);
+ − 520 }
+ − 521 }
+ − 522 if (!interface.IsPure()) {
+ − 523 // 15.5.2.9(1): if dummy is not pure, actual need not be.
+ − 524 argInterface.attrs.reset(characteristics::Procedure::Attr::Pure);
+ − 525 }
+ − 526 if (interface.HasExplicitInterface()) {
+ − 527 if (interface != argInterface) {
+ − 528 messages.Say(
+ − 529 "Actual argument procedure has interface incompatible with %s"_err_en_US,
+ − 530 dummyName);
+ − 531 }
+ − 532 } else { // 15.5.2.9(2,3)
+ − 533 if (interface.IsSubroutine() && argInterface.IsFunction()) {
+ − 534 messages.Say(
+ − 535 "Actual argument associated with procedure %s is a function but must be a subroutine"_err_en_US,
+ − 536 dummyName);
+ − 537 } else if (interface.IsFunction()) {
+ − 538 if (argInterface.IsFunction()) {
+ − 539 if (interface.functionResult != argInterface.functionResult) {
+ − 540 messages.Say(
+ − 541 "Actual argument function associated with procedure %s has incompatible result type"_err_en_US,
+ − 542 dummyName);
+ − 543 }
+ − 544 } else if (argInterface.IsSubroutine()) {
+ − 545 messages.Say(
+ − 546 "Actual argument associated with procedure %s is a subroutine but must be a function"_err_en_US,
+ − 547 dummyName);
+ − 548 }
+ − 549 }
+ − 550 }
+ − 551 } else {
+ − 552 messages.Say(
+ − 553 "Actual argument associated with procedure %s is not a procedure"_err_en_US,
+ − 554 dummyName);
+ − 555 }
+ − 556 } else if (!(dummyIsPointer && IsNullPointer(*expr))) {
+ − 557 messages.Say(
+ − 558 "Actual argument associated with procedure %s is not a procedure"_err_en_US,
+ − 559 dummyName);
+ − 560 }
+ − 561 if (interface.HasExplicitInterface()) {
+ − 562 if (dummyIsPointer) {
+ − 563 // 15.5.2.9(5) -- dummy procedure POINTER
+ − 564 // Interface compatibility has already been checked above by comparison.
+ − 565 if (proc.intent != common::Intent::In && !IsVariable(*expr)) {
+ − 566 messages.Say(
+ − 567 "Actual argument associated with procedure pointer %s must be a POINTER unless INTENT(IN)"_err_en_US,
+ − 568 dummyName);
+ − 569 }
+ − 570 } else { // 15.5.2.9(4) -- dummy procedure is not POINTER
+ − 571 if (!argProcDesignator) {
+ − 572 messages.Say(
+ − 573 "Actual argument associated with non-POINTER procedure %s must be a procedure (and not a procedure pointer)"_err_en_US,
+ − 574 dummyName);
+ − 575 }
+ − 576 }
+ − 577 }
+ − 578 } else {
+ − 579 messages.Say(
+ − 580 "Assumed-type argument may not be forwarded as procedure %s"_err_en_US,
+ − 581 dummyName);
+ − 582 }
+ − 583 }
+ − 584
+ − 585 static void CheckExplicitInterfaceArg(evaluate::ActualArgument &arg,
+ − 586 const characteristics::DummyArgument &dummy,
+ − 587 const characteristics::Procedure &proc, evaluate::FoldingContext &context,
+ − 588 const Scope *scope) {
+ − 589 auto &messages{context.messages()};
+ − 590 std::string dummyName{"dummy argument"};
+ − 591 if (!dummy.name.empty()) {
+ − 592 dummyName += " '"s + parser::ToLowerCaseLetters(dummy.name) + "='";
+ − 593 }
+ − 594 std::visit(
+ − 595 common::visitors{
+ − 596 [&](const characteristics::DummyDataObject &object) {
+ − 597 if (auto *expr{arg.UnwrapExpr()}) {
+ − 598 if (auto type{characteristics::TypeAndShape::Characterize(
+ − 599 *expr, context)}) {
+ − 600 arg.set_dummyIntent(object.intent);
+ − 601 bool isElemental{object.type.Rank() == 0 && proc.IsElemental()};
+ − 602 CheckExplicitDataArg(object, dummyName, *expr, *type,
+ − 603 isElemental, IsArrayElement(*expr), context, scope);
+ − 604 } else if (object.type.type().IsTypelessIntrinsicArgument() &&
+ − 605 std::holds_alternative<evaluate::BOZLiteralConstant>(
+ − 606 expr->u)) {
+ − 607 // ok
+ − 608 } else {
+ − 609 messages.Say(
+ − 610 "Actual argument is not a variable or typed expression"_err_en_US);
+ − 611 }
+ − 612 } else {
+ − 613 const Symbol &assumed{DEREF(arg.GetAssumedTypeDummy())};
+ − 614 if (!object.type.type().IsAssumedType()) {
+ − 615 messages.Say(
+ − 616 "Assumed-type '%s' may be associated only with an assumed-type %s"_err_en_US,
+ − 617 assumed.name(), dummyName);
+ − 618 } else if (const auto *details{
+ − 619 assumed.detailsIf<ObjectEntityDetails>()}) {
+ − 620 if (!(details->IsAssumedShape() || details->IsAssumedRank())) {
+ − 621 messages.Say( // C711
+ − 622 "Assumed-type '%s' must be either assumed shape or assumed rank to be associated with assumed-type %s"_err_en_US,
+ − 623 assumed.name(), dummyName);
+ − 624 }
+ − 625 }
+ − 626 }
+ − 627 },
+ − 628 [&](const characteristics::DummyProcedure &proc) {
+ − 629 CheckProcedureArg(arg, proc, dummyName, context);
+ − 630 },
+ − 631 [&](const characteristics::AlternateReturn &) {
+ − 632 // TODO check alternate return
+ − 633 },
+ − 634 },
+ − 635 dummy.u);
+ − 636 }
+ − 637
+ − 638 static void RearrangeArguments(const characteristics::Procedure &proc,
+ − 639 evaluate::ActualArguments &actuals, parser::ContextualMessages &messages) {
+ − 640 CHECK(proc.HasExplicitInterface());
+ − 641 if (actuals.size() < proc.dummyArguments.size()) {
+ − 642 actuals.resize(proc.dummyArguments.size());
+ − 643 } else if (actuals.size() > proc.dummyArguments.size()) {
+ − 644 messages.Say(
+ − 645 "Too many actual arguments (%zd) passed to procedure that expects only %zd"_err_en_US,
+ − 646 actuals.size(), proc.dummyArguments.size());
+ − 647 }
+ − 648 std::map<std::string, evaluate::ActualArgument> kwArgs;
+ − 649 for (auto &x : actuals) {
+ − 650 if (x && x->keyword()) {
+ − 651 auto emplaced{
+ − 652 kwArgs.try_emplace(x->keyword()->ToString(), std::move(*x))};
+ − 653 if (!emplaced.second) {
+ − 654 messages.Say(*x->keyword(),
+ − 655 "Argument keyword '%s=' appears on more than one effective argument in this procedure reference"_err_en_US,
+ − 656 *x->keyword());
+ − 657 }
+ − 658 x.reset();
+ − 659 }
+ − 660 }
+ − 661 if (!kwArgs.empty()) {
+ − 662 int index{0};
+ − 663 for (const auto &dummy : proc.dummyArguments) {
+ − 664 if (!dummy.name.empty()) {
+ − 665 auto iter{kwArgs.find(dummy.name)};
+ − 666 if (iter != kwArgs.end()) {
+ − 667 evaluate::ActualArgument &x{iter->second};
+ − 668 if (actuals[index]) {
+ − 669 messages.Say(*x.keyword(),
+ − 670 "Keyword argument '%s=' has already been specified positionally (#%d) in this procedure reference"_err_en_US,
+ − 671 *x.keyword(), index + 1);
+ − 672 } else {
+ − 673 actuals[index] = std::move(x);
+ − 674 }
+ − 675 kwArgs.erase(iter);
+ − 676 }
+ − 677 }
+ − 678 ++index;
+ − 679 }
+ − 680 for (auto &bad : kwArgs) {
+ − 681 evaluate::ActualArgument &x{bad.second};
+ − 682 messages.Say(*x.keyword(),
+ − 683 "Argument keyword '%s=' is not recognized for this procedure reference"_err_en_US,
+ − 684 *x.keyword());
+ − 685 }
+ − 686 }
+ − 687 }
+ − 688
+ − 689 static parser::Messages CheckExplicitInterface(
+ − 690 const characteristics::Procedure &proc, evaluate::ActualArguments &actuals,
+ − 691 const evaluate::FoldingContext &context, const Scope *scope) {
+ − 692 parser::Messages buffer;
+ − 693 parser::ContextualMessages messages{context.messages().at(), &buffer};
+ − 694 RearrangeArguments(proc, actuals, messages);
+ − 695 if (buffer.empty()) {
+ − 696 int index{0};
+ − 697 evaluate::FoldingContext localContext{context, messages};
+ − 698 for (auto &actual : actuals) {
+ − 699 const auto &dummy{proc.dummyArguments.at(index++)};
+ − 700 if (actual) {
+ − 701 CheckExplicitInterfaceArg(*actual, dummy, proc, localContext, scope);
+ − 702 } else if (!dummy.IsOptional()) {
+ − 703 if (dummy.name.empty()) {
+ − 704 messages.Say(
+ − 705 "Dummy argument #%d is not OPTIONAL and is not associated with "
+ − 706 "an actual argument in this procedure reference"_err_en_US,
+ − 707 index);
+ − 708 } else {
+ − 709 messages.Say("Dummy argument '%s=' (#%d) is not OPTIONAL and is not "
+ − 710 "associated with an actual argument in this procedure "
+ − 711 "reference"_err_en_US,
+ − 712 dummy.name, index);
+ − 713 }
+ − 714 }
+ − 715 }
+ − 716 }
+ − 717 return buffer;
+ − 718 }
+ − 719
+ − 720 parser::Messages CheckExplicitInterface(const characteristics::Procedure &proc,
+ − 721 evaluate::ActualArguments &actuals, const evaluate::FoldingContext &context,
+ − 722 const Scope &scope) {
+ − 723 return CheckExplicitInterface(proc, actuals, context, &scope);
+ − 724 }
+ − 725
+ − 726 bool CheckInterfaceForGeneric(const characteristics::Procedure &proc,
+ − 727 evaluate::ActualArguments &actuals,
+ − 728 const evaluate::FoldingContext &context) {
+ − 729 return CheckExplicitInterface(proc, actuals, context, nullptr).empty();
+ − 730 }
+ − 731
+ − 732 void CheckArguments(const characteristics::Procedure &proc,
+ − 733 evaluate::ActualArguments &actuals, evaluate::FoldingContext &context,
+ − 734 const Scope &scope, bool treatingExternalAsImplicit) {
+ − 735 bool explicitInterface{proc.HasExplicitInterface()};
+ − 736 if (explicitInterface) {
+ − 737 auto buffer{CheckExplicitInterface(proc, actuals, context, scope)};
+ − 738 if (treatingExternalAsImplicit && !buffer.empty()) {
+ − 739 if (auto *msg{context.messages().Say(
+ − 740 "Warning: if the procedure's interface were explicit, this reference would be in error:"_en_US)}) {
+ − 741 buffer.AttachTo(*msg);
+ − 742 }
+ − 743 }
+ − 744 if (auto *msgs{context.messages().messages()}) {
+ − 745 msgs->Merge(std::move(buffer));
+ − 746 }
+ − 747 }
+ − 748 if (!explicitInterface || treatingExternalAsImplicit) {
+ − 749 for (auto &actual : actuals) {
+ − 750 if (actual) {
+ − 751 CheckImplicitInterfaceArg(*actual, context.messages());
+ − 752 }
+ − 753 }
+ − 754 }
+ − 755 }
+ − 756 } // namespace Fortran::semantics