Doomhowl-Interactive/llvm-project
0
0
Fork 0
Code Issues Pull Requests Actions 5 Packages Projects Releases Wiki Activity
Files
main
llvm-project/flang/lib/Semantics/check-call.cpp
Peter Klausler c5aefc7753 [flang] Downgrade an overly strict error to a warning (#187524) 
Fortran allows a PURE subroutine to have dummy argument with INTENT(IN
OUT). An actual argument that is associated with an INTENT(IN OUT) dummy
argument must be definable. Consequently, there's a hole in the language
that allows a PURE subroutine to modify arbitrary global state: the
argument could have a derived type with an impure FINAL subroutine, and
that FINAL subroutine could be invoked by an assignment to the dummy
argument. I consider this to be a mistake in the language design.

So the compiler was reporting this case as an error, although it is
indeed conforming usage, and not flagged by any other compiler.
Unfortunately, somebody has a code that needs this usage to be accepted,
because (I presume) they can't modify the dummy argument to be
INTENT(IN).

Consequently, we'll need to allow this usage. But it will elicit a
warning, and the warning is on by default.
2026-03-19 15:27:01 -05:00

2539 lines
115 KiB
C++
Raw Permalink Blame History

//===-- 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 "llvm/ADT/StringSet.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, SemanticsContext &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);
}
auto type{arg.GetType()};
if (type) {
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 (arg.isPercentVal() &&
(!type || !type->IsLengthlessIntrinsicType() || arg.Rank() != 0)) {
messages.Say(
"%VAL argument must be a scalar numeric or logical expression"_err_en_US);
}
if (const auto *expr{arg.UnwrapExpr()}) {
if (const Symbol *base{GetFirstSymbol(*expr)}) {
context.NoteDefinedSymbol(GetAssociationRoot(*base));
}
if (IsBOZLiteral(*expr)) {
messages.Say("BOZ argument %s requires an explicit interface"_err_en_US,
expr->AsFortran());
} else if (evaluate::IsNullPointerOrAllocatable(expr)) {
messages.Say(
"Null pointer argument '%s' requires an explicit interface"_err_en_US,
expr->AsFortran());
} else if (auto named{evaluate::ExtractNamedEntity(*expr)}) {
const Symbol &resolved{ResolveAssociations(named->GetLastSymbol())};
if (IsAssumedRank(resolved)) {
messages.Say(
"Assumed rank argument '%s' requires an explicit interface"_err_en_US,
expr->AsFortran());
}
const Symbol &symbol{GetAssociationRoot(resolved)};
if (symbol.attrs().test(Attr::ASYNCHRONOUS)) {
messages.Say(
"ASYNCHRONOUS argument '%s' requires an explicit interface"_err_en_US,
expr->AsFortran());
}
if (symbol.attrs().test(Attr::VOLATILE)) {
messages.Say(
"VOLATILE argument '%s' requires an explicit interface"_err_en_US,
expr->AsFortran());
}
if (const auto *object{symbol.detailsIf<ObjectEntityDetails>()}) {
if (object->cudaDataAttr()) {
messages.Warn(/*inModuleFile=*/false, context.languageFeatures(),
common::UsageWarning::CUDAUsage,
"Actual argument '%s' with CUDA data attributes should be passed via an explicit interface"_warn_en_US,
expr->AsFortran());
}
}
} else if (auto argChars{characteristics::DummyArgument::FromActual(
"actual argument", *expr, context.foldingContext(),
/*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.attrs.test(characteristics::DummyDataObject::Attr::Allocatable) &&
!dummy.attrs.test(characteristics::DummyDataObject::Attr::Pointer) &&
dummy.type.corank() == 0;
}
// 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)) {
bool actualIsAssumedRank{IsAssumedRank(actual)};
if (actualIsAssumedRank &&
!dummy.type.attrs().test(
characteristics::TypeAndShape::Attr::AssumedRank)) {
if (!context.languageFeatures().IsEnabled(
common::LanguageFeature::AssumedRankPassedToNonAssumedRank)) {
messages.Say(
"Assumed-rank character array may not be associated with a dummy argument that is not assumed-rank"_err_en_US);
} else {
context.Warn(messages,
common::LanguageFeature::AssumedRankPassedToNonAssumedRank,
messages.at(),
"Assumed-rank character array should not be associated with a dummy argument that is not assumed-rank"_port_en_US);
}
}
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(dummy.type.shape())))}) {
auto dummyChars{*dummySize * *dummyLength};
if (actualType.Rank() == 0 && !actualIsAssumedRank) {
evaluate::DesignatorFolder folder{
context.foldingContext(), /*getLastComponent=*/true};
if (auto actualOffset{folder.FoldDesignator(actual)}) {
std::int64_t actualChars{*actualLength};
if (IsAllocatableOrPointer(actualOffset->symbol())) {
// don't use actualOffset->symbol().size()!
} else if (static_cast<std::size_t>(actualOffset->offset()) >=
actualOffset->symbol().size() ||
!evaluate::IsContiguous(
actualOffset->symbol(), foldingContext)
.value_or(false)) {
// 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) {
if (extentErrors) {
messages.Say(
"Actual argument has fewer characters remaining in storage sequence (%jd) than %s (%jd)"_err_en_US,
static_cast<std::intmax_t>(actualChars), dummyName,
static_cast<std::intmax_t>(dummyChars));
} else {
context.Warn(messages,
common::UsageWarning::ShortCharacterActual,
"Actual argument has fewer characters remaining in storage sequence (%jd) than %s (%jd)"_warn_en_US,
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(actualType.shape())))};
actualSize &&
*actualSize * *actualLength < *dummySize * *dummyLength) {
if (extentErrors) {
messages.Say(
"Actual argument array has fewer characters (%jd) than %s array (%jd)"_err_en_US,
static_cast<std::intmax_t>(*actualSize * *actualLength),
dummyName,
static_cast<std::intmax_t>(*dummySize * *dummyLength));
} else {
context.Warn(messages,
common::UsageWarning::ShortCharacterActual,
"Actual argument array has fewer characters (%jd) than %s array (%jd)"_warn_en_US,
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 (isVariable) {
context.Warn(messages, common::UsageWarning::ShortCharacterActual,
"Actual argument variable length '%jd' is less than expected length '%jd'"_warn_en_US,
*actualLength, *dummyLength);
} else {
context.Warn(messages, common::UsageWarning::ShortCharacterActual,
"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() &&
dummyType.Rank() == 0 && actualType.Rank() == 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)) {
messages.Say(
"Actual argument scalar expression of type INTEGER(%d) cannot be implicitly converted to smaller dummy argument type INTEGER(%d)"_err_en_US,
actualType.type().kind(), dummyType.type().kind());
} else {
semanticsContext.Warn(messages,
common::LanguageFeature::ActualIntegerConvertedToSmallerKind,
"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;
}
}
// 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) {
if (actual && 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;
}
// List of intrinsics that are skipped when checking for device actual
// arguments.
static const llvm::StringSet<> cudaSkippedIntrinsics = {"__builtin_c_devloc",
"__builtin_c_f_pointer", "__builtin_c_loc", "__builtin_show_descriptor",
"allocated", "associated", "kind", "lbound", "loc", "present", "shape",
"size", "sizeof", "ubound"};
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,
const evaluate::ActualArgument &arg,
const characteristics::DummyArgument &dummyArg) {
// 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()};
// Used to issue a general warning when we don't generate a specific warning
// or error for this case.
bool volatileOrAsyncNeedsTempDiagnosticIssued{false};
if (typesCompatible) {
if (const auto *constantChar{
evaluate::UnwrapConstantValue<evaluate::Ascii>(actual)};
constantChar && constantChar->wasHollerith() &&
dummy.type.type().IsUnlimitedPolymorphic()) {
foldingContext.Warn(common::LanguageFeature::HollerithPolymorphic,
"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())}) {
foldingContext.Warn(common::LanguageFeature::HollerithOrCharacterAsBOZ,
"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)};
bool actualIsAssumedSize{actualType.attrs().test(
characteristics::TypeAndShape::Attr::AssumedSize)};
bool actualIsAssumedRank{IsAssumedRank(actual)};
bool actualIsPointer{evaluate::IsObjectPointer(actual)};
bool actualIsAllocatable{evaluate::IsAllocatableDesignator(actual)};
bool actualMayBeAssumedSize{actualIsAssumedSize ||
(actualIsAssumedRank && !actualIsPointer && !actualIsAllocatable)};
bool actualIsPolymorphic{actualType.type().IsPolymorphic()};
const auto *actualDerived{evaluate::GetDerivedTypeSpec(actualType.type())};
if (typesCompatible) {
if (isElemental) {
} else if (dummyIsAssumedRank) {
if (actualMayBeAssumedSize && dummy.intent == common::Intent::Out) {
// An INTENT(OUT) dummy might be a no-op at run time
bool dummyHasSignificantIntentOut{actualIsPolymorphic ||
(actualDerived &&
(actualDerived->HasDefaultInitialization(
/*ignoreAllocatable=*/false, /*ignorePointer=*/true) ||
actualDerived->HasDestruction()))};
const char *actualDesc{
actualIsAssumedSize ? "Assumed-size" : "Assumed-rank"};
if (dummyHasSignificantIntentOut) {
messages.Say(
"%s actual argument may not be associated with INTENT(OUT) assumed-rank dummy argument requiring finalization, destruction, or initialization"_err_en_US,
actualDesc);
} else {
foldingContext.Warn(common::UsageWarning::Portability, messages.at(),
"%s actual argument should not be associated with INTENT(OUT) assumed-rank dummy argument"_port_en_US,
actualDesc);
}
}
} else if (actualIsAssumedRank) {
if (actualType.type().category() != TypeCategory::Character &&
!intrinsic) {
// A more specific message will have already been emitted for
// assumed-rank argument that's CHARACTER, a callee that's ELEMENTAL,
// or an intrinsic procedure that can't handle assumed-rank.
if (!context.languageFeatures().IsEnabled(
common::LanguageFeature::AssumedRankPassedToNonAssumedRank)) {
messages.Say(
"Assumed-rank actual argument may not be associated with a %s that is not also assumed-rank"_err_en_US,
dummyName);
} else {
foldingContext.Warn(
common::LanguageFeature::AssumedRankPassedToNonAssumedRank,
"Assumed-rank actual argument should not be associated with a %s that is not also assumed-rank"_port_en_US,
dummyName);
}
}
} 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 if (dummy.type.shape() && actualType.shape()) {
// 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());
}
auto actualCoarrayRef{ExtractCoarrayRef(actual)};
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)};
bool dummyIsPolymorphic{dummy.type.type().IsPolymorphic()};
if (actualIsPolymorphic && dummyIsPolymorphic &&
actualCoarrayRef) { // 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 (actualDerived && !actualDerived->IsVectorType()) {
if (dummy.type.type().IsAssumedType()) {
if (!actualDerived->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(*actualDerived, [](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(*actualDerived)};
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, actualDerived->typeSymbol().name(), name)}) {
msg->Attach(name, "FINAL subroutine '%s' in derived type '%s'"_en_US,
name, actualDerived->typeSymbol().name());
}
}
}
if (actualCoarrayRef) {
if (dummy.intent != common::Intent::In && !dummyIsValue) {
if (auto bad{FindAllocatableUltimateComponent(
*actualDerived)}) { // 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);
}
}
const Symbol &coarray{actualCoarrayRef->GetLastSymbol()};
if (const DeclTypeSpec * type{coarray.GetType()}) { // C1537
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(*actualDerived)}) {
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);
}
int actualRank{actualType.Rank()};
if (dummyIsValue && dummyRank == 0 &&
dummy.ignoreTKR.test(common::IgnoreTKR::Rank) && actualRank > 0) {
messages.Say(
"Array actual argument may not be associated with IGNORE_TKR(R) scalar %s with VALUE attribute"_err_en_US,
dummyName);
} else 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 (dummyIsAssumedSize && dummy.type.type().IsAssumedType() &&
actualRank == 0 && !actualIsAssumedRank) {
// F'2023 15.5.2.5 p14 third bullet allows a scalar actual
// argument to associate with a TYPE(*) assumed-size dummy
foldingContext.Warn(common::UsageWarning::AssumedTypeSizeDummy,
"A scalar actual argument for an assumed-size TYPE(*) dummy is not portable"_port_en_US);
} 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 (actualCoarrayRef) {
basicError = true;
messages.Say(
"Coindexed scalar actual argument must be associated with a scalar %s"_err_en_US,
dummyName);
}
bool actualIsArrayElement{IsArrayElement(actual) != nullptr};
bool actualIsCKindCharacter{
actualType.type().category() == TypeCategory::Character &&
actualType.type().kind() == 1};
if (!actualIsCKindCharacter) {
if (!actualIsArrayElement && !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);
}
bool isOkBecauseContiguous{
context.IsEnabled(
common::LanguageFeature::ContiguousOkForSeqAssociation) &&
actualLastSymbol &&
evaluate::IsContiguous(*actualLastSymbol, foldingContext)
.value_or(false)};
if (actualIsArrayElement && actualLastSymbol &&
!dummy.ignoreTKR.test(common::IgnoreTKR::Contiguous)) {
if (IsPointer(*actualLastSymbol)) {
if (isOkBecauseContiguous) {
foldingContext.Warn(
common::LanguageFeature::ContiguousOkForSeqAssociation,
"Element of contiguous pointer array is accepted for storage sequence association"_port_en_US);
} else {
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)) {
if (isOkBecauseContiguous) {
foldingContext.Warn(
common::LanguageFeature::ContiguousOkForSeqAssociation,
"Element of contiguous assumed-shape array is accepted for storage sequence association"_port_en_US);
} else {
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(dummy.type.shape())))}) {
if (actualIsAssumedRank) {
if (!context.languageFeatures().IsEnabled(
common::LanguageFeature::AssumedRankPassedToNonAssumedRank)) {
messages.Say(
"Assumed-rank array may not be associated with a dummy argument that is not assumed-rank"_err_en_US);
} else {
foldingContext.Warn(
common::LanguageFeature::AssumedRankPassedToNonAssumedRank,
"Assumed-rank array should not be associated with a dummy argument that is not assumed-rank"_port_en_US);
}
} else if (actualRank == 0) {
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 (IsAllocatableOrPointer(actualOffset->symbol())) {
// don't use actualOffset->symbol().size()!
} else if (static_cast<std::size_t>(actualOffset->offset()) >=
actualOffset->symbol().size() ||
!evaluate::IsContiguous(
actualOffset->symbol(), foldingContext)
.value_or(false)) {
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) {
if (extentErrors) {
messages.Say(
"Actual argument has fewer elements remaining in storage sequence (%jd) than %s array (%jd)"_err_en_US,
static_cast<std::intmax_t>(*actualElements), dummyName,
static_cast<std::intmax_t>(*dummySize));
} else {
foldingContext.Warn(common::UsageWarning::ShortArrayActual,
"Actual argument has fewer elements remaining in storage sequence (%jd) than %s array (%jd)"_warn_en_US,
static_cast<std::intmax_t>(*actualElements), dummyName,
static_cast<std::intmax_t>(*dummySize));
}
}
}
}
} else {
if (auto actualSize{evaluate::ToInt64(evaluate::Fold(
foldingContext, evaluate::GetSize(actualType.shape())))};
actualSize && *actualSize < *dummySize) {
if (extentErrors) {
messages.Say(
"Actual argument array has fewer elements (%jd) than %s array (%jd)"_err_en_US,
static_cast<std::intmax_t>(*actualSize), dummyName,
static_cast<std::intmax_t>(*dummySize));
} else {
foldingContext.Warn(common::UsageWarning::ShortArrayActual,
"Actual argument array has fewer elements (%jd) than %s array (%jd)"_warn_en_US,
static_cast<std::intmax_t>(*actualSize), dummyName,
static_cast<std::intmax_t>(*dummySize));
}
}
}
}
}
}
const ObjectEntityDetails *actualLastObject{actualLastSymbol
? actualLastSymbol->detailsIf<ObjectEntityDetails>()
: nullptr};
if (actualLastObject && actualLastObject->IsCoarray() &&
dummy.attrs.test(characteristics::DummyDataObject::Attr::Allocatable) &&
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 checking
// Problems with polymorphism are caught in the callee's definition.
if (scope) {
std::optional<parser::MessageFixedText> undefinableMessage;
DefinabilityFlags flags{DefinabilityFlag::PolymorphicOkInPure};
if (dummy.intent == common::Intent::InOut) {
flags.set(DefinabilityFlag::AllowEventLockOrNotifyType);
flags.set(DefinabilityFlag::OnlyWarnOnImpureFinalInPureContext);
undefinableMessage =
"Actual argument associated with INTENT(IN OUT) %s is not definable"_err_en_US;
} else if (dummy.intent == common::Intent::Out) {
undefinableMessage =
"Actual argument associated with INTENT(OUT) %s is not definable"_err_en_US;
} else if (context.ShouldWarn(common::LanguageFeature::
UndefinableAsynchronousOrVolatileActual)) {
if (dummy.attrs.test(
characteristics::DummyDataObject::Attr::Asynchronous)) {
undefinableMessage =
"Actual argument associated with ASYNCHRONOUS %s is not definable"_warn_en_US;
} else if (dummy.attrs.test(
characteristics::DummyDataObject::Attr::Volatile)) {
undefinableMessage =
"Actual argument associated with VOLATILE %s is not definable"_warn_en_US;
}
}
if (undefinableMessage) {
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 (whyNot->IsFatal()) {
if (auto *msg{messages.Say(*undefinableMessage, dummyName)}) {
if (!msg->IsFatal()) {
volatileOrAsyncNeedsTempDiagnosticIssued = true;
msg->set_languageFeature(common::LanguageFeature::
UndefinableAsynchronousOrVolatileActual);
}
msg->Attach(
std::move(whyNot->set_severity(parser::Severity::Because)));
}
} else {
messages.Say(std::move(*whyNot));
}
}
} else if (dummy.intent != common::Intent::In ||
(dummyIsPointer && !actualIsPointer) ||
(intrinsic && intrinsic->name == "loc")) {
if (auto named{evaluate::ExtractNamedEntity(actual)}) {
context.NoteDefinedSymbol(named->GetFirstSymbol());
}
}
}
bool dummyIsContiguous{
dummy.attrs.test(characteristics::DummyDataObject::Attr::Contiguous)};
bool actualIsContiguous{IsSimplyContiguous(actual, foldingContext)};
// Cases when temporaries might be needed but must not be permitted.
bool dummyIsAssumedShape{dummy.type.attrs().test(
characteristics::TypeAndShape::Attr::AssumedShape)};
bool copyOutNeeded{
evaluate::ActualArgNeedsCopy(&arg, &dummyArg, foldingContext,
/*forCopyOut=*/true)
.value_or(false)};
if (copyOutNeeded && !dummyIsValue &&
(dummyIsAsynchronous || dummyIsVolatile)) {
if (actualIsAsynchronous || actualIsVolatile) {
if (actualCoarrayRef) { // F'2023 C1547
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);
volatileOrAsyncNeedsTempDiagnosticIssued = true;
}
if ((actualRank > 0 || actualIsAssumedRank) && !actualIsContiguous) {
if (dummyIsContiguous ||
!(dummyIsAssumedShape || dummyIsAssumedRank ||
(actualIsPointer && dummyIsPointer))) { // F'2023 C1548 & C1549
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);
volatileOrAsyncNeedsTempDiagnosticIssued = true;
}
}
} else if (!(dummyIsAssumedShape || dummyIsAssumedRank ||
(actualIsPointer && dummyIsPointer)) &&
evaluate::IsArraySection(actual) && !actualIsContiguous &&
!evaluate::HasVectorSubscript(actual)) {
foldingContext.Warn(common::UsageWarning::VolatileOrAsynchronousTemporary,
"The array section '%s' should not be associated with %s with %s attribute, unless the dummy is assumed-shape or assumed-rank"_warn_en_US,
actual.AsFortran(), dummyName,
dummyIsAsynchronous ? "ASYNCHRONOUS" : "VOLATILE");
volatileOrAsyncNeedsTempDiagnosticIssued = true;
}
}
// General implementation of F'23 15.5.2.5 note 5
// Adds a less specific error message for any copy-out that could overwrite
// a unread value in the actual argument.
// Occurences of `volatileOrAsyncNeedsTempDiagnosticIssued = true` indicate a
// more specific error message has already been issued. We might be able to
// clean this up by switching the coding style of ActualArgNeedsCopy to be
// more like WhyNotDefinable.
if (copyOutNeeded && !volatileOrAsyncNeedsTempDiagnosticIssued) {
if ((actualIsVolatile || actualIsAsynchronous) &&
(dummyIsVolatile || dummyIsAsynchronous)) {
foldingContext.Warn(common::UsageWarning::VolatileOrAsynchronousTemporary,
"The actual argument '%s' with %s attribute should not be associated with %s with %s attribute, because a temporary copy is required during the call"_warn_en_US,
actual.AsFortran(), actualIsVolatile ? "VOLATILE" : "ASYNCHRONOUS",
dummyName, dummyIsVolatile ? "VOLATILE" : "ASYNCHRONOUS");
}
}
// If there are any cases where we don't need a copy and some other compiler
// does, we issue a portability warning here.
if (context.ShouldWarn(common::UsageWarning::Portability)) {
// 3 other compilers error on this case even though it is ok.
// Possibly as an over-restriction of F'23 C1548.
if (!copyOutNeeded && !volatileOrAsyncNeedsTempDiagnosticIssued &&
(!dummyIsValue && (dummyIsAsynchronous || dummyIsVolatile)) &&
!(actualIsAsynchronous || actualIsVolatile) &&
!(dummyIsAssumedShape || dummyIsAssumedRank ||
(actualIsPointer && dummyIsPointer)) &&
evaluate::IsArraySection(actual) &&
!evaluate::HasVectorSubscript(actual)) {
foldingContext.Warn(common::UsageWarning::Portability,
"The array section '%s' should not be associated with %s with %s attribute, unless the dummy is assumed-shape or assumed-rank"_port_en_US,
actual.AsFortran(), dummyName,
dummyIsAsynchronous ? "ASYNCHRONOUS" : "VOLATILE");
}
// Possibly an over-restriction of F'23 15.5.2.5 note 5
if (copyOutNeeded && !volatileOrAsyncNeedsTempDiagnosticIssued) {
if ((dummyIsVolatile && !actualIsVolatile && !actualIsAsynchronous) ||
(dummyIsAsynchronous && !actualIsVolatile && !actualIsAsynchronous)) {
foldingContext.Warn(common::UsageWarning::Portability,
"The actual argument '%s' should not be associated with %s with %s attribute, because a temporary copy is required during the call"_port_en_US,
actual.AsFortran(), dummyName,
dummyIsVolatile ? "VOLATILE" : "ASYNCHRONOUS");
}
}
}
// 15.5.2.6 -- dummy is ALLOCATABLE
bool dummyIsOptional{
dummy.attrs.test(characteristics::DummyDataObject::Attr::Optional)};
if (dummyIsAllocatable) {
if (actualIsAllocatable) {
if (actualCoarrayRef && 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 (!actualCoarrayRef && actualLastSymbol && dummy.type.corank() == 0 &&
actualLastSymbol->Corank() > 0) {
messages.Say(
"ALLOCATABLE %s is not a coarray but actual argument has corank %d"_err_en_US,
dummyName, actualLastSymbol->Corank());
}
} else if (evaluate::IsBareNullPointer(&actual)) {
if (dummyIsOptional) {
} else if (dummy.intent == common::Intent::Default &&
context.ShouldWarn(
common::UsageWarning::NullActualForDefaultIntentAllocatable)) {
messages.Say(
"A null pointer should not be associated with allocatable %s without INTENT(IN)"_warn_en_US,
dummyName);
} else if (dummy.intent == common::Intent::In) {
foldingContext.Warn(common::LanguageFeature::NullActualForAllocatable,
"Allocatable %s is associated with a null pointer"_port_en_US,
dummyName);
}
// INTENT(OUT) and INTENT(IN OUT) cases are caught elsewhere as being
// undefinable actual arguments.
} else if (evaluate::IsNullAllocatable(&actual)) {
if (dummyIsOptional) {
} else if (dummy.intent == common::Intent::Default &&
context.ShouldWarn(
common::UsageWarning::NullActualForDefaultIntentAllocatable)) {
messages.Say(
"A null allocatable should not be associated with allocatable %s without INTENT(IN)"_warn_en_US,
dummyName);
}
// INTENT(OUT) and INTENT(IN OUT) cases are caught elsewhere
} else if (!actualIsAllocatable &&
!dummy.ignoreTKR.test(common::IgnoreTKR::Pointer)) {
messages.Say(
"ALLOCATABLE %s must be associated with an ALLOCATABLE actual argument"_err_en_US,
dummyName);
}
}
// 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, actualIsPointer);
}
} else if (!actualIsPointer &&
!dummy.ignoreTKR.test(common::IgnoreTKR::Pointer)) {
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), and for a polymorphic actual being associated with a
// monomorphic dummy, 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()};
bool checkTypeCompatibility{true};
if (actualIsUnlimited != dummyIsUnlimited) {
checkTypeCompatibility = false;
if (dummyIsUnlimited && dummy.intent == common::Intent::In &&
context.IsEnabled(common::LanguageFeature::RelaxedIntentInChecking)) {
foldingContext.Warn(common::LanguageFeature::RelaxedIntentInChecking,
"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)) {
foldingContext.Warn(common::LanguageFeature::RelaxedIntentInChecking,
"If a POINTER or ALLOCATABLE dummy or actual argument is polymorphic, both should be so"_port_en_US);
} else if (actualIsPolymorphic &&
context.IsEnabled(common::LanguageFeature::
PolymorphicActualAllocatableOrPointerToMonomorphicDummy)) {
foldingContext.Warn(
common::LanguageFeature::
PolymorphicActualAllocatableOrPointerToMonomorphicDummy,
"If a POINTER or ALLOCATABLE actual argument is polymorphic, the corresponding dummy argument should also be so"_port_en_US);
} else {
checkTypeCompatibility = false;
messages.Say(
"If a POINTER or ALLOCATABLE dummy or actual argument is polymorphic, both must be so"_err_en_US);
}
} else if ((dummy.ignoreTKR.test(common::IgnoreTKR::Type) ||
dummy.ignoreTKR.test(common::IgnoreTKR::Kind)) &&
dummy.ignoreTKR.test(common::IgnoreTKR::Contiguous)) {
// Descriptor based dummy args passed with ignore_tkr(tc) or
// ignore_tkr(kc) are allowed to have type and kind differences
checkTypeCompatibility = false;
}
if (checkTypeCompatibility && !actualIsUnlimited) {
if (!actualType.type().IsTkCompatibleWith(dummy.type.type())) {
if (dummy.intent == common::Intent::In &&
context.IsEnabled(
common::LanguageFeature::RelaxedIntentInChecking)) {
foldingContext.Warn(common::LanguageFeature::RelaxedIntentInChecking,
"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 *dummyDerived{evaluate::GetDerivedTypeSpec(dummy.type.type())};
if (!DefersSameTypeParameters(actualDerived, dummyDerived) ||
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);
} else if (actualType.corank() != dummy.type.corank() &&
dummyIsAllocatableOrPointer) {
messages.Say(
"ALLOCATABLE or POINTER %s has corank %d but actual argument has corank %d"_err_en_US,
dummyName, dummy.type.corank(), actualType.corank());
}
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 &&
evaluate::IsNullPointer(&actual)) {
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
bool actualIsVariable{evaluate::IsVariable(actual)};
if (dummy.attrs.test(characteristics::DummyDataObject::Attr::Target) &&
context.ShouldWarn(common::UsageWarning::NonTargetPassedToTarget)) {
bool actualIsTemp{
!actualIsVariable || HasVectorSubscript(actual) || actualCoarrayRef};
if (actualIsTemp) {
foldingContext.Warn(common::UsageWarning::NonTargetPassedToTarget,
"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)) {
foldingContext.Warn(common::UsageWarning::NonTargetPassedToTarget,
"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;
// For a%b%c, the last symbol with a CUDA data attribute wins
if (actualIsVariable) {
for (const Symbol &s : evaluate::GetSymbolVector(actual)) {
if (const auto *object{s.detailsIf<ObjectEntityDetails>()}) {
if (auto cudaAttr{object->cudaDataAttr()}) {
actualDataAttr = *cudaAttr;
}
}
}
}
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;
}
// For device procedures, treat actual arguments with VALUE attribute as
// device data; also constant actual arguments and the function result.
if (!actualDataAttr &&
(!actualFirstSymbol || IsValue(*actualFirstSymbol) ||
IsFunctionResult(*actualFirstSymbol)) &&
(*procedure.cudaSubprogramAttrs ==
common::CUDASubprogramAttrs::Device)) {
actualDataAttr = common::CUDADataAttr::Device;
}
}
if (dummyDataAttr == common::CUDADataAttr::Device &&
(dummyIsAssumedShape || dummyIsAssumedRank) &&
!dummy.ignoreTKR.test(common::IgnoreTKR::Contiguous)) {
if (auto contig{evaluate::IsContiguous(actual, foldingContext,
/*namedConstantSectionsAreContiguous=*/true,
/*firstDimensionStride1=*/true)}) {
if (!*contig) {
messages.Say(
"actual argument associated with assumed shape/rank device %s is known to be discontiguous on its first dimension"_err_en_US,
dummyName);
}
} else {
messages.Say(
"actual argument associated with assumed shape/rank device %s is not known to be contiguous on its first dimension"_warn_en_US,
dummyName);
}
}
bool isHostDeviceProc{procedure.cudaSubprogramAttrs &&
*procedure.cudaSubprogramAttrs ==
common::CUDASubprogramAttrs::HostDevice};
if (!common::AreCompatibleCUDADataAttrs(dummyDataAttr, actualDataAttr,
dummy.ignoreTKR, /*allowUnifiedMatchingRule=*/true,
isHostDeviceProc, &context.languageFeatures())) {
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));
}
}
// Emit an error message if an actual argument passed to a host intrinsic is
// on the device.
if (intrinsic && !FindCUDADeviceContext(scope) &&
!FindOpenACCConstructContaining(scope) &&
!HasOpenACCRoutineDirective(scope)) {
if (!cudaSkippedIntrinsics.contains(intrinsic->name)) {
std::optional<common::CUDADataAttr> actualDataAttr;
if (const auto *actualObject{actualLastSymbol
? actualLastSymbol->detailsIf<ObjectEntityDetails>()
: nullptr}) {
actualDataAttr = actualObject->cudaDataAttr();
}
if (actualDataAttr && *actualDataAttr == common::CUDADataAttr::Device) {
messages.Say(
"Actual argument %s associated with host intrinsic %s is on the device"_err_en_US,
actualLastSymbol ? actualLastSymbol->name() : "", intrinsic->name);
}
}
}
// Warning for breaking F'2023 change with character allocatables
if (intrinsic && dummy.intent != common::Intent::In) {
WarnOnDeferredLengthCharacterScalar(
context, &actual, messages.at(), dummyName.c_str());
}
// %VAL() and %REF() checking for explicit interface
if ((arg.isPercentRef() || arg.isPercentVal()) &&
dummy.IsPassedByDescriptor(procedure.IsBindC())) {
messages.Say(
"%%VAL or %%REF are not allowed for %s that must be passed by means of a descriptor"_err_en_US,
dummyName);
}
if (arg.isPercentVal() &&
(!actualType.type().IsLengthlessIntrinsicType() ||
actualType.Rank() != 0)) {
messages.Say(
"%VAL argument must be a scalar numeric or logical expression"_err_en_US);
}
}
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()};
parser::CharBlock location{arg.sourceLocation().value_or(messages.at())};
auto restorer{messages.SetLocation(location)};
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)) {
evaluate::SayWithDeclaration(messages, *argProcSymbol,
"Procedure binding '%s' passed as an actual argument"_err_en_US,
argProcSymbol->name());
} else {
evaluate::WarnWithDeclaration(foldingContext, *argProcSymbol,
common::LanguageFeature::BindingAsProcedure,
"Procedure binding '%s' passed as an actual argument"_port_en_US,
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);
argInterface.attrs.reset(
characteristics::Procedure::Attr::NullAllocatable);
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);
argInterface.attrs.reset(
characteristics::Procedure::Attr::NullAllocatable);
}
}
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 {
foldingContext.Warn(
common::UsageWarning::ImplicitInterfaceActual,
"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) {
foldingContext.Warn(common::UsageWarning::ProcDummyArgShapes,
"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) {
if (dummy.intent == common::Intent::In) {
// need not be definable, can be a target
} else if (!IsProcedurePointer(*expr)) {
messages.Say(
"Actual argument associated with procedure pointer %s is not a procedure pointer"_err_en_US,
dummyName);
} else if (dummy.intent == common::Intent::Default) {
// ok, needs to be definable only if defined at run time
} else {
DefinabilityFlags flags{DefinabilityFlag::PointerDefinition};
if (dummy.intent != common::Intent::Out) {
flags.set(DefinabilityFlag::DoNotNoteDefinition);
}
if (auto whyNot{WhyNotDefinable(
location, context.FindScope(location), flags, *expr)}) {
if (auto *msg{messages.Say(
"Actual argument associated with INTENT(%s) procedure pointer %s is not definable"_err_en_US,
dummy.intent == common::Intent::Out ? "OUT" : "IN OUT",
dummyName)}) {
msg->Attach(
std::move(whyNot->set_severity(parser::Severity::Because)));
}
}
}
}
} 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 false;
} else {
return true;
}
};
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, arg,
dummy);
} 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) &&
evaluate::IsNullObjectPointer(expr) &&
(object.attrs.test(
characteristics::DummyDataObject::Attr::Allocatable) ||
object.attrs.test(
characteristics::DummyDataObject::Attr::Pointer) ||
!object.attrs.test(characteristics::DummyDataObject::
Attr::Optional))) {
messages.Say(
"NULL() without MOLD= must not be associated with an assumed-rank dummy argument that is ALLOCATABLE, POINTER, or non-OPTIONAL"_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::IsNullAllocatable(expr) ||
evaluate::IsBareNullPointer(expr))) {
if (object.intent == common::Intent::Out ||
object.intent == common::Intent::InOut) {
messages.Say(
"NULL() actual argument '%s' may not be associated with allocatable dummy argument %s that is INTENT(OUT) or INTENT(IN OUT)"_err_en_US,
expr->AsFortran(), dummyName);
} else if (object.intent == common::Intent::Default) {
foldingContext.Warn(
common::UsageWarning::
NullActualForDefaultIntentAllocatable,
"NULL() actual argument '%s' should not be associated with allocatable dummy argument %s without INTENT(IN)"_warn_en_US,
expr->AsFortran(), dummyName);
} else {
foldingContext.Warn(
common::LanguageFeature::NullActualForAllocatable,
"Allocatable %s is associated with %s"_port_en_US,
dummyName, expr->AsFortran());
}
} 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) && !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 (const auto *wholeSymbol{evaluate::UnwrapWholeSymbolDataRef(arg)}) {
wholeSymbol = &ResolveAssociations(*wholeSymbol);
if (IsAssumedSizeArray(*wholeSymbol)) {
evaluate::SayWithDeclaration(messages, *wholeSymbol,
"Whole assumed-size array '%s' may not be used as an argument to an elemental procedure"_err_en_US,
wholeSymbol->name());
} else if (IsAssumedRank(*wholeSymbol)) {
evaluate::SayWithDeclaration(messages, *wholeSymbol,
"Assumed-rank array '%s' may not be used as an argument to an elemental procedure"_err_en_US,
wholeSymbol->name());
}
}
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) {
if (!evaluate::CheckConformance(messages, *shape, *argShape,
evaluate::CheckConformanceFlags::None, shapeName.c_str(),
argName.c_str())
.value_or(true)) {
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 type compatible with the POINTER= for a data pointer. In
// the case of procedure pointers, the standard requires that it
// 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)) {
foldingContext.Warn(common::UsageWarning::Portability,
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,
DefinabilityFlag::DoNotNoteDefinition},
*pointerExpr)}) {
if (whyNot->IsFatal()) {
if (auto *msg{foldingContext.Warn(
common::UsageWarning::Portability,
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->set_severity(parser::Severity::Because)));
}
} else {
messages.Say(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)};
std::optional<common::UsageWarning> whichWarning;
if (!msg && warning &&
semanticsContext.ShouldWarn(
common::UsageWarning::ProcDummyArgShapes)) {
whichWarning = common::UsageWarning::ProcDummyArgShapes;
msg =
"Procedures '%s' and '%s' may not be completely compatible: %s"_warn_en_US;
whyNot = std::move(*warning);
} else if (msg && !msg->IsFatal() &&
semanticsContext.ShouldWarn(
common::UsageWarning::ProcPointerCompatibility)) {
whichWarning =
common::UsageWarning::ProcPointerCompatibility;
}
if (msg && (msg->IsFatal() || whichWarning)) {
if (auto *said{messages.Say(std::move(*msg),
"pointer '" + pointerExpr->AsFortran() + "'",
targetExpr->AsFortran(), whyNot)};
said && whichWarning) {
said->set_usageWarning(*whichWarning);
}
}
}
} 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) ||
targetType->IsTkCompatibleWith(*pointerType);
}
}
} 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());
}
if (!IsAssumedRank(*pointerExpr)) {
if (IsAssumedRank(*targetExpr)) {
messages.Say(
"TARGET= argument '%s' may not be assumed-rank when POINTER= argument is not"_err_en_US,
pointerExpr->AsFortran());
} else if (pointerExpr->Rank() != targetExpr->Rank()) {
messages.Say(
"POINTER= argument and TARGET= argument have incompatible ranks %d and %d"_err_en_US,
pointerExpr->Rank(), targetExpr->Rank());
}
}
}
}
}
} 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);
}
}
// CO_REDUCE (F'2023 16.9.49)
static void CheckCoReduce(
evaluate::ActualArguments &arguments, evaluate::FoldingContext &context) {
parser::ContextualMessages &messages{context.messages()};
evaluate::CheckForCoindexedObject(
context.messages(), arguments[0], "co_reduce", "a");
evaluate::CheckForCoindexedObject(
context.messages(), arguments[2], "co_reduce", "stat");
evaluate::CheckForCoindexedObject(
context.messages(), arguments[3], "co_reduce", "errmsg");
std::optional<evaluate::DynamicType> aType;
if (const auto &a{arguments[0]}) {
aType = a->GetType();
}
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, /*emitError=*/true);
} else if (const auto *ref{
std::get_if<evaluate::ProcedureRef>(&expr->u)}) {
procChars = characteristics::Procedure::Characterize(*ref, context);
}
}
}
static constexpr characteristics::DummyDataObject::Attrs notAllowedArgAttrs{
characteristics::DummyDataObject::Attr::Optional,
characteristics::DummyDataObject::Attr::Allocatable,
characteristics::DummyDataObject::Attr::Pointer,
};
static constexpr characteristics::FunctionResult::Attrs
notAllowedFuncResAttrs{
characteristics::FunctionResult::Attr::Allocatable,
characteristics::FunctionResult::Attr::Pointer,
};
const characteristics::TypeAndShape *result{
procChars && procChars->functionResult
? procChars->functionResult->GetTypeAndShape()
: nullptr};
if (!procChars || !procChars->IsPure() ||
procChars->dummyArguments.size() != 2 || !procChars->functionResult) {
messages.Say(
"OPERATION= argument of CO_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 CO_REDUCE() is not supported"_err_en_US);
} else if (!result || result->Rank() != 0) {
messages.Say(
"OPERATION= argument of CO_REDUCE() must be a scalar function"_err_en_US);
} else if (result->type().IsPolymorphic() ||
(aType && !aType->IsTkLenCompatibleWith(result->type()))) {
messages.Say(
"OPERATION= argument of CO_REDUCE() must have the same type as A="_err_en_US);
} else if (((procChars->functionResult->attrs & notAllowedFuncResAttrs) !=
characteristics::FunctionResult::Attrs{}) ||
procChars->functionResult->GetTypeAndShape()->type().IsPolymorphic()) {
messages.Say(
"Result of OPERATION= procedure of CO_REDUCE() must be scalar and neither allocatable, pointer, nor polymorphic"_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 CO_REDUCE() may not have dummy procedure arguments"_err_en_US);
} else {
for (int j{0}; j < 2; ++j) {
if (((data[j]->attrs & notAllowedArgAttrs) !=
characteristics::DummyDataObject::Attrs{}) ||
data[j]->type.Rank() != 0 || data[j]->type.type().IsPolymorphic() ||
(aType && !data[j]->type.type().IsTkCompatibleWith(*aType))) {
messages.Say(
"Arguments of OPERATION= procedure of CO_REDUCE() must be both scalar of the same type as A=, and neither allocatable, pointer, polymorphic, nor optional"_err_en_US);
break;
}
}
static constexpr characteristics::DummyDataObject::Attrs attrs{
characteristics::DummyDataObject::Attr::Asynchronous,
characteristics::DummyDataObject::Attr::Target,
characteristics::DummyDataObject::Attr::Value,
};
if ((data[0]->attrs & attrs) != (data[1]->attrs & attrs)) {
messages.Say(
"If either argument of the OPERATION= procedure of CO_REDUCE() has the ASYNCHRONOUS, TARGET, or VALUE attribute, both must have that attribute"_err_en_US);
}
}
}
}
// DATE_AND_TIME (F'2023 16.9.69)
static void CheckDate_And_Time(evaluate::ActualArguments &arguments,
evaluate::FoldingContext &foldingContext) {
if (arguments.size() >= 4 && arguments[3]) {
if (const auto valuesShape{
evaluate::GetShape(arguments[3]->UnwrapExpr())}) {
if (auto extents{
evaluate::AsConstantExtents(foldingContext, *valuesShape)}) {
if (!extents->empty() && extents->at(0) < 8) {
auto &messages{foldingContext.messages()};
messages.Say(arguments[3]->sourceLocation().value_or(messages.at()),
"VALUES= argument to DATE_AND_TIME must have at least 8 elements"_err_en_US);
}
}
}
}
}
// EVENT_QUERY (F'2023 16.9.82)
static void CheckEvent_Query(evaluate::ActualArguments &arguments,
evaluate::FoldingContext &foldingContext) {
if (arguments.size() > 0 && arguments[0] &&
ExtractCoarrayRef(*arguments[0]).has_value()) {
foldingContext.messages().Say(arguments[0]->sourceLocation(),
"EVENT= argument to EVENT_QUERY must not be coindexed"_err_en_US);
}
if (arguments.size() > 1 && arguments[1]) {
if (auto dyType{arguments[1]->GetType()}) {
int defaultInt{
foldingContext.defaults().GetDefaultKind(TypeCategory::Integer)};
if (dyType->category() == TypeCategory::Integer &&
dyType->kind() < defaultInt) {
foldingContext.messages().Say(arguments[1]->sourceLocation(),
"COUNT= argument to EVENT_QUERY must be an integer with kind >= %d"_err_en_US,
defaultInt);
}
}
}
if (arguments.size() > 2 && arguments[2]) {
if (auto dyType{arguments[2]->GetType()}) {
if (dyType->category() == TypeCategory::Integer && dyType->kind() < 2) {
foldingContext.messages().Say(arguments[2]->sourceLocation(),
"STAT= argument to EVENT_QUERY must be an integer with kind >= 2 when present"_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())}) {
auto coarrayArgCorank{coarrayArgSymbol->Corank()};
if (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);
}
}
}
}
}
}
// Ensure that any optional argument that might be absent at run time
// does not require data conversion.
static void CheckMaxMin(const characteristics::Procedure &proc,
evaluate::ActualArguments &arguments,
parser::ContextualMessages &messages) {
if (proc.functionResult) {
if (const auto *typeAndShape{proc.functionResult->GetTypeAndShape()}) {
for (std::size_t j{2}; j < arguments.size(); ++j) {
if (arguments[j]) {
if (const auto *expr{arguments[j]->UnwrapExpr()};
expr && evaluate::MayBePassedAsAbsentOptional(*expr)) {
if (auto thisType{expr->GetType()}) {
if (thisType->category() == TypeCategory::Character &&
typeAndShape->type().category() == TypeCategory::Character &&
thisType->kind() == typeAndShape->type().kind()) {
// don't care about lengths
} else if (*thisType != typeAndShape->type()) {
messages.Say(arguments[j]->sourceLocation(),
"An actual argument to MAX/MIN requiring data conversion may not be OPTIONAL, POINTER, or ALLOCATABLE"_err_en_US);
}
}
}
}
}
}
}
}
static void CheckFree(evaluate::ActualArguments &arguments,
parser::ContextualMessages &messages) {
if (arguments.size() != 1) {
messages.Say("FREE expects a single argument"_err_en_US);
}
auto arg = arguments[0];
if (const Symbol * symbol{evaluate::UnwrapWholeSymbolDataRef(arg)};
!symbol || !symbol->test(Symbol::Flag::CrayPointer)) {
messages.Say("FREE should only be used with Cray pointers"_warn_en_US);
}
}
// 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");
int fromCR{GetCorank(arguments[0])};
int toCR{GetCorank(arguments[1])};
if (fromCR != toCR) {
messages.Say(*arguments[0]->sourceLocation(),
"FROM= argument to MOVE_ALLOC has corank %d, but TO= argument has corank %d"_err_en_US,
fromCR, toCR);
}
}
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->GetUltimate().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, /*emitError=*/true);
} else if (const auto *ref{
std::get_if<evaluate::ProcedureRef>(&expr->u)}) {
procChars = characteristics::Procedure::Characterize(*ref, context);
}
}
}
const auto *result{procChars && procChars->functionResult
? 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.foldingContext().Warn(common::UsageWarning::PolymorphicTransferArg,
"%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::WarnWithDeclaration(context.foldingContext(), *bad,
common::UsageWarning::PointerComponentTransferArg,
"%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 {
foldingContext.Warn(common::UsageWarning::VoidMold,
"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)) {
foldingContext.Warn(common::UsageWarning::TransferSizePresence,
"SIZE= argument that is allocatable or pointer must be present at execution; parenthesize to silence this warning"_warn_en_US);
}
}
}
}
}
static void CheckSpecificIntrinsic(const characteristics::Procedure &proc,
evaluate::ActualArguments &arguments, SemanticsContext &context,
const Scope *scope, const evaluate::SpecificIntrinsic &intrinsic) {
if (intrinsic.name == "associated") {
CheckAssociated(arguments, context, scope);
} else if (intrinsic.name == "co_reduce") {
CheckCoReduce(arguments, context.foldingContext());
} else if (intrinsic.name == "date_and_time") {
CheckDate_And_Time(arguments, context.foldingContext());
} else if (intrinsic.name == "event_query") {
CheckEvent_Query(arguments, context.foldingContext());
} else if (intrinsic.name == "image_index") {
CheckImage_Index(arguments, context.foldingContext().messages());
} else if (intrinsic.name == "max" || intrinsic.name == "min") {
CheckMaxMin(proc, 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);
} else if (intrinsic.name == "free") {
CheckFree(arguments, context.foldingContext().messages());
}
}
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(proc, 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 CheckWindowsIntrinsic(
const Symbol &intrinsic, evaluate::FoldingContext &foldingContext) {
parser::ContextualMessages &messages{foldingContext.messages()};
// TODO: there are other intrinsics that are unsupported on Windows that
// should be added here.
if (intrinsic.name() == "getuid") {
messages.Say(
"User IDs do not exist on Windows. This function will always return 1"_warn_en_US);
}
if (intrinsic.name() == "getgid") {
messages.Say(
"Group IDs do not exist on Windows. This function will always return 1"_warn_en_US);
}
return true;
}
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()};
bool allowArgumentConversions{true};
parser::Messages implicitBuffer;
if (!explicitInterface || treatingExternalAsImplicit) {
{
auto restorer{messages.SetMessages(implicitBuffer)};
for (auto &actual : actuals) {
if (actual) {
CheckImplicitInterfaceArg(*actual, messages, context);
}
}
}
if (implicitBuffer.AnyFatalError()) {
if (auto *msgs{messages.messages()}) {
msgs->Annex(std::move(implicitBuffer));
}
return false; // don't pile on
}
allowArgumentConversions = false;
}
if (explicitInterface) {
auto explicitBuffer{CheckExplicitInterface(proc, actuals, context, &scope,
intrinsic, allowArgumentConversions,
/*extentErrors=*/true, ignoreImplicitVsExplicit)};
if (!explicitBuffer.empty()) {
if (treatingExternalAsImplicit && explicitBuffer.AnyFatalError()) {
// Combine all messages into one warning
if (auto *warning{messages.Warn(/*inModuleFile=*/false,
context.languageFeatures(),
common::UsageWarning::KnownBadImplicitInterface,
"If the procedure's interface were explicit, this reference would be in error"_warn_en_US)}) {
explicitBuffer.AttachTo(*warning, parser::Severity::Because);
}
} else if (auto *msgs{messages.messages()}) {
msgs->Annex(std::move(explicitBuffer));
}
// These messages override any in implicitBuffer.
return false;
}
}
if (!implicitBuffer.empty()) {
if (auto *msgs{messages.messages()}) {
msgs->Annex(std::move(implicitBuffer));
}
return false;
} else {
return true; // no messages
}
}
} // namespace Fortran::semantics
Reference in New Issue View Git Blame Copy Permalink