xref: /llvm-project/flang/lib/Semantics/check-coarray.cpp (revision 2625510ef8094457413661ef0ce2651844f584d2) 
1 //===-- lib/Semantics/check-coarray.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 "check-coarray.h"
10 #include "flang/Common/indirection.h"
11 #include "flang/Evaluate/expression.h"
12 #include "flang/Parser/message.h"
13 #include "flang/Parser/parse-tree.h"
14 #include "flang/Parser/tools.h"
15 #include "flang/Semantics/expression.h"
16 #include "flang/Semantics/tools.h"
17 
18 namespace Fortran::semantics {
19 
20 class CriticalBodyEnforce {
21 public:
22   CriticalBodyEnforce(
23       SemanticsContext &context, parser::CharBlock criticalSourcePosition)
24       : context_{context}, criticalSourcePosition_{criticalSourcePosition} {}
25   std::set<parser::Label> labels() { return labels_; }
26   template <typename T> bool Pre(const T &) { return true; }
27   template <typename T> void Post(const T &) {}
28 
29   template <typename T> bool Pre(const parser::Statement<T> &statement) {
30     currentStatementSourcePosition_ = statement.source;
31     if (statement.label.has_value()) {
32       labels_.insert(*statement.label);
33     }
34     return true;
35   }
36 
37   // C1118
38   void Post(const parser::ReturnStmt &) {
39     context_
40         .Say(currentStatementSourcePosition_,
41             "RETURN statement is not allowed in a CRITICAL construct"_err_en_US)
42         .Attach(criticalSourcePosition_, GetEnclosingMsg());
43   }
44   void Post(const parser::ExecutableConstruct &construct) {
45     if (IsImageControlStmt(construct)) {
46       context_
47           .Say(currentStatementSourcePosition_,
48               "An image control statement is not allowed in a CRITICAL"
49               " construct"_err_en_US)
50           .Attach(criticalSourcePosition_, GetEnclosingMsg());
51     }
52   }
53 
54 private:
55   parser::MessageFixedText GetEnclosingMsg() {
56     return "Enclosing CRITICAL statement"_en_US;
57   }
58 
59   SemanticsContext &context_;
60   std::set<parser::Label> labels_;
61   parser::CharBlock currentStatementSourcePosition_;
62   parser::CharBlock criticalSourcePosition_;
63 };
64 
65 template <typename T>
66 static void CheckTeamType(SemanticsContext &context, const T &x) {
67   if (const auto *expr{GetExpr(context, x)}) {
68     if (!IsTeamType(evaluate::GetDerivedTypeSpec(expr->GetType()))) {
69       context.Say(parser::FindSourceLocation(x), // C1114
70           "Team value must be of type TEAM_TYPE from module ISO_FORTRAN_ENV"_err_en_US);
71     }
72   }
73 }
74 
75 static void CheckTeamStat(
76     SemanticsContext &context, const parser::ImageSelectorSpec::Stat &stat) {
77   const parser::Variable &var{stat.v.thing.thing.value()};
78   if (parser::GetCoindexedNamedObject(var)) {
79     context.Say(parser::FindSourceLocation(var), // C931
80         "Image selector STAT variable must not be a coindexed "
81         "object"_err_en_US);
82   }
83 }
84 
85 static void CheckCoindexedStatOrErrmsg(SemanticsContext &context,
86     const parser::StatOrErrmsg &statOrErrmsg, const std::string &listName) {
87   auto CoindexedCheck{[&](const auto &statOrErrmsg) {
88     if (const auto *expr{GetExpr(context, statOrErrmsg)}) {
89       if (ExtractCoarrayRef(expr)) {
90         context.Say(parser::FindSourceLocation(statOrErrmsg), // C1173
91             "The stat-variable or errmsg-variable in a %s may not be a coindexed object"_err_en_US,
92             listName);
93       }
94     }
95   }};
96   Fortran::common::visit(CoindexedCheck, statOrErrmsg.u);
97 }
98 
99 static void CheckSyncStatList(
100     SemanticsContext &context, const std::list<parser::StatOrErrmsg> &list) {
101   bool gotStat{false}, gotMsg{false};
102 
103   for (const parser::StatOrErrmsg &statOrErrmsg : list) {
104     common::visit(
105         common::visitors{
106             [&](const parser::StatVariable &stat) {
107               if (gotStat) {
108                 context.Say( // C1172
109                     "The stat-variable in a sync-stat-list may not be repeated"_err_en_US);
110               }
111               gotStat = true;
112             },
113             [&](const parser::MsgVariable &var) {
114               WarnOnDeferredLengthCharacterScalar(context,
115                   GetExpr(context, var), var.v.thing.thing.GetSource(),
116                   "ERRMSG=");
117               if (gotMsg) {
118                 context.Say( // C1172
119                     "The errmsg-variable in a sync-stat-list may not be repeated"_err_en_US);
120               }
121               gotMsg = true;
122             },
123         },
124         statOrErrmsg.u);
125 
126     CheckCoindexedStatOrErrmsg(context, statOrErrmsg, "sync-stat-list");
127   }
128 }
129 
130 static void CheckEventVariable(
131     SemanticsContext &context, const parser::EventVariable &eventVar) {
132   if (const auto *expr{GetExpr(context, eventVar)}) {
133     if (!IsEventType(evaluate::GetDerivedTypeSpec(expr->GetType()))) { // C1176
134       context.Say(parser::FindSourceLocation(eventVar),
135           "The event-variable must be of type EVENT_TYPE from module ISO_FORTRAN_ENV"_err_en_US);
136     }
137   }
138 }
139 
140 void CoarrayChecker::Leave(const parser::ChangeTeamStmt &x) {
141   CheckNamesAreDistinct(std::get<std::list<parser::CoarrayAssociation>>(x.t));
142   CheckTeamType(context_, std::get<parser::TeamValue>(x.t));
143   CheckSyncStatList(context_, std::get<std::list<parser::StatOrErrmsg>>(x.t));
144 }
145 
146 void CoarrayChecker::Leave(const parser::EndChangeTeamStmt &x) {
147   CheckSyncStatList(context_, std::get<std::list<parser::StatOrErrmsg>>(x.t));
148 }
149 
150 void CoarrayChecker::Leave(const parser::SyncAllStmt &x) {
151   CheckSyncStatList(context_, x.v);
152 }
153 
154 void CoarrayChecker::Leave(const parser::SyncImagesStmt &x) {
155   CheckSyncStatList(context_, std::get<std::list<parser::StatOrErrmsg>>(x.t));
156 
157   const auto &imageSet{std::get<parser::SyncImagesStmt::ImageSet>(x.t)};
158   if (const auto *intExpr{std::get_if<parser::IntExpr>(&imageSet.u)}) {
159     if (const auto *expr{GetExpr(context_, *intExpr)}) {
160       if (expr->Rank() > 1) {
161         context_.Say(parser::FindSourceLocation(imageSet), // C1174
162             "An image-set that is an int-expr must be a scalar or a rank-one array"_err_en_US);
163       }
164     }
165   }
166 }
167 
168 void CoarrayChecker::Leave(const parser::SyncMemoryStmt &x) {
169   CheckSyncStatList(context_, x.v);
170 }
171 
172 void CoarrayChecker::Leave(const parser::SyncTeamStmt &x) {
173   CheckTeamType(context_, std::get<parser::TeamValue>(x.t));
174   CheckSyncStatList(context_, std::get<std::list<parser::StatOrErrmsg>>(x.t));
175 }
176 
177 static void CheckEventWaitSpecList(SemanticsContext &context,
178     const std::list<parser::EventWaitSpec> &eventWaitSpecList) {
179   bool gotStat{false}, gotMsg{false}, gotUntil{false};
180   for (const parser::EventWaitSpec &eventWaitSpec : eventWaitSpecList) {
181     common::visit(
182         common::visitors{
183             [&](const parser::ScalarIntExpr &untilCount) {
184               if (gotUntil) {
185                 context.Say( // C1178
186                     "Until-spec in a event-wait-spec-list may not be repeated"_err_en_US);
187               }
188               gotUntil = true;
189             },
190             [&](const parser::StatOrErrmsg &statOrErrmsg) {
191               common::visit(
192                   common::visitors{
193                       [&](const parser::StatVariable &stat) {
194                         if (gotStat) {
195                           context.Say( // C1178
196                               "A stat-variable in a event-wait-spec-list may not be repeated"_err_en_US);
197                         }
198                         gotStat = true;
199                       },
200                       [&](const parser::MsgVariable &var) {
201                         WarnOnDeferredLengthCharacterScalar(context,
202                             GetExpr(context, var),
203                             var.v.thing.thing.GetSource(), "ERRMSG=");
204                         if (gotMsg) {
205                           context.Say( // C1178
206                               "A errmsg-variable in a event-wait-spec-list may not be repeated"_err_en_US);
207                         }
208                         gotMsg = true;
209                       },
210                   },
211                   statOrErrmsg.u);
212               CheckCoindexedStatOrErrmsg(
213                   context, statOrErrmsg, "event-wait-spec-list");
214             },
215 
216         },
217         eventWaitSpec.u);
218   }
219 }
220 
221 void CoarrayChecker::Leave(const parser::NotifyWaitStmt &x) {
222   const auto &notifyVar{std::get<parser::Scalar<parser::Variable>>(x.t)};
223 
224   if (const auto *expr{GetExpr(context_, notifyVar)}) {
225     if (ExtractCoarrayRef(expr)) {
226       context_.Say(parser::FindSourceLocation(notifyVar), // F2023 - C1178
227           "A notify-variable in a NOTIFY WAIT statement may not be a coindexed object"_err_en_US);
228     } else if (!IsNotifyType(evaluate::GetDerivedTypeSpec(
229                    expr->GetType()))) { // F2023 - C1177
230       context_.Say(parser::FindSourceLocation(notifyVar),
231           "The notify-variable must be of type NOTIFY_TYPE from module ISO_FORTRAN_ENV"_err_en_US);
232     } else if (!evaluate::IsCoarray(*expr)) { // F2023 - C1612
233       context_.Say(parser::FindSourceLocation(notifyVar),
234           "The notify-variable must be a coarray"_err_en_US);
235     }
236   }
237 
238   CheckEventWaitSpecList(
239       context_, std::get<std::list<parser::EventWaitSpec>>(x.t));
240 }
241 
242 void CoarrayChecker::Leave(const parser::EventPostStmt &x) {
243   CheckSyncStatList(context_, std::get<std::list<parser::StatOrErrmsg>>(x.t));
244   CheckEventVariable(context_, std::get<parser::EventVariable>(x.t));
245 }
246 
247 void CoarrayChecker::Leave(const parser::EventWaitStmt &x) {
248   const auto &eventVar{std::get<parser::EventVariable>(x.t)};
249 
250   if (const auto *expr{GetExpr(context_, eventVar)}) {
251     if (ExtractCoarrayRef(expr)) {
252       context_.Say(parser::FindSourceLocation(eventVar), // C1177
253           "A event-variable in a EVENT WAIT statement may not be a coindexed object"_err_en_US);
254     } else {
255       CheckEventVariable(context_, eventVar);
256     }
257   }
258 
259   CheckEventWaitSpecList(
260       context_, std::get<std::list<parser::EventWaitSpec>>(x.t));
261 }
262 
263 void CoarrayChecker::Leave(const parser::UnlockStmt &x) {
264   CheckSyncStatList(context_, std::get<std::list<parser::StatOrErrmsg>>(x.t));
265 }
266 
267 void CoarrayChecker::Leave(const parser::CriticalStmt &x) {
268   CheckSyncStatList(context_, std::get<std::list<parser::StatOrErrmsg>>(x.t));
269 }
270 
271 void CoarrayChecker::Leave(const parser::ImageSelector &imageSelector) {
272   haveStat_ = false;
273   haveTeam_ = false;
274   haveTeamNumber_ = false;
275   for (const auto &imageSelectorSpec :
276       std::get<std::list<parser::ImageSelectorSpec>>(imageSelector.t)) {
277     if (const auto *team{
278             std::get_if<parser::TeamValue>(&imageSelectorSpec.u)}) {
279       if (haveTeam_) {
280         context_.Say(parser::FindSourceLocation(imageSelectorSpec), // C929
281             "TEAM value can only be specified once"_err_en_US);
282       }
283       CheckTeamType(context_, *team);
284       haveTeam_ = true;
285     }
286     if (const auto *stat{std::get_if<parser::ImageSelectorSpec::Stat>(
287             &imageSelectorSpec.u)}) {
288       if (haveStat_) {
289         context_.Say(parser::FindSourceLocation(imageSelectorSpec), // C929
290             "STAT variable can only be specified once"_err_en_US);
291       }
292       CheckTeamStat(context_, *stat);
293       haveStat_ = true;
294     }
295     if (std::get_if<parser::ImageSelectorSpec::Team_Number>(
296             &imageSelectorSpec.u)) {
297       if (haveTeamNumber_) {
298         context_.Say(parser::FindSourceLocation(imageSelectorSpec), // C929
299             "TEAM_NUMBER value can only be specified once"_err_en_US);
300       }
301       haveTeamNumber_ = true;
302     }
303   }
304   if (haveTeam_ && haveTeamNumber_) {
305     context_.Say(parser::FindSourceLocation(imageSelector), // C930
306         "Cannot specify both TEAM and TEAM_NUMBER"_err_en_US);
307   }
308 }
309 
310 void CoarrayChecker::Leave(const parser::FormTeamStmt &x) {
311   CheckTeamType(context_, std::get<parser::TeamVariable>(x.t));
312 }
313 
314 void CoarrayChecker::Enter(const parser::CriticalConstruct &x) {
315   auto &criticalStmt{std::get<parser::Statement<parser::CriticalStmt>>(x.t)};
316 
317   const parser::Block &block{std::get<parser::Block>(x.t)};
318   CriticalBodyEnforce criticalBodyEnforce{context_, criticalStmt.source};
319   parser::Walk(block, criticalBodyEnforce);
320 
321   // C1119
322   LabelEnforce criticalLabelEnforce{
323       context_, criticalBodyEnforce.labels(), criticalStmt.source, "CRITICAL"};
324   parser::Walk(block, criticalLabelEnforce);
325 }
326 
327 // Check that coarray names and selector names are all distinct.
328 void CoarrayChecker::CheckNamesAreDistinct(
329     const std::list<parser::CoarrayAssociation> &list) {
330   std::set<parser::CharBlock> names;
331   auto getPreviousUse{
332       [&](const parser::Name &name) -> const parser::CharBlock * {
333         auto pair{names.insert(name.source)};
334         return !pair.second ? &*pair.first : nullptr;
335       }};
336   for (const auto &assoc : list) {
337     const auto &decl{std::get<parser::CodimensionDecl>(assoc.t)};
338     const auto &selector{std::get<parser::Selector>(assoc.t)};
339     const auto &declName{std::get<parser::Name>(decl.t)};
340     if (context_.HasError(declName)) {
341       continue; // already reported an error about this name
342     }
343     if (auto *prev{getPreviousUse(declName)}) {
344       Say2(declName.source, // C1113
345           "Coarray '%s' was already used as a selector or coarray in this statement"_err_en_US,
346           *prev, "Previous use of '%s'"_en_US);
347     }
348     // ResolveNames verified the selector is a simple name
349     const parser::Name *name{parser::Unwrap<parser::Name>(selector)};
350     if (name) {
351       if (auto *prev{getPreviousUse(*name)}) {
352         Say2(name->source, // C1113, C1115
353             "Selector '%s' was already used as a selector or coarray in this statement"_err_en_US,
354             *prev, "Previous use of '%s'"_en_US);
355       }
356     }
357   }
358 }
359 
360 void CoarrayChecker::Say2(const parser::CharBlock &name1,
361     parser::MessageFixedText &&msg1, const parser::CharBlock &name2,
362     parser::MessageFixedText &&msg2) {
363   context_.Say(name1, std::move(msg1), name1)
364       .Attach(name2, std::move(msg2), name2);
365 }
366 } // namespace Fortran::semantics
367