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