1 //===-- lib/Semantics/pointer-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-exception 6 // 7 //===----------------------------------------------------------------------===// 8 9 #include "pointer-assignment.h" 10 #include "definable.h" 11 #include "flang/Common/idioms.h" 12 #include "flang/Common/restorer.h" 13 #include "flang/Evaluate/characteristics.h" 14 #include "flang/Evaluate/expression.h" 15 #include "flang/Evaluate/fold.h" 16 #include "flang/Evaluate/tools.h" 17 #include "flang/Parser/message.h" 18 #include "flang/Parser/parse-tree-visitor.h" 19 #include "flang/Parser/parse-tree.h" 20 #include "flang/Semantics/expression.h" 21 #include "flang/Semantics/symbol.h" 22 #include "flang/Semantics/tools.h" 23 #include "llvm/Support/raw_ostream.h" 24 #include <optional> 25 #include <set> 26 #include <string> 27 #include <type_traits> 28 29 // Semantic checks for pointer assignment. 30 31 namespace Fortran::semantics { 32 33 using namespace parser::literals; 34 using evaluate::characteristics::DummyDataObject; 35 using evaluate::characteristics::FunctionResult; 36 using evaluate::characteristics::Procedure; 37 using evaluate::characteristics::TypeAndShape; 38 using parser::MessageFixedText; 39 using parser::MessageFormattedText; 40 41 class PointerAssignmentChecker { 42 public: 43 PointerAssignmentChecker(evaluate::FoldingContext &context, 44 const Scope &scope, parser::CharBlock source, 45 const std::string &description) 46 : context_{context}, scope_{scope}, source_{source}, description_{ 47 description} {} 48 PointerAssignmentChecker( 49 evaluate::FoldingContext &context, const Scope &scope, const Symbol &lhs) 50 : context_{context}, scope_{scope}, source_{lhs.name()}, 51 description_{"pointer '"s + lhs.name().ToString() + '\''}, lhs_{&lhs} { 52 set_lhsType(TypeAndShape::Characterize(lhs, context)); 53 set_isContiguous(lhs.attrs().test(Attr::CONTIGUOUS)); 54 set_isVolatile(lhs.attrs().test(Attr::VOLATILE)); 55 } 56 PointerAssignmentChecker &set_lhsType(std::optional<TypeAndShape> &&); 57 PointerAssignmentChecker &set_isContiguous(bool); 58 PointerAssignmentChecker &set_isVolatile(bool); 59 PointerAssignmentChecker &set_isBoundsRemapping(bool); 60 bool CheckLeftHandSide(const SomeExpr &); 61 bool Check(const SomeExpr &); 62 63 private: 64 bool CharacterizeProcedure(); 65 template <typename T> bool Check(const T &); 66 template <typename T> bool Check(const evaluate::Expr<T> &); 67 template <typename T> bool Check(const evaluate::FunctionRef<T> &); 68 template <typename T> bool Check(const evaluate::Designator<T> &); 69 bool Check(const evaluate::NullPointer &); 70 bool Check(const evaluate::ProcedureDesignator &); 71 bool Check(const evaluate::ProcedureRef &); 72 // Target is a procedure 73 bool Check(parser::CharBlock rhsName, bool isCall, 74 const Procedure * = nullptr, 75 const evaluate::SpecificIntrinsic *specific = nullptr); 76 bool LhsOkForUnlimitedPoly() const; 77 template <typename... A> parser::Message *Say(A &&...); 78 79 evaluate::FoldingContext &context_; 80 const Scope &scope_; 81 const parser::CharBlock source_; 82 const std::string description_; 83 const Symbol *lhs_{nullptr}; 84 std::optional<TypeAndShape> lhsType_; 85 std::optional<Procedure> procedure_; 86 bool characterizedProcedure_{false}; 87 bool isContiguous_{false}; 88 bool isVolatile_{false}; 89 bool isBoundsRemapping_{false}; 90 }; 91 92 PointerAssignmentChecker &PointerAssignmentChecker::set_lhsType( 93 std::optional<TypeAndShape> &&lhsType) { 94 lhsType_ = std::move(lhsType); 95 return *this; 96 } 97 98 PointerAssignmentChecker &PointerAssignmentChecker::set_isContiguous( 99 bool isContiguous) { 100 isContiguous_ = isContiguous; 101 return *this; 102 } 103 104 PointerAssignmentChecker &PointerAssignmentChecker::set_isVolatile( 105 bool isVolatile) { 106 isVolatile_ = isVolatile; 107 return *this; 108 } 109 110 PointerAssignmentChecker &PointerAssignmentChecker::set_isBoundsRemapping( 111 bool isBoundsRemapping) { 112 isBoundsRemapping_ = isBoundsRemapping; 113 return *this; 114 } 115 116 bool PointerAssignmentChecker::CharacterizeProcedure() { 117 if (!characterizedProcedure_) { 118 characterizedProcedure_ = true; 119 if (lhs_ && IsProcedure(*lhs_)) { 120 procedure_ = Procedure::Characterize(*lhs_, context_); 121 } 122 } 123 return procedure_.has_value(); 124 } 125 126 bool PointerAssignmentChecker::CheckLeftHandSide(const SomeExpr &lhs) { 127 if (auto whyNot{WhyNotDefinable(context_.messages().at(), scope_, 128 DefinabilityFlags{DefinabilityFlag::PointerDefinition}, lhs)}) { 129 if (auto *msg{context_.messages().Say( 130 "The left-hand side of a pointer assignment is not definable"_err_en_US)}) { 131 msg->Attach(std::move(*whyNot)); 132 } 133 return false; 134 } else { 135 return true; 136 } 137 } 138 139 template <typename T> bool PointerAssignmentChecker::Check(const T &) { 140 // Catch-all case for really bad target expression 141 Say("Target associated with %s must be a designator or a call to a" 142 " pointer-valued function"_err_en_US, 143 description_); 144 return false; 145 } 146 147 template <typename T> 148 bool PointerAssignmentChecker::Check(const evaluate::Expr<T> &x) { 149 return common::visit([&](const auto &x) { return Check(x); }, x.u); 150 } 151 152 bool PointerAssignmentChecker::Check(const SomeExpr &rhs) { 153 if (HasVectorSubscript(rhs)) { // C1025 154 Say("An array section with a vector subscript may not be a pointer target"_err_en_US); 155 return false; 156 } else if (ExtractCoarrayRef(rhs)) { // C1026 157 Say("A coindexed object may not be a pointer target"_err_en_US); 158 return false; 159 } else { 160 return common::visit([&](const auto &x) { return Check(x); }, rhs.u); 161 } 162 } 163 164 bool PointerAssignmentChecker::Check(const evaluate::NullPointer &) { 165 return true; // P => NULL() without MOLD=; always OK 166 } 167 168 template <typename T> 169 bool PointerAssignmentChecker::Check(const evaluate::FunctionRef<T> &f) { 170 std::string funcName; 171 const auto *symbol{f.proc().GetSymbol()}; 172 if (symbol) { 173 funcName = symbol->name().ToString(); 174 } else if (const auto *intrinsic{f.proc().GetSpecificIntrinsic()}) { 175 funcName = intrinsic->name; 176 } 177 auto proc{Procedure::Characterize(f.proc(), context_)}; 178 if (!proc) { 179 return false; 180 } 181 std::optional<MessageFixedText> msg; 182 const auto &funcResult{proc->functionResult}; // C1025 183 if (!funcResult) { 184 msg = "%s is associated with the non-existent result of reference to" 185 " procedure"_err_en_US; 186 } else if (CharacterizeProcedure()) { 187 // Shouldn't be here in this function unless lhs is an object pointer. 188 msg = "Procedure %s is associated with the result of a reference to" 189 " function '%s' that does not return a procedure pointer"_err_en_US; 190 } else if (funcResult->IsProcedurePointer()) { 191 msg = "Object %s is associated with the result of a reference to" 192 " function '%s' that is a procedure pointer"_err_en_US; 193 } else if (!funcResult->attrs.test(FunctionResult::Attr::Pointer)) { 194 msg = "%s is associated with the result of a reference to function '%s'" 195 " that is a not a pointer"_err_en_US; 196 } else if (isContiguous_ && 197 !funcResult->attrs.test(FunctionResult::Attr::Contiguous)) { 198 msg = "CONTIGUOUS %s is associated with the result of reference to" 199 " function '%s' that is not contiguous"_err_en_US; 200 } else if (lhsType_) { 201 const auto *frTypeAndShape{funcResult->GetTypeAndShape()}; 202 CHECK(frTypeAndShape); 203 if (!lhsType_->IsCompatibleWith(context_.messages(), *frTypeAndShape, 204 "pointer", "function result", 205 isBoundsRemapping_ /*omit shape check*/, 206 evaluate::CheckConformanceFlags::BothDeferredShape)) { 207 return false; // IsCompatibleWith() emitted message 208 } 209 } 210 if (msg) { 211 auto restorer{common::ScopedSet(lhs_, symbol)}; 212 Say(*msg, description_, funcName); 213 return false; 214 } 215 return true; 216 } 217 218 template <typename T> 219 bool PointerAssignmentChecker::Check(const evaluate::Designator<T> &d) { 220 const Symbol *last{d.GetLastSymbol()}; 221 const Symbol *base{d.GetBaseObject().symbol()}; 222 if (!last || !base) { 223 // P => "character literal"(1:3) 224 context_.messages().Say("Pointer target is not a named entity"_err_en_US); 225 return false; 226 } 227 std::optional<std::variant<MessageFixedText, MessageFormattedText>> msg; 228 if (CharacterizeProcedure()) { 229 // Shouldn't be here in this function unless lhs is an object pointer. 230 msg = "In assignment to procedure %s, the target is not a procedure or" 231 " procedure pointer"_err_en_US; 232 } else if (!evaluate::GetLastTarget(GetSymbolVector(d))) { // C1025 233 msg = "In assignment to object %s, the target '%s' is not an object with" 234 " POINTER or TARGET attributes"_err_en_US; 235 } else if (auto rhsType{TypeAndShape::Characterize(d, context_)}) { 236 if (!lhsType_) { 237 msg = "%s associated with object '%s' with incompatible type or" 238 " shape"_err_en_US; 239 } else if (rhsType->corank() > 0 && 240 (isVolatile_ != last->attrs().test(Attr::VOLATILE))) { // C1020 241 // TODO: what if A is VOLATILE in A%B%C? need a better test here 242 if (isVolatile_) { 243 msg = "Pointer may not be VOLATILE when target is a" 244 " non-VOLATILE coarray"_err_en_US; 245 } else { 246 msg = "Pointer must be VOLATILE when target is a" 247 " VOLATILE coarray"_err_en_US; 248 } 249 } else if (rhsType->type().IsUnlimitedPolymorphic()) { 250 if (!LhsOkForUnlimitedPoly()) { 251 msg = "Pointer type must be unlimited polymorphic or non-extensible" 252 " derived type when target is unlimited polymorphic"_err_en_US; 253 } 254 } else { 255 if (!lhsType_->type().IsTkCompatibleWith(rhsType->type())) { 256 msg = MessageFormattedText{ 257 "Target type %s is not compatible with pointer type %s"_err_en_US, 258 rhsType->type().AsFortran(), lhsType_->type().AsFortran()}; 259 260 } else if (!isBoundsRemapping_) { 261 int lhsRank{evaluate::GetRank(lhsType_->shape())}; 262 int rhsRank{evaluate::GetRank(rhsType->shape())}; 263 if (lhsRank != rhsRank) { 264 msg = MessageFormattedText{ 265 "Pointer has rank %d but target has rank %d"_err_en_US, lhsRank, 266 rhsRank}; 267 } 268 } 269 } 270 } 271 if (msg) { 272 auto restorer{common::ScopedSet(lhs_, last)}; 273 if (auto *m{std::get_if<MessageFixedText>(&*msg)}) { 274 std::string buf; 275 llvm::raw_string_ostream ss{buf}; 276 d.AsFortran(ss); 277 Say(*m, description_, ss.str()); 278 } else { 279 Say(std::get<MessageFormattedText>(*msg)); 280 } 281 return false; 282 } 283 return true; 284 } 285 286 // Common handling for procedure pointer right-hand sides 287 bool PointerAssignmentChecker::Check(parser::CharBlock rhsName, bool isCall, 288 const Procedure *rhsProcedure, 289 const evaluate::SpecificIntrinsic *specific) { 290 std::string whyNot; 291 CharacterizeProcedure(); 292 if (std::optional<MessageFixedText> msg{evaluate::CheckProcCompatibility( 293 isCall, procedure_, rhsProcedure, specific, whyNot)}) { 294 Say(std::move(*msg), description_, rhsName, whyNot); 295 return false; 296 } 297 return true; 298 } 299 300 bool PointerAssignmentChecker::Check(const evaluate::ProcedureDesignator &d) { 301 if (const Symbol * symbol{d.GetSymbol()}) { 302 if (const auto *subp{ 303 symbol->GetUltimate().detailsIf<SubprogramDetails>()}) { 304 if (subp->stmtFunction()) { 305 evaluate::SayWithDeclaration(context_.messages(), *symbol, 306 "Statement function '%s' may not be the target of a pointer assignment"_err_en_US, 307 symbol->name()); 308 return false; 309 } 310 } else if (symbol->has<ProcBindingDetails>()) { 311 evaluate::SayWithDeclaration(context_.messages(), *symbol, 312 "Procedure binding '%s' used as target of a pointer assignment"_port_en_US, 313 symbol->name()); 314 } 315 } 316 if (auto chars{Procedure::Characterize(d, context_)}) { 317 return Check(d.GetName(), false, &*chars, d.GetSpecificIntrinsic()); 318 } else { 319 return Check(d.GetName(), false); 320 } 321 } 322 323 bool PointerAssignmentChecker::Check(const evaluate::ProcedureRef &ref) { 324 if (auto chars{Procedure::Characterize(ref, context_)}) { 325 if (chars->functionResult) { 326 if (const auto *proc{chars->functionResult->IsProcedurePointer()}) { 327 return Check(ref.proc().GetName(), true, proc); 328 } 329 } 330 return Check(ref.proc().GetName(), true, &*chars); 331 } else { 332 return Check(ref.proc().GetName(), true, nullptr); 333 } 334 } 335 336 // The target can be unlimited polymorphic if the pointer is, or if it is 337 // a non-extensible derived type. 338 bool PointerAssignmentChecker::LhsOkForUnlimitedPoly() const { 339 const auto &type{lhsType_->type()}; 340 if (type.category() != TypeCategory::Derived || type.IsAssumedType()) { 341 return false; 342 } else if (type.IsUnlimitedPolymorphic()) { 343 return true; 344 } else { 345 return !IsExtensibleType(&type.GetDerivedTypeSpec()); 346 } 347 } 348 349 template <typename... A> 350 parser::Message *PointerAssignmentChecker::Say(A &&...x) { 351 auto *msg{context_.messages().Say(std::forward<A>(x)...)}; 352 if (msg) { 353 if (lhs_) { 354 return evaluate::AttachDeclaration(msg, *lhs_); 355 } 356 if (!source_.empty()) { 357 msg->Attach(source_, "Declaration of %s"_en_US, description_); 358 } 359 } 360 return msg; 361 } 362 363 // Verify that any bounds on the LHS of a pointer assignment are valid. 364 // Return true if it is a bound-remapping so we can perform further checks. 365 static bool CheckPointerBounds( 366 evaluate::FoldingContext &context, const evaluate::Assignment &assignment) { 367 auto &messages{context.messages()}; 368 const SomeExpr &lhs{assignment.lhs}; 369 const SomeExpr &rhs{assignment.rhs}; 370 bool isBoundsRemapping{false}; 371 std::size_t numBounds{common::visit( 372 common::visitors{ 373 [&](const evaluate::Assignment::BoundsSpec &bounds) { 374 return bounds.size(); 375 }, 376 [&](const evaluate::Assignment::BoundsRemapping &bounds) { 377 isBoundsRemapping = true; 378 evaluate::ExtentExpr lhsSizeExpr{1}; 379 for (const auto &bound : bounds) { 380 lhsSizeExpr = std::move(lhsSizeExpr) * 381 (common::Clone(bound.second) - common::Clone(bound.first) + 382 evaluate::ExtentExpr{1}); 383 } 384 if (std::optional<std::int64_t> lhsSize{evaluate::ToInt64( 385 evaluate::Fold(context, std::move(lhsSizeExpr)))}) { 386 if (auto shape{evaluate::GetShape(context, rhs)}) { 387 if (std::optional<std::int64_t> rhsSize{ 388 evaluate::ToInt64(evaluate::Fold( 389 context, evaluate::GetSize(std::move(*shape))))}) { 390 if (*lhsSize > *rhsSize) { 391 messages.Say( 392 "Pointer bounds require %d elements but target has" 393 " only %d"_err_en_US, 394 *lhsSize, *rhsSize); // 10.2.2.3(9) 395 } 396 } 397 } 398 } 399 return bounds.size(); 400 }, 401 [](const auto &) -> std::size_t { 402 DIE("not valid for pointer assignment"); 403 }, 404 }, 405 assignment.u)}; 406 if (numBounds > 0) { 407 if (lhs.Rank() != static_cast<int>(numBounds)) { 408 messages.Say("Pointer '%s' has rank %d but the number of bounds specified" 409 " is %d"_err_en_US, 410 lhs.AsFortran(), lhs.Rank(), numBounds); // C1018 411 } 412 } 413 if (isBoundsRemapping && rhs.Rank() != 1 && 414 !evaluate::IsSimplyContiguous(rhs, context)) { 415 messages.Say("Pointer bounds remapping target must have rank 1 or be" 416 " simply contiguous"_err_en_US); // 10.2.2.3(9) 417 } 418 return isBoundsRemapping; 419 } 420 421 bool CheckPointerAssignment(evaluate::FoldingContext &context, 422 const evaluate::Assignment &assignment, const Scope &scope) { 423 return CheckPointerAssignment(context, assignment.lhs, assignment.rhs, scope, 424 CheckPointerBounds(context, assignment)); 425 } 426 427 bool CheckPointerAssignment(evaluate::FoldingContext &context, 428 const SomeExpr &lhs, const SomeExpr &rhs, const Scope &scope, 429 bool isBoundsRemapping) { 430 const Symbol *pointer{GetLastSymbol(lhs)}; 431 if (!pointer) { 432 return false; // error was reported 433 } 434 PointerAssignmentChecker checker{context, scope, *pointer}; 435 checker.set_isBoundsRemapping(isBoundsRemapping); 436 bool lhsOk{checker.CheckLeftHandSide(lhs)}; 437 bool rhsOk{checker.Check(rhs)}; 438 return lhsOk && rhsOk; // don't short-circuit 439 } 440 441 bool CheckStructConstructorPointerComponent(evaluate::FoldingContext &context, 442 const Symbol &lhs, const SomeExpr &rhs, const Scope &scope) { 443 CHECK(IsPointer(lhs)); 444 return PointerAssignmentChecker{context, scope, lhs}.Check(rhs); 445 } 446 447 bool CheckPointerAssignment(evaluate::FoldingContext &context, 448 parser::CharBlock source, const std::string &description, 449 const DummyDataObject &lhs, const SomeExpr &rhs, const Scope &scope) { 450 return PointerAssignmentChecker{context, scope, source, description} 451 .set_lhsType(common::Clone(lhs.type)) 452 .set_isContiguous(lhs.attrs.test(DummyDataObject::Attr::Contiguous)) 453 .set_isVolatile(lhs.attrs.test(DummyDataObject::Attr::Volatile)) 454 .Check(rhs); 455 } 456 457 bool CheckInitialTarget(evaluate::FoldingContext &context, 458 const SomeExpr &pointer, const SomeExpr &init, const Scope &scope) { 459 return evaluate::IsInitialDataTarget(init, &context.messages()) && 460 CheckPointerAssignment(context, pointer, init, scope); 461 } 462 463 } // namespace Fortran::semantics 464