shylie/llvm-project
1
0
Fork 0
Code Issues Pull Requests Actions 6 Packages Projects Releases Wiki Activity
llvm-project/flang/lib/Semantics/check-allocate.cpp
Peter Klausler 5fc77c1666
[flang] Add new warnings for unused & undefined locals (#173504) 
Add a requested warning for completely unused local variables. The
implementation runs a scan over typed expressions during the existing
expression semantics pass to detect variable uses, and a routine at the
end of semantics to take a pass over the symbol tables to find unused
locals.

The new infrastructure needed to detect variable uses, and the existing
infrastructure that detects potential variable definitions, then makes
it easy to detect variables that are used without any possible
initialization or definition, so I did that too.

The warning for unused locals is off by default -- they might indicate a
misspelling (that IMPLICIT NONE would have caught), but seem otherwise
generally benign. The warning for uses of completely uninitialized and
undefined variables, however, is enabled by default, since that's likely
to indicate a program bug that should be investigated.

This patch touches a lot of files lightly. Many of these files are tests
that would have produced needless warning noise; one new test was added.

Fixes https://github.com/llvm/llvm-project/issues/173276.
2025-12-31 12:42:06 -08:00

839 lines
33 KiB
C++
Raw Blame History

//===-- lib/Semantics/check-allocate.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-allocate.h"
#include "assignment.h"
#include "definable.h"
#include "flang/Evaluate/fold.h"
#include "flang/Evaluate/shape.h"
#include "flang/Evaluate/type.h"
#include "flang/Parser/parse-tree.h"
#include "flang/Parser/tools.h"
#include "flang/Semantics/attr.h"
#include "flang/Semantics/expression.h"
#include "flang/Semantics/tools.h"
#include "flang/Semantics/type.h"
namespace Fortran::semantics {
struct AllocateCheckerInfo {
const DeclTypeSpec *typeSpec{nullptr};
std::optional<evaluate::DynamicType> sourceExprType;
std::optional<parser::CharBlock> sourceExprLoc;
std::optional<parser::CharBlock> typeSpecLoc;
std::optional<parser::CharBlock> statSource;
std::optional<parser::CharBlock> msgSource;
const SomeExpr *statVar{nullptr};
const SomeExpr *msgVar{nullptr};
int sourceExprRank{0}; // only valid if gotMold || gotSource
bool gotStat{false};
bool gotMsg{false};
bool gotTypeSpec{false};
bool gotSource{false};
bool gotMold{false};
bool gotStream{false};
bool gotPinned{false};
std::optional<evaluate::ConstantSubscripts> sourceExprShape;
};
class AllocationCheckerHelper {
public:
AllocationCheckerHelper(
const parser::Allocation &alloc, AllocateCheckerInfo &info)
: allocateInfo_{info}, allocation_{alloc},
allocateObject_{std::get<parser::AllocateObject>(alloc.t)},
allocateShapeSpecRank_{ShapeSpecRank(alloc)},
allocateCoarraySpecRank_{CoarraySpecRank(alloc)} {}
bool RunChecks(SemanticsContext &context);
private:
bool hasAllocateShapeSpecList() const { return allocateShapeSpecRank_ != 0; }
bool hasAllocateCoarraySpec() const { return allocateCoarraySpecRank_ != 0; }
bool RunCoarrayRelatedChecks(SemanticsContext &) const;
static int ShapeSpecRank(const parser::Allocation &allocation) {
return static_cast<int>(
std::get<std::list<parser::AllocateShapeSpec>>(allocation.t).size());
}
static int CoarraySpecRank(const parser::Allocation &allocation) {
if (const auto &coarraySpec{
std::get<std::optional<parser::AllocateCoarraySpec>>(
allocation.t)}) {
return std::get<std::list<parser::AllocateCoshapeSpec>>(coarraySpec->t)
.size() +
1;
} else {
return 0;
}
}
void GatherAllocationBasicInfo() {
if (type_->category() == DeclTypeSpec::Category::Character) {
hasDeferredTypeParameter_ =
type_->characterTypeSpec().length().isDeferred();
} else if (const DerivedTypeSpec * derivedTypeSpec{type_->AsDerived()}) {
for (const auto &pair : derivedTypeSpec->parameters()) {
hasDeferredTypeParameter_ |= pair.second.isDeferred();
}
isAbstract_ = derivedTypeSpec->typeSymbol().attrs().test(Attr::ABSTRACT);
}
isUnlimitedPolymorphic_ =
type_->category() == DeclTypeSpec::Category::ClassStar;
}
AllocateCheckerInfo &allocateInfo_;
const parser::Allocation &allocation_;
const parser::AllocateObject &allocateObject_;
const int allocateShapeSpecRank_{0};
const int allocateCoarraySpecRank_{0};
const parser::Name &name_{parser::GetLastName(allocateObject_)};
// no USE or host association
const Symbol *ultimate_{
name_.symbol ? &name_.symbol->GetUltimate() : nullptr};
const DeclTypeSpec *type_{ultimate_ ? ultimate_->GetType() : nullptr};
const int rank_{ultimate_ ? ultimate_->Rank() : 0};
const int corank_{ultimate_ ? ultimate_->Corank() : 0};
bool hasDeferredTypeParameter_{false};
bool isUnlimitedPolymorphic_{false};
bool isAbstract_{false};
};
static std::optional<AllocateCheckerInfo> CheckAllocateOptions(
const parser::AllocateStmt &allocateStmt, SemanticsContext &context) {
AllocateCheckerInfo info;
bool stopCheckingAllocate{false}; // for errors that would lead to ambiguity
if (const auto &typeSpec{
std::get<std::optional<parser::TypeSpec>>(allocateStmt.t)}) {
info.typeSpec = typeSpec->declTypeSpec;
if (!info.typeSpec) {
CHECK(context.AnyFatalError());
return std::nullopt;
}
info.gotTypeSpec = true;
info.typeSpecLoc = parser::FindSourceLocation(*typeSpec);
if (const DerivedTypeSpec * derived{info.typeSpec->AsDerived()}) {
// C937
if (auto it{FindCoarrayUltimateComponent(*derived)}) {
context
.Say(
"Type-spec in ALLOCATE must not specify a type with a coarray ultimate component"_err_en_US)
.Attach(it->name(),
"Type '%s' has coarray ultimate component '%s' declared here"_en_US,
info.typeSpec->AsFortran(), it.BuildResultDesignatorName());
}
}
if (auto dyType{evaluate::DynamicType::From(*info.typeSpec)}) {
if (dyType->HasDeferredTypeParameter()) {
context.Say(
"Type-spec in ALLOCATE must not have a deferred type parameter"_err_en_US);
}
}
}
const parser::Expr *parserSourceExpr{nullptr};
for (const parser::AllocOpt &allocOpt :
std::get<std::list<parser::AllocOpt>>(allocateStmt.t)) {
common::visit(
common::visitors{
[&](const parser::StatOrErrmsg &statOrErr) {
common::visit(
common::visitors{
[&](const parser::StatVariable &var) {
if (info.gotStat) { // C943
context.Say(
"STAT may not be duplicated in a ALLOCATE statement"_err_en_US);
}
info.gotStat = true;
info.statVar = GetExpr(context, var);
info.statSource =
parser::Unwrap<parser::Variable>(var)->GetSource();
},
[&](const parser::MsgVariable &var) {
WarnOnDeferredLengthCharacterScalar(context,
GetExpr(context, var),
parser::UnwrapRef<parser::Variable>(var)
.GetSource(),
"ERRMSG=");
if (info.gotMsg) { // C943
context.Say(
"ERRMSG may not be duplicated in a ALLOCATE statement"_err_en_US);
}
info.gotMsg = true;
info.msgVar = GetExpr(context, var);
info.msgSource =
parser::Unwrap<parser::Variable>(var)->GetSource();
},
},
statOrErr.u);
},
[&](const parser::AllocOpt::Source &source) {
if (info.gotSource) { // C943
context.Say(
"SOURCE may not be duplicated in a ALLOCATE statement"_err_en_US);
stopCheckingAllocate = true;
}
if (info.gotMold || info.gotTypeSpec) { // C944
context.Say(
"At most one of source-expr and type-spec may appear in a ALLOCATE statement"_err_en_US);
stopCheckingAllocate = true;
}
parserSourceExpr = &source.v.value();
info.gotSource = true;
},
[&](const parser::AllocOpt::Mold &mold) {
if (info.gotMold) { // C943
context.Say(
"MOLD may not be duplicated in a ALLOCATE statement"_err_en_US);
stopCheckingAllocate = true;
}
if (info.gotSource || info.gotTypeSpec) { // C944
context.Say(
"At most one of source-expr and type-spec may appear in a ALLOCATE statement"_err_en_US);
stopCheckingAllocate = true;
}
parserSourceExpr = &mold.v.value();
info.gotMold = true;
},
[&](const parser::AllocOpt::Stream &stream) { // CUDA
if (info.gotStream) {
context.Say(
"STREAM may not be duplicated in a ALLOCATE statement"_err_en_US);
stopCheckingAllocate = true;
}
info.gotStream = true;
},
[&](const parser::AllocOpt::Pinned &pinned) { // CUDA
if (info.gotPinned) {
context.Say(
"PINNED may not be duplicated in a ALLOCATE statement"_err_en_US);
stopCheckingAllocate = true;
}
info.gotPinned = true;
},
},
allocOpt.u);
}
if (stopCheckingAllocate) {
return std::nullopt;
}
if (info.gotSource || info.gotMold) {
if (const auto *expr{GetExpr(context, DEREF(parserSourceExpr))}) {
parser::CharBlock at{parserSourceExpr->source};
info.sourceExprType = expr->GetType();
if (!info.sourceExprType) {
context.Say(at,
"Typeless item not allowed as SOURCE or MOLD in ALLOCATE"_err_en_US);
return std::nullopt;
}
info.sourceExprRank = expr->Rank();
info.sourceExprLoc = parserSourceExpr->source;
if (const DerivedTypeSpec *
derived{evaluate::GetDerivedTypeSpec(info.sourceExprType)}) {
// C949
if (auto it{FindCoarrayUltimateComponent(*derived)}) {
context
.Say(at,
"SOURCE or MOLD expression must not have a type with a coarray ultimate component"_err_en_US)
.Attach(it->name(),
"Type '%s' has coarray ultimate component '%s' declared here"_en_US,
info.sourceExprType.value().AsFortran(),
it.BuildResultDesignatorName());
}
if (info.gotSource) {
// C948
if (IsEventTypeOrLockType(derived)) {
context.Say(at,
"SOURCE expression type must not be EVENT_TYPE or LOCK_TYPE from ISO_FORTRAN_ENV"_err_en_US);
} else if (auto it{FindEventOrLockPotentialComponent(*derived)}) {
context
.Say(at,
"SOURCE expression type must not have potential subobject "
"component"
" of type EVENT_TYPE or LOCK_TYPE from ISO_FORTRAN_ENV"_err_en_US)
.Attach(it->name(),
"Type '%s' has potential ultimate component '%s' declared here"_en_US,
info.sourceExprType.value().AsFortran(),
it.BuildResultDesignatorName());
}
}
}
if (info.gotSource) { // C1594(6) - SOURCE= restrictions when pure
const Scope &scope{context.FindScope(at)};
if (FindPureProcedureContaining(scope)) {
parser::ContextualMessages messages{at, &context.messages()};
CheckCopyabilityInPureScope(messages, *expr, scope);
}
}
auto maybeShape{evaluate::GetShape(context.foldingContext(), *expr)};
info.sourceExprShape =
evaluate::AsConstantExtents(context.foldingContext(), maybeShape);
} else {
// Error already reported on source expression.
// Do not continue allocate checks.
return std::nullopt;
}
}
return info;
}
// Beware, type compatibility is not symmetric, IsTypeCompatible checks that
// type1 is type compatible with type2. Note: type parameters are not considered
// in this test.
static bool IsTypeCompatible(
const DeclTypeSpec &type1, const DerivedTypeSpec &derivedType2) {
if (const DerivedTypeSpec * derivedType1{type1.AsDerived()}) {
if (type1.category() == DeclTypeSpec::Category::TypeDerived) {
return evaluate::AreSameDerivedTypeIgnoringTypeParameters(
*derivedType1, derivedType2);
} else if (type1.category() == DeclTypeSpec::Category::ClassDerived) {
for (const DerivedTypeSpec *parent{&derivedType2}; parent;
parent = parent->typeSymbol().GetParentTypeSpec()) {
if (evaluate::AreSameDerivedTypeIgnoringTypeParameters(
*derivedType1, *parent)) {
return true;
}
}
}
}
return false;
}
static bool IsTypeCompatible(
const DeclTypeSpec &type1, const DeclTypeSpec &type2) {
if (type1.category() == DeclTypeSpec::Category::ClassStar) {
// TypeStar does not make sense in allocate context because assumed type
// cannot be allocatable (C709)
return true;
}
if (const IntrinsicTypeSpec * intrinsicType2{type2.AsIntrinsic()}) {
if (const IntrinsicTypeSpec * intrinsicType1{type1.AsIntrinsic()}) {
return intrinsicType1->category() == intrinsicType2->category();
} else {
return false;
}
} else if (const DerivedTypeSpec * derivedType2{type2.AsDerived()}) {
return IsTypeCompatible(type1, *derivedType2);
}
return false;
}
static bool IsTypeCompatible(
const DeclTypeSpec &type1, const evaluate::DynamicType &type2) {
if (type1.category() == DeclTypeSpec::Category::ClassStar) {
// TypeStar does not make sense in allocate context because assumed type
// cannot be allocatable (C709)
return true;
}
if (type2.category() != evaluate::TypeCategory::Derived) {
if (const IntrinsicTypeSpec * intrinsicType1{type1.AsIntrinsic()}) {
return intrinsicType1->category() == type2.category();
} else {
return false;
}
} else if (!type2.IsUnlimitedPolymorphic()) {
return IsTypeCompatible(type1, type2.GetDerivedTypeSpec());
}
return false;
}
// Note: Check assumes type1 is compatible with type2. type2 may have more type
// parameters than type1 but if a type2 type parameter is assumed, then this
// check enforce that type1 has it. type1 can be unlimited polymorphic, but not
// type2.
static bool HaveSameAssumedTypeParameters(
const DeclTypeSpec &type1, const DeclTypeSpec &type2) {
if (type2.category() == DeclTypeSpec::Category::Character) {
bool type2LengthIsAssumed{type2.characterTypeSpec().length().isAssumed()};
if (type1.category() == DeclTypeSpec::Category::Character) {
return type1.characterTypeSpec().length().isAssumed() ==
type2LengthIsAssumed;
}
// It is possible to reach this if type1 is unlimited polymorphic
return !type2LengthIsAssumed;
} else if (const DerivedTypeSpec * derivedType2{type2.AsDerived()}) {
int type2AssumedParametersCount{0};
int type1AssumedParametersCount{0};
for (const auto &pair : derivedType2->parameters()) {
type2AssumedParametersCount += pair.second.isAssumed();
}
// type1 may be unlimited polymorphic
if (const DerivedTypeSpec * derivedType1{type1.AsDerived()}) {
for (auto it{derivedType1->parameters().begin()};
it != derivedType1->parameters().end(); ++it) {
if (it->second.isAssumed()) {
++type1AssumedParametersCount;
const ParamValue *param{derivedType2->FindParameter(it->first)};
if (!param || !param->isAssumed()) {
// type1 has an assumed parameter that is not a type parameter of
// type2 or not assumed in type2.
return false;
}
}
}
}
// Will return false if type2 has type parameters that are not assumed in
// type1 or do not exist in type1
return type1AssumedParametersCount == type2AssumedParametersCount;
}
return true; // other intrinsic types have no length type parameters
}
static std::optional<std::int64_t> GetTypeParameterInt64Value(
const Symbol &parameterSymbol, const DerivedTypeSpec &derivedType) {
if (const ParamValue *
paramValue{derivedType.FindParameter(parameterSymbol.name())}) {
return evaluate::ToInt64(paramValue->GetExplicit());
}
return std::nullopt;
}
static bool HaveCompatibleTypeParameters(
const DerivedTypeSpec &derivedType1, const DerivedTypeSpec &derivedType2) {
for (const Symbol &symbol :
OrderParameterDeclarations(derivedType1.typeSymbol())) {
auto v1{GetTypeParameterInt64Value(symbol, derivedType1)};
auto v2{GetTypeParameterInt64Value(symbol, derivedType2)};
if (v1 && v2 && *v1 != *v2) {
return false;
}
}
return true;
}
static bool HaveCompatibleTypeParameters(
const DeclTypeSpec &type1, const evaluate::DynamicType &type2) {
if (type1.category() == DeclTypeSpec::Category::ClassStar) {
return true;
}
if (const IntrinsicTypeSpec * intrinsicType1{type1.AsIntrinsic()}) {
return evaluate::ToInt64(intrinsicType1->kind()).value() == type2.kind();
} else if (type2.IsUnlimitedPolymorphic()) {
return false;
} else if (const DerivedTypeSpec * derivedType1{type1.AsDerived()}) {
return HaveCompatibleTypeParameters(
*derivedType1, type2.GetDerivedTypeSpec());
} else {
common::die("unexpected type1 category");
}
}
static bool HaveCompatibleTypeParameters(
const DeclTypeSpec &type1, const DeclTypeSpec &type2) {
if (type1.category() == DeclTypeSpec::Category::ClassStar) {
return true;
} else if (const IntrinsicTypeSpec * intrinsicType1{type1.AsIntrinsic()}) {
const IntrinsicTypeSpec *intrinsicType2{type2.AsIntrinsic()};
return !intrinsicType2 || intrinsicType1->kind() == intrinsicType2->kind();
} else if (const DerivedTypeSpec * derivedType1{type1.AsDerived()}) {
const DerivedTypeSpec *derivedType2{type2.AsDerived()};
return !derivedType2 ||
HaveCompatibleTypeParameters(*derivedType1, *derivedType2);
} else {
common::die("unexpected type1 category");
}
}
static bool HaveCompatibleLengths(
const DeclTypeSpec &type1, const DeclTypeSpec &type2) {
if (type1.category() == DeclTypeSpec::Character &&
type2.category() == DeclTypeSpec::Character) {
auto v1{
evaluate::ToInt64(type1.characterTypeSpec().length().GetExplicit())};
auto v2{
evaluate::ToInt64(type2.characterTypeSpec().length().GetExplicit())};
return !v1 || !v2 || (*v1 >= 0 ? *v1 : 0) == (*v2 >= 0 ? *v2 : 0);
} else {
return true;
}
}
static bool HaveCompatibleLengths(
const DeclTypeSpec &type1, const evaluate::DynamicType &type2) {
if (type1.category() == DeclTypeSpec::Character &&
type2.category() == TypeCategory::Character) {
auto v1{
evaluate::ToInt64(type1.characterTypeSpec().length().GetExplicit())};
auto v2{type2.knownLength()};
return !v1 || !v2 || (*v1 >= 0 ? *v1 : 0) == (*v2 >= 0 ? *v2 : 0);
} else {
return true;
}
}
bool AreSameAllocation(const SomeExpr *root, const SomeExpr *path) {
if (root && path) {
// For now we just use equality of expressions. If we implement a more
// sophisticated alias analysis we should use it here.
return *root == *path;
} else {
return false;
}
}
bool AllocationCheckerHelper::RunChecks(SemanticsContext &context) {
if (!ultimate_) {
CHECK(context.AnyFatalError());
return false;
}
if (!IsVariableName(*ultimate_)) { // C932 pre-requisite
context.Say(name_.source,
"Name in ALLOCATE statement must be a variable name"_err_en_US);
return false;
}
if (!type_) {
// This is done after variable check because a user could have put
// a subroutine name in allocate for instance which is a symbol with
// no type.
CHECK(context.AnyFatalError());
return false;
}
GatherAllocationBasicInfo();
if (!IsAllocatableOrObjectPointer(ultimate_)) { // C932
context.Say(name_.source,
"Entity in ALLOCATE statement must have the ALLOCATABLE or POINTER attribute"_err_en_US);
return false;
}
bool gotSourceExprOrTypeSpec{allocateInfo_.gotMold ||
allocateInfo_.gotTypeSpec || allocateInfo_.gotSource};
if (hasDeferredTypeParameter_ && !gotSourceExprOrTypeSpec) {
// C933
context.Say(name_.source,
"Either type-spec or source-expr must appear in ALLOCATE when allocatable object has a deferred type parameters"_err_en_US);
return false;
}
if (isUnlimitedPolymorphic_ && !gotSourceExprOrTypeSpec) {
// C933
context.Say(name_.source,
"Either type-spec or source-expr must appear in ALLOCATE when allocatable object is unlimited polymorphic"_err_en_US);
return false;
}
if (isAbstract_ && !gotSourceExprOrTypeSpec) {
// C933
context.Say(name_.source,
"Either type-spec or source-expr must appear in ALLOCATE when allocatable object is of abstract type"_err_en_US);
return false;
}
if (allocateInfo_.gotTypeSpec) {
if (!IsTypeCompatible(*type_, *allocateInfo_.typeSpec)) {
// C934
context.Say(name_.source,
"Allocatable object in ALLOCATE must be type compatible with type-spec"_err_en_US);
return false;
}
if (!HaveCompatibleTypeParameters(*type_, *allocateInfo_.typeSpec)) {
context.Say(name_.source,
// C936
"Type parameters of allocatable object in ALLOCATE must be the same as the corresponding ones in type-spec"_err_en_US);
return false;
}
if (!HaveCompatibleLengths(*type_, *allocateInfo_.typeSpec)) { // C934
context.Say(name_.source,
"Character length of allocatable object in ALLOCATE must be the same as the type-spec"_err_en_US);
return false;
}
if (!HaveSameAssumedTypeParameters(*type_, *allocateInfo_.typeSpec)) {
// C935
context.Say(name_.source,
"Type parameters in type-spec must be assumed if and only if they are assumed for allocatable object in ALLOCATE"_err_en_US);
return false;
}
} else if (allocateInfo_.gotSource || allocateInfo_.gotMold) {
if (!IsTypeCompatible(*type_, allocateInfo_.sourceExprType.value())) {
// first part of C945
context.Say(name_.source,
"Allocatable object in ALLOCATE must be type compatible with source expression from MOLD or SOURCE"_err_en_US);
return false;
}
if (!HaveCompatibleTypeParameters(
*type_, allocateInfo_.sourceExprType.value())) {
// C946
context.Say(name_.source,
"Derived type parameters of allocatable object must be the same as the corresponding ones of SOURCE or MOLD expression"_err_en_US);
return false;
}
// Character length distinction is allowed, with a warning
if (!HaveCompatibleLengths(
*type_, allocateInfo_.sourceExprType.value())) { // F'2023 C950
context.Warn(common::LanguageFeature::AllocateToOtherLength, name_.source,
"Character length of allocatable object in ALLOCATE should be the same as the SOURCE or MOLD"_port_en_US);
}
}
// Shape related checks
if (ultimate_ && IsAssumedRank(*ultimate_)) {
context.Say(name_.source,
"An assumed-rank dummy argument may not appear in an ALLOCATE statement"_err_en_US);
return false;
}
if (ultimate_ && IsAssumedSizeArray(*ultimate_) && context.AnyFatalError()) {
// An assumed-size dummy array or RANK(*) case of SELECT RANK will have
// already been diagnosed; don't pile on.
return false;
}
if (rank_ > 0) {
if (!hasAllocateShapeSpecList()) {
// C939
if (!(allocateInfo_.gotSource || allocateInfo_.gotMold)) {
context.Say(name_.source,
"Arrays in ALLOCATE must have a shape specification or an expression of the same rank must appear in SOURCE or MOLD"_err_en_US);
return false;
} else {
if (allocateInfo_.sourceExprRank != rank_) {
context
.Say(name_.source,
"Arrays in ALLOCATE must have a shape specification or an expression of the same rank must appear in SOURCE or MOLD"_err_en_US)
.Attach(allocateInfo_.sourceExprLoc.value(),
"Expression in %s has rank %d but allocatable object has rank %d"_en_US,
allocateInfo_.gotSource ? "SOURCE" : "MOLD",
allocateInfo_.sourceExprRank, rank_);
return false;
}
}
} else {
// explicit shape-spec-list
if (allocateShapeSpecRank_ != rank_) {
context
.Say(name_.source,
"The number of shape specifications, when they appear, must match the rank of allocatable object"_err_en_US)
.Attach(
ultimate_->name(), "Declared here with rank %d"_en_US, rank_);
return false;
} else if (allocateInfo_.gotSource && allocateInfo_.sourceExprShape &&
allocateInfo_.sourceExprShape->size() ==
static_cast<std::size_t>(allocateShapeSpecRank_)) {
std::size_t j{0};
for (const auto &shapeSpec :
std::get<std::list<parser::AllocateShapeSpec>>(allocation_.t)) {
if (j >= allocateInfo_.sourceExprShape->size()) {
break;
}
std::optional<evaluate::ConstantSubscript> lbound;
if (const auto &lb{std::get<0>(shapeSpec.t)}) {
lbound.reset();
const auto &lbExpr{parser::UnwrapRef<parser::Expr>(lb)};
if (const auto *expr{GetExpr(context, lbExpr)}) {
auto folded{
evaluate::Fold(context.foldingContext(), SomeExpr(*expr))};
lbound = evaluate::ToInt64(folded);
evaluate::SetExpr(lbExpr, std::move(folded));
}
} else {
lbound = 1;
}
if (lbound) {
const auto &ubExpr{
parser::UnwrapRef<parser::Expr>(std::get<1>(shapeSpec.t))};
if (const auto *expr{GetExpr(context, ubExpr)}) {
auto folded{
evaluate::Fold(context.foldingContext(), SomeExpr(*expr))};
auto ubound{evaluate::ToInt64(folded)};
evaluate::SetExpr(ubExpr, std::move(folded));
if (ubound) {
auto extent{*ubound - *lbound + 1};
if (extent < 0) {
extent = 0;
}
if (extent != allocateInfo_.sourceExprShape->at(j)) {
context.Say(name_.source,
"Allocation has extent %jd on dimension %d, but SOURCE= has extent %jd"_err_en_US,
static_cast<std::intmax_t>(extent), j + 1,
static_cast<std::intmax_t>(
allocateInfo_.sourceExprShape->at(j)));
}
}
}
}
++j;
}
}
}
} else { // allocating a scalar object
if (hasAllocateShapeSpecList()) {
context.Say(name_.source,
"Shape specifications must not appear when allocatable object is scalar"_err_en_US);
return false;
}
}
// second and last part of C945
if (allocateInfo_.gotSource && allocateInfo_.sourceExprRank &&
allocateInfo_.sourceExprRank != rank_) {
context
.Say(name_.source,
"If SOURCE appears, the related expression must be scalar or have the same rank as each allocatable object in ALLOCATE"_err_en_US)
.Attach(allocateInfo_.sourceExprLoc.value(),
"SOURCE expression has rank %d"_en_US, allocateInfo_.sourceExprRank)
.Attach(ultimate_->name(),
"Allocatable object declared here with rank %d"_en_US, rank_);
return false;
}
context.CheckIndexVarRedefine(name_);
const Scope &subpScope{
GetProgramUnitContaining(context.FindScope(name_.source))};
if (allocateObject_.typedExpr && allocateObject_.typedExpr->v) {
DefinabilityFlags flags{DefinabilityFlag::PointerDefinition,
DefinabilityFlag::AcceptAllocatable};
if (allocateInfo_.gotSource) {
flags.set(DefinabilityFlag::SourcedAllocation);
}
if (auto whyNot{WhyNotDefinable(
name_.source, subpScope, flags, *allocateObject_.typedExpr->v)}) {
context
.Say(name_.source,
"Name in ALLOCATE statement is not definable"_err_en_US)
.Attach(std::move(whyNot->set_severity(parser::Severity::Because)));
return false;
}
}
if (allocateInfo_.gotPinned) {
std::optional<common::CUDADataAttr> cudaAttr{GetCUDADataAttr(ultimate_)};
if ((!cudaAttr || *cudaAttr != common::CUDADataAttr::Pinned) &&
context.languageFeatures().ShouldWarn(
common::UsageWarning::CUDAUsage)) {
context.Say(name_.source,
"Object in ALLOCATE should have PINNED attribute when PINNED option is specified"_warn_en_US);
}
}
if (allocateInfo_.gotStream) {
std::optional<common::CUDADataAttr> cudaAttr{GetCUDADataAttr(ultimate_)};
if (!cudaAttr || *cudaAttr != common::CUDADataAttr::Device) {
context.Say(name_.source,
"Object in ALLOCATE must have DEVICE attribute when STREAM option is specified"_err_en_US);
}
}
if (const SomeExpr *allocObj{GetExpr(context, allocateObject_)}) {
if (AreSameAllocation(allocObj, allocateInfo_.statVar)) {
context.Say(allocateInfo_.statSource.value_or(name_.source),
"STAT variable in ALLOCATE must not be the variable being allocated"_err_en_US);
}
if (AreSameAllocation(allocObj, allocateInfo_.msgVar)) {
context.Say(allocateInfo_.msgSource.value_or(name_.source),
"ERRMSG variable in ALLOCATE must not be the variable being allocated"_err_en_US);
}
}
return RunCoarrayRelatedChecks(context);
}
bool AllocationCheckerHelper::RunCoarrayRelatedChecks(
SemanticsContext &context) const {
if (!ultimate_) {
CHECK(context.AnyFatalError());
return false;
}
if (evaluate::IsCoarray(*ultimate_)) {
if (allocateInfo_.gotTypeSpec) {
// C938
if (const DerivedTypeSpec *
derived{allocateInfo_.typeSpec->AsDerived()}) {
if (IsTeamType(derived)) {
context
.Say(allocateInfo_.typeSpecLoc.value(),
"Type-Spec in ALLOCATE must not be TEAM_TYPE from ISO_FORTRAN_ENV when an allocatable object is a coarray"_err_en_US)
.Attach(name_.source, "'%s' is a coarray"_en_US, name_.source);
return false;
} else if (IsIsoCType(derived)) {
context
.Say(allocateInfo_.typeSpecLoc.value(),
"Type-Spec in ALLOCATE must not be C_PTR or C_FUNPTR from ISO_C_BINDING when an allocatable object is a coarray"_err_en_US)
.Attach(name_.source, "'%s' is a coarray"_en_US, name_.source);
return false;
}
}
} else if (allocateInfo_.gotSource || allocateInfo_.gotMold) {
// C948
const evaluate::DynamicType &sourceType{
allocateInfo_.sourceExprType.value()};
if (const auto *derived{evaluate::GetDerivedTypeSpec(sourceType)}) {
if (IsTeamType(derived)) {
context
.Say(allocateInfo_.sourceExprLoc.value(),
"SOURCE or MOLD expression type must not be TEAM_TYPE from ISO_FORTRAN_ENV when an allocatable object is a coarray"_err_en_US)
.Attach(name_.source, "'%s' is a coarray"_en_US, name_.source);
return false;
} else if (IsIsoCType(derived)) {
context
.Say(allocateInfo_.sourceExprLoc.value(),
"SOURCE or MOLD expression type must not be C_PTR or C_FUNPTR from ISO_C_BINDING when an allocatable object is a coarray"_err_en_US)
.Attach(name_.source, "'%s' is a coarray"_en_US, name_.source);
return false;
}
}
}
if (!hasAllocateCoarraySpec()) {
// C941
context.Say(name_.source,
"Coarray specification must appear in ALLOCATE when allocatable object is a coarray"_err_en_US);
return false;
} else {
if (allocateCoarraySpecRank_ != corank_) {
// Second and last part of C942
context
.Say(name_.source,
"Corank of coarray specification in ALLOCATE must match corank of alloctable coarray"_err_en_US)
.Attach(ultimate_->name(), "Declared here with corank %d"_en_US,
corank_);
return false;
}
if (const auto &coarraySpec{
std::get<std::optional<parser::AllocateCoarraySpec>>(
allocation_.t)}) {
int dim{0};
for (const auto &spec :
std::get<std::list<parser::AllocateCoshapeSpec>>(coarraySpec->t)) {
if (auto ubv{evaluate::ToInt64(
GetExpr(context, std::get<parser::BoundExpr>(spec.t)))}) {
if (auto *lbx{GetExpr(context,
std::get<std::optional<parser::BoundExpr>>(spec.t))}) {
auto lbv{evaluate::ToInt64(*lbx)};
if (lbv && *ubv < *lbv) {
context.Say(name_.source,
"Upper cobound %jd is less than lower cobound %jd of codimension %d"_err_en_US,
std::intmax_t{*ubv}, std::intmax_t{*lbv}, dim + 1);
}
} else if (*ubv < 1) {
context.Say(name_.source,
"Upper cobound %jd of codimension %d is less than 1"_err_en_US,
std::intmax_t{*ubv}, dim + 1);
}
}
++dim;
}
}
}
} else { // Not a coarray
if (hasAllocateCoarraySpec()) {
// C941
context.Say(name_.source,
"Coarray specification must not appear in ALLOCATE when allocatable object is not a coarray"_err_en_US);
return false;
}
}
if (const parser::CoindexedNamedObject *
coindexedObject{parser::GetCoindexedNamedObject(allocateObject_)}) {
// C950
context.Say(parser::FindSourceLocation(*coindexedObject),
"Allocatable object must not be coindexed in ALLOCATE"_err_en_US);
return false;
}
return true;
}
void AllocateChecker::Leave(const parser::AllocateStmt &allocateStmt) {
if (auto info{CheckAllocateOptions(allocateStmt, context_)}) {
for (const parser::Allocation &allocation :
std::get<std::list<parser::Allocation>>(allocateStmt.t)) {
AllocationCheckerHelper{allocation, *info}.RunChecks(context_);
}
}
}
} // namespace Fortran::semantics
Reference in New Issue View Git Blame Copy Permalink