Google Git
Sign in
llvm / llvm-project / 24e9ee44a8a58ae4b23a2508ca331ebf001972e2 / . / flang / lib / Evaluate / check-expression.cpp
blob: 8931cbe485ac2aa38c2a1c56d54e756802d3a264 [file] [log] [blame]
//===-- lib/Evaluate/check-expression.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 "flang/Evaluate/check-expression.h"
#include "flang/Evaluate/characteristics.h"
#include "flang/Evaluate/intrinsics.h"
#include "flang/Evaluate/tools.h"
#include "flang/Evaluate/traverse.h"
#include "flang/Evaluate/type.h"
#include "flang/Semantics/semantics.h"
#include "flang/Semantics/symbol.h"
#include "flang/Semantics/tools.h"
#include <set>
#include <string>
namespace Fortran::evaluate {
// Constant expression predicates IsConstantExpr() & IsScopeInvariantExpr().
// This code determines whether an expression is a "constant expression"
// in the sense of section 10.1.12. This is not the same thing as being
// able to fold it (yet) into a known constant value; specifically,
// the expression may reference derived type kind parameters whose values
// are not yet known.
//
// The variant form (IsScopeInvariantExpr()) also accepts symbols that are
// INTENT(IN) dummy arguments without the VALUE attribute.
template <bool INVARIANT>
class IsConstantExprHelper
: public AllTraverse<IsConstantExprHelper<INVARIANT>, true> {
public:
using Base = AllTraverse<IsConstantExprHelper, true>;
IsConstantExprHelper() : Base{*this} {}
using Base::operator();
// A missing expression is not considered to be constant.
template <typename A> bool operator()(const std::optional<A> &x) const {
return x && (*this)(*x);
}
bool operator()(const TypeParamInquiry &inq) const {
return INVARIANT || semantics::IsKindTypeParameter(inq.parameter());
}
bool operator()(const semantics::Symbol &symbol) const {
const auto &ultimate{GetAssociationRoot(symbol)};
return IsNamedConstant(ultimate) || IsImpliedDoIndex(ultimate) ||
IsInitialProcedureTarget(ultimate) ||
ultimate.has<semantics::TypeParamDetails>() ||
(INVARIANT && IsIntentIn(symbol) && !IsOptional(symbol) &&
!symbol.attrs().test(semantics::Attr::VALUE));
}
bool operator()(const CoarrayRef &) const { return false; }
bool operator()(const semantics::ParamValue &param) const {
return param.isExplicit() && (*this)(param.GetExplicit());
}
bool operator()(const ProcedureRef &) const;
bool operator()(const StructureConstructor &constructor) const {
for (const auto &[symRef, expr] : constructor) {
if (!IsConstantStructureConstructorComponent(*symRef, expr.value())) {
return false;
}
}
return true;
}
bool operator()(const Component &component) const {
return (*this)(component.base());
}
// Prevent integer division by known zeroes in constant expressions.
template <int KIND>
bool operator()(
const Divide<Type<TypeCategory::Integer, KIND>> &division) const {
using T = Type<TypeCategory::Integer, KIND>;
if ((*this)(division.left()) && (*this)(division.right())) {
const auto divisor{GetScalarConstantValue<T>(division.right())};
return !divisor || !divisor->IsZero();
} else {
return false;
}
}
bool operator()(const Constant<SomeDerived> &) const { return true; }
bool operator()(const DescriptorInquiry &x) const {
const Symbol &sym{x.base().GetLastSymbol()};
return INVARIANT && !IsAllocatable(sym) &&
(!IsDummy(sym) ||
(IsIntentIn(sym) && !IsOptional(sym) &&
!sym.attrs().test(semantics::Attr::VALUE)));
}
private:
bool IsConstantStructureConstructorComponent(
const Symbol &, const Expr<SomeType> &) const;
bool IsConstantExprShape(const Shape &) const;
};
template <bool INVARIANT>
bool IsConstantExprHelper<INVARIANT>::IsConstantStructureConstructorComponent(
const Symbol &component, const Expr<SomeType> &expr) const {
if (IsAllocatable(component)) {
return IsNullObjectPointer(&expr);
} else if (IsPointer(component)) {
return IsNullPointerOrAllocatable(&expr) || IsInitialDataTarget(expr) ||
IsInitialProcedureTarget(expr);
} else {
return (*this)(expr);
}
}
template <bool INVARIANT>
bool IsConstantExprHelper<INVARIANT>::operator()(
const ProcedureRef &call) const {
// LBOUND, UBOUND, and SIZE with truly constant DIM= arguments will have
// been rewritten into DescriptorInquiry operations.
if (const auto *intrinsic{std::get_if<SpecificIntrinsic>(&call.proc().u)}) {
const characteristics::Procedure &proc{intrinsic->characteristics.value()};
if (intrinsic->name == "kind" ||
intrinsic->name == IntrinsicProcTable::InvalidName ||
call.arguments().empty() || !call.arguments()[0]) {
// kind is always a constant, and we avoid cascading errors by considering
// invalid calls to intrinsics to be constant
return true;
} else if (intrinsic->name == "lbound") {
auto base{ExtractNamedEntity(call.arguments()[0]->UnwrapExpr())};
return base && IsConstantExprShape(GetLBOUNDs(*base));
} else if (intrinsic->name == "ubound") {
auto base{ExtractNamedEntity(call.arguments()[0]->UnwrapExpr())};
return base && IsConstantExprShape(GetUBOUNDs(*base));
} else if (intrinsic->name == "shape" || intrinsic->name == "size") {
auto shape{GetShape(call.arguments()[0]->UnwrapExpr())};
return shape && IsConstantExprShape(*shape);
} else if (proc.IsPure()) {
std::size_t j{0};
for (const auto &arg : call.arguments()) {
if (const auto *dataDummy{j < proc.dummyArguments.size()
? std::get_if<characteristics::DummyDataObject>(
&proc.dummyArguments[j].u)
: nullptr};
dataDummy &&
dataDummy->attrs.test(
characteristics::DummyDataObject::Attr::OnlyIntrinsicInquiry)) {
// The value of the argument doesn't matter
} else if (!arg) {
return false;
} else if (const auto *expr{arg->UnwrapExpr()};
!expr || !(*this)(*expr)) {
return false;
}
++j;
}
return true;
}
// TODO: STORAGE_SIZE
}
return false;
}
template <bool INVARIANT>
bool IsConstantExprHelper<INVARIANT>::IsConstantExprShape(
const Shape &shape) const {
for (const auto &extent : shape) {
if (!(*this)(extent)) {
return false;
}
}
return true;
}
template <typename A> bool IsConstantExpr(const A &x) {
return IsConstantExprHelper<false>{}(x);
}
template bool IsConstantExpr(const Expr<SomeType> &);
template bool IsConstantExpr(const Expr<SomeInteger> &);
template bool IsConstantExpr(const Expr<SubscriptInteger> &);
template bool IsConstantExpr(const StructureConstructor &);
// IsScopeInvariantExpr()
template <typename A> bool IsScopeInvariantExpr(const A &x) {
return IsConstantExprHelper<true>{}(x);
}
template bool IsScopeInvariantExpr(const Expr<SomeType> &);
template bool IsScopeInvariantExpr(const Expr<SomeInteger> &);
template bool IsScopeInvariantExpr(const Expr<SubscriptInteger> &);
// IsActuallyConstant()
struct IsActuallyConstantHelper {
template <typename A> bool operator()(const A &) { return false; }
template <typename T> bool operator()(const Constant<T> &) { return true; }
template <typename T> bool operator()(const Parentheses<T> &x) {
return (*this)(x.left());
}
template <typename T> bool operator()(const Expr<T> &x) {
return common::visit([=](const auto &y) { return (*this)(y); }, x.u);
}
bool operator()(const Expr<SomeType> &x) {
return common::visit([this](const auto &y) { return (*this)(y); }, x.u);
}
bool operator()(const StructureConstructor &x) {
for (const auto &pair : x) {
const Expr<SomeType> &y{pair.second.value()};
const auto sym{pair.first};
const bool compIsConstant{(*this)(y)};
// If an allocatable component is initialized by a constant,
// the structure constructor is not a constant.
if ((!compIsConstant && !IsNullPointerOrAllocatable(&y)) ||
(compIsConstant && IsAllocatable(sym))) {
return false;
}
}
return true;
}
template <typename A> bool operator()(const A *x) { return x && (*this)(*x); }
template <typename A> bool operator()(const std::optional<A> &x) {
return x && (*this)(*x);
}
};
template <typename A> bool IsActuallyConstant(const A &x) {
return IsActuallyConstantHelper{}(x);
}
template bool IsActuallyConstant(const Expr<SomeType> &);
template bool IsActuallyConstant(const Expr<SomeInteger> &);
template bool IsActuallyConstant(const Expr<SubscriptInteger> &);
template bool IsActuallyConstant(const std::optional<Expr<SubscriptInteger>> &);
// Object pointer initialization checking predicate IsInitialDataTarget().
// This code determines whether an expression is allowable as the static
// data address used to initialize a pointer with "=> x". See C765.
class IsInitialDataTargetHelper
: public AllTraverse<IsInitialDataTargetHelper, true> {
public:
using Base = AllTraverse<IsInitialDataTargetHelper, true>;
using Base::operator();
explicit IsInitialDataTargetHelper(parser::ContextualMessages *m)
: Base{*this}, messages_{m} {}
bool emittedMessage() const { return emittedMessage_; }
bool operator()(const BOZLiteralConstant &) const { return false; }
bool operator()(const NullPointer &) const { return true; }
template <typename T> bool operator()(const Constant<T> &) const {
return false;
}
bool operator()(const semantics::Symbol &symbol) {
// This function checks only base symbols, not components.
const Symbol &ultimate{symbol.GetUltimate()};
if (const auto *assoc{
ultimate.detailsIf<semantics::AssocEntityDetails>()}) {
if (const auto &expr{assoc->expr()}) {
if (IsVariable(*expr)) {
return (*this)(*expr);
} else if (messages_) {
messages_->Say(
"An initial data target may not be an associated expression ('%s')"_err_en_US,
ultimate.name());
emittedMessage_ = true;
}
}
return false;
} else if (!CheckVarOrComponent(ultimate)) {
return false;
} else if (!ultimate.attrs().test(semantics::Attr::TARGET)) {
if (messages_) {
messages_->Say(
"An initial data target may not be a reference to an object '%s' that lacks the TARGET attribute"_err_en_US,
ultimate.name());
emittedMessage_ = true;
}
return false;
} else if (!IsSaved(ultimate)) {
if (messages_) {
messages_->Say(
"An initial data target may not be a reference to an object '%s' that lacks the SAVE attribute"_err_en_US,
ultimate.name());
emittedMessage_ = true;
}
return false;
} else {
return true;
}
}
bool operator()(const StaticDataObject &) const { return false; }
bool operator()(const TypeParamInquiry &) const { return false; }
bool operator()(const Triplet &x) const {
return IsConstantExpr(x.lower()) && IsConstantExpr(x.upper()) &&
IsConstantExpr(x.stride());
}
bool operator()(const Subscript &x) const {
return common::visit(common::visitors{
[&](const Triplet &t) { return (*this)(t); },
[&](const auto &y) {
return y.value().Rank() == 0 &&
IsConstantExpr(y.value());
},
},
x.u);
}
bool operator()(const CoarrayRef &) const { return false; }
bool operator()(const Component &x) {
return CheckVarOrComponent(x.GetLastSymbol()) && (*this)(x.base());
}
bool operator()(const Substring &x) const {
return IsConstantExpr(x.lower()) && IsConstantExpr(x.upper()) &&
(*this)(x.parent());
}
bool operator()(const DescriptorInquiry &) const { return false; }
template <typename T> bool operator()(const ArrayConstructor<T> &) const {
return false;
}
bool operator()(const StructureConstructor &) const { return false; }
template <typename D, typename R, typename... O>
bool operator()(const Operation<D, R, O...> &) const {
return false;
}
template <typename T> bool operator()(const Parentheses<T> &x) const {
return (*this)(x.left());
}
bool operator()(const ProcedureRef &x) const {
if (const SpecificIntrinsic * intrinsic{x.proc().GetSpecificIntrinsic()}) {
return intrinsic->characteristics.value().attrs.test(
characteristics::Procedure::Attr::NullPointer) ||
intrinsic->characteristics.value().attrs.test(
characteristics::Procedure::Attr::NullAllocatable);
}
return false;
}
bool operator()(const Relational<SomeType> &) const { return false; }
private:
bool CheckVarOrComponent(const semantics::Symbol &symbol) {
const Symbol &ultimate{symbol.GetUltimate()};
const char *unacceptable{nullptr};
if (ultimate.Corank() > 0) {
unacceptable = "a coarray";
} else if (IsAllocatable(ultimate)) {
unacceptable = "an ALLOCATABLE";
} else if (IsPointer(ultimate)) {
unacceptable = "a POINTER";
} else {
return true;
}
if (messages_) {
messages_->Say(
"An initial data target may not be a reference to %s '%s'"_err_en_US,
unacceptable, ultimate.name());
emittedMessage_ = true;
}
return false;
}
parser::ContextualMessages *messages_;
bool emittedMessage_{false};
};
bool IsInitialDataTarget(
const Expr<SomeType> &x, parser::ContextualMessages *messages) {
IsInitialDataTargetHelper helper{messages};
bool result{helper(x)};
if (!result && messages && !helper.emittedMessage()) {
messages->Say(
"An initial data target must be a designator with constant subscripts"_err_en_US);
}
return result;
}
bool IsInitialProcedureTarget(const semantics::Symbol &symbol) {
const auto &ultimate{symbol.GetUltimate()};
return common::visit(
common::visitors{
[&](const semantics::SubprogramDetails &subp) {
return !subp.isDummy() && !subp.stmtFunction() &&
symbol.owner().kind() != semantics::Scope::Kind::MainProgram &&
symbol.owner().kind() != semantics::Scope::Kind::Subprogram;
},
[](const semantics::SubprogramNameDetails &x) {
return x.kind() != semantics::SubprogramKind::Internal;
},
[&](const semantics::ProcEntityDetails &proc) {
return !semantics::IsPointer(ultimate) && !proc.isDummy();
},
[](const auto &) { return false; },
},
ultimate.details());
}
bool IsInitialProcedureTarget(const ProcedureDesignator &proc) {
if (const auto *intrin{proc.GetSpecificIntrinsic()}) {
return !intrin->isRestrictedSpecific;
} else if (proc.GetComponent()) {
return false;
} else {
return IsInitialProcedureTarget(DEREF(proc.GetSymbol()));
}
}
bool IsInitialProcedureTarget(const Expr<SomeType> &expr) {
if (const auto *proc{std::get_if<ProcedureDesignator>(&expr.u)}) {
return IsInitialProcedureTarget(*proc);
} else {
return IsNullProcedurePointer(&expr);
}
}
class SuspiciousRealLiteralFinder
: public AnyTraverse<SuspiciousRealLiteralFinder> {
public:
using Base = AnyTraverse<SuspiciousRealLiteralFinder>;
SuspiciousRealLiteralFinder(int kind, FoldingContext &c)
: Base{*this}, kind_{kind}, context_{c} {}
using Base::operator();
template <int KIND>
bool operator()(const Constant<Type<TypeCategory::Real, KIND>> &x) const {
if (kind_ > KIND && x.result().isFromInexactLiteralConversion()) {
context_.Warn(common::UsageWarning::RealConstantWidening,
"Default real literal in REAL(%d) context might need a kind suffix, as its rounded value %s is inexact"_warn_en_US,
kind_, x.AsFortran());
return true;
} else {
return false;
}
}
template <int KIND>
bool operator()(const Constant<Type<TypeCategory::Complex, KIND>> &x) const {
if (kind_ > KIND && x.result().isFromInexactLiteralConversion()) {
context_.Warn(common::UsageWarning::RealConstantWidening,
"Default real literal in COMPLEX(%d) context might need a kind suffix, as its rounded value %s is inexact"_warn_en_US,
kind_, x.AsFortran());
return true;
} else {
return false;
}
}
template <TypeCategory TOCAT, int TOKIND, TypeCategory FROMCAT>
bool operator()(const Convert<Type<TOCAT, TOKIND>, FROMCAT> &x) const {
if constexpr ((TOCAT == TypeCategory::Real ||
TOCAT == TypeCategory::Complex) &&
(FROMCAT == TypeCategory::Real || FROMCAT == TypeCategory::Complex)) {
auto fromType{x.left().GetType()};
if (!fromType || fromType->kind() < TOKIND) {
return false;
}
}
return (*this)(x.left());
}
private:
int kind_;
FoldingContext &context_;
};
void CheckRealWidening(const Expr<SomeType> &expr, const DynamicType &toType,
FoldingContext &context) {
if (toType.category() == TypeCategory::Real ||
toType.category() == TypeCategory::Complex) {
if (auto fromType{expr.GetType()}) {
if ((fromType->category() == TypeCategory::Real ||
fromType->category() == TypeCategory::Complex) &&
toType.kind() > fromType->kind()) {
SuspiciousRealLiteralFinder{toType.kind(), context}(expr);
}
}
}
}
void CheckRealWidening(const Expr<SomeType> &expr,
const std::optional<DynamicType> &toType, FoldingContext &context) {
if (toType) {
CheckRealWidening(expr, *toType, context);
}
}
class InexactLiteralConversionFlagClearer
: public AnyTraverse<InexactLiteralConversionFlagClearer> {
public:
using Base = AnyTraverse<InexactLiteralConversionFlagClearer>;
InexactLiteralConversionFlagClearer() : Base(*this) {}
using Base::operator();
template <int KIND>
bool operator()(const Constant<Type<TypeCategory::Real, KIND>> &x) const {
auto &mut{const_cast<Type<TypeCategory::Real, KIND> &>(x.result())};
mut.set_isFromInexactLiteralConversion(false);
return false;
}
};
// Converts, folds, and then checks type, rank, and shape of an
// initialization expression for a named constant, a non-pointer
// variable static initialization, a component default initializer,
// a type parameter default value, or instantiated type parameter value.
std::optional<Expr<SomeType>> NonPointerInitializationExpr(const Symbol &symbol,
Expr<SomeType> &&x, FoldingContext &context,
const semantics::Scope *instantiation) {
CHECK(!IsPointer(symbol));
if (auto symTS{
characteristics::TypeAndShape::Characterize(symbol, context)}) {
auto xType{x.GetType()};
CheckRealWidening(x, symTS->type(), context);
auto converted{ConvertToType(symTS->type(), Expr<SomeType>{x})};
if (!converted &&
symbol.owner().context().IsEnabled(
common::LanguageFeature::LogicalIntegerAssignment)) {
converted = DataConstantConversionExtension(context, symTS->type(), x);
if (converted) {
context.Warn(common::LanguageFeature::LogicalIntegerAssignment,
"nonstandard usage: initialization of %s with %s"_port_en_US,
symTS->type().AsFortran(), x.GetType().value().AsFortran());
}
}
if (converted) {
auto folded{Fold(context, std::move(*converted))};
if (IsActuallyConstant(folded)) {
InexactLiteralConversionFlagClearer{}(folded);
int symRank{symTS->Rank()};
if (IsImpliedShape(symbol)) {
if (folded.Rank() == symRank) {
return ArrayConstantBoundChanger{
std::move(*AsConstantExtents(
context, GetRawLowerBounds(context, NamedEntity{symbol})))}
.ChangeLbounds(std::move(folded));
} else {
context.messages().Say(
"Implied-shape parameter '%s' has rank %d but its initializer has rank %d"_err_en_US,
symbol.name(), symRank, folded.Rank());
}
} else if (auto extents{AsConstantExtents(context, symTS->shape())};
extents && !HasNegativeExtent(*extents)) {
if (folded.Rank() == 0 && symRank == 0) {
// symbol and constant are both scalars
return {std::move(folded)};
} else if (folded.Rank() == 0 && symRank > 0) {
// expand the scalar constant to an array
return ScalarConstantExpander{std::move(*extents),
AsConstantExtents(
context, GetRawLowerBounds(context, NamedEntity{symbol}))}
.Expand(std::move(folded));
} else if (auto resultShape{GetShape(context, folded)}) {
CHECK(symTS->shape()); // Assumed-ranks cannot be initialized.
if (CheckConformance(context.messages(), *symTS->shape(),
*resultShape, CheckConformanceFlags::None,
"initialized object", "initialization expression")
.value_or(false /*fail if not known now to conform*/)) {
// make a constant array with adjusted lower bounds
return ArrayConstantBoundChanger{
std::move(*AsConstantExtents(context,
GetRawLowerBounds(context, NamedEntity{symbol})))}
.ChangeLbounds(std::move(folded));
}
}
} else if (IsNamedConstant(symbol)) {
if (IsExplicitShape(symbol)) {
context.messages().Say(
"Named constant '%s' array must have constant shape"_err_en_US,
symbol.name());
} else {
// Declaration checking handles other cases
}
} else {
context.messages().Say(
"Shape of initialized object '%s' must be constant"_err_en_US,
symbol.name());
}
} else if (IsErrorExpr(folded)) {
} else if (IsLenTypeParameter(symbol)) {
return {std::move(folded)};
} else if (IsKindTypeParameter(symbol)) {
if (instantiation) {
context.messages().Say(
"Value of kind type parameter '%s' (%s) must be a scalar INTEGER constant"_err_en_US,
symbol.name(), folded.AsFortran());
} else {
return {std::move(folded)};
}
} else if (IsNamedConstant(symbol)) {
if (symbol.name() == "numeric_storage_size" &&
symbol.owner().IsModule() &&
DEREF(symbol.owner().symbol()).name() == "iso_fortran_env") {
// Very special case: numeric_storage_size is not folded until
// it read from the iso_fortran_env module file, as its value
// depends on compilation options.
return {std::move(folded)};
}
context.messages().Say(
"Value of named constant '%s' (%s) cannot be computed as a constant value"_err_en_US,
symbol.name(), folded.AsFortran());
} else {
context.messages().Say(
"Initialization expression for '%s' (%s) cannot be computed as a constant value"_err_en_US,
symbol.name(), x.AsFortran());
}
} else if (xType) {
context.messages().Say(
"Initialization expression cannot be converted to declared type of '%s' from %s"_err_en_US,
symbol.name(), xType->AsFortran());
} else {
context.messages().Say(
"Initialization expression cannot be converted to declared type of '%s'"_err_en_US,
symbol.name());
}
}
return std::nullopt;
}
// Specification expression validation (10.1.11(2), C1010)
class CheckSpecificationExprHelper
: public AnyTraverse<CheckSpecificationExprHelper,
std::optional<std::string>> {
public:
using Result = std::optional<std::string>;
using Base = AnyTraverse<CheckSpecificationExprHelper, Result>;
explicit CheckSpecificationExprHelper(const semantics::Scope &s,
FoldingContext &context, bool forElementalFunctionResult)
: Base{*this}, scope_{s}, context_{context},
forElementalFunctionResult_{forElementalFunctionResult} {}
using Base::operator();
Result operator()(const CoarrayRef &) const { return "coindexed reference"; }
Result operator()(const semantics::Symbol &symbol) const {
const auto &ultimate{symbol.GetUltimate()};
const auto *object{ultimate.detailsIf<semantics::ObjectEntityDetails>()};
bool isInitialized{semantics::IsSaved(ultimate) &&
!IsAllocatable(ultimate) && object &&
(ultimate.test(Symbol::Flag::InDataStmt) ||
object->init().has_value())};
bool hasHostAssociation{
&symbol.owner() != &scope_ || &ultimate.owner() != &scope_};
if (const auto *assoc{
ultimate.detailsIf<semantics::AssocEntityDetails>()}) {
return (*this)(assoc->expr());
} else if (semantics::IsNamedConstant(ultimate) ||
ultimate.owner().IsModule() || ultimate.owner().IsSubmodule()) {
return std::nullopt;
} else if (scope_.IsDerivedType() &&
IsVariableName(ultimate)) { // C750, C754
return "derived type component or type parameter value not allowed to "
"reference variable '"s +
ultimate.name().ToString() + "'";
} else if (IsDummy(ultimate)) {
if (!inInquiry_ && forElementalFunctionResult_) {
return "dependence on value of dummy argument '"s +
ultimate.name().ToString() + "'";
} else if (ultimate.attrs().test(semantics::Attr::OPTIONAL)) {
return "reference to OPTIONAL dummy argument '"s +
ultimate.name().ToString() + "'";
} else if (!inInquiry_ && !hasHostAssociation &&
ultimate.attrs().test(semantics::Attr::INTENT_OUT)) {
return "reference to INTENT(OUT) dummy argument '"s +
ultimate.name().ToString() + "'";
} else if (!ultimate.has<semantics::ObjectEntityDetails>()) {
return "dummy procedure argument";
} else {
// Sketchy case: some compilers allow an INTENT(OUT) dummy argument
// to be used in a specification expression if it is host-associated.
// The arguments raised in support this usage, however, depend on
// a reading of the standard that would also accept an OPTIONAL
// host-associated dummy argument, and that doesn't seem like a
// good idea.
if (!inInquiry_ && hasHostAssociation &&
ultimate.attrs().test(semantics::Attr::INTENT_OUT)) {
context_.Warn(common::UsageWarning::HostAssociatedIntentOutInSpecExpr,
"specification expression refers to host-associated INTENT(OUT) dummy argument '%s'"_port_en_US,
ultimate.name());
}
return std::nullopt;
}
} else if (hasHostAssociation) {
return std::nullopt; // host association is in play
} else if (isInitialized &&
context_.languageFeatures().IsEnabled(
common::LanguageFeature::SavedLocalInSpecExpr)) {
context_.Warn(common::LanguageFeature::SavedLocalInSpecExpr,
"specification expression refers to local object '%s' (initialized and saved)"_port_en_US,
ultimate.name());
return std::nullopt;
} else if (const auto *object{
ultimate.detailsIf<semantics::ObjectEntityDetails>()}) {
if (object->commonBlock()) {
return std::nullopt;
}
}
if (inInquiry_) {
return std::nullopt;
} else {
return "reference to local entity '"s + ultimate.name().ToString() + "'";
}
}
Result operator()(const Component &x) const {
// Don't look at the component symbol.
return (*this)(x.base());
}
Result operator()(const ArrayRef &x) const {
if (auto result{(*this)(x.base())}) {
return result;
}
// The subscripts don't get special protection for being in a
// specification inquiry context;
auto restorer{common::ScopedSet(inInquiry_, false)};
return (*this)(x.subscript());
}
Result operator()(const Substring &x) const {
if (auto result{(*this)(x.parent())}) {
return result;
}
// The bounds don't get special protection for being in a
// specification inquiry context;
auto restorer{common::ScopedSet(inInquiry_, false)};
if (auto result{(*this)(x.lower())}) {
return result;
}
return (*this)(x.upper());
}
Result operator()(const DescriptorInquiry &x) const {
// Many uses of SIZE(), LBOUND(), &c. that are valid in specification
// expressions will have been converted to expressions over descriptor
// inquiries by Fold().
// Catch REAL, ALLOCATABLE :: X(:); REAL :: Y(SIZE(X))
if (IsPermissibleInquiry(
x.base().GetFirstSymbol(), x.base().GetLastSymbol(), x.field())) {
auto restorer{common::ScopedSet(inInquiry_, true)};
return (*this)(x.base());
} else if (IsConstantExpr(x)) {
return std::nullopt;
} else {
return "non-constant descriptor inquiry not allowed for local object";
}
}
Result operator()(const TypeParamInquiry &inq) const {
if (scope_.IsDerivedType()) {
if (!IsConstantExpr(inq) &&
inq.base() /* X%T, not local T */) { // C750, C754
return "non-constant reference to a type parameter inquiry not allowed "
"for derived type components or type parameter values";
}
} else if (inq.base() &&
IsInquiryAlwaysPermissible(inq.base()->GetFirstSymbol())) {
auto restorer{common::ScopedSet(inInquiry_, true)};
return (*this)(inq.base());
} else if (!IsConstantExpr(inq)) {
return "non-constant type parameter inquiry not allowed for local object";
}
return std::nullopt;
}
Result operator()(const ProcedureRef &x) const {
if (const auto *symbol{x.proc().GetSymbol()}) {
const Symbol &ultimate{symbol->GetUltimate()};
if (!semantics::IsPureProcedure(ultimate)) {
return "reference to impure function '"s + ultimate.name().ToString() +
"'";
}
if (semantics::IsStmtFunction(ultimate)) {
return "reference to statement function '"s +
ultimate.name().ToString() + "'";
}
if (scope_.IsDerivedType()) { // C750, C754
return "reference to function '"s + ultimate.name().ToString() +
"' not allowed for derived type components or type parameter"
" values";
}
if (auto procChars{characteristics::Procedure::Characterize(
x.proc(), context_, /*emitError=*/true)}) {
const auto iter{std::find_if(procChars->dummyArguments.begin(),
procChars->dummyArguments.end(),
[](const characteristics::DummyArgument &dummy) {
return std::holds_alternative<characteristics::DummyProcedure>(
dummy.u);
})};
if (iter != procChars->dummyArguments.end() &&
ultimate.name().ToString() != "__builtin_c_funloc") {
return "reference to function '"s + ultimate.name().ToString() +
"' with dummy procedure argument '" + iter->name + '\'';
}
}
// References to internal functions are caught in expression semantics.
// TODO: other checks for standard module procedures
auto restorer{common::ScopedSet(inInquiry_, false)};
return (*this)(x.arguments());
} else { // intrinsic
const SpecificIntrinsic &intrin{DEREF(x.proc().GetSpecificIntrinsic())};
bool inInquiry{context_.intrinsics().GetIntrinsicClass(intrin.name) ==
IntrinsicClass::inquiryFunction};
if (scope_.IsDerivedType()) { // C750, C754
if ((context_.intrinsics().IsIntrinsic(intrin.name) &&
badIntrinsicsForComponents_.find(intrin.name) !=
badIntrinsicsForComponents_.end())) {
return "reference to intrinsic '"s + intrin.name +
"' not allowed for derived type components or type parameter"
" values";
}
if (inInquiry && !IsConstantExpr(x)) {
return "non-constant reference to inquiry intrinsic '"s +
intrin.name +
"' not allowed for derived type components or type"
" parameter values";
}
}
// Type-determined inquiries (DIGITS, HUGE, &c.) will have already been
// folded and won't arrive here. Inquiries that are represented with
// DescriptorInquiry operations (LBOUND) are checked elsewhere. If a
// call that makes it to here satisfies the requirements of a constant
// expression (as Fortran defines it), it's fine.
if (IsConstantExpr(x)) {
return std::nullopt;
}
if (intrin.name == "present") {
return std::nullopt; // always ok
}
const auto &proc{intrin.characteristics.value()};
std::size_t j{0};
for (const auto &arg : x.arguments()) {
bool checkArg{true};
if (const auto *dataDummy{j < proc.dummyArguments.size()
? std::get_if<characteristics::DummyDataObject>(
&proc.dummyArguments[j].u)
: nullptr}) {
if (dataDummy->attrs.test(characteristics::DummyDataObject::Attr::
OnlyIntrinsicInquiry)) {
checkArg = false; // value unused, e.g. IEEE_SUPPORT_FLAG(,,,. X)
}
}
if (arg && checkArg) {
// Catch CHARACTER(:), ALLOCATABLE :: X; CHARACTER(LEN(X)) :: Y
if (inInquiry) {
if (auto dataRef{ExtractDataRef(*arg, true, true)}) {
if (intrin.name == "allocated" || intrin.name == "associated" ||
intrin.name == "is_contiguous") { // ok
} else if (intrin.name == "len" &&
IsPermissibleInquiry(dataRef->GetFirstSymbol(),
dataRef->GetLastSymbol(),
DescriptorInquiry::Field::Len)) { // ok
} else if (intrin.name == "lbound" &&
IsPermissibleInquiry(dataRef->GetFirstSymbol(),
dataRef->GetLastSymbol(),
DescriptorInquiry::Field::LowerBound)) { // ok
} else if ((intrin.name == "shape" || intrin.name == "size" ||
intrin.name == "sizeof" ||
intrin.name == "storage_size" ||
intrin.name == "ubound") &&
IsPermissibleInquiry(dataRef->GetFirstSymbol(),
dataRef->GetLastSymbol(),
DescriptorInquiry::Field::Extent)) { // ok
} else {
return "non-constant inquiry function '"s + intrin.name +
"' not allowed for local object";
}
}
}
auto restorer{common::ScopedSet(inInquiry_, inInquiry)};
if (auto err{(*this)(*arg)}) {
return err;
}
}
++j;
}
return std::nullopt;
}
}
private:
const semantics::Scope &scope_;
FoldingContext &context_;
// Contextual information: this flag is true when in an argument to
// an inquiry intrinsic like SIZE().
mutable bool inInquiry_{false};
bool forElementalFunctionResult_{false}; // F'2023 C15121
const std::set<std::string> badIntrinsicsForComponents_{
"allocated", "associated", "extends_type_of", "present", "same_type_as"};
bool IsInquiryAlwaysPermissible(const semantics::Symbol &) const;
bool IsPermissibleInquiry(const semantics::Symbol &firstSymbol,
const semantics::Symbol &lastSymbol,
DescriptorInquiry::Field field) const;
};
bool CheckSpecificationExprHelper::IsInquiryAlwaysPermissible(
const semantics::Symbol &symbol) const {
if (&symbol.owner() != &scope_ || symbol.has<semantics::UseDetails>() ||
symbol.owner().kind() == semantics::Scope::Kind::Module ||
semantics::FindCommonBlockContaining(symbol) ||
symbol.has<semantics::HostAssocDetails>()) {
return true; // it's nonlocal
} else if (semantics::IsDummy(symbol) && !forElementalFunctionResult_) {
return true;
} else {
return false;
}
}
bool CheckSpecificationExprHelper::IsPermissibleInquiry(
const semantics::Symbol &firstSymbol, const semantics::Symbol &lastSymbol,
DescriptorInquiry::Field field) const {
if (IsInquiryAlwaysPermissible(firstSymbol)) {
return true;
}
// Inquiries on local objects may not access a deferred bound or length.
// (This code used to be a switch, but it proved impossible to write it
// thus without running afoul of bogus warnings from different C++
// compilers.)
if (field == DescriptorInquiry::Field::Rank) {
return true; // always known
}
const auto *object{lastSymbol.detailsIf<semantics::ObjectEntityDetails>()};
if (field == DescriptorInquiry::Field::LowerBound ||
field == DescriptorInquiry::Field::Extent ||
field == DescriptorInquiry::Field::Stride) {
return object && !object->shape().CanBeDeferredShape();
}
if (field == DescriptorInquiry::Field::Len) {
return object && object->type() &&
object->type()->category() == semantics::DeclTypeSpec::Character &&
!object->type()->characterTypeSpec().length().isDeferred();
}
return false;
}
template <typename A>
void CheckSpecificationExpr(const A &x, const semantics::Scope &scope,
FoldingContext &context, bool forElementalFunctionResult) {
CheckSpecificationExprHelper errors{
scope, context, forElementalFunctionResult};
if (auto why{errors(x)}) {
context.messages().Say("Invalid specification expression%s: %s"_err_en_US,
forElementalFunctionResult ? " for elemental function result" : "",
*why);
}
}
template void CheckSpecificationExpr(const Expr<SomeType> &,
const semantics::Scope &, FoldingContext &,
bool forElementalFunctionResult);
template void CheckSpecificationExpr(const Expr<SomeInteger> &,
const semantics::Scope &, FoldingContext &,
bool forElementalFunctionResult);
template void CheckSpecificationExpr(const Expr<SubscriptInteger> &,
const semantics::Scope &, FoldingContext &,
bool forElementalFunctionResult);
template void CheckSpecificationExpr(const std::optional<Expr<SomeType>> &,
const semantics::Scope &, FoldingContext &,
bool forElementalFunctionResult);
template void CheckSpecificationExpr(const std::optional<Expr<SomeInteger>> &,
const semantics::Scope &, FoldingContext &,
bool forElementalFunctionResult);
template void CheckSpecificationExpr(
const std::optional<Expr<SubscriptInteger>> &, const semantics::Scope &,
FoldingContext &, bool forElementalFunctionResult);
// IsContiguous() -- 9.5.4
class IsContiguousHelper
: public AnyTraverse<IsContiguousHelper, std::optional<bool>> {
public:
using Result = std::optional<bool>; // tri-state
using Base = AnyTraverse<IsContiguousHelper, Result>;
explicit IsContiguousHelper(FoldingContext &c,
bool namedConstantSectionsAreContiguous,
bool firstDimensionStride1 = false)
: Base{*this}, context_{c},
namedConstantSectionsAreContiguous_{namedConstantSectionsAreContiguous},
firstDimensionStride1_{firstDimensionStride1} {}
using Base::operator();
template <typename T> Result operator()(const Constant<T> &) const {
return true;
}
Result operator()(const StaticDataObject &) const { return true; }
Result operator()(const semantics::Symbol &symbol) const {
const auto &ultimate{symbol.GetUltimate()};
if (ultimate.attrs().test(semantics::Attr::CONTIGUOUS)) {
return true;
} else if (!IsVariable(symbol)) {
return true;
} else if (ultimate.Rank() == 0) {
// Extension: accept scalars as a degenerate case of
// simple contiguity to allow their use in contexts like
// data targets in pointer assignments with remapping.
return true;
} else if (const auto *details{
ultimate.detailsIf<semantics::AssocEntityDetails>()}) {
// RANK(*) associating entity is contiguous.
if (details->IsAssumedSize()) {
return true;
} else if (!IsVariable(details->expr()) &&
(namedConstantSectionsAreContiguous_ ||
!ExtractDataRef(details->expr(), true, true))) {
// Selector is associated to an expression value.
return true;
} else {
return Base::operator()(ultimate); // use expr
}
} else if (semantics::IsPointer(ultimate) || IsAssumedShape(ultimate) ||
IsAssumedRank(ultimate)) {
return std::nullopt;
} else if (ultimate.has<semantics::ObjectEntityDetails>()) {
return true;
} else {
return Base::operator()(ultimate);
}
}
Result operator()(const ArrayRef &x) const {
if (x.Rank() == 0) {
return true; // scalars considered contiguous
}
int subscriptRank{0};
auto baseLbounds{GetLBOUNDs(context_, x.base())};
auto baseUbounds{GetUBOUNDs(context_, x.base())};
auto subscripts{CheckSubscripts(
x.subscript(), subscriptRank, &baseLbounds, &baseUbounds)};
if (!subscripts.value_or(false)) {
return subscripts; // subscripts not known to be contiguous
} else if (subscriptRank > 0) {
// a(1)%b(:,:) is contiguous if and only if a(1)%b is contiguous.
return (*this)(x.base());
} else {
// a(:)%b(1,1) is (probably) not contiguous.
return std::nullopt;
}
}
Result operator()(const CoarrayRef &x) const { return (*this)(x.base()); }
Result operator()(const Component &x) const {
if (x.base().Rank() == 0) {
return (*this)(x.GetLastSymbol());
} else {
const DataRef &base{x.base()};
if (Result baseIsContiguous{(*this)(base)}) {
if (!*baseIsContiguous) {
return false;
} else {
bool sizeKnown{false};
if (auto constShape{GetConstantExtents(context_, x)}) {
sizeKnown = true;
if (GetSize(*constShape) <= 1) {
return true; // empty or singleton
}
}
const Symbol &last{base.GetLastSymbol()};
if (auto type{DynamicType::From(last)}) {
CHECK(type->category() == TypeCategory::Derived);
if (!type->IsPolymorphic()) {
const auto &derived{type->GetDerivedTypeSpec()};
if (const auto *scope{derived.scope()}) {
auto iter{scope->begin()};
if (++iter == scope->end()) {
return true; // type has but one component
} else if (sizeKnown) {
return false; // multiple components & array size is known > 1
}
}
}
}
}
}
return std::nullopt;
}
}
Result operator()(const ComplexPart &x) const {
// TODO: should be true when base is empty array or singleton, too
return x.complex().Rank() == 0;
}
Result operator()(const Substring &x) const {
if (x.Rank() == 0) {
return true; // scalar substring always contiguous
}
// Substrings with rank must have DataRefs as their parents
const DataRef &parentDataRef{DEREF(x.GetParentIf<DataRef>())};
std::optional<std::int64_t> len;
if (auto lenExpr{parentDataRef.LEN()}) {
len = ToInt64(Fold(context_, std::move(*lenExpr)));
if (len) {
if (*len <= 0) {
return true; // empty substrings
} else if (*len == 1) {
// Substrings can't be incomplete; is base array contiguous?
return (*this)(parentDataRef);
}
}
}
std::optional<std::int64_t> upper;
bool upperIsLen{false};
if (auto upperExpr{x.upper()}) {
upper = ToInt64(Fold(context_, common::Clone(*upperExpr)));
if (upper) {
if (*upper < 1) {
return true; // substring(n:0) empty
}
upperIsLen = len && *upper >= *len;
} else if (const auto *inquiry{
UnwrapConvertedExpr<DescriptorInquiry>(*upperExpr)};
inquiry && inquiry->field() == DescriptorInquiry::Field::Len) {
upperIsLen =
&parentDataRef.GetLastSymbol() == &inquiry->base().GetLastSymbol();
}
} else {
upperIsLen = true; // substring(n:)
}
if (auto lower{ToInt64(Fold(context_, x.lower()))}) {
if (*lower == 1 && upperIsLen) {
// known complete substring; is base contiguous?
return (*this)(parentDataRef);
} else if (upper) {
if (*upper < *lower) {
return true; // empty substring(3:2)
} else if (*lower > 1) {
return false; // known incomplete substring
} else if (len && *upper < *len) {
return false; // known incomplete substring
}
}
}
return std::nullopt; // contiguity not known
}
Result operator()(const ProcedureRef &x) const {
if (auto chars{characteristics::Procedure::Characterize(
x.proc(), context_, /*emitError=*/true)}) {
if (chars->functionResult) {
const auto &result{*chars->functionResult};
if (!result.IsProcedurePointer()) {
if (result.attrs.test(
characteristics::FunctionResult::Attr::Contiguous)) {
return true;
}
if (!result.attrs.test(
characteristics::FunctionResult::Attr::Pointer)) {
return true;
}
if (const auto *type{result.GetTypeAndShape()};
type && type->Rank() == 0) {
return true; // pointer to scalar
}
// Must be non-CONTIGUOUS pointer to array
}
}
}
return std::nullopt;
}
Result operator()(const NullPointer &) const { return true; }
private:
// Returns "true" for a provably empty or simply contiguous array section;
// return "false" for a provably nonempty discontiguous section or for use
// of a vector subscript.
std::optional<bool> CheckSubscripts(const std::vector<Subscript> &subscript,
int &rank, const Shape *baseLbounds = nullptr,
const Shape *baseUbounds = nullptr) const {
bool anyTriplet{false};
rank = 0;
// Detect any provably empty dimension in this array section, which would
// render the whole section empty and therefore vacuously contiguous.
std::optional<bool> result;
bool mayBeEmpty{false};
auto dims{subscript.size()};
std::vector<bool> knownPartialSlice(dims, false);
for (auto j{dims}; j-- > 0;) {
if (j == 0 && firstDimensionStride1_ && !result.value_or(true)) {
result.reset(); // ignore problems on later dimensions
}
std::optional<ConstantSubscript> dimLbound;
std::optional<ConstantSubscript> dimUbound;
std::optional<ConstantSubscript> dimExtent;
if (baseLbounds && j < baseLbounds->size()) {
if (const auto &lb{baseLbounds->at(j)}) {
dimLbound = ToInt64(Fold(context_, Expr<SubscriptInteger>{*lb}));
}
}
if (baseUbounds && j < baseUbounds->size()) {
if (const auto &ub{baseUbounds->at(j)}) {
dimUbound = ToInt64(Fold(context_, Expr<SubscriptInteger>{*ub}));
}
}
if (dimLbound && dimUbound) {
if (*dimLbound <= *dimUbound) {
dimExtent = *dimUbound - *dimLbound + 1;
} else {
// This is an empty dimension.
result = true;
dimExtent = 0;
}
}
if (const auto *triplet{std::get_if<Triplet>(&subscript[j].u)}) {
++rank;
const Expr<SubscriptInteger> *lowerBound{triplet->GetLower()};
const Expr<SubscriptInteger> *upperBound{triplet->GetUpper()};
std::optional<ConstantSubscript> lowerVal{lowerBound
? ToInt64(Fold(context_, Expr<SubscriptInteger>{*lowerBound}))
: dimLbound};
std::optional<ConstantSubscript> upperVal{upperBound
? ToInt64(Fold(context_, Expr<SubscriptInteger>{*upperBound}))
: dimUbound};
if (auto stride{ToInt64(triplet->stride())}) {
if (j == 0 && *stride == 1 && firstDimensionStride1_) {
result = *stride == 1; // contiguous or empty if so
}
if (lowerVal && upperVal) {
if (*lowerVal < *upperVal) {
if (*stride < 0) {
result = true; // empty dimension
} else if (!result && *stride > 1 &&
*lowerVal + *stride <= *upperVal) {
result = false; // discontiguous if not empty
}
} else if (*lowerVal > *upperVal) {
if (*stride > 0) {
result = true; // empty dimension
} else if (!result && *stride < 0 &&
*lowerVal + *stride >= *upperVal) {
result = false; // discontiguous if not empty
}
} else { // bounds known and equal
if (j == 0 && firstDimensionStride1_) {
result = true; // stride doesn't matter
}
}
} else { // bounds not both known
mayBeEmpty = true;
}
} else { // stride not known
if (lowerVal && upperVal && *lowerVal == *upperVal) {
// stride doesn't matter when bounds are equal
if (j == 0 && firstDimensionStride1_) {
result = true;
}
} else {
mayBeEmpty = true;
}
}
} else if (subscript[j].Rank() > 0) { // vector subscript
++rank;
if (!result) {
result = false;
}
mayBeEmpty = true;
} else { // scalar subscript
if (dimExtent && *dimExtent > 1) {
knownPartialSlice[j] = true;
}
}
}
if (rank == 0) {
result = true; // scalar
}
if (result) {
return result;
}
// Not provably contiguous or discontiguous at this point.
// Return "true" if simply contiguous, otherwise nullopt.
for (auto j{subscript.size()}; j-- > 0;) {
if (const auto *triplet{std::get_if<Triplet>(&subscript[j].u)}) {
auto stride{ToInt64(triplet->stride())};
if (!stride || stride != 1) {
return std::nullopt;
} else if (anyTriplet) {
if (triplet->GetLower() || triplet->GetUpper()) {
// all triplets before the last one must be just ":" for
// simple contiguity
return std::nullopt;
}
} else {
anyTriplet = true;
}
++rank;
} else if (anyTriplet) {
// If the section cannot be empty, and this dimension's
// scalar subscript is known not to cover the whole
// dimension, then the array section is provably
// discontiguous.
return (mayBeEmpty || !knownPartialSlice[j])
? std::nullopt
: std::make_optional(false);
}
}
return true; // simply contiguous
}
FoldingContext &context_;
bool namedConstantSectionsAreContiguous_{false};
bool firstDimensionStride1_{false};
};
template <typename A>
std::optional<bool> IsContiguous(const A &x, FoldingContext &context,
bool namedConstantSectionsAreContiguous, bool firstDimensionStride1) {
if (!IsVariable(x) &&
(namedConstantSectionsAreContiguous || !ExtractDataRef(x, true, true))) {
return true;
} else {
return IsContiguousHelper{
context, namedConstantSectionsAreContiguous, firstDimensionStride1}(x);
}
}
std::optional<bool> IsContiguous(const ActualArgument &actual,
FoldingContext &fc, bool namedConstantSectionsAreContiguous,
bool firstDimensionStride1) {
auto *expr{actual.UnwrapExpr()};
return expr &&
IsContiguous(
*expr, fc, namedConstantSectionsAreContiguous, firstDimensionStride1);
}
template std::optional<bool> IsContiguous(const Expr<SomeType> &,
FoldingContext &, bool namedConstantSectionsAreContiguous,
bool firstDimensionStride1);
template std::optional<bool> IsContiguous(const ActualArgument &,
FoldingContext &, bool namedConstantSectionsAreContiguous,
bool firstDimensionStride1);
template std::optional<bool> IsContiguous(const ArrayRef &, FoldingContext &,
bool namedConstantSectionsAreContiguous, bool firstDimensionStride1);
template std::optional<bool> IsContiguous(const Substring &, FoldingContext &,
bool namedConstantSectionsAreContiguous, bool firstDimensionStride1);
template std::optional<bool> IsContiguous(const Component &, FoldingContext &,
bool namedConstantSectionsAreContiguous, bool firstDimensionStride1);
template std::optional<bool> IsContiguous(const ComplexPart &, FoldingContext &,
bool namedConstantSectionsAreContiguous, bool firstDimensionStride1);
template std::optional<bool> IsContiguous(const CoarrayRef &, FoldingContext &,
bool namedConstantSectionsAreContiguous, bool firstDimensionStride1);
template std::optional<bool> IsContiguous(const Symbol &, FoldingContext &,
bool namedConstantSectionsAreContiguous, bool firstDimensionStride1);
// IsErrorExpr()
struct IsErrorExprHelper : public AnyTraverse<IsErrorExprHelper, bool> {
using Result = bool;
using Base = AnyTraverse<IsErrorExprHelper, Result>;
IsErrorExprHelper() : Base{*this} {}
using Base::operator();
bool operator()(const SpecificIntrinsic &x) {
return x.name == IntrinsicProcTable::InvalidName;
}
};
template <typename A> bool IsErrorExpr(const A &x) {
return IsErrorExprHelper{}(x);
}
template bool IsErrorExpr(const Expr<SomeType> &);
// C1577
// TODO: Also check C1579 & C1582 here
class StmtFunctionChecker
: public AnyTraverse<StmtFunctionChecker, std::optional<parser::Message>> {
public:
using Result = std::optional<parser::Message>;
using Base = AnyTraverse<StmtFunctionChecker, Result>;
static constexpr auto feature{
common::LanguageFeature::StatementFunctionExtensions};
StmtFunctionChecker(const Symbol &sf, FoldingContext &context)
: Base{*this}, sf_{sf}, context_{context} {
if (!context_.languageFeatures().IsEnabled(feature)) {
severity_ = parser::Severity::Error;
} else if (context_.languageFeatures().ShouldWarn(feature)) {
severity_ = parser::Severity::Portability;
}
}
using Base::operator();
Result Return(parser::Message &&msg) const {
if (severity_) {
msg.set_severity(*severity_);
if (*severity_ != parser::Severity::Error) {
msg.set_languageFeature(feature);
}
}
return std::move(msg);
}
template <typename T> Result operator()(const ArrayConstructor<T> &) const {
if (severity_) {
return Return(parser::Message{sf_.name(),
"Statement function '%s' should not contain an array constructor"_port_en_US,
sf_.name()});
} else {
return std::nullopt;
}
}
Result operator()(const StructureConstructor &) const {
if (severity_) {
return Return(parser::Message{sf_.name(),
"Statement function '%s' should not contain a structure constructor"_port_en_US,
sf_.name()});
} else {
return std::nullopt;
}
}
Result operator()(const TypeParamInquiry &) const {
if (severity_) {
return Return(parser::Message{sf_.name(),
"Statement function '%s' should not contain a type parameter inquiry"_port_en_US,
sf_.name()});
} else {
return std::nullopt;
}
}
Result operator()(const ProcedureDesignator &proc) const {
if (const Symbol * symbol{proc.GetSymbol()}) {
const Symbol &ultimate{symbol->GetUltimate()};
if (const auto *subp{
ultimate.detailsIf<semantics::SubprogramDetails>()}) {
if (subp->stmtFunction() && &ultimate.owner() == &sf_.owner()) {
if (ultimate.name().begin() > sf_.name().begin()) {
return parser::Message{sf_.name(),
"Statement function '%s' may not reference another statement function '%s' that is defined later"_err_en_US,
sf_.name(), ultimate.name()};
}
}
}
if (auto chars{characteristics::Procedure::Characterize(
proc, context_, /*emitError=*/true)}) {
if (!chars->CanBeCalledViaImplicitInterface()) {
if (severity_) {
return Return(parser::Message{sf_.name(),
"Statement function '%s' should not reference function '%s' that requires an explicit interface"_port_en_US,
sf_.name(), symbol->name()});
}
}
}
}
if (proc.Rank() > 0) {
if (severity_) {
return Return(parser::Message{sf_.name(),
"Statement function '%s' should not reference a function that returns an array"_port_en_US,
sf_.name()});
}
}
return std::nullopt;
}
Result operator()(const ActualArgument &arg) const {
if (const auto *expr{arg.UnwrapExpr()}) {
if (auto result{(*this)(*expr)}) {
return result;
}
if (expr->Rank() > 0 && !UnwrapWholeSymbolOrComponentDataRef(*expr)) {
if (severity_) {
return Return(parser::Message{sf_.name(),
"Statement function '%s' should not pass an array argument that is not a whole array"_port_en_US,
sf_.name()});
}
}
}
return std::nullopt;
}
private:
const Symbol &sf_;
FoldingContext &context_;
std::optional<parser::Severity> severity_;
};
std::optional<parser::Message> CheckStatementFunction(
const Symbol &sf, const Expr<SomeType> &expr, FoldingContext &context) {
return StmtFunctionChecker{sf, context}(expr);
}
// Helper class for checking differences between actual and dummy arguments
class CopyInOutExplicitInterface {
public:
explicit CopyInOutExplicitInterface(FoldingContext &fc,
const ActualArgument &actual,
const characteristics::DummyDataObject &dummyObj)
: fc_{fc}, actual_{actual}, dummyObj_{dummyObj} {}
// Returns true, if actual and dummy have different contiguity requirements
bool HaveContiguityDifferences() const {
// Check actual contiguity, unless dummy doesn't care
bool dummyTreatAsArray{dummyObj_.ignoreTKR.test(common::IgnoreTKR::Rank)};
bool actualTreatAsContiguous{
dummyObj_.ignoreTKR.test(common::IgnoreTKR::Contiguous) ||
IsSimplyContiguous(actual_, fc_)};
bool dummyIsExplicitShape{dummyObj_.type.IsExplicitShape()};
bool dummyIsAssumedSize{dummyObj_.type.attrs().test(
characteristics::TypeAndShape::Attr::AssumedSize)};
bool dummyIsPolymorphic{dummyObj_.type.type().IsPolymorphic()};
// type(*) with IGNORE_TKR(tkr) is often used to interface with C "void*".
// Since the other languages don't know about Fortran's discontiguity
// handling, such cases should require contiguity.
bool dummyIsVoidStar{dummyObj_.type.type().IsAssumedType() &&
dummyObj_.ignoreTKR.test(common::IgnoreTKR::Type) &&
dummyObj_.ignoreTKR.test(common::IgnoreTKR::Rank) &&
dummyObj_.ignoreTKR.test(common::IgnoreTKR::Kind)};
// Explicit shape and assumed size arrays must be contiguous
bool dummyNeedsContiguity{dummyIsExplicitShape || dummyIsAssumedSize ||
(dummyTreatAsArray && !dummyIsPolymorphic) || dummyIsVoidStar ||
dummyObj_.attrs.test(
characteristics::DummyDataObject::Attr::Contiguous)};
return !actualTreatAsContiguous && dummyNeedsContiguity;
}
// Returns true, if actual and dummy have polymorphic differences
bool HavePolymorphicDifferences() const {
bool dummyIsAssumedRank{dummyObj_.type.attrs().test(
characteristics::TypeAndShape::Attr::AssumedRank)};
bool actualIsAssumedRank{semantics::IsAssumedRank(actual_)};
bool dummyIsAssumedShape{dummyObj_.type.attrs().test(
characteristics::TypeAndShape::Attr::AssumedShape)};
bool actualIsAssumedShape{semantics::IsAssumedShape(actual_)};
if ((actualIsAssumedRank && dummyIsAssumedRank) ||
(actualIsAssumedShape && dummyIsAssumedShape)) {
// Assumed-rank and assumed-shape arrays are represented by descriptors,
// so don't need to do polymorphic check.
} else if (!dummyObj_.ignoreTKR.test(common::IgnoreTKR::Type)) {
// flang supports limited cases of passing polymorphic to non-polimorphic.
// These cases require temporary of non-polymorphic type. (For example,
// the actual argument could be polymorphic array of child type,
// while the dummy argument could be non-polymorphic array of parent
// type.)
bool dummyIsPolymorphic{dummyObj_.type.type().IsPolymorphic()};
auto actualType{
characteristics::TypeAndShape::Characterize(actual_, fc_)};
bool actualIsPolymorphic{
actualType && actualType->type().IsPolymorphic()};
if (actualIsPolymorphic && !dummyIsPolymorphic) {
return true;
}
}
return false;
}
bool HaveArrayOrAssumedRankArgs() const {
bool dummyTreatAsArray{dummyObj_.ignoreTKR.test(common::IgnoreTKR::Rank)};
return IsArrayOrAssumedRank(actual_) &&
(IsArrayOrAssumedRank(dummyObj_) || dummyTreatAsArray);
}
bool PassByValue() const {
return dummyObj_.attrs.test(characteristics::DummyDataObject::Attr::Value);
}
bool HaveCoarrayDifferences() const {
return ExtractCoarrayRef(actual_) && dummyObj_.type.corank() == 0;
}
bool HasIntentOut() const { return dummyObj_.intent == common::Intent::Out; }
bool HasIntentIn() const { return dummyObj_.intent == common::Intent::In; }
static bool IsArrayOrAssumedRank(const ActualArgument &actual) {
return semantics::IsAssumedRank(actual) || actual.Rank() > 0;
}
static bool IsArrayOrAssumedRank(
const characteristics::DummyDataObject &dummy) {
return dummy.type.attrs().test(
characteristics::TypeAndShape::Attr::AssumedRank) ||
dummy.type.Rank() > 0;
}
private:
FoldingContext &fc_;
const ActualArgument &actual_;
const characteristics::DummyDataObject &dummyObj_;
};
// If forCopyOut is false, returns if a particular actual/dummy argument
// combination may need a temporary creation with copy-in operation. If
// forCopyOut is true, returns the same for copy-out operation. For
// procedures with explicit interface, it's expected that "dummy" is not null.
// For procedures with implicit interface dummy may be null.
//
// Note that these copy-in and copy-out checks are done from the caller's
// perspective, meaning that for copy-in the caller need to do the copy
// before calling the callee. Similarly, for copy-out the caller is expected
// to do the copy after the callee returns.
bool MayNeedCopy(const ActualArgument *actual,
const characteristics::DummyArgument *dummy, FoldingContext &fc,
bool forCopyOut) {
if (!actual) {
return false;
}
if (actual->isAlternateReturn()) {
return false;
}
const auto *dummyObj{dummy
? std::get_if<characteristics::DummyDataObject>(&dummy->u)
: nullptr};
const bool forCopyIn = !forCopyOut;
if (!evaluate::IsVariable(*actual)) {
// Actual argument expressions that aren’t variables are copy-in, but
// not copy-out.
return forCopyIn;
}
if (dummyObj) { // Explict interface
CopyInOutExplicitInterface check{fc, *actual, *dummyObj};
if (forCopyOut && check.HasIntentIn()) {
// INTENT(IN) dummy args never need copy-out
return false;
}
if (forCopyIn && check.HasIntentOut()) {
// INTENT(OUT) dummy args never need copy-in
return false;
}
if (check.PassByValue()) {
// Pass by value, always copy-in, never copy-out
return forCopyIn;
}
if (check.HaveCoarrayDifferences()) {
return true;
}
// Note: contiguity and polymorphic checks deal with array or assumed rank
// arguments
if (!check.HaveArrayOrAssumedRankArgs()) {
return false;
}
if (check.HaveContiguityDifferences()) {
return true;
}
if (check.HavePolymorphicDifferences()) {
return true;
}
} else { // Implicit interface
if (ExtractCoarrayRef(*actual)) {
// Coindexed actual args may need copy-in and copy-out with implicit
// interface
return true;
}
if (!IsSimplyContiguous(*actual, fc)) {
// Copy-in: actual arguments that are variables are copy-in when
// non-contiguous.
// Copy-out: vector subscripts could refer to duplicate elements, can't
// copy out.
return !(forCopyOut && HasVectorSubscript(*actual));
}
}
// For everything else, no copy-in or copy-out
return false;
}
} // namespace Fortran::evaluate