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
18namespace Fortran::semantics {
19
20class CriticalBodyEnforce {
21public:
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
54private:
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
65template <typename T>
66static 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
75static 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
85static 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 std::visit(CoindexedCheck, statOrErrmsg.u);
97}
98
99static 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
130static 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 } else if (!evaluate::IsCoarray(*expr)) { // C1604
137 context.Say(parser::FindSourceLocation(eventVar),
138 "The event-variable must be a coarray"_err_en_US);
139 }
140 }
141}
142
143void CoarrayChecker::Leave(const parser::ChangeTeamStmt &x) {
144 CheckNamesAreDistinct(std::get<std::list<parser::CoarrayAssociation>>(x.t));
145 CheckTeamType(context_, std::get<parser::TeamValue>(x.t));
146 CheckSyncStatList(context_, std::get<std::list<parser::StatOrErrmsg>>(x.t));
147}
148
149void CoarrayChecker::Leave(const parser::EndChangeTeamStmt &x) {
150 CheckSyncStatList(context_, std::get<std::list<parser::StatOrErrmsg>>(x.t));
151}
152
153void CoarrayChecker::Leave(const parser::SyncAllStmt &x) {
154 CheckSyncStatList(context_, x.v);
155}
156
157void CoarrayChecker::Leave(const parser::SyncImagesStmt &x) {
158 CheckSyncStatList(context_, std::get<std::list<parser::StatOrErrmsg>>(x.t));
159
160 const auto &imageSet{std::get<parser::SyncImagesStmt::ImageSet>(x.t)};
161 if (const auto *intExpr{std::get_if<parser::IntExpr>(&imageSet.u)}) {
162 if (const auto *expr{GetExpr(context_, *intExpr)}) {
163 if (expr->Rank() > 1) {
164 context_.Say(parser::FindSourceLocation(imageSet), // C1174
165 "An image-set that is an int-expr must be a scalar or a rank-one array"_err_en_US);
166 }
167 }
168 }
169}
170
171void CoarrayChecker::Leave(const parser::SyncMemoryStmt &x) {
172 CheckSyncStatList(context_, x.v);
173}
174
175void CoarrayChecker::Leave(const parser::SyncTeamStmt &x) {
176 CheckTeamType(context_, std::get<parser::TeamValue>(x.t));
177 CheckSyncStatList(context_, std::get<std::list<parser::StatOrErrmsg>>(x.t));
178}
179
180static void CheckEventWaitSpecList(SemanticsContext &context,
181 const std::list<parser::EventWaitSpec> &eventWaitSpecList) {
182 bool gotStat{false}, gotMsg{false}, gotUntil{false};
183 for (const parser::EventWaitSpec &eventWaitSpec : eventWaitSpecList) {
184 common::visit(
185 common::visitors{
186 [&](const parser::ScalarIntExpr &untilCount) {
187 if (gotUntil) {
188 context.Say( // C1178
189 "Until-spec in a event-wait-spec-list may not be repeated"_err_en_US);
190 }
191 gotUntil = true;
192 },
193 [&](const parser::StatOrErrmsg &statOrErrmsg) {
194 common::visit(
195 common::visitors{
196 [&](const parser::StatVariable &stat) {
197 if (gotStat) {
198 context.Say( // C1178
199 "A stat-variable in a event-wait-spec-list may not be repeated"_err_en_US);
200 }
201 gotStat = true;
202 },
203 [&](const parser::MsgVariable &var) {
204 WarnOnDeferredLengthCharacterScalar(context,
205 GetExpr(context, var),
206 var.v.thing.thing.GetSource(), "ERRMSG=");
207 if (gotMsg) {
208 context.Say( // C1178
209 "A errmsg-variable in a event-wait-spec-list may not be repeated"_err_en_US);
210 }
211 gotMsg = true;
212 },
213 },
214 statOrErrmsg.u);
215 CheckCoindexedStatOrErrmsg(
216 context, statOrErrmsg, "event-wait-spec-list");
217 },
218
219 },
220 eventWaitSpec.u);
221 }
222}
223
224void CoarrayChecker::Leave(const parser::NotifyWaitStmt &x) {
225 const auto &notifyVar{std::get<parser::Scalar<parser::Variable>>(x.t)};
226
227 if (const auto *expr{GetExpr(context_, notifyVar)}) {
228 if (ExtractCoarrayRef(expr)) {
229 context_.Say(parser::FindSourceLocation(notifyVar), // F2023 - C1178
230 "A notify-variable in a NOTIFY WAIT statement may not be a coindexed object"_err_en_US);
231 } else if (!IsNotifyType(evaluate::GetDerivedTypeSpec(
232 expr->GetType()))) { // F2023 - C1177
233 context_.Say(parser::FindSourceLocation(notifyVar),
234 "The notify-variable must be of type NOTIFY_TYPE from module ISO_FORTRAN_ENV"_err_en_US);
235 } else if (!evaluate::IsCoarray(*expr)) { // F2023 - C1612
236 context_.Say(parser::FindSourceLocation(notifyVar),
237 "The notify-variable must be a coarray"_err_en_US);
238 }
239 }
240
241 CheckEventWaitSpecList(
242 context_, std::get<std::list<parser::EventWaitSpec>>(x.t));
243}
244
245void CoarrayChecker::Leave(const parser::EventPostStmt &x) {
246 CheckSyncStatList(context_, std::get<std::list<parser::StatOrErrmsg>>(x.t));
247 CheckEventVariable(context_, std::get<parser::EventVariable>(x.t));
248}
249
250void CoarrayChecker::Leave(const parser::EventWaitStmt &x) {
251 const auto &eventVar{std::get<parser::EventVariable>(x.t)};
252
253 if (const auto *expr{GetExpr(context_, eventVar)}) {
254 if (ExtractCoarrayRef(expr)) {
255 context_.Say(parser::FindSourceLocation(eventVar), // C1177
256 "A event-variable in a EVENT WAIT statement may not be a coindexed object"_err_en_US);
257 } else {
258 CheckEventVariable(context_, eventVar);
259 }
260 }
261
262 CheckEventWaitSpecList(
263 context_, std::get<std::list<parser::EventWaitSpec>>(x.t));
264}
265
266void CoarrayChecker::Leave(const parser::UnlockStmt &x) {
267 CheckSyncStatList(context_, std::get<std::list<parser::StatOrErrmsg>>(x.t));
268}
269
270void CoarrayChecker::Leave(const parser::CriticalStmt &x) {
271 CheckSyncStatList(context_, std::get<std::list<parser::StatOrErrmsg>>(x.t));
272}
273
274void CoarrayChecker::Leave(const parser::ImageSelector &imageSelector) {
275 haveStat_ = false;
276 haveTeam_ = false;
277 haveTeamNumber_ = false;
278 for (const auto &imageSelectorSpec :
279 std::get<std::list<parser::ImageSelectorSpec>>(imageSelector.t)) {
280 if (const auto *team{
281 std::get_if<parser::TeamValue>(&imageSelectorSpec.u)}) {
282 if (haveTeam_) {
283 context_.Say(parser::FindSourceLocation(imageSelectorSpec), // C929
284 "TEAM value can only be specified once"_err_en_US);
285 }
286 CheckTeamType(context_, *team);
287 haveTeam_ = true;
288 }
289 if (const auto *stat{std::get_if<parser::ImageSelectorSpec::Stat>(
290 &imageSelectorSpec.u)}) {
291 if (haveStat_) {
292 context_.Say(parser::FindSourceLocation(imageSelectorSpec), // C929
293 "STAT variable can only be specified once"_err_en_US);
294 }
295 CheckTeamStat(context_, *stat);
296 haveStat_ = true;
297 }
298 if (std::get_if<parser::ImageSelectorSpec::Team_Number>(
299 &imageSelectorSpec.u)) {
300 if (haveTeamNumber_) {
301 context_.Say(parser::FindSourceLocation(imageSelectorSpec), // C929
302 "TEAM_NUMBER value can only be specified once"_err_en_US);
303 }
304 haveTeamNumber_ = true;
305 }
306 }
307 if (haveTeam_ && haveTeamNumber_) {
308 context_.Say(parser::FindSourceLocation(imageSelector), // C930
309 "Cannot specify both TEAM and TEAM_NUMBER"_err_en_US);
310 }
311}
312
313void CoarrayChecker::Leave(const parser::FormTeamStmt &x) {
314 CheckTeamType(context_, std::get<parser::TeamVariable>(x.t));
315}
316
317void CoarrayChecker::Enter(const parser::CriticalConstruct &x) {
318 auto &criticalStmt{std::get<parser::Statement<parser::CriticalStmt>>(x.t)};
319
320 const parser::Block &block{std::get<parser::Block>(x.t)};
321 CriticalBodyEnforce criticalBodyEnforce{context_, criticalStmt.source};
322 parser::Walk(block, criticalBodyEnforce);
323
324 // C1119
325 LabelEnforce criticalLabelEnforce{
326 context_, criticalBodyEnforce.labels(), criticalStmt.source, "CRITICAL"};
327 parser::Walk(block, criticalLabelEnforce);
328}
329
330// Check that coarray names and selector names are all distinct.
331void CoarrayChecker::CheckNamesAreDistinct(
332 const std::list<parser::CoarrayAssociation> &list) {
333 std::set<parser::CharBlock> names;
334 auto getPreviousUse{
335 [&](const parser::Name &name) -> const parser::CharBlock * {
336 auto pair{names.insert(name.source)};
337 return !pair.second ? &*pair.first : nullptr;
338 }};
339 for (const auto &assoc : list) {
340 const auto &decl{std::get<parser::CodimensionDecl>(assoc.t)};
341 const auto &selector{std::get<parser::Selector>(assoc.t)};
342 const auto &declName{std::get<parser::Name>(decl.t)};
343 if (context_.HasError(declName)) {
344 continue; // already reported an error about this name
345 }
346 if (auto *prev{getPreviousUse(declName)}) {
347 Say2(declName.source, // C1113
348 "Coarray '%s' was already used as a selector or coarray in this statement"_err_en_US,
349 *prev, "Previous use of '%s'"_en_US);
350 }
351 // ResolveNames verified the selector is a simple name
352 const parser::Name *name{parser::Unwrap<parser::Name>(selector)};
353 if (name) {
354 if (auto *prev{getPreviousUse(*name)}) {
355 Say2(name->source, // C1113, C1115
356 "Selector '%s' was already used as a selector or coarray in this statement"_err_en_US,
357 *prev, "Previous use of '%s'"_en_US);
358 }
359 }
360 }
361}
362
363void CoarrayChecker::Say2(const parser::CharBlock &name1,
364 parser::MessageFixedText &&msg1, const parser::CharBlock &name2,
365 parser::MessageFixedText &&msg2) {
366 context_.Say(name1, std::move(msg1), name1)
367 .Attach(name2, std::move(msg2), name2);
368}
369} // namespace Fortran::semantics
370

source code of flang/lib/Semantics/check-coarray.cpp