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