| //===-- 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 "pointer-assignment.h" |
| #include "flang/Evaluate/characteristics.h" |
| #include "flang/Evaluate/check-expression.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) { |
| 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 argument requires an explicit interface"_err_en_US); |
| } else if (type->IsPolymorphic()) { |
| messages.Say( |
| "Polymorphic argument requires an explicit interface"_err_en_US); |
| } else if (const DerivedTypeSpec * derived{GetDerivedTypeSpec(type)}) { |
| if (!derived->parameters().empty()) { |
| messages.Say( |
| "Parameterized derived type 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); |
| } |
| 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); |
| } |
| } |
| } |
| } |
| |
| // When scalar CHARACTER actual arguments are known to be short, |
| // we extend them on the right with spaces and a warning. |
| static void PadShortCharacterActual(evaluate::Expr<evaluate::SomeType> &actual, |
| const characteristics::TypeAndShape &dummyType, |
| characteristics::TypeAndShape &actualType, |
| evaluate::FoldingContext &context, parser::ContextualMessages &messages) { |
| if (dummyType.type().category() == TypeCategory::Character && |
| actualType.type().category() == TypeCategory::Character && |
| dummyType.type().kind() == actualType.type().kind() && |
| GetRank(actualType.shape()) == 0) { |
| if (dummyType.LEN() && actualType.LEN()) { |
| auto dummyLength{ToInt64(Fold(context, common::Clone(*dummyType.LEN())))}; |
| auto actualLength{ |
| ToInt64(Fold(context, common::Clone(*actualType.LEN())))}; |
| if (dummyLength && actualLength && *actualLength < *dummyLength) { |
| messages.Say( |
| "Actual length '%jd' is less than expected length '%jd'"_en_US, |
| *actualLength, *dummyLength); |
| auto converted{ConvertToType(dummyType.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) { |
| 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()) { |
| messages.Say( |
| "Actual argument scalar expression of type INTEGER(%d) was converted to smaller dummy argument type INTEGER(%d)"_en_US, |
| actualType.type().kind(), dummyType.type().kind()); |
| } |
| 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, |
| evaluate::FoldingContext &context, const Scope *scope, |
| const evaluate::SpecificIntrinsic *intrinsic) { |
| |
| // Basic type & rank checking |
| parser::ContextualMessages &messages{context.messages()}; |
| PadShortCharacterActual(actual, dummy.type, actualType, context, messages); |
| ConvertIntegerActual(actual, dummy.type, actualType, messages); |
| bool typesCompatible{dummy.type.type().IsTkCompatibleWith(actualType.type())}; |
| if (typesCompatible) { |
| if (isElemental) { |
| } else if (dummy.type.attrs().test( |
| characteristics::TypeAndShape::Attr::AssumedRank)) { |
| } else if (!dummy.type.attrs().test( |
| characteristics::TypeAndShape::Attr::AssumedShape) && |
| (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. |
| } else { |
| // Let CheckConformance accept scalars; storage association |
| // cases are checked here below. |
| CheckConformance(messages, dummy.type.shape(), actualType.shape(), |
| evaluate::CheckConformanceFlags::EitherScalarExpandable, |
| "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)}; |
| if (const auto *derived{evaluate::GetDerivedTypeSpec(actualType.type())}) { |
| 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()); |
| } |
| const auto &finals{ |
| derived->typeSymbol().get<DerivedTypeDetails>().finals()}; |
| if (!finals.empty()) { // 15.5.2.4(2) |
| 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(), |
| finals.begin()->first)}) { |
| msg->Attach(finals.begin()->first, |
| "FINAL subroutine '%s' in derived type '%s'"_en_US, |
| finals.begin()->first, 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{evaluate::GetRank(actualType.shape())}; |
| bool actualIsPointer{evaluate::IsObjectPointer(actual, context)}; |
| bool dummyIsAssumedRank{dummy.type.attrs().test( |
| characteristics::TypeAndShape::Attr::AssumedRank)}; |
| if (dummy.type.attrs().test( |
| characteristics::TypeAndShape::Attr::AssumedShape)) { |
| // 15.5.2.4(16) |
| if (actualRank == 0) { |
| messages.Say( |
| "Scalar actual argument may not be associated with assumed-shape %s"_err_en_US, |
| dummyName); |
| } |
| if (actualIsAssumedSize && actualLastSymbol) { |
| evaluate::SayWithDeclaration(messages, *actualLastSymbol, |
| "Assumed-size array may not be associated with assumed-shape %s"_err_en_US, |
| dummyName); |
| } |
| } else if (actualRank == 0 && dummy.type.Rank() > 0) { |
| // Actual is scalar, dummy is an array. 15.5.2.4(14), 15.5.2.11 |
| if (actualIsCoindexed) { |
| messages.Say( |
| "Coindexed scalar actual argument must be associated with a scalar %s"_err_en_US, |
| dummyName); |
| } |
| if (!IsArrayElement(actual) && |
| !(actualType.type().category() == TypeCategory::Character && |
| actualType.type().kind() == 1) && |
| !(dummy.type.type().IsAssumedType() && dummyIsAssumedSize) && |
| !dummyIsAssumedRank) { |
| messages.Say( |
| "Whole scalar actual argument may not be associated with a %s array"_err_en_US, |
| dummyName); |
| } |
| if (actualIsPolymorphic) { |
| messages.Say( |
| "Polymorphic scalar may not be associated with a %s array"_err_en_US, |
| dummyName); |
| } |
| if (actualIsPointer) { |
| messages.Say( |
| "Scalar POINTER target may not be associated with a %s array"_err_en_US, |
| dummyName); |
| } |
| if (actualLastObject && actualLastObject->IsAssumedShape()) { |
| messages.Say( |
| "Element of assumed-shape array may not be associated with a %s array"_err_en_US, |
| dummyName); |
| } |
| } |
| 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 |
| const char *reason{nullptr}; |
| if (dummy.intent == common::Intent::Out) { |
| reason = "INTENT(OUT)"; |
| } else if (dummy.intent == common::Intent::InOut) { |
| reason = "INTENT(IN OUT)"; |
| } else if (dummyIsAsynchronous) { |
| reason = "ASYNCHRONOUS"; |
| } else if (dummyIsVolatile) { |
| reason = "VOLATILE"; |
| } |
| if (reason && scope) { |
| bool vectorSubscriptIsOk{isElemental || dummyIsValue}; // 15.5.2.4(21) |
| if (auto why{WhyNotModifiable( |
| messages.at(), actual, *scope, vectorSubscriptIsOk)}) { |
| if (auto *msg{messages.Say( |
| "Actual argument associated with %s %s must be definable"_err_en_US, // C1158 |
| reason, dummyName)}) { |
| msg->Attach(*why); |
| } |
| } |
| } |
| |
| // Cases when temporaries might be needed but must not be permitted. |
| bool dummyIsPointer{ |
| dummy.attrs.test(characteristics::DummyDataObject::Attr::Pointer)}; |
| bool dummyIsContiguous{ |
| dummy.attrs.test(characteristics::DummyDataObject::Attr::Contiguous)}; |
| bool actualIsContiguous{IsSimplyContiguous(actual, context)}; |
| bool dummyIsAssumedShape{dummy.type.attrs().test( |
| characteristics::TypeAndShape::Attr::AssumedShape)}; |
| 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 && !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 %s"_err_en_US, |
| dummyName); |
| } |
| } |
| } |
| |
| // 15.5.2.6 -- dummy is ALLOCATABLE |
| bool dummyIsAllocatable{ |
| dummy.attrs.test(characteristics::DummyDataObject::Attr::Allocatable)}; |
| bool actualIsAllocatable{ |
| actualLastSymbol && IsAllocatable(*actualLastSymbol)}; |
| if (dummyIsAllocatable) { |
| if (!actualIsAllocatable) { |
| messages.Say( |
| "ALLOCATABLE %s must be associated with an ALLOCATABLE actual argument"_err_en_US, |
| dummyName); |
| } |
| if (actualIsAllocatable && 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); |
| } |
| 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 (dummyIsContiguous && !actualIsContiguous) { |
| messages.Say( |
| "Actual argument associated with CONTIGUOUS POINTER %s must be simply contiguous"_err_en_US, |
| dummyName); |
| } |
| if (!actualIsPointer) { |
| if (dummy.intent == common::Intent::In) { |
| semantics::CheckPointerAssignment( |
| context, parser::CharBlock{}, dummyName, dummy, actual); |
| } else { |
| 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 |
| if ((actualIsPointer && dummyIsPointer) || |
| (actualIsAllocatable && dummyIsAllocatable)) { |
| bool actualIsUnlimited{actualType.type().IsUnlimitedPolymorphic()}; |
| bool dummyIsUnlimited{dummy.type.type().IsUnlimitedPolymorphic()}; |
| if (actualIsUnlimited != dummyIsUnlimited) { |
| if (typesCompatible) { |
| 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 (dummy.intent == common::Intent::In && typesCompatible) { |
| // extension: allow with warning, rule is only relevant for definables |
| messages.Say( |
| "If a POINTER or ALLOCATABLE dummy or actual argument is polymorphic, both should be so"_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 && typesCompatible) { |
| if (!actualType.type().IsTkCompatibleWith(dummy.type.type())) { |
| if (dummy.intent == common::Intent::In) { |
| // extension: allow with warning, rule is only relevant for definables |
| messages.Say( |
| "POINTER or ALLOCATABLE dummy and actual arguments should have the same declared type and kind"_en_US); |
| } else { |
| messages.Say( |
| "POINTER or ALLOCATABLE dummy and actual arguments must have the same declared type and kind"_err_en_US); |
| } |
| } |
| if (const auto *derived{ |
| evaluate::GetDerivedTypeSpec(actualType.type())}) { |
| if (!DefersSameTypeParameters( |
| *derived, *evaluate::GetDerivedTypeSpec(dummy.type.type()))) { |
| 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 == dummy.type.Rank() && !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); |
| } |
| } |
| } |
| } |
| |
| static void CheckProcedureArg(evaluate::ActualArgument &arg, |
| const characteristics::DummyProcedure &proc, const std::string &dummyName, |
| evaluate::FoldingContext &context) { |
| parser::ContextualMessages &messages{context.messages()}; |
| const characteristics::Procedure &interface{proc.procedure.value()}; |
| if (const auto *expr{arg.UnwrapExpr()}) { |
| bool dummyIsPointer{ |
| proc.attrs.test(characteristics::DummyProcedure::Attr::Pointer)}; |
| const auto *argProcDesignator{ |
| std::get_if<evaluate::ProcedureDesignator>(&expr->u)}; |
| const auto *argProcSymbol{ |
| argProcDesignator ? argProcDesignator->GetSymbol() : nullptr}; |
| if (auto argChars{characteristics::DummyArgument::FromActual( |
| "actual argument", *expr, context)}) { |
| 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.IsPure()) { |
| // 15.5.2.9(1): if dummy is not pure, actual need not be. |
| argInterface.attrs.reset(characteristics::Procedure::Attr::Pure); |
| } |
| if (interface.HasExplicitInterface()) { |
| if (interface != argInterface) { |
| // 15.5.2.9(1): Explicit interfaces must match |
| if (argInterface.HasExplicitInterface()) { |
| messages.Say( |
| "Actual procedure argument has interface incompatible with %s"_err_en_US, |
| dummyName); |
| return; |
| } else { |
| messages.Say( |
| "Actual procedure argument has an implicit interface " |
| "which is not known to be compatible with %s which has an " |
| "explicit interface"_en_US, |
| dummyName); |
| } |
| } |
| } 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()) { |
| if (interface.functionResult != argInterface.functionResult) { |
| messages.Say( |
| "Actual argument function associated with procedure %s has incompatible result type"_err_en_US, |
| dummyName); |
| } |
| } 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) { |
| 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 (interface.HasExplicitInterface() && dummyIsPointer && |
| proc.intent != common::Intent::In) { |
| const Symbol *last{GetLastSymbol(*expr)}; |
| if (!(last && IsProcedurePointer(*last))) { |
| // 15.5.2.9(5) -- dummy procedure POINTER |
| // Interface compatibility has already been checked above by comparison. |
| 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); |
| } |
| } |
| |
| static void CheckExplicitInterfaceArg(evaluate::ActualArgument &arg, |
| const characteristics::DummyArgument &dummy, |
| const characteristics::Procedure &proc, evaluate::FoldingContext &context, |
| const Scope *scope, const evaluate::SpecificIntrinsic *intrinsic) { |
| auto &messages{context.messages()}; |
| std::string dummyName{"dummy argument"}; |
| if (!dummy.name.empty()) { |
| dummyName += " '"s + parser::ToLowerCaseLetters(dummy.name) + "='"; |
| } |
| std::visit( |
| common::visitors{ |
| [&](const characteristics::DummyDataObject &object) { |
| if (auto *expr{arg.UnwrapExpr()}) { |
| if (auto type{characteristics::TypeAndShape::Characterize( |
| *expr, context)}) { |
| arg.set_dummyIntent(object.intent); |
| bool isElemental{object.type.Rank() == 0 && proc.IsElemental()}; |
| CheckExplicitDataArg(object, dummyName, *expr, *type, |
| isElemental, context, scope, intrinsic); |
| } else if (object.type.type().IsTypelessIntrinsicArgument() && |
| IsBOZLiteral(*expr)) { |
| // ok |
| } else if (object.type.type().IsTypelessIntrinsicArgument() && |
| evaluate::IsNullPointer(*expr)) { |
| // ok, ASSOCIATED(NULL()) |
| } else if (object.attrs.test( |
| characteristics::DummyDataObject::Attr::Pointer) && |
| evaluate::IsNullPointer(*expr)) { |
| // ok, FOO(NULL()) |
| } 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 (const auto *details{ |
| assumed.detailsIf<ObjectEntityDetails>()}) { |
| if (!(details->IsAssumedShape() || details->IsAssumedRank())) { |
| messages.Say( // C711 |
| "Assumed-type '%s' must be either assumed shape or assumed rank to be associated with assumed-type %s"_err_en_US, |
| assumed.name(), dummyName); |
| } |
| } |
| } |
| }, |
| [&](const characteristics::DummyProcedure &proc) { |
| CheckProcedureArg(arg, proc, dummyName, context); |
| }, |
| [&](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; |
| for (auto &x : actuals) { |
| if (x && 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(); |
| } |
| } |
| 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()); |
| } |
| } |
| } |
| |
| // The actual argument arrays 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}; |
| 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; |
| } |
| } |
| } |
| } |
| } |
| } |
| return true; |
| } |
| |
| static parser::Messages CheckExplicitInterface( |
| const characteristics::Procedure &proc, evaluate::ActualArguments &actuals, |
| const evaluate::FoldingContext &context, const Scope *scope, |
| const evaluate::SpecificIntrinsic *intrinsic) { |
| parser::Messages buffer; |
| parser::ContextualMessages messages{context.messages().at(), &buffer}; |
| RearrangeArguments(proc, actuals, messages); |
| if (buffer.empty()) { |
| int index{0}; |
| evaluate::FoldingContext localContext{context, messages}; |
| for (auto &actual : actuals) { |
| const auto &dummy{proc.dummyArguments.at(index++)}; |
| if (actual) { |
| CheckExplicitInterfaceArg( |
| *actual, dummy, proc, localContext, scope, intrinsic); |
| } 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, localContext); |
| } |
| } |
| return buffer; |
| } |
| |
| parser::Messages CheckExplicitInterface(const characteristics::Procedure &proc, |
| evaluate::ActualArguments &actuals, const evaluate::FoldingContext &context, |
| const Scope &scope, const evaluate::SpecificIntrinsic *intrinsic) { |
| return CheckExplicitInterface(proc, actuals, context, &scope, intrinsic); |
| } |
| |
| bool CheckInterfaceForGeneric(const characteristics::Procedure &proc, |
| evaluate::ActualArguments &actuals, |
| const evaluate::FoldingContext &context) { |
| return !CheckExplicitInterface(proc, actuals, context, nullptr, nullptr) |
| .AnyFatalError(); |
| } |
| |
| void CheckArguments(const characteristics::Procedure &proc, |
| evaluate::ActualArguments &actuals, evaluate::FoldingContext &context, |
| const Scope &scope, bool treatingExternalAsImplicit, |
| const evaluate::SpecificIntrinsic *intrinsic) { |
| bool explicitInterface{proc.HasExplicitInterface()}; |
| if (explicitInterface) { |
| auto buffer{ |
| CheckExplicitInterface(proc, actuals, context, scope, intrinsic)}; |
| if (treatingExternalAsImplicit && !buffer.empty()) { |
| if (auto *msg{context.messages().Say( |
| "Warning: if the procedure's interface were explicit, this reference would be in error:"_en_US)}) { |
| buffer.AttachTo(*msg); |
| } |
| } |
| if (auto *msgs{context.messages().messages()}) { |
| msgs->Merge(std::move(buffer)); |
| } |
| } |
| if (!explicitInterface || treatingExternalAsImplicit) { |
| for (auto &actual : actuals) { |
| if (actual) { |
| CheckImplicitInterfaceArg(*actual, context.messages()); |
| } |
| } |
| } |
| } |
| } // namespace Fortran::semantics |
