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/Common/template.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 "llvm/Support/raw_ostream.h" |
25 | #include <optional> |
26 | #include <set> |
27 | #include <string> |
28 | #include <type_traits> |
29 | |
30 | // Semantic checks for pointer assignment. |
31 | |
32 | namespace Fortran::semantics { |
33 | |
34 | using namespace parser::literals; |
35 | using evaluate::characteristics::DummyDataObject; |
36 | using evaluate::characteristics::FunctionResult; |
37 | using evaluate::characteristics::Procedure; |
38 | using evaluate::characteristics::TypeAndShape; |
39 | using parser::MessageFixedText; |
40 | using parser::MessageFormattedText; |
41 | |
42 | class PointerAssignmentChecker { |
43 | public: |
44 | PointerAssignmentChecker(SemanticsContext &context, const Scope &scope, |
45 | parser::CharBlock source, const std::string &description) |
46 | : context_{context}, scope_{scope}, source_{source}, description_{ |
47 | description} {} |
48 | PointerAssignmentChecker( |
49 | SemanticsContext &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, foldingContext_)); |
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 | PointerAssignmentChecker &set_isAssumedRank(bool); |
61 | PointerAssignmentChecker &set_pointerComponentLHS(const Symbol *); |
62 | PointerAssignmentChecker &set_isRHSPointerActualArgument(bool); |
63 | bool CheckLeftHandSide(const SomeExpr &); |
64 | bool Check(const SomeExpr &); |
65 | |
66 | private: |
67 | bool CharacterizeProcedure(); |
68 | template <typename T> bool Check(const T &); |
69 | template <typename T> bool Check(const evaluate::Expr<T> &); |
70 | template <typename T> bool Check(const evaluate::FunctionRef<T> &); |
71 | template <typename T> bool Check(const evaluate::Designator<T> &); |
72 | bool Check(const evaluate::NullPointer &); |
73 | bool Check(const evaluate::ProcedureDesignator &); |
74 | bool Check(const evaluate::ProcedureRef &); |
75 | // Target is a procedure |
76 | bool Check(parser::CharBlock rhsName, bool isCall, |
77 | const Procedure * = nullptr, |
78 | const evaluate::SpecificIntrinsic *specific = nullptr); |
79 | bool LhsOkForUnlimitedPoly() const; |
80 | std::optional<MessageFormattedText> CheckRanks(const TypeAndShape &rhs) const; |
81 | template <typename... A> parser::Message *Say(A &&...); |
82 | template <typename FeatureOrUsageWarning, typename... A> |
83 | parser::Message *Warn(FeatureOrUsageWarning, A &&...); |
84 | |
85 | SemanticsContext &context_; |
86 | evaluate::FoldingContext &foldingContext_{context_.foldingContext()}; |
87 | const Scope &scope_; |
88 | const parser::CharBlock source_; |
89 | const std::string description_; |
90 | const Symbol *lhs_{nullptr}; |
91 | std::optional<TypeAndShape> lhsType_; |
92 | std::optional<Procedure> procedure_; |
93 | bool characterizedProcedure_{false}; |
94 | bool isContiguous_{false}; |
95 | bool isVolatile_{false}; |
96 | bool isBoundsRemapping_{false}; |
97 | bool isAssumedRank_{false}; |
98 | bool isRHSPointerActualArgument_{false}; |
99 | const Symbol *pointerComponentLHS_{nullptr}; |
100 | }; |
101 | |
102 | PointerAssignmentChecker &PointerAssignmentChecker::set_lhsType( |
103 | std::optional<TypeAndShape> &&lhsType) { |
104 | lhsType_ = std::move(lhsType); |
105 | return *this; |
106 | } |
107 | |
108 | PointerAssignmentChecker &PointerAssignmentChecker::set_isContiguous( |
109 | bool isContiguous) { |
110 | isContiguous_ = isContiguous; |
111 | return *this; |
112 | } |
113 | |
114 | PointerAssignmentChecker &PointerAssignmentChecker::set_isVolatile( |
115 | bool isVolatile) { |
116 | isVolatile_ = isVolatile; |
117 | return *this; |
118 | } |
119 | |
120 | PointerAssignmentChecker &PointerAssignmentChecker::set_isBoundsRemapping( |
121 | bool isBoundsRemapping) { |
122 | isBoundsRemapping_ = isBoundsRemapping; |
123 | return *this; |
124 | } |
125 | |
126 | PointerAssignmentChecker &PointerAssignmentChecker::set_isAssumedRank( |
127 | bool isAssumedRank) { |
128 | isAssumedRank_ = isAssumedRank; |
129 | return *this; |
130 | } |
131 | |
132 | PointerAssignmentChecker &PointerAssignmentChecker::set_pointerComponentLHS( |
133 | const Symbol *symbol) { |
134 | pointerComponentLHS_ = symbol; |
135 | return *this; |
136 | } |
137 | |
138 | PointerAssignmentChecker & |
139 | PointerAssignmentChecker::set_isRHSPointerActualArgument(bool isPointerActual) { |
140 | isRHSPointerActualArgument_ = isPointerActual; |
141 | return *this; |
142 | } |
143 | |
144 | bool PointerAssignmentChecker::CharacterizeProcedure() { |
145 | if (!characterizedProcedure_) { |
146 | characterizedProcedure_ = true; |
147 | if (lhs_ && IsProcedure(*lhs_)) { |
148 | procedure_ = Procedure::Characterize(*lhs_, foldingContext_); |
149 | } |
150 | } |
151 | return procedure_.has_value(); |
152 | } |
153 | |
154 | bool PointerAssignmentChecker::CheckLeftHandSide(const SomeExpr &lhs) { |
155 | if (auto whyNot{WhyNotDefinable(foldingContext_.messages().at(), scope_, |
156 | DefinabilityFlags{DefinabilityFlag::PointerDefinition}, lhs)}) { |
157 | if (auto *msg{Say( |
158 | "The left-hand side of a pointer assignment is not definable"_err_en_US)}) { |
159 | msg->Attach(std::move(whyNot->set_severity(parser::Severity::Because))); |
160 | } |
161 | return false; |
162 | } else if (evaluate::IsAssumedRank(lhs)) { |
163 | Say("The left-hand side of a pointer assignment must not be an assumed-rank dummy argument"_err_en_US); |
164 | return false; |
165 | } else if (evaluate::ExtractCoarrayRef(lhs)) { // F'2023 C1027 |
166 | Say("The left-hand side of a pointer assignment must not be coindexed"_err_en_US); |
167 | return false; |
168 | } else { |
169 | return true; |
170 | } |
171 | } |
172 | |
173 | template <typename T> bool PointerAssignmentChecker::Check(const T &) { |
174 | // Catch-all case for really bad target expression |
175 | Say("Target associated with %s must be a designator or a call to a" |
176 | " pointer-valued function"_err_en_US, |
177 | description_); |
178 | return false; |
179 | } |
180 | |
181 | template <typename T> |
182 | bool PointerAssignmentChecker::Check(const evaluate::Expr<T> &x) { |
183 | return common::visit([&](const auto &x) { return Check(x); }, x.u); |
184 | } |
185 | |
186 | bool PointerAssignmentChecker::Check(const SomeExpr &rhs) { |
187 | if (HasVectorSubscript(rhs)) { // C1025 |
188 | Say("An array section with a vector subscript may not be a pointer target"_err_en_US); |
189 | return false; |
190 | } |
191 | if (ExtractCoarrayRef(rhs)) { // F'2023 C1029 |
192 | Say("A coindexed object may not be a pointer target"_err_en_US); |
193 | return false; |
194 | } |
195 | if (!common::visit([&](const auto &x) { return Check(x); }, rhs.u)) { |
196 | return false; |
197 | } |
198 | if (IsNullPointer(&rhs)) { |
199 | return true; |
200 | } |
201 | if (lhs_ && IsProcedure(*lhs_)) { |
202 | return true; |
203 | } |
204 | if (const auto *pureProc{FindPureProcedureContaining(scope_)}) { |
205 | if (pointerComponentLHS_) { // F'2023 C15104(4) is a hard error |
206 | if (const Symbol * object{FindExternallyVisibleObject(rhs, *pureProc)}) { |
207 | if (auto *msg{Say( |
208 | "Externally visible object '%s' may not be associated with pointer component '%s' in a pure procedure"_err_en_US, |
209 | object->name(), pointerComponentLHS_->name())}) { |
210 | msg->Attach(object->name(), "Object declaration"_en_US) |
211 | .Attach( |
212 | pointerComponentLHS_->name(), "Pointer declaration"_en_US); |
213 | } |
214 | return false; |
215 | } |
216 | } else if (const Symbol * base{GetFirstSymbol(rhs)}) { |
217 | if (const char *why{WhyBaseObjectIsSuspicious( |
218 | base->GetUltimate(), scope_)}) { // C1594(3) |
219 | evaluate::SayWithDeclaration(foldingContext_.messages(), *base, |
220 | "A pure subprogram may not use '%s' as the target of pointer assignment because it is %s"_err_en_US, |
221 | base->name(), why); |
222 | return false; |
223 | } |
224 | } |
225 | } |
226 | if (isContiguous_) { |
227 | if (auto contiguous{evaluate::IsContiguous(rhs, foldingContext_)}) { |
228 | if (!*contiguous) { |
229 | Say("CONTIGUOUS pointer may not be associated with a discontiguous target"_err_en_US); |
230 | return false; |
231 | } |
232 | } else if (isRHSPointerActualArgument_) { |
233 | Say("CONTIGUOUS pointer dummy argument may not be associated with non-CONTIGUOUS pointer actual argument"_err_en_US); |
234 | return false; |
235 | } else { |
236 | Warn(common::UsageWarning::PointerToPossibleNoncontiguous, |
237 | "Target of CONTIGUOUS pointer association is not known to be contiguous"_warn_en_US); |
238 | } |
239 | } |
240 | // Warn about undefinable data targets |
241 | if (auto because{ |
242 | WhyNotDefinable(foldingContext_.messages().at(), scope_, {}, rhs)}) { |
243 | if (auto *msg{Warn(common::UsageWarning::PointerToUndefinable, |
244 | "Pointer target is not a definable variable"_warn_en_US)}) { |
245 | msg->Attach(std::move(because->set_severity(parser::Severity::Because))); |
246 | return false; |
247 | } |
248 | } |
249 | return true; |
250 | } |
251 | |
252 | bool PointerAssignmentChecker::Check(const evaluate::NullPointer &) { |
253 | return true; // P => NULL() without MOLD=; always OK |
254 | } |
255 | |
256 | template <typename T> |
257 | bool PointerAssignmentChecker::Check(const evaluate::FunctionRef<T> &f) { |
258 | std::string funcName; |
259 | const auto *symbol{f.proc().GetSymbol()}; |
260 | if (symbol) { |
261 | funcName = symbol->name().ToString(); |
262 | } else if (const auto *intrinsic{f.proc().GetSpecificIntrinsic()}) { |
263 | funcName = intrinsic->name; |
264 | } |
265 | auto proc{ |
266 | Procedure::Characterize(f.proc(), foldingContext_, /*emitError=*/true)}; |
267 | if (!proc) { |
268 | return false; |
269 | } |
270 | std::optional<MessageFixedText> msg; |
271 | const auto &funcResult{proc->functionResult}; // C1025 |
272 | if (!funcResult) { |
273 | msg = "%s is associated with the non-existent result of reference to" |
274 | " procedure"_err_en_US; |
275 | } else if (CharacterizeProcedure()) { |
276 | // Shouldn't be here in this function unless lhs is an object pointer. |
277 | msg = "Procedure %s is associated with the result of a reference to" |
278 | " function '%s' that does not return a procedure pointer"_err_en_US; |
279 | } else if (funcResult->IsProcedurePointer()) { |
280 | msg = "Object %s is associated with the result of a reference to" |
281 | " function '%s' that is a procedure pointer"_err_en_US; |
282 | } else if (!funcResult->attrs.test(FunctionResult::Attr::Pointer)) { |
283 | msg = "%s is associated with the result of a reference to function '%s'" |
284 | " that is a not a pointer"_err_en_US; |
285 | } else if (isContiguous_ && |
286 | !funcResult->attrs.test(FunctionResult::Attr::Contiguous)) { |
287 | auto restorer{common::ScopedSet(lhs_, symbol)}; |
288 | if (Warn(common::UsageWarning::PointerToPossibleNoncontiguous, |
289 | "CONTIGUOUS %s is associated with the result of reference to function '%s' that is not known to be contiguous"_warn_en_US, |
290 | description_, funcName)) { |
291 | return false; |
292 | } |
293 | } else if (lhsType_) { |
294 | const auto *frTypeAndShape{funcResult->GetTypeAndShape()}; |
295 | CHECK(frTypeAndShape); |
296 | if (frTypeAndShape->type().IsUnlimitedPolymorphic() && |
297 | LhsOkForUnlimitedPoly()) { |
298 | // Special case exception to type checking (F'2023 C1017); |
299 | // still check rank compatibility. |
300 | if (auto msg{CheckRanks(*frTypeAndShape)}) { |
301 | Say(*msg); |
302 | return false; |
303 | } |
304 | } else if (!lhsType_->IsCompatibleWith(foldingContext_.messages(), |
305 | *frTypeAndShape, "pointer", "function result", |
306 | /*omitShapeConformanceCheck=*/isBoundsRemapping_ || |
307 | isAssumedRank_, |
308 | evaluate::CheckConformanceFlags::BothDeferredShape)) { |
309 | return false; // IsCompatibleWith() emitted message |
310 | } |
311 | } |
312 | if (msg) { |
313 | auto restorer{common::ScopedSet(lhs_, symbol)}; |
314 | Say(*msg, description_, funcName); |
315 | return false; |
316 | } |
317 | return true; |
318 | } |
319 | |
320 | template <typename T> |
321 | bool PointerAssignmentChecker::Check(const evaluate::Designator<T> &d) { |
322 | const Symbol *last{d.GetLastSymbol()}; |
323 | const Symbol *base{d.GetBaseObject().symbol()}; |
324 | if (!last || !base) { |
325 | // P => "character literal"(1:3) |
326 | Say("Pointer target is not a named entity"_err_en_US); |
327 | return false; |
328 | } |
329 | std::optional<std::variant<MessageFixedText, MessageFormattedText>> msg; |
330 | if (CharacterizeProcedure()) { |
331 | // Shouldn't be here in this function unless lhs is an object pointer. |
332 | msg = "In assignment to procedure %s, the target is not a procedure or" |
333 | " procedure pointer"_err_en_US; |
334 | } else if (!evaluate::GetLastTarget(GetSymbolVector(d))) { // C1025 |
335 | msg = "In assignment to object %s, the target '%s' is not an object with" |
336 | " POINTER or TARGET attributes"_err_en_US; |
337 | } else if (auto rhsType{TypeAndShape::Characterize(d, foldingContext_)}) { |
338 | if (!lhsType_) { |
339 | msg = "%s associated with object '%s' with incompatible type or" |
340 | " shape"_err_en_US; |
341 | } else if (rhsType->corank() > 0 && |
342 | (isVolatile_ != last->attrs().test(Attr::VOLATILE))) { // C1020 |
343 | if (isVolatile_) { |
344 | msg = "Pointer may not be VOLATILE when target is a" |
345 | " non-VOLATILE coarray"_err_en_US; |
346 | } else { |
347 | msg = "Pointer must be VOLATILE when target is a" |
348 | " VOLATILE coarray"_err_en_US; |
349 | } |
350 | } else if (auto m{CheckRanks(*rhsType)}) { |
351 | msg = std::move(*m); |
352 | } else if (rhsType->type().IsUnlimitedPolymorphic()) { |
353 | if (!LhsOkForUnlimitedPoly()) { |
354 | msg = "Pointer type must be unlimited polymorphic or non-extensible" |
355 | " derived type when target is unlimited polymorphic"_err_en_US; |
356 | } |
357 | } else if (!lhsType_->type().IsTkLenCompatibleWith(rhsType->type())) { |
358 | msg = MessageFormattedText{ |
359 | "Target type %s is not compatible with pointer type %s"_err_en_US, |
360 | rhsType->type().AsFortran(), lhsType_->type().AsFortran()}; |
361 | } |
362 | } |
363 | if (msg) { |
364 | auto restorer{common::ScopedSet(lhs_, last)}; |
365 | if (auto *m{std::get_if<MessageFixedText>(&*msg)}) { |
366 | std::string buf; |
367 | llvm::raw_string_ostream ss{buf}; |
368 | d.AsFortran(ss); |
369 | Say(*m, description_, buf); |
370 | } else { |
371 | Say(std::get<MessageFormattedText>(*msg)); |
372 | } |
373 | } |
374 | |
375 | // Show warnings after errors |
376 | |
377 | // 8.5.20(3) A pointer should have the VOLATILE attribute if its target has |
378 | // the VOLATILE attribute |
379 | // 8.5.20(4) If an object has the VOLATILE attribute, then all of its |
380 | // subobjects also have the VOLATILE attribute. |
381 | if (!isVolatile_ && base->attrs().test(Attr::VOLATILE)) { |
382 | Warn(common::UsageWarning::NonVolatilePointerToVolatile, |
383 | "VOLATILE target associated with non-VOLATILE pointer"_warn_en_US); |
384 | } |
385 | |
386 | if (msg) { |
387 | return false; |
388 | } else { |
389 | context_.NoteDefinedSymbol(*base); |
390 | return true; |
391 | } |
392 | } |
393 | |
394 | // Common handling for procedure pointer right-hand sides |
395 | bool PointerAssignmentChecker::Check(parser::CharBlock rhsName, bool isCall, |
396 | const Procedure *rhsProcedure, |
397 | const evaluate::SpecificIntrinsic *specific) { |
398 | std::string whyNot; |
399 | std::optional<std::string> warning; |
400 | CharacterizeProcedure(); |
401 | if (std::optional<MessageFixedText> msg{evaluate::CheckProcCompatibility( |
402 | isCall, procedure_, rhsProcedure, specific, whyNot, warning, |
403 | /*ignoreImplicitVsExplicit=*/isCall)}) { |
404 | Say(std::move(*msg), description_, rhsName, whyNot); |
405 | return false; |
406 | } |
407 | if (warning) { |
408 | Warn(common::UsageWarning::ProcDummyArgShapes, |
409 | "%s and %s may not be completely compatible procedures: %s"_warn_en_US, |
410 | description_, rhsName, std::move(*warning)); |
411 | } |
412 | return true; |
413 | } |
414 | |
415 | bool PointerAssignmentChecker::Check(const evaluate::ProcedureDesignator &d) { |
416 | const Symbol *symbol{d.GetSymbol()}; |
417 | if (symbol) { |
418 | if (const auto *subp{ |
419 | symbol->GetUltimate().detailsIf<SubprogramDetails>()}) { |
420 | if (subp->stmtFunction()) { |
421 | evaluate::SayWithDeclaration(foldingContext_.messages(), *symbol, |
422 | "Statement function '%s' may not be the target of a pointer assignment"_err_en_US, |
423 | symbol->name()); |
424 | return false; |
425 | } |
426 | } else if (symbol->has<ProcBindingDetails>()) { |
427 | evaluate::AttachDeclaration( |
428 | Warn(common::LanguageFeature::BindingAsProcedure, |
429 | "Procedure binding '%s' used as target of a pointer assignment"_port_en_US, |
430 | symbol->name()), |
431 | *symbol); |
432 | } |
433 | } |
434 | if (auto chars{ |
435 | Procedure::Characterize(d, foldingContext_, /*emitError=*/true)}) { |
436 | // Disregard the elemental attribute of RHS intrinsics. |
437 | if (symbol && symbol->GetUltimate().attrs().test(Attr::INTRINSIC)) { |
438 | chars->attrs.reset(Procedure::Attr::Elemental); |
439 | } |
440 | return Check(d.GetName(), false, &*chars, d.GetSpecificIntrinsic()); |
441 | } else { |
442 | return Check(d.GetName(), false); |
443 | } |
444 | } |
445 | |
446 | bool PointerAssignmentChecker::Check(const evaluate::ProcedureRef &ref) { |
447 | auto chars{Procedure::Characterize(ref, foldingContext_)}; |
448 | return Check(ref.proc().GetName(), true, common::GetPtrFromOptional(chars)); |
449 | } |
450 | |
451 | // The target can be unlimited polymorphic if the pointer is, or if it is |
452 | // a non-extensible derived type. |
453 | bool PointerAssignmentChecker::LhsOkForUnlimitedPoly() const { |
454 | const auto &type{lhsType_->type()}; |
455 | if (type.category() != TypeCategory::Derived || type.IsAssumedType()) { |
456 | return false; |
457 | } else if (type.IsUnlimitedPolymorphic()) { |
458 | return true; |
459 | } else { |
460 | return !IsExtensibleType(&type.GetDerivedTypeSpec()); |
461 | } |
462 | } |
463 | |
464 | std::optional<MessageFormattedText> PointerAssignmentChecker::CheckRanks( |
465 | const TypeAndShape &rhs) const { |
466 | if (!isBoundsRemapping_ && |
467 | !lhsType_->attrs().test(TypeAndShape::Attr::AssumedRank)) { |
468 | int lhsRank{lhsType_->Rank()}; |
469 | int rhsRank{rhs.Rank()}; |
470 | if (lhsRank != rhsRank) { |
471 | return MessageFormattedText{ |
472 | "Pointer has rank %d but target has rank %d"_err_en_US, lhsRank, |
473 | rhsRank}; |
474 | } |
475 | } |
476 | return std::nullopt; |
477 | } |
478 | |
479 | template <typename... A> |
480 | parser::Message *PointerAssignmentChecker::Say(A &&...x) { |
481 | auto *msg{foldingContext_.messages().Say(std::forward<A>(x)...)}; |
482 | if (msg) { |
483 | if (lhs_) { |
484 | return evaluate::AttachDeclaration(msg, *lhs_); |
485 | } |
486 | if (!source_.empty()) { |
487 | msg->Attach(source_, "Declaration of %s"_en_US, description_); |
488 | } |
489 | } |
490 | return msg; |
491 | } |
492 | |
493 | template <typename FeatureOrUsageWarning, typename... A> |
494 | parser::Message *PointerAssignmentChecker::Warn( |
495 | FeatureOrUsageWarning warning, A &&...x) { |
496 | auto *msg{context_.Warn( |
497 | warning, foldingContext_.messages().at(), std::forward<A>(x)...)}; |
498 | if (msg) { |
499 | if (lhs_) { |
500 | return evaluate::AttachDeclaration(msg, *lhs_); |
501 | } |
502 | if (!source_.empty()) { |
503 | msg->Attach(source_, "Declaration of %s"_en_US, description_); |
504 | } |
505 | } |
506 | return msg; |
507 | } |
508 | |
509 | // Verify that any bounds on the LHS of a pointer assignment are valid. |
510 | // Return true if it is a bound-remapping so we can perform further checks. |
511 | static bool CheckPointerBounds( |
512 | evaluate::FoldingContext &context, const evaluate::Assignment &assignment) { |
513 | auto &messages{context.messages()}; |
514 | const SomeExpr &lhs{assignment.lhs}; |
515 | const SomeExpr &rhs{assignment.rhs}; |
516 | bool isBoundsRemapping{false}; |
517 | std::size_t numBounds{common::visit( |
518 | common::visitors{ |
519 | [&](const evaluate::Assignment::BoundsSpec &bounds) { |
520 | return bounds.size(); |
521 | }, |
522 | [&](const evaluate::Assignment::BoundsRemapping &bounds) { |
523 | isBoundsRemapping = true; |
524 | evaluate::ExtentExpr lhsSizeExpr{1}; |
525 | for (const auto &bound : bounds) { |
526 | lhsSizeExpr = std::move(lhsSizeExpr) * |
527 | (common::Clone(bound.second) - common::Clone(bound.first) + |
528 | evaluate::ExtentExpr{1}); |
529 | } |
530 | if (std::optional<std::int64_t> lhsSize{evaluate::ToInt64( |
531 | evaluate::Fold(context, std::move(lhsSizeExpr)))}) { |
532 | if (auto shape{evaluate::GetShape(context, rhs)}) { |
533 | if (std::optional<std::int64_t> rhsSize{ |
534 | evaluate::ToInt64(evaluate::Fold( |
535 | context, evaluate::GetSize(std::move(*shape))))}) { |
536 | if (*lhsSize > *rhsSize) { |
537 | messages.Say( |
538 | "Pointer bounds require %d elements but target has" |
539 | " only %d"_err_en_US, |
540 | *lhsSize, *rhsSize); // 10.2.2.3(9) |
541 | } |
542 | } |
543 | } |
544 | } |
545 | return bounds.size(); |
546 | }, |
547 | [](const auto &) -> std::size_t { |
548 | DIE("not valid for pointer assignment"); |
549 | }, |
550 | }, |
551 | assignment.u)}; |
552 | if (numBounds > 0) { |
553 | if (lhs.Rank() != static_cast<int>(numBounds)) { |
554 | messages.Say("Pointer '%s' has rank %d but the number of bounds specified" |
555 | " is %d"_err_en_US, |
556 | lhs.AsFortran(), lhs.Rank(), numBounds); // C1018 |
557 | } |
558 | } |
559 | if (isBoundsRemapping && rhs.Rank() != 1 && |
560 | !evaluate::IsSimplyContiguous(rhs, context)) { |
561 | messages.Say("Pointer bounds remapping target must have rank 1 or be" |
562 | " simply contiguous"_err_en_US); // 10.2.2.3(9) |
563 | } |
564 | return isBoundsRemapping; |
565 | } |
566 | |
567 | bool CheckPointerAssignment(SemanticsContext &context, |
568 | const evaluate::Assignment &assignment, const Scope &scope) { |
569 | return CheckPointerAssignment(context, assignment.lhs, assignment.rhs, scope, |
570 | CheckPointerBounds(context.foldingContext(), assignment), |
571 | /*isAssumedRank=*/false); |
572 | } |
573 | |
574 | bool CheckPointerAssignment(SemanticsContext &context, const SomeExpr &lhs, |
575 | const SomeExpr &rhs, const Scope &scope, bool isBoundsRemapping, |
576 | bool isAssumedRank) { |
577 | const Symbol *pointer{GetLastSymbol(lhs)}; |
578 | if (!pointer) { |
579 | return false; // error was reported |
580 | } |
581 | PointerAssignmentChecker checker{context, scope, *pointer}; |
582 | const Symbol *base{GetFirstSymbol(lhs)}; |
583 | if (base) { |
584 | // 8.5.20(4) If an object has the VOLATILE attribute, then all of its |
585 | // subobjects also have the VOLATILE attribute. |
586 | checker.set_isVolatile(base->attrs().test(Attr::VOLATILE)); |
587 | } |
588 | checker.set_isBoundsRemapping(isBoundsRemapping); |
589 | checker.set_isAssumedRank(isAssumedRank); |
590 | bool lhsOk{checker.CheckLeftHandSide(lhs)}; |
591 | bool rhsOk{checker.Check(rhs)}; |
592 | return lhsOk && rhsOk; // don't short-circuit |
593 | } |
594 | |
595 | bool CheckStructConstructorPointerComponent(SemanticsContext &context, |
596 | const Symbol &lhs, const SomeExpr &rhs, const Scope &scope) { |
597 | return PointerAssignmentChecker{context, scope, lhs} |
598 | .set_pointerComponentLHS(&lhs) |
599 | .Check(rhs); |
600 | } |
601 | |
602 | bool CheckPointerAssignment(SemanticsContext &context, parser::CharBlock source, |
603 | const std::string &description, const DummyDataObject &lhs, |
604 | const SomeExpr &rhs, const Scope &scope, bool isAssumedRank, |
605 | bool isPointerActualArgument) { |
606 | return PointerAssignmentChecker{context, scope, source, description} |
607 | .set_lhsType(common::Clone(lhs.type)) |
608 | .set_isContiguous(lhs.attrs.test(DummyDataObject::Attr::Contiguous)) |
609 | .set_isVolatile(lhs.attrs.test(DummyDataObject::Attr::Volatile)) |
610 | .set_isAssumedRank(isAssumedRank) |
611 | .set_isRHSPointerActualArgument(isPointerActualArgument) |
612 | .Check(rhs); |
613 | } |
614 | |
615 | bool CheckInitialDataPointerTarget(SemanticsContext &context, |
616 | const SomeExpr &pointer, const SomeExpr &init, const Scope &scope) { |
617 | return evaluate::IsInitialDataTarget( |
618 | init, &context.foldingContext().messages()) && |
619 | CheckPointerAssignment(context, pointer, init, scope, |
620 | /*isBoundsRemapping=*/false, |
621 | /*isAssumedRank=*/false); |
622 | } |
623 | |
624 | } // namespace Fortran::semantics |
625 |
Definitions
- PointerAssignmentChecker
- PointerAssignmentChecker
- PointerAssignmentChecker
- set_lhsType
- set_isContiguous
- set_isVolatile
- set_isBoundsRemapping
- set_isAssumedRank
- set_pointerComponentLHS
- set_isRHSPointerActualArgument
- CharacterizeProcedure
- CheckLeftHandSide
- Check
- Check
- Check
- Check
- Check
- Check
- Check
- Check
- Check
- LhsOkForUnlimitedPoly
- CheckRanks
- Say
- Warn
- CheckPointerBounds
- CheckPointerAssignment
- CheckPointerAssignment
- CheckStructConstructorPointerComponent
- CheckPointerAssignment
Improve your Profiling and Debugging skills
Find out more