2465 lines · cpp
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-exception6//7//===----------------------------------------------------------------------===//8 9#include "check-call.h"10#include "definable.h"11#include "pointer-assignment.h"12#include "flang/Evaluate/characteristics.h"13#include "flang/Evaluate/check-expression.h"14#include "flang/Evaluate/fold-designator.h"15#include "flang/Evaluate/shape.h"16#include "flang/Evaluate/tools.h"17#include "flang/Parser/characters.h"18#include "flang/Parser/message.h"19#include "flang/Semantics/scope.h"20#include "flang/Semantics/tools.h"21#include <map>22#include <string>23 24using namespace Fortran::parser::literals;25namespace characteristics = Fortran::evaluate::characteristics;26 27namespace Fortran::semantics {28 29static void CheckImplicitInterfaceArg(evaluate::ActualArgument &arg,30 parser::ContextualMessages &messages, SemanticsContext &context) {31 auto restorer{32 messages.SetLocation(arg.sourceLocation().value_or(messages.at()))};33 if (auto kw{arg.keyword()}) {34 messages.Say(*kw,35 "Keyword '%s=' may not appear in a reference to a procedure with an implicit interface"_err_en_US,36 *kw);37 }38 auto type{arg.GetType()};39 if (type) {40 if (type->IsAssumedType()) {41 messages.Say(42 "Assumed type actual argument requires an explicit interface"_err_en_US);43 } else if (type->IsUnlimitedPolymorphic()) {44 messages.Say(45 "Unlimited polymorphic actual argument requires an explicit interface"_err_en_US);46 } else if (const DerivedTypeSpec * derived{GetDerivedTypeSpec(type)}) {47 if (!derived->parameters().empty()) {48 messages.Say(49 "Parameterized derived type actual argument requires an explicit interface"_err_en_US);50 }51 }52 }53 if (arg.isPercentVal() &&54 (!type || !type->IsLengthlessIntrinsicType() || arg.Rank() != 0)) {55 messages.Say(56 "%VAL argument must be a scalar numeric or logical expression"_err_en_US);57 }58 if (const auto *expr{arg.UnwrapExpr()}) {59 if (const Symbol *base{GetFirstSymbol(*expr)}) {60 const Symbol &symbol{GetAssociationRoot(*base)};61 if (IsFunctionResult(symbol)) {62 context.NoteDefinedSymbol(symbol);63 }64 }65 if (IsBOZLiteral(*expr)) {66 messages.Say("BOZ argument %s requires an explicit interface"_err_en_US,67 expr->AsFortran());68 } else if (evaluate::IsNullPointerOrAllocatable(expr)) {69 messages.Say(70 "Null pointer argument '%s' requires an explicit interface"_err_en_US,71 expr->AsFortran());72 } else if (auto named{evaluate::ExtractNamedEntity(*expr)}) {73 const Symbol &resolved{ResolveAssociations(named->GetLastSymbol())};74 if (IsAssumedRank(resolved)) {75 messages.Say(76 "Assumed rank argument '%s' requires an explicit interface"_err_en_US,77 expr->AsFortran());78 }79 const Symbol &symbol{GetAssociationRoot(resolved)};80 if (symbol.attrs().test(Attr::ASYNCHRONOUS)) {81 messages.Say(82 "ASYNCHRONOUS argument '%s' requires an explicit interface"_err_en_US,83 expr->AsFortran());84 }85 if (symbol.attrs().test(Attr::VOLATILE)) {86 messages.Say(87 "VOLATILE argument '%s' requires an explicit interface"_err_en_US,88 expr->AsFortran());89 }90 if (const auto *object{symbol.detailsIf<ObjectEntityDetails>()}) {91 if (object->cudaDataAttr()) {92 messages.Warn(/*inModuleFile=*/false, context.languageFeatures(),93 common::UsageWarning::CUDAUsage,94 "Actual argument '%s' with CUDA data attributes should be passed via an explicit interface"_warn_en_US,95 expr->AsFortran());96 }97 }98 } else if (auto argChars{characteristics::DummyArgument::FromActual(99 "actual argument", *expr, context.foldingContext(),100 /*forImplicitInterface=*/true)}) {101 const auto *argProcDesignator{102 std::get_if<evaluate::ProcedureDesignator>(&expr->u)};103 if (const auto *argProcSymbol{104 argProcDesignator ? argProcDesignator->GetSymbol() : nullptr}) {105 if (!argChars->IsTypelessIntrinsicDummy() && argProcDesignator &&106 argProcDesignator->IsElemental()) { // C1533107 evaluate::SayWithDeclaration(messages, *argProcSymbol,108 "Non-intrinsic ELEMENTAL procedure '%s' may not be passed as an actual argument"_err_en_US,109 argProcSymbol->name());110 } else if (const auto *subp{argProcSymbol->GetUltimate()111 .detailsIf<SubprogramDetails>()}) {112 if (subp->stmtFunction()) {113 evaluate::SayWithDeclaration(messages, *argProcSymbol,114 "Statement function '%s' may not be passed as an actual argument"_err_en_US,115 argProcSymbol->name());116 }117 }118 }119 }120 }121}122 123// F'2023 15.5.2.12p1: "Sequence association only applies when the dummy124// argument is an explicit-shape or assumed-size array."125static bool CanAssociateWithStorageSequence(126 const characteristics::DummyDataObject &dummy) {127 return !dummy.type.attrs().test(128 characteristics::TypeAndShape::Attr::AssumedRank) &&129 !dummy.type.attrs().test(130 characteristics::TypeAndShape::Attr::AssumedShape) &&131 !dummy.attrs.test(characteristics::DummyDataObject::Attr::Allocatable) &&132 !dummy.attrs.test(characteristics::DummyDataObject::Attr::Pointer) &&133 dummy.type.corank() == 0;134}135 136// When a CHARACTER actual argument is known to be short,137// we extend it on the right with spaces and a warning if138// possible. When it is long, and not required to be equal,139// the usage conforms to the standard and no warning is needed.140static void CheckCharacterActual(evaluate::Expr<evaluate::SomeType> &actual,141 const characteristics::DummyDataObject &dummy,142 characteristics::TypeAndShape &actualType, SemanticsContext &context,143 parser::ContextualMessages &messages, bool extentErrors,144 const std::string &dummyName) {145 if (dummy.type.type().category() == TypeCategory::Character &&146 actualType.type().category() == TypeCategory::Character &&147 dummy.type.type().kind() == actualType.type().kind() &&148 !dummy.attrs.test(149 characteristics::DummyDataObject::Attr::DeducedFromActual)) {150 bool actualIsAssumedRank{IsAssumedRank(actual)};151 if (actualIsAssumedRank &&152 !dummy.type.attrs().test(153 characteristics::TypeAndShape::Attr::AssumedRank)) {154 if (!context.languageFeatures().IsEnabled(155 common::LanguageFeature::AssumedRankPassedToNonAssumedRank)) {156 messages.Say(157 "Assumed-rank character array may not be associated with a dummy argument that is not assumed-rank"_err_en_US);158 } else {159 context.Warn(messages,160 common::LanguageFeature::AssumedRankPassedToNonAssumedRank,161 messages.at(),162 "Assumed-rank character array should not be associated with a dummy argument that is not assumed-rank"_port_en_US);163 }164 }165 if (dummy.type.LEN() && actualType.LEN()) {166 evaluate::FoldingContext &foldingContext{context.foldingContext()};167 auto dummyLength{168 ToInt64(Fold(foldingContext, common::Clone(*dummy.type.LEN())))};169 auto actualLength{170 ToInt64(Fold(foldingContext, common::Clone(*actualType.LEN())))};171 if (dummyLength && actualLength) {172 bool canAssociate{CanAssociateWithStorageSequence(dummy)};173 if (dummy.type.Rank() > 0 && canAssociate) {174 // Character storage sequence association (F'2023 15.5.2.12p4)175 if (auto dummySize{evaluate::ToInt64(evaluate::Fold(176 foldingContext, evaluate::GetSize(dummy.type.shape())))}) {177 auto dummyChars{*dummySize * *dummyLength};178 if (actualType.Rank() == 0 && !actualIsAssumedRank) {179 evaluate::DesignatorFolder folder{180 context.foldingContext(), /*getLastComponent=*/true};181 if (auto actualOffset{folder.FoldDesignator(actual)}) {182 std::int64_t actualChars{*actualLength};183 if (IsAllocatableOrPointer(actualOffset->symbol())) {184 // don't use actualOffset->symbol().size()!185 } else if (static_cast<std::size_t>(actualOffset->offset()) >=186 actualOffset->symbol().size() ||187 !evaluate::IsContiguous(188 actualOffset->symbol(), foldingContext)189 .value_or(false)) {190 // If substring, take rest of substring191 if (*actualLength > 0) {192 actualChars -=193 (actualOffset->offset() / actualType.type().kind()) %194 *actualLength;195 }196 } else {197 actualChars = (static_cast<std::int64_t>(198 actualOffset->symbol().size()) -199 actualOffset->offset()) /200 actualType.type().kind();201 }202 if (actualChars < dummyChars) {203 if (extentErrors) {204 messages.Say(205 "Actual argument has fewer characters remaining in storage sequence (%jd) than %s (%jd)"_err_en_US,206 static_cast<std::intmax_t>(actualChars), dummyName,207 static_cast<std::intmax_t>(dummyChars));208 } else {209 context.Warn(messages,210 common::UsageWarning::ShortCharacterActual,211 "Actual argument has fewer characters remaining in storage sequence (%jd) than %s (%jd)"_warn_en_US,212 static_cast<std::intmax_t>(actualChars), dummyName,213 static_cast<std::intmax_t>(dummyChars));214 }215 }216 }217 } else { // actual.type.Rank() > 0218 if (auto actualSize{evaluate::ToInt64(evaluate::Fold(219 foldingContext, evaluate::GetSize(actualType.shape())))};220 actualSize &&221 *actualSize * *actualLength < *dummySize * *dummyLength) {222 if (extentErrors) {223 messages.Say(224 "Actual argument array has fewer characters (%jd) than %s array (%jd)"_err_en_US,225 static_cast<std::intmax_t>(*actualSize * *actualLength),226 dummyName,227 static_cast<std::intmax_t>(*dummySize * *dummyLength));228 } else {229 context.Warn(messages,230 common::UsageWarning::ShortCharacterActual,231 "Actual argument array has fewer characters (%jd) than %s array (%jd)"_warn_en_US,232 static_cast<std::intmax_t>(*actualSize * *actualLength),233 dummyName,234 static_cast<std::intmax_t>(*dummySize * *dummyLength));235 }236 }237 }238 }239 } else if (*actualLength != *dummyLength) {240 // Not using storage sequence association, and the lengths don't241 // match.242 if (!canAssociate) {243 // F'2023 15.5.2.5 paragraph 4244 messages.Say(245 "Actual argument variable length '%jd' does not match the expected length '%jd'"_err_en_US,246 *actualLength, *dummyLength);247 } else if (*actualLength < *dummyLength) {248 CHECK(dummy.type.Rank() == 0);249 bool isVariable{evaluate::IsVariable(actual)};250 if (isVariable) {251 context.Warn(messages, common::UsageWarning::ShortCharacterActual,252 "Actual argument variable length '%jd' is less than expected length '%jd'"_warn_en_US,253 *actualLength, *dummyLength);254 } else {255 context.Warn(messages, common::UsageWarning::ShortCharacterActual,256 "Actual argument expression length '%jd' is less than expected length '%jd'"_warn_en_US,257 *actualLength, *dummyLength);258 }259 if (!isVariable) {260 auto converted{261 ConvertToType(dummy.type.type(), std::move(actual))};262 CHECK(converted);263 actual = std::move(*converted);264 actualType.set_LEN(SubscriptIntExpr{*dummyLength});265 }266 }267 }268 }269 }270 }271}272 273// Automatic conversion of different-kind INTEGER scalar actual274// argument expressions (not variables) to INTEGER scalar dummies.275// We return nonstandard INTEGER(8) results from intrinsic functions276// like SIZE() by default in order to facilitate the use of large277// arrays. Emit a warning when downconverting.278static void ConvertIntegerActual(evaluate::Expr<evaluate::SomeType> &actual,279 const characteristics::TypeAndShape &dummyType,280 characteristics::TypeAndShape &actualType,281 parser::ContextualMessages &messages, SemanticsContext &semanticsContext) {282 if (dummyType.type().category() == TypeCategory::Integer &&283 actualType.type().category() == TypeCategory::Integer &&284 dummyType.type().kind() != actualType.type().kind() &&285 dummyType.Rank() == 0 && actualType.Rank() == 0 &&286 !evaluate::IsVariable(actual)) {287 auto converted{288 evaluate::ConvertToType(dummyType.type(), std::move(actual))};289 CHECK(converted);290 actual = std::move(*converted);291 if (dummyType.type().kind() < actualType.type().kind()) {292 if (!semanticsContext.IsEnabled(293 common::LanguageFeature::ActualIntegerConvertedToSmallerKind)) {294 messages.Say(295 "Actual argument scalar expression of type INTEGER(%d) cannot be implicitly converted to smaller dummy argument type INTEGER(%d)"_err_en_US,296 actualType.type().kind(), dummyType.type().kind());297 } else {298 semanticsContext.Warn(messages,299 common::LanguageFeature::ActualIntegerConvertedToSmallerKind,300 "Actual argument scalar expression of type INTEGER(%d) was converted to smaller dummy argument type INTEGER(%d)"_port_en_US,301 actualType.type().kind(), dummyType.type().kind());302 }303 }304 actualType = dummyType;305 }306}307 308// Automatic conversion of different-kind LOGICAL scalar actual argument309// expressions (not variables) to LOGICAL scalar dummies when the dummy is of310// default logical kind. This allows expressions in dummy arguments to work when311// the default logical kind is not the one used in LogicalResult. This will312// always be safe even when downconverting so no warning is needed.313static void ConvertLogicalActual(evaluate::Expr<evaluate::SomeType> &actual,314 const characteristics::TypeAndShape &dummyType,315 characteristics::TypeAndShape &actualType) {316 if (dummyType.type().category() == TypeCategory::Logical &&317 actualType.type().category() == TypeCategory::Logical &&318 dummyType.type().kind() != actualType.type().kind() &&319 !evaluate::IsVariable(actual)) {320 auto converted{321 evaluate::ConvertToType(dummyType.type(), std::move(actual))};322 CHECK(converted);323 actual = std::move(*converted);324 actualType = dummyType;325 }326}327 328static bool DefersSameTypeParameters(329 const DerivedTypeSpec *actual, const DerivedTypeSpec *dummy) {330 if (actual && dummy) {331 for (const auto &pair : actual->parameters()) {332 const ParamValue &actualValue{pair.second};333 const ParamValue *dummyValue{dummy->FindParameter(pair.first)};334 if (!dummyValue ||335 (actualValue.isDeferred() != dummyValue->isDeferred())) {336 return false;337 }338 }339 }340 return true;341}342 343static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,344 const std::string &dummyName, evaluate::Expr<evaluate::SomeType> &actual,345 characteristics::TypeAndShape &actualType, bool isElemental,346 SemanticsContext &context, evaluate::FoldingContext &foldingContext,347 const Scope *scope, const evaluate::SpecificIntrinsic *intrinsic,348 bool allowActualArgumentConversions, bool extentErrors,349 const characteristics::Procedure &procedure,350 const evaluate::ActualArgument &arg,351 const characteristics::DummyArgument &dummyArg) {352 353 // Basic type & rank checking354 parser::ContextualMessages &messages{foldingContext.messages()};355 CheckCharacterActual(356 actual, dummy, actualType, context, messages, extentErrors, dummyName);357 bool dummyIsAllocatable{358 dummy.attrs.test(characteristics::DummyDataObject::Attr::Allocatable)};359 bool dummyIsPointer{360 dummy.attrs.test(characteristics::DummyDataObject::Attr::Pointer)};361 bool dummyIsAllocatableOrPointer{dummyIsAllocatable || dummyIsPointer};362 allowActualArgumentConversions &= !dummyIsAllocatableOrPointer;363 bool typesCompatibleWithIgnoreTKR{364 (dummy.ignoreTKR.test(common::IgnoreTKR::Type) &&365 (dummy.type.type().category() == TypeCategory::Derived ||366 actualType.type().category() == TypeCategory::Derived ||367 dummy.type.type().category() != actualType.type().category())) ||368 (dummy.ignoreTKR.test(common::IgnoreTKR::Kind) &&369 dummy.type.type().category() == actualType.type().category())};370 allowActualArgumentConversions &= !typesCompatibleWithIgnoreTKR;371 if (allowActualArgumentConversions) {372 ConvertIntegerActual(actual, dummy.type, actualType, messages, context);373 ConvertLogicalActual(actual, dummy.type, actualType);374 }375 bool typesCompatible{typesCompatibleWithIgnoreTKR ||376 dummy.type.type().IsTkCompatibleWith(actualType.type())};377 int dummyRank{dummy.type.Rank()};378 // Used to issue a general warning when we don't generate a specific warning379 // or error for this case.380 bool volatileOrAsyncNeedsTempDiagnosticIssued{false};381 if (typesCompatible) {382 if (const auto *constantChar{383 evaluate::UnwrapConstantValue<evaluate::Ascii>(actual)};384 constantChar && constantChar->wasHollerith() &&385 dummy.type.type().IsUnlimitedPolymorphic()) {386 foldingContext.Warn(common::LanguageFeature::HollerithPolymorphic,387 "passing Hollerith to unlimited polymorphic as if it were CHARACTER"_port_en_US);388 }389 } else if (dummyRank == 0 && allowActualArgumentConversions) {390 // Extension: pass Hollerith literal to scalar as if it had been BOZ391 if (auto converted{evaluate::HollerithToBOZ(392 foldingContext, actual, dummy.type.type())}) {393 foldingContext.Warn(common::LanguageFeature::HollerithOrCharacterAsBOZ,394 "passing Hollerith or character literal as if it were BOZ"_port_en_US);395 actual = *converted;396 actualType.type() = dummy.type.type();397 typesCompatible = true;398 }399 }400 bool dummyIsAssumedRank{dummy.type.attrs().test(401 characteristics::TypeAndShape::Attr::AssumedRank)};402 bool actualIsAssumedSize{actualType.attrs().test(403 characteristics::TypeAndShape::Attr::AssumedSize)};404 bool actualIsAssumedRank{IsAssumedRank(actual)};405 bool actualIsPointer{evaluate::IsObjectPointer(actual)};406 bool actualIsAllocatable{evaluate::IsAllocatableDesignator(actual)};407 bool actualMayBeAssumedSize{actualIsAssumedSize ||408 (actualIsAssumedRank && !actualIsPointer && !actualIsAllocatable)};409 bool actualIsPolymorphic{actualType.type().IsPolymorphic()};410 const auto *actualDerived{evaluate::GetDerivedTypeSpec(actualType.type())};411 if (typesCompatible) {412 if (isElemental) {413 } else if (dummyIsAssumedRank) {414 if (actualMayBeAssumedSize && dummy.intent == common::Intent::Out) {415 // An INTENT(OUT) dummy might be a no-op at run time416 bool dummyHasSignificantIntentOut{actualIsPolymorphic ||417 (actualDerived &&418 (actualDerived->HasDefaultInitialization(419 /*ignoreAllocatable=*/false, /*ignorePointer=*/true) ||420 actualDerived->HasDestruction()))};421 const char *actualDesc{422 actualIsAssumedSize ? "Assumed-size" : "Assumed-rank"};423 if (dummyHasSignificantIntentOut) {424 messages.Say(425 "%s actual argument may not be associated with INTENT(OUT) assumed-rank dummy argument requiring finalization, destruction, or initialization"_err_en_US,426 actualDesc);427 } else {428 foldingContext.Warn(common::UsageWarning::Portability, messages.at(),429 "%s actual argument should not be associated with INTENT(OUT) assumed-rank dummy argument"_port_en_US,430 actualDesc);431 }432 }433 } else if (dummy.ignoreTKR.test(common::IgnoreTKR::Rank)) {434 } else if (dummyRank > 0 && !dummyIsAllocatableOrPointer &&435 !dummy.type.attrs().test(436 characteristics::TypeAndShape::Attr::AssumedShape) &&437 !dummy.type.attrs().test(438 characteristics::TypeAndShape::Attr::DeferredShape) &&439 (actualType.Rank() > 0 || IsArrayElement(actual))) {440 // Sequence association (15.5.2.11) applies -- rank need not match441 // if the actual argument is an array or array element designator,442 // and the dummy is an array, but not assumed-shape or an INTENT(IN)443 // pointer that's standing in for an assumed-shape dummy.444 } else if (dummy.type.shape() && actualType.shape()) {445 // Let CheckConformance accept actual scalars; storage association446 // cases are checked here below.447 CheckConformance(messages, *dummy.type.shape(), *actualType.shape(),448 dummyIsAllocatableOrPointer449 ? evaluate::CheckConformanceFlags::None450 : evaluate::CheckConformanceFlags::RightScalarExpandable,451 "dummy argument", "actual argument");452 }453 } else {454 const auto &len{actualType.LEN()};455 messages.Say(456 "Actual argument type '%s' is not compatible with dummy argument type '%s'"_err_en_US,457 actualType.type().AsFortran(len ? len->AsFortran() : ""),458 dummy.type.type().AsFortran());459 }460 461 auto actualCoarrayRef{ExtractCoarrayRef(actual)};462 bool dummyIsAssumedSize{dummy.type.attrs().test(463 characteristics::TypeAndShape::Attr::AssumedSize)};464 bool dummyIsAsynchronous{465 dummy.attrs.test(characteristics::DummyDataObject::Attr::Asynchronous)};466 bool dummyIsVolatile{467 dummy.attrs.test(characteristics::DummyDataObject::Attr::Volatile)};468 bool dummyIsValue{469 dummy.attrs.test(characteristics::DummyDataObject::Attr::Value)};470 bool dummyIsPolymorphic{dummy.type.type().IsPolymorphic()};471 if (actualIsPolymorphic && dummyIsPolymorphic &&472 actualCoarrayRef) { // 15.5.2.4(2)473 messages.Say(474 "Coindexed polymorphic object may not be associated with a polymorphic %s"_err_en_US,475 dummyName);476 }477 if (actualIsPolymorphic && !dummyIsPolymorphic &&478 actualIsAssumedSize) { // 15.5.2.4(2)479 messages.Say(480 "Assumed-size polymorphic array may not be associated with a monomorphic %s"_err_en_US,481 dummyName);482 }483 484 // Derived type actual argument checks485 const Symbol *actualFirstSymbol{evaluate::GetFirstSymbol(actual)};486 bool actualIsAsynchronous{487 actualFirstSymbol && actualFirstSymbol->attrs().test(Attr::ASYNCHRONOUS)};488 bool actualIsVolatile{489 actualFirstSymbol && actualFirstSymbol->attrs().test(Attr::VOLATILE)};490 if (actualDerived && !actualDerived->IsVectorType()) {491 if (dummy.type.type().IsAssumedType()) {492 if (!actualDerived->parameters().empty()) { // 15.5.2.4(2)493 messages.Say(494 "Actual argument associated with TYPE(*) %s may not have a parameterized derived type"_err_en_US,495 dummyName);496 }497 if (const Symbol *498 tbp{FindImmediateComponent(*actualDerived, [](const Symbol &symbol) {499 return symbol.has<ProcBindingDetails>();500 })}) { // 15.5.2.4(2)501 evaluate::SayWithDeclaration(messages, *tbp,502 "Actual argument associated with TYPE(*) %s may not have type-bound procedure '%s'"_err_en_US,503 dummyName, tbp->name());504 }505 auto finals{FinalsForDerivedTypeInstantiation(*actualDerived)};506 if (!finals.empty()) { // 15.5.2.4(2)507 SourceName name{finals.front()->name()};508 if (auto *msg{messages.Say(509 "Actual argument associated with TYPE(*) %s may not have derived type '%s' with FINAL subroutine '%s'"_err_en_US,510 dummyName, actualDerived->typeSymbol().name(), name)}) {511 msg->Attach(name, "FINAL subroutine '%s' in derived type '%s'"_en_US,512 name, actualDerived->typeSymbol().name());513 }514 }515 }516 if (actualCoarrayRef) {517 if (dummy.intent != common::Intent::In && !dummyIsValue) {518 if (auto bad{FindAllocatableUltimateComponent(519 *actualDerived)}) { // 15.5.2.4(6)520 evaluate::SayWithDeclaration(messages, *bad,521 "Coindexed actual argument with ALLOCATABLE ultimate component '%s' must be associated with a %s with VALUE or INTENT(IN) attributes"_err_en_US,522 bad.BuildResultDesignatorName(), dummyName);523 }524 }525 const Symbol &coarray{actualCoarrayRef->GetLastSymbol()};526 if (const DeclTypeSpec * type{coarray.GetType()}) { // C1537527 if (const DerivedTypeSpec * derived{type->AsDerived()}) {528 if (auto bad{semantics::FindPointerUltimateComponent(*derived)}) {529 evaluate::SayWithDeclaration(messages, coarray,530 "Coindexed object '%s' with POINTER ultimate component '%s' cannot be associated with %s"_err_en_US,531 coarray.name(), bad.BuildResultDesignatorName(), dummyName);532 }533 }534 }535 }536 if (actualIsVolatile != dummyIsVolatile) { // 15.5.2.4(22)537 if (auto bad{semantics::FindCoarrayUltimateComponent(*actualDerived)}) {538 evaluate::SayWithDeclaration(messages, *bad,539 "VOLATILE attribute must match for %s when actual argument has a coarray ultimate component '%s'"_err_en_US,540 dummyName, bad.BuildResultDesignatorName());541 }542 }543 }544 545 // Rank and shape checks546 const auto *actualLastSymbol{evaluate::GetLastSymbol(actual)};547 if (actualLastSymbol) {548 actualLastSymbol = &ResolveAssociations(*actualLastSymbol);549 }550 int actualRank{actualType.Rank()};551 if (dummyIsValue && dummyRank == 0 &&552 dummy.ignoreTKR.test(common::IgnoreTKR::Rank) && actualRank > 0) {553 messages.Say(554 "Array actual argument may not be associated with IGNORE_TKR(R) scalar %s with VALUE attribute"_err_en_US,555 dummyName);556 } else if (dummy.type.attrs().test(557 characteristics::TypeAndShape::Attr::AssumedShape)) {558 // 15.5.2.4(16)559 if (actualIsAssumedRank) {560 messages.Say(561 "Assumed-rank actual argument may not be associated with assumed-shape %s"_err_en_US,562 dummyName);563 } else if (actualRank == 0) {564 messages.Say(565 "Scalar actual argument may not be associated with assumed-shape %s"_err_en_US,566 dummyName);567 } else if (actualIsAssumedSize && actualLastSymbol) {568 evaluate::SayWithDeclaration(messages, *actualLastSymbol,569 "Assumed-size array may not be associated with assumed-shape %s"_err_en_US,570 dummyName);571 }572 } else if (dummyRank > 0) {573 bool basicError{false};574 if (actualRank == 0 && !actualIsAssumedRank &&575 !dummyIsAllocatableOrPointer) {576 // Actual is scalar, dummy is an array. F'2023 15.5.2.5p14577 if (actualCoarrayRef) {578 basicError = true;579 messages.Say(580 "Coindexed scalar actual argument must be associated with a scalar %s"_err_en_US,581 dummyName);582 }583 bool actualIsArrayElement{IsArrayElement(actual) != nullptr};584 bool actualIsCKindCharacter{585 actualType.type().category() == TypeCategory::Character &&586 actualType.type().kind() == 1};587 if (!actualIsCKindCharacter) {588 if (!actualIsArrayElement &&589 !(dummy.type.type().IsAssumedType() && dummyIsAssumedSize) &&590 !dummyIsAssumedRank &&591 !dummy.ignoreTKR.test(common::IgnoreTKR::Rank)) {592 basicError = true;593 messages.Say(594 "Whole scalar actual argument may not be associated with a %s array"_err_en_US,595 dummyName);596 }597 if (actualIsPolymorphic) {598 basicError = true;599 messages.Say(600 "Polymorphic scalar may not be associated with a %s array"_err_en_US,601 dummyName);602 }603 bool isOkBecauseContiguous{604 context.IsEnabled(605 common::LanguageFeature::ContiguousOkForSeqAssociation) &&606 actualLastSymbol &&607 evaluate::IsContiguous(*actualLastSymbol, foldingContext)608 .value_or(false)};609 if (actualIsArrayElement && actualLastSymbol &&610 !dummy.ignoreTKR.test(common::IgnoreTKR::Contiguous)) {611 if (IsPointer(*actualLastSymbol)) {612 if (isOkBecauseContiguous) {613 context.Warn(614 common::LanguageFeature::ContiguousOkForSeqAssociation,615 messages.at(),616 "Element of contiguous pointer array is accepted for storage sequence association"_port_en_US);617 } else {618 basicError = true;619 messages.Say(620 "Element of pointer array may not be associated with a %s array"_err_en_US,621 dummyName);622 }623 } else if (IsAssumedShape(*actualLastSymbol) &&624 !dummy.ignoreTKR.test(common::IgnoreTKR::Contiguous)) {625 if (isOkBecauseContiguous) {626 context.Warn(627 common::LanguageFeature::ContiguousOkForSeqAssociation,628 messages.at(),629 "Element of contiguous assumed-shape array is accepted for storage sequence association"_port_en_US);630 } else {631 basicError = true;632 messages.Say(633 "Element of assumed-shape array may not be associated with a %s array"_err_en_US,634 dummyName);635 }636 }637 }638 }639 }640 // Storage sequence association (F'2023 15.5.2.12p3) checks.641 // Character storage sequence association is checked in642 // CheckCharacterActual().643 if (!basicError &&644 actualType.type().category() != TypeCategory::Character &&645 CanAssociateWithStorageSequence(dummy) &&646 !dummy.attrs.test(647 characteristics::DummyDataObject::Attr::DeducedFromActual)) {648 if (auto dummySize{evaluate::ToInt64(evaluate::Fold(649 foldingContext, evaluate::GetSize(dummy.type.shape())))}) {650 if (actualIsAssumedRank) {651 if (!context.languageFeatures().IsEnabled(652 common::LanguageFeature::AssumedRankPassedToNonAssumedRank)) {653 messages.Say(654 "Assumed-rank array may not be associated with a dummy argument that is not assumed-rank"_err_en_US);655 } else {656 context.Warn(657 common::LanguageFeature::AssumedRankPassedToNonAssumedRank,658 messages.at(),659 "Assumed-rank array should not be associated with a dummy argument that is not assumed-rank"_port_en_US);660 }661 } else if (actualRank == 0) {662 if (evaluate::IsArrayElement(actual)) {663 // Actual argument is a scalar array element664 evaluate::DesignatorFolder folder{665 context.foldingContext(), /*getLastComponent=*/true};666 if (auto actualOffset{folder.FoldDesignator(actual)}) {667 std::optional<std::int64_t> actualElements;668 if (IsAllocatableOrPointer(actualOffset->symbol())) {669 // don't use actualOffset->symbol().size()!670 } else if (static_cast<std::size_t>(actualOffset->offset()) >=671 actualOffset->symbol().size() ||672 !evaluate::IsContiguous(673 actualOffset->symbol(), foldingContext)674 .value_or(false)) {675 actualElements = 1;676 } else if (auto actualSymType{evaluate::DynamicType::From(677 actualOffset->symbol())}) {678 if (auto actualSymTypeBytes{679 evaluate::ToInt64(evaluate::Fold(foldingContext,680 actualSymType->MeasureSizeInBytes(681 foldingContext, false)))};682 actualSymTypeBytes && *actualSymTypeBytes > 0) {683 actualElements = (static_cast<std::int64_t>(684 actualOffset->symbol().size()) -685 actualOffset->offset()) /686 *actualSymTypeBytes;687 }688 }689 if (actualElements && *actualElements < *dummySize) {690 if (extentErrors) {691 messages.Say(692 "Actual argument has fewer elements remaining in storage sequence (%jd) than %s array (%jd)"_err_en_US,693 static_cast<std::intmax_t>(*actualElements), dummyName,694 static_cast<std::intmax_t>(*dummySize));695 } else {696 context.Warn(common::UsageWarning::ShortArrayActual,697 "Actual argument has fewer elements remaining in storage sequence (%jd) than %s array (%jd)"_warn_en_US,698 static_cast<std::intmax_t>(*actualElements), dummyName,699 static_cast<std::intmax_t>(*dummySize));700 }701 }702 }703 }704 } else {705 if (auto actualSize{evaluate::ToInt64(evaluate::Fold(706 foldingContext, evaluate::GetSize(actualType.shape())))};707 actualSize && *actualSize < *dummySize) {708 if (extentErrors) {709 messages.Say(710 "Actual argument array has fewer elements (%jd) than %s array (%jd)"_err_en_US,711 static_cast<std::intmax_t>(*actualSize), dummyName,712 static_cast<std::intmax_t>(*dummySize));713 } else {714 context.Warn(common::UsageWarning::ShortArrayActual,715 "Actual argument array has fewer elements (%jd) than %s array (%jd)"_warn_en_US,716 static_cast<std::intmax_t>(*actualSize), dummyName,717 static_cast<std::intmax_t>(*dummySize));718 }719 }720 }721 }722 }723 }724 const ObjectEntityDetails *actualLastObject{actualLastSymbol725 ? actualLastSymbol->detailsIf<ObjectEntityDetails>()726 : nullptr};727 if (actualLastObject && actualLastObject->IsCoarray() &&728 dummy.attrs.test(characteristics::DummyDataObject::Attr::Allocatable) &&729 dummy.intent == common::Intent::Out &&730 !(intrinsic &&731 evaluate::AcceptsIntentOutAllocatableCoarray(732 intrinsic->name))) { // C846733 messages.Say(734 "ALLOCATABLE coarray '%s' may not be associated with INTENT(OUT) %s"_err_en_US,735 actualLastSymbol->name(), dummyName);736 }737 738 // Definability checking739 // Problems with polymorphism are caught in the callee's definition.740 if (scope) {741 std::optional<parser::MessageFixedText> undefinableMessage;742 DefinabilityFlags flags{DefinabilityFlag::PolymorphicOkInPure};743 if (dummy.intent == common::Intent::InOut) {744 flags.set(DefinabilityFlag::AllowEventLockOrNotifyType);745 undefinableMessage =746 "Actual argument associated with INTENT(IN OUT) %s is not definable"_err_en_US;747 } else if (dummy.intent == common::Intent::Out) {748 undefinableMessage =749 "Actual argument associated with INTENT(OUT) %s is not definable"_err_en_US;750 } else if (context.ShouldWarn(common::LanguageFeature::751 UndefinableAsynchronousOrVolatileActual)) {752 if (dummy.attrs.test(753 characteristics::DummyDataObject::Attr::Asynchronous)) {754 undefinableMessage =755 "Actual argument associated with ASYNCHRONOUS %s is not definable"_warn_en_US;756 } else if (dummy.attrs.test(757 characteristics::DummyDataObject::Attr::Volatile)) {758 undefinableMessage =759 "Actual argument associated with VOLATILE %s is not definable"_warn_en_US;760 }761 }762 if (undefinableMessage) {763 if (isElemental) { // 15.5.2.4(21)764 flags.set(DefinabilityFlag::VectorSubscriptIsOk);765 }766 if (actualIsPointer && dummyIsPointer) { // 19.6.8767 flags.set(DefinabilityFlag::PointerDefinition);768 }769 if (auto whyNot{WhyNotDefinable(messages.at(), *scope, flags, actual)}) {770 if (whyNot->IsFatal()) {771 if (auto *msg{messages.Say(*undefinableMessage, dummyName)}) {772 if (!msg->IsFatal()) {773 volatileOrAsyncNeedsTempDiagnosticIssued = true;774 msg->set_languageFeature(common::LanguageFeature::775 UndefinableAsynchronousOrVolatileActual);776 }777 msg->Attach(778 std::move(whyNot->set_severity(parser::Severity::Because)));779 }780 } else {781 messages.Say(std::move(*whyNot));782 }783 }784 } else if (dummy.intent != common::Intent::In ||785 (dummyIsPointer && !actualIsPointer)) {786 if (auto named{evaluate::ExtractNamedEntity(actual)}) {787 if (const Symbol & base{named->GetFirstSymbol()};788 IsFunctionResult(base)) {789 context.NoteDefinedSymbol(base);790 }791 }792 }793 }794 795 bool dummyIsContiguous{796 dummy.attrs.test(characteristics::DummyDataObject::Attr::Contiguous)};797 bool actualIsContiguous{IsSimplyContiguous(actual, foldingContext)};798 799 // Cases when temporaries might be needed but must not be permitted.800 bool dummyIsAssumedShape{dummy.type.attrs().test(801 characteristics::TypeAndShape::Attr::AssumedShape)};802 bool copyOutNeeded{803 evaluate::ActualArgNeedsCopy(&arg, &dummyArg, foldingContext,804 /*forCopyOut=*/true)805 .value_or(false)};806 if (copyOutNeeded && !dummyIsValue &&807 (dummyIsAsynchronous || dummyIsVolatile)) {808 if (actualIsAsynchronous || actualIsVolatile) {809 if (actualCoarrayRef) { // F'2023 C1547810 messages.Say(811 "Coindexed ASYNCHRONOUS or VOLATILE actual argument may not be associated with %s with ASYNCHRONOUS or VOLATILE attributes unless VALUE"_err_en_US,812 dummyName);813 volatileOrAsyncNeedsTempDiagnosticIssued = true;814 }815 if ((actualRank > 0 || actualIsAssumedRank) && !actualIsContiguous) {816 if (dummyIsContiguous ||817 !(dummyIsAssumedShape || dummyIsAssumedRank ||818 (actualIsPointer && dummyIsPointer))) { // F'2023 C1548 & C1549819 messages.Say(820 "ASYNCHRONOUS or VOLATILE actual argument that is not simply contiguous may not be associated with a contiguous ASYNCHRONOUS or VOLATILE %s"_err_en_US,821 dummyName);822 volatileOrAsyncNeedsTempDiagnosticIssued = true;823 }824 }825 } else if (!(dummyIsAssumedShape || dummyIsAssumedRank ||826 (actualIsPointer && dummyIsPointer)) &&827 evaluate::IsArraySection(actual) && !actualIsContiguous &&828 !evaluate::HasVectorSubscript(actual)) {829 context.Warn(common::UsageWarning::VolatileOrAsynchronousTemporary,830 messages.at(),831 "The array section '%s' should not be associated with %s with %s attribute, unless the dummy is assumed-shape or assumed-rank"_warn_en_US,832 actual.AsFortran(), dummyName,833 dummyIsAsynchronous ? "ASYNCHRONOUS" : "VOLATILE");834 volatileOrAsyncNeedsTempDiagnosticIssued = true;835 }836 }837 // General implementation of F'23 15.5.2.5 note 5838 // Adds a less specific error message for any copy-out that could overwrite839 // a unread value in the actual argument.840 // Occurences of `volatileOrAsyncNeedsTempDiagnosticIssued = true` indicate a841 // more specific error message has already been issued. We might be able to842 // clean this up by switching the coding style of ActualArgNeedsCopy to be843 // more like WhyNotDefinable.844 if (copyOutNeeded && !volatileOrAsyncNeedsTempDiagnosticIssued) {845 if ((actualIsVolatile || actualIsAsynchronous) &&846 (dummyIsVolatile || dummyIsAsynchronous)) {847 context.Warn(common::UsageWarning::VolatileOrAsynchronousTemporary,848 messages.at(),849 "The actual argument '%s' with %s attribute should not be associated with %s with %s attribute, because a temporary copy is required during the call"_warn_en_US,850 actual.AsFortran(), actualIsVolatile ? "VOLATILE" : "ASYNCHRONOUS",851 dummyName, dummyIsVolatile ? "VOLATILE" : "ASYNCHRONOUS");852 }853 }854 // If there are any cases where we don't need a copy and some other compiler855 // does, we issue a portability warning here.856 if (context.ShouldWarn(common::UsageWarning::Portability)) {857 // 3 other compilers error on this case even though it is ok.858 // Possibly as an over-restriction of F'23 C1548.859 if (!copyOutNeeded && !volatileOrAsyncNeedsTempDiagnosticIssued &&860 (!dummyIsValue && (dummyIsAsynchronous || dummyIsVolatile)) &&861 !(actualIsAsynchronous || actualIsVolatile) &&862 !(dummyIsAssumedShape || dummyIsAssumedRank ||863 (actualIsPointer && dummyIsPointer)) &&864 evaluate::IsArraySection(actual) &&865 !evaluate::HasVectorSubscript(actual)) {866 context.Warn(common::UsageWarning::Portability, messages.at(),867 "The array section '%s' should not be associated with %s with %s attribute, unless the dummy is assumed-shape or assumed-rank"_port_en_US,868 actual.AsFortran(), dummyName,869 dummyIsAsynchronous ? "ASYNCHRONOUS" : "VOLATILE");870 }871 // Possibly an over-restriction of F'23 15.5.2.5 note 5872 if (copyOutNeeded && !volatileOrAsyncNeedsTempDiagnosticIssued) {873 if ((dummyIsVolatile && !actualIsVolatile && !actualIsAsynchronous) ||874 (dummyIsAsynchronous && !actualIsVolatile && !actualIsAsynchronous)) {875 context.Warn(common::UsageWarning::Portability, messages.at(),876 "The actual argument '%s' should not be associated with %s with %s attribute, because a temporary copy is required during the call"_port_en_US,877 actual.AsFortran(), dummyName,878 dummyIsVolatile ? "VOLATILE" : "ASYNCHRONOUS");879 }880 }881 }882 883 // 15.5.2.6 -- dummy is ALLOCATABLE884 bool dummyIsOptional{885 dummy.attrs.test(characteristics::DummyDataObject::Attr::Optional)};886 if (dummyIsAllocatable) {887 if (actualIsAllocatable) {888 if (actualCoarrayRef && dummy.intent != common::Intent::In) {889 messages.Say(890 "ALLOCATABLE %s must have INTENT(IN) to be associated with a coindexed actual argument"_err_en_US,891 dummyName);892 }893 if (!actualCoarrayRef && actualLastSymbol && dummy.type.corank() == 0 &&894 actualLastSymbol->Corank() > 0) {895 messages.Say(896 "ALLOCATABLE %s is not a coarray but actual argument has corank %d"_err_en_US,897 dummyName, actualLastSymbol->Corank());898 }899 } else if (evaluate::IsBareNullPointer(&actual)) {900 if (dummyIsOptional) {901 } else if (dummy.intent == common::Intent::Default &&902 context.ShouldWarn(903 common::UsageWarning::NullActualForDefaultIntentAllocatable)) {904 messages.Say(905 "A null pointer should not be associated with allocatable %s without INTENT(IN)"_warn_en_US,906 dummyName);907 } else if (dummy.intent == common::Intent::In) {908 foldingContext.Warn(common::LanguageFeature::NullActualForAllocatable,909 "Allocatable %s is associated with a null pointer"_port_en_US,910 dummyName);911 }912 // INTENT(OUT) and INTENT(IN OUT) cases are caught elsewhere as being913 // undefinable actual arguments.914 } else if (evaluate::IsNullAllocatable(&actual)) {915 if (dummyIsOptional) {916 } else if (dummy.intent == common::Intent::Default &&917 context.ShouldWarn(918 common::UsageWarning::NullActualForDefaultIntentAllocatable)) {919 messages.Say(920 "A null allocatable should not be associated with allocatable %s without INTENT(IN)"_warn_en_US,921 dummyName);922 }923 // INTENT(OUT) and INTENT(IN OUT) cases are caught elsewhere924 } else if (!actualIsAllocatable &&925 !dummy.ignoreTKR.test(common::IgnoreTKR::Pointer)) {926 messages.Say(927 "ALLOCATABLE %s must be associated with an ALLOCATABLE actual argument"_err_en_US,928 dummyName);929 }930 }931 932 // 15.5.2.7 -- dummy is POINTER933 if (dummyIsPointer) {934 if (actualIsPointer || dummy.intent == common::Intent::In) {935 if (scope) {936 semantics::CheckPointerAssignment(context, messages.at(), dummyName,937 dummy, actual, *scope,938 /*isAssumedRank=*/dummyIsAssumedRank, actualIsPointer);939 }940 } else if (!actualIsPointer &&941 !dummy.ignoreTKR.test(common::IgnoreTKR::Pointer)) {942 messages.Say(943 "Actual argument associated with POINTER %s must also be POINTER unless INTENT(IN)"_err_en_US,944 dummyName);945 }946 }947 948 // 15.5.2.5 -- actual & dummy are both POINTER or both ALLOCATABLE949 // For INTENT(IN), and for a polymorphic actual being associated with a950 // monomorphic dummy, we relax two checks that are in Fortran to951 // prevent the callee from changing the type or to avoid having952 // to use a descriptor.953 if (!typesCompatible) {954 // Don't pile on the errors emitted above955 } else if ((actualIsPointer && dummyIsPointer) ||956 (actualIsAllocatable && dummyIsAllocatable)) {957 bool actualIsUnlimited{actualType.type().IsUnlimitedPolymorphic()};958 bool dummyIsUnlimited{dummy.type.type().IsUnlimitedPolymorphic()};959 bool checkTypeCompatibility{true};960 if (actualIsUnlimited != dummyIsUnlimited) {961 checkTypeCompatibility = false;962 if (dummyIsUnlimited && dummy.intent == common::Intent::In &&963 context.IsEnabled(common::LanguageFeature::RelaxedIntentInChecking)) {964 foldingContext.Warn(common::LanguageFeature::RelaxedIntentInChecking,965 "If a POINTER or ALLOCATABLE dummy or actual argument is unlimited polymorphic, both should be so"_port_en_US);966 } else {967 messages.Say(968 "If a POINTER or ALLOCATABLE dummy or actual argument is unlimited polymorphic, both must be so"_err_en_US);969 }970 } else if (dummyIsPolymorphic != actualIsPolymorphic) {971 if (dummyIsPolymorphic && dummy.intent == common::Intent::In &&972 context.IsEnabled(common::LanguageFeature::RelaxedIntentInChecking)) {973 foldingContext.Warn(common::LanguageFeature::RelaxedIntentInChecking,974 "If a POINTER or ALLOCATABLE dummy or actual argument is polymorphic, both should be so"_port_en_US);975 } else if (actualIsPolymorphic &&976 context.IsEnabled(common::LanguageFeature::977 PolymorphicActualAllocatableOrPointerToMonomorphicDummy)) {978 foldingContext.Warn(979 common::LanguageFeature::980 PolymorphicActualAllocatableOrPointerToMonomorphicDummy,981 "If a POINTER or ALLOCATABLE actual argument is polymorphic, the corresponding dummy argument should also be so"_port_en_US);982 } else {983 checkTypeCompatibility = false;984 messages.Say(985 "If a POINTER or ALLOCATABLE dummy or actual argument is polymorphic, both must be so"_err_en_US);986 }987 }988 if (checkTypeCompatibility && !actualIsUnlimited) {989 if (!actualType.type().IsTkCompatibleWith(dummy.type.type())) {990 if (dummy.intent == common::Intent::In &&991 context.IsEnabled(992 common::LanguageFeature::RelaxedIntentInChecking)) {993 foldingContext.Warn(common::LanguageFeature::RelaxedIntentInChecking,994 "POINTER or ALLOCATABLE dummy and actual arguments should have the same declared type and kind"_port_en_US);995 } else {996 messages.Say(997 "POINTER or ALLOCATABLE dummy and actual arguments must have the same declared type and kind"_err_en_US);998 }999 }1000 // 15.5.2.5(4)1001 const auto *dummyDerived{evaluate::GetDerivedTypeSpec(dummy.type.type())};1002 if (!DefersSameTypeParameters(actualDerived, dummyDerived) ||1003 dummy.type.type().HasDeferredTypeParameter() !=1004 actualType.type().HasDeferredTypeParameter()) {1005 messages.Say(1006 "Dummy and actual arguments must defer the same type parameters when POINTER or ALLOCATABLE"_err_en_US);1007 }1008 }1009 }1010 1011 // 15.5.2.8 -- coarray dummy arguments1012 if (dummy.type.corank() > 0) {1013 if (actualType.corank() == 0) {1014 messages.Say(1015 "Actual argument associated with coarray %s must be a coarray"_err_en_US,1016 dummyName);1017 } else if (actualType.corank() != dummy.type.corank() &&1018 dummyIsAllocatableOrPointer) {1019 messages.Say(1020 "ALLOCATABLE or POINTER %s has corank %d but actual argument has corank %d"_err_en_US,1021 dummyName, dummy.type.corank(), actualType.corank());1022 }1023 if (dummyIsVolatile) {1024 if (!actualIsVolatile) {1025 messages.Say(1026 "non-VOLATILE coarray may not be associated with VOLATILE coarray %s"_err_en_US,1027 dummyName);1028 }1029 } else {1030 if (actualIsVolatile) {1031 messages.Say(1032 "VOLATILE coarray may not be associated with non-VOLATILE coarray %s"_err_en_US,1033 dummyName);1034 }1035 }1036 if (actualRank == dummyRank && !actualIsContiguous) {1037 if (dummyIsContiguous) {1038 messages.Say(1039 "Actual argument associated with a CONTIGUOUS coarray %s must be simply contiguous"_err_en_US,1040 dummyName);1041 } else if (!dummyIsAssumedShape && !dummyIsAssumedRank) {1042 messages.Say(1043 "Actual argument associated with coarray %s (not assumed shape or rank) must be simply contiguous"_err_en_US,1044 dummyName);1045 }1046 }1047 }1048 1049 // NULL(MOLD=) checking for non-intrinsic procedures1050 if (!intrinsic && !dummyIsAllocatableOrPointer && !dummyIsOptional &&1051 evaluate::IsNullPointer(&actual)) {1052 messages.Say(1053 "Actual argument associated with %s may not be null pointer %s"_err_en_US,1054 dummyName, actual.AsFortran());1055 }1056 1057 // Warn about dubious actual argument association with a TARGET dummy1058 // argument1059 if (dummy.attrs.test(characteristics::DummyDataObject::Attr::Target) &&1060 context.ShouldWarn(common::UsageWarning::NonTargetPassedToTarget)) {1061 bool actualIsVariable{evaluate::IsVariable(actual)};1062 bool actualIsTemp{1063 !actualIsVariable || HasVectorSubscript(actual) || actualCoarrayRef};1064 if (actualIsTemp) {1065 foldingContext.Warn(common::UsageWarning::NonTargetPassedToTarget,1066 "Any pointer associated with TARGET %s during this call will not be associated with the value of '%s' afterwards"_warn_en_US,1067 dummyName, actual.AsFortran());1068 } else {1069 auto actualSymbolVector{GetSymbolVector(actual)};1070 if (!evaluate::GetLastTarget(actualSymbolVector)) {1071 foldingContext.Warn(common::UsageWarning::NonTargetPassedToTarget,1072 "Any pointer associated with TARGET %s during this call must not be used afterwards, as '%s' is not a target"_warn_en_US,1073 dummyName, actual.AsFortran());1074 }1075 }1076 }1077 1078 // CUDA specific checks1079 // TODO: These are disabled in OpenACC constructs, which may not be1080 // correct when the target is not a GPU.1081 if (!intrinsic &&1082 !dummy.attrs.test(characteristics::DummyDataObject::Attr::Value) &&1083 !FindOpenACCConstructContaining(scope)) {1084 std::optional<common::CUDADataAttr> actualDataAttr, dummyDataAttr;1085 if (const auto *actualObject{actualLastSymbol1086 ? actualLastSymbol->detailsIf<ObjectEntityDetails>()1087 : nullptr}) {1088 actualDataAttr = actualObject->cudaDataAttr();1089 }1090 dummyDataAttr = dummy.cudaDataAttr;1091 // Treat MANAGED like DEVICE for nonallocatable nonpointer arguments to1092 // device subprograms1093 if (procedure.cudaSubprogramAttrs.value_or(1094 common::CUDASubprogramAttrs::Host) !=1095 common::CUDASubprogramAttrs::Host &&1096 !dummy.attrs.test(1097 characteristics::DummyDataObject::Attr::Allocatable) &&1098 !dummy.attrs.test(characteristics::DummyDataObject::Attr::Pointer)) {1099 if (!dummyDataAttr || *dummyDataAttr == common::CUDADataAttr::Managed) {1100 dummyDataAttr = common::CUDADataAttr::Device;1101 }1102 if ((!actualDataAttr && FindCUDADeviceContext(scope)) ||1103 (actualDataAttr &&1104 *actualDataAttr == common::CUDADataAttr::Managed)) {1105 actualDataAttr = common::CUDADataAttr::Device;1106 }1107 // For device procedures, treat actual arguments with VALUE attribute as1108 // device data1109 if (!actualDataAttr && actualLastSymbol && IsValue(*actualLastSymbol) &&1110 (*procedure.cudaSubprogramAttrs ==1111 common::CUDASubprogramAttrs::Device)) {1112 actualDataAttr = common::CUDADataAttr::Device;1113 }1114 }1115 if (dummyDataAttr == common::CUDADataAttr::Device &&1116 (dummyIsAssumedShape || dummyIsAssumedRank) &&1117 !dummy.ignoreTKR.test(common::IgnoreTKR::Contiguous)) {1118 if (auto contig{evaluate::IsContiguous(actual, foldingContext,1119 /*namedConstantSectionsAreContiguous=*/true,1120 /*firstDimensionStride1=*/true)}) {1121 if (!*contig) {1122 messages.Say(1123 "actual argument associated with assumed shape/rank device %s is known to be discontiguous on its first dimension"_err_en_US,1124 dummyName);1125 }1126 } else {1127 messages.Say(1128 "actual argument associated with assumed shape/rank device %s is not known to be contiguous on its first dimension"_warn_en_US,1129 dummyName);1130 }1131 }1132 bool isHostDeviceProc{procedure.cudaSubprogramAttrs &&1133 *procedure.cudaSubprogramAttrs ==1134 common::CUDASubprogramAttrs::HostDevice};1135 if (!common::AreCompatibleCUDADataAttrs(dummyDataAttr, actualDataAttr,1136 dummy.ignoreTKR, /*allowUnifiedMatchingRule=*/true,1137 isHostDeviceProc, &context.languageFeatures())) {1138 auto toStr{[](std::optional<common::CUDADataAttr> x) {1139 return x ? "ATTRIBUTES("s +1140 parser::ToUpperCaseLetters(common::EnumToString(*x)) + ")"s1141 : "no CUDA data attribute"s;1142 }};1143 messages.Say(1144 "%s has %s but its associated actual argument has %s"_err_en_US,1145 dummyName, toStr(dummyDataAttr), toStr(actualDataAttr));1146 }1147 }1148 1149 // Warning for breaking F'2023 change with character allocatables1150 if (intrinsic && dummy.intent != common::Intent::In) {1151 WarnOnDeferredLengthCharacterScalar(1152 context, &actual, messages.at(), dummyName.c_str());1153 }1154 1155 // %VAL() and %REF() checking for explicit interface1156 if ((arg.isPercentRef() || arg.isPercentVal()) &&1157 dummy.IsPassedByDescriptor(procedure.IsBindC())) {1158 messages.Say(1159 "%%VAL or %%REF are not allowed for %s that must be passed by means of a descriptor"_err_en_US,1160 dummyName);1161 }1162 if (arg.isPercentVal() &&1163 (!actualType.type().IsLengthlessIntrinsicType() ||1164 actualType.Rank() != 0)) {1165 messages.Say(1166 "%VAL argument must be a scalar numeric or logical expression"_err_en_US);1167 }1168}1169 1170static void CheckProcedureArg(evaluate::ActualArgument &arg,1171 const characteristics::Procedure &proc,1172 const characteristics::DummyProcedure &dummy, const std::string &dummyName,1173 SemanticsContext &context, bool ignoreImplicitVsExplicit) {1174 evaluate::FoldingContext &foldingContext{context.foldingContext()};1175 parser::ContextualMessages &messages{foldingContext.messages()};1176 parser::CharBlock location{arg.sourceLocation().value_or(messages.at())};1177 auto restorer{messages.SetLocation(location)};1178 const characteristics::Procedure &interface { dummy.procedure.value() };1179 if (const auto *expr{arg.UnwrapExpr()}) {1180 bool dummyIsPointer{1181 dummy.attrs.test(characteristics::DummyProcedure::Attr::Pointer)};1182 const auto *argProcDesignator{1183 std::get_if<evaluate::ProcedureDesignator>(&expr->u)};1184 const auto *argProcSymbol{1185 argProcDesignator ? argProcDesignator->GetSymbol() : nullptr};1186 if (argProcSymbol) {1187 if (const auto *subp{1188 argProcSymbol->GetUltimate().detailsIf<SubprogramDetails>()}) {1189 if (subp->stmtFunction()) {1190 evaluate::SayWithDeclaration(messages, *argProcSymbol,1191 "Statement function '%s' may not be passed as an actual argument"_err_en_US,1192 argProcSymbol->name());1193 return;1194 }1195 } else if (argProcSymbol->has<ProcBindingDetails>()) {1196 if (!context.IsEnabled(common::LanguageFeature::BindingAsProcedure)) {1197 evaluate::SayWithDeclaration(messages, *argProcSymbol,1198 "Procedure binding '%s' passed as an actual argument"_err_en_US,1199 argProcSymbol->name());1200 } else {1201 evaluate::WarnWithDeclaration(foldingContext, *argProcSymbol,1202 common::LanguageFeature::BindingAsProcedure,1203 "Procedure binding '%s' passed as an actual argument"_port_en_US,1204 argProcSymbol->name());1205 }1206 }1207 }1208 if (auto argChars{characteristics::DummyArgument::FromActual(1209 "actual argument", *expr, foldingContext,1210 /*forImplicitInterface=*/true)}) {1211 if (!argChars->IsTypelessIntrinsicDummy()) {1212 if (auto *argProc{1213 std::get_if<characteristics::DummyProcedure>(&argChars->u)}) {1214 characteristics::Procedure &argInterface{argProc->procedure.value()};1215 argInterface.attrs.reset(1216 characteristics::Procedure::Attr::NullPointer);1217 argInterface.attrs.reset(1218 characteristics::Procedure::Attr::NullAllocatable);1219 if (!argProcSymbol || argProcSymbol->attrs().test(Attr::INTRINSIC)) {1220 // It's ok to pass ELEMENTAL unrestricted intrinsic functions.1221 argInterface.attrs.reset(1222 characteristics::Procedure::Attr::Elemental);1223 } else if (argInterface.attrs.test(1224 characteristics::Procedure::Attr::Elemental)) {1225 if (argProcSymbol) { // C15331226 evaluate::SayWithDeclaration(messages, *argProcSymbol,1227 "Non-intrinsic ELEMENTAL procedure '%s' may not be passed as an actual argument"_err_en_US,1228 argProcSymbol->name());1229 return; // avoid piling on with checks below1230 } else {1231 argInterface.attrs.reset(1232 characteristics::Procedure::Attr::NullPointer);1233 argInterface.attrs.reset(1234 characteristics::Procedure::Attr::NullAllocatable);1235 }1236 }1237 if (interface.HasExplicitInterface()) {1238 std::string whyNot;1239 std::optional<std::string> warning;1240 if (!interface.IsCompatibleWith(argInterface,1241 ignoreImplicitVsExplicit, &whyNot,1242 /*specificIntrinsic=*/nullptr, &warning)) {1243 // 15.5.2.9(1): Explicit interfaces must match1244 if (argInterface.HasExplicitInterface()) {1245 messages.Say(1246 "Actual procedure argument has interface incompatible with %s: %s"_err_en_US,1247 dummyName, whyNot);1248 return;1249 } else if (proc.IsPure()) {1250 messages.Say(1251 "Actual procedure argument for %s of a PURE procedure must have an explicit interface"_err_en_US,1252 dummyName);1253 } else {1254 foldingContext.Warn(1255 common::UsageWarning::ImplicitInterfaceActual,1256 "Actual procedure argument has an implicit interface which is not known to be compatible with %s which has an explicit interface"_warn_en_US,1257 dummyName);1258 }1259 } else if (warning) {1260 foldingContext.Warn(common::UsageWarning::ProcDummyArgShapes,1261 "Actual procedure argument has possible interface incompatibility with %s: %s"_warn_en_US,1262 dummyName, std::move(*warning));1263 }1264 } else { // 15.5.2.9(2,3)1265 if (interface.IsSubroutine() && argInterface.IsFunction()) {1266 messages.Say(1267 "Actual argument associated with procedure %s is a function but must be a subroutine"_err_en_US,1268 dummyName);1269 } else if (interface.IsFunction()) {1270 if (argInterface.IsFunction()) {1271 std::string whyNot;1272 if (!interface.functionResult->IsCompatibleWith(1273 *argInterface.functionResult, &whyNot)) {1274 messages.Say(1275 "Actual argument function associated with procedure %s is not compatible: %s"_err_en_US,1276 dummyName, whyNot);1277 }1278 } else if (argInterface.IsSubroutine()) {1279 messages.Say(1280 "Actual argument associated with procedure %s is a subroutine but must be a function"_err_en_US,1281 dummyName);1282 }1283 }1284 }1285 } else {1286 messages.Say(1287 "Actual argument associated with procedure %s is not a procedure"_err_en_US,1288 dummyName);1289 }1290 } else if (IsNullPointer(expr)) {1291 if (!dummyIsPointer &&1292 !dummy.attrs.test(1293 characteristics::DummyProcedure::Attr::Optional)) {1294 messages.Say(1295 "Actual argument associated with procedure %s is a null pointer"_err_en_US,1296 dummyName);1297 }1298 } else {1299 messages.Say(1300 "Actual argument associated with procedure %s is typeless"_err_en_US,1301 dummyName);1302 }1303 }1304 if (dummyIsPointer) {1305 if (dummy.intent == common::Intent::In) {1306 // need not be definable, can be a target1307 } else if (!IsProcedurePointer(*expr)) {1308 messages.Say(1309 "Actual argument associated with procedure pointer %s is not a procedure pointer"_err_en_US,1310 dummyName);1311 } else if (dummy.intent == common::Intent::Default) {1312 // ok, needs to be definable only if defined at run time1313 } else {1314 DefinabilityFlags flags{DefinabilityFlag::PointerDefinition};1315 if (dummy.intent != common::Intent::Out) {1316 flags.set(DefinabilityFlag::DoNotNoteDefinition);1317 }1318 if (auto whyNot{WhyNotDefinable(1319 location, context.FindScope(location), flags, *expr)}) {1320 if (auto *msg{messages.Say(1321 "Actual argument associated with INTENT(%s) procedure pointer %s is not definable"_err_en_US,1322 dummy.intent == common::Intent::Out ? "OUT" : "IN OUT",1323 dummyName)}) {1324 msg->Attach(1325 std::move(whyNot->set_severity(parser::Severity::Because)));1326 }1327 }1328 }1329 }1330 } else {1331 messages.Say(1332 "Assumed-type argument may not be forwarded as procedure %s"_err_en_US,1333 dummyName);1334 }1335}1336 1337// Allow BOZ literal actual arguments when they can be converted to a known1338// dummy argument type1339static void ConvertBOZLiteralArg(1340 evaluate::ActualArgument &arg, const evaluate::DynamicType &type) {1341 if (auto *expr{arg.UnwrapExpr()}) {1342 if (IsBOZLiteral(*expr)) {1343 if (auto converted{evaluate::ConvertToType(type, SomeExpr{*expr})}) {1344 arg = std::move(*converted);1345 }1346 }1347 }1348}1349 1350static void CheckExplicitInterfaceArg(evaluate::ActualArgument &arg,1351 const characteristics::DummyArgument &dummy,1352 const characteristics::Procedure &proc, SemanticsContext &context,1353 const Scope *scope, const evaluate::SpecificIntrinsic *intrinsic,1354 bool allowActualArgumentConversions, bool extentErrors,1355 bool ignoreImplicitVsExplicit) {1356 evaluate::FoldingContext &foldingContext{context.foldingContext()};1357 auto &messages{foldingContext.messages()};1358 std::string dummyName{"dummy argument"};1359 if (!dummy.name.empty()) {1360 dummyName += " '"s + parser::ToLowerCaseLetters(dummy.name) + "='";1361 }1362 auto restorer{1363 messages.SetLocation(arg.sourceLocation().value_or(messages.at()))};1364 auto CheckActualArgForLabel = [&](evaluate::ActualArgument &arg) {1365 if (arg.isAlternateReturn()) {1366 messages.Say(1367 "Alternate return label '%d' cannot be associated with %s"_err_en_US,1368 arg.GetLabel(), dummyName);1369 return false;1370 } else {1371 return true;1372 }1373 };1374 common::visit(1375 common::visitors{1376 [&](const characteristics::DummyDataObject &object) {1377 if (CheckActualArgForLabel(arg)) {1378 ConvertBOZLiteralArg(arg, object.type.type());1379 if (auto *expr{arg.UnwrapExpr()}) {1380 if (auto type{characteristics::TypeAndShape::Characterize(1381 *expr, foldingContext)}) {1382 arg.set_dummyIntent(object.intent);1383 bool isElemental{1384 object.type.Rank() == 0 && proc.IsElemental()};1385 CheckExplicitDataArg(object, dummyName, *expr, *type,1386 isElemental, context, foldingContext, scope, intrinsic,1387 allowActualArgumentConversions, extentErrors, proc, arg,1388 dummy);1389 } else if (object.type.type().IsTypelessIntrinsicArgument() &&1390 IsBOZLiteral(*expr)) {1391 // ok1392 } else if (object.type.type().IsTypelessIntrinsicArgument() &&1393 evaluate::IsNullObjectPointer(expr)) {1394 // ok, ASSOCIATED(NULL(without MOLD=))1395 } else if (object.type.attrs().test(characteristics::1396 TypeAndShape::Attr::AssumedRank) &&1397 evaluate::IsNullObjectPointer(expr) &&1398 (object.attrs.test(1399 characteristics::DummyDataObject::Attr::Allocatable) ||1400 object.attrs.test(1401 characteristics::DummyDataObject::Attr::Pointer) ||1402 !object.attrs.test(characteristics::DummyDataObject::1403 Attr::Optional))) {1404 messages.Say(1405 "NULL() without MOLD= must not be associated with an assumed-rank dummy argument that is ALLOCATABLE, POINTER, or non-OPTIONAL"_err_en_US);1406 } else if ((object.attrs.test(characteristics::DummyDataObject::1407 Attr::Pointer) ||1408 object.attrs.test(characteristics::1409 DummyDataObject::Attr::Optional)) &&1410 evaluate::IsNullObjectPointer(expr)) {1411 // FOO(NULL(without MOLD=))1412 if (object.type.type().IsAssumedLengthCharacter()) {1413 messages.Say(1414 "Actual argument associated with %s is a NULL() pointer without a MOLD= to provide a character length"_err_en_US,1415 dummyName);1416 } else if (const DerivedTypeSpec *1417 derived{GetDerivedTypeSpec(object.type.type())}) {1418 for (const auto &[pName, pValue] : derived->parameters()) {1419 if (pValue.isAssumed()) {1420 messages.Say(1421 "Actual argument associated with %s is a NULL() pointer without a MOLD= to provide a value for the assumed type parameter '%s'"_err_en_US,1422 dummyName, pName.ToString());1423 break;1424 }1425 }1426 }1427 } else if (object.attrs.test(characteristics::DummyDataObject::1428 Attr::Allocatable) &&1429 (evaluate::IsNullAllocatable(expr) ||1430 evaluate::IsBareNullPointer(expr))) {1431 if (object.intent == common::Intent::Out ||1432 object.intent == common::Intent::InOut) {1433 messages.Say(1434 "NULL() actual argument '%s' may not be associated with allocatable dummy argument %s that is INTENT(OUT) or INTENT(IN OUT)"_err_en_US,1435 expr->AsFortran(), dummyName);1436 } else if (object.intent == common::Intent::Default) {1437 foldingContext.Warn(1438 common::UsageWarning::1439 NullActualForDefaultIntentAllocatable,1440 "NULL() actual argument '%s' should not be associated with allocatable dummy argument %s without INTENT(IN)"_warn_en_US,1441 expr->AsFortran(), dummyName);1442 } else {1443 foldingContext.Warn(1444 common::LanguageFeature::NullActualForAllocatable,1445 "Allocatable %s is associated with %s"_port_en_US,1446 dummyName, expr->AsFortran());1447 }1448 } else {1449 messages.Say(1450 "Actual argument '%s' associated with %s is not a variable or typed expression"_err_en_US,1451 expr->AsFortran(), dummyName);1452 }1453 } else {1454 const Symbol &assumed{DEREF(arg.GetAssumedTypeDummy())};1455 if (!object.type.type().IsAssumedType()) {1456 messages.Say(1457 "Assumed-type '%s' may be associated only with an assumed-type %s"_err_en_US,1458 assumed.name(), dummyName);1459 } else if (object.type.attrs().test(characteristics::1460 TypeAndShape::Attr::AssumedRank) &&1461 !IsAssumedShape(assumed) && !IsAssumedRank(assumed)) {1462 messages.Say( // C7111463 "Assumed-type '%s' must be either assumed shape or assumed rank to be associated with assumed rank %s"_err_en_US,1464 assumed.name(), dummyName);1465 }1466 }1467 }1468 },1469 [&](const characteristics::DummyProcedure &dummy) {1470 if (CheckActualArgForLabel(arg)) {1471 CheckProcedureArg(arg, proc, dummy, dummyName, context,1472 ignoreImplicitVsExplicit);1473 }1474 },1475 [&](const characteristics::AlternateReturn &) {1476 // All semantic checking is done elsewhere1477 },1478 },1479 dummy.u);1480}1481 1482static void RearrangeArguments(const characteristics::Procedure &proc,1483 evaluate::ActualArguments &actuals, parser::ContextualMessages &messages) {1484 CHECK(proc.HasExplicitInterface());1485 if (actuals.size() < proc.dummyArguments.size()) {1486 actuals.resize(proc.dummyArguments.size());1487 } else if (actuals.size() > proc.dummyArguments.size()) {1488 messages.Say(1489 "Too many actual arguments (%zd) passed to procedure that expects only %zd"_err_en_US,1490 actuals.size(), proc.dummyArguments.size());1491 }1492 std::map<std::string, evaluate::ActualArgument> kwArgs;1493 bool anyKeyword{false};1494 int which{1};1495 for (auto &x : actuals) {1496 if (!x) {1497 } else if (x->keyword()) {1498 auto emplaced{1499 kwArgs.try_emplace(x->keyword()->ToString(), std::move(*x))};1500 if (!emplaced.second) {1501 messages.Say(*x->keyword(),1502 "Argument keyword '%s=' appears on more than one effective argument in this procedure reference"_err_en_US,1503 *x->keyword());1504 }1505 x.reset();1506 anyKeyword = true;1507 } else if (anyKeyword) {1508 messages.Say(x ? x->sourceLocation() : std::nullopt,1509 "Actual argument #%d without a keyword may not follow any actual argument with a keyword"_err_en_US,1510 which);1511 }1512 ++which;1513 }1514 if (!kwArgs.empty()) {1515 int index{0};1516 for (const auto &dummy : proc.dummyArguments) {1517 if (!dummy.name.empty()) {1518 auto iter{kwArgs.find(dummy.name)};1519 if (iter != kwArgs.end()) {1520 evaluate::ActualArgument &x{iter->second};1521 if (actuals[index]) {1522 messages.Say(*x.keyword(),1523 "Keyword argument '%s=' has already been specified positionally (#%d) in this procedure reference"_err_en_US,1524 *x.keyword(), index + 1);1525 } else {1526 actuals[index] = std::move(x);1527 }1528 kwArgs.erase(iter);1529 }1530 }1531 ++index;1532 }1533 for (auto &bad : kwArgs) {1534 evaluate::ActualArgument &x{bad.second};1535 messages.Say(*x.keyword(),1536 "Argument keyword '%s=' is not recognized for this procedure reference"_err_en_US,1537 *x.keyword());1538 }1539 }1540}1541 1542// 15.8.1(3) -- In a reference to an elemental procedure, if any argument is an1543// array, each actual argument that corresponds to an INTENT(OUT) or1544// INTENT(INOUT) dummy argument shall be an array. The actual argument to an1545// ELEMENTAL procedure must conform.1546static bool CheckElementalConformance(parser::ContextualMessages &messages,1547 const characteristics::Procedure &proc, evaluate::ActualArguments &actuals,1548 evaluate::FoldingContext &context) {1549 std::optional<evaluate::Shape> shape;1550 std::string shapeName;1551 int index{0};1552 bool hasArrayArg{false};1553 for (const auto &arg : actuals) {1554 if (arg && !arg->isAlternateReturn() && arg->Rank() > 0) {1555 hasArrayArg = true;1556 break;1557 }1558 }1559 for (const auto &arg : actuals) {1560 const auto &dummy{proc.dummyArguments.at(index++)};1561 if (arg) {1562 if (const auto *expr{arg->UnwrapExpr()}) {1563 if (const auto *wholeSymbol{evaluate::UnwrapWholeSymbolDataRef(arg)}) {1564 wholeSymbol = &ResolveAssociations(*wholeSymbol);1565 if (IsAssumedSizeArray(*wholeSymbol)) {1566 evaluate::SayWithDeclaration(messages, *wholeSymbol,1567 "Whole assumed-size array '%s' may not be used as an argument to an elemental procedure"_err_en_US,1568 wholeSymbol->name());1569 } else if (IsAssumedRank(*wholeSymbol)) {1570 evaluate::SayWithDeclaration(messages, *wholeSymbol,1571 "Assumed-rank array '%s' may not be used as an argument to an elemental procedure"_err_en_US,1572 wholeSymbol->name());1573 }1574 }1575 if (auto argShape{evaluate::GetShape(context, *expr)}) {1576 if (GetRank(*argShape) > 0) {1577 std::string argName{"actual argument ("s + expr->AsFortran() +1578 ") corresponding to dummy argument #" + std::to_string(index) +1579 " ('" + dummy.name + "')"};1580 if (shape) {1581 if (!evaluate::CheckConformance(messages, *shape, *argShape,1582 evaluate::CheckConformanceFlags::None, shapeName.c_str(),1583 argName.c_str())1584 .value_or(true)) {1585 return false;1586 }1587 } else {1588 shape = std::move(argShape);1589 shapeName = argName;1590 }1591 } else if ((dummy.GetIntent() == common::Intent::Out ||1592 dummy.GetIntent() == common::Intent::InOut) &&1593 hasArrayArg) {1594 messages.Say(1595 "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,1596 expr->AsFortran());1597 }1598 }1599 }1600 }1601 }1602 return true;1603}1604 1605// ASSOCIATED (16.9.16)1606static void CheckAssociated(evaluate::ActualArguments &arguments,1607 SemanticsContext &semanticsContext, const Scope *scope) {1608 evaluate::FoldingContext &foldingContext{semanticsContext.foldingContext()};1609 parser::ContextualMessages &messages{foldingContext.messages()};1610 bool ok{true};1611 if (arguments.size() < 2) {1612 return;1613 }1614 if (const auto &pointerArg{arguments[0]}) {1615 if (const auto *pointerExpr{pointerArg->UnwrapExpr()}) {1616 if (!IsPointer(*pointerExpr)) {1617 messages.Say(pointerArg->sourceLocation(),1618 "POINTER= argument of ASSOCIATED() must be a pointer"_err_en_US);1619 return;1620 }1621 if (const auto &targetArg{arguments[1]}) {1622 // The standard requires that the TARGET= argument, when present,1623 // be type compatible with the POINTER= for a data pointer. In1624 // the case of procedure pointers, the standard requires that it1625 // be a valid RHS for a pointer assignment that has the POINTER=1626 // argument as its LHS. Some popular compilers misinterpret this1627 // requirement more strongly than necessary, and actually validate1628 // the POINTER= argument as if it were serving as the LHS of a pointer1629 // assignment. This, perhaps unintentionally, excludes function1630 // results, including NULL(), from being used there, as well as1631 // INTENT(IN) dummy pointers. Detect these conditions and emit1632 // portability warnings.1633 if (semanticsContext.ShouldWarn(common::UsageWarning::Portability)) {1634 if (!evaluate::ExtractDataRef(*pointerExpr) &&1635 !evaluate::IsProcedurePointer(*pointerExpr)) {1636 foldingContext.Warn(common::UsageWarning::Portability,1637 pointerArg->sourceLocation(),1638 "POINTER= argument of ASSOCIATED() is required by some other compilers to be a pointer"_port_en_US);1639 } else if (scope && !evaluate::UnwrapProcedureRef(*pointerExpr)) {1640 if (auto whyNot{WhyNotDefinable(1641 pointerArg->sourceLocation().value_or(messages.at()),1642 *scope,1643 DefinabilityFlags{DefinabilityFlag::PointerDefinition,1644 DefinabilityFlag::DoNotNoteDefinition},1645 *pointerExpr)}) {1646 if (whyNot->IsFatal()) {1647 if (auto *msg{foldingContext.Warn(1648 common::UsageWarning::Portability,1649 pointerArg->sourceLocation(),1650 "POINTER= argument of ASSOCIATED() is required by some other compilers to be a valid left-hand side of a pointer assignment statement"_port_en_US)}) {1651 msg->Attach(std::move(1652 whyNot->set_severity(parser::Severity::Because)));1653 }1654 } else {1655 messages.Say(std::move(*whyNot));1656 }1657 }1658 }1659 }1660 if (const auto *targetExpr{targetArg->UnwrapExpr()}) {1661 if (IsProcedurePointer(*pointerExpr) &&1662 !IsBareNullPointer(pointerExpr)) { // POINTER= is a procedure1663 if (auto pointerProc{characteristics::Procedure::Characterize(1664 *pointerExpr, foldingContext)}) {1665 if (IsBareNullPointer(targetExpr)) {1666 } else if (IsProcedurePointerTarget(*targetExpr)) {1667 if (auto targetProc{characteristics::Procedure::Characterize(1668 *targetExpr, foldingContext)}) {1669 bool isCall{!!UnwrapProcedureRef(*targetExpr)};1670 std::string whyNot;1671 std::optional<std::string> warning;1672 const auto *targetProcDesignator{1673 evaluate::UnwrapExpr<evaluate::ProcedureDesignator>(1674 *targetExpr)};1675 const evaluate::SpecificIntrinsic *specificIntrinsic{1676 targetProcDesignator1677 ? targetProcDesignator->GetSpecificIntrinsic()1678 : nullptr};1679 std::optional<parser::MessageFixedText> msg{1680 CheckProcCompatibility(isCall, pointerProc, &*targetProc,1681 specificIntrinsic, whyNot, warning,1682 /*ignoreImplicitVsExplicit=*/false)};1683 std::optional<common::UsageWarning> whichWarning;1684 if (!msg && warning &&1685 semanticsContext.ShouldWarn(1686 common::UsageWarning::ProcDummyArgShapes)) {1687 whichWarning = common::UsageWarning::ProcDummyArgShapes;1688 msg =1689 "Procedures '%s' and '%s' may not be completely compatible: %s"_warn_en_US;1690 whyNot = std::move(*warning);1691 } else if (msg && !msg->IsFatal() &&1692 semanticsContext.ShouldWarn(1693 common::UsageWarning::ProcPointerCompatibility)) {1694 whichWarning =1695 common::UsageWarning::ProcPointerCompatibility;1696 }1697 if (msg && (msg->IsFatal() || whichWarning)) {1698 if (auto *said{messages.Say(std::move(*msg),1699 "pointer '" + pointerExpr->AsFortran() + "'",1700 targetExpr->AsFortran(), whyNot)};1701 said && whichWarning) {1702 said->set_usageWarning(*whichWarning);1703 }1704 }1705 }1706 } else if (!IsNullProcedurePointer(targetExpr)) {1707 messages.Say(1708 "POINTER= argument '%s' is a procedure pointer but the TARGET= argument '%s' is not a procedure or procedure pointer"_err_en_US,1709 pointerExpr->AsFortran(), targetExpr->AsFortran());1710 }1711 }1712 } else if (IsVariable(*targetExpr) || IsNullPointer(targetExpr)) {1713 // Object pointer and target1714 if (ExtractDataRef(*targetExpr)) {1715 if (SymbolVector symbols{GetSymbolVector(*targetExpr)};1716 !evaluate::GetLastTarget(symbols)) {1717 parser::Message *msg{messages.Say(targetArg->sourceLocation(),1718 "TARGET= argument '%s' must have either the POINTER or the TARGET attribute"_err_en_US,1719 targetExpr->AsFortran())};1720 for (SymbolRef ref : symbols) {1721 msg = evaluate::AttachDeclaration(msg, *ref);1722 }1723 } else if (HasVectorSubscript(*targetExpr) ||1724 ExtractCoarrayRef(*targetExpr)) {1725 messages.Say(targetArg->sourceLocation(),1726 "TARGET= argument '%s' may not have a vector subscript or coindexing"_err_en_US,1727 targetExpr->AsFortran());1728 }1729 }1730 if (const auto pointerType{pointerArg->GetType()}) {1731 if (const auto targetType{targetArg->GetType()}) {1732 ok = pointerType->IsTkCompatibleWith(*targetType) ||1733 targetType->IsTkCompatibleWith(*pointerType);1734 }1735 }1736 } else {1737 messages.Say(1738 "POINTER= argument '%s' is an object pointer but the TARGET= argument '%s' is not a variable"_err_en_US,1739 pointerExpr->AsFortran(), targetExpr->AsFortran());1740 }1741 if (!IsAssumedRank(*pointerExpr)) {1742 if (IsAssumedRank(*targetExpr)) {1743 messages.Say(1744 "TARGET= argument '%s' may not be assumed-rank when POINTER= argument is not"_err_en_US,1745 pointerExpr->AsFortran());1746 } else if (pointerExpr->Rank() != targetExpr->Rank()) {1747 messages.Say(1748 "POINTER= argument and TARGET= argument have incompatible ranks %d and %d"_err_en_US,1749 pointerExpr->Rank(), targetExpr->Rank());1750 }1751 }1752 }1753 }1754 }1755 } else {1756 // No arguments to ASSOCIATED()1757 ok = false;1758 }1759 if (!ok) {1760 messages.Say(1761 "Arguments of ASSOCIATED() must be a pointer and an optional valid target"_err_en_US);1762 }1763}1764 1765// CO_REDUCE (F'2023 16.9.49)1766static void CheckCoReduce(1767 evaluate::ActualArguments &arguments, evaluate::FoldingContext &context) {1768 parser::ContextualMessages &messages{context.messages()};1769 evaluate::CheckForCoindexedObject(1770 context.messages(), arguments[0], "co_reduce", "a");1771 evaluate::CheckForCoindexedObject(1772 context.messages(), arguments[2], "co_reduce", "stat");1773 evaluate::CheckForCoindexedObject(1774 context.messages(), arguments[3], "co_reduce", "errmsg");1775 1776 std::optional<evaluate::DynamicType> aType;1777 if (const auto &a{arguments[0]}) {1778 aType = a->GetType();1779 }1780 std::optional<characteristics::Procedure> procChars;1781 if (const auto &operation{arguments[1]}) {1782 if (const auto *expr{operation->UnwrapExpr()}) {1783 if (const auto *designator{1784 std::get_if<evaluate::ProcedureDesignator>(&expr->u)}) {1785 procChars = characteristics::Procedure::Characterize(1786 *designator, context, /*emitError=*/true);1787 } else if (const auto *ref{1788 std::get_if<evaluate::ProcedureRef>(&expr->u)}) {1789 procChars = characteristics::Procedure::Characterize(*ref, context);1790 }1791 }1792 }1793 1794 static constexpr characteristics::DummyDataObject::Attrs notAllowedArgAttrs{1795 characteristics::DummyDataObject::Attr::Optional,1796 characteristics::DummyDataObject::Attr::Allocatable,1797 characteristics::DummyDataObject::Attr::Pointer,1798 };1799 static constexpr characteristics::FunctionResult::Attrs1800 notAllowedFuncResAttrs{1801 characteristics::FunctionResult::Attr::Allocatable,1802 characteristics::FunctionResult::Attr::Pointer,1803 };1804 const characteristics::TypeAndShape *result{1805 procChars && procChars->functionResult1806 ? procChars->functionResult->GetTypeAndShape()1807 : nullptr};1808 if (!procChars || !procChars->IsPure() ||1809 procChars->dummyArguments.size() != 2 || !procChars->functionResult) {1810 messages.Say(1811 "OPERATION= argument of CO_REDUCE() must be a pure function of two data arguments"_err_en_US);1812 } else if (procChars->attrs.test(characteristics::Procedure::Attr::BindC)) {1813 messages.Say(1814 "A BIND(C) OPERATION= argument of CO_REDUCE() is not supported"_err_en_US);1815 } else if (!result || result->Rank() != 0) {1816 messages.Say(1817 "OPERATION= argument of CO_REDUCE() must be a scalar function"_err_en_US);1818 } else if (result->type().IsPolymorphic() ||1819 (aType && !aType->IsTkLenCompatibleWith(result->type()))) {1820 messages.Say(1821 "OPERATION= argument of CO_REDUCE() must have the same type as A="_err_en_US);1822 } else if (((procChars->functionResult->attrs & notAllowedFuncResAttrs) !=1823 characteristics::FunctionResult::Attrs{}) ||1824 procChars->functionResult->GetTypeAndShape()->type().IsPolymorphic()) {1825 messages.Say(1826 "Result of OPERATION= procedure of CO_REDUCE() must be scalar and neither allocatable, pointer, nor polymorphic"_err_en_US);1827 } else {1828 const characteristics::DummyDataObject *data[2]{};1829 for (int j{0}; j < 2; ++j) {1830 const auto &dummy{procChars->dummyArguments.at(j)};1831 data[j] = std::get_if<characteristics::DummyDataObject>(&dummy.u);1832 }1833 if (!data[0] || !data[1]) {1834 messages.Say(1835 "OPERATION= argument of CO_REDUCE() may not have dummy procedure arguments"_err_en_US);1836 } else {1837 for (int j{0}; j < 2; ++j) {1838 if (((data[j]->attrs & notAllowedArgAttrs) !=1839 characteristics::DummyDataObject::Attrs{}) ||1840 data[j]->type.Rank() != 0 || data[j]->type.type().IsPolymorphic() ||1841 (aType && !data[j]->type.type().IsTkCompatibleWith(*aType))) {1842 messages.Say(1843 "Arguments of OPERATION= procedure of CO_REDUCE() must be both scalar of the same type as A=, and neither allocatable, pointer, polymorphic, nor optional"_err_en_US);1844 break;1845 }1846 }1847 static constexpr characteristics::DummyDataObject::Attrs attrs{1848 characteristics::DummyDataObject::Attr::Asynchronous,1849 characteristics::DummyDataObject::Attr::Target,1850 characteristics::DummyDataObject::Attr::Value,1851 };1852 if ((data[0]->attrs & attrs) != (data[1]->attrs & attrs)) {1853 messages.Say(1854 "If either argument of the OPERATION= procedure of CO_REDUCE() has the ASYNCHRONOUS, TARGET, or VALUE attribute, both must have that attribute"_err_en_US);1855 }1856 }1857 }1858}1859 1860// EVENT_QUERY (F'2023 16.9.82)1861static void CheckEvent_Query(evaluate::ActualArguments &arguments,1862 evaluate::FoldingContext &foldingContext) {1863 if (arguments.size() > 0 && arguments[0] &&1864 ExtractCoarrayRef(*arguments[0]).has_value()) {1865 foldingContext.messages().Say(arguments[0]->sourceLocation(),1866 "EVENT= argument to EVENT_QUERY must not be coindexed"_err_en_US);1867 }1868 if (arguments.size() > 1 && arguments[1]) {1869 if (auto dyType{arguments[1]->GetType()}) {1870 int defaultInt{1871 foldingContext.defaults().GetDefaultKind(TypeCategory::Integer)};1872 if (dyType->category() == TypeCategory::Integer &&1873 dyType->kind() < defaultInt) {1874 foldingContext.messages().Say(arguments[1]->sourceLocation(),1875 "COUNT= argument to EVENT_QUERY must be an integer with kind >= %d"_err_en_US,1876 defaultInt);1877 }1878 }1879 }1880 if (arguments.size() > 2 && arguments[2]) {1881 if (auto dyType{arguments[2]->GetType()}) {1882 if (dyType->category() == TypeCategory::Integer && dyType->kind() < 2) {1883 foldingContext.messages().Say(arguments[2]->sourceLocation(),1884 "STAT= argument to EVENT_QUERY must be an integer with kind >= 2 when present"_err_en_US);1885 }1886 }1887 }1888}1889 1890// IMAGE_INDEX (F'2023 16.9.107)1891static void CheckImage_Index(evaluate::ActualArguments &arguments,1892 parser::ContextualMessages &messages) {1893 if (arguments[1] && arguments[0]) {1894 if (const auto subArrShape{1895 evaluate::GetShape(arguments[1]->UnwrapExpr())}) {1896 if (const auto *coarrayArgSymbol{UnwrapWholeSymbolOrComponentDataRef(1897 arguments[0]->UnwrapExpr())}) {1898 auto coarrayArgCorank{coarrayArgSymbol->Corank()};1899 if (auto subArrSize{evaluate::ToInt64(*subArrShape->front())}) {1900 if (subArrSize != coarrayArgCorank) {1901 messages.Say(arguments[1]->sourceLocation(),1902 "The size of 'SUB=' (%jd) for intrinsic 'image_index' must be equal to the corank of 'COARRAY=' (%d)"_err_en_US,1903 static_cast<std::int64_t>(*subArrSize), coarrayArgCorank);1904 }1905 }1906 }1907 }1908 }1909}1910 1911// Ensure that any optional argument that might be absent at run time1912// does not require data conversion.1913static void CheckMaxMin(const characteristics::Procedure &proc,1914 evaluate::ActualArguments &arguments,1915 parser::ContextualMessages &messages) {1916 if (proc.functionResult) {1917 if (const auto *typeAndShape{proc.functionResult->GetTypeAndShape()}) {1918 for (std::size_t j{2}; j < arguments.size(); ++j) {1919 if (arguments[j]) {1920 if (const auto *expr{arguments[j]->UnwrapExpr()};1921 expr && evaluate::MayBePassedAsAbsentOptional(*expr)) {1922 if (auto thisType{expr->GetType()}) {1923 if (thisType->category() == TypeCategory::Character &&1924 typeAndShape->type().category() == TypeCategory::Character &&1925 thisType->kind() == typeAndShape->type().kind()) {1926 // don't care about lengths1927 } else if (*thisType != typeAndShape->type()) {1928 messages.Say(arguments[j]->sourceLocation(),1929 "An actual argument to MAX/MIN requiring data conversion may not be OPTIONAL, POINTER, or ALLOCATABLE"_err_en_US);1930 }1931 }1932 }1933 }1934 }1935 }1936 }1937}1938 1939static void CheckFree(evaluate::ActualArguments &arguments,1940 parser::ContextualMessages &messages) {1941 if (arguments.size() != 1) {1942 messages.Say("FREE expects a single argument"_err_en_US);1943 }1944 auto arg = arguments[0];1945 if (const Symbol * symbol{evaluate::UnwrapWholeSymbolDataRef(arg)};1946 !symbol || !symbol->test(Symbol::Flag::CrayPointer)) {1947 messages.Say("FREE should only be used with Cray pointers"_warn_en_US);1948 }1949}1950 1951// MOVE_ALLOC (F'2023 16.9.147)1952static void CheckMove_Alloc(evaluate::ActualArguments &arguments,1953 parser::ContextualMessages &messages) {1954 if (arguments.size() >= 1) {1955 evaluate::CheckForCoindexedObject(1956 messages, arguments[0], "move_alloc", "from");1957 }1958 if (arguments.size() >= 2) {1959 evaluate::CheckForCoindexedObject(1960 messages, arguments[1], "move_alloc", "to");1961 int fromCR{GetCorank(arguments[0])};1962 int toCR{GetCorank(arguments[1])};1963 if (fromCR != toCR) {1964 messages.Say(*arguments[0]->sourceLocation(),1965 "FROM= argument to MOVE_ALLOC has corank %d, but TO= argument has corank %d"_err_en_US,1966 fromCR, toCR);1967 }1968 }1969 if (arguments.size() >= 3) {1970 evaluate::CheckForCoindexedObject(1971 messages, arguments[2], "move_alloc", "stat");1972 }1973 if (arguments.size() >= 4) {1974 evaluate::CheckForCoindexedObject(1975 messages, arguments[3], "move_alloc", "errmsg");1976 }1977 if (arguments.size() >= 2 && arguments[0] && arguments[1]) {1978 for (int j{0}; j < 2; ++j) {1979 if (const Symbol *1980 whole{UnwrapWholeSymbolOrComponentDataRef(arguments[j])};1981 !whole || !IsAllocatable(whole->GetUltimate())) {1982 messages.Say(*arguments[j]->sourceLocation(),1983 "Argument #%d to MOVE_ALLOC must be allocatable"_err_en_US, j + 1);1984 }1985 }1986 auto type0{arguments[0]->GetType()};1987 auto type1{arguments[1]->GetType()};1988 if (type0 && type1 && type0->IsPolymorphic() && !type1->IsPolymorphic()) {1989 messages.Say(arguments[1]->sourceLocation(),1990 "When MOVE_ALLOC(FROM=) is polymorphic, TO= must also be polymorphic"_err_en_US);1991 }1992 }1993}1994 1995// PRESENT (F'2023 16.9.163)1996static void CheckPresent(evaluate::ActualArguments &arguments,1997 parser::ContextualMessages &messages) {1998 if (arguments.size() == 1) {1999 if (const auto &arg{arguments[0]}; arg) {2000 const Symbol *symbol{nullptr};2001 if (const auto *expr{arg->UnwrapExpr()}) {2002 if (const auto *proc{2003 std::get_if<evaluate::ProcedureDesignator>(&expr->u)}) {2004 symbol = proc->GetSymbol();2005 } else {2006 symbol = evaluate::UnwrapWholeSymbolDataRef(*expr);2007 }2008 } else {2009 symbol = arg->GetAssumedTypeDummy();2010 }2011 if (!symbol ||2012 !symbol->GetUltimate().attrs().test(semantics::Attr::OPTIONAL)) {2013 messages.Say(arg ? arg->sourceLocation() : messages.at(),2014 "Argument of PRESENT() must be the name of a whole OPTIONAL dummy argument"_err_en_US);2015 }2016 }2017 }2018}2019 2020// REDUCE (F'2023 16.9.173)2021static void CheckReduce(2022 evaluate::ActualArguments &arguments, evaluate::FoldingContext &context) {2023 std::optional<evaluate::DynamicType> arrayType;2024 parser::ContextualMessages &messages{context.messages()};2025 if (const auto &array{arguments[0]}) {2026 arrayType = array->GetType();2027 if (!arguments[/*identity=*/4]) {2028 if (const auto *expr{array->UnwrapExpr()}) {2029 if (auto shape{2030 evaluate::GetShape(context, *expr, /*invariantOnly=*/false)}) {2031 if (const auto &dim{arguments[2]}; dim && array->Rank() > 1) {2032 // Partial reduction2033 auto dimVal{evaluate::ToInt64(dim->UnwrapExpr())};2034 std::int64_t j{0};2035 int zeroDims{0};2036 bool isSelectedDimEmpty{false};2037 for (const auto &extent : *shape) {2038 ++j;2039 if (evaluate::ToInt64(extent) == 0) {2040 ++zeroDims;2041 isSelectedDimEmpty |= dimVal && j == *dimVal;2042 }2043 }2044 if (isSelectedDimEmpty && zeroDims == 1) {2045 messages.Say(2046 "IDENTITY= must be present when DIM=%d and the array has zero extent on that dimension"_err_en_US,2047 static_cast<int>(dimVal.value()));2048 }2049 } else { // no DIM= or DIM=1 on a vector: total reduction2050 for (const auto &extent : *shape) {2051 if (evaluate::ToInt64(extent) == 0) {2052 messages.Say(2053 "IDENTITY= must be present when the array is empty and the result is scalar"_err_en_US);2054 break;2055 }2056 }2057 }2058 }2059 }2060 }2061 }2062 std::optional<characteristics::Procedure> procChars;2063 if (const auto &operation{arguments[1]}) {2064 if (const auto *expr{operation->UnwrapExpr()}) {2065 if (const auto *designator{2066 std::get_if<evaluate::ProcedureDesignator>(&expr->u)}) {2067 procChars = characteristics::Procedure::Characterize(2068 *designator, context, /*emitError=*/true);2069 } else if (const auto *ref{2070 std::get_if<evaluate::ProcedureRef>(&expr->u)}) {2071 procChars = characteristics::Procedure::Characterize(*ref, context);2072 }2073 }2074 }2075 const auto *result{procChars && procChars->functionResult2076 ? procChars->functionResult->GetTypeAndShape()2077 : nullptr};2078 if (!procChars || !procChars->IsPure() ||2079 procChars->dummyArguments.size() != 2 || !procChars->functionResult) {2080 messages.Say(2081 "OPERATION= argument of REDUCE() must be a pure function of two data arguments"_err_en_US);2082 } else if (procChars->attrs.test(characteristics::Procedure::Attr::BindC)) {2083 messages.Say(2084 "A BIND(C) OPERATION= argument of REDUCE() is not supported"_err_en_US);2085 } else if (!result || result->Rank() != 0) {2086 messages.Say(2087 "OPERATION= argument of REDUCE() must be a scalar function"_err_en_US);2088 } else if (result->type().IsPolymorphic() ||2089 (arrayType && !arrayType->IsTkLenCompatibleWith(result->type()))) {2090 messages.Say(2091 "OPERATION= argument of REDUCE() must have the same type as ARRAY="_err_en_US);2092 } else {2093 const characteristics::DummyDataObject *data[2]{};2094 for (int j{0}; j < 2; ++j) {2095 const auto &dummy{procChars->dummyArguments.at(j)};2096 data[j] = std::get_if<characteristics::DummyDataObject>(&dummy.u);2097 }2098 if (!data[0] || !data[1]) {2099 messages.Say(2100 "OPERATION= argument of REDUCE() may not have dummy procedure arguments"_err_en_US);2101 } else {2102 for (int j{0}; j < 2; ++j) {2103 if (data[j]->attrs.test(2104 characteristics::DummyDataObject::Attr::Optional) ||2105 data[j]->attrs.test(2106 characteristics::DummyDataObject::Attr::Allocatable) ||2107 data[j]->attrs.test(2108 characteristics::DummyDataObject::Attr::Pointer) ||2109 data[j]->type.Rank() != 0 || data[j]->type.type().IsPolymorphic() ||2110 (arrayType &&2111 !data[j]->type.type().IsTkCompatibleWith(*arrayType))) {2112 messages.Say(2113 "Arguments of OPERATION= procedure of REDUCE() must be both scalar of the same type as ARRAY=, and neither allocatable, pointer, polymorphic, nor optional"_err_en_US);2114 }2115 }2116 static constexpr characteristics::DummyDataObject::Attr attrs[]{2117 characteristics::DummyDataObject::Attr::Asynchronous,2118 characteristics::DummyDataObject::Attr::Target,2119 characteristics::DummyDataObject::Attr::Value,2120 };2121 for (std::size_t j{0}; j < sizeof attrs / sizeof *attrs; ++j) {2122 if (data[0]->attrs.test(attrs[j]) != data[1]->attrs.test(attrs[j])) {2123 messages.Say(2124 "If either argument of the OPERATION= procedure of REDUCE() has the ASYNCHRONOUS, TARGET, or VALUE attribute, both must have that attribute"_err_en_US);2125 break;2126 }2127 }2128 }2129 }2130 // When the MASK= is present and has no .TRUE. element, and there is2131 // no IDENTITY=, it's an error.2132 if (const auto &mask{arguments[3]}; mask && !arguments[/*identity*/ 4]) {2133 if (const auto *expr{mask->UnwrapExpr()}) {2134 if (const auto *logical{2135 std::get_if<evaluate::Expr<evaluate::SomeLogical>>(&expr->u)}) {2136 if (common::visit(2137 [](const auto &kindExpr) {2138 using KindExprType = std::decay_t<decltype(kindExpr)>;2139 using KindLogical = typename KindExprType::Result;2140 if (const auto *c{evaluate::UnwrapConstantValue<KindLogical>(2141 kindExpr)}) {2142 for (const auto &element : c->values()) {2143 if (element.IsTrue()) {2144 return false;2145 }2146 }2147 return true;2148 }2149 return false;2150 },2151 logical->u)) {2152 messages.Say(2153 "MASK= has no .TRUE. element, so IDENTITY= must be present"_err_en_US);2154 }2155 }2156 }2157 }2158}2159 2160// TRANSFER (16.9.193)2161static void CheckTransferOperandType(SemanticsContext &context,2162 const evaluate::DynamicType &type, const char *which) {2163 if (type.IsPolymorphic()) {2164 context.foldingContext().Warn(common::UsageWarning::PolymorphicTransferArg,2165 "%s of TRANSFER is polymorphic"_warn_en_US, which);2166 } else if (!type.IsUnlimitedPolymorphic() &&2167 type.category() == TypeCategory::Derived &&2168 context.ShouldWarn(common::UsageWarning::PointerComponentTransferArg)) {2169 DirectComponentIterator directs{type.GetDerivedTypeSpec()};2170 if (auto bad{std::find_if(directs.begin(), directs.end(), IsDescriptor)};2171 bad != directs.end()) {2172 evaluate::WarnWithDeclaration(context.foldingContext(), *bad,2173 common::UsageWarning::PointerComponentTransferArg,2174 "%s of TRANSFER contains allocatable or pointer component %s"_warn_en_US,2175 which, bad.BuildResultDesignatorName());2176 }2177 }2178}2179 2180static void CheckTransfer(evaluate::ActualArguments &arguments,2181 SemanticsContext &context, const Scope *scope) {2182 evaluate::FoldingContext &foldingContext{context.foldingContext()};2183 parser::ContextualMessages &messages{foldingContext.messages()};2184 if (arguments.size() >= 2) {2185 if (auto source{characteristics::TypeAndShape::Characterize(2186 arguments[0], foldingContext)}) {2187 CheckTransferOperandType(context, source->type(), "Source");2188 if (auto mold{characteristics::TypeAndShape::Characterize(2189 arguments[1], foldingContext)}) {2190 CheckTransferOperandType(context, mold->type(), "Mold");2191 if (mold->Rank() > 0 &&2192 evaluate::ToInt64(2193 evaluate::Fold(foldingContext,2194 mold->MeasureElementSizeInBytes(foldingContext, false)))2195 .value_or(1) == 0) {2196 if (auto sourceSize{evaluate::ToInt64(evaluate::Fold(foldingContext,2197 source->MeasureSizeInBytes(foldingContext)))}) {2198 if (*sourceSize > 0) {2199 messages.Say(2200 "Element size of MOLD= array may not be zero when SOURCE= is not empty"_err_en_US);2201 }2202 } else {2203 foldingContext.Warn(common::UsageWarning::VoidMold,2204 "Element size of MOLD= array may not be zero unless SOURCE= is empty"_warn_en_US);2205 }2206 }2207 }2208 }2209 if (arguments.size() > 2) { // SIZE=2210 if (const Symbol *2211 whole{UnwrapWholeSymbolOrComponentDataRef(arguments[2])}) {2212 if (IsOptional(*whole)) {2213 messages.Say(2214 "SIZE= argument may not be the optional dummy argument '%s'"_err_en_US,2215 whole->name());2216 } else if (context.ShouldWarn(2217 common::UsageWarning::TransferSizePresence) &&2218 IsAllocatableOrObjectPointer(whole)) {2219 foldingContext.Warn(common::UsageWarning::TransferSizePresence,2220 "SIZE= argument that is allocatable or pointer must be present at execution; parenthesize to silence this warning"_warn_en_US);2221 }2222 }2223 }2224 }2225}2226 2227static void CheckSpecificIntrinsic(const characteristics::Procedure &proc,2228 evaluate::ActualArguments &arguments, SemanticsContext &context,2229 const Scope *scope, const evaluate::SpecificIntrinsic &intrinsic) {2230 if (intrinsic.name == "associated") {2231 CheckAssociated(arguments, context, scope);2232 } else if (intrinsic.name == "co_reduce") {2233 CheckCoReduce(arguments, context.foldingContext());2234 } else if (intrinsic.name == "event_query") {2235 CheckEvent_Query(arguments, context.foldingContext());2236 } else if (intrinsic.name == "image_index") {2237 CheckImage_Index(arguments, context.foldingContext().messages());2238 } else if (intrinsic.name == "max" || intrinsic.name == "min") {2239 CheckMaxMin(proc, arguments, context.foldingContext().messages());2240 } else if (intrinsic.name == "move_alloc") {2241 CheckMove_Alloc(arguments, context.foldingContext().messages());2242 } else if (intrinsic.name == "present") {2243 CheckPresent(arguments, context.foldingContext().messages());2244 } else if (intrinsic.name == "reduce") {2245 CheckReduce(arguments, context.foldingContext());2246 } else if (intrinsic.name == "transfer") {2247 CheckTransfer(arguments, context, scope);2248 } else if (intrinsic.name == "free") {2249 CheckFree(arguments, context.foldingContext().messages());2250 }2251}2252 2253parser::Messages CheckExplicitInterface(const characteristics::Procedure &proc,2254 evaluate::ActualArguments &actuals, SemanticsContext &context,2255 const Scope *scope, const evaluate::SpecificIntrinsic *intrinsic,2256 bool allowActualArgumentConversions, bool extentErrors,2257 bool ignoreImplicitVsExplicit) {2258 evaluate::FoldingContext &foldingContext{context.foldingContext()};2259 parser::ContextualMessages &messages{foldingContext.messages()};2260 parser::Messages buffer;2261 auto restorer{messages.SetMessages(buffer)};2262 RearrangeArguments(proc, actuals, messages);2263 if (!buffer.empty()) {2264 return buffer;2265 }2266 int index{0};2267 for (auto &actual : actuals) {2268 const auto &dummy{proc.dummyArguments.at(index++)};2269 if (actual) {2270 CheckExplicitInterfaceArg(*actual, dummy, proc, context, scope, intrinsic,2271 allowActualArgumentConversions, extentErrors,2272 ignoreImplicitVsExplicit);2273 } else if (!dummy.IsOptional()) {2274 if (dummy.name.empty()) {2275 messages.Say(2276 "Dummy argument #%d is not OPTIONAL and is not associated with "2277 "an actual argument in this procedure reference"_err_en_US,2278 index);2279 } else {2280 messages.Say("Dummy argument '%s=' (#%d) is not OPTIONAL and is not "2281 "associated with an actual argument in this procedure "2282 "reference"_err_en_US,2283 dummy.name, index);2284 }2285 }2286 }2287 if (proc.IsElemental() && !buffer.AnyFatalError()) {2288 CheckElementalConformance(messages, proc, actuals, foldingContext);2289 }2290 if (intrinsic) {2291 CheckSpecificIntrinsic(proc, actuals, context, scope, *intrinsic);2292 }2293 return buffer;2294}2295 2296bool CheckInterfaceForGeneric(const characteristics::Procedure &proc,2297 evaluate::ActualArguments &actuals, SemanticsContext &context,2298 bool allowActualArgumentConversions) {2299 return proc.HasExplicitInterface() &&2300 !CheckExplicitInterface(proc, actuals, context, nullptr, nullptr,2301 allowActualArgumentConversions, /*extentErrors=*/false,2302 /*ignoreImplicitVsExplicit=*/false)2303 .AnyFatalError();2304}2305 2306bool CheckArgumentIsConstantExprInRange(2307 const evaluate::ActualArguments &actuals, int index, int lowerBound,2308 int upperBound, parser::ContextualMessages &messages) {2309 CHECK(index >= 0 && static_cast<unsigned>(index) < actuals.size());2310 2311 const std::optional<evaluate::ActualArgument> &argOptional{actuals[index]};2312 if (!argOptional) {2313 DIE("Actual argument should have value");2314 return false;2315 }2316 2317 const evaluate::ActualArgument &arg{argOptional.value()};2318 const evaluate::Expr<evaluate::SomeType> *argExpr{arg.UnwrapExpr()};2319 CHECK(argExpr != nullptr);2320 2321 if (!IsConstantExpr(*argExpr)) {2322 messages.Say("Actual argument #%d must be a constant expression"_err_en_US,2323 index + 1);2324 return false;2325 }2326 2327 // This does not imply that the kind of the argument is 8. The kind2328 // for the intrinsic's argument should have been check prior. This is just2329 // a conversion so that we can read the constant value.2330 auto scalarValue{evaluate::ToInt64(argExpr)};2331 CHECK(scalarValue.has_value());2332 2333 if (*scalarValue < lowerBound || *scalarValue > upperBound) {2334 messages.Say(2335 "Argument #%d must be a constant expression in range %d to %d"_err_en_US,2336 index + 1, lowerBound, upperBound);2337 return false;2338 }2339 return true;2340}2341 2342bool CheckPPCIntrinsic(const Symbol &generic, const Symbol &specific,2343 const evaluate::ActualArguments &actuals,2344 evaluate::FoldingContext &context) {2345 parser::ContextualMessages &messages{context.messages()};2346 2347 if (specific.name() == "__ppc_mtfsf") {2348 return CheckArgumentIsConstantExprInRange(actuals, 0, 0, 7, messages);2349 }2350 if (specific.name() == "__ppc_mtfsfi") {2351 return CheckArgumentIsConstantExprInRange(actuals, 0, 0, 7, messages) &&2352 CheckArgumentIsConstantExprInRange(actuals, 1, 0, 15, messages);2353 }2354 if (specific.name().ToString().compare(0, 14, "__ppc_vec_sld_") == 0) {2355 return CheckArgumentIsConstantExprInRange(actuals, 2, 0, 15, messages);2356 }2357 if (specific.name().ToString().compare(0, 15, "__ppc_vec_sldw_") == 0) {2358 return CheckArgumentIsConstantExprInRange(actuals, 2, 0, 3, messages);2359 }2360 if (specific.name().ToString().compare(0, 14, "__ppc_vec_ctf_") == 0) {2361 return CheckArgumentIsConstantExprInRange(actuals, 1, 0, 31, messages);2362 }2363 if (specific.name().ToString().compare(0, 16, "__ppc_vec_permi_") == 0) {2364 return CheckArgumentIsConstantExprInRange(actuals, 2, 0, 3, messages);2365 }2366 if (specific.name().ToString().compare(0, 21, "__ppc_vec_splat_s32__") == 0) {2367 return CheckArgumentIsConstantExprInRange(actuals, 0, -16, 15, messages);2368 }2369 if (specific.name().ToString().compare(0, 16, "__ppc_vec_splat_") == 0) {2370 // The value of arg2 in vec_splat must be a constant expression that is2371 // greater than or equal to 0, and less than the number of elements in arg1.2372 auto *expr{actuals[0].value().UnwrapExpr()};2373 auto type{characteristics::TypeAndShape::Characterize(*expr, context)};2374 assert(type && "unknown type");2375 const auto *derived{evaluate::GetDerivedTypeSpec(type.value().type())};2376 if (derived && derived->IsVectorType()) {2377 for (const auto &pair : derived->parameters()) {2378 if (pair.first == "element_kind") {2379 auto vecElemKind{Fortran::evaluate::ToInt64(pair.second.GetExplicit())2380 .value_or(0)};2381 auto numElem{vecElemKind == 0 ? 0 : (16 / vecElemKind)};2382 return CheckArgumentIsConstantExprInRange(2383 actuals, 1, 0, numElem - 1, messages);2384 }2385 }2386 } else2387 assert(false && "vector type is expected");2388 }2389 return false;2390}2391 2392bool CheckWindowsIntrinsic(2393 const Symbol &intrinsic, evaluate::FoldingContext &foldingContext) {2394 parser::ContextualMessages &messages{foldingContext.messages()};2395 // TODO: there are other intrinsics that are unsupported on Windows that2396 // should be added here.2397 if (intrinsic.name() == "getuid") {2398 messages.Say(2399 "User IDs do not exist on Windows. This function will always return 1"_warn_en_US);2400 }2401 if (intrinsic.name() == "getgid") {2402 messages.Say(2403 "Group IDs do not exist on Windows. This function will always return 1"_warn_en_US);2404 }2405 return true;2406}2407 2408bool CheckArguments(const characteristics::Procedure &proc,2409 evaluate::ActualArguments &actuals, SemanticsContext &context,2410 const Scope &scope, bool treatingExternalAsImplicit,2411 bool ignoreImplicitVsExplicit,2412 const evaluate::SpecificIntrinsic *intrinsic) {2413 bool explicitInterface{proc.HasExplicitInterface()};2414 evaluate::FoldingContext foldingContext{context.foldingContext()};2415 parser::ContextualMessages &messages{foldingContext.messages()};2416 bool allowArgumentConversions{true};2417 parser::Messages implicitBuffer;2418 if (!explicitInterface || treatingExternalAsImplicit) {2419 {2420 auto restorer{messages.SetMessages(implicitBuffer)};2421 for (auto &actual : actuals) {2422 if (actual) {2423 CheckImplicitInterfaceArg(*actual, messages, context);2424 }2425 }2426 }2427 if (implicitBuffer.AnyFatalError()) {2428 if (auto *msgs{messages.messages()}) {2429 msgs->Annex(std::move(implicitBuffer));2430 }2431 return false; // don't pile on2432 }2433 allowArgumentConversions = false;2434 }2435 if (explicitInterface) {2436 auto explicitBuffer{CheckExplicitInterface(proc, actuals, context, &scope,2437 intrinsic, allowArgumentConversions,2438 /*extentErrors=*/true, ignoreImplicitVsExplicit)};2439 if (!explicitBuffer.empty()) {2440 if (treatingExternalAsImplicit) {2441 // Combine all messages into one warning2442 if (auto *warning{messages.Warn(/*inModuleFile=*/false,2443 context.languageFeatures(),2444 common::UsageWarning::KnownBadImplicitInterface,2445 "If the procedure's interface were explicit, this reference would be in error"_warn_en_US)}) {2446 explicitBuffer.AttachTo(*warning, parser::Severity::Because);2447 }2448 } else if (auto *msgs{messages.messages()}) {2449 msgs->Annex(std::move(explicitBuffer));2450 }2451 // These messages override any in implicitBuffer.2452 return false;2453 }2454 }2455 if (!implicitBuffer.empty()) {2456 if (auto *msgs{messages.messages()}) {2457 msgs->Annex(std::move(implicitBuffer));2458 }2459 return false;2460 } else {2461 return true; // no messages2462 }2463}2464} // namespace Fortran::semantics2465