248 lines
9.7 KiB
C++
248 lines
9.7 KiB
C++
//===-- lib/Semantics/definable.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 "definable.h"
|
|
#include "flang/Evaluate/tools.h"
|
|
#include "flang/Semantics/tools.h"
|
|
|
|
using namespace Fortran::parser::literals;
|
|
|
|
namespace Fortran::semantics {
|
|
|
|
template <typename... A>
|
|
static parser::Message BlameSymbol(parser::CharBlock at,
|
|
const parser::MessageFixedText &text, const Symbol &original, A &&...x) {
|
|
parser::Message message{at, text, original.name(), std::forward<A>(x)...};
|
|
message.set_severity(parser::Severity::Because);
|
|
evaluate::AttachDeclaration(message, original);
|
|
return message;
|
|
}
|
|
|
|
static bool IsPointerDummyOfPureFunction(const Symbol &x) {
|
|
return IsPointerDummy(x) && FindPureProcedureContaining(x.owner()) &&
|
|
x.owner().symbol() && IsFunction(*x.owner().symbol());
|
|
}
|
|
|
|
// See C1594, first paragraph. These conditions enable checks on both
|
|
// left-hand and right-hand sides in various circumstances.
|
|
const char *WhyBaseObjectIsSuspicious(const Symbol &x, const Scope &scope) {
|
|
if (IsHostAssociatedIntoSubprogram(x, scope)) {
|
|
return "host-associated";
|
|
} else if (IsUseAssociated(x, scope)) {
|
|
return "USE-associated";
|
|
} else if (IsPointerDummyOfPureFunction(x)) {
|
|
return "a POINTER dummy argument of a pure function";
|
|
} else if (IsIntentIn(x)) {
|
|
return "an INTENT(IN) dummy argument";
|
|
} else if (FindCommonBlockContaining(x)) {
|
|
return "in a COMMON block";
|
|
} else {
|
|
return nullptr;
|
|
}
|
|
}
|
|
|
|
// Checks C1594(1,2); false if check fails
|
|
static std::optional<parser::Message> CheckDefinabilityInPureScope(
|
|
SourceName at, const Symbol &original, const Symbol &ultimate,
|
|
const Scope &context, const Scope &pure) {
|
|
if (pure.symbol()) {
|
|
if (const char *why{WhyBaseObjectIsSuspicious(ultimate, context)}) {
|
|
return BlameSymbol(at,
|
|
"'%s' may not be defined in pure subprogram '%s' because it is %s"_en_US,
|
|
original, pure.symbol()->name(), why);
|
|
}
|
|
}
|
|
return std::nullopt;
|
|
}
|
|
|
|
// When a DataRef contains pointers, gets the rightmost one (unless it is
|
|
// the entity being defined, in which case the last pointer above it);
|
|
// otherwise, returns the leftmost symbol. The resulting symbol is the
|
|
// relevant base object for definabiliy checking. Examples:
|
|
// ptr1%ptr2 => ... -> ptr1
|
|
// nonptr%ptr => ... -> nonptr
|
|
// nonptr%ptr = ... -> ptr
|
|
// ptr1%ptr2 = ... -> ptr2
|
|
// ptr1%ptr2%nonptr = ... -> ptr2
|
|
// nonptr1%nonptr2 = ... -> nonptr1
|
|
static const Symbol &GetRelevantSymbol(
|
|
const evaluate::DataRef &dataRef, bool isPointerDefinition) {
|
|
if (isPointerDefinition) {
|
|
if (const auto *component{std::get_if<evaluate::Component>(&dataRef.u)}) {
|
|
if (IsPointer(component->GetLastSymbol())) {
|
|
return GetRelevantSymbol(component->base(), false);
|
|
}
|
|
}
|
|
}
|
|
if (const Symbol * lastPointer{GetLastPointerSymbol(dataRef)}) {
|
|
return *lastPointer;
|
|
} else {
|
|
return dataRef.GetFirstSymbol();
|
|
}
|
|
}
|
|
|
|
// Check the leftmost (or only) symbol from a data-ref or expression.
|
|
static std::optional<parser::Message> WhyNotDefinableBase(parser::CharBlock at,
|
|
const Scope &scope, DefinabilityFlags flags, const Symbol &original) {
|
|
const Symbol &ultimate{original.GetUltimate()};
|
|
bool isPointerDefinition{flags.test(DefinabilityFlag::PointerDefinition)};
|
|
bool isTargetDefinition{!isPointerDefinition && IsPointer(ultimate)};
|
|
if (const auto *association{ultimate.detailsIf<AssocEntityDetails>()}) {
|
|
if (association->rank().has_value()) {
|
|
return std::nullopt; // SELECT RANK always modifiable variable
|
|
} else if (!IsVariable(association->expr())) {
|
|
return BlameSymbol(at,
|
|
"'%s' is construct associated with an expression"_en_US, original);
|
|
} else if (evaluate::HasVectorSubscript(association->expr().value())) {
|
|
return BlameSymbol(at,
|
|
"Construct association '%s' has a vector subscript"_en_US, original);
|
|
} else if (auto dataRef{evaluate::ExtractDataRef(
|
|
*association->expr(), true, true)}) {
|
|
return WhyNotDefinableBase(
|
|
at, scope, flags, GetRelevantSymbol(*dataRef, isPointerDefinition));
|
|
}
|
|
}
|
|
if (isTargetDefinition) {
|
|
} else if (!isPointerDefinition && !IsVariableName(ultimate)) {
|
|
return BlameSymbol(at, "'%s' is not a variable"_en_US, original);
|
|
} else if (IsProtected(ultimate) && IsUseAssociated(original, scope)) {
|
|
return BlameSymbol(at, "'%s' is protected in this scope"_en_US, original);
|
|
} else if (IsIntentIn(ultimate)) {
|
|
return BlameSymbol(
|
|
at, "'%s' is an INTENT(IN) dummy argument"_en_US, original);
|
|
}
|
|
if (const Scope * pure{FindPureProcedureContaining(scope)}) {
|
|
// Additional checking for pure subprograms.
|
|
if (!isTargetDefinition) {
|
|
if (auto msg{CheckDefinabilityInPureScope(
|
|
at, original, ultimate, scope, *pure)}) {
|
|
return msg;
|
|
}
|
|
}
|
|
if (const Symbol *
|
|
visible{FindExternallyVisibleObject(
|
|
ultimate, *pure, isPointerDefinition)}) {
|
|
return BlameSymbol(at,
|
|
"'%s' is externally visible via '%s' and not definable in a pure subprogram"_en_US,
|
|
original, visible->name());
|
|
}
|
|
}
|
|
return std::nullopt;
|
|
}
|
|
|
|
static std::optional<parser::Message> WhyNotDefinableLast(parser::CharBlock at,
|
|
const Scope &scope, DefinabilityFlags flags, const Symbol &original) {
|
|
const Symbol &ultimate{original.GetUltimate()};
|
|
if (flags.test(DefinabilityFlag::PointerDefinition)) {
|
|
if (!IsPointer(ultimate)) {
|
|
return BlameSymbol(at, "'%s' is not a pointer"_en_US, original);
|
|
}
|
|
return std::nullopt; // pointer assignment - skip following checks
|
|
}
|
|
if (IsOrContainsEventOrLockComponent(ultimate)) {
|
|
return BlameSymbol(at,
|
|
"'%s' is an entity with either an EVENT_TYPE or LOCK_TYPE"_en_US,
|
|
original);
|
|
}
|
|
if (!flags.test(DefinabilityFlag::PolymorphicOkInPure) &&
|
|
FindPureProcedureContaining(scope)) {
|
|
if (auto dyType{evaluate::DynamicType::From(ultimate)}) {
|
|
if (dyType->IsPolymorphic()) { // C1596
|
|
return BlameSymbol(at,
|
|
"'%s' is polymorphic in a pure subprogram"_because_en_US, original);
|
|
}
|
|
if (const DerivedTypeSpec * derived{GetDerivedTypeSpec(dyType)}) {
|
|
if (auto bad{FindPolymorphicAllocatableNonCoarrayUltimateComponent(
|
|
*derived)}) {
|
|
return BlameSymbol(at,
|
|
"'%s' has polymorphic non-coarray component '%s' in a pure subprogram"_because_en_US,
|
|
original, bad.BuildResultDesignatorName());
|
|
}
|
|
}
|
|
}
|
|
}
|
|
return std::nullopt;
|
|
}
|
|
|
|
// Checks a data-ref
|
|
static std::optional<parser::Message> WhyNotDefinable(parser::CharBlock at,
|
|
const Scope &scope, DefinabilityFlags flags,
|
|
const evaluate::DataRef &dataRef) {
|
|
const Symbol &base{GetRelevantSymbol(
|
|
dataRef, flags.test(DefinabilityFlag::PointerDefinition))};
|
|
if (auto whyNot{WhyNotDefinableBase(at, scope, flags, base)}) {
|
|
return whyNot;
|
|
} else {
|
|
return WhyNotDefinableLast(at, scope, flags, dataRef.GetLastSymbol());
|
|
}
|
|
}
|
|
|
|
// Checks a NOPASS procedure pointer component
|
|
static std::optional<parser::Message> WhyNotDefinable(parser::CharBlock at,
|
|
const Scope &scope, DefinabilityFlags flags,
|
|
const evaluate::Component &component) {
|
|
const evaluate::DataRef &dataRef{component.base()};
|
|
const Symbol &base{GetRelevantSymbol(dataRef, false)};
|
|
DefinabilityFlags baseFlags{flags};
|
|
baseFlags.reset(DefinabilityFlag::PointerDefinition);
|
|
return WhyNotDefinableBase(at, scope, baseFlags, base);
|
|
}
|
|
|
|
std::optional<parser::Message> WhyNotDefinable(parser::CharBlock at,
|
|
const Scope &scope, DefinabilityFlags flags, const Symbol &original) {
|
|
if (auto base{WhyNotDefinableBase(at, scope, flags, original)}) {
|
|
return base;
|
|
}
|
|
return WhyNotDefinableLast(at, scope, flags, original);
|
|
}
|
|
|
|
std::optional<parser::Message> WhyNotDefinable(parser::CharBlock at,
|
|
const Scope &scope, DefinabilityFlags flags,
|
|
const evaluate::Expr<evaluate::SomeType> &expr) {
|
|
if (auto dataRef{evaluate::ExtractDataRef(expr, true, true)}) {
|
|
if (!flags.test(DefinabilityFlag::VectorSubscriptIsOk) &&
|
|
evaluate::HasVectorSubscript(expr)) {
|
|
return parser::Message{at,
|
|
"Variable '%s' has a vector subscript"_because_en_US,
|
|
expr.AsFortran()};
|
|
}
|
|
if (FindPureProcedureContaining(scope) &&
|
|
evaluate::ExtractCoarrayRef(expr)) {
|
|
return parser::Message(at,
|
|
"A pure subprogram may not define the coindexed object '%s'"_because_en_US,
|
|
expr.AsFortran());
|
|
}
|
|
return WhyNotDefinable(at, scope, flags, *dataRef);
|
|
}
|
|
if (evaluate::IsVariable(expr)) {
|
|
return std::nullopt; // result of function returning a pointer - ok
|
|
}
|
|
if (flags.test(DefinabilityFlag::PointerDefinition)) {
|
|
if (const auto *procDesignator{
|
|
std::get_if<evaluate::ProcedureDesignator>(&expr.u)}) {
|
|
// Defining a procedure pointer
|
|
if (const Symbol * procSym{procDesignator->GetSymbol()}) {
|
|
if (evaluate::ExtractCoarrayRef(expr)) { // C1027
|
|
return BlameSymbol(at,
|
|
"Procedure pointer '%s' may not be a coindexed object"_because_en_US,
|
|
*procSym, expr.AsFortran());
|
|
}
|
|
if (const auto *component{procDesignator->GetComponent()}) {
|
|
return WhyNotDefinable(at, scope, flags, *component);
|
|
} else {
|
|
return WhyNotDefinable(at, scope, flags, *procSym);
|
|
}
|
|
}
|
|
}
|
|
}
|
|
return parser::Message{
|
|
at, "'%s' is not a variable or pointer"_because_en_US, expr.AsFortran()};
|
|
}
|
|
|
|
} // namespace Fortran::semantics
|