79a25e11fe
Refine handling of NULL(...) in semantics to properly distinguish NULL(), NULL(objectPointer), NULL(procPointer), and NULL(allocatable) from each other in relevant contexts. Add IsNullAllocatable() and IsNullPointerOrAllocatable() utility functions. IsNullAllocatable() is true only for NULL(allocatable); it is false for a bare NULL(), which can be detected independently with IsBareNullPointer(). IsNullPointer() now returns false for NULL(allocatable). ALLOCATED(NULL(allocatable)) now works, and folds to .FALSE. These utilities were modified to accept const pointer arguments rather than const references; I usually prefer this style when the result should clearly be false for a null argument (in the C sense), and it helped me find all of their use sites in the code.
590 lines
22 KiB
C++
590 lines
22 KiB
C++
//===-- lib/Semantics/pointer-assignment.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 "pointer-assignment.h"
|
|
#include "definable.h"
|
|
#include "flang/Common/idioms.h"
|
|
#include "flang/Common/restorer.h"
|
|
#include "flang/Common/template.h"
|
|
#include "flang/Evaluate/characteristics.h"
|
|
#include "flang/Evaluate/expression.h"
|
|
#include "flang/Evaluate/fold.h"
|
|
#include "flang/Evaluate/tools.h"
|
|
#include "flang/Parser/message.h"
|
|
#include "flang/Parser/parse-tree-visitor.h"
|
|
#include "flang/Parser/parse-tree.h"
|
|
#include "flang/Semantics/expression.h"
|
|
#include "flang/Semantics/symbol.h"
|
|
#include "flang/Semantics/tools.h"
|
|
#include "llvm/Support/raw_ostream.h"
|
|
#include <optional>
|
|
#include <set>
|
|
#include <string>
|
|
#include <type_traits>
|
|
|
|
// Semantic checks for pointer assignment.
|
|
|
|
namespace Fortran::semantics {
|
|
|
|
using namespace parser::literals;
|
|
using evaluate::characteristics::DummyDataObject;
|
|
using evaluate::characteristics::FunctionResult;
|
|
using evaluate::characteristics::Procedure;
|
|
using evaluate::characteristics::TypeAndShape;
|
|
using parser::MessageFixedText;
|
|
using parser::MessageFormattedText;
|
|
|
|
class PointerAssignmentChecker {
|
|
public:
|
|
PointerAssignmentChecker(SemanticsContext &context, const Scope &scope,
|
|
parser::CharBlock source, const std::string &description)
|
|
: context_{context}, scope_{scope}, source_{source}, description_{
|
|
description} {}
|
|
PointerAssignmentChecker(
|
|
SemanticsContext &context, const Scope &scope, const Symbol &lhs)
|
|
: context_{context}, scope_{scope}, source_{lhs.name()},
|
|
description_{"pointer '"s + lhs.name().ToString() + '\''}, lhs_{&lhs} {
|
|
set_lhsType(TypeAndShape::Characterize(lhs, foldingContext_));
|
|
set_isContiguous(lhs.attrs().test(Attr::CONTIGUOUS));
|
|
set_isVolatile(lhs.attrs().test(Attr::VOLATILE));
|
|
}
|
|
PointerAssignmentChecker &set_lhsType(std::optional<TypeAndShape> &&);
|
|
PointerAssignmentChecker &set_isContiguous(bool);
|
|
PointerAssignmentChecker &set_isVolatile(bool);
|
|
PointerAssignmentChecker &set_isBoundsRemapping(bool);
|
|
PointerAssignmentChecker &set_isAssumedRank(bool);
|
|
PointerAssignmentChecker &set_pointerComponentLHS(const Symbol *);
|
|
bool CheckLeftHandSide(const SomeExpr &);
|
|
bool Check(const SomeExpr &);
|
|
|
|
private:
|
|
bool CharacterizeProcedure();
|
|
template <typename T> bool Check(const T &);
|
|
template <typename T> bool Check(const evaluate::Expr<T> &);
|
|
template <typename T> bool Check(const evaluate::FunctionRef<T> &);
|
|
template <typename T> bool Check(const evaluate::Designator<T> &);
|
|
bool Check(const evaluate::NullPointer &);
|
|
bool Check(const evaluate::ProcedureDesignator &);
|
|
bool Check(const evaluate::ProcedureRef &);
|
|
// Target is a procedure
|
|
bool Check(parser::CharBlock rhsName, bool isCall,
|
|
const Procedure * = nullptr,
|
|
const evaluate::SpecificIntrinsic *specific = nullptr);
|
|
bool LhsOkForUnlimitedPoly() const;
|
|
std::optional<MessageFormattedText> CheckRanks(const TypeAndShape &rhs) const;
|
|
template <typename... A> parser::Message *Say(A &&...);
|
|
template <typename FeatureOrUsageWarning, typename... A>
|
|
parser::Message *Warn(FeatureOrUsageWarning, A &&...);
|
|
|
|
SemanticsContext &context_;
|
|
evaluate::FoldingContext &foldingContext_{context_.foldingContext()};
|
|
const Scope &scope_;
|
|
const parser::CharBlock source_;
|
|
const std::string description_;
|
|
const Symbol *lhs_{nullptr};
|
|
std::optional<TypeAndShape> lhsType_;
|
|
std::optional<Procedure> procedure_;
|
|
bool characterizedProcedure_{false};
|
|
bool isContiguous_{false};
|
|
bool isVolatile_{false};
|
|
bool isBoundsRemapping_{false};
|
|
bool isAssumedRank_{false};
|
|
const Symbol *pointerComponentLHS_{nullptr};
|
|
};
|
|
|
|
PointerAssignmentChecker &PointerAssignmentChecker::set_lhsType(
|
|
std::optional<TypeAndShape> &&lhsType) {
|
|
lhsType_ = std::move(lhsType);
|
|
return *this;
|
|
}
|
|
|
|
PointerAssignmentChecker &PointerAssignmentChecker::set_isContiguous(
|
|
bool isContiguous) {
|
|
isContiguous_ = isContiguous;
|
|
return *this;
|
|
}
|
|
|
|
PointerAssignmentChecker &PointerAssignmentChecker::set_isVolatile(
|
|
bool isVolatile) {
|
|
isVolatile_ = isVolatile;
|
|
return *this;
|
|
}
|
|
|
|
PointerAssignmentChecker &PointerAssignmentChecker::set_isBoundsRemapping(
|
|
bool isBoundsRemapping) {
|
|
isBoundsRemapping_ = isBoundsRemapping;
|
|
return *this;
|
|
}
|
|
|
|
PointerAssignmentChecker &PointerAssignmentChecker::set_isAssumedRank(
|
|
bool isAssumedRank) {
|
|
isAssumedRank_ = isAssumedRank;
|
|
return *this;
|
|
}
|
|
|
|
PointerAssignmentChecker &PointerAssignmentChecker::set_pointerComponentLHS(
|
|
const Symbol *symbol) {
|
|
pointerComponentLHS_ = symbol;
|
|
return *this;
|
|
}
|
|
|
|
bool PointerAssignmentChecker::CharacterizeProcedure() {
|
|
if (!characterizedProcedure_) {
|
|
characterizedProcedure_ = true;
|
|
if (lhs_ && IsProcedure(*lhs_)) {
|
|
procedure_ = Procedure::Characterize(*lhs_, foldingContext_);
|
|
}
|
|
}
|
|
return procedure_.has_value();
|
|
}
|
|
|
|
bool PointerAssignmentChecker::CheckLeftHandSide(const SomeExpr &lhs) {
|
|
if (auto whyNot{WhyNotDefinable(foldingContext_.messages().at(), scope_,
|
|
DefinabilityFlags{DefinabilityFlag::PointerDefinition}, lhs)}) {
|
|
if (auto *msg{Say(
|
|
"The left-hand side of a pointer assignment is not definable"_err_en_US)}) {
|
|
msg->Attach(std::move(whyNot->set_severity(parser::Severity::Because)));
|
|
}
|
|
return false;
|
|
} else if (evaluate::IsAssumedRank(lhs)) {
|
|
Say("The left-hand side of a pointer assignment must not be an assumed-rank dummy argument"_err_en_US);
|
|
return false;
|
|
} else {
|
|
return true;
|
|
}
|
|
}
|
|
|
|
template <typename T> bool PointerAssignmentChecker::Check(const T &) {
|
|
// Catch-all case for really bad target expression
|
|
Say("Target associated with %s must be a designator or a call to a"
|
|
" pointer-valued function"_err_en_US,
|
|
description_);
|
|
return false;
|
|
}
|
|
|
|
template <typename T>
|
|
bool PointerAssignmentChecker::Check(const evaluate::Expr<T> &x) {
|
|
return common::visit([&](const auto &x) { return Check(x); }, x.u);
|
|
}
|
|
|
|
bool PointerAssignmentChecker::Check(const SomeExpr &rhs) {
|
|
if (HasVectorSubscript(rhs)) { // C1025
|
|
Say("An array section with a vector subscript may not be a pointer target"_err_en_US);
|
|
return false;
|
|
}
|
|
if (ExtractCoarrayRef(rhs)) { // C1026
|
|
Say("A coindexed object may not be a pointer target"_err_en_US);
|
|
return false;
|
|
}
|
|
if (!common::visit([&](const auto &x) { return Check(x); }, rhs.u)) {
|
|
return false;
|
|
}
|
|
if (IsNullPointer(&rhs)) {
|
|
return true;
|
|
}
|
|
if (lhs_ && IsProcedure(*lhs_)) {
|
|
return true;
|
|
}
|
|
if (const auto *pureProc{FindPureProcedureContaining(scope_)}) {
|
|
if (pointerComponentLHS_) { // C1594(4) is a hard error
|
|
if (const Symbol * object{FindExternallyVisibleObject(rhs, *pureProc)}) {
|
|
if (auto *msg{Say(
|
|
"Externally visible object '%s' may not be associated with pointer component '%s' in a pure procedure"_err_en_US,
|
|
object->name(), pointerComponentLHS_->name())}) {
|
|
msg->Attach(object->name(), "Object declaration"_en_US)
|
|
.Attach(
|
|
pointerComponentLHS_->name(), "Pointer declaration"_en_US);
|
|
}
|
|
return false;
|
|
}
|
|
} else if (const Symbol * base{GetFirstSymbol(rhs)}) {
|
|
if (const char *why{WhyBaseObjectIsSuspicious(
|
|
base->GetUltimate(), scope_)}) { // C1594(3)
|
|
evaluate::SayWithDeclaration(foldingContext_.messages(), *base,
|
|
"A pure subprogram may not use '%s' as the target of pointer assignment because it is %s"_err_en_US,
|
|
base->name(), why);
|
|
return false;
|
|
}
|
|
}
|
|
}
|
|
if (isContiguous_) {
|
|
if (auto contiguous{evaluate::IsContiguous(rhs, foldingContext_)}) {
|
|
if (!*contiguous) {
|
|
Say("CONTIGUOUS pointer may not be associated with a discontiguous target"_err_en_US);
|
|
return false;
|
|
}
|
|
} else {
|
|
Warn(common::UsageWarning::PointerToPossibleNoncontiguous,
|
|
"Target of CONTIGUOUS pointer association is not known to be contiguous"_warn_en_US);
|
|
}
|
|
}
|
|
// Warn about undefinable data targets
|
|
if (auto because{
|
|
WhyNotDefinable(foldingContext_.messages().at(), scope_, {}, rhs)}) {
|
|
if (auto *msg{Warn(common::UsageWarning::PointerToUndefinable,
|
|
"Pointer target is not a definable variable"_warn_en_US)}) {
|
|
msg->Attach(std::move(because->set_severity(parser::Severity::Because)));
|
|
return false;
|
|
}
|
|
}
|
|
return true;
|
|
}
|
|
|
|
bool PointerAssignmentChecker::Check(const evaluate::NullPointer &) {
|
|
return true; // P => NULL() without MOLD=; always OK
|
|
}
|
|
|
|
template <typename T>
|
|
bool PointerAssignmentChecker::Check(const evaluate::FunctionRef<T> &f) {
|
|
std::string funcName;
|
|
const auto *symbol{f.proc().GetSymbol()};
|
|
if (symbol) {
|
|
funcName = symbol->name().ToString();
|
|
} else if (const auto *intrinsic{f.proc().GetSpecificIntrinsic()}) {
|
|
funcName = intrinsic->name;
|
|
}
|
|
auto proc{
|
|
Procedure::Characterize(f.proc(), foldingContext_, /*emitError=*/true)};
|
|
if (!proc) {
|
|
return false;
|
|
}
|
|
std::optional<MessageFixedText> msg;
|
|
const auto &funcResult{proc->functionResult}; // C1025
|
|
if (!funcResult) {
|
|
msg = "%s is associated with the non-existent result of reference to"
|
|
" procedure"_err_en_US;
|
|
} else if (CharacterizeProcedure()) {
|
|
// Shouldn't be here in this function unless lhs is an object pointer.
|
|
msg = "Procedure %s is associated with the result of a reference to"
|
|
" function '%s' that does not return a procedure pointer"_err_en_US;
|
|
} else if (funcResult->IsProcedurePointer()) {
|
|
msg = "Object %s is associated with the result of a reference to"
|
|
" function '%s' that is a procedure pointer"_err_en_US;
|
|
} else if (!funcResult->attrs.test(FunctionResult::Attr::Pointer)) {
|
|
msg = "%s is associated with the result of a reference to function '%s'"
|
|
" that is a not a pointer"_err_en_US;
|
|
} else if (isContiguous_ &&
|
|
!funcResult->attrs.test(FunctionResult::Attr::Contiguous)) {
|
|
auto restorer{common::ScopedSet(lhs_, symbol)};
|
|
if (Warn(common::UsageWarning::PointerToPossibleNoncontiguous,
|
|
"CONTIGUOUS %s is associated with the result of reference to function '%s' that is not known to be contiguous"_warn_en_US,
|
|
description_, funcName)) {
|
|
return false;
|
|
}
|
|
} else if (lhsType_) {
|
|
const auto *frTypeAndShape{funcResult->GetTypeAndShape()};
|
|
CHECK(frTypeAndShape);
|
|
if (frTypeAndShape->type().IsUnlimitedPolymorphic() &&
|
|
LhsOkForUnlimitedPoly()) {
|
|
// Special case exception to type checking (F'2023 C1017);
|
|
// still check rank compatibility.
|
|
if (auto msg{CheckRanks(*frTypeAndShape)}) {
|
|
Say(*msg);
|
|
return false;
|
|
}
|
|
} else if (!lhsType_->IsCompatibleWith(foldingContext_.messages(),
|
|
*frTypeAndShape, "pointer", "function result",
|
|
/*omitShapeConformanceCheck=*/isBoundsRemapping_ ||
|
|
isAssumedRank_,
|
|
evaluate::CheckConformanceFlags::BothDeferredShape)) {
|
|
return false; // IsCompatibleWith() emitted message
|
|
}
|
|
}
|
|
if (msg) {
|
|
auto restorer{common::ScopedSet(lhs_, symbol)};
|
|
Say(*msg, description_, funcName);
|
|
return false;
|
|
}
|
|
return true;
|
|
}
|
|
|
|
template <typename T>
|
|
bool PointerAssignmentChecker::Check(const evaluate::Designator<T> &d) {
|
|
const Symbol *last{d.GetLastSymbol()};
|
|
const Symbol *base{d.GetBaseObject().symbol()};
|
|
if (!last || !base) {
|
|
// P => "character literal"(1:3)
|
|
Say("Pointer target is not a named entity"_err_en_US);
|
|
return false;
|
|
}
|
|
std::optional<std::variant<MessageFixedText, MessageFormattedText>> msg;
|
|
if (CharacterizeProcedure()) {
|
|
// Shouldn't be here in this function unless lhs is an object pointer.
|
|
msg = "In assignment to procedure %s, the target is not a procedure or"
|
|
" procedure pointer"_err_en_US;
|
|
} else if (!evaluate::GetLastTarget(GetSymbolVector(d))) { // C1025
|
|
msg = "In assignment to object %s, the target '%s' is not an object with"
|
|
" POINTER or TARGET attributes"_err_en_US;
|
|
} else if (auto rhsType{TypeAndShape::Characterize(d, foldingContext_)}) {
|
|
if (!lhsType_) {
|
|
msg = "%s associated with object '%s' with incompatible type or"
|
|
" shape"_err_en_US;
|
|
} else if (rhsType->corank() > 0 &&
|
|
(isVolatile_ != last->attrs().test(Attr::VOLATILE))) { // C1020
|
|
// TODO: what if A is VOLATILE in A%B%C? need a better test here
|
|
if (isVolatile_) {
|
|
msg = "Pointer may not be VOLATILE when target is a"
|
|
" non-VOLATILE coarray"_err_en_US;
|
|
} else {
|
|
msg = "Pointer must be VOLATILE when target is a"
|
|
" VOLATILE coarray"_err_en_US;
|
|
}
|
|
} else if (auto m{CheckRanks(*rhsType)}) {
|
|
msg = std::move(*m);
|
|
} else if (rhsType->type().IsUnlimitedPolymorphic()) {
|
|
if (!LhsOkForUnlimitedPoly()) {
|
|
msg = "Pointer type must be unlimited polymorphic or non-extensible"
|
|
" derived type when target is unlimited polymorphic"_err_en_US;
|
|
}
|
|
} else if (!lhsType_->type().IsTkLenCompatibleWith(rhsType->type())) {
|
|
msg = MessageFormattedText{
|
|
"Target type %s is not compatible with pointer type %s"_err_en_US,
|
|
rhsType->type().AsFortran(), lhsType_->type().AsFortran()};
|
|
}
|
|
}
|
|
if (msg) {
|
|
auto restorer{common::ScopedSet(lhs_, last)};
|
|
if (auto *m{std::get_if<MessageFixedText>(&*msg)}) {
|
|
std::string buf;
|
|
llvm::raw_string_ostream ss{buf};
|
|
d.AsFortran(ss);
|
|
Say(*m, description_, buf);
|
|
} else {
|
|
Say(std::get<MessageFormattedText>(*msg));
|
|
}
|
|
return false;
|
|
} else {
|
|
context_.NoteDefinedSymbol(*base);
|
|
return true;
|
|
}
|
|
}
|
|
|
|
// Common handling for procedure pointer right-hand sides
|
|
bool PointerAssignmentChecker::Check(parser::CharBlock rhsName, bool isCall,
|
|
const Procedure *rhsProcedure,
|
|
const evaluate::SpecificIntrinsic *specific) {
|
|
std::string whyNot;
|
|
std::optional<std::string> warning;
|
|
CharacterizeProcedure();
|
|
if (std::optional<MessageFixedText> msg{evaluate::CheckProcCompatibility(
|
|
isCall, procedure_, rhsProcedure, specific, whyNot, warning,
|
|
/*ignoreImplicitVsExplicit=*/isCall)}) {
|
|
Say(std::move(*msg), description_, rhsName, whyNot);
|
|
return false;
|
|
}
|
|
if (warning) {
|
|
Warn(common::UsageWarning::ProcDummyArgShapes,
|
|
"%s and %s may not be completely compatible procedures: %s"_warn_en_US,
|
|
description_, rhsName, std::move(*warning));
|
|
}
|
|
return true;
|
|
}
|
|
|
|
bool PointerAssignmentChecker::Check(const evaluate::ProcedureDesignator &d) {
|
|
const Symbol *symbol{d.GetSymbol()};
|
|
if (symbol) {
|
|
if (const auto *subp{
|
|
symbol->GetUltimate().detailsIf<SubprogramDetails>()}) {
|
|
if (subp->stmtFunction()) {
|
|
evaluate::SayWithDeclaration(foldingContext_.messages(), *symbol,
|
|
"Statement function '%s' may not be the target of a pointer assignment"_err_en_US,
|
|
symbol->name());
|
|
return false;
|
|
}
|
|
} else if (symbol->has<ProcBindingDetails>()) {
|
|
evaluate::AttachDeclaration(
|
|
Warn(common::LanguageFeature::BindingAsProcedure,
|
|
"Procedure binding '%s' used as target of a pointer assignment"_port_en_US,
|
|
symbol->name()),
|
|
*symbol);
|
|
}
|
|
}
|
|
if (auto chars{
|
|
Procedure::Characterize(d, foldingContext_, /*emitError=*/true)}) {
|
|
// Disregard the elemental attribute of RHS intrinsics.
|
|
if (symbol && symbol->GetUltimate().attrs().test(Attr::INTRINSIC)) {
|
|
chars->attrs.reset(Procedure::Attr::Elemental);
|
|
}
|
|
return Check(d.GetName(), false, &*chars, d.GetSpecificIntrinsic());
|
|
} else {
|
|
return Check(d.GetName(), false);
|
|
}
|
|
}
|
|
|
|
bool PointerAssignmentChecker::Check(const evaluate::ProcedureRef &ref) {
|
|
auto chars{Procedure::Characterize(ref, foldingContext_)};
|
|
return Check(ref.proc().GetName(), true, common::GetPtrFromOptional(chars));
|
|
}
|
|
|
|
// The target can be unlimited polymorphic if the pointer is, or if it is
|
|
// a non-extensible derived type.
|
|
bool PointerAssignmentChecker::LhsOkForUnlimitedPoly() const {
|
|
const auto &type{lhsType_->type()};
|
|
if (type.category() != TypeCategory::Derived || type.IsAssumedType()) {
|
|
return false;
|
|
} else if (type.IsUnlimitedPolymorphic()) {
|
|
return true;
|
|
} else {
|
|
return !IsExtensibleType(&type.GetDerivedTypeSpec());
|
|
}
|
|
}
|
|
|
|
std::optional<MessageFormattedText> PointerAssignmentChecker::CheckRanks(
|
|
const TypeAndShape &rhs) const {
|
|
if (!isBoundsRemapping_ &&
|
|
!lhsType_->attrs().test(TypeAndShape::Attr::AssumedRank)) {
|
|
int lhsRank{lhsType_->Rank()};
|
|
int rhsRank{rhs.Rank()};
|
|
if (lhsRank != rhsRank) {
|
|
return MessageFormattedText{
|
|
"Pointer has rank %d but target has rank %d"_err_en_US, lhsRank,
|
|
rhsRank};
|
|
}
|
|
}
|
|
return std::nullopt;
|
|
}
|
|
|
|
template <typename... A>
|
|
parser::Message *PointerAssignmentChecker::Say(A &&...x) {
|
|
auto *msg{foldingContext_.messages().Say(std::forward<A>(x)...)};
|
|
if (msg) {
|
|
if (lhs_) {
|
|
return evaluate::AttachDeclaration(msg, *lhs_);
|
|
}
|
|
if (!source_.empty()) {
|
|
msg->Attach(source_, "Declaration of %s"_en_US, description_);
|
|
}
|
|
}
|
|
return msg;
|
|
}
|
|
|
|
template <typename FeatureOrUsageWarning, typename... A>
|
|
parser::Message *PointerAssignmentChecker::Warn(
|
|
FeatureOrUsageWarning warning, A &&...x) {
|
|
auto *msg{context_.Warn(
|
|
warning, foldingContext_.messages().at(), std::forward<A>(x)...)};
|
|
if (msg) {
|
|
if (lhs_) {
|
|
return evaluate::AttachDeclaration(msg, *lhs_);
|
|
}
|
|
if (!source_.empty()) {
|
|
msg->Attach(source_, "Declaration of %s"_en_US, description_);
|
|
}
|
|
}
|
|
return msg;
|
|
}
|
|
|
|
// Verify that any bounds on the LHS of a pointer assignment are valid.
|
|
// Return true if it is a bound-remapping so we can perform further checks.
|
|
static bool CheckPointerBounds(
|
|
evaluate::FoldingContext &context, const evaluate::Assignment &assignment) {
|
|
auto &messages{context.messages()};
|
|
const SomeExpr &lhs{assignment.lhs};
|
|
const SomeExpr &rhs{assignment.rhs};
|
|
bool isBoundsRemapping{false};
|
|
std::size_t numBounds{common::visit(
|
|
common::visitors{
|
|
[&](const evaluate::Assignment::BoundsSpec &bounds) {
|
|
return bounds.size();
|
|
},
|
|
[&](const evaluate::Assignment::BoundsRemapping &bounds) {
|
|
isBoundsRemapping = true;
|
|
evaluate::ExtentExpr lhsSizeExpr{1};
|
|
for (const auto &bound : bounds) {
|
|
lhsSizeExpr = std::move(lhsSizeExpr) *
|
|
(common::Clone(bound.second) - common::Clone(bound.first) +
|
|
evaluate::ExtentExpr{1});
|
|
}
|
|
if (std::optional<std::int64_t> lhsSize{evaluate::ToInt64(
|
|
evaluate::Fold(context, std::move(lhsSizeExpr)))}) {
|
|
if (auto shape{evaluate::GetShape(context, rhs)}) {
|
|
if (std::optional<std::int64_t> rhsSize{
|
|
evaluate::ToInt64(evaluate::Fold(
|
|
context, evaluate::GetSize(std::move(*shape))))}) {
|
|
if (*lhsSize > *rhsSize) {
|
|
messages.Say(
|
|
"Pointer bounds require %d elements but target has"
|
|
" only %d"_err_en_US,
|
|
*lhsSize, *rhsSize); // 10.2.2.3(9)
|
|
}
|
|
}
|
|
}
|
|
}
|
|
return bounds.size();
|
|
},
|
|
[](const auto &) -> std::size_t {
|
|
DIE("not valid for pointer assignment");
|
|
},
|
|
},
|
|
assignment.u)};
|
|
if (numBounds > 0) {
|
|
if (lhs.Rank() != static_cast<int>(numBounds)) {
|
|
messages.Say("Pointer '%s' has rank %d but the number of bounds specified"
|
|
" is %d"_err_en_US,
|
|
lhs.AsFortran(), lhs.Rank(), numBounds); // C1018
|
|
}
|
|
}
|
|
if (isBoundsRemapping && rhs.Rank() != 1 &&
|
|
!evaluate::IsSimplyContiguous(rhs, context)) {
|
|
messages.Say("Pointer bounds remapping target must have rank 1 or be"
|
|
" simply contiguous"_err_en_US); // 10.2.2.3(9)
|
|
}
|
|
return isBoundsRemapping;
|
|
}
|
|
|
|
bool CheckPointerAssignment(SemanticsContext &context,
|
|
const evaluate::Assignment &assignment, const Scope &scope) {
|
|
return CheckPointerAssignment(context, assignment.lhs, assignment.rhs, scope,
|
|
CheckPointerBounds(context.foldingContext(), assignment),
|
|
/*isAssumedRank=*/false);
|
|
}
|
|
|
|
bool CheckPointerAssignment(SemanticsContext &context, const SomeExpr &lhs,
|
|
const SomeExpr &rhs, const Scope &scope, bool isBoundsRemapping,
|
|
bool isAssumedRank) {
|
|
const Symbol *pointer{GetLastSymbol(lhs)};
|
|
if (!pointer) {
|
|
return false; // error was reported
|
|
}
|
|
PointerAssignmentChecker checker{context, scope, *pointer};
|
|
checker.set_isBoundsRemapping(isBoundsRemapping);
|
|
checker.set_isAssumedRank(isAssumedRank);
|
|
bool lhsOk{checker.CheckLeftHandSide(lhs)};
|
|
bool rhsOk{checker.Check(rhs)};
|
|
return lhsOk && rhsOk; // don't short-circuit
|
|
}
|
|
|
|
bool CheckStructConstructorPointerComponent(SemanticsContext &context,
|
|
const Symbol &lhs, const SomeExpr &rhs, const Scope &scope) {
|
|
return PointerAssignmentChecker{context, scope, lhs}
|
|
.set_pointerComponentLHS(&lhs)
|
|
.Check(rhs);
|
|
}
|
|
|
|
bool CheckPointerAssignment(SemanticsContext &context, parser::CharBlock source,
|
|
const std::string &description, const DummyDataObject &lhs,
|
|
const SomeExpr &rhs, const Scope &scope, bool isAssumedRank) {
|
|
return PointerAssignmentChecker{context, scope, source, description}
|
|
.set_lhsType(common::Clone(lhs.type))
|
|
.set_isContiguous(lhs.attrs.test(DummyDataObject::Attr::Contiguous))
|
|
.set_isVolatile(lhs.attrs.test(DummyDataObject::Attr::Volatile))
|
|
.set_isAssumedRank(isAssumedRank)
|
|
.Check(rhs);
|
|
}
|
|
|
|
bool CheckInitialDataPointerTarget(SemanticsContext &context,
|
|
const SomeExpr &pointer, const SomeExpr &init, const Scope &scope) {
|
|
return evaluate::IsInitialDataTarget(
|
|
init, &context.foldingContext().messages()) &&
|
|
CheckPointerAssignment(context, pointer, init, scope,
|
|
/*isBoundsRemapping=*/false,
|
|
/*isAssumedRank=*/false);
|
|
}
|
|
|
|
} // namespace Fortran::semantics
|