| //===-- lib/Semantics/check-call.cpp --------------------------------------===// |
| // |
| // Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. |
| // See https://llvm.org/LICENSE.txt for license information. |
| // SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception |
| // |
| //===----------------------------------------------------------------------===// |
| |
| #include "check-call.h" |
| #include "definable.h" |
| #include "pointer-assignment.h" |
| #include "flang/Evaluate/characteristics.h" |
| #include "flang/Evaluate/check-expression.h" |
| #include "flang/Evaluate/fold-designator.h" |
| #include "flang/Evaluate/shape.h" |
| #include "flang/Evaluate/tools.h" |
| #include "flang/Parser/characters.h" |
| #include "flang/Parser/message.h" |
| #include "flang/Semantics/scope.h" |
| #include "flang/Semantics/tools.h" |
| #include <map> |
| #include <string> |
| |
| using namespace Fortran::parser::literals; |
| namespace characteristics = Fortran::evaluate::characteristics; |
| |
| namespace Fortran::semantics { |
| |
| static void CheckImplicitInterfaceArg(evaluate::ActualArgument &arg, |
| parser::ContextualMessages &messages, evaluate::FoldingContext &context) { |
| auto restorer{ |
| messages.SetLocation(arg.sourceLocation().value_or(messages.at()))}; |
| if (auto kw{arg.keyword()}) { |
| messages.Say(*kw, |
| "Keyword '%s=' may not appear in a reference to a procedure with an implicit interface"_err_en_US, |
| *kw); |
| } |
| if (auto type{arg.GetType()}) { |
| if (type->IsAssumedType()) { |
| messages.Say( |
| "Assumed type actual argument requires an explicit interface"_err_en_US); |
| } else if (type->IsUnlimitedPolymorphic()) { |
| messages.Say( |
| "Unlimited polymorphic actual argument requires an explicit interface"_err_en_US); |
| } else if (const DerivedTypeSpec * derived{GetDerivedTypeSpec(type)}) { |
| if (!derived->parameters().empty()) { |
| messages.Say( |
| "Parameterized derived type actual argument requires an explicit interface"_err_en_US); |
| } |
| } |
| } |
| if (const auto *expr{arg.UnwrapExpr()}) { |
| if (IsBOZLiteral(*expr)) { |
| messages.Say("BOZ argument requires an explicit interface"_err_en_US); |
| } else if (evaluate::IsNullPointer(*expr)) { |
| messages.Say( |
| "Null pointer argument requires an explicit interface"_err_en_US); |
| } else if (auto named{evaluate::ExtractNamedEntity(*expr)}) { |
| const Symbol &symbol{named->GetLastSymbol()}; |
| if (symbol.Corank() > 0) { |
| messages.Say( |
| "Coarray argument requires an explicit interface"_err_en_US); |
| } |
| if (const auto *details{symbol.detailsIf<ObjectEntityDetails>()}) { |
| if (details->IsAssumedRank()) { |
| messages.Say( |
| "Assumed rank argument requires an explicit interface"_err_en_US); |
| } |
| } |
| if (symbol.attrs().test(Attr::ASYNCHRONOUS)) { |
| messages.Say( |
| "ASYNCHRONOUS argument requires an explicit interface"_err_en_US); |
| } |
| if (symbol.attrs().test(Attr::VOLATILE)) { |
| messages.Say( |
| "VOLATILE argument requires an explicit interface"_err_en_US); |
| } |
| } else if (auto argChars{characteristics::DummyArgument::FromActual( |
| "actual argument", *expr, context, |
| /*forImplicitInterface=*/true)}) { |
| const auto *argProcDesignator{ |
| std::get_if<evaluate::ProcedureDesignator>(&expr->u)}; |
| if (const auto *argProcSymbol{ |
| argProcDesignator ? argProcDesignator->GetSymbol() : nullptr}) { |
| if (!argChars->IsTypelessIntrinsicDummy() && argProcDesignator && |
| argProcDesignator->IsElemental()) { // C1533 |
| evaluate::SayWithDeclaration(messages, *argProcSymbol, |
| "Non-intrinsic ELEMENTAL procedure '%s' may not be passed as an actual argument"_err_en_US, |
| argProcSymbol->name()); |
| } else if (const auto *subp{argProcSymbol->GetUltimate() |
| .detailsIf<SubprogramDetails>()}) { |
| if (subp->stmtFunction()) { |
| evaluate::SayWithDeclaration(messages, *argProcSymbol, |
| "Statement function '%s' may not be passed as an actual argument"_err_en_US, |
| argProcSymbol->name()); |
| } |
| } |
| } |
| } |
| } |
| } |
| |
| // F'2023 15.5.2.12p1: "Sequence association only applies when the dummy |
| // argument is an explicit-shape or assumed-size array." |
| static bool CanAssociateWithStorageSequence( |
| const characteristics::DummyDataObject &dummy) { |
| return !dummy.type.attrs().test( |
| characteristics::TypeAndShape::Attr::AssumedRank) && |
| !dummy.type.attrs().test( |
| characteristics::TypeAndShape::Attr::AssumedShape) && |
| !dummy.type.attrs().test(characteristics::TypeAndShape::Attr::Coarray) && |
| !dummy.attrs.test(characteristics::DummyDataObject::Attr::Allocatable) && |
| !dummy.attrs.test(characteristics::DummyDataObject::Attr::Pointer); |
| } |
| |
| // When a CHARACTER actual argument is known to be short, |
| // we extend it on the right with spaces and a warning if |
| // possible. When it is long, and not required to be equal, |
| // the usage conforms to the standard and no warning is needed. |
| static void CheckCharacterActual(evaluate::Expr<evaluate::SomeType> &actual, |
| const characteristics::DummyDataObject &dummy, |
| characteristics::TypeAndShape &actualType, SemanticsContext &context, |
| parser::ContextualMessages &messages, bool extentErrors, |
| const std::string &dummyName) { |
| if (dummy.type.type().category() == TypeCategory::Character && |
| actualType.type().category() == TypeCategory::Character && |
| dummy.type.type().kind() == actualType.type().kind() && |
| !dummy.attrs.test( |
| characteristics::DummyDataObject::Attr::DeducedFromActual)) { |
| if (dummy.type.LEN() && actualType.LEN()) { |
| evaluate::FoldingContext &foldingContext{context.foldingContext()}; |
| auto dummyLength{ |
| ToInt64(Fold(foldingContext, common::Clone(*dummy.type.LEN())))}; |
| auto actualLength{ |
| ToInt64(Fold(foldingContext, common::Clone(*actualType.LEN())))}; |
| if (dummyLength && actualLength) { |
| bool canAssociate{CanAssociateWithStorageSequence(dummy)}; |
| if (dummy.type.Rank() > 0 && canAssociate) { |
| // Character storage sequence association (F'2023 15.5.2.12p4) |
| if (auto dummySize{evaluate::ToInt64(evaluate::Fold(foldingContext, |
| evaluate::GetSize(evaluate::Shape{dummy.type.shape()})))}) { |
| auto dummyChars{*dummySize * *dummyLength}; |
| if (actualType.Rank() == 0) { |
| evaluate::DesignatorFolder folder{ |
| context.foldingContext(), /*getLastComponent=*/true}; |
| if (auto actualOffset{folder.FoldDesignator(actual)}) { |
| std::int64_t actualChars{*actualLength}; |
| if (static_cast<std::size_t>(actualOffset->offset()) >= |
| actualOffset->symbol().size() || |
| !evaluate::IsContiguous( |
| actualOffset->symbol(), foldingContext)) { |
| // If substring, take rest of substring |
| if (*actualLength > 0) { |
| actualChars -= |
| (actualOffset->offset() / actualType.type().kind()) % |
| *actualLength; |
| } |
| } else { |
| actualChars = (static_cast<std::int64_t>( |
| actualOffset->symbol().size()) - |
| actualOffset->offset()) / |
| actualType.type().kind(); |
| } |
| if (actualChars < dummyChars) { |
| auto msg{ |
| "Actual argument has fewer characters remaining in storage sequence (%jd) than %s (%jd)"_warn_en_US}; |
| if (extentErrors) { |
| msg.set_severity(parser::Severity::Error); |
| } |
| messages.Say(std::move(msg), |
| static_cast<std::intmax_t>(actualChars), dummyName, |
| static_cast<std::intmax_t>(dummyChars)); |
| } |
| } |
| } else { // actual.type.Rank() > 0 |
| if (auto actualSize{evaluate::ToInt64(evaluate::Fold( |
| foldingContext, |
| evaluate::GetSize(evaluate::Shape(actualType.shape()))))}; |
| actualSize && |
| *actualSize * *actualLength < *dummySize * *dummyLength) { |
| auto msg{ |
| "Actual argument array has fewer characters (%jd) than %s array (%jd)"_warn_en_US}; |
| if (extentErrors) { |
| msg.set_severity(parser::Severity::Error); |
| } |
| messages.Say(std::move(msg), |
| static_cast<std::intmax_t>(*actualSize * *actualLength), |
| dummyName, |
| static_cast<std::intmax_t>(*dummySize * *dummyLength)); |
| } |
| } |
| } |
| } else if (*actualLength != *dummyLength) { |
| // Not using storage sequence association, and the lengths don't |
| // match. |
| if (!canAssociate) { |
| // F'2023 15.5.2.5 paragraph 4 |
| messages.Say( |
| "Actual argument variable length '%jd' does not match the expected length '%jd'"_err_en_US, |
| *actualLength, *dummyLength); |
| } else if (*actualLength < *dummyLength) { |
| CHECK(dummy.type.Rank() == 0); |
| bool isVariable{evaluate::IsVariable(actual)}; |
| if (context.ShouldWarn( |
| common::UsageWarning::ShortCharacterActual)) { |
| if (isVariable) { |
| messages.Say( |
| "Actual argument variable length '%jd' is less than expected length '%jd'"_warn_en_US, |
| *actualLength, *dummyLength); |
| } else { |
| messages.Say( |
| "Actual argument expression length '%jd' is less than expected length '%jd'"_warn_en_US, |
| *actualLength, *dummyLength); |
| } |
| } |
| if (!isVariable) { |
| auto converted{ |
| ConvertToType(dummy.type.type(), std::move(actual))}; |
| CHECK(converted); |
| actual = std::move(*converted); |
| actualType.set_LEN(SubscriptIntExpr{*dummyLength}); |
| } |
| } |
| } |
| } |
| } |
| } |
| } |
| |
| // Automatic conversion of different-kind INTEGER scalar actual |
| // argument expressions (not variables) to INTEGER scalar dummies. |
| // We return nonstandard INTEGER(8) results from intrinsic functions |
| // like SIZE() by default in order to facilitate the use of large |
| // arrays. Emit a warning when downconverting. |
| static void ConvertIntegerActual(evaluate::Expr<evaluate::SomeType> &actual, |
| const characteristics::TypeAndShape &dummyType, |
| characteristics::TypeAndShape &actualType, |
| parser::ContextualMessages &messages, SemanticsContext &semanticsContext) { |
| if (dummyType.type().category() == TypeCategory::Integer && |
| actualType.type().category() == TypeCategory::Integer && |
| dummyType.type().kind() != actualType.type().kind() && |
| GetRank(dummyType.shape()) == 0 && GetRank(actualType.shape()) == 0 && |
| !evaluate::IsVariable(actual)) { |
| auto converted{ |
| evaluate::ConvertToType(dummyType.type(), std::move(actual))}; |
| CHECK(converted); |
| actual = std::move(*converted); |
| if (dummyType.type().kind() < actualType.type().kind()) { |
| if (!semanticsContext.IsEnabled( |
| common::LanguageFeature::ActualIntegerConvertedToSmallerKind) || |
| semanticsContext.ShouldWarn( |
| common::LanguageFeature::ActualIntegerConvertedToSmallerKind)) { |
| std::optional<parser::MessageFixedText> msg; |
| if (!semanticsContext.IsEnabled( |
| common::LanguageFeature::ActualIntegerConvertedToSmallerKind)) { |
| msg = |
| "Actual argument scalar expression of type INTEGER(%d) cannot beimplicitly converted to smaller dummy argument type INTEGER(%d)"_err_en_US; |
| } else { |
| msg = |
| "Actual argument scalar expression of type INTEGER(%d) was converted to smaller dummy argument type INTEGER(%d)"_port_en_US; |
| } |
| messages.Say(std::move(msg.value()), actualType.type().kind(), |
| dummyType.type().kind()); |
| } |
| } |
| actualType = dummyType; |
| } |
| } |
| |
| // Automatic conversion of different-kind LOGICAL scalar actual argument |
| // expressions (not variables) to LOGICAL scalar dummies when the dummy is of |
| // default logical kind. This allows expressions in dummy arguments to work when |
| // the default logical kind is not the one used in LogicalResult. This will |
| // always be safe even when downconverting so no warning is needed. |
| static void ConvertLogicalActual(evaluate::Expr<evaluate::SomeType> &actual, |
| const characteristics::TypeAndShape &dummyType, |
| characteristics::TypeAndShape &actualType) { |
| if (dummyType.type().category() == TypeCategory::Logical && |
| actualType.type().category() == TypeCategory::Logical && |
| dummyType.type().kind() != actualType.type().kind() && |
| !evaluate::IsVariable(actual)) { |
| auto converted{ |
| evaluate::ConvertToType(dummyType.type(), std::move(actual))}; |
| CHECK(converted); |
| actual = std::move(*converted); |
| actualType = dummyType; |
| } |
| } |
| |
| static bool DefersSameTypeParameters( |
| const DerivedTypeSpec &actual, const DerivedTypeSpec &dummy) { |
| for (const auto &pair : actual.parameters()) { |
| const ParamValue &actualValue{pair.second}; |
| const ParamValue *dummyValue{dummy.FindParameter(pair.first)}; |
| if (!dummyValue || (actualValue.isDeferred() != dummyValue->isDeferred())) { |
| return false; |
| } |
| } |
| return true; |
| } |
| |
| static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy, |
| const std::string &dummyName, evaluate::Expr<evaluate::SomeType> &actual, |
| characteristics::TypeAndShape &actualType, bool isElemental, |
| SemanticsContext &context, evaluate::FoldingContext &foldingContext, |
| const Scope *scope, const evaluate::SpecificIntrinsic *intrinsic, |
| bool allowActualArgumentConversions, bool extentErrors, |
| const characteristics::Procedure &procedure) { |
| |
| // Basic type & rank checking |
| parser::ContextualMessages &messages{foldingContext.messages()}; |
| CheckCharacterActual( |
| actual, dummy, actualType, context, messages, extentErrors, dummyName); |
| bool dummyIsAllocatable{ |
| dummy.attrs.test(characteristics::DummyDataObject::Attr::Allocatable)}; |
| bool dummyIsPointer{ |
| dummy.attrs.test(characteristics::DummyDataObject::Attr::Pointer)}; |
| bool dummyIsAllocatableOrPointer{dummyIsAllocatable || dummyIsPointer}; |
| allowActualArgumentConversions &= !dummyIsAllocatableOrPointer; |
| bool typesCompatibleWithIgnoreTKR{ |
| (dummy.ignoreTKR.test(common::IgnoreTKR::Type) && |
| (dummy.type.type().category() == TypeCategory::Derived || |
| actualType.type().category() == TypeCategory::Derived || |
| dummy.type.type().category() != actualType.type().category())) || |
| (dummy.ignoreTKR.test(common::IgnoreTKR::Kind) && |
| dummy.type.type().category() == actualType.type().category())}; |
| allowActualArgumentConversions &= !typesCompatibleWithIgnoreTKR; |
| if (allowActualArgumentConversions) { |
| ConvertIntegerActual(actual, dummy.type, actualType, messages, context); |
| ConvertLogicalActual(actual, dummy.type, actualType); |
| } |
| bool typesCompatible{typesCompatibleWithIgnoreTKR || |
| dummy.type.type().IsTkCompatibleWith(actualType.type())}; |
| int dummyRank{dummy.type.Rank()}; |
| if (typesCompatible) { |
| if (const auto *constantChar{ |
| evaluate::UnwrapConstantValue<evaluate::Ascii>(actual)}; |
| constantChar && constantChar->wasHollerith() && |
| dummy.type.type().IsUnlimitedPolymorphic()) { |
| messages.Say( |
| "passing Hollerith to unlimited polymorphic as if it were CHARACTER"_port_en_US); |
| } |
| } else if (dummyRank == 0 && allowActualArgumentConversions) { |
| // Extension: pass Hollerith literal to scalar as if it had been BOZ |
| if (auto converted{evaluate::HollerithToBOZ( |
| foldingContext, actual, dummy.type.type())}) { |
| if (context.ShouldWarn( |
| common::LanguageFeature::HollerithOrCharacterAsBOZ)) { |
| messages.Say( |
| "passing Hollerith or character literal as if it were BOZ"_port_en_US); |
| } |
| actual = *converted; |
| actualType.type() = dummy.type.type(); |
| typesCompatible = true; |
| } |
| } |
| bool dummyIsAssumedRank{dummy.type.attrs().test( |
| characteristics::TypeAndShape::Attr::AssumedRank)}; |
| if (typesCompatible) { |
| if (isElemental) { |
| } else if (dummyIsAssumedRank) { |
| } else if (dummy.ignoreTKR.test(common::IgnoreTKR::Rank)) { |
| } else if (dummyRank > 0 && !dummyIsAllocatableOrPointer && |
| !dummy.type.attrs().test( |
| characteristics::TypeAndShape::Attr::AssumedShape) && |
| !dummy.type.attrs().test( |
| characteristics::TypeAndShape::Attr::DeferredShape) && |
| (actualType.Rank() > 0 || IsArrayElement(actual))) { |
| // Sequence association (15.5.2.11) applies -- rank need not match |
| // if the actual argument is an array or array element designator, |
| // and the dummy is an array, but not assumed-shape or an INTENT(IN) |
| // pointer that's standing in for an assumed-shape dummy. |
| } else { |
| // Let CheckConformance accept actual scalars; storage association |
| // cases are checked here below. |
| CheckConformance(messages, dummy.type.shape(), actualType.shape(), |
| dummyIsAllocatableOrPointer |
| ? evaluate::CheckConformanceFlags::None |
| : evaluate::CheckConformanceFlags::RightScalarExpandable, |
| "dummy argument", "actual argument"); |
| } |
| } else { |
| const auto &len{actualType.LEN()}; |
| messages.Say( |
| "Actual argument type '%s' is not compatible with dummy argument type '%s'"_err_en_US, |
| actualType.type().AsFortran(len ? len->AsFortran() : ""), |
| dummy.type.type().AsFortran()); |
| } |
| |
| bool actualIsPolymorphic{actualType.type().IsPolymorphic()}; |
| bool dummyIsPolymorphic{dummy.type.type().IsPolymorphic()}; |
| bool actualIsCoindexed{ExtractCoarrayRef(actual).has_value()}; |
| bool actualIsAssumedSize{actualType.attrs().test( |
| characteristics::TypeAndShape::Attr::AssumedSize)}; |
| bool dummyIsAssumedSize{dummy.type.attrs().test( |
| characteristics::TypeAndShape::Attr::AssumedSize)}; |
| bool dummyIsAsynchronous{ |
| dummy.attrs.test(characteristics::DummyDataObject::Attr::Asynchronous)}; |
| bool dummyIsVolatile{ |
| dummy.attrs.test(characteristics::DummyDataObject::Attr::Volatile)}; |
| bool dummyIsValue{ |
| dummy.attrs.test(characteristics::DummyDataObject::Attr::Value)}; |
| |
| if (actualIsPolymorphic && dummyIsPolymorphic && |
| actualIsCoindexed) { // 15.5.2.4(2) |
| messages.Say( |
| "Coindexed polymorphic object may not be associated with a polymorphic %s"_err_en_US, |
| dummyName); |
| } |
| if (actualIsPolymorphic && !dummyIsPolymorphic && |
| actualIsAssumedSize) { // 15.5.2.4(2) |
| messages.Say( |
| "Assumed-size polymorphic array may not be associated with a monomorphic %s"_err_en_US, |
| dummyName); |
| } |
| |
| // Derived type actual argument checks |
| const Symbol *actualFirstSymbol{evaluate::GetFirstSymbol(actual)}; |
| bool actualIsAsynchronous{ |
| actualFirstSymbol && actualFirstSymbol->attrs().test(Attr::ASYNCHRONOUS)}; |
| bool actualIsVolatile{ |
| actualFirstSymbol && actualFirstSymbol->attrs().test(Attr::VOLATILE)}; |
| const auto *derived{evaluate::GetDerivedTypeSpec(actualType.type())}; |
| if (derived && !derived->IsVectorType()) { |
| if (dummy.type.type().IsAssumedType()) { |
| if (!derived->parameters().empty()) { // 15.5.2.4(2) |
| messages.Say( |
| "Actual argument associated with TYPE(*) %s may not have a parameterized derived type"_err_en_US, |
| dummyName); |
| } |
| if (const Symbol * |
| tbp{FindImmediateComponent(*derived, [](const Symbol &symbol) { |
| return symbol.has<ProcBindingDetails>(); |
| })}) { // 15.5.2.4(2) |
| evaluate::SayWithDeclaration(messages, *tbp, |
| "Actual argument associated with TYPE(*) %s may not have type-bound procedure '%s'"_err_en_US, |
| dummyName, tbp->name()); |
| } |
| auto finals{FinalsForDerivedTypeInstantiation(*derived)}; |
| if (!finals.empty()) { // 15.5.2.4(2) |
| SourceName name{finals.front()->name()}; |
| if (auto *msg{messages.Say( |
| "Actual argument associated with TYPE(*) %s may not have derived type '%s' with FINAL subroutine '%s'"_err_en_US, |
| dummyName, derived->typeSymbol().name(), name)}) { |
| msg->Attach(name, "FINAL subroutine '%s' in derived type '%s'"_en_US, |
| name, derived->typeSymbol().name()); |
| } |
| } |
| } |
| if (actualIsCoindexed) { |
| if (dummy.intent != common::Intent::In && !dummyIsValue) { |
| if (auto bad{ |
| FindAllocatableUltimateComponent(*derived)}) { // 15.5.2.4(6) |
| evaluate::SayWithDeclaration(messages, *bad, |
| "Coindexed actual argument with ALLOCATABLE ultimate component '%s' must be associated with a %s with VALUE or INTENT(IN) attributes"_err_en_US, |
| bad.BuildResultDesignatorName(), dummyName); |
| } |
| } |
| if (auto coarrayRef{evaluate::ExtractCoarrayRef(actual)}) { // C1537 |
| const Symbol &coarray{coarrayRef->GetLastSymbol()}; |
| if (const DeclTypeSpec * type{coarray.GetType()}) { |
| if (const DerivedTypeSpec * derived{type->AsDerived()}) { |
| if (auto bad{semantics::FindPointerUltimateComponent(*derived)}) { |
| evaluate::SayWithDeclaration(messages, coarray, |
| "Coindexed object '%s' with POINTER ultimate component '%s' cannot be associated with %s"_err_en_US, |
| coarray.name(), bad.BuildResultDesignatorName(), dummyName); |
| } |
| } |
| } |
| } |
| } |
| if (actualIsVolatile != dummyIsVolatile) { // 15.5.2.4(22) |
| if (auto bad{semantics::FindCoarrayUltimateComponent(*derived)}) { |
| evaluate::SayWithDeclaration(messages, *bad, |
| "VOLATILE attribute must match for %s when actual argument has a coarray ultimate component '%s'"_err_en_US, |
| dummyName, bad.BuildResultDesignatorName()); |
| } |
| } |
| } |
| |
| // Rank and shape checks |
| const auto *actualLastSymbol{evaluate::GetLastSymbol(actual)}; |
| if (actualLastSymbol) { |
| actualLastSymbol = &ResolveAssociations(*actualLastSymbol); |
| } |
| const ObjectEntityDetails *actualLastObject{actualLastSymbol |
| ? actualLastSymbol->detailsIf<ObjectEntityDetails>() |
| : nullptr}; |
| int actualRank{actualType.Rank()}; |
| bool actualIsPointer{evaluate::IsObjectPointer(actual)}; |
| bool actualIsAssumedRank{evaluate::IsAssumedRank(actual)}; |
| if (dummy.type.attrs().test( |
| characteristics::TypeAndShape::Attr::AssumedShape)) { |
| // 15.5.2.4(16) |
| if (actualIsAssumedRank) { |
| messages.Say( |
| "Assumed-rank actual argument may not be associated with assumed-shape %s"_err_en_US, |
| dummyName); |
| } else if (actualRank == 0) { |
| messages.Say( |
| "Scalar actual argument may not be associated with assumed-shape %s"_err_en_US, |
| dummyName); |
| } else if (actualIsAssumedSize && actualLastSymbol) { |
| evaluate::SayWithDeclaration(messages, *actualLastSymbol, |
| "Assumed-size array may not be associated with assumed-shape %s"_err_en_US, |
| dummyName); |
| } |
| } else if (dummyRank > 0) { |
| bool basicError{false}; |
| if (actualRank == 0 && !actualIsAssumedRank && |
| !dummyIsAllocatableOrPointer) { |
| // Actual is scalar, dummy is an array. F'2023 15.5.2.5p14 |
| if (actualIsCoindexed) { |
| basicError = true; |
| messages.Say( |
| "Coindexed scalar actual argument must be associated with a scalar %s"_err_en_US, |
| dummyName); |
| } |
| bool actualIsArrayElement{IsArrayElement(actual)}; |
| bool actualIsCKindCharacter{ |
| actualType.type().category() == TypeCategory::Character && |
| actualType.type().kind() == 1}; |
| if (!actualIsCKindCharacter) { |
| if (!actualIsArrayElement && |
| !(dummy.type.type().IsAssumedType() && dummyIsAssumedSize) && |
| !dummyIsAssumedRank && |
| !dummy.ignoreTKR.test(common::IgnoreTKR::Rank)) { |
| basicError = true; |
| messages.Say( |
| "Whole scalar actual argument may not be associated with a %s array"_err_en_US, |
| dummyName); |
| } |
| if (actualIsPolymorphic) { |
| basicError = true; |
| messages.Say( |
| "Polymorphic scalar may not be associated with a %s array"_err_en_US, |
| dummyName); |
| } |
| if (actualIsArrayElement && actualLastSymbol && |
| !evaluate::IsContiguous(*actualLastSymbol, foldingContext) && |
| !dummy.ignoreTKR.test(common::IgnoreTKR::Contiguous)) { |
| if (IsPointer(*actualLastSymbol)) { |
| basicError = true; |
| messages.Say( |
| "Element of pointer array may not be associated with a %s array"_err_en_US, |
| dummyName); |
| } else if (IsAssumedShape(*actualLastSymbol) && |
| !dummy.ignoreTKR.test(common::IgnoreTKR::Contiguous)) { |
| basicError = true; |
| messages.Say( |
| "Element of assumed-shape array may not be associated with a %s array"_err_en_US, |
| dummyName); |
| } |
| } |
| } |
| } |
| // Storage sequence association (F'2023 15.5.2.12p3) checks. |
| // Character storage sequence association is checked in |
| // CheckCharacterActual(). |
| if (!basicError && |
| actualType.type().category() != TypeCategory::Character && |
| CanAssociateWithStorageSequence(dummy) && |
| !dummy.attrs.test( |
| characteristics::DummyDataObject::Attr::DeducedFromActual)) { |
| if (auto dummySize{evaluate::ToInt64(evaluate::Fold(foldingContext, |
| evaluate::GetSize(evaluate::Shape{dummy.type.shape()})))}) { |
| if (actualRank == 0 && !actualIsAssumedRank) { |
| if (evaluate::IsArrayElement(actual)) { |
| // Actual argument is a scalar array element |
| evaluate::DesignatorFolder folder{ |
| context.foldingContext(), /*getLastComponent=*/true}; |
| if (auto actualOffset{folder.FoldDesignator(actual)}) { |
| std::optional<std::int64_t> actualElements; |
| if (static_cast<std::size_t>(actualOffset->offset()) >= |
| actualOffset->symbol().size() || |
| !evaluate::IsContiguous( |
| actualOffset->symbol(), foldingContext)) { |
| actualElements = 1; |
| } else if (auto actualSymType{evaluate::DynamicType::From( |
| actualOffset->symbol())}) { |
| if (auto actualSymTypeBytes{ |
| evaluate::ToInt64(evaluate::Fold(foldingContext, |
| actualSymType->MeasureSizeInBytes( |
| foldingContext, false)))}; |
| actualSymTypeBytes && *actualSymTypeBytes > 0) { |
| actualElements = (static_cast<std::int64_t>( |
| actualOffset->symbol().size()) - |
| actualOffset->offset()) / |
| *actualSymTypeBytes; |
| } |
| } |
| if (actualElements && *actualElements < *dummySize) { |
| auto msg{ |
| "Actual argument has fewer elements remaining in storage sequence (%jd) than %s array (%jd)"_warn_en_US}; |
| if (extentErrors) { |
| msg.set_severity(parser::Severity::Error); |
| } |
| messages.Say(std::move(msg), |
| static_cast<std::intmax_t>(*actualElements), dummyName, |
| static_cast<std::intmax_t>(*dummySize)); |
| } |
| } |
| } |
| } else { // actualRank > 0 || actualIsAssumedRank |
| if (auto actualSize{evaluate::ToInt64(evaluate::Fold(foldingContext, |
| evaluate::GetSize(evaluate::Shape(actualType.shape()))))}; |
| actualSize && *actualSize < *dummySize) { |
| auto msg{ |
| "Actual argument array has fewer elements (%jd) than %s array (%jd)"_warn_en_US}; |
| if (extentErrors) { |
| msg.set_severity(parser::Severity::Error); |
| } |
| messages.Say(std::move(msg), |
| static_cast<std::intmax_t>(*actualSize), dummyName, |
| static_cast<std::intmax_t>(*dummySize)); |
| } |
| } |
| } |
| } |
| } |
| if (actualLastObject && actualLastObject->IsCoarray() && |
| IsAllocatable(*actualLastSymbol) && dummy.intent == common::Intent::Out && |
| !(intrinsic && |
| evaluate::AcceptsIntentOutAllocatableCoarray( |
| intrinsic->name))) { // C846 |
| messages.Say( |
| "ALLOCATABLE coarray '%s' may not be associated with INTENT(OUT) %s"_err_en_US, |
| actualLastSymbol->name(), dummyName); |
| } |
| |
| // Definability |
| bool actualIsVariable{evaluate::IsVariable(actual)}; |
| const char *reason{nullptr}; |
| if (dummy.intent == common::Intent::Out) { |
| reason = "INTENT(OUT)"; |
| } else if (dummy.intent == common::Intent::InOut) { |
| reason = "INTENT(IN OUT)"; |
| } |
| if (reason && scope) { |
| // Problems with polymorphism are caught in the callee's definition. |
| DefinabilityFlags flags{DefinabilityFlag::PolymorphicOkInPure}; |
| if (isElemental) { // 15.5.2.4(21) |
| flags.set(DefinabilityFlag::VectorSubscriptIsOk); |
| } |
| if (actualIsPointer && dummyIsPointer) { // 19.6.8 |
| flags.set(DefinabilityFlag::PointerDefinition); |
| } |
| if (auto whyNot{WhyNotDefinable(messages.at(), *scope, flags, actual)}) { |
| if (auto *msg{messages.Say( |
| "Actual argument associated with %s %s is not definable"_err_en_US, |
| reason, dummyName)}) { |
| msg->Attach(std::move(*whyNot)); |
| } |
| } |
| } |
| |
| // technically legal but worth emitting a warning |
| // llvm-project issue #58973: constant actual argument passed in where dummy |
| // argument is marked volatile |
| if (dummyIsVolatile && !actualIsVariable && |
| context.ShouldWarn(common::UsageWarning::ExprPassedToVolatile)) { |
| messages.Say( |
| "actual argument associated with VOLATILE %s is not a variable"_warn_en_US, |
| dummyName); |
| } |
| |
| // Cases when temporaries might be needed but must not be permitted. |
| bool actualIsContiguous{IsSimplyContiguous(actual, foldingContext)}; |
| bool dummyIsAssumedShape{dummy.type.attrs().test( |
| characteristics::TypeAndShape::Attr::AssumedShape)}; |
| bool dummyIsContiguous{ |
| dummy.attrs.test(characteristics::DummyDataObject::Attr::Contiguous)}; |
| if ((actualIsAsynchronous || actualIsVolatile) && |
| (dummyIsAsynchronous || dummyIsVolatile) && !dummyIsValue) { |
| if (actualIsCoindexed) { // C1538 |
| messages.Say( |
| "Coindexed ASYNCHRONOUS or VOLATILE actual argument may not be associated with %s with ASYNCHRONOUS or VOLATILE attributes unless VALUE"_err_en_US, |
| dummyName); |
| } |
| if ((actualRank > 0 || actualIsAssumedRank) && !actualIsContiguous) { |
| if (dummyIsContiguous || |
| !(dummyIsAssumedShape || dummyIsAssumedRank || |
| (actualIsPointer && dummyIsPointer))) { // C1539 & C1540 |
| messages.Say( |
| "ASYNCHRONOUS or VOLATILE actual argument that is not simply contiguous may not be associated with a contiguous ASYNCHRONOUS or VOLATILE %s"_err_en_US, |
| dummyName); |
| } |
| } |
| } |
| |
| // 15.5.2.6 -- dummy is ALLOCATABLE |
| bool actualIsAllocatable{evaluate::IsAllocatableDesignator(actual)}; |
| bool dummyIsOptional{ |
| dummy.attrs.test(characteristics::DummyDataObject::Attr::Optional)}; |
| bool actualIsNull{evaluate::IsNullPointer(actual)}; |
| if (dummyIsAllocatable) { |
| if (actualIsAllocatable) { |
| if (actualIsCoindexed && dummy.intent != common::Intent::In) { |
| messages.Say( |
| "ALLOCATABLE %s must have INTENT(IN) to be associated with a coindexed actual argument"_err_en_US, |
| dummyName); |
| } |
| } else if (actualIsNull) { |
| if (dummyIsOptional) { |
| } else if (dummy.intent == common::Intent::In) { |
| // Extension (Intel, NAG, XLF): a NULL() pointer is an acceptable |
| // actual argument for an INTENT(IN) allocatable dummy, and it |
| // is treated as an unassociated allocatable. |
| if (context.languageFeatures().ShouldWarn( |
| common::LanguageFeature::NullActualForAllocatable)) { |
| messages.Say( |
| "Allocatable %s is associated with a null pointer"_port_en_US, |
| dummyName); |
| } |
| } else { |
| messages.Say( |
| "A null pointer may not be associated with allocatable %s without INTENT(IN)"_err_en_US, |
| dummyName); |
| } |
| } else { |
| messages.Say( |
| "ALLOCATABLE %s must be associated with an ALLOCATABLE actual argument"_err_en_US, |
| dummyName); |
| } |
| if (!actualIsCoindexed && actualLastSymbol && |
| actualLastSymbol->Corank() != dummy.type.corank()) { |
| messages.Say( |
| "ALLOCATABLE %s has corank %d but actual argument has corank %d"_err_en_US, |
| dummyName, dummy.type.corank(), actualLastSymbol->Corank()); |
| } |
| } |
| |
| // 15.5.2.7 -- dummy is POINTER |
| if (dummyIsPointer) { |
| if (actualIsPointer || dummy.intent == common::Intent::In) { |
| if (scope) { |
| semantics::CheckPointerAssignment(context, messages.at(), dummyName, |
| dummy, actual, *scope, |
| /*isAssumedRank=*/dummyIsAssumedRank); |
| } |
| } else if (!actualIsPointer) { |
| messages.Say( |
| "Actual argument associated with POINTER %s must also be POINTER unless INTENT(IN)"_err_en_US, |
| dummyName); |
| } |
| } |
| |
| // 15.5.2.5 -- actual & dummy are both POINTER or both ALLOCATABLE |
| // For INTENT(IN) we relax two checks that are in Fortran to |
| // prevent the callee from changing the type or to avoid having |
| // to use a descriptor. |
| if (!typesCompatible) { |
| // Don't pile on the errors emitted above |
| } else if ((actualIsPointer && dummyIsPointer) || |
| (actualIsAllocatable && dummyIsAllocatable)) { |
| bool actualIsUnlimited{actualType.type().IsUnlimitedPolymorphic()}; |
| bool dummyIsUnlimited{dummy.type.type().IsUnlimitedPolymorphic()}; |
| if (actualIsUnlimited != dummyIsUnlimited) { |
| if (dummyIsUnlimited && dummy.intent == common::Intent::In && |
| context.IsEnabled(common::LanguageFeature::RelaxedIntentInChecking)) { |
| if (context.ShouldWarn( |
| common::LanguageFeature::RelaxedIntentInChecking)) { |
| messages.Say( |
| "If a POINTER or ALLOCATABLE dummy or actual argument is unlimited polymorphic, both should be so"_port_en_US); |
| } |
| } else { |
| messages.Say( |
| "If a POINTER or ALLOCATABLE dummy or actual argument is unlimited polymorphic, both must be so"_err_en_US); |
| } |
| } else if (dummyIsPolymorphic != actualIsPolymorphic) { |
| if (dummyIsPolymorphic && dummy.intent == common::Intent::In && |
| context.IsEnabled(common::LanguageFeature::RelaxedIntentInChecking)) { |
| if (context.ShouldWarn( |
| common::LanguageFeature::RelaxedIntentInChecking)) { |
| messages.Say( |
| "If a POINTER or ALLOCATABLE dummy or actual argument is polymorphic, both should be so"_port_en_US); |
| } |
| } else { |
| messages.Say( |
| "If a POINTER or ALLOCATABLE dummy or actual argument is polymorphic, both must be so"_err_en_US); |
| } |
| } else if (!actualIsUnlimited) { |
| if (!actualType.type().IsTkCompatibleWith(dummy.type.type())) { |
| if (dummy.intent == common::Intent::In && |
| context.IsEnabled( |
| common::LanguageFeature::RelaxedIntentInChecking)) { |
| if (context.ShouldWarn( |
| common::LanguageFeature::RelaxedIntentInChecking)) { |
| messages.Say( |
| "POINTER or ALLOCATABLE dummy and actual arguments should have the same declared type and kind"_port_en_US); |
| } |
| } else { |
| messages.Say( |
| "POINTER or ALLOCATABLE dummy and actual arguments must have the same declared type and kind"_err_en_US); |
| } |
| } |
| // 15.5.2.5(4) |
| const auto *derived{evaluate::GetDerivedTypeSpec(actualType.type())}; |
| if ((derived && |
| !DefersSameTypeParameters(*derived, |
| *evaluate::GetDerivedTypeSpec(dummy.type.type()))) || |
| dummy.type.type().HasDeferredTypeParameter() != |
| actualType.type().HasDeferredTypeParameter()) { |
| messages.Say( |
| "Dummy and actual arguments must defer the same type parameters when POINTER or ALLOCATABLE"_err_en_US); |
| } |
| } |
| } |
| |
| // 15.5.2.8 -- coarray dummy arguments |
| if (dummy.type.corank() > 0) { |
| if (actualType.corank() == 0) { |
| messages.Say( |
| "Actual argument associated with coarray %s must be a coarray"_err_en_US, |
| dummyName); |
| } |
| if (dummyIsVolatile) { |
| if (!actualIsVolatile) { |
| messages.Say( |
| "non-VOLATILE coarray may not be associated with VOLATILE coarray %s"_err_en_US, |
| dummyName); |
| } |
| } else { |
| if (actualIsVolatile) { |
| messages.Say( |
| "VOLATILE coarray may not be associated with non-VOLATILE coarray %s"_err_en_US, |
| dummyName); |
| } |
| } |
| if (actualRank == dummyRank && !actualIsContiguous) { |
| if (dummyIsContiguous) { |
| messages.Say( |
| "Actual argument associated with a CONTIGUOUS coarray %s must be simply contiguous"_err_en_US, |
| dummyName); |
| } else if (!dummyIsAssumedShape && !dummyIsAssumedRank) { |
| messages.Say( |
| "Actual argument associated with coarray %s (not assumed shape or rank) must be simply contiguous"_err_en_US, |
| dummyName); |
| } |
| } |
| } |
| |
| // NULL(MOLD=) checking for non-intrinsic procedures |
| if (!intrinsic && !dummyIsAllocatableOrPointer && !dummyIsOptional && |
| actualIsNull) { |
| messages.Say( |
| "Actual argument associated with %s may not be null pointer %s"_err_en_US, |
| dummyName, actual.AsFortran()); |
| } |
| |
| // Warn about dubious actual argument association with a TARGET dummy argument |
| if (dummy.attrs.test(characteristics::DummyDataObject::Attr::Target) && |
| context.ShouldWarn(common::UsageWarning::NonTargetPassedToTarget)) { |
| bool actualIsTemp{!actualIsVariable || HasVectorSubscript(actual) || |
| evaluate::ExtractCoarrayRef(actual)}; |
| if (actualIsTemp) { |
| messages.Say( |
| "Any pointer associated with TARGET %s during this call will not be associated with the value of '%s' afterwards"_warn_en_US, |
| dummyName, actual.AsFortran()); |
| } else { |
| auto actualSymbolVector{GetSymbolVector(actual)}; |
| if (!evaluate::GetLastTarget(actualSymbolVector)) { |
| messages.Say( |
| "Any pointer associated with TARGET %s during this call must not be used afterwards, as '%s' is not a target"_warn_en_US, |
| dummyName, actual.AsFortran()); |
| } |
| } |
| } |
| |
| // CUDA specific checks |
| // TODO: These are disabled in OpenACC constructs, which may not be |
| // correct when the target is not a GPU. |
| if (!intrinsic && |
| !dummy.attrs.test(characteristics::DummyDataObject::Attr::Value) && |
| !FindOpenACCConstructContaining(scope)) { |
| std::optional<common::CUDADataAttr> actualDataAttr, dummyDataAttr; |
| if (const auto *actualObject{actualLastSymbol |
| ? actualLastSymbol->detailsIf<ObjectEntityDetails>() |
| : nullptr}) { |
| actualDataAttr = actualObject->cudaDataAttr(); |
| } |
| dummyDataAttr = dummy.cudaDataAttr; |
| // Treat MANAGED like DEVICE for nonallocatable nonpointer arguments to |
| // device subprograms |
| if (procedure.cudaSubprogramAttrs.value_or( |
| common::CUDASubprogramAttrs::Host) != |
| common::CUDASubprogramAttrs::Host && |
| !dummy.attrs.test( |
| characteristics::DummyDataObject::Attr::Allocatable) && |
| !dummy.attrs.test(characteristics::DummyDataObject::Attr::Pointer)) { |
| if (!dummyDataAttr || *dummyDataAttr == common::CUDADataAttr::Managed) { |
| dummyDataAttr = common::CUDADataAttr::Device; |
| } |
| if ((!actualDataAttr && FindCUDADeviceContext(scope)) || |
| (actualDataAttr && |
| *actualDataAttr == common::CUDADataAttr::Managed)) { |
| actualDataAttr = common::CUDADataAttr::Device; |
| } |
| } |
| if (!common::AreCompatibleCUDADataAttrs( |
| dummyDataAttr, actualDataAttr, dummy.ignoreTKR)) { |
| auto toStr{[](std::optional<common::CUDADataAttr> x) { |
| return x ? "ATTRIBUTES("s + |
| parser::ToUpperCaseLetters(common::EnumToString(*x)) + ")"s |
| : "no CUDA data attribute"s; |
| }}; |
| messages.Say( |
| "%s has %s but its associated actual argument has %s"_err_en_US, |
| dummyName, toStr(dummyDataAttr), toStr(actualDataAttr)); |
| } |
| } |
| |
| // Breaking change warnings |
| if (intrinsic && dummy.intent != common::Intent::In) { |
| WarnOnDeferredLengthCharacterScalar( |
| context, &actual, messages.at(), dummyName.c_str()); |
| } |
| } |
| |
| static void CheckProcedureArg(evaluate::ActualArgument &arg, |
| const characteristics::Procedure &proc, |
| const characteristics::DummyProcedure &dummy, const std::string &dummyName, |
| SemanticsContext &context, bool ignoreImplicitVsExplicit) { |
| evaluate::FoldingContext &foldingContext{context.foldingContext()}; |
| parser::ContextualMessages &messages{foldingContext.messages()}; |
| auto restorer{ |
| messages.SetLocation(arg.sourceLocation().value_or(messages.at()))}; |
| const characteristics::Procedure &interface { dummy.procedure.value() }; |
| if (const auto *expr{arg.UnwrapExpr()}) { |
| bool dummyIsPointer{ |
| dummy.attrs.test(characteristics::DummyProcedure::Attr::Pointer)}; |
| const auto *argProcDesignator{ |
| std::get_if<evaluate::ProcedureDesignator>(&expr->u)}; |
| const auto *argProcSymbol{ |
| argProcDesignator ? argProcDesignator->GetSymbol() : nullptr}; |
| if (argProcSymbol) { |
| if (const auto *subp{ |
| argProcSymbol->GetUltimate().detailsIf<SubprogramDetails>()}) { |
| if (subp->stmtFunction()) { |
| evaluate::SayWithDeclaration(messages, *argProcSymbol, |
| "Statement function '%s' may not be passed as an actual argument"_err_en_US, |
| argProcSymbol->name()); |
| return; |
| } |
| } else if (argProcSymbol->has<ProcBindingDetails>()) { |
| if (!context.IsEnabled(common::LanguageFeature::BindingAsProcedure) || |
| context.ShouldWarn(common::LanguageFeature::BindingAsProcedure)) { |
| parser::MessageFixedText msg{ |
| "Procedure binding '%s' passed as an actual argument"_port_en_US}; |
| if (!context.IsEnabled(common::LanguageFeature::BindingAsProcedure)) { |
| msg.set_severity(parser::Severity::Error); |
| } |
| evaluate::SayWithDeclaration( |
| messages, *argProcSymbol, std::move(msg), argProcSymbol->name()); |
| } |
| } |
| } |
| if (auto argChars{characteristics::DummyArgument::FromActual( |
| "actual argument", *expr, foldingContext, |
| /*forImplicitInterface=*/true)}) { |
| if (!argChars->IsTypelessIntrinsicDummy()) { |
| if (auto *argProc{ |
| std::get_if<characteristics::DummyProcedure>(&argChars->u)}) { |
| characteristics::Procedure &argInterface{argProc->procedure.value()}; |
| argInterface.attrs.reset( |
| characteristics::Procedure::Attr::NullPointer); |
| if (!argProcSymbol || argProcSymbol->attrs().test(Attr::INTRINSIC)) { |
| // It's ok to pass ELEMENTAL unrestricted intrinsic functions. |
| argInterface.attrs.reset( |
| characteristics::Procedure::Attr::Elemental); |
| } else if (argInterface.attrs.test( |
| characteristics::Procedure::Attr::Elemental)) { |
| if (argProcSymbol) { // C1533 |
| evaluate::SayWithDeclaration(messages, *argProcSymbol, |
| "Non-intrinsic ELEMENTAL procedure '%s' may not be passed as an actual argument"_err_en_US, |
| argProcSymbol->name()); |
| return; // avoid piling on with checks below |
| } else { |
| argInterface.attrs.reset( |
| characteristics::Procedure::Attr::NullPointer); |
| } |
| } |
| if (interface.HasExplicitInterface()) { |
| std::string whyNot; |
| std::optional<std::string> warning; |
| if (!interface.IsCompatibleWith(argInterface, |
| ignoreImplicitVsExplicit, &whyNot, |
| /*specificIntrinsic=*/nullptr, &warning)) { |
| // 15.5.2.9(1): Explicit interfaces must match |
| if (argInterface.HasExplicitInterface()) { |
| messages.Say( |
| "Actual procedure argument has interface incompatible with %s: %s"_err_en_US, |
| dummyName, whyNot); |
| return; |
| } else if (proc.IsPure()) { |
| messages.Say( |
| "Actual procedure argument for %s of a PURE procedure must have an explicit interface"_err_en_US, |
| dummyName); |
| } else if (context.ShouldWarn( |
| common::UsageWarning::ImplicitInterfaceActual)) { |
| messages.Say( |
| "Actual procedure argument has an implicit interface which is not known to be compatible with %s which has an explicit interface"_warn_en_US, |
| dummyName); |
| } |
| } else if (warning && |
| context.ShouldWarn(common::UsageWarning::ProcDummyArgShapes)) { |
| messages.Say( |
| "Actual procedure argument has possible interface incompatibility with %s: %s"_warn_en_US, |
| dummyName, std::move(*warning)); |
| } |
| } else { // 15.5.2.9(2,3) |
| if (interface.IsSubroutine() && argInterface.IsFunction()) { |
| messages.Say( |
| "Actual argument associated with procedure %s is a function but must be a subroutine"_err_en_US, |
| dummyName); |
| } else if (interface.IsFunction()) { |
| if (argInterface.IsFunction()) { |
| std::string whyNot; |
| if (!interface.functionResult->IsCompatibleWith( |
| *argInterface.functionResult, &whyNot)) { |
| messages.Say( |
| "Actual argument function associated with procedure %s is not compatible: %s"_err_en_US, |
| dummyName, whyNot); |
| } |
| } else if (argInterface.IsSubroutine()) { |
| messages.Say( |
| "Actual argument associated with procedure %s is a subroutine but must be a function"_err_en_US, |
| dummyName); |
| } |
| } |
| } |
| } else { |
| messages.Say( |
| "Actual argument associated with procedure %s is not a procedure"_err_en_US, |
| dummyName); |
| } |
| } else if (IsNullPointer(*expr)) { |
| if (!dummyIsPointer && |
| !dummy.attrs.test( |
| characteristics::DummyProcedure::Attr::Optional)) { |
| messages.Say( |
| "Actual argument associated with procedure %s is a null pointer"_err_en_US, |
| dummyName); |
| } |
| } else { |
| messages.Say( |
| "Actual argument associated with procedure %s is typeless"_err_en_US, |
| dummyName); |
| } |
| } |
| if (dummyIsPointer && dummy.intent != common::Intent::In) { |
| const Symbol *last{GetLastSymbol(*expr)}; |
| if (last && IsProcedurePointer(*last)) { |
| if (dummy.intent != common::Intent::Default && |
| IsIntentIn(last->GetUltimate())) { // 19.6.8 |
| messages.Say( |
| "Actual argument associated with procedure pointer %s may not be INTENT(IN)"_err_en_US, |
| dummyName); |
| } |
| } else if (!(dummy.intent == common::Intent::Default && |
| IsNullProcedurePointer(*expr))) { |
| // 15.5.2.9(5) -- dummy procedure POINTER |
| // Interface compatibility has already been checked above |
| messages.Say( |
| "Actual argument associated with procedure pointer %s must be a pointer unless INTENT(IN)"_err_en_US, |
| dummyName); |
| } |
| } |
| } else { |
| messages.Say( |
| "Assumed-type argument may not be forwarded as procedure %s"_err_en_US, |
| dummyName); |
| } |
| } |
| |
| // Allow BOZ literal actual arguments when they can be converted to a known |
| // dummy argument type |
| static void ConvertBOZLiteralArg( |
| evaluate::ActualArgument &arg, const evaluate::DynamicType &type) { |
| if (auto *expr{arg.UnwrapExpr()}) { |
| if (IsBOZLiteral(*expr)) { |
| if (auto converted{evaluate::ConvertToType(type, SomeExpr{*expr})}) { |
| arg = std::move(*converted); |
| } |
| } |
| } |
| } |
| |
| static void CheckExplicitInterfaceArg(evaluate::ActualArgument &arg, |
| const characteristics::DummyArgument &dummy, |
| const characteristics::Procedure &proc, SemanticsContext &context, |
| const Scope *scope, const evaluate::SpecificIntrinsic *intrinsic, |
| bool allowActualArgumentConversions, bool extentErrors, |
| bool ignoreImplicitVsExplicit) { |
| evaluate::FoldingContext &foldingContext{context.foldingContext()}; |
| auto &messages{foldingContext.messages()}; |
| std::string dummyName{"dummy argument"}; |
| if (!dummy.name.empty()) { |
| dummyName += " '"s + parser::ToLowerCaseLetters(dummy.name) + "='"; |
| } |
| auto restorer{ |
| messages.SetLocation(arg.sourceLocation().value_or(messages.at()))}; |
| auto checkActualArgForLabel = [&](evaluate::ActualArgument &arg) { |
| if (arg.isAlternateReturn()) { |
| messages.Say( |
| "Alternate return label '%d' cannot be associated with %s"_err_en_US, |
| arg.GetLabel(), dummyName); |
| return true; |
| } else { |
| return false; |
| } |
| }; |
| common::visit( |
| common::visitors{ |
| [&](const characteristics::DummyDataObject &object) { |
| if (!checkActualArgForLabel(arg)) { |
| ConvertBOZLiteralArg(arg, object.type.type()); |
| if (auto *expr{arg.UnwrapExpr()}) { |
| if (auto type{characteristics::TypeAndShape::Characterize( |
| *expr, foldingContext)}) { |
| arg.set_dummyIntent(object.intent); |
| bool isElemental{ |
| object.type.Rank() == 0 && proc.IsElemental()}; |
| CheckExplicitDataArg(object, dummyName, *expr, *type, |
| isElemental, context, foldingContext, scope, intrinsic, |
| allowActualArgumentConversions, extentErrors, proc); |
| } else if (object.type.type().IsTypelessIntrinsicArgument() && |
| IsBOZLiteral(*expr)) { |
| // ok |
| } else if (object.type.type().IsTypelessIntrinsicArgument() && |
| evaluate::IsNullObjectPointer(*expr)) { |
| // ok, ASSOCIATED(NULL(without MOLD=)) |
| } else if (object.type.attrs().test(characteristics:: |
| TypeAndShape::Attr::AssumedRank)) { |
| messages.Say( |
| "NULL() without MOLD= must not be associated with an assumed-rank dummy argument"_err_en_US); |
| } else if ((object.attrs.test(characteristics::DummyDataObject:: |
| Attr::Pointer) || |
| object.attrs.test(characteristics:: |
| DummyDataObject::Attr::Optional)) && |
| evaluate::IsNullObjectPointer(*expr)) { |
| // FOO(NULL(without MOLD=)) |
| if (object.type.type().IsAssumedLengthCharacter()) { |
| messages.Say( |
| "Actual argument associated with %s is a NULL() pointer without a MOLD= to provide a character length"_err_en_US, |
| dummyName); |
| } else if (const DerivedTypeSpec * |
| derived{GetDerivedTypeSpec(object.type.type())}) { |
| for (const auto &[pName, pValue] : derived->parameters()) { |
| if (pValue.isAssumed()) { |
| messages.Say( |
| "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, |
| dummyName, pName.ToString()); |
| break; |
| } |
| } |
| } |
| } else if (object.attrs.test(characteristics::DummyDataObject:: |
| Attr::Allocatable) && |
| evaluate::IsNullPointer(*expr)) { |
| if (object.intent == common::Intent::In) { |
| // Extension (Intel, NAG, XLF); see CheckExplicitDataArg. |
| if (context.languageFeatures().ShouldWarn(common:: |
| LanguageFeature::NullActualForAllocatable)) { |
| messages.Say( |
| "Allocatable %s is associated with NULL()"_port_en_US, |
| dummyName); |
| } |
| } else { |
| messages.Say( |
| "NULL() actual argument '%s' may not be associated with allocatable %s without INTENT(IN)"_err_en_US, |
| expr->AsFortran(), dummyName); |
| } |
| } else { |
| messages.Say( |
| "Actual argument '%s' associated with %s is not a variable or typed expression"_err_en_US, |
| expr->AsFortran(), dummyName); |
| } |
| } else { |
| const Symbol &assumed{DEREF(arg.GetAssumedTypeDummy())}; |
| if (!object.type.type().IsAssumedType()) { |
| messages.Say( |
| "Assumed-type '%s' may be associated only with an assumed-type %s"_err_en_US, |
| assumed.name(), dummyName); |
| } else if (object.type.attrs().test(characteristics:: |
| TypeAndShape::Attr::AssumedRank) && |
| !IsAssumedShape(assumed) && |
| !evaluate::IsAssumedRank(assumed)) { |
| messages.Say( // C711 |
| "Assumed-type '%s' must be either assumed shape or assumed rank to be associated with assumed rank %s"_err_en_US, |
| assumed.name(), dummyName); |
| } |
| } |
| } |
| }, |
| [&](const characteristics::DummyProcedure &dummy) { |
| if (!checkActualArgForLabel(arg)) { |
| CheckProcedureArg(arg, proc, dummy, dummyName, context, |
| ignoreImplicitVsExplicit); |
| } |
| }, |
| [&](const characteristics::AlternateReturn &) { |
| // All semantic checking is done elsewhere |
| }, |
| }, |
| dummy.u); |
| } |
| |
| static void RearrangeArguments(const characteristics::Procedure &proc, |
| evaluate::ActualArguments &actuals, parser::ContextualMessages &messages) { |
| CHECK(proc.HasExplicitInterface()); |
| if (actuals.size() < proc.dummyArguments.size()) { |
| actuals.resize(proc.dummyArguments.size()); |
| } else if (actuals.size() > proc.dummyArguments.size()) { |
| messages.Say( |
| "Too many actual arguments (%zd) passed to procedure that expects only %zd"_err_en_US, |
| actuals.size(), proc.dummyArguments.size()); |
| } |
| std::map<std::string, evaluate::ActualArgument> kwArgs; |
| bool anyKeyword{false}; |
| int which{1}; |
| for (auto &x : actuals) { |
| if (!x) { |
| } else if (x->keyword()) { |
| auto emplaced{ |
| kwArgs.try_emplace(x->keyword()->ToString(), std::move(*x))}; |
| if (!emplaced.second) { |
| messages.Say(*x->keyword(), |
| "Argument keyword '%s=' appears on more than one effective argument in this procedure reference"_err_en_US, |
| *x->keyword()); |
| } |
| x.reset(); |
| anyKeyword = true; |
| } else if (anyKeyword) { |
| messages.Say(x ? x->sourceLocation() : std::nullopt, |
| "Actual argument #%d without a keyword may not follow any actual argument with a keyword"_err_en_US, |
| which); |
| } |
| ++which; |
| } |
| if (!kwArgs.empty()) { |
| int index{0}; |
| for (const auto &dummy : proc.dummyArguments) { |
| if (!dummy.name.empty()) { |
| auto iter{kwArgs.find(dummy.name)}; |
| if (iter != kwArgs.end()) { |
| evaluate::ActualArgument &x{iter->second}; |
| if (actuals[index]) { |
| messages.Say(*x.keyword(), |
| "Keyword argument '%s=' has already been specified positionally (#%d) in this procedure reference"_err_en_US, |
| *x.keyword(), index + 1); |
| } else { |
| actuals[index] = std::move(x); |
| } |
| kwArgs.erase(iter); |
| } |
| } |
| ++index; |
| } |
| for (auto &bad : kwArgs) { |
| evaluate::ActualArgument &x{bad.second}; |
| messages.Say(*x.keyword(), |
| "Argument keyword '%s=' is not recognized for this procedure reference"_err_en_US, |
| *x.keyword()); |
| } |
| } |
| } |
| |
| // 15.8.1(3) -- In a reference to an elemental procedure, if any argument is an |
| // array, each actual argument that corresponds to an INTENT(OUT) or |
| // INTENT(INOUT) dummy argument shall be an array. The actual argument to an |
| // ELEMENTAL procedure must conform. |
| static bool CheckElementalConformance(parser::ContextualMessages &messages, |
| const characteristics::Procedure &proc, evaluate::ActualArguments &actuals, |
| evaluate::FoldingContext &context) { |
| std::optional<evaluate::Shape> shape; |
| std::string shapeName; |
| int index{0}; |
| bool hasArrayArg{false}; |
| for (const auto &arg : actuals) { |
| if (arg && !arg->isAlternateReturn() && arg->Rank() > 0) { |
| hasArrayArg = true; |
| break; |
| } |
| } |
| for (const auto &arg : actuals) { |
| const auto &dummy{proc.dummyArguments.at(index++)}; |
| if (arg) { |
| if (const auto *expr{arg->UnwrapExpr()}) { |
| if (auto argShape{evaluate::GetShape(context, *expr)}) { |
| if (GetRank(*argShape) > 0) { |
| std::string argName{"actual argument ("s + expr->AsFortran() + |
| ") corresponding to dummy argument #" + std::to_string(index) + |
| " ('" + dummy.name + "')"}; |
| if (shape) { |
| auto tristate{evaluate::CheckConformance(messages, *shape, |
| *argShape, evaluate::CheckConformanceFlags::None, |
| shapeName.c_str(), argName.c_str())}; |
| if (tristate && !*tristate) { |
| return false; |
| } |
| } else { |
| shape = std::move(argShape); |
| shapeName = argName; |
| } |
| } else if ((dummy.GetIntent() == common::Intent::Out || |
| dummy.GetIntent() == common::Intent::InOut) && |
| hasArrayArg) { |
| messages.Say( |
| "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, |
| expr->AsFortran()); |
| } |
| } |
| } |
| } |
| } |
| return true; |
| } |
| |
| // ASSOCIATED (16.9.16) |
| static void CheckAssociated(evaluate::ActualArguments &arguments, |
| SemanticsContext &semanticsContext, const Scope *scope) { |
| evaluate::FoldingContext &foldingContext{semanticsContext.foldingContext()}; |
| parser::ContextualMessages &messages{foldingContext.messages()}; |
| bool ok{true}; |
| if (arguments.size() < 2) { |
| return; |
| } |
| if (const auto &pointerArg{arguments[0]}) { |
| if (const auto *pointerExpr{pointerArg->UnwrapExpr()}) { |
| if (!IsPointer(*pointerExpr)) { |
| messages.Say(pointerArg->sourceLocation(), |
| "POINTER= argument of ASSOCIATED() must be a pointer"_err_en_US); |
| return; |
| } |
| if (const auto &targetArg{arguments[1]}) { |
| // The standard requires that the TARGET= argument, when present, |
| // be a valid RHS for a pointer assignment that has the POINTER= |
| // argument as its LHS. Some popular compilers misinterpret this |
| // requirement more strongly than necessary, and actually validate |
| // the POINTER= argument as if it were serving as the LHS of a pointer |
| // assignment. This, perhaps unintentionally, excludes function |
| // results, including NULL(), from being used there, as well as |
| // INTENT(IN) dummy pointers. Detect these conditions and emit |
| // portability warnings. |
| if (semanticsContext.ShouldWarn(common::UsageWarning::Portability)) { |
| if (!evaluate::ExtractDataRef(*pointerExpr) && |
| !evaluate::IsProcedurePointer(*pointerExpr)) { |
| messages.Say(pointerArg->sourceLocation(), |
| "POINTER= argument of ASSOCIATED() is required by some other compilers to be a pointer"_port_en_US); |
| } else if (scope && !evaluate::UnwrapProcedureRef(*pointerExpr)) { |
| if (auto whyNot{WhyNotDefinable( |
| pointerArg->sourceLocation().value_or(messages.at()), |
| *scope, |
| DefinabilityFlags{DefinabilityFlag::PointerDefinition}, |
| *pointerExpr)}) { |
| if (auto *msg{messages.Say(pointerArg->sourceLocation(), |
| "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)}) { |
| msg->Attach(std::move(*whyNot)); |
| } |
| } |
| } |
| } |
| if (const auto *targetExpr{targetArg->UnwrapExpr()}) { |
| if (IsProcedurePointer(*pointerExpr) && |
| !IsBareNullPointer(pointerExpr)) { // POINTER= is a procedure |
| if (auto pointerProc{characteristics::Procedure::Characterize( |
| *pointerExpr, foldingContext)}) { |
| if (IsBareNullPointer(targetExpr)) { |
| } else if (IsProcedurePointerTarget(*targetExpr)) { |
| if (auto targetProc{characteristics::Procedure::Characterize( |
| *targetExpr, foldingContext)}) { |
| bool isCall{!!UnwrapProcedureRef(*targetExpr)}; |
| std::string whyNot; |
| std::optional<std::string> warning; |
| const auto *targetProcDesignator{ |
| evaluate::UnwrapExpr<evaluate::ProcedureDesignator>( |
| *targetExpr)}; |
| const evaluate::SpecificIntrinsic *specificIntrinsic{ |
| targetProcDesignator |
| ? targetProcDesignator->GetSpecificIntrinsic() |
| : nullptr}; |
| std::optional<parser::MessageFixedText> msg{ |
| CheckProcCompatibility(isCall, pointerProc, &*targetProc, |
| specificIntrinsic, whyNot, warning, |
| /*ignoreImplicitVsExplicit=*/false)}; |
| if (!msg && warning && |
| semanticsContext.ShouldWarn( |
| common::UsageWarning::ProcDummyArgShapes)) { |
| msg = |
| "Procedures '%s' and '%s' may not be completely compatible: %s"_warn_en_US; |
| whyNot = std::move(*warning); |
| } |
| if (msg) { |
| msg->set_severity(parser::Severity::Warning); |
| messages.Say(std::move(*msg), |
| "pointer '" + pointerExpr->AsFortran() + "'", |
| targetExpr->AsFortran(), whyNot); |
| } |
| } |
| } else if (!IsNullProcedurePointer(*targetExpr)) { |
| messages.Say( |
| "POINTER= argument '%s' is a procedure pointer but the TARGET= argument '%s' is not a procedure or procedure pointer"_err_en_US, |
| pointerExpr->AsFortran(), targetExpr->AsFortran()); |
| } |
| } |
| } else if (IsVariable(*targetExpr) || IsNullPointer(*targetExpr)) { |
| // Object pointer and target |
| if (ExtractDataRef(*targetExpr)) { |
| if (SymbolVector symbols{GetSymbolVector(*targetExpr)}; |
| !evaluate::GetLastTarget(symbols)) { |
| parser::Message *msg{messages.Say(targetArg->sourceLocation(), |
| "TARGET= argument '%s' must have either the POINTER or the TARGET attribute"_err_en_US, |
| targetExpr->AsFortran())}; |
| for (SymbolRef ref : symbols) { |
| msg = evaluate::AttachDeclaration(msg, *ref); |
| } |
| } else if (HasVectorSubscript(*targetExpr) || |
| ExtractCoarrayRef(*targetExpr)) { |
| messages.Say(targetArg->sourceLocation(), |
| "TARGET= argument '%s' may not have a vector subscript or coindexing"_err_en_US, |
| targetExpr->AsFortran()); |
| } |
| } |
| if (const auto pointerType{pointerArg->GetType()}) { |
| if (const auto targetType{targetArg->GetType()}) { |
| ok = pointerType->IsTkCompatibleWith(*targetType); |
| } |
| } |
| } else { |
| messages.Say( |
| "POINTER= argument '%s' is an object pointer but the TARGET= argument '%s' is not a variable"_err_en_US, |
| pointerExpr->AsFortran(), targetExpr->AsFortran()); |
| } |
| } |
| } |
| } |
| } else { |
| // No arguments to ASSOCIATED() |
| ok = false; |
| } |
| if (!ok) { |
| messages.Say( |
| "Arguments of ASSOCIATED() must be a pointer and an optional valid target"_err_en_US); |
| } |
| } |
| |
| // IMAGE_INDEX (F'2023 16.9.107) |
| static void CheckImage_Index(evaluate::ActualArguments &arguments, |
| parser::ContextualMessages &messages) { |
| if (arguments[1] && arguments[0]) { |
| if (const auto subArrShape{ |
| evaluate::GetShape(arguments[1]->UnwrapExpr())}) { |
| if (const auto *coarrayArgSymbol{UnwrapWholeSymbolOrComponentDataRef( |
| arguments[0]->UnwrapExpr())}) { |
| const auto coarrayArgCorank = coarrayArgSymbol->Corank(); |
| if (const auto subArrSize = evaluate::ToInt64(*subArrShape->front())) { |
| if (subArrSize != coarrayArgCorank) { |
| messages.Say(arguments[1]->sourceLocation(), |
| "The size of 'SUB=' (%jd) for intrinsic 'image_index' must be equal to the corank of 'COARRAY=' (%d)"_err_en_US, |
| static_cast<std::int64_t>(*subArrSize), coarrayArgCorank); |
| } |
| } |
| } |
| } |
| } |
| } |
| |
| // MOVE_ALLOC (F'2023 16.9.147) |
| static void CheckMove_Alloc(evaluate::ActualArguments &arguments, |
| parser::ContextualMessages &messages) { |
| if (arguments.size() >= 1) { |
| evaluate::CheckForCoindexedObject( |
| messages, arguments[0], "move_alloc", "from"); |
| } |
| if (arguments.size() >= 2) { |
| evaluate::CheckForCoindexedObject( |
| messages, arguments[1], "move_alloc", "to"); |
| } |
| if (arguments.size() >= 3) { |
| evaluate::CheckForCoindexedObject( |
| messages, arguments[2], "move_alloc", "stat"); |
| } |
| if (arguments.size() >= 4) { |
| evaluate::CheckForCoindexedObject( |
| messages, arguments[3], "move_alloc", "errmsg"); |
| } |
| if (arguments.size() >= 2 && arguments[0] && arguments[1]) { |
| for (int j{0}; j < 2; ++j) { |
| if (const Symbol * |
| whole{UnwrapWholeSymbolOrComponentDataRef(arguments[j])}; |
| !whole || !IsAllocatable(whole->GetUltimate())) { |
| messages.Say(*arguments[j]->sourceLocation(), |
| "Argument #%d to MOVE_ALLOC must be allocatable"_err_en_US, j + 1); |
| } |
| } |
| auto type0{arguments[0]->GetType()}; |
| auto type1{arguments[1]->GetType()}; |
| if (type0 && type1 && type0->IsPolymorphic() && !type1->IsPolymorphic()) { |
| messages.Say(arguments[1]->sourceLocation(), |
| "When MOVE_ALLOC(FROM=) is polymorphic, TO= must also be polymorphic"_err_en_US); |
| } |
| } |
| } |
| |
| // PRESENT (F'2023 16.9.163) |
| static void CheckPresent(evaluate::ActualArguments &arguments, |
| parser::ContextualMessages &messages) { |
| if (arguments.size() == 1) { |
| if (const auto &arg{arguments[0]}; arg) { |
| const Symbol *symbol{nullptr}; |
| if (const auto *expr{arg->UnwrapExpr()}) { |
| if (const auto *proc{ |
| std::get_if<evaluate::ProcedureDesignator>(&expr->u)}) { |
| symbol = proc->GetSymbol(); |
| } else { |
| symbol = evaluate::UnwrapWholeSymbolDataRef(*expr); |
| } |
| } else { |
| symbol = arg->GetAssumedTypeDummy(); |
| } |
| if (!symbol || !symbol->attrs().test(semantics::Attr::OPTIONAL)) { |
| messages.Say(arg ? arg->sourceLocation() : messages.at(), |
| "Argument of PRESENT() must be the name of a whole OPTIONAL dummy argument"_err_en_US); |
| } |
| } |
| } |
| } |
| |
| // REDUCE (F'2023 16.9.173) |
| static void CheckReduce( |
| evaluate::ActualArguments &arguments, evaluate::FoldingContext &context) { |
| std::optional<evaluate::DynamicType> arrayType; |
| parser::ContextualMessages &messages{context.messages()}; |
| if (const auto &array{arguments[0]}) { |
| arrayType = array->GetType(); |
| if (!arguments[/*identity=*/4]) { |
| if (const auto *expr{array->UnwrapExpr()}) { |
| if (auto shape{ |
| evaluate::GetShape(context, *expr, /*invariantOnly=*/false)}) { |
| if (const auto &dim{arguments[2]}; dim && array->Rank() > 1) { |
| // Partial reduction |
| auto dimVal{evaluate::ToInt64(dim->UnwrapExpr())}; |
| std::int64_t j{0}; |
| int zeroDims{0}; |
| bool isSelectedDimEmpty{false}; |
| for (const auto &extent : *shape) { |
| ++j; |
| if (evaluate::ToInt64(extent) == 0) { |
| ++zeroDims; |
| isSelectedDimEmpty |= dimVal && j == *dimVal; |
| } |
| } |
| if (isSelectedDimEmpty && zeroDims == 1) { |
| messages.Say( |
| "IDENTITY= must be present when DIM=%d and the array has zero extent on that dimension"_err_en_US, |
| static_cast<int>(dimVal.value())); |
| } |
| } else { // no DIM= or DIM=1 on a vector: total reduction |
| for (const auto &extent : *shape) { |
| if (evaluate::ToInt64(extent) == 0) { |
| messages.Say( |
| "IDENTITY= must be present when the array is empty and the result is scalar"_err_en_US); |
| break; |
| } |
| } |
| } |
| } |
| } |
| } |
| } |
| std::optional<characteristics::Procedure> procChars; |
| if (const auto &operation{arguments[1]}) { |
| if (const auto *expr{operation->UnwrapExpr()}) { |
| if (const auto *designator{ |
| std::get_if<evaluate::ProcedureDesignator>(&expr->u)}) { |
| procChars = |
| characteristics::Procedure::Characterize(*designator, context); |
| } else if (const auto *ref{ |
| std::get_if<evaluate::ProcedureRef>(&expr->u)}) { |
| procChars = characteristics::Procedure::Characterize(*ref, context); |
| } |
| } |
| } |
| const auto *result{ |
| procChars ? procChars->functionResult->GetTypeAndShape() : nullptr}; |
| if (!procChars || !procChars->IsPure() || |
| procChars->dummyArguments.size() != 2 || !procChars->functionResult) { |
| messages.Say( |
| "OPERATION= argument of REDUCE() must be a pure function of two data arguments"_err_en_US); |
| } else if (procChars->attrs.test(characteristics::Procedure::Attr::BindC)) { |
| messages.Say( |
| "A BIND(C) OPERATION= argument of REDUCE() is not supported"_err_en_US); |
| } else if (!result || result->Rank() != 0) { |
| messages.Say( |
| "OPERATION= argument of REDUCE() must be a scalar function"_err_en_US); |
| } else if (result->type().IsPolymorphic() || |
| (arrayType && !arrayType->IsTkLenCompatibleWith(result->type()))) { |
| messages.Say( |
| "OPERATION= argument of REDUCE() must have the same type as ARRAY="_err_en_US); |
| } else { |
| const characteristics::DummyDataObject *data[2]{}; |
| for (int j{0}; j < 2; ++j) { |
| const auto &dummy{procChars->dummyArguments.at(j)}; |
| data[j] = std::get_if<characteristics::DummyDataObject>(&dummy.u); |
| } |
| if (!data[0] || !data[1]) { |
| messages.Say( |
| "OPERATION= argument of REDUCE() may not have dummy procedure arguments"_err_en_US); |
| } else { |
| for (int j{0}; j < 2; ++j) { |
| if (data[j]->attrs.test( |
| characteristics::DummyDataObject::Attr::Optional) || |
| data[j]->attrs.test( |
| characteristics::DummyDataObject::Attr::Allocatable) || |
| data[j]->attrs.test( |
| characteristics::DummyDataObject::Attr::Pointer) || |
| data[j]->type.Rank() != 0 || data[j]->type.type().IsPolymorphic() || |
| (arrayType && |
| !data[j]->type.type().IsTkCompatibleWith(*arrayType))) { |
| messages.Say( |
| "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); |
| } |
| } |
| static constexpr characteristics::DummyDataObject::Attr attrs[]{ |
| characteristics::DummyDataObject::Attr::Asynchronous, |
| characteristics::DummyDataObject::Attr::Target, |
| characteristics::DummyDataObject::Attr::Value, |
| }; |
| for (std::size_t j{0}; j < sizeof attrs / sizeof *attrs; ++j) { |
| if (data[0]->attrs.test(attrs[j]) != data[1]->attrs.test(attrs[j])) { |
| messages.Say( |
| "If either argument of the OPERATION= procedure of REDUCE() has the ASYNCHRONOUS, TARGET, or VALUE attribute, both must have that attribute"_err_en_US); |
| break; |
| } |
| } |
| } |
| } |
| // When the MASK= is present and has no .TRUE. element, and there is |
| // no IDENTITY=, it's an error. |
| if (const auto &mask{arguments[3]}; mask && !arguments[/*identity*/ 4]) { |
| if (const auto *expr{mask->UnwrapExpr()}) { |
| if (const auto *logical{ |
| std::get_if<evaluate::Expr<evaluate::SomeLogical>>(&expr->u)}) { |
| if (common::visit( |
| [](const auto &kindExpr) { |
| using KindExprType = std::decay_t<decltype(kindExpr)>; |
| using KindLogical = typename KindExprType::Result; |
| if (const auto *c{evaluate::UnwrapConstantValue<KindLogical>( |
| kindExpr)}) { |
| for (const auto &element : c->values()) { |
| if (element.IsTrue()) { |
| return false; |
| } |
| } |
| return true; |
| } |
| return false; |
| }, |
| logical->u)) { |
| messages.Say( |
| "MASK= has no .TRUE. element, so IDENTITY= must be present"_err_en_US); |
| } |
| } |
| } |
| } |
| } |
| |
| // TRANSFER (16.9.193) |
| static void CheckTransferOperandType(SemanticsContext &context, |
| const evaluate::DynamicType &type, const char *which) { |
| if (type.IsPolymorphic() && |
| context.ShouldWarn(common::UsageWarning::PolymorphicTransferArg)) { |
| context.foldingContext().messages().Say( |
| "%s of TRANSFER is polymorphic"_warn_en_US, which); |
| } else if (!type.IsUnlimitedPolymorphic() && |
| type.category() == TypeCategory::Derived && |
| context.ShouldWarn(common::UsageWarning::PointerComponentTransferArg)) { |
| DirectComponentIterator directs{type.GetDerivedTypeSpec()}; |
| if (auto bad{std::find_if(directs.begin(), directs.end(), IsDescriptor)}; |
| bad != directs.end()) { |
| evaluate::SayWithDeclaration(context.foldingContext().messages(), *bad, |
| "%s of TRANSFER contains allocatable or pointer component %s"_warn_en_US, |
| which, bad.BuildResultDesignatorName()); |
| } |
| } |
| } |
| |
| static void CheckTransfer(evaluate::ActualArguments &arguments, |
| SemanticsContext &context, const Scope *scope) { |
| evaluate::FoldingContext &foldingContext{context.foldingContext()}; |
| parser::ContextualMessages &messages{foldingContext.messages()}; |
| if (arguments.size() >= 2) { |
| if (auto source{characteristics::TypeAndShape::Characterize( |
| arguments[0], foldingContext)}) { |
| CheckTransferOperandType(context, source->type(), "Source"); |
| if (auto mold{characteristics::TypeAndShape::Characterize( |
| arguments[1], foldingContext)}) { |
| CheckTransferOperandType(context, mold->type(), "Mold"); |
| if (mold->Rank() > 0 && |
| evaluate::ToInt64( |
| evaluate::Fold(foldingContext, |
| mold->MeasureElementSizeInBytes(foldingContext, false))) |
| .value_or(1) == 0) { |
| if (auto sourceSize{evaluate::ToInt64(evaluate::Fold(foldingContext, |
| source->MeasureSizeInBytes(foldingContext)))}) { |
| if (*sourceSize > 0) { |
| messages.Say( |
| "Element size of MOLD= array may not be zero when SOURCE= is not empty"_err_en_US); |
| } |
| } else { |
| messages.Say( |
| "Element size of MOLD= array may not be zero unless SOURCE= is empty"_warn_en_US); |
| } |
| } |
| } |
| } |
| if (arguments.size() > 2) { // SIZE= |
| if (const Symbol * |
| whole{UnwrapWholeSymbolOrComponentDataRef(arguments[2])}) { |
| if (IsOptional(*whole)) { |
| messages.Say( |
| "SIZE= argument may not be the optional dummy argument '%s'"_err_en_US, |
| whole->name()); |
| } else if (context.ShouldWarn( |
| common::UsageWarning::TransferSizePresence) && |
| IsAllocatableOrObjectPointer(whole)) { |
| messages.Say( |
| "SIZE= argument that is allocatable or pointer must be present at execution; parenthesize to silence this warning"_warn_en_US); |
| } |
| } |
| } |
| } |
| } |
| |
| static void CheckSpecificIntrinsic(evaluate::ActualArguments &arguments, |
| SemanticsContext &context, const Scope *scope, |
| const evaluate::SpecificIntrinsic &intrinsic) { |
| if (intrinsic.name == "associated") { |
| CheckAssociated(arguments, context, scope); |
| } else if (intrinsic.name == "image_index") { |
| CheckImage_Index(arguments, context.foldingContext().messages()); |
| } else if (intrinsic.name == "move_alloc") { |
| CheckMove_Alloc(arguments, context.foldingContext().messages()); |
| } else if (intrinsic.name == "present") { |
| CheckPresent(arguments, context.foldingContext().messages()); |
| } else if (intrinsic.name == "reduce") { |
| CheckReduce(arguments, context.foldingContext()); |
| } else if (intrinsic.name == "transfer") { |
| CheckTransfer(arguments, context, scope); |
| } |
| } |
| |
| static parser::Messages CheckExplicitInterface( |
| const characteristics::Procedure &proc, evaluate::ActualArguments &actuals, |
| SemanticsContext &context, const Scope *scope, |
| const evaluate::SpecificIntrinsic *intrinsic, |
| bool allowActualArgumentConversions, bool extentErrors, |
| bool ignoreImplicitVsExplicit) { |
| evaluate::FoldingContext &foldingContext{context.foldingContext()}; |
| parser::ContextualMessages &messages{foldingContext.messages()}; |
| parser::Messages buffer; |
| auto restorer{messages.SetMessages(buffer)}; |
| RearrangeArguments(proc, actuals, messages); |
| if (!buffer.empty()) { |
| return buffer; |
| } |
| int index{0}; |
| for (auto &actual : actuals) { |
| const auto &dummy{proc.dummyArguments.at(index++)}; |
| if (actual) { |
| CheckExplicitInterfaceArg(*actual, dummy, proc, context, scope, intrinsic, |
| allowActualArgumentConversions, extentErrors, |
| ignoreImplicitVsExplicit); |
| } else if (!dummy.IsOptional()) { |
| if (dummy.name.empty()) { |
| messages.Say( |
| "Dummy argument #%d is not OPTIONAL and is not associated with " |
| "an actual argument in this procedure reference"_err_en_US, |
| index); |
| } else { |
| messages.Say("Dummy argument '%s=' (#%d) is not OPTIONAL and is not " |
| "associated with an actual argument in this procedure " |
| "reference"_err_en_US, |
| dummy.name, index); |
| } |
| } |
| } |
| if (proc.IsElemental() && !buffer.AnyFatalError()) { |
| CheckElementalConformance(messages, proc, actuals, foldingContext); |
| } |
| if (intrinsic) { |
| CheckSpecificIntrinsic(actuals, context, scope, *intrinsic); |
| } |
| return buffer; |
| } |
| |
| bool CheckInterfaceForGeneric(const characteristics::Procedure &proc, |
| evaluate::ActualArguments &actuals, SemanticsContext &context, |
| bool allowActualArgumentConversions) { |
| return proc.HasExplicitInterface() && |
| !CheckExplicitInterface(proc, actuals, context, nullptr, nullptr, |
| allowActualArgumentConversions, /*extentErrors=*/false, |
| /*ignoreImplicitVsExplicit=*/false) |
| .AnyFatalError(); |
| } |
| |
| bool CheckArgumentIsConstantExprInRange( |
| const evaluate::ActualArguments &actuals, int index, int lowerBound, |
| int upperBound, parser::ContextualMessages &messages) { |
| CHECK(index >= 0 && static_cast<unsigned>(index) < actuals.size()); |
| |
| const std::optional<evaluate::ActualArgument> &argOptional{actuals[index]}; |
| if (!argOptional) { |
| DIE("Actual argument should have value"); |
| return false; |
| } |
| |
| const evaluate::ActualArgument &arg{argOptional.value()}; |
| const evaluate::Expr<evaluate::SomeType> *argExpr{arg.UnwrapExpr()}; |
| CHECK(argExpr != nullptr); |
| |
| if (!IsConstantExpr(*argExpr)) { |
| messages.Say("Actual argument #%d must be a constant expression"_err_en_US, |
| index + 1); |
| return false; |
| } |
| |
| // This does not imply that the kind of the argument is 8. The kind |
| // for the intrinsic's argument should have been check prior. This is just |
| // a conversion so that we can read the constant value. |
| auto scalarValue{evaluate::ToInt64(argExpr)}; |
| CHECK(scalarValue.has_value()); |
| |
| if (*scalarValue < lowerBound || *scalarValue > upperBound) { |
| messages.Say( |
| "Argument #%d must be a constant expression in range %d to %d"_err_en_US, |
| index + 1, lowerBound, upperBound); |
| return false; |
| } |
| return true; |
| } |
| |
| bool CheckPPCIntrinsic(const Symbol &generic, const Symbol &specific, |
| const evaluate::ActualArguments &actuals, |
| evaluate::FoldingContext &context) { |
| parser::ContextualMessages &messages{context.messages()}; |
| |
| if (specific.name() == "__ppc_mtfsf") { |
| return CheckArgumentIsConstantExprInRange(actuals, 0, 0, 7, messages); |
| } |
| if (specific.name() == "__ppc_mtfsfi") { |
| return CheckArgumentIsConstantExprInRange(actuals, 0, 0, 7, messages) && |
| CheckArgumentIsConstantExprInRange(actuals, 1, 0, 15, messages); |
| } |
| if (specific.name().ToString().compare(0, 14, "__ppc_vec_sld_") == 0) { |
| return CheckArgumentIsConstantExprInRange(actuals, 2, 0, 15, messages); |
| } |
| if (specific.name().ToString().compare(0, 15, "__ppc_vec_sldw_") == 0) { |
| return CheckArgumentIsConstantExprInRange(actuals, 2, 0, 3, messages); |
| } |
| if (specific.name().ToString().compare(0, 14, "__ppc_vec_ctf_") == 0) { |
| return CheckArgumentIsConstantExprInRange(actuals, 1, 0, 31, messages); |
| } |
| if (specific.name().ToString().compare(0, 16, "__ppc_vec_permi_") == 0) { |
| return CheckArgumentIsConstantExprInRange(actuals, 2, 0, 3, messages); |
| } |
| if (specific.name().ToString().compare(0, 21, "__ppc_vec_splat_s32__") == 0) { |
| return CheckArgumentIsConstantExprInRange(actuals, 0, -16, 15, messages); |
| } |
| if (specific.name().ToString().compare(0, 16, "__ppc_vec_splat_") == 0) { |
| // The value of arg2 in vec_splat must be a constant expression that is |
| // greater than or equal to 0, and less than the number of elements in arg1. |
| auto *expr{actuals[0].value().UnwrapExpr()}; |
| auto type{characteristics::TypeAndShape::Characterize(*expr, context)}; |
| assert(type && "unknown type"); |
| const auto *derived{evaluate::GetDerivedTypeSpec(type.value().type())}; |
| if (derived && derived->IsVectorType()) { |
| for (const auto &pair : derived->parameters()) { |
| if (pair.first == "element_kind") { |
| auto vecElemKind{Fortran::evaluate::ToInt64(pair.second.GetExplicit()) |
| .value_or(0)}; |
| auto numElem{vecElemKind == 0 ? 0 : (16 / vecElemKind)}; |
| return CheckArgumentIsConstantExprInRange( |
| actuals, 1, 0, numElem - 1, messages); |
| } |
| } |
| } else |
| assert(false && "vector type is expected"); |
| } |
| return false; |
| } |
| |
| bool CheckArguments(const characteristics::Procedure &proc, |
| evaluate::ActualArguments &actuals, SemanticsContext &context, |
| const Scope &scope, bool treatingExternalAsImplicit, |
| bool ignoreImplicitVsExplicit, |
| const evaluate::SpecificIntrinsic *intrinsic) { |
| bool explicitInterface{proc.HasExplicitInterface()}; |
| evaluate::FoldingContext foldingContext{context.foldingContext()}; |
| parser::ContextualMessages &messages{foldingContext.messages()}; |
| if (!explicitInterface || treatingExternalAsImplicit) { |
| parser::Messages buffer; |
| { |
| auto restorer{messages.SetMessages(buffer)}; |
| for (auto &actual : actuals) { |
| if (actual) { |
| CheckImplicitInterfaceArg(*actual, messages, foldingContext); |
| } |
| } |
| } |
| if (!buffer.empty()) { |
| if (auto *msgs{messages.messages()}) { |
| msgs->Annex(std::move(buffer)); |
| } |
| return false; // don't pile on |
| } |
| } |
| if (explicitInterface) { |
| auto buffer{CheckExplicitInterface(proc, actuals, context, &scope, |
| intrinsic, /*allowArgumentConversions=*/true, /*extentErrors=*/true, |
| ignoreImplicitVsExplicit)}; |
| if (!buffer.empty()) { |
| if (treatingExternalAsImplicit) { |
| if (auto *msg{messages.Say( |
| "If the procedure's interface were explicit, this reference would be in error"_warn_en_US)}) { |
| buffer.AttachTo(*msg, parser::Severity::Because); |
| } |
| } |
| if (auto *msgs{messages.messages()}) { |
| msgs->Annex(std::move(buffer)); |
| } |
| return false; |
| } |
| } |
| return true; |
| } |
| } // namespace Fortran::semantics |
