250 lines · cpp
1//===-- lib/Semantics/assignment.cpp --------------------------------------===//2//3// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.4// See https://llvm.org/LICENSE.txt for license information.5// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception6//7//===----------------------------------------------------------------------===//8 9#include "assignment.h"10#include "definable.h"11#include "pointer-assignment.h"12#include "flang/Common/idioms.h"13#include "flang/Common/restorer.h"14#include "flang/Evaluate/characteristics.h"15#include "flang/Evaluate/expression.h"16#include "flang/Evaluate/fold.h"17#include "flang/Evaluate/tools.h"18#include "flang/Parser/message.h"19#include "flang/Parser/parse-tree-visitor.h"20#include "flang/Parser/parse-tree.h"21#include "flang/Semantics/expression.h"22#include "flang/Semantics/symbol.h"23#include "flang/Semantics/tools.h"24#include <optional>25#include <set>26#include <string>27#include <type_traits>28 29using namespace Fortran::parser::literals;30 31namespace Fortran::semantics {32 33class AssignmentContext {34public:35 explicit AssignmentContext(SemanticsContext &context) : context_{context} {}36 AssignmentContext(AssignmentContext &&) = default;37 AssignmentContext(const AssignmentContext &) = delete;38 bool operator==(const AssignmentContext &x) const { return this == &x; }39 40 template <typename A> void PushWhereContext(const A &);41 void PopWhereContext();42 void Analyze(const parser::AssignmentStmt &);43 void Analyze(const parser::PointerAssignmentStmt &);44 SemanticsContext &context() { return context_; }45 46private:47 bool CheckForPureContext(const SomeExpr &rhs, parser::CharBlock rhsSource);48 void CheckShape(parser::CharBlock, const SomeExpr *);49 template <typename... A>50 parser::Message *Say(parser::CharBlock at, A &&...args) {51 return &context_.Say(at, std::forward<A>(args)...);52 }53 evaluate::FoldingContext &foldingContext() {54 return context_.foldingContext();55 }56 57 SemanticsContext &context_;58 int whereDepth_{0}; // number of WHEREs currently nested in59 // shape of masks in LHS of assignments in current WHERE:60 std::vector<std::optional<std::int64_t>> whereExtents_;61};62 63void AssignmentContext::Analyze(const parser::AssignmentStmt &stmt) {64 if (const evaluate::Assignment * assignment{GetAssignment(stmt)}) {65 const SomeExpr &lhs{assignment->lhs};66 const SomeExpr &rhs{assignment->rhs};67 auto lhsLoc{std::get<parser::Variable>(stmt.t).GetSource()};68 const Scope &scope{context_.FindScope(lhsLoc)};69 DefinabilityFlags flags{DefinabilityFlag::VectorSubscriptIsOk};70 bool isDefinedAssignment{71 std::holds_alternative<evaluate::ProcedureRef>(assignment->u)};72 if (isDefinedAssignment) {73 flags.set(DefinabilityFlag::AllowEventLockOrNotifyType);74 } else if (const Symbol *75 whole{evaluate::UnwrapWholeSymbolOrComponentDataRef(lhs)}) {76 if (IsAllocatable(whole->GetUltimate())) {77 flags.set(DefinabilityFlag::PotentialDeallocation);78 if (IsPolymorphic(*whole) && whereDepth_ > 0) {79 Say(lhsLoc,80 "Assignment to whole polymorphic allocatable '%s' may not be nested in a WHERE statement or construct"_err_en_US,81 whole->name());82 }83 }84 }85 if (auto whyNot{WhyNotDefinable(lhsLoc, scope, flags, lhs)}) {86 if (whyNot->IsFatal()) {87 if (auto *msg{Say(lhsLoc,88 "Left-hand side of assignment is not definable"_err_en_US)}) {89 msg->Attach(90 std::move(whyNot->set_severity(parser::Severity::Because)));91 }92 } else {93 context_.Say(std::move(*whyNot));94 }95 }96 auto rhsLoc{std::get<parser::Expr>(stmt.t).source};97 if (!isDefinedAssignment) {98 CheckForPureContext(rhs, rhsLoc);99 }100 if (whereDepth_ > 0) {101 CheckShape(lhsLoc, &lhs);102 }103 }104}105 106void AssignmentContext::Analyze(const parser::PointerAssignmentStmt &stmt) {107 CHECK(whereDepth_ == 0);108 if (const evaluate::Assignment * assignment{GetAssignment(stmt)}) {109 parser::CharBlock at{context_.location().value()};110 auto restorer{foldingContext().messages().SetLocation(at)};111 CheckPointerAssignment(context_, *assignment, context_.FindScope(at));112 }113}114 115static std::optional<std::string> GetPointerComponentDesignatorName(116 const SomeExpr &expr) {117 if (const auto *derived{118 evaluate::GetDerivedTypeSpec(evaluate::DynamicType::From(expr))}) {119 PotentialAndPointerComponentIterator potentials{*derived};120 if (auto pointer{121 std::find_if(potentials.begin(), potentials.end(), IsPointer)}) {122 return pointer.BuildResultDesignatorName();123 }124 }125 return std::nullopt;126}127 128// Checks C1594(5,6); false if check fails129bool CheckCopyabilityInPureScope(parser::ContextualMessages &messages,130 const SomeExpr &expr, const Scope &scope) {131 if (auto pointer{GetPointerComponentDesignatorName(expr)}) {132 if (const Symbol * base{GetFirstSymbol(expr)}) {133 const char *why{WhyBaseObjectIsSuspicious(base->GetUltimate(), scope)};134 if (!why) {135 if (auto coarray{evaluate::ExtractCoarrayRef(expr)}) {136 base = &coarray->GetLastSymbol();137 why = "coindexed";138 }139 }140 if (why) {141 evaluate::SayWithDeclaration(messages, *base,142 "A pure subprogram may not copy the value of '%s' because it is %s"143 " and has the POINTER potential subobject component '%s'"_err_en_US,144 base->name(), why, *pointer);145 return false;146 }147 }148 }149 return true;150}151 152bool AssignmentContext::CheckForPureContext(153 const SomeExpr &rhs, parser::CharBlock rhsSource) {154 const Scope &scope{context_.FindScope(rhsSource)};155 if (FindPureProcedureContaining(scope)) {156 parser::ContextualMessages messages{157 context_.location().value(), &context_.messages()};158 return CheckCopyabilityInPureScope(messages, rhs, scope);159 } else {160 return true;161 }162}163 164// 10.2.3.1(2) The masks and LHS of assignments must be arrays of the same shape165void AssignmentContext::CheckShape(parser::CharBlock at, const SomeExpr *expr) {166 if (auto shape{evaluate::GetShape(foldingContext(), expr)}) {167 std::size_t size{shape->size()};168 if (size == 0) {169 Say(at, "The mask or variable must not be scalar"_err_en_US);170 }171 if (whereDepth_ == 0) {172 whereExtents_.resize(size);173 } else if (whereExtents_.size() != size) {174 Say(at,175 "Must have rank %zd to match prior mask or assignment of"176 " WHERE construct"_err_en_US,177 whereExtents_.size());178 return;179 }180 for (std::size_t i{0}; i < size; ++i) {181 if (std::optional<std::int64_t> extent{evaluate::ToInt64((*shape)[i])}) {182 if (!whereExtents_[i]) {183 whereExtents_[i] = *extent;184 } else if (*whereExtents_[i] != *extent) {185 Say(at,186 "Dimension %d must have extent %jd to match prior mask or"187 " assignment of WHERE construct"_err_en_US,188 i + 1, *whereExtents_[i]);189 }190 }191 }192 }193}194 195template <typename A> void AssignmentContext::PushWhereContext(const A &x) {196 const auto &expr{std::get<parser::LogicalExpr>(x.t)};197 CheckShape(198 parser::UnwrapRef<parser::Expr>(expr).source, GetExpr(context_, expr));199 ++whereDepth_;200}201 202void AssignmentContext::PopWhereContext() {203 --whereDepth_;204 if (whereDepth_ == 0) {205 whereExtents_.clear();206 }207}208 209AssignmentChecker::~AssignmentChecker() {}210 211SemanticsContext &AssignmentChecker::context() {212 return context_.value().context();213}214 215AssignmentChecker::AssignmentChecker(SemanticsContext &context)216 : context_{new AssignmentContext{context}} {}217 218void AssignmentChecker::Enter(219 const parser::OpenMPDeclareReductionConstruct &x) {220 context().set_location(x.source);221}222void AssignmentChecker::Enter(const parser::AssignmentStmt &x) {223 context_.value().Analyze(x);224}225void AssignmentChecker::Enter(const parser::PointerAssignmentStmt &x) {226 context_.value().Analyze(x);227}228void AssignmentChecker::Enter(const parser::WhereStmt &x) {229 context_.value().PushWhereContext(x);230}231void AssignmentChecker::Leave(const parser::WhereStmt &) {232 context_.value().PopWhereContext();233}234void AssignmentChecker::Enter(const parser::WhereConstructStmt &x) {235 context_.value().PushWhereContext(x);236}237void AssignmentChecker::Leave(const parser::EndWhereStmt &) {238 context_.value().PopWhereContext();239}240void AssignmentChecker::Enter(const parser::MaskedElsewhereStmt &x) {241 context_.value().PushWhereContext(x);242}243void AssignmentChecker::Leave(const parser::MaskedElsewhereStmt &) {244 context_.value().PopWhereContext();245}246 247} // namespace Fortran::semantics248template class Fortran::common::Indirection<249 Fortran::semantics::AssignmentContext>;250