9299bde9e3
Per 15.5.2.5 p2, when both a dummy data object and its associated actual argument are ALLOCATABLE or POINTER, there are rules requiring that both be unlimited polymorphic if either is, and that both be polymorphic if either is. The justifications for the first restriction is that the called procedure might change the type of an unlimited polymorphic dummy argument, but as this cannot occur for a dummy argument with INTENT(IN), we can relax the check to an optional portability warning. The justification for the second restriction is that some implementations would have to create a type descriptor to associate a monomorphic allocatable/pointer actual argument with a polymorphic dummy argument, and that doesn't apply to f18 since we use descriptors for them anyways. Relaxing these needless checks allows more library procedures to use "class(*), dimension(..), pointer, intent(in)" dummy arguments in explicit interfaces. Differential Revision: https://reviews.llvm.org/D151941
1413 lines
60 KiB
C++
1413 lines
60 KiB
C++
//===-- 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/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 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);
|
|
} 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)}) {
|
|
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());
|
|
}
|
|
}
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
// 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) {
|
|
if (dummy.type.type().category() == TypeCategory::Character &&
|
|
actualType.type().category() == TypeCategory::Character &&
|
|
dummy.type.type().kind() == actualType.type().kind()) {
|
|
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 && *actualLength != *dummyLength) {
|
|
if (dummy.attrs.test(
|
|
characteristics::DummyDataObject::Attr::Allocatable) ||
|
|
dummy.attrs.test(characteristics::DummyDataObject::Attr::Pointer) ||
|
|
dummy.type.attrs().test(
|
|
characteristics::TypeAndShape::Attr::AssumedRank) ||
|
|
dummy.type.attrs().test(
|
|
characteristics::TypeAndShape::Attr::AssumedShape)) {
|
|
// See 15.5.2.4 paragraph 4., 15.5.2.5.
|
|
messages.Say(
|
|
"Actual argument variable length '%jd' does not match the expected length '%jd'"_err_en_US,
|
|
*actualLength, *dummyLength);
|
|
} else if (*actualLength < *dummyLength) {
|
|
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) {
|
|
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)"_port_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,
|
|
SemanticsContext &context, evaluate::FoldingContext &foldingContext,
|
|
const Scope *scope, const evaluate::SpecificIntrinsic *intrinsic,
|
|
bool allowActualArgumentConversions,
|
|
const characteristics::Procedure &procedure) {
|
|
|
|
// Basic type & rank checking
|
|
parser::ContextualMessages &messages{foldingContext.messages()};
|
|
CheckCharacterActual(actual, dummy, actualType, context, messages);
|
|
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);
|
|
}
|
|
bool typesCompatible{typesCompatibleWithIgnoreTKR ||
|
|
dummy.type.type().IsTkCompatibleWith(actualType.type())};
|
|
if (!typesCompatible && dummy.type.Rank() == 0 &&
|
|
allowActualArgumentConversions) {
|
|
// Extension: pass Hollerith literal to scalar as if it had been BOZ
|
|
if (auto converted{evaluate::HollerithToBOZ(
|
|
foldingContext, actual, dummy.type.type())}) {
|
|
messages.Say(
|
|
"passing Hollerith or character literal as if it were BOZ"_port_en_US);
|
|
actual = *converted;
|
|
actualType.type() = dummy.type.type();
|
|
typesCompatible = true;
|
|
}
|
|
}
|
|
if (typesCompatible) {
|
|
if (isElemental) {
|
|
} else if (dummy.type.attrs().test(
|
|
characteristics::TypeAndShape::Attr::AssumedRank)) {
|
|
} else if (dummy.ignoreTKR.test(common::IgnoreTKR::Rank)) {
|
|
} else if (dummy.type.Rank() > 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)};
|
|
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());
|
|
}
|
|
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{evaluate::GetRank(actualType.shape())};
|
|
bool actualIsPointer{evaluate::IsObjectPointer(actual, foldingContext)};
|
|
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 &&
|
|
!dummyIsAllocatableOrPointer) {
|
|
// 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);
|
|
}
|
|
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)) {
|
|
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 (actualIsArrayElement && actualLastSymbol &&
|
|
IsPointer(*actualLastSymbol)) {
|
|
messages.Say(
|
|
"Element of pointer array may not be associated with a %s array"_err_en_US,
|
|
dummyName);
|
|
}
|
|
if (actualLastSymbol && IsAssumedShape(*actualLastSymbol)) {
|
|
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)";
|
|
}
|
|
if (reason && scope) {
|
|
// Problems with polymorphism are caught in the callee's definition.
|
|
DefinabilityFlags flags{DefinabilityFlag::PolymorphicOkInPure};
|
|
if (isElemental || dummyIsValue) { // 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
|
|
bool actualIsVariable{evaluate::IsVariable(actual)};
|
|
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 && !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 actualIsAllocatable{evaluate::IsAllocatableDesignator(actual)};
|
|
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 (actualIsPointer || dummy.intent == common::Intent::In) {
|
|
if (scope) {
|
|
semantics::CheckPointerAssignment(
|
|
context, messages.at(), dummyName, dummy, actual, *scope);
|
|
}
|
|
} 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 == 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);
|
|
}
|
|
}
|
|
}
|
|
|
|
// NULL(MOLD=) checking for non-intrinsic procedures
|
|
bool dummyIsOptional{
|
|
dummy.attrs.test(characteristics::DummyDataObject::Attr::Optional)};
|
|
bool actualIsNull{evaluate::IsNullPointer(actual)};
|
|
if (!intrinsic && !dummyIsPointer && !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
|
|
if (!intrinsic &&
|
|
!dummy.attrs.test(characteristics::DummyDataObject::Attr::Value)) {
|
|
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));
|
|
}
|
|
}
|
|
}
|
|
|
|
static void CheckProcedureArg(evaluate::ActualArgument &arg,
|
|
const characteristics::Procedure &proc,
|
|
const characteristics::DummyProcedure &dummy, const std::string &dummyName,
|
|
SemanticsContext &context) {
|
|
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>()) {
|
|
evaluate::SayWithDeclaration(messages, *argProcSymbol,
|
|
"Procedure binding '%s' passed as an actual argument"_port_en_US,
|
|
argProcSymbol->name());
|
|
}
|
|
}
|
|
if (auto argChars{characteristics::DummyArgument::FromActual(
|
|
"actual argument", *expr, foldingContext)}) {
|
|
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;
|
|
if (!interface.IsCompatibleWith(argInterface, &whyNot)) {
|
|
// 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 { // 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) {
|
|
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, proc);
|
|
} else if (object.type.type().IsTypelessIntrinsicArgument() &&
|
|
IsBOZLiteral(*expr)) {
|
|
// ok
|
|
} else if (object.type.type().IsTypelessIntrinsicArgument() &&
|
|
evaluate::IsNullObjectPointer(*expr)) {
|
|
// ok, ASSOCIATED(NULL())
|
|
} else if ((object.attrs.test(characteristics::DummyDataObject::
|
|
Attr::Pointer) ||
|
|
object.attrs.test(characteristics::
|
|
DummyDataObject::Attr::Optional)) &&
|
|
evaluate::IsNullObjectPointer(*expr)) {
|
|
// ok, FOO(NULL())
|
|
} else if (object.attrs.test(characteristics::DummyDataObject::
|
|
Attr::Allocatable) &&
|
|
evaluate::IsNullPointer(*expr)) {
|
|
// Unsupported extension that more or less naturally falls
|
|
// out of other Fortran implementations that pass separate
|
|
// base address and descriptor address physical arguments
|
|
messages.Say(
|
|
"Null actual argument '%s' may not be associated with allocatable %s"_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(evaluate::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);
|
|
}
|
|
},
|
|
[&](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,
|
|
evaluate::FoldingContext &context, const Scope *scope) {
|
|
bool ok{true};
|
|
if (arguments.size() < 2) {
|
|
return;
|
|
}
|
|
if (const auto &pointerArg{arguments[0]}) {
|
|
if (const auto *pointerExpr{pointerArg->UnwrapExpr()}) {
|
|
const Symbol *pointerSymbol{GetLastSymbol(*pointerExpr)};
|
|
if (pointerSymbol && !IsPointer(*pointerSymbol)) {
|
|
evaluate::AttachDeclaration(
|
|
context.messages().Say(pointerArg->sourceLocation(),
|
|
"POINTER= argument of ASSOCIATED() must be a POINTER"_err_en_US),
|
|
*pointerSymbol);
|
|
return;
|
|
}
|
|
if (const auto &targetArg{arguments[1]}) {
|
|
// The standard requires that the POINTER= argument be a valid LHS for
|
|
// a pointer assignment when the TARGET= argument is present. This,
|
|
// perhaps unintentionally, excludes function results, including NULL(),
|
|
// from being used there, as well as INTENT(IN) dummy pointers.
|
|
// Allow this usage as a benign extension with a portability warning.
|
|
if (!evaluate::ExtractDataRef(*pointerExpr) &&
|
|
!evaluate::IsProcedurePointer(*pointerExpr)) {
|
|
context.messages().Say(pointerArg->sourceLocation(),
|
|
"POINTER= argument of ASSOCIATED() should be a pointer"_port_en_US);
|
|
} else if (scope) {
|
|
if (auto whyNot{WhyNotDefinable(pointerArg->sourceLocation().value_or(
|
|
context.messages().at()),
|
|
*scope,
|
|
DefinabilityFlags{DefinabilityFlag::PointerDefinition},
|
|
*pointerExpr)}) {
|
|
if (auto *msg{context.messages().Say(pointerArg->sourceLocation(),
|
|
"POINTER= argument of ASSOCIATED() would not be a valid left-hand side of a pointer assignment statement"_port_en_US)}) {
|
|
msg->Attach(std::move(*whyNot));
|
|
}
|
|
}
|
|
}
|
|
const auto *targetExpr{targetArg->UnwrapExpr()};
|
|
if (targetExpr && pointerSymbol) {
|
|
std::optional<characteristics::Procedure> pointerProc, targetProc;
|
|
const auto *targetProcDesignator{
|
|
evaluate::UnwrapExpr<evaluate::ProcedureDesignator>(*targetExpr)};
|
|
const Symbol *targetSymbol{GetLastSymbol(*targetExpr)};
|
|
bool isCall{false};
|
|
std::string targetName;
|
|
if (const auto *targetProcRef{// target is a function call
|
|
std::get_if<evaluate::ProcedureRef>(&targetExpr->u)}) {
|
|
if (auto targetRefedChars{characteristics::Procedure::Characterize(
|
|
*targetProcRef, context)}) {
|
|
targetProc = *targetRefedChars;
|
|
targetName = targetProcRef->proc().GetName() + "()";
|
|
isCall = true;
|
|
}
|
|
} else if (targetProcDesignator) {
|
|
targetProc = characteristics::Procedure::Characterize(
|
|
*targetProcDesignator, context);
|
|
targetName = targetProcDesignator->GetName();
|
|
} else if (targetSymbol) {
|
|
if (IsProcedure(*targetSymbol)) {
|
|
// proc that's not a call
|
|
targetProc = characteristics::Procedure::Characterize(
|
|
*targetSymbol, context);
|
|
}
|
|
targetName = targetSymbol->name().ToString();
|
|
}
|
|
if (pointerSymbol && IsProcedure(*pointerSymbol)) {
|
|
pointerProc = characteristics::Procedure::Characterize(
|
|
*pointerSymbol, context);
|
|
}
|
|
if (pointerProc) {
|
|
if (targetProc) {
|
|
// procedure pointer and procedure target
|
|
std::string whyNot;
|
|
const evaluate::SpecificIntrinsic *specificIntrinsic{nullptr};
|
|
if (targetProcDesignator) {
|
|
specificIntrinsic =
|
|
targetProcDesignator->GetSpecificIntrinsic();
|
|
}
|
|
if (std::optional<parser::MessageFixedText> msg{
|
|
CheckProcCompatibility(isCall, pointerProc, &*targetProc,
|
|
specificIntrinsic, whyNot)}) {
|
|
msg->set_severity(parser::Severity::Warning);
|
|
evaluate::AttachDeclaration(
|
|
context.messages().Say(std::move(*msg),
|
|
"pointer '" + pointerSymbol->name().ToString() + "'",
|
|
targetName, whyNot),
|
|
*pointerSymbol);
|
|
}
|
|
} else if (!IsNullProcedurePointer(*targetExpr)) {
|
|
// procedure pointer and object target
|
|
evaluate::AttachDeclaration(
|
|
context.messages().Say(
|
|
"POINTER= argument '%s' is a procedure pointer but the TARGET= argument '%s' is not a procedure or procedure pointer"_err_en_US,
|
|
pointerSymbol->name(), targetName),
|
|
*pointerSymbol);
|
|
}
|
|
} else if (targetProc) {
|
|
// object pointer and procedure target
|
|
evaluate::AttachDeclaration(
|
|
context.messages().Say(
|
|
"POINTER= argument '%s' is an object pointer but the TARGET= argument '%s' is a procedure designator"_err_en_US,
|
|
pointerSymbol->name(), targetName),
|
|
*pointerSymbol);
|
|
} else if (targetSymbol) {
|
|
// object pointer and target
|
|
SymbolVector symbols{GetSymbolVector(*targetExpr)};
|
|
CHECK(!symbols.empty());
|
|
if (!evaluate::GetLastTarget(symbols)) {
|
|
parser::Message *msg{context.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)) {
|
|
context.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 {
|
|
// No arguments to ASSOCIATED()
|
|
ok = false;
|
|
}
|
|
if (!ok) {
|
|
context.messages().Say(
|
|
"Arguments of ASSOCIATED() must be a POINTER and an optional valid target"_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) &&
|
|
IsAllocatableOrPointer(*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.foldingContext(), scope);
|
|
} 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) {
|
|
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);
|
|
} 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)
|
|
.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-%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);
|
|
}
|
|
return false;
|
|
}
|
|
|
|
bool CheckArguments(const characteristics::Procedure &proc,
|
|
evaluate::ActualArguments &actuals, SemanticsContext &context,
|
|
const Scope &scope, bool treatingExternalAsImplicit,
|
|
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, true)};
|
|
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
|