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